mingw-ocaml/0000755000175000017500000000000012124403242012364 5ustar tootstootsmingw-ocaml/LICENSE0000644000175000017500000002505512124403240013376 0ustar tootstootsUpstream Authors: * OCaml authors are: Xavier Leroy, Damien Doligez, Jacques Garrigue, Nicolas Pouillard, Pierre Weis, Jérôme Vouillon, Maxence Guesdon, Alain Frisch * Findlib authors is: Gerd Stolpmann * Flexdll author is: Alain Frisch Most of the original patch for mingw-ocaml have been contributed by Richard W.M. Jones. License and copyright, per project: ----- FlexDLL ------ Copyright: Copyright 2007 Institut National de Recherche en Informatique et en Automatique. License: This software is provided 'as-is', without any express or implied warranty. In no event will the authors be held liable for any damages arising from the use of this software. Permission is granted to anyone to use this software for any purpose, including commercial applications, and to alter it and redistribute it freely, subject to the following restrictions: 1. The origin of this software must not be misrepresented; you must not claim that you wrote the original software. If you use this software in a product, an acknowledgment in the product documentation would be appreciated but is not required. 2. Altered source versions must be plainly marked as such, and must not be misrepresented as being the original software. 3. This notice may not be removed or altered from any source distribution. ----- OCaml ------ Files: * Copyright: © 1996-2008 Institut National de Recherche en Informatique et en Automatique License: QPL-1 | LGPL-2 | other Files: otherlibs/labltk/* Copyright: © 1999-2002 Institut National de Recherche en Informatique et en Automatique and Kyoto University License: LGPL-2 | other Files: emacs/* Copyright: © 1988-1991 Free Software Foundation © 1996-1998 Institut National de Recherche en Informatique et en Automatique © 1996 Ian T Zimmerman License: GPL-2 Files: debian/* Copyright: © 2001-2009 Debian OCaml Maintainers License: LGPL-2 ---------------------------------------------------------------------- In the following, "the Library" refers to all files marked "Copyright INRIA" in the following directories and their sub-directories: asmrun, byterun, camlp4, config, otherlibs, stdlib, win32caml and "the Compiler" refers to all files marked "Copyright INRIA" in the following directories and their sub-directories: asmcomp, boot, bytecomp, debugger, driver, lex, ocamldoc, parsing, tools, toplevel, typing, utils, yacc and the "emacs bindings" refer to all files marked "Copyright INRIA" in the following directory: emacs The Compiler is distributed under the terms of the Q Public License version 1.0 with a change to choice of law (included below). The Library is distributed under the terms of the GNU Library General Public License version 2 (found in /usr/share/common-licenses/LGPL-2 on debian systems). The emacs bindings are distributed under the terms of the GNU General Public License version 2 (found in /usr/share/common-licenses/GPL-2 on debian systems). As a special exception to the Q Public Licence, you may develop application programs, reusable components and other software items that link with the original or modified versions of the Compiler and are not made available to the general public, without any of the additional requirements listed in clause 6c of the Q Public licence. As a special exception to the GNU Library General Public License, you may link, statically or dynamically, a "work that uses the Library" with a publicly distributed version of the Library to produce an executable file containing portions of the Library, and distribute that executable file under terms of your choice, without any of the additional requirements listed in clause 6 of the GNU Library General Public License. By "a publicly distributed version of the Library", we mean either the unmodified Library as distributed by INRIA, or a modified version of the Library that is distributed under the conditions defined in clause 3 of the GNU Library General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Library General Public License. ---------------------------------------------------------------------- THE Q PUBLIC LICENSE version 1.0 Copyright (C) 1999 Troll Tech AS, Norway. Everyone is permitted to copy and distribute this license document. The intent of this license is to establish freedom to share and change the software regulated by this license under the open source model. This license applies to any software containing a notice placed by the copyright holder saying that it may be distributed under the terms of the Q Public License version 1.0. Such software is herein referred to as the Software. This license covers modification and distribution of the Software, use of third-party application programs based on the Software, and development of free software which uses the Software. Granted Rights 1. You are granted the non-exclusive rights set forth in this license provided you agree to and comply with any and all conditions in this license. Whole or partial distribution of the Software, or software items that link with the Software, in any form signifies acceptance of this license. 2. You may copy and distribute the Software in unmodified form provided that the entire package, including - but not restricted to - copyright, trademark notices and disclaimers, as released by the initial developer of the Software, is distributed. 3. You may make modifications to the Software and distribute your modifications, in a form that is separate from the Software, such as patches. The following restrictions apply to modifications: a. Modifications must not alter or remove any copyright notices in the Software. b. When modifications to the Software are released under this license, a non-exclusive royalty-free right is granted to the initial developer of the Software to distribute your modification in future versions of the Software provided such versions remain available under these terms in addition to any other license(s) of the initial developer. 4. You may distribute machine-executable forms of the Software or machine-executable forms of modified versions of the Software, provided that you meet these restrictions: a. You must include this license document in the distribution. b. You must ensure that all recipients of the machine-executable forms are also able to receive the complete machine-readable source code to the distributed Software, including all modifications, without any charge beyond the costs of data transfer, and place prominent notices in the distribution explaining this. c. You must ensure that all modifications included in the machine-executable forms are available under the terms of this license. 5. You may use the original or modified versions of the Software to compile, link and run application programs legally developed by you or by others. 6. You may develop application programs, reusable components and other software items that link with the original or modified versions of the Software. These items, when distributed, are subject to the following requirements: a. You must ensure that all recipients of machine-executable forms of these items are also able to receive and use the complete machine-readable source code to the items without any charge beyond the costs of data transfer. b. You must explicitly license all recipients of your items to use and re-distribute original and modified versions of the items in both machine-executable and source code forms. The recipients must be able to do so without any charges whatsoever, and they must be able to re-distribute to anyone they choose. c. If the items are not available to the general public, and the initial developer of the Software requests a copy of the items, then you must supply one. Limitations of Liability In no event shall the initial developers or copyright holders be liable for any damages whatsoever, including - but not restricted to - lost revenue or profits or other direct, indirect, special, incidental or consequential damages, even if they have been advised of the possibility of such damages, except to the extent invariable law, if any, provides otherwise. No Warranty The Software and this license document are provided AS IS with NO WARRANTY OF ANY KIND, INCLUDING THE WARRANTY OF DESIGN, MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. Choice of Law This license is governed by the Laws of France. ----- Findlib ------ Files: * Copyright: © 1999-2009 Gerd Stolpmann License: other Copyright 1999 by Gerd Stolpmann The package "findlib" is copyright by Gerd Stolpmann. Permission is hereby granted, free of charge, to any person obtaining a copy of this document and the "findlib" software (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software 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 Software. The Software 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 Gerd Stolpmann 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 Software or the use or other dealings in the software. Files: src/findlib/num_top* Copyright: © 2003 Stefano Zacchiroli License: LGPL-2.1+ This 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; either version 2.1 of the License, or (at your option) any later version. On Debian systems, the complete text of the GNU Lesser General Public License can be found in `/usr/share/common-licenses/LGPL-2.1'. mingw-ocaml/Makefile0000644000175000017500000002710412124403240014026 0ustar tootstoots.PHONY: all dist clean patch flexdll mingw-ocaml findlib binary install MINGW_HOST := i686-w64-mingw32 FLEXDLL_DIR := flexdll OCAML_DIR := ocaml FINDLIB_DIR := findlib OTHER_LIBS := win32unix str num dynlink bigarray systhreads win32graph BUILD_DIR := build BINARY_DIR := $(CURDIR)/binary INSTALL_DIR := # install at root INSTALL_PREFIX := /usr PATH := $(PATH):$(CURDIR)/$(BUILD_DIR)/$(FLEXDLL_DIR) ifeq ($(MINGW_HOST),i686-w64-mingw32) BUILD_CC := gcc -m32 ARCH := i386 MINGW_SYSTEM := mingw else BUILD_CC := gcc ARCH := amd64 MINGW_SYSTEM := mingw64 endif DISTFILES := LICENSE Makefile README files findlib flexdll ocaml patches.in all: binary $(BUILD_DIR): mkdir -p $(BUILD_DIR) cp -rf $(FLEXDLL_DIR) $(OCAML_DIR) $(FINDLIB_DIR) $(BUILD_DIR) patches: mkdir -p patches find patches.in | grep '.patch' | while read i; do \ sed -e 's#@mingw_host@#$(MINGW_HOST)#g' < $$i > \ `echo $$i | sed -e 's#patches.in#patches#'`; \ done cp patches.in/series patches patch: stamp-quilt-patches stamp-quilt-patches: patches $(BUILD_DIR) quilt push -a touch stamp-quilt-patches flexdll: stamp-build-flexdll stamp-build-flexdll: stamp-quilt-patches cd $(BUILD_DIR)/$(FLEXDLL_DIR) && make flexlink.exe build_mingw build_mingw64 rm -f $(BUILD_DIR)/$(FLEXDLL_DIR)/flexlink ln -s flexlink.exe $(BUILD_DIR)/$(FLEXDLL_DIR)/flexlink touch stamp-build-flexdll mingw-ocaml: stamp-binary-mingw-ocaml stamp-build-ocamlcore: stamp-quilt-patches # Build native ocamlrun and ocamlc which contain the # filename-win32-dirsep patch. # # Note that we must build a 32 bit compiler, even on 64 bit build # architectures, because this compiler will try to do strength # reduction optimizations using its internal int type, and that must # match Windows' int type. (That's what -cc and -host are for). cd $(BUILD_DIR)/$(OCAML_DIR) && ./configure \ -prefix $(INSTALL_PREFIX)/$(MINGW_HOST) \ -bindir $(INSTALL_PREFIX)/$(MINGW_HOST)/bin \ -libdir $(INSTALL_PREFIX)/$(MINGW_HOST)/lib/ocaml \ -no-tk \ -cc "$(BUILD_CC)" -host $(MINGW_HOST) -verbose cd $(BUILD_DIR)/$(OCAML_DIR) && make world # Now move the working ocamlrun, ocamlc into the boot/ directory, # overwriting the binary versions which ship with the compiler with # ones that contain the filename-win32-dirsep patch. cd $(BUILD_DIR)/$(OCAML_DIR) && make coreboot touch stamp-build-ocamlcore stamp-patch-mingw-include: stamp-build-ocamlcore # Now patch utils/clflags.ml to hardcode mingw-specific include. patch -p1 < patches/ocaml-hardcode_mingw_include.patch touch stamp-patch-mingw-include stamp-prepare-cross-build: stamp-patch-mingw-include # Replace the compiler configuration (config/{s.h,m.h,Makefile}) # with ones as they would be on a 32 bit Windows system. cp -f $(BUILD_DIR)/$(OCAML_DIR)/config/m-nt.h $(BUILD_DIR)/$(OCAML_DIR)/config/m.h cp -f $(BUILD_DIR)/$(OCAML_DIR)/config/s-nt.h $(BUILD_DIR)/$(OCAML_DIR)/config/s.h # config/Makefile is a custom one which we supply. rm -f $(BUILD_DIR)/$(OCAML_DIR)/config/Makefile sed \ -e "s,@prefix@,/usr/$(MINGW_HOST),g" \ -e "s,@bindir@,/usr/$(MINGW_HOST)/bin,g" \ -e "s,@libdir@,/usr/$(MINGW_HOST)/lib/ocaml,g" \ -e "s,@otherlibraries@,$(OTHER_LIBS),g" \ -e "s,@arch@,$(ARCH),g" \ -e "s,@mingw_system@,$(MINGW_SYSTEM),g" \ -e "s,@flexdir@,$(CURDIR)/$(BUILD_DIR)/$(FLEXDLL_DIR),g" \ -e "s,@flexlink_mingw_chain@,$(MINGW_SYSTEM),g" \ -e "s,@mingw_host@,$(MINGW_HOST),g" \ < files/ocaml//Makefile-mingw.in > $(BUILD_DIR)/$(OCAML_DIR)/config/Makefile # We're going to build in otherlibs/win32unix and otherlibs/win32graph # directories, but since they would normally only be built under # Windows, they only have the Makefile.nt files. Just symlink # Makefile -> Makefile.nt for these cases. for d in $(BUILD_DIR)/$(OCAML_DIR)/otherlibs/win32unix \ $(BUILD_DIR)/$(OCAML_DIR)/otherlibs/win32graph \ $(BUILD_DIR)/$(OCAML_DIR)/otherlibs/bigarray \ $(BUILD_DIR)/$(OCAML_DIR)/otherlibs/systhreads; do \ ln -sf Makefile.nt $$d/Makefile; \ done # Now clean the temporary files from the previous build. This # will also cause asmcomp/arch.ml (etc) to be linked to the 32 bit # i386 versions, essentially causing ocamlopt to use the Win/i386 code # generator. cd $(BUILD_DIR)/$(OCAML_DIR) && make partialclean # We need to remove any .o object for make sure they are # recompiled later.. cd $(BUILD_DIR)/$(OCAML_DIR) && rm byterun/*.o # Finally, make a stamp file to tell myocamlbuild to # build for win32 touch $(BUILD_DIR)/$(OCAML_DIR)/stamp-build-mingw-win32 touch stamp-prepare-cross-build stamp-build-mingw-ocaml: stamp-build-flexdll stamp-prepare-cross-build # Just rebuild some small bits that we need for the following # 'make opt' to work. Note that 'make all' fails here. cd $(BUILD_DIR)/$(OCAML_DIR) && make -C byterun libcamlrun.a cd $(BUILD_DIR)/$(OCAML_DIR) && make ocaml ocamlc cd $(BUILD_DIR)/$(OCAML_DIR) && make -C stdlib cd $(BUILD_DIR)/$(OCAML_DIR) && make -C tools ocamlmklib cd $(BUILD_DIR)/$(OCAML_DIR) && make opt # Now build otherlibs for ocamlopt cd $(BUILD_DIR)/$(OCAML_DIR) && \ for i in $(OTHER_LIBS); do \ make -C otherlibs/$$i clean; \ PATH=$(CURDIR)/$(BUILD_DIR)/$(FLEXDLL_DIR):$(PATH) \ make -C otherlibs/$$i all; \ PATH=$(CURDIR)/$(BUILD_DIR)/$(FLEXDLL_DIR):$(PATH) \ make -C otherlibs/$$i allopt; \ done # Finally build all tools cd $(BUILD_DIR)/$(OCAML_DIR) && make -C tools touch stamp-build-mingw-ocaml stamp-binary-mingw-ocaml: stamp-build-mingw-ocaml mkdir -p $(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/lib/ocaml/threads mkdir -p $(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/lib/ocaml/stublibs mkdir -p $(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/bin mkdir -p $(BINARY_DIR)$(INSTALL_PREFIX)/bin mkdir -p $(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/lib/ocaml/compiler-libs cd $(BUILD_DIR)/$(OCAML_DIR) && make BINDIR=$(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/bin \ LIBDIR=$(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/lib/ocaml \ -C byterun install cd $(BUILD_DIR)/$(OCAML_DIR) && make BINDIR=$(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/bin \ LIBDIR=$(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/lib/ocaml \ -C stdlib install cd $(BUILD_DIR)/$(OCAML_DIR) && \ for i in $(OTHER_LIBS); do \ make BINDIR=$(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/bin \ LIBDIR=$(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/lib/ocaml \ -C otherlibs/$$i install; \ done cd $(BUILD_DIR)/$(OCAML_DIR) && make BINDIR=$(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/bin \ LIBDIR=$(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/lib/ocaml \ -C tools install cd $(BUILD_DIR)/$(OCAML_DIR) && make BINDIR=$(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/bin \ LIBDIR=$(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/lib/ocaml \ installopt cd $(BUILD_DIR)/$(OCAML_DIR) && install -m 0755 ocamlc $(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/bin cd $(BUILD_DIR)/$(OCAML_DIR) && cp \ toplevel/topstart.cmo \ typing/outcometree.cmi typing/outcometree.mli \ toplevel/toploop.cmi toplevel/toploop.mli \ toplevel/topdirs.cmi toplevel/topdirs.mli \ toplevel/topmain.cmi toplevel/topmain.mli \ $(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/lib/ocaml # Rename all the binaries to target-binary for f in ocamlc ocamlcp ocamlrun ocamldep ocamlmklib ocamlmktop ocamlopt ocamlprof; do \ mv $(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/bin/$$f $(BINARY_DIR)$(INSTALL_PREFIX)/bin/$(MINGW_HOST)-$$f; \ done # We do not need this. rm -rf $(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/lib/ocaml/compiler-libs touch stamp-binary-mingw-ocaml findlib: stamp-build-findlib stamp-build-findlib: stamp-binary-mingw-ocaml cd $(BUILD_DIR)/$(FINDLIB_DIR)/tools/extract_args && make $(BUILD_DIR)/$(FINDLIB_DIR)/tools/extract_args/extract_args \ -o $(BUILD_DIR)/$(FINDLIB_DIR)/src/findlib/ocaml_args.ml \ $(BINARY_DIR)$(INSTALL_PREFIX)/bin/$(MINGW_HOST)-ocamlc \ $(BINARY_DIR)$(INSTALL_PREFIX)/bin/$(MINGW_HOST)-ocamlcp \ $(BINARY_DIR)$(INSTALL_PREFIX)/bin/$(MINGW_HOST)-ocamlmktop \ $(BINARY_DIR)$(INSTALL_PREFIX)/bin/$(MINGW_HOST)-ocamlopt \ $(BINARY_DIR)$(INSTALL_PREFIX)/bin/$(MINGW_HOST)-ocamldep cd $(BUILD_DIR)/$(FINDLIB_DIR) && ./configure \ -config /etc/$(MINGW_HOST)-ocamlfind.conf \ -bindir $(INSTALL_PREFIX)/$(MINGW_HOST)/bin \ -sitelib $(INSTALL_PREFIX)/$(MINGW_HOST)/lib/ocaml \ -mandir $(INSTALL_PREFIX)/share/man \ -with-toolbox cd $(BUILD_DIR)/$(FINDLIB_DIR) && make all cd $(BUILD_DIR)/$(FINDLIB_DIR) && make opt touch stamp-build-findlib binary: stamp-binary-all stamp-binary-all: stamp-build-findlib # Install findlib # Create this dir to please install.. mkdir -p $(BINARY_DIR)$(INSTALL_PREFIX)/lib/ocaml cd $(BUILD_DIR)/$(FINDLIB_DIR) && make install \ prefix=$(BINARY_DIR) # Remove ocamlfind binary - we will use the native version. rm $(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/bin/ocamlfind # Remove findlib & num-top libs: if anything uses these we can # add them back later. rm -r $(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/lib/ocaml/findlib rm -r $(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/lib/ocaml/num-top # XXX topfind gets installed as %{_libdir}/ocaml - not sure why # but delete it anyway. rm -rf $(BINARY_DIR)$(INSTALL_PREFIX)/lib/ocaml # Override /etc/%{_mingw_target}-ocamlfind.conf with our # own version. rm $(BINARY_DIR)/etc/$(MINGW_HOST)-ocamlfind.conf sed \ -e "s,@libdir@,$(INSTALL_PREFIX)/$(MINGW_HOST)/lib,g" \ -e 's,@target@,$(MINGW_HOST),g' \ < files/findlib/ocamlfind.conf.in \ > $(BINARY_DIR)/etc/$(MINGW_HOST)-ocamlfind.conf # Install flexlink binary mkdir -p $(BINARY_DIR)$(INSTALL_PREFIX)/lib/flexdll cd $(BUILD_DIR)/$(FLEXDLL_DIR) && install -m 0755 flexlink.exe flexdll_mingw.o flexdll_initer_mingw.o \ flexdll_mingw64.o flexdll_initer_mingw64.o \ $(BINARY_DIR)$(INSTALL_PREFIX)/lib/flexdll # Nothing in /usr/$(MINGW_HOST)/lib/ocaml should 'a priori' be executable except flexlink.exe.. find $(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/lib/ocaml -type f -executable | grep -v flexlink.exe | while read i; do \ chmod -x $$i; done # Now make all script with #!/usr/bin/ocamlrun executables grep -r -l '#!/usr/$(MINGW_HOST)/bin/ocamlrun' $(BINARY_DIR)$(INSTALL_PREFIX)/bin | while read i; do \ sed -e 's|#!/usr/$(MINGW_HOST)/bin/ocamlrun|#!/usr/bin/$(MINGW_HOST)-ocamlrun|' -i $$i; \ chmod +x $$i; done # Remove rm -rf $(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/bin: all binaries should be prefixed and living in /usr/bin.. rm -rf $(BINARY_DIR)$(INSTALL_PREFIX)/$(MINGW_HOST)/bin touch stamp-binary-all install: stamp-binary-all find $(BINARY_DIR) -type f | sed -e s'#$(BINARY_DIR)##g' | while read i; do \ [ -d $(INSTALL_DIR)`dirname $$i` ] || mkdir -p $(INSTALL_DIR)`dirname $$i`; \ cp -f $(BINARY_DIR)/$$i $(INSTALL_DIR)`dirname $$i`; \ done # Symlink flexlink to flexlink.exe rm -f $(INSTALL_DIR)$(INSTALL_PREFIX)/bin/flexlink ln -s ../lib/flexdll/flexlink.exe $(INSTALL_DIR)$(INSTALL_PREFIX)/bin/flexlink clean: rm -rf $(BUILD_DIR) $(BINARY_DIR) $(INSTALL_DIR) patches .pc/ stamp-* dist: clean rm -rf mingw-ocaml mkdir mingw-ocaml cp -rf $(DISTFILES) mingw-ocaml find mingw-ocaml -name .git | xargs rm -rf tar cvzf mingw-ocaml.tar.gz mingw-ocaml rm -rf mingw-ocaml mingw-ocaml/ocaml/0000755000175000017500000000000012124403242013457 5ustar tootstootsmingw-ocaml/ocaml/asmrun/0000755000175000017500000000000012124403240014762 5ustar tootstootsmingw-ocaml/ocaml/asmrun/.ignore0000644000175000017500000000054412124403240016251 0ustar tootstoots*.p.c *.d.c libasmrun.a libasmrunp.a main.c misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c weak.c compact.c finalise.c custom.c meta.c globroots.c unix.c dynlink.c signals.c debugger.c .depend.nt mingw-ocaml/ocaml/asmrun/natdynlink.h0000644000175000017500000000000012124403240017274 0ustar tootstootsmingw-ocaml/ocaml/asmrun/sparc.S0000644000175000017500000002753512124403240016232 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Asm part of the runtime system for the Sparc processor. */ /* Must be preprocessed by cpp */ #ifndef SYS_solaris #define INDIRECT_LIMIT #endif #define Exn_ptr %l5 #define Alloc_ptr %l6 #define Alloc_limit %l7 #define Load(symb,reg) sethi %hi(symb), %g1; ld [%g1 + %lo(symb)], reg #define Store(reg,symb) sethi %hi(symb), %g1; st reg, [%g1 + %lo(symb)] #define Address(symb,reg) sethi %hi(symb), reg; or reg, %lo(symb), reg /* Allocation functions */ .text .global caml_system__code_begin caml_system__code_begin: .global caml_allocN .global caml_call_gc /* Required size in %g2 */ caml_allocN: #ifdef INDIRECT_LIMIT ld [Alloc_limit], %g1 sub Alloc_ptr, %g2, Alloc_ptr cmp Alloc_ptr, %g1 #else sub Alloc_ptr, %g2, Alloc_ptr cmp Alloc_ptr, Alloc_limit #endif /*blu,pt %icc, caml_call_gc*/ blu caml_call_gc nop retl nop /* Required size in %g2 */ caml_call_gc: /* Save exception pointer if GC raises */ Store(Exn_ptr, caml_exception_pointer) /* Save current allocation pointer for debugging purposes */ Store(Alloc_ptr, caml_young_ptr) /* Record lowest stack address */ Store(%sp, caml_bottom_of_stack) /* Record last return address */ Store(%o7, caml_last_return_address) /* Allocate space on stack for caml_context structure and float regs */ sub %sp, 20*4 + 15*8, %sp /* Save int regs on stack and save it into caml_gc_regs */ L100: add %sp, 96 + 15*8, %g1 st %o0, [%g1] st %o1, [%g1 + 0x4] st %o2, [%g1 + 0x8] st %o3, [%g1 + 0xc] st %o4, [%g1 + 0x10] st %o5, [%g1 + 0x14] st %i0, [%g1 + 0x18] st %i1, [%g1 + 0x1c] st %i2, [%g1 + 0x20] st %i3, [%g1 + 0x24] st %i4, [%g1 + 0x28] st %i5, [%g1 + 0x2c] st %l0, [%g1 + 0x30] st %l1, [%g1 + 0x34] st %l2, [%g1 + 0x38] st %l3, [%g1 + 0x3c] st %l4, [%g1 + 0x40] st %g3, [%g1 + 0x44] st %g4, [%g1 + 0x48] st %g2, [%g1 + 0x4C] /* Save required size */ mov %g1, %g2 Store(%g2, caml_gc_regs) /* Save the floating-point registers */ add %sp, 96, %g1 std %f0, [%g1] std %f2, [%g1 + 0x8] std %f4, [%g1 + 0x10] std %f6, [%g1 + 0x18] std %f8, [%g1 + 0x20] std %f10, [%g1 + 0x28] std %f12, [%g1 + 0x30] std %f14, [%g1 + 0x38] std %f16, [%g1 + 0x40] std %f18, [%g1 + 0x48] std %f20, [%g1 + 0x50] std %f22, [%g1 + 0x58] std %f24, [%g1 + 0x60] std %f26, [%g1 + 0x68] std %f28, [%g1 + 0x70] /* Call the garbage collector */ call caml_garbage_collection nop /* Restore all regs used by the code generator */ add %sp, 96 + 15*8, %g1 ld [%g1], %o0 ld [%g1 + 0x4], %o1 ld [%g1 + 0x8], %o2 ld [%g1 + 0xc], %o3 ld [%g1 + 0x10], %o4 ld [%g1 + 0x14], %o5 ld [%g1 + 0x18], %i0 ld [%g1 + 0x1c], %i1 ld [%g1 + 0x20], %i2 ld [%g1 + 0x24], %i3 ld [%g1 + 0x28], %i4 ld [%g1 + 0x2c], %i5 ld [%g1 + 0x30], %l0 ld [%g1 + 0x34], %l1 ld [%g1 + 0x38], %l2 ld [%g1 + 0x3c], %l3 ld [%g1 + 0x40], %l4 ld [%g1 + 0x44], %g3 ld [%g1 + 0x48], %g4 ld [%g1 + 0x4C], %g2 /* Recover desired size */ add %sp, 96, %g1 ldd [%g1], %f0 ldd [%g1 + 0x8], %f2 ldd [%g1 + 0x10], %f4 ldd [%g1 + 0x18], %f6 ldd [%g1 + 0x20], %f8 ldd [%g1 + 0x28], %f10 ldd [%g1 + 0x30], %f12 ldd [%g1 + 0x38], %f14 ldd [%g1 + 0x40], %f16 ldd [%g1 + 0x48], %f18 ldd [%g1 + 0x50], %f20 ldd [%g1 + 0x58], %f22 ldd [%g1 + 0x60], %f24 ldd [%g1 + 0x68], %f26 ldd [%g1 + 0x70], %f28 /* Reload alloc ptr */ Load(caml_young_ptr, Alloc_ptr) /* Allocate space for block */ #ifdef INDIRECT_LIMIT ld [Alloc_limit], %g1 sub Alloc_ptr, %g2, Alloc_ptr cmp Alloc_ptr, %g1 /* Check that we have enough free space */ #else Load(caml_young_limit,Alloc_limit) sub Alloc_ptr, %g2, Alloc_ptr cmp Alloc_ptr, Alloc_limit #endif blu L100 /* If not, call GC again */ nop /* Return to caller */ Load(caml_last_return_address, %o7) retl add %sp, 20*4 + 15*8, %sp /* in delay slot */ /* Call a C function from Ocaml */ .global caml_c_call /* Function to call is in %g2 */ caml_c_call: /* Record lowest stack address and return address */ Store(%sp, caml_bottom_of_stack) Store(%o7, caml_last_return_address) /* Save the exception handler and alloc pointer */ Store(Exn_ptr, caml_exception_pointer) sethi %hi(caml_young_ptr), %g1 /* Call the C function */ call %g2 st Alloc_ptr, [%g1 + %lo(caml_young_ptr)] /* in delay slot */ /* Reload return address */ Load(caml_last_return_address, %o7) /* Reload alloc pointer */ sethi %hi(caml_young_ptr), %g1 /* Return to caller */ retl ld [%g1 + %lo(caml_young_ptr)], Alloc_ptr /* in delay slot */ /* Start the Ocaml program */ .global caml_start_program caml_start_program: /* Save all callee-save registers */ save %sp, -96, %sp /* Address of code to call */ Address(caml_program, %l2) /* Code shared with caml_callback* */ L108: /* Set up a callback link on the stack. */ sub %sp, 16, %sp Load(caml_bottom_of_stack, %l0) Load(caml_last_return_address, %l1) Load(caml_gc_regs, %l3) st %l0, [%sp + 96] st %l1, [%sp + 100] /* Set up a trap frame to catch exceptions escaping the Ocaml code */ call L111 st %l3, [%sp + 104] b L110 nop L111: sub %sp, 8, %sp Load(caml_exception_pointer, Exn_ptr) st %o7, [%sp + 96] st Exn_ptr, [%sp + 100] mov %sp, Exn_ptr /* Reload allocation pointers */ Load(caml_young_ptr, Alloc_ptr) #ifdef INDIRECT_LIMIT Address(caml_young_limit, Alloc_limit) #else Load(caml_young_limit, Alloc_limit) #endif /* Call the Ocaml code */ L109: call %l2 nop /* Pop trap frame and restore caml_exception_pointer */ ld [%sp + 100], Exn_ptr add %sp, 8, %sp Store(Exn_ptr, caml_exception_pointer) /* Pop callback link, restoring the global variables */ L112: ld [%sp + 96], %l0 ld [%sp + 100], %l1 ld [%sp + 104], %l2 Store(%l0, caml_bottom_of_stack) Store(%l1, caml_last_return_address) Store(%l2, caml_gc_regs) add %sp, 16, %sp /* Save allocation pointer */ Store(Alloc_ptr, caml_young_ptr) /* Reload callee-save registers and return */ ret restore %o0, 0, %o0 /* copy %o0 in this window to caller's %o0 */ L110: /* The trap handler */ Store(Exn_ptr, caml_exception_pointer) /* Encode exception bucket as an exception result */ b L112 or %o0, 2, %o0 /* Raise an exception from C */ .global caml_raise_exception caml_raise_exception: /* Save exception bucket in a register outside the reg windows */ mov %o0, %g2 /* Load exception pointer in a register outside the reg windows */ Load(caml_exception_pointer, %g3) /* Pop some frames until the trap pointer is in the current frame. */ cmp %g3, %fp blt L107 /* if Exn_ptr < %fp, over */ nop L106: restore cmp %fp, %g3 /* if %fp <= Exn_ptr, loop */ ble L106 nop L107: /* Reload allocation registers */ Load(caml_young_ptr, Alloc_ptr) #ifdef INDIRECT_LIMIT Address(caml_young_limit, Alloc_limit) #else Load(caml_young_limit, Alloc_limit) #endif /* Branch to exception handler */ mov %g3, %sp ld [%sp + 96], %g1 ld [%sp + 100], Exn_ptr add %sp, 8, %sp jmp %g1 + 8 /* Restore bucket, in delay slot */ mov %g2, %o0 /* Callbacks C -> ML */ .global caml_callback_exn caml_callback_exn: /* Save callee-save registers and return address */ save %sp, -96, %sp /* Initial shuffling of arguments */ mov %i0, %g1 mov %i1, %i0 /* first arg */ mov %g1, %i1 /* environment */ b L108 ld [%g1], %l2 /* code pointer */ .global caml_callback2_exn caml_callback2_exn: /* Save callee-save registers and return address */ save %sp, -104, %sp /* Initial shuffling of arguments */ mov %i0, %g1 mov %i1, %i0 /* first arg */ mov %i2, %i1 /* second arg */ mov %g1, %i2 /* environment */ sethi %hi(caml_apply2), %l2 b L108 or %l2, %lo(caml_apply2), %l2 .global caml_callback3_exn caml_callback3_exn: /* Save callee-save registers and return address */ save %sp, -104, %sp /* Initial shuffling of arguments */ mov %i0, %g1 mov %i1, %i0 /* first arg */ mov %i2, %i1 /* second arg */ mov %i3, %i2 /* third arg */ mov %g1, %i3 /* environment */ sethi %hi(caml_apply3), %l2 b L108 or %l2, %lo(caml_apply3), %l2 #ifndef SYS_solaris /* Glue code to call [caml_array_bound_error] */ .global caml_ml_array_bound_error caml_ml_array_bound_error: Address(caml_array_bound_error, %g2) b caml_c_call nop #endif .global caml_system__code_end caml_system__code_end: #ifdef SYS_solaris .section ".rodata" #else .data #endif .global caml_system__frametable .align 4 /* required for gas? */ caml_system__frametable: .word 1 /* one descriptor */ .word L109 /* return address into callback */ .half -1 /* negative frame size => use callback link */ .half 0 /* no roots */ #ifdef SYS_solaris .type caml_allocN, #function .type caml_call_gc, #function .type caml_c_call, #function .type caml_start_program, #function .type caml_raise_exception, #function .type caml_system__frametable, #object #endif mingw-ocaml/ocaml/asmrun/power-elf.S0000644000175000017500000003167212124403240017017 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #define Addrglobal(reg,glob) \ addis reg, 0, glob@ha; \ addi reg, reg, glob@l #define Loadglobal(reg,glob,tmp) \ addis tmp, 0, glob@ha; \ lwz reg, glob@l(tmp) #define Storeglobal(reg,glob,tmp) \ addis tmp, 0, glob@ha; \ stw reg, glob@l(tmp) .section ".text" /* Invoke the garbage collector. */ .globl caml_system__code_begin caml_system__code_begin: .globl caml_call_gc .type caml_call_gc, @function caml_call_gc: /* Set up stack frame */ stwu 1, -0x1A0(1) /* 0x1A0 = 4*32 (int regs) + 8*32 (float regs) + 32 (space for C call) */ /* Record return address into OCaml code */ mflr 0 Storeglobal(0, caml_last_return_address, 11) /* Record lowest stack address */ addi 0, 1, 0x1A0 Storeglobal(0, caml_bottom_of_stack, 11) /* Record pointer to register array */ addi 0, 1, 8*32 + 32 Storeglobal(0, caml_gc_regs, 11) /* Save current allocation pointer for debugging purposes */ Storeglobal(31, caml_young_ptr, 11) /* Save exception pointer (if e.g. a sighandler raises) */ Storeglobal(29, caml_exception_pointer, 11) /* Save all registers used by the code generator */ addi 11, 1, 8*32 + 32 - 4 stwu 3, 4(11) stwu 4, 4(11) stwu 5, 4(11) stwu 6, 4(11) stwu 7, 4(11) stwu 8, 4(11) stwu 9, 4(11) stwu 10, 4(11) stwu 14, 4(11) stwu 15, 4(11) stwu 16, 4(11) stwu 17, 4(11) stwu 18, 4(11) stwu 19, 4(11) stwu 20, 4(11) stwu 21, 4(11) stwu 22, 4(11) stwu 23, 4(11) stwu 24, 4(11) stwu 25, 4(11) stwu 26, 4(11) stwu 27, 4(11) stwu 28, 4(11) addi 11, 1, 32 - 8 stfdu 1, 8(11) stfdu 2, 8(11) stfdu 3, 8(11) stfdu 4, 8(11) stfdu 5, 8(11) stfdu 6, 8(11) stfdu 7, 8(11) stfdu 8, 8(11) stfdu 9, 8(11) stfdu 10, 8(11) stfdu 11, 8(11) stfdu 12, 8(11) stfdu 13, 8(11) stfdu 14, 8(11) stfdu 15, 8(11) stfdu 16, 8(11) stfdu 17, 8(11) stfdu 18, 8(11) stfdu 19, 8(11) stfdu 20, 8(11) stfdu 21, 8(11) stfdu 22, 8(11) stfdu 23, 8(11) stfdu 24, 8(11) stfdu 25, 8(11) stfdu 26, 8(11) stfdu 27, 8(11) stfdu 28, 8(11) stfdu 29, 8(11) stfdu 30, 8(11) stfdu 31, 8(11) /* Call the GC */ bl caml_garbage_collection /* Reload new allocation pointer and allocation limit */ Loadglobal(31, caml_young_ptr, 11) Loadglobal(30, caml_young_limit, 11) /* Restore all regs used by the code generator */ addi 11, 1, 8*32 + 32 - 4 lwzu 3, 4(11) lwzu 4, 4(11) lwzu 5, 4(11) lwzu 6, 4(11) lwzu 7, 4(11) lwzu 8, 4(11) lwzu 9, 4(11) lwzu 10, 4(11) lwzu 14, 4(11) lwzu 15, 4(11) lwzu 16, 4(11) lwzu 17, 4(11) lwzu 18, 4(11) lwzu 19, 4(11) lwzu 20, 4(11) lwzu 21, 4(11) lwzu 22, 4(11) lwzu 23, 4(11) lwzu 24, 4(11) lwzu 25, 4(11) lwzu 26, 4(11) lwzu 27, 4(11) lwzu 28, 4(11) addi 11, 1, 32 - 8 lfdu 1, 8(11) lfdu 2, 8(11) lfdu 3, 8(11) lfdu 4, 8(11) lfdu 5, 8(11) lfdu 6, 8(11) lfdu 7, 8(11) lfdu 8, 8(11) lfdu 9, 8(11) lfdu 10, 8(11) lfdu 11, 8(11) lfdu 12, 8(11) lfdu 13, 8(11) lfdu 14, 8(11) lfdu 15, 8(11) lfdu 16, 8(11) lfdu 17, 8(11) lfdu 18, 8(11) lfdu 19, 8(11) lfdu 20, 8(11) lfdu 21, 8(11) lfdu 22, 8(11) lfdu 23, 8(11) lfdu 24, 8(11) lfdu 25, 8(11) lfdu 26, 8(11) lfdu 27, 8(11) lfdu 28, 8(11) lfdu 29, 8(11) lfdu 30, 8(11) lfdu 31, 8(11) /* Return to caller, restarting the allocation */ Loadglobal(0, caml_last_return_address, 11) addic 0, 0, -16 /* Restart the allocation (4 instructions) */ mtlr 0 /* Say we are back into OCaml code */ li 12, 0 Storeglobal(12, caml_last_return_address, 11) /* Deallocate stack frame */ addi 1, 1, 0x1A0 /* Return */ blr /* Call a C function from OCaml */ .globl caml_c_call .type caml_c_call, @function caml_c_call: /* Save return address */ mflr 25 /* Get ready to call C function (address in 11) */ mtctr 11 /* Record lowest stack address and return address */ Storeglobal(1, caml_bottom_of_stack, 12) Storeglobal(25, caml_last_return_address, 12) /* Make the exception handler and alloc ptr available to the C code */ Storeglobal(31, caml_young_ptr, 11) Storeglobal(29, caml_exception_pointer, 11) /* Call the function (address in CTR register) */ bctrl /* Restore return address (in 25, preserved by the C function) */ mtlr 25 /* Reload allocation pointer and allocation limit*/ Loadglobal(31, caml_young_ptr, 11) Loadglobal(30, caml_young_limit, 11) /* Say we are back into OCaml code */ li 12, 0 Storeglobal(12, caml_last_return_address, 11) /* Return to caller */ blr /* Raise an exception from C */ .globl caml_raise_exception .type caml_raise_exception, @function caml_raise_exception: /* Reload OCaml global registers */ Loadglobal(1, caml_exception_pointer, 11) Loadglobal(31, caml_young_ptr, 11) Loadglobal(30, caml_young_limit, 11) /* Say we are back into OCaml code */ li 0, 0 Storeglobal(0, caml_last_return_address, 11) /* Pop trap frame */ lwz 0, 0(1) lwz 29, 4(1) mtlr 0 addi 1, 1, 16 /* Branch to handler */ blr /* Start the OCaml program */ .globl caml_start_program .type caml_start_program, @function caml_start_program: Addrglobal(12, caml_program) /* Code shared between caml_start_program and caml_callback */ .L102: /* Allocate and link stack frame */ stwu 1, -256(1) /* Save return address */ mflr 0 stw 0, 256+4(1) /* Save all callee-save registers */ /* GPR 14 at sp+16 ... GPR 31 at sp+84 FPR 14 at sp+92 ... FPR 31 at sp+228 */ addi 11, 1, 16-4 stwu 14, 4(11) stwu 15, 4(11) stwu 16, 4(11) stwu 17, 4(11) stwu 18, 4(11) stwu 19, 4(11) stwu 20, 4(11) stwu 21, 4(11) stwu 22, 4(11) stwu 23, 4(11) stwu 24, 4(11) stwu 25, 4(11) stwu 26, 4(11) stwu 27, 4(11) stwu 28, 4(11) stwu 29, 4(11) stwu 30, 4(11) stwu 31, 4(11) stfdu 14, 8(11) stfdu 15, 8(11) stfdu 16, 8(11) stfdu 17, 8(11) stfdu 18, 8(11) stfdu 19, 8(11) stfdu 20, 8(11) stfdu 21, 8(11) stfdu 22, 8(11) stfdu 23, 8(11) stfdu 24, 8(11) stfdu 25, 8(11) stfdu 26, 8(11) stfdu 27, 8(11) stfdu 28, 8(11) stfdu 29, 8(11) stfdu 30, 8(11) stfdu 31, 8(11) /* Set up a callback link */ addi 1, 1, -16 Loadglobal(9, caml_bottom_of_stack, 11) Loadglobal(10, caml_last_return_address, 11) Loadglobal(11, caml_gc_regs, 11) stw 9, 0(1) stw 10, 4(1) stw 11, 8(1) /* Build an exception handler to catch exceptions escaping out of OCaml */ bl .L103 b .L104 .L103: addi 1, 1, -16 mflr 0 stw 0, 0(1) Loadglobal(11, caml_exception_pointer, 11) stw 11, 4(1) mr 29, 1 /* Reload allocation pointers */ Loadglobal(31, caml_young_ptr, 11) Loadglobal(30, caml_young_limit, 11) /* Say we are back into OCaml code */ li 0, 0 Storeglobal(0, caml_last_return_address, 11) /* Call the OCaml code */ mtlr 12 .L105: blrl /* Pop the trap frame, restoring caml_exception_pointer */ lwz 9, 4(1) Storeglobal(9, caml_exception_pointer, 11) addi 1, 1, 16 /* Pop the callback link, restoring the global variables */ .L106: lwz 9, 0(1) lwz 10, 4(1) lwz 11, 8(1) Storeglobal(9, caml_bottom_of_stack, 12) Storeglobal(10, caml_last_return_address, 12) Storeglobal(11, caml_gc_regs, 12) addi 1, 1, 16 /* Update allocation pointer */ Storeglobal(31, caml_young_ptr, 11) /* Restore callee-save registers */ addi 11, 1, 16-4 lwzu 14, 4(11) lwzu 15, 4(11) lwzu 16, 4(11) lwzu 17, 4(11) lwzu 18, 4(11) lwzu 19, 4(11) lwzu 20, 4(11) lwzu 21, 4(11) lwzu 22, 4(11) lwzu 23, 4(11) lwzu 24, 4(11) lwzu 25, 4(11) lwzu 26, 4(11) lwzu 27, 4(11) lwzu 28, 4(11) lwzu 29, 4(11) lwzu 30, 4(11) lwzu 31, 4(11) lfdu 14, 8(11) lfdu 15, 8(11) lfdu 16, 8(11) lfdu 17, 8(11) lfdu 18, 8(11) lfdu 19, 8(11) lfdu 20, 8(11) lfdu 21, 8(11) lfdu 22, 8(11) lfdu 23, 8(11) lfdu 24, 8(11) lfdu 25, 8(11) lfdu 26, 8(11) lfdu 27, 8(11) lfdu 28, 8(11) lfdu 29, 8(11) lfdu 30, 8(11) lfdu 31, 8(11) /* Reload return address */ lwz 0, 256+4(1) mtlr 0 /* Return */ addi 1, 1, 256 blr /* The trap handler: */ .L104: /* Update caml_exception_pointer */ Storeglobal(29, caml_exception_pointer, 11) /* Encode exception bucket as an exception result and return it */ ori 3, 3, 2 b .L106 /* Callback from C to OCaml */ .globl caml_callback_exn .type caml_callback_exn, @function caml_callback_exn: /* Initial shuffling of arguments */ mr 0, 3 /* Closure */ mr 3, 4 /* Argument */ mr 4, 0 lwz 12, 0(4) /* Code pointer */ b .L102 .globl caml_callback2_exn .type caml_callback2_exn, @function caml_callback2_exn: mr 0, 3 /* Closure */ mr 3, 4 /* First argument */ mr 4, 5 /* Second argument */ mr 5, 0 Addrglobal(12, caml_apply2) b .L102 .globl caml_callback3_exn .type caml_callback3_exn, @function caml_callback3_exn: mr 0, 3 /* Closure */ mr 3, 4 /* First argument */ mr 4, 5 /* Second argument */ mr 5, 6 /* Third argument */ mr 6, 0 Addrglobal(12, caml_apply3) b .L102 .globl caml_system__code_end caml_system__code_end: /* Frame table */ .section ".data" .globl caml_system__frametable .type caml_system__frametable, @object caml_system__frametable: .long 1 /* one descriptor */ .long .L105 + 4 /* return address into callback */ .short -1 /* negative size count => use callback link */ .short 0 /* no roots here */ mingw-ocaml/ocaml/asmrun/arm.S0000644000175000017500000003511012124403240015665 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Benedikt Meurer, University of Siegen */ /* */ /* Copyright 1998 Institut National de Recherche en Informatique */ /* et en Automatique. Copyright 2012 Benedikt Meurer. All rights */ /* reserved. This file is distributed under the terms of the GNU */ /* Library General Public License, with the special exception on */ /* linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Asm part of the runtime system, ARM processor */ /* Must be preprocessed by cpp */ .syntax unified .text #if defined(SYS_linux_eabihf) .arch armv7-a .fpu vfpv3-d16 .thumb #elif defined(SYS_linux_eabi) .arch armv4t .arm /* Compatibility macros */ .macro blx reg mov lr, pc bx \reg .endm .macro cbz reg, lbl cmp \reg, #0 beq \lbl .endm .macro vpop regs .endm .macro vpush regs .endm #endif trap_ptr .req r8 alloc_ptr .req r10 alloc_limit .req r11 /* Support for profiling with gprof */ #if defined(PROFILING) && (defined(SYS_linux_eabihf) || defined(SYS_linux_eabi)) #define PROFILE \ push {lr}; \ bl __gnu_mcount_nc #else #define PROFILE #endif /* Allocation functions and GC interface */ .globl caml_system__code_begin caml_system__code_begin: .align 2 .globl caml_call_gc .type caml_call_gc, %function caml_call_gc: PROFILE /* Record return address */ ldr r12, =caml_last_return_address str lr, [r12] .Lcaml_call_gc: /* Record lowest stack address */ ldr r12, =caml_bottom_of_stack str sp, [r12] /* Save caller floating-point registers on the stack */ vpush {d0-d7} /* Save integer registers and return address on the stack */ push {r0-r7,r12,lr} /* Store pointer to saved integer registers in caml_gc_regs */ ldr r12, =caml_gc_regs str sp, [r12] /* Save current allocation pointer for debugging purposes */ ldr alloc_limit, =caml_young_ptr str alloc_ptr, [alloc_limit] /* Save trap pointer in case an exception is raised during GC */ ldr r12, =caml_exception_pointer str trap_ptr, [r12] /* Call the garbage collector */ bl caml_garbage_collection /* Restore integer registers and return address from the stack */ pop {r0-r7,r12,lr} /* Restore floating-point registers from the stack */ vpop {d0-d7} /* Reload new allocation pointer and limit */ /* alloc_limit still points to caml_young_ptr */ ldr r12, =caml_young_limit ldr alloc_ptr, [alloc_limit] ldr alloc_limit, [r12] /* Return to caller */ bx lr .type caml_call_gc, %function .size caml_call_gc, .-caml_call_gc .align 2 .globl caml_alloc1 .type caml_alloc1, %function caml_alloc1: PROFILE .Lcaml_alloc1: sub alloc_ptr, alloc_ptr, 8 cmp alloc_ptr, alloc_limit bcc 1f bx lr 1: /* Record return address */ ldr r7, =caml_last_return_address str lr, [r7] /* Call GC (preserves r7) */ bl .Lcaml_call_gc /* Restore return address */ ldr lr, [r7] /* Try again */ b .Lcaml_alloc1 .type caml_alloc1, %function .size caml_alloc1, .-caml_alloc1 .align 2 .globl caml_alloc2 .type caml_alloc2, %function caml_alloc2: PROFILE .Lcaml_alloc2: sub alloc_ptr, alloc_ptr, 12 cmp alloc_ptr, alloc_limit bcc 1f bx lr 1: /* Record return address */ ldr r7, =caml_last_return_address str lr, [r7] /* Call GC (preserves r7) */ bl .Lcaml_call_gc /* Restore return address */ ldr lr, [r7] /* Try again */ b .Lcaml_alloc2 .type caml_alloc2, %function .size caml_alloc2, .-caml_alloc2 .align 2 .globl caml_alloc3 .type caml_alloc3, %function caml_alloc3: PROFILE .Lcaml_alloc3: sub alloc_ptr, alloc_ptr, 16 cmp alloc_ptr, alloc_limit bcc 1f bx lr 1: /* Record return address */ ldr r7, =caml_last_return_address str lr, [r7] /* Call GC (preserves r7) */ bl .Lcaml_call_gc /* Restore return address */ ldr lr, [r7] /* Try again */ b .Lcaml_alloc3 .type caml_alloc3, %function .size caml_alloc3, .-caml_alloc3 .align 2 .globl caml_allocN .type caml_allocN, %function caml_allocN: PROFILE .Lcaml_allocN: sub alloc_ptr, alloc_ptr, r7 cmp alloc_ptr, alloc_limit bcc 1f bx lr 1: /* Record return address */ ldr r12, =caml_last_return_address str lr, [r12] /* Call GC (preserves r7) */ bl .Lcaml_call_gc /* Restore return address */ ldr r12, =caml_last_return_address ldr lr, [r12] /* Try again */ b .Lcaml_allocN .type caml_allocN, %function .size caml_allocN, .-caml_allocN /* Call a C function from OCaml */ /* Function to call is in r7 */ .align 2 .globl caml_c_call .type caml_c_call, %function caml_c_call: PROFILE /* Record lowest stack address and return address */ ldr r5, =caml_last_return_address ldr r6, =caml_bottom_of_stack str lr, [r5] str sp, [r6] /* Preserve return address in callee-save register r4 */ mov r4, lr /* Make the exception handler alloc ptr available to the C code */ ldr r5, =caml_young_ptr ldr r6, =caml_exception_pointer str alloc_ptr, [r5] str trap_ptr, [r6] /* Call the function */ blx r7 /* Reload alloc ptr and alloc limit */ ldr r6, =caml_young_limit ldr alloc_ptr, [r5] /* r5 still points to caml_young_ptr */ ldr alloc_limit, [r6] /* Return */ bx r4 .type caml_c_call, %function .size caml_c_call, .-caml_c_call /* Start the OCaml program */ .align 2 .globl caml_start_program .type caml_start_program, %function caml_start_program: PROFILE ldr r12, =caml_program /* Code shared with caml_callback* */ /* Address of OCaml code to call is in r12 */ /* Arguments to the OCaml code are in r0...r3 */ .Ljump_to_caml: /* Save return address and callee-save registers */ vpush {d8-d15} push {r4-r8,r10,r11,lr} /* 8-byte alignment */ /* Setup a callback link on the stack */ sub sp, sp, 4*4 /* 8-byte alignment */ ldr r4, =caml_bottom_of_stack ldr r5, =caml_last_return_address ldr r6, =caml_gc_regs ldr r4, [r4] ldr r5, [r5] ldr r6, [r6] str r4, [sp, 0] str r5, [sp, 4] str r6, [sp, 8] /* Setup a trap frame to catch exceptions escaping the OCaml code */ sub sp, sp, 2*4 ldr r6, =caml_exception_pointer ldr r5, =.Ltrap_handler ldr r4, [r6] str r4, [sp, 0] str r5, [sp, 4] mov trap_ptr, sp /* Reload allocation pointers */ ldr r4, =caml_young_ptr ldr alloc_ptr, [r4] ldr r4, =caml_young_limit ldr alloc_limit, [r4] /* Call the OCaml code */ blx r12 .Lcaml_retaddr: /* Pop the trap frame, restoring caml_exception_pointer */ ldr r4, =caml_exception_pointer ldr r5, [sp, 0] str r5, [r4] add sp, sp, 2*4 /* Pop the callback link, restoring the global variables */ .Lreturn_result: ldr r4, =caml_bottom_of_stack ldr r5, [sp, 0] str r5, [r4] ldr r4, =caml_last_return_address ldr r5, [sp, 4] str r5, [r4] ldr r4, =caml_gc_regs ldr r5, [sp, 8] str r5, [r4] add sp, sp, 4*4 /* Update allocation pointer */ ldr r4, =caml_young_ptr str alloc_ptr, [r4] /* Reload callee-save registers and return */ pop {r4-r8,r10,r11,lr} vpop {d8-d15} bx lr .type .Lcaml_retaddr, %function .size .Lcaml_retaddr, .-.Lcaml_retaddr .type caml_start_program, %function .size caml_start_program, .-caml_start_program /* The trap handler */ .align 2 .Ltrap_handler: /* Save exception pointer */ ldr r12, =caml_exception_pointer str trap_ptr, [r12] /* Encode exception bucket as an exception result */ orr r0, r0, 2 /* Return it */ b .Lreturn_result .type .Ltrap_handler, %function .size .Ltrap_handler, .-.Ltrap_handler /* Raise an exception from OCaml */ .align 2 .globl caml_raise_exn caml_raise_exn: PROFILE /* Test if backtrace is active */ ldr r1, =caml_backtrace_active ldr r1, [r1] cbz r1, 1f /* Preserve exception bucket in callee-save register r4 */ mov r4, r0 /* Stash the backtrace */ mov r1, lr /* arg2: pc of raise */ mov r2, sp /* arg3: sp of raise */ mov r3, trap_ptr /* arg4: sp of handler */ bl caml_stash_backtrace /* Restore exception bucket */ mov r0, r4 1: /* Cut stack at current trap handler */ mov sp, trap_ptr /* Pop previous handler and addr of trap, and jump to it */ pop {trap_ptr, pc} .type caml_raise_exn, %function .size caml_raise_exn, .-caml_raise_exn /* Raise an exception from C */ .align 2 .globl caml_raise_exception .type caml_raise_exception, %function caml_raise_exception: PROFILE /* Reload trap ptr, alloc ptr and alloc limit */ ldr trap_ptr, =caml_exception_pointer ldr alloc_ptr, =caml_young_ptr ldr alloc_limit, =caml_young_limit ldr trap_ptr, [trap_ptr] ldr alloc_ptr, [alloc_ptr] ldr alloc_limit, [alloc_limit] /* Test if backtrace is active */ ldr r1, =caml_backtrace_active ldr r1, [r1] cbz r1, 1f /* Preserve exception bucket in callee-save register r4 */ mov r4, r0 ldr r1, =caml_last_return_address /* arg2: pc of raise */ ldr r1, [r1] ldr r2, =caml_bottom_of_stack /* arg3: sp of raise */ ldr r2, [r2] mov r3, trap_ptr /* arg4: sp of handler */ bl caml_stash_backtrace /* Restore exception bucket */ mov r0, r4 1: /* Cut stack at current trap handler */ mov sp, trap_ptr /* Pop previous handler and addr of trap, and jump to it */ pop {trap_ptr, pc} .type caml_raise_exception, %function .size caml_raise_exception, .-caml_raise_exception /* Callback from C to OCaml */ .align 2 .globl caml_callback_exn .type caml_callback_exn, %function caml_callback_exn: PROFILE /* Initial shuffling of arguments (r0 = closure, r1 = first arg) */ mov r12, r0 mov r0, r1 /* r0 = first arg */ mov r1, r12 /* r1 = closure environment */ ldr r12, [r12] /* code pointer */ b .Ljump_to_caml .type caml_callback_exn, %function .size caml_callback_exn, .-caml_callback_exn .align 2 .globl caml_callback2_exn .type caml_callback2_exn, %function caml_callback2_exn: PROFILE /* Initial shuffling of arguments (r0 = closure, r1 = arg1, r2 = arg2) */ mov r12, r0 mov r0, r1 /* r0 = first arg */ mov r1, r2 /* r1 = second arg */ mov r2, r12 /* r2 = closure environment */ ldr r12, =caml_apply2 b .Ljump_to_caml .type caml_callback2_exn, %function .size caml_callback2_exn, .-caml_callback2_exn .align 2 .globl caml_callback3_exn .type caml_callback3_exn, %function caml_callback3_exn: PROFILE /* Initial shuffling of arguments */ /* (r0 = closure, r1 = arg1, r2 = arg2, r3 = arg3) */ mov r12, r0 mov r0, r1 /* r0 = first arg */ mov r1, r2 /* r1 = second arg */ mov r2, r3 /* r2 = third arg */ mov r3, r12 /* r3 = closure environment */ ldr r12, =caml_apply3 b .Ljump_to_caml .type caml_callback3_exn, %function .size caml_callback3_exn, .-caml_callback3_exn .align 2 .globl caml_ml_array_bound_error .type caml_ml_array_bound_error, %function caml_ml_array_bound_error: PROFILE /* Load address of [caml_array_bound_error] in r7 */ ldr r7, =caml_array_bound_error /* Call that function */ b caml_c_call .type caml_ml_array_bound_error, %function .size caml_ml_array_bound_error, .-caml_ml_array_bound_error .globl caml_system__code_end caml_system__code_end: /* GC roots for callback */ .data .align 2 .globl caml_system__frametable caml_system__frametable: .word 1 /* one descriptor */ .word .Lcaml_retaddr /* return address into callback */ .short -1 /* negative frame size => use callback link */ .short 0 /* no roots */ .align 2 .type caml_system__frametable, %object .size caml_system__frametable, .-caml_system__frametable mingw-ocaml/ocaml/asmrun/backtrace.c0000644000175000017500000001555712124403240017062 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ /* */ /* Copyright 2006 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Stack backtrace for uncaught exceptions */ #include #include "alloc.h" #include "backtrace.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" #include "stack.h" int caml_backtrace_active = 0; int caml_backtrace_pos = 0; code_t * caml_backtrace_buffer = NULL; value caml_backtrace_last_exn = Val_unit; #define BACKTRACE_BUFFER_SIZE 1024 /* Start or stop the backtrace machinery */ CAMLprim value caml_record_backtrace(value vflag) { int flag = Int_val(vflag); if (flag != caml_backtrace_active) { caml_backtrace_active = flag; caml_backtrace_pos = 0; if (flag) { caml_register_global_root(&caml_backtrace_last_exn); } else { caml_remove_global_root(&caml_backtrace_last_exn); } } return Val_unit; } /* Return the status of the backtrace machinery */ CAMLprim value caml_backtrace_status(value vunit) { return Val_bool(caml_backtrace_active); } /* Store the return addresses contained in the given stack fragment into the backtrace array */ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) { frame_descr * d; uintnat h; if (exn != caml_backtrace_last_exn) { caml_backtrace_pos = 0; caml_backtrace_last_exn = exn; } if (caml_backtrace_buffer == NULL) { caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); if (caml_backtrace_buffer == NULL) return; } if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); while (1) { /* Find the descriptor corresponding to the return address */ h = Hash_retaddr(pc); while(1) { d = caml_frame_descriptors[h]; if (d == 0) return; /* can happen if some code not compiled with -g */ if (d->retaddr == pc) break; h = (h+1) & caml_frame_descriptors_mask; } /* Skip to next frame */ if (d->frame_size != 0xFFFF) { /* Regular frame, store its descriptor in the backtrace buffer */ if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) d; #ifndef Stack_grows_upwards sp += (d->frame_size & 0xFFFC); #else sp -= (d->frame_size & 0xFFFC); #endif pc = Saved_return_address(sp); #ifdef Mask_already_scanned pc = Mask_already_scanned(pc); #endif } else { /* Special frame marking the top of a stack chunk for an ML callback. Skip C portion of stack and continue with next ML stack chunk. */ struct caml_context * next_context = Callback_link(sp); sp = next_context->bottom_of_stack; pc = next_context->last_retaddr; /* A null sp means no more ML stack chunks; stop here. */ if (sp == NULL) return; } /* Stop when we reach the current exception handler */ #ifndef Stack_grows_upwards if (sp > trapsp) return; #else if (sp < trapsp) return; #endif } } /* Extract location information for the given frame descriptor */ struct loc_info { int loc_valid; int loc_is_raise; char * loc_filename; int loc_lnum; int loc_startchr; int loc_endchr; }; static void extract_location_info(frame_descr * d, /*out*/ struct loc_info * li) { uintnat infoptr; uint32 info1, info2; /* If no debugging information available, print nothing. When everything is compiled with -g, this corresponds to compiler-inserted re-raise operations. */ if ((d->frame_size & 1) == 0) { li->loc_valid = 0; li->loc_is_raise = 1; return; } /* Recover debugging info */ infoptr = ((uintnat) d + sizeof(char *) + sizeof(short) + sizeof(short) + sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) & -sizeof(frame_descr *); info1 = ((uint32 *)infoptr)[0]; info2 = ((uint32 *)infoptr)[1]; /* Format of the two info words: llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk 44 36 26 2 0 (32+12) (32+4) k ( 2 bits): 0 if it's a call, 1 if it's a raise n (24 bits): offset (in 4-byte words) of file name relative to infoptr l (20 bits): line number a ( 8 bits): beginning of character range b (10 bits): end of character range */ li->loc_valid = 1; li->loc_is_raise = (info1 & 3) != 0; li->loc_filename = (char *) infoptr + (info1 & 0x3FFFFFC); li->loc_lnum = info2 >> 12; li->loc_startchr = (info2 >> 4) & 0xFF; li->loc_endchr = ((info2 & 0xF) << 6) | (info1 >> 26); } static void print_location(struct loc_info * li, int index) { char * info; /* Ignore compiler-inserted raise */ if (!li->loc_valid) return; if (index == 0) info = "Raised at"; else if (li->loc_is_raise) info = "Re-raised at"; else info = "Called from"; fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", info, li->loc_filename, li->loc_lnum, li->loc_startchr, li->loc_endchr); } /* Print a backtrace */ void caml_print_exception_backtrace(void) { int i; struct loc_info li; for (i = 0; i < caml_backtrace_pos; i++) { extract_location_info((frame_descr *) (caml_backtrace_buffer[i]), &li); print_location(&li, i); } } /* Convert the backtrace to a data structure usable from OCaml */ CAMLprim value caml_get_exception_backtrace(value unit) { CAMLparam0(); CAMLlocal4(res, arr, p, fname); int i; struct loc_info li; arr = caml_alloc(caml_backtrace_pos, 0); for (i = 0; i < caml_backtrace_pos; i++) { extract_location_info((frame_descr *) (caml_backtrace_buffer[i]), &li); if (li.loc_valid) { fname = caml_copy_string(li.loc_filename); p = caml_alloc_small(5, 0); Field(p, 0) = Val_bool(li.loc_is_raise); Field(p, 1) = fname; Field(p, 2) = Val_int(li.loc_lnum); Field(p, 3) = Val_int(li.loc_startchr); Field(p, 4) = Val_int(li.loc_endchr); } else { p = caml_alloc_small(1, 1); Field(p, 0) = Val_bool(li.loc_is_raise); } caml_modify(&Field(arr, i), p); } res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ CAMLreturn(res); } mingw-ocaml/ocaml/asmrun/roots.c0000644000175000017500000002451412124403240016302 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* To walk the memory roots for garbage collection */ #include "finalise.h" #include "globroots.h" #include "memory.h" #include "major_gc.h" #include "minor_gc.h" #include "misc.h" #include "mlvalues.h" #include "stack.h" #include "roots.h" #include #include /* Roots registered from C functions */ struct caml__roots_block *caml_local_roots = NULL; void (*caml_scan_roots_hook) (scanning_action) = NULL; /* The hashtable of frame descriptors */ frame_descr ** caml_frame_descriptors = NULL; int caml_frame_descriptors_mask; /* Linked-list */ typedef struct link { void *data; struct link *next; } link; static link *cons(void *data, link *tl) { link *lnk = caml_stat_alloc(sizeof(link)); lnk->data = data; lnk->next = tl; return lnk; } #define iter_list(list,lnk) \ for (lnk = list; lnk != NULL; lnk = lnk->next) /* Linked-list of frametables */ static link *frametables = NULL; void caml_register_frametable(intnat *table) { frametables = cons(table,frametables); if (NULL != caml_frame_descriptors) { caml_stat_free(caml_frame_descriptors); caml_frame_descriptors = NULL; /* force caml_init_frame_descriptors to be called */ } } void caml_init_frame_descriptors(void) { intnat num_descr, tblsize, i, j, len; intnat * tbl; frame_descr * d; uintnat nextd; uintnat h; link *lnk; static int inited = 0; if (!inited) { for (i = 0; caml_frametable[i] != 0; i++) caml_register_frametable(caml_frametable[i]); inited = 1; } /* Count the frame descriptors */ num_descr = 0; iter_list(frametables,lnk) { num_descr += *((intnat*) lnk->data); } /* The size of the hashtable is a power of 2 greater or equal to 2 times the number of descriptors */ tblsize = 4; while (tblsize < 2 * num_descr) tblsize *= 2; /* Allocate the hash table */ caml_frame_descriptors = (frame_descr **) caml_stat_alloc(tblsize * sizeof(frame_descr *)); for (i = 0; i < tblsize; i++) caml_frame_descriptors[i] = NULL; caml_frame_descriptors_mask = tblsize - 1; /* Fill the hash table */ iter_list(frametables,lnk) { tbl = (intnat*) lnk->data; len = *tbl; d = (frame_descr *)(tbl + 1); for (j = 0; j < len; j++) { h = Hash_retaddr(d->retaddr); while (caml_frame_descriptors[h] != NULL) { h = (h+1) & caml_frame_descriptors_mask; } caml_frame_descriptors[h] = d; nextd = ((uintnat)d + sizeof(char *) + sizeof(short) + sizeof(short) + sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) & -sizeof(frame_descr *); if (d->frame_size & 1) nextd += 8; d = (frame_descr *) nextd; } } } /* Communication with [caml_start_program] and [caml_call_gc]. */ char * caml_top_of_stack; char * caml_bottom_of_stack = NULL; /* no stack initially */ uintnat caml_last_return_address = 1; /* not in OCaml code initially */ value * caml_gc_regs; intnat caml_globals_inited = 0; static intnat caml_globals_scanned = 0; static link * caml_dyn_globals = NULL; void caml_register_dyn_global(void *v) { caml_dyn_globals = cons((void*) v,caml_dyn_globals); } /* Call [caml_oldify_one] on (at least) all the roots that point to the minor heap. */ void caml_oldify_local_roots (void) { char * sp; uintnat retaddr; value * regs; frame_descr * d; uintnat h; int i, j, n, ofs; #ifdef Stack_grows_upwards short * p; /* PR#4339: stack offsets are negative in this case */ #else unsigned short * p; #endif value glob; value * root; struct caml__roots_block *lr; link *lnk; /* The global roots */ for (i = caml_globals_scanned; i <= caml_globals_inited && caml_globals[i] != 0; i++) { glob = caml_globals[i]; for (j = 0; j < Wosize_val(glob); j++){ Oldify (&Field (glob, j)); } } caml_globals_scanned = caml_globals_inited; /* Dynamic global roots */ iter_list(caml_dyn_globals, lnk) { glob = (value) lnk->data; for (j = 0; j < Wosize_val(glob); j++){ Oldify (&Field (glob, j)); } } /* The stack and local roots */ if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); sp = caml_bottom_of_stack; retaddr = caml_last_return_address; regs = caml_gc_regs; if (sp != NULL) { while (1) { /* Find the descriptor corresponding to the return address */ h = Hash_retaddr(retaddr); while(1) { d = caml_frame_descriptors[h]; if (d->retaddr == retaddr) break; h = (h+1) & caml_frame_descriptors_mask; } if (d->frame_size != 0xFFFF) { /* Scan the roots in this frame */ for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) { ofs = *p; if (ofs & 1) { root = regs + (ofs >> 1); } else { root = (value *)(sp + ofs); } Oldify (root); } /* Move to next frame */ #ifndef Stack_grows_upwards sp += (d->frame_size & 0xFFFC); #else sp -= (d->frame_size & 0xFFFC); #endif retaddr = Saved_return_address(sp); #ifdef Already_scanned /* Stop here if the frame has been scanned during earlier GCs */ if (Already_scanned(sp, retaddr)) break; /* Mark frame as already scanned */ Mark_scanned(sp, retaddr); #endif } else { /* This marks the top of a stack chunk for an ML callback. Skip C portion of stack and continue with next ML stack chunk. */ struct caml_context * next_context = Callback_link(sp); sp = next_context->bottom_of_stack; retaddr = next_context->last_retaddr; regs = next_context->gc_regs; /* A null sp means no more ML stack chunks; stop here. */ if (sp == NULL) break; } } } /* Local C roots */ for (lr = caml_local_roots; lr != NULL; lr = lr->next) { for (i = 0; i < lr->ntables; i++){ for (j = 0; j < lr->nitems; j++){ root = &(lr->tables[i][j]); Oldify (root); } } } /* Global C roots */ caml_scan_global_young_roots(&caml_oldify_one); /* Finalised values */ caml_final_do_young_roots (&caml_oldify_one); /* Hook */ if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one); } /* Call [darken] on all roots */ void caml_darken_all_roots (void) { caml_do_roots (caml_darken); } void caml_do_roots (scanning_action f) { int i, j; value glob; link *lnk; /* The global roots */ for (i = 0; caml_globals[i] != 0; i++) { glob = caml_globals[i]; for (j = 0; j < Wosize_val(glob); j++) f (Field (glob, j), &Field (glob, j)); } /* Dynamic global roots */ iter_list(caml_dyn_globals, lnk) { glob = (value) lnk->data; for (j = 0; j < Wosize_val(glob); j++){ f (Field (glob, j), &Field (glob, j)); } } /* The stack and local roots */ if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); caml_do_local_roots(f, caml_bottom_of_stack, caml_last_return_address, caml_gc_regs, caml_local_roots); /* Global C roots */ caml_scan_global_roots(f); /* Finalised values */ caml_final_do_strong_roots (f); /* Hook */ if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f); } void caml_do_local_roots(scanning_action f, char * bottom_of_stack, uintnat last_retaddr, value * gc_regs, struct caml__roots_block * local_roots) { char * sp; uintnat retaddr; value * regs; frame_descr * d; uintnat h; int i, j, n, ofs; #ifdef Stack_grows_upwards short * p; /* PR#4339: stack offsets are negative in this case */ #else unsigned short * p; #endif value * root; struct caml__roots_block *lr; sp = bottom_of_stack; retaddr = last_retaddr; regs = gc_regs; if (sp != NULL) { while (1) { /* Find the descriptor corresponding to the return address */ h = Hash_retaddr(retaddr); while(1) { d = caml_frame_descriptors[h]; if (d->retaddr == retaddr) break; h = (h+1) & caml_frame_descriptors_mask; } if (d->frame_size != 0xFFFF) { /* Scan the roots in this frame */ for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) { ofs = *p; if (ofs & 1) { root = regs + (ofs >> 1); } else { root = (value *)(sp + ofs); } f (*root, root); } /* Move to next frame */ #ifndef Stack_grows_upwards sp += (d->frame_size & 0xFFFC); #else sp -= (d->frame_size & 0xFFFC); #endif retaddr = Saved_return_address(sp); #ifdef Mask_already_scanned retaddr = Mask_already_scanned(retaddr); #endif } else { /* This marks the top of a stack chunk for an ML callback. Skip C portion of stack and continue with next ML stack chunk. */ struct caml_context * next_context = Callback_link(sp); sp = next_context->bottom_of_stack; retaddr = next_context->last_retaddr; regs = next_context->gc_regs; /* A null sp means no more ML stack chunks; stop here. */ if (sp == NULL) break; } } } /* Local C roots */ for (lr = local_roots; lr != NULL; lr = lr->next) { for (i = 0; i < lr->ntables; i++){ for (j = 0; j < lr->nitems; j++){ root = &(lr->tables[i][j]); f (*root, root); } } } } uintnat (*caml_stack_usage_hook)(void) = NULL; uintnat caml_stack_usage (void) { uintnat sz; sz = (value *) caml_top_of_stack - (value *) caml_bottom_of_stack; if (caml_stack_usage_hook != NULL) sz += (*caml_stack_usage_hook)(); return sz; } mingw-ocaml/ocaml/asmrun/Makefile0000644000175000017500000001416412124403240016430 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### # $Id$ include ../config/Makefile CC=$(NATIVECC) FLAGS=-I../byterun -DCAML_NAME_SPACE -DNATIVE_CODE \ -DTARGET_$(ARCH) -DSYS_$(SYSTEM) $(IFLEXDIR) CFLAGS=$(FLAGS) -O $(NATIVECCCOMPOPTS) DFLAGS=$(FLAGS) -g -DDEBUG $(NATIVECCCOMPOPTS) PFLAGS=$(FLAGS) -pg -O -DPROFILING $(NATIVECCPROFOPTS) COBJS=startup.o main.o fail.o roots.o globroots.o signals.o signals_asm.o \ misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \ floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \ gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \ compact.o finalise.o custom.o unix.o backtrace.o natdynlink.o debugger.o \ meta.o dynlink.o ASMOBJS=$(ARCH).o OBJS=$(COBJS) $(ASMOBJS) DOBJS=$(COBJS:.o=.d.o) $(ASMOBJS) POBJS=$(COBJS:.o=.p.o) $(ASMOBJS:.o=.p.o) all: libasmrun.a all-$(RUNTIMED) all-$(PROFILING) libasmrun.a: $(OBJS) rm -f libasmrun.a ar rc libasmrun.a $(OBJS) $(RANLIB) libasmrun.a all-noruntimed: .PHONY: all-noruntimed all-runtimed: libasmrund.a .PHONY: all-runtimed libasmrund.a: $(DOBJS) rm -f libasmrund.a ar rc libasmrund.a $(DOBJS) $(RANLIB) libasmrund.a all-noprof: all-prof: libasmrunp.a libasmrunp.a: $(POBJS) rm -f libasmrunp.a ar rc libasmrunp.a $(POBJS) $(RANLIB) libasmrunp.a install: install-default install-$(RUNTIMED) install-$(PROFILING) install-default: cp libasmrun.a $(LIBDIR)/libasmrun.a cd $(LIBDIR); $(RANLIB) libasmrun.a install-noruntimed: .PHONY: install-noruntimed install-runtimed: cp libasmrund.a $(LIBDIR)/libasmrund.a cd $(LIBDIR); $(RANLIB) libasmrund.a .PHONY: install-runtimed install-noprof: rm -f $(LIBDIR)/libasmrunp.a; ln -s libasmrun.a $(LIBDIR)/libasmrunp.a install-prof: cp libasmrunp.a $(LIBDIR)/libasmrunp.a cd $(LIBDIR); $(RANLIB) libasmrunp.a power.o: power-$(SYSTEM).o cp power-$(SYSTEM).o power.o power.p.o: power-$(SYSTEM).o cp power-$(SYSTEM).o power.p.o main.c: ../byterun/main.c ln -s ../byterun/main.c main.c misc.c: ../byterun/misc.c ln -s ../byterun/misc.c misc.c freelist.c: ../byterun/freelist.c ln -s ../byterun/freelist.c freelist.c major_gc.c: ../byterun/major_gc.c ln -s ../byterun/major_gc.c major_gc.c minor_gc.c: ../byterun/minor_gc.c ln -s ../byterun/minor_gc.c minor_gc.c memory.c: ../byterun/memory.c ln -s ../byterun/memory.c memory.c alloc.c: ../byterun/alloc.c ln -s ../byterun/alloc.c alloc.c array.c: ../byterun/array.c ln -s ../byterun/array.c array.c compare.c: ../byterun/compare.c ln -s ../byterun/compare.c compare.c ints.c: ../byterun/ints.c ln -s ../byterun/ints.c ints.c floats.c: ../byterun/floats.c ln -s ../byterun/floats.c floats.c str.c: ../byterun/str.c ln -s ../byterun/str.c str.c io.c: ../byterun/io.c ln -s ../byterun/io.c io.c extern.c: ../byterun/extern.c ln -s ../byterun/extern.c extern.c intern.c: ../byterun/intern.c ln -s ../byterun/intern.c intern.c hash.c: ../byterun/hash.c ln -s ../byterun/hash.c hash.c sys.c: ../byterun/sys.c ln -s ../byterun/sys.c sys.c parsing.c: ../byterun/parsing.c ln -s ../byterun/parsing.c parsing.c gc_ctrl.c: ../byterun/gc_ctrl.c ln -s ../byterun/gc_ctrl.c gc_ctrl.c terminfo.c: ../byterun/terminfo.c ln -s ../byterun/terminfo.c terminfo.c md5.c: ../byterun/md5.c ln -s ../byterun/md5.c md5.c obj.c: ../byterun/obj.c ln -s ../byterun/obj.c obj.c lexing.c: ../byterun/lexing.c ln -s ../byterun/lexing.c lexing.c printexc.c: ../byterun/printexc.c ln -s ../byterun/printexc.c printexc.c callback.c: ../byterun/callback.c ln -s ../byterun/callback.c callback.c weak.c: ../byterun/weak.c ln -s ../byterun/weak.c weak.c compact.c: ../byterun/compact.c ln -s ../byterun/compact.c compact.c finalise.c: ../byterun/finalise.c ln -s ../byterun/finalise.c finalise.c custom.c: ../byterun/custom.c ln -s ../byterun/custom.c custom.c meta.c: ../byterun/meta.c ln -s ../byterun/meta.c meta.c globroots.c: ../byterun/globroots.c ln -s ../byterun/globroots.c globroots.c unix.c: ../byterun/unix.c ln -s ../byterun/unix.c unix.c dynlink.c: ../byterun/dynlink.c ln -s ../byterun/dynlink.c dynlink.c signals.c: ../byterun/signals.c ln -s ../byterun/signals.c signals.c debugger.c: ../byterun/debugger.c ln -s ../byterun/debugger.c debugger.c LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \ weak.c compact.c finalise.c meta.c custom.c main.c globroots.c unix.c \ dynlink.c signals.c debugger.c clean:: rm -f $(LINKEDFILES) .SUFFIXES: .S .d.o .p.o .S.o: $(ASPP) -DSYS_$(SYSTEM) -o $*.o $*.S || \ { echo "If your assembler produced syntax errors, it is probably unhappy with the"; echo "preprocessor. Check your assembler, or try producing $*.o by hand."; exit 2; } .S.p.o: $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.S .c.d.o: ln -s -f $*.c $*.d.c $(CC) -c $(DFLAGS) $*.d.c rm -f $*.d.c .c.p.o: ln -s -f $*.c $*.p.c $(CC) -c $(PFLAGS) $*.p.c rm -f $*.p.c .s.o: $(ASPP) -DSYS_$(SYSTEM) -o $*.o $*.s .s.p.o: $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.s clean:: rm -f *.o *.a *~ depend: $(COBJS:.o=.c) ${LINKEDFILES} -gcc -MM $(FLAGS) *.c > .depend gcc -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend gcc -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.p.o/' >> .depend include .depend mingw-ocaml/ocaml/asmrun/i386nt.asm0000644000175000017500000002351312124403240016523 0ustar tootstoots;*********************************************************************** ;* * ;* OCaml * ;* * ;* Xavier Leroy, projet Cristal, INRIA Rocquencourt * ;* * ;* Copyright 1996 Institut National de Recherche en Informatique et * ;* en Automatique. All rights reserved. This file is distributed * ;* under the terms of the GNU Library General Public License, with * ;* the special exception on linking described in file ../LICENSE. * ;* * ;*********************************************************************** ; $Id$ ; Asm part of the runtime system, Intel 386 processor, Intel syntax .386 .MODEL FLAT EXTERN _caml_garbage_collection: PROC EXTERN _caml_apply2: PROC EXTERN _caml_apply3: PROC EXTERN _caml_program: PROC EXTERN _caml_array_bound_error: PROC EXTERN _caml_young_limit: DWORD EXTERN _caml_young_ptr: DWORD EXTERN _caml_bottom_of_stack: DWORD EXTERN _caml_last_return_address: DWORD EXTERN _caml_gc_regs: DWORD EXTERN _caml_exception_pointer: DWORD EXTERN _caml_backtrace_active: DWORD EXTERN _caml_stash_backtrace: PROC ; Allocation .CODE PUBLIC _caml_alloc1 PUBLIC _caml_alloc2 PUBLIC _caml_alloc3 PUBLIC _caml_allocN PUBLIC _caml_call_gc _caml_call_gc: ; Record lowest stack address and return address mov eax, [esp] mov _caml_last_return_address, eax lea eax, [esp+4] mov _caml_bottom_of_stack, eax ; Save all regs used by the code generator L105: push ebp push edi push esi push edx push ecx push ebx push eax mov _caml_gc_regs, esp ; Call the garbage collector call _caml_garbage_collection ; Restore all regs used by the code generator pop eax pop ebx pop ecx pop edx pop esi pop edi pop ebp ; Return to caller ret ALIGN 4 _caml_alloc1: mov eax, _caml_young_ptr sub eax, 8 mov _caml_young_ptr, eax cmp eax, _caml_young_limit jb L100 ret L100: mov eax, [esp] mov _caml_last_return_address, eax lea eax, [esp+4] mov _caml_bottom_of_stack, eax call L105 jmp _caml_alloc1 ALIGN 4 _caml_alloc2: mov eax, _caml_young_ptr sub eax, 12 mov _caml_young_ptr, eax cmp eax, _caml_young_limit jb L101 ret L101: mov eax, [esp] mov _caml_last_return_address, eax lea eax, [esp+4] mov _caml_bottom_of_stack, eax call L105 jmp _caml_alloc2 ALIGN 4 _caml_alloc3: mov eax, _caml_young_ptr sub eax, 16 mov _caml_young_ptr, eax cmp eax, _caml_young_limit jb L102 ret L102: mov eax, [esp] mov _caml_last_return_address, eax lea eax, [esp+4] mov _caml_bottom_of_stack, eax call L105 jmp _caml_alloc3 ALIGN 4 _caml_allocN: sub eax, _caml_young_ptr ; eax = size - young_ptr neg eax ; eax = young_ptr - size cmp eax, _caml_young_limit jb L103 mov _caml_young_ptr, eax ret L103: sub eax, _caml_young_ptr ; eax = - size neg eax ; eax = size push eax ; save desired size sub _caml_young_ptr, eax ; must update young_ptr mov eax, [esp+4] mov _caml_last_return_address, eax lea eax, [esp+8] mov _caml_bottom_of_stack, eax call L105 pop eax ; recover desired size jmp _caml_allocN ; Call a C function from OCaml PUBLIC _caml_c_call ALIGN 4 _caml_c_call: ; Record lowest stack address and return address mov edx, [esp] mov _caml_last_return_address, edx lea edx, [esp+4] mov _caml_bottom_of_stack, edx ; Call the function (address in %eax) jmp eax ; Start the OCaml program PUBLIC _caml_start_program ALIGN 4 _caml_start_program: ; Save callee-save registers push ebx push esi push edi push ebp ; Initial code pointer is caml_program mov esi, offset _caml_program ; Code shared between caml_start_program and callback* L106: ; Build a callback link push _caml_gc_regs push _caml_last_return_address push _caml_bottom_of_stack ; Build an exception handler push L108 push _caml_exception_pointer mov _caml_exception_pointer, esp ; Call the OCaml code call esi L107: ; Pop the exception handler pop _caml_exception_pointer pop esi ; dummy register L109: ; Pop the callback link, restoring the global variables ; used by caml_c_call pop _caml_bottom_of_stack pop _caml_last_return_address pop _caml_gc_regs ; Restore callee-save registers. pop ebp pop edi pop esi pop ebx ; Return to caller. ret L108: ; Exception handler ; Mark the bucket as an exception result and return it or eax, 2 jmp L109 ; Raise an exception for OCaml PUBLIC _caml_raise_exn ALIGN 4 _caml_raise_exn: test _caml_backtrace_active, 1 jne L110 mov esp, _caml_exception_pointer pop _caml_exception_pointer ret L110: mov esi, eax ; Save exception bucket in esi mov edi, _caml_exception_pointer ; SP of handler mov eax, [esp] ; PC of raise lea edx, [esp+4] push edi ; arg 4: SP of handler push edx ; arg 3: SP of raise push eax ; arg 2: PC of raise push esi ; arg 1: exception bucket call _caml_stash_backtrace mov eax, esi ; recover exception bucket mov esp, edi ; cut the stack pop _caml_exception_pointer ret ; Raise an exception from C PUBLIC _caml_raise_exception ALIGN 4 _caml_raise_exception: test _caml_backtrace_active, 1 jne L111 mov eax, [esp+4] mov esp, _caml_exception_pointer pop _caml_exception_pointer ret L111: mov esi, [esp+4] ; Save exception bucket in esi push _caml_exception_pointer ; arg 4: SP of handler push _caml_bottom_of_stack ; arg 3: SP of raise push _caml_last_return_address ; arg 2: PC of raise push esi ; arg 1: exception bucket call _caml_stash_backtrace mov eax, esi ; recover exception bucket mov esp, _caml_exception_pointer ; cut the stack pop _caml_exception_pointer ret ; Callback from C to OCaml PUBLIC _caml_callback_exn ALIGN 4 _caml_callback_exn: ; Save callee-save registers push ebx push esi push edi push ebp ; Initial loading of arguments mov ebx, [esp+20] ; closure mov eax, [esp+24] ; argument mov esi, [ebx] ; code pointer jmp L106 PUBLIC _caml_callback2_exn ALIGN 4 _caml_callback2_exn: ; Save callee-save registers push ebx push esi push edi push ebp ; Initial loading of arguments mov ecx, [esp+20] ; closure mov eax, [esp+24] ; first argument mov ebx, [esp+28] ; second argument mov esi, offset _caml_apply2 ; code pointer jmp L106 PUBLIC _caml_callback3_exn ALIGN 4 _caml_callback3_exn: ; Save callee-save registers push ebx push esi push edi push ebp ; Initial loading of arguments mov edx, [esp+20] ; closure mov eax, [esp+24] ; first argument mov ebx, [esp+28] ; second argument mov ecx, [esp+32] ; third argument mov esi, offset _caml_apply3 ; code pointer jmp L106 PUBLIC _caml_ml_array_bound_error ALIGN 4 _caml_ml_array_bound_error: ; Empty the floating-point stack ffree st(0) ffree st(1) ffree st(2) ffree st(3) ffree st(4) ffree st(5) ffree st(6) ffree st(7) ; Branch to caml_array_bound_error mov eax, offset _caml_array_bound_error jmp _caml_c_call .DATA PUBLIC _caml_system__frametable _caml_system__frametable LABEL DWORD DWORD 1 ; one descriptor DWORD L107 ; return address into callback WORD -1 ; negative frame size => use callback link WORD 0 ; no roots here PUBLIC _caml_extra_params _caml_extra_params LABEL DWORD BYTE 64 DUP (?) END mingw-ocaml/ocaml/asmrun/amd64.S0000644000175000017500000004302512124403240016025 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2003 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Asm part of the runtime system, AMD64 processor */ /* Must be preprocessed by cpp */ /* PIC mode support based on contribution by Paul Stravers (see PR#4795) */ #include "../config/m.h" #if defined(SYS_macosx) #define LBL(x) L##x #define G(r) _##r #define GREL(r) _##r@GOTPCREL #define GCALL(r) _##r #define FUNCTION_ALIGN 2 #define EIGHT_ALIGN 3 #define SIXTEEN_ALIGN 4 #define FUNCTION(name) \ .globl name; \ .align FUNCTION_ALIGN; \ name: #elif defined(SYS_mingw64) #define LBL(x) .L##x #define G(r) r #undef GREL #define GCALL(r) r #define FUNCTION_ALIGN 4 #define EIGHT_ALIGN 8 #define SIXTEEN_ALIGN 16 #define FUNCTION(name) \ .globl name; \ .align FUNCTION_ALIGN; \ name: #else #define LBL(x) .L##x #define G(r) r #define GREL(r) r@GOTPCREL #define GCALL(r) r@PLT #define FUNCTION_ALIGN 4 #define EIGHT_ALIGN 8 #define SIXTEEN_ALIGN 16 #define FUNCTION(name) \ .globl name; \ .type name,@function; \ .align FUNCTION_ALIGN; \ name: #endif #ifdef ASM_CFI_SUPPORTED #define CFI_STARTPROC .cfi_startproc #define CFI_ENDPROC .cfi_endproc #define CFI_ADJUST(n) .cfi_adjust_cfa_offset n #else #define CFI_STARTPROC #define CFI_ENDPROC #define CFI_ADJUST(n) #endif #if defined(__PIC__) && !defined(SYS_mingw64) /* Position-independent operations on global variables. */ /* Store [srcreg] in global [dstlabel]. Clobbers %r11. */ #define STORE_VAR(srcreg,dstlabel) \ movq GREL(dstlabel)(%rip), %r11 ; \ movq srcreg, (%r11) /* Load global [srclabel] in register [dstreg]. Clobbers %r11. */ #define LOAD_VAR(srclabel,dstreg) \ movq GREL(srclabel)(%rip), %r11 ; \ movq (%r11), dstreg /* Compare global [label] with register [reg]. Clobbers %rax. */ #define CMP_VAR(label,reg) \ movq GREL(label)(%rip), %rax ; \ cmpq (%rax), reg /* Test 32-bit global [label] against mask [imm]. Clobbers %r11. */ #define TESTL_VAR(imm,label) \ movq GREL(label)(%rip), %r11 ; \ testl imm, (%r11) /* Push global [label] on stack. Clobbers %r11. */ #define PUSH_VAR(srclabel) \ movq GREL(srclabel)(%rip), %r11 ; \ pushq (%r11) /* Pop global [label] off stack. Clobbers %r11. */ #define POP_VAR(dstlabel) \ movq GREL(dstlabel)(%rip), %r11 ; \ popq (%r11) /* Record lowest stack address and return address. Clobbers %rax. */ #define RECORD_STACK_FRAME(OFFSET) \ pushq %r11 ; \ movq 8+OFFSET(%rsp), %rax ; \ STORE_VAR(%rax,caml_last_return_address) ; \ leaq 16+OFFSET(%rsp), %rax ; \ STORE_VAR(%rax,caml_bottom_of_stack) ; \ popq %r11 #else /* Non-PIC operations on global variables. Slightly faster. */ #define STORE_VAR(srcreg,dstlabel) \ movq srcreg, G(dstlabel)(%rip) #define LOAD_VAR(srclabel,dstreg) \ movq G(srclabel)(%rip), dstreg #define CMP_VAR(label,reg) \ cmpq G(label)(%rip), %r15 #define TESTL_VAR(imm,label) \ testl imm, G(label)(%rip) #define PUSH_VAR(srclabel) \ pushq G(srclabel)(%rip) #define POP_VAR(dstlabel) \ popq G(dstlabel)(%rip) #define RECORD_STACK_FRAME(OFFSET) \ movq OFFSET(%rsp), %rax ; \ STORE_VAR(%rax,caml_last_return_address) ; \ leaq 8+OFFSET(%rsp), %rax ; \ STORE_VAR(%rax,caml_bottom_of_stack) #endif /* Save and restore all callee-save registers on stack. Keep the stack 16-aligned. */ #if defined(SYS_mingw64) /* Win64 API: callee-save regs are rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 */ #define PUSH_CALLEE_SAVE_REGS \ pushq %rbx; \ pushq %rbp; \ pushq %rsi; \ pushq %rdi; \ pushq %r12; \ pushq %r13; \ pushq %r14; \ pushq %r15; \ subq $(8+10*16), %rsp; \ movupd %xmm6, 0*16(%rsp); \ movupd %xmm7, 1*16(%rsp); \ movupd %xmm8, 2*16(%rsp); \ movupd %xmm9, 3*16(%rsp); \ movupd %xmm10, 4*16(%rsp); \ movupd %xmm11, 5*16(%rsp); \ movupd %xmm12, 6*16(%rsp); \ movupd %xmm13, 7*16(%rsp); \ movupd %xmm14, 8*16(%rsp); \ movupd %xmm15, 9*16(%rsp) #define POP_CALLEE_SAVE_REGS \ movupd 0*16(%rsp), %xmm6; \ movupd 1*16(%rsp), %xmm7; \ movupd 2*16(%rsp), %xmm8; \ movupd 3*16(%rsp), %xmm9; \ movupd 4*16(%rsp), %xmm10; \ movupd 5*16(%rsp), %xmm11; \ movupd 6*16(%rsp), %xmm12; \ movupd 7*16(%rsp), %xmm13; \ movupd 8*16(%rsp), %xmm14; \ movupd 9*16(%rsp), %xmm15; \ addq $(8+10*16), %rsp; \ popq %r15; \ popq %r14; \ popq %r13; \ popq %r12; \ popq %rdi; \ popq %rsi; \ popq %rbp; \ popq %rbx #else /* Unix API: callee-save regs are rbx, rbp, r12-r15 */ #define PUSH_CALLEE_SAVE_REGS \ pushq %rbx; \ pushq %rbp; \ pushq %r12; \ pushq %r13; \ pushq %r14; \ pushq %r15; \ subq $8, %rsp #define POP_CALLEE_SAVE_REGS \ addq $8, %rsp; \ popq %r15; \ popq %r14; \ popq %r13; \ popq %r12; \ popq %rbp; \ popq %rbx #endif #ifdef SYS_mingw64 /* Calls from OCaml to C must reserve 32 bytes of extra stack space */ # define PREPARE_FOR_C_CALL subq $32, %rsp # define CLEANUP_AFTER_C_CALL addq $32, %rsp #else # define PREPARE_FOR_C_CALL # define CLEANUP_AFTER_C_CALL #endif .text .globl G(caml_system__code_begin) G(caml_system__code_begin): /* Allocation */ FUNCTION(G(caml_call_gc)) CFI_STARTPROC RECORD_STACK_FRAME(0) LBL(caml_call_gc): #ifndef SYS_mingw64 /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ subq $32768, %rsp movq %rax, 0(%rsp) addq $32768, %rsp #endif /* Build array of registers, save it into caml_gc_regs */ pushq %r11 pushq %r10 pushq %rbp pushq %r13 pushq %r12 pushq %r9 pushq %r8 pushq %rcx pushq %rdx pushq %rsi pushq %rdi pushq %rbx pushq %rax STORE_VAR(%rsp, caml_gc_regs) /* Save caml_young_ptr, caml_exception_pointer */ STORE_VAR(%r15, caml_young_ptr) STORE_VAR(%r14, caml_exception_pointer) /* Save floating-point registers */ subq $(16*8), %rsp CFI_ADJUST(232) movsd %xmm0, 0*8(%rsp) movsd %xmm1, 1*8(%rsp) movsd %xmm2, 2*8(%rsp) movsd %xmm3, 3*8(%rsp) movsd %xmm4, 4*8(%rsp) movsd %xmm5, 5*8(%rsp) movsd %xmm6, 6*8(%rsp) movsd %xmm7, 7*8(%rsp) movsd %xmm8, 8*8(%rsp) movsd %xmm9, 9*8(%rsp) movsd %xmm10, 10*8(%rsp) movsd %xmm11, 11*8(%rsp) movsd %xmm12, 12*8(%rsp) movsd %xmm13, 13*8(%rsp) movsd %xmm14, 14*8(%rsp) movsd %xmm15, 15*8(%rsp) /* Call the garbage collector */ PREPARE_FOR_C_CALL call GCALL(caml_garbage_collection) CLEANUP_AFTER_C_CALL /* Restore caml_young_ptr, caml_exception_pointer */ LOAD_VAR(caml_young_ptr, %r15) LOAD_VAR(caml_exception_pointer, %r14) /* Restore all regs used by the code generator */ movsd 0*8(%rsp), %xmm0 movsd 1*8(%rsp), %xmm1 movsd 2*8(%rsp), %xmm2 movsd 3*8(%rsp), %xmm3 movsd 4*8(%rsp), %xmm4 movsd 5*8(%rsp), %xmm5 movsd 6*8(%rsp), %xmm6 movsd 7*8(%rsp), %xmm7 movsd 8*8(%rsp), %xmm8 movsd 9*8(%rsp), %xmm9 movsd 10*8(%rsp), %xmm10 movsd 11*8(%rsp), %xmm11 movsd 12*8(%rsp), %xmm12 movsd 13*8(%rsp), %xmm13 movsd 14*8(%rsp), %xmm14 movsd 15*8(%rsp), %xmm15 addq $(16*8), %rsp popq %rax popq %rbx popq %rdi popq %rsi popq %rdx popq %rcx popq %r8 popq %r9 popq %r12 popq %r13 popq %rbp popq %r10 popq %r11 CFI_ADJUST(-232) /* Return to caller */ ret CFI_ENDPROC FUNCTION(G(caml_alloc1)) LBL(caml_alloc1): subq $16, %r15 CMP_VAR(caml_young_limit, %r15) jb LBL(100) ret LBL(100): RECORD_STACK_FRAME(0) subq $8, %rsp call LBL(caml_call_gc) addq $8, %rsp jmp LBL(caml_alloc1) FUNCTION(G(caml_alloc2)) LBL(caml_alloc2): subq $24, %r15 CMP_VAR(caml_young_limit, %r15) jb LBL(101) ret LBL(101): RECORD_STACK_FRAME(0) subq $8, %rsp call LBL(caml_call_gc) addq $8, %rsp jmp LBL(caml_alloc2) FUNCTION(G(caml_alloc3)) LBL(caml_alloc3): subq $32, %r15 CMP_VAR(caml_young_limit, %r15) jb LBL(102) ret LBL(102): RECORD_STACK_FRAME(0) subq $8, %rsp call LBL(caml_call_gc) addq $8, %rsp jmp LBL(caml_alloc3) FUNCTION(G(caml_allocN)) LBL(caml_allocN): pushq %rax /* save desired size */ subq %rax, %r15 CMP_VAR(caml_young_limit, %r15) jb LBL(103) addq $8, %rsp /* drop desired size */ ret LBL(103): RECORD_STACK_FRAME(8) call LBL(caml_call_gc) popq %rax /* recover desired size */ jmp LBL(caml_allocN) /* Call a C function from OCaml */ FUNCTION(G(caml_c_call)) LBL(caml_c_call): /* Record lowest stack address and return address */ popq %r12 STORE_VAR(%r12, caml_last_return_address) STORE_VAR(%rsp, caml_bottom_of_stack) pushq %r12 #ifndef SYS_mingw64 /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ subq $32768, %rsp movq %rax, 0(%rsp) addq $32768, %rsp #endif /* Make the exception handler and alloc ptr available to the C code */ STORE_VAR(%r15, caml_young_ptr) STORE_VAR(%r14, caml_exception_pointer) /* Call the function (address in %rax) */ /* No need to PREPARE_FOR_C_CALL since the caller already reserved the stack space if needed (cf. amd64/proc.ml) */ jmp *%rax /* Start the OCaml program */ FUNCTION(G(caml_start_program)) CFI_STARTPROC /* Save callee-save registers */ PUSH_CALLEE_SAVE_REGS CFI_ADJUST(56) /* Initial entry point is G(caml_program) */ leaq GCALL(caml_program)(%rip), %r12 /* Common code for caml_start_program and caml_callback* */ LBL(caml_start_program): /* Build a callback link */ subq $8, %rsp /* stack 16-aligned */ PUSH_VAR(caml_gc_regs) PUSH_VAR(caml_last_return_address) PUSH_VAR(caml_bottom_of_stack) CFI_ADJUST(32) /* Setup alloc ptr and exception ptr */ LOAD_VAR(caml_young_ptr, %r15) LOAD_VAR(caml_exception_pointer, %r14) /* Build an exception handler */ lea LBL(108)(%rip), %r13 pushq %r13 pushq %r14 CFI_ADJUST(16) movq %rsp, %r14 /* Call the OCaml code */ call *%r12 LBL(107): /* Pop the exception handler */ popq %r14 popq %r12 /* dummy register */ CFI_ADJUST(-16) LBL(109): /* Update alloc ptr and exception ptr */ STORE_VAR(%r15,caml_young_ptr) STORE_VAR(%r14,caml_exception_pointer) /* Pop the callback link, restoring the global variables */ POP_VAR(caml_bottom_of_stack) POP_VAR(caml_last_return_address) POP_VAR(caml_gc_regs) addq $8, %rsp /* Restore callee-save registers. */ POP_CALLEE_SAVE_REGS /* Return to caller. */ ret LBL(108): /* Exception handler*/ /* Mark the bucket as an exception result and return it */ orq $2, %rax jmp LBL(109) CFI_ENDPROC /* Registers holding arguments of C functions. */ #ifdef SYS_mingw64 #define C_ARG_1 %rcx #define C_ARG_2 %rdx #define C_ARG_3 %r8 #define C_ARG_4 %r9 #else #define C_ARG_1 %rdi #define C_ARG_2 %rsi #define C_ARG_3 %rdx #define C_ARG_4 %rcx #endif /* Raise an exception from OCaml */ FUNCTION(G(caml_raise_exn)) TESTL_VAR($1, caml_backtrace_active) jne LBL(110) movq %r14, %rsp popq %r14 ret LBL(110): movq %rax, %r12 /* Save exception bucket */ movq %rax, C_ARG_1 /* arg 1: exception bucket */ popq C_ARG_2 /* arg 2: pc of raise */ movq %rsp, C_ARG_3 /* arg 3: sp at raise */ movq %r14, C_ARG_4 /* arg 4: sp of handler */ /* PR#5700: thanks to popq above, stack is now 16-aligned */ PREPARE_FOR_C_CALL /* no need to cleanup after */ call GCALL(caml_stash_backtrace) movq %r12, %rax /* Recover exception bucket */ movq %r14, %rsp popq %r14 ret /* Raise an exception from C */ FUNCTION(G(caml_raise_exception)) TESTL_VAR($1, caml_backtrace_active) jne LBL(111) movq C_ARG_1, %rax LOAD_VAR(caml_exception_pointer, %rsp) /* Cut stack */ popq %r14 /* Recover previous exception handler */ LOAD_VAR(caml_young_ptr, %r15) /* Reload alloc ptr */ ret LBL(111): movq C_ARG_1, %r12 /* Save exception bucket */ /* arg 1: exception bucket */ LOAD_VAR(caml_last_return_address,C_ARG_2) /* arg 2: pc of raise */ LOAD_VAR(caml_bottom_of_stack,C_ARG_3) /* arg 3: sp of raise */ LOAD_VAR(caml_exception_pointer,C_ARG_4) /* arg 4: sp of handler */ subq $8, %rsp /* PR#5700: maintain stack alignment */ PREPARE_FOR_C_CALL /* no need to cleanup after */ call GCALL(caml_stash_backtrace) movq %r12, %rax /* Recover exception bucket */ LOAD_VAR(caml_exception_pointer,%rsp) popq %r14 /* Recover previous exception handler */ LOAD_VAR(caml_young_ptr,%r15) /* Reload alloc ptr */ ret /* Callback from C to OCaml */ FUNCTION(G(caml_callback_exn)) /* Save callee-save registers */ PUSH_CALLEE_SAVE_REGS /* Initial loading of arguments */ movq C_ARG_1, %rbx /* closure */ movq C_ARG_2, %rax /* argument */ movq 0(%rbx), %r12 /* code pointer */ jmp LBL(caml_start_program) FUNCTION(G(caml_callback2_exn)) /* Save callee-save registers */ PUSH_CALLEE_SAVE_REGS /* Initial loading of arguments */ movq C_ARG_1, %rdi /* closure -- no op with Unix conventions */ movq C_ARG_2, %rax /* first argument */ movq C_ARG_3, %rbx /* second argument */ leaq GCALL(caml_apply2)(%rip), %r12 /* code pointer */ jmp LBL(caml_start_program) FUNCTION(G(caml_callback3_exn)) /* Save callee-save registers */ PUSH_CALLEE_SAVE_REGS /* Initial loading of arguments */ movq C_ARG_2, %rax /* first argument */ movq C_ARG_3, %rbx /* second argument */ movq C_ARG_1, %rsi /* closure */ movq C_ARG_4, %rdi /* third argument */ leaq GCALL(caml_apply3)(%rip), %r12 /* code pointer */ jmp LBL(caml_start_program) FUNCTION(G(caml_ml_array_bound_error)) leaq GCALL(caml_array_bound_error)(%rip), %rax jmp LBL(caml_c_call) .globl G(caml_system__code_end) G(caml_system__code_end): .data .globl G(caml_system__frametable) .align EIGHT_ALIGN G(caml_system__frametable): .quad 1 /* one descriptor */ .quad LBL(107) /* return address into callback */ .value -1 /* negative frame size => use callback link */ .value 0 /* no roots here */ .align EIGHT_ALIGN #if defined(SYS_macosx) .literal16 #elif defined(SYS_mingw64) .section .rdata,"dr" #else .section .rodata.cst8,"a",@progbits #endif .globl G(caml_negf_mask) .align SIXTEEN_ALIGN G(caml_negf_mask): .quad 0x8000000000000000, 0 .globl G(caml_absf_mask) .align SIXTEEN_ALIGN G(caml_absf_mask): .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF #if defined(SYS_linux) /* Mark stack as non-executable, PR#4564 */ .section .note.GNU-stack,"",%progbits #endif mingw-ocaml/ocaml/asmrun/Makefile.nt0000644000175000017500000000530512124403240017045 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### # $Id$ include ../config/Makefile CC=$(NATIVECC) CFLAGS=-I../byterun -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) $(NATIVECCCOMPOPTS) COBJS=startup.$(O) main.$(O) fail.$(O) roots.$(O) signals.$(O) signals_asm.$(O) \ misc.$(O) freelist.$(O) major_gc.$(O) minor_gc.$(O) memory.$(O) alloc.$(O) \ compare.$(O) ints.$(O) floats.$(O) str.$(O) array.$(O) io.$(O) extern.$(O) \ intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) terminfo.$(O) \ md5.$(O) obj.$(O) lexing.$(O) win32.$(O) printexc.$(O) callback.$(O) \ weak.$(O) compact.$(O) finalise.$(O) custom.$(O) globroots.$(O) \ backtrace.$(O) natdynlink.$(O) debugger.$(O) meta.$(O) dynlink.$(O) LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \ weak.c compact.c meta.c finalise.c custom.c main.c globroots.c \ dynlink.c signals.c debugger.c ifeq ($(TOOLCHAIN),mingw) ASMOBJS=$(ARCH).o else ASMOBJS=$(ARCH)nt.obj endif OBJS=$(COBJS) $(ASMOBJS) all: libasmrun.$(A) libasmrun.$(A): $(OBJS) $(call MKLIB,libasmrun.$(A), $(OBJS)) i386nt.obj: i386nt.asm $(ASM)i386nt.obj i386nt.asm amd64nt.obj: amd64nt.asm $(ASM)amd64nt.obj amd64nt.asm i386.o: i386.S $(CC) -c -DSYS_$(SYSTEM) i386.S amd64.o: amd64.S $(CC) -c -DSYS_$(SYSTEM) amd64.S install: cp libasmrun.$(A) $(LIBDIR) $(LINKEDFILES): %.c: ../byterun/%.c cp ../byterun/$*.c $*.c # Need special compilation rule so as not to do -I../byterun win32.$(O): ../byterun/win32.c $(CC) -c $(NATIVECCCOMPOPTS) -DNATIVE_CODE $(IFLEXDIR) ../byterun/win32.c .SUFFIXES: .c .$(O) .c.$(O): $(CC) $(CFLAGS) -c $< clean:: rm -f $(LINKEDFILES) clean:: rm -f *.$(O) *.$(A) *~ .depend.nt: .depend sed -e 's/\.o/.$(O)/g' .depend > .depend.nt include .depend.nt mingw-ocaml/ocaml/asmrun/fail.c0000644000175000017500000001342612124403240016047 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Raising exceptions from C. */ #include #include "alloc.h" #include "fail.h" #include "io.h" #include "gc.h" #include "memory.h" #include "mlvalues.h" #include "printexc.h" #include "signals.h" #include "stack.h" #include "roots.h" /* The globals holding predefined exceptions */ typedef value caml_generated_constant[1]; extern caml_generated_constant caml_exn_Out_of_memory, caml_exn_Sys_error, caml_exn_Failure, caml_exn_Invalid_argument, caml_exn_End_of_file, caml_exn_Division_by_zero, caml_exn_Not_found, caml_exn_Match_failure, caml_exn_Sys_blocked_io, caml_exn_Stack_overflow, caml_exn_Assert_failure, caml_exn_Undefined_recursive_module; extern caml_generated_constant caml_bucket_Out_of_memory, caml_bucket_Stack_overflow; /* Exception raising */ extern void caml_raise_exception (value bucket) Noreturn; char * caml_exception_pointer = NULL; void caml_raise(value v) { Unlock_exn(); if (caml_exception_pointer == NULL) caml_fatal_uncaught_exception(v); #ifndef Stack_grows_upwards #define PUSHED_AFTER < #else #define PUSHED_AFTER > #endif while (caml_local_roots != NULL && (char *) caml_local_roots PUSHED_AFTER caml_exception_pointer) { caml_local_roots = caml_local_roots->next; } #undef PUSHED_AFTER caml_raise_exception(v); } void caml_raise_constant(value tag) { CAMLparam1 (tag); CAMLlocal1 (bucket); bucket = caml_alloc_small (1, 0); Field(bucket, 0) = tag; caml_raise(bucket); CAMLnoreturn; } void caml_raise_with_arg(value tag, value arg) { CAMLparam2 (tag, arg); CAMLlocal1 (bucket); bucket = caml_alloc_small (2, 0); Field(bucket, 0) = tag; Field(bucket, 1) = arg; caml_raise(bucket); CAMLnoreturn; } void caml_raise_with_args(value tag, int nargs, value args[]) { CAMLparam1 (tag); CAMLxparamN (args, nargs); value bucket; int i; Assert(1 + nargs <= Max_young_wosize); bucket = caml_alloc_small (1 + nargs, 0); Field(bucket, 0) = tag; for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i]; caml_raise(bucket); CAMLnoreturn; } void caml_raise_with_string(value tag, char const *msg) { caml_raise_with_arg(tag, caml_copy_string(msg)); } void caml_failwith (char const *msg) { caml_raise_with_string((value) caml_exn_Failure, msg); } void caml_invalid_argument (char const *msg) { caml_raise_with_string((value) caml_exn_Invalid_argument, msg); } /* To raise [Out_of_memory], we can't use [caml_raise_constant], because it allocates and we're out of memory... We therefore use a statically-allocated bucket constructed by the ocamlopt linker. This works OK because the exception value for [Out_of_memory] is also statically allocated out of the heap. The same applies to Stack_overflow. */ void caml_raise_out_of_memory(void) { caml_raise((value) &caml_bucket_Out_of_memory); } void caml_raise_stack_overflow(void) { caml_raise((value) &caml_bucket_Stack_overflow); } void caml_raise_sys_error(value msg) { caml_raise_with_arg((value) caml_exn_Sys_error, msg); } void caml_raise_end_of_file(void) { caml_raise_constant((value) caml_exn_End_of_file); } void caml_raise_zero_divide(void) { caml_raise_constant((value) caml_exn_Division_by_zero); } void caml_raise_not_found(void) { caml_raise_constant((value) caml_exn_Not_found); } void caml_raise_sys_blocked_io(void) { caml_raise_constant((value) caml_exn_Sys_blocked_io); } /* We allocate statically the bucket for the exception because we can't do a GC before the exception is raised (lack of stack descriptors for the ccall to [caml_array_bound_error]. */ #define BOUND_MSG "index out of bounds" #define BOUND_MSG_LEN (sizeof(BOUND_MSG) - 1) static struct { header_t hdr; value exn; value arg; } array_bound_error_bucket; static struct { header_t hdr; char data[BOUND_MSG_LEN + sizeof(value)]; } array_bound_error_msg = { 0, BOUND_MSG }; static int array_bound_error_bucket_inited = 0; void caml_array_bound_error(void) { if (! array_bound_error_bucket_inited) { mlsize_t wosize = (BOUND_MSG_LEN + sizeof(value)) / sizeof(value); mlsize_t offset_index = Bsize_wsize(wosize) - 1; array_bound_error_msg.hdr = Make_header(wosize, String_tag, Caml_white); array_bound_error_msg.data[offset_index] = offset_index - BOUND_MSG_LEN; array_bound_error_bucket.hdr = Make_header(2, 0, Caml_white); array_bound_error_bucket.exn = (value) caml_exn_Invalid_argument; array_bound_error_bucket.arg = (value) array_bound_error_msg.data; array_bound_error_bucket_inited = 1; caml_page_table_add(In_static_data, &array_bound_error_msg, &array_bound_error_msg + 1); array_bound_error_bucket_inited = 1; } caml_raise((value) &array_bound_error_bucket.exn); } int caml_is_special_exception(value exn) { return exn == (value) caml_exn_Match_failure || exn == (value) caml_exn_Assert_failure || exn == (value) caml_exn_Undefined_recursive_module; } mingw-ocaml/ocaml/asmrun/signals_asm.c0000644000175000017500000001721512124403240017434 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ /* */ /* Copyright 2007 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Signal handling, code specific to the native-code compiler */ #if defined(TARGET_amd64) && defined (SYS_linux) #define _GNU_SOURCE #endif #include #include #include "fail.h" #include "memory.h" #include "osdeps.h" #include "signals.h" #include "signals_machdep.h" #include "signals_osdep.h" #include "stack.h" #ifdef HAS_STACK_OVERFLOW_DETECTION #include #include #endif #ifndef NSIG #define NSIG 64 #endif typedef void (*signal_handler)(int signo); #ifdef _WIN32 extern signal_handler caml_win32_signal(int sig, signal_handler action); #define signal(sig,act) caml_win32_signal(sig,act) extern void caml_win32_overflow_detection(); #endif extern char * caml_code_area_start, * caml_code_area_end; extern char caml_system__code_begin, caml_system__code_end; #define Is_in_code_area(pc) \ ( ((char *)(pc) >= caml_code_area_start && \ (char *)(pc) <= caml_code_area_end) \ || ((char *)(pc) >= &caml_system__code_begin && \ (char *)(pc) <= &caml_system__code_end) \ || (Classify_addr(pc) & In_code_area) ) /* This routine is the common entry point for garbage collection and signal handling. It can trigger a callback to OCaml code. With system threads, this callback can cause a context switch. Hence [caml_garbage_collection] must not be called from regular C code (e.g. the [caml_alloc] function) because the context of the call (e.g. [intern_val]) may not allow context switching. Only generated assembly code can call [caml_garbage_collection], via the caml_call_gc assembly stubs. */ void caml_garbage_collection(void) { caml_young_limit = caml_young_start; if (caml_young_ptr < caml_young_start || caml_force_major_slice) { caml_minor_collection(); } caml_process_pending_signals(); } DECLARE_SIGNAL_HANDLER(handle_signal) { #if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS) signal(sig, handle_signal); #endif if (sig < 0 || sig >= NSIG) return; if (caml_try_leave_blocking_section_hook ()) { caml_execute_signal(sig, 1); caml_enter_blocking_section_hook(); } else { caml_record_signal(sig); /* Some ports cache [caml_young_limit] in a register. Use the signal context to modify that register too, but only if we are inside OCaml code (not inside C code). */ #if defined(CONTEXT_PC) && defined(CONTEXT_YOUNG_LIMIT) if (Is_in_code_area(CONTEXT_PC)) CONTEXT_YOUNG_LIMIT = (context_reg) caml_young_limit; #endif } } int caml_set_signal_action(int signo, int action) { signal_handler oldact; #ifdef POSIX_SIGNALS struct sigaction sigact, oldsigact; #else signal_handler act; #endif #ifdef POSIX_SIGNALS switch(action) { case 0: sigact.sa_handler = SIG_DFL; sigact.sa_flags = 0; break; case 1: sigact.sa_handler = SIG_IGN; sigact.sa_flags = 0; break; default: SET_SIGACT(sigact, handle_signal); break; } sigemptyset(&sigact.sa_mask); if (sigaction(signo, &sigact, &oldsigact) == -1) return -1; oldact = oldsigact.sa_handler; #else switch(action) { case 0: act = SIG_DFL; break; case 1: act = SIG_IGN; break; default: act = handle_signal; break; } oldact = signal(signo, act); if (oldact == SIG_ERR) return -1; #endif if (oldact == (signal_handler) handle_signal) return 2; else if (oldact == SIG_IGN) return 1; else return 0; } /* Machine- and OS-dependent handling of bound check trap */ #if defined(TARGET_power) || (defined(TARGET_sparc) && defined(SYS_solaris)) DECLARE_SIGNAL_HANDLER(trap_handler) { #if defined(SYS_solaris) if (info->si_code != ILL_ILLTRP) { /* Deactivate our exception handler and return. */ struct sigaction act; act.sa_handler = SIG_DFL; act.sa_flags = 0; sigemptyset(&act.sa_mask); sigaction(sig, &act, NULL); return; } #endif #if defined(SYS_rhapsody) /* Unblock SIGTRAP */ { sigset_t mask; sigemptyset(&mask); sigaddset(&mask, SIGTRAP); sigprocmask(SIG_UNBLOCK, &mask, NULL); } #endif caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER; caml_young_ptr = (char *) CONTEXT_YOUNG_PTR; #if defined(SYS_rhapsody) caml_bottom_of_stack = (char *) CONTEXT_SP; caml_last_return_address = (uintnat) CONTEXT_PC; #endif caml_array_bound_error(); } #endif /* Machine- and OS-dependent handling of stack overflow */ #ifdef HAS_STACK_OVERFLOW_DETECTION static char * system_stack_top; static char sig_alt_stack[SIGSTKSZ]; #if defined(SYS_linux) /* PR#4746: recent Linux kernels with support for stack randomization silently add 2 Mb of stack space on top of RLIMIT_STACK. 2 Mb = 0x200000, to which we add 8 kB (=0x2000) for overshoot. */ #define EXTRA_STACK 0x202000 #else #define EXTRA_STACK 0x2000 #endif DECLARE_SIGNAL_HANDLER(segv_handler) { struct rlimit limit; struct sigaction act; char * fault_addr; /* Sanity checks: - faulting address is word-aligned - faulting address is within the stack - we are in OCaml code */ fault_addr = CONTEXT_FAULTING_ADDRESS; if (((uintnat) fault_addr & (sizeof(intnat) - 1)) == 0 && getrlimit(RLIMIT_STACK, &limit) == 0 && fault_addr < system_stack_top && fault_addr >= system_stack_top - limit.rlim_cur - EXTRA_STACK #ifdef CONTEXT_PC && Is_in_code_area(CONTEXT_PC) #endif ) { /* Turn this into a Stack_overflow exception */ #if defined(CONTEXT_YOUNG_PTR) && defined(CONTEXT_EXCEPTION_POINTER) caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER; caml_young_ptr = (char *) CONTEXT_YOUNG_PTR; #endif caml_raise_stack_overflow(); } /* Otherwise, deactivate our exception handler and return, causing fatal signal to be generated at point of error. */ act.sa_handler = SIG_DFL; act.sa_flags = 0; sigemptyset(&act.sa_mask); sigaction(SIGSEGV, &act, NULL); } #endif /* Initialization of signal stuff */ void caml_init_signals(void) { /* Bound-check trap handling */ #if defined(TARGET_sparc) && defined(SYS_solaris) { struct sigaction act; sigemptyset(&act.sa_mask); SET_SIGACT(act, trap_handler); act.sa_flags |= SA_NODEFER; sigaction(SIGILL, &act, NULL); } #endif #if defined(TARGET_power) { struct sigaction act; sigemptyset(&act.sa_mask); SET_SIGACT(act, trap_handler); #if !defined(SYS_rhapsody) act.sa_flags |= SA_NODEFER; #endif sigaction(SIGTRAP, &act, NULL); } #endif /* Stack overflow handling */ #ifdef HAS_STACK_OVERFLOW_DETECTION { stack_t stk; struct sigaction act; stk.ss_sp = sig_alt_stack; stk.ss_size = SIGSTKSZ; stk.ss_flags = 0; SET_SIGACT(act, segv_handler); act.sa_flags |= SA_ONSTACK | SA_NODEFER; sigemptyset(&act.sa_mask); system_stack_top = (char *) &act; if (sigaltstack(&stk, NULL) == 0) { sigaction(SIGSEGV, &act, NULL); } } #endif #if defined(_WIN32) && !defined(_WIN64) caml_win32_overflow_detection(); #endif } mingw-ocaml/ocaml/asmrun/amd64nt.asm0000644000175000017500000003642712124403240016755 0ustar tootstoots;*********************************************************************** ;* * ;* OCaml * ;* * ;* Xavier Leroy, projet Gallium, INRIA Rocquencourt * ;* * ;* Copyright 2006 Institut National de Recherche en Informatique et * ;* en Automatique. All rights reserved. This file is distributed * ;* under the terms of the GNU Library General Public License, with * ;* the special exception on linking described in file ../LICENSE. * ;* * ;*********************************************************************** ; $Id$ ; Asm part of the runtime system, AMD64 processor, Intel syntax ; Notes on Win64 calling conventions: ; function arguments in RCX, RDX, R8, R9 / XMM0 - XMM3 ; caller must reserve 32 bytes of stack space ; callee must preserve RBX, RBP, RSI, RDI, R12-R15, XMM6-XMM15 EXTRN caml_garbage_collection: NEAR EXTRN caml_apply2: NEAR EXTRN caml_apply3: NEAR EXTRN caml_program: NEAR EXTRN caml_array_bound_error: NEAR EXTRN caml_young_limit: QWORD EXTRN caml_young_ptr: QWORD EXTRN caml_bottom_of_stack: QWORD EXTRN caml_last_return_address: QWORD EXTRN caml_gc_regs: QWORD EXTRN caml_exception_pointer: QWORD EXTRN caml_backtrace_active: DWORD EXTRN caml_stash_backtrace: NEAR .CODE ; Allocation PUBLIC caml_call_gc ALIGN 16 caml_call_gc: ; Record lowest stack address and return address mov rax, [rsp] mov caml_last_return_address, rax lea rax, [rsp+8] mov caml_bottom_of_stack, rax L105: ; Save caml_young_ptr, caml_exception_pointer mov caml_young_ptr, r15 mov caml_exception_pointer, r14 ; Build array of registers, save it into caml_gc_regs push r11 push r10 push rbp push r13 push r12 push r9 push r8 push rcx push rdx push rsi push rdi push rbx push rax mov caml_gc_regs, rsp ; Save floating-point registers sub rsp, 16*8 movsd QWORD PTR [rsp + 0*8], xmm0 movsd QWORD PTR [rsp + 1*8], xmm1 movsd QWORD PTR [rsp + 2*8], xmm2 movsd QWORD PTR [rsp + 3*8], xmm3 movsd QWORD PTR [rsp + 4*8], xmm4 movsd QWORD PTR [rsp + 5*8], xmm5 movsd QWORD PTR [rsp + 6*8], xmm6 movsd QWORD PTR [rsp + 7*8], xmm7 movsd QWORD PTR [rsp + 8*8], xmm8 movsd QWORD PTR [rsp + 9*8], xmm9 movsd QWORD PTR [rsp + 10*8], xmm10 movsd QWORD PTR [rsp + 11*8], xmm11 movsd QWORD PTR [rsp + 12*8], xmm12 movsd QWORD PTR [rsp + 13*8], xmm13 movsd QWORD PTR [rsp + 14*8], xmm14 movsd QWORD PTR [rsp + 15*8], xmm15 ; Call the garbage collector sub rsp, 32 ; PR#5008: bottom 32 bytes are reserved for callee call caml_garbage_collection add rsp, 32 ; PR#5008 ; Restore all regs used by the code generator movsd xmm0, QWORD PTR [rsp + 0*8] movsd xmm1, QWORD PTR [rsp + 1*8] movsd xmm2, QWORD PTR [rsp + 2*8] movsd xmm3, QWORD PTR [rsp + 3*8] movsd xmm4, QWORD PTR [rsp + 4*8] movsd xmm5, QWORD PTR [rsp + 5*8] movsd xmm6, QWORD PTR [rsp + 6*8] movsd xmm7, QWORD PTR [rsp + 7*8] movsd xmm8, QWORD PTR [rsp + 8*8] movsd xmm9, QWORD PTR [rsp + 9*8] movsd xmm10, QWORD PTR [rsp + 10*8] movsd xmm11, QWORD PTR [rsp + 11*8] movsd xmm12, QWORD PTR [rsp + 12*8] movsd xmm13, QWORD PTR [rsp + 13*8] movsd xmm14, QWORD PTR [rsp + 14*8] movsd xmm15, QWORD PTR [rsp + 15*8] add rsp, 16*8 pop rax pop rbx pop rdi pop rsi pop rdx pop rcx pop r8 pop r9 pop r12 pop r13 pop rbp pop r10 pop r11 ; Restore caml_young_ptr, caml_exception_pointer mov r15, caml_young_ptr mov r14, caml_exception_pointer ; Return to caller ret PUBLIC caml_alloc1 ALIGN 16 caml_alloc1: sub r15, 16 cmp r15, caml_young_limit jb L100 ret L100: mov rax, [rsp + 0] mov caml_last_return_address, rax lea rax, [rsp + 8] mov caml_bottom_of_stack, rax sub rsp, 8 call L105 add rsp, 8 jmp caml_alloc1 PUBLIC caml_alloc2 ALIGN 16 caml_alloc2: sub r15, 24 cmp r15, caml_young_limit jb L101 ret L101: mov rax, [rsp + 0] mov caml_last_return_address, rax lea rax, [rsp + 8] mov caml_bottom_of_stack, rax sub rsp, 8 call L105 add rsp, 8 jmp caml_alloc2 PUBLIC caml_alloc3 ALIGN 16 caml_alloc3: sub r15, 32 cmp r15, caml_young_limit jb L102 ret L102: mov rax, [rsp + 0] mov caml_last_return_address, rax lea rax, [rsp + 8] mov caml_bottom_of_stack, rax sub rsp, 8 call L105 add rsp, 8 jmp caml_alloc3 PUBLIC caml_allocN ALIGN 16 caml_allocN: sub r15, rax cmp r15, caml_young_limit jb L103 ret L103: push rax ; save desired size mov rax, [rsp + 8] mov caml_last_return_address, rax lea rax, [rsp + 16] mov caml_bottom_of_stack, rax call L105 pop rax ; recover desired size jmp caml_allocN ; Call a C function from OCaml PUBLIC caml_c_call ALIGN 16 caml_c_call: ; Record lowest stack address and return address pop r12 mov caml_last_return_address, r12 mov caml_bottom_of_stack, rsp ; Make the exception handler and alloc ptr available to the C code mov caml_young_ptr, r15 mov caml_exception_pointer, r14 ; Call the function (address in rax) call rax ; Reload alloc ptr mov r15, caml_young_ptr ; Return to caller push r12 ret ; Start the OCaml program PUBLIC caml_start_program ALIGN 16 caml_start_program: ; Save callee-save registers push rbx push rbp push rsi push rdi push r12 push r13 push r14 push r15 sub rsp, 8+10*16 ; stack 16-aligned + 10 saved xmm regs movapd OWORD PTR [rsp + 0*16], xmm6 movapd OWORD PTR [rsp + 1*16], xmm7 movapd OWORD PTR [rsp + 2*16], xmm8 movapd OWORD PTR [rsp + 3*16], xmm9 movapd OWORD PTR [rsp + 4*16], xmm10 movapd OWORD PTR [rsp + 5*16], xmm11 movapd OWORD PTR [rsp + 6*16], xmm12 movapd OWORD PTR [rsp + 7*16], xmm13 movapd OWORD PTR [rsp + 8*16], xmm14 movapd OWORD PTR [rsp + 9*16], xmm15 ; Initial entry point is caml_program lea r12, caml_program ; Common code for caml_start_program and caml_callback* L106: ; Build a callback link sub rsp, 8 ; stack 16-aligned push caml_gc_regs push caml_last_return_address push caml_bottom_of_stack ; Setup alloc ptr and exception ptr mov r15, caml_young_ptr mov r14, caml_exception_pointer ; Build an exception handler lea r13, L108 push r13 push r14 mov r14, rsp ; Call the OCaml code call r12 L107: ; Pop the exception handler pop r14 pop r12 ; dummy register L109: ; Update alloc ptr and exception ptr mov caml_young_ptr, r15 mov caml_exception_pointer, r14 ; Pop the callback restoring, link the global variables pop caml_bottom_of_stack pop caml_last_return_address pop caml_gc_regs add rsp, 8 ; Restore callee-save registers. movapd xmm6, OWORD PTR [rsp + 0*16] movapd xmm7, OWORD PTR [rsp + 1*16] movapd xmm8, OWORD PTR [rsp + 2*16] movapd xmm9, OWORD PTR [rsp + 3*16] movapd xmm10, OWORD PTR [rsp + 4*16] movapd xmm11, OWORD PTR [rsp + 5*16] movapd xmm12, OWORD PTR [rsp + 6*16] movapd xmm13, OWORD PTR [rsp + 7*16] movapd xmm14, OWORD PTR [rsp + 8*16] movapd xmm15, OWORD PTR [rsp + 9*16] add rsp, 8+10*16 pop r15 pop r14 pop r13 pop r12 pop rdi pop rsi pop rbp pop rbx ; Return to caller ret L108: ; Exception handler ; Mark the bucket as an exception result and return it or rax, 2 jmp L109 ; Raise an exception from OCaml PUBLIC caml_raise_exn ALIGN 16 caml_raise_exn: test caml_backtrace_active, 1 jne L110 mov rsp, r14 ; Cut stack pop r14 ; Recover previous exception handler ret ; Branch to handler L110: mov r12, rax ; Save exception bucket in r12 mov rcx, rax ; Arg 1: exception bucket mov rdx, [rsp] ; Arg 2: PC of raise lea r8, [rsp+8] ; Arg 3: SP of raise mov r9, r14 ; Arg 4: SP of handler sub rsp, 32 ; Reserve 32 bytes on stack call caml_stash_backtrace mov rax, r12 ; Recover exception bucket mov rsp, r14 ; Cut stack pop r14 ; Recover previous exception handler ret ; Branch to handler ; Raise an exception from C PUBLIC caml_raise_exception ALIGN 16 caml_raise_exception: test caml_backtrace_active, 1 jne L111 mov rax, rcx ; First argument is exn bucket mov rsp, caml_exception_pointer pop r14 ; Recover previous exception handler mov r15, caml_young_ptr ; Reload alloc ptr ret L111: mov r12, rcx ; Save exception bucket in r12 ; Arg 1: exception bucket mov rdx, caml_last_return_address ; Arg 2: PC of raise mov r8, caml_bottom_of_stack ; Arg 3: SP of raise mov r9, caml_exception_pointer ; Arg 4: SP of handler sub rsp, 32 ; Reserve 32 bytes on stack call caml_stash_backtrace mov rax, r12 ; Recover exception bucket mov rsp, caml_exception_pointer pop r14 ; Recover previous exception handler mov r15, caml_young_ptr ; Reload alloc ptr ret ; Callback from C to OCaml PUBLIC caml_callback_exn ALIGN 16 caml_callback_exn: ; Save callee-save registers push rbx push rbp push rsi push rdi push r12 push r13 push r14 push r15 sub rsp, 8+10*16 ; stack 16-aligned + 10 saved xmm regs movapd OWORD PTR [rsp + 0*16], xmm6 movapd OWORD PTR [rsp + 1*16], xmm7 movapd OWORD PTR [rsp + 2*16], xmm8 movapd OWORD PTR [rsp + 3*16], xmm9 movapd OWORD PTR [rsp + 4*16], xmm10 movapd OWORD PTR [rsp + 5*16], xmm11 movapd OWORD PTR [rsp + 6*16], xmm12 movapd OWORD PTR [rsp + 7*16], xmm13 movapd OWORD PTR [rsp + 8*16], xmm14 movapd OWORD PTR [rsp + 9*16], xmm15 ; Initial loading of arguments mov rbx, rcx ; closure mov rax, rdx ; argument mov r12, [rbx] ; code pointer jmp L106 PUBLIC caml_callback2_exn ALIGN 16 caml_callback2_exn: ; Save callee-save registers push rbx push rbp push rsi push rdi push r12 push r13 push r14 push r15 sub rsp, 8+10*16 ; stack 16-aligned + 10 saved xmm regs movapd OWORD PTR [rsp + 0*16], xmm6 movapd OWORD PTR [rsp + 1*16], xmm7 movapd OWORD PTR [rsp + 2*16], xmm8 movapd OWORD PTR [rsp + 3*16], xmm9 movapd OWORD PTR [rsp + 4*16], xmm10 movapd OWORD PTR [rsp + 5*16], xmm11 movapd OWORD PTR [rsp + 6*16], xmm12 movapd OWORD PTR [rsp + 7*16], xmm13 movapd OWORD PTR [rsp + 8*16], xmm14 movapd OWORD PTR [rsp + 9*16], xmm15 ; Initial loading of arguments mov rdi, rcx ; closure mov rax, rdx ; first argument mov rbx, r8 ; second argument lea r12, caml_apply2 ; code pointer jmp L106 PUBLIC caml_callback3_exn ALIGN 16 caml_callback3_exn: ; Save callee-save registers push rbx push rbp push rsi push rdi push r12 push r13 push r14 push r15 sub rsp, 8+10*16 ; stack 16-aligned + 10 saved xmm regs movapd OWORD PTR [rsp + 0*16], xmm6 movapd OWORD PTR [rsp + 1*16], xmm7 movapd OWORD PTR [rsp + 2*16], xmm8 movapd OWORD PTR [rsp + 3*16], xmm9 movapd OWORD PTR [rsp + 4*16], xmm10 movapd OWORD PTR [rsp + 5*16], xmm11 movapd OWORD PTR [rsp + 6*16], xmm12 movapd OWORD PTR [rsp + 7*16], xmm13 movapd OWORD PTR [rsp + 8*16], xmm14 movapd OWORD PTR [rsp + 9*16], xmm15 ; Initial loading of arguments mov rsi, rcx ; closure mov rax, rdx ; first argument mov rbx, r8 ; second argument mov rdi, r9 ; third argument lea r12, caml_apply3 ; code pointer jmp L106 PUBLIC caml_ml_array_bound_error ALIGN 16 caml_ml_array_bound_error: lea rax, caml_array_bound_error jmp caml_c_call .DATA PUBLIC caml_system__frametable caml_system__frametable LABEL QWORD QWORD 1 ; one descriptor QWORD L107 ; return address into callback WORD -1 ; negative frame size => use callback link WORD 0 ; no roots here ALIGN 8 PUBLIC caml_negf_mask ALIGN 16 caml_negf_mask LABEL QWORD QWORD 8000000000000000H, 0 PUBLIC caml_absf_mask ALIGN 16 caml_absf_mask LABEL QWORD QWORD 7FFFFFFFFFFFFFFFH, 0FFFFFFFFFFFFFFFFH END mingw-ocaml/ocaml/asmrun/power-rhapsody.S0000644000175000017500000003721412124403240020100 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifdef __ppc64__ #define X(a,b) b #else #define X(a,b) a #endif #define WORD X(4,8) #define lg X(lwz,ld) #define lgu X(lwzu,ldu) #define stg X(stw,std) #define stgu X(stwu,stdu) #define gdata X(.long,.quad) .macro Addrglobal /* reg, glob */ addis $0, 0, ha16($1) addi $0, $0, lo16($1) .endmacro .macro Loadglobal /* reg,glob,tmp */ addis $2, 0, ha16($1) lg $0, lo16($1)($2) .endmacro .macro Storeglobal /* reg,glob,tmp */ addis $2, 0, ha16($1) stg $0, lo16($1)($2) .endmacro .text .globl _caml_system__code_begin _caml_system__code_begin: /* Invoke the garbage collector. */ .globl _caml_call_gc _caml_call_gc: /* Set up stack frame */ #define FRAMESIZE (32*WORD + 32*8 + 32) stwu r1, -FRAMESIZE(r1) /* Record return address into OCaml code */ mflr r0 Storeglobal r0, _caml_last_return_address, r11 /* Record lowest stack address */ addi r0, r1, FRAMESIZE Storeglobal r0, _caml_bottom_of_stack, r11 /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ addi r1, r1, -4096*WORD stg r0, 0(r1) addi r1, r1, 4096*WORD /* Record pointer to register array */ addi r0, r1, 8*32 + 32 Storeglobal r0, _caml_gc_regs, r11 /* Save current allocation pointer for debugging purposes */ Storeglobal r31, _caml_young_ptr, r11 /* Save exception pointer (if e.g. a sighandler raises) */ Storeglobal r29, _caml_exception_pointer, r11 /* Save all registers used by the code generator */ addi r11, r1, 8*32 + 32 - WORD stgu r3, WORD(r11) stgu r4, WORD(r11) stgu r5, WORD(r11) stgu r6, WORD(r11) stgu r7, WORD(r11) stgu r8, WORD(r11) stgu r9, WORD(r11) stgu r10, WORD(r11) stgu r14, WORD(r11) stgu r15, WORD(r11) stgu r16, WORD(r11) stgu r17, WORD(r11) stgu r18, WORD(r11) stgu r19, WORD(r11) stgu r20, WORD(r11) stgu r21, WORD(r11) stgu r22, WORD(r11) stgu r23, WORD(r11) stgu r24, WORD(r11) stgu r25, WORD(r11) stgu r26, WORD(r11) stgu r27, WORD(r11) stgu r28, WORD(r11) addi r11, r1, 32 - 8 stfdu f1, 8(r11) stfdu f2, 8(r11) stfdu f3, 8(r11) stfdu f4, 8(r11) stfdu f5, 8(r11) stfdu f6, 8(r11) stfdu f7, 8(r11) stfdu f8, 8(r11) stfdu f9, 8(r11) stfdu f10, 8(r11) stfdu f11, 8(r11) stfdu f12, 8(r11) stfdu f13, 8(r11) stfdu f14, 8(r11) stfdu f15, 8(r11) stfdu f16, 8(r11) stfdu f17, 8(r11) stfdu f18, 8(r11) stfdu f19, 8(r11) stfdu f20, 8(r11) stfdu f21, 8(r11) stfdu f22, 8(r11) stfdu f23, 8(r11) stfdu f24, 8(r11) stfdu f25, 8(r11) stfdu f26, 8(r11) stfdu f27, 8(r11) stfdu f28, 8(r11) stfdu f29, 8(r11) stfdu f30, 8(r11) stfdu f31, 8(r11) /* Call the GC */ bl _caml_garbage_collection /* Reload new allocation pointer and allocation limit */ Loadglobal r31, _caml_young_ptr, r11 Loadglobal r30, _caml_young_limit, r11 /* Restore all regs used by the code generator */ addi r11, r1, 8*32 + 32 - WORD lgu r3, WORD(r11) lgu r4, WORD(r11) lgu r5, WORD(r11) lgu r6, WORD(r11) lgu r7, WORD(r11) lgu r8, WORD(r11) lgu r9, WORD(r11) lgu r10, WORD(r11) lgu r14, WORD(r11) lgu r15, WORD(r11) lgu r16, WORD(r11) lgu r17, WORD(r11) lgu r18, WORD(r11) lgu r19, WORD(r11) lgu r20, WORD(r11) lgu r21, WORD(r11) lgu r22, WORD(r11) lgu r23, WORD(r11) lgu r24, WORD(r11) lgu r25, WORD(r11) lgu r26, WORD(r11) lgu r27, WORD(r11) lgu r28, WORD(r11) addi r11, r1, 32 - 8 lfdu f1, 8(r11) lfdu f2, 8(r11) lfdu f3, 8(r11) lfdu f4, 8(r11) lfdu f5, 8(r11) lfdu f6, 8(r11) lfdu f7, 8(r11) lfdu f8, 8(r11) lfdu f9, 8(r11) lfdu f10, 8(r11) lfdu f11, 8(r11) lfdu f12, 8(r11) lfdu f13, 8(r11) lfdu f14, 8(r11) lfdu f15, 8(r11) lfdu f16, 8(r11) lfdu f17, 8(r11) lfdu f18, 8(r11) lfdu f19, 8(r11) lfdu f20, 8(r11) lfdu f21, 8(r11) lfdu f22, 8(r11) lfdu f23, 8(r11) lfdu f24, 8(r11) lfdu f25, 8(r11) lfdu f26, 8(r11) lfdu f27, 8(r11) lfdu f28, 8(r11) lfdu f29, 8(r11) lfdu f30, 8(r11) lfdu f31, 8(r11) /* Return to caller, restarting the allocation */ Loadglobal r0, _caml_last_return_address, r11 addic r0, r0, -16 /* Restart the allocation (4 instructions) */ mtlr r0 /* Say we are back into OCaml code */ li r12, 0 Storeglobal r12, _caml_last_return_address, r11 /* Deallocate stack frame */ addi r1, r1, FRAMESIZE /* Return */ blr #undef FRAMESIZE /* Call a C function from OCaml */ .globl _caml_c_call _caml_c_call: /* Save return address */ mflr r25 /* Get ready to call C function (address in 11) */ mtctr r11 /* Record lowest stack address and return address */ Storeglobal r1, _caml_bottom_of_stack, r12 Storeglobal r25, _caml_last_return_address, r12 /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ addi r1, r1, -4096*WORD stg r0, 0(r1) addi r1, r1, 4096*WORD /* Make the exception handler and alloc ptr available to the C code */ Storeglobal r31, _caml_young_ptr, r11 Storeglobal r29, _caml_exception_pointer, r11 /* Call the function (address in link register) */ bctrl /* Restore return address (in 25, preserved by the C function) */ mtlr r25 /* Reload allocation pointer and allocation limit*/ Loadglobal r31, _caml_young_ptr, r11 Loadglobal r30, _caml_young_limit, r11 /* Say we are back into OCaml code */ li r12, 0 Storeglobal r12, _caml_last_return_address, r11 /* Return to caller */ blr /* Raise an exception from OCaml */ .globl _caml_raise_exn _caml_raise_exn: addis r11, 0, ha16(_caml_backtrace_active) lwz r11, lo16(_caml_backtrace_active)(r11) cmpwi r11, 0 bne L110 L111: /* Pop trap frame */ lg r0, 0(r29) mr r1, r29 mtlr r0 lg r29, WORD(r1) addi r1, r1, 16 /* Branch to handler */ blr L110: mr r28, r3 /* preserve exn bucket in callee-save */ /* arg 1: exception bucket (already in r3) */ mflr r4 /* arg 2: PC of raise */ mr r5, r1 /* arg 3: SP of raise */ mr r6, r29 /* arg 4: SP of handler */ addi r1, r1, -(16*WORD) /* reserve stack space for C call */ bl _caml_stash_backtrace mr r3, r28 b L111 /* Raise an exception from C */ .globl _caml_raise_exception _caml_raise_exception: addis r11, 0, ha16(_caml_backtrace_active) lwz r11, lo16(_caml_backtrace_active)(r11) cmpwi r11, 0 bne L112 L113: /* Reload OCaml global registers */ Loadglobal r1, _caml_exception_pointer, r11 Loadglobal r31, _caml_young_ptr, r11 Loadglobal r30, _caml_young_limit, r11 /* Say we are back into OCaml code */ li r0, 0 Storeglobal r0, _caml_last_return_address, r11 /* Pop trap frame */ lg r0, 0(r1) lg r29, WORD(r1) mtlr r0 addi r1, r1, 16 /* Branch to handler */ blr L112: mr r28, r3 /* preserve exn bucket in callee-save */ /* arg 1: exception bucket (already in r3) */ Loadglobal r4, _caml_last_return_address, r11 /* arg 2: PC of raise */ Loadglobal r5, _caml_bottom_of_stack, r11 /* arg 3: SP of raise */ Loadglobal r6, _caml_exception_pointer, r11 /* arg 4: SP of handler */ addi r1, r1, -(16*WORD) /* reserve stack space for C call */ bl _caml_stash_backtrace mr r3, r28 b L113 /* Start the OCaml program */ .globl _caml_start_program _caml_start_program: Addrglobal r12, _caml_program /* Code shared between caml_start_program and caml_callback */ L102: /* Allocate and link stack frame */ #define FRAMESIZE (16 + 20*WORD + 18*8) stgu r1, -FRAMESIZE(r1) /* Save return address */ mflr r0 stg r0, WORD(r1) /* Save all callee-save registers */ /* GPR14 ... GPR31, then FPR14 ... FPR31 starting at sp+16 */ addi r11, r1, 16-WORD stgu r14, WORD(r11) stgu r15, WORD(r11) stgu r16, WORD(r11) stgu r17, WORD(r11) stgu r18, WORD(r11) stgu r19, WORD(r11) stgu r20, WORD(r11) stgu r21, WORD(r11) stgu r22, WORD(r11) stgu r23, WORD(r11) stgu r24, WORD(r11) stgu r25, WORD(r11) stgu r26, WORD(r11) stgu r27, WORD(r11) stgu r28, WORD(r11) stgu r29, WORD(r11) stgu r30, WORD(r11) stgu r31, WORD(r11) stfdu f14, 8(r11) stfdu f15, 8(r11) stfdu f16, 8(r11) stfdu f17, 8(r11) stfdu f18, 8(r11) stfdu f19, 8(r11) stfdu f20, 8(r11) stfdu f21, 8(r11) stfdu f22, 8(r11) stfdu f23, 8(r11) stfdu f24, 8(r11) stfdu f25, 8(r11) stfdu f26, 8(r11) stfdu f27, 8(r11) stfdu f28, 8(r11) stfdu f29, 8(r11) stfdu f30, 8(r11) stfdu f31, 8(r11) /* Set up a callback link */ addi r1, r1, -32 Loadglobal r9, _caml_bottom_of_stack, r11 Loadglobal r10, _caml_last_return_address, r11 Loadglobal r11, _caml_gc_regs, r11 stg r9, 0(r1) stg r10, WORD(r1) stg r11, 2*WORD(r1) /* Build an exception handler to catch exceptions escaping out of OCaml */ bl L103 b L104 L103: addi r1, r1, -16 mflr r0 stg r0, 0(r1) Loadglobal r11, _caml_exception_pointer, r11 stg r11, WORD(r1) mr r29, r1 /* Reload allocation pointers */ Loadglobal r31, _caml_young_ptr, r11 Loadglobal r30, _caml_young_limit, r11 /* Say we are back into OCaml code */ li r0, 0 Storeglobal r0, _caml_last_return_address, r11 /* Call the OCaml code */ mtctr r12 L105: bctrl /* Pop the trap frame, restoring caml_exception_pointer */ lg r9, WORD(r1) Storeglobal r9, _caml_exception_pointer, r11 addi r1, r1, 16 /* Pop the callback link, restoring the global variables */ L106: lg r9, 0(r1) lg r10, WORD(r1) lg r11, 2*WORD(r1) Storeglobal r9, _caml_bottom_of_stack, r12 Storeglobal r10, _caml_last_return_address, r12 Storeglobal r11, _caml_gc_regs, r12 addi r1, r1, 32 /* Update allocation pointer */ Storeglobal r31, _caml_young_ptr, r11 /* Restore callee-save registers */ addi r11, r1, 16-WORD lgu r14, WORD(r11) lgu r15, WORD(r11) lgu r16, WORD(r11) lgu r17, WORD(r11) lgu r18, WORD(r11) lgu r19, WORD(r11) lgu r20, WORD(r11) lgu r21, WORD(r11) lgu r22, WORD(r11) lgu r23, WORD(r11) lgu r24, WORD(r11) lgu r25, WORD(r11) lgu r26, WORD(r11) lgu r27, WORD(r11) lgu r28, WORD(r11) lgu r29, WORD(r11) lgu r30, WORD(r11) lgu r31, WORD(r11) lfdu f14, 8(r11) lfdu f15, 8(r11) lfdu f16, 8(r11) lfdu f17, 8(r11) lfdu f18, 8(r11) lfdu f19, 8(r11) lfdu f20, 8(r11) lfdu f21, 8(r11) lfdu f22, 8(r11) lfdu f23, 8(r11) lfdu f24, 8(r11) lfdu f25, 8(r11) lfdu f26, 8(r11) lfdu f27, 8(r11) lfdu f28, 8(r11) lfdu f29, 8(r11) lfdu f30, 8(r11) lfdu f31, 8(r11) /* Reload return address */ lg r0, WORD(r1) mtlr r0 /* Return */ addi r1, r1, FRAMESIZE blr /* The trap handler: */ L104: /* Update caml_exception_pointer */ Storeglobal r29, _caml_exception_pointer, r11 /* Encode exception bucket as an exception result and return it */ ori r3, r3, 2 b L106 #undef FRAMESIZE /* Callback from C to OCaml */ .globl _caml_callback_exn _caml_callback_exn: /* Initial shuffling of arguments */ mr r0, r3 /* Closure */ mr r3, r4 /* Argument */ mr r4, r0 lg r12, 0(r4) /* Code pointer */ b L102 .globl _caml_callback2_exn _caml_callback2_exn: mr r0, r3 /* Closure */ mr r3, r4 /* First argument */ mr r4, r5 /* Second argument */ mr r5, r0 Addrglobal r12, _caml_apply2 b L102 .globl _caml_callback3_exn _caml_callback3_exn: mr r0, r3 /* Closure */ mr r3, r4 /* First argument */ mr r4, r5 /* Second argument */ mr r5, r6 /* Third argument */ mr r6, r0 Addrglobal r12, _caml_apply3 b L102 .globl _caml_system__code_end _caml_system__code_end: /* Frame table */ .const .globl _caml_system__frametable _caml_system__frametable: gdata 1 /* one descriptor */ gdata L105 + 4 /* return address into callback */ .short -1 /* negative size count => use callback link */ .short 0 /* no roots here */ .align X(2,3) mingw-ocaml/ocaml/asmrun/startup.c0000644000175000017500000001467512124403240016645 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Start-up code */ #include #include #include "callback.h" #include "backtrace.h" #include "custom.h" #include "debugger.h" #include "fail.h" #include "freelist.h" #include "gc.h" #include "gc_ctrl.h" #include "intext.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" #include "osdeps.h" #include "printexc.h" #include "stack.h" #include "sys.h" #include "natdynlink.h" #ifdef HAS_UI #include "ui.h" #endif extern int caml_parser_trace; CAMLexport header_t caml_atom_table[256]; char * caml_code_area_start, * caml_code_area_end; /* Initialize the atom table and the static data and code area limits. */ struct segment { char * begin; char * end; }; static void init_atoms(void) { extern struct segment caml_data_segments[], caml_code_segments[]; int i; struct code_fragment * cf; for (i = 0; i < 256; i++) { caml_atom_table[i] = Make_header(0, i, Caml_white); } if (caml_page_table_add(In_static_data, caml_atom_table, caml_atom_table + 256) != 0) caml_fatal_error("Fatal error: not enough memory for the initial page table"); for (i = 0; caml_data_segments[i].begin != 0; i++) { /* PR#5509: we must include the zero word at end of data segment, because pointers equal to caml_data_segments[i].end are static data. */ if (caml_page_table_add(In_static_data, caml_data_segments[i].begin, caml_data_segments[i].end + sizeof(value)) != 0) caml_fatal_error("Fatal error: not enough memory for the initial page table"); } caml_code_area_start = caml_code_segments[0].begin; caml_code_area_end = caml_code_segments[0].end; for (i = 1; caml_code_segments[i].begin != 0; i++) { if (caml_code_segments[i].begin < caml_code_area_start) caml_code_area_start = caml_code_segments[i].begin; if (caml_code_segments[i].end > caml_code_area_end) caml_code_area_end = caml_code_segments[i].end; } /* Register the code in the table of code fragments */ cf = caml_stat_alloc(sizeof(struct code_fragment)); cf->code_start = caml_code_area_start; cf->code_end = caml_code_area_end; cf->digest_computed = 0; caml_ext_table_init(&caml_code_fragments_table, 8); caml_ext_table_add(&caml_code_fragments_table, cf); } /* Configuration parameters and flags */ static uintnat percent_free_init = Percent_free_def; static uintnat max_percent_free_init = Max_percent_free_def; static uintnat minor_heap_init = Minor_heap_def; static uintnat heap_chunk_init = Heap_chunk_def; static uintnat heap_size_init = Init_heap_def; static uintnat max_stack_init = Max_stack_def; /* Parse the CAMLRUNPARAM variable */ /* The option letter for each runtime option is the first letter of the last word of the ML name of the option (see [stdlib/gc.mli]). Except for l (maximum stack size) and h (initial heap size). */ /* Note: option l is irrelevant to the native-code runtime. */ /* If you change these functions, see also their copy in byterun/startup.c */ static void scanmult (char *opt, uintnat *var) { char mult = ' '; int val; sscanf (opt, "=%u%c", &val, &mult); sscanf (opt, "=0x%x%c", &val, &mult); switch (mult) { case 'k': *var = (uintnat) val * 1024; break; case 'M': *var = (uintnat) val * 1024 * 1024; break; case 'G': *var = (uintnat) val * 1024 * 1024 * 1024; break; default: *var = (uintnat) val; break; } } static void parse_camlrunparam(void) { char *opt = getenv ("OCAMLRUNPARAM"); uintnat p; if (opt == NULL) opt = getenv ("CAMLRUNPARAM"); if (opt != NULL){ while (*opt != '\0'){ switch (*opt++){ case 's': scanmult (opt, &minor_heap_init); break; case 'i': scanmult (opt, &heap_chunk_init); break; case 'h': scanmult (opt, &heap_size_init); break; case 'l': scanmult (opt, &max_stack_init); break; case 'o': scanmult (opt, &percent_free_init); break; case 'O': scanmult (opt, &max_percent_free_init); break; case 'v': scanmult (opt, &caml_verb_gc); break; case 'b': caml_record_backtrace(Val_true); break; case 'p': caml_parser_trace = 1; break; case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break; } } } } /* These are termination hooks used by the systhreads library */ struct longjmp_buffer caml_termination_jmpbuf; void (*caml_termination_hook)(void *) = NULL; extern value caml_start_program (void); extern void caml_init_ieee_floats (void); extern void caml_init_signals (void); void caml_main(char **argv) { char * exe_name; #ifdef __linux__ static char proc_self_exe[256]; #endif value res; char tos; caml_init_ieee_floats(); caml_init_custom_operations(); #ifdef DEBUG caml_verb_gc = 63; #endif caml_top_of_stack = &tos; parse_camlrunparam(); caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, percent_free_init, max_percent_free_init); init_atoms(); caml_init_signals(); caml_debugger_init (); /* force debugger.o stub to be linked */ exe_name = argv[0]; if (exe_name == NULL) exe_name = ""; #ifdef __linux__ if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) exe_name = proc_self_exe; else exe_name = caml_search_exe_in_path(exe_name); #else exe_name = caml_search_exe_in_path(exe_name); #endif caml_sys_init(exe_name, argv); if (sigsetjmp(caml_termination_jmpbuf.buf, 0)) { if (caml_termination_hook != NULL) caml_termination_hook(NULL); return; } res = caml_start_program(); if (Is_exception_result(res)) caml_fatal_uncaught_exception(Extract_exception(res)); } void caml_startup(char **argv) { caml_main(argv); } mingw-ocaml/ocaml/asmrun/stack.h0000644000175000017500000000652612124403240016251 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Machine-dependent interface with the asm code */ #ifndef CAML_STACK_H #define CAML_STACK_H /* Macros to access the stack frame */ #ifdef TARGET_sparc #define Saved_return_address(sp) *((intnat *)((sp) + 92)) #define Callback_link(sp) ((struct caml_context *)((sp) + 104)) #endif #ifdef TARGET_i386 #define Saved_return_address(sp) *((intnat *)((sp) - 4)) #ifdef SYS_macosx #define Callback_link(sp) ((struct caml_context *)((sp) + 16)) #else #define Callback_link(sp) ((struct caml_context *)((sp) + 8)) #endif #endif #ifdef TARGET_power #define Saved_return_address(sp) *((intnat *)((sp) - SIZEOF_PTR)) #define Already_scanned(sp, retaddr) ((retaddr) & 1) #define Mark_scanned(sp, retaddr) (*((intnat *)((sp) - SIZEOF_PTR)) = (retaddr) | 1) #define Mask_already_scanned(retaddr) ((retaddr) & ~1) #ifdef SYS_aix #define Trap_frame_size 32 #else #define Trap_frame_size 16 #endif #define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size)) #endif #ifdef TARGET_arm #define Saved_return_address(sp) *((intnat *)((sp) - 4)) #define Callback_link(sp) ((struct caml_context *)((sp) + 8)) #endif #ifdef TARGET_amd64 #define Saved_return_address(sp) *((intnat *)((sp) - 8)) #define Callback_link(sp) ((struct caml_context *)((sp) + 16)) #endif /* Structure of OCaml callback contexts */ struct caml_context { char * bottom_of_stack; /* beginning of OCaml stack chunk */ uintnat last_retaddr; /* last return address in OCaml code */ value * gc_regs; /* pointer to register block */ }; /* Structure of frame descriptors */ typedef struct { uintnat retaddr; unsigned short frame_size; unsigned short num_live; unsigned short live_ofs[1]; } frame_descr; /* Hash table of frame descriptors */ extern frame_descr ** caml_frame_descriptors; extern int caml_frame_descriptors_mask; #define Hash_retaddr(addr) \ (((uintnat)(addr) >> 3) & caml_frame_descriptors_mask) extern void caml_init_frame_descriptors(void); extern void caml_register_frametable(intnat *); extern void caml_register_dyn_global(void *); extern uintnat caml_stack_usage (void); extern uintnat (*caml_stack_usage_hook)(void); /* Declaration of variables used in the asm code */ extern char * caml_top_of_stack; extern char * caml_bottom_of_stack; extern uintnat caml_last_return_address; extern value * caml_gc_regs; extern char * caml_exception_pointer; extern value caml_globals[]; extern intnat caml_globals_inited; extern intnat * caml_frametable[]; #endif /* CAML_STACK_H */ mingw-ocaml/ocaml/asmrun/natdynlink.c0000644000175000017500000000776312124403240017316 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Alain Frisch, projet Gallium, INRIA Rocquencourt */ /* */ /* Copyright 2007 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ #include "misc.h" #include "mlvalues.h" #include "memory.h" #include "stack.h" #include "callback.h" #include "alloc.h" #include "intext.h" #include "natdynlink.h" #include "osdeps.h" #include "fail.h" #include #include static void *getsym(void *handle, char *module, char *name){ char *fullname = malloc(strlen(module) + strlen(name) + 5); void *sym; sprintf(fullname, "caml%s%s", module, name); sym = caml_dlsym (handle, fullname); /* printf("%s => %lx\n", fullname, (uintnat) sym); */ free(fullname); return sym; } extern char caml_globals_map[]; CAMLprim value caml_natdynlink_getmap(value unit) { return (value)caml_globals_map; } CAMLprim value caml_natdynlink_globals_inited(value unit) { return Val_int(caml_globals_inited); } CAMLprim value caml_natdynlink_open(value filename, value global) { CAMLparam1 (filename); CAMLlocal1 (res); void *sym; void *handle; /* TODO: dlclose in case of error... */ handle = caml_dlopen(String_val(filename), 1, Int_val(global)); if (NULL == handle) CAMLreturn(caml_copy_string(caml_dlerror())); sym = caml_dlsym(handle, "caml_plugin_header"); if (NULL == sym) CAMLreturn(caml_copy_string("not an OCaml plugin")); res = caml_alloc_tuple(2); Field(res, 0) = (value) handle; Field(res, 1) = (value) (sym); CAMLreturn(res); } CAMLprim value caml_natdynlink_run(void *handle, value symbol) { CAMLparam1 (symbol); CAMLlocal1 (result); void *sym,*sym2; struct code_fragment * cf; #define optsym(n) getsym(handle,unit,n) char *unit; void (*entrypoint)(void); unit = String_val(symbol); sym = optsym("__frametable"); if (NULL != sym) caml_register_frametable(sym); sym = optsym(""); if (NULL != sym) caml_register_dyn_global(sym); sym = optsym("__data_begin"); sym2 = optsym("__data_end"); if (NULL != sym && NULL != sym2) caml_page_table_add(In_static_data, sym, sym2); sym = optsym("__code_begin"); sym2 = optsym("__code_end"); if (NULL != sym && NULL != sym2) { caml_page_table_add(In_code_area, sym, sym2); cf = caml_stat_alloc(sizeof(struct code_fragment)); cf->code_start = (char *) sym; cf->code_end = (char *) sym2; cf->digest_computed = 0; caml_ext_table_add(&caml_code_fragments_table, cf); } entrypoint = optsym("__entry"); if (NULL != entrypoint) result = caml_callback((value)(&entrypoint), 0); else result = Val_unit; #undef optsym CAMLreturn (result); } CAMLprim value caml_natdynlink_run_toplevel(value filename, value symbol) { CAMLparam2 (filename, symbol); CAMLlocal2 (res, v); void *handle; /* TODO: dlclose in case of error... */ handle = caml_dlopen(String_val(filename), 1, 1); if (NULL == handle) { res = caml_alloc(1,1); v = caml_copy_string(caml_dlerror()); Store_field(res, 0, v); } else { res = caml_alloc(1,0); v = caml_natdynlink_run(handle, symbol); Store_field(res, 0, v); } CAMLreturn(res); } CAMLprim value caml_natdynlink_loadsym(value symbol) { CAMLparam1 (symbol); CAMLlocal1 (sym); sym = (value) caml_globalsym(String_val(symbol)); if (!sym) caml_failwith(String_val(symbol)); CAMLreturn(sym); } mingw-ocaml/ocaml/asmrun/.depend0000644000175000017500000013446612124403240016240 0ustar tootstootsalloc.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ ../byterun/memory.h array.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h backtrace.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h callback.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/mlvalues.h compact.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/weak.h compare.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h custom.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h debugger.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ ../byterun/misc.h dynlink.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ ../byterun/fail.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/osdeps.h \ ../byterun/prims.h extern.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h fail.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h finalise.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/signals.h floats.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h freelist.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h gc_ctrl.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h stack.h globroots.o: globroots.c ../byterun/memory.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ ../byterun/globroots.h ../byterun/roots.h hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h intern.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h ints.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h io.o: io.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ ../byterun/sys.h lexing.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h main.o: main.c ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/sys.h major_gc.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/weak.h md5.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ ../byterun/reverse.h memory.o: memory.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/signals.h meta.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ ../byterun/interp.h ../byterun/intext.h ../byterun/io.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/prims.h ../byterun/stacks.h ../byterun/memory.h minor_gc.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ ../byterun/weak.h misc.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h natdynlink.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \ ../byterun/fail.h obj.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/prims.h parsing.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/alloc.h printexc.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/printexc.h roots.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h stack.h ../byterun/roots.h signals.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ ../byterun/sys.h signals_asm.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ signals_osdep.h stack.h startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h sys.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h terminfo.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ ../byterun/io.h ../byterun/mlvalues.h unix.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/osdeps.h weak.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h alloc.d.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ ../byterun/memory.h array.d.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h backtrace.d.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h callback.d.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/mlvalues.h compact.d.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/weak.h compare.d.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h custom.d.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h debugger.d.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ ../byterun/misc.h dynlink.d.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ ../byterun/fail.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/osdeps.h \ ../byterun/prims.h extern.d.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h fail.d.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h finalise.d.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/signals.h floats.d.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h freelist.d.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h gc_ctrl.d.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h stack.h globroots.d.o: globroots.c ../byterun/memory.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ ../byterun/globroots.h ../byterun/roots.h hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h intern.d.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h ints.d.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h io.d.o: io.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ ../byterun/sys.h lexing.d.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h main.d.o: main.c ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/sys.h major_gc.d.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/weak.h md5.d.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ ../byterun/reverse.h memory.d.o: memory.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/signals.h meta.d.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ ../byterun/interp.h ../byterun/intext.h ../byterun/io.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/prims.h ../byterun/stacks.h ../byterun/memory.h minor_gc.d.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ ../byterun/weak.h misc.d.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h natdynlink.d.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \ ../byterun/fail.h obj.d.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/prims.h parsing.d.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/alloc.h printexc.d.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/printexc.h roots.d.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h stack.h ../byterun/roots.h signals.d.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ ../byterun/sys.h signals_asm.d.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ signals_osdep.h stack.h startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h sys.d.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h terminfo.d.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ ../byterun/io.h ../byterun/mlvalues.h unix.d.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/osdeps.h weak.d.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h alloc.p.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ ../byterun/memory.h array.p.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h backtrace.p.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h callback.p.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/mlvalues.h compact.p.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/weak.h compare.p.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h custom.p.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h debugger.p.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ ../byterun/misc.h dynlink.p.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ ../byterun/fail.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/osdeps.h \ ../byterun/prims.h extern.p.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h fail.p.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h finalise.p.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/signals.h floats.p.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h freelist.p.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h gc_ctrl.p.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h stack.h globroots.p.o: globroots.c ../byterun/memory.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ ../byterun/globroots.h ../byterun/roots.h hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h intern.p.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h ints.p.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h io.p.o: io.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ ../byterun/sys.h lexing.p.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h main.p.o: main.c ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/sys.h major_gc.p.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/weak.h md5.p.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ ../byterun/reverse.h memory.p.o: memory.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/signals.h meta.p.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ ../byterun/interp.h ../byterun/intext.h ../byterun/io.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/prims.h ../byterun/stacks.h ../byterun/memory.h minor_gc.p.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ ../byterun/weak.h misc.p.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h natdynlink.p.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \ ../byterun/fail.h obj.p.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/prims.h parsing.p.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/alloc.h printexc.p.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/printexc.h roots.p.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/mlvalues.h stack.h ../byterun/roots.h signals.p.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ ../byterun/sys.h signals_asm.p.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ signals_osdep.h stack.h startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h sys.p.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h terminfo.p.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ ../byterun/io.h ../byterun/mlvalues.h unix.p.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/osdeps.h weak.p.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h mingw-ocaml/ocaml/asmrun/i386.S0000644000175000017500000003507412124403240015610 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Asm part of the runtime system, Intel 386 processor */ /* Must be preprocessed by cpp */ #include "../config/m.h" /* Linux/BSD with ELF binaries and Solaris do not prefix identifiers with _. Linux/BSD with a.out binaries and NextStep do. */ #if defined(SYS_solaris) #define CONCAT(a,b) a/**/b #else #define CONCAT(a,b) a##b #endif #if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \ || defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_gnu) #define G(x) x #define LBL(x) CONCAT(.L,x) #else #define G(x) CONCAT(_,x) #define LBL(x) CONCAT(L,x) #endif #if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \ || defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_cygwin) \ || defined(SYS_mingw) || defined(SYS_gnu) #define FUNCTION_ALIGN 4 #else #define FUNCTION_ALIGN 2 #endif #ifdef ASM_CFI_SUPPORTED #define CFI_STARTPROC .cfi_startproc #define CFI_ENDPROC .cfi_endproc #define CFI_ADJUST(n) .cfi_adjust_cfa_offset n #else #define CFI_STARTPROC #define CFI_ENDPROC #define CFI_ADJUST(n) #endif #if defined(PROFILING) #if defined(SYS_linux_elf) || defined(SYS_gnu) #define PROFILE_CAML \ pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \ call mcount; \ popl %edx; popl %ecx; popl %eax; popl %ebp #define PROFILE_C \ pushl %ebp; movl %esp, %ebp; call mcount; popl %ebp #elif defined(SYS_bsd_elf) #define PROFILE_CAML \ pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \ call .mcount; \ popl %edx; popl %ecx; popl %eax; popl %ebp #define PROFILE_C \ pushl %ebp; movl %esp, %ebp; call .mcount; popl %ebp #elif defined(SYS_macosx) #define PROFILE_CAML \ pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \ call Lmcount$stub; \ popl %edx; popl %ecx; popl %eax; popl %ebp #define PROFILE_C \ pushl %ebp; movl %esp, %ebp; call Lmcount$stub; popl %ebp #endif #else #define PROFILE_CAML #define PROFILE_C #endif #ifdef SYS_macosx #define ALIGN_STACK(amount) subl $ amount, %esp #define UNDO_ALIGN_STACK(amount) addl $ amount, %esp #else #define ALIGN_STACK(amount) #define UNDO_ALIGN_STACK(amount) #endif /* Allocation */ .text .globl G(caml_system__code_begin) G(caml_system__code_begin): .globl G(caml_call_gc) .globl G(caml_alloc1) .globl G(caml_alloc2) .globl G(caml_alloc3) .globl G(caml_allocN) .align FUNCTION_ALIGN G(caml_call_gc): CFI_STARTPROC PROFILE_CAML /* Record lowest stack address and return address */ movl 0(%esp), %eax movl %eax, G(caml_last_return_address) leal 4(%esp), %eax movl %eax, G(caml_bottom_of_stack) LBL(105): #if !defined(SYS_mingw) && !defined(SYS_cygwin) /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ subl $16384, %esp movl %eax, 0(%esp) addl $16384, %esp #endif /* Build array of registers, save it into caml_gc_regs */ pushl %ebp pushl %edi pushl %esi pushl %edx pushl %ecx pushl %ebx pushl %eax CFI_ADJUST(28) movl %esp, G(caml_gc_regs) /* MacOSX note: 16-alignment of stack preserved at this point */ /* Call the garbage collector */ call G(caml_garbage_collection) /* Restore all regs used by the code generator */ popl %eax popl %ebx popl %ecx popl %edx popl %esi popl %edi popl %ebp CFI_ADJUST(-28) /* Return to caller */ ret CFI_ENDPROC .align FUNCTION_ALIGN G(caml_alloc1): PROFILE_CAML movl G(caml_young_ptr), %eax subl $8, %eax movl %eax, G(caml_young_ptr) cmpl G(caml_young_limit), %eax jb LBL(100) ret LBL(100): movl 0(%esp), %eax movl %eax, G(caml_last_return_address) leal 4(%esp), %eax movl %eax, G(caml_bottom_of_stack) ALIGN_STACK(12) call LBL(105) UNDO_ALIGN_STACK(12) jmp G(caml_alloc1) .align FUNCTION_ALIGN G(caml_alloc2): PROFILE_CAML movl G(caml_young_ptr), %eax subl $12, %eax movl %eax, G(caml_young_ptr) cmpl G(caml_young_limit), %eax jb LBL(101) ret LBL(101): movl 0(%esp), %eax movl %eax, G(caml_last_return_address) leal 4(%esp), %eax movl %eax, G(caml_bottom_of_stack) ALIGN_STACK(12) call LBL(105) UNDO_ALIGN_STACK(12) jmp G(caml_alloc2) .align FUNCTION_ALIGN G(caml_alloc3): PROFILE_CAML movl G(caml_young_ptr), %eax subl $16, %eax movl %eax, G(caml_young_ptr) cmpl G(caml_young_limit), %eax jb LBL(102) ret LBL(102): movl 0(%esp), %eax movl %eax, G(caml_last_return_address) leal 4(%esp), %eax movl %eax, G(caml_bottom_of_stack) ALIGN_STACK(12) call LBL(105) UNDO_ALIGN_STACK(12) jmp G(caml_alloc3) .align FUNCTION_ALIGN G(caml_allocN): PROFILE_CAML subl G(caml_young_ptr), %eax /* eax = size - caml_young_ptr */ negl %eax /* eax = caml_young_ptr - size */ cmpl G(caml_young_limit), %eax jb LBL(103) movl %eax, G(caml_young_ptr) ret LBL(103): subl G(caml_young_ptr), %eax /* eax = - size */ negl %eax /* eax = size */ pushl %eax /* save desired size */ subl %eax, G(caml_young_ptr) /* must update young_ptr */ movl 4(%esp), %eax movl %eax, G(caml_last_return_address) leal 8(%esp), %eax movl %eax, G(caml_bottom_of_stack) ALIGN_STACK(8) call LBL(105) UNDO_ALIGN_STACK(8) popl %eax /* recover desired size */ jmp G(caml_allocN) /* Call a C function from OCaml */ .globl G(caml_c_call) .align FUNCTION_ALIGN G(caml_c_call): PROFILE_CAML /* Record lowest stack address and return address */ movl (%esp), %edx movl %edx, G(caml_last_return_address) leal 4(%esp), %edx movl %edx, G(caml_bottom_of_stack) #if !defined(SYS_mingw) && !defined(SYS_cygwin) /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ subl $16384, %esp movl %eax, 0(%esp) addl $16384, %esp #endif /* Call the function (address in %eax) */ jmp *%eax /* Start the OCaml program */ .globl G(caml_start_program) .align FUNCTION_ALIGN G(caml_start_program): CFI_STARTPROC PROFILE_C /* Save callee-save registers */ pushl %ebx pushl %esi pushl %edi pushl %ebp CFI_ADJUST(16) /* Initial entry point is caml_program */ movl $ G(caml_program), %esi /* Common code for caml_start_program and caml_callback* */ LBL(106): /* Build a callback link */ pushl G(caml_gc_regs) pushl G(caml_last_return_address) pushl G(caml_bottom_of_stack) /* Note: 16-alignment preserved on MacOSX at this point */ /* Build an exception handler */ pushl $ LBL(108) ALIGN_STACK(8) pushl G(caml_exception_pointer) CFI_ADJUST(20) movl %esp, G(caml_exception_pointer) /* Call the OCaml code */ call *%esi LBL(107): /* Pop the exception handler */ popl G(caml_exception_pointer) #ifdef SYS_macosx addl $12, %esp #else addl $4, %esp #endif CFI_ADJUST(-8) LBL(109): /* Pop the callback link, restoring the global variables */ popl G(caml_bottom_of_stack) popl G(caml_last_return_address) popl G(caml_gc_regs) /* Restore callee-save registers. */ popl %ebp popl %edi popl %esi popl %ebx /* Return to caller. */ ret LBL(108): /* Exception handler*/ /* Mark the bucket as an exception result and return it */ orl $2, %eax jmp LBL(109) CFI_ENDPROC /* Raise an exception from OCaml */ .globl G(caml_raise_exn) .align FUNCTION_ALIGN G(caml_raise_exn): testl $1, G(caml_backtrace_active) jne LBL(110) movl G(caml_exception_pointer), %esp popl G(caml_exception_pointer) UNDO_ALIGN_STACK(8) ret LBL(110): movl %eax, %esi /* Save exception bucket in esi */ movl G(caml_exception_pointer), %edi /* SP of handler */ movl 0(%esp), %eax /* PC of raise */ leal 4(%esp), %edx /* SP of raise */ ALIGN_STACK(12) pushl %edi /* arg 4: sp of handler */ pushl %edx /* arg 3: sp of raise */ pushl %eax /* arg 2: pc of raise */ pushl %esi /* arg 1: exception bucket */ call G(caml_stash_backtrace) movl %esi, %eax /* Recover exception bucket */ movl %edi, %esp popl G(caml_exception_pointer) UNDO_ALIGN_STACK(8) ret /* Raise an exception from C */ .globl G(caml_raise_exception) .align FUNCTION_ALIGN G(caml_raise_exception): PROFILE_C testl $1, G(caml_backtrace_active) jne LBL(111) movl 4(%esp), %eax movl G(caml_exception_pointer), %esp popl G(caml_exception_pointer) UNDO_ALIGN_STACK(8) ret LBL(111): movl 4(%esp), %esi /* Save exception bucket in esi */ ALIGN_STACK(12) pushl G(caml_exception_pointer) /* arg 4: sp of handler */ pushl G(caml_bottom_of_stack) /* arg 3: sp of raise */ pushl G(caml_last_return_address) /* arg 2: pc of raise */ pushl %esi /* arg 1: exception bucket */ call G(caml_stash_backtrace) movl %esi, %eax /* Recover exception bucket */ movl G(caml_exception_pointer), %esp popl G(caml_exception_pointer) UNDO_ALIGN_STACK(8) ret /* Callback from C to OCaml */ .globl G(caml_callback_exn) .align FUNCTION_ALIGN G(caml_callback_exn): PROFILE_C /* Save callee-save registers */ pushl %ebx pushl %esi pushl %edi pushl %ebp /* Initial loading of arguments */ movl 20(%esp), %ebx /* closure */ movl 24(%esp), %eax /* argument */ movl 0(%ebx), %esi /* code pointer */ jmp LBL(106) .globl G(caml_callback2_exn) .align FUNCTION_ALIGN G(caml_callback2_exn): PROFILE_C /* Save callee-save registers */ pushl %ebx pushl %esi pushl %edi pushl %ebp /* Initial loading of arguments */ movl 20(%esp), %ecx /* closure */ movl 24(%esp), %eax /* first argument */ movl 28(%esp), %ebx /* second argument */ movl $ G(caml_apply2), %esi /* code pointer */ jmp LBL(106) .globl G(caml_callback3_exn) .align FUNCTION_ALIGN G(caml_callback3_exn): PROFILE_C /* Save callee-save registers */ pushl %ebx pushl %esi pushl %edi pushl %ebp /* Initial loading of arguments */ movl 20(%esp), %edx /* closure */ movl 24(%esp), %eax /* first argument */ movl 28(%esp), %ebx /* second argument */ movl 32(%esp), %ecx /* third argument */ movl $ G(caml_apply3), %esi /* code pointer */ jmp LBL(106) .globl G(caml_ml_array_bound_error) .align FUNCTION_ALIGN G(caml_ml_array_bound_error): /* Empty the floating-point stack */ ffree %st(0) ffree %st(1) ffree %st(2) ffree %st(3) ffree %st(4) ffree %st(5) ffree %st(6) ffree %st(7) /* Record lowest stack address and return address */ movl (%esp), %edx movl %edx, G(caml_last_return_address) leal 4(%esp), %edx movl %edx, G(caml_bottom_of_stack) /* For MacOS X: re-align the stack */ #ifdef SYS_macosx andl $-16, %esp #endif /* Branch to [caml_array_bound_error] (never returns) */ call G(caml_array_bound_error) .globl G(caml_system__code_end) G(caml_system__code_end): .data .globl G(caml_system__frametable) G(caml_system__frametable): .long 1 /* one descriptor */ .long LBL(107) /* return address into callback */ #ifndef SYS_solaris .word -1 /* negative frame size => use callback link */ .word 0 /* no roots here */ #else .value -1 /* negative frame size => use callback link */ .value 0 /* no roots here */ #endif .globl G(caml_extra_params) G(caml_extra_params): #ifndef SYS_solaris .space 64 #else .zero 64 #endif #if defined(PROFILING) && defined(SYS_macosx) .section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5 Lmcount$stub: .indirect_symbol mcount hlt ; hlt ; hlt ; hlt ; hlt .subsections_via_symbols #endif #if defined(SYS_linux_elf) /* Mark stack as non-executable, PR#4564 */ .section .note.GNU-stack,"",%progbits #endif mingw-ocaml/ocaml/asmrun/signals_osdep.h0000644000175000017500000002172112124403240017770 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2004 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Processor- and OS-dependent signal interface */ /****************** AMD64, Linux */ #if defined(TARGET_amd64) && defined (SYS_linux) #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, ucontext_t * context) #define SET_SIGACT(sigact,name) \ sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ sigact.sa_flags = SA_SIGINFO typedef greg_t context_reg; #define CONTEXT_PC (context->uc_mcontext.gregs[REG_RIP]) #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14]) #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15]) #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.gregs[REG_CR2]) /****************** AMD64, MacOSX */ #elif defined(TARGET_amd64) && defined (SYS_macosx) #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, void * context) #define SET_SIGACT(sigact,name) \ sigact.sa_sigaction = (name); \ sigact.sa_flags = SA_SIGINFO | SA_64REGSET #include #include #if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5 #define CONTEXT_REG(r) r #else #define CONTEXT_REG(r) __##r #endif #define CONTEXT_STATE (((ucontext_t *)context)->uc_mcontext->CONTEXT_REG(ss)) #define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(rip)) #define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.CONTEXT_REG(r14)) #define CONTEXT_YOUNG_PTR (CONTEXT_STATE.CONTEXT_REG(r15)) #define CONTEXT_SP (CONTEXT_STATE.CONTEXT_REG(rsp)) #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) /****************** ARM, Linux */ #elif defined(TARGET_arm) && (defined(SYS_linux_eabi) || defined(SYS_linux_eabihf)) #include #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, ucontext_t * context) #define SET_SIGACT(sigact,name) \ sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ sigact.sa_flags = SA_SIGINFO typedef unsigned long context_reg; #define CONTEXT_PC (context->uc_mcontext.arm_pc) #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.arm_fp) #define CONTEXT_YOUNG_PTR (context->uc_mcontext.arm_r8) #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.fault_address) /****************** AMD64, Solaris x86 */ #elif defined(TARGET_amd64) && defined (SYS_solaris) #include #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, ucontext_t * context) #define SET_SIGACT(sigact,name) \ sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ sigact.sa_flags = SA_SIGINFO typedef greg_t context_reg; #define CONTEXT_PC (context->uc_mcontext.gregs[REG_RIP]) #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14]) #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15]) #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) /****************** I386, Linux */ #elif defined(TARGET_i386) && defined(SYS_linux_elf) #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, struct sigcontext context) #define SET_SIGACT(sigact,name) \ sigact.sa_handler = (void (*)(int)) (name); \ sigact.sa_flags = 0 #define CONTEXT_FAULTING_ADDRESS ((char *) context.cr2) /****************** I386, BSD */ #elif defined(TARGET_i386) && defined(SYS_bsd) #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, void * context) #define SET_SIGACT(sigact,name) \ sigact.sa_sigaction = (name); \ sigact.sa_flags = SA_SIGINFO #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) /****************** I386, MacOS X */ #elif defined(TARGET_i386) && defined(SYS_macosx) #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, void * context) #define SET_SIGACT(sigact,name) \ sigact.sa_sigaction = (name); \ sigact.sa_flags = SA_SIGINFO #include #include #if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5 #define CONTEXT_REG(r) r #else #define CONTEXT_REG(r) __##r #endif #define CONTEXT_STATE (((ucontext_t *)context)->uc_mcontext->CONTEXT_REG(ss)) #define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(eip)) #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) /****************** I386, Solaris x86 */ #elif defined(TARGET_i386) && defined(SYS_solaris) #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, void * context) #define SET_SIGACT(sigact,name) \ sigact.sa_sigaction = (name); \ sigact.sa_flags = SA_SIGINFO #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) /****************** PowerPC, MacOS X */ #elif defined(TARGET_power) && defined(SYS_rhapsody) #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, void * context) #include #include #ifdef __LP64__ #define SET_SIGACT(sigact,name) \ sigact.sa_sigaction = (name); \ sigact.sa_flags = SA_SIGINFO | SA_64REGSET typedef unsigned long long context_reg; #define CONTEXT_MCONTEXT (((ucontext64_t *)context)->uc_mcontext64) #else #define SET_SIGACT(sigact,name) \ sigact.sa_sigaction = (name); \ sigact.sa_flags = SA_SIGINFO typedef unsigned long context_reg; #define CONTEXT_MCONTEXT (((ucontext_t *)context)->uc_mcontext) #endif #if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5 #define CONTEXT_REG(r) r #else #define CONTEXT_REG(r) __##r #endif #define CONTEXT_STATE (CONTEXT_MCONTEXT->CONTEXT_REG(ss)) #define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(srr0)) #define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.CONTEXT_REG(r29)) #define CONTEXT_YOUNG_LIMIT (CONTEXT_STATE.CONTEXT_REG(r30)) #define CONTEXT_YOUNG_PTR (CONTEXT_STATE.CONTEXT_REG(r31)) #define CONTEXT_SP (CONTEXT_STATE.CONTEXT_REG(r1)) #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) /****************** PowerPC, ELF (Linux) */ #elif defined(TARGET_power) && defined(SYS_elf) #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, struct sigcontext * context) #define SET_SIGACT(sigact,name) \ sigact.sa_handler = (void (*)(int)) (name); \ sigact.sa_flags = 0 typedef unsigned long context_reg; #define CONTEXT_PC (context->regs->nip) #define CONTEXT_EXCEPTION_POINTER (context->regs->gpr[29]) #define CONTEXT_YOUNG_LIMIT (context->regs->gpr[30]) #define CONTEXT_YOUNG_PTR (context->regs->gpr[31]) /****************** PowerPC, BSD */ #elif defined(TARGET_power) && defined(SYS_bsd) #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, int code, struct sigcontext * context) #define SET_SIGACT(sigact,name) \ sigact.sa_handler = (void (*)(int)) (name); \ sigact.sa_flags = 0 typedef unsigned long context_reg; #define CONTEXT_EXCEPTION_POINTER (context->sc_frame.fixreg[29]) #define CONTEXT_YOUNG_LIMIT (context->sc_frame.fixreg[30]) #define CONTEXT_YOUNG_PTR (context->sc_frame.fixreg[31]) /****************** SPARC, Solaris */ #elif defined(TARGET_sparc) && defined(SYS_solaris) #include #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, ucontext_t * context) #define SET_SIGACT(sigact,name) \ sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ sigact.sa_flags = SA_SIGINFO typedef long context_reg; #define CONTEXT_PC (context->uc_mcontext.gregs[REG_PC]) /* Local register number N is saved on the stack N words after the stack pointer */ #define SPARC_L_REG(n) ((long *)(context->uc_mcontext.gregs[REG_SP]))[n] #define CONTEXT_EXCEPTION_POINTER (SPARC_L_REG(5)) #define CONTEXT_YOUNG_LIMIT (SPARC_L_REG(7)) #define CONTEXT_YOUNG_PTR (SPARC_L_REG(6)) /******************** Default */ #else #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig) #define SET_SIGACT(sigact,name) \ sigact.sa_handler = (name); \ sigact.sa_flags = 0 #endif mingw-ocaml/ocaml/byterun/0000755000175000017500000000000012124403240015145 5ustar tootstootsmingw-ocaml/ocaml/byterun/intext.h0000644000175000017500000001420612124403240016634 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Structured input/output */ #ifndef CAML_INTEXT_H #define CAML_INTEXT_H #ifndef CAML_NAME_SPACE #include "compatibility.h" #endif #include "misc.h" #include "mlvalues.h" /* */ #include "io.h" /* Magic number */ #define Intext_magic_number 0x8495A6BE /* Codes for the compact format */ #define PREFIX_SMALL_BLOCK 0x80 #define PREFIX_SMALL_INT 0x40 #define PREFIX_SMALL_STRING 0x20 #define CODE_INT8 0x0 #define CODE_INT16 0x1 #define CODE_INT32 0x2 #define CODE_INT64 0x3 #define CODE_SHARED8 0x4 #define CODE_SHARED16 0x5 #define CODE_SHARED32 0x6 #define CODE_BLOCK32 0x8 #define CODE_BLOCK64 0x13 #define CODE_STRING8 0x9 #define CODE_STRING32 0xA #define CODE_DOUBLE_BIG 0xB #define CODE_DOUBLE_LITTLE 0xC #define CODE_DOUBLE_ARRAY8_BIG 0xD #define CODE_DOUBLE_ARRAY8_LITTLE 0xE #define CODE_DOUBLE_ARRAY32_BIG 0xF #define CODE_DOUBLE_ARRAY32_LITTLE 0x7 #define CODE_CODEPOINTER 0x10 #define CODE_INFIXPOINTER 0x11 #define CODE_CUSTOM 0x12 #if ARCH_FLOAT_ENDIANNESS == 0x76543210 #define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG #define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_BIG #define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_BIG #else #define CODE_DOUBLE_NATIVE CODE_DOUBLE_LITTLE #define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_LITTLE #define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_LITTLE #endif /* Size-ing data structures for extern. Chosen so that sizeof(struct trail_block) and sizeof(struct output_block) are slightly below 8Kb. */ #define ENTRIES_PER_TRAIL_BLOCK 1025 #define SIZE_EXTERN_OUTPUT_BLOCK 8100 /* The entry points */ void caml_output_val (struct channel * chan, value v, value flags); /* Output [v] with flags [flags] on the channel [chan]. */ /* */ #ifdef __cplusplus extern "C" { #endif CAMLextern void caml_output_value_to_malloc(value v, value flags, /*out*/ char ** buf, /*out*/ intnat * len); /* Output [v] with flags [flags] to a memory buffer allocated with malloc. On return, [*buf] points to the buffer and [*len] contains the number of bytes in buffer. */ CAMLextern intnat caml_output_value_to_block(value v, value flags, char * data, intnat len); /* Output [v] with flags [flags] to a user-provided memory buffer. [data] points to the start of this buffer, and [len] is its size in bytes. Return the number of bytes actually written in buffer. Raise [Failure] if buffer is too short. */ /* */ value caml_input_val (struct channel * chan); /* Read a structured value from the channel [chan]. */ /* */ CAMLextern value caml_input_val_from_string (value str, intnat ofs); /* Read a structured value from the OCaml string [str], starting at offset [ofs]. */ CAMLextern value caml_input_value_from_malloc(char * data, intnat ofs); /* Read a structured value from a malloced buffer. [data] points to the beginning of the buffer, and [ofs] is the offset of the beginning of the externed data in this buffer. The buffer is deallocated with [free] on return, or if an exception is raised. */ CAMLextern value caml_input_value_from_block(char * data, intnat len); /* Read a structured value from a user-provided buffer. [data] points to the beginning of the externed data in this buffer, and [len] is the length in bytes of valid data in this buffer. The buffer is never deallocated by this routine. */ /* Functions for writing user-defined marshallers */ CAMLextern void caml_serialize_int_1(int i); CAMLextern void caml_serialize_int_2(int i); CAMLextern void caml_serialize_int_4(int32 i); CAMLextern void caml_serialize_int_8(int64 i); CAMLextern void caml_serialize_float_4(float f); CAMLextern void caml_serialize_float_8(double f); CAMLextern void caml_serialize_block_1(void * data, intnat len); CAMLextern void caml_serialize_block_2(void * data, intnat len); CAMLextern void caml_serialize_block_4(void * data, intnat len); CAMLextern void caml_serialize_block_8(void * data, intnat len); CAMLextern void caml_serialize_block_float_8(void * data, intnat len); CAMLextern int caml_deserialize_uint_1(void); CAMLextern int caml_deserialize_sint_1(void); CAMLextern int caml_deserialize_uint_2(void); CAMLextern int caml_deserialize_sint_2(void); CAMLextern uint32 caml_deserialize_uint_4(void); CAMLextern int32 caml_deserialize_sint_4(void); CAMLextern uint64 caml_deserialize_uint_8(void); CAMLextern int64 caml_deserialize_sint_8(void); CAMLextern float caml_deserialize_float_4(void); CAMLextern double caml_deserialize_float_8(void); CAMLextern void caml_deserialize_block_1(void * data, intnat len); CAMLextern void caml_deserialize_block_2(void * data, intnat len); CAMLextern void caml_deserialize_block_4(void * data, intnat len); CAMLextern void caml_deserialize_block_8(void * data, intnat len); CAMLextern void caml_deserialize_block_float_8(void * data, intnat len); CAMLextern void caml_deserialize_error(char * msg); /* */ /* Auxiliary stuff for sending code pointers */ struct code_fragment { char * code_start; char * code_end; unsigned char digest[16]; char digest_computed; }; struct ext_table caml_code_fragments_table; /* */ #ifdef __cplusplus } #endif #endif /* CAML_INTEXT_H */ mingw-ocaml/ocaml/byterun/reverse.h0000644000175000017500000001266012124403240016776 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Swap byte-order in 16, 32, and 64-bit integers or floats */ #ifndef CAML_REVERSE_H #define CAML_REVERSE_H #define Reverse_16(dst,src) { \ char * _p, * _q; \ char _a; \ _p = (char *) (src); \ _q = (char *) (dst); \ _a = _p[0]; \ _q[0] = _p[1]; \ _q[1] = _a; \ } #define Reverse_32(dst,src) { \ char * _p, * _q; \ char _a, _b; \ _p = (char *) (src); \ _q = (char *) (dst); \ _a = _p[0]; \ _b = _p[1]; \ _q[0] = _p[3]; \ _q[1] = _p[2]; \ _q[3] = _a; \ _q[2] = _b; \ } #define Reverse_64(dst,src) { \ char * _p, * _q; \ char _a, _b; \ _p = (char *) (src); \ _q = (char *) (dst); \ _a = _p[0]; \ _b = _p[1]; \ _q[0] = _p[7]; \ _q[1] = _p[6]; \ _q[7] = _a; \ _q[6] = _b; \ _a = _p[2]; \ _b = _p[3]; \ _q[2] = _p[5]; \ _q[3] = _p[4]; \ _q[5] = _a; \ _q[4] = _b; \ } #define Perm_index(perm,i) ((perm >> (i * 4)) & 0xF) #define Permute_64(dst,perm_dst,src,perm_src) { \ char * _p; \ char _a, _b, _c, _d, _e, _f, _g, _h; \ _p = (char *) (src); \ _a = _p[Perm_index(perm_src, 0)]; \ _b = _p[Perm_index(perm_src, 1)]; \ _c = _p[Perm_index(perm_src, 2)]; \ _d = _p[Perm_index(perm_src, 3)]; \ _e = _p[Perm_index(perm_src, 4)]; \ _f = _p[Perm_index(perm_src, 5)]; \ _g = _p[Perm_index(perm_src, 6)]; \ _h = _p[Perm_index(perm_src, 7)]; \ _p = (char *) (dst); \ _p[Perm_index(perm_dst, 0)] = _a; \ _p[Perm_index(perm_dst, 1)] = _b; \ _p[Perm_index(perm_dst, 2)] = _c; \ _p[Perm_index(perm_dst, 3)] = _d; \ _p[Perm_index(perm_dst, 4)] = _e; \ _p[Perm_index(perm_dst, 5)] = _f; \ _p[Perm_index(perm_dst, 6)] = _g; \ _p[Perm_index(perm_dst, 7)] = _h; \ } #endif /* CAML_REVERSE_H */ mingw-ocaml/ocaml/byterun/alloc.h0000644000175000017500000000424012124403240016410 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_ALLOC_H #define CAML_ALLOC_H #ifndef CAML_NAME_SPACE #include "compatibility.h" #endif #include "misc.h" #include "mlvalues.h" #ifdef __cplusplus extern "C" { #endif CAMLextern value caml_alloc (mlsize_t, tag_t); CAMLextern value caml_alloc_small (mlsize_t, tag_t); CAMLextern value caml_alloc_tuple (mlsize_t); CAMLextern value caml_alloc_string (mlsize_t); /* size in bytes */ CAMLextern value caml_copy_string (char const *); CAMLextern value caml_copy_string_array (char const **); CAMLextern value caml_copy_double (double); CAMLextern value caml_copy_int32 (int32); /* defined in [ints.c] */ CAMLextern value caml_copy_int64 (int64); /* defined in [ints.c] */ CAMLextern value caml_copy_nativeint (intnat); /* defined in [ints.c] */ CAMLextern value caml_alloc_array (value (*funct) (char const *), char const ** array); typedef void (*final_fun)(value); CAMLextern value caml_alloc_final (mlsize_t, /*size in words*/ final_fun, /*finalization function*/ mlsize_t, /*resources consumed*/ mlsize_t /*max resources*/); CAMLextern int caml_convert_flag_list (value, int *); #ifdef __cplusplus } #endif #endif /* CAML_ALLOC_H */ mingw-ocaml/ocaml/byterun/memory.h0000644000175000017500000004135612124403240016637 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Allocation macros and functions */ #ifndef CAML_MEMORY_H #define CAML_MEMORY_H #ifndef CAML_NAME_SPACE #include "compatibility.h" #endif #include "config.h" /* */ #include "gc.h" #include "major_gc.h" #include "minor_gc.h" /* */ #include "misc.h" #include "mlvalues.h" #ifdef __cplusplus extern "C" { #endif CAMLextern value caml_alloc_shr (mlsize_t, tag_t); CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); CAMLextern void caml_alloc_dependent_memory (mlsize_t); CAMLextern void caml_free_dependent_memory (mlsize_t); CAMLextern void caml_modify (value *, value); CAMLextern void caml_initialize (value *, value); CAMLextern value caml_check_urgent_gc (value); CAMLextern void * caml_stat_alloc (asize_t); /* Size in bytes. */ CAMLextern void caml_stat_free (void *); CAMLextern void * caml_stat_resize (void *, asize_t); /* Size in bytes. */ char *caml_alloc_for_heap (asize_t request); /* Size in bytes. */ void caml_free_for_heap (char *mem); int caml_add_to_heap (char *mem); color_t caml_allocation_color (void *hp); /* void caml_shrink_heap (char *); Only used in compact.c */ /* */ #define Not_in_heap 0 #define In_heap 1 #define In_young 2 #define In_static_data 4 #define In_code_area 8 #ifdef ARCH_SIXTYFOUR /* 64 bits: Represent page table as a sparse hash table */ int caml_page_table_lookup(void * addr); #define Classify_addr(a) (caml_page_table_lookup((void *)(a))) #else /* 32 bits: Represent page table as a 2-level array */ #define Pagetable2_log 11 #define Pagetable2_size (1 << Pagetable2_log) #define Pagetable1_log (Page_log + Pagetable2_log) #define Pagetable1_size (1 << (32 - Pagetable1_log)) CAMLextern unsigned char * caml_page_table[Pagetable1_size]; #define Pagetable_index1(a) (((uintnat)(a)) >> Pagetable1_log) #define Pagetable_index2(a) \ ((((uintnat)(a)) >> Page_log) & (Pagetable2_size - 1)) #define Classify_addr(a) \ caml_page_table[Pagetable_index1(a)][Pagetable_index2(a)] #endif #define Is_in_value_area(a) \ (Classify_addr(a) & (In_heap | In_young | In_static_data)) #define Is_in_heap(a) (Classify_addr(a) & In_heap) #define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young)) int caml_page_table_add(int kind, void * start, void * end); int caml_page_table_remove(int kind, void * start, void * end); int caml_page_table_initialize(mlsize_t bytesize); #ifdef DEBUG #define DEBUG_clear(result, wosize) do{ \ uintnat caml__DEBUG_i; \ for (caml__DEBUG_i = 0; caml__DEBUG_i < (wosize); ++ caml__DEBUG_i){ \ Field ((result), caml__DEBUG_i) = Debug_uninit_minor; \ } \ }while(0) #else #define DEBUG_clear(result, wosize) #endif #define Alloc_small(result, wosize, tag) do{ CAMLassert ((wosize) >= 1); \ CAMLassert ((tag_t) (tag) < 256); \ CAMLassert ((wosize) <= Max_young_wosize); \ caml_young_ptr -= Bhsize_wosize (wosize); \ if (caml_young_ptr < caml_young_start){ \ caml_young_ptr += Bhsize_wosize (wosize); \ Setup_for_gc; \ caml_minor_collection (); \ Restore_after_gc; \ caml_young_ptr -= Bhsize_wosize (wosize); \ } \ Hd_hp (caml_young_ptr) = Make_header ((wosize), (tag), Caml_black); \ (result) = Val_hp (caml_young_ptr); \ DEBUG_clear ((result), (wosize)); \ }while(0) /* You must use [Modify] to change a field of an existing shared block, unless you are sure the value being overwritten is not a shared block and the value being written is not a young block. */ /* [Modify] never calls the GC. */ /* [Modify] can also be used to do assignment on data structures that are not in the (major) heap. In this case, it is a bit slower than simple assignment. In particular, you can use [Modify] when you don't know whether the block being changed is in the minor heap or the major heap. */ #define Modify(fp, val) do{ \ value _old_ = *(fp); \ *(fp) = (val); \ if (Is_in_heap (fp)){ \ if (caml_gc_phase == Phase_mark) caml_darken (_old_, NULL); \ if (Is_block (val) && Is_young (val) \ && ! (Is_block (_old_) && Is_young (_old_))){ \ if (caml_ref_table.ptr >= caml_ref_table.limit){ \ CAMLassert (caml_ref_table.ptr == caml_ref_table.limit); \ caml_realloc_ref_table (&caml_ref_table); \ } \ *caml_ref_table.ptr++ = (fp); \ } \ } \ }while(0) /* */ struct caml__roots_block { struct caml__roots_block *next; intnat ntables; intnat nitems; value *tables [5]; }; CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ /* The following macros are used to declare C local variables and function parameters of type [value]. The function body must start with one of the [CAMLparam] macros. If the function has no parameter of type [value], use [CAMLparam0]. If the function has 1 to 5 [value] parameters, use the corresponding [CAMLparam] with the parameters as arguments. If the function has more than 5 [value] parameters, use [CAMLparam5] for the first 5 parameters, and one or more calls to the [CAMLxparam] macros for the others. If the function takes an array of [value]s as argument, use [CAMLparamN] to declare it (or [CAMLxparamN] if you already have a call to [CAMLparam] for some other arguments). If you need local variables of type [value], declare them with one or more calls to the [CAMLlocal] macros at the beginning of the function, after the call to CAMLparam. Use [CAMLlocalN] (at the beginning of the function) to declare an array of [value]s. Your function may raise an exception or return a [value] with the [CAMLreturn] macro. Its argument is simply the [value] returned by your function. Do NOT directly return a [value] with the [return] keyword. If your function returns void, use [CAMLreturn0]. All the identifiers beginning with "caml__" are reserved by OCaml. Do not use them for anything (local or global variables, struct or union tags, macros, etc.) */ #define CAMLparam0() \ struct caml__roots_block *caml__frame = caml_local_roots #define CAMLparam1(x) \ CAMLparam0 (); \ CAMLxparam1 (x) #define CAMLparam2(x, y) \ CAMLparam0 (); \ CAMLxparam2 (x, y) #define CAMLparam3(x, y, z) \ CAMLparam0 (); \ CAMLxparam3 (x, y, z) #define CAMLparam4(x, y, z, t) \ CAMLparam0 (); \ CAMLxparam4 (x, y, z, t) #define CAMLparam5(x, y, z, t, u) \ CAMLparam0 (); \ CAMLxparam5 (x, y, z, t, u) #define CAMLparamN(x, size) \ CAMLparam0 (); \ CAMLxparamN (x, (size)) #if defined (__GNUC__) && (__GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ > 7)) #define CAMLunused __attribute__ ((unused)) #else #define CAMLunused #endif #define CAMLxparam1(x) \ struct caml__roots_block caml__roots_##x; \ CAMLunused int caml__dummy_##x = ( \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ (caml__roots_##x.ntables = 1), \ (caml__roots_##x.tables [0] = &x), \ 0) #define CAMLxparam2(x, y) \ struct caml__roots_block caml__roots_##x; \ CAMLunused int caml__dummy_##x = ( \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ (caml__roots_##x.ntables = 2), \ (caml__roots_##x.tables [0] = &x), \ (caml__roots_##x.tables [1] = &y), \ 0) #define CAMLxparam3(x, y, z) \ struct caml__roots_block caml__roots_##x; \ CAMLunused int caml__dummy_##x = ( \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ (caml__roots_##x.ntables = 3), \ (caml__roots_##x.tables [0] = &x), \ (caml__roots_##x.tables [1] = &y), \ (caml__roots_##x.tables [2] = &z), \ 0) #define CAMLxparam4(x, y, z, t) \ struct caml__roots_block caml__roots_##x; \ CAMLunused int caml__dummy_##x = ( \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ (caml__roots_##x.ntables = 4), \ (caml__roots_##x.tables [0] = &x), \ (caml__roots_##x.tables [1] = &y), \ (caml__roots_##x.tables [2] = &z), \ (caml__roots_##x.tables [3] = &t), \ 0) #define CAMLxparam5(x, y, z, t, u) \ struct caml__roots_block caml__roots_##x; \ CAMLunused int caml__dummy_##x = ( \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ (caml__roots_##x.ntables = 5), \ (caml__roots_##x.tables [0] = &x), \ (caml__roots_##x.tables [1] = &y), \ (caml__roots_##x.tables [2] = &z), \ (caml__roots_##x.tables [3] = &t), \ (caml__roots_##x.tables [4] = &u), \ 0) #define CAMLxparamN(x, size) \ struct caml__roots_block caml__roots_##x; \ CAMLunused int caml__dummy_##x = ( \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = (size)), \ (caml__roots_##x.ntables = 1), \ (caml__roots_##x.tables[0] = &(x[0])), \ 0) #define CAMLlocal1(x) \ value x = 0; \ CAMLxparam1 (x) #define CAMLlocal2(x, y) \ value x = 0, y = 0; \ CAMLxparam2 (x, y) #define CAMLlocal3(x, y, z) \ value x = 0, y = 0, z = 0; \ CAMLxparam3 (x, y, z) #define CAMLlocal4(x, y, z, t) \ value x = 0, y = 0, z = 0, t = 0; \ CAMLxparam4 (x, y, z, t) #define CAMLlocal5(x, y, z, t, u) \ value x = 0, y = 0, z = 0, t = 0, u = 0; \ CAMLxparam5 (x, y, z, t, u) #define CAMLlocalN(x, size) \ value x [(size)] = { 0, /* 0, 0, ... */ }; \ CAMLxparamN (x, (size)) #define CAMLreturn0 do{ \ caml_local_roots = caml__frame; \ return; \ }while (0) #define CAMLreturnT(type, result) do{ \ type caml__temp_result = (result); \ caml_local_roots = caml__frame; \ return (caml__temp_result); \ }while(0) #define CAMLreturn(result) CAMLreturnT(value, result) #define CAMLnoreturn ((void) caml__frame) /* convenience macro */ #define Store_field(block, offset, val) do{ \ mlsize_t caml__temp_offset = (offset); \ value caml__temp_val = (val); \ caml_modify (&Field ((block), caml__temp_offset), caml__temp_val); \ }while(0) /* NOTE: [Begin_roots] and [End_roots] are superseded by [CAMLparam]*, [CAMLxparam]*, [CAMLlocal]*, [CAMLreturn]. [Begin_roots] and [End_roots] are used for C variables that are GC roots. It must contain all values in C local variables and function parameters at the time the minor GC is called. Usage: After initialising your local variables to legal OCaml values, but before calling allocation functions, insert [Begin_roots_n(v1, ... vn)], where v1 ... vn are your variables of type [value] that you want to be updated across allocations. At the end, insert [End_roots()]. Note that [Begin_roots] opens a new block, and [End_roots] closes it. Thus they must occur in matching pairs at the same brace nesting level. You can use [Val_unit] as a dummy initial value for your variables. */ #define Begin_root Begin_roots1 #define Begin_roots1(r0) { \ struct caml__roots_block caml__roots_block; \ caml__roots_block.next = caml_local_roots; \ caml_local_roots = &caml__roots_block; \ caml__roots_block.nitems = 1; \ caml__roots_block.ntables = 1; \ caml__roots_block.tables[0] = &(r0); #define Begin_roots2(r0, r1) { \ struct caml__roots_block caml__roots_block; \ caml__roots_block.next = caml_local_roots; \ caml_local_roots = &caml__roots_block; \ caml__roots_block.nitems = 1; \ caml__roots_block.ntables = 2; \ caml__roots_block.tables[0] = &(r0); \ caml__roots_block.tables[1] = &(r1); #define Begin_roots3(r0, r1, r2) { \ struct caml__roots_block caml__roots_block; \ caml__roots_block.next = caml_local_roots; \ caml_local_roots = &caml__roots_block; \ caml__roots_block.nitems = 1; \ caml__roots_block.ntables = 3; \ caml__roots_block.tables[0] = &(r0); \ caml__roots_block.tables[1] = &(r1); \ caml__roots_block.tables[2] = &(r2); #define Begin_roots4(r0, r1, r2, r3) { \ struct caml__roots_block caml__roots_block; \ caml__roots_block.next = caml_local_roots; \ caml_local_roots = &caml__roots_block; \ caml__roots_block.nitems = 1; \ caml__roots_block.ntables = 4; \ caml__roots_block.tables[0] = &(r0); \ caml__roots_block.tables[1] = &(r1); \ caml__roots_block.tables[2] = &(r2); \ caml__roots_block.tables[3] = &(r3); #define Begin_roots5(r0, r1, r2, r3, r4) { \ struct caml__roots_block caml__roots_block; \ caml__roots_block.next = caml_local_roots; \ caml_local_roots = &caml__roots_block; \ caml__roots_block.nitems = 1; \ caml__roots_block.ntables = 5; \ caml__roots_block.tables[0] = &(r0); \ caml__roots_block.tables[1] = &(r1); \ caml__roots_block.tables[2] = &(r2); \ caml__roots_block.tables[3] = &(r3); \ caml__roots_block.tables[4] = &(r4); #define Begin_roots_block(table, size) { \ struct caml__roots_block caml__roots_block; \ caml__roots_block.next = caml_local_roots; \ caml_local_roots = &caml__roots_block; \ caml__roots_block.nitems = (size); \ caml__roots_block.ntables = 1; \ caml__roots_block.tables[0] = (table); #define End_roots() caml_local_roots = caml__roots_block.next; } /* [caml_register_global_root] registers a global C variable as a memory root for the duration of the program, or until [caml_remove_global_root] is called. */ CAMLextern void caml_register_global_root (value *); /* [caml_remove_global_root] removes a memory root registered on a global C variable with [caml_register_global_root]. */ CAMLextern void caml_remove_global_root (value *); /* [caml_register_generational_global_root] registers a global C variable as a memory root for the duration of the program, or until [caml_remove_generational_global_root] is called. The program guarantees that the value contained in this variable will not be assigned directly. If the program needs to change the value of this variable, it must do so by calling [caml_modify_generational_global_root]. The [value *] pointer passed to [caml_register_generational_global_root] must contain a valid OCaml value before the call. In return for these constraints, scanning of memory roots during minor collection is made more efficient. */ CAMLextern void caml_register_generational_global_root (value *); /* [caml_remove_generational_global_root] removes a memory root registered on a global C variable with [caml_register_generational_global_root]. */ CAMLextern void caml_remove_generational_global_root (value *); /* [caml_modify_generational_global_root(r, newval)] modifies the value contained in [r], storing [newval] inside. In other words, the assignment [*r = newval] is performed, but in a way that is compatible with the optimized scanning of generational global roots. [r] must be a global memory root previously registered with [caml_register_generational_global_root]. */ CAMLextern void caml_modify_generational_global_root(value *r, value newval); #ifdef __cplusplus } #endif #endif /* CAML_MEMORY_H */ mingw-ocaml/ocaml/byterun/.ignore0000644000175000017500000000023712124403240016433 0ustar tootstootsjumptbl.h primitives prims.c opnames.h version.h ocamlrun ocamlrun.exe ocamlrund ocamlrund.exe ld.conf interp.a.lst *.[sd]obj *.lib .gdb_history *.d.c *.pic.c mingw-ocaml/ocaml/byterun/md5.c0000644000175000017500000002463612124403240016011 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "alloc.h" #include "fail.h" #include "md5.h" #include "memory.h" #include "mlvalues.h" #include "io.h" #include "reverse.h" /* MD5 message digest */ CAMLprim value caml_md5_string(value str, value ofs, value len) { struct MD5Context ctx; value res; caml_MD5Init(&ctx); caml_MD5Update(&ctx, &Byte_u(str, Long_val(ofs)), Long_val(len)); res = caml_alloc_string(16); caml_MD5Final(&Byte_u(res, 0), &ctx); return res; } CAMLprim value caml_md5_chan(value vchan, value len) { CAMLparam2 (vchan, len); struct channel * chan = Channel(vchan); struct MD5Context ctx; value res; intnat toread, read; char buffer[4096]; Lock(chan); caml_MD5Init(&ctx); toread = Long_val(len); if (toread < 0){ while (1){ read = caml_getblock (chan, buffer, sizeof(buffer)); if (read == 0) break; caml_MD5Update (&ctx, (unsigned char *) buffer, read); } }else{ while (toread > 0) { read = caml_getblock(chan, buffer, toread > sizeof(buffer) ? sizeof(buffer) : toread); if (read == 0) caml_raise_end_of_file(); caml_MD5Update(&ctx, (unsigned char *) buffer, read); toread -= read; } } res = caml_alloc_string(16); caml_MD5Final(&Byte_u(res, 0), &ctx); Unlock(chan); CAMLreturn (res); } CAMLexport void caml_md5_block(unsigned char digest[16], void * data, uintnat len) { struct MD5Context ctx; caml_MD5Init(&ctx); caml_MD5Update(&ctx, data, len); caml_MD5Final(digest, &ctx); } /* * This code implements the MD5 message-digest algorithm. * The algorithm is due to Ron Rivest. This code was * written by Colin Plumb in 1993, no copyright is claimed. * This code is in the public domain; do with it what you wish. * * Equivalent code is available from RSA Data Security, Inc. * This code has been tested against that, and is equivalent, * except that you don't need to include two pages of legalese * with every copy. * * To compute the message digest of a chunk of bytes, declare an * MD5Context structure, pass it to caml_MD5Init, call caml_MD5Update as * needed on buffers full of bytes, and then call caml_MD5Final, which * will fill a supplied 16-byte array with the digest. */ #ifndef ARCH_BIG_ENDIAN #define byteReverse(buf, len) /* Nothing */ #else static void byteReverse(unsigned char * buf, unsigned longs) { uint32 t; do { t = (uint32) ((unsigned) buf[3] << 8 | buf[2]) << 16 | ((unsigned) buf[1] << 8 | buf[0]); *(uint32 *) buf = t; buf += 4; } while (--longs); } #endif /* * Start MD5 accumulation. Set bit count to 0 and buffer to mysterious * initialization constants. */ CAMLexport void caml_MD5Init(struct MD5Context *ctx) { ctx->buf[0] = 0x67452301; ctx->buf[1] = 0xefcdab89; ctx->buf[2] = 0x98badcfe; ctx->buf[3] = 0x10325476; ctx->bits[0] = 0; ctx->bits[1] = 0; } /* * Update context to reflect the concatenation of another buffer full * of bytes. */ CAMLexport void caml_MD5Update(struct MD5Context *ctx, unsigned char *buf, uintnat len) { uint32 t; /* Update bitcount */ t = ctx->bits[0]; if ((ctx->bits[0] = t + ((uint32) len << 3)) < t) ctx->bits[1]++; /* Carry from low to high */ ctx->bits[1] += len >> 29; t = (t >> 3) & 0x3f; /* Bytes already in shsInfo->data */ /* Handle any leading odd-sized chunks */ if (t) { unsigned char *p = (unsigned char *) ctx->in + t; t = 64 - t; if (len < t) { memcpy(p, buf, len); return; } memcpy(p, buf, t); byteReverse(ctx->in, 16); caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); buf += t; len -= t; } /* Process data in 64-byte chunks */ while (len >= 64) { memcpy(ctx->in, buf, 64); byteReverse(ctx->in, 16); caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); buf += 64; len -= 64; } /* Handle any remaining bytes of data. */ memcpy(ctx->in, buf, len); } /* * Final wrapup - pad to 64-byte boundary with the bit pattern * 1 0* (64-bit count of bits processed, MSB-first) */ CAMLexport void caml_MD5Final(unsigned char *digest, struct MD5Context *ctx) { unsigned count; unsigned char *p; /* Compute number of bytes mod 64 */ count = (ctx->bits[0] >> 3) & 0x3F; /* Set the first char of padding to 0x80. This is safe since there is always at least one byte free */ p = ctx->in + count; *p++ = 0x80; /* Bytes of padding needed to make 64 bytes */ count = 64 - 1 - count; /* Pad out to 56 mod 64 */ if (count < 8) { /* Two lots of padding: Pad the first block to 64 bytes */ memset(p, 0, count); byteReverse(ctx->in, 16); caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); /* Now fill the next block with 56 bytes */ memset(ctx->in, 0, 56); } else { /* Pad block to 56 bytes */ memset(p, 0, count - 8); } byteReverse(ctx->in, 14); /* Append length in bits and transform */ ((uint32 *) ctx->in)[14] = ctx->bits[0]; ((uint32 *) ctx->in)[15] = ctx->bits[1]; caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); byteReverse((unsigned char *) ctx->buf, 4); memcpy(digest, ctx->buf, 16); memset(ctx, 0, sizeof(ctx)); /* In case it's sensitive */ } /* The four core functions - F1 is optimized somewhat */ /* #define F1(x, y, z) (x & y | ~x & z) */ #define F1(x, y, z) (z ^ (x & (y ^ z))) #define F2(x, y, z) F1(z, x, y) #define F3(x, y, z) (x ^ y ^ z) #define F4(x, y, z) (y ^ (x | ~z)) /* This is the central step in the MD5 algorithm. */ #define MD5STEP(f, w, x, y, z, data, s) \ ( w += f(x, y, z) + data, w = w<>(32-s), w += x ) /* * The core of the MD5 algorithm, this alters an existing MD5 hash to * reflect the addition of 16 longwords of new data. caml_MD5Update blocks * the data and converts bytes into longwords for this routine. */ CAMLexport void caml_MD5Transform(uint32 *buf, uint32 *in) { register uint32 a, b, c, d; a = buf[0]; b = buf[1]; c = buf[2]; d = buf[3]; MD5STEP(F1, a, b, c, d, in[0] + 0xd76aa478, 7); MD5STEP(F1, d, a, b, c, in[1] + 0xe8c7b756, 12); MD5STEP(F1, c, d, a, b, in[2] + 0x242070db, 17); MD5STEP(F1, b, c, d, a, in[3] + 0xc1bdceee, 22); MD5STEP(F1, a, b, c, d, in[4] + 0xf57c0faf, 7); MD5STEP(F1, d, a, b, c, in[5] + 0x4787c62a, 12); MD5STEP(F1, c, d, a, b, in[6] + 0xa8304613, 17); MD5STEP(F1, b, c, d, a, in[7] + 0xfd469501, 22); MD5STEP(F1, a, b, c, d, in[8] + 0x698098d8, 7); MD5STEP(F1, d, a, b, c, in[9] + 0x8b44f7af, 12); MD5STEP(F1, c, d, a, b, in[10] + 0xffff5bb1, 17); MD5STEP(F1, b, c, d, a, in[11] + 0x895cd7be, 22); MD5STEP(F1, a, b, c, d, in[12] + 0x6b901122, 7); MD5STEP(F1, d, a, b, c, in[13] + 0xfd987193, 12); MD5STEP(F1, c, d, a, b, in[14] + 0xa679438e, 17); MD5STEP(F1, b, c, d, a, in[15] + 0x49b40821, 22); MD5STEP(F2, a, b, c, d, in[1] + 0xf61e2562, 5); MD5STEP(F2, d, a, b, c, in[6] + 0xc040b340, 9); MD5STEP(F2, c, d, a, b, in[11] + 0x265e5a51, 14); MD5STEP(F2, b, c, d, a, in[0] + 0xe9b6c7aa, 20); MD5STEP(F2, a, b, c, d, in[5] + 0xd62f105d, 5); MD5STEP(F2, d, a, b, c, in[10] + 0x02441453, 9); MD5STEP(F2, c, d, a, b, in[15] + 0xd8a1e681, 14); MD5STEP(F2, b, c, d, a, in[4] + 0xe7d3fbc8, 20); MD5STEP(F2, a, b, c, d, in[9] + 0x21e1cde6, 5); MD5STEP(F2, d, a, b, c, in[14] + 0xc33707d6, 9); MD5STEP(F2, c, d, a, b, in[3] + 0xf4d50d87, 14); MD5STEP(F2, b, c, d, a, in[8] + 0x455a14ed, 20); MD5STEP(F2, a, b, c, d, in[13] + 0xa9e3e905, 5); MD5STEP(F2, d, a, b, c, in[2] + 0xfcefa3f8, 9); MD5STEP(F2, c, d, a, b, in[7] + 0x676f02d9, 14); MD5STEP(F2, b, c, d, a, in[12] + 0x8d2a4c8a, 20); MD5STEP(F3, a, b, c, d, in[5] + 0xfffa3942, 4); MD5STEP(F3, d, a, b, c, in[8] + 0x8771f681, 11); MD5STEP(F3, c, d, a, b, in[11] + 0x6d9d6122, 16); MD5STEP(F3, b, c, d, a, in[14] + 0xfde5380c, 23); MD5STEP(F3, a, b, c, d, in[1] + 0xa4beea44, 4); MD5STEP(F3, d, a, b, c, in[4] + 0x4bdecfa9, 11); MD5STEP(F3, c, d, a, b, in[7] + 0xf6bb4b60, 16); MD5STEP(F3, b, c, d, a, in[10] + 0xbebfbc70, 23); MD5STEP(F3, a, b, c, d, in[13] + 0x289b7ec6, 4); MD5STEP(F3, d, a, b, c, in[0] + 0xeaa127fa, 11); MD5STEP(F3, c, d, a, b, in[3] + 0xd4ef3085, 16); MD5STEP(F3, b, c, d, a, in[6] + 0x04881d05, 23); MD5STEP(F3, a, b, c, d, in[9] + 0xd9d4d039, 4); MD5STEP(F3, d, a, b, c, in[12] + 0xe6db99e5, 11); MD5STEP(F3, c, d, a, b, in[15] + 0x1fa27cf8, 16); MD5STEP(F3, b, c, d, a, in[2] + 0xc4ac5665, 23); MD5STEP(F4, a, b, c, d, in[0] + 0xf4292244, 6); MD5STEP(F4, d, a, b, c, in[7] + 0x432aff97, 10); MD5STEP(F4, c, d, a, b, in[14] + 0xab9423a7, 15); MD5STEP(F4, b, c, d, a, in[5] + 0xfc93a039, 21); MD5STEP(F4, a, b, c, d, in[12] + 0x655b59c3, 6); MD5STEP(F4, d, a, b, c, in[3] + 0x8f0ccc92, 10); MD5STEP(F4, c, d, a, b, in[10] + 0xffeff47d, 15); MD5STEP(F4, b, c, d, a, in[1] + 0x85845dd1, 21); MD5STEP(F4, a, b, c, d, in[8] + 0x6fa87e4f, 6); MD5STEP(F4, d, a, b, c, in[15] + 0xfe2ce6e0, 10); MD5STEP(F4, c, d, a, b, in[6] + 0xa3014314, 15); MD5STEP(F4, b, c, d, a, in[13] + 0x4e0811a1, 21); MD5STEP(F4, a, b, c, d, in[4] + 0xf7537e82, 6); MD5STEP(F4, d, a, b, c, in[11] + 0xbd3af235, 10); MD5STEP(F4, c, d, a, b, in[2] + 0x2ad7d2bb, 15); MD5STEP(F4, b, c, d, a, in[9] + 0xeb86d391, 21); buf[0] += a; buf[1] += b; buf[2] += c; buf[3] += d; } mingw-ocaml/ocaml/byterun/globroots.c0000644000175000017500000002235312124403240017330 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Registration of global memory roots */ #include "memory.h" #include "misc.h" #include "mlvalues.h" #include "roots.h" #include "globroots.h" /* The sets of global memory roots are represented as skip lists (see William Pugh, "Skip lists: a probabilistic alternative to balanced binary trees", Comm. ACM 33(6), 1990). */ struct global_root { value * root; /* the address of the root */ struct global_root * forward[1]; /* variable-length array */ }; #define NUM_LEVELS 17 struct global_root_list { value * root; /* dummy value for layout compatibility */ struct global_root * forward[NUM_LEVELS]; /* forward chaining */ int level; /* max used level */ }; /* Generate a random level for a new node: 0 with probability 3/4, 1 with probability 3/16, 2 with probability 3/64, etc. We use a simple linear congruential PRNG (see Knuth vol 2) instead of random(), because we need exactly 32 bits of pseudo-random data (i.e. 2 * (NUM_LEVELS - 1)). Moreover, the congruential PRNG is faster and guaranteed to be deterministic (to reproduce bugs). */ static uint32 random_seed = 0; static int random_level(void) { uint32 r; int level = 0; /* Linear congruence with modulus = 2^32, multiplier = 69069 (Knuth vol 2 p. 106, line 15 of table 1), additive = 25173. */ r = random_seed = random_seed * 69069 + 25173; /* Knuth (vol 2 p. 13) shows that the least significant bits are "less random" than the most significant bits with a modulus of 2^m, so consume most significant bits first */ while ((r & 0xC0000000U) == 0xC0000000U) { level++; r = r << 2; } Assert(level < NUM_LEVELS); return level; } /* Insertion in a global root list */ static void caml_insert_global_root(struct global_root_list * rootlist, value * r) { struct global_root * update[NUM_LEVELS]; struct global_root * e, * f; int i, new_level; /* Init "cursor" to list head */ e = (struct global_root *) rootlist; /* Find place to insert new node */ for (i = rootlist->level; i >= 0; i--) { while (1) { f = e->forward[i]; if (f == NULL || f->root >= r) break; e = f; } update[i] = e; } e = e->forward[0]; /* If already present, don't do anything */ if (e != NULL && e->root == r) return; /* Insert additional element, updating list level if necessary */ new_level = random_level(); if (new_level > rootlist->level) { for (i = rootlist->level + 1; i <= new_level; i++) update[i] = (struct global_root *) rootlist; rootlist->level = new_level; } e = caml_stat_alloc(sizeof(struct global_root) + new_level * sizeof(struct global_root *)); e->root = r; for (i = 0; i <= new_level; i++) { e->forward[i] = update[i]->forward[i]; update[i]->forward[i] = e; } } /* Deletion in a global root list */ static void caml_delete_global_root(struct global_root_list * rootlist, value * r) { struct global_root * update[NUM_LEVELS]; struct global_root * e, * f; int i; /* Init "cursor" to list head */ e = (struct global_root *) rootlist; /* Find element in list */ for (i = rootlist->level; i >= 0; i--) { while (1) { f = e->forward[i]; if (f == NULL || f->root >= r) break; e = f; } update[i] = e; } e = e->forward[0]; /* If not found, nothing to do */ if (e == NULL || e->root != r) return; /* Rebuild list without node */ for (i = 0; i <= rootlist->level; i++) { if (update[i]->forward[i] == e) update[i]->forward[i] = e->forward[i]; } /* Reclaim list element */ caml_stat_free(e); /* Down-correct list level */ while (rootlist->level > 0 && rootlist->forward[rootlist->level] == NULL) rootlist->level--; } /* Iterate over a global root list */ static void caml_iterate_global_roots(scanning_action f, struct global_root_list * rootlist) { struct global_root * gr; for (gr = rootlist->forward[0]; gr != NULL; gr = gr->forward[0]) { f(*(gr->root), gr->root); } } /* Empty a global root list */ static void caml_empty_global_roots(struct global_root_list * rootlist) { struct global_root * gr, * next; int i; for (gr = rootlist->forward[0]; gr != NULL; /**/) { next = gr->forward[0]; caml_stat_free(gr); gr = next; } for (i = 0; i <= rootlist->level; i++) rootlist->forward[i] = NULL; rootlist->level = 0; } /* The three global root lists */ struct global_root_list caml_global_roots = { NULL, { NULL, }, 0 }; /* mutable roots, don't know whether old or young */ struct global_root_list caml_global_roots_young = { NULL, { NULL, }, 0 }; /* generational roots pointing to minor or major heap */ struct global_root_list caml_global_roots_old = { NULL, { NULL, }, 0 }; /* generational roots pointing to major heap */ /* Register a global C root of the mutable kind */ CAMLexport void caml_register_global_root(value *r) { Assert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */ caml_insert_global_root(&caml_global_roots, r); } /* Un-register a global C root of the mutable kind */ CAMLexport void caml_remove_global_root(value *r) { caml_delete_global_root(&caml_global_roots, r); } /* Register a global C root of the generational kind */ CAMLexport void caml_register_generational_global_root(value *r) { value v = *r; Assert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */ if (Is_block(v)) { if (Is_young(v)) caml_insert_global_root(&caml_global_roots_young, r); else if (Is_in_heap(v)) caml_insert_global_root(&caml_global_roots_old, r); } } /* Un-register a global C root of the generational kind */ CAMLexport void caml_remove_generational_global_root(value *r) { value v = *r; if (Is_block(v)) { if (Is_young(v)) caml_delete_global_root(&caml_global_roots_young, r); else if (Is_in_heap(v)) caml_delete_global_root(&caml_global_roots_old, r); } } /* Modify the value of a global C root of the generational kind */ CAMLexport void caml_modify_generational_global_root(value *r, value newval) { value oldval = *r; /* It is OK to have a root in roots_young that suddenly points to the old generation -- the next minor GC will take care of that. What needs corrective action is a root in roots_old that suddenly points to the young generation. */ if (Is_block(newval) && Is_young(newval) && Is_block(oldval) && Is_in_heap(oldval)) { caml_delete_global_root(&caml_global_roots_old, r); caml_insert_global_root(&caml_global_roots_young, r); } /* PR#4704 */ else if (!Is_block(oldval) && Is_block(newval)) { /* The previous value in the root was unboxed but now it is boxed. The root won't appear in any of the root lists thus far (by virtue of the operation of [caml_register_generational_global_root]), so we need to make sure it gets in, or else it will never be scanned. */ if (Is_young(newval)) caml_insert_global_root(&caml_global_roots_young, r); else if (Is_in_heap(newval)) caml_insert_global_root(&caml_global_roots_old, r); } else if (Is_block(oldval) && !Is_block(newval)) { /* The previous value in the root was boxed but now it is unboxed, so the root should be removed. If [oldval] is young, this will happen anyway at the next minor collection, but it is safer to delete it here. */ if (Is_young(oldval)) caml_delete_global_root(&caml_global_roots_young, r); else if (Is_in_heap(oldval)) caml_delete_global_root(&caml_global_roots_old, r); } /* end PR#4704 */ *r = newval; } /* Scan all global roots */ void caml_scan_global_roots(scanning_action f) { caml_iterate_global_roots(f, &caml_global_roots); caml_iterate_global_roots(f, &caml_global_roots_young); caml_iterate_global_roots(f, &caml_global_roots_old); } /* Scan global roots for a minor collection */ void caml_scan_global_young_roots(scanning_action f) { struct global_root * gr; caml_iterate_global_roots(f, &caml_global_roots); caml_iterate_global_roots(f, &caml_global_roots_young); /* Move young roots to old roots */ for (gr = caml_global_roots_young.forward[0]; gr != NULL; gr = gr->forward[0]) { caml_insert_global_root(&caml_global_roots_old, gr->root); } caml_empty_global_roots(&caml_global_roots_young); } mingw-ocaml/ocaml/byterun/io.c0000644000175000017500000005255112124403240015730 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Buffered input/output. */ #include #include #include #include #include #include "config.h" #ifdef HAS_UNISTD #include #endif #include "alloc.h" #include "custom.h" #include "fail.h" #include "io.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" #include "signals.h" #include "sys.h" #ifndef SEEK_SET #define SEEK_SET 0 #define SEEK_CUR 1 #define SEEK_END 2 #endif /* Hooks for locking channels */ CAMLexport void (*caml_channel_mutex_free) (struct channel *) = NULL; CAMLexport void (*caml_channel_mutex_lock) (struct channel *) = NULL; CAMLexport void (*caml_channel_mutex_unlock) (struct channel *) = NULL; CAMLexport void (*caml_channel_mutex_unlock_exn) (void) = NULL; /* List of opened channels */ CAMLexport struct channel * caml_all_opened_channels = NULL; /* Basic functions over type struct channel *. These functions can be called directly from C. No locking is performed. */ /* Functions shared between input and output */ CAMLexport struct channel * caml_open_descriptor_in(int fd) { struct channel * channel; channel = (struct channel *) caml_stat_alloc(sizeof(struct channel)); channel->fd = fd; caml_enter_blocking_section(); channel->offset = lseek(fd, 0, SEEK_CUR); caml_leave_blocking_section(); channel->curr = channel->max = channel->buff; channel->end = channel->buff + IO_BUFFER_SIZE; channel->mutex = NULL; channel->revealed = 0; channel->old_revealed = 0; channel->refcount = 0; channel->flags = 0; channel->next = caml_all_opened_channels; channel->prev = NULL; if (caml_all_opened_channels != NULL) caml_all_opened_channels->prev = channel; caml_all_opened_channels = channel; return channel; } CAMLexport struct channel * caml_open_descriptor_out(int fd) { struct channel * channel; channel = caml_open_descriptor_in(fd); channel->max = NULL; return channel; } static void unlink_channel(struct channel *channel) { if (channel->prev == NULL) { Assert (channel == caml_all_opened_channels); caml_all_opened_channels = caml_all_opened_channels->next; if (caml_all_opened_channels != NULL) caml_all_opened_channels->prev = NULL; } else { channel->prev->next = channel->next; if (channel->next != NULL) channel->next->prev = channel->prev; } } CAMLexport void caml_close_channel(struct channel *channel) { close(channel->fd); if (channel->refcount > 0) return; if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(channel); unlink_channel(channel); caml_stat_free(channel); } CAMLexport file_offset caml_channel_size(struct channel *channel) { file_offset offset; file_offset end; int fd; /* We extract data from [channel] before dropping the OCaml lock, in case someone else touches the block. */ fd = channel->fd; offset = channel->offset; caml_enter_blocking_section(); end = lseek(fd, 0, SEEK_END); if (end == -1 || lseek(fd, offset, SEEK_SET) != offset) { caml_leave_blocking_section(); caml_sys_error(NO_ARG); } caml_leave_blocking_section(); return end; } CAMLexport int caml_channel_binary_mode(struct channel *channel) { #if defined(_WIN32) || defined(__CYGWIN__) int oldmode = setmode(channel->fd, O_BINARY); if (oldmode == O_TEXT) setmode(channel->fd, O_TEXT); return oldmode == O_BINARY; #else return 1; #endif } /* Output */ #ifndef EINTR #define EINTR (-1) #endif #ifndef EAGAIN #define EAGAIN (-1) #endif #ifndef EWOULDBLOCK #define EWOULDBLOCK (-1) #endif static int do_write(int fd, char *p, int n) { int retcode; again: caml_enter_blocking_section(); retcode = write(fd, p, n); caml_leave_blocking_section(); if (retcode == -1) { if (errno == EINTR) goto again; if ((errno == EAGAIN || errno == EWOULDBLOCK) && n > 1) { /* We couldn't do a partial write here, probably because n <= PIPE_BUF and POSIX says that writes of less than PIPE_BUF characters must be atomic. We first try again with a partial write of 1 character. If that fails too, we'll raise Sys_blocked_io below. */ n = 1; goto again; } } if (retcode == -1) caml_sys_io_error(NO_ARG); return retcode; } /* Attempt to flush the buffer. This will make room in the buffer for at least one character. Returns true if the buffer is empty at the end of the flush, or false if some data remains in the buffer. */ CAMLexport int caml_flush_partial(struct channel *channel) { int towrite, written; towrite = channel->curr - channel->buff; if (towrite > 0) { written = do_write(channel->fd, channel->buff, towrite); channel->offset += written; if (written < towrite) memmove(channel->buff, channel->buff + written, towrite - written); channel->curr -= written; } return (channel->curr == channel->buff); } /* Flush completely the buffer. */ CAMLexport void caml_flush(struct channel *channel) { while (! caml_flush_partial(channel)) /*nothing*/; } /* Output data */ CAMLexport void caml_putword(struct channel *channel, uint32 w) { if (! caml_channel_binary_mode(channel)) caml_failwith("output_binary_int: not a binary channel"); putch(channel, w >> 24); putch(channel, w >> 16); putch(channel, w >> 8); putch(channel, w); } CAMLexport int caml_putblock(struct channel *channel, char *p, intnat len) { int n, free, towrite, written; n = len >= INT_MAX ? INT_MAX : (int) len; free = channel->end - channel->curr; if (n < free) { /* Write request small enough to fit in buffer: transfer to buffer. */ memmove(channel->curr, p, n); channel->curr += n; return n; } else { /* Write request overflows buffer (or just fills it up): transfer whatever fits to buffer and write the buffer */ memmove(channel->curr, p, free); towrite = channel->end - channel->buff; written = do_write(channel->fd, channel->buff, towrite); if (written < towrite) memmove(channel->buff, channel->buff + written, towrite - written); channel->offset += written; channel->curr = channel->end - written; return free; } } CAMLexport void caml_really_putblock(struct channel *channel, char *p, intnat len) { int written; while (len > 0) { written = caml_putblock(channel, p, len); p += written; len -= written; } } CAMLexport void caml_seek_out(struct channel *channel, file_offset dest) { caml_flush(channel); caml_enter_blocking_section(); if (lseek(channel->fd, dest, SEEK_SET) != dest) { caml_leave_blocking_section(); caml_sys_error(NO_ARG); } caml_leave_blocking_section(); channel->offset = dest; } CAMLexport file_offset caml_pos_out(struct channel *channel) { return channel->offset + (file_offset)(channel->curr - channel->buff); } /* Input */ /* caml_do_read is exported for Cash */ CAMLexport int caml_do_read(int fd, char *p, unsigned int n) { int retcode; do { caml_enter_blocking_section(); retcode = read(fd, p, n); #if defined(_WIN32) if (retcode == -1 && errno == ENOMEM && n > 16384){ retcode = read(fd, p, 16384); } #endif caml_leave_blocking_section(); } while (retcode == -1 && errno == EINTR); if (retcode == -1) caml_sys_io_error(NO_ARG); return retcode; } CAMLexport unsigned char caml_refill(struct channel *channel) { int n; n = caml_do_read(channel->fd, channel->buff, channel->end - channel->buff); if (n == 0) caml_raise_end_of_file(); channel->offset += n; channel->max = channel->buff + n; channel->curr = channel->buff + 1; return (unsigned char)(channel->buff[0]); } CAMLexport uint32 caml_getword(struct channel *channel) { int i; uint32 res; if (! caml_channel_binary_mode(channel)) caml_failwith("input_binary_int: not a binary channel"); res = 0; for(i = 0; i < 4; i++) { res = (res << 8) + getch(channel); } return res; } CAMLexport int caml_getblock(struct channel *channel, char *p, intnat len) { int n, avail, nread; n = len >= INT_MAX ? INT_MAX : (int) len; avail = channel->max - channel->curr; if (n <= avail) { memmove(p, channel->curr, n); channel->curr += n; return n; } else if (avail > 0) { memmove(p, channel->curr, avail); channel->curr += avail; return avail; } else { nread = caml_do_read(channel->fd, channel->buff, channel->end - channel->buff); channel->offset += nread; channel->max = channel->buff + nread; if (n > nread) n = nread; memmove(p, channel->buff, n); channel->curr = channel->buff + n; return n; } } CAMLexport int caml_really_getblock(struct channel *chan, char *p, intnat n) { int r; while (n > 0) { r = caml_getblock(chan, p, n); if (r == 0) break; p += r; n -= r; } return (n == 0); } CAMLexport void caml_seek_in(struct channel *channel, file_offset dest) { if (dest >= channel->offset - (channel->max - channel->buff) && dest <= channel->offset) { channel->curr = channel->max - (channel->offset - dest); } else { caml_enter_blocking_section(); if (lseek(channel->fd, dest, SEEK_SET) != dest) { caml_leave_blocking_section(); caml_sys_error(NO_ARG); } caml_leave_blocking_section(); channel->offset = dest; channel->curr = channel->max = channel->buff; } } CAMLexport file_offset caml_pos_in(struct channel *channel) { return channel->offset - (file_offset)(channel->max - channel->curr); } CAMLexport intnat caml_input_scan_line(struct channel *channel) { char * p; int n; p = channel->curr; do { if (p >= channel->max) { /* No more characters available in the buffer */ if (channel->curr > channel->buff) { /* Try to make some room in the buffer by shifting the unread portion at the beginning */ memmove(channel->buff, channel->curr, channel->max - channel->curr); n = channel->curr - channel->buff; channel->curr -= n; channel->max -= n; p -= n; } if (channel->max >= channel->end) { /* Buffer is full, no room to read more characters from the input. Return the number of characters in the buffer, with negative sign to indicate that no newline was encountered. */ return -(channel->max - channel->curr); } /* Fill the buffer as much as possible */ n = caml_do_read(channel->fd, channel->max, channel->end - channel->max); if (n == 0) { /* End-of-file encountered. Return the number of characters in the buffer, with negative sign since we haven't encountered a newline. */ return -(channel->max - channel->curr); } channel->offset += n; channel->max += n; } } while (*p++ != '\n'); /* Found a newline. Return the length of the line, newline included. */ return (p - channel->curr); } /* OCaml entry points for the I/O functions. Wrap struct channel * objects into a heap-allocated object. Perform locking and unlocking around the I/O operations. */ /* FIXME CAMLexport, but not in io.h exported for Cash ? */ CAMLexport void caml_finalize_channel(value vchan) { struct channel * chan = Channel(vchan); if (--chan->refcount > 0) return; if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(chan); unlink_channel(chan); caml_stat_free(chan); } static int compare_channel(value vchan1, value vchan2) { struct channel * chan1 = Channel(vchan1); struct channel * chan2 = Channel(vchan2); return (chan1 == chan2) ? 0 : (chan1 < chan2) ? -1 : 1; } static intnat hash_channel(value vchan) { return (intnat) (Channel(vchan)); } static struct custom_operations channel_operations = { "_chan", caml_finalize_channel, compare_channel, hash_channel, custom_serialize_default, custom_deserialize_default, custom_compare_ext_default }; CAMLexport value caml_alloc_channel(struct channel *chan) { value res; chan->refcount++; /* prevent finalization during next alloc */ res = caml_alloc_custom(&channel_operations, sizeof(struct channel *), 1, 1000); Channel(res) = chan; return res; } CAMLprim value caml_ml_open_descriptor_in(value fd) { return caml_alloc_channel(caml_open_descriptor_in(Int_val(fd))); } CAMLprim value caml_ml_open_descriptor_out(value fd) { return caml_alloc_channel(caml_open_descriptor_out(Int_val(fd))); } #define Pair_tag 0 CAMLprim value caml_ml_out_channels_list (value unit) { CAMLparam0 (); CAMLlocal3 (res, tail, chan); struct channel * channel; res = Val_emptylist; for (channel = caml_all_opened_channels; channel != NULL; channel = channel->next) /* Testing channel->fd >= 0 looks unnecessary, as caml_ml_close_channel changes max when setting fd to -1. */ if (channel->max == NULL) { chan = caml_alloc_channel (channel); tail = res; res = caml_alloc_small (2, Pair_tag); Field (res, 0) = chan; Field (res, 1) = tail; } CAMLreturn (res); } CAMLprim value caml_channel_descriptor(value vchannel) { int fd = Channel(vchannel)->fd; if (fd == -1) { errno = EBADF; caml_sys_error(NO_ARG); } return Val_int(fd); } CAMLprim value caml_ml_close_channel(value vchannel) { int result; int do_syscall; int fd; /* For output channels, must have flushed before */ struct channel * channel = Channel(vchannel); if (channel->fd != -1){ fd = channel->fd; channel->fd = -1; do_syscall = 1; }else{ do_syscall = 0; result = 0; } /* Ensure that every read or write on the channel will cause an immediate caml_flush_partial or caml_refill, thus raising a Sys_error exception */ channel->curr = channel->max = channel->end; if (do_syscall) { caml_enter_blocking_section(); result = close(fd); caml_leave_blocking_section(); } if (result == -1) caml_sys_error (NO_ARG); return Val_unit; } /* EOVERFLOW is the Unix98 error indicating that a file position or file size is not representable. ERANGE is the ANSI C error indicating that some argument to some function is out of range. This is less precise than EOVERFLOW, but guaranteed to be defined on all ANSI C environments. */ #ifndef EOVERFLOW #define EOVERFLOW ERANGE #endif CAMLprim value caml_ml_channel_size(value vchannel) { file_offset size = caml_channel_size(Channel(vchannel)); if (size > Max_long) { errno = EOVERFLOW; caml_sys_error(NO_ARG); } return Val_long(size); } CAMLprim value caml_ml_channel_size_64(value vchannel) { return Val_file_offset(caml_channel_size(Channel(vchannel))); } CAMLprim value caml_ml_set_binary_mode(value vchannel, value mode) { #if defined(_WIN32) || defined(__CYGWIN__) struct channel * channel = Channel(vchannel); if (setmode(channel->fd, Bool_val(mode) ? O_BINARY : O_TEXT) == -1) caml_sys_error(NO_ARG); #endif return Val_unit; } /* If the channel is closed, DO NOT raise a "bad file descriptor" exception, but do nothing (the buffer is already empty). This is because some libraries will flush at exit, even on file descriptors that may be closed. */ CAMLprim value caml_ml_flush_partial(value vchannel) { CAMLparam1 (vchannel); struct channel * channel = Channel(vchannel); int res; if (channel->fd == -1) CAMLreturn(Val_true); Lock(channel); res = caml_flush_partial(channel); Unlock(channel); CAMLreturn (Val_bool(res)); } CAMLprim value caml_ml_flush(value vchannel) { CAMLparam1 (vchannel); struct channel * channel = Channel(vchannel); if (channel->fd == -1) CAMLreturn(Val_unit); Lock(channel); caml_flush(channel); Unlock(channel); CAMLreturn (Val_unit); } CAMLprim value caml_ml_output_char(value vchannel, value ch) { CAMLparam2 (vchannel, ch); struct channel * channel = Channel(vchannel); Lock(channel); putch(channel, Long_val(ch)); Unlock(channel); CAMLreturn (Val_unit); } CAMLprim value caml_ml_output_int(value vchannel, value w) { CAMLparam2 (vchannel, w); struct channel * channel = Channel(vchannel); Lock(channel); caml_putword(channel, Long_val(w)); Unlock(channel); CAMLreturn (Val_unit); } CAMLprim value caml_ml_output_partial(value vchannel, value buff, value start, value length) { CAMLparam4 (vchannel, buff, start, length); struct channel * channel = Channel(vchannel); int res; Lock(channel); res = caml_putblock(channel, &Byte(buff, Long_val(start)), Long_val(length)); Unlock(channel); CAMLreturn (Val_int(res)); } CAMLprim value caml_ml_output(value vchannel, value buff, value start, value length) { CAMLparam4 (vchannel, buff, start, length); struct channel * channel = Channel(vchannel); intnat pos = Long_val(start); intnat len = Long_val(length); Lock(channel); while (len > 0) { int written = caml_putblock(channel, &Byte(buff, pos), len); pos += written; len -= written; } Unlock(channel); CAMLreturn (Val_unit); } CAMLprim value caml_ml_seek_out(value vchannel, value pos) { CAMLparam2 (vchannel, pos); struct channel * channel = Channel(vchannel); Lock(channel); caml_seek_out(channel, Long_val(pos)); Unlock(channel); CAMLreturn (Val_unit); } CAMLprim value caml_ml_seek_out_64(value vchannel, value pos) { CAMLparam2 (vchannel, pos); struct channel * channel = Channel(vchannel); Lock(channel); caml_seek_out(channel, File_offset_val(pos)); Unlock(channel); CAMLreturn (Val_unit); } CAMLprim value caml_ml_pos_out(value vchannel) { file_offset pos = caml_pos_out(Channel(vchannel)); if (pos > Max_long) { errno = EOVERFLOW; caml_sys_error(NO_ARG); } return Val_long(pos); } CAMLprim value caml_ml_pos_out_64(value vchannel) { return Val_file_offset(caml_pos_out(Channel(vchannel))); } CAMLprim value caml_ml_input_char(value vchannel) { CAMLparam1 (vchannel); struct channel * channel = Channel(vchannel); unsigned char c; Lock(channel); c = getch(channel); Unlock(channel); CAMLreturn (Val_long(c)); } CAMLprim value caml_ml_input_int(value vchannel) { CAMLparam1 (vchannel); struct channel * channel = Channel(vchannel); intnat i; Lock(channel); i = caml_getword(channel); Unlock(channel); #ifdef ARCH_SIXTYFOUR i = (i << 32) >> 32; /* Force sign extension */ #endif CAMLreturn (Val_long(i)); } CAMLprim value caml_ml_input(value vchannel, value buff, value vstart, value vlength) { CAMLparam4 (vchannel, buff, vstart, vlength); struct channel * channel = Channel(vchannel); intnat start, len; int n, avail, nread; Lock(channel); /* We cannot call caml_getblock here because buff may move during caml_do_read */ start = Long_val(vstart); len = Long_val(vlength); n = len >= INT_MAX ? INT_MAX : (int) len; avail = channel->max - channel->curr; if (n <= avail) { memmove(&Byte(buff, start), channel->curr, n); channel->curr += n; } else if (avail > 0) { memmove(&Byte(buff, start), channel->curr, avail); channel->curr += avail; n = avail; } else { nread = caml_do_read(channel->fd, channel->buff, channel->end - channel->buff); channel->offset += nread; channel->max = channel->buff + nread; if (n > nread) n = nread; memmove(&Byte(buff, start), channel->buff, n); channel->curr = channel->buff + n; } Unlock(channel); CAMLreturn (Val_long(n)); } CAMLprim value caml_ml_seek_in(value vchannel, value pos) { CAMLparam2 (vchannel, pos); struct channel * channel = Channel(vchannel); Lock(channel); caml_seek_in(channel, Long_val(pos)); Unlock(channel); CAMLreturn (Val_unit); } CAMLprim value caml_ml_seek_in_64(value vchannel, value pos) { CAMLparam2 (vchannel, pos); struct channel * channel = Channel(vchannel); Lock(channel); caml_seek_in(channel, File_offset_val(pos)); Unlock(channel); CAMLreturn (Val_unit); } CAMLprim value caml_ml_pos_in(value vchannel) { file_offset pos = caml_pos_in(Channel(vchannel)); if (pos > Max_long) { errno = EOVERFLOW; caml_sys_error(NO_ARG); } return Val_long(pos); } CAMLprim value caml_ml_pos_in_64(value vchannel) { return Val_file_offset(caml_pos_in(Channel(vchannel))); } CAMLprim value caml_ml_input_scan_line(value vchannel) { CAMLparam1 (vchannel); struct channel * channel = Channel(vchannel); intnat res; Lock(channel); res = caml_input_scan_line(channel); Unlock(channel); CAMLreturn (Val_long(res)); } /* Conversion between file_offset and int64 */ #ifndef ARCH_INT64_TYPE CAMLexport value caml_Val_file_offset(file_offset fofs) { int64 ofs; ofs.l = fofs; ofs.h = 0; return caml_copy_int64(ofs); } CAMLexport file_offset caml_File_offset_val(value v) { int64 ofs = Int64_val(v); return (file_offset) ofs.l; } #endif mingw-ocaml/ocaml/byterun/lexing.c0000644000175000017500000001633412124403240016606 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* The table-driven automaton for lexers generated by camllex. */ #include "fail.h" #include "mlvalues.h" #include "stacks.h" struct lexer_buffer { value refill_buff; value lex_buffer; value lex_buffer_len; value lex_abs_pos; value lex_start_pos; value lex_curr_pos; value lex_last_pos; value lex_last_action; value lex_eof_reached; value lex_mem; value lex_start_p; value lex_curr_p; }; struct lexing_table { value lex_base; value lex_backtrk; value lex_default; value lex_trans; value lex_check; value lex_base_code; value lex_backtrk_code; value lex_default_code; value lex_trans_code; value lex_check_code; value lex_code; }; #if defined(ARCH_BIG_ENDIAN) || SIZEOF_SHORT != 2 #define Short(tbl,n) \ (*((unsigned char *)((tbl) + (n) * 2)) + \ (*((schar *)((tbl) + (n) * 2 + 1)) << 8)) #else #define Short(tbl,n) (((short *)(tbl))[(n)]) #endif CAMLprim value caml_lex_engine(struct lexing_table *tbl, value start_state, struct lexer_buffer *lexbuf) { int state, base, backtrk, c; state = Int_val(start_state); if (state >= 0) { /* First entry */ lexbuf->lex_last_pos = lexbuf->lex_start_pos = lexbuf->lex_curr_pos; lexbuf->lex_last_action = Val_int(-1); } else { /* Reentry after refill */ state = -state - 1; } while(1) { /* Lookup base address or action number for current state */ base = Short(tbl->lex_base, state); if (base < 0) return Val_int(-base-1); /* See if it's a backtrack point */ backtrk = Short(tbl->lex_backtrk, state); if (backtrk >= 0) { lexbuf->lex_last_pos = lexbuf->lex_curr_pos; lexbuf->lex_last_action = Val_int(backtrk); } /* See if we need a refill */ if (lexbuf->lex_curr_pos >= lexbuf->lex_buffer_len){ if (lexbuf->lex_eof_reached == Val_bool (0)){ return Val_int(-state - 1); }else{ c = 256; } }else{ /* Read next input char */ c = Byte_u(lexbuf->lex_buffer, Long_val(lexbuf->lex_curr_pos)); lexbuf->lex_curr_pos += 2; } /* Determine next state */ if (Short(tbl->lex_check, base + c) == state) state = Short(tbl->lex_trans, base + c); else state = Short(tbl->lex_default, state); /* If no transition on this char, return to last backtrack point */ if (state < 0) { lexbuf->lex_curr_pos = lexbuf->lex_last_pos; if (lexbuf->lex_last_action == Val_int(-1)) { caml_failwith("lexing: empty token"); } else { return lexbuf->lex_last_action; } }else{ /* Erase the EOF condition only if the EOF pseudo-character was consumed by the automaton (i.e. there was no backtrack above) */ if (c == 256) lexbuf->lex_eof_reached = Val_bool (0); } } } /***********************************************/ /* New lexer engine, with memory of positions */ /***********************************************/ static void run_mem(char *pc, value mem, value curr_pos) { for (;;) { unsigned char dst, src ; dst = *pc++ ; if (dst == 0xff) return ; src = *pc++ ; if (src == 0xff) { /* fprintf(stderr,"[%hhu] <- %d\n",dst,Int_val(curr_pos)) ;*/ Field(mem,dst) = curr_pos ; } else { /* fprintf(stderr,"[%hhu] <- [%hhu]\n",dst,src) ; */ Field(mem,dst) = Field(mem,src) ; } } } static void run_tag(char *pc, value mem) { for (;;) { unsigned char dst, src ; dst = *pc++ ; if (dst == 0xff) return ; src = *pc++ ; if (src == 0xff) { /* fprintf(stderr,"[%hhu] <- -1\n",dst) ; */ Field(mem,dst) = Val_int(-1) ; } else { /* fprintf(stderr,"[%hhu] <- [%hhu]\n",dst,src) ; */ Field(mem,dst) = Field(mem,src) ; } } } CAMLprim value caml_new_lex_engine(struct lexing_table *tbl, value start_state, struct lexer_buffer *lexbuf) { int state, base, backtrk, c, pstate ; state = Int_val(start_state); if (state >= 0) { /* First entry */ lexbuf->lex_last_pos = lexbuf->lex_start_pos = lexbuf->lex_curr_pos; lexbuf->lex_last_action = Val_int(-1); } else { /* Reentry after refill */ state = -state - 1; } while(1) { /* Lookup base address or action number for current state */ base = Short(tbl->lex_base, state); if (base < 0) { int pc_off = Short(tbl->lex_base_code, state) ; run_tag(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem); /* fprintf(stderr,"Perform: %d\n",-base-1) ; */ return Val_int(-base-1); } /* See if it's a backtrack point */ backtrk = Short(tbl->lex_backtrk, state); if (backtrk >= 0) { int pc_off = Short(tbl->lex_backtrk_code, state); run_tag(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem); lexbuf->lex_last_pos = lexbuf->lex_curr_pos; lexbuf->lex_last_action = Val_int(backtrk); } /* See if we need a refill */ if (lexbuf->lex_curr_pos >= lexbuf->lex_buffer_len){ if (lexbuf->lex_eof_reached == Val_bool (0)){ return Val_int(-state - 1); }else{ c = 256; } }else{ /* Read next input char */ c = Byte_u(lexbuf->lex_buffer, Long_val(lexbuf->lex_curr_pos)); lexbuf->lex_curr_pos += 2; } /* Determine next state */ pstate=state ; if (Short(tbl->lex_check, base + c) == state) state = Short(tbl->lex_trans, base + c); else state = Short(tbl->lex_default, state); /* If no transition on this char, return to last backtrack point */ if (state < 0) { lexbuf->lex_curr_pos = lexbuf->lex_last_pos; if (lexbuf->lex_last_action == Val_int(-1)) { caml_failwith("lexing: empty token"); } else { return lexbuf->lex_last_action; } }else{ /* If some transition, get and perform memory moves */ int base_code = Short(tbl->lex_base_code, pstate) ; int pc_off ; if (Short(tbl->lex_check_code, base_code + c) == pstate) pc_off = Short(tbl->lex_trans_code, base_code + c) ; else pc_off = Short(tbl->lex_default_code, pstate) ; if (pc_off > 0) run_mem(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem, lexbuf->lex_curr_pos) ; /* Erase the EOF condition only if the EOF pseudo-character was consumed by the automaton (i.e. there was no backtrack above) */ if (c == 256) lexbuf->lex_eof_reached = Val_bool (0); } } } mingw-ocaml/ocaml/byterun/compact.h0000644000175000017500000000211412124403240016742 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_COMPACT_H #define CAML_COMPACT_H #include "config.h" #include "misc.h" extern void caml_compact_heap (void); extern void caml_compact_heap_maybe (void); #endif /* CAML_COMPACT_H */ mingw-ocaml/ocaml/byterun/stacks.c0000644000175000017500000000776512124403240016620 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* To initialize and resize the stacks */ #include #include "config.h" #include "fail.h" #include "misc.h" #include "mlvalues.h" #include "stacks.h" CAMLexport value * caml_stack_low; CAMLexport value * caml_stack_high; CAMLexport value * caml_stack_threshold; CAMLexport value * caml_extern_sp; CAMLexport value * caml_trapsp; CAMLexport value * caml_trap_barrier; value caml_global_data = 0; uintnat caml_max_stack_size; /* also used in gc_ctrl.c */ void caml_init_stack (uintnat initial_max_size) { caml_stack_low = (value *) caml_stat_alloc(Stack_size); caml_stack_high = caml_stack_low + Stack_size / sizeof (value); caml_stack_threshold = caml_stack_low + Stack_threshold / sizeof (value); caml_extern_sp = caml_stack_high; caml_trapsp = caml_stack_high; caml_trap_barrier = caml_stack_high + 1; caml_max_stack_size = initial_max_size; caml_gc_message (0x08, "Initial stack limit: %luk bytes\n", caml_max_stack_size / 1024 * sizeof (value)); } void caml_realloc_stack(asize_t required_space) { asize_t size; value * new_low, * new_high, * new_sp; value * p; Assert(caml_extern_sp >= caml_stack_low); size = caml_stack_high - caml_stack_low; do { if (size >= caml_max_stack_size) caml_raise_stack_overflow(); size *= 2; } while (size < caml_stack_high - caml_extern_sp + required_space); caml_gc_message (0x08, "Growing stack to %" ARCH_INTNAT_PRINTF_FORMAT "uk bytes\n", (uintnat) size * sizeof(value) / 1024); new_low = (value *) caml_stat_alloc(size * sizeof(value)); new_high = new_low + size; #define shift(ptr) \ ((char *) new_high - ((char *) caml_stack_high - (char *) (ptr))) new_sp = (value *) shift(caml_extern_sp); memmove((char *) new_sp, (char *) caml_extern_sp, (caml_stack_high - caml_extern_sp) * sizeof(value)); caml_stat_free(caml_stack_low); caml_trapsp = (value *) shift(caml_trapsp); caml_trap_barrier = (value *) shift(caml_trap_barrier); for (p = caml_trapsp; p < new_high; p = Trap_link(p)) Trap_link(p) = (value *) shift(Trap_link(p)); caml_stack_low = new_low; caml_stack_high = new_high; caml_stack_threshold = caml_stack_low + Stack_threshold / sizeof (value); caml_extern_sp = new_sp; #undef shift } CAMLprim value caml_ensure_stack_capacity(value required_space) { asize_t req = Long_val(required_space); if (caml_extern_sp - req < caml_stack_low) caml_realloc_stack(req); return Val_unit; } void caml_change_max_stack_size (uintnat new_max_size) { asize_t size = caml_stack_high - caml_extern_sp + Stack_threshold / sizeof (value); if (new_max_size < size) new_max_size = size; if (new_max_size != caml_max_stack_size){ caml_gc_message (0x08, "Changing stack limit to %luk bytes\n", new_max_size * sizeof (value) / 1024); } caml_max_stack_size = new_max_size; } CAMLexport uintnat (*caml_stack_usage_hook)(void) = NULL; uintnat caml_stack_usage(void) { uintnat sz; sz = caml_stack_high - caml_extern_sp; if (caml_stack_usage_hook != NULL) sz += (*caml_stack_usage_hook)(); return sz; } mingw-ocaml/ocaml/byterun/extern.c0000644000175000017500000005561512124403240016632 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Structured output */ /* The interface of this file is "intext.h" */ #include #include "alloc.h" #include "custom.h" #include "fail.h" #include "gc.h" #include "intext.h" #include "io.h" #include "md5.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" #include "reverse.h" static uintnat obj_counter; /* Number of objects emitted so far */ static uintnat size_32; /* Size in words of 32-bit block for struct. */ static uintnat size_64; /* Size in words of 64-bit block for struct. */ static int extern_ignore_sharing; /* Flag to ignore sharing */ static int extern_closures; /* Flag to allow externing code pointers */ /* Trail mechanism to undo forwarding pointers put inside objects */ struct trail_entry { value obj; /* address of object + initial color in low 2 bits */ value field0; /* initial contents of field 0 */ }; struct trail_block { struct trail_block * previous; struct trail_entry entries[ENTRIES_PER_TRAIL_BLOCK]; }; static struct trail_block extern_trail_first; static struct trail_block * extern_trail_block; static struct trail_entry * extern_trail_cur, * extern_trail_limit; /* Stack for pending values to marshal */ struct extern_item { value * v; mlsize_t count; }; #define EXTERN_STACK_INIT_SIZE 256 #define EXTERN_STACK_MAX_SIZE (1024*1024*100) static struct extern_item extern_stack_init[EXTERN_STACK_INIT_SIZE]; static struct extern_item * extern_stack = extern_stack_init; static struct extern_item * extern_stack_limit = extern_stack_init + EXTERN_STACK_INIT_SIZE; /* Forward declarations */ static void extern_out_of_memory(void); static void extern_invalid_argument(char *msg); static void extern_failwith(char *msg); static void extern_stack_overflow(void); static struct code_fragment * extern_find_code(char *addr); static void extern_replay_trail(void); static void free_extern_output(void); /* Free the extern stack if needed */ static void extern_free_stack(void) { if (extern_stack != extern_stack_init) { free(extern_stack); /* Reinitialize the globals for next time around */ extern_stack = extern_stack_init; extern_stack_limit = extern_stack + EXTERN_STACK_INIT_SIZE; } } static struct extern_item * extern_resize_stack(struct extern_item * sp) { asize_t newsize = 2 * (extern_stack_limit - extern_stack); asize_t sp_offset = sp - extern_stack; struct extern_item * newstack; if (newsize >= EXTERN_STACK_MAX_SIZE) extern_stack_overflow(); if (extern_stack == extern_stack_init) { newstack = malloc(sizeof(struct extern_item) * newsize); if (newstack == NULL) extern_stack_overflow(); memcpy(newstack, extern_stack_init, sizeof(struct extern_item) * EXTERN_STACK_INIT_SIZE); } else { newstack = realloc(extern_stack, sizeof(struct extern_item) * newsize); if (newstack == NULL) extern_stack_overflow(); } extern_stack = newstack; extern_stack_limit = newstack + newsize; return newstack + sp_offset; } /* Initialize the trail */ static void init_extern_trail(void) { extern_trail_block = &extern_trail_first; extern_trail_cur = extern_trail_block->entries; extern_trail_limit = extern_trail_block->entries + ENTRIES_PER_TRAIL_BLOCK; } /* Replay the trail, undoing the in-place modifications performed on objects */ static void extern_replay_trail(void) { struct trail_block * blk, * prevblk; struct trail_entry * ent, * lim; blk = extern_trail_block; lim = extern_trail_cur; while (1) { for (ent = &(blk->entries[0]); ent < lim; ent++) { value obj = ent->obj; color_t colornum = obj & 3; obj = obj & ~3; Hd_val(obj) = Coloredhd_hd(Hd_val(obj), colornum); Field(obj, 0) = ent->field0; } if (blk == &extern_trail_first) break; prevblk = blk->previous; free(blk); blk = prevblk; lim = &(blk->entries[ENTRIES_PER_TRAIL_BLOCK]); } /* Protect against a second call to extern_replay_trail */ extern_trail_block = &extern_trail_first; extern_trail_cur = extern_trail_block->entries; } /* Set forwarding pointer on an object and add corresponding entry to the trail. */ static void extern_record_location(value obj) { header_t hdr; if (extern_ignore_sharing) return; if (extern_trail_cur == extern_trail_limit) { struct trail_block * new_block = malloc(sizeof(struct trail_block)); if (new_block == NULL) extern_out_of_memory(); new_block->previous = extern_trail_block; extern_trail_block = new_block; extern_trail_cur = extern_trail_block->entries; extern_trail_limit = extern_trail_block->entries + ENTRIES_PER_TRAIL_BLOCK; } hdr = Hd_val(obj); extern_trail_cur->obj = obj | Colornum_hd(hdr); extern_trail_cur->field0 = Field(obj, 0); extern_trail_cur++; Hd_val(obj) = Bluehd_hd(hdr); Field(obj, 0) = (value) obj_counter; obj_counter++; } /* To buffer the output */ static char * extern_userprovided_output; static char * extern_ptr, * extern_limit; struct output_block { struct output_block * next; char * end; char data[SIZE_EXTERN_OUTPUT_BLOCK]; }; static struct output_block * extern_output_first, * extern_output_block; static void init_extern_output(void) { extern_userprovided_output = NULL; extern_output_first = malloc(sizeof(struct output_block)); if (extern_output_first == NULL) caml_raise_out_of_memory(); extern_output_block = extern_output_first; extern_output_block->next = NULL; extern_ptr = extern_output_block->data; extern_limit = extern_output_block->data + SIZE_EXTERN_OUTPUT_BLOCK; } static void close_extern_output(void) { if (extern_userprovided_output == NULL){ extern_output_block->end = extern_ptr; } } static void free_extern_output(void) { struct output_block * blk, * nextblk; if (extern_userprovided_output != NULL) return; for (blk = extern_output_first; blk != NULL; blk = nextblk) { nextblk = blk->next; free(blk); } extern_output_first = NULL; extern_free_stack(); } static void grow_extern_output(intnat required) { struct output_block * blk; intnat extra; if (extern_userprovided_output != NULL) { extern_failwith("Marshal.to_buffer: buffer overflow"); } extern_output_block->end = extern_ptr; if (required <= SIZE_EXTERN_OUTPUT_BLOCK / 2) extra = 0; else extra = required; blk = malloc(sizeof(struct output_block) + extra); if (blk == NULL) extern_out_of_memory(); extern_output_block->next = blk; extern_output_block = blk; extern_output_block->next = NULL; extern_ptr = extern_output_block->data; extern_limit = extern_output_block->data + SIZE_EXTERN_OUTPUT_BLOCK + extra; } static intnat extern_output_length(void) { struct output_block * blk; intnat len; if (extern_userprovided_output != NULL) { return extern_ptr - extern_userprovided_output; } else { for (len = 0, blk = extern_output_first; blk != NULL; blk = blk->next) len += blk->end - blk->data; return len; } } /* Exception raising, with cleanup */ static void extern_out_of_memory(void) { extern_replay_trail(); free_extern_output(); caml_raise_out_of_memory(); } static void extern_invalid_argument(char *msg) { extern_replay_trail(); free_extern_output(); caml_invalid_argument(msg); } static void extern_failwith(char *msg) { extern_replay_trail(); free_extern_output(); caml_failwith(msg); } static void extern_stack_overflow(void) { caml_gc_message (0x04, "Stack overflow in marshaling value\n", 0); extern_replay_trail(); free_extern_output(); caml_raise_out_of_memory(); } /* Write characters, integers, and blocks in the output buffer */ #define Write(c) \ if (extern_ptr >= extern_limit) grow_extern_output(1); \ *extern_ptr++ = (c) static void writeblock(char *data, intnat len) { if (extern_ptr + len > extern_limit) grow_extern_output(len); memmove(extern_ptr, data, len); extern_ptr += len; } #if ARCH_FLOAT_ENDIANNESS == 0x01234567 || ARCH_FLOAT_ENDIANNESS == 0x76543210 #define writeblock_float8(data,ndoubles) \ writeblock((char *)(data), (ndoubles) * 8) #else #define writeblock_float8(data,ndoubles) \ caml_serialize_block_float_8((data), (ndoubles)) #endif static void writecode8(int code, intnat val) { if (extern_ptr + 2 > extern_limit) grow_extern_output(2); extern_ptr[0] = code; extern_ptr[1] = val; extern_ptr += 2; } static void writecode16(int code, intnat val) { if (extern_ptr + 3 > extern_limit) grow_extern_output(3); extern_ptr[0] = code; extern_ptr[1] = val >> 8; extern_ptr[2] = val; extern_ptr += 3; } static void write32(intnat val) { if (extern_ptr + 4 > extern_limit) grow_extern_output(4); extern_ptr[0] = val >> 24; extern_ptr[1] = val >> 16; extern_ptr[2] = val >> 8; extern_ptr[3] = val; extern_ptr += 4; } static void writecode32(int code, intnat val) { if (extern_ptr + 5 > extern_limit) grow_extern_output(5); extern_ptr[0] = code; extern_ptr[1] = val >> 24; extern_ptr[2] = val >> 16; extern_ptr[3] = val >> 8; extern_ptr[4] = val; extern_ptr += 5; } #ifdef ARCH_SIXTYFOUR static void writecode64(int code, intnat val) { int i; if (extern_ptr + 9 > extern_limit) grow_extern_output(9); *extern_ptr ++ = code; for (i = 64 - 8; i >= 0; i -= 8) *extern_ptr++ = val >> i; } #endif /* Marshal the given value in the output buffer */ static void extern_rec(value v) { struct code_fragment * cf; struct extern_item * sp; sp = extern_stack; while(1) { if (Is_long(v)) { intnat n = Long_val(v); if (n >= 0 && n < 0x40) { Write(PREFIX_SMALL_INT + n); } else if (n >= -(1 << 7) && n < (1 << 7)) { writecode8(CODE_INT8, n); } else if (n >= -(1 << 15) && n < (1 << 15)) { writecode16(CODE_INT16, n); #ifdef ARCH_SIXTYFOUR } else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) { writecode64(CODE_INT64, n); #endif } else writecode32(CODE_INT32, n); goto next_item; } if (Is_in_value_area(v)) { header_t hd = Hd_val(v); tag_t tag = Tag_hd(hd); mlsize_t sz = Wosize_hd(hd); if (tag == Forward_tag) { value f = Forward_val (v); if (Is_block (f) && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){ /* Do not short-circuit the pointer. */ }else{ v = f; continue; } } /* Atoms are treated specially for two reasons: they are not allocated in the externed block, and they are automatically shared. */ if (sz == 0) { if (tag < 16) { Write(PREFIX_SMALL_BLOCK + tag); } else { writecode32(CODE_BLOCK32, hd); } goto next_item; } /* Check if already seen */ if (Color_hd(hd) == Caml_blue) { uintnat d = obj_counter - (uintnat) Field(v, 0); if (d < 0x100) { writecode8(CODE_SHARED8, d); } else if (d < 0x10000) { writecode16(CODE_SHARED16, d); } else { writecode32(CODE_SHARED32, d); } goto next_item; } /* Output the contents of the object */ switch(tag) { case String_tag: { mlsize_t len = caml_string_length(v); if (len < 0x20) { Write(PREFIX_SMALL_STRING + len); } else if (len < 0x100) { writecode8(CODE_STRING8, len); } else { writecode32(CODE_STRING32, len); } writeblock(String_val(v), len); size_32 += 1 + (len + 4) / 4; size_64 += 1 + (len + 8) / 8; extern_record_location(v); break; } case Double_tag: { if (sizeof(double) != 8) extern_invalid_argument("output_value: non-standard floats"); Write(CODE_DOUBLE_NATIVE); writeblock_float8((double *) v, 1); size_32 += 1 + 2; size_64 += 1 + 1; extern_record_location(v); break; } case Double_array_tag: { mlsize_t nfloats; if (sizeof(double) != 8) extern_invalid_argument("output_value: non-standard floats"); nfloats = Wosize_val(v) / Double_wosize; if (nfloats < 0x100) { writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats); } else { writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats); } writeblock_float8((double *) v, nfloats); size_32 += 1 + nfloats * 2; size_64 += 1 + nfloats; extern_record_location(v); break; } case Abstract_tag: extern_invalid_argument("output_value: abstract value (Abstract)"); break; case Infix_tag: writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd)); extern_rec(v - Infix_offset_hd(hd)); break; case Custom_tag: { uintnat sz_32, sz_64; char * ident = Custom_ops_val(v)->identifier; void (*serialize)(value v, uintnat * wsize_32, uintnat * wsize_64) = Custom_ops_val(v)->serialize; if (serialize == NULL) extern_invalid_argument("output_value: abstract value (Custom)"); Write(CODE_CUSTOM); writeblock(ident, strlen(ident) + 1); Custom_ops_val(v)->serialize(v, &sz_32, &sz_64); size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */ size_64 += 2 + ((sz_64 + 7) >> 3); extern_record_location(v); break; } default: { value field0; if (tag < 16 && sz < 8) { Write(PREFIX_SMALL_BLOCK + tag + (sz << 4)); #ifdef ARCH_SIXTYFOUR } else if (hd >= ((uintnat)1 << 32)) { writecode64(CODE_BLOCK64, Whitehd_hd (hd)); #endif } else { writecode32(CODE_BLOCK32, Whitehd_hd (hd)); } size_32 += 1 + sz; size_64 += 1 + sz; field0 = Field(v, 0); extern_record_location(v); /* Remember that we still have to serialize fields 1 ... sz - 1 */ if (sz > 1) { sp++; if (sp >= extern_stack_limit) sp = extern_resize_stack(sp); sp->v = &Field(v,1); sp->count = sz-1; } /* Continue serialization with the first field */ v = field0; continue; } } } else if ((cf = extern_find_code((char *) v)) != NULL) { if (!extern_closures) extern_invalid_argument("output_value: functional value"); writecode32(CODE_CODEPOINTER, (char *) v - cf->code_start); writeblock((char *) cf->digest, 16); } else { extern_invalid_argument("output_value: abstract value (outside heap)"); } next_item: /* Pop one more item to marshal, if any */ if (sp == extern_stack) { /* We are done. Cleanup the stack and leave the function */ extern_free_stack(); return; } v = *((sp->v)++); if (--(sp->count) == 0) sp--; } /* Never reached as function leaves with return */ } enum { NO_SHARING = 1, CLOSURES = 2 }; static int extern_flags[] = { NO_SHARING, CLOSURES }; static intnat extern_value(value v, value flags) { intnat res_len; int fl; /* Parse flag list */ fl = caml_convert_flag_list(flags, extern_flags); extern_ignore_sharing = fl & NO_SHARING; extern_closures = fl & CLOSURES; /* Initializations */ init_extern_trail(); obj_counter = 0; size_32 = 0; size_64 = 0; /* Write magic number */ write32(Intext_magic_number); /* Set aside space for the sizes */ extern_ptr += 4*4; /* Marshal the object */ extern_rec(v); /* Record end of output */ close_extern_output(); /* Undo the modifications done on externed blocks */ extern_replay_trail(); /* Write the sizes */ res_len = extern_output_length(); #ifdef ARCH_SIXTYFOUR if (res_len >= ((intnat)1 << 32) || size_32 >= ((intnat)1 << 32) || size_64 >= ((intnat)1 << 32)) { /* The object is so big its size cannot be written in the header. Besides, some of the array lengths or string lengths or shared offsets it contains may have overflowed the 32 bits used to write them. */ free_extern_output(); caml_failwith("output_value: object too big"); } #endif if (extern_userprovided_output != NULL) extern_ptr = extern_userprovided_output + 4; else { extern_ptr = extern_output_first->data + 4; extern_limit = extern_output_first->data + SIZE_EXTERN_OUTPUT_BLOCK; } write32(res_len - 5*4); write32(obj_counter); write32(size_32); write32(size_64); return res_len; } void caml_output_val(struct channel *chan, value v, value flags) { intnat len; struct output_block * blk, * nextblk; if (! caml_channel_binary_mode(chan)) caml_failwith("output_value: not a binary channel"); init_extern_output(); len = extern_value(v, flags); /* During [caml_really_putblock], concurrent [caml_output_val] operations can take place (via signal handlers or context switching in systhreads), and [extern_output_first] may change. So, save it in a local variable. */ blk = extern_output_first; while (blk != NULL) { caml_really_putblock(chan, blk->data, blk->end - blk->data); nextblk = blk->next; free(blk); blk = nextblk; } } CAMLprim value caml_output_value(value vchan, value v, value flags) { CAMLparam3 (vchan, v, flags); struct channel * channel = Channel(vchan); Lock(channel); caml_output_val(channel, v, flags); Unlock(channel); CAMLreturn (Val_unit); } CAMLprim value caml_output_value_to_string(value v, value flags) { intnat len, ofs; value res; struct output_block * blk, * nextblk; init_extern_output(); len = extern_value(v, flags); /* PR#4030: it is prudent to save extern_output_first before allocating the result, as in caml_output_val */ blk = extern_output_first; res = caml_alloc_string(len); ofs = 0; while (blk != NULL) { int n = blk->end - blk->data; memmove(&Byte(res, ofs), blk->data, n); ofs += n; nextblk = blk->next; free(blk); blk = nextblk; } return res; } CAMLprim value caml_output_value_to_buffer(value buf, value ofs, value len, value v, value flags) { intnat len_res; extern_userprovided_output = &Byte(buf, Long_val(ofs)); extern_ptr = extern_userprovided_output; extern_limit = extern_userprovided_output + Long_val(len); len_res = extern_value(v, flags); return Val_long(len_res); } CAMLexport void caml_output_value_to_malloc(value v, value flags, /*out*/ char ** buf, /*out*/ intnat * len) { intnat len_res; char * res; struct output_block * blk; init_extern_output(); len_res = extern_value(v, flags); res = malloc(len_res); if (res == NULL) extern_out_of_memory(); *buf = res; *len = len_res; for (blk = extern_output_first; blk != NULL; blk = blk->next) { int n = blk->end - blk->data; memmove(res, blk->data, n); res += n; } free_extern_output(); } CAMLexport intnat caml_output_value_to_block(value v, value flags, char * buf, intnat len) { intnat len_res; extern_userprovided_output = buf; extern_ptr = extern_userprovided_output; extern_limit = extern_userprovided_output + len; len_res = extern_value(v, flags); return len_res; } /* Functions for writing user-defined marshallers */ CAMLexport void caml_serialize_int_1(int i) { if (extern_ptr + 1 > extern_limit) grow_extern_output(1); extern_ptr[0] = i; extern_ptr += 1; } CAMLexport void caml_serialize_int_2(int i) { if (extern_ptr + 2 > extern_limit) grow_extern_output(2); extern_ptr[0] = i >> 8; extern_ptr[1] = i; extern_ptr += 2; } CAMLexport void caml_serialize_int_4(int32 i) { if (extern_ptr + 4 > extern_limit) grow_extern_output(4); extern_ptr[0] = i >> 24; extern_ptr[1] = i >> 16; extern_ptr[2] = i >> 8; extern_ptr[3] = i; extern_ptr += 4; } CAMLexport void caml_serialize_int_8(int64 i) { caml_serialize_block_8(&i, 1); } CAMLexport void caml_serialize_float_4(float f) { caml_serialize_block_4(&f, 1); } CAMLexport void caml_serialize_float_8(double f) { caml_serialize_block_float_8(&f, 1); } CAMLexport void caml_serialize_block_1(void * data, intnat len) { if (extern_ptr + len > extern_limit) grow_extern_output(len); memmove(extern_ptr, data, len); extern_ptr += len; } CAMLexport void caml_serialize_block_2(void * data, intnat len) { if (extern_ptr + 2 * len > extern_limit) grow_extern_output(2 * len); #ifndef ARCH_BIG_ENDIAN { unsigned char * p; char * q; for (p = data, q = extern_ptr; len > 0; len--, p += 2, q += 2) Reverse_16(q, p); extern_ptr = q; } #else memmove(extern_ptr, data, len * 2); extern_ptr += len * 2; #endif } CAMLexport void caml_serialize_block_4(void * data, intnat len) { if (extern_ptr + 4 * len > extern_limit) grow_extern_output(4 * len); #ifndef ARCH_BIG_ENDIAN { unsigned char * p; char * q; for (p = data, q = extern_ptr; len > 0; len--, p += 4, q += 4) Reverse_32(q, p); extern_ptr = q; } #else memmove(extern_ptr, data, len * 4); extern_ptr += len * 4; #endif } CAMLexport void caml_serialize_block_8(void * data, intnat len) { if (extern_ptr + 8 * len > extern_limit) grow_extern_output(8 * len); #ifndef ARCH_BIG_ENDIAN { unsigned char * p; char * q; for (p = data, q = extern_ptr; len > 0; len--, p += 8, q += 8) Reverse_64(q, p); extern_ptr = q; } #else memmove(extern_ptr, data, len * 8); extern_ptr += len * 8; #endif } CAMLexport void caml_serialize_block_float_8(void * data, intnat len) { if (extern_ptr + 8 * len > extern_limit) grow_extern_output(8 * len); #if ARCH_FLOAT_ENDIANNESS == 0x01234567 memmove(extern_ptr, data, len * 8); extern_ptr += len * 8; #elif ARCH_FLOAT_ENDIANNESS == 0x76543210 { unsigned char * p; char * q; for (p = data, q = extern_ptr; len > 0; len--, p += 8, q += 8) Reverse_64(q, p); extern_ptr = q; } #else { unsigned char * p; char * q; for (p = data, q = extern_ptr; len > 0; len--, p += 8, q += 8) Permute_64(q, 0x01234567, p, ARCH_FLOAT_ENDIANNESS); extern_ptr = q; } #endif } /* Find where a code pointer comes from */ static struct code_fragment * extern_find_code(char *addr) { int i; for (i = caml_code_fragments_table.size - 1; i >= 0; i--) { struct code_fragment * cf = caml_code_fragments_table.contents[i]; if (! cf->digest_computed) { caml_md5_block(cf->digest, cf->code_start, cf->code_end - cf->code_start); cf->digest_computed = 1; } if (cf->code_start <= addr && addr < cf->code_end) return cf; } return NULL; } mingw-ocaml/ocaml/byterun/signals_byt.c0000644000175000017500000000546312124403240017637 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 2007 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Signal handling, code specific to the bytecode interpreter */ #include #include "config.h" #include "memory.h" #include "osdeps.h" #include "signals.h" #include "signals_machdep.h" #ifndef NSIG #define NSIG 64 #endif #ifdef _WIN32 typedef void (*sighandler)(int sig); extern sighandler caml_win32_signal(int sig, sighandler action); #define signal(sig,act) caml_win32_signal(sig,act) #endif CAMLexport int volatile caml_something_to_do = 0; CAMLexport void (* volatile caml_async_action_hook)(void) = NULL; void caml_process_event(void) { void (*async_action)(void); if (caml_force_major_slice) caml_minor_collection (); /* FIXME should be [caml_check_urgent_gc] */ caml_process_pending_signals(); async_action = caml_async_action_hook; if (async_action != NULL) { caml_async_action_hook = NULL; (*async_action)(); } } static void handle_signal(int signal_number) { #if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS) signal(signal_number, handle_signal); #endif if (signal_number < 0 || signal_number >= NSIG) return; if (caml_try_leave_blocking_section_hook()) { caml_execute_signal(signal_number, 1); caml_enter_blocking_section_hook(); }else{ caml_record_signal(signal_number); } } int caml_set_signal_action(int signo, int action) { void (*act)(int signo), (*oldact)(int signo); #ifdef POSIX_SIGNALS struct sigaction sigact, oldsigact; #endif switch (action) { case 0: act = SIG_DFL; break; case 1: act = SIG_IGN; break; default: act = handle_signal; break; } #ifdef POSIX_SIGNALS sigact.sa_handler = act; sigemptyset(&sigact.sa_mask); sigact.sa_flags = 0; if (sigaction(signo, &sigact, &oldsigact) == -1) return -1; oldact = oldsigact.sa_handler; #else oldact = signal(signo, act); if (oldact == SIG_ERR) return -1; #endif if (oldact == handle_signal) return 2; else if (oldact == SIG_IGN) return 1; else return 0; } mingw-ocaml/ocaml/byterun/floats.c0000644000175000017500000003043612124403240016607 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* The interface of this file is in "mlvalues.h" and "alloc.h" */ #include #include #include #include #include "alloc.h" #include "fail.h" #include "memory.h" #include "mlvalues.h" #include "misc.h" #include "reverse.h" #include "stacks.h" #ifdef _MSC_VER #include #define isnan _isnan #define isfinite _finite #endif #ifdef ARCH_ALIGN_DOUBLE CAMLexport double caml_Double_val(value val) { union { value v[2]; double d; } buffer; Assert(sizeof(double) == 2 * sizeof(value)); buffer.v[0] = Field(val, 0); buffer.v[1] = Field(val, 1); return buffer.d; } CAMLexport void caml_Store_double_val(value val, double dbl) { union { value v[2]; double d; } buffer; Assert(sizeof(double) == 2 * sizeof(value)); buffer.d = dbl; Field(val, 0) = buffer.v[0]; Field(val, 1) = buffer.v[1]; } #endif CAMLexport value caml_copy_double(double d) { value res; #define Setup_for_gc #define Restore_after_gc Alloc_small(res, Double_wosize, Double_tag); #undef Setup_for_gc #undef Restore_after_gc Store_double_val(res, d); return res; } CAMLprim value caml_format_float(value fmt, value arg) { #define MAX_DIGITS 350 /* Max number of decimal digits in a "natural" (not artificially padded) representation of a float. Can be quite big for %f format. Max exponent for IEEE format is 308 decimal digits. Rounded up for good measure. */ char format_buffer[MAX_DIGITS + 20]; int prec, i; char * p; char * dest; value res; double d = Double_val(arg); #ifdef HAS_BROKEN_PRINTF if (isfinite(d)) { #endif prec = MAX_DIGITS; for (p = String_val(fmt); *p != 0; p++) { if (*p >= '0' && *p <= '9') { i = atoi(p) + MAX_DIGITS; if (i > prec) prec = i; break; } } for( ; *p != 0; p++) { if (*p == '.') { i = atoi(p+1) + MAX_DIGITS; if (i > prec) prec = i; break; } } if (prec < sizeof(format_buffer)) { dest = format_buffer; } else { dest = caml_stat_alloc(prec); } sprintf(dest, String_val(fmt), d); res = caml_copy_string(dest); if (dest != format_buffer) { caml_stat_free(dest); } #ifdef HAS_BROKEN_PRINTF } else { if (isnan(d)) { res = caml_copy_string("nan"); } else { if (d > 0) { res = caml_copy_string("inf"); } else { res = caml_copy_string("-inf"); } } } #endif return res; } /*CAMLprim*/ value caml_float_of_substring(value vs, value idx, value l) { char parse_buffer[64]; char * buf, * src, * dst, * end; mlsize_t len, lenvs; double d; intnat flen = Long_val(l); intnat fidx = Long_val(idx); lenvs = caml_string_length(vs); len = fidx >= 0 && fidx < lenvs && flen > 0 && flen <= lenvs - fidx ? flen : 0; buf = len < sizeof(parse_buffer) ? parse_buffer : caml_stat_alloc(len + 1); src = String_val(vs) + fidx; dst = buf; while (len--) { char c = *src++; if (c != '_') *dst++ = c; } *dst = 0; if (dst == buf) goto error; d = strtod((const char *) buf, &end); if (end != dst) goto error; if (buf != parse_buffer) caml_stat_free(buf); return caml_copy_double(d); error: if (buf != parse_buffer) caml_stat_free(buf); caml_failwith("float_of_string"); } CAMLprim value caml_float_of_string(value vs) { char parse_buffer[64]; char * buf, * src, * dst, * end; mlsize_t len; double d; len = caml_string_length(vs); buf = len < sizeof(parse_buffer) ? parse_buffer : caml_stat_alloc(len + 1); src = String_val(vs); dst = buf; while (len--) { char c = *src++; if (c != '_') *dst++ = c; } *dst = 0; if (dst == buf) goto error; d = strtod((const char *) buf, &end); if (end != dst) goto error; if (buf != parse_buffer) caml_stat_free(buf); return caml_copy_double(d); error: if (buf != parse_buffer) caml_stat_free(buf); caml_failwith("float_of_string"); } CAMLprim value caml_int_of_float(value f) { return Val_long((intnat) Double_val(f)); } CAMLprim value caml_float_of_int(value n) { return caml_copy_double((double) Long_val(n)); } CAMLprim value caml_neg_float(value f) { return caml_copy_double(- Double_val(f)); } CAMLprim value caml_abs_float(value f) { return caml_copy_double(fabs(Double_val(f))); } CAMLprim value caml_add_float(value f, value g) { return caml_copy_double(Double_val(f) + Double_val(g)); } CAMLprim value caml_sub_float(value f, value g) { return caml_copy_double(Double_val(f) - Double_val(g)); } CAMLprim value caml_mul_float(value f, value g) { return caml_copy_double(Double_val(f) * Double_val(g)); } CAMLprim value caml_div_float(value f, value g) { return caml_copy_double(Double_val(f) / Double_val(g)); } CAMLprim value caml_exp_float(value f) { return caml_copy_double(exp(Double_val(f))); } CAMLprim value caml_floor_float(value f) { return caml_copy_double(floor(Double_val(f))); } CAMLprim value caml_fmod_float(value f1, value f2) { return caml_copy_double(fmod(Double_val(f1), Double_val(f2))); } CAMLprim value caml_frexp_float(value f) { CAMLparam1 (f); CAMLlocal2 (res, mantissa); int exponent; mantissa = caml_copy_double(frexp (Double_val(f), &exponent)); res = caml_alloc_tuple(2); Field(res, 0) = mantissa; Field(res, 1) = Val_int(exponent); CAMLreturn (res); } CAMLprim value caml_ldexp_float(value f, value i) { return caml_copy_double(ldexp(Double_val(f), Int_val(i))); } CAMLprim value caml_log_float(value f) { return caml_copy_double(log(Double_val(f))); } CAMLprim value caml_log10_float(value f) { return caml_copy_double(log10(Double_val(f))); } CAMLprim value caml_modf_float(value f) { double frem; CAMLparam1 (f); CAMLlocal3 (res, quo, rem); quo = caml_copy_double(modf (Double_val(f), &frem)); rem = caml_copy_double(frem); res = caml_alloc_tuple(2); Field(res, 0) = quo; Field(res, 1) = rem; CAMLreturn (res); } CAMLprim value caml_sqrt_float(value f) { return caml_copy_double(sqrt(Double_val(f))); } CAMLprim value caml_power_float(value f, value g) { return caml_copy_double(pow(Double_val(f), Double_val(g))); } CAMLprim value caml_sin_float(value f) { return caml_copy_double(sin(Double_val(f))); } CAMLprim value caml_sinh_float(value f) { return caml_copy_double(sinh(Double_val(f))); } CAMLprim value caml_cos_float(value f) { return caml_copy_double(cos(Double_val(f))); } CAMLprim value caml_cosh_float(value f) { return caml_copy_double(cosh(Double_val(f))); } CAMLprim value caml_tan_float(value f) { return caml_copy_double(tan(Double_val(f))); } CAMLprim value caml_tanh_float(value f) { return caml_copy_double(tanh(Double_val(f))); } CAMLprim value caml_asin_float(value f) { return caml_copy_double(asin(Double_val(f))); } CAMLprim value caml_acos_float(value f) { return caml_copy_double(acos(Double_val(f))); } CAMLprim value caml_atan_float(value f) { return caml_copy_double(atan(Double_val(f))); } CAMLprim value caml_atan2_float(value f, value g) { return caml_copy_double(atan2(Double_val(f), Double_val(g))); } CAMLprim value caml_ceil_float(value f) { return caml_copy_double(ceil(Double_val(f))); } CAMLexport double caml_hypot(double x, double y) { #ifdef HAS_C99_FLOAT_OPS return hypot(x, y); #else double tmp, ratio; if (x != x) return x; /* NaN */ if (y != y) return y; /* NaN */ x = fabs(x); y = fabs(y); if (x < y) { tmp = x; x = y; y = tmp; } if (x == 0.0) return 0.0; ratio = y / x; return x * sqrt(1.0 + ratio * ratio); #endif } CAMLprim value caml_hypot_float(value f, value g) { return caml_copy_double(caml_hypot(Double_val(f), Double_val(g))); } /* These emulations of expm1() and log1p() are due to William Kahan. See http://www.plunk.org/~hatch/rightway.php */ CAMLexport double caml_expm1(double x) { #ifdef HAS_C99_FLOAT_OPS return expm1(x); #else double u = exp(x); if (u == 1.) return x; if (u - 1. == -1.) return -1.; return (u - 1.) * x / log(u); #endif } CAMLexport double caml_log1p(double x) { #ifdef HAS_C99_FLOAT_OPS return log1p(x); #else double u = 1. + x; if (u == 1.) return x; else return log(u) * x / (u - 1.); #endif } CAMLprim value caml_expm1_float(value f) { return caml_copy_double(caml_expm1(Double_val(f))); } CAMLprim value caml_log1p_float(value f) { return caml_copy_double(caml_log1p(Double_val(f))); } union double_as_two_int32 { double d; #if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__)) struct { uint32 h; uint32 l; } i; #else struct { uint32 l; uint32 h; } i; #endif }; CAMLexport double caml_copysign(double x, double y) { #ifdef HAS_C99_FLOAT_OPS return copysign(x, y); #else union double_as_two_int32 ux, uy; ux.d = x; uy.d = y; ux.i.h &= 0x7FFFFFFFU; ux.i.h |= (uy.i.h & 0x80000000U); return ux.d; #endif } CAMLprim value caml_copysign_float(value f, value g) { return caml_copy_double(caml_copysign(Double_val(f), Double_val(g))); } CAMLprim value caml_eq_float(value f, value g) { return Val_bool(Double_val(f) == Double_val(g)); } CAMLprim value caml_neq_float(value f, value g) { return Val_bool(Double_val(f) != Double_val(g)); } CAMLprim value caml_le_float(value f, value g) { return Val_bool(Double_val(f) <= Double_val(g)); } CAMLprim value caml_lt_float(value f, value g) { return Val_bool(Double_val(f) < Double_val(g)); } CAMLprim value caml_ge_float(value f, value g) { return Val_bool(Double_val(f) >= Double_val(g)); } CAMLprim value caml_gt_float(value f, value g) { return Val_bool(Double_val(f) > Double_val(g)); } CAMLprim value caml_float_compare(value vf, value vg) { double f = Double_val(vf); double g = Double_val(vg); if (f == g) return Val_int(0); if (f < g) return Val_int(-1); if (f > g) return Val_int(1); /* One or both of f and g is NaN. Order according to the convention NaN = NaN and NaN < x for all other floats x. */ if (f == f) return Val_int(1); /* f is not NaN, g is NaN */ if (g == g) return Val_int(-1); /* g is not NaN, f is NaN */ return Val_int(0); /* both f and g are NaN */ } enum { FP_normal, FP_subnormal, FP_zero, FP_infinite, FP_nan }; CAMLprim value caml_classify_float(value vd) { /* Cygwin 1.3 has problems with fpclassify (PR#1293), so don't use it */ #if defined(fpclassify) && !defined(__CYGWIN32__) && !defined(__MINGW32__) switch (fpclassify(Double_val(vd))) { case FP_NAN: return Val_int(FP_nan); case FP_INFINITE: return Val_int(FP_infinite); case FP_ZERO: return Val_int(FP_zero); case FP_SUBNORMAL: return Val_int(FP_subnormal); default: /* case FP_NORMAL */ return Val_int(FP_normal); } #else union double_as_two_int32 u; uint32 h, l; u.d = Double_val(vd); h = u.i.h; l = u.i.l; l = l | (h & 0xFFFFF); h = h & 0x7FF00000; if ((h | l) == 0) return Val_int(FP_zero); if (h == 0) return Val_int(FP_subnormal); if (h == 0x7FF00000) { if (l == 0) return Val_int(FP_infinite); else return Val_int(FP_nan); } return Val_int(FP_normal); #endif } /* The [caml_init_ieee_float] function should initialize floating-point hardware so that it behaves as much as possible like the IEEE standard. In particular, return special numbers like Infinity and NaN instead of signalling exceptions. Currently, everyone is in IEEE mode at program startup, except FreeBSD prior to 4.0R. */ #ifdef __FreeBSD__ #include #if (__FreeBSD_version < 400017) #include #endif #endif void caml_init_ieee_floats(void) { #if defined(__FreeBSD__) && (__FreeBSD_version < 400017) fpsetmask(0); #endif } mingw-ocaml/ocaml/byterun/terminfo.c0000644000175000017500000000667512124403240017152 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Read and output terminal commands */ #include "config.h" #include "alloc.h" #include "fail.h" #include "io.h" #include "mlvalues.h" #define Uninitialised (Val_int(0)) #define Bad_term (Val_int(1)) #define Good_term_tag 0 #if defined (HAS_TERMCAP) && !defined (NATIVE_CODE) extern int tgetent (char * buffer, char * name); extern char * tgetstr (char * id, char ** area); extern int tgetnum (char * id); extern int tputs (char * str, int count, int (*outchar)(int c)); static struct channel *chan; static char area [1024]; static char *area_p = area; static int num_lines; static char *up = NULL; static char *down = NULL; static char *standout = NULL; static char *standend = NULL; CAMLprim value caml_terminfo_setup (value vchan) { value result; static char buffer[1024]; char *term; chan = Channel (vchan); term = getenv ("TERM"); if (term == NULL) return Bad_term; if (tgetent(buffer, term) != 1) return Bad_term; num_lines = tgetnum ("li"); up = tgetstr ("up", &area_p); down = tgetstr ("do", &area_p); standout = tgetstr ("us", &area_p); standend = tgetstr ("ue", &area_p); if (standout == NULL || standend == NULL){ standout = tgetstr ("so", &area_p); standend = tgetstr ("se", &area_p); } Assert (area_p <= area + 1024); if (num_lines == -1 || up == NULL || down == NULL || standout == NULL || standend == NULL){ return Bad_term; } result = caml_alloc_small (1, Good_term_tag); Field (result, 0) = Val_int (num_lines); return result; } static int terminfo_putc (int c) { putch (chan, c); return c; } CAMLprim value caml_terminfo_backup (value lines) { int i; for (i = 0; i < Int_val (lines); i++){ tputs (up, 1, terminfo_putc); } return Val_unit; } CAMLprim value caml_terminfo_standout (value start) { tputs (Bool_val (start) ? standout : standend, 1, terminfo_putc); return Val_unit; } CAMLprim value caml_terminfo_resume (value lines) { int i; for (i = 0; i < Int_val (lines); i++){ tputs (down, 1, terminfo_putc); } return Val_unit; } #else /* defined (HAS_TERMCAP) && !defined (NATIVE_CODE) */ CAMLexport value caml_terminfo_setup (value vchan) { return Bad_term; } CAMLexport value caml_terminfo_backup (value lines) { caml_invalid_argument("Terminfo.backup"); return Val_unit; } CAMLexport value caml_terminfo_standout (value start) { caml_invalid_argument("Terminfo.standout"); return Val_unit; } CAMLexport value caml_terminfo_resume (value lines) { caml_invalid_argument("Terminfo.resume"); return Val_unit; } #endif /* defined (HAS_TERMCAP) && !defined (NATIVE_CODE) */ mingw-ocaml/ocaml/byterun/startup.h0000644000175000017500000000327512124403240017027 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_STARTUP_H #define CAML_STARTUP_H #include "mlvalues.h" #include "exec.h" CAMLextern void caml_main(char **argv); CAMLextern void caml_startup_code( code_t code, asize_t code_size, char *data, asize_t data_size, char *section_table, asize_t section_table_size, char **argv); enum { FILE_NOT_FOUND = -1, BAD_BYTECODE = -2 }; extern int caml_attempt_open(char **name, struct exec_trailer *trail, int do_open_script); extern void caml_read_section_descriptors(int fd, struct exec_trailer *trail); extern int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name); extern int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name); #endif /* CAML_STARTUP_H */ mingw-ocaml/ocaml/byterun/fail.h0000644000175000017500000000615612124403240016241 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_FAIL_H #define CAML_FAIL_H /* */ #include /* */ #ifndef CAML_NAME_SPACE #include "compatibility.h" #endif #include "misc.h" #include "mlvalues.h" /* */ #define OUT_OF_MEMORY_EXN 0 /* "Out_of_memory" */ #define SYS_ERROR_EXN 1 /* "Sys_error" */ #define FAILURE_EXN 2 /* "Failure" */ #define INVALID_EXN 3 /* "Invalid_argument" */ #define END_OF_FILE_EXN 4 /* "End_of_file" */ #define ZERO_DIVIDE_EXN 5 /* "Division_by_zero" */ #define NOT_FOUND_EXN 6 /* "Not_found" */ #define MATCH_FAILURE_EXN 7 /* "Match_failure" */ #define STACK_OVERFLOW_EXN 8 /* "Stack_overflow" */ #define SYS_BLOCKED_IO 9 /* "Sys_blocked_io" */ #define ASSERT_FAILURE_EXN 10 /* "Assert_failure" */ #define UNDEFINED_RECURSIVE_MODULE_EXN 11 /* "Undefined_recursive_module" */ #ifdef POSIX_SIGNALS struct longjmp_buffer { sigjmp_buf buf; }; #else struct longjmp_buffer { jmp_buf buf; }; #define sigsetjmp(buf,save) setjmp(buf) #define siglongjmp(buf,val) longjmp(buf,val) #endif CAMLextern struct longjmp_buffer * caml_external_raise; extern value caml_exn_bucket; int caml_is_special_exception(value exn); /* */ #ifdef __cplusplus extern "C" { #endif CAMLextern void caml_raise (value bucket) Noreturn; CAMLextern void caml_raise_constant (value tag) Noreturn; CAMLextern void caml_raise_with_arg (value tag, value arg) Noreturn; CAMLextern void caml_raise_with_args (value tag, int nargs, value arg[]) Noreturn; CAMLextern void caml_raise_with_string (value tag, char const * msg) Noreturn; CAMLextern void caml_failwith (char const *) Noreturn; CAMLextern void caml_invalid_argument (char const *) Noreturn; CAMLextern void caml_raise_out_of_memory (void) Noreturn; CAMLextern void caml_raise_stack_overflow (void) Noreturn; CAMLextern void caml_raise_sys_error (value) Noreturn; CAMLextern void caml_raise_end_of_file (void) Noreturn; CAMLextern void caml_raise_zero_divide (void) Noreturn; CAMLextern void caml_raise_not_found (void) Noreturn; CAMLextern void caml_init_exceptions (void); CAMLextern void caml_array_bound_error (void) Noreturn; CAMLextern void caml_raise_sys_blocked_io (void) Noreturn; #ifdef __cplusplus } #endif #endif /* CAML_FAIL_H */ mingw-ocaml/ocaml/byterun/backtrace.c0000644000175000017500000002126712124403240017240 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2000 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Stack backtrace for uncaught exceptions */ #include #include #include #include "config.h" #ifdef HAS_UNISTD #include #endif #include "mlvalues.h" #include "alloc.h" #include "io.h" #include "instruct.h" #include "intext.h" #include "exec.h" #include "fix_code.h" #include "memory.h" #include "startup.h" #include "stacks.h" #include "sys.h" #include "backtrace.h" CAMLexport int caml_backtrace_active = 0; CAMLexport int caml_backtrace_pos = 0; CAMLexport code_t * caml_backtrace_buffer = NULL; CAMLexport value caml_backtrace_last_exn = Val_unit; CAMLexport char * caml_cds_file = NULL; #define BACKTRACE_BUFFER_SIZE 1024 /* Location of fields in the Instruct.debug_event record */ enum { EV_POS = 0, EV_MODULE = 1, EV_LOC = 2, EV_KIND = 3 }; /* Location of fields in the Location.t record. */ enum { LOC_START = 0, LOC_END = 1, LOC_GHOST = 2 }; /* Location of fields in the Lexing.position record. */ enum { POS_FNAME = 0, POS_LNUM = 1, POS_BOL = 2, POS_CNUM = 3 }; /* Start or stop the backtrace machinery */ CAMLprim value caml_record_backtrace(value vflag) { int flag = Int_val(vflag); if (flag != caml_backtrace_active) { caml_backtrace_active = flag; caml_backtrace_pos = 0; if (flag) { caml_register_global_root(&caml_backtrace_last_exn); } else { caml_remove_global_root(&caml_backtrace_last_exn); } /* Note: lazy initialization of caml_backtrace_buffer in caml_stash_backtrace to simplify the interface with the thread libraries */ } return Val_unit; } /* Return the status of the backtrace machinery */ CAMLprim value caml_backtrace_status(value vunit) { return Val_bool(caml_backtrace_active); } /* Store the return addresses contained in the given stack fragment into the backtrace array */ void caml_stash_backtrace(value exn, code_t pc, value * sp) { code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size); if (pc != NULL) pc = pc - 1; if (exn != caml_backtrace_last_exn) { caml_backtrace_pos = 0; caml_backtrace_last_exn = exn; } if (caml_backtrace_buffer == NULL) { caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); if (caml_backtrace_buffer == NULL) return; } if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; if (pc >= caml_start_code && pc < end_code){ caml_backtrace_buffer[caml_backtrace_pos++] = pc; } for (/*nothing*/; sp < caml_trapsp; sp++) { code_t p = (code_t) *sp; if (p >= caml_start_code && p < end_code) { if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break; caml_backtrace_buffer[caml_backtrace_pos++] = p; } } } /* Read the debugging info contained in the current bytecode executable. Return an OCaml array of OCaml lists of debug_event records in "events", or Val_false on failure. */ #ifndef O_BINARY #define O_BINARY 0 #endif static value read_debug_info(void) { CAMLparam0(); CAMLlocal1(events); char * exec_name; int fd; struct exec_trailer trail; struct channel * chan; uint32 num_events, orig, i; value evl, l; if (caml_cds_file != NULL) { exec_name = caml_cds_file; } else { exec_name = caml_exe_name; } fd = caml_attempt_open(&exec_name, &trail, 1); if (fd < 0) CAMLreturn(Val_false); caml_read_section_descriptors(fd, &trail); if (caml_seek_optional_section(fd, &trail, "DBUG") == -1) { close(fd); CAMLreturn(Val_false); } chan = caml_open_descriptor_in(fd); num_events = caml_getword(chan); events = caml_alloc(num_events, 0); for (i = 0; i < num_events; i++) { orig = caml_getword(chan); evl = caml_input_val(chan); /* Relocate events in event list */ for (l = evl; l != Val_int(0); l = Field(l, 1)) { value ev = Field(l, 0); Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig); } /* Record event list */ Store_field(events, i, evl); } caml_close_channel(chan); CAMLreturn(events); } /* Search the event for the given PC. Return Val_false if not found. */ static value event_for_location(value events, code_t pc) { mlsize_t i; value pos, l, ev, ev_pos, best_ev; best_ev = 0; Assert(pc >= caml_start_code && pc < caml_start_code + caml_code_size); pos = Val_long((char *) pc - (char *) caml_start_code); for (i = 0; i < Wosize_val(events); i++) { for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) { ev = Field(l, 0); ev_pos = Field(ev, EV_POS); if (ev_pos == pos) return ev; /* ocamlc sometimes moves an event past a following PUSH instruction; allow mismatch by 1 instruction. */ if (ev_pos == pos + 8) best_ev = ev; } } if (best_ev != 0) return best_ev; return Val_false; } /* Extract location information for the given PC */ struct loc_info { int loc_valid; int loc_is_raise; char * loc_filename; int loc_lnum; int loc_startchr; int loc_endchr; }; static void extract_location_info(value events, code_t pc, /*out*/ struct loc_info * li) { value ev, ev_start; ev = event_for_location(events, pc); li->loc_is_raise = caml_is_instruction(*pc, RAISE); if (ev == Val_false) { li->loc_valid = 0; return; } li->loc_valid = 1; ev_start = Field (Field (ev, EV_LOC), LOC_START); li->loc_filename = String_val (Field (ev_start, POS_FNAME)); li->loc_lnum = Int_val (Field (ev_start, POS_LNUM)); li->loc_startchr = Int_val (Field (ev_start, POS_CNUM)) - Int_val (Field (ev_start, POS_BOL)); li->loc_endchr = Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM)) - Int_val (Field (ev_start, POS_BOL)); } /* Print location information */ static void print_location(struct loc_info * li, int index) { char * info; /* Ignore compiler-inserted raise */ if (!li->loc_valid && li->loc_is_raise) return; if (li->loc_is_raise) { /* Initial raise if index == 0, re-raise otherwise */ if (index == 0) info = "Raised at"; else info = "Re-raised at"; } else { if (index == 0) info = "Raised by primitive operation at"; else info = "Called from"; } if (! li->loc_valid) { fprintf(stderr, "%s unknown location\n", info); } else { fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", info, li->loc_filename, li->loc_lnum, li->loc_startchr, li->loc_endchr); } } /* Print a backtrace */ CAMLexport void caml_print_exception_backtrace(void) { value events; int i; struct loc_info li; events = read_debug_info(); if (events == Val_false) { fprintf(stderr, "(Program not linked with -g, cannot print stack backtrace)\n"); return; } for (i = 0; i < caml_backtrace_pos; i++) { extract_location_info(events, caml_backtrace_buffer[i], &li); print_location(&li, i); } } /* Convert the backtrace to a data structure usable from OCaml */ CAMLprim value caml_get_exception_backtrace(value unit) { CAMLparam0(); CAMLlocal5(events, res, arr, p, fname); int i; struct loc_info li; events = read_debug_info(); if (events == Val_false) { res = Val_int(0); /* None */ } else { arr = caml_alloc(caml_backtrace_pos, 0); for (i = 0; i < caml_backtrace_pos; i++) { extract_location_info(events, caml_backtrace_buffer[i], &li); if (li.loc_valid) { fname = caml_copy_string(li.loc_filename); p = caml_alloc_small(5, 0); Field(p, 0) = Val_bool(li.loc_is_raise); Field(p, 1) = fname; Field(p, 2) = Val_int(li.loc_lnum); Field(p, 3) = Val_int(li.loc_startchr); Field(p, 4) = Val_int(li.loc_endchr); } else { p = caml_alloc_small(1, 1); Field(p, 0) = Val_bool(li.loc_is_raise); } caml_modify(&Field(arr, i), p); } res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ } CAMLreturn(res); } mingw-ocaml/ocaml/byterun/instrtrace.h0000644000175000017500000000244312124403240017477 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Trace the instructions executed */ #ifndef _instrtrace_ #define _instrtrace_ #include "mlvalues.h" #include "misc.h" extern int caml_trace_flag; extern intnat caml_icount; void caml_stop_here (void); void caml_disasm_instr (code_t pc); void caml_trace_value_file (value v, code_t prog, int proglen, FILE * f); void caml_trace_accu_sp_file(value accu, value * sp, code_t prog, int proglen, FILE * f); #endif mingw-ocaml/ocaml/byterun/backtrace.h0000644000175000017500000000256612124403240017246 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_BACKTRACE_H #define CAML_BACKTRACE_H #include "mlvalues.h" CAMLextern int caml_backtrace_active; CAMLextern int caml_backtrace_pos; CAMLextern code_t * caml_backtrace_buffer; CAMLextern value caml_backtrace_last_exn; CAMLextern char * caml_cds_file; CAMLprim value caml_record_backtrace(value vflag); #ifndef NATIVE_CODE extern void caml_stash_backtrace(value exn, code_t pc, value * sp); #endif CAMLextern void caml_print_exception_backtrace(void); #endif /* CAML_BACKTRACE_H */ mingw-ocaml/ocaml/byterun/meta.c0000644000175000017500000001261112124403240016240 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Primitives for the toplevel */ #include #include "alloc.h" #include "config.h" #include "fail.h" #include "fix_code.h" #include "interp.h" #include "intext.h" #include "major_gc.h" #include "memory.h" #include "minor_gc.h" #include "misc.h" #include "mlvalues.h" #include "prims.h" #include "stacks.h" #ifndef NATIVE_CODE CAMLprim value caml_get_global_data(value unit) { return caml_global_data; } char * caml_section_table = NULL; asize_t caml_section_table_size; CAMLprim value caml_get_section_table(value unit) { if (caml_section_table == NULL) caml_raise_not_found(); return caml_input_value_from_block(caml_section_table, caml_section_table_size); } CAMLprim value caml_reify_bytecode(value prog, value len) { value clos; #ifdef ARCH_BIG_ENDIAN caml_fixup_endianness((code_t) prog, (asize_t) Long_val(len)); #endif #ifdef THREADED_CODE caml_thread_code((code_t) prog, (asize_t) Long_val(len)); #endif caml_prepare_bytecode((code_t) prog, (asize_t) Long_val(len)); clos = caml_alloc_small (1, Closure_tag); Code_val(clos) = (code_t) prog; return clos; } CAMLprim value caml_register_code_fragment(value prog, value len, value digest) { struct code_fragment * cf = caml_stat_alloc(sizeof(struct code_fragment)); cf->code_start = (char *) prog; cf->code_end = (char *) prog + Long_val(len); memcpy(cf->digest, String_val(digest), 16); cf->digest_computed = 1; caml_ext_table_add(&caml_code_fragments_table, cf); return Val_unit; } CAMLprim value caml_realloc_global(value size) { mlsize_t requested_size, actual_size, i; value new_global_data; requested_size = Long_val(size); actual_size = Wosize_val(caml_global_data); if (requested_size >= actual_size) { requested_size = (requested_size + 0x100) & 0xFFFFFF00; caml_gc_message (0x08, "Growing global data to %lu entries\n", requested_size); new_global_data = caml_alloc_shr(requested_size, 0); for (i = 0; i < actual_size; i++) caml_initialize(&Field(new_global_data, i), Field(caml_global_data, i)); for (i = actual_size; i < requested_size; i++){ Field (new_global_data, i) = Val_long (0); } caml_global_data = new_global_data; } return Val_unit; } CAMLprim value caml_get_current_environment(value unit) { return *caml_extern_sp; } CAMLprim value caml_invoke_traced_function(value codeptr, value env, value arg) { /* Stack layout on entry: return frame into instrument_closure function arg3 to call_original_code (arg) arg2 to call_original_code (env) arg1 to call_original_code (codeptr) arg3 to call_original_code (arg) arg2 to call_original_code (env) saved env */ /* Stack layout on exit: return frame into instrument_closure function actual arg to code (arg) pseudo return frame into codeptr: extra_args = 0 environment = env PC = codeptr arg3 to call_original_code (arg) same 6 bottom words as arg2 to call_original_code (env) on entrance, but arg1 to call_original_code (codeptr) shifted down 4 words arg3 to call_original_code (arg) arg2 to call_original_code (env) saved env */ value * osp, * nsp; int i; osp = caml_extern_sp; caml_extern_sp -= 4; nsp = caml_extern_sp; for (i = 0; i < 6; i++) nsp[i] = osp[i]; nsp[6] = codeptr; nsp[7] = env; nsp[8] = Val_int(0); nsp[9] = arg; return Val_unit; } #else /* Dummy definitions to support compilation of ocamlc.opt */ value caml_get_global_data(value unit) { caml_invalid_argument("Meta.get_global_data"); return Val_unit; /* not reached */ } value caml_get_section_table(value unit) { caml_invalid_argument("Meta.get_section_table"); return Val_unit; /* not reached */ } value caml_realloc_global(value size) { caml_invalid_argument("Meta.realloc_global"); return Val_unit; /* not reached */ } value caml_invoke_traced_function(value codeptr, value env, value arg) { caml_invalid_argument("Meta.invoke_traced_function"); return Val_unit; /* not reached */ } value caml_reify_bytecode(value prog, value len) { caml_invalid_argument("Meta.reify_bytecode"); return Val_unit; /* not reached */ } value * caml_stack_low; value * caml_stack_high; value * caml_stack_threshold; value * caml_extern_sp; value * caml_trapsp; int caml_callback_depth; int volatile caml_something_to_do; void (* volatile caml_async_action_hook)(void); struct longjmp_buffer * caml_external_raise; #endif mingw-ocaml/ocaml/byterun/alloc.c0000644000175000017500000001157512124403240016414 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* 1. Allocation functions doing the same work as the macros in the case where [Setup_for_gc] and [Restore_after_gc] are no-ops. 2. Convenience functions related to allocation. */ #include #include "alloc.h" #include "custom.h" #include "major_gc.h" #include "memory.h" #include "mlvalues.h" #include "stacks.h" #define Setup_for_gc #define Restore_after_gc CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag) { value result; mlsize_t i; Assert (tag < 256); Assert (tag != Infix_tag); if (wosize == 0){ result = Atom (tag); }else if (wosize <= Max_young_wosize){ Alloc_small (result, wosize, tag); if (tag < No_scan_tag){ for (i = 0; i < wosize; i++) Field (result, i) = 0; } }else{ result = caml_alloc_shr (wosize, tag); if (tag < No_scan_tag) memset (Bp_val (result), 0, Bsize_wsize (wosize)); result = caml_check_urgent_gc (result); } return result; } CAMLexport value caml_alloc_small (mlsize_t wosize, tag_t tag) { value result; Assert (wosize > 0); Assert (wosize <= Max_young_wosize); Assert (tag < 256); Alloc_small (result, wosize, tag); return result; } CAMLexport value caml_alloc_tuple(mlsize_t n) { return caml_alloc(n, 0); } CAMLexport value caml_alloc_string (mlsize_t len) { value result; mlsize_t offset_index; mlsize_t wosize = (len + sizeof (value)) / sizeof (value); if (wosize <= Max_young_wosize) { Alloc_small (result, wosize, String_tag); }else{ result = caml_alloc_shr (wosize, String_tag); result = caml_check_urgent_gc (result); } Field (result, wosize - 1) = 0; offset_index = Bsize_wsize (wosize) - 1; Byte (result, offset_index) = offset_index - len; return result; } CAMLexport value caml_alloc_final (mlsize_t len, final_fun fun, mlsize_t mem, mlsize_t max) { return caml_alloc_custom(caml_final_custom_operations(fun), len * sizeof(value), mem, max); } CAMLexport value caml_copy_string(char const *s) { int len; value res; len = strlen(s); res = caml_alloc_string(len); memmove(String_val(res), s, len); return res; } CAMLexport value caml_alloc_array(value (*funct)(char const *), char const ** arr) { CAMLparam0 (); mlsize_t nbr, n; CAMLlocal2 (v, result); nbr = 0; while (arr[nbr] != 0) nbr++; if (nbr == 0) { CAMLreturn (Atom(0)); } else { result = caml_alloc (nbr, 0); for (n = 0; n < nbr; n++) { /* The two statements below must be separate because of evaluation order (don't take the address &Field(result, n) before calling funct, which may cause a GC and move result). */ v = funct(arr[n]); caml_modify(&Field(result, n), v); } CAMLreturn (result); } } CAMLexport value caml_copy_string_array(char const ** arr) { return caml_alloc_array(caml_copy_string, arr); } CAMLexport int caml_convert_flag_list(value list, int *flags) { int res; res = 0; while (list != Val_int(0)) { res |= flags[Int_val(Field(list, 0))]; list = Field(list, 1); } return res; } /* For compiling let rec over values */ CAMLprim value caml_alloc_dummy(value size) { mlsize_t wosize = Int_val(size); if (wosize == 0) return Atom(0); return caml_alloc (wosize, 0); } CAMLprim value caml_alloc_dummy_float (value size) { mlsize_t wosize = Int_val(size) * Double_wosize; if (wosize == 0) return Atom(0); return caml_alloc (wosize, 0); } CAMLprim value caml_update_dummy(value dummy, value newval) { mlsize_t size, i; tag_t tag; size = Wosize_val(newval); tag = Tag_val (newval); Assert (size == Wosize_val(dummy)); Assert (tag < No_scan_tag || tag == Double_array_tag); Tag_val(dummy) = tag; if (tag == Double_array_tag){ size = Wosize_val (newval) / Double_wosize; for (i = 0; i < size; i++){ Store_double_field (dummy, i, Double_field (newval, i)); } }else{ for (i = 0; i < size; i++){ caml_modify (&Field(dummy, i), Field(newval, i)); } } return Val_unit; } mingw-ocaml/ocaml/byterun/compare.c0000644000175000017500000002453212124403240016745 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "custom.h" #include "fail.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" /* Structural comparison on trees. */ struct compare_item { value * v1, * v2; mlsize_t count; }; #define COMPARE_STACK_INIT_SIZE 256 #define COMPARE_STACK_MAX_SIZE (1024*1024) static struct compare_item compare_stack_init[COMPARE_STACK_INIT_SIZE]; static struct compare_item * compare_stack = compare_stack_init; static struct compare_item * compare_stack_limit = compare_stack_init + COMPARE_STACK_INIT_SIZE; CAMLexport int caml_compare_unordered; /* Free the compare stack if needed */ static void compare_free_stack(void) { if (compare_stack != compare_stack_init) { free(compare_stack); /* Reinitialize the globals for next time around */ compare_stack = compare_stack_init; compare_stack_limit = compare_stack + COMPARE_STACK_INIT_SIZE; } } /* Same, then raise Out_of_memory */ static void compare_stack_overflow(void) { caml_gc_message (0x04, "Stack overflow in structural comparison\n", 0); compare_free_stack(); caml_raise_out_of_memory(); } /* Grow the compare stack */ static struct compare_item * compare_resize_stack(struct compare_item * sp) { asize_t newsize = 2 * (compare_stack_limit - compare_stack); asize_t sp_offset = sp - compare_stack; struct compare_item * newstack; if (newsize >= COMPARE_STACK_MAX_SIZE) compare_stack_overflow(); if (compare_stack == compare_stack_init) { newstack = malloc(sizeof(struct compare_item) * newsize); if (newstack == NULL) compare_stack_overflow(); memcpy(newstack, compare_stack_init, sizeof(struct compare_item) * COMPARE_STACK_INIT_SIZE); } else { newstack = realloc(compare_stack, sizeof(struct compare_item) * newsize); if (newstack == NULL) compare_stack_overflow(); } compare_stack = newstack; compare_stack_limit = newstack + newsize; return newstack + sp_offset; } /* Structural comparison */ #define LESS -1 #define EQUAL 0 #define GREATER 1 #define UNORDERED ((intnat)1 << (8 * sizeof(value) - 1)) /* The return value of compare_val is as follows: > 0 v1 is greater than v2 0 v1 is equal to v2 < 0 and > UNORDERED v1 is less than v2 UNORDERED v1 and v2 cannot be compared */ static intnat compare_val(value v1, value v2, int total) { struct compare_item * sp; tag_t t1, t2; sp = compare_stack; while (1) { if (v1 == v2 && total) goto next_item; if (Is_long(v1)) { if (v1 == v2) goto next_item; if (Is_long(v2)) return Long_val(v1) - Long_val(v2); /* Subtraction above cannot overflow and cannot result in UNORDERED */ if (Is_in_value_area(v2)) { switch (Tag_val(v2)) { case Forward_tag: v2 = Forward_val(v2); continue; case Custom_tag: { int res; int (*compare)(value v1, value v2) = Custom_ops_val(v2)->compare_ext; if (compare == NULL) break; /* for backward compatibility */ caml_compare_unordered = 0; res = compare(v1, v2); if (caml_compare_unordered && !total) return UNORDERED; if (res != 0) return res; goto next_item; } default: /*fallthrough*/; } } return LESS; /* v1 long < v2 block */ } if (Is_long(v2)) { if (Is_in_value_area(v1)) { switch (Tag_val(v1)) { case Forward_tag: v1 = Forward_val(v1); continue; case Custom_tag: { int res; int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare_ext; if (compare == NULL) break; /* for backward compatibility */ caml_compare_unordered = 0; res = compare(v1, v2); if (caml_compare_unordered && !total) return UNORDERED; if (res != 0) return res; goto next_item; } default: /*fallthrough*/; } } return GREATER; /* v1 block > v2 long */ } /* If one of the objects is outside the heap (but is not an atom), use address comparison. Since both addresses are 2-aligned, shift lsb off to avoid overflow in subtraction. */ if (! Is_in_value_area(v1) || ! Is_in_value_area(v2)) { if (v1 == v2) goto next_item; return (v1 >> 1) - (v2 >> 1); /* Subtraction above cannot result in UNORDERED */ } t1 = Tag_val(v1); t2 = Tag_val(v2); if (t1 == Forward_tag) { v1 = Forward_val (v1); continue; } if (t2 == Forward_tag) { v2 = Forward_val (v2); continue; } if (t1 != t2) return (intnat)t1 - (intnat)t2; switch(t1) { case String_tag: { mlsize_t len1, len2; int res; if (v1 == v2) break; len1 = caml_string_length(v1); len2 = caml_string_length(v2); res = memcmp(String_val(v1), String_val(v2), len1 <= len2 ? len1 : len2); if (res < 0) return LESS; if (res > 0) return GREATER; if (len1 != len2) return len1 - len2; break; } case Double_tag: { double d1 = Double_val(v1); double d2 = Double_val(v2); if (d1 < d2) return LESS; if (d1 > d2) return GREATER; if (d1 != d2) { if (! total) return UNORDERED; /* One or both of d1 and d2 is NaN. Order according to the convention NaN = NaN and NaN < f for all other floats f. */ if (d1 == d1) return GREATER; /* d1 is not NaN, d2 is NaN */ if (d2 == d2) return LESS; /* d2 is not NaN, d1 is NaN */ /* d1 and d2 are both NaN, thus equal: continue comparison */ } break; } case Double_array_tag: { mlsize_t sz1 = Wosize_val(v1) / Double_wosize; mlsize_t sz2 = Wosize_val(v2) / Double_wosize; mlsize_t i; if (sz1 != sz2) return sz1 - sz2; for (i = 0; i < sz1; i++) { double d1 = Double_field(v1, i); double d2 = Double_field(v2, i); if (d1 < d2) return LESS; if (d1 > d2) return GREATER; if (d1 != d2) { if (! total) return UNORDERED; /* See comment for Double_tag case */ if (d1 == d1) return GREATER; if (d2 == d2) return LESS; } } break; } case Abstract_tag: compare_free_stack(); caml_invalid_argument("equal: abstract value"); case Closure_tag: case Infix_tag: compare_free_stack(); caml_invalid_argument("equal: functional value"); case Object_tag: { intnat oid1 = Oid_val(v1); intnat oid2 = Oid_val(v2); if (oid1 != oid2) return oid1 - oid2; break; } case Custom_tag: { int res; int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare; /* Hardening against comparisons between different types */ if (compare != Custom_ops_val(v2)->compare) { return strcmp(Custom_ops_val(v1)->identifier, Custom_ops_val(v2)->identifier) < 0 ? LESS : GREATER; } if (compare == NULL) { compare_free_stack(); caml_invalid_argument("equal: abstract value"); } caml_compare_unordered = 0; res = compare(v1, v2); if (caml_compare_unordered && !total) return UNORDERED; if (res != 0) return res; break; } default: { mlsize_t sz1 = Wosize_val(v1); mlsize_t sz2 = Wosize_val(v2); /* Compare sizes first for speed */ if (sz1 != sz2) return sz1 - sz2; if (sz1 == 0) break; /* Remember that we still have to compare fields 1 ... sz - 1 */ if (sz1 > 1) { sp++; if (sp >= compare_stack_limit) sp = compare_resize_stack(sp); sp->v1 = &Field(v1, 1); sp->v2 = &Field(v2, 1); sp->count = sz1 - 1; } /* Continue comparison with first field */ v1 = Field(v1, 0); v2 = Field(v2, 0); continue; } } next_item: /* Pop one more item to compare, if any */ if (sp == compare_stack) return EQUAL; /* we're done */ v1 = *((sp->v1)++); v2 = *((sp->v2)++); if (--(sp->count) == 0) sp--; } } CAMLprim value caml_compare(value v1, value v2) { intnat res = compare_val(v1, v2, 1); /* Free stack if needed */ if (compare_stack != compare_stack_init) compare_free_stack(); if (res < 0) return Val_int(LESS); else if (res > 0) return Val_int(GREATER); else return Val_int(EQUAL); } CAMLprim value caml_equal(value v1, value v2) { intnat res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); return Val_int(res == 0); } CAMLprim value caml_notequal(value v1, value v2) { intnat res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); return Val_int(res != 0); } CAMLprim value caml_lessthan(value v1, value v2) { intnat res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); return Val_int(res < 0 && res != UNORDERED); } CAMLprim value caml_lessequal(value v1, value v2) { intnat res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); return Val_int(res <= 0 && res != UNORDERED); } CAMLprim value caml_greaterthan(value v1, value v2) { intnat res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); return Val_int(res > 0); } CAMLprim value caml_greaterequal(value v1, value v2) { intnat res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); return Val_int(res >= 0); } mingw-ocaml/ocaml/byterun/compatibility.h0000644000175000017500000003115012124403240020167 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Moscova, INRIA Rocquencourt */ /* */ /* Copyright 2003 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* definitions for compatibility with old identifiers */ #ifndef CAML_COMPATIBILITY_H #define CAML_COMPATIBILITY_H #ifndef CAML_NAME_SPACE /* #define --> CAMLextern (defined with CAMLexport or CAMLprim) (rien) --> CAMLprim g --> global C identifier x --> special case SP* signals the special cases: - when the identifier was not simply prefixed with [caml_] - when the [caml_] version was already used for something else, and was renamed out of the way (watch out for [caml_alloc] and [caml_array_bound_error] in *.s) */ /* a faire: - ui_* (reverifier que win32.c n'en depend pas) */ /* **** alloc.c */ #define alloc caml_alloc /*SP*/ #define alloc_small caml_alloc_small #define alloc_tuple caml_alloc_tuple #define alloc_string caml_alloc_string #define alloc_final caml_alloc_final #define copy_string caml_copy_string #define alloc_array caml_alloc_array #define copy_string_array caml_copy_string_array #define convert_flag_list caml_convert_flag_list /* **** array.c */ /* **** backtrace.c */ #define backtrace_active caml_backtrace_active #define backtrace_pos caml_backtrace_pos #define backtrace_buffer caml_backtrace_buffer #define backtrace_last_exn caml_backtrace_last_exn #define print_exception_backtrace caml_print_exception_backtrace /* **** callback.c */ #define callback_depth caml_callback_depth #define callbackN_exn caml_callbackN_exn #define callback_exn caml_callback_exn #define callback2_exn caml_callback2_exn #define callback3_exn caml_callback3_exn #define callback caml_callback #define callback2 caml_callback2 #define callback3 caml_callback3 #define callbackN caml_callbackN /* **** compact.c */ /* **** compare.c */ #define compare_unordered caml_compare_unordered /* **** custom.c */ #define alloc_custom caml_alloc_custom #define register_custom_operations caml_register_custom_operations /* **** debugger.c */ /* **** dynlink.c */ /* **** extern.c */ #define output_val caml_output_val #define output_value_to_malloc caml_output_value_to_malloc #define output_value_to_block caml_output_value_to_block #define serialize_int_1 caml_serialize_int_1 #define serialize_int_2 caml_serialize_int_2 #define serialize_int_4 caml_serialize_int_4 #define serialize_int_8 caml_serialize_int_8 #define serialize_float_4 caml_serialize_float_4 #define serialize_float_8 caml_serialize_float_8 #define serialize_block_1 caml_serialize_block_1 #define serialize_block_2 caml_serialize_block_2 #define serialize_block_4 caml_serialize_block_4 #define serialize_block_8 caml_serialize_block_8 #define serialize_block_float_8 caml_serialize_block_float_8 /* **** fail.c */ #define external_raise caml_external_raise #define mlraise caml_raise /*SP*/ #define raise_constant caml_raise_constant #define raise_with_arg caml_raise_with_arg #define raise_with_string caml_raise_with_string #define failwith caml_failwith #define invalid_argument caml_invalid_argument #define array_bound_error caml_array_bound_error /*SP*/ #define raise_out_of_memory caml_raise_out_of_memory #define raise_stack_overflow caml_raise_stack_overflow #define raise_sys_error caml_raise_sys_error #define raise_end_of_file caml_raise_end_of_file #define raise_zero_divide caml_raise_zero_divide #define raise_not_found caml_raise_not_found #define raise_sys_blocked_io caml_raise_sys_blocked_io #define init_exceptions caml_init_exceptions /* **** asmrun/fail.c */ /* **** asmrun/.s */ /* **** finalise.c */ /* **** fix_code.c */ /* **** floats.c */ /*#define Double_val caml_Double_val done in mlvalues.h as needed */ /*#define Store_double_val caml_Store_double_val done in mlvalues.h as needed */ #define copy_double caml_copy_double /* **** freelist.c */ /* **** gc_ctrl.c */ /* **** globroots.c */ #define register_global_root caml_register_global_root #define remove_global_root caml_remove_global_root /* **** hash.c */ #define hash_variant caml_hash_variant /* **** instrtrace.c */ /* **** intern.c */ #define input_val caml_input_val #define input_val_from_string caml_input_val_from_string #define input_value_from_malloc caml_input_value_from_malloc #define input_value_from_block caml_input_value_from_block #define deserialize_uint_1 caml_deserialize_uint_1 #define deserialize_sint_1 caml_deserialize_sint_1 #define deserialize_uint_2 caml_deserialize_uint_2 #define deserialize_sint_2 caml_deserialize_sint_2 #define deserialize_uint_4 caml_deserialize_uint_4 #define deserialize_sint_4 caml_deserialize_sint_4 #define deserialize_uint_8 caml_deserialize_uint_8 #define deserialize_sint_8 caml_deserialize_sint_8 #define deserialize_float_4 caml_deserialize_float_4 #define deserialize_float_8 caml_deserialize_float_8 #define deserialize_block_1 caml_deserialize_block_1 #define deserialize_block_2 caml_deserialize_block_2 #define deserialize_block_4 caml_deserialize_block_4 #define deserialize_block_8 caml_deserialize_block_8 #define deserialize_block_float_8 caml_deserialize_block_float_8 #define deserialize_error caml_deserialize_error /* **** interp.c */ /* **** ints.c */ #define int32_ops caml_int32_ops #define copy_int32 caml_copy_int32 /*#define Int64_val caml_Int64_val *** done in mlvalues.h as needed */ #define int64_ops caml_int64_ops #define copy_int64 caml_copy_int64 #define nativeint_ops caml_nativeint_ops #define copy_nativeint caml_copy_nativeint /* **** io.c */ #define channel_mutex_free caml_channel_mutex_free #define channel_mutex_lock caml_channel_mutex_lock #define channel_mutex_unlock caml_channel_mutex_unlock #define channel_mutex_unlock_exn caml_channel_mutex_unlock_exn #define all_opened_channels caml_all_opened_channels #define open_descriptor_in caml_open_descriptor_in /*SP*/ #define open_descriptor_out caml_open_descriptor_out /*SP*/ #define close_channel caml_close_channel /*SP*/ #define channel_size caml_channel_size /*SP*/ #define channel_binary_mode caml_channel_binary_mode #define flush_partial caml_flush_partial /*SP*/ #define flush caml_flush /*SP*/ #define putword caml_putword #define putblock caml_putblock #define really_putblock caml_really_putblock #define seek_out caml_seek_out /*SP*/ #define pos_out caml_pos_out /*SP*/ #define do_read caml_do_read #define refill caml_refill #define getword caml_getword #define getblock caml_getblock #define really_getblock caml_really_getblock #define seek_in caml_seek_in /*SP*/ #define pos_in caml_pos_in /*SP*/ #define input_scan_line caml_input_scan_line /*SP*/ #define finalize_channel caml_finalize_channel #define alloc_channel caml_alloc_channel /*#define Val_file_offset caml_Val_file_offset *** done in io.h as needed */ /*#define File_offset_val caml_File_offset_val *** done in io.h as needed */ /* **** lexing.c */ /* **** main.c */ /* *** no change */ /* **** major_gc.c */ #define heap_start caml_heap_start #define page_table caml_page_table /* **** md5.c */ #define md5_string caml_md5_string #define md5_chan caml_md5_chan #define MD5Init caml_MD5Init #define MD5Update caml_MD5Update #define MD5Final caml_MD5Final #define MD5Transform caml_MD5Transform /* **** memory.c */ #define alloc_shr caml_alloc_shr #define initialize caml_initialize #define modify caml_modify #define stat_alloc caml_stat_alloc #define stat_free caml_stat_free #define stat_resize caml_stat_resize /* **** meta.c */ /* **** minor_gc.c */ #define young_start caml_young_start #define young_end caml_young_end #define young_ptr caml_young_ptr #define young_limit caml_young_limit #define ref_table caml_ref_table #define minor_collection caml_minor_collection #define check_urgent_gc caml_check_urgent_gc /* **** misc.c */ /* **** obj.c */ /* **** parsing.c */ /* **** prims.c */ /* **** printexc.c */ #define format_caml_exception caml_format_exception /*SP*/ /* **** roots.c */ #define local_roots caml_local_roots #define scan_roots_hook caml_scan_roots_hook #define do_local_roots caml_do_local_roots /* **** signals.c */ #define pending_signals caml_pending_signals #define something_to_do caml_something_to_do #define enter_blocking_section_hook caml_enter_blocking_section_hook #define leave_blocking_section_hook caml_leave_blocking_section_hook #define try_leave_blocking_section_hook caml_try_leave_blocking_section_hook #define async_action_hook caml_async_action_hook #define enter_blocking_section caml_enter_blocking_section #define leave_blocking_section caml_leave_blocking_section #define convert_signal_number caml_convert_signal_number /* **** asmrun/signals.c */ #define garbage_collection caml_garbage_collection /* **** stacks.c */ #define stack_low caml_stack_low #define stack_high caml_stack_high #define stack_threshold caml_stack_threshold #define extern_sp caml_extern_sp #define trapsp caml_trapsp #define trap_barrier caml_trap_barrier /* **** startup.c */ #define atom_table caml_atom_table /* **** asmrun/startup.c */ #define static_data_start caml_static_data_start #define static_data_end caml_static_data_end /* **** str.c */ #define string_length caml_string_length /* **** sys.c */ #define sys_error caml_sys_error #define sys_exit caml_sys_exit /* **** terminfo.c */ /* **** unix.c & win32.c */ #define search_exe_in_path caml_search_exe_in_path /* **** weak.c */ /* **** asmcomp/asmlink.ml */ /* **** asmcomp/cmmgen.ml */ /* **** asmcomp/asmlink.ml, asmcomp/cmmgen.ml, asmcomp/compilenv.ml */ /* ************************************************************* */ /* **** otherlibs/bigarray */ #define int8 caml_ba_int8 #define uint8 caml_ba_uint8 #define int16 caml_ba_int16 #define uint16 caml_ba_uint16 #define MAX_NUM_DIMS CAML_BA_MAX_NUM_DIMS #define caml_bigarray_kind caml_ba_kind #define BIGARRAY_FLOAT32 CAML_BA_FLOAT32 #define BIGARRAY_FLOAT64 CAML_BA_FLOAT64 #define BIGARRAY_SINT8 CAML_BA_SINT8 #define BIGARRAY_UINT8 CAML_BA_UINT8 #define BIGARRAY_SINT16 CAML_BA_SINT16 #define BIGARRAY_UINT16 CAML_BA_UINT16 #define BIGARRAY_INT32 CAML_BA_INT32 #define BIGARRAY_INT64 CAML_BA_INT64 #define BIGARRAY_CAML_INT CAML_BA_CAML_INT #define BIGARRAY_NATIVE_INT CAML_BA_NATIVE_INT #define BIGARRAY_COMPLEX32 CAML_BA_COMPLEX32 #define BIGARRAY_COMPLEX64 CAML_BA_COMPLEX64 #define BIGARRAY_KIND_MASK CAML_BA_KIND_MASK #define caml_bigarray_layout caml_ba_layout #define BIGARRAY_C_LAYOUT CAML_BA_C_LAYOUT #define BIGARRAY_FORTRAN_LAYOUT CAML_BA_FORTRAN_LAYOUT #define BIGARRAY_LAYOUT_MASK CAML_BA_LAYOUT_MASK #define caml_bigarray_managed caml_ba_managed #define BIGARRAY_EXTERNAL CAML_BA_EXTERNAL #define BIGARRAY_MANAGED CAML_BA_MANAGED #define BIGARRAY_MAPPED_FILE CAML_BA_MAPPED_FILE #define BIGARRAY_MANAGED_MASK CAML_BA_MANAGED_MASK #define caml_bigarray_proxy caml_ba_proxy #define caml_bigarray caml_ba_array #define Bigarray_val Caml_ba_array_val #define Data_bigarray_val Caml_ba_data_val #define alloc_bigarray caml_ba_alloc #define alloc_bigarray_dims caml_ba_alloc_dims #define bigarray_map_file caml_ba_map_file #define bigarray_unmap_file caml_ba_unmap_file #define bigarray_element_size caml_ba_element_size #define bigarray_byte_size caml_ba_byte_size #define bigarray_deserialize caml_ba_deserialize #define MAX_BIGARRAY_MEMORY CAML_BA_MAX_MEMORY #define bigarray_create caml_ba_create #define bigarray_get_N caml_ba_get_N #define bigarray_get_1 caml_ba_get_1 #define bigarray_get_2 caml_ba_get_2 #define bigarray_get_3 caml_ba_get_3 #define bigarray_get_generic caml_ba_get_generic #define bigarray_set_1 caml_ba_set_1 #define bigarray_set_2 caml_ba_set_2 #define bigarray_set_3 caml_ba_set_3 #define bigarray_set_N caml_ba_set_N #define bigarray_set_generic caml_ba_set_generic #define bigarray_num_dims caml_ba_num_dims #define bigarray_dim caml_ba_dim #define bigarray_kind caml_ba_kind #define bigarray_layout caml_ba_layout #define bigarray_slice caml_ba_slice #define bigarray_sub caml_ba_sub #define bigarray_blit caml_ba_blit #define bigarray_fill caml_ba_fill #define bigarray_reshape caml_ba_reshape #define bigarray_init caml_ba_init #endif /* CAML_NAME_SPACE */ #endif /* CAML_COMPATIBILITY_H */ mingw-ocaml/ocaml/byterun/prims.h0000644000175000017500000000254012124403240016451 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Interface with C primitives. */ #ifndef CAML_PRIMS_H #define CAML_PRIMS_H typedef value (*c_primitive)(); extern c_primitive caml_builtin_cprim[]; extern char * caml_names_of_builtin_cprim[]; extern struct ext_table caml_prim_table; #ifdef DEBUG extern struct ext_table caml_prim_name_table; #endif #define Primitive(n) ((c_primitive)(caml_prim_table.contents[n])) extern char * caml_section_table; extern asize_t caml_section_table_size; #endif /* CAML_PRIMS_H */ mingw-ocaml/ocaml/byterun/roots.c0000644000175000017500000000632512124403240016465 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* To walk the memory roots for garbage collection */ #include "finalise.h" #include "globroots.h" #include "major_gc.h" #include "memory.h" #include "minor_gc.h" #include "misc.h" #include "mlvalues.h" #include "roots.h" #include "stacks.h" CAMLexport struct caml__roots_block *caml_local_roots = NULL; CAMLexport void (*caml_scan_roots_hook) (scanning_action f) = NULL; /* FIXME should rename to [caml_oldify_young_roots] and synchronise with asmrun/roots.c */ /* Call [caml_oldify_one] on (at least) all the roots that point to the minor heap. */ void caml_oldify_local_roots (void) { register value * sp; struct caml__roots_block *lr; intnat i, j; /* The stack */ for (sp = caml_extern_sp; sp < caml_stack_high; sp++) { caml_oldify_one (*sp, sp); } /* Local C roots */ /* FIXME do the old-frame trick ? */ for (lr = caml_local_roots; lr != NULL; lr = lr->next) { for (i = 0; i < lr->ntables; i++){ for (j = 0; j < lr->nitems; j++){ sp = &(lr->tables[i][j]); caml_oldify_one (*sp, sp); } } } /* Global C roots */ caml_scan_global_young_roots(&caml_oldify_one); /* Finalised values */ caml_final_do_young_roots (&caml_oldify_one); /* Hook */ if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one); } /* Call [caml_darken] on all roots */ void caml_darken_all_roots (void) { caml_do_roots (caml_darken); } void caml_do_roots (scanning_action f) { /* Global variables */ f(caml_global_data, &caml_global_data); /* The stack and the local C roots */ caml_do_local_roots(f, caml_extern_sp, caml_stack_high, caml_local_roots); /* Global C roots */ caml_scan_global_roots(f); /* Finalised values */ caml_final_do_strong_roots (f); /* Hook */ if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f); } CAMLexport void caml_do_local_roots (scanning_action f, value *stack_low, value *stack_high, struct caml__roots_block *local_roots) { register value * sp; struct caml__roots_block *lr; int i, j; for (sp = stack_low; sp < stack_high; sp++) { f (*sp, sp); } for (lr = local_roots; lr != NULL; lr = lr->next) { for (i = 0; i < lr->ntables; i++){ for (j = 0; j < lr->nitems; j++){ sp = &(lr->tables[i][j]); f (*sp, sp); } } } } mingw-ocaml/ocaml/byterun/win32.c0000644000175000017500000003215112124403240016255 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Win32-specific stuff */ #include #include #include #include #include #include #include #include #include #include #include #include "fail.h" #include "memory.h" #include "misc.h" #include "osdeps.h" #include "signals.h" #include "sys.h" #include "flexdll.h" #ifndef S_ISREG #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) #endif char * caml_decompose_path(struct ext_table * tbl, char * path) { char * p, * q; int n; if (path == NULL) return NULL; p = caml_stat_alloc(strlen(path) + 1); strcpy(p, path); q = p; while (1) { for (n = 0; q[n] != 0 && q[n] != ';'; n++) /*nothing*/; caml_ext_table_add(tbl, q); q = q + n; if (*q == 0) break; *q = 0; q += 1; } return p; } char * caml_search_in_path(struct ext_table * path, char * name) { char * p, * fullname; int i; struct stat st; for (p = name; *p != 0; p++) { if (*p == '/' || *p == '\\') goto not_found; } for (i = 0; i < path->size; i++) { fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) + strlen(name) + 2); strcpy(fullname, (char *)(path->contents[i])); strcat(fullname, "\\"); strcat(fullname, name); caml_gc_message(0x100, "Searching %s\n", (uintnat) fullname); if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname; caml_stat_free(fullname); } not_found: caml_gc_message(0x100, "%s not found in search path\n", (uintnat) name); fullname = caml_stat_alloc(strlen(name) + 1); strcpy(fullname, name); return fullname; } CAMLexport char * caml_search_exe_in_path(char * name) { char * fullname, * filepart; DWORD pathlen, retcode; pathlen = strlen(name) + 1; if (pathlen < 256) pathlen = 256; while (1) { fullname = stat_alloc(pathlen); retcode = SearchPath(NULL, /* use system search path */ name, ".exe", /* add .exe extension if needed */ pathlen, fullname, &filepart); if (retcode == 0) { caml_gc_message(0x100, "%s not found in search path\n", (uintnat) name); strcpy(fullname, name); break; } if (retcode < pathlen) break; stat_free(fullname); pathlen = retcode + 1; } return fullname; } char * caml_search_dll_in_path(struct ext_table * path, char * name) { char * dllname = caml_stat_alloc(strlen(name) + 5); char * res; strcpy(dllname, name); strcat(dllname, ".dll"); res = caml_search_in_path(path, dllname); caml_stat_free(dllname); return res; } void * caml_dlopen(char * libname, int for_execution, int global) { void *handle; int flags = (global ? FLEXDLL_RTLD_GLOBAL : 0); if (!for_execution) flags |= FLEXDLL_RTLD_NOEXEC; handle = flexdll_dlopen(libname, flags); if ((handle != NULL) && ((caml_verb_gc & 0x100) != 0)) { flexdll_dump_exports(handle); fflush(stdout); } return handle; } void caml_dlclose(void * handle) { flexdll_dlclose(handle); } void * caml_dlsym(void * handle, char * name) { return flexdll_dlsym(handle, name); } void * caml_globalsym(char * name) { return flexdll_dlsym(flexdll_dlopen(NULL,0), name); } char * caml_dlerror(void) { return flexdll_dlerror(); } /* Proper emulation of signal(), including ctrl-C and ctrl-break */ typedef void (*sighandler)(int sig); static int ctrl_handler_installed = 0; static volatile sighandler ctrl_handler_action = SIG_DFL; static BOOL WINAPI ctrl_handler(DWORD event) { int saved_mode; /* Only ctrl-C and ctrl-Break are handled */ if (event != CTRL_C_EVENT && event != CTRL_BREAK_EVENT) return FALSE; /* Default behavior is to exit, which we get by not handling the event */ if (ctrl_handler_action == SIG_DFL) return FALSE; /* Ignore behavior is to do nothing, which we get by claiming that we have handled the event */ if (ctrl_handler_action == SIG_IGN) return TRUE; /* Win32 doesn't like it when we do a longjmp() at this point (it looks like we're running in a different thread than the main program!). So, just record the signal. */ caml_record_signal(SIGINT); /* We have handled the event */ return TRUE; } sighandler caml_win32_signal(int sig, sighandler action) { sighandler oldaction; if (sig != SIGINT) return signal(sig, action); if (! ctrl_handler_installed) { SetConsoleCtrlHandler(ctrl_handler, TRUE); ctrl_handler_installed = 1; } oldaction = ctrl_handler_action; ctrl_handler_action = action; return oldaction; } /* Expansion of @responsefile and *? file patterns in the command line */ static int argc; static char ** argv; static int argvsize; static void store_argument(char * arg); static void expand_argument(char * arg); static void expand_pattern(char * arg); static void out_of_memory(void) { fprintf(stderr, "Out of memory while expanding command line\n"); exit(2); } static void store_argument(char * arg) { if (argc + 1 >= argvsize) { argvsize *= 2; argv = (char **) realloc(argv, argvsize * sizeof(char *)); if (argv == NULL) out_of_memory(); } argv[argc++] = arg; } static void expand_argument(char * arg) { char * p; for (p = arg; *p != 0; p++) { if (*p == '*' || *p == '?') { expand_pattern(arg); return; } } store_argument(arg); } static void expand_pattern(char * pat) { int handle; struct _finddata_t ffblk; int preflen; handle = _findfirst(pat, &ffblk); if (handle == -1) { store_argument(pat); /* a la Bourne shell */ return; } for (preflen = strlen(pat); preflen > 0; preflen--) { char c = pat[preflen - 1]; if (c == '\\' || c == '/' || c == ':') break; } do { char * name = malloc(preflen + strlen(ffblk.name) + 1); if (name == NULL) out_of_memory(); memcpy(name, pat, preflen); strcpy(name + preflen, ffblk.name); store_argument(name); } while (_findnext(handle, &ffblk) != -1); _findclose(handle); } CAMLexport void caml_expand_command_line(int * argcp, char *** argvp) { int i; argc = 0; argvsize = 16; argv = (char **) malloc(argvsize * sizeof(char *)); if (argv == NULL) out_of_memory(); for (i = 0; i < *argcp; i++) expand_argument((*argvp)[i]); argv[argc] = NULL; *argcp = argc; *argvp = argv; } /* Add to [contents] the (short) names of the files contained in the directory named [dirname]. No entries are added for [.] and [..]. Return 0 on success, -1 on error; set errno in the case of error. */ int caml_read_directory(char * dirname, struct ext_table * contents) { int dirnamelen; char * template; #if _MSC_VER <= 1200 int h; #else intptr_t h; #endif struct _finddata_t fileinfo; char * p; dirnamelen = strlen(dirname); template = caml_stat_alloc(dirnamelen + 5); strcpy(template, dirname); switch (dirname[dirnamelen - 1]) { case '/': case '\\': case ':': strcat(template, "*.*"); break; default: strcat(template, "\\*.*"); } h = _findfirst(template, &fileinfo); caml_stat_free(template); if (h == -1) return errno == ENOENT ? 0 : -1; do { if (strcmp(fileinfo.name, ".") != 0 && strcmp(fileinfo.name, "..") != 0) { p = caml_stat_alloc(strlen(fileinfo.name) + 1); strcpy(p, fileinfo.name); caml_ext_table_add(contents, p); } } while (_findnext(h, &fileinfo) == 0); _findclose(h); return 0; } #ifndef NATIVE_CODE /* Set up a new thread for control-C emulation and termination */ void caml_signal_thread(void * lpParam) { char *endptr; HANDLE h; /* Get an hexa-code raw handle through the environment */ h = (HANDLE) strtol(getenv("CAMLSIGPIPE"), &endptr, 16); while (1) { DWORD numread; BOOL ret; char iobuf[2]; /* This shall always return a single character */ ret = ReadFile(h, iobuf, 1, &numread, NULL); if (!ret || numread != 1) caml_sys_exit(Val_int(2)); switch (iobuf[0]) { case 'C': caml_record_signal(SIGINT); break; case 'T': raise(SIGTERM); return; } } } #endif /* NATIVE_CODE */ #if defined(NATIVE_CODE) && !defined(_WIN64) /* Handling of system stack overflow. * Based on code provided by Olivier Andrieu. * An EXCEPTION_STACK_OVERFLOW is signaled when the guard page at the * end of the stack has been accessed. Windows clears the PAGE_GUARD * protection (making it a regular PAGE_READWRITE) and then calls our * exception handler. This means that although we're handling an "out * of stack" condition, there is a bit of stack available to call * functions and allocate temporaries. * * PAGE_GUARD is a one-shot access protection mechanism: we need to * restore the PAGE_GUARD protection on this page otherwise the next * stack overflow won't be detected and the program will abruptly exit * with STATUS_ACCESS_VIOLATION. * * Visual Studio 2003 and later (_MSC_VER >= 1300) have a * _resetstkoflw() function that resets this protection. * Unfortunately, it cannot work when called directly from the * exception handler because at this point we are using the page that * is to be protected. * * A solution is to used an alternate stack when restoring the * protection. However it's not possible to use _resetstkoflw() then * since it determines the stack pointer by calling alloca(): it would * try to protect the alternate stack. * * Finally, we call caml_raise_stack_overflow; it will either call * caml_raise_exception which switches back to the normal stack, or * call caml_fatal_uncaught_exception which terminates the program * quickly. * * NB: The PAGE_GUARD protection is only available on WinNT, not * Win9x. There is an equivalent mechanism on Win9x with * PAGE_NOACCESS. * * Currently, does not work under Win64. */ static uintnat win32_alt_stack[0x80]; static void caml_reset_stack (void *faulting_address) { OSVERSIONINFO osi; SYSTEM_INFO si; DWORD page_size; MEMORY_BASIC_INFORMATION mbi; DWORD oldprot; /* get the os version (Win9x or WinNT ?) */ osi.dwOSVersionInfoSize = sizeof osi; if (! GetVersionEx (&osi)) goto failed; /* get the system's page size. */ GetSystemInfo (&si); page_size = si.dwPageSize; /* get some information on the page the fault occurred */ if (! VirtualQuery (faulting_address, &mbi, sizeof mbi)) goto failed; /* restore the PAGE_GUARD protection on this page */ switch (osi.dwPlatformId) { case VER_PLATFORM_WIN32_NT: VirtualProtect (mbi.BaseAddress, page_size, mbi.Protect | PAGE_GUARD, &oldprot); break; case VER_PLATFORM_WIN32_WINDOWS: VirtualProtect (mbi.BaseAddress, page_size, PAGE_NOACCESS, &oldprot); break; } failed: caml_raise_stack_overflow(); } extern char * caml_code_area_start, * caml_code_area_end; CAMLextern int caml_is_in_code(void *); #define Is_in_code_area(pc) \ ( ((char *)(pc) >= caml_code_area_start && \ (char *)(pc) <= caml_code_area_end) \ || (Classify_addr(pc) & In_code_area) ) static LONG CALLBACK caml_UnhandledExceptionFilter (EXCEPTION_POINTERS* exn_info) { DWORD code = exn_info->ExceptionRecord->ExceptionCode; CONTEXT *ctx = exn_info->ContextRecord; DWORD *ctx_ip = &(ctx->Eip); DWORD *ctx_sp = &(ctx->Esp); if (code == EXCEPTION_STACK_OVERFLOW && Is_in_code_area (*ctx_ip)) { uintnat faulting_address; uintnat * alt_esp; /* grab the address that caused the fault */ faulting_address = exn_info->ExceptionRecord->ExceptionInformation[1]; /* call caml_reset_stack(faulting_address) using the alternate stack */ alt_esp = win32_alt_stack + sizeof(win32_alt_stack) / sizeof(uintnat); *--alt_esp = faulting_address; *ctx_sp = (uintnat) (alt_esp - 1); *ctx_ip = (uintnat) &caml_reset_stack; return EXCEPTION_CONTINUE_EXECUTION; } return EXCEPTION_CONTINUE_SEARCH; } void caml_win32_overflow_detection() { SetUnhandledExceptionFilter (caml_UnhandledExceptionFilter); } #endif /* Seeding of pseudo-random number generators */ int caml_win32_random_seed (intnat data[16]) { /* For better randomness, consider: http://msdn.microsoft.com/library/en-us/seccrypto/security/rtlgenrandom.asp */ FILETIME t; GetSystemTimeAsFileTime(&t); data[0] = t.dwLowDateTime; data[1] = t.dwHighDateTime; data[2] = GetCurrentProcessId(); return 3; } mingw-ocaml/ocaml/byterun/Makefile0000644000175000017500000000461212124403240016610 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### # $Id$ include Makefile.common CFLAGS=-DCAML_NAME_SPACE -O $(BYTECCCOMPOPTS) $(IFLEXDIR) DFLAGS=-DCAML_NAME_SPACE -g -DDEBUG $(BYTECCCOMPOPTS) $(IFLEXDIR) OBJS=$(COMMONOBJS) unix.o main.o DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o PICOBJS=$(OBJS:.o=.pic.o) SHARED_LIBS_TMP=$(SUPPORTS_SHARED_LIBRARIES:%false=) SHARED_LIBS_DEPS=$(SHARED_LIBS_TMP:%true=libcamlrun_shared.so) all:: $(SHARED_LIBS_DEPS) ocamlrun$(EXE): libcamlrun.a prims.o $(MKEXE) $(BYTECCLINKOPTS) -o ocamlrun$(EXE) \ prims.o libcamlrun.a $(BYTECCLIBS) ocamlrund$(EXE): libcamlrund.a prims.o $(MKEXE) $(MKEXEDEBUGFLAG) $(BYTECCLINKOPTS) -o ocamlrund$(EXE) \ prims.o libcamlrund.a $(BYTECCLIBS) libcamlrun.a: $(OBJS) ar rc libcamlrun.a $(OBJS) $(RANLIB) libcamlrun.a libcamlrund.a: $(DOBJS) ar rc libcamlrund.a $(DOBJS) $(RANLIB) libcamlrund.a libcamlrun_shared.so: $(PICOBJS) $(MKDLL) -o libcamlrun_shared.so $(PICOBJS) $(BYTECCLIBS) install:: if test -f libcamlrun_shared.so; then \ cp libcamlrun_shared.so $(LIBDIR)/libcamlrun_shared.so; fi clean:: rm -f libcamlrun_shared.so .SUFFIXES: .d.o .pic.o .c.d.o: ln -s -f $*.c $*.d.c $(CC) -c $(DFLAGS) $*.d.c rm $*.d.c .c.pic.o: ln -s -f $*.c $*.pic.c $(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $*.pic.c rm $*.pic.c clean:: rm -f *.pic.c *.d.c depend : prims.c opnames.h jumptbl.h version.h -gcc -MM $(BYTECCCOMPOPTS) *.c > .depend -gcc -MM $(BYTECCCOMPOPTS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend -gcc -MM $(BYTECCCOMPOPTS) *.c | sed -e 's/\.o/.pic.o/' >> .depend .PHONY: depend include .depend mingw-ocaml/ocaml/byterun/callback.h0000644000175000017500000000411312124403240017051 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Callbacks from C to OCaml */ #ifndef CAML_CALLBACK_H #define CAML_CALLBACK_H #ifndef CAML_NAME_SPACE #include "compatibility.h" #endif #include "mlvalues.h" #ifdef __cplusplus extern "C" { #endif CAMLextern value caml_callback (value closure, value arg); CAMLextern value caml_callback2 (value closure, value arg1, value arg2); CAMLextern value caml_callback3 (value closure, value arg1, value arg2, value arg3); CAMLextern value caml_callbackN (value closure, int narg, value args[]); CAMLextern value caml_callback_exn (value closure, value arg); CAMLextern value caml_callback2_exn (value closure, value arg1, value arg2); CAMLextern value caml_callback3_exn (value closure, value arg1, value arg2, value arg3); CAMLextern value caml_callbackN_exn (value closure, int narg, value args[]); #define Make_exception_result(v) ((v) | 2) #define Is_exception_result(v) (((v) & 3) == 2) #define Extract_exception(v) ((v) & ~3) CAMLextern value * caml_named_value (char const * name); CAMLextern void caml_main (char ** argv); CAMLextern void caml_startup (char ** argv); CAMLextern int caml_callback_depth; #ifdef __cplusplus } #endif #endif mingw-ocaml/ocaml/byterun/obj.c0000644000175000017500000001523412124403240016070 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Operations on objects */ #include #include "alloc.h" #include "fail.h" #include "gc.h" #include "interp.h" #include "major_gc.h" #include "memory.h" #include "minor_gc.h" #include "misc.h" #include "mlvalues.h" #include "prims.h" CAMLprim value caml_static_alloc(value size) { return (value) caml_stat_alloc((asize_t) Long_val(size)); } CAMLprim value caml_static_free(value blk) { caml_stat_free((void *) blk); return Val_unit; } /* signal to the interpreter machinery that a bytecode is no more needed (before freeing it) - this might be useful for a JIT implementation */ CAMLprim value caml_static_release_bytecode(value blk, value size) { #ifndef NATIVE_CODE caml_release_bytecode((code_t) blk, (asize_t) Long_val(size)); #else caml_failwith("Meta.static_release_bytecode impossible with native code"); #endif return Val_unit; } CAMLprim value caml_static_resize(value blk, value new_size) { return (value) caml_stat_resize((char *) blk, (asize_t) Long_val(new_size)); } CAMLprim value caml_obj_is_block(value arg) { return Val_bool(Is_block(arg)); } CAMLprim value caml_obj_tag(value arg) { if (Is_long (arg)){ return Val_int (1000); /* int_tag */ }else if ((long) arg & (sizeof (value) - 1)){ return Val_int (1002); /* unaligned_tag */ }else if (Is_in_value_area (arg)){ return Val_int(Tag_val(arg)); }else{ return Val_int (1001); /* out_of_heap_tag */ } } CAMLprim value caml_obj_set_tag (value arg, value new_tag) { Tag_val (arg) = Int_val (new_tag); return Val_unit; } CAMLprim value caml_obj_block(value tag, value size) { value res; mlsize_t sz, i; tag_t tg; sz = Long_val(size); tg = Long_val(tag); if (sz == 0) return Atom(tg); res = caml_alloc(sz, tg); for (i = 0; i < sz; i++) Field(res, i) = Val_long(0); return res; } CAMLprim value caml_obj_dup(value arg) { CAMLparam1 (arg); CAMLlocal1 (res); mlsize_t sz, i; tag_t tg; sz = Wosize_val(arg); if (sz == 0) CAMLreturn (arg); tg = Tag_val(arg); if (tg >= No_scan_tag) { res = caml_alloc(sz, tg); memcpy(Bp_val(res), Bp_val(arg), sz * sizeof(value)); } else if (sz <= Max_young_wosize) { res = caml_alloc_small(sz, tg); for (i = 0; i < sz; i++) Field(res, i) = Field(arg, i); } else { res = caml_alloc_shr(sz, tg); for (i = 0; i < sz; i++) caml_initialize(&Field(res, i), Field(arg, i)); } CAMLreturn (res); } /* Shorten the given block to the given size and return void. Raise Invalid_argument if the given size is less than or equal to 0 or greater than the current size. algorithm: Change the length field of the header. Make up a white object with the leftover part of the object: this is needed in the major heap and harmless in the minor heap. */ CAMLprim value caml_obj_truncate (value v, value newsize) { mlsize_t new_wosize = Long_val (newsize); header_t hd = Hd_val (v); tag_t tag = Tag_hd (hd); color_t color = Color_hd (hd); mlsize_t wosize = Wosize_hd (hd); mlsize_t i; if (tag == Double_array_tag) new_wosize *= Double_wosize; /* PR#156 */ if (new_wosize <= 0 || new_wosize > wosize){ caml_invalid_argument ("Obj.truncate"); } if (new_wosize == wosize) return Val_unit; /* PR#61: since we're about to lose our references to the elements beyond new_wosize in v, erase them explicitly so that the GC can darken them as appropriate. */ if (tag < No_scan_tag) { for (i = new_wosize; i < wosize; i++){ caml_modify(&Field(v, i), Val_unit); #ifdef DEBUG Field (v, i) = Debug_free_truncate; #endif } } /* We must use an odd tag for the header of the leftovers so it does not look like a pointer because there may be some references to it in ref_table. */ Field (v, new_wosize) = Make_header (Wosize_whsize (wosize-new_wosize), 1, Caml_white); Hd_val (v) = Make_header (new_wosize, tag, color); return Val_unit; } CAMLprim value caml_obj_add_offset (value v, value offset) { return v + (unsigned long) Int32_val (offset); } /* The following functions are used in stdlib/lazy.ml. They are not written in OCaml because they must be atomic with respect to the GC. */ CAMLprim value caml_lazy_follow_forward (value v) { if (Is_block (v) && Is_in_value_area(v) && Tag_val (v) == Forward_tag){ return Forward_val (v); }else{ return v; } } CAMLprim value caml_lazy_make_forward (value v) { CAMLparam1 (v); CAMLlocal1 (res); res = caml_alloc_small (1, Forward_tag); Field (res, 0) = v; CAMLreturn (res); } /* For mlvalues.h and camlinternalOO.ml See also GETPUBMET in interp.c */ CAMLprim value caml_get_public_method (value obj, value tag) { value meths = Field (obj, 0); int li = 3, hi = Field(meths,0), mi; while (li < hi) { mi = ((li+hi) >> 1) | 1; if (tag < Field(meths,mi)) hi = mi-2; else li = mi; } /* return 0 if tag is not there */ return (tag == Field(meths,li) ? Field (meths, li-1) : 0); } /* these two functions might be useful to an hypothetical JIT */ #ifdef CAML_JIT #ifdef NATIVE_CODE #define MARK 1 #else #define MARK 0 #endif value caml_cache_public_method (value meths, value tag, value *cache) { int li = 3, hi = Field(meths,0), mi; while (li < hi) { mi = ((li+hi) >> 1) | 1; if (tag < Field(meths,mi)) hi = mi-2; else li = mi; } *cache = (li-3)*sizeof(value) + MARK; return Field (meths, li-1); } value caml_cache_public_method2 (value *meths, value tag, value *cache) { value ofs = *cache & meths[1]; if (*(value*)(((char*)(meths+3)) + ofs - MARK) == tag) return *(value*)(((char*)(meths+2)) + ofs - MARK); { int li = 3, hi = meths[0], mi; while (li < hi) { mi = ((li+hi) >> 1) | 1; if (tag < meths[mi]) hi = mi-2; else li = mi; } *cache = (li-3)*sizeof(value) + MARK; return meths[li-1]; } } #endif /*CAML_JIT*/ mingw-ocaml/ocaml/byterun/callback.c0000644000175000017500000001550612124403240017054 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Callbacks from C to OCaml */ #include #include "callback.h" #include "fail.h" #include "memory.h" #include "mlvalues.h" #ifndef NATIVE_CODE /* Bytecode callbacks */ #include "interp.h" #include "instruct.h" #include "fix_code.h" #include "stacks.h" CAMLexport int caml_callback_depth = 0; #ifndef LOCAL_CALLBACK_BYTECODE static opcode_t callback_code[] = { ACC, 0, APPLY, 0, POP, 1, STOP }; #endif #ifdef THREADED_CODE static int callback_code_threaded = 0; static void thread_callback(void) { caml_thread_code(callback_code, sizeof(callback_code)); callback_code_threaded = 1; } #define Init_callback() if (!callback_code_threaded) thread_callback() #else #define Init_callback() #endif CAMLexport value caml_callbackN_exn(value closure, int narg, value args[]) { int i; value res; /* some alternate bytecode implementations (e.g. a JIT translator) might require that the bytecode is kept in a local variable on the C stack */ #ifdef LOCAL_CALLBACK_BYTECODE opcode_t local_callback_code[7]; #endif Assert(narg + 4 <= 256); caml_extern_sp -= narg + 4; for (i = 0; i < narg; i++) caml_extern_sp[i] = args[i]; /* arguments */ #ifndef LOCAL_CALLBACK_BYTECODE caml_extern_sp[narg] = (value) (callback_code + 4); /* return address */ caml_extern_sp[narg + 1] = Val_unit; /* environment */ caml_extern_sp[narg + 2] = Val_long(0); /* extra args */ caml_extern_sp[narg + 3] = closure; Init_callback(); callback_code[1] = narg + 3; callback_code[3] = narg; res = caml_interprete(callback_code, sizeof(callback_code)); #else /*have LOCAL_CALLBACK_BYTECODE*/ caml_extern_sp[narg] = (value) (local_callback_code + 4); /* return address */ caml_extern_sp[narg + 1] = Val_unit; /* environment */ caml_extern_sp[narg + 2] = Val_long(0); /* extra args */ caml_extern_sp[narg + 3] = closure; local_callback_code[0] = ACC; local_callback_code[1] = narg + 3; local_callback_code[2] = APPLY; local_callback_code[3] = narg; local_callback_code[4] = POP; local_callback_code[5] = 1; local_callback_code[6] = STOP; #ifdef THREADED_CODE caml_thread_code(local_callback_code, sizeof(local_callback_code)); #endif /*THREADED_CODE*/ res = caml_interprete(local_callback_code, sizeof(local_callback_code)); caml_release_bytecode(local_callback_code, sizeof(local_callback_code)); #endif /*LOCAL_CALLBACK_BYTECODE*/ if (Is_exception_result(res)) caml_extern_sp += narg + 4; /* PR#1228 */ return res; } CAMLexport value caml_callback_exn(value closure, value arg1) { value arg[1]; arg[0] = arg1; return caml_callbackN_exn(closure, 1, arg); } CAMLexport value caml_callback2_exn(value closure, value arg1, value arg2) { value arg[2]; arg[0] = arg1; arg[1] = arg2; return caml_callbackN_exn(closure, 2, arg); } CAMLexport value caml_callback3_exn(value closure, value arg1, value arg2, value arg3) { value arg[3]; arg[0] = arg1; arg[1] = arg2; arg[2] = arg3; return caml_callbackN_exn(closure, 3, arg); } #else /* Native-code callbacks. caml_callback[123]_exn are implemented in asm. */ CAMLexport value caml_callbackN_exn(value closure, int narg, value args[]) { CAMLparam1 (closure); CAMLxparamN (args, narg); CAMLlocal1 (res); int i; res = closure; for (i = 0; i < narg; /*nothing*/) { /* Pass as many arguments as possible */ switch (narg - i) { case 1: res = caml_callback_exn(res, args[i]); if (Is_exception_result(res)) CAMLreturn (res); i += 1; break; case 2: res = caml_callback2_exn(res, args[i], args[i + 1]); if (Is_exception_result(res)) CAMLreturn (res); i += 2; break; default: res = caml_callback3_exn(res, args[i], args[i + 1], args[i + 2]); if (Is_exception_result(res)) CAMLreturn (res); i += 3; break; } } CAMLreturn (res); } #endif /* Exception-propagating variants of the above */ CAMLexport value caml_callback (value closure, value arg) { value res = caml_callback_exn(closure, arg); if (Is_exception_result(res)) caml_raise(Extract_exception(res)); return res; } CAMLexport value caml_callback2 (value closure, value arg1, value arg2) { value res = caml_callback2_exn(closure, arg1, arg2); if (Is_exception_result(res)) caml_raise(Extract_exception(res)); return res; } CAMLexport value caml_callback3 (value closure, value arg1, value arg2, value arg3) { value res = caml_callback3_exn(closure, arg1, arg2, arg3); if (Is_exception_result(res)) caml_raise(Extract_exception(res)); return res; } CAMLexport value caml_callbackN (value closure, int narg, value args[]) { value res = caml_callbackN_exn(closure, narg, args); if (Is_exception_result(res)) caml_raise(Extract_exception(res)); return res; } /* Naming of OCaml values */ struct named_value { value val; struct named_value * next; char name[1]; }; #define Named_value_size 13 static struct named_value * named_value_table[Named_value_size] = { NULL, }; static unsigned int hash_value_name(char const *name) { unsigned int h; for (h = 0; *name != 0; name++) h = h * 19 + *name; return h % Named_value_size; } CAMLprim value caml_register_named_value(value vname, value val) { struct named_value * nv; char * name = String_val(vname); unsigned int h = hash_value_name(name); for (nv = named_value_table[h]; nv != NULL; nv = nv->next) { if (strcmp(name, nv->name) == 0) { nv->val = val; return Val_unit; } } nv = (struct named_value *) caml_stat_alloc(sizeof(struct named_value) + strlen(name)); strcpy(nv->name, name); nv->val = val; nv->next = named_value_table[h]; named_value_table[h] = nv; caml_register_global_root(&nv->val); return Val_unit; } CAMLexport value * caml_named_value(char const *name) { struct named_value * nv; for (nv = named_value_table[hash_value_name(name)]; nv != NULL; nv = nv->next) { if (strcmp(name, nv->name) == 0) return &nv->val; } return NULL; } mingw-ocaml/ocaml/byterun/custom.c0000644000175000017500000000677412124403240016641 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ /* */ /* Copyright 2000 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "alloc.h" #include "custom.h" #include "fail.h" #include "memory.h" #include "mlvalues.h" CAMLexport value caml_alloc_custom(struct custom_operations * ops, uintnat size, mlsize_t mem, mlsize_t max) { mlsize_t wosize; value result; wosize = 1 + (size + sizeof(value) - 1) / sizeof(value); if (ops->finalize == NULL && wosize <= Max_young_wosize) { result = caml_alloc_small(wosize, Custom_tag); Custom_ops_val(result) = ops; } else { result = caml_alloc_shr(wosize, Custom_tag); Custom_ops_val(result) = ops; caml_adjust_gc_speed(mem, max); result = caml_check_urgent_gc(result); } return result; } struct custom_operations_list { struct custom_operations * ops; struct custom_operations_list * next; }; static struct custom_operations_list * custom_ops_table = NULL; CAMLexport void caml_register_custom_operations(struct custom_operations * ops) { struct custom_operations_list * l = caml_stat_alloc(sizeof(struct custom_operations_list)); Assert(ops->identifier != NULL); Assert(ops->deserialize != NULL); l->ops = ops; l->next = custom_ops_table; custom_ops_table = l; } struct custom_operations * caml_find_custom_operations(char * ident) { struct custom_operations_list * l; for (l = custom_ops_table; l != NULL; l = l->next) if (strcmp(l->ops->identifier, ident) == 0) return l->ops; return NULL; } static struct custom_operations_list * custom_ops_final_table = NULL; struct custom_operations * caml_final_custom_operations(final_fun fn) { struct custom_operations_list * l; struct custom_operations * ops; for (l = custom_ops_final_table; l != NULL; l = l->next) if (l->ops->finalize == fn) return l->ops; ops = caml_stat_alloc(sizeof(struct custom_operations)); ops->identifier = "_final"; ops->finalize = fn; ops->compare = custom_compare_default; ops->hash = custom_hash_default; ops->serialize = custom_serialize_default; ops->deserialize = custom_deserialize_default; ops->compare_ext = custom_compare_ext_default; l = caml_stat_alloc(sizeof(struct custom_operations_list)); l->ops = ops; l->next = custom_ops_final_table; custom_ops_final_table = l; return ops; } extern struct custom_operations caml_int32_ops, caml_nativeint_ops, caml_int64_ops; void caml_init_custom_operations(void) { caml_register_custom_operations(&caml_int32_ops); caml_register_custom_operations(&caml_nativeint_ops); caml_register_custom_operations(&caml_int64_ops); } mingw-ocaml/ocaml/byterun/gc_ctrl.c0000644000175000017500000003756412124403240016745 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "alloc.h" #include "compact.h" #include "custom.h" #include "finalise.h" #include "freelist.h" #include "gc.h" #include "gc_ctrl.h" #include "major_gc.h" #include "minor_gc.h" #include "misc.h" #include "mlvalues.h" #ifdef NATIVE_CODE #include "stack.h" #else #include "stacks.h" #endif #ifndef NATIVE_CODE extern uintnat caml_max_stack_size; /* defined in stacks.c */ #endif double caml_stat_minor_words = 0.0, caml_stat_promoted_words = 0.0, caml_stat_major_words = 0.0; intnat caml_stat_minor_collections = 0, caml_stat_major_collections = 0, caml_stat_heap_size = 0, /* bytes */ caml_stat_top_heap_size = 0, /* bytes */ caml_stat_compactions = 0, caml_stat_heap_chunks = 0; extern uintnat caml_major_heap_increment; /* bytes; see major_gc.c */ extern uintnat caml_percent_free; /* see major_gc.c */ extern uintnat caml_percent_max; /* see compact.c */ extern uintnat caml_allocation_policy; /* see freelist.c */ #define Next(hp) ((hp) + Bhsize_hp (hp)) #ifdef DEBUG /* Check that [v]'s header looks good. [v] must be a block in the heap. */ static void check_head (value v) { Assert (Is_block (v)); Assert (Is_in_heap (v)); Assert (Wosize_val (v) != 0); Assert (Color_hd (Hd_val (v)) != Caml_blue); Assert (Is_in_heap (v)); if (Tag_val (v) == Infix_tag){ int offset = Wsize_bsize (Infix_offset_val (v)); value trueval = Val_op (&Field (v, -offset)); Assert (Tag_val (trueval) == Closure_tag); Assert (Wosize_val (trueval) > offset); Assert (Is_in_heap (&Field (trueval, Wosize_val (trueval) - 1))); }else{ Assert (Is_in_heap (&Field (v, Wosize_val (v) - 1))); } if (Tag_val (v) == Double_tag){ Assert (Wosize_val (v) == Double_wosize); }else if (Tag_val (v) == Double_array_tag){ Assert (Wosize_val (v) % Double_wosize == 0); } } static void check_block (char *hp) { mlsize_t i; value v = Val_hp (hp); value f; check_head (v); switch (Tag_hp (hp)){ case Abstract_tag: break; case String_tag: break; case Double_tag: Assert (Wosize_val (v) == Double_wosize); break; case Double_array_tag: Assert (Wosize_val (v) % Double_wosize == 0); break; case Custom_tag: Assert (!Is_in_heap (Custom_ops_val (v))); break; case Infix_tag: Assert (0); break; default: Assert (Tag_hp (hp) < No_scan_tag); for (i = 0; i < Wosize_hp (hp); i++){ f = Field (v, i); if (Is_block (f) && Is_in_heap (f)){ check_head (f); Assert (Color_val (f) != Caml_blue); } } } } #endif /* DEBUG */ /* Check the heap structure (if compiled in debug mode) and gather statistics; return the stats if [returnstats] is true, otherwise return [Val_unit]. */ static value heap_stats (int returnstats) { CAMLparam0 (); intnat live_words = 0, live_blocks = 0, free_words = 0, free_blocks = 0, largest_free = 0, fragments = 0, heap_chunks = 0; char *chunk = caml_heap_start, *chunk_end; char *cur_hp, *prev_hp; header_t cur_hd; #ifdef DEBUG caml_gc_message (-1, "### OCaml runtime: heap check ###\n", 0); #endif while (chunk != NULL){ ++ heap_chunks; chunk_end = chunk + Chunk_size (chunk); prev_hp = NULL; cur_hp = chunk; while (cur_hp < chunk_end){ cur_hd = Hd_hp (cur_hp); Assert (Next (cur_hp) <= chunk_end); switch (Color_hd (cur_hd)){ case Caml_white: if (Wosize_hd (cur_hd) == 0){ ++ fragments; Assert (prev_hp == NULL || Color_hp (prev_hp) != Caml_blue || cur_hp == caml_gc_sweep_hp); }else{ if (caml_gc_phase == Phase_sweep && cur_hp >= caml_gc_sweep_hp){ ++ free_blocks; free_words += Whsize_hd (cur_hd); if (Whsize_hd (cur_hd) > largest_free){ largest_free = Whsize_hd (cur_hd); } }else{ ++ live_blocks; live_words += Whsize_hd (cur_hd); #ifdef DEBUG check_block (cur_hp); #endif } } break; case Caml_gray: case Caml_black: Assert (Wosize_hd (cur_hd) > 0); ++ live_blocks; live_words += Whsize_hd (cur_hd); #ifdef DEBUG check_block (cur_hp); #endif break; case Caml_blue: Assert (Wosize_hd (cur_hd) > 0); ++ free_blocks; free_words += Whsize_hd (cur_hd); if (Whsize_hd (cur_hd) > largest_free){ largest_free = Whsize_hd (cur_hd); } /* not true any more with big heap chunks Assert (prev_hp == NULL || (Color_hp (prev_hp) != Caml_blue && Wosize_hp (prev_hp) > 0) || cur_hp == caml_gc_sweep_hp); Assert (Next (cur_hp) == chunk_end || (Color_hp (Next (cur_hp)) != Caml_blue && Wosize_hp (Next (cur_hp)) > 0) || (Whsize_hd (cur_hd) + Wosize_hp (Next (cur_hp)) > Max_wosize) || Next (cur_hp) == caml_gc_sweep_hp); */ break; } prev_hp = cur_hp; cur_hp = Next (cur_hp); } Assert (cur_hp == chunk_end); chunk = Chunk_next (chunk); } Assert (heap_chunks == caml_stat_heap_chunks); Assert (live_words + free_words + fragments == Wsize_bsize (caml_stat_heap_size)); if (returnstats){ CAMLlocal1 (res); /* get a copy of these before allocating anything... */ double minwords = caml_stat_minor_words + (double) Wsize_bsize (caml_young_end - caml_young_ptr); double prowords = caml_stat_promoted_words; double majwords = caml_stat_major_words + (double) caml_allocated_words; intnat mincoll = caml_stat_minor_collections; intnat majcoll = caml_stat_major_collections; intnat heap_words = Wsize_bsize (caml_stat_heap_size); intnat cpct = caml_stat_compactions; intnat top_heap_words = Wsize_bsize (caml_stat_top_heap_size); res = caml_alloc_tuple (16); Store_field (res, 0, caml_copy_double (minwords)); Store_field (res, 1, caml_copy_double (prowords)); Store_field (res, 2, caml_copy_double (majwords)); Store_field (res, 3, Val_long (mincoll)); Store_field (res, 4, Val_long (majcoll)); Store_field (res, 5, Val_long (heap_words)); Store_field (res, 6, Val_long (heap_chunks)); Store_field (res, 7, Val_long (live_words)); Store_field (res, 8, Val_long (live_blocks)); Store_field (res, 9, Val_long (free_words)); Store_field (res, 10, Val_long (free_blocks)); Store_field (res, 11, Val_long (largest_free)); Store_field (res, 12, Val_long (fragments)); Store_field (res, 13, Val_long (cpct)); Store_field (res, 14, Val_long (top_heap_words)); Store_field (res, 15, Val_long (caml_stack_usage())); CAMLreturn (res); }else{ CAMLreturn (Val_unit); } } #ifdef DEBUG void caml_heap_check (void) { heap_stats (0); } #endif CAMLprim value caml_gc_stat(value v) { Assert (v == Val_unit); return heap_stats (1); } CAMLprim value caml_gc_quick_stat(value v) { CAMLparam0 (); CAMLlocal1 (res); /* get a copy of these before allocating anything... */ double minwords = caml_stat_minor_words + (double) Wsize_bsize (caml_young_end - caml_young_ptr); double prowords = caml_stat_promoted_words; double majwords = caml_stat_major_words + (double) caml_allocated_words; intnat mincoll = caml_stat_minor_collections; intnat majcoll = caml_stat_major_collections; intnat heap_words = caml_stat_heap_size / sizeof (value); intnat top_heap_words = caml_stat_top_heap_size / sizeof (value); intnat cpct = caml_stat_compactions; intnat heap_chunks = caml_stat_heap_chunks; res = caml_alloc_tuple (16); Store_field (res, 0, caml_copy_double (minwords)); Store_field (res, 1, caml_copy_double (prowords)); Store_field (res, 2, caml_copy_double (majwords)); Store_field (res, 3, Val_long (mincoll)); Store_field (res, 4, Val_long (majcoll)); Store_field (res, 5, Val_long (heap_words)); Store_field (res, 6, Val_long (heap_chunks)); Store_field (res, 7, Val_long (0)); Store_field (res, 8, Val_long (0)); Store_field (res, 9, Val_long (0)); Store_field (res, 10, Val_long (0)); Store_field (res, 11, Val_long (0)); Store_field (res, 12, Val_long (0)); Store_field (res, 13, Val_long (cpct)); Store_field (res, 14, Val_long (top_heap_words)); Store_field (res, 15, Val_long (caml_stack_usage())); CAMLreturn (res); } CAMLprim value caml_gc_counters(value v) { CAMLparam0 (); /* v is ignored */ CAMLlocal1 (res); /* get a copy of these before allocating anything... */ double minwords = caml_stat_minor_words + (double) Wsize_bsize (caml_young_end - caml_young_ptr); double prowords = caml_stat_promoted_words; double majwords = caml_stat_major_words + (double) caml_allocated_words; res = caml_alloc_tuple (3); Store_field (res, 0, caml_copy_double (minwords)); Store_field (res, 1, caml_copy_double (prowords)); Store_field (res, 2, caml_copy_double (majwords)); CAMLreturn (res); } CAMLprim value caml_gc_get(value v) { CAMLparam0 (); /* v is ignored */ CAMLlocal1 (res); res = caml_alloc_tuple (7); Store_field (res, 0, Val_long (Wsize_bsize (caml_minor_heap_size))); /* s */ Store_field (res, 1,Val_long(Wsize_bsize(caml_major_heap_increment)));/* i */ Store_field (res, 2, Val_long (caml_percent_free)); /* o */ Store_field (res, 3, Val_long (caml_verb_gc)); /* v */ Store_field (res, 4, Val_long (caml_percent_max)); /* O */ #ifndef NATIVE_CODE Store_field (res, 5, Val_long (caml_max_stack_size)); /* l */ #else Store_field (res, 5, Val_long (0)); #endif Store_field (res, 6, Val_long (caml_allocation_policy)); /* a */ CAMLreturn (res); } #define Max(x,y) ((x) < (y) ? (y) : (x)) static uintnat norm_pfree (uintnat p) { return Max (p, 1); } static uintnat norm_pmax (uintnat p) { return p; } static intnat norm_heapincr (uintnat i) { #define Psv (Wsize_bsize (Page_size)) i = ((i + Psv - 1) / Psv) * Psv; if (i < Heap_chunk_min) i = Heap_chunk_min; return i; } static intnat norm_minsize (intnat s) { if (s < Minor_heap_min) s = Minor_heap_min; if (s > Minor_heap_max) s = Minor_heap_max; return s; } CAMLprim value caml_gc_set(value v) { uintnat newpf, newpm; asize_t newheapincr; asize_t newminsize; uintnat oldpolicy; caml_verb_gc = Long_val (Field (v, 3)); #ifndef NATIVE_CODE caml_change_max_stack_size (Long_val (Field (v, 5))); #endif newpf = norm_pfree (Long_val (Field (v, 2))); if (newpf != caml_percent_free){ caml_percent_free = newpf; caml_gc_message (0x20, "New space overhead: %d%%\n", caml_percent_free); } newpm = norm_pmax (Long_val (Field (v, 4))); if (newpm != caml_percent_max){ caml_percent_max = newpm; caml_gc_message (0x20, "New max overhead: %d%%\n", caml_percent_max); } newheapincr = Bsize_wsize (norm_heapincr (Long_val (Field (v, 1)))); if (newheapincr != caml_major_heap_increment){ caml_major_heap_increment = newheapincr; caml_gc_message (0x20, "New heap increment size: %luk bytes\n", caml_major_heap_increment/1024); } oldpolicy = caml_allocation_policy; caml_set_allocation_policy (Long_val (Field (v, 6))); if (oldpolicy != caml_allocation_policy){ caml_gc_message (0x20, "New allocation policy: %d\n", caml_allocation_policy); } /* Minor heap size comes last because it will trigger a minor collection (thus invalidating [v]) and it can raise [Out_of_memory]. */ newminsize = norm_minsize (Bsize_wsize (Long_val (Field (v, 0)))); if (newminsize != caml_minor_heap_size){ caml_gc_message (0x20, "New minor heap size: %luk bytes\n", newminsize/1024); caml_set_minor_heap_size (newminsize); } return Val_unit; } CAMLprim value caml_gc_minor(value v) { Assert (v == Val_unit); caml_minor_collection (); return Val_unit; } static void test_and_compact (void) { float fp; fp = 100.0 * caml_fl_cur_size / (Wsize_bsize (caml_stat_heap_size) - caml_fl_cur_size); if (fp > 999999.0) fp = 999999.0; caml_gc_message (0x200, "Estimated overhead (lower bound) = %" ARCH_INTNAT_PRINTF_FORMAT "u%%\n", (uintnat) fp); if (fp >= caml_percent_max && caml_stat_heap_chunks > 1){ caml_gc_message (0x200, "Automatic compaction triggered.\n", 0); caml_compact_heap (); } } CAMLprim value caml_gc_major(value v) { Assert (v == Val_unit); caml_gc_message (0x1, "Major GC cycle requested\n", 0); caml_empty_minor_heap (); caml_finish_major_cycle (); test_and_compact (); caml_final_do_calls (); return Val_unit; } CAMLprim value caml_gc_full_major(value v) { Assert (v == Val_unit); caml_gc_message (0x1, "Full major GC cycle requested\n", 0); caml_empty_minor_heap (); caml_finish_major_cycle (); caml_final_do_calls (); caml_empty_minor_heap (); caml_finish_major_cycle (); test_and_compact (); caml_final_do_calls (); return Val_unit; } CAMLprim value caml_gc_major_slice (value v) { Assert (Is_long (v)); caml_empty_minor_heap (); return Val_long (caml_major_collection_slice (Long_val (v))); } CAMLprim value caml_gc_compaction(value v) { Assert (v == Val_unit); caml_gc_message (0x10, "Heap compaction requested\n", 0); caml_empty_minor_heap (); caml_finish_major_cycle (); caml_final_do_calls (); caml_empty_minor_heap (); caml_finish_major_cycle (); caml_compact_heap (); caml_final_do_calls (); return Val_unit; } void caml_init_gc (uintnat minor_size, uintnat major_size, uintnat major_incr, uintnat percent_fr, uintnat percent_m) { uintnat major_heap_size = Bsize_wsize (norm_heapincr (major_size)); if (caml_page_table_initialize(Bsize_wsize(minor_size) + major_heap_size)){ caml_fatal_error ("OCaml runtime error: cannot initialize page table\n"); } caml_set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size))); caml_major_heap_increment = Bsize_wsize (norm_heapincr (major_incr)); caml_percent_free = norm_pfree (percent_fr); caml_percent_max = norm_pmax (percent_m); caml_init_major_heap (major_heap_size); caml_gc_message (0x20, "Initial minor heap size: %luk bytes\n", caml_minor_heap_size / 1024); caml_gc_message (0x20, "Initial major heap size: %luk bytes\n", major_heap_size / 1024); caml_gc_message (0x20, "Initial space overhead: %lu%%\n", caml_percent_free); caml_gc_message (0x20, "Initial max overhead: %lu%%\n", caml_percent_max); caml_gc_message (0x20, "Initial heap increment: %luk bytes\n", caml_major_heap_increment / 1024); caml_gc_message (0x20, "Initial allocation policy: %d\n", caml_allocation_policy); } mingw-ocaml/ocaml/byterun/Makefile.nt0000644000175000017500000000411412124403240017225 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### # $Id$ include Makefile.common CFLAGS=-DOCAML_STDLIB_DIR='"$(LIBDIR)"' $(IFLEXDIR) DBGO=d.$(O) OBJS=$(COMMONOBJS:.o=.$(O)) win32.$(O) main.$(O) DOBJS=$(OBJS:.$(O)=.$(DBGO)) instrtrace.$(DBGO) ocamlrun$(EXE): libcamlrun.$(A) prims.$(O) $(MKEXE) -o ocamlrun$(EXE) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrun.$(A) ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O) $(MKEXE) -o ocamlrun$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrund.$(A) libcamlrun.$(A): $(OBJS) $(call MKLIB,libcamlrun.$(A),$(OBJS)) libcamlrund.$(A): $(DOBJS) $(call MKLIB,libcamlrund.$(A),$(DOBJS)) .SUFFIXES: .$(O) .$(DBGO) .c.$(O): $(CC) $(CFLAGS) $(BYTECCCOMPOPTS) -c $< .c.$(DBGO): $(CC) $(CFLAGS) $(BYTECCDBGCOMPOPTS) -c $< mv $*.$(O) $*.$(DBGO) .depend.nt: .depend rm -f .depend.win32 echo "win32.o: win32.c fail.h compatibility.h misc.h config.h \\" >> .depend.win32 echo " ../config/m.h ../config/s.h mlvalues.h memory.h gc.h \\" >> .depend.win32 echo " major_gc.h freelist.h minor_gc.h osdeps.h signals.h" >> .depend.win32 cat .depend >> .depend.win32 sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(O) \1.$$(DBGO):/' .depend.win32 > .depend.nt rm -f .depend.win32 include .depend.nt mingw-ocaml/ocaml/byterun/int64_format.h0000644000175000017500000000653712124403240017645 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* printf-like formatting of 64-bit integers, in case the C library printf() function does not support them. */ #ifndef CAML_INT64_FORMAT_H #define CAML_INT64_FORMAT_H static void I64_format(char * buffer, char * fmt, int64 x) { static char conv_lower[] = "0123456789abcdef"; static char conv_upper[] = "0123456789ABCDEF"; char rawbuffer[24]; char justify, signstyle, filler, alternate, signedconv; int base, width, sign, i, rawlen; char * cvtbl; char * p, * r; int64 wbase, digit; /* Parsing of format */ justify = '+'; signstyle = '-'; filler = ' '; alternate = 0; base = 0; signedconv = 0; width = 0; cvtbl = conv_lower; for (p = fmt; *p != 0; p++) { switch (*p) { case '-': justify = '-'; break; case '+': case ' ': signstyle = *p; break; case '0': filler = '0'; break; case '#': alternate = 1; break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': width = atoi(p); while (p[1] >= '0' && p[1] <= '9') p++; break; case 'd': case 'i': signedconv = 1; /* fallthrough */ case 'u': base = 10; break; case 'x': base = 16; break; case 'X': base = 16; cvtbl = conv_upper; break; case 'o': base = 8; break; } } if (base == 0) { buffer[0] = 0; return; } /* Do the conversion */ sign = 1; if (signedconv && I64_is_negative(x)) { sign = -1; x = I64_neg(x); } r = rawbuffer + sizeof(rawbuffer); wbase = I64_of_int32(base); do { I64_udivmod(x, wbase, &x, &digit); *--r = cvtbl[I64_to_int32(digit)]; } while (! I64_is_zero(x)); rawlen = rawbuffer + sizeof(rawbuffer) - r; /* Adjust rawlen to reflect additional chars (sign, etc) */ if (signedconv && (sign < 0 || signstyle != '-')) rawlen++; if (alternate) { if (base == 8) rawlen += 1; if (base == 16) rawlen += 2; } /* Do the formatting */ p = buffer; if (justify == '+' && filler == ' ') { for (i = rawlen; i < width; i++) *p++ = ' '; } if (signedconv) { if (sign < 0) *p++ = '-'; else if (signstyle != '-') *p++ = signstyle; } if (alternate && base == 8) *p++ = '0'; if (alternate && base == 16) { *p++ = '0'; *p++ = 'x'; } if (justify == '+' && filler == '0') { for (i = rawlen; i < width; i++) *p++ = '0'; } while (r < rawbuffer + sizeof(rawbuffer)) *p++ = *r++; if (justify == '-') { for (i = rawlen; i < width; i++) *p++ = ' '; } *p = 0; } #endif /* CAML_INT64_FORMAT_H */ mingw-ocaml/ocaml/byterun/str.c0000644000175000017500000001034012124403240016117 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Operations on strings */ #include #include #include "alloc.h" #include "fail.h" #include "mlvalues.h" #include "misc.h" #ifdef HAS_LOCALE #include #endif CAMLexport mlsize_t caml_string_length(value s) { mlsize_t temp; temp = Bosize_val(s) - 1; Assert (Byte (s, temp - Byte (s, temp)) == 0); return temp - Byte (s, temp); } CAMLprim value caml_ml_string_length(value s) { mlsize_t temp; temp = Bosize_val(s) - 1; Assert (Byte (s, temp - Byte (s, temp)) == 0); return Val_long(temp - Byte (s, temp)); } CAMLprim value caml_create_string(value len) { mlsize_t size = Long_val(len); if (size > Bsize_wsize (Max_wosize) - 1){ caml_invalid_argument("String.create"); } return caml_alloc_string(size); } CAMLprim value caml_string_get(value str, value index) { intnat idx = Long_val(index); if (idx < 0 || idx >= caml_string_length(str)) caml_array_bound_error(); return Val_int(Byte_u(str, idx)); } CAMLprim value caml_string_set(value str, value index, value newval) { intnat idx = Long_val(index); if (idx < 0 || idx >= caml_string_length(str)) caml_array_bound_error(); Byte_u(str, idx) = Int_val(newval); return Val_unit; } CAMLprim value caml_string_equal(value s1, value s2) { mlsize_t sz1, sz2; value * p1, * p2; if (s1 == s2) return Val_true; sz1 = Wosize_val(s1); sz2 = Wosize_val(s2); if (sz1 != sz2) return Val_false; for(p1 = Op_val(s1), p2 = Op_val(s2); sz1 > 0; sz1--, p1++, p2++) if (*p1 != *p2) return Val_false; return Val_true; } CAMLprim value caml_string_notequal(value s1, value s2) { return Val_not(caml_string_equal(s1, s2)); } CAMLprim value caml_string_compare(value s1, value s2) { mlsize_t len1, len2; int res; if (s1 == s2) return Val_int(0); len1 = caml_string_length(s1); len2 = caml_string_length(s2); res = memcmp(String_val(s1), String_val(s2), len1 <= len2 ? len1 : len2); if (res < 0) return Val_int(-1); if (res > 0) return Val_int(1); if (len1 < len2) return Val_int(-1); if (len1 > len2) return Val_int(1); return Val_int(0); } CAMLprim value caml_string_lessthan(value s1, value s2) { return caml_string_compare(s1, s2) < Val_int(0) ? Val_true : Val_false; } CAMLprim value caml_string_lessequal(value s1, value s2) { return caml_string_compare(s1, s2) <= Val_int(0) ? Val_true : Val_false; } CAMLprim value caml_string_greaterthan(value s1, value s2) { return caml_string_compare(s1, s2) > Val_int(0) ? Val_true : Val_false; } CAMLprim value caml_string_greaterequal(value s1, value s2) { return caml_string_compare(s1, s2) >= Val_int(0) ? Val_true : Val_false; } CAMLprim value caml_blit_string(value s1, value ofs1, value s2, value ofs2, value n) { memmove(&Byte(s2, Long_val(ofs2)), &Byte(s1, Long_val(ofs1)), Int_val(n)); return Val_unit; } CAMLprim value caml_fill_string(value s, value offset, value len, value init) { memset(&Byte(s, Long_val(offset)), Int_val(init), Long_val(len)); return Val_unit; } CAMLprim value caml_is_printable(value chr) { int c; #ifdef HAS_LOCALE static int locale_is_set = 0; if (! locale_is_set) { setlocale(LC_CTYPE, ""); locale_is_set = 1; } #endif c = Int_val(chr); return Val_bool(isprint(c)); } CAMLprim value caml_bitvect_test(value bv, value n) { int pos = Int_val(n); return Val_int(Byte_u(bv, pos >> 3) & (1 << (pos & 7))); } mingw-ocaml/ocaml/byterun/config.h0000644000175000017500000001227712124403240016574 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_CONFIG_H #define CAML_CONFIG_H /* */ /* */ /* */ #include "../config/m.h" #include "../config/s.h" /* */ #ifndef CAML_NAME_SPACE #include "compatibility.h" #endif /* Types for signed chars, 32-bit integers, 64-bit integers, native integers (as wide as a pointer type) */ typedef signed char schar; #if SIZEOF_PTR == SIZEOF_LONG /* Standard models: ILP32 or I32LP64 */ typedef long intnat; typedef unsigned long uintnat; #define ARCH_INTNAT_PRINTF_FORMAT "l" #elif SIZEOF_PTR == SIZEOF_INT /* Hypothetical IP32L64 model */ typedef int intnat; typedef unsigned int uintnat; #define ARCH_INTNAT_PRINTF_FORMAT "" #elif SIZEOF_PTR == 8 && defined(ARCH_INT64_TYPE) /* Win64 model: IL32LLP64 */ typedef ARCH_INT64_TYPE intnat; typedef ARCH_UINT64_TYPE uintnat; #define ARCH_INTNAT_PRINTF_FORMAT ARCH_INT64_PRINTF_FORMAT #else #error "No integer type available to represent pointers" #endif #if SIZEOF_INT == 4 typedef int int32; typedef unsigned int uint32; #define ARCH_INT32_PRINTF_FORMAT "" #elif SIZEOF_LONG == 4 typedef long int32; typedef unsigned long uint32; #define ARCH_INT32_PRINTF_FORMAT "l" #elif SIZEOF_SHORT == 4 typedef short int32; typedef unsigned short uint32; #define ARCH_INT32_PRINTF_FORMAT "" #else #error "No 32-bit integer type available" #endif #if defined(ARCH_INT64_TYPE) typedef ARCH_INT64_TYPE int64; typedef ARCH_UINT64_TYPE uint64; #else # ifdef ARCH_BIG_ENDIAN typedef struct { uint32 h, l; } uint64, int64; # else typedef struct { uint32 l, h; } uint64, int64; # endif #endif /* Endianness of floats */ /* ARCH_FLOAT_ENDIANNESS encodes the byte order of doubles as follows: the value [0xabcdefgh] means that the least significant byte of the float is at byte offset [a], the next lsb at [b], ..., and the most significant byte at [h]. */ #if defined(__arm__) && !defined(__ARM_EABI__) #define ARCH_FLOAT_ENDIANNESS 0x45670123 #elif defined(ARCH_BIG_ENDIAN) #define ARCH_FLOAT_ENDIANNESS 0x76543210 #else #define ARCH_FLOAT_ENDIANNESS 0x01234567 #endif /* We use threaded code interpretation if the compiler provides labels as first-class values (GCC 2.x). */ #if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) && !defined (SHRINKED_GNUC) && !defined(CAML_JIT) #define THREADED_CODE #endif /* Do not change this definition. */ #define Page_size (1 << Page_log) /* Memory model parameters */ /* The size of a page for memory management (in bytes) is [1 << Page_log]. It must be a multiple of [sizeof (value)] and >= 8 and <= 20. */ #define Page_log 12 /* A page is 4 kilobytes. */ /* Initial size of stack (bytes). */ #define Stack_size (4096 * sizeof(value)) /* Minimum free size of stack (bytes); below that, it is reallocated. */ #define Stack_threshold (256 * sizeof(value)) /* Default maximum size of the stack (words). */ #define Max_stack_def (1024 * 1024) /* Maximum size of a block allocated in the young generation (words). */ /* Must be > 4 */ #define Max_young_wosize 256 /* Minimum size of the minor zone (words). This must be at least [Max_young_wosize + 1]. */ #define Minor_heap_min 4096 /* Maximum size of the minor zone (words). Must be greater than or equal to [Minor_heap_min]. */ #define Minor_heap_max (1 << 28) /* Default size of the minor zone. (words) */ #define Minor_heap_def 262144 /* Minimum size increment when growing the heap (words). Must be a multiple of [Page_size / sizeof (value)]. */ #define Heap_chunk_min (2 * Page_size / sizeof (value)) /* Default size increment when growing the heap. (words) Must be a multiple of [Page_size / sizeof (value)]. (Approx 512 Kb for a 32-bit platform, 1 Mb for a 64-bit platform.) */ #define Heap_chunk_def (31 * Page_size) /* Default initial size of the major heap (words); same constraints as for Heap_chunk_def. */ #define Init_heap_def (31 * Page_size) /* Default speed setting for the major GC. The heap will grow until the dead objects and the free list represent this percentage of the total size of live objects. */ #define Percent_free_def 80 /* Default setting for the compacter: 500% (i.e. trigger the compacter when 5/6 of the heap is free or garbage) This can be set quite high because the overhead is over-estimated when fragmentation occurs. */ #define Max_percent_free_def 500 #endif /* CAML_CONFIG_H */ mingw-ocaml/ocaml/byterun/compact.c0000644000175000017500000004053212124403240016743 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "config.h" #include "finalise.h" #include "freelist.h" #include "gc.h" #include "gc_ctrl.h" #include "major_gc.h" #include "memory.h" #include "mlvalues.h" #include "roots.h" #include "weak.h" extern uintnat caml_percent_free; /* major_gc.c */ extern void caml_shrink_heap (char *); /* memory.c */ /* Encoded headers: the color is stored in the 2 least significant bits. (For pointer inversion, we need to distinguish headers from pointers.) s is a Wosize, t is a tag, and c is a color (a two-bit number) For the purpose of compaction, "colors" are: 0: pointers (direct or inverted) 1: integer or (unencoded) infix header 2: inverted pointer for infix header 3: integer or encoded (noninfix) header XXX Should be fixed: XXX The above assumes that all roots are aligned on a 4-byte boundary, XXX which is not always guaranteed by C. XXX (see [caml_register_global_roots] and [caml_init_exceptions]) XXX Should be able to fix it to only assume 2-byte alignment. */ #define Make_ehd(s,t,c) (((s) << 10) | (t) << 2 | (c)) #define Whsize_ehd(h) Whsize_hd (h) #define Wosize_ehd(h) Wosize_hd (h) #define Tag_ehd(h) (((h) >> 2) & 0xFF) #define Ecolor(w) ((w) & 3) typedef uintnat word; static void invert_pointer_at (word *p) { word q = *p; Assert (Ecolor ((intnat) p) == 0); /* Use Ecolor (q) == 0 instead of Is_block (q) because q could be an inverted pointer for an infix header (with Ecolor == 2). */ if (Ecolor (q) == 0 && (Classify_addr (q) & In_heap)){ switch (Ecolor (Hd_val (q))){ case 0: case 3: /* Pointer or header: insert in inverted list. */ *p = Hd_val (q); Hd_val (q) = (header_t) p; break; case 1: /* Infix header: make inverted infix list. */ /* Double inversion: the last of the inverted infix list points to the next infix header in this block. The last of the last list contains the original block header. */ { /* This block as a value. */ value val = (value) q - Infix_offset_val (q); /* Get the block header. */ word *hp = (word *) Hp_val (val); while (Ecolor (*hp) == 0) hp = (word *) *hp; Assert (Ecolor (*hp) == 3); if (Tag_ehd (*hp) == Closure_tag){ /* This is the first infix found in this block. */ /* Save original header. */ *p = *hp; /* Link inverted infix list. */ Hd_val (q) = (header_t) ((word) p | 2); /* Change block header's tag to Infix_tag, and change its size to point to the infix list. */ *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3); }else{ Assert (Tag_ehd (*hp) == Infix_tag); /* Point the last of this infix list to the current first infix list of the block. */ *p = (word) &Field (val, Wosize_ehd (*hp)) | 1; /* Point the head of this infix list to the above. */ Hd_val (q) = (header_t) ((word) p | 2); /* Change block header's size to point to this infix list. */ *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3); } } break; case 2: /* Inverted infix list: insert. */ *p = Hd_val (q); Hd_val (q) = (header_t) ((word) p | 2); break; } } } static void invert_root (value v, value *p) { invert_pointer_at ((word *) p); } static char *compact_fl; static void init_compact_allocate (void) { char *ch = caml_heap_start; while (ch != NULL){ Chunk_alloc (ch) = 0; ch = Chunk_next (ch); } compact_fl = caml_heap_start; } static char *compact_allocate (mlsize_t size) /* in bytes, including header */ { char *chunk, *adr; while (Chunk_size (compact_fl) - Chunk_alloc (compact_fl) <= Bhsize_wosize (3) && Chunk_size (Chunk_next (compact_fl)) - Chunk_alloc (Chunk_next (compact_fl)) <= Bhsize_wosize (3)){ compact_fl = Chunk_next (compact_fl); } chunk = compact_fl; while (Chunk_size (chunk) - Chunk_alloc (chunk) < size){ chunk = Chunk_next (chunk); Assert (chunk != NULL); } adr = chunk + Chunk_alloc (chunk); Chunk_alloc (chunk) += size; return adr; } static void do_compaction (void) { char *ch, *chend; Assert (caml_gc_phase == Phase_idle); caml_gc_message (0x10, "Compacting heap...\n", 0); #ifdef DEBUG caml_heap_check (); #endif /* First pass: encode all noninfix headers. */ { ch = caml_heap_start; while (ch != NULL){ header_t *p = (header_t *) ch; chend = ch + Chunk_size (ch); while ((char *) p < chend){ header_t hd = Hd_hp (p); mlsize_t sz = Wosize_hd (hd); if (Is_blue_hd (hd)){ /* Free object. Give it a string tag. */ Hd_hp (p) = Make_ehd (sz, String_tag, 3); }else{ Assert (Is_white_hd (hd)); /* Live object. Keep its tag. */ Hd_hp (p) = Make_ehd (sz, Tag_hd (hd), 3); } p += Whsize_wosize (sz); } ch = Chunk_next (ch); } } /* Second pass: invert pointers. Link infix headers in each block in an inverted list of inverted lists. Don't forget roots and weak pointers. */ { /* Invert roots first because the threads library needs some heap data structures to find its roots. Fortunately, it doesn't need the headers (see above). */ caml_do_roots (invert_root); caml_final_do_weak_roots (invert_root); ch = caml_heap_start; while (ch != NULL){ word *p = (word *) ch; chend = ch + Chunk_size (ch); while ((char *) p < chend){ word q = *p; size_t sz, i; tag_t t; word *infixes; while (Ecolor (q) == 0) q = * (word *) q; sz = Whsize_ehd (q); t = Tag_ehd (q); if (t == Infix_tag){ /* Get the original header of this block. */ infixes = p + sz; q = *infixes; while (Ecolor (q) != 3) q = * (word *) (q & ~(uintnat)3); sz = Whsize_ehd (q); t = Tag_ehd (q); } if (t < No_scan_tag){ for (i = 1; i < sz; i++) invert_pointer_at (&(p[i])); } p += sz; } ch = Chunk_next (ch); } /* Invert weak pointers. */ { value *pp = &caml_weak_list_head; value p; word q; size_t sz, i; while (1){ p = *pp; if (p == (value) NULL) break; q = Hd_val (p); while (Ecolor (q) == 0) q = * (word *) q; sz = Wosize_ehd (q); for (i = 1; i < sz; i++){ if (Field (p,i) != caml_weak_none){ invert_pointer_at ((word *) &(Field (p,i))); } } invert_pointer_at ((word *) pp); pp = &Field (p, 0); } } } /* Third pass: reallocate virtually; revert pointers; decode headers. Rebuild infix headers. */ { init_compact_allocate (); ch = caml_heap_start; while (ch != NULL){ word *p = (word *) ch; chend = ch + Chunk_size (ch); while ((char *) p < chend){ word q = *p; if (Ecolor (q) == 0 || Tag_ehd (q) == Infix_tag){ /* There were (normal or infix) pointers to this block. */ size_t sz; tag_t t; char *newadr; word *infixes = NULL; while (Ecolor (q) == 0) q = * (word *) q; sz = Whsize_ehd (q); t = Tag_ehd (q); if (t == Infix_tag){ /* Get the original header of this block. */ infixes = p + sz; q = *infixes; Assert (Ecolor (q) == 2); while (Ecolor (q) != 3) q = * (word *) (q & ~(uintnat)3); sz = Whsize_ehd (q); t = Tag_ehd (q); } newadr = compact_allocate (Bsize_wsize (sz)); q = *p; while (Ecolor (q) == 0){ word next = * (word *) q; * (word *) q = (word) Val_hp (newadr); q = next; } *p = Make_header (Wosize_whsize (sz), t, Caml_white); if (infixes != NULL){ /* Rebuild the infix headers and revert the infix pointers. */ while (Ecolor ((word) infixes) != 3){ infixes = (word *) ((word) infixes & ~(uintnat) 3); q = *infixes; while (Ecolor (q) == 2){ word next; q = (word) q & ~(uintnat) 3; next = * (word *) q; * (word *) q = (word) Val_hp ((word *) newadr + (infixes - p)); q = next; } Assert (Ecolor (q) == 1 || Ecolor (q) == 3); *infixes = Make_header (infixes - p, Infix_tag, Caml_white); infixes = (word *) q; } } p += sz; }else{ Assert (Ecolor (q) == 3); /* This is guaranteed only if caml_compact_heap was called after a nonincremental major GC: Assert (Tag_ehd (q) == String_tag); */ /* No pointers to the header and no infix header: the object was free. */ *p = Make_header (Wosize_ehd (q), Tag_ehd (q), Caml_blue); p += Whsize_ehd (q); } } ch = Chunk_next (ch); } } /* Fourth pass: reallocate and move objects. Use the exact same allocation algorithm as pass 3. */ { init_compact_allocate (); ch = caml_heap_start; while (ch != NULL){ word *p = (word *) ch; chend = ch + Chunk_size (ch); while ((char *) p < chend){ word q = *p; if (Color_hd (q) == Caml_white){ size_t sz = Bhsize_hd (q); char *newadr = compact_allocate (sz); memmove (newadr, p, sz); p += Wsize_bsize (sz); }else{ Assert (Color_hd (q) == Caml_blue); p += Whsize_hd (q); } } ch = Chunk_next (ch); } } /* Shrink the heap if needed. */ { /* Find the amount of live data and the unshrinkable free space. */ asize_t live = 0; asize_t free = 0; asize_t wanted; ch = caml_heap_start; while (ch != NULL){ if (Chunk_alloc (ch) != 0){ live += Wsize_bsize (Chunk_alloc (ch)); free += Wsize_bsize (Chunk_size (ch) - Chunk_alloc (ch)); } ch = Chunk_next (ch); } /* Add up the empty chunks until there are enough, then remove the other empty chunks. */ wanted = caml_percent_free * (live / 100 + 1); ch = caml_heap_start; while (ch != NULL){ char *next_chunk = Chunk_next (ch); /* Chunk_next (ch) will be erased */ if (Chunk_alloc (ch) == 0){ if (free < wanted){ free += Wsize_bsize (Chunk_size (ch)); }else{ caml_shrink_heap (ch); } } ch = next_chunk; } } /* Rebuild the free list. */ { ch = caml_heap_start; caml_fl_reset (); while (ch != NULL){ if (Chunk_size (ch) > Chunk_alloc (ch)){ caml_make_free_blocks ((value *) (ch + Chunk_alloc (ch)), Wsize_bsize (Chunk_size(ch)-Chunk_alloc(ch)), 1, Caml_white); } ch = Chunk_next (ch); } } ++ caml_stat_compactions; caml_gc_message (0x10, "done.\n", 0); } uintnat caml_percent_max; /* used in gc_ctrl.c and memory.c */ void caml_compact_heap (void) { uintnat target_words, target_size, live; do_compaction (); /* Compaction may fail to shrink the heap to a reasonable size because it deals in complete chunks: if a very large chunk is at the beginning of the heap, everything gets moved to it and it is not freed. In that case, we allocate a new chunk of the desired heap size, chain it at the beginning of the heap (thus pretending its address is smaller), and launch a second compaction. This will move all data to this new chunk and free the very large chunk. See PR#5389 */ /* We compute: freewords = caml_fl_cur_size (exact) heapwords = Wsize_bsize (caml_heap_size) (exact) live = heapwords - freewords wanted = caml_percent_free * (live / 100 + 1) (same as in do_compaction) target_words = live + wanted We add one page to make sure a small difference in counting sizes won't make [do_compaction] keep the second block (and break all sorts of invariants). We recompact if target_size < heap_size / 2 */ live = Wsize_bsize (caml_stat_heap_size) - caml_fl_cur_size; target_words = live + caml_percent_free * (live / 100 + 1) + Wsize_bsize (Page_size); target_size = caml_round_heap_chunk_size (Bsize_wsize (target_words)); if (target_size < caml_stat_heap_size / 2){ char *chunk; caml_gc_message (0x10, "Recompacting heap (target=%luk)\n", target_size / 1024); chunk = caml_alloc_for_heap (target_size); if (chunk == NULL) return; /* PR#5757: we need to make the new blocks blue, or they won't be recognized as free by the recompaction. */ caml_make_free_blocks ((value *) chunk, Wsize_bsize (Chunk_size (chunk)), 0, Caml_blue); if (caml_page_table_add (In_heap, chunk, chunk + Chunk_size (chunk)) != 0){ caml_free_for_heap (chunk); return; } Chunk_next (chunk) = caml_heap_start; caml_heap_start = chunk; ++ caml_stat_heap_chunks; caml_stat_heap_size += Chunk_size (chunk); if (caml_stat_heap_size > caml_stat_top_heap_size){ caml_stat_top_heap_size = caml_stat_heap_size; } do_compaction (); Assert (caml_stat_heap_chunks == 1); Assert (Chunk_next (caml_heap_start) == NULL); Assert (caml_stat_heap_size == Chunk_size (chunk)); } } void caml_compact_heap_maybe (void) { /* Estimated free words in the heap: FW = fl_size_at_change + 3 * (caml_fl_cur_size - caml_fl_size_at_phase_change) FW = 3 * caml_fl_cur_size - 2 * caml_fl_size_at_phase_change Estimated live words: LW = caml_stat_heap_size - FW Estimated free percentage: FP = 100 * FW / LW We compact the heap if FP > caml_percent_max */ float fw, fp; Assert (caml_gc_phase == Phase_idle); if (caml_percent_max >= 1000000) return; if (caml_stat_major_collections < 3) return; fw = 3.0 * caml_fl_cur_size - 2.0 * caml_fl_size_at_phase_change; if (fw < 0) fw = caml_fl_cur_size; if (fw >= Wsize_bsize (caml_stat_heap_size)){ fp = 1000000.0; }else{ fp = 100.0 * fw / (Wsize_bsize (caml_stat_heap_size) - fw); if (fp > 1000000.0) fp = 1000000.0; } caml_gc_message (0x200, "FL size at phase change = %" ARCH_INTNAT_PRINTF_FORMAT "u\n", (uintnat) caml_fl_size_at_phase_change); caml_gc_message (0x200, "Estimated overhead = %" ARCH_INTNAT_PRINTF_FORMAT "u%%\n", (uintnat) fp); if (fp >= caml_percent_max){ caml_gc_message (0x200, "Automatic compaction triggered.\n", 0); caml_finish_major_cycle (); /* We just did a complete GC, so we can measure the overhead exactly. */ fw = caml_fl_cur_size; fp = 100.0 * fw / (Wsize_bsize (caml_stat_heap_size) - fw); caml_gc_message (0x200, "Measured overhead: %" ARCH_INTNAT_PRINTF_FORMAT "u%%\n", (uintnat) fp); caml_compact_heap (); } } mingw-ocaml/ocaml/byterun/Makefile.common0000755000175000017500000000714412124403240020105 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### # $Id$ include ../config/Makefile CC=$(BYTECC) COMMONOBJS=\ interp.o misc.o stacks.o fix_code.o startup.o \ freelist.o major_gc.o minor_gc.o memory.o alloc.o roots.o globroots.o \ fail.o signals.o signals_byt.o printexc.o backtrace.o \ compare.o ints.o floats.o str.o array.o io.o extern.o intern.o \ hash.o sys.o meta.o parsing.o gc_ctrl.o terminfo.o md5.o obj.o \ lexing.o callback.o debugger.o weak.o compact.o finalise.o custom.o \ dynlink.o PRIMS=\ alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \ intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \ signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c \ dynlink.c backtrace.c PUBLIC_INCLUDES=\ alloc.h callback.h config.h custom.h fail.h hash.h intext.h \ memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A) all-$(RUNTIMED) .PHONY: all all-noruntimed: .PHONY: all-noruntimed all-runtimed: ocamlrund$(EXE) libcamlrund.$(A) .PHONY: all-runtimed ld.conf: ../config/Makefile echo "$(STUBLIBDIR)" > ld.conf echo "$(LIBDIR)" >> ld.conf install:: cp ocamlrun$(EXE) $(BINDIR)/ocamlrun$(EXE) cp libcamlrun.$(A) $(LIBDIR)/libcamlrun.$(A) cd $(LIBDIR); $(RANLIB) libcamlrun.$(A) if test -d $(LIBDIR)/caml; then : ; else mkdir $(LIBDIR)/caml; fi for i in $(PUBLIC_INCLUDES); do \ sed -f ../tools/cleanup-header $$i > $(LIBDIR)/caml/$$i; \ done cp ld.conf $(LIBDIR)/ld.conf .PHONY: install install:: install-$(RUNTIMED) install-noruntimed: .PHONY: install-noruntimed install-runtimed: cp ocamlrund$(EXE) $(BINDIR)/ocamlrund$(EXE) cp libcamlrund.$(A) $(LIBDIR)/libcamlrund.$(A) .PHONY: install-runtimed primitives : $(PRIMS) sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \ $(PRIMS) > primitives prims.c : primitives (echo '#include "mlvalues.h"'; \ echo '#include "prims.h"'; \ sed -e 's/.*/extern value &();/' primitives; \ echo 'c_primitive caml_builtin_cprim[] = {'; \ sed -e 's/.*/ &,/' primitives; \ echo ' 0 };'; \ echo 'char * caml_names_of_builtin_cprim[] = {'; \ sed -e 's/.*/ "&",/' primitives; \ echo ' 0 };') > prims.c opnames.h : instruct.h sed -e '/\/\*/d' \ -e '/^#/d' \ -e 's/enum /char * names_of_/' \ -e 's/{$$/[] = {/' \ -e 's/\([[:upper:]][[:upper:]_0-9]*\)/"\1"/g' instruct.h > opnames.h # jumptbl.h is required only if you have GCC 2.0 or later jumptbl.h : instruct.h sed -n -e '/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \ -e '/^}/q' instruct.h > jumptbl.h version.h : ../VERSION echo "#define OCAML_VERSION \"`sed -e 1q ../VERSION`\"" > version.h clean :: rm -f ocamlrun$(EXE) ocamlrund$(EXE) *.$(O) *.$(A) *.$(SO) rm -f primitives prims.c opnames.h jumptbl.h ld.conf rm -f version.h .PHONY: clean mingw-ocaml/ocaml/byterun/mlvalues.h0000644000175000017500000002527212124403240017156 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_MLVALUES_H #define CAML_MLVALUES_H #ifndef CAML_NAME_SPACE #include "compatibility.h" #endif #include "config.h" #include "misc.h" #ifdef __cplusplus extern "C" { #endif /* Definitions word: Four bytes on 32 and 16 bit architectures, eight bytes on 64 bit architectures. long: A C integer having the same number of bytes as a word. val: The ML representation of something. A long or a block or a pointer outside the heap. If it is a block, it is the (encoded) address of an object. If it is a long, it is encoded as well. block: Something allocated. It always has a header and some fields or some number of bytes (a multiple of the word size). field: A word-sized val which is part of a block. bp: Pointer to the first byte of a block. (a char *) op: Pointer to the first field of a block. (a value *) hp: Pointer to the header of a block. (a char *) int32: Four bytes on all architectures. int64: Eight bytes on all architectures. Remark: A block size is always a multiple of the word size, and at least one word plus the header. bosize: Size (in bytes) of the "bytes" part. wosize: Size (in words) of the "fields" part. bhsize: Size (in bytes) of the block with its header. whsize: Size (in words) of the block with its header. hd: A header. tag: The value of the tag field of the header. color: The value of the color field of the header. This is for use only by the GC. */ typedef intnat value; typedef uintnat header_t; typedef uintnat mlsize_t; typedef unsigned int tag_t; /* Actually, an unsigned char */ typedef uintnat color_t; typedef uintnat mark_t; /* Longs vs blocks. */ #define Is_long(x) (((x) & 1) != 0) #define Is_block(x) (((x) & 1) == 0) /* Conversion macro names are always of the form "to_from". */ /* Example: Val_long as in "Val from long" or "Val of long". */ #define Val_long(x) (((intnat)(x) << 1) + 1) #define Long_val(x) ((x) >> 1) #define Max_long (((intnat)1 << (8 * sizeof(value) - 2)) - 1) #define Min_long (-((intnat)1 << (8 * sizeof(value) - 2))) #define Val_int(x) Val_long(x) #define Int_val(x) ((int) Long_val(x)) #define Unsigned_long_val(x) ((uintnat)(x) >> 1) #define Unsigned_int_val(x) ((int) Unsigned_long_val(x)) /* Structure of the header: For 16-bit and 32-bit architectures: +--------+-------+-----+ | wosize | color | tag | +--------+-------+-----+ bits 31 10 9 8 7 0 For 64-bit architectures: +--------+-------+-----+ | wosize | color | tag | +--------+-------+-----+ bits 63 10 9 8 7 0 */ #define Tag_hd(hd) ((tag_t) ((hd) & 0xFF)) #define Wosize_hd(hd) ((mlsize_t) ((hd) >> 10)) #define Hd_val(val) (((header_t *) (val)) [-1]) /* Also an l-value. */ #define Hd_op(op) (Hd_val (op)) /* Also an l-value. */ #define Hd_bp(bp) (Hd_val (bp)) /* Also an l-value. */ #define Hd_hp(hp) (* ((header_t *) (hp))) /* Also an l-value. */ #define Hp_val(val) ((char *) (((header_t *) (val)) - 1)) #define Hp_op(op) (Hp_val (op)) #define Hp_bp(bp) (Hp_val (bp)) #define Val_op(op) ((value) (op)) #define Val_hp(hp) ((value) (((header_t *) (hp)) + 1)) #define Op_hp(hp) ((value *) Val_hp (hp)) #define Bp_hp(hp) ((char *) Val_hp (hp)) #define Num_tags (1 << 8) #ifdef ARCH_SIXTYFOUR #define Max_wosize (((intnat)1 << 54) - 1) #else #define Max_wosize ((1 << 22) - 1) #endif #define Wosize_val(val) (Wosize_hd (Hd_val (val))) #define Wosize_op(op) (Wosize_val (op)) #define Wosize_bp(bp) (Wosize_val (bp)) #define Wosize_hp(hp) (Wosize_hd (Hd_hp (hp))) #define Whsize_wosize(sz) ((sz) + 1) #define Wosize_whsize(sz) ((sz) - 1) #define Wosize_bhsize(sz) ((sz) / sizeof (value) - 1) #define Bsize_wsize(sz) ((sz) * sizeof (value)) #define Wsize_bsize(sz) ((sz) / sizeof (value)) #define Bhsize_wosize(sz) (Bsize_wsize (Whsize_wosize (sz))) #define Bhsize_bosize(sz) ((sz) + sizeof (header_t)) #define Bosize_val(val) (Bsize_wsize (Wosize_val (val))) #define Bosize_op(op) (Bosize_val (Val_op (op))) #define Bosize_bp(bp) (Bosize_val (Val_bp (bp))) #define Bosize_hd(hd) (Bsize_wsize (Wosize_hd (hd))) #define Whsize_hp(hp) (Whsize_wosize (Wosize_hp (hp))) #define Whsize_val(val) (Whsize_hp (Hp_val (val))) #define Whsize_bp(bp) (Whsize_val (Val_bp (bp))) #define Whsize_hd(hd) (Whsize_wosize (Wosize_hd (hd))) #define Bhsize_hp(hp) (Bsize_wsize (Whsize_hp (hp))) #define Bhsize_hd(hd) (Bsize_wsize (Whsize_hd (hd))) #ifdef ARCH_BIG_ENDIAN #define Tag_val(val) (((unsigned char *) (val)) [-1]) /* Also an l-value. */ #define Tag_hp(hp) (((unsigned char *) (hp)) [sizeof(value)-1]) /* Also an l-value. */ #else #define Tag_val(val) (((unsigned char *) (val)) [-sizeof(value)]) /* Also an l-value. */ #define Tag_hp(hp) (((unsigned char *) (hp)) [0]) /* Also an l-value. */ #endif /* The lowest tag for blocks containing no value. */ #define No_scan_tag 251 /* 1- If tag < No_scan_tag : a tuple of fields. */ /* Pointer to the first field. */ #define Op_val(x) ((value *) (x)) /* Fields are numbered from 0. */ #define Field(x, i) (((value *)(x)) [i]) /* Also an l-value. */ typedef int32 opcode_t; typedef opcode_t * code_t; /* NOTE: [Forward_tag] and [Infix_tag] must be just under [No_scan_tag], with [Infix_tag] the lower one. See [caml_oldify_one] in minor_gc.c for more details. NOTE: Update stdlib/obj.ml whenever you change the tags. */ /* Forward_tag: forwarding pointer that the GC may silently shortcut. See stdlib/lazy.ml. */ #define Forward_tag 250 #define Forward_val(v) Field(v, 0) /* If tag == Infix_tag : an infix header inside a closure */ /* Infix_tag must be odd so that the infix header is scanned as an integer */ /* Infix_tag must be 1 modulo 4 and infix headers can only occur in blocks with tag Closure_tag (see compact.c). */ #define Infix_tag 249 #define Infix_offset_hd(hd) (Bosize_hd(hd)) #define Infix_offset_val(v) Infix_offset_hd(Hd_val(v)) /* Another special case: objects */ #define Object_tag 248 #define Class_val(val) Field((val), 0) #define Oid_val(val) Long_val(Field((val), 1)) CAMLextern value caml_get_public_method (value obj, value tag); /* Called as: caml_callback(caml_get_public_method(obj, caml_hash_variant(name)), obj) */ /* caml_get_public_method returns 0 if tag not in the table. Note however that tags being hashed, same tag does not necessarily mean same method name. */ /* Special case of tuples of fields: closures */ #define Closure_tag 247 #define Code_val(val) (((code_t *) (val)) [0]) /* Also an l-value. */ /* This tag is used (with Forward_tag) to implement lazy values. See major_gc.c and stdlib/lazy.ml. */ #define Lazy_tag 246 /* Another special case: variants */ CAMLextern value caml_hash_variant(char const * tag); /* 2- If tag >= No_scan_tag : a sequence of bytes. */ /* Pointer to the first byte */ #define Bp_val(v) ((char *) (v)) #define Val_bp(p) ((value) (p)) /* Bytes are numbered from 0. */ #define Byte(x, i) (((char *) (x)) [i]) /* Also an l-value. */ #define Byte_u(x, i) (((unsigned char *) (x)) [i]) /* Also an l-value. */ /* Abstract things. Their contents is not traced by the GC; therefore they must not contain any [value]. */ #define Abstract_tag 251 /* Strings. */ #define String_tag 252 #define String_val(x) ((char *) Bp_val(x)) CAMLextern mlsize_t caml_string_length (value); /* size in bytes */ /* Floating-point numbers. */ #define Double_tag 253 #define Double_wosize ((sizeof(double) / sizeof(value))) #ifndef ARCH_ALIGN_DOUBLE #define Double_val(v) (* (double *)(v)) #define Store_double_val(v,d) (* (double *)(v) = (d)) #else CAMLextern double caml_Double_val (value); CAMLextern void caml_Store_double_val (value,double); #define Double_val(v) caml_Double_val(v) #define Store_double_val(v,d) caml_Store_double_val(v,d) #endif /* Arrays of floating-point numbers. */ #define Double_array_tag 254 #define Double_field(v,i) Double_val((value)((double *)(v) + (i))) #define Store_double_field(v,i,d) do{ \ mlsize_t caml__temp_i = (i); \ double caml__temp_d = (d); \ Store_double_val((value)((double *) (v) + caml__temp_i), caml__temp_d); \ }while(0) CAMLextern mlsize_t caml_array_length (value); /* size in items */ CAMLextern int caml_is_double_array (value); /* 0 is false, 1 is true */ /* Custom blocks. They contain a pointer to a "method suite" of functions (for finalization, comparison, hashing, etc) followed by raw data. The contents of custom blocks is not traced by the GC; therefore, they must not contain any [value]. See [custom.h] for operations on method suites. */ #define Custom_tag 255 #define Data_custom_val(v) ((void *) &Field((v), 1)) struct custom_operations; /* defined in [custom.h] */ /* Int32.t, Int64.t and Nativeint.t are represented as custom blocks. */ #define Int32_val(v) (*((int32 *) Data_custom_val(v))) #define Nativeint_val(v) (*((intnat *) Data_custom_val(v))) #ifndef ARCH_ALIGN_INT64 #define Int64_val(v) (*((int64 *) Data_custom_val(v))) #else CAMLextern int64 caml_Int64_val(value v); #define Int64_val(v) caml_Int64_val(v) #endif /* 3- Atoms are 0-tuples. They are statically allocated once and for all. */ CAMLextern header_t caml_atom_table[]; #define Atom(tag) (Val_hp (&(caml_atom_table [(tag)]))) /* Booleans are integers 0 or 1 */ #define Val_bool(x) Val_int((x) != 0) #define Bool_val(x) Int_val(x) #define Val_false Val_int(0) #define Val_true Val_int(1) #define Val_not(x) (Val_false + Val_true - (x)) /* The unit value is 0 (tagged) */ #define Val_unit Val_int(0) /* List constructors */ #define Val_emptylist Val_int(0) #define Tag_cons 0 /* The table of global identifiers */ extern value caml_global_data; #ifdef __cplusplus } #endif #endif /* CAML_MLVALUES_H */ mingw-ocaml/ocaml/byterun/dynlink.c0000644000175000017500000002007712124403240016767 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2000 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Dynamic loading of C primitives. */ #include #include #include #include #include #include "config.h" #ifdef HAS_UNISTD #include #endif #include "alloc.h" #include "dynlink.h" #include "fail.h" #include "mlvalues.h" #include "memory.h" #include "misc.h" #include "osdeps.h" #include "prims.h" #ifndef NATIVE_CODE /* The table of primitives */ struct ext_table caml_prim_table; #ifdef DEBUG /* The names of primitives (for instrtrace.c) */ struct ext_table caml_prim_name_table; #endif /* The table of shared libraries currently opened */ static struct ext_table shared_libs; /* The search path for shared libraries */ struct ext_table caml_shared_libs_path; /* Look up the given primitive name in the built-in primitive table, then in the opened shared libraries (shared_libs) */ static c_primitive lookup_primitive(char * name) { int i; void * res; for (i = 0; caml_names_of_builtin_cprim[i] != NULL; i++) { if (strcmp(name, caml_names_of_builtin_cprim[i]) == 0) return caml_builtin_cprim[i]; } for (i = 0; i < shared_libs.size; i++) { res = caml_dlsym(shared_libs.contents[i], name); if (res != NULL) return (c_primitive) res; } return NULL; } /* Parse the OCAML_STDLIB_DIR/ld.conf file and add the directories listed there to the search path */ #define LD_CONF_NAME "ld.conf" static char * parse_ld_conf(void) { char * stdlib, * ldconfname, * config, * p, * q; struct stat st; int ldconf, nread; stdlib = getenv("OCAMLLIB"); if (stdlib == NULL) stdlib = getenv("CAMLLIB"); if (stdlib == NULL) stdlib = OCAML_STDLIB_DIR; ldconfname = caml_stat_alloc(strlen(stdlib) + 2 + sizeof(LD_CONF_NAME)); strcpy(ldconfname, stdlib); strcat(ldconfname, "/" LD_CONF_NAME); if (stat(ldconfname, &st) == -1) { caml_stat_free(ldconfname); return NULL; } ldconf = open(ldconfname, O_RDONLY, 0); if (ldconf == -1) caml_fatal_error_arg("Fatal error: cannot read loader config file %s\n", ldconfname); config = caml_stat_alloc(st.st_size + 1); nread = read(ldconf, config, st.st_size); if (nread == -1) caml_fatal_error_arg ("Fatal error: error while reading loader config file %s\n", ldconfname); config[nread] = 0; q = config; for (p = config; *p != 0; p++) { if (*p == '\n') { *p = 0; caml_ext_table_add(&caml_shared_libs_path, q); q = p + 1; } } if (q < p) caml_ext_table_add(&caml_shared_libs_path, q); close(ldconf); caml_stat_free(ldconfname); return config; } /* Open the given shared library and add it to shared_libs. Abort on error. */ static void open_shared_lib(char * name) { char * realname; void * handle; realname = caml_search_dll_in_path(&caml_shared_libs_path, name); caml_gc_message(0x100, "Loading shared library %s\n", (uintnat) realname); handle = caml_dlopen(realname, 1, 1); if (handle == NULL) caml_fatal_error_arg2("Fatal error: cannot load shared library %s\n", name, "Reason: %s\n", caml_dlerror()); caml_ext_table_add(&shared_libs, handle); caml_stat_free(realname); } /* Build the table of primitives, given a search path and a list of shared libraries (both 0-separated in a char array). Abort the runtime system on error. */ void caml_build_primitive_table(char * lib_path, char * libs, char * req_prims) { char * tofree1, * tofree2; char * p; /* Initialize the search path for dynamic libraries: - directories specified on the command line with the -I option - directories specified in the CAML_LD_LIBRARY_PATH - directories specified in the executable - directories specified in the file /ld.conf */ tofree1 = caml_decompose_path(&caml_shared_libs_path, getenv("CAML_LD_LIBRARY_PATH")); if (lib_path != NULL) for (p = lib_path; *p != 0; p += strlen(p) + 1) caml_ext_table_add(&caml_shared_libs_path, p); tofree2 = parse_ld_conf(); /* Open the shared libraries */ caml_ext_table_init(&shared_libs, 8); if (libs != NULL) for (p = libs; *p != 0; p += strlen(p) + 1) open_shared_lib(p); /* Build the primitive table */ caml_ext_table_init(&caml_prim_table, 0x180); #ifdef DEBUG caml_ext_table_init(&caml_prim_name_table, 0x180); #endif for (p = req_prims; *p != 0; p += strlen(p) + 1) { c_primitive prim = lookup_primitive(p); if (prim == NULL) caml_fatal_error_arg("Fatal error: unknown C primitive `%s'\n", p); caml_ext_table_add(&caml_prim_table, (void *) prim); #ifdef DEBUG caml_ext_table_add(&caml_prim_name_table, strdup(p)); #endif } /* Clean up */ caml_stat_free(tofree1); caml_stat_free(tofree2); caml_ext_table_free(&caml_shared_libs_path, 0); } /* Build the table of primitives as a copy of the builtin primitive table. Used for executables generated by ocamlc -output-obj. */ void caml_build_primitive_table_builtin(void) { int i; caml_ext_table_init(&caml_prim_table, 0x180); #ifdef DEBUG caml_ext_table_init(&caml_prim_name_table, 0x180); #endif for (i = 0; caml_builtin_cprim[i] != 0; i++) { caml_ext_table_add(&caml_prim_table, (void *) caml_builtin_cprim[i]); #ifdef DEBUG caml_ext_table_add(&caml_prim_name_table, strdup(caml_names_of_builtin_cprim[i])); #endif } } #endif /* NATIVE_CODE */ /** dlopen interface for the bytecode linker **/ #define Handle_val(v) (*((void **) (v))) CAMLprim value caml_dynlink_open_lib(value mode, value filename) { void * handle; value result; caml_gc_message(0x100, "Opening shared library %s\n", (uintnat) String_val(filename)); handle = caml_dlopen(String_val(filename), Int_val(mode), 1); if (handle == NULL) caml_failwith(caml_dlerror()); result = caml_alloc_small(1, Abstract_tag); Handle_val(result) = handle; return result; } CAMLprim value caml_dynlink_close_lib(value handle) { caml_dlclose(Handle_val(handle)); return Val_unit; } /*#include */ CAMLprim value caml_dynlink_lookup_symbol(value handle, value symbolname) { void * symb; value result; symb = caml_dlsym(Handle_val(handle), String_val(symbolname)); /* printf("%s = 0x%lx\n", String_val(symbolname), symb); fflush(stdout); */ if (symb == NULL) return Val_unit /*caml_failwith(caml_dlerror())*/; result = caml_alloc_small(1, Abstract_tag); Handle_val(result) = symb; return result; } #ifndef NATIVE_CODE CAMLprim value caml_dynlink_add_primitive(value handle) { return Val_int(caml_ext_table_add(&caml_prim_table, Handle_val(handle))); } CAMLprim value caml_dynlink_get_current_libs(value unit) { CAMLparam0(); CAMLlocal1(res); int i; res = caml_alloc_tuple(shared_libs.size); for (i = 0; i < shared_libs.size; i++) { value v = caml_alloc_small(1, Abstract_tag); Handle_val(v) = shared_libs.contents[i]; Store_field(res, i, v); } CAMLreturn(res); } #else value caml_dynlink_add_primitive(value handle) { caml_invalid_argument("dynlink_add_primitive"); return Val_unit; /* not reached */ } value caml_dynlink_get_current_libs(value unit) { caml_invalid_argument("dynlink_get_current_libs"); return Val_unit; /* not reached */ } #endif /* NATIVE_CODE */ mingw-ocaml/ocaml/byterun/fix_code.h0000644000175000017500000000310512124403240017075 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Handling of blocks of bytecode (endianness switch, threading). */ #ifndef CAML_FIX_CODE_H #define CAML_FIX_CODE_H #include "config.h" #include "misc.h" #include "mlvalues.h" extern code_t caml_start_code; extern asize_t caml_code_size; extern unsigned char * caml_saved_code; void caml_init_code_fragments(); void caml_load_code (int fd, asize_t len); void caml_fixup_endianness (code_t code, asize_t len); void caml_set_instruction (code_t pos, opcode_t instr); int caml_is_instruction (opcode_t instr1, opcode_t instr2); #ifdef THREADED_CODE extern char ** caml_instr_table; extern char * caml_instr_base; void caml_thread_code (code_t code, asize_t len); #endif #endif /* CAML_FIX_CODE_H */ mingw-ocaml/ocaml/byterun/roots.h0000644000175000017500000000314112124403240016463 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_ROOTS_H #define CAML_ROOTS_H #include "misc.h" #include "memory.h" typedef void (*scanning_action) (value, value *); void caml_oldify_local_roots (void); void caml_darken_all_roots (void); void caml_do_roots (scanning_action); #ifndef NATIVE_CODE CAMLextern void caml_do_local_roots (scanning_action, value *, value *, struct caml__roots_block *); #else CAMLextern void caml_do_local_roots(scanning_action f, char * bottom_of_stack, uintnat last_retaddr, value * gc_regs, struct caml__roots_block * local_roots); #endif CAMLextern void (*caml_scan_roots_hook) (scanning_action); #endif /* CAML_ROOTS_H */ mingw-ocaml/ocaml/byterun/printexc.c0000644000175000017500000000741412124403240017153 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Print an uncaught exception and abort */ #include #include #include #include "backtrace.h" #include "callback.h" #include "debugger.h" #include "fail.h" #include "misc.h" #include "mlvalues.h" #include "printexc.h" struct stringbuf { char * ptr; char * end; char data[256]; }; static void add_char(struct stringbuf *buf, char c) { if (buf->ptr < buf->end) *(buf->ptr++) = c; } static void add_string(struct stringbuf *buf, char *s) { int len = strlen(s); if (buf->ptr + len > buf->end) len = buf->end - buf->ptr; if (len > 0) memmove(buf->ptr, s, len); buf->ptr += len; } CAMLexport char * caml_format_exception(value exn) { mlsize_t start, i; value bucket, v; struct stringbuf buf; char intbuf[64]; char * res; buf.ptr = buf.data; buf.end = buf.data + sizeof(buf.data) - 1; add_string(&buf, String_val(Field(Field(exn, 0), 0))); if (Wosize_val(exn) >= 2) { /* Check for exceptions in the style of Match_failure and Assert_failure */ if (Wosize_val(exn) == 2 && Is_block(Field(exn, 1)) && Tag_val(Field(exn, 1)) == 0 && caml_is_special_exception(Field(exn, 0))) { bucket = Field(exn, 1); start = 0; } else { bucket = exn; start = 1; } add_char(&buf, '('); for (i = start; i < Wosize_val(bucket); i++) { if (i > start) add_string(&buf, ", "); v = Field(bucket, i); if (Is_long(v)) { sprintf(intbuf, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v)); add_string(&buf, intbuf); } else if (Tag_val(v) == String_tag) { add_char(&buf, '"'); add_string(&buf, String_val(v)); add_char(&buf, '"'); } else { add_char(&buf, '_'); } } add_char(&buf, ')'); } *buf.ptr = 0; /* Terminate string */ i = buf.ptr - buf.data + 1; res = malloc(i); if (res == NULL) return NULL; memmove(res, buf.data, i); return res; } void caml_fatal_uncaught_exception(value exn) { char * msg; value * at_exit; int saved_backtrace_active, saved_backtrace_pos; /* Build a string representation of the exception */ msg = caml_format_exception(exn); /* Perform "at_exit" processing, ignoring all exceptions that may be triggered by this */ saved_backtrace_active = caml_backtrace_active; saved_backtrace_pos = caml_backtrace_pos; caml_backtrace_active = 0; at_exit = caml_named_value("Pervasives.do_at_exit"); if (at_exit != NULL) caml_callback_exn(*at_exit, Val_unit); caml_backtrace_active = saved_backtrace_active; caml_backtrace_pos = saved_backtrace_pos; /* Display the uncaught exception */ fprintf(stderr, "Fatal error: exception %s\n", msg); free(msg); /* Display the backtrace if available */ if (caml_backtrace_active #ifndef NATIVE_CODE && !caml_debugger_in_use #endif ) { caml_print_exception_backtrace(); } /* Terminate the process */ exit(2); } mingw-ocaml/ocaml/byterun/unix.c0000644000175000017500000001656012124403240016304 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Unix-specific stuff */ #define _GNU_SOURCE /* Helps finding RTLD_DEFAULT in glibc */ #include #include #include #include #include #include #include "config.h" #ifdef SUPPORT_DYNAMIC_LINKING #ifdef __CYGWIN32__ #include "flexdll.h" #else #include #endif #endif #ifdef HAS_UNISTD #include #endif #ifdef HAS_DIRENT #include #else #include #endif #include "memory.h" #include "misc.h" #include "osdeps.h" #ifndef S_ISREG #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) #endif char * caml_decompose_path(struct ext_table * tbl, char * path) { char * p, * q; int n; if (path == NULL) return NULL; p = caml_stat_alloc(strlen(path) + 1); strcpy(p, path); q = p; while (1) { for (n = 0; q[n] != 0 && q[n] != ':'; n++) /*nothing*/; caml_ext_table_add(tbl, q); q = q + n; if (*q == 0) break; *q = 0; q += 1; } return p; } char * caml_search_in_path(struct ext_table * path, char * name) { char * p, * fullname; int i; struct stat st; for (p = name; *p != 0; p++) { if (*p == '/') goto not_found; } for (i = 0; i < path->size; i++) { fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) + strlen(name) + 2); strcpy(fullname, (char *)(path->contents[i])); if (fullname[0] != 0) strcat(fullname, "/"); strcat(fullname, name); if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname; caml_stat_free(fullname); } not_found: fullname = caml_stat_alloc(strlen(name) + 1); strcpy(fullname, name); return fullname; } #ifdef __CYGWIN32__ /* Cygwin needs special treatment because of the implicit ".exe" at the end of executable file names */ static int cygwin_file_exists(char * name) { int fd; /* Cannot use stat() here because it adds ".exe" implicitly */ fd = open(name, O_RDONLY); if (fd == -1) return 0; close(fd); return 1; } static char * cygwin_search_exe_in_path(struct ext_table * path, char * name) { char * p, * fullname; int i; for (p = name; *p != 0; p++) { if (*p == '/' || *p == '\\') goto not_found; } for (i = 0; i < path->size; i++) { fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) + strlen(name) + 6); strcpy(fullname, (char *)(path->contents[i])); strcat(fullname, "/"); strcat(fullname, name); if (cygwin_file_exists(fullname)) return fullname; strcat(fullname, ".exe"); if (cygwin_file_exists(fullname)) return fullname; caml_stat_free(fullname); } not_found: fullname = caml_stat_alloc(strlen(name) + 5); strcpy(fullname, name); if (cygwin_file_exists(fullname)) return fullname; strcat(fullname, ".exe"); if (cygwin_file_exists(fullname)) return fullname; strcpy(fullname, name); return fullname; } #endif char * caml_search_exe_in_path(char * name) { struct ext_table path; char * tofree; char * res; caml_ext_table_init(&path, 8); tofree = caml_decompose_path(&path, getenv("PATH")); #ifndef __CYGWIN32__ res = caml_search_in_path(&path, name); #else res = cygwin_search_exe_in_path(&path, name); #endif caml_stat_free(tofree); caml_ext_table_free(&path, 0); return res; } char * caml_search_dll_in_path(struct ext_table * path, char * name) { char * dllname = caml_stat_alloc(strlen(name) + 4); char * res; strcpy(dllname, name); strcat(dllname, ".so"); res = caml_search_in_path(path, dllname); caml_stat_free(dllname); return res; } #ifdef SUPPORT_DYNAMIC_LINKING #ifdef __CYGWIN32__ /* Use flexdll */ void * caml_dlopen(char * libname, int for_execution, int global) { int flags = (global ? FLEXDLL_RTLD_GLOBAL : 0); if (!for_execution) flags |= FLEXDLL_RTLD_NOEXEC; return flexdll_dlopen(libname, flags); } void caml_dlclose(void * handle) { flexdll_dlclose(handle); } void * caml_dlsym(void * handle, char * name) { return flexdll_dlsym(handle, name); } void * caml_globalsym(char * name) { return flexdll_dlsym(flexdll_dlopen(NULL,0), name); } char * caml_dlerror(void) { return flexdll_dlerror(); } #else /* Use normal dlopen */ #ifndef RTLD_GLOBAL #define RTLD_GLOBAL 0 #endif #ifndef RTLD_LOCAL #define RTLD_LOCAL 0 #endif #ifndef RTLD_NODELETE #define RTLD_NODELETE 0 #endif void * caml_dlopen(char * libname, int for_execution, int global) { return dlopen(libname, RTLD_NOW | (global ? RTLD_GLOBAL : RTLD_LOCAL) | RTLD_NODELETE); /* Could use RTLD_LAZY if for_execution == 0, but needs testing */ } void caml_dlclose(void * handle) { dlclose(handle); } void * caml_dlsym(void * handle, char * name) { #ifdef DL_NEEDS_UNDERSCORE char _name[1000] = "_"; strncat (_name, name, 998); name = _name; #endif return dlsym(handle, name); } void * caml_globalsym(char * name) { #ifdef RTLD_DEFAULT return caml_dlsym(RTLD_DEFAULT, name); #else return NULL; #endif } char * caml_dlerror(void) { return (char*) dlerror(); } #endif #else void * caml_dlopen(char * libname, int for_execution, int global) { return NULL; } void caml_dlclose(void * handle) { } void * caml_dlsym(void * handle, char * name) { return NULL; } void * caml_globalsym(char * name) { return NULL; } char * caml_dlerror(void) { return "dynamic loading not supported on this platform"; } #endif /* Add to [contents] the (short) names of the files contained in the directory named [dirname]. No entries are added for [.] and [..]. Return 0 on success, -1 on error; set errno in the case of error. */ int caml_read_directory(char * dirname, struct ext_table * contents) { DIR * d; #ifdef HAS_DIRENT struct dirent * e; #else struct direct * e; #endif char * p; d = opendir(dirname); if (d == NULL) return -1; while (1) { e = readdir(d); if (e == NULL) break; if (strcmp(e->d_name, ".") == 0 || strcmp(e->d_name, "..") == 0) continue; p = caml_stat_alloc(strlen(e->d_name) + 1); strcpy(p, e->d_name); caml_ext_table_add(contents, p); } closedir(d); return 0; } /* Recover executable name from /proc/self/exe if possible */ #ifdef __linux__ int caml_executable_name(char * name, int name_len) { int retcode; struct stat st; retcode = readlink("/proc/self/exe", name, name_len); if (retcode == -1 || retcode >= name_len) return -1; name[retcode] = 0; /* Make sure that the contents of /proc/self/exe is a regular file. (Old Linux kernels return an inode number instead.) */ if (stat(name, &st) != 0) return -1; if (! S_ISREG(st.st_mode)) return -1; return 0; } #endif mingw-ocaml/ocaml/byterun/fail.c0000644000175000017500000001141212124403240016223 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Raising exceptions from C. */ #include #include #include "alloc.h" #include "fail.h" #include "io.h" #include "gc.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" #include "printexc.h" #include "signals.h" #include "stacks.h" CAMLexport struct longjmp_buffer * caml_external_raise = NULL; value caml_exn_bucket; CAMLexport void caml_raise(value v) { Unlock_exn(); caml_exn_bucket = v; if (caml_external_raise == NULL) caml_fatal_uncaught_exception(v); siglongjmp(caml_external_raise->buf, 1); } CAMLexport void caml_raise_constant(value tag) { CAMLparam1 (tag); CAMLlocal1 (bucket); bucket = caml_alloc_small (1, 0); Field(bucket, 0) = tag; caml_raise(bucket); CAMLnoreturn; } CAMLexport void caml_raise_with_arg(value tag, value arg) { CAMLparam2 (tag, arg); CAMLlocal1 (bucket); bucket = caml_alloc_small (2, 0); Field(bucket, 0) = tag; Field(bucket, 1) = arg; caml_raise(bucket); CAMLnoreturn; } CAMLexport void caml_raise_with_args(value tag, int nargs, value args[]) { CAMLparam1 (tag); CAMLxparamN (args, nargs); value bucket; int i; Assert(1 + nargs <= Max_young_wosize); bucket = caml_alloc_small (1 + nargs, 0); Field(bucket, 0) = tag; for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i]; caml_raise(bucket); CAMLnoreturn; } CAMLexport void caml_raise_with_string(value tag, char const *msg) { CAMLparam1 (tag); CAMLlocal1 (vmsg); vmsg = caml_copy_string(msg); caml_raise_with_arg(tag, vmsg); CAMLnoreturn; } /* PR#5115: Failure and Invalid_argument can be triggered by input_value while reading the initial value of [caml_global_data]. */ CAMLexport void caml_failwith (char const *msg) { if (caml_global_data == 0) { fprintf(stderr, "Fatal error: exception Failure(\"%s\")\n", msg); exit(2); } caml_raise_with_string(Field(caml_global_data, FAILURE_EXN), msg); } CAMLexport void caml_invalid_argument (char const *msg) { if (caml_global_data == 0) { fprintf(stderr, "Fatal error: exception Invalid_argument(\"%s\")\n", msg); exit(2); } caml_raise_with_string(Field(caml_global_data, INVALID_EXN), msg); } CAMLexport void caml_array_bound_error(void) { caml_invalid_argument("index out of bounds"); } /* Problem: we can't use [caml_raise_constant], because it allocates and we're out of memory... Here, we allocate statically the exn bucket for [Out_of_memory]. */ static struct { header_t hdr; value exn; } out_of_memory_bucket = { 0, 0 }; CAMLexport void caml_raise_out_of_memory(void) { if (out_of_memory_bucket.exn == 0) caml_fatal_error ("Fatal error: out of memory while raising Out_of_memory\n"); caml_raise((value) &(out_of_memory_bucket.exn)); } CAMLexport void caml_raise_stack_overflow(void) { caml_raise_constant(Field(caml_global_data, STACK_OVERFLOW_EXN)); } CAMLexport void caml_raise_sys_error(value msg) { caml_raise_with_arg(Field(caml_global_data, SYS_ERROR_EXN), msg); } CAMLexport void caml_raise_end_of_file(void) { caml_raise_constant(Field(caml_global_data, END_OF_FILE_EXN)); } CAMLexport void caml_raise_zero_divide(void) { caml_raise_constant(Field(caml_global_data, ZERO_DIVIDE_EXN)); } CAMLexport void caml_raise_not_found(void) { caml_raise_constant(Field(caml_global_data, NOT_FOUND_EXN)); } CAMLexport void caml_raise_sys_blocked_io(void) { caml_raise_constant(Field(caml_global_data, SYS_BLOCKED_IO)); } /* Initialization of statically-allocated exception buckets */ void caml_init_exceptions(void) { out_of_memory_bucket.hdr = Make_header(1, 0, Caml_white); out_of_memory_bucket.exn = Field(caml_global_data, OUT_OF_MEMORY_EXN); caml_register_global_root(&out_of_memory_bucket.exn); } int caml_is_special_exception(value exn) { return exn == Field(caml_global_data, MATCH_FAILURE_EXN) || exn == Field(caml_global_data, ASSERT_FAILURE_EXN) || exn == Field(caml_global_data, UNDEFINED_RECURSIVE_MODULE_EXN); } mingw-ocaml/ocaml/byterun/gc.h0000644000175000017500000000477012124403240015717 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_GC_H #define CAML_GC_H #include "mlvalues.h" #define Caml_white (0 << 8) #define Caml_gray (1 << 8) #define Caml_blue (2 << 8) #define Caml_black (3 << 8) #define Color_hd(hd) ((color_t) ((hd) & Caml_black)) #define Color_hp(hp) (Color_hd (Hd_hp (hp))) #define Color_val(val) (Color_hd (Hd_val (val))) #define Is_white_hd(hd) (Color_hd (hd) == Caml_white) #define Is_gray_hd(hd) (Color_hd (hd) == Caml_gray) #define Is_blue_hd(hd) (Color_hd (hd) == Caml_blue) #define Is_black_hd(hd) (Color_hd (hd) == Caml_black) #define Whitehd_hd(hd) (((hd) & ~Caml_black)/*| Caml_white*/) #define Grayhd_hd(hd) (((hd) & ~Caml_black) | Caml_gray) #define Blackhd_hd(hd) (((hd)/*& ~Caml_black*/)| Caml_black) #define Bluehd_hd(hd) (((hd) & ~Caml_black) | Caml_blue) /* This depends on the layout of the header. See [mlvalues.h]. */ #define Make_header(wosize, tag, color) \ (/*Assert ((wosize) <= Max_wosize),*/ \ ((header_t) (((header_t) (wosize) << 10) \ + (color) \ + (tag_t) (tag))) \ ) #define Is_white_val(val) (Color_val(val) == Caml_white) #define Is_gray_val(val) (Color_val(val) == Caml_gray) #define Is_blue_val(val) (Color_val(val) == Caml_blue) #define Is_black_val(val) (Color_val(val) == Caml_black) /* For extern.c */ #define Colornum_hd(hd) ((color_t) (((hd) >> 8) & 3)) #define Coloredhd_hd(hd,colnum) (((hd) & ~Caml_black) | ((colnum) << 8)) #endif /* CAML_GC_H */ mingw-ocaml/ocaml/byterun/minor_gc.h0000644000175000017500000000414312124403240017115 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_MINOR_GC_H #define CAML_MINOR_GC_H #include "misc.h" CAMLextern char *caml_young_start, *caml_young_ptr; CAMLextern char *caml_young_end, *caml_young_limit; extern asize_t caml_minor_heap_size; extern int caml_in_minor_collection; struct caml_ref_table { value **base; value **end; value **threshold; value **ptr; value **limit; asize_t size; asize_t reserve; }; CAMLextern struct caml_ref_table caml_ref_table, caml_weak_ref_table; #define Is_young(val) \ (Assert (Is_block (val)), \ (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start) extern void caml_set_minor_heap_size (asize_t); extern void caml_empty_minor_heap (void); CAMLextern void caml_minor_collection (void); CAMLextern void garbage_collection (void); /* def in asmrun/signals.c */ extern void caml_realloc_ref_table (struct caml_ref_table *); extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t); extern void caml_oldify_one (value, value *); extern void caml_oldify_mopup (void); #define Oldify(p) do{ \ value __oldify__v__ = *p; \ if (Is_block (__oldify__v__) && Is_young (__oldify__v__)){ \ caml_oldify_one (__oldify__v__, (p)); \ } \ }while(0) #endif /* CAML_MINOR_GC_H */ mingw-ocaml/ocaml/byterun/io.h0000644000175000017500000001170112124403240015725 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Buffered input/output */ #ifndef CAML_IO_H #define CAML_IO_H #include "misc.h" #include "mlvalues.h" #ifndef IO_BUFFER_SIZE #define IO_BUFFER_SIZE 65536 #endif #if defined(_WIN32) typedef __int64 file_offset; extern __int64 _lseeki64(int, __int64, int); #define lseek(fd,d,m) _lseeki64(fd,d,m) #elif defined(HAS_OFF_T) #include typedef off_t file_offset; #else typedef long file_offset; #endif struct channel { int fd; /* Unix file descriptor */ file_offset offset; /* Absolute position of fd in the file */ char * end; /* Physical end of the buffer */ char * curr; /* Current position in the buffer */ char * max; /* Logical end of the buffer (for input) */ void * mutex; /* Placeholder for mutex (for systhreads) */ struct channel * next, * prev;/* Double chaining of channels (flush_all) */ int revealed; /* For Cash only */ int old_revealed; /* For Cash only */ int refcount; /* For flush_all and for Cash */ int flags; /* Bitfield */ char buff[IO_BUFFER_SIZE]; /* The buffer itself */ }; enum { CHANNEL_FLAG_FROM_SOCKET = 1 /* For Windows */ }; /* For an output channel: [offset] is the absolute position of the beginning of the buffer [buff]. For an input channel: [offset] is the absolute position of the logical end of the buffer, [max]. */ /* Functions and macros that can be called from C. Take arguments of type struct channel *. No locking is performed. */ #define putch(channel, ch) do{ \ if ((channel)->curr >= (channel)->end) caml_flush_partial(channel); \ *((channel)->curr)++ = (ch); \ }while(0) #define getch(channel) \ ((channel)->curr >= (channel)->max \ ? caml_refill(channel) \ : (unsigned char) *((channel)->curr)++) CAMLextern struct channel * caml_open_descriptor_in (int); CAMLextern struct channel * caml_open_descriptor_out (int); CAMLextern void caml_close_channel (struct channel *); CAMLextern int caml_channel_binary_mode (struct channel *); CAMLextern value caml_alloc_channel(struct channel *chan); CAMLextern int caml_flush_partial (struct channel *); CAMLextern void caml_flush (struct channel *); CAMLextern void caml_putword (struct channel *, uint32); CAMLextern int caml_putblock (struct channel *, char *, intnat); CAMLextern void caml_really_putblock (struct channel *, char *, intnat); CAMLextern unsigned char caml_refill (struct channel *); CAMLextern uint32 caml_getword (struct channel *); CAMLextern int caml_getblock (struct channel *, char *, intnat); CAMLextern int caml_really_getblock (struct channel *, char *, intnat); /* Extract a struct channel * from the heap object representing it */ #define Channel(v) (*((struct channel **) (Data_custom_val(v)))) /* The locking machinery */ CAMLextern void (*caml_channel_mutex_free) (struct channel *); CAMLextern void (*caml_channel_mutex_lock) (struct channel *); CAMLextern void (*caml_channel_mutex_unlock) (struct channel *); CAMLextern void (*caml_channel_mutex_unlock_exn) (void); CAMLextern struct channel * caml_all_opened_channels; #define Lock(channel) \ if (caml_channel_mutex_lock != NULL) (*caml_channel_mutex_lock)(channel) #define Unlock(channel) \ if (caml_channel_mutex_unlock != NULL) (*caml_channel_mutex_unlock)(channel) #define Unlock_exn() \ if (caml_channel_mutex_unlock_exn != NULL) (*caml_channel_mutex_unlock_exn)() /* Conversion between file_offset and int64 */ #ifdef ARCH_INT64_TYPE #define Val_file_offset(fofs) caml_copy_int64(fofs) #define File_offset_val(v) ((file_offset) Int64_val(v)) #else CAMLextern value caml_Val_file_offset(file_offset fofs); CAMLextern file_offset caml_File_offset_val(value v); #define Val_file_offset caml_Val_file_offset #define File_offset_val caml_File_offset_val #endif #endif /* CAML_IO_H */ mingw-ocaml/ocaml/byterun/signals.h0000644000175000017500000000411312124403240016755 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_SIGNALS_H #define CAML_SIGNALS_H #ifndef CAML_NAME_SPACE #include "compatibility.h" #endif #include "misc.h" #include "mlvalues.h" #ifdef __cplusplus extern "C" { #endif /* */ CAMLextern intnat volatile caml_signals_are_pending; CAMLextern intnat volatile caml_pending_signals[]; CAMLextern int volatile caml_something_to_do; extern int volatile caml_force_major_slice; /* */ CAMLextern void caml_enter_blocking_section (void); CAMLextern void caml_leave_blocking_section (void); /* */ void caml_urge_major_slice (void); CAMLextern int caml_convert_signal_number (int); CAMLextern int caml_rev_convert_signal_number (int); void caml_execute_signal(int signal_number, int in_signal_handler); void caml_record_signal(int signal_number); void caml_process_pending_signals(void); void caml_process_event(void); int caml_set_signal_action(int signo, int action); CAMLextern void (*caml_enter_blocking_section_hook)(void); CAMLextern void (*caml_leave_blocking_section_hook)(void); CAMLextern int (*caml_try_leave_blocking_section_hook)(void); CAMLextern void (* volatile caml_async_action_hook)(void); /* */ #ifdef __cplusplus } #endif #endif /* CAML_SIGNALS_H */ mingw-ocaml/ocaml/byterun/freelist.h0000644000175000017500000000254412124403240017140 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Free lists of heap blocks. */ #ifndef CAML_FREELIST_H #define CAML_FREELIST_H #include "misc.h" #include "mlvalues.h" extern asize_t caml_fl_cur_size; /* size in words */ char *caml_fl_allocate (mlsize_t); void caml_fl_init_merge (void); void caml_fl_reset (void); char *caml_fl_merge_block (char *); void caml_fl_add_blocks (char *); void caml_make_free_blocks (value *, mlsize_t, int, int); void caml_set_allocation_policy (uintnat); #endif /* CAML_FREELIST_H */ mingw-ocaml/ocaml/byterun/compare.h0000644000175000017500000000177012124403240016751 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, Projet Moscova, INRIA Rocquencourt */ /* */ /* Copyright 2003 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_COMPARE_H #define CAML_COMPARE_H CAMLextern int caml_compare_unordered; #endif /* CAML_COMPARE_H */ mingw-ocaml/ocaml/byterun/weak.h0000644000175000017500000000207712124403240016253 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1997 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Operations on weak arrays */ #ifndef CAML_WEAK_H #define CAML_WEAK_H #include "mlvalues.h" extern value caml_weak_list_head; extern value caml_weak_none; #endif /* CAML_WEAK_H */ mingw-ocaml/ocaml/byterun/fix_code.c0000644000175000017500000001240212124403240017070 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Handling of blocks of bytecode (endianness switch, threading). */ #include "config.h" #ifdef HAS_UNISTD #include #endif #include "debugger.h" #include "fix_code.h" #include "instruct.h" #include "intext.h" #include "md5.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" #include "reverse.h" code_t caml_start_code; asize_t caml_code_size; unsigned char * caml_saved_code; unsigned char caml_code_md5[16]; /* Read the main bytecode block from a file */ void caml_init_code_fragments() { struct code_fragment * cf; /* Register the code in the table of code fragments */ cf = caml_stat_alloc(sizeof(struct code_fragment)); cf->code_start = (char *) caml_start_code; cf->code_end = (char *) caml_start_code + caml_code_size; caml_md5_block(cf->digest, caml_start_code, caml_code_size); cf->digest_computed = 1; caml_ext_table_init(&caml_code_fragments_table, 8); caml_ext_table_add(&caml_code_fragments_table, cf); } void caml_load_code(int fd, asize_t len) { int i; caml_code_size = len; caml_start_code = (code_t) caml_stat_alloc(caml_code_size); if (read(fd, (char *) caml_start_code, caml_code_size) != caml_code_size) caml_fatal_error("Fatal error: truncated bytecode file.\n"); caml_init_code_fragments(); /* Prepare the code for execution */ #ifdef ARCH_BIG_ENDIAN caml_fixup_endianness(caml_start_code, caml_code_size); #endif if (caml_debugger_in_use) { len /= sizeof(opcode_t); caml_saved_code = (unsigned char *) caml_stat_alloc(len); for (i = 0; i < len; i++) caml_saved_code[i] = caml_start_code[i]; } #ifdef THREADED_CODE /* Better to thread now than at the beginning of [caml_interprete], since the debugger interface needs to perform SET_EVENT requests on the code. */ caml_thread_code(caml_start_code, caml_code_size); #endif } /* This code is needed only if the processor is big endian */ #ifdef ARCH_BIG_ENDIAN void caml_fixup_endianness(code_t code, asize_t len) { code_t p; len /= sizeof(opcode_t); for (p = code; p < code + len; p++) { Reverse_32(p, p); } } #endif /* This code is needed only if we're using threaded code */ #ifdef THREADED_CODE char ** caml_instr_table; char * caml_instr_base; void caml_thread_code (code_t code, asize_t len) { code_t p; int l [STOP + 1]; int i; for (i = 0; i <= STOP; i++) { l [i] = 0; } /* Instructions with one operand */ l[PUSHACC] = l[ACC] = l[POP] = l[ASSIGN] = l[PUSHENVACC] = l[ENVACC] = l[PUSH_RETADDR] = l[APPLY] = l[APPTERM1] = l[APPTERM2] = l[APPTERM3] = l[RETURN] = l[GRAB] = l[PUSHGETGLOBAL] = l[GETGLOBAL] = l[SETGLOBAL] = l[PUSHATOM] = l[ATOM] = l[MAKEBLOCK1] = l[MAKEBLOCK2] = l[MAKEBLOCK3] = l[MAKEFLOATBLOCK] = l[GETFIELD] = l[GETFLOATFIELD] = l[SETFIELD] = l[SETFLOATFIELD] = l[BRANCH] = l[BRANCHIF] = l[BRANCHIFNOT] = l[PUSHTRAP] = l[C_CALL1] = l[C_CALL2] = l[C_CALL3] = l[C_CALL4] = l[C_CALL5] = l[CONSTINT] = l[PUSHCONSTINT] = l[OFFSETINT] = l[OFFSETREF] = l[OFFSETCLOSURE] = l[PUSHOFFSETCLOSURE] = 1; /* Instructions with two operands */ l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] = l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] = l[BEQ] = l[BNEQ] = l[BLTINT] = l[BLEINT] = l[BGTINT] = l[BGEINT] = l[BULTINT] = l[BUGEINT] = l[GETPUBMET] = 2; len /= sizeof(opcode_t); for (p = code; p < code + len; /*nothing*/) { opcode_t instr = *p; if (instr < 0 || instr > STOP){ /* FIXME -- should Assert(false) ? caml_fatal_error_arg ("Fatal error in fix_code: bad opcode (%lx)\n", (char *)(long)instr); */ instr = STOP; } *p++ = (opcode_t)(caml_instr_table[instr] - caml_instr_base); if (instr == SWITCH) { uint32 sizes = *p++; uint32 const_size = sizes & 0xFFFF; uint32 block_size = sizes >> 16; p += const_size + block_size; } else if (instr == CLOSUREREC) { uint32 nfuncs = *p++; p++; /* skip nvars */ p += nfuncs; } else { p += l[instr]; } } Assert(p == code + len); } #endif /* THREADED_CODE */ void caml_set_instruction(code_t pos, opcode_t instr) { #ifdef THREADED_CODE *pos = (opcode_t)(caml_instr_table[instr] - caml_instr_base); #else *pos = instr; #endif } int caml_is_instruction(opcode_t instr1, opcode_t instr2) { #ifdef THREADED_CODE return instr1 == (opcode_t)(caml_instr_table[instr2] - caml_instr_base); #else return instr1 == instr2; #endif } mingw-ocaml/ocaml/byterun/exec.h0000644000175000017500000000424312124403240016245 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* exec.h : format of executable bytecode files */ #ifndef CAML_EXEC_H #define CAML_EXEC_H /* Executable bytecode files are composed of a number of sections, identified by 4-character names. A table of contents at the end of the file lists the section names along with their sizes, in the order in which they appear in the file: offset 0 ---> initial junk data for section 1 data for section 2 ... data for section N table of contents: descriptor for section 1 ... descriptor for section N trailer end of file ---> */ /* Structure of t.o.c. entries Numerical quantities are 32-bit unsigned integers, big endian */ struct section_descriptor { char name[4]; /* Section name */ uint32 len; /* Length of data in bytes */ }; /* Structure of the trailer. */ struct exec_trailer { uint32 num_sections; /* Number of sections */ char magic[12]; /* The magic number */ struct section_descriptor * section; /* Not part of file */ }; #define TRAILER_SIZE (4+12) /* Magic number for this release */ #define EXEC_MAGIC "Caml1999X008" #endif /* CAML_EXEC_H */ mingw-ocaml/ocaml/byterun/md5.h0000644000175000017500000000324312124403240016005 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* MD5 message digest */ #ifndef CAML_MD5_H #define CAML_MD5_H #include "mlvalues.h" #include "io.h" CAMLextern value caml_md5_string (value str, value ofs, value len); CAMLextern value caml_md5_chan (value vchan, value len); CAMLextern void caml_md5_block(unsigned char digest[16], void * data, uintnat len); struct MD5Context { uint32 buf[4]; uint32 bits[2]; unsigned char in[64]; }; CAMLextern void caml_MD5Init (struct MD5Context *context); CAMLextern void caml_MD5Update (struct MD5Context *context, unsigned char *buf, uintnat len); CAMLextern void caml_MD5Final (unsigned char *digest, struct MD5Context *ctx); CAMLextern void caml_MD5Transform (uint32 *buf, uint32 *in); #endif /* CAML_MD5_H */ mingw-ocaml/ocaml/byterun/signals_machdep.h0000644000175000017500000000371712124403240020447 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Processor-specific operation: atomic "read and clear" */ #ifndef CAML_SIGNALS_MACHDEP_H #define CAML_SIGNALS_MACHDEP_H #if defined(__GNUC__) && defined(__i386__) #define Read_and_clear(dst,src) \ asm("xorl %0, %0; xchgl %0, %1" \ : "=r" (dst), "=m" (src) \ : "m" (src)) #elif defined(__GNUC__) && defined(__x86_64__) #define Read_and_clear(dst,src) \ asm("xorq %0, %0; xchgq %0, %1" \ : "=r" (dst), "=m" (src) \ : "m" (src)) #elif defined(__GNUC__) && defined(__ppc__) #define Read_and_clear(dst,src) \ asm("0: lwarx %0, 0, %1\n\t" \ "stwcx. %2, 0, %1\n\t" \ "bne- 0b" \ : "=&r" (dst) \ : "r" (&(src)), "r" (0) \ : "cr0", "memory") #elif defined(__GNUC__) && defined(__ppc64__) #define Read_and_clear(dst,src) \ asm("0: ldarx %0, 0, %1\n\t" \ "stdcx. %2, 0, %1\n\t" \ "bne- 0b" \ : "=&r" (dst) \ : "r" (&(src)), "r" (0) \ : "cr0", "memory") #else /* Default, non-atomic implementation */ #define Read_and_clear(dst,src) ((dst) = (src), (src) = 0) #endif #endif /* CAML_SIGNALS_MACHDEP_H */ mingw-ocaml/ocaml/byterun/sys.h0000644000175000017500000000230712124403240016136 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_SYS_H #define CAML_SYS_H #include "misc.h" #define NO_ARG Val_int(0) CAMLextern void caml_sys_error (value); CAMLextern void caml_sys_io_error (value); extern void caml_sys_init (char * exe_name, char ** argv); CAMLextern value caml_sys_exit (value); extern char * caml_exe_name; #endif /* CAML_SYS_H */ mingw-ocaml/ocaml/byterun/intern.c0000644000175000017500000006432212124403240016617 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Structured input, compact format */ /* The interface of this file is "intext.h" */ #include #include #include "alloc.h" #include "callback.h" #include "custom.h" #include "fail.h" #include "gc.h" #include "intext.h" #include "io.h" #include "md5.h" #include "memory.h" #include "mlvalues.h" #include "misc.h" #include "reverse.h" static unsigned char * intern_src; /* Reading pointer in block holding input data. */ static unsigned char * intern_input; /* Pointer to beginning of block holding input data. Meaningful only if intern_input_malloced = 1. */ static int intern_input_malloced; /* 1 if intern_input was allocated by caml_stat_alloc() and needs caml_stat_free() on error, 0 otherwise. */ static header_t * intern_dest; /* Writing pointer in destination block */ static char * intern_extra_block; /* If non-NULL, point to new heap chunk allocated with caml_alloc_for_heap. */ static asize_t obj_counter; /* Count how many objects seen so far */ static value * intern_obj_table; /* The pointers to objects already seen */ static unsigned int intern_color; /* Color to assign to newly created headers */ static header_t intern_header; /* Original header of the destination block. Meaningful only if intern_extra_block is NULL. */ static value intern_block; /* Point to the heap block allocated as destination block. Meaningful only if intern_extra_block is NULL. */ static value * camlinternaloo_last_id = NULL; /* Pointer to a reference holding the last object id. -1 means not available (CamlinternalOO not loaded). */ static char * intern_resolve_code_pointer(unsigned char digest[16], asize_t offset); static void intern_bad_code_pointer(unsigned char digest[16]) Noreturn; static void intern_free_stack(void); #define Sign_extend_shift ((sizeof(intnat) - 1) * 8) #define Sign_extend(x) (((intnat)(x) << Sign_extend_shift) >> Sign_extend_shift) #define read8u() (*intern_src++) #define read8s() Sign_extend(*intern_src++) #define read16u() \ (intern_src += 2, \ (intern_src[-2] << 8) + intern_src[-1]) #define read16s() \ (intern_src += 2, \ (Sign_extend(intern_src[-2]) << 8) + intern_src[-1]) #define read32u() \ (intern_src += 4, \ ((uintnat)(intern_src[-4]) << 24) + (intern_src[-3] << 16) + \ (intern_src[-2] << 8) + intern_src[-1]) #define read32s() \ (intern_src += 4, \ (Sign_extend(intern_src[-4]) << 24) + (intern_src[-3] << 16) + \ (intern_src[-2] << 8) + intern_src[-1]) #ifdef ARCH_SIXTYFOUR static intnat read64s(void) { intnat res; int i; res = 0; for (i = 0; i < 8; i++) res = (res << 8) + intern_src[i]; intern_src += 8; return res; } #endif #define readblock(dest,len) \ (memmove((dest), intern_src, (len)), intern_src += (len)) static void intern_cleanup(void) { if (intern_input_malloced) caml_stat_free(intern_input); if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); if (intern_extra_block != NULL) { /* free newly allocated heap chunk */ caml_free_for_heap(intern_extra_block); } else if (intern_block != 0) { /* restore original header for heap block, otherwise GC is confused */ Hd_val(intern_block) = intern_header; } /* free the recursion stack */ intern_free_stack(); } static void readfloat(double * dest, unsigned int code) { if (sizeof(double) != 8) { intern_cleanup(); caml_invalid_argument("input_value: non-standard floats"); } readblock((char *) dest, 8); /* Fix up endianness, if needed */ #if ARCH_FLOAT_ENDIANNESS == 0x76543210 /* Host is big-endian; fix up if data read is little-endian */ if (code != CODE_DOUBLE_BIG) Reverse_64(dest, dest); #elif ARCH_FLOAT_ENDIANNESS == 0x01234567 /* Host is little-endian; fix up if data read is big-endian */ if (code != CODE_DOUBLE_LITTLE) Reverse_64(dest, dest); #else /* Host is neither big nor little; permute as appropriate */ if (code == CODE_DOUBLE_LITTLE) Permute_64(dest, ARCH_FLOAT_ENDIANNESS, dest, 0x01234567) else Permute_64(dest, ARCH_FLOAT_ENDIANNESS, dest, 0x76543210); #endif } static void readfloats(double * dest, mlsize_t len, unsigned int code) { mlsize_t i; if (sizeof(double) != 8) { intern_cleanup(); caml_invalid_argument("input_value: non-standard floats"); } readblock((char *) dest, len * 8); /* Fix up endianness, if needed */ #if ARCH_FLOAT_ENDIANNESS == 0x76543210 /* Host is big-endian; fix up if data read is little-endian */ if (code != CODE_DOUBLE_ARRAY8_BIG && code != CODE_DOUBLE_ARRAY32_BIG) { for (i = 0; i < len; i++) Reverse_64(dest + i, dest + i); } #elif ARCH_FLOAT_ENDIANNESS == 0x01234567 /* Host is little-endian; fix up if data read is big-endian */ if (code != CODE_DOUBLE_ARRAY8_LITTLE && code != CODE_DOUBLE_ARRAY32_LITTLE) { for (i = 0; i < len; i++) Reverse_64(dest + i, dest + i); } #else /* Host is neither big nor little; permute as appropriate */ if (code == CODE_DOUBLE_ARRAY8_LITTLE || code == CODE_DOUBLE_ARRAY32_LITTLE) { for (i = 0; i < len; i++) Permute_64(dest + i, ARCH_FLOAT_ENDIANNESS, dest + i, 0x01234567); } else { for (i = 0; i < len; i++) Permute_64(dest + i, ARCH_FLOAT_ENDIANNESS, dest + i, 0x76543210); } #endif } /* Item on the stack with defined operation */ struct intern_item { value * dest; intnat arg; enum { OReadItems, /* read arg items and store them in dest[0], dest[1], ... */ OFreshOID, /* generate a fresh OID and store it in *dest */ OShift /* offset *dest by arg */ } op; }; /* FIXME: This is duplicated in two other places, with the only difference of the type of elements stored in the stack. Possible solution in C would be to instantiate stack these function via. C preprocessor macro. */ #define INTERN_STACK_INIT_SIZE 256 #define INTERN_STACK_MAX_SIZE (1024*1024*100) static struct intern_item intern_stack_init[INTERN_STACK_INIT_SIZE]; static struct intern_item * intern_stack = intern_stack_init; static struct intern_item * intern_stack_limit = intern_stack_init + INTERN_STACK_INIT_SIZE; /* Free the recursion stack if needed */ static void intern_free_stack(void) { if (intern_stack != intern_stack_init) { free(intern_stack); /* Reinitialize the globals for next time around */ intern_stack = intern_stack_init; intern_stack_limit = intern_stack + INTERN_STACK_INIT_SIZE; } } /* Same, then raise Out_of_memory */ static void intern_stack_overflow(void) { caml_gc_message (0x04, "Stack overflow in un-marshaling value\n", 0); intern_free_stack(); caml_raise_out_of_memory(); } static struct intern_item * intern_resize_stack(struct intern_item * sp) { asize_t newsize = 2 * (intern_stack_limit - intern_stack); asize_t sp_offset = sp - intern_stack; struct intern_item * newstack; if (newsize >= INTERN_STACK_MAX_SIZE) intern_stack_overflow(); if (intern_stack == intern_stack_init) { newstack = malloc(sizeof(struct intern_item) * newsize); if (newstack == NULL) intern_stack_overflow(); memcpy(newstack, intern_stack_init, sizeof(struct intern_item) * INTERN_STACK_INIT_SIZE); } else { newstack = realloc(intern_stack, sizeof(struct intern_item) * newsize); if (newstack == NULL) intern_stack_overflow(); } intern_stack = newstack; intern_stack_limit = newstack + newsize; return newstack + sp_offset; } /* Convenience macros for requesting operation on the stack */ #define PushItem() \ do { \ sp++; \ if (sp >= intern_stack_limit) sp = intern_resize_stack(sp); \ } while(0) #define ReadItems(_dest,_n) \ do { \ if (_n > 0) { \ PushItem(); \ sp->op = OReadItems; \ sp->dest = _dest; \ sp->arg = _n; \ } \ } while(0) static void intern_rec(value *dest) { unsigned int code; tag_t tag; mlsize_t size, len, ofs_ind; value v; asize_t ofs; header_t header; unsigned char digest[16]; struct custom_operations * ops; char * codeptr; struct intern_item * sp; sp = intern_stack; /* Initially let's try to read the first object from the stream */ ReadItems(dest, 1); /* The un-marshaler loop, the recursion is unrolled */ while(sp != intern_stack) { /* Interpret next item on the stack */ dest = sp->dest; switch (sp->op) { case OFreshOID: /* Refresh the object ID */ if (camlinternaloo_last_id == NULL) { camlinternaloo_last_id = caml_named_value("CamlinternalOO.last_id"); if (camlinternaloo_last_id == NULL) camlinternaloo_last_id = (value*) (-1); } if (camlinternaloo_last_id != (value*) (-1)) { value id = Field(*camlinternaloo_last_id,0); Field(dest, 0) = id; Field(*camlinternaloo_last_id,0) = id + 2; } /* Pop item and iterate */ sp--; break; case OShift: /* Shift value by an offset */ *dest += sp->arg; /* Pop item and iterate */ sp--; break; case OReadItems: /* Pop item */ sp->dest++; if (--(sp->arg) == 0) sp--; /* Read a value and set v to this value */ code = read8u(); if (code >= PREFIX_SMALL_INT) { if (code >= PREFIX_SMALL_BLOCK) { /* Small block */ tag = code & 0xF; size = (code >> 4) & 0x7; read_block: if (size == 0) { v = Atom(tag); } else { v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; *intern_dest = Make_header(size, tag, intern_color); intern_dest += 1 + size; /* For objects, we need to freshen the oid */ if (tag == Object_tag) { Assert(size >= 2); /* Request to read rest of the elements of the block */ ReadItems(&Field(v, 2), size - 2); /* Request freshing OID */ PushItem(); sp->op = OFreshOID; sp->dest = &Field(v, 1); sp->arg = 1; /* Finally read first two block elements: method table and old OID */ ReadItems(&Field(v, 0), 2); } else /* If it's not an object then read the contents of the block */ ReadItems(&Field(v, 0), size); } } else { /* Small integer */ v = Val_int(code & 0x3F); } } else { if (code >= PREFIX_SMALL_STRING) { /* Small string */ len = (code & 0x1F); read_string: size = (len + sizeof(value)) / sizeof(value); v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; *intern_dest = Make_header(size, String_tag, intern_color); intern_dest += 1 + size; Field(v, size - 1) = 0; ofs_ind = Bsize_wsize(size) - 1; Byte(v, ofs_ind) = ofs_ind - len; readblock(String_val(v), len); } else { switch(code) { case CODE_INT8: v = Val_long(read8s()); break; case CODE_INT16: v = Val_long(read16s()); break; case CODE_INT32: v = Val_long(read32s()); break; case CODE_INT64: #ifdef ARCH_SIXTYFOUR v = Val_long(read64s()); break; #else intern_cleanup(); caml_failwith("input_value: integer too large"); break; #endif case CODE_SHARED8: ofs = read8u(); read_shared: Assert (ofs > 0); Assert (ofs <= obj_counter); Assert (intern_obj_table != NULL); v = intern_obj_table[obj_counter - ofs]; break; case CODE_SHARED16: ofs = read16u(); goto read_shared; case CODE_SHARED32: ofs = read32u(); goto read_shared; case CODE_BLOCK32: header = (header_t) read32u(); tag = Tag_hd(header); size = Wosize_hd(header); goto read_block; case CODE_BLOCK64: #ifdef ARCH_SIXTYFOUR header = (header_t) read64s(); tag = Tag_hd(header); size = Wosize_hd(header); goto read_block; #else intern_cleanup(); caml_failwith("input_value: data block too large"); break; #endif case CODE_STRING8: len = read8u(); goto read_string; case CODE_STRING32: len = read32u(); goto read_string; case CODE_DOUBLE_LITTLE: case CODE_DOUBLE_BIG: v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; *intern_dest = Make_header(Double_wosize, Double_tag, intern_color); intern_dest += 1 + Double_wosize; readfloat((double *) v, code); break; case CODE_DOUBLE_ARRAY8_LITTLE: case CODE_DOUBLE_ARRAY8_BIG: len = read8u(); read_double_array: size = len * Double_wosize; v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; *intern_dest = Make_header(size, Double_array_tag, intern_color); intern_dest += 1 + size; readfloats((double *) v, len, code); break; case CODE_DOUBLE_ARRAY32_LITTLE: case CODE_DOUBLE_ARRAY32_BIG: len = read32u(); goto read_double_array; case CODE_CODEPOINTER: ofs = read32u(); readblock(digest, 16); codeptr = intern_resolve_code_pointer(digest, ofs); if (codeptr != NULL) { v = (value) codeptr; } else { value * function_placeholder = caml_named_value ("Debugger.function_placeholder"); if (function_placeholder != NULL) { v = *function_placeholder; } else { intern_cleanup(); intern_bad_code_pointer(digest); } } break; case CODE_INFIXPOINTER: ofs = read32u(); /* Read a value to *dest, then offset *dest by ofs */ PushItem(); sp->dest = dest; sp->op = OShift; sp->arg = ofs; ReadItems(dest, 1); continue; /* with next iteration of main loop, skipping *dest = v */ case CODE_CUSTOM: ops = caml_find_custom_operations((char *) intern_src); if (ops == NULL) { intern_cleanup(); caml_failwith("input_value: unknown custom block identifier"); } while (*intern_src++ != 0) /*nothing*/; /*skip identifier*/ size = ops->deserialize((void *) (intern_dest + 2)); size = 1 + (size + sizeof(value) - 1) / sizeof(value); v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; *intern_dest = Make_header(size, Custom_tag, intern_color); Custom_ops_val(v) = ops; intern_dest += 1 + size; break; default: intern_cleanup(); caml_failwith("input_value: ill-formed message"); } } } /* end of case OReadItems */ *dest = v; break; default: Assert(0); } } /* We are done. Cleanup the stack and leave the function */ intern_free_stack(); } static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) { mlsize_t wosize; if (camlinternaloo_last_id == (value*)-1) camlinternaloo_last_id = NULL; /* Reset ignore flag */ if (whsize == 0) { intern_obj_table = NULL; intern_extra_block = NULL; intern_block = 0; return; } wosize = Wosize_whsize(whsize); if (wosize > Max_wosize) { /* Round desired size up to next page */ asize_t request = ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log; intern_extra_block = caml_alloc_for_heap(request); if (intern_extra_block == NULL) caml_raise_out_of_memory(); intern_color = caml_allocation_color(intern_extra_block); intern_dest = (header_t *) intern_extra_block; } else { /* this is a specialised version of caml_alloc from alloc.c */ if (wosize == 0){ intern_block = Atom (String_tag); }else if (wosize <= Max_young_wosize){ intern_block = caml_alloc_small (wosize, String_tag); }else{ intern_block = caml_alloc_shr (wosize, String_tag); /* do not do the urgent_gc check here because it might darken intern_block into gray and break the Assert 3 lines down */ } intern_header = Hd_val(intern_block); intern_color = Color_hd(intern_header); Assert (intern_color == Caml_white || intern_color == Caml_black); intern_dest = (header_t *) Hp_val(intern_block); intern_extra_block = NULL; } obj_counter = 0; if (num_objects > 0) intern_obj_table = (value *) caml_stat_alloc(num_objects * sizeof(value)); else intern_obj_table = NULL; } static void intern_add_to_heap(mlsize_t whsize) { /* Add new heap chunk to heap if needed */ if (intern_extra_block != NULL) { /* If heap chunk not filled totally, build free block at end */ asize_t request = ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log; header_t * end_extra_block = (header_t *) intern_extra_block + Wsize_bsize(request); Assert(intern_dest <= end_extra_block); if (intern_dest < end_extra_block){ caml_make_free_blocks ((value *) intern_dest, end_extra_block - intern_dest, 0, Caml_white); } caml_allocated_words += Wsize_bsize ((char *) intern_dest - intern_extra_block); caml_add_to_heap(intern_extra_block); } } value caml_input_val(struct channel *chan) { uint32 magic; mlsize_t block_len, num_objects, size_32, size_64, whsize; char * block; value res; if (! caml_channel_binary_mode(chan)) caml_failwith("input_value: not a binary channel"); magic = caml_getword(chan); if (magic != Intext_magic_number) caml_failwith("input_value: bad object"); block_len = caml_getword(chan); num_objects = caml_getword(chan); size_32 = caml_getword(chan); size_64 = caml_getword(chan); /* Read block from channel */ block = caml_stat_alloc(block_len); /* During [caml_really_getblock], concurrent [caml_input_val] operations can take place (via signal handlers or context switching in systhreads), and [intern_input] may change. So, wait until [caml_really_getblock] is over before using [intern_input] and the other global vars. */ if (caml_really_getblock(chan, block, block_len) == 0) { caml_stat_free(block); caml_failwith("input_value: truncated object"); } intern_input = (unsigned char *) block; intern_input_malloced = 1; intern_src = intern_input; /* Allocate result */ #ifdef ARCH_SIXTYFOUR whsize = size_64; #else whsize = size_32; #endif intern_alloc(whsize, num_objects); /* Fill it in */ intern_rec(&res); intern_add_to_heap(whsize); /* Free everything */ caml_stat_free(intern_input); if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); return res; } CAMLprim value caml_input_value(value vchan) { CAMLparam1 (vchan); struct channel * chan = Channel(vchan); CAMLlocal1 (res); Lock(chan); res = caml_input_val(chan); Unlock(chan); CAMLreturn (res); } CAMLexport value caml_input_val_from_string(value str, intnat ofs) { CAMLparam1 (str); mlsize_t num_objects, size_32, size_64, whsize; CAMLlocal1 (obj); intern_src = &Byte_u(str, ofs + 2*4); intern_input_malloced = 0; num_objects = read32u(); size_32 = read32u(); size_64 = read32u(); /* Allocate result */ #ifdef ARCH_SIXTYFOUR whsize = size_64; #else whsize = size_32; #endif intern_alloc(whsize, num_objects); intern_src = &Byte_u(str, ofs + 5*4); /* If a GC occurred */ /* Fill it in */ intern_rec(&obj); intern_add_to_heap(whsize); /* Free everything */ if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); CAMLreturn (obj); } CAMLprim value caml_input_value_from_string(value str, value ofs) { return caml_input_val_from_string(str, Long_val(ofs)); } static value input_val_from_block(void) { mlsize_t num_objects, size_32, size_64, whsize; value obj; num_objects = read32u(); size_32 = read32u(); size_64 = read32u(); /* Allocate result */ #ifdef ARCH_SIXTYFOUR whsize = size_64; #else whsize = size_32; #endif intern_alloc(whsize, num_objects); /* Fill it in */ intern_rec(&obj); intern_add_to_heap(whsize); /* Free internal data structures */ if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); return obj; } CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs) { uint32 magic; mlsize_t block_len; value obj; intern_input = (unsigned char *) data; intern_src = intern_input + ofs; intern_input_malloced = 1; magic = read32u(); if (magic != Intext_magic_number) caml_failwith("input_value_from_malloc: bad object"); block_len = read32u(); obj = input_val_from_block(); /* Free the input */ caml_stat_free(intern_input); return obj; } CAMLexport value caml_input_value_from_block(char * data, intnat len) { uint32 magic; mlsize_t block_len; value obj; intern_input = (unsigned char *) data; intern_src = intern_input; intern_input_malloced = 0; magic = read32u(); if (magic != Intext_magic_number) caml_failwith("input_value_from_block: bad object"); block_len = read32u(); if (5*4 + block_len > len) caml_failwith("input_value_from_block: bad block length"); obj = input_val_from_block(); return obj; } CAMLprim value caml_marshal_data_size(value buff, value ofs) { uint32 magic; mlsize_t block_len; intern_src = &Byte_u(buff, Long_val(ofs)); intern_input_malloced = 0; magic = read32u(); if (magic != Intext_magic_number){ caml_failwith("Marshal.data_size: bad object"); } block_len = read32u(); return Val_long(block_len); } /* Resolution of code pointers */ static char * intern_resolve_code_pointer(unsigned char digest[16], asize_t offset) { int i; for (i = caml_code_fragments_table.size - 1; i >= 0; i--) { struct code_fragment * cf = caml_code_fragments_table.contents[i]; if (! cf->digest_computed) { caml_md5_block(cf->digest, cf->code_start, cf->code_end - cf->code_start); cf->digest_computed = 1; } if (memcmp(digest, cf->digest, 16) == 0) { if (cf->code_start + offset < cf->code_end) return cf->code_start + offset; else return NULL; } } return NULL; } static void intern_bad_code_pointer(unsigned char digest[16]) { char msg[256]; sprintf(msg, "input_value: unknown code module %02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X", digest[0], digest[1], digest[2], digest[3], digest[4], digest[5], digest[6], digest[7], digest[8], digest[9], digest[10], digest[11], digest[12], digest[13], digest[14], digest[15]); caml_failwith(msg); } /* Functions for writing user-defined marshallers */ CAMLexport int caml_deserialize_uint_1(void) { return read8u(); } CAMLexport int caml_deserialize_sint_1(void) { return read8s(); } CAMLexport int caml_deserialize_uint_2(void) { return read16u(); } CAMLexport int caml_deserialize_sint_2(void) { return read16s(); } CAMLexport uint32 caml_deserialize_uint_4(void) { return read32u(); } CAMLexport int32 caml_deserialize_sint_4(void) { return read32s(); } CAMLexport uint64 caml_deserialize_uint_8(void) { uint64 i; caml_deserialize_block_8(&i, 1); return i; } CAMLexport int64 caml_deserialize_sint_8(void) { int64 i; caml_deserialize_block_8(&i, 1); return i; } CAMLexport float caml_deserialize_float_4(void) { float f; caml_deserialize_block_4(&f, 1); return f; } CAMLexport double caml_deserialize_float_8(void) { double f; caml_deserialize_block_float_8(&f, 1); return f; } CAMLexport void caml_deserialize_block_1(void * data, intnat len) { memmove(data, intern_src, len); intern_src += len; } CAMLexport void caml_deserialize_block_2(void * data, intnat len) { #ifndef ARCH_BIG_ENDIAN unsigned char * p, * q; for (p = intern_src, q = data; len > 0; len--, p += 2, q += 2) Reverse_16(q, p); intern_src = p; #else memmove(data, intern_src, len * 2); intern_src += len * 2; #endif } CAMLexport void caml_deserialize_block_4(void * data, intnat len) { #ifndef ARCH_BIG_ENDIAN unsigned char * p, * q; for (p = intern_src, q = data; len > 0; len--, p += 4, q += 4) Reverse_32(q, p); intern_src = p; #else memmove(data, intern_src, len * 4); intern_src += len * 4; #endif } CAMLexport void caml_deserialize_block_8(void * data, intnat len) { #ifndef ARCH_BIG_ENDIAN unsigned char * p, * q; for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8) Reverse_64(q, p); intern_src = p; #else memmove(data, intern_src, len * 8); intern_src += len * 8; #endif } CAMLexport void caml_deserialize_block_float_8(void * data, intnat len) { #if ARCH_FLOAT_ENDIANNESS == 0x01234567 memmove(data, intern_src, len * 8); intern_src += len * 8; #elif ARCH_FLOAT_ENDIANNESS == 0x76543210 unsigned char * p, * q; for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8) Reverse_64(q, p); intern_src = p; #else unsigned char * p, * q; for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8) Permute_64(q, ARCH_FLOAT_ENDIANNESS, p, 0x01234567); intern_src = p; #endif } CAMLexport void caml_deserialize_error(char * msg) { intern_cleanup(); caml_failwith(msg); } mingw-ocaml/ocaml/byterun/ints.c0000644000175000017500000005423412124403240016276 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "alloc.h" #include "custom.h" #include "fail.h" #include "intext.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" static char * parse_sign_and_base(char * p, /*out*/ int * base, /*out*/ int * sign) { *sign = 1; if (*p == '-') { *sign = -1; p++; } *base = 10; if (*p == '0') { switch (p[1]) { case 'x': case 'X': *base = 16; p += 2; break; case 'o': case 'O': *base = 8; p += 2; break; case 'b': case 'B': *base = 2; p += 2; break; } } return p; } static int parse_digit(char c) { if (c >= '0' && c <= '9') return c - '0'; else if (c >= 'A' && c <= 'F') return c - 'A' + 10; else if (c >= 'a' && c <= 'f') return c - 'a' + 10; else return -1; } static intnat parse_intnat(value s, int nbits) { char * p; uintnat res, threshold; int sign, base, d; p = parse_sign_and_base(String_val(s), &base, &sign); threshold = ((uintnat) -1) / base; d = parse_digit(*p); if (d < 0 || d >= base) caml_failwith("int_of_string"); for (p++, res = d; /*nothing*/; p++) { char c = *p; if (c == '_') continue; d = parse_digit(c); if (d < 0 || d >= base) break; /* Detect overflow in multiplication base * res */ if (res > threshold) caml_failwith("int_of_string"); res = base * res + d; /* Detect overflow in addition (base * res) + d */ if (res < (uintnat) d) caml_failwith("int_of_string"); } if (p != String_val(s) + caml_string_length(s)){ caml_failwith("int_of_string"); } if (base == 10) { /* Signed representation expected, allow -2^(nbits-1) to 2^(nbits-1) - 1 */ if (sign >= 0) { if (res >= (uintnat)1 << (nbits - 1)) caml_failwith("int_of_string"); } else { if (res > (uintnat)1 << (nbits - 1)) caml_failwith("int_of_string"); } } else { /* Unsigned representation expected, allow 0 to 2^nbits - 1 and tolerate -(2^nbits - 1) to 0 */ if (nbits < sizeof(uintnat) * 8 && res >= (uintnat)1 << nbits) caml_failwith("int_of_string"); } return sign < 0 ? -((intnat) res) : (intnat) res; } #ifdef NONSTANDARD_DIV_MOD intnat caml_safe_div(intnat p, intnat q) { uintnat ap = p >= 0 ? p : -p; uintnat aq = q >= 0 ? q : -q; uintnat ar = ap / aq; return (p ^ q) >= 0 ? ar : -ar; } intnat caml_safe_mod(intnat p, intnat q) { uintnat ap = p >= 0 ? p : -p; uintnat aq = q >= 0 ? q : -q; uintnat ar = ap % aq; return p >= 0 ? ar : -ar; } #endif /* Tagged integers */ CAMLprim value caml_int_compare(value v1, value v2) { int res = (v1 > v2) - (v1 < v2); return Val_int(res); } CAMLprim value caml_int_of_string(value s) { return Val_long(parse_intnat(s, 8 * sizeof(value) - 1)); } #define FORMAT_BUFFER_SIZE 32 static char * parse_format(value fmt, char * suffix, char format_string[], char default_format_buffer[], char *conv) { int prec; char * p; char lastletter; mlsize_t len, len_suffix; /* Copy OCaml format fmt to format_string, adding the suffix before the last letter of the format */ len = caml_string_length(fmt); len_suffix = strlen(suffix); if (len + len_suffix + 1 >= FORMAT_BUFFER_SIZE) caml_invalid_argument("format_int: format too long"); memmove(format_string, String_val(fmt), len); p = format_string + len - 1; lastletter = *p; /* Compress two-letter formats, ignoring the [lnL] annotation */ if (p[-1] == 'l' || p[-1] == 'n' || p[-1] == 'L') p--; memmove(p, suffix, len_suffix); p += len_suffix; *p++ = lastletter; *p = 0; /* Determine space needed for result and allocate it dynamically if needed */ prec = 22 + 5; /* 22 digits for 64-bit number in octal + 5 extra */ for (p = String_val(fmt); *p != 0; p++) { if (*p >= '0' && *p <= '9') { prec = atoi(p) + 5; break; } } *conv = lastletter; if (prec < FORMAT_BUFFER_SIZE) return default_format_buffer; else return caml_stat_alloc(prec + 1); } CAMLprim value caml_format_int(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; char default_format_buffer[FORMAT_BUFFER_SIZE]; char * buffer; char conv; value res; buffer = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, format_string, default_format_buffer, &conv); switch (conv) { case 'u': case 'x': case 'X': case 'o': sprintf(buffer, format_string, Unsigned_long_val(arg)); break; default: sprintf(buffer, format_string, Long_val(arg)); break; } res = caml_copy_string(buffer); if (buffer != default_format_buffer) caml_stat_free(buffer); return res; } /* 32-bit integers */ static int int32_cmp(value v1, value v2) { int32 i1 = Int32_val(v1); int32 i2 = Int32_val(v2); return (i1 > i2) - (i1 < i2); } static intnat int32_hash(value v) { return Int32_val(v); } static void int32_serialize(value v, uintnat * wsize_32, uintnat * wsize_64) { caml_serialize_int_4(Int32_val(v)); *wsize_32 = *wsize_64 = 4; } static uintnat int32_deserialize(void * dst) { *((int32 *) dst) = caml_deserialize_sint_4(); return 4; } CAMLexport struct custom_operations caml_int32_ops = { "_i", custom_finalize_default, int32_cmp, int32_hash, int32_serialize, int32_deserialize, custom_compare_ext_default }; CAMLexport value caml_copy_int32(int32 i) { value res = caml_alloc_custom(&caml_int32_ops, 4, 0, 1); Int32_val(res) = i; return res; } CAMLprim value caml_int32_neg(value v) { return caml_copy_int32(- Int32_val(v)); } CAMLprim value caml_int32_add(value v1, value v2) { return caml_copy_int32(Int32_val(v1) + Int32_val(v2)); } CAMLprim value caml_int32_sub(value v1, value v2) { return caml_copy_int32(Int32_val(v1) - Int32_val(v2)); } CAMLprim value caml_int32_mul(value v1, value v2) { return caml_copy_int32(Int32_val(v1) * Int32_val(v2)); } CAMLprim value caml_int32_div(value v1, value v2) { int32 dividend = Int32_val(v1); int32 divisor = Int32_val(v2); if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ if (dividend == (1<<31) && divisor == -1) return v1; #ifdef NONSTANDARD_DIV_MOD return caml_copy_int32(caml_safe_div(dividend, divisor)); #else return caml_copy_int32(dividend / divisor); #endif } CAMLprim value caml_int32_mod(value v1, value v2) { int32 dividend = Int32_val(v1); int32 divisor = Int32_val(v2); if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, modulus crashes if division overflows. Implement the same behavior as for type "int". */ if (dividend == (1<<31) && divisor == -1) return caml_copy_int32(0); #ifdef NONSTANDARD_DIV_MOD return caml_copy_int32(caml_safe_mod(dividend, divisor)); #else return caml_copy_int32(dividend % divisor); #endif } CAMLprim value caml_int32_and(value v1, value v2) { return caml_copy_int32(Int32_val(v1) & Int32_val(v2)); } CAMLprim value caml_int32_or(value v1, value v2) { return caml_copy_int32(Int32_val(v1) | Int32_val(v2)); } CAMLprim value caml_int32_xor(value v1, value v2) { return caml_copy_int32(Int32_val(v1) ^ Int32_val(v2)); } CAMLprim value caml_int32_shift_left(value v1, value v2) { return caml_copy_int32(Int32_val(v1) << Int_val(v2)); } CAMLprim value caml_int32_shift_right(value v1, value v2) { return caml_copy_int32(Int32_val(v1) >> Int_val(v2)); } CAMLprim value caml_int32_shift_right_unsigned(value v1, value v2) { return caml_copy_int32((uint32)Int32_val(v1) >> Int_val(v2)); } CAMLprim value caml_int32_of_int(value v) { return caml_copy_int32(Long_val(v)); } CAMLprim value caml_int32_to_int(value v) { return Val_long(Int32_val(v)); } CAMLprim value caml_int32_of_float(value v) { return caml_copy_int32((int32)(Double_val(v))); } CAMLprim value caml_int32_to_float(value v) { return caml_copy_double((double)(Int32_val(v))); } CAMLprim value caml_int32_compare(value v1, value v2) { int32 i1 = Int32_val(v1); int32 i2 = Int32_val(v2); int res = (i1 > i2) - (i1 < i2); return Val_int(res); } CAMLprim value caml_int32_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; char default_format_buffer[FORMAT_BUFFER_SIZE]; char * buffer; char conv; value res; buffer = parse_format(fmt, ARCH_INT32_PRINTF_FORMAT, format_string, default_format_buffer, &conv); sprintf(buffer, format_string, Int32_val(arg)); res = caml_copy_string(buffer); if (buffer != default_format_buffer) caml_stat_free(buffer); return res; } CAMLprim value caml_int32_of_string(value s) { return caml_copy_int32(parse_intnat(s, 32)); } CAMLprim value caml_int32_bits_of_float(value vd) { union { float d; int32 i; } u; u.d = Double_val(vd); return caml_copy_int32(u.i); } CAMLprim value caml_int32_float_of_bits(value vi) { union { float d; int32 i; } u; u.i = Int32_val(vi); return caml_copy_double(u.d); } /* 64-bit integers */ #ifdef ARCH_INT64_TYPE #include "int64_native.h" #else #include "int64_emul.h" #endif #ifdef ARCH_ALIGN_INT64 CAMLexport int64 caml_Int64_val(value v) { union { int32 i[2]; int64 j; } buffer; buffer.i[0] = ((int32 *) Data_custom_val(v))[0]; buffer.i[1] = ((int32 *) Data_custom_val(v))[1]; return buffer.j; } #endif static int int64_cmp(value v1, value v2) { int64 i1 = Int64_val(v1); int64 i2 = Int64_val(v2); return I64_compare(i1, i2); } static intnat int64_hash(value v) { int64 x = Int64_val(v); uint32 lo, hi; I64_split(x, hi, lo); return hi ^ lo; } static void int64_serialize(value v, uintnat * wsize_32, uintnat * wsize_64) { caml_serialize_int_8(Int64_val(v)); *wsize_32 = *wsize_64 = 8; } static uintnat int64_deserialize(void * dst) { #ifndef ARCH_ALIGN_INT64 *((int64 *) dst) = caml_deserialize_sint_8(); #else union { int32 i[2]; int64 j; } buffer; buffer.j = caml_deserialize_sint_8(); ((int32 *) dst)[0] = buffer.i[0]; ((int32 *) dst)[1] = buffer.i[1]; #endif return 8; } CAMLexport struct custom_operations caml_int64_ops = { "_j", custom_finalize_default, int64_cmp, int64_hash, int64_serialize, int64_deserialize, custom_compare_ext_default }; CAMLexport value caml_copy_int64(int64 i) { value res = caml_alloc_custom(&caml_int64_ops, 8, 0, 1); #ifndef ARCH_ALIGN_INT64 Int64_val(res) = i; #else union { int32 i[2]; int64 j; } buffer; buffer.j = i; ((int32 *) Data_custom_val(res))[0] = buffer.i[0]; ((int32 *) Data_custom_val(res))[1] = buffer.i[1]; #endif return res; } CAMLprim value caml_int64_neg(value v) { return caml_copy_int64(I64_neg(Int64_val(v))); } CAMLprim value caml_int64_add(value v1, value v2) { return caml_copy_int64(I64_add(Int64_val(v1), Int64_val(v2))); } CAMLprim value caml_int64_sub(value v1, value v2) { return caml_copy_int64(I64_sub(Int64_val(v1), Int64_val(v2))); } CAMLprim value caml_int64_mul(value v1, value v2) { return caml_copy_int64(I64_mul(Int64_val(v1), Int64_val(v2))); } CAMLprim value caml_int64_div(value v1, value v2) { int64 dividend = Int64_val(v1); int64 divisor = Int64_val(v2); if (I64_is_zero(divisor)) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ if (I64_is_min_int(dividend) && I64_is_minus_one(divisor)) return v1; return caml_copy_int64(I64_div(Int64_val(v1), divisor)); } CAMLprim value caml_int64_mod(value v1, value v2) { int64 dividend = Int64_val(v1); int64 divisor = Int64_val(v2); if (I64_is_zero(divisor)) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ if (I64_is_min_int(dividend) && I64_is_minus_one(divisor)) { int64 zero = I64_literal(0,0); return caml_copy_int64(zero); } return caml_copy_int64(I64_mod(Int64_val(v1), divisor)); } CAMLprim value caml_int64_and(value v1, value v2) { return caml_copy_int64(I64_and(Int64_val(v1), Int64_val(v2))); } CAMLprim value caml_int64_or(value v1, value v2) { return caml_copy_int64(I64_or(Int64_val(v1), Int64_val(v2))); } CAMLprim value caml_int64_xor(value v1, value v2) { return caml_copy_int64(I64_xor(Int64_val(v1), Int64_val(v2))); } CAMLprim value caml_int64_shift_left(value v1, value v2) { return caml_copy_int64(I64_lsl(Int64_val(v1), Int_val(v2))); } CAMLprim value caml_int64_shift_right(value v1, value v2) { return caml_copy_int64(I64_asr(Int64_val(v1), Int_val(v2))); } CAMLprim value caml_int64_shift_right_unsigned(value v1, value v2) { return caml_copy_int64(I64_lsr(Int64_val(v1), Int_val(v2))); } CAMLprim value caml_int64_of_int(value v) { return caml_copy_int64(I64_of_intnat(Long_val(v))); } CAMLprim value caml_int64_to_int(value v) { return Val_long(I64_to_intnat(Int64_val(v))); } CAMLprim value caml_int64_of_float(value v) { return caml_copy_int64(I64_of_double(Double_val(v))); } CAMLprim value caml_int64_to_float(value v) { int64 i = Int64_val(v); return caml_copy_double(I64_to_double(i)); } CAMLprim value caml_int64_of_int32(value v) { return caml_copy_int64(I64_of_int32(Int32_val(v))); } CAMLprim value caml_int64_to_int32(value v) { return caml_copy_int32(I64_to_int32(Int64_val(v))); } CAMLprim value caml_int64_of_nativeint(value v) { return caml_copy_int64(I64_of_intnat(Nativeint_val(v))); } CAMLprim value caml_int64_to_nativeint(value v) { return caml_copy_nativeint(I64_to_intnat(Int64_val(v))); } CAMLprim value caml_int64_compare(value v1, value v2) { int64 i1 = Int64_val(v1); int64 i2 = Int64_val(v2); return Val_int(I64_compare(i1, i2)); } #ifdef ARCH_INT64_PRINTF_FORMAT #define I64_format(buf,fmt,x) sprintf(buf,fmt,x) #else #include "int64_format.h" #define ARCH_INT64_PRINTF_FORMAT "" #endif CAMLprim value caml_int64_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; char default_format_buffer[FORMAT_BUFFER_SIZE]; char * buffer; char conv; value res; buffer = parse_format(fmt, ARCH_INT64_PRINTF_FORMAT, format_string, default_format_buffer, &conv); I64_format(buffer, format_string, Int64_val(arg)); res = caml_copy_string(buffer); if (buffer != default_format_buffer) caml_stat_free(buffer); return res; } CAMLprim value caml_int64_of_string(value s) { char * p; uint64 max_uint64 = I64_literal(0xFFFFFFFF, 0xFFFFFFFF); uint64 max_int64_pos = I64_literal(0x7FFFFFFF, 0xFFFFFFFF); uint64 max_int64_neg = I64_literal(0x80000000, 0x00000000); uint64 res, threshold; int sign, base, d; p = parse_sign_and_base(String_val(s), &base, &sign); I64_udivmod(max_uint64, I64_of_int32(base), &threshold, &res); d = parse_digit(*p); if (d < 0 || d >= base) caml_failwith("int_of_string"); res = I64_of_int32(d); for (p++; /*nothing*/; p++) { char c = *p; if (c == '_') continue; d = parse_digit(c); if (d < 0 || d >= base) break; /* Detect overflow in multiplication base * res */ if (I64_ult(threshold, res)) caml_failwith("int_of_string"); res = I64_add(I64_mul(I64_of_int32(base), res), I64_of_int32(d)); /* Detect overflow in addition (base * res) + d */ if (I64_ult(res, I64_of_int32(d))) caml_failwith("int_of_string"); } if (p != String_val(s) + caml_string_length(s)){ caml_failwith("int_of_string"); } if (base == 10) { if (I64_ult((sign >= 0 ? max_int64_pos : max_int64_neg), res)) caml_failwith("int_of_string"); } if (sign < 0) res = I64_neg(res); return caml_copy_int64(res); } CAMLprim value caml_int64_bits_of_float(value vd) { union { double d; int64 i; int32 h[2]; } u; u.d = Double_val(vd); #if defined(__arm__) && !defined(__ARM_EABI__) { int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } #endif return caml_copy_int64(u.i); } CAMLprim value caml_int64_float_of_bits(value vi) { union { double d; int64 i; int32 h[2]; } u; u.i = Int64_val(vi); #if defined(__arm__) && !defined(__ARM_EABI__) { int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } #endif return caml_copy_double(u.d); } /* Native integers */ static int nativeint_cmp(value v1, value v2) { intnat i1 = Nativeint_val(v1); intnat i2 = Nativeint_val(v2); return (i1 > i2) - (i1 < i2); } static intnat nativeint_hash(value v) { intnat n = Nativeint_val(v); #ifdef ARCH_SIXTYFOUR /* 32/64 bits compatibility trick. See explanations in file "hash.c", function caml_hash_mix_intnat. */ return (n >> 32) ^ (n >> 63) ^ n; #else return n; #endif } static void nativeint_serialize(value v, uintnat * wsize_32, uintnat * wsize_64) { intnat l = Nativeint_val(v); #ifdef ARCH_SIXTYFOUR if (l >= -((intnat)1 << 31) && l < ((intnat)1 << 31)) { caml_serialize_int_1(1); caml_serialize_int_4((int32) l); } else { caml_serialize_int_1(2); caml_serialize_int_8(l); } #else caml_serialize_int_1(1); caml_serialize_int_4(l); #endif *wsize_32 = 4; *wsize_64 = 8; } static uintnat nativeint_deserialize(void * dst) { switch (caml_deserialize_uint_1()) { case 1: *((intnat *) dst) = caml_deserialize_sint_4(); break; case 2: #ifdef ARCH_SIXTYFOUR *((intnat *) dst) = caml_deserialize_sint_8(); #else caml_deserialize_error("input_value: native integer value too large"); #endif break; default: caml_deserialize_error("input_value: ill-formed native integer"); } return sizeof(long); } CAMLexport struct custom_operations caml_nativeint_ops = { "_n", custom_finalize_default, nativeint_cmp, nativeint_hash, nativeint_serialize, nativeint_deserialize, custom_compare_ext_default }; CAMLexport value caml_copy_nativeint(intnat i) { value res = caml_alloc_custom(&caml_nativeint_ops, sizeof(intnat), 0, 1); Nativeint_val(res) = i; return res; } CAMLprim value caml_nativeint_neg(value v) { return caml_copy_nativeint(- Nativeint_val(v)); } CAMLprim value caml_nativeint_add(value v1, value v2) { return caml_copy_nativeint(Nativeint_val(v1) + Nativeint_val(v2)); } CAMLprim value caml_nativeint_sub(value v1, value v2) { return caml_copy_nativeint(Nativeint_val(v1) - Nativeint_val(v2)); } CAMLprim value caml_nativeint_mul(value v1, value v2) { return caml_copy_nativeint(Nativeint_val(v1) * Nativeint_val(v2)); } #define Nativeint_min_int ((intnat) 1 << (sizeof(intnat) * 8 - 1)) CAMLprim value caml_nativeint_div(value v1, value v2) { intnat dividend = Nativeint_val(v1); intnat divisor = Nativeint_val(v2); if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, modulus crashes if division overflows. Implement the same behavior as for type "int". */ if (dividend == Nativeint_min_int && divisor == -1) return v1; #ifdef NONSTANDARD_DIV_MOD return caml_copy_nativeint(caml_safe_div(dividend, divisor)); #else return caml_copy_nativeint(dividend / divisor); #endif } CAMLprim value caml_nativeint_mod(value v1, value v2) { intnat dividend = Nativeint_val(v1); intnat divisor = Nativeint_val(v2); if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, modulus crashes if division overflows. Implement the same behavior as for type "int". */ if (dividend == Nativeint_min_int && divisor == -1) return caml_copy_nativeint(0); #ifdef NONSTANDARD_DIV_MOD return caml_copy_nativeint(caml_safe_mod(dividend, divisor)); #else return caml_copy_nativeint(dividend % divisor); #endif } CAMLprim value caml_nativeint_and(value v1, value v2) { return caml_copy_nativeint(Nativeint_val(v1) & Nativeint_val(v2)); } CAMLprim value caml_nativeint_or(value v1, value v2) { return caml_copy_nativeint(Nativeint_val(v1) | Nativeint_val(v2)); } CAMLprim value caml_nativeint_xor(value v1, value v2) { return caml_copy_nativeint(Nativeint_val(v1) ^ Nativeint_val(v2)); } CAMLprim value caml_nativeint_shift_left(value v1, value v2) { return caml_copy_nativeint(Nativeint_val(v1) << Int_val(v2)); } CAMLprim value caml_nativeint_shift_right(value v1, value v2) { return caml_copy_nativeint(Nativeint_val(v1) >> Int_val(v2)); } CAMLprim value caml_nativeint_shift_right_unsigned(value v1, value v2) { return caml_copy_nativeint((uintnat)Nativeint_val(v1) >> Int_val(v2)); } CAMLprim value caml_nativeint_of_int(value v) { return caml_copy_nativeint(Long_val(v)); } CAMLprim value caml_nativeint_to_int(value v) { return Val_long(Nativeint_val(v)); } CAMLprim value caml_nativeint_of_float(value v) { return caml_copy_nativeint((intnat)(Double_val(v))); } CAMLprim value caml_nativeint_to_float(value v) { return caml_copy_double((double)(Nativeint_val(v))); } CAMLprim value caml_nativeint_of_int32(value v) { return caml_copy_nativeint(Int32_val(v)); } CAMLprim value caml_nativeint_to_int32(value v) { return caml_copy_int32(Nativeint_val(v)); } CAMLprim value caml_nativeint_compare(value v1, value v2) { intnat i1 = Nativeint_val(v1); intnat i2 = Nativeint_val(v2); int res = (i1 > i2) - (i1 < i2); return Val_int(res); } CAMLprim value caml_nativeint_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; char default_format_buffer[FORMAT_BUFFER_SIZE]; char * buffer; char conv; value res; buffer = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, format_string, default_format_buffer, &conv); sprintf(buffer, format_string, Nativeint_val(arg)); res = caml_copy_string(buffer); if (buffer != default_format_buffer) caml_stat_free(buffer); return res; } CAMLprim value caml_nativeint_of_string(value s) { return caml_copy_nativeint(parse_intnat(s, 8 * sizeof(value))); } mingw-ocaml/ocaml/byterun/weak.c0000644000175000017500000001365012124403240016245 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1997 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Operations on weak arrays */ #include #include "alloc.h" #include "fail.h" #include "major_gc.h" #include "memory.h" #include "mlvalues.h" value caml_weak_list_head = 0; static value weak_dummy = 0; value caml_weak_none = (value) &weak_dummy; CAMLprim value caml_weak_create (value len) { mlsize_t size, i; value res; size = Long_val (len) + 1; if (size <= 0 || size > Max_wosize) caml_invalid_argument ("Weak.create"); res = caml_alloc_shr (size, Abstract_tag); for (i = 1; i < size; i++) Field (res, i) = caml_weak_none; Field (res, 0) = caml_weak_list_head; caml_weak_list_head = res; return res; } #define None_val (Val_int(0)) #define Some_tag 0 static void do_set (value ar, mlsize_t offset, value v) { if (Is_block (v) && Is_young (v)){ /* modified version of Modify */ value old = Field (ar, offset); Field (ar, offset) = v; if (!(Is_block (old) && Is_young (old))){ if (caml_weak_ref_table.ptr >= caml_weak_ref_table.limit){ CAMLassert (caml_weak_ref_table.ptr == caml_weak_ref_table.limit); caml_realloc_ref_table (&caml_weak_ref_table); } *caml_weak_ref_table.ptr++ = &Field (ar, offset); } }else{ Field (ar, offset) = v; } } CAMLprim value caml_weak_set (value ar, value n, value el) { mlsize_t offset = Long_val (n) + 1; Assert (Is_in_heap (ar)); if (offset < 1 || offset >= Wosize_val (ar)){ caml_invalid_argument ("Weak.set"); } if (el != None_val && Is_block (el)){ Assert (Wosize_val (el) == 1); do_set (ar, offset, Field (el, 0)); }else{ Field (ar, offset) = caml_weak_none; } return Val_unit; } #define Setup_for_gc #define Restore_after_gc CAMLprim value caml_weak_get (value ar, value n) { CAMLparam2 (ar, n); mlsize_t offset = Long_val (n) + 1; CAMLlocal2 (res, elt); Assert (Is_in_heap (ar)); if (offset < 1 || offset >= Wosize_val (ar)){ caml_invalid_argument ("Weak.get"); } if (Field (ar, offset) == caml_weak_none){ res = None_val; }else{ elt = Field (ar, offset); if (caml_gc_phase == Phase_mark && Is_block (elt) && Is_in_heap (elt)){ caml_darken (elt, NULL); } res = caml_alloc_small (1, Some_tag); Field (res, 0) = elt; } CAMLreturn (res); } #undef Setup_for_gc #undef Restore_after_gc CAMLprim value caml_weak_get_copy (value ar, value n) { CAMLparam2 (ar, n); mlsize_t offset = Long_val (n) + 1; CAMLlocal2 (res, elt); value v; /* Caution: this is NOT a local root. */ Assert (Is_in_heap (ar)); if (offset < 1 || offset >= Wosize_val (ar)){ caml_invalid_argument ("Weak.get"); } v = Field (ar, offset); if (v == caml_weak_none) CAMLreturn (None_val); if (Is_block (v) && Is_in_heap_or_young(v)) { elt = caml_alloc (Wosize_val (v), Tag_val (v)); /* The GC may erase or move v during this call to caml_alloc. */ v = Field (ar, offset); if (v == caml_weak_none) CAMLreturn (None_val); if (Tag_val (v) < No_scan_tag){ mlsize_t i; for (i = 0; i < Wosize_val (v); i++){ value f = Field (v, i); if (caml_gc_phase == Phase_mark && Is_block (f) && Is_in_heap (f)){ caml_darken (f, NULL); } Modify (&Field (elt, i), f); } }else{ memmove (Bp_val (elt), Bp_val (v), Bosize_val (v)); } }else{ elt = v; } res = caml_alloc_small (1, Some_tag); Field (res, 0) = elt; CAMLreturn (res); } CAMLprim value caml_weak_check (value ar, value n) { mlsize_t offset = Long_val (n) + 1; Assert (Is_in_heap (ar)); if (offset < 1 || offset >= Wosize_val (ar)){ caml_invalid_argument ("Weak.get"); } return Val_bool (Field (ar, offset) != caml_weak_none); } CAMLprim value caml_weak_blit (value ars, value ofs, value ard, value ofd, value len) { mlsize_t offset_s = Long_val (ofs) + 1; mlsize_t offset_d = Long_val (ofd) + 1; mlsize_t length = Long_val (len); long i; Assert (Is_in_heap (ars)); Assert (Is_in_heap (ard)); if (offset_s < 1 || offset_s + length > Wosize_val (ars)){ caml_invalid_argument ("Weak.blit"); } if (offset_d < 1 || offset_d + length > Wosize_val (ard)){ caml_invalid_argument ("Weak.blit"); } if (caml_gc_phase == Phase_mark && caml_gc_subphase == Subphase_weak1){ for (i = 0; i < length; i++){ value v = Field (ars, offset_s + i); if (v != caml_weak_none && Is_block (v) && Is_in_heap (v) && Is_white_val (v)){ Field (ars, offset_s + i) = caml_weak_none; } } } if (offset_d < offset_s){ for (i = 0; i < length; i++){ do_set (ard, offset_d + i, Field (ars, offset_s + i)); } }else{ for (i = length - 1; i >= 0; i--){ do_set (ard, offset_d + i, Field (ars, offset_s + i)); } } return Val_unit; } mingw-ocaml/ocaml/byterun/osdeps.h0000644000175000017500000000614512124403240016621 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Operating system - specific stuff */ #ifndef CAML_OSDEPS_H #define CAML_OSDEPS_H #include "misc.h" /* Decompose the given path into a list of directories, and add them to the given table. Return the block to be freed later. */ extern char * caml_decompose_path(struct ext_table * tbl, char * path); /* Search the given file in the given list of directories. If not found, return a copy of [name]. Result is allocated with [caml_stat_alloc]. */ extern char * caml_search_in_path(struct ext_table * path, char * name); /* Same, but search an executable name in the system path for executables. */ CAMLextern char * caml_search_exe_in_path(char * name); /* Same, but search a shared library in the given path. */ extern char * caml_search_dll_in_path(struct ext_table * path, char * name); /* Open a shared library and return a handle on it. If [for_execution] is true, perform full symbol resolution and execute initialization code so that functions from the shared library can be called. If [for_execution] is false, functions from this shared library will not be called, but just checked for presence, so symbol resolution can be skipped. If [global] is true, symbols from the shared library can be used to resolve for other libraries to be opened later on. Return [NULL] on error. */ extern void * caml_dlopen(char * libname, int for_execution, int global); /* Close a shared library handle */ extern void caml_dlclose(void * handle); /* Look up the given symbol in the given shared library. Return [NULL] if not found, or symbol value if found. */ extern void * caml_dlsym(void * handle, char * name); extern void * caml_globalsym(char * name); /* Return an error message describing the most recent dynlink failure. */ extern char * caml_dlerror(void); /* Add to [contents] the (short) names of the files contained in the directory named [dirname]. No entries are added for [.] and [..]. Return 0 on success, -1 on error; set errno in the case of error. */ extern int caml_read_directory(char * dirname, struct ext_table * contents); #ifdef __linux__ /* Recover executable name from /proc/self/exe if possible */ extern int caml_executable_name(char * name, int name_len); #endif #endif /* CAML_OSDEPS_H */ mingw-ocaml/ocaml/byterun/dynlink.h0000644000175000017500000000322312124403240016766 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2000 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Dynamic loading of C primitives. */ #ifndef CAML_DYNLINK_H #define CAML_DYNLINK_H #include "misc.h" /* Build the table of primitives, given a search path, a list of shared libraries, and a list of primitive names (all three 0-separated in char arrays). Abort the runtime system on error. */ extern void caml_build_primitive_table(char * lib_path, char * libs, char * req_prims); /* The search path for shared libraries */ extern struct ext_table caml_shared_libs_path; /* Build the table of primitives as a copy of the builtin primitive table. Used for executables generated by ocamlc -output-obj. */ extern void caml_build_primitive_table_builtin(void); #endif /* CAML_DYNLINK_H */ mingw-ocaml/ocaml/byterun/finalise.c0000644000175000017500000001566412124403240017117 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Moscova, INRIA Rocquencourt */ /* */ /* Copyright 2000 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Handling of finalised values. */ #include "callback.h" #include "fail.h" #include "mlvalues.h" #include "roots.h" #include "signals.h" struct final { value fun; value val; int offset; }; static struct final *final_table = NULL; static uintnat old = 0, young = 0, size = 0; /* [0..old) : finalisable set [old..young) : recent set [young..size) : free space */ struct to_do { struct to_do *next; int size; struct final item[1]; /* variable size */ }; static struct to_do *to_do_hd = NULL; static struct to_do *to_do_tl = NULL; static void alloc_to_do (int size) { struct to_do *result = malloc (sizeof (struct to_do) + size * sizeof (struct final)); if (result == NULL) caml_fatal_error ("out of memory"); result->next = NULL; result->size = size; if (to_do_tl == NULL){ to_do_hd = result; to_do_tl = result; }else{ Assert (to_do_tl->next == NULL); to_do_tl->next = result; to_do_tl = result; } } /* Find white finalisable values, put them in the finalising set, and darken them. The recent set is empty. */ void caml_final_update (void) { uintnat i, j, k; uintnat todo_count = 0; Assert (young == old); for (i = 0; i < old; i++){ Assert (Is_block (final_table[i].val)); Assert (Is_in_heap (final_table[i].val)); if (Is_white_val (final_table[i].val)) ++ todo_count; } if (todo_count > 0){ alloc_to_do (todo_count); j = k = 0; for (i = 0; i < old; i++){ again: Assert (Is_block (final_table[i].val)); Assert (Is_in_heap (final_table[i].val)); if (Is_white_val (final_table[i].val)){ if (Tag_val (final_table[i].val) == Forward_tag){ value fv; Assert (final_table[i].offset == 0); fv = Forward_val (final_table[i].val); if (Is_block (fv) && (!Is_in_value_area(fv) || Tag_val (fv) == Forward_tag || Tag_val (fv) == Lazy_tag || Tag_val (fv) == Double_tag)){ /* Do not short-circuit the pointer. */ }else{ final_table[i].val = fv; if (Is_block (final_table[i].val) && Is_in_heap (final_table[i].val)){ goto again; } } } to_do_tl->item[k++] = final_table[i]; }else{ final_table[j++] = final_table[i]; } } young = old = j; to_do_tl->size = k; for (i = 0; i < k; i++){ CAMLassert (Is_white_val (to_do_tl->item[i].val)); caml_darken (to_do_tl->item[i].val, NULL); } } } static int running_finalisation_function = 0; /* Call the finalisation functions for the finalising set. Note that this function must be reentrant. */ void caml_final_do_calls (void) { struct final f; value res; if (running_finalisation_function) return; if (to_do_hd != NULL){ caml_gc_message (0x80, "Calling finalisation functions.\n", 0); while (1){ while (to_do_hd != NULL && to_do_hd->size == 0){ struct to_do *next_hd = to_do_hd->next; free (to_do_hd); to_do_hd = next_hd; if (to_do_hd == NULL) to_do_tl = NULL; } if (to_do_hd == NULL) break; Assert (to_do_hd->size > 0); -- to_do_hd->size; f = to_do_hd->item[to_do_hd->size]; running_finalisation_function = 1; res = caml_callback_exn (f.fun, f.val + f.offset); running_finalisation_function = 0; if (Is_exception_result (res)) caml_raise (Extract_exception (res)); } caml_gc_message (0x80, "Done calling finalisation functions.\n", 0); } } /* Call a scanning_action [f] on [x]. */ #define Call_action(f,x) (*(f)) ((x), &(x)) /* Call [*f] on the closures of the finalisable set and the closures and values of the finalising set. The recent set is empty. This is called by the major GC and the compactor through [caml_darken_all_roots]. */ void caml_final_do_strong_roots (scanning_action f) { uintnat i; struct to_do *todo; Assert (old == young); for (i = 0; i < old; i++) Call_action (f, final_table[i].fun); for (todo = to_do_hd; todo != NULL; todo = todo->next){ for (i = 0; i < todo->size; i++){ Call_action (f, todo->item[i].fun); Call_action (f, todo->item[i].val); } } } /* Call [*f] on the values of the finalisable set. The recent set is empty. This is called directly by the compactor. */ void caml_final_do_weak_roots (scanning_action f) { uintnat i; Assert (old == young); for (i = 0; i < old; i++) Call_action (f, final_table[i].val); } /* Call [*f] on the closures and values of the recent set. This is called by the minor GC through [caml_oldify_local_roots]. */ void caml_final_do_young_roots (scanning_action f) { uintnat i; Assert (old <= young); for (i = old; i < young; i++){ Call_action (f, final_table[i].fun); Call_action (f, final_table[i].val); } } /* Empty the recent set into the finalisable set. This is called at the end of each minor collection. The minor heap must be empty when this is called. */ void caml_final_empty_young (void) { old = young; } /* Put (f,v) in the recent set. */ CAMLprim value caml_final_register (value f, value v) { if (!(Is_block (v) && Is_in_heap_or_young(v))) { caml_invalid_argument ("Gc.finalise"); } Assert (old <= young); if (young >= size){ if (final_table == NULL){ uintnat new_size = 30; final_table = caml_stat_alloc (new_size * sizeof (struct final)); Assert (old == 0); Assert (young == 0); size = new_size; }else{ uintnat new_size = size * 2; final_table = caml_stat_resize (final_table, new_size * sizeof (struct final)); size = new_size; } } Assert (young < size); final_table[young].fun = f; if (Tag_val (v) == Infix_tag){ final_table[young].offset = Infix_offset_val (v); final_table[young].val = v - Infix_offset_val (v); }else{ final_table[young].offset = 0; final_table[young].val = v; } ++ young; return Val_unit; } CAMLprim value caml_final_release (value unit) { running_finalisation_function = 0; return Val_unit; } mingw-ocaml/ocaml/byterun/globroots.h0000644000175000017500000000222212124403240017326 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Registration of global memory roots */ #ifndef CAML_GLOBROOTS_H #define CAML_GLOBROOTS_H #include "mlvalues.h" #include "roots.h" void caml_scan_global_roots(scanning_action f); void caml_scan_global_young_roots(scanning_action f); #endif /* CAML_GLOBROOTS_H */ mingw-ocaml/ocaml/byterun/gc_ctrl.h0000644000175000017500000000262412124403240016737 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_GC_CTRL_H #define CAML_GC_CTRL_H #include "misc.h" extern double caml_stat_minor_words, caml_stat_promoted_words, caml_stat_major_words; extern intnat caml_stat_minor_collections, caml_stat_major_collections, caml_stat_heap_size, caml_stat_top_heap_size, caml_stat_compactions, caml_stat_heap_chunks; void caml_init_gc (uintnat, uintnat, uintnat, uintnat, uintnat); #ifdef DEBUG void caml_heap_check (void); #endif #endif /* CAML_GC_CTRL_H */ mingw-ocaml/ocaml/byterun/misc.c0000644000175000017500000000701712124403240016251 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "config.h" #include "misc.h" #include "memory.h" #ifdef DEBUG int caml_failed_assert (char * expr, char * file, int line) { fprintf (stderr, "file %s; line %d ### Assertion failed: %s\n", file, line, expr); fflush (stderr); exit (100); return 1; /* not reached */ } void caml_set_fields (char *bp, unsigned long start, unsigned long filler) { mlsize_t i; for (i = start; i < Wosize_bp (bp); i++){ Field (Val_bp (bp), i) = (value) filler; } } #endif /* DEBUG */ uintnat caml_verb_gc = 0; void caml_gc_message (int level, char *msg, uintnat arg) { if (level < 0 || (caml_verb_gc & level) != 0){ fprintf (stderr, msg, arg); fflush (stderr); } } CAMLexport void caml_fatal_error (char *msg) { fprintf (stderr, "%s", msg); exit(2); } CAMLexport void caml_fatal_error_arg (char *fmt, char *arg) { fprintf (stderr, fmt, arg); exit(2); } CAMLexport void caml_fatal_error_arg2 (char *fmt1, char *arg1, char *fmt2, char *arg2) { fprintf (stderr, fmt1, arg1); fprintf (stderr, fmt2, arg2); exit(2); } char *caml_aligned_malloc (asize_t size, int modulo, void **block) { char *raw_mem; uintnat aligned_mem; Assert (modulo < Page_size); raw_mem = (char *) malloc (size + Page_size); if (raw_mem == NULL) return NULL; *block = raw_mem; raw_mem += modulo; /* Address to be aligned */ aligned_mem = (((uintnat) raw_mem / Page_size + 1) * Page_size); #ifdef DEBUG { uintnat *p; uintnat *p0 = (void *) *block, *p1 = (void *) (aligned_mem - modulo), *p2 = (void *) (aligned_mem - modulo + size), *p3 = (void *) ((char *) *block + size + Page_size); for (p = p0; p < p1; p++) *p = Debug_filler_align; for (p = p1; p < p2; p++) *p = Debug_uninit_align; for (p = p2; p < p3; p++) *p = Debug_filler_align; } #endif return (char *) (aligned_mem - modulo); } void caml_ext_table_init(struct ext_table * tbl, int init_capa) { tbl->size = 0; tbl->capacity = init_capa; tbl->contents = caml_stat_alloc(sizeof(void *) * init_capa); } int caml_ext_table_add(struct ext_table * tbl, void * data) { int res; if (tbl->size >= tbl->capacity) { tbl->capacity *= 2; tbl->contents = caml_stat_resize(tbl->contents, sizeof(void *) * tbl->capacity); } res = tbl->size; tbl->contents[res] = data; tbl->size++; return res; } void caml_ext_table_free(struct ext_table * tbl, int free_entries) { int i; if (free_entries) for (i = 0; i < tbl->size; i++) caml_stat_free(tbl->contents[i]); caml_stat_free(tbl->contents); } mingw-ocaml/ocaml/byterun/debugger.c0000644000175000017500000003013512124403240017077 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Interface with the byte-code debugger */ #ifdef _WIN32 #include #endif /* _WIN32 */ #include #include "alloc.h" #include "config.h" #include "debugger.h" #include "misc.h" int caml_debugger_in_use = 0; uintnat caml_event_count; int caml_debugger_fork_mode = 1; /* parent by default */ value marshal_flags = Val_emptylist; #if !defined(HAS_SOCKETS) || defined(NATIVE_CODE) void caml_debugger_init(void) { } void caml_debugger(enum event_kind event) { } void caml_debugger_cleanup_fork(void) { } #else #ifdef HAS_UNISTD #include #endif #include #include #ifndef _WIN32 #include #include #include #include #include #include #else #define ATOM ATOM_WS #include #undef ATOM #include #endif #include "fail.h" #include "fix_code.h" #include "instruct.h" #include "intext.h" #include "io.h" #include "mlvalues.h" #include "stacks.h" #include "sys.h" static int sock_domain; /* Socket domain for the debugger */ static union { /* Socket address for the debugger */ struct sockaddr s_gen; #ifndef _WIN32 struct sockaddr_un s_unix; #endif struct sockaddr_in s_inet; } sock_addr; static int sock_addr_len; /* Length of sock_addr */ static int dbg_socket = -1; /* The socket connected to the debugger */ static struct channel * dbg_in; /* Input channel on the socket */ static struct channel * dbg_out;/* Output channel on the socket */ static char *dbg_addr = "(none)"; static void open_connection(void) { #ifdef _WIN32 /* Set socket to synchronous mode so that file descriptor-oriented functions (read()/write() etc.) can be used */ int oldvalue, oldvaluelen, newvalue, retcode; oldvaluelen = sizeof(oldvalue); retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &oldvalue, &oldvaluelen); if (retcode == 0) { newvalue = SO_SYNCHRONOUS_NONALERT; setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &newvalue, sizeof(newvalue)); } #endif dbg_socket = socket(sock_domain, SOCK_STREAM, 0); #ifdef _WIN32 if (retcode == 0) { /* Restore initial mode */ setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &oldvalue, oldvaluelen); } #endif if (dbg_socket == -1 || connect(dbg_socket, &sock_addr.s_gen, sock_addr_len) == -1){ caml_fatal_error_arg2 ("cannot connect to debugger at %s\n", dbg_addr, "error: %s\n", strerror (errno)); } #ifdef _WIN32 dbg_socket = _open_osfhandle(dbg_socket, 0); if (dbg_socket == -1) caml_fatal_error("_open_osfhandle failed"); #endif dbg_in = caml_open_descriptor_in(dbg_socket); dbg_out = caml_open_descriptor_out(dbg_socket); if (!caml_debugger_in_use) caml_putword(dbg_out, -1); /* first connection */ #ifdef _WIN32 caml_putword(dbg_out, _getpid()); #else caml_putword(dbg_out, getpid()); #endif caml_flush(dbg_out); } static void close_connection(void) { caml_close_channel(dbg_in); caml_close_channel(dbg_out); dbg_socket = -1; /* was closed by caml_close_channel */ } #ifdef _WIN32 static void winsock_startup(void) { WSADATA wsaData; int err = WSAStartup(MAKEWORD(2, 0), &wsaData); if (err) caml_fatal_error("WSAStartup failed"); } static void winsock_cleanup(void) { WSACleanup(); } #endif void caml_debugger_init(void) { char * address; char * port, * p; struct hostent * host; int n; caml_register_global_root(&marshal_flags); marshal_flags = caml_alloc(2, Tag_cons); Store_field(marshal_flags, 0, Val_int(1)); /* Marshal.Closures */ Store_field(marshal_flags, 1, Val_emptylist); address = getenv("CAML_DEBUG_SOCKET"); if (address == NULL) return; dbg_addr = address; #ifdef _WIN32 winsock_startup(); (void)atexit(winsock_cleanup); #endif /* Parse the address */ port = NULL; for (p = address; *p != 0; p++) { if (*p == ':') { *p = 0; port = p+1; break; } } if (port == NULL) { #ifndef _WIN32 /* Unix domain */ sock_domain = PF_UNIX; sock_addr.s_unix.sun_family = AF_UNIX; strncpy(sock_addr.s_unix.sun_path, address, sizeof(sock_addr.s_unix.sun_path)); sock_addr_len = ((char *)&(sock_addr.s_unix.sun_path) - (char *)&(sock_addr.s_unix)) + strlen(address); #else caml_fatal_error("Unix sockets not supported"); #endif } else { /* Internet domain */ sock_domain = PF_INET; for (p = (char *) &sock_addr.s_inet, n = sizeof(sock_addr.s_inet); n > 0; n--) *p++ = 0; sock_addr.s_inet.sin_family = AF_INET; sock_addr.s_inet.sin_addr.s_addr = inet_addr(address); if (sock_addr.s_inet.sin_addr.s_addr == -1) { host = gethostbyname(address); if (host == NULL) caml_fatal_error_arg("Unknown debugging host %s\n", address); memmove(&sock_addr.s_inet.sin_addr, host->h_addr, host->h_length); } sock_addr.s_inet.sin_port = htons(atoi(port)); sock_addr_len = sizeof(sock_addr.s_inet); } open_connection(); caml_debugger_in_use = 1; caml_trap_barrier = caml_stack_high; } static value getval(struct channel *chan) { value res; if (caml_really_getblock(chan, (char *) &res, sizeof(res)) == 0) caml_raise_end_of_file(); /* Bad, but consistent with caml_getword */ return res; } static void putval(struct channel *chan, value val) { caml_really_putblock(chan, (char *) &val, sizeof(val)); } static void safe_output_value(struct channel *chan, value val) { struct longjmp_buffer raise_buf, * saved_external_raise; /* Catch exceptions raised by [caml_output_val] */ saved_external_raise = caml_external_raise; if (sigsetjmp(raise_buf.buf, 0) == 0) { caml_external_raise = &raise_buf; caml_output_val(chan, val, marshal_flags); } else { /* Send wrong magic number, will cause [caml_input_value] to fail */ caml_really_putblock(chan, "\000\000\000\000", 4); } caml_external_raise = saved_external_raise; } #define Pc(sp) ((code_t)((sp)[0])) #define Env(sp) ((sp)[1]) #define Extra_args(sp) (Long_val(((sp)[2]))) #define Locals(sp) ((sp) + 3) void caml_debugger(enum event_kind event) { int frame_number; value * frame; intnat i, pos; value val; if (dbg_socket == -1) return; /* Not connected to a debugger. */ /* Reset current frame */ frame_number = 0; frame = caml_extern_sp + 1; /* Report the event to the debugger */ switch(event) { case PROGRAM_START: /* Nothing to report */ goto command_loop; case EVENT_COUNT: putch(dbg_out, REP_EVENT); break; case BREAKPOINT: putch(dbg_out, REP_BREAKPOINT); break; case PROGRAM_EXIT: putch(dbg_out, REP_EXITED); break; case TRAP_BARRIER: putch(dbg_out, REP_TRAP); break; case UNCAUGHT_EXC: putch(dbg_out, REP_UNCAUGHT_EXC); break; } caml_putword(dbg_out, caml_event_count); if (event == EVENT_COUNT || event == BREAKPOINT) { caml_putword(dbg_out, caml_stack_high - frame); caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t)); } else { /* No PC and no stack frame associated with other events */ caml_putword(dbg_out, 0); caml_putword(dbg_out, 0); } caml_flush(dbg_out); command_loop: /* Read and execute the commands sent by the debugger */ while(1) { switch(getch(dbg_in)) { case REQ_SET_EVENT: pos = caml_getword(dbg_in); Assert (pos >= 0); Assert (pos < caml_code_size); caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), EVENT); break; case REQ_SET_BREAKPOINT: pos = caml_getword(dbg_in); Assert (pos >= 0); Assert (pos < caml_code_size); caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), BREAK); break; case REQ_RESET_INSTR: pos = caml_getword(dbg_in); Assert (pos >= 0); Assert (pos < caml_code_size); pos = pos / sizeof(opcode_t); caml_set_instruction(caml_start_code + pos, caml_saved_code[pos]); break; case REQ_CHECKPOINT: #ifndef _WIN32 i = fork(); if (i == 0) { close_connection(); /* Close parent connection. */ open_connection(); /* Open new connection with debugger */ } else { caml_putword(dbg_out, i); caml_flush(dbg_out); } #else caml_fatal_error("error: REQ_CHECKPOINT command"); exit(-1); #endif break; case REQ_GO: caml_event_count = caml_getword(dbg_in); return; case REQ_STOP: exit(0); break; case REQ_WAIT: #ifndef _WIN32 wait(NULL); #else caml_fatal_error("Fatal error: REQ_WAIT command"); exit(-1); #endif break; case REQ_INITIAL_FRAME: frame = caml_extern_sp + 1; /* Fall through */ case REQ_GET_FRAME: caml_putword(dbg_out, caml_stack_high - frame); if (frame < caml_stack_high){ caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t)); }else{ caml_putword (dbg_out, 0); } caml_flush(dbg_out); break; case REQ_SET_FRAME: i = caml_getword(dbg_in); frame = caml_stack_high - i; break; case REQ_UP_FRAME: i = caml_getword(dbg_in); if (frame + Extra_args(frame) + i + 3 >= caml_stack_high) { caml_putword(dbg_out, -1); } else { frame += Extra_args(frame) + i + 3; caml_putword(dbg_out, caml_stack_high - frame); caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t)); } caml_flush(dbg_out); break; case REQ_SET_TRAP_BARRIER: i = caml_getword(dbg_in); caml_trap_barrier = caml_stack_high - i; break; case REQ_GET_LOCAL: i = caml_getword(dbg_in); putval(dbg_out, Locals(frame)[i]); caml_flush(dbg_out); break; case REQ_GET_ENVIRONMENT: i = caml_getword(dbg_in); putval(dbg_out, Field(Env(frame), i)); caml_flush(dbg_out); break; case REQ_GET_GLOBAL: i = caml_getword(dbg_in); putval(dbg_out, Field(caml_global_data, i)); caml_flush(dbg_out); break; case REQ_GET_ACCU: putval(dbg_out, *caml_extern_sp); caml_flush(dbg_out); break; case REQ_GET_HEADER: val = getval(dbg_in); caml_putword(dbg_out, Hd_val(val)); caml_flush(dbg_out); break; case REQ_GET_FIELD: val = getval(dbg_in); i = caml_getword(dbg_in); if (Tag_val(val) != Double_array_tag) { putch(dbg_out, 0); putval(dbg_out, Field(val, i)); } else { double d = Double_field(val, i); putch(dbg_out, 1); caml_really_putblock(dbg_out, (char *) &d, 8); } caml_flush(dbg_out); break; case REQ_MARSHAL_OBJ: val = getval(dbg_in); safe_output_value(dbg_out, val); caml_flush(dbg_out); break; case REQ_GET_CLOSURE_CODE: val = getval(dbg_in); caml_putword(dbg_out, (Code_val(val)-caml_start_code) * sizeof(opcode_t)); caml_flush(dbg_out); break; case REQ_SET_FORK_MODE: caml_debugger_fork_mode = caml_getword(dbg_in); break; } } } void caml_debugger_cleanup_fork(void) { /* We could remove all of the breakpoints, but closing the connection * means that they'll just be skipped anyway. */ close_connection(); caml_debugger_in_use = 0; } #endif mingw-ocaml/ocaml/byterun/printexc.h0000644000175000017500000000225212124403240017153 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_PRINTEXC_H #define CAML_PRINTEXC_H #include "misc.h" #include "mlvalues.h" #ifdef __cplusplus extern "C" { #endif CAMLextern char * caml_format_exception (value); void caml_fatal_uncaught_exception (value) Noreturn; #ifdef __cplusplus } #endif #endif /* CAML_PRINTEXC_H */ mingw-ocaml/ocaml/byterun/ui.h0000644000175000017500000000233412124403240015735 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Function declarations for non-Unix user interfaces */ #ifndef CAML_UI_H #define CAML_UI_H #include "config.h" void ui_exit (int return_code); int ui_read (int file_desc, char *buf, unsigned int length); int ui_write (int file_desc, char *buf, unsigned int length); void ui_print_stderr (char *format, void *arg); #endif /* CAML_UI_H */ mingw-ocaml/ocaml/byterun/interp.h0000644000175000017500000000254412124403240016624 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* The bytecode interpreter */ #ifndef CAML_INTERP_H #define CAML_INTERP_H #include "misc.h" #include "mlvalues.h" /* interpret a bytecode */ value caml_interprete (code_t prog, asize_t prog_size); /* tell the runtime that a bytecode program might be needed */ void caml_prepare_bytecode(code_t prog, asize_t prog_size); /* tell the runtime that a bytecode program is no more needed */ void caml_release_bytecode(code_t prog, asize_t prog_size); #endif /* CAML_INTERP_H */ mingw-ocaml/ocaml/byterun/instruct.h0000644000175000017500000000500012124403240017164 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* The instruction set. */ #ifndef CAML_INSTRUCT_H #define CAML_INSTRUCT_H enum instructions { ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, ACC, PUSH, PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3, PUSHACC4, PUSHACC5, PUSHACC6, PUSHACC7, PUSHACC, POP, ASSIGN, ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC, PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC, PUSH_RETADDR, APPLY, APPLY1, APPLY2, APPLY3, APPTERM, APPTERM1, APPTERM2, APPTERM3, RETURN, RESTART, GRAB, CLOSURE, CLOSUREREC, OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE, PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0, PUSHOFFSETCLOSURE2, PUSHOFFSETCLOSURE, GETGLOBAL, PUSHGETGLOBAL, GETGLOBALFIELD, PUSHGETGLOBALFIELD, SETGLOBAL, ATOM0, ATOM, PUSHATOM0, PUSHATOM, MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, MAKEFLOATBLOCK, GETFIELD0, GETFIELD1, GETFIELD2, GETFIELD3, GETFIELD, GETFLOATFIELD, SETFIELD0, SETFIELD1, SETFIELD2, SETFIELD3, SETFIELD, SETFLOATFIELD, VECTLENGTH, GETVECTITEM, SETVECTITEM, GETSTRINGCHAR, SETSTRINGCHAR, BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, BOOLNOT, PUSHTRAP, POPTRAP, RAISE, CHECK_SIGNALS, C_CALL1, C_CALL2, C_CALL3, C_CALL4, C_CALL5, C_CALLN, CONST0, CONST1, CONST2, CONST3, CONSTINT, PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, NEGINT, ADDINT, SUBINT, MULINT, DIVINT, MODINT, ANDINT, ORINT, XORINT, LSLINT, LSRINT, ASRINT, EQ, NEQ, LTINT, LEINT, GTINT, GEINT, OFFSETINT, OFFSETREF, ISINT, GETMETHOD, BEQ, BNEQ, BLTINT, BLEINT, BGTINT, BGEINT, ULTINT, UGEINT, BULTINT, BUGEINT, GETPUBMET, GETDYNMET, STOP, EVENT, BREAK }; #endif /* CAML_INSTRUCT_H */ mingw-ocaml/ocaml/byterun/debugger.h0000644000175000017500000001130712124403240017104 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Interface with the debugger */ #ifndef CAML_DEBUGGER_H #define CAML_DEBUGGER_H #include "misc.h" #include "mlvalues.h" CAMLextern int caml_debugger_in_use; CAMLextern int caml_debugger_fork_mode; /* non-zero for parent */ extern uintnat caml_event_count; enum event_kind { EVENT_COUNT, BREAKPOINT, PROGRAM_START, PROGRAM_EXIT, TRAP_BARRIER, UNCAUGHT_EXC }; void caml_debugger_init (void); void caml_debugger (enum event_kind event); void caml_debugger_cleanup_fork (void); /* Communication protocol */ /* Requests from the debugger to the runtime system */ enum debugger_request { REQ_SET_EVENT = 'e', /* uint32 pos */ /* Set an event on the instruction at position pos */ REQ_SET_BREAKPOINT = 'B', /* uint32 pos, (char k) */ /* Set a breakpoint at position pos */ /* In profiling mode, the breakpoint kind is set to k */ REQ_RESET_INSTR = 'i', /* uint32 pos */ /* Clear an event or breapoint at position pos, restores initial instr. */ REQ_CHECKPOINT = 'c', /* no args */ /* Checkpoint the runtime system by forking a child process. Reply is pid of child process or -1 if checkpoint failed. */ REQ_GO = 'g', /* uint32 n */ /* Run the program for n events. Reply is one of debugger_reply described below. */ REQ_STOP = 's', /* no args */ /* Terminate the runtime system */ REQ_WAIT = 'w', /* no args */ /* Reap one dead child (a discarded checkpoint). */ REQ_INITIAL_FRAME = '0', /* no args */ /* Set current frame to bottom frame (the one currently executing). Reply is stack offset and current pc. */ REQ_GET_FRAME = 'f', /* no args */ /* Return current frame location (stack offset + current pc). */ REQ_SET_FRAME = 'S', /* uint32 stack_offset */ /* Set current frame to given stack offset. No reply. */ REQ_UP_FRAME = 'U', /* uint32 n */ /* Move one frame up. Argument n is size of current frame (in words). Reply is stack offset and current pc, or -1 if top of stack reached. */ REQ_SET_TRAP_BARRIER = 'b', /* uint32 offset */ /* Set the trap barrier at the given offset. */ REQ_GET_LOCAL = 'L', /* uint32 slot_number */ /* Return the local variable at the given slot in the current frame. Reply is one value. */ REQ_GET_ENVIRONMENT = 'E', /* uint32 slot_number */ /* Return the local variable at the given slot in the heap environment of the current frame. Reply is one value. */ REQ_GET_GLOBAL = 'G', /* uint32 global_number */ /* Return the specified global variable. Reply is one value. */ REQ_GET_ACCU = 'A', /* no args */ /* Return the current contents of the accumulator. Reply is one value. */ REQ_GET_HEADER = 'H', /* mlvalue v */ /* As REQ_GET_OBJ, but sends only the header. */ REQ_GET_FIELD = 'F', /* mlvalue v, uint32 fieldnum */ /* As REQ_GET_OBJ, but sends only one field. */ REQ_MARSHAL_OBJ = 'M', /* mlvalue v */ /* Send a copy of the data structure rooted at v, using the same format as [caml_output_value]. */ REQ_GET_CLOSURE_CODE = 'C', /* mlvalue v */ /* Send the code address of the given closure. Reply is one uint32. */ REQ_SET_FORK_MODE = 'K' /* uint32 m */ /* Set whether to follow the child (m=0) or the parent on fork. */ }; /* Replies to a REQ_GO request. All replies are followed by three uint32: - the value of the event counter - the position of the stack - the current pc. */ enum debugger_reply { REP_EVENT = 'e', /* Event counter reached 0. */ REP_BREAKPOINT = 'b', /* Breakpoint hit. */ REP_EXITED = 'x', /* Program exited by calling exit or reaching the end of the source. */ REP_TRAP = 's', /* Trap barrier crossed. */ REP_UNCAUGHT_EXC = 'u' /* Program exited due to a stray exception. */ }; #endif /* CAML_DEBUGGER_H */ mingw-ocaml/ocaml/byterun/instrtrace.c0000644000175000017500000001646212124403240017500 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Trace the instructions executed */ #ifdef DEBUG #include #include #include #include "instruct.h" #include "misc.h" #include "mlvalues.h" #include "opnames.h" #include "prims.h" #include "stacks.h" extern code_t caml_start_code; intnat caml_icount = 0; void caml_stop_here () {} int caml_trace_flag = 0; void caml_disasm_instr(pc) code_t pc; { int instr = *pc; printf("%6ld %s", (long) (pc - caml_start_code), instr < 0 || instr > STOP ? "???" : names_of_instructions[instr]); pc++; switch(instr) { /* Instructions with one integer operand */ case PUSHACC: case ACC: case POP: case ASSIGN: case PUSHENVACC: case ENVACC: case PUSH_RETADDR: case APPLY: case APPTERM1: case APPTERM2: case APPTERM3: case RETURN: case GRAB: case PUSHGETGLOBAL: case GETGLOBAL: case SETGLOBAL: case PUSHATOM: case ATOM: case MAKEBLOCK1: case MAKEBLOCK2: case MAKEBLOCK3: case MAKEFLOATBLOCK: case GETFIELD: case SETFIELD: case GETFLOATFIELD: case SETFLOATFIELD: case BRANCH: case BRANCHIF: case BRANCHIFNOT: case PUSHTRAP: case CONSTINT: case PUSHCONSTINT: case OFFSETINT: case OFFSETREF: case OFFSETCLOSURE: case PUSHOFFSETCLOSURE: printf(" %d\n", pc[0]); break; /* Instructions with two operands */ case APPTERM: case CLOSURE: case CLOSUREREC: case PUSHGETGLOBALFIELD: case GETGLOBALFIELD: case MAKEBLOCK: case BEQ: case BNEQ: case BLTINT: case BLEINT: case BGTINT: case BGEINT: case BULTINT: case BUGEINT: printf(" %d, %d\n", pc[0], pc[1]); break; /* Instructions with a C primitive as operand */ case C_CALLN: printf(" %d,", pc[0]); pc++; /* fallthrough */ case C_CALL1: case C_CALL2: case C_CALL3: case C_CALL4: case C_CALL5: if (pc[0] < 0 || pc[0] >= caml_prim_name_table.size) printf(" unknown primitive %d\n", pc[0]); else printf(" %s\n", (char *) caml_prim_name_table.contents[pc[0]]); break; default: printf("\n"); } fflush (stdout); } char * caml_instr_string (code_t pc) { static char buf[256]; char nambuf[128]; int instr = *pc; char *nam; nam = (instr < 0 || instr > STOP) ? (sprintf (nambuf, "???%d", instr), nambuf) : names_of_instructions[instr]; pc++; switch (instr) { /* Instructions with one integer operand */ case PUSHACC: case ACC: case POP: case ASSIGN: case PUSHENVACC: case ENVACC: case PUSH_RETADDR: case APPLY: case APPTERM1: case APPTERM2: case APPTERM3: case RETURN: case GRAB: case PUSHGETGLOBAL: case GETGLOBAL: case SETGLOBAL: case PUSHATOM: case ATOM: case MAKEBLOCK1: case MAKEBLOCK2: case MAKEBLOCK3: case MAKEFLOATBLOCK: case GETFIELD: case SETFIELD: case GETFLOATFIELD: case SETFLOATFIELD: case BRANCH: case BRANCHIF: case BRANCHIFNOT: case PUSHTRAP: case CONSTINT: case PUSHCONSTINT: case OFFSETINT: case OFFSETREF: case OFFSETCLOSURE: case PUSHOFFSETCLOSURE: sprintf(buf, "%s %d", nam, pc[0]); break; /* Instructions with two operands */ case APPTERM: case CLOSURE: case CLOSUREREC: case PUSHGETGLOBALFIELD: case GETGLOBALFIELD: case MAKEBLOCK: case BEQ: case BNEQ: case BLTINT: case BLEINT: case BGTINT: case BGEINT: case BULTINT: case BUGEINT: sprintf(buf, "%s %d, %d", nam, pc[0], pc[1]); break; case SWITCH: sprintf(buf, "SWITCH sz%#lx=%ld::ntag%ld nint%ld", (long) pc[0], (long) pc[0], (unsigned long) pc[0] >> 16, (unsigned long) pc[0] & 0xffff); break; /* Instructions with a C primitive as operand */ case C_CALLN: sprintf(buf, "%s %d,", nam, pc[0]); pc++; /* fallthrough */ case C_CALL1: case C_CALL2: case C_CALL3: case C_CALL4: case C_CALL5: if (pc[0] < 0 || pc[0] >= caml_prim_name_table.size) sprintf(buf, "%s unknown primitive %d", nam, pc[0]); else sprintf(buf, "%s %s", nam, (char *) caml_prim_name_table.contents[pc[0]]); break; default: sprintf(buf, "%s", nam); break; }; return buf; } void caml_trace_value_file (value v, code_t prog, int proglen, FILE * f) { int i; fprintf (f, "%#lx", v); if (!v) return; if (prog && v % sizeof (int) == 0 && (code_t) v >= prog && (code_t) v < (code_t) ((char *) prog + proglen)) fprintf (f, "=code@%d", (code_t) v - prog); else if (Is_long (v)) fprintf (f, "=long%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val (v)); else if ((void*)v >= (void*)caml_stack_low && (void*)v < (void*)caml_stack_high) fprintf (f, "=stack_%d", (intnat*)caml_stack_high - (intnat*)v); else if (Is_block (v)) { int s = Wosize_val (v); int tg = Tag_val (v); int l = 0; switch (tg) { case Closure_tag: fprintf (f, "=closure[s%d,cod%d]", s, (code_t) (Code_val (v)) - prog); goto displayfields; case String_tag: l = caml_string_length (v); fprintf (f, "=string[s%dL%d]'", s, l); for (i = 0; i < ((l>0x1f)?0x1f:l) ; i++) { if (isprint (Byte (v, i))) putc (Byte (v, i), f); else putc ('?', f); }; fprintf (f, "'"); goto displayfields; case Double_tag: fprintf (f, "=float[s%d]=%g", s, Double_val (v)); goto displayfields; case Double_array_tag: fprintf (f, "=floatarray[s%d]", s); for (i = 0; i < ((s>0xf)?0xf:s); i++) fprintf (f, " %g", Double_field (v, i)); goto displayfields; case Abstract_tag: fprintf (f, "=abstract[s%d]", s); goto displayfields; case Custom_tag: fprintf (f, "=custom[s%d]", s); goto displayfields; default: fprintf (f, "=block", tg, s); displayfields: if (s > 0) fputs ("=(", f); for (i = 0; i < s; i++) { if (i > 20) { fputs ("....", f); break; }; if (i > 0) putc (' ', f); fprintf (f, "%#lx", Field (v, i)); }; if (s > 0) putc (')', f); }; } } void caml_trace_accu_sp_file (value accu, value * sp, code_t prog, int proglen, FILE * f) { int i; value *p; fprintf (f, "accu="); caml_trace_value_file (accu, prog, proglen, f); fprintf (f, "\n sp=%#" ARCH_INTNAT_PRINTF_FORMAT "x @%d:", (intnat) sp, caml_stack_high - sp); for (p = sp, i = 0; i < 12 + (1 << caml_trace_flag) && p < caml_stack_high; p++, i++) { fprintf (f, "\n[%d] ", caml_stack_high - p); caml_trace_value_file (*p, prog, proglen, f); }; putc ('\n', f); fflush (f); } #endif /* DEBUG */ mingw-ocaml/ocaml/byterun/custom.h0000644000175000017500000000473312124403240016637 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ /* */ /* Copyright 2000 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_CUSTOM_H #define CAML_CUSTOM_H #ifndef CAML_NAME_SPACE #include "compatibility.h" #endif #include "mlvalues.h" struct custom_operations { char *identifier; void (*finalize)(value v); int (*compare)(value v1, value v2); intnat (*hash)(value v); void (*serialize)(value v, /*out*/ uintnat * wsize_32 /*size in bytes*/, /*out*/ uintnat * wsize_64 /*size in bytes*/); uintnat (*deserialize)(void * dst); int (*compare_ext)(value v1, value v2); }; #define custom_finalize_default NULL #define custom_compare_default NULL #define custom_hash_default NULL #define custom_serialize_default NULL #define custom_deserialize_default NULL #define custom_compare_ext_default NULL #define Custom_ops_val(v) (*((struct custom_operations **) (v))) #ifdef __cplusplus extern "C" { #endif CAMLextern value caml_alloc_custom(struct custom_operations * ops, uintnat size, /*size in bytes*/ mlsize_t mem, /*resources consumed*/ mlsize_t max /*max resources*/); CAMLextern void caml_register_custom_operations(struct custom_operations * ops); CAMLextern int caml_compare_unordered; /* Used by custom comparison to report unordered NaN-like cases. */ /* */ extern struct custom_operations * caml_find_custom_operations(char * ident); extern struct custom_operations * caml_final_custom_operations(void (*fn)(value)); extern void caml_init_custom_operations(void); /* */ #ifdef __cplusplus } #endif #endif /* CAML_CUSTOM_H */ mingw-ocaml/ocaml/byterun/stacks.h0000644000175000017500000000311012124403240016601 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* structure of the stacks */ #ifndef CAML_STACKS_H #define CAML_STACKS_H #include "misc.h" #include "mlvalues.h" #include "memory.h" CAMLextern value * caml_stack_low; CAMLextern value * caml_stack_high; CAMLextern value * caml_stack_threshold; CAMLextern value * caml_extern_sp; CAMLextern value * caml_trapsp; CAMLextern value * caml_trap_barrier; #define Trap_pc(tp) (((code_t *)(tp))[0]) #define Trap_link(tp) (((value **)(tp))[1]) void caml_init_stack (uintnat init_max_size); void caml_realloc_stack (asize_t required_size); void caml_change_max_stack_size (uintnat new_max_size); uintnat caml_stack_usage (void); CAMLextern uintnat (*caml_stack_usage_hook)(void); #endif /* CAML_STACKS_H */ mingw-ocaml/ocaml/byterun/sys.c0000644000175000017500000002122712124403240016133 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Basic system calls */ #include #include #include #include #include #include #include #include #include #if !_WIN32 #include #endif #include "config.h" #ifdef HAS_UNISTD #include #endif #ifdef HAS_TIMES #include #endif #ifdef HAS_GETRUSAGE #include #include #endif #ifdef HAS_GETTIMEOFDAY #include #endif #include "alloc.h" #include "debugger.h" #include "fail.h" #include "instruct.h" #include "mlvalues.h" #include "osdeps.h" #include "signals.h" #include "stacks.h" #include "sys.h" static char * error_message(void) { return strerror(errno); } #ifndef EAGAIN #define EAGAIN (-1) #endif #ifndef EWOULDBLOCK #define EWOULDBLOCK (-1) #endif CAMLexport void caml_sys_error(value arg) { CAMLparam1 (arg); char * err; CAMLlocal1 (str); err = error_message(); if (arg == NO_ARG) { str = caml_copy_string(err); } else { int err_len = strlen(err); int arg_len = caml_string_length(arg); str = caml_alloc_string(arg_len + 2 + err_len); memmove(&Byte(str, 0), String_val(arg), arg_len); memmove(&Byte(str, arg_len), ": ", 2); memmove(&Byte(str, arg_len + 2), err, err_len); } caml_raise_sys_error(str); CAMLnoreturn; } CAMLexport void caml_sys_io_error(value arg) { if (errno == EAGAIN || errno == EWOULDBLOCK) { caml_raise_sys_blocked_io(); } else { caml_sys_error(arg); } } CAMLprim value caml_sys_exit(value retcode) { #ifndef NATIVE_CODE caml_debugger(PROGRAM_EXIT); #endif exit(Int_val(retcode)); return Val_unit; } #ifndef O_BINARY #define O_BINARY 0 #endif #ifndef O_TEXT #define O_TEXT 0 #endif #ifndef O_NONBLOCK #ifdef O_NDELAY #define O_NONBLOCK O_NDELAY #else #define O_NONBLOCK 0 #endif #endif static int sys_open_flags[] = { O_RDONLY, O_WRONLY, O_APPEND | O_WRONLY, O_CREAT, O_TRUNC, O_EXCL, O_BINARY, O_TEXT, O_NONBLOCK }; CAMLprim value caml_sys_open(value path, value vflags, value vperm) { CAMLparam3(path, vflags, vperm); int fd, flags, perm; char * p; p = caml_stat_alloc(caml_string_length(path) + 1); strcpy(p, String_val(path)); flags = caml_convert_flag_list(vflags, sys_open_flags); perm = Int_val(vperm); /* open on a named FIFO can block (PR#1533) */ caml_enter_blocking_section(); fd = open(p, flags, perm); /* fcntl on a fd can block (PR#5069)*/ #if defined(F_SETFD) && defined(FD_CLOEXEC) if (fd != -1) fcntl(fd, F_SETFD, FD_CLOEXEC); #endif caml_leave_blocking_section(); caml_stat_free(p); if (fd == -1) caml_sys_error(path); CAMLreturn(Val_long(fd)); } CAMLprim value caml_sys_close(value fd) { close(Int_val(fd)); return Val_unit; } CAMLprim value caml_sys_file_exists(value name) { struct stat st; return Val_bool(stat(String_val(name), &st) == 0); } CAMLprim value caml_sys_is_directory(value name) { struct stat st; if (stat(String_val(name), &st) == -1) caml_sys_error(name); #ifdef S_ISDIR return Val_bool(S_ISDIR(st.st_mode)); #else return Val_bool(st.st_mode & S_IFDIR); #endif } CAMLprim value caml_sys_remove(value name) { int ret; ret = unlink(String_val(name)); if (ret != 0) caml_sys_error(name); return Val_unit; } CAMLprim value caml_sys_rename(value oldname, value newname) { if (rename(String_val(oldname), String_val(newname)) != 0) caml_sys_error(NO_ARG); return Val_unit; } CAMLprim value caml_sys_chdir(value dirname) { if (chdir(String_val(dirname)) != 0) caml_sys_error(dirname); return Val_unit; } CAMLprim value caml_sys_getcwd(value unit) { char buff[4096]; #ifdef HAS_GETCWD if (getcwd(buff, sizeof(buff)) == 0) caml_sys_error(NO_ARG); #else if (getwd(buff) == 0) caml_sys_error(NO_ARG); #endif /* HAS_GETCWD */ return caml_copy_string(buff); } CAMLprim value caml_sys_getenv(value var) { char * res; res = getenv(String_val(var)); if (res == 0) caml_raise_not_found(); return caml_copy_string(res); } char * caml_exe_name; static char ** caml_main_argv; CAMLprim value caml_sys_get_argv(value unit) { CAMLparam0 (); /* unit is unused */ CAMLlocal3 (exe_name, argv, res); exe_name = caml_copy_string(caml_exe_name); argv = caml_copy_string_array((char const **) caml_main_argv); res = caml_alloc_small(2, 0); Field(res, 0) = exe_name; Field(res, 1) = argv; CAMLreturn(res); } void caml_sys_init(char * exe_name, char **argv) { caml_exe_name = exe_name; caml_main_argv = argv; } #ifdef _WIN32 #define WIFEXITED(status) 1 #define WEXITSTATUS(status) (status) #else #if !(defined(WIFEXITED) && defined(WEXITSTATUS)) /* Assume old-style V7 status word */ #define WIFEXITED(status) (((status) & 0xFF) == 0) #define WEXITSTATUS(status) (((status) >> 8) & 0xFF) #endif #endif CAMLprim value caml_sys_system_command(value command) { CAMLparam1 (command); int status, retcode; char *buf; intnat len; len = caml_string_length (command); buf = caml_stat_alloc (len + 1); memmove (buf, String_val (command), len + 1); caml_enter_blocking_section (); status = system(buf); caml_leave_blocking_section (); caml_stat_free(buf); if (status == -1) caml_sys_error(command); if (WIFEXITED(status)) retcode = WEXITSTATUS(status); else retcode = 255; CAMLreturn (Val_int(retcode)); } CAMLprim value caml_sys_time(value unit) { #ifdef HAS_GETRUSAGE struct rusage ru; getrusage (RUSAGE_SELF, &ru); return caml_copy_double (ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6 + ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6); #else #ifdef HAS_TIMES #ifndef CLK_TCK #ifdef HZ #define CLK_TCK HZ #else #define CLK_TCK 60 #endif #endif struct tms t; times(&t); return caml_copy_double((double)(t.tms_utime + t.tms_stime) / CLK_TCK); #else /* clock() is standard ANSI C */ return caml_copy_double((double)clock() / CLOCKS_PER_SEC); #endif #endif } #ifdef _WIN32 extern int caml_win32_random_seed (intnat data[16]); #endif CAMLprim value caml_sys_random_seed (value unit) { intnat data[16]; int n, i; value res; #ifdef _WIN32 n = caml_win32_random_seed(data); #else int fd; n = 0; /* Try /dev/urandom first */ fd = open("/dev/urandom", O_RDONLY, 0); if (fd != -1) { unsigned char buffer[12]; int nread = read(fd, buffer, 12); close(fd); while (nread > 0) data[n++] = buffer[--nread]; } /* If the read from /dev/urandom fully succeeded, we now have 96 bits of good random data and can stop here. Otherwise, complement whatever we got (probably nothing) with some not-very-random data. */ if (n < 12) { #ifdef HAS_GETTIMEOFDAY struct timeval tv; gettimeofday(&tv, NULL); data[n++] = tv.tv_usec; data[n++] = tv.tv_sec; #else data[n++] = time(NULL); #endif #ifdef HAS_UNISTD data[n++] = getpid(); data[n++] = getppid(); #endif } #endif /* Convert to an OCaml array of ints */ res = caml_alloc_small(n, 0); for (i = 0; i < n; i++) Field(res, i) = Val_long(data[i]); return res; } CAMLprim value caml_sys_get_config(value unit) { CAMLparam0 (); /* unit is unused */ CAMLlocal2 (result, ostype); ostype = caml_copy_string(OCAML_OS_TYPE); result = caml_alloc_small (3, 0); Field(result, 0) = ostype; Field(result, 1) = Val_long (8 * sizeof(value)); #ifdef ARCH_BIG_ENDIAN Field(result, 2) = Val_true; #else Field(result, 2) = Val_false; #endif CAMLreturn (result); } CAMLprim value caml_sys_read_directory(value path) { CAMLparam1(path); CAMLlocal1(result); struct ext_table tbl; caml_ext_table_init(&tbl, 50); if (caml_read_directory(String_val(path), &tbl) == -1){ caml_ext_table_free(&tbl, 1); caml_sys_error(path); } caml_ext_table_add(&tbl, NULL); result = caml_copy_string_array((char const **) tbl.contents); caml_ext_table_free(&tbl, 1); CAMLreturn(result); } mingw-ocaml/ocaml/byterun/hash.h0000644000175000017500000000254612124403240016250 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ /* */ /* Copyright 2011 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Auxiliary functions for custom hash functions */ #ifndef CAML_HASH_H #define CAML_HASH_H #include "mlvalues.h" CAMLextern uint32 caml_hash_mix_uint32(uint32 h, uint32 d); CAMLextern uint32 caml_hash_mix_intnat(uint32 h, intnat d); CAMLextern uint32 caml_hash_mix_int64(uint32 h, int64 d); CAMLextern uint32 caml_hash_mix_double(uint32 h, double d); CAMLextern uint32 caml_hash_mix_float(uint32 h, float d); CAMLextern uint32 caml_hash_mix_string(uint32 h, value s); #endif mingw-ocaml/ocaml/byterun/finalise.h0000644000175000017500000000242612124403240017114 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Moscova, INRIA Rocquencourt */ /* */ /* Copyright 2000 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_FINALISE_H #define CAML_FINALISE_H #include "roots.h" void caml_final_update (void); void caml_final_do_calls (void); void caml_final_do_strong_roots (scanning_action f); void caml_final_do_weak_roots (scanning_action f); void caml_final_do_young_roots (scanning_action f); void caml_final_empty_young (void); value caml_final_register (value f, value v); #endif /* CAML_FINALISE_H */ mingw-ocaml/ocaml/byterun/major_gc.h0000644000175000017500000000436012124403240017102 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_MAJOR_GC_H #define CAML_MAJOR_GC_H #include "freelist.h" #include "misc.h" typedef struct { void *block; /* address of the malloced block this chunk live in */ asize_t alloc; /* in bytes, used for compaction */ asize_t size; /* in bytes */ char *next; } heap_chunk_head; #define Chunk_size(c) (((heap_chunk_head *) (c)) [-1]).size #define Chunk_alloc(c) (((heap_chunk_head *) (c)) [-1]).alloc #define Chunk_next(c) (((heap_chunk_head *) (c)) [-1]).next #define Chunk_block(c) (((heap_chunk_head *) (c)) [-1]).block extern int caml_gc_phase; extern int caml_gc_subphase; extern uintnat caml_allocated_words; extern double caml_extra_heap_resources; extern uintnat caml_dependent_size, caml_dependent_allocated; extern uintnat caml_fl_size_at_phase_change; #define Phase_mark 0 #define Phase_sweep 1 #define Phase_idle 2 #define Subphase_main 10 #define Subphase_weak1 11 #define Subphase_weak2 12 #define Subphase_final 13 CAMLextern char *caml_heap_start; extern uintnat total_heap_size; extern char *caml_gc_sweep_hp; void caml_init_major_heap (asize_t); /* size in bytes */ asize_t caml_round_heap_chunk_size (asize_t); /* size in bytes */ void caml_darken (value, value *); intnat caml_major_collection_slice (intnat); void major_collection (void); void caml_finish_major_cycle (void); #endif /* CAML_MAJOR_GC_H */ mingw-ocaml/ocaml/byterun/startup.c0000644000175000017500000003622412124403240017022 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Start-up code */ #include #include #include #include #include "config.h" #ifdef HAS_UNISTD #include #endif #ifdef _WIN32 #include #endif #include "alloc.h" #include "backtrace.h" #include "callback.h" #include "custom.h" #include "debugger.h" #include "dynlink.h" #include "exec.h" #include "fail.h" #include "fix_code.h" #include "freelist.h" #include "gc_ctrl.h" #include "instrtrace.h" #include "interp.h" #include "intext.h" #include "io.h" #include "memory.h" #include "minor_gc.h" #include "misc.h" #include "mlvalues.h" #include "osdeps.h" #include "prims.h" #include "printexc.h" #include "reverse.h" #include "signals.h" #include "stacks.h" #include "sys.h" #include "startup.h" #include "version.h" #ifndef O_BINARY #define O_BINARY 0 #endif #ifndef SEEK_END #define SEEK_END 2 #endif extern int caml_parser_trace; CAMLexport header_t caml_atom_table[256]; /* Initialize the atom table */ static void init_atoms(void) { int i; for(i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white); if (caml_page_table_add(In_static_data, caml_atom_table, caml_atom_table + 256) != 0) { caml_fatal_error("Fatal error: not enough memory for the initial page table"); } } /* Read the trailer of a bytecode file */ static void fixup_endianness_trailer(uint32 * p) { #ifndef ARCH_BIG_ENDIAN Reverse_32(p, p); #endif } static int read_trailer(int fd, struct exec_trailer *trail) { lseek(fd, (long) -TRAILER_SIZE, SEEK_END); if (read(fd, (char *) trail, TRAILER_SIZE) < TRAILER_SIZE) return BAD_BYTECODE; fixup_endianness_trailer(&trail->num_sections); if (strncmp(trail->magic, EXEC_MAGIC, 12) == 0) return 0; else return BAD_BYTECODE; } int caml_attempt_open(char **name, struct exec_trailer *trail, int do_open_script) { char * truename; int fd; int err; char buf [2]; truename = caml_search_exe_in_path(*name); *name = truename; caml_gc_message(0x100, "Opening bytecode executable %s\n", (uintnat) truename); fd = open(truename, O_RDONLY | O_BINARY); if (fd == -1) { caml_gc_message(0x100, "Cannot open file\n", 0); return FILE_NOT_FOUND; } if (!do_open_script) { err = read (fd, buf, 2); if (err < 2 || (buf [0] == '#' && buf [1] == '!')) { close(fd); caml_gc_message(0x100, "Rejected #! script\n", 0); return BAD_BYTECODE; } } err = read_trailer(fd, trail); if (err != 0) { close(fd); caml_gc_message(0x100, "Not a bytecode executable\n", 0); return err; } return fd; } /* Read the section descriptors */ void caml_read_section_descriptors(int fd, struct exec_trailer *trail) { int toc_size, i; toc_size = trail->num_sections * 8; trail->section = caml_stat_alloc(toc_size); lseek(fd, - (long) (TRAILER_SIZE + toc_size), SEEK_END); if (read(fd, (char *) trail->section, toc_size) != toc_size) caml_fatal_error("Fatal error: cannot read section table\n"); /* Fixup endianness of lengths */ for (i = 0; i < trail->num_sections; i++) fixup_endianness_trailer(&(trail->section[i].len)); } /* Position fd at the beginning of the section having the given name. Return the length of the section data in bytes, or -1 if no section found with that name. */ int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name) { long ofs; int i; ofs = TRAILER_SIZE + trail->num_sections * 8; for (i = trail->num_sections - 1; i >= 0; i--) { ofs += trail->section[i].len; if (strncmp(trail->section[i].name, name, 4) == 0) { lseek(fd, -ofs, SEEK_END); return trail->section[i].len; } } return -1; } /* Position fd at the beginning of the section having the given name. Return the length of the section data in bytes. */ int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name) { int32 len = caml_seek_optional_section(fd, trail, name); if (len == -1) caml_fatal_error_arg("Fatal_error: section `%s' is missing\n", name); return len; } /* Read and return the contents of the section having the given name. Add a terminating 0. Return NULL if no such section. */ static char * read_section(int fd, struct exec_trailer *trail, char *name) { int32 len; char * data; len = caml_seek_optional_section(fd, trail, name); if (len == -1) return NULL; data = caml_stat_alloc(len + 1); if (read(fd, data, len) != len) caml_fatal_error_arg("Fatal error: error reading section %s\n", name); data[len] = 0; return data; } /* Invocation of ocamlrun: 4 cases. 1. runtime + bytecode user types: ocamlrun [options] bytecode args... arguments: ocamlrun [options] bytecode args... 2. bytecode script user types: bytecode args... 2a (kernel 1) arguments: ocamlrun ./bytecode args... 2b (kernel 2) arguments: bytecode bytecode args... 3. concatenated runtime and bytecode user types: composite args... arguments: composite args... Algorithm: 1- If argument 0 is a valid byte-code file that does not start with #!, then we are in case 3 and we pass the same command line to the OCaml program. 2- In all other cases, we parse the command line as: (whatever) [options] bytecode args... and we strip "(whatever) [options]" from the command line. */ /* Configuration parameters and flags */ static uintnat percent_free_init = Percent_free_def; static uintnat max_percent_free_init = Max_percent_free_def; static uintnat minor_heap_init = Minor_heap_def; static uintnat heap_chunk_init = Heap_chunk_def; static uintnat heap_size_init = Init_heap_def; static uintnat max_stack_init = Max_stack_def; /* Parse options on the command line */ static int parse_command_line(char **argv) { int i, j; for(i = 1; argv[i] != NULL && argv[i][0] == '-'; i++) { switch(argv[i][1]) { #ifdef DEBUG case 't': caml_trace_flag++; break; #endif case 'v': if (!strcmp (argv[i], "-version")){ printf ("The OCaml runtime, version " OCAML_VERSION "\n"); exit (0); }else if (!strcmp (argv[i], "-vnum")){ printf (OCAML_VERSION "\n"); exit (0); }else{ caml_verb_gc = 0x001+0x004+0x008+0x010+0x020; } break; case 'p': for (j = 0; caml_names_of_builtin_cprim[j] != NULL; j++) printf("%s\n", caml_names_of_builtin_cprim[j]); exit(0); break; case 'b': caml_record_backtrace(Val_true); break; case 'I': if (argv[i + 1] != NULL) { caml_ext_table_add(&caml_shared_libs_path, argv[i + 1]); i++; } break; default: caml_fatal_error_arg("Unknown option %s.\n", argv[i]); } } return i; } /* Parse the OCAMLRUNPARAM variable */ /* The option letter for each runtime option is the first letter of the last word of the ML name of the option (see [stdlib/gc.mli]). Except for l (maximum stack size) and h (initial heap size). */ /* If you change these functions, see also their copy in asmrun/startup.c */ static void scanmult (char *opt, uintnat *var) { char mult = ' '; unsigned int val; sscanf (opt, "=%u%c", &val, &mult); sscanf (opt, "=0x%x%c", &val, &mult); switch (mult) { case 'k': *var = (uintnat) val * 1024; break; case 'M': *var = (uintnat) val * 1024 * 1024; break; case 'G': *var = (uintnat) val * 1024 * 1024 * 1024; break; default: *var = (uintnat) val; break; } } static void parse_camlrunparam(void) { char *opt = getenv ("OCAMLRUNPARAM"); uintnat p; if (opt == NULL) opt = getenv ("CAMLRUNPARAM"); if (opt != NULL){ while (*opt != '\0'){ switch (*opt++){ case 's': scanmult (opt, &minor_heap_init); break; case 'i': scanmult (opt, &heap_chunk_init); break; case 'h': scanmult (opt, &heap_size_init); break; case 'l': scanmult (opt, &max_stack_init); break; case 'o': scanmult (opt, &percent_free_init); break; case 'O': scanmult (opt, &max_percent_free_init); break; case 'v': scanmult (opt, &caml_verb_gc); break; case 'b': caml_record_backtrace(Val_true); break; case 'p': caml_parser_trace = 1; break; case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break; } } } } extern void caml_init_ieee_floats (void); #ifdef _WIN32 extern void caml_signal_thread(void * lpParam); #endif /* Main entry point when loading code from a file */ CAMLexport void caml_main(char **argv) { int fd, pos; struct exec_trailer trail; struct channel * chan; value res; char * shared_lib_path, * shared_libs, * req_prims; char * exe_name; #ifdef __linux__ static char proc_self_exe[256]; #endif /* Machine-dependent initialization of the floating-point hardware so that it behaves as much as possible as specified in IEEE */ caml_init_ieee_floats(); caml_init_custom_operations(); caml_ext_table_init(&caml_shared_libs_path, 8); caml_external_raise = NULL; /* Determine options and position of bytecode file */ #ifdef DEBUG caml_verb_gc = 0xBF; #endif parse_camlrunparam(); pos = 0; exe_name = argv[0]; #ifdef __linux__ if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) exe_name = proc_self_exe; #endif fd = caml_attempt_open(&exe_name, &trail, 0); if (fd < 0) { pos = parse_command_line(argv); if (argv[pos] == 0) caml_fatal_error("No bytecode file specified.\n"); exe_name = argv[pos]; fd = caml_attempt_open(&exe_name, &trail, 1); switch(fd) { case FILE_NOT_FOUND: caml_fatal_error_arg("Fatal error: cannot find file '%s'\n", argv[pos]); break; case BAD_BYTECODE: caml_fatal_error_arg( "Fatal error: the file '%s' is not a bytecode executable file\n", exe_name); break; } } /* Read the table of contents (section descriptors) */ caml_read_section_descriptors(fd, &trail); /* Initialize the abstract machine */ caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, percent_free_init, max_percent_free_init); caml_init_stack (max_stack_init); init_atoms(); /* Initialize the interpreter */ caml_interprete(NULL, 0); /* Initialize the debugger, if needed */ caml_debugger_init(); /* Load the code */ caml_code_size = caml_seek_section(fd, &trail, "CODE"); caml_load_code(fd, caml_code_size); /* Build the table of primitives */ shared_lib_path = read_section(fd, &trail, "DLPT"); shared_libs = read_section(fd, &trail, "DLLS"); req_prims = read_section(fd, &trail, "PRIM"); if (req_prims == NULL) caml_fatal_error("Fatal error: no PRIM section\n"); caml_build_primitive_table(shared_lib_path, shared_libs, req_prims); caml_stat_free(shared_lib_path); caml_stat_free(shared_libs); caml_stat_free(req_prims); /* Load the globals */ caml_seek_section(fd, &trail, "DATA"); chan = caml_open_descriptor_in(fd); caml_global_data = caml_input_val(chan); caml_close_channel(chan); /* this also closes fd */ caml_stat_free(trail.section); /* Ensure that the globals are in the major heap. */ caml_oldify_one (caml_global_data, &caml_global_data); caml_oldify_mopup (); /* Initialize system libraries */ caml_init_exceptions(); caml_sys_init(exe_name, argv + pos); #ifdef _WIN32 /* Start a thread to handle signals */ if (getenv("CAMLSIGPIPE")) _beginthread(caml_signal_thread, 4096, NULL); #endif /* Execute the program */ caml_debugger(PROGRAM_START); res = caml_interprete(caml_start_code, caml_code_size); if (Is_exception_result(res)) { caml_exn_bucket = Extract_exception(res); if (caml_debugger_in_use) { caml_extern_sp = &caml_exn_bucket; /* The debugger needs the exception value.*/ caml_debugger(UNCAUGHT_EXC); } caml_fatal_uncaught_exception(caml_exn_bucket); } } /* Main entry point when code is linked in as initialized data */ CAMLexport void caml_startup_code( code_t code, asize_t code_size, char *data, asize_t data_size, char *section_table, asize_t section_table_size, char **argv) { value res; char* cds_file; char * exe_name; #ifdef __linux__ static char proc_self_exe[256]; #endif caml_init_ieee_floats(); caml_init_custom_operations(); #ifdef DEBUG caml_verb_gc = 63; #endif cds_file = getenv("CAML_DEBUG_FILE"); if (cds_file != NULL) { caml_cds_file = caml_stat_alloc(strlen(cds_file) + 1); strcpy(caml_cds_file, cds_file); } parse_camlrunparam(); exe_name = argv[0]; #ifdef __linux__ if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) exe_name = proc_self_exe; #endif caml_external_raise = NULL; /* Initialize the abstract machine */ caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, percent_free_init, max_percent_free_init); caml_init_stack (max_stack_init); init_atoms(); /* Initialize the interpreter */ caml_interprete(NULL, 0); /* Initialize the debugger, if needed */ caml_debugger_init(); /* Load the code */ caml_start_code = code; caml_code_size = code_size; caml_init_code_fragments(); if (caml_debugger_in_use) { int len, i; len = code_size / sizeof(opcode_t); caml_saved_code = (unsigned char *) caml_stat_alloc(len); for (i = 0; i < len; i++) caml_saved_code[i] = caml_start_code[i]; } #ifdef THREADED_CODE caml_thread_code(caml_start_code, code_size); #endif /* Use the builtin table of primitives */ caml_build_primitive_table_builtin(); /* Load the globals */ caml_global_data = caml_input_value_from_block(data, data_size); /* Ensure that the globals are in the major heap. */ caml_oldify_one (caml_global_data, &caml_global_data); caml_oldify_mopup (); /* Record the sections (for caml_get_section_table in meta.c) */ caml_section_table = section_table; caml_section_table_size = section_table_size; /* Initialize system libraries */ caml_init_exceptions(); caml_sys_init(exe_name, argv); /* Execute the program */ caml_debugger(PROGRAM_START); res = caml_interprete(caml_start_code, caml_code_size); if (Is_exception_result(res)) { caml_exn_bucket = Extract_exception(res); if (caml_debugger_in_use) { caml_extern_sp = &caml_exn_bucket; /* The debugger needs the exception value.*/ caml_debugger(UNCAUGHT_EXC); } caml_fatal_uncaught_exception(caml_exn_bucket); } } mingw-ocaml/ocaml/byterun/main.c0000644000175000017500000000375512124403240016247 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Main entry point (can be overridden by a user-provided main() function that calls caml_main() later). */ #include "misc.h" #include "mlvalues.h" #include "sys.h" CAMLextern void caml_main (char **); #ifdef _WIN32 CAMLextern void caml_expand_command_line (int *, char ***); #endif int main(int argc, char **argv) { #ifdef DEBUG { char *ocp; char *cp; int i; caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0); #if 0 caml_gc_message (-1, "### command line:", 0); for (i = 0; i < argc; i++){ caml_gc_message (-1, " %s", argv[i]); } caml_gc_message (-1, "\n", 0); ocp = getenv ("OCAMLRUNPARAM"); caml_gc_message (-1, "### OCAMLRUNPARAM=%s\n", ocp == NULL ? "" : ocp); cp = getenv ("CAMLRUNPARAM"); caml_gc_message (-1, "### CAMLRUNPARAM=%s\n", cp == NULL ? "" : cp); caml_gc_message (-1, "### working dir: %s\n", getcwd (NULL, 0)); #endif } #endif #ifdef _WIN32 /* Expand wildcards and diversions in command line */ caml_expand_command_line(&argc, &argv); #endif caml_main(argv); caml_sys_exit(Val_int(0)); return 0; /* not reached */ } mingw-ocaml/ocaml/byterun/minor_gc.c0000644000175000017500000002421412124403240017111 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "config.h" #include "fail.h" #include "finalise.h" #include "gc.h" #include "gc_ctrl.h" #include "major_gc.h" #include "memory.h" #include "minor_gc.h" #include "misc.h" #include "mlvalues.h" #include "roots.h" #include "signals.h" #include "weak.h" asize_t caml_minor_heap_size; static void *caml_young_base = NULL; CAMLexport char *caml_young_start = NULL, *caml_young_end = NULL; CAMLexport char *caml_young_ptr = NULL, *caml_young_limit = NULL; CAMLexport struct caml_ref_table caml_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}, caml_weak_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}; int caml_in_minor_collection = 0; #ifdef DEBUG static unsigned long minor_gc_counter = 0; #endif void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv) { value **new_table; tbl->size = sz; tbl->reserve = rsv; new_table = (value **) caml_stat_alloc ((tbl->size + tbl->reserve) * sizeof (value *)); if (tbl->base != NULL) caml_stat_free (tbl->base); tbl->base = new_table; tbl->ptr = tbl->base; tbl->threshold = tbl->base + tbl->size; tbl->limit = tbl->threshold; tbl->end = tbl->base + tbl->size + tbl->reserve; } static void reset_table (struct caml_ref_table *tbl) { tbl->size = 0; tbl->reserve = 0; if (tbl->base != NULL) caml_stat_free (tbl->base); tbl->base = tbl->ptr = tbl->threshold = tbl->limit = tbl->end = NULL; } static void clear_table (struct caml_ref_table *tbl) { tbl->ptr = tbl->base; tbl->limit = tbl->threshold; } void caml_set_minor_heap_size (asize_t size) { char *new_heap; void *new_heap_base; Assert (size >= Minor_heap_min); Assert (size <= Minor_heap_max); Assert (size % sizeof (value) == 0); if (caml_young_ptr != caml_young_end) caml_minor_collection (); Assert (caml_young_ptr == caml_young_end); new_heap = caml_aligned_malloc(size, 0, &new_heap_base); if (new_heap == NULL) caml_raise_out_of_memory(); if (caml_page_table_add(In_young, new_heap, new_heap + size) != 0) caml_raise_out_of_memory(); if (caml_young_start != NULL){ caml_page_table_remove(In_young, caml_young_start, caml_young_end); free (caml_young_base); } caml_young_base = new_heap_base; caml_young_start = new_heap; caml_young_end = new_heap + size; caml_young_limit = caml_young_start; caml_young_ptr = caml_young_end; caml_minor_heap_size = size; reset_table (&caml_ref_table); reset_table (&caml_weak_ref_table); } static value oldify_todo_list = 0; /* Note that the tests on the tag depend on the fact that Infix_tag, Forward_tag, and No_scan_tag are contiguous. */ void caml_oldify_one (value v, value *p) { value result; header_t hd; mlsize_t sz, i; tag_t tag; tail_call: if (Is_block (v) && Is_young (v)){ Assert (Hp_val (v) >= caml_young_ptr); hd = Hd_val (v); if (hd == 0){ /* If already forwarded */ *p = Field (v, 0); /* then forward pointer is first field. */ }else{ tag = Tag_hd (hd); if (tag < Infix_tag){ value field0; sz = Wosize_hd (hd); result = caml_alloc_shr (sz, tag); *p = result; field0 = Field (v, 0); Hd_val (v) = 0; /* Set forward flag */ Field (v, 0) = result; /* and forward pointer. */ if (sz > 1){ Field (result, 0) = field0; Field (result, 1) = oldify_todo_list; /* Add this block */ oldify_todo_list = v; /* to the "to do" list. */ }else{ Assert (sz == 1); p = &Field (result, 0); v = field0; goto tail_call; } }else if (tag >= No_scan_tag){ sz = Wosize_hd (hd); result = caml_alloc_shr (sz, tag); for (i = 0; i < sz; i++) Field (result, i) = Field (v, i); Hd_val (v) = 0; /* Set forward flag */ Field (v, 0) = result; /* and forward pointer. */ *p = result; }else if (tag == Infix_tag){ mlsize_t offset = Infix_offset_hd (hd); caml_oldify_one (v - offset, p); /* Cannot recurse deeper than 1. */ *p += offset; }else{ value f = Forward_val (v); tag_t ft = 0; int vv = 1; Assert (tag == Forward_tag); if (Is_block (f)){ if (Is_young (f)){ vv = 1; ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f); }else{ vv = Is_in_value_area(f); if (vv){ ft = Tag_val (f); } } } if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){ /* Do not short-circuit the pointer. Copy as a normal block. */ Assert (Wosize_hd (hd) == 1); result = caml_alloc_shr (1, Forward_tag); *p = result; Hd_val (v) = 0; /* Set (GC) forward flag */ Field (v, 0) = result; /* and forward pointer. */ p = &Field (result, 0); v = f; goto tail_call; }else{ v = f; /* Follow the forwarding */ goto tail_call; /* then oldify. */ } } } }else{ *p = v; } } /* Finish the work that was put off by [caml_oldify_one]. Note that [caml_oldify_one] itself is called by oldify_mopup, so we have to be careful to remove the first entry from the list before oldifying its fields. */ void caml_oldify_mopup (void) { value v, new_v, f; mlsize_t i; while (oldify_todo_list != 0){ v = oldify_todo_list; /* Get the head. */ Assert (Hd_val (v) == 0); /* It must be forwarded. */ new_v = Field (v, 0); /* Follow forward pointer. */ oldify_todo_list = Field (new_v, 1); /* Remove from list. */ f = Field (new_v, 0); if (Is_block (f) && Is_young (f)){ caml_oldify_one (f, &Field (new_v, 0)); } for (i = 1; i < Wosize_val (new_v); i++){ f = Field (v, i); if (Is_block (f) && Is_young (f)){ caml_oldify_one (f, &Field (new_v, i)); }else{ Field (new_v, i) = f; } } } } /* Make sure the minor heap is empty by performing a minor collection if needed. */ void caml_empty_minor_heap (void) { value **r; if (caml_young_ptr != caml_young_end){ caml_in_minor_collection = 1; caml_gc_message (0x02, "<", 0); caml_oldify_local_roots(); for (r = caml_ref_table.base; r < caml_ref_table.ptr; r++){ caml_oldify_one (**r, *r); } caml_oldify_mopup (); for (r = caml_weak_ref_table.base; r < caml_weak_ref_table.ptr; r++){ if (Is_block (**r) && Is_young (**r)){ if (Hd_val (**r) == 0){ **r = Field (**r, 0); }else{ **r = caml_weak_none; } } } if (caml_young_ptr < caml_young_start) caml_young_ptr = caml_young_start; caml_stat_minor_words += Wsize_bsize (caml_young_end - caml_young_ptr); caml_young_ptr = caml_young_end; caml_young_limit = caml_young_start; clear_table (&caml_ref_table); clear_table (&caml_weak_ref_table); caml_gc_message (0x02, ">", 0); caml_in_minor_collection = 0; } caml_final_empty_young (); #ifdef DEBUG { value *p; for (p = (value *) caml_young_start; p < (value *) caml_young_end; ++p){ *p = Debug_free_minor; } ++ minor_gc_counter; } #endif } /* Do a minor collection and a slice of major collection, call finalisation functions, etc. Leave the minor heap empty. */ CAMLexport void caml_minor_collection (void) { intnat prev_alloc_words = caml_allocated_words; caml_empty_minor_heap (); caml_stat_promoted_words += caml_allocated_words - prev_alloc_words; ++ caml_stat_minor_collections; caml_major_collection_slice (0); caml_force_major_slice = 0; caml_final_do_calls (); caml_empty_minor_heap (); } CAMLexport value caml_check_urgent_gc (value extra_root) { CAMLparam1 (extra_root); if (caml_force_major_slice) caml_minor_collection(); CAMLreturn (extra_root); } void caml_realloc_ref_table (struct caml_ref_table *tbl) { Assert (tbl->ptr == tbl->limit); Assert (tbl->limit <= tbl->end); Assert (tbl->limit >= tbl->threshold); if (tbl->base == NULL){ caml_alloc_table (tbl, caml_minor_heap_size / sizeof (value) / 8, 256); }else if (tbl->limit == tbl->threshold){ caml_gc_message (0x08, "ref_table threshold crossed\n", 0); tbl->limit = tbl->end; caml_urge_major_slice (); }else{ /* This will almost never happen with the bytecode interpreter. */ asize_t sz; asize_t cur_ptr = tbl->ptr - tbl->base; Assert (caml_force_major_slice); tbl->size *= 2; sz = (tbl->size + tbl->reserve) * sizeof (value *); caml_gc_message (0x08, "Growing ref_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n", (intnat) sz/1024); tbl->base = (value **) realloc ((char *) tbl->base, sz); if (tbl->base == NULL){ caml_fatal_error ("Fatal error: ref_table overflow\n"); } tbl->end = tbl->base + tbl->size + tbl->reserve; tbl->threshold = tbl->base + tbl->size; tbl->ptr = tbl->base + cur_ptr; tbl->limit = tbl->end; } } mingw-ocaml/ocaml/byterun/interp.c0000644000175000017500000007303212124403240016617 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* The bytecode interpreter */ #include #include "alloc.h" #include "backtrace.h" #include "callback.h" #include "debugger.h" #include "fail.h" #include "fix_code.h" #include "instrtrace.h" #include "instruct.h" #include "interp.h" #include "major_gc.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" #include "prims.h" #include "signals.h" #include "stacks.h" /* Registers for the abstract machine: pc the code pointer sp the stack pointer (grows downward) accu the accumulator env heap-allocated environment caml_trapsp pointer to the current trap frame extra_args number of extra arguments provided by the caller sp is a local copy of the global variable caml_extern_sp. */ /* Instruction decoding */ #ifdef THREADED_CODE # define Instruct(name) lbl_##name # if defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) # define Jumptbl_base ((char *) &&lbl_ACC0) # else # define Jumptbl_base ((char *) 0) # define jumptbl_base ((char *) 0) # endif # ifdef DEBUG # define Next goto next_instr # else # define Next goto *(void *)(jumptbl_base + *pc++) # endif #else # define Instruct(name) case name # define Next break #endif /* GC interface */ #define Setup_for_gc \ { sp -= 2; sp[0] = accu; sp[1] = env; caml_extern_sp = sp; } #define Restore_after_gc \ { accu = sp[0]; env = sp[1]; sp += 2; } #define Setup_for_c_call \ { saved_pc = pc; *--sp = env; caml_extern_sp = sp; } #define Restore_after_c_call \ { sp = caml_extern_sp; env = *sp++; saved_pc = NULL; } /* An event frame must look like accu + a C_CALL frame + a RETURN 1 frame */ #define Setup_for_event \ { sp -= 6; \ sp[0] = accu; /* accu */ \ sp[1] = Val_unit; /* C_CALL frame: dummy environment */ \ sp[2] = Val_unit; /* RETURN frame: dummy local 0 */ \ sp[3] = (value) pc; /* RETURN frame: saved return address */ \ sp[4] = env; /* RETURN frame: saved environment */ \ sp[5] = Val_long(extra_args); /* RETURN frame: saved extra args */ \ caml_extern_sp = sp; } #define Restore_after_event \ { sp = caml_extern_sp; accu = sp[0]; \ pc = (code_t) sp[3]; env = sp[4]; extra_args = Long_val(sp[5]); \ sp += 6; } /* Debugger interface */ #define Setup_for_debugger \ { sp -= 4; \ sp[0] = accu; sp[1] = (value)(pc - 1); \ sp[2] = env; sp[3] = Val_long(extra_args); \ caml_extern_sp = sp; } #define Restore_after_debugger { sp += 4; } #ifdef THREADED_CODE #define Restart_curr_instr \ goto *(jumptable[caml_saved_code[pc - 1 - caml_start_code]]) #else #define Restart_curr_instr \ curr_instr = caml_saved_code[pc - 1 - caml_start_code]; \ goto dispatch_instr #endif /* Register optimization. Some compilers underestimate the use of the local variables representing the abstract machine registers, and don't put them in hardware registers, which slows down the interpreter considerably. For GCC, I have hand-assigned hardware registers for several architectures. */ #if defined(__GNUC__) && !defined(DEBUG) && !defined(__INTEL_COMPILER) && !defined(__llvm__) #ifdef __mips__ #define PC_REG asm("$16") #define SP_REG asm("$17") #define ACCU_REG asm("$18") #endif #ifdef __sparc__ #define PC_REG asm("%l0") #define SP_REG asm("%l1") #define ACCU_REG asm("%l2") #endif #ifdef __alpha__ #ifdef __CRAY__ #define PC_REG asm("r9") #define SP_REG asm("r10") #define ACCU_REG asm("r11") #define JUMPTBL_BASE_REG asm("r12") #else #define PC_REG asm("$9") #define SP_REG asm("$10") #define ACCU_REG asm("$11") #define JUMPTBL_BASE_REG asm("$12") #endif #endif #ifdef __i386__ #define PC_REG asm("%esi") #define SP_REG asm("%edi") #define ACCU_REG #endif #if defined(__ppc__) || defined(__ppc64__) #define PC_REG asm("26") #define SP_REG asm("27") #define ACCU_REG asm("28") #endif #ifdef __hppa__ #define PC_REG asm("%r18") #define SP_REG asm("%r17") #define ACCU_REG asm("%r16") #endif #ifdef __mc68000__ #define PC_REG asm("a5") #define SP_REG asm("a4") #define ACCU_REG asm("d7") #endif /* PR#4953: these specific registers not available in Thumb mode */ #if defined (__arm__) && !defined(__thumb__) #define PC_REG asm("r6") #define SP_REG asm("r8") #define ACCU_REG asm("r7") #endif #ifdef __ia64__ #define PC_REG asm("36") #define SP_REG asm("37") #define ACCU_REG asm("38") #define JUMPTBL_BASE_REG asm("39") #endif #ifdef __x86_64__ #define PC_REG asm("%r15") #define SP_REG asm("%r14") #define ACCU_REG asm("%r13") #endif #endif /* Division and modulus madness */ #ifdef NONSTANDARD_DIV_MOD extern intnat caml_safe_div(intnat p, intnat q); extern intnat caml_safe_mod(intnat p, intnat q); #endif #ifdef DEBUG static intnat caml_bcodcount; #endif /* The interpreter itself */ value caml_interprete(code_t prog, asize_t prog_size) { #ifdef PC_REG register code_t pc PC_REG; register value * sp SP_REG; register value accu ACCU_REG; #else register code_t pc; register value * sp; register value accu; #endif #if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) #ifdef JUMPTBL_BASE_REG register char * jumptbl_base JUMPTBL_BASE_REG; #else register char * jumptbl_base; #endif #endif value env; intnat extra_args; struct longjmp_buffer * initial_external_raise; int initial_sp_offset; /* volatile ensures that initial_local_roots and saved_pc will keep correct value across longjmp */ struct caml__roots_block * volatile initial_local_roots; volatile code_t saved_pc = NULL; struct longjmp_buffer raise_buf; value * modify_dest, modify_newval; #ifndef THREADED_CODE opcode_t curr_instr; #endif #ifdef THREADED_CODE static void * jumptable[] = { # include "jumptbl.h" }; #endif if (prog == NULL) { /* Interpreter is initializing */ #ifdef THREADED_CODE caml_instr_table = (char **) jumptable; caml_instr_base = Jumptbl_base; #endif return Val_unit; } #if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) jumptbl_base = Jumptbl_base; #endif initial_local_roots = caml_local_roots; initial_sp_offset = (char *) caml_stack_high - (char *) caml_extern_sp; initial_external_raise = caml_external_raise; caml_callback_depth++; saved_pc = NULL; if (sigsetjmp(raise_buf.buf, 0)) { caml_local_roots = initial_local_roots; sp = caml_extern_sp; accu = caml_exn_bucket; pc = saved_pc; saved_pc = NULL; if (pc != NULL) pc += 2; /* +2 adjustement for the sole purpose of backtraces */ goto raise_exception; } caml_external_raise = &raise_buf; sp = caml_extern_sp; pc = prog; extra_args = 0; env = Atom(0); accu = Val_int(0); #ifdef THREADED_CODE #ifdef DEBUG next_instr: if (caml_icount-- == 0) caml_stop_here (); Assert(sp >= caml_stack_low); Assert(sp <= caml_stack_high); #endif goto *(void *)(jumptbl_base + *pc++); /* Jump to the first instruction */ #else while(1) { #ifdef DEBUG caml_bcodcount++; if (caml_icount-- == 0) caml_stop_here (); if (caml_trace_flag>1) printf("\n##%ld\n", caml_bcodcount); if (caml_trace_flag) caml_disasm_instr(pc); if (caml_trace_flag>1) { printf("env="); caml_trace_value_file(env,prog,prog_size,stdout); putchar('\n'); caml_trace_accu_sp_file(accu,sp,prog,prog_size,stdout); fflush(stdout); }; Assert(sp >= caml_stack_low); Assert(sp <= caml_stack_high); #endif curr_instr = *pc++; dispatch_instr: switch(curr_instr) { #endif /* Basic stack operations */ Instruct(ACC0): accu = sp[0]; Next; Instruct(ACC1): accu = sp[1]; Next; Instruct(ACC2): accu = sp[2]; Next; Instruct(ACC3): accu = sp[3]; Next; Instruct(ACC4): accu = sp[4]; Next; Instruct(ACC5): accu = sp[5]; Next; Instruct(ACC6): accu = sp[6]; Next; Instruct(ACC7): accu = sp[7]; Next; Instruct(PUSH): Instruct(PUSHACC0): *--sp = accu; Next; Instruct(PUSHACC1): *--sp = accu; accu = sp[1]; Next; Instruct(PUSHACC2): *--sp = accu; accu = sp[2]; Next; Instruct(PUSHACC3): *--sp = accu; accu = sp[3]; Next; Instruct(PUSHACC4): *--sp = accu; accu = sp[4]; Next; Instruct(PUSHACC5): *--sp = accu; accu = sp[5]; Next; Instruct(PUSHACC6): *--sp = accu; accu = sp[6]; Next; Instruct(PUSHACC7): *--sp = accu; accu = sp[7]; Next; Instruct(PUSHACC): *--sp = accu; /* Fallthrough */ Instruct(ACC): accu = sp[*pc++]; Next; Instruct(POP): sp += *pc++; Next; Instruct(ASSIGN): sp[*pc++] = accu; accu = Val_unit; Next; /* Access in heap-allocated environment */ Instruct(ENVACC1): accu = Field(env, 1); Next; Instruct(ENVACC2): accu = Field(env, 2); Next; Instruct(ENVACC3): accu = Field(env, 3); Next; Instruct(ENVACC4): accu = Field(env, 4); Next; Instruct(PUSHENVACC1): *--sp = accu; accu = Field(env, 1); Next; Instruct(PUSHENVACC2): *--sp = accu; accu = Field(env, 2); Next; Instruct(PUSHENVACC3): *--sp = accu; accu = Field(env, 3); Next; Instruct(PUSHENVACC4): *--sp = accu; accu = Field(env, 4); Next; Instruct(PUSHENVACC): *--sp = accu; /* Fallthrough */ Instruct(ENVACC): accu = Field(env, *pc++); Next; /* Function application */ Instruct(PUSH_RETADDR): { sp -= 3; sp[0] = (value) (pc + *pc); sp[1] = env; sp[2] = Val_long(extra_args); pc++; Next; } Instruct(APPLY): { extra_args = *pc - 1; pc = Code_val(accu); env = accu; goto check_stacks; } Instruct(APPLY1): { value arg1 = sp[0]; sp -= 3; sp[0] = arg1; sp[1] = (value)pc; sp[2] = env; sp[3] = Val_long(extra_args); pc = Code_val(accu); env = accu; extra_args = 0; goto check_stacks; } Instruct(APPLY2): { value arg1 = sp[0]; value arg2 = sp[1]; sp -= 3; sp[0] = arg1; sp[1] = arg2; sp[2] = (value)pc; sp[3] = env; sp[4] = Val_long(extra_args); pc = Code_val(accu); env = accu; extra_args = 1; goto check_stacks; } Instruct(APPLY3): { value arg1 = sp[0]; value arg2 = sp[1]; value arg3 = sp[2]; sp -= 3; sp[0] = arg1; sp[1] = arg2; sp[2] = arg3; sp[3] = (value)pc; sp[4] = env; sp[5] = Val_long(extra_args); pc = Code_val(accu); env = accu; extra_args = 2; goto check_stacks; } Instruct(APPTERM): { int nargs = *pc++; int slotsize = *pc; value * newsp; int i; /* Slide the nargs bottom words of the current frame to the top of the frame, and discard the remainder of the frame */ newsp = sp + slotsize - nargs; for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i]; sp = newsp; pc = Code_val(accu); env = accu; extra_args += nargs - 1; goto check_stacks; } Instruct(APPTERM1): { value arg1 = sp[0]; sp = sp + *pc - 1; sp[0] = arg1; pc = Code_val(accu); env = accu; goto check_stacks; } Instruct(APPTERM2): { value arg1 = sp[0]; value arg2 = sp[1]; sp = sp + *pc - 2; sp[0] = arg1; sp[1] = arg2; pc = Code_val(accu); env = accu; extra_args += 1; goto check_stacks; } Instruct(APPTERM3): { value arg1 = sp[0]; value arg2 = sp[1]; value arg3 = sp[2]; sp = sp + *pc - 3; sp[0] = arg1; sp[1] = arg2; sp[2] = arg3; pc = Code_val(accu); env = accu; extra_args += 2; goto check_stacks; } Instruct(RETURN): { sp += *pc++; if (extra_args > 0) { extra_args--; pc = Code_val(accu); env = accu; } else { pc = (code_t)(sp[0]); env = sp[1]; extra_args = Long_val(sp[2]); sp += 3; } Next; } Instruct(RESTART): { int num_args = Wosize_val(env) - 2; int i; sp -= num_args; for (i = 0; i < num_args; i++) sp[i] = Field(env, i + 2); env = Field(env, 1); extra_args += num_args; Next; } Instruct(GRAB): { int required = *pc++; if (extra_args >= required) { extra_args -= required; } else { mlsize_t num_args, i; num_args = 1 + extra_args; /* arg1 + extra args */ Alloc_small(accu, num_args + 2, Closure_tag); Field(accu, 1) = env; for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */ sp += num_args; pc = (code_t)(sp[0]); env = sp[1]; extra_args = Long_val(sp[2]); sp += 3; } Next; } Instruct(CLOSURE): { int nvars = *pc++; int i; if (nvars > 0) *--sp = accu; Alloc_small(accu, 1 + nvars, Closure_tag); Code_val(accu) = pc + *pc; pc++; for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; sp += nvars; Next; } Instruct(CLOSUREREC): { int nfuncs = *pc++; int nvars = *pc++; int i; value * p; if (nvars > 0) *--sp = accu; Alloc_small(accu, nfuncs * 2 - 1 + nvars, Closure_tag); p = &Field(accu, nfuncs * 2 - 1); for (i = 0; i < nvars; i++) { *p++ = sp[i]; } sp += nvars; p = &Field(accu, 0); *p = (value) (pc + pc[0]); *--sp = accu; p++; for (i = 1; i < nfuncs; i++) { *p = Make_header(i * 2, Infix_tag, Caml_white); /* color irrelevant. */ p++; *p = (value) (pc + pc[i]); *--sp = (value) p; p++; } pc += nfuncs; Next; } Instruct(PUSHOFFSETCLOSURE): *--sp = accu; /* fallthrough */ Instruct(OFFSETCLOSURE): accu = env + *pc++ * sizeof(value); Next; Instruct(PUSHOFFSETCLOSUREM2): *--sp = accu; /* fallthrough */ Instruct(OFFSETCLOSUREM2): accu = env - 2 * sizeof(value); Next; Instruct(PUSHOFFSETCLOSURE0): *--sp = accu; /* fallthrough */ Instruct(OFFSETCLOSURE0): accu = env; Next; Instruct(PUSHOFFSETCLOSURE2): *--sp = accu; /* fallthrough */ Instruct(OFFSETCLOSURE2): accu = env + 2 * sizeof(value); Next; /* Access to global variables */ Instruct(PUSHGETGLOBAL): *--sp = accu; /* Fallthrough */ Instruct(GETGLOBAL): accu = Field(caml_global_data, *pc); pc++; Next; Instruct(PUSHGETGLOBALFIELD): *--sp = accu; /* Fallthrough */ Instruct(GETGLOBALFIELD): { accu = Field(caml_global_data, *pc); pc++; accu = Field(accu, *pc); pc++; Next; } Instruct(SETGLOBAL): caml_modify(&Field(caml_global_data, *pc), accu); accu = Val_unit; pc++; Next; /* Allocation of blocks */ Instruct(PUSHATOM0): *--sp = accu; /* Fallthrough */ Instruct(ATOM0): accu = Atom(0); Next; Instruct(PUSHATOM): *--sp = accu; /* Fallthrough */ Instruct(ATOM): accu = Atom(*pc++); Next; Instruct(MAKEBLOCK): { mlsize_t wosize = *pc++; tag_t tag = *pc++; mlsize_t i; value block; if (wosize <= Max_young_wosize) { Alloc_small(block, wosize, tag); Field(block, 0) = accu; for (i = 1; i < wosize; i++) Field(block, i) = *sp++; } else { block = caml_alloc_shr(wosize, tag); caml_initialize(&Field(block, 0), accu); for (i = 1; i < wosize; i++) caml_initialize(&Field(block, i), *sp++); } accu = block; Next; } Instruct(MAKEBLOCK1): { tag_t tag = *pc++; value block; Alloc_small(block, 1, tag); Field(block, 0) = accu; accu = block; Next; } Instruct(MAKEBLOCK2): { tag_t tag = *pc++; value block; Alloc_small(block, 2, tag); Field(block, 0) = accu; Field(block, 1) = sp[0]; sp += 1; accu = block; Next; } Instruct(MAKEBLOCK3): { tag_t tag = *pc++; value block; Alloc_small(block, 3, tag); Field(block, 0) = accu; Field(block, 1) = sp[0]; Field(block, 2) = sp[1]; sp += 2; accu = block; Next; } Instruct(MAKEFLOATBLOCK): { mlsize_t size = *pc++; mlsize_t i; value block; if (size <= Max_young_wosize / Double_wosize) { Alloc_small(block, size * Double_wosize, Double_array_tag); } else { block = caml_alloc_shr(size * Double_wosize, Double_array_tag); } Store_double_field(block, 0, Double_val(accu)); for (i = 1; i < size; i++){ Store_double_field(block, i, Double_val(*sp)); ++ sp; } accu = block; Next; } /* Access to components of blocks */ Instruct(GETFIELD0): accu = Field(accu, 0); Next; Instruct(GETFIELD1): accu = Field(accu, 1); Next; Instruct(GETFIELD2): accu = Field(accu, 2); Next; Instruct(GETFIELD3): accu = Field(accu, 3); Next; Instruct(GETFIELD): accu = Field(accu, *pc); pc++; Next; Instruct(GETFLOATFIELD): { double d = Double_field(accu, *pc); Alloc_small(accu, Double_wosize, Double_tag); Store_double_val(accu, d); pc++; Next; } Instruct(SETFIELD0): modify_dest = &Field(accu, 0); modify_newval = *sp++; modify: Modify(modify_dest, modify_newval); accu = Val_unit; Next; Instruct(SETFIELD1): modify_dest = &Field(accu, 1); modify_newval = *sp++; goto modify; Instruct(SETFIELD2): modify_dest = &Field(accu, 2); modify_newval = *sp++; goto modify; Instruct(SETFIELD3): modify_dest = &Field(accu, 3); modify_newval = *sp++; goto modify; Instruct(SETFIELD): modify_dest = &Field(accu, *pc); pc++; modify_newval = *sp++; goto modify; Instruct(SETFLOATFIELD): Store_double_field(accu, *pc, Double_val(*sp)); accu = Val_unit; sp++; pc++; Next; /* Array operations */ Instruct(VECTLENGTH): { mlsize_t size = Wosize_val(accu); if (Tag_val(accu) == Double_array_tag) size = size / Double_wosize; accu = Val_long(size); Next; } Instruct(GETVECTITEM): accu = Field(accu, Long_val(sp[0])); sp += 1; Next; Instruct(SETVECTITEM): modify_dest = &Field(accu, Long_val(sp[0])); modify_newval = sp[1]; sp += 2; goto modify; /* String operations */ Instruct(GETSTRINGCHAR): accu = Val_int(Byte_u(accu, Long_val(sp[0]))); sp += 1; Next; Instruct(SETSTRINGCHAR): Byte_u(accu, Long_val(sp[0])) = Int_val(sp[1]); sp += 2; accu = Val_unit; Next; /* Branches and conditional branches */ Instruct(BRANCH): pc += *pc; Next; Instruct(BRANCHIF): if (accu != Val_false) pc += *pc; else pc++; Next; Instruct(BRANCHIFNOT): if (accu == Val_false) pc += *pc; else pc++; Next; Instruct(SWITCH): { uint32 sizes = *pc++; if (Is_block(accu)) { intnat index = Tag_val(accu); Assert ((uintnat) index < (sizes >> 16)); pc += pc[(sizes & 0xFFFF) + index]; } else { intnat index = Long_val(accu); Assert ((uintnat) index < (sizes & 0xFFFF)) ; pc += pc[index]; } Next; } Instruct(BOOLNOT): accu = Val_not(accu); Next; /* Exceptions */ Instruct(PUSHTRAP): sp -= 4; Trap_pc(sp) = pc + *pc; Trap_link(sp) = caml_trapsp; sp[2] = env; sp[3] = Val_long(extra_args); caml_trapsp = sp; pc++; Next; Instruct(POPTRAP): if (caml_something_to_do) { /* We must check here so that if a signal is pending and its handler triggers an exception, the exception is trapped by the current try...with, not the enclosing one. */ pc--; /* restart the POPTRAP after processing the signal */ goto process_signal; } caml_trapsp = Trap_link(sp); sp += 4; Next; Instruct(RAISE): raise_exception: if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER); if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp); if ((char *) caml_trapsp >= (char *) caml_stack_high - initial_sp_offset) { caml_external_raise = initial_external_raise; caml_extern_sp = (value *) ((char *) caml_stack_high - initial_sp_offset); caml_callback_depth--; return Make_exception_result(accu); } sp = caml_trapsp; pc = Trap_pc(sp); caml_trapsp = Trap_link(sp); env = sp[2]; extra_args = Long_val(sp[3]); sp += 4; Next; /* Stack checks */ check_stacks: if (sp < caml_stack_threshold) { caml_extern_sp = sp; caml_realloc_stack(Stack_threshold / sizeof(value)); sp = caml_extern_sp; } /* Fall through CHECK_SIGNALS */ /* Signal handling */ Instruct(CHECK_SIGNALS): /* accu not preserved */ if (caml_something_to_do) goto process_signal; Next; process_signal: caml_something_to_do = 0; Setup_for_event; caml_process_event(); Restore_after_event; Next; /* Calling C functions */ Instruct(C_CALL1): Setup_for_c_call; accu = Primitive(*pc)(accu); Restore_after_c_call; pc++; Next; Instruct(C_CALL2): Setup_for_c_call; accu = Primitive(*pc)(accu, sp[1]); Restore_after_c_call; sp += 1; pc++; Next; Instruct(C_CALL3): Setup_for_c_call; accu = Primitive(*pc)(accu, sp[1], sp[2]); Restore_after_c_call; sp += 2; pc++; Next; Instruct(C_CALL4): Setup_for_c_call; accu = Primitive(*pc)(accu, sp[1], sp[2], sp[3]); Restore_after_c_call; sp += 3; pc++; Next; Instruct(C_CALL5): Setup_for_c_call; accu = Primitive(*pc)(accu, sp[1], sp[2], sp[3], sp[4]); Restore_after_c_call; sp += 4; pc++; Next; Instruct(C_CALLN): { int nargs = *pc++; *--sp = accu; Setup_for_c_call; accu = Primitive(*pc)(sp + 1, nargs); Restore_after_c_call; sp += nargs; pc++; Next; } /* Integer constants */ Instruct(CONST0): accu = Val_int(0); Next; Instruct(CONST1): accu = Val_int(1); Next; Instruct(CONST2): accu = Val_int(2); Next; Instruct(CONST3): accu = Val_int(3); Next; Instruct(PUSHCONST0): *--sp = accu; accu = Val_int(0); Next; Instruct(PUSHCONST1): *--sp = accu; accu = Val_int(1); Next; Instruct(PUSHCONST2): *--sp = accu; accu = Val_int(2); Next; Instruct(PUSHCONST3): *--sp = accu; accu = Val_int(3); Next; Instruct(PUSHCONSTINT): *--sp = accu; /* Fallthrough */ Instruct(CONSTINT): accu = Val_int(*pc); pc++; Next; /* Integer arithmetic */ Instruct(NEGINT): accu = (value)(2 - (intnat)accu); Next; Instruct(ADDINT): accu = (value)((intnat) accu + (intnat) *sp++ - 1); Next; Instruct(SUBINT): accu = (value)((intnat) accu - (intnat) *sp++ + 1); Next; Instruct(MULINT): accu = Val_long(Long_val(accu) * Long_val(*sp++)); Next; Instruct(DIVINT): { intnat divisor = Long_val(*sp++); if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); } #ifdef NONSTANDARD_DIV_MOD accu = Val_long(caml_safe_div(Long_val(accu), divisor)); #else accu = Val_long(Long_val(accu) / divisor); #endif Next; } Instruct(MODINT): { intnat divisor = Long_val(*sp++); if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); } #ifdef NONSTANDARD_DIV_MOD accu = Val_long(caml_safe_mod(Long_val(accu), divisor)); #else accu = Val_long(Long_val(accu) % divisor); #endif Next; } Instruct(ANDINT): accu = (value)((intnat) accu & (intnat) *sp++); Next; Instruct(ORINT): accu = (value)((intnat) accu | (intnat) *sp++); Next; Instruct(XORINT): accu = (value)(((intnat) accu ^ (intnat) *sp++) | 1); Next; Instruct(LSLINT): accu = (value)((((intnat) accu - 1) << Long_val(*sp++)) + 1); Next; Instruct(LSRINT): accu = (value)((((uintnat) accu - 1) >> Long_val(*sp++)) | 1); Next; Instruct(ASRINT): accu = (value)((((intnat) accu - 1) >> Long_val(*sp++)) | 1); Next; #define Integer_comparison(typ,opname,tst) \ Instruct(opname): \ accu = Val_int((typ) accu tst (typ) *sp++); Next; Integer_comparison(intnat,EQ, ==) Integer_comparison(intnat,NEQ, !=) Integer_comparison(intnat,LTINT, <) Integer_comparison(intnat,LEINT, <=) Integer_comparison(intnat,GTINT, >) Integer_comparison(intnat,GEINT, >=) Integer_comparison(uintnat,ULTINT, <) Integer_comparison(uintnat,UGEINT, >=) #define Integer_branch_comparison(typ,opname,tst,debug) \ Instruct(opname): \ if ( *pc++ tst (typ) Long_val(accu)) { \ pc += *pc ; \ } else { \ pc++ ; \ } ; Next; Integer_branch_comparison(intnat,BEQ, ==, "==") Integer_branch_comparison(intnat,BNEQ, !=, "!=") Integer_branch_comparison(intnat,BLTINT, <, "<") Integer_branch_comparison(intnat,BLEINT, <=, "<=") Integer_branch_comparison(intnat,BGTINT, >, ">") Integer_branch_comparison(intnat,BGEINT, >=, ">=") Integer_branch_comparison(uintnat,BULTINT, <, "<") Integer_branch_comparison(uintnat,BUGEINT, >=, ">=") Instruct(OFFSETINT): accu += *pc << 1; pc++; Next; Instruct(OFFSETREF): Field(accu, 0) += *pc << 1; accu = Val_unit; pc++; Next; Instruct(ISINT): accu = Val_long(accu & 1); Next; /* Object-oriented operations */ #define Lookup(obj, lab) Field (Field (obj, 0), Int_val(lab)) /* please don't forget to keep below code in sync with the functions caml_cache_public_method and caml_cache_public_method2 in obj.c */ Instruct(GETMETHOD): accu = Lookup(sp[0], accu); Next; #define CAML_METHOD_CACHE #ifdef CAML_METHOD_CACHE Instruct(GETPUBMET): { /* accu == object, pc[0] == tag, pc[1] == cache */ value meths = Field (accu, 0); value ofs; #ifdef CAML_TEST_CACHE static int calls = 0, hits = 0; if (calls >= 10000000) { fprintf(stderr, "cache hit = %d%%\n", hits / 100000); calls = 0; hits = 0; } calls++; #endif *--sp = accu; accu = Val_int(*pc++); ofs = *pc & Field(meths,1); if (*(value*)(((char*)&Field(meths,3)) + ofs) == accu) { #ifdef CAML_TEST_CACHE hits++; #endif accu = *(value*)(((char*)&Field(meths,2)) + ofs); } else { int li = 3, hi = Field(meths,0), mi; while (li < hi) { mi = ((li+hi) >> 1) | 1; if (accu < Field(meths,mi)) hi = mi-2; else li = mi; } *pc = (li-3)*sizeof(value); accu = Field (meths, li-1); } pc++; Next; } #else Instruct(GETPUBMET): *--sp = accu; accu = Val_int(*pc); pc += 2; /* Fallthrough */ #endif Instruct(GETDYNMET): { /* accu == tag, sp[0] == object, *pc == cache */ value meths = Field (sp[0], 0); int li = 3, hi = Field(meths,0), mi; while (li < hi) { mi = ((li+hi) >> 1) | 1; if (accu < Field(meths,mi)) hi = mi-2; else li = mi; } accu = Field (meths, li-1); Next; } /* Debugging and machine control */ Instruct(STOP): caml_external_raise = initial_external_raise; caml_extern_sp = sp; caml_callback_depth--; return accu; Instruct(EVENT): if (--caml_event_count == 0) { Setup_for_debugger; caml_debugger(EVENT_COUNT); Restore_after_debugger; } Restart_curr_instr; Instruct(BREAK): Setup_for_debugger; caml_debugger(BREAKPOINT); Restore_after_debugger; Restart_curr_instr; #ifndef THREADED_CODE default: #if _MSC_VER >= 1200 __assume(0); #else caml_fatal_error_arg("Fatal error: bad opcode (%" ARCH_INTNAT_PRINTF_FORMAT "x)\n", (char *)(*(pc-1))); #endif } } #endif } void caml_prepare_bytecode(code_t prog, asize_t prog_size) { /* other implementations of the interpreter (such as an hypothetical JIT translator) might want to do something with a bytecode before running it */ Assert(prog); Assert(prog_size>0); /* actually, the threading of the bytecode might be done here */ } void caml_release_bytecode(code_t prog, asize_t prog_size) { /* other implementations of the interpreter (such as an hypothetical JIT translator) might want to know when a bytecode is removed */ /* check that we have a program */ Assert(prog); Assert(prog_size>0); } mingw-ocaml/ocaml/byterun/int64_emul.h0000644000175000017500000001401112124403240017301 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Software emulation of 64-bit integer arithmetic, for C compilers that do not support it. */ #ifndef CAML_INT64_EMUL_H #define CAML_INT64_EMUL_H #include #ifdef ARCH_BIG_ENDIAN #define I64_literal(hi,lo) { hi, lo } #else #define I64_literal(hi,lo) { lo, hi } #endif #define I64_split(x,hi,lo) (hi = (x).h, lo = (x).l) /* Unsigned comparison */ static int I64_ucompare(uint64 x, uint64 y) { if (x.h > y.h) return 1; if (x.h < y.h) return -1; if (x.l > y.l) return 1; if (x.l < y.l) return -1; return 0; } #define I64_ult(x, y) (I64_ucompare(x, y) < 0) /* Signed comparison */ static int I64_compare(int64 x, int64 y) { if ((int32)x.h > (int32)y.h) return 1; if ((int32)x.h < (int32)y.h) return -1; if (x.l > y.l) return 1; if (x.l < y.l) return -1; return 0; } /* Negation */ static int64 I64_neg(int64 x) { int64 res; res.l = -x.l; res.h = ~x.h; if (res.l == 0) res.h++; return res; } /* Addition */ static int64 I64_add(int64 x, int64 y) { int64 res; res.l = x.l + y.l; res.h = x.h + y.h; if (res.l < x.l) res.h++; return res; } /* Subtraction */ static int64 I64_sub(int64 x, int64 y) { int64 res; res.l = x.l - y.l; res.h = x.h - y.h; if (x.l < y.l) res.h--; return res; } /* Multiplication */ static int64 I64_mul(int64 x, int64 y) { int64 res; uint32 prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); uint32 prod10 = (x.l >> 16) * (y.l & 0xFFFF); uint32 prod01 = (x.l & 0xFFFF) * (y.l >> 16); uint32 prod11 = (x.l >> 16) * (y.l >> 16); res.l = prod00; res.h = prod11 + (prod01 >> 16) + (prod10 >> 16); prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++; prod10 = prod10 << 16; res.l += prod10; if (res.l < prod10) res.h++; res.h += x.l * y.h + x.h * y.l; return res; } #define I64_is_zero(x) (((x).l | (x).h) == 0) #define I64_is_negative(x) ((int32) (x).h < 0) #define I64_is_min_int(x) ((x).l == 0 && (x).h == 0x80000000U) #define I64_is_minus_one(x) (((x).l & (x).h) == 0xFFFFFFFFU) /* Bitwise operations */ static int64 I64_and(int64 x, int64 y) { int64 res; res.l = x.l & y.l; res.h = x.h & y.h; return res; } static int64 I64_or(int64 x, int64 y) { int64 res; res.l = x.l | y.l; res.h = x.h | y.h; return res; } static int64 I64_xor(int64 x, int64 y) { int64 res; res.l = x.l ^ y.l; res.h = x.h ^ y.h; return res; } /* Shifts */ static int64 I64_lsl(int64 x, int s) { int64 res; s = s & 63; if (s == 0) return x; if (s < 32) { res.l = x.l << s; res.h = (x.h << s) | (x.l >> (32 - s)); } else { res.l = 0; res.h = x.l << (s - 32); } return res; } static int64 I64_lsr(int64 x, int s) { int64 res; s = s & 63; if (s == 0) return x; if (s < 32) { res.l = (x.l >> s) | (x.h << (32 - s)); res.h = x.h >> s; } else { res.l = x.h >> (s - 32); res.h = 0; } return res; } static int64 I64_asr(int64 x, int s) { int64 res; s = s & 63; if (s == 0) return x; if (s < 32) { res.l = (x.l >> s) | (x.h << (32 - s)); res.h = (int32) x.h >> s; } else { res.l = (int32) x.h >> (s - 32); res.h = (int32) x.h >> 31; } return res; } /* Division and modulus */ #define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1 #define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1 static void I64_udivmod(uint64 modulus, uint64 divisor, uint64 * quo, uint64 * mod) { int64 quotient, mask; int cmp; quotient.h = 0; quotient.l = 0; mask.h = 0; mask.l = 1; while ((int32) divisor.h >= 0) { cmp = I64_ucompare(divisor, modulus); I64_SHL1(divisor); I64_SHL1(mask); if (cmp >= 0) break; } while (mask.l | mask.h) { if (I64_ucompare(modulus, divisor) >= 0) { quotient.h |= mask.h; quotient.l |= mask.l; modulus = I64_sub(modulus, divisor); } I64_SHR1(mask); I64_SHR1(divisor); } *quo = quotient; *mod = modulus; } static int64 I64_div(int64 x, int64 y) { int64 q, r; int32 sign; sign = x.h ^ y.h; if ((int32) x.h < 0) x = I64_neg(x); if ((int32) y.h < 0) y = I64_neg(y); I64_udivmod(x, y, &q, &r); if (sign < 0) q = I64_neg(q); return q; } static int64 I64_mod(int64 x, int64 y) { int64 q, r; int32 sign; sign = x.h; if ((int32) x.h < 0) x = I64_neg(x); if ((int32) y.h < 0) y = I64_neg(y); I64_udivmod(x, y, &q, &r); if (sign < 0) r = I64_neg(r); return r; } /* Coercions */ static int64 I64_of_int32(int32 x) { int64 res; res.l = x; res.h = x >> 31; return res; } #define I64_to_int32(x) ((int32) (x).l) /* Note: we assume sizeof(intnat) = 4 here, which is true otherwise autoconfiguration would have selected native 64-bit integers */ #define I64_of_intnat I64_of_int32 #define I64_to_intnat I64_to_int32 static double I64_to_double(int64 x) { double res; int32 sign = x.h; if (sign < 0) x = I64_neg(x); res = ldexp((double) x.h, 32) + x.l; if (sign < 0) res = -res; return res; } static int64 I64_of_double(double f) { int64 res; double frac, integ; int neg; neg = (f < 0); f = fabs(f); frac = modf(ldexp(f, -32), &integ); res.h = (uint32) integ; res.l = (uint32) ldexp(frac, 32); if (neg) res = I64_neg(res); return res; } #endif /* CAML_INT64_EMUL_H */ mingw-ocaml/ocaml/byterun/parsing.c0000644000175000017500000002157612124403240016767 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* The PDA automaton for parsers generated by camlyacc */ #include #include #include "config.h" #include "mlvalues.h" #include "memory.h" #include "alloc.h" #define ERRCODE 256 struct parser_tables { /* Mirrors parse_tables in ../stdlib/parsing.mli */ value actions; value transl_const; value transl_block; char * lhs; char * len; char * defred; char * dgoto; char * sindex; char * rindex; char * gindex; value tablesize; char * table; char * check; value error_function; char * names_const; char * names_block; }; struct parser_env { /* Mirrors parser_env in ../stdlib/parsing.ml */ value s_stack; value v_stack; value symb_start_stack; value symb_end_stack; value stacksize; value stackbase; value curr_char; value lval; value symb_start; value symb_end; value asp; value rule_len; value rule_number; value sp; value state; value errflag; }; #if defined(ARCH_BIG_ENDIAN) || SIZEOF_SHORT != 2 #define Short(tbl,n) \ (*((unsigned char *)((tbl) + (n) * 2)) + \ (*((schar *)((tbl) + (n) * 2 + 1)) << 8)) #else #define Short(tbl,n) (((short *)(tbl))[n]) #endif int caml_parser_trace = 0; /* Input codes */ /* Mirrors parser_input in ../stdlib/parsing.ml */ #define START 0 #define TOKEN_READ 1 #define STACKS_GROWN_1 2 #define STACKS_GROWN_2 3 #define SEMANTIC_ACTION_COMPUTED 4 #define ERROR_DETECTED 5 /* Output codes */ /* Mirrors parser_output in ../stdlib/parsing.ml */ #define READ_TOKEN Val_int(0) #define RAISE_PARSE_ERROR Val_int(1) #define GROW_STACKS_1 Val_int(2) #define GROW_STACKS_2 Val_int(3) #define COMPUTE_SEMANTIC_ACTION Val_int(4) #define CALL_ERROR_FUNCTION Val_int(5) /* To preserve local variables when communicating with the ML code */ #define SAVE \ env->sp = Val_int(sp), \ env->state = Val_int(state), \ env->errflag = Val_int(errflag) #define RESTORE \ sp = Int_val(env->sp), \ state = Int_val(env->state), \ errflag = Int_val(env->errflag) /* Auxiliary for printing token just read */ static char * token_name(char * names, int number) { for (/*nothing*/; number > 0; number--) { if (names[0] == 0) return ""; names += strlen(names) + 1; } return names; } static void print_token(struct parser_tables *tables, int state, value tok) { value v; if (Is_long(tok)) { fprintf(stderr, "State %d: read token %s\n", state, token_name(tables->names_const, Int_val(tok))); } else { fprintf(stderr, "State %d: read token %s(", state, token_name(tables->names_block, Tag_val(tok))); v = Field(tok, 0); if (Is_long(v)) fprintf(stderr, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v)); else if (Tag_val(v) == String_tag) fprintf(stderr, "%s", String_val(v)); else if (Tag_val(v) == Double_tag) fprintf(stderr, "%g", Double_val(v)); else fprintf(stderr, "_"); fprintf(stderr, ")\n"); } } /* The pushdown automata */ CAMLprim value caml_parse_engine(struct parser_tables *tables, struct parser_env *env, value cmd, value arg) { int state; mlsize_t sp, asp; int errflag; int n, n1, n2, m, state1; switch(Int_val(cmd)) { case START: state = 0; sp = Int_val(env->sp); errflag = 0; loop: n = Short(tables->defred, state); if (n != 0) goto reduce; if (Int_val(env->curr_char) >= 0) goto testshift; SAVE; return READ_TOKEN; /* The ML code calls the lexer and updates */ /* symb_start and symb_end */ case TOKEN_READ: RESTORE; if (Is_block(arg)) { env->curr_char = Field(tables->transl_block, Tag_val(arg)); caml_modify(&env->lval, Field(arg, 0)); } else { env->curr_char = Field(tables->transl_const, Int_val(arg)); caml_modify(&env->lval, Val_long(0)); } if (caml_parser_trace) print_token(tables, state, arg); testshift: n1 = Short(tables->sindex, state); n2 = n1 + Int_val(env->curr_char); if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) && Short(tables->check, n2) == Int_val(env->curr_char)) goto shift; n1 = Short(tables->rindex, state); n2 = n1 + Int_val(env->curr_char); if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) && Short(tables->check, n2) == Int_val(env->curr_char)) { n = Short(tables->table, n2); goto reduce; } if (errflag > 0) goto recover; SAVE; return CALL_ERROR_FUNCTION; /* The ML code calls the error function */ case ERROR_DETECTED: RESTORE; recover: if (errflag < 3) { errflag = 3; while (1) { state1 = Int_val(Field(env->s_stack, sp)); n1 = Short(tables->sindex, state1); n2 = n1 + ERRCODE; if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) && Short(tables->check, n2) == ERRCODE) { if (caml_parser_trace) fprintf(stderr, "Recovering in state %d\n", state1); goto shift_recover; } else { if (caml_parser_trace){ fprintf(stderr, "Discarding state %d\n", state1); } if (sp <= Int_val(env->stackbase)) { if (caml_parser_trace){ fprintf(stderr, "No more states to discard\n"); } return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */ } sp--; } } } else { if (Int_val(env->curr_char) == 0) return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */ if (caml_parser_trace) fprintf(stderr, "Discarding last token read\n"); env->curr_char = Val_int(-1); goto loop; } shift: env->curr_char = Val_int(-1); if (errflag > 0) errflag--; shift_recover: if (caml_parser_trace) fprintf(stderr, "State %d: shift to state %d\n", state, Short(tables->table, n2)); state = Short(tables->table, n2); sp++; if (sp < Long_val(env->stacksize)) goto push; SAVE; return GROW_STACKS_1; /* The ML code resizes the stacks */ case STACKS_GROWN_1: RESTORE; push: Field(env->s_stack, sp) = Val_int(state); caml_modify(&Field(env->v_stack, sp), env->lval); Store_field (env->symb_start_stack, sp, env->symb_start); Store_field (env->symb_end_stack, sp, env->symb_end); goto loop; reduce: if (caml_parser_trace) fprintf(stderr, "State %d: reduce by rule %d\n", state, n); m = Short(tables->len, n); env->asp = Val_int(sp); env->rule_number = Val_int(n); env->rule_len = Val_int(m); sp = sp - m + 1; m = Short(tables->lhs, n); state1 = Int_val(Field(env->s_stack, sp - 1)); n1 = Short(tables->gindex, m); n2 = n1 + state1; if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) && Short(tables->check, n2) == state1) { state = Short(tables->table, n2); } else { state = Short(tables->dgoto, m); } if (sp < Long_val(env->stacksize)) goto semantic_action; SAVE; return GROW_STACKS_2; /* The ML code resizes the stacks */ case STACKS_GROWN_2: RESTORE; semantic_action: SAVE; return COMPUTE_SEMANTIC_ACTION; /* The ML code calls the semantic action */ case SEMANTIC_ACTION_COMPUTED: RESTORE; Field(env->s_stack, sp) = Val_int(state); caml_modify(&Field(env->v_stack, sp), arg); asp = Int_val(env->asp); Store_field (env->symb_end_stack, sp, Field(env->symb_end_stack, asp)); if (sp > asp) { /* This is an epsilon production. Take symb_start equal to symb_end. */ Store_field (env->symb_start_stack, sp, Field(env->symb_end_stack, asp)); } goto loop; default: /* Should not happen */ Assert(0); return RAISE_PARSE_ERROR; /* Keeps gcc -Wall happy */ } } /* Control printing of debugging info */ CAMLprim value caml_set_parser_trace(value flag) { value oldflag = Val_bool(caml_parser_trace); caml_parser_trace = Bool_val(flag); return oldflag; } mingw-ocaml/ocaml/byterun/int64_native.h0000644000175000017500000000435312124403240017635 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Wrapper macros around native 64-bit integer arithmetic, so that it has the same interface as the software emulation provided in int64_emul.h */ #ifndef CAML_INT64_NATIVE_H #define CAML_INT64_NATIVE_H #define I64_literal(hi,lo) ((int64)(hi) << 32 | (lo)) #define I64_split(x,hi,lo) (hi = (uint32)((x)>>32), lo = (uint32)(x)) #define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) #define I64_ult(x,y) ((uint64)(x) < (uint64)(y)) #define I64_neg(x) (-(x)) #define I64_add(x,y) ((x) + (y)) #define I64_sub(x,y) ((x) - (y)) #define I64_mul(x,y) ((x) * (y)) #define I64_is_zero(x) ((x) == 0) #define I64_is_negative(x) ((x) < 0) #define I64_is_min_int(x) ((x) == ((int64)1 << 63)) #define I64_is_minus_one(x) ((x) == -1) #define I64_div(x,y) ((x) / (y)) #define I64_mod(x,y) ((x) % (y)) #define I64_udivmod(x,y,quo,rem) \ (*(rem) = (uint64)(x) % (uint64)(y), \ *(quo) = (uint64)(x) / (uint64)(y)) #define I64_and(x,y) ((x) & (y)) #define I64_or(x,y) ((x) | (y)) #define I64_xor(x,y) ((x) ^ (y)) #define I64_lsl(x,y) ((x) << (y)) #define I64_asr(x,y) ((x) >> (y)) #define I64_lsr(x,y) ((uint64)(x) >> (y)) #define I64_to_intnat(x) ((intnat) (x)) #define I64_of_intnat(x) ((intnat) (x)) #define I64_to_int32(x) ((int32) (x)) #define I64_of_int32(x) ((int64) (x)) #define I64_to_double(x) ((double)(x)) #define I64_of_double(x) ((int64)(x)) #endif /* CAML_INT64_NATIVE_H */ mingw-ocaml/ocaml/byterun/signals.c0000644000175000017500000001752512124403240016763 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Signal handling, code common to the bytecode and native systems */ #include #include "alloc.h" #include "callback.h" #include "config.h" #include "fail.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" #include "roots.h" #include "signals.h" #include "signals_machdep.h" #include "sys.h" #ifndef NSIG #define NSIG 64 #endif /* The set of pending signals (received but not yet processed) */ CAMLexport intnat volatile caml_signals_are_pending = 0; CAMLexport intnat volatile caml_pending_signals[NSIG]; /* Execute all pending signals */ void caml_process_pending_signals(void) { int i; if (caml_signals_are_pending) { caml_signals_are_pending = 0; for (i = 0; i < NSIG; i++) { if (caml_pending_signals[i]) { caml_pending_signals[i] = 0; caml_execute_signal(i, 0); } } } } /* Record the delivery of a signal, and arrange for it to be processed as soon as possible: - in bytecode: via caml_something_to_do, processed in caml_process_event - in native-code: by playing with the allocation limit, processed in caml_garbage_collection */ void caml_record_signal(int signal_number) { caml_pending_signals[signal_number] = 1; caml_signals_are_pending = 1; #ifndef NATIVE_CODE caml_something_to_do = 1; #else caml_young_limit = caml_young_end; #endif } /* Management of blocking sections. */ static intnat volatile caml_async_signal_mode = 0; static void caml_enter_blocking_section_default(void) { Assert (caml_async_signal_mode == 0); caml_async_signal_mode = 1; } static void caml_leave_blocking_section_default(void) { Assert (caml_async_signal_mode == 1); caml_async_signal_mode = 0; } static int caml_try_leave_blocking_section_default(void) { intnat res; Read_and_clear(res, caml_async_signal_mode); return res; } CAMLexport void (*caml_enter_blocking_section_hook)(void) = caml_enter_blocking_section_default; CAMLexport void (*caml_leave_blocking_section_hook)(void) = caml_leave_blocking_section_default; CAMLexport int (*caml_try_leave_blocking_section_hook)(void) = caml_try_leave_blocking_section_default; CAMLexport void caml_enter_blocking_section(void) { while (1){ /* Process all pending signals now */ caml_process_pending_signals(); caml_enter_blocking_section_hook (); /* Check again for pending signals. If none, done; otherwise, try again */ if (! caml_signals_are_pending) break; caml_leave_blocking_section_hook (); } } CAMLexport void caml_leave_blocking_section(void) { caml_leave_blocking_section_hook (); caml_process_pending_signals(); } /* Execute a signal handler immediately */ static value caml_signal_handlers = 0; void caml_execute_signal(int signal_number, int in_signal_handler) { value res; #ifdef POSIX_SIGNALS sigset_t sigs; /* Block the signal before executing the handler, and record in sigs the original signal mask */ sigemptyset(&sigs); sigaddset(&sigs, signal_number); sigprocmask(SIG_BLOCK, &sigs, &sigs); #endif res = caml_callback_exn( Field(caml_signal_handlers, signal_number), Val_int(caml_rev_convert_signal_number(signal_number))); #ifdef POSIX_SIGNALS if (! in_signal_handler) { /* Restore the original signal mask */ sigprocmask(SIG_SETMASK, &sigs, NULL); } else if (Is_exception_result(res)) { /* Restore the original signal mask and unblock the signal itself */ sigdelset(&sigs, signal_number); sigprocmask(SIG_SETMASK, &sigs, NULL); } #endif if (Is_exception_result(res)) caml_raise(Extract_exception(res)); } /* Arrange for a garbage collection to be performed as soon as possible */ int volatile caml_force_major_slice = 0; void caml_urge_major_slice (void) { caml_force_major_slice = 1; #ifndef NATIVE_CODE caml_something_to_do = 1; #else caml_young_limit = caml_young_end; /* This is only moderately effective on ports that cache [caml_young_limit] in a register, since [caml_modify] is called directly, not through [caml_c_call], so it may take a while before the register is reloaded from [caml_young_limit]. */ #endif } /* OS-independent numbering of signals */ #ifndef SIGABRT #define SIGABRT -1 #endif #ifndef SIGALRM #define SIGALRM -1 #endif #ifndef SIGFPE #define SIGFPE -1 #endif #ifndef SIGHUP #define SIGHUP -1 #endif #ifndef SIGILL #define SIGILL -1 #endif #ifndef SIGINT #define SIGINT -1 #endif #ifndef SIGKILL #define SIGKILL -1 #endif #ifndef SIGPIPE #define SIGPIPE -1 #endif #ifndef SIGQUIT #define SIGQUIT -1 #endif #ifndef SIGSEGV #define SIGSEGV -1 #endif #ifndef SIGTERM #define SIGTERM -1 #endif #ifndef SIGUSR1 #define SIGUSR1 -1 #endif #ifndef SIGUSR2 #define SIGUSR2 -1 #endif #ifndef SIGCHLD #define SIGCHLD -1 #endif #ifndef SIGCONT #define SIGCONT -1 #endif #ifndef SIGSTOP #define SIGSTOP -1 #endif #ifndef SIGTSTP #define SIGTSTP -1 #endif #ifndef SIGTTIN #define SIGTTIN -1 #endif #ifndef SIGTTOU #define SIGTTOU -1 #endif #ifndef SIGVTALRM #define SIGVTALRM -1 #endif #ifndef SIGPROF #define SIGPROF -1 #endif static int posix_signals[] = { SIGABRT, SIGALRM, SIGFPE, SIGHUP, SIGILL, SIGINT, SIGKILL, SIGPIPE, SIGQUIT, SIGSEGV, SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT, SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, SIGVTALRM, SIGPROF }; CAMLexport int caml_convert_signal_number(int signo) { if (signo < 0 && signo >= -(sizeof(posix_signals) / sizeof(int))) return posix_signals[-signo-1]; else return signo; } CAMLexport int caml_rev_convert_signal_number(int signo) { int i; for (i = 0; i < sizeof(posix_signals) / sizeof(int); i++) if (signo == posix_signals[i]) return -i - 1; return signo; } /* Installation of a signal handler (as per [Sys.signal]) */ CAMLprim value caml_install_signal_handler(value signal_number, value action) { CAMLparam2 (signal_number, action); CAMLlocal1 (res); int sig, act, oldact; sig = caml_convert_signal_number(Int_val(signal_number)); if (sig < 0 || sig >= NSIG) caml_invalid_argument("Sys.signal: unavailable signal"); switch(action) { case Val_int(0): /* Signal_default */ act = 0; break; case Val_int(1): /* Signal_ignore */ act = 1; break; default: /* Signal_handle */ act = 2; break; } oldact = caml_set_signal_action(sig, act); switch (oldact) { case 0: /* was Signal_default */ res = Val_int(0); break; case 1: /* was Signal_ignore */ res = Val_int(1); break; case 2: /* was Signal_handle */ res = caml_alloc_small (1, 0); Field(res, 0) = Field(caml_signal_handlers, sig); break; default: /* error in caml_set_signal_action */ caml_sys_error(NO_ARG); } if (Is_block(action)) { if (caml_signal_handlers == 0) { caml_signal_handlers = caml_alloc(NSIG, 0); caml_register_global_root(&caml_signal_handlers); } caml_modify(&Field(caml_signal_handlers, sig), Field(action, 0)); } caml_process_pending_signals(); CAMLreturn (res); } mingw-ocaml/ocaml/byterun/.depend0000644000175000017500000006021612124403240016412 0ustar tootstootsalloc.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h stacks.h array.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h backtrace.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ startup.h stacks.h sys.h backtrace.h callback.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h compact.o: compact.c config.h ../config/m.h ../config/s.h compatibility.h \ finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h \ freelist.h minor_gc.h gc_ctrl.h weak.h compare.o: compare.c custom.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h custom.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h debugger.o: debugger.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h sys.h dynlink.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h osdeps.h prims.h extern.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ memory.h major_gc.h freelist.h minor_gc.h reverse.h fail.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ freelist.h minor_gc.h printexc.h signals.h stacks.h finalise.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h signals.h fix_code.o: fix_code.c config.h ../config/m.h ../config/s.h \ compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ reverse.h floats.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h freelist.o: freelist.c config.h ../config/m.h ../config/s.h \ compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ major_gc.h minor_gc.h gc_ctrl.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ stacks.h globroots.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ roots.h globroots.h hash.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h hash.h int64_native.h instrtrace.o: instrtrace.c intern.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h interp.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h ints.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h int64_native.h io.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h signals.h sys.h lexing.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h main.o: main.c misc.h compatibility.h config.h ../config/m.h \ ../config/s.h mlvalues.h sys.h major_gc.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h md5.o: md5.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h reverse.h memory.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ minor_gc.h signals.h meta.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h minor_gc.o: minor_gc.c config.h ../config/m.h ../config/s.h \ compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h misc.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h obj.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ memory.h minor_gc.h prims.h parsing.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ alloc.h prims.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h prims.h printexc.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ printexc.h roots.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ freelist.h minor_gc.h globroots.h stacks.h signals.o: signals.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ sys.h signals_byt.o: signals_byt.c config.h ../config/m.h ../config/s.h \ compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ minor_gc.h osdeps.h signals.h signals_machdep.h stacks.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h startup.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ version.h str.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h sys.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h terminfo.o: terminfo.c config.h ../config/m.h ../config/s.h \ compatibility.h alloc.h misc.h mlvalues.h fail.h io.h unix.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ osdeps.h weak.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h alloc.d.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h stacks.h array.d.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h backtrace.d.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ startup.h stacks.h sys.h backtrace.h callback.d.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h compact.d.o: compact.c config.h ../config/m.h ../config/s.h compatibility.h \ finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h \ freelist.h minor_gc.h gc_ctrl.h weak.h compare.d.o: compare.c custom.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h custom.d.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h debugger.d.o: debugger.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h sys.h dynlink.d.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h osdeps.h prims.h extern.d.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ memory.h major_gc.h freelist.h minor_gc.h reverse.h fail.d.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ freelist.h minor_gc.h printexc.h signals.h stacks.h finalise.d.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h signals.h fix_code.d.o: fix_code.c config.h ../config/m.h ../config/s.h \ compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ reverse.h floats.d.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h freelist.d.o: freelist.c config.h ../config/m.h ../config/s.h \ compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ major_gc.h minor_gc.h gc_ctrl.d.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ stacks.h globroots.d.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ roots.h globroots.h hash.d.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h hash.h int64_native.h instrtrace.d.o: instrtrace.c instruct.h misc.h compatibility.h config.h \ ../config/m.h ../config/s.h mlvalues.h opnames.h prims.h stacks.h \ memory.h gc.h major_gc.h freelist.h minor_gc.h intern.d.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h interp.d.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ memory.h gc.h minor_gc.h prims.h signals.h stacks.h ints.d.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h int64_native.h io.d.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h signals.h sys.h lexing.d.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h main.d.o: main.c misc.h compatibility.h config.h ../config/m.h \ ../config/s.h mlvalues.h sys.h major_gc.d.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h md5.d.o: md5.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h reverse.h memory.d.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ minor_gc.h signals.h meta.d.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h minor_gc.d.o: minor_gc.c config.h ../config/m.h ../config/s.h \ compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h misc.d.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h obj.d.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ memory.h minor_gc.h prims.h parsing.d.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ alloc.h prims.d.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h prims.h printexc.d.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ printexc.h roots.d.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ freelist.h minor_gc.h globroots.h stacks.h signals.d.o: signals.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ sys.h signals_byt.d.o: signals_byt.c config.h ../config/m.h ../config/s.h \ compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ minor_gc.h osdeps.h signals.h signals_machdep.h stacks.d.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h startup.d.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ version.h str.d.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h sys.d.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h terminfo.d.o: terminfo.c config.h ../config/m.h ../config/s.h \ compatibility.h alloc.h misc.h mlvalues.h fail.h io.h unix.d.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ osdeps.h weak.d.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h alloc.pic.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h stacks.h array.pic.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h backtrace.pic.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ startup.h stacks.h sys.h backtrace.h callback.pic.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h compact.pic.o: compact.c config.h ../config/m.h ../config/s.h compatibility.h \ finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h \ freelist.h minor_gc.h gc_ctrl.h weak.h compare.pic.o: compare.c custom.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h custom.pic.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h debugger.pic.o: debugger.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h sys.h dynlink.pic.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h osdeps.h prims.h extern.pic.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ memory.h major_gc.h freelist.h minor_gc.h reverse.h fail.pic.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ freelist.h minor_gc.h printexc.h signals.h stacks.h finalise.pic.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h signals.h fix_code.pic.o: fix_code.c config.h ../config/m.h ../config/s.h \ compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ reverse.h floats.pic.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h freelist.pic.o: freelist.c config.h ../config/m.h ../config/s.h \ compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ major_gc.h minor_gc.h gc_ctrl.pic.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ stacks.h globroots.pic.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ roots.h globroots.h hash.pic.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h hash.h int64_native.h instrtrace.pic.o: instrtrace.c intern.pic.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h interp.pic.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h ints.pic.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h int64_native.h io.pic.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h signals.h sys.h lexing.pic.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h main.pic.o: main.c misc.h compatibility.h config.h ../config/m.h \ ../config/s.h mlvalues.h sys.h major_gc.pic.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h md5.pic.o: md5.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h reverse.h memory.pic.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ minor_gc.h signals.h meta.pic.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h minor_gc.pic.o: minor_gc.c config.h ../config/m.h ../config/s.h \ compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h misc.pic.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h obj.pic.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ memory.h minor_gc.h prims.h parsing.pic.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ alloc.h prims.pic.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h prims.h printexc.pic.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ printexc.h roots.pic.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ freelist.h minor_gc.h globroots.h stacks.h signals.pic.o: signals.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ sys.h signals_byt.pic.o: signals_byt.c config.h ../config/m.h ../config/s.h \ compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ minor_gc.h osdeps.h signals.h signals_machdep.h stacks.pic.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h startup.pic.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ version.h str.pic.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h sys.pic.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h terminfo.pic.o: terminfo.c config.h ../config/m.h ../config/s.h \ compatibility.h alloc.h misc.h mlvalues.h fail.h io.h unix.pic.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ osdeps.h weak.pic.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h mingw-ocaml/ocaml/byterun/memory.c0000644000175000017500000004062412124403240016627 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "fail.h" #include "freelist.h" #include "gc.h" #include "gc_ctrl.h" #include "major_gc.h" #include "memory.h" #include "major_gc.h" #include "minor_gc.h" #include "misc.h" #include "mlvalues.h" #include "signals.h" extern uintnat caml_percent_free; /* major_gc.c */ /* Page table management */ #define Page(p) ((uintnat) (p) >> Page_log) #define Page_mask ((uintnat) -1 << Page_log) #ifdef ARCH_SIXTYFOUR /* 64-bit implementation: The page table is represented sparsely as a hash table with linear probing */ struct page_table { mlsize_t size; /* size == 1 << (wordsize - shift) */ int shift; mlsize_t mask; /* mask == size - 1 */ mlsize_t occupancy; uintnat * entries; /* [size] */ }; static struct page_table caml_page_table; /* Page table entries are the logical 'or' of - the key: address of a page (low Page_log bits = 0) - the data: a 8-bit integer */ #define Page_entry_matches(entry,addr) \ ((((entry) ^ (addr)) & Page_mask) == 0) /* Multiplicative Fibonacci hashing (Knuth, TAOCP vol 3, section 6.4, page 518). HASH_FACTOR is (sqrt(5) - 1) / 2 * 2^wordsize. */ #ifdef ARCH_SIXTYFOUR #define HASH_FACTOR 11400714819323198486UL #else #define HASH_FACTOR 2654435769UL #endif #define Hash(v) (((v) * HASH_FACTOR) >> caml_page_table.shift) int caml_page_table_lookup(void * addr) { uintnat h, e; h = Hash(Page(addr)); /* The first hit is almost always successful, so optimize for this case */ e = caml_page_table.entries[h]; if (Page_entry_matches(e, (uintnat)addr)) return e & 0xFF; while(1) { if (e == 0) return 0; h = (h + 1) & caml_page_table.mask; e = caml_page_table.entries[h]; if (Page_entry_matches(e, (uintnat)addr)) return e & 0xFF; } } int caml_page_table_initialize(mlsize_t bytesize) { uintnat pagesize = Page(bytesize); caml_page_table.size = 1; caml_page_table.shift = 8 * sizeof(uintnat); /* Aim for initial load factor between 1/4 and 1/2 */ while (caml_page_table.size < 2 * pagesize) { caml_page_table.size <<= 1; caml_page_table.shift -= 1; } caml_page_table.mask = caml_page_table.size - 1; caml_page_table.occupancy = 0; caml_page_table.entries = calloc(caml_page_table.size, sizeof(uintnat)); if (caml_page_table.entries == NULL) return -1; else return 0; } static int caml_page_table_resize(void) { struct page_table old = caml_page_table; uintnat * new_entries; uintnat i, h; caml_gc_message (0x08, "Growing page table to %lu entries\n", caml_page_table.size); new_entries = calloc(2 * old.size, sizeof(uintnat)); if (new_entries == NULL) { caml_gc_message (0x08, "No room for growing page table\n", 0); return -1; } caml_page_table.size = 2 * old.size; caml_page_table.shift = old.shift - 1; caml_page_table.mask = caml_page_table.size - 1; caml_page_table.occupancy = old.occupancy; caml_page_table.entries = new_entries; for (i = 0; i < old.size; i++) { uintnat e = old.entries[i]; if (e == 0) continue; h = Hash(Page(e)); while (caml_page_table.entries[h] != 0) h = (h + 1) & caml_page_table.mask; caml_page_table.entries[h] = e; } free(old.entries); return 0; } static int caml_page_table_modify(uintnat page, int toclear, int toset) { uintnat h; Assert ((page & ~Page_mask) == 0); /* Resize to keep load factor below 1/2 */ if (caml_page_table.occupancy * 2 >= caml_page_table.size) { if (caml_page_table_resize() != 0) return -1; } h = Hash(Page(page)); while (1) { if (caml_page_table.entries[h] == 0) { caml_page_table.entries[h] = page | toset; caml_page_table.occupancy++; break; } if (Page_entry_matches(caml_page_table.entries[h], page)) { caml_page_table.entries[h] = (caml_page_table.entries[h] & ~toclear) | toset; break; } h = (h + 1) & caml_page_table.mask; } return 0; } #else /* 32-bit implementation: The page table is represented as a 2-level array of unsigned char */ CAMLexport unsigned char * caml_page_table[Pagetable1_size]; static unsigned char caml_page_table_empty[Pagetable2_size] = { 0, }; int caml_page_table_initialize(mlsize_t bytesize) { int i; for (i = 0; i < Pagetable1_size; i++) caml_page_table[i] = caml_page_table_empty; return 0; } static int caml_page_table_modify(uintnat page, int toclear, int toset) { uintnat i = Pagetable_index1(page); uintnat j = Pagetable_index2(page); if (caml_page_table[i] == caml_page_table_empty) { unsigned char * new_tbl = calloc(Pagetable2_size, 1); if (new_tbl == 0) return -1; caml_page_table[i] = new_tbl; } caml_page_table[i][j] = (caml_page_table[i][j] & ~toclear) | toset; return 0; } #endif int caml_page_table_add(int kind, void * start, void * end) { uintnat pstart = (uintnat) start & Page_mask; uintnat pend = ((uintnat) end - 1) & Page_mask; uintnat p; for (p = pstart; p <= pend; p += Page_size) if (caml_page_table_modify(p, 0, kind) != 0) return -1; return 0; } int caml_page_table_remove(int kind, void * start, void * end) { uintnat pstart = (uintnat) start & Page_mask; uintnat pend = ((uintnat) end - 1) & Page_mask; uintnat p; for (p = pstart; p <= pend; p += Page_size) if (caml_page_table_modify(p, kind, 0) != 0) return -1; return 0; } /* Allocate a block of the requested size, to be passed to [caml_add_to_heap] later. [request] must be a multiple of [Page_size]. [caml_alloc_for_heap] returns NULL if the request cannot be satisfied. The returned pointer is a hp, but the header must be initialized by the caller. */ char *caml_alloc_for_heap (asize_t request) { char *mem; void *block; Assert (request % Page_size == 0); mem = caml_aligned_malloc (request + sizeof (heap_chunk_head), sizeof (heap_chunk_head), &block); if (mem == NULL) return NULL; mem += sizeof (heap_chunk_head); Chunk_size (mem) = request; Chunk_block (mem) = block; return mem; } /* Use this function to free a block allocated with [caml_alloc_for_heap] if you don't add it with [caml_add_to_heap]. */ void caml_free_for_heap (char *mem) { free (Chunk_block (mem)); } /* Take a chunk of memory as argument, which must be the result of a call to [caml_alloc_for_heap], and insert it into the heap chaining. The contents of the chunk must be a sequence of valid blocks and fragments: no space between blocks and no trailing garbage. If some blocks are blue, they must be added to the free list by the caller. All other blocks must have the color [caml_allocation_color(m)]. The caller must update [caml_allocated_words] if applicable. Return value: 0 if no error; -1 in case of error. See also: caml_compact_heap, which duplicates most of this function. */ int caml_add_to_heap (char *m) { Assert (Chunk_size (m) % Page_size == 0); #ifdef DEBUG /* Should check the contents of the block. */ #endif /* debug */ caml_gc_message (0x04, "Growing heap to %luk bytes\n", (caml_stat_heap_size + Chunk_size (m)) / 1024); /* Register block in page table */ if (caml_page_table_add(In_heap, m, m + Chunk_size(m)) != 0) return -1; /* Chain this heap chunk. */ { char **last = &caml_heap_start; char *cur = *last; while (cur != NULL && cur < m){ last = &(Chunk_next (cur)); cur = *last; } Chunk_next (m) = cur; *last = m; ++ caml_stat_heap_chunks; } caml_stat_heap_size += Chunk_size (m); if (caml_stat_heap_size > caml_stat_top_heap_size){ caml_stat_top_heap_size = caml_stat_heap_size; } return 0; } /* Allocate more memory from malloc for the heap. Return a blue block of at least the requested size. The blue block is chained to a sequence of blue blocks (through their field 0); the last block of the chain is pointed by field 1 of the first. There may be a fragment after the last block. The caller must insert the blocks into the free list. The request must be less than or equal to Max_wosize. Return NULL when out of memory. */ static char *expand_heap (mlsize_t request) { char *mem, *hp, *prev; asize_t over_request, malloc_request, remain; Assert (request <= Max_wosize); over_request = request + request / 100 * caml_percent_free; malloc_request = caml_round_heap_chunk_size (Bhsize_wosize (over_request)); mem = caml_alloc_for_heap (malloc_request); if (mem == NULL){ caml_gc_message (0x04, "No room for growing heap\n", 0); return NULL; } remain = malloc_request; prev = hp = mem; /* FIXME find a way to do this with a call to caml_make_free_blocks */ while (Wosize_bhsize (remain) > Max_wosize){ Hd_hp (hp) = Make_header (Max_wosize, 0, Caml_blue); #ifdef DEBUG caml_set_fields (Bp_hp (hp), 0, Debug_free_major); #endif hp += Bhsize_wosize (Max_wosize); remain -= Bhsize_wosize (Max_wosize); Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp); prev = hp; } if (remain > 1){ Hd_hp (hp) = Make_header (Wosize_bhsize (remain), 0, Caml_blue); #ifdef DEBUG caml_set_fields (Bp_hp (hp), 0, Debug_free_major); #endif Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp); Field (Op_hp (hp), 0) = (value) NULL; }else{ Field (Op_hp (prev), 0) = (value) NULL; if (remain == 1) Hd_hp (hp) = Make_header (0, 0, Caml_white); } Assert (Wosize_hp (mem) >= request); if (caml_add_to_heap (mem) != 0){ caml_free_for_heap (mem); return NULL; } return Bp_hp (mem); } /* Remove the heap chunk [chunk] from the heap and give the memory back to [free]. */ void caml_shrink_heap (char *chunk) { char **cp; /* Never deallocate the first chunk, because caml_heap_start is both the first block and the base address for page numbers, and we don't want to shift the page table, it's too messy (see above). It will never happen anyway, because of the way compaction works. (see compact.c) */ if (chunk == caml_heap_start) return; caml_stat_heap_size -= Chunk_size (chunk); caml_gc_message (0x04, "Shrinking heap to %luk bytes\n", (unsigned long) caml_stat_heap_size / 1024); #ifdef DEBUG { mlsize_t i; for (i = 0; i < Wsize_bsize (Chunk_size (chunk)); i++){ ((value *) chunk) [i] = Debug_free_shrink; } } #endif -- caml_stat_heap_chunks; /* Remove [chunk] from the list of chunks. */ cp = &caml_heap_start; while (*cp != chunk) cp = &(Chunk_next (*cp)); *cp = Chunk_next (chunk); /* Remove the pages of [chunk] from the page table. */ caml_page_table_remove(In_heap, chunk, chunk + Chunk_size (chunk)); /* Free the [malloc] block that contains [chunk]. */ caml_free_for_heap (chunk); } color_t caml_allocation_color (void *hp) { if (caml_gc_phase == Phase_mark || (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){ return Caml_black; }else{ Assert (caml_gc_phase == Phase_idle || (caml_gc_phase == Phase_sweep && (addr)hp < (addr)caml_gc_sweep_hp)); return Caml_white; } } CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag) { char *hp, *new_block; if (wosize > Max_wosize) caml_raise_out_of_memory (); hp = caml_fl_allocate (wosize); if (hp == NULL){ new_block = expand_heap (wosize); if (new_block == NULL) { if (caml_in_minor_collection) caml_fatal_error ("Fatal error: out of memory.\n"); else caml_raise_out_of_memory (); } caml_fl_add_blocks (new_block); hp = caml_fl_allocate (wosize); } Assert (Is_in_heap (Val_hp (hp))); /* Inline expansion of caml_allocation_color. */ if (caml_gc_phase == Phase_mark || (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){ Hd_hp (hp) = Make_header (wosize, tag, Caml_black); }else{ Assert (caml_gc_phase == Phase_idle || (caml_gc_phase == Phase_sweep && (addr)hp < (addr)caml_gc_sweep_hp)); Hd_hp (hp) = Make_header (wosize, tag, Caml_white); } Assert (Hd_hp (hp) == Make_header (wosize, tag, caml_allocation_color (hp))); caml_allocated_words += Whsize_wosize (wosize); if (caml_allocated_words > Wsize_bsize (caml_minor_heap_size)){ caml_urge_major_slice (); } #ifdef DEBUG { uintnat i; for (i = 0; i < wosize; i++){ Field (Val_hp (hp), i) = Debug_uninit_major; } } #endif return Val_hp (hp); } /* Dependent memory is all memory blocks allocated out of the heap that depend on the GC (and finalizers) for deallocation. For the GC to take dependent memory into account when computing its automatic speed setting, you must call [caml_alloc_dependent_memory] when you alloate some dependent memory, and [caml_free_dependent_memory] when you free it. In both cases, you pass as argument the size (in bytes) of the block being allocated or freed. */ CAMLexport void caml_alloc_dependent_memory (mlsize_t nbytes) { caml_dependent_size += nbytes / sizeof (value); caml_dependent_allocated += nbytes / sizeof (value); } CAMLexport void caml_free_dependent_memory (mlsize_t nbytes) { if (caml_dependent_size < nbytes / sizeof (value)){ caml_dependent_size = 0; }else{ caml_dependent_size -= nbytes / sizeof (value); } } /* Use this function to tell the major GC to speed up when you use finalized blocks to automatically deallocate resources (other than memory). The GC will do at least one cycle every [max] allocated resources; [res] is the number of resources allocated this time. Note that only [res/max] is relevant. The units (and kind of resource) can change between calls to [caml_adjust_gc_speed]. */ CAMLexport void caml_adjust_gc_speed (mlsize_t res, mlsize_t max) { if (max == 0) max = 1; if (res > max) res = max; caml_extra_heap_resources += (double) res / (double) max; if (caml_extra_heap_resources > 1.0){ caml_extra_heap_resources = 1.0; caml_urge_major_slice (); } if (caml_extra_heap_resources > (double) Wsize_bsize (caml_minor_heap_size) / 2.0 / (double) Wsize_bsize (caml_stat_heap_size)) { caml_urge_major_slice (); } } /* You must use [caml_initialize] to store the initial value in a field of a shared block, unless you are sure the value is not a young block. A block value [v] is a shared block if and only if [Is_in_heap (v)] is true. */ /* [caml_initialize] never calls the GC, so you may call it while an block is unfinished (i.e. just after a call to [caml_alloc_shr].) */ void caml_initialize (value *fp, value val) { *fp = val; if (Is_block (val) && Is_young (val) && Is_in_heap (fp)){ if (caml_ref_table.ptr >= caml_ref_table.limit){ caml_realloc_ref_table (&caml_ref_table); } *caml_ref_table.ptr++ = fp; } } /* You must use [caml_modify] to change a field of an existing shared block, unless you are sure the value being overwritten is not a shared block and the value being written is not a young block. */ /* [caml_modify] never calls the GC. */ void caml_modify (value *fp, value val) { Modify (fp, val); } CAMLexport void * caml_stat_alloc (asize_t sz) { void * result = malloc (sz); /* malloc() may return NULL if size is 0 */ if (result == NULL && sz != 0) caml_raise_out_of_memory (); #ifdef DEBUG memset (result, Debug_uninit_stat, sz); #endif return result; } CAMLexport void caml_stat_free (void * blk) { free (blk); } CAMLexport void * caml_stat_resize (void * blk, asize_t sz) { void * result = realloc (blk, sz); if (result == NULL) caml_raise_out_of_memory (); return result; } mingw-ocaml/ocaml/byterun/major_gc.c0000644000175000017500000004074212124403240017101 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "compact.h" #include "custom.h" #include "config.h" #include "fail.h" #include "finalise.h" #include "freelist.h" #include "gc.h" #include "gc_ctrl.h" #include "major_gc.h" #include "misc.h" #include "mlvalues.h" #include "roots.h" #include "weak.h" uintnat caml_percent_free; uintnat caml_major_heap_increment; CAMLexport char *caml_heap_start; char *caml_gc_sweep_hp; int caml_gc_phase; /* always Phase_mark, Phase_sweep, or Phase_idle */ static value *gray_vals; static value *gray_vals_cur, *gray_vals_end; static asize_t gray_vals_size; static int heap_is_pure; /* The heap is pure if the only gray objects below [markhp] are also in [gray_vals]. */ uintnat caml_allocated_words; uintnat caml_dependent_size, caml_dependent_allocated; double caml_extra_heap_resources; uintnat caml_fl_size_at_phase_change = 0; extern char *caml_fl_merge; /* Defined in freelist.c. */ static char *markhp, *chunk, *limit; int caml_gc_subphase; /* Subphase_{main,weak1,weak2,final} */ static value *weak_prev; #ifdef DEBUG static unsigned long major_gc_counter = 0; #endif static void realloc_gray_vals (void) { value *new; Assert (gray_vals_cur == gray_vals_end); if (gray_vals_size < caml_stat_heap_size / 128){ caml_gc_message (0x08, "Growing gray_vals to %" ARCH_INTNAT_PRINTF_FORMAT "uk bytes\n", (intnat) gray_vals_size * sizeof (value) / 512); new = (value *) realloc ((char *) gray_vals, 2 * gray_vals_size * sizeof (value)); if (new == NULL){ caml_gc_message (0x08, "No room for growing gray_vals\n", 0); gray_vals_cur = gray_vals; heap_is_pure = 0; }else{ gray_vals = new; gray_vals_cur = gray_vals + gray_vals_size; gray_vals_size *= 2; gray_vals_end = gray_vals + gray_vals_size; } }else{ gray_vals_cur = gray_vals + gray_vals_size / 2; heap_is_pure = 0; } } void caml_darken (value v, value *p /* not used */) { if (Is_block (v) && Is_in_heap (v)) { header_t h = Hd_val (v); tag_t t = Tag_hd (h); if (t == Infix_tag){ v -= Infix_offset_val(v); h = Hd_val (v); t = Tag_hd (h); } CAMLassert (!Is_blue_hd (h)); if (Is_white_hd (h)){ if (t < No_scan_tag){ Hd_val (v) = Grayhd_hd (h); *gray_vals_cur++ = v; if (gray_vals_cur >= gray_vals_end) realloc_gray_vals (); }else{ Hd_val (v) = Blackhd_hd (h); } } } } static void start_cycle (void) { Assert (caml_gc_phase == Phase_idle); Assert (gray_vals_cur == gray_vals); caml_gc_message (0x01, "Starting new major GC cycle\n", 0); caml_darken_all_roots(); caml_gc_phase = Phase_mark; caml_gc_subphase = Subphase_main; markhp = NULL; #ifdef DEBUG ++ major_gc_counter; caml_heap_check (); #endif } static void mark_slice (intnat work) { value *gray_vals_ptr; /* Local copy of gray_vals_cur */ value v, child; header_t hd; mlsize_t size, i; caml_gc_message (0x40, "Marking %ld words\n", work); caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase); gray_vals_ptr = gray_vals_cur; while (work > 0){ if (gray_vals_ptr > gray_vals){ v = *--gray_vals_ptr; hd = Hd_val(v); Assert (Is_gray_hd (hd)); Hd_val (v) = Blackhd_hd (hd); size = Wosize_hd (hd); if (Tag_hd (hd) < No_scan_tag){ for (i = 0; i < size; i++){ child = Field (v, i); if (Is_block (child) && Is_in_heap (child)) { hd = Hd_val (child); if (Tag_hd (hd) == Forward_tag){ value f = Forward_val (child); if (Is_block (f) && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){ /* Do not short-circuit the pointer. */ }else{ Field (v, i) = f; } } else if (Tag_hd(hd) == Infix_tag) { child -= Infix_offset_val(child); hd = Hd_val(child); } if (Is_white_hd (hd)){ Hd_val (child) = Grayhd_hd (hd); *gray_vals_ptr++ = child; if (gray_vals_ptr >= gray_vals_end) { gray_vals_cur = gray_vals_ptr; realloc_gray_vals (); gray_vals_ptr = gray_vals_cur; } } } } } work -= Whsize_wosize(size); }else if (markhp != NULL){ if (markhp == limit){ chunk = Chunk_next (chunk); if (chunk == NULL){ markhp = NULL; }else{ markhp = chunk; limit = chunk + Chunk_size (chunk); } }else{ if (Is_gray_val (Val_hp (markhp))){ Assert (gray_vals_ptr == gray_vals); *gray_vals_ptr++ = Val_hp (markhp); } markhp += Bhsize_hp (markhp); } }else if (!heap_is_pure){ heap_is_pure = 1; chunk = caml_heap_start; markhp = chunk; limit = chunk + Chunk_size (chunk); }else{ switch (caml_gc_subphase){ case Subphase_main: { /* The main marking phase is over. Start removing weak pointers to dead values. */ caml_gc_subphase = Subphase_weak1; weak_prev = &caml_weak_list_head; } break; case Subphase_weak1: { value cur, curfield; mlsize_t sz, i; header_t hd; cur = *weak_prev; if (cur != (value) NULL){ hd = Hd_val (cur); sz = Wosize_hd (hd); for (i = 1; i < sz; i++){ curfield = Field (cur, i); weak_again: if (curfield != caml_weak_none && Is_block (curfield) && Is_in_heap (curfield)){ if (Tag_val (curfield) == Forward_tag){ value f = Forward_val (curfield); if (Is_block (f)) { if (!Is_in_value_area(f) || Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag){ /* Do not short-circuit the pointer. */ }else{ Field (cur, i) = curfield = f; goto weak_again; } } } if (Is_white_val (curfield)){ Field (cur, i) = caml_weak_none; } } } weak_prev = &Field (cur, 0); work -= Whsize_hd (hd); }else{ /* Subphase_weak1 is done. Handle finalised values and start removing dead weak arrays. */ gray_vals_cur = gray_vals_ptr; caml_final_update (); gray_vals_ptr = gray_vals_cur; caml_gc_subphase = Subphase_weak2; weak_prev = &caml_weak_list_head; } } break; case Subphase_weak2: { value cur; header_t hd; cur = *weak_prev; if (cur != (value) NULL){ hd = Hd_val (cur); if (Color_hd (hd) == Caml_white){ /* The whole array is dead, remove it from the list. */ *weak_prev = Field (cur, 0); }else{ weak_prev = &Field (cur, 0); } work -= 1; }else{ /* Subphase_weak2 is done. Go to Subphase_final. */ caml_gc_subphase = Subphase_final; } } break; case Subphase_final: { /* Initialise the sweep phase. */ gray_vals_cur = gray_vals_ptr; caml_gc_sweep_hp = caml_heap_start; caml_fl_init_merge (); caml_gc_phase = Phase_sweep; chunk = caml_heap_start; caml_gc_sweep_hp = chunk; limit = chunk + Chunk_size (chunk); work = 0; caml_fl_size_at_phase_change = caml_fl_cur_size; } break; default: Assert (0); } } } gray_vals_cur = gray_vals_ptr; } static void sweep_slice (intnat work) { char *hp; header_t hd; caml_gc_message (0x40, "Sweeping %ld words\n", work); while (work > 0){ if (caml_gc_sweep_hp < limit){ hp = caml_gc_sweep_hp; hd = Hd_hp (hp); work -= Whsize_hd (hd); caml_gc_sweep_hp += Bhsize_hd (hd); switch (Color_hd (hd)){ case Caml_white: if (Tag_hd (hd) == Custom_tag){ void (*final_fun)(value) = Custom_ops_val(Val_hp(hp))->finalize; if (final_fun != NULL) final_fun(Val_hp(hp)); } caml_gc_sweep_hp = caml_fl_merge_block (Bp_hp (hp)); break; case Caml_blue: /* Only the blocks of the free-list are blue. See [freelist.c]. */ caml_fl_merge = Bp_hp (hp); break; default: /* gray or black */ Assert (Color_hd (hd) == Caml_black); Hd_hp (hp) = Whitehd_hd (hd); break; } Assert (caml_gc_sweep_hp <= limit); }else{ chunk = Chunk_next (chunk); if (chunk == NULL){ /* Sweeping is done. */ ++ caml_stat_major_collections; work = 0; caml_gc_phase = Phase_idle; }else{ caml_gc_sweep_hp = chunk; limit = chunk + Chunk_size (chunk); } } } } /* The main entry point for the GC. Called after each minor GC. [howmuch] is the amount of work to do, 0 to let the GC compute it. Return the computed amount of work to do. */ intnat caml_major_collection_slice (intnat howmuch) { double p, dp; intnat computed_work; /* Free memory at the start of the GC cycle (garbage + free list) (assumed): FM = caml_stat_heap_size * caml_percent_free / (100 + caml_percent_free) Assuming steady state and enforcing a constant allocation rate, then FM is divided in 2/3 for garbage and 1/3 for free list. G = 2 * FM / 3 G is also the amount of memory that will be used during this cycle (still assuming steady state). Proportion of G consumed since the previous slice: PH = caml_allocated_words / G = caml_allocated_words * 3 * (100 + caml_percent_free) / (2 * caml_stat_heap_size * caml_percent_free) Proportion of extra-heap resources consumed since the previous slice: PE = caml_extra_heap_resources Proportion of total work to do in this slice: P = max (PH, PE) Amount of marking work for the GC cycle: MW = caml_stat_heap_size * 100 / (100 + caml_percent_free) Amount of sweeping work for the GC cycle: SW = caml_stat_heap_size In order to finish marking with a non-empty free list, we will use 40% of the time for marking, and 60% for sweeping. If TW is the total work for this cycle, MW = 40/100 * TW SW = 60/100 * TW Amount of work to do for this slice: W = P * TW Amount of marking work for a marking slice: MS = P * MW / (40/100) MS = P * caml_stat_heap_size * 250 / (100 + caml_percent_free) Amount of sweeping work for a sweeping slice: SS = P * SW / (60/100) SS = P * caml_stat_heap_size * 5 / 3 This slice will either mark MS words or sweep SS words. */ if (caml_gc_phase == Phase_idle) start_cycle (); p = (double) caml_allocated_words * 3.0 * (100 + caml_percent_free) / Wsize_bsize (caml_stat_heap_size) / caml_percent_free / 2.0; if (caml_dependent_size > 0){ dp = (double) caml_dependent_allocated * (100 + caml_percent_free) / caml_dependent_size / caml_percent_free; }else{ dp = 0.0; } if (p < dp) p = dp; if (p < caml_extra_heap_resources) p = caml_extra_heap_resources; caml_gc_message (0x40, "allocated_words = %" ARCH_INTNAT_PRINTF_FORMAT "u\n", caml_allocated_words); caml_gc_message (0x40, "extra_heap_resources = %" ARCH_INTNAT_PRINTF_FORMAT "uu\n", (uintnat) (caml_extra_heap_resources * 1000000)); caml_gc_message (0x40, "amount of work to do = %" ARCH_INTNAT_PRINTF_FORMAT "uu\n", (uintnat) (p * 1000000)); if (caml_gc_phase == Phase_mark){ computed_work = (intnat) (p * Wsize_bsize (caml_stat_heap_size) * 250 / (100 + caml_percent_free)); }else{ computed_work = (intnat) (p * Wsize_bsize (caml_stat_heap_size) * 5 / 3); } caml_gc_message (0x40, "ordered work = %ld words\n", howmuch); caml_gc_message (0x40, "computed work = %ld words\n", computed_work); if (howmuch == 0) howmuch = computed_work; if (caml_gc_phase == Phase_mark){ mark_slice (howmuch); caml_gc_message (0x02, "!", 0); }else{ Assert (caml_gc_phase == Phase_sweep); sweep_slice (howmuch); caml_gc_message (0x02, "$", 0); } if (caml_gc_phase == Phase_idle) caml_compact_heap_maybe (); caml_stat_major_words += caml_allocated_words; caml_allocated_words = 0; caml_dependent_allocated = 0; caml_extra_heap_resources = 0.0; return computed_work; } /* The minor heap must be empty when this function is called; the minor heap is empty when this function returns. */ /* This does not call caml_compact_heap_maybe because the estimations of free and live memory are only valid for a cycle done incrementally. Besides, this function is called by caml_compact_heap_maybe. */ void caml_finish_major_cycle (void) { if (caml_gc_phase == Phase_idle) start_cycle (); while (caml_gc_phase == Phase_mark) mark_slice (LONG_MAX); Assert (caml_gc_phase == Phase_sweep); while (caml_gc_phase == Phase_sweep) sweep_slice (LONG_MAX); Assert (caml_gc_phase == Phase_idle); caml_stat_major_words += caml_allocated_words; caml_allocated_words = 0; } /* Make sure the request is at least Heap_chunk_min and round it up to a multiple of the page size. */ static asize_t clip_heap_chunk_size (asize_t request) { if (request < Bsize_wsize (Heap_chunk_min)){ request = Bsize_wsize (Heap_chunk_min); } return ((request + Page_size - 1) >> Page_log) << Page_log; } /* Make sure the request is >= caml_major_heap_increment, then call clip_heap_chunk_size, then make sure the result is >= request. */ asize_t caml_round_heap_chunk_size (asize_t request) { asize_t result = request; if (result < caml_major_heap_increment){ result = caml_major_heap_increment; } result = clip_heap_chunk_size (result); if (result < request){ caml_raise_out_of_memory (); return 0; /* not reached */ } return result; } void caml_init_major_heap (asize_t heap_size) { caml_stat_heap_size = clip_heap_chunk_size (heap_size); caml_stat_top_heap_size = caml_stat_heap_size; Assert (caml_stat_heap_size % Page_size == 0); caml_heap_start = (char *) caml_alloc_for_heap (caml_stat_heap_size); if (caml_heap_start == NULL) caml_fatal_error ("Fatal error: not enough memory for the initial heap.\n"); Chunk_next (caml_heap_start) = NULL; caml_stat_heap_chunks = 1; if (caml_page_table_add(In_heap, caml_heap_start, caml_heap_start + caml_stat_heap_size) != 0) { caml_fatal_error ("Fatal error: not enough memory for the initial page table.\n"); } caml_fl_init_merge (); caml_make_free_blocks ((value *) caml_heap_start, Wsize_bsize (caml_stat_heap_size), 1, Caml_white); caml_gc_phase = Phase_idle; gray_vals_size = 2048; gray_vals = (value *) malloc (gray_vals_size * sizeof (value)); if (gray_vals == NULL) caml_fatal_error ("Fatal error: not enough memory for the gray cache.\n"); gray_vals_cur = gray_vals; gray_vals_end = gray_vals + gray_vals_size; heap_is_pure = 1; caml_allocated_words = 0; caml_extra_heap_resources = 0.0; } mingw-ocaml/ocaml/byterun/freelist.c0000644000175000017500000004064612124403240017140 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Para, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #define FREELIST_DEBUG 0 #if FREELIST_DEBUG #include #endif #include #include "config.h" #include "freelist.h" #include "gc.h" #include "gc_ctrl.h" #include "memory.h" #include "major_gc.h" #include "misc.h" #include "mlvalues.h" /* The free-list is kept sorted by increasing addresses. This makes the merging of adjacent free blocks possible. (See [caml_fl_merge_block].) */ typedef struct { char *next_bp; /* Pointer to the first byte of the next block. */ } block; /* The sentinel can be located anywhere in memory, but it must not be adjacent to any heap object. */ static struct { value filler1; /* Make sure the sentinel is never adjacent to any block. */ header_t h; value first_bp; value filler2; /* Make sure the sentinel is never adjacent to any block. */ } sentinel = {0, Make_header (0, 0, Caml_blue), 0, 0}; #define Fl_head ((char *) (&(sentinel.first_bp))) static char *fl_prev = Fl_head; /* Current allocation pointer. */ static char *fl_last = NULL; /* Last block in the list. Only valid just after [caml_fl_allocate] returns NULL. */ char *caml_fl_merge = Fl_head; /* Current insertion pointer. Managed jointly with [sweep_slice]. */ asize_t caml_fl_cur_size = 0; /* Number of words in the free list, including headers but not fragments. */ #define FLP_MAX 1000 static char *flp [FLP_MAX]; static int flp_size = 0; static char *beyond = NULL; #define Next(b) (((block *) (b))->next_bp) #define Policy_next_fit 0 #define Policy_first_fit 1 uintnat caml_allocation_policy = Policy_next_fit; #define policy caml_allocation_policy #ifdef DEBUG static void fl_check (void) { char *cur, *prev; int prev_found = 0, flp_found = 0, merge_found = 0; uintnat size_found = 0; int sz = 0; prev = Fl_head; cur = Next (prev); while (cur != NULL){ size_found += Whsize_bp (cur); Assert (Is_in_heap (cur)); if (cur == fl_prev) prev_found = 1; if (policy == Policy_first_fit && Wosize_bp (cur) > sz){ sz = Wosize_bp (cur); if (flp_found < flp_size){ Assert (Next (flp[flp_found]) == cur); ++ flp_found; }else{ Assert (beyond == NULL || cur >= Next (beyond)); } } if (cur == caml_fl_merge) merge_found = 1; prev = cur; cur = Next (prev); } if (policy == Policy_next_fit) Assert (prev_found || fl_prev == Fl_head); if (policy == Policy_first_fit) Assert (flp_found == flp_size); Assert (merge_found || caml_fl_merge == Fl_head); Assert (size_found == caml_fl_cur_size); } #endif /* [allocate_block] is called by [caml_fl_allocate]. Given a suitable free block and the desired size, it allocates a new block from the free block. There are three cases: 0. The free block has the desired size. Detach the block from the free-list and return it. 1. The free block is 1 word longer than the desired size. Detach the block from the free list. The remaining word cannot be linked: turn it into an empty block (header only), and return the rest. 2. The free block is big enough. Split it in two and return the right block. In all cases, the allocated block is right-justified in the free block: it is located in the high-address words of the free block. This way, the linking of the free-list does not change in case 2. */ static char *allocate_block (mlsize_t wh_sz, int flpi, char *prev, char *cur) { header_t h = Hd_bp (cur); Assert (Whsize_hd (h) >= wh_sz); if (Wosize_hd (h) < wh_sz + 1){ /* Cases 0 and 1. */ caml_fl_cur_size -= Whsize_hd (h); Next (prev) = Next (cur); Assert (Is_in_heap (Next (prev)) || Next (prev) == NULL); if (caml_fl_merge == cur) caml_fl_merge = prev; #ifdef DEBUG fl_last = NULL; #endif /* In case 1, the following creates the empty block correctly. In case 0, it gives an invalid header to the block. The function calling [caml_fl_allocate] will overwrite it. */ Hd_op (cur) = Make_header (0, 0, Caml_white); if (policy == Policy_first_fit){ if (flpi + 1 < flp_size && flp[flpi + 1] == cur){ flp[flpi + 1] = prev; }else if (flpi == flp_size - 1){ beyond = (prev == Fl_head) ? NULL : prev; -- flp_size; } } }else{ /* Case 2. */ caml_fl_cur_size -= wh_sz; Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue); } if (policy == Policy_next_fit) fl_prev = prev; return cur + Bosize_hd (h) - Bsize_wsize (wh_sz); } /* [caml_fl_allocate] does not set the header of the newly allocated block. The calling function must do it before any GC function gets called. [caml_fl_allocate] returns a head pointer. */ char *caml_fl_allocate (mlsize_t wo_sz) { char *cur = NULL, *prev, *result; int i; mlsize_t sz, prevsz; Assert (sizeof (char *) == sizeof (value)); Assert (wo_sz >= 1); switch (policy){ case Policy_next_fit: Assert (fl_prev != NULL); /* Search from [fl_prev] to the end of the list. */ prev = fl_prev; cur = Next (prev); while (cur != NULL){ Assert (Is_in_heap (cur)); if (Wosize_bp (cur) >= wo_sz){ return allocate_block (Whsize_wosize (wo_sz), 0, prev, cur); } prev = cur; cur = Next (prev); } fl_last = prev; /* Search from the start of the list to [fl_prev]. */ prev = Fl_head; cur = Next (prev); while (prev != fl_prev){ if (Wosize_bp (cur) >= wo_sz){ return allocate_block (Whsize_wosize (wo_sz), 0, prev, cur); } prev = cur; cur = Next (prev); } /* No suitable block was found. */ return NULL; break; case Policy_first_fit: { /* Search in the flp array. */ for (i = 0; i < flp_size; i++){ sz = Wosize_bp (Next (flp[i])); if (sz >= wo_sz){ #if FREELIST_DEBUG if (i > 5) fprintf (stderr, "FLP: found at %d size=%d\n", i, wo_sz); #endif result = allocate_block (Whsize_wosize (wo_sz), i, flp[i], Next(flp[i])); goto update_flp; } } /* Extend the flp array. */ if (flp_size == 0){ prev = Fl_head; prevsz = 0; }else{ prev = Next (flp[flp_size - 1]); prevsz = Wosize_bp (prev); if (beyond != NULL) prev = beyond; } while (flp_size < FLP_MAX){ cur = Next (prev); if (cur == NULL){ fl_last = prev; beyond = (prev == Fl_head) ? NULL : prev; return NULL; }else{ sz = Wosize_bp (cur); if (sz > prevsz){ flp[flp_size] = prev; ++ flp_size; if (sz >= wo_sz){ beyond = cur; i = flp_size - 1; #if FREELIST_DEBUG if (flp_size > 5){ fprintf (stderr, "FLP: extended to %d\n", flp_size); } #endif result = allocate_block (Whsize_wosize (wo_sz), flp_size - 1, prev, cur); goto update_flp; } prevsz = sz; } } prev = cur; } beyond = cur; /* The flp table is full. Do a slow first-fit search. */ #if FREELIST_DEBUG fprintf (stderr, "FLP: table is full -- slow first-fit\n"); #endif if (beyond != NULL){ prev = beyond; }else{ prev = flp[flp_size - 1]; } prevsz = Wosize_bp (Next (flp[FLP_MAX-1])); Assert (prevsz < wo_sz); cur = Next (prev); while (cur != NULL){ Assert (Is_in_heap (cur)); sz = Wosize_bp (cur); if (sz < prevsz){ beyond = cur; }else if (sz >= wo_sz){ return allocate_block (Whsize_wosize (wo_sz), flp_size, prev, cur); } prev = cur; cur = Next (prev); } fl_last = prev; return NULL; update_flp: /* (i, sz) */ /* The block at [i] was removed or reduced. Update the table. */ Assert (0 <= i && i < flp_size + 1); if (i < flp_size){ if (i > 0){ prevsz = Wosize_bp (Next (flp[i-1])); }else{ prevsz = 0; } if (i == flp_size - 1){ if (Wosize_bp (Next (flp[i])) <= prevsz){ beyond = Next (flp[i]); -- flp_size; }else{ beyond = NULL; } }else{ char *buf [FLP_MAX]; int j = 0; mlsize_t oldsz = sz; prev = flp[i]; while (prev != flp[i+1]){ cur = Next (prev); sz = Wosize_bp (cur); if (sz > prevsz){ buf[j++] = prev; prevsz = sz; if (sz >= oldsz){ Assert (sz == oldsz); break; } } prev = cur; } #if FREELIST_DEBUG if (j > 2) fprintf (stderr, "FLP: update; buf size = %d\n", j); #endif if (FLP_MAX >= flp_size + j - 1){ if (j != 1){ memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (flp_size-i-1)); } if (j > 0) memmove (&flp[i], &buf[0], sizeof (block *) * j); flp_size += j - 1; }else{ if (FLP_MAX > i + j){ if (j != 1){ memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (FLP_MAX-i-j)); } if (j > 0) memmove (&flp[i], &buf[0], sizeof (block *) * j); }else{ if (i != FLP_MAX){ memmove (&flp[i], &buf[0], sizeof (block *) * (FLP_MAX - i)); } } flp_size = FLP_MAX - 1; beyond = Next (flp[FLP_MAX - 1]); } } } return result; } break; default: Assert (0); /* unknown policy */ break; } return NULL; /* NOT REACHED */ } static char *last_fragment; void caml_fl_init_merge (void) { last_fragment = NULL; caml_fl_merge = Fl_head; #ifdef DEBUG fl_check (); #endif } static void truncate_flp (char *changed) { if (changed == Fl_head){ flp_size = 0; beyond = NULL; }else{ while (flp_size > 0 && Next (flp[flp_size - 1]) >= changed) -- flp_size; if (beyond >= changed) beyond = NULL; } } /* This is called by caml_compact_heap. */ void caml_fl_reset (void) { Next (Fl_head) = NULL; switch (policy){ case Policy_next_fit: fl_prev = Fl_head; break; case Policy_first_fit: truncate_flp (Fl_head); break; default: Assert (0); break; } caml_fl_cur_size = 0; caml_fl_init_merge (); } /* [caml_fl_merge_block] returns the head pointer of the next block after [bp], because merging blocks may change the size of [bp]. */ char *caml_fl_merge_block (char *bp) { char *prev, *cur, *adj; header_t hd = Hd_bp (bp); mlsize_t prev_wosz; caml_fl_cur_size += Whsize_hd (hd); #ifdef DEBUG caml_set_fields (bp, 0, Debug_free_major); #endif prev = caml_fl_merge; cur = Next (prev); /* The sweep code makes sure that this is the right place to insert this block: */ Assert (prev < bp || prev == Fl_head); Assert (cur > bp || cur == NULL); if (policy == Policy_first_fit) truncate_flp (prev); /* If [last_fragment] and [bp] are adjacent, merge them. */ if (last_fragment == Hp_bp (bp)){ mlsize_t bp_whsz = Whsize_bp (bp); if (bp_whsz <= Max_wosize){ hd = Make_header (bp_whsz, 0, Caml_white); bp = last_fragment; Hd_bp (bp) = hd; caml_fl_cur_size += Whsize_wosize (0); } } /* If [bp] and [cur] are adjacent, remove [cur] from the free-list and merge them. */ adj = bp + Bosize_hd (hd); if (adj == Hp_bp (cur)){ char *next_cur = Next (cur); mlsize_t cur_whsz = Whsize_bp (cur); if (Wosize_hd (hd) + cur_whsz <= Max_wosize){ Next (prev) = next_cur; if (policy == Policy_next_fit && fl_prev == cur) fl_prev = prev; hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Caml_blue); Hd_bp (bp) = hd; adj = bp + Bosize_hd (hd); #ifdef DEBUG fl_last = NULL; Next (cur) = (char *) Debug_free_major; Hd_bp (cur) = Debug_free_major; #endif cur = next_cur; } } /* If [prev] and [bp] are adjacent merge them, else insert [bp] into the free-list if it is big enough. */ prev_wosz = Wosize_bp (prev); if (prev + Bsize_wsize (prev_wosz) == Hp_bp (bp) && prev_wosz + Whsize_hd (hd) < Max_wosize){ Hd_bp (prev) = Make_header (prev_wosz + Whsize_hd (hd), 0,Caml_blue); #ifdef DEBUG Hd_bp (bp) = Debug_free_major; #endif Assert (caml_fl_merge == prev); }else if (Wosize_hd (hd) != 0){ Hd_bp (bp) = Bluehd_hd (hd); Next (bp) = cur; Next (prev) = bp; caml_fl_merge = bp; }else{ /* This is a fragment. Leave it in white but remember it for eventual merging with the next block. */ last_fragment = bp; caml_fl_cur_size -= Whsize_wosize (0); } return adj; } /* This is a heap extension. We have to insert it in the right place in the free-list. [caml_fl_add_blocks] can only be called right after a call to [caml_fl_allocate] that returned NULL. Most of the heap extensions are expected to be at the end of the free list. (This depends on the implementation of [malloc].) [bp] must point to a list of blocks chained by their field 0, terminated by NULL, and field 1 of the first block must point to the last block. */ void caml_fl_add_blocks (char *bp) { Assert (fl_last != NULL); Assert (Next (fl_last) == NULL); caml_fl_cur_size += Whsize_bp (bp); if (bp > fl_last){ Next (fl_last) = bp; if (fl_last == caml_fl_merge && bp < caml_gc_sweep_hp){ caml_fl_merge = (char *) Field (bp, 1); } if (policy == Policy_first_fit && flp_size < FLP_MAX){ flp [flp_size++] = fl_last; } }else{ char *cur, *prev; prev = Fl_head; cur = Next (prev); while (cur != NULL && cur < bp){ Assert (prev < bp || prev == Fl_head); /* XXX TODO: extend flp on the fly */ prev = cur; cur = Next (prev); } Assert (prev < bp || prev == Fl_head); Assert (cur > bp || cur == NULL); Next (Field (bp, 1)) = cur; Next (prev) = bp; /* When inserting blocks between [caml_fl_merge] and [caml_gc_sweep_hp], we must advance [caml_fl_merge] to the new block, so that [caml_fl_merge] is always the last free-list block before [caml_gc_sweep_hp]. */ if (prev == caml_fl_merge && bp < caml_gc_sweep_hp){ caml_fl_merge = (char *) Field (bp, 1); } if (policy == Policy_first_fit) truncate_flp (bp); } } /* Cut a block of memory into Max_wosize pieces, give them headers, and optionally merge them into the free list. arguments: p: pointer to the first word of the block size: size of the block (in words) do_merge: 1 -> do merge; 0 -> do not merge color: which color to give to the pieces; if [do_merge] is 1, this is overridden by the merge code, but we have historically used [Caml_white]. */ void caml_make_free_blocks (value *p, mlsize_t size, int do_merge, int color) { mlsize_t sz; while (size > 0){ if (size > Whsize_wosize (Max_wosize)){ sz = Whsize_wosize (Max_wosize); }else{ sz = size; } *(header_t *)p = Make_header (Wosize_whsize (sz), 0, color); if (do_merge) caml_fl_merge_block (Bp_hp (p)); size -= sz; p += sz; } } void caml_set_allocation_policy (uintnat p) { switch (p){ case Policy_next_fit: fl_prev = Fl_head; policy = p; break; case Policy_first_fit: flp_size = 0; beyond = NULL; policy = p; break; default: break; } } mingw-ocaml/ocaml/byterun/misc.h0000644000175000017500000000744312124403240016261 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Miscellaneous macros and variables. */ #ifndef CAML_MISC_H #define CAML_MISC_H #ifndef CAML_NAME_SPACE #include "compatibility.h" #endif #include "config.h" /* Standard definitions */ #include #include /* Basic types and constants */ typedef size_t asize_t; #ifndef NULL #define NULL 0 #endif /* */ typedef char * addr; /* */ #ifdef __GNUC__ /* Works only in GCC 2.5 and later */ #define Noreturn __attribute__ ((noreturn)) #else #define Noreturn #endif /* Export control (to mark primitives and to handle Windows DLL) */ #define CAMLexport #define CAMLprim #define CAMLextern extern /* Assertions */ /* */ #ifdef DEBUG #define CAMLassert(x) ((x) ? 0 : caml_failed_assert ( #x , __FILE__, __LINE__)) CAMLextern int caml_failed_assert (char *, char *, int); #else #define CAMLassert(x) ((void) 0) #endif CAMLextern void caml_fatal_error (char *msg) Noreturn; CAMLextern void caml_fatal_error_arg (char *fmt, char *arg) Noreturn; CAMLextern void caml_fatal_error_arg2 (char *fmt1, char *arg1, char *fmt2, char *arg2) Noreturn; /* Data structures */ struct ext_table { int size; int capacity; void ** contents; }; extern void caml_ext_table_init(struct ext_table * tbl, int init_capa); extern int caml_ext_table_add(struct ext_table * tbl, void * data); extern void caml_ext_table_free(struct ext_table * tbl, int free_entries); /* GC flags and messages */ extern uintnat caml_verb_gc; void caml_gc_message (int, char *, uintnat); /* Memory routines */ char *caml_aligned_malloc (asize_t, int, void **); #ifdef DEBUG #ifdef ARCH_SIXTYFOUR #define Debug_tag(x) (0xD700D7D7D700D6D7ul \ | ((uintnat) (x) << 16) \ | ((uintnat) (x) << 48)) #else #define Debug_tag(x) (0xD700D6D7ul | ((uintnat) (x) << 16)) #endif /* ARCH_SIXTYFOUR */ /* 00 -> free words in minor heap 01 -> fields of free list blocks in major heap 03 -> heap chunks deallocated by heap shrinking 04 -> fields deallocated by [caml_obj_truncate] 10 -> uninitialised fields of minor objects 11 -> uninitialised fields of major objects 15 -> uninitialised words of [caml_aligned_malloc] blocks 85 -> filler bytes of [caml_aligned_malloc] special case (byte by byte): D7 -> uninitialised words of [caml_stat_alloc] blocks */ #define Debug_free_minor Debug_tag (0x00) #define Debug_free_major Debug_tag (0x01) #define Debug_free_shrink Debug_tag (0x03) #define Debug_free_truncate Debug_tag (0x04) #define Debug_uninit_minor Debug_tag (0x10) #define Debug_uninit_major Debug_tag (0x11) #define Debug_uninit_align Debug_tag (0x15) #define Debug_filler_align Debug_tag (0x85) #define Debug_uninit_stat 0xD7 extern void caml_set_fields (char *, unsigned long, unsigned long); #endif /* DEBUG */ #ifndef CAML_AVOID_CONFLICTS #define Assert CAMLassert #endif /* */ #endif /* CAML_MISC_H */ mingw-ocaml/ocaml/byterun/array.c0000644000175000017500000002663012124403240016436 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Operations on arrays */ #include #include "alloc.h" #include "fail.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" CAMLexport mlsize_t caml_array_length(value array) { if (Tag_val(array) == Double_array_tag) return Wosize_val(array) / Double_wosize; else return Wosize_val(array); } CAMLexport int caml_is_double_array(value array) { return (Tag_val(array) == Double_array_tag); } CAMLprim value caml_array_get_addr(value array, value index) { intnat idx = Long_val(index); if (idx < 0 || idx >= Wosize_val(array)) caml_array_bound_error(); return Field(array, idx); } CAMLprim value caml_array_get_float(value array, value index) { intnat idx = Long_val(index); double d; value res; if (idx < 0 || idx >= Wosize_val(array) / Double_wosize) caml_array_bound_error(); d = Double_field(array, idx); #define Setup_for_gc #define Restore_after_gc Alloc_small(res, Double_wosize, Double_tag); #undef Setup_for_gc #undef Restore_after_gc Store_double_val(res, d); return res; } CAMLprim value caml_array_get(value array, value index) { if (Tag_val(array) == Double_array_tag) return caml_array_get_float(array, index); else return caml_array_get_addr(array, index); } CAMLprim value caml_array_set_addr(value array, value index, value newval) { intnat idx = Long_val(index); if (idx < 0 || idx >= Wosize_val(array)) caml_array_bound_error(); Modify(&Field(array, idx), newval); return Val_unit; } CAMLprim value caml_array_set_float(value array, value index, value newval) { intnat idx = Long_val(index); if (idx < 0 || idx >= Wosize_val(array) / Double_wosize) caml_array_bound_error(); Store_double_field(array, idx, Double_val(newval)); return Val_unit; } CAMLprim value caml_array_set(value array, value index, value newval) { if (Tag_val(array) == Double_array_tag) return caml_array_set_float(array, index, newval); else return caml_array_set_addr(array, index, newval); } CAMLprim value caml_array_unsafe_get_float(value array, value index) { double d; value res; d = Double_field(array, Long_val(index)); #define Setup_for_gc #define Restore_after_gc Alloc_small(res, Double_wosize, Double_tag); #undef Setup_for_gc #undef Restore_after_gc Store_double_val(res, d); return res; } CAMLprim value caml_array_unsafe_get(value array, value index) { if (Tag_val(array) == Double_array_tag) return caml_array_unsafe_get_float(array, index); else return Field(array, Long_val(index)); } CAMLprim value caml_array_unsafe_set_addr(value array, value index,value newval) { intnat idx = Long_val(index); Modify(&Field(array, idx), newval); return Val_unit; } CAMLprim value caml_array_unsafe_set_float(value array,value index,value newval) { Store_double_field(array, Long_val(index), Double_val(newval)); return Val_unit; } CAMLprim value caml_array_unsafe_set(value array, value index, value newval) { if (Tag_val(array) == Double_array_tag) return caml_array_unsafe_set_float(array, index, newval); else return caml_array_unsafe_set_addr(array, index, newval); } CAMLprim value caml_make_vect(value len, value init) { CAMLparam2 (len, init); CAMLlocal1 (res); mlsize_t size, wsize, i; double d; size = Long_val(len); if (size == 0) { res = Atom(0); } else if (Is_block(init) && Is_in_value_area(init) && Tag_val(init) == Double_tag) { d = Double_val(init); wsize = size * Double_wosize; if (wsize > Max_wosize) caml_invalid_argument("Array.make"); res = caml_alloc(wsize, Double_array_tag); for (i = 0; i < size; i++) { Store_double_field(res, i, d); } } else { if (size > Max_wosize) caml_invalid_argument("Array.make"); if (size < Max_young_wosize) { res = caml_alloc_small(size, 0); for (i = 0; i < size; i++) Field(res, i) = init; } else if (Is_block(init) && Is_young(init)) { caml_minor_collection(); res = caml_alloc_shr(size, 0); for (i = 0; i < size; i++) Field(res, i) = init; res = caml_check_urgent_gc (res); } else { res = caml_alloc_shr(size, 0); for (i = 0; i < size; i++) caml_initialize(&Field(res, i), init); res = caml_check_urgent_gc (res); } } CAMLreturn (res); } CAMLprim value caml_make_array(value init) { CAMLparam1 (init); mlsize_t wsize, size, i; CAMLlocal2 (v, res); size = Wosize_val(init); if (size == 0) { CAMLreturn (init); } else { v = Field(init, 0); if (Is_long(v) || ! Is_in_value_area(v) || Tag_val(v) != Double_tag) { CAMLreturn (init); } else { Assert(size < Max_young_wosize); wsize = size * Double_wosize; res = caml_alloc_small(wsize, Double_array_tag); for (i = 0; i < size; i++) { Store_double_field(res, i, Double_val(Field(init, i))); } CAMLreturn (res); } } } /* Blitting */ CAMLprim value caml_array_blit(value a1, value ofs1, value a2, value ofs2, value n) { value * src, * dst; intnat count; if (Tag_val(a2) == Double_array_tag) { /* Arrays of floats. The values being copied are floats, not pointer, so we can do a direct copy. memmove takes care of potential overlap between the copied areas. */ memmove((double *)a2 + Long_val(ofs2), (double *)a1 + Long_val(ofs1), Long_val(n) * sizeof(double)); return Val_unit; } if (Is_young(a2)) { /* Arrays of values, destination is in young generation. Here too we can do a direct copy since this cannot create old-to-young pointers, nor mess up with the incremental major GC. Again, memmove takes care of overlap. */ memmove(&Field(a2, Long_val(ofs2)), &Field(a1, Long_val(ofs1)), Long_val(n) * sizeof(value)); return Val_unit; } /* Array of values, destination is in old generation. We must use caml_modify. */ count = Long_val(n); if (a1 == a2 && Long_val(ofs1) < Long_val(ofs2)) { /* Copy in descending order */ for (dst = &Field(a2, Long_val(ofs2) + count - 1), src = &Field(a1, Long_val(ofs1) + count - 1); count > 0; count--, src--, dst--) { caml_modify(dst, *src); } } else { /* Copy in ascending order */ for (dst = &Field(a2, Long_val(ofs2)), src = &Field(a1, Long_val(ofs1)); count > 0; count--, src++, dst++) { caml_modify(dst, *src); } } /* Many caml_modify in a row can create a lot of old-to-young refs. Give the minor GC a chance to run if it needs to. */ caml_check_urgent_gc(Val_unit); return Val_unit; } /* A generic function for extraction and concatenation of sub-arrays */ static value caml_array_gather(intnat num_arrays, value arrays[/*num_arrays*/], intnat offsets[/*num_arrays*/], intnat lengths[/*num_arrays*/]) { CAMLparamN(arrays, num_arrays); value res; /* no need to register it as a root */ int isfloat; mlsize_t i, size, wsize, count, pos; value * src; /* Determine total size and whether result array is an array of floats */ size = 0; isfloat = 0; for (i = 0; i < num_arrays; i++) { size += lengths[i]; if (Tag_val(arrays[i]) == Double_array_tag) isfloat = 1; } if (size == 0) { /* If total size = 0, just return empty array */ res = Atom(0); } else if (isfloat) { /* This is an array of floats. We can use memcpy directly. */ wsize = size * Double_wosize; if (wsize > Max_wosize) caml_invalid_argument("Array.concat"); res = caml_alloc(wsize, Double_array_tag); for (i = 0, pos = 0; i < num_arrays; i++) { memcpy((double *)res + pos, (double *)arrays[i] + offsets[i], lengths[i] * sizeof(double)); pos += lengths[i]; } Assert(pos == size); } else if (size > Max_wosize) { /* Array of values, too big. */ caml_invalid_argument("Array.concat"); } else if (size < Max_young_wosize) { /* Array of values, small enough to fit in young generation. We can use memcpy directly. */ res = caml_alloc_small(size, 0); for (i = 0, pos = 0; i < num_arrays; i++) { memcpy(&Field(res, pos), &Field(arrays[i], offsets[i]), lengths[i] * sizeof(value)); pos += lengths[i]; } Assert(pos == size); } else { /* Array of values, must be allocated in old generation and filled using caml_initialize. */ res = caml_alloc_shr(size, 0); pos = 0; for (i = 0, pos = 0; i < num_arrays; i++) { for (src = &Field(arrays[i], offsets[i]), count = lengths[i]; count > 0; count--, src++, pos++) { caml_initialize(&Field(res, pos), *src); } /* Many caml_initialize in a row can create a lot of old-to-young refs. Give the minor GC a chance to run if it needs to. */ res = caml_check_urgent_gc(res); } Assert(pos == size); } CAMLreturn (res); } CAMLprim value caml_array_sub(value a, value ofs, value len) { value arrays[1] = { a }; intnat offsets[1] = { Long_val(ofs) }; intnat lengths[1] = { Long_val(len) }; return caml_array_gather(1, arrays, offsets, lengths); } CAMLprim value caml_array_append(value a1, value a2) { value arrays[2] = { a1, a2 }; intnat offsets[2] = { 0, 0 }; intnat lengths[2] = { caml_array_length(a1), caml_array_length(a2) }; return caml_array_gather(2, arrays, offsets, lengths); } CAMLprim value caml_array_concat(value al) { #define STATIC_SIZE 16 value static_arrays[STATIC_SIZE], * arrays; intnat static_offsets[STATIC_SIZE], * offsets; intnat static_lengths[STATIC_SIZE], * lengths; intnat n, i; value l, res; /* Length of list = number of arrays */ for (n = 0, l = al; l != Val_int(0); l = Field(l, 1)) n++; /* Allocate extra storage if too many arrays */ if (n <= STATIC_SIZE) { arrays = static_arrays; offsets = static_offsets; lengths = static_lengths; } else { arrays = caml_stat_alloc(n * sizeof(value)); offsets = caml_stat_alloc(n * sizeof(intnat)); lengths = caml_stat_alloc(n * sizeof(value)); } /* Build the parameters to caml_array_gather */ for (i = 0, l = al; l != Val_int(0); l = Field(l, 1), i++) { arrays[i] = Field(l, 0); offsets[i] = 0; lengths[i] = caml_array_length(Field(l, 0)); } /* Do the concatenation */ res = caml_array_gather(n, arrays, offsets, lengths); /* Free the extra storage if needed */ if (n > STATIC_SIZE) { caml_stat_free(arrays); caml_stat_free(offsets); caml_stat_free(lengths); } return res; } mingw-ocaml/ocaml/byterun/hash.c0000644000175000017500000002602012124403240016234 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* The generic hashing primitive */ /* The interface of this file is in "mlvalues.h" (for [caml_hash_variant]) and in "hash.h" (for the other exported functions). */ #include "mlvalues.h" #include "custom.h" #include "memory.h" #include "hash.h" #ifdef ARCH_INT64_TYPE #include "int64_native.h" #else #include "int64_emul.h" #endif /* The new implementation, based on MurmurHash 3, http://code.google.com/p/smhasher/ */ #define ROTL32(x,n) ((x) << n | (x) >> (32-n)) #define MIX(h,d) \ d *= 0xcc9e2d51; \ d = ROTL32(d, 15); \ d *= 0x1b873593; \ h ^= d; \ h = ROTL32(h, 13); \ h = h * 5 + 0xe6546b64; #define FINAL_MIX(h) \ h ^= h >> 16; \ h *= 0x85ebca6b; \ h ^= h >> 13; \ h *= 0xc2b2ae35; \ h ^= h >> 16; CAMLexport uint32 caml_hash_mix_uint32(uint32 h, uint32 d) { MIX(h, d); return h; } /* Mix a platform-native integer. */ CAMLexport uint32 caml_hash_mix_intnat(uint32 h, intnat d) { uint32 n; #ifdef ARCH_SIXTYFOUR /* Mix the low 32 bits and the high 32 bits, in a way that preserves 32/64 compatibility: we want n = (uint32) d if d is in the range [-2^31, 2^31-1]. */ n = (d >> 32) ^ (d >> 63) ^ d; /* If 0 <= d < 2^31: d >> 32 = 0 d >> 63 = 0 If -2^31 <= d < 0: d >> 32 = -1 d >> 63 = -1 In both cases, n = (uint32) d. */ #else n = d; #endif MIX(h, n); return h; } /* Mix a 64-bit integer. */ CAMLexport uint32 caml_hash_mix_int64(uint32 h, int64 d) { uint32 hi, lo; I64_split(d, hi, lo); MIX(h, lo); MIX(h, hi); return h; } /* Mix a double-precision float. Treats +0.0 and -0.0 identically. Treats all NaNs identically. */ CAMLexport uint32 caml_hash_mix_double(uint32 hash, double d) { union { double d; #if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__)) struct { uint32 h; uint32 l; } i; #else struct { uint32 l; uint32 h; } i; #endif } u; uint32 h, l; /* Convert to two 32-bit halves */ u.d = d; h = u.i.h; l = u.i.l; /* Normalize NaNs */ if ((h & 0x7FF00000) == 0x7FF00000 && (l | (h & 0xFFFFF)) != 0) { h = 0x7FF00000; l = 0x00000001; } /* Normalize -0 into +0 */ else if (h == 0x80000000 && l == 0) { h = 0; } MIX(hash, l); MIX(hash, h); return hash; } /* Mix a single-precision float. Treats +0.0 and -0.0 identically. Treats all NaNs identically. */ CAMLexport uint32 caml_hash_mix_float(uint32 hash, float d) { union { float f; uint32 i; } u; uint32 n; /* Convert to int32 */ u.f = d; n = u.i; /* Normalize NaNs */ if ((n & 0x7F800000) == 0x7F800000 && (n & 0x007FFFFF) != 0) { n = 0x7F800001; } /* Normalize -0 into +0 */ else if (n == 0x80000000) { n = 0; } MIX(hash, n); return hash; } /* Mix an OCaml string */ CAMLexport uint32 caml_hash_mix_string(uint32 h, value s) { mlsize_t len = caml_string_length(s); mlsize_t i; uint32 w; /* Mix by 32-bit blocks (little-endian) */ for (i = 0; i + 4 <= len; i += 4) { #ifdef ARCH_BIG_ENDIAN w = Byte_u(s, i) | (Byte_u(s, i+1) << 8) | (Byte_u(s, i+2) << 16) | (Byte_u(s, i+3) << 24); #else w = *((uint32 *) &Byte_u(s, i)); #endif MIX(h, w); } /* Finish with up to 3 bytes */ w = 0; switch (len & 3) { case 3: w = Byte_u(s, i+2) << 16; /* fallthrough */ case 2: w |= Byte_u(s, i+1) << 8; /* fallthrough */ case 1: w |= Byte_u(s, i); MIX(h, w); default: /*skip*/; /* len & 3 == 0, no extra bytes, do nothing */ } /* Finally, mix in the length. Ignore the upper 32 bits, generally 0. */ h ^= (uint32) len; return h; } /* Maximal size of the queue used for breadth-first traversal. */ #define HASH_QUEUE_SIZE 256 /* The generic hash function */ CAMLprim value caml_hash(value count, value limit, value seed, value obj) { value queue[HASH_QUEUE_SIZE]; /* Queue of values to examine */ intnat rd; /* Position of first value in queue */ intnat wr; /* One past position of last value in queue */ intnat sz; /* Max number of values to put in queue */ intnat num; /* Max number of meaningful values to see */ uint32 h; /* Rolling hash */ value v; mlsize_t i, len; sz = Long_val(limit); if (sz < 0 || sz > HASH_QUEUE_SIZE) sz = HASH_QUEUE_SIZE; num = Long_val(count); h = Int_val(seed); queue[0] = obj; rd = 0; wr = 1; while (rd < wr && num > 0) { v = queue[rd++]; again: if (Is_long(v)) { h = caml_hash_mix_intnat(h, v); num--; } else if (Is_in_value_area(v)) { switch (Tag_val(v)) { case String_tag: h = caml_hash_mix_string(h, v); num--; break; case Double_tag: h = caml_hash_mix_double(h, Double_val(v)); num--; break; case Double_array_tag: for (i = 0, len = Wosize_val(v) / Double_wosize; i < len; i++) { h = caml_hash_mix_double(h, Double_field(v, i)); num--; if (num < 0) break; } break; case Abstract_tag: /* Block contents unknown. Do nothing. */ break; case Infix_tag: /* Mix in the offset to distinguish different functions from the same mutually-recursive definition */ h = caml_hash_mix_uint32(h, Infix_offset_val(v)); v = v - Infix_offset_val(v); goto again; case Forward_tag: v = Forward_val(v); goto again; case Object_tag: h = caml_hash_mix_intnat(h, Oid_val(v)); num--; break; case Custom_tag: /* If no hashing function provided, do nothing. */ /* Only use low 32 bits of custom hash, for 32/64 compatibility */ if (Custom_ops_val(v)->hash != NULL) { uint32 n = (uint32) Custom_ops_val(v)->hash(v); h = caml_hash_mix_uint32(h, n); num--; } break; default: /* Mix in the tag and size, but do not count this towards [num] */ h = caml_hash_mix_uint32(h, Whitehd_hd(Hd_val(v))); /* Copy fields into queue, not exceeding the total size [sz] */ for (i = 0, len = Wosize_val(v); i < len; i++) { if (wr >= sz) break; queue[wr++] = Field(v, i); } break; } } else { /* v is a pointer outside the heap, probably a code pointer. Shall we count it? Let's say yes by compatibility with old code. */ h = caml_hash_mix_intnat(h, v); num--; } } /* Final mixing of bits */ FINAL_MIX(h); /* Fold result to the range [0, 2^30-1] so that it is a nonnegative OCaml integer both on 32 and 64-bit platforms. */ return Val_int(h & 0x3FFFFFFFU); } /* The old implementation */ static uintnat hash_accu; static intnat hash_univ_limit, hash_univ_count; static void hash_aux(value obj); CAMLprim value caml_hash_univ_param(value count, value limit, value obj) { hash_univ_limit = Long_val(limit); hash_univ_count = Long_val(count); hash_accu = 0; hash_aux(obj); return Val_long(hash_accu & 0x3FFFFFFF); /* The & has two purposes: ensure that the return value is positive and give the same result on 32 bit and 64 bit architectures. */ } #define Alpha 65599 #define Beta 19 #define Combine(new) (hash_accu = hash_accu * Alpha + (new)) #define Combine_small(new) (hash_accu = hash_accu * Beta + (new)) static void hash_aux(value obj) { unsigned char * p; mlsize_t i, j; tag_t tag; hash_univ_limit--; if (hash_univ_count < 0 || hash_univ_limit < 0) return; again: if (Is_long(obj)) { hash_univ_count--; Combine(Long_val(obj)); return; } /* Pointers into the heap are well-structured blocks. So are atoms. We can inspect the block contents. */ Assert (Is_block (obj)); if (Is_in_value_area(obj)) { tag = Tag_val(obj); switch (tag) { case String_tag: hash_univ_count--; i = caml_string_length(obj); for (p = &Byte_u(obj, 0); i > 0; i--, p++) Combine_small(*p); break; case Double_tag: /* For doubles, we inspect their binary representation, LSB first. The results are consistent among all platforms with IEEE floats. */ hash_univ_count--; #ifdef ARCH_BIG_ENDIAN for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double); i > 0; p--, i--) #else for (p = &Byte_u(obj, 0), i = sizeof(double); i > 0; p++, i--) #endif Combine_small(*p); break; case Double_array_tag: hash_univ_count--; for (j = 0; j < Bosize_val(obj); j += sizeof(double)) { #ifdef ARCH_BIG_ENDIAN for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double); i > 0; p--, i--) #else for (p = &Byte_u(obj, j), i = sizeof(double); i > 0; p++, i--) #endif Combine_small(*p); } break; case Abstract_tag: /* We don't know anything about the contents of the block. Better do nothing. */ break; case Infix_tag: hash_aux(obj - Infix_offset_val(obj)); break; case Forward_tag: obj = Forward_val (obj); goto again; case Object_tag: hash_univ_count--; Combine(Oid_val(obj)); break; case Custom_tag: /* If no hashing function provided, do nothing */ if (Custom_ops_val(obj)->hash != NULL) { hash_univ_count--; Combine(Custom_ops_val(obj)->hash(obj)); } break; default: hash_univ_count--; Combine_small(tag); i = Wosize_val(obj); while (i != 0) { i--; hash_aux(Field(obj, i)); } break; } return; } /* Otherwise, obj is a pointer outside the heap, to an object with a priori unknown structure. Use its physical address as hash key. */ Combine((intnat) obj); } /* Hashing variant tags */ CAMLexport value caml_hash_variant(char const * tag) { value accu; /* Same hashing algorithm as in ../typing/btype.ml, function hash_variant */ for (accu = Val_int(0); *tag != 0; tag++) accu = Val_int(223 * Int_val(accu) + *((unsigned char *) tag)); #ifdef ARCH_SIXTYFOUR accu = accu & Val_long(0x7FFFFFFFL); #endif /* Force sign extension of bit 31 for compatibility between 32 and 64-bit platforms */ return (int32) accu; } mingw-ocaml/ocaml/tools/0000755000175000017500000000000012124403240014615 5ustar tootstootsmingw-ocaml/ocaml/tools/.ignore0000644000175000017500000000052312124403240016101 0ustar tootstootsocamldep ocamldep.opt ocamldep.bak ocamlprof opnames.ml dumpobj dumpapprox objinfo cvt_emit cvt_emit.bak cvt_emit.ml ocamlcp ocamloptp ocamlmktop primreq ocamldumpobj keywords lexer299.ml ocaml299to3 ocamlmklib ocamlmklib.ml lexer301.ml scrapelabels addlabels myocamlbuild_config.ml objinfo_helper objinfo_helper.exe read_cmt read_cmt.bak mingw-ocaml/ocaml/tools/untypeast.mli0000644000175000017500000000200012124403240017344 0ustar tootstoots(**************************************************************************) (* *) (* OCaml *) (* *) (* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (**************************************************************************) val untype_structure : Typedtree.structure -> Parsetree.structure val untype_signature : Typedtree.signature -> Parsetree.signature val lident_of_path : Path.t -> Longident.t mingw-ocaml/ocaml/tools/cleanup-header0000644000175000017500000000210412124403240017412 0ustar tootstoots#!/bin/sed -f ####################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 2002 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ####################################################################### # Remove private parts from runtime include files, before installation # in /usr/local/lib/ocaml/caml /\/\* \*\// { r ../config/m.h d } /\/\* \*\// { r ../config/s.h d } /\/\* \*\//,/\/\* <\/private> \*\//d mingw-ocaml/ocaml/tools/ocamldep.ml0000644000175000017500000003702512124403240016742 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Longident open Parsetree (* Print the dependencies *) type file_kind = ML | MLI;; let load_path = ref ([] : (string * string array) list) let ml_synonyms = ref [".ml"] let mli_synonyms = ref [".mli"] let native_only = ref false let force_slash = ref false let error_occurred = ref false let raw_dependencies = ref false let sort_files = ref false let all_dependencies = ref false let one_line = ref false let files = ref [] (* Fix path to use '/' as directory separator instead of '\'. Only under Windows. *) let fix_slash s = if Sys.os_type = "Unix" then s else begin let r = String.copy s in for i = 0 to String.length r - 1 do if r.[i] = '\\' then r.[i] <- '/' done; r end let add_to_load_path dir = try let dir = Misc.expand_directory Config.standard_library dir in let contents = Sys.readdir dir in load_path := !load_path @ [dir, contents] with Sys_error msg -> Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg; error_occurred := true let add_to_synonym_list synonyms suffix = if (String.length suffix) > 1 && suffix.[0] = '.' then synonyms := suffix :: !synonyms else begin Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix; error_occurred := true end (* Find file 'name' (capitalized) in search path *) let find_file name = let uname = String.uncapitalize name in let rec find_in_array a pos = if pos >= Array.length a then None else begin let s = a.(pos) in if s = name || s = uname then Some s else find_in_array a (pos + 1) end in let rec find_in_path = function [] -> raise Not_found | (dir, contents) :: rem -> match find_in_array contents 0 with Some truename -> if dir = "." then truename else Filename.concat dir truename | None -> find_in_path rem in find_in_path !load_path let rec find_file_in_list = function [] -> raise Not_found | x :: rem -> try find_file x with Not_found -> find_file_in_list rem let find_dependency target_kind modname (byt_deps, opt_deps) = try let candidates = List.map ((^) modname) !mli_synonyms in let filename = find_file_in_list candidates in let basename = Filename.chop_extension filename in let cmi_file = basename ^ ".cmi" in let ml_exists = List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms in let new_opt_dep = if !all_dependencies then match target_kind with | MLI -> [ cmi_file ] | ML -> cmi_file :: (if ml_exists then [ basename ^ ".cmx"] else []) else (* this is a make-specific hack that makes .cmx to be a 'proxy' target that would force the dependency on .cmi via transitivity *) if ml_exists then [ basename ^ ".cmx" ] else [ cmi_file ] in ( cmi_file :: byt_deps, new_opt_dep @ opt_deps) with Not_found -> try (* "just .ml" case *) let candidates = List.map ((^) modname) !ml_synonyms in let filename = find_file_in_list candidates in let basename = Filename.chop_extension filename in let bytenames = if !all_dependencies then match target_kind with | MLI -> [basename ^ ".cmi"] | ML -> [basename ^ ".cmi";] else (* again, make-specific hack *) [basename ^ (if !native_only then ".cmx" else ".cmo")] in let optnames = if !all_dependencies then match target_kind with | MLI -> [basename ^ ".cmi"] | ML -> [basename ^ ".cmi"; basename ^ ".cmx"] else [ basename ^ ".cmx" ] in (bytenames @ byt_deps, optnames @ opt_deps) with Not_found -> (byt_deps, opt_deps) let (depends_on, escaped_eol) = (":", " \\\n ") let print_filename s = let s = if !force_slash then fix_slash s else s in if not (String.contains s ' ') then begin print_string s; end else begin let rec count n i = if i >= String.length s then n else if s.[i] = ' ' then count (n+1) (i+1) else count n (i+1) in let spaces = count 0 0 in let result = String.create (String.length s + spaces) in let rec loop i j = if i >= String.length s then () else if s.[i] = ' ' then begin result.[j] <- '\\'; result.[j+1] <- ' '; loop (i+1) (j+2); end else begin result.[j] <- s.[i]; loop (i+1) (j+1); end in loop 0 0; print_string result; end ;; let print_dependencies target_files deps = let rec print_items pos = function [] -> print_string "\n" | dep :: rem -> if !one_line || (pos + 1 + String.length dep <= 77) then begin if pos <> 0 then print_string " "; print_filename dep; print_items (pos + String.length dep + 1) rem end else begin print_string escaped_eol; print_filename dep; print_items (String.length dep + 4) rem end in print_items 0 (target_files @ [depends_on] @ deps) let print_raw_dependencies source_file deps = print_filename source_file; print_string depends_on; Depend.StringSet.iter (fun dep -> if (String.length dep > 0) && (match dep.[0] with 'A'..'Z' -> true | _ -> false) then begin print_char ' '; print_string dep end) deps; print_char '\n' (* Optionally preprocess a source file *) let preprocessor = ref None exception Preprocessing_error let preprocess sourcefile = match !preprocessor with None -> sourcefile | Some pp -> flush Pervasives.stdout; let tmpfile = Filename.temp_file "ocamldep_pp" "" in let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in if Sys.command comm <> 0 then begin Misc.remove_file tmpfile; raise Preprocessing_error end; tmpfile let remove_preprocessed inputfile = match !preprocessor with None -> () | Some _ -> Misc.remove_file inputfile (* Parse a file or get a dumped syntax tree in it *) let is_ast_file ic ast_magic = try let buffer = Misc.input_bytes ic (String.length ast_magic) in if buffer = ast_magic then true else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then failwith "OCaml and preprocessor have incompatible versions" else false with End_of_file -> false let parse_use_file ic = if is_ast_file ic Config.ast_impl_magic_number then let _source_file = input_value ic in [Ptop_def (input_value ic : Parsetree.structure)] else begin seek_in ic 0; let lb = Lexing.from_channel ic in Location.init lb !Location.input_name; Parse.use_file lb end let parse_interface ic = if is_ast_file ic Config.ast_intf_magic_number then let _source_file = input_value ic in (input_value ic : Parsetree.signature) else begin seek_in ic 0; let lb = Lexing.from_channel ic in Location.init lb !Location.input_name; Parse.interface lb end (* Process one file *) let report_err source_file exn = error_occurred := true; match exn with | Lexer.Error(err, range) -> Format.fprintf Format.err_formatter "@[%a%a@]@." Location.print_error range Lexer.report_error err | Syntaxerr.Error err -> Format.fprintf Format.err_formatter "@[%a@]@." Syntaxerr.report_error err | Sys_error msg -> Format.fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg | Preprocessing_error -> Format.fprintf Format.err_formatter "@[Preprocessing error on file %s@]@." source_file | x -> raise x let read_parse_and_extract parse_function extract_function source_file = Depend.free_structure_names := Depend.StringSet.empty; try let input_file = preprocess source_file in let ic = open_in_bin input_file in let cleanup () = close_in ic; remove_preprocessed input_file in try let ast = parse_function ic in extract_function Depend.StringSet.empty ast; cleanup (); !Depend.free_structure_names with x -> cleanup (); raise x with x -> report_err source_file x; Depend.StringSet.empty let ml_file_dependencies source_file = let extracted_deps = read_parse_and_extract parse_use_file Depend.add_use_file source_file in if !sort_files then files := (source_file, ML, !Depend.free_structure_names) :: !files else if !raw_dependencies then begin print_raw_dependencies source_file extracted_deps end else begin let basename = Filename.chop_extension source_file in let byte_targets = [ basename ^ ".cmo" ] in let native_targets = if !all_dependencies then [ basename ^ ".cmx"; basename ^ ".o" ] else [ basename ^ ".cmx" ] in let init_deps = if !all_dependencies then [source_file] else [] in let cmi_name = basename ^ ".cmi" in let init_deps, extra_targets = if List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !mli_synonyms then (cmi_name :: init_deps, cmi_name :: init_deps), [] else (init_deps, init_deps), (if !all_dependencies then [cmi_name] else []) in let (byt_deps, native_deps) = Depend.StringSet.fold (find_dependency ML) extracted_deps init_deps in print_dependencies (byte_targets @ extra_targets) byt_deps; print_dependencies (native_targets @ extra_targets) native_deps; end let mli_file_dependencies source_file = let extracted_deps = read_parse_and_extract parse_interface Depend.add_signature source_file in if !sort_files then files := (source_file, MLI, extracted_deps) :: !files else if !raw_dependencies then begin print_raw_dependencies source_file extracted_deps end else begin let basename = Filename.chop_extension source_file in let (byt_deps, opt_deps) = Depend.StringSet.fold (find_dependency MLI) extracted_deps ([], []) in print_dependencies [basename ^ ".cmi"] byt_deps end let file_dependencies_as kind source_file = Location.input_name := source_file; try if Sys.file_exists source_file then begin match kind with | ML -> ml_file_dependencies source_file | MLI -> mli_file_dependencies source_file end with x -> report_err source_file x let file_dependencies source_file = if List.exists (Filename.check_suffix source_file) !ml_synonyms then file_dependencies_as ML source_file else if List.exists (Filename.check_suffix source_file) !mli_synonyms then file_dependencies_as MLI source_file else () let sort_files_by_dependencies files = let h = Hashtbl.create 31 in let worklist = ref [] in (* Init Hashtbl with all defined modules *) let files = List.map (fun (file, file_kind, deps) -> let modname = Filename.chop_extension (Filename.basename file) in modname.[0] <- Char.uppercase modname.[0]; let key = (modname, file_kind) in let new_deps = ref [] in Hashtbl.add h key (file, new_deps); worklist := key :: !worklist; (modname, file_kind, deps, new_deps) ) files in (* Keep only dependencies to defined modules *) List.iter (fun (modname, file_kind, deps, new_deps) -> let add_dep modname kind = new_deps := (modname, kind) :: !new_deps; in Depend.StringSet.iter (fun modname -> match file_kind with ML -> (* ML depends both on ML and MLI *) if Hashtbl.mem h (modname, MLI) then add_dep modname MLI; if Hashtbl.mem h (modname, ML) then add_dep modname ML | MLI -> (* MLI depends on MLI if exists, or ML otherwise *) if Hashtbl.mem h (modname, MLI) then add_dep modname MLI else if Hashtbl.mem h (modname, ML) then add_dep modname ML ) deps; if file_kind = ML then (* add dep from .ml to .mli *) if Hashtbl.mem h (modname, MLI) then add_dep modname MLI ) files; (* Print and remove all files with no remaining dependency. Iterate until all files have been removed (worklist is empty) or no file was removed during a turn (cycle). *) let printed = ref true in while !printed && !worklist <> [] do let files = !worklist in worklist := []; printed := false; List.iter (fun key -> let (file, deps) = Hashtbl.find h key in let set = !deps in deps := []; List.iter (fun key -> if Hashtbl.mem h key then deps := key :: !deps ) set; if !deps = [] then begin printed := true; Printf.printf "%s " file; Hashtbl.remove h key; end else worklist := key :: !worklist ) files done; if !worklist <> [] then begin Format.fprintf Format.err_formatter "@[Warning: cycle in dependencies. End of list is not sorted.@]@."; Hashtbl.iter (fun _ (file, deps) -> Format.fprintf Format.err_formatter "\t@[%s: " file; List.iter (fun (modname, kind) -> Format.fprintf Format.err_formatter "%s.%s " modname (if kind=ML then "ml" else "mli"); ) !deps; Format.fprintf Format.err_formatter "@]@."; Printf.printf "%s " file) h; end; Printf.printf "\n%!"; () (* Entry point *) let usage = "Usage: ocamldep [options] \nOptions are:" let print_version () = Format.printf "ocamldep, version %s@." Sys.ocaml_version; exit 0; ;; let print_version_num () = Format.printf "%s@." Sys.ocaml_version; exit 0; ;; let _ = Clflags.classic := false; add_to_load_path Filename.current_dir_name; Arg.parse [ "-all", Arg.Set all_dependencies, " Generate dependencies on all files"; "-I", Arg.String add_to_load_path, " Add to the list of include directories"; "-impl", Arg.String (file_dependencies_as ML), " Process as a .ml file"; "-intf", Arg.String (file_dependencies_as MLI), " Process as a .mli file"; "-ml-synonym", Arg.String(add_to_synonym_list ml_synonyms), " Consider as a synonym of the .ml extension"; "-mli-synonym", Arg.String(add_to_synonym_list mli_synonyms), " Consider as a synonym of the .mli extension"; "-modules", Arg.Set raw_dependencies, " Print module dependencies in raw form (not suitable for make)"; "-native", Arg.Set native_only, " Generate dependencies for native-code only (no .cmo files)"; "-one-line", Arg.Set one_line, " Output one line per file, regardless of the length"; "-pp", Arg.String(fun s -> preprocessor := Some s), " Pipe sources through preprocessor "; "-slash", Arg.Set force_slash, " (Windows) Use forward slash / instead of backslash \\ in file paths"; "-sort", Arg.Set sort_files, " Sort files according to their dependencies"; "-version", Arg.Unit print_version, " Print version and exit"; "-vnum", Arg.Unit print_version_num, " Print version number and exit"; ] file_dependencies usage; if !sort_files then sort_files_by_dependencies !files; exit (if !error_occurred then 2 else 0) mingw-ocaml/ocaml/tools/ocaml299to3.ml0000644000175000017500000001136712124403240017144 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Lexer299 let input_buffer = Buffer.create 16383 let input_function ic buf len = let len = input ic buf 0 len in Buffer.add_substring input_buffer buf 0 len; len let output_buffer = Buffer.create 16383 let modified = ref false let convert buffer = let input_pos = ref 0 in let copy_input stop = Buffer.add_substring output_buffer (Buffer.contents input_buffer) !input_pos (stop - !input_pos); input_pos := stop in let last = ref (EOF, 0, 0) in try while true do let token = Lexer299.token buffer and start = Lexing.lexeme_start buffer and stop = Lexing.lexeme_end buffer and last_token, last_start, last_stop = !last in begin match token with | LABEL l0 -> let l = if l0 = "fun" then "f" else l0 in begin match last_token with | PREFIXOP "?(" -> modified := true; copy_input last_start; Buffer.add_char output_buffer '?'; Buffer.add_string output_buffer l; Buffer.add_string output_buffer ":("; input_pos := stop | QUESTION | LPAREN | LBRACE | SEMI | MINUSGREATER | EQUAL | COLON | COLONGREATER | VAL | MUTABLE | EXTERNAL | METHOD | OF -> if l0 = "fun" then begin modified := true; copy_input start; Buffer.add_string output_buffer l; Buffer.add_char output_buffer ':'; input_pos := stop end | _ -> modified := true; copy_input start; Buffer.add_char output_buffer '~'; Buffer.add_string output_buffer l; Buffer.add_char output_buffer ':'; input_pos := stop end | LABELID l -> modified := true; begin match last_token with | PREFIXOP "?(" -> copy_input last_start; Buffer.add_string output_buffer "?("; Buffer.add_string output_buffer l; input_pos := stop | LPAREN -> copy_input last_start; Buffer.add_string output_buffer "~("; Buffer.add_string output_buffer l; input_pos := stop | QUESTION -> copy_input last_stop; Buffer.add_string output_buffer l; input_pos := stop | _ -> copy_input start; Buffer.add_char output_buffer '~'; Buffer.add_string output_buffer l; input_pos := stop end | EOF -> raise End_of_file | _ -> () end; if last_token = QUESTION && token = LPAREN then last := (PREFIXOP "?(", last_start, stop) else last := (token, start, stop) done with End_of_file -> copy_input (Buffer.length input_buffer) let convert_file name = let ic = open_in name in Buffer.clear input_buffer; Buffer.clear output_buffer; modified := false; begin try convert (Lexing.from_function (input_function ic)); close_in ic with exn -> close_in ic; raise exn end; if !modified then begin let backup = name ^ ".bak" in if Sys.file_exists backup then Sys.remove name else Sys.rename name backup; let oc = open_out name in Buffer.output_buffer oc output_buffer; close_out oc end let _ = if Array.length Sys.argv < 2 || Sys.argv.(1) = "-h" || Sys.argv.(1) = "-help" then begin print_endline "Usage: ocaml299to3 ..."; print_endline "Description:"; print_endline "Convert OCaml 2.99 O'Labl-style labels in implementation files to"; print_endline "a syntax compatible with version 3. Also `fun:' labels are replaced by `f:'."; print_endline "Other syntactic changes are not handled."; print_endline "Old files are renamed to .bak."; print_endline "Interface files do not need label syntax conversion."; exit 0 end; for i = 1 to Array.length Sys.argv - 1 do let name = Sys.argv.(i) in prerr_endline ("Converting " ^ name); Printexc.catch convert_file name done mingw-ocaml/ocaml/tools/addlabels.ml0000644000175000017500000004210512124403240017064 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the Q Public License *) (* version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open StdLabels open Asttypes open Parsetree let norec = ref false let input_file file = let ic = try open_in file with _ -> failwith ("input_file : " ^ file) in let b = Buffer.create 1024 in let buf = String.create 1024 and len = ref 0 in while len := input ic buf 0 1024; !len > 0 do Buffer.add_substring b buf 0 !len done; close_in ic; Buffer.contents b module SMap = struct include Map.Make(struct type t = string let compare = compare end) let rec removes l m = match l with [] -> m | k::l -> let m = try remove k m with Not_found -> m in removes l m end let rec labels_of_sty sty = match sty.ptyp_desc with Ptyp_arrow (lab, _, rem) -> lab :: labels_of_sty rem | Ptyp_alias (rem, _) -> labels_of_sty rem | _ -> [] let rec labels_of_cty cty = match cty.pcty_desc with Pcty_fun (lab, _, rem) -> let (labs, meths) = labels_of_cty rem in (lab :: labs, meths) | Pcty_signature { pcsig_fields = fields } -> ([], List.fold_left fields ~init:[] ~f: begin fun meths -> function { pctf_desc = Pctf_meth (s, _, sty) } -> (s, labels_of_sty sty)::meths | _ -> meths end) | _ -> ([],[]) let rec pattern_vars pat = match pat.ppat_desc with Ppat_var s -> [s.txt] | Ppat_alias (pat, s) -> s.txt :: pattern_vars pat | Ppat_tuple l | Ppat_array l -> List.concat (List.map pattern_vars l) | Ppat_construct (_, Some pat, _) | Ppat_variant (_, Some pat) | Ppat_constraint (pat, _) -> pattern_vars pat | Ppat_record(l, _) -> List.concat (List.map l ~f:(fun (_,p) -> pattern_vars p)) | Ppat_or (pat1, pat2) -> pattern_vars pat1 @ pattern_vars pat2 | Ppat_lazy pat -> pattern_vars pat | Ppat_any | Ppat_constant _ | Ppat_construct _ | Ppat_variant _ | Ppat_type _ | Ppat_unpack _ -> [] let pattern_name pat = match pat.ppat_desc with Ppat_var s -> Some s | Ppat_constraint ({ppat_desc = Ppat_var s}, _) -> Some s | _ -> None let insertions = ref [] let add_insertion pos s = insertions := (pos,s) :: !insertions let sort_insertions () = List.sort !insertions ~cmp:(fun (pos1,_) (pos2,_) -> pos1 - pos2) let is_space = function ' '|'\t'|'\n'|'\r' -> true | _ -> false let is_alphanum = function 'A'..'Z'|'a'..'z'|'_'|'\192'..'\214'|'\216'..'\246' | '\248'..'\255'|'\''|'0'..'9' -> true | _ -> false (* Remove "(" or "begin" before a pattern *) let rec insertion_point pos ~text = let pos' = ref (pos-1) in while is_space text.[!pos'] do decr pos' done; if text.[!pos'] = '(' then insertion_point !pos' ~text else if !pos' >= 5 && String.sub text ~pos:(!pos'-4) ~len:5 = "begin" && not (is_alphanum text.[!pos'-5]) then insertion_point (!pos'-4) ~text else pos (* Search "=" or "->" before "function" *) let rec insertion_point2 pos ~text = let pos' = ref (pos-1) in while is_space text.[!pos'] do decr pos' done; if text.[!pos'] = '(' then insertion_point2 !pos' ~text else if !pos' >= 5 && String.sub text ~pos:(!pos'-4) ~len:5 = "begin" && not (is_alphanum text.[!pos'-5]) then insertion_point2 (!pos'-4) ~text else if text.[!pos'] = '=' then Some !pos' else if !pos' >= 1 && text.[!pos'-1] = '-' && text.[!pos'] = '>' then Some (!pos' - 1) else None let rec insert_labels ~labels ~text expr = match labels, expr.pexp_desc with l::labels, Pexp_function(l', _, [pat, rem]) -> if l <> "" && l.[0] <> '?' && l' = "" then begin let start_c = pat.ppat_loc.Location.loc_start.Lexing.pos_cnum in let pos = insertion_point start_c ~text in match pattern_name pat with | Some name when l = name.txt -> add_insertion pos "~" | _ -> add_insertion pos ("~" ^ l ^ ":") end; insert_labels ~labels ~text rem | l::labels, Pexp_function(l', _, lst) -> let pos = expr.pexp_loc.Location.loc_start.Lexing.pos_cnum in if l <> "" && l.[0] <> '?' && l' = "" && String.sub text ~pos ~len:8 = "function" then begin String.blit ~src:"match th" ~src_pos:0 ~dst:text ~dst_pos:pos ~len:8; add_insertion (pos+6) (l ^ " wi"); match insertion_point2 pos ~text with Some pos' -> add_insertion pos' ("~" ^ l ^ " ") | None -> add_insertion pos ("fun ~" ^ l ^ " -> ") end; List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e) | _, Pexp_match( _, lst) -> List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e) | _, Pexp_try(expr, lst) -> insert_labels ~labels ~text expr; List.iter lst ~f:(fun (p,e) -> insert_labels ~labels ~text e) | _, ( Pexp_let(_,_,e) | Pexp_sequence(_,e) | Pexp_when(_,e) | Pexp_constraint(e,_,_) | Pexp_letmodule(_,_,e) | Pexp_ifthenelse(_,e,None) ) -> insert_labels ~labels ~text e | _, Pexp_ifthenelse (_, e1, Some e2) -> insert_labels ~labels ~text e1; insert_labels ~labels ~text e2 | _ -> () let rec insert_labels_class ~labels ~text expr = match labels, expr.pcl_desc with l::labels, Pcl_fun(l', _, pat, rem) -> if l <> "" && l.[0] <> '?' && l' = "" then begin let start_c = pat.ppat_loc.Location.loc_start.Lexing.pos_cnum in let pos = insertion_point start_c ~text in match pattern_name pat with | Some name when l = name.txt -> add_insertion pos "~" | _ -> add_insertion pos ("~" ^ l ^ ":") end; insert_labels_class ~labels ~text rem | labels, (Pcl_constraint (expr, _) | Pcl_let (_, _, expr)) -> insert_labels_class ~labels ~text expr | _ -> () let rec insert_labels_type ~labels ~text ty = match labels, ty.ptyp_desc with l::labels, Ptyp_arrow(l', _, rem) -> if l <> "" && l.[0] <> '?' && l' = "" then begin let start_c = ty.ptyp_loc.Location.loc_start.Lexing.pos_cnum in let pos = insertion_point start_c ~text in add_insertion pos (l ^ ":") end; insert_labels_type ~labels ~text rem | _ -> () let rec insert_labels_app ~labels ~text args = match labels, args with l::labels, (l',arg)::args -> if l <> "" && l.[0] <> '?' && l' = "" then begin let pos0 = arg.pexp_loc.Location.loc_start.Lexing.pos_cnum in let pos = insertion_point pos0 ~text in match arg.pexp_desc with | Pexp_ident({ txt = Longident.Lident name }) when l = name && pos = pos0 -> add_insertion pos "~" | _ -> add_insertion pos ("~" ^ l ^ ":") end; insert_labels_app ~labels ~text args | _ -> () let insert_labels_app ~labels ~text args = let labels, opt_labels = List.partition labels ~f:(fun l -> l = "" || l.[0] <> '?') in let nopt_labels = List.map opt_labels ~f:(fun l -> String.sub l ~pos:1 ~len:(String.length l - 1)) in (* avoid ambiguous labels *) if List.exists labels ~f:(List.mem ~set:nopt_labels) then () else let aopt_labels = opt_labels @ nopt_labels in let args, lab_args = List.partition args ~f:(fun (l,_) -> l = "") in (* only optional arguments are labeled *) if List.for_all lab_args ~f:(fun (l,_) -> List.mem l ~set:aopt_labels) then insert_labels_app ~labels ~text args let rec add_labels_expr ~text ~values ~classes expr = let add_labels_rec ?(values=values) expr = add_labels_expr ~text ~values ~classes expr in match expr.pexp_desc with Pexp_apply ({pexp_desc=Pexp_ident({ txt = Longident.Lident s })}, args) -> begin try let labels = SMap.find s values in insert_labels_app ~labels ~text args with Not_found -> () end; List.iter args ~f:(fun (_,e) -> add_labels_rec e) | Pexp_apply ({pexp_desc=Pexp_send ({pexp_desc=Pexp_ident({ txt = Longident.Lident s })},meth)}, args) -> begin try if SMap.find s values = [""] then let labels = SMap.find (s ^ "#" ^ meth) values in insert_labels_app ~labels ~text args with Not_found -> () end | Pexp_apply ({pexp_desc=Pexp_new ({ txt = Longident.Lident s })}, args) -> begin try let labels = SMap.find s classes in insert_labels_app ~labels ~text args with Not_found -> () end | Pexp_let (recp, lst, expr) -> let vars = List.concat (List.map lst ~f:(fun (p,_) -> pattern_vars p)) in let vals = SMap.removes vars values in List.iter lst ~f: begin fun (_,e) -> add_labels_rec e ~values:(if recp = Recursive then vals else values) end; add_labels_rec expr ~values:vals | Pexp_function (_, None, lst) -> List.iter lst ~f: (fun (p,e) -> add_labels_rec e ~values:(SMap.removes (pattern_vars p) values)) | Pexp_function (_, Some e, lst) | Pexp_match (e, lst) | Pexp_try (e, lst) -> add_labels_rec e; List.iter lst ~f: (fun (p,e) -> add_labels_rec e ~values:(SMap.removes (pattern_vars p) values)) | Pexp_apply (e, args) -> List.iter add_labels_rec (e :: List.map snd args) | Pexp_tuple l | Pexp_array l -> List.iter add_labels_rec l | Pexp_construct (_, Some e, _) | Pexp_variant (_, Some e) | Pexp_field (e, _) | Pexp_constraint (e, _, _) | Pexp_send (e, _) | Pexp_setinstvar (_, e) | Pexp_letmodule (_, _, e) | Pexp_assert e | Pexp_lazy e | Pexp_poly (e, _) | Pexp_newtype (_, e) | Pexp_open (_, e) -> add_labels_rec e | Pexp_record (lst, opt) -> List.iter lst ~f:(fun (_,e) -> add_labels_rec e); begin match opt with Some e -> add_labels_rec e | None -> () end | Pexp_setfield (e1, _, e2) | Pexp_ifthenelse (e1, e2, None) | Pexp_sequence (e1, e2) | Pexp_while (e1, e2) | Pexp_when (e1, e2) -> add_labels_rec e1; add_labels_rec e2 | Pexp_ifthenelse (e1, e2, Some e3) -> add_labels_rec e1; add_labels_rec e2; add_labels_rec e3 | Pexp_for (s, e1, e2, _, e3) -> add_labels_rec e1; add_labels_rec e2; add_labels_rec e3 ~values:(SMap.removes [s.txt] values) | Pexp_override lst -> List.iter lst ~f:(fun (_,e) -> add_labels_rec e) | Pexp_ident _ | Pexp_constant _ | Pexp_construct _ | Pexp_variant _ | Pexp_new _ | Pexp_assertfalse | Pexp_object _ | Pexp_pack _ -> () let rec add_labels_class ~text ~classes ~values ~methods cl = match cl.pcl_desc with Pcl_constr _ -> () | Pcl_structure { pcstr_pat = p; pcstr_fields = l } -> let values = SMap.removes (pattern_vars p) values in let values = match pattern_name p with None -> values | Some s -> List.fold_left methods ~init:(SMap.add s.txt [""] values) ~f:(fun m (k,l) -> SMap.add (s.txt^"#"^k) l m) in ignore (List.fold_left l ~init:values ~f: begin fun values -> function e -> match e.pcf_desc with | Pcf_val (s, _, _, e) -> add_labels_expr ~text ~classes ~values e; SMap.removes [s.txt] values | Pcf_meth (s, _, _, e) -> begin try let labels = List.assoc s.txt methods in insert_labels ~labels ~text e with Not_found -> () end; add_labels_expr ~text ~classes ~values e; values | Pcf_init e -> add_labels_expr ~text ~classes ~values e; values | Pcf_inher _ | Pcf_valvirt _ | Pcf_virt _ | Pcf_constr _ -> values end) | Pcl_fun (_, opt, pat, cl) -> begin match opt with None -> () | Some e -> add_labels_expr ~text ~classes ~values e end; let values = SMap.removes (pattern_vars pat) values in add_labels_class ~text ~classes ~values ~methods cl | Pcl_apply (cl, args) -> List.iter args ~f:(fun (_,e) -> add_labels_expr ~text ~classes ~values e); add_labels_class ~text ~classes ~values ~methods cl | Pcl_let (recp, lst, cl) -> let vars = List.concat (List.map lst ~f:(fun (p,_) -> pattern_vars p)) in let vals = SMap.removes vars values in List.iter lst ~f: begin fun (_,e) -> add_labels_expr e ~text ~classes ~values:(if recp = Recursive then vals else values) end; add_labels_class cl ~text ~classes ~values:vals ~methods | Pcl_constraint (cl, _) -> add_labels_class ~text ~classes ~values ~methods cl let add_labels ~intf ~impl ~file = insertions := []; let values, classes = List.fold_left intf ~init:(SMap.empty, SMap.empty) ~f: begin fun (values, classes as acc) item -> match item.psig_desc with Psig_value (name, {pval_type = sty}) -> (SMap.add name.txt (labels_of_sty sty) values, classes) | Psig_class l -> (values, List.fold_left l ~init:classes ~f: begin fun classes {pci_name=name; pci_expr=cty} -> SMap.add name.txt (labels_of_cty cty) classes end) | _ -> acc end in let text = input_file file in ignore (List.fold_right impl ~init:(values, classes) ~f: begin fun item (values, classes as acc) -> match item.pstr_desc with Pstr_value (recp, l) -> let names = List.concat (List.map l ~f:(fun (p,_) -> pattern_vars p)) in List.iter l ~f: begin fun (pat, expr) -> begin match pattern_name pat with | Some s -> begin try let labels = SMap.find s.txt values in insert_labels ~labels ~text expr; if !norec then () else let values = SMap.fold (fun s l m -> if List.mem s names then SMap.add s l m else m) values SMap.empty in add_labels_expr expr ~text ~values ~classes:SMap.empty with Not_found -> () end | None -> () end; end; (SMap.removes names values, classes) | Pstr_primitive (s, {pval_type=sty}) -> begin try let labels = SMap.find s.txt values in insert_labels_type ~labels ~text sty; (SMap.removes [s.txt] values, classes) with Not_found -> acc end | Pstr_class l -> let names = List.map l ~f:(fun pci -> pci.pci_name.txt) in List.iter l ~f: begin fun {pci_name=name; pci_expr=expr} -> try let (labels, methods) = SMap.find name.txt classes in insert_labels_class ~labels ~text expr; if !norec then () else let classes = SMap.fold (fun s (l,_) m -> if List.mem s names then SMap.add s l m else m) classes SMap.empty in add_labels_class expr ~text ~classes ~methods ~values:SMap.empty with Not_found -> () end; (values, SMap.removes names classes) | _ -> acc end); if !insertions <> [] then begin let backup = file ^ ".bak" in if Sys.file_exists backup then Sys.remove file else Sys.rename file backup; let oc = open_out file in let last_pos = List.fold_left (sort_insertions ()) ~init:0 ~f: begin fun pos (pos', s) -> output oc text pos (pos'-pos); output_string oc s; pos' end in if last_pos < String.length text then output oc text last_pos (String.length text - last_pos); close_out oc end else prerr_endline ("No labels to insert in " ^ file) let process_file file = prerr_endline ("Processing " ^ file); if Filename.check_suffix file ".ml" then let intf = Filename.chop_suffix file ".ml" ^ ".mli" in let ic = open_in intf in let lexbuf = Lexing.from_channel ic in Location.init lexbuf intf; let intf = Parse.interface lexbuf in close_in ic; let ic = open_in file in let lexbuf = Lexing.from_channel ic in Location.init lexbuf file; let impl = Parse.implementation lexbuf in close_in ic; add_labels ~intf ~impl ~file else prerr_endline (file ^ " is not an implementation") let main () = let files = ref [] in Arg.parse ["-norec", Arg.Set norec, "do not labelize recursive calls"] (fun f -> files := f :: !files) "addlabels [-norec] "; let files = List.rev !files in List.iter files ~f:process_file let () = main () mingw-ocaml/ocaml/tools/Makefile0000644000175000017500000000205412124403240016256 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # $Id$ include Makefile.shared # To make custom toplevels ocamlmktop: ocamlmktop.tpl ../config/Makefile sed -e 's|%%BINDIR%%|$(BINDIR)|' ocamlmktop.tpl > ocamlmktop chmod +x ocamlmktop install:: cp ocamlmktop $(BINDIR) clean:: rm -f ocamlmktop mingw-ocaml/ocaml/tools/make-package-macosx0000755000175000017500000001061612124403240020345 0ustar tootstoots#!/bin/sh ######################################################################### # # # OCaml # # # # Damien Doligez, projet Moscova, INRIA Rocquencourt # # # # Copyright 2003 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # $Id$ cd package-macosx rm -rf ocaml.pkg ocaml-rw.dmg VERSION=`sed -e 1q ../VERSION` VERSION_MAJOR=`sed -n -e '1s/^\([0-9]*\)\..*/\1/p' ../VERSION` VERSION_MINOR=`sed -n -e '1s/^[0-9]*\.\([0-9]*\)[.+].*/\1/p' ../VERSION` cat >Description.plist < IFPkgDescriptionDeleteWarning IFPkgDescriptionDescription The OCaml compiler and tools IFPkgDescriptionTitle OCaml IFPkgDescriptionVersion ${VERSION} EOF cat >Info.plist < CFBundleGetInfoString OCaml ${VERSION} CFBundleIdentifier fr.inria.ocaml CFBundleName OCaml CFBundleShortVersionString ${VERSION} IFMajorVersion ${VERSION_MAJOR} IFMinorVersion ${VERSION_MINOR} IFPkgFlagAllowBackRev IFPkgFlagAuthorizationAction AdminAuthorization IFPkgFlagDefaultLocation /usr/local IFPkgFlagInstallFat IFPkgFlagIsRequired IFPkgFlagRelocatable IFPkgFlagRestartAction NoRestart IFPkgFlagRootVolumeOnly IFPkgFlagUpdateInstalledLanguages IFPkgFormatVersion 0.10000000149011612 EOF mkdir -p resources # stop here -> | cat >resources/ReadMe.txt <&2 exit 3 fi open "/Volumes/$volname" sleep 2 hdiutil detach $name rm -rf "ocaml-${VERSION}.dmg" hdiutil convert ocaml-rw.dmg -format UDZO -o "ocaml-${VERSION}.dmg" mingw-ocaml/ocaml/tools/ocamloptp.ml0000644000175000017500000001326412124403240017153 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2012 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: ocamlcp.ml 11890 2011-12-20 10:35:43Z frisch $ *) open Printf let compargs = ref ([] : string list) let profargs = ref ([] : string list) let toremove = ref ([] : string list) let option opt () = compargs := opt :: !compargs let option_with_arg opt arg = compargs := (Filename.quote arg) :: opt :: !compargs ;; let option_with_int opt arg = compargs := (string_of_int arg) :: opt :: !compargs ;; let make_archive = ref false;; let with_impl = ref false;; let with_intf = ref false;; let with_mli = ref false;; let with_ml = ref false;; let process_file filename = if Filename.check_suffix filename ".ml" then with_ml := true; if Filename.check_suffix filename ".mli" then with_mli := true; compargs := (Filename.quote filename) :: !compargs ;; let usage = "Usage: ocamloptp \noptions are:" let incompatible o = fprintf stderr "ocamloptp: profiling is incompatible with the %s option\n" o; exit 2 module Options = Main_args.Make_optcomp_options (struct let _a () = make_archive := true; option "-a" () let _absname = option "-absname" let _annot = option "-annot" let _binannot = option "-bin-annot" let _c = option "-c" let _cc s = option_with_arg "-cc" s let _cclib s = option_with_arg "-cclib" s let _ccopt s = option_with_arg "-ccopt" s let _compact = option "-compact" let _config = option "-config" let _for_pack s = option_with_arg "-for-pack" s let _g = option "-g" let _i = option "-i" let _I s = option_with_arg "-I" s let _impl s = with_impl := true; option_with_arg "-impl" s let _inline n = option_with_int "-inline" n let _intf s = with_intf := true; option_with_arg "-intf" s let _intf_suffix s = option_with_arg "-intf-suffix" s let _labels = option "-labels" let _linkall = option "-linkall" let _no_app_funct = option "-no-app-funct" let _noassert = option "-noassert" let _noautolink = option "-noautolink" let _nodynlink = option "-nodynlink" let _nolabels = option "-nolabels" let _nostdlib = option "-nostdlib" let _o s = option_with_arg "-o" s let _output_obj = option "-output-obj" let _p = option "-p" let _pack = option "-pack" let _pp s = incompatible "-pp" let _principal = option "-principal" let _rectypes = option "-rectypes" let _runtime_variant s = option_with_arg "-runtime-variant" s let _S = option "-S" let _strict_sequence = option "-strict-sequence" let _shared = option "-shared" let _thread = option "-thread" let _unsafe = option "-unsafe" let _v = option "-v" let _version = option "-version" let _vnum = option "-vnum" let _verbose = option "-verbose" let _w = option_with_arg "-w" let _warn_error = option_with_arg "-warn-error" let _warn_help = option "-warn-help" let _where = option "-where" let _nopervasives = option "-nopervasives" let _dparsetree = option "-dparsetree" let _drawlambda = option "-drawlambda" let _dlambda = option "-dlambda" let _dclambda = option "-dclambda" let _dcmm = option "-dcmm" let _dsel = option "-dsel" let _dcombine = option "-dcombine" let _dlive = option "-dlive" let _dspill = option "-dspill" let _dsplit = option "-dsplit" let _dinterf = option "-dinterf" let _dprefer = option "-dprefer" let _dalloc = option "-dalloc" let _dreload = option "-dreload" let _dscheduling = option "-dscheduling" let _dlinear = option "-dlinear" let _dstartup = option "-dstartup" let anonymous = process_file end);; let add_profarg s = profargs := (Filename.quote s) :: "-m" :: !profargs ;; let optlist = ("-P", Arg.String add_profarg, "[afilmt] Profile constructs specified by argument (default fm):\n\ \032 a Everything\n\ \032 f Function calls and method calls\n\ \032 i if ... then ... else\n\ \032 l while and for loops\n\ \032 m match ... with\n\ \032 t try ... with") :: Options.list in Arg.parse optlist process_file usage; if !with_impl && !with_intf then begin fprintf stderr "ocamloptp cannot deal with both \"-impl\" and \"-intf\"\n"; fprintf stderr "please compile interfaces and implementations separately\n"; exit 2; end else if !with_impl && !with_mli then begin fprintf stderr "ocamloptp cannot deal with both \"-impl\" and .mli files\n"; fprintf stderr "please compile interfaces and implementations separately\n"; exit 2; end else if !with_intf && !with_ml then begin fprintf stderr "ocamloptp cannot deal with both \"-intf\" and .ml files\n"; fprintf stderr "please compile interfaces and implementations separately\n"; exit 2; end; if !with_impl then profargs := "-impl" :: !profargs; if !with_intf then profargs := "-intf" :: !profargs; let status = Sys.command (Printf.sprintf "ocamlopt -pp \"ocamlprof -instrument %s\" %s %s" (String.concat " " (List.rev !profargs)) (if !make_archive then "" else "profiling.cmx") (String.concat " " (List.rev !compargs))) in exit status ;; mingw-ocaml/ocaml/tools/Makefile.nt0000644000175000017500000000217512124403240016702 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # $Id$ include Makefile.shared # To make custom toplevels OCAMLMKTOP=ocamlmktop.cmo OCAMLMKTOP_IMPORTS=misc.cmo config.cmo clflags.cmo ccomp.cmo ocamlmktop: $(OCAMLMKTOP) $(CAMLC) $(LINKFLAGS) -o ocamlmktop $(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP) install:: cp ocamlmktop $(BINDIR)/ocamlmktop$(EXE) clean:: rm -f ocamlmktop$(EXE) mingw-ocaml/ocaml/tools/ocamlcp.ml0000644000175000017500000001241412124403240016567 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Printf let compargs = ref ([] : string list) let profargs = ref ([] : string list) let toremove = ref ([] : string list) let option opt () = compargs := opt :: !compargs let option_with_arg opt arg = compargs := (Filename.quote arg) :: opt :: !compargs ;; let make_archive = ref false;; let with_impl = ref false;; let with_intf = ref false;; let with_mli = ref false;; let with_ml = ref false;; let process_file filename = if Filename.check_suffix filename ".ml" then with_ml := true; if Filename.check_suffix filename ".mli" then with_mli := true; compargs := (Filename.quote filename) :: !compargs ;; let usage = "Usage: ocamlcp \noptions are:" let incompatible o = fprintf stderr "ocamlcp: profiling is incompatible with the %s option\n" o; exit 2 module Options = Main_args.Make_bytecomp_options (struct let _a () = make_archive := true; option "-a" () let _absname = option "-absname" let _annot = option "-annot" let _binannot = option "-bin-annot" let _c = option "-c" let _cc s = option_with_arg "-cc" s let _cclib s = option_with_arg "-cclib" s let _ccopt s = option_with_arg "-ccopt" s let _config = option "-config" let _custom = option "-custom" let _dllib = option_with_arg "-dllib" let _dllpath = option_with_arg "-dllpath" let _dtypes = option "-dtypes" let _g = option "-g" let _i = option "-i" let _I s = option_with_arg "-I" s let _impl s = with_impl := true; option_with_arg "-impl" s let _intf s = with_intf := true; option_with_arg "-intf" s let _intf_suffix s = option_with_arg "-intf-suffix" s let _labels = option "-labels" let _linkall = option "-linkall" let _make_runtime = option "-make-runtime" let _no_app_funct = option "-no-app-funct" let _noassert = option "-noassert" let _nolabels = option "-nolabels" let _noautolink = option "-noautolink" let _nostdlib = option "-nostdlib" let _o s = option_with_arg "-o" s let _output_obj = option "-output-obj" let _pack = option "-pack" let _pp s = incompatible "-pp" let _principal = option "-principal" let _rectypes = option "-rectypes" let _runtime_variant s = option_with_arg "-runtime-variant" s let _strict_sequence = option "-strict-sequence" let _thread () = option "-thread" () let _vmthread () = option "-vmthread" () let _unsafe = option "-unsafe" let _use_prims s = option_with_arg "-use-prims" s let _use_runtime s = option_with_arg "-use-runtime" s let _v = option "-v" let _version = option "-version" let _vnum = option "-vnum" let _verbose = option "-verbose" let _w = option_with_arg "-w" let _warn_error = option_with_arg "-warn-error" let _warn_help = option "-warn-help" let _where = option "-where" let _nopervasives = option "-nopervasives" let _dparsetree = option "-dparsetree" let _drawlambda = option "-drawlambda" let _dlambda = option "-dlambda" let _dinstr = option "-dinstr" let anonymous = process_file end);; let add_profarg s = profargs := (Filename.quote s) :: "-m" :: !profargs ;; let optlist = ("-P", Arg.String add_profarg, "[afilmt] Profile constructs specified by argument (default fm):\n\ \032 a Everything\n\ \032 f Function calls and method calls\n\ \032 i if ... then ... else\n\ \032 l while and for loops\n\ \032 m match ... with\n\ \032 t try ... with") :: ("-p", Arg.String add_profarg, "[afilmt] Same as option -P") :: Options.list in Arg.parse optlist process_file usage; if !with_impl && !with_intf then begin fprintf stderr "ocamlcp cannot deal with both \"-impl\" and \"-intf\"\n"; fprintf stderr "please compile interfaces and implementations separately\n"; exit 2; end else if !with_impl && !with_mli then begin fprintf stderr "ocamlcp cannot deal with both \"-impl\" and .mli files\n"; fprintf stderr "please compile interfaces and implementations separately\n"; exit 2; end else if !with_intf && !with_ml then begin fprintf stderr "ocamlcp cannot deal with both \"-intf\" and .ml files\n"; fprintf stderr "please compile interfaces and implementations separately\n"; exit 2; end; if !with_impl then profargs := "-impl" :: !profargs; if !with_intf then profargs := "-intf" :: !profargs; let status = Sys.command (Printf.sprintf "ocamlc -pp \"ocamlprof -instrument %s\" %s %s" (String.concat " " (List.rev !profargs)) (if !make_archive then "" else "profiling.cmo") (String.concat " " (List.rev !compargs))) in exit status ;; mingw-ocaml/ocaml/tools/read_cmt.ml0000644000175000017500000000671712124403240016740 0ustar tootstoots(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Fabrice Le Fessant, INRIA Saclay *) (* *) (* Copyright 2012 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) let gen_annot = ref false let gen_ml = ref false let print_info_arg = ref false let target_filename = ref None let arg_list = [ "-o", Arg.String (fun s -> target_filename := Some s ), " FILE (or -) : dump to file FILE (or stdout)"; "-annot", Arg.Set gen_annot, " : generate the corresponding .annot file"; "-src", Arg.Set gen_ml, " : generate an equivalent of the original source file (without comments) from a .cmt or a .cmti file"; "-info", Arg.Set print_info_arg, " : print information on the file"; ] let arg_usage = "read_cmt [OPTIONS] FILE.cmt : read FILE.cmt and print related information" let print_info cmt = let open Cmt_format in Printf.printf "module name: %s\n" cmt.cmt_modname; begin match cmt.cmt_annots with Packed (_, list) -> Printf.printf "pack: %s\n" (String.concat " " list) | Implementation _ -> Printf.printf "kind: implementation\n" | Interface _ -> Printf.printf "kind: interface\n" | Partial_implementation _ -> Printf.printf "kind: implementation with errors\n" | Partial_interface _ -> Printf.printf "kind: interface with errors\n" end; Printf.printf "command: %s\n" (String.concat " " (Array.to_list cmt.cmt_args)); begin match cmt.cmt_sourcefile with None -> () | Some name -> Printf.printf "sourcefile: %s\n" name; end; Printf.printf "build directory: %s\n" cmt.cmt_builddir; List.iter (fun dir -> Printf.printf "load path: %s\n%!" dir) cmt.cmt_loadpath; begin match cmt.cmt_source_digest with None -> () | Some digest -> Printf.printf "source digest: %s\n" (Digest.to_hex digest); end; begin match cmt.cmt_interface_digest with None -> () | Some digest -> Printf.printf "interface digest: %s\n" (Digest.to_hex digest); end; List.iter (fun (name, digest) -> Printf.printf "import: %s %s\n" name (Digest.to_hex digest); ) (List.sort compare cmt.cmt_imports); Printf.printf "%!"; () let _ = Clflags.annotations := true; Arg.parse arg_list (fun filename -> if Filename.check_suffix filename ".cmt" || Filename.check_suffix filename ".cmti" then begin (* init_path(); *) let cmt = Cmt_format.read_cmt filename in if !gen_annot then Cmt2annot.gen_annot !target_filename filename cmt; if !gen_ml then Cmt2annot.gen_ml !target_filename filename cmt; if !print_info_arg || not (!gen_ml || !gen_annot) then print_info cmt; end else begin Printf.fprintf stderr "Error: the file must have an extension in .cmt or .cmti.\n%!"; Arg.usage arg_list arg_usage end ) arg_usage mingw-ocaml/ocaml/tools/cmt2annot.ml0000644000175000017500000002127712124403240017065 0ustar tootstoots(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Fabrice Le Fessant, INRIA Saclay *) (* *) (* Copyright 2012 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Generate .annot file from a .types files. *) open Typedtree open TypedtreeIter let pattern_scopes = ref [] let push_None () = pattern_scopes := None :: !pattern_scopes let push_Some annot = pattern_scopes := (Some annot) :: !pattern_scopes let pop_scope () = match !pattern_scopes with [] -> assert false | _ :: scopes -> pattern_scopes := scopes module ForIterator = struct open Asttypes include DefaultIteratorArgument let structure_begin_scopes = ref [] let structure_end_scopes = ref [] let rec find_last list = match list with [] -> assert false | [x] -> x | _ :: tail -> find_last tail let enter_structure str = match str.str_items with [] -> () | _ -> let loc = match !structure_end_scopes with [] -> Location.none | _ -> let s = find_last str.str_items in s.str_loc in structure_end_scopes := loc :: !structure_end_scopes; let rec iter list = match list with [] -> assert false | [ { str_desc = Tstr_value (Nonrecursive, _); str_loc = loc } ] -> structure_begin_scopes := loc.Location.loc_end :: !structure_begin_scopes | [ _ ] -> () | item :: tail -> iter tail; match item, tail with { str_desc = Tstr_value (Nonrecursive,_) }, { str_loc = loc } :: _ -> structure_begin_scopes := loc.Location.loc_start :: !structure_begin_scopes | _ -> () in iter str.str_items let leave_structure str = match str.str_items with [] -> () | _ -> match !structure_end_scopes with [] -> assert false | _ :: scopes -> structure_end_scopes := scopes let enter_class_expr node = Stypes.record (Stypes.Ti_class node) let enter_module_expr node = Stypes.record (Stypes.Ti_mod node) let add_variable pat id = match !pattern_scopes with | [] -> assert false | None :: _ -> () | (Some s) :: _ -> Stypes.record (Stypes.An_ident (pat.pat_loc, Ident.name id, s)) let enter_pattern pat = match pat.pat_desc with | Tpat_var (id, _) | Tpat_alias (_, id,_) -> add_variable pat id | Tpat_any -> () | Tpat_constant _ | Tpat_tuple _ | Tpat_construct _ | Tpat_lazy _ | Tpat_or _ | Tpat_array _ | Tpat_record _ | Tpat_variant _ -> () let leave_pattern pat = Stypes.record (Stypes.Ti_pat pat) let rec name_of_path = function | Path.Pident id -> Ident.name id | Path.Pdot(p, s, pos) -> if Oprint.parenthesized_ident s then name_of_path p ^ ".( " ^ s ^ " )" else name_of_path p ^ "." ^ s | Path.Papply(p1, p2) -> name_of_path p1 ^ "(" ^ name_of_path p2 ^ ")" let enter_expression exp = match exp.exp_desc with Texp_ident (path, _, _) -> let full_name = name_of_path path in begin try let annot = Env.find_annot path exp.exp_env in Stypes.record (Stypes.An_ident (exp.exp_loc, full_name , annot)) with Not_found -> Stypes.record (Stypes.An_ident (exp.exp_loc, full_name , Annot.Iref_external)) end | Texp_let (rec_flag, _, body) -> begin match rec_flag with | Recursive -> push_Some (Annot.Idef exp.exp_loc) | Nonrecursive -> push_Some (Annot.Idef body.exp_loc) | Default -> push_None () end | Texp_function _ -> push_None () | Texp_match _ -> push_None () | Texp_try _ -> push_None () | _ -> () let leave_expression exp = if not exp.exp_loc.Location.loc_ghost then Stypes.record (Stypes.Ti_expr exp); match exp.exp_desc with | Texp_let _ | Texp_function _ | Texp_match _ | Texp_try _ -> pop_scope () | _ -> () let enter_binding pat exp = let scope = match !pattern_scopes with | [] -> assert false | None :: _ -> Some (Annot.Idef exp.exp_loc) | scope :: _ -> scope in pattern_scopes := scope :: !pattern_scopes let leave_binding _ _ = pop_scope () let enter_class_expr exp = match exp.cl_desc with | Tcl_fun _ -> push_None () | Tcl_let _ -> push_None () | _ -> () let leave_class_expr exp = match exp.cl_desc with | Tcl_fun _ | Tcl_let _ -> pop_scope () | _ -> () let enter_class_structure _ = push_None () let leave_class_structure _ = pop_scope () (* let enter_class_field cf = match cf.cf_desc with Tcf_let _ -> push_None () | _ -> () let leave_class_field cf = match cf.cf_desc with Tcf_let _ -> pop_scope () | _ -> () *) let enter_structure_item s = Stypes.record_phrase s.str_loc; match s.str_desc with Tstr_value (rec_flag, _) -> begin let loc = s.str_loc in let scope = match !structure_end_scopes with [] -> assert false | scope :: _ -> scope in match rec_flag with | Recursive -> push_Some (Annot.Idef { scope with Location.loc_start = loc.Location.loc_start}) | Nonrecursive -> (* TODO: do it lazily, when we start the next element ! *) (* let start = match srem with | [] -> loc.Location.loc_end | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start in *) let start = match !structure_begin_scopes with [] -> assert false | loc :: tail -> structure_begin_scopes := tail; loc in push_Some (Annot.Idef {scope with Location.loc_start = start}) | Default -> push_None () end | _ -> () let leave_structure_item s = match s.str_desc with Tstr_value _ -> pop_scope () | _ -> () end module Iterator = MakeIterator(ForIterator) let gen_annot target_filename filename cmt = match cmt.Cmt_format.cmt_annots with Cmt_format.Implementation typedtree -> Iterator.iter_structure typedtree; let target_filename = match target_filename with None -> Some (filename ^ ".annot") | Some "-" -> None | Some filename -> target_filename in Stypes.dump target_filename | Cmt_format.Interface _ -> Printf.fprintf stderr "Cannot generate annotations for interface file\n%!"; exit 2 | _ -> Printf.fprintf stderr "File was generated with an error\n%!"; exit 2 let gen_ml target_filename filename cmt = let (printer, ext) = match cmt.Cmt_format.cmt_annots with | Cmt_format.Implementation typedtree -> (fun ppf -> Pprintast.print_structure ppf (Untypeast.untype_structure typedtree)), ".ml" | Cmt_format.Interface typedtree -> (fun ppf -> Pprintast.print_signature ppf (Untypeast.untype_signature typedtree)), ".mli" | _ -> Printf.fprintf stderr "File was generated with an error\n%!"; exit 2 in let target_filename = match target_filename with None -> Some (filename ^ ext) | Some "-" -> None | Some filename -> target_filename in let oc = match target_filename with None -> None | Some filename -> Some (open_out filename) in let ppf = match oc with None -> Format.std_formatter | Some oc -> Format.formatter_of_out_channel oc in printer ppf; Format.pp_print_flush ppf (); match oc with None -> flush stdout | Some oc -> close_out oc mingw-ocaml/ocaml/tools/typedtreeIter.mli0000644000175000017500000001035512124403240020155 0ustar tootstoots(**************************************************************************) (* *) (* OCaml *) (* *) (* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (**************************************************************************) open Asttypes open Typedtree module type IteratorArgument = sig val enter_structure : structure -> unit val enter_value_description : value_description -> unit val enter_type_declaration : type_declaration -> unit val enter_exception_declaration : exception_declaration -> unit val enter_pattern : pattern -> unit val enter_expression : expression -> unit val enter_package_type : package_type -> unit val enter_signature : signature -> unit val enter_signature_item : signature_item -> unit val enter_modtype_declaration : modtype_declaration -> unit val enter_module_type : module_type -> unit val enter_module_expr : module_expr -> unit val enter_with_constraint : with_constraint -> unit val enter_class_expr : class_expr -> unit val enter_class_signature : class_signature -> unit val enter_class_declaration : class_declaration -> unit val enter_class_description : class_description -> unit val enter_class_type_declaration : class_type_declaration -> unit val enter_class_type : class_type -> unit val enter_class_type_field : class_type_field -> unit val enter_core_type : core_type -> unit val enter_core_field_type : core_field_type -> unit val enter_class_structure : class_structure -> unit val enter_class_field : class_field -> unit val enter_structure_item : structure_item -> unit val leave_structure : structure -> unit val leave_value_description : value_description -> unit val leave_type_declaration : type_declaration -> unit val leave_exception_declaration : exception_declaration -> unit val leave_pattern : pattern -> unit val leave_expression : expression -> unit val leave_package_type : package_type -> unit val leave_signature : signature -> unit val leave_signature_item : signature_item -> unit val leave_modtype_declaration : modtype_declaration -> unit val leave_module_type : module_type -> unit val leave_module_expr : module_expr -> unit val leave_with_constraint : with_constraint -> unit val leave_class_expr : class_expr -> unit val leave_class_signature : class_signature -> unit val leave_class_declaration : class_declaration -> unit val leave_class_description : class_description -> unit val leave_class_type_declaration : class_type_declaration -> unit val leave_class_type : class_type -> unit val leave_class_type_field : class_type_field -> unit val leave_core_type : core_type -> unit val leave_core_field_type : core_field_type -> unit val leave_class_structure : class_structure -> unit val leave_class_field : class_field -> unit val leave_structure_item : structure_item -> unit val enter_bindings : rec_flag -> unit val enter_binding : pattern -> expression -> unit val leave_binding : pattern -> expression -> unit val leave_bindings : rec_flag -> unit end module MakeIterator : functor (Iter : IteratorArgument) -> sig val iter_structure : structure -> unit val iter_signature : signature -> unit val iter_structure_item : structure_item -> unit val iter_signature_item : signature_item -> unit val iter_expression : expression -> unit val iter_module_type : module_type -> unit val iter_pattern : pattern -> unit val iter_class_expr : class_expr -> unit end module DefaultIteratorArgument : IteratorArgument mingw-ocaml/ocaml/tools/setignore0000755000175000017500000000203012124403240016535 0ustar tootstoots#!/bin/sh ######################################################################### # # # OCaml # # # # Damien Doligez, projet Gallium, INRIA Rocquencourt # # # # Copyright 2011 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### ( cat < raise (Closing token) | EOF -> raise End_of_file | _ -> (token, start, stop) in let openunix = ref None and openstd = ref None and openmore = ref None in let rec may_start (token, s, e) = match token with LIDENT _ -> search_start (dropext (next_token ())) | UIDENT m when List.mem m !modules -> may_discard (dropext (next_token ())) | UIDENT m -> List.iter ~f: (fun (set,r) -> if !r = None && List.mem m ~set then r := Some true) [stdlabels, openstd; ["Unix"], openunix; morelabels, openmore]; search_start (next_token ()) | _ -> search_start (token, s, e) and dropext (token, s, e) = match token with DOT -> let (token, s, e) = next_token () in begin match token with LPAREN | LBRACKET | LBRACE -> process_paren (token, s, e); dropext (next_token ()) | UIDENT _ | LIDENT _ -> dropext (next_token ()) | _ -> prerr_endline ("bad index at position " ^ string_of_int s); (token, s, e) end | _ -> (token, s, e) and may_discard (token, s, e) = match token with TILDE | LABEL _ -> modified := true; copy_input s; input_pos := e; may_discard (next_token ()) | _ when !alllabels -> may_discard (next_token ()) | LPAREN | LBRACKET | LBRACKETBAR | LBRACKETLESS | BEGIN | LBRACE | LBRACELESS | STRUCT | SIG | OBJECT-> process_paren (token, s, e); may_discard (next_token ()) | PREFIXOP _ -> may_discard (next_token ()) | LIDENT _ | UIDENT _ -> may_discard (dropext (next_token ())) | BACKQUOTE -> ignore (next_token ()); may_discard (next_token ()) | INT _ | CHAR _ | STRING _ | FLOAT _ | FALSE | TRUE -> may_discard (next_token ()) | _ -> search_start (token, s, e) and search_start (token, s, e) = match token with LPAREN | LBRACKET | LBRACKETBAR | LBRACKETLESS | BEGIN | LBRACE | LBRACELESS | STRUCT | SIG | OBJECT -> process_paren (token, s, e); search_start (next_token ()) | EQUAL | SEMI | SEMISEMI | MINUSGREATER | LESSMINUS | COMMA | IF | THEN | ELSE | WHILE | TO | DOWNTO | DO | IN | MATCH | TRY | INFIXOP0 _ | INFIXOP1 _ | INFIXOP2 _ | INFIXOP3 _ | INFIXOP4 _ | PLUS | MINUS | MINUSDOT | STAR | LESS | GREATER | OR | BARBAR | AMPERSAND | AMPERAMPER | COLONEQUAL -> may_start (next_token ()) | OPEN -> begin match next_token () with | UIDENT m, _, _ -> List.iter ~f:(fun (set,r) -> if List.mem m ~set then r := Some false) [stdlabels, openstd; ["Unix"], openunix; morelabels, openmore] | _ -> () end; search_start (next_token ()) | _ -> search_start (next_token ()) and process_paren (token, s, e) = try match token with LPAREN | LBRACKET | LBRACKETBAR | LBRACKETLESS | BEGIN -> may_start (next_token ()) | LBRACE | LBRACELESS | STRUCT | SIG | OBJECT -> search_start (next_token ()) | _ -> assert false with Closing last -> match token, last with LPAREN, RPAREN | (LBRACKET|LBRACKETBAR|LBRACKETLESS), (RBRACKET|BARRBRACKET|GREATERRBRACKET) | (BEGIN|STRUCT|SIG|OBJECT), END | LBRACE, RBRACE | LBRACELESS, GREATERRBRACE -> () | _ -> raise (Closing last) in let first = next_token () in try if !alllabels then may_discard first else may_start first with End_of_file -> copy_input (Buffer.length input_buffer); if not !alllabels && List.exists (fun r -> !r = Some true) [openstd; openunix; openmore] then begin modified := true; let text = Buffer.contents output_buffer in Buffer.clear output_buffer; let (token, s, _) = first in Buffer.add_substring output_buffer text 0 s; List.iter ~f: (fun (r, s) -> if !r = Some true then Buffer.add_string output_buffer s) [ openstd, "open StdLabels\n"; openmore, "open MoreLabels\n"; openunix, "module Unix = UnixLabels\n" ]; let sep = if List.mem token [CLASS; EXTERNAL; EXCEPTION; FUNCTOR; LET; MODULE; FUNCTOR; TYPE; VAL] then "\n" else if token = OPEN then "" else ";;\n\n" in Buffer.add_string output_buffer sep; Buffer.add_substring output_buffer text s (String.length text - s) end | Closing _ -> prerr_endline ("bad closing token at position " ^ string_of_int (Lexing.lexeme_start buffer)); modified := false type state = Out | Enter | In | Escape let convert_intf buffer = let input_pos = ref 0 in let copy_input stop = Buffer.add_substring output_buffer (Buffer.contents input_buffer) !input_pos (stop - !input_pos); input_pos := stop in let last = ref (EOF, 0, 0) in let state = ref Out in try while true do let token = Lexer301.token buffer and start = Lexing.lexeme_start buffer and stop = Lexing.lexeme_end buffer and last_token, last_start, last_stop = !last in begin match token with | EXCEPTION | CONSTRAINT -> state := In | VAL | EXTERNAL | CLASS | METHOD | TYPE | AND -> state := Enter | EQUAL when !state = Enter -> state := In | COLON -> begin match !state, last_token with | In, LIDENT _ -> modified := true; copy_input last_start; input_pos := stop | Enter, _ -> state := In | Escape, _ -> state := In | _ -> state := Out end | LBRACE | SEMI | QUESTION when !state = In -> state := Escape | SEMISEMI | SIG | STRUCT | END | OBJECT | OPEN | INCLUDE | MODULE -> state := Out | EOF -> raise End_of_file | _ -> () end; last := (token, start, stop) done with End_of_file -> copy_input (Buffer.length input_buffer) let convert_file ~intf name = let ic = open_in name in Buffer.clear input_buffer; Buffer.clear output_buffer; modified := false; begin let convert = if intf then convert_intf else convert_impl in try convert (Lexing.from_function (input_function ic)); close_in ic with exn -> close_in ic; raise exn end; if !modified then begin let backup = name ^ ".bak" in if Sys.file_exists backup then Sys.remove name else Sys.rename name backup; let oc = open_out name in Buffer.output_buffer oc output_buffer; close_out oc end else prerr_endline ("No changes in " ^ name) let _ = let files = ref [] and intf = ref false and keepstd = ref false and keepmore = ref false in Arg.parse [ "-intf", Arg.Set intf, " remove all non-optional labels from an interface;\n" ^ " other options are ignored"; "-all", Arg.Set alllabels, " remove all labels, possibly including optional ones!"; "-keepstd", Arg.Set keepstd, " keep labels for Array, List, String and Unix"; "-keepmore", Arg.Set keepmore, " keep also labels for Hashtbl, Map and Set; implies -keepstd"; "-m", Arg.String (fun s -> modules := s :: !modules), " remove also labels for "; "-noopen", Arg.Set noopen, " do not insert `open' statements for -keepstd/-keepmore" ] (fun s -> files := s :: !files) ("Usage: scrapelabels \n" ^ " Remove labels from function arguments in standard library modules.\n" ^ " With -intf option below, can also process interfaces.\n" ^ " Old files are renamed to .bak if there is no backup yet.\n" ^ "Options are:"); if !keepmore then keepstd := true; if not !keepstd then modules := "Unix" :: stdlabels @ !modules; if not !keepmore then modules := morelabels @ !modules; List.iter (List.rev !files) ~f: begin fun name -> prerr_endline ("Processing " ^ name); Printexc.catch (convert_file ~intf:!intf) name end mingw-ocaml/ocaml/tools/depend.mli0000644000175000017500000000207612124403240016564 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Module dependencies. *) module StringSet : Set.S with type elt = string val free_structure_names : StringSet.t ref val add_use_file : StringSet.t -> Parsetree.toplevel_phrase list -> unit val add_signature : StringSet.t -> Parsetree.signature -> unit mingw-ocaml/ocaml/tools/ocamlmktop.ml0000644000175000017500000000201712124403240017315 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) let _ = let args = Ccomp.quote_files (List.tl (Array.to_list Sys.argv)) in exit(Sys.command("ocamlc -I +compiler-libs -linkall ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma " ^ args ^ " topstart.cmo")) mingw-ocaml/ocaml/tools/ocamlmktop.tpl0000644000175000017500000000167112124403240017511 0ustar tootstoots#!/bin/sh ######################################################################### # # # OCaml # # # # Damien Doligez, projet Para, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # $Id$ exec %%BINDIR%%/ocamlc -I +compiler-libs -linkall ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma "$@" topstart.cmo mingw-ocaml/ocaml/tools/ocamlprof.ml0000644000175000017500000003433012124403240017134 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez and Francois Rouaix, INRIA Rocquencourt *) (* Ported to Caml Special Light by John Malecki *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Printf open Clflags open Config open Location open Misc open Parsetree (* User programs must not use identifiers that start with these prefixes. *) let idprefix = "__ocaml_prof_";; let modprefix = "OCAML__prof_";; (* Errors specific to the profiler *) exception Profiler of string (* Modes *) let instr_fun = ref false and instr_match = ref false and instr_if = ref false and instr_loops = ref false and instr_try = ref false let cur_point = ref 0 and inchan = ref stdin and outchan = ref stdout (* To copy source fragments *) let copy_buffer = String.create 256 let copy_chars_unix nchars = let n = ref nchars in while !n > 0 do let m = input !inchan copy_buffer 0 (min !n 256) in if m = 0 then raise End_of_file; output !outchan copy_buffer 0 m; n := !n - m done let copy_chars_win32 nchars = for i = 1 to nchars do let c = input_char !inchan in if c <> '\r' then output_char !outchan c done let copy_chars = match Sys.os_type with "Win32" | "Cygwin" -> copy_chars_win32 | _ -> copy_chars_unix let copy next = assert (next >= !cur_point); seek_in !inchan !cur_point; copy_chars (next - !cur_point); cur_point := next; ;; let prof_counter = ref 0;; let instr_mode = ref false type insert = Open | Close;; let to_insert = ref ([] : (insert * int) list);; let insert_action st en = to_insert := (Open, st) :: (Close, en) :: !to_insert ;; (* Producing instrumented code *) let add_incr_counter modul (kind,pos) = copy pos; match kind with | Open -> fprintf !outchan "(%sProfiling.incr %s%s_cnt %d; " modprefix idprefix modul !prof_counter; incr prof_counter; | Close -> fprintf !outchan ")"; ;; let counters = ref (Array.create 0 0) (* User defined marker *) let special_id = ref "" (* Producing results of profile run *) let add_val_counter (kind,pos) = if kind = Open then begin copy pos; fprintf !outchan "(* %s%d *) " !special_id !counters.(!prof_counter); incr prof_counter; end ;; (* ************* rewrite ************* *) let insert_profile rw_exp ex = let st = ex.pexp_loc.loc_start.Lexing.pos_cnum and en = ex.pexp_loc.loc_end.Lexing.pos_cnum and gh = ex.pexp_loc.loc_ghost in if gh || st = en then rw_exp true ex else begin insert_action st en; rw_exp false ex; end ;; let pos_len = ref 0 let init_rewrite modes mod_name = cur_point := 0; if !instr_mode then begin fprintf !outchan "module %sProfiling = Profiling;; " modprefix; fprintf !outchan "let %s%s_cnt = Array.create 000000000" idprefix mod_name; pos_len := pos_out !outchan; fprintf !outchan " 0;; Profiling.counters := \ (\"%s\", (\"%s\", %s%s_cnt)) :: !Profiling.counters;; " mod_name modes idprefix mod_name; end let final_rewrite add_function = to_insert := Sort.list (fun x y -> snd x < snd y) !to_insert; prof_counter := 0; List.iter add_function !to_insert; copy (in_channel_length !inchan); if !instr_mode then begin let len = string_of_int !prof_counter in if String.length len > 9 then raise (Profiler "too many counters"); seek_out !outchan (!pos_len - String.length len); output_string !outchan len end; (* Cannot close because outchan is stdout and Format doesn't like a closed stdout. close_out !outchan; *) ;; let rec rewrite_patexp_list iflag l = rewrite_exp_list iflag (List.map snd l) and rewrite_patlexp_list iflag l = rewrite_exp_list iflag (List.map snd l) and rewrite_labelexp_list iflag l = rewrite_exp_list iflag (List.map snd l) and rewrite_exp_list iflag l = List.iter (rewrite_exp iflag) l and rewrite_exp iflag sexp = if iflag then insert_profile rw_exp sexp else rw_exp false sexp and rw_exp iflag sexp = match sexp.pexp_desc with Pexp_ident lid -> () | Pexp_constant cst -> () | Pexp_let(_, spat_sexp_list, sbody) -> rewrite_patexp_list iflag spat_sexp_list; rewrite_exp iflag sbody | Pexp_function (_, _, caselist) -> if !instr_fun then rewrite_function iflag caselist else rewrite_patlexp_list iflag caselist | Pexp_match(sarg, caselist) -> rewrite_exp iflag sarg; if !instr_match && not sexp.pexp_loc.loc_ghost then rewrite_funmatching caselist else rewrite_patlexp_list iflag caselist | Pexp_try(sbody, caselist) -> rewrite_exp iflag sbody; if !instr_try && not sexp.pexp_loc.loc_ghost then rewrite_trymatching caselist else rewrite_patexp_list iflag caselist | Pexp_apply(sfunct, sargs) -> rewrite_exp iflag sfunct; rewrite_exp_list iflag (List.map snd sargs) | Pexp_tuple sexpl -> rewrite_exp_list iflag sexpl | Pexp_construct(_, None, _) -> () | Pexp_construct(_, Some sarg, _) -> rewrite_exp iflag sarg | Pexp_variant(_, None) -> () | Pexp_variant(_, Some sarg) -> rewrite_exp iflag sarg | Pexp_record(lid_sexp_list, None) -> rewrite_labelexp_list iflag lid_sexp_list | Pexp_record(lid_sexp_list, Some sexp) -> rewrite_exp iflag sexp; rewrite_labelexp_list iflag lid_sexp_list | Pexp_field(sarg, _) -> rewrite_exp iflag sarg | Pexp_setfield(srecord, _, snewval) -> rewrite_exp iflag srecord; rewrite_exp iflag snewval | Pexp_array(sargl) -> rewrite_exp_list iflag sargl | Pexp_ifthenelse(scond, sifso, None) -> rewrite_exp iflag scond; rewrite_ifbody iflag sexp.pexp_loc.loc_ghost sifso | Pexp_ifthenelse(scond, sifso, Some sifnot) -> rewrite_exp iflag scond; rewrite_ifbody iflag sexp.pexp_loc.loc_ghost sifso; rewrite_ifbody iflag sexp.pexp_loc.loc_ghost sifnot | Pexp_sequence(sexp1, sexp2) -> rewrite_exp iflag sexp1; rewrite_exp iflag sexp2 | Pexp_while(scond, sbody) -> rewrite_exp iflag scond; if !instr_loops && not sexp.pexp_loc.loc_ghost then insert_profile rw_exp sbody else rewrite_exp iflag sbody | Pexp_for(_, slow, shigh, _, sbody) -> rewrite_exp iflag slow; rewrite_exp iflag shigh; if !instr_loops && not sexp.pexp_loc.loc_ghost then insert_profile rw_exp sbody else rewrite_exp iflag sbody | Pexp_constraint(sarg, _, _) -> rewrite_exp iflag sarg | Pexp_when(scond, sbody) -> rewrite_exp iflag scond; rewrite_exp iflag sbody | Pexp_send (sobj, _) -> rewrite_exp iflag sobj | Pexp_new _ -> () | Pexp_setinstvar (_, sarg) -> rewrite_exp iflag sarg | Pexp_override l -> List.iter (fun (_, sexp) -> rewrite_exp iflag sexp) l | Pexp_letmodule (_, smod, sexp) -> rewrite_mod iflag smod; rewrite_exp iflag sexp | Pexp_assert (cond) -> rewrite_exp iflag cond | Pexp_assertfalse -> () | Pexp_lazy (expr) -> rewrite_exp iflag expr | Pexp_poly (sexp, _) -> rewrite_exp iflag sexp | Pexp_object cl -> List.iter (rewrite_class_field iflag) cl.pcstr_fields | Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp | Pexp_open (_, e) -> rewrite_exp iflag e | Pexp_pack (smod) -> rewrite_mod iflag smod and rewrite_ifbody iflag ghost sifbody = if !instr_if && not ghost then insert_profile rw_exp sifbody else rewrite_exp iflag sifbody (* called only when !instr_fun *) and rewrite_annotate_exp_list l = List.iter (function | {pexp_desc = Pexp_when(scond, sbody)} -> insert_profile rw_exp scond; insert_profile rw_exp sbody; | {pexp_desc = Pexp_constraint(sbody, _, _)} (* let f x : t = e *) -> insert_profile rw_exp sbody | sexp -> insert_profile rw_exp sexp) l and rewrite_function iflag = function | [spat, ({pexp_desc = Pexp_function _} as sexp)] -> rewrite_exp iflag sexp | l -> rewrite_funmatching l and rewrite_funmatching l = rewrite_annotate_exp_list (List.map snd l) and rewrite_trymatching l = rewrite_annotate_exp_list (List.map snd l) (* Rewrite a class definition *) and rewrite_class_field iflag cf = match cf.pcf_desc with Pcf_inher (_, cexpr, _) -> rewrite_class_expr iflag cexpr | Pcf_val (_, _, _, sexp) -> rewrite_exp iflag sexp | Pcf_meth (_, _, _, ({pexp_desc = Pexp_function _} as sexp)) -> rewrite_exp iflag sexp | Pcf_meth (_, _, _, sexp) -> let loc = cf.pcf_loc in if !instr_fun && not loc.loc_ghost then insert_profile rw_exp sexp else rewrite_exp iflag sexp | Pcf_init sexp -> rewrite_exp iflag sexp | Pcf_valvirt _ | Pcf_virt _ | Pcf_constr _ -> () and rewrite_class_expr iflag cexpr = match cexpr.pcl_desc with Pcl_constr _ -> () | Pcl_structure st -> List.iter (rewrite_class_field iflag) st.pcstr_fields | Pcl_fun (_, _, _, cexpr) -> rewrite_class_expr iflag cexpr | Pcl_apply (cexpr, exprs) -> rewrite_class_expr iflag cexpr; List.iter (rewrite_exp iflag) (List.map snd exprs) | Pcl_let (_, spat_sexp_list, cexpr) -> rewrite_patexp_list iflag spat_sexp_list; rewrite_class_expr iflag cexpr | Pcl_constraint (cexpr, _) -> rewrite_class_expr iflag cexpr and rewrite_class_declaration iflag cl = rewrite_class_expr iflag cl.pci_expr (* Rewrite a module expression or structure expression *) and rewrite_mod iflag smod = match smod.pmod_desc with Pmod_ident lid -> () | Pmod_structure sstr -> List.iter (rewrite_str_item iflag) sstr | Pmod_functor(param, smty, sbody) -> rewrite_mod iflag sbody | Pmod_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2 | Pmod_constraint(smod, smty) -> rewrite_mod iflag smod | Pmod_unpack(sexp) -> rewrite_exp iflag sexp and rewrite_str_item iflag item = match item.pstr_desc with Pstr_eval exp -> rewrite_exp iflag exp | Pstr_value(_, exps) -> List.iter (function (_,exp) -> rewrite_exp iflag exp) exps | Pstr_module(name, smod) -> rewrite_mod iflag smod | Pstr_class classes -> List.iter (rewrite_class_declaration iflag) classes | _ -> () (* Rewrite a .ml file *) let rewrite_file srcfile add_function = inchan := open_in_bin srcfile; let lb = Lexing.from_channel !inchan in Location.input_name := srcfile; Location.init lb srcfile; List.iter (rewrite_str_item false) (Parse.implementation lb); final_rewrite add_function; close_in !inchan (* Copy a non-.ml file without change *) let null_rewrite srcfile = inchan := open_in_bin srcfile; copy (in_channel_length !inchan); close_in !inchan ;; (* Setting flags from saved config *) let set_flags s = for i = 0 to String.length s - 1 do match String.get s i with 'f' -> instr_fun := true | 'm' -> instr_match := true | 'i' -> instr_if := true | 'l' -> instr_loops := true | 't' -> instr_try := true | 'a' -> instr_fun := true; instr_match := true; instr_if := true; instr_loops := true; instr_try := true | _ -> () done (* Command-line options *) let modes = ref "fm" let dumpfile = ref "ocamlprof.dump" (* Process a file *) let process_intf_file filename = null_rewrite filename;; let process_impl_file filename = let modname = Filename.basename(Filename.chop_extension filename) in (* FIXME should let modname = String.capitalize modname *) if !instr_mode then begin (* Instrumentation mode *) set_flags !modes; init_rewrite !modes modname; rewrite_file filename (add_incr_counter modname); end else begin (* Results mode *) let ic = open_in_bin !dumpfile in let allcounters = (input_value ic : (string * (string * int array)) list) in close_in ic; let (modes, cv) = try List.assoc modname allcounters with Not_found -> raise(Profiler("Module " ^ modname ^ " not used in this profile.")) in counters := cv; set_flags modes; init_rewrite modes modname; rewrite_file filename add_val_counter; end ;; let process_anon_file filename = if Filename.check_suffix filename ".ml" then process_impl_file filename else process_intf_file filename ;; (* Main function *) open Format let usage = "Usage: ocamlprof \noptions are:" let print_version () = printf "ocamlprof, version %s@." Sys.ocaml_version; exit 0; ;; let print_version_num () = printf "%s@." Sys.ocaml_version; exit 0; ;; let main () = try Warnings.parse_options false "a"; Arg.parse [ "-f", Arg.String (fun s -> dumpfile := s), " Use as dump file (default ocamlprof.dump)"; "-F", Arg.String (fun s -> special_id := s), " Insert string with the counts"; "-impl", Arg.String process_impl_file, " Process as a .ml file"; "-instrument", Arg.Set instr_mode, " (undocumented)"; "-intf", Arg.String process_intf_file, " Process as a .mli file"; "-m", Arg.String (fun s -> modes := s), " (undocumented)"; "-version", Arg.Unit print_version, " Print version and exit"; "-vnum", Arg.Unit print_version_num, " Print version number and exit"; ] process_anon_file usage; exit 0 with x -> let report_error ppf = function | Lexer.Error(err, range) -> fprintf ppf "@[%a%a@]@." Location.print_error range Lexer.report_error err | Syntaxerr.Error err -> fprintf ppf "@[%a@]@." Syntaxerr.report_error err | Profiler msg -> fprintf ppf "@[%s@]@." msg | Sys_error msg -> fprintf ppf "@[I/O error:@ %s@]@." msg | x -> raise x in report_error Format.err_formatter x; exit 2 let _ = main () mingw-ocaml/ocaml/tools/pprintast.ml0000644000175000017500000020070712124403240017201 0ustar tootstoots(**************************************************************************) (* *) (* OCaml *) (* *) (* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (**************************************************************************) (* Original Code from Ber-metaocaml, modified fo 3.12.0 and fixed *) (* Printing code expressions *) (* Authors: Ed Pizzi, Fabrice Le Fessant *) open Asttypes open Format open Location open Lexing open Parsetree (* borrowed from printast.ml *) let fmt_position f l = if l.pos_fname = "" && l.pos_lnum = 1 then fprintf f "%d" l.pos_cnum else if l.pos_lnum = -1 then fprintf f "%s[%d]" l.pos_fname l.pos_cnum else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol (l.pos_cnum - l.pos_bol) ;; let fmt_location f loc = fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end; if loc.loc_ghost then fprintf f " ghost"; ;; let line i f s (*...*) = fprintf f "%s" (String.make (2*i) ' '); fprintf f s (*...*) ;; let label i ppf x = line i ppf "label=\"%s\"\n" x;; (* end borrowing *) let indent = 1 ;; (* standard indentation increment *) let bar_on_first_case = true ;; (* These sets of symbols are taken from the manual. However, it's unclear what the sets infix_symbols and prefix_symbols are for, as operator_chars, which contains their union seems to be the only set useful to determine whether an identifier is prefix or infix. The set postfix_chars I added, which is the set of characters allowed at the end of an identifier to allow for internal MetaOCaml variable renaming. *) let prefix_symbols = [ '!'; '?'; '~' ] ;; let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; '$'; '%' ] ;; let operator_chars = [ '!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?'; '@'; '^'; '|'; '~' ] ;; let numeric_chars = [ '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9' ] ;; type fixity = | Infix | Prefix ;; let is_infix fx = match fx with | Infix -> true | Prefix -> false ;; let special_infix_strings = ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!=" ] ;; (* let is_special_infix_string s = List.exists (fun x -> (x = s)) special_infix_strings ;; *) let is_in_list e l = List.exists (fun x -> (x = e)) l (* determines if the string is an infix string. checks backwards, first allowing a renaming postfix ("_102") which may have resulted from Pexp -> Texp -> Pexp translation, then checking if all the characters in the beginning of the string are valid infix characters. *) let fixity_of_string s = if ((is_in_list s special_infix_strings) || (is_in_list (String.get s 0) infix_symbols)) then Infix else Prefix let fixity_of_longident li = match li.txt with | Longident.Lident name -> fixity_of_string name (* This is wrong (and breaks RTT): | Longident.Ldot (_, name) when is_in_list name special_infix_strings -> Infix *) | _ -> Prefix ;; let fixity_of_exp e = match e.pexp_desc with | Pexp_ident (li) -> (fixity_of_longident li) (* | Pexp_cspval (_,li) -> if false (* default valu of !Clflags.prettycsp *) then (fixity_of_longident li) else Prefix *) | _ -> Prefix ;; let rec fmt_longident_aux f x = match x with | Longident.Lident s -> fprintf f "%s" s; | Longident.Ldot(y, s) when is_in_list s special_infix_strings -> fprintf f "%a.( %s )@ " fmt_longident_aux y s (* This is wrong (and breaks RTT): fprintf f "@ %s@ " s *) | Longident.Ldot (y, s) -> begin match s.[0] with 'a'..'z' | 'A'..'Z' -> fprintf f "%a.%s" fmt_longident_aux y s | _ -> fprintf f "%a.( %s )@ " fmt_longident_aux y s end | Longident.Lapply (y, z) -> fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; ;; let fmt_longident ppf x = fprintf ppf "%a" fmt_longident_aux x.txt;; let fmt_char f c = let i = int_of_char c in if (i < 32) || (i >= 128) then fprintf f "'\\%03d'" (Char.code c) else match c with '\'' | '\\' -> fprintf f "'\\%c'" c | _ -> fprintf f "'%c'" c;; let fmt_constant f x = match x with | Const_int (i) -> if (i < 0) then fprintf f "(%d)" i else fprintf f "%d" i; | Const_char (c) -> fprintf f "%a" fmt_char c ; | Const_string (s) -> fprintf f "%S" s; | Const_float (s) -> if ((String.get s 0) = '-') then fprintf f "(%s)" s else fprintf f "%s" s; (* maybe parenthesize all floats for consistency? *) | Const_int32 (i) -> if i < 0l then fprintf f "(%ldl)" i else fprintf f "%ldl" i; | Const_int64 (i) -> if i < 0L then fprintf f "(%LdL)" i else fprintf f "%LdL" i; | Const_nativeint (i) -> if i < 0n then fprintf f "(%ndn)" i else fprintf f "%ndn" i; ;; let fmt_mutable_flag ppf x = match x with | Immutable -> (); | Mutable -> fprintf ppf "mutable "; ;; let string ppf s = fprintf ppf "%s" s ;; let text ppf s = fprintf ppf "%s" s.txt ;; let constant_string ppf s = fprintf ppf "\"%s\"" (String.escaped s) ;; let fmt_virtual_flag f x = match x with | Virtual -> fprintf f "virtual "; | Concrete -> (); ;; let list f ppf l = let n = List.length l in List.iteri (fun i fmt -> f ppf fmt; if i < n-1 then Format.fprintf ppf "\n") l;; (* List2 - applies f to each element in list l, placing break hints and a separator string between the resulting outputs. *) let rec list2 f ppf l ?(indent=0) ?(space=1) ?(breakfirst=false) ?(breaklast=false) sep = match l with [] -> if (breaklast=true) then pp_print_break ppf space indent; | (last::[]) -> if (breakfirst=true) then pp_print_break ppf space indent; f ppf last; if (breaklast=true) then pp_print_break ppf space indent; | (first::rest) -> if (breakfirst=true) then pp_print_break ppf space indent; f ppf first ; fprintf ppf sep; pp_print_break ppf space indent; list2 f ppf rest ~indent:indent ~space:space ~breakfirst:false ~breaklast:breaklast sep ;; let type_var_print ppf str = fprintf ppf "'%s" str.txt ;; let type_var_option_print ppf str = match str with None -> () (* TODO check *) | Some str -> fprintf ppf "'%s" str.txt ;; let fmt_class_params ppf (l, loc) = let length = (List.length l) in if (length = 0) then () else if (length = 1) then fprintf ppf "%s@ " (List.hd l) else begin fprintf ppf "(" ; list2 string ppf l "," ; fprintf ppf ")@ " ; end ;; let fmt_class_params_def ppf (l, loc) = let length = (List.length l) in if (length = 0) then () else begin fprintf ppf "[" ; list2 type_var_print ppf l "," ; fprintf ppf "]@ "; end ;; let fmt_rec_flag f x = match x with | Nonrecursive -> (); | Recursive | Default -> fprintf f " rec"; (* todo - what is "default" recursion?? this seemed safe, as it's better to falsely make a non-recursive let recursive than the opposite. *) ;; let fmt_direction_flag ppf x = match x with | Upto -> fprintf ppf "to" ; | Downto -> fprintf ppf "downto" ; ;; let fmt_private_flag f x = match x with | Public -> () ; (* fprintf f "Public"; *) | Private -> fprintf f "private "; ;; let option f ppf x = (* DELETE *) match x with | None -> () ; | Some x -> line 0 ppf "Some\n"; f ppf x; ;; let option_quiet_p f ppf x = match x with | None -> (); | Some x -> fprintf ppf "@ (" ; f ppf x; fprintf ppf ")"; ;; let option_quiet f ppf x = match x with | None -> (); | Some x -> fprintf ppf "@ " ; f ppf x; ;; let rec expression_is_terminal_list exp = match exp with | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("[]")}, None, _)} -> true ; | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("::")}, Some({pexp_desc = Pexp_tuple([exp1 ; exp2])}), _)} -> (expression_is_terminal_list exp2) | {pexp_desc = _} -> false ;; let rec core_type ppf x = match x.ptyp_desc with | Ptyp_any -> fprintf ppf "_"; (* done *) | Ptyp_var (s) -> fprintf ppf "'%s" s; (* done *) | Ptyp_arrow (l, ct1, ct2) -> (* done *) pp_open_hovbox ppf indent ; fprintf ppf "(" ; (match l with | "" -> core_type ppf ct1; | s when (String.get s 0 = '?') -> (match ct1.ptyp_desc with | Ptyp_constr ({ txt = Longident.Lident ("option")}, l) -> fprintf ppf "%s :@ " s ; type_constr_list ppf l ; | _ -> core_type ppf ct1; (* todo: what do we do here? *) ); | s -> fprintf ppf "%s :@ " s ; core_type ppf ct1; (* todo: what do we do here? *) ); fprintf ppf "@ ->@ " ; core_type ppf ct2 ; fprintf ppf ")" ; pp_close_box ppf () ; | Ptyp_tuple l -> (* done *) pp_open_hovbox ppf indent ; fprintf ppf "(" ; list2 core_type ppf l " *" ; fprintf ppf ")" ; pp_close_box ppf () ; | Ptyp_constr (li, l) -> (* done *) pp_open_hovbox ppf indent ; type_constr_list ppf ~space:true l ; fprintf ppf "%a" fmt_longident li ; pp_close_box ppf () ; | Ptyp_variant (l, closed, low) -> pp_open_hovbox ppf indent ; (match closed with | true -> fprintf ppf "[ " ; | false -> fprintf ppf "[> " ; ); list2 type_variant_helper ppf l " |" ; fprintf ppf " ]"; pp_close_box ppf () ; | Ptyp_object (l) -> if ((List.length l) > 0) then begin pp_open_hovbox ppf indent ; fprintf ppf "< " ; list2 core_field_type ppf l " ;" ; fprintf ppf " >" ; pp_close_box ppf () ; end else fprintf ppf "< >" ; (* line i ppf "Ptyp_object\n"; list i core_field_type ppf l; *) | Ptyp_class (li, l, low) -> (* done... sort of *) pp_open_hovbox ppf indent ; list2 core_type ppf l ~breaklast:true "" ; fprintf ppf "#%a" fmt_longident li; if ((List.length low) < 0) then begin (* done, untested *) fprintf ppf "@ [> " ; list2 class_var ppf low "" ; fprintf ppf " ]"; end ; pp_close_box ppf (); (* line i ppf "Ptyp_class %a\n" fmt_longident li; list i core_type ppf l; list i string ppf low *) | Ptyp_alias (ct, s) -> (* done *) pp_open_hovbox ppf indent ; fprintf ppf "(" ; core_type ppf ct ; fprintf ppf "@ as@ '%s)" s; pp_close_box ppf () ; | Ptyp_poly (sl, ct) -> (* done? *) pp_open_hovbox ppf indent ; if ((List.length sl) > 0) then begin list2 (fun ppf x -> fprintf ppf "'%s" x) ppf sl ~breaklast:true ""; fprintf ppf ".@ " ; end ; core_type ppf ct ; pp_close_box ppf () ; | Ptyp_package (lid, cstrs) -> fprintf ppf "(module %a@ " fmt_longident lid; pp_open_hovbox ppf indent; begin match cstrs with [] -> () | _ -> fprintf ppf "@ with@ "; string_x_core_type_ands ppf cstrs ; end; pp_close_box ppf (); fprintf ppf ")"; and class_var ppf s = fprintf ppf "`%s" s ; and core_field_type ppf x = match x.pfield_desc with | Pfield (s, ct) -> pp_open_hovbox ppf indent ; fprintf ppf "%s :@ " s; core_type ppf ct; pp_close_box ppf () ; | Pfield_var -> fprintf ppf ".."; and type_constr_list ppf ?(space=false) l = match (List.length l) with | 0 -> () | 1 -> list2 core_type ppf l "" ; if (space) then fprintf ppf " " ; | _ -> fprintf ppf "(" ; list2 core_type ppf l "," ; fprintf ppf ")" ; if (space) then fprintf ppf " " ; and pattern_with_label ppf x s = if (s = "") then simple_pattern ppf x else begin let s = if (String.get s 0 = '?') then begin fprintf ppf "?" ; String.sub s 1 ((String.length s) - 1) end else begin fprintf ppf "~" ; s end in fprintf ppf "%s" s ; match x.ppat_desc with | Ppat_var (s2) -> if (s <> s2.txt) then begin fprintf ppf ":" ; simple_pattern ppf x ; end | _ -> fprintf ppf ":" ; simple_pattern ppf x end ; and pattern_with_when ppf whenclause x = match whenclause with | None -> pattern ppf x ; | Some (e) -> pp_open_hovbox ppf indent ; pattern ppf x ; fprintf ppf "@ when@ " ; expression ppf e ; pp_close_box ppf () ; and pattern ppf x = match x.ppat_desc with | Ppat_construct (li, po, b) -> pp_open_hovbox ppf indent ; (match li.txt,po with | Longident.Lident("::"), Some ({ppat_desc = Ppat_tuple([pat1; pat2])}) -> fprintf ppf "(" ; pattern ppf pat1 ; fprintf ppf "@ ::@ " ; pattern_list_helper ppf pat2 ; fprintf ppf ")"; | _,_ -> fprintf ppf "%a" fmt_longident li; option_quiet pattern_in_parens ppf po;); pp_close_box ppf () ; (* OXX what is this boolean ?? bool i ppf b; *) | _ -> simple_pattern ppf x and simple_pattern ppf x = match x.ppat_desc with | Ppat_construct (li, None, _) -> fprintf ppf "%a@ " fmt_longident li | Ppat_any -> fprintf ppf "_"; (* OXX done *) | Ppat_var ({txt = txt}) -> if (is_infix (fixity_of_string txt)) || List.mem txt.[0] prefix_symbols then fprintf ppf "(%s)" txt (* OXX done *) else fprintf ppf "%s" txt; | Ppat_alias (p, s) -> (* OXX done ... *) pp_open_hovbox ppf indent ; fprintf ppf "(" ; pattern ppf p ; fprintf ppf " as@ %s)" s.txt; pp_close_box ppf () ; | Ppat_constant (c) -> (* OXX done *) fprintf ppf "%a" fmt_constant c; | Ppat_tuple (l) -> (* OXX done *) fprintf ppf "@[("; list2 pattern ppf l ","; fprintf ppf "@])"; | Ppat_variant (l, po) -> (match po with | None -> fprintf ppf "`%s" l; | Some (p) -> pp_open_hovbox ppf indent ; fprintf ppf "(`%s@ " l ; pattern ppf p ; fprintf ppf ")" ; pp_close_box ppf () ; ); | Ppat_record (l, closed) -> (* OXX done *) fprintf ppf "{" ; list2 longident_x_pattern ppf l ";" ; begin match closed with Open -> fprintf ppf "_ "; | Closed -> () end; fprintf ppf "}" ; | Ppat_array (l) -> (* OXX done *) pp_open_hovbox ppf 2 ; fprintf ppf "[|" ; list2 pattern ppf l ";" ; fprintf ppf "|]" ; pp_close_box ppf () ; | Ppat_or (p1, p2) -> (* OXX done *) pp_open_hovbox ppf indent ; fprintf ppf "(" ; pattern ppf p1 ; fprintf ppf "@ | " ; pattern ppf p2 ; fprintf ppf ")" ; pp_close_box ppf () ; | Ppat_constraint (p, ct) -> (* OXX done, untested *) fprintf ppf "(" ; pattern ppf p ; fprintf ppf " :" ; pp_print_break ppf 1 indent ; core_type ppf ct ; fprintf ppf ")" ; | Ppat_type (li) -> (* OXX done *) fprintf ppf "#%a" fmt_longident li ; | Ppat_lazy p -> pp_open_hovbox ppf indent ; fprintf ppf "(lazy @ "; pattern ppf p ; fprintf ppf ")" ; pp_close_box ppf () | Ppat_unpack (s) -> fprintf ppf "(module@ %s)@ " s.txt | _ -> fprintf ppf "@[("; pattern ppf x; fprintf ppf "@])"; and simple_expr ppf x = match x.pexp_desc with | Pexp_construct (li, None, _) -> fprintf ppf "%a@ " fmt_longident li | Pexp_ident (li) -> (* was (li, b) *) if is_infix (fixity_of_longident li) || match li.txt with | Longident.Lident (li) -> List.mem li.[0] prefix_symbols | _ -> false then fprintf ppf "(%a)" fmt_longident li else fprintf ppf "%a" fmt_longident li ; | Pexp_constant (c) -> fprintf ppf "%a" fmt_constant c; | Pexp_pack (me) -> fprintf ppf "(module@ "; pp_open_hovbox ppf indent; module_expr ppf me; pp_close_box ppf (); fprintf ppf ")"; | Pexp_newtype (lid, e) -> fprintf ppf "fun (type %s)@ " lid; expression ppf e | Pexp_tuple (l) -> fprintf ppf "@[("; list2 simple_expr ppf l ","; fprintf ppf ")@]"; | Pexp_variant (l, eo) -> pp_open_hovbox ppf indent ; fprintf ppf "`%s" l ; option_quiet expression ppf eo ; pp_close_box ppf () ; | Pexp_record (l, eo) -> pp_open_hovbox ppf indent ; (* maybe just 1? *) fprintf ppf "{" ; begin match eo with None -> () | Some e -> expression ppf e; fprintf ppf "@ with@ " end; list2 longident_x_expression ppf l ";" ; fprintf ppf "}" ; pp_close_box ppf () ; | Pexp_array (l) -> pp_open_hovbox ppf 2 ; fprintf ppf "[|" ; list2 simple_expr ppf l ";" ; fprintf ppf "|]" ; pp_close_box ppf () ; | Pexp_while (e1, e2) -> pp_open_hvbox ppf 0 ; pp_open_hovbox ppf indent ; fprintf ppf "while@ " ; expression ppf e1 ; fprintf ppf " do" ; pp_close_box ppf () ; pp_print_break ppf 1 indent ; expression_sequence ppf e2 ~first:false; pp_print_break ppf 1 0 ; fprintf ppf "done" ; pp_close_box ppf () ; | Pexp_for (s, e1, e2, df, e3) -> pp_open_hvbox ppf 0 ; pp_open_hovbox ppf indent ; fprintf ppf "for %s =@ " s.txt ; expression ppf e1 ; fprintf ppf "@ %a@ " fmt_direction_flag df ; expression ppf e2 ; fprintf ppf " do" ; pp_close_box ppf () ; pp_print_break ppf 1 indent ; expression_sequence ppf ~first:false e3 ; pp_print_break ppf 1 0 ; fprintf ppf "done" ; pp_close_box ppf () ; | _ -> fprintf ppf "(@ "; expression ppf x; fprintf ppf "@ )" and expression ppf x = match x.pexp_desc with | Pexp_let (rf, l, e) -> let l1 = (List.hd l) in let l2 = (List.tl l) in pp_open_hvbox ppf 0 ; pp_open_hvbox ppf indent ; fprintf ppf "let%a " fmt_rec_flag rf; pattern_x_expression_def ppf l1; pattern_x_expression_def_list ppf l2; pp_close_box ppf () ; fprintf ppf " in" ; pp_print_space ppf () ; expression_sequence ppf ~first:false ~indent:0 e ; pp_close_box ppf () ; | Pexp_function (label, None, [ { ppat_desc = Ppat_var { txt ="*opt*" } }, { pexp_desc = Pexp_let (_, [ arg , { pexp_desc = Pexp_match (_, [ _; _, eo ] ) } ], e) } ] ) -> expression ppf { x with pexp_desc = Pexp_function(label, Some eo, [arg, e]) } | Pexp_function (p, eo, l) -> if (List.length l = 1) then begin pp_open_hvbox ppf indent; fprintf ppf "fun " ; pattern_x_expression_case_single ppf (List.hd l) eo p end else begin pp_open_hvbox ppf 0; fprintf ppf "function" ; option_quiet expression_in_parens ppf eo ; pp_print_space ppf () ; pattern_x_expression_case_list ppf l ; end ; pp_close_box ppf (); | Pexp_apply (e, l) -> (* was (e, l, _) *) let fixity = (is_infix (fixity_of_exp e)) in let sd = (match e.pexp_desc with | Pexp_ident ({ txt = Longident.Ldot (Longident.Lident(modname), valname) }) -> (modname, valname) | Pexp_ident ({ txt = Longident.Lident(valname) }) -> ("",valname) | _ -> ("","")) in (match sd,l with | ("Array", "get"), [(_,exp1) ; (_,exp2)] -> pp_open_hovbox ppf indent; (match exp1.pexp_desc with | Pexp_ident (_) -> expression ppf exp1 ; | _ -> expression_in_parens ppf exp1 ; ); fprintf ppf "."; expression_in_parens ppf exp2; pp_close_box ppf (); | ("Array", "set"), [(_,array) ; (_,index) ; (_, valu)] -> pp_open_hovbox ppf indent; (match array.pexp_desc with | Pexp_ident (_) -> expression ppf array ; | _ -> expression_in_parens ppf array ; ); fprintf ppf "."; expression_in_parens ppf index; fprintf ppf "@ <-@ "; expression ppf valu; pp_close_box ppf (); | ("","!"),[(_,exp1)] -> fprintf ppf "!" ; simple_expr ppf exp1 ; (* | ("","raise"),[(_,exp)] -> fprintf ppf "raising [" ; expression ppf exp; fprintf ppf "], says %s" st; *) | (_,_) -> pp_open_hovbox ppf (indent + 1) ; fprintf ppf "(" ; if (fixity = false) then begin (match e.pexp_desc with | Pexp_ident(_) -> expression ppf e ; | Pexp_send (_,_) -> expression ppf e ; | _ -> pp_open_hovbox ppf indent; expression_in_parens ppf e ; pp_close_box ppf () ); fprintf ppf "@ " ; list2 label_x_expression_param ppf l ""; end else begin match l with [ arg1; arg2 ] -> label_x_expression_param ppf arg1 ; pp_print_space ppf () ; (match e.pexp_desc with | Pexp_ident(li) -> (* override parenthesization of infix identifier *) fprintf ppf "%a" fmt_longident li ; | _ -> simple_expr ppf e) ; pp_print_space ppf () ; label_x_expression_param ppf arg2 | _ -> (* fprintf ppf "(" ; *) simple_expr ppf e ; (* fprintf ppf ")" ; *) list2 label_x_expression_param ppf l ~breakfirst:true "" end ; fprintf ppf ")" ; pp_close_box ppf () ;) | Pexp_match (e, l) -> fprintf ppf "(" ; pp_open_hvbox ppf 0; pp_open_hovbox ppf 2; fprintf ppf "match@ " ; expression ppf e ; fprintf ppf " with" ; pp_close_box ppf () ; pp_print_space ppf () ; pattern_x_expression_case_list ppf l ; pp_close_box ppf () ; fprintf ppf ")" ; | Pexp_try (e, l) -> fprintf ppf "("; pp_open_vbox ppf 0; (* <-- always break here, says style manual *) pp_open_hvbox ppf 0; fprintf ppf "try"; pp_print_break ppf 1 indent ; expression_sequence ppf ~first:false e; pp_print_break ppf 1 0; fprintf ppf "with"; pp_close_box ppf (); pp_print_cut ppf (); pattern_x_expression_case_list ppf l ; pp_close_box ppf (); fprintf ppf ")"; | Pexp_construct (li, eo, b) -> (match li.txt with | Longident.Lident ("::") -> (match eo with Some ({pexp_desc = Pexp_tuple ([exp1 ; exp2])}) -> pp_open_hovbox ppf indent ; if (expression_is_terminal_list exp2) then begin fprintf ppf "[" ; simple_expr ppf exp1 ; expression_list_helper ppf exp2 ; fprintf ppf "]" ; end else begin pp_open_hovbox ppf indent ; fprintf ppf "(@ "; simple_expr ppf exp1 ; fprintf ppf " ) ::@ " ; expression_list_nonterminal ppf exp2 ; fprintf ppf "@ " ; pp_close_box ppf () ; end ; pp_close_box ppf () ; | _ -> assert false ); | Longident.Lident ("()") -> fprintf ppf "()" ; | _ -> fprintf ppf "("; pp_open_hovbox ppf indent ; fmt_longident ppf li; option_quiet expression_in_parens ppf eo; pp_close_box ppf () ; fprintf ppf ")" ); | Pexp_field (e, li) -> pp_open_hovbox ppf indent ; (match e.pexp_desc with | Pexp_ident (_) -> simple_expr ppf e ; | _ -> expression_in_parens ppf e ; ); fprintf ppf ".%a" fmt_longident li ; pp_close_box ppf () ; | Pexp_setfield (e1, li, e2) -> pp_open_hovbox ppf indent ; (match e1.pexp_desc with | Pexp_ident (_) -> simple_expr ppf e1 ; | _ -> expression_in_parens ppf e1 ; ); fprintf ppf ".%a" fmt_longident li; fprintf ppf "@ <-@ "; expression ppf e2; pp_close_box ppf () ; | Pexp_ifthenelse (e1, e2, eo) -> fprintf ppf "@[" ; expression_if_common ppf e1 e2 eo; fprintf ppf "@]"; | Pexp_sequence (e1, e2) -> fprintf ppf "@[begin" ; pp_print_break ppf 1 indent ; (* "@;<1 2>" ; *) expression_sequence ppf ~first:false x ; fprintf ppf "@;<1 0>end@]" ; | Pexp_constraint (e, cto1, cto2) -> (match (cto1, cto2) with | (None, None) -> expression ppf e ; | (Some (x1), Some (x2)) -> pp_open_hovbox ppf 2 ; fprintf ppf "(" ; expression ppf e ; fprintf ppf " :@ " ; core_type ppf x1 ; fprintf ppf " :>@ " ; core_type ppf x2 ; fprintf ppf ")" ; pp_close_box ppf () ; | (Some (x), None) -> pp_open_hovbox ppf 2 ; fprintf ppf "(" ; expression ppf e ; fprintf ppf " :@ " ; core_type ppf x ; fprintf ppf ")" ; pp_close_box ppf () | (None, Some (x)) -> pp_open_hovbox ppf 2 ; fprintf ppf "(" ; expression ppf e ; fprintf ppf " :>@ " ; core_type ppf x ; fprintf ppf ")" ; pp_close_box ppf () ) | Pexp_when (e1, e2) -> assert false ; (* This is a wierd setup. The ocaml phrase "pattern when condition -> expression" found in pattern matching contexts is encoded as: "pattern -> when condition expression" Thus, the when clause ("when condition"), which one might expect to be part of the pattern, is encoded as part of the expression following the pattern. A "when clause" should never exist in a vaccum. It should always occur in a pattern matching context and be printed as part of the pattern (in pattern_x_expression_case_list). Thus these Pexp_when expressions are printed elsewhere, and if this code is executed, an error has occurred. *) | Pexp_send (e, s) -> pp_open_hovbox ppf indent; (match e.pexp_desc with | Pexp_ident(_) -> expression ppf e; fprintf ppf "#%s" s; | _ -> fprintf ppf "(" ; expression_in_parens ppf e; fprintf ppf "@,#%s" s; fprintf ppf ")" ); pp_close_box ppf (); (* bug fixed? *) | Pexp_new (li) -> pp_open_hovbox ppf indent; fprintf ppf "new@ %a" fmt_longident li; pp_close_box ppf (); | Pexp_setinstvar (s, e) -> pp_open_hovbox ppf indent; fprintf ppf "%s <-@ " s.txt; expression ppf e; pp_close_box ppf (); | Pexp_override (l) -> pp_open_hovbox ppf indent ; fprintf ppf "{< " ; if ((List.length l) > 0) then begin list2 string_x_expression ppf l ";"; fprintf ppf " " ; end ; fprintf ppf ">}" ; pp_close_box ppf () ; | Pexp_letmodule (s, me, e) -> pp_open_hvbox ppf 0 ; pp_open_hovbox ppf indent ; fprintf ppf "let module %s =@ " s.txt ; module_expr ppf me ; fprintf ppf " in" ; pp_close_box ppf () ; pp_print_space ppf () ; expression_sequence ppf ~first:false ~indent:0 e ; pp_close_box ppf () ; | Pexp_assert (e) -> pp_open_hovbox ppf indent ; fprintf ppf "assert@ " ; expression ppf e ; pp_close_box ppf () ; | Pexp_assertfalse -> fprintf ppf "assert false" ; | Pexp_lazy (e) -> pp_open_hovbox ppf indent ; fprintf ppf "lazy@ " ; simple_expr ppf e ; pp_close_box ppf () ; | Pexp_poly (e, cto) -> (* should this even print by itself? *) (match cto with | None -> expression ppf e ; | Some (ct) -> pp_open_hovbox ppf indent ; expression ppf e ; fprintf ppf "@ (* poly:@ " ; core_type ppf ct ; fprintf ppf " *)" ; pp_close_box ppf () ); | Pexp_object cs -> pp_open_hovbox ppf indent ; class_structure ppf cs ; pp_close_box ppf () ; | Pexp_open (lid, e) -> pp_open_hvbox ppf 0 ; fprintf ppf "let open@ %a in@ " fmt_longident lid; expression_sequence ppf ~first:false ~indent:0 e ; pp_close_box ppf () ; | _ -> simple_expr ppf x and value_description ppf x = pp_open_hovbox ppf indent ; core_type ppf x.pval_type; if ((List.length x.pval_prim) > 0) then begin fprintf ppf " =@ " ; list2 constant_string ppf x.pval_prim ""; end ; pp_close_box ppf () ; and type_declaration ppf x = pp_open_hovbox ppf indent ; (match x.ptype_manifest with | None -> () | Some(y) -> core_type ppf y; match x.ptype_kind with | Ptype_variant _ | Ptype_record _ -> fprintf ppf " = " | Ptype_abstract -> ()); (match x.ptype_kind with | Ptype_variant (first::rest) -> pp_open_hovbox ppf indent ; pp_open_hvbox ppf 0 ; type_variant_leaf ppf first true ; type_variant_leaf_list ppf rest ; (* string_x_core_type_list ppf lst; *) pp_close_box ppf () ; pp_close_box ppf () ; | Ptype_variant [] -> assert false ; | Ptype_abstract -> () | Ptype_record l -> pp_open_hovbox ppf indent ; fprintf ppf "{" ; pp_print_break ppf 0 indent ; pp_open_hvbox ppf 0; list2 type_record_field ppf l ";" ; pp_close_box ppf () ; fprintf ppf "@," ; pp_close_box ppf () ; fprintf ppf "}" ; pp_close_box ppf () ; ); list2 typedef_constraint ppf x.ptype_cstrs ~breakfirst:true "" ; pp_close_box ppf () ; and exception_declaration ppf x = match x with | [] -> () | first::rest -> fprintf ppf "@ of@ "; list2 core_type ppf x " *"; and class_type ppf x = match x.pcty_desc with | Pcty_signature (cs) -> class_signature ppf cs; | Pcty_constr (li, l) -> pp_open_hovbox ppf indent ; (match l with | [] -> () | _ -> fprintf ppf "[" ; list2 core_type ppf l "," ; fprintf ppf "]@ " ); fprintf ppf "%a" fmt_longident li ; pp_close_box ppf () ; | Pcty_fun (l, co, cl) -> pp_open_hovbox ppf indent ; core_type ppf co ; fprintf ppf " ->@ " ; (match l with | "" -> () ; | _ -> fprintf ppf "[%s] " l ); (* todo - what's l *) class_type ppf cl ; pp_close_box ppf () ; and class_signature ppf { pcsig_self = ct; pcsig_fields = l } = pp_open_hvbox ppf 0; pp_open_hovbox ppf indent ; fprintf ppf "object"; (match ct.ptyp_desc with | Ptyp_any -> () | _ -> fprintf ppf "@ ("; core_type ppf ct; fprintf ppf ")" ); pp_close_box ppf () ; list2 class_type_field ppf l ~indent:indent ~breakfirst:true ""; pp_print_break ppf 1 0; fprintf ppf "end"; and class_type_field ppf x = match x.pctf_desc with | Pctf_inher (ct) -> (* todo: test this *) pp_open_hovbox ppf indent ; fprintf ppf "inherit@ " ; class_type ppf ct ; pp_close_box ppf () ; | Pctf_val (s, mf, vf, ct) -> pp_open_hovbox ppf indent ; fprintf ppf "val %s%s%s :@ " (match mf with | Mutable -> "mutable " | _ -> "") (match vf with | Virtual -> "virtual " | _ -> "") s; core_type ppf ct ; pp_close_box ppf () ; | Pctf_virt (s, pf, ct) -> (* todo: test this *) pp_open_hovbox ppf indent ; pp_open_hovbox ppf indent ; fprintf ppf "method@ %avirtual@ %s" fmt_private_flag pf s ; pp_close_box ppf () ; fprintf ppf " :@ " ; core_type ppf ct ; pp_close_box ppf () ; | Pctf_meth (s, pf, ct) -> pp_open_hovbox ppf indent ; pp_open_hovbox ppf indent ; fprintf ppf "method %a%s" fmt_private_flag pf s; pp_close_box ppf () ; fprintf ppf " :@ " ; core_type ppf ct ; pp_close_box ppf () ; | Pctf_cstr (ct1, ct2) -> pp_open_hovbox ppf indent ; fprintf ppf "constraint@ " ; core_type ppf ct1; fprintf ppf " =@ " ; core_type ppf ct2; pp_close_box ppf () ; and class_description ppf x = pp_open_hvbox ppf 0 ; pp_open_hovbox ppf indent ; fprintf ppf "class %a%a%s :" fmt_virtual_flag x.pci_virt fmt_class_params_def x.pci_params x.pci_name.txt ; pp_close_box ppf () ; pp_print_break ppf 1 indent ; class_type ppf x.pci_expr ; pp_close_box ppf () ; and class_type_declaration ppf x = class_type_declaration_ext ppf true x ; and class_type_declaration_ext ppf first x = pp_open_hvbox ppf 0; pp_open_hovbox ppf indent ; fprintf ppf "%s@ %a%a%s =" (if (first) then "class type" else "and") fmt_virtual_flag x.pci_virt fmt_class_params_def x.pci_params x.pci_name.txt ; pp_close_box ppf (); pp_print_break ppf 1 indent ; class_type ppf x.pci_expr; pp_close_box ppf (); and class_type_declaration_list ppf ?(first=true) l = if (first) then pp_open_hvbox ppf 0 ; match l with | [] -> if (first) then pp_close_box ppf () ; | h :: [] -> class_type_declaration_ext ppf first h ; pp_close_box ppf () ; | h :: t -> class_type_declaration_ext ppf first h ; pp_print_space ppf () ; class_type_declaration_list ppf ~first:false t ; and class_expr ppf x = match x.pcl_desc with | Pcl_structure (cs) -> class_structure ppf cs ; | Pcl_fun (l, eo, p, e) -> pp_open_hvbox ppf indent; pp_open_hovbox ppf indent; fprintf ppf "fun@ "; pattern ppf p; fprintf ppf " ->"; pp_close_box ppf (); (match (eo, l) with | (None, "") -> () ; | (_,_) -> pp_open_hovbox ppf indent; fprintf ppf " (* eo: "; option expression ppf eo; fprintf ppf "@ label: "; label 0 ppf l; fprintf ppf " *)"; pp_close_box ppf () ); fprintf ppf "@ "; class_expr ppf e; pp_close_box ppf (); | Pcl_let (rf, l, ce) -> let l1 = (List.hd l) in let l2 = (List.tl l) in pp_open_hvbox ppf 0 ; pp_open_hvbox ppf indent ; fprintf ppf "let%a " fmt_rec_flag rf; pattern_x_expression_def ppf l1; pattern_x_expression_def_list ppf l2; pp_close_box ppf () ; pp_close_box ppf () ; fprintf ppf " in" ; pp_print_space ppf () ; class_expr ppf ce; | Pcl_apply (ce, l) -> pp_open_hovbox ppf indent ; fprintf ppf "("; class_expr ppf ce; list2 label_x_expression_param ppf l ~breakfirst:true ""; fprintf ppf ")"; pp_close_box ppf () ; | Pcl_constr (li, l) -> pp_open_hovbox ppf indent; if ((List.length l) != 0) then begin fprintf ppf "[" ; list2 core_type ppf l "," ; fprintf ppf "]@ " ; end ; fprintf ppf "%a" fmt_longident li; pp_close_box ppf (); | Pcl_constraint (ce, ct) -> pp_open_hovbox ppf indent; fprintf ppf "("; class_expr ppf ce; fprintf ppf "@ : "; class_type ppf ct; fprintf ppf ")"; pp_close_box ppf (); and class_structure ppf { pcstr_pat = p; pcstr_fields = l } = pp_open_hvbox ppf 0 ; pp_open_hovbox ppf indent ; fprintf ppf "object" ; (match p.ppat_desc with | Ppat_any -> (); | _ -> fprintf ppf "@ " ; pattern_in_parens ppf p ); pp_close_box ppf () ; list2 class_field ppf l ~indent:indent ~breakfirst:true ""; fprintf ppf "@ end" ; pp_close_box ppf () ; and override ovf = match ovf with Override -> "!" | Fresh -> "" and class_field ppf x = match x.pcf_desc with | Pcf_inher (ovf, ce, so) -> pp_open_hovbox ppf indent ; fprintf ppf "inherit%s@ " (override ovf); class_expr ppf ce; (match so with | None -> (); | Some (s) -> fprintf ppf "@ as %s" s ); pp_close_box ppf (); | Pcf_val (s, mf, ovf, e) -> pp_open_hovbox ppf indent ; fprintf ppf "val%s %a%s =@ " (override ovf) fmt_mutable_flag mf s.txt ; expression_sequence ppf ~indent:0 e ; pp_close_box ppf () ; | Pcf_virt (s, pf, ct) -> pp_open_hovbox ppf indent ; fprintf ppf "method virtual %a%s" fmt_private_flag pf s.txt ; fprintf ppf " :@ " ; core_type ppf ct; pp_close_box ppf () ; | Pcf_valvirt (s, mf, ct) -> pp_open_hovbox ppf indent ; fprintf ppf "val virtual %s%s" (match mf with | Mutable -> "mutable " | _ -> "") s.txt; fprintf ppf " :@ " ; core_type ppf ct; pp_close_box ppf () ; | Pcf_meth (s, pf, ovf, e) -> pp_open_hovbox ppf indent ; fprintf ppf "method%s %a%s" (override ovf) fmt_private_flag pf s.txt ; (match e.pexp_desc with | Pexp_poly (e, Some(ct)) -> fprintf ppf " :@ " ; core_type ppf ct ; fprintf ppf " =@ " ; expression ppf e ; | _ -> fprintf ppf " =@ " ; expression ppf e; ) ; (* special Pexp_poly handling? *) pp_close_box ppf () ; | Pcf_constr (ct1, ct2) -> pp_open_hovbox ppf indent ; fprintf ppf "constraint@ "; core_type ppf ct1; fprintf ppf " =@ " ; core_type ppf ct2; pp_close_box ppf (); (* | Pcf_let (rf, l) -> (* at the time that this was written, Pcf_let was commented out of the parser, rendering this untestable. In the interest of completeness, the following code is designed to print what the parser seems to expect *) (* todo: test this, eventually *) let l1 = (List.hd l) in let l2 = (List.tl l) in pp_open_hvbox ppf indent ; fprintf ppf "let%a " fmt_rec_flag rf; pattern_x_expression_def ppf l1; pattern_x_expression_def_list ppf l2; fprintf ppf " in" ; pp_close_box ppf () ; *) | Pcf_init (e) -> pp_open_hovbox ppf indent ; fprintf ppf "initializer@ " ; expression_sequence ppf ~indent:0 e ; pp_close_box ppf () ; and class_fun_helper ppf e = match e.pcl_desc with | Pcl_fun (l, eo, p, e) -> pattern ppf p; fprintf ppf "@ "; (match (eo, l) with | (None, "") -> () ; | (_,_) -> fprintf ppf "(* "; option expression ppf eo; label 0 ppf l; fprintf ppf " *)@ " ); class_fun_helper ppf e; | _ -> e; and class_declaration_list ppf ?(first=true) l = match l with | [] -> if (first = false) then pp_close_box ppf (); | cd::l -> let s = (if first then begin pp_open_hvbox ppf 0 ; "class" end else begin pp_print_space ppf () ; "and" end) in class_declaration ppf ~str:s cd ; class_declaration_list ppf ~first:false l ; and class_declaration ppf ?(str="class") x = pp_open_hvbox ppf indent ; pp_open_hovbox ppf indent ; fprintf ppf "%s %a%a%s@ " str fmt_virtual_flag x.pci_virt fmt_class_params_def x.pci_params x.pci_name.txt ; let ce = (match x.pci_expr.pcl_desc with | Pcl_fun (l, eo, p, e) -> class_fun_helper ppf x.pci_expr; | _ -> x.pci_expr) in let ce = (match ce.pcl_desc with | Pcl_constraint (ce, ct) -> fprintf ppf ":@ " ; class_type ppf ct ; fprintf ppf "@ " ; ce | _ -> ce ) in fprintf ppf "=" ; pp_close_box ppf () ; fprintf ppf "@ " ; class_expr ppf ce ; pp_close_box ppf () ; and module_type ppf x = match x.pmty_desc with | Pmty_ident (li) -> fprintf ppf "%a" fmt_longident li; | Pmty_signature (s) -> pp_open_hvbox ppf 0; fprintf ppf "sig"; list2 signature_item ppf s ~breakfirst:true ~indent:indent ""; pp_print_break ppf 1 0; fprintf ppf "end"; pp_close_box ppf (); | Pmty_functor (s, mt1, mt2) -> pp_open_hvbox ppf indent; pp_open_hovbox ppf indent; fprintf ppf "functor@ (%s : " s.txt ; module_type ppf mt1; fprintf ppf ") ->"; pp_close_box ppf (); pp_print_space ppf (); module_type ppf mt2; pp_close_box ppf (); | Pmty_with (mt, l) -> pp_open_hovbox ppf indent ; fprintf ppf "(" ; module_type ppf mt ; fprintf ppf "@ with@ " ; longident_x_with_constraint_list ppf l ; fprintf ppf ")" ; pp_close_box ppf () ; | Pmty_typeof me -> pp_open_hovbox ppf indent ; fprintf ppf "module type of " ; module_expr ppf me ; pp_close_box ppf () and signature ppf x = list signature_item ppf x and signature_item ppf x = begin match x.psig_desc with | Psig_type (l) -> let first = (List.hd l) in let rest = (List.tl l) in pp_open_hvbox ppf 0; pp_open_hvbox ppf 0; fprintf ppf "type " ; string_x_type_declaration ppf first; pp_close_box ppf (); type_def_list_helper ppf rest; pp_close_box ppf (); | Psig_value (s, vd) -> let intro = if vd.pval_prim = [] then "val" else "external" in pp_open_hovbox ppf indent ; if (is_infix (fixity_of_string s.txt)) || List.mem s.txt.[0] prefix_symbols then fprintf ppf "%s ( %s ) :@ " intro s.txt (* OXX done *) else fprintf ppf "%s %s :@ " intro s.txt; value_description ppf vd; pp_close_box ppf () ; | Psig_exception (s, ed) -> pp_open_hovbox ppf indent ; fprintf ppf "exception %s" s.txt; exception_declaration ppf ed; pp_close_box ppf (); | Psig_class (l) -> pp_open_hvbox ppf 0 ; list2 class_description ppf l ""; pp_close_box ppf () ; | Psig_module (s, mt) -> (* todo: check this *) pp_open_hovbox ppf indent ; pp_open_hovbox ppf indent ; fprintf ppf "module@ %s :" s.txt ; pp_close_box ppf () ; pp_print_space ppf () ; module_type ppf mt; pp_close_box ppf () ; | Psig_open (li) -> pp_open_hovbox ppf indent ; fprintf ppf "open@ %a" fmt_longident li ; pp_close_box ppf () ; | Psig_include (mt) -> (* todo: check this *) pp_open_hovbox ppf indent ; fprintf ppf "include@ " ; module_type ppf mt; pp_close_box ppf () ; | Psig_modtype (s, md) -> (* todo: check this *) pp_open_hovbox ppf indent ; fprintf ppf "module type %s" s.txt ; (match md with | Pmodtype_abstract -> () | Pmodtype_manifest (mt) -> pp_print_space ppf () ; fprintf ppf " = " ; module_type ppf mt; ); pp_close_box ppf () ; | Psig_class_type (l) -> class_type_declaration_list ppf l ; | Psig_recmodule decls -> pp_open_hvbox ppf 0 ; pp_open_hovbox ppf indent ; fprintf ppf "module rec@ " ; string_x_module_type_list ppf decls ; (* closes hov box *) pp_close_box ppf () ; end; fprintf ppf "\n" and modtype_declaration ppf x = match x with | Pmodtype_abstract -> line 0 ppf "Pmodtype_abstract\n"; | Pmodtype_manifest (mt) -> line 0 ppf "Pmodtype_manifest\n"; module_type ppf mt; and module_expr ppf x = match x.pmod_desc with | Pmod_structure (s) -> pp_open_hvbox ppf 0; fprintf ppf "struct"; list2 structure_item ppf s ~breakfirst:true ~indent:indent ""; pp_print_break ppf 1 0; fprintf ppf "end"; pp_close_box ppf (); (* bug fixed? *) | Pmod_constraint (me, mt) -> fprintf ppf "("; pp_open_hovbox ppf indent; module_expr ppf me; fprintf ppf " :@ "; (* <-- incorrect indentation? *) module_type ppf mt; pp_close_box ppf (); fprintf ppf ")"; | Pmod_ident (li) -> fprintf ppf "%a" fmt_longident li; | Pmod_functor (s, mt, me) -> pp_open_hvbox ppf indent ; fprintf ppf "functor (%s : " s.txt; module_type ppf mt; fprintf ppf ") ->@ "; module_expr ppf me; pp_close_box ppf () ; | Pmod_apply (me1, me2) -> pp_open_hovbox ppf indent; fprintf ppf "(" ; module_expr ppf me1; fprintf ppf ")" ; pp_print_cut ppf (); fprintf ppf "(" ; module_expr ppf me2; fprintf ppf ")" ; pp_close_box ppf (); | Pmod_unpack e -> fprintf ppf "(val@ "; pp_open_hovbox ppf indent; expression ppf e; pp_close_box ppf (); fprintf ppf ")"; and structure ppf x = list structure_item ppf x; (* (* closes one box *) and string_x_modtype_x_module ppf (s, _, mt, me) = (* (match me.pmod_desc with | Pmod_constraint (me, ({pmty_desc=(Pmty_ident (_) | Pmty_signature (_))} as mt)) -> (* assert false ; *) (* 3.07 - should this ever happen here? *) fprintf ppf "%s :@ " s ; module_type ppf mt ; fprintf ppf " =" ; pp_close_box ppf () ; pp_print_space ppf () ; module_expr ppf me ; | _ -> *) fprintf ppf "%s :@ " s; module_type ppf mt ; fprintf ppf " =" ; pp_close_box ppf () ; pp_print_space ppf () ; module_expr ppf me ; (* ) ; *) *) (* closes one box *) and text_x_modtype_x_module ppf (s, mt, me) = (* (match me.pmod_desc with | Pmod_constraint (me, ({pmty_desc=(Pmty_ident (_) | Pmty_signature (_))} as mt)) -> (* assert false ; *) (* 3.07 - should this ever happen here? *) fprintf ppf "%s :@ " s ; module_type ppf mt ; fprintf ppf " =" ; pp_close_box ppf () ; pp_print_space ppf () ; module_expr ppf me ; | _ -> *) fprintf ppf "%s :@ " s.txt; module_type ppf mt ; fprintf ppf " =" ; pp_close_box ppf () ; pp_print_space ppf () ; module_expr ppf me ; (* ) ; *) (* (* net gain of one box (-1, +2) *) and string_x_modtype_x_module_list ppf l = match l with | [] -> () | hd :: tl -> pp_close_box ppf () ; pp_print_space ppf () ; pp_open_hvbox ppf indent ; pp_open_hovbox ppf indent ; fprintf ppf "and " ; string_x_modtype_x_module ppf hd; (* closes a box *) string_x_modtype_x_module_list ppf tl ; (* net open of one box *) *) (* net gain of one box (-1, +2) *) and text_x_modtype_x_module_list ppf l = match l with | [] -> () | hd :: tl -> pp_close_box ppf () ; pp_print_space ppf () ; pp_open_hvbox ppf indent ; pp_open_hovbox ppf indent ; fprintf ppf "and " ; text_x_modtype_x_module ppf hd; (* closes a box *) text_x_modtype_x_module_list ppf tl ; (* net open of one box *) (* context: [hv [hov .]] returns [hv .] closes inner hov box. *) and string_x_module_type_list ppf ?(first=true) l = match l with | [] -> () ; | hd :: tl -> if (first=false) then begin pp_print_space ppf () ; pp_open_hovbox ppf indent ; fprintf ppf "and " ; end ; string_x_module_type ppf hd ; pp_close_box ppf () ; string_x_module_type_list ppf ~first:false tl ; and string_x_module_type ppf (s, mty) = fprintf ppf "%s :@ " s.txt ; module_type ppf mty ; and structure_item ppf x = begin match x.pstr_desc with | Pstr_eval (e) -> pp_open_hvbox ppf 0 ; fprintf ppf "let _ = " ; expression_sequence ppf ~first:false ~indent:0 e ; pp_close_box ppf () ; | Pstr_type [] -> assert false | Pstr_type (first :: rest) -> pp_open_vbox ppf 0; pp_open_hvbox ppf 0; fprintf ppf "type " ; string_x_type_declaration ppf first; pp_close_box ppf (); type_def_list_helper ppf rest; pp_close_box ppf (); | Pstr_value (rf, l) -> let l1 = (List.hd l) in let l2 = (List.tl l) in pp_open_hvbox ppf 0 ; pp_open_hvbox ppf indent ; fprintf ppf "let%a " fmt_rec_flag rf; pattern_x_expression_def ppf l1; pattern_x_expression_def_list ppf l2; pp_close_box ppf () ; pp_close_box ppf () ; | Pstr_exception (s, ed) -> pp_open_hovbox ppf indent ; fprintf ppf "exception@ %s" s.txt; exception_declaration ppf ed; pp_close_box ppf () ; | Pstr_module (s, me) -> pp_open_hvbox ppf indent; pp_open_hovbox ppf indent ; fprintf ppf "module %s" s.txt ; (match me.pmod_desc with | Pmod_constraint (me, ({pmty_desc=(Pmty_ident (_) | Pmty_signature (_))} as mt)) -> fprintf ppf " :@ " ; module_type ppf mt ; fprintf ppf " =" ; pp_close_box ppf () ; pp_print_space ppf () ; module_expr ppf me ; | _ -> fprintf ppf " =" ; pp_close_box ppf () ; pp_print_space ppf () ; module_expr ppf me ; ) ; pp_close_box ppf (); | Pstr_open (li) -> fprintf ppf "open %a" fmt_longident li; | Pstr_modtype (s, mt) -> pp_open_hovbox ppf indent; fprintf ppf "module type %s =@ " s.txt; module_type ppf mt; pp_close_box ppf () ; (* bug fixed? *) | Pstr_class (l) -> class_declaration_list ppf l; | Pstr_class_type (l) -> class_type_declaration_list ppf l ; | Pstr_primitive (s, vd) -> pp_open_hovbox ppf indent ; let need_parens = match s.txt with | "or" | "mod" | "land" | "lor" | "lxor" | "lsl" | "lsr" | "asr" -> true | _ -> match s.txt.[0] with 'a'..'z' -> false | _ -> true in if need_parens then fprintf ppf "external@ ( %s ) :@ " s.txt else fprintf ppf "external@ %s :@ " s.txt; value_description ppf vd; pp_close_box ppf () ; | Pstr_include me -> pp_open_hovbox ppf indent ; fprintf ppf "include " ; module_expr ppf me ; pp_close_box ppf () ; | Pstr_exn_rebind (s, li) -> (* todo: check this *) pp_open_hovbox ppf indent ; fprintf ppf "exception@ %s =@ %a" s.txt fmt_longident li ; pp_close_box ppf () ; | Pstr_recmodule decls -> (* 3.07 *) let l1 = (List.hd decls) in let l2 = (List.tl decls) in pp_open_hvbox ppf 0; (* whole recmodule box *) pp_open_hvbox ppf indent ; (* this definition box *) pp_open_hovbox ppf indent ; (* first line box *) fprintf ppf "module rec " ; text_x_modtype_x_module ppf l1; (* closes a box *) text_x_modtype_x_module_list ppf l2; (* net opens one box *) pp_close_box ppf () ; pp_close_box ppf () ; pp_close_box ppf () ; end; fprintf ppf "\n" and type_def_list_helper ppf l = match l with | [] -> () | first :: rest -> pp_print_space ppf () ; pp_open_hovbox ppf indent ; fprintf ppf "and " ; string_x_type_declaration ppf first; pp_close_box ppf () ; type_def_list_helper ppf rest ; and string_x_type_declaration ppf (s, td) = let l = td.ptype_params in (match (List.length l) with | 0 -> () | 1 -> list2 type_var_option_print ppf l "" ; fprintf ppf " " ; | _ -> pp_open_hovbox ppf indent ; fprintf ppf "(" ; list2 type_var_option_print ppf l "," ; fprintf ppf ")" ; pp_close_box ppf (); fprintf ppf " " ; ); fprintf ppf "%s" s.txt ; (match (td.ptype_kind, td.ptype_manifest) with | Ptype_abstract, None -> () | Ptype_record _, _ -> fprintf ppf " = " ; | _ , _ -> fprintf ppf " =" ; pp_print_break ppf 1 indent ; ); type_declaration ppf td; and longident_x_with_constraint_list ?(first=true) ppf l = match l with | [] -> () ; | h :: [] -> if (first = false) then fprintf ppf "@ and " ; longident_x_with_constraint ppf h ; | h :: t -> if (first = false) then fprintf ppf "@ and " ; longident_x_with_constraint ppf h ; fprintf ppf "@ and " ; longident_x_with_constraint ppf h ; longident_x_with_constraint_list ~first:false ppf t; and string_x_core_type_ands ?(first=true) ppf l = match l with | [] -> () ; | h :: [] -> if (first = false) then fprintf ppf "@ and " ; string_x_core_type ppf h ; | h :: t -> if (first = false) then fprintf ppf "@ and " ; string_x_core_type ppf h; string_x_core_type_ands ~first:false ppf t; and string_x_core_type ppf (s, ct) = fprintf ppf "%a@ =@ %a" fmt_longident s core_type ct and longident_x_with_constraint ppf (li, wc) = match wc with | Pwith_type (td) -> fprintf ppf "type@ %a =@ " fmt_longident li; type_declaration ppf td ; | Pwith_module (li2) -> fprintf ppf "module %a =@ %a" fmt_longident li fmt_longident li2; | Pwith_typesubst td -> fprintf ppf "type@ %a :=@ " fmt_longident li; type_declaration ppf td ; | Pwith_modsubst (li2) -> fprintf ppf "module %a :=@ %a" fmt_longident li fmt_longident li2; and typedef_constraint ppf (ct1, ct2, l) = pp_open_hovbox ppf indent ; fprintf ppf "constraint@ " ; core_type ppf ct1; fprintf ppf " =@ " ; core_type ppf ct2; pp_close_box ppf () ; and type_variant_leaf ppf (s, l,_, _) first = (* TODO *) if (first) then begin pp_print_if_newline ppf (); pp_print_string ppf " "; end else begin pp_print_space ppf (); fprintf ppf "| " ; end ; pp_open_hovbox ppf indent ; fprintf ppf "%s" s.txt ; if ((List.length l) > 0) then begin fprintf ppf "@ of@ " ; list2 core_type ppf l " *" end ; pp_close_box ppf (); and type_variant_leaf_list ppf list = match list with | [] -> () | first :: rest -> type_variant_leaf ppf first false ; type_variant_leaf_list ppf rest ; and type_record_field ppf (s, mf, ct,_) = pp_open_hovbox ppf indent ; fprintf ppf "%a%s:" fmt_mutable_flag mf s.txt ; core_type ppf ct ; pp_close_box ppf () ; and longident_x_pattern ppf (li, p) = pp_open_hovbox ppf indent ; fprintf ppf "%a =@ " fmt_longident li; pattern ppf p; pp_close_box ppf () ; and pattern_x_expression_case_list ppf ?(first:bool=true) ?(special_first_case=bar_on_first_case) (l:(pattern * expression) list) = match l with | [] -> () | (p,e)::[] -> (* last time *) if (first=false) then fprintf ppf "| " ; pp_open_hvbox ppf indent ; let (e,w) = (match e with | {pexp_desc = Pexp_when (e1, e2)} -> (e2, Some (e1)) | _ -> (e, None)) in pattern_with_when ppf w p ; fprintf ppf " ->@ " ; pp_open_hvbox ppf 0 ; expression_sequence ppf ~indent:0 e ; pp_close_box ppf () ; pp_close_box ppf () ; | (p,e)::r -> (* not last *) pp_open_hvbox ppf (indent + 2) ; if ((first=true) & (special_first_case=false)) then begin pp_print_if_newline ppf () ; pp_print_string ppf " " end else fprintf ppf "| " ; let (e,w) = (match e with | {pexp_desc = Pexp_when (e1, e2)} -> (e2, Some (e1)) | _ -> (e, None)) in pattern_with_when ppf w p ; fprintf ppf " ->@ " ; pp_open_hvbox ppf 0 ; expression_sequence ppf ~indent:0 e ; pp_close_box ppf () ; pp_close_box ppf () ; pp_print_break ppf 1 0; (pattern_x_expression_case_list ppf ~first:false r); and pattern_x_expression_def ppf (p, e) = pattern ppf p ; fprintf ppf " =@ " ; expression ppf e; and pattern_list_helper ppf p = match p with | {ppat_desc = Ppat_construct ({ txt = Longident.Lident("::") }, Some ({ppat_desc = Ppat_tuple([pat1; pat2])}), _)} -> pattern ppf pat1 ; fprintf ppf "@ ::@ " ; pattern_list_helper ppf pat2 ; | _ -> pattern ppf p ; and string_x_expression ppf (s, e) = pp_open_hovbox ppf indent ; fprintf ppf "%s =@ " s.txt ; expression ppf e ; pp_close_box ppf () ; and longident_x_expression ppf (li, e) = pp_open_hovbox ppf indent ; fprintf ppf "%a =@ " fmt_longident li; simple_expr ppf e; pp_close_box ppf () ; and label_x_expression_param ppf (l,e) = match l with | "" -> simple_expr ppf e ; | lbl -> if ((String.get lbl 0) = '?') then begin fprintf ppf "%s:" lbl ; simple_expr ppf e ; end else begin fprintf ppf "~%s:" lbl ; simple_expr ppf e ; end ; and expression_in_parens ppf e = let already_has_parens = (match e.pexp_desc with Pexp_apply ({pexp_desc=Pexp_ident ({ txt = Longident.Ldot ( Longident.Lident(modname), funname) })},_) -> (match modname,funname with | "Array","get" -> false; | "Array","set" -> false; | _,_ -> true) ; | Pexp_apply ({pexp_desc=Pexp_ident ({ txt = Longident.Lident(funname) })},_) -> (match funname with | "!" -> false; | _ -> true); | Pexp_apply (_,_) -> true; | Pexp_match (_,_) -> true; | Pexp_tuple (_) -> true ; | Pexp_constraint (_,_,_) -> true ; | _ -> false) in if (already_has_parens) then expression ppf e else begin fprintf ppf "(" ; expression ppf e ; fprintf ppf ")" ; end ; and pattern_in_parens ppf p = let already_has_parens = match p.ppat_desc with | Ppat_alias (_,_) -> true | Ppat_tuple (_) -> true | Ppat_or (_,_) -> true | Ppat_constraint (_,_) -> true | _ -> false in if (already_has_parens) then pattern ppf p else begin fprintf ppf "(" ; pattern ppf p ; fprintf ppf ")" ; end; and pattern_constr_params_option ppf po = match po with | None -> (); | Some pat -> pp_print_space ppf (); pattern_in_parens ppf pat; and type_variant_helper ppf x = match x with | Rtag (l, b, ctl) -> (* is b important? *) pp_open_hovbox ppf indent ; fprintf ppf "`%s" l ; if ((List.length ctl) != 0) then begin fprintf ppf " of@ " ; list2 core_type ppf ctl " *" ; end ; pp_close_box ppf () ; | Rinherit (ct) -> core_type ppf ct (* prints a list of definitions as found in a let statement note! breaks "open and close boxes in same function" convention, however does always open and close the same number of boxes. (i.e. no "net gain or loss" of box depth. *) and pattern_x_expression_def_list ppf l = match l with | [] -> () | hd :: tl -> pp_close_box ppf () ; pp_print_space ppf () ; pp_open_hvbox ppf indent ; fprintf ppf "and " ; pattern_x_expression_def ppf hd; pattern_x_expression_def_list ppf tl ; (* end an if statement by printing an else phrase if there is an "else" statement in the ast. otherwise just close the box. *) (* added: special case for "else if" case *) and expression_eo ppf eo extra = match eo with | None -> (); | Some x -> if extra then fprintf ppf " " else fprintf ppf "@ " ; match x.pexp_desc with | Pexp_ifthenelse (e1, e2, eo) -> (* ... else if ...*) fprintf ppf "else" ; expression_elseif ppf (e1, e2, eo) | Pexp_sequence (e1, e2) -> fprintf ppf "else" ; expression_ifbegin ppf x; (* ... else begin ... end*) | _ -> (* ... else ... *) pp_open_hvbox ppf indent ; fprintf ppf "else@ " ; expression ppf x ; pp_close_box ppf () ; and expression_elseif ppf (e1,e2,eo) = fprintf ppf " " ; expression_if_common ppf e1 e2 eo ; and expression_ifbegin ppf e = fprintf ppf " begin"; pp_print_break ppf 1 indent ; (* "@;<1 2>"; *) expression_sequence ppf e; pp_print_break ppf 1 0 ; (* fprintf ppf "@;<1 0>" *) fprintf ppf "end"; and expression_if_common ppf e1 e2 eo = match eo, e2.pexp_desc with | None, Pexp_sequence (_, _) -> fprintf ppf "if@ " ; expression ppf e1; fprintf ppf "@ then@ " ; expression_ifbegin ppf e2 | None, _ -> fprintf ppf "if@ " ; expression ppf e1; fprintf ppf "@ then@ " ; simple_expr ppf e2 | Some _, Pexp_sequence _ -> fprintf ppf "if " ; expression ppf e1; fprintf ppf "@ then@ " ; expression_ifbegin ppf e2; expression_eo ppf eo true; (* ... then begin ... end *) | Some _, _ -> pp_open_hvbox ppf indent ; fprintf ppf "if " ; expression ppf e1; fprintf ppf " then@ " ; simple_expr ppf e2; pp_close_box ppf () ; expression_eo ppf eo false; and expression_sequence ppf ?(skip=1) ?(indent=indent) ?(first=true) expr = if (first = true) then begin pp_open_hvbox ppf 0 ; expression_sequence ppf ~skip:skip ~indent:0 ~first:false expr ; pp_close_box ppf () ; end else match expr.pexp_desc with | Pexp_sequence (e1, e2) -> simple_expr ppf e1 ; fprintf ppf ";" ; pp_print_break ppf skip indent ; (* "@;<1 2>" ; *) expression_sequence ppf ~skip:skip ~indent:indent ~first:false e2 ; | _ -> expression ppf expr ; and expression_list_helper ppf exp = match exp with | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("[]") }, None, _)} -> () ; | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("::") }, Some({pexp_desc = Pexp_tuple([exp1 ; exp2])}), _)} -> fprintf ppf ";@ " ; simple_expr ppf exp1 ; expression_list_helper ppf exp2 ; | {pexp_desc = _} -> assert false; and expression_list_nonterminal ppf exp = match exp with | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("[]") }, None, _)} -> fprintf ppf "[]" ; (* assert false; *) | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("::") }, Some({pexp_desc = Pexp_tuple([exp1 ; exp2])}), _)} -> simple_expr ppf exp1; fprintf ppf " ::@ "; expression_list_nonterminal ppf exp2; | {pexp_desc = _} -> expression ppf exp; ; and directive_argument ppf x = match x with | Pdir_none -> () | Pdir_string (s) -> fprintf ppf "@ \"%s\"" s; | Pdir_int (i) -> fprintf ppf "@ %d" i; | Pdir_ident (li) -> fprintf ppf "@ %a" fmt_longident_aux li; | Pdir_bool (b) -> fprintf ppf "@ %s" (string_of_bool b); and string_x_core_type_list ppf (s, l) = string ppf s; list core_type ppf l; and string_list_x_location ppf (l, loc) = line 0 ppf " %a\n" fmt_location loc; list string ppf l; and pattern_x_expression_case_single ppf (p, e) eo lbl = (match eo with None -> pattern_with_label ppf p lbl | Some x -> fprintf ppf "?" ; pp_open_hovbox ppf indent ; fprintf ppf "(" ; begin match p.ppat_desc with Ppat_constraint ({ ppat_desc = Ppat_var s }, ct) -> fprintf ppf "%s@ :@ %a" s.txt core_type ct | Ppat_var s -> fprintf ppf "%s" s.txt | _ -> assert false end; fprintf ppf " =@ " ; expression ppf x ; fprintf ppf ")" ; pp_close_box ppf () ) ; fprintf ppf " ->@ " ; expression_sequence ppf ~indent:0 e ;; let rec toplevel_phrase ppf x = match x with | Ptop_def (s) -> pp_open_hvbox ppf 0; list2 structure_item ppf s ~breakfirst:false ~indent:0 ""; pp_close_box ppf (); | Ptop_dir (s, da) -> pp_open_hovbox ppf indent; fprintf ppf "#%s" s; directive_argument ppf da; pp_close_box ppf () ;; let expression ppf x = fprintf ppf "@["; expression ppf x; fprintf ppf "@]";; let string_of_expression x = ignore (flush_str_formatter ()) ; let ppf = str_formatter in expression ppf x ; flush_str_formatter () ;; let toplevel_phrase ppf x = pp_print_newline ppf () ; toplevel_phrase ppf x; fprintf ppf ";;" ; pp_print_newline ppf ();; let print_structure = structure let print_signature = signature mingw-ocaml/ocaml/tools/magic0000644000175000017500000000113412124403240015617 0ustar tootstoots# Here are some definitions that can be added to the /usr/share/magic # database so that the file(1) command recognizes OCaml compiled files. # Contributed by Sven Luther. 0 string Caml1999 OCaml >8 string X bytecode executable >8 string I interface data (.cmi) >8 string O bytecode object data (.cmo) >8 string A bytecode library data (.cma) >8 string Y native object data (.cmx) >8 string Z native library data (.cmxa) >9 string >\0 (Version %3.3s). mingw-ocaml/ocaml/tools/typedtreeIter.ml0000644000175000017500000005404612124403240020011 0ustar tootstoots(**************************************************************************) (* *) (* OCaml *) (* *) (* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (**************************************************************************) (* TODO: - 2012/05/10: Follow camlp4 way of building map and iter using classes and inheritance ? *) open Asttypes open Typedtree module type IteratorArgument = sig val enter_structure : structure -> unit val enter_value_description : value_description -> unit val enter_type_declaration : type_declaration -> unit val enter_exception_declaration : exception_declaration -> unit val enter_pattern : pattern -> unit val enter_expression : expression -> unit val enter_package_type : package_type -> unit val enter_signature : signature -> unit val enter_signature_item : signature_item -> unit val enter_modtype_declaration : modtype_declaration -> unit val enter_module_type : module_type -> unit val enter_module_expr : module_expr -> unit val enter_with_constraint : with_constraint -> unit val enter_class_expr : class_expr -> unit val enter_class_signature : class_signature -> unit val enter_class_declaration : class_declaration -> unit val enter_class_description : class_description -> unit val enter_class_type_declaration : class_type_declaration -> unit val enter_class_type : class_type -> unit val enter_class_type_field : class_type_field -> unit val enter_core_type : core_type -> unit val enter_core_field_type : core_field_type -> unit val enter_class_structure : class_structure -> unit val enter_class_field : class_field -> unit val enter_structure_item : structure_item -> unit val leave_structure : structure -> unit val leave_value_description : value_description -> unit val leave_type_declaration : type_declaration -> unit val leave_exception_declaration : exception_declaration -> unit val leave_pattern : pattern -> unit val leave_expression : expression -> unit val leave_package_type : package_type -> unit val leave_signature : signature -> unit val leave_signature_item : signature_item -> unit val leave_modtype_declaration : modtype_declaration -> unit val leave_module_type : module_type -> unit val leave_module_expr : module_expr -> unit val leave_with_constraint : with_constraint -> unit val leave_class_expr : class_expr -> unit val leave_class_signature : class_signature -> unit val leave_class_declaration : class_declaration -> unit val leave_class_description : class_description -> unit val leave_class_type_declaration : class_type_declaration -> unit val leave_class_type : class_type -> unit val leave_class_type_field : class_type_field -> unit val leave_core_type : core_type -> unit val leave_core_field_type : core_field_type -> unit val leave_class_structure : class_structure -> unit val leave_class_field : class_field -> unit val leave_structure_item : structure_item -> unit val enter_bindings : rec_flag -> unit val enter_binding : pattern -> expression -> unit val leave_binding : pattern -> expression -> unit val leave_bindings : rec_flag -> unit end module MakeIterator(Iter : IteratorArgument) : sig val iter_structure : structure -> unit val iter_signature : signature -> unit val iter_structure_item : structure_item -> unit val iter_signature_item : signature_item -> unit val iter_expression : expression -> unit val iter_module_type : module_type -> unit val iter_pattern : pattern -> unit val iter_class_expr : class_expr -> unit end = struct let may_iter f v = match v with None -> () | Some x -> f x open Misc open Asttypes let rec iter_structure str = Iter.enter_structure str; List.iter iter_structure_item str.str_items; Iter.leave_structure str and iter_binding (pat, exp) = Iter.enter_binding pat exp; iter_pattern pat; iter_expression exp; Iter.leave_binding pat exp and iter_bindings rec_flag list = Iter.enter_bindings rec_flag; List.iter iter_binding list; Iter.leave_bindings rec_flag and iter_structure_item item = Iter.enter_structure_item item; begin match item.str_desc with Tstr_eval exp -> iter_expression exp | Tstr_value (rec_flag, list) -> iter_bindings rec_flag list | Tstr_primitive (id, _, v) -> iter_value_description v | Tstr_type list -> List.iter (fun (id, _, decl) -> iter_type_declaration decl) list | Tstr_exception (id, _, decl) -> iter_exception_declaration decl | Tstr_exn_rebind (id, _, p, _) -> () | Tstr_module (id, _, mexpr) -> iter_module_expr mexpr | Tstr_recmodule list -> List.iter (fun (id, _, mtype, mexpr) -> iter_module_type mtype; iter_module_expr mexpr) list | Tstr_modtype (id, _, mtype) -> iter_module_type mtype | Tstr_open _ -> () | Tstr_class list -> List.iter (fun (ci, _, _) -> Iter.enter_class_declaration ci; iter_class_expr ci.ci_expr; Iter.leave_class_declaration ci; ) list | Tstr_class_type list -> List.iter (fun (id, _, ct) -> Iter.enter_class_type_declaration ct; iter_class_type ct.ci_expr; Iter.leave_class_type_declaration ct; ) list | Tstr_include (mexpr, _) -> iter_module_expr mexpr end; Iter.leave_structure_item item and iter_value_description v = Iter.enter_value_description v; iter_core_type v.val_desc; Iter.leave_value_description v and iter_type_declaration decl = Iter.enter_type_declaration decl; List.iter (fun (ct1, ct2, loc) -> iter_core_type ct1; iter_core_type ct2 ) decl.typ_cstrs; begin match decl.typ_kind with Ttype_abstract -> () | Ttype_variant list -> List.iter (fun (s, _, cts, loc) -> List.iter iter_core_type cts ) list | Ttype_record list -> List.iter (fun (s, _, mut, ct, loc) -> iter_core_type ct ) list end; begin match decl.typ_manifest with None -> () | Some ct -> iter_core_type ct end; Iter.leave_type_declaration decl and iter_exception_declaration decl = Iter.enter_exception_declaration decl; List.iter iter_core_type decl.exn_params; Iter.leave_exception_declaration decl; and iter_pattern pat = Iter.enter_pattern pat; List.iter (fun (cstr, _) -> match cstr with | Tpat_type _ -> () | Tpat_unpack -> () | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra; begin match pat.pat_desc with Tpat_any -> () | Tpat_var (id, _) -> () | Tpat_alias (pat1, _, _) -> iter_pattern pat1 | Tpat_constant cst -> () | Tpat_tuple list -> List.iter iter_pattern list | Tpat_construct (path, _, _, args, _) -> List.iter iter_pattern args | Tpat_variant (label, pato, _) -> begin match pato with None -> () | Some pat -> iter_pattern pat end | Tpat_record (list, closed) -> List.iter (fun (path, _, _, pat) -> iter_pattern pat) list | Tpat_array list -> List.iter iter_pattern list | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2 | Tpat_lazy p -> iter_pattern p end; Iter.leave_pattern pat and option f x = match x with None -> () | Some e -> f e and iter_expression exp = Iter.enter_expression exp; List.iter (function (cstr, _) -> match cstr with Texp_constraint (cty1, cty2) -> option iter_core_type cty1; option iter_core_type cty2 | Texp_open (path, _, _) -> () | Texp_poly cto -> option iter_core_type cto | Texp_newtype s -> ()) exp.exp_extra; begin match exp.exp_desc with Texp_ident (path, _, _) -> () | Texp_constant cst -> () | Texp_let (rec_flag, list, exp) -> iter_bindings rec_flag list; iter_expression exp | Texp_function (label, cases, _) -> iter_bindings Nonrecursive cases | Texp_apply (exp, list) -> iter_expression exp; List.iter (fun (label, expo, _) -> match expo with None -> () | Some exp -> iter_expression exp ) list | Texp_match (exp, list, _) -> iter_expression exp; iter_bindings Nonrecursive list | Texp_try (exp, list) -> iter_expression exp; iter_bindings Nonrecursive list | Texp_tuple list -> List.iter iter_expression list | Texp_construct (path, _, _, args, _) -> List.iter iter_expression args | Texp_variant (label, expo) -> begin match expo with None -> () | Some exp -> iter_expression exp end | Texp_record (list, expo) -> List.iter (fun (path, _, _, exp) -> iter_expression exp ) list; begin match expo with None -> () | Some exp -> iter_expression exp end | Texp_field (exp, path, _, label) -> iter_expression exp | Texp_setfield (exp1, path, _ , label, exp2) -> iter_expression exp1; iter_expression exp2 | Texp_array list -> List.iter iter_expression list | Texp_ifthenelse (exp1, exp2, expo) -> iter_expression exp1; iter_expression exp2; begin match expo with None -> () | Some exp -> iter_expression exp end | Texp_sequence (exp1, exp2) -> iter_expression exp1; iter_expression exp2 | Texp_while (exp1, exp2) -> iter_expression exp1; iter_expression exp2 | Texp_for (id, _, exp1, exp2, dir, exp3) -> iter_expression exp1; iter_expression exp2; iter_expression exp3 | Texp_when (exp1, exp2) -> iter_expression exp1; iter_expression exp2 | Texp_send (exp, meth, expo) -> iter_expression exp; begin match expo with None -> () | Some exp -> iter_expression exp end | Texp_new (path, _, _) -> () | Texp_instvar (_, path, _) -> () | Texp_setinstvar (_, _, _, exp) -> iter_expression exp | Texp_override (_, list) -> List.iter (fun (path, _, exp) -> iter_expression exp ) list | Texp_letmodule (id, _, mexpr, exp) -> iter_module_expr mexpr; iter_expression exp | Texp_assert exp -> iter_expression exp | Texp_assertfalse -> () | Texp_lazy exp -> iter_expression exp | Texp_object (cl, _) -> iter_class_structure cl | Texp_pack (mexpr) -> iter_module_expr mexpr end; Iter.leave_expression exp; and iter_package_type pack = Iter.enter_package_type pack; List.iter (fun (s, ct) -> iter_core_type ct) pack.pack_fields; Iter.leave_package_type pack; and iter_signature sg = Iter.enter_signature sg; List.iter iter_signature_item sg.sig_items; Iter.leave_signature sg; and iter_signature_item item = Iter.enter_signature_item item; begin match item.sig_desc with Tsig_value (id, _, v) -> iter_value_description v | Tsig_type list -> List.iter (fun (id, _, decl) -> iter_type_declaration decl ) list | Tsig_exception (id, _, decl) -> iter_exception_declaration decl | Tsig_module (id, _, mtype) -> iter_module_type mtype | Tsig_recmodule list -> List.iter (fun (id, _, mtype) -> iter_module_type mtype) list | Tsig_modtype (id, _, mdecl) -> iter_modtype_declaration mdecl | Tsig_open _ -> () | Tsig_include (mty,_) -> iter_module_type mty | Tsig_class list -> List.iter iter_class_description list | Tsig_class_type list -> List.iter iter_class_type_declaration list end; Iter.leave_signature_item item; and iter_modtype_declaration mdecl = Iter.enter_modtype_declaration mdecl; begin match mdecl with Tmodtype_abstract -> () | Tmodtype_manifest mtype -> iter_module_type mtype end; Iter.leave_modtype_declaration mdecl; and iter_class_description cd = Iter.enter_class_description cd; iter_class_type cd.ci_expr; Iter.leave_class_description cd; and iter_class_type_declaration cd = Iter.enter_class_type_declaration cd; iter_class_type cd.ci_expr; Iter.leave_class_type_declaration cd; and iter_module_type mty = Iter.enter_module_type mty; begin match mty.mty_desc with Tmty_ident (path, _) -> () | Tmty_signature sg -> iter_signature sg | Tmty_functor (id, _, mtype1, mtype2) -> iter_module_type mtype1; iter_module_type mtype2 | Tmty_with (mtype, list) -> iter_module_type mtype; List.iter (fun (path, _, withc) -> iter_with_constraint withc ) list | Tmty_typeof mexpr -> iter_module_expr mexpr end; Iter.leave_module_type mty; and iter_with_constraint cstr = Iter.enter_with_constraint cstr; begin match cstr with Twith_type decl -> iter_type_declaration decl | Twith_module _ -> () | Twith_typesubst decl -> iter_type_declaration decl | Twith_modsubst _ -> () end; Iter.leave_with_constraint cstr; and iter_module_expr mexpr = Iter.enter_module_expr mexpr; begin match mexpr.mod_desc with Tmod_ident (p, _) -> () | Tmod_structure st -> iter_structure st | Tmod_functor (id, _, mtype, mexpr) -> iter_module_type mtype; iter_module_expr mexpr | Tmod_apply (mexp1, mexp2, _) -> iter_module_expr mexp1; iter_module_expr mexp2 | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) -> iter_module_expr mexpr | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> iter_module_expr mexpr; iter_module_type mtype | Tmod_unpack (exp, mty) -> iter_expression exp (* iter_module_type mty *) end; Iter.leave_module_expr mexpr; and iter_class_expr cexpr = Iter.enter_class_expr cexpr; begin match cexpr.cl_desc with | Tcl_constraint (cl, None, _, _, _ ) -> iter_class_expr cl; | Tcl_structure clstr -> iter_class_structure clstr | Tcl_fun (label, pat, priv, cl, partial) -> iter_pattern pat; List.iter (fun (id, _, exp) -> iter_expression exp) priv; iter_class_expr cl | Tcl_apply (cl, args) -> iter_class_expr cl; List.iter (fun (label, expo, _) -> match expo with None -> () | Some exp -> iter_expression exp ) args | Tcl_let (rec_flat, bindings, ivars, cl) -> iter_bindings rec_flat bindings; List.iter (fun (id, _, exp) -> iter_expression exp) ivars; iter_class_expr cl | Tcl_constraint (cl, Some clty, vals, meths, concrs) -> iter_class_expr cl; iter_class_type clty | Tcl_ident (_, _, tyl) -> List.iter iter_core_type tyl end; Iter.leave_class_expr cexpr; and iter_class_type ct = Iter.enter_class_type ct; begin match ct.cltyp_desc with Tcty_signature csg -> iter_class_signature csg | Tcty_constr (path, _, list) -> List.iter iter_core_type list | Tcty_fun (label, ct, cl) -> iter_core_type ct; iter_class_type cl end; Iter.leave_class_type ct; and iter_class_signature cs = Iter.enter_class_signature cs; iter_core_type cs.csig_self; List.iter iter_class_type_field cs.csig_fields; Iter.leave_class_signature cs and iter_class_type_field ctf = Iter.enter_class_type_field ctf; begin match ctf.ctf_desc with Tctf_inher ct -> iter_class_type ct | Tctf_val (s, mut, virt, ct) -> iter_core_type ct | Tctf_virt (s, priv, ct) -> iter_core_type ct | Tctf_meth (s, priv, ct) -> iter_core_type ct | Tctf_cstr (ct1, ct2) -> iter_core_type ct1; iter_core_type ct2 end; Iter.leave_class_type_field ctf and iter_core_type ct = Iter.enter_core_type ct; begin match ct.ctyp_desc with Ttyp_any -> () | Ttyp_var s -> () | Ttyp_arrow (label, ct1, ct2) -> iter_core_type ct1; iter_core_type ct2 | Ttyp_tuple list -> List.iter iter_core_type list | Ttyp_constr (path, _, list) -> List.iter iter_core_type list | Ttyp_object list -> List.iter iter_core_field_type list | Ttyp_class (path, _, list, labels) -> List.iter iter_core_type list | Ttyp_alias (ct, s) -> iter_core_type ct | Ttyp_variant (list, bool, labels) -> List.iter iter_row_field list | Ttyp_poly (list, ct) -> iter_core_type ct | Ttyp_package pack -> iter_package_type pack end; Iter.leave_core_type ct; and iter_core_field_type cft = Iter.enter_core_field_type cft; begin match cft.field_desc with Tcfield_var -> () | Tcfield (s, ct) -> iter_core_type ct end; Iter.leave_core_field_type cft; and iter_class_structure cs = Iter.enter_class_structure cs; iter_pattern cs.cstr_pat; List.iter iter_class_field cs.cstr_fields; Iter.leave_class_structure cs; and iter_row_field rf = match rf with Ttag (label, bool, list) -> List.iter iter_core_type list | Tinherit ct -> iter_core_type ct and iter_class_field cf = Iter.enter_class_field cf; begin match cf.cf_desc with Tcf_inher (ovf, cl, super, _vals, _meths) -> iter_class_expr cl | Tcf_constr (cty, cty') -> iter_core_type cty; iter_core_type cty' | Tcf_val (lab, _, _, mut, Tcfk_virtual cty, override) -> iter_core_type cty | Tcf_val (lab, _, _, mut, Tcfk_concrete exp, override) -> iter_expression exp | Tcf_meth (lab, _, priv, Tcfk_virtual cty, override) -> iter_core_type cty | Tcf_meth (lab, _, priv, Tcfk_concrete exp, override) -> iter_expression exp (* | Tcf_let (rec_flag, bindings, exps) -> iter_bindings rec_flag bindings; List.iter (fun (id, _, exp) -> iter_expression exp) exps; *) | Tcf_init exp -> iter_expression exp end; Iter.leave_class_field cf; end module DefaultIteratorArgument = struct let enter_structure _ = () let enter_value_description _ = () let enter_type_declaration _ = () let enter_exception_declaration _ = () let enter_pattern _ = () let enter_expression _ = () let enter_package_type _ = () let enter_signature _ = () let enter_signature_item _ = () let enter_modtype_declaration _ = () let enter_module_type _ = () let enter_module_expr _ = () let enter_with_constraint _ = () let enter_class_expr _ = () let enter_class_signature _ = () let enter_class_declaration _ = () let enter_class_description _ = () let enter_class_type_declaration _ = () let enter_class_type _ = () let enter_class_type_field _ = () let enter_core_type _ = () let enter_core_field_type _ = () let enter_class_structure _ = () let enter_class_field _ = () let enter_structure_item _ = () let leave_structure _ = () let leave_value_description _ = () let leave_type_declaration _ = () let leave_exception_declaration _ = () let leave_pattern _ = () let leave_expression _ = () let leave_package_type _ = () let leave_signature _ = () let leave_signature_item _ = () let leave_modtype_declaration _ = () let leave_module_type _ = () let leave_module_expr _ = () let leave_with_constraint _ = () let leave_class_expr _ = () let leave_class_signature _ = () let leave_class_declaration _ = () let leave_class_description _ = () let leave_class_type_declaration _ = () let leave_class_type _ = () let leave_class_type_field _ = () let leave_core_type _ = () let leave_core_field_type _ = () let leave_class_structure _ = () let leave_class_field _ = () let leave_structure_item _ = () let enter_binding _ _ = () let leave_binding _ _ = () let enter_bindings _ = () let leave_bindings _ = () end mingw-ocaml/ocaml/tools/Makefile.shared0000644000175000017500000002041612124403240017525 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # $Id$ include ../config/Makefile CAMLRUN=../boot/ocamlrun CAMLC=$(CAMLRUN) ../boot/ocamlc -strict-sequence -nostdlib -I ../boot CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib CAMLLEX=$(CAMLRUN) ../boot/ocamllex INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \ -I ../driver COMPFLAGS= -warn-error A $(INCLUDES) LINKFLAGS=$(INCLUDES) all: ocamldep ocamlprof ocamlcp ocamloptp ocamlmktop ocamlmklib dumpobj \ objinfo read_cmt # scrapelabels addlabels .PHONY: all opt.opt: ocamldep.opt .PHONY: opt.opt # The dependency generator CAMLDEP_OBJ=depend.cmo ocamldep.cmo CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ warnings.cmo location.cmo longident.cmo \ syntaxerr.cmo parser.cmo lexer.cmo parse.cmo ocamldep: depend.cmi $(CAMLDEP_OBJ) $(CAMLC) $(LINKFLAGS) -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ) ocamldep.opt: depend.cmi $(CAMLDEP_OBJ:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) -o ocamldep.opt $(CAMLDEP_IMPORTS:.cmo=.cmx) \ $(CAMLDEP_OBJ:.cmo=.cmx) # ocamldep is precious: sometimes we are stuck in the middle of a # bootstrap and we need to remake the dependencies clean:: if test -f ocamldep; then mv -f ocamldep ocamldep.bak; else :; fi rm -f ocamldep.opt install:: cp ocamldep $(BINDIR)/ocamldep$(EXE) if test -f ocamldep.opt; \ then cp ocamldep.opt $(BINDIR)/ocamldep.opt$(EXE); else :; fi # The profiler CSLPROF=ocamlprof.cmo CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ warnings.cmo location.cmo longident.cmo \ syntaxerr.cmo parser.cmo lexer.cmo parse.cmo ocamlprof: $(CSLPROF) profiling.cmo $(CAMLC) $(LINKFLAGS) -o ocamlprof $(CSLPROF_IMPORTS) $(CSLPROF) ocamlcp: ocamlcp.cmo $(CAMLC) $(LINKFLAGS) -o ocamlcp warnings.cmo main_args.cmo ocamlcp.cmo ocamloptp: ocamloptp.cmo $(CAMLC) $(LINKFLAGS) -o ocamloptp warnings.cmo main_args.cmo \ ocamloptp.cmo opt:: profiling.cmx install:: cp ocamlprof $(BINDIR)/ocamlprof$(EXE) cp ocamlcp $(BINDIR)/ocamlcp$(EXE) cp ocamloptp $(BINDIR)/ocamloptp$(EXE) cp profiling.cmi profiling.cmo $(LIBDIR) installopt:: cp profiling.cmx profiling.o $(LIBDIR) clean:: rm -f ocamlprof ocamlcp ocamloptp # To help building mixed-mode libraries (OCaml + C) ocamlmklib: myocamlbuild_config.cmo ocamlmklib.cmo $(CAMLC) $(LINKFLAGS) -o ocamlmklib myocamlbuild_config.cmo \ ocamlmklib.cmo ocamlmklib.cmo: myocamlbuild_config.cmi myocamlbuild_config.cmi: myocamlbuild_config.cmo myocamlbuild_config.ml: ../config/Makefile ../build/mkmyocamlbuild_config.sh ../build/mkmyocamlbuild_config.sh cp ../myocamlbuild_config.ml . install:: cp ocamlmklib $(BINDIR)/ocamlmklib$(EXE) clean:: rm -f ocamlmklib ocamlmklib.ml: ocamlmklib.mlp ../config/Makefile echo '(* THIS FILE IS GENERATED FROM ocamlmklib.mlp *)' >ocamlmklib.ml sed -e "s|%%BINDIR%%|$(BINDIR)|" \ -e "s|%%SUPPORTS_SHARED_LIBRARIES%%|$(SUPPORTS_SHARED_LIBRARIES)|" \ -e "s|%%MKSHAREDLIB%%|$(MKSHAREDLIB)|" \ -e "s|%%BYTECCRPATH%%|$(BYTECCRPATH)|" \ -e "s|%%NATIVECCRPATH%%|$(NATIVECCRPATH)|" \ -e "s|%%MKSHAREDLIBRPATH%%|$(MKSHAREDLIBRPATH)|" \ -e "s|%%RANLIB%%|$(RANLIB)|" \ ocamlmklib.mlp >> ocamlmklib.ml beforedepend:: ocamlmklib.ml clean:: rm -f ocamlmklib.ml # Converter olabl/ocaml 2.99 to ocaml 3 OCAML299TO3= lexer299.cmo ocaml299to3.cmo LIBRARY3= misc.cmo warnings.cmo location.cmo ocaml299to3: $(OCAML299TO3) $(CAMLC) $(LINKFLAGS) -o ocaml299to3 $(LIBRARY3) $(OCAML299TO3) lexer299.ml: lexer299.mll $(CAMLLEX) lexer299.mll #install:: # cp ocaml299to3 $(BINDIR)/ocaml299to3$(EXE) clean:: rm -f ocaml299to3 lexer299.ml # Label remover for interface files (upgrade 3.02 to 3.03) SCRAPELABELS= lexer301.cmo scrapelabels.cmo scrapelabels: $(SCRAPELABELS) $(CAMLC) $(LINKFLAGS) -o scrapelabels $(LIBRARY3) $(SCRAPELABELS) lexer301.ml: lexer301.mll $(CAMLLEX) lexer301.mll #install:: # cp scrapelabels $(LIBDIR) clean:: rm -f scrapelabels lexer301.ml # Insert labels following an interface file (upgrade 3.02 to 3.03) ADDLABELS_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ warnings.cmo location.cmo longident.cmo \ syntaxerr.cmo parser.cmo lexer.cmo parse.cmo addlabels: addlabels.cmo $(CAMLC) $(LINKFLAGS) -w sl -o addlabels \ $(ADDLABELS_IMPORTS) addlabels.cmo #install:: # cp addlabels $(LIBDIR) clean:: rm -f addlabels # The preprocessor for asm generators CVT_EMIT=cvt_emit.cmo cvt_emit: $(CVT_EMIT) $(CAMLC) $(LINKFLAGS) -o cvt_emit $(CVT_EMIT) # cvt_emit is precious: sometimes we are stuck in the middle of a # bootstrap and we need to remake the dependencies clean:: if test -f cvt_emit; then mv -f cvt_emit cvt_emit.bak; else :; fi cvt_emit.ml: cvt_emit.mll $(CAMLLEX) cvt_emit.mll clean:: rm -f cvt_emit.ml beforedepend:: cvt_emit.ml # Reading cmt files READ_CMT= \ ../utils/misc.cmo \ ../utils/warnings.cmo \ ../utils/tbl.cmo \ ../utils/consistbl.cmo \ ../utils/config.cmo \ ../utils/clflags.cmo \ ../parsing/location.cmo \ ../parsing/longident.cmo \ ../parsing/lexer.cmo \ ../typing/ident.cmo \ ../typing/path.cmo \ ../typing/types.cmo \ ../typing/typedtree.cmo \ ../typing/btype.cmo \ ../typing/subst.cmo \ ../typing/predef.cmo \ ../typing/datarepr.cmo \ ../typing/cmi_format.cmo \ ../typing/env.cmo \ ../typing/ctype.cmo \ ../typing/oprint.cmo \ ../typing/primitive.cmo \ ../typing/printtyp.cmo \ ../typing/cmt_format.cmo \ ../typing/stypes.cmo \ \ pprintast.cmo untypeast.cmo typedtreeIter.cmo \ cmt2annot.cmo read_cmt.cmo read_cmt: $(READ_CMT) $(CAMLC) $(LINKFLAGS) -o read_cmt $(READ_CMT) clean:: rm -f read_cmt beforedepend:: # The bytecode disassembler DUMPOBJ=opnames.cmo dumpobj.cmo dumpobj: $(DUMPOBJ) $(CAMLC) $(LINKFLAGS) -o dumpobj \ misc.cmo tbl.cmo config.cmo ident.cmo \ opcodes.cmo bytesections.cmo $(DUMPOBJ) clean:: rm -f dumpobj opnames.ml: ../byterun/instruct.h unset LC_ALL || : ; \ unset LC_CTYPE || : ; \ unset LC_COLLATE LANG || : ; \ sed -e '/\/\*/d' \ -e '/^#/d' \ -e 's/enum \(.*\) {/let names_of_\1 = [|/' \ -e 's/};$$/ |]/' \ -e 's/\([A-Z][A-Z_0-9a-z]*\)/"\1"/g' \ -e 's/,/;/g' \ ../byterun/instruct.h > opnames.ml clean:: rm -f opnames.ml beforedepend:: opnames.ml # Display info on compiled files objinfo_helper$(EXE): objinfo_helper.c ../config/s.h $(BYTECC) -o objinfo_helper$(EXE) $(BYTECCCOMPOPTS) \ objinfo_helper.c $(LIBBFD_LINK) OBJINFO=../utils/misc.cmo ../utils/config.cmo \ ../utils/warnings.cmo ../parsing/location.cmo \ ../typing/cmi_format.cmo ../bytecomp/bytesections.cmo \ objinfo.cmo objinfo: objinfo_helper$(EXE) $(OBJINFO) $(CAMLC) -o objinfo $(OBJINFO) install:: cp objinfo $(BINDIR)/ocamlobjinfo$(EXE) cp objinfo_helper$(EXE) $(LIBDIR)/objinfo_helper$(EXE) clean:: rm -f objinfo objinfo_helper$(EXE) # Scan object files for required primitives PRIMREQ=primreq.cmo primreq: $(PRIMREQ) $(CAMLC) $(LINKFLAGS) -o primreq config.cmo $(PRIMREQ) clean:: rm -f primreq # Common stuff .SUFFIXES: .SUFFIXES: .ml .cmo .mli .cmi .cmx .ml.cmo: $(CAMLC) -c $(COMPFLAGS) $< .mli.cmi: $(CAMLC) -c $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) $(COMPFLAGS) -c $< clean:: rm -f *.cmo *.cmi *.cma *.dll *.so *.lib *.a depend: beforedepend $(CAMLRUN) ./ocamldep $(INCLUDES) *.mli *.ml > .depend .PHONY: clean install beforedepend depend include .depend mingw-ocaml/ocaml/tools/untypeast.ml0000644000175000017500000004725712124403240017222 0ustar tootstoots(**************************************************************************) (* *) (* OCaml *) (* *) (* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (**************************************************************************) open Misc open Asttypes open Typedtree open Parsetree (* Some notes: * For Pexp_function, we cannot go back to the exact original version when there is a default argument, because the default argument is translated in the typer. The code, if printed, will not be parsable because new generated identifiers are not correct. * For Pexp_apply, it is unclear whether arguments are reordered, especially when there are optional arguments. * TODO: check Ttype_variant -> Ptype_variant (stub None) *) let rec lident_of_path path = match path with Path.Pident id -> Longident.Lident (Ident.name id) | Path.Pdot (p, s, _) -> Longident.Ldot (lident_of_path p, s) | Path.Papply (p1, p2) -> Longident.Lapply (lident_of_path p1, lident_of_path p2) let rec untype_structure str = List.map untype_structure_item str.str_items and untype_structure_item item = let desc = match item.str_desc with Tstr_eval exp -> Pstr_eval (untype_expression exp) | Tstr_value (rec_flag, list) -> Pstr_value (rec_flag, List.map (fun (pat, exp) -> untype_pattern pat, untype_expression exp) list) | Tstr_primitive (id, name, v) -> Pstr_primitive (name, untype_value_description v) | Tstr_type list -> Pstr_type (List.map (fun (id, name, decl) -> name, untype_type_declaration decl) list) | Tstr_exception (id, name, decl) -> Pstr_exception (name, untype_exception_declaration decl) | Tstr_exn_rebind (id, name, p, lid) -> Pstr_exn_rebind (name, lid) | Tstr_module (id, name, mexpr) -> Pstr_module (name, untype_module_expr mexpr) | Tstr_recmodule list -> Pstr_recmodule (List.map (fun (id, name, mtype, mexpr) -> name, untype_module_type mtype, untype_module_expr mexpr) list) | Tstr_modtype (id, name, mtype) -> Pstr_modtype (name, untype_module_type mtype) | Tstr_open (path, lid) -> Pstr_open (lid) | Tstr_class list -> Pstr_class (List.map (fun (ci, _, _) -> { pci_virt = ci.ci_virt; pci_params = ci.ci_params; pci_name = ci.ci_id_name; pci_expr = untype_class_expr ci.ci_expr; pci_variance = ci.ci_variance; pci_loc = ci.ci_loc; } ) list) | Tstr_class_type list -> Pstr_class_type (List.map (fun (id, name, ct) -> { pci_virt = ct.ci_virt; pci_params = ct.ci_params; pci_name = ct.ci_id_name; pci_expr = untype_class_type ct.ci_expr; pci_variance = ct.ci_variance; pci_loc = ct.ci_loc; } ) list) | Tstr_include (mexpr, _) -> Pstr_include (untype_module_expr mexpr) in { pstr_desc = desc; pstr_loc = item.str_loc; } and untype_value_description v = { pval_prim = v.val_prim; pval_type = untype_core_type v.val_desc; pval_loc = v.val_loc } and untype_type_declaration decl = { ptype_params = decl.typ_params; ptype_cstrs = List.map (fun (ct1, ct2, loc) -> (untype_core_type ct1, untype_core_type ct2, loc) ) decl.typ_cstrs; ptype_kind = (match decl.typ_kind with Ttype_abstract -> Ptype_abstract | Ttype_variant list -> Ptype_variant (List.map (fun (s, name, cts, loc) -> (name, List.map untype_core_type cts, None, loc) ) list) | Ttype_record list -> Ptype_record (List.map (fun (s, name, mut, ct, loc) -> (name, mut, untype_core_type ct, loc) ) list) ); ptype_private = decl.typ_private; ptype_manifest = (match decl.typ_manifest with None -> None | Some ct -> Some (untype_core_type ct)); ptype_variance = decl.typ_variance; ptype_loc = decl.typ_loc; } and untype_exception_declaration decl = List.map untype_core_type decl.exn_params and untype_pattern pat = let desc = match pat with { pat_extra=[Tpat_unpack, _]; pat_desc = Tpat_var (_,name) } -> Ppat_unpack name | { pat_extra=[Tpat_type (path, lid), _] } -> Ppat_type lid | { pat_extra= (Tpat_constraint ct, _) :: rem } -> Ppat_constraint (untype_pattern { pat with pat_extra=rem }, untype_core_type ct) | _ -> match pat.pat_desc with Tpat_any -> Ppat_any | Tpat_var (id, name) -> begin match (Ident.name id).[0] with 'A'..'Z' -> Ppat_unpack name | _ -> Ppat_var name end | Tpat_alias (pat, id, name) -> Ppat_alias (untype_pattern pat, name) | Tpat_constant cst -> Ppat_constant cst | Tpat_tuple list -> Ppat_tuple (List.map untype_pattern list) | Tpat_construct (path, lid, _, args, explicit_arity) -> Ppat_construct (lid, (match args with [] -> None | args -> Some { ppat_desc = Ppat_tuple (List.map untype_pattern args); ppat_loc = pat.pat_loc; } ), explicit_arity) | Tpat_variant (label, pato, _) -> Ppat_variant (label, match pato with None -> None | Some pat -> Some (untype_pattern pat)) | Tpat_record (list, closed) -> Ppat_record (List.map (fun (path, lid, _, pat) -> lid, untype_pattern pat) list, closed) | Tpat_array list -> Ppat_array (List.map untype_pattern list) | Tpat_or (p1, p2, _) -> Ppat_or (untype_pattern p1, untype_pattern p2) | Tpat_lazy p -> Ppat_lazy (untype_pattern p) in { ppat_desc = desc; ppat_loc = pat.pat_loc; } and option f x = match x with None -> None | Some e -> Some (f e) and untype_extra (extra, loc) sexp = let desc = match extra with Texp_constraint (cty1, cty2) -> Pexp_constraint (sexp, option untype_core_type cty1, option untype_core_type cty2) | Texp_open (path, lid, _) -> Pexp_open (lid, sexp) | Texp_poly cto -> Pexp_poly (sexp, option untype_core_type cto) | Texp_newtype s -> Pexp_newtype (s, sexp) in { pexp_desc = desc; pexp_loc = loc } and untype_expression exp = let desc = match exp.exp_desc with Texp_ident (path, lid, _) -> Pexp_ident (lid) | Texp_constant cst -> Pexp_constant cst | Texp_let (rec_flag, list, exp) -> Pexp_let (rec_flag, List.map (fun (pat, exp) -> untype_pattern pat, untype_expression exp) list, untype_expression exp) | Texp_function (label, cases, _) -> Pexp_function (label, None, List.map (fun (pat, exp) -> (untype_pattern pat, untype_expression exp)) cases) | Texp_apply (exp, list) -> Pexp_apply (untype_expression exp, List.fold_right (fun (label, expo, _) list -> match expo with None -> list | Some exp -> (label, untype_expression exp) :: list ) list []) | Texp_match (exp, list, _) -> Pexp_match (untype_expression exp, List.map (fun (pat, exp) -> untype_pattern pat, untype_expression exp) list) | Texp_try (exp, list) -> Pexp_try (untype_expression exp, List.map (fun (pat, exp) -> untype_pattern pat, untype_expression exp) list) | Texp_tuple list -> Pexp_tuple (List.map untype_expression list) | Texp_construct (path, lid, _, args, explicit_arity) -> Pexp_construct (lid, (match args with [] -> None | [ arg ] -> Some (untype_expression arg) | args -> Some { pexp_desc = Pexp_tuple (List.map untype_expression args); pexp_loc = exp.exp_loc; } ), explicit_arity) | Texp_variant (label, expo) -> Pexp_variant (label, match expo with None -> None | Some exp -> Some (untype_expression exp)) | Texp_record (list, expo) -> Pexp_record (List.map (fun (path, lid, _, exp) -> lid, untype_expression exp ) list, match expo with None -> None | Some exp -> Some (untype_expression exp)) | Texp_field (exp, path, lid, label) -> Pexp_field (untype_expression exp, lid) | Texp_setfield (exp1, path, lid, label, exp2) -> Pexp_setfield (untype_expression exp1, lid, untype_expression exp2) | Texp_array list -> Pexp_array (List.map untype_expression list) | Texp_ifthenelse (exp1, exp2, expo) -> Pexp_ifthenelse (untype_expression exp1, untype_expression exp2, match expo with None -> None | Some exp -> Some (untype_expression exp)) | Texp_sequence (exp1, exp2) -> Pexp_sequence (untype_expression exp1, untype_expression exp2) | Texp_while (exp1, exp2) -> Pexp_while (untype_expression exp1, untype_expression exp2) | Texp_for (id, name, exp1, exp2, dir, exp3) -> Pexp_for (name, untype_expression exp1, untype_expression exp2, dir, untype_expression exp3) | Texp_when (exp1, exp2) -> Pexp_when (untype_expression exp1, untype_expression exp2) | Texp_send (exp, meth, _) -> Pexp_send (untype_expression exp, match meth with Tmeth_name name -> name | Tmeth_val id -> Ident.name id) | Texp_new (path, lid, _) -> Pexp_new (lid) | Texp_instvar (_, path, name) -> Pexp_ident ({name with txt = lident_of_path path}) | Texp_setinstvar (_, path, lid, exp) -> Pexp_setinstvar (lid, untype_expression exp) | Texp_override (_, list) -> Pexp_override (List.map (fun (path, lid, exp) -> lid, untype_expression exp ) list) | Texp_letmodule (id, name, mexpr, exp) -> Pexp_letmodule (name, untype_module_expr mexpr, untype_expression exp) | Texp_assert exp -> Pexp_assert (untype_expression exp) | Texp_assertfalse -> Pexp_assertfalse | Texp_lazy exp -> Pexp_lazy (untype_expression exp) | Texp_object (cl, _) -> Pexp_object (untype_class_structure cl) | Texp_pack (mexpr) -> Pexp_pack (untype_module_expr mexpr) in List.fold_right untype_extra exp.exp_extra { pexp_loc = exp.exp_loc; pexp_desc = desc } and untype_package_type pack = (pack.pack_txt, List.map (fun (s, ct) -> (s, untype_core_type ct)) pack.pack_fields) and untype_signature sg = List.map untype_signature_item sg.sig_items and untype_signature_item item = let desc = match item.sig_desc with Tsig_value (id, name, v) -> Psig_value (name, untype_value_description v) | Tsig_type list -> Psig_type (List.map (fun (id, name, decl) -> name, untype_type_declaration decl ) list) | Tsig_exception (id, name, decl) -> Psig_exception (name, untype_exception_declaration decl) | Tsig_module (id, name, mtype) -> Psig_module (name, untype_module_type mtype) | Tsig_recmodule list -> Psig_recmodule (List.map (fun (id, name, mtype) -> name, untype_module_type mtype) list) | Tsig_modtype (id, name, mdecl) -> Psig_modtype (name, untype_modtype_declaration mdecl) | Tsig_open (path, lid) -> Psig_open (lid) | Tsig_include (mty, lid) -> Psig_include (untype_module_type mty) | Tsig_class list -> Psig_class (List.map untype_class_description list) | Tsig_class_type list -> Psig_class_type (List.map untype_class_type_declaration list) in { psig_desc = desc; psig_loc = item.sig_loc; } and untype_modtype_declaration mdecl = match mdecl with Tmodtype_abstract -> Pmodtype_abstract | Tmodtype_manifest mtype -> Pmodtype_manifest (untype_module_type mtype) and untype_class_description cd = { pci_virt = cd.ci_virt; pci_params = cd.ci_params; pci_name = cd.ci_id_name; pci_expr = untype_class_type cd.ci_expr; pci_variance = cd.ci_variance; pci_loc = cd.ci_loc; } and untype_class_type_declaration cd = { pci_virt = cd.ci_virt; pci_params = cd.ci_params; pci_name = cd.ci_id_name; pci_expr = untype_class_type cd.ci_expr; pci_variance = cd.ci_variance; pci_loc = cd.ci_loc; } and untype_module_type mty = let desc = match mty.mty_desc with Tmty_ident (path, lid) -> Pmty_ident (lid) | Tmty_signature sg -> Pmty_signature (untype_signature sg) | Tmty_functor (id, name, mtype1, mtype2) -> Pmty_functor (name, untype_module_type mtype1, untype_module_type mtype2) | Tmty_with (mtype, list) -> Pmty_with (untype_module_type mtype, List.map (fun (path, lid, withc) -> lid, untype_with_constraint withc ) list) | Tmty_typeof mexpr -> Pmty_typeof (untype_module_expr mexpr) in { pmty_desc = desc; pmty_loc = mty.mty_loc; } and untype_with_constraint cstr = match cstr with Twith_type decl -> Pwith_type (untype_type_declaration decl) | Twith_module (path, lid) -> Pwith_module (lid) | Twith_typesubst decl -> Pwith_typesubst (untype_type_declaration decl) | Twith_modsubst (path, lid) -> Pwith_modsubst (lid) and untype_module_expr mexpr = match mexpr.mod_desc with Tmod_constraint (m, _, Tmodtype_implicit, _ ) -> untype_module_expr m | _ -> let desc = match mexpr.mod_desc with Tmod_ident (p, lid) -> Pmod_ident (lid) | Tmod_structure st -> Pmod_structure (untype_structure st) | Tmod_functor (id, name, mtype, mexpr) -> Pmod_functor (name, untype_module_type mtype, untype_module_expr mexpr) | Tmod_apply (mexp1, mexp2, _) -> Pmod_apply (untype_module_expr mexp1, untype_module_expr mexp2) | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> Pmod_constraint (untype_module_expr mexpr, untype_module_type mtype) | Tmod_constraint (mexpr, _, Tmodtype_implicit, _) -> assert false | Tmod_unpack (exp, pack) -> Pmod_unpack (untype_expression exp) (* TODO , untype_package_type pack) *) in { pmod_desc = desc; pmod_loc = mexpr.mod_loc; } and untype_class_expr cexpr = let desc = match cexpr.cl_desc with | Tcl_constraint ( { cl_desc = Tcl_ident (path, lid, tyl) }, None, _, _, _ ) -> Pcl_constr (lid, List.map untype_core_type tyl) | Tcl_structure clstr -> Pcl_structure (untype_class_structure clstr) | Tcl_fun (label, pat, pv, cl, partial) -> Pcl_fun (label, None, untype_pattern pat, untype_class_expr cl) | Tcl_apply (cl, args) -> Pcl_apply (untype_class_expr cl, List.fold_right (fun (label, expo, _) list -> match expo with None -> list | Some exp -> (label, untype_expression exp) :: list ) args []) | Tcl_let (rec_flat, bindings, ivars, cl) -> Pcl_let (rec_flat, List.map (fun (pat, exp) -> (untype_pattern pat, untype_expression exp)) bindings, untype_class_expr cl) | Tcl_constraint (cl, Some clty, vals, meths, concrs) -> Pcl_constraint (untype_class_expr cl, untype_class_type clty) | Tcl_ident _ -> assert false | Tcl_constraint (_, None, _, _, _) -> assert false in { pcl_desc = desc; pcl_loc = cexpr.cl_loc; } and untype_class_type ct = let desc = match ct.cltyp_desc with Tcty_signature csg -> Pcty_signature (untype_class_signature csg) | Tcty_constr (path, lid, list) -> Pcty_constr (lid, List.map untype_core_type list) | Tcty_fun (label, ct, cl) -> Pcty_fun (label, untype_core_type ct, untype_class_type cl) in { pcty_desc = desc; pcty_loc = ct.cltyp_loc } and untype_class_signature cs = { pcsig_self = untype_core_type cs.csig_self; pcsig_fields = List.map untype_class_type_field cs.csig_fields; pcsig_loc = cs.csig_loc; } and untype_class_type_field ctf = let desc = match ctf.ctf_desc with Tctf_inher ct -> Pctf_inher (untype_class_type ct) | Tctf_val (s, mut, virt, ct) -> Pctf_val (s, mut, virt, untype_core_type ct) | Tctf_virt (s, priv, ct) -> Pctf_virt (s, priv, untype_core_type ct) | Tctf_meth (s, priv, ct) -> Pctf_meth (s, priv, untype_core_type ct) | Tctf_cstr (ct1, ct2) -> Pctf_cstr (untype_core_type ct1, untype_core_type ct2) in { pctf_desc = desc; pctf_loc = ctf.ctf_loc; } and untype_core_type ct = let desc = match ct.ctyp_desc with Ttyp_any -> Ptyp_any | Ttyp_var s -> Ptyp_var s | Ttyp_arrow (label, ct1, ct2) -> Ptyp_arrow (label, untype_core_type ct1, untype_core_type ct2) | Ttyp_tuple list -> Ptyp_tuple (List.map untype_core_type list) | Ttyp_constr (path, lid, list) -> Ptyp_constr (lid, List.map untype_core_type list) | Ttyp_object list -> Ptyp_object (List.map untype_core_field_type list) | Ttyp_class (path, lid, list, labels) -> Ptyp_class (lid, List.map untype_core_type list, labels) | Ttyp_alias (ct, s) -> Ptyp_alias (untype_core_type ct, s) | Ttyp_variant (list, bool, labels) -> Ptyp_variant (List.map untype_row_field list, bool, labels) | Ttyp_poly (list, ct) -> Ptyp_poly (list, untype_core_type ct) | Ttyp_package pack -> Ptyp_package (untype_package_type pack) in { ptyp_desc = desc; ptyp_loc = ct.ctyp_loc } and untype_core_field_type cft = { pfield_desc = (match cft.field_desc with Tcfield_var -> Pfield_var | Tcfield (s, ct) -> Pfield (s, untype_core_type ct)); pfield_loc = cft.field_loc; } and untype_class_structure cs = { pcstr_pat = untype_pattern cs.cstr_pat; pcstr_fields = List.map untype_class_field cs.cstr_fields; } and untype_row_field rf = match rf with Ttag (label, bool, list) -> Rtag (label, bool, List.map untype_core_type list) | Tinherit ct -> Rinherit (untype_core_type ct) and untype_class_field cf = let desc = match cf.cf_desc with Tcf_inher (ovf, cl, super, _vals, _meths) -> Pcf_inher (ovf, untype_class_expr cl, super) | Tcf_constr (cty, cty') -> Pcf_constr (untype_core_type cty, untype_core_type cty') | Tcf_val (lab, name, mut, _, Tcfk_virtual cty, override) -> Pcf_valvirt (name, mut, untype_core_type cty) | Tcf_val (lab, name, mut, _, Tcfk_concrete exp, override) -> Pcf_val (name, mut, (if override then Override else Fresh), untype_expression exp) | Tcf_meth (lab, name, priv, Tcfk_virtual cty, override) -> Pcf_virt (name, priv, untype_core_type cty) | Tcf_meth (lab, name, priv, Tcfk_concrete exp, override) -> Pcf_meth (name, priv, (if override then Override else Fresh), untype_expression exp) (* | Tcf_let (rec_flag, bindings, _) -> Pcf_let (rec_flag, List.map (fun (pat, exp) -> untype_pattern pat, untype_expression exp) bindings) *) | Tcf_init exp -> Pcf_init (untype_expression exp) in { pcf_desc = desc; pcf_loc = cf.cf_loc } mingw-ocaml/ocaml/tools/make-version-header.sh0000755000175000017500000000420212124403240021000 0ustar tootstoots#!/bin/sh ######################################################################### # # # OCaml # # # # Damien Doligez, projet Gallium, INRIA Rocquencourt # # # # Copyright 2003 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. As an exception to the # # licensing rules of OCaml, this file is freely redistributable, # # modified or not, without constraints. # # # ######################################################################### # For maximal compatibility with older versions, we Use "ocamlc -v" # instead of "ocamlc -vnum" or the VERSION file in .../lib/ocaml/. # This script extracts the components from an OCaml version number # and provides them as C defines: # OCAML_VERSION_MAJOR: the major version number # OCAML_VERSION_MAJOR: the minor version number # OCAML_VERSION_PATCHLEVEL: the patchlevel number if present, or 0 if absent # OCAML_VERSION_ADDITIONAL: this is defined only if the additional-info # field is present, and is a string that contains that field. # Note that additional-info is always absent in officially-released # versions of OCaml. version="`ocamlc -v | sed -n -e 's/.*version //p'`" major="`echo "$version" | sed -n -e '1s/^\([0-9]*\)\..*/\1/p'`" minor="`echo "$version" | sed -n -e '1s/^[0-9]*\.\([0-9]*\).*/\1/p'`" patchlevel="`echo "$version" | sed -n -e '1s/^[0-9]*\.[0-9]*\.\([0-9]*\).*/\1/p'`" suffix="`echo "$version" | sed -n -e '1s/^[^+]*+\(.*\)/\1/p'`" echo "#define OCAML_VERSION_MAJOR $major" echo "#define OCAML_VERSION_MINOR $minor" case $patchlevel in "") patchlevel=0;; esac echo "#define OCAML_VERSION_PATCHLEVEL $patchlevel" case "$suffix" in "") echo "#undef OCAML_VERSION_ADDITIONAL";; *) echo "#define OCAML_VERSION_ADDITIONAL \"$suffix\"";; esac mingw-ocaml/ocaml/tools/ocamlsize0000755000175000017500000000424512124403240016536 0ustar tootstoots#!/usr/bin/perl ####################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 2002 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ####################################################################### foreach $f (@ARGV) { open(FILE, $f) || die("Cannot open $f"); seek(FILE, -16, 2); $num_sections = do read_int(); read(FILE, $magic, 12); seek(FILE, -16 - 8 * $num_sections, 2); @secname = (); @seclength = (); %length = (); for ($i = 0; $i < $num_sections; $i++) { read(FILE, $sec, 4); $secname[$i] = $sec; $seclength[$i] = do read_int(); $length{$sec} = $seclength[$i]; } print $f, ":\n" if ($#ARGV > 0); $path = $length{'RNTM'} > 0 ? do read_section('RNTM') : "(default runtime)\n"; printf ("\tcode: %-7d data: %-7d symbols: %-7d debug: %-7d\n", $length{'CODE'}, $length{'DATA'}, $length{'SYMB'}, $length{'DBUG'}); printf ("\tmagic number: %s runtime system: %s", $magic, $path); close(FILE); } sub read_int { read(FILE, $buff, 4) == 4 || die("Truncated bytecode file $f"); @int = unpack("C4", $buff); return ($int[0] << 24) + ($int[1] << 16) + ($int[2] << 8) + $int[3]; } sub read_section { local ($sec) = @_; local ($i, $ofs, $data); for ($i = $num_sections - 1; $i >= 0; $i--) { $ofs += $seclength[$i]; if ($secname[$i] eq $sec) { seek(FILE, -16 - 8 * $num_sections - $ofs, 2); read(FILE, $data, $seclength[$i]); return $data; } } return ''; } mingw-ocaml/ocaml/tools/depend.ml0000644000175000017500000002653712124403240016423 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Asttypes open Format open Location open Longident open Parsetree module StringSet = Set.Make(struct type t = string let compare = compare end) (* Collect free module identifiers in the a.s.t. *) let fst3 (x, _, _) = x let free_structure_names = ref StringSet.empty let rec addmodule bv lid = match lid with Lident s -> if not (StringSet.mem s bv) then free_structure_names := StringSet.add s !free_structure_names | Ldot(l, s) -> addmodule bv l | Lapply(l1, l2) -> addmodule bv l1; addmodule bv l2 let add bv lid = match lid.txt with Ldot(l, s) -> addmodule bv l | _ -> () let addmodule bv lid = addmodule bv lid.txt let rec add_type bv ty = match ty.ptyp_desc with Ptyp_any -> () | Ptyp_var v -> () | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2 | Ptyp_tuple tl -> List.iter (add_type bv) tl | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl | Ptyp_object fl -> List.iter (add_field_type bv) fl | Ptyp_class(c, tl, _) -> add bv c; List.iter (add_type bv) tl | Ptyp_alias(t, s) -> add_type bv t | Ptyp_variant(fl, _, _) -> List.iter (function Rtag(_,_,stl) -> List.iter (add_type bv) stl | Rinherit sty -> add_type bv sty) fl | Ptyp_poly(_, t) -> add_type bv t | Ptyp_package pt -> add_package_type bv pt and add_package_type bv (lid, l) = add bv lid; List.iter (add_type bv) (List.map (fun (_, e) -> e) l) and add_field_type bv ft = match ft.pfield_desc with Pfield(name, ty) -> add_type bv ty | Pfield_var -> () let add_opt add_fn bv = function None -> () | Some x -> add_fn bv x let add_type_declaration bv td = List.iter (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2) td.ptype_cstrs; add_opt add_type bv td.ptype_manifest; let rec add_tkind = function Ptype_abstract -> () | Ptype_variant cstrs -> List.iter (fun (c, args, rty, _) -> List.iter (add_type bv) args; Misc.may (add_type bv) rty) cstrs | Ptype_record lbls -> List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in add_tkind td.ptype_kind let rec add_class_type bv cty = match cty.pcty_desc with Pcty_constr(l, tyl) -> add bv l; List.iter (add_type bv) tyl | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } -> add_type bv ty; List.iter (add_class_type_field bv) fieldl | Pcty_fun(_, ty1, cty2) -> add_type bv ty1; add_class_type bv cty2 and add_class_type_field bv pctf = match pctf.pctf_desc with Pctf_inher cty -> add_class_type bv cty | Pctf_val(_, _, _, ty) -> add_type bv ty | Pctf_virt(_, _, ty) -> add_type bv ty | Pctf_meth(_, _, ty) -> add_type bv ty | Pctf_cstr(ty1, ty2) -> add_type bv ty1; add_type bv ty2 let add_class_description bv infos = add_class_type bv infos.pci_expr let add_class_type_declaration = add_class_description let pattern_bv = ref StringSet.empty let rec add_pattern bv pat = match pat.ppat_desc with Ppat_any -> () | Ppat_var _ -> () | Ppat_alias(p, _) -> add_pattern bv p | Ppat_constant _ -> () | Ppat_tuple pl -> List.iter (add_pattern bv) pl | Ppat_construct(c, op, _) -> add bv c; add_opt add_pattern bv op | Ppat_record(pl, _) -> List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl | Ppat_array pl -> List.iter (add_pattern bv) pl | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2 | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty | Ppat_variant(_, op) -> add_opt add_pattern bv op | Ppat_type li -> add bv li | Ppat_lazy p -> add_pattern bv p | Ppat_unpack id -> pattern_bv := StringSet.add id.txt !pattern_bv let add_pattern bv pat = pattern_bv := bv; add_pattern bv pat; !pattern_bv let rec add_expr bv exp = match exp.pexp_desc with Pexp_ident l -> add bv l | Pexp_constant _ -> () | Pexp_let(rf, pel, e) -> let bv = add_bindings rf bv pel in add_expr bv e | Pexp_function (_, opte, pel) -> add_opt add_expr bv opte; add_pat_expr_list bv pel | Pexp_apply(e, el) -> add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el | Pexp_match(e, pel) -> add_expr bv e; add_pat_expr_list bv pel | Pexp_try(e, pel) -> add_expr bv e; add_pat_expr_list bv pel | Pexp_tuple el -> List.iter (add_expr bv) el | Pexp_construct(c, opte, _) -> add bv c; add_opt add_expr bv opte | Pexp_variant(_, opte) -> add_opt add_expr bv opte | Pexp_record(lblel, opte) -> List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel; add_opt add_expr bv opte | Pexp_field(e, fld) -> add_expr bv e; add bv fld | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2 | Pexp_array el -> List.iter (add_expr bv) el | Pexp_ifthenelse(e1, e2, opte3) -> add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3 | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2 | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2 | Pexp_for( _, e1, e2, _, e3) -> add_expr bv e1; add_expr bv e2; add_expr bv e3 | Pexp_constraint(e1, oty2, oty3) -> add_expr bv e1; add_opt add_type bv oty2; add_opt add_type bv oty3 | Pexp_when(e1, e2) -> add_expr bv e1; add_expr bv e2 | Pexp_send(e, m) -> add_expr bv e | Pexp_new li -> add bv li | Pexp_setinstvar(v, e) -> add_expr bv e | Pexp_override sel -> List.iter (fun (s, e) -> add_expr bv e) sel | Pexp_letmodule(id, m, e) -> add_module bv m; add_expr (StringSet.add id.txt bv) e | Pexp_assert (e) -> add_expr bv e | Pexp_assertfalse -> () | Pexp_lazy (e) -> add_expr bv e | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t | Pexp_object { pcstr_pat = pat; pcstr_fields = fieldl } -> let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl | Pexp_newtype (_, e) -> add_expr bv e | Pexp_pack m -> add_module bv m | Pexp_open (m, e) -> addmodule bv m; add_expr bv e and add_pat_expr_list bv pel = List.iter (fun (p, e) -> let bv = add_pattern bv p in add_expr bv e) pel and add_bindings recf bv pel = let bv' = List.fold_left (fun bv (p, _) -> add_pattern bv p) bv pel in let bv = if recf = Recursive then bv' else bv in List.iter (fun (_, e) -> add_expr bv e) pel; bv' and add_modtype bv mty = match mty.pmty_desc with Pmty_ident l -> add bv l | Pmty_signature s -> add_signature bv s | Pmty_functor(id, mty1, mty2) -> add_modtype bv mty1; add_modtype (StringSet.add id.txt bv) mty2 | Pmty_with(mty, cstrl) -> add_modtype bv mty; List.iter (function (_, Pwith_type td) -> add_type_declaration bv td | (_, Pwith_module (lid)) -> addmodule bv lid | (_, Pwith_typesubst td) -> add_type_declaration bv td | (_, Pwith_modsubst (lid)) -> addmodule bv lid) cstrl | Pmty_typeof m -> add_module bv m and add_signature bv = function [] -> () | item :: rem -> add_signature (add_sig_item bv item) rem and add_sig_item bv item = match item.psig_desc with Psig_value(id, vd) -> add_type bv vd.pval_type; bv | Psig_type dcls -> List.iter (fun (id, td) -> add_type_declaration bv td) dcls; bv | Psig_exception(id, args) -> List.iter (add_type bv) args; bv | Psig_module(id, mty) -> add_modtype bv mty; StringSet.add id.txt bv | Psig_recmodule decls -> let bv' = List.fold_right StringSet.add (List.map (fun (x,_) -> x.txt) decls) bv in List.iter (fun (id, mty) -> add_modtype bv' mty) decls; bv' | Psig_modtype(id,mtyd) -> begin match mtyd with Pmodtype_abstract -> () | Pmodtype_manifest mty -> add_modtype bv mty end; bv | Psig_open lid -> addmodule bv lid; bv | Psig_include mty -> add_modtype bv mty; bv | Psig_class cdl -> List.iter (add_class_description bv) cdl; bv | Psig_class_type cdtl -> List.iter (add_class_type_declaration bv) cdtl; bv and add_module bv modl = match modl.pmod_desc with Pmod_ident l -> addmodule bv l | Pmod_structure s -> ignore (add_structure bv s) | Pmod_functor(id, mty, modl) -> add_modtype bv mty; add_module (StringSet.add id.txt bv) modl | Pmod_apply(mod1, mod2) -> add_module bv mod1; add_module bv mod2 | Pmod_constraint(modl, mty) -> add_module bv modl; add_modtype bv mty | Pmod_unpack(e) -> add_expr bv e and add_structure bv item_list = List.fold_left add_struct_item bv item_list and add_struct_item bv item = match item.pstr_desc with Pstr_eval e -> add_expr bv e; bv | Pstr_value(rf, pel) -> let bv = add_bindings rf bv pel in bv | Pstr_primitive(id, vd) -> add_type bv vd.pval_type; bv | Pstr_type dcls -> List.iter (fun (id, td) -> add_type_declaration bv td) dcls; bv | Pstr_exception(id, args) -> List.iter (add_type bv) args; bv | Pstr_exn_rebind(id, l) -> add bv l; bv | Pstr_module(id, modl) -> add_module bv modl; StringSet.add id.txt bv | Pstr_recmodule bindings -> let bv' = List.fold_right StringSet.add (List.map (fun (id,_,_) -> id.txt) bindings) bv in List.iter (fun (id, mty, modl) -> add_modtype bv' mty; add_module bv' modl) bindings; bv' | Pstr_modtype(id, mty) -> add_modtype bv mty; bv | Pstr_open l -> addmodule bv l; bv | Pstr_class cdl -> List.iter (add_class_declaration bv) cdl; bv | Pstr_class_type cdtl -> List.iter (add_class_type_declaration bv) cdtl; bv | Pstr_include modl -> add_module bv modl; bv and add_use_file bv top_phrs = ignore (List.fold_left add_top_phrase bv top_phrs) and add_top_phrase bv = function | Ptop_def str -> add_structure bv str | Ptop_dir (_, _) -> bv and add_class_expr bv ce = match ce.pcl_desc with Pcl_constr(l, tyl) -> add bv l; List.iter (add_type bv) tyl | Pcl_structure { pcstr_pat = pat; pcstr_fields = fieldl } -> let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl | Pcl_fun(_, opte, pat, ce) -> add_opt add_expr bv opte; let bv = add_pattern bv pat in add_class_expr bv ce | Pcl_apply(ce, exprl) -> add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl | Pcl_let(rf, pel, ce) -> let bv = add_bindings rf bv pel in add_class_expr bv ce | Pcl_constraint(ce, ct) -> add_class_expr bv ce; add_class_type bv ct and add_class_field bv pcf = match pcf.pcf_desc with Pcf_inher(_, ce, _) -> add_class_expr bv ce | Pcf_val(_, _, _, e) -> add_expr bv e | Pcf_valvirt(_, _, ty) | Pcf_virt(_, _, ty) -> add_type bv ty | Pcf_meth(_, _, _, e) -> add_expr bv e | Pcf_constr(ty1, ty2) -> add_type bv ty1; add_type bv ty2 | Pcf_init e -> add_expr bv e and add_class_declaration bv decl = add_class_expr bv decl.pci_expr mingw-ocaml/ocaml/tools/ocamlmklib.mlp0000644000175000017500000002516212124403240017447 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Printf open Myocamlbuild_config (* PR#4783: under Windows, don't use absolute paths because we do not know where the binary distribution will be installed. *) let compiler_path name = if Sys.os_type = "Win32" then name else Filename.concat bindir name let bytecode_objs = ref [] (* .cmo,.cma,.ml,.mli files to pass to ocamlc *) and native_objs = ref [] (* .cmx,.cmxa,.ml,.mli files to pass to ocamlopt *) and c_objs = ref [] (* .o, .a, .obj, .lib, .dll files to pass to mksharedlib and ar *) and caml_libs = ref [] (* -cclib to pass to ocamlc, ocamlopt *) and caml_opts = ref [] (* -ccopt to pass to ocamlc, ocamlopt *) and dynlink = ref supports_shared_libraries and failsafe = ref false (* whether to fall back on static build only *) and c_libs = ref [] (* libs to pass to mksharedlib and ocamlc -cclib *) and c_Lopts = ref [] (* options to pass to mksharedlib and ocamlc -cclib *) and c_opts = ref [] (* options to pass to mksharedlib and ocamlc -ccopt *) and ld_opts = ref [] (* options to pass only to the linker *) and ocamlc = ref (compiler_path "ocamlc") and ocamlopt = ref (compiler_path "ocamlopt") and output = ref "a" (* Output name for OCaml part of library *) and output_c = ref "" (* Output name for C part of library *) and rpath = ref [] (* rpath options *) and verbose = ref false let starts_with s pref = String.length s >= String.length pref && String.sub s 0 (String.length pref) = pref let ends_with = Filename.check_suffix let chop_prefix s pref = String.sub s (String.length pref) (String.length s - String.length pref) let chop_suffix = Filename.chop_suffix exception Bad_argument of string let print_version () = printf "ocamlmklib, version %s\n" Sys.ocaml_version; exit 0; ;; let print_version_num () = printf "%s\n" Sys.ocaml_version; exit 0; ;; let parse_arguments argv = let i = ref 1 in let next_arg () = if !i + 1 >= Array.length argv then raise (Bad_argument("Option " ^ argv.(!i) ^ " expects one argument")); incr i; argv.(!i) in while !i < Array.length argv do let s = argv.(!i) in if ends_with s ".cmo" || ends_with s ".cma" then bytecode_objs := s :: !bytecode_objs else if ends_with s ".cmx" || ends_with s ".cmxa" then native_objs := s :: !native_objs else if ends_with s ".ml" || ends_with s ".mli" then (bytecode_objs := s :: !bytecode_objs; native_objs := s :: !native_objs) else if List.exists (ends_with s) [".o"; ".a"; ".obj"; ".lib"; ".dll"] then c_objs := s :: !c_objs else if s = "-cclib" then caml_libs := next_arg () :: "-cclib" :: !caml_libs else if s = "-ccopt" then caml_opts := next_arg () :: "-ccopt" :: !caml_opts else if s = "-custom" then dynlink := false else if s = "-I" then caml_opts := next_arg () :: "-I" :: !caml_opts else if s = "-failsafe" then failsafe := true else if s = "-h" || s = "-help" || s = "--help" then raise (Bad_argument "") else if s = "-ldopt" then ld_opts := next_arg () :: !ld_opts else if s = "-linkall" then caml_opts := s :: !caml_opts else if starts_with s "-l" then c_libs := s :: !c_libs else if starts_with s "-L" then (c_Lopts := s :: !c_Lopts; let l = chop_prefix s "-L" in if not (Filename.is_relative l) then rpath := l :: !rpath) else if s = "-ocamlc" then ocamlc := next_arg () else if s = "-ocamlopt" then ocamlopt := next_arg () else if s = "-o" then output := next_arg() else if s = "-oc" then output_c := next_arg() else if s = "-dllpath" || s = "-R" || s = "-rpath" then rpath := next_arg() :: !rpath else if starts_with s "-R" then rpath := chop_prefix s "-R" :: !rpath else if s = "-Wl,-rpath" then (let a = next_arg() in if starts_with a "-Wl," then rpath := chop_prefix a "-Wl," :: !rpath else raise (Bad_argument("Option -Wl,-rpath expects a -Wl, argument"))) else if starts_with s "-Wl,-rpath," then rpath := chop_prefix s "-Wl,-rpath," :: !rpath else if starts_with s "-Wl,-R" then rpath := chop_prefix s "-Wl,-R" :: !rpath else if s = "-v" || s = "-verbose" then verbose := true else if s = "-version" then print_version () else if s = "-vnum" then print_version_num () else if starts_with s "-F" then c_opts := s :: !c_opts else if s = "-framework" then (let a = next_arg() in c_opts := a :: s :: !c_opts) else if starts_with s "-" then prerr_endline ("Unknown option " ^ s) else raise (Bad_argument("Don't know what to do with " ^ s)); incr i done; List.iter (fun r -> r := List.rev !r) [ bytecode_objs; native_objs; caml_libs; caml_opts; c_libs; c_objs; c_opts; ld_opts; rpath ]; (* Put -L options in front of -l options in -cclib to mimic -ccopt behavior *) c_libs := !c_Lopts @ !c_libs; if !output_c = "" then output_c := !output let usage = "\ Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|.dll files>\ \nOptions are:\ \n -cclib C library passed to ocamlc -a or ocamlopt -a only\ \n -ccopt C option passed to ocamlc -a or ocamlopt -a only\ \n -custom disable dynamic loading\ \n -dllpath Add to the run-time search path for DLLs\ \n -F Specify a framework directory (MacOSX)\ \n -framework Use framework (MacOSX)\ \n -help Print this help message and exit\ \n --help Same as -help\ \n -h Same as -help\ \n -I Add to the path searched for OCaml object files\ \n -failsafe fall back to static linking if DLL construction failed\ \n -ldopt C option passed to the shared linker only\ \n -linkall Build OCaml archive with link-all behavior\ \n -l Specify a dependent C library\ \n -L Add to the path searched for C libraries\ \n -ocamlc Use in place of \"ocamlc\"\ \n -ocamlopt Use in place of \"ocamlopt\"\ \n -o Generated OCaml library is named .cma or .cmxa\ \n -oc Generated C library is named dll.so or lib.a\ \n -rpath Same as -dllpath \ \n -R Same as -rpath\ \n -verbose Print commands before executing them\ \n -v same as -verbose\ \n -version Print version and exit\ \n -vnum Print version number and exit\ \n -Wl,-rpath, Same as -dllpath \ \n -Wl,-rpath -Wl, Same as -dllpath \ \n -Wl,-R Same as -dllpath \ \n" let command cmd = if !verbose then (print_string "+ "; print_string cmd; print_newline()); Sys.command cmd let scommand cmd = if command cmd <> 0 then exit 2 let safe_remove s = try Sys.remove s with Sys_error _ -> () let make_set l = let rec merge l = function [] -> List.rev l | p :: r -> if List.mem p l then merge l r else merge (p::l) r in merge [] l let make_rpath flag = if !rpath = [] || flag = "" then "" else flag ^ String.concat ":" (make_set !rpath) let make_rpath_ccopt flag = if !rpath = [] || flag = "" then "" else "-ccopt " ^ flag ^ String.concat ":" (make_set !rpath) let prefix_list pref l = List.map (fun s -> pref ^ s) l let prepostfix pre name post = let base = Filename.basename name in let dir = Filename.dirname name in Filename.concat dir (pre ^ base ^ post) ;; let transl_path s = match Sys.os_type with | "Win32" -> let rec aux i = if i = String.length s || s.[i] = ' ' then s else (if s.[i] = '/' then s.[i] <- '\\'; aux (i + 1)) in aux 0 | _ -> s let build_libs () = if !c_objs <> [] then begin if !dynlink then begin let retcode = command (Printf.sprintf "%s -o %s %s %s %s %s %s" mkdll (prepostfix "dll" !output_c ext_dll) (String.concat " " !c_objs) (String.concat " " !c_opts) (String.concat " " !ld_opts) (make_rpath mksharedlibrpath) (String.concat " " !c_libs) ) in if retcode <> 0 then if !failsafe then dynlink := false else exit 2 end; safe_remove (prepostfix "lib" !output_c ext_lib); scommand (mklib (prepostfix "lib" !output_c ext_lib) (String.concat " " !c_objs) ""); end; if !bytecode_objs <> [] then scommand (sprintf "%s -a %s -o %s.cma %s %s -dllib -l%s -cclib -l%s %s %s %s %s" (transl_path !ocamlc) (if !dynlink then "" else "-custom") !output (String.concat " " !caml_opts) (String.concat " " !bytecode_objs) (Filename.basename !output_c) (Filename.basename !output_c) (String.concat " " (prefix_list "-ccopt " !c_opts)) (make_rpath_ccopt byteccrpath) (String.concat " " (prefix_list "-cclib " !c_libs)) (String.concat " " !caml_libs)); if !native_objs <> [] then scommand (sprintf "%s -a -o %s.cmxa %s %s -cclib -l%s %s %s %s %s" (transl_path !ocamlopt) !output (String.concat " " !caml_opts) (String.concat " " !native_objs) (Filename.basename !output_c) (String.concat " " (prefix_list "-ccopt " !c_opts)) (make_rpath_ccopt nativeccrpath) (String.concat " " (prefix_list "-cclib " !c_libs)) (String.concat " " !caml_libs)) let _ = try parse_arguments Sys.argv; build_libs() with | Bad_argument "" -> prerr_string usage; exit 0 | Bad_argument s -> prerr_endline s; prerr_string usage; exit 4 | Sys_error s -> prerr_string "System error: "; prerr_endline s; exit 4 | x -> raise x mingw-ocaml/ocaml/tools/dumpobj.ml0000644000175000017500000003676412124403240016627 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Disassembler for executable and .cmo object files *) open Asttypes open Config open Emitcode open Instruct open Lambda open Location open Obj open Opcodes open Opnames open Cmo_format open Printf let print_locations = ref true (* Read signed and unsigned integers *) let inputu ic = let b1 = input_byte ic in let b2 = input_byte ic in let b3 = input_byte ic in let b4 = input_byte ic in (b4 lsl 24) + (b3 lsl 16) + (b2 lsl 8) + b1 let inputs ic = let b1 = input_byte ic in let b2 = input_byte ic in let b3 = input_byte ic in let b4 = input_byte ic in let b4' = if b4 >= 128 then b4-256 else b4 in (b4' lsl 24) + (b3 lsl 16) + (b2 lsl 8) + b1 (* Global variables *) type global_table_entry = Empty | Global of Ident.t | Constant of Obj.t let start = ref 0 (* Position of beg. of code *) let reloc = ref ([] : (reloc_info * int) list) (* Relocation table *) let globals = ref ([||] : global_table_entry array) (* Global map *) let primitives = ref ([||] : string array) (* Table of primitives *) let objfile = ref false (* true if dumping a .cmo *) (* Events (indexed by PC) *) let event_table = (Hashtbl.create 253 : (int, debug_event) Hashtbl.t) let relocate_event orig ev = ev.ev_pos <- orig + ev.ev_pos; match ev.ev_repr with Event_parent repr -> repr := ev.ev_pos | _ -> () let record_events orig evl = List.iter (fun ev -> relocate_event orig ev; Hashtbl.add event_table ev.ev_pos ev) evl (* Print a structured constant *) let print_float f = if String.contains f '.' then printf "%s" f else printf "%s." f ;; let rec print_struct_const = function Const_base(Const_int i) -> printf "%d" i | Const_base(Const_float f) -> print_float f | Const_base(Const_string s) -> printf "%S" s | Const_immstring s -> printf "%S" s | Const_base(Const_char c) -> printf "%C" c | Const_base(Const_int32 i) -> printf "%ldl" i | Const_base(Const_nativeint i) -> printf "%ndn" i | Const_base(Const_int64 i) -> printf "%LdL" i | Const_pointer n -> printf "%da" n | Const_block(tag, args) -> printf "<%d>" tag; begin match args with [] -> () | [a1] -> printf "("; print_struct_const a1; printf ")" | a1::al -> printf "("; print_struct_const a1; List.iter (fun a -> printf ", "; print_struct_const a) al; printf ")" end | Const_float_array a -> printf "[|"; List.iter (fun f -> print_float f; printf "; ") a; printf "|]" (* Print an obj *) let same_custom x y = Obj.field x 0 = Obj.field (Obj.repr y) 0 let rec print_obj x = if Obj.is_block x then begin let tag = Obj.tag x in if tag = Obj.string_tag then printf "%S" (Obj.magic x : string) else if tag = Obj.double_tag then printf "%.12g" (Obj.magic x : float) else if tag = Obj.double_array_tag then begin let a = (Obj.magic x : float array) in printf "[|"; for i = 0 to Array.length a - 1 do if i > 0 then printf ", "; printf "%.12g" a.(i) done; printf "|]" end else if tag = Obj.custom_tag && same_custom x 0l then printf "%ldl" (Obj.magic x : int32) else if tag = Obj.custom_tag && same_custom x 0n then printf "%ndn" (Obj.magic x : nativeint) else if tag = Obj.custom_tag && same_custom x 0L then printf "%LdL" (Obj.magic x : int64) else if tag < Obj.no_scan_tag then begin printf "<%d>" (Obj.tag x); match Obj.size x with 0 -> () | 1 -> printf "("; print_obj (Obj.field x 0); printf ")" | n -> printf "("; print_obj (Obj.field x 0); for i = 1 to n - 1 do printf ", "; print_obj (Obj.field x i) done; printf ")" end else printf "" tag end else printf "%d" (Obj.magic x : int) (* Current position in input file *) let currpos ic = pos_in ic - !start (* Access in the relocation table *) let rec rassoc key = function [] -> raise Not_found | (a,b) :: l -> if b = key then a else rassoc key l let find_reloc ic = rassoc (pos_in ic - !start) !reloc (* Symbolic printing of global names, etc *) let print_getglobal_name ic = if !objfile then begin begin try match find_reloc ic with Reloc_getglobal id -> print_string (Ident.name id) | Reloc_literal sc -> print_struct_const sc | _ -> print_string "" with Not_found -> print_string "" end; ignore (inputu ic); end else begin let n = inputu ic in if n >= Array.length !globals || n < 0 then print_string "" else match !globals.(n) with Global id -> print_string(Ident.name id) | Constant obj -> print_obj obj | _ -> print_string "???" end let print_setglobal_name ic = if !objfile then begin begin try match find_reloc ic with Reloc_setglobal id -> print_string (Ident.name id) | _ -> print_string "" with Not_found -> print_string "" end; ignore (inputu ic); end else begin let n = inputu ic in if n >= Array.length !globals || n < 0 then print_string "" else match !globals.(n) with Global id -> print_string(Ident.name id) | _ -> print_string "???" end let print_primitive ic = if !objfile then begin begin try match find_reloc ic with Reloc_primitive s -> print_string s | _ -> print_string "" with Not_found -> print_string "" end; ignore (inputu ic); end else begin let n = inputu ic in if n >= Array.length !primitives || n < 0 then print_int n else print_string !primitives.(n) end (* Disassemble one instruction *) let currpc ic = currpos ic / 4 type shape = | Nothing | Uint | Sint | Uint_Uint | Disp | Uint_Disp | Sint_Disp | Getglobal | Getglobal_Uint | Setglobal | Primitive | Uint_Primitive | Switch | Closurerec | Pubmet ;; let op_shapes = [ opACC0, Nothing; opACC1, Nothing; opACC2, Nothing; opACC3, Nothing; opACC4, Nothing; opACC5, Nothing; opACC6, Nothing; opACC7, Nothing; opACC, Uint; opPUSH, Nothing; opPUSHACC0, Nothing; opPUSHACC1, Nothing; opPUSHACC2, Nothing; opPUSHACC3, Nothing; opPUSHACC4, Nothing; opPUSHACC5, Nothing; opPUSHACC6, Nothing; opPUSHACC7, Nothing; opPUSHACC, Uint; opPOP, Uint; opASSIGN, Uint; opENVACC1, Nothing; opENVACC2, Nothing; opENVACC3, Nothing; opENVACC4, Nothing; opENVACC, Uint; opPUSHENVACC1, Nothing; opPUSHENVACC2, Nothing; opPUSHENVACC3, Nothing; opPUSHENVACC4, Nothing; opPUSHENVACC, Uint; opPUSH_RETADDR, Disp; opAPPLY, Uint; opAPPLY1, Nothing; opAPPLY2, Nothing; opAPPLY3, Nothing; opAPPTERM, Uint_Uint; opAPPTERM1, Uint; opAPPTERM2, Uint; opAPPTERM3, Uint; opRETURN, Uint; opRESTART, Nothing; opGRAB, Uint; opCLOSURE, Uint_Disp; opCLOSUREREC, Closurerec; opOFFSETCLOSUREM2, Nothing; opOFFSETCLOSURE0, Nothing; opOFFSETCLOSURE2, Nothing; opOFFSETCLOSURE, Sint; (* was Uint *) opPUSHOFFSETCLOSUREM2, Nothing; opPUSHOFFSETCLOSURE0, Nothing; opPUSHOFFSETCLOSURE2, Nothing; opPUSHOFFSETCLOSURE, Sint; (* was Nothing *) opGETGLOBAL, Getglobal; opPUSHGETGLOBAL, Getglobal; opGETGLOBALFIELD, Getglobal_Uint; opPUSHGETGLOBALFIELD, Getglobal_Uint; opSETGLOBAL, Setglobal; opATOM0, Nothing; opATOM, Uint; opPUSHATOM0, Nothing; opPUSHATOM, Uint; opMAKEBLOCK, Uint_Uint; opMAKEBLOCK1, Uint; opMAKEBLOCK2, Uint; opMAKEBLOCK3, Uint; opMAKEFLOATBLOCK, Uint; opGETFIELD0, Nothing; opGETFIELD1, Nothing; opGETFIELD2, Nothing; opGETFIELD3, Nothing; opGETFIELD, Uint; opGETFLOATFIELD, Uint; opSETFIELD0, Nothing; opSETFIELD1, Nothing; opSETFIELD2, Nothing; opSETFIELD3, Nothing; opSETFIELD, Uint; opSETFLOATFIELD, Uint; opVECTLENGTH, Nothing; opGETVECTITEM, Nothing; opSETVECTITEM, Nothing; opGETSTRINGCHAR, Nothing; opSETSTRINGCHAR, Nothing; opBRANCH, Disp; opBRANCHIF, Disp; opBRANCHIFNOT, Disp; opSWITCH, Switch; opBOOLNOT, Nothing; opPUSHTRAP, Disp; opPOPTRAP, Nothing; opRAISE, Nothing; opCHECK_SIGNALS, Nothing; opC_CALL1, Primitive; opC_CALL2, Primitive; opC_CALL3, Primitive; opC_CALL4, Primitive; opC_CALL5, Primitive; opC_CALLN, Uint_Primitive; opCONST0, Nothing; opCONST1, Nothing; opCONST2, Nothing; opCONST3, Nothing; opCONSTINT, Sint; opPUSHCONST0, Nothing; opPUSHCONST1, Nothing; opPUSHCONST2, Nothing; opPUSHCONST3, Nothing; opPUSHCONSTINT, Sint; opNEGINT, Nothing; opADDINT, Nothing; opSUBINT, Nothing; opMULINT, Nothing; opDIVINT, Nothing; opMODINT, Nothing; opANDINT, Nothing; opORINT, Nothing; opXORINT, Nothing; opLSLINT, Nothing; opLSRINT, Nothing; opASRINT, Nothing; opEQ, Nothing; opNEQ, Nothing; opLTINT, Nothing; opLEINT, Nothing; opGTINT, Nothing; opGEINT, Nothing; opOFFSETINT, Sint; opOFFSETREF, Sint; opISINT, Nothing; opGETMETHOD, Nothing; opGETDYNMET, Nothing; opGETPUBMET, Pubmet; opBEQ, Sint_Disp; opBNEQ, Sint_Disp; opBLTINT, Sint_Disp; opBLEINT, Sint_Disp; opBGTINT, Sint_Disp; opBGEINT, Sint_Disp; opULTINT, Nothing; opUGEINT, Nothing; opBULTINT, Uint_Disp; opBUGEINT, Uint_Disp; opSTOP, Nothing; opEVENT, Nothing; opBREAK, Nothing; ];; let print_event ev = if !print_locations then let ls = ev.ev_loc.loc_start in let le = ev.ev_loc.loc_end in printf "File \"%s\", line %d, characters %d-%d:\n" ls.Lexing.pos_fname ls.Lexing.pos_lnum (ls.Lexing.pos_cnum - ls.Lexing.pos_bol) (le.Lexing.pos_cnum - ls.Lexing.pos_bol) let print_instr ic = let pos = currpos ic in List.iter print_event (Hashtbl.find_all event_table pos); printf "%8d " (pos / 4); let op = inputu ic in if op >= Array.length names_of_instructions || op < 0 then (print_string "*** unknown opcode : "; print_int op) else print_string names_of_instructions.(op); print_string " "; begin try match List.assoc op op_shapes with | Uint -> print_int (inputu ic) | Sint -> print_int (inputs ic) | Uint_Uint -> print_int (inputu ic); print_string ", "; print_int (inputu ic) | Disp -> let p = currpc ic in print_int (p + inputs ic) | Uint_Disp -> print_int (inputu ic); print_string ", "; let p = currpc ic in print_int (p + inputs ic) | Sint_Disp -> print_int (inputs ic); print_string ", "; let p = currpc ic in print_int (p + inputs ic) | Getglobal -> print_getglobal_name ic | Getglobal_Uint -> print_getglobal_name ic; print_string ", "; print_int (inputu ic) | Setglobal -> print_setglobal_name ic | Primitive -> print_primitive ic | Uint_Primitive -> print_int(inputu ic); print_string ", "; print_primitive ic | Switch -> let n = inputu ic in let orig = currpc ic in for i = 0 to (n land 0xFFFF) - 1 do print_string "\n int "; print_int i; print_string " -> "; print_int(orig + inputs ic); done; for i = 0 to (n lsr 16) - 1 do print_string "\n tag "; print_int i; print_string " -> "; print_int(orig + inputs ic); done; | Closurerec -> let nfuncs = inputu ic in let nvars = inputu ic in let orig = currpc ic in print_int nvars; for i = 0 to nfuncs - 1 do print_string ", "; print_int (orig + inputs ic); done; | Pubmet -> let tag = inputs ic in let _cache = inputu ic in print_int tag | Nothing -> () with Not_found -> print_string "(unknown arguments)" end; print_string "\n"; ;; (* Disassemble a block of code *) let print_code ic len = start := pos_in ic; let stop = !start + len in while pos_in ic < stop do print_instr ic done (* Dump relocation info *) let print_reloc (info, pos) = printf " %d (%d) " pos (pos/4); match info with Reloc_literal sc -> print_struct_const sc; printf "\n" | Reloc_getglobal id -> printf "require %s\n" (Ident.name id) | Reloc_setglobal id -> printf "provide %s\n" (Ident.name id) | Reloc_primitive s -> printf "prim %s\n" s (* Print a .cmo file *) let dump_obj filename ic = let buffer = Misc.input_bytes ic (String.length cmo_magic_number) in if buffer <> cmo_magic_number then begin prerr_endline "Not an object file"; exit 2 end; let cu_pos = input_binary_int ic in seek_in ic cu_pos; let cu = (input_value ic : compilation_unit) in reloc := cu.cu_reloc; if cu.cu_debug > 0 then begin seek_in ic cu.cu_debug; let evl = (input_value ic : debug_event list) in record_events 0 evl end; seek_in ic cu.cu_pos; print_code ic cu.cu_codesize (* Read the primitive table from an executable *) let read_primitive_table ic len = let p = Misc.input_bytes ic len in let rec split beg cur = if cur >= len then [] else if p.[cur] = '\000' then String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1) else split beg (cur + 1) in Array.of_list(split 0 0) (* Print an executable file *) let dump_exe ic = Bytesections.read_toc ic; let prim_size = Bytesections.seek_section ic "PRIM" in primitives := read_primitive_table ic prim_size; ignore(Bytesections.seek_section ic "DATA"); let init_data = (input_value ic : Obj.t array) in globals := Array.create (Array.length init_data) Empty; for i = 0 to Array.length init_data - 1 do !globals.(i) <- Constant (init_data.(i)) done; ignore(Bytesections.seek_section ic "SYMB"); let (_, sym_table) = (input_value ic : int * (Ident.t, int) Tbl.t) in Tbl.iter (fun id pos -> !globals.(pos) <- Global id) sym_table; begin try ignore (Bytesections.seek_section ic "DBUG"); let num_eventlists = input_binary_int ic in for i = 1 to num_eventlists do let orig = input_binary_int ic in let evl = (input_value ic : debug_event list) in record_events orig evl done with Not_found -> () end; let code_size = Bytesections.seek_section ic "CODE" in print_code ic code_size let arg_list = [ "-noloc", Arg.Clear print_locations, " : don't print source information"; ] let arg_usage = Printf.sprintf "%s [OPTIONS] FILES : dump content of bytecode files" Sys.argv.(0) let first_file = ref true let arg_fun filename = let ic = open_in_bin filename in if not !first_file then print_newline (); first_file := false; printf "## start of ocaml dump of %S\n%!" filename; begin try objfile := false; dump_exe ic with Bytesections.Bad_magic_number -> objfile := true; seek_in ic 0; dump_obj filename ic end; close_in ic; printf "## end of ocaml dump of %S\n%!" filename let main() = Arg.parse arg_list arg_fun arg_usage; exit 0 let _ = main () mingw-ocaml/ocaml/tools/objinfo.ml0000644000175000017500000002210612124403240016576 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* Mehdi Dogguy, PPS laboratory, University Paris Diderot *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. Modifications Copyright 2010 Mehdi Dogguy, *) (* used and distributed as part of OCaml by permission from *) (* the author. This file is distributed under the terms of the *) (* Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Dump info on .cmi, .cmo, .cmx, .cma, .cmxa, .cmxs files and on bytecode executables. *) open Printf open Misc open Config open Cmo_format open Clambda let input_stringlist ic len = let get_string_list sect len = let rec fold s e acc = if e != len then if sect.[e] = '\000' then fold (e+1) (e+1) (String.sub sect s (e-s) :: acc) else fold s (e+1) acc else acc in fold 0 0 [] in let sect = Misc.input_bytes ic len in get_string_list sect len let print_name_crc (name, crc) = printf "\t%s\t%s\n" (Digest.to_hex crc) name let print_line name = printf "\t%s\n" name let print_cmo_infos cu = printf "Unit name: %s\n" cu.cu_name; print_string "Interfaces imported:\n"; List.iter print_name_crc cu.cu_imports; printf "Uses unsafe features: "; (match cu.cu_primitives with | [] -> printf "no\n" | l -> printf "YES\n"; printf "Primitives declared in this module:\n"; List.iter print_line l); printf "Force link: %s\n" (if cu.cu_force_link then "YES" else "no") let rec print_approx_infos ppf = function Value_closure(fundesc, approx) -> Format.fprintf ppf "@[<2>function %s@ arity %i" fundesc.fun_label fundesc.fun_arity; if fundesc.fun_closed then begin Format.fprintf ppf "@ (closed)" end; if fundesc.fun_inline <> None then begin Format.fprintf ppf "@ (inline)" end; Format.fprintf ppf "@ -> @ %a@]" print_approx_infos approx | Value_tuple approx -> let tuple ppf approx = for i = 0 to Array.length approx - 1 do if i > 0 then Format.fprintf ppf ";@ "; Format.fprintf ppf "%i: %a" i print_approx_infos approx.(i) done in Format.fprintf ppf "@[(%a)@]" tuple approx | Value_unknown -> Format.fprintf ppf "_" | Value_integer n -> Format.fprintf ppf "%d" n | Value_constptr n -> Format.fprintf ppf "%dp" n let print_spaced_string s = printf " %s" s let print_cma_infos (lib : Cmo_format.library) = printf "Force custom: %s\n" (if lib.lib_custom then "YES" else "no"); printf "Extra C object files:"; (* PR#4949: print in linking order *) List.iter print_spaced_string (List.rev lib.lib_ccobjs); printf "\nExtra C options:"; List.iter print_spaced_string lib.lib_ccopts; printf "\n"; print_string "Extra dynamically-loaded libraries:"; List.iter print_spaced_string lib.lib_dllibs; printf "\n"; List.iter print_cmo_infos lib.lib_units let print_cmi_infos name sign crcs = printf "Unit name: %s\n" name; printf "Interfaces imported:\n"; List.iter print_name_crc crcs let print_general_infos name crc defines cmi cmx = printf "Name: %s\n" name; printf "CRC of implementation: %s\n" (Digest.to_hex crc); printf "Globals defined:\n"; List.iter print_line defines; printf "Interfaces imported:\n"; List.iter print_name_crc cmi; printf "Implementations imported:\n"; List.iter print_name_crc cmx open Cmx_format let print_cmx_infos (ui, crc) = print_general_infos ui.ui_name crc ui.ui_defines ui.ui_imports_cmi ui.ui_imports_cmx; printf "Approximation:\n"; Format.fprintf Format.std_formatter " %a@." print_approx_infos ui.ui_approx; let pr_funs _ fns = List.iter (fun arity -> printf " %d" arity) fns in printf "Currying functions:%a\n" pr_funs ui.ui_curry_fun; printf "Apply functions:%a\n" pr_funs ui.ui_apply_fun; printf "Send functions:%a\n" pr_funs ui.ui_send_fun; printf "Force link: %s\n" (if ui.ui_force_link then "YES" else "no") let print_cmxa_infos (lib : Cmx_format.library_infos) = printf "Extra C object files:"; List.iter print_spaced_string (List.rev lib.lib_ccobjs); printf "\nExtra C options:"; List.iter print_spaced_string lib.lib_ccopts; printf "\n"; List.iter print_cmx_infos lib.lib_units let print_cmxs_infos header = List.iter (fun ui -> print_general_infos ui.dynu_name ui.dynu_crc ui.dynu_defines ui.dynu_imports_cmi ui.dynu_imports_cmx) header.dynu_units let p_title title = printf "%s:\n" title let p_section title = function | [] -> () | l -> p_title title; List.iter print_name_crc l let p_list title print = function | [] -> () | l -> p_title title; List.iter print l let dump_byte ic = Bytesections.read_toc ic; let toc = Bytesections.toc () in let toc = List.sort Pervasives.compare toc in List.iter (fun (section, _) -> try let len = Bytesections.seek_section ic section in if len > 0 then match section with | "CRCS" -> p_section "Imported units" (input_value ic : (string * Digest.t) list) | "DLLS" -> p_list "Used DLLs" print_line (input_stringlist ic len) | "DLPT" -> p_list "Additional DLL paths" print_line (input_stringlist ic len) | "PRIM" -> p_list "Primitives used" print_line (input_stringlist ic len) | _ -> () with _ -> () ) toc let read_dyn_header filename ic = let tempfile = Filename.temp_file "objinfo" ".out" in let helper = Filename.concat Config.standard_library "objinfo_helper" in try try_finally (fun () -> let rc = Sys.command (sprintf "%s %s > %s" (Filename.quote helper) (Filename.quote filename) tempfile) in if rc <> 0 then failwith "cannot read"; let tc = open_in tempfile in try_finally (fun () -> let ofs = Scanf.fscanf tc "%Ld" (fun x -> x) in LargeFile.seek_in ic ofs; Some(input_value ic : dynheader)) (fun () -> close_in tc)) (fun () -> remove_file tempfile) with Failure _ | Sys_error _ -> None let dump_obj filename = printf "File %s\n" filename; let ic = open_in_bin filename in let len_magic_number = String.length cmo_magic_number in let magic_number = Misc.input_bytes ic len_magic_number in if magic_number = cmo_magic_number then begin let cu_pos = input_binary_int ic in seek_in ic cu_pos; let cu = (input_value ic : compilation_unit) in close_in ic; print_cmo_infos cu end else if magic_number = cma_magic_number then begin let toc_pos = input_binary_int ic in seek_in ic toc_pos; let toc = (input_value ic : library) in close_in ic; print_cma_infos toc end else if magic_number = cmi_magic_number then begin let cmi = Cmi_format.input_cmi ic in close_in ic; print_cmi_infos cmi.Cmi_format.cmi_name cmi.Cmi_format.cmi_sign cmi.Cmi_format.cmi_crcs end else if magic_number = cmx_magic_number then begin let ui = (input_value ic : unit_infos) in let crc = Digest.input ic in close_in ic; print_cmx_infos (ui, crc) end else if magic_number = cmxa_magic_number then begin let li = (input_value ic : library_infos) in close_in ic; print_cmxa_infos li end else begin let pos_trailer = in_channel_length ic - len_magic_number in let _ = seek_in ic pos_trailer in let _ = really_input ic magic_number 0 len_magic_number in if magic_number = Config.exec_magic_number then begin dump_byte ic; close_in ic end else if Filename.check_suffix filename ".cmxs" then begin flush stdout; match read_dyn_header filename ic with | None -> printf "Unable to read info on file %s\n" filename; exit 2 | Some header -> if header.dynu_magic = Config.cmxs_magic_number then print_cmxs_infos header else begin printf "Wrong magic number\n"; exit 2 end; close_in ic end else begin printf "Not an OCaml object file\n"; exit 2 end end let arg_list = [] let arg_usage = Printf.sprintf "%s [OPTIONS] FILES : give information on files" Sys.argv.(0) let main() = Arg.parse arg_list dump_obj arg_usage; exit 0 let _ = main () mingw-ocaml/ocaml/tools/ocaml-objcopy-macosx0000755000175000017500000000307012124403240020571 0ustar tootstoots#!/bin/bash ######################################################################### # # # OCaml # # # # Damien Doligez, projet Cristal, INRIA Rocquencourt # # # # Copyright 2005 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # $Id$ TMP="${TMPDIR=/tmp}" TEMP="${TMP}"/ocaml-objcopy-$$.o UNDEF="${TMP}"/ocaml-objcopy-$$.sym usage () { echo "usage: objcopy {--redefine-sym =} file.o" >&2 exit 2 } : > "$UNDEF" while : ; do case $# in 0) break;; *) case $1 in --redefine-sym) case $2 in *=*) ALIAS="$ALIAS -i${2#*=}:${2%%=*}" echo ${2%%=*} >>"$UNDEF" ;; *) usage;; esac shift 2 ;; -*) usage;; *) case $FILE in "") FILE=$1; shift;; *) usage;; esac;; esac;; esac done ld -o "$TEMP" -r $ALIAS "$FILE" ld -o "$FILE" -r -unexported_symbols_list "$UNDEF" "$TEMP" rm -f "$TEMP" "$UNDEF" mingw-ocaml/ocaml/tools/checkstack.c0000644000175000017500000000314112124403240017063 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Damien Doligez, projet Moscova, INRIA Rocquencourt */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #define MINSTACKBYTES (384 * 1024 * sizeof (long)) int main(int argc, char ** argv) { struct rlimit limit; int rc; rc = getrlimit (RLIMIT_STACK, &limit); if (rc != 0) exit (0); if (limit.rlim_cur < MINSTACKBYTES){ fprintf (stderr, "\nThe current stack size limit is too low (%luk)\n" "You must increase it with one of the following commands:\n" "Under sh, bash, zsh: ulimit -s %lu\n" "Under csh, tcsh: limit stacksize %lu\n\n", (unsigned long) (limit.rlim_cur / 1024), (unsigned long) (MINSTACKBYTES / 1024), (unsigned long) (MINSTACKBYTES / 1024)); exit (3); } exit (0); } mingw-ocaml/ocaml/tools/make-opcodes0000644000175000017500000000014612124403240017110 0ustar tootstoots$1=="enum" {n=0; next; } {for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}} mingw-ocaml/ocaml/tools/objinfo_helper.c0000644000175000017500000000463212124403240017753 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Mehdi Dogguy, PPS laboratory, University Paris Diderot */ /* */ /* Copyright 2010 Mehdi Dogguy. Used and distributed as part of */ /* OCaml by permission from the author. This file is */ /* distributed under the terms of the Q Public License version 1.0. */ /***********************************************************************/ #include "../config/s.h" #include "../byterun/mlvalues.h" #include "../byterun/alloc.h" #include #ifdef HAS_LIBBFD #include #include #include int main(int argc, char ** argv) { bfd *fd; asection *sec; file_ptr offset; long st_size; asymbol ** symbol_table; long sym_count, i; if (argc != 2) { fprintf(stderr, "Usage: objinfo_helper \n"); return 2; } fd = bfd_openr(argv[1], "default"); if (!fd) { fprintf(stderr, "Error opening file %s\n", argv[1]); return 2; } if (! bfd_check_format (fd, bfd_object)) { fprintf(stderr, "Error: wrong format\n"); bfd_close(fd); return 2; } sec = bfd_get_section_by_name(fd, ".data"); if (! sec) { fprintf(stderr, "Error: section .data not found\n"); bfd_close(fd); return 2; } offset = sec->filepos; st_size = bfd_get_dynamic_symtab_upper_bound (fd); if (st_size <= 0) { fprintf(stderr, "Error: size of section .data unknown\n"); bfd_close(fd); return 2; } symbol_table = malloc(st_size); if (! symbol_table) { fprintf(stderr, "Error: out of memory\n"); bfd_close(fd); return 2; } sym_count = bfd_canonicalize_dynamic_symtab (fd, symbol_table); for (i = 0; i < sym_count; i++) { if (strcmp(symbol_table[i]->name, "caml_plugin_header") == 0) { printf("%ld\n", (long) (offset + symbol_table[i]->value)); bfd_close(fd); return 0; } } fprintf(stderr, "Error: missing symbol caml_plugin_header\n"); bfd_close(fd); return 2; } #else int main(int argc, char ** argv) { fprintf(stderr, "BFD library unavailable, cannot print info on .cmxs files\n"); return 2; } #endif mingw-ocaml/ocaml/tools/profiling.mli0000644000175000017500000000213312124403240017310 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez and Francois Rouaix, INRIA Rocquencourt *) (* Ported to OCaml by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Run-time library for profiled programs *) val counters: (string * (string * int array)) list ref;; val incr: int array -> int -> unit;; mingw-ocaml/ocaml/tools/lexer301.mll0000644000175000017500000002710112124403240016667 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* The lexer definition *) { open Misc type token = AMPERAMPER | AMPERSAND | AND | AS | ASSERT | BACKQUOTE | BAR | BARBAR | BARRBRACKET | BEGIN | CHAR of (char) | CLASS | COLON | COLONCOLON | COLONEQUAL | COLONGREATER | COMMA | CONSTRAINT | DO | DONE | DOT | DOTDOT | DOWNTO | ELSE | END | EOF | EQUAL | EXCEPTION | EXTERNAL | FALSE | FLOAT of (string) | FOR | FUN | FUNCTION | FUNCTOR | GREATER | GREATERRBRACE | GREATERRBRACKET | IF | IN | INCLUDE | INFIXOP0 of (string) | INFIXOP1 of (string) | INFIXOP2 of (string) | INFIXOP3 of (string) | INFIXOP4 of (string) | INHERIT | INITIALIZER | INT of (int) | LABEL of (string) | LAZY | LBRACE | LBRACELESS | LBRACKET | LBRACKETBAR | LBRACKETLESS | LESS | LESSMINUS | LET | LIDENT of (string) | LPAREN | MATCH | METHOD | MINUS | MINUSDOT | MINUSGREATER | MODULE | MUTABLE | NEW | OBJECT | OF | OPEN | OPTLABEL of (string) | OR | PARSER | PLUS | PREFIXOP of (string) | PRIVATE | QUESTION | QUESTION2 | QUOTE | RBRACE | RBRACKET | REC | RPAREN | SEMI | SEMISEMI | SHARP | SIG | STAR | STRING of (string) | STRUCT | THEN | TILDE | TO | TRUE | TRY | TYPE | UIDENT of (string) | UNDERSCORE | VAL | VIRTUAL | WHEN | WHILE | WITH type error = | Illegal_character of char | Unterminated_comment | Unterminated_string | Unterminated_string_in_comment | Keyword_as_label of string ;; exception Error of error * int * int (* The table of keywords *) let keyword_table = create_hashtable 149 [ "and", AND; "as", AS; "assert", ASSERT; "begin", BEGIN; "class", CLASS; "constraint", CONSTRAINT; "do", DO; "done", DONE; "downto", DOWNTO; "else", ELSE; "end", END; "exception", EXCEPTION; "external", EXTERNAL; "false", FALSE; "for", FOR; "fun", FUN; "function", FUNCTION; "functor", FUNCTOR; "if", IF; "in", IN; "include", INCLUDE; "inherit", INHERIT; "initializer", INITIALIZER; "lazy", LAZY; "let", LET; "match", MATCH; "method", METHOD; "module", MODULE; "mutable", MUTABLE; "new", NEW; "object", OBJECT; "of", OF; "open", OPEN; "or", OR; "parser", PARSER; "private", PRIVATE; "rec", REC; "sig", SIG; "struct", STRUCT; "then", THEN; "to", TO; "true", TRUE; "try", TRY; "type", TYPE; "val", VAL; "virtual", VIRTUAL; "when", WHEN; "while", WHILE; "with", WITH; "mod", INFIXOP3("mod"); "land", INFIXOP3("land"); "lor", INFIXOP3("lor"); "lxor", INFIXOP3("lxor"); "lsl", INFIXOP4("lsl"); "lsr", INFIXOP4("lsr"); "asr", INFIXOP4("asr") ] (* To buffer string literals *) let initial_string_buffer = String.create 256 let string_buff = ref initial_string_buffer let string_index = ref 0 let reset_string_buffer () = string_buff := initial_string_buffer; string_index := 0 let store_string_char c = if !string_index >= String.length (!string_buff) then begin let new_buff = String.create (String.length (!string_buff) * 2) in String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff)); string_buff := new_buff end; String.unsafe_set (!string_buff) (!string_index) c; incr string_index let get_stored_string () = let s = String.sub (!string_buff) 0 (!string_index) in string_buff := initial_string_buffer; s (* To translate escape sequences *) let char_for_backslash = function | 'n' -> '\010' | 'r' -> '\013' | 'b' -> '\008' | 't' -> '\009' | c -> c let char_for_decimal_code lexbuf i = let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in Char.chr(c land 0xFF) (* To store the position of the beginning of a string and comment *) let string_start_pos = ref 0;; let comment_start_pos = ref [];; let in_comment () = !comment_start_pos <> [];; (* Error report *) open Format let report_error ppf = function | Illegal_character c -> fprintf ppf "Illegal character (%s)" (Char.escaped c) | Unterminated_comment -> fprintf ppf "Comment not terminated" | Unterminated_string -> fprintf ppf "String literal not terminated" | Unterminated_string_in_comment -> fprintf ppf "This comment contains an unterminated string literal" | Keyword_as_label kwd -> fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd ;; } let blank = [' ' '\010' '\013' '\009' '\012'] let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] let identchar = ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] let symbolchar = ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] let decimal_literal = ['0'-'9']+ let hex_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ let oct_literal = '0' ['o' 'O'] ['0'-'7']+ let bin_literal = '0' ['b' 'B'] ['0'-'1']+ let float_literal = ['0'-'9']+ ('.' ['0'-'9']* )? (['e' 'E'] ['+' '-']? ['0'-'9']+)? rule token = parse blank + { token lexbuf } | "_" { UNDERSCORE } | "~" { TILDE } | "~" lowercase identchar * ':' { let s = Lexing.lexeme lexbuf in let name = String.sub s 1 (String.length s - 2) in if Hashtbl.mem keyword_table name then raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)); LABEL name } | "?" { QUESTION } | "?" lowercase identchar * ':' { let s = Lexing.lexeme lexbuf in let name = String.sub s 1 (String.length s - 2) in if Hashtbl.mem keyword_table name then raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)); OPTLABEL name } | lowercase identchar * { let s = Lexing.lexeme lexbuf in try Hashtbl.find keyword_table s with Not_found -> LIDENT s } | uppercase identchar * { UIDENT(Lexing.lexeme lexbuf) } (* No capitalized keywords *) | decimal_literal | hex_literal | oct_literal | bin_literal { INT (int_of_string(Lexing.lexeme lexbuf)) } | float_literal { FLOAT (Lexing.lexeme lexbuf) } | "\"" { reset_string_buffer(); let string_start = Lexing.lexeme_start lexbuf in string_start_pos := string_start; string lexbuf; lexbuf.Lexing.lex_start_pos <- string_start - lexbuf.Lexing.lex_abs_pos; STRING (get_stored_string()) } | "'" [^ '\\' '\''] "'" { CHAR(Lexing.lexeme_char lexbuf 1) } | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) } | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { CHAR(char_for_decimal_code lexbuf 2) } | "(*" { comment_start_pos := [Lexing.lexeme_start lexbuf]; comment lexbuf; token lexbuf } | "(*)" { let loc = Location.curr lexbuf and warn = Warnings.Comment_start in Location.prerr_warning loc warn; comment_start_pos := [Lexing.lexeme_start lexbuf]; comment lexbuf; token lexbuf } | "*)" { let loc = Location.curr lexbuf and warn = Warnings.Comment_not_end in Location.prerr_warning loc warn; lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; STAR } | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n") (* # linenum ... *) { token lexbuf } | "#" { SHARP } | "&" { AMPERSAND } | "&&" { AMPERAMPER } | "`" { BACKQUOTE } | "'" { QUOTE } | "(" { LPAREN } | ")" { RPAREN } | "*" { STAR } | "," { COMMA } | "??" { QUESTION2 } | "->" { MINUSGREATER } | "." { DOT } | ".." { DOTDOT } | ":" { COLON } | "::" { COLONCOLON } | ":=" { COLONEQUAL } | ":>" { COLONGREATER } | ";" { SEMI } | ";;" { SEMISEMI } | "<" { LESS } | "<-" { LESSMINUS } | "=" { EQUAL } | "[" { LBRACKET } | "[|" { LBRACKETBAR } | "[<" { LBRACKETLESS } | "]" { RBRACKET } | "{" { LBRACE } | "{<" { LBRACELESS } | "|" { BAR } | "||" { BARBAR } | "|]" { BARRBRACKET } | ">" { GREATER } | ">]" { GREATERRBRACKET } | "}" { RBRACE } | ">}" { GREATERRBRACE } | "!=" { INFIXOP0 "!=" } | "+" { PLUS } | "-" { MINUS } | "-." { MINUSDOT } | "!" symbolchar * { PREFIXOP(Lexing.lexeme lexbuf) } | ['~' '?'] symbolchar + { PREFIXOP(Lexing.lexeme lexbuf) } | ['=' '<' '>' '|' '&' '$'] symbolchar * { INFIXOP0(Lexing.lexeme lexbuf) } | ['@' '^'] symbolchar * { INFIXOP1(Lexing.lexeme lexbuf) } | ['+' '-'] symbolchar * { INFIXOP2(Lexing.lexeme lexbuf) } | "**" symbolchar * { INFIXOP4(Lexing.lexeme lexbuf) } | ['*' '/' '%'] symbolchar * { INFIXOP3(Lexing.lexeme lexbuf) } | eof { EOF } | _ { raise (Error(Illegal_character ((Lexing.lexeme lexbuf).[0]), Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) } and comment = parse "(*" { comment_start_pos := Lexing.lexeme_start lexbuf :: !comment_start_pos; comment lexbuf; } | "*)" { match !comment_start_pos with | [] -> assert false | [x] -> comment_start_pos := []; | _ :: l -> comment_start_pos := l; comment lexbuf; } | "\"" { reset_string_buffer(); string_start_pos := Lexing.lexeme_start lexbuf; begin try string lexbuf with Error (Unterminated_string, _, _) -> let st = List.hd !comment_start_pos in raise (Error (Unterminated_string_in_comment, st, st + 2)) end; string_buff := initial_string_buffer; comment lexbuf } | "''" { comment lexbuf } | "'" [^ '\\' '\''] "'" { comment lexbuf } | "'\\" ['\\' '\'' 'n' 't' 'b' 'r'] "'" { comment lexbuf } | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { comment lexbuf } | eof { let st = List.hd !comment_start_pos in raise (Error (Unterminated_comment, st, st + 2)); } | _ { comment lexbuf } and string = parse '"' { () } | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] * { string lexbuf } | '\\' ['\\' '"' 'n' 't' 'b' 'r'] { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); string lexbuf } | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_string_char(char_for_decimal_code lexbuf 1); string lexbuf } | eof { raise (Error (Unterminated_string, !string_start_pos, !string_start_pos+1)) } | _ { store_string_char(Lexing.lexeme_char lexbuf 0); string lexbuf } mingw-ocaml/ocaml/tools/primreq.ml0000644000175000017500000000612712124403240016634 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Determine the set of C primitives required by the given .cmo and .cma files *) open Config open Cmo_format module StringSet = Set.Make(struct type t = string let compare = compare end) let defined = ref true let used = ref false let exclude_file = ref "" let primitives = ref StringSet.empty let scan_reloc = function (Reloc_primitive s, _) -> primitives := StringSet.add s !primitives | _ -> () let scan_prim s = primitives := StringSet.add s !primitives let scan_info cu = if !used then List.iter scan_reloc cu.cu_reloc; if !defined then List.iter scan_prim cu.cu_primitives let scan_obj filename = let ic = open_in_bin filename in let buffer = String.create (String.length cmo_magic_number) in really_input ic buffer 0 (String.length cmo_magic_number); if buffer = cmo_magic_number then begin let cu_pos = input_binary_int ic in seek_in ic cu_pos; let cu = (input_value ic : compilation_unit) in close_in ic; scan_info cu end else if buffer = cma_magic_number then begin let toc_pos = input_binary_int ic in seek_in ic toc_pos; let toc = (input_value ic : library) in close_in ic; List.iter scan_info toc.lib_units end else begin prerr_endline "Not an object file"; exit 2 end let exclude filename = let ic = open_in filename in try while true do let s = input_line ic in primitives := StringSet.remove s !primitives done with End_of_file -> close_in ic | x -> close_in ic; raise x let main() = Arg.parse ["-used", Arg.Unit(fun () -> used := true; defined := false), "show primitives referenced in the object files"; "-defined", Arg.Unit(fun () -> defined := true; used := false), "show primitives defined in the object files (default)"; "-all", Arg.Unit(fun () -> defined := true; used := true), "show primitives defined or referenced in the object files"; "-exclude", Arg.String(fun s -> exclude_file := s), " don't print the primitives mentioned in "] scan_obj "Usage: primreq [options] <.cmo and .cma files>\nOptions are:"; if String.length !exclude_file > 0 then exclude !exclude_file; StringSet.iter (fun s -> if s.[0] <> '%' then begin print_string s; print_newline() end) !primitives; exit 0 let _ = main () mingw-ocaml/ocaml/tools/profiling.ml0000644000175000017500000000405712124403240017146 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez and Francois Rouaix, INRIA Rocquencourt *) (* Ported to Caml Special Light by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Run-time library for profiled programs *) type profiling_counters = (string * (string * int array)) list let counters = ref ([] : profiling_counters);; let incr a i = a.(i) <- a.(i) + 1;; exception Bad_profile let dump_counters () = let dumpfile = try Sys.getenv "OCAMLPROF_DUMP" with Not_found -> "ocamlprof.dump" in begin try let ic = open_in_bin dumpfile in let prevl = (input_value ic : profiling_counters) in close_in ic; List.iter2 (fun (curname, (curmodes,curcount)) (prevname, (prevmodes,prevcount)) -> if curname <> prevname || curmodes <> prevmodes || Array.length curcount <> Array.length prevcount then raise Bad_profile) !counters prevl; List.iter2 (fun (curname, (_,curcount)) (prevname, (_,prevcount)) -> for i = 0 to Array.length curcount - 1 do curcount.(i) <- curcount.(i) + prevcount.(i) done) !counters prevl with _ -> () end; begin try let oc = open_out_bin dumpfile in output_value oc !counters; close_out oc with _ -> () end let _ = at_exit dump_counters mingw-ocaml/ocaml/tools/lexer299.mll0000644000175000017500000002732712124403240016721 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* The lexer definition *) { open Lexing open Misc type token = AMPERAMPER | AMPERSAND | AND | AS | ASSERT | BACKQUOTE | BAR | BARBAR | BARRBRACKET | BEGIN | CHAR of (char) | CLASS | COLON | COLONCOLON | COLONEQUAL | COLONGREATER | COMMA | CONSTRAINT | DO | DONE | DOT | DOTDOT | DOWNTO | ELSE | END | EOF | EQUAL | EXCEPTION | EXTERNAL | FALSE | FLOAT of (string) | FOR | FUN | FUNCTION | FUNCTOR | GREATER | GREATERRBRACE | GREATERRBRACKET | IF | IN | INCLUDE | INFIXOP0 of (string) | INFIXOP1 of (string) | INFIXOP2 of (string) | INFIXOP3 of (string) | INFIXOP4 of (string) | INHERIT | INITIALIZER | INT of (int) | LABEL of (string) | LABELID of (string) | LAZY | LBRACE | LBRACELESS | LBRACKET | LBRACKETBAR | LBRACKETLESS | LESS | LESSMINUS | LET | LIDENT of (string) | LPAREN | MATCH | METHOD | MINUSGREATER | MODULE | MUTABLE | NEW | OBJECT | OF | OPEN | OR | PARSER | PREFIXOP of (string) | PRIVATE | QUESTION | QUESTION2 | QUOTE | RBRACE | RBRACKET | REC | RPAREN | SEMI | SEMISEMI | SHARP | SIG | STAR | STRING of (string) | STRUCT | SUBTRACTIVE of (string) | THEN | TO | TRUE | TRY | TYPE | UIDENT of (string) | UNDERSCORE | VAL | VIRTUAL | WHEN | WHILE | WITH type error = | Illegal_character of char | Unterminated_comment | Unterminated_string | Unterminated_string_in_comment ;; exception Error of error * int * int (* The table of keywords *) let keyword_table = create_hashtable 149 [ "and", AND; "as", AS; "assert", ASSERT; "begin", BEGIN; "class", CLASS; "constraint", CONSTRAINT; "do", DO; "done", DONE; "downto", DOWNTO; "else", ELSE; "end", END; "exception", EXCEPTION; "external", EXTERNAL; "false", FALSE; "for", FOR; "fun", FUN; "function", FUNCTION; "functor", FUNCTOR; "if", IF; "in", IN; "include", INCLUDE; "inherit", INHERIT; "initializer", INITIALIZER; "lazy", LAZY; "let", LET; "match", MATCH; "method", METHOD; "module", MODULE; "mutable", MUTABLE; "new", NEW; "object", OBJECT; "of", OF; "open", OPEN; "or", OR; "parser", PARSER; "private", PRIVATE; "rec", REC; "sig", SIG; "struct", STRUCT; "then", THEN; "to", TO; "true", TRUE; "try", TRY; "type", TYPE; "val", VAL; "virtual", VIRTUAL; "when", WHEN; "while", WHILE; "with", WITH; "mod", INFIXOP3("mod"); "land", INFIXOP3("land"); "lor", INFIXOP3("lor"); "lxor", INFIXOP3("lxor"); "lsl", INFIXOP4("lsl"); "lsr", INFIXOP4("lsr"); "asr", INFIXOP4("asr") ] (* To buffer string literals *) let initial_string_buffer = String.create 256 let string_buff = ref initial_string_buffer let string_index = ref 0 let reset_string_buffer () = string_buff := initial_string_buffer; string_index := 0 let store_string_char c = if !string_index >= String.length (!string_buff) then begin let new_buff = String.create (String.length (!string_buff) * 2) in String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff)); string_buff := new_buff end; String.unsafe_set (!string_buff) (!string_index) c; incr string_index let get_stored_string () = let s = String.sub (!string_buff) 0 (!string_index) in string_buff := initial_string_buffer; s (* To translate escape sequences *) let char_for_backslash = function | 'n' -> '\010' | 'r' -> '\013' | 'b' -> '\008' | 't' -> '\009' | c -> c let char_for_decimal_code lexbuf i = let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in Char.chr(c land 0xFF) (* To store the position of the beginning of a string and comment *) let string_start_pos = ref 0;; let comment_start_pos = ref [];; (* Error report *) open Format let report_error ppf = function | Illegal_character c -> fprintf ppf "Illegal character (%s)" (Char.escaped c) | Unterminated_comment -> fprintf ppf "Comment not terminated" | Unterminated_string -> fprintf ppf "String literal not terminated" | Unterminated_string_in_comment -> fprintf ppf "This comment contains an unterminated string literal" ;; } let blank = [' ' '\010' '\013' '\009' '\012'] let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] let identchar = ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] let symbolchar = ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] let symbolchar2 = ['!' '$' '%' '&' '*' '+' '-' '.' '/' '<' '=' '>' '?' '@' '^' '|' '~'] (* ['!' '$' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] *) let decimal_literal = ['0'-'9']+ let hex_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ let oct_literal = '0' ['o' 'O'] ['0'-'7']+ let bin_literal = '0' ['b' 'B'] ['0'-'1']+ let float_literal = ['0'-'9']+ ('.' ['0'-'9']* )? (['e' 'E'] ['+' '-']? ['0'-'9']+)? rule token = parse blank + { token lexbuf } | "_" { UNDERSCORE } | lowercase identchar * ':' [ ^ ':' '=' '>'] { let s = Lexing.lexeme lexbuf in lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - 1; lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_cnum = lexbuf.lex_curr_p.pos_cnum - 1}; LABEL (String.sub s 0 (String.length s - 2)) } (* | lowercase identchar * ':' { let s = Lexing.lexeme lexbuf in LABEL (String.sub s 0 (String.length s - 1)) } | '%' lowercase identchar * *) | ':' lowercase identchar * { let s = Lexing.lexeme lexbuf in let l = String.length s - 1 in LABELID (String.sub s 1 l) } | lowercase identchar * { let s = Lexing.lexeme lexbuf in try Hashtbl.find keyword_table s with Not_found -> LIDENT s } | uppercase identchar * { UIDENT(Lexing.lexeme lexbuf) } (* No capitalized keywords *) | decimal_literal | hex_literal | oct_literal | bin_literal { INT (int_of_string(Lexing.lexeme lexbuf)) } | float_literal { FLOAT (Lexing.lexeme lexbuf) } | "\"" { reset_string_buffer(); let string_start = Lexing.lexeme_start lexbuf in string_start_pos := string_start; string lexbuf; lexbuf.Lexing.lex_start_pos <- string_start - lexbuf.Lexing.lex_abs_pos; STRING (get_stored_string()) } | "'" [^ '\\' '\''] "'" { CHAR(Lexing.lexeme_char lexbuf 1) } | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) } | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { CHAR(char_for_decimal_code lexbuf 2) } | "(*" { comment_start_pos := [Lexing.lexeme_start lexbuf]; comment lexbuf; token lexbuf } | "(*)" { let loc = { Location.loc_start = Lexing.lexeme_start_p lexbuf; Location.loc_end = Lexing.lexeme_end_p lexbuf; Location.loc_ghost = false } in Location.prerr_warning loc (Warnings.Comment_start); comment_start_pos := [Lexing.lexeme_start lexbuf]; comment lexbuf; token lexbuf } | "*)" { let loc = { Location.loc_start = Lexing.lexeme_start_p lexbuf; Location.loc_end = Lexing.lexeme_end_p lexbuf; Location.loc_ghost = false } in Location.prerr_warning loc Warnings.Comment_not_end; lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; STAR } | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n") (* # linenum ... *) { token lexbuf } | "#" { SHARP } | "&" { AMPERSAND } | "&&" { AMPERAMPER } | "`" { BACKQUOTE } | "'" { QUOTE } | "(" { LPAREN } | ")" { RPAREN } | "*" { STAR } | "," { COMMA } | "?" { QUESTION } | "??" { QUESTION2 } | "->" { MINUSGREATER } | "." { DOT } | ".." { DOTDOT } | ":" { COLON } | "::" { COLONCOLON } | ":=" { COLONEQUAL } | ":>" { COLONGREATER } | ";" { SEMI } | ";;" { SEMISEMI } | "<" { LESS } | "<-" { LESSMINUS } | "=" { EQUAL } | "[" { LBRACKET } | "[|" { LBRACKETBAR } | "[<" { LBRACKETLESS } | "]" { RBRACKET } | "{" { LBRACE } | "{<" { LBRACELESS } | "|" { BAR } | "||" { BARBAR } | "|]" { BARRBRACKET } | ">" { GREATER } | ">]" { GREATERRBRACKET } | "}" { RBRACE } | ">}" { GREATERRBRACE } | "!=" { INFIXOP0 "!=" } | "-" { SUBTRACTIVE "-" } | "-." { SUBTRACTIVE "-." } | ['!' '~'] symbolchar * { PREFIXOP(Lexing.lexeme lexbuf) } | '?' symbolchar2 * { PREFIXOP(Lexing.lexeme lexbuf) } | ['=' '<' '>' '|' '&' '$'] symbolchar * { INFIXOP0(Lexing.lexeme lexbuf) } | ['@' '^'] symbolchar * { INFIXOP1(Lexing.lexeme lexbuf) } | ['+' '-'] symbolchar * { INFIXOP2(Lexing.lexeme lexbuf) } | "**" symbolchar * { INFIXOP4(Lexing.lexeme lexbuf) } | ['*' '/' '%'] symbolchar * { INFIXOP3(Lexing.lexeme lexbuf) } | eof { EOF } | _ { raise (Error(Illegal_character ((Lexing.lexeme lexbuf).[0]), Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) } and comment = parse "(*" { comment_start_pos := Lexing.lexeme_start lexbuf :: !comment_start_pos; comment lexbuf; } | "*)" { match !comment_start_pos with | [] -> assert false | [x] -> () | _ :: l -> comment_start_pos := l; comment lexbuf; } | "\"" { reset_string_buffer(); string_start_pos := Lexing.lexeme_start lexbuf; begin try string lexbuf with Error (Unterminated_string, _, _) -> let st = List.hd !comment_start_pos in raise (Error (Unterminated_string_in_comment, st, st + 2)) end; string_buff := initial_string_buffer; comment lexbuf } | "''" { comment lexbuf } | "'" [^ '\\' '\''] "'" { comment lexbuf } | "'\\" ['\\' '\'' 'n' 't' 'b' 'r'] "'" { comment lexbuf } | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { comment lexbuf } | eof { let st = List.hd !comment_start_pos in raise (Error (Unterminated_comment, st, st + 2)); } | _ { comment lexbuf } and string = parse '"' { () } | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] * { string lexbuf } | '\\' ['\\' '"' 'n' 't' 'b' 'r'] { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); string lexbuf } | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_string_char(char_for_decimal_code lexbuf 1); string lexbuf } | eof { raise (Error (Unterminated_string, !string_start_pos, !string_start_pos+1)) } | _ { store_string_char(Lexing.lexeme_char lexbuf 0); string lexbuf } mingw-ocaml/ocaml/tools/.depend0000644000175000017500000001176512124403240016067 0ustar tootstootsdepend.cmi : ../parsing/parsetree.cmi profiling.cmi : typedtreeIter.cmi : ../typing/typedtree.cmi ../parsing/asttypes.cmi untypeast.cmi : ../typing/typedtree.cmi ../typing/path.cmi \ ../parsing/parsetree.cmi ../parsing/longident.cmi addlabels.cmo : ../parsing/parsetree.cmi ../parsing/parse.cmi \ ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi addlabels.cmx : ../parsing/parsetree.cmi ../parsing/parse.cmx \ ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi cmt2annot.cmo : untypeast.cmi typedtreeIter.cmi ../typing/typedtree.cmi \ ../typing/stypes.cmi pprintast.cmo ../typing/path.cmi \ ../typing/oprint.cmi ../parsing/location.cmi ../typing/ident.cmi \ ../typing/env.cmi ../typing/cmt_format.cmi ../parsing/asttypes.cmi \ ../typing/annot.cmi cmt2annot.cmx : untypeast.cmx typedtreeIter.cmx ../typing/typedtree.cmx \ ../typing/stypes.cmx pprintast.cmx ../typing/path.cmx \ ../typing/oprint.cmx ../parsing/location.cmx ../typing/ident.cmx \ ../typing/env.cmx ../typing/cmt_format.cmx ../parsing/asttypes.cmi \ ../typing/annot.cmi cvt_emit.cmo : cvt_emit.cmx : depend.cmo : ../parsing/parsetree.cmi ../utils/misc.cmi \ ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi \ depend.cmi depend.cmx : ../parsing/parsetree.cmi ../utils/misc.cmx \ ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi \ depend.cmi dumpobj.cmo : ../utils/tbl.cmi opnames.cmo ../bytecomp/opcodes.cmo \ ../utils/misc.cmi ../parsing/location.cmi ../bytecomp/lambda.cmi \ ../bytecomp/instruct.cmi ../typing/ident.cmi ../bytecomp/emitcode.cmi \ ../utils/config.cmi ../bytecomp/cmo_format.cmi \ ../bytecomp/bytesections.cmi ../parsing/asttypes.cmi dumpobj.cmx : ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.cmx \ ../utils/misc.cmx ../parsing/location.cmx ../bytecomp/lambda.cmx \ ../bytecomp/instruct.cmx ../typing/ident.cmx ../bytecomp/emitcode.cmx \ ../utils/config.cmx ../bytecomp/cmo_format.cmi \ ../bytecomp/bytesections.cmx ../parsing/asttypes.cmi myocamlbuild_config.cmo : myocamlbuild_config.cmx : objinfo.cmo : ../utils/misc.cmi ../utils/config.cmi \ ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \ ../typing/cmi_format.cmi ../asmcomp/clambda.cmi \ ../bytecomp/bytesections.cmi objinfo.cmx : ../utils/misc.cmx ../utils/config.cmx \ ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \ ../typing/cmi_format.cmx ../asmcomp/clambda.cmx \ ../bytecomp/bytesections.cmx ocaml299to3.cmo : ocaml299to3.cmx : ocamlcp.cmo : ../driver/main_args.cmi ocamlcp.cmx : ../driver/main_args.cmx ocamldep.cmo : ../parsing/syntaxerr.cmi ../parsing/parsetree.cmi \ ../parsing/parse.cmi ../utils/misc.cmi ../parsing/longident.cmi \ ../parsing/location.cmi ../parsing/lexer.cmi depend.cmi \ ../utils/config.cmi ../utils/clflags.cmi ocamldep.cmx : ../parsing/syntaxerr.cmx ../parsing/parsetree.cmi \ ../parsing/parse.cmx ../utils/misc.cmx ../parsing/longident.cmx \ ../parsing/location.cmx ../parsing/lexer.cmx depend.cmx \ ../utils/config.cmx ../utils/clflags.cmx ocamlmklib.cmo : myocamlbuild_config.cmo ocamlmklib.cmx : myocamlbuild_config.cmx ocamlmktop.cmo : ../utils/ccomp.cmi ocamlmktop.cmx : ../utils/ccomp.cmx ocamloptp.cmo : ../driver/main_args.cmi ocamloptp.cmx : ../driver/main_args.cmx ocamlprof.cmo : ../utils/warnings.cmi ../parsing/syntaxerr.cmi \ ../parsing/parsetree.cmi ../parsing/parse.cmi ../utils/misc.cmi \ ../parsing/location.cmi ../parsing/lexer.cmi ../utils/config.cmi \ ../utils/clflags.cmi ocamlprof.cmx : ../utils/warnings.cmx ../parsing/syntaxerr.cmx \ ../parsing/parsetree.cmi ../parsing/parse.cmx ../utils/misc.cmx \ ../parsing/location.cmx ../parsing/lexer.cmx ../utils/config.cmx \ ../utils/clflags.cmx opnames.cmo : opnames.cmx : pprintast.cmo : ../parsing/parsetree.cmi ../parsing/longident.cmi \ ../parsing/location.cmi ../parsing/asttypes.cmi pprintast.cmx : ../parsing/parsetree.cmi ../parsing/longident.cmx \ ../parsing/location.cmx ../parsing/asttypes.cmi primreq.cmo : ../utils/config.cmi ../bytecomp/cmo_format.cmi primreq.cmx : ../utils/config.cmx ../bytecomp/cmo_format.cmi profiling.cmo : profiling.cmi profiling.cmx : profiling.cmi read_cmt.cmo : ../typing/cmt_format.cmi cmt2annot.cmo ../utils/clflags.cmi read_cmt.cmx : ../typing/cmt_format.cmx cmt2annot.cmx ../utils/clflags.cmx scrapelabels.cmo : scrapelabels.cmx : typedtreeIter.cmo : ../typing/typedtree.cmi ../utils/misc.cmi \ ../parsing/asttypes.cmi typedtreeIter.cmi typedtreeIter.cmx : ../typing/typedtree.cmx ../utils/misc.cmx \ ../parsing/asttypes.cmi typedtreeIter.cmi untypeast.cmo : ../typing/typedtree.cmi ../typing/path.cmi \ ../parsing/parsetree.cmi ../utils/misc.cmi ../parsing/longident.cmi \ ../typing/ident.cmi ../parsing/asttypes.cmi untypeast.cmi untypeast.cmx : ../typing/typedtree.cmx ../typing/path.cmx \ ../parsing/parsetree.cmi ../utils/misc.cmx ../parsing/longident.cmx \ ../typing/ident.cmx ../parsing/asttypes.cmi untypeast.cmi mingw-ocaml/ocaml/tools/cvt_emit.mll0000644000175000017500000000522612124403240017142 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) { let first_item = ref false let command_beginning = ref 0 let add_semicolon () = if !first_item then first_item := false else print_string "; " let print_unescaped_string s = let l = String.length s in let i = ref 0 in while !i < l do if s.[!i] = '\\' && !i+1 < l && (let c = s.[!i+1] in c = '{' || c = '`') (* ` *) then i := !i+1; print_char s.[!i]; i := !i + 1 done } rule main = parse "`" { command_beginning := Lexing.lexeme_start lexbuf; first_item := true; print_char '('; command lexbuf; print_char ')'; main lexbuf } | "\\`" { print_string "`"; main lexbuf } | eof { () } | _ { print_char(Lexing.lexeme_char lexbuf 0); main lexbuf } and command = parse "`" { () } | eof { prerr_string "Unterminated `...` at character "; prerr_int !command_beginning; prerr_newline(); exit 2 } | "{" [^ '}'] * "}" { let s = Lexing.lexeme lexbuf in add_semicolon(); print_string (String.sub s 1 (String.length s - 2)); command lexbuf } | ( [^ '`' '{' '\\'] | '\\' ['\\' '"' 'n' 't' 'b' 'r' '`' '{' ] | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] ) + { let s = Lexing.lexeme lexbuf in add_semicolon(); (* Optimise one-character strings *) if String.length s = 1 && s.[0] <> '\\' && s.[0] <> '\'' || String.length s = 2 && s.[0] = '\\' && s.[1] <> '`' && s.[1]<>'{' (* ` *) then begin print_string "emit_char '"; print_unescaped_string s; print_string "'" end else begin print_string "emit_string \""; print_unescaped_string s; print_string "\"" end; command lexbuf } { let _ = main(Lexing.from_channel stdin) let _ = exit (0) } mingw-ocaml/ocaml/.ignore0000644000175000017500000000030412124403240014736 0ustar tootstootsconfigure ocamlc ocamlc.opt expunge ocaml ocamlopt ocamlopt.opt ocamlcomp.sh ocamlcompopt.sh package-macosx _boot_log1 _boot_log2 _build _log myocamlbuild_config.ml ocamlbuild-mixed-boot ocamlnat mingw-ocaml/ocaml/ocamlbuild/0000755000175000017500000000000012124403240015570 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/main.mli0000644000175000017500000000144712124403240017225 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) val main : unit -> unit mingw-ocaml/ocaml/ocamlbuild/start.sh0000755000175000017500000000726212124403240017273 0ustar tootstoots#!/bin/sh ######################################################################### # # # OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # # Copyright 2007 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### set -e set -x rm -rf _start mkdir _start cp *.ml* _start cd _start cat >> ocamlbuild_Myocamlbuild_config.ml < unit val get : string -> string val put : string -> string -> unit mingw-ocaml/ocaml/ocamlbuild/ppcache.ml0000644000175000017500000000511512124403240017527 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Command open Pathname.Operators let () = Log.level := -1000 let usage () = Format.eprintf "Usage: %s @." Sys.argv.(0); exit 4 let () = if Array.length Sys.argv < 2 then usage () let args = List.tl (Array.to_list Sys.argv) let buf = Buffer.create 2048 let digest_file file = Buffer.add_string buf (Digest.file file) let digest_string string = Buffer.add_string buf (Digest.string string) let search_in_path x = if Sys.file_exists x then x else try search_in_path x with Not_found -> (Format.eprintf "Command not found %s@." x; exit 3) let cmd = match args with | ocamlrun :: x :: _ when String.contains_string ocamlrun 0 "ocamlrun" <> None -> digest_file (search_in_path ocamlrun); x | x :: _ -> x | _ -> usage () let output = ref "" let () = digest_file (search_in_path cmd) let rec loop = function | [] -> Digest.string (Buffer.contents buf) | ("-impl"|"-intf") :: x :: xs -> digest_string x; digest_file x; loop xs | "-o" :: x :: xs -> output := x; loop xs | x :: xs -> let ext = Pathname.get_extension x in digest_string x; (match ext with | "cmo" | "cma" | "ml" | "mli" -> digest_file x | _ -> ()); loop xs let digest = loop args;; let cache_dir = "/tmp/ppcache";; (* FIXME *) let () = Shell.mkdir_p cache_dir;; let path = cache_dir/(Digest.to_hex digest);; let cat path = with_input_file ~bin:true path (fun ic -> copy_chan ic stdout);; if sys_file_exists path then if !output = "" then cat path else Shell.cp path !output else let cmd = atomize args in if !output = "" then begin let tmp = path^".tmp" in Command.execute (Cmd(S[cmd; Sh ">"; A tmp])); Shell.mv tmp path; cat path end else begin Command.execute (Cmd cmd); Shell.cp !output path end mingw-ocaml/ocaml/ocamlbuild/ocaml_arch.mli0000644000175000017500000000153712124403240020371 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) include Signatures.ARCH val forpack_flags_of_pathname : string -> Command.spec mingw-ocaml/ocaml/ocamlbuild/AUTHORS0000644000175000017500000000003612124403240016637 0ustar tootstootsNicolas Pouillard Berke Durak mingw-ocaml/ocaml/ocamlbuild/ocaml_tools.mli0000644000175000017500000000334512124403240020613 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) val ocamldoc_c : Tags.t -> string -> string -> Command.t val ocamldoc_l_dir : Tags.t -> string list -> string -> string -> Command.t val ocamldoc_l_file : Tags.t -> string list -> string -> string -> Command.t val ocamldep_command : string -> string -> Rule.action val menhir_ocamldep_command : string -> string -> Rule.action val menhir_modular_ocamldep_command : string -> string -> Rule.action val menhir_modular : string -> string -> string -> Rule.action val ocamlyacc : string -> Rule.action val ocamllex : string -> Rule.action val menhir : string -> Rule.action val infer_interface : string -> string -> Rule.action val document_ocaml_interf : string -> string -> Rule.action val document_ocaml_implem : string -> string -> Rule.action val document_ocaml_project : ?ocamldoc:(Tags.t -> string list -> string -> string -> Command.t) -> string -> string -> string -> Rule.action val camlp4 : ?default:Command.spec -> Tags.elt -> Pathname.t -> Pathname.t -> Rule.action mingw-ocaml/ocaml/ocamlbuild/pathname.mli0000644000175000017500000000154312124403240020073 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) include Signatures.PATHNAME val link_to_dir : t -> t -> bool val normalize : t -> t mingw-ocaml/ocaml/ocamlbuild/ocamlbuildlight.ml0000644000175000017500000000145612124403240021273 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) Ocamlbuild_pack.Main.main ();; mingw-ocaml/ocaml/ocamlbuild/ocaml_specific.mli0000644000175000017500000000145112124403240021234 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) val init : unit -> unit mingw-ocaml/ocaml/ocamlbuild/my_unix.mli0000644000175000017500000000461312124403240017767 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) type file_kind = | FK_dir | FK_file | FK_link | FK_other type stats = { stat_file_kind : file_kind; stat_key : string } val is_degraded : bool Lazy.t val is_link : string -> bool val run_and_open : string -> (in_channel -> 'a) -> 'a val readlink : string -> string val run_and_read : string -> string (** See [Ocamlbuild_executor.execute] *) val execute_many : ?max_jobs:int -> ?ticker:(unit -> unit) -> ?period:float -> ?display:((out_channel -> unit) -> unit) -> ((unit -> string) list list) -> (bool list * exn) option val report_error : Format.formatter -> exn -> unit val at_exit_once : (unit -> unit) -> unit val gettimeofday : unit -> float val stdout_isatty : unit -> bool val stat : string -> stats val lstat : string -> stats (** internal usage only *) type implem = { mutable is_degraded : bool; mutable is_link : string -> bool; mutable run_and_open : 'a . string -> (in_channel -> 'a) -> 'a; mutable readlink : string -> string; mutable execute_many : ?max_jobs:int -> ?ticker:(unit -> unit) -> ?period:float -> ?display:((out_channel -> unit) -> unit) -> ((unit -> string) list list) -> (bool list * exn) option; mutable report_error : Format.formatter -> exn -> unit; mutable at_exit_once : (unit -> unit) -> unit; mutable gettimeofday : unit -> float; mutable stdout_isatty : unit -> bool; mutable stat : string -> stats; mutable lstat : string -> stats; } val implem : implem mingw-ocaml/ocaml/ocamlbuild/solver.ml0000644000175000017500000001240312124403240017434 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Log open Format open Outcome type backtrace = | Leaf of Pathname.t | Choice of backtrace list | Depth of Pathname.t * backtrace | Target of string * backtrace exception Failed of backtrace exception Circular of Pathname.t * Pathname.t list let failed target backtrace = Resource.Cache.resource_failed target; raise (Failed backtrace) let rec pp_repeat f (n, s) = if n > 0 then (pp_print_string f s; pp_repeat f (n - 1, s)) (* Targets must be normalized pathnames. * Recursive calls are either on input targets * or dependencies of these targets (returned by Rule.deps_of_rule). *) let rec self depth on_the_go_orig target = let rules = Rule.get_rules () in let on_the_go = target :: on_the_go_orig in dprintf 4 "==%a> %a" pp_repeat (depth, "==") Resource.print target; if List.mem target on_the_go_orig then raise (Circular(target, on_the_go_orig)); match Resource.Cache.resource_state target with | Resource.Cache.Bbuilt -> (dprintf 5 "%a already built" Resource.print target) | Resource.Cache.Bcannot_be_built -> (dprintf 5 "%a already failed" Resource.print target; failed target (Leaf target)) | Resource.Cache.Bsuspension(s) -> (dprintf 5 "%a was suspended -> resuming" Resource.print target; Resource.Cache.resume_suspension s) | Resource.Cache.Bnot_built_yet -> if not (Pathname.is_relative target) && Pathname.exists target then if Resource.Cache.external_is_up_to_date target then () else (* perhaps the error can be refined *) failed target (Leaf target) else if Resource.exists_in_source_dir target then Resource.Cache.import_in_build_dir target else match List.filter_opt (Rule.can_produce target) rules with | [] -> failed target (Leaf target) | matching_rules -> let rec until_works rs backtraces = match rs with | [] -> assert false | r :: rs -> try List.iter (force_self (depth + 1) on_the_go) (Rule.deps_of_rule r); try Rule.call (self_firsts (depth + 1) on_the_go) r with Rule.Failed -> raise (Failed (Leaf target)) with Failed backtrace -> if rs = [] then failed target (Depth (target, Choice (backtrace :: backtraces))) else let () = match backtrace with | Depth (top_prod, _) -> Resource.Cache.clear_resource_failed top_prod | Target _ | Choice _ | Leaf _ -> () in until_works rs (backtrace :: backtraces) in until_works matching_rules [] (* Build the first target that is buildable *) and self_first depth on_the_go already_failed rs = match rs with | [] -> Bad (Failed (Choice already_failed)) | r :: rs -> try self depth on_the_go r; Good r with Failed backtrace -> self_first depth on_the_go (backtrace :: already_failed) rs (* This variant is the one (once partially applied) called the 'build' * function in the rule actions. * * This one takes a list of list of pathnames to build. * This is a parallel conjonction of sequential alternatives. * This means that in each sublist of pathnames, the first * target that is buildable will be picked. The outer list * denotes that one can build each target in parallel. *) and self_firsts depth on_the_go rss = let results = List.map (self_first depth on_the_go []) rss in let cmds, thunks = List.fold_right begin fun res ((acc1, acc2) as acc) -> match res with | Bad _ -> acc | Good res -> match Resource.Cache.get_optional_resource_suspension res with | None -> acc | Some (cmd, thunk) -> (cmd :: acc1, thunk :: acc2) end results ([], []) in let count = List.length cmds in let job_debug = if !Command.jobs = 1 then 10 else 5 in if count > 1 then dprintf job_debug ">>> PARALLEL: %d" count; let opt_exn = Command.execute_many cmds in if count > 1 then dprintf job_debug "<<< PARALLEL"; begin match opt_exn with | Some(res, exn) -> List.iter2 (fun res thunk -> if res then thunk ()) res thunks; Log.finish ~how:`Error (); raise exn | None -> List.iter (fun thunk -> thunk ()) thunks end; results and force_self depth on_the_go x = self depth on_the_go x; Resource.Cache.resume_resource x let solve = force_self 0 [] let solve_target name rs = match self_first 0 [] [] rs with | Good res -> Resource.Cache.resume_resource res; res | Bad (Failed backtrace) -> raise (Failed (Target (name, backtrace))) | Bad exn -> raise exn mingw-ocaml/ocaml/ocamlbuild/slurp.ml0000644000175000017500000001444212124403240017274 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Slurp *) open My_std open Outcome type 'a entry = | Dir of string * string * My_unix.stats Lazy.t * 'a * 'a entry list Lazy.t | File of string * string * My_unix.stats Lazy.t * 'a | Error of exn | Nothing let (/) = filename_concat let rec filter predicate = function | Dir(path, name, st, attr, entries) -> if predicate path name attr then Dir(path, name, st, attr, lazy (List.map (filter predicate) !*entries)) else Nothing | File(path, name, _, attr) as f -> if predicate path name attr then f else Nothing | Nothing -> Nothing | Error _ as e -> e let real_slurp path = let cwd = Sys.getcwd () in let abs x = if Filename.is_implicit x || Filename.is_relative x then cwd/x else x in let visited = Hashtbl.create 1024 in let rec scandir path names = let (file_acc, dir_acc) = Array.fold_left begin fun ((file_acc, dir_acc) as acc) name -> match do_entry true path name with | None -> acc | Some((Dir _|Error _) as entry) -> (file_acc, entry :: dir_acc) | Some((File _) as entry) -> (entry :: file_acc, dir_acc) | Some Nothing -> acc end ([], []) names in file_acc @ dir_acc and do_entry link_mode path name = let fn = path/name in let absfn = abs fn in match try Good(if link_mode then My_unix.lstat absfn else My_unix.stat absfn) with | x -> Bad x with | Bad x -> Some(Error x) | Good st -> let key = st.My_unix.stat_key in if try Hashtbl.find visited key with Not_found -> false then None else begin Hashtbl.add visited key true; let res = match st.My_unix.stat_file_kind with | My_unix.FK_link -> let fn' = My_unix.readlink absfn in if sys_file_exists (abs fn') then do_entry false path name else Some(File(path, name, lazy st, ())) | My_unix.FK_dir -> (match sys_readdir absfn with | Good names -> Some(Dir(path, name, lazy st, (), lazy (scandir fn names))) | Bad exn -> Some(Error exn)) | My_unix.FK_other -> None | My_unix.FK_file -> Some(File(path, name, lazy st, ())) in Hashtbl.replace visited key false; res end in match do_entry true "" path with | None -> raise Not_found | Some entry -> entry let split path = let rec aux path = if path = Filename.current_dir_name then [] else (Filename.basename path) :: aux (Filename.dirname path) in List.rev (aux path) let rec join = function | [] -> assert false | [x] -> x | x :: xs -> x/(join xs) let rec add root path entries = match path, entries with | [], _ -> entries | xpath :: xspath, (Dir(dpath, dname, dst, dattr, dentries) as d) :: entries -> if xpath = dname then Dir(dpath, dname, dst, dattr, lazy (add (root/xpath) xspath !*dentries)) :: entries else d :: add root path entries | [xpath], [] -> [File(root, xpath, lazy (My_unix.stat (root/xpath)), ())] | xpath :: xspath, [] -> [Dir(root/(join xspath), xpath, lazy (My_unix.stat (root/(join path))), (), lazy (add (root/xpath) xspath []))] | _, Nothing :: entries -> add root path entries | _, Error _ :: _ -> entries | [xpath], (File(_, fname, _, _) as f) :: entries' -> if xpath = fname then entries else f :: add root path entries' | xpath :: xspath, (File(fpath, fname, fst, fattr) as f) :: entries' -> if xpath = fname then Dir(fpath, fname, fst, fattr, lazy (add (root/xpath) xspath [])) :: entries' else f :: add root path entries' let slurp_with_find path = let find_cmd = try Sys.getenv "OCAMLBUILD_FIND" with _ -> "find" in let lines = My_unix.run_and_open (Printf.sprintf "%s %s" find_cmd (Filename.quote path)) begin fun ic -> let acc = ref [] in try while true do acc := input_line ic :: !acc done; [] with End_of_file -> !acc end in let res = List.fold_right begin fun line acc -> add path (split line) acc end lines [] in match res with | [] -> Nothing | [entry] -> entry | entries -> Dir(path, Filename.basename path, lazy (My_unix.stat path), (), lazy entries) let slurp x = if !*My_unix.is_degraded then slurp_with_find x else real_slurp x let rec print print_attr f entry = match entry with | Dir(path, name, _, attr, entries) -> Format.fprintf f "@[<2>Dir(%S,@ %S,@ _,@ %a,@ %a)@]" path name print_attr attr (List.print (print print_attr)) !*entries | File(path, name, _, attr) -> Format.fprintf f "@[<2>File(%S,@ %S,@ _,@ %a)@]" path name print_attr attr | Nothing -> Format.fprintf f "Nothing" | Error(_) -> Format.fprintf f "Error(_)" let rec fold f entry acc = match entry with | Dir(path, name, _, attr, contents) -> f path name attr (List.fold_right (fold f) !*contents acc) | File(path, name, _, attr) -> f path name attr acc | Nothing | Error _ -> acc let map f entry = let rec self entry = match entry with | Dir(path, name, st, attr, contents) -> Dir(path, name, st, f path name attr, lazy (List.map self !*contents)) | File(path, name, st, attr) -> File(path, name, st, f path name attr) | Nothing -> Nothing | Error e -> Error e in self entry let rec force = function | Dir(_, _, st, _, contents) -> let _ = !*st in List.iter force !*contents | File(_, _, st, _) -> ignore !*st | Nothing | Error _ -> () mingw-ocaml/ocaml/ocamlbuild/exit_codes.ml0000644000175000017500000000255612124403240020260 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) let rc_ok = 0 let rc_usage = 1 let rc_failure = 2 let rc_invalid_argument = 3 let rc_system_error = 4 let rc_hygiene = 1 let rc_circularity = 5 let rc_solver_failed = 6 let rc_ocamldep_error = 7 let rc_lexing_error = 8 let rc_build_error = 9 let rc_executor_subcommand_failed = 10 let rc_executor_subcommand_got_signal = 11 let rc_executor_io_error = 12 let rc_executor_excetptional_condition = 13 mingw-ocaml/ocaml/ocamlbuild/_tags0000644000175000017500000000231412124403240016610 0ustar tootstoots######################################################################### # # # OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # # Copyright 2007 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # OCamlbuild tags file true: debug <*.ml> or <*.mli>: warn_L, warn_R, warn_Z, annot "discard_printf.ml": rectypes "ocamlbuildlib.cma" or "ocamlbuildlightlib.cma": linkall <*.byte> or <*.native> or <*.top>: use_unix "ocamlbuildlight.byte": -use_unix, nopervasives <*.cmx>: for-pack(Ocamlbuild_pack) <{ocamlbuild_{pack,unix_plugin,plugin,executor},ppcache}{,.p}.cmx>: -for-pack(Ocamlbuild_pack) "doc": not_hygienic mingw-ocaml/ocaml/ocamlbuild/glob.ml0000644000175000017500000002651112124403240017052 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Glob *) open My_std;; open Bool;; include Glob_ast;; open Glob_lexer;; let sf = Printf.sprintf;; let brute_limit = 10;; (*** string_of_token *) let string_of_token = function | ATOM _ -> "ATOM" | AND -> "AND" | OR -> "OR" | NOT -> "NOT" | LPAR -> "LPAR" | RPAR -> "RPAR" | TRUE -> "TRUE" | FALSE -> "FALSE" | EOF -> "EOF" ;; (* ***) (*** match_character_class *) let match_character_class cl c = Bool.eval begin function (c1,c2) -> c1 <= c && c <= c2 end cl ;; (* ***) (*** NFA *) module NFA = struct type transition = | QCLASS of character_class | QEPSILON ;; module IS = Set.Make(struct type t = int let compare = compare let print = Format.pp_print_int end);; module ISM = Map.Make(struct type t = IS.t let compare = IS.compare let print = IS.print end);; type machine = { mc_qi : IS.t; mc_table : (character_class * IS.t) list array; mc_qf : int; mc_power_table : (char, IS.t ISM.t) Hashtbl.t } (*** build' *) let build' p = let count = ref 0 in let transitions = ref [] in let epsilons : (int * int) list ref = ref [] in let state () = let id = !count in incr count; id in let ( --> ) q1 t q2 = match t with | QEPSILON -> epsilons := (q1,q2) :: !epsilons; q1 | QCLASS cl -> transitions := (q1,cl,q2) :: !transitions; q1 in (* Construit les transitions correspondant au motif donné et arrivant * sur l'état qf. Retourne l'état d'origine. *) let rec loop qf = function | Epsilon -> qf | Word u -> let m = String.length u in let q0 = state () in let rec loop q i = if i = m then q0 else begin let q' = if i = m - 1 then qf else state () in let _ = (q --> QCLASS(Atom(u.[i], u.[i]))) q' in loop q' (i + 1) end in loop q0 0 | Class cl -> let q1 = state () in (q1 --> QCLASS cl) qf | Star p -> (* The fucking Kleene star *) let q2 = state () in let q1 = loop q2 p in (* q1 -{p}-> q2 *) let _ = (q1 --> QEPSILON) qf in let _ = (q2 --> QEPSILON) q1 in let _ = (q2 --> QEPSILON) q1 in q1 | Concat(p1,p2) -> let q12 = state () in let q1 = loop q12 p1 in (* q1 -{p1}-> q12 *) let q2 = loop qf p2 in (* q2 -{p2}-> qf *) let _ = (q12 --> QEPSILON) q2 in q1 | Union pl -> let qi = state () in List.iter begin fun p -> let q = loop qf p in (* q -{p2}-> qf *) let _ = (qi --> QEPSILON) q in (* qi -{}---> q *) () end pl; qi in let qf = state () in let qi = loop qf p in let m = !count in (* Compute epsilon closure *) let graph = Array.make m IS.empty in List.iter begin fun (q,q') -> graph.(q) <- IS.add q' graph.(q) end !epsilons; let closure = Array.make m IS.empty in let rec transitive past = function | [] -> past | q :: future -> let past' = IS.add q past in let future' = IS.fold begin fun q' future' -> (* q -{}--> q' *) if IS.mem q' past' then future' else q' :: future' end graph.(q) future in transitive past' future' in for i = 0 to m - 1 do closure.(i) <- transitive IS.empty [i] (* O(n^2), I know *) done; (* Finally, build the table *) let table = Array.make m [] in List.iter begin fun (q,t,q') -> table.(q) <- (t, closure.(q')) :: table.(q) end !transitions; (graph, closure, { mc_qi = closure.(qi); mc_table = table; mc_qf = qf; mc_power_table = Hashtbl.create 37 }) ;; let build x = let (_,_, machine) = build' x in machine;; (* ***) (*** run *) let run ?(trace=false) machine u = let m = String.length u in let apply qs c = try let t = Hashtbl.find machine.mc_power_table c in ISM.find qs t with | Not_found -> let qs' = IS.fold begin fun q qs' -> List.fold_left begin fun qs' (cl,qs'') -> if match_character_class cl c then IS.union qs' qs'' else qs' end qs' machine.mc_table.(q) end qs IS.empty in let t = try Hashtbl.find machine.mc_power_table c with | Not_found -> ISM.empty in Hashtbl.replace machine.mc_power_table c (ISM.add qs qs' t); qs' in let rec loop qs i = if IS.is_empty qs then false else begin if i = m then IS.mem machine.mc_qf qs else begin let c = u.[i] in if trace then begin Printf.printf "%d %C {" i c; IS.iter (fun q -> Printf.printf " %d" q) qs; Printf.printf " }\n%!" end; let qs' = apply qs c in loop qs' (i + 1) end end in loop machine.mc_qi 0 ;; (* ***) end ;; (* ***) (*** Brute *) module Brute = struct exception Succeed;; exception Fail;; exception Too_hard;; (*** match_pattern *) let match_pattern counter p u = let m = String.length u in (** [loop i n p] returns [true] iff the word [u.(i .. i + n - 1)] is in the ** language generated by the pattern [p]. ** We must have 0 <= i and i + n <= m *) let rec loop (i,n,p) = assert (0 <= i && 0 <= n && i + n <= m); incr counter; if !counter >= brute_limit then raise Too_hard; match p with | Word v -> String.length v = n && begin let rec check j = j = n or (v.[j] = u.[i + j] && check (j + 1)) in check 0 end | Epsilon -> n = 0 | Star(Class True) -> true | Star(Class cl) -> let rec check k = if k = n then true else (match_character_class cl u.[i + k]) && check (k + 1) in check 0 | Star _ -> raise Too_hard | Class cl -> n = 1 && match_character_class cl u.[i] | Concat(p1,p2) -> let rec scan j = j <= n && ((loop (i,j,p1) && loop (i+j, n - j,p2)) || scan (j + 1)) in scan 0 | Union pl -> List.exists (fun p' -> loop (i,n,p')) pl in loop (0,m,p) ;; (* ***) end ;; (* ***) (*** fast_pattern_contents, fast_pattern, globber *) type fast_pattern_contents = | Brute of int ref * pattern | Machine of NFA.machine ;; type fast_pattern = fast_pattern_contents ref;; type globber = fast_pattern atom Bool.boolean;; (* ***) (*** fast_pattern_of_pattern *) let fast_pattern_of_pattern p = ref (Brute(ref 0, p));; (* ***) (*** add_dir *) let add_dir dir x = match dir with | None -> x | Some(dir) -> match x with | Constant(s) -> Constant(My_std.filename_concat dir s) | Pattern(p) -> Pattern(Concat(Word(My_std.filename_concat dir ""), p)) ;; (* ***) (*** add_ast_dir *) let add_ast_dir dir x = match dir with | None -> x | Some dir -> let slash = Class(Atom('/','/')) in let any = Class True in let q = Union[Epsilon; Concat(slash, Star any)] in (* ( /** )? *) And[Atom(Pattern(ref (Brute(ref 0, Concat(Word dir, q))))); x] ;; (* ***) (*** parse *) let parse ?dir u = let l = Lexing.from_string u in let tok = ref None in let f = fun () -> match !tok with | None -> token l | Some x -> tok := None; x in let g t = match !tok with | None -> tok := Some t | Some t' -> raise (Parse_error(sf "Trying to unput token %s while %s is active" (string_of_token t) (string_of_token t'))) in let read x = let y = f () in if x = y then () else raise (Parse_error(sf "Unexpected token, expecting %s, got %s" (string_of_token x) (string_of_token y))) in let rec atomizer continuation = match f () with | NOT -> atomizer (fun x -> continuation (Not x)) | ATOM x -> begin let a = match add_dir dir x with | Constant u -> Constant u | Pattern p -> Pattern(fast_pattern_of_pattern p) in continuation (Atom a) end | TRUE -> continuation True | FALSE -> continuation False | LPAR -> let y = parse_s () in read RPAR; continuation y | t -> raise (Parse_error(sf "Unexpected token %s in atomizer" (string_of_token t))) and parse_s1 x = match f () with | OR -> let y = parse_s () in Or[x; y] | AND -> parse_t x | t -> g t; x and parse_t1 x y = match f () with | OR -> let z = parse_s () in Or[And[x;y]; z] | AND -> parse_t (And[x;y]) | t -> g t; And[x;y] and parse_s () = atomizer parse_s1 and parse_t x = atomizer (parse_t1 x) in let x = parse_s () in read EOF; add_ast_dir dir x ;; (* ***) (*** eval *) let eval g u = Bool.eval begin function | Constant v -> u = v | Pattern kind -> match !kind with | Brute(count, p) -> begin let do_nfa () = let m = NFA.build p in kind := Machine m; NFA.run m u in if !count >= brute_limit then do_nfa () else try Brute.match_pattern count p u with | Brute.Too_hard -> do_nfa () end | Machine m -> NFA.run m u end g (* ***) (*** Debug *) (*let (Atom(Pattern x)) = parse "<{a,b}>";; #install_printer IS.print;; #install_printer ISM.print;; let (graph, closure, machine) = build' x;;*) (* ***) mingw-ocaml/ocaml/ocamlbuild/ocamlbuild_executor.mli0000644000175000017500000000443312124403240022330 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Ocamlbuild_executor *) (** UNIX-specific module for running tasks in parallel and properly multiplexing their outputs. *) type error = | Subcommand_failed | Subcommand_got_signal | Io_error | Exceptionl_condition (** [execute ~ticker ~period ~display ~exit commands] will execute the commands in [commands] in parallel, correctly multiplexing their outputs. A command is a function that given a unit [()] returns the shell command string to execute, commands are functions in order to do some job just before executing the command. These functions will be called once. If specified, it will call [ticker] at least every [period] seconds. If specified, it will call [display f] when it wishes to print something; [display] should then call [f] with then channel on which [f] should print. Note that if the shell command to execute is the empty string [""], it's considered as a no-op. Note that [f] must be idempotent as it may well be called twice, once for the log file, once for the actual output. If one of the commands fails, it will exit with an appropriate error code, calling [cleanup] before. All exits are done trough the call to the given [exit] function, if not supplied Pervasives.exit is used. *) val execute : ?max_jobs:int -> ?ticker:(unit -> unit) -> ?period:float -> ?display:((out_channel -> unit) -> unit) -> exit:(error -> unit) -> ((unit -> string) list list) -> (bool list * exn) option mingw-ocaml/ocaml/ocamlbuild/digest_cache.ml0000644000175000017500000000267212124403240020533 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Pathname.Operators let digests = Hashtbl.create 103 let get = Hashtbl.find digests let put = Hashtbl.replace digests let _digests = lazy (!Options.build_dir / (Pathname.mk "_digests")) let finalize () = with_output_file !*_digests begin fun oc -> Hashtbl.iter begin fun name digest -> Printf.fprintf oc "%S: %S\n" name digest end digests end let init () = Shell.chdir !Options.build_dir; if Pathname.exists !*_digests then with_input_file !*_digests begin fun ic -> try while true do let l = input_line ic in Scanf.sscanf l "%S: %S" put done with End_of_file -> () end; My_unix.at_exit_once finalize mingw-ocaml/ocaml/ocamlbuild/flags.mli0000644000175000017500000000217012124403240017367 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) val of_tags : Tags.t -> Command.spec val of_tag_list : Tags.elt list -> Command.spec val flag : Tags.elt list -> Command.spec -> unit val pflag : Tags.elt list -> string -> (string -> Command.spec) -> unit val add : 'a -> 'a list -> 'a list val remove : 'a -> 'a list -> 'a list (** For system use only *) val get_flags : unit -> (Tags.t * Command.spec) list mingw-ocaml/ocaml/ocamlbuild/man/0000755000175000017500000000000012124403240016343 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/man/ocamlbuild.10000644000175000017500000001226712124403240020550 0ustar tootstoots.\"***********************************************************************) .\"* ocamlbuild *) .\"* *) .\"* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) .\"* *) .\"* Copyright 2007 Institut National de Recherche en Informatique et *) .\"* en Automatique. All rights reserved. This file is distributed *) .\"* under the terms of the Q Public License version 1.0. *) .\"* *) .\"***********************************************************************) .\" .TH OCAMLBUILD 1 .SH NAME ocamlbuild \- The OCaml project compilation tool .SH SYNOPSIS .B ocamlbuild [ .B \-Is \ dir1,... ] [ .BI \-libs \ lib1,... ] [ .BI \-lflags \ flag1,... ] [ .BI \-pp \ flags ] [ .BI \-tags \ tag1,... ] [ .B \-j \ parallel-jobs ] .I target.native [ .B \-\- arg1 arg2 ... ] .I (same options) .SH DESCRIPTION .BR ocamlbuild (1) orchestrates the compilation process of your OCaml project. It is similar in function to .BR make (1) except that it is tailor-made to automatically compile most OCaml projects with very little user input. .BR ocamlbuild should be invoked in the root of a clean project tree (e.g., with no leftover compilation files). Given one or more targets to compile, it scans the required subdirectories to gather information about the various files present, running tools such as .BR ocamldep (1) to extract dependency information, and gathering optional files that fine-tune its behaviour. Target names are very significant. .SH TARGET NAMES .BR ocamlbuild uses a set of target naming conventions to select the kind of objects to produce. Target names are of the form .BR base.extension where .BR base is usually the name of the underlying OCaml module and .BR extension denotes the kind of object to produce from that file -- a byte code executable, a native executable, documentation... Of course extensions such as .BR .cmo, .BR .cma, .BR .cmi... map to their usual counterparts. Here is a list of the most important .BR ocamlbuild \&-specific extensions: .TP 2i .B .native Native code executable .TP 2i .B .byte Byte code executable .TP 2i .B .inferred.mli Interface inferred with .BR ocamlc -i .TP 2i .B .docdir/index.html HTML documentation generated with .BR ocamldoc .PP .SH OPTIONS The following command-line options are recognized by .BR ocamlbuild (1). .TP \fB\-version\fR Display the version .TP \fB\-quiet\fR Make as quiet as possible .TP \fB\-verbose\fR Set the verbose level .TP \fB\-documentation\fR Show rules and flags .TP \fB\-log\fR Set log file .TP \fB\-no\-log\fR No log file .TP \fB\-clean\fR Remove build directory and other files, then exit .TP \fB\-I\fR Add to include directories .TP \fB\-Is\fR (same as above, but accepts a comma\-separated list) .TP \fB\-X\fR Directory to ignore .TP \fB\-Xs\fR (idem) .TP \fB\-lib\fR Link to this ocaml library .TP \fB\-libs\fR (idem) .TP \fB\-lflag\fR Add to ocamlc link flags .TP \fB\-lflags\fR (idem) .TP \fB\-cflag\fR Add to ocamlc compile flags .TP \fB\-cflags\fR (idem) .TP \fB\-yaccflag\fR Add to ocamlyacc flags .TP \fB\-yaccflags\fR (idem) .TP \fB\-lexflag\fR Add to ocamllex flags .TP \fB\-lexflags\fR (idem) .TP \fB\-ppflag\fR Add to ocaml preprocessing flags .TP \fB\-pp\fR (idem) .TP \fB\-tag\fR Add to default tags .TP \fB\-tags\fR (idem) .TP \fB\-ignore\fR Don't try to build these modules .TP \fB\-no\-links\fR Don't make links of produced final targets .TP \fB\-no\-skip\fR Don't skip modules that are requested by ocamldep but cannot be built .TP \fB\-no\-hygiene\fR Don't apply sanity\-check rules .TP \fB\-no\-plugin\fR Don't build myocamlbuild.ml .TP \fB\-no\-stdlib\fR Don't ignore stdlib modules .TP \fB\-just\-plugin\fR Just build myocamlbuild.ml .TP \fB\-byte\-plugin\fR Don't use a native plugin but bytecode .TP \fB\-no-sanitize\fR Do not enforce sanity\-check rules .TP \fB\-nothing\-should\-be\-rebuilt\fR Fail if something needs to be rebuilt .TP \fB\-classic\-display\fR Display executed commands the old\-fashioned way .TP \fB\-j\fR Allow N jobs at once (0 for unlimited) .TP \fB\-build\-dir\fR Set build directory .TP \fB\-install\-dir\fR Set the install directory .TP \fB\-where\fR Display the install directory .TP \fB\-ocamlc\fR Set the OCaml bytecode compiler .TP \fB\-ocamlopt\fR Set the OCaml native compiler .TP \fB\-ocamldep\fR Set the OCaml dependency tool .TP \fB\-ocamlyacc\fR Set the ocamlyacc tool .TP \fB\-ocamllex\fR Set the ocamllex tool .TP \fB\-ocamlrun\fR Set the ocamlrun tool .TP \fB\-\-\fR Stop argument processing, remaining arguments are given to the user program .TP \fB\-help\fR Display the list of options .TP \fB\-\-help\fR Display the list of options .PP .SH SEE ALSO The .BR ocamlbuild manual, .BR ocaml (1), .BR make (1). .br .I The OCaml user's manual, chapter "Batch compilation". mingw-ocaml/ocaml/ocamlbuild/manual/0000755000175000017500000000000012124403240017045 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/manual/.gitignore0000644000175000017500000000000012124403240021023 0ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/display.mli0000644000175000017500000000251712124403240017745 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Display *) type display type tagline_description = (string * char) list val create : ?channel:out_channel -> ?mode:[ `Classic | `Sophisticated ] -> ?columns:int -> ?description:tagline_description -> ?log_file:string -> ?log_level:int -> unit -> display val finish : ?how:[`Success|`Error|`Quiet] -> display -> unit val event : display -> ?pretend:bool -> string -> string -> Tags.t -> unit val display : display -> (out_channel -> unit) -> unit val update : display -> unit val dprintf : ?log_level:int -> display -> ('a, Format.formatter, unit) format -> 'a mingw-ocaml/ocaml/ocamlbuild/my_std.ml0000644000175000017500000002557212124403240017434 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open Format exception Exit_OK exception Exit_usage of string exception Exit_system_error of string exception Exit_with_code of int exception Exit_silently_with_code of int module Outcome = struct type ('a,'b) t = | Good of 'a | Bad of 'b let ignore_good = function | Good _ -> () | Bad e -> raise e let good = function | Good x -> x | Bad exn -> raise exn let wrap f x = try Good (f x) with e -> Bad e end let opt_print elt ppf = function | Some x -> fprintf ppf "@[<2>Some@ %a@]" elt x | None -> pp_print_string ppf "None" open Format let ksbprintf g fmt = let buff = Buffer.create 42 in let f = formatter_of_buffer buff in kfprintf (fun f -> (pp_print_flush f (); g (Buffer.contents buff))) f fmt let sbprintf fmt = ksbprintf (fun x -> x) fmt (** Some extensions of the standard library *) module Set = struct module type OrderedTypePrintable = sig include Set.OrderedType val print : formatter -> t -> unit end module type S = sig include Set.S val find : (elt -> bool) -> t -> elt val map : (elt -> elt) -> t -> t val of_list : elt list -> t val print : formatter -> t -> unit end module Make (M : OrderedTypePrintable) : S with type elt = M.t = struct include Set.Make(M) exception Found of elt let find p set = try iter begin fun elt -> if p elt then raise (Found elt) end set; raise Not_found with Found elt -> elt let map f set = fold (fun x -> add (f x)) set empty let of_list l = List.fold_right add l empty let print f s = let () = fprintf f "@[@[{.@ " in let _ = fold begin fun elt first -> if not first then fprintf f ",@ "; M.print f elt; false end s true in fprintf f "@]@ .}@]" end end module List = struct include List let print pp_elt f ls = fprintf f "@[<2>[@ "; let _ = fold_left begin fun first elt -> if not first then fprintf f ";@ "; pp_elt f elt; false end true ls in fprintf f "@ ]@]" let filter_opt f xs = List.fold_right begin fun x acc -> match f x with | Some x -> x :: acc | None -> acc end xs [] let rec rev_append_uniq acc = function | [] -> acc | x :: xs -> if mem x acc then rev_append_uniq acc xs else rev_append_uniq (x :: acc) xs let union a b = rev (rev_append_uniq (rev_append_uniq [] a) b) let ordered_unique (type el) (lst : el list) = let module Set = Set.Make(struct type t = el let compare = Pervasives.compare let print _ _ = () end) in let _, lst = List.fold_left (fun (set,acc) el -> if Set.mem el set then set, acc else Set.add el set, el :: acc) (Set.empty,[]) lst in List.rev lst end module String = struct include String let print f s = fprintf f "%S" s let chomp s = let is_nl_char = function '\n' | '\r' -> true | _ -> false in let rec cut n = if n = 0 then 0 else if is_nl_char s.[n-1] then cut (n-1) else n in let ls = length s in let n = cut ls in if n = ls then s else sub s 0 n let before s pos = sub s 0 pos let after s pos = sub s pos (length s - pos) let first_chars s n = sub s 0 n let last_chars s n = sub s (length s - n) n let rec eq_sub_strings s1 p1 s2 p2 len = if len > 0 then s1.[p1] = s2.[p2] && eq_sub_strings s1 (p1+1) s2 (p2+1) (len-1) else true let rec contains_string s1 p1 s2 = let ls1 = length s1 in let ls2 = length s2 in try let pos = index_from s1 p1 s2.[0] in if ls1 - pos < ls2 then None else if eq_sub_strings s1 pos s2 0 ls2 then Some pos else contains_string s1 (pos + 1) s2 with Not_found -> None let subst patt repl s = let lpatt = length patt in let lrepl = length repl in let rec loop s from = match contains_string s from patt with | Some pos -> loop (before s pos ^ repl ^ after s (pos + lpatt)) (pos + lrepl) | None -> s in loop s 0 let tr patt subst text = let len = length text in let text = copy text in let rec loop pos = if pos < len then begin (if text.[pos] = patt then text.[pos] <- subst); loop (pos + 1) end in loop 0; text (*** is_prefix : is u a prefix of v ? *) let is_prefix u v = let m = String.length u and n = String.length v in m <= n && let rec loop i = i = m or u.[i] = v.[i] && loop (i + 1) in loop 0 (* ***) (*** is_suffix : is v a suffix of u ? *) let is_suffix u v = let m = String.length u and n = String.length v in n <= m && let rec loop i = i = n or u.[m - 1 - i] = v.[n - 1 - i] && loop (i + 1) in loop 0 (* ***) let rev s = let sl = String.length s in let s' = String.create sl in for i = 0 to sl - 1 do s'.[i] <- s.[sl - i - 1] done; s';; let implode l = match l with | [] -> "" | cs -> let r = create (List.length cs) in let pos = ref 0 in List.iter begin fun c -> unsafe_set r !pos c; incr pos end cs; r let explode s = let sl = String.length s in let rec go pos = if pos >= sl then [] else unsafe_get s pos :: go (pos + 1) in go 0 end module StringSet = Set.Make(String) let sys_readdir, reset_readdir_cache, reset_readdir_cache_for = let cache = Hashtbl.create 103 in let sys_readdir dir = try Hashtbl.find cache dir with Not_found -> let res = Outcome.wrap Sys.readdir dir in (Hashtbl.add cache dir res; res) and reset_readdir_cache () = Hashtbl.clear cache and reset_readdir_cache_for dir = Hashtbl.remove cache dir in (sys_readdir, reset_readdir_cache, reset_readdir_cache_for) let sys_file_exists x = let dirname = Filename.dirname x in let basename = Filename.basename x in match sys_readdir dirname with | Outcome.Bad _ -> false | Outcome.Good a -> if basename = Filename.current_dir_name then true else try Array.iter (fun x -> if x = basename then raise Exit) a; false with Exit -> true let sys_command = match Sys.os_type with | "Win32" -> fun cmd -> if cmd = "" then 0 else let cmd = "bash -c "^Filename.quote cmd in Sys.command cmd | _ -> fun cmd -> if cmd = "" then 0 else Sys.command cmd (* FIXME warning fix and use Filename.concat *) let filename_concat x y = if x = Filename.current_dir_name || x = "" then y else if Sys.os_type = "Win32" && (x.[String.length x - 1] = '\\') || x.[String.length x - 1] = '/' then if y = "" then x else x ^ y else x ^ "/" ^ y (* let reslash = match Sys.os_type with | "Win32" -> tr '\\' '/' | _ -> (fun x -> x) *) open Format let invalid_arg' fmt = ksbprintf invalid_arg fmt let the = function Some x -> x | None -> invalid_arg "the: expect Some not None" let getenv ?default var = try Sys.getenv var with Not_found -> match default with | Some x -> x | None -> failwith (sprintf "This command must have %S in his environment" var);; let with_input_file ?(bin=false) x f = let ic = (if bin then open_in_bin else open_in) x in try let res = f ic in close_in ic; res with e -> (close_in ic; raise e) let with_output_file ?(bin=false) x f = reset_readdir_cache_for (Filename.dirname x); let oc = (if bin then open_out_bin else open_out) x in try let res = f oc in close_out oc; res with e -> (close_out oc; raise e) let read_file x = with_input_file ~bin:true x begin fun ic -> let len = in_channel_length ic in let buf = String.create len in let () = really_input ic buf 0 len in buf end let copy_chan ic oc = let m = in_channel_length ic in let m = (m lsr 12) lsl 12 in let m = max 16384 (min Sys.max_string_length m) in let buf = String.create m in let rec loop () = let len = input ic buf 0 m in if len > 0 then begin output oc buf 0 len; loop () end in loop () let copy_file src dest = reset_readdir_cache_for (Filename.dirname dest); with_input_file ~bin:true src begin fun ic -> with_output_file ~bin:true dest begin fun oc -> copy_chan ic oc end end let ( !* ) = Lazy.force let ( @:= ) ref list = ref := !ref @ list let ( & ) f x = f x let ( |> ) x f = f x let print_string_list = List.print String.print module Digest = struct include Digest (* USEFUL FOR DIGEST DEBUGING let digest_log_hash = Hashtbl.create 103;; let digest_log = "digest.log";; let digest_log_oc = open_out_gen [Open_append;Open_wronly;Open_text;Open_creat] 0o666 digest_log;; let my_to_hex x = to_hex x ^ ";";; if sys_file_exists digest_log then with_input_file digest_log begin fun ic -> try while true do let l = input_line ic in Scanf.sscanf l "%S: %S" (Hashtbl.replace digest_log_hash) done with End_of_file -> () end;; let string s = let res = my_to_hex (string s) in if try let x = Hashtbl.find digest_log_hash res in s <> x with Not_found -> true then begin Hashtbl.replace digest_log_hash res s; Printf.fprintf digest_log_oc "%S: %S\n%!" res s end; res let file f = my_to_hex (file f) let to_hex x = x *) let digest_cache = Hashtbl.create 103 let reset_digest_cache () = Hashtbl.clear digest_cache let reset_digest_cache_for file = Hashtbl.remove digest_cache file let file f = try Hashtbl.find digest_cache f with Not_found -> let res = file f in (Hashtbl.add digest_cache f res; res) end let reset_filesys_cache () = Digest.reset_digest_cache (); reset_readdir_cache () let reset_filesys_cache_for_file file = Digest.reset_digest_cache_for file; reset_readdir_cache_for (Filename.dirname file) let sys_remove x = reset_filesys_cache_for_file x; Sys.remove x let with_temp_file pre suf fct = let tmp = Filename.temp_file pre suf in (* Sys.remove is used instead of sys_remove since we know that the tempfile is not that important *) try let res = fct tmp in Sys.remove tmp; res with e -> (Sys.remove tmp; raise e) let memo f = let cache = Hashtbl.create 103 in fun x -> try Hashtbl.find cache x with Not_found -> let res = f x in (Hashtbl.add cache x res; res) mingw-ocaml/ocaml/ocamlbuild/Makefile0000644000175000017500000001045112124403240017231 0ustar tootstoots######################################################################### # # # OCaml # # # # Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt # # # # Copyright 2007 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # $Id$ .PHONY: all byte native profile debug ppcache doc ifndef INSTALL_PREFIX INSTALL_PREFIX := $(PWD)/_install endif ifndef INSTALL_LIB INSTALL_LIB := $(INSTALL_PREFIX)/lib/ocamlbuild endif ifndef INSTALL_BIN INSTALL_BIN := $(INSTALL_PREFIX)/bin endif ifndef BUILDDIR BUILDDIR := "_build" endif ifndef OCAMLBUILDCMD OCAMLBUILDCMD := ./boot/ocamlbuild endif ifdef O OCAMLBUILD_OPTIONS := $(OCAMLBUILD_OPTIONS) $(O) endif ifeq ($(wildcard ./ocamlbuild_Myocamlbuil*_config.ml),./ocamlbuild_Myocamlbuild_config.ml) ifeq ($(wildcard ./boot/oc*build),./boot/ocamlbuild) OCAMLBUILD=INSTALL_LIB=$(INSTALL_LIB) INSTALL_BIN=$(INSTALL_BIN) $(OCAMLBUILDCMD) -build-dir $(BUILDDIR) -no-links $(OCAMLBUILD_OPTIONS) LIBS=ocamlbuildlib ocamlbuildlightlib PROGRAMS=ocamlbuild ocamlbuildlight BYTE=$(LIBS:=.cma) $(PROGRAMS:=.byte) NATIVE=$(LIBS:=.cmxa) $(PROGRAMS:=.native) all: $(OCAMLBUILD) $(BYTE) $(NATIVE) byte: $(OCAMLBUILD) $(BYTE) native: $(OCAMLBUILD) $(NATIVE) profile: $(OCAMLBUILD) $(LIBS:=.p.cmxa) $(PROGRAMS:=.p.native) debug: $(OCAMLBUILD) $(LIBS:=.d.cma) $(PROGRAMS:=.d.byte) ppcache: $(OCAMLBUILD) ppcache.byte ppcache.native doc: $(OCAMLBUILD) ocamlbuild.docdir/index.html ln -s -f $(BUILDDIR)/ocamlbuild.docdir doc else all byte native: ocamlbuild.byte.start mkdir -p boot cp ocamlbuild.byte.start boot/ocamlbuild $(MAKE) $(MFLAGS) $(MAKECMDGOALS) cp $(BUILDDIR)/ocamlbuild.native boot/ocamlbuild $(MAKE) $(MFLAGS) $(MAKECMDGOALS) OCAMLBUILD_OPTIONS="-nothing-should-be-rebuilt -verbose -1" endif else all byte native: @echo "Please copy the myocamlbuild_config.ml of the OCaml source distribution" @echo " as ocamlbuild_Myocamlbuild_config.ml" @echo @echo "$$ cp ../myocamlbuild_config.ml ocamlbuild_Myocamlbuild_config.ml" endif ocamlbuild.byte.start: ./start.sh promote: cp $(BUILDDIR)/ocamlbuild.native boot/ocamlbuild clean: rm -rf $(BUILDDIR) distclean: clean rm -rf _log _start ocamlbuild.byte.start boot/ocamlbuild install: all mkdir -p $(INSTALL_BIN) mkdir -p $(INSTALL_LIB) install $(BUILDDIR)/ocamlbuild.byte \ $(BUILDDIR)/ocamlbuild.native \ $(BUILDDIR)/ocamlbuildlight.byte \ $(BUILDDIR)/ocamlbuildlight.native \ $(INSTALL_BIN) install $(BUILDDIR)/ocamlbuild.native $(INSTALL_BIN)/ocamlbuild install $(BUILDDIR)/ocamlbuildlight.byte $(INSTALL_BIN)/ocamlbuildlight install -m 644 \ $(BUILDDIR)/ocamlbuildlib.cmxa \ $(BUILDDIR)/ocamlbuildlib.a \ $(BUILDDIR)/ocamlbuildlib.cma \ $(BUILDDIR)/ocamlbuildlightlib.cmxa \ $(BUILDDIR)/ocamlbuildlightlib.a \ $(BUILDDIR)/ocamlbuildlightlib.cma \ $(BUILDDIR)/ocamlbuild_unix_plugin.cmx \ $(BUILDDIR)/ocamlbuild_unix_plugin.o \ $(BUILDDIR)/ocamlbuild_unix_plugin.cmo \ $(BUILDDIR)/ocamlbuild_unix_plugin.cmi \ $(BUILDDIR)/ocamlbuild_executor.cmi \ $(BUILDDIR)/ocamlbuild_executor.cmo \ $(BUILDDIR)/ocamlbuild_executor.cmx \ $(BUILDDIR)/ocamlbuild_executor.o \ $(BUILDDIR)/ocamlbuild_pack.cmi \ $(BUILDDIR)/ocamlbuild_pack.cmo \ $(BUILDDIR)/ocamlbuild_pack.cmx \ $(BUILDDIR)/ocamlbuild_pack.o \ $(BUILDDIR)/ocamlbuild.cmi \ $(BUILDDIR)/ocamlbuild_plugin.cmi \ $(BUILDDIR)/ocamlbuild.cmx \ $(BUILDDIR)/ocamlbuild.o \ $(BUILDDIR)/ocamlbuild.cmo \ $(BUILDDIR)/ocamlbuildlight.cmx \ $(BUILDDIR)/ocamlbuildlight.o \ $(BUILDDIR)/ocamlbuildlight.cmo $(INSTALL_LIB) ranlib $(INSTALL_LIB)/ocamlbuildlib.a ranlib $(INSTALL_LIB)/ocamlbuildlightlib.a mingw-ocaml/ocaml/ocamlbuild/param_tags.mli0000644000175000017500000000347412124403240020421 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Romain Bardou *) val declare: string -> (string -> unit) -> unit (** Declare a parameterized tag. [declare "name" action]: [action "param"] will be executed (once) by [init] if a tag of the form [name(param)] is [acknowledge]d. A given tag may be declared several times with different actions. All actions will be executed, in the order they were declared. *) val acknowledge: string -> unit (** Acknowledge a tag. If the tag is of the form [X(Y)], and have been declared using [declare], then the actions given using [declare] will be executed with [Y] as parameter when [init] is executed. The action will only be called once per acknowledged parameter. *) val init: unit -> unit (** Initialize parameterized tags. Call this function once all tags have been [declare]d and [acknowledge]d. If you [declare] or [acknowledge] a tag after having called [init], this will have no effect. [init] should only be called once. *) val make: Tags.elt -> string -> Tags.elt (** Make a parameterized tag instance. Example: [make "package" "unix"]: return the tag ["package(unix)"] *) mingw-ocaml/ocaml/ocamlbuild/ocaml_dependencies.ml0000644000175000017500000001605312124403240021730 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Log open Tools open Ocaml_utils let mydprintf fmt = dprintf 10 fmt exception Circular_dependencies of string list * string module type INPUT = sig val fold_dependencies : (string -> string -> 'a -> 'a) -> 'a -> 'a val fold_libraries : (string -> string list -> 'a -> 'a) -> 'a -> 'a val fold_packages : (string -> string list -> 'a -> 'a) -> 'a -> 'a end module Make (I : INPUT) = struct open I module SMap = Map.Make(String) module Resources = Resource.Resources module Utils = struct let add = SMap.add let empty = SMap.empty let find_all_set x acc = try SMap.find x acc with Not_found -> Resources.empty let smap_add_set src dst acc = SMap.add src (Resources.add dst (find_all_set src acc)) acc let print_smap pp f smap = Format.fprintf f "@[{:@["; SMap.iter begin fun k v -> Format.fprintf f "@ @[<2>%S =>@ %a@];" k pp v end smap; Format.fprintf f "@]@,:}@]" let print_smap_list = print_smap pp_l let print_smap_set = print_smap Resources.print let print_lazy pp f l = pp f !*l let find_all_list x acc = try SMap.find x acc with Not_found -> [] let find_all_rec xs map = let visited = Hashtbl.create 32 in let rec self x acc = try Hashtbl.find visited x; acc with Not_found -> Hashtbl.replace visited x (); let acc = Resources.add x acc in try Resources.fold self (SMap.find x map) acc with Not_found -> acc in List.fold_right self xs Resources.empty let mkindex fold filter = fold begin fun name contents acc -> if filter name then List.fold_right begin fun elt acc -> add elt (name :: (find_all_list elt acc)) acc end contents acc else acc end empty end open Utils let caml_transitive_closure ?(caml_obj_ext="cmo") ?(caml_lib_ext="cma") ?(pack_mode=false) ?(used_libraries=[]) ?(hidden_packages=[]) fns = let valid_link_exts = if pack_mode then [caml_obj_ext; "cmi"] else [caml_obj_ext; caml_lib_ext] in mydprintf "caml_transitive_closure@ ~caml_obj_ext:%S@ ~pack_mode:%b@ ~used_libraries:%a@ %a" caml_obj_ext pack_mode pp_l used_libraries pp_l fns; let packages = fold_packages (fun name _ -> Resources.add name) Resources.empty in mydprintf "packages:@ %a" Resources.print packages; let caml_obj_ext_of_cmi x = if Filename.check_suffix x ".cmi" then Pathname.update_extensions caml_obj_ext x else x in let maybe_caml_obj_ext_of_cmi x = if pack_mode then if Filename.check_suffix x ".cmi" then let caml_obj = Pathname.update_extensions caml_obj_ext x in if Resource.exists_in_build_dir caml_obj then caml_obj else x else x else if Filename.check_suffix x ".cmi" then Pathname.update_extensions caml_obj_ext x else x in let not_linkable x = not (List.exists (Pathname.check_extension x) valid_link_exts) in let dependency_map = fold_dependencies begin fun x y acc -> let x = maybe_caml_obj_ext_of_cmi x and y = maybe_caml_obj_ext_of_cmi y in if x = y || not_linkable x || not_linkable y then acc else smap_add_set x y acc end SMap.empty in mydprintf "dependency_map:@ %a" print_smap_set dependency_map; let used_files = find_all_rec fns dependency_map in mydprintf "used_files:@ %a" Resources.print used_files; let open_packages = Resources.fold begin fun file acc -> if Resources.mem file packages && not (List.mem file hidden_packages) then file :: acc else acc end used_files [] in mydprintf "open_packages:@ %a" pp_l open_packages; let index_filter ext list x = Pathname.check_extension x ext && List.mem x list in let lib_index = lazy (mkindex fold_libraries (index_filter caml_lib_ext used_libraries)) in mydprintf "lib_index:@ %a" (print_lazy print_smap_list) lib_index; let package_index = lazy (mkindex fold_packages (index_filter caml_obj_ext open_packages)) in let rec resolve_packages x = match find_all_list x !*package_index with | [] -> x | [x] -> resolve_packages x | pkgs -> failwith (sbprintf "the file %S is included in more than one active open package (%a)" x pp_l pkgs) in let libs_of x = find_all_list x !*lib_index in let lib_of x = match libs_of x with | [] -> None | [lib] -> Some(lib) | libs -> failwith (sbprintf "the file %S is included in more than one active library (%a)" x pp_l libs) in let convert_dependency src dst acc = let src = resolve_packages src in let dst = resolve_packages dst in let add_if_diff x y = if x = y then acc else smap_add_set x y acc in match (lib_of src, lib_of dst) with | None, None -> add_if_diff src dst | Some(liba), Some(libb) -> add_if_diff liba libb | Some(lib), None -> add_if_diff lib dst | None, Some(lib) -> add_if_diff src lib in let dependencies = lazy begin SMap.fold begin fun k -> Resources.fold (convert_dependency k) end dependency_map empty end in mydprintf "dependencies:@ %a" (print_lazy print_smap_set) dependencies; let dependencies_of x = try SMap.find x !*dependencies with Not_found -> Resources.empty in let needed = ref [] in let seen = ref [] in let rec aux fn = if sys_file_exists fn && not (List.mem fn !needed) then begin if List.mem fn !seen then raise (Circular_dependencies (!seen, fn)); seen := fn :: !seen; Resources.iter begin fun f -> if sys_file_exists f then if Filename.check_suffix f ".cmi" then let f' = caml_obj_ext_of_cmi f in if f' <> fn then if sys_file_exists f' then aux f' else if pack_mode then aux f else () else () else aux f end (dependencies_of fn); needed := fn :: !needed end in List.iter aux fns; mydprintf "caml_transitive_closure:@ %a ->@ %a" pp_l fns pp_l !needed; List.rev !needed end mingw-ocaml/ocaml/ocamlbuild/hygiene.ml0000644000175000017500000001361712124403240017562 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Hygiene *) open My_std open Slurp exception Exit_hygiene_violations type rule = | Implies_not of pattern * pattern | Not of pattern and pattern = suffix and suffix = string type penalty = Warn | Fail type law = { law_name : string; law_rules : rule list; law_penalty : penalty } let list_collect f l = let rec loop result = function | [] -> List.rev result | x :: rest -> match f x with | None -> loop result rest | Some y -> loop (y :: result) rest in loop [] l let list_none_for_all f l = let rec loop = function | [] -> None | x :: rest -> match f x with | None -> loop rest | y -> y in loop l let sf = Printf.sprintf module SS = Set.Make(String);; let check ?sanitize laws entry = let penalties = ref [] in let microbes = ref SS.empty in let () = match sanitize with | Some fn -> if sys_file_exists fn then sys_remove fn | None -> () in let remove path name = if sanitize <> None then microbes := SS.add (filename_concat path name) !microbes in let check_rule = fun entries -> function | Not suffix -> list_collect begin function | File(path, name, _, true) -> if Filename.check_suffix name suffix && not ( Pathname.link_to_dir (filename_concat path name) !Options.build_dir ) then begin remove path name; Some(sf "File %s in %s has suffix %s" name path suffix) end else None | File _ | Dir _| Error _ | Nothing -> None end entries | Implies_not(suffix1, suffix2) -> list_collect begin function | File(path, name, _, true) -> if Filename.check_suffix name suffix1 then begin let base = Filename.chop_suffix name suffix1 in let name' = base ^ suffix2 in if List.exists begin function | File(_, name'', _, true) -> name' = name'' | File _ | Dir _ | Error _ | Nothing -> false end entries then begin remove path name'; Some(sf "Files %s and %s should not be together in %s" name name' path) end else None end else None | File _ | Dir _ | Error _ | Nothing -> None end entries in let rec check_entry = function | Dir(_,_,_,true,entries) -> List.iter begin fun law -> match List.concat (List.map (check_rule !*entries) law.law_rules) with | [] -> () | explanations -> penalties := (law, explanations) :: !penalties end laws; List.iter check_entry !*entries | Dir _ | File _ | Error _ | Nothing -> () in check_entry entry; begin let microbes = !microbes in if not (SS.is_empty microbes) then begin match sanitize with | None -> Log.eprintf "sanitize: the following are files that should probably not be in your\n\ source tree:\n"; SS.iter begin fun fn -> Log.eprintf " %s" fn end microbes; Log.eprintf "Remove them manually, don't use the -no-sanitize option, use -no-hygiene, or\n\ define hygiene exceptions using the tags or plugin mechanism.\n"; raise Exit_hygiene_violations | Some fn -> let m = SS.cardinal microbes in Log.eprintf "@[SANITIZE:@ a@ total@ of@ %d@ file%s@ that@ should@ probably\ @ not@ be@ in@ your@ source@ tree@ has@ been@ found.\ @ A@ script@ shell@ file@ %S@ is@ being@ created.\ @ Check@ this@ script@ and@ run@ it@ to@ remove@ unwanted@ files\ @ or@ use@ other@ options@ (such@ as@ defining@ hygiene@ exceptions\ @ or@ using@ the@ -no-hygiene@ option).@]" m (if m = 1 then "" else "s") fn; let oc = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o777 fn in (* See PR #5338: under mingw, one produces a shell script, which must follow Unix eol convention; hence Open_binary. *) let fp = Printf.fprintf in fp oc "#!/bin/sh\n\ # File generated by ocamlbuild\n\ \n\ cd %s\n\ \n" (Shell.quote_filename_if_needed Pathname.pwd); SS.iter begin fun fn -> fp oc "rm -f %s\n" (Shell.quote_filename_if_needed fn) end microbes; (* Also clean itself *) fp oc "# Also clean the script itself\n"; fp oc "rm -f %s\n" (Shell.quote_filename_if_needed fn); close_out oc end; !penalties end ;; mingw-ocaml/ocaml/ocamlbuild/resource.ml0000644000175000017500000003031312124403240017751 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Format open Log open Pathname.Operators module Resources = Set.Make(Pathname) let print = Pathname.print let equal = (=) let compare = compare let in_source_dir p = if Pathname.is_implicit p then Pathname.pwd/p else invalid_arg (Printf.sprintf "in_source_dir: %S" p) let in_build_dir p = if Pathname.is_relative p then p else invalid_arg (Printf.sprintf "in_build_dir: %S" p) let clean_up_links entry = if not !Options.make_links then entry else Slurp.filter begin fun path name _ -> let pathname = in_source_dir (path/name) in if Pathname.link_to_dir pathname !Options.build_dir then let z = Pathname.readlink pathname in (* Here is one exception where one can use Sys.file_exists directly *) (if not (Sys.file_exists z) then Shell.rm pathname; false) else true end entry let clean_up_link_to_build () = Options.entry := Some(clean_up_links (the !Options.entry)) let source_dir_path_set_without_links_to_build = lazy begin clean_up_link_to_build (); Slurp.fold (fun path name _ -> StringSet.add (path/name)) (the !Options.entry) StringSet.empty end let clean_links () = if !*My_unix.is_degraded then () else ignore (clean_up_link_to_build ()) let exists_in_source_dir p = if !*My_unix.is_degraded then sys_file_exists (in_source_dir p) else StringSet.mem p !*source_dir_path_set_without_links_to_build let clean p = Shell.rm_f p module Cache = struct let clean () = Shell.chdir Pathname.pwd; Shell.rm_rf !Options.build_dir type knowledge = | Yes | No | Unknown type suspension = (Command.t * (unit -> unit)) type build_status = | Bbuilt | Bcannot_be_built | Bnot_built_yet | Bsuspension of suspension type cache_entry = { mutable built : build_status; mutable changed : knowledge; mutable dependencies : Resources.t } let empty () = { built = Bnot_built_yet; changed = Unknown; dependencies = Resources.empty } let print_knowledge f = function | Yes -> pp_print_string f "Yes" | No -> pp_print_string f "No" | Unknown -> pp_print_string f "Unknown" let print_build_status f = function | Bbuilt -> pp_print_string f "Bbuilt" | Bnot_built_yet -> pp_print_string f "Bnot_built_yet" | Bcannot_be_built -> pp_print_string f "Bcannot_be_built" | Bsuspension(cmd, _) -> fprintf f "@[<2>Bsuspension(%a,@ ( : unit -> unit))@]" Command.print cmd let print_cache_entry f e = fprintf f "@[<2>{ @[<2>built =@ %a@];@ @[<2>changed =@ %a@];@ @[<2>dependencies =@ %a@]@ }@]" print_build_status e.built print_knowledge e.changed Resources.print e.dependencies let cache = Hashtbl.create 103 let get r = try Hashtbl.find cache r with Not_found -> let cache_entry = empty () in Hashtbl.add cache r cache_entry; cache_entry let fold_cache f x = Hashtbl.fold f cache x let print_cache f () = fprintf f "@[@[{:"; fold_cache begin fun k v () -> fprintf f "@ @[<2>%a =>@ %a@];" print k print_cache_entry v end (); fprintf f "@]:}@]" let print_graph f () = fprintf f "@[@[{:"; fold_cache begin fun k v () -> if not (Resources.is_empty v.dependencies) then fprintf f "@ @[<2>%a =>@ %a@];" print k Resources.print v.dependencies end (); fprintf f "@]@ :}@]" let resource_changed r = dprintf 10 "resource_changed:@ %a" print r; (get r).changed <- Yes let external_is_up_to_date absolute_path = let key = "Resource: " ^ absolute_path in let digest = Digest.file absolute_path in let is_up_to_date = try let digest' = Digest_cache.get key in digest = digest' with Not_found -> false in is_up_to_date || (Digest_cache.put key digest; false) let source_is_up_to_date r_in_source_dir r_in_build_dir = let key = "Resource: " ^ r_in_source_dir in let digest = Digest.file r_in_source_dir in let r_is_up_to_date = Pathname.exists r_in_build_dir && try let digest' = Digest_cache.get key in digest = digest' with Not_found -> false in r_is_up_to_date || (Digest_cache.put key digest; false) let prod_is_up_to_date p = let x = in_build_dir p in not (exists_in_source_dir p) || Pathname.exists x && Pathname.same_contents x (in_source_dir p) let rec resource_has_changed r = let cache_entry = get r in match cache_entry.changed with | Yes -> true | No -> false | Unknown -> let res = match cache_entry.built with | Bbuilt -> false | Bsuspension _ -> assert false | Bcannot_be_built -> false | Bnot_built_yet -> not (prod_is_up_to_date r) in let () = cache_entry.changed <- if res then Yes else No in res let resource_state r = (get r).built let resource_built r = (get r).built <- Bbuilt let resource_failed r = (get r).built <- Bcannot_be_built let import_in_build_dir r = let cache_entry = get r in let r_in_build_dir = in_build_dir r in let r_in_source_dir = in_source_dir r in if source_is_up_to_date r_in_source_dir r_in_build_dir then begin dprintf 5 "%a exists and up to date" print r; end else begin dprintf 5 "%a exists in source dir -> import it" print r; Shell.mkdir_p (Pathname.dirname r); Pathname.copy r_in_source_dir r_in_build_dir; cache_entry.changed <- Yes; end; cache_entry.built <- Bbuilt let suspend_resource r cmd kont prods = let cache_entry = get r in match cache_entry.built with | Bsuspension _ -> () | Bbuilt -> () | Bcannot_be_built -> assert false | Bnot_built_yet -> let kont = begin fun () -> kont (); List.iter begin fun prod -> (get prod).built <- Bbuilt end prods end in cache_entry.built <- Bsuspension(cmd, kont) let resume_suspension (cmd, kont) = Command.execute cmd; kont () let resume_resource r = let cache_entry = get r in match cache_entry.built with | Bsuspension(s) -> resume_suspension s | Bbuilt -> () | Bcannot_be_built -> () | Bnot_built_yet -> () let get_optional_resource_suspension r = match (get r).built with | Bsuspension cmd_kont -> Some cmd_kont | Bbuilt | Bcannot_be_built | Bnot_built_yet -> None let clear_resource_failed r = (get r).built <- Bnot_built_yet let dependencies r = (get r).dependencies let fold_dependencies f = fold_cache (fun k v -> Resources.fold (f k) v.dependencies) let add_dependency r s = let cache_entry = get r in cache_entry.dependencies <- Resources.add s cache_entry.dependencies let print_dependencies = print_graph end let digest p = let f = Pathname.to_string (in_build_dir p) in let buf = Buffer.create 1024 in Buffer.add_string buf f; (if sys_file_exists f then Buffer.add_string buf (Digest.file f)); Digest.string (Buffer.contents buf) let exists_in_build_dir p = Pathname.exists (in_build_dir p) (* type env = string let split_percent s = try let pos = String.index s '%' in Some (String.before s pos, String.after s (pos + 1)) with Not_found -> None let extract prefix suffix s = let lprefix = String.length prefix in let lsuffix = String.length suffix in let ls = String.length s in if lprefix + lsuffix > ls then None else let s' = String.sub s lprefix (ls - lsuffix - lprefix) in if equal (prefix ^ s' ^ suffix) s then Some s' else None let matchit r1 r2 = match split_percent r1 with | Some (x, y) -> extract x y r2 | _ -> if equal r1 r2 then Some "" else None let rec subst percent r = match split_percent r with | Some (x, y) -> x ^ percent ^ y | _ -> r let print_env = pp_print_string *) (* Should normalize *) let import x = Pathname.normalize x module MetaPath : sig type t type env val mk : (bool * string) -> t val matchit : t -> string -> env option val subst : env -> t -> string val print_env : Format.formatter -> env -> unit end = struct open Glob_ast type atoms = A of string | V of string * Glob.globber type t = atoms list type env = (string * string) list exception No_solution let mk (pattern_allowed, s) = List.map begin function | `Var(var_name, globber) -> V(var_name, globber) | `Word s -> A s end (Lexers.path_scheme pattern_allowed (Lexing.from_string s)) let mk = memo mk let match_prefix s pos prefix = match String.contains_string s pos prefix with | Some(pos') -> if pos = pos' then pos' + String.length prefix else raise No_solution | None -> raise No_solution let matchit p s = let sl = String.length s in let rec loop xs pos acc delta = match xs with | [] -> if pos = sl then acc else raise No_solution | A prefix :: xs -> loop xs (match_prefix s pos prefix) acc 0 | V(var, patt) :: A s2 :: xs' -> begin match String.contains_string s (pos + delta) s2 with | Some(pos') -> let matched = String.sub s pos (pos' - pos) in if Glob.eval patt matched then try loop xs' (pos' + String.length s2) ((var, matched) :: acc) 0 with No_solution -> loop xs pos acc (pos' - pos + 1) else loop xs pos acc (pos' - pos + 1) | None -> raise No_solution end | [V(var, patt)] -> let matched = String.sub s pos (sl - pos) in if Glob.eval patt matched then (var, matched) :: acc else raise No_solution | V _ :: _ -> assert false in try Some (loop p 0 [] 0) with No_solution -> None let pp_opt pp_elt f = function | None -> pp_print_string f "None" | Some x -> Format.fprintf f "Some(%a)" pp_elt x let print_env f env = List.iter begin fun (k, v) -> if k = "" then Format.fprintf f "%%=%s " v else Format.fprintf f "%%(%s)=%s " k v end env (* let matchit p s = let res = matchit p s in Format.eprintf "matchit %S %S = %a@." p s (pp_opt print_env) res; res let _ = begin assert (matchit "%(path)lib%(libname).a" "libfoo.a" <> None); assert (matchit "%(path)lib%(libname).a" "path/libfoo.a" <> None); assert (matchit "libfoo.a" "libfoo.a" <> None); assert (matchit "lib%(libname).a" "libfoo.a" <> None); assert (matchit "%(path)libfoo.a" "path/libfoo.a" <> None); assert (matchit "foo%" "foobar" <> None); exit 42 end;; *) let subst env s = String.concat "" begin List.map begin fun x -> match x with | A atom -> atom | V(var, _) -> List.assoc var env end s end end type env = MetaPath.env type resource_pattern = (Pathname.t * MetaPath.t) let print_pattern f (x, _) = Pathname.print f x let import_pattern x = x, MetaPath.mk (true, x) let matchit (_, p) x = MetaPath.matchit p x let subst env s = MetaPath.subst env (MetaPath.mk (false, s)) let subst_any env s = MetaPath.subst env (MetaPath.mk (true, s)) let subst_pattern env (_, p) = MetaPath.subst env p let print_env = MetaPath.print_env mingw-ocaml/ocaml/ocamlbuild/ocamlbuild.odocl0000644000175000017500000000063512124403240020731 0ustar tootstootsLog My_unix My_std Std_signatures Signatures Shell Display Command Configuration Discard_printf Flags Hygiene Options Pathname Report Resource Rule Slurp Solver Tags Tools Fda Ocaml_specific Ocaml_arch Ocamlbuild_where Ocamlbuild_Myocamlbuild_config Lexers Glob Bool Glob_ast Glob_lexer Plugin Main Hooks Ocaml_utils Ocaml_tools Ocaml_compiler Ocaml_dependencies Exit_codes Digest_cache Ocamlbuild_plugin Findlib mingw-ocaml/ocaml/ocamlbuild/bool.ml0000644000175000017500000000256412124403240017064 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Bool *) type 'a boolean = And of 'a boolean list | Or of 'a boolean list | Not of 'a boolean | Atom of 'a | True | False;; let rec eval f = function | And l -> List.for_all (eval f) l | Or l -> List.exists (eval f) l | Not x -> not (eval f x) | Atom a -> f a | True -> true | False -> false ;; let rec iter f = function | (And l|Or l) -> List.iter (iter f) l | Not x -> iter f x | Atom a -> f a | True|False -> () ;; let rec map f = function | And l -> And(List.map (map f) l) | Or l -> Or(List.map (map f) l) | Not x -> Not(map f x) | Atom a -> Atom(f a) | (True|False) as b -> b ;; mingw-ocaml/ocaml/ocamlbuild/ocaml_tools.ml0000644000175000017500000001500512124403240020436 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Pathname.Operators open Tags.Operators open Tools open Command open Ocaml_utils let add_suffix s = List.map (fun x -> x -.- s) ;; let ocamldep_command' tags = let tags' = tags++"ocaml"++"ocamldep" in S [!Options.ocamldep; T tags'; ocaml_ppflags (tags++"pp:dep"); A "-modules"] let menhir_ocamldep_command' tags ~menhir_spec out = let menhir = if !Options.ocamlyacc = N then V"MENHIR" else !Options.ocamlyacc in Cmd(S[menhir; T tags; A"--raw-depend"; A"--ocamldep"; Quote (ocamldep_command' Tags.empty); menhir_spec ; Sh ">"; Px out]) let menhir_ocamldep_command arg out env _build = let arg = env arg and out = env out in let tags = tags_of_pathname arg++"ocaml"++"menhir_ocamldep" in menhir_ocamldep_command' tags ~menhir_spec:(P arg) out let import_mlypack build mlypack = let tags1 = tags_of_pathname mlypack in let files = string_list_of_file mlypack in let include_dirs = Pathname.include_dirs_of (Pathname.dirname mlypack) in let files_alternatives = List.map begin fun module_name -> expand_module include_dirs module_name ["mly"] end files in let files = List.map Outcome.good (build files_alternatives) in let tags2 = List.fold_right (fun file -> Tags.union (tags_of_pathname file)) files tags1 in (tags2, files) let menhir_modular_ocamldep_command mlypack out env build = let mlypack = env mlypack and out = env out in let (tags,files) = import_mlypack build mlypack in let tags = tags++"ocaml"++"menhir_ocamldep" in let menhir_base = Pathname.remove_extensions mlypack in let menhir_spec = S[A "--base" ; P menhir_base ; atomize_paths files] in menhir_ocamldep_command' tags ~menhir_spec out let menhir_modular menhir_base mlypack mlypack_depends env build = let menhir = if !Options.ocamlyacc = N then V"MENHIR" else !Options.ocamlyacc in let menhir_base = env menhir_base in let mlypack = env mlypack in let mlypack_depends = env mlypack_depends in let (tags,files) = import_mlypack build mlypack in let () = List.iter Outcome.ignore_good (build [[mlypack_depends]]) in Ocaml_compiler.prepare_compile build mlypack; let ocamlc_tags = tags++"ocaml"++"byte"++"compile" in let tags = tags++"ocaml"++"parser"++"menhir" in Cmd(S[menhir ; A "--ocamlc"; Quote(S[!Options.ocamlc; T ocamlc_tags; ocaml_include_flags mlypack]); T tags ; A "--infer" ; A "--base" ; Px menhir_base ; atomize_paths files]) let ocamldep_command arg out env _build = let arg = env arg and out = env out in let tags = tags_of_pathname arg in Cmd(S[ocamldep_command' tags; P arg; Sh ">"; Px out]) let ocamlyacc mly env _build = let mly = env mly in let ocamlyacc = if !Options.ocamlyacc = N then V"OCAMLYACC" else !Options.ocamlyacc in Cmd(S[ocamlyacc; T(tags_of_pathname mly++"ocaml"++"parser"++"ocamlyacc"); Px mly]) let ocamllex mll env _build = let mll = env mll in Cmd(S[!Options.ocamllex; T(tags_of_pathname mll++"ocaml"++"lexer"++"ocamllex"); Px mll]) let infer_interface ml mli env build = let ml = env ml and mli = env mli in let tags = tags_of_pathname ml++"ocaml" in Ocaml_compiler.prepare_compile build ml; Cmd(S[!Options.ocamlc; ocaml_ppflags tags; ocaml_include_flags ml; A"-i"; (if Tags.mem "thread" tags then A"-thread" else N); T(tags++"infer_interface"); P ml; Sh">"; Px mli]) let menhir mly env build = let mly = env mly in let menhir = if !Options.ocamlyacc = N then V"MENHIR" else !Options.ocamlyacc in Ocaml_compiler.prepare_compile build mly; Cmd(S[menhir; A"--ocamlc"; Quote(S[!Options.ocamlc; ocaml_include_flags mly]); T(tags_of_pathname mly++"ocaml"++"parser"++"menhir"); A"--infer"; Px mly]) let ocamldoc_c tags arg odoc = let tags = tags++"ocaml" in Cmd (S [!Options.ocamldoc; A"-dump"; Px odoc; T(tags++"doc"); ocaml_ppflags (tags++"pp:doc"); ocaml_include_flags arg; P arg]) let ocamldoc_l_dir tags deps _docout docdir = Seq[Cmd (S[A"rm"; A"-rf"; Px docdir]); Cmd (S[A"mkdir"; A"-p"; Px docdir]); Cmd (S [!Options.ocamldoc; S(List.map (fun a -> S[A"-load"; P a]) deps); T(tags++"doc"++"docdir"); A"-d"; Px docdir])] let ocamldoc_l_file tags deps docout _docdir = Seq[Cmd (S[A"rm"; A"-rf"; Px docout]); Cmd (S[A"mkdir"; A"-p"; Px (Pathname.dirname docout)]); Cmd (S [!Options.ocamldoc; S(List.map (fun a -> S[A"-load"; P a]) deps); T(tags++"doc"++"docfile"); A"-o"; Px docout])] let document_ocaml_interf mli odoc env build = let mli = env mli and odoc = env odoc in Ocaml_compiler.prepare_compile build mli; ocamldoc_c (tags_of_pathname mli++"interf") mli odoc let document_ocaml_implem ml odoc env build = let ml = env ml and odoc = env odoc in Ocaml_compiler.prepare_compile build ml; ocamldoc_c (tags_of_pathname ml++"implem") ml odoc let document_ocaml_project ?(ocamldoc=ocamldoc_l_file) odocl docout docdir env build = let odocl = env odocl and docout = env docout and docdir = env docdir in let contents = string_list_of_file odocl in let include_dirs = Pathname.include_dirs_of (Pathname.dirname odocl) in let to_build = List.map begin fun module_name -> expand_module include_dirs module_name ["odoc"] end contents in let module_paths = List.map Outcome.good (build to_build) in let tags = (Tags.union (tags_of_pathname docout) (tags_of_pathname docdir))++"ocaml" in ocamldoc tags module_paths docout docdir let camlp4 ?(default=A"camlp4o") tag i o env build = let ml = env i and pp_ml = env o in let tags = tags_of_pathname ml++"ocaml"++"pp"++tag in let _ = Rule.build_deps_of_tags build tags in let pp = Command.reduce (Flags.of_tags tags) in let pp = match pp with | N -> default | _ -> pp in Cmd(S[pp; P ml; A"-printer"; A"o"; A"-o"; Px pp_ml]) mingw-ocaml/ocaml/ocamlbuild/ocaml_compiler.ml0000644000175000017500000003476212124403240021123 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Format open Log open Pathname.Operators open Tools open Command open Rule open Tags.Operators open Ocaml_utils open Rule.Common_commands open Outcome let forpack_flags arg tags = if Tags.mem "pack" tags then Ocaml_arch.forpack_flags_of_pathname arg else N let ocamlc_c tags arg out = let tags = tags++"ocaml"++"byte" in Cmd (S [!Options.ocamlc; A"-c"; T(tags++"compile"); ocaml_ppflags tags; ocaml_include_flags arg; A"-o"; Px out; P arg]) let ocamlc_link flag tags deps out = Cmd (S [!Options.ocamlc; flag; T tags; atomize_paths deps; A"-o"; Px out]) let ocamlc_link_lib = ocamlc_link (A"-a") let ocamlc_link_prog = ocamlc_link N let ocamlmklib tags deps out = Cmd (S [!Options.ocamlmklib; T tags; atomize_paths deps; A"-o"; Px (Pathname.remove_extensions out)]) let ocamlmktop tags deps out = Cmd( S [!Options.ocamlmktop; T (tags++"mktop"); atomize_paths deps; A"-o"; Px out]) let byte_lib_linker tags = if Tags.mem "ocamlmklib" tags then ocamlmklib tags else ocamlc_link_lib tags let byte_lib_linker_tags tags = tags++"ocaml"++"link"++"byte"++"library" let ocamlc_p tags deps out = Cmd (S [!Options.ocamlc; A"-pack"; T tags; atomize_paths deps; A"-o"; Px out]) let ocamlopt_c tags arg out = let tags = tags++"ocaml"++"native" in Cmd (S [!Options.ocamlopt; A"-c"; Ocaml_arch.forpack_flags_of_pathname arg; T(tags++"compile"); ocaml_ppflags tags; ocaml_include_flags arg; A"-o"; Px out (* FIXME ocamlopt bug -o cannot be after the input file *); P arg]) let ocamlopt_link flag tags deps out = Cmd (S [!Options.ocamlopt; flag; forpack_flags out tags; T tags; atomize_paths deps; A"-o"; Px out]) let ocamlopt_link_lib = ocamlopt_link (A"-a") let ocamlopt_link_shared_lib = ocamlopt_link (A"-shared") let ocamlopt_link_prog = ocamlopt_link N let ocamlopt_p tags deps out = let dirnames = List.union [] (List.map Pathname.dirname deps) in let include_flags = List.fold_right ocaml_add_include_flag dirnames [] in let mli = Pathname.update_extensions "mli" out in let cmd = S [!Options.ocamlopt; A"-pack"; forpack_flags out tags; T tags; S include_flags; atomize_paths deps; A"-o"; Px out] in if (*FIXME true ||*) Pathname.exists mli then Cmd cmd else let rm = S[A"rm"; A"-f"; P mli] in Cmd(S[A"touch"; P mli; Sh" ; if "; cmd; Sh" ; then "; rm; Sh" ; else "; rm; Sh" ; exit 1; fi"]) let native_lib_linker tags = if Tags.mem "ocamlmklib" tags then ocamlmklib tags else ocamlopt_link_lib tags let native_shared_lib_linker tags = (* ocamlmklib seems to not support -shared, is this OK? if Tags.mem "ocamlmklib" tags then ocamlmklib tags else *) ocamlopt_link_shared_lib tags let native_lib_linker_tags tags = tags++"ocaml"++"link"++"native"++"library" let prepare_compile build ml = let dir = Pathname.dirname ml in let include_dirs = Pathname.include_dirs_of dir in let modules = path_dependencies_of ml in let results = build (List.map (fun (_, x) -> expand_module include_dirs x ["cmi"]) modules) in List.iter2 begin fun (mandatory, name) res -> match mandatory, res with | _, Good _ -> () | `mandatory, Bad exn -> if !Options.ignore_auto then dprintf 3 "Warning: Failed to build the module \ %s requested by ocamldep" name else raise exn | `just_try, Bad _ -> () end modules results let byte_compile_ocaml_interf mli cmi env build = let mli = env mli and cmi = env cmi in prepare_compile build mli; ocamlc_c (tags_of_pathname mli++"interf") mli cmi let byte_compile_ocaml_implem ?tag ml cmo env build = let ml = env ml and cmo = env cmo in prepare_compile build ml; ocamlc_c (Tags.union (tags_of_pathname ml) (tags_of_pathname cmo)++"implem"+++tag) ml cmo let cache_prepare_link = Hashtbl.create 107 let rec prepare_link tag cmx extensions build = let key = (tag, cmx, extensions) in let dir = Pathname.dirname cmx in let include_dirs = Pathname.include_dirs_of dir in let ml = Pathname.update_extensions "ml" cmx in let mli = Pathname.update_extensions "mli" cmx in let modules = List.union (if Pathname.exists (ml-.-"depends") then path_dependencies_of ml else []) (if Pathname.exists (mli-.-"depends") then path_dependencies_of mli else []) in if modules <> [] && not (Hashtbl.mem cache_prepare_link key) then let () = Hashtbl.add cache_prepare_link key true in let modules' = List.map (fun (_, x) -> expand_module include_dirs x extensions) modules in List.iter2 begin fun (mandatory, _) result -> match mandatory, result with | _, Good p -> prepare_link tag p extensions build | `mandatory, Bad exn -> if not !Options.ignore_auto then raise exn | `just_try, Bad _ -> () end modules (build modules') let native_compile_ocaml_implem ?tag ?(cmx_ext="cmx") ml env build = let ml = env ml in let cmi = Pathname.update_extensions "cmi" ml in let cmx = Pathname.update_extensions cmx_ext ml in prepare_link cmx cmi [cmx_ext; "cmi"] build; ocamlopt_c (Tags.union (tags_of_pathname ml) (tags_of_pathname cmx)++"implem"+++tag) ml cmx let libs_of_use_lib tags = Tags.fold begin fun tag acc -> try let libpath, extern = Hashtbl.find info_libraries tag in if extern then acc else libpath :: acc with Not_found -> acc end tags [] let prepare_libs cma_ext a_ext out build = let out_no_ext = Pathname.remove_extension out in let libs1 = List.union (libraries_of out_no_ext) (libs_of_use_lib (tags_of_pathname out)) in let () = dprintf 10 "prepare_libs: %S -> %a" out pp_l libs1 in let libs = List.map (fun x -> x-.-cma_ext) libs1 in let libs2 = List.map (fun lib -> [lib-.-a_ext]) libs1 in List.iter ignore_good (build libs2); libs let library_index = Hashtbl.create 32 let package_index = Hashtbl.create 32 let hidden_packages = ref [] let hide_package_contents package = hidden_packages := package :: !hidden_packages module Ocaml_dependencies_input = struct let fold_dependencies = Resource.Cache.fold_dependencies let fold_libraries f = Hashtbl.fold f library_index let fold_packages f = Hashtbl.fold f package_index end module Ocaml_dependencies = Ocaml_dependencies.Make(Ocaml_dependencies_input) let caml_transitive_closure = Ocaml_dependencies.caml_transitive_closure let link_one_gen linker tagger cmX out env _build = let cmX = env cmX and out = env out in let tags = tagger (tags_of_pathname out) in linker tags [cmX] out let link_gen cmX_ext cma_ext a_ext extensions linker tagger cmX out env build = let cmX = env cmX and out = env out in let tags = tagger (tags_of_pathname out) in let dyndeps = Rule.build_deps_of_tags build (tags++"link_with") in let cmi = Pathname.update_extensions "cmi" cmX in prepare_link cmX cmi extensions build; let libs = prepare_libs cma_ext a_ext out build in let hidden_packages = List.map (fun x -> x-.-cmX_ext) !hidden_packages in let deps = caml_transitive_closure ~caml_obj_ext:cmX_ext ~caml_lib_ext:cma_ext ~used_libraries:libs ~hidden_packages (cmX :: dyndeps) in let deps = (List.filter (fun l -> not (List.mem l deps)) libs) @ deps in (* Hack to avoid linking twice with the standard library. *) let stdlib = "stdlib/stdlib"-.-cma_ext in let is_not_stdlib x = x <> stdlib in let deps = List.filter is_not_stdlib deps in if deps = [] then failwith "Link list cannot be empty"; let () = dprintf 6 "link: %a -o %a" print_string_list deps Pathname.print out in linker (tags++"dont_link_with") deps out let byte_link_gen = link_gen "cmo" "cma" "cma" ["cmo"; "cmi"] let byte_link = byte_link_gen ocamlc_link_prog (fun tags -> tags++"ocaml"++"link"++"byte"++"program") let byte_library_link = byte_link_gen byte_lib_linker byte_lib_linker_tags let byte_debug_link_gen = link_gen "d.cmo" "d.cma" "d.cma" ["d.cmo"; "cmi"] let byte_debug_link = byte_debug_link_gen ocamlc_link_prog (fun tags -> tags++"ocaml"++"link"++"byte"++"debug"++"program") let byte_debug_library_link = byte_debug_link_gen byte_lib_linker (fun tags -> byte_lib_linker_tags tags++"debug") let native_link_gen linker = link_gen "cmx" "cmxa" !Options.ext_lib [!Options.ext_obj; "cmi"] linker let native_link x = native_link_gen ocamlopt_link_prog (fun tags -> tags++"ocaml"++"link"++"native"++"program") x let native_library_link x = native_link_gen native_lib_linker native_lib_linker_tags x let native_profile_link_gen linker = link_gen "p.cmx" "p.cmxa" ("p" -.- !Options.ext_lib) ["p" -.- !Options.ext_obj; "cmi"] linker let native_profile_link x = native_profile_link_gen ocamlopt_link_prog (fun tags -> tags++"ocaml"++"link"++"native"++"profile"++"program") x let native_profile_library_link x = native_profile_link_gen native_lib_linker (fun tags -> native_lib_linker_tags tags++"profile") x let link_units table extensions cmX_ext cma_ext a_ext linker tagger contents_list cmX env build = let cmX = env cmX in let tags = tagger (tags_of_pathname cmX) in let _ = Rule.build_deps_of_tags build tags in let dir = let dir1 = Pathname.remove_extensions cmX in if Resource.exists_in_source_dir dir1 then dir1 else Pathname.dirname cmX in let include_dirs = Pathname.include_dirs_of dir in let extension_keys = List.map fst extensions in let libs = prepare_libs cma_ext a_ext cmX build in let results = build begin List.map begin fun module_name -> expand_module include_dirs module_name extension_keys end contents_list end in let module_paths = List.map begin function | Good p -> let extension_values = List.assoc (Pathname.get_extensions p) extensions in List.iter begin fun ext -> List.iter ignore_good (build [[Pathname.update_extensions ext p]]) end extension_values; p | Bad exn -> raise exn end results in Hashtbl.replace table cmX module_paths; let hidden_packages = List.map (fun x -> x-.-cmX_ext) !hidden_packages in let deps = caml_transitive_closure ~caml_obj_ext:cmX_ext ~caml_lib_ext:cma_ext ~hidden_packages ~pack_mode:true module_paths in let full_contents = libs @ module_paths in let deps = List.filter (fun x -> List.mem x full_contents) deps in let deps = (List.filter (fun l -> not (List.mem l deps)) libs) @ deps in (* Hack to avoid linking twice with the standard library. *) let stdlib = "stdlib/stdlib"-.-cma_ext in let is_not_stdlib x = x <> stdlib in let deps = List.filter is_not_stdlib deps in linker tags deps cmX let link_modules = link_units library_index let pack_modules = link_units package_index let link_from_file link modules_file cmX env build = let modules_file = env modules_file in let contents_list = string_list_of_file modules_file in link contents_list cmX env build let byte_library_link_modules = link_modules [("cmo",[])] "cmo" "cma" "cma" byte_lib_linker byte_lib_linker_tags let byte_library_link_mllib = link_from_file byte_library_link_modules let byte_toplevel_link_modules = link_modules [("cmo",[])] "cmo" "cma" "cma" ocamlmktop (fun tags -> tags++"ocaml"++"link"++"byte"++"toplevel") let byte_toplevel_link_mltop = link_from_file byte_toplevel_link_modules let byte_debug_library_link_modules = link_modules [("d.cmo",[])] "d.cmo" "d.cma" "d.cma" byte_lib_linker (fun tags -> byte_lib_linker_tags tags++"debug") let byte_debug_library_link_mllib = link_from_file byte_debug_library_link_modules let byte_pack_modules = pack_modules [("cmo",["cmi"]); ("cmi",[])] "cmo" "cma" "cma" ocamlc_p (fun tags -> tags++"ocaml"++"pack"++"byte") let byte_pack_mlpack = link_from_file byte_pack_modules let byte_debug_pack_modules = pack_modules [("d.cmo",["cmi"]); ("cmi",[])] "d.cmo" "d.cma" "d.cma" ocamlc_p (fun tags -> tags++"ocaml"++"pack"++"byte"++"debug") let byte_debug_pack_mlpack = link_from_file byte_debug_pack_modules let native_pack_modules x = pack_modules [("cmx",["cmi"; !Options.ext_obj]); ("cmi",[])] "cmx" "cmxa" !Options.ext_lib ocamlopt_p (fun tags -> tags++"ocaml"++"pack"++"native") x let native_pack_mlpack = link_from_file native_pack_modules let native_profile_pack_modules x = pack_modules [("p.cmx",["cmi"; "p" -.- !Options.ext_obj]); ("cmi",[])] "p.cmx" "p.cmxa" ("p" -.- !Options.ext_lib) ocamlopt_p (fun tags -> tags++"ocaml"++"pack"++"native"++"profile") x let native_profile_pack_mlpack = link_from_file native_profile_pack_modules let native_library_link_modules x = link_modules [("cmx",[!Options.ext_obj])] "cmx" "cmxa" !Options.ext_lib native_lib_linker native_lib_linker_tags x let native_shared_library_link_modules x = link_modules [("cmx",[!Options.ext_obj])] "cmx" "cmxa" !Options.ext_lib native_shared_lib_linker (fun tags -> native_lib_linker_tags tags++"shared") x let native_library_link_mllib = link_from_file native_library_link_modules let native_shared_library_link_mldylib = link_from_file native_shared_library_link_modules let native_shared_library_tags tags basetags = List.fold_left (++) (basetags++"ocaml"++"link"++"native"++"shared"++"library") tags let native_shared_library_link ?(tags = []) x = link_one_gen native_shared_lib_linker (native_shared_library_tags tags) x let native_profile_library_link_modules x = link_modules [("p.cmx",["p" -.- !Options.ext_obj])] "p.cmx" "p.cmxa" ("p" -.- !Options.ext_lib) native_lib_linker (fun tags -> native_lib_linker_tags tags++"profile") x let native_profile_shared_library_link_modules x = link_modules [("p.cmx",["p" -.- !Options.ext_obj])] "p.cmx" "p.cmxa" ("p" -.- !Options.ext_lib) native_shared_lib_linker (fun tags -> native_lib_linker_tags tags++"shared"++"profile") x let native_profile_library_link_mllib = link_from_file native_profile_library_link_modules let native_profile_shared_library_link_mldylib = link_from_file native_profile_shared_library_link_modules mingw-ocaml/ocaml/ocamlbuild/ocamlbuild_where.ml0000644000175000017500000000167312124403240021436 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) let bindir = ref Ocamlbuild_Myocamlbuild_config.bindir;; let libdir = ref begin Filename.concat (try Sys.getenv "OCAMLLIB" with Not_found -> Ocamlbuild_Myocamlbuild_config.libdir) "ocamlbuild" end;; mingw-ocaml/ocaml/ocamlbuild/ppcache.mli0000644000175000017500000000144712124403240017704 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) (* nothing to export *) mingw-ocaml/ocaml/ocamlbuild/main.ml0000644000175000017500000002331012124403240017045 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) open My_std open Log open Pathname.Operators open Command open Tools open Ocaml_specific open Format ;; exception Exit_build_error of string exception Exit_silently let clean () = Log.finish (); Shell.rm_rf !Options.build_dir; if !Options.make_links then begin let entry = Slurp.map (fun _ _ _ -> true) (Slurp.slurp Filename.current_dir_name) in Slurp.force (Resource.clean_up_links entry) end; raise Exit_silently ;; let show_tags () = if List.length !Options.show_tags > 0 then Log.eprintf "Warning: the following tags do not include \ dynamically-generated tags, such as link, compile, pack, byte, native, c, \ pdf... (this list is by no means exhaustive).\n"; List.iter begin fun path -> Log.eprintf "@[<2>Tags for %S:@ {. %a .}@]" path Tags.print (tags_of_pathname path) end !Options.show_tags ;; let show_documentation () = let rules = Rule.get_rules () in let flags = Flags.get_flags () in let pp fmt = Log.raw_dprintf (-1) fmt in List.iter begin fun rule -> pp "%a@\n@\n" (Rule.pretty_print Resource.print_pattern) rule end rules; List.iter begin fun (tags, flag) -> let sflag = Command.string_of_command_spec flag in pp "@[<2>flag@ {. %a .}@ %S@]@\n@\n" Tags.print tags sflag end flags; pp "@." ;; let proceed () = Hooks.call_hook Hooks.Before_options; Options.init (); if !Options.must_clean then clean (); Hooks.call_hook Hooks.After_options; Plugin.execute_plugin_if_needed (); if !Options.targets = [] && !Options.show_tags = [] && not !Options.show_documentation then raise Exit_silently; let target_dirs = List.union [] (List.map Pathname.dirname !Options.targets) in Configuration.parse_string "<**/*.ml> or <**/*.mli> or <**/*.mlpack> or <**/*.ml.depends>: ocaml\n\ <**/*.byte>: ocaml, byte, program\n\ <**/*.odoc>: ocaml, doc\n\ <**/*.native>: ocaml, native, program\n\ <**/*.cma>: ocaml, byte, library\n\ <**/*.cmxa>: ocaml, native, library\n\ <**/*.cmo>: ocaml, byte\n\ <**/*.cmi>: ocaml, byte, native\n\ <**/*.cmx>: ocaml, native\n\ "; Configuration.tag_any !Options.tags; if !Options.recursive || Sys.file_exists (* authorized since we're not in build *) "_tags" || Sys.file_exists (* authorized since we're not in build *) "myocamlbuild.ml" then Configuration.tag_any ["traverse"]; (* options related to findlib *) List.iter (fun pkg -> Configuration.tag_any [Param_tags.make "package" pkg]) !Options.ocaml_pkgs; let newpwd = Sys.getcwd () in Sys.chdir Pathname.pwd; let entry_include_dirs = ref [] in let entry = Slurp.filter begin fun path name _ -> let dir = if path = Filename.current_dir_name then None else Some path in let path_name = path/name in if name = "_tags" then ignore (Configuration.parse_file ?dir path_name); (List.mem name ["_oasis"] || (String.length name > 0 && name.[0] <> '_')) && (name <> !Options.build_dir && not (List.mem name !Options.exclude_dirs)) && begin if path_name <> Filename.current_dir_name && Pathname.is_directory path_name then let tags = tags_of_pathname path_name in if Tags.mem "include" tags || List.mem path_name !Options.include_dirs then (entry_include_dirs := path_name :: !entry_include_dirs; true) else Tags.mem "traverse" tags || List.exists (Pathname.is_prefix path_name) !Options.include_dirs || List.exists (Pathname.is_prefix path_name) target_dirs else true end end (Slurp.slurp Filename.current_dir_name) in Hooks.call_hook Hooks.Before_hygiene; let hygiene_entry = Slurp.map begin fun path name () -> let tags = tags_of_pathname (path/name) in not (Tags.mem "not_hygienic" tags) && not (Tags.mem "precious" tags) end entry in if !Options.hygiene then Fda.inspect hygiene_entry else Slurp.force hygiene_entry; let entry = hygiene_entry in Hooks.call_hook Hooks.After_hygiene; Options.include_dirs := Pathname.current_dir_name :: List.rev !entry_include_dirs; dprintf 3 "include directories are:@ %a" print_string_list !Options.include_dirs; Options.entry := Some entry; List.iter Configuration.parse_string !Options.tag_lines; Hooks.call_hook Hooks.Before_rules; Ocaml_specific.init (); Hooks.call_hook Hooks.After_rules; Param_tags.init (); Sys.chdir newpwd; (*let () = dprintf 0 "source_dir_path_set:@ %a" StringSet.print source_dir_path_set*) if !Options.show_documentation then begin show_documentation (); raise Exit_silently end; Digest_cache.init (); Sys.catch_break true; show_tags (); let targets = List.map begin fun starget -> let starget = Resource.import starget in let target = path_and_context_of_string starget in let ext = Pathname.get_extension starget in (target, starget, ext) end !Options.targets in try let targets = List.map begin fun (target, starget, ext) -> Shell.mkdir_p (Pathname.dirname starget); let target = Solver.solve_target starget target in (target, ext) end targets in Command.dump_parallel_stats (); Log.finish (); Shell.chdir Pathname.pwd; let call spec = sys_command (Command.string_of_command_spec spec) in let cmds = List.fold_right begin fun (target, ext) acc -> let cmd = !Options.build_dir/target in let link x = if !Options.make_links then ignore (call (S [A"ln"; A"-sf"; P x; A Pathname.current_dir_name])) in match ext with | "byte" | "native" | "top" -> link cmd; cmd :: acc | "html" -> link (Pathname.dirname cmd); acc | _ -> if !Options.program_to_execute then eprintf "Warning: Won't execute %s whose extension is neither .byte nor .native" cmd; acc end targets [] in if !Options.program_to_execute then begin match List.rev cmds with | [] -> raise (Exit_usage "Using -- requires one target"); | cmd :: rest -> if rest <> [] then dprintf 0 "Warning: Using -- only run the last target"; let cmd_spec = S [P cmd; atomize !Options.program_args] in dprintf 3 "Running the user command:@ %a" Pathname.print cmd; raise (Exit_with_code (call cmd_spec)) (* Exit with the exit code of the called command *) end else () with | Ocaml_dependencies.Circular_dependencies(seen, p) -> raise (Exit_build_error (sbprintf "@[<2>Circular dependencies: %S already seen in@ %a@]@." p pp_l seen)) ;; open Exit_codes;; let main () = let exit rc = Log.finish ~how:(if rc <> 0 then `Error else `Success) (); Pervasives.exit rc in try proceed () with e -> if !Options.catch_errors then try raise e with | Exit_OK -> exit rc_ok | Fda.Exit_hygiene_failed -> Log.eprintf "Exiting due to hygiene violations."; exit rc_hygiene | Exit_usage u -> Log.eprintf "Usage:@ %s." u; exit rc_usage | Exit_system_error msg -> Log.eprintf "System error:@ %s." msg; exit rc_system_error | Exit_with_code rc -> exit rc | Exit_silently -> Log.finish ~how:`Quiet (); Pervasives.exit rc_ok | Exit_silently_with_code rc -> Log.finish ~how:`Quiet (); Pervasives.exit rc | Solver.Failed backtrace -> Log.raw_dprintf (-1) "@[@[<2>Solver failed:@ %a@]@\n@[Backtrace:%a@]@]@." Report.print_backtrace_analyze backtrace Report.print_backtrace backtrace; exit rc_solver_failed | Failure s -> Log.eprintf "Failure:@ %s." s; exit rc_failure | Solver.Circular(r, rs) -> Log.eprintf "Circular build detected@ (%a already seen in %a)" Resource.print r (List.print Resource.print) rs; exit rc_circularity | Invalid_argument s -> Log.eprintf "INTERNAL ERROR: Invalid argument %s\n\ This is likely to be a bug, please report this to the ocamlbuild\n\ developers." s; exit rc_invalid_argument | Ocaml_utils.Ocamldep_error msg -> Log.eprintf "Ocamldep error: %s" msg; exit rc_ocamldep_error | Lexers.Error msg -> Log.eprintf "Lexical analysis error: %s" msg; exit rc_lexing_error | Arg.Bad msg -> Log.eprintf "%s" msg; exit rc_usage | Exit_build_error msg -> Log.eprintf "%s" msg; exit rc_build_error | Arg.Help msg -> Log.eprintf "%s" msg; exit rc_ok | e -> try Log.eprintf "%a" My_unix.report_error e; exit 100 with | e -> Log.eprintf "Exception@ %s." (Printexc.to_string e); exit 100 else raise e ;; mingw-ocaml/ocaml/ocamlbuild/rule.mli0000644000175000017500000000542612124403240017251 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Resource type env = Pathname.t -> Pathname.t type builder = Pathname.t list list -> (Pathname.t, exn) Outcome.t list type action = env -> builder -> Command.t type 'a gen_rule type rule = Pathname.t gen_rule type rule_scheme = resource_pattern gen_rule type 'a rule_printer = (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a gen_rule -> unit (** This exception can be raised inside the action of a rule to make the algorithm skip this rule. *) exception Failed val name_of_rule : 'a gen_rule -> string val deps_of_rule : 'a gen_rule -> Pathname.t list val prods_of_rule : 'a gen_rule -> 'a list val rule : string -> ?tags:string list -> ?prods:string list -> ?deps:string list -> ?prod:string -> ?dep:string -> ?stamp:string -> ?insert:[`top | `before of string | `after of string | `bottom] -> action -> unit (** [copy_rule name ?insert source destination] *) val copy_rule : string -> ?insert:[`top | `before of string | `after of string | `bottom] -> string -> string -> unit module Common_commands : sig val mv : Pathname.t -> Pathname.t -> Command.t val cp : Pathname.t -> Pathname.t -> Command.t val cp_p : Pathname.t -> Pathname.t -> Command.t val ln_f : Pathname.t -> Pathname.t -> Command.t val ln_s : Pathname.t -> Pathname.t -> Command.t val rm_f : Pathname.t -> Command.t val chmod : Command.spec -> Pathname.t -> Command.t val cmp : Pathname.t -> Pathname.t -> Command.t end val print : Format.formatter -> rule -> unit val pretty_print : 'a rule_printer (** For system use only *) val subst : Resource.env -> rule_scheme -> rule val can_produce : Pathname.t -> rule_scheme -> rule option (* val tags_matches : Tags.t -> t -> t option *) val compare : 'a gen_rule -> 'a gen_rule -> int val print_rule_name : Format.formatter -> 'a gen_rule -> unit val print_rule_contents : 'a rule_printer val get_rules : unit -> rule_scheme list val clear_rules : unit -> unit val call : builder -> rule -> unit val build_deps_of_tags : builder -> Tags.t -> Pathname.t list mingw-ocaml/ocaml/ocamlbuild/ocamlbuild_executor.ml0000644000175000017500000002275012124403240022161 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Ocamlbuild_executor *) open Unix;; type error = | Subcommand_failed | Subcommand_got_signal | Io_error | Exceptionl_condition type task = unit -> string;; type job = { job_id : int * int; job_command : string; job_next : task list; job_result : bool ref; (* Result of this sequence group *) job_stdout : in_channel; job_stdin : out_channel; job_stderr : in_channel; job_buffer : Buffer.t; mutable job_dying : bool; };; module JS = Set.Make(struct type t = job let compare = compare end);; module FDM = Map.Make(struct type t = file_descr let compare = compare end);; let sf = Printf.sprintf;; let fp = Printf.fprintf;; (*** print_unix_status *) (* FIXME never called *) let print_unix_status oc = function | WEXITED x -> fp oc "exit %d" x | WSIGNALED i -> fp oc "signal %d" i | WSTOPPED i -> fp oc "stop %d" i ;; (* ***) (*** print_job_id *) let print_job_id oc (x,y) = fp oc "%d.%d" x y;; (* ***) (*** output_lines *) let output_lines prefix oc buffer = let u = Buffer.contents buffer in let m = String.length u in let output_line i j = output_string oc prefix; output oc u i (j - i); output_char oc '\n' in let rec loop i = if i = m then () else begin try let j = String.index_from u i '\n' in output_line i j; loop (j + 1) with | Not_found -> output_line i m end in loop 0 ;; (* ***) (*** execute *) (* XXX: Add test for non reentrancy *) let execute ?(max_jobs=max_int) ?(ticker=ignore) ?(period=0.1) ?(display=(fun f -> f Pervasives.stdout)) ~exit (commands : task list list) = let batch_id = ref 0 in let env = environment () in let jobs = ref JS.empty in let jobs_active = ref 0 in let jobs_to_terminate = Queue.create () in let commands_to_execute = Queue.create () in let all_ok = ref true in let results = List.map (fun tasks -> let result = ref false in Queue.add (tasks, result) commands_to_execute; result) commands in let outputs = ref FDM.empty in let doi = descr_of_in_channel in let doo = descr_of_out_channel in (*** compute_fds *) let compute_fds = let fds = ref ([], [], []) in let prev_jobs = ref JS.empty in fun () -> if not (!prev_jobs == !jobs) then begin prev_jobs := !jobs; fds := JS.fold begin fun job (rfds, wfds, xfds) -> let ofd = doi job.job_stdout and ifd = doo job.job_stdin and efd = doi job.job_stderr in (ofd :: efd :: rfds, wfds, ofd :: ifd :: efd :: xfds) end !jobs ([], [], []) end; !fds in (* ***) (*** add_job *) let add_job cmd rest result id = (*display begin fun oc -> fp oc "Job %a is %s\n%!" print_job_id id cmd; end;*) let (stdout', stdin', stderr') = open_process_full cmd env in incr jobs_active; set_nonblock (doi stdout'); set_nonblock (doi stderr'); let job = { job_id = id; job_command = cmd; job_next = rest; job_result = result; job_stdout = stdout'; job_stdin = stdin'; job_stderr = stderr'; job_buffer = Buffer.create 1024; job_dying = false } in outputs := FDM.add (doi stdout') job (FDM.add (doi stderr') job !outputs); jobs := JS.add job !jobs; in (* ***) (*** skip_empty_tasks *) let rec skip_empty_tasks = function | [] -> None | task :: tasks -> let cmd = task () in if cmd = "" then skip_empty_tasks tasks else Some(cmd, tasks) in (* ***) (*** add_some_jobs *) let add_some_jobs () = let (tasks, result) = Queue.take commands_to_execute in match skip_empty_tasks tasks with | None -> result := false | Some(cmd, rest) -> let b_id = !batch_id in incr batch_id; add_job cmd rest result (b_id, 0) in (* ***) (*** terminate *) let terminate ?(continue=true) job = if not job.job_dying then begin job.job_dying <- true; Queue.add (job, continue) jobs_to_terminate end else () in (* ***) (*** add_more_jobs_if_possible *) let add_more_jobs_if_possible () = while !jobs_active < max_jobs && not (Queue.is_empty commands_to_execute) do add_some_jobs () done in (* ***) (*** do_read *) let do_read = let u = String.create 4096 in fun ?(loop=false) fd job -> (*if job.job_dying then () else*) try let rec iteration () = let m = try read fd u 0 (String.length u) with | Unix.Unix_error(_,_,_) -> 0 in if m = 0 then if job.job_dying then () else terminate job else begin Buffer.add_substring job.job_buffer u 0 m; if loop then iteration () else () end in iteration () with | x -> display begin fun oc -> fp oc "Exception %s while reading output of command %S\n%!" job.job_command (Printexc.to_string x); end; exit Io_error in (* ***) (*** process_jobs_to_terminate *) let process_jobs_to_terminate () = while not (Queue.is_empty jobs_to_terminate) do ticker (); let (job, continue) = Queue.take jobs_to_terminate in (*display begin fun oc -> fp oc "Terminating job %a\n%!" print_job_id job.job_id; end;*) decr jobs_active; do_read ~loop:true (doi job.job_stdout) job; do_read ~loop:true (doi job.job_stderr) job; outputs := FDM.remove (doi job.job_stdout) (FDM.remove (doi job.job_stderr) !outputs); jobs := JS.remove job !jobs; let status = close_process_full (job.job_stdout, job.job_stdin, job.job_stderr) in let shown = ref false in let show_command () = if !shown then () else display begin fun oc -> shown := true; fp oc "+ %s\n" job.job_command; output_lines "" oc job.job_buffer end in if Buffer.length job.job_buffer > 0 then show_command (); begin match status with | Unix.WEXITED 0 -> begin if continue then begin match skip_empty_tasks job.job_next with | None -> job.job_result := true | Some(cmd, rest) -> let (b_id, s_id) = job.job_id in add_job cmd rest job.job_result (b_id, s_id + 1) end else all_ok := false; end | Unix.WEXITED rc -> show_command (); display (fun oc -> fp oc "Command exited with code %d.\n" rc); all_ok := false; exit Subcommand_failed | Unix.WSTOPPED s | Unix.WSIGNALED s -> show_command (); all_ok := false; display (fun oc -> fp oc "Command got signal %d.\n" s); exit Subcommand_got_signal end done in (* ***) (*** terminate_all_jobs *) let terminate_all_jobs () = JS.iter (terminate ~continue:false) !jobs in (* ***) (*** loop *) let rec loop () = (*display (fun oc -> fp oc "Total %d jobs\n" !jobs_active);*) process_jobs_to_terminate (); add_more_jobs_if_possible (); if JS.is_empty !jobs then () else begin let (rfds, wfds, xfds) = compute_fds () in ticker (); let (chrfds, chwfds, chxfds) = select rfds wfds xfds period in List.iter begin fun (fdlist, hook) -> List.iter begin fun fd -> try let job = FDM.find fd !outputs in ticker (); hook fd job with | Not_found -> () (* XXX *) end fdlist end [chrfds, do_read ~loop:false; chwfds, (fun _ _ -> ()); chxfds, begin fun _ _job -> (*display (fun oc -> fp oc "Exceptional condition on command %S\n%!" job.job_command); exit Exceptional_condition*) () (* FIXME *) end]; loop () end in try loop (); None with | x -> begin try terminate_all_jobs () with | x' -> display (fun oc -> fp oc "Extra exception %s\n%!" (Printexc.to_string x')) end; Some(List.map (!) results, x) ;; (* ***) mingw-ocaml/ocaml/ocamlbuild/configuration.mli0000644000175000017500000000315412124403240021145 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) (* Configuration *) (** Handles the "_tags" file mechanism. *) (** Incorporate a newline-separated configuration string into the current configuration. Will usually raising an [Invalid_arg] with an appropriately explicit message in case of error. *) val parse_string : string -> unit (** [parse_file ?dir fn] incorporates the configuration file named [fn], prefixing its glob patterns with [dir] if given. *) val parse_file : ?dir:string -> string -> unit (** Return the set of tags that apply to a given filename under the current configuration. *) val tags_of_filename : string -> Tags.t val has_tag : string -> bool (** [tag_file filename tag_list] Tag the given filename with all given tags. *) val tag_file : Pathname.t -> Tags.elt list -> unit (** [tag_any tag_list] Tag anything with all given tags. *) val tag_any : Tags.elt list -> unit mingw-ocaml/ocaml/ocamlbuild/ocaml_dependencies.mli0000644000175000017500000000372312124403240022101 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) (** OCaml dependencies *) exception Circular_dependencies of string list * string (** Give to this module a way to access libraries, packages, and dependencies between files. *) module type INPUT = sig val fold_dependencies : (string -> string -> 'a -> 'a) -> 'a -> 'a val fold_libraries : (string -> string list -> 'a -> 'a) -> 'a -> 'a val fold_packages : (string -> string list -> 'a -> 'a) -> 'a -> 'a end (** Wait an [INPUT] module and gives a function to compute the transitive closure of caml file takeing in account libraries and packages. *) module Make (I : INPUT) : sig (** [caml_transitive_closure] takes a list of root ocaml compiled files and returns the list of files that must be given to a linker. Optionally you can change the extension of caml object/library files (cmo/cma by default); use the pack mode (false by default) to include only root files (just sort them); and gives the list of used libraries (empty by default). *) val caml_transitive_closure : ?caml_obj_ext:string -> ?caml_lib_ext:string -> ?pack_mode:bool -> ?used_libraries:string list -> ?hidden_packages:string list -> Pathname.t list -> Pathname.t list end mingw-ocaml/ocaml/ocamlbuild/glob.mli0000644000175000017500000000232012124403240017213 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Glob *) (** The type representing fast patterns. Do not attempt to compare them, as they get on-the-fly optimizations. *) type fast_pattern (** A self-contained module implementing extended shell glob patterns who have an expressive power equal to boolean combinations of regular expressions. *) include Signatures.GLOB with type globber = fast_pattern Glob_ast.atom Bool.boolean val fast_pattern_of_pattern : Glob_ast.pattern -> fast_pattern mingw-ocaml/ocaml/ocamlbuild/ocamlbuild.ml0000644000175000017500000000151512124403240020237 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) Ocamlbuild_unix_plugin.setup (); Ocamlbuild_pack.Main.main () mingw-ocaml/ocaml/ocamlbuild/solver.mli0000644000175000017500000000211512124403240017604 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) type backtrace = private | Leaf of Pathname.t | Choice of backtrace list | Depth of Pathname.t * backtrace | Target of string * backtrace exception Failed of backtrace exception Circular of Pathname.t * Pathname.t list val solve : Pathname.t -> unit val solve_target : string -> Pathname.t list -> Pathname.t mingw-ocaml/ocaml/ocamlbuild/log.mli0000644000175000017500000000246312124403240017061 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) (* Log *) (** Module for modulating the logging output with the logging level. *) include Signatures.LOG (** Turn it to true to have a classic display of commands. *) val classic_display : bool ref (** See {Display.event}. *) val event : ?pretend:bool -> string -> string -> Tags.t -> unit (**/**) (** Initialize the Log module given a log file name. *) val init : string option -> unit val finish : ?how:[`Success|`Error|`Quiet] -> unit -> unit val display : (out_channel -> unit) -> unit val update : unit -> unit val mode : string -> bool mingw-ocaml/ocaml/ocamlbuild/TODO0000644000175000017500000000305512124403240016263 0ustar tootstootsTo do: * Add rules for producing .recdepends from .ml, .mli, .mllib, .mlpack * Produce a dependency subgraph when failing on circular deps (e.g. "A: B C\nB: D") * Executor: exceptional conditions and Not_found * Fix report * Design a nice, friendly, future-proof plugin (myocamlbuild) API * Ocamlbuild should keep track of files removed from the source directory, e.g., removing a .mli should be mirrored in the _build directory. Being done: * Write doc Almost done: * Fine control for hygiene using a glob pattern (command line option + tag) => the command line option is todo. -tag " or ..." "tag1, -tag2, ..." Won't fix: * Config file for options => no since myocamlbuild is sufficent * Optimize MD5 (Daemon ? Dnotify ?) : too much hassle for little gain Done: * Fix uncaught exception handler to play well with the Display module * Finish display before executing target * Slurp: in a directory read files, before subdirs (to have _tags before foo/_tags) * Add a -clean option * Add ocamldoc rules (use .odoc extension) * Add .inferred.mli target rules * -- with no args does not call the executable * Complain when used with -- and no target * dep ["ocaml"; "link"; "use_foo"] ["foo/foo.o"] tags for adding targets * Ensure that _build and _log are not created if not needed (with -help for instance) * Display: should display nothing (even when finish is called) when no real event as occured. * Have some option to draw tags/rules that applies on a target (it's -show-tags). * rm sanitize.sh during -clean * rm sanitize.sh when running ocamlbuild mingw-ocaml/ocaml/ocamlbuild/ocamlbuild_plugin.ml0000644000175000017500000000543012124403240021615 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open Ocamlbuild_pack include Ocamlbuild_pack.My_std module Arch = Ocamlbuild_pack.Ocaml_arch module Command = Ocamlbuild_pack.Command module Pathname = Ocamlbuild_pack.Pathname module Tags = Ocamlbuild_pack.Tags include Pathname.Operators include Tags.Operators module Rule = Ocamlbuild_pack.Rule module Options = Ocamlbuild_pack.Options module Findlib = Ocamlbuild_pack.Findlib type command = Command.t = Seq of command list | Cmd of spec | Echo of string list * string | Nop and spec = Command.spec = | N | S of spec list | A of string | P of string | Px of string | Sh of string | T of Tags.t | V of string | Quote of spec include Rule.Common_commands type env = Pathname.t -> Pathname.t type builder = Pathname.t list list -> (Pathname.t, exn) Ocamlbuild_pack.My_std.Outcome.t list type action = env -> builder -> Command.t let rule = Rule.rule let clear_rules = Rule.clear_rules let dep = Command.dep let pdep = Command.pdep let copy_rule = Rule.copy_rule let ocaml_lib = Ocamlbuild_pack.Ocaml_utils.ocaml_lib let flag = Ocamlbuild_pack.Flags.flag let pflag = Ocamlbuild_pack.Flags.pflag let flag_and_dep = Ocamlbuild_pack.Ocaml_utils.flag_and_dep let pflag_and_dep = Ocamlbuild_pack.Ocaml_utils.pflag_and_dep let non_dependency = Ocamlbuild_pack.Ocaml_utils.non_dependency let use_lib = Ocamlbuild_pack.Ocaml_utils.use_lib let module_name_of_pathname = Ocamlbuild_pack.Ocaml_utils.module_name_of_pathname let string_list_of_file = Ocamlbuild_pack.Ocaml_utils.string_list_of_file let expand_module = Ocamlbuild_pack.Ocaml_utils.expand_module let tags_of_pathname = Ocamlbuild_pack.Tools.tags_of_pathname let hide_package_contents = Ocamlbuild_pack.Ocaml_compiler.hide_package_contents let tag_file = Ocamlbuild_pack.Configuration.tag_file let tag_any = Ocamlbuild_pack.Configuration.tag_any let run_and_read = Ocamlbuild_pack.My_unix.run_and_read type hook = Ocamlbuild_pack.Hooks.message = | Before_hygiene | After_hygiene | Before_options | After_options | Before_rules | After_rules let dispatch = Ocamlbuild_pack.Hooks.setup_hooks mingw-ocaml/ocaml/ocamlbuild/ocamlbuild_pack.mlpack0000644000175000017500000000060712124403240022075 0ustar tootstootsLog My_unix My_std Signatures Shell Display Command Configuration Discard_printf Flags Hygiene Options Pathname Report Resource Rule Slurp Solver Tags Tools Fda Ocaml_specific Ocaml_arch Ocamlbuild_where Ocamlbuild_Myocamlbuild_config Lexers Glob Bool Glob_ast Glob_lexer Plugin Main Hooks Ocaml_utils Ocaml_tools Ocaml_compiler Ocaml_dependencies Exit_codes Digest_cache Findlib Param_tags mingw-ocaml/ocaml/ocamlbuild/hooks.ml0000644000175000017500000000173512124403240017253 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) type message = | Before_hygiene | After_hygiene | Before_options | After_options | Before_rules | After_rules let hooks = ref ignore let setup_hooks f = hooks := f let call_hook m = !hooks m mingw-ocaml/ocaml/ocamlbuild/configuration.ml0000644000175000017500000000452012124403240020772 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Log open Lexers type t = Lexers.conf let acknowledge_config config = List.iter (fun (_, config) -> List.iter Param_tags.acknowledge config.plus_tags) config let cache = Hashtbl.create 107 let (configs, add_config) = let configs = ref [] in (fun () -> !configs), (fun config -> acknowledge_config config; configs := config :: !configs; Hashtbl.clear cache) let parse_string s = let conf = Lexers.conf_lines None 1 (Printf.sprintf "string: %S" s) (Lexing.from_string s) in add_config conf let parse_file ?dir file = try with_input_file file begin fun ic -> let conf = Lexers.conf_lines dir 1 (Printf.sprintf "file: %S" file) (Lexing.from_channel ic) in add_config conf end with Lexers.Error msg -> raise (Lexers.Error (file ^ ": " ^ msg)) let key_match = Glob.eval let apply_config s (config : t) init = List.fold_left begin fun tags (key, v) -> if key_match key s then List.fold_right Tags.add v.plus_tags (List.fold_right Tags.remove v.minus_tags tags) else tags end init config let apply_configs s = List.fold_right (apply_config s) (configs ()) Tags.empty let tags_of_filename s = try Hashtbl.find cache s with Not_found -> let res = apply_configs s in let () = Hashtbl.replace cache s res in res let has_tag tag = Tags.mem tag (tags_of_filename "") let tag_file file tags = if tags <> [] then parse_string (Printf.sprintf "%S: %s" file (String.concat ", " tags));; let tag_any tags = if tags <> [] then parse_string (Printf.sprintf "true: %s" (String.concat ", " tags));; mingw-ocaml/ocaml/ocamlbuild/bool.mli0000644000175000017500000000275712124403240017241 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Bool *) (** Provides a datatype for representing boolean formulas and evaluation, iteration and map functions. *) (** Public type for generic boolean formulas. An empty conjunction [And[]] is true and an empty disjunction [Or[]] is false. *) type 'a boolean = And of 'a boolean list | Or of 'a boolean list | Not of 'a boolean | Atom of 'a | True | False val eval : ('a -> bool) -> 'a boolean -> bool (** [eval g f] evaluates the boolean formula [f] using the values returned by [g] for the atoms. *) val iter : ('a -> unit) -> 'a boolean -> unit (** [iter g f] calls [g] over every atom of [f]. *) val map : ('a -> 'b) -> 'a boolean -> 'b boolean (** [map g f] replaces every atom of [f] by its image by [g]. *) mingw-ocaml/ocaml/ocamlbuild/tags.mli0000644000175000017500000000145012124403240017231 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) include Signatures.TAGS mingw-ocaml/ocaml/ocamlbuild/ChangeLog0000644000175000017500000024524112124403240017352 0ustar tootstoots2007-03-22 Nicolas Pouillard Allow to receive the build function in {custom,file}_rule. * rule.ml, * rule.mli, * signatures.mli: Ditto. * ocaml_specific.ml: Update. * command.ml, * command.mli: Add a function to get string and tags. * ocamldep.ml, * ocamldep.mli: Make tag based dependencies. * ocaml_compiler.ml: Do the pack as one command to be sure running the remove. * test/test8/myocamlbuild.ml, * test/good-output: Update. 2007-03-21 Nicolas Pouillard Fix the previous fix. * ocaml_compiler.ml: Remove the empty file. * test/good-output: Update. 2007-03-21 Nicolas Pouillard [native pack] use touch instead of mv and cmp. * ocaml_compiler.ml: This version is will force ocamlopt to do the right thing. * test/good-output: Update. 2007-03-20 Nicolas Pouillard Two bugs, two fixes. * ocaml_tools.ml: Add pp flags to interface inference. * ocaml_specific.ml: Add a rule for packing with a cmi that already exists. * test/good-output: Update. * Makefile: Change the default location. 2007-03-13 Nicolas Pouillard Fix a bug in expand_module. * ocaml_utils.ml: Handle correctly pathnames instead of just basenames. 2007-03-13 Nicolas Pouillard Use sys_file_exists instead of Sys.file_exists. * my_unix.ml: Since Sys.file_exists don't treat well captial letters. * my_std.ml: Fix a bug. * pathname.ml: Here is a an exception to the previous rule so, put a comment. 2007-03-11 Nicolas Pouillard Fix the List.union order. * my_std.ml: Fix and improve List.union. * pathname.ml: Use it and fix merge_include_dirs. * test/good-output: Update since the union order was wrong. 2007-03-11 Nicolas Pouillard Re fix menhir and include dirs. * ocaml_tools.ml: Specifiy ocamlc and -I with --ocamlc. 2007-03-11 Nicolas Pouillard Fix a bug: Add include directories to menhir. * ocaml_tools.ml: Ditto. * my_std.ml, * signatures.mli: Specification typo. 2007-03-07 Nicolas Pouillard Handle specially archives files during an import. * shell.ml: Ditto. 2007-03-07 Nicolas Pouillard Use cp -p in copy_rule, and fix some typos in the manual. * manual/manual.tex: Typos. * rule.ml, * rule.mli: Add cp_p and use it for copy_rule. 2007-03-05 Nicolas Pouillard Relaxe executor on exception condition. Patch from Berke. * executor.ml: Ignore Not_found and exceptional conditions. * TODO: Add an entry (needs to better understand POSIX). 2007-03-04 Nicolas Pouillard Split where in bindir and libdir. * ocamlbuild_where.mli: Ditto. * ocaml_specific.ml: Update. * options.ml: Use bindir. * plugin.ml: Update. * start.sh: Update. 2007-03-04 Nicolas Pouillard Virtual solvers for ocaml tools. * options.ml: Setup virtual command solver for commands like ocamlc, ocamlopt... This allow to have full pathname but let also failback to classic search path. * ocaml_compiler.ml: Add a tag to differentiate dependencies at link time. * ocamlbuild-presentation.rslide: Add an item as suggested by a friend. 2007-03-02 Nicolas Pouillard Same thing for the second link function. * ocaml_compiler.ml: Ignore stdlib. 2007-03-02 Nicolas Pouillard Move the stdlib hack. * ocaml_compiler.ml: Should works better. 2007-03-02 Nicolas Pouillard Little fix about library linking. * ocaml_utils.ml: Avoid linking twice in some cases. * ocaml_compiler.ml: Handle specially the OCaml stdlib. 2007-03-01 Nicolas Pouillard Remove a rec. * glob.ml: Parse is not rec. 2007-03-01 Nicolas Pouillard true: traverse and FAQ. * main.ml: Move the inital config upper to be loaded before the others and hygiene. * FAQ: New. 2007-02-28 Nicolas Pouillard Improve the glob dir handling. * glob.ml: Extend the ast instead of parsing an extended string. 2007-02-28 Nicolas Pouillard Ensure that the whole boolean expression is only valid in the directory. * glob.ml: Ditto. 2007-02-28 Nicolas Pouillard Put -g on link only for programs. * ocaml_specific.ml: Ditto. 2007-02-26 Berke Durak Added disclaimer to default rules table. * manual/manual.tex: . 2007-02-26 Nicolas Pouillard Add the -documentation option. * main.ml: Implement it. * flags.ml, * flags.mli: Add get_flags. * man/ocamlbuild.1: Update. * signatures.mli, * options.ml: Add show_documention. * rule.ml, * rule.mli: Add pretty_print. 2007-02-26 Nicolas Pouillard Add the -dont-catch-errors option. * main.ml: Implement it. * options.ml: Parse it. * signatures.mli: Declare it. * _tags: Use debug. 2007-02-26 Nicolas Pouillard Deal with the camlp4 library name. * ocaml_specific.ml: Introduce use_old_camlp4 for the old one. 2007-02-26 Nicolas Pouillard Minor `ocaml_lib' improvments. * signatures.mli: Declare and doc it. * ocamlbuild_plugin.ml: Export it. * ocaml_specific.ml, * ocaml_specific.mli: Add some dirs to std libs. Move the ocaml_lib implem to ... * ocaml_utils.mli, * ocaml_utils.ml: ... here. Improve it by adding the ~tag_name option. * ocaml_compiler.ml: The hash now contains the tag. * _tags: *.top use unix too. 2007-02-22 Berke Durak Should use Log.eprintf for show_tags. * main.ml: . 2007-02-22 Nicolas Pouillard ( & ), sanitize.sh, and the manual... * signatures.mli: Add ( & ). * hygiene.ml: Also clean the sanitize.sh script itself. * my_std.ml: Add ( & ). * manual/manual.tex: Some fixes and a section that I wrote but that's needs reflexion about what solution we want to support. 2007-02-22 Berke Durak Implemented fixes suggested by Commissar Leroy. * fda.ml: . * hygiene.ml: . * hygiene.mli: . * man/ocamlbuild.1: . * manual/manual.tex: . * ocaml_specific.ml: . * options.ml: . * signatures.mli: . 2007-02-20 Nicolas Pouillard Add -show-tags. * hygiene.ml: Rewrap the error message. * main.ml: Do the show_tags job. Move one hook. * ocaml_specific.ml: Add -g also in native code. * options.ml, * signatures.mli: Add the -show-tags option. * tags.ml: Fix print. * TODO: Add a done entry. 2007-02-16 Nicolas Pouillard Relaxing plural options to spaces. * lexers.mli, * lexers.mll: Add comma_or_blank_sep_strings. * options.ml: Use it. 2007-02-16 Nicolas Pouillard Add a plugin example. * manual/myocamlbuild.ml: New. 2007-02-16 Nicolas Pouillard Typos. * ocamlbuild-presentation.rslide: . * manual/trace.out: . 2007-02-16 Berke Durak Fixed a few typos and sentences. * ocamlbuild-presentation.rslide: . 2007-02-15 Nicolas Pouillard Little changes... * ocamlbuild-presentation.rslide: . 2007-02-15 Nicolas Pouillard Slides almost done... * manual/trace.out: New. Of course you needed it. * ocamlbuild-presentation.rslide: Ditto. 2007-02-15 Berke Durak Improving slides. * ocamlbuild-presentation.rslide: . 2007-02-15 Nicolas Pouillard Slides... * ocamlbuild-presentation.rslide: . 2007-02-15 Nicolas Pouillard Working on slides... * ocamlbuild-presentation.rslide: . 2007-02-15 Nicolas Pouillard More slides... * ocamlbuild-presentation.rslide: . 2007-02-12 Nicolas Pouillard Keep include dirs uniq. * ocaml_compiler.ml: Ditto. 2007-02-12 Nicolas Pouillard Keep include dirs uniq. * ocaml_compiler.ml: Ditto. 2007-02-12 Nicolas Pouillard Add ocamlmktop support. * ocamlbuild.mltop: New. * main.ml: Handle .top as binaries. * ocaml_compiler.ml, * ocaml_specific.ml, * ocaml_compiler.mli: Add mktop functions and rules. * options.ml, * signatures.mli: Add an ocamlmktop option. 2007-02-09 Berke Durak Was attempting to link with threads.cmxa in byte mode. * ocaml_specific.ml: . 2007-02-09 Berke Durak Talking of sterilize.sh. * manual/manual.tex: . 2007-02-09 Berke Durak Rewrote some parts, filled the abstract, moved rantings to the appendix. * manual/manual.tex: . * .vcs: . 2007-02-08 Nicolas Pouillard Add manual/manual.hva. * manual/manual.hva: New. 2007-02-08 Nicolas Pouillard Changes done with Luc. * manual/manual.tex: . * manual/Makefile: . 2007-02-08 Nicolas Pouillard Fix a bug found by Luc in hevea. * ocaml_utils.ml, * ocaml_utils.mli: Change keep_this_module into module_importance to have a finer grain. * ocaml_compiler.ml: Update to importance. * ocamldep.ml, * ocamldep.mli: We now try to also build stdlib modules but don't fail if they don't exists. * test/test5/stack.ml: New. * test/test5/a.ml: A test case (from hevea). * test/good-output: Update. 2007-02-08 Nicolas Pouillard Ocamldoc, extension:* tag ... * ocaml_tools.mli, * ocaml_tools.ml: The ocamldoc support now takes into account two modes *d and -o. * ocaml_specific.ml: Two more rules and many flags for some of the standard behaviors. * signatures.mli: Some comments. * tools.ml: Add the extension:* tag. * TODO: Update. 2007-02-08 Berke Durak Hygiene generates sterilize.sh. * fda.ml: . * fda.mli: . * hygiene.ml: . * hygiene.mli: . * main.ml: . * options.ml: . * signatures.mli: . 2007-02-07 Berke Durak Updated section on ocamldoc. * manual/manual.tex: . 2007-02-07 Nicolas Pouillard Some minor manual and slides changes. * ocamlbuild-presentation.rslide, * manual/manual.tex: Ditto. 2007-02-07 Nicolas Pouillard Make links for the documentation. * main.ml: Handle doc. * test/good-output: Update. 2007-02-07 Berke Durak Added manual section for ocamldoc. * manual/manual.tex: . * manual/Makefile: . 2007-02-07 Berke Durak Fixed truncated display problem. * executor.ml: . * .vcs: . 2007-02-07 Nicolas Pouillard Fix the bootstrap. * start.sh: Swap lines. * Makefile: -verbose. 2007-02-07 Berke Durak TODO + Executor. * manual/manual.tex: . * TODO: . 2007-02-06 Nicolas Pouillard Make -a more static, to avoid some complications. * ocaml_utils.ml, * ocaml_compiler.ml, * ocaml_compiler.ml, * ocaml_specific.ml: Ditto. 2007-02-06 Nicolas Pouillard A fix. * ocaml_compiler.ml: Don't use these refs too early. * ocamlbuild-presentation.rslide: . 2007-02-05 Nicolas Pouillard Plugin signature. Somewhat a big patch, but that's just moving things around. * signatures.mli: Add TAGS, OUTCOME, MISC, OPTIONS, ARCH and PLUGIN. * ocamlbuild_plugin.mli: New. * ocamlbuild_plugin.ml: Conform to the sig. * command.ml, * command.mli: Add a tags type. * main.ml: Quit early if no targets. * my_std.ml, * my_std.mli: More things are in signatures. * resource.ml, * resource.mli: Remove the type t that was an Pathname.t alias. * options.ml, * options.mli: Add ext_lib, ext_obj, ext_dll. * ocaml_compiler.ml: Update. * ocaml_tools.ml: Update to Outcome. * ocaml_specific.ml: Update. * ocaml_utils.mli: Remove *ext_*. * ocaml_arch.mli: Now in signatures. * pathname.ml: Add readdir. * slurp.ml: open Outcome. * rule.ml, * rule.mli, * solver.ml, * solver.mli: Update to Resource.t and Outcome.t. * tags.mli: Now in Signatures. * test/good-output: Update. * test/test8/test.sh, * test/test3/test.sh, * test/test4/test.sh, * test/test5/test.sh, * test/test6/test.sh, * test/test7/test.sh, * test/test2/test.sh: Update to -verbose 0. 2007-02-05 Berke Durak Continuing doc. * manual/manual.tex: . * .: . 2007-02-05 Berke Durak Described display line. * manual/manual.tex: . 2007-02-05 Berke Durak Renamed -debug as -verbose. Authorized spaces etc. in flags. Continuing documentation. * lexers.mll: . * manual/manual.tex: . * options.ml: . 2007-02-05 Berke Durak Added man page. * main.ml: . * man: New. * man/ocamlbuild.1: New. * manual/manual.tex: . * TODO: . 2007-02-05 Nicolas Pouillard Update start.sh. * start.sh: Update. 2007-02-05 Nicolas Pouillard Typo s/Orignal/Original/g. 2007-02-05 Nicolas Pouillard Make signatures and std_signatures mliS. * signatures.ml: Remove. * std_signatures.ml: Remove. * signatures.mli: New. * std_signatures.mli: New. * Makefile: Update. * lexers.mll: Allow any prefix: for tags. 2007-02-04 Nicolas Pouillard The beginning of a presentation. * ocamlbuild-presentation.rslide: New. 2007-02-04 Nicolas Pouillard Also add who is the original author of the file. * ocamlbuild.ml, * ocamlbuild_plugin.ml, * ocamlbuildlight.ml, * ocamlbuild_where.mli, * ocamlbuild.mli, * ocamlbuildlight.mli, * bool.ml, * bool.mli, * configuration.ml, * configuration.mli, * command.ml, * command.mli, * display.ml, * discard_printf.ml, * display.mli, * discard_printf.mli, * executor.ml, * executor.mli, * flags.ml, * fda.ml, * flags.mli, * fda.mli, * glob.ml, * glob_ast.ml, * glob_ast.mli, * glob.mli, * glob_lexer.mli, * glob_lexer.mll, * hygiene.ml, * hooks.ml, * hygiene.mli, * hooks.mli, * log.ml, * lexers.mli, * log.mli, * lexers.mll, * my_unix_with_unix.ml, * main.ml, * my_unix.ml, * my_std.ml, * my_unix_with_unix.mli, * my_std.mli, * my_unix.mli, * main.mli, * ocaml_utils.ml, * ocaml_tools.ml, * ocaml_arch.ml, * ocaml_specific.ml, * ocaml_compiler.ml, * ocaml_dependencies.ml, * ocaml_utils.mli, * ocaml_specific.mli, * ocaml_dependencies.mli, * ocaml_tools.mli, * ocaml_arch.mli, * ocaml_compiler.mli, * options.ml, * options.mli, * ocamldep.ml, * ocamldep.mli, * plugin.ml, * ppcache.ml, * pathname.ml, * ppcache.mli, * plugin.mli, * pathname.mli, * resource.ml, * resource.mli, * rule.ml, * rule.mli, * report.ml, * report.mli, * signatures.ml, * slurp.ml, * std_signatures.ml, * solver.ml, * shell.ml, * shell.mli, * slurp.mli, * solver.mli, * tags.ml, * tools.ml, * tags.mli, * tools.mli: Ditto. 2007-02-04 Nicolas Pouillard Add the header license. * ocamlbuildlight.ml, * ocamlbuild.ml, * ocamlbuild_plugin.ml, * ocamlbuild_where.mli, * ocamlbuild.mli, * ocamlbuildlight.mli, * bool.ml, * bool.mli, * configuration.ml, * configuration.mli, * command.ml, * command.mli, * discard_printf.ml, * display.ml, * display.mli, * discard_printf.mli, * executor.ml, * executor.mli, * fda.ml, * flags.ml, * flags.mli, * fda.mli, * glob.ml, * glob_ast.ml, * glob.mli, * glob_ast.mli, * glob_lexer.mli, * glob_lexer.mll, * hygiene.ml, * hooks.ml, * hygiene.mli, * hooks.mli, * log.ml, * lexers.mli, * log.mli, * lexers.mll, * my_unix.ml, * main.ml, * my_std.ml, * my_unix_with_unix.ml, * misc/opentracer.ml, * my_std.mli, * main.mli, * my_unix.mli, * my_unix_with_unix.mli, * ocaml_arch.ml, * ocaml_compiler.ml, * ocaml_specific.ml, * ocaml_tools.ml, * ocaml_utils.ml, * ocaml_dependencies.ml, * ocaml_utils.mli, * ocaml_tools.mli, * ocaml_dependencies.mli, * ocaml_compiler.mli, * ocaml_specific.mli, * ocaml_arch.mli, * options.ml, * options.mli, * ocamldep.ml, * ocamldep.mli, * plugin.ml, * pathname.ml, * ppcache.ml, * plugin.mli, * ppcache.mli, * pathname.mli, * resource.ml, * resource.mli, * rule.ml, * rule.mli, * report.ml, * report.mli, * slurp.ml, * std_signatures.ml, * signatures.ml, * solver.ml, * shell.ml, * shell.mli, * slurp.mli, * solver.mli, * tools.ml, * tags.ml, * tags.mli, * tools.mli: Ditto. 2007-02-03 Nicolas Pouillard Fix a bug in copy_file. * my_std.ml: Also use the binary mode for the output channel. 2007-02-03 Nicolas Pouillard Add nopervasives, and nolabels. * ocaml_specific.ml: Ditto. 2007-02-03 Nicolas Pouillard Windows cannot use executor. * shell.ml: As in command.ml use executor only in non-windows and non-degraded mode. * rule.ml: Update two error messages. 2007-02-02 Nicolas Pouillard Some minor things for the ocaml myocamlbuild for instance. * configuration.ml, * configuration.mli: Add has_tag. * my_std.ml, * my_std.mli: Add getenv and copy_chan. * ocaml_utils.ml, * ocaml_utils.mli: Move some commands to rule. * ocaml_specific.ml: Improve the menhir switching. * options.ml, * options.mli: Add -use-menhir and -menhir options. * rule.ml, * rule.mli: Add copy_rule and move some commands from ocaml_utils. * signatures.ml: . 2007-02-01 Nicolas Pouillard Move main sigs in signatures.ml and std_signatures.ml. * ocamlbuild_pack.mlpack: . * ocamlbuildlib.mllib: . * ocamlbuildlightlib.mllib: . * ocamlbuild.odocl: . * command.mli: . * glob.mli: . * log.mli: . * my_unix_with_unix.ml: . * my_std.ml: . * my_std.mli: . * ocaml_specific.ml: . * pathname.mli: . * std_signatures.ml: New. * signatures.ml: New. * start.sh: . * tags.ml: . * tags.mli: . * test/test5/_tags: . * Makefile: . * _tags: . 2007-02-01 Berke Durak Shell.run doesn't use execute_many in degraded mode. * shell.ml: . 2007-02-01 Berke Durak cp, rm -rf and mv-like commands use Executor to better play with display. * display.ml: . * my_unix.ml: . * main.ml: . * my_std.ml: . * my_unix.mli: . * shell.ml: . * shell.mli: . * start.sh: . * _tags: . 2007-02-01 Berke Durak Systematizing exit codes. * executor.ml: . * main.ml: . 2007-02-01 Berke Durak Added automatic file: tag, changed flag syntax. * lexers.mli: . * lexers.mll: . * main.ml: . * ocamldep.ml: . * ocamldep.mli: . * tools.ml: . 2007-01-31 Berke Durak Cleans up links to the _build directory. * main.ml: . * options.ml: . * options.mli: . * pathname.ml: . * pathname.mli: . 2007-01-31 Nicolas Pouillard Restore the link to binary targets functionality. * main.ml: Make it separate from target running. 2007-01-31 Nicolas Pouillard Add an hygiene hook pair. * ocamlbuild_plugin.ml, * hooks.ml, * hooks.mli, * main.ml: Ditto. 2007-01-31 Nicolas Pouillard The Killer feature about a fine grained dependency injection control. * rule.ml, * rule.mli: Add build_deps_of_tags and call it automatically before * ocaml_compiler.ml, * ocaml_compiler.mli: Rework tags, to have them when callinng build_deps_of_tags. executing a command. * ocaml_specific.ml, * ocaml_specific.mli: Move the exception Exit_build_error to main and remove the old dep function. * ocamlbuild_plugin.ml: Export some new functions. * test/test7/myocamlbuild.ml: Add a dep declaration. * test/test7/cool_plugin.ml: New. * test/test7/_tags: New. * test/good-output: Update. * flags.ml, * command.ml, * command.mli: Rename flags_of_tags as tag_handler. * main.ml: Update error handling. * TODO: Done. 2007-01-30 Nicolas Pouillard Fix and improve the new link/deps system. * ocaml_dependencies.ml, * ocaml_dependencies.mli: Some fixes and improvements. * pathname.ml, * pathname.mli: Add check_extension. * ocaml_compiler.ml, * ocaml_compiler.mli: Add support for hidden_packages and update. 2007-01-30 Nicolas Pouillard Reverse the last 2 patches, since there is fact no name clash. 2007-01-30 Nicolas Pouillard Shell -> Oshell second part. * ocamlbuild.odocl: Ditto. * test/good-output: Update. 2007-01-30 Nicolas Pouillard Rename the Shell module as Oshell to avoid a name clash with labltk. * shell.ml: Remove. * shell.mli: Remove. * oshell.ml: New. * oshell.mli: New. * ocamlbuild_pack.mlpack, * command.ml, * display.ml, * main.ml, * options.ml, * ppcache.ml, * pathname.ml, * plugin.ml, * resource.ml, * start.sh: Update. 2007-01-30 Nicolas Pouillard Fix 2 bugs. * test/test9/testglob.ml: More tests. * glob_lexer.mll: Fix "/**". * _tags: Restore my warnings. * executor.ml: Use the unused variable. 2007-01-30 Nicolas Pouillard Improve dprintf and update. * log.ml, log.mli: dprintf now wraps the message between "@[<2>" and "@]@.". * command.ml, * display.ml, * fda.ml, * main.ml, * ocaml_dependencies.ml, * ocaml_compiler.ml, * ocaml_utils.ml, * ocamldep.ml, * pathname.ml, * resource.ml, * rule.ml, * solver.ml: Update the dprintf usage. 2007-01-30 Nicolas Pouillard Add the new dependency linking system (plz test it !). * ocamlbuild_pack.mlpack: Add a brand new module. * ocaml_dependencies.ml: New. * ocaml_dependencies.mli: New. * ocaml_compiler.ml, * ocaml_compiler.mli: Use this new module. * resource.ml, * resource.mli: Export a folding function on dependencies. * TODO: Add something to do. * start.sh: . * main.ml: Update. 2007-01-29 Nicolas Pouillard Executor exit codes. * executor.ml: Use the standard exit. * main.ml: Some exit codes are reserved for Executor. 2007-01-29 Berke Durak Executor returns finer-grained results. * executor.ml: . * manual/manual.tex: . 2007-01-29 Nicolas Pouillard Toward a working command execute feature :). * executor.ml, * executor.mli: FIXME. * command.ml, * command.mli: Update to the new signature and merge the degraded mode to avoid duplication. * my_unix.ml, * my_unix.mli, * ocaml_utils.ml, * ocamldep.ml, * plugin.ml, * resource.ml, * rule.ml, * solver.ml, * test/good-output: Update. 2007-01-29 Nicolas Pouillard Revert almost all of the 2 last patches. * command.ml: . * command.mli: . * executor.ml: . * executor.mli: . * my_unix.ml: . * my_unix.mli: . * ocaml_utils.ml: . * ocaml_specific.ml: . * ocamldep.ml: . * plugin.ml: . * resource.ml: . * rule.ml: . * solver.ml: . 2007-01-29 Berke Durak Fixing before/after thunks. * command.ml: . * command.mli: . * ocaml_utils.ml: . * ocamldep.ml: . * plugin.ml: . * resource.ml: . * rule.ml: . * solver.ml: . * TODO: . 2007-01-29 Berke Durak Adding before and after handlers to Executor. * command.ml: . * executor.ml: . * executor.mli: . * my_unix.ml: . * my_unix.mli: . * manual/manual.tex: . 2007-01-29 Berke Durak Fixed multi-dir globbing. * glob_lexer.mll: . * manual/manual.tex: . 2007-01-29 Nicolas Pouillard Add Rule.custom_rule and cleanup the ocamldep meta rule. * ocamldep.ml, * ocamldep.mli: Make it a meta rule (or a rule generator). * rule.ml, * rule.mli: Add custom_rule. * ocaml_specific.ml: Update to Ocamldep. * test/good-output: Minor update. 2007-01-29 Nicolas Pouillard MakefileS... * manual/Makefile: More things to remove (sometimes). * Makefile: Use $(BUILDDIR) instead of _build. 2007-01-26 Berke Durak Documenting glob expressions. * glob_lexer.mll: Added negative character classes. * manual/manual.tex: . 2007-01-26 Berke Durak Started documenting glob syntax. * manual/manual.tex: . 2007-01-25 Nicolas Pouillard One other include dir fix. * main.ml: Ditto. * test/test9/testglob.ml: Add a failing test (request for feature). * test/good-output: Update. 2007-01-25 Nicolas Pouillard Include dirs and Backtrace. * main.ml: Fix -I, and restore the backtrace. * report.ml, * report.mli: Fix the backtrace and rename analyze to print_backtrace_analyze. 2007-01-25 Berke Durak Added cross-directory globbing. * glob_ast.ml: . * glob.ml: . * glob_ast.mli: . * glob_lexer.mll: . * test/test9/testglob.ml: . 2007-01-25 Nicolas Pouillard Inlcude dirs trought tags. * main.ml: Ditto. * my_unix_with_unix.ml: Imrpove stat errors. * my_std.ml, * my_std.mli: . * pathname.ml: bmla. * slurp.ml, * slurp.mli: Add force, fix bugs. 2007-01-25 Berke Durak Fixed double display of error status. * command.ml: . * display.ml: . * display.mli: . * log.ml: . * log.mli: . * main.ml: . * my_std.ml: . * my_std.mli: . * plugin.ml: . 2007-01-25 Berke Durak Stupid bug. * log.ml: . * main.ml: . * options.ml: . 2007-01-25 Berke Durak Fixed interface, handling of -- with no argument. * ocamlbuild_plugin.mli: Remove. * manual/manual.tex: . * options.ml: . 2007-01-25 Berke Durak Updated start.sh. * start.sh: . 2007-01-25 Berke Durak Added .mlis. * ocamlbuild_plugin.mli: New. * fda.mli: New. * main.ml: . * ocaml_specific.ml: . * plugin.ml: . * plugin.mli: New. 2007-01-25 Nicolas Pouillard Cut down ocaml_specific in pieces. * ocaml_specific.ml, * ocaml_specific.mli: Split. * ocamlbuild_plugin.ml: Update. * ocamlbuild_pack.mlpack: Add new modules. * my_std.ml, * my_std.mli: Add good_outcome. * ocaml_utils.ml: New. * ocaml_tools.ml: New. * ocaml_compiler.ml: New. * ocaml_utils.mli: New. * ocaml_compiler.mli: New. * ocaml_tools.mli: New. * ocamldep.ml: New. * ocamldep.mli: New. * start.sh: Update. * TODO: Move things done. 2007-01-25 Berke Durak Fixer return codes and error message flushing issues. * display.ml: . * log.ml: . * log.mli: . * main.ml: . * report.ml: . * report.mli: . 2007-01-25 Nicolas Pouillard Add a warning. * ocaml_specific.ml: In -debug 1 mode there is a now a warning when ocamlbuild skip a seliently a module, supposing that's an error of ocamldep. 2007-01-24 Nicolas Pouillard More hooks. * ocamlbuild_plugin.ml, * hooks.ml, * hooks.mli, * main.ml: Add {Before,After}_rules. 2007-01-24 Nicolas Pouillard Call these hooks. * main.ml: Call these hooks. 2007-01-24 Nicolas Pouillard Add a first version of dispatch. * ocamlbuild_plugin.ml: Export dispatch and the hooks type. * ocamlbuild_pack.mlpack: Add Hooks. * hooks.ml: New. * hooks.mli: New. * ocaml_specific.mli: New line. 2007-01-24 Berke Durak Mini slurp bug. * slurp.ml: . * TODO: . 2007-01-24 Nicolas Pouillard Fix few more things. * ocamlbuildlight.ml: . * ocamlbuild_version.ml: Remove. * ocamlbuild.ml: . * ocamlbuild_pack.mlpack: . * main.ml: . * ocaml_specific.ml: . * ocaml_specific.mli: . * start.sh: . * test/test2/toto.ml: . * test/good-output: . 2007-01-24 Berke Durak Read directories before files in Slurp. * slurp.ml: . * TODO: . 2007-01-24 Nicolas Pouillard Fix some bugs. * ocamlbuild_version.ml: Remove. * ocamlbuild.ml, * ocamlbuildlight.ml: Main is now in the pack. * ocamlbuild_pack.mlpack: more things. * ocaml_specific.ml: One fix and one comment. * start.sh: Update. 2007-01-24 Berke Durak Splitting ocaml_specific into multiple files. * ocamlbuildlight.ml: . * ocamlbuild.ml: . * ocamlbuild_version.ml: New. * ocamlbuild.mli: . * ocamlbuildlight.mli: . * ocamlbuild_pack.mlpack: . * command.ml: . * fda.ml: New. * hygiene.ml: . * main.ml: New. * my_std.ml: . * my_std.mli: . * main.mli: New. * manual/manual.tex: . * ocaml_specific.ml: . * ocaml_specific.mli: . * options.ml: . * options.mli: . * plugin.ml: New. * rule.ml: . * report.ml: . * tools.ml: New. * tools.mli: New. * TODO: . * _tags: . 2007-01-24 Nicolas Pouillard Minor changes. * manual/manual.tex: Typo s/the the/the/g. * ocaml_specific.ml, * ocaml_specific.mli: Add some function to deal with linking of a module list. Add a better lib declaration function. * TODO: Update. 2007-01-17 Nicolas Pouillard A new pathname operator and a bug fix. * pathname.ml, * pathname.mli: add the ( -.- ) operator to add an extension to a pathname. * ocaml_specific.ml: Use that new operator. * resource.ml: Fix a bug. 2007-01-17 Berke Durak More examples. * examples/example3/epoch.ml: . * examples/example3/make.sh: New. * manual/manual.tex: . * TODO: . 2007-01-17 Nicolas Pouillard Infered mli's, and bug fixes. * my_unix.ml: Fix a bug. * my_std.mli: Doc. * manual/manual.tex: Use \verb. * ocaml_arch.ml: Don't always overide the forpack_flags_of_pathname function reference. * ocaml_arch.mli: Remove the reference. * ocaml_specific.ml: Update for forpack and add infered mli's. * pathname.ml, * pathname.mli: Add is_directory. 2007-01-17 Berke Durak More examples. * examples/example3/epoch.ml: New. * examples/example2/hello.ml: . * examples/example2/greet.ml: New. * examples/example3: New. * examples/example2: New. * manual/manual.tex: . * TODO: . 2007-01-17 Berke Durak Started examples. * examples/example1/hello.ml: New. * examples/example1: New. * examples: New. * manual/manual.tex: . * .vcs: . * TODO: . 2007-01-17 Berke Durak Wrote limitations and features. * manual/manual.tex: . 2007-01-17 Berke Durak Wrote motivations. * manual/manual.tex: . * _tags: . 2007-01-17 Berke Durak Started manual. * manual/Makefile: New. * manual/manual.tex: New. * manual: New. 2007-01-17 Nicolas Pouillard Bugs, menhir, path variables. * display.ml: Fix a bug. * glob.mli: Fix a typo. * lexers.mli, * lexers.mll: Extend ocamldep_output lexer and meta_path lexer. * my_std.ml, * my_std.mli: Add memo and String.rev. * ocaml_specific.ml, * ocaml_specific.mli: Better rules for C lib linking and menhir rules. * resource.ml, * resource.mli: Handle naively some multiple variables. * rule.ml, * rule.mli: Update. * start.sh: Update. 2007-01-11 Nicolas Pouillard Integrate dprintf to the display. * display.ml, * display.mli: Add dprintf and log_level. * log.ml, * log.mli: Add dprintf and level. * debug.ml: Remove. * debug.mli: Remove. * options.ml: Update. * command.ml, ocaml_specific.ml, my_std.ml, * pathname.ml, ppcache.ml, resource.ml, * rule.ml, report.ml, slurp.ml, solver.ml, * configuration.ml, tags.ml: Update to Log. * ocamlbuild.odocl: Add Log, remove Debug. * ocamlbuild_pack.mlpack: Remove Debug. * bool.ml: Remove the debug dependency. 2007-01-10 Nicolas Pouillard Execute and windows... * command.ml: Test windows here. * my_unix_with_unix.ml: Revert a little. 2007-01-10 Nicolas Pouillard Don't use executor on windows. * my_unix_with_unix.ml: Since at least set_nonblock does not works on windows. 2007-01-10 Nicolas Pouillard Add the -no-log option and fix a log bug. * log.mli, * log.ml: Log is now a lazy to have the good setup order. * options.ml: Add the -no-log option. 2007-01-10 Nicolas Pouillard Fix a bug with quoting of the nil string. * shell.ml: Quote the nil string. 2007-01-09 Berke Durak Documented the interface of the glob module. * glob.mli: . 2007-01-09 Berke Durak Continuing to document interfaces. * bool.mli: . * debug.mli: . * discard_printf.mli: . * executor.mli: . * hygiene.mli: . * my_std.mli: . * slurp.mli: . * Makefile: . 2007-01-09 Nicolas Pouillard Fix a bug with directory links to build dir. * ocaml_specific.ml, * options.ml, * options.mli: Keep the Slurp.entry instead of a set. * pathname.ml: Clean the entry instead of the set, that more precise. * Makefile: Add doc phonny rules. 2007-01-09 Berke Durak Doc for Configuration. * ocamlbuild_plugin.ml: . * bool.mli: . * configuration.ml: . * configuration.mli: . * command.mli: . * doc: New. * glob.ml: . * ocaml_specific.ml: . * Makefile: . 2007-01-09 Berke Durak Started documentation. * bool.mli: . * command.ml: . * command.mli: . 2007-01-09 Nicolas Pouillard Export the doc. * Makefile: Use a link. * _tags: Don't spend times in that dir. 2007-01-09 Nicolas Pouillard Put the log file in the source dir and not when building plugin. * log.ml, * log.mli: Use an optional. * options.ml: Update. * pathname.mli: Export in_source_dir. * .vcs: Add _log. 2007-01-09 Berke Durak Added doc target. * report.ml: . * Makefile: . * TODO: . 2007-01-09 Berke Durak Writes tags to log file. * display.ml: . 2007-01-09 Nicolas Pouillard Add the Log module. * ocamlbuild_pack.mlpack: Add Log. * command.ml, * command.mli: Use Log. * log.ml: New. * log.mli: New. * options.ml: Use Log. * start.sh: Update. 2007-01-09 Berke Durak Added -log option. * command.ml: . * command.mli: . * display.ml: . * display.mli: . * executor.mli: . * options.ml: . * _tags: . 2007-01-09 Nicolas Pouillard Make usable the ocamldoc support. * ocaml_specific.ml: Add rules for ocamldoc. * ocamlbuild.odocl: New. * test/test3/proj.odocl: New. * test/good-output: Update. * test/test3/test.sh: Add a odoc test. 2007-01-09 Nicolas Pouillard Some cleanups. * ocamlbuild_plugin.ml: Add tag_file that simule one simple line in the _tags file. * ocaml_specific.ml, * ocaml_specific.mli: Add ln_s, touch, chmod. * pathname.ml, * pathname.mli: Remove map_extension*, split_extension* and compiled files hack skipping. * rule.ml: Improve logging. * solver.ml: Use another level. 2007-01-07 Nicolas Pouillard Fix a bug with debug rules. * ocaml_specific.ml: Move %.cmi from prods to deps. * test/good-output: Update. 2007-01-07 Nicolas Pouillard Add debugging rules. To get a ocamlbuild with debugging info you can call `make debug' that will produce ocamlbuild.d.byte and x.d.cmo files. * ocaml_specific.ml, * ocaml_specific.mli: Add debugging rules, reorder warnings flag to have 'A' and 'a' before others. * Makefile: Add the debug target. * _tags: Cleanup (remove the debug tag that was set by default). 2007-01-07 Nicolas Pouillard Add profiling support directly in rules. This means that you can now request for building a target such as my_main.p.native or my_lib.p.cmxa, that will create %.p.cmx intermediate files that do not interfer with non-profiling ones. * ocaml_specific.ml, * ocaml_specific.mli: Add rules and functions for native link and comilation in profiling mode. * Makefile: Add a profile target (require a fixed ocamlopt w.r.t pack). * _tags: Take care also of .p.cmx files. * glob.ml: IS.print is equivalent to print_is. * my_std.ml: Fix a bug. 2007-01-07 Nicolas Pouillard Add some functions... * glob.ml: Extract is_suffix and is_prefix. * my_std.ml, * my_std.mli: Add String.{is_suffix,is_prefix,first_chars,last_chars} and List.union. * pathname.ml, * pathname.mli: Add get_extensions, remove_extensions, update_extensions, map_extensions that treat all extensions instead of just the last. * tags.ml, * tags.mli: Add +++ and --- that treat optional tags. 2007-01-06 Nicolas Pouillard Change the default display in degraded mode. * command.ml: Ditto. 2007-01-06 Nicolas Pouillard Cleanup Makefile options. * Makefile: Ditto. 2007-01-06 Nicolas Pouillard Add a simple opened files tracer. * misc/opentracer.ml: New. Just support ktrace for now. A strace one will be appreciated the interface to follow is quite simple anyway. * misc: New. 2007-01-06 Nicolas Pouillard Handle better commands without Px atom. * command.ml: Display the whole command if no Px is found. * display.mli: No longer export these strings. 2007-01-06 Nicolas Pouillard Handle myocamlbuild_config.mli. * ocaml_specific.ml: Add support for an interface to the config. 2007-01-06 Berke Durak Improved language of explanations in Report. * report.ml: . 2007-01-06 Nicolas Pouillard Factor and fix the plugin building. * ocamlbuildlight.mli: New. * executor.ml: Call cleanup, add a fixme. * ocaml_specific.ml: Factor and fix plugin stuffs. * start.sh: Update. * Makefile: Update. * TODO: Update. * _tags: No longer do favors to some modules. 2007-01-05 Nicolas Pouillard Fix plugins. * ocamlbuildlib.mllib: Add missing modules. * ocamlbuildlightlib.mllib: New. * Makefile: Update. 2007-01-05 Nicolas Pouillard Change the my_unix system. * ocamlbuildlight.ml: Just call the main. * ocamlbuild.ml: Setup my_unix_with_unix. * ocamlbuildlib.mllib: Remove executor and exit_codes for the lib. * ocamlbuild_pack.mlpack: Remove my_std and my_unix. * exit_codes.ml: Remove. Put them directly in executor. * executor.ml: Add exitcodes. * my_unix.ml: New. Default implem. * my_unix_with_unix.ml: Extend the default implem. * my_unix_without_unix.ml: Remove. * my_unix.mli: Add the implem type and val. * my_unix_with_unix.mli: New. * ocaml_specific.ml, * pathname.ml, * slurp.ml, * Makefile, * command.ml, * _tags: Update. 2007-01-05 Nicolas Pouillard Don't use executor for the myocamlbuild call. * ocaml_specific.ml: Use sys_command directly. 2007-01-05 Nicolas Pouillard Fix a stupid bug. * command.ml: That cause to have reversed sequences. 2007-01-05 Nicolas Pouillard Some libs and ocamldoc changes. * ocaml_specific.ml, * ocaml_specific.mli: Improve ocaml_lib_flag, add fews libs. Fix ocamldoc support update tags, and use Px only once. 2007-01-05 Berke Durak Started ocamldoc support. * ocaml_specific.ml: . * options.ml: . * options.mli: . 2007-01-05 Berke Durak Pretend option didn't work. * command.ml: . 2007-01-05 Berke Durak TODO + typo. * options.ml: . * TODO: . 2007-01-05 Nicolas Pouillard Really call executor all time. * command.ml, * command.mli: Remove normalization. And execute_many, it's now execute that do all the job. In degraded mode it's execute_degraded. * my_unix_without_unix.ml: Update. * ocaml_specific.ml, * resource.ml, * rule.ml, * solver.ml: Update to Command.execute type. 2007-01-05 Berke Durak Isatty detection logic. * command.ml: . * executor.ml: . * my_unix_with_unix.ml: . * my_unix_without_unix.ml: . * my_unix.mli: . 2007-01-05 Nicolas Pouillard Always call executor. * command.ml: Unless in degraded mode. 2007-01-05 Berke Durak Removed debugging output, added period argument for ticker. * display.ml: . * executor.ml: . * executor.mli: . * my_unix.mli: . 2007-01-05 Berke Durak Somewhat slow but executor seems to work. * executor.ml: . 2007-01-05 Berke Durak Added an Exit_codes module. Fixing Executor... * ocamlbuild.ml: . * ocamlbuildlib.mllib: . * executor.ml: . * exit_codes.ml: New. * solver.ml: . 2007-01-05 Nicolas Pouillard Fix the max_jobs argument passing. * command.ml: Use an optional argument. 2007-01-05 Nicolas Pouillard Subway changes... * my_unix_without_unix.ml, * my_unix_with_unix.ml, * my_unix.mli, * command.ml: Call the new execute_many. * executor.ml, * executor.mli: Handle command sequences. 2007-01-04 Berke Durak Added Display.update. * display.ml: . * display.mli: . * executor.ml: . 2007-01-04 Berke Durak Added display function, indentation, language. * display.ml: . * display.mli: . * hygiene.ml: . 2007-01-04 Berke Durak Fixing interface of Executor. * executor.ml: . * executor.mli: . * my_unix_with_unix.ml: . 2007-01-04 Nicolas Pouillard Add attributes to entries. Add the -byte-plugin option. * slurp.ml, * slurp.mli: Add an attribute field, add map, rename fold_pathnames to fold and filter_on_names to filter. * hygiene.ml, * hygiene.mli: Perform hygiene only on entries with a true attribute. * options.ml, * options.mli: Add the native_plugin reference and the -byte-plugin option. * ocaml_specific.ml, * ocaml_specific.mli: Exclude files tagged not_hygienic or precious from hygiene. 2007-01-04 Berke Durak Fixed pack issues. * ocamlbuild.ml: . * executor.ml: . * executor.mli: New. * _tags: . 2007-01-04 Berke Durak Started executor module. * executor.ml: New. * hygiene.ml: . * my_unix_with_unix.ml: . 2007-01-04 Nicolas Pouillard Add virtual commands. * command.ml, * command.mli: Add the V constructor for virtual commands that will query a virtual command solver to use the best implementation of that virtual command. 2007-01-04 Nicolas Pouillard Mainly, prepare for parallel display. * ocamlbuild_plugin.ml: Export file_rule. * command.ml, * command.mli: Some cleanup and preparation. * lexers.mll: Remove the dirty hack. * my_std.ml, * my_std.mli: Move search_in_path to Command and add ( @:= ). * my_unix_with_unix.ml, * my_unix_without_unix.ml, * my_unix.mli: Change the execute_many_using_fork type. * ocaml_specific.ml: Use the nopervasives tag for pervasives dependencies. * start.sh: Update. * test/test8/myocamlbuild.ml: Update. * test/good-output: Update. * Makefile: Update. 2007-01-03 Nicolas Pouillard I don't like microbes. * hygiene.ml: Reverse the bool. 2007-01-03 Nicolas Pouillard Fix the stat problem. * ocaml_specific.ml: Use the filtered entry for source_dir_path_set. 2007-01-03 Berke Durak Hygiene filters cleaned out microbes. * hygiene.ml: . * hygiene.mli: . * ocaml_specific.ml: . * ocaml_specific.mli: . * slurp.ml: . * slurp.mli: . 2007-01-03 Nicolas Pouillard Filename concat cleanup. * my_std.ml, * my_std.mli: Add filename_concat. * glob.ml, * hygiene.ml, * lexers.mll, * pathname.ml, * resource.ml, * report.ml, * solver.ml, * slurp.ml, * solver.mli: Use filename_concat. * flags.ml: FIXME. 2007-01-03 Berke Durak Revert to old. * slurp.ml: . 2007-01-03 Berke Durak Debugging tags for myocamlbuild.ml. * ocaml_specific.ml: . * slurp.ml: . 2007-01-02 Nicolas Pouillard Another atempt to fix the slurp bug and lazy. * slurp.ml: Ditto. 2007-01-02 Nicolas Pouillard Fix slurp w.r.t lazyness: keep the cwd. * slurp.ml: Ditto. 2007-01-02 Nicolas Pouillard My_unix, slurp in degraded mode, _tags in subdirs, fix the bug with -j... * ocamlbuild_version.mli: Remove. * ocamlbuild_where.mli: New. * display.mli: New. * shell.ml: New. * shell.mli: New. * glob.ml, * glob.mli, * configuration.ml, * lexers.mli, * lexers.mll, * configuration.mli: Honor _tags files in subdirs. * my_unix_with_unix.ml, * command.ml, * command.mli, * resource.ml, * resource.mli, * solver.ml: Fix the bug with the -j option. * slurp.ml, * slurp.mli: New degraded mode using the find command. Use lazy values to avoid computing useless directories. * options.ml, * options.mli: Update -version and -where. * pathname.ml, * pathname.mli: Remove the init section. * rule.ml, * rule.mli: Add file_rule useful for rules that don't run a command but just write a file. * ocaml_specific.ml: Fix some plugin bugs. Remove -I to ocamldep. Handle msvc .obj,.lib instead of .o,.a. * my_unix_without_unix.ml: Make works link stuffs running the readlink command. * display.ml, * hygiene.ml, * my_std.ml, * my_unix.mli, * my_std.mli, * start.sh, * test/test5/test.sh, * test/good-output, * test/test6/test.sh, * test/test7/test.sh, * test/test4/test.sh, * test/test8/test.sh, * test/test3/test.sh, * test/test2/test.sh, * Makefile, * _tags, * ocamlbuild_pack.mlpack: Update. 2007-01-02 Berke Durak Fixed ticker. * display.ml: . 2006-12-21 Berke Durak Cosmetic. * command.ml: . * display.ml: . 2006-12-21 Berke Durak Computing display length. * display.ml: . 2006-12-21 Nicolas Pouillard Add -classic-display. * command.ml, * command.mli: Provide a way to use the classic display. * options.ml: Add the -classic-display option. * Makefile: Remove ppcache form the default. 2006-12-21 Berke Durak Finish display only once ; display number of jobs cached. * command.ml: . * display.ml: . 2006-12-21 Nicolas Pouillard Oops fix a bug. * command.ml: Add begin .. end. 2006-12-21 Nicolas Pouillard Some display fixes. * command.ml: Select the display mode and remove the assert false. * display.ml: Change the print function to have a more compact one. * start.sh: Update. 2006-12-21 Berke Durak Error support in Display.finish. * display.ml: . 2006-12-21 Berke Durak Support for cache. * display.ml: . 2006-12-21 Nicolas Pouillard Integrate display mode. * ocamlbuild_pack.mlpack: Add display. * command.mli: Add Px to indicate to highligth this pathname. * command.ml: Support Px and call Display. * display.ml: Fix minor bugs. * ocaml_specific.ml: Declare some Px, and quiet ocamlyacc, ocamllex. * options.ml: Add quiet to default tags. * ppcache.ml: Detect more accuratly ocamlrun. * pathname.ml: Improve concat. * _tags: No profile. 2006-12-21 Berke Durak Added pretend. * display.ml: . 2006-12-21 Berke Durak Added ticker. * display.ml: . 2006-12-21 Berke Durak Display module. * display.ml: . * my_unix_with_unix.ml: . * my_unix_without_unix.ml: . * my_unix.mli: . * test/test10/test.sh: New. * test/test10: New. * test/test10/dbdi: New. 2006-12-21 Nicolas Pouillard Use a better init order, and fix a Filename.concat usage. * ocaml_specific.ml: The plugin should act before any initialization. * ocaml_arch.ml: Use Pathname.(/). 2006-12-21 Berke Durak Started user-friendly display module. * display.ml: New. 2006-12-21 Nicolas Pouillard Fix init order. * ocaml_specific.ml: Config must be available for plugin building. 2006-12-21 Nicolas Pouillard Some fixes. * command.ml: Quote if needed. * my_std.mli: Comment String.contains_string. * resource.ml: Remove a useless separator. * test/good-output: Update. 2006-12-21 Nicolas Pouillard Plugin config file and profile mode. * ocaml_specific.ml: Fix a bug due to the lazyness of &&. * ocaml_specific.mli: Move some functions. 2006-12-21 Berke Durak Now compiles patterns for fast matching. Removed regexp support. * glob_ast.ml: . * glob.ml: . * glob_lexer.mli: . * glob_ast.mli: . * glob_lexer.mll: . * test/test9/testglob.ml: . * test/test9/dbgl: New. 2006-12-20 Berke Durak Pattern matching seems to start to work. * glob.ml: . 2006-12-20 Berke Durak Started faster pattern matching code. * ocaml_specific.ml: . * _tags: . 2006-12-20 Berke Durak myocamlbuild is rebuilt only as needed. * hygiene.ml: . * ocaml_specific.ml: . * pathname.ml: . * pathname.mli: . * resource.ml: . 2006-12-20 Nicolas Pouillard Some changes mainly for windows support. * command.ml, * command.mli: Add the Quote constructor to help quoting building in commands. * my_unix_with_unix.ml, * my_unix_without_unix.ml, * glob.ml: Commented reslash mode. * my_std.ml, * my_std.mli: Some new functions. * my_unix.mli: Export sys_command. * ocaml_specific.ml, * ocaml_specific.mli: Update and windows support. * options.ml, * options.mli: Remove the ocamlmklib option. * ppcache.ml: Fix a bug. * pathname.ml: Add more dirseps. Use a custom Filename.concat (for now). * resource.ml, * rule.ml, * Makefile, * _tags: Update. 2006-12-15 Nicolas Pouillard Update start order. * start.sh: Ditto. 2006-12-11 Berke Durak Added -custom, fixed paths for installation. * ocaml_specific.ml: . * Makefile: . 2006-12-11 Berke Durak Typo. * report.ml: . 2006-12-08 Nicolas Pouillard Add a basic ocamlmklib support. * ocaml_specific.ml, * ocaml_specific.mli: Use ocamlmklib to make libraries if enabled. * options.ml, * options.mli: Add -ocamlmklib and -use-ocamlmklib. 2006-12-08 Nicolas Pouillard Export more references of options. * command.ml, * command.mli: Add ?quiet to execute. * ocaml_specific.ml, * ocaml_specific.mli: Update to options. * options.ml, * options.mli: Move ocamlc, ocamlopt... to references on command specs. * solver.ml: Update. * Makefile: Use _ocamldistr to avoid hygiene. * .vcs: Use _ocamldistr. 2006-12-08 Nicolas Pouillard OCaml distrib stuffs. * command.ml, * command.mli: Add a normalization callback. * ocaml_specific.ml, * ocaml_specific.mli: Add a more complete interface. * options.ml, * options.mli: Add nostdlib. * pathname.ml: Add mkdir -p to import in build. * rule.ml, * rule.mli: Call normalization of commands for digest. * report.ml: Add ignore. * start.sh: Add report.ml*. * Makefile: Add distrib exportation (make a link). * .vcs: Unmask ocamldistrib link. 2006-12-07 Berke Durak Added TODO item. * .vcs: . * TODO: . 2006-12-07 Berke Durak Added TODO file. * TODO: New. 2006-12-07 Berke Durak Very rudimentary report analysis. * report.ml: . * _tags: . 2006-12-07 Nicolas Pouillard Update tests to run ocamlbuild correctly. * test/test2/test.sh, * test/test3/test.sh, * test/test4/test.sh, * test/test5/test.sh, * test/test6/test.sh, * test/test7/test.sh, * test/test8/test.sh, * test/test9/test.sh: Ditto. * test/good-output: Update. 2006-12-07 Nicolas Pouillard Make test9 independant. * test/test9/test.sh: Ditto. 2006-12-07 Berke Durak Rewrote globbing engine, adding {,} ; moved reporting functions to Report. * ocamlbuild_pack.mlpack: . * command.ml: . * glob_ast.ml: . * glob.ml: . * glob_ast.mli: . * glob_lexer.mll: . * ocaml_specific.ml: . * report.ml: New. * report.mli: New. * solver.ml: . * solver.mli: . * start.sh: . * test/test9/testglob.ml: . * test/test9/test.sh: . * test/test3/test.sh: . * _tags: . 2006-12-07 Nicolas Pouillard Degraded mode... * ocamlbuildlight.ml: New. * ocamlbuild_pack.mlpack: Include new modules. * bool.ml: Fake dependency. * configuration.ml: Adapt to the glob parser. * command.ml: Export the fork usage. * glob.ml: Use Str through My_unix. * glob_lexer.mli: New. * glob_lexer.mll: Add slashs to valid character patterns. * lexers.mli, * lexers.mll: Use the glob parser. * my_std.ml: Use My_unix. * my_unix_with_unix.ml: New. * my_unix_without_unix.ml: New. * my_unix.mli: New. * my_std.mli: Add search_in_path and change lazy force to ( !* ). * ocaml_specific.ml: Some updates. * options.ml, * options.mli: Add -ocamlrun. * pathname.ml: Adapt to an optional slurp. * ppcache.ml: Use search_in_path of my_std. * resource.ml: Update to ( !* ). * solver.ml: Export Unix errors reporting. * slurp.ml, * slurp.mli: Use My_unix. * start.sh: Update. * test/test9/testglob.ml: Test a constant. * test/test5/_tags, * test/test3/_tags, * test/test4/_tags: Don't use regexp. * test/good-output: Add test9. * test/test9/test.sh: Remove the parent usage. * Makefile: Add the light mode. * .vcs: Update. * _tags: Update. 2006-12-06 Berke Durak Extra tests for globbing. * test/test9/testglob.ml: . 2006-12-06 Berke Durak First draft of pattern matching. * glob_ast.ml: . * glob.ml: . * glob_ast.mli: . * glob_lexer.mll: . 2006-12-06 Berke Durak More hard-wired but common cases for globbing. * glob.ml: . * test/test9/testglob.ml: . 2006-12-06 Berke Durak Hidden interface in globber. * glob.mli: . * test/test9/testglob.ml: . 2006-12-06 Berke Durak Basic globbing works. * glob.ml: . * glob.mli: . * test/test9/testglob.ml: . 2006-12-06 Berke Durak Improved interface. * glob.ml: . * glob_ast.ml: New. * glob_ast.mli: New. * glob.mli: New. * glob_lexer.mll: . * test/test9/testglob.ml: . * _tags: . 2006-12-06 Berke Durak Added test9. * test/test9/testglob.ml: New. * test/test9/parent: New. * test/runtest.sh: . * test/test9: New. * test/test9/test.sh: New. 2006-12-06 Berke Durak Parser seems to work. * glob.ml: . * glob_lexer.mll: . 2006-12-06 Berke Durak Removed eof_char. * glob.ml: . * glob_lexer.mll: . 2006-12-06 Berke Durak Interface seems to be OK. * glob.ml: . * glob_lexer.mll: . 2006-12-06 Berke Durak Adding files for the globbing module. * bool.ml: New. * bool.mli: New. * glob.ml: New. * glob_lexer.mll: New. * _tags: . 2006-12-06 Berke Durak Replaced numeric escapes. * lexers.mll: . 2006-12-05 Nicolas Pouillard Remove most of the Str usage by using ocamllex. * ocamlbuild_pack.mlpack: Remove Re, add Lexers. * configuration.ml: Use Lexers. * command.ml: Don't use Re. * lexers.mli: New. * lexers.mll: New. * my_std.ml, * my_std.mli: Add String.before and String.after. * ocaml_specific.ml, * ocaml_specific.mli: Use Lexers but also provide tags for warnings. * resource.ml, * rule.ml, * options.ml, * ppcache.ml, * pathname.ml: Use Lexers. * re.ml: Remove. * re.mli: Remove. * start.sh: Update. * Makefile: Igonre _build... and gives -ml to ocamllex. * _tags: Warnings for lexers. 2006-12-05 Nicolas Pouillard Use Sys instead of Unix for readdir. * my_std.ml, * my_std.mli: Supress a Unix usage. 2006-12-05 Nicolas Pouillard Add an option to disable the link creation. * ocaml_specific.ml: Honor this option. * options.ml: Declare it. * options.mli: Define it. 2006-12-05 Nicolas Pouillard Don't import compiled files... * pathname.ml: For the OCaml compilation itself I need to exclude some dirs that contains compiled files but I want to use some of them with ocamlbuild. 2006-12-05 Nicolas Pouillard Support flags for ocamlyacc and ocamllex. * ocaml_specific.ml, * options.ml, * options.mli: Add these options. 2006-12-04 Nicolas Pouillard Two fixes (hygiene and libraries)... * hygiene.ml: Exit 0 if sterilize removes some files (since source files are cached in a rather persistent data structure I prefer let the user start on a fresh setup). * ocaml_specific.ml: Use the dirname if there is no directory named by removing the extension. 2006-12-04 Berke Durak Small bug in hygiene. * hygiene.ml: . 2006-12-04 Nicolas Pouillard Add postition specifications to rules. * rule.ml, * rule.mli: Add a way to specifie where to put a new rule (top,bottom,before another,after another). * flags.ml: Reorder. * my_std.ml, * my_std.mli: Add mv, fix an error handling. * ocaml_specific.ml: Better error message for circular dependencies. * ppcache.ml: Handle errors better. 2006-11-29 Nicolas Pouillard Add a working multiple job support. * command.ml, * command.mli: Add different versions of execute_many including a version that use forks. * options.ml, * options.mli: Restore the -j option. * solver.ml: Call Command.execute_many. * test/runtest.sh: Pass $@ to sub tests. * test/good-output: Update. 2006-11-28 Nicolas Pouillard Fix the link order. * start.sh: Fix the link order. 2006-11-28 Nicolas Pouillard One step toward multiple jobs: Add the support for suspended building. * resource.ml, * resource.mli: Add the notion of suspended building. This represent a resource that is fully ready for evaluation, it's just a command and a function to apply after. * rule.ml: Do not really execute rules that can be safely suspended. * solver.ml: Play with suspended rules to collect as many as possible to get closer to a pararllel execution. 2006-11-27 Nicolas Pouillard Fix the makefile. * Makefile: Fix deps. 2006-11-27 Nicolas Pouillard Activates more warnings, and prepare the -j feature. * hygiene.ml: Consolidates fragile patterns. * my_std.ml: Likewise. * ocaml_specific.ml: Mainly update to the new builder prototype. * pathname.ml, * pathname.mli: Kick a useless parameter. * resource.ml: Remove dead code and update. * rule.ml, * rule.mli: The bulider now takes a list of resource lists, it will try to make in parallel the first level of commands. * solver.ml: Update to builder without parallelism. * test/good-output: Update. * Makefile: Warnings are now set to -w A -warn-error A. 2006-11-26 Nicolas Pouillard Fix packages... again. * ocaml_specific.ml: Ditto. 2006-11-26 Nicolas Pouillard Fix packages. * ocaml_specific.ml: Try to handle better packages during link. * Makefile: Add the try_bootstrap rule. 2006-11-26 Nicolas Pouillard Add -tag, -tags to options. * ocaml_specific.ml: Append default tags from options. * options.ml, * options.mli: Add -tag and -tags. * tags.mli: Indent. 2006-11-26 Nicolas Pouillard Fix a bug and update tests. * resource.ml: Use Hashtbl.replace of course instead of Hashtbl.add to avoid a nasty bug. * test/test7/test.sh, * test/test8/test.sh, * test/test2/test.sh, * test/test6/test.sh, * test/test4/test.sh, * test/test5/test.sh, * test/test3/test.sh: Extract program options to be sure that the -nothing-should-be-rebuilt option is before the -- one. * test/good-output: Update. 2006-11-26 Nicolas Pouillard Use a hashtbl for digests. * resource.ml: Ditto. * ocaml_specific.ml: Remove dead code. 2006-11-26 Nicolas Pouillard Use lists instead of sets for rule deps & prods. * ocaml_specific.ml: Move the mli dep first. * resource.ml, * resource.mli: No more provide digest_resources but digest_resource. * rule.ml, * rule.mli: Use list instead of sets for deps and prods, since they are not heavily updated and the order matter. * solver.ml: Adapt. * test/good-output: Yeah! 2006-11-26 Nicolas Pouillard One more fix for libraries. * ocaml_specific.ml: Improve the link_exception handling. * test/good-output: Update. 2006-11-25 Nicolas Pouillard Fix the library linking. * ocaml_specific.ml: The test7 is specially made to check that feature. 2006-11-25 Nicolas Pouillard Remove list_set. * ocamlbuild_pack.mlpack: Remove list_set * list_set.ml: Remove. * list_set.mli: Remove. * start.sh: Remove list_set. * test/good-output: Regen. 2006-11-25 Nicolas Pouillard Fix the C rule when dirname = '.'. * ocaml_specific.ml: Don't move the output when it's useless. 2006-11-25 Nicolas Pouillard Ignore ocamlbuild_version.ml. 2006-11-25 Nicolas Pouillard New transitive closure. * ocamlbuild_version.ml: Remove. * my_std.ml, * my_std.mli: Add a debug mode for digests and run_and_read. * ocaml_specific.ml: New transitive closure. * pathname.ml, * pathname.mli: Export also parent_dir_name and fix same_contents. * resource.ml, * resource.mli: Add dependencies. * rule.ml: Adapt. * test/good-output: Regen. * Makefile: Improve install. * .vcs: Ignore other _build dirs. 2006-11-20 Nicolas Pouillard Rule definition shortcut and C files. * rule.ml, * rule.mli: Allow to pass ~prod and ~dep when there is just one file. * ocaml_specific.ml: Add a rule for C files and use the previous shortcut. 2006-11-18 Nicolas Pouillard No more extend Format. * command.ml, * my_std.ml, * my_std.mli: Put directly ksbprintf and sbprintf in My_std. 2006-11-18 Nicolas Pouillard Clean up and consistent use of Pathname instead of Filename. * command.ml, * my_std.ml, * my_std.mli, * ocaml_specific.ml, * pathname.ml, * ppcache.ml, * pathname.mli, * resource.ml: That's it. 2006-11-18 Nicolas Pouillard Restore List_set. * ocamlbuild_pack.mlpack, * list_set.ml, * list_set.mli, * resource.ml, * start.sh: Ditto. 2006-11-18 Nicolas Pouillard Remove List_set and List_map. * ocamlbuild_pack.mlpack: No more in the pack. * list_set.ml: Remove. * list_map.ml: Remove. * list_map.mli: Remove. * list_set.mli: Remove. * resource.ml: Use a Set. * start.sh: Adapt. 2006-11-18 Nicolas Pouillard Huge speed up, worth updating. * resource.ml, * resource.mli: Use a hash instead of map, remove the percent type. * rule.ml, * rule.mli: Remove the function for rule names. Use an exception to choose matching rules. 2006-11-18 Nicolas Pouillard Speedup rule calling. * rule.ml, * rule.mli: No more call the code rule twice to compute the digest. * ocaml_specific.ml, * ocaml_specific.mli: Adapt to Rule. * test/test8/myocamlbuild.ml: Use the exception. * test/good-output: Update. * boot: Update svn:ignore. 2006-11-16 Nicolas Pouillard Remove phony resources and include dependencies. * ocaml_specific.ml, * options.ml, * options.mli, * pathname.ml, * pathname.mli, * resource.ml, * resource.mli, * rule.ml, * rule.mli, * solver.ml, * test/test8/myocamlbuild.ml: Simplify a lot the code. 2006-11-16 Nicolas Pouillard Some improvements... * ocamlbuild.ml: . * ocamlbuild_version.ml: New. * ocamlbuild_plugin.ml: New. * ocamlbuild_version.mli: New. * ocamlbuildlib.mllib: . * ocamlbuild.sh: Remove. * ocamlbuild_pack.mlpack: New. * boot: . * ocaml_specific.ml: . * ocaml_specific.mli: . * options.ml: . * options.mli: . * rule.ml: . * rule.mli: . * start.sh: . * test/test8/a.ml: New. * test/test7/a2.ml: . * test/test7/a3.ml: New. * test/test8/myocamlbuild.ml: New. * test/test7/myocamlbuild.ml: New. * test/test8: New. * test/test8/test.sh: New. * test/runtest.sh: . * test/test7/test.sh: . * test/good-output: . * Makefile: . * _tags: . 2006-11-15 Nicolas Pouillard Add support for libraries. * ocamlbuildlib.ml: Remove. * ocamlbuildlib.mllib: New. * ocaml_specific.ml: Rules and actions for libraries. * rule.ml: Improve explanations. * start.sh: Don't make ocamlbuildlib. * test/test7/a.mli: New. * test/runtest.sh: Add test7. * test/test7/test.sh: Add reverts for a.ml. * test/good-output: Update. * Makefile: Remove junk lines. 2006-11-14 Nicolas Pouillard Add a tests for libraries. * test/test7/e.ml: New. * test/test7/d.ml: New. * test/test7/a.ml: New. * test/test7/b.ml: New. * test/test7/a2.ml: New. * test/test7/c.ml: New. * test/test7/test.sh: New. * test/test7/ablib.mllib: New. * test/test7: New. 2006-11-14 Nicolas Pouillard Simplify dependency rules. * ocaml_specific.ml: No more use bytelinkdeps... * rule.ml, * rule.mli: Add a dyndeps set. * ocamlbuild.sh, * pathname.ml, * Makefile: Update. 2006-11-14 Nicolas Pouillard Update tests... * test/test2/vivi3.ml: . * test/good-output: . 2006-11-10 Berke Durak Added -sterilize option. * hygiene.ml: ditto * hygiene.mli: ditto * ocaml_specific.ml: ditto * options.ml: ditto * options.mli: ditto 2006-11-10 Nicolas Pouillard View the context dir in first. * pathname.ml: Ditto. 2006-11-10 Berke Durak Added thread and profile tags. * ocaml_specific.ml: ditto. 2006-11-10 Berke Durak Added law for leftover dependency files. * ocaml_specific.ml: ditto. 2006-11-10 Nicolas Pouillard Reverse the ignore_auto default value. * options.ml: Add -no-skip, remove -ignore-auto, add -Is and -Xs. * test/test2/test.sh, * test/test5/test.sh, * test/test6/test.sh, * test/test4/test.sh, * test/test3/test.sh, * Makefile: Revert flags. 2006-11-10 Berke Durak Added install target to Makefile. * Makefile: . 2006-11-10 Nicolas Pouillard Deal with for-pack flags... * ocaml_arch.ml: Define a hook. * ocaml_arch.mli: Declare it. * ocaml_specific.ml: Use it. * test/test6: Ignore main.byte. 2006-11-09 Nicolas Pouillard Fix start.sh and remove dead code. * ocaml_specific.ml: Remove dead code about ignore_auto. * start.sh: Swap two modules. * test/test6/main.byte: Remove. 2006-11-09 Nicolas Pouillard Pack now works great... * ocamlbuild.sh: Use ocamlopt. * command.ml: Reset filesys cache. * my_std.ml, * my_std.mli: Add a filesys cache for case sensitive file_exists and digest over files. * ocaml_specific.ml: Work on link and packs. * ppcache.ml: Exit 2 is for unix. * pathname.ml, * resource.ml, * rule.ml, * rule.mli, * slurp.ml, * solver.ml, * solver.mli, * test/test5: Update. 2006-11-07 Nicolas Pouillard Too lazy to fill this up :). * ocamlbuild.sh, * configuration.ml, * command.ml, * debug.ml, * debug.mli, * my_std.ml, * my_std.mli, * ocaml_specific.ml, * ocaml_specific.mli, * options.ml, * options.mli, * pathname.ml, * ppcache.ml,ew. * ppcache.mli,ew. * pathname.mli, * resource.ml, * resource.mli, * rule.ml, * rule.mli, * slurp.ml, * solver.ml, * solver.mli, * slurp.mli, * start.sh, * tags.ml, * test/test5/test.sh, * test/test4/test.sh, * test/test3/test.sh, * test/good-output, * test/test2/test.sh, * test/test6/test.sh, * Makefile, * _tags: This too. 2006-11-04 Nicolas Pouillard Some pack,dirs stuffs. * ocamlbuild.ml, * ocamlbuildlib.ml,ew. * ocamlbuild.sh,ew. * configuration.ml, * my_std.ml, * my_std.mli, * ocaml_arch.ml,ew. * ocaml_specific.ml, * ocaml_specific.mli, * ocaml_arch.mli,ew. * options.ml, * options.mli, * pathname.ml, * pathname.mli, * resource.ml, * resource.mli, * rule.ml, * solver.ml, * test/good-output, * Makefile, * _tags: That's it. 2006-10-31 Nicolas Pouillard Remove the dirty thing about cmi's. * ocaml_specific.ml, * ocaml_specific.mli: Moves of files are no more needed. * test/good-output: Update. 2006-10-31 Nicolas Pouillard Some renaming and cleanup... * ocamlbuild.ml, * configuration.ml, * configuration.mli, * list_set.ml, * ocaml_specific.ml, * resource.ml, * test/good-output, * test/test6/test.sh: Do that. 2006-10-31 Nicolas Pouillard Use the nothing-should-be-rebuilt for tests and update the output. * test/test2, * test/test2/test.sh, * test/test3/test.sh, * test/test4/test.sh, * test/test5/test.sh, * test/test6/test.sh, * test/good-output: Do that. 2006-10-31 Nicolas Pouillard Add a mode usefull for tests. * options.ml, options.mli, rule.ml: This new mode fails when something needs to be rebuilt. 2006-10-31 Nicolas Pouillard Improve the ocaml rule set. * ocaml_specific.ml: Yipee! 2006-10-31 Nicolas Pouillard Add scripts to run tests. * test/test2/vivi1.ml: New. * test/test2/vivi2.ml: New. * test/test2/vivi3.ml: New. * test/test2/vivi.ml: . * test/test4/test.sh: New. * test/test5/test.sh: New. * test/test2/test.sh: New. * test/test6/test.sh: . * test/good-output: New. * test/test3/test.sh: New. * test/runtest.sh: New. 2006-10-31 Nicolas Pouillard Restore some recursivity for includes. * resource.ml, * resource.mli: Remove the digest field. * rule.ml: . * test/test6/test.sh: . 2006-10-30 Nicolas Pouillard Remove the arbitrary deep dependencies. * ocaml_specific.ml, * ocaml_specific.mli: No more implicit transitives deps. * resource.ml, * resource.mli: Remove as many things as possible. * rule.ml, * rule.mli, * solver.ml: Simplify. * command.ml: Fix newlines and flush. 2006-10-30 Nicolas Pouillard Separated preprocessing, total order over rules... * ocamlbuild.ml, * my_std.ml, * my_std.mli, * ocaml_specific.ml, * ocaml_specific.mli, * options.ml, * options.mli, * pathname.ml, * pathname.mli, * resource.ml, * resource.mli, * rule.ml, * rule.mli, * solver.ml, * test/test2/tutu.ml, * tags.ml, * test/test2/tyty.mli,ew. * test/test6/test.sh, * test/test6, * test/test5/_tags, * test/test5: Update. 2006-10-27 Nicolas Pouillard Add options: -ocamlc,-ocamlopt,-ocamldep,-ocamlyacc,-ocamllex. * options.ml, * options.mli: Declare them. * ocaml_specific.ml: Use them. 2006-10-27 Nicolas Pouillard Fix start.sh. * start.sh: Fix the output. 2006-10-27 Nicolas Pouillard Regen start.sh. * start.sh: Regen. 2006-10-27 Nicolas Pouillard Use the list based implems and fix many bugs. * ocamlbuild.ml: Rename some dependency files. * boot: Ignore boot/ocamlbuild.byte.save.* files. * command.ml: Fix command printing. * my_std.ml, * my_std.mli: Add List.equal, use the cp command in Shell.cp. * ocaml_specific.ml, * ocaml_specific.mli: Many things. * pathname.ml, pathname.mli: Make compare obselete prefer equal. * resource.ml, resource.mli: Add print_cache and use list based sets and maps. * Makefile: Add the bootstrap rule. 2006-10-27 Nicolas Pouillard Add a test for fine-grained dependencies. * test/test6/main.ml: New. * test/test6/d.ml: New. * test/test6/b.ml: New. * test/test6/a.ml: New. * test/test6/main.mli: New. * test/test6/a.mli: New. * test/test6/d.mli: New. * test/test6/b.mli: New. * test/test6/b.mli.v2: New. * test/test6/main.byte: New. * test/test6/d.mli.v1: New. * test/test6/test.sh: New. * test/test6/d.mli.v2: New. * test/test6/b.mli.v1: New. * test/test6: New. 2006-10-26 Nicolas Pouillard Dummy implementations for set and map using lists. The main advantage is to only rely on the equal function that is simpler to maintain correct in an imperative setting. * list_map.ml: New. * list_set.ml: New. * list_map.mli: New. * list_set.mli: New. 2006-10-24 Nicolas Pouillard Fixes and improvment. * ocamlbuild.ml, * my_std.ml, * my_std.mli, * ocaml_specific.ml, * ocaml_specific.mli, * pathname.ml, * resource.ml, * rule.ml, * rule.mli, * solver.ml, * solver.mli: The previous version was somwhat unstable. 2006-10-24 Nicolas Pouillard Many things... * ocamlbuild.ml, * command.ml, * command.mli, * ocaml_specific.ml, * ocaml_specific.mli, * options.ml, * options.mli, * resource.ml, * resource.mli, * rule.ml, * rule.mli, * solver.ml, * solver.mli: Simplify the whole solver by removing the value type. Rule code now returns a resource set, that is injected as dependencies. So rule code always returns unit. But can raise exceptions. Add -ignore, and -ignore-auto options to workaround ocamldep approximations without igonring errors. * Makefile: Add backup and restore targets. 2006-10-23 Nicolas Pouillard Compute digests of dependencies recursively. * ocamlbuild.ml, * ocaml_specific.ml, * options.ml, * options.mli, * resource.ml, * resource.mli, * rule.ml: Ditto. 2006-10-23 Nicolas Pouillard One step toward a parallelisable system. * boot, * command.ml, * ocaml_specific.ml, * ocaml_specific.mli, * options.ml, * options.mli, * rule.ml, * rule.mli, * solver.ml: Update. * value.ml: Remove. * value.mli: Remove. 2006-10-20 Nicolas Pouillard Add vcs config file to setup a good default setup. * .vcs: New. 2006-10-20 Nicolas Pouillard Simplify the bootstrap by introducing a shell script. * boot/ocamlbuild.byte: Remove. Useless in distribution mode but will be created, the first time. So the devel is not disturbed. * start.sh: New. * Makefile: Remove the old one to use start.sh. 2006-10-20 Nicolas Pouillard Take command line in account for the digest computation. * command.ml, * command.mli, * debug.ml, * ocaml_specific.ml, * ocaml_specific.mli, * resource.ml, * resource.mli, * rule.ml, * rule.mli, * solver.ml, * value.ml, * value.mli: Update. 2006-10-19 Nicolas Pouillard New pathname representation. * pathname.ml, pathname.mli: This new representation should avoids "fix" problems. 2006-10-17 Nicolas Pouillard Change the cache implem -> now really fast at link time. * ocamlbuild.ml, * boot/ocamlbuild.byte, * my_std.ml, * ocaml_specific.ml, * pathname.ml, * resource.ml, * resource.mli, * solver.ml: By replacing various sets by a map of records and remember that something has not changed, or cannot be built; there is a real speedup. In particular to detect that the link is not necessary to do. 2006-10-17 Nicolas Pouillard Add a basic support for a digest based cache verification. * resource.ml, resource.mli: Add have_digest and store_digest. * rule.ml: Use these digests but don't include the command for now. * test/test2/vivi.ml, test/test2/tata.mli: Dummy updates. 2006-10-16 Nicolas Pouillard Split in many files. * ocamlbuild.ml: Splitted. * boot/ocamlbuild.byte: Updated. * configuration.ml: New. * configuration.mli: New. * command.ml: New. * command.mli: New. * debug.ml: New. * debug.mli: New. * flags.ml: New. * flags.mli: New. * my_std.ml: New. * my_std.mli: New. * ocaml_specific.ml: New. * ocaml_specific.mli: New. * options.ml: New. * options.mli: New. * pathname.ml: New. * pathname.mli: New. * re.ml: New. * re.mli: New. * resource.ml: New. * resource.mli: New. * rule.ml: New. * rule.mli: New. * solver.ml: New. * solver.mli: New. * test/test5/d.ml: New. * tags.ml: New. * test/test5/b.ml: New. * test/test5/a.ml: New. * tags.mli: New. * test/test5/a.mli: New. * test/test5/c.mlpack: New. * test/test5/_tags: New. * test/test5: New. * value.ml: New. * value.mli: New. * Makefile: . 2006-10-16 Berke Durak Various useful changes. * ocamlbuild.ml: Hygiene to true. * slurp.ml: Remove debugging * Makefile: Clean annot and object files. 2006-10-15 Nicolas Pouillard Bootstrap it ;). * ocamlbuild.ml: Add support for -g, -dtypes, and -rectypes in four lines. * _tags: New. Specify how to build ocamlbuild itself. * boot: New. * boot/ocamlbuild.byte: New. A bytecode version needed to bootstrap * Makefile: By default make it a wrapper over ocamlbuild in boot. 2006-10-15 Nicolas Pouillard Little fix... * ocamlbuild.ml: Don't assoc over pathnames since the default compare is wrong and slow use the string repr. 2006-10-15 Nicolas Pouillard Allow to control flags, and libraries by tags. * ocamlbuild.ml: In the _tags file you can add or remove flags using a colon flag_name:flag_value. * test/test2/vivi.ml, * test/test3/f.ml, * test/test4/b/bb.ml: Dummy updates. * test/test3/_tags: New. * test/test4/_tags: New. 2006-10-15 Nicolas Pouillard Add a tag based flag system. * test/test2/vivi.ml: An example. * test/test2/_tags: New. * ocamlbuild.ml: Now a command can request for flags by giving a set of tags these tags include file specific tags this allow to tweak flags by just providing a _tags file. 2006-10-15 Nicolas Pouillard Add -lib,-libs options remove -P. * ocamlbuild.ml: -P Is useless due to the fact that we now have the same directory structure in the _build directory. Add -lib,-libs that allows one to specify -lib unix without its extension in order to request for native and byte compilations. 2006-10-15 Nicolas Pouillard Multi directories now works ;). * ocamlbuild.ml: Solve the whole problem by improving the Pathname module. Pathnames are now symbolic values that can include variable names. These variable names represent still ambiguous pathnames /a/b/(c|d as x1)/e.ml but variables can be shared, so discovering that /a/b/(c|d as x1)/e.ml is in fact /a/b/c/e.ml will make /a/b/(c|d as x1)/e.cmo automatically take this value /a/b/c/e.cmo cause it shares the x1 variable. 2006-10-13 Nicolas Pouillard I prefer capitalized names. * AUTHORS 2006-10-13 Berke Durak Added an AUTHORS file. * AUTHORS: New. 2006-10-13 Nicolas Pouillard Add the vcs dir. * vcs: New. * vcs/ocamlbuild.rb: New. 2006-10-13 Nicolas Pouillard * ocamlbuild.ml: Restore dependencies. 2006-10-13 Nicolas Pouillard Fix the makefile. * Makefile, discard_printf.ml: Ditto. 2006-10-13 Nicolas Pouillard Improve the directory handling. * ocamlbuild.ml: Ditto, but there is still a problem with native. * Makefile: Update. 2006-10-11 Nicolas Pouillard Fix native dependencies. * ocamlbuild.ml: By default due to inlining the cmx dependencies are needed to build a cmx. * Makefile: Add native support. 2006-10-11 Nicolas Pouillard Use phony for linkdeps. * ocamlbuild.ml: Ditto. 2006-10-11 Nicolas Pouillard Fix exit on multiple targets. * ocamlbuild.ml: Ditto. 2006-10-11 Nicolas Pouillard More flags -lflags,-lflag... * ocamlbuild.ml: Add plrual form options for those that use comma separated lists. 2006-10-11 Nicolas Pouillard Use phony resources for .cmo.linkdeps. * ocamlbuild.ml: Also restore the command running if "--" is specified 2006-10-11 Nicolas Pouillard Remove Include_string_list resources, add Phony resources. * ocamlbuild.ml: Also fix some rules. 2006-10-11 Nicolas Pouillard Shift debug levels. * ocamlbuild.ml: Add -quiet. 2006-10-11 Nicolas Pouillard Use str more intensively. * ocamlbuild.ml: Also clean up useless functions. 2006-10-11 Nicolas Pouillard Fix link dependencies. * ocamlbuild.ml: Force to consider recursivly Include_ tagged resources for their full contents. Alas it takes more time to know if we need to recompute the link. * test/test2/vivi.ml: Update. 2006-10-10 Nicolas Pouillard Support multiple directories, it can compile the OCaml compiler :). * ocamlbuild.ml: Add directory handling but also start the tags config files handling. * Makefile: Use str.cma. 2006-10-08 Nicolas Pouillard Add library support. * ocamlbuild.ml: Deduce basic set of tags form the target extension. 2006-10-08 Nicolas Pouillard More customisable flags, and cycle detection. * ocamlbuild.ml: Add some flags -lflag, -ppflag, -cflag, --. Also add a detection mechanism for dependencies. * discard_printf.ml, Makefile: Update. mingw-ocaml/ocaml/ocamlbuild/display.ml0000644000175000017500000002733112124403240017575 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Display *) open My_std;; open My_unix;; let fp = Printf.fprintf;; (*** ANSI *) module ANSI = struct let up oc n = fp oc "\027[%dA" n;; let clear_to_eol oc () = fp oc "\027[K";; let bol oc () = fp oc "\r";; let get_columns () = if Sys.os_type = "Unix" then try int_of_string (String.chomp (My_unix.run_and_read "tput cols")) with | Failure _ -> 80 else 80 end ;; (* ***) (*** tagline_description *) type tagline_description = (string * char) list;; (* ***) (*** sophisticated_display *) type sophisticated_display = { ds_channel : out_channel; (** Channel for writing *) ds_start_time : float; (** When was compilation started *) mutable ds_last_update : float; (** When was the display last updated *) mutable ds_last_target : string; (** Last target built *) mutable ds_last_cached : bool; (** Was the last target cached or really built ? *) mutable ds_last_tags : Tags.t; (** Tags of the last command *) mutable ds_changed : bool; (** Does the tag line need recomputing ? *) ds_update_interval : float; (** Minimum interval between updates *) ds_columns : int; (** Number of columns in dssplay *) mutable ds_jobs : int; (** Number of jobs launched or cached *) mutable ds_jobs_cached : int; (** Number of jobs cached *) ds_tagline : string; (** Current tagline *) mutable ds_seen_tags : Tags.t; (** Tags that we have encountered *) ds_pathname_length : int; (** How much space for displaying pathnames ? *) ds_tld : tagline_description; (** Description for the tagline *) };; (* ***) (*** display_line, display *) type display_line = | Classic | Sophisticated of sophisticated_display type display = { di_log_level : int; mutable di_log_channel : (Format.formatter * out_channel) option; di_channel : out_channel; di_formatter : Format.formatter; di_display_line : display_line; mutable di_finished : bool; } ;; (* ***) (*** various defaults *) let default_update_interval = 0.05;; let default_tagline_description = [ "ocaml", 'O'; "native", 'N'; "byte", 'B'; "program", 'P'; "pp", 'R'; "debug", 'D'; "interf", 'I'; "link", 'L'; ];; (* NOT including spaces *) let countdown_chars = 8;; let jobs_chars = 3;; let jobs_cached_chars = 5;; let dots = "...";; let start_target = "STARTING";; let finish_target = "FINISHED";; let ticker_chars = 3;; let ticker_period = 0.25;; let ticker_animation = [| "\\"; "|"; "/"; "-"; |];; let cached = "*";; let uncached = " ";; let cache_chars = 1;; (* ***) (*** create_tagline *) let create_tagline description = String.make (List.length description) '-';; (* ***) (*** create *) let create ?(channel=stdout) ?(mode:[`Classic|`Sophisticated] = `Sophisticated) ?columns:(_columns=75) ?(description = default_tagline_description) ?log_file ?(log_level=1) () = let log_channel = match log_file with | None -> None | Some fn -> let oc = open_out_gen [Open_text; Open_wronly; Open_creat; Open_trunc] 0o666 fn in let f = Format.formatter_of_out_channel oc in Format.fprintf f "### Starting build.\n"; Some (f, oc) in let display_line = match mode with | `Classic -> Classic | `Sophisticated -> (* We assume Unix is not degraded. *) let n = ANSI.get_columns () in let tag_chars = List.length description in Sophisticated { ds_channel = stdout; ds_start_time = gettimeofday (); ds_last_update = 0.0; ds_last_target = start_target; ds_last_tags = Tags.empty; ds_last_cached = false; ds_changed = false; ds_update_interval = default_update_interval; ds_columns = n; ds_jobs = 0; ds_jobs_cached = 0; ds_tagline = create_tagline description; ds_seen_tags = Tags.empty; ds_pathname_length = n - (countdown_chars + 1 + jobs_chars + 1 + jobs_cached_chars + 1 + cache_chars + 1 + tag_chars + 1 + ticker_chars + 2); ds_tld = description } in { di_log_level = log_level; di_log_channel = log_channel; di_channel = channel; di_formatter = Format.formatter_of_out_channel channel; di_display_line = display_line; di_finished = false } ;; (* ***) (*** print_time *) let print_time oc t = let t = int_of_float t in let s = t mod 60 in let m = (t / 60) mod 60 in let h = t / 3600 in fp oc "%02d:%02d:%02d" h m s ;; (* ***) (*** print_shortened_pathname *) let print_shortened_pathname length oc u = assert(length >= 3); let m = String.length u in if m <= length then begin output_string oc u; fp oc "%*s" (length - m) "" end else begin let n = String.length dots in let k = length - n in output_string oc dots; output oc u (m - k) k; end (* ***) (*** Layout 00000000001111111111222222222233333333334444444444555555555566666666667777777777 01234567890123456789012345678901234567890123456789012345678901234567890123456789 HH MM SS XXXX PATHNAME 00:12:31 32 ( 26) ...lp4Filters/Camlp4LocationStripper.cmo * OBn------------- | | | | | \ tags | | | \ last target built \ cached ? | | | | | \ number of jobs cached | \ number of jobs \ elapsed time cmo mllib ***) (*** redraw_sophisticated *) let redraw_sophisticated ds = let t = gettimeofday () in let oc = ds.ds_channel in let dt = t -. ds.ds_start_time in ds.ds_last_update <- t; fp oc "%a" ANSI.bol (); let ticker_phase = (abs (int_of_float (ceil (dt /. ticker_period)))) mod (Array.length ticker_animation) in let ticker = ticker_animation.(ticker_phase) in fp oc "%a %-4d (%-4d) %a %s %s %s" print_time dt ds.ds_jobs ds.ds_jobs_cached (print_shortened_pathname ds.ds_pathname_length) ds.ds_last_target (if ds.ds_last_cached then cached else uncached) ds.ds_tagline ticker; fp oc "%a%!" ANSI.clear_to_eol () ;; (* ***) (*** redraw *) let redraw = function | Classic -> () | Sophisticated ds -> redraw_sophisticated ds ;; (* ***) (*** finish_sophisticated *) let finish_sophisticated ?(how=`Success) ds = let t = gettimeofday () in let oc = ds.ds_channel in let dt = t -. ds.ds_start_time in match how with | `Success|`Error -> fp oc "%a" ANSI.bol (); fp oc "%s %d target%s (%d cached) in %a." (if how = `Error then "Compilation unsuccessful after building" else "Finished,") ds.ds_jobs (if ds.ds_jobs = 1 then "" else "s") ds.ds_jobs_cached print_time dt; fp oc "%a\n%!" ANSI.clear_to_eol () | `Quiet -> fp oc "%a%a%!" ANSI.bol () ANSI.clear_to_eol (); ;; (* ***) (*** sophisticated_display *) let sophisticated_display ds f = fp ds.ds_channel "%a%a%!" ANSI.bol () ANSI.clear_to_eol (); f ds.ds_channel ;; (* ***) (*** call_if *) let call_if log_channel f = match log_channel with | None -> () | Some x -> f x ;; (* ***) (*** display *) let display di f = call_if di.di_log_channel (fun (_, oc) -> f oc); match di.di_display_line with | Classic -> f di.di_channel | Sophisticated ds -> sophisticated_display ds f ;; (* ***) (*** finish *) let finish ?(how=`Success) di = if not di.di_finished then begin di.di_finished <- true; call_if di.di_log_channel begin fun (fmt, oc) -> Format.fprintf fmt "# Compilation %ssuccessful.@." (if how = `Error then "un" else ""); close_out oc; di.di_log_channel <- None end; match di.di_display_line with | Classic -> () | Sophisticated ds -> finish_sophisticated ~how ds end ;; (* ***) (*** update_tagline_from_tags *) let update_tagline_from_tags ds = let tagline = ds.ds_tagline in let tags = ds.ds_last_tags in let rec loop i = function | [] -> for j = i to String.length tagline - 1 do tagline.[j] <- '-' done | (tag, c) :: rest -> if Tags.mem tag tags then tagline.[i] <- Char.uppercase c else if Tags.mem tag ds.ds_seen_tags then tagline.[i] <- Char.lowercase c else tagline.[i] <- '-'; loop (i + 1) rest in loop 0 ds.ds_tld; ;; (* ***) (*** update_sophisticated *) let update_sophisticated ds = let t = gettimeofday () in let dt = t -. ds.ds_last_update in if dt > ds.ds_update_interval then begin if ds.ds_changed then begin update_tagline_from_tags ds; ds.ds_changed <- false end; redraw_sophisticated ds end else () ;; (* ***) (*** set_target_sophisticated *) let set_target_sophisticated ds target tags cached = ds.ds_changed <- true; ds.ds_last_target <- target; ds.ds_last_tags <- tags; ds.ds_jobs <- 1 + ds.ds_jobs; if cached then ds.ds_jobs_cached <- 1 + ds.ds_jobs_cached; ds.ds_last_cached <- cached; ds.ds_seen_tags <- Tags.union ds.ds_seen_tags ds.ds_last_tags; update_sophisticated ds ;; let print_tags f tags = let first = ref true in Tags.iter begin fun tag -> if !first then begin first := false; Format.fprintf f "%s" tag end else Format.fprintf f ", %s" tag end tags ;; (* ***) (*** update *) let update di = match di.di_display_line with | Classic -> () | Sophisticated ds -> update_sophisticated ds ;; (* ***) (*** event *) let event di ?(pretend=false) command target tags = call_if di.di_log_channel (fun (fmt, _) -> Format.fprintf fmt "# Target: %s, tags: { %a }\n" target print_tags tags; Format.fprintf fmt "%s%s@." command (if pretend then " # cached" else "")); match di.di_display_line with | Classic -> if pretend then (if di.di_log_level >= 2 then Format.fprintf di.di_formatter "[cache hit] %s\n%!" command) else (if di.di_log_level >= 1 then Format.fprintf di.di_formatter "%s\n%!" command) | Sophisticated ds -> set_target_sophisticated ds target tags pretend; update_sophisticated ds ;; (* ***) (*** dprintf *) let dprintf ?(log_level=1) di fmt = if log_level > di.di_log_level then Discard_printf.discard_printf fmt else match di.di_display_line with | Classic -> Format.fprintf di.di_formatter fmt | Sophisticated _ -> if log_level < 0 then begin display di ignore; Format.fprintf di.di_formatter fmt end else match di.di_log_channel with | Some (f, _) -> Format.fprintf f fmt | None -> Discard_printf.discard_printf fmt (* ***) mingw-ocaml/ocaml/ocamlbuild/exit_codes.mli0000644000175000017500000000261012124403240020420 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) val rc_ok : int val rc_usage : int val rc_failure : int val rc_invalid_argument : int val rc_system_error : int val rc_hygiene : int val rc_circularity : int val rc_solver_failed : int val rc_ocamldep_error : int val rc_lexing_error : int val rc_build_error : int val rc_executor_subcommand_failed : int val rc_executor_subcommand_got_signal : int val rc_executor_io_error : int val rc_executor_excetptional_condition : int mingw-ocaml/ocaml/ocamlbuild/lexers.mll0000644000175000017500000001603712124403240017607 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) { exception Error of string open Glob_ast type conf_values = { plus_tags : string list; minus_tags : string list } type conf = (Glob.globber * conf_values) list let empty = { plus_tags = []; minus_tags = [] } } let newline = ('\n' | '\r' | "\r\n") let space = [' ' '\t' '\012'] let space_or_esc_nl = (space | '\\' newline) let blank = newline | space let not_blank = [^' ' '\t' '\012' '\n' '\r'] let not_space_nor_comma = [^' ' '\t' '\012' ','] let not_newline = [^ '\n' '\r' ] let not_newline_nor_colon = [^ '\n' '\r' ':' ] let normal_flag_value = [^ '(' ')' '\n' '\r'] let normal = [^ ':' ',' '(' ')' ''' ' ' '\n' '\r'] let tag = normal+ | ( normal+ ':' normal+ ) | normal+ '(' [^ ')' ]* ')' let variable = [ 'a'-'z' 'A'-'Z' '_' '-' '0'-'9' ]* let pattern = ([^ '(' ')' '\\' ] | '\\' [ '(' ')' ])* rule ocamldep_output = parse | ([^ ':' '\n' '\r' ]+ as k) ':' { let x = (k, space_sep_strings_nl lexbuf) in x :: ocamldep_output lexbuf } | eof { [] } | _ { raise (Error "Expecting colon followed by space-separated module name list") } and space_sep_strings_nl = parse | space* (not_blank+ as word) { word :: space_sep_strings_nl lexbuf } | space* newline { [] } | _ { raise (Error "Expecting space-separated strings terminated with newline") } and space_sep_strings = parse | space* (not_blank+ as word) { word :: space_sep_strings lexbuf } | space* newline? eof { [] } | _ { raise (Error "Expecting space-separated strings") } and blank_sep_strings = parse | blank* '#' not_newline* newline { blank_sep_strings lexbuf } | blank* '#' not_newline* eof { [] } | blank* (not_blank+ as word) { word :: blank_sep_strings lexbuf } | blank* eof { [] } | _ { raise (Error "Expecting blank-separated strings") } and comma_sep_strings = parse | space* (not_space_nor_comma+ as word) space* eof { [word] } | space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf } | space* eof { [] } | _ { raise (Error "Expecting comma-separated strings (1)") } and comma_sep_strings_aux = parse | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf } | space* eof { [] } | _ { raise (Error "Expecting comma-separated strings (2)") } and comma_or_blank_sep_strings = parse | space* (not_space_nor_comma+ as word) space* eof { [word] } | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } | space* eof { [] } | _ { raise (Error "Expecting (comma|blank)-separated strings (1)") } and comma_or_blank_sep_strings_aux = parse | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } | space* eof { [] } | _ { raise (Error "Expecting (comma|blank)-separated strings (2)") } and parse_environment_path_w = parse | ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf } | ';' ([^ ';']* as word) { "" :: word :: parse_environment_path_aux_w lexbuf } | eof { [] } and parse_environment_path_aux_w = parse | ';' ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf } | eof { [] } | _ { raise (Error "Impossible: expecting colon-separated strings") } and parse_environment_path = parse | ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf } | ':' ([^ ':']* as word) { "" :: word :: parse_environment_path_aux lexbuf } | eof { [] } and parse_environment_path_aux = parse | ':' ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf } | eof { [] } | _ { raise (Error "Impossible: expecting colon-separated strings") } and conf_lines dir pos err = parse | space* '#' not_newline* newline { conf_lines dir (pos + 1) err lexbuf } | space* '#' not_newline* eof { [] } | space* newline { conf_lines dir (pos + 1) err lexbuf } | space* eof { [] } | space* (not_newline_nor_colon+ as k) space* ':' space* { let bexpr = Glob.parse ?dir k in let v1 = conf_value pos err empty lexbuf in let v2 = conf_values pos err v1 lexbuf in let rest = conf_lines dir (pos + 1) err lexbuf in (bexpr, v2) :: rest } | _ { raise (Error(Printf.sprintf "Bad key in configuration line at line %d (from %s)" pos err)) } and conf_value pos err x = parse | '-' (tag as tag) { { (x) with minus_tags = tag :: x.minus_tags } } | '+'? (tag as tag) { { (x) with plus_tags = tag :: x.plus_tags } } | (_ | eof) { raise (Error(Printf.sprintf "Bad value in configuration line at line %d (from %s)" pos err)) } and conf_values pos err x = parse | space_or_esc_nl* ',' space_or_esc_nl* { conf_values pos err (conf_value pos err x lexbuf) lexbuf } | (newline | eof) { x } | (_ | eof) { raise (Error(Printf.sprintf "Bad values in configuration line at line %d (from %s)" pos err)) } and path_scheme patt_allowed = parse | ([^ '%' ]+ as prefix) { `Word prefix :: path_scheme patt_allowed lexbuf } | "%(" (variable as var) ')' { `Var (var, Bool.True) :: path_scheme patt_allowed lexbuf } | "%(" (variable as var) ':' (pattern as patt) ')' { if patt_allowed then let patt = My_std.String.implode (unescape (Lexing.from_string patt)) in `Var (var, Glob.parse patt) :: path_scheme patt_allowed lexbuf else raise (Error( Printf.sprintf "Patterns are not allowed in this pathname (%%(%s:%s) only in ~prod)" var patt)) } | '%' { `Var ("", Bool.True) :: path_scheme patt_allowed lexbuf } | eof { [] } | _ { raise (Error("Bad pathanme scheme")) } and unescape = parse | '\\' (['(' ')'] as c) { c :: unescape lexbuf } | _ as c { c :: unescape lexbuf } | eof { [] } and ocamlfind_query = parse | newline* "package:" space* (not_newline* as n) newline+ "description:" space* (not_newline* as d) newline+ "version:" space* (not_newline* as v) newline+ "archive(s):" space* (not_newline* as a) newline+ "linkopts:" space* (not_newline* as lo) newline+ "location:" space* (not_newline* as l) newline+ { n, d, v, a, lo, l } | _ { raise (Error "Bad ocamlfind query") } and trim_blanks = parse | blank* (not_blank* as word) blank* { word } | _ { raise (Error "Bad input for trim_blanks") } and tag_gen = parse | (normal+ as name) ('(' ([^')']* as param) ')')? { name, param } mingw-ocaml/ocaml/ocamlbuild/lexers.mli0000644000175000017500000000367412124403240017607 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) exception Error of string type conf_values = { plus_tags : string list; minus_tags : string list } type conf = (Glob.globber * conf_values) list val ocamldep_output : Lexing.lexbuf -> (string * string list) list val space_sep_strings : Lexing.lexbuf -> string list val blank_sep_strings : Lexing.lexbuf -> string list val comma_sep_strings : Lexing.lexbuf -> string list val comma_or_blank_sep_strings : Lexing.lexbuf -> string list val trim_blanks : Lexing.lexbuf -> string (* Parse an environment path (i.e. $PATH). This is a colon separated string. Note: successive colons means an empty string. Example: ":aaa:bbb:::ccc:" -> [""; "aaa"; "bbb"; ""; ""; "ccc"; ""] *) val parse_environment_path : Lexing.lexbuf -> string list (* Same one, for Windows (PATH is ;-separated) *) val parse_environment_path_w : Lexing.lexbuf -> string list val conf_lines : string option -> int -> string -> Lexing.lexbuf -> conf val path_scheme : bool -> Lexing.lexbuf -> [ `Word of string | `Var of (string * Glob.globber) ] list val ocamlfind_query : Lexing.lexbuf -> string * string * string * string * string * string val tag_gen : Lexing.lexbuf -> string * string option mingw-ocaml/ocaml/ocamlbuild/glob_lexer.mli0000644000175000017500000000162412124403240020420 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) open Glob_ast type token = | ATOM of pattern atom | AND | OR | NOT | LPAR | RPAR | TRUE | FALSE | EOF val token : Lexing.lexbuf -> token mingw-ocaml/ocaml/ocamlbuild/ocaml_specific.ml0000644000175000017500000005034512124403240021071 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Format open Log open Pathname.Operators open Tags.Operators open Rule open Tools open Rule.Common_commands open Outcome open Command;; open Ocaml_utils module C_tools = struct let link_C_library clib a libname env build = let clib = env clib and a = env a and libname = env libname in let objs = string_list_of_file clib in let include_dirs = Pathname.include_dirs_of (Pathname.dirname a) in let obj_of_o x = if Filename.check_suffix x ".o" && !Options.ext_obj <> "o" then Pathname.update_extension !Options.ext_obj x else x in let resluts = build (List.map (fun o -> List.map (fun dir -> dir / obj_of_o o) include_dirs) objs) in let objs = List.map begin function | Good o -> o | Bad exn -> raise exn end resluts in Cmd(S[!Options.ocamlmklib; A"-o"; Px libname; T(tags_of_pathname a++"c"++"ocamlmklib"); atomize objs]);; end open Flags open Command open Rule let init () = let module M = struct let ext_lib = !Options.ext_lib;; let ext_obj = !Options.ext_obj;; let ext_dll = !Options.ext_dll;; let x_o = "%"-.-ext_obj;; let x_a = "%"-.-ext_lib;; let x_dll = "%"-.-ext_dll;; let x_p_o = "%.p"-.-ext_obj;; let x_p_a = "%.p"-.-ext_lib;; let x_p_dll = "%.p"-.-ext_dll;; rule "target files" ~dep:"%.itarget" ~stamp:"%.otarget" begin fun env build -> let itarget = env "%.itarget" in let dir = Pathname.dirname itarget in let targets = string_list_of_file itarget in List.iter ignore_good (build (List.map (fun x -> [dir/x]) targets)); if !Options.make_links then let link x = Cmd (S [A"ln"; A"-sf"; P (!Options.build_dir/x); A Pathname.parent_dir_name]) in Seq (List.map (fun x -> link (dir/x)) targets) else Nop end;; rule "ocaml: mli -> cmi" ~tags:["ocaml"] ~prod:"%.cmi" ~deps:["%.mli"; "%.mli.depends"] (Ocaml_compiler.byte_compile_ocaml_interf "%.mli" "%.cmi");; rule "ocaml: mlpack & d.cmo* -> d.cmo & cmi" ~tags:["ocaml"; "debug"; "byte"] ~prods:["%.d.cmo"] ~deps:["%.mlpack"; "%.cmi"] (Ocaml_compiler.byte_debug_pack_mlpack "%.mlpack" "%.d.cmo");; rule "ocaml: mlpack & cmo* & cmi -> cmo" ~tags:["ocaml"; "byte"] ~prod:"%.cmo" ~deps:["%.mli"; "%.cmi"; "%.mlpack"] (Ocaml_compiler.byte_pack_mlpack "%.mlpack" "%.cmo");; rule "ocaml: mlpack & cmo* -> cmo & cmi" ~tags:["ocaml"; "byte"] ~prods:["%.cmo"; "%.cmi"] ~dep:"%.mlpack" (Ocaml_compiler.byte_pack_mlpack "%.mlpack" "%.cmo");; rule "ocaml: ml & cmi -> d.cmo" ~tags:["ocaml"; "byte"] ~prod:"%.d.cmo" ~deps:["%.mli"(* This one is inserted to force this rule to be skiped when a .ml is provided without a .mli *); "%.ml"; "%.ml.depends"; "%.cmi"] (Ocaml_compiler.byte_compile_ocaml_implem ~tag:"debug" "%.ml" "%.d.cmo");; rule "ocaml: ml & cmi -> cmo" ~tags:["ocaml"; "byte"] ~prod:"%.cmo" ~deps:["%.mli"(* This one is inserted to force this rule to be skiped when a .ml is provided without a .mli *); "%.ml"; "%.ml.depends"; "%.cmi"] (Ocaml_compiler.byte_compile_ocaml_implem "%.ml" "%.cmo");; rule "ocaml: mlpack & cmi & p.cmx* & p.o* -> p.cmx & p.o" ~tags:["ocaml"; "profile"; "native"] ~prods:["%.p.cmx"; x_p_o(* no cmi here you must make the byte version to have it *)] ~deps:["%.mlpack"; "%.cmi"] (Ocaml_compiler.native_profile_pack_mlpack "%.mlpack" "%.p.cmx");; rule "ocaml: mlpack & cmi & cmx* & o* -> cmx & o" ~tags:["ocaml"; "native"] ~prods:["%.cmx"; x_o(* no cmi here you must make the byte version to have it *)] ~deps:["%.mlpack"; "%.cmi"] (Ocaml_compiler.native_pack_mlpack "%.mlpack" "%.cmx");; rule "ocaml: ml & cmi -> p.cmx & p.o" ~tags:["ocaml"; "native"; "profile"] ~prods:["%.p.cmx"; x_p_o] ~deps:["%.ml"; "%.ml.depends"; "%.cmi"] (Ocaml_compiler.native_compile_ocaml_implem ~tag:"profile" ~cmx_ext:"p.cmx" "%.ml");; rule "ocaml: ml & cmi -> cmx & o" ~tags:["ocaml"; "native"] ~prods:["%.cmx"; x_o] ~deps:["%.ml"; "%.ml.depends"; "%.cmi"] (Ocaml_compiler.native_compile_ocaml_implem "%.ml");; rule "ocaml: ml -> d.cmo & cmi" ~tags:["ocaml"; "debug"] ~prods:["%.d.cmo"] ~deps:["%.ml"; "%.ml.depends"; "%.cmi"] (Ocaml_compiler.byte_compile_ocaml_implem ~tag:"debug" "%.ml" "%.d.cmo");; rule "ocaml: ml -> cmo & cmi" ~tags:["ocaml"] ~prods:["%.cmo"; "%.cmi"] ~deps:["%.ml"; "%.ml.depends"] (Ocaml_compiler.byte_compile_ocaml_implem "%.ml" "%.cmo");; rule "ocaml: d.cmo* -> d.byte" ~tags:["ocaml"; "byte"; "debug"; "program"] ~prod:"%.d.byte" ~dep:"%.d.cmo" (Ocaml_compiler.byte_debug_link "%.d.cmo" "%.d.byte");; rule "ocaml: cmo* -> byte" ~tags:["ocaml"; "byte"; "program"] ~prod:"%.byte" ~dep:"%.cmo" (Ocaml_compiler.byte_link "%.cmo" "%.byte");; rule "ocaml: p.cmx* & p.o* -> p.native" ~tags:["ocaml"; "native"; "profile"; "program"] ~prod:"%.p.native" ~deps:["%.p.cmx"; x_p_o] (Ocaml_compiler.native_profile_link "%.p.cmx" "%.p.native");; rule "ocaml: cmx* & o* -> native" ~tags:["ocaml"; "native"; "program"] ~prod:"%.native" ~deps:["%.cmx"; x_o] (Ocaml_compiler.native_link "%.cmx" "%.native");; rule "ocaml: mllib & d.cmo* -> d.cma" ~tags:["ocaml"; "byte"; "debug"; "library"] ~prod:"%.d.cma" ~dep:"%.mllib" (Ocaml_compiler.byte_debug_library_link_mllib "%.mllib" "%.d.cma");; rule "ocaml: mllib & cmo* -> cma" ~tags:["ocaml"; "byte"; "library"] ~prod:"%.cma" ~dep:"%.mllib" (Ocaml_compiler.byte_library_link_mllib "%.mllib" "%.cma");; rule "ocaml: d.cmo* -> d.cma" ~tags:["ocaml"; "byte"; "debug"; "library"] ~prod:"%.d.cma" ~dep:"%.d.cmo" (Ocaml_compiler.byte_debug_library_link "%.d.cmo" "%.d.cma");; rule "ocaml: cmo* -> cma" ~tags:["ocaml"; "byte"; "library"] ~prod:"%.cma" ~dep:"%.cmo" (Ocaml_compiler.byte_library_link "%.cmo" "%.cma");; rule "ocaml C stubs: clib & (o|obj)* -> (a|lib) & (so|dll)" ~prods:["%(path:<**/>)lib%(libname:<*> and not <*.*>)"-.-ext_lib; "%(path:<**/>)dll%(libname:<*> and not <*.*>)"-.-ext_dll] ~dep:"%(path)lib%(libname).clib" (C_tools.link_C_library "%(path)lib%(libname).clib" ("%(path)lib%(libname)"-.-ext_lib) "%(path)%(libname)");; rule "ocaml: mllib & p.cmx* & p.o* -> p.cmxa & p.a" ~tags:["ocaml"; "native"; "profile"; "library"] ~prods:["%.p.cmxa"; x_p_a] ~dep:"%.mllib" (Ocaml_compiler.native_profile_library_link_mllib "%.mllib" "%.p.cmxa");; rule "ocaml: mllib & cmx* & o* -> cmxa & a" ~tags:["ocaml"; "native"; "library"] ~prods:["%.cmxa"; x_a] ~dep:"%.mllib" (Ocaml_compiler.native_library_link_mllib "%.mllib" "%.cmxa");; rule "ocaml: p.cmx & p.o -> p.cmxa & p.a" ~tags:["ocaml"; "native"; "profile"; "library"] ~prods:["%.p.cmxa"; x_p_a] ~deps:["%.p.cmx"; x_p_o] (Ocaml_compiler.native_profile_library_link "%.p.cmx" "%.p.cmxa");; rule "ocaml: cmx & o -> cmxa & a" ~tags:["ocaml"; "native"; "library"] ~prods:["%.cmxa"; x_a] ~deps:["%.cmx"; x_o] (Ocaml_compiler.native_library_link "%.cmx" "%.cmxa");; rule "ocaml: mldylib & p.cmx* & p.o* -> p.cmxs & p.so" ~tags:["ocaml"; "native"; "profile"; "shared"; "library"] ~prods:["%.p.cmxs"; x_p_dll] ~dep:"%.mldylib" (Ocaml_compiler.native_profile_shared_library_link_mldylib "%.mldylib" "%.p.cmxs");; rule "ocaml: mldylib & cmx* & o* -> cmxs & so" ~tags:["ocaml"; "native"; "shared"; "library"] ~prods:["%.cmxs"; x_dll] ~dep:"%.mldylib" (Ocaml_compiler.native_shared_library_link_mldylib "%.mldylib" "%.cmxs");; rule "ocaml: p.cmx & p.o -> p.cmxs & p.so" ~tags:["ocaml"; "native"; "profile"; "shared"; "library"] ~prods:["%.p.cmxs"; x_p_dll] ~deps:["%.p.cmx"; x_p_o] (Ocaml_compiler.native_shared_library_link ~tags:["profile"] "%.p.cmx" "%.p.cmxs");; rule "ocaml: p.cmxa & p.a -> p.cmxs & p.so" ~tags:["ocaml"; "native"; "profile"; "shared"; "library"] ~prods:["%.p.cmxs"; x_p_dll] ~deps:["%.p.cmxa"; x_p_a] (Ocaml_compiler.native_shared_library_link ~tags:["profile";"linkall"] "%.p.cmxa" "%.p.cmxs");; rule "ocaml: cmx & o -> cmxs" ~tags:["ocaml"; "native"; "shared"; "library"] ~prods:["%.cmxs"] ~deps:["%.cmx"; x_o] (Ocaml_compiler.native_shared_library_link "%.cmx" "%.cmxs");; rule "ocaml: cmx & o -> cmxs & so" ~tags:["ocaml"; "native"; "shared"; "library"] ~prods:["%.cmxs"; x_dll] ~deps:["%.cmx"; x_o] (Ocaml_compiler.native_shared_library_link "%.cmx" "%.cmxs");; rule "ocaml: cmxa & a -> cmxs & so" ~tags:["ocaml"; "native"; "shared"; "library"] ~prods:["%.cmxs"; x_dll] ~deps:["%.cmxa"; x_a] (Ocaml_compiler.native_shared_library_link ~tags:["linkall"] "%.cmxa" "%.cmxs");; rule "ocaml dependencies ml" ~prod:"%.ml.depends" ~dep:"%.ml" (Ocaml_tools.ocamldep_command "%.ml" "%.ml.depends");; rule "ocaml dependencies mli" ~prod:"%.mli.depends" ~dep:"%.mli" (Ocaml_tools.ocamldep_command "%.mli" "%.mli.depends");; rule "ocamllex" ~tags:["ocaml"] (* FIXME "lexer" *) ~prod:"%.ml" ~dep:"%.mll" (Ocaml_tools.ocamllex "%.mll");; rule "ocaml: mli -> odoc" ~tags:["ocaml"; "doc"] ~prod:"%.odoc" ~deps:["%.mli"; "%.mli.depends"] (Ocaml_tools.document_ocaml_interf "%.mli" "%.odoc");; rule "ocaml: ml -> odoc" ~tags:["ocaml"; "doc"] ~prod:"%.odoc" ~deps:["%.ml"; "%.ml.depends"] (Ocaml_tools.document_ocaml_implem "%.ml" "%.odoc");; rule "ocamldoc: document ocaml project odocl & *odoc -> docdir (html)" ~prod:"%.docdir/index.html" ~stamp:"%.docdir/html.stamp" (* Depend on this file if you want to depends on all files of %.docdir *) ~dep:"%.odocl" (Ocaml_tools.document_ocaml_project ~ocamldoc:Ocaml_tools.ocamldoc_l_dir "%.odocl" "%.docdir/index.html" "%.docdir");; rule "ocamldoc: document ocaml project odocl & *odoc -> docdir (man)" ~prod:"%.docdir/man" ~stamp:"%.docdir/man.stamp" (* Depend on this file if you want to depends on all files of %.docdir/man *) ~dep:"%.odocl" (Ocaml_tools.document_ocaml_project ~ocamldoc:Ocaml_tools.ocamldoc_l_dir "%.odocl" "%.docdir/man" "%.docdir");; rule "ocamldoc: document ocaml project odocl & *odoc -> man|latex|dot..." ~prod:"%(dir).docdir/%(file)" ~dep:"%(dir).odocl" (Ocaml_tools.document_ocaml_project ~ocamldoc:Ocaml_tools.ocamldoc_l_file "%(dir).odocl" "%(dir).docdir/%(file)" "%(dir).docdir");; (* To use menhir give the -use-menhir option at command line, Or put true: use_menhir in your tag file. *) if !Options.use_menhir || Configuration.has_tag "use_menhir" then begin (* Automatic handling of menhir modules, given a description file %.mlypack *) rule "ocaml: modular menhir (mlypack)" ~prods:["%.mli" ; "%.ml"] ~deps:["%.mlypack"] (Ocaml_tools.menhir_modular "%" "%.mlypack" "%.mlypack.depends"); rule "ocaml: menhir modular dependencies" ~prod:"%.mlypack.depends" ~dep:"%.mlypack" (Ocaml_tools.menhir_modular_ocamldep_command "%.mlypack" "%.mlypack.depends"); rule "ocaml: menhir" ~prods:["%.ml"; "%.mli"] ~deps:["%.mly"; "%.mly.depends"] (Ocaml_tools.menhir "%.mly"); rule "ocaml: menhir dependencies" ~prod:"%.mly.depends" ~dep:"%.mly" (Ocaml_tools.menhir_ocamldep_command "%.mly" "%.mly.depends"); end else rule "ocamlyacc" ~tags:["ocaml"] (* FIXME "parser" *) ~prods:["%.ml"; "%.mli"] ~dep:"%.mly" (Ocaml_tools.ocamlyacc "%.mly");; rule "ocaml C stubs: c -> o" ~prod:x_o ~dep:"%.c" begin fun env _build -> let c = env "%.c" in let o = env x_o in let comp = if Tags.mem "native" (tags_of_pathname c) then !Options.ocamlopt else !Options.ocamlc in let cc = Cmd(S[comp; T(tags_of_pathname c++"c"++"compile"); A"-c"; Px c]) in if Pathname.dirname o = Pathname.current_dir_name then cc else Seq[cc; mv (Pathname.basename o) o] end;; rule "ocaml: ml & ml.depends & *cmi -> .inferred.mli" ~prod:"%.inferred.mli" ~deps:["%.ml"; "%.ml.depends"] (Ocaml_tools.infer_interface "%.ml" "%.inferred.mli");; rule "ocaml: mltop -> top" ~prod:"%.top" ~dep:"%.mltop" (Ocaml_compiler.byte_toplevel_link_mltop "%.mltop" "%.top");; rule "preprocess: ml -> pp.ml" ~dep:"%.ml" ~prod:"%.pp.ml" (Ocaml_tools.camlp4 "pp.ml" "%.ml" "%.pp.ml");; flag ["ocaml"; "pp"] begin S (List.fold_right (fun x acc -> Sh x :: acc) !Options.ocaml_ppflags []) end;; flag ["ocaml"; "compile"] begin atomize !Options.ocaml_cflags end;; flag ["c"; "compile"] begin atomize !Options.ocaml_cflags end;; flag ["ocaml"; "link"] begin atomize !Options.ocaml_lflags end;; flag ["c"; "link"] begin atomize !Options.ocaml_lflags end;; flag ["ocaml"; "ocamlyacc"] (atomize !Options.ocaml_yaccflags);; flag ["ocaml"; "menhir"] (atomize !Options.ocaml_yaccflags);; flag ["ocaml"; "doc"] (atomize !Options.ocaml_docflags);; (* Tell menhir to explain conflicts *) flag [ "ocaml" ; "menhir" ; "explain" ] (S[A "--explain"]);; flag ["ocaml"; "ocamllex"] (atomize !Options.ocaml_lexflags);; (* Tell ocamllex to generate ml code *) flag [ "ocaml" ; "ocamllex" ; "generate_ml" ] (S[A "-ml"]);; flag ["ocaml"; "byte"; "link"] begin S (List.map (fun x -> A (x^".cma")) !Options.ocaml_libs) end;; flag ["ocaml"; "native"; "link"] begin S (List.map (fun x -> A (x^".cmxa")) !Options.ocaml_libs) end;; flag ["ocaml"; "byte"; "link"] begin S (List.map (fun x -> A (x^".cmo")) !Options.ocaml_mods) end;; flag ["ocaml"; "native"; "link"] begin S (List.map (fun x -> A (x^".cmx")) !Options.ocaml_mods) end;; (* findlib *) let () = if !Options.use_ocamlfind then begin (* Ocamlfind will link the archives for us. *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg"; let all_tags = [ ["ocaml"; "byte"; "compile"]; ["ocaml"; "native"; "compile"]; ["ocaml"; "byte"; "link"]; ["ocaml"; "native"; "link"]; ["ocaml"; "ocamldep"]; ["ocaml"; "doc"]; ["ocaml"; "mktop"]; ["ocaml"; "infer_interface"]; ] in (* tags package(X), predicate(X) and syntax(X) *) List.iter begin fun tags -> pflag tags "package" (fun pkg -> S [A "-package"; A pkg]); pflag tags "predicate" (fun pkg -> S [A "-predicates"; A pkg]); pflag tags "syntax" (fun pkg -> S [A "-syntax"; A pkg]) end all_tags end else begin try (* Note: if there is no -pkg option, ocamlfind won't be called *) let pkgs = List.map Findlib.query !Options.ocaml_pkgs in flag ["ocaml"; "byte"; "compile"] (Findlib.compile_flags_byte pkgs); flag ["ocaml"; "native"; "compile"] (Findlib.compile_flags_native pkgs); flag ["ocaml"; "byte"; "link"] (Findlib.link_flags_byte pkgs); flag ["ocaml"; "native"; "link"] (Findlib.link_flags_native pkgs) with Findlib.Findlib_error e -> Findlib.report_error e end (* parameterized tags *) let () = pflag ["ocaml"; "native"; "compile"] "for-pack" (fun param -> S [A "-for-pack"; A param]); pflag ["ocaml"; "native"; "pack"] "for-pack" (fun param -> S [A "-for-pack"; A param]); pflag ["ocaml"; "native"; "compile"] "inline" (fun param -> S [A "-inline"; A param]); pflag ["ocaml"; "compile"] "pp" (fun param -> S [A "-pp"; A param]); pflag ["ocaml"; "ocamldep"] "pp" (fun param -> S [A "-pp"; A param]); pflag ["ocaml"; "doc"] "pp" (fun param -> S [A "-pp"; A param]); pflag ["ocaml"; "infer_interface"] "pp" (fun param -> S [A "-pp"; A param]); pflag ["ocaml";"compile";] "warn" (fun param -> S [A "-w"; A param]) let camlp4_flags camlp4s = List.iter begin fun camlp4 -> flag ["ocaml"; "pp"; camlp4] (A camlp4) end camlp4s;; camlp4_flags ["camlp4o"; "camlp4r"; "camlp4of"; "camlp4rf"; "camlp4orf"; "camlp4oof"];; let camlp4_flags' camlp4s = List.iter begin fun (camlp4, flags) -> flag ["ocaml"; "pp"; camlp4] flags end camlp4s;; camlp4_flags' ["camlp4orr", S[A"camlp4of"; A"-parser"; A"reloaded"]; "camlp4rrr", S[A"camlp4rf"; A"-parser"; A"reloaded"]];; flag ["ocaml"; "pp"; "camlp4:no_quot"] (A"-no_quot");; ocaml_lib ~extern:true "dynlink";; ocaml_lib ~extern:true "unix";; ocaml_lib ~extern:true "str";; ocaml_lib ~extern:true "bigarray";; ocaml_lib ~extern:true "nums";; ocaml_lib ~extern:true "dbm";; ocaml_lib ~extern:true "graphics";; ocaml_lib ~extern:true ~tag_name:"use_toplevel" "toplevellib";; ocaml_lib ~extern:true ~dir:"+labltk" "labltk";; ocaml_lib ~extern:true ~dir:"+ocamldoc" "ocamldoc";; ocaml_lib ~extern:true ~dir:"+ocamlbuild" ~tag_name:"use_ocamlbuild" "ocamlbuildlib";; ocaml_lib ~extern:true ~dir:"+camlp4" ~tag_name:"use_camlp4" "camlp4lib";; ocaml_lib ~extern:true ~dir:"+camlp4" ~tag_name:"use_old_camlp4" "camlp4";; ocaml_lib ~extern:true ~dir:"+camlp4" ~tag_name:"use_camlp4_full" "camlp4fulllib";; flag ["ocaml"; "compile"; "use_camlp4_full"] (S[A"-I"; A"+camlp4/Camlp4Parsers"; A"-I"; A"+camlp4/Camlp4Printers"; A"-I"; A"+camlp4/Camlp4Filters"]);; flag ["ocaml"; "use_camlp4_bin"; "link"; "byte"] (A"+camlp4/Camlp4Bin.cmo");; flag ["ocaml"; "use_camlp4_bin"; "link"; "native"] (A"+camlp4/Camlp4Bin.cmx");; flag ["ocaml"; "debug"; "compile"; "byte"] (A "-g");; flag ["ocaml"; "debug"; "link"; "byte"; "program"] (A "-g");; flag ["ocaml"; "debug"; "pack"; "byte"] (A "-g");; flag ["ocaml"; "debug"; "compile"; "native"] (A "-g");; flag ["ocaml"; "debug"; "link"; "native"; "program"] (A "-g");; flag ["ocaml"; "debug"; "pack"; "native"] (A "-g");; flag ["ocaml"; "link"; "native"; "output_obj"] (A"-output-obj");; flag ["ocaml"; "link"; "byte"; "output_obj"] (A"-output-obj");; flag ["ocaml"; "dtypes"; "compile"] (A "-dtypes");; flag ["ocaml"; "annot"; "compile"] (A "-annot");; flag ["ocaml"; "rectypes"; "compile"] (A "-rectypes");; flag ["ocaml"; "rectypes"; "infer_interface"] (A "-rectypes");; flag ["ocaml"; "rectypes"; "doc"] (A "-rectypes");; flag ["ocaml"; "linkall"; "link"] (A "-linkall");; flag ["ocaml"; "link"; "profile"; "native"] (A "-p");; flag ["ocaml"; "link"; "program"; "custom"; "byte"] (A "-custom");; flag ["ocaml"; "link"; "library"; "custom"; "byte"] (A "-custom");; flag ["ocaml"; "compile"; "profile"; "native"] (A "-p");; (* threads, with or without findlib *) flag ["ocaml"; "compile"; "thread"] (A "-thread");; if not !Options.use_ocamlfind then begin flag ["ocaml"; "doc"; "thread"] (S[A"-I"; A"+threads"]); flag ["ocaml"; "link"; "thread"; "native"; "program"] (S[A "threads.cmxa"; A "-thread"]); flag ["ocaml"; "link"; "thread"; "byte"; "program"] (S[A "threads.cma"; A "-thread"]); flag ["ocaml"; "link"; "thread"; "native"; "toplevel"] (S[A "threads.cmxa"; A "-thread"]); flag ["ocaml"; "link"; "thread"; "byte"; "toplevel"] (S[A "threads.cma"; A "-thread"]) end else begin flag ["ocaml"; "link"; "thread"; "program"] (A "-thread") end;; flag ["ocaml"; "compile"; "nopervasives"] (A"-nopervasives");; flag ["ocaml"; "compile"; "nolabels"] (A"-nolabels");; (*flag ["ocaml"; "ocamlyacc"; "quiet"] (A"-q");;*) flag ["ocaml"; "ocamllex"; "quiet"] (A"-q");; let ocaml_warn_flag c = flag ["ocaml"; "compile"; sprintf "warn_%c" (Char.uppercase c)] (S[A"-w"; A (sprintf "%c" (Char.uppercase c))]); flag ["ocaml"; "compile"; sprintf "warn_error_%c" (Char.uppercase c)] (S[A"-warn-error"; A (sprintf "%c" (Char.uppercase c))]); flag ["ocaml"; "compile"; sprintf "warn_%c" (Char.lowercase c)] (S[A"-w"; A (sprintf "%c" (Char.lowercase c))]); flag ["ocaml"; "compile"; sprintf "warn_error_%c" (Char.lowercase c)] (S[A"-warn-error"; A (sprintf "%c" (Char.lowercase c))]);; List.iter ocaml_warn_flag ['A'; 'C'; 'D'; 'E'; 'F'; 'L'; 'M'; 'P'; 'R'; 'S'; 'U'; 'V'; 'Y'; 'Z'; 'X'];; flag ["ocaml"; "doc"; "docdir"; "extension:html"] (A"-html");; flag ["ocaml"; "doc"; "docdir"; "manpage"] (A"-man");; flag ["ocaml"; "doc"; "docfile"; "extension:dot"] (A"-dot");; flag ["ocaml"; "doc"; "docfile"; "extension:tex"] (A"-latex");; flag ["ocaml"; "doc"; "docfile"; "extension:ltx"] (A"-latex");; flag ["ocaml"; "doc"; "docfile"; "extension:texi"] (A"-texi");; ocaml_lib "ocamlbuildlib";; ocaml_lib "ocamlbuildlightlib";; end in () mingw-ocaml/ocaml/ocamlbuild/ocamlbuildlib.mllib0000644000175000017500000000011512124403240021410 0ustar tootstootsOcamlbuild_pack Ocamlbuild_plugin Ocamlbuild_unix_plugin Ocamlbuild_executor mingw-ocaml/ocaml/ocamlbuild/options.ml0000644000175000017500000003160712124403240017624 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) let version = "ocamlbuild "^(Sys.ocaml_version);; type command_spec = Command.spec open My_std open Arg open Format open Command let entry = ref None let build_dir = ref (Filename.concat (Sys.getcwd ()) "_build") let include_dirs = ref [] let exclude_dirs = ref [] let nothing_should_be_rebuilt = ref false let sanitize = ref true let sanitization_script = ref "sanitize.sh" let hygiene = ref true let ignore_auto = ref true let plugin = ref true let just_plugin = ref false let native_plugin = ref true let make_links = ref true let nostdlib = ref false let use_menhir = ref false let catch_errors = ref true let use_ocamlfind = ref false let mk_virtual_solvers = let dir = Ocamlbuild_where.bindir in List.iter begin fun cmd -> let opt = cmd ^ ".opt" in let a_opt = A opt in let a_cmd = A cmd in let search_in_path = memo Command.search_in_path in let solver () = if sys_file_exists !dir then let long = filename_concat !dir cmd in let long_opt = long ^ ".opt" in if file_or_exe_exists long_opt then A long_opt else if file_or_exe_exists long then A long else try let _ = search_in_path opt in a_opt with Not_found -> a_cmd else try let _ = search_in_path opt in a_opt with Not_found -> a_cmd in Command.setup_virtual_command_solver (String.uppercase cmd) solver end let () = mk_virtual_solvers ["ocamlc"; "ocamlopt"; "ocamldep"; "ocamldoc"; "ocamlyacc"; "menhir"; "ocamllex"; "ocamlmklib"; "ocamlmktop"; "ocamlfind"] let ocamlc = ref (V"OCAMLC") let ocamlopt = ref (V"OCAMLOPT") let ocamldep = ref (V"OCAMLDEP") let ocamldoc = ref (V"OCAMLDOC") let ocamlyacc = ref N let ocamllex = ref (V"OCAMLLEX") let ocamlmklib = ref (V"OCAMLMKLIB") let ocamlmktop = ref (V"OCAMLMKTOP") let ocamlrun = ref N let ocamlfind x = S[V"OCAMLFIND"; x] let program_to_execute = ref false let must_clean = ref false let show_documentation = ref false let recursive = ref false let ext_lib = ref Ocamlbuild_Myocamlbuild_config.a let ext_obj = ref Ocamlbuild_Myocamlbuild_config.o let ext_dll = ref Ocamlbuild_Myocamlbuild_config.so let exe = ref Ocamlbuild_Myocamlbuild_config.exe let targets_internal = ref [] let ocaml_libs_internal = ref [] let ocaml_mods_internal = ref [] let ocaml_pkgs_internal = ref [] let ocaml_lflags_internal = ref [] let ocaml_cflags_internal = ref [] let ocaml_docflags_internal = ref [] let ocaml_ppflags_internal = ref [] let ocaml_yaccflags_internal = ref [] let ocaml_lexflags_internal = ref [] let program_args_internal = ref [] let ignore_list_internal = ref [] let tags_internal = ref [["quiet"]] let tag_lines_internal = ref [] let show_tags_internal = ref [] let log_file_internal = ref "_log" let my_include_dirs = ref [[Filename.current_dir_name]] let my_exclude_dirs = ref [[".svn"; "CVS"]] let dummy = "*invalid-dummy-string*";; (* Dummy string for delimiting the latest argument *) (* The JoCaml support will be in a plugin when the plugin system will support * multiple/installed plugins *) let use_jocaml () = ocamlc := A "jocamlc"; ocamlopt := A "jocamlopt"; ocamldep := A "jocamldep"; ocamlyacc := A "jocamlyacc"; ocamllex := A "jocamllex"; ocamlmklib := A "jocamlmklib"; ocamlmktop := A "jocamlmktop"; ocamlrun := A "jocamlrun"; ;; let add_to rxs x = let xs = Lexers.comma_or_blank_sep_strings (Lexing.from_string x) in rxs := xs :: !rxs let add_to' rxs x = if x <> dummy then rxs := [x] :: !rxs else () let set_cmd rcmd = String (fun s -> rcmd := Sh s) let set_build_dir s = make_links := false; if Filename.is_relative s then build_dir := Filename.concat (Sys.getcwd ()) s else build_dir := s let spec = ref ( Arg.align [ "-version", Unit (fun () -> print_endline version; raise Exit_OK), " Display the version"; "-vnum", Unit (fun () -> print_endline Sys.ocaml_version; raise Exit_OK), " Display the version number"; "-quiet", Unit (fun () -> Log.level := 0), " Make as quiet as possible"; "-verbose", Int (fun i -> Log.level := i + 2), " Set the verbosity level"; "-documentation", Set show_documentation, " Show rules and flags"; "-log", Set_string log_file_internal, " Set log file"; "-no-log", Unit (fun () -> log_file_internal := ""), " No log file"; "-clean", Set must_clean, " Remove build directory and other files, then exit"; "-r", Set recursive, " Traverse directories by default (true: traverse)"; "-I", String (add_to' my_include_dirs), " Add to include directories"; "-Is", String (add_to my_include_dirs), " (same as above, but accepts a (comma or blank)-separated list)"; "-X", String (add_to' my_exclude_dirs), " Directory to ignore"; "-Xs", String (add_to my_exclude_dirs), " (idem)"; "-lib", String (add_to' ocaml_libs_internal), " Link to this ocaml library"; "-libs", String (add_to ocaml_libs_internal), " (idem)"; "-mod", String (add_to' ocaml_mods_internal), " Link to this ocaml module"; "-mods", String (add_to ocaml_mods_internal), " (idem)"; "-pkg", String (add_to' ocaml_pkgs_internal), " Link to this ocaml findlib package"; "-pkgs", String (add_to ocaml_pkgs_internal), " (idem)"; "-package", String (add_to' ocaml_pkgs_internal), " (idem)"; "-lflag", String (add_to' ocaml_lflags_internal), " Add to ocamlc link flags"; "-lflags", String (add_to ocaml_lflags_internal), " (idem)"; "-cflag", String (add_to' ocaml_cflags_internal), " Add to ocamlc compile flags"; "-cflags", String (add_to ocaml_cflags_internal), " (idem)"; "-docflag", String (add_to' ocaml_docflags_internal), " Add to ocamldoc flags"; "-docflags", String (add_to ocaml_docflags_internal), " (idem)"; "-yaccflag", String (add_to' ocaml_yaccflags_internal), " Add to ocamlyacc flags"; "-yaccflags", String (add_to ocaml_yaccflags_internal), " (idem)"; "-lexflag", String (add_to' ocaml_lexflags_internal), " Add to ocamllex flags"; "-lexflags", String (add_to ocaml_lexflags_internal), " (idem)"; "-ppflag", String (add_to' ocaml_ppflags_internal), " Add to ocaml preprocessing flags"; "-pp", String (add_to ocaml_ppflags_internal), " (idem)"; "-tag", String (add_to' tags_internal), " Add to default tags"; "-tags", String (add_to tags_internal), " (idem)"; "-tag-line", String (add_to' tag_lines_internal), " Use this line of tags (as in _tags)"; "-show-tags", String (add_to' show_tags_internal), " Show tags that applies on that pathname"; "-ignore", String (add_to ignore_list_internal), " Don't try to build these modules"; "-no-links", Clear make_links, " Don't make links of produced final targets"; "-no-skip", Clear ignore_auto, " Don't skip modules that are requested by ocamldep but cannot be built"; "-no-hygiene", Clear hygiene, " Don't apply sanity-check rules"; "-no-plugin", Clear plugin, " Don't build myocamlbuild.ml"; "-no-stdlib", Set nostdlib, " Don't ignore stdlib modules"; "-dont-catch-errors", Clear catch_errors, " Don't catch and display exceptions (useful to display the call stack)"; "-just-plugin", Set just_plugin, " Just build myocamlbuild.ml"; "-byte-plugin", Clear native_plugin, " Don't use a native plugin but bytecode"; "-plugin-option", String ignore, " Use the option only when plugin is run"; "-sanitization-script", Set_string sanitization_script, " Change the file name for the generated sanitization script"; "-no-sanitize", Clear sanitize, " Do not generate sanitization script"; "-nothing-should-be-rebuilt", Set nothing_should_be_rebuilt, " Fail if something needs to be rebuilt"; "-classic-display", Set Log.classic_display, " Display executed commands the old-fashioned way"; "-use-menhir", Set use_menhir, " Use menhir instead of ocamlyacc"; "-use-jocaml", Unit use_jocaml, " Use jocaml compilers instead of ocaml ones"; "-use-ocamlfind", Set use_ocamlfind, " Use ocamlfind to call ocaml compilers"; "-j", Set_int Command.jobs, " Allow N jobs at once (0 for unlimited)"; "-build-dir", String set_build_dir, " Set build directory (implies no-links)"; "-install-lib-dir", Set_string Ocamlbuild_where.libdir, " Set the install library directory"; "-install-bin-dir", Set_string Ocamlbuild_where.bindir, " Set the install binary directory"; "-where", Unit (fun () -> print_endline !Ocamlbuild_where.libdir; raise Exit_OK), " Display the install library directory"; "-ocamlc", set_cmd ocamlc, " Set the OCaml bytecode compiler"; "-ocamlopt", set_cmd ocamlopt, " Set the OCaml native compiler"; "-ocamldep", set_cmd ocamldep, " Set the OCaml dependency tool"; "-ocamldoc", set_cmd ocamldoc, " Set the OCaml documentation generator"; "-ocamlyacc", set_cmd ocamlyacc, " Set the ocamlyacc tool"; "-menhir", set_cmd ocamlyacc, " Set the menhir tool (use it after -use-menhir)"; "-ocamllex", set_cmd ocamllex, " Set the ocamllex tool"; (* Not set since we perhaps want to replace ocamlmklib *) (* "-ocamlmklib", set_cmd ocamlmklib, " Set the ocamlmklib tool"; *) "-ocamlmktop", set_cmd ocamlmktop, " Set the ocamlmktop tool"; "-ocamlrun", set_cmd ocamlrun, " Set the ocamlrun tool"; "--", Rest (fun x -> program_to_execute := true; add_to' program_args_internal x), " Stop argument processing, remaining arguments are given to the user program"; ]) let add x = spec := !spec @ [x] let targets = ref [] let ocaml_libs = ref [] let ocaml_mods = ref [] let ocaml_pkgs = ref [] let ocaml_lflags = ref [] let ocaml_cflags = ref [] let ocaml_ppflags = ref [] let ocaml_docflags = ref [] let ocaml_yaccflags = ref [] let ocaml_lexflags = ref [] let program_args = ref [] let ignore_list = ref [] let tags = ref [] let tag_lines = ref [] let show_tags = ref [] let init () = let anon_fun = add_to' targets_internal in let usage_msg = sprintf "Usage %s [options] " Sys.argv.(0) in let argv' = Array.concat [Sys.argv; [|dummy|]] in parse_argv argv' !spec anon_fun usage_msg; Shell.mkdir_p !build_dir; let () = let log = !log_file_internal in if log = "" then Log.init None else if not (Filename.is_implicit log) then failwith (sprintf "Bad log file name: the file name must be implicit (not %S)" log) else let log = filename_concat !build_dir log in Shell.mkdir_p (Filename.dirname log); Shell.rm_f log; let log = if !Log.level > 0 then Some log else None in Log.init log in if !use_ocamlfind then begin (* TODO: warning message when using an option such as -ocamlc *) (* Note that plugins can still modify these variables After_options. This design decision can easily be changed. *) ocamlc := ocamlfind & A"ocamlc"; ocamlopt := ocamlfind & A"ocamlopt"; ocamldep := ocamlfind & A"ocamldep"; ocamldoc := ocamlfind & A"ocamldoc"; ocamlmktop := ocamlfind & A"ocamlmktop"; end; let reorder x y = x := !x @ (List.concat (List.rev !y)) in reorder targets targets_internal; reorder ocaml_libs ocaml_libs_internal; reorder ocaml_mods ocaml_mods_internal; reorder ocaml_pkgs ocaml_pkgs_internal; reorder ocaml_cflags ocaml_cflags_internal; reorder ocaml_lflags ocaml_lflags_internal; reorder ocaml_ppflags ocaml_ppflags_internal; reorder ocaml_docflags ocaml_docflags_internal; reorder ocaml_yaccflags ocaml_yaccflags_internal; reorder ocaml_lexflags ocaml_lexflags_internal; reorder program_args program_args_internal; reorder tags tags_internal; reorder tag_lines tag_lines_internal; reorder ignore_list ignore_list_internal; reorder show_tags show_tags_internal; let check_dir dir = if Filename.is_implicit dir then sys_file_exists dir else failwith (sprintf "Included or excluded directories must be implicit (not %S)" dir) in let dir_reorder my dir = let d = !dir in reorder dir my; dir := List.filter check_dir (!dir @ d) in dir_reorder my_include_dirs include_dirs; dir_reorder my_exclude_dirs exclude_dirs; ignore_list := List.map String.capitalize !ignore_list ;; mingw-ocaml/ocaml/ocamlbuild/glob_ast.mli0000644000175000017500000000206512124403240020070 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Glob_ast *) exception Parse_error of string type pattern = | Epsilon | Star of pattern | Class of character_class | Concat of pattern * pattern | Union of pattern list | Word of string and character_class = (char * char) Bool.boolean type 'pattern atom = Constant of string | Pattern of 'pattern mingw-ocaml/ocaml/ocamlbuild/resource.mli0000644000175000017500000000516512124403240020131 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Pathname type resource_pattern type env module Resources : Set.S with type elt = t module Cache : sig type cache_entry type suspension type build_status = | Bbuilt | Bcannot_be_built | Bnot_built_yet | Bsuspension of suspension val clean : unit -> unit val resource_state : t -> build_status val resource_changed : t -> unit val resource_has_changed : t -> bool val resource_built : t -> unit val resource_failed : t -> unit val import_in_build_dir : t -> unit val suspend_resource : t -> Command.t -> (unit -> unit) -> t list -> unit val resume_resource : t -> unit val resume_suspension : suspension -> unit val get_optional_resource_suspension : t -> (Command.t * (unit -> unit)) option val clear_resource_failed : t -> unit val add_dependency : t -> t -> unit val fold_dependencies : (string -> string -> 'a -> 'a) -> 'a -> 'a val external_is_up_to_date : t -> bool (* These are not currently used by others modules. *) val dependencies : t -> Resources.t val print_cache : Format.formatter -> unit -> unit val print_dependencies : Format.formatter -> unit -> unit end val digest : t -> string val exists_in_source_dir : t -> bool val exists_in_build_dir : t -> bool val in_build_dir : t -> t val in_source_dir : t -> t val clean_up_links : bool Slurp.entry -> bool Slurp.entry val compare : t -> t -> int val print : Format.formatter -> t -> unit val print_pattern : Format.formatter -> resource_pattern -> unit val clean : t -> unit val import : string -> t val import_pattern : string -> resource_pattern val matchit : resource_pattern -> t -> env option val subst : env -> t -> t val subst_any : env -> t -> t val subst_pattern : env -> resource_pattern -> t (* val is_up_to_date : t -> bool *) val print_env : Format.formatter -> env -> unit mingw-ocaml/ocaml/ocamlbuild/report.mli0000644000175000017500000000164612124403240017615 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Report *) val print_backtrace_analyze : Format.formatter -> Solver.backtrace -> unit val print_backtrace : Format.formatter -> Solver.backtrace -> unit mingw-ocaml/ocaml/ocamlbuild/options.mli0000644000175000017500000000162212124403240017767 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) include Signatures.OPTIONS with type command_spec = Command.spec val entry : bool Slurp.entry option ref val init : unit -> unit mingw-ocaml/ocaml/ocamlbuild/findlib.ml0000644000175000017500000001301612124403240017532 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Romain Bardou *) open My_std open My_unix open Command type command_spec = Command.spec type error = | Cannot_run_ocamlfind | Dependency_not_found of string * string (* package, dependency *) | Package_not_found of string | Cannot_parse_query of string * string (* package, explaination *) exception Findlib_error of error let error x = raise (Findlib_error x) let string_of_error = function | Cannot_run_ocamlfind -> "Cannot run Ocamlfind." | Dependency_not_found(p, d) -> Printf.sprintf "Ocamlfind returned \"%s\" as a dependency for package \"%s\" but does \ not know this dependency." d p | Package_not_found p -> Printf.sprintf "Findlib package not found: \"%s\"." p | Cannot_parse_query(p, e) -> Printf.sprintf "Cannot parse Ocamlfind query for package \"%s\": %s" p e let report_error e = prerr_endline (string_of_error e); exit 2 let ocamlfind = "ocamlfind" type package = { name: string; description: string; version: string; archives_byte: string; archives_native: string; link_options: string; location: string; dependencies: package list; } let packages = Hashtbl.create 42 let run_and_parse lexer command = Printf.ksprintf (fun command -> lexer & Lexing.from_string & run_and_read command) command let run_and_read command = Printf.ksprintf run_and_read command let rec query name = try Hashtbl.find packages name with Not_found -> try let n, d, v, a_byte, lo, l = run_and_parse Lexers.ocamlfind_query "%s query -l -predicates byte %s" ocamlfind name in let a_native = run_and_parse Lexers.trim_blanks "%s query -a-format -predicates native %s" ocamlfind name in let deps = run_and_parse Lexers.blank_sep_strings "%s query -r -p-format %s" ocamlfind name in let deps = List.filter ((<>) n) deps in let deps = try List.map query deps with Findlib_error (Package_not_found dep_name) -> (* Ocamlfind cannot find a package which it returned as a dependency. This should not happen. *) error (Dependency_not_found (name, dep_name)) in let package = { name = n; description = d; version = v; archives_byte = a_byte; archives_native = a_native; link_options = lo; location = l; dependencies = deps; } in Hashtbl.add packages n package; package with | Failure _ -> (* TODO: Improve to differenciate whether ocamlfind cannot be run or is not installed *) error Cannot_run_ocamlfind | Lexers.Error s -> error (Cannot_parse_query (name, s)) let split_nl s = let x = ref [] in let rec go s = let pos = String.index s '\n' in x := (String.before s pos)::!x; go (String.after s (pos + 1)) in try go s with Not_found -> !x let before_space s = try String.before s (String.index s ' ') with Not_found -> s let list () = List.map before_space (split_nl & run_and_read "%s list" ocamlfind) (* The closure algorithm is easy because the dependencies are already closed and sorted for each package. We only have to make the union. We could also make another ocamlfind query such as: ocamlfind query -p-format -r package1 package2 ... *) let topological_closure l = let add l x = if List.mem x l then l else x :: l in let l = List.fold_left begin fun acc p -> add (List.fold_left add acc p.dependencies) p end [] l in List.rev l module SSet = Set.Make(String) let add_atom a l = match a, l with | A "", _ -> l | _ -> a :: l let compile_flags l = let pkgs = topological_closure l in let locations = List.fold_left begin fun acc p -> SSet.add p.location acc end SSet.empty pkgs in let flags = [] in (* includes *) let flags = List.fold_left begin fun acc l -> add_atom (P l) (add_atom (A "-I") acc) end flags (SSet.elements locations) in S (List.rev flags) let compile_flags_byte = compile_flags let compile_flags_native = compile_flags let link_flags f l = let pkgs = topological_closure l in let locations = List.fold_left begin fun acc p -> SSet.add p.location acc end SSet.empty pkgs in let flags = [] in (* includes *) let flags = List.fold_left begin fun acc l -> add_atom (P l) (add_atom (A "-I") acc) end flags (SSet.elements locations) in (* special link options *) let flags = List.fold_left begin fun acc x -> add_atom (A x.link_options) acc end flags pkgs in (* archives *) let flags = List.fold_left begin fun acc x -> add_atom (A (f x)) acc end flags pkgs in S (List.rev flags) let link_flags_byte = link_flags (fun x -> x.archives_byte) let link_flags_native = link_flags (fun x -> x.archives_native) mingw-ocaml/ocaml/ocamlbuild/rule.ml0000644000175000017500000002653412124403240017103 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Format open Log open Outcome module Resources = Resource.Resources exception Exit_rule_error of string exception Failed type env = Pathname.t -> Pathname.t type builder = Pathname.t list list -> (Pathname.t, exn) Outcome.t list type action = env -> builder -> Command.t type digest_command = { digest : string; command : Command.t } type 'a gen_rule = { name : string; tags : Tags.t; deps : Pathname.t list; (* These pathnames must be normalized *) prods : 'a list; (* Note that prods also contains stamp *) stamp : 'a option; code : env -> builder -> digest_command } type rule = Pathname.t gen_rule type rule_scheme = Resource.resource_pattern gen_rule let name_of_rule r = r.name let deps_of_rule r = r.deps let prods_of_rule r = r.prods let stamp_of_rule r = r.stamp type 'a rule_printer = (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a gen_rule -> unit let compare _ _ = assert false let print_rule_name f r = pp_print_string f r.name let print_resource_list = List.print Resource.print let print_rule_contents ppelt f r = fprintf f "@[{@ @[<2>name =@ %S@];@ @[<2>tags =@ %a@];@ @[<2>deps =@ %a@];@ @[<2>prods = %a@];@ @[<2>code = @]@]@ }" r.name Tags.print r.tags print_resource_list r.deps (List.print ppelt) r.prods let pretty_print ppelt f r = fprintf f "@[rule@ %S@ ~deps:%a@ ~prods:%a@ @]" r.name print_resource_list r.deps (List.print ppelt) r.prods let print = print_rule_name let subst env rule = let subst_resources = List.map (Resource.subst env) in let subst_resource_patterns = List.map (Resource.subst_pattern env) in let finder next_finder p = next_finder (Resource.subst_any env p) in let stamp = match rule.stamp with None -> None | Some x -> Some (Resource.subst_pattern env x) in let prods = subst_resource_patterns rule.prods in { (rule) with name = sbprintf "%s (%a)" rule.name Resource.print_env env; prods = prods; deps = subst_resources rule.deps; (* The substition should preserve normalization of pathnames *) stamp = stamp; code = (fun env -> rule.code (finder env)) } exception Can_produce of rule let can_produce target rule = try List.iter begin fun resource -> match Resource.matchit resource target with | Some env -> raise (Can_produce (subst env rule)) | None -> () end rule.prods; None with Can_produce r -> Some r (* let tags_matches tags r = if Tags.does_match tags r.tags then Some r else None *) let digest_prods r = List.fold_right begin fun p acc -> let f = Pathname.to_string (Resource.in_build_dir p) in if sys_file_exists f then (f, Digest.file f) :: acc else acc end r.prods [] let digest_deps r dyndeps = let buf = Buffer.create 1024 in let add_resource r = Buffer.add_string buf (Digest.to_hex (Resource.digest r)) in Buffer.add_string buf "deps:"; List.iter add_resource r.deps; Buffer.add_string buf "dyndeps:"; Resources.iter add_resource dyndeps; Digest.to_hex (Digest.string (Buffer.contents buf)) let digest_rule r dyndeps action = let buf = Buffer.create 1024 in Buffer.add_string buf action.digest; let add_resource r = Buffer.add_string buf (Resource.digest r) in Buffer.add_string buf "prods:"; List.iter add_resource r.prods; Buffer.add_string buf "deps:"; List.iter add_resource r.deps; Buffer.add_string buf "dyndeps:"; Resources.iter add_resource dyndeps; Digest.string (Buffer.contents buf) let cached_digest r = try Some (Digest_cache.get ("Rule: " ^ r.name)) with Not_found -> None let store_digest r digest = Digest_cache.put ("Rule: " ^ r.name) digest let print_digest f x = pp_print_string f (Digest.to_hex x) let exists2 find p rs = try Some (find p rs) with Not_found -> None let build_deps_of_tags builder tags = match Command.deps_of_tags tags with | [] -> [] | deps -> List.map Outcome.good (builder (List.map (fun x -> [x]) deps)) let build_deps_of_tags_on_cmd builder = Command.iter_tags begin fun tags -> match Command.deps_of_tags tags with | [] -> () | deps -> List.iter ignore_good (builder (List.map (fun x -> [x]) deps)) end let call builder r = let dyndeps = ref Resources.empty in let builder rs = let results = builder rs in List.map begin fun res -> match res with | Good res' -> let () = dprintf 10 "new dyndep for %S(%a): %S" r.name print_resource_list r.prods res' in dyndeps := Resources.add res' !dyndeps; List.iter (fun x -> Resource.Cache.add_dependency x res') r.prods; res | Bad _ -> res end results in let () = dprintf 5 "start rule %a" print r in let action = r.code (fun x -> x) builder in build_deps_of_tags_on_cmd builder action.command; let dyndeps = !dyndeps in let () = dprintf 10 "dyndeps: %a" Resources.print dyndeps in let (reason, cached) = match exists2 List.find (fun r -> not (Resource.exists_in_build_dir r)) r.prods with | Some r -> (`cache_miss_missing_prod r, false) | _ -> begin match exists2 List.find Resource.Cache.resource_has_changed r.deps with | Some r -> (`cache_miss_changed_dep r, false) | _ -> begin match exists2 Resources.find Resource.Cache.resource_has_changed dyndeps with | Some r -> (`cache_miss_changed_dyn_dep r, false) | _ -> begin match cached_digest r with | None -> (`cache_miss_no_digest, false) | Some d -> let rule_digest = digest_rule r dyndeps action in if d = rule_digest then (`cache_hit, true) else (`cache_miss_digest_changed(d, rule_digest), false) end end end in let explain_reason l = raw_dprintf (l+1) "mid rule %a: " print r; match reason with | `cache_miss_missing_prod r -> dprintf l "cache miss: a product is not in build dir (%a)" Resource.print r | `cache_miss_changed_dep r -> dprintf l "cache miss: a dependency has changed (%a)" Resource.print r | `cache_miss_changed_dyn_dep r -> dprintf l "cache miss: a dynamic dependency has changed (%a)" Resource.print r | `cache_miss_no_digest -> dprintf l "cache miss: no digest found for %S (the command, a dependency, or a product)" r.name | `cache_hit -> dprintf (l+1) "cache hit" | `cache_miss_digest_changed(old_d, new_d) -> dprintf l "cache miss: the digest has changed for %S (the command, a dependency, or a product: %a <> %a)" r.name print_digest old_d print_digest new_d in let prod_digests = digest_prods r in (if not cached then List.iter Resource.clean r.prods); (if !Options.nothing_should_be_rebuilt && not cached then (explain_reason (-1); let msg = sbprintf "Need to rebuild %a through the rule `%a'" print_resource_list r.prods print r in raise (Exit_rule_error msg))); explain_reason 3; let thunk () = try if cached then Command.execute ~pretend:true action.command else begin match r.stamp with | Some stamp -> reset_filesys_cache (); let digest_deps = digest_deps r dyndeps in with_output_file stamp (fun oc -> output_string oc digest_deps) | None -> () end; List.iter (fun r -> Resource.Cache.resource_built r) r.prods; (if not cached then let new_rule_digest = digest_rule r dyndeps action in let new_prod_digests = digest_prods r in let () = store_digest r new_rule_digest in List.iter begin fun p -> let f = Pathname.to_string (Resource.in_build_dir p) in (try let digest = List.assoc f prod_digests in let new_digest = List.assoc f new_prod_digests in if digest <> new_digest then raise Not_found with Not_found -> Resource.Cache.resource_changed p) end r.prods); dprintf 5 "end rule %a" print r with exn -> (List.iter Resource.clean r.prods; raise exn) in if cached then thunk () else List.iter (fun x -> Resource.Cache.suspend_resource x action.command thunk r.prods) r.prods let (get_rules, add_rule, clear_rules) = let rules = ref [] in (fun () -> !rules), begin fun pos r -> try let _ = List.find (fun x -> x.name = r.name) !rules in raise (Exit_rule_error (sbprintf "Rule.add_rule: already exists: (%a)" print r)) with Not_found -> match pos with | `bottom -> rules := !rules @ [r] | `top -> rules := r :: !rules | `after s -> rules := List.fold_right begin fun x acc -> if x.name = s then x :: r :: acc else x :: acc end !rules [] | `before s -> rules := List.fold_right begin fun x acc -> if x.name = s then r :: x :: acc else x :: acc end !rules [] end, (fun () -> rules := []) let rule name ?(tags=[]) ?(prods=[]) ?(deps=[]) ?prod ?dep ?stamp ?(insert = `bottom) code = let res_add import xs xopt = let init = match xopt with | None -> [] | Some r -> [import r] in List.fold_right begin fun x acc -> let r = import x in if List.mem r acc then failwith (sprintf "in rule %s, multiple occurences of the resource %s" name x) else r :: acc end xs init in if prods = [] && prod = None && stamp = None then raise (Exit_rule_error "Can't make a rule that produce nothing"); let stamp, prods = match stamp with | None -> None, prods | Some stamp -> Some (Resource.import_pattern stamp), stamp :: prods in let prods = res_add Resource.import_pattern prods prod in let code env build = let cmd = code env build in { digest = Command.digest cmd ; command = cmd } in add_rule insert { name = name; tags = List.fold_right Tags.add tags Tags.empty; deps = res_add Resource.import (* should normalize *) deps dep; stamp = stamp; prods = prods; code = code } module Common_commands = struct open Command let mv src dest = Cmd (S [A"mv"; P src; Px dest]) let cp src dest = Cmd (S [A"cp"; P src; Px dest]) let cp_p src dest = Cmd (S [A"cp"; A"-p"; P src; Px dest]) let ln_f pointed pointer = Cmd (S [A"ln"; A"-f"; P pointed; Px pointer]) let ln_s pointed pointer = Cmd (S[A"ln"; A"-s"; P pointed; Px pointer]) let rm_f x = Cmd (S [A"rm"; A"-f"; Px x]) let chmod opts file = Cmd (S[A"chmod"; opts; Px file]) let cmp a b = Cmd (S[A"cmp"; P a; Px b]) end open Common_commands let copy_rule name ?insert src dest = rule name ?insert ~prod:dest ~dep:src begin fun env _ -> let src = env src and dest = env dest in Shell.mkdir_p (Pathname.dirname dest); cp_p src dest end mingw-ocaml/ocaml/ocamlbuild/slurp.mli0000644000175000017500000000456412124403240017451 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Slurp *) (** Scans a directory lazily to build a tree that can be user-decorated. *) type 'a entry = Dir of string * string * My_unix.stats Lazy.t * 'a * 'a entry list Lazy.t (** [Dir(path, name, lst, decoration, lentries)] is a directory named [name] whose path is [path]. Its stat is lazily stored in [lst] and its entries are lazily scanned in [lentries]. [decoration] is of type 'a. *) | File of string * string * My_unix.stats Lazy.t * 'a (** [File(path, name, lst, decoration)] is a file named [name] whose path is [path]. Its stat is lazily stored in [lst]. [decoration] is of type 'a. *) | Error of exn (** [Error x] means that the exception [x] was raised while scanning or statting an entry. *) | Nothing (** Convenient when filtering out entries. *) (** Recursively scan the filesystem starting at the given directory. *) val slurp : string -> unit entry (** [filter f entry] only retains from [entry] the nodes for which [f path name] returns [true]. *) val filter : (string -> string -> 'a -> bool) -> 'a entry -> 'a entry (** [map f entries] changes the decoration in [entries] by applying [f] to them. [f] is called as [f path name decoration]. *) val map : (string -> string -> 'a -> 'b) -> 'a entry -> 'b entry (** [fold f entry x] iterates [f] over the entries and an accumulator initially containing [x]; at each iteration, [f] gets the current value of the accumulator and returns its new value. *) val fold : (string -> string -> 'b -> 'a -> 'a) -> 'b entry -> 'a -> 'a (** Force the evaluation of the whole entry. *) val force : 'a entry -> unit mingw-ocaml/ocaml/ocamlbuild/hooks.mli0000644000175000017500000000172612124403240017424 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) type message = | Before_hygiene | After_hygiene | Before_options | After_options | Before_rules | After_rules val setup_hooks : (message -> unit) -> unit val call_hook : message -> unit mingw-ocaml/ocaml/ocamlbuild/shell.ml0000644000175000017500000000613212124403240017233 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std let is_simple_filename s = let ls = String.length s in ls <> 0 && let rec loop pos = if pos >= ls then true else match s.[pos] with | 'a'..'z' | 'A'..'Z' | '0'..'9' | '.' | '-' | '/' | '_' | ':' | '@' | '+' | ',' -> loop (pos + 1) | _ -> false in loop 0 let quote_filename_if_needed s = if is_simple_filename s then s (* We should probably be using [Filename.unix_quote] except that function * isn't exported. Users on Windows will have to live with not being able to * install OCaml into c:\o'caml. Too bad. *) else if Sys.os_type = "Win32" then Printf.sprintf "'%s'" s else Filename.quote s let chdir dir = reset_filesys_cache (); Sys.chdir dir let run args target = reset_readdir_cache (); let cmd = String.concat " " (List.map quote_filename_if_needed args) in if !*My_unix.is_degraded || Sys.os_type = "Win32" then begin Log.event cmd target Tags.empty; let st = sys_command cmd in if st <> 0 then failwith (Printf.sprintf "Error during command `%s'.\nExit code %d.\n" cmd st) else () end else match My_unix.execute_many ~ticker:Log.update ~display:Log.display [[(fun () -> cmd)]] with | None -> () | Some(_, x) -> failwith (Printf.sprintf "Error during command %S: %s" cmd (Printexc.to_string x)) let rm = sys_remove let rm_f x = if sys_file_exists x then rm x let mkdir dir = reset_filesys_cache_for_file dir; (*Sys.mkdir dir (* MISSING in ocaml *) *) run ["mkdir"; dir] dir let try_mkdir dir = if not (sys_file_exists dir) then mkdir dir let rec mkdir_p dir = if sys_file_exists dir then () else (mkdir_p (Filename.dirname dir); mkdir dir) let cp_pf src dest = reset_filesys_cache_for_file dest; run["cp";"-pf";src;dest] dest (* L'Arrêté du 2007-03-07 prend en consideration differement les archives. Pour les autres fichiers le décret du 2007-02-01 est toujours valable :-) *) let cp src dst = if Filename.check_suffix src ".a" && Filename.check_suffix dst ".a" then cp_pf src dst (* try to make a hard link *) else copy_file src dst let readlink = My_unix.readlink let is_link = My_unix.is_link let rm_rf x = reset_filesys_cache (); run["rm";"-Rf";x] x let mv src dest = reset_filesys_cache_for_file src; reset_filesys_cache_for_file dest; run["mv"; src; dest] dest (*Sys.rename src dest*) mingw-ocaml/ocaml/ocamlbuild/ocamlbuild.mltop0000644000175000017500000000007112124403240020756 0ustar tootstootsOcamlbuild_pack Ocamlbuild_plugin Ocamlbuild_unix_plugin mingw-ocaml/ocaml/ocamlbuild/FAQ0000644000175000017500000000154512124403240016127 0ustar tootstootsQ: I've a directory with examples and I want build all of them easily? R: You can use an .itarget file listing all products that you want. $ cat examples.itarget examples/a.byte examples/b.byte $ ocamlbuild examples.otarget You can also have a dynamic rule that read the examples directory: $ cat myocamlbuild.ml open Ocamlbuild_plugin;; dispatch begin function | After_rules -> let examples = Array.fold_right begin fun f acc -> if Pathname.get_extension f = "ml" then ("examples" / Pathname.update_extension "byte" f) :: acc else acc end (Pathname.readdir "examples") [] in rule "All examples" ~prod:"examples.otarget" ~deps:examples (fun _ _ -> Command.Nop) | _ -> () end $ ocamlbuild examples.otarget mingw-ocaml/ocaml/ocamlbuild/discard_printf.ml0000644000175000017500000000152412124403240021117 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) let discard_printf fmt = Format.ifprintf Format.std_formatter fmt;; mingw-ocaml/ocaml/ocamlbuild/examples/0000755000175000017500000000000012124403240017406 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/examples/example2/0000755000175000017500000000000012124403240021123 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/examples/example2/hello.ml0000644000175000017500000000035512124403240022563 0ustar tootstootsopen Greet let _ = let name = if Array.length Sys.argv > 1 then Sys.argv.(1) else "stranger" in greet (if name = "Caesar" then Nicely else Badly) name; Printf.printf "My name is %s\n" Sys.argv.(0) ;; mingw-ocaml/ocaml/ocamlbuild/examples/example2/greet.ml0000644000175000017500000000027512124403240022567 0ustar tootstootstype how = Nicely | Badly;; let greet how who = match how with Nicely -> Printf.printf "Hello, %s !\n" who | Badly -> Printf.printf "Oh, here is that %s again.\n" who ;; mingw-ocaml/ocaml/ocamlbuild/examples/example3/0000755000175000017500000000000012124403240021124 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/examples/example3/epoch.ml0000644000175000017500000000037512124403240022561 0ustar tootstootslet _ = let s = Num.num_of_string (Printf.sprintf "%.0f" (Unix.gettimeofday ())) in let ps = Num.mult_num (Num.num_of_string "1000000000000") s in Printf.printf "%s picoseconds have passed since January 1st, 1970.\n" (Num.string_of_num ps) ;; mingw-ocaml/ocaml/ocamlbuild/examples/example3/make.sh0000755000175000017500000000070212124403240022377 0ustar tootstoots#!/bin/sh set -e TARGET=epoch FLAGS="-libs unix,nums" OCAMLBUILD=ocamlbuild ocb() { $OCAMLBUILD $FLAGS $* } rule() { case $1 in clean) ocb -clean;; native) ocb $TARGET.native;; byte) ocb $TARGET.byte;; all) ocb $TARGET.native $TARGET.byte;; depend) echo "Not needed.";; *) echo "Unknown action $1";; esac; } if [ $# -eq 0 ]; then rule all else while [ $# -gt 0 ]; do rule $1; shift done fi mingw-ocaml/ocaml/ocamlbuild/examples/example1/0000755000175000017500000000000012124403240021122 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/examples/example1/hello.ml0000644000175000017500000000021712124403240022557 0ustar tootstootslet _ = Printf.printf "Hello, %s ! My name is %s\n" (if Array.length Sys.argv > 1 then Sys.argv.(1) else "stranger") Sys.argv.(0) ;; mingw-ocaml/ocaml/ocamlbuild/log.ml0000644000175000017500000000351312124403240016705 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std module Debug = struct let mode _ = true end include Debug let level = ref 1 let classic_display = ref false let internal_display = ref None let failsafe_display = lazy (Display.create ~mode:`Classic ~log_level:!level ()) let ( !- ) r = match !r with | None -> !*failsafe_display | Some x -> x let init log_file = let mode = if !classic_display || !*My_unix.is_degraded || !level <= 0 || not (My_unix.stdout_isatty ()) then `Classic else `Sophisticated in internal_display := Some (Display.create ~mode ?log_file ~log_level:!level ()) let raw_dprintf log_level = Display.dprintf ~log_level !-internal_display let dprintf log_level fmt = raw_dprintf log_level ("@[<2>"^^fmt^^"@]@.") let eprintf fmt = dprintf (-1) fmt let update () = Display.update !-internal_display let event ?pretend x = Display.event !-internal_display ?pretend x let display x = Display.display !-internal_display x let finish ?how () = match !internal_display with | None -> () | Some d -> Display.finish ?how d (*let () = My_unix.at_exit_once finish*) mingw-ocaml/ocaml/ocamlbuild/ocamlbuildlight.mli0000644000175000017500000000143512124403240021441 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) (* Nothing *) mingw-ocaml/ocaml/ocamlbuild/ocaml_arch.ml0000644000175000017500000001237012124403240020215 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Command open Pathname.Operators type 'a arch = | Arch_dir of string * 'a * 'a arch list | Arch_dir_pack of string * 'a * 'a arch list | Arch_file of string * 'a let dir name contents = Arch_dir(name, (), contents) let dir_pack name contents = Arch_dir_pack(name, (), contents) let file name = Arch_file(name, ()) type info = { current_path : string; include_dirs : string list; for_pack : string; } let join_pack parent base = if parent = "" then base else parent ^ "." ^ base let annotate arch = let rec self arch acc = match arch with | Arch_dir_pack(name, _, contents) -> let acc = { (acc) with for_pack = join_pack acc.for_pack name } in let (_, _, i, new_contents) = self_contents name contents acc in ([], Arch_dir_pack(name, i, List.rev new_contents)) | Arch_dir(name, _, contents) -> let (current_path, include_dirs, i, new_contents) = self_contents name contents acc in (current_path :: include_dirs, Arch_dir(name, i, List.rev new_contents)) | Arch_file(name, _) -> ([], Arch_file(name, acc)) and self_contents name contents acc = let current_path = acc.current_path/name in let include_dirs = if current_path = "" then acc.include_dirs else current_path :: acc.include_dirs in let i = { (acc) with current_path = current_path; include_dirs = include_dirs } in let (include_dirs, new_contents) = List.fold_left begin fun (include_dirs, new_contents) x -> let j = { (i) with include_dirs = include_dirs @ i.include_dirs } in let (include_dirs', x') = self x j in (include_dirs @ include_dirs', x' :: new_contents) end ([], []) contents in (current_path, include_dirs, i, new_contents) in let init = { current_path = ""; include_dirs = []; for_pack = "" } in snd (self arch init) let rec print print_info f = let rec print_contents f = function | [] -> () | x :: xs -> Format.fprintf f "@ %a%a" (print print_info) x print_contents xs in function | Arch_dir(name, info, contents) -> Format.fprintf f "@[dir %S%a%a@]" name print_info info print_contents contents | Arch_dir_pack(name, info, contents) -> Format.fprintf f "@[dir_pack %S%a%a@]" name print_info info print_contents contents | Arch_file(name, info) -> Format.fprintf f "@[<2>file %S%a@]" name print_info info let print_include_dirs = List.print String.print let print_info f i = Format.fprintf f "@ @[{ @[<2>current_path =@ %S@];@\ \ @[<2>include_dirs =@ %a@];@\ \ @[<2>for_pack =@ %S@] }@]" i.current_path print_include_dirs i.include_dirs i.for_pack let rec iter_info f = function | Arch_dir_pack(_, i, xs) | Arch_dir(_, i, xs) -> f i; List.iter (iter_info f) xs | Arch_file(_, i) -> f i let rec fold_info f arch acc = match arch with | Arch_dir_pack(_, i, xs) | Arch_dir(_, i, xs) -> List.fold_right (fold_info f) xs (f i acc) | Arch_file(_, i) -> f i acc module SS = Set.Make(String) let iter_include_dirs arch = let set = fold_info (fun i -> List.fold_right SS.add i.include_dirs) arch SS.empty in fun f -> SS.iter f set let forpack_flags_of_pathname = ref (fun _ -> N) let print_table print_value f table = Format.fprintf f "@[{:@["; Hashtbl.iter begin fun k v -> if k <> "" then Format.fprintf f "@ @[<2>%S =>@ %a@];" k print_value v; end table; Format.fprintf f "@]@ :}@]" let print_tables f (include_dirs_table, for_pack_table) = Format.fprintf f "@[<2>@[<2>include_dirs_table:@ %a@];@ @[<2>for_pack_table: %a@]@]" (print_table (List.print String.print)) include_dirs_table (print_table String.print) for_pack_table let mk_tables arch = let include_dirs_table = Hashtbl.create 17 and for_pack_table = Hashtbl.create 17 in iter_info begin fun i -> Hashtbl.replace include_dirs_table i.current_path i.include_dirs; Hashtbl.replace for_pack_table i.current_path i.for_pack end arch; let previous_forpack_flags_of_pathname = !forpack_flags_of_pathname in forpack_flags_of_pathname := begin fun m -> let m' = Pathname.dirname m in try let for_pack = Hashtbl.find for_pack_table m' in if for_pack = "" then N else S[A"-for-pack"; A for_pack] with Not_found -> previous_forpack_flags_of_pathname m end; (* Format.eprintf "@[<2>%a@]@." print_tables (include_dirs_table, for_pack_table); *) (include_dirs_table, for_pack_table) let forpack_flags_of_pathname m = !forpack_flags_of_pathname m mingw-ocaml/ocaml/ocamlbuild/tools.mli0000644000175000017500000000167212124403240017441 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) (* Tools *) val tags_of_pathname : Pathname.t -> Tags.t val path_and_context_of_string : Pathname.t -> Pathname.t list val pp_l : Format.formatter -> string list -> unit mingw-ocaml/ocaml/ocamlbuild/shell.mli0000644000175000017500000000245012124403240017403 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) val is_simple_filename : string -> bool val quote_filename_if_needed : string -> string (** This will quote using Unix conventions, even on Windows, because commands are * always run through bash -c on Windows. *) val chdir : string -> unit val rm : string -> unit val rm_f : string -> unit val rm_rf : string -> unit val mkdir : string -> unit val try_mkdir : string -> unit val mkdir_p : string -> unit val cp : string -> string -> unit val mv : string -> string -> unit val readlink : string -> string val is_link : string -> bool mingw-ocaml/ocaml/ocamlbuild/tools.ml0000644000175000017500000000303312124403240017261 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) (* Tools *) open My_std open Format open Log open Pathname.Operators open Tags.Operators open Rule let pp_l = List.print String.print let tags_of_pathname p = Configuration.tags_of_filename (Pathname.to_string p) ++("file:"^p) ++("extension:"^Pathname.get_extension p) let opt_print elt ppf = function | Some x -> fprintf ppf "@[<2>Some@ %a@]" elt x | None -> pp_print_string ppf "None" let path_and_context_of_string s = if Pathname.is_implicit s then let b = Pathname.basename s in let d = Pathname.dirname s in if d <> Pathname.current_dir_name then let () = Pathname.define_context d [d] in [s] else let include_dirs = Pathname.include_dirs_of d in List.map (fun include_dir -> include_dir/b) include_dirs else [s] mingw-ocaml/ocaml/ocamlbuild/glob_lexer.mll0000644000175000017500000000746612124403240020435 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Glob *) { open Bool;; open Glob_ast;; type token = | ATOM of pattern atom | AND | OR | NOT | LPAR | RPAR | TRUE | FALSE | EOF ;; let sf = Printf.sprintf;; let concat_patterns p1 p2 = match (p1,p2) with | (Epsilon,_) -> p2 | (_,Epsilon) -> p1 | (_,_) -> Concat(p1,p2) ;; let slash = Class(Atom('/','/'));; let not_slash = Class(Not(Atom('/','/')));; let any = Class True;; } let pattern_chars = ['a'-'z']|['A'-'Z']|'_'|'-'|['0'-'9']|'.' let space_chars = [' ' '\t' '\n' '\r' '\012'] rule token = parse | '<' { ATOM(Pattern(let (p,_) = parse_pattern ['>'] Epsilon lexbuf in p)) } | '"' { ATOM(Constant(parse_string (Buffer.create 32) lexbuf)) } | "and"|"AND"|"&" { AND } | "or"|"OR"|"|" { OR } | "not"|"NOT"|"~" { NOT } | "true"|"1" { TRUE } | "false"|"0" { FALSE } | "(" { LPAR } | ")" { RPAR } | space_chars+ { token lexbuf } | eof { EOF } and parse_pattern eof_chars p = parse | (pattern_chars+ as u) { parse_pattern eof_chars (concat_patterns p (Word u)) lexbuf } | '{' { let rec loop pl = let (p',c) = parse_pattern ['}';','] Epsilon lexbuf in let pl = p' :: pl in if c = ',' then loop pl else parse_pattern eof_chars (concat_patterns p (Union pl)) lexbuf in loop [] } | "[^" { let cl = Not(Or(parse_class [] lexbuf)) in parse_pattern eof_chars (concat_patterns p (Class cl)) lexbuf } | '[' { let cl = Or(parse_class [] lexbuf) in parse_pattern eof_chars (concat_patterns p (Class cl)) lexbuf } (* Random thought... **/* seems to be equal to True *) | "/**/" (* / | /\Sigma^*/ *) { let q = Union[slash; Concat(slash, Concat(Star any, slash)) ] in parse_pattern eof_chars (concat_patterns p q) lexbuf } | "/**" (* \varepsilon | /\Sigma^* *) { let q = Union[Epsilon; Concat(slash, Star any)] in parse_pattern eof_chars (concat_patterns p q) lexbuf } | "**/" (* \varepsilon | \Sigma^*/ *) { let q = Union[Epsilon; Concat(Star any, slash)] in parse_pattern eof_chars (concat_patterns p q) lexbuf } | "**" { raise (Parse_error("Ambiguous ** pattern not allowed unless surrounded by one or more slashes")) } | '*' { parse_pattern eof_chars (concat_patterns p (Star not_slash)) lexbuf } | '/' { parse_pattern eof_chars (concat_patterns p slash) lexbuf } | '?' { parse_pattern eof_chars (concat_patterns p not_slash) lexbuf } | _ as c { if List.mem c eof_chars then (p,c) else raise (Parse_error(sf "Unexpected character %C in glob pattern" c)) } and parse_string b = parse | "\"" { Buffer.contents b } | "\\\"" { Buffer.add_char b '"'; parse_string b lexbuf } | [^'"' '\\']+ as u { Buffer.add_string b u; parse_string b lexbuf } | _ as c { raise (Parse_error(sf "Unexpected character %C in string" c)) } and parse_class cl = parse | ']' { cl } | "-]" { ((Atom('-','-'))::cl) } | (_ as c1) '-' (_ as c2) { parse_class ((Atom(c1,c2))::cl) lexbuf } | _ as c { parse_class ((Atom(c,c))::cl) lexbuf } mingw-ocaml/ocaml/ocamlbuild/fda.mli0000644000175000017500000000153212124403240017026 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Fda *) exception Exit_hygiene_failed val inspect : bool Slurp.entry -> unit mingw-ocaml/ocaml/ocamlbuild/ocamlbuild_unix_plugin.mli0000644000175000017500000000145012124403240023027 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) val setup : unit -> unit mingw-ocaml/ocaml/ocamlbuild/report.ml0000644000175000017500000000463412124403240017444 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Report *) open My_std open Log open Format open Solver let sources_glob = Glob.parse "<*.ml> or <*.mli> or <*.c> or <*.h>";; let rec analyze f bt = match bt with | Leaf r -> fprintf f "Ocamlbuild knows of no rules that apply to a target named %a. \ This can happen if you ask Ocamlbuild to build a target with the \ wrong extension (e.g. .opt instead of .native) or if the source \ files live in directories that have not been specified as \ include directories." Resource.print r; false | Depth(r, bt) -> if Glob.eval sources_glob r then begin fprintf f "Ocamlbuild cannot find or build %a. A file with such a name would \ usually be a source file. I suspect you have given a wrong target \ name to Ocamlbuild." Resource.print r; false end else analyze f bt | Choice bl -> List.for_all (analyze f) bl | Target(_, bt) -> analyze f bt let rec print_backtrace f = function | Target (name, backtrace) -> fprintf f "@\n- @[<2>Failed to build the target %s%a@]" name print_backtrace backtrace | Leaf r -> fprintf f "@\n- @[<2>Building %a@]" Resource.print r | Depth (r, backtrace) -> fprintf f "@\n- @[Building %a:%a@]" Resource.print r print_backtrace backtrace | Choice [backtrace] -> print_backtrace f backtrace | Choice backtraces -> fprintf f "@\n- @[Failed to build all of these:"; List.iter (print_backtrace f) backtraces; fprintf f "@]" let print_backtrace_analyze f bt = ignore (analyze f bt) mingw-ocaml/ocaml/ocamlbuild/command.mli0000644000175000017500000000354212124403240017715 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) (* Command *) (** Provides an abstract type for easily building complex shell commands without making quotation mistakes. *) include Signatures.COMMAND with type tags = Tags.t and type pathname = string (** {6 For system use only, not for the casual user} *) val string_target_and_tags_of_command_spec : spec -> string * string * Tags.t val iter_tags : (Tags.t -> unit) -> t -> unit val fold_pathnames : (pathname -> 'a -> 'a) -> t -> 'a -> 'a (** Digest the given command. *) val digest : t -> Digest.t (** Maximum number of parallel jobs. *) val jobs : int ref (** Hook here the function that maps a set of tags to appropriate command options. It also build the dependencies that matches the tags. *) val tag_handler : (Tags.t -> spec) ref (** For system use only *) val dump_parallel_stats : unit -> unit val deps_of_tags : Tags.t -> pathname list (** [dep tags deps] Will build [deps] when [tags] will be activated. *) val dep : Tags.elt list -> pathname list -> unit val pdep : Tags.elt list -> Tags.elt -> (string -> pathname list) -> unit val file_or_exe_exists: string -> bool mingw-ocaml/ocaml/ocamlbuild/test/0000755000175000017500000000000012124403240016547 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test10/0000755000175000017500000000000012124403240017667 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test10/dbdi0000644000175000017500000000037712124403240020523 0ustar tootstoots#load "discard_printf.cmo";; #load "debug.cmo";; #load "unix.cma";; #load "str.cma";; #load "my_unix.cmo";; #load "bool.cmo";; #load "glob_ast.cmo";; #load "glob_lexer.cmo";; #load "glob.cmo";; #load "lexers.cmo";; #load "my_std.cmo";; #load "tags.cmo";; mingw-ocaml/ocaml/ocamlbuild/test/test10/test.sh0000755000175000017500000000026312124403240021206 0ustar tootstoots#!/bin/sh set -e set -x cd `dirname $0`/../.. ./_build/ocamlbuild.native -quiet -build-dir _buildtest -no-links test/test9/testglob.native ./_buildtest/test/test9/testglob.native mingw-ocaml/ocaml/ocamlbuild/test/good-output0000644000175000017500000014543412124403240020773 0ustar tootstoots _____ _ ____ |_ _|__ ___| |_|___ \ | |/ _ \/ __| __| __) | | | __/\__ \ |_ / __/ |_|\___||___/\__|_____| + CMDOPTS='-- -help' + BUILD='../../_build/ocamlbuild.native toto.byte toto.native -no-skip -classic-display ' + BUILD1='../../_build/ocamlbuild.native toto.byte toto.native -no-skip -classic-display -- -help' + BUILD2='../../_build/ocamlbuild.native toto.byte toto.native -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt -- -help' + rm -rf _build + cp vivi1.ml vivi.ml + ../../_build/ocamlbuild.native toto.byte toto.native -no-skip -classic-display -- -help ocamldep.opt -modules toto.ml > toto.ml.depends ocamldep.opt -modules tata.mli > tata.mli.depends ocamldep.opt -modules titi.ml > titi.ml.depends ocamldep.opt -modules tutu.mli > tutu.mli.depends ocamlc.opt -c -o tata.cmi tata.mli ocamlc.opt -c -o titi.cmo titi.ml ocamlc.opt -c -o tutu.cmi tutu.mli ocamlc.opt -c -o toto.cmo toto.ml ocamldep.opt -modules tata.ml > tata.ml.depends ocamldep.opt -modules tutu.ml > tutu.ml.depends ocamldep.opt -modules tyty.mli > tyty.mli.depends ocamldep.opt -pp camlp4o -modules vivi.ml > vivi.ml.depends ocamlc.opt -c -o tyty.cmi tyty.mli ocamlc.opt -c -pp camlp4o -o vivi.cmo vivi.ml ocamlc.opt -c -o tata.cmo tata.ml ocamlc.opt -c -o tutu.cmo tutu.ml ocamlc.opt tata.cmo titi.cmo vivi.cmo tutu.cmo toto.cmo -o toto.byte ocamlopt.opt -c -pp camlp4o -o vivi.cmx vivi.ml ocamlopt.opt -c -o tata.cmx tata.ml ocamlopt.opt -c -o titi.cmx titi.ml ocamlopt.opt -c -o tutu.cmx tutu.ml ocamlopt.opt -c -o toto.cmx toto.ml ocamlopt.opt tata.cmx titi.cmx vivi.cmx tutu.cmx toto.cmx -o toto.native Warning: Using -- only run the last target toto.native: _build/toto.native: Hello world!!! Tutu.tutu => 1 Tata.tata => "TATA2" + ../../_build/ocamlbuild.native toto.byte toto.native -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt -- -help [cache hit] ocamldep.opt -modules toto.ml > toto.ml.depends [cache hit] ocamldep.opt -modules tata.mli > tata.mli.depends [cache hit] ocamlc.opt -c -o tata.cmi tata.mli [cache hit] ocamldep.opt -modules titi.ml > titi.ml.depends [cache hit] ocamlc.opt -c -o titi.cmo titi.ml [cache hit] ocamldep.opt -modules tutu.mli > tutu.mli.depends [cache hit] ocamlc.opt -c -o tutu.cmi tutu.mli [cache hit] ocamlc.opt -c -o toto.cmo toto.ml [cache hit] ocamldep.opt -modules tata.ml > tata.ml.depends [cache hit] ocamlc.opt -c -o tata.cmo tata.ml [cache hit] ocamldep.opt -modules tutu.ml > tutu.ml.depends [cache hit] ocamldep.opt -modules tyty.mli > tyty.mli.depends [cache hit] ocamlc.opt -c -o tyty.cmi tyty.mli [cache hit] ocamldep.opt -pp camlp4o -modules vivi.ml > vivi.ml.depends [cache hit] ocamlc.opt -c -pp camlp4o -o vivi.cmo vivi.ml [cache hit] ocamlc.opt -c -o tutu.cmo tutu.ml [cache hit] ocamlc.opt tata.cmo titi.cmo vivi.cmo tutu.cmo toto.cmo -o toto.byte [cache hit] ocamlopt.opt -c -o tata.cmx tata.ml [cache hit] ocamlopt.opt -c -o titi.cmx titi.ml [cache hit] ocamlopt.opt -c -pp camlp4o -o vivi.cmx vivi.ml [cache hit] ocamlopt.opt -c -o tutu.cmx tutu.ml [cache hit] ocamlopt.opt -c -o toto.cmx toto.ml [cache hit] ocamlopt.opt tata.cmx titi.cmx vivi.cmx tutu.cmx toto.cmx -o toto.native Warning: Using -- only run the last target toto.native: _build/toto.native: Hello world!!! Tutu.tutu => 1 Tata.tata => "TATA2" + cp vivi2.ml vivi.ml + ../../_build/ocamlbuild.native toto.byte toto.native -no-skip -classic-display -- -help ocamldep.opt -pp camlp4o -modules vivi.ml > vivi.ml.depends ocamlc.opt -c -pp camlp4o -o vivi.cmo vivi.ml ocamlc.opt tata.cmo titi.cmo vivi.cmo tutu.cmo toto.cmo -o toto.byte ocamlopt.opt -c -pp camlp4o -o vivi.cmx vivi.ml ocamlopt.opt tata.cmx titi.cmx vivi.cmx tutu.cmx toto.cmx -o toto.native Warning: Using -- only run the last target toto.native: _build/toto.native: Hello world!!! Tutu.tutu => 1 Tata.tata => "TATA2" + ../../_build/ocamlbuild.native toto.byte toto.native -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt -- -help [cache hit] ocamldep.opt -modules toto.ml > toto.ml.depends [cache hit] ocamldep.opt -modules tata.mli > tata.mli.depends [cache hit] ocamlc.opt -c -o tata.cmi tata.mli [cache hit] ocamldep.opt -modules titi.ml > titi.ml.depends [cache hit] ocamlc.opt -c -o titi.cmo titi.ml [cache hit] ocamldep.opt -modules tutu.mli > tutu.mli.depends [cache hit] ocamlc.opt -c -o tutu.cmi tutu.mli [cache hit] ocamlc.opt -c -o toto.cmo toto.ml [cache hit] ocamldep.opt -modules tata.ml > tata.ml.depends [cache hit] ocamlc.opt -c -o tata.cmo tata.ml [cache hit] ocamldep.opt -modules tutu.ml > tutu.ml.depends [cache hit] ocamldep.opt -modules tyty.mli > tyty.mli.depends [cache hit] ocamlc.opt -c -o tyty.cmi tyty.mli [cache hit] ocamldep.opt -pp camlp4o -modules vivi.ml > vivi.ml.depends [cache hit] ocamlc.opt -c -pp camlp4o -o vivi.cmo vivi.ml [cache hit] ocamlc.opt -c -o tutu.cmo tutu.ml [cache hit] ocamlc.opt tata.cmo titi.cmo vivi.cmo tutu.cmo toto.cmo -o toto.byte [cache hit] ocamlopt.opt -c -o tata.cmx tata.ml [cache hit] ocamlopt.opt -c -o titi.cmx titi.ml [cache hit] ocamlopt.opt -c -pp camlp4o -o vivi.cmx vivi.ml [cache hit] ocamlopt.opt -c -o tutu.cmx tutu.ml [cache hit] ocamlopt.opt -c -o toto.cmx toto.ml [cache hit] ocamlopt.opt tata.cmx titi.cmx vivi.cmx tutu.cmx toto.cmx -o toto.native Warning: Using -- only run the last target toto.native: _build/toto.native: Hello world!!! Tutu.tutu => 1 Tata.tata => "TATA2" + cp vivi3.ml vivi.ml + ../../_build/ocamlbuild.native toto.byte toto.native -no-skip -classic-display -- -help ocamldep.opt -pp camlp4o -modules vivi.ml > vivi.ml.depends ocamlc.opt -c -pp camlp4o -o vivi.cmo vivi.ml ocamlc.opt -c -o tutu.cmo tutu.ml ocamlc.opt tata.cmo titi.cmo vivi.cmo tutu.cmo toto.cmo -o toto.byte ocamlopt.opt -c -pp camlp4o -o vivi.cmx vivi.ml ocamlopt.opt -c -o tutu.cmx tutu.ml ocamlopt.opt -c -o toto.cmx toto.ml ocamlopt.opt tata.cmx titi.cmx vivi.cmx tutu.cmx toto.cmx -o toto.native Warning: Using -- only run the last target toto.native: _build/toto.native: Hello world!!! Tutu.tutu => 2 Tata.tata => "TATA2" + ../../_build/ocamlbuild.native toto.byte toto.native -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt -- -help [cache hit] ocamldep.opt -modules toto.ml > toto.ml.depends [cache hit] ocamldep.opt -modules tata.mli > tata.mli.depends [cache hit] ocamlc.opt -c -o tata.cmi tata.mli [cache hit] ocamldep.opt -modules titi.ml > titi.ml.depends [cache hit] ocamlc.opt -c -o titi.cmo titi.ml [cache hit] ocamldep.opt -modules tutu.mli > tutu.mli.depends [cache hit] ocamlc.opt -c -o tutu.cmi tutu.mli [cache hit] ocamlc.opt -c -o toto.cmo toto.ml [cache hit] ocamldep.opt -modules tata.ml > tata.ml.depends [cache hit] ocamlc.opt -c -o tata.cmo tata.ml [cache hit] ocamldep.opt -modules tutu.ml > tutu.ml.depends [cache hit] ocamldep.opt -modules tyty.mli > tyty.mli.depends [cache hit] ocamlc.opt -c -o tyty.cmi tyty.mli [cache hit] ocamldep.opt -pp camlp4o -modules vivi.ml > vivi.ml.depends [cache hit] ocamlc.opt -c -pp camlp4o -o vivi.cmo vivi.ml [cache hit] ocamlc.opt -c -o tutu.cmo tutu.ml [cache hit] ocamlc.opt tata.cmo titi.cmo vivi.cmo tutu.cmo toto.cmo -o toto.byte [cache hit] ocamlopt.opt -c -o tata.cmx tata.ml [cache hit] ocamlopt.opt -c -o titi.cmx titi.ml [cache hit] ocamlopt.opt -c -pp camlp4o -o vivi.cmx vivi.ml [cache hit] ocamlopt.opt -c -o tutu.cmx tutu.ml [cache hit] ocamlopt.opt -c -o toto.cmx toto.ml [cache hit] ocamlopt.opt tata.cmx titi.cmx vivi.cmx tutu.cmx toto.cmx -o toto.native Warning: Using -- only run the last target toto.native: _build/toto.native: Hello world!!! Tutu.tutu => 2 Tata.tata => "TATA2" _____ _ _____ |_ _|__ ___| |_|___ / | |/ _ \/ __| __| |_ \ | | __/\__ \ |_ ___) | |_|\___||___/\__|____/ + CMDOTPS= + BUILD='../../_build/ocamlbuild.native a.byte a.native proj.docdir/index.html -no-skip -classic-display ' + BUILD1='../../_build/ocamlbuild.native a.byte a.native proj.docdir/index.html -no-skip -classic-display ' + BUILD2='../../_build/ocamlbuild.native a.byte a.native proj.docdir/index.html -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt ' + rm -rf _build + ../../_build/ocamlbuild.native a.byte a.native proj.docdir/index.html -no-skip -classic-display ocamldep.opt -modules a.mli > a.mli.depends ocamlc.opt -c -o a.cmi a.mli ocamldep.opt -modules a.ml > a.ml.depends ocamldep.opt -modules b.mli > b.mli.depends ocamlc.opt -c -o b.cmi b.mli ocamlc.opt -c -o a.cmo a.ml ocamldep.opt -modules b.ml > b.ml.depends ocamldep.opt -modules c.mli > c.mli.depends ocamlc.opt -c -o c.cmi c.mli ocamlc.opt -c -o b.cmo b.ml ocamldep.opt -modules c.ml > c.ml.depends ocamldep.opt -modules d.mli > d.mli.depends ocamlc.opt -c -o d.cmi d.mli ocamlc.opt -c -o c.cmo c.ml ocamldep.opt -modules d.ml > d.ml.depends ocamldep.opt -modules e.mli > e.mli.depends ocamlc.opt -c -o e.cmi e.mli ocamlc.opt -c -o d.cmo d.ml ocamldep.opt -modules e.ml > e.ml.depends ocamldep.opt -modules f.mli > f.mli.depends ocamlc.opt -c -o f.cmi f.mli ocamlc.opt -c -o e.cmo e.ml ocamldep.opt -modules f.ml > f.ml.depends ocamlc.opt -c -o f.cmo f.ml ocamlc.opt unix.cma f.cmo e.cmo d.cmo c.cmo b.cmo a.cmo -o a.byte ocamlopt.opt -c -o f.cmx f.ml ocamlopt.opt -c -o e.cmx e.ml ocamlopt.opt -c -o d.cmx d.ml ocamlopt.opt -c -o c.cmx c.ml ocamlopt.opt -c -o b.cmx b.ml ocamlopt.opt -c -o a.cmx a.ml ocamlopt.opt unix.cmxa f.cmx e.cmx d.cmx c.cmx b.cmx a.cmx -o a.native ocamldoc.opt -dump a.odoc a.mli ocamldoc.opt -dump b.odoc b.mli ocamldoc.opt -dump c.odoc c.mli ocamldoc.opt -dump d.odoc d.mli ocamldoc.opt -dump e.odoc e.mli ocamldoc.opt -dump f.odoc f.mli rm -rf proj.docdir mkdir -p proj.docdir ocamldoc.opt -load a.odoc -load b.odoc -load c.odoc -load d.odoc -load e.odoc -load f.odoc -html -d proj.docdir + ../../_build/ocamlbuild.native a.byte a.native proj.docdir/index.html -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt [cache hit] ocamldep.opt -modules a.mli > a.mli.depends [cache hit] ocamlc.opt -c -o a.cmi a.mli [cache hit] ocamldep.opt -modules a.ml > a.ml.depends [cache hit] ocamldep.opt -modules b.mli > b.mli.depends [cache hit] ocamlc.opt -c -o b.cmi b.mli [cache hit] ocamlc.opt -c -o a.cmo a.ml [cache hit] ocamldep.opt -modules b.ml > b.ml.depends [cache hit] ocamldep.opt -modules c.mli > c.mli.depends [cache hit] ocamlc.opt -c -o c.cmi c.mli [cache hit] ocamlc.opt -c -o b.cmo b.ml [cache hit] ocamldep.opt -modules c.ml > c.ml.depends [cache hit] ocamldep.opt -modules d.mli > d.mli.depends [cache hit] ocamlc.opt -c -o d.cmi d.mli [cache hit] ocamlc.opt -c -o c.cmo c.ml [cache hit] ocamldep.opt -modules d.ml > d.ml.depends [cache hit] ocamldep.opt -modules e.mli > e.mli.depends [cache hit] ocamlc.opt -c -o e.cmi e.mli [cache hit] ocamlc.opt -c -o d.cmo d.ml [cache hit] ocamldep.opt -modules e.ml > e.ml.depends [cache hit] ocamldep.opt -modules f.mli > f.mli.depends [cache hit] ocamlc.opt -c -o f.cmi f.mli [cache hit] ocamlc.opt -c -o e.cmo e.ml [cache hit] ocamldep.opt -modules f.ml > f.ml.depends [cache hit] ocamlc.opt -c -o f.cmo f.ml [cache hit] ocamlc.opt unix.cma f.cmo e.cmo d.cmo c.cmo b.cmo a.cmo -o a.byte [cache hit] ocamlopt.opt -c -o f.cmx f.ml [cache hit] ocamlopt.opt -c -o e.cmx e.ml [cache hit] ocamlopt.opt -c -o d.cmx d.ml [cache hit] ocamlopt.opt -c -o c.cmx c.ml [cache hit] ocamlopt.opt -c -o b.cmx b.ml [cache hit] ocamlopt.opt -c -o a.cmx a.ml [cache hit] ocamlopt.opt unix.cmxa f.cmx e.cmx d.cmx c.cmx b.cmx a.cmx -o a.native [cache hit] ocamldoc.opt -dump a.odoc a.mli [cache hit] ocamldoc.opt -dump b.odoc b.mli [cache hit] ocamldoc.opt -dump c.odoc c.mli [cache hit] ocamldoc.opt -dump d.odoc d.mli [cache hit] ocamldoc.opt -dump e.odoc e.mli [cache hit] ocamldoc.opt -dump f.odoc f.mli [cache hit] rm -rf proj.docdir [cache hit] mkdir -p proj.docdir [cache hit] ocamldoc.opt -load a.odoc -load b.odoc -load c.odoc -load d.odoc -load e.odoc -load f.odoc -html -d proj.docdir _____ _ _ _ |_ _|__ ___| |_| || | | |/ _ \/ __| __| || |_ | | __/\__ \ |_|__ _| |_|\___||___/\__| |_| + CMDOTPS= + BUILD='../../_build/ocamlbuild.native -I a -I b aa.byte aa.native -no-skip -classic-display ' + BUILD1='../../_build/ocamlbuild.native -I a -I b aa.byte aa.native -no-skip -classic-display ' + BUILD2='../../_build/ocamlbuild.native -I a -I b aa.byte aa.native -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt ' + rm -rf _build + ../../_build/ocamlbuild.native -I a -I b aa.byte aa.native -no-skip -classic-display ocamldep.opt -modules a/aa.mli > a/aa.mli.depends ocamlc.opt -c -I a -I b -o a/aa.cmi a/aa.mli ocamldep.opt -modules a/aa.ml > a/aa.ml.depends ocamldep.opt -modules b/bb.ml > b/bb.ml.depends ocamlc.opt -c -I b -I a -o b/bb.cmo b/bb.ml ocamlc.opt -c -I a -I b -o a/aa.cmo a/aa.ml ocamlc.opt str.cma b/bb.cmo a/aa.cmo -o a/aa.byte ocamlopt.opt -c -I b -I a -o b/bb.cmx b/bb.ml ocamlopt.opt -c -I a -I b -o a/aa.cmx a/aa.ml ocamlopt.opt str.cmxa b/bb.cmx a/aa.cmx -o a/aa.native + ../../_build/ocamlbuild.native -I a -I b aa.byte aa.native -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt [cache hit] ocamldep.opt -modules a/aa.mli > a/aa.mli.depends [cache hit] ocamlc.opt -c -I a -I b -o a/aa.cmi a/aa.mli [cache hit] ocamldep.opt -modules a/aa.ml > a/aa.ml.depends [cache hit] ocamldep.opt -modules b/bb.ml > b/bb.ml.depends [cache hit] ocamlc.opt -c -I b -I a -o b/bb.cmo b/bb.ml [cache hit] ocamlc.opt -c -I a -I b -o a/aa.cmo a/aa.ml [cache hit] ocamlc.opt str.cma b/bb.cmo a/aa.cmo -o a/aa.byte [cache hit] ocamlopt.opt -c -I b -I a -o b/bb.cmx b/bb.ml [cache hit] ocamlopt.opt -c -I a -I b -o a/aa.cmx a/aa.ml [cache hit] ocamlopt.opt str.cmxa b/bb.cmx a/aa.cmx -o a/aa.native _____ _ ____ |_ _|__ ___| |_| ___| | |/ _ \/ __| __|___ \ | | __/\__ \ |_ ___) | |_|\___||___/\__|____/ + CMDOPTS= + BUILD='../../_build/ocamlbuild.native d.byte d.native -no-skip -classic-display ' + BUILD1='../../_build/ocamlbuild.native d.byte d.native -no-skip -classic-display ' + BUILD2='../../_build/ocamlbuild.native d.byte d.native -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt ' + rm -rf _build + ../../_build/ocamlbuild.native d.byte d.native -no-skip -classic-display ocamldep.opt -modules d.ml > d.ml.depends ocamldep.opt -modules a.mli > a.mli.depends ocamlc.opt -c -o a.cmi a.mli ocamldep.opt -modules a.ml > a.ml.depends ocamldep.opt -modules stack.ml > stack.ml.depends ocamlc.opt -c -o stack.cmo stack.ml ocamldep.opt -modules b.ml > b.ml.depends ocamlc.opt -c -o a.cmo a.ml ocamlc.opt -c -o b.cmo b.ml ocamlc.opt -pack a.cmo b.cmo -o c.cmo ocamlc.opt -c -o d.cmo d.ml ocamlc.opt stack.cmo c.cmo d.cmo -o d.byte ocamlopt.opt -c -o stack.cmx stack.ml ocamlopt.opt -c -for-pack C -o a.cmx a.ml ocamlopt.opt -c -for-pack C -o b.cmx b.ml touch c.mli ; if ocamlopt.opt -pack a.cmx b.cmx -o c.cmx ; then rm -f c.mli ; else rm -f c.mli ; exit 1; fi ocamlopt.opt -c -o d.cmx d.ml ocamlopt.opt stack.cmx c.cmx d.cmx -o d.native + ../../_build/ocamlbuild.native d.byte d.native -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt [cache hit] ocamldep.opt -modules d.ml > d.ml.depends [cache hit] ocamldep.opt -modules a.mli > a.mli.depends [cache hit] ocamlc.opt -c -o a.cmi a.mli [cache hit] ocamldep.opt -modules a.ml > a.ml.depends [cache hit] ocamldep.opt -modules stack.ml > stack.ml.depends [cache hit] ocamlc.opt -c -o stack.cmo stack.ml [cache hit] ocamlc.opt -c -o a.cmo a.ml [cache hit] ocamldep.opt -modules b.ml > b.ml.depends [cache hit] ocamlc.opt -c -o b.cmo b.ml [cache hit] ocamlc.opt -pack a.cmo b.cmo -o c.cmo [cache hit] ocamlc.opt -c -o d.cmo d.ml [cache hit] ocamlc.opt stack.cmo c.cmo d.cmo -o d.byte [cache hit] ocamlopt.opt -c -o stack.cmx stack.ml [cache hit] ocamlopt.opt -c -for-pack C -o a.cmx a.ml [cache hit] ocamlopt.opt -c -for-pack C -o b.cmx b.ml [cache hit] touch c.mli ; if ocamlopt.opt -pack a.cmx b.cmx -o c.cmx ; then rm -f c.mli ; else rm -f c.mli ; exit 1; fi [cache hit] ocamlopt.opt -c -o d.cmx d.ml [cache hit] ocamlopt.opt stack.cmx c.cmx d.cmx -o d.native _____ _ __ |_ _|__ ___| |_ / /_ | |/ _ \/ __| __| '_ \ | | __/\__ \ |_| (_) | |_|\___||___/\__|\___/ + rm -rf _build + CMDOPTS= + BUILD='../../_build/ocamlbuild.native -no-skip main.byte -classic-display ' + BUILD1='../../_build/ocamlbuild.native -no-skip main.byte -classic-display ' + BUILD2='../../_build/ocamlbuild.native -no-skip main.byte -classic-display -verbose 0 -nothing-should-be-rebuilt ' + cp b.mli.v1 b.mli + cp d.mli.v1 d.mli + ../../_build/ocamlbuild.native -no-skip main.byte -classic-display ocamldep.opt -modules main.mli > main.mli.depends ocamlc.opt -c -o main.cmi main.mli ocamldep.opt -modules main.ml > main.ml.depends ocamldep.opt -modules a.mli > a.mli.depends ocamldep.opt -modules d.mli > d.mli.depends ocamlc.opt -c -o a.cmi a.mli ocamlc.opt -c -o d.cmi d.mli ocamlc.opt -c -o main.cmo main.ml ocamldep.opt -modules a.ml > a.ml.depends ocamldep.opt -modules b.mli > b.mli.depends ocamlc.opt -c -o b.cmi b.mli ocamldep.opt -modules d.ml > d.ml.depends ocamlc.opt -c -o a.cmo a.ml ocamlc.opt -c -o d.cmo d.ml ocamldep.opt -modules b.ml > b.ml.depends ocamlc.opt -c -o b.cmo b.ml ocamlc.opt d.cmo b.cmo a.cmo main.cmo -o main.byte + ../../_build/ocamlbuild.native -no-skip main.byte -classic-display -verbose 0 -nothing-should-be-rebuilt [cache hit] ocamldep.opt -modules main.mli > main.mli.depends [cache hit] ocamlc.opt -c -o main.cmi main.mli [cache hit] ocamldep.opt -modules main.ml > main.ml.depends [cache hit] ocamldep.opt -modules a.mli > a.mli.depends [cache hit] ocamlc.opt -c -o a.cmi a.mli [cache hit] ocamldep.opt -modules d.mli > d.mli.depends [cache hit] ocamlc.opt -c -o d.cmi d.mli [cache hit] ocamlc.opt -c -o main.cmo main.ml [cache hit] ocamldep.opt -modules a.ml > a.ml.depends [cache hit] ocamldep.opt -modules b.mli > b.mli.depends [cache hit] ocamlc.opt -c -o b.cmi b.mli [cache hit] ocamlc.opt -c -o a.cmo a.ml [cache hit] ocamldep.opt -modules d.ml > d.ml.depends [cache hit] ocamlc.opt -c -o d.cmo d.ml [cache hit] ocamldep.opt -modules b.ml > b.ml.depends [cache hit] ocamlc.opt -c -o b.cmo b.ml [cache hit] ocamlc.opt d.cmo b.cmo a.cmo main.cmo -o main.byte + cp b.mli.v2 b.mli + cp d.mli.v2 d.mli + ../../_build/ocamlbuild.native -no-skip main.byte -classic-display ocamldep.opt -modules d.mli > d.mli.depends ocamlc.opt -c -o d.cmi d.mli ocamlc.opt -c -o main.cmo main.ml ocamldep.opt -modules b.mli > b.mli.depends + ocamldep.opt -modules b.mli > b.mli.depends File "b.mli", line 1, characters 0-2: Syntax error Command exited with code 2. + cp b.mli.v1 b.mli + ../../_build/ocamlbuild.native -no-skip main.byte -classic-display ocamldep.opt -modules b.mli > b.mli.depends ocamlc.opt -c -o b.cmi b.mli ocamlc.opt -c -o d.cmo d.ml ocamlc.opt -c -o b.cmo b.ml ocamlc.opt d.cmo b.cmo a.cmo main.cmo -o main.byte + ../../_build/ocamlbuild.native -no-skip main.byte -classic-display -verbose 0 -nothing-should-be-rebuilt [cache hit] ocamldep.opt -modules main.mli > main.mli.depends [cache hit] ocamlc.opt -c -o main.cmi main.mli [cache hit] ocamldep.opt -modules main.ml > main.ml.depends [cache hit] ocamldep.opt -modules a.mli > a.mli.depends [cache hit] ocamlc.opt -c -o a.cmi a.mli [cache hit] ocamldep.opt -modules d.mli > d.mli.depends [cache hit] ocamlc.opt -c -o d.cmi d.mli [cache hit] ocamlc.opt -c -o main.cmo main.ml [cache hit] ocamldep.opt -modules a.ml > a.ml.depends [cache hit] ocamldep.opt -modules b.mli > b.mli.depends [cache hit] ocamlc.opt -c -o b.cmi b.mli [cache hit] ocamlc.opt -c -o a.cmo a.ml [cache hit] ocamldep.opt -modules d.ml > d.ml.depends [cache hit] ocamlc.opt -c -o d.cmo d.ml [cache hit] ocamldep.opt -modules b.ml > b.ml.depends [cache hit] ocamlc.opt -c -o b.cmo b.ml [cache hit] ocamlc.opt d.cmo b.cmo a.cmo main.cmo -o main.byte + echo PASS PASS _____ _ _____ |_ _|__ ___| ||___ | | |/ _ \/ __| __| / / | | __/\__ \ |_ / / |_|\___||___/\__/_/ + CMDOPTS= + BUILD='../../_build/ocamlbuild.native bbcc.cma main.byte bbcc.cmxa main.native -no-skip -classic-display ' + BUILD1='../../_build/ocamlbuild.native bbcc.cma main.byte bbcc.cmxa main.native -no-skip -classic-display ' + BUILD2='../../_build/ocamlbuild.native bbcc.cma main.byte bbcc.cmxa main.native -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt ' + rm -rf _build + cp bb1.ml bb.ml + ../../_build/ocamlbuild.native bbcc.cma main.byte bbcc.cmxa main.native -no-skip -classic-display ocamlopt.opt -I /Users/ertai/l/ocaml/ocamlbuild-unstable/ocamlbuild/_install/lib/ocamlbuild unix.cmxa /Users/ertai/l/ocaml/ocamlbuild-unstable/ocamlbuild/_install/lib/ocamlbuild/ocamlbuildlib.cmxa myocamlbuild.ml /Users/ertai/l/ocaml/ocamlbuild-unstable/ocamlbuild/_install/lib/ocamlbuild/ocamlbuild.cmx -o myocamlbuild ocamldep.opt -modules bb.mli > bb.mli.depends ocamlc.opt -c -o bb.cmi bb.mli ocamldep.opt -modules bb.ml > bb.ml.depends ocamldep.opt -modules cc.ml > cc.ml.depends ocamldep.opt -modules aa.ml > aa.ml.depends ocamldep.opt -modules c2.mli > c2.mli.depends ocamlc.opt -c -o aa.cmo aa.ml ocamlc.opt -c -o c2.cmi c2.mli ocamlc.opt -c -o bb.cmo bb.ml ocamlc.opt -c -o cc.cmo cc.ml ocamlc.opt -a bb.cmo cc.cmo -o bbcc.cma ocamldep.opt -modules main.ml > main.ml.depends ocamldep.opt -modules c3.ml > c3.ml.depends ocamlc.opt -c -o c3.cmo c3.ml ocamlc.opt -c -o main.cmo main.ml ocamldep.opt -modules cool_plugin.ml > cool_plugin.ml.depends ocamlc.opt -c -o cool_plugin.cmo cool_plugin.ml ocamldep.opt -modules c2.ml > c2.ml.depends ocamlc.opt -c -o c2.cmo c2.ml ocamlc.opt aa.cmo c2.cmo bbcc.cma c3.cmo main.cmo cool_plugin.cmo -o main.byte ocamlopt.opt -c -o bb.cmx bb.ml ocamlopt.opt -c -o aa.cmx aa.ml ocamlopt.opt -c -o c2.cmx c2.ml ocamlopt.opt -c -o cc.cmx cc.ml ocamlopt.opt -a bb.cmx cc.cmx -o bbcc.cmxa ocamlopt.opt -c -o c3.cmx c3.ml ocamlopt.opt -c -o main.cmx main.ml ocamlopt.opt aa.cmx c2.cmx bbcc.cmxa c3.cmx main.cmx -o main.native + ../../_build/ocamlbuild.native bbcc.cma main.byte bbcc.cmxa main.native -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt [cache hit] ocamldep.opt -modules bb.mli > bb.mli.depends [cache hit] ocamlc.opt -c -o bb.cmi bb.mli [cache hit] ocamldep.opt -modules bb.ml > bb.ml.depends [cache hit] ocamlc.opt -c -o bb.cmo bb.ml [cache hit] ocamldep.opt -modules cc.ml > cc.ml.depends [cache hit] ocamldep.opt -modules aa.ml > aa.ml.depends [cache hit] ocamlc.opt -c -o aa.cmo aa.ml [cache hit] ocamldep.opt -modules c2.mli > c2.mli.depends [cache hit] ocamlc.opt -c -o c2.cmi c2.mli [cache hit] ocamlc.opt -c -o cc.cmo cc.ml [cache hit] ocamlc.opt -a bb.cmo cc.cmo -o bbcc.cma [cache hit] ocamldep.opt -modules main.ml > main.ml.depends [cache hit] ocamldep.opt -modules c3.ml > c3.ml.depends [cache hit] ocamlc.opt -c -o c3.cmo c3.ml [cache hit] ocamlc.opt -c -o main.cmo main.ml [cache hit] ocamldep.opt -modules cool_plugin.ml > cool_plugin.ml.depends [cache hit] ocamlc.opt -c -o cool_plugin.cmo cool_plugin.ml [cache hit] ocamldep.opt -modules c2.ml > c2.ml.depends [cache hit] ocamlc.opt -c -o c2.cmo c2.ml [cache hit] ocamlc.opt aa.cmo c2.cmo bbcc.cma c3.cmo main.cmo cool_plugin.cmo -o main.byte [cache hit] ocamlopt.opt -c -o bb.cmx bb.ml [cache hit] ocamlopt.opt -c -o aa.cmx aa.ml [cache hit] ocamlopt.opt -c -o c2.cmx c2.ml [cache hit] ocamlopt.opt -c -o cc.cmx cc.ml [cache hit] ocamlopt.opt -a bb.cmx cc.cmx -o bbcc.cmxa [cache hit] ocamlopt.opt -c -o c3.cmx c3.ml [cache hit] ocamlopt.opt -c -o main.cmx main.ml [cache hit] ocamlopt.opt aa.cmx c2.cmx bbcc.cmxa c3.cmx main.cmx -o main.native + cp bb2.ml bb.ml + ../../_build/ocamlbuild.native bbcc.cma main.byte bbcc.cmxa main.native -no-skip -classic-display -verbose 0 [cache hit] ocamldep.opt -modules bb.mli > bb.mli.depends [cache hit] ocamlc.opt -c -o bb.cmi bb.mli ocamldep.opt -modules bb.ml > bb.ml.depends [cache hit] ocamldep.opt -modules cc.ml > cc.ml.depends [cache hit] ocamldep.opt -modules aa.ml > aa.ml.depends [cache hit] ocamlc.opt -c -o aa.cmo aa.ml [cache hit] ocamldep.opt -modules c2.mli > c2.mli.depends [cache hit] ocamlc.opt -c -o c2.cmi c2.mli [cache hit] ocamlc.opt -c -o cc.cmo cc.ml ocamlc.opt -c -o bb.cmo bb.ml ocamlc.opt -a bb.cmo cc.cmo -o bbcc.cma [cache hit] ocamldep.opt -modules main.ml > main.ml.depends [cache hit] ocamldep.opt -modules c3.ml > c3.ml.depends [cache hit] ocamlc.opt -c -o c3.cmo c3.ml [cache hit] ocamlc.opt -c -o main.cmo main.ml [cache hit] ocamldep.opt -modules cool_plugin.ml > cool_plugin.ml.depends [cache hit] ocamlc.opt -c -o cool_plugin.cmo cool_plugin.ml [cache hit] ocamldep.opt -modules c2.ml > c2.ml.depends [cache hit] ocamlc.opt -c -o c2.cmo c2.ml ocamlc.opt aa.cmo c2.cmo bbcc.cma c3.cmo main.cmo cool_plugin.cmo -o main.byte [cache hit] ocamlopt.opt -c -o aa.cmx aa.ml ocamlopt.opt -c -o bb.cmx bb.ml [cache hit] ocamlopt.opt -c -o c2.cmx c2.ml ocamlopt.opt -c -o cc.cmx cc.ml ocamlopt.opt -a bb.cmx cc.cmx -o bbcc.cmxa ocamlopt.opt -c -o c3.cmx c3.ml ocamlopt.opt -c -o main.cmx main.ml ocamlopt.opt aa.cmx c2.cmx bbcc.cmxa c3.cmx main.cmx -o main.native + ../../_build/ocamlbuild.native bbcc.cma main.byte bbcc.cmxa main.native -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt [cache hit] ocamldep.opt -modules bb.mli > bb.mli.depends [cache hit] ocamlc.opt -c -o bb.cmi bb.mli [cache hit] ocamldep.opt -modules bb.ml > bb.ml.depends [cache hit] ocamlc.opt -c -o bb.cmo bb.ml [cache hit] ocamldep.opt -modules cc.ml > cc.ml.depends [cache hit] ocamldep.opt -modules aa.ml > aa.ml.depends [cache hit] ocamlc.opt -c -o aa.cmo aa.ml [cache hit] ocamldep.opt -modules c2.mli > c2.mli.depends [cache hit] ocamlc.opt -c -o c2.cmi c2.mli [cache hit] ocamlc.opt -c -o cc.cmo cc.ml [cache hit] ocamlc.opt -a bb.cmo cc.cmo -o bbcc.cma [cache hit] ocamldep.opt -modules main.ml > main.ml.depends [cache hit] ocamldep.opt -modules c3.ml > c3.ml.depends [cache hit] ocamlc.opt -c -o c3.cmo c3.ml [cache hit] ocamlc.opt -c -o main.cmo main.ml [cache hit] ocamldep.opt -modules cool_plugin.ml > cool_plugin.ml.depends [cache hit] ocamlc.opt -c -o cool_plugin.cmo cool_plugin.ml [cache hit] ocamldep.opt -modules c2.ml > c2.ml.depends [cache hit] ocamlc.opt -c -o c2.cmo c2.ml [cache hit] ocamlc.opt aa.cmo c2.cmo bbcc.cma c3.cmo main.cmo cool_plugin.cmo -o main.byte [cache hit] ocamlopt.opt -c -o bb.cmx bb.ml [cache hit] ocamlopt.opt -c -o aa.cmx aa.ml [cache hit] ocamlopt.opt -c -o c2.cmx c2.ml [cache hit] ocamlopt.opt -c -o cc.cmx cc.ml [cache hit] ocamlopt.opt -a bb.cmx cc.cmx -o bbcc.cmxa [cache hit] ocamlopt.opt -c -o c3.cmx c3.ml [cache hit] ocamlopt.opt -c -o main.cmx main.ml [cache hit] ocamlopt.opt aa.cmx c2.cmx bbcc.cmxa c3.cmx main.cmx -o main.native + cp bb3.ml bb.ml + ../../_build/ocamlbuild.native bbcc.cma main.byte bbcc.cmxa main.native -no-skip -classic-display -verbose 0 [cache hit] ocamldep.opt -modules bb.mli > bb.mli.depends [cache hit] ocamlc.opt -c -o bb.cmi bb.mli ocamldep.opt -modules bb.ml > bb.ml.depends [cache hit] ocamldep.opt -modules cc.ml > cc.ml.depends [cache hit] ocamldep.opt -modules aa.ml > aa.ml.depends [cache hit] ocamlc.opt -c -o aa.cmo aa.ml [cache hit] ocamldep.opt -modules c2.mli > c2.mli.depends [cache hit] ocamlc.opt -c -o c2.cmi c2.mli [cache hit] ocamlc.opt -c -o cc.cmo cc.ml ocamlc.opt -c -o bb.cmo bb.ml ocamlc.opt -a bb.cmo cc.cmo -o bbcc.cma [cache hit] ocamldep.opt -modules main.ml > main.ml.depends [cache hit] ocamldep.opt -modules c3.ml > c3.ml.depends [cache hit] ocamlc.opt -c -o c3.cmo c3.ml [cache hit] ocamlc.opt -c -o main.cmo main.ml [cache hit] ocamldep.opt -modules cool_plugin.ml > cool_plugin.ml.depends [cache hit] ocamlc.opt -c -o cool_plugin.cmo cool_plugin.ml [cache hit] ocamldep.opt -modules c2.ml > c2.ml.depends [cache hit] ocamlc.opt -c -o c2.cmo c2.ml ocamlc.opt aa.cmo c2.cmo bbcc.cma c3.cmo main.cmo cool_plugin.cmo -o main.byte [cache hit] ocamlopt.opt -c -o aa.cmx aa.ml ocamlopt.opt -c -o bb.cmx bb.ml [cache hit] ocamlopt.opt -c -o c2.cmx c2.ml [cache hit] ocamlopt.opt -c -o cc.cmx cc.ml ocamlopt.opt -a bb.cmx cc.cmx -o bbcc.cmxa [cache hit] ocamlopt.opt -c -o c3.cmx c3.ml [cache hit] ocamlopt.opt -c -o main.cmx main.ml ocamlopt.opt aa.cmx c2.cmx bbcc.cmxa c3.cmx main.cmx -o main.native + ../../_build/ocamlbuild.native bbcc.cma main.byte bbcc.cmxa main.native -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt [cache hit] ocamldep.opt -modules bb.mli > bb.mli.depends [cache hit] ocamlc.opt -c -o bb.cmi bb.mli [cache hit] ocamldep.opt -modules bb.ml > bb.ml.depends [cache hit] ocamlc.opt -c -o bb.cmo bb.ml [cache hit] ocamldep.opt -modules cc.ml > cc.ml.depends [cache hit] ocamldep.opt -modules aa.ml > aa.ml.depends [cache hit] ocamlc.opt -c -o aa.cmo aa.ml [cache hit] ocamldep.opt -modules c2.mli > c2.mli.depends [cache hit] ocamlc.opt -c -o c2.cmi c2.mli [cache hit] ocamlc.opt -c -o cc.cmo cc.ml [cache hit] ocamlc.opt -a bb.cmo cc.cmo -o bbcc.cma [cache hit] ocamldep.opt -modules main.ml > main.ml.depends [cache hit] ocamldep.opt -modules c3.ml > c3.ml.depends [cache hit] ocamlc.opt -c -o c3.cmo c3.ml [cache hit] ocamlc.opt -c -o main.cmo main.ml [cache hit] ocamldep.opt -modules cool_plugin.ml > cool_plugin.ml.depends [cache hit] ocamlc.opt -c -o cool_plugin.cmo cool_plugin.ml [cache hit] ocamldep.opt -modules c2.ml > c2.ml.depends [cache hit] ocamlc.opt -c -o c2.cmo c2.ml [cache hit] ocamlc.opt aa.cmo c2.cmo bbcc.cma c3.cmo main.cmo cool_plugin.cmo -o main.byte [cache hit] ocamlopt.opt -c -o bb.cmx bb.ml [cache hit] ocamlopt.opt -c -o aa.cmx aa.ml [cache hit] ocamlopt.opt -c -o c2.cmx c2.ml [cache hit] ocamlopt.opt -c -o cc.cmx cc.ml [cache hit] ocamlopt.opt -a bb.cmx cc.cmx -o bbcc.cmxa [cache hit] ocamlopt.opt -c -o c3.cmx c3.ml [cache hit] ocamlopt.opt -c -o main.cmx main.ml [cache hit] ocamlopt.opt aa.cmx c2.cmx bbcc.cmxa c3.cmx main.cmx -o main.native _____ _ ___ |_ _|__ ___| |_( _ ) | |/ _ \/ __| __/ _ \ | | __/\__ \ || (_) | |_|\___||___/\__\___/ + CMDOPTS= + BUILD='../../_build/ocamlbuild.native a.byte a.native a a.opt bin/a bin/a.opt -no-skip -classic-display ' + BUILD1='../../_build/ocamlbuild.native a.byte a.native a a.opt bin/a bin/a.opt -no-skip -classic-display ' + BUILD2='../../_build/ocamlbuild.native a.byte a.native a a.opt bin/a bin/a.opt -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt ' + rm -rf _build + ../../_build/ocamlbuild.native a.byte a.native a a.opt bin/a bin/a.opt -no-skip -classic-display ocamlopt.opt -I /Users/ertai/l/ocaml/ocamlbuild-unstable/ocamlbuild/_install/lib/ocamlbuild unix.cmxa /Users/ertai/l/ocaml/ocamlbuild-unstable/ocamlbuild/_install/lib/ocamlbuild/ocamlbuildlib.cmxa myocamlbuild.ml /Users/ertai/l/ocaml/ocamlbuild-unstable/ocamlbuild/_install/lib/ocamlbuild/ocamlbuild.cmx -o myocamlbuild ocamldep.opt -modules a.ml > a.ml.depends ocamldep.opt -modules myconfig.ml > myconfig.ml.depends ocamlc.opt -c -o myconfig.cmo myconfig.ml ocamlc.opt -c -o a.cmo a.ml ocamlc.opt myconfig.cmo a.cmo -o a.byte ocamlopt.opt -c -o myconfig.cmx myconfig.ml ocamlopt.opt -c -o a.cmx a.ml ocamlopt.opt myconfig.cmx a.cmx -o a.native cp -p a.byte a cp -p a.native a.opt cp -p a.byte bin/a.byte cp -p bin/a.byte bin/a cp -p a.native bin/a.native cp -p bin/a.native bin/a.opt + ../../_build/ocamlbuild.native a.byte a.native a a.opt bin/a bin/a.opt -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt [cache hit] ocamldep.opt -modules a.ml > a.ml.depends [cache hit] ocamldep.opt -modules myconfig.ml > myconfig.ml.depends [cache hit] ocamlc.opt -c -o myconfig.cmo myconfig.ml [cache hit] ocamlc.opt -c -o a.cmo a.ml [cache hit] ocamlc.opt myconfig.cmo a.cmo -o a.byte [cache hit] ocamlopt.opt -c -o myconfig.cmx myconfig.ml [cache hit] ocamlopt.opt -c -o a.cmx a.ml [cache hit] ocamlopt.opt myconfig.cmx a.cmx -o a.native [cache hit] cp -p a.byte a [cache hit] cp -p a.native a.opt [cache hit] cp -p a.byte bin/a.byte [cache hit] cp -p bin/a.byte bin/a [cache hit] cp -p a.native bin/a.native [cache hit] cp -p bin/a.native bin/a.opt _____ _ ___ |_ _|__ ___| |_ / _ \ | |/ _ \/ __| __| (_) | | | __/\__ \ |_ \__, | |_|\___||___/\__| /_/ ++ dirname ./test9/test.sh + cd ./test9/../.. + ./_build/ocamlbuild.native -quiet -build-dir _buildtest -no-links test/test9/testglob.native + ./_buildtest/test/test9/testglob.native Globexp for "\"hello\"" OK Globexp for "" OK Globexp for "" OK Globexp for " and or " OK Globexp for " titi" OK Glob.eval "<[a]>" "a" = true OK Glob.eval "<[a]>" "b" = false OK Glob.eval "<[a]>" "a" = true OK Glob.eval "<[a]>" "b" = false OK Glob.eval "<[a]>" "a" = true OK Glob.eval "<[a]>" "b" = false OK Glob.eval "<[a-z]>" "a" = true OK Glob.eval "<[a-z]>" "e" = true OK Glob.eval "<[a-z]>" "k" = true OK Glob.eval "<[a-z]>" "z" = true OK Glob.eval "<[a-z]>" "0" = false OK Glob.eval "<[a-z]>" "A" = false OK Glob.eval "<[a-z]>" "~" = false OK Glob.eval "<[a-z]>" "a" = true OK Glob.eval "<[a-z]>" "e" = true OK Glob.eval "<[a-z]>" "k" = true OK Glob.eval "<[a-z]>" "z" = true OK Glob.eval "<[a-z]>" "0" = false OK Glob.eval "<[a-z]>" "A" = false OK Glob.eval "<[a-z]>" "~" = false OK Glob.eval "<[a-z]>" "a" = true OK Glob.eval "<[a-z]>" "e" = true OK Glob.eval "<[a-z]>" "k" = true OK Glob.eval "<[a-z]>" "z" = true OK Glob.eval "<[a-z]>" "0" = false OK Glob.eval "<[a-z]>" "A" = false OK Glob.eval "<[a-z]>" "~" = false OK Glob.eval "<[a-z][0-9]>" "a0" = true OK Glob.eval "<[a-z][0-9]>" "b9" = true OK Glob.eval "<[a-z][0-9]>" "a00" = false OK Glob.eval "<[a-z][0-9]>" "a0a" = false OK Glob.eval "<[a-z][0-9]>" "b0a" = false OK Glob.eval "<[a-z][0-9]>" "isduis" = false OK Glob.eval "<[a-z][0-9]>" "" = false OK Glob.eval "<[a-z][0-9]>" "a0" = true OK Glob.eval "<[a-z][0-9]>" "b9" = true OK Glob.eval "<[a-z][0-9]>" "a00" = false OK Glob.eval "<[a-z][0-9]>" "a0a" = false OK Glob.eval "<[a-z][0-9]>" "b0a" = false OK Glob.eval "<[a-z][0-9]>" "isduis" = false OK Glob.eval "<[a-z][0-9]>" "" = false OK Glob.eval "<[a-z][0-9]>" "a0" = true OK Glob.eval "<[a-z][0-9]>" "b9" = true OK Glob.eval "<[a-z][0-9]>" "a00" = false OK Glob.eval "<[a-z][0-9]>" "a0a" = false OK Glob.eval "<[a-z][0-9]>" "b0a" = false OK Glob.eval "<[a-z][0-9]>" "isduis" = false OK Glob.eval "<[a-z][0-9]>" "" = false OK Glob.eval "" "hello" = true OK Glob.eval "" "helli" = false OK Glob.eval "" "hello" = true OK Glob.eval "" "helli" = false OK Glob.eval "" "hello" = true OK Glob.eval "" "helli" = false OK Glob.eval "\"hello\"" "hello" = true OK Glob.eval "\"hello\"" "heidi" = false OK Glob.eval "\"hello\"" "hello" = true OK Glob.eval "\"hello\"" "heidi" = false OK Glob.eval "\"hello\"" "hello" = true OK Glob.eval "\"hello\"" "heidi" = false OK Glob.eval "<*>" "" = true OK Glob.eval "<*>" "a" = true OK Glob.eval "<*>" "ax" = true OK Glob.eval "<*>" "" = true OK Glob.eval "<*>" "a" = true OK Glob.eval "<*>" "ax" = true OK Glob.eval "<*>" "" = true OK Glob.eval "<*>" "a" = true OK Glob.eval "<*>" "ax" = true OK Glob.eval "" "ab" = true OK Glob.eval "" "acb" = true OK Glob.eval "" "axxxxxb" = true OK Glob.eval "" "ababbababb" = true OK Glob.eval "" "abx" = false OK Glob.eval "" "xxxxxab" = false OK Glob.eval "" "xab" = false OK Glob.eval "" "ab" = true OK Glob.eval "" "acb" = true OK Glob.eval "" "axxxxxb" = true OK Glob.eval "" "ababbababb" = true OK Glob.eval "" "abx" = false OK Glob.eval "" "xxxxxab" = false OK Glob.eval "" "xab" = false OK Glob.eval "" "ab" = true OK Glob.eval "" "acb" = true OK Glob.eval "" "axxxxxb" = true OK Glob.eval "" "ababbababb" = true OK Glob.eval "" "abx" = false OK Glob.eval "" "xxxxxab" = false OK Glob.eval "" "xab" = false OK Glob.eval "<*.ml>" "hello.ml" = true OK Glob.eval "<*.ml>" ".ml" = true OK Glob.eval "<*.ml>" "ml" = false OK Glob.eval "<*.ml>" "" = false OK Glob.eval "<*.ml>" "toto.mli" = false OK Glob.eval "<*.ml>" "hello.ml" = true OK Glob.eval "<*.ml>" ".ml" = true OK Glob.eval "<*.ml>" "ml" = false OK Glob.eval "<*.ml>" "" = false OK Glob.eval "<*.ml>" "toto.mli" = false OK Glob.eval "<*.ml>" "hello.ml" = true OK Glob.eval "<*.ml>" ".ml" = true OK Glob.eval "<*.ml>" "ml" = false OK Glob.eval "<*.ml>" "" = false OK Glob.eval "<*.ml>" "toto.mli" = false OK Glob.eval "" "a" = true OK Glob.eval "" "" = false OK Glob.eval "" "aa" = false OK Glob.eval "" "ba" = false OK Glob.eval "" "ab" = false OK Glob.eval "" "abaa" = false OK Glob.eval "" "a" = true OK Glob.eval "" "" = false OK Glob.eval "" "aa" = false OK Glob.eval "" "ba" = false OK Glob.eval "" "ab" = false OK Glob.eval "" "abaa" = false OK Glob.eval "" "a" = true OK Glob.eval "" "" = false OK Glob.eval "" "aa" = false OK Glob.eval "" "ba" = false OK Glob.eval "" "ab" = false OK Glob.eval "" "abaa" = false OK Glob.eval "" "ab" = true OK Glob.eval "" "" = false OK Glob.eval "" "abab" = false OK Glob.eval "" "aba" = false OK Glob.eval "" "abx" = false OK Glob.eval "" "ab" = true OK Glob.eval "" "" = false OK Glob.eval "" "abab" = false OK Glob.eval "" "aba" = false OK Glob.eval "" "abx" = false OK Glob.eval "" "ab" = true OK Glob.eval "" "" = false OK Glob.eval "" "abab" = false OK Glob.eval "" "aba" = false OK Glob.eval "" "abx" = false OK Glob.eval "" "abac" = true OK Glob.eval "" "abxc" = true OK Glob.eval "" "abab" = false OK Glob.eval "" "ababab" = false OK Glob.eval "" "ababa" = false OK Glob.eval "" "abac" = true OK Glob.eval "" "abxc" = true OK Glob.eval "" "abab" = false OK Glob.eval "" "ababab" = false OK Glob.eval "" "ababa" = false OK Glob.eval "" "abac" = true OK Glob.eval "" "abxc" = true OK Glob.eval "" "abab" = false OK Glob.eval "" "ababab" = false OK Glob.eval "" "ababa" = false OK Glob.eval "<*ab?cd*>" "123abecd345" = true OK Glob.eval "<*ab?cd*>" "abccd" = true OK Glob.eval "<*ab?cd*>" "abccd345" = true OK Glob.eval "<*ab?cd*>" "ababcababccdab" = true OK Glob.eval "<*ab?cd*>" "abcd" = false OK Glob.eval "<*ab?cd*>" "aaaaabcdababcd" = false OK Glob.eval "<*ab?cd*>" "123abecd345" = true OK Glob.eval "<*ab?cd*>" "abccd" = true OK Glob.eval "<*ab?cd*>" "abccd345" = true OK Glob.eval "<*ab?cd*>" "ababcababccdab" = true OK Glob.eval "<*ab?cd*>" "abcd" = false OK Glob.eval "<*ab?cd*>" "aaaaabcdababcd" = false OK Glob.eval "<*ab?cd*>" "123abecd345" = true OK Glob.eval "<*ab?cd*>" "abccd" = true OK Glob.eval "<*ab?cd*>" "abccd345" = true OK Glob.eval "<*ab?cd*>" "ababcababccdab" = true OK Glob.eval "<*ab?cd*>" "abcd" = false OK Glob.eval "<*ab?cd*>" "aaaaabcdababcd" = false OK Glob.eval "<*this*is*a*test*>" "this is a test" = true OK Glob.eval "<*this*is*a*test*>" "You know this is a test really" = true OK Glob.eval "<*this*is*a*test*>" "thisisatest" = true OK Glob.eval "<*this*is*a*test*>" "thisatest" = false OK Glob.eval "<*this*is*a*test*>" "this is a test" = true OK Glob.eval "<*this*is*a*test*>" "You know this is a test really" = true OK Glob.eval "<*this*is*a*test*>" "thisisatest" = true OK Glob.eval "<*this*is*a*test*>" "thisatest" = false OK Glob.eval "<*this*is*a*test*>" "this is a test" = true OK Glob.eval "<*this*is*a*test*>" "You know this is a test really" = true OK Glob.eval "<*this*is*a*test*>" "thisisatest" = true OK Glob.eval "<*this*is*a*test*>" "thisatest" = false OK Glob.eval "" "bxx" = true OK Glob.eval "" "bx" = true OK Glob.eval "" "aaab" = false OK Glob.eval "" "" = false OK Glob.eval "" "bxx" = true OK Glob.eval "" "bx" = true OK Glob.eval "" "aaab" = false OK Glob.eval "" "" = false OK Glob.eval "" "bxx" = true OK Glob.eval "" "bx" = true OK Glob.eval "" "aaab" = false OK Glob.eval "" "" = false OK Glob.eval "<*>" "" = true OK Glob.eval "<*>" "a" = true OK Glob.eval "<*>" "aaa" = true OK Glob.eval "<*>" "aaaaa" = true OK Glob.eval "<*>" "" = true OK Glob.eval "<*>" "a" = true OK Glob.eval "<*>" "aaa" = true OK Glob.eval "<*>" "aaaaa" = true OK Glob.eval "<*>" "" = true OK Glob.eval "<*>" "a" = true OK Glob.eval "<*>" "aaa" = true OK Glob.eval "<*>" "aaaaa" = true OK Glob.eval "" "a" = true OK Glob.eval "" "" = false OK Glob.eval "" "aaa" = false OK Glob.eval "" "aaaaa" = false OK Glob.eval "" "a" = true OK Glob.eval "" "" = false OK Glob.eval "" "aaa" = false OK Glob.eval "" "aaaaa" = false OK Glob.eval "" "a" = true OK Glob.eval "" "" = false OK Glob.eval "" "aaa" = false OK Glob.eval "" "aaaaa" = false OK Glob.eval "<{a,b}>" "a" = true OK Glob.eval "<{a,b}>" "b" = true OK Glob.eval "<{a,b}>" "" = false OK Glob.eval "<{a,b}>" "aa" = false OK Glob.eval "<{a,b}>" "ab" = false OK Glob.eval "<{a,b}>" "ba" = false OK Glob.eval "<{a,b}>" "bb" = false OK Glob.eval "<{a,b}>" "c" = false OK Glob.eval "<{a,b}>" "a" = true OK Glob.eval "<{a,b}>" "b" = true OK Glob.eval "<{a,b}>" "" = false OK Glob.eval "<{a,b}>" "aa" = false OK Glob.eval "<{a,b}>" "ab" = false OK Glob.eval "<{a,b}>" "ba" = false OK Glob.eval "<{a,b}>" "bb" = false OK Glob.eval "<{a,b}>" "c" = false OK Glob.eval "<{a,b}>" "a" = true OK Glob.eval "<{a,b}>" "b" = true OK Glob.eval "<{a,b}>" "" = false OK Glob.eval "<{a,b}>" "aa" = false OK Glob.eval "<{a,b}>" "ab" = false OK Glob.eval "<{a,b}>" "ba" = false OK Glob.eval "<{a,b}>" "bb" = false OK Glob.eval "<{a,b}>" "c" = false OK Glob.eval "" "toto.ml" = true OK Glob.eval "" "toto.mli" = true OK Glob.eval "" "toto." = false OK Glob.eval "" "toto.mll" = false OK Glob.eval "" "toto.ml" = true OK Glob.eval "" "toto.mli" = true OK Glob.eval "" "toto." = false OK Glob.eval "" "toto.mll" = false OK Glob.eval "" "toto.ml" = true OK Glob.eval "" "toto.mli" = true OK Glob.eval "" "toto." = false OK Glob.eval "" "toto.mll" = false OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "acf" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "acg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "adf" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "adg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "aef" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "aeg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcf" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdf" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "bef" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "beg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "afg" = false OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "af" = false OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "aee" = false OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "acf" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "acg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "adf" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "adg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "aef" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "aeg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcf" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdf" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "bef" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "beg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "afg" = false OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "af" = false OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "aee" = false OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "acf" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "acg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "adf" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "adg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "aef" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "aeg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcf" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "bcg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdf" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "bdg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "bef" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "beg" = true OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "afg" = false OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "af" = false OK Glob.eval "<{a,b}{c,[de]}{f,g}>" "aee" = false OK Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.ml" = true OK Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "b.ml" = true OK Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli" = true OK Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "hello.ml" = false OK Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli.x" = false OK Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.ml" = true OK Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "b.ml" = true OK Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli" = true OK Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "hello.ml" = false OK Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli.x" = false OK Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.ml" = true OK Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "b.ml" = true OK Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli" = true OK Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "hello.ml" = false OK Glob.eval "(<*.ml> or <*.mli>) and not \"hello.ml\"" "a.mli.x" = false OK Glob.eval "<*>" "alpha" = true OK Glob.eval "<*>" "beta" = true OK Glob.eval "<*>" "alpha/beta" = false OK Glob.eval "<*>" "gamma/delta" = false OK Glob.eval "<*>" "alpha" = true OK Glob.eval "<*>" "beta" = true OK Glob.eval "<*>" "alpha/beta" = false OK Glob.eval "<*>" "gamma/delta" = false OK Glob.eval "<*>" "alpha" = true OK Glob.eval "<*>" "beta" = true OK Glob.eval "<*>" "alpha/beta" = false OK Glob.eval "<*>" "gamma/delta" = false OK Glob.eval "" "alpha/beta" = true OK Glob.eval "" "alpha/gamma/beta" = true OK Glob.eval "" "alpha/gamma/delta/beta" = true OK Glob.eval "" "alpha" = false OK Glob.eval "" "beta" = false OK Glob.eval "" "gamma/delta" = false OK Glob.eval "" "alpha/beta" = true OK Glob.eval "" "alpha/gamma/beta" = true OK Glob.eval "" "alpha/gamma/delta/beta" = true OK Glob.eval "" "alpha" = false OK Glob.eval "" "beta" = false OK Glob.eval "" "gamma/delta" = false OK Glob.eval "" "alpha/beta" = true OK Glob.eval "" "alpha/gamma/beta" = true OK Glob.eval "" "alpha/gamma/delta/beta" = true OK Glob.eval "" "alpha" = false OK Glob.eval "" "beta" = false OK Glob.eval "" "gamma/delta" = false OK Glob.eval "<**/*.ml>" "toto.ml" = true OK Glob.eval "<**/*.ml>" "toto/tata.ml" = true OK Glob.eval "<**/*.ml>" "alpha/gamma/delta/beta.ml" = true OK Glob.eval "<**/*.ml>" "toto.mli" = false OK Glob.eval "<**/*.ml>" "toto.ml" = true OK Glob.eval "<**/*.ml>" "toto/tata.ml" = true OK Glob.eval "<**/*.ml>" "alpha/gamma/delta/beta.ml" = true OK Glob.eval "<**/*.ml>" "toto.mli" = false OK Glob.eval "<**/*.ml>" "toto.ml" = true OK Glob.eval "<**/*.ml>" "toto/tata.ml" = true OK Glob.eval "<**/*.ml>" "alpha/gamma/delta/beta.ml" = true OK Glob.eval "<**/*.ml>" "toto.mli" = false OK Glob.eval "" "toto/" = true OK Glob.eval "" "toto/tata" = true OK Glob.eval "" "toto/alpha/gamma/delta/beta.ml" = true OK Glob.eval "" "toto" = true OK Glob.eval "" "toto2/tata" = false OK Glob.eval "" "tata/titi" = false OK Glob.eval "" "toto/" = true OK Glob.eval "" "toto/tata" = true OK Glob.eval "" "toto/alpha/gamma/delta/beta.ml" = true OK Glob.eval "" "toto" = true OK Glob.eval "" "toto2/tata" = false OK Glob.eval "" "tata/titi" = false OK Glob.eval "" "toto/" = true OK Glob.eval "" "toto/tata" = true OK Glob.eval "" "toto/alpha/gamma/delta/beta.ml" = true OK Glob.eval "" "toto" = true OK Glob.eval "" "toto2/tata" = false OK Glob.eval "" "tata/titi" = false OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/bar/libfoo.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibs/unix/libunix.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibsliblib/unlibix/libunix.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo/libbar.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/libfoo/boo/libbar.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "bar" = None OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libbar/foo.a" = None OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.b.a" = None OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/bar/libfoo.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibs/unix/libunix.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibsliblib/unlibix/libunix.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo/libbar.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/libfoo/boo/libbar.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "bar" = None OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libbar/foo.a" = None OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.b.a" = None OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/bar/libfoo.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibs/unix/libunix.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "otherlibsliblib/unlibix/libunix.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo/libbar.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "src/libfoo/boo/libbar.a" OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "bar" = None OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libbar/foo.a" = None OK Resource.matchit "%(path:<**/>)lib%(libname:<*> and not <*.*>).a" "libfoo.b.a" = None OK _____ _ __ ___ _ _ |_ _|__ ___| |_ \ \ / (_)_ __| |_ _ _ __ _| | | |/ _ \/ __| __| \ \ / /| | '__| __| | | |/ _` | | | | __/\__ \ |_ \ V / | | | | |_| |_| | (_| | | |_|\___||___/\__| \_/ |_|_| \__|\__,_|\__,_|_| _____ _ |_ _|_ _ _ __ __ _ ___| |_ ___ | |/ _` | '__/ _` |/ _ \ __/ __| | | (_| | | | (_| | __/ |_\__ \ |_|\__,_|_| \__, |\___|\__|___/ |___/ + CMDOPTS= + BUILD='../../_build/ocamlbuild.native bar -no-skip -classic-display ' + BUILD1='../../_build/ocamlbuild.native bar -no-skip -classic-display ' + BUILD2='../../_build/ocamlbuild.native bar -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt ' + rm -rf _build + cp foo1 foo + ../../_build/ocamlbuild.native bar -no-skip -classic-display ocamlopt.opt -I /Users/ertai/l/ocaml/ocamlbuild-unstable/ocamlbuild/_install/lib/ocamlbuild unix.cmxa /Users/ertai/l/ocaml/ocamlbuild-unstable/ocamlbuild/_install/lib/ocamlbuild/ocamlbuildlib.cmxa myocamlbuild.ml /Users/ertai/l/ocaml/ocamlbuild-unstable/ocamlbuild/_install/lib/ocamlbuild/ocamlbuild.cmx -o myocamlbuild cp foo bar + ../../_build/ocamlbuild.native bar -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt [cache hit] cp foo bar + cp foo2 foo + ../../_build/ocamlbuild.native bar -no-skip -classic-display -verbose 0 cp foo bar + ../../_build/ocamlbuild.native bar -no-skip -classic-display -verbose 0 -nothing-should-be-rebuilt [cache hit] cp foo bar + rm foo mingw-ocaml/ocaml/ocamlbuild/test/test1/0000755000175000017500000000000012124403240017607 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test1/foo.ml0000644000175000017500000000002012124403240020714 0ustar tootstootsmodule MA1 = A1 mingw-ocaml/ocaml/ocamlbuild/test/test11/0000755000175000017500000000000012124403240017670 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test11/_tags0000644000175000017500000000006312124403240020707 0ustar tootstoots# a comment "a/aa.byte" or "a/aa.native": use_libb mingw-ocaml/ocaml/ocamlbuild/test/test11/b/0000755000175000017500000000000012124403240020111 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test11/b/bb.ml0000644000175000017500000000002012124403240021016 0ustar tootstootslet foo = [2.2] mingw-ocaml/ocaml/ocamlbuild/test/test11/b/libb.mllib0000644000175000017500000000000312124403240022033 0ustar tootstootsBb mingw-ocaml/ocaml/ocamlbuild/test/test11/a/0000755000175000017500000000000012124403240020110 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test11/a/aa.ml0000644000175000017500000000004112124403240021016 0ustar tootstootslet bar = 3 + List.length Bb.foo mingw-ocaml/ocaml/ocamlbuild/test/test11/a/aa.mli0000644000175000017500000000001612124403240021171 0ustar tootstootsval bar : int mingw-ocaml/ocaml/ocamlbuild/test/test11/myocamlbuild.ml0000644000175000017500000000014312124403240022701 0ustar tootstootsopen Ocamlbuild_plugin;; dispatch begin function | After_rules -> ocaml_lib "b/libb" | _ -> () end mingw-ocaml/ocaml/ocamlbuild/test/test11/test.sh0000755000175000017500000000056012124403240021207 0ustar tootstoots#!/bin/sh cd `dirname $0` set -e set -x CMDOTPS="" # -- command args BUILD="../../_build/ocamlbuild.native -I a -I b aa.byte aa.native -no-skip -classic-display $@" BUILD1="$BUILD $CMDOPTS" BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS" rm -rf _build $BUILD1 echo looks if libs are there ls _build/b/libb.cma _build/b/libb.cmxa _build/b/libb.a $BUILD2 mingw-ocaml/ocaml/ocamlbuild/test/test4/0000755000175000017500000000000012124403240017612 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test4/_tags0000644000175000017500000000006212124403240020630 0ustar tootstoots# a comment "a/aa.byte" or "a/aa.native": use_str mingw-ocaml/ocaml/ocamlbuild/test/test4/b/0000755000175000017500000000000012124403240020033 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test4/b/bb.ml0000644000175000017500000000004712124403240020751 0ustar tootstootslet r = Str.regexp "r" let foo = [2.2] mingw-ocaml/ocaml/ocamlbuild/test/test4/a/0000755000175000017500000000000012124403240020032 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test4/a/aa.ml0000644000175000017500000000004112124403240020740 0ustar tootstootslet bar = 3 + List.length Bb.foo mingw-ocaml/ocaml/ocamlbuild/test/test4/a/aa.mli0000644000175000017500000000001612124403240021113 0ustar tootstootsval bar : int mingw-ocaml/ocaml/ocamlbuild/test/test4/test.sh0000755000175000017500000000043312124403240021130 0ustar tootstoots#!/bin/sh cd `dirname $0` set -e set -x CMDOTPS="" # -- command args BUILD="../../_build/ocamlbuild.native -I a -I b aa.byte aa.native -no-skip -classic-display $@" BUILD1="$BUILD $CMDOPTS" BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS" rm -rf _build $BUILD1 $BUILD2 mingw-ocaml/ocaml/ocamlbuild/test/test2/0000755000175000017500000000000012124403240017610 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test2/toto.ml0000644000175000017500000000034012124403240021124 0ustar tootstootslet i = Tutu.tutu + 10 let s = Tata.tata ^ ".ml" let l = 3 :: Titi.titi let () = Format.printf "toto.native: %s: Hello world!!!@." Sys.argv.(0) let () = Format.printf "Tutu.tutu => %d@.Tata.tata => %S@." Tutu.tutu Tata.tata mingw-ocaml/ocaml/ocamlbuild/test/test2/vivi1.ml0000644000175000017500000000006712124403240021203 0ustar tootstootslet rec p i = [< '1; '2; p (i + 1) >] let vivi = [|2|] mingw-ocaml/ocaml/ocamlbuild/test/test2/_tags0000644000175000017500000000007612124403240020633 0ustar tootstoots"vivi.ml": camlp4o # , some_useless_tag, \ more_useless_tags mingw-ocaml/ocaml/ocamlbuild/test/test2/tata.ml0000644000175000017500000000002312124403240021066 0ustar tootstootslet tata = "TATA2" mingw-ocaml/ocaml/ocamlbuild/test/test2/tutu.ml0000644000175000017500000000012212124403240021136 0ustar tootstootslet tutu = (Array.length Vivi.vivi : Tyty.t) let tutu' = 2.0 +. float_of_int tutu mingw-ocaml/ocaml/ocamlbuild/test/test2/tyty.mli0000644000175000017500000000001512124403240021320 0ustar tootstootstype t = int mingw-ocaml/ocaml/ocamlbuild/test/test2/tutu.mli0000644000175000017500000000006112124403240021311 0ustar tootstoots(* a comment *) val tutu : int val tutu' : float mingw-ocaml/ocaml/ocamlbuild/test/test2/tata.mli0000644000175000017500000000004212124403240021240 0ustar tootstoots(* a comment *) val tata : string mingw-ocaml/ocaml/ocamlbuild/test/test2/vivi2.ml0000644000175000017500000000006712124403240021204 0ustar tootstootslet rec p i = [< '1; '2; p (i + 1) >] let vivi = [|3|] mingw-ocaml/ocaml/ocamlbuild/test/test2/titi.ml0000644000175000017500000000001612124403240021110 0ustar tootstootslet titi = [] mingw-ocaml/ocaml/ocamlbuild/test/test2/vivi3.ml0000644000175000017500000000007612124403240021205 0ustar tootstootslet rec p i = [< '1; '2; p (i + 1) >] let vivi = [|2.1; 1.1|] mingw-ocaml/ocaml/ocamlbuild/test/test2/test.sh0000755000175000017500000000054712124403240021134 0ustar tootstoots#!/bin/sh cd `dirname $0` set -e set -x CMDOPTS="-- -help" BUILD="../../_build/ocamlbuild.native toto.byte toto.native -no-skip -classic-display $@" BUILD1="$BUILD $CMDOPTS" BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS" rm -rf _build cp vivi1.ml vivi.ml $BUILD1 $BUILD2 cp vivi2.ml vivi.ml $BUILD1 $BUILD2 cp vivi3.ml vivi.ml $BUILD1 $BUILD2 mingw-ocaml/ocaml/ocamlbuild/test/test8/0000755000175000017500000000000012124403240017616 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test8/a.ml0000644000175000017500000000004112124403240020363 0ustar tootstootsprint_endline Myconfig.version;; mingw-ocaml/ocaml/ocamlbuild/test/test8/myocamlbuild.ml0000644000175000017500000000112112124403240022624 0ustar tootstootsopen Ocamlbuild_plugin;; let version = "0.1";; dispatch begin function | After_rules -> rule "myconfig.ml" ~prod:"myconfig.ml" begin fun _ _ -> Echo(["let version = \""; version; "\";;\n"], "myconfig.ml") end; copy_rule "copy byte-code executables" "%(path).byte" "%(path:not <**/*.*>)"; copy_rule "copy native executables" "%(path).native" "%(path:not <**/*.*>).opt"; copy_rule "copy binaries to bin" "%(basename).%(extension)" "bin/%(basename).%(extension:<{byte,native}>)"; | _ -> () end mingw-ocaml/ocaml/ocamlbuild/test/test8/test.sh0000755000175000017500000000044712124403240021141 0ustar tootstoots#!/bin/sh cd `dirname $0` set -e set -x CMDOPTS="" # -- command args BUILD="../../_build/ocamlbuild.native a.byte a.native a a.opt bin/a bin/a.opt -no-skip -classic-display $@" BUILD1="$BUILD $CMDOPTS" BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS" rm -rf _build $BUILD1 $BUILD2 mingw-ocaml/ocaml/ocamlbuild/test/test3/0000755000175000017500000000000012124403240017611 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test3/proj.odocl0000644000175000017500000000001412124403240021600 0ustar tootstootsA B C D E F mingw-ocaml/ocaml/ocamlbuild/test/test3/e.mli0000644000175000017500000000001612124403240020535 0ustar tootstoots(* nothing *) mingw-ocaml/ocaml/ocamlbuild/test/test3/_tags0000644000175000017500000000004112124403240020624 0ustar tootstoots"a.byte" or "a.native": use_unix mingw-ocaml/ocaml/ocamlbuild/test/test3/c.mli0000644000175000017500000000001612124403240020533 0ustar tootstoots(* nothing *) mingw-ocaml/ocaml/ocamlbuild/test/test3/f.ml0000644000175000017500000000004012124403240020362 0ustar tootstoots(* nothing *) let _ = Unix.stat mingw-ocaml/ocaml/ocamlbuild/test/test3/f.mli0000644000175000017500000000001612124403240020536 0ustar tootstoots(* nothing *) mingw-ocaml/ocaml/ocamlbuild/test/test3/c.ml0000644000175000017500000000001512124403240020361 0ustar tootstootsmodule X = D mingw-ocaml/ocaml/ocamlbuild/test/test3/d.ml0000644000175000017500000000001512124403240020362 0ustar tootstootsmodule X = E mingw-ocaml/ocaml/ocamlbuild/test/test3/b.ml0000644000175000017500000000001512124403240020360 0ustar tootstootsmodule X = C mingw-ocaml/ocaml/ocamlbuild/test/test3/a.mli0000644000175000017500000000001612124403240020531 0ustar tootstoots(* Nothing *) mingw-ocaml/ocaml/ocamlbuild/test/test3/a.ml0000644000175000017500000000001512124403240020357 0ustar tootstootsmodule X = B mingw-ocaml/ocaml/ocamlbuild/test/test3/b.mli0000644000175000017500000000001612124403240020532 0ustar tootstoots(* nothing *) mingw-ocaml/ocaml/ocamlbuild/test/test3/d.mli0000644000175000017500000000001612124403240020534 0ustar tootstoots(* nothing *) mingw-ocaml/ocaml/ocamlbuild/test/test3/e.ml0000644000175000017500000000001512124403240020363 0ustar tootstootsmodule X = F mingw-ocaml/ocaml/ocamlbuild/test/test3/test.sh0000755000175000017500000000044612124403240021133 0ustar tootstoots#!/bin/sh cd `dirname $0` set -e set -x CMDOTPS="" # -- command args BUILD="../../_build/ocamlbuild.native a.byte a.native proj.docdir/index.html -no-skip -classic-display $@" BUILD1="$BUILD $CMDOPTS" BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS" rm -rf _build $BUILD1 $BUILD2 mingw-ocaml/ocaml/ocamlbuild/test/test6/0000755000175000017500000000000012124403240017614 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test6/main.mli0000644000175000017500000000001612124403240021240 0ustar tootstoots(* nothing *) mingw-ocaml/ocaml/ocamlbuild/test/test6/d.mli.v20000644000175000017500000000002112124403240021061 0ustar tootstootsval d : 'a -> 'a mingw-ocaml/ocaml/ocamlbuild/test/test6/main.ml0000644000175000017500000000002112124403240021063 0ustar tootstootsA.a 2. +. D.d 1. mingw-ocaml/ocaml/ocamlbuild/test/test6/d.ml0000644000175000017500000000002312124403240020364 0ustar tootstootstype t let d x = x mingw-ocaml/ocaml/ocamlbuild/test/test6/d.mli.v10000644000175000017500000000003012124403240021060 0ustar tootstootstype t val d : 'a -> 'a mingw-ocaml/ocaml/ocamlbuild/test/test6/b.ml0000644000175000017500000000001412124403240020362 0ustar tootstootslet b = D.d mingw-ocaml/ocaml/ocamlbuild/test/test6/a.mli0000644000175000017500000000002112124403240020530 0ustar tootstootsval a : 'a -> 'a mingw-ocaml/ocaml/ocamlbuild/test/test6/a.ml0000644000175000017500000000001412124403240020361 0ustar tootstootslet a = B.b mingw-ocaml/ocaml/ocamlbuild/test/test6/b.mli.v20000644000175000017500000000002612124403240021064 0ustar tootstoots.... val b : 'a -> 'a mingw-ocaml/ocaml/ocamlbuild/test/test6/b.mli0000644000175000017500000000002112124403240020531 0ustar tootstootsval b : 'a -> 'a mingw-ocaml/ocaml/ocamlbuild/test/test6/d.mli0000644000175000017500000000002112124403240020533 0ustar tootstootsval d : 'a -> 'a mingw-ocaml/ocaml/ocamlbuild/test/test6/b.mli.v10000644000175000017500000000002112124403240021056 0ustar tootstootsval b : 'a -> 'a mingw-ocaml/ocaml/ocamlbuild/test/test6/test.sh0000755000175000017500000000074312124403240021136 0ustar tootstoots#!/bin/sh cd `dirname $0` set -x rm -rf _build CMDOPTS="" # -- command args BUILD="../../_build/ocamlbuild.native -no-skip main.byte -classic-display $@" BUILD1="$BUILD $CMDOPTS" BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS" cp b.mli.v1 b.mli cp d.mli.v1 d.mli $BUILD1 $BUILD2 cp b.mli.v2 b.mli cp d.mli.v2 d.mli $BUILD1 cp b.mli.v1 b.mli if $BUILD1; then if $BUILD2; then echo PASS else echo "FAIL (-nothing-should-be-rebuilt)" fi else echo FAIL fi mingw-ocaml/ocaml/ocamlbuild/test/test5/0000755000175000017500000000000012124403240017613 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test5/_tags0000644000175000017500000000004012124403240020625 0ustar tootstoots"a.cmx" or "b.cmx": for-pack(C) mingw-ocaml/ocaml/ocamlbuild/test/test5/d.ml0000644000175000017500000000004312124403240020365 0ustar tootstootsFormat.printf "C.B.b = %d@." C.B.b mingw-ocaml/ocaml/ocamlbuild/test/test5/stack.ml0000644000175000017500000000001712124403240021250 0ustar tootstootslet stack = 42 mingw-ocaml/ocaml/ocamlbuild/test/test5/c.mlpack0000644000175000017500000000000412124403240021220 0ustar tootstootsA B mingw-ocaml/ocaml/ocamlbuild/test/test5/b.ml0000644000175000017500000000002012124403240020356 0ustar tootstootslet b = A.a + 1 mingw-ocaml/ocaml/ocamlbuild/test/test5/a.mli0000644000175000017500000000001412124403240020531 0ustar tootstootsval a : int mingw-ocaml/ocaml/ocamlbuild/test/test5/a.ml0000644000175000017500000000003112124403240020357 0ustar tootstootslet a = 42 + Stack.stack mingw-ocaml/ocaml/ocamlbuild/test/test5/test.sh0000755000175000017500000000041712124403240021133 0ustar tootstoots#!/bin/sh cd `dirname $0` set -e set -x CMDOPTS="" # -- command args BUILD="../../_build/ocamlbuild.native d.byte d.native -no-skip -classic-display $@" BUILD1="$BUILD $CMDOPTS" BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS" rm -rf _build $BUILD1 $BUILD2 mingw-ocaml/ocaml/ocamlbuild/test/test7/0000755000175000017500000000000012124403240017615 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test7/c2.mli0000644000175000017500000000001512124403240020620 0ustar tootstootsval c2 : int mingw-ocaml/ocaml/ocamlbuild/test/test7/aa.ml0000644000175000017500000000001612124403240020525 0ustar tootstootslet aa = "aa" mingw-ocaml/ocaml/ocamlbuild/test/test7/bbcc.mllib0000644000175000017500000000000612124403240021523 0ustar tootstootsBb Cc mingw-ocaml/ocaml/ocamlbuild/test/test7/bb1.ml0000644000175000017500000000001412124403240020606 0ustar tootstootslet bb = 43 mingw-ocaml/ocaml/ocamlbuild/test/test7/_tags0000644000175000017500000000003412124403240020632 0ustar tootstoots"main.byte": my_cool_plugin mingw-ocaml/ocaml/ocamlbuild/test/test7/main.ml0000644000175000017500000000007312124403240021073 0ustar tootstootslet main = String.length Aa.aa - Bb.bb - C3.c3 - Cc.cc - 1 mingw-ocaml/ocaml/ocamlbuild/test/test7/cool_plugin.ml0000644000175000017500000000004312124403240022456 0ustar tootstootsprint_endline "I am a cool plugin" mingw-ocaml/ocaml/ocamlbuild/test/test7/bb2.ml0000644000175000017500000000006212124403240020612 0ustar tootstootslet bb = 43 let f x = x + 1 let () = incr (ref 0) mingw-ocaml/ocaml/ocamlbuild/test/test7/bb3.ml0000644000175000017500000000006212124403240020613 0ustar tootstootslet bb = 43 let f x = x + 1 let () = incr (ref 1) mingw-ocaml/ocaml/ocamlbuild/test/test7/bb.mli0000644000175000017500000000001512124403240020677 0ustar tootstootsval bb : int mingw-ocaml/ocaml/ocamlbuild/test/test7/cc.ml0000644000175000017500000000005712124403240020536 0ustar tootstootslet cc = (String.length Aa.aa) + Bb.bb + C2.c2 mingw-ocaml/ocaml/ocamlbuild/test/test7/c3.ml0000644000175000017500000000002412124403240020450 0ustar tootstootslet c3 = Bb.bb + 13 mingw-ocaml/ocaml/ocamlbuild/test/test7/c2.ml0000644000175000017500000000001412124403240020446 0ustar tootstootslet c2 = 12 mingw-ocaml/ocaml/ocamlbuild/test/test7/myocamlbuild.ml0000644000175000017500000000026412124403240022632 0ustar tootstootsopen Ocamlbuild_plugin;; dispatch begin function | After_rules -> use_lib "main" "bbcc"; dep ["ocaml"; "link"; "byte"; "my_cool_plugin"] ["cool_plugin.cmo"]; | _ -> () end mingw-ocaml/ocaml/ocamlbuild/test/test7/test.sh0000755000175000017500000000061612124403240021136 0ustar tootstoots#!/bin/sh cd `dirname $0` set -e set -x CMDOPTS="" # -- command args BUILD="../../_build/ocamlbuild.native bbcc.cma main.byte bbcc.cmxa main.native -no-skip -classic-display $@" BUILD1="$BUILD $CMDARGS" BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDARGS" rm -rf _build cp bb1.ml bb.ml $BUILD1 $BUILD2 cp bb2.ml bb.ml $BUILD1 -verbose 0 $BUILD2 cp bb3.ml bb.ml $BUILD1 -verbose 0 $BUILD2 mingw-ocaml/ocaml/ocamlbuild/test/runtest.sh0000755000175000017500000000106012124403240020607 0ustar tootstoots#!/bin/sh set -e cd `dirname $0` myfiglet() { figlet $@ | sed 's/ *$//' } if figlet ""; then BANNER=myfiglet else echo "Install figlet to have a better output, press enter to continue with echo" read BANNER=echo fi HERE=`pwd` $BANNER Test2 ./test2/test.sh $@ $BANNER Test3 ./test3/test.sh $@ $BANNER Test4 ./test4/test.sh $@ $BANNER Test5 ./test5/test.sh $@ $BANNER Test6 ./test6/test.sh $@ $BANNER Test7 ./test7/test.sh $@ $BANNER Test8 ./test8/test.sh $@ $BANNER Test9 ./test9/test.sh $@ $BANNER Test Virtual Targets ./test_virtual/test.sh $@ mingw-ocaml/ocaml/ocamlbuild/test/test9/0000755000175000017500000000000012124403240017617 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test9/dbgl0000644000175000017500000000033412124403240020452 0ustar tootstoots#load "unix.cma";; #load "str.cma";; #load "discard_printf.cmo";; #load "debug.cmo";; #load "bool.cmo";; #load "glob_ast.cmo";; #load "glob_lexer.cmo";; #load "my_unix.cmo";; #use "glob.ml";; #install_printer print_is;; mingw-ocaml/ocaml/ocamlbuild/test/test9/testglob.ml0000644000175000017500000001077012124403240022001 0ustar tootstoots(* Testglob *) open Bool;; open Glob;; let yep f x = try ignore (f x); true with | _ -> false ;; let tests1 = [ "\"hello\"", true; "", true; "", true; " and or ", true; " titi", false ];; let tests2 = [ "<[a]>", ["a"], ["b"]; "<[a-z]>", ["a";"e";"k";"z"], ["0";"A";"~"]; "<[a-z][0-9]>", ["a0";"b9"], ["a00";"a0a";"b0a";"isduis";""]; "", ["hello"], ["helli"]; "\"hello\"", ["hello"], ["heidi"]; "<*>", ["";"a";"ax"], []; "", ["ab";"acb";"axxxxxb";"ababbababb"], ["abx";"xxxxxab";"xab"]; "<*.ml>", ["hello.ml";".ml"], ["ml"; ""; "toto.mli"]; "", ["a"], ["";"aa";"ba";"ab";"abaa"]; "", ["ab"], ["";"abab";"aba";"abx"]; "", ["abac";"abxc"], ["abab";"ababab";"ababa"]; "<*ab?cd*>", ["123abecd345";"abccd";"abccd345";"ababcababccdab"], ["abcd";"aaaaabcdababcd"]; "<*this*is*a*test*>", ["this is a test";"You know this is a test really";"thisisatest"], ["thisatest"]; "", ["bxx";"bx"], ["aaab";""]; "<*>", ["";"a";"aaa";"aaaaa"], []; "", ["a"],["";"aaa";"aaaaa"]; "<{a,b}>", ["a";"b"],["";"aa";"ab";"ba";"bb";"c"]; "", ["toto.ml";"toto.mli"],["toto.";"toto.mll"]; "<{a,b}{c,[de]}{f,g}>", ["acf";"acg";"adf";"adg";"aef";"aeg";"bcf";"bcg";"bdf";"bdg";"bef";"beg"], ["afg";"af";"aee"]; "(<*.ml> or <*.mli>) and not \"hello.ml\"", ["a.ml"; "b.ml"; "a.mli"], ["hello.ml"; "a.mli.x"]; "<*>", ["alpha";"beta"], ["alpha/beta";"gamma/delta"]; "", ["alpha/beta";"alpha/gamma/beta";"alpha/gamma/delta/beta"], ["alpha";"beta";"gamma/delta"]; "<**/*.ml>", ["toto.ml";"toto/tata.ml";"alpha/gamma/delta/beta.ml"], ["toto.mli"]; "", ["toto/";"toto/tata";"toto/alpha/gamma/delta/beta.ml";"toto"], ["toto2/tata"; "tata/titi"] ];; let tests3 = [ "%(path:<**/>)lib%(libname:<*> and not <*.*>).a", ["libfoo.a","","foo"; "src/bar/libfoo.a","src/bar/","foo"; "otherlibs/unix/libunix.a","otherlibs/unix/","unix"; "otherlibsliblib/unlibix/libunix.a","otherlibsliblib/unlibix/","unix"; "libfoo/libbar.a","libfoo/","bar"; "src/libfoo/boo/libbar.a","src/libfoo/boo/","bar"; ], ["bar"; "libbar/foo.a"; "libfoo.b.a"] ];; let _ = let times = 3 in List.iter begin fun (str, ast) -> let ast' = yep Glob.parse str in if ast <> ast' then begin Printf.printf "Globexp parsing failed for %S.\n%!" str; exit 1 end else Printf.printf "Globexp for %S OK\n%!" str end tests1; List.iter begin fun (gstr, yes, no) -> let globber = Glob.parse gstr in let check polarity = List.iter begin fun y -> if Glob.eval globber y = polarity then Printf.printf "Glob.eval %S %S = %b OK\n%!" gstr y polarity else begin Printf.printf "Glob.eval %S %S = %b FAIL\n%!" gstr y (not polarity); exit 1 end end in for k = 1 to times do check true yes; check false no done end tests2; List.iter begin fun (str, yes, no) -> let resource = Resource.import_pattern str in for k = 1 to times do List.iter begin fun (y, path, libname) -> let resource' = Resource.import y in match Resource.matchit resource resource' with | Some env -> let path' = Resource.subst env "%(path)" in let libname' = Resource.subst env "%(libname)" in if path' = path && libname = libname' then Printf.printf "Resource.matchit %S %S OK\n%!" str y else begin Printf.printf "Resource.matchit %S %S FAIL\n%!" str y; exit 1 end | None -> begin Printf.printf "Resource.matchit %S %S = None FAIL\n%!" str y; exit 1 end end yes; List.iter begin fun y -> let resource' = Resource.import y in if Resource.matchit resource resource' = None then Printf.printf "Resource.matchit %S %S = None OK\n%!" str y else begin Printf.printf "Resource.matchit %S %S <> None FAIL\n%!" str y; exit 1 end end no done end tests3 ;; mingw-ocaml/ocaml/ocamlbuild/test/test9/test.sh0000755000175000017500000000026612124403240021141 0ustar tootstoots#!/bin/sh set -e set -x cd `dirname $0`/../.. ./_build/ocamlbuild.native -quiet -build-dir _buildtest -no-links test/test9/testglob.native $@ ./_buildtest/test/test9/testglob.native mingw-ocaml/ocaml/ocamlbuild/test/test_virtual/0000755000175000017500000000000012124403240021274 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/test/test_virtual/foo.itarget0000644000175000017500000000000412124403240023432 0ustar tootstootsfoo mingw-ocaml/ocaml/ocamlbuild/test/test_virtual/foo10000644000175000017500000000000512124403240022056 0ustar tootstootsfoo1 mingw-ocaml/ocaml/ocamlbuild/test/test_virtual/foo20000644000175000017500000000000512124403240022057 0ustar tootstootsfoo2 mingw-ocaml/ocaml/ocamlbuild/test/test_virtual/myocamlbuild.ml0000644000175000017500000000033712124403240024312 0ustar tootstootsopen Ocamlbuild_plugin;; dispatch begin function | After_rules -> rule "copy foo" ~prod:"bar" ~dep:"foo.otarget" begin fun _env _build -> cp "foo" "bar" end | _ -> () end mingw-ocaml/ocaml/ocamlbuild/test/test_virtual/test.sh0000644000175000017500000000047512124403240022615 0ustar tootstoots#!/bin/sh cd `dirname $0` set -e set -x CMDOPTS="" # -- command args BUILD="../../_build/ocamlbuild.native bar -no-skip -classic-display $@" BUILD1="$BUILD $CMDOPTS" BUILD2="$BUILD -verbose 0 -nothing-should-be-rebuilt $CMDOPTS" rm -rf _build cp foo1 foo $BUILD1 $BUILD2 cp foo2 foo $BUILD1 -verbose 0 $BUILD2 rm foo mingw-ocaml/ocaml/ocamlbuild/plugin.ml0000644000175000017500000001145512124403240017426 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Format open Log open Pathname.Operators open Tags.Operators open Rule open Tools open Command ;; module Make(U:sig end) = struct let plugin = "myocamlbuild" let plugin_file = plugin^".ml" let plugin_config_file = plugin^"_config.ml" let plugin_config_file_interface = plugin^"_config.mli" let we_have_a_config_file = sys_file_exists plugin_config_file let we_need_a_plugin = !Options.plugin && sys_file_exists plugin_file let we_have_a_plugin = sys_file_exists ((!Options.build_dir/plugin)^(!Options.exe)) let we_have_a_config_file_interface = sys_file_exists plugin_config_file_interface let up_to_date_or_copy fn = let fn' = !Options.build_dir/fn in Pathname.exists fn && begin Pathname.exists fn' && Pathname.same_contents fn fn' || begin Shell.cp fn fn'; false end end let profiling = Tags.mem "profile" (tags_of_pathname plugin_file) let debugging = Tags.mem "debug" (tags_of_pathname plugin_file) let rebuild_plugin_if_needed () = let a = up_to_date_or_copy plugin_file in let b = (not we_have_a_config_file) or up_to_date_or_copy plugin_config_file in let c = (not we_have_a_config_file_interface) or up_to_date_or_copy plugin_config_file_interface in if a && b && c && we_have_a_plugin then () (* Up to date *) (* FIXME: remove ocamlbuild_config.ml in _build/ if removed in parent *) else begin if !Options.native_plugin && not (sys_file_exists ((!Ocamlbuild_where.libdir)/"ocamlbuildlib.cmxa")) then begin Options.native_plugin := false; eprintf "Warning: Won't be able to compile a native plugin" end; let plugin_config = if we_have_a_config_file then if we_have_a_config_file_interface then S[P plugin_config_file_interface; P plugin_config_file] else P plugin_config_file else N in let cma, cmo, more_options, compiler = if !Options.native_plugin then "cmxa", "cmx", (if profiling then A"-p" else N), !Options.ocamlopt else "cma", "cmo", (if debugging then A"-g" else N), !Options.ocamlc in let ocamlbuildlib, ocamlbuild, libs = if (not !Options.native_plugin) && !*My_unix.is_degraded then "ocamlbuildlightlib", "ocamlbuildlight", N else "ocamlbuildlib", "ocamlbuild", A("unix"-.-cma) in let ocamlbuildlib = ocamlbuildlib-.-cma in let ocamlbuild = ocamlbuild-.-cmo in let dir = !Ocamlbuild_where.libdir in if not (sys_file_exists (dir/ocamlbuildlib)) then failwith (sprintf "Cannot find %S in ocamlbuild -where directory" ocamlbuildlib); let dir = if Pathname.is_implicit dir then Pathname.pwd/dir else dir in let cmd = Cmd(S[compiler; A"-I"; P dir; libs; more_options; P(dir/ocamlbuildlib); plugin_config; P plugin_file; P(dir/ocamlbuild); A"-o"; Px (plugin^(!Options.exe))]) in Shell.chdir !Options.build_dir; Shell.rm_f (plugin^(!Options.exe)); Command.execute cmd end let execute_plugin_if_needed () = if we_need_a_plugin then begin rebuild_plugin_if_needed (); Shell.chdir Pathname.pwd; if not !Options.just_plugin then let runner = if !Options.native_plugin then N else !Options.ocamlrun in let argv = List.tl (Array.to_list Sys.argv) in let spec = S[runner; P(!Options.build_dir/plugin^(!Options.exe)); A"-no-plugin"; atomize (List.filter (fun s -> s <> "-plugin-option") argv)] in let () = Log.finish () in raise (Exit_silently_with_code (sys_command (Command.string_of_command_spec spec))) end else () end ;; let execute_plugin_if_needed () = let module P = Make(struct end) in P.execute_plugin_if_needed () ;; mingw-ocaml/ocaml/ocamlbuild/param_tags.ml0000644000175000017500000000362512124403240020246 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Romain Bardou *) module StringSet = Set.Make(String) (* tag name -> tag action (string -> unit) *) let declared_tags = Hashtbl.create 17 let acknowledged_tags = ref [] let only_once f = let instances = ref StringSet.empty in fun param -> if StringSet.mem param !instances then () else begin instances := StringSet.add param !instances; f param end let declare name action = Hashtbl.add declared_tags name (only_once action) let acknowledge tag = let tag = Lexers.tag_gen (Lexing.from_string tag) in acknowledged_tags := tag :: !acknowledged_tags let really_acknowledge (name, param) = match param with | None -> if Hashtbl.mem declared_tags name then Log.eprintf "Warning: tag %S expects a parameter" name | Some param -> let actions = List.rev (Hashtbl.find_all declared_tags name) in if actions = [] then Log.eprintf "Warning: tag %S does not expect a parameter, but is used with parameter %S" name param; List.iter (fun f -> f param) actions let init () = List.iter really_acknowledge (My_std.List.ordered_unique !acknowledged_tags) let make = Printf.sprintf "%s(%s)" mingw-ocaml/ocaml/ocamlbuild/ocamlbuild.mli0000644000175000017500000000146012124403240020407 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) (** Nothing to export for now *) mingw-ocaml/ocaml/ocamlbuild/ocaml_compiler.mli0000644000175000017500000001160512124403240021263 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) val forpack_flags : string -> Tags.t -> Command.spec val ocamlc_c : Tags.t -> Pathname.t -> Pathname.t -> Command.t val ocamlc_link_lib : Tags.t -> Pathname.t list -> Pathname.t -> Command.t val ocamlc_link_prog : Tags.t -> Pathname.t list -> Pathname.t -> Command.t val ocamlc_p : Tags.t -> Pathname.t list -> Pathname.t -> Command.t val ocamlopt_c : Tags.t -> Pathname.t -> Pathname.t -> Command.t val ocamlopt_link_lib : Tags.t -> Pathname.t list -> Pathname.t -> Command.t val ocamlopt_link_shared_lib : Tags.t -> Pathname.t list -> Pathname.t -> Command.t val ocamlopt_link_prog : Tags.t -> Pathname.t list -> Pathname.t -> Command.t val ocamlopt_p : Tags.t -> Pathname.t list -> Pathname.t -> Command.t val ocamlmklib : Tags.t -> Pathname.t list -> Pathname.t -> Command.t val ocamlmktop : Tags.t -> Pathname.t list -> Pathname.t -> Command.t val prepare_compile : Rule.builder -> Pathname.t -> unit val byte_compile_ocaml_interf : string -> string -> Rule.action val byte_compile_ocaml_implem : ?tag:string -> string -> string -> Rule.action val prepare_link : Pathname.t -> Pathname.t -> string list -> Rule.builder -> unit val native_compile_ocaml_implem : ?tag:string -> ?cmx_ext:string -> string -> Rule.action val prepare_libs : string -> string -> Pathname.t -> Rule.builder -> Pathname.t list val link_gen : string -> string -> string -> string list -> (Tags.t -> Pathname.t list -> Pathname.t -> Command.t) -> (Tags.t -> Tags.t) -> string -> string -> Rule.action val byte_link : string -> string -> Rule.action val byte_library_link : string -> string -> Rule.action val byte_debug_link : string -> string -> Rule.action val byte_debug_library_link : string -> string -> Rule.action val native_link : string -> string -> Rule.action val native_library_link : string -> string -> Rule.action val native_shared_library_link : ?tags:(string list) -> string -> string -> Rule.action val native_profile_link : string -> string -> Rule.action val native_profile_library_link : string -> string -> Rule.action val link_modules : (Pathname.t * string list) list -> string -> string -> string -> (Tags.t -> Pathname.t list -> Pathname.t -> Command.t) -> (Tags.t -> Tags.t) -> string list -> string -> Rule.action val pack_modules : (Pathname.t * string list) list -> string -> string -> string -> (Tags.t -> Pathname.t list -> Pathname.t -> Command.t) -> (Tags.t -> Tags.t) -> string list -> string -> Rule.action val byte_library_link_modules : string list -> string -> Rule.action val byte_library_link_mllib : string -> string -> Rule.action val byte_debug_library_link_modules : string list -> string -> Rule.action val byte_debug_library_link_mllib : string -> string -> Rule.action val byte_pack_modules : string list -> string -> Rule.action val byte_pack_mlpack : string -> string -> Rule.action val byte_debug_pack_modules : string list -> string -> Rule.action val byte_debug_pack_mlpack : string -> string -> Rule.action val byte_toplevel_link_modules : string list -> string -> Rule.action val byte_toplevel_link_mltop : string -> string -> Rule.action val native_pack_modules : string list -> string -> Rule.action val native_pack_mlpack : string -> string -> Rule.action val native_library_link_modules : string list -> string -> Rule.action val native_library_link_mllib : string -> string -> Rule.action val native_shared_library_link_modules : string list -> string -> Rule.action val native_shared_library_link_mldylib : string -> string -> Rule.action val native_profile_pack_modules : string list -> string -> Rule.action val native_profile_pack_mlpack : string -> string -> Rule.action val native_profile_library_link_modules : string list -> string -> Rule.action val native_profile_library_link_mllib : string -> string -> Rule.action val native_profile_shared_library_link_modules : string list -> string -> Rule.action val native_profile_shared_library_link_mldylib : string -> string -> Rule.action (** [hide_package_contents pack_name] Don't treat the given package as an open package. So a module will not be replaced during linking by this package even if it contains that module. *) val hide_package_contents : string -> unit mingw-ocaml/ocaml/ocamlbuild/tags.ml0000644000175000017500000000272712124403240017070 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) include Set.Make(String) (** does_match {foo, bar, baz} {foo} => ok does_match {foo, bar, baz} {foo, boo} => ko does_match {foo, bar, baz} {} => ok does_match {foo, bar, baz} {foo, bar, baz} => ok *) let does_match x y = subset y x let of_list l = List.fold_right add l empty open Format let print f s = let () = fprintf f "@[<0>" in let _ = fold begin fun elt first -> if not first then fprintf f ",@ "; pp_print_string f elt; false end s true in fprintf f "@]" module Operators = struct let ( ++ ) x y = add y x let ( -- ) x y = remove y x let ( +++ ) x = function Some y -> add y x | None -> x let ( --- ) x = function Some y -> remove y x | None -> x end mingw-ocaml/ocaml/ocamlbuild/findlib.mli0000644000175000017500000000151512124403240017704 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Romain Bardou *) include Signatures.FINDLIB with type command_spec = Command.spec mingw-ocaml/ocaml/ocamlbuild/plugin.mli0000644000175000017500000000151112124403240017567 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) (* Plugin *) val execute_plugin_if_needed : unit -> unit mingw-ocaml/ocaml/ocamlbuild/discard_printf.mli0000644000175000017500000000172712124403240021275 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) (* Discard_printf *) (** This module compiled with [-rectypes] allows one to write functions taking formatters as arguments. *) open Format val discard_printf: ('a, formatter, unit) format -> 'a mingw-ocaml/ocaml/ocamlbuild/glob_ast.ml0000644000175000017500000000213712124403240017717 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Glob_ast *) exception Parse_error of string;; type pattern = | Epsilon | Star of pattern (* The fucking Kleene star *) | Class of character_class | Concat of pattern * pattern | Union of pattern list | Word of string and character_class = (char * char) Bool.boolean ;; type 'pattern atom = | Constant of string | Pattern of 'pattern ;; mingw-ocaml/ocaml/ocamlbuild/hygiene.mli0000644000175000017500000000471712124403240017734 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* Hygiene *) (** Module for checking that the source tree is not polluted by object files. *) (** Sanity rules to abide. Not to be confused with compilation rules. *) type rule = Implies_not of pattern * pattern (** The rule [Implies_not(".mll",".ml")] is broken if there is a file [foo.mll] together with a file [foo.ml] int the same directory. The second file can get sanitized. *) | Not of pattern (* No files with suffix [pattern] will be tolerated. *) (** Suffix matching is enough for the purpose of this module. *) and pattern = suffix (** And a suffix is a string. *) and suffix = string (** A warning is simply displayed. A failures stops the compilation. *) type penalty = Warn | Fail (** This type is used to encode laws that will be checked by this module. *) type law = { law_name : string; (** The name of the law that will be printed when it is violated. *) law_rules : rule list; (** Breaking any of these rules is breaking this law. *) law_penalty : penalty; (** Breaking the law gives you either a warning or a failure. *) } (** [check ~sanitize laws entry] will scan the directory tree [entry] for violation to the given [laws]. Any warnings or errors will be printed on the [stdout]. If [sanitize] is [Some fn], a shell script will be written into the file [fn] with commands to delete the offending files. The command will return a pair [(fatal, penalties)] where [fatal] is [true] when serious hygiene violations have been spotted, and [penalties] is a list of laws and messages describing the offenses. *) val check : ?sanitize:string -> law list -> bool Slurp.entry -> (law * string list) list mingw-ocaml/ocaml/ocamlbuild/my_std.mli0000644000175000017500000000427712124403240017604 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) (* My_std *) (** Generic utility functions, and system-independent glue. *) exception Exit_OK exception Exit_usage of string exception Exit_system_error of string exception Exit_with_code of int exception Exit_silently_with_code of int module Outcome : Signatures.OUTCOME val ksbprintf : (string -> 'a) -> ('b, Format.formatter, unit, 'a) format4 -> 'b val sbprintf : ('a, Format.formatter, unit, string) format4 -> 'a module Set : sig module type OrderedTypePrintable = Signatures.OrderedTypePrintable module type S = Signatures.SET module Make (M : OrderedTypePrintable) : S with type elt = M.t end module List : Signatures.LIST module String : Signatures.STRING module Digest : sig type t = string val string : string -> t val substring : string -> int -> int -> t external channel : in_channel -> int -> t = "caml_md5_chan" val file : string -> t val output : out_channel -> t -> unit val input : in_channel -> t val to_hex : t -> string end module StringSet : Set.S with type elt = String.t val sys_readdir : string -> (string array, exn) Outcome.t val sys_remove : string -> unit val reset_readdir_cache : unit -> unit val reset_filesys_cache : unit -> unit val reset_filesys_cache_for_file : string -> unit val sys_file_exists : string -> bool val sys_command : string -> int val filename_concat : string -> string -> string val invalid_arg' : ('a, Format.formatter, unit, 'b) format4 -> 'a include Signatures.MISC mingw-ocaml/ocaml/ocamlbuild/my_unix.ml0000644000175000017500000001053612124403240017617 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std type file_kind = | FK_dir | FK_file | FK_link | FK_other type stats = { stat_file_kind : file_kind; stat_key : string } type implem = { mutable is_degraded : bool; mutable is_link : string -> bool; mutable run_and_open : 'a . string -> (in_channel -> 'a) -> 'a; mutable readlink : string -> string; mutable execute_many : ?max_jobs:int -> ?ticker:(unit -> unit) -> ?period:float -> ?display:((out_channel -> unit) -> unit) -> ((unit -> string) list list) -> (bool list * exn) option; mutable report_error : Format.formatter -> exn -> unit; mutable at_exit_once : (unit -> unit) -> unit; mutable gettimeofday : unit -> float; mutable stdout_isatty : unit -> bool; mutable stat : string -> stats; mutable lstat : string -> stats; } let is_degraded = true let stat f = { stat_key = f; stat_file_kind = if sys_file_exists f then if Sys.is_directory f then FK_dir else FK_file else let _ = with_input_file f input_char in assert false } let run_and_open s kont = with_temp_file "ocamlbuild" "out" begin fun tmp -> let s = Printf.sprintf "%s > '%s'" s tmp in let st = sys_command s in if st <> 0 then failwith (Printf.sprintf "Error while running: %s" s); with_input_file tmp kont end exception Not_a_link exception No_such_file exception Link_to_directories_not_supported let readlinkcmd = let cache = Hashtbl.create 32 in fun x -> try Hashtbl.find cache x with Not_found -> run_and_open (Printf.sprintf "readlink %s" (Filename.quote x)) begin fun ic -> let y = String.chomp (input_line ic) in Hashtbl.replace cache x y; y end let rec readlink x = if sys_file_exists x then try let y = readlinkcmd x in if (lstat y).stat_file_kind = FK_dir then raise Link_to_directories_not_supported else y with Failure(_) -> raise Not_a_link else raise No_such_file and is_link x = try ignore(readlink x); true with | No_such_file | Not_a_link -> false and lstat x = if is_link x then { stat_key = x; stat_file_kind = FK_link } else stat x let implem = { is_degraded = true; stat = stat; lstat = lstat; readlink = readlink; is_link = is_link; run_and_open = run_and_open; (* at_exit_once is at_exit in the degraded mode since fork is not accessible in this mode *) at_exit_once = at_exit; report_error = (fun _ -> raise); gettimeofday = (fun () -> assert false); stdout_isatty = (fun () -> false); execute_many = (fun ?max_jobs:(_) ?ticker:(_) ?period:(_) ?display:(_) _ -> assert false) } let is_degraded = lazy implem.is_degraded let stat x = implem.stat x let lstat x = implem.lstat x let readlink x = implem.readlink x let is_link x = implem.is_link x let run_and_open x = implem.run_and_open x let at_exit_once x = implem.at_exit_once x let report_error x = implem.report_error x let gettimeofday x = implem.gettimeofday x let stdout_isatty x = implem.stdout_isatty x let execute_many ?max_jobs = implem.execute_many ?max_jobs let run_and_read cmd = let bufsiz = 2048 in let buf = String.create bufsiz in let totalbuf = Buffer.create 4096 in implem.run_and_open cmd begin fun ic -> let rec loop pos = let len = input ic buf 0 bufsiz in if len > 0 then begin Buffer.add_substring totalbuf buf 0 len; loop (pos + len) end in loop 0; Buffer.contents totalbuf end mingw-ocaml/ocaml/ocamlbuild/command.ml0000644000175000017500000003067312124403240017551 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) (* Command *) open My_std open Log type tags = Tags.t type pathname = string let jobs = ref 1 type t = | Seq of t list | Cmd of spec | Echo of string list * pathname | Nop and spec = | N (* nop or nil *) | S of spec list | A of string | P of pathname | Px of pathname | Sh of string | T of Tags.t | V of string | Quote of spec (*type v = [ `Seq of v list | `Cmd of vspec | `Nop ] and vspec = [ `N | `S of vspec list | `A of string | `P of pathname | `Px of pathname | `Sh of string | `Quote of vspec ] let rec spec_of_vspec = function | `N -> N | `S vspecs -> S (List.map spec_of_vspec vspecs) | `A s -> A s | `P s -> P s | `Px s -> Px s | `Sh s -> Sh s | `Quote vspec -> Quote (spec_of_vspec vspec) let rec vspec_of_spec = function | N -> `N | S specs -> `S (List.map vspec_of_spec specs) | A s -> `A s | P s -> `P s | Px s -> `Px s | Sh s -> `Sh s | T _ -> invalid_arg "vspec_of_spec: T not supported" | Quote spec -> `Quote (vspec_of_spec spec) let rec t_of_v = function | `Nop -> Nop | `Cmd vspec -> Cmd (spec_of_vspec vspec) | `Seq cmds -> Seq (List.map t_of_v cmds) let rec v_of_t = function | Nop -> `Nop | Cmd spec -> `Cmd (vspec_of_spec spec) | Seq cmds -> `Seq (List.map v_of_t cmds)*) let no_tag_handler _ = failwith "no_tag_handler" let tag_handler = ref no_tag_handler (*** atomize *) let atomize l = S(List.map (fun x -> A x) l) let atomize_paths l = S(List.map (fun x -> P x) l) (* ***) let env_path = lazy begin let path_var = Sys.getenv "PATH" in let parse_path = if Sys.os_type = "Win32" then Lexers.parse_environment_path_w else Lexers.parse_environment_path in let paths = try parse_path (Lexing.from_string path_var) with Lexers.Error msg -> raise (Lexers.Error ("$PATH: " ^ msg)) in let norm_current_dir_name path = if path = "" then Filename.current_dir_name else path in List.map norm_current_dir_name paths end let virtual_solvers = Hashtbl.create 32 let setup_virtual_command_solver virtual_command solver = Hashtbl.replace virtual_solvers virtual_command solver let virtual_solver virtual_command = let solver = try Hashtbl.find virtual_solvers virtual_command with Not_found -> failwith (sbprintf "no solver for the virtual command %S \ (setup one with Command.setup_virtual_command_solver)" virtual_command) in try solver () with Not_found -> failwith (Printf.sprintf "the solver for the virtual command %S \ has failed finding a valid command" virtual_command) (* On Windows, we need to also check for the ".exe" version of the file. *) let file_or_exe_exists file = sys_file_exists file || Sys.os_type = "Win32" && sys_file_exists (file ^ ".exe") let search_in_path cmd = (* Try to find [cmd] in path [path]. *) let try_path path = (* Don't know why we're trying to be subtle here... *) if path = Filename.current_dir_name then file_or_exe_exists cmd else file_or_exe_exists (filename_concat path cmd) in if Filename.is_implicit cmd then let path = List.find try_path !*env_path in (* We're not trying to append ".exe" here because all windows shells are * capable of understanding the command without the ".exe" suffix. *) filename_concat path cmd else cmd (*** string_of_command_spec{,_with_calls *) let rec string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals spec = let self = string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals in let b = Buffer.create 256 in (* The best way to prevent bash from switching to its windows-style * quote-handling is to prepend an empty string before the command name. *) if Sys.os_type = "Win32" then Buffer.add_string b "''"; let first = ref true in let put_space () = if !first then first := false else Buffer.add_char b ' ' in let put_filename p = Buffer.add_string b (Shell.quote_filename_if_needed p) in let rec do_spec = function | N -> () | A u -> put_space (); put_filename u | Sh u -> put_space (); Buffer.add_string b u | P p -> put_space (); put_filename p | Px u -> put_space (); put_filename u; call_with_target u | V v -> if resolve_virtuals then do_spec (virtual_solver v) else (put_space (); Printf.bprintf b "" (Shell.quote_filename_if_needed v)) | S l -> List.iter do_spec l | T tags -> call_with_tags tags; do_spec (!tag_handler tags) | Quote s -> put_space (); put_filename (self s) in do_spec spec; Buffer.contents b let string_of_command_spec x = string_of_command_spec_with_calls ignore ignore false x let string_target_and_tags_of_command_spec spec = let rtags = ref Tags.empty in let rtarget = ref "" in let union_rtags tags = rtags := Tags.union !rtags tags in let s = string_of_command_spec_with_calls union_rtags ((:=) rtarget) true spec in let target = if !rtarget = "" then s else !rtarget in s, target, !rtags let string_print_of_command_spec spec quiet pretend = let s, target, tags = string_target_and_tags_of_command_spec spec in fun () -> if not quiet then Log.event ~pretend s target tags; s (* ***) let print_escaped_string f = Format.fprintf f "%S" let rec print f = function | Cmd spec -> Format.pp_print_string f (string_of_command_spec spec) | Seq seq -> List.print print f seq | Nop -> Format.pp_print_string f "nop" | Echo(texts, dest_path) -> Format.fprintf f "@[<2>Echo(%a,@ %a)@]" (List.print print_escaped_string) texts print_escaped_string dest_path let to_string x = sbprintf "%a" print x let add_parallel_stat, dump_parallel_stats = let xmin = ref max_int in let xmax = ref 0 in let xsum = ref 0 in let xsumall = ref 0 in let xcount = ref 0 in let xcountall = ref 0 in let add_parallel_stat x = if x > 0 then begin incr xcountall; xsumall := x + !xsumall; end; if x > 1 then begin incr xcount; xsum := x + !xsum; xmax := max !xmax x; xmin := min !xmin x; end in let dump_parallel_stats () = if !jobs <> 1 then if !xcount = 0 then dprintf 1 "# No parallelism done" else let xaverage = float_of_int !xsumall /. float_of_int !xcountall in let xaveragepara = float_of_int !xsum /. float_of_int !xcount in dprintf 1 "# Parallel statistics: { count(total): %d(%d), max: %d, min: %d, average(total): %.3f(%.3f) }" !xcount !xcountall !xmax !xmin xaveragepara xaverage in add_parallel_stat, dump_parallel_stats module Primitives = struct let do_echo texts dest_path = with_output_file dest_path begin fun oc -> List.iter (output_string oc) texts end let echo x y () = (* no print here yet *) do_echo x y; "" end let rec list_rev_iter f = function | [] -> () | x :: xs -> list_rev_iter f xs; f x let flatten_commands quiet pretend cmd = let rec loop acc = function | [] -> acc | Nop :: xs -> loop acc xs | Cmd spec :: xs -> loop (string_print_of_command_spec spec quiet pretend :: acc) xs | Echo(texts, dest_path) :: xs -> loop (Primitives.echo texts dest_path :: acc) xs | Seq l :: xs -> loop (loop acc l) xs in List.rev (loop [] [cmd]) let execute_many ?(quiet=false) ?(pretend=false) cmds = add_parallel_stat (List.length cmds); let degraded = !*My_unix.is_degraded || Sys.os_type = "Win32" in let jobs = !jobs in if jobs < 0 then invalid_arg "jobs < 0"; let max_jobs = if jobs = 0 then None else Some jobs in let ticker = Log.update in let display = Log.display in if cmds = [] then None else begin let konts = List.map (flatten_commands quiet pretend) cmds in if pretend then begin List.iter (List.iter (fun f -> ignore (f ()))) konts; None end else begin reset_filesys_cache (); if degraded then let res, opt_exn = List.fold_left begin fun (acc_res, acc_exn) cmds -> match acc_exn with | None -> begin try List.iter begin fun action -> let cmd = action () in let rc = sys_command cmd in if rc <> 0 then begin if not quiet then eprintf "Exit code %d while executing this \ command:@\n%s" rc cmd; raise (Exit_with_code rc) end end cmds; true :: acc_res, None with e -> false :: acc_res, Some e end | Some _ -> false :: acc_res, acc_exn end ([], None) konts in match opt_exn with | Some(exn) -> Some(List.rev res, exn) | None -> None else My_unix.execute_many ~ticker ?max_jobs ~display konts end end ;; let execute ?quiet ?pretend cmd = match execute_many ?quiet ?pretend [cmd] with | Some(_, exn) -> raise exn | _ -> () let iter_tags f x = let rec spec x = match x with | N | A _ | Sh _ | P _ | Px _ | V _ | Quote _ -> () | S l -> List.iter spec l | T tags -> f tags in let rec cmd x = match x with | Nop | Echo _ -> () | Cmd(s) -> spec s | Seq(s) -> List.iter cmd s in cmd x let fold_pathnames f x = let rec spec = function | N | A _ | Sh _ | V _ | Quote _ | T _ -> fun acc -> acc | P p | Px p -> f p | S l -> List.fold_right spec l in let rec cmd = function | Nop -> fun acc -> acc | Echo(_, p) -> f p | Cmd(s) -> spec s | Seq(s) -> List.fold_right cmd s in cmd x let rec reduce x = let rec self x acc = match x with | N -> acc | A _ | Sh _ | P _ | Px _ | V _ -> x :: acc | S l -> List.fold_right self l acc | T tags -> self (!tag_handler tags) acc | Quote s -> Quote (reduce s) :: acc in match self x [] with | [] -> N | [x] -> x | xs -> S xs let digest = let list = List.fold_right in let text x acc = Digest.string x :: acc in let rec cmd = function | Cmd spec -> fun acc -> string_of_command_spec spec :: acc | Seq seq -> list cmd seq | Nop -> fun acc -> acc | Echo(texts, dest_path) -> list text (dest_path :: texts) in fun x -> match cmd x [] with | [x] -> x | xs -> Digest.string ("["^String.concat ";" xs^"]") let all_deps_of_tags = ref [] let cons deps acc = List.rev& List.fold_left begin fun acc dep -> if List.mem dep acc then acc else dep :: acc end acc deps let deps_of_tags tags = List.fold_left begin fun acc (xtags, xdeps) -> if Tags.does_match tags xtags then cons xdeps acc else acc end [] !all_deps_of_tags let set_deps_of_tags tags deps = all_deps_of_tags := (tags, deps) :: !all_deps_of_tags let dep tags deps = set_deps_of_tags (Tags.of_list tags) deps let pdep tags ptag deps = Param_tags.declare ptag (fun param -> dep (Param_tags.make ptag param :: tags) (deps param)) (* let to_string_for_digest x = let rec cmd_of_spec = function | [] -> None | N :: xs -> cmd_of_spec xs | (A x | P x | P x) :: _ -> Some x | Sh x :: _ -> if Shell.is_simple_filename x then Some x else None (* Sh"ocamlfind ocamlc" for example will not be digested. *) | S specs1 :: specs2 -> cmd_of_spec (specs1 @ specs2) | (T _ | Quote _) :: _ -> assert false in let rec cmd_of_cmds = function | Nop | Seq [] -> None | Cmd spec -> cmd_of_spec [spec] | Seq (cmd :: _) -> cmd_of_cmds cmd in let s = to_string x in match cmd_of_cmds x with | Some x -> if sys_file_exists x then sprintf "(%S,%S)" s (Digest.file x) else s | None -> s *) mingw-ocaml/ocaml/ocamlbuild/fda.ml0000644000175000017500000000514612124403240016662 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Berke Durak *) (* FDA *) open Log open Hygiene ;; exception Exit_hygiene_failed ;; let laws = [ { law_name = "Leftover OCaml compilation files"; law_rules = [Not ".cmo"; Not ".cmi"; Not ".cmx"; Not ".cma"; Not ".cmxa"]; law_penalty = Fail }; { law_name = "Leftover OCaml type annotation files"; law_rules = [Not ".annot"]; law_penalty = Warn }; { law_name = "Leftover object files"; law_rules = [Not ".o"; Not ".a"; Not ".so"; Not ".obj"; Not ".lib"; Not ".dll"]; law_penalty = Fail }; { law_name = "Leftover ocamlyacc-generated files"; law_rules = [Implies_not(".mly",".ml"); Implies_not(".mly",".mli")]; law_penalty = Fail }; { law_name = "Leftover ocamllex-generated files"; law_rules = [Implies_not(".mll",".ml")]; law_penalty = Fail }; { law_name = "Leftover dependency files"; law_rules = [Not ".ml.depends"; Not ".mli.depends"]; law_penalty = Fail } ] let inspect entry = dprintf 5 "Doing sanity checks"; let evil = ref false in match Hygiene.check ?sanitize: begin if !Options.sanitize then Some(Pathname.concat !Options.build_dir !Options.sanitization_script) else None end laws entry with | [] -> () | stuff -> List.iter begin fun (law, msgs) -> Printf.printf "%s: %s:\n" (match law.law_penalty with | Warn -> "Warning" | Fail -> if not !evil then begin Printf.printf "IMPORTANT: I cannot work with leftover compiled files.\n%!"; evil := true end; "ERROR") law.law_name; List.iter begin fun msg -> Printf.printf " %s\n" msg end msgs end stuff; if !evil then raise Exit_hygiene_failed; ;; mingw-ocaml/ocaml/ocamlbuild/flags.ml0000644000175000017500000000273412124403240017224 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open Command open Bool (* FIXME remove me *) open Tags.Operators let all_flags = ref [] let of_tags tags = S begin List.fold_left begin fun acc (xtags, xflags) -> if Tags.does_match tags xtags then xflags :: acc else acc end [] !all_flags end let () = Command.tag_handler := of_tags let of_tag_list x = of_tags (Tags.of_list x) let set_flags tags flags = all_flags := (tags, flags) :: !all_flags let flag tags flags = set_flags (Tags.of_list tags) flags let pflag tags ptag flags = Param_tags.declare ptag (fun param -> flag (Param_tags.make ptag param :: tags) (flags param)) let add x xs = x :: xs let remove me = List.filter (fun x -> me <> x) let get_flags () = !all_flags mingw-ocaml/ocaml/ocamlbuild/ocamlbuildlightlib.mllib0000644000175000017500000000004212124403240022437 0ustar tootstootsOcamlbuild_pack Ocamlbuild_plugin mingw-ocaml/ocaml/ocamlbuild/pathname.ml0000644000175000017500000001052412124403240017721 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Format open Log type t = string include Filename let print_strings = List.print String.print let concat = filename_concat let compare = compare let print = pp_print_string let mk s = s let pwd = Sys.getcwd () let add_extension ext x = x ^ "." ^ ext let check_extension x ext = let lx = String.length x and lext = String.length ext in lx > lext + 1 && x.[lx - lext - 1] = '.' && String.is_suffix x ext module Operators = struct let ( / ) = concat let ( -.- ) file ext = add_extension ext file end open Operators let equal x y = x = y let to_string x = x let is_link = Shell.is_link let readlink = Shell.readlink let is_directory x = try (My_unix.stat x).My_unix.stat_file_kind = My_unix.FK_dir with Sys_error _ -> false let readdir x = Outcome.good (sys_readdir x) let dir_seps = ['/';'\\'] (* FIXME add more *) let not_normal_form_re = Glob.parse "<**/{,.,..}/**>" let parent x = concat parent_dir_name x let split p = let rec go p acc = let dir = dirname p in if dir = p then dir, acc else go dir (basename p :: acc) in go p [] let join root paths = let root = if root = current_dir_name then "" else root in List.fold_left (/) root paths let _H1 = assert (current_dir_name = ".") let _H2 = assert (parent_dir_name = "..") (* Use H1, H2 *) let rec normalize_list = function | [] -> [] | "." :: xs -> normalize_list xs | ".." :: _ -> failwith "Pathname.normalize_list: .. is forbidden here" | _ :: ".." :: xs -> normalize_list xs | x :: xs -> x :: normalize_list xs let normalize x = if Glob.eval not_normal_form_re x then let root, paths = split x in join root (normalize_list paths) else x (* [is_prefix x y] is [x] a pathname prefix of [y] *) let is_prefix x y = let lx = String.length x and ly = String.length y in if lx = ly then x = (String.before y lx) else if lx < ly then x = (String.before y lx) && List.mem y.[lx] dir_seps else false let link_to_dir p dir = is_link p && is_prefix dir (readlink p) let remove_extension x = try chop_extension x with Invalid_argument _ -> x let get_extension x = try let pos = String.rindex x '.' in String.after x (pos + 1) with Not_found -> "" let update_extension ext x = add_extension ext (chop_extension x) let chop_extensions x = let dirname = dirname x and basename = basename x in try let pos = String.index basename '.' in dirname / (String.before basename pos) with Not_found -> invalid_arg "chop_extensions: no extensions" let remove_extensions x = try chop_extensions x with Invalid_argument _ -> x let get_extensions x = let basename = basename x in try let pos = String.index basename '.' in String.after basename (pos + 1) with Not_found -> "" let update_extensions ext x = add_extension ext (chop_extensions x) let exists = sys_file_exists let copy = Shell.cp let remove = Shell.rm let try_remove x = if exists x then Shell.rm x let read = read_file let with_input_file = with_input_file let with_output_file = with_output_file let print_path_list = List.print print let context_table = Hashtbl.create 107 let rec include_dirs_of dir = try Hashtbl.find context_table dir with Not_found -> dir :: List.filter (fun dir' -> dir <> dir') !Options.include_dirs (* let include_dirs_of s = let res = include_dirs_of s in let () = dprintf 0 "include_dirs_of %S ->@ %a" s (List.print print) res in res *) let define_context dir context = let dir = if dir = "" then current_dir_name else dir in Hashtbl.replace context_table dir& List.union context& include_dirs_of dir let same_contents x y = Digest.file x = Digest.file y mingw-ocaml/ocaml/ocamlbuild/signatures.mli0000644000175000017500000007021512124403240020464 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) (** This module contains all module signatures that the user could use to build an ocamlbuild plugin. *) module type OrderedTypePrintable = sig type t val compare : t -> t -> int val print : Format.formatter -> t -> unit end module type SET = sig include Set.S val find : (elt -> bool) -> t -> elt val map : (elt -> elt) -> t -> t val of_list : elt list -> t val print : Format.formatter -> t -> unit end module type LIST = sig (* Added functions *) val print : (Format.formatter -> 'a -> 'b) -> Format.formatter -> 'a list -> unit val filter_opt : ('a -> 'b option) -> 'a list -> 'b list val union : 'a list -> 'a list -> 'a list val ordered_unique : 'a list -> 'a list (* Original functions *) include module type of List end module type STRING = sig val print : Format.formatter -> string -> unit val chomp : string -> string (** [before s n] returns the substring of all characters of [s] that precede position [n] (excluding the character at position [n]). This is the same function as {!Str.string_before}. *) val before : string -> int -> string (** [after s n] returns the substring of all characters of [s] that follow position [n] (including the character at position [n]). This is the same function as {!Str.string_after}. *) val after : string -> int -> string val first_chars : string -> int -> string (** [first_chars s n] returns the first [n] characters of [s]. This is the same function as {!before} ant {!Str.first_chars}. *) val last_chars : string -> int -> string (** [last_chars s n] returns the last [n] characters of [s]. This is the same function as {!Str.last_chars}. *) val eq_sub_strings : string -> int -> string -> int -> int -> bool (** [is_prefix u v] is u a prefix of v ? *) val is_prefix : string -> string -> bool (** [is_suffix u v] : is v a suffix of u ? *) val is_suffix : string -> string -> bool (** [contains_string s1 p2 s2] Search in [s1] starting from [p1] if it contains the [s2] string. Returns [Some position] where [position] is the begining of the string [s2] in [s1], [None] otherwise. *) val contains_string : string -> int -> string -> int option (** [subst patt repl text] *) val subst : string -> string -> string -> string (** [tr patt repl text] *) val tr : char -> char -> string -> string val rev : string -> string (* Convert a character list into a character string *) val implode : char list -> string (* Convert a character string into a character list *) val explode : string -> char list (** The following are original functions from the [String] module. *) include module type of String end module type TAGS = sig include Set.S with type elt = string val of_list : string list -> t val print : Format.formatter -> t -> unit val does_match : t -> t -> bool module Operators : sig val ( ++ ) : t -> elt -> t val ( -- ) : t -> elt -> t val ( +++ ) : t -> elt option -> t val ( --- ) : t -> elt option -> t end end module type PATHNAME = sig type t = string val concat : t -> t -> t val compare : t -> t -> int val equal : t -> t -> bool val exists : t -> bool val mk : string -> t val define_context : string -> string list -> unit val include_dirs_of : string -> string list val copy : t -> t -> unit val to_string : t -> string val print : Format.formatter -> t -> unit val current_dir_name : t val parent_dir_name : t val read : t -> string val same_contents : t -> t -> bool val basename : t -> t val dirname : t -> t val is_relative : t -> bool val readlink : t -> t val readdir : t -> t array val is_link : t -> bool val is_directory : t -> bool val add_extension : string -> t -> t val check_extension : t -> string -> bool val get_extension : t -> string val remove_extension : t -> t val update_extension : string -> t -> t val get_extensions : t -> string val remove_extensions : t -> t val update_extensions : string -> t -> t val print_path_list : Format.formatter -> t list -> unit val pwd : t val parent : t -> t (** [is_prefix x y] is [x] a pathname prefix of [y] *) val is_prefix : t -> t -> bool val is_implicit : t -> bool module Operators : sig val ( / ) : t -> t -> t val ( -.- ) : t -> string -> t end end (** Provides an abstract type for easily building complex shell commands without making quotation mistakes. *) module type COMMAND = sig type tags type pathname (** The type [t] provides some basic combinators and command primitives. Other commands can be made of command specifications ([spec]). *) type t = | Seq of t list (** A sequence of commands (like the `;' in shell) *) | Cmd of spec (** A command is made of command specifications ([spec]) *) | Echo of string list * pathname (** Write the given strings (w/ any formatting) to the given file *) | Nop (** The command that does nothing *) (** The type for command specifications. That is pieces of command. *) and spec = | N (** No operation. *) | S of spec list (** A sequence. This gets flattened in the last stages *) | A of string (** An atom. *) | P of pathname (** A pathname. *) | Px of pathname (** A pathname, that will also be given to the call_with_target hook. *) | Sh of string (** A bit of raw shell code, that will not be escaped. *) | T of tags (** A set of tags, that describe properties and some semantics information about the command, afterward these tags will be replaced by command [spec]s (flags for instance). *) | V of string (** A virtual command, that will be resolved at execution using [resolve_virtuals] *) | Quote of spec (** A string that should be quoted like a filename but isn't really one. *) (*type v = [ `Seq of v list | `Cmd of vspec | `Nop ] and vspec = [ `N | `S of vspec list | `A of string | `P of pathname | `Px of pathname | `Sh of string | `Quote of vspec ] val spec_of_vspec : vspec -> spec val vspec_of_spec : spec -> vspec val t_of_v : v -> t val v_of_t : t -> v*) (** Will convert a string list to a list of atoms by adding [A] constructors. *) val atomize : string list -> spec (** Will convert a string list to a list of paths by adding [P] constructors. *) val atomize_paths : string list -> spec (** Run the command. *) val execute : ?quiet:bool -> ?pretend:bool -> t -> unit (** Run the commands in the given list, if possible in parallel. See the module [Ocamlbuild_executor]. *) val execute_many : ?quiet:bool -> ?pretend:bool -> t list -> (bool list * exn) option (** [setup_virtual_command_solver virtual_command solver] the given solver can raise Not_found if it fails to find a valid command for this virtual command. *) val setup_virtual_command_solver : string -> (unit -> spec) -> unit (** Search the given command in the command path and return its absolute pathname. *) val search_in_path : string -> string (** Simplify a command by flattening the sequences and resolving the tags into command-line options. *) val reduce : spec -> spec (** Print a command (the format is not suitable to running the command). *) val print : Format.formatter -> t -> unit (** Convert a command to a string (same format as print). *) val to_string : t -> string (** Build a string representation of a command that can be passed to the system calls. *) val string_of_command_spec : spec -> string end (** A self-contained module implementing extended shell glob patterns who have an expressive power equal to boolean combinations of regular expressions. *) module type GLOB = sig (** A globber is a boolean combination of basic expressions indented to work on pathnames. Known operators are [or], [and] and [not], which may also be written [|], [&] and [~]. There are also constants [true] and [false] (or [1] and [0]). Expression can be grouped using parentheses. - [true] matches anything, - [false] matches nothing, - {i basic} [or] {i basic} matches strings matching either one of the basic expressions, - {i basic} [and] {i basic} matches strings matching both basic expressions, - not {i basic} matches string that don't match the basic expression, - {i basic} matches strings that match the basic expression. A basic expression can be a constant string enclosed in double quotes, in which double quotes must be preceded by backslashes, or a glob pattern enclosed between a [<] and a [>], - ["]{i string}["] matches the literal string {i string}, - [<]{i glob}[>] matches the glob pattern {i glob}. A glob pattern is an anchored regular expression in a shell-like syntax. Most characters stand for themselves. Character ranges are given in usual shell syntax between brackets. The star [*] stands for any sequence of characters. The joker '?' stands for exactly one, unspecified character. Alternation is achieved using braces [{]. - {i glob1}{i glob2} matches strings who have a prefix matching {i glob1} and the corresponding suffix matching {i glob2}. - [a] matches the string consisting of the single letter [a]. - [{]{i glob1},{i glob2}[}] matches strings matching {i glob1} or {i glob2}. - [?] any one-letter string, excluding the slash. - [*] matches all strings not containing a slash, including the empty one. - [**/] the empty string, or any string ending with a slash. - [/**] any string starting with a slash, or the empty string. - [/**/] any string starting and ending with a slash. - [\[]{i c1}-{i c2}{i c3}-{i c4}...[\]] matches characters in the range {i c1} to {i c2} inclusive, or in the range {i c3} to {i c4} inclusive. For instance [\[a-fA-F0-9\]] matches hexadecimal digits. To match the dash, put it at the end. *) (** The type representing globbers. Do not attempt to compare them, as they get on-the-fly optimizations. *) type globber (** [parse ~dir pattern] will parse the globber pattern [pattern], optionally prefixing its patterns with [dir]. *) val parse : ?dir:string -> string -> globber (** A descriptive exception raised when an invalid glob pattern description is given. *) exception Parse_error of string (** [eval g u] returns [true] if and only if the string [u] matches the given glob expression. Avoid reparsing the same pattern, since the automaton implementing the pattern is optimized on the fly. The first few evaluations are done using a time-inefficient but memory-efficient algorithm. It then compiles the pattern into an efficient but more memory-hungry data structure. *) val eval : globber -> string -> bool end (** Module for modulating the logging output with the logging level. *) module type LOG = sig (** Current logging (debugging) level. *) val level : int ref (** [dprintf level fmt args...] formats the logging information [fmt] with the arguments [args...] on the logging output if the logging level is greater than or equal to [level]. The default level is 1. More obscure debugging information should have a higher logging level. Youre formats are wrapped inside these two formats ["@\[<2>"] and ["@\]@."]. *) val dprintf : int -> ('a, Format.formatter, unit) format -> 'a (** Equivalent to calling [dprintf] with a level [< 0]. *) val eprintf : ('a, Format.formatter, unit) format -> 'a (** Same as dprintf but without the format wrapping. *) val raw_dprintf : int -> ('a, Format.formatter, unit) format -> 'a end module type OUTCOME = sig type ('a,'b) t = | Good of 'a | Bad of 'b val wrap : ('a -> 'b) -> 'a -> ('b, exn) t val ignore_good : ('a, exn) t -> unit val good : ('a, exn) t -> 'a end module type MISC = sig val opt_print : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit val the : 'a option -> 'a val getenv : ?default:string -> string -> string val with_input_file : ?bin:bool -> string -> (in_channel -> 'a) -> 'a val with_output_file : ?bin:bool -> string -> (out_channel -> 'a) -> 'a val with_temp_file : string -> string -> (string -> 'a) -> 'a val read_file : string -> string val copy_chan : in_channel -> out_channel -> unit val copy_file : string -> string -> unit val print_string_list : Format.formatter -> string list -> unit (** A shortcut to force lazy value (See {Lazy.force}). *) val ( !* ) : 'a Lazy.t -> 'a (** The right associative application. Useful when writing to much parentheses: << f (g x ... t) >> becomes << f& g x ... t >> << f (g (h x)) >> becomes << f& g& h x >> *) val ( & ) : ('a -> 'b) -> 'a -> 'b (** The reversed application combinator. Useful to describe some operations chaining. << f x (g y (h z)) >> becomes << z |> h |> g y |> f x >> *) val ( |> ) : 'a -> ('a -> 'b) -> 'b (** [r @:= l] is equivalent to [r := !r @ l] *) val ( @:= ) : 'a list ref -> 'a list -> unit val memo : ('a -> 'b) -> ('a -> 'b) end module type OPTIONS = sig type command_spec val build_dir : string ref val include_dirs : string list ref val exclude_dirs : string list ref val nothing_should_be_rebuilt : bool ref val ocamlc : command_spec ref val ocamlopt : command_spec ref val ocamldep : command_spec ref val ocamldoc : command_spec ref val ocamlyacc : command_spec ref val ocamllex : command_spec ref val ocamlrun : command_spec ref val ocamlmklib : command_spec ref val ocamlmktop : command_spec ref val hygiene : bool ref val sanitize : bool ref val sanitization_script : string ref val ignore_auto : bool ref val plugin : bool ref val just_plugin : bool ref val native_plugin : bool ref val make_links : bool ref val nostdlib : bool ref val program_to_execute : bool ref val must_clean : bool ref val catch_errors : bool ref val use_menhir : bool ref val show_documentation : bool ref val recursive : bool ref val use_ocamlfind : bool ref val targets : string list ref val ocaml_libs : string list ref val ocaml_mods : string list ref val ocaml_pkgs : string list ref val ocaml_cflags : string list ref val ocaml_lflags : string list ref val ocaml_ppflags : string list ref val ocaml_docflags : string list ref val ocaml_yaccflags : string list ref val ocaml_lexflags : string list ref val program_args : string list ref val ignore_list : string list ref val tags : string list ref val tag_lines : string list ref val show_tags : string list ref val ext_obj : string ref val ext_lib : string ref val ext_dll : string ref val exe : string ref val add : string * Arg.spec * string -> unit end module type ARCH = sig type 'a arch = private | Arch_dir of string * 'a * 'a arch list | Arch_dir_pack of string * 'a * 'a arch list | Arch_file of string * 'a val dir : string -> unit arch list -> unit arch val dir_pack : string -> unit arch list -> unit arch val file : string -> unit arch type info = private { current_path : string; include_dirs : string list; for_pack : string; } val annotate : 'a arch -> info arch val print : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a arch -> unit val print_include_dirs : Format.formatter -> string list -> unit val print_info : Format.formatter -> info -> unit val iter_info : ('a -> unit) -> 'a arch -> unit val fold_info : ('a -> 'b -> 'b) -> 'a arch -> 'b -> 'b val iter_include_dirs : info arch -> (string -> unit) -> unit val mk_tables : info arch -> (string, string list) Hashtbl.t * (string, string) Hashtbl.t val print_table : (Format.formatter -> 'a -> unit) -> Format.formatter -> (string, 'a) Hashtbl.t -> unit end module type FINDLIB = sig (** Findlib / Ocamlfind tools. *) type command_spec type error = | Cannot_run_ocamlfind | Dependency_not_found of string * string (* package, dependency *) | Package_not_found of string | Cannot_parse_query of string * string (* package, explaination *) exception Findlib_error of error val string_of_error: error -> string (** Return a string message describing an error. *) val report_error: error -> 'a (** Report an error on the standard error and exit with code 2. *) type package = { name: string; description: string; version: string; archives_byte: string; (** Archive names, with the .cma extension, but without the directory. *) archives_native: string; (** Archive names, with the .cmxa extension, but without the directory. *) link_options: string; location: string; dependencies: package list; (** Transitive closure, as returned by [ocamlfind query -r]. *) } (** Package information. *) val query: string -> package (** Query information about a package, given its name. May raise [Not_found]. *) val list: unit -> string list (** Return the names of all known packages. *) val topological_closure: package list -> package list (** Computes the transitive closure of a list of packages and sort them in topological order. Given any list of package [l], [topological_closure l] returns a list of packages including [l] and their dependencies, in an order where any element may only depend on the previous ones. *) val compile_flags_byte: package list -> command_spec (** Return the flags to add when compiling in byte mode (include directories). *) val compile_flags_native: package list -> command_spec (** Same as [link_flags_byte] but for native mode. *) val link_flags_byte: package list -> command_spec (** Return the flags to add when linking in byte mode. It includes: include directories, libraries and special link options. *) val link_flags_native: package list -> command_spec (** Same as [link_flags_byte] but for native mode. *) end (** This module contains the functions and values that can be used by plugins. *) module type PLUGIN = sig module Pathname : PATHNAME module Tags : TAGS module Command : COMMAND with type tags = Tags.t and type pathname = Pathname.t module Outcome : OUTCOME module String : STRING module List : LIST module StringSet : Set.S with type elt = String.t module Options : OPTIONS with type command_spec = Command.spec module Arch : ARCH module Findlib : FINDLIB with type command_spec = Command.spec include MISC (** See [COMMAND] for the description of these types. *) type command = Command.t = Seq of command list | Cmd of spec | Echo of string list * Pathname.t | Nop and spec = Command.spec = | N | S of spec list | A of string | P of string | Px of string | Sh of string | T of Tags.t | V of string | Quote of spec (** [path1/path2] Join the given path names. *) val ( / ) : Pathname.t -> Pathname.t -> Pathname.t (** [path-.-extension] Add the given extension to the given pathname. *) val ( -.- ) : Pathname.t -> string -> Pathname.t (** [tags++tag] Add the given tag to the given set of tags. *) val ( ++ ) : Tags.t -> Tags.elt -> Tags.t (** [tags--tag] Remove the given tag to the given set of tags. *) val ( -- ) : Tags.t -> Tags.elt -> Tags.t (** [tags+++optional_tag] Add the given optional tag to the given set of tags if the given option is Some. *) val ( +++ ) : Tags.t -> Tags.elt option -> Tags.t (** [tags---optional_tag] Remove the given optional tag to the given set of tags if the given option is Some. *) val ( --- ) : Tags.t -> Tags.elt option -> Tags.t (** The type of the builder environments. Here an environment is just the lookup function of it. Basically this function will resolve path variables like % or more generally %(var_name). *) type env = Pathname.t -> Pathname.t (** A builder is a function that waits for conjonction of alternative targets. The alternatives are here to support some choices, for instance for an OCaml module an alternatives can be foo.cmo, foo.cmi, Foo.cmo, Foo.cmi. Conjonctions are here to help making parallelism, indeed commands that are independant will be run concurently. *) type builder = Pathname.t list list -> (Pathname.t, exn) Outcome.t list (** This is the type for rule actions. An action receive as argument, the environment lookup function (see [env]), and a function to dynamically build more targets (see [builder]). An action should return the command to run in order to build the rule productions using the rule dependencies. *) type action = env -> builder -> Command.t (** This is the main function for adding a rule to the ocamlbuild engine. - The first argument is the name of the rule (should be unique). - It takes files that the rule produces. Use ~prod for one file, ~prods for list of files. - It also takes files that the rule uses. Use ~dep for one file, ~deps for list of files. - It finally takes the action to perform in order to produce the productions files using the dependencies (see [action]). There is also two more options: - The ~insert argument allow to insert the rules precisely between other rules. - The ~stamp argument specify the name of a file that will be automatically produced by ocamlbuild. This file can serve as a virtual target (or phony target), since it will be filled up by a digest of it dependencies. - The ~tags argument in deprecated, don't use it. *) val rule : string -> ?tags:string list -> ?prods:string list -> ?deps:string list -> ?prod:string -> ?dep:string -> ?stamp:string -> ?insert:[`top | `before of string | `after of string | `bottom] -> action -> unit (** [copy_rule name ?insert source destination] *) val copy_rule : string -> ?insert:[`top | `before of string | `after of string | `bottom] -> string -> string -> unit (** Empties the list of rules of the ocamlbuild engine. *) val clear_rules : unit -> unit (** [dep tags deps] Will build [deps] when all [tags] will be activated. *) val dep : Tags.elt list -> Pathname.t list -> unit (** [pdep tags ptag deps] is equivalent to [dep tags deps], with an additional parameterized tag [ptag]. [deps] is now a function which takes the parameter of the tag [ptag] as an argument. Example: [pdep ["ocaml"; "compile"] "autodep" (fun param -> param)] says that the tag [autodep(file)] can now be used to automatically add [file] as a dependency when compiling an OCaml program. *) val pdep : Tags.elt list -> Tags.elt -> (string -> Pathname.t list) -> unit (** [flag tags command_spec] Will inject the given piece of command ([command_spec]) when all [tags] will be activated. *) val flag : Tags.elt list -> Command.spec -> unit (** Allows to use [flag] with a parameterized tag (as [pdep] for [dep]). Example: [pflag ["ocaml"; "compile"] "inline" (fun count -> S [A "-inline"; A count])] says that command line option ["-inline 42"] should be added when compiling files tagged with tag ["inline(42)"]. *) val pflag : Tags.elt list -> Tags.elt -> (string -> Command.spec) -> unit (** [flag_and_dep tags command_spec] Combines [flag] and [dep] function. Basically it calls [flag tags command_spec], and calls [dep tags files] where [files] is the list of all pathnames in [command_spec]. Pathnames selected are those in the constructor [P] or [Px], or the pathname argument of builtins like [Echo]. *) val flag_and_dep : Tags.elt list -> Command.spec -> unit (** Allows to use [flag_and_dep] with a parameterized tag (as [pdep] for [dep]). *) val pflag_and_dep : Tags.elt list -> Tags.elt -> (string -> Command.spec) -> unit (** [non_dependency module_path module_name] Example: [non_dependency "foo/bar/baz" "Goo"] Says that the module [Baz] in the file [foo/bar/baz.*] does not depend on [Goo]. *) val non_dependency : Pathname.t -> string -> unit (** [use_lib module_path lib_path]*) val use_lib : Pathname.t -> Pathname.t -> unit (** [ocaml_lib library_pathname] Declare an ocaml library. Example: ocaml_lib "foo/bar" This will setup the tag use_bar tag. At link time it will include: foo/bar.cma or foo/bar.cmxa If you supply the ~dir:"boo" option -I boo will be added at link and compile time. Use ~extern:true for non-ocamlbuild handled libraries. Use ~byte:false or ~native:false to disable byte or native mode. Use ~tag_name:"usebar" to override the default tag name. *) val ocaml_lib : ?extern:bool -> ?byte:bool -> ?native:bool -> ?dir:Pathname.t -> ?tag_name:string -> Pathname.t -> unit (** [expand_module include_dirs module_name extensions] Example: [expand_module ["a";"b";"c"] "Foo" ["cmo";"cmi"] = ["a/foo.cmo"; "a/Foo.cmo"; "a/foo.cmi"; "a/Foo.cmi"; "b/foo.cmo"; "b/Foo.cmo"; "b/foo.cmi"; "b/Foo.cmi"; "c/foo.cmo"; "c/Foo.cmo"; "c/foo.cmi"; "c/Foo.cmi"]] *) val expand_module : Pathname.t list -> Pathname.t -> string list -> Pathname.t list (** Reads the given file, parse it has list of words separated by blanks. It ignore lines that begins with a '#' character. *) val string_list_of_file : Pathname.t -> string list (** Takes a pathname and returns an OCaml module name. Basically it will remove directories and extensions, and then capitalize the string. *) val module_name_of_pathname : Pathname.t -> string (** The Unix mv command. *) val mv : Pathname.t -> Pathname.t -> Command.t (** The Unix cp command. *) val cp : Pathname.t -> Pathname.t -> Command.t (** The Unix ln -f command. *) val ln_f : Pathname.t -> Pathname.t -> Command.t (** The Unix ln -s command. *) val ln_s : Pathname.t -> Pathname.t -> Command.t (** The Unix rm -f command. *) val rm_f : Pathname.t -> Command.t (** The Unix chmod command (almost deprecated). *) val chmod : Command.spec -> Pathname.t -> Command.t (** The Unix cmp command (almost deprecated). *) val cmp : Pathname.t -> Pathname.t -> Command.t (** [hide_package_contents pack_name] Don't treat the given package as an open package. So a module will not be replaced during linking by this package even if it contains that module. *) val hide_package_contents : string -> unit (** [tag_file filename tag_list] Tag the given filename with all given tags. *) val tag_file : Pathname.t -> Tags.elt list -> unit (** [tag_any tag_list] Tag anything with all given tags. *) val tag_any : Tags.elt list -> unit (** Returns the set of tags that applies to the given pathname. *) val tags_of_pathname : Pathname.t -> Tags.t (** Run the given command and returns it's output as a string. *) val run_and_read : string -> string (** Here is the list of hooks that the dispatch function have to handle. Generally one respond to one or two hooks (like After_rules) and do nothing in the default case. *) type hook = | Before_hygiene | After_hygiene | Before_options | After_options | Before_rules | After_rules (** [dispatch hook_handler] Is the entry point for ocamlbuild plugins. Every plugin must call it with a [hook_handler] where all calls to plugin functions lives. *) val dispatch : (hook -> unit) -> unit end mingw-ocaml/ocaml/ocamlbuild/ocamlbuild_unix_plugin.ml0000644000175000017500000000606412124403240022664 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open Format open Ocamlbuild_pack open My_unix let report_error f = function | Unix.Unix_error(err, fun_name, arg) -> fprintf f "%s: %S failed" Sys.argv.(0) fun_name; if String.length arg > 0 then fprintf f " on %S" arg; fprintf f ": %s" (Unix.error_message err) | exn -> raise exn let mkstat unix_stat x = let st = try unix_stat x with Unix.Unix_error _ as e -> raise (Sys_error (My_std.sbprintf "%a" report_error e)) in { stat_key = sprintf "(%d,%d)" st.Unix.st_dev st.Unix.st_ino; stat_file_kind = match st.Unix.st_kind with | Unix.S_LNK -> FK_link | Unix.S_DIR -> FK_dir | Unix.S_CHR | Unix.S_BLK | Unix.S_FIFO | Unix.S_SOCK -> FK_other | Unix.S_REG -> FK_file } let is_link s = (Unix.lstat s).Unix.st_kind = Unix.S_LNK let at_exit_once callback = let pid = Unix.getpid () in at_exit begin fun () -> if pid = Unix.getpid () then callback () end let run_and_open s kont = let ic = Unix.open_process_in s in let close () = match Unix.close_process_in ic with | Unix.WEXITED 0 -> () | Unix.WEXITED _ | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> failwith (Printf.sprintf "Error while running: %s" s) in let res = try kont ic with e -> (close (); raise e) in close (); res let stdout_isatty () = Unix.isatty Unix.stdout && try Unix.getenv "TERM" <> "dumb" with Not_found -> true let execute_many = let exit i = raise (My_std.Exit_with_code i) in let exit = function | Ocamlbuild_executor.Subcommand_failed -> exit Exit_codes.rc_executor_subcommand_failed | Ocamlbuild_executor.Subcommand_got_signal -> exit Exit_codes.rc_executor_subcommand_got_signal | Ocamlbuild_executor.Io_error -> exit Exit_codes.rc_executor_io_error | Ocamlbuild_executor.Exceptionl_condition -> exit Exit_codes.rc_executor_excetptional_condition in Ocamlbuild_executor.execute ~exit let setup () = implem.is_degraded <- false; implem.stdout_isatty <- stdout_isatty; implem.gettimeofday <- Unix.gettimeofday; implem.report_error <- report_error; implem.execute_many <- execute_many; implem.readlink <- Unix.readlink; implem.run_and_open <- run_and_open; implem.at_exit_once <- at_exit_once; implem.is_link <- is_link; implem.stat <- mkstat Unix.stat; implem.lstat <- mkstat Unix.lstat;; mingw-ocaml/ocaml/ocamlbuild/ocaml_utils.mli0000644000175000017500000000362712124403240020616 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) val stdlib_dir : Pathname.t Lazy.t val module_name_of_filename : Pathname.t -> string val module_name_of_pathname : Pathname.t -> string val ignore_stdlib : string -> bool val non_dependency : string -> string -> unit val expand_module : Pathname.t list -> Pathname.t -> string list -> Pathname.t list val string_list_of_file : string -> string list val ocaml_ppflags : Tags.t -> Command.spec val ocaml_include_flags : Pathname.t -> Command.spec val libraries_of : Pathname.t -> Pathname.t list val use_lib : Pathname.t -> Pathname.t -> unit val cmi_of : Pathname.t -> Pathname.t val ocaml_add_include_flag : string -> Command.spec list -> Command.spec list val flag_and_dep : Tags.elt list -> Command.spec -> unit val pflag_and_dep : Tags.elt list -> Tags.elt -> (string -> Command.spec) -> unit exception Ocamldep_error of string (* Takes a path and returns a list of modules *) val path_dependencies_of : Pathname.t -> ([ `mandatory | `just_try ] * string) list val info_libraries : (string, string * bool) Hashtbl.t val ocaml_lib : ?extern:bool -> ?byte:bool -> ?native:bool -> ?dir:Pathname.t -> ?tag_name:string -> Pathname.t -> unit mingw-ocaml/ocaml/ocamlbuild/ocaml_utils.ml0000644000175000017500000001405612124403240020443 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Original author: Nicolas Pouillard *) open My_std open Format open Log open Pathname.Operators open Tags.Operators open Tools open Flags open Command;; module S = Set.Make(String) let flag_and_dep tags cmd_spec = flag tags cmd_spec; let ps = Command.fold_pathnames (fun p ps -> p :: ps) (Cmd cmd_spec) [] in dep tags ps let stdlib_dir = lazy begin let ocamlc_where = !Options.build_dir / (Pathname.mk "ocamlc.where") in let () = Command.execute ~quiet:true (Cmd(S[!Options.ocamlc; A"-where"; Sh">"; P ocamlc_where])) in String.chomp (read_file ocamlc_where) end let pflag_and_dep tags ptag cmd_spec = Param_tags.declare ptag (fun param -> flag_and_dep (Param_tags.make ptag param :: tags) (cmd_spec param)) let module_name_of_filename f = String.capitalize (Pathname.remove_extensions f) let module_name_of_pathname x = module_name_of_filename (Pathname.to_string (Pathname.basename x)) let ignore_stdlib x = if !Options.nostdlib then false else let x' = !*stdlib_dir/((String.uncapitalize x)-.-"cmi") in Pathname.exists x' let non_dependencies = ref [] let non_dependency m1 m2 = (* non_dependency was not supposed to accept pathnames without extension. *) if String.length (Pathname.get_extensions m1) = 0 then invalid_arg "non_dependency: no extension"; non_dependencies := (m1, m2) :: !non_dependencies let path_importance path x = if List.mem (path, x) !non_dependencies || (List.mem x !Options.ignore_list) then begin let () = dprintf 3 "This module (%s) is ignored by %s" x path in `ignored end else if ignore_stdlib x then `just_try else `mandatory let expand_module include_dirs module_name exts = let dirname = Pathname.dirname module_name in let basename = Pathname.basename module_name in let module_name_cap = dirname/(String.capitalize basename) in let module_name_uncap = dirname/(String.uncapitalize basename) in List.fold_right begin fun include_dir -> List.fold_right begin fun ext acc -> include_dir/(module_name_uncap-.-ext) :: include_dir/(module_name_cap-.-ext) :: acc end exts end include_dirs [] let string_list_of_file file = with_input_file file begin fun ic -> Lexers.blank_sep_strings (Lexing.from_channel ic) end let print_path_list = Pathname.print_path_list let ocaml_ppflags tags = let flags = Flags.of_tags (tags++"ocaml"++"pp") in let reduced = Command.reduce flags in if reduced = N then N else S[A"-pp"; Quote reduced] let ocaml_add_include_flag x acc = if x = Pathname.current_dir_name then acc else A"-I" :: A x :: acc let ocaml_include_flags path = S (List.fold_right ocaml_add_include_flag (Pathname.include_dirs_of (Pathname.dirname path)) []) let info_libraries = Hashtbl.create 103 let libraries = Hashtbl.create 103 let libraries_of m = try Hashtbl.find libraries m with Not_found -> [] let use_lib m lib = Hashtbl.replace libraries m (lib :: libraries_of m) let ocaml_lib ?(extern=false) ?(byte=true) ?(native=true) ?dir ?tag_name libpath = let add_dir x = match dir with | Some dir -> S[A"-I"; P dir; x] | None -> x in let tag_name = match tag_name with | Some x -> x | None -> "use_" ^ Pathname.basename libpath in let flag_and_dep tags lib = flag tags (add_dir (A lib)); if not extern then dep tags [lib] (* cannot happen? *) in Hashtbl.replace info_libraries tag_name (libpath, extern); if extern then begin if byte then flag_and_dep ["ocaml"; tag_name; "link"; "byte"] (libpath^".cma"); if native then flag_and_dep ["ocaml"; tag_name; "link"; "native"] (libpath^".cmxa"); end else begin if not byte && not native then invalid_arg "ocaml_lib: ~byte:false or ~native:false only works with ~extern:true"; end; match dir with | None -> () | Some dir -> List.iter (fun x -> flag ["ocaml"; tag_name; x] (S[A"-I"; P dir])) ["compile"; "doc"; "infer_interface"] let cmi_of = Pathname.update_extensions "cmi" exception Ocamldep_error of string let read_path_dependencies = let path_dependencies = Hashtbl.create 103 in let read path = let module_name = module_name_of_pathname path in let depends = path-.-"depends" in with_input_file depends begin fun ic -> let ocamldep_output = try Lexers.ocamldep_output (Lexing.from_channel ic) with Lexers.Error msg -> raise (Ocamldep_error(Printf.sprintf "Ocamldep.ocamldep: bad output (%s)" msg)) in let deps = List.fold_right begin fun (path, deps) acc -> let module_name' = module_name_of_pathname path in if module_name' = module_name then List.union deps acc else raise (Ocamldep_error(Printf.sprintf "Ocamldep.ocamldep: multiple files in ocamldep output (%s not expected)" path)) end ocamldep_output [] in let deps = if !Options.nostdlib && not (Tags.mem "nopervasives" (tags_of_pathname path)) then "Pervasives" :: deps else deps in let deps' = List.fold_right begin fun dep acc -> match path_importance path dep with | `ignored -> acc | (`just_try | `mandatory) as importance -> (importance, dep) :: acc end deps [] in Hashtbl.replace path_dependencies path (List.union (try Hashtbl.find path_dependencies path with Not_found -> []) deps'); deps' end in read let path_dependencies_of = memo read_path_dependencies mingw-ocaml/ocaml/ocamlbuild/misc/0000755000175000017500000000000012124403240016523 5ustar tootstootsmingw-ocaml/ocaml/ocamlbuild/misc/opentracer.ml0000644000175000017500000000724312124403240021225 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) open My_std module type TRACER = sig (** Call the given command using the tracer, it returns the exit status. *) val call : string -> string list -> StringSet.t * Unix.process_status end module Ktrace = struct let process_line line (wait_a_string, set) = let strings = Lexers.space_sep_strings (Lexing.from_string line) in if wait_a_string then match strings with | [_; _; "NAMI"; file] -> false, StringSet.add file set | _ -> failwith (Printf.sprintf "unexpected ktrace output line (%S)" line) else match strings with | [_; _; "CALL"; fct] -> (String.length fct > 5 && String.sub fct 0 5 = "open("), set | _ -> false, set let call cmd args = let tmp = Filename.temp_file "ktrace" "out" in match Unix.fork () with | 0 -> Unix.execvp "ktrace" (Array.of_list("-d"::"-i"::"-t"::"nc"::"-f"::tmp::cmd::args)) | pid -> let _, st = Unix.waitpid [] pid in let ic = Unix.open_process_in (Printf.sprintf "kdump -f %s" (Filename.quote tmp)) in let close () = ignore (Unix.close_process_in ic); Sys.remove tmp in let set = try let rec loop acc = match try Some (input_line ic) with End_of_file -> None with | Some line -> loop (process_line line acc) | None -> acc in let _, set = loop (false, StringSet.empty) in close (); set with e -> (close (); raise e) in set, st end module Driver (T : TRACER) = struct let usage () = Printf.eprintf "Usage: %s [-a ]* *\n%!" Sys.argv.(0); exit 2 let main () = let log = "opentracer.log" in let oc = if sys_file_exists log then open_out_gen [Open_wronly;Open_append;Open_text] 0 log else let oc = open_out log in let () = output_string oc "---\n" in oc in let rec loop acc = function | "-a" :: file :: rest -> loop (StringSet.add file acc) rest | "-a" :: _ -> usage () | "--" :: cmd :: args -> acc, cmd, args | cmd :: args -> acc, cmd, args | [] -> usage () in let authorized_files, cmd, args = loop StringSet.empty (List.tl (Array.to_list Sys.argv)) in let opened_files, st = T.call cmd args in let forbidden_files = StringSet.diff opened_files authorized_files in if not (StringSet.is_empty forbidden_files) then begin Printf.fprintf oc "- cmd: %s\n args:\n%!" cmd; let pp = Printf.fprintf oc " - %s\n%!" in List.iter pp args; Printf.fprintf oc " forbidden_files:\n%!"; StringSet.iter pp forbidden_files; end; close_out oc; match st with | Unix.WEXITED st -> exit st | Unix.WSIGNALED s | Unix.WSTOPPED s -> Unix.kill (Unix.getpid ()) s end let main = (* match os with *) (* | "macos" -> *) let module M = Driver(Ktrace) in M.main (* | "linux" -> *) (* let module M = Driver(Strace) in M.main *) let () = main () mingw-ocaml/ocaml/ocamlbuild/ocamlbuild_plugin.mli0000644000175000017500000000173012124403240021765 0ustar tootstoots(***********************************************************************) (* ocamlbuild *) (* *) (* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) include Ocamlbuild_pack.Signatures.PLUGIN with module Pathname = Ocamlbuild_pack.Pathname and module Outcome = Ocamlbuild_pack.My_std.Outcome and module Tags = Ocamlbuild_pack.Tags and module Command = Ocamlbuild_pack.Command mingw-ocaml/ocaml/config/0000755000175000017500000000000012124403240014722 5ustar tootstootsmingw-ocaml/ocaml/config/.ignore0000644000175000017500000000003312124403240016202 0ustar tootstootsm.h s.h Makefile config.sh mingw-ocaml/ocaml/config/s-nt.h0000644000175000017500000000231012124403240015750 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Operating system dependencies, Intel x86 processors, Windows NT */ #define OCAML_OS_TYPE "Win32" #undef BSD_SIGNALS #define HAS_STRERROR #define HAS_SOCKETS #define HAS_GETCWD #define HAS_UTIME #define HAS_DUP2 #define HAS_GETHOSTNAME #define HAS_MKTIME #define HAS_PUTENV #define HAS_LOCALE #define HAS_BROKEN_PRINTF mingw-ocaml/ocaml/config/Makefile.mingw0000644000175000017500000001051312124403240017502 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### # $Id$ # Configuration for Windows, Mingw compiler ######### General configuration PREFIX=C:/ocamlmgw ### Remove this to disable compiling camlp4 CAMLP4=camlp4 ### Where to install the binaries BINDIR=$(PREFIX)/bin ### Where to install the standard library LIBDIR=$(PREFIX)/lib ### Where to install the stub DLLs STUBLIBDIR=$(LIBDIR)/stublibs ### Where to install the info files DISTRIB=$(PREFIX) ### Where to install the man pages MANDIR=$(PREFIX)/man ########## Toolchain and OS dependencies TOOLCHAIN=mingw ### Toolchain prefix TOOLPREF=i686-w64-mingw32- CCOMPTYPE=cc O=o A=a S=s SO=s.o DO=d.o EXE=.exe EXT_DLL=.dll EXT_OBJ=.$(O) EXT_LIB=.$(A) EXT_ASM=.$(S) MANEXT=1 SHARPBANGSCRIPTS=false PTHREAD_LINK= X11_INCLUDES= X11_LINK= DBM_INCLUDES= DBM_LINK= BYTECCRPATH= SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= MKSHAREDLIBRPATH= NATIVECCPROFOPTS= NATIVECCRPATH= ASM=$(TOOLPREF)as ASPP=gcc ASPPPROFFLAGS= PROFILING=noprof DYNLINKOPTS= DEBUGGER=ocamldebugger CC_PROFILE= SYSTHREAD_SUPPORT=true EXTRALIBS= NATDYNLINK=true CMXS=cmxs RUNTIMED=noruntimed ASM_CFI_SUPPORTED=false ########## Configuration for the bytecode compiler ### Which C compiler to use for the bytecode interpreter. BYTECC=$(TOOLPREF)gcc ### Additional compile-time options for $(BYTECC). (For static linking.) BYTECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused ### Additional link-time options for $(BYTECC). (For static linking.) BYTECCLINKOPTS= ### Additional compile-time options for $(BYTECC). (For building a DLL.) DLLCCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused -DCAML_DLL ### Libraries needed BYTECCLIBS=-lws2_32 NATIVECCLIBS=-lws2_32 ### How to invoke the C preprocessor CPP=$(BYTECC) -E ### Flexlink FLEXLINK=flexlink -chain mingw -stack 16777216 FLEXDIR=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) MKEXE=$(FLEXLINK) -exe MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library MKLIB=rm -f $(1); $(TOOLPREF)ar rc $(1) $(2); $(RANLIB) $(1) #ml let mklib out files opts = Printf.sprintf "rm -f %s && %sar rcs %s %s %s" out toolpref opts out files;; ### Canonicalize the name of a system library SYSLIB=-l$(1) #ml let syslib x = "-l"^x;; ### The ranlib command RANLIB=$(TOOLPREF)ranlib RANLIBCMD=$(TOOLPREF)ranlib ### The ar command ARCMD=$(TOOLPREF)ar ############# Configuration for the native-code compiler ### Name of architecture for the native-code compiler ARCH=i386 ### Name of architecture model for the native-code compiler. MODEL=default ### Name of operating system family for the native-code compiler. SYSTEM=mingw ### Which C compiler to use for the native-code compiler. NATIVECC=$(BYTECC) ### Additional compile-time options for $(NATIVECC). NATIVECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused ### Additional link-time options for $(NATIVECC) NATIVECCLINKOPTS= ### Build partially-linked object file PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o #there must be a space after this '-o' ############# Configuration for the contributed libraries OTHERLIBRARIES=win32unix str num win32graph dynlink bigarray systhreads labltk ### Name of the target architecture for the "num" library BNG_ARCH=ia32 BNG_ASM_LEVEL=1 ### Configuration for LablTk # Set TK_ROOT to the directory where you installed TCL/TK 8.5 # There must be no spaces or special characters in $(TK_ROOT) TK_ROOT=c:/tcl TK_DEFS=-I$(TK_ROOT)/include TK_LINK=$(TK_ROOT)/bin/tk85.dll $(TK_ROOT)/bin/tcl85.dll -lws2_32 ############# Aliases for common commands MAKEREC=$(MAKE) -f Makefile.nt MAKECMD=$(MAKE) mingw-ocaml/ocaml/config/gnu/0000755000175000017500000000000012124403240015513 5ustar tootstootsmingw-ocaml/ocaml/config/gnu/config.sub0000755000175000017500000010516212124403240017503 0ustar tootstoots#! /bin/sh # Configuration validation subroutine script. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, # 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, # 2011 Free Software Foundation, Inc. timestamp='2011-11-11' # This file is (in principle) common to ALL GNU software. # The presence of a machine in this file suggests that SOME GNU software # can handle that machine. It does not imply ALL GNU software can. # # This file 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. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Please send patches to . Submit a context # diff and a properly formatted GNU ChangeLog entry. # # Configuration subroutine to validate and canonicalize a configuration type. # Supply the specified configuration type as an argument. # If it is invalid, we print an error message on stderr and exit with code 1. # Otherwise, we print the canonical config type on stdout and succeed. # You can get the latest version of this script from: # http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD # This file is supposed to be the same for all GNU packages # and recognize all the CPU types, system types and aliases # that are meaningful with *any* GNU software. # Each package is responsible for reporting which valid configurations # it does not support. The user should be able to distinguish # a failure to support a valid configuration from a meaningless # configuration. # The goal of this file is to map all the various variations of a given # machine specification into a single specification in the form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM # or in some cases, the newer four-part form: # CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM # It is wrong to echo any other type of specification. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] CPU-MFR-OPSYS $0 [OPTION] ALIAS Canonicalize a configuration name. Operation modes: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.sub ($timestamp) Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" exit 1 ;; *local*) # First pass through any local machine types. echo $1 exit ;; * ) break ;; esac done case $# in 0) echo "$me: missing argument$help" >&2 exit 1;; 1) ;; *) echo "$me: too many arguments$help" >&2 exit 1;; esac # Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). # Here we must recognize all the valid KERNEL-OS combinations. maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` case $maybe_os in nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ knetbsd*-gnu* | netbsd*-gnu* | \ kopensolaris*-gnu* | \ storm-chaos* | os2-emx* | rtmk-nova*) os=-$maybe_os basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` ;; *) basic_machine=`echo $1 | sed 's/-[^-]*$//'` if [ $basic_machine != $1 ] then os=`echo $1 | sed 's/.*-/-/'` else os=; fi ;; esac ### Let's recognize common machines as not being operating systems so ### that things like config.sub decstation-3100 work. We also ### recognize some manufacturers as not being operating systems, so we ### can provide default operating systems below. case $os in -sun*os*) # Prevent following clause from handling this invalid input. ;; -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ -apple | -axis | -knuth | -cray | -microblaze) os= basic_machine=$1 ;; -bluegene*) os=-cnk ;; -sim | -cisco | -oki | -wec | -winbond) os= basic_machine=$1 ;; -scout) ;; -wrs) os=-vxworks basic_machine=$1 ;; -chorusos*) os=-chorusos basic_machine=$1 ;; -chorusrdb) os=-chorusrdb basic_machine=$1 ;; -hiux*) os=-hiuxwe2 ;; -sco6) os=-sco5v6 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco5) os=-sco3.2v5 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco4) os=-sco3.2v4 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2.[4-9]*) os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2v[4-9]*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco5v6*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco*) os=-sco3.2v2 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -udk*) basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -isc) os=-isc2.2 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -clix*) basic_machine=clipper-intergraph ;; -isc*) basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -lynx*) os=-lynxos ;; -ptx*) basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` ;; -windowsnt*) os=`echo $os | sed -e 's/windowsnt/winnt/'` ;; -psos*) os=-psos ;; -mint | -mint[0-9]*) basic_machine=m68k-atari os=-mint ;; esac # Decode aliases for certain CPU-COMPANY combinations. case $basic_machine in # Recognize the basic CPU types without company name. # Some are omitted here because they have special meanings below. 1750a | 580 \ | a29k \ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ | am33_2.0 \ | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr | avr32 \ | be32 | be64 \ | bfin \ | c4x | clipper \ | d10v | d30v | dlx | dsp16xx \ | epiphany \ | fido | fr30 | frv \ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ | hexagon \ | i370 | i860 | i960 | ia64 \ | ip2k | iq2000 \ | le32 | le64 \ | lm32 \ | m32c | m32r | m32rle | m68000 | m68k | m88k \ | maxq | mb | microblaze | mcore | mep | metag \ | mips | mipsbe | mipseb | mipsel | mipsle \ | mips16 \ | mips64 | mips64el \ | mips64octeon | mips64octeonel \ | mips64orion | mips64orionel \ | mips64r5900 | mips64r5900el \ | mips64vr | mips64vrel \ | mips64vr4100 | mips64vr4100el \ | mips64vr4300 | mips64vr4300el \ | mips64vr5000 | mips64vr5000el \ | mips64vr5900 | mips64vr5900el \ | mipsisa32 | mipsisa32el \ | mipsisa32r2 | mipsisa32r2el \ | mipsisa64 | mipsisa64el \ | mipsisa64r2 | mipsisa64r2el \ | mipsisa64sb1 | mipsisa64sb1el \ | mipsisa64sr71k | mipsisa64sr71kel \ | mipstx39 | mipstx39el \ | mn10200 | mn10300 \ | moxie \ | mt \ | msp430 \ | nds32 | nds32le | nds32be \ | nios | nios2 \ | ns16k | ns32k \ | open8 \ | or32 \ | pdp10 | pdp11 | pj | pjl \ | powerpc | powerpc64 | powerpc64le | powerpcle \ | pyramid \ | rl78 | rx \ | score \ | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ | sh64 | sh64le \ | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ | spu \ | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ | ubicom32 \ | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ | we32k \ | x86 | xc16x | xstormy16 | xtensa \ | z8k | z80) basic_machine=$basic_machine-unknown ;; c54x) basic_machine=tic54x-unknown ;; c55x) basic_machine=tic55x-unknown ;; c6x) basic_machine=tic6x-unknown ;; m6811 | m68hc11 | m6812 | m68hc12 | picochip) # Motorola 68HC11/12. basic_machine=$basic_machine-unknown os=-none ;; m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) ;; ms1) basic_machine=mt-unknown ;; strongarm | thumb | xscale) basic_machine=arm-unknown ;; xscaleeb) basic_machine=armeb-unknown ;; xscaleel) basic_machine=armel-unknown ;; # We use `pc' rather than `unknown' # because (1) that's what they normally are, and # (2) the word "unknown" tends to confuse beginning users. i*86 | x86_64) basic_machine=$basic_machine-pc ;; # Object if more than one company name word. *-*-*) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; # Recognize the basic CPU types with company name. 580-* \ | a29k-* \ | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ | avr-* | avr32-* \ | be32-* | be64-* \ | bfin-* | bs2000-* \ | c[123]* | c30-* | [cjt]90-* | c4x-* \ | clipper-* | craynv-* | cydra-* \ | d10v-* | d30v-* | dlx-* \ | elxsi-* \ | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ | h8300-* | h8500-* \ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ | hexagon-* \ | i*86-* | i860-* | i960-* | ia64-* \ | ip2k-* | iq2000-* \ | le32-* | le64-* \ | lm32-* \ | m32c-* | m32r-* | m32rle-* \ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ | m88110-* | m88k-* | maxq-* | mcore-* | metag-* | microblaze-* \ | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ | mips16-* \ | mips64-* | mips64el-* \ | mips64octeon-* | mips64octeonel-* \ | mips64orion-* | mips64orionel-* \ | mips64r5900-* | mips64r5900el-* \ | mips64vr-* | mips64vrel-* \ | mips64vr4100-* | mips64vr4100el-* \ | mips64vr4300-* | mips64vr4300el-* \ | mips64vr5000-* | mips64vr5000el-* \ | mips64vr5900-* | mips64vr5900el-* \ | mipsisa32-* | mipsisa32el-* \ | mipsisa32r2-* | mipsisa32r2el-* \ | mipsisa64-* | mipsisa64el-* \ | mipsisa64r2-* | mipsisa64r2el-* \ | mipsisa64sb1-* | mipsisa64sb1el-* \ | mipsisa64sr71k-* | mipsisa64sr71kel-* \ | mipstx39-* | mipstx39el-* \ | mmix-* \ | mt-* \ | msp430-* \ | nds32-* | nds32le-* | nds32be-* \ | nios-* | nios2-* \ | none-* | np1-* | ns16k-* | ns32k-* \ | open8-* \ | orion-* \ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ | pyramid-* \ | rl78-* | romp-* | rs6000-* | rx-* \ | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ | sparclite-* \ | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx?-* \ | tahoe-* \ | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ | tile*-* \ | tron-* \ | ubicom32-* \ | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ | vax-* \ | we32k-* \ | x86-* | x86_64-* | xc16x-* | xps100-* \ | xstormy16-* | xtensa*-* \ | ymp-* \ | z8k-* | z80-*) ;; # Recognize the basic CPU types without company name, with glob match. xtensa*) basic_machine=$basic_machine-unknown ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. 386bsd) basic_machine=i386-unknown os=-bsd ;; 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) basic_machine=m68000-att ;; 3b*) basic_machine=we32k-att ;; a29khif) basic_machine=a29k-amd os=-udi ;; abacus) basic_machine=abacus-unknown ;; adobe68k) basic_machine=m68010-adobe os=-scout ;; alliant | fx80) basic_machine=fx80-alliant ;; altos | altos3068) basic_machine=m68k-altos ;; am29k) basic_machine=a29k-none os=-bsd ;; amd64) basic_machine=x86_64-pc ;; amd64-*) basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; amdahl) basic_machine=580-amdahl os=-sysv ;; amiga | amiga-*) basic_machine=m68k-unknown ;; amigaos | amigados) basic_machine=m68k-unknown os=-amigaos ;; amigaunix | amix) basic_machine=m68k-unknown os=-sysv4 ;; apollo68) basic_machine=m68k-apollo os=-sysv ;; apollo68bsd) basic_machine=m68k-apollo os=-bsd ;; aros) basic_machine=i386-pc os=-aros ;; aux) basic_machine=m68k-apple os=-aux ;; balance) basic_machine=ns32k-sequent os=-dynix ;; blackfin) basic_machine=bfin-unknown os=-linux ;; blackfin-*) basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; bluegene*) basic_machine=powerpc-ibm os=-cnk ;; c54x-*) basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'` ;; c55x-*) basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'` ;; c6x-*) basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'` ;; c90) basic_machine=c90-cray os=-unicos ;; cegcc) basic_machine=arm-unknown os=-cegcc ;; convex-c1) basic_machine=c1-convex os=-bsd ;; convex-c2) basic_machine=c2-convex os=-bsd ;; convex-c32) basic_machine=c32-convex os=-bsd ;; convex-c34) basic_machine=c34-convex os=-bsd ;; convex-c38) basic_machine=c38-convex os=-bsd ;; cray | j90) basic_machine=j90-cray os=-unicos ;; craynv) basic_machine=craynv-cray os=-unicosmp ;; cr16 | cr16-*) basic_machine=cr16-unknown os=-elf ;; crds | unos) basic_machine=m68k-crds ;; crisv32 | crisv32-* | etraxfs*) basic_machine=crisv32-axis ;; cris | cris-* | etrax*) basic_machine=cris-axis ;; crx) basic_machine=crx-unknown os=-elf ;; da30 | da30-*) basic_machine=m68k-da30 ;; decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) basic_machine=mips-dec ;; decsystem10* | dec10*) basic_machine=pdp10-dec os=-tops10 ;; decsystem20* | dec20*) basic_machine=pdp10-dec os=-tops20 ;; delta | 3300 | motorola-3300 | motorola-delta \ | 3300-motorola | delta-motorola) basic_machine=m68k-motorola ;; delta88) basic_machine=m88k-motorola os=-sysv3 ;; dicos) basic_machine=i686-pc os=-dicos ;; djgpp) basic_machine=i586-pc os=-msdosdjgpp ;; dpx20 | dpx20-*) basic_machine=rs6000-bull os=-bosx ;; dpx2* | dpx2*-bull) basic_machine=m68k-bull os=-sysv3 ;; ebmon29k) basic_machine=a29k-amd os=-ebmon ;; elxsi) basic_machine=elxsi-elxsi os=-bsd ;; encore | umax | mmax) basic_machine=ns32k-encore ;; es1800 | OSE68k | ose68k | ose | OSE) basic_machine=m68k-ericsson os=-ose ;; fx2800) basic_machine=i860-alliant ;; genix) basic_machine=ns32k-ns ;; gmicro) basic_machine=tron-gmicro os=-sysv ;; go32) basic_machine=i386-pc os=-go32 ;; h3050r* | hiux*) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; h8300hms) basic_machine=h8300-hitachi os=-hms ;; h8300xray) basic_machine=h8300-hitachi os=-xray ;; h8500hms) basic_machine=h8500-hitachi os=-hms ;; harris) basic_machine=m88k-harris os=-sysv3 ;; hp300-*) basic_machine=m68k-hp ;; hp300bsd) basic_machine=m68k-hp os=-bsd ;; hp300hpux) basic_machine=m68k-hp os=-hpux ;; hp3k9[0-9][0-9] | hp9[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k2[0-9][0-9] | hp9k31[0-9]) basic_machine=m68000-hp ;; hp9k3[2-9][0-9]) basic_machine=m68k-hp ;; hp9k6[0-9][0-9] | hp6[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k7[0-79][0-9] | hp7[0-79][0-9]) basic_machine=hppa1.1-hp ;; hp9k78[0-9] | hp78[0-9]) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[0-9][13679] | hp8[0-9][13679]) basic_machine=hppa1.1-hp ;; hp9k8[0-9][0-9] | hp8[0-9][0-9]) basic_machine=hppa1.0-hp ;; hppa-next) os=-nextstep3 ;; hppaosf) basic_machine=hppa1.1-hp os=-osf ;; hppro) basic_machine=hppa1.1-hp os=-proelf ;; i370-ibm* | ibm*) basic_machine=i370-ibm ;; # I'm not sure what "Sysv32" means. Should this be sysv3.2? i*86v32) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv32 ;; i*86v4*) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv4 ;; i*86v) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv ;; i*86sol2) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-solaris2 ;; i386mach) basic_machine=i386-mach os=-mach ;; i386-vsta | vsta) basic_machine=i386-unknown os=-vsta ;; iris | iris4d) basic_machine=mips-sgi case $os in -irix*) ;; *) os=-irix4 ;; esac ;; isi68 | isi) basic_machine=m68k-isi os=-sysv ;; m68knommu) basic_machine=m68k-unknown os=-linux ;; m68knommu-*) basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; m88k-omron*) basic_machine=m88k-omron ;; magnum | m3230) basic_machine=mips-mips os=-sysv ;; merlin) basic_machine=ns32k-utek os=-sysv ;; microblaze) basic_machine=microblaze-xilinx ;; mingw32) basic_machine=i386-pc os=-mingw32 ;; mingw32ce) basic_machine=arm-unknown os=-mingw32ce ;; miniframe) basic_machine=m68000-convergent ;; *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) basic_machine=m68k-atari os=-mint ;; mips3*-*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` ;; mips3*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown ;; monitor) basic_machine=m68k-rom68k os=-coff ;; morphos) basic_machine=powerpc-unknown os=-morphos ;; msdos) basic_machine=i386-pc os=-msdos ;; ms1-*) basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` ;; msys) basic_machine=i386-pc os=-msys ;; mvs) basic_machine=i370-ibm os=-mvs ;; nacl) basic_machine=le32-unknown os=-nacl ;; ncr3000) basic_machine=i486-ncr os=-sysv4 ;; netbsd386) basic_machine=i386-unknown os=-netbsd ;; netwinder) basic_machine=armv4l-rebel os=-linux ;; news | news700 | news800 | news900) basic_machine=m68k-sony os=-newsos ;; news1000) basic_machine=m68030-sony os=-newsos ;; news-3600 | risc-news) basic_machine=mips-sony os=-newsos ;; necv70) basic_machine=v70-nec os=-sysv ;; next | m*-next ) basic_machine=m68k-next case $os in -nextstep* ) ;; -ns2*) os=-nextstep2 ;; *) os=-nextstep3 ;; esac ;; nh3000) basic_machine=m68k-harris os=-cxux ;; nh[45]000) basic_machine=m88k-harris os=-cxux ;; nindy960) basic_machine=i960-intel os=-nindy ;; mon960) basic_machine=i960-intel os=-mon960 ;; nonstopux) basic_machine=mips-compaq os=-nonstopux ;; np1) basic_machine=np1-gould ;; neo-tandem) basic_machine=neo-tandem ;; nse-tandem) basic_machine=nse-tandem ;; nsr-tandem) basic_machine=nsr-tandem ;; op50n-* | op60c-*) basic_machine=hppa1.1-oki os=-proelf ;; openrisc | openrisc-*) basic_machine=or32-unknown ;; os400) basic_machine=powerpc-ibm os=-os400 ;; OSE68000 | ose68000) basic_machine=m68000-ericsson os=-ose ;; os68k) basic_machine=m68k-none os=-os68k ;; pa-hitachi) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; paragon) basic_machine=i860-intel os=-osf ;; parisc) basic_machine=hppa-unknown os=-linux ;; parisc-*) basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; pbd) basic_machine=sparc-tti ;; pbb) basic_machine=m68k-tti ;; pc532 | pc532-*) basic_machine=ns32k-pc532 ;; pc98) basic_machine=i386-pc ;; pc98-*) basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentium | p5 | k5 | k6 | nexgen | viac3) basic_machine=i586-pc ;; pentiumpro | p6 | 6x86 | athlon | athlon_*) basic_machine=i686-pc ;; pentiumii | pentium2 | pentiumiii | pentium3) basic_machine=i686-pc ;; pentium4) basic_machine=i786-pc ;; pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentiumpro-* | p6-* | 6x86-* | athlon-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentium4-*) basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pn) basic_machine=pn-gould ;; power) basic_machine=power-ibm ;; ppc | ppcbe) basic_machine=powerpc-unknown ;; ppc-* | ppcbe-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppcle | powerpclittle | ppc-le | powerpc-little) basic_machine=powerpcle-unknown ;; ppcle-* | powerpclittle-*) basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppc64) basic_machine=powerpc64-unknown ;; ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppc64le | powerpc64little | ppc64-le | powerpc64-little) basic_machine=powerpc64le-unknown ;; ppc64le-* | powerpc64little-*) basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ps2) basic_machine=i386-ibm ;; pw32) basic_machine=i586-unknown os=-pw32 ;; rdos) basic_machine=i386-pc os=-rdos ;; rom68k) basic_machine=m68k-rom68k os=-coff ;; rm[46]00) basic_machine=mips-siemens ;; rtpc | rtpc-*) basic_machine=romp-ibm ;; s390 | s390-*) basic_machine=s390-ibm ;; s390x | s390x-*) basic_machine=s390x-ibm ;; sa29200) basic_machine=a29k-amd os=-udi ;; sb1) basic_machine=mipsisa64sb1-unknown ;; sb1el) basic_machine=mipsisa64sb1el-unknown ;; sde) basic_machine=mipsisa32-sde os=-elf ;; sei) basic_machine=mips-sei os=-seiux ;; sequent) basic_machine=i386-sequent ;; sh) basic_machine=sh-hitachi os=-hms ;; sh5el) basic_machine=sh5le-unknown ;; sh64) basic_machine=sh64-unknown ;; sparclite-wrs | simso-wrs) basic_machine=sparclite-wrs os=-vxworks ;; sps7) basic_machine=m68k-bull os=-sysv2 ;; spur) basic_machine=spur-unknown ;; st2000) basic_machine=m68k-tandem ;; stratus) basic_machine=i860-stratus os=-sysv4 ;; strongarm-* | thumb-*) basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'` ;; sun2) basic_machine=m68000-sun ;; sun2os3) basic_machine=m68000-sun os=-sunos3 ;; sun2os4) basic_machine=m68000-sun os=-sunos4 ;; sun3os3) basic_machine=m68k-sun os=-sunos3 ;; sun3os4) basic_machine=m68k-sun os=-sunos4 ;; sun4os3) basic_machine=sparc-sun os=-sunos3 ;; sun4os4) basic_machine=sparc-sun os=-sunos4 ;; sun4sol2) basic_machine=sparc-sun os=-solaris2 ;; sun3 | sun3-*) basic_machine=m68k-sun ;; sun4) basic_machine=sparc-sun ;; sun386 | sun386i | roadrunner) basic_machine=i386-sun ;; sv1) basic_machine=sv1-cray os=-unicos ;; symmetry) basic_machine=i386-sequent os=-dynix ;; t3e) basic_machine=alphaev5-cray os=-unicos ;; t90) basic_machine=t90-cray os=-unicos ;; tile*) basic_machine=$basic_machine-unknown os=-linux-gnu ;; tx39) basic_machine=mipstx39-unknown ;; tx39el) basic_machine=mipstx39el-unknown ;; toad1) basic_machine=pdp10-xkl os=-tops20 ;; tower | tower-32) basic_machine=m68k-ncr ;; tpf) basic_machine=s390x-ibm os=-tpf ;; udi29k) basic_machine=a29k-amd os=-udi ;; ultra3) basic_machine=a29k-nyu os=-sym1 ;; v810 | necv810) basic_machine=v810-nec os=-none ;; vaxv) basic_machine=vax-dec os=-sysv ;; vms) basic_machine=vax-dec os=-vms ;; vpp*|vx|vx-*) basic_machine=f301-fujitsu ;; vxworks960) basic_machine=i960-wrs os=-vxworks ;; vxworks68) basic_machine=m68k-wrs os=-vxworks ;; vxworks29k) basic_machine=a29k-wrs os=-vxworks ;; w65*) basic_machine=w65-wdc os=-none ;; w89k-*) basic_machine=hppa1.1-winbond os=-proelf ;; xbox) basic_machine=i686-pc os=-mingw32 ;; xps | xps100) basic_machine=xps100-honeywell ;; xscale-* | xscalee[bl]-*) basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'` ;; ymp) basic_machine=ymp-cray os=-unicos ;; z8k-*-coff) basic_machine=z8k-unknown os=-sim ;; z80-*-coff) basic_machine=z80-unknown os=-sim ;; none) basic_machine=none-none os=-none ;; # Here we handle the default manufacturer of certain CPU types. It is in # some cases the only manufacturer, in others, it is the most popular. w89k) basic_machine=hppa1.1-winbond ;; op50n) basic_machine=hppa1.1-oki ;; op60c) basic_machine=hppa1.1-oki ;; romp) basic_machine=romp-ibm ;; mmix) basic_machine=mmix-knuth ;; rs6000) basic_machine=rs6000-ibm ;; vax) basic_machine=vax-dec ;; pdp10) # there are many clones, so DEC is not a safe bet basic_machine=pdp10-unknown ;; pdp11) basic_machine=pdp11-dec ;; we32k) basic_machine=we32k-att ;; sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) basic_machine=sh-unknown ;; sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) basic_machine=sparc-sun ;; cydra) basic_machine=cydra-cydrome ;; orion) basic_machine=orion-highlevel ;; orion105) basic_machine=clipper-highlevel ;; mac | mpw | mac-mpw) basic_machine=m68k-apple ;; pmac | pmac-mpw) basic_machine=powerpc-apple ;; *-unknown) # Make sure to match an already-canonicalized machine name. ;; *) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; esac # Here we canonicalize certain aliases for manufacturers. case $basic_machine in *-digital*) basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` ;; *-commodore*) basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` ;; *) ;; esac # Decode manufacturer-specific aliases for certain operating systems. if [ x"$os" != x"" ] then case $os in # First match some system type aliases # that might get confused with valid system types. # -solaris* is a basic system type, with this one exception. -auroraux) os=-auroraux ;; -solaris1 | -solaris1.*) os=`echo $os | sed -e 's|solaris1|sunos4|'` ;; -solaris) os=-solaris2 ;; -svr4*) os=-sysv4 ;; -unixware*) os=-sysv4.2uw ;; -gnu/linux*) os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` ;; # First accept the basic system types. # The portable systems comes first. # Each alternative MUST END IN A *, to match a version number. # -sysv* is not here because it comes later, after sysvr4. -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ | -sym* | -kopensolaris* \ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ | -aos* | -aros* \ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ | -openbsd* | -solidbsd* \ | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ | -chorusos* | -chorusrdb* | -cegcc* \ | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ | -mingw32* | -linux-gnu* | -linux-android* \ | -linux-newlib* | -linux-uclibc* \ | -uxpv* | -beos* | -mpeix* | -udk* \ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es*) # Remember, each alternative MUST END IN *, to match a version number. ;; -qnx*) case $basic_machine in x86-* | i*86-*) ;; *) os=-nto$os ;; esac ;; -nto-qnx*) ;; -nto*) os=`echo $os | sed -e 's|nto|nto-qnx|'` ;; -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) ;; -mac*) os=`echo $os | sed -e 's|mac|macos|'` ;; -linux-dietlibc) os=-linux-dietlibc ;; -linux*) os=`echo $os | sed -e 's|linux|linux-gnu|'` ;; -sunos5*) os=`echo $os | sed -e 's|sunos5|solaris2|'` ;; -sunos6*) os=`echo $os | sed -e 's|sunos6|solaris3|'` ;; -opened*) os=-openedition ;; -os400*) os=-os400 ;; -wince*) os=-wince ;; -osfrose*) os=-osfrose ;; -osf*) os=-osf ;; -utek*) os=-bsd ;; -dynix*) os=-bsd ;; -acis*) os=-aos ;; -atheos*) os=-atheos ;; -syllable*) os=-syllable ;; -386bsd) os=-bsd ;; -ctix* | -uts*) os=-sysv ;; -nova*) os=-rtmk-nova ;; -ns2 ) os=-nextstep2 ;; -nsk*) os=-nsk ;; # Preserve the version number of sinix5. -sinix5.*) os=`echo $os | sed -e 's|sinix|sysv|'` ;; -sinix*) os=-sysv4 ;; -tpf*) os=-tpf ;; -triton*) os=-sysv3 ;; -oss*) os=-sysv3 ;; -svr4) os=-sysv4 ;; -svr3) os=-sysv3 ;; -sysvr4) os=-sysv4 ;; # This must come after -sysvr4. -sysv*) ;; -ose*) os=-ose ;; -es1800*) os=-ose ;; -xenix) os=-xenix ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) os=-mint ;; -aros*) os=-aros ;; -kaos*) os=-kaos ;; -zvmoe) os=-zvmoe ;; -dicos*) os=-dicos ;; -nacl*) ;; -none) ;; *) # Get rid of the `-' at the beginning of $os. os=`echo $os | sed 's/[^-]*-//'` echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 exit 1 ;; esac else # Here we handle the default operating systems that come with various machines. # The value should be what the vendor currently ships out the door with their # machine or put another way, the most popular os provided with the machine. # Note that if you're going to try to match "-MANUFACTURER" here (say, # "-sun"), then you have to tell the case statement up towards the top # that MANUFACTURER isn't an operating system. Otherwise, code above # will signal an error saying that MANUFACTURER isn't an operating # system, and we'll never get to this point. case $basic_machine in score-*) os=-elf ;; spu-*) os=-elf ;; *-acorn) os=-riscix1.2 ;; arm*-rebel) os=-linux ;; arm*-semi) os=-aout ;; c4x-* | tic4x-*) os=-coff ;; tic54x-*) os=-coff ;; tic55x-*) os=-coff ;; tic6x-*) os=-coff ;; # This must come before the *-dec entry. pdp10-*) os=-tops20 ;; pdp11-*) os=-none ;; *-dec | vax-*) os=-ultrix4.2 ;; m68*-apollo) os=-domain ;; i386-sun) os=-sunos4.0.2 ;; m68000-sun) os=-sunos3 # This also exists in the configure program, but was not the # default. # os=-sunos4 ;; m68*-cisco) os=-aout ;; mep-*) os=-elf ;; mips*-cisco) os=-elf ;; mips*-*) os=-elf ;; or32-*) os=-coff ;; *-tti) # must be before sparc entry or we get the wrong os. os=-sysv3 ;; sparc-* | *-sun) os=-sunos4.1.1 ;; *-be) os=-beos ;; *-haiku) os=-haiku ;; *-ibm) os=-aix ;; *-knuth) os=-mmixware ;; *-wec) os=-proelf ;; *-winbond) os=-proelf ;; *-oki) os=-proelf ;; *-hp) os=-hpux ;; *-hitachi) os=-hiux ;; i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) os=-sysv ;; *-cbm) os=-amigaos ;; *-dg) os=-dgux ;; *-dolphin) os=-sysv3 ;; m68k-ccur) os=-rtu ;; m88k-omron*) os=-luna ;; *-next ) os=-nextstep ;; *-sequent) os=-ptx ;; *-crds) os=-unos ;; *-ns) os=-genix ;; i370-*) os=-mvs ;; *-next) os=-nextstep3 ;; *-gould) os=-sysv ;; *-highlevel) os=-bsd ;; *-encore) os=-bsd ;; *-sgi) os=-irix ;; *-siemens) os=-sysv4 ;; *-masscomp) os=-rtu ;; f30[01]-fujitsu | f700-fujitsu) os=-uxpv ;; *-rom68k) os=-coff ;; *-*bug) os=-coff ;; *-apple) os=-macos ;; *-atari*) os=-mint ;; *) os=-none ;; esac fi # Here we handle the case where we know the os, and the CPU type, but not the # manufacturer. We pick the logical manufacturer. vendor=unknown case $basic_machine in *-unknown) case $os in -riscix*) vendor=acorn ;; -sunos*) vendor=sun ;; -cnk*|-aix*) vendor=ibm ;; -beos*) vendor=be ;; -hpux*) vendor=hp ;; -mpeix*) vendor=hp ;; -hiux*) vendor=hitachi ;; -unos*) vendor=crds ;; -dgux*) vendor=dg ;; -luna*) vendor=omron ;; -genix*) vendor=ns ;; -mvs* | -opened*) vendor=ibm ;; -os400*) vendor=ibm ;; -ptx*) vendor=sequent ;; -tpf*) vendor=ibm ;; -vxsim* | -vxworks* | -windiss*) vendor=wrs ;; -aux*) vendor=apple ;; -hms*) vendor=hitachi ;; -mpw* | -macos*) vendor=apple ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) vendor=atari ;; -vos*) vendor=stratus ;; esac basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` ;; esac echo $basic_machine$os exit # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: mingw-ocaml/ocaml/config/gnu/config.guess0000755000175000017500000012704512124403240020044 0ustar tootstoots#! /bin/sh # Attempt to guess a canonical system name. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, # 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, # 2011 Free Software Foundation, Inc. timestamp='2011-11-11' # This file 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. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Originally written by Per Bothner. Please send patches (context # diff format) to and include a ChangeLog # entry. # # This script attempts to guess a canonical system name similar to # config.sub. If it succeeds, it prints the system name on stdout, and # exits with 0. Otherwise, it exits with 1. # # You can get the latest version of this script from: # http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] Output the configuration name of the system \`$me' is run on. Operation modes: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.guess ($timestamp) Originally written by Per Bothner. Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" >&2 exit 1 ;; * ) break ;; esac done if test $# != 0; then echo "$me: too many arguments$help" >&2 exit 1 fi trap 'exit 1' 1 2 15 # CC_FOR_BUILD -- compiler used by this script. Note that the use of a # compiler to aid in system detection is discouraged as it requires # temporary files to be created and, as you can see below, it is a # headache to deal with in a portable fashion. # Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still # use `HOST_CC' if defined, but it is deprecated. # Portable tmp directory creation inspired by the Autoconf team. set_cc_for_build=' trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; : ${TMPDIR=/tmp} ; { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; dummy=$tmp/dummy ; tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; case $CC_FOR_BUILD,$HOST_CC,$CC in ,,) echo "int x;" > $dummy.c ; for c in cc gcc c89 c99 ; do if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then CC_FOR_BUILD="$c"; break ; fi ; done ; if test x"$CC_FOR_BUILD" = x ; then CC_FOR_BUILD=no_compiler_found ; fi ;; ,,*) CC_FOR_BUILD=$CC ;; ,*,*) CC_FOR_BUILD=$HOST_CC ;; esac ; set_cc_for_build= ;' # This is needed to find uname on a Pyramid OSx when run in the BSD universe. # (ghazi@noc.rutgers.edu 1994-08-24) if (test -f /.attbin/uname) >/dev/null 2>&1 ; then PATH=$PATH:/.attbin ; export PATH fi UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown # Note: order is significant - the case branches are not exclusive. case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in *:NetBSD:*:*) # NetBSD (nbsd) targets should (where applicable) match one or # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently # switched to ELF, *-*-netbsd* would select the old # object file format. This provides both forward # compatibility and a consistent mechanism for selecting the # object file format. # # Note: NetBSD doesn't particularly care about the vendor # portion of the name. We always set it to "unknown". sysctl="sysctl -n hw.machine_arch" UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ /usr/sbin/$sysctl 2>/dev/null || echo unknown)` case "${UNAME_MACHINE_ARCH}" in armeb) machine=armeb-unknown ;; arm*) machine=arm-unknown ;; sh3el) machine=shl-unknown ;; sh3eb) machine=sh-unknown ;; sh5el) machine=sh5le-unknown ;; *) machine=${UNAME_MACHINE_ARCH}-unknown ;; esac # The Operating System including object format, if it has switched # to ELF recently, or will in the future. case "${UNAME_MACHINE_ARCH}" in arm*|i386|m68k|ns32k|sh3*|sparc|vax) eval $set_cc_for_build if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ELF__ then # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). # Return netbsd for either. FIX? os=netbsd else os=netbsdelf fi ;; *) os=netbsd ;; esac # The OS release # Debian GNU/NetBSD machines have a different userland, and # thus, need a distinct triplet. However, they do not need # kernel version information, so it can be replaced with a # suitable tag, in the style of linux-gnu. case "${UNAME_VERSION}" in Debian*) release='-gnu' ;; *) release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` ;; esac # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: # contains redundant information, the shorter form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. echo "${machine}-${os}${release}" exit ;; *:OpenBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} exit ;; *:ekkoBSD:*:*) echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} exit ;; *:SolidBSD:*:*) echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} exit ;; macppc:MirBSD:*:*) echo powerpc-unknown-mirbsd${UNAME_RELEASE} exit ;; *:MirBSD:*:*) echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} exit ;; alpha:OSF1:*:*) case $UNAME_RELEASE in *4.0) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` ;; *5.*) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` ;; esac # According to Compaq, /usr/sbin/psrinfo has been available on # OSF/1 and Tru64 systems produced since 1995. I hope that # covers most systems running today. This code pipes the CPU # types through head -n 1, so we only detect the type of CPU 0. ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` case "$ALPHA_CPU_TYPE" in "EV4 (21064)") UNAME_MACHINE="alpha" ;; "EV4.5 (21064)") UNAME_MACHINE="alpha" ;; "LCA4 (21066/21068)") UNAME_MACHINE="alpha" ;; "EV5 (21164)") UNAME_MACHINE="alphaev5" ;; "EV5.6 (21164A)") UNAME_MACHINE="alphaev56" ;; "EV5.6 (21164PC)") UNAME_MACHINE="alphapca56" ;; "EV5.7 (21164PC)") UNAME_MACHINE="alphapca57" ;; "EV6 (21264)") UNAME_MACHINE="alphaev6" ;; "EV6.7 (21264A)") UNAME_MACHINE="alphaev67" ;; "EV6.8CB (21264C)") UNAME_MACHINE="alphaev68" ;; "EV6.8AL (21264B)") UNAME_MACHINE="alphaev68" ;; "EV6.8CX (21264D)") UNAME_MACHINE="alphaev68" ;; "EV6.9A (21264/EV69A)") UNAME_MACHINE="alphaev69" ;; "EV7 (21364)") UNAME_MACHINE="alphaev7" ;; "EV7.9 (21364A)") UNAME_MACHINE="alphaev79" ;; esac # A Pn.n version is a patched version. # A Vn.n version is a released version. # A Tn.n version is a released field test version. # A Xn.n version is an unreleased experimental baselevel. # 1.2 uses "1.2" for uname -r. echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` # Reset EXIT trap before exiting to avoid spurious non-zero exit code. exitcode=$? trap '' 0 exit $exitcode ;; Alpha\ *:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # Should we change UNAME_MACHINE based on the output of uname instead # of the specific Alpha model? echo alpha-pc-interix exit ;; 21064:Windows_NT:50:3) echo alpha-dec-winnt3.5 exit ;; Amiga*:UNIX_System_V:4.0:*) echo m68k-unknown-sysv4 exit ;; *:[Aa]miga[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-amigaos exit ;; *:[Mm]orph[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-morphos exit ;; *:OS/390:*:*) echo i370-ibm-openedition exit ;; *:z/VM:*:*) echo s390-ibm-zvmoe exit ;; *:OS400:*:*) echo powerpc-ibm-os400 exit ;; arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) echo arm-acorn-riscix${UNAME_RELEASE} exit ;; arm:riscos:*:*|arm:RISCOS:*:*) echo arm-unknown-riscos exit ;; SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) echo hppa1.1-hitachi-hiuxmpp exit ;; Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. if test "`(/bin/universe) 2>/dev/null`" = att ; then echo pyramid-pyramid-sysv3 else echo pyramid-pyramid-bsd fi exit ;; NILE*:*:*:dcosx) echo pyramid-pyramid-svr4 exit ;; DRS?6000:unix:4.0:6*) echo sparc-icl-nx6 exit ;; DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) case `/usr/bin/uname -p` in sparc) echo sparc-icl-nx7; exit ;; esac ;; s390x:SunOS:*:*) echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4H:SunOS:5.*:*) echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) echo i386-pc-auroraux${UNAME_RELEASE} exit ;; i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) eval $set_cc_for_build SUN_ARCH="i386" # If there is a compiler, see if it is configured for 64-bit objects. # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. # This test works for both compilers. if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then SUN_ARCH="x86_64" fi fi echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:6*:*) # According to config.sub, this is the proper way to canonicalize # SunOS6. Hard to guess exactly what SunOS6 will be like, but # it's likely to be more like Solaris than SunOS4. echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:*:*) case "`/usr/bin/arch -k`" in Series*|S4*) UNAME_RELEASE=`uname -v` ;; esac # Japanese Language versions have a version number like `4.1.3-JL'. echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` exit ;; sun3*:SunOS:*:*) echo m68k-sun-sunos${UNAME_RELEASE} exit ;; sun*:*:4.2BSD:*) UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 case "`/bin/arch`" in sun3) echo m68k-sun-sunos${UNAME_RELEASE} ;; sun4) echo sparc-sun-sunos${UNAME_RELEASE} ;; esac exit ;; aushp:SunOS:*:*) echo sparc-auspex-sunos${UNAME_RELEASE} exit ;; # The situation for MiNT is a little confusing. The machine name # can be virtually everything (everything which is not # "atarist" or "atariste" at least should have a processor # > m68000). The system name ranges from "MiNT" over "FreeMiNT" # to the lowercase version "mint" (or "freemint"). Finally # the system name "TOS" denotes a system which is actually not # MiNT. But MiNT is downward compatible to TOS, so this should # be no problem. atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) echo m68k-milan-mint${UNAME_RELEASE} exit ;; hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) echo m68k-hades-mint${UNAME_RELEASE} exit ;; *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) echo m68k-unknown-mint${UNAME_RELEASE} exit ;; m68k:machten:*:*) echo m68k-apple-machten${UNAME_RELEASE} exit ;; powerpc:machten:*:*) echo powerpc-apple-machten${UNAME_RELEASE} exit ;; RISC*:Mach:*:*) echo mips-dec-mach_bsd4.3 exit ;; RISC*:ULTRIX:*:*) echo mips-dec-ultrix${UNAME_RELEASE} exit ;; VAX*:ULTRIX*:*:*) echo vax-dec-ultrix${UNAME_RELEASE} exit ;; 2020:CLIX:*:* | 2430:CLIX:*:*) echo clipper-intergraph-clix${UNAME_RELEASE} exit ;; mips:*:*:UMIPS | mips:*:*:RISCos) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #ifdef __cplusplus #include /* for printf() prototype */ int main (int argc, char *argv[]) { #else int main (argc, argv) int argc; char *argv[]; { #endif #if defined (host_mips) && defined (MIPSEB) #if defined (SYSTYPE_SYSV) printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_SVR4) printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); #endif #endif exit (-1); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && SYSTEM_NAME=`$dummy $dummyarg` && { echo "$SYSTEM_NAME"; exit; } echo mips-mips-riscos${UNAME_RELEASE} exit ;; Motorola:PowerMAX_OS:*:*) echo powerpc-motorola-powermax exit ;; Motorola:*:4.3:PL8-*) echo powerpc-harris-powermax exit ;; Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) echo powerpc-harris-powermax exit ;; Night_Hawk:Power_UNIX:*:*) echo powerpc-harris-powerunix exit ;; m88k:CX/UX:7*:*) echo m88k-harris-cxux7 exit ;; m88k:*:4*:R4*) echo m88k-motorola-sysv4 exit ;; m88k:*:3*:R3*) echo m88k-motorola-sysv3 exit ;; AViiON:dgux:*:*) # DG/UX returns AViiON for all architectures UNAME_PROCESSOR=`/usr/bin/uname -p` if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] then if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ [ ${TARGET_BINARY_INTERFACE}x = x ] then echo m88k-dg-dgux${UNAME_RELEASE} else echo m88k-dg-dguxbcs${UNAME_RELEASE} fi else echo i586-dg-dgux${UNAME_RELEASE} fi exit ;; M88*:DolphinOS:*:*) # DolphinOS (SVR3) echo m88k-dolphin-sysv3 exit ;; M88*:*:R3*:*) # Delta 88k system running SVR3 echo m88k-motorola-sysv3 exit ;; XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) echo m88k-tektronix-sysv3 exit ;; Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) echo m68k-tektronix-bsd exit ;; *:IRIX*:*:*) echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` exit ;; ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' i*86:AIX:*:*) echo i386-ibm-aix exit ;; ia64:AIX:*:*) if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} exit ;; *:AIX:2:3) if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include main() { if (!__power_pc()) exit(1); puts("powerpc-ibm-aix3.2.5"); exit(0); } EOF if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` then echo "$SYSTEM_NAME" else echo rs6000-ibm-aix3.2.5 fi elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then echo rs6000-ibm-aix3.2.4 else echo rs6000-ibm-aix3.2 fi exit ;; *:AIX:*:[4567]) IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then IBM_ARCH=rs6000 else IBM_ARCH=powerpc fi if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${IBM_ARCH}-ibm-aix${IBM_REV} exit ;; *:AIX:*:*) echo rs6000-ibm-aix exit ;; ibmrt:4.4BSD:*|romp-ibm:BSD:*) echo romp-ibm-bsd4.4 exit ;; ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to exit ;; # report: romp-ibm BSD 4.3 *:BOSX:*:*) echo rs6000-bull-bosx exit ;; DPX/2?00:B.O.S.:*:*) echo m68k-bull-sysv3 exit ;; 9000/[34]??:4.3bsd:1.*:*) echo m68k-hp-bsd exit ;; hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) echo m68k-hp-bsd4.4 exit ;; 9000/[34678]??:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` case "${UNAME_MACHINE}" in 9000/31? ) HP_ARCH=m68000 ;; 9000/[34]?? ) HP_ARCH=m68k ;; 9000/[678][0-9][0-9]) if [ -x /usr/bin/getconf ]; then sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` case "${sc_cpu_version}" in 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 532) # CPU_PA_RISC2_0 case "${sc_kernel_bits}" in 32) HP_ARCH="hppa2.0n" ;; 64) HP_ARCH="hppa2.0w" ;; '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 esac ;; esac fi if [ "${HP_ARCH}" = "" ]; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #define _HPUX_SOURCE #include #include int main () { #if defined(_SC_KERNEL_BITS) long bits = sysconf(_SC_KERNEL_BITS); #endif long cpu = sysconf (_SC_CPU_VERSION); switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0"); break; case CPU_PA_RISC1_1: puts ("hppa1.1"); break; case CPU_PA_RISC2_0: #if defined(_SC_KERNEL_BITS) switch (bits) { case 64: puts ("hppa2.0w"); break; case 32: puts ("hppa2.0n"); break; default: puts ("hppa2.0"); break; } break; #else /* !defined(_SC_KERNEL_BITS) */ puts ("hppa2.0"); break; #endif default: puts ("hppa1.0"); break; } exit (0); } EOF (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` test -z "$HP_ARCH" && HP_ARCH=hppa fi ;; esac if [ ${HP_ARCH} = "hppa2.0w" ] then eval $set_cc_for_build # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler # generating 64-bit code. GNU and HP use different nomenclature: # # $ CC_FOR_BUILD=cc ./config.guess # => hppa2.0w-hp-hpux11.23 # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess # => hppa64-hp-hpux11.23 if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | grep -q __LP64__ then HP_ARCH="hppa2.0w" else HP_ARCH="hppa64" fi fi echo ${HP_ARCH}-hp-hpux${HPUX_REV} exit ;; ia64:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` echo ia64-hp-hpux${HPUX_REV} exit ;; 3050*:HI-UX:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include int main () { long cpu = sysconf (_SC_CPU_VERSION); /* The order matters, because CPU_IS_HP_MC68K erroneously returns true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct results, however. */ if (CPU_IS_PA_RISC (cpu)) { switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; default: puts ("hppa-hitachi-hiuxwe2"); break; } } else if (CPU_IS_HP_MC68K (cpu)) puts ("m68k-hitachi-hiuxwe2"); else puts ("unknown-hitachi-hiuxwe2"); exit (0); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && { echo "$SYSTEM_NAME"; exit; } echo unknown-hitachi-hiuxwe2 exit ;; 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) echo hppa1.1-hp-bsd exit ;; 9000/8??:4.3bsd:*:*) echo hppa1.0-hp-bsd exit ;; *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) echo hppa1.0-hp-mpeix exit ;; hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) echo hppa1.1-hp-osf exit ;; hp8??:OSF1:*:*) echo hppa1.0-hp-osf exit ;; i*86:OSF1:*:*) if [ -x /usr/sbin/sysversion ] ; then echo ${UNAME_MACHINE}-unknown-osf1mk else echo ${UNAME_MACHINE}-unknown-osf1 fi exit ;; parisc*:Lites*:*:*) echo hppa1.1-hp-lites exit ;; C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) echo c1-convex-bsd exit ;; C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) echo c34-convex-bsd exit ;; C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) echo c38-convex-bsd exit ;; C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) echo c4-convex-bsd exit ;; CRAY*Y-MP:*:*:*) echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*[A-Z]90:*:*:*) echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ -e 's/\.[^.]*$/.X/' exit ;; CRAY*TS:*:*:*) echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*T3E:*:*:*) echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*SV1:*:*:*) echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; *:UNICOS/mp:*:*) echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; 5000:UNIX_System_V:4.*:*) FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} exit ;; sparc*:BSD/OS:*:*) echo sparc-unknown-bsdi${UNAME_RELEASE} exit ;; *:BSD/OS:*:*) echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} exit ;; *:FreeBSD:*:*) UNAME_PROCESSOR=`/usr/bin/uname -p` case ${UNAME_PROCESSOR} in amd64) echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; *) echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; esac exit ;; i*:CYGWIN*:*) echo ${UNAME_MACHINE}-pc-cygwin exit ;; *:MINGW*:*) echo ${UNAME_MACHINE}-pc-mingw32 exit ;; i*:MSYS*:*) echo ${UNAME_MACHINE}-pc-msys exit ;; i*:windows32*:*) # uname -m includes "-pc" on this system. echo ${UNAME_MACHINE}-mingw32 exit ;; i*:PW*:*) echo ${UNAME_MACHINE}-pc-pw32 exit ;; *:Interix*:*) case ${UNAME_MACHINE} in x86) echo i586-pc-interix${UNAME_RELEASE} exit ;; authenticamd | genuineintel | EM64T) echo x86_64-unknown-interix${UNAME_RELEASE} exit ;; IA64) echo ia64-unknown-interix${UNAME_RELEASE} exit ;; esac ;; [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) echo i${UNAME_MACHINE}-pc-mks exit ;; 8664:Windows_NT:*) echo x86_64-pc-mks exit ;; i*:Windows_NT*:* | Pentium*:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we # UNAME_MACHINE based on the output of uname instead of i386? echo i586-pc-interix exit ;; i*:UWIN*:*) echo ${UNAME_MACHINE}-pc-uwin exit ;; amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) echo x86_64-unknown-cygwin exit ;; p*:CYGWIN*:*) echo powerpcle-unknown-cygwin exit ;; prep*:SunOS:5.*:*) echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; *:GNU:*:*) # the GNU system echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` exit ;; *:GNU/*:*:*) # other systems with GNU libc and userland echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu exit ;; i*86:Minix:*:*) echo ${UNAME_MACHINE}-pc-minix exit ;; alpha:Linux:*:*) case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in EV5) UNAME_MACHINE=alphaev5 ;; EV56) UNAME_MACHINE=alphaev56 ;; PCA56) UNAME_MACHINE=alphapca56 ;; PCA57) UNAME_MACHINE=alphapca56 ;; EV6) UNAME_MACHINE=alphaev6 ;; EV67) UNAME_MACHINE=alphaev67 ;; EV68*) UNAME_MACHINE=alphaev68 ;; esac objdump --private-headers /bin/sh | grep -q ld.so.1 if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} exit ;; arm*:Linux:*:*) eval $set_cc_for_build if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_EABI__ then echo ${UNAME_MACHINE}-unknown-linux-gnu else if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_PCS_VFP then echo ${UNAME_MACHINE}-unknown-linux-gnueabi else echo ${UNAME_MACHINE}-unknown-linux-gnueabihf fi fi exit ;; avr32*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; cris:Linux:*:*) echo cris-axis-linux-gnu exit ;; crisv32:Linux:*:*) echo crisv32-axis-linux-gnu exit ;; frv:Linux:*:*) echo frv-unknown-linux-gnu exit ;; hexagon:Linux:*:*) echo hexagon-unknown-linux-gnu exit ;; i*86:Linux:*:*) LIBC=gnu eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #ifdef __dietlibc__ LIBC=dietlibc #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'` echo "${UNAME_MACHINE}-pc-linux-${LIBC}" exit ;; ia64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; m32r*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; m68*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; mips:Linux:*:* | mips64:Linux:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #undef CPU #undef ${UNAME_MACHINE} #undef ${UNAME_MACHINE}el #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) CPU=${UNAME_MACHINE}el #else #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) CPU=${UNAME_MACHINE} #else CPU= #endif #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } ;; or32:Linux:*:*) echo or32-unknown-linux-gnu exit ;; padre:Linux:*:*) echo sparc-unknown-linux-gnu exit ;; parisc64:Linux:*:* | hppa64:Linux:*:*) echo hppa64-unknown-linux-gnu exit ;; parisc:Linux:*:* | hppa:Linux:*:*) # Look for CPU level case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in PA7*) echo hppa1.1-unknown-linux-gnu ;; PA8*) echo hppa2.0-unknown-linux-gnu ;; *) echo hppa-unknown-linux-gnu ;; esac exit ;; ppc64:Linux:*:*) echo powerpc64-unknown-linux-gnu exit ;; ppc:Linux:*:*) echo powerpc-unknown-linux-gnu exit ;; s390:Linux:*:* | s390x:Linux:*:*) echo ${UNAME_MACHINE}-ibm-linux exit ;; sh64*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; sh*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; sparc:Linux:*:* | sparc64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; tile*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; vax:Linux:*:*) echo ${UNAME_MACHINE}-dec-linux-gnu exit ;; x86_64:Linux:*:*) echo x86_64-unknown-linux-gnu exit ;; xtensa*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; i*86:DYNIX/ptx:4*:*) # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. # earlier versions are messed up and put the nodename in both # sysname and nodename. echo i386-sequent-sysv4 exit ;; i*86:UNIX_SV:4.2MP:2.*) # Unixware is an offshoot of SVR4, but it has its own version # number series starting with 2... # I am not positive that other SVR4 systems won't match this, # I just have to hope. -- rms. # Use sysv4.2uw... so that sysv4* matches it. echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} exit ;; i*86:OS/2:*:*) # If we were able to find `uname', then EMX Unix compatibility # is probably installed. echo ${UNAME_MACHINE}-pc-os2-emx exit ;; i*86:XTS-300:*:STOP) echo ${UNAME_MACHINE}-unknown-stop exit ;; i*86:atheos:*:*) echo ${UNAME_MACHINE}-unknown-atheos exit ;; i*86:syllable:*:*) echo ${UNAME_MACHINE}-pc-syllable exit ;; i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) echo i386-unknown-lynxos${UNAME_RELEASE} exit ;; i*86:*DOS:*:*) echo ${UNAME_MACHINE}-pc-msdosdjgpp exit ;; i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} else echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} fi exit ;; i*86:*:5:[678]*) # UnixWare 7.x, OpenUNIX and OpenServer 6. case `/bin/uname -X | grep "^Machine"` in *486*) UNAME_MACHINE=i486 ;; *Pentium) UNAME_MACHINE=i586 ;; *Pent*|*Celeron) UNAME_MACHINE=i686 ;; esac echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} exit ;; i*86:*:3.2:*) if test -f /usr/options/cb.name; then UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ && UNAME_MACHINE=i586 (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ && UNAME_MACHINE=i686 (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ && UNAME_MACHINE=i686 echo ${UNAME_MACHINE}-pc-sco$UNAME_REL else echo ${UNAME_MACHINE}-pc-sysv32 fi exit ;; pc:*:*:*) # Left here for compatibility: # uname -m prints for DJGPP always 'pc', but it prints nothing about # the processor, so we play safe by assuming i586. # Note: whatever this is, it MUST be the same as what config.sub # prints for the "djgpp" host, or else GDB configury will decide that # this is a cross-build. echo i586-pc-msdosdjgpp exit ;; Intel:Mach:3*:*) echo i386-pc-mach3 exit ;; paragon:*:*:*) echo i860-intel-osf1 exit ;; i860:*:4.*:*) # i860-SVR4 if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 else # Add other i860-SVR4 vendors below as they are discovered. echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 fi exit ;; mini*:CTIX:SYS*5:*) # "miniframe" echo m68010-convergent-sysv exit ;; mc68k:UNIX:SYSTEM5:3.51m) echo m68k-convergent-sysv exit ;; M680?0:D-NIX:5.3:*) echo m68k-diab-dnix exit ;; M68*:*:R3V[5678]*:*) test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) OS_REL='' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4; exit; } ;; NCR*:*:4.2:* | MPRAS*:*:4.2:*) OS_REL='.3' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) echo m68k-unknown-lynxos${UNAME_RELEASE} exit ;; mc68030:UNIX_System_V:4.*:*) echo m68k-atari-sysv4 exit ;; TSUNAMI:LynxOS:2.*:*) echo sparc-unknown-lynxos${UNAME_RELEASE} exit ;; rs6000:LynxOS:2.*:*) echo rs6000-unknown-lynxos${UNAME_RELEASE} exit ;; PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) echo powerpc-unknown-lynxos${UNAME_RELEASE} exit ;; SM[BE]S:UNIX_SV:*:*) echo mips-dde-sysv${UNAME_RELEASE} exit ;; RM*:ReliantUNIX-*:*:*) echo mips-sni-sysv4 exit ;; RM*:SINIX-*:*:*) echo mips-sni-sysv4 exit ;; *:SINIX-*:*:*) if uname -p 2>/dev/null >/dev/null ; then UNAME_MACHINE=`(uname -p) 2>/dev/null` echo ${UNAME_MACHINE}-sni-sysv4 else echo ns32k-sni-sysv fi exit ;; PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort # says echo i586-unisys-sysv4 exit ;; *:UNIX_System_V:4*:FTX*) # From Gerald Hewes . # How about differentiating between stratus architectures? -djm echo hppa1.1-stratus-sysv4 exit ;; *:*:*:FTX*) # From seanf@swdc.stratus.com. echo i860-stratus-sysv4 exit ;; i*86:VOS:*:*) # From Paul.Green@stratus.com. echo ${UNAME_MACHINE}-stratus-vos exit ;; *:VOS:*:*) # From Paul.Green@stratus.com. echo hppa1.1-stratus-vos exit ;; mc68*:A/UX:*:*) echo m68k-apple-aux${UNAME_RELEASE} exit ;; news*:NEWS-OS:6*:*) echo mips-sony-newsos6 exit ;; R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) if [ -d /usr/nec ]; then echo mips-nec-sysv${UNAME_RELEASE} else echo mips-unknown-sysv${UNAME_RELEASE} fi exit ;; BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. echo powerpc-be-beos exit ;; BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. echo powerpc-apple-beos exit ;; BePC:BeOS:*:*) # BeOS running on Intel PC compatible. echo i586-pc-beos exit ;; BePC:Haiku:*:*) # Haiku running on Intel PC compatible. echo i586-pc-haiku exit ;; SX-4:SUPER-UX:*:*) echo sx4-nec-superux${UNAME_RELEASE} exit ;; SX-5:SUPER-UX:*:*) echo sx5-nec-superux${UNAME_RELEASE} exit ;; SX-6:SUPER-UX:*:*) echo sx6-nec-superux${UNAME_RELEASE} exit ;; SX-7:SUPER-UX:*:*) echo sx7-nec-superux${UNAME_RELEASE} exit ;; SX-8:SUPER-UX:*:*) echo sx8-nec-superux${UNAME_RELEASE} exit ;; SX-8R:SUPER-UX:*:*) echo sx8r-nec-superux${UNAME_RELEASE} exit ;; Power*:Rhapsody:*:*) echo powerpc-apple-rhapsody${UNAME_RELEASE} exit ;; *:Rhapsody:*:*) echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} exit ;; *:Darwin:*:*) UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown case $UNAME_PROCESSOR in i386) eval $set_cc_for_build if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then UNAME_PROCESSOR="x86_64" fi fi ;; unknown) UNAME_PROCESSOR=powerpc ;; esac echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} exit ;; *:procnto*:*:* | *:QNX:[0123456789]*:*) UNAME_PROCESSOR=`uname -p` if test "$UNAME_PROCESSOR" = "x86"; then UNAME_PROCESSOR=i386 UNAME_MACHINE=pc fi echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} exit ;; *:QNX:*:4*) echo i386-pc-qnx exit ;; NEO-?:NONSTOP_KERNEL:*:*) echo neo-tandem-nsk${UNAME_RELEASE} exit ;; NSE-?:NONSTOP_KERNEL:*:*) echo nse-tandem-nsk${UNAME_RELEASE} exit ;; NSR-?:NONSTOP_KERNEL:*:*) echo nsr-tandem-nsk${UNAME_RELEASE} exit ;; *:NonStop-UX:*:*) echo mips-compaq-nonstopux exit ;; BS2000:POSIX*:*:*) echo bs2000-siemens-sysv exit ;; DS/*:UNIX_System_V:*:*) echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} exit ;; *:Plan9:*:*) # "uname -m" is not consistent, so use $cputype instead. 386 # is converted to i386 for consistency with other x86 # operating systems. if test "$cputype" = "386"; then UNAME_MACHINE=i386 else UNAME_MACHINE="$cputype" fi echo ${UNAME_MACHINE}-unknown-plan9 exit ;; *:TOPS-10:*:*) echo pdp10-unknown-tops10 exit ;; *:TENEX:*:*) echo pdp10-unknown-tenex exit ;; KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) echo pdp10-dec-tops20 exit ;; XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) echo pdp10-xkl-tops20 exit ;; *:TOPS-20:*:*) echo pdp10-unknown-tops20 exit ;; *:ITS:*:*) echo pdp10-unknown-its exit ;; SEI:*:*:SEIUX) echo mips-sei-seiux${UNAME_RELEASE} exit ;; *:DragonFly:*:*) echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` exit ;; *:*VMS:*:*) UNAME_MACHINE=`(uname -p) 2>/dev/null` case "${UNAME_MACHINE}" in A*) echo alpha-dec-vms ; exit ;; I*) echo ia64-dec-vms ; exit ;; V*) echo vax-dec-vms ; exit ;; esac ;; *:XENIX:*:SysV) echo i386-pc-xenix exit ;; i*86:skyos:*:*) echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' exit ;; i*86:rdos:*:*) echo ${UNAME_MACHINE}-pc-rdos exit ;; i*86:AROS:*:*) echo ${UNAME_MACHINE}-pc-aros exit ;; esac #echo '(No uname command or uname output not recognized.)' 1>&2 #echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 eval $set_cc_for_build cat >$dummy.c < # include #endif main () { #if defined (sony) #if defined (MIPSEB) /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, I don't know.... */ printf ("mips-sony-bsd\n"); exit (0); #else #include printf ("m68k-sony-newsos%s\n", #ifdef NEWSOS4 "4" #else "" #endif ); exit (0); #endif #endif #if defined (__arm) && defined (__acorn) && defined (__unix) printf ("arm-acorn-riscix\n"); exit (0); #endif #if defined (hp300) && !defined (hpux) printf ("m68k-hp-bsd\n"); exit (0); #endif #if defined (NeXT) #if !defined (__ARCHITECTURE__) #define __ARCHITECTURE__ "m68k" #endif int version; version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; if (version < 4) printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); else printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); exit (0); #endif #if defined (MULTIMAX) || defined (n16) #if defined (UMAXV) printf ("ns32k-encore-sysv\n"); exit (0); #else #if defined (CMU) printf ("ns32k-encore-mach\n"); exit (0); #else printf ("ns32k-encore-bsd\n"); exit (0); #endif #endif #endif #if defined (__386BSD__) printf ("i386-pc-bsd\n"); exit (0); #endif #if defined (sequent) #if defined (i386) printf ("i386-sequent-dynix\n"); exit (0); #endif #if defined (ns32000) printf ("ns32k-sequent-dynix\n"); exit (0); #endif #endif #if defined (_SEQUENT_) struct utsname un; uname(&un); if (strncmp(un.version, "V2", 2) == 0) { printf ("i386-sequent-ptx2\n"); exit (0); } if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ printf ("i386-sequent-ptx1\n"); exit (0); } printf ("i386-sequent-ptx\n"); exit (0); #endif #if defined (vax) # if !defined (ultrix) # include # if defined (BSD) # if BSD == 43 printf ("vax-dec-bsd4.3\n"); exit (0); # else # if BSD == 199006 printf ("vax-dec-bsd4.3reno\n"); exit (0); # else printf ("vax-dec-bsd\n"); exit (0); # endif # endif # else printf ("vax-dec-bsd\n"); exit (0); # endif # else printf ("vax-dec-ultrix\n"); exit (0); # endif #endif #if defined (alliant) && defined (i860) printf ("i860-alliant-bsd\n"); exit (0); #endif exit (1); } EOF $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && { echo "$SYSTEM_NAME"; exit; } # Apollos put the system type in the environment. test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } # Convex versions that predate uname can use getsysinfo(1) if [ -x /usr/convex/getsysinfo ] then case `getsysinfo -f cpu_type` in c1*) echo c1-convex-bsd exit ;; c2*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; c34*) echo c34-convex-bsd exit ;; c38*) echo c38-convex-bsd exit ;; c4*) echo c4-convex-bsd exit ;; esac fi cat >&2 < in order to provide the needed information to handle your system. config.guess timestamp = $timestamp uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` /bin/uname -X = `(/bin/uname -X) 2>/dev/null` hostinfo = `(hostinfo) 2>/dev/null` /bin/universe = `(/bin/universe) 2>/dev/null` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` /bin/arch = `(/bin/arch) 2>/dev/null` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` UNAME_MACHINE = ${UNAME_MACHINE} UNAME_RELEASE = ${UNAME_RELEASE} UNAME_SYSTEM = ${UNAME_SYSTEM} UNAME_VERSION = ${UNAME_VERSION} EOF exit 1 # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: mingw-ocaml/ocaml/config/m-nt.h0000644000175000017500000000273412124403240015754 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Machine configuration, Intel x86 processors, Win32, Visual C++ or Mingw compiler */ #ifdef _WIN64 #define ARCH_SIXTYFOUR #else #undef ARCH_SIXTYFOUR #endif #undef ARCH_BIG_ENDIAN #undef ARCH_ALIGN_DOUBLE #define SIZEOF_INT 4 #define SIZEOF_LONG 4 #ifdef _WIN64 #define SIZEOF_PTR 8 #else #define SIZEOF_PTR 4 #endif #define SIZEOF_SHORT 2 #ifdef __MINGW32__ #define ARCH_INT64_TYPE long long #define ARCH_UINT64_TYPE unsigned long long #else #define ARCH_INT64_TYPE __int64 #define ARCH_UINT64_TYPE unsigned __int64 #endif #define ARCH_INT64_PRINTF_FORMAT "I64" #undef NONSTANDARD_DIV_MOD mingw-ocaml/ocaml/config/s-templ.h0000644000175000017500000001365512124403240016466 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Operating system and standard library dependencies. */ /* 0. Operating system type string. */ #define OCAML_OS_TYPE "Unix" /* #define OCAML_OS_TYPE "Win32" */ /* #define OCAML_OS_TYPE "MacOS" */ /* 1. For the runtime system. */ #define POSIX_SIGNALS /* Define POSIX_SIGNALS if signal handling is POSIX-compliant. In particular, sigaction(), sigprocmask() and the operations on sigset_t are provided. */ #define BSD_SIGNALS /* Define BSD_SIGNALS if signal handlers have the BSD semantics: the handler remains attached to the signal when the signal is received. Leave it undefined if signal handlers have the System V semantics: the signal resets the behavior to default. */ #define HAS_SIGSETMASK /* Define HAS_SIGSETMASK if you have sigsetmask(), as in BSD. */ #define HAS_TERMCAP /* Define HAS_TERMCAP if you have the termcap functions to read the terminal database, e.g. tgetent(), tgetstr(), tgetnum(), tputs(). Also add the required libraries (e.g. -lcurses -ltermcap) to $(CCLIBS) in ../Makefile.config */ #define SUPPORT_DYNAMIC_LINKING /* Define SUPPORT_DYNAMIC_LINKING if dynamic loading of C stub code via dlopen() is available. */ #define HAS_C99_FLOAT_OPS /* Define HAS_C99_FLOAT_OPS if conforms to ISO C99. In particular, it should provide expm1(), log1p(), hypot(), copysign(). */ /* 2. For the Unix library. */ #define HAS_SOCKETS /* Define HAS_SOCKETS if you have BSD sockets. */ #define HAS_SOCKLEN_T /* Define HAS_SOCKLEN_T if the type socklen_t is defined in /usr/include/sys/socket.h. */ #define HAS_UNISTD /* Define HAS_UNISTD if you have /usr/include/unistd.h. */ #define HAS_DIRENT /* Define HAS_DIRENT if you have /usr/include/dirent.h and the result of readdir() is of type struct dirent *. Otherwise, we'll load /usr/include/sys/dir.h, and readdir() is expected to return a struct direct *. */ #define HAS_REWINDDIR /* Define HAS_REWINDDIR if you have rewinddir(). */ #define HAS_LOCKF /* Define HAS_LOCKF if the library provides the lockf() function. */ #define HAS_MKFIFO /* Define HAS_MKFIFO if the library provides the mkfifo() function. */ #define HAS_GETCWD #define HAS_GETWD /* Define HAS_GETCWD if the library provides the getcwd() function. */ /* Define HAS_GETWD if the library provides the getwd() function. */ #define HAS_GETPRIORITY /* Define HAS_GETPRIORITY if the library provides getpriority() and setpriority(). Otherwise, we'll use nice(). */ #define HAS_UTIME #define HAS_UTIMES /* Define HAS_UTIME if you have /usr/include/utime.h and the library provides utime(). Define HAS_UTIMES if the library provides utimes(). */ #define HAS_DUP2 /* Define HAS_DUP2 if you have dup2(). */ #define HAS_FCHMOD /* Define HAS_FCHMOD if you have fchmod() and fchown(). */ #define HAS_TRUNCATE /* Define HAS_TRUNCATE if you have truncate() and ftruncate(). */ #define HAS_SELECT /* Define HAS_SELECT if you have select(). */ #define HAS_SYS_SELECT_H /* Define HAS_SYS_SELECT_H if /usr/include/sys/select.h exists and should be included before using select(). */ #define HAS_SYMLINK /* Define HAS_SYMLINK if you have symlink() and readlink() and lstat(). */ #define HAS_WAIT4 #define HAS_WAITPID /* Define HAS_WAIT4 if you have wait4(). Define HAS_WAITPID if you have waitpid(). */ #define HAS_GETGROUPS /* Define HAS_GETGROUPS if you have getgroups(). */ #define HAS_SETGROUPS /* Define HAS_SETGROUPS if you have setgroups(). */ #define HAS_INITGROUPS /* Define HAS_INITGROUPS if you have initgroups(). */ #define HAS_TERMIOS /* Define HAS_TERMIOS if you have /usr/include/termios.h and it is Posix-compliant. */ #define HAS_ASYNC_IO /* Define HAS_ASYNC_IO if BSD-style asynchronous I/O are supported (the process can request to be sent a SIGIO signal when a descriptor is ready for reading). */ #define HAS_SETITIMER /* Define HAS_SETITIMER if you have setitimer(). */ #define HAS_GETHOSTNAME /* Define HAS_GETHOSTNAME if you have gethostname(). */ #define HAS_UNAME /* Define HAS_UNAME if you have uname(). */ #define HAS_GETTIMEOFDAY /* Define HAS_GETTIMEOFDAY if you have gettimeofday(). */ #define HAS_MKTIME /* Define HAS_MKTIME if you have mktime(). */ #define HAS_SETSID /* Define HAS_SETSID if you have setsid(). */ #define HAS_PUTENV /* Define HAS_PUTENV if you have putenv(). */ #define HAS_LOCALE /* Define HAS_LOCALE if you have the include file and the setlocale() function. */ #define HAS_MMAP /* Define HAS_MMAP if you have the include file and the functions mmap() and munmap(). */ #define HAS_GETHOSTBYNAME_R 6 /* Define HAS_GETHOSTBYNAME_R if gethostbyname_r() is available. The value of this symbol is the number of arguments of gethostbyname_r(): either 5 or 6 depending on prototype. (5 is the Solaris version, 6 is the Linux version). */ #define HAS_GETHOSTBYADDR_R 8 /* Define HAS_GETHOSTBYADDR_R if gethostbyname_r() is available. The value of this symbol is the number of arguments of gethostbyaddr_r(): either 7 or 8 depending on prototype. (7 is the Solaris version, 8 is the Linux version). */ mingw-ocaml/ocaml/config/auto-aux/0000755000175000017500000000000012124403240016465 5ustar tootstootsmingw-ocaml/ocaml/config/auto-aux/.ignore0000644000175000017500000000002112124403240017742 0ustar tootstootscamlp4_config.ml mingw-ocaml/ocaml/config/auto-aux/searchpath0000755000175000017500000000202512124403240020534 0ustar tootstoots#!/bin/sh ######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1996 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # Find a program in the path IFS=':' for dir in $PATH; do if test -z "$dir"; then dir=.; fi if test -f $dir/$1; then exit 0; fi done exit 1 mingw-ocaml/ocaml/config/auto-aux/longlong.c0000644000175000017500000000314212124403240020450 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include /* Check for the availability of "long long" type as per ISO C9X */ /* Meaning of return code: 0 long long OK, printf with %ll 1 long long OK, printf with %q 2 long long OK, no printf 3 long long not suitable */ int main(int argc, char **argv) { long long l; unsigned long long u; char buffer[64]; if (sizeof(long long) != 8) return 3; l = 123456789123456789LL; buffer[0] = '\0'; sprintf(buffer, "%lld", l); if (strcmp(buffer, "123456789123456789") == 0) return 0; /* the MacOS X library uses qd to format long longs */ buffer[0] = '\0'; sprintf (buffer, "%qd", l); if (strcmp (buffer, "123456789123456789") == 0) return 1; return 2; } mingw-ocaml/ocaml/config/auto-aux/schar2.c0000644000175000017500000000175512124403240020023 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ signed char foo[]="\377"; int main(int argc, char ** argv) { int i; i = foo[0]; exit(i != -1); } mingw-ocaml/ocaml/config/auto-aux/runtest0000755000175000017500000000206112124403240020116 0ustar tootstoots#!/bin/sh ######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1995 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### if test "$verbose" = yes; then echo "runtest: $cc -o tst $* $cclibs" >&2 $cc -o tst $* $cclibs || exit 100 else $cc -o tst $* $cclibs 2> /dev/null || exit 100 fi exec ./tst mingw-ocaml/ocaml/config/auto-aux/tryassemble0000644000175000017500000000055312124403240020745 0ustar tootstoots#!/bin/sh if test "$verbose" = yes; then echo "tryassemble: $aspp -o tst $*" >&2 $aspp -o tst $* || exit 100 else $aspp -o tst $* 2> /dev/null || exit 100 fi # test as also (if differs) if test "$aspp" != "$as"; then if test "$verbose" = yes; then echo "tryassemble: $as -o tst $*" >&2 $as -o tst $* || exit 100 else $as -o tst $* 2> /dev/null || exit 100 fi fi mingw-ocaml/ocaml/config/auto-aux/ansi.c0000644000175000017500000000167512124403240017574 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1997 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ int main() { #ifdef __STDC__ return 0; #else return 1; #endif } mingw-ocaml/ocaml/config/auto-aux/sharpbang0000755000175000017500000000002312124403240020353 0ustar tootstoots#! /bin/cat exit 1 mingw-ocaml/ocaml/config/auto-aux/bytecopy.c0000644000175000017500000000257612124403240020501 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ char buffer[27]; #ifdef reverse #define cpy(s1,s2,n) copy(s2,s1,n) #else #define cpy copy #endif int main(int argc, char ** argv) { cpy("abcdefghijklmnopqrstuvwxyz", buffer, 27); if (strcmp(buffer, "abcdefghijklmnopqrstuvwxyz") != 0) exit(1); cpy(buffer, buffer+3, 26-3); if (strcmp(buffer, "abcabcdefghijklmnopqrstuvw") != 0) exit(1); cpy("abcdefghijklmnopqrstuvwxyz", buffer, 27); cpy(buffer+3, buffer, 26-3); if (strcmp(buffer, "defghijklmnopqrstuvwxyzxyz") != 0) exit(1); exit(0); } mingw-ocaml/ocaml/config/auto-aux/tclversion.c0000644000175000017500000000227312124403240021025 0ustar tootstoots/***********************************************************************/ /* */ /* MLTk, Tcl/Tk interface of OCaml */ /* */ /* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file LICENSE found in the OCaml source tree. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include main () { puts(TCL_VERSION); } mingw-ocaml/ocaml/config/auto-aux/getgroups.c0000644000175000017500000000214212124403240020647 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #ifdef NGROUPS_MAX int main(void) { int gidset[NGROUPS_MAX]; if (getgroups(NGROUPS_MAX, gidset) == -1) return 1; return 0; } #else int main(void) { return 1; } #endif mingw-ocaml/ocaml/config/auto-aux/setgroups.c0000644000175000017500000000212712124403240020666 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Contributed by Stephane Glondu */ /* */ /* Copyright 2009 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include int main(void) { gid_t gidset[1]; gidset[0] = 0; if (setgroups(1, gidset) == -1 && errno != EPERM) return 1; return 0; } mingw-ocaml/ocaml/config/auto-aux/divmod.c0000644000175000017500000000315012124403240020112 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Test semantics of division and modulus for negative arguments */ long div4[] = { -4,-3,-3,-3,-3,-2,-2,-2,-2,-1,-1,-1,-1,0,0,0, 0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4 }; long divm4[] = { 4,3,3,3,3,2,2,2,2,1,1,1,1,0,0,0, 0,0,0,0,-1,-1,-1,-1,-2,-2,-2,-2,-3,-3,-3,-3,-4 }; long mod4[] = { 0,-3,-2,-1,0,-3,-2,-1,0,-3,-2,-1,0,-3,-2,-1, 0,1,2,3,0,1,2,3,0,1,2,3,0,1,2,3,0 }; long modm4[] = { 0,-3,-2,-1,0,-3,-2,-1,0,-3,-2,-1,0,-3,-2,-1, 0,1,2,3,0,1,2,3,0,1,2,3,0,1,2,3,0 }; long q1 = 4; long q2 = -4; int main() { int i; for (i = -16; i <= 16; i++) { if (i / q1 != div4[i+16]) return 1; if (i / q2 != divm4[i+16]) return 1; if (i % q1 != mod4[i+16]) return 1; if (i % q2 != modm4[i+16]) return 1; } return 0; } mingw-ocaml/ocaml/config/auto-aux/ia32sse2.c0000644000175000017500000000206112124403240020163 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2003 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Test whether IA32 assembler supports SSE2 instructions */ int main() { asm("pmuludq %mm1, %mm0"); asm("paddq %mm1, %mm0"); asm("psubq %mm1, %mm0"); return 0; } mingw-ocaml/ocaml/config/auto-aux/schar.c0000644000175000017500000000174612124403240017741 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ char foo[]="\377"; int main(int argc, char ** argv) { int i; i = foo[0]; exit(i != -1); } mingw-ocaml/ocaml/config/auto-aux/trycompile0000755000175000017500000000205112124403240020600 0ustar tootstoots#!/bin/sh ######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 2002 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### if test "$verbose" = yes; then echo "trycompile: $cc -o tst $* $cclibs" >&2 $cc -o tst $* $cclibs || exit 100 else $cc -o tst $* $cclibs 2> /dev/null || exit 100 fi mingw-ocaml/ocaml/config/auto-aux/cfi.S0000644000175000017500000000025412124403240017353 0ustar tootstootscamlPervasives__loop_1128: .file 1 "pervasives.ml" .loc 1 193 .cfi_startproc .cfi_adjust_cfa_offset 8 .cfi_endproc mingw-ocaml/ocaml/config/auto-aux/hasgot20000644000175000017500000000277312124403240017770 0ustar tootstoots#!/bin/sh ######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 2011 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### opts="" libs="$cclibs" args=$* rm -f hasgot.c var="x" while : ; do case "$1" in -i) echo "#include <$2>" >> hasgot.c; shift;; -t) echo "$2 $var;" >> hasgot.c; var="x$var"; shift;; -l*|-L*|-F*) libs="$libs $1";; -framework) libs="$libs $1 $2"; shift;; -*) opts="$opts $1";; *) break;; esac shift done (echo "main() {" for f in $*; do echo " (void) & $f;"; done echo "}") >> hasgot.c if test "$verbose" = yes; then echo "hasgot2 $args: $cc $opts -o tst hasgot.c $libs" >&2 exec $cc $opts -o tst hasgot.c $libs > /dev/null else exec $cc $opts -o tst hasgot.c $libs > /dev/null 2>/dev/null fi mingw-ocaml/ocaml/config/auto-aux/dblalign.c0000644000175000017500000000265212124403240020412 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include double foo; void access_double(double *p) { foo = *p; } jmp_buf failure; void sig_handler(int sig) { longjmp(failure, 1); } int main(void) { long n[10]; int res; signal(SIGSEGV, sig_handler); #ifdef SIGBUS signal(SIGBUS, sig_handler); #endif if(setjmp(failure) == 0) { access_double((double *) n); access_double((double *) (n+1)); res = 0; } else { res = 1; } signal(SIGSEGV, SIG_DFL); #ifdef SIGBUS signal(SIGBUS, SIG_DFL); #endif exit(res); } mingw-ocaml/ocaml/config/auto-aux/gethostbyname.c0000644000175000017500000000263112124403240021504 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef _REENTRANT /* This helps detection on Digital Unix... */ #define _REENTRANT #endif #include #include int main(int argc, char ** argv) { #if NUM_ARGS == 5 struct hostent *hp; struct hostent h; char buffer[1000]; int h_errno; hp = gethostbyname_r("www.caml.org", &h, buffer, 10, &h_errno); #elif NUM_ARGS == 6 struct hostent *hp; struct hostent h; char buffer[1000]; int h_errno; int rc; rc = gethostbyname_r("www.caml.org", &h, buffer, 10, &hp, &h_errno); #endif return 0; } mingw-ocaml/ocaml/config/auto-aux/align.c0000644000175000017500000000427412124403240017732 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include long foo; void access16(short int *p) { foo = *p; } void access32(long int *p) { foo = *p; } jmp_buf failure; void sig_handler(int dummy) { longjmp(failure, 1); } int test(void (*fct) (/* ??? */), char *p) { int res; signal(SIGSEGV, sig_handler); signal(SIGBUS, sig_handler); if(setjmp(failure) == 0) { fct(p); res = 0; } else { res = 1; } signal(SIGSEGV, SIG_DFL); signal(SIGBUS, SIG_DFL); return res; } jmp_buf timer; void alarm_handler(int dummy) { longjmp(timer, 1); } void use(int n) { return; } int speedtest(char *p) { int * q; volatile int total; int i; volatile int sum; signal(SIGALRM, alarm_handler); sum = 0; if (setjmp(timer) == 0) { alarm(1); total = 0; while(1) { for (q = (int *) p, i = 1000; i > 0; q++, i--) sum += *q; total++; } } use(sum); signal(SIGALRM, SIG_DFL); return total; } main(void) { long n[1001]; int speed_aligned, speed_unaligned; if (test(access16, (char *) n + 1)) exit(1); if (test(access32, (char *) n + 1)) exit(1); if (test(access32, (char *) n + 2)) exit(1); speed_aligned = speedtest((char *) n); speed_unaligned = speedtest((char *) n + 1); if (speed_aligned >= 3 * speed_unaligned) exit(1); exit(0); } mingw-ocaml/ocaml/config/auto-aux/hasgot0000755000175000017500000000276312124403240017710 0ustar tootstoots#!/bin/sh ######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1995 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### opts="" libs="$cclibs" args=$* rm -f hasgot.c var="x" while : ; do case "$1" in -i) echo "#include <$2>" >> hasgot.c; shift;; -t) echo "$2 $var;" >> hasgot.c; var="x$var"; shift;; -l*|-L*|-F*) libs="$libs $1";; -framework) libs="$libs $1 $2"; shift;; -*) opts="$opts $1";; *) break;; esac shift done (echo "main() {" for f in $*; do echo " $f();"; done echo "}") >> hasgot.c if test "$verbose" = yes; then echo "hasgot $args: $cc $opts -o tst hasgot.c $libs" >&2 exec $cc $opts -o tst hasgot.c $libs > /dev/null else exec $cc $opts -o tst hasgot.c $libs > /dev/null 2>/dev/null fi mingw-ocaml/ocaml/config/auto-aux/sizes.c0000644000175000017500000000204712124403240017771 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include int main(int argc, char **argv) { printf("%d %d %d %d\n", sizeof(int), sizeof(long), sizeof(long *), sizeof(short)); return 0; } mingw-ocaml/ocaml/config/auto-aux/endian.c0000644000175000017500000000246412124403240020075 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "m.h" #ifndef ARCH_SIXTYFOUR long intval = 0x41424344L; char * bigendian = "ABCD"; char * littleendian = "DCBA"; #else long intval = 0x4142434445464748L; char * bigendian = "ABCDEFGH"; char * littleendian = "HGFEDCBA"; #endif main(void) { long n[2]; char * p; n[0] = intval; n[1] = 0; p = (char *) n; if (strcmp(p, bigendian) == 0) exit(0); if (strcmp(p, littleendian) == 0) exit(1); exit(2); } mingw-ocaml/ocaml/config/auto-aux/int64align.c0000644000175000017500000000273212124403240020614 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2000 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "m.h" ARCH_INT64_TYPE foo; void access_int64(ARCH_INT64_TYPE *p) { foo = *p; } jmp_buf failure; void sig_handler(int sig) { longjmp(failure, 1); } int main(void) { long n[10]; int res; signal(SIGSEGV, sig_handler); #ifdef SIGBUS signal(SIGBUS, sig_handler); #endif if(setjmp(failure) == 0) { access_int64((ARCH_INT64_TYPE *) n); access_int64((ARCH_INT64_TYPE *) (n+1)); res = 0; } else { res = 1; } signal(SIGSEGV, SIG_DFL); #ifdef SIGBUS signal(SIGBUS, SIG_DFL); #endif exit(res); } mingw-ocaml/ocaml/config/auto-aux/sighandler.c0000644000175000017500000000176112124403240020756 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include int main(void) { SIGRETURN (*old)(); old = signal(SIGQUIT, SIG_DFL); return 0; } mingw-ocaml/ocaml/config/auto-aux/elf.c0000644000175000017500000000201512124403240017375 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include int main(int argc, char ** argv) { #ifdef __ELF__ printf("elf\n"); #else printf("aout\n"); #endif return 0; } mingw-ocaml/ocaml/config/auto-aux/gethostbyaddr.c0000644000175000017500000000312312124403240021473 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef _REENTRANT /* This helps detection on Digital Unix... */ #define _REENTRANT #endif #include #include int main(int argc, char ** argv) { #if NUM_ARGS == 7 char * address; int length; int type; struct hostent h; char buffer[10]; int buflen; int h_errnop; struct hostent * hp; hp = gethostbyaddr_r(address, length, type, &h, buffer, buflen, &h_errnop); #elif NUM_ARGS == 8 char * address; int length; int type; struct hostent h; char buffer[10]; int buflen; int h_errnop; struct hostent * hp; int rc; rc = gethostbyaddr_r(address, length, type, &h, buffer, buflen, &hp, &h_errnop); #endif return 0; } mingw-ocaml/ocaml/config/auto-aux/async_io.c0000644000175000017500000000334312124403240020440 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include #include "s.h" int signalled; void sigio_handler(int arg) { signalled = 1; } int main(void) { #if defined(SIGIO) && defined(FASYNC) && defined(F_SETFL) && defined(F_SETOWN) int p[2]; int ret; #define OUT 0 #define IN 1 if (socketpair(PF_UNIX, SOCK_STREAM, 0, p) == -1) return 1; signalled = 0; signal(SIGIO, sigio_handler); ret = fcntl(p[OUT], F_GETFL, 0); fcntl(p[OUT], F_SETFL, ret | FASYNC); fcntl(p[OUT], F_SETOWN, getpid()); switch(fork()) { case -1: return 1; case 0: close(p[OUT]); write(p[IN], "x", 1); sleep(1); exit(0); default: close(p[IN]); while(wait(NULL) == -1 && errno == EINTR) /*nothing*/; } if (signalled) return 0; else return 1; #else return 1; #endif } mingw-ocaml/ocaml/config/auto-aux/signals.c0000644000175000017500000000326212124403240020274 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* To determine the semantics of signal handlers (System V: signal is reset to default behavior on entrance to the handler BSD: signal handler remains active). */ #include #include /* Find a signal that is ignored by default */ #ifdef SIGCHLD #define IGNSIG SIGCHLD #else #ifdef SIGIO #define IGNSIG SIGIO #else #ifdef SIGCLD #define IGNSIG SIGCLD #else #ifdef SIGPWR #define IGNSIG SIGPWR #endif #endif #endif #endif #ifdef IGNSIG int counter; void sig_handler(int dummy) { counter++; } int main(int argc, char **argv) { signal(IGNSIG, sig_handler); counter = 0; kill(getpid(), IGNSIG); kill(getpid(), IGNSIG); return (counter == 2 ? 0 : 1); } #else /* If no suitable signal was found, assume System V */ int main(int argc, char ** argv) { return 1; } #endif mingw-ocaml/ocaml/config/auto-aux/expm1.c0000644000175000017500000000201212124403240017656 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2011 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include volatile double x; int main(int argc, char **argv) { x = 3.1415; x = expm1(x); x = log1p(x); return 0; } mingw-ocaml/ocaml/config/auto-aux/initgroups.c0000644000175000017500000000206412124403240021036 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Contributed by Stephane Glondu */ /* */ /* Copyright 2009 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include int main(void) { if (initgroups("root", 0) == -1 && errno != EPERM) return 1; return 0; } mingw-ocaml/ocaml/config/auto-aux/stackov.c0000644000175000017500000000470412124403240020310 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include static char sig_alt_stack[SIGSTKSZ]; static char * system_stack_top; #if defined(TARGET_i386) && defined(SYS_linux_elf) static void segv_handler(int signo, struct sigcontext sc) { char * fault_addr = (char *) sc.cr2; #else static void segv_handler(int signo, siginfo_t * info, void * context) { char * fault_addr = (char *) info->si_addr; #endif struct rlimit limit; if (getrlimit(RLIMIT_STACK, &limit) == 0 && ((long) fault_addr & (sizeof(long) - 1)) == 0 && fault_addr < system_stack_top && fault_addr >= system_stack_top - limit.rlim_cur - 0x2000) { _exit(0); } else { _exit(4); } } int main(int argc, char ** argv) { stack_t stk; struct sigaction act; stk.ss_sp = sig_alt_stack; stk.ss_size = SIGSTKSZ; stk.ss_flags = 0; #if defined(TARGET_i386) && defined(SYS_linux_elf) act.sa_handler = (void (*)(int)) segv_handler; act.sa_flags = SA_ONSTACK | SA_NODEFER; #else act.sa_sigaction = segv_handler; act.sa_flags = SA_SIGINFO | SA_ONSTACK | SA_NODEFER; #endif sigemptyset(&act.sa_mask); system_stack_top = (char *) &act; if (sigaltstack(&stk, NULL) != 0) { perror("sigaltstack"); return 2; } if (sigaction(SIGSEGV, &act, NULL) != 0) { perror("sigaction"); return 2; } /* We used to trigger a stack overflow at this point to test whether the code above works, but this causes problems with POSIX threads on some BSD systems. So, instead, we just test that all this code compiles, indicating that the required syscalls are there. */ return 0; } mingw-ocaml/ocaml/config/auto-aux/sharpbang20000755000175000017500000000002712124403240020441 0ustar tootstoots#! /usr/bin/cat exit 1 mingw-ocaml/ocaml/config/auto-aux/solaris-ld0000644000175000017500000000212512124403240020461 0ustar tootstoots#!/bin/sh ######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 2001 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # Determine if gcc calls the Solaris ld or the GNU ld # Exit code is 0 for Solaris ld, 1 for GNU ld echo "int main() { return 0; }" > hasgot.c $cc -v -o tst hasgot.c 2>&1 | grep -s '^ld:' > /dev/null exit $? mingw-ocaml/ocaml/config/Makefile.msvc640000644000175000017500000001064012124403240017504 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### # $Id$ # Configuration for Windows, Visual C++ compiler ######### General configuration PREFIX=C:/ocamlms64 ### Where to install the binaries. BINDIR=$(PREFIX)/bin ### Where to install the standard library LIBDIR=$(PREFIX)/lib ### Where to install the stub DLLs STUBLIBDIR=$(LIBDIR)/stublibs ### Where to install the info files DISTRIB=$(PREFIX) ### Where to install the man pages MANDIR=$(PREFIX)/man ########## Toolchain and OS dependencies TOOLCHAIN=msvc CCOMPTYPE=msvc O=obj A=lib S=asm SO=s.obj DO=d.obj DBGO=dbg.obj EXE=.exe EXT_DLL=.dll EXT_OBJ=.$(O) EXT_LIB=.$(A) EXT_ASM=.$(S) MANEXT=1 SHARPBANGSCRIPTS=false PTHREAD_LINK= X11_INCLUDES= X11_LINK= DBM_INCLUDES= DBM_LINK= BYTECCRPATH= SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= NATIVECCPROFOPTS= NATIVECCRPATH= ASM=ml64 /nologo /Cp /c /Fo ASPP= ASPPPROFFLAGS= PROFILING=noprof DYNLINKOPTS= DEBUGGER=ocamldebugger CC_PROFILE= SYSTHREAD_SUPPORT=true CMXS=cmxs NATDYNLINK=true RUNTIMED=noruntimed ASM_CFI_SUPPORTED=false ########## Configuration for the bytecode compiler ### Which C compiler to use for the bytecode interpreter. BYTECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(BYTECC). (For static linking.) BYTECCCOMPOPTS=/Ox /MD ### Additional compile-time options for $(BYTECC). (For debug version.) BYTECCDBGCOMPOPTS=-DDEBUG /Zi /W3 /Wp64 ### Additional link-time options for $(BYTECC). (For static linking.) BYTECCLINKOPTS= ### Additional compile-time options for $(BYTECC). (For building a DLL.) DLLCCCOMPOPTS=/Ox /MD ### Libraries needed #EXTRALIBS=bufferoverflowu.lib # for the old PSDK compiler only EXTRALIBS= BYTECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS) NATIVECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS) ### How to invoke the C preprocessor CPP=cl /nologo /EP ### Flexlink FLEXLINK=flexlink -x64 -merge-manifest -stack 33554432 FLEXDIR=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) MKEXE=$(FLEXLINK) -exe MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library MKLIB=link /lib /nologo /machine:AMD64 /out:$(1) $(2) #ml let mklib out files opts = Printf.sprintf "link /lib /nologo /machine:AMD64 /out:%s %s %s" out opts files;; MKSHAREDLIBRPATH= ### Canonicalize the name of a system library SYSLIB=$(1).lib #ml let syslib x = x ^ ".lib";; ### The ranlib command RANLIB=echo RANLIBCMD= ### The ar command ARCMD= ############# Configuration for the native-code compiler ### Name of architecture for the native-code compiler ARCH=amd64 ### Name of architecture model for the native-code compiler. MODEL=default ### Name of operating system family for the native-code compiler. SYSTEM=win64 ### Which C compiler to use for the native-code compiler. NATIVECC=cl /nologo ### Additional compile-time options for $(NATIVECC). NATIVECCCOMPOPTS=/Ox /MD ### Additional link-time options for $(NATIVECC) NATIVECCLINKOPTS= ### Build partially-linked object file PACKLD=link /lib /nologo /machine:AMD64 /out:# there must be no space after this '/out:' ############# Configuration for camlp4 # This variable controls whether camlp4 will be built. # If it is set to camlp4, then it will be built. # If it is set to the empty string, then it will not be built. CAMLP4=camlp4 ############# Configuration for the contributed libraries OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray ### Name of the target architecture for the "num" library BNG_ARCH=generic BNG_ASM_LEVEL=0 ### Configuration for LablTk (not supported) TK_DEFS= TK_LINK= ############# Aliases for common commands MAKEREC=$(MAKE) -f Makefile.nt MAKECMD=$(MAKE) mingw-ocaml/ocaml/config/Makefile.mingw640000644000175000017500000001027112124403240017655 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### # $Id: Makefile.mingw 11319 2011-12-16 17:02:48Z xleroy $ # Configuration for Windows, Mingw compiler ######### General configuration PREFIX=C:/ocamlmgw64 ### Remove this to disable compiling camlp4 CAMLP4=camlp4 ### Where to install the binaries BINDIR=$(PREFIX)/bin ### Where to install the standard library LIBDIR=$(PREFIX)/lib ### Where to install the stub DLLs STUBLIBDIR=$(LIBDIR)/stublibs ### Where to install the info files DISTRIB=$(PREFIX) ### Where to install the man pages MANDIR=$(PREFIX)/man ########## Toolchain and OS dependencies TOOLCHAIN=mingw ### Toolchain prefix TOOLPREF=x86_64-w64-mingw32- CCOMPTYPE=cc O=o A=a S=s SO=s.o DO=d.o EXE=.exe EXT_DLL=.dll EXT_OBJ=.$(O) EXT_LIB=.$(A) EXT_ASM=.$(S) MANEXT=1 SHARPBANGSCRIPTS=false PTHREAD_LINK= X11_INCLUDES= X11_LINK= DBM_INCLUDES= DBM_LINK= BYTECCRPATH= SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= MKSHAREDLIBRPATH= NATIVECCPROFOPTS= NATIVECCRPATH= ASM=$(TOOLPREF)as ASPP=gcc ASPPPROFFLAGS= PROFILING=noprof DYNLINKOPTS= DEBUGGER=ocamldebugger CC_PROFILE= SYSTHREAD_SUPPORT=true EXTRALIBS= NATDYNLINK=true CMXS=cmxs RUNTIMED=noruntimed ASM_CFI_SUPPORTED=false ########## Configuration for the bytecode compiler ### Which C compiler to use for the bytecode interpreter. BYTECC=$(TOOLPREF)gcc ### Additional compile-time options for $(BYTECC). (For static linking.) BYTECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused ### Additional link-time options for $(BYTECC). (For static linking.) BYTECCLINKOPTS= ### Additional compile-time options for $(BYTECC). (For building a DLL.) DLLCCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused -DCAML_DLL ### Libraries needed BYTECCLIBS=-lws2_32 NATIVECCLIBS=-lws2_32 ### How to invoke the C preprocessor CPP=$(BYTECC) -E ### Flexlink FLEXLINK=flexlink -chain mingw64 -stack 33554432 FLEXDIR=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) MKEXE=$(FLEXLINK) -exe MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library MKLIB=rm -f $(1); $(TOOLPREF)ar rc $(1) $(2); $(RANLIB) $(1) #ml let mklib out files opts = Printf.sprintf "rm -f %s && %sar rcs %s %s %s" out toolpref opts out files;; ### Canonicalize the name of a system library SYSLIB=-l$(1) #ml let syslib x = "-l"^x;; ### The ranlib command RANLIB=$(TOOLPREF)ranlib RANLIBCMD=$(TOOLPREF)ranlib ### The ar command ARCMD=$(TOOLPREF)ar ############# Configuration for the native-code compiler ### Name of architecture for the native-code compiler ARCH=amd64 ### Name of architecture model for the native-code compiler. MODEL=default ### Name of operating system family for the native-code compiler. SYSTEM=mingw64 ### Which C compiler to use for the native-code compiler. NATIVECC=$(BYTECC) ### Additional compile-time options for $(NATIVECC). NATIVECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused ### Additional link-time options for $(NATIVECC) NATIVECCLINKOPTS= ### Build partially-linked object file PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o #there must be a space after this '-o' ############# Configuration for the contributed libraries OTHERLIBRARIES=win32unix str num win32graph dynlink bigarray systhreads ### Name of the target architecture for the "num" library BNG_ARCH=amd64 BNG_ASM_LEVEL=1 ### Configuration for LablTk (not supported) TK_DEFS= TK_LINK= ############# Aliases for common commands MAKEREC=$(MAKE) -f Makefile.nt MAKECMD=$(MAKE) mingw-ocaml/ocaml/config/m-templ.h0000644000175000017500000000655012124403240016454 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Processor dependencies */ #define ARCH_SIXTYFOUR /* Define ARCH_SIXTYFOUR if the processor has a natural word size of 64 bits. That is, sizeof(char *) = 8. Otherwise, leave ARCH_SIXTYFOUR undefined. This assumes sizeof(char *) = 4. */ #define ARCH_BIG_ENDIAN /* Define ARCH_BIG_ENDIAN if the processor is big endian (the most significant byte of an integer stored in memory comes first). Leave ARCH_BIG_ENDIAN undefined if the processor is little-endian (the least significant byte comes first). */ #define ARCH_ALIGN_DOUBLE /* Define ARCH_ALIGN_DOUBLE if the processor requires doubles to be doubleword-aligned. Leave ARCH_ALIGN_DOUBLE undefined if the processor supports word-aligned doubles. */ #undef ARCH_CODE32 /* Define ARCH_CODE32 if, on a 64-bit machine, code pointers fit in 32 bits, i.e. the code segment resides in the low 4G of the addressing space. ARCH_CODE32 is ignored on 32-bit machines. */ #define SIZEOF_INT 4 #define SIZEOF_LONG 4 #define SIZEOF_PTR 4 #define SIZEOF_SHORT 2 /* Define SIZEOF_INT, SIZEOF_LONG, SIZEOF_PTR and SIZEOF_SHORT to the sizes in bytes of the C types "int", "long", "char *" and "short", respectively. */ #define ARCH_INT64_TYPE long long #define ARCH_UINT64_TYPE unsigned long long /* Define ARCH_INT64_TYPE and ARCH_UINT64_TYPE to 64-bit integer types, typically "long long" and "unsigned long long" on 32-bit platforms, and "long" and "unsigned long" on 64-bit platforms. If the C compiler doesn't support any 64-bit integer type, leave both ARCH_INT64_TYPE and ARCH_UINT64_TYPE undefined. */ #define ARCH_INT64_PRINTF_FORMAT "ll" /* Define ARCH_INT64_PRINTF_FORMAT to the printf format used for formatting values of type ARCH_INT64_TYPE. This is usually "ll" on 32-bit platforms and "l" on 64-bit platforms. Leave undefined if ARCH_INT64_TYPE is undefined. */ #define ARCH_ALIGN_INT64 /* Define ARCH_ALIGN_INT64 if the processor requires 64-bit integers to be doubleword-aligned. Leave ARCH_ALIGN_INT64 undefined if the processor supports word-aligned 64-bit integers. Leave undefined if 64-bit integers are not supported. */ #undef NONSTANDARD_DIV_MOD /* Leave NONSTANDARD_DIV_MOD undefined if the C operators / and % implement round-towards-zero semantics, as specified by ISO C 9x and implemented by most contemporary processors. Otherwise, or if you don't know, define NONSTANDARD_DIV_MOD: this will select a slower but correct software emulation of division and modulus. */ mingw-ocaml/ocaml/config/Makefile.msvc0000644000175000017500000001135612124403240017337 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### # $Id$ # Configuration for Windows, Visual C++ compiler ######### General configuration PREFIX=C:/ocamlms ### Where to install the binaries. BINDIR=$(PREFIX)/bin ### Where to install the standard library LIBDIR=$(PREFIX)/lib ### Where to install the stub DLLs STUBLIBDIR=$(LIBDIR)/stublibs ### Where to install the info files DISTRIB=$(PREFIX) ### Where to install the man pages MANDIR=$(PREFIX)/man ########## Toolchain and OS dependencies TOOLCHAIN=msvc CCOMPTYPE=msvc O=obj A=lib S=asm SO=s.obj DO=d.obj EXE=.exe EXT_DLL=.dll EXT_OBJ=.$(O) EXT_LIB=.$(A) EXT_ASM=.$(S) MANEXT=1 SHARPBANGSCRIPTS=false PTHREAD_LINK= X11_INCLUDES= X11_LINK= DBM_INCLUDES= DBM_LINK= BYTECCRPATH= SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= NATIVECCPROFOPTS= NATIVECCRPATH= ASM=ml /nologo /coff /Cp /c /Fo ASPP= ASPPPROFFLAGS= PROFILING=noprof DYNLINKOPTS= DEBUGGER=ocamldebugger CC_PROFILE= SYSTHREAD_SUPPORT=true EXTRALIBS= CMXS=cmxs NATDYNLINK=true RUNTIMED=noruntimed ASM_CFI_SUPPORTED=false ########## Configuration for the bytecode compiler ### Which C compiler to use for the bytecode interpreter. BYTECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(BYTECC). (For static linking.) BYTECCCOMPOPTS=/Ox /MD ### Additional link-time options for $(BYTECC). (For static linking.) BYTECCLINKOPTS= ### Additional compile-time options for $(BYTECC). (For building a DLL.) DLLCCCOMPOPTS=/Ox /MD ### Libraries needed BYTECCLIBS=advapi32.lib ws2_32.lib NATIVECCLIBS=advapi32.lib ws2_32.lib ### How to invoke the C preprocessor CPP=cl /nologo /EP ### Flexlink FLEXLINK=flexlink -merge-manifest -stack 16777216 FLEXDIR=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) MKEXE=$(FLEXLINK) -exe MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library MKLIB=link /lib /nologo /out:$(1) $(2) #ml let mklib out files opts = Printf.sprintf "link /lib /nologo /out:%s %s %s" out opts files;; MKSHAREDLIBRPATH= ### Canonicalize the name of a system library SYSLIB=$(1).lib #ml let syslib x = x ^ ".lib";; ### The ranlib command RANLIB=echo RANLIBCMD= ### The ar command ARCMD= ############# Configuration for the native-code compiler ### Name of architecture for the native-code compiler ARCH=i386 ### Name of architecture model for the native-code compiler. MODEL=default ### Name of operating system family for the native-code compiler. SYSTEM=win32 ### Which C compiler to use for the native-code compiler. NATIVECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(NATIVECC). NATIVECCCOMPOPTS=/Ox /MD ### Additional link-time options for $(NATIVECC) NATIVECCLINKOPTS= ### Build partially-linked object file PACKLD=link /lib /nologo /out:# there must be no space after this '/out:' ############# Configuration for camlp4 # This variable controls whether camlp4 will be built. # If it is set to camlp4, then it will be built. # If it is set to the empty string, then it will not be built. CAMLP4=camlp4 ############# Configuration for the contributed libraries OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray labltk ### Name of the target architecture for the "num" library BNG_ARCH=generic BNG_ASM_LEVEL=0 ### Configuration for LablTk # Set TK_ROOT to the directory where you installed TCL/TK 8.5 TK_ROOT=c:/tcl TK_DEFS=-I$(TK_ROOT)/include # The following definition avoids hard-wiring $(TK_ROOT) in the libraries # produced by OCaml, and is therefore required for binary distribution # of these libraries. However, $(TK_ROOT)/lib must be added to the LIB # environment variable, as described in README.win32. TK_LINK=tk85.lib tcl85.lib ws2_32.lib # An alternative definition that avoids mucking with the LIB variable, # but hard-wires the Tcl/Tk location in the binaries # TK_LINK=$(TK_ROOT)/tk85.lib $(TK_ROOT)/tcl85.lib ws2_32.lib ############# Aliases for common commands MAKEREC=$(MAKE) -f Makefile.nt MAKECMD=$(MAKE) mingw-ocaml/ocaml/config/Makefile-templ0000644000175000017500000001676012124403240017513 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### # $Id$ ### Compile-time configuration ########## General configuration ### Where to install the binaries BINDIR=/usr/local/bin ### Where to install the standard library LIBDIR=/usr/local/lib/ocaml STUBLIBDIR=$(LIBDIR)/stublibs ### Where to install the man pages # Man pages for commands go in $(MANDIR)/man$(MANEXT) # Man pages for the library go in $(MANDIR)/mano MANDIR=/usr/local/man MANEXT=1 ### Do #! scripts work on your system? ### Beware: on some systems (e.g. SunOS 4), this will work only if ### the string "#!$(BINDIR)/ocamlrun" is less than 32 characters long. ### In doubt, set SHARPBANGSCRIPTS to false. SHARPBANGSCRIPTS=true #SHARPBANGSCRIPTS=false ########## Configuration for the bytecode compiler ### Which C compiler to use for the bytecode interpreter. ### Performance of the bytecode interpreter is *much* improved ### if Gnu CC version 2 is used. #BYTECC=gcc #BYTECC=cc ### Additional compile-time options for $(BYTECC). # If using gcc on Intel x86: # (the -fno-defer-pop option circumvents a bug in certain versions of gcc) #BYTECCCOMPOPTS=-fno-defer-pop -Wall # If using gcc and being cautious: #BYTECCCOMPOPTS=-Wall # Otherwise: #BYTECCCOMPOPTS= ### Additional link-time options for $(BYTECC) # To support dynamic loading of shared libraries (they need to look at # our own symbols): #BYTECCLINKOPTS=-Wl,-E # Otherwise: #BYTECCLINKOPTS= ### Libraries needed # On most platforms: #CCLIBS=-lcurses -ltermcap -lm ### How to invoke the C preprocessor # This is not needed anymore. Leave these lines commented out. # On most machines: #CPP=/lib/cpp -P # Under Solaris: #CPP=/usr/ccs/lib/cpp -P # Under FreeBSD: #CPP=cpp -P ### Magic declarations for ocamlbuild -- leave unchanged #ml let syslib x = "-l"^x;; #ml let mklib out files opts = Printf.sprintf "ar rc %s %s %s; ranlib %s" out opts files out;; ### How to invoke ranlib RANLIB=ranlib RANLIBCMD=ranlib # If ranlib is not needed: #RANLIB=ar rs #RANLIBCMD= ### How to invoke ar #ARCMD=ar ### Shared library support # Extension for shared libraries: so if supported, a if not supported #SO=so #SO=a # Set to nothing if shared libraries supported, and to -custom if not supported #CUSTOM_IF_NOT_SHARED= #CUSTOM_IF_NOT_SHARED=-custom # Options to $(BYTECC) to produce shared objects (e.g. PIC) #SHAREDCCCOMPOPTS=-fPIC # How to build a shared library, invoked with output .so as first arg # and object files as remaining args #MKSHAREDLIB=gcc -shared -o # Compile-time option to $(BYTECC) to add a directory to be searched # at run-time for shared libraries #BYTECCRPATH=-Wl,-rpath ############# Configuration for the native-code compiler ### Name of architecture for the native-code compiler ### Currently supported: ### ### i386 Intel Pentium PCs under Linux, *BSD*, NextStep ### sparc Sun Sparcstation under SunOS 4.1 or Solaris 2 ### power Macintosh under Mac OS X and Linux ### arm ARM under Linux ### ### Set ARCH=none if your machine is not supported #ARCH=i386 #ARCH=sparc #ARCH=power #ARCH=arm #ARCH=none ### Name of architecture model for the native-code compiler. ### Some architectures come in several slightly different flavors ### that share a common code generator. This variable tailors the ### behavior of the code generator to the particular flavor used. ### Currently needed only if ARCH=power; leave MODEL=default for ### other architectures. ### If ARCH=power: set MODEL=ppc ### For other architectures: leave MODEL=default ### #MODEL=ppc #MODEL=default ### Name of operating system family for the native-code compiler. #SYSTEM=solaris #SYSTEM=linux #SYSTEM=linux_elf #SYSTEM=bsd #SYSTEM=unknown ### Which C compiler to use for the native-code compiler. #NATIVECC=cc #NATIVECC=gcc ### Additional compile-time options for $(NATIVECC). # For gcc if cautious: #NATIVECCCOMPOPTS=-Wall ### Additional link-time options for $(NATIVECC) #NATIVECCLINKOPTS= # Compile-time option to $(NATIVECC) to add a directory to be searched # at run-time for shared libraries #NATIVECCRPATH=-Wl,-rpath ### Command and flags to use for assembling ocamlopt-generated code #ASM=as ### Command and flags to use for assembling .S files (often with preprocessing) # If gcc is available: #ASPP=gcc -c # On Solaris: #ASPP=as -P ### Extra flags to use for assembling .S files in profiling mode #ASPPPROFFLAGS=-DPROFILING ### Whether profiling with gprof is supported # If yes: (e.g. x86/Linux, Sparc/Solaris): #PROFILING=prof # If no: #PROFILING=noprof ### Option to give to the C compiler for profiling #CC_PROFILE=-pg #CC_PROFILE=-xpg ### How to perform a partial link PARTIALLD=ld -r $(NATIVECCLINKOPTS) ############# Configuration for the contributed libraries ### Which libraries to compile and install # Currently available: # unix Unix system calls # str Regular expressions and high-level string processing # num Arbitrary-precision rational arithmetic # threads Lightweight concurrent processes # systhreads Same as threads, requires POSIX threads # graph Portable drawing primitives for X11 # dynlink Dynamic linking of bytecode # labltk Tcl/Tk interface # bigarray Large, multidimensional numerical arrays OTHERLIBRARIES=unix str num threads graph dynlink labltk bigarray ### Name of the target architecture for the "num" library # Known targets: # generic (portable C, works everywhere) # ia32 (Intel x86) # amd64 (AMD Opteron, Athlon64) # ppc (Power PC) # sparc # If you don't know, leave BNG_ARCH=generic, which selects a portable # C implementation of these routines. BNG_ARCH=generic BNG_ASM_LEVEL=1 ### Link-time options to ocamlc or ocamlopt for linking with POSIX threads # Needed for the "systhreads" package # Usually: #PTHREAD_LINK=-cclib -lpthread # For Solaris: #PTHREAD_LINK=-cclib -lpthread -cclib -lposix4 ### -I options for finding the X11/*.h includes # Needed for the "graph" and "labltk" packages # Usually: #X11_INCLUDES=-I/usr/X11R6/include # For SunOS with OpenLook: #X11_INCLUDES=/usr/openwin/include ### Link-time options to ocamlc or ocamlopt for linking with X11 libraries # Needed for the "graph" and "labltk" packages # Usually: #X11_LINK=-lX11 # For SunOS with OpenLook: #X11_LINK=-L$(X11_LIB) -lX11 ### Preprocessor options for finding tcl.h and tk.h # Needed for the "labltk" package # Required only if not in the standard include path. # For Tcl/Tk 8.0 on FreeBSD: #TK_DEFS="-I/usr/local/include/tcl8.0 -I/usr/local/include/tk8.0" ### Linker options for linking tcl and tk libraries # Needed for the "labltk" package # Usually (with appropriate version numbers): #TK_LINK="-ltk8.0 -ltcl8.0" # For Tcl/Tk 8.0 on FreeBSD: #TK_LINK="-L/usr/local/lib -ltk8.0 -ltcl8.0" mingw-ocaml/ocaml/_tags0000644000175000017500000000770512124403240014506 0ustar tootstoots######################################################################### # # # OCaml # # # # Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # # # # Copyright 2007 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # Ocamlbuild tags file true: -traverse # Traverse only these directories <{bytecomp,driver,stdlib,tools,asmcomp,camlp4,ocamlbuild,toplevel,ocamldoc,typing,otherlibs,utils,debugger,lex,parsing,byterun,asmrun}/**>: traverse "boot" or "byterun" or "asmrun" or "compilerlibs": not_hygienic # These should not be required but it fails on *BSD and Windows... "yacc" or "win32caml": not_hygienic # We want -g everywhere it's possible true: debug # By default everything we link needs the stdlib true: use_stdlib # The stdlib neither requires the stdlib nor debug information : -use_stdlib, -debug <**/*.ml*>: warn_error_A <{bytecomp,driver,stdlib,tools,asmcomp,toplevel,typing,utils,lex,parsing}/**>: strict_sequence "toplevel/topstart.byte": linkall : -debug : ocamldoc_sources : include_unix, include_str, include_dynlink : use_unix, use_str, use_dynlink : camlp4boot, warn_Z : -camlp4boot "camlp4/Camlp4_import.ml": -warn_Z or or "camlp4/Camlp4/Struct/Lexer.ml": -camlp4boot, -warn_Z, warn_a or : use_dynlink : include_unix "camlp4/Camlp4/Struct/DynLoader.ml" or "camlp4/boot/Camlp4.ml": include_dynlink : include_toplevel : -debug : include_unix <**/pervasives.ml> or <**/pervasives.mli> or <**/camlinternalOO.mli>: nopervasives <**/camlinternalOO*.cmx>: inline(0) <**/scanf*.cmx>: inline(9) <**/*Labels.ml*>: nolabels "tools/addlabels.ml": warn_s or : use_unix, linkall : include_unix or : ocamlmklib or : ocamlmklib : ocamlmklib : ocamlmklib "otherlibs/threads/unix.cma": ocamlmklib : ocamlmklib : include_unix # See the remark about static linking of threads.cmxa in myocamlbuild.ml : ocamlmklib "otherlibs/threads/pervasives.ml": include_unix : otherlibs : otherlibs_unix : otherlibs_win32unix : otherlibs_bigarray : otherlibs_num : otherlibs_threads "otherlibs/threads/unix.cma": -otherlibs_threads : otherlibs_systhreads : otherlibs_dbm : otherlibs_graph : otherlibs_win32graph : otherlibs_labltk or : bootstrap_thread : ocamlmklib "otherlibs/labltk/browser/jglib.cma": -ocamlmklib "otherlibs/labltk/browser/main.byte": use_unix, use_str, ocamlbrowser, bootstrap_thread : include_unix, include_str mingw-ocaml/ocaml/LICENSE0000644000175000017500000007644612124403240014503 0ustar tootstootsIn the following, "the Library" refers to all files marked "Copyright INRIA" in the following directories and their sub-directories: asmrun, byterun, camlp4, config, otherlibs, stdlib, win32caml and "the Compiler" refers to all files marked "Copyright INRIA" in the following directories and their sub-directories: asmcomp, boot, build, bytecomp, debugger, driver, lex, man, ocamlbuild, ocamldoc, parsing, testsuite, tools, toplevel, typing, utils, yacc The Compiler is distributed under the terms of the Q Public License version 1.0 with a change to choice of law (included below). The Library is distributed under the terms of the GNU Library General Public License version 2 (included below). As a special exception to the Q Public Licence, you may develop application programs, reusable components and other software items that link with the original or modified versions of the Compiler and are not made available to the general public, without any of the additional requirements listed in clause 6c of the Q Public licence. As a special exception to the GNU Library General Public License, you may link, statically or dynamically, a "work that uses the Library" with a publicly distributed version of the Library to produce an executable file containing portions of the Library, and distribute that executable file under terms of your choice, without any of the additional requirements listed in clause 6 of the GNU Library General Public License. By "a publicly distributed version of the Library", we mean either the unmodified Library as distributed by INRIA, or a modified version of the Library that is distributed under the conditions defined in clause 2 of the GNU Library General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Library General Public License. ---------------------------------------------------------------------- THE Q PUBLIC LICENSE version 1.0 Copyright (C) 1999 Troll Tech AS, Norway. Everyone is permitted to copy and distribute this license document. The intent of this license is to establish freedom to share and change the software regulated by this license under the open source model. This license applies to any software containing a notice placed by the copyright holder saying that it may be distributed under the terms of the Q Public License version 1.0. Such software is herein referred to as the Software. This license covers modification and distribution of the Software, use of third-party application programs based on the Software, and development of free software which uses the Software. Granted Rights 1. You are granted the non-exclusive rights set forth in this license provided you agree to and comply with any and all conditions in this license. Whole or partial distribution of the Software, or software items that link with the Software, in any form signifies acceptance of this license. 2. You may copy and distribute the Software in unmodified form provided that the entire package, including - but not restricted to - copyright, trademark notices and disclaimers, as released by the initial developer of the Software, is distributed. 3. You may make modifications to the Software and distribute your modifications, in a form that is separate from the Software, such as patches. The following restrictions apply to modifications: a. Modifications must not alter or remove any copyright notices in the Software. b. When modifications to the Software are released under this license, a non-exclusive royalty-free right is granted to the initial developer of the Software to distribute your modification in future versions of the Software provided such versions remain available under these terms in addition to any other license(s) of the initial developer. 4. You may distribute machine-executable forms of the Software or machine-executable forms of modified versions of the Software, provided that you meet these restrictions: a. You must include this license document in the distribution. b. You must ensure that all recipients of the machine-executable forms are also able to receive the complete machine-readable source code to the distributed Software, including all modifications, without any charge beyond the costs of data transfer, and place prominent notices in the distribution explaining this. c. You must ensure that all modifications included in the machine-executable forms are available under the terms of this license. 5. You may use the original or modified versions of the Software to compile, link and run application programs legally developed by you or by others. 6. You may develop application programs, reusable components and other software items that link with the original or modified versions of the Software. These items, when distributed, are subject to the following requirements: a. You must ensure that all recipients of machine-executable forms of these items are also able to receive and use the complete machine-readable source code to the items without any charge beyond the costs of data transfer. b. You must explicitly license all recipients of your items to use and re-distribute original and modified versions of the items in both machine-executable and source code forms. The recipients must be able to do so without any charges whatsoever, and they must be able to re-distribute to anyone they choose. c. If the items are not available to the general public, and the initial developer of the Software requests a copy of the items, then you must supply one. Limitations of Liability In no event shall the initial developers or copyright holders be liable for any damages whatsoever, including - but not restricted to - lost revenue or profits or other direct, indirect, special, incidental or consequential damages, even if they have been advised of the possibility of such damages, except to the extent invariable law, if any, provides otherwise. No Warranty The Software and this license document are provided AS IS with NO WARRANTY OF ANY KIND, INCLUDING THE WARRANTY OF DESIGN, MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. Choice of Law This license is governed by the Laws of France. ---------------------------------------------------------------------- GNU LIBRARY GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1991 Free Software Foundation, Inc. 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the library GPL. It is numbered 2 because it goes with version 2 of the ordinary GPL.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Library General Public License, applies to some specially designated Free Software Foundation software, and to any other libraries whose authors decide to use it. You can use it for your libraries, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library, or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link a program with the library, you must provide complete object files to the recipients so that they can relink them with the library, after making changes to the library and recompiling it. And you must show them these terms so they know their rights. Our method of protecting your rights has two steps: (1) copyright the library, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the library. Also, for each distributor's protection, we want to make certain that everyone understands that there is no warranty for this free library. If the library is modified by someone else and passed on, we want its recipients to know that what they have is not the original version, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that companies distributing free software will individually obtain patent licenses, thus in effect transforming the program into proprietary software. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License, which was designed for utility programs. This license, the GNU Library General Public License, applies to certain designated libraries. This license is quite different from the ordinary one; be sure to read it in full, and don't assume that anything in it is the same as in the ordinary license. The reason we have a separate public license for some libraries is that they blur the distinction we usually make between modifying or adding to a program and simply using it. Linking a program with a library, without changing the library, is in some sense simply using the library, and is analogous to running a utility program or application program. However, in a textual and legal sense, the linked executable is a combined work, a derivative of the original library, and the ordinary General Public License treats it as such. Because of this blurred distinction, using the ordinary General Public License for libraries did not effectively promote software sharing, because most developers did not use the libraries. We concluded that weaker conditions might promote sharing better. However, unrestricted linking of non-free programs would deprive the users of those programs of all benefit from the free status of the libraries themselves. This Library General Public License is intended to permit developers of non-free programs to use free libraries, while preserving your freedom as a user of such programs to change the free libraries that are incorporated in them. (We have not seen how to achieve this as regards changes in header files, but we have achieved it as regards changes in the actual functions of the Library.) The hope is that this will lead to faster development of free libraries. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, while the latter only works together with the library. Note that it is possible for a library to be covered by the ordinary General Public License rather than by this special one. GNU LIBRARY GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Library General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also compile or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. c) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. d) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Library General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! mingw-ocaml/ocaml/configure0000755000175000017500000015002612124403240015370 0ustar tootstoots#! /bin/sh ######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file LICENSE. # # # ######################################################################### # $Id$ configure_options="$*" prefix=/usr/local bindir='' libdir='' mandir='' manext=1 host_type=unknown ccoption='' asoption='' asppoption='' cclibs='' curseslibs='' mathlib='-lm' dllib='' x11_include_dir='' x11_lib_dir='' graph_wanted=yes tk_wanted=yes pthread_wanted=yes tk_defs='' tk_libs='' tk_x11=yes dl_defs='' verbose=no withcurses=yes debugruntime=noruntimed withsharedlibs=yes gcc_warnings="-Wall" partialld="ld -r" withcamlp4=camlp4 # Try to turn internationalization off, can cause config.guess to malfunction! unset LANG unset LC_ALL LC_CTYPE LC_COLLATE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME # Turn off some MacOS X debugging stuff, same reason unset RC_TRACE_ARCHIVES RC_TRACE_DYLIBS RC_TRACE_PREBINDING_DISABLED # Parse command-line arguments while : ; do case "$1" in "") break;; -prefix|--prefix) prefix=$2; shift;; -bindir|--bindir) bindir=$2; shift;; -libdir|--libdir) libdir=$2; shift;; -mandir|--mandir) case "$2" in */man[1-9ln]) mandir=`echo $2 | sed -e 's|^\(.*\)/man.$|\1|'` manext=`echo $2 | sed -e 's/^.*\(.\)$/\1/'`;; *) mandir=$2 manext=1;; esac shift;; -host*|--host*) host_type=$2; shift;; -cc*) ccoption="$2"; shift;; -as) asoption="$2"; shift;; -aspp) asppoption="$2"; shift;; -lib*) cclibs="$2 $cclibs"; shift;; -no-curses|--no-curses) withcurses=no;; -no-shared-libs|--no-shared-libs) withsharedlibs=no;; -x11include*|--x11include*) x11_include_dir=$2; shift;; -x11lib*|--x11lib*) x11_lib_dir=$2; shift;; -no-graph|--no-graph) graph_wanted=no;; -with-pthread*|--with-pthread*) ;; # Ignored for backward compatibility -no-pthread*|--no-pthread*) pthread_wanted=no;; -no-tk|--no-tk) tk_wanted=no;; -partialld|--partialld) partialld="$2"; shift;; -tkdefs*|--tkdefs*) tk_defs=$2; shift;; -tklibs*|--tklibs*) tk_libs=$2; shift;; -tk-no-x11|--tk-no-x11) tk_x11=no;; -dldefs*|--dldefs*) dl_defs="$2"; shift;; -dllibs*|--dllibs*) dllib="$2"; shift;; -verbose|--verbose) verbose=yes;; -with-debug-runtime|--with-debug-runtime) debugruntime=runtimed;; -no-camlp4|--no-camlp4) withcamlp4="";; *) echo "Unknown option \"$1\"." 1>&2; exit 2;; esac shift done # Sanity checks case "$prefix" in /*) ;; *) echo "The -prefix directory must be absolute." 1>&2; exit 2;; esac case "$bindir" in /*) ;; "") ;; '$(PREFIX)/'*) ;; *) echo 'The -bindir directory must be absolute or relative to $(PREFIX).'>&2 exit 2;; esac case "$libdir" in /*) ;; "") ;; '$(PREFIX)/'*) ;; *) echo 'The -libdir directory must be absolute or relative to $(PREFIX).'>&2 exit 2;; esac case "$mandir" in /*) ;; "") ;; '$(PREFIX)/'*) ;; *) echo 'The -mandir directory must be absolute or relative to $(PREFIX).'>&2 exit 2;; esac # Generate the files cd config/auto-aux rm -f s.h m.h Makefile touch s.h m.h Makefile # Write options to Makefile echo "# generated by ./configure $configure_options" >> Makefile # Where to install echo "PREFIX=$prefix" >> Makefile case "$bindir" in "") echo 'BINDIR=$(PREFIX)/bin' >> Makefile bindir="$prefix/bin";; *) echo "BINDIR=$bindir" >> Makefile;; esac case "$libdir" in "") echo 'LIBDIR=$(PREFIX)/lib/ocaml' >> Makefile libdir="$prefix/lib/ocaml";; *) echo "LIBDIR=$libdir" >> Makefile;; esac echo 'STUBLIBDIR=$(LIBDIR)/stublibs' >> Makefile case "$mandir" in "") echo 'MANDIR=$(PREFIX)/man' >> Makefile mandir="$prefix/man";; *) echo "MANDIR=$mandir" >> Makefile;; esac echo "MANEXT=$manext" >> Makefile # Determine the system type if test "$host_type" = "unknown"; then if host_type=`../gnu/config.guess`; then :; else echo "Cannot guess host type" echo "You must specify one with the -host option" exit 2 fi fi if host=`../gnu/config.sub $host_type`; then :; else echo "Please specify the correct host type with the -host option" exit 2 fi echo "Configuring for a $host ..." # Do we have gcc? if test -z "$ccoption"; then if sh ./searchpath gcc; then echo "gcc found" cc=gcc else cc=cc fi else cc="$ccoption" fi # Check for buggy versions of GCC buggycc="no" case "$host,$cc" in i[3456]86-*-*,gcc*) case `$cc --version` in 2.7.2.1) cat <<'EOF' WARNING: you are using gcc version 2.7.2.1 on an Intel x86 processor. This version of gcc is known to generate incorrect code for the OCaml runtime system on some Intel x86 machines. (The symptom is a crash of boot/ocamlc when compiling stdlib/pervasives.mli.) In particular, the version of gcc 2.7.2.1 that comes with Linux RedHat 4.x / Intel is affected by this problem. Other Linux distributions might also be affected. If you are using one of these configurations, you are strongly advised to use another version of gcc, such as 2.95, which are known to work well with OCaml. Press to proceed or to stop. EOF read reply;; 2.96*) cat <<'EOF' WARNING: you are using gcc version 2.96 on an Intel x86 processor. Certain patched versions of gcc 2.96 are known to generate incorrect code for the OCaml runtime system. (The symptom is a segmentation violation on boot/ocamlc.) Those incorrectly patched versions can be found in RedHat 7.2 and Mandrake 8.0 and 8.1; other Linux distributions might also be affected. (See bug #57760 on bugzilla.redhat.com) Auto-configuration will now select gcc compiler flags that work around the problem. Still, if you observe segmentation faults while running ocamlc or ocamlopt, you are advised to try another version of gcc, such as 2.95.3 or 3.2. EOF buggycc="gcc.2.96";; esac;; esac # Configure the bytecode compiler bytecc="$cc" mkexe="\$(BYTECC)" mkexedebugflag="-g" bytecccompopts="" bytecclinkopts="" dllccompopts="" ostype="Unix" exe="" iflexdir="" case "$bytecc,$host" in cc,*-*-nextstep*) # GNU C extensions disabled, but __GNUC__ still defined! bytecccompopts="-fno-defer-pop $gcc_warnings -U__GNUC__ -posix" bytecclinkopts="-posix";; *,*-*-rhapsody*) # Almost the same as NeXTStep bytecccompopts="-fno-defer-pop $gcc_warnings -DSHRINKED_GNUC" mathlib="";; *,*-*-darwin*) bytecccompopts="-fno-defer-pop $gcc_warnings" mathlib="" # Tell gcc that we can use 32-bit code addresses for threaded code # unless we are compiled for a shared library (-fPIC option) echo "#ifndef __PIC__" >> m.h echo "# define ARCH_CODE32" >> m.h echo "#endif" >> m.h;; *,*-*-beos*) bytecccompopts="-fno-defer-pop $gcc_warnings" # No -lm library mathlib="";; gcc,alpha*-*-osf*) bytecccompopts="-fno-defer-pop $gcc_warnings" if cc="$bytecc" sh ./hasgot -mieee; then bytecccompopts="-mieee $bytecccompopts"; fi # Put code and static data in lower 4GB bytecclinkopts="-Wl,-T,12000000 -Wl,-D,14000000" # Tell gcc that we can use 32-bit code addresses for threaded code echo "#define ARCH_CODE32" >> m.h;; cc,alpha*-*-osf*) bytecccompopts="-std1 -ieee";; gcc,alpha*-*-linux*) if cc="$bytecc" sh ./hasgot -mieee; then bytecccompopts="-mieee $bytecccompopts"; fi;; cc,mips-*-irix6*) # Add -n32 flag to ensure compatibility with native-code compiler bytecccompopts="-n32" # Turn off warning "unused library" bytecclinkopts="-n32 -Wl,-woff,84";; cc*,mips-*-irix6*) # (For those who want to force "cc -64") # Turn off warning "unused library" bytecclinkopts="-Wl,-woff,84";; *,alpha*-*-unicos*) # For the Cray T3E bytecccompopts="-DUMK";; gcc*,powerpc-*-aix*) # Avoid name-space pollution by requiring Unix98-conformant includes bytecccompopts="-fno-defer-pop $gcc_warnings -D_XOPEN_SOURCE=500";; *,powerpc-*-aix*) bytecccompopts="-D_XOPEN_SOURCE=500";; gcc*,*-*-cygwin*) bytecccompopts="-fno-defer-pop $gcc_warnings -U_WIN32" dllccompopts="-U_WIN32 -DCAML_DLL" if test $withsharedlibs = yes; then flexlink="flexlink -chain cygwin -merge-manifest -stack 16777216" flexdir=`$flexlink -where | dos2unix` if test -z "$flexdir"; then echo "flexlink not found: native shared libraries won't be available" withsharedlibs=no else iflexdir="-I\"$flexdir\"" mkexe="$flexlink -exe" mkexedebugflag="-link -g" fi fi exe=".exe" ostype="Cygwin";; gcc*,x86_64-*-linux*) bytecccompopts="-fno-defer-pop $gcc_warnings" # Tell gcc that we can use 32-bit code addresses for threaded code # unless we are compiled for a shared library (-fPIC option) echo "#ifndef __PIC__" >> m.h echo "# define ARCH_CODE32" >> m.h echo "#endif" >> m.h;; gcc*) bytecccompopts="-fno-defer-pop $gcc_warnings";; esac # Configure compiler to use in further tests cc="$bytecc -O $bytecclinkopts" export cc cclibs verbose # Check C compiler sh ./runtest ansi.c case $? in 0) echo "The C compiler is ANSI-compliant.";; 1) echo "The C compiler $cc is not ANSI-compliant." echo "You need an ANSI C compiler to build OCaml." exit 2;; *) echo "Unable to compile the test program." echo "Make sure the C compiler $cc is properly installed." exit 2;; esac # Check the sizes of data types echo "Checking the sizes of integers and pointers..." set `sh ./runtest sizes.c` case "$2,$3" in 4,4) echo "OK, this is a regular 32 bit architecture." echo "#undef ARCH_SIXTYFOUR" >> m.h arch64=false;; *,8) echo "Wow! A 64 bit architecture!" echo "#define ARCH_SIXTYFOUR" >> m.h arch64=true;; *,*) echo "This architecture seems to be neither 32 bits nor 64 bits." echo "OCaml won't run on this architecture." exit 2;; *) echo "Unable to compile the test program." echo "Make sure the C compiler $cc is properly installed." exit 2;; esac if test $1 != 4 && test $2 != 4 && test $4 != 4; then echo "Sorry, we can't find a 32-bit integer type" echo "(sizeof(short) = $4, sizeof(int) = $1, sizeof(long) = $2)" echo "OCaml won't run on this architecture." exit 2 fi echo "#define SIZEOF_INT $1" >> m.h echo "#define SIZEOF_LONG $2" >> m.h echo "#define SIZEOF_PTR $3" >> m.h echo "#define SIZEOF_SHORT $4" >> m.h if test $2 = 8; then echo "#define ARCH_INT64_TYPE long" >> m.h echo "#define ARCH_UINT64_TYPE unsigned long" >> m.h echo '#define ARCH_INT64_PRINTF_FORMAT "l"' >> m.h int64_native=true else sh ./runtest longlong.c case $? in 0) echo "64-bit \"long long\" integer type found (printf with \"%ll\")." echo "#define ARCH_INT64_TYPE long long" >> m.h echo "#define ARCH_UINT64_TYPE unsigned long long" >> m.h echo '#define ARCH_INT64_PRINTF_FORMAT "ll"' >> m.h int64_native=true;; 1) echo "64-bit \"long long\" integer type found (printf with \"%q\")." echo "#define ARCH_INT64_TYPE long long" >> m.h echo "#define ARCH_UINT64_TYPE unsigned long long" >> m.h echo '#define ARCH_INT64_PRINTF_FORMAT "q"' >> m.h int64_native=true;; 2) echo "64-bit \"long long\" integer type found (but no printf)." echo "#define ARCH_INT64_TYPE long long" >> m.h echo "#define ARCH_UINT64_TYPE unsigned long long" >> m.h echo '#undef ARCH_INT64_PRINTF_FORMAT' >> m.h int64_native=true;; *) echo "No suitable 64-bit integer type found, will use software emulation." echo "#undef ARCH_INT64_TYPE" >> m.h echo "#undef ARCH_UINT64_TYPE" >> m.h echo '#undef ARCH_INT64_PRINTF_FORMAT' >> m.h int64_native=false;; esac fi if test $3 = 8 && test $int64_native = false; then echo "This architecture has 64-bit pointers but no 64-bit integer type." echo "OCaml won't run on this architecture." exit 2 fi # Determine endianness sh ./runtest endian.c case $? in 0) echo "This is a big-endian architecture." echo "#define ARCH_BIG_ENDIAN" >> m.h;; 1) echo "This is a little-endian architecture." echo "#undef ARCH_BIG_ENDIAN" >> m.h;; 2) echo "This architecture seems to be neither big endian nor little endian." echo "OCaml won't run on this architecture." exit 2;; *) echo "Something went wrong during endianness determination." echo "You'll have to figure out endianness yourself" echo "(option ARCH_BIG_ENDIAN in m.h).";; esac # Determine alignment constraints case "$host" in sparc*-*-*|hppa*-*-*|arm*-*-*|mips*-*-*) # On Sparc V9 with certain versions of gcc, determination of double # alignment is not reliable (PR#1521), hence force it. # Same goes for hppa. # PR#5088 suggests same problem on ARM. # PR#5280 reports same problem on MIPS. # But there's a knack (PR#2572): # if we're in 64-bit mode (sizeof(long) == 8), # we must not doubleword-align floats... if test $2 = 8; then echo "Doubles can be word-aligned." echo "#undef ARCH_ALIGN_DOUBLE" >> m.h else echo "Doubles must be doubleword-aligned." echo "#define ARCH_ALIGN_DOUBLE" >> m.h fi;; *) sh ./runtest dblalign.c case $? in 0) echo "Doubles can be word-aligned." echo "#undef ARCH_ALIGN_DOUBLE" >> m.h;; 1) echo "Doubles must be doubleword-aligned." echo "#define ARCH_ALIGN_DOUBLE" >> m.h;; *) echo "Something went wrong during alignment determination for doubles." echo "I'm going to assume this architecture has alignment constraints over doubles." echo "That's a safe bet: OCaml will work even if" echo "this architecture has actually no alignment constraints." echo "#define ARCH_ALIGN_DOUBLE" >> m.h;; esac;; esac if $int64_native; then case "$host" in # PR#5088: autodetection is unreliable on ARM. PR#5280: also on MIPS. sparc*-*-*|hppa*-*-*|arm*-*-*|mips*-*-*) if test $2 = 8; then echo "64-bit integers can be word-aligned." echo "#undef ARCH_ALIGN_INT64" >> m.h else echo "64-bit integers must be doubleword-aligned." echo "#define ARCH_ALIGN_INT64" >> m.h fi;; *) sh ./runtest int64align.c case $? in 0) echo "64-bit integers can be word-aligned." echo "#undef ARCH_ALIGN_INT64" >> m.h;; 1) echo "64-bit integers must be doubleword-aligned." echo "#define ARCH_ALIGN_INT64" >> m.h;; *) echo "Something went wrong during alignment determination for 64-bit integers." echo "I'm going to assume this architecture has alignment constraints." echo "That's a safe bet: OCaml will work even if" echo "this architecture has actually no alignment constraints." echo "#define ARCH_ALIGN_INT64" >> m.h;; esac esac else echo "#undef ARCH_ALIGN_INT64" >> m.h fi # Check semantics of division and modulus sh ./runtest divmod.c case $? in 0) echo "Native division and modulus have round-towards-zero semantics, will use them." echo "#undef NONSTANDARD_DIV_MOD" >> m.h;; 1) echo "Native division and modulus do not have round-towards-zero semantics, will use software emulation." echo "#define NONSTANDARD_DIV_MOD" >> m.h;; *) echo "Something went wrong while checking native division and modulus, please report it." echo "#define NONSTANDARD_DIV_MOD" >> m.h;; esac # Shared library support shared_libraries_supported=false dl_needs_underscore=false sharedcccompopts='' mksharedlib='' byteccrpath='' mksharedlibrpath='' natdynlinkopts="" if test $withsharedlibs = "yes"; then case "$host" in *-*-cygwin*) mksharedlib="$flexlink" mkmaindll="$flexlink -maindll" shared_libraries_supported=true;; *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-openbsd*|*-*-netbsd*|*-*-gnu*) sharedcccompopts="-fPIC" mksharedlib="$bytecc -shared" bytecclinkopts="$bytecclinkopts -Wl,-E" byteccrpath="-Wl,-rpath," mksharedlibrpath="-Wl,-rpath," natdynlinkopts="-Wl,-E" shared_libraries_supported=true;; alpha*-*-osf*) case "$bytecc" in gcc*) sharedcccompopts="-fPIC" mksharedlib="$bytecc -shared" byteccrpath="-Wl,-rpath," mksharedlibrpath="-Wl,-rpath," shared_libraries_supported=true;; cc*) sharedcccompopts="" mksharedlib="ld -shared -expect_unresolved '*'" byteccrpath="-Wl,-rpath," mksharedlibrpath="-rpath " shared_libraries_supported=true;; esac;; *-*-solaris2*) case "$bytecc" in gcc*) sharedcccompopts="-fPIC" if sh ./solaris-ld; then mksharedlib="$bytecc -shared" byteccrpath="-R" mksharedlibrpath="-R" else mksharedlib="$bytecc -shared" bytecclinkopts="$bytecclinkopts -Wl,-E" natdynlinkopts="-Wl,-E" byteccrpath="-Wl,-rpath," mksharedlibrpath="-Wl,-rpath," fi shared_libraries_supported=true;; *) sharedcccompopts="-KPIC" byteccrpath="-R" mksharedlibrpath="-R" mksharedlib="/usr/ccs/bin/ld -G" shared_libraries_supported=true;; esac;; mips*-*-irix[56]*) case "$bytecc" in cc*) sharedcccompopts="";; gcc*) sharedcccompopts="-fPIC";; esac mksharedlib="ld -shared -rdata_shared" byteccrpath="-Wl,-rpath," mksharedlibrpath="-rpath " shared_libraries_supported=true;; i[3456]86-*-darwin[89].*) mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress -read_only_relocs suppress" bytecccompopts="$dl_defs $bytecccompopts" dl_needs_underscore=false shared_libraries_supported=true;; *-apple-darwin*) mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress" bytecccompopts="$dl_defs $bytecccompopts" dl_needs_underscore=false shared_libraries_supported=true;; m88k-*-openbsd*) shared_libraries_supported=false;; vax-*-openbsd*) shared_libraries_supported=false;; *-*-openbsd*) sharedcccompopts="-fPIC" mksharedlib="$bytecc -shared" bytecclinkopts="$bytecclinkopts -Wl,-E" natdynlinkopts="-Wl,-E" byteccrpath="-Wl,-rpath," mksharedlibrpath="-Wl,-rpath," shared_libraries_supported=true;; esac fi if test -z "$mkmaindll"; then mkmaindll=$mksharedlib fi # Configure native dynlink natdynlink=false if test $withsharedlibs = "yes"; then case "$host" in *-*-cygwin*) natdynlink=true;; i[3456]86-*-linux*) natdynlink=true;; i[3456]86-*-gnu*) natdynlink=true;; x86_64-*-linux*) natdynlink=true;; i[3456]86-*-darwin[89].*) natdynlink=true;; i[3456]86-*-darwin*) if test $arch64 == true; then natdynlink=true fi;; x86_64-*-darwin*) natdynlink=true;; powerpc*-*-linux*) natdynlink=true;; sparc*-*-linux*) natdynlink=true;; i686-*-kfreebsd*) natdynlink=true;; x86_64-*-kfreebsd*) natdynlink=true;; i[345]86-*-freebsd*) natdynlink=true;; x86_64-*-freebsd*) natdynlink=true;; i[345]86-*-openbsd*) natdynlink=true;; x86_64-*-openbsd*) natdynlink=true;; i[345]86-*-netbsd*) natdynlink=true;; x86_64-*-netbsd*) natdynlink=true;; i386-*-gnu0.3) natdynlink=true;; arm*-*-linux*) natdynlink=true;; esac fi if test $natdynlink = "true"; then cmxs="cmxs" else cmxs="cmxa" fi # Configure the native-code compiler arch=none model=default system=unknown case "$host" in sparc*-*-solaris2.*) arch=sparc; system=solaris;; sparc*-*-*bsd*) arch=sparc; system=bsd;; sparc*-*-linux*) arch=sparc; system=linux;; sparc*-*-gnu*) arch=sparc; system=gnu;; i[3456]86-*-linux*) arch=i386; system=linux_`sh ./runtest elf.c`;; i[3456]86-*-*bsd*) arch=i386; system=bsd_`sh ./runtest elf.c`;; i[3456]86-*-nextstep*) arch=i386; system=nextstep;; i[3456]86-*-solaris*) if $arch64; then arch=amd64; system=solaris else arch=i386; system=solaris fi;; i[3456]86-*-beos*) arch=i386; system=beos;; i[3456]86-*-cygwin*) arch=i386; system=cygwin;; i[3456]86-*-darwin*) if $arch64; then arch=amd64; system=macosx else arch=i386; system=macosx fi;; i[3456]86-*-gnu*) arch=i386; system=gnu;; powerpc*-*-linux*) arch=power; model=ppc; system=elf;; powerpc-*-netbsd*) arch=power; model=ppc; system=elf;; powerpc-*-rhapsody*) arch=power; model=ppc; system=rhapsody;; powerpc-*-darwin*) arch=power; system=rhapsody if $arch64; then model=ppc64; else model=ppc; fi;; arm*-*-linux-gnueabihf) arch=arm; system=linux_eabihf;; armv7*-*-linux-gnueabi) arch=arm; model=armv7; system=linux_eabi;; armv6t2*-*-linux-gnueabi) arch=arm; model=armv6t2; system=linux_eabi;; armv6*-*-linux-gnueabi) arch=arm; model=armv6; system=linux_eabi;; armv5te*-*-linux-gnueabi) arch=arm; model=armv5te; system=linux_eabi;; armv5*-*-linux-gnueabi) arch=arm; model=armv5; system=linux_eabi;; arm*-*-linux-gnueabi) arch=arm; system=linux_eabi;; x86_64-*-linux*) arch=amd64; system=linux;; x86_64-*-gnu*) arch=amd64; system=gnu;; x86_64-*-freebsd*) arch=amd64; system=freebsd;; x86_64-*-netbsd*) arch=amd64; system=netbsd;; x86_64-*-openbsd*) arch=amd64; system=openbsd;; x86_64-*-darwin*) arch=amd64; system=macosx;; esac # Some platforms exist both in 32-bit and 64-bit variants, not distinguished # by $host. Turn off native code compilation on platforms where 64-bit mode # is not supported. (PR#4441) if $arch64; then case "$arch,$model" in sparc,default|power,ppc) arch=none; model=default; system=unknown;; esac fi if test -z "$ccoption"; then nativecc="$bytecc" else nativecc="$ccoption" fi nativecccompopts='' nativecclinkopts='' nativeccrpath="$byteccrpath" case "$arch,$nativecc,$system,$host_type" in *,*,nextstep,*) nativecccompopts="$gcc_warnings -U__GNUC__ -posix" nativecclinkopts="-posix";; *,*,rhapsody,*darwin[1-5].*) nativecccompopts="$gcc_warnings -DSHRINKED_GNUC";; *,*,rhapsody,*) nativecccompopts="$gcc_warnings -DDARWIN_VERSION_6 $dl_defs" if $arch64; then partialld="ld -r -arch ppc64"; fi;; *,gcc*,cygwin,*) nativecccompopts="$gcc_warnings -U_WIN32";; amd64,gcc*,macosx,*) partialld="ld -r -arch x86_64";; amd64,gcc*,solaris,*) partialld="ld -r -m elf_x86_64";; *,gcc*,*,*) nativecccompopts="$gcc_warnings";; esac asppprofflags='-DPROFILING' case "$arch,$model,$system" in amd64,*,macosx) as='as -arch x86_64' aspp='gcc -arch x86_64 -c';; amd64,*,solaris) as='as --64' aspp='gcc -m64 -c';; amd64,*,*) as='as' aspp='gcc -c';; arm,*,*) as='as'; aspp='gcc -c';; i386,*,solaris) as='as' aspp='/usr/ccs/bin/as -P';; i386,*,*) as='as' aspp='gcc -c';; power,*,elf) as='as -u -m ppc' aspp='gcc -c';; power,*,bsd) as='as' aspp='gcc -c';; power,*,rhapsody) as="as -arch $model" aspp="$bytecc -c";; sparc,*,solaris) as='as' case "$cc" in gcc*) aspp='gcc -c';; *) aspp='as -P';; esac;; sparc,*,*) as='as' aspp='gcc -c';; esac if test -n "$asoption"; then as="$asoption"; fi if test -n "$asppoption"; then aspp="$asppoption"; fi cc_profile='-pg' case "$arch,$model,$system" in i386,*,linux_elf) profiling='prof';; i386,*,gnu) profiling='prof';; i386,*,bsd_elf) profiling='prof';; amd64,*,macosx) profiling='prof';; i386,*,macosx) profiling='prof';; sparc,*,solaris) profiling='prof' case "$nativecc" in gcc*) ;; *) cc_profile='-xpg';; esac;; amd64,*,linux) profiling='prof';; amd64,*,gnu) profiling='prof';; arm,*,linux*) profiling='prof';; *) profiling='noprof';; esac # Where is ranlib? if sh ./searchpath ranlib; then echo "ranlib found" echo "RANLIB=ranlib" >> Makefile echo "RANLIBCMD=ranlib" >> Makefile else echo "ranlib not used" echo "RANLIB=ar rs" >> Makefile echo "RANLIBCMD=" >> Makefile fi echo "ARCMD=ar" >> Makefile # Do #! scripts work? if (SHELL=/bin/sh; export SHELL; (./sharpbang || ./sharpbang2) >/dev/null); then echo "#! appears to work in shell scripts" case "$host" in *-*-sunos*|*-*-unicos*) echo "We won't use it, though, because under SunOS and Unicos it breaks" echo "on pathnames longer than 30 characters" echo "SHARPBANGSCRIPTS=false" >> Makefile;; *-*-cygwin*) echo "We won't use it, though, because of conflicts with .exe extension" echo "under Cygwin" echo "SHARPBANGSCRIPTS=false" >> Makefile;; *) echo "SHARPBANGSCRIPTS=true" >> Makefile;; esac else echo "No support for #! in shell scripts" echo "SHARPBANGSCRIPTS=false" >> Makefile fi # Write the OS type (Unix or Cygwin) echo "#define OCAML_OS_TYPE \"$ostype\"" >> s.h echo "#define OCAML_STDLIB_DIR \"$libdir\"" >> s.h # Use 64-bit file offset if possible bytecccompopts="$bytecccompopts -D_FILE_OFFSET_BITS=64" nativecccompopts="$nativecccompopts -D_FILE_OFFSET_BITS=64" # Check the semantics of signal handlers if sh ./hasgot sigaction sigprocmask; then echo "POSIX signal handling found." echo "#define POSIX_SIGNALS" >> s.h else if sh ./runtest signals.c; then echo "Signals have the BSD semantics." echo "#define BSD_SIGNALS" >> s.h else echo "Signals have the System V semantics." fi if sh ./hasgot sigsetmask; then echo "sigsetmask() found" echo "#define HAS_SIGSETMASK" >> s.h fi fi # For the Pervasives module if sh ./hasgot2 -i math.h $mathlib expm1 log1p hypot copysign; then echo "expm1(), log1p(), hypot(), copysign() found." echo "#define HAS_C99_FLOAT_OPS" >> s.h fi # For the Sys module if sh ./hasgot getrusage; then echo "getrusage() found." echo "#define HAS_GETRUSAGE" >> s.h fi if sh ./hasgot times; then echo "times() found." echo "#define HAS_TIMES" >> s.h fi # For the terminfo module if test "$withcurses" = "yes"; then for libs in "" "-lcurses" "-ltermcap" "-lcurses -ltermcap" "-lncurses"; do if sh ./hasgot $libs tgetent tgetstr tgetnum tputs; then echo "termcap functions found (with libraries '$libs')" echo "#define HAS_TERMCAP" >> s.h curseslibs="${libs}" break fi done fi # Configuration for the libraries otherlibraries="unix str num dynlink bigarray" # For the Unix library has_sockets=no if sh ./hasgot socket socketpair bind listen accept connect; then echo "You have BSD sockets." echo "#define HAS_SOCKETS" >> s.h has_sockets=yes elif sh ./hasgot -lnsl -lsocket socket socketpair bind listen accept connect; then echo "You have BSD sockets (with libraries '-lnsl -lsocket')" cclibs="$cclibs -lnsl -lsocket" echo "#define HAS_SOCKETS" >> s.h has_sockets=yes fi if sh ./hasgot -i sys/socket.h -t socklen_t; then echo "socklen_t is defined in " echo "#define HAS_SOCKLEN_T" >> s.h fi if sh ./hasgot inet_aton; then echo "inet_aton() found." echo "#define HAS_INET_ATON" >> s.h fi if sh ./hasgot -i sys/types.h -i sys/socket.h -i netinet/in.h \ -t 'struct sockaddr_in6' \ && sh ./hasgot getaddrinfo getnameinfo inet_pton inet_ntop; then echo "IPv6 is supported." echo "#define HAS_IPV6" >> s.h fi if sh ./hasgot -i unistd.h; then echo "unistd.h found." echo "#define HAS_UNISTD" >> s.h fi if sh ./hasgot -i sys/types.h -t off_t; then echo "off_t is defined in " echo "#define HAS_OFF_T" >> s.h fi if sh ./hasgot -i sys/types.h -i dirent.h; then echo "dirent.h found." echo "#define HAS_DIRENT" >> s.h fi if sh ./hasgot rewinddir; then echo "rewinddir() found." echo "#define HAS_REWINDDIR" >> s.h fi if sh ./hasgot lockf; then echo "lockf() found." echo "#define HAS_LOCKF" >> s.h fi if sh ./hasgot mkfifo; then echo "mkfifo() found." echo "#define HAS_MKFIFO" >> s.h fi if sh ./hasgot getcwd; then echo "getcwd() found." echo "#define HAS_GETCWD" >> s.h fi if sh ./hasgot getwd; then echo "getwd() found." echo "#define HAS_GETWD" >> s.h fi if sh ./hasgot getpriority setpriority; then echo "getpriority() found." echo "#define HAS_GETPRIORITY" >> s.h fi if sh ./hasgot -i sys/types.h -i utime.h && sh ./hasgot utime; then echo "utime() found." echo "#define HAS_UTIME" >> s.h fi if sh ./hasgot utimes; then echo "utimes() found." echo "#define HAS_UTIMES" >> s.h fi if sh ./hasgot dup2; then echo "dup2() found." echo "#define HAS_DUP2" >> s.h fi if sh ./hasgot fchmod fchown; then echo "fchmod() found." echo "#define HAS_FCHMOD" >> s.h fi if sh ./hasgot truncate ftruncate; then echo "truncate() found." echo "#define HAS_TRUNCATE" >> s.h fi select_include='' if sh ./hasgot -i sys/types.h -i sys/select.h; then echo "sys/select.h found." echo "#define HAS_SYS_SELECT_H" >> s.h select_include='-i sys/select.h' fi has_select=no if sh ./hasgot select && \ sh ./hasgot -i sys/types.h $select_include -t fd_set ; then echo "select() found." echo "#define HAS_SELECT" >> s.h has_select=yes fi if sh ./hasgot symlink readlink lstat; then echo "symlink() found." echo "#define HAS_SYMLINK" >> s.h fi has_wait=no if sh ./hasgot waitpid; then echo "waitpid() found." echo "#define HAS_WAITPID" >> s.h has_wait=yes fi if sh ./hasgot wait4; then echo "wait4() found." echo "#define HAS_WAIT4" >> s.h has_wait=yes fi if sh ./hasgot -i limits.h && sh ./runtest getgroups.c; then echo "getgroups() found." echo "#define HAS_GETGROUPS" >> s.h fi if sh ./hasgot -i limits.h -i grp.h && sh ./runtest setgroups.c; then echo "setgroups() found." echo "#define HAS_SETGROUPS" >> s.h fi if sh ./hasgot -i limits.h -i grp.h && sh ./runtest initgroups.c; then echo "initgroups() found." echo "#define HAS_INITGROUPS" >> s.h fi if sh ./hasgot -i termios.h && sh ./hasgot tcgetattr tcsetattr tcsendbreak tcflush tcflow; then echo "POSIX termios found." echo "#define HAS_TERMIOS" >> s.h fi if sh ./runtest async_io.c; then echo "Asynchronous I/O are supported." echo "#define HAS_ASYNC_IO" >> s.h fi has_setitimer=no if sh ./hasgot setitimer; then echo "setitimer() found." echo "#define HAS_SETITIMER" >> s.h has_setitimer="yes" fi if sh ./hasgot gethostname; then echo "gethostname() found." echo "#define HAS_GETHOSTNAME" >> s.h fi if sh ./hasgot -i sys/utsname.h && sh ./hasgot uname; then echo "uname() found." echo "#define HAS_UNAME" >> s.h fi has_gettimeofday=no if sh ./hasgot gettimeofday; then echo "gettimeofday() found." echo "#define HAS_GETTIMEOFDAY" >> s.h has_gettimeofday="yes" fi if sh ./hasgot mktime; then echo "mktime() found." echo "#define HAS_MKTIME" >> s.h fi case "$host" in *-*-cygwin*) ;; # setsid emulation under Cygwin breaks the debugger *) if sh ./hasgot setsid; then echo "setsid() found." echo "#define HAS_SETSID" >> s.h fi;; esac if sh ./hasgot putenv; then echo "putenv() found." echo "#define HAS_PUTENV" >> s.h fi if sh ./hasgot -i locale.h && sh ./hasgot setlocale; then echo "setlocale() and found." echo "#define HAS_LOCALE" >> s.h fi if sh ./hasgot $dllib dlopen; then echo "dlopen() found." elif sh ./hasgot $dllib -ldl dlopen; then echo "dlopen() found in -ldl." dllib="$dllib -ldl" else shared_libraries_supported=false fi if $shared_libraries_supported; then echo "Dynamic loading of shared libraries is supported." echo "#define SUPPORT_DYNAMIC_LINKING" >> s.h if $dl_needs_underscore; then echo '#define DL_NEEDS_UNDERSCORE' >>s.h fi fi if sh ./hasgot -i sys/types.h -i sys/mman.h && sh ./hasgot mmap munmap; then echo "mmap() found." echo "#define HAS_MMAP" >> s.h fi if sh ./hasgot pwrite; then echo "pwrite() found" echo "#define HAS_PWRITE" >> s.h fi nargs=none for i in 5 6; do if sh ./trycompile -DNUM_ARGS=${i} gethostbyname.c; then nargs=$i; break; fi done if test $nargs != "none"; then echo "gethostbyname_r() found (with ${nargs} arguments)." echo "#define HAS_GETHOSTBYNAME_R $nargs" >> s.h fi nargs=none for i in 7 8; do if sh ./trycompile -DNUM_ARGS=${i} gethostbyaddr.c; then nargs=$i; break; fi done if test $nargs != "none"; then echo "gethostbyaddr_r() found (with ${nargs} arguments)." echo "#define HAS_GETHOSTBYADDR_R $nargs" >> s.h fi # Determine if the debugger is supported if test "$has_sockets" = "yes"; then echo "Replay debugger supported." debugger="ocamldebugger" else echo "No replay debugger (missing system calls)" debugger="" fi # Determine if system stack overflows can be detected case "$arch,$system" in i386,linux_elf|amd64,linux|power,rhapsody|amd64,macosx|i386,macosx) echo "System stack overflow can be detected." echo "#define HAS_STACK_OVERFLOW_DETECTION" >> s.h;; *) echo "Cannot detect system stack overflow.";; esac # Determine the target architecture for the "num" library case "$arch" in i386) bng_arch=ia32 if sh ./trycompile ia32sse2.c then bng_asm_level=2 else bng_asm_level=1 fi;; power) bng_arch=ppc; bng_asm_level=1;; amd64) bng_arch=amd64; bng_asm_level=1;; *) bng_arch=generic; bng_asm_level=0;; esac echo "BNG_ARCH=$bng_arch" >> Makefile echo "BNG_ASM_LEVEL=$bng_asm_level" >> Makefile # Determine if the POSIX threads library is supported systhread_support=false if test "$pthread_wanted" = "yes"; then case "$host" in *-*-solaris*) pthread_link="-lpthread -lposix4" pthread_caml_link="-cclib -lpthread -cclib -lposix4";; *-*-freebsd*) pthread_link="-pthread" pthread_caml_link="-cclib -pthread";; *-*-openbsd*) pthread_link="-pthread" pthread_caml_link="-cclib -pthread";; *) pthread_link="-lpthread" pthread_caml_link="-cclib -lpthread";; esac if ./hasgot -i pthread.h $pthread_link pthread_self; then echo "POSIX threads library supported." systhread_support=true otherlibraries="$otherlibraries systhreads" bytecccompopts="$bytecccompopts -D_REENTRANT" nativecccompopts="$nativecccompopts -D_REENTRANT" case "$host" in *-*-freebsd*) bytecccompopts="$bytecccompopts -D_THREAD_SAFE" nativecccompopts="$nativecccompopts -D_THREAD_SAFE";; *-*-openbsd*) bytecccompopts="$bytecccompopts -pthread" asppflags="$asppflags -pthread" nativecccompopts="$nativecccompopts -pthread";; esac echo "Options for linking with POSIX threads: $pthread_link" if sh ./hasgot $pthread_link sigwait; then echo "sigwait() found" echo "#define HAS_SIGWAIT" >> s.h fi else echo "POSIX threads not found." pthread_link="" fi else pthread_link="" fi echo "PTHREAD_LINK=$pthread_caml_link" >> Makefile # Determine if the bytecode thread library is supported if test "$has_select" = "yes" \ && test "$has_setitimer" = "yes" \ && test "$has_gettimeofday" = "yes" \ && test "$has_wait" = "yes"; then echo "Bytecode threads library supported." otherlibraries="$otherlibraries threads" else echo "Bytecode threads library not supported (missing system calls)" fi # Determine the location of X include files and libraries # If the user specified -x11include and/or -x11lib, these settings # are used. Otherwise, we check whether there is pkg-config, and take # the flags from there. Otherwise, we search the location. x11_include="not found" x11_link="not found" if test -z "$x11_include_dir" -a -z "$x11_lib_dir"; then if pkg-config --exists x11 2>/dev/null; then x11_include=`pkg-config --cflags x11` x11_link=`pkg-config --libs x11` fi fi if test "$x11_include" = "not found"; then for dir in \ $x11_include_dir \ \ /usr/X11R7/include \ /usr/include/X11R7 \ /usr/local/X11R7/include \ /usr/local/include/X11R7 \ /opt/X11R7/include \ \ /usr/X11R6/include \ /usr/include/X11R6 \ /usr/local/X11R6/include \ /usr/local/include/X11R6 \ /opt/X11R6/include \ \ /usr/X11/include \ /usr/include/X11 \ /usr/local/X11/include \ /usr/local/include/X11 \ /opt/X11/include \ \ /usr/X11R5/include \ /usr/include/X11R5 \ /usr/local/X11R5/include \ /usr/local/include/X11R5 \ /usr/local/x11r5/include \ /opt/X11R5/include \ \ /usr/X11R4/include \ /usr/include/X11R4 \ /usr/local/X11R4/include \ /usr/local/include/X11R4 \ \ /usr/X386/include \ /usr/x386/include \ /usr/XFree86/include/X11 \ \ /usr/include \ /usr/local/include \ /usr/unsupported/include \ /usr/athena/include \ /usr/lpp/Xamples/include \ \ /usr/openwin/include \ /usr/openwin/share/include \ ; \ do if test -f $dir/X11/X.h; then x11_include_dir=$dir x11_include="-I$dir" break fi done if test "$x11_include" = "not found"; then x11_try_lib_dir='' else x11_try_lib_dir=`echo $x11_include_dir | sed -e 's|include|lib|'` fi for dir in \ $x11_lib_dir \ $x11_try_lib_dir \ \ /usr/X11R6/lib64 \ /usr/X11R6/lib \ /usr/lib/X11R6 \ /usr/local/X11R6/lib \ /usr/local/lib/X11R6 \ /opt/X11R6/lib \ \ /usr/X11/lib \ /usr/lib/X11 \ /usr/local/X11/lib \ /usr/local/lib/X11 \ /opt/X11/lib \ \ /usr/X11R5/lib \ /usr/lib/X11R5 \ /usr/local/X11R5/lib \ /usr/local/lib/X11R5 \ /usr/local/x11r5/lib \ /opt/X11R5/lib \ \ /usr/X11R4/lib \ /usr/lib/X11R4 \ /usr/local/X11R4/lib \ /usr/local/lib/X11R4 \ \ /usr/X386/lib \ /usr/x386/lib \ /usr/XFree86/lib/X11 \ \ /usr/lib64 \ /usr/lib \ /usr/local/lib \ /usr/unsupported/lib \ /usr/athena/lib \ /usr/lpp/Xamples/lib \ /lib/usr/lib/X11 \ \ /usr/openwin/lib \ /usr/openwin/share/lib \ \ /usr/lib/i386-linux-gnu \ /usr/lib/x86_64-linux-gnu \ ; \ do if test -f $dir/libX11.a || \ test -f $dir/libX11.so || \ test -f $dir/libX11.dll.a || \ test -f $dir/libX11.dylib || \ test -f $dir/libX11.sa; then if test $dir = /usr/lib; then x11_link="-lX11" else x11_libs="-L$dir" case "$host" in *-kfreebsd*-gnu) x11_link="-L$dir -lX11";; *-*-*bsd*) x11_link="-R$dir -L$dir -lX11";; *) x11_link="-L$dir -lX11";; esac fi break fi done fi if test "x11_include" != "not found"; then if test "$x11_include" = "-I/usr/include"; then x11_include="" fi if ./hasgot $x11_include $x11_link -i X11/Xlib.h XrmInitialize; then echo "X11 works" else echo "Cannot compile X11 program" x11_include="not found" fi fi has_graph=false if test "$x11_include" = "not found" || test "$x11_link" = "not found" then echo "X11 not found, the \"graph\" library will not be supported." x11_include="not found" x11_link="not found" else echo "Options for compiling for X11: $x11_include" echo "Options for linking with X11: $x11_link" if test "$graph_wanted" = yes then has_graph=true otherlibraries="$otherlibraries graph" fi fi echo "X11_INCLUDES=$x11_include" >> Makefile echo "X11_LINK=$x11_link" >> Makefile # Look for tcl/tk echo "Configuring LablTk..." if test $tk_wanted = no; then has_tk=false elif test $tk_x11 = no; then has_tk=true elif test "$x11_include" = "not found" || test "$x11_link" = "not found"; then echo "X11 not found or disabled." has_tk=false else tk_x11_include="$x11_include" tk_x11_libs="$x11_link" has_tk=true fi if test $has_tk = true; then tcl_version='' tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` for tk_incs in \ "-I/usr/local/include" \ "-I/usr/include" \ "-I/usr/local/include/tcl8.5 -I/usr/local/include/tk8.5" \ "-I/usr/include/tcl8.5 -I/usr/include/tk8.5" \ "-I/usr/local/include/tcl8.4 -I/usr/local/include/tk8.4" \ "-I/usr/include/tcl8.4 -I/usr/include/tk8.4" \ "-I/usr/local/include/tcl8.3 -I/usr/local/include/tk8.3" \ "-I/usr/include/tcl8.3 -I/usr/include/tk8.3" \ "-I/usr/local/include/tcl8.2 -I/usr/local/include/tk8.2" \ "-I/usr/include/tcl8.2 -I/usr/include/tk8.2" \ "-I/sw/include" \ "-I/usr/pkg/include" do if test -z "$tcl_version"; then tk_defs="$tk_incs" tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` fi; done if test -n "$tcl_version" && test "x$tcl_version" != "xnone"; then echo "tcl.h and tk.h version $tcl_version found with \"$tk_defs\"." case $tcl_version in 8.5) tclmaj=8 tclmin=5 tkmaj=8 tkmin=5 ;; 8.4) tclmaj=8 tclmin=4 tkmaj=8 tkmin=4 ;; 8.3) tclmaj=8 tclmin=3 tkmaj=8 tkmin=3 ;; 8.2) tclmaj=8 tclmin=2 tkmaj=8 tkmin=2 ;; 8.1) tclmaj=8 tclmin=1 tkmaj=8 tkmin=1 ;; 8.0) tclmaj=8 tclmin=0 tkmaj=8 tkmin=0 ;; 7.6) tclmaj=7 tclmin=6 tkmaj=4 tkmin=2 ;; 7.5) tclmaj=7 tclmin=5 tkmaj=4 tkmin=1 ;; *) echo "This version is not known."; has_tk=false ;; esac else echo "tcl.h and/or tk.h not found." has_tk=false fi fi tkauxlibs="$mathlib $dllib" tcllib='' tklib='' if test $has_tk = true; then if test -n "$tk_libs" && \ sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tcl_DoOneEvent then tk_libs="$tk_libs $dllib" elif sh ./hasgot $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs Tcl_DoOneEvent then tk_libs="$tk_libs -ltk$tkmaj.$tkmin -ltcl$tclmaj.$tclmin $dllib" elif sh ./hasgot $tk_libs -ltcl$tclmaj$tclmin $tkauxlibs Tcl_DoOneEvent then tk_libs="$tk_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin $dllib" elif test -z "$tk_libs" && tk_libs=-L/usr/local/lib && \ sh ./hasgot $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs Tcl_DoOneEvent then tk_libs="$tk_libs -ltk$tkmaj.$tkmin -ltcl$tclmaj.$tclmin $dllib" elif sh ./hasgot $tk_libs -ltcl$tclmaj$tclmin $tkauxlibs Tcl_DoOneEvent then tk_libs="$tk_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin $dllib" elif sh ./hasgot -L/sw/lib $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs \ Tcl_DoOneEvent then tk_libs="-L/sw/lib -ltk$tkmaj.$tkmin -ltcl$tclmaj.$tclmin $dllib" elif sh ./hasgot -L/usr/pkg/lib $tk_libs $tk_x11_libs \ -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin -lpthread $tkauxlibs \ Tcl_DoOneEvent then case "$host" in *-*-*bsd*) tk_libs="-R/usr/pkg/lib -L/usr/pkg/lib $tk_libs $tk_x11_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin -lpthread $tkauxlibs";; *) tk_libs="-L/usr/pkg/lib $tk_libs $tk_x11_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin -lpthread $tkauxlibs";; esac else echo "Tcl library not found." has_tk=false fi fi if test $has_tk = true; then if sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid; then echo "Tcl/Tk libraries found." elif sh ./hasgot -L/sw/lib $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid; then case "$host" in *-*-*bsd*) tk_libs="-R/sw/lib -L/sw/lib $tk_libs";; *) tk_libs="-L/sw/lib $tk_libs";; esac echo "Tcl/Tk libraries found." elif sh ./hasgot -L/usr/pkg/lib $tk_libs $tk_x11_libs $tkauxlibs \ Tk_SetGrid; then case "$host" in *-*-*bsd*) tk_libs="-R/usr/pkg/lib -L/usr/pkg/lib $tk_libs";; *) tk_libs="-L/usr/pkg/lib $tk_libs";; esac echo "Tcl/Tk libraries found." else echo "Tcl library found." echo "Tk library not found." has_tk=false fi fi if test $has_tk = true; then if test $tk_x11 = yes; then echo "TK_DEFS=$tk_defs "'$(X11_INCLUDES)' >> Makefile echo "TK_LINK=$tk_libs "'$(X11_LINK)' >> Makefile else echo "TK_DEFS=$tk_defs" >> Makefile echo "TK_LINK=$tk_libs" >> Makefile fi otherlibraries="$otherlibraries labltk" else echo "Configuration failed, LablTk will not be built." echo "TK_DEFS=" >> Makefile echo "TK_LINK=" >> Makefile fi # Look for BFD library if ./hasgot -i bfd.h && \ ./hasgot -lbfd -ldl -liberty -lz bfd_openr; then echo "BFD library found." echo "#define HAS_LIBBFD" >> s.h echo "LIBBFD_LINK=-lbfd -ldl -liberty -lz" >> Makefile else echo "BFD library not found, 'objinfo' will be unable to display info on .cmxs files" echo "LIBBFD_LINK=" >> Makefile fi # Check whether assembler supports CFI directives asm_cfi_supported=false export as aspp if sh ./tryassemble cfi.S; then echo "#define ASM_CFI_SUPPORTED" >> m.h asm_cfi_supported=true echo "Assembler supports CFI" else echo "Assembler does not support CFI" fi # Final twiddling of compiler options to work around known bugs nativeccprofopts="$nativecccompopts" case "$buggycc" in gcc.2.96) bytecccompopts="$bytecccompopts -fomit-frame-pointer" nativecccompopts="$nativecccompopts -fomit-frame-pointer";; esac # Finish generated files cclibs="$cclibs $mathlib" echo "BYTECC=$bytecc" >> Makefile echo "BYTECCCOMPOPTS=$bytecccompopts" >> Makefile echo "BYTECCLINKOPTS=$bytecclinkopts" >> Makefile echo "BYTECCLIBS=$cclibs $dllib $curseslibs $pthread_link" >> Makefile echo "BYTECCRPATH=$byteccrpath" >> Makefile echo "EXE=$exe" >> Makefile echo "SUPPORTS_SHARED_LIBRARIES=$shared_libraries_supported" >> Makefile echo "SHAREDCCCOMPOPTS=$sharedcccompopts" >> Makefile echo "MKSHAREDLIBRPATH=$mksharedlibrpath" >> Makefile echo "NATDYNLINKOPTS=$natdynlinkopts" >> Makefile cat >> Makefile <> Makefile echo "MODEL=$model" >> Makefile echo "SYSTEM=$system" >> Makefile echo "NATIVECC=$nativecc" >> Makefile echo "NATIVECCCOMPOPTS=$nativecccompopts" >> Makefile echo "NATIVECCPROFOPTS=$nativeccprofopts" >> Makefile echo "NATIVECCLINKOPTS=$nativecclinkopts" >> Makefile echo "NATIVECCRPATH=$nativeccrpath" >> Makefile echo "NATIVECCLIBS=$cclibs $dllib" >> Makefile echo "ASM=$as" >> Makefile echo "ASPP=$aspp" >> Makefile echo "ASPPPROFFLAGS=$asppprofflags" >> Makefile echo "PROFILING=$profiling" >> Makefile echo "DYNLINKOPTS=$dllib" >> Makefile echo "OTHERLIBRARIES=$otherlibraries" >> Makefile echo "DEBUGGER=$debugger" >> Makefile echo "CC_PROFILE=$cc_profile" >> Makefile echo "SYSTHREAD_SUPPORT=$systhread_support" >> Makefile echo "PARTIALLD=$partialld" >> Makefile echo "PACKLD=\$(PARTIALLD) \$(NATIVECCLINKOPTS) -o " \ | sed -e 's/ $/\\ /' >> Makefile echo "DLLCCCOMPOPTS=$dllccompopts" >> Makefile echo "IFLEXDIR=$iflexdir" >> Makefile echo "O=o" >> Makefile echo "A=a" >> Makefile echo "SO=so" >> Makefile echo "EXT_OBJ=.o" >> Makefile echo "EXT_ASM=.s" >> Makefile echo "EXT_LIB=.a" >> Makefile echo "EXT_DLL=.so" >> Makefile echo "EXTRALIBS=" >> Makefile echo "CCOMPTYPE=cc" >> Makefile echo "TOOLCHAIN=cc" >> Makefile echo "NATDYNLINK=$natdynlink" >> Makefile echo "CMXS=$cmxs" >> Makefile echo "MKEXE=$mkexe" >> Makefile echo "MKEXEDEBUGFLAG=$mkexedebugflag" >> Makefile echo "MKDLL=$mksharedlib" >> Makefile echo "MKMAINDLL=$mkmaindll" >> Makefile echo "RUNTIMED=${debugruntime}" >>Makefile echo "CAMLP4=${withcamlp4}" >>Makefile echo "ASM_CFI_SUPPORTED=$asm_cfi_supported" >> Makefile rm -f tst hasgot.c rm -f ../m.h ../s.h ../Makefile mv m.h s.h Makefile .. # Print a summary echo echo "** Configuration summary **" echo echo "Directories where OCaml will be installed:" echo " binaries.................. $bindir" echo " standard library.......... $libdir" echo " manual pages.............. $mandir (with extension .$manext)" echo "Configuration for the bytecode compiler:" echo " C compiler used........... $bytecc" echo " options for compiling..... $bytecccompopts" echo " options for linking....... $bytecclinkopts $cclibs $dllib $curseslibs $pthread_link" if $shared_libraries_supported; then echo " shared libraries are supported" echo " options for compiling..... $sharedcccompopts $bytecccompopts" echo " command for building...... $mksharedlib -o lib.so $mksharedlibrpath/a/path objs" else echo " shared libraries not supported" fi echo "Configuration for the native-code compiler:" if test "$arch" = "none"; then echo " (not supported on this platform)" else if test "$model" = "default"; then echo " hardware architecture..... $arch" else echo " hardware architecture..... $arch ($model)" fi if test "$system" = "unknown"; then : ; else echo " OS variant................ $system" fi echo " C compiler used........... $nativecc" echo " options for compiling..... $nativecccompopts" echo " options for linking....... $nativecclinkopts $cclibs" echo " assembler ................ $as" echo " preprocessed assembler ... $aspp" if test "$asm_cfi_supported" = "true"; then echo " assembler supports CFI ... yes" else echo " assembler supports CFI ... no" fi echo " native dynlink ........... $natdynlink" if test "$profiling" = "prof"; then echo " profiling with gprof ..... supported" else echo " profiling with gprof ..... not supported" fi fi if test "$debugger" = "ocamldebugger"; then echo "Source-level replay debugger: supported" else echo "Source-level replay debugger: not supported" fi if test "$debugruntime" = "runtimed"; then echo "Debug runtime will be compiled and installed" fi echo "Additional libraries supported:" echo " $otherlibraries" echo "Configuration for the \"num\" library:" echo " target architecture ...... $bng_arch (asm level $bng_asm_level)" if $has_graph; then echo "Configuration for the \"graph\" library:" echo " options for compiling .... $x11_include" echo " options for linking ...... $x11_link" else echo "The \"graph\" library: not supported" fi if test $has_tk = true; then echo "Configuration for the \"labltk\" library:" echo " use tcl/tk version ....... $tcl_version" echo " options for compiling .... $tk_defs $tk_x11_include" echo " options for linking ...... $tk_libs $tk_x11_libs" else echo "The \"labltk\" library: not supported" fi echo echo "** OCaml configuration completed successfully **" echo if test ! -z "$MACOSX_DEPLOYMENT_TARGET"; then echo "WARNING: the environment variable MACOSX_DEPLOYMENT_TARGET is set." echo "This will probably prevent compiling the OCaml system." fi mingw-ocaml/ocaml/camlp4/0000755000175000017500000000000012124403240014635 5ustar tootstootsmingw-ocaml/ocaml/camlp4/.ignore0000644000175000017500000000002712124403240016120 0ustar tootstoots.cache-status *.tmp.ml mingw-ocaml/ocaml/camlp4/Camlp4Bin.ml0000644000175000017500000003244012124403240016743 0ustar tootstoots(* camlp4r *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) open Camlp4; open PreCast.Syntax; open PreCast; open Format; module CleanAst = Camlp4.Struct.CleanAst.Make Ast; module SSet = Set.Make String; value pa_r = "Camlp4OCamlRevisedParser"; value pa_rr = "Camlp4OCamlReloadedParser"; value pa_o = "Camlp4OCamlParser"; value pa_rp = "Camlp4OCamlRevisedParserParser"; value pa_op = "Camlp4OCamlParserParser"; value pa_g = "Camlp4GrammarParser"; value pa_m = "Camlp4MacroParser"; value pa_qb = "Camlp4QuotationCommon"; value pa_q = "Camlp4QuotationExpander"; value pa_rq = "Camlp4OCamlRevisedQuotationExpander"; value pa_oq = "Camlp4OCamlOriginalQuotationExpander"; value pa_l = "Camlp4ListComprehension"; open Register; value dyn_loader = ref (fun []); value rcall_callback = ref (fun () -> ()); value loaded_modules = ref SSet.empty; value add_to_loaded_modules name = loaded_modules.val := SSet.add name loaded_modules.val; value (objext,libext) = if DynLoader.is_native then (".cmxs",".cmxs") else (".cmo",".cma"); value rewrite_and_load n x = let dyn_loader = dyn_loader.val () in let find_in_path = DynLoader.find_in_path dyn_loader in let real_load name = do { add_to_loaded_modules name; DynLoader.load dyn_loader name } in let load = List.iter begin fun n -> if SSet.mem n loaded_modules.val || List.mem n Register.loaded_modules.val then () else begin add_to_loaded_modules n; DynLoader.load dyn_loader (n ^ objext); end end in do { match (n, String.lowercase x) with [ ("Parsers"|"", "pa_r.cmo" | "r" | "ocamlr" | "ocamlrevised" | "camlp4ocamlrevisedparser.cmo") -> load [pa_r] | ("Parsers"|"", "rr" | "reloaded" | "ocamlreloaded" | "camlp4ocamlreloadedparser.cmo") -> load [pa_rr] | ("Parsers"|"", "pa_o.cmo" | "o" | "ocaml" | "camlp4ocamlparser.cmo") -> load [pa_r; pa_o] | ("Parsers"|"", "pa_rp.cmo" | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo") -> load [pa_r; pa_rp] | ("Parsers"|"", "pa_op.cmo" | "op" | "parser" | "camlp4ocamlparserparser.cmo") -> load [pa_r; pa_o; pa_rp; pa_op] | ("Parsers"|"", "pa_extend.cmo" | "pa_extend_m.cmo" | "g" | "grammar" | "camlp4grammarparser.cmo") -> load [pa_g] | ("Parsers"|"", "pa_macro.cmo" | "m" | "macro" | "camlp4macroparser.cmo") -> load [pa_m] | ("Parsers"|"", "q" | "camlp4quotationexpander.cmo") -> load [pa_qb; pa_q] | ("Parsers"|"", "q_mlast.cmo" | "rq" | "camlp4ocamlrevisedquotationexpander.cmo") -> load [pa_qb; pa_rq] | ("Parsers"|"", "oq" | "camlp4ocamloriginalquotationexpander.cmo") -> load [pa_r; pa_o; pa_qb; pa_oq] | ("Parsers"|"", "rf") -> load [pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m] | ("Parsers"|"", "of") -> load [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m] | ("Parsers"|"", "comp" | "camlp4listcomprehension.cmo") -> load [pa_l] | ("Filters"|"", "lift" | "camlp4astlifter.cmo") -> load ["Camlp4AstLifter"] | ("Filters"|"", "exn" | "camlp4exceptiontracer.cmo") -> load ["Camlp4ExceptionTracer"] | ("Filters"|"", "prof" | "camlp4profiler.cmo") -> load ["Camlp4Profiler"] (* map is now an alias of fold since fold handles map too *) | ("Filters"|"", "map" | "camlp4mapgenerator.cmo") -> load ["Camlp4FoldGenerator"] | ("Filters"|"", "fold" | "camlp4foldgenerator.cmo") -> load ["Camlp4FoldGenerator"] | ("Filters"|"", "meta" | "camlp4metagenerator.cmo") -> load ["Camlp4MetaGenerator"] | ("Filters"|"", "trash" | "camlp4trashremover.cmo") -> load ["Camlp4TrashRemover"] | ("Filters"|"", "striploc" | "camlp4locationstripper.cmo") -> load ["Camlp4LocationStripper"] | ("Printers"|"", "pr_r.cmo" | "r" | "ocamlr" | "camlp4ocamlrevisedprinter.cmo") -> Register.enable_ocamlr_printer () | ("Printers"|"", "pr_o.cmo" | "o" | "ocaml" | "camlp4ocamlprinter.cmo") -> Register.enable_ocaml_printer () | ("Printers"|"", "pr_dump.cmo" | "p" | "dumpocaml" | "camlp4ocamlastdumper.cmo") -> Register.enable_dump_ocaml_ast_printer () | ("Printers"|"", "d" | "dumpcamlp4" | "camlp4astdumper.cmo") -> Register.enable_dump_camlp4_ast_printer () | ("Printers"|"", "a" | "auto" | "camlp4autoprinter.cmo") -> load ["Camlp4AutoPrinter"] | _ -> let y = "Camlp4"^n^"/"^x^objext in real_load (try find_in_path y with [ Not_found -> x ]) ]; rcall_callback.val (); }; value print_warning = eprintf "%a:\n%s@." Loc.print; value rec parse_file dyn_loader name pa getdir = let directive_handler = Some (fun ast -> match getdir ast with [ Some x -> match x with [ (_, "load", s) -> do { rewrite_and_load "" s; None } | (_, "directory", s) -> do { DynLoader.include_dir dyn_loader s; None } | (_, "use", s) -> Some (parse_file dyn_loader s pa getdir) | (_, "default_quotation", s) -> do { Quotation.default.val := s; None } | (loc, _, _) -> Loc.raise loc (Stream.Error "bad directive") ] | None -> None ]) in let loc = Loc.mk name in do { current_warning.val := print_warning; let ic = if name = "-" then stdin else open_in_bin name; let cs = Stream.of_channel ic; let clear () = if name = "-" then () else close_in ic; let phr = try pa ?directive_handler loc cs with x -> do { clear (); raise x }; clear (); phr }; value output_file = ref None; value process dyn_loader name pa pr clean fold_filters getdir = let ast = parse_file dyn_loader name pa getdir in let ast = fold_filters (fun t filter -> filter t) ast in let ast = clean ast in pr ?input_file:(Some name) ?output_file:output_file.val ast; value gind = fun [ <:sig_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s) | _ -> None ]; value gimd = fun [ <:str_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s) | _ -> None ]; value process_intf dyn_loader name = process dyn_loader name CurrentParser.parse_interf CurrentPrinter.print_interf (new CleanAst.clean_ast)#sig_item AstFilters.fold_interf_filters gind; value process_impl dyn_loader name = process dyn_loader name CurrentParser.parse_implem CurrentPrinter.print_implem (new CleanAst.clean_ast)#str_item AstFilters.fold_implem_filters gimd; value just_print_the_version () = do { printf "%s@." Camlp4_config.version; exit 0 }; value print_version () = do { eprintf "Camlp4 version %s@." Camlp4_config.version; exit 0 }; value print_stdlib () = do { printf "%s@." Camlp4_config.camlp4_standard_library; exit 0 }; value usage ini_sl ext_sl = do { eprintf "\ Usage: camlp4 [load-options] [--] [other-options]\n\ Options:\n\ .ml Parse this implementation file\n\ .mli Parse this interface file\n\ .%s Load this module inside the Camlp4 core@." (if DynLoader.is_native then "cmxs " else "(cmo|cma)") ; Options.print_usage_list ini_sl; (* loop (ini_sl @ ext_sl) where rec loop = fun [ [(y, _, _) :: _] when y = "-help" -> () | [_ :: sl] -> loop sl | [] -> eprintf " -help Display this list of options.@." ]; *) if ext_sl <> [] then do { eprintf "Options added by loaded object files:@."; Options.print_usage_list ext_sl; } else (); }; value warn_noassert () = do { eprintf "\ camlp4 warning: option -noassert is obsolete\n\ You should give the -noassert option to the ocaml compiler instead.@."; }; type file_kind = [ Intf of string | Impl of string | Str of string | ModuleImpl of string | IncludeDir of string ]; value search_stdlib = ref True; value print_loaded_modules = ref False; value (task, do_task) = let t = ref None in let task f x = let () = Camlp4_config.current_input_file.val := x in t.val := Some (if t.val = None then (fun _ -> f x) else (fun usage -> usage ())) in let do_task usage = match t.val with [ Some f -> f usage | None -> () ] in (task, do_task); value input_file x = let dyn_loader = dyn_loader.val () in do { rcall_callback.val (); match x with [ Intf file_name -> task (process_intf dyn_loader) file_name | Impl file_name -> task (process_impl dyn_loader) file_name | Str s -> begin let (f, o) = Filename.open_temp_file "from_string" ".ml"; output_string o s; close_out o; task (process_impl dyn_loader) f; at_exit (fun () -> Sys.remove f); end | ModuleImpl file_name -> rewrite_and_load "" file_name | IncludeDir dir -> DynLoader.include_dir dyn_loader dir ]; rcall_callback.val (); }; value initial_spec_list = [("-I", Arg.String (fun x -> input_file (IncludeDir x)), " Add directory in search patch for object files."); ("-where", Arg.Unit print_stdlib, "Print camlp4 library directory and exit."); ("-nolib", Arg.Clear search_stdlib, "No automatic search for object files in library directory."); ("-intf", Arg.String (fun x -> input_file (Intf x)), " Parse as an interface, whatever its extension."); ("-impl", Arg.String (fun x -> input_file (Impl x)), " Parse as an implementation, whatever its extension."); ("-str", Arg.String (fun x -> input_file (Str x)), " Parse as an implementation."); ("-unsafe", Arg.Set Camlp4_config.unsafe, "Generate unsafe accesses to array and strings."); ("-noassert", Arg.Unit warn_noassert, "Obsolete, do not use this option."); ("-verbose", Arg.Set Camlp4_config.verbose, "More verbose in parsing errors."); ("-loc", Arg.Set_string Loc.name, " Name of the location variable (default: " ^ Loc.name.val ^ ")."); ("-QD", Arg.String (fun x -> Quotation.dump_file.val := Some x), " Dump quotation expander result in case of syntax error."); ("-o", Arg.String (fun x -> output_file.val := Some x), " Output on instead of standard output."); ("-v", Arg.Unit print_version, "Print Camlp4 version and exit."); ("-version", Arg.Unit just_print_the_version, "Print Camlp4 version number and exit."); ("-vnum", Arg.Unit just_print_the_version, "Print Camlp4 version number and exit."); ("-no_quot", Arg.Clear Camlp4_config.quotations, "Don't parse quotations, allowing to use, e.g. \"<:>\" as token."); ("-loaded-modules", Arg.Set print_loaded_modules, "Print the list of loaded modules."); ("-parser", Arg.String (rewrite_and_load "Parsers"), " Load the parser Camlp4Parsers/.cm(o|a|xs)"); ("-printer", Arg.String (rewrite_and_load "Printers"), " Load the printer Camlp4Printers/.cm(o|a|xs)"); ("-filter", Arg.String (rewrite_and_load "Filters"), " Load the filter Camlp4Filters/.cm(o|a|xs)"); ("-ignore", Arg.String ignore, "ignore the next argument"); ("--", Arg.Unit ignore, "Deprecated, does nothing") ]; Options.init initial_spec_list; value anon_fun name = input_file (if Filename.check_suffix name ".mli" then Intf name else if Filename.check_suffix name ".ml" then Impl name else if Filename.check_suffix name objext then ModuleImpl name else if Filename.check_suffix name libext then ModuleImpl name else raise (Arg.Bad ("don't know what to do with " ^ name))); value main argv = let usage () = do { usage initial_spec_list (Options.ext_spec_list ()); exit 0 } in try do { let dynloader = DynLoader.mk ~ocaml_stdlib:search_stdlib.val ~camlp4_stdlib:search_stdlib.val (); dyn_loader.val := fun () -> dynloader; let call_callback () = Register.iter_and_take_callbacks (fun (name, module_callback) -> let () = add_to_loaded_modules name in module_callback ()); call_callback (); rcall_callback.val := call_callback; match Options.parse anon_fun argv with [ [] -> () | ["-help"|"--help"|"-h"|"-?" :: _] -> usage () | [s :: _] -> do { eprintf "%s: unknown or misused option\n" s; eprintf "Use option -help for usage@."; exit 2 } ]; do_task usage; call_callback (); if print_loaded_modules.val then do { SSet.iter (eprintf "%s@.") loaded_modules.val; } else () } with [ Arg.Bad s -> do { eprintf "Error: %s\n" s; eprintf "Use option -help for usage@."; exit 2 } | Arg.Help _ -> usage () | exc -> do { eprintf "@[%a@]@." ErrorHandler.print exc; exit 2 } ]; main Sys.argv; mingw-ocaml/ocaml/camlp4/camlp4lib.mllib0000644000175000017500000000004312124403240017522 0ustar tootstootsCamlp4 Camlp4_import Camlp4_config mingw-ocaml/ocaml/camlp4/meta/0000755000175000017500000000000012124403240015563 5ustar tootstootsmingw-ocaml/ocaml/camlp4/meta/.gitignore0000644000175000017500000000000012124403240017541 0ustar tootstootsmingw-ocaml/ocaml/camlp4/camlp4/0000755000175000017500000000000012124403240016015 5ustar tootstootsmingw-ocaml/ocaml/camlp4/camlp4/.gitignore0000644000175000017500000000000012124403240017773 0ustar tootstootsmingw-ocaml/ocaml/camlp4/CHANGES0000644000175000017500000012203312124403240015631 0ustar tootstoots- [...] In the revised syntax of parsers the "?" is now a "??" like in the orignal syntax to not conflict with optional labels. - [29 Jun 05] Add private row types. Make "private" a type constructor "TyPrv" rather than a flag. (Jacques) - [09 Jun 04] Moved "-no_quot" option from pa_o to camlp4, enabling to use it indepently fom pa_o.cmo. - [17 Nov 04] Renamed "loc" into "_loc", introducing an incompatibility with existing code (3.08.x and before). Such code can generally run unmodified using the -loc option (camlp4 -loc "loc"). Camlp4 Version 3.08.2 ------------------------ - [07 Oct 04] Changes in the interfaces plexer.mli and pcaml.mli: - plexer.mli: introduced a new lexer building function `make_lexer', similar to `gmake', but returning a triple of references in addition (holding respectively the character number of the beginning of the current line, the current line number and the name of the file being parsed). - pcaml.mli: a new value `position'. A global reference to a triple like the one mentioned above. - [07 Sep 04] Camlp4 grammars `error recovery mode' now issues a warning when used (but this warning is disabled by default). Camlp4 Version 3.08.[01] ------------------------ - [05 Jul 04] creation of the `unmaintained' directory: pa_format, pa_lefteval, pa_ocamllex, pa_olabl, pa_scheme and pa_sml go there, each in its own subdir. Currently, they compile fine. - [05 Jul 04] pa_ifdef, subsumed by pa_macro since 3.07, prints a warning when loaded, encouraging use of pa_macro. - [01 July 04] profiled versions of Camlp4 libs are *NOT* installed by default (not even built). To build and install them, uncomment the line PROFILING=prof in camlp4/config/Makefile.tpl, and then make opt.opt && make install - [22-23 June 04] `make install' now installs also pa_[or].cmx, pa_[or]p.cmx, pa_[or]_fast.cmx, and odyl.cmx - [12 may 04] Added to the camlp4 tools the -version option that prints the version number, in the same way as the other ocaml tools. - [12 may 04] Locations are now handled as in OCaml. The main benefit is that line numbers are now correct in error messages. However, this slightly changes the interface of a few Camlp4 modules (see ICHANGES). ** Warning: Some contribs of the camlp4 distribution are broken because of this change. In particular the scheme/lisp syntaxes. - [20 nov 03] Illegal escape sequences in strings now issue a warning. Camlp4 Version 3.07 ___________________ - [29 Sep 03] Camlp4 code now licensed under the LGPL minus clause 6. - [09 Sep 03] Added tokens LABEL and OPTLABEL in plexer, and use them in both parsers (ocaml and revised). There was, afaik, no other way to fix ambiguities (bugs) in parsing labels and type constraints. Camlp4 Version 3.07 beta1 ________________________ - [July 03] Updated the ocaml/camlp4 CVS tree with the camlp4 "parallel" CVS tree, which becomes obsolete from now on. Added support for recursive modules, private data constructors, and new syntaxes for integers (int32, nativeint, ...). Camlp4 Version 3.06++ ----------------------- - [02 Dec 02] In AST predefined quotation, changed antiquotations for "rec", "mutable": now all are with coercion "opt": $opt:...$ (instead of "rec" and "mut"). Added antiquotation for "private". Cleaned up the entries for "methods" and for labelled and optional parameters. - [29 Nov 02] Removed all "extract_crc" stuff no more necessary with the new interface of Dynlink. - [26 Nov 02] Added ability to use "#use" directives in compiled files. - [21 Nov 02] Changed Scheme syntax for directives: now, e.g. #load "file" is written: # (load "file"). Added directives in "implem", "interf" and "use" directive. - [20 Nov 02] Added Grammar.glexer returning the lexer used by a grammar. Also added a field in Token.glexer type to ask lexers to record the locations of the comments. - [04 Nov 02] Added option -no_quot with normal syntax (pa_o.cmo): don't parse quotations (it allows to use e.g. <:> as a valid token). - [31 Oct 02] Added pa_macro.cmo (to replace pa_ifdef.cmo which is kept for compatibility, but deprecated). The extended statements allow de definitions of macros and conditional compilation like in C. - [29 Oct 02] Changed pretty printers of the three main syntaxes: if the locations of input are not correct, do no more raise End_of_file when displaying the inter-phrases (return: the input found up to eof if not empty, otherwise the value of the -sep parameter if not empty, otherwise the string "\n"). - [25 Oct 02] Added option -records in pa_sml.cmo: generates normal OCaml records instead of objects (the user must be sure that there are no names conflicts). - [22 Oct 02] Added Plexer.specific_space_dot: when set to "true", the next call to Plexer.gmake returns a lexer where the dot preceded by spaces (space, tab, newline, etc.) return a different token than when not preceded by spaces. - [19 Oct 02] Added printer in Scheme syntax: pr_scheme.cmo and the extension pr_schemep.cmo which rebuilts parsers. - [15 Oct 02] Now, in case of syntax error, the real input file name is displayed (can be different from the input file, because of the possibility of line directives, typically generated by /lib/cpp). Changed interface of Stdpp.line_of_loc: now return also a string: the name of the real input file name. - [14 Oct 02] Fixed bug in normal syntax (pa_o.cmo): the constructors with currification of parameters (C x y) were accepted. - [14 Oct 02] Fixed many problems of make under Windows (in particular if installations directories contain spaces). - [11 Oct 02] In ocaml syntax (pa_o.cmo), fixed 3 bugs (or incompatibilities with the ocaml yacc version of the compiler): 1/ "ref new foo" was interpreted as "ref;; new foo" instead of "ref (new foo)" 2/ unary minuses did not work correctly (nor in quotation of syntax trees), in particular "-0.0" 3/ "begin end" was a syntax error, instead of being "()". - [Sep-Oct 02] Many changes and improvements in Scheme syntax. - [07 Oct 02] Added definition of Pcaml.type_declaration which is now visible in the interface, allowing to change the type declarations. - [07 Oct 02] Added Pcaml.syntax_name to allow syntax extensions to test it and take different decision. In revised syntax, its value is "Revised", in normal syntax "OCaml" and in Scheme syntax "Scheme". - [03 Oct 02] Added lexing of '\xHH' where HH is hexadecimal number. - [01 Oct 02] In normal syntax (camlp4o), fixed problem of lexing comment: (* bleble'''*) - [23 Sep 02] Fixed bug: input "0x" raised Failure "int_of_string" without location (syntaxes pa_o and pa_r). - [14 Sep 02] Added functions Grammar.iter_entry and Grammar.fold_entry to iterate a grammar entry and transitively all the entries it calls. - [12 Sep 02] Added "Pcaml.rename_id", a hook to allow parsers to give ability to rename their identifiers. Called in Scheme syntax (pa_scheme.ml) when generating its identifiers. - [09 Sep 02] Fixed bug under toplevel, the command: !Toploop.parse_toplevel_phrase (Lexing.from_buff "1;;");; failed "End_of_file". - [06 Sep 02] Added "Pcaml.string_of". Combined with Pcaml.pr_expr, Pcaml.pr_patt, and so on, allow to pretty print syntax trees in string. E.g. in the toplevel: # #load "pr_o.cmo"; # Pcaml.string_of Pcaml.pr_expr <:expr< let x = 3 in x + 2 >>;; - : string = "let x = 3 in x + 2" Camlp4 Version 3.06 -------------------- - [24 Jul 02] Added Scheme syntax: pa_scheme.ml, camlp4sch.cma (toplevel), camlp4sch (command). Camlp4 Version 3.05 ----------------------- - [12 Jul 02] Better treatment of comments in option -cip (add comments in phrases) for both printers pr_o.cmo (normal syntax) and pr_r.cmo (revised syntax); added comments before let binding and class structure items; treat comments inside sum and record type definitions; the option -tc is now deprecated and equivalent to -cip. - [13 Jun 02] Added pa_lefteval.cmo: add let..in expressions to guarantee left evaluation of functions parameters, t-uples, and so on (instead of the default non-specified-but-in-fact-right-to-left evaluation). - [06 Jun 02] Changed revised syntax (pa_r) of variants types definition; (Jacques Garrigue's idea): old syntax new syntax [| ... |] [ = ... ] [| < ... |] [ < ... ] [| > ... |] [ > ... ] This applies also in predefined quotations of syntax tree for types <:ctyp< ... >> - [05 Jun 02] Added option -ss in pr_o.cmo: print with double semicolons; and the option -no_ss is now by default. - [30 May 02] Improved SML syntax (pa_sml). - [30 May 02] Changed the AST for the "with module" construct (was with type "module_type"; changed into type "module_expr"). - [26 May 02] Added missing abstract module types. - [21 Apr 02] Added polymorphic types for polymorphic methods: revised syntax (example): ! 'a 'b . type ctyp quotation: <:ctyp< ! $list:pl$ . $t$ >> - [17 Apr 02] Fixed bug: in normal syntax (pa_o.cmo) made a parse error on the "dot" on (in interface file file): class c : a * B.c -> object val x : int end - [03 Apr 02] Fixed bug: (* "(*" *) resulted in "comment not terminated". - [03 Apr 02] Fixed incompatibility with ocaml: ''' and '"' must be displayed as '\'' and '\"' in normal syntax printer (pr_o.cmo). - [03 Apr 02] When there are several tokens parsed together (locally LL(n)), the location error now highlights all tokens, resulting in a more clear error message (e.g. "for i let" would display "illegal begin of expr" and highlight the 3 tokens, not just "for"). - [30 Mar 02] Added pa_extfold.cmo extending pa_extend.cmo by grammar symbols FOLD0 and FOLD1. Work like LIST0 and LIST1 but have two initial parameters: a function of type 'a -> 'b -> 'b doing the fold and an initial value of type 'b. Actually, LIST0 now is like FOLD0 (fun x y -> x :: y) [] with an reverse of the resulting list. - [20 Mar 02] Fixed problem: when running a toplevel linked with camlp4 as a script, the camlp4 welcome message was displayed. - [14 Mar 02] The configure shell and the program now test the consistency of OCaml and Camlp4. Therefore 1/ if trying to compile this version with an incompatible OCaml version or 2/ trying to run an installed Camlp4 with a incompatible OCaml version: in both cases, camlp4 fails. - [14 Mar 02] When make opt.opt is done, the very fast version is made for the normal syntax ("compiled" version). The installed camlp4o.opt is that version. - [05 Mar 02] Changed the conversion to OCaml syntax tree for <:expr< x.val >> and <:expr< x.val := e >> which generates now the tree of !x and x := e, no more x.contents and x.contents <- e. This change was necessary because of a problem if a record has been defined with a field named "contents". - [16 Feb 02] Changed interface of grammars: the token type is now customizable, using a new lexer type Token.glexer, parametrized by the token type, and a new functor GMake. This was accompanied by some cleanup. Become deprecated: the type Token.lexer (use Token.glexer), Grammar.create (use Grammar.gcreate), Unsafe.reinit_gram (use Unsafe.gram_reinit), the functor Grammar.Make (use Grammar.GMake). Deprecated means that they are kept during some versions and removed afterwards. - [06 Feb 02] Added missing infix "%" in pa_o (normal syntax). - [06 Feb 02] Added Grammar.print_entry printing any kind of (obj) entry and having the Format.formatter as first parameter (Grammar.Entry.print and its equivalent in functorial interface call it). - [05 Feb 02] Added a flag Plexer.no_quotations. When set to True, the quotations are no more lexed in all lexers built by Plexer.make () - [05 Feb 02] Changed the printing of options so that the option -help aligns correctly their documentation. One can use now Pcaml.add_option without having to calculate that. - [05 Feb 02] pr_r.cmo: now the option -ncip (no comments in phrases) is by default, because its behaviour is not 100% sure. An option -cip has been added to set it. - [03 Feb 02] Added function Stdpp.line_of_loc returning the line and columns positions from a character location and a file. - [01 Feb 02] Fixed bug in token.ml: the location function provided by lexer_func_of_parser, lexer_func_of_ocamllex and make_stream_and_location could raise Invalid_argument "Array.make" for big files if the number of read tokens overflows the maximum arrays size (Sys.max_array_length). The bug is not really fixed: in case of this overflow, the returned location is (0, 0) (but the program does not fail). - [28 Jan 02] Fixed bug in pa_o when parsing class_types. A horrible hack had to be programmed to be able to treat them correctly. - [28 Jan 02] Fixed bug in OCaml toplevel when loading camlp4: the directives were not applied in the good order. - [26 Jan 02] The printer pr_extend.cmo try now also to rebuild GEXTEND statements (before it tried only the EXTEND). - [23 Jan 02] The empty functional stream "fstream [: :]" is now of type 'a Fstream.t thanks to the new implementation of lazies allowing to create polymorphic lazy values. - [11 Jan 02] Added a test in grammars using Plexer that a keyword is not used also as parameter of a LIDENT or a UIDENT. - [04 Jan 02] Fixed bug in pa_sml (SML syntax): the function definitions with several currified parameters did not work. It works now, but the previous code was supposed to treat let ("fun" in SML syntax) definitions of infix operators, what does not work any more now. - [04 Jan 02] Alain Frisch's contribution: Added pa_ocamllex.cma, syntax for ocamllex files. The command: camlp4 pa_ocamllex.cmo pr_o.cmo -ocamllex -impl foo.mll > foo.ml does the same thing as: ocamllex foo.mll Allow to compile directly mll files. Without option -ocamllex, allow to insert lex rules in a ml file. - [29 Dec 01] Added variable "inter_phrases" in Pcaml, of type ref (option string) to specify the string to print between phrases in pretty printers. The default is None, meaning to copy the inter phrases from the source file. Camlp4 Version 3.04 ------------------- - [07 Dec 01] Added Pcaml.parse_interf and Pcaml.parse_implem, hooks to specify the parsers tof use, i.e. now can use other parsing technics than the Camlp4 grammar system. - [27 Nov 01] Fixed functions Token.eval_char and Token.eval_string which returned bad values, resulting lexing of backslash sequences incompatible with OCaml (e.g. "\1" returned "\001" (one character) but OCaml returns the string of the two characters \ and 1). - [15 Nov 01] In revised syntax, in let binding in sequences, the "in" can be replaced by a semicolon; the revised syntax printer pr_r.cmo now rather prints a semicolon there. - [07 Nov 01] Added the ability to use $ as token: was impossible so far, because of AST quotation uses it for its antiquotation. The fix is just a little (invisible) change in Plexer. - [05 Nov 01] Added option -tc (types comment) when using pr_o or pr_r try to print comments inside sum and record types like they are in the source (not by default, because may work incorrectly). - [05 Nov 01] Added option -ca (comment after) when using pr_o or pr_r: print ocamldoc comments after the declarations, when they are before. - [04 Nov 01] Added locations for variants and labels declarations in AST (file MLast.mli). - [03 Nov 01] In pretty printers pr_o and pr_r, skip to next begin of line when displaying the sources between phrase, to prevent e.g. the displaying of the possible last comment of a sum type declaration (the other comment being not displayed anyway). - [24 Oct 01] Fixed incorrect locations in sequences. - [24 Oct 01] Was erroneously compiled by the OCaml boot compiler instead of the generated ocamlc. Fixed. - [15 Oct 01] Fixed some parsing differences between pa_o and ocamlyacc: in parsers, in labels. - [12 Oct 01] Added missing bigarray syntax a.{b} (and Cie) in standard syntax (pa_o). Camlp4 Version 3.03 ------------------- - [09 Oct 01] Fixed bug: the token !$ did not work. Fixed and completed some syntaxes of labels patterns. Added missing case in exception declaration (exception rebinding). - [05 Oct 01] Fixed bug in normal syntax: when defining a constructor named "True" of "False" (capitalized, i.e. not like the booleans), it did not work. - [04 Oct 01] Fixed some revised and quotation syntaxes in objects classes and types (cleaner). Cleaned up also several parts of the parsers. - [02 Oct 01] In revised syntax, the warning for using old syntax for sequences is now by default. To remove it, the option -no-warn-seq of camlp4r has been added. Option -warn-seq has been removed. - [07 Sep 01] Included Camlp4 in OCaml distribution. - [06 Sep 01] Added missing pattern construction #t - [05 Sep 01] Fixed bug in pa_o: {A.B.c = d} was refused. - [26 Aug 01] Fixed bug: in normal and revised syntaxes, refused -1.0 (minus float) as pattern. - [24 Aug 01] Fixed bug: (a : b :> c) and ((a : b) :> c) were parsed identically. - [20 Aug 01] Fixed configure script for Windows configuration. - [10 Aug 01] Fixed bug: <:expr< 'a' >> did not work because of a typing problem. - [10 Aug 01] Fixed bug in compilation process under Windows: the use of the extension .exe was missing in several parts in Makefiles and shell scripts. - [09 Aug 01] Changed message error in grammar: in the case when the rule is: ....; tok1; tok2; .. tokn; ... (n terminal tokens following each other), where the grammar is locally LL(n), it displays now: tok1 tok2 .. tokn expected instead of just tok1 expected because "tok1" can be correct in the input, and in this case, the message underscored the tok1 and said "tok1 expected". - [07 Aug 01] When camlp4r.cma is loaded in the toplevel, the results are now displayed in revised syntax. - [04 Aug 01] Added syntax "declare..end" in quotations class_str_item and class_sig_item to be able to generate several items from one only item (like in str_item and sig_item). Camlp4 Version 3.02 ------------------- - [21 Jul 01] Fixed bug: <:expr< { l = x } >> was badly built and resulted in a typing error. - [13 Jul 01] Fixed bug: did not accept floats in patterns. - [11 Jul 01] Added function Pcaml.top_printer to be able to use the printers Pcaml.pr_expr, Pcaml.pr_patt, and so on for the #install_printer of OCaml toplevel. Ex: let f = Pcaml.top_printer Pcaml.pr_expr;; #install_printer f;; #load "pr_o.cmo";; - [24 Jun 01] In grammars, added symbol ANY, returning the current token, whichever it is. - [24 Jun 01] In grammars, a rule list of the form [ s1 | s2 | .. | sn ] is interpreted as [ x = s1 -> x | x = s2 -> x | .. x = sn -> x ] instead of [ _ = s1 -> () | _ = s2 -> () .. ] - [24 Jun 01] Moved the functions [Plexer.char_of_char_token] and [Plexer.string_of_string_token] into module [Token] with names [Token.eval_char] and [Token.eval_string]. - [22 Jun 01] Added warning when using old syntax for sequences, while and do (do..return, do..done) in predefined quotation expr. - [22 Jun 01] Changed message for unbound quotations (more clear). Camlp4 Version 3.01.6: ---------------------- - [22 Jun 01] Changed the module Pretty into Spretty. - [21 Jun 01] Camlp4 can now be compiled even if OCaml is not installed: in the directory "config", the file "configure_batch" is a possibility to configure the compilation (alternative of "configure" of the top directory) and has a parameter "-ocaml-top" to specify the OCaml top directory (relative to the camlp4/config directory). - [21 Jun 01] The interactive "configure" now tests if the native-code compilers ocamlc.opt and ocamlopt.opt are accessible and tell the Makefile to preferably use them if they are. - [16 Jun 01] The syntax tree for strings and characters now represent their exact input representation (the node for characters is now of type string, no more char). For example, the string "a\098c" remains "a\098c" and is *not* converted into (the equivalent) "abc" in the syntax tree. The convertion takes place when converting into OCaml tree representation. This has the advantage that the pretty print now display them as they are in the input file. To convert from input to real representation (if needed), two functions have been added: Plexer.string_of_string_token and Plexer.char_of_char_token. - [10 Jun 01] In revised syntax, added ability to write {foo x = y} as short form for {foo = fun x -> y}. - [08 Jun 01] Completed missing cases in pa_extfun.cmo for variants. - [06 Jun 01] Completed missing cases in abstract syntax tree and in normal syntax parser pa_o.ml (about classes). - [06 Jun 01] Fixed bug in pa_o.cmo (parser of normal syntax): (~~) did not work, and actually all prefix operators between parentheses. Camlp4 Version 3.01.5: ---------------------- - [04 Jun 01] Fixed bug: when using "include" in a structure item the rest of the structure was lost. - [31 May 01] Added ability to user #load and #directory inside ml or mli files to specify a cmo file to be loaded (for syntax extension) or the directory path (like option -I). Same semantics than in toplevel. - [29 May 01] The name of the location variable used in grammars (action parts of the rules) and in the predefined quotations for OCaml syntax trees is now configurable in Stdpp.loc_name (string reference). Added also option -loc to set this variable. Default: loc. - [26 May 01] Added functional streams: a library module Fstream and a syntax kit: pa_fstream.cmo. Syntax: streams: fstream [: ... :] parsers: fparser [ [: ... :] -> ... | ... ] - [25 May 01] Added function Token.lexer_func_of a little bit more general than Token.lexer_func_of_parser. Camlp4 Version 3.01.4: ---------------------- - [20 May 01] Fixed bug: pr_rp and pr_op could generate bound variables resulting incorrect program: (e.g. fun s -> parser [: `_; x :] -> s x was printed: fun s -> parser [: `_; s :] -> s s) - [19 May 01] Small improvement in pretty.ml resulting a faster print (no more stacked HOVboxes which printers pr_r and pr_o usually generate in expr, patt, ctyp, etc.) - [18 May 01] Added [lexer_func_of_parser] and [lexer_func_of_ocamllex] in module [Token] to create lexers functions from char stream parsers or from [ocamllex] lexers. - [16 May 01] Pretty printing with pr_r.cmo (revised syntax) now keep comments inside phrases. - [15 May 01] Changed pretty printing system, using now new extensible functions of Camlp4. - [15 May 01] Added library module Extfun for extensible functions, syntax pa_extfun, and a printer pr_extfun. - [12 May 01] Fixed bug: missing cases in pr_o and pr_r for in cases of "for", "while", and some other expressions, when between parentheses. Camlp4 Version 3.01.3: ---------------------- - [04 May 01] Put back the syntax "do ... return ..." in predefined quotation "expr", to be able to compile previous programs. Work only if the quotation is in position of expression, not in pattern. - [04 May 01] Added lisp syntax pa_lisp.cmo (not terminated). - [01 May 01] Fixed bug: in toplevel, in case of syntax error in #use, the display was incorrect: it displayed the input, instead of the file location. Camlp4 Version 3.01.2: ---------------------- - [27 Apr 01] Added variable Grammar.error_verbose and option -verbose of command camlp4 to display more information in case of parsing error. - [27 Apr 01] Fixed bug: the locations in sequences was not what expected by OCaml, resulting on bad locations displaying in case of typing error. - [27 Apr 01] Fixed bug: in normal syntax, the sequence was parsed of left associative instead of right associative, resulting bad pretty printing. Camlp4 Version 3.01.1: ---------------------- - [19 Apr 01] Added missing new feature "include" (structure item). - [17 Apr 01] Changed revised syntax of sequences. Now: do { expr1; expr2 ..... ; exprn } for patt = expr to/downto expr do { expr1; expr2 ..... ; exprn } while expr do { expr1; expr2 ..... ; exprn } * If holding a "let ... in", the scope applies up to the end of the sequence. * The old syntax "do .... return ..." is still accepted. * In expr quotation, it is *not* accepted. To ensure backward compatibility, use ifdef NEWSEQ, which answers True from this version. * The printer pr_r.cmo by default prints with this new syntax. * To print with old syntax, use option -old_seq. * To get a warning when using old syntax, use option -warn_seq. Camlp4 Version 3.01: -------------------- - [5 Mar 01] In pa_o.ml fixed problem, did not parse: class ['a, 'b] cl a b : ['a, 'b] classtype - [9 Oct 00] Raise now Stream.Error when parsing with an empty entry (meaning that the user probably forgot to initialize it). - [21 Jul 00] Fixed (pr_o.cmo) pb of bad printing of let (f : unit -> int) = fun () -> 1 - [10 Jun, 21 Jul 00] Added Pcaml.sync to synchronize after syntax error in toplevel. - [24 May 00] Changed the "make opt", returning to what was done in the previous releases, i.e. just the compilation of the library (6 files). The native code compilation of "camlp4o" and "camlp4r" are not absolutely necessary and can create problems in some systems because of too long code. The drawbacks are more important than the advantages. - [19 May 00] Changed option -split_gext (when pa_extend.cmo is loaded) into -split_ext: it applies now also for non functorial grammars (extended by EXTEND instead of GEXTEND). - [12 May 00] Fixed problem in pr_rp.cmo and pr_op.cmo: the pretty printing of the construction "match x with parser" did not work (because of the type constraint "Stream.t _" added some versions ago). Camlp4 Version 3.00: -------------------- - [Apr 19, 00] Added "pa_olabl" for labels with old Olabl syntax. - [Apr 18, 00] Make opt now builds camlp4o.opt and camlp4r.opt - [Apr 17, 00] Added support for labels and variants. - [Mar 28, 00] Improved the grammars: now the rules starting with n terminals are locally LL(n), i.e. if any of the terminal fails, it is not Error but just Failure. Allows to write the OCaml syntax case: ( operator ) ( expr ) with the problem of "( - )" as: "("; "-"; ")" "("; operator; ")" "("; expr; ")" after factorization of the "(", the rule "-"; ")" is locally LL(2): it works for this reason. In the previous implementation, a hack had to be added for this case. To allow this, the interface of "Token" changed. The field "tparse" is now of type "pattern -> option (Stream.t t -> string)" instead of "pattern -> Stream.t t -> string". Set it to "None" for standard pattern parsing (or if you don't know). Camlp4 Version 2.04: -------------------- - [Nov 23, 99] Changed the module name Config into Oconfig, because of conflict problem when applications want to link with the module Config of OCaml. Camlp4 Version 2.03: -------------------- * pr_depend: - [Jun 25, 99] Added missing case in "pr_depend.cmo": pattern A.B.C. - [Jun 5, 99] Fixed in "pr_depend.ml" case expression "Foo.Bar" displaying a bad dependency with file "bar.ml" if existed. And changed "pa_r.ml" (revised syntax parsing) to generate a more logical ast for case "var.Mod.lab". - [Apr 29, 99] Added missing cases in "pr_o.cmo" and in "pr_depend.cmo". - [Mar 11, 99] Added missing cases in "pr_depend.cmo". - [Mar 9, 99] Added missing case in pr_depend.ml. * Other: - [Sep 10, 99] Updated from current OCaml new interfaces. - [Jul 9, 99] Added stream type constraint in pa_oop.ml to reflect the same change in OCaml. - [Jun 24, 99] Added missing "constraint" construction in types - [Jun 15, 99] Added option -I for command "mkcamlp4". - [May 14, 99] Added man pages (links) for camlp4o, camlp4r, mkcamlp4, ocpp - [May 10, 99] Added shell script "configure_batch" in directory "config". - [May 10, 99] Changed LICENSE to BSD. - [Apr 29, 99] Added "ifdef" for mli files. - [Apr 11, 99] Changed option "-no_cp" into "-sep" in pr_r.cmo and pr_o.cmo. - [Apr 11, 99] Fixed (old) bug: too long strings where bad pretty printed. - [Mar 24, 99] Added missing stream type constraint for parsers. - [Mar 17, 99] Changed template Makefile to use ocamlc.opt and ocamlopt.opt by default, instead of ocamlc and ocamlopt. - [Mar 9, 99] Added ifndef in pa_ifdef.ml. - [Mar 7, 99] Completed and fixed some cases in pr_extend.ml. Camlp4 Version 2.02: -------------------- * Parsing: - [Feb 27, 99] Fixed 2 bugs, resulting of incorrect OCaml parsing of the program example: "type t = F(B).t" - [Jan 30, 99] Fixed bug "pa_op.ml", could not parse "parser | [<>] -> ()". - [Jan 16, 99] Added "define" and "undef" in "pa_ifdef.cmo". - [Dec 22, 98] Fixed precedence of "!=" in OCaml syntax * Printing: - [Mar 4, 99] Added pr_depend.cmo for printing file dependencies. - [Dec 28, 98] Fixed pretty printing of long strings starting with spaces; used to display "\\n..." instead of "\\n...". * Camlp4: - [Feb 19, 99] Sort command line argument list in reverse order to avoid argument names conflicts when adding arguments. * Olabl: - [Feb 26, 99] Started extensions for Olabl: directory "lablp4" and some changes in MLast. Olabl programs can be preprocessed by: camlp4 pa_labl.cma pr_ldump.cmo * Internal: - Use of pr_depend.cmo instead of ocamldep for dependencies. Camlp4 Version 2.01: -------------------- Token interface * Big change: the type for tokens and tokens patterns is now (string * string) the first string being the constructor name and the second its possible parameters. No change in EXTEND statements using Plexer. But lexers have: - a supplementary parameter "tparse" to specify how to parse token from token patterns. - fields "using" and "removing" replacing "add_keyword" and "remove_keyword". See the file README-2.01 for how to update your programs and the interface of Token. Grammar interface * The function "keywords" have been replaced by "tokens". The equivalent of the old statement: Grammar.keywords g is now: Grammar.tokens g "" Missing features added * Added "lazy" statement (pa_r.cmo, pa_o.cmo, pr_r.cmo, pr_o.cmo) * Added print "assert" statement (pr_o.cmo, pr_r.cmo) * Added parsing of infix operators like in OCaml (e.g. |||) in pa_o.cmo Compilation * Added "make scratch" * Changed Makefile. No more "make T=../", working bad in some systems. * Some changes to make compilation in Windows 95/98 working better (thanks to Patricia Peratto). Classes and objects * Added quotations for classes and objects (q_MLast.ml) * Added accessible entries in module Pcaml (class_type, class_expr, etc.) * Changed classes and objects types in definition (module MLast) Miscelleneous * Some adds in pa_sml.cmo. Thanks to Franklin Chen. * Added option "-no_cp" when "pr_o.cmo" or "pr_r.cmo" is loaded: do not print comments between phrases. * Added option "-split_gext" when "pa_extend.cmo" is loaded: split GEXTEND by functions to turn around a PowerPC problem. Bug fixes * Fixed pa_r.cmo, pa_o.cmo to parse, and pr_r.cmo, pr_o.cmo to print "(x:#M.c)" * Fixed printing pr_o.cmo of "(a.b <- 1)::1" * Extended options with parameters worked only when the parameter was sticked. Ex: camlp4o pr_o.cmo -l120 foo.ml worked, but not: camlp4o pr_o.cmo -l 120 foo.ml Camlp4 Version 2.00: -------------------- * Designation "righteous" has been renamed "revised". * Added class and objects in OCaml printing (pr_o.cmo), revised parsing (pa_r.cmo) and printing (pr_r.cmo). * Fixed bug in OCaml syntax: let _, x = 1, 2;; was refused. Camlp4 Version 2.00--1: ----------------------- * Added classes and objects in OCaml syntax (pa_o.cmo) * Fixed pr_r.cmo et pr_r.cmo which wrote on stdout, even when option -o Camlp4 Version 2.00--: ---------------------- * Adapted for OCaml 2.00. * No objects and classes in this version. * Added "let module" parsing and printing. * Added arrays patterns parsing and printing. * Added records with "with" "{... with ...}" parsing and printing * Added # num "string" in plexer (was missing). * Fixed bug in pr_o.cmo: module A = B (C);; was printed module A = B C;; * Added "pa_sml.cmo", SML syntax + "lib.sml" * Fixed bug in pa_r.ml and pa_o.ml: forgot to clear let_binding * Changed Plexer: unknown keywords do not raise error but return Tterm * q_MLast.cmo: suppressed <:expr< [$list:el$] >> (cannot work) * Added option "-no_ss" (no ;;) when "pr_o.cmo" loaded * Many changes and bug fixing in pretty printing pr_o.cmo and pr_r.cmo * Command ocpp works now without having to explicitely load "/usr/local/lib/ocaml/stdlib.cma" and "/usr/local/lib/camlp4/gramlib.cma" * Fixed problem of pretty print "&" and "or" in normal and righteous syntaxes * Added missing statement "include" in signature item in normal and righteous syntaxes * Changed precedence of ":=" and "<-" in normal syntax (pa_o et pr_o): now before "or", like in OCaml compiler. * Same change in righteous syntax, by symmetry. Camlp4 Version 1.07.2: ---------------------- Errors and missings in normal and righteous syntaxes. * Added forgotten syntax (righteous): type constraints in class type fields. * Added missing syntax (normal): type foo = bar = {......} * Added missing syntax (normal): did not accept separators before ending constructions (many of them). * Fixed bug: "assert false" is now of type 'a, like in OCaml. * Fixed to match OCaml feature: "\^" is "\^" in OCaml, but just "^" in Camlp4. * Fixed bug in Windows NT/95: problem in backslash before newlines in strings Grammars, EXTEND, DELETE_RULE * Added functorial version for grammars (started in version 1.07.1, completed in this version). * Added statements GEXTEND and GDELETE_RULE in pa_extend.cmo for functorial version. * EXTEND statement is added AFTER "top" instead of LEVEL "top" (because of problems parsing "a; EXTEND...") * Added ability to have expressions (in antiquotation form) of type string in EXTEND after keywords "LIDENT", "UIDENT", "IDENT", "ANTIQUOT", "INT" as in others constructions inside EXTEND. * A grammar rule hidden by another is not deleted but just masked. DELETE_RULE will restore the old version. * DELETE_RULE now raises Not_found if no rule matched. * Fixed bug: DELETE_RULE did not work when deleting a rule which is a prefix of another rule. * Some functions for "system use" in [Grammar] become "official": [Entry.obj], [extend], [delete_rule]. Command line, man page * Added option -o: output on file instead of standard output, necessary to allow compilation in Windows NT/95 (in fact, this option exists since 1.07.1 but forgotten in its "changes" list). * Command line option -help more complete. * Updated man page: camlp4 options are better explained. * Fixed bug: "camlp4 [other-options] foo.ml" worked but not "camlp4 foo.ml [other-options]". * Fixed bug: "camlp4 foo" did not display a understandable error message. Camlp4's compilation * Changes in compilation process in order to try to make it work better for Windows NT under Cygnus. Miscellaneous * Added [Pcaml.add_option] for adding command line options. Camlp4 Version 1.07.1: ---------------------- * Added forgotten syntax in pr_o: type x = y = A | B * Fixed bug negative floats parsing in pa_o => error while pretty printing * Added assert statement and option -noassert. * Environment variable CAMLP4LIB to change camlp4 library directory * Grammar: empty rules have a correct location instead of (-1, -1) * Compilation possible in Windows NT/95 * String constants no more shared while parsing OCaml * Fixed bug in antiquotations in q_MLast.cmo (bad errors locations) * Fixed bug in antiquotations in q_MLast.cmo (EOI not checked) * Fixed bug in Plexer: could not create keywords with iso 8859 characters Camlp4 Version 1.07: -------------------- * Changed version number + configuration script * Added iso 8859 uppercase characters for uidents in plexer.ml * Fixed bug factorization IDENT in grammars * Fixed bug pr_o.cmo was printing "declare" * Fixed bug constructor arity in OCaml syntax (pa_o.cmo). * Changed "lazy" into "slazy". * Completed pa_ifdef.cmo. Camlp4 Version 1.06: -------------------- * Adapted to OCaml 1.06. * Changed version number to match OCaml's => 1.06 too. * Deleted module Gstream, using OCaml's Stream. * Generate different AST for C(x,y) and C x y (change done in OCaml's compiler) * No more message "Interrupted" in toplevel in case of syntax error. * Added flag to suppress warnings while extending grammars. * Completed some missing statements and declarations (objects) * Modified odyl implementation; works better * Added ability to extend command line specification * Added "let_binding" as predefined (accessible) entry in Pcaml. * Added construction FUNCTION in EXTEND statement to call another function. * Added some ISO-8859-1 characters in lexer identifiers. * Fixed bug "value x = {val = 1};" (righteous syntax) * Fixed bug "open A.B.C" was interpreted as "open B.A.C" * Modified behavior of "DELETE_RULE": the complete rule must be provided * Completed quotations MLast ("expr", "patt", etc) to accept whole language * Renamed "LIKE" into "LEVEL" in grammar EXTEND * Added "NEXT" as grammar symbol in grammar EXTEND * Added command "mkcamlp4" to make camlp4 executables linked with C code * Added "pr_extend.cmo" to reconstitute EXTEND instructions Camlp4 Version 0.6: ------------------- --- Installing * To compile camlp4, it is no more necessary to have the sources of the Objective Caml compiler available. It can be compiled like any other Objective Caml program. --- Options of "camlp4" * Added option -where: "camlp4 -where" prints the name of the standard library directory of Camlp4 and exit. So, the ocaml toplevel and the compiler can use the option: -I `camlp4 -where` * Added option -nolib to not search for objects files in the installed library directory of Camlp4. --- Interface of grammar library modules * The function Grammar.keywords returns now a list of pairs. The pair is composed of a keyword and the number of times it is used in entries. * Changed interface of Token and Grammar for lexers, so user lexers have to be changed. --- New features in grammars * New instruction "DELETE_RULE" provided by pa_extend.cmo to delete rules. Ex: DELETE_RULE Pcaml.expr: "if" END; deletes the "if" instruction of the language. * Added the ability to parse some specific integer in grammars: a possible parameter to INT, like the ones for LIDENT and UIDENT. * In instruction EXTEND, ability to omit "-> action", default is "-> ()" * Ability to add antiquotation (between $'s) as symbol rule, of type string, interpreted as a keyword, in instruction EXTEND. * Ability to put entries with qualified names (Foo.bar) in instruction EXTEND. --- Quotations * The module Ast has been renamed MLast. The quotation expander "q_ast.cmo" has been renamed "q_MLast.cmo". * Quotation expanders are now of two kinds: - The "classical" type for expanders returning a string. These expanders have now a supplementary parameter: a boolean value set to "True" when the quotation is in a context of an expression an to "False" when the quotation is in a context of a pattern. These expanders, returning strings which are parsed afterwards, may work for some language syntax and/or language extensions used (e.g. may work for Righteous syntax and not for OCaml syntax). - A new type of expander returning directly syntax trees. A pair of functions, for expressions and for patterns must be provided. These expanders are independant from the language syntax and/or extensions used. * The predefined quotation expanders "ctyp_", "patt_" and "expr_" has been deleted; one can use "ctyp", "patt", and "expr" in position of pattern or expression. --- OCaml and Righteous syntaxes * Fixed bug: "open Foo.Bar" was converted (pr_dump.cmo) into "open Bar.Foo" * Corrected behavior different from OCaml's: "^" and "@" were at the same level than "=": now, like OCaml, they have a separated right associative level. --- Grammars behavior * While extending entries: default position is now "extension of the first level", instead of "adding a new level at the end". * Another Change: in each precedence level, terminals are inserted before other symbols (non terminals, lists, options, etc), LIDENT "foo" before LIDENT (alone) and UIDENT "foo" before UIDENT (alone). New rules not factorizable are now inserted before the other rules. * Changed algorithm of entries parsing: each precedence level is tested against the stream *before* its next precedences levels (instead of *after*): EXTEND e: [[ LIDENT "a" -> "xxx" ] | [ i = LIDENT -> i ]]; END; Now, parsing the entry e with the string "a" returns "xxx" instead of "a" * Less keywords in instruction EXTEND (LEFTA, LIDENT, etc), which can be used now as normal identifiers. * When inserting a new rule, a warning appears if a rule with the same production already existed (it is deleted). * Parse error messages (Gstream.Error) are formatted => spaces trigger Format.print_space and newlines trigger Format.force_newline. Camlp4 Version 0.5: ------------------- * Possible creation of native code library (make opt) * OCaml and Righteous Syntax more complete * Added pa_ru.cmo for compiling sequences of type unit (Righteous) * Quotations AST - No more quotation long_id - Antiquotations for identifiers more simple * Lot of small changes Camlp4 Version 0.4: ------------------- * First distributed version mingw-ocaml/ocaml/camlp4/man/0000755000175000017500000000000012124403240015410 5ustar tootstootsmingw-ocaml/ocaml/camlp4/man/.ignore0000644000175000017500000000002512124403240016671 0ustar tootstootscamlp4.1 camlp4.help mingw-ocaml/ocaml/camlp4/man/Makefile0000644000175000017500000000253312124403240017053 0ustar tootstoots######################################################################### # # # OCaml # # # # Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt # # # # Copyright 2001 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### include ../config/Makefile.cnf TARGET=camlp4.1 ALIASES=camlp4o.1 camlp4r.1 mkcamlp4.1 ocpp.1 camlp4o.opt.1 camlp4r.opt.1 include ../config/Makefile.base install-local: if test -n '$(MANDIR)'; then \ $(MKDIR) $(MANDIR)/man1 ; \ cp $(TARGET) $(MANDIR)/man1/. ; \ for i in $(ALIASES); do \ rm -f $(MANDIR)/man1/$$i; \ echo '.so man1/$(TARGET)' > $(MANDIR)/man1/$$i; \ done; \ fi camlp4.1: camlp4.1.tpl sed -e "s'LIBDIR'$(LIBDIR)'g" camlp4.1.tpl > camlp4.1 mingw-ocaml/ocaml/camlp4/man/camlp4.1.tpl0000644000175000017500000001443212124403240017454 0ustar tootstoots.\"*********************************************************************** .\"* * .\"* OCaml * .\"* * .\"* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt * .\"* * .\"* Copyright 2001 Institut National de Recherche en Informatique et * .\"* en Automatique. All rights reserved. This file is distributed * .\"* under the terms of the GNU Library General Public License, with * .\"* the special exception on linking described in file ../LICENSE. * .\"* * .\"*********************************************************************** .\" .\" $Id$ .\" .TH CAMLP4 1 "" "INRIA" .SH NAME camlp4 - Pre-Precessor-Pretty-Printer for OCaml .br mkcamlp4 - Create custom camlp4 .br ocpp - Universal preprocessor .SH SYNOPSIS .B camlp4 [ load-options ] [--] [ other-options ] .br .B camlp4o [ load-options ] [--] [ other-options ] .br .B camlp4r [ load-options ] [--] [ other-options ] .br .B camlp4o.cma .br .B camlp4r.cma .br .B mkcamlp4 .br .B ocpp [ load-options ] file .LP .br .B camlp4o.opt [--] [ other-options ] .br .B camlp4r.opt [--] [ other-options ] .SH DESCRIPTION .B camlp4 is a Pre-Processor-Pretty-Printer for OCaml, parsing a source file and printing some result on standard output. .LP .B camlp4o and .B camlp4r are versions of .B camlp4 with some files already loaded (see below). .LP .B camlp4o.cma and .B camlp4r.cma are files to be loaded in ocaml toplevel to use the camlp4 machinery. .LP .B mkcamlp4 creates camlp4 executables with almost the same options as ocamlmktop (see below). .LP .B ocpp is an universal preprocessor, expanding quotations in any kind of text file. .LP .B camlp4o.opt and .B camlp4r.opt are versions of camlp4o and camlp4r compiled by the native-code compiler ocamlopt. They are faster but not extensible. And they are not available in all installations of camlp4. .SH LOAD OPTIONS The load options select parsing and printing actions recorded in OCaml object files (ending with .cmo or .cma). They must precede other options. .LP An optional .B \-\- may end the load options. .TP .BI \-I\ directory Add .I directory in the search path for files loaded. Unless the option \-nolib is used, the camlp4 library directory is appended to the path. Note that there is no automatic search in the current directory: add "\-I ." for this. .TP .B \-where Print camlp4 library directory name and exit. .TP .B \-nolib No automatic search for objects files in camlp4 library directory. .TP .I object-file Load .I object-file in the camlp4 core. .SH OTHER OPTIONS .LP The others options are: .TP .I file Treat .I file as an interface file if it ends with .mli and as an implementation file if it ends with .ml. .TP .BI \-intf\ file Treat .I file as an interface file, whatever its extension is. .TP .BI \-impl\ file Treat .I file as an implementation file, whatever its extension is. .TP .B \-unsafe Generate unsafe accesses to arrays and strings. .TP .B \-noassert Do not compile assertion checks. .TP .B \-verbose More verbose in parsing errors. .TP .BI \-QD\ file Dump in .I file in case of syntax error in the result of a quotation expansion. .TP .BI \-o\ out-file Print the result in .I out-file instead of standard output. File is opened with open_out_bin (see the documentation of the Pervasives OCaml library). .TP .B \-v Print the version number and exit. .TP .B \-help Print the available options and exit. The output includes the options possibly added by the loaded object files. .LP The others options can be extended by loaded object files. The provided files add the following options: .TP .BI \-l\ line-length Added by pr_o.cmo and pr_r.cmo: set the line length (default 78). .TP .BI \-sep\ string Added by pr_o.cmo and pr_r.cmo: print this string between phrases instead of comments. .TP .BI \-no_ss Added by pr_o.cmo: do not print double semicolons .TP .BI \-D\ ident Added by pa_macro.cmo: define the ident. .TP .BI \-U\ ident Added by pa_macro.cmo: undefine the ident. .SH "PROVIDED FILES" These files are installed in LIBDIR/camlp4. .LP Parsing files: .nf .ta 1c pa_o.cmo: syntax of OCaml pa_op.cmo: streams and parsers pa_oop.cmo: streams and parsers (without code optimization) pa_r.cmo: revised syntax pa_rp.cmo: streams and parsers pa_extend.cmo: syntax extension for grammars pa_extfold.cmo: extension of pa_extend with FOLD0 and FOLD1 pa_extfun.cmo: syntax extension for extensible functions pa_fstream.cmo: syntax extension for functional streams pa_macro.cmo: add macros (ifdef, define) like in C pa_lefteval.cmo: left-to-right evaluation of parameters pa_olabl.cmo: old syntax for labels .fi .LP Printing files: .nf .ta 1c pr_o.cmo: syntax of OCaml pr_op.cmo: try to rebuild streams and parsers syntax pr_r.cmo: revised syntax pr_rp.cmo: try to rebuild streams and parsers syntax pr_extend.cmo: try to rebuild EXTEND statements pr_extfun.cmo: try to rebuild extfun statements pr_dump.cmo: syntax tree pr_depend.cmo: file dependencies pr_null.cmo: no output .fi .LP Quotation expanders: .nf .ta 1c q_MLast.cmo: syntax tree nodes q_phony.cmo: keeping quotations for pretty printing .fi .LP The command .B camlp4o is a shortcut for: .nf .ta 1c camlp4 pa_o.cmo pa_op.cmo pr_dump.cmo .fi .LP The command .B camlp4r is a shortcut for: .nf .ta 1c camlp4 pa_r.cmo pa_rp.cmo pr_dump.cmo .fi .LP .LP The file .B camlp4o.cma can be loaded in the toplevel to start camlp4 with OCaml syntax. .LP The file .B camlp4r.cma can be loaded in the toplevel to start camlp4 with revised syntax. .SH "MKCAMLP4" .B mkcamlp4 creates camlp4 executables with almost the same options than ocamlmktop. The only difference is that the interfaces to be visible must be explicitly added in the command line as ".cmi" files. For example, how to add the the OCaml module "str": .nf .ta 1c 2c mkcamlp4 -custom str.cmi str.cma -cclib -lstr \\ -o camlp4str .fi .SH "FILES" Camlp4 library directory in the current installation: .br LIBDIR/camlp4 .SH "SEE ALSO" Camlp4 - tutorial .br Camlp4 - reference manual .br ocamlc(1), ocaml(1). .SH AUTHOR Daniel de Rauglaudre, INRIA Rocquencourt. mingw-ocaml/ocaml/camlp4/Camlp4Top.mlpack0000644000175000017500000000001312124403240017623 0ustar tootstootsTop Rprint mingw-ocaml/ocaml/camlp4/unmaintained/0000755000175000017500000000000012124403240017311 5ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/extfold/0000755000175000017500000000000012124403240020756 5ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/extfold/pa_extfold.ml0000644000175000017500000000255512124403240023444 0ustar tootstoots(* camlp4r pa_extend.cmo q_MLast.cmo *) open Pcaml; open Pa_extend; value sfold _loc n foldfun f e s = let styp = STquo _loc (new_type_var ()) in let e = <:expr< Extfold.$lid:foldfun$ $f$ $e$ >> in let t = STapp _loc (STapp _loc (STtyp <:ctyp< Extfold.t _ >>) s.styp) styp in {used = s.used; text = TXmeta _loc n [s.text] e t; styp = styp} ; value sfoldsep _loc n foldfun f e s sep = let styp = STquo _loc (new_type_var ()) in let e = <:expr< Extfold.$lid:foldfun$ $f$ $e$ >> in let t = STapp _loc (STapp _loc (STtyp <:ctyp< Extfold.tsep _ >>) s.styp) styp in {used = s.used @ sep.used; text = TXmeta _loc n [s.text; sep.text] e t; styp = styp} ; EXTEND GLOBAL: symbol; symbol: LEVEL "top" [ [ UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF -> sfold _loc "FOLD0" "sfold0" f e s | UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF -> sfold _loc "FOLD1" "sfold1" f e s | UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF; UIDENT "SEP"; sep = symbol -> sfoldsep _loc "FOLD0 SEP" "sfold0sep" f e s sep | UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF; UIDENT "SEP"; sep = symbol -> sfoldsep _loc "FOLD1 SEP" "sfold1sep" f e s sep ] ] ; simple_expr: [ [ i = LIDENT -> <:expr< $lid:i$ >> | "("; e = expr; ")" -> e ] ] ; END; mingw-ocaml/ocaml/camlp4/unmaintained/extfold/README0000644000175000017500000000107012124403240021634 0ustar tootstootsThis is an application of or an extension for Camlp4. Although it is currently distributed with OCaml/Camlp4, it may or may not be actively maintained. It probably won't be part of future OCaml/Camlp4 distributions but be accessible from the Camlp4 hump. If you are interested in developing this package further and/or actively maintain it, please let us know (caml@inria.fr) This package is distributed under the same license as the OCaml Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny Nicolas Pouillard mingw-ocaml/ocaml/camlp4/unmaintained/Makefile0000644000175000017500000000201212124403240020744 0ustar tootstoots######################################################################### # # # OCaml # # # # Camlp4 # # # # Copyright 2004 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # # The unmaintained directory # include ../config/Makefile.cnf DIRS=format lefteval ocamllex olabl scheme sml include ../config/Makefile.base mingw-ocaml/ocaml/camlp4/unmaintained/scheme/0000755000175000017500000000000012124403240020555 5ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/scheme/Makefile0000644000175000017500000000605412124403240022222 0ustar tootstoots######################################################################### # # # OCaml # # # # Camlp4 # # # # Copyright 2004 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../../LICENSE.# # # ######################################################################### # # Makefile for pa_lefteval # M.Mauny # include ../../config/Makefile.cnf OCAMLTOP=../../.. CAMLP4=../../camlp4/camlp4$(EXE) OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) P4INCLUDES= -nolib -I ../../meta -I ../../etc OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../camlp4 -I ../../lib -I ../../etc OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) SCHSRC=pa_scheme.sc SRC=pa_scheme.ml pr_scheme.ml pr_schp_main.ml OBJS=$(SRC:.ml=.cmo) OBJSX=$(OCAMLSRC:.ml=.cmx) all: $(OBJS) pr_schemep.cmo camlp4sch$(EXE) opt: all bootstrap: camlp4sch$(EXE) save ./camlp4sch$(EXE) ../../etc/q_phony.cmo ../../meta/pa_extend.cmo ../../etc/pr_r.cmo ../../etc/pr_extend.cmo ../../etc/pr_rp.cmo -impl pa_scheme.sc \ | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' \ -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' > pa_scheme.ml @if cmp -s pa_scheme.ml SAVED/pa_scheme.ml; then \ echo 'pa_scheme.ml and SAVED/pa_scheme.ml are identical' ; \ else \ echo '**** Note: pa_scheme.ml differs from SAVED/pa_scheme.ml'; \ fi save: test -d SAVED || mkdir SAVED mkdir SAVED.$$$$ && mv SAVED pa_scheme.ml SAVED.$$$$ && mv SAVED.$$$$ SAVED restore: mv SAVED SAVED.$$$$ && mv SAVED.$$$$/* . && rmdir SAVED.$$$$ depend: cp .depend .depend.bak > .depend for file in $(SRC); do \ $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ done clean: rm -f camlp4sch$(EXE) *.cm* *.$(O) *.bak .*.bak camlp4sch: pa_scheme.cmo rm -f camlp4sch DIR=`pwd` && cd ../../camlp4 && $(MAKE) CAMLP4=$$DIR/camlp4sch CAMLP4M="-I $$DIR pa_scheme.cmo ../meta/pr_dump.cmo" pr_schemep.cmo: pr_schp_main.cmo $(OCAMLC) ../../etc/parserify.cmo pr_schp_main.cmo -a -o $@ .SUFFIXES: .cmx .cmo .cmi .ml .mli .mli.cmi: $(OCAMLC) $(OCAMLCFLAGS) -c $< .ml.cmo: $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<` -loc loc" -c $< .ml.cmx: $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<` -loc loc" -c $< include .depend mingw-ocaml/ocaml/camlp4/unmaintained/scheme/README0000644000175000017500000000104312124403240021433 0ustar tootstootsThis is an application of or an extension for Camlp4. Although it is currently distributed with OCaml/Camlp4, it may or may not be actively maintained. It probably won't be part of future OCaml/Camlp4 distributions but be accessible from the Camlp4 hump. If you are interested in developing this package further and/or actively maintain it, please let us know (caml@inria.fr) This package is distributed under the same license as the OCaml Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny mingw-ocaml/ocaml/camlp4/unmaintained/scheme/pr_schp_main.ml0000644000175000017500000001124112124403240023550 0ustar tootstoots(* pa_r.cmo q_MLast.cmo pa_extfun.cmo pr_dump.cmo *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file *) (* ../../../LICENSE. *) (* *) (***********************************************************************) open Format; open Pcaml; open Parserify; value nok = Pr_scheme.nok; value ks = Pr_scheme.ks; value patt = Pr_scheme.patt; value expr = Pr_scheme.expr; value find_pr_level = Pr_scheme.find_pr_level; value pr_expr = Pr_scheme.pr_expr; type printer_t 'a = Pr_scheme.printer_t 'a == { pr_fun : mutable string -> Pr_scheme.next 'a; pr_levels : mutable list (pr_level 'a) } and pr_level 'a = Pr_scheme.pr_level 'a == { pr_label : string; pr_box : formatter -> (formatter -> unit) -> 'a -> unit; pr_rules : mutable Pr_scheme.pr_rule 'a } ; (* extensions for rebuilding syntax of parsers *) value parser_cases ppf (spel, k) = let rec parser_cases ppf (spel, k) = match spel with [ [] -> fprintf ppf "[: `HVbox [: b; k :] :]" | [(sp, epo, e)] -> parser_case ppf (sp, epo, e, k) | [(sp, epo, e) :: spel] -> fprintf ppf "%a@ %a" parser_case (sp, epo, e, nok) parser_cases (spel, k) ] and parser_case ppf (sp, epo, e, k) = fprintf ppf "(@[@[(%a)%t@]@ %a@]" stream_patt (sp, nok) (fun ppf -> match epo with [ Some p -> fprintf ppf "@ %a" patt (p, nok) | None -> () ]) expr (e, ks ")" k) and stream_patt ppf (sp, k) = match sp with [ [] -> k ppf | [(spc, None)] -> fprintf ppf "%a" stream_patt_comp (spc, k) | [(spc, Some e)] -> fprintf ppf "(@[? %a@ %a@]" stream_patt_comp (spc, nok) expr (e, ks ")" k) | [(spc, None) :: spcl] -> fprintf ppf "%a@ %a" stream_patt_comp (spc, nok) stream_patt (spcl, k) | [(spc, Some e) :: spcl] -> fprintf ppf "(@[? %a@ %a@]@ %a" stream_patt_comp (spc, nok) expr (e, ks ")" nok) stream_patt (spcl, k) ] and stream_patt_comp ppf (spc, k) = match spc with [ SPCterm (p, w) -> match w with [ Some e -> fprintf ppf "(` %a@ %a" patt (p, nok) expr (e, ks ")" k) | None -> fprintf ppf "(` %a" patt (p, ks ")" k) ] | SPCnterm p e -> fprintf ppf "(@[%a %a@]" patt (p, nok) expr (e, ks ")" k) | SPCsterm p -> fprintf ppf "%a" patt (p, k) ] in parser_cases ppf (spel, k) ; value parser_body ppf (e, k) = let (bp, e) = match e with [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) | e -> (None, e) ] in match parser_of_expr e with [ [] -> fprintf ppf "(parser%t%t" (fun ppf -> match bp with [ Some p -> fprintf ppf "@ %a" patt (p, nok) | _ -> ()]) (ks ")" k) | spel -> fprintf ppf "(@[@[parser%t@]@ @[%a@]@]" (fun ppf -> match bp with [ Some p -> fprintf ppf "@ %a" patt (p, nok) | _ -> ()]) parser_cases (spel, ks ")" k) ] ; value pmatch ppf (e, k) = let (me, e) = match e with [ <:expr< let (__strm : Stream.t _) = $me$ in $e$ >> -> (me, e) | _ -> failwith "Pr_schp_main.pmatch" ] in let (bp, e) = match e with [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) | e -> (None, e) ] in let spel = parser_of_expr e in fprintf ppf "(@[@[match_with_parser@ %a@]%t@ @[%a@]@]" expr (me, nok) (fun ppf -> match bp with [ Some p -> fprintf ppf "@ %a" patt (p, nok) | _ -> () ]) parser_cases (spel, ks ")" k) ; pr_expr_fun_args.val := extfun pr_expr_fun_args.val with [ <:expr< fun [(__strm : $_$) -> $_$] >> as ge -> ([], ge) ]; let lev = find_pr_level "top" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< fun (__strm : $_$) -> $x$ >> -> fun ppf curr next dg k -> fprintf ppf "%a" parser_body (x, k) | <:expr< let (__strm : Stream.t _) = $_$ in $_$ >> as e -> fun ppf curr next dg k -> fprintf ppf "%a" pmatch (e, k) ]; mingw-ocaml/ocaml/camlp4/unmaintained/scheme/pr_scheme.ml0000644000175000017500000007545012124403240023067 0ustar tootstoots(* pa_r.cmo q_MLast.cmo pa_extfun.cmo pr_dump.cmo *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file *) (* ../../../LICENSE. *) (* *) (***********************************************************************) open Pcaml; open Format; type printer_t 'a = { pr_fun : mutable string -> next 'a; pr_levels : mutable list (pr_level 'a) } and pr_level 'a = { pr_label : string; pr_box : formatter -> (formatter -> unit) -> 'a -> unit; pr_rules : mutable pr_rule 'a } and pr_rule 'a = Extfun.t 'a (formatter -> curr 'a -> next 'a -> string -> kont -> unit) and curr 'a = formatter -> ('a * string * kont) -> unit and next 'a = formatter -> ('a * string * kont) -> unit and kont = formatter -> unit; value not_impl name x ppf k = let desc = if Obj.is_block (Obj.repr x) then "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) else "int_val = " ^ string_of_int (Obj.magic x) in fprintf ppf "%t" name desc k ; value pr_fun name pr lab = loop False pr.pr_levels where rec loop app = fun [ [] -> fun ppf (x, dg, k) -> failwith ("unable to print " ^ name) | [lev :: levl] -> if app || lev.pr_label = lab then let next = loop True levl in let rec curr ppf (x, dg, k) = Extfun.apply lev.pr_rules x ppf curr next dg k in fun ppf ((x, _, _) as n) -> lev.pr_box ppf (fun ppf -> curr ppf n) x else loop app levl ] ; value rec find_pr_level lab = fun [ [] -> failwith ("level " ^ lab ^ " not found") | [lev :: levl] -> if lev.pr_label = lab then lev else find_pr_level lab levl ] ; value pr_constr_decl = {pr_fun = fun []; pr_levels = []}; value constr_decl ppf (x, k) = pr_constr_decl.pr_fun "top" ppf (x, "", k); pr_constr_decl.pr_fun := pr_fun "constr_decl" pr_constr_decl; value pr_ctyp = {pr_fun = fun []; pr_levels = []}; pr_ctyp.pr_fun := pr_fun "ctyp" pr_ctyp; value ctyp ppf (x, k) = pr_ctyp.pr_fun "top" ppf (x, "", k); value pr_expr = {pr_fun = fun []; pr_levels = []}; pr_expr.pr_fun := pr_fun "expr" pr_expr; value expr ppf (x, k) = pr_expr.pr_fun "top" ppf (x, "", k); value pr_label_decl = {pr_fun = fun []; pr_levels = []}; value label_decl ppf (x, k) = pr_label_decl.pr_fun "top" ppf (x, "", k); pr_label_decl.pr_fun := pr_fun "label_decl" pr_label_decl; value pr_let_binding = {pr_fun = fun []; pr_levels = []}; pr_let_binding.pr_fun := pr_fun "let_binding" pr_let_binding; value let_binding ppf (x, k) = pr_let_binding.pr_fun "top" ppf (x, "", k); value pr_match_assoc = {pr_fun = fun []; pr_levels = []}; pr_match_assoc.pr_fun := pr_fun "match_assoc" pr_match_assoc; value match_assoc ppf (x, k) = pr_match_assoc.pr_fun "top" ppf (x, "", k); value pr_mod_ident = {pr_fun = fun []; pr_levels = []}; pr_mod_ident.pr_fun := pr_fun "mod_ident" pr_mod_ident; value mod_ident ppf (x, k) = pr_mod_ident.pr_fun "top" ppf (x, "", k); value pr_module_binding = {pr_fun = fun []; pr_levels = []}; pr_module_binding.pr_fun := pr_fun "module_binding" pr_module_binding; value module_binding ppf (x, k) = pr_module_binding.pr_fun "top" ppf (x, "", k); value pr_module_expr = {pr_fun = fun []; pr_levels = []}; pr_module_expr.pr_fun := pr_fun "module_expr" pr_module_expr; value module_expr ppf (x, k) = pr_module_expr.pr_fun "top" ppf (x, "", k); value pr_module_type = {pr_fun = fun []; pr_levels = []}; pr_module_type.pr_fun := pr_fun "module_type" pr_module_type; value module_type ppf (x, k) = pr_module_type.pr_fun "top" ppf (x, "", k); value pr_patt = {pr_fun = fun []; pr_levels = []}; pr_patt.pr_fun := pr_fun "patt" pr_patt; value patt ppf (x, k) = pr_patt.pr_fun "top" ppf (x, "", k); value pr_sig_item = {pr_fun = fun []; pr_levels = []}; pr_sig_item.pr_fun := pr_fun "sig_item" pr_sig_item; value sig_item ppf (x, k) = pr_sig_item.pr_fun "top" ppf (x, "", k); value pr_str_item = {pr_fun = fun []; pr_levels = []}; pr_str_item.pr_fun := pr_fun "str_item" pr_str_item; value str_item ppf (x, k) = pr_str_item.pr_fun "top" ppf (x, "", k); value pr_type_decl = {pr_fun = fun []; pr_levels = []}; value type_decl ppf (x, k) = pr_type_decl.pr_fun "top" ppf (x, "", k); pr_type_decl.pr_fun := pr_fun "type_decl" pr_type_decl; value pr_type_params = {pr_fun = fun []; pr_levels = []}; value type_params ppf (x, k) = pr_type_params.pr_fun "top" ppf (x, "", k); pr_type_params.pr_fun := pr_fun "type_params" pr_type_params; value pr_with_constr = {pr_fun = fun []; pr_levels = []}; value with_constr ppf (x, k) = pr_with_constr.pr_fun "top" ppf (x, "", k); pr_with_constr.pr_fun := pr_fun "with_constr" pr_with_constr; (* general functions *) value nok ppf = (); value ks s k ppf = fprintf ppf "%s%t" s k; value rec list f ppf (l, k) = match l with [ [] -> k ppf | [x] -> f ppf (x, k) | [x :: l] -> fprintf ppf "%a@ %a" f (x, nok) (list f) (l, k) ] ; value rec listwb b f ppf (l, k) = match l with [ [] -> k ppf | [x] -> f ppf ((b, x), k) | [x :: l] -> fprintf ppf "%a@ %a" f ((b, x), nok) (listwb "" f) (l, k) ] ; (* specific functions *) value rec is_irrefut_patt = fun [ <:patt< $lid:_$ >> -> True | <:patt< () >> -> True | <:patt< _ >> -> True | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y | <:patt< { $list:fpl$ } >> -> List.for_all (fun (_, p) -> is_irrefut_patt p) fpl | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl | <:patt< ? $_$ : ( $p$ ) >> -> is_irrefut_patt p | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p | <:patt< ~ $_$ >> -> True | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p | _ -> False ] ; value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; pr_expr_fun_args.val := extfun Extfun.empty with [ <:expr< fun [$p$ -> $e$] >> as ge -> if is_irrefut_patt p then let (pl, e) = expr_fun_args e in ([p :: pl], e) else ([], ge) | ge -> ([], ge) ]; value sequence ppf (e, k) = match e with [ <:expr< do { $list:el$ } >> -> fprintf ppf "@[%a@]" (list expr) (el, k) | _ -> expr ppf (e, k) ] ; value string ppf (s, k) = fprintf ppf "\"%s\"%t" s k; value int_repr s = if String.length s > 2 && s.[0] = '0' then match s.[1] with [ 'b' | 'o' | 'x' | 'B' | 'O' | 'X' -> "#" ^ String.sub s 1 (String.length s - 1) | _ -> s ] else s ; value assoc_left_parsed_op_list = ["+"; "*"; "land"; "lor"; "lxor"]; value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"]; value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="]; (* extensible pretty print functions *) pr_constr_decl.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ (loc, c, []) -> fun ppf curr next dg k -> fprintf ppf "(@[%s%t@]" c (ks ")" k) | (loc, c, tl) -> fun ppf curr next dg k -> fprintf ppf "(@[%s@ %a@]" c (list ctyp) (tl, ks ")" k) ]}]; pr_ctyp.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ <:ctyp< [ $list:cdl$ ] >> -> fun ppf curr next dg k -> fprintf ppf "(@[sum@ %a@]" (list constr_decl) (cdl, ks ")" k) | <:ctyp< { $list:cdl$ } >> -> fun ppf curr next dg k -> fprintf ppf "{@[%a@]" (list label_decl) (cdl, ks "}" k) | <:ctyp< ( $list:tl$ ) >> -> fun ppf curr next dg k -> fprintf ppf "(@[* @[%a@]@]" (list ctyp) (tl, ks ")" k) | <:ctyp< $t1$ -> $t2$ >> -> fun ppf curr next dg k -> let tl = loop t2 where rec loop = fun [ <:ctyp< $t1$ -> $t2$ >> -> [t1 :: loop t2] | t -> [t] ] in fprintf ppf "(@[-> @[%a@]@]" (list ctyp) ([t1 :: tl], ks ")" k) | <:ctyp< $t1$ $t2$ >> -> fun ppf curr next dg k -> let (t, tl) = loop [t2] t1 where rec loop tl = fun [ <:ctyp< $t1$ $t2$ >> -> loop [t2 :: tl] t1 | t1 -> (t1, tl) ] in fprintf ppf "(@[%a@ %a@]" ctyp (t, nok) (list ctyp) (tl, ks ")" k) | <:ctyp< $t1$ . $t2$ >> -> fun ppf curr next dg k -> fprintf ppf "%a.%a" ctyp (t1, nok) ctyp (t2, k) | <:ctyp< $lid:s$ >> | <:ctyp< $uid:s$ >> -> fun ppf curr next dg k -> fprintf ppf "%s%t" s k | <:ctyp< ' $s$ >> -> fun ppf curr next dg k -> fprintf ppf "'%s%t" s k | <:ctyp< _ >> -> fun ppf curr next dg k -> fprintf ppf "_%t" k | x -> fun ppf curr next dg k -> not_impl "ctyp" x ppf k ]}]; pr_expr.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ <:expr< fun [] >> -> fun ppf curr next dg k -> fprintf ppf "(lambda%t" (ks ")" k) | <:expr< fun $lid:s$ -> $e$ >> -> fun ppf curr next dg k -> fprintf ppf "(lambda@ %s@;<1 1>%a" s expr (e, ks ")" k) | <:expr< fun [ $list:pwel$ ] >> -> fun ppf curr next dg k -> fprintf ppf "(@[lambda_match@ %a@]" (list match_assoc) (pwel, ks ")" k) | <:expr< match $e$ with [ $list:pwel$ ] >> -> fun ppf curr next dg k -> fprintf ppf "(@[@[match@ %a@]@ %a@]" expr (e, nok) (list match_assoc) (pwel, ks ")" k) | <:expr< try $e$ with [ $list:pwel$ ] >> -> fun ppf curr next dg k -> fprintf ppf "(@[@[try@ %a@]@ %a@]" expr (e, nok) (list match_assoc) (pwel, ks ")" k) | <:expr< let $p1$ = $e1$ in $e2$ >> -> fun ppf curr next dg k -> let (pel, e) = loop [(p1, e1)] e2 where rec loop pel = fun [ <:expr< let $p1$ = $e1$ in $e2$ >> -> loop [(p1, e1) :: pel] e2 | e -> (List.rev pel, e) ] in let b = match pel with [ [_] -> "let" | _ -> "let*" ] in fprintf ppf "(@[@[%s (@[%a@]@]@;<1 2>%a@]" b (listwb "" let_binding) (pel, ks ")" nok) sequence (e, ks ")" k) | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> fun ppf curr next dg k -> let b = if rf then "letrec" else "let" in fprintf ppf "(@[%s@ (@[%a@]@ %a@]" b (listwb "" let_binding) (pel, ks ")" nok) expr (e, ks ")" k) | <:expr< if $e1$ then $e2$ else () >> -> fun ppf curr next dg k -> fprintf ppf "(if @[%a@;<1 0>%a@]" expr (e1, nok) expr (e2, ks ")" k) | <:expr< if $e1$ then $e2$ else $e3$ >> -> fun ppf curr next dg k -> fprintf ppf "(if @[%a@ %a@ %a@]" expr (e1, nok) expr (e2, nok) expr (e3, ks ")" k) | <:expr< do { $list:el$ } >> -> fun ppf curr next dg k -> fprintf ppf "(begin@;<1 1>@[%a@]" (list expr) (el, ks ")" k) | <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> -> fun ppf curr next dg k -> fprintf ppf "(@[for %s@ %a@ %a %a@]" i expr (e1, nok) expr (e2, nok) (list expr) (el, ks ")" k) | <:expr< ($e$ : $t$) >> -> fun ppf curr next dg k -> fprintf ppf "(:@ %a@ %a" expr (e, nok) ctyp (t, ks ")" k) | <:expr< ($list:el$) >> -> fun ppf curr next dg k -> fprintf ppf "(values @[%a@]" (list expr) (el, ks ")" k) | <:expr< { $list:fel$ } >> -> fun ppf curr next dg k -> let record_binding ppf ((p, e), k) = fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k) in fprintf ppf "{@[%a@]" (list record_binding) (fel, ks "}" k) | <:expr< { ($e$) with $list:fel$ } >> -> fun ppf curr next dg k -> let record_binding ppf ((p, e), k) = fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k) in fprintf ppf "{@[@[with@ %a@]@ @[%a@]@]" expr (e, nok) (list record_binding) (fel, ks "}" k) | <:expr< $e1$ := $e2$ >> -> fun ppf curr next dg k -> fprintf ppf "(:=@;<1 1>%a@;<1 1>%a" expr (e1, nok) expr (e2, ks ")" k) | <:expr< [$_$ :: $_$] >> as e -> fun ppf curr next dg k -> let (el, c) = make_list e where rec make_list e = match e with [ <:expr< [$e$ :: $y$] >> -> let (el, c) = make_list y in ([e :: el], c) | <:expr< [] >> -> ([], None) | x -> ([], Some e) ] in match c with [ None -> fprintf ppf "[%a" (list expr) (el, ks "]" k) | Some x -> fprintf ppf "[%a@ %a" (list expr) (el, ks " ." nok) expr (x, ks "]" k) ] | <:expr< lazy ($x$) >> -> fun ppf curr next dg k -> fprintf ppf "(@[lazy@ %a@]" expr (x, ks ")" k) | <:expr< $lid:s$ $e1$ $e2$ >> when List.mem s assoc_right_parsed_op_list -> fun ppf curr next dg k -> let el = loop [e1] e2 where rec loop el = fun [ <:expr< $lid:s1$ $e1$ $e2$ >> when s1 = s -> loop [e1 :: el] e2 | e -> List.rev [e :: el] ] in fprintf ppf "(@[%s %a@]" s (list expr) (el, ks ")" k) | <:expr< $e1$ $e2$ >> -> fun ppf curr next dg k -> let (f, el) = loop [e2] e1 where rec loop el = fun [ <:expr< $e1$ $e2$ >> -> loop [e2 :: el] e1 | e1 -> (e1, el) ] in fprintf ppf "(@[%a@ %a@]" expr (f, nok) (list expr) (el, ks ")" k) | <:expr< ~ $s$ : ($e$) >> -> fun ppf curr next dg k -> fprintf ppf "(~%s@ %a" s expr (e, ks ")" k) | <:expr< $e1$ .[ $e2$ ] >> -> fun ppf curr next dg k -> fprintf ppf "%a.[%a" expr (e1, nok) expr (e2, ks "]" k) | <:expr< $e1$ .( $e2$ ) >> -> fun ppf curr next dg k -> fprintf ppf "%a.(%a" expr (e1, nok) expr (e2, ks ")" k) | <:expr< $e1$ . $e2$ >> -> fun ppf curr next dg k -> fprintf ppf "%a.%a" expr (e1, nok) expr (e2, k) | <:expr< $int:s$ >> -> fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k | <:expr< $lid:s$ >> | <:expr< $uid:s$ >> -> fun ppf curr next dg k -> fprintf ppf "%s%t" s k | <:expr< ` $s$ >> -> fun ppf curr next dg k -> fprintf ppf "`%s%t" s k | <:expr< $str:s$ >> -> fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k | <:expr< $chr:s$ >> -> fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k | x -> fun ppf curr next dg k -> not_impl "expr" x ppf k ]}]; pr_label_decl.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ (loc, f, m, t) -> fun ppf curr next dg k -> fprintf ppf "(@[%s%t@ %a@]" f (fun ppf -> if m then fprintf ppf "@ mutable" else ()) ctyp (t, ks ")" k) ]}]; pr_let_binding.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ (b, (p, e)) -> fun ppf curr next dg k -> let (pl, e) = expr_fun_args e in match pl with [ [] -> fprintf ppf "(@[%s%s%a@ %a@]" b (if b = "" then "" else " ") patt (p, nok) sequence (e, ks ")" k) | _ -> fprintf ppf "(@[%s%s(%a)@ %a@]" b (if b = "" then "" else " ") (list patt) ([p :: pl], nok) sequence (e, ks ")" k) ] ]}]; pr_match_assoc.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ (p, we, e) -> fun ppf curr next dg k -> fprintf ppf "(@[%t@ %a@]" (fun ppf -> match we with [ Some e -> fprintf ppf "(when@ %a@ %a" patt (p, nok) expr (e, ks ")" nok) | None -> patt ppf (p, nok) ]) sequence (e, ks ")" k) ]}]; pr_mod_ident.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ [s] -> fun ppf curr next dg k -> fprintf ppf "%s%t" s k | [s :: sl] -> fun ppf curr next dg k -> fprintf ppf "%s.%a" s curr (sl, "", k) | x -> fun ppf curr next dg k -> not_impl "mod_ident" x ppf k ]}]; pr_module_binding.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ (b, s, me) -> fun ppf curr next dg k -> fprintf ppf "%s@ %s@ %a" b s module_expr (me, k) ]}]; pr_module_expr.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ <:module_expr< functor ($i$ : $mt$) -> $me$ >> -> fun ppf curr next dg k -> fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]" i module_type (mt, nok) module_expr (me, ks ")" k) | <:module_expr< struct $list:sil$ end >> -> fun ppf curr next dg k -> fprintf ppf "(@[struct@ @[%a@]@]" (list str_item) (sil, ks ")" k) | <:module_expr< $me1$ $me2$ >> -> fun ppf curr next dg k -> fprintf ppf "(@[%a@ %a@]" module_expr (me1, nok) module_expr (me2, ks ")" k) | <:module_expr< $uid:s$ >> -> fun ppf curr next dg k -> fprintf ppf "%s%t" s k | x -> fun ppf curr next dg k -> not_impl "module_expr" x ppf k ]}]; pr_module_type.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ <:module_type< functor ($i$ : $mt1$) -> $mt2$ >> -> fun ppf curr next dg k -> fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]" i module_type (mt1, nok) module_type (mt2, ks ")" k) | <:module_type< sig $list:sil$ end >> -> fun ppf curr next dg k -> fprintf ppf "(@[sig@ @[%a@]@]" (list sig_item) (sil, ks ")" k) | <:module_type< $mt$ with $list:wcl$ >> -> fun ppf curr next dg k -> fprintf ppf "(@[with@;<1 2>@[%a@ (%a@]@]" module_type (mt, nok) (list with_constr) (wcl, ks "))" k) | <:module_type< $uid:s$ >> -> fun ppf curr next dg k -> fprintf ppf "%s%t" s k | x -> fun ppf curr next dg k -> not_impl "module_type" x ppf k ]}]; pr_patt.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ <:patt< $p1$ | $p2$ >> -> fun ppf curr next dg k -> let (f, pl) = loop [p2] p1 where rec loop pl = fun [ <:patt< $p1$ | $p2$ >> -> loop [p2 :: pl] p1 | p1 -> (p1, pl) ] in fprintf ppf "(@[or@ %a@ %a@]" patt (f, nok) (list patt) (pl, ks ")" k) | <:patt< ($p1$ as $p2$) >> -> fun ppf curr next dg k -> fprintf ppf "(@[as@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) | <:patt< $p1$ .. $p2$ >> -> fun ppf curr next dg k -> fprintf ppf "(@[range@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) | <:patt< [$_$ :: $_$] >> as p -> fun ppf curr next dg k -> let (pl, c) = make_list p where rec make_list p = match p with [ <:patt< [$p$ :: $y$] >> -> let (pl, c) = make_list y in ([p :: pl], c) | <:patt< [] >> -> ([], None) | x -> ([], Some p) ] in match c with [ None -> fprintf ppf "[%a" (list patt) (pl, ks "]" k) | Some x -> fprintf ppf "[%a@ %a" (list patt) (pl, ks " ." nok) patt (x, ks "]" k) ] | <:patt< $p1$ $p2$ >> -> fun ppf curr next dg k -> let pl = loop [p2] p1 where rec loop pl = fun [ <:patt< $p1$ $p2$ >> -> loop [p2 :: pl] p1 | p1 -> [p1 :: pl] ] in fprintf ppf "(@[%a@]" (list patt) (pl, ks ")" k) | <:patt< ($p$ : $t$) >> -> fun ppf curr next dg k -> fprintf ppf "(:@ %a@ %a" patt (p, nok) ctyp (t, ks ")" k) | <:patt< ($list:pl$) >> -> fun ppf curr next dg k -> fprintf ppf "(values @[%a@]" (list patt) (pl, ks ")" k) | <:patt< { $list:fpl$ } >> -> fun ppf curr next dg k -> let record_binding ppf ((p1, p2), k) = fprintf ppf "(@[%a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) in fprintf ppf "(@[{}@ %a@]" (list record_binding) (fpl, ks ")" k) | <:patt< ? $x$ >> -> fun ppf curr next dg k -> fprintf ppf "?%s%t" x k | <:patt< ? ($lid:x$ = $e$) >> -> fun ppf curr next dg k -> fprintf ppf "(?%s@ %a" x expr (e, ks ")" k) | <:patt< $p1$ . $p2$ >> -> fun ppf curr next dg k -> fprintf ppf "%a.%a" patt (p1, nok) patt (p2, k) | <:patt< $lid:s$ >> | <:patt< $uid:s$ >> -> fun ppf curr next dg k -> fprintf ppf "%s%t" s k | <:patt< $str:s$ >> -> fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k | <:patt< $chr:s$ >> -> fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k | <:patt< $int:s$ >> -> fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k | <:patt< $flo:s$ >> -> fun ppf curr next dg k -> fprintf ppf "%s%t" s k | <:patt< _ >> -> fun ppf curr next dg k -> fprintf ppf "_%t" k | x -> fun ppf curr next dg k -> not_impl "patt" x ppf k ]}]; pr_sig_item.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ <:sig_item< type $list:tdl$ >> -> fun ppf curr next dg k -> match tdl with [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k) | tdl -> fprintf ppf "(@[type@ %a@]" (listwb "" type_decl) (tdl, ks ")" k) ] | <:sig_item< exception $c$ of $list:tl$ >> -> fun ppf curr next dg k -> match tl with [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k) | tl -> fprintf ppf "(@[@[exception@ %s@]@ %a@]" c (list ctyp) (tl, ks ")" k) ] | <:sig_item< value $i$ : $t$ >> -> fun ppf curr next dg k -> fprintf ppf "(@[@[value %s@]@ %a@]" i ctyp (t, ks ")" k) | <:sig_item< external $i$ : $t$ = $list:pd$ >> -> fun ppf curr next dg k -> fprintf ppf "(@[@[external@ %s@]@ %a@ %a@]" i ctyp (t, nok) (list string) (pd, ks ")" k) | <:sig_item< module $s$ : $mt$ >> -> fun ppf curr next dg k -> fprintf ppf "(@[@[module@ %s@]@ %a@]" s module_type (mt, ks ")" k) | <:sig_item< module type $s$ = $mt$ >> -> fun ppf curr next dg k -> fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s module_type (mt, ks ")" k) | <:sig_item< declare $list:s$ end >> -> fun ppf curr next dg k -> if s = [] then fprintf ppf "; ..." else fprintf ppf "%a" (list sig_item) (s, k) | MLast.SgUse _ _ _ -> fun ppf curr next dg k -> () | x -> fun ppf curr next dg k -> not_impl "sig_item" x ppf k ]}]; pr_str_item.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ <:str_item< open $i$ >> -> fun ppf curr next dg k -> fprintf ppf "(open@ %a" mod_ident (i, ks ")" k) | <:str_item< type $list:tdl$ >> -> fun ppf curr next dg k -> match tdl with [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k) | tdl -> fprintf ppf "(@[type@ %a@]" (listwb "" type_decl) (tdl, ks ")" k) ] | <:str_item< exception $c$ of $list:tl$ >> -> fun ppf curr next dg k -> match tl with [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k) | tl -> fprintf ppf "(@[@[exception@ %s@]@ %a@]" c (list ctyp) (tl, ks ")" k) ] | <:str_item< value $opt:rf$ $list:pel$ >> -> fun ppf curr next dg k -> let b = if rf then "definerec" else "define" in match pel with [ [(p, e)] -> fprintf ppf "%a" let_binding ((b, (p, e)), k) | pel -> fprintf ppf "(@[%s*@ %a@]" b (listwb "" let_binding) (pel, ks ")" k) ] | <:str_item< module $s$ = $me$ >> -> fun ppf curr next dg k -> fprintf ppf "(%a" module_binding (("module", s, me), ks ")" k) | <:str_item< module type $s$ = $mt$ >> -> fun ppf curr next dg k -> fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s module_type (mt, ks ")" k) | <:str_item< external $i$ : $t$ = $list:pd$ >> -> fun ppf curr next dg k -> fprintf ppf "(@[external@ %s@ %a@ %a@]" i ctyp (t, nok) (list string) (pd, ks ")" k) | <:str_item< $exp:e$ >> -> fun ppf curr next dg k -> fprintf ppf "%a" expr (e, k) | <:str_item< # $s$ $opt:x$ >> -> fun ppf curr next dg k -> match x with [ Some e -> fprintf ppf "; # (%s %a" s expr (e, ks ")" k) | None -> fprintf ppf "; # (%s%t" s (ks ")" k) ] | <:str_item< declare $list:s$ end >> -> fun ppf curr next dg k -> if s = [] then fprintf ppf "; ..." else fprintf ppf "%a" (list str_item) (s, k) | MLast.StUse _ _ _ -> fun ppf curr next dg k -> () | x -> fun ppf curr next dg k -> not_impl "str_item" x ppf k ]}]; pr_type_decl.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ (b, ((_, tn), tp, te, cl)) -> fun ppf curr next dg k -> fprintf ppf "%t%t@;<1 1>%a" (fun ppf -> if b <> "" then fprintf ppf "%s@ " b else ()) (fun ppf -> match tp with [ [] -> fprintf ppf "%s" tn | tp -> fprintf ppf "(%s%a)" tn type_params (tp, nok) ]) ctyp (te, k) ]}]; pr_type_params.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ [(s, vari) :: tpl] -> fun ppf curr next dg k -> fprintf ppf "@ '%s%a" s type_params (tpl, k) | [] -> fun ppf curr next dg k -> () ]}]; pr_with_constr.pr_levels := [{pr_label = "top"; pr_box ppf f x = fprintf ppf "@[%t@]" f; pr_rules = extfun Extfun.empty with [ MLast.WcTyp _ m tp te -> fun ppf curr next dg k -> fprintf ppf "(type@ %t@;<1 1>%a" (fun ppf -> match tp with [ [] -> fprintf ppf "%a" mod_ident (m, nok) | tp -> fprintf ppf "(%a@ %a)" mod_ident (m, nok) type_params (tp, nok) ]) ctyp (te, ks ")" k) | x -> fun ppf curr next dg k -> not_impl "with_constr" x ppf k ]}]; (* main *) value output_string_eval ppf s = loop 0 where rec loop i = if i == String.length s then () else if i == String.length s - 1 then pp_print_char ppf s.[i] else match (s.[i], s.[i + 1]) with [ ('\\', 'n') -> do { pp_print_char ppf '\n'; loop (i + 2) } | (c, _) -> do { pp_print_char ppf c; loop (i + 1) } ] ; value sep = Pcaml.inter_phrases; value input_source ic len = let buff = Buffer.create 20 in try let rec loop i = if i >= len then Buffer.contents buff else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) } in loop 0 with [ End_of_file -> let s = Buffer.contents buff in if s = "" then match sep.val with [ Some s -> s | None -> "\n" ] else s ] ; value copy_source ppf (ic, first, bp, ep) = match sep.val with [ Some str -> if first then () else if ep == in_channel_length ic then pp_print_string ppf "\n" else output_string_eval ppf str | None -> do { seek_in ic bp; let s = input_source ic (ep - bp) in pp_print_string ppf s } ] ; value copy_to_end ppf (ic, first, bp) = let ilen = in_channel_length ic in if bp < ilen then copy_source ppf (ic, first, bp, ilen) else pp_print_string ppf "\n" ; value apply_printer printer ast = let ppf = std_formatter in if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do { let ic = open_in_bin Pcaml.input_file.val in try let (first, last_pos) = List.fold_left (fun (first, last_pos) (si, (bp, ep)) -> do { fprintf ppf "@[%a@]@?" copy_source (ic, first, last_pos.Lexing.pos_cnum, bp.Lexing.pos_cnum); fprintf ppf "@[%a@]@?" printer (si, nok); (False, ep) }) (True, Token.nowhere) ast in fprintf ppf "@[%a@]@?" copy_to_end (ic, first, last_pos.Lexing.pos_cnum) with x -> do { fprintf ppf "@."; close_in ic; raise x }; close_in ic; } else failwith "not implemented" ; Pcaml.print_interf.val := apply_printer sig_item; Pcaml.print_implem.val := apply_printer str_item; Pcaml.add_option "-l" (Arg.Int (fun x -> set_margin x)) " Maximum line length for pretty printing."; Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x)) " Use this string between phrases instead of reading source."; mingw-ocaml/ocaml/camlp4/unmaintained/scheme/pa_scheme.ml0000644000175000017500000010607312124403240023042 0ustar tootstoots(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) (* ********************************************************************** *) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file *) (* ../../../LICENSE. *) (* *) (* ********************************************************************** *) (* File generated by pretty print; do not edit! *) open Pcaml; open Stdpp; type choice 'a 'b = [ Left of 'a | Right of 'b ] ; (* Buffer *) module Buff = struct value buff = ref (String.create 80); value store len x = do { if len >= String.length buff.val then buff.val := buff.val ^ String.create (String.length buff.val) else (); buff.val.[len] := x; succ len } ; value get len = String.sub buff.val 0 len; end ; (* Lexer *) value rec skip_to_eol = parser [ [: `'\n' | '\r' :] -> () | [: `_; s :] -> skip_to_eol s ] ; value no_ident = ['('; ')'; '['; ']'; '{'; '}'; ' '; '\t'; '\n'; '\r'; ';']; value rec ident len = parser [ [: `'.' :] -> (Buff.get len, True) | [: `x when not (List.mem x no_ident); s :] -> ident (Buff.store len x) s | [: :] -> (Buff.get len, False) ] ; value identifier kwt (s, dot) = let con = try do { (Hashtbl.find kwt s : unit); "" } with [ Not_found -> match s.[0] with [ 'A'..'Z' -> if dot then "UIDENTDOT" else "UIDENT" | _ -> if dot then "LIDENTDOT" else "LIDENT" ] ] in (con, s) ; value rec string len = parser [ [: `'"' :] -> Buff.get len | [: `'\\'; `c; s :] -> string (Buff.store (Buff.store len '\\') c) s | [: `x; s :] -> string (Buff.store len x) s ] ; value rec end_exponent_part_under len = parser [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s | [: :] -> ("FLOAT", Buff.get len) ] ; value end_exponent_part len = parser [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ] ; value exponent_part len = parser [ [: `('+' | '-' as c); s :] -> end_exponent_part (Buff.store len c) s | [: a = end_exponent_part len :] -> a ] ; value rec decimal_part len = parser [ [: `('0'..'9' as c); s :] -> decimal_part (Buff.store len c) s | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s | [: :] -> ("FLOAT", Buff.get len) ] ; value rec number len = parser [ [: `('0'..'9' as c); s :] -> number (Buff.store len c) s | [: `'.'; s :] -> decimal_part (Buff.store len '.') s | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s | [: :] -> ("INT", Buff.get len) ] ; value binary = parser [: `('0'..'1' as c) :] -> c; value octal = parser [: `('0'..'7' as c) :] -> c; value hexa = parser [: `('0'..'9' | 'a'..'f' | 'A'..'F' as c) :] -> c; value rec digits_under kind len = parser [ [: d = kind; s :] -> digits_under kind (Buff.store len d) s | [: :] -> Buff.get len ] ; value digits kind bp len = parser [ [: d = kind; s :] -> ("INT", digits_under kind (Buff.store len d) s) | [: s :] ep -> raise_with_loc (Reloc.shift_pos bp Reloc.zero_loc, Reloc.shift_pos ep Reloc.zero_loc) (Failure "ill-formed integer constant") ] ; value base_number kwt bp len = parser [ [: `'b' | 'B'; s :] -> digits binary bp (Buff.store len 'b') s | [: `'o' | 'O'; s :] -> digits octal bp (Buff.store len 'o') s | [: `'x' | 'X'; s :] -> digits hexa bp (Buff.store len 'x') s | [: id = ident (Buff.store 0 '#') :] -> identifier kwt id ] ; value rec operator len = parser [ [: `'.' :] -> Buff.get (Buff.store len '.') | [: :] -> Buff.get len ] ; value char_or_quote_id x = parser [ [: `''' :] -> ("CHAR", String.make 1 x) | [: s :] ep -> if List.mem x no_ident then Stdpp.raise_with_loc (Reloc.shift_pos (ep - 2) Reloc.zero_loc, Reloc.shift_pos (ep - 1) Reloc.zero_loc) (Stream.Error "bad quote") else let len = Buff.store (Buff.store 0 ''') x in let (s, dot) = ident len s in (if dot then "LIDENTDOT" else "LIDENT", s) ] ; value rec char len = parser [ [: `''' :] -> len | [: `x; s :] -> char (Buff.store len x) s ] ; value quote = parser [ [: `'\\'; len = char (Buff.store 0 '\\') :] -> ("CHAR", Buff.get len) | [: `x; s :] -> char_or_quote_id x s ] ; (* The system with LIDENTDOT and UIDENTDOT is not great (it would be *) (* better to have a token DOT (actually SPACEDOT and DOT)) but it is *) (* the only way (that I have found) to have a good behaviour in the *) (* toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be *) (* complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the *) (* parser rule with dot is right associative and we have to reverse *) (* the resulting tree (using the function leftify). *) (* This is a complicated issue: the behaviour of the OCaml toplevel *) (* is strange, anyway. For example, even without Camlp4, The OCaml *) (* toplevel accepts that: *) (* # let x = 32;; foo bar match let ) *) value rec lexer kwt = parser [: t = lexer0 kwt; _ = no_dot :] -> t and no_dot = parser [ [: `'.' :] ep -> Stdpp.raise_with_loc (Reloc.shift_pos (ep - 1) Reloc.zero_loc, Reloc.shift_pos ep Reloc.zero_loc) (Stream.Error "bad dot") | [: :] -> () ] and lexer0 kwt = parser bp [ [: `'\t' | '\n' | '\r'; s :] -> lexer0 kwt s | [: `' '; s :] -> after_space kwt s | [: `';'; _ = skip_to_eol; s :] -> lexer kwt s | [: `'(' :] -> (("", "("), (bp, bp + 1)) | [: `')'; s :] ep -> (("", rparen s), (bp, ep)) | [: `'[' :] -> (("", "["), (bp, bp + 1)) | [: `']' :] -> (("", "]"), (bp, bp + 1)) | [: `'{' :] -> (("", "{"), (bp, bp + 1)) | [: `'}' :] -> (("", "}"), (bp, bp + 1)) | [: `'"'; s = string 0 :] ep -> (("STRING", s), (bp, ep)) | [: `'''; tok = quote :] ep -> (tok, (bp, ep)) | [: `'<'; tok = less kwt :] ep -> (tok, (bp, ep)) | [: `'-'; tok = minus kwt :] ep -> (tok, (bp, ep)) | [: `'~'; tok = tilde :] ep -> (tok, (bp, ep)) | [: `'?'; tok = question :] ep -> (tok, (bp, ep)) | [: `'#'; tok = base_number kwt bp (Buff.store 0 '0') :] ep -> (tok, (bp, ep)) | [: `('0'..'9' as c); tok = number (Buff.store 0 c) :] ep -> (tok, (bp, ep)) | [: `('+' | '*' | '/' as c); id = operator (Buff.store 0 c) :] ep -> (identifier kwt (id, False), (bp, ep)) | [: `x; id = ident (Buff.store 0 x) :] ep -> (identifier kwt id, (bp, ep)) | [: :] -> (("EOI", ""), (bp, bp + 1)) ] and rparen = parser [ [: `'.' :] -> ")." | [: ___ :] -> ")" ] and after_space kwt = parser [ [: `'.' :] ep -> (("", "."), (ep - 1, ep)) | [: x = lexer0 kwt :] -> x ] and tilde = parser [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] -> ("TILDEIDENT", s) | [: :] -> ("LIDENT", "~") ] and question = parser [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] -> ("QUESTIONIDENT", s) | [: :] -> ("LIDENT", "?") ] and minus kwt = parser [ [: `'.' :] -> identifier kwt ("-.", False) | [: `('0'..'9' as c); n = number (Buff.store (Buff.store 0 '-') c) :] -> n | [: id = ident (Buff.store 0 '-') :] -> identifier kwt id ] and less kwt = parser [ [: `':'; lab = label 0; `'<' ? "'<' expected"; q = quotation 0 :] -> ("QUOT", lab ^ ":" ^ q) | [: id = ident (Buff.store 0 '<') :] -> identifier kwt id ] and label len = parser [ [: `('a'..'z' | 'A'..'Z' | '_' as c); s :] -> label (Buff.store len c) s | [: :] -> Buff.get len ] and quotation len = parser [ [: `'>'; s :] -> quotation_greater len s | [: `x; s :] -> quotation (Buff.store len x) s | [: :] -> failwith "quotation not terminated" ] and quotation_greater len = parser [ [: `'>' :] -> Buff.get len | [: a = quotation (Buff.store len '>') :] -> a ] ; value lexer_using kwt (con, prm) = match con with [ "CHAR" | "EOI" | "INT" | "FLOAT" | "LIDENT" | "LIDENTDOT" | "QUESTIONIDENT" | "QUOT" | "STRING" | "TILDEIDENT" | "UIDENT" | "UIDENTDOT" -> () | "ANTIQUOT" -> () | "" -> try Hashtbl.find kwt prm with [ Not_found -> Hashtbl.add kwt prm () ] | _ -> raise (Token.Error ("the constructor \"" ^ con ^ "\" is not recognized by Plexer")) ] ; value lexer_text (con, prm) = if con = "" then "'" ^ prm ^ "'" else if prm = "" then con else con ^ " \"" ^ prm ^ "\"" ; value lexer_gmake () = let kwt = Hashtbl.create 89 in {Token.tok_func = Token.lexer_func_of_parser (fun s -> let (r, (bp, ep)) = lexer kwt s in (r, (Reloc.shift_pos bp Reloc.zero_loc, Reloc.shift_pos ep Reloc.zero_loc))); Token.tok_using = lexer_using kwt; Token.tok_removing = fun []; Token.tok_match = Token.default_match; Token.tok_text = lexer_text; Token.tok_comm = None} ; (* Building AST *) type sexpr = [ Sacc of Loc.t and sexpr and sexpr | Schar of Loc.t and string | Sexpr of Loc.t and list sexpr | Sint of Loc.t and string | Sfloat of Loc.t and string | Slid of Loc.t and string | Slist of Loc.t and list sexpr | Sqid of Loc.t and string | Squot of Loc.t and string and string | Srec of Loc.t and list sexpr | Sstring of Loc.t and string | Stid of Loc.t and string | Suid of Loc.t and string ] ; value loc_of_sexpr = fun [ Sacc loc _ _ | Schar loc _ | Sexpr loc _ | Sint loc _ | Sfloat loc _ | Slid loc _ | Slist loc _ | Sqid loc _ | Squot loc _ _ | Srec loc _ | Sstring loc _ | Stid loc _ | Suid loc _ -> loc ] ; value error_loc loc err = raise_with_loc loc (Stream.Error (err ^ " expected")) ; value error se err = error_loc (loc_of_sexpr se) err; value strm_n = "__strm"; value peek_fun loc = <:expr< Stream.peek >>; value junk_fun loc = <:expr< Stream.junk >>; value assoc_left_parsed_op_list = ["+"; "*"; "+."; "*."; "land"; "lor"; "lxor"] ; value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"]; value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="]; value op_apply loc e1 e2 = fun [ "and" -> <:expr< $e1$ && $e2$ >> | "or" -> <:expr< $e1$ || $e2$ >> | x -> <:expr< $lid:x$ $e1$ $e2$ >> ] ; value string_se = fun [ Sstring loc s -> s | se -> error se "string" ] ; value mod_ident_se = fun [ Suid _ s -> [Pcaml.rename_id.val s] | Slid _ s -> [Pcaml.rename_id.val s] | se -> error se "mod_ident" ] ; value lident_expr loc s = if String.length s > 1 && s.[0] = '`' then let s = String.sub s 1 (String.length s - 1) in <:expr< ` $s$ >> else <:expr< $lid:(Pcaml.rename_id.val s)$ >> ; value rec module_expr_se = fun [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] -> let s = Pcaml.rename_id.val s in let mt = module_type_se se1 in let me = module_expr_se se2 in <:module_expr< functor ($s$ : $mt$) -> $me$ >> | Sexpr loc [Slid _ "struct" :: sl] -> let mel = List.map str_item_se sl in <:module_expr< struct $list:mel$ end >> | Sexpr loc [se1; se2] -> let me1 = module_expr_se se1 in let me2 = module_expr_se se2 in <:module_expr< $me1$ $me2$ >> | Suid loc s -> <:module_expr< $uid:(Pcaml.rename_id.val s)$ >> | se -> error se "module expr" ] and module_type_se = fun [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] -> let s = Pcaml.rename_id.val s in let mt1 = module_type_se se1 in let mt2 = module_type_se se2 in <:module_type< functor ($s$ : $mt1$) -> $mt2$ >> | Sexpr loc [Slid _ "sig" :: sel] -> let sil = List.map sig_item_se sel in <:module_type< sig $list:sil$ end >> | Sexpr loc [Slid _ "with"; se; Sexpr _ sel] -> let mt = module_type_se se in let wcl = List.map with_constr_se sel in <:module_type< $mt$ with $list:wcl$ >> | Suid loc s -> <:module_type< $uid:(Pcaml.rename_id.val s)$ >> | se -> error se "module type" ] and with_constr_se = fun [ Sexpr loc [Slid _ "type"; se1; se2] -> let tn = mod_ident_se se1 in let te = ctyp_se se2 in MLast.WcTyp loc tn [] te | se -> error se "with constr" ] and sig_item_se = fun [ Sexpr loc [Slid _ "type" :: sel] -> let tdl = type_declaration_list_se sel in <:sig_item< type $list:tdl$ >> | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] -> let c = Pcaml.rename_id.val c in let tl = List.map ctyp_se sel in <:sig_item< exception $c$ of $list:tl$ >> | Sexpr loc [Slid _ "value"; Slid _ s; se] -> let s = Pcaml.rename_id.val s in let t = ctyp_se se in <:sig_item< value $s$ : $t$ >> | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] -> let i = Pcaml.rename_id.val i in let pd = List.map string_se sel in let t = ctyp_se se in <:sig_item< external $i$ : $t$ = $list:pd$ >> | Sexpr loc [Slid _ "module"; Suid _ s; se] -> let s = Pcaml.rename_id.val s in let mb = module_type_se se in <:sig_item< module $s$ : $mb$ >> | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] -> let s = Pcaml.rename_id.val s in let mt = module_type_se se in <:sig_item< module type $s$ = $mt$ >> | se -> error se "sig item" ] and str_item_se se = match se with [ Sexpr loc [Slid _ "open"; se] -> let s = mod_ident_se se in <:str_item< open $s$ >> | Sexpr loc [Slid _ "type" :: sel] -> let tdl = type_declaration_list_se sel in <:str_item< type $list:tdl$ >> | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] -> let c = Pcaml.rename_id.val c in let tl = List.map ctyp_se sel in <:str_item< exception $c$ of $list:tl$ >> | Sexpr loc [Slid _ ("define" | "definerec" as r); se :: sel] -> let r = r = "definerec" in let (p, e) = fun_binding_se se (begin_se loc sel) in <:str_item< value $opt:r$ $p$ = $e$ >> | Sexpr loc [Slid _ ("define*" | "definerec*" as r) :: sel] -> let r = r = "definerec*" in let lbs = List.map let_binding_se sel in <:str_item< value $opt:r$ $list:lbs$ >> | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] -> let i = Pcaml.rename_id.val i in let pd = List.map string_se sel in let t = ctyp_se se in <:str_item< external $i$ : $t$ = $list:pd$ >> | Sexpr loc [Slid _ "module"; Suid _ i; se] -> let i = Pcaml.rename_id.val i in let mb = module_binding_se se in <:str_item< module $i$ = $mb$ >> | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] -> let s = Pcaml.rename_id.val s in let mt = module_type_se se in <:str_item< module type $s$ = $mt$ >> | _ -> let loc = loc_of_sexpr se in let e = expr_se se in <:str_item< $exp:e$ >> ] and module_binding_se se = module_expr_se se and expr_se = fun [ Sacc loc se1 se2 -> let e1 = expr_se se1 in match se2 with [ Slist loc [se2] -> let e2 = expr_se se2 in <:expr< $e1$ .[ $e2$ ] >> | Sexpr loc [se2] -> let e2 = expr_se se2 in <:expr< $e1$ .( $e2$ ) >> | _ -> let e2 = expr_se se2 in <:expr< $e1$ . $e2$ >> ] | Slid loc s -> lident_expr loc s | Suid loc s -> <:expr< $uid:(Pcaml.rename_id.val s)$ >> | Sint loc s -> <:expr< $int:s$ >> | Sfloat loc s -> <:expr< $flo:s$ >> | Schar loc s -> <:expr< $chr:s$ >> | Sstring loc s -> <:expr< $str:s$ >> | Stid loc s -> <:expr< ~ $(Pcaml.rename_id.val s)$ >> | Sqid loc s -> <:expr< ? $(Pcaml.rename_id.val s)$ >> | Sexpr loc [] -> <:expr< () >> | Sexpr loc [Slid _ s; e1 :: ([_ :: _] as sel)] when List.mem s assoc_left_parsed_op_list -> let rec loop e1 = fun [ [] -> e1 | [e2 :: el] -> loop (op_apply loc e1 e2 s) el ] in loop (expr_se e1) (List.map expr_se sel) | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)] when List.mem s assoc_right_parsed_op_list -> let rec loop = fun [ [] -> assert False | [e1] -> e1 | [e1 :: el] -> let e2 = loop el in op_apply loc e1 e2 s ] in loop (List.map expr_se sel) | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)] when List.mem s and_by_couple_op_list -> let rec loop = fun [ [] | [_] -> assert False | [e1; e2] -> <:expr< $lid:s$ $e1$ $e2$ >> | [e1 :: ([e2; _ :: _] as el)] -> let a1 = op_apply loc e1 e2 s in let a2 = loop el in <:expr< $a1$ && $a2$ >> ] in loop (List.map expr_se sel) | Sexpr loc [Stid _ s; se] -> let e = expr_se se in <:expr< ~ $s$ : $e$ >> | Sexpr loc [Slid _ "-"; se] -> let e = expr_se se in <:expr< - $e$ >> | Sexpr loc [Slid _ "if"; se; se1] -> let e = expr_se se in let e1 = expr_se se1 in <:expr< if $e$ then $e1$ else () >> | Sexpr loc [Slid _ "if"; se; se1; se2] -> let e = expr_se se in let e1 = expr_se se1 in let e2 = expr_se se2 in <:expr< if $e$ then $e1$ else $e2$ >> | Sexpr loc [Slid _ "cond" :: sel] -> let rec loop = fun [ [Sexpr loc [Slid _ "else" :: sel]] -> begin_se loc sel | [Sexpr loc [se1 :: sel1] :: sel] -> let e1 = expr_se se1 in let e2 = begin_se loc sel1 in let e3 = loop sel in <:expr< if $e1$ then $e2$ else $e3$ >> | [] -> <:expr< () >> | [se :: _] -> error se "cond clause" ] in loop sel | Sexpr loc [Slid _ "while"; se :: sel] -> let e = expr_se se in let el = List.map expr_se sel in <:expr< while $e$ do { $list:el$ } >> | Sexpr loc [Slid _ "for"; Slid _ i; se1; se2 :: sel] -> let i = Pcaml.rename_id.val i in let e1 = expr_se se1 in let e2 = expr_se se2 in let el = List.map expr_se sel in <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> | Sexpr loc [Slid loc1 "lambda"] -> <:expr< fun [] >> | Sexpr loc [Slid loc1 "lambda"; sep :: sel] -> let e = begin_se loc1 sel in match ipatt_opt_se sep with [ Left p -> <:expr< fun $p$ -> $e$ >> | Right (se, sel) -> List.fold_right (fun se e -> let p = ipatt_se se in <:expr< fun $p$ -> $e$ >>) [se :: sel] e ] | Sexpr loc [Slid _ "lambda_match" :: sel] -> let pel = List.map (match_case loc) sel in <:expr< fun [ $list:pel$ ] >> | Sexpr loc [Slid _ ("let" | "letrec" as r) :: sel] -> match sel with [ [Sexpr _ sel1 :: sel2] -> let r = r = "letrec" in let lbs = List.map let_binding_se sel1 in let e = begin_se loc sel2 in <:expr< let $opt:r$ $list:lbs$ in $e$ >> | [Slid _ n; Sexpr _ sl :: sel] -> let n = Pcaml.rename_id.val n in let (pl, el) = List.fold_right (fun se (pl, el) -> match se with [ Sexpr _ [se1; se2] -> ([patt_se se1 :: pl], [expr_se se2 :: el]) | se -> error se "named let" ]) sl ([], []) in let e1 = List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl (begin_se loc sel) in let e2 = List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) <:expr< $lid:n$ >> el in <:expr< let rec $lid:n$ = $e1$ in $e2$ >> | [se :: _] -> error se "let_binding" | _ -> error_loc loc "let_binding" ] | Sexpr loc [Slid _ "let*" :: sel] -> match sel with [ [Sexpr _ sel1 :: sel2] -> List.fold_right (fun se ek -> let (p, e) = let_binding_se se in <:expr< let $p$ = $e$ in $ek$ >>) sel1 (begin_se loc sel2) | [se :: _] -> error se "let_binding" | _ -> error_loc loc "let_binding" ] | Sexpr loc [Slid _ "match"; se :: sel] -> let e = expr_se se in let pel = List.map (match_case loc) sel in <:expr< match $e$ with [ $list:pel$ ] >> | Sexpr loc [Slid _ "parser" :: sel] -> let e = match sel with [ [(Slid _ _ as se) :: sel] -> let p = patt_se se in let pc = parser_cases_se loc sel in <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >> | _ -> parser_cases_se loc sel ] in <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >> | Sexpr loc [Slid _ "match_with_parser"; se :: sel] -> let me = expr_se se in let (bpo, sel) = match sel with [ [(Slid _ _ as se) :: sel] -> (Some (patt_se se), sel) | _ -> (None, sel) ] in let pc = parser_cases_se loc sel in let e = match bpo with [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> | None -> pc ] in match me with [ <:expr< $lid:x$ >> when x = strm_n -> e | _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ] | Sexpr loc [Slid _ "try"; se :: sel] -> let e = expr_se se in let pel = List.map (match_case loc) sel in <:expr< try $e$ with [ $list:pel$ ] >> | Sexpr loc [Slid _ "begin" :: sel] -> let el = List.map expr_se sel in <:expr< do { $list:el$ } >> | Sexpr loc [Slid _ ":="; se1; se2] -> let e1 = expr_se se1 in let e2 = expr_se se2 in <:expr< $e1$ := $e2$ >> | Sexpr loc [Slid _ "values" :: sel] -> let el = List.map expr_se sel in <:expr< ( $list:el$ ) >> | Srec loc [Slid _ "with"; se :: sel] -> let e = expr_se se in let lel = List.map (label_expr_se loc) sel in <:expr< { ($e$) with $list:lel$ } >> | Srec loc sel -> let lel = List.map (label_expr_se loc) sel in <:expr< { $list:lel$ } >> | Sexpr loc [Slid _ ":"; se1; se2] -> let e = expr_se se1 in let t = ctyp_se se2 in <:expr< ( $e$ : $t$ ) >> | Sexpr loc [se] -> let e = expr_se se in <:expr< $e$ () >> | Sexpr loc [Slid _ "assert"; Suid _ "False"] -> <:expr< assert False >> | Sexpr loc [Slid _ "assert"; se] -> let e = expr_se se in <:expr< assert $e$ >> | Sexpr loc [Slid _ "lazy"; se] -> let e = expr_se se in <:expr< lazy $e$ >> | Sexpr loc [se :: sel] -> List.fold_left (fun e se -> let e1 = expr_se se in <:expr< $e$ $e1$ >>) (expr_se se) sel | Slist loc sel -> let rec loop = fun [ [] -> <:expr< [] >> | [se1; Slid _ "."; se2] -> let e = expr_se se1 in let el = expr_se se2 in <:expr< [$e$ :: $el$] >> | [se :: sel] -> let e = expr_se se in let el = loop sel in <:expr< [$e$ :: $el$] >> ] in loop sel | Squot loc typ txt -> Pcaml.handle_expr_quotation loc (typ, txt) ] and begin_se loc = fun [ [] -> <:expr< () >> | [se] -> expr_se se | sel -> let el = List.map expr_se sel in let loc = (fst (loc_of_sexpr (List.hd sel)), snd loc) in <:expr< do { $list:el$ } >> ] and let_binding_se = fun [ Sexpr loc [se :: sel] -> let e = begin_se loc sel in match ipatt_opt_se se with [ Left p -> (p, e) | Right _ -> fun_binding_se se e ] | se -> error se "let_binding" ] and fun_binding_se se e = match se with [ Sexpr _ [Slid _ "values" :: _] -> (ipatt_se se, e) | Sexpr _ [Slid loc s :: sel] -> let s = Pcaml.rename_id.val s in let e = List.fold_right (fun se e -> let loc = (fst (loc_of_sexpr se), snd (MLast.loc_of_expr e)) in let p = ipatt_se se in <:expr< fun $p$ -> $e$ >>) sel e in let p = <:patt< $lid:s$ >> in (p, e) | _ -> (ipatt_se se, e) ] and match_case loc = fun [ Sexpr loc [Sexpr _ [Slid _ "when"; se; sew] :: sel] -> (patt_se se, Some (expr_se sew), begin_se loc sel) | Sexpr loc [se :: sel] -> (patt_se se, None, begin_se loc sel) | se -> error se "match_case" ] and label_expr_se loc = fun [ Sexpr _ [se1; se2] -> (patt_se se1, expr_se se2) | se -> error se "label_expr" ] and label_patt_se loc = fun [ Sexpr _ [se1; se2] -> (patt_se se1, patt_se se2) | se -> error se "label_patt" ] and parser_cases_se loc = fun [ [] -> <:expr< raise Stream.Failure >> | [Sexpr loc [Sexpr _ spsel :: act] :: sel] -> let ekont _ = parser_cases_se loc sel in let act = match act with [ [se] -> expr_se se | [sep; se] -> let p = patt_se sep in let e = expr_se se in <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >> | _ -> error_loc loc "parser_case" ] in stream_pattern_se loc act ekont spsel | [se :: _] -> error se "parser_case" ] and stream_pattern_se loc act ekont = fun [ [] -> act | [se :: sel] -> let ckont err = <:expr< raise (Stream.Error $err$) >> in let skont = stream_pattern_se loc act ckont sel in stream_pattern_component skont ekont <:expr< "" >> se ] and stream_pattern_component skont ekont err = fun [ Sexpr loc [Slid _ "`"; se :: wol] -> let wo = match wol with [ [se] -> Some (expr_se se) | [] -> None | _ -> error_loc loc "stream_pattern_component" ] in let e = peek_fun loc in let p = patt_se se in let j = junk_fun loc in let k = ekont err in <:expr< match $e$ $lid:strm_n$ with [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ } | _ -> $k$ ] >> | Sexpr loc [se1; se2] -> let p = patt_se se1 in let e = let e = expr_se se2 in <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >> in let k = ekont err in <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >> | Sexpr loc [Slid _ "?"; se1; se2] -> stream_pattern_component skont ekont (expr_se se2) se1 | Slid loc s -> let s = Pcaml.rename_id.val s in <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >> | se -> error se "stream_pattern_component" ] and patt_se = fun [ Sacc loc se1 se2 -> let p1 = patt_se se1 in let p2 = patt_se se2 in <:patt< $p1$ . $p2$ >> | Slid loc "_" -> <:patt< _ >> | Slid loc s -> <:patt< $lid:(Pcaml.rename_id.val s)$ >> | Suid loc s -> <:patt< $uid:(Pcaml.rename_id.val s)$ >> | Sint loc s -> <:patt< $int:s$ >> | Sfloat loc s -> <:patt< $flo:s$ >> | Schar loc s -> <:patt< $chr:s$ >> | Sstring loc s -> <:patt< $str:s$ >> | Stid loc _ -> error_loc loc "patt" | Sqid loc _ -> error_loc loc "patt" | Srec loc sel -> let lpl = List.map (label_patt_se loc) sel in <:patt< { $list:lpl$ } >> | Sexpr loc [Slid _ ":"; se1; se2] -> let p = patt_se se1 in let t = ctyp_se se2 in <:patt< ($p$ : $t$) >> | Sexpr loc [Slid _ "or"; se :: sel] -> List.fold_left (fun p se -> let p1 = patt_se se in <:patt< $p$ | $p1$ >>) (patt_se se) sel | Sexpr loc [Slid _ "range"; se1; se2] -> let p1 = patt_se se1 in let p2 = patt_se se2 in <:patt< $p1$ .. $p2$ >> | Sexpr loc [Slid _ "values" :: sel] -> let pl = List.map patt_se sel in <:patt< ( $list:pl$ ) >> | Sexpr loc [Slid _ "as"; se1; se2] -> let p1 = patt_se se1 in let p2 = patt_se se2 in <:patt< ($p1$ as $p2$) >> | Sexpr loc [se :: sel] -> List.fold_left (fun p se -> let p1 = patt_se se in <:patt< $p$ $p1$ >>) (patt_se se) sel | Sexpr loc [] -> <:patt< () >> | Slist loc sel -> let rec loop = fun [ [] -> <:patt< [] >> | [se1; Slid _ "."; se2] -> let p = patt_se se1 in let pl = patt_se se2 in <:patt< [$p$ :: $pl$] >> | [se :: sel] -> let p = patt_se se in let pl = loop sel in <:patt< [$p$ :: $pl$] >> ] in loop sel | Squot loc typ txt -> Pcaml.handle_patt_quotation loc (typ, txt) ] and ipatt_se se = match ipatt_opt_se se with [ Left p -> p | Right (se, _) -> error se "ipatt" ] and ipatt_opt_se = fun [ Slid loc "_" -> Left <:patt< _ >> | Slid loc s -> Left <:patt< $lid:(Pcaml.rename_id.val s)$ >> | Stid loc s -> Left <:patt< ~ $(Pcaml.rename_id.val s)$ >> | Sqid loc s -> Left <:patt< ? $(Pcaml.rename_id.val s)$ >> | Sexpr loc [Sqid _ s; se] -> let s = Pcaml.rename_id.val s in let e = expr_se se in Left <:patt< ? ( $lid:s$ = $e$ ) >> | Sexpr loc [Slid _ ":"; se1; se2] -> let p = ipatt_se se1 in let t = ctyp_se se2 in Left <:patt< ($p$ : $t$) >> | Sexpr loc [Slid _ "values" :: sel] -> let pl = List.map ipatt_se sel in Left <:patt< ( $list:pl$ ) >> | Sexpr loc [] -> Left <:patt< () >> | Sexpr loc [se :: sel] -> Right (se, sel) | se -> error se "ipatt" ] and type_declaration_list_se = fun [ [se1; se2 :: sel] -> let (n1, loc1, tpl) = match se1 with [ Sexpr _ [Slid loc n :: sel] -> (n, loc, List.map type_parameter_se sel) | Slid loc n -> (n, loc, []) | se -> error se "type declaration" ] in [((loc1, Pcaml.rename_id.val n1), tpl, ctyp_se se2, []) :: type_declaration_list_se sel] | [] -> [] | [se :: _] -> error se "type_declaration" ] and type_parameter_se = fun [ Slid _ s when String.length s >= 2 && s.[0] = ''' -> (String.sub s 1 (String.length s - 1), (False, False)) | se -> error se "type_parameter" ] and ctyp_se = fun [ Sexpr loc [Slid _ "sum" :: sel] -> let cdl = List.map constructor_declaration_se sel in <:ctyp< [ $list:cdl$ ] >> | Srec loc sel -> let ldl = List.map label_declaration_se sel in <:ctyp< { $list:ldl$ } >> | Sexpr loc [Slid _ "->" :: ([_; _ :: _] as sel)] -> let rec loop = fun [ [] -> assert False | [se] -> ctyp_se se | [se :: sel] -> let t1 = ctyp_se se in let loc = (fst (loc_of_sexpr se), snd loc) in let t2 = loop sel in <:ctyp< $t1$ -> $t2$ >> ] in loop sel | Sexpr loc [Slid _ "*" :: sel] -> let tl = List.map ctyp_se sel in <:ctyp< ($list:tl$) >> | Sexpr loc [se :: sel] -> List.fold_left (fun t se -> let t2 = ctyp_se se in <:ctyp< $t$ $t2$ >>) (ctyp_se se) sel | Sacc loc se1 se2 -> let t1 = ctyp_se se1 in let t2 = ctyp_se se2 in <:ctyp< $t1$ . $t2$ >> | Slid loc "_" -> <:ctyp< _ >> | Slid loc s -> if s.[0] = ''' then let s = String.sub s 1 (String.length s - 1) in <:ctyp< '$s$ >> else <:ctyp< $lid:(Pcaml.rename_id.val s)$ >> | Suid loc s -> <:ctyp< $uid:(Pcaml.rename_id.val s)$ >> | se -> error se "ctyp" ] and constructor_declaration_se = fun [ Sexpr loc [Suid _ ci :: sel] -> (loc, Pcaml.rename_id.val ci, List.map ctyp_se sel) | se -> error se "constructor_declaration" ] and label_declaration_se = fun [ Sexpr loc [Slid _ lab; Slid _ "mutable"; se] -> (loc, Pcaml.rename_id.val lab, True, ctyp_se se) | Sexpr loc [Slid _ lab; se] -> (loc, Pcaml.rename_id.val lab, False, ctyp_se se) | se -> error se "label_declaration" ] ; value directive_se = fun [ Sexpr _ [Slid _ s] -> (s, None) | Sexpr _ [Slid _ s; se] -> let e = expr_se se in (s, Some e) | se -> error se "directive" ] ; (* Parser *) Pcaml.syntax_name.val := "Scheme"; Pcaml.no_constructors_arity.val := False; do { Grammar.Unsafe.gram_reinit gram (lexer_gmake ()); Grammar.Unsafe.clear_entry interf; Grammar.Unsafe.clear_entry implem; Grammar.Unsafe.clear_entry top_phrase; Grammar.Unsafe.clear_entry use_file; Grammar.Unsafe.clear_entry module_type; Grammar.Unsafe.clear_entry module_expr; Grammar.Unsafe.clear_entry sig_item; Grammar.Unsafe.clear_entry str_item; Grammar.Unsafe.clear_entry expr; Grammar.Unsafe.clear_entry patt; Grammar.Unsafe.clear_entry ctyp; Grammar.Unsafe.clear_entry let_binding; Grammar.Unsafe.clear_entry type_declaration; Grammar.Unsafe.clear_entry class_type; Grammar.Unsafe.clear_entry class_expr; Grammar.Unsafe.clear_entry class_sig_item; Grammar.Unsafe.clear_entry class_str_item }; Pcaml.parse_interf.val := Grammar.Entry.parse interf; Pcaml.parse_implem.val := Grammar.Entry.parse implem; value sexpr = Grammar.Entry.create gram "sexpr"; value rec leftify = fun [ Sacc loc1 se1 se2 -> match leftify se2 with [ Sacc loc2 se2 se3 -> Sacc loc1 (Sacc loc2 se1 se2) se3 | se2 -> Sacc loc1 se1 se2 ] | x -> x ] ; EXTEND GLOBAL: implem interf top_phrase use_file str_item sig_item expr patt sexpr; implem: [ [ "#"; se = sexpr -> let (n, dp) = directive_se se in ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True) | si = str_item; x = SELF -> let (sil, stopped) = x in let loc = MLast.loc_of_str_item si in ([(si, loc) :: sil], stopped) | EOI -> ([], False) ] ] ; interf: [ [ "#"; se = sexpr -> let (n, dp) = directive_se se in ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True) | si = sig_item; x = SELF -> let (sil, stopped) = x in let loc = MLast.loc_of_sig_item si in ([(si, loc) :: sil], stopped) | EOI -> ([], False) ] ] ; top_phrase: [ [ "#"; se = sexpr -> let (n, dp) = directive_se se in Some <:str_item< # $n$ $opt:dp$ >> | se = sexpr -> Some (str_item_se se) | EOI -> None ] ] ; use_file: [ [ "#"; se = sexpr -> let (n, dp) = directive_se se in ([<:str_item< # $n$ $opt:dp$ >>], True) | si = str_item; x = SELF -> let (sil, stopped) = x in ([si :: sil], stopped) | EOI -> ([], False) ] ] ; str_item: [ [ se = sexpr -> str_item_se se | e = expr -> <:str_item< $exp:e$ >> ] ] ; sig_item: [ [ se = sexpr -> sig_item_se se ] ] ; expr: [ "top" [ se = sexpr -> expr_se se ] ] ; patt: [ [ se = sexpr -> patt_se se ] ] ; sexpr: [ [ se1 = sexpr_dot; se2 = SELF -> leftify (Sacc loc se1 se2) ] | [ "("; sl = LIST0 sexpr; ")" -> Sexpr loc sl | "("; sl = LIST0 sexpr; ")."; se = SELF -> leftify (Sacc loc (Sexpr loc sl) se) | "["; sl = LIST0 sexpr; "]" -> Slist loc sl | "{"; sl = LIST0 sexpr; "}" -> Srec loc sl | a = pa_extend_keyword -> Slid loc a | s = LIDENT -> Slid loc s | s = UIDENT -> Suid loc s | s = TILDEIDENT -> Stid loc s | s = QUESTIONIDENT -> Sqid loc s | s = INT -> Sint loc s | s = FLOAT -> Sfloat loc s | s = CHAR -> Schar loc s | s = STRING -> Sstring loc s | s = QUOT -> let i = String.index s ':' in let typ = String.sub s 0 i in let txt = String.sub s (i + 1) (String.length s - i - 1) in Squot loc typ txt ] ] ; sexpr_dot: [ [ s = LIDENTDOT -> Slid loc s | s = UIDENTDOT -> Suid loc s ] ] ; pa_extend_keyword: [ [ "_" -> "_" | "," -> "," | "=" -> "=" | ":" -> ":" | "." -> "." | "/" -> "/" ] ] ; END; mingw-ocaml/ocaml/camlp4/unmaintained/scheme/.depend0000644000175000017500000000000012124403240022003 0ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/scheme/pa_scheme.sc0000644000175000017500000011307412124403240023036 0ustar tootstoots; pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo ; ********************************************************************** ; ; ; ; Camlp4 ; ; ; ; Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt ; ; ; ; Copyright 2002 Institut National de Recherche en Informatique et ; ; en Automatique. All rights reserved. This file is distributed ; ; under the terms of the GNU Library General Public License, with ; ; the special exception on linking described in file ; ; ../../../LICENSE. ; ; ; ; ********************************************************************** ; (open Pcaml) (open Stdpp) (type (choice 'a 'b) (sum (Left 'a) (Right 'b))) ; Buffer (module Buff (struct (define buff (ref (String.create 80))) (define (store len x) (if (>= len (String.length buff.val)) (:= buff.val (^ buff.val (String.create (String.length buff.val))))) (:= buff.val.[len] x) (succ len)) (define (get len) (String.sub buff.val 0 len)))) ; Lexer (definerec skip_to_eol (parser (((` (or '\n' '\r'))) ()) (((` _) s) (skip_to_eol s)))) (define no_ident ['(' ')' '[' ']' '{' '}' ' ' '\t' '\n' '\r' ';']) (definerec (ident len) (parser (((` '.')) (values (Buff.get len) True)) (((` x (not (List.mem x no_ident))) s) (ident (Buff.store len x) s)) (() (values (Buff.get len) False)))) (define (identifier kwt (values s dot)) (let ((con (try (begin (: (Hashtbl.find kwt s) unit) "") (Not_found (match s.[0] ((range 'A' 'Z') (if dot "UIDENTDOT" "UIDENT")) (_ (if dot "LIDENTDOT" "LIDENT"))))))) (values con s))) (definerec (string len) (parser (((` '"')) (Buff.get len)) (((` '\\') (` c) s) (string (Buff.store (Buff.store len '\\') c) s)) (((` x) s) (string (Buff.store len x) s)))) (definerec (end_exponent_part_under len) (parser (((` (as (range '0' '9') c)) s) (end_exponent_part_under (Buff.store len c) s)) (() (values "FLOAT" (Buff.get len))))) (define (end_exponent_part len) (parser (((` (as (range '0' '9') c)) s) (end_exponent_part_under (Buff.store len c) s)) (() (raise (Stream.Error "ill-formed floating-point constant"))))) (define (exponent_part len) (parser (((` (as (or '+' '-') c)) s) (end_exponent_part (Buff.store len c) s)) (((a (end_exponent_part len))) a))) (definerec (decimal_part len) (parser (((` (as (range '0' '9') c)) s) (decimal_part (Buff.store len c) s)) (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s)) (() (values "FLOAT" (Buff.get len))))) (definerec (number len) (parser (((` (as (range '0' '9') c)) s) (number (Buff.store len c) s)) (((` '.') s) (decimal_part (Buff.store len '.') s)) (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s)) (() (values "INT" (Buff.get len))))) (define binary (parser (((` (as (range '0' '1') c))) c))) (define octal (parser (((` (as (range '0' '7') c))) c))) (define hexa (parser (((` (as (or (range '0' '9') (range 'a' 'f') (range 'A' 'F')) c))) c))) (definerec (digits_under kind len) (parser (((d kind) s) (digits_under kind (Buff.store len d) s)) (() (Buff.get len)))) (define (digits kind bp len) (parser (((d kind) s) (values "INT" (digits_under kind (Buff.store len d) s))) ((s) ep (raise_with_loc (values (Reloc.shift_pos bp Reloc.zero_loc) (Reloc.shift_pos ep Reloc.zero_loc)) (Failure "ill-formed integer constant"))))) (define (base_number kwt bp len) (parser (((` (or 'b' 'B')) s) (digits binary bp (Buff.store len 'b') s)) (((` (or 'o' 'O')) s) (digits octal bp (Buff.store len 'o') s)) (((` (or 'x' 'X')) s) (digits hexa bp (Buff.store len 'x') s)) (((id (ident (Buff.store 0 '#')))) (identifier kwt id)))) (definerec (operator len) (parser (((` '.')) (Buff.get (Buff.store len '.'))) (() (Buff.get len)))) (define (char_or_quote_id x) (parser (((` ''')) (values "CHAR" (String.make 1 x))) ((s) ep (if (List.mem x no_ident) (Stdpp.raise_with_loc (values (Reloc.shift_pos (- ep 2) Reloc.zero_loc) (Reloc.shift_pos (- ep 1) Reloc.zero_loc)) (Stream.Error "bad quote")) (let* ((len (Buff.store (Buff.store 0 ''') x)) ((values s dot) (ident len s))) (values (if dot "LIDENTDOT" "LIDENT") s)))))) (definerec (char len) (parser (((` ''')) len) (((` x) s) (char (Buff.store len x) s)))) (define quote (parser (((` '\\') (len (char (Buff.store 0 '\\')))) (values "CHAR" (Buff.get len))) (((` x) s) (char_or_quote_id x s)))) ; The system with LIDENTDOT and UIDENTDOT is not great (it would be ; better to have a token DOT (actually SPACEDOT and DOT)) but it is ; the only way (that I have found) to have a good behaviour in the ; toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be ; complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the ; parser rule with dot is right associative and we have to reverse ; the resulting tree (using the function leftify). ; This is a complicated issue: the behaviour of the OCaml toplevel ; is strange, anyway. For example, even without Camlp4, The OCaml ; toplevel accepts that: ; # let x = 32;; foo bar match let ) (definerec* ((lexer kwt) (parser (((t (lexer0 kwt)) (_ no_dot)) t))) (no_dot (parser (((` '.')) ep (Stdpp.raise_with_loc (values (Reloc.shift_pos (- ep 1) Reloc.zero_loc) (Reloc.shift_pos ep Reloc.zero_loc)) (Stream.Error "bad dot"))) (() ()))) ((lexer0 kwt) (parser bp (((` (or '\t' '\n' '\r')) s) (lexer0 kwt s)) (((` ' ') s) (after_space kwt s)) (((` ';') (_ skip_to_eol) s) (lexer kwt s)) (((` '(')) (values (values "" "(") (values bp (+ bp 1)))) (((` ')') s) ep (values (values "" (rparen s)) (values bp ep))) (((` '[')) (values (values "" "[") (values bp (+ bp 1)))) (((` ']')) (values (values "" "]") (values bp (+ bp 1)))) (((` '{')) (values (values "" "{") (values bp (+ bp 1)))) (((` '}')) (values (values "" "}") (values bp (+ bp 1)))) (((` '"') (s (string 0))) ep (values (values "STRING" s) (values bp ep))) (((` ''') (tok quote)) ep (values tok (values bp ep))) (((` '<') (tok (less kwt))) ep (values tok (values bp ep))) (((` '-') (tok (minus kwt))) ep (values tok (values bp ep))) (((` '~') (tok tilde)) ep (values tok (values bp ep))) (((` '?') (tok question)) ep (values tok (values bp ep))) (((` '#') (tok (base_number kwt bp (Buff.store 0 '0')))) ep (values tok (values bp ep))) (((` (as (range '0' '9') c)) (tok (number (Buff.store 0 c)))) ep (values tok (values bp ep))) (((` (as (or '+' '*' '/') c)) (id (operator (Buff.store 0 c)))) ep (values (identifier kwt (values id False)) (values bp ep))) (((` x) (id (ident (Buff.store 0 x)))) ep (values (identifier kwt id) (values bp ep))) (() (values (values "EOI" "") (values bp (+ bp 1)))))) (rparen (parser (((` '.')) ").") ((_) ")"))) ((after_space kwt) (parser (((` '.')) ep (values (values "" ".") (values (- ep 1) ep))) (((x (lexer0 kwt))) x))) (tilde (parser (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c)))) (values "TILDEIDENT" s)) (() (values "LIDENT" "~")))) (question (parser (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c)))) (values "QUESTIONIDENT" s)) (() (values "LIDENT" "?")))) ((minus kwt) (parser (((` '.')) (identifier kwt (values "-." False))) (((` (as (range '0' '9') c)) (n (number (Buff.store (Buff.store 0 '-') c)))) ep n) (((id (ident (Buff.store 0 '-')))) (identifier kwt id)))) ((less kwt) (parser (((` ':') (lab (label 0)) (? (` '<') "'<' expected") (q (quotation 0))) (values "QUOT" (^ lab ":" q))) (((id (ident (Buff.store 0 '<')))) (identifier kwt id)))) ((label len) (parser (((` (as (or (range 'a' 'z') (range 'A' 'Z') '_') c)) s) (label (Buff.store len c) s)) (() (Buff.get len)))) ((quotation len) (parser (((` '>') s) (quotation_greater len s)) (((` x) s) (quotation (Buff.store len x) s)) (() (failwith "quotation not terminated")))) ((quotation_greater len) (parser (((` '>')) (Buff.get len)) (((a (quotation (Buff.store len '>')))) a)))) (define (lexer_using kwt (values con prm)) (match con ((or "CHAR" "EOI" "INT" "FLOAT" "LIDENT" "LIDENTDOT" "QUESTIONIDENT" "QUOT" "STRING" "TILDEIDENT" "UIDENT" "UIDENTDOT") ()) ("ANTIQUOT" ()) ("" (try (Hashtbl.find kwt prm) (Not_found (Hashtbl.add kwt prm ())))) (_ (raise (Token.Error (^ "the constructor \"" con "\" is not recognized by Plexer")))))) (define (lexer_text (values con prm)) (cond ((= con "") (^ "'"prm "'")) ((= prm "") con) (else (^ con " \"" prm "\"")))) (define (lexer_gmake ()) (let ((kwt (Hashtbl.create 89))) {(Token.tok_func (Token.lexer_func_of_parser (lambda (s) (let (((values r (values bp ep)) (lexer kwt s))) (values r (values (Reloc.shift_pos bp Reloc.zero_loc) (Reloc.shift_pos ep Reloc.zero_loc))))))) (Token.tok_using (lexer_using kwt)) (Token.tok_removing (lambda)) (Token.tok_match Token.default_match) (Token.tok_text lexer_text) (Token.tok_comm None)})) ; Building AST (type sexpr (sum (Sacc MLast.loc sexpr sexpr) (Schar MLast.loc string) (Sexpr MLast.loc (list sexpr)) (Sint MLast.loc string) (Sfloat MLast.loc string) (Slid MLast.loc string) (Slist MLast.loc (list sexpr)) (Sqid MLast.loc string) (Squot MLast.loc string string) (Srec MLast.loc (list sexpr)) (Sstring MLast.loc string) (Stid MLast.loc string) (Suid MLast.loc string))) (define loc_of_sexpr (lambda_match ((or (Sacc loc _ _) (Schar loc _) (Sexpr loc _) (Sint loc _) (Sfloat loc _) (Slid loc _) (Slist loc _) (Sqid loc _) (Squot loc _ _) (Srec loc _) (Sstring loc _) (Stid loc _) (Suid loc _)) loc))) (define (error_loc loc err) (raise_with_loc loc (Stream.Error (^ err " expected")))) (define (error se err) (error_loc (loc_of_sexpr se) err)) (define strm_n "strm__") (define (peek_fun loc) <:expr< Stream.peek >>) (define (junk_fun loc) <:expr< Stream.junk >>) (define assoc_left_parsed_op_list ["+" "*" "+." "*." "land" "lor" "lxor"]) (define assoc_right_parsed_op_list ["and" "or" "^" "@"]) (define and_by_couple_op_list ["=" "<>" "<" ">" "<=" ">=" "==" "!="]) (define (op_apply loc e1 e2) (lambda_match ("and" <:expr< $e1$ && $e2$ >>) ("or" <:expr< $e1$ || $e2$ >>) (x <:expr< $lid:x$ $e1$ $e2$ >>))) (define string_se (lambda_match ((Sstring loc s) s) (se (error se "string")))) (define mod_ident_se (lambda_match ((Suid _ s) [(Pcaml.rename_id.val s)]) ((Slid _ s) [(Pcaml.rename_id.val s)]) (se (error se "mod_ident")))) (define (lident_expr loc s) (if (&& (> (String.length s) 1) (= s.[0] '`')) (let ((s (String.sub s 1 (- (String.length s) 1)))) <:expr< ` $s$ >>) <:expr< $lid:(Pcaml.rename_id.val s)$ >>)) (definerec* (module_expr_se (lambda_match ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2]) (let* ((s (Pcaml.rename_id.val s)) (mt (module_type_se se1)) (me (module_expr_se se2))) <:module_expr< functor ($s$ : $mt$) -> $me$ >>)) ((Sexpr loc [(Slid _ "struct") . sl]) (let ((mel (List.map str_item_se sl))) <:module_expr< struct $list:mel$ end >>)) ((Sexpr loc [se1 se2]) (let* ((me1 (module_expr_se se1)) (me2 (module_expr_se se2))) <:module_expr< $me1$ $me2$ >>)) ((Suid loc s) <:module_expr< $uid:(Pcaml.rename_id.val s)$ >>) (se (error se "module expr")))) (module_type_se (lambda_match ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2]) (let* ((s (Pcaml.rename_id.val s)) (mt1 (module_type_se se1)) (mt2 (module_type_se se2))) <:module_type< functor ($s$ : $mt1$) -> $mt2$ >>)) ((Sexpr loc [(Slid _ "sig") . sel]) (let ((sil (List.map sig_item_se sel))) <:module_type< sig $list:sil$ end >>)) ((Sexpr loc [(Slid _ "with") se (Sexpr _ sel)]) (let* ((mt (module_type_se se)) (wcl (List.map with_constr_se sel))) <:module_type< $mt$ with $list:wcl$ >>)) ((Suid loc s) <:module_type< $uid:(Pcaml.rename_id.val s)$ >>) (se (error se "module type")))) (with_constr_se (lambda_match ((Sexpr loc [(Slid _ "type") se1 se2]) (let* ((tn (mod_ident_se se1)) (te (ctyp_se se2))) (MLast.WcTyp loc tn [] te))) (se (error se "with constr")))) (sig_item_se (lambda_match ((Sexpr loc [(Slid _ "type") . sel]) (let ((tdl (type_declaration_list_se sel))) <:sig_item< type $list:tdl$ >>)) ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel]) (let* ((c (Pcaml.rename_id.val c)) (tl (List.map ctyp_se sel))) <:sig_item< exception $c$ of $list:tl$ >>)) ((Sexpr loc [(Slid _ "value") (Slid _ s) se]) (let* ((s (Pcaml.rename_id.val s)) (t (ctyp_se se))) <:sig_item< value $s$ : $t$ >>)) ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel]) (let* ((i (Pcaml.rename_id.val i)) (pd (List.map string_se sel)) (t (ctyp_se se))) <:sig_item< external $i$ : $t$ = $list:pd$ >>)) ((Sexpr loc [(Slid _ "module") (Suid _ s) se]) (let* ((s (Pcaml.rename_id.val s)) (mb (module_type_se se))) <:sig_item< module $s$ : $mb$ >>)) ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se]) (let* ((s (Pcaml.rename_id.val s)) (mt (module_type_se se))) <:sig_item< module type $s$ = $mt$ >>)) (se (error se "sig item")))) ((str_item_se se) (match se ((Sexpr loc [(Slid _ "open") se]) (let ((s (mod_ident_se se))) <:str_item< open $s$ >>)) ((Sexpr loc [(Slid _ "type") . sel]) (let ((tdl (type_declaration_list_se sel))) <:str_item< type $list:tdl$ >>)) ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel]) (let* ((c (Pcaml.rename_id.val c)) (tl (List.map ctyp_se sel))) <:str_item< exception $c$ of $list:tl$ >>)) ((Sexpr loc [(Slid _ (as (or "define" "definerec") r)) se . sel]) (let* ((r (= r "definerec")) ((values p e) (fun_binding_se se (begin_se loc sel)))) <:str_item< value $opt:r$ $p$ = $e$ >>)) ((Sexpr loc [(Slid _ (as (or "define*" "definerec*") r)) . sel]) (let* ((r (= r "definerec*")) (lbs (List.map let_binding_se sel))) <:str_item< value $opt:r$ $list:lbs$ >>)) ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel]) (let* ((i (Pcaml.rename_id.val i)) (pd (List.map string_se sel)) (t (ctyp_se se))) <:str_item< external $i$ : $t$ = $list:pd$ >>)) ((Sexpr loc [(Slid _ "module") (Suid _ i) se]) (let* ((i (Pcaml.rename_id.val i)) (mb (module_binding_se se))) <:str_item< module $i$ = $mb$ >>)) ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se]) (let* ((s (Pcaml.rename_id.val s)) (mt (module_type_se se))) <:str_item< module type $s$ = $mt$ >>)) (_ (let* ((loc (loc_of_sexpr se)) (e (expr_se se))) <:str_item< $exp:e$ >>)))) ((module_binding_se se) (module_expr_se se)) (expr_se (lambda_match ((Sacc loc se1 se2) (let ((e1 (expr_se se1))) (match se2 ((Slist loc [se2]) (let ((e2 (expr_se se2))) <:expr< $e1$ .[ $e2$ ] >>)) ((Sexpr loc [se2]) (let ((e2 (expr_se se2))) <:expr< $e1$ .( $e2$ ) >>)) (_ (let ((e2 (expr_se se2))) <:expr< $e1$ . $e2$ >>))))) ((Slid loc s) (lident_expr loc s)) ((Suid loc s) <:expr< $uid:(Pcaml.rename_id.val s)$ >>) ((Sint loc s) <:expr< $int:s$ >>) ((Sfloat loc s) <:expr< $flo:s$ >>) ((Schar loc s) <:expr< $chr:s$ >>) ((Sstring loc s) <:expr< $str:s$ >>) ((Stid loc s) <:expr< ~ $(Pcaml.rename_id.val s)$ >>) ((Sqid loc s) <:expr< ? $(Pcaml.rename_id.val s)$ >>) ((Sexpr loc []) <:expr< () >>) ((when (Sexpr loc [(Slid _ s) e1 . (as [_ . _] sel)]) (List.mem s assoc_left_parsed_op_list)) (letrec (((loop e1) (lambda_match ([] e1) ([e2 . el] (loop (op_apply loc e1 e2 s) el))))) (loop (expr_se e1) (List.map expr_se sel)))) ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)]) (List.mem s assoc_right_parsed_op_list)) (letrec ((loop (lambda_match ([] (assert False)) ([e1] e1) ([e1 . el] (let ((e2 (loop el))) (op_apply loc e1 e2 s)))))) (loop (List.map expr_se sel)))) ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)]) (List.mem s and_by_couple_op_list)) (letrec ((loop (lambda_match ((or [] [_]) (assert False)) ([e1 e2] <:expr< $lid:s$ $e1$ $e2$ >>) ([e1 . (as [e2 _ . _] el)] (let* ((a1 (op_apply loc e1 e2 s)) (a2 (loop el))) <:expr< $a1$ && $a2$ >>))))) (loop (List.map expr_se sel)))) ((Sexpr loc [(Stid _ s) se]) (let ((e (expr_se se))) <:expr< ~ $s$ : $e$ >>)) ((Sexpr loc [(Slid _ "-") se]) (let ((e (expr_se se))) <:expr< - $e$ >>)) ((Sexpr loc [(Slid _ "if") se se1]) (let* ((e (expr_se se)) (e1 (expr_se se1))) <:expr< if $e$ then $e1$ else () >>)) ((Sexpr loc [(Slid _ "if") se se1 se2]) (let* ((e (expr_se se)) (e1 (expr_se se1)) (e2 (expr_se se2))) <:expr< if $e$ then $e1$ else $e2$ >>)) ((Sexpr loc [(Slid _ "cond") . sel]) (letrec ((loop (lambda_match ([(Sexpr loc [(Slid _ "else") . sel])] (begin_se loc sel)) ([(Sexpr loc [se1 . sel1]) . sel] (let* ((e1 (expr_se se1)) (e2 (begin_se loc sel1)) (e3 (loop sel))) <:expr< if $e1$ then $e2$ else $e3$ >>)) ([] <:expr< () >>) ([se . _] (error se "cond clause"))))) (loop sel))) ((Sexpr loc [(Slid _ "while") se . sel]) (let* ((e (expr_se se)) (el (List.map expr_se sel))) <:expr< while $e$ do { $list:el$ } >>)) ((Sexpr loc [(Slid _ "for") (Slid _ i) se1 se2 . sel]) (let* ((i (Pcaml.rename_id.val i)) (e1 (expr_se se1)) (e2 (expr_se se2)) (el (List.map expr_se sel))) <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >>)) ((Sexpr loc [(Slid loc1 "lambda")]) <:expr< fun [] >>) ((Sexpr loc [(Slid loc1 "lambda") sep . sel]) (let ((e (begin_se loc1 sel))) (match (ipatt_opt_se sep) ((Left p) <:expr< fun $p$ -> $e$ >>) ((Right (values se sel)) (List.fold_right (lambda (se e) (let ((p (ipatt_se se))) <:expr< fun $p$ -> $e$ >>)) [se . sel] e))))) ((Sexpr loc [(Slid _ "lambda_match") . sel]) (let ((pel (List.map (match_case loc) sel))) <:expr< fun [ $list:pel$ ] >>)) ((Sexpr loc [(Slid _ (as (or "let" "letrec") r)) . sel]) (match sel ([(Sexpr _ sel1) . sel2] (let* ((r (= r "letrec")) (lbs (List.map let_binding_se sel1)) (e (begin_se loc sel2))) <:expr< let $opt:r$ $list:lbs$ in $e$ >>)) ([(Slid _ n) (Sexpr _ sl) . sel] (let* ((n (Pcaml.rename_id.val n)) ((values pl el) (List.fold_right (lambda (se (values pl el)) (match se ((Sexpr _ [se1 se2]) (values [(patt_se se1) . pl] [(expr_se se2) . el])) (se (error se "named let")))) sl (values [] []))) (e1 (List.fold_right (lambda (p e) <:expr< fun $p$ -> $e$ >>) pl (begin_se loc sel))) (e2 (List.fold_left (lambda (e1 e2) <:expr< $e1$ $e2$ >>) <:expr< $lid:n$ >> el))) <:expr< let rec $lid:n$ = $e1$ in $e2$ >>)) ([se . _] (error se "let_binding")) (_ (error_loc loc "let_binding")))) ((Sexpr loc [(Slid _ "let*") . sel]) (match sel ([(Sexpr _ sel1) . sel2] (List.fold_right (lambda (se ek) (let (((values p e) (let_binding_se se))) <:expr< let $p$ = $e$ in $ek$ >>)) sel1 (begin_se loc sel2))) ([se . _] (error se "let_binding")) (_ (error_loc loc "let_binding")))) ((Sexpr loc [(Slid _ "match") se . sel]) (let* ((e (expr_se se)) (pel (List.map (match_case loc) sel))) <:expr< match $e$ with [ $list:pel$ ] >>)) ((Sexpr loc [(Slid _ "parser") . sel]) (let ((e (match sel ([(as (Slid _ _) se) . sel] (let* ((p (patt_se se)) (pc (parser_cases_se loc sel))) <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>)) (_ (parser_cases_se loc sel))))) <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>)) ((Sexpr loc [(Slid _ "match_with_parser") se . sel]) (let* ((me (expr_se se)) ((values bpo sel) (match sel ([(as (Slid _ _) se) . sel] (values (Some (patt_se se)) sel)) (_ (values None sel)))) (pc (parser_cases_se loc sel)) (e (match bpo ((Some bp) <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>) (None pc)))) (match me ((when <:expr< $lid:x$ >> (= x strm_n)) e) (_ <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >>)))) ((Sexpr loc [(Slid _ "try") se . sel]) (let* ((e (expr_se se)) (pel (List.map (match_case loc) sel))) <:expr< try $e$ with [ $list:pel$ ] >>)) ((Sexpr loc [(Slid _ "begin") . sel]) (let ((el (List.map expr_se sel))) <:expr< do { $list:el$ } >>)) ((Sexpr loc [(Slid _ ":=") se1 se2]) (let* ((e1 (expr_se se1)) (e2 (expr_se se2))) <:expr< $e1$ := $e2$ >>)) ((Sexpr loc [(Slid _ "values") . sel]) (let ((el (List.map expr_se sel))) <:expr< ( $list:el$ ) >>)) ((Srec loc [(Slid _ "with") se . sel]) (let* ((e (expr_se se)) (lel (List.map (label_expr_se loc) sel))) <:expr< { ($e$) with $list:lel$ } >>)) ((Srec loc sel) (let ((lel (List.map (label_expr_se loc) sel))) <:expr< { $list:lel$ } >>)) ((Sexpr loc [(Slid _ ":") se1 se2]) (let* ((e (expr_se se1)) (t (ctyp_se se2))) <:expr< ( $e$ : $t$ ) >>)) ((Sexpr loc [se]) (let ((e (expr_se se))) <:expr< $e$ () >>)) ((Sexpr loc [(Slid _ "assert") (Suid _ "False")]) <:expr< assert False >>) ((Sexpr loc [(Slid _ "assert") se]) (let ((e (expr_se se))) <:expr< assert $e$ >>)) ((Sexpr loc [(Slid _ "lazy") se]) (let ((e (expr_se se))) <:expr< lazy $e$ >>)) ((Sexpr loc [se . sel]) (List.fold_left (lambda (e se) (let ((e1 (expr_se se))) <:expr< $e$ $e1$ >>)) (expr_se se) sel)) ((Slist loc sel) (letrec ((loop (lambda_match ([] <:expr< [] >>) ([se1 (Slid _ ".") se2] (let* ((e (expr_se se1)) (el (expr_se se2))) <:expr< [$e$ :: $el$] >>)) ([se . sel] (let* ((e (expr_se se)) (el (loop sel))) <:expr< [$e$ :: $el$] >>))))) (loop sel))) ((Squot loc typ txt) (Pcaml.handle_expr_quotation loc (values typ txt))))) ((begin_se loc) (lambda_match ([] <:expr< () >>) ([se] (expr_se se)) ((sel) (let* ((el (List.map expr_se sel)) (loc (values (fst (loc_of_sexpr (List.hd sel))) (snd loc)))) <:expr< do { $list:el$ } >>)))) (let_binding_se (lambda_match ((Sexpr loc [se . sel]) (let ((e (begin_se loc sel))) (match (ipatt_opt_se se) ((Left p) (values p e)) ((Right _) (fun_binding_se se e))))) (se (error se "let_binding")))) ((fun_binding_se se e) (match se ((Sexpr _ [(Slid _ "values") . _]) (values (ipatt_se se) e)) ((Sexpr _ [(Slid loc s) . sel]) (let* ((s (Pcaml.rename_id.val s)) (e (List.fold_right (lambda (se e) (let* ((loc (values (fst (loc_of_sexpr se)) (snd (MLast.loc_of_expr e)))) (p (ipatt_se se))) <:expr< fun $p$ -> $e$ >>)) sel e)) (p <:patt< $lid:s$ >>)) (values p e))) ((_) (values (ipatt_se se) e)))) ((match_case loc) (lambda_match ((Sexpr loc [(Sexpr _ [(Slid _ "when") se sew]) . sel]) (values (patt_se se) (Some (expr_se sew)) (begin_se loc sel))) ((Sexpr loc [se . sel]) (values (patt_se se) None (begin_se loc sel))) (se (error se "match_case")))) ((label_expr_se loc) (lambda_match ((Sexpr _ [se1 se2]) (values (patt_se se1) (expr_se se2))) (se (error se "label_expr")))) ((label_patt_se loc) (lambda_match ((Sexpr _ [se1 se2]) (values (patt_se se1) (patt_se se2))) (se (error se "label_patt")))) ((parser_cases_se loc) (lambda_match ([] <:expr< raise Stream.Failure >>) ([(Sexpr loc [(Sexpr _ spsel) . act]) . sel] (let* ((ekont (lambda _ (parser_cases_se loc sel))) (act (match act ([se] (expr_se se)) ([sep se] (let* ((p (patt_se sep)) (e (expr_se se))) <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>)) (_ (error_loc loc "parser_case"))))) (stream_pattern_se loc act ekont spsel))) ([se . _] (error se "parser_case")))) ((stream_pattern_se loc act ekont) (lambda_match ([] act) ([se . sel] (let* ((ckont (lambda err <:expr< raise (Stream.Error $err$) >>)) (skont (stream_pattern_se loc act ckont sel))) (stream_pattern_component skont ekont <:expr< "" >> se))))) ((stream_pattern_component skont ekont err) (lambda_match ((Sexpr loc [(Slid _ "`") se . wol]) (let* ((wo (match wol ([se] (Some (expr_se se))) ([] None) (_ (error_loc loc "stream_pattern_component")))) (e (peek_fun loc)) (p (patt_se se)) (j (junk_fun loc)) (k (ekont err))) <:expr< match $e$ $lid:strm_n$ with [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ } | _ -> $k$ ] >>)) ((Sexpr loc [se1 se2]) (let* ((p (patt_se se1)) (e (let ((e (expr_se se2))) <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>)) (k (ekont err))) <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>)) ((Sexpr loc [(Slid _ "?") se1 se2]) (stream_pattern_component skont ekont (expr_se se2) se1)) ((Slid loc s) (let ((s (Pcaml.rename_id.val s))) <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>)) (se (error se "stream_pattern_component")))) (patt_se (lambda_match ((Sacc loc se1 se2) (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ . $p2$ >>)) ((Slid loc "_") <:patt< _ >>) ((Slid loc s) <:patt< $lid:(Pcaml.rename_id.val s)$ >>) ((Suid loc s) <:patt< $uid:(Pcaml.rename_id.val s)$ >>) ((Sint loc s) <:patt< $int:s$ >>) ((Sfloat loc s) <:patt< $flo:s$ >>) ((Schar loc s) <:patt< $chr:s$ >>) ((Sstring loc s) <:patt< $str:s$ >>) ((Stid loc _) (error_loc loc "patt")) ((Sqid loc _) (error_loc loc "patt")) ((Srec loc sel) (let ((lpl (List.map (label_patt_se loc) sel))) <:patt< { $list:lpl$ } >>)) ((Sexpr loc [(Slid _ ":") se1 se2]) (let* ((p (patt_se se1)) (t (ctyp_se se2))) <:patt< ($p$ : $t$) >>)) ((Sexpr loc [(Slid _ "or") se . sel]) (List.fold_left (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ | $p1$ >>)) (patt_se se) sel)) ((Sexpr loc [(Slid _ "range") se1 se2]) (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ .. $p2$ >>)) ((Sexpr loc [(Slid _ "values") . sel]) (let ((pl (List.map patt_se sel))) <:patt< ( $list:pl$ ) >>)) ((Sexpr loc [(Slid _ "as") se1 se2]) (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< ($p1$ as $p2$) >>)) ((Sexpr loc [se . sel]) (List.fold_left (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ $p1$ >>)) (patt_se se) sel)) ((Sexpr loc []) <:patt< () >>) ((Slist loc sel) (letrec ((loop (lambda_match ([] <:patt< [] >>) ([se1 (Slid _ ".") se2] (let* ((p (patt_se se1)) (pl (patt_se se2))) <:patt< [$p$ :: $pl$] >>)) ([se . sel] (let* ((p (patt_se se)) (pl (loop sel))) <:patt< [$p$ :: $pl$] >>))))) (loop sel))) ((Squot loc typ txt) (Pcaml.handle_patt_quotation loc (values typ txt))))) ((ipatt_se se) (match (ipatt_opt_se se) ((Left p) p) ((Right (values se _)) (error se "ipatt")))) (ipatt_opt_se (lambda_match ((Slid loc "_") (Left <:patt< _ >>)) ((Slid loc s) (Left <:patt< $lid:(Pcaml.rename_id.val s)$ >>)) ((Stid loc s) (Left <:patt< ~ $(Pcaml.rename_id.val s)$ >>)) ((Sqid loc s) (Left <:patt< ? $(Pcaml.rename_id.val s)$ >>)) ((Sexpr loc [(Sqid _ s) se]) (let* ((s (Pcaml.rename_id.val s)) (e (expr_se se))) (Left <:patt< ? ( $lid:s$ = $e$ ) >>))) ((Sexpr loc [(Slid _ ":") se1 se2]) (let* ((p (ipatt_se se1)) (t (ctyp_se se2))) (Left <:patt< ($p$ : $t$) >>))) ((Sexpr loc [(Slid _ "values") . sel]) (let ((pl (List.map ipatt_se sel))) (Left <:patt< ( $list:pl$ ) >>))) ((Sexpr loc []) (Left <:patt< () >>)) ((Sexpr loc [se . sel]) (Right (values se sel))) (se (error se "ipatt")))) (type_declaration_list_se (lambda_match ([se1 se2 . sel] (let (((values n1 loc1 tpl) (match se1 ((Sexpr _ [(Slid loc n) . sel]) (values n loc (List.map type_parameter_se sel))) ((Slid loc n) (values n loc [])) ((se) (error se "type declaration"))))) [(values (values loc1 (Pcaml.rename_id.val n1)) tpl (ctyp_se se2) []) . (type_declaration_list_se sel)])) ([] []) ([se . _] (error se "type_declaration")))) (type_parameter_se (lambda_match ((when (Slid _ s) (and (>= (String.length s) 2) (= s.[0] '''))) (values (String.sub s 1 (- (String.length s) 1)) (values False False))) (se (error se "type_parameter")))) (ctyp_se (lambda_match ((Sexpr loc [(Slid _ "sum") . sel]) (let ((cdl (List.map constructor_declaration_se sel))) <:ctyp< [ $list:cdl$ ] >>)) ((Srec loc sel) (let ((ldl (List.map label_declaration_se sel))) <:ctyp< { $list:ldl$ } >>)) ((Sexpr loc [(Slid _ "->") . (as [_ _ . _] sel)]) (letrec ((loop (lambda_match ([] (assert False)) ([se] (ctyp_se se)) ([se . sel] (let* ((t1 (ctyp_se se)) (loc (values (fst (loc_of_sexpr se)) (snd loc))) (t2 (loop sel))) <:ctyp< $t1$ -> $t2$ >>))))) (loop sel))) ((Sexpr loc [(Slid _ "*") . sel]) (let ((tl (List.map ctyp_se sel))) <:ctyp< ($list:tl$) >>)) ((Sexpr loc [se . sel]) (List.fold_left (lambda (t se) (let ((t2 (ctyp_se se))) <:ctyp< $t$ $t2$ >>)) (ctyp_se se) sel)) ((Sacc loc se1 se2) (let* ((t1 (ctyp_se se1)) (t2 (ctyp_se se2))) <:ctyp< $t1$ . $t2$ >>)) ((Slid loc "_") <:ctyp< _ >>) ((Slid loc s) (if (= s.[0] ''') (let ((s (String.sub s 1 (- (String.length s) 1)))) <:ctyp< '$s$ >>) <:ctyp< $lid:(Pcaml.rename_id.val s)$ >>)) ((Suid loc s) <:ctyp< $uid:(Pcaml.rename_id.val s)$ >>) (se (error se "ctyp")))) (constructor_declaration_se (lambda_match ((Sexpr loc [(Suid _ ci) . sel]) (values loc (Pcaml.rename_id.val ci) (List.map ctyp_se sel))) (se (error se "constructor_declaration")))) (label_declaration_se (lambda_match ((Sexpr loc [(Slid _ lab) (Slid _ "mutable") se]) (values loc (Pcaml.rename_id.val lab) True (ctyp_se se))) ((Sexpr loc [(Slid _ lab) se]) (values loc (Pcaml.rename_id.val lab) False (ctyp_se se))) (se (error se "label_declaration"))))) (define directive_se (lambda_match ((Sexpr _ [(Slid _ s)]) (values s None)) ((Sexpr _ [(Slid _ s) se]) (let ((e (expr_se se))) (values s (Some e)))) (se (error se "directive")))) ; Parser (:= Pcaml.syntax_name.val "Scheme") (:= Pcaml.no_constructors_arity.val False) (begin (Grammar.Unsafe.gram_reinit gram (lexer_gmake ())) (Grammar.Unsafe.clear_entry interf) (Grammar.Unsafe.clear_entry implem) (Grammar.Unsafe.clear_entry top_phrase) (Grammar.Unsafe.clear_entry use_file) (Grammar.Unsafe.clear_entry module_type) (Grammar.Unsafe.clear_entry module_expr) (Grammar.Unsafe.clear_entry sig_item) (Grammar.Unsafe.clear_entry str_item) (Grammar.Unsafe.clear_entry expr) (Grammar.Unsafe.clear_entry patt) (Grammar.Unsafe.clear_entry ctyp) (Grammar.Unsafe.clear_entry let_binding) (Grammar.Unsafe.clear_entry type_declaration) (Grammar.Unsafe.clear_entry class_type) (Grammar.Unsafe.clear_entry class_expr) (Grammar.Unsafe.clear_entry class_sig_item) (Grammar.Unsafe.clear_entry class_str_item)) (:= Pcaml.parse_interf.val (Grammar.Entry.parse interf)) (:= Pcaml.parse_implem.val (Grammar.Entry.parse implem)) (define sexpr (Grammar.Entry.create gram "sexpr")) (definerec leftify (lambda_match ((Sacc loc1 se1 se2) (match (leftify se2) ((Sacc loc2 se2 se3) (Sacc loc1 (Sacc loc2 se1 se2) se3)) (se2 (Sacc loc1 se1 se2)))) (x x))) EXTEND GLOBAL : implem interf top_phrase use_file str_item sig_item expr patt sexpr / implem : [ [ "#" / se = sexpr -> (let (((values n dp) (directive_se se))) (values [(values <:str_item< # $n$ $opt:dp$ >> loc)] True)) | si = str_item / x = SELF -> (let* (((values sil stopped) x) (loc (MLast.loc_of_str_item si))) (values [(values si loc) . sil] stopped)) | EOI -> (values [] False) ] ] / interf : [ [ "#" / se = sexpr -> (let (((values n dp) (directive_se se))) (values [(values <:sig_item< # $n$ $opt:dp$ >> loc)] True)) | si = sig_item / x = SELF -> (let* (((values sil stopped) x) (loc (MLast.loc_of_sig_item si))) (values [(values si loc) . sil] stopped)) | EOI -> (values [] False) ] ] / top_phrase : [ [ "#" / se = sexpr -> (let (((values n dp) (directive_se se))) (Some <:str_item< # $n$ $opt:dp$ >>)) | se = sexpr -> (Some (str_item_se se)) | EOI -> None ] ] / use_file : [ [ "#" / se = sexpr -> (let (((values n dp) (directive_se se))) (values [<:str_item< # $n$ $opt:dp$ >>] True)) | si = str_item / x = SELF -> (let (((values sil stopped) x)) (values [si . sil] stopped)) | EOI -> (values [] False) ] ] / str_item : [ [ se = sexpr -> (str_item_se se) | e = expr -> <:str_item< $exp:e$ >> ] ] / sig_item : [ [ se = sexpr -> (sig_item_se se) ] ] / expr : [ "top" [ se = sexpr -> (expr_se se) ] ] / patt : [ [ se = sexpr -> (patt_se se) ] ] / sexpr : [ [ se1 = sexpr_dot / se2 = sexpr -> (leftify (Sacc loc se1 se2)) ] | [ "(" / sl = LIST0 sexpr / ")" -> (Sexpr loc sl) | "(" / sl = LIST0 sexpr / ")." / se = sexpr -> (leftify (Sacc loc (Sexpr loc sl) se)) | "[" / sl = LIST0 sexpr / "]" -> (Slist loc sl) | "{" / sl = LIST0 sexpr / "}" -> (Srec loc sl) | a = pa_extend_keyword -> (Slid loc a) | s = LIDENT -> (Slid loc s) | s = UIDENT -> (Suid loc s) | s = TILDEIDENT -> (Stid loc s) | s = QUESTIONIDENT -> (Sqid loc s) | s = INT -> (Sint loc s) | s = FLOAT -> (Sfloat loc s) | s = CHAR -> (Schar loc s) | s = STRING -> (Sstring loc s) | s = QUOT -> (let* ((i (String.index s ':')) (typ (String.sub s 0 i)) (txt (String.sub s (+ i 1) (- (- (String.length s) i) 1)))) (Squot loc typ txt)) ] ] / sexpr_dot : [ [ s = LIDENTDOT -> (Slid loc s) | s = UIDENTDOT -> (Suid loc s) ] ] / pa_extend_keyword : [ [ "_" -> "_" | "," -> "," | "=" -> "=" | ":" -> ":" | "." -> "." | "/" -> "/" ] ] / END mingw-ocaml/ocaml/camlp4/unmaintained/format/0000755000175000017500000000000012124403240020601 5ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/format/Makefile0000644000175000017500000000375312124403240022251 0ustar tootstoots######################################################################### # # # OCaml # # # # Camlp4 # # # # Copyright 2004 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../../LICENSE.# # # ######################################################################### # # Makefile for pa_format # M.Mauny # include ../../config/Makefile.cnf OCAMLTOP=../../.. CAMLP4=../../camlp4/camlp4$(EXE) OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) P4INCLUDES= -nolib -I ../../lib -I ../../meta -I ../../etc OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../lib -I ../../camlp4 OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) SRC=pa_format.ml OBJS=$(SRC:.ml=.cmo) OBJSX=$(SRC:.ml=.cmx) all: $(OBJS) opt: $(OBJSX) depend: cp .depend .depend.bak > .depend for file in $(SRC); do \ $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ done clean: rm -f *.cm* *.$(O) *.bak .*.bak .SUFFIXES: .cmx .cmo .cmi .ml .mli .mli.cmi: $(OCAMLC) $(OCAMLCFLAGS) -c $< .ml.cmo: $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< .ml.cmx: $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< include .depend mingw-ocaml/ocaml/camlp4/unmaintained/format/README0000644000175000017500000000104312124403240021457 0ustar tootstootsThis is an application of or an extension for Camlp4. Although it is currently distributed with OCaml/Camlp4, it may or may not be actively maintained. It probably won't be part of future OCaml/Camlp4 distributions but be accessible from the Camlp4 hump. If you are interested in developing this package further and/or actively maintain it, please let us know (caml@inria.fr) This package is distributed under the same license as the OCaml Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny mingw-ocaml/ocaml/camlp4/unmaintained/format/.depend0000644000175000017500000000000012124403240022027 0ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/format/pa_format.ml0000644000175000017500000000440512124403240023106 0ustar tootstoots(* pa_r.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file *) (* ../../../LICENSE. *) (* *) (***********************************************************************) open Pcaml; EXTEND GLOBAL: expr; expr: LEVEL "top" [ [ n = box_type; d = SELF; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" -> let el = [<:expr< Format.$lid:"open_" ^ n$ $d$ >> :: el] in let el = el @ [<:expr< Format.close_box () >>] in <:expr< do { $list:el$ } >> | "hbox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" -> let el = [<:expr< Format.open_hbox () >> :: el] in let el = el @ [<:expr< Format.close_box () >>] in <:expr< do { $list:el$ } >> | "nobox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" -> match el with [ [e] -> e | _ -> <:expr< do { $list:el$ } >> ] ] ] ; box_type: [ [ n = "hovbox" -> n | n = "hvbox" -> n | n = "vbox" -> n | n = "box" -> n ] ] ; box_expr: [ [ s = STRING -> <:expr< Format.print_string $str:s$ >> | UIDENT "STRING"; e = expr -> <:expr< Format.print_string $e$ >> | UIDENT "INT"; e = expr -> <:expr< Format.print_int $e$ >> | "/-" -> <:expr< Format.print_space () >> | "//" -> <:expr< Format.print_cut () >> | "!/" -> <:expr< Format.force_newline () >> | "?/" -> <:expr< Format.print_if_newline () >> | e = expr -> e ] ] ; END; mingw-ocaml/ocaml/camlp4/unmaintained/odyl/0000755000175000017500000000000012124403240020260 5ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/odyl/.ignore0000644000175000017500000000003212124403240021537 0ustar tootstootsodyl *.lib odyl_config.ml mingw-ocaml/ocaml/camlp4/unmaintained/odyl/Makefile0000644000175000017500000000322112124403240021716 0ustar tootstoots include ../config/Makefile.cnf EXECUTABLES=odyl INCLUDES=-I $(OTOP)/otherlibs/dynlink OBJS=odyl_config.cmo odyl_main.cmo OBJSX=odyl.cmx odyl.cmxa CLEANFILES=odyl_config.ml include ../config/Makefile.base odyl$(EXE): odyl.cma odyl.cmo $(OCAMLC) odyl.cma odyl.cmo -o $@ odyl.opt: odyl.cmxa odyl.cmx $(OCAMLOPT) odyl.cmxa odyl.cmx -o $@ odyl.cma: $(OBJS) $(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o $@ odyl.cmxa: $(OBJSX) $(OCAMLOPT) $(LINKFLAGS) $(OBJSX) -a -o $@ odyl.p.cmxa: $(OBJSP) $(OCAMLOPT) $(LINKFLAGS) $(OBJSP) -a -o $@ odyl_main.cmx: odyl_main.ml $(CAMLP4BOOT) -nolib -DOPT -o odyl_main.ppo odyl_main.ml $(OCAMLOPT) -c -impl odyl_main.ppo rm -f odyl_main.ppo odyl_main.p.cmx: odyl_main.ml $(CAMLP4BOOT) -nolib -DOPT -o odyl_main.ppo odyl_main.ml $(OCAMLOPT) -p -c -o $@ -impl odyl_main.ppo rm -f odyl_main.ppo odyl_config.ml: (echo '(* camlp4r *)'; \ echo 'value standard_library ='; \ echo ' try Sys.getenv "CAMLP4LIB" with [ Not_found -> '; \ echo ' try Sys.getenv "OCAMLLIB" ^ "/camlp4" with [ Not_found -> '; \ echo ' try Sys.getenv "CAMLLIB" ^ "/camlp4" with [ Not_found -> '; \ echo ' "$(LIBDIR)/camlp4"]]];') \ | sed -e 's|\\|/|g' > odyl_config.ml install-local: -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" cp odyl.cmo odyl.cma odyl_main.cmi $(LIBDIR)/camlp4/. for f in odyl.$(A) odyl.p.$(A) ; do \ if test -f $$f ; then \ cp $$f "$(LIBDIR)/camlp4/." && ( cd "$(LIBDIR)/camlp4/." && $(RANLIB) $$f ) ; \ fi ; \ done for f in odyl.cmx odyl.o odyl.p.cmx odyl.p.o odyl.cmxa odyl.p.cmxa ; do \ if test -f $$f ; then \ cp $$f "$(LIBDIR)/camlp4/." ; \ fi ; \ done include .depend mingw-ocaml/ocaml/camlp4/unmaintained/odyl/odyl.ml0000644000175000017500000000373112124403240021565 0ustar tootstoots(* camlp4r *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) value apply_load () = let i = ref 1 in let stop = ref False in while not stop.val && i.val < Array.length Sys.argv do { let s = Sys.argv.(i.val) in if s = "-I" && i.val + 1 < Array.length Sys.argv then do { Odyl_main.directory Sys.argv.(i.val + 1); i.val := i.val + 2 } else if s = "-nolib" then do { Odyl_main.nolib.val := True; incr i } else if s = "-where" then do { print_string Odyl_config.standard_library; print_newline (); flush stdout; exit 0 } else if s = "-version" then do { print_string Sys.ocaml_version; print_newline (); flush stdout; exit 0 } else if s = "--" then do { incr i; stop.val := True; () } else if String.length s > 0 && s.[0] == '-' then stop.val := True else if Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma" then do { Odyl_main.loadfile s; incr i } else stop.val := True } ; value main () = try do { apply_load () ; Odyl_main.go.val () } with [ Odyl_main.Error fname str -> do { flush stdout; Printf.eprintf "Error while loading \"%s\": " fname; Printf.eprintf "%s.\n" str; flush stderr; exit 2 } ] ; Printexc.catch main (); mingw-ocaml/ocaml/camlp4/unmaintained/odyl/odyl_main.mli0000644000175000017500000000041112124403240022732 0ustar tootstoots(* camlp4r *) exception Error of string and string; value nolib : ref bool; value initialized : ref bool; value path : ref (list string); value loadfile : string -> unit; value directory : string -> unit; value go : ref (unit -> unit); value name : ref string; mingw-ocaml/ocaml/camlp4/unmaintained/odyl/.depend0000644000175000017500000000025212124403240021517 0ustar tootstootsodyl.cmo: odyl_main.cmi odyl_config.cmo odyl.cmx: odyl_main.cmx odyl_config.cmx odyl_main.cmo: odyl_config.cmo odyl_main.cmi odyl_main.cmx: odyl_config.cmx odyl_main.cmi mingw-ocaml/ocaml/camlp4/unmaintained/olabl/0000755000175000017500000000000012124403240020402 5ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/olabl/pa_olabl.ml0000644000175000017500000021143412124403240022512 0ustar tootstoots(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file *) (* ../../../LICENSE. *) (* *) (***********************************************************************) module Plexer = struct open Stdpp; open Token; value buff = ref (String.create 80); value store len x = do { if len >= String.length buff.val then buff.val := buff.val ^ String.create (String.length buff.val) else (); buff.val.[len] := x; succ len } ; value mstore len s = add_rec len 0 where rec add_rec len i = if i == String.length s then len else add_rec (store len s.[i]) (succ i) ; value get_buff len = String.sub buff.val 0 len; value rec ident len = parser [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255' | '0'..'9' | '_' | ''' as c) ; s :] -> ident (store len c) s | [: :] -> len ] and ident2 len = parser [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' | '.' | ':' | '<' | '>' | '|' as c) ; s :] -> ident2 (store len c) s | [: :] -> len ] and ident3 len = parser [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | ''' | '$' as c) ; s :] -> ident3 (store len c) s | [: :] -> len ] and ident4 len = parser [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' | '.' | '<' | '>' | '|' as c) ; s :] -> ident4 (store len c) s | [: :] -> len ] and base_number len = parser [ [: `'o' | 'O'; s :] -> octal_digits (store len 'o') s | [: `'x' | 'X'; s :] -> hexa_digits (store len 'x') s | [: `'b' | 'B'; s :] -> binary_digits (store len 'b') s | [: a = number len :] -> a ] and octal_digits len = parser [ [: `('0'..'7' as d); s :] -> octal_digits (store len d) s | [: :] -> ("INT", get_buff len) ] and hexa_digits len = parser [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d); s :] -> hexa_digits (store len d) s | [: :] -> ("INT", get_buff len) ] and binary_digits len = parser [ [: `('0'..'1' as d); s :] -> binary_digits (store len d) s | [: :] -> ("INT", get_buff len) ] and number len = parser [ [: `('0'..'9' as c); s :] -> number (store len c) s | [: `'.'; s :] -> decimal_part (store len '.') s | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s | [: :] -> ("INT", get_buff len) ] and decimal_part len = parser [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s | [: :] -> ("FLOAT", get_buff len) ] and exponent_part len = parser [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s | [: a = end_exponent_part len :] -> a ] and end_exponent_part len = parser [ [: `('0'..'9' as c); s :] -> end_exponent_part (store len c) s | [: :] -> ("FLOAT", get_buff len) ] ; value valch x = Char.code x - Char.code '0'; value rec backslash s i = if i = String.length s then raise Not_found else match s.[i] with [ 'n' -> ('\n', i + 1) | 'r' -> ('\r', i + 1) | 't' -> ('\t', i + 1) | 'b' -> ('\b', i + 1) | '\\' -> ('\\', i + 1) | '0'..'9' as c -> backslash1 (valch c) s (i + 1) | _ -> raise Not_found ] and backslash1 cod s i = if i = String.length s then (Char.chr cod, i) else match s.[i] with [ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) | _ -> (Char.chr cod, i) ] and backslash2 cod s i = if i = String.length s then (Char.chr cod, i) else match s.[i] with [ '0'..'9' as c -> (Char.chr (10 * cod + valch c), i + 1) | _ -> (Char.chr cod, i) ] ; value rec skip_indent s i = if i = String.length s then i else match s.[i] with [ ' ' | '\t' -> skip_indent s (i + 1) | _ -> i ] ; value skip_opt_linefeed s i = if i = String.length s then i else if s.[i] = '\010' then i + 1 else i ; value char_of_char_token s = if String.length s = 1 then s.[0] else if String.length s = 0 then failwith "invalid char token" else if s.[0] = '\\' then if String.length s = 2 && s.[1] = ''' then ''' else try let (c, i) = backslash s 1 in if i = String.length s then c else raise Not_found with [ Not_found -> failwith "invalid char token" ] else failwith "invalid char token" ; value string_of_string_token s = loop 0 0 where rec loop len i = if i = String.length s then get_buff len else let (len, i) = if s.[i] = '\\' then let i = i + 1 in if i = String.length s then failwith "invalid string token" else if s.[i] = '"' then (store len '"', i + 1) else match s.[i] with [ '\010' -> (len, skip_indent s (i + 1)) | '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1))) | c -> try let (c, i) = backslash s i in (store len c, i) with [ Not_found -> (store (store len '\\') c, i + 1) ] ] else (store len s.[i], i + 1) in loop len i ; value rec skip_spaces = parser [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] -> skip_spaces s | [: :] -> () ] ; value error_on_unknown_keywords = ref False; value next_token_fun find_id_kwd find_spe_kwd fname lnum bolpos = let make_pos p = {Lexing.pos_fname = fname.val; Lexing.pos_lnum = lnum.val; Lexing.pos_bol = bolpos.val; Lexing.pos_cnum = p} in let mkloc (bp, ep) = (make_pos bp, make_pos ep) in let err loc msg = raise_with_loc loc (Token.Error msg) in let keyword_or_error (bp,ep) s = try ("", find_spe_kwd s) with [ Not_found -> if error_on_unknown_keywords.val then err (mkloc (bp, ep)) ("illegal token: " ^ s) else ("", s) ] in let rec next_token = parser bp [ [: `('A'..'Z' | ''..'' | ''..'' as c); s :] -> let id = get_buff (ident (store 0 c) s) in try ("", find_id_kwd id) with [ Not_found -> ("UIDENT", id) ] | [: `('a'..'z' | ''..'' | ''..'' | '_' as c); s :] -> let id = get_buff (ident (store 0 c) s) in let is_label = match Stream.peek s with [ Some ':' -> match Stream.npeek 2 s with [ [_; ':' | '=' | '>'] -> False | _ -> True ] | _ -> False ] in if is_label then do { Stream.junk s; ("LABEL", id) } else try ("", find_id_kwd id) with [ Not_found -> ("LIDENT", id) ] | [: `('1'..'9' as c); s :] -> number (store 0 c) s | [: `'0'; s :] -> base_number (store 0 '0') s | [: `'''; s :] ep -> match Stream.npeek 2 s with [ [_; '''] | ['\\'; _] -> ("CHAR", char bp 0 s) | _ -> keyword_or_error (bp, ep) "'" ] | [: `'"'; s :] -> ("STRING", string bp 0 s) | [: `'$'; s :] -> locate_or_antiquot bp 0 s | [: `('!' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c) ; s :] -> let id = get_buff (ident2 (store 0 c) s) in keyword_or_error (bp, Stream.count s) id | [: `('?' as c); s :] -> let id = get_buff (ident4 (store 0 c) s) in keyword_or_error (bp, Stream.count s) id | [: `'<'; s :] -> less bp s | [: `(':' as c1); (is_label, len) = parser [ [: `(']' | ':' | '=' | '>' as c2) :] -> (False, store (store 0 c1) c2) | [: `('a'..'z' | ''..'' | ''..'' | '_' as c); s :] -> (True, ident (store 0 c) s) | [: :] -> (False, store 0 c1) ] :] ep -> let id = get_buff len in if is_label then ("ELABEL", id) else keyword_or_error (bp, ep) id | [: `('>' | '|' as c1); len = parser [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2 | [: a = ident2 (store 0 c1) :] -> a ] :] ep -> let id = get_buff len in keyword_or_error (bp, ep) id | [: `('[' | '{' as c1); s :] -> let len = match Stream.npeek 2 s with [ ['<'; '<' | ':'] -> store 0 c1 | _ -> match s with parser [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2 | [: :] -> store 0 c1 ] ] in let ep = Stream.count s in let id = get_buff len in keyword_or_error (bp, ep) id | [: `'.'; id = parser [ [: `'.' :] -> ".." | [: :] -> "." ] :] ep -> keyword_or_error (bp, ep) id | [: `';'; id = parser [ [: `';' :] -> ";;" | [: :] -> ";" ] :] ep -> keyword_or_error (bp, ep) id | [: `'\\'; s :] -> ("LIDENT", get_buff (ident3 0 s)) | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) ] and less bp = parser [ [: `'<'; s :] -> ("QUOTATION", ":" ^ get_buff (quotation bp 0 s)) | [: `':'; i = parser [: len = ident 0 :] -> get_buff len; `'<' ? "character '<' expected"; s :] -> ("QUOTATION", i ^ ":" ^ get_buff (quotation bp 0 s)) | [: s :] ep -> let id = get_buff (ident2 (store 0 '<') s) in keyword_or_error (bp, ep) id ] and string bp len = parser [ [: `'"' :] -> get_buff len | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s | [: `c; s :] -> string bp (store len c) s | [: :] ep -> err (mkloc (bp, ep)) "string not terminated" ] and char bp len = parser [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else get_buff len | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s | [: `c; s :] -> char bp (store len c) s | [: :] ep -> err (mkloc(bp,ep)) "char not terminated" ] and locate_or_antiquot bp len = parser [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s | [: `':'; s :] -> let k = get_buff len in ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) | [: `'\\'; `c; s :] -> ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) | [: `c; s :] -> ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ] and maybe_locate bp len = parser [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s | [: `':'; s :] -> ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s) | [: `'\\'; `c; s :] -> ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) | [: `c; s :] -> ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ] and antiquot bp len = parser [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] -> antiquot bp (store len c) s | [: `':'; s :] -> let k = get_buff len in ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) | [: `'\\'; `c; s :] -> ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) | [: `c; s :] -> ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ] and locate_or_antiquot_rest bp len = parser [ [: `'$' :] -> get_buff len | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ] and quotation bp len = parser [ [: `'>'; s :] -> maybe_end_quotation bp len s | [: `'<'; s :] -> quotation bp (maybe_nested_quotation bp (store len '<') __strm) s | [: `'\\'; len = parser [ [: `('>' | '<' | '\\' as c) :] -> store len c | [: :] -> store len '\\' ]; s :] -> quotation bp len s | [: `c; s :] -> quotation bp (store len c) s | [: :] ep -> err (mkloc(bp,ep)) "quotation not terminated" ] and maybe_nested_quotation bp len = parser [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" | [: `':'; len = ident (store len ':'); a = parser [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" | [: :] -> len ] :] -> a | [: :] -> len ] and maybe_end_quotation bp len = parser [ [: `'>' :] -> len | [: a = quotation bp (store len '>') :] -> a ] in let rec next_token_loc = parser bp [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] -> next_token_loc s | [: `'('; s :] -> maybe_comment bp s | [: `'#'; _ = spaces_tabs; a = linenum bp :] -> a | [: tok = next_token :] ep -> (tok, mkloc(bp, ep)) | [: _ = Stream.empty :] -> (("EOI", ""), mkloc(bp, succ bp)) ] and maybe_comment bp = parser [ [: `'*'; s :] -> do { comment bp s; next_token_loc s } | [: :] ep -> let tok = keyword_or_error (bp, ep) "(" in (tok, mkloc(bp, ep)) ] and comment bp = parser [ [: `'('; s :] -> maybe_nested_comment bp s | [: `'*'; s :] -> maybe_end_comment bp s | [: `c; s :] -> comment bp s | [: :] ep -> err (mkloc(bp,ep)) "comment not terminated" ] and maybe_nested_comment bp = parser [ [: `'*'; s :] -> do { comment bp s; comment bp s } | [: a = comment bp :] -> a ] and maybe_end_comment bp = parser [ [: `')' :] -> () | [: a = comment bp :] -> a ] and linenum bp = parser [ [: `'0'..'9'; _ = digits; _ = spaces_tabs; `'"'; _ = any_to_nl; s :] -> next_token_loc s | [: :] -> (keyword_or_error (bp, bp + 1) "#", mkloc(bp, bp + 1)) ] and spaces_tabs = parser [ [: `' ' | '\t'; s :] -> spaces_tabs s | [: :] -> () ] and digits = parser [ [: `'0'..'9'; s :] -> digits s | [: :] -> () ] and any_to_nl = parser [ [: `'\r' | '\n' :] -> () | [: `_; s :] -> any_to_nl s | [: :] -> () ] in fun cstrm -> try next_token_loc cstrm with [ Stream.Error str -> err (mkloc(Stream.count cstrm, Stream.count cstrm + 1)) str ] ; value locerr () = invalid_arg "Lexer: location function"; value loct_create () = ref (Array.create 1024 None); value loct_func loct i = match if i < 0 || i >= Array.length loct.val then None else Array.unsafe_get loct.val i with [ Some loc -> loc | _ -> locerr () ] ; value loct_add loct i loc = do { if i >= Array.length loct.val then do { let new_tmax = Array.length loct.val * 2 in let new_loct = Array.create new_tmax None in Array.blit loct.val 0 new_loct 0 (Array.length loct.val); loct.val := new_loct } else (); loct.val.(i) := Some loc } ; value func kwd_table = let bolpos = ref 0 in let lnum = ref 0 in let fname = ref "" in let find = Hashtbl.find kwd_table in let lex cstrm = let next_token_loc = next_token_fun find find fname lnum bolpos in let loct = loct_create () in let ts = Stream.from (fun i -> let (tok, loc) = next_token_loc cstrm in do { loct_add loct i loc; Some tok }) in let locf = loct_func loct in (ts, locf) in lex ; value rec check_keyword_stream = parser [: _ = check; _ = Stream.empty :] -> True and check = parser [ [: `'A'..'Z' | 'a'..'z' | ''..'' | ''..'' | ''..''; s :] -> check_ident s | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' | '.' ; s :] -> check_ident2 s | [: `'<'; s :] -> match Stream.npeek 1 s with [ [':' | '<'] -> () | _ -> check_ident2 s ] | [: `':'; _ = parser [ [: `']' | ':' | '=' | '>' :] -> () | [: :] -> () ] :] ep -> () | [: `'>' | '|'; _ = parser [ [: `']' | '}' :] -> () | [: a = check_ident2 :] -> a ] :] -> () | [: `'[' | '{'; s :] -> match Stream.npeek 2 s with [ ['<'; '<' | ':'] -> () | _ -> match s with parser [ [: :] -> match Stream.peek __strm with [ Some ('|' | '<' | ':') -> Stream.junk __strm | _ -> () ] ] ] | [: `';'; _ = parser [ [: `';' :] -> () | [: :] -> () ] :] -> () | [: `_ :] -> () ] and check_ident = parser [ [: `'A'..'Z' | 'a'..'z' | ''..'' | ''..'' | ''..'' | '0'..'9' | '_' | ''' ; s :] -> check_ident s | [: :] -> () ] and check_ident2 = parser [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' | '.' | ':' | '<' | '>' | '|' ; s :] -> check_ident2 s | [: :] -> () ] ; value check_keyword s = try check_keyword_stream (Stream.of_string s) with _ -> False ; value using_token kwd_table (p_con, p_prm) = match p_con with [ "" -> try let _ = Hashtbl.find kwd_table p_prm in () with [ Not_found -> if check_keyword p_prm then Hashtbl.add kwd_table p_prm p_prm else raise (Token.Error ("the token \"" ^ p_prm ^ "\" does not respect Plexer rules")) ] | "LIDENT" | "UIDENT" | "INT" | "FLOAT" | "CHAR" | "STRING" | "QUOTATION" | "ANTIQUOT" | "LOCATE" | "LABEL" | "ELABEL" | "EOI" -> () | _ -> raise (Token.Error ("the constructor \"" ^ p_con ^ "\" is not recognized by Llexer")) ] ; value removing_token kwd_table (p_con, p_prm) = if p_con = "" then Hashtbl.remove kwd_table p_prm else () ; value text = fun [ ("", t) -> "'" ^ t ^ "'" | ("LIDENT", "") -> "lowercase identifier" | ("LIDENT", t) -> "'" ^ t ^ "'" | ("UIDENT", "") -> "uppercase identifier" | ("UIDENT", t) -> "'" ^ t ^ "'" | ("INT", "") -> "integer" | ("INT", s) -> "'" ^ s ^ "'" | ("FLOAT", "") -> "float" | ("STRING", "") -> "string" | ("CHAR", "") -> "char" | ("QUOTATION", "") -> "quotation" | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\"" | ("LOCATE", "") -> "locate" | ("LABEL", "") -> "label" | ("ELABEL", "") -> "elabel" | ("EOI", "") -> "end of input" | (con, "") -> con | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ] ; value eq_before_colon p e = loop 0 where rec loop i = if i == String.length e then failwith "Internal error in Plexer: incorrect ANTIQUOT" else if i == String.length p then e.[i] == ':' else if p.[i] == e.[i] then loop (i + 1) else False ; value after_colon e = try let i = String.index e ':' in String.sub e (i + 1) (String.length e - i - 1) with [ Not_found -> "" ] ; value gmake () = let kwd_table = Hashtbl.create 301 in {tok_func = func kwd_table; tok_using = using_token kwd_table; tok_removing = removing_token kwd_table; tok_match = Token.default_match; tok_text = text; tok_comm = None} ; end ; open Stdpp; open Pcaml; Pcaml.no_constructors_arity.val := True; do { Grammar.Unsafe.gram_reinit gram (Plexer.gmake ()); Grammar.Unsafe.clear_entry interf; Grammar.Unsafe.clear_entry implem; Grammar.Unsafe.clear_entry top_phrase; Grammar.Unsafe.clear_entry use_file; Grammar.Unsafe.clear_entry module_type; Grammar.Unsafe.clear_entry module_expr; Grammar.Unsafe.clear_entry sig_item; Grammar.Unsafe.clear_entry str_item; Grammar.Unsafe.clear_entry expr; Grammar.Unsafe.clear_entry patt; Grammar.Unsafe.clear_entry ctyp; Grammar.Unsafe.clear_entry let_binding; Grammar.Unsafe.clear_entry class_type; Grammar.Unsafe.clear_entry class_expr; Grammar.Unsafe.clear_entry class_sig_item; Grammar.Unsafe.clear_entry class_str_item }; Pcaml.parse_interf.val := Grammar.Entry.parse interf; Pcaml.parse_implem.val := Grammar.Entry.parse implem; value o2b = fun [ Some _ -> True | None -> False ] ; value mkumin loc f arg = match arg with [ <:expr< $int:n$ >> when int_of_string n > 0 -> let n = "-" ^ n in <:expr< $int:n$ >> | <:expr< $flo:n$ >> when float_of_string n > 0.0 -> let n = "-" ^ n in <:expr< $flo:n$ >> | _ -> let f = "~" ^ f in <:expr< $lid:f$ $arg$ >> ] ; external loc_of_node : 'a -> Loc.t = "%field0"; value mklistexp loc last = loop True where rec loop top = fun [ [] -> match last with [ Some e -> e | None -> <:expr< [] >> ] | [e1 :: el] -> let loc = if top then loc else (fst (loc_of_node e1), snd loc) in <:expr< [$e1$ :: $loop False el$] >> ] ; value mklistpat loc last = loop True where rec loop top = fun [ [] -> match last with [ Some p -> p | None -> <:patt< [] >> ] | [p1 :: pl] -> let loc = if top then loc else (fst (loc_of_node p1), snd loc) in <:patt< [$p1$ :: $loop False pl$] >> ] ; value neg s = string_of_int (- int_of_string s); value is_operator = let ht = Hashtbl.create 73 in let ct = Hashtbl.create 73 in do { List.iter (fun x -> Hashtbl.add ht x True) ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"]; List.iter (fun x -> Hashtbl.add ct x True) ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~'; '?'; '%'; '.']; fun x -> try Hashtbl.find ht x with [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ] } ; (* value p_operator strm = match Stream.peek strm with [ Some (Token.Tterm "(") -> match Stream.npeek 3 strm with [ [_; Token.Tterm x; Token.Tterm ")"] when is_operator x -> do { Stream.junk strm; Stream.junk strm; Stream.junk strm; x } | _ -> raise Stream.Failure ] | _ -> raise Stream.Failure ] ; value operator = Grammar.Entry.of_parser gram "operator" p_operator; *) value operator = Grammar.Entry.of_parser gram "operator" (parser [: `("", x) when is_operator x :] -> x) ; value symbolchar = let list = ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?'; '@'; '^'; '|'; '~'] in let rec loop s i = if i == String.length s then True else if List.mem s.[i] list then loop s (i + 1) else False in loop ; value prefixop = let list = ['!'; '?'; '~'] in let excl = ["!="] in Grammar.Entry.of_parser gram "prefixop" (parser [: `("", x) when not (List.mem x excl) && String.length x >= 2 && List.mem x.[0] list && symbolchar x 1 :] -> x) ; value infixop0 = let list = ['='; '<'; '>'; '|'; '&'; '$'] in let excl = ["<-"; "||"; "&&"] in Grammar.Entry.of_parser gram "infixop0" (parser [: `("", x) when not (List.mem x excl) && String.length x >= 2 && List.mem x.[0] list && symbolchar x 1 :] -> x) ; value infixop1 = let list = ['@'; '^'] in Grammar.Entry.of_parser gram "infixop1" (parser [: `("", x) when String.length x >= 2 && List.mem x.[0] list && symbolchar x 1 :] -> x) ; value infixop2 = let list = ['+'; '-'] in Grammar.Entry.of_parser gram "infixop2" (parser [: `("", x) when x <> "->" && String.length x >= 2 && List.mem x.[0] list && symbolchar x 1 :] -> x) ; value infixop3 = let list = ['*'; '/'; '%'] in Grammar.Entry.of_parser gram "infixop3" (parser [: `("", x) when String.length x >= 2 && List.mem x.[0] list && symbolchar x 1 :] -> x) ; value infixop4 = Grammar.Entry.of_parser gram "infixop4" (parser [: `("", x) when String.length x >= 3 && x.[0] == '*' && x.[1] == '*' && symbolchar x 2 :] -> x) ; value test_constr_decl = Grammar.Entry.of_parser gram "test_constr_decl" (fun strm -> match Stream.npeek 1 strm with [ [("UIDENT", _)] -> match Stream.npeek 2 strm with [ [_; ("", ".")] -> raise Stream.Failure | [_; ("", "(")] -> raise Stream.Failure | [_ :: _] -> () | _ -> raise Stream.Failure ] | [("", "|")] -> () | _ -> raise Stream.Failure ]) ; value stream_peek_nth n strm = loop n (Stream.npeek n strm) where rec loop n = fun [ [] -> None | [x] -> if n == 1 then Some x else None | [_ :: l] -> loop (n - 1) l ] ; value test_label_eq = let rec test lev strm = match stream_peek_nth lev strm with [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) -> test (lev + 1) strm | Some ("", "=") -> () | _ -> raise Stream.Failure ] in Grammar.Entry.of_parser gram "test_label_eq" (test 1) ; value constr_arity = ref [("Some", 1); ("Match_Failure", 1)]; value rec constr_expr_arity = fun [ <:expr< $uid:c$ >> -> try List.assoc c constr_arity.val with [ Not_found -> 0 ] | <:expr< $uid:_$.$e$ >> -> constr_expr_arity e | _ -> 1 ] ; value rec constr_patt_arity = fun [ <:patt< $uid:c$ >> -> try List.assoc c constr_arity.val with [ Not_found -> 0 ] | <:patt< $uid:_$.$p$ >> -> constr_patt_arity p | _ -> 1 ] ; value rec get_seq = fun [ <:expr< do { $list:el$ } >> -> el | e -> [e] ] ; value choose_tvar tpl = let rec find_alpha v = let s = String.make 1 v in if List.mem_assoc s tpl then if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1)) else Some (String.make 1 v) in let rec make_n n = let v = "a" ^ string_of_int n in if List.mem_assoc v tpl then make_n (succ n) else v in match find_alpha 'a' with [ Some x -> x | None -> make_n 1 ] ; value rec patt_lid = fun [ <:patt< $lid:i$ $p$ >> -> Some (i, [p]) | <:patt< $p1$ $p2$ >> -> match patt_lid p1 with [ Some (i, pl) -> Some (i, [p2 :: pl]) | None -> None ] | _ -> None ] ; value type_parameter = Grammar.Entry.create gram "type_parameter"; value fun_def = Grammar.Entry.create gram "fun_def"; value fun_binding = Grammar.Entry.create gram "fun_binding"; EXTEND GLOBAL: interf implem top_phrase use_file sig_item str_item ctyp patt expr module_type module_expr let_binding type_parameter fun_def fun_binding; (* Main entry points *) interf: [ [ st = LIST0 [ s = sig_item; OPT ";;" -> (s, loc) ]; EOI -> (st, False) ] ] ; implem: [ [ st = LIST0 [ s = str_item; OPT ";;" -> (s, loc) ]; EOI -> (st, False) ] ] ; top_phrase: [ [ ph = phrase; ";;" -> Some ph | EOI -> None ] ] ; use_file: [ [ l = LIST0 [ ph = phrase; OPT ";;" -> ph ]; EOI -> (l, False) ] ] ; phrase: [ [ sti = str_item -> sti | "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ] ; dir_param: [ [ -> None | e = expr -> Some e ] ] ; (* Module expressions *) module_expr: [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->"; me = SELF -> <:module_expr< functor ( $i$ : $t$ ) -> $me$ >> | "struct"; st = LIST0 [ s = str_item; OPT ";;" -> s ]; "end" -> <:module_expr< struct $list:st$ end >> ] | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ] | [ i = mod_expr_ident -> i | "("; me = SELF; ":"; mt = module_type; ")" -> <:module_expr< ( $me$ : $mt$ ) >> | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ] ; mod_expr_ident: [ LEFTA [ m1 = SELF; "."; m2 = SELF -> <:module_expr< $m1$ . $m2$ >> ] | [ m = UIDENT -> <:module_expr< $uid:m$ >> ] ] ; str_item: [ "top" [ "exception"; (_, c, tl) = constructor_declaration -> <:str_item< exception $c$ of $list:tl$ >> | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> <:str_item< external $i$ : $t$ = $list:pd$ >> | "external"; i = LABEL; t = ctyp; "="; pd = LIST1 STRING -> <:str_item< external $i$ : $t$ = $list:pd$ >> | "external"; "("; i = operator; ")"; ":"; t = ctyp; "="; pd = LIST1 STRING -> <:str_item< external $i$ : $t$ = $list:pd$ >> | "module"; i = UIDENT; mb = module_binding -> <:str_item< module $i$ = $mb$ >> | "module"; "type"; i = UIDENT; "="; mt = module_type -> <:str_item< module type $i$ = $mt$ >> | "open"; i = mod_ident -> <:str_item< open $i$ >> | "type"; tdl = LIST1 type_declaration SEP "and" -> <:str_item< type $list:tdl$ >> | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; x = expr -> let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in <:str_item< $exp:e$ >> | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" -> match l with [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >> | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ] | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr -> <:str_item< let module $m$ = $mb$ in $e$ >> | e = expr -> <:str_item< $exp:e$ >> ] ] ; module_binding: [ RIGHTA [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF -> <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >> | ":"; mt = module_type; "="; me = module_expr -> <:module_expr< ( $me$ : $mt$ ) >> | "="; me = module_expr -> <:module_expr< $me$ >> ] ] ; (* Module types *) module_type: [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" -> <:module_type< $mt$ with $list:wcl$ >> ] | [ "sig"; sg = LIST0 [ s = sig_item; OPT ";;" -> s ]; "end" -> <:module_type< sig $list:sg$ end >> | i = mod_type_ident -> i | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ] ; mod_type_ident: [ LEFTA [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >> | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ] | [ m = UIDENT -> <:module_type< $uid:m$ >> | m = LIDENT -> <:module_type< $lid:m$ >> ] ] ; sig_item: [ "top" [ "exception"; (_, c, tl) = constructor_declaration -> <:sig_item< exception $c$ of $list:tl$ >> | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> <:sig_item< external $i$ : $t$ = $list:pd$ >> | "external"; i = LABEL; t = ctyp; "="; pd = LIST1 STRING -> <:sig_item< external $i$ : $t$ = $list:pd$ >> | "external"; "("; i = operator; ")"; ":"; t = ctyp; "="; pd = LIST1 STRING -> <:sig_item< external $i$ : $t$ = $list:pd$ >> | "include"; mt = module_type -> <:sig_item< include $mt$ >> | "module"; i = UIDENT; mt = module_declaration -> <:sig_item< module $i$ : $mt$ >> | "module"; "type"; i = UIDENT; "="; mt = module_type -> <:sig_item< module type $i$ = $mt$ >> | "open"; i = mod_ident -> <:sig_item< open $i$ >> | "type"; tdl = LIST1 type_declaration SEP "and" -> <:sig_item< type $list:tdl$ >> | "val"; i = LIDENT; ":"; t = ctyp -> <:sig_item< value $i$ : $t$ >> | "val"; i = LABEL; t = ctyp -> <:sig_item< value $i$ : $t$ >> | "val"; "("; i = operator; ")"; ":"; t = ctyp -> <:sig_item< value $i$ : $t$ >> ] ] ; module_declaration: [ RIGHTA [ ":"; mt = module_type -> <:module_type< $mt$ >> | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF -> <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ] ; (* "with" constraints (additional type equations over signature components) *) with_constr: [ [ "type"; tp = type_parameters; i = mod_ident; "="; t = ctyp -> MLast.WcTyp loc i tp t | "module"; i = mod_ident; "="; me = module_expr -> MLast.WcMod loc i me ] ] ; (* Core expressions *) expr: [ "top" LEFTA [ e1 = SELF; ";"; e2 = SELF -> <:expr< do { $list:[e1 :: get_seq e2]$ } >> | e1 = SELF; ";" -> e1 ] | "expr1" [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; x = expr LEVEL "top" -> <:expr< let $opt:o2b o$ $list:l$ in $x$ >> | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr LEVEL "top" -> <:expr< let module $m$ = $mb$ in $e$ >> | "function"; OPT "|"; l = LIST1 match_case SEP "|" -> <:expr< fun [ $list:l$ ] >> | "fun"; p = patt LEVEL "simple"; e = fun_def -> <:expr< fun [$p$ -> $e$] >> | "match"; x = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> <:expr< match $x$ with [ $list:l$ ] >> | "try"; x = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> <:expr< try $x$ with [ $list:l$ ] >> | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1"; e3 = [ "else"; e = expr LEVEL "expr1" -> e | -> <:expr< () >> ] -> <:expr< if $e1$ then $e2$ else $e3$ >> | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; "do"; e = SELF; "done" -> <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >> | "while"; e1 = SELF; "do"; e2 = SELF; "done" -> <:expr< while $e1$ do { $list:get_seq e2$ } >> ] | [ e = SELF; ","; el = LIST1 NEXT SEP "," -> <:expr< ( $list:[e :: el]$ ) >> ] | ":=" NONA [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" -> <:expr< $e1$.val := $e2$ >> | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" -> <:expr< $e1$ := $e2$ >> ] | "||" RIGHTA [ e1 = SELF; f = [ op = "or" -> op | op = "||" -> op ]; e2 = SELF -> <:expr< $lid:f$ $e1$ $e2$ >> ] | "&&" RIGHTA [ e1 = SELF; f = [ op = "&" -> op | op = "&&" -> op ]; e2 = SELF -> <:expr< $lid:f$ $e1$ $e2$ >> ] | "<" LEFTA [ e1 = SELF; f = [ op = "<" -> op | op = ">" -> op | op = "<=" -> op | op = ">=" -> op | op = "=" -> op | op = "<>" -> op | op = "==" -> op | op = "!=" -> op | op = infixop0 -> op ]; e2 = SELF -> <:expr< $lid:f$ $e1$ $e2$ >> ] | "^" RIGHTA [ e1 = SELF; f = [ op = "^" -> op | op = "@" -> op | op = infixop1 -> op ]; e2 = SELF -> <:expr< $lid:f$ $e1$ $e2$ >> ] | RIGHTA [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ] | "+" LEFTA [ e1 = SELF; f = [ op = "+" -> op | op = "-" -> op | op = "+." -> op | op = "-." -> op | op = infixop2 -> op ]; e2 = SELF -> <:expr< $lid:f$ $e1$ $e2$ >> ] | "*" LEFTA [ e1 = SELF; f = [ op = "*" -> op | op = "/" -> op | op = "*." -> op | op = "/." -> op | op = "land" -> op | op = "lor" -> op | op = "lxor" -> op | op = "mod" -> op | op = infixop3 -> op ]; e2 = SELF -> <:expr< $lid:f$ $e1$ $e2$ >> ] | "**" RIGHTA [ e1 = SELF; f = [ op = "**" -> op | op = "asr" -> op | op = "lsl" -> op | op = "lsr" -> op | op = infixop4 -> op ]; e2 = SELF -> <:expr< $lid:f$ $e1$ $e2$ >> ] | "unary minus" NONA [ f = [ op = "-" -> op | op = "-." -> op ]; e = SELF -> <:expr< $mkumin loc f e$ >> ] | "apply" LEFTA [ e1 = SELF; e2 = SELF -> match constr_expr_arity e1 with [ 1 -> <:expr< $e1$ $e2$ >> | _ -> match e2 with [ <:expr< ( $list:el$ ) >> -> List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el | _ -> <:expr< $e1$ $e2$ >> ] ] | "assert"; e = expr LEVEL "simple" -> match e with [ <:expr< False >> -> MLast.ExAsf loc | _ -> MLast.ExAsr loc e ] | "lazy"; e = SELF -> <:expr< lazy ($e$) >> ] | "simple" LEFTA [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >> | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >> | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> | "!"; e = SELF -> <:expr< $e$ . val>> | f = [ op = "~-" -> op | op = "~-." -> op | op = "~" -> op | op = prefixop -> op ]; e = SELF -> <:expr< $lid:f$ $e$ >> | s = INT -> <:expr< $int:s$ >> | s = FLOAT -> <:expr< $flo:s$ >> | s = STRING -> <:expr< $str:s$ >> | c = CHAR -> <:expr< $chr:c$ >> | i = expr_ident -> i | s = "false" -> <:expr< False >> | s = "true" -> <:expr< True >> | "["; "]" -> <:expr< [] >> | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >> | "[|"; "|]" -> <:expr< [| |] >> | "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >> | "{"; test_label_eq; lel = lbl_expr_list; "}" -> <:expr< { $list:lel$ } >> | "{"; e = expr LEVEL "simple"; "with"; lel = lbl_expr_list; "}" -> <:expr< { ($e$) with $list:lel$ } >> | "("; ")" -> <:expr< () >> | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >> | "("; e = SELF; ")" -> <:expr< $e$ >> | "("; "-"; ")" -> <:expr< $lid:"-"$ >> | "("; "-."; ")" -> <:expr< $lid:"-."$ >> | "("; op = operator; ")" -> <:expr< $lid:op$ >> | "begin"; e = SELF; "end" -> <:expr< $e$ >> | x = LOCATE -> let x = try let i = String.index x ':' in ({Lexing.pos_fname = ""; Lexing.pos_lnum = 0; Lexing.pos_bol = 0; Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, String.sub x (i + 1) (String.length x - i - 1)) with [ Not_found | Failure _ -> (Token.nowhere, x) ] in Pcaml.handle_expr_locate loc x | x = QUOTATION -> let x = try let i = String.index x ':' in (String.sub x 0 i, String.sub x (i + 1) (String.length x - i - 1)) with [ Not_found -> ("", x) ] in Pcaml.handle_expr_quotation loc x ] ] ; let_binding: [ [ p = patt; e = fun_binding -> match patt_lid p with [ Some (i, pl) -> let e = List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl in (<:patt< $lid:i$ >>, e) | None -> (p, e) ] ] ] ; fun_binding: [ RIGHTA [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> | "="; e = expr -> <:expr< $e$ >> | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ] ; match_case: [ [ x1 = patt; w = OPT [ "when"; e = expr -> e ]; "->"; x2 = expr -> (x1, w, x2) ] ] ; lbl_expr_list: [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel] | le = lbl_expr; ";" -> [le] | le = lbl_expr -> [le] ] ] ; lbl_expr: [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ] ; expr1_semi_list: [ [ e = expr LEVEL "expr1"; ";"; el = SELF -> [e :: el] | e = expr LEVEL "expr1"; ";" -> [e] | e = expr LEVEL "expr1" -> [e] ] ] ; fun_def: [ RIGHTA [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> | "->"; e = expr -> <:expr< $e$ >> ] ] ; expr_ident: [ RIGHTA [ i = LIDENT -> <:expr< $lid:i$ >> | i = UIDENT -> <:expr< $uid:i$ >> | m = UIDENT; "."; i = SELF -> let rec loop m = fun [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y | e -> <:expr< $m$ . $e$ >> ] in loop <:expr< $uid:m$ >> i | m = UIDENT; "."; "("; i = operator; ")" -> <:expr< $uid:m$ . $lid:i$ >> ] ] ; (* Patterns *) patt: [ LEFTA [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ] | LEFTA [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ] | [ p = SELF; ","; pl = LIST1 NEXT SEP "," -> <:patt< ( $list:[p :: pl]$) >> ] | NONA [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ] | RIGHTA [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ] | LEFTA [ p1 = SELF; p2 = SELF -> match constr_patt_arity p1 with [ 1 -> <:patt< $p1$ $p2$ >> | n -> let p2 = match p2 with [ <:patt< _ >> when n > 1 -> let pl = loop n where rec loop n = if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)] in <:patt< ( $list:pl$ ) >> | _ -> p2 ] in match p2 with [ <:patt< ( $list:pl$ ) >> -> List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl | _ -> <:patt< $p1$ $p2$ >> ] ] ] | LEFTA [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] | "simple" [ s = LIDENT -> <:patt< $lid:s$ >> | s = UIDENT -> <:patt< $uid:s$ >> | s = INT -> <:patt< $int:s$ >> | "-"; s = INT -> <:patt< $int:neg s$ >> | s = STRING -> <:patt< $str:s$ >> | s = CHAR -> <:patt< $chr:s$ >> | s = "false" -> <:patt< False >> | s = "true" -> <:patt< True >> | "["; "]" -> <:patt< [] >> | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >> | "[|"; "|]" -> <:patt< [| |] >> | "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >> | "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >> | "("; ")" -> <:patt< () >> | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> | "("; p = SELF; ")" -> <:patt< $p$ >> | "("; "-"; ")" -> <:patt< $lid:"-"$ >> | "("; op = operator; ")" -> <:patt< $lid:op$ >> | "_" -> <:patt< _ >> | x = LOCATE -> let x = try let i = String.index x ':' in ({Lexing.pos_fname = ""; Lexing.pos_lnum = 0; Lexing.pos_bol = 0; Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, String.sub x (i + 1) (String.length x - i - 1)) with [ Not_found | Failure _ -> (Token.nowhere, x) ] in Pcaml.handle_patt_locate loc x | x = QUOTATION -> let x = try let i = String.index x ':' in (String.sub x 0 i, String.sub x (i + 1) (String.length x - i - 1)) with [ Not_found -> ("", x) ] in Pcaml.handle_patt_quotation loc x ] ] ; patt_semi_list: [ [ p = patt; ";"; pl = SELF -> [p :: pl] | p = patt; ";" -> [p] | p = patt -> [p] ] ] ; lbl_patt_list: [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel] | le = lbl_patt; ";" -> [le] | le = lbl_patt -> [le] ] ] ; lbl_patt: [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ] ; patt_label_ident: [ RIGHTA [ i = UIDENT -> <:patt< $uid:i$ >> | i = LIDENT -> <:patt< $lid:i$ >> | m = UIDENT; "."; i = SELF -> <:patt< $uid:m$ . $i$ >> ] ] ; (* Type declaration *) type_declaration: [ [ tpl = type_parameters; n = type_patt; "="; tk = type_kind; cl = LIST0 constrain -> (n, tpl, tk, cl) | tpl = type_parameters; n = type_patt; cl = LIST0 constrain -> (n, tpl, <:ctyp< '$choose_tvar tpl$ >>, cl) ] ] ; type_patt: [ [ n = LIDENT -> (loc, n) ] ] ; constrain: [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ] ; type_kind: [ [ test_constr_decl; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< [ $list:cdl$ ] >> | t = ctyp -> <:ctyp< $t$ >> | t = ctyp; "="; "{"; ldl = label_declarations; "}" -> <:ctyp< $t$ == { $list:ldl$ } >> | t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< $t$ == [ $list:cdl$ ] >> | "{"; ldl = label_declarations; "}" -> <:ctyp< { $list:ldl$ } >> ] ] ; type_parameters: [ [ -> (* empty *) [] | tp = type_parameter -> [tp] | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ] ; type_parameter: [ [ "'"; i = ident -> (i, (False, False)) ] ] ; constructor_declaration: [ [ ci = UIDENT; "of"; cal = LIST1 ctyp LEVEL "ctyp1" SEP "*" -> (loc, ci, cal) | ci = UIDENT -> (loc, ci, []) ] ] ; label_declarations: [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl] | ld = label_declaration; ";" -> [ld] | ld = label_declaration -> [ld] ] ] ; label_declaration: [ [ i = LIDENT; ":"; t = ctyp -> (loc, i, False, t) | i = LABEL; t = ctyp -> (loc, i, False, t) | "mutable"; i = LIDENT; ":"; t = ctyp -> (loc, i, True, t) | "mutable"; i = LABEL; t = ctyp -> (loc, i, True, t) ] ] ; (* Core types *) ctyp: [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ] | "arrow" RIGHTA [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ] | [ t = SELF; "*"; tl = LIST1 ctyp LEVEL "ctyp1" SEP "*" -> <:ctyp< ( $list:[t :: tl]$ ) >> ] | "ctyp1" [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ] | "ctyp2" [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >> | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ] | "simple" [ "'"; i = ident -> <:ctyp< '$i$ >> | "_" -> <:ctyp< _ >> | i = LIDENT -> <:ctyp< $lid:i$ >> | i = UIDENT -> <:ctyp< $uid:i$ >> | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")"; i = ctyp LEVEL "ctyp2" -> List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl] | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ] ; (* Identifiers *) ident: [ [ i = LIDENT -> i | i = UIDENT -> i ] ] ; mod_ident: [ RIGHTA [ i = UIDENT -> [i] | i = LIDENT -> [i] | m = UIDENT; "."; i = SELF -> [m :: i] ] ] ; (* Miscellaneous *) direction_flag: [ [ "to" -> True | "downto" -> False ] ] ; END; (* Objects and Classes *) value rec class_type_of_ctyp loc t = match t with [ <:ctyp< $lid:i$ >> -> <:class_type< $list:[i]$ >> | <:ctyp< $uid:m$.$t$ >> -> <:class_type< $list:[m :: type_id_list t]$ >> | _ -> raise_with_loc loc (Stream.Error "lowercase identifier expected") ] and type_id_list = fun [ <:ctyp< $uid:m$.$t$ >> -> [m :: type_id_list t] | <:ctyp< $lid:i$ >> -> [i] | t -> raise_with_loc (loc_of_node t) (Stream.Error "lowercase identifier expected") ] ; value class_fun_binding = Grammar.Entry.create gram "class_fun_binding"; EXTEND GLOBAL: str_item sig_item expr ctyp class_sig_item class_str_item class_type class_expr class_fun_binding; str_item: [ [ "class"; cd = LIST1 class_declaration SEP "and" -> <:str_item< class $list:cd$ >> | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> <:str_item< class type $list:ctd$ >> ] ] ; sig_item: [ [ "class"; cd = LIST1 class_description SEP "and" -> <:sig_item< class $list:cd$ >> | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> <:sig_item< class type $list:ctd$ >> ] ] ; (* Class expressions *) class_declaration: [ [ vf = OPT "virtual"; ctp = class_type_parameters; i = LIDENT; cfb = class_fun_binding -> {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; MLast.ciNam = i; MLast.ciExp = cfb} ] ] ; class_fun_binding: [ [ "="; ce = class_expr -> ce | ":"; ct = class_type; "="; ce = class_expr -> <:class_expr< ($ce$ : $ct$) >> | p = patt LEVEL "simple"; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ] ; class_type_parameters: [ [ -> (loc, []) | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ] ; class_fun_def: [ [ p = patt LEVEL "simple"; "->"; ce = class_expr -> <:class_expr< fun $p$ -> $ce$ >> | p = patt LEVEL "simple"; cfd = SELF -> <:class_expr< fun $p$ -> $cfd$ >> ] ] ; class_expr: [ "top" [ "fun"; cfd = class_fun_def -> cfd | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in"; ce = SELF -> <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ] | "apply" NONA [ ce = SELF; e = expr LEVEL "label" -> <:class_expr< $ce$ $e$ >> ] | "simple" [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]"; ci = class_longident -> <:class_expr< $list:ci$ [ $list:[ct :: ctcl]$ ] >> | "["; ct = ctyp; "]"; ci = class_longident -> <:class_expr< $list:ci$ [ $ct$ ] >> | ci = class_longident -> <:class_expr< $list:ci$ >> | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" -> <:class_expr< object $opt:cspo$ $list:cf$ end >> | "("; ce = SELF; ":"; ct = class_type; ")" -> <:class_expr< ($ce$ : $ct$) >> | "("; ce = SELF; ")" -> ce ] ] ; class_structure: [ [ cf = LIST0 class_str_item -> cf ] ] ; class_self_patt: [ [ "("; p = patt; ")" -> p | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ] ; class_str_item: [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] -> <:class_str_item< inherit $ce$ $opt:pb$ >> | "val"; (lab, mf, e) = cvalue -> <:class_str_item< value $opt:mf$ $lab$ = $e$ >> | "method"; "private"; "virtual"; l = label; ":"; t = ctyp -> <:class_str_item< method virtual private $l$ : $t$ >> | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> <:class_str_item< method virtual private $l$ : $t$ >> | "method"; "virtual"; l = label; ":"; t = ctyp -> <:class_str_item< method virtual $l$ : $t$ >> | "method"; "private"; l = label; fb = fun_binding -> <:class_str_item< method private $l$ = $fb$ >> | "method"; l = label; fb = fun_binding -> <:class_str_item< method $l$ = $fb$ >> | "constraint"; t1 = ctyp; "="; t2 = ctyp -> <:class_str_item< type $t1$ = $t2$ >> | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ] ; cvalue: [ [ mf = OPT "mutable"; l = label; "="; e = expr -> (l, o2b mf, e) | mf = OPT "mutable"; l = label; ":"; t = ctyp; "="; e = expr -> (l, o2b mf, <:expr< ($e$ : $t$) >>) | mf = OPT "mutable"; l = label; ":"; t1 = ctyp; ":>"; t2 = ctyp; "="; e = expr -> (l, o2b mf, <:expr< ($e$ : $t1$ :> $t2$) >>) | mf = OPT "mutable"; l = label; ":>"; t = ctyp; "="; e = expr -> (l, o2b mf, <:expr< ($e$ :> $t$) >>) ] ] ; label: [ [ i = LIDENT -> i ] ] ; (* Class types *) class_type: [ [ t = ctyp LEVEL "ctyp1" -> class_type_of_ctyp loc t | t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> <:class_type< [ $t$ ] -> $ct$ >> | t = ctyp LEVEL "ctyp1"; "*"; tl = LIST1 ctyp LEVEL "simple" SEP "*"; "->"; ct = SELF -> <:class_type< [ ($t$ * $list:tl$) ] -> $ct$ >> | cs = class_signature -> cs ] ] ; class_signature: [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = clty_longident -> <:class_type< $list:id$ [ $list:tl$ ] >> | id = clty_longident -> <:class_type< $list:id$ >> | "object"; cst = OPT class_self_type; csf = LIST0 class_sig_item; "end" -> <:class_type< object $opt:cst$ $list:csf$ end >> ] ] ; class_self_type: [ [ "("; t = ctyp; ")" -> t ] ] ; class_sig_item: [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >> | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> | "method"; "private"; "virtual"; l = label; ":"; t = ctyp -> <:class_sig_item< method virtual private $l$ : $t$ >> | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> <:class_sig_item< method virtual private $l$ : $t$ >> | "method"; "virtual"; l = label; ":"; t = ctyp -> <:class_sig_item< method virtual $l$ : $t$ >> | "method"; "private"; l = label; ":"; t = ctyp -> <:class_sig_item< method private $l$ : $t$ >> | "method"; l = label; ":"; t = ctyp -> <:class_sig_item< method $l$ : $t$ >> | "constraint"; t1 = ctyp; "="; t2 = ctyp -> <:class_sig_item< type $t1$ = $t2$ >> ] ] ; class_description: [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; ":"; ct = class_type -> {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; MLast.ciNam = n; MLast.ciExp = ct} | vf = OPT "virtual"; ctp = class_type_parameters; n = LABEL; ct = class_type -> {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; MLast.ciNam = n; MLast.ciExp = ct} ] ] ; class_type_declaration: [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; "="; cs = class_signature -> {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; MLast.ciNam = n; MLast.ciExp = cs} ] ] ; (* Expressions *) expr: LEVEL "apply" [ LEFTA [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ] ; expr: LEVEL "simple" [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ] ; expr: LEVEL "simple" [ [ "("; e = SELF; ":"; t1 = ctyp; ":>"; t2 = ctyp; ")" -> <:expr< ($e$ : $t1$ :> $t2$) >> | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >> | "{<"; ">}" -> <:expr< {< >} >> | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $list:fel$ >} >> ] ] ; field_expr_list: [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF -> [(l, e) :: fel] | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)] | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ] ; (* Core types *) ctyp: LEVEL "simple" [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >> | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >> | "<"; ">" -> <:ctyp< < > >> ] ] ; meth_list: [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v) | f = field; ";" -> ([f], False) | f = field -> ([f], False) | ".." -> ([], True) ] ] ; field: [ [ lab = LIDENT; ":"; t = ctyp -> (lab, t) | lab = LABEL; t = ctyp -> (lab, t) ] ] ; (* Identifiers *) clty_longident: [ [ m = UIDENT; "."; l = SELF -> [m :: l] | i = LIDENT -> [i] ] ] ; class_longident: [ [ m = UIDENT; "."; l = SELF -> [m :: l] | i = LIDENT -> [i] ] ] ; END; (* Labels *) EXTEND GLOBAL: ctyp expr patt fun_def fun_binding class_type class_fun_binding; ctyp: AFTER "arrow" [ NONA [ i = LABEL; t = SELF -> <:ctyp< ~ $i$ : $t$ >> | "?"; i = LABEL; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] ] ; ctyp: LEVEL "simple" [ [ "["; OPT "|"; rfl = LIST0 row_field SEP "|"; "]" -> <:ctyp< [ = $list:rfl$ ] >> | "["; ">"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> <:ctyp< [ > $list:rfl$ ] >> | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> <:ctyp< [ < $list:rfl$ ] >> | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; ">"; ntl = LIST1 name_tag; "]" -> <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] ; row_field: [ [ "`"; i = ident -> MLast.RfTag i False [] | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" -> MLast.RfTag i (o2b ao) l | "`"; i = ident; "&"; l = LIST1 ctyp SEP "&" -> MLast.RfTag i True l | "`"; i = ident; l = LIST1 ctyp SEP "&" -> MLast.RfTag i False l ] ] ; name_tag: [ [ "`"; i = ident -> i ] ] ; expr: LEVEL "expr1" [ [ "fun"; p = labeled_patt; e = fun_def -> <:expr< fun $p$ -> $e$ >> ] ] ; expr: AFTER "apply" [ "label" [ i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >> | i = ELABEL -> <:expr< ~ $i$ >> | "?"; i = LABEL; e = SELF -> <:expr< ? $i$ : $e$ >> | "?"; i = ELABEL -> <:expr< ? $i$ >> ] ] ; expr: LEVEL "simple" [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ] ; fun_def: [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] ; fun_binding: [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] ; patt: LEVEL "simple" [ [ "`"; s = ident -> <:patt< ` $s$ >> ] ] ; labeled_patt: [ [ i = LABEL; p = patt LEVEL "simple" -> <:patt< ~ $i$ : $p$ >> | i = ELABEL -> <:patt< ~ $i$ >> | "?"; i = LABEL; j = LIDENT -> <:patt< ? $i$ : ($lid:j$) >> | "?"; "("; i = LABEL; j = LIDENT; ")" -> <:patt< ? $i$ : ($lid:j$) >> | "?"; "("; i = LABEL; j = LIDENT; "="; e = expr; ")" -> <:patt< ? $i$ : ( $lid:j$ = $e$ ) >> | "?"; i = ELABEL -> <:patt< ? $i$ : ($lid:i$) >> | "?"; "("; i = ELABEL; "="; e = expr; ")" -> <:patt< ? $i$ : ( $lid:i$ = $e$ ) >> ] ] ; class_type: [ [ i = LABEL; t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >> | "?"; i = LABEL; t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> ] ] ; class_fun_binding: [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ] ; ident: [ [ i = LIDENT -> i | i = UIDENT -> i ] ] ; END; type spat_comp = [ SpTrm of Loc.t and MLast.patt and option MLast.expr | SpNtr of Loc.t and MLast.patt and MLast.expr | SpStr of Loc.t and MLast.patt ] ; type sexp_comp = [ SeTrm of Loc.t and MLast.expr | SeNtr of Loc.t and MLast.expr ] ; value strm_n = "__strm"; value peek_fun loc = <:expr< Stream.peek >>; value junk_fun loc = <:expr< Stream.junk >>; (* Parsers. *) (* In syntax generated, many cases are optimisations. *) value rec pattern_eq_expression p e = match (p, e) with [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) -> pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 | _ -> False ] ; value is_raise e = match e with [ <:expr< raise $_$ >> -> True | _ -> False ] ; value is_raise_failure e = match e with [ <:expr< raise Stream.Failure >> -> True | _ -> False ] ; value rec handle_failure e = match e with [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> -> handle_failure e | <:expr< match $me$ with [ $list:pel$ ] >> -> handle_failure me && List.for_all (fun [ (_, None, e) -> handle_failure e | _ -> False ]) pel | <:expr< let $list:pel$ in $e$ >> -> List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> | <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> -> True | <:expr< raise $e$ >> -> match e with [ <:expr< Stream.Failure >> -> False | _ -> True ] | <:expr< $f$ $x$ >> -> is_constr_apply f && handle_failure f && handle_failure x | _ -> False ] and is_constr_apply = fun [ <:expr< $uid:_$ >> -> True | <:expr< $lid:_$ >> -> False | <:expr< $x$ $_$ >> -> is_constr_apply x | _ -> False ] ; value rec subst v e = let loc = MLast.loc_of_expr e in match e with [ <:expr< $lid:x$ >> -> let x = if x = v then strm_n else x in <:expr< $lid:x$ >> | <:expr< $uid:_$ >> -> e | <:expr< $int:_$ >> -> e | <:expr< $chr:_$ >> -> e | <:expr< $str:_$ >> -> e | <:expr< $_$ . $_$ >> -> e | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >> | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >> | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >> | _ -> raise Not_found ] and subst_pe v (p, e) = match p with [ <:patt< $lid:v'$ >> -> if v = v' then (p, e) else (p, subst v e) | _ -> raise Not_found ] ; value stream_pattern_component skont ckont = fun [ SpTrm loc p wo -> <:expr< match $peek_fun loc$ $lid:strm_n$ with [ Some $p$ $when:wo$ -> do { $junk_fun loc$ $lid:strm_n$; $skont$ } | _ -> $ckont$ ] >> | SpNtr loc p e -> let e = match e with [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> e | _ -> <:expr< $e$ $lid:strm_n$ >> ] in if pattern_eq_expression p skont then if is_raise_failure ckont then e else if handle_failure e then e else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> else if is_raise_failure ckont then <:expr< let $p$ = $e$ in $skont$ >> else if pattern_eq_expression <:patt< Some $p$ >> skont then <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >> else if is_raise ckont then let tst = if handle_failure e then e else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> in <:expr< let $p$ = $tst$ in $skont$ >> else <:expr< match try Some $e$ with [ Stream.Failure -> None ] with [ Some $p$ -> $skont$ | _ -> $ckont$ ] >> | SpStr loc p -> try match p with [ <:patt< $lid:v$ >> -> subst v skont | _ -> raise Not_found ] with [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ] ; value rec stream_pattern loc epo e ekont = fun [ [] -> match epo with [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >> | _ -> e ] | [(spc, err) :: spcl] -> let skont = let ekont err = let str = match err with [ Some estr -> estr | _ -> <:expr< "" >> ] in <:expr< raise (Stream.Error $str$) >> in stream_pattern loc epo e ekont spcl in let ckont = ekont err in stream_pattern_component skont ckont spc ] ; value stream_patterns_term loc ekont tspel = let pel = List.map (fun (p, w, loc, spcl, epo, e) -> let p = <:patt< Some $p$ >> in let e = let ekont err = let str = match err with [ Some estr -> estr | _ -> <:expr< "" >> ] in <:expr< raise (Stream.Error $str$) >> in let skont = stream_pattern loc epo e ekont spcl in <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >> in (p, w, e)) tspel in let pel = pel @ [(<:patt< _ >>, None, ekont ())] in <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >> ; value rec group_terms = fun [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] -> let (tspel, spel) = group_terms spel in ([(p, w, loc, spcl, epo, e) :: tspel], spel) | spel -> ([], spel) ] ; value rec parser_cases loc = fun [ [] -> <:expr< raise Stream.Failure >> | spel -> match group_terms spel with [ ([], [(spcl, epo, e) :: spel]) -> stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl | (tspel, spel) -> stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ] ; value cparser loc bpo pc = let e = parser_cases loc pc in let e = match bpo with [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >> | None -> e ] in let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in <:expr< fun $p$ -> $e$ >> ; value cparser_match loc me bpo pc = let pc = parser_cases loc pc in let e = match bpo with [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> | None -> pc ] in <:expr< let $lid:strm_n$ = $me$ in $e$ >> ; (* streams *) value rec not_computing = fun [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> | <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> -> True | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y | _ -> False ] and is_cons_apply_not_computing = fun [ <:expr< $uid:_$ >> -> True | <:expr< $lid:_$ >> -> False | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y | _ -> False ] ; value slazy loc e = match e with [ <:expr< $f$ () >> -> match f with [ <:expr< $lid:_$ >> -> f | _ -> <:expr< fun _ -> $e$ >> ] | _ -> <:expr< fun _ -> $e$ >> ] ; value rec cstream gloc = fun [ [] -> let loc = gloc in <:expr< Stream.sempty >> | [SeTrm loc e] -> if not_computing e then <:expr< Stream.ising $e$ >> else <:expr< Stream.lsing $slazy loc e$ >> | [SeTrm loc e :: secl] -> if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >> else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >> | [SeNtr loc e] -> if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >> | [SeNtr loc e :: secl] -> if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >> else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ] ; (* Syntax extensions in OCaml grammar *) EXTEND GLOBAL: expr; expr: LEVEL "expr1" [ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" -> <:expr< $cparser loc po pcl$ >> | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" -> <:expr< $cparser_match loc e po pcl$ >> ] ] ; parser_case: [ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr -> (sp, po, e) ] ] ; stream_patt: [ [ spc = stream_patt_comp -> [(spc, None)] | spc = stream_patt_comp; ";" -> [(spc, None)] | spc = stream_patt_comp; ";"; sp = stream_patt_comp_err_list -> [(spc, None) :: sp] | -> (* empty *) [] ] ] ; stream_patt_comp_err_list: [ [ spc = stream_patt_comp_err -> [spc] | spc = stream_patt_comp_err; ";" -> [spc] | spc = stream_patt_comp_err; ";"; sp = SELF -> [spc :: sp] ] ] ; stream_patt_comp: [ [ "'"; p = patt; eo = OPT [ "when"; e = expr LEVEL "expr1" -> e ] -> SpTrm loc p eo | p = patt; "="; e = expr LEVEL "expr1" -> SpNtr loc p e | p = patt -> SpStr loc p ] ] ; stream_patt_comp_err: [ [ spc = stream_patt_comp; eo = OPT [ "?"; e = expr LEVEL "expr1" -> e ] -> (spc, eo) ] ] ; ipatt: [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ] ; expr: LEVEL "simple" [ [ "[<"; ">]" -> <:expr< $cstream loc []$ >> | "[<"; sel = stream_expr_comp_list; ">]" -> <:expr< $cstream loc sel$ >> ] ] ; stream_expr_comp_list: [ [ se = stream_expr_comp; ";"; sel = SELF -> [se :: sel] | se = stream_expr_comp; ";" -> [se] | se = stream_expr_comp -> [se] ] ] ; stream_expr_comp: [ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e | e = expr LEVEL "expr1" -> SeNtr loc e ] ] ; END; mingw-ocaml/ocaml/camlp4/unmaintained/olabl/Makefile0000644000175000017500000000375412124403240022053 0ustar tootstoots######################################################################### # # # OCaml # # # # Camlp4 # # # # Copyright 2004 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../../LICENSE.# # # ######################################################################### # # Makefile for pa_lefteval # M.Mauny # include ../../config/Makefile.cnf OCAMLTOP=../../.. CAMLP4=../../camlp4/camlp4$(EXE) OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) P4INCLUDES= -nolib -I ../../meta -I ../../lib -I ../../etc OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../lib -I ../../camlp4 OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) SRC=pa_olabl.ml OBJS=$(SRC:.ml=.cmo) OBJSX=$(SRC:.ml=.cmx) all: $(OBJS) opt: $(OBJSX) depend: cp .depend .depend.bak > .depend for file in $(SRC); do \ $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ done clean: rm -f *.cm* *.$(O) *.bak .*.bak .SUFFIXES: .cmx .cmo .cmi .ml .mli .mli.cmi: $(OCAMLC) $(OCAMLCFLAGS) -c $< .ml.cmo: $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< .ml.cmx: $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< include .depend mingw-ocaml/ocaml/camlp4/unmaintained/olabl/README0000644000175000017500000000104312124403240021260 0ustar tootstootsThis is an application of or an extension for Camlp4. Although it is currently distributed with OCaml/Camlp4, it may or may not be actively maintained. It probably won't be part of future OCaml/Camlp4 distributions but be accessible from the Camlp4 hump. If you are interested in developing this package further and/or actively maintain it, please let us know (caml@inria.fr) This package is distributed under the same license as the OCaml Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny mingw-ocaml/ocaml/camlp4/unmaintained/olabl/.depend0000644000175000017500000000000012124403240021630 0ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/lib/0000755000175000017500000000000012124403240020057 5ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/lib/.cvsignore0000644000175000017500000000003012124403240022050 0ustar tootstoots*.cm[oiax] *.cmxa *.lib mingw-ocaml/ocaml/camlp4/unmaintained/lib/fstream.ml0000644000175000017500000000321412124403240022052 0ustar tootstoots(* camlp4r *) (* Copyright 2001 INRIA *) type t 'a = { count : int; data : Lazy.t (data 'a) } and data 'a = [ Nil | Cons of 'a and t 'a | App of t 'a and t 'a ] ; value from f = loop 0 where rec loop i = {count = 0; data = lazy (match f i with [ Some x -> Cons x (loop (i + 1)) | None -> Nil ])} ; value rec next s = let count = s.count + 1 in match Lazy.force s.data with [ Nil -> None | Cons a s -> Some (a, {count = count; data = s.data}) | App s1 s2 -> match next s1 with [ Some (a, s1) -> Some (a, {count = count; data = lazy (App s1 s2)}) | None -> match next s2 with [ Some (a, s2) -> Some (a, {count = count; data = s2.data}) | None -> None ] ] ] ; value empty s = match next s with [ Some _ -> None | None -> Some ((), s) ] ; value nil = {count = 0; data = lazy Nil}; value cons a s = Cons a s; value app s1 s2 = App s1 s2; value flazy f = {count = 0; data = Lazy.lazy_from_fun f}; value of_list l = List.fold_right (fun x s -> flazy (fun () -> cons x s)) l nil ; value of_string s = from (fun c -> if c < String.length s then Some s.[c] else None) ; value of_channel ic = from (fun _ -> try Some (input_char ic) with [ End_of_file -> None ]) ; value iter f = do_rec where rec do_rec strm = match next strm with [ Some (a, strm) -> let _ = f a in do_rec strm | None -> () ] ; value count s = s.count; value count_unfrozen s = loop 0 s where rec loop cnt s = if Lazy.lazy_is_val s.data then match Lazy.force s.data with [ Cons _ s -> loop (cnt + 1) s | _ -> cnt ] else cnt ; mingw-ocaml/ocaml/camlp4/unmaintained/lib/extfun.ml0000644000175000017500000000447412124403240021733 0ustar tootstoots(* camlp4r *) (* Copyright 2001 INRIA *) (* Extensible Functions *) type t 'a 'b = list (matching 'a 'b) and matching 'a 'b = { patt : patt; has_when : bool; expr : expr 'a 'b } and patt = [ Eapp of list patt | Eacc of list patt | Econ of string | Estr of string | Eint of string | Etup of list patt | Evar of unit ] and expr 'a 'b = 'a -> option 'b ; exception Failure; value empty = []; (*** Apply ***) value rec apply_matchings a = fun [ [m :: ml] -> match m.expr a with [ None -> apply_matchings a ml | x -> x ] | [] -> None ] ; value apply ef a = match apply_matchings a ef with [ Some x -> x | None -> raise Failure ] ; (*** Trace ***) value rec list_iter_sep f s = fun [ [] -> () | [x] -> f x | [x :: l] -> do { f x; s (); list_iter_sep f s l } ] ; value rec print_patt = fun [ Eapp pl -> list_iter_sep print_patt2 (fun () -> print_string " ") pl | p -> print_patt2 p ] and print_patt2 = fun [ Eacc pl -> list_iter_sep print_patt1 (fun () -> print_string ".") pl | p -> print_patt1 p ] and print_patt1 = fun [ Econ s -> print_string s | Estr s -> do { print_string "\""; print_string s; print_string "\"" } | Eint s -> print_string s | Evar () -> print_string "_" | Etup pl -> do { print_string "("; list_iter_sep print_patt (fun () -> print_string ", ") pl; print_string ")" } | Eapp _ | Eacc _ as p -> do { print_string "("; print_patt p; print_string ")" } ] ; value print ef = List.iter (fun m -> do { print_patt m.patt; if m.has_when then print_string " when ..." else (); print_newline () }) ef ; (*** Extension ***) value insert_matching matchings (patt, has_when, expr) = let m1 = {patt = patt; has_when = has_when; expr = expr} in let rec loop = fun [ [m :: ml] as gml -> if m1.has_when && not m.has_when then [m1 :: gml] else if not m1.has_when && m.has_when then [m :: loop ml] else (* either both or none have a when clause *) if compare m1.patt m.patt = 0 then if not m1.has_when then [m1 :: ml] else [m1 :: gml] else [m :: loop ml] | [] -> [m1] ] in loop matchings ; (* available extension function *) value extend ef matchings_def = List.fold_left insert_matching ef matchings_def ; mingw-ocaml/ocaml/camlp4/unmaintained/lib/Makefile0000644000175000017500000000301512124403240021516 0ustar tootstoots include ../config/Makefile.cnf INCLUDES=-I $(OTOP)/parsing -I $(OTOP)/utils LIBRARIES=gramlib.cma OBJS=$(OTOP)/utils/misc.cmo $(OTOP)/parsing/linenum.cmo \ $(OTOP)/utils/warnings.cmo $(OTOP)/parsing/location.cmo \ $(OTOP)/utils/config.cmo debug.cmo loc.cmo \ token.cmo lexer_token.cmo lexer_error.cmo \ plexer.cmo grammar.cmo extfun.cmo \ fstream.cmo CLEANFILES=plexer.ml include ../config/Makefile.base debug.cmo: debug.cmi debug.cmo: debug.ml $(OCAMLC) -pp '$(CAMLP4BOOT)' -rectypes $(OCAMLCFLAGS) $< -c -o $@ plexer.cmo: plexer.ml plexer.cmi $(OCAMLC) $(OCAMLCFLAGS) $< -c -o $@ plexer.cmx: plexer.ml plexer.cmi $(OCAMLOPT) $(OCAMLCFLAGS) $< -c -o $@ $(LIBRARIES): $(OBJS) $(OCAMLC) -linkall $(OBJS) -a -o $(LIBRARIES) $(LIBRARIESX): $(OBJSX) $(OCAMLOPT) -linkall $(OBJSX) -a -o $(LIBRARIESX) $(LIBRARIESP): $(OBJSP) $(OCAMLOPT) -linkall $(OBJSP) -a -o $(LIBRARIESP) install-local: -$(MKDIR) "$(LIBDIR)/camlp4" cp $(LIBRARIES) *.mli "$(LIBDIR)/camlp4/." cp *.cmi "$(LIBDIR)/camlp4/." test -f $(LIBRARIESX) && $(MAKE) installopt LIBDIR="$(LIBDIR)" || true installopt: for f in $(LIBRARIESX) $(LIBRARIESP) *.cmx ; do \ test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true ; \ done # Special treatment for this one: some versions of make don't like $(A) in $(TARGET:.cma=.$(A)) target="`echo $(LIBRARIES) | sed -e 's/\.cma$$/.$(A)/'`" ; \ if test -f $$target ; then \ cp $$target "$(LIBDIR)/camlp4/." && ( cd "$(LIBDIR)/camlp4/." && $(RANLIB) $$target ) \ fi include .depend mingw-ocaml/ocaml/camlp4/unmaintained/lib/extfun.mli0000644000175000017500000000152612124403240022077 0ustar tootstoots(* camlp4r *) (** Extensible functions. This module implements pattern matching extensible functions. To extend, use syntax [pa_extfun.cmo]: [extfun e with [ pattern_matching ]] *) type t 'a 'b = 'x; (** The type of the extensible functions of type ['a -> 'b] *) value empty : t 'a 'b; (** Empty extensible function *) value apply : t 'a 'b -> 'a -> 'b; (** Apply an extensible function *) exception Failure; (** Match failure while applying an extensible function *) value print : t 'a 'b -> unit; (** Print patterns in the order they are recorded *) (**/**) type patt = [ Eapp of list patt | Eacc of list patt | Econ of string | Estr of string | Eint of string | Etup of list patt | Evar of unit ] and expr 'a 'b = 'a -> option 'b ; value extend : t 'a 'b -> list (patt * bool * expr 'a 'b) -> t 'a 'b; mingw-ocaml/ocaml/camlp4/unmaintained/lib/.depend0000644000175000017500000000055312124403240021322 0ustar tootstootsdebug.cmo: debug.cmi debug.cmx: debug.cmi extfun.cmo: extfun.cmi extfun.cmx: extfun.cmi fstream.cmo: fstream.cmi fstream.cmx: fstream.cmi grammar.cmo: token.cmi plexer.cmi loc.cmi grammar.cmx: token.cmx plexer.cmi loc.cmx loc.cmo: loc.cmi loc.cmx: loc.cmi token.cmo: loc.cmi token.cmi token.cmx: loc.cmx token.cmi plexer.cmi: token.cmi loc.cmi token.cmi: loc.cmi mingw-ocaml/ocaml/camlp4/unmaintained/lib/fstream.mli0000644000175000017500000000445612124403240022234 0ustar tootstoots(* camlp4r *) (* Module [Fstream]: functional streams *) (* This module implement functional streams. To be used with syntax [pa_fstream.cmo]. The syntax is: - stream: [fstream [: ... :]] - parser: [parser [ [: ... :] -> ... | ... ]] Functional parsers are of type: [Fstream.t 'a -> option ('a * Fstream.t 'a)] They have limited backtrack, i.e if a rule fails, the next rule is tested with the initial stream; limited because when in case of a rule with two consecutive symbols [a] and [b], if [b] fails, the rule fails: there is no try with the next rule of [a]. *) type t 'a = 'x; (* The type of 'a functional streams *) value from : (int -> option 'a) -> t 'a; (* [Fstream.from f] returns a stream built from the function [f]. To create a new stream element, the function [f] is called with the current stream count. The user function [f] must return either [Some ] for a value or [None] to specify the end of the stream. *) value of_list : list 'a -> t 'a; (* Return the stream holding the elements of the list in the same order. *) value of_string : string -> t char; (* Return the stream of the characters of the string parameter. *) value of_channel : in_channel -> t char; (* Return the stream of the characters read from the input channel. *) value iter : ('a -> unit) -> t 'a -> unit; (* [Fstream.iter f s] scans the whole stream s, applying function [f] in turn to each stream element encountered. *) value next : t 'a -> option ('a * t 'a); (* Return [Some (a, s)] where [a] is the first element of the stream and [s] the remaining stream, or [None] if the stream is empty. *) value empty : t 'a -> option (unit * t 'a); (* Return [Some ((), s)] if the stream is empty where [s] is itself, else [None] *) value count : t 'a -> int; (* Return the current count of the stream elements, i.e. the number of the stream elements discarded. *) value count_unfrozen : t 'a -> int; (* Return the number of unfrozen elements in the beginning of the stream; useful to determine the position of a parsing error (longuest path). *) (*--*) value nil : t 'a; type data 'a = 'x; value cons : 'a -> t 'a -> data 'a; value app : t 'a -> t 'a -> data 'a; value flazy : (unit -> data 'a) -> t 'a; mingw-ocaml/ocaml/camlp4/unmaintained/compile/0000755000175000017500000000000012124403240020741 5ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/compile/.ignore0000644000175000017500000000005112124403240022221 0ustar tootstoots*.fast *.fast.opt o_fast.ml pa_o_fast.ml mingw-ocaml/ocaml/camlp4/unmaintained/compile/Makefile0000644000175000017500000000264512124403240022410 0ustar tootstoots include ../config/Makefile.cnf INCLUDES=-I ../camlp4 -I ../lib SRC=../etc/pa_o.ml ../etc/pa_op.ml # FIXME and why not pa_$D.ml? D=o COMP_OPT=-strict_parsing -e "Grammar.Entry.obj Pcaml.interf" -e "Grammar.Entry.obj Pcaml.implem" -e "Grammar.Entry.obj Pcaml.top_phrase" -e "Grammar.Entry.obj Pcaml.use_file" CLEANFILES=pa_*_fast.ml *_fast.ml # FIXME EXECUTABLES=#camlp4$D.fast include ../config/Makefile.base WARNINGS=Ay camlp4$D.fast: pa_$D_fast.cmo rm -f camlp4$D.fast cd ../camlp4; $(MAKE) CAMLP4=../compile/camlp4$D.fast CAMLP4M="../compile/pa_$D_fast.cmo ../meta/pr_dump.cmo" camlp4$D.fast.opt: pa_$D_fast.cmx rm -f camlp4$D.fast.opt cd ../camlp4; $(MAKE) ../compile/camlp4$D.fast.opt CAMLP4OPT=../compile/camlp4$D.fast.opt CAMLP4M="../compile/pa_$D_fast.cmx ../meta/pr_dump.cmx" pa_$D_fast.ml: comp_head.ml $D_fast.ml comp_trail.ml cat $(SRC) | sed -e "s/Plexer.make_lexer *()/P.lexer_pos/" -e "/EXTEND/,/END/d" -e "/Grammar.Entry.of_parser/d" -e "/Grammar.Entry.gcreate/d" | cat comp_head.ml - $D_fast.ml comp_trail.ml > pa_$D_fast.ml $D_fast.ml: compile.cmo $(SRC) echo '(* camlp4r *)' >$D_fast.ml OTOP=$(OTOP) EXE=$(EXE) ./compile.sh $(COMP_OPT) $(SRC) >> $D_fast.ml install-local: if test -f camlp4$D.fast.opt; then cp camlp4$D.fast.opt $(BINDIR)/camlp4$D.opt$(EXE); fi for TARG in pa_$D_fast.cmi pa_$D_fast.cmo pa_$D_fast.cmx ; do if test -f $$TARG; then cp $$TARG "$(LIBDIR)/camlp4/."; fi; done include .depend mingw-ocaml/ocaml/camlp4/unmaintained/compile/compile.sh0000755000175000017500000000151012124403240022725 0ustar tootstoots#!/bin/sh -e ARGS= FILES= ENTRIES= while test "" != "$1"; do case $1 in -e) shift; if test "$ENTRIES" != ""; then ENTRIES="$ENTRIES; "; fi ENTRIES="$ENTRIES$1";; *.ml*) FILES="$FILES $1";; *) ARGS="$ARGS $1";; esac shift done cat $FILES | sed -e 's/Pcaml.parse_i.*$//' > tmp.ml echo "Compile.entries.val := [$ENTRIES];" >> tmp.ml > tmp.mli set -x $OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -I $OTOP/boot -c tmp.mli $OTOP/boot/ocamlrun$EXE ../boot/camlp4boot$EXE -meta_action tmp.ml -o tmp.ppo $OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -I $OTOP/boot -I ../lib -I ../camlp4 -c -impl tmp.ppo rm tmp.ppo > tmp.null $OTOP/boot/ocamlrun$EXE ../camlp4/camlp4$EXE ./compile.cmo ./tmp.cmo ../etc/pr_r.cmo ../etc/pr_rp.cmo $ARGS -sep "\n\n" -impl tmp.null && rm tmp.* mingw-ocaml/ocaml/camlp4/unmaintained/compile/compile.ml0000644000175000017500000004274012124403240022732 0ustar tootstoots(* camlp4r *) open Gramext; value strict_parsing = ref False; value keywords = ref []; value _loc = Loc.ghost; (* Watch the segmentation faults here! the compiled file must have been loaded in camlp4 with the option pa_extend.cmo -meta_action. *) value magic_act (act : Obj.t) : MLast.expr = Obj.magic act; (* Names of symbols for error messages; code borrowed to grammar.ml *) value rec name_of_symbol entry = fun [ Snterm e -> "[" ^ e.ename ^ "]" | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]" | Sself | Snext -> "[" ^ entry.ename ^ "]" | Stoken tok -> entry.egram.glexer.Token.tok_text tok | _ -> "???" ] ; value rec name_of_symbol_failed entry = fun [ Slist0 s -> name_of_symbol_failed entry s | Slist0sep s _ -> name_of_symbol_failed entry s | Slist1 s -> name_of_symbol_failed entry s | Slist1sep s _ -> name_of_symbol_failed entry s | Sopt s -> name_of_symbol_failed entry s | Stree t -> name_of_tree_failed entry t | s -> name_of_symbol entry s ] and name_of_tree_failed entry = fun [ Node {node = s; brother = bro; son = son} -> let txt = name_of_symbol_failed entry s in let txt = match (s, son) with [ (Sopt _, Node _) -> txt ^ " or " ^ name_of_tree_failed entry son | _ -> txt ] in let txt = match bro with [ DeadEnd | LocAct _ _ -> txt | _ -> txt ^ " or " ^ name_of_tree_failed entry bro ] in txt | DeadEnd | LocAct _ _ -> "???" ] ; value tree_failed entry prev_symb tree = let (s2, s3) = let txt = name_of_tree_failed entry tree in match prev_symb with [ Slist0 s -> let txt1 = name_of_symbol_failed entry s in ("", txt1 ^ " or " ^ txt) | Slist1 s -> let txt1 = name_of_symbol_failed entry s in ("", txt1 ^ " or " ^ txt) | Slist0sep s sep -> let txt1 = name_of_symbol_failed entry s in ("", txt1 ^ " or " ^ txt) | Slist1sep s sep -> let txt1 = name_of_symbol_failed entry s in ("", txt1 ^ " or " ^ txt) | Sopt _ | Stree _ -> ("", txt) | _ -> (name_of_symbol entry prev_symb, txt) ] in <:expr< P.error $str:entry.ename$ $`str:s2$ $`str:s3$ >> ; (* Compilation *) value rec find_act = fun [ DeadEnd -> failwith "find_act" | LocAct act _ -> (magic_act act, 0) | Node {son = son; brother = bro} -> let (act, n) = try find_act son with [ Failure _ -> find_act bro ] in (act, n + 1) ] ; value level_number e l = match e.edesc with [ Dlevels elevs -> loop 0 elevs where rec loop n = fun [ [lev :: levs] -> if lev.lname = Some l then n else loop (n + 1) levs | [] -> failwith ("level " ^ l ^ " not found in entry " ^ e.ename) ] | Dparser _ -> 0 ] ; value nth_patt_of_act (e, n) = let patt_list = loop e where rec loop = fun [ <:expr< fun (_loc : Locaction.t) -> $_$ >> -> [] | <:expr< fun ($p$ : $_$) -> $e$ >> -> [p :: loop e] | <:expr< fun $p$ -> $e$ >> -> [p :: loop e] | _ -> failwith "nth_patt_of_act" ] in List.nth patt_list n ; value rec last_patt_of_act = fun [ <:expr< fun ($p$ : $_$) (_loc : Locaction.t) -> $_$ >> -> p | <:expr< fun $_$ -> $e$ >> -> last_patt_of_act e | _ -> failwith "last_patt_of_act" ] ; #load "pr_r.cmo"; value rec final_action = fun [ <:expr< fun (_loc : Loc.t) -> ($e$ : $_$) >> -> e | <:expr< fun $_$ -> $e$ >> -> final_action e | ast -> do { print_endline "final_action failed"; Pcaml.print_implem.val [(MLast.StExp _loc ast, _loc)]; failwith "final_action"; } ] ; value parse_standard_symbol e rkont fkont ending_act = <:expr< match try Some ($e$ __strm) with [ Stream.Failure -> None ] with [ Some $nth_patt_of_act ending_act$ -> $rkont$ | _ -> $fkont$ ] >> ; value parse_symbol_no_failure e rkont fkont ending_act = <:expr< let $nth_patt_of_act ending_act$ = try $e$ __strm with [ Stream.Failure -> raise (Stream.Error "") ] in $rkont$ >> ; value rec contain_loc = fun [ <:expr< $lid:s$ >> -> (s = "loc") || (s = "_loc") | <:expr< $uid:_$ >> -> False | <:expr< $str:_$ >> -> False | <:expr< ($list:el$) >> -> List.exists contain_loc el | <:expr< $e1$ $e2$ >> -> contain_loc e1 || contain_loc e2 | _ -> True ] ; value gen_let_loc _loc e = if contain_loc e then <:expr< let _loc = P.gloc bp __strm in $e$ >> else e ; value phony_entry = Grammar.Entry.obj Pcaml.implem; value rec parse_tree entry nlevn alevn (tree, fst_symb) act_kont kont = match tree with [ DeadEnd -> kont | LocAct act _ -> let act = magic_act act in act_kont False act | Node {node = Sself; son = LocAct act _; brother = bro} -> let act = magic_act act in let n = entry.ename ^ "_" ^ string_of_int alevn in let e = if strict_parsing.val || alevn = 0 || fst_symb then <:expr< $lid:n$ >> else <:expr< P.orzero $lid:n$ $lid:entry.ename ^ "_0"$ >> in let p2 = match bro with [ DeadEnd -> kont | _ -> parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont ] in let p1 = act_kont True act in parse_standard_symbol e p1 p2 (act, 0) | Node {node = s; son = LocAct act _; brother = bro} -> let act = magic_act act in let p2 = parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont in let p1 = act_kont False act in parse_symbol entry nlevn s p1 p2 (act, 0) | Node {node = s; son = son; brother = bro} -> let p2 = parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont in let p1 = let err = let txt = tree_failed entry s son in <:expr< raise (Stream.Error $txt$) >> in match son with [ Node {brother = DeadEnd} -> parse_tree entry nlevn alevn (son, False) act_kont err | _ -> let p1 = parse_tree entry nlevn alevn (son, True) act_kont <:expr< raise Stream.Failure >> in <:expr< try $p1$ with [ Stream.Failure -> $err$ ] >> ] in parse_symbol entry nlevn s p1 p2 (find_act son) ] and parse_symbol entry nlevn s rkont fkont ending_act = match s with [ Slist0 s -> let e = <:expr< P.list0 $symbol_parser entry nlevn s$ >> in parse_symbol_no_failure e rkont fkont ending_act | Slist1 s -> let e = <:expr< P.list1 $symbol_parser entry nlevn s$ >> in parse_standard_symbol e rkont fkont ending_act | Slist0sep s sep -> let e = <:expr< P.list0sep $symbol_parser entry nlevn s$ $symbol_parser entry nlevn sep$ >> in parse_symbol_no_failure e rkont fkont ending_act | Slist1sep s sep -> let e = <:expr< P.list1sep $symbol_parser entry nlevn s$ $symbol_parser entry nlevn sep$ >> in parse_standard_symbol e rkont fkont ending_act | Sopt s -> let e = <:expr< P.option $symbol_parser entry nlevn s$ >> in parse_symbol_no_failure e rkont fkont ending_act | Stree tree -> let kont = <:expr< raise Stream.Failure >> in let act_kont _ act = gen_let_loc _loc (final_action act) in let e = parse_tree phony_entry 0 0 (tree, True) act_kont kont in parse_standard_symbol <:expr< fun __strm -> $e$ >> rkont fkont ending_act | Snterm e -> let n = match e.edesc with [ Dparser _ -> e.ename | Dlevels _ -> e.ename ^ "_0" ] in parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act | Snterml e l -> let n = e.ename ^ "_" ^ string_of_int (level_number e l) in parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act | Sself -> let n = entry.ename ^ "_0" in parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act | Snext -> let n = entry.ename ^ "_" ^ string_of_int nlevn in parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act | Stoken tok -> let _ = do { if fst tok = "" && not (List.mem (snd tok) keywords.val) then keywords.val := [snd tok :: keywords.val] else () } in let p = let patt = nth_patt_of_act ending_act in let p_con = fst tok in let p_prm = snd tok in if snd tok = "" then if fst tok = "ANY" then <:patt< (_, $patt$) >> else <:patt< ($`str:p_con$, $patt$) >> else match patt with [ <:patt< _ >> -> <:patt< ($`str:p_con$, $`str:p_prm$) >> | _ -> <:patt< ($`str:p_con$, ($`str:p_prm$ as $patt$)) >> ] in <:expr< match Stream.peek __strm with [ Some $p$ -> do { Stream.junk __strm; $rkont$ } | _ -> $fkont$ ] >> | _ -> parse_standard_symbol <:expr< not_impl >> rkont fkont ending_act ] and symbol_parser entry nlevn = fun [ Snterm e -> let n = e.ename ^ "_0" in <:expr< $lid:n$ >> | Snterml e l -> let n = e.ename ^ "_" ^ string_of_int (level_number e l) in <:expr< $lid:n$ >> | Snext -> let n = entry.ename ^ "_" ^ string_of_int nlevn in if strict_parsing.val then <:expr< $lid:n$ >> else let n0 = entry.ename ^ "_0" in <:expr< P.orzero $lid:n$ $lid:n0$ >> | Stoken tok -> let _ = do { if fst tok = "" && not (List.mem (snd tok) keywords.val) then keywords.val := [snd tok :: keywords.val] else () } in <:expr< P.token ($`str:fst tok$, $`str:snd tok$) >> | Stree tree -> let kont = <:expr< raise Stream.Failure >> in let act_kont _ act = final_action act in <:expr< fun __strm -> $parse_tree phony_entry 0 0 (tree, True) act_kont kont$ >> | _ -> <:expr< aaa >> ] ; value rec start_parser_of_levels entry clevn levs = let n = entry.ename ^ "_" ^ string_of_int clevn in let next = entry.ename ^ "_" ^ string_of_int (clevn + 1) in let p = <:patt< $lid:n$ >> in match levs with [ [] -> [Some (p, <:expr< fun __strm -> raise Stream.Failure >>)] | [lev :: levs] -> let pel = start_parser_of_levels entry (succ clevn) levs in match lev.lprefix with [ DeadEnd -> let ncont = if not strict_parsing.val && clevn = 0 then entry.ename ^ "_gen_cont" else entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in let curr = <:expr< let a = $lid:next$ __strm in $lid:ncont$ bp a __strm >> in let curr = <:expr< let bp = Stream.count __strm in $curr$ >> in let e = <:expr< fun __strm -> $curr$ >> in let pel = if levs = [] then [] else pel in [Some (p, e) :: pel] | tree -> let alevn = clevn in let (kont, pel) = match levs with [ [] -> (<:expr< raise Stream.Failure >>, []) | _ -> let e = match (lev.assoc, lev.lsuffix) with [ (NonA, _) | (_, DeadEnd) -> <:expr< $lid:next$ __strm >> | _ -> let ncont = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in <:expr< let a = $lid:next$ __strm in $lid:ncont$ bp a __strm >> ] in (e, pel) ] in let act_kont end_with_self act = if lev.lsuffix = DeadEnd then gen_let_loc _loc (final_action act) else let ncont = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in gen_let_loc _loc <:expr< $lid:ncont$ bp $final_action act$ __strm >> in let curr = parse_tree entry (succ clevn) alevn (tree, True) act_kont kont in let curr = <:expr< let bp = Stream.count __strm in $curr$ >> in let e = <:expr< fun __strm -> $curr$ >> in [Some (p, e) :: pel] ] ] ; value rec continue_parser_of_levels entry clevn levs = let n = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in let p = <:patt< $lid:n$ >> in match levs with [ [] -> [None] | [lev :: levs] -> let pel = continue_parser_of_levels entry (succ clevn) levs in match lev.lsuffix with [ DeadEnd -> [None :: pel] | tree -> let alevn = match lev.assoc with [ LeftA | NonA -> succ clevn | RightA -> clevn ] in let (kont, pel) = match levs with [ [] -> (<:expr< a__ >>, []) | _ -> (<:expr< a__ >>, pel) ] in let act_kont end_with_self act = let p = last_patt_of_act act in match lev.assoc with [ RightA | NonA -> <:expr< let $p$ = a__ in $gen_let_loc _loc (final_action act)$ >> | LeftA -> let ncont = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in gen_let_loc _loc <:expr< let $p$ = a__ in $lid:ncont$ bp $final_action act$ __strm >> ] in let curr = parse_tree entry (succ clevn) alevn (tree, True) act_kont kont in let e = <:expr< fun bp a__ __strm -> $curr$ >> in [Some (p, e) :: pel] ] ] ; value continue_parser_of_levels_again entry levs = let n = entry.ename ^ "_gen_cont" in let e = loop <:expr< a__ >> 0 levs where rec loop var levn = fun [ [] -> <:expr< if x == a__ then x else $lid:n$ bp x __strm >> | [lev :: levs] -> match lev.lsuffix with [ DeadEnd -> loop var (levn + 1) levs | _ -> let n = entry.ename ^ "_" ^ string_of_int levn ^ "_cont" in let rest = loop <:expr< x >> (levn + 1) levs in <:expr< let x = $lid:n$ bp $var$ __strm in $rest$ >> ] ] in (<:patt< $lid:n$ >>, <:expr< fun bp a__ __strm -> $e$ >>) ; value empty_entry ename = let p = <:patt< $lid:ename$ >> in let e = <:expr< fun __strm -> raise (Stream.Error $str:"entry [" ^ ename ^ "] is empty"$) >> in [Some (p, e)] ; value start_parser_of_entry entry = match entry.edesc with [ Dlevels [] -> empty_entry entry.ename | Dlevels elev -> start_parser_of_levels entry 0 elev | Dparser p -> [] ] ; value continue_parser_of_entry entry = match entry.edesc with [ Dlevels elev -> continue_parser_of_levels entry 0 elev | Dparser p -> [] ] ; value continue_parser_of_entry_again entry = if strict_parsing.val then [] else match entry.edesc with [ Dlevels ([_; _ :: _] as levs) -> [continue_parser_of_levels_again entry levs] | _ -> [] ] ; value rec list_alternate l1 l2 = match (l1, l2) with [ ([x1 :: l1], [x2 :: l2]) -> [x1; x2 :: list_alternate l1 l2] | ([], l2) -> l2 | (l1, []) -> l1 ] ; value compile_entry entry = let pel1 = start_parser_of_entry entry in let pel2 = continue_parser_of_entry entry in let pel = list_alternate pel1 pel2 in List.fold_right (fun pe list -> match pe with [ Some pe -> [pe :: list] | None -> list ]) pel (continue_parser_of_entry_again entry) ; (* get all entries connected together *) value rec scan_tree list = fun [ Node {node = n; son = son; brother = bro} -> let list = scan_symbol list n in let list = scan_tree list son in let list = scan_tree list bro in list | LocAct _ _ | DeadEnd -> list ] and scan_symbol list = fun [ Snterm e -> scan_entry list e | Snterml e l -> scan_entry list e | Slist0 s -> scan_symbol list s | Slist0sep s sep -> scan_symbol (scan_symbol list s) sep | Slist1 s -> scan_symbol list s | Slist1sep s sep -> scan_symbol (scan_symbol list s) sep | Sopt s -> scan_symbol list s | Stree t -> scan_tree list t | Smeta _ _ _ | Sself | Snext | Stoken _ -> list ] and scan_level list lev = let list = scan_tree list lev.lsuffix in let list = scan_tree list lev.lprefix in list and scan_levels list levs = List.fold_left scan_level list levs and scan_entry list entry = if List.memq entry list then list else match entry.edesc with [ Dlevels levs -> scan_levels [entry :: list] levs | Dparser _ -> list ] ; value all_entries_in_graph list entry = List.rev (scan_entry list entry) ; (* main *) value entries = ref []; value rec list_mem_right_assoc x = fun [ [] -> False | [(a, b) :: l] -> x = b || list_mem_right_assoc x l ] ; value rec expr_list = fun [ [] -> <:expr< [] >> | [x :: l] -> <:expr< [$`str:x$ :: $expr_list l$] >> ] ; value compile () = let _ = do { keywords.val := []; } in let list = List.fold_left all_entries_in_graph [] entries.val in let list = List.filter (fun e -> List.memq e list) entries.val @ List.filter (fun e -> not (List.memq e entries.val)) list in let list = let set = ref [] in List.fold_right (fun entry list -> if List.mem entry.ename set.val then list else do { set.val := [entry.ename :: set.val]; [entry :: list] }) list [] in let pell = List.map compile_entry list in let pel = List.flatten pell in let si1 = <:str_item< value rec $list:pel$ >> in let si2 = let list = List.sort compare keywords.val in <:str_item< List.iter (fun kw -> P.lexer.Token.tok_using ("", kw)) $expr_list list$ >> in let loc = Loc.ghost in ([(si1, loc); (si2, loc)], False) ; Pcaml.parse_implem.val := fun _ _ -> compile (); Pcaml.add_option "-strict_parsing" (Arg.Set strict_parsing) "Don't generate error recovering by trying continuations or first levels" ; mingw-ocaml/ocaml/camlp4/unmaintained/compile/comp_head.ml0000644000175000017500000000343112124403240023213 0ustar tootstoots(* camlp4r q_MLast.cmo pa_extend.cmo *) module P = struct value gloc bp strm = Grammar.loc_of_token_interval bp (Stream.count strm); value list0 symb = let rec loop al = parser [ [: a = symb; s :] -> loop [a :: al] s | [: :] -> al ] in parser [: a = loop [] :] -> List.rev a ; value list0sep symb sep = let rec kont al = parser [ [: v = sep; a = symb; s :] -> kont [a :: al] s | [: :] -> al ] in parser [ [: a = symb; s :] -> List.rev (kont [a] s) | [: :] -> [] ] ; value list1 symb = let rec loop al = parser [ [: a = symb; s :] -> loop [a :: al] s | [: :] -> al ] in parser [: a = symb; s :] -> List.rev (loop [a] s) ; value list1sep symb sep = let rec kont al = parser [ [: v = sep; a = symb; s :] -> kont [a :: al] s | [: :] -> al ] in parser [: a = symb; s :] -> List.rev (kont [a] s) ; value option f = parser [ [: x = f :] -> Some x | [: :] -> None ] ; value token (p_con, p_prm) = if p_prm = "" then parser [: `(con, prm) when con = p_con :] -> prm else parser [: `(con, prm) when con = p_con && prm = p_prm :] -> prm ; value orzero f f0 = parser bp [ [: x = f :] -> x | [: x = f0 :] ep -> (* let (loc1, loc2) = Grammar.loc_of_token_interval bp ep in let _ = do { Printf.eprintf "recovered or_zero at loc (%d, %d)\n" loc1 loc2; flush stderr } in *) x ] ; value error entry prev_symb symb = symb ^ " expected" ^ (if prev_symb = "" then "" else " after " ^ prev_symb) ^ " (in [" ^ entry ^ "])" ; value lexer = Plexer.gmake(); end ; (****************************************) mingw-ocaml/ocaml/camlp4/unmaintained/compile/comp_trail.ml0000644000175000017500000000111612124403240023423 0ustar tootstoots(* camlp4r pa_extend.cmo *) (****************************************) value interf_p = Grammar.Entry.of_parser Pcaml.gram "interf" interf_0 ; value implem_p = Grammar.Entry.of_parser Pcaml.gram "implem" implem_0 ; value top_phrase_p = Grammar.Entry.of_parser Pcaml.gram "top_phrase" top_phrase_0 ; value use_file_p = Grammar.Entry.of_parser Pcaml.gram "use_file" use_file_0 ; EXTEND interf: [ [ x = interf_p -> x ] ] ; implem: [ [ x = implem_p -> x ] ] ; top_phrase: [ [ x = top_phrase_p -> x ] ] ; use_file: [ [ x = use_file_p -> x ] ] ; END; mingw-ocaml/ocaml/camlp4/unmaintained/compile/.depend0000644000175000017500000000000012124403240022167 0ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/etc/0000755000175000017500000000000012124403240020064 5ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/etc/pa_ru.ml0000644000175000017500000000300612124403240021523 0ustar tootstoots(* camlp4r pa_extend.cmo q_MLast.cmo *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) open Pcaml; value o2b = fun [ Some _ -> True | None -> False ] ; EXTEND GLOBAL: expr; expr: LEVEL "top" [ [ "do"; "{"; seq = sequence; "}" -> match seq with [ [e] -> e | _ -> <:expr< do { $list:seq$ } >> ] ] ] ; sequence: [ [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; [ "in" | ";" ]; el = SELF -> let e = match el with [ [e] -> e | _ -> <:expr< do { $list:el$ } >> ] in [ <:expr< let $opt:o2b o$ $list:l$ in $e$ >> ] | e = expr; ";"; el = SELF -> let e = let _loc = MLast.loc_of_expr e in <:expr< ($e$ : unit) >> in [e :: el] | e = expr; ";" -> [e] | e = expr -> [e] ] ] ; END; mingw-ocaml/ocaml/camlp4/unmaintained/etc/q_phony.ml0000644000175000017500000000247712124403240022105 0ustar tootstoots(* camlp4r pa_extend.cmo q_MLast.cmo *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) open Pcaml; value t = ref ""; Quotation.add "" (Quotation.ExAst (fun c s -> let _loc = c.Quotation.loc in let t = if t.val = "" then "<<" ^ s ^ ">>" else "<:" ^ t.val ^ "<" ^ s ^ ">>" in <:expr< $uid:t$ >>, fun c s -> let _loc = c.Quotation.loc in let t = if t.val = "" then "<<" ^ s ^ ">>" else "<:" ^ t.val ^ "<" ^ s ^ ">>" in <:patt< $uid:t$ >>)) ; Quotation.default.val := ""; Quotation.translate.val := fun s -> do { t.val := s; "" }; mingw-ocaml/ocaml/camlp4/unmaintained/etc/.ignore0000644000175000017500000000006512124403240021351 0ustar tootstootscamlp4o camlp4sch camlp4o.opt version.sh mkcamlp4.sh mingw-ocaml/ocaml/camlp4/unmaintained/etc/pr_rp.ml0000644000175000017500000001574412124403240021553 0ustar tootstoots(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) open Pcaml; open Spretty; value _loc = (Token.nowhere, Token.nowhere); value expr e dg k = pr_expr.pr_fun "top" e dg k; value patt e dg k = pr_patt.pr_fun "top" e dg k; (* Streams *) value stream e dg k = let rec get = fun [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] | <:expr< Stream.ising $x$ >> -> [(True, x)] | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] | <:expr< Stream.sempty >> -> [] | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] | e -> [(False, e)] ] in let elem e k = match e with [ (True, e) -> [: `HOVbox [: `S LO "`"; `expr e "" k :] :] | (False, e) -> [: `expr e "" k :] ] in let rec glop e k = match e with [ [] -> k | [e] -> [: elem e k :] | [e :: el] -> [: elem e [: `S RO ";" :]; glop el k :] ] in HOVbox [: `S LR "[:"; glop (get e) [: `S LR ":]"; k :] :] ; (* Parsers *) value parser_cases b spel k = let rec parser_cases b spel k = match spel with [ [] -> [: `HVbox [: b; k :] :] | [(sp, epo, e)] -> [: `parser_case b sp epo e k :] | [(sp, epo, e) :: spel] -> [: `parser_case b sp epo e [: :]; parser_cases [: `S LR "|" :] spel k :] ] and parser_case b sp epo e k = let epo = match epo with [ Some p -> [: `patt p "" [: `S LR "->" :] :] | _ -> [: `S LR "->" :] ] in HVbox [: b; `HOVbox [: `HOVbox [: `S LR "[:"; stream_patt [: :] sp [: `S LR ":]"; epo :] :]; `expr e "" k :] :] and stream_patt b sp k = match sp with [ [] -> [: `HVbox [: b; k :] :] | [(spc, None)] -> [: `stream_patt_comp b spc k :] | [(spc, Some e)] -> [: `HVbox [: `stream_patt_comp b spc [: :]; `HVbox [: `S LR "?"; `expr e "" k :] :] :] | [(spc, None) :: spcl] -> [: `stream_patt_comp b spc [: `S RO ";" :]; stream_patt [: :] spcl k :] | [(spc, Some e) :: spcl] -> [: `HVbox [: `stream_patt_comp b spc [: :]; `HVbox [: `S LR "?"; `expr e "" [: `S RO ";" :] :] :]; stream_patt [: :] spcl k :] ] and stream_patt_comp b spc k = match spc with [ SPCterm (p, w) -> HVbox [: b; `S LO "`"; `patt p "" [: :]; `HVbox [: when_opt w k :] :] | SPCnterm p e -> HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e "" k :] :] | SPCsterm p -> HVbox [: b; `patt p "" k :] ] and when_opt wo k = match wo with [ Some e -> [: `S LR "when"; `expr e "" k :] | _ -> k ] in parser_cases b spel k ; value parser_body e dg k = let (bp, e) = match e with [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) | e -> (None, e) ] in match Parserify.parser_of_expr e with [ [] -> HVbox [: `HVbox [: `S LR "parser"; match bp with [ Some p -> [: `patt p "" [: :] :] | _ -> [: :] ] :]; `HVbox [: `S LR "[]"; k :] :] | [spe] -> HVbox [: `HVbox [: `S LR "parser"; match bp with [ Some p -> [: `patt p "" [: :] :] | _ -> [: :] ] :]; parser_cases [: :] [spe] k :] | spel -> Vbox [: `HVbox [: :]; `HVbox [: `S LR "parser"; match bp with [ Some p -> [: `patt p "" [: :] :] | _ -> [: :] ] :]; parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] ] ; value pmatch e dg k = let (me, e) = match e with [ <:expr< let (__strm : Stream.t _) = $me$ in $e$ >> -> (me, e) | <:expr< match $_$ __strm with [ $list:_$ ] >> -> (<:expr< __strm >>, e) | _ -> failwith "Pr_rp.pmatch" ] in let (bp, e) = match e with [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) | e -> (None, e) ] in let spel = Parserify.parser_of_expr e in Vbox [: `HVbox [: :]; `HVbox [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; match bp with [ Some p -> [: `patt p "" [: :] :] | _ -> [: :] ] :]; parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] ; (* Printer extensions *) pr_expr_fun_args.val := extfun pr_expr_fun_args.val with [ <:expr< fun __strm -> $_$ >> as ge -> ([], ge) | <:expr< fun [(__strm : $_$) -> $_$] >> as ge -> ([], ge) ]; let lev = find_pr_level "top" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< let (__strm : Stream.t _) = $_$ in $_$ >> as e -> fun curr next _ k -> [: `pmatch e "" k :] | <:expr< match $_$ __strm with [ $list:_$ ] >> as e -> fun curr next _ k -> [: `pmatch e "" k :] | <:expr< fun __strm -> $x$ >> -> fun curr next _ k -> [: `parser_body x "" k :] | <:expr< fun (__strm : $_$) -> $x$ >> -> fun curr next _ k -> [: `parser_body x "" k :] ]; let lev = find_pr_level "apply" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | <:expr< Stream.slazy $_$ >> as e -> fun curr next _ k -> [: `next e "" k :] ]; let lev = find_pr_level "dot" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Stream.sempty >> as e -> fun curr next _ k -> [: `next e "" k :] ]; let lev = find_pr_level "simple" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | <:expr< Stream.slazy $_$ >> as e -> fun curr next _ k -> [: `stream e "" k :] ]; mingw-ocaml/ocaml/camlp4/unmaintained/etc/pr_op.ml0000644000175000017500000001616412124403240021545 0ustar tootstoots(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) open Pcaml; open Spretty; value expr e dg k = pr_expr.pr_fun "top" e dg k; value patt e dg k = pr_patt.pr_fun "top" e dg k; value spatt p dg k = match p with [ <:patt< $lid:s$ >> -> if String.length s >= 2 && s.[1] == ''' then HVbox [: `S LR (" " ^ s); k :] else patt p dg k | _ -> patt p dg k ] ; (* Streams *) value stream e _ k = let rec get = fun [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] | <:expr< Stream.ising $x$ >> -> [(True, x)] | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] | <:expr< Stream.sempty >> -> [] | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] | e -> [(False, e)] ] in let elem e dg k = match e with [ (True, e) -> [: `HOVbox [: `S LO "'"; `expr e dg k :] :] | (False, e) -> [: `expr e dg k :] ] in let rec glop e k = match e with [ [] -> k | [e] -> [: elem e "" k :] | [e :: el] -> [: elem e ";" [: `S RO ";" :]; glop el k :] ] in HOVbox [: `S LR "[<"; glop (get e) [: `S LR ">]"; k :] :] ; (* Parsers *) value parser_cases b spel dg k = let rec parser_cases b spel dg k = match spel with [ [] -> [: `HVbox [: b; k :] :] | [(sp, epo, e)] -> [: `parser_case b sp epo e dg k :] | [(sp, epo, e) :: spel] -> [: `parser_case b sp epo e "|" [: :]; parser_cases [: `S LR "|" :] spel dg k :] ] and parser_case b sp epo e dg k = let epo = match epo with [ Some p -> [: `patt p "" [: `S LR "->" :] :] | _ -> [: `S LR "->" :] ] in HVbox [: b; `HOVbox [: `HOVbox [: `S LR "[<"; stream_patt [: :] sp [: `S LR ">]"; epo :] :]; `expr e dg k :] :] and stream_patt b sp k = match sp with [ [] -> [: `HVbox [: b; k :] :] | [(spc, None)] -> [: `stream_patt_comp b spc "" k :] | [(spc, Some e)] -> [: `HVbox [: `stream_patt_comp b spc "" [: :]; `HVbox [: `S LR "??"; `expr e "" k :] :] :] | [(spc, None) :: spcl] -> [: `stream_patt_comp b spc ";" [: `S RO ";" :]; stream_patt [: :] spcl k :] | [(spc, Some e) :: spcl] -> [: `HVbox [: `stream_patt_comp b spc "" [: :]; `HVbox [: `S LR "??"; `expr e ";" [: `S RO ";" :] :] :]; stream_patt [: :] spcl k :] ] and stream_patt_comp b spc dg k = match spc with [ SPCterm (p, w) -> HVbox [: b; `S LO "'"; `spatt p "" (when_opt w k) :] | SPCnterm p e -> HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e dg k :] :] | SPCsterm p -> HVbox [: b; `patt p "" k :] ] and when_opt wo k = match wo with [ Some e -> [: `S LR "when"; `expr e "" k :] | _ -> k ] in parser_cases b spel dg k ; value parser_body e dg k = let (bp, e) = match e with [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) | e -> (None, e) ] in match Parserify.parser_of_expr e with [ [] -> let spe = ([], None, <:expr< raise Stream.Failure >>) in HVbox [: `HVbox [: `S LR "parser"; match bp with [ Some p -> [: `patt p "" [: :] :] | _ -> [: :] ] :]; parser_cases [: :] [spe] dg k :] | spel -> BEVbox [: `HVbox [: `S LR "parser"; match bp with [ Some p -> [: `patt p "" [: :] :] | _ -> [: :] ] :]; parser_cases [: :] spel dg k :] ] ; value pmatch e dg k = let (me, e) = match e with [ <:expr< let (__strm : Stream.t _) = $me$ in $e$ >> -> (me, e) | _ -> failwith "Pr_op.pmatch" ] in let (bp, e) = match e with [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) | e -> (None, e) ] in let spel = Parser_of_expr.parser_of_expr e in Vbox [: `HVbox [: :]; `HVbox [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; match bp with [ Some p -> [: `patt p "" [: :] :] | _ -> [: :] ] :]; `BEbox [: `HVbox [: :]; parser_cases [: :] spel dg k :] :] ; (* Printer extensions *) pr_expr_fun_args.val := extfun pr_expr_fun_args.val with [ <:expr< fun __strm -> $_$ >> as ge -> ([], ge) | <:expr< fun [(__strm : $_$) -> $_$] >> as ge -> ([], ge) ]; let lev = find_pr_level "expr1" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< let (__strm : Stream.t _) = $_$ in $_$ >> as e -> fun curr next dg k -> if not (List.mem dg ["|"; ";"]) then [: `pmatch e dg k :] else [: `S LO "("; `pmatch e "" [: `S RO ")"; k :] :] | <:expr< fun __strm -> $x$ >> -> fun curr next dg k -> if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] | <:expr< fun [ (__strm : $_$) -> $x$ ] >> -> fun curr next dg k -> if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] ]; let lev = find_pr_level "apply" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | <:expr< Stream.slazy $_$ >> as e -> fun curr next dg k -> [: `next e "" k :] ]; let lev = find_pr_level "dot" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Stream.sempty >> as e -> fun curr next dg k -> [: `next e "" k :] ]; let lev = find_pr_level "simple" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | <:expr< Stream.slazy $_$ >> as e -> fun curr next dg k -> [: `stream e "" k :] ]; mingw-ocaml/ocaml/camlp4/unmaintained/etc/Makefile0000644000175000017500000000373112124403240021530 0ustar tootstoots include ../config/Makefile.cnf INCLUDES=-I ../camlp4 -I ../lib -I ../meta -I $(OTOP)/lex -I $(OTOP)/parsing OBJS=q_phony.cmo pa_o.cmo pa_op.cmo pa_oop.cmo pa_ru.cmo pa_extfun.cmo pa_fstream.cmo pa_ifdef.cmo pr_r.cmo pr_rp.cmo pr_o.cmo pr_op.cmo pr_extend.cmo pr_extfun.cmo pr_null.cmo pr_depend.cmo genTraversal.cmo fi_exc_tracer.cmo INTF=pa_o.cmi CAMLP4OM=pa_o.cmo pa_op.cmo ../meta/pr_dump.cmo CAMLP4OMX=$(CAMLP4OM:.cmo=.cmx) EXECUTABLES=camlp4o include ../config/Makefile.base all-local: mkcamlp4.sh pr_rp.cmo: parserify.cmo pr_rp_main.cmo $(OCAMLC) parserify.cmo pr_rp_main.cmo -a -o $@ pr_op.cmo: parserify.cmo pr_op_main.cmo $(OCAMLC) parserify.cmo pr_op_main.cmo -a -o $@ pr_rp.cmx: parserify.cmx pr_rp_main.cmx $(OCAMLOPT) parserify.cmx pr_rp_main.cmx -a -o pr_rp.cmxa mv pr_rp.cmxa pr_rp.cmx mv pr_rp.$(A) pr_rp.$(O) pr_op.cmx: parserify.cmx pr_op_main.cmx $(OCAMLOPT) parserify.cmx pr_op_main.cmx -a -o pr_op.cmxa mv pr_op.cmxa pr_op.cmx mv pr_op.$(A) pr_op.$(O) camlp4o$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4OM) rm -f camlp4o$(EXE) cd ../camlp4; $(MAKE) CAMLP4=../etc/camlp4o$(EXE) CAMLP4M="-I ../etc $(CAMLP4OM)" camlp4o.opt: $(CAMLP4OMX) rm -f camlp4o.opt cd ../camlp4; $(MAKE) ../etc/camlp4o.opt CAMLP4OPT=../etc/camlp4o.opt CAMLP4M="-I ../etc $(CAMLP4OMX)" mkcamlp4.sh: mkcamlp4.sh.tpl version.sh sed -e "s!LIBDIR!$(LIBDIR)!g" -e "/define VERSION/r version.sh" \ mkcamlp4.sh.tpl > mkcamlp4.sh version.sh : $(OTOP)/VERSION echo "VERSION=\"`sed -e 1q ../VERSION`\"" >version.sh install-local: -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" cp $(OBJS) "$(LIBDIR)/camlp4/." cp $(INTF) "$(LIBDIR)/camlp4/." cp camlp4o$(EXE) "$(BINDIR)/." if test -f camlp4o.opt; then \ cp camlp4o.opt "$(BINDIR)/camlp4o.opt$(EXE)"; \ cp $(OBJSX) "$(LIBDIR)/camlp4/."; \ for file in $(OBJSX); do \ cp "`echo $$file | sed -e 's/\.cmx$$/.$(O)/'`" "$(LIBDIR)/camlp4/."; \ done ; \ fi cp mkcamlp4.sh "$(BINDIR)/mkcamlp4" chmod a+x "$(BINDIR)/mkcamlp4" include .depend mingw-ocaml/ocaml/camlp4/unmaintained/etc/pr_rp_main.ml0000644000175000017500000001540612124403240022552 0ustar tootstoots(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) open Pcaml; open Spretty; value _loc = Loc.mk "FIXME pr_rp_main.ml"; value expr e dg k = pr_expr.pr_fun "top" e dg k; value patt e dg k = pr_patt.pr_fun "top" e dg k; (* Streams *) value stream e _ k = let rec get = fun [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] | <:expr< Stream.ising $x$ >> -> [(True, x)] | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] | <:expr< Stream.sempty >> -> [] | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] | e -> [(False, e)] ] in let elem e k = match e with [ (True, e) -> [: `HOVbox [: `S LO "`"; `expr e "" k :] :] | (False, e) -> [: `expr e "" k :] ] in let rec glop e k = match e with [ [] -> k | [e] -> [: elem e k :] | [e :: el] -> [: elem e [: `S RO ";" :]; glop el k :] ] in HOVbox [: `S LR "[:"; glop (get e) [: `S LR ":]"; k :] :] ; (* Parsers *) open Parserify; value parser_cases b spel k = let rec parser_cases b spel k = match spel with [ [] -> [: `HVbox [: b; k :] :] | [(sp, epo, e)] -> [: `parser_case b sp epo e k :] | [(sp, epo, e) :: spel] -> [: `parser_case b sp epo e [: :]; parser_cases [: `S LR "|" :] spel k :] ] and parser_case b sp epo e k = let epo = match epo with [ Some p -> [: `patt p "" [: `S LR "->" :] :] | _ -> [: `S LR "->" :] ] in HVbox [: b; `HOVbox [: `HOVbox [: `S LR "[:"; stream_patt [: :] sp [: `S LR ":]"; epo :] :]; `expr e "" k :] :] and stream_patt b sp k = match sp with [ [] -> [: `HVbox [: b; k :] :] | [(spc, None)] -> [: `stream_patt_comp b spc k :] | [(spc, Some e)] -> [: `HVbox [: `stream_patt_comp b spc [: :]; `HVbox [: `S LR "?"; `expr e "" k :] :] :] | [(spc, None) :: spcl] -> [: `stream_patt_comp b spc [: `S RO ";" :]; stream_patt [: :] spcl k :] | [(spc, Some e) :: spcl] -> [: `HVbox [: `stream_patt_comp b spc [: :]; `HVbox [: `S LR "?"; `expr e "" [: `S RO ";" :] :] :]; stream_patt [: :] spcl k :] ] and stream_patt_comp b spc k = match spc with [ SPCterm (p, w) -> HVbox [: b; `S LO "`"; `patt p "" [: :]; `HVbox [: when_opt w k :] :] | SPCnterm p e -> HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e "" k :] :] | SPCsterm p -> HVbox [: b; `patt p "" k :] ] and when_opt wo k = match wo with [ Some e -> [: `S LR "when"; `expr e "" k :] | _ -> k ] in parser_cases b spel k ; value parser_body e _ k = let (bp, e) = match e with [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) | e -> (None, e) ] in match parser_of_expr e with [ [] -> HVbox [: `HVbox [: `S LR "parser"; match bp with [ Some p -> [: `patt p "" [: :] :] | _ -> [: :] ] :]; `HVbox [: `S LR "[]"; k :] :] | [spe] -> HVbox [: `HVbox [: `S LR "parser"; match bp with [ Some p -> [: `patt p "" [: :] :] | _ -> [: :] ] :]; parser_cases [: :] [spe] k :] | spel -> Vbox [: `HVbox [: :]; `HVbox [: `S LR "parser"; match bp with [ Some p -> [: `patt p "" [: :] :] | _ -> [: :] ] :]; parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] ] ; value pmatch e _ k = let (me, e) = match e with [ <:expr< let (__strm : Stream.t _) = $me$ in $e$ >> -> (me, e) | _ -> failwith "Pr_rp.pmatch" ] in let (bp, e) = match e with [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) | e -> (None, e) ] in let spel = parser_of_expr e in Vbox [: `HVbox [: :]; `HVbox [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; match bp with [ Some p -> [: `patt p "" [: :] :] | _ -> [: :] ] :]; parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] ; (* Printer extensions *) pr_expr_fun_args.val := extfun pr_expr_fun_args.val with [ <:expr< fun __strm -> $_$ >> as ge -> ([], ge) | <:expr< fun [(__strm : $_$) -> $_$] >> as ge -> ([], ge) ]; let lev = find_pr_level "top" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< let (__strm : Stream.t _) = $_$ in $_$ >> as e -> fun _ _ _ k -> [: `pmatch e "" k :] | <:expr< fun __strm -> $x$ >> -> fun _ _ _ k -> [: `parser_body x "" k :] | <:expr< fun (__strm : $_$) -> $x$ >> -> fun _ _ _ k -> [: `parser_body x "" k :] ]; let lev = find_pr_level "apply" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | <:expr< Stream.slazy $_$ >> as e -> fun _ next _ k -> [: `next e "" k :] ]; let lev = find_pr_level "dot" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Stream.sempty >> as e -> fun _ next _ k -> [: `next e "" k :] ]; let lev = find_pr_level "simple" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | <:expr< Stream.slazy $_$ >> as e -> fun _ _ _ k -> [: `stream e "" k :] ]; mingw-ocaml/ocaml/camlp4/unmaintained/etc/pr_extend.ml0000644000175000017500000003355312124403240022417 0ustar tootstoots(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) open Pcaml; open Spretty; value no_slist = ref False; value expr e dg k = pr_expr.pr_fun "top" e dg k; value patt e dg k = pr_patt.pr_fun "top" e dg k; (* Utilities *) value rec list elem el k = match el with [ [] -> k | [x] -> [: `elem x k :] | [x :: l] -> [: `elem x [: :]; list elem l k :] ] ; value rec listws elem sep el k = match el with [ [] -> k | [x] -> [: `elem x k :] | [x :: l] -> [: `elem x [: `sep :]; listws elem sep l k :] ] ; value rec listwbws elem b sep el dg k = match el with [ [] -> [: b; k :] | [x] -> [: `elem b x dg k :] | [x :: l] -> let sdg = match sep with [ S _ x -> x | _ -> "" ] in [: `elem b x sdg [: :]; listwbws elem [: `sep :] sep l dg k :] ] ; (* Extracting *) value rec get_globals = fun [ [(<:patt< _ >>, <:expr< ($e$ : $uid:gmod1$.Entry.e '$_$) >>) :: pel] -> let (gmod, gl) = get_globals pel in if gmod = "" || gmod = gmod1 then (gmod1, [e :: gl]) else raise Not_found | [] -> ("", []) | _ -> raise Not_found ] ; value rec get_locals = fun [ [(<:patt< $_$ >>, <:expr< (grammar_entry_create $_$ : $_$) >>) :: pel] -> get_locals pel | [] -> () | _ -> raise Not_found ] ; value unposition = fun [ <:expr< None >> -> None | <:expr< Some Gramext.First >> -> Some Gramext.First | <:expr< Some Gramext.Last >> -> Some Gramext.Last | <:expr< Some (Gramext.Before $str:s$) >> -> Some (Gramext.Before s) | <:expr< Some (Gramext.After $str:s$) >> -> Some (Gramext.After s) | <:expr< Some (Gramext.Level $str:s$) >> -> Some (Gramext.Level s) | _ -> raise Not_found ] ; value unlabel = fun [ <:expr< None >> -> None | <:expr< Some $str:s$ >> -> Some s | _ -> raise Not_found ] ; value unassoc = fun [ <:expr< None >> -> None | <:expr< Some Gramext.NonA >> -> Some Gramext.NonA | <:expr< Some Gramext.LeftA >> -> Some Gramext.LeftA | <:expr< Some Gramext.RightA >> -> Some Gramext.RightA | _ -> raise Not_found ] ; value rec unaction = fun [ <:expr< fun ($lid:locp$ : Loc.t) -> ($a$ : $_$) >> when locp = Stdpp.loc_name.val -> let ao = match a with [ <:expr< () >> -> None | _ -> Some a ] in ([], ao) | <:expr< fun ($p$ : $_$) -> $e$ >> -> let (pl, a) = unaction e in ([p :: pl], a) | <:expr@_loc< fun _ -> $e$ >> -> let (pl, a) = unaction e in ([ <:patt< _ >> :: pl ], a) | _ -> raise Not_found ] ; value untoken = fun [ <:expr< ($str:x$, $str:y$) >> -> (x, y) | _ -> raise Not_found ] ; type symbol = [ Snterm of MLast.expr | Snterml of MLast.expr and string | Slist0 of symbol | Slist0sep of symbol and symbol | Slist1 of symbol | Slist1sep of symbol and symbol | Sopt of symbol | Sself | Snext | Stoken of Token.pattern | Srules of list (list (option MLast.patt * symbol) * option MLast.expr) ] ; value rec unsymbol = fun [ <:expr< Gramext.Snterm ($uid:_$.Entry.obj ($e$ : $_$)) >> -> Snterm e | <:expr< Gramext.Snterml ($uid:_$.Entry.obj ($e$ : $_$)) $str:s$ >> -> Snterml e s | <:expr< Gramext.Snterml ($uid:_$.Entry.obj ($e$ : $_$), $str:s$) >> -> Snterml e s | <:expr< Gramext.Slist0 $e$ >> -> Slist0 (unsymbol e) | <:expr< Gramext.Slist0sep $e1$ $e2$ >> -> Slist0sep (unsymbol e1) (unsymbol e2) | <:expr< Gramext.Slist0sep ($e1$, $e2$) >> -> Slist0sep (unsymbol e1) (unsymbol e2) | <:expr< Gramext.Slist1 $e$ >> -> Slist1 (unsymbol e) | <:expr< Gramext.Slist1sep $e1$ $e2$ >> -> Slist1sep (unsymbol e1) (unsymbol e2) | <:expr< Gramext.Slist1sep ($e1$, $e2$) >> -> Slist1sep (unsymbol e1) (unsymbol e2) | <:expr< Gramext.Sopt $e$ >> -> Sopt (unsymbol e) | <:expr< Gramext.Sself >> -> Sself | <:expr< Gramext.Snext >> -> Snext | <:expr< Gramext.Stoken $e$ >> -> Stoken (untoken e) | <:expr< Gramext.srules $e$ >> -> Srules (unrule_list [] e) | _ -> raise Not_found ] and unpsymbol_list pl e = match (pl, e) with [ ([], <:expr< [] >>) -> [] | ([p :: pl], <:expr< [$e$ :: $el$] >>) -> let op = match p with [ <:patt< _ >> -> None | _ -> Some p ] in [(op, unsymbol e) :: unpsymbol_list pl el] | _ -> raise Not_found ] and unrule = fun [ <:expr@_loc< ($e1$, Gramext.action $e2$) >> -> let (pl, a) = match unaction e2 with [ ([], None) -> ([], Some <:expr< () >>) | x -> x ] in let sl = unpsymbol_list (List.rev pl) e1 in (sl, a) | _ -> raise Not_found ] and unrule_list rl = fun [ <:expr< [$e$ :: $el$] >> -> unrule_list [unrule e :: rl] el | <:expr< [] >> -> rl | _ -> raise Not_found ] ; value unlevel = fun [ <:expr< ($e1$, $e2$, $e3$) >> -> (unlabel e1, unassoc e2, unrule_list [] e3) | _ -> raise Not_found ] ; value rec unlevel_list = fun [ <:expr< [$e$ :: $el$] >> -> [unlevel e :: unlevel_list el] | <:expr< [] >> -> [] | _ -> raise Not_found ] ; value unentry = fun [ <:expr< (Grammar.Entry.obj ($e$ : Grammar.Entry.e '$_$), $pos$, $ll$) >> -> (e, unposition pos, unlevel_list ll) | _ -> raise Not_found ] ; value rec unentry_list = fun [ <:expr< [$e$ :: $el$] >> -> [unentry e :: unentry_list el] | <:expr< [] >> -> [] | _ -> raise Not_found ] ; value unextend_body e = let ((_, globals), e) = match e with [ <:expr< let $list:pel$ in $e1$ >> -> try (get_globals pel, e1) with [ Not_found -> (("", []), e) ] | _ -> (("", []), e) ] in let e = match e with [ <:expr< let grammar_entry_create s = Grammar.Entry.create (Grammar.of_entry $_$) s in $e$ >> -> let e = match e with [ <:expr< let $list:pel$ in $e1$ >> -> try let _ = get_locals pel in e1 with [ Not_found -> e ] | _ -> e ] in e | _ -> e ] in let el = unentry_list e in (globals, el) ; value ungextend_body e = let e = match e with [ <:expr< let grammar_entry_create = Gram.Entry.create in let $list:ll$ in $e$ >> -> let _ = get_locals ll in e | _ -> e ] in match e with [ <:expr< do { $list:el$ } >> -> List.map (fun [ <:expr< $uid:_$.extend ($e$ : $uid:_$.Entry.e '$_$) $pos$ $ll$ >> -> (e, unposition pos, unlevel_list ll) | _ -> raise Not_found ]) el | _ -> raise Not_found ] ; (* Printing *) value ident s k = HVbox [: `S LR s; k :]; value string s k = HVbox [: `S LR ("\"" ^ s ^ "\""); k :]; value position = fun [ None -> [: :] | Some Gramext.First -> [: `S LR "FIRST" :] | Some Gramext.Last -> [: `S LR "LAST" :] | Some (Gramext.Before s) -> [: `S LR "BEFORE"; `string s [: :] :] | Some (Gramext.After s) -> [: `S LR "AFTER"; `string s [: :] :] | Some (Gramext.Level s) -> [: `S LR "LEVEL"; `string s [: :] :] ] ; value action expr a dg k = expr a dg k ; value token (con, prm) k = if con = "" then string prm k else if prm = "" then HVbox [: `S LR con; k :] else HVbox [: `S LR con; `string prm k :] ; value simplify_rules rl = try List.map (fun [ ([(Some <:patt< $lid:x$ >>, s)], Some <:expr< $lid:y$ >>) -> if x = y then ([(None, s)], None) else raise Exit | ([], _) as r -> r | _ -> raise Exit ]) rl with [ Exit -> rl ] ; value rec symbol s k = match s with [ Snterm e -> expr e "" k | Snterml e s -> HVbox [: `expr e "" [: :]; `S LR "LEVEL"; `string s k :] | Slist0 s -> HVbox [: `S LR "LIST0"; `symbol s k :] | Slist0sep s sep -> HVbox [: `S LR "LIST0"; `symbol s [: :]; `S LR "SEP"; `symbol sep k :] | Slist1 s -> HVbox [: `S LR "LIST1"; `symbol s k :] | Slist1sep s sep -> HVbox [: `S LR "LIST1"; `symbol s [: :]; `S LR "SEP"; `symbol sep k :] | Sopt s -> HVbox [: `S LR "OPT"; `symbol s k :] | Sself -> HVbox [: `S LR "SELF"; k :] | Snext -> HVbox [: `S LR "NEXT"; k :] | Stoken tok -> token tok k | Srules [([(Some <:patt< a >>, Snterm <:expr< a_list >>)], Some <:expr< a >>); ([(Some <:patt< a >>, ((Slist0 _ | Slist1 _ | Slist0sep _ _ | Slist1sep _ _) as s))], Some <:expr< Qast.List a >>)] when not no_slist.val -> match s with [ Slist0 s -> HVbox [: `S LR "SLIST0"; `simple_symbol s k :] | Slist1 s -> HVbox [: `S LR "SLIST1"; `simple_symbol s k :] | Slist0sep s sep -> HVbox [: `S LR "SLIST0"; `simple_symbol s [: :]; `S LR "SEP"; `symbol sep k :] | Slist1sep s sep -> HVbox [: `S LR "SLIST1"; `simple_symbol s [: :]; `S LR "SEP"; `simple_symbol sep k :] | _ -> assert False ] | Srules [([(Some <:patt< a >>, Snterm <:expr< a_opt >>)], Some <:expr< a >>); ([(Some <:patt< a >>, Sopt s)], Some <:expr< Qast.Option a >>)] when not no_slist.val -> let s = match s with [ Srules [([(Some <:patt< x >>, Stoken ("", str))], Some <:expr< Qast.Str x >>)] -> Stoken ("", str) | s -> s ] in HVbox [: `S LR "SOPT"; `simple_symbol s k :] | Srules rl -> let rl = simplify_rules rl in HVbox [: `HVbox [: :]; rule_list rl k :] ] and simple_symbol s k = match s with [ Snterml _ _ -> HVbox [: `S LO "("; `symbol s [: `S RO ")"; k :] :] | s -> symbol s k ] and psymbol (p, s) k = match p with [ None -> symbol s k | Some p -> HVbox [: `patt p "" [: `S LR "=" :]; `symbol s k :] ] and psymbol_list sl k = listws psymbol (S RO ";") sl k and rule b (sl, a) dg k = match a with [ None -> HVbox [: b; `HOVbox [: psymbol_list sl k :] :] | Some a -> HVbox [: b; `HOVbox [: `HOVbox [: `HVbox [: :]; psymbol_list sl [: `S LR "->" :] :]; `action expr a dg k :] :] ] and rule_list ll k = listwbws rule [: `S LR "[" :] (S LR "|") ll "" [: `S LR "]"; k :] ; value label = fun [ Some s -> [: `S LR ("\"" ^ s ^ "\"") :] | None -> [: :] ] ; value intloc loc = ((Loc.start_off loc), (Loc.stop_off loc)); value intloc2 (bp, ep) = (bp.Lexing.pos_cnum, ep.Lexing.pos_cnum); value assoc = fun [ Some Gramext.NonA -> [: `S LR "NONA" :] | Some Gramext.LeftA -> [: `S LR "LEFTA" :] | Some Gramext.RightA -> [: `S LR "RIGHTA" :] | None -> [: :] ] ; value level b (lab, ass, rl) _ k = let s = if rl = [] then [: `S LR "[ ]"; k :] else [: `Vbox [: `HVbox [: :]; rule_list rl k :] :] in match (lab, ass) with [ (None, None) -> HVbox [: b; s :] | _ -> Vbox [: `HVbox [: b; label lab; assoc ass :]; `HVbox [: `HVbox [: :]; s :] :] ] ; value level_list ll k = Vbox [: `HVbox [: :]; listwbws level [: `S LR "[" :] (S LR "|") ll "" [: `S LR "]"; k :] :] ; value entry (e, pos, ll) k = BEbox [: `LocInfo (intloc(MLast.loc_of_expr e)) (HVbox [: `expr e "" [: `S RO ":" :]; position pos :]); `level_list ll [: :]; `HVbox [: `S RO ";"; k :] :] ; value entry_list el k = Vbox [: `HVbox [: :]; list entry el k :] ; value extend_body (globals, e) k = let s = entry_list e k in match globals with [ [] -> s | sl -> HVbox [: `HVbox [: :]; `HOVbox [: `S LR "GLOBAL"; `S RO ":"; list (fun e k -> HVbox [: `expr e "" k :]) sl [: `S RO ";" :] :]; `s :] ] ; value extend e _ k = match e with [ <:expr< Grammar.extend $e$ >> -> try let ex = unextend_body e in BEbox [: `S LR "EXTEND"; `extend_body ex [: :]; `HVbox [: `S LR "END"; k :] :] with [ Not_found -> HVbox [: `S LR "Grammar.extend"; `HOVbox [: `S LO "("; `expr e "" [: `HVbox [: `S RO ")"; k :] :] :] :] ] | _ -> expr e "" k ] ; value get_gextend = fun [ <:expr< let $list:gl$ in $e$ >> -> try let (gmod, gl) = get_globals gl in let el = ungextend_body e in Some (gmod, gl, el) with [ Not_found -> None ] | _ -> None ] ; value gextend e _ k = match get_gextend e with [ Some (gmod, gl, el) -> BEbox [: `HVbox [: `S LR "GEXTEND"; `S LR gmod :]; `extend_body (gl, el) [: :]; `HVbox [: `S LR "END"; k :] :] | None -> expr e "" k ] ; value is_gextend e = get_gextend e <> None; (* Printer extensions *) let lev = try find_pr_level "expr1" pr_expr.pr_levels with [ Failure _ -> find_pr_level "top" pr_expr.pr_levels ] in lev.pr_rules := extfun lev.pr_rules with [ <:expr< let $list:_$ in $_$ >> as e when is_gextend e -> fun _ next _ k -> [: `next e "" k :] ]; let lev = find_pr_level "apply" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Grammar.extend $_$ >> as e -> fun _ next _ k -> [: `next e "" k :] ]; let lev = find_pr_level "simple" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Grammar.extend $_$ >> as e -> fun _ _ _ k -> [: `extend e "" k :] | <:expr< let $list:_$ in $_$ >> as e when is_gextend e -> fun _ _ _ k -> [: `gextend e "" k :] ]; Pcaml.add_option "-no_slist" (Arg.Set no_slist) "Don't reconstruct SLIST and SOPT"; mingw-ocaml/ocaml/camlp4/unmaintained/etc/pr_op_main.ml0000644000175000017500000001616712124403240022554 0ustar tootstoots(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) open Pcaml; open Spretty; value _loc = Loc.mk "FIXME pr_op_main.ml"; value expr e dg k = pr_expr.pr_fun "top" e dg k; value patt e dg k = pr_patt.pr_fun "top" e dg k; value spatt p dg k = match p with [ <:patt< $lid:s$ >> -> if String.length s >= 2 && s.[1] == ''' then HVbox [: `S LR (" " ^ s); k :] else patt p dg k | _ -> patt p dg k ] ; (* Streams *) value stream e _ k = let rec get = fun [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] | <:expr< Stream.ising $x$ >> -> [(True, x)] | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] | <:expr< Stream.sempty >> -> [] | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] | e -> [(False, e)] ] in let elem e dg k = match e with [ (True, e) -> [: `HOVbox [: `S LO "'"; `expr e dg k :] :] | (False, e) -> [: `expr e dg k :] ] in let rec glop e k = match e with [ [] -> k | [e] -> [: elem e "" k :] | [e :: el] -> [: elem e ";" [: `S RO ";" :]; glop el k :] ] in HOVbox [: `S LR "[<"; glop (get e) [: `S LR ">]"; k :] :] ; (* Parsers *) open Parserify; value parser_cases b spel dg k = let rec parser_cases b spel dg k = match spel with [ [] -> [: `HVbox [: b; k :] :] | [(sp, epo, e)] -> [: `parser_case b sp epo e dg k :] | [(sp, epo, e) :: spel] -> [: `parser_case b sp epo e "|" [: :]; parser_cases [: `S LR "|" :] spel dg k :] ] and parser_case b sp epo e dg k = let epo = match epo with [ Some p -> [: `patt p "" [: `S LR "->" :] :] | _ -> [: `S LR "->" :] ] in HVbox [: b; `HOVbox [: `HOVbox [: `S LR "[<"; stream_patt [: :] sp [: `S LR ">]"; epo :] :]; `expr e dg k :] :] and stream_patt b sp k = match sp with [ [] -> [: `HVbox [: b; k :] :] | [(spc, None)] -> [: `stream_patt_comp b spc "" k :] | [(spc, Some e)] -> [: `HVbox [: `stream_patt_comp b spc "" [: :]; `HVbox [: `S LR "??"; `expr e "" k :] :] :] | [(spc, None) :: spcl] -> [: `stream_patt_comp b spc ";" [: `S RO ";" :]; stream_patt [: :] spcl k :] | [(spc, Some e) :: spcl] -> [: `HVbox [: `stream_patt_comp b spc "" [: :]; `HVbox [: `S LR "??"; `expr e ";" [: `S RO ";" :] :] :]; stream_patt [: :] spcl k :] ] and stream_patt_comp b spc dg k = match spc with [ SPCterm (p, w) -> HVbox [: b; `S LO "'"; `spatt p "" (when_opt w k) :] | SPCnterm p e -> HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e dg k :] :] | SPCsterm p -> HVbox [: b; `patt p "" k :] ] and when_opt wo k = match wo with [ Some e -> [: `S LR "when"; `expr e "" k :] | _ -> k ] in parser_cases b spel dg k ; value parser_body e dg k = let (bp, e) = match e with [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) | e -> (None, e) ] in match parser_of_expr e with [ [] -> let spe = ([], None, <:expr< raise Stream.Failure >>) in HVbox [: `HVbox [: `S LR "parser"; match bp with [ Some p -> [: `patt p "" [: :] :] | _ -> [: :] ] :]; parser_cases [: :] [spe] dg k :] | spel -> BEVbox [: `HVbox [: `S LR "parser"; match bp with [ Some p -> [: `patt p "" [: :] :] | _ -> [: :] ] :]; parser_cases [: :] spel dg k :] ] ; value pmatch e dg k = let (me, e) = match e with [ <:expr< let (__strm : Stream.t _) = $me$ in $e$ >> -> (me, e) | _ -> failwith "Pr_op.pmatch" ] in let (bp, e) = match e with [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) | e -> (None, e) ] in let spel = parser_of_expr e in Vbox [: `HVbox [: :]; `HVbox [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; match bp with [ Some p -> [: `patt p "" [: :] :] | _ -> [: :] ] :]; `BEbox [: `HVbox [: :]; parser_cases [: :] spel dg k :] :] ; (* Printer extensions *) pr_expr_fun_args.val := extfun pr_expr_fun_args.val with [ <:expr< fun __strm -> $_$ >> as ge -> ([], ge) | <:expr< fun [(__strm : $_$) -> $_$] >> as ge -> ([], ge) ]; let lev = find_pr_level "expr1" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< let (__strm : Stream.t _) = $_$ in $_$ >> as e -> fun _ _ dg k -> if not (List.mem dg ["|"; ";"]) then [: `pmatch e dg k :] else [: `S LO "("; `pmatch e "" [: `S RO ")"; k :] :] | <:expr< fun __strm -> $x$ >> -> fun _ _ dg k -> if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] | <:expr< fun [ (__strm : $_$) -> $x$ ] >> -> fun _ _ dg k -> if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] ]; let lev = find_pr_level "apply" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | <:expr< Stream.slazy $_$ >> as e -> fun _ next _ k -> [: `next e "" k :] ]; let lev = find_pr_level "dot" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Stream.sempty >> as e -> fun _ next _ k -> [: `next e "" k :] ]; let lev = find_pr_level "simple" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | <:expr< Stream.slazy $_$ >> as e -> fun _ _ _ k -> [: `stream e "" k :] ]; mingw-ocaml/ocaml/camlp4/unmaintained/etc/pa_oop.ml0000644000175000017500000001112612124403240021674 0ustar tootstoots(* camlp4r pa_extend.cmo q_MLast.cmo *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) open Pcaml; type spat_comp = [ SpTrm of Loc.t and MLast.patt and option MLast.expr | SpNtr of Loc.t and MLast.patt and MLast.expr | SpStr of Loc.t and MLast.patt ] ; type sexp_comp = [ SeTrm of Loc.t and MLast.expr | SeNtr of Loc.t and MLast.expr ] ; value strm_n = "__strm"; value peek_fun _loc = <:expr< Stream.peek >>; value junk_fun _loc = <:expr< Stream.junk >>; (* Parsers. *) value stream_pattern_component skont = fun [ SpTrm _loc p wo -> (<:expr< $peek_fun _loc$ $lid:strm_n$ >>, p, wo, <:expr< do { $junk_fun _loc$ $lid:strm_n$; $skont$ } >>) | SpNtr _loc p e -> (<:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>, p, None, skont) | SpStr _loc p -> (<:expr< Some $lid:strm_n$ >>, p, None, skont) ] ; value rec stream_pattern _loc epo e ekont = fun [ [] -> match epo with [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >> | _ -> e ] | [(spc, err) :: spcl] -> let skont = let ekont err = let str = match err with [ Some estr -> estr | _ -> <:expr< "" >> ] in <:expr< raise (Stream.Error $str$) >> in stream_pattern _loc epo e ekont spcl in let (tst, p, wo, e) = stream_pattern_component skont spc in let ckont = ekont err in <:expr< match $tst$ with [ Some $p$ $when:wo$ -> $e$ | _ -> $ckont$ ] >> ] ; value rec parser_cases _loc = fun [ [] -> <:expr< raise Stream.Failure >> | [(spcl, epo, e) :: spel] -> stream_pattern _loc epo e (fun _ -> parser_cases _loc spel) spcl ] ; value cparser _loc bpo pc = let e = parser_cases _loc pc in let e = match bpo with [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >> | None -> e ] in let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in <:expr< fun $p$ -> $e$ >> ; value cparser_match _loc me bpo pc = let pc = parser_cases _loc pc in let e = match bpo with [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> | None -> pc ] in <:expr< let $lid:strm_n$ = $me$ in $e$ >> ; (* streams *) value slazy _loc e = <:expr< fun _ -> $e$ >>; value rec cstream gloc = fun [ [] -> let _loc = gloc in <:expr< Stream.sempty >> | [SeTrm _loc e :: secl] -> <:expr< Stream.lcons $slazy _loc e$ $cstream gloc secl$ >> | [SeNtr _loc e :: secl] -> <:expr< Stream.lapp $slazy _loc e$ $cstream gloc secl$ >> ] ; (* Syntax extensions in OCaml grammar *) EXTEND GLOBAL: expr; expr: LEVEL "expr1" [ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" -> <:expr< $cparser _loc po pcl$ >> | "match"; e = expr; "with"; "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" -> <:expr< $cparser_match _loc e po pcl$ >> ] ] ; parser_case: [ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr -> (sp, po, e) ] ] ; stream_patt: [ [ spc = stream_patt_comp -> [(spc, None)] | spc = stream_patt_comp; ";"; sp = LIST1 stream_patt_comp_err SEP ";" -> [(spc, None) :: sp] | (* empty *) -> [] ] ] ; stream_patt_comp_err: [ [ spc = stream_patt_comp; eo = OPT [ "??"; e = expr LEVEL "expr1" -> e ] -> (spc, eo) ] ] ; stream_patt_comp: [ [ "'"; p = patt; eo = OPT [ "when"; e = (expr LEVEL "expr1") -> e ] -> SpTrm _loc p eo | p = patt; "="; e = (expr LEVEL "expr1") -> SpNtr _loc p e | p = patt -> SpStr _loc p ] ] ; ipatt: [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ] ; expr: LEVEL "simple" [ [ "[<"; se = LIST0 stream_expr_comp SEP ";"; ">]" -> <:expr< $cstream _loc se$ >> ] ] ; stream_expr_comp: [ [ "'"; e = expr LEVEL "expr1" -> SeTrm _loc e | e = expr LEVEL "expr1" -> SeNtr _loc e ] ] ; END; mingw-ocaml/ocaml/camlp4/unmaintained/etc/parserify.mli0000644000175000017500000000041012124403240022566 0ustar tootstoots(* camlp4r *) type spc = [ SPCterm of (MLast.patt * option MLast.expr) | SPCnterm of MLast.patt and MLast.expr | SPCsterm of MLast.patt ] ; value parser_of_expr : MLast.expr -> list (list (spc * option MLast.expr) * option MLast.patt * MLast.expr); mingw-ocaml/ocaml/camlp4/unmaintained/etc/pr_depend.ml0000644000175000017500000002260412124403240022362 0ustar tootstoots(* camlp4r *) open MLast; value not_impl name x = Format.eprintf "pr_depend: not impl: %s; %a@." name ObjTools.print (Obj.repr x) ; module StrSet = Set.Make (struct type t = string; value compare = compare; end) ; value fset = ref StrSet.empty; value addmodule s = fset.val := StrSet.add s fset.val; value list = List.iter; value option f = fun [ Some x -> f x | None -> () ] ; value longident = fun [ [s; _ :: _] -> addmodule s | _ -> () ] ; value rec ctyp = fun [ TyAcc _ t _ -> ctyp_module t | TyAli _ t1 t2 -> do { ctyp t1; ctyp t2; } | TyApp _ t1 t2 -> do { ctyp t1; ctyp t2; } | TyAny _ -> () | TyArr _ t1 t2 -> do { ctyp t1; ctyp t2; } | TyCls _ li -> longident li | TyLab _ _ t -> ctyp t | TyLid _ _ -> () | TyMan _ t1 t2 -> do { ctyp t1; ctyp t2; } | TyOlb _ _ t -> ctyp t | TyQuo _ _ -> () | TyRec _ ldl -> list label_decl ldl | TySum _ cdl -> list constr_decl cdl | TyPrv _ t -> ctyp t | TyTup _ tl -> list ctyp tl | TyVrn _ sbtll _ -> list variant sbtll | x -> not_impl "ctyp" x ] and constr_decl (_, _, tl) = list ctyp tl and label_decl (_, _, _, t) = ctyp t and variant = fun [ RfTag _ _ tl -> list ctyp tl | RfInh t -> ctyp t ] and ctyp_module = fun [ TyAcc _ t _ -> ctyp_module t | TyApp _ t1 t2 -> do { ctyp t1; ctyp t2; } | TyUid _ m -> addmodule m | x -> not_impl "ctyp_module" x ] ; value rec patt = fun [ PaAcc _ p _ -> patt_module p | PaAli _ p1 p2 -> do { patt p1; patt p2; } | PaAny _ -> () | PaApp _ p1 p2 -> do { patt p1; patt p2; } | PaArr _ pl -> list patt pl | PaChr _ _ -> () | PaInt _ _ -> () | PaLab _ _ po -> option patt po | PaLid _ _ -> () | PaOlb _ _ peoo -> option (fun (p, eo) -> do { patt p; option expr eo }) peoo | PaOrp _ p1 p2 -> do { patt p1; patt p2; } | PaRec _ lpl -> list label_patt lpl | PaRng _ p1 p2 -> do { patt p1; patt p2; } | PaStr _ _ -> () | PaTup _ pl -> list patt pl | PaTyc _ p t -> do { patt p; ctyp t; } | PaUid _ _ -> () | PaVrn _ _ -> () | x -> not_impl "patt" x ] and patt_module = fun [ PaUid _ m -> addmodule m | PaAcc _ p _ -> patt_module p | x -> not_impl "patt_module" x ] and label_patt (p1, p2) = do { patt p1; patt p2; } and expr = fun [ ExAcc _ e1 e2 -> do { expr_module e1; expr e2; } | ExApp _ e1 e2 -> do { expr e1; expr e2; } | ExAre _ e1 e2 -> do { expr e1; expr e2; } | ExArr _ el -> list expr el | ExAsf _ -> () | ExAsr _ e -> do { expr e; } | ExAss _ e1 e2 -> do { expr e1; expr e2; } | ExChr _ _ -> () | ExCoe _ e t1 t2 -> do { expr e; option ctyp t1; ctyp t2 } | ExFor _ _ e1 e2 _ el -> do { expr e1; expr e2; list expr el; } | ExFun _ pwel -> list match_case pwel | ExIfe _ e1 e2 e3 -> do { expr e1; expr e2; expr e3; } | ExInt _ _ -> () | ExInt32 _ _ -> () | ExInt64 _ _ -> () | ExNativeInt _ _ -> () | ExFlo _ _ -> () | ExLab _ _ eo -> option expr eo | ExLaz _ e -> expr e | ExLet _ _ pel e -> do { list let_binding pel; expr e; } | ExLid _ _ -> () | ExLmd _ _ me e -> do { module_expr me; expr e; } | ExMat _ e pwel -> do { expr e; list match_case pwel; } | ExNew _ li -> longident li | ExOlb _ _ eo -> option expr eo | ExRec _ lel w -> do { list label_expr lel; option expr w; } | ExSeq _ el -> list expr el | ExSnd _ e _ -> expr e | ExSte _ e1 e2 -> do { expr e1; expr e2; } | ExStr _ _ -> () | ExTry _ e pwel -> do { expr e; list match_case pwel; } | ExTup _ el -> list expr el | ExTyc _ e t -> do { expr e; ctyp t; } | ExUid _ _ -> () | ExVrn _ _ -> () | ExWhi _ e el -> do { expr e; list expr el; } | x -> not_impl "expr" x ] and expr_module = fun [ ExUid _ m -> addmodule m | e -> expr e ] and let_binding (p, e) = do { patt p; expr e } and label_expr (p, e) = do { patt p; expr e } and match_case (p, w, e) = do { patt p; option expr w; expr e; } and module_type = fun [ MtAcc _ (MtUid _ m) _ -> addmodule m | MtFun _ _ mt1 mt2 -> do { module_type mt1; module_type mt2; } | MtSig _ sil -> list sig_item sil | MtUid _ _ -> () | MtWit _ mt wc -> do { module_type mt; list with_constr wc; } | x -> not_impl "module_type" x ] and with_constr = fun [ WcTyp _ _ _ t -> ctyp t | x -> not_impl "with_constr" x ] and sig_item = fun [ SgDcl _ sil -> list sig_item sil | SgExc _ _ tl -> list ctyp tl | SgExt _ _ t _ -> ctyp t | SgMod _ _ mt -> module_type mt | SgRecMod _ mts -> list (fun (_, mt) -> module_type mt) mts | SgMty _ _ mt -> module_type mt | SgOpn _ [s :: _] -> addmodule s | SgTyp _ tdl -> list type_decl tdl | SgVal _ _ t -> ctyp t | x -> not_impl "sig_item" x ] and module_expr = fun [ MeAcc _ (MeUid _ m) _ -> addmodule m | MeApp _ me1 me2 -> do { module_expr me1; module_expr me2; } | MeFun _ _ mt me -> do { module_type mt; module_expr me; } | MeStr _ sil -> list str_item sil | MeTyc _ me mt -> do { module_expr me; module_type mt; } | MeUid _ _ -> () | x -> not_impl "module_expr" x ] and str_item = fun [ StCls _ cil -> list (fun ci -> class_expr ci.ciExp) cil | StDcl _ sil -> list str_item sil | StDir _ _ _ -> () | StExc _ _ tl _ -> list ctyp tl | StExp _ e -> expr e | StExt _ _ t _ -> ctyp t | StMod _ _ me -> module_expr me | StRecMod _ nmtmes -> list (fun (_, mt, me) -> do { module_expr me; module_type mt; }) nmtmes | StMty _ _ mt -> module_type mt | StOpn _ [s :: _] -> addmodule s | StTyp _ tdl -> list type_decl tdl | StVal _ _ pel -> list let_binding pel | x -> not_impl "str_item" x ] and type_decl (_, _, t, _) = ctyp t and class_expr = fun [ CeApp _ ce e -> do { class_expr ce; expr e; } | CeCon _ li tl -> do { longident li; list ctyp tl; } | CeFun _ p ce -> do { patt p; class_expr ce; } | CeLet _ _ pel ce -> do { list let_binding pel; class_expr ce; } | CeStr _ po csil -> do { option patt po; list class_str_item csil; } | x -> not_impl "class_expr" x ] and class_str_item = fun [ CrInh _ ce _ -> class_expr ce | CrIni _ e -> expr e | CrMth _ _ _ e None -> expr e | CrMth _ _ _ e (Some t) -> do { expr e; ctyp t } | CrVal _ _ _ e -> expr e | CrVir _ _ _ t -> ctyp t | x -> not_impl "class_str_item" x ] ; (* Print dependencies *) value load_path = ref [""]; value find_in_path path name = if not (Filename.is_implicit name) then if Sys.file_exists name then name else raise Not_found else let rec try_dir = fun [ [] -> raise Not_found | [dir :: rem] -> let fullname = Filename.concat dir name in if Sys.file_exists fullname then fullname else try_dir rem ] in try_dir path ; value find_depend modname (byt_deps, opt_deps) = let name = String.uncapitalize modname in try let filename = find_in_path load_path.val (name ^ ".mli") in let basename = Filename.chop_suffix filename ".mli" in let byt_dep = basename ^ ".cmi" in let opt_dep = if Sys.file_exists (basename ^ ".ml") then basename ^ ".cmx" else basename ^ ".cmi" in ([byt_dep :: byt_deps], [opt_dep :: opt_deps]) with [ Not_found -> try let filename = find_in_path load_path.val (name ^ ".ml") in let basename = Filename.chop_suffix filename ".ml" in ([basename ^ ".cmo" :: byt_deps], [basename ^ ".cmx" :: opt_deps]) with [ Not_found -> (byt_deps, opt_deps) ] ] ; value (depends_on, escaped_eol) = match Sys.os_type with [ "Unix" | "Win32" | "Cygwin" -> (": ", "\\\n ") | "MacOS" -> ("\196 ", "\182\n ") | _ -> assert False ] ; value print_depend target_file deps = match deps with [ [] -> () | _ -> do { print_string target_file; print_string depends_on; let rec print_items pos = fun [ [] -> print_string "\n" | [dep :: rem] -> if pos + String.length dep <= 77 then do { print_string dep; print_string " "; print_items (pos + String.length dep + 1) rem } else do { print_string escaped_eol; print_string dep; print_string " "; print_items (String.length dep + 5) rem } ] in print_items (String.length target_file + 2) deps } ] ; (* Main *) value depend_sig ast = do { fset.val := StrSet.empty; List.iter (fun (si, _) -> sig_item si) ast; let basename = Filename.chop_suffix Pcaml.input_file.val ".mli" in let (byt_deps, _) = StrSet.fold find_depend fset.val ([], []) in print_depend (basename ^ ".cmi") byt_deps; } ; value depend_str ast = do { fset.val := StrSet.empty; List.iter (fun (si, _) -> str_item si) ast; let basename = if Filename.check_suffix Pcaml.input_file.val ".ml" then Filename.chop_suffix Pcaml.input_file.val ".ml" else try let len = String.rindex Pcaml.input_file.val '.' in String.sub Pcaml.input_file.val 0 len with [ Failure _ | Not_found -> Pcaml.input_file.val ] in let init_deps = if Sys.file_exists (basename ^ ".mli") then let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name]) else ([], []) in let (byt_deps, opt_deps) = StrSet.fold find_depend fset.val init_deps in print_depend (basename ^ ".cmo") byt_deps; print_depend (basename ^ ".cmx") opt_deps; } ; Pcaml.print_interf.val := depend_sig; Pcaml.print_implem.val := depend_str; Pcaml.add_option "-I" (Arg.String (fun dir -> load_path.val := load_path.val @ [dir])) " Add to the list of include directories."; mingw-ocaml/ocaml/camlp4/unmaintained/etc/pr_extfun.ml0000644000175000017500000000525312124403240022435 0ustar tootstoots(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) open Pcaml; open Spretty; value _loc = Loc.mk "FIXME pr_extfun.ml"; value expr e dg k = pr_expr.pr_fun "top" e dg k; value patt e dg k = pr_patt.pr_fun "top" e dg k; value rec un_extfun rpel = fun [ <:expr< [ ($_$, $_$, fun [ $list:pel$ ]) :: $el$ ] >> -> let (p, wo, e) = match pel with [ [(p, wo, <:expr< Some $e$ >>); (<:patt< _ >>, None, <:expr< None >>)] -> (p, wo, e) | [(p, wo, <:expr< Some $e$ >>)] -> (p, wo, e) | _ -> raise Not_found ] in let rpel = match rpel with [ [(p1, wo1, e1) :: pel] -> if wo1 = wo && e1 = e then let p = match (p1, p) with [ (<:patt< ($x1$ as $x2$) >>, <:patt< ($y1$ as $y2$) >>) -> if x2 = y2 then <:patt< ($x1$ | $y1$ as $x2$) >> else <:patt< $p1$ | $p$ >> | _ -> <:patt< $p1$ | $p$ >> ] in [(p, wo, e) :: pel] else [(p, wo, e) :: rpel] | [] -> [(p, wo, e)] ] in un_extfun rpel el | <:expr< [] >> -> List.rev rpel | _ -> raise Not_found ] ; value rec listwbws elem b sep el k = match el with [ [] -> [: b; k :] | [x] -> [: `elem b x k :] | [x :: l] -> [: `elem b x [: :]; listwbws elem [: `sep :] sep l k :] ] ; value rec match_assoc_list pwel k = match pwel with [ [pwe] -> match_assoc [: `S LR "[" :] pwe [: `S LR "]"; k :] | pel -> Vbox [: `HVbox [: :]; listwbws match_assoc [: `S LR "[" :] (S LR "|") pel [: `S LR "]"; k :] :] ] and match_assoc b (p, w, e) k = let s = let (p, k) = match p with [ <:patt< ($p$ as $p2$) >> -> (p, [: `S LR "as"; `patt p2 "" [: :] :]) | _ -> (p, [: :]) ] in match w with [ Some e1 -> [: `HVbox [: `HVbox [: :]; `patt p "" k; `HVbox [: `S LR "when"; `expr e1 "" [: `S LR "->" :] :] :] :] | _ -> [: `patt p "" [: k; `S LR "->" :] :] ] in HVbox [: b; `HVbox [: `HVbox s; `expr e "" k :] :] ; let lev = find_pr_level "top" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Extfun.extend $e$ $list$ >> as ge -> fun _ next dg k -> try let pel = un_extfun [] list in [: `HVbox [: :]; `BEbox [: `S LR "extfun"; `expr e "" [: :]; `S LR "with" :]; `match_assoc_list pel k :] with [ Not_found -> [: `next ge dg k :] ] ]; let lev = find_pr_level "apply" pr_expr.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:expr< Extfun.extend $_$ $_$ >> as ge -> fun _ next dg k -> [: `next ge dg k :] ]; mingw-ocaml/ocaml/camlp4/unmaintained/etc/pr_null.ml0000644000175000017500000000150312124403240022070 0ustar tootstoots(* camlp4r *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) Pcaml.print_interf.val := fun _ -> (); Pcaml.print_implem.val := fun _ -> (); mingw-ocaml/ocaml/camlp4/unmaintained/etc/pa_ifdef.ml0000644000175000017500000000627712124403240022167 0ustar tootstoots(* camlp4r pa_extend.cmo q_MLast.cmo *) (* This module is deprecated since version 3.07; use pa_macro.ml instead *) value _ = prerr_endline "Warning: pa_ifdef is deprecated since OCaml 3.07. Use pa_macro instead." ; type item_or_def 'a = [ SdStr of 'a | SdDef of string | SdUnd of string | SdNop ] ; value list_remove x l = List.fold_right (fun e l -> if e = x then l else [e :: l]) l [] ; value defined = ref ["OCAML_308"; "OCAML_307"; "OCAML_305"; "CAMLP4_300"; "NEWSEQ"]; value define x = defined.val := [x :: defined.val]; value undef x = defined.val := list_remove x defined.val; EXTEND GLOBAL: Pcaml.expr Pcaml.str_item Pcaml.sig_item; Pcaml.expr: LEVEL "top" [ [ "ifdef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else"; e2 = Pcaml.expr -> if List.mem c defined.val then e1 else e2 | "ifndef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else"; e2 = Pcaml.expr -> if List.mem c defined.val then e2 else e1 ] ] ; Pcaml.str_item: FIRST [ [ x = def_undef_str -> match x with [ SdStr si -> si | SdDef x -> do { define x; <:str_item< declare end >> } | SdUnd x -> do { undef x; <:str_item< declare end >> } | SdNop -> <:str_item< declare end >> ] ] ] ; def_undef_str: [ [ "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef; "else"; e2 = str_item_def_undef -> if List.mem c defined.val then e1 else e2 | "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef -> if List.mem c defined.val then e1 else SdNop | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef; "else"; e2 = str_item_def_undef -> if List.mem c defined.val then e2 else e1 | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef -> if List.mem c defined.val then SdNop else e1 | "define"; c = UIDENT -> SdDef c | "undef"; c = UIDENT -> SdUnd c ] ] ; str_item_def_undef: [ [ d = def_undef_str -> d | si = Pcaml.str_item -> SdStr si ] ] ; Pcaml.sig_item: FIRST [ [ x = def_undef_sig -> match x with [ SdStr si -> si | SdDef x -> do { define x; <:sig_item< declare end >> } | SdUnd x -> do { undef x; <:sig_item< declare end >> } | SdNop -> <:sig_item< declare end >> ] ] ] ; def_undef_sig: [ [ "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef; "else"; e2 = sig_item_def_undef -> if List.mem c defined.val then e1 else e2 | "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef -> if List.mem c defined.val then e1 else SdNop | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef; "else"; e2 = sig_item_def_undef -> if List.mem c defined.val then e2 else e1 | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef -> if List.mem c defined.val then SdNop else e1 | "define"; c = UIDENT -> SdDef c | "undef"; c = UIDENT -> SdUnd c ] ] ; sig_item_def_undef: [ [ d = def_undef_sig -> d | si = Pcaml.sig_item -> SdStr si ] ] ; END; Pcaml.add_option "-D" (Arg.String define) " Define for ifdef instruction." ; Pcaml.add_option "-U" (Arg.String undef) " Undefine for ifdef instruction." ; mingw-ocaml/ocaml/camlp4/unmaintained/etc/.depend0000644000175000017500000000026212124403240021324 0ustar tootstootsparserify.cmo: parserify.cmi parserify.cmx: parserify.cmi pr_op_main.cmo: parserify.cmi pr_op_main.cmx: parserify.cmx pr_rp_main.cmo: parserify.cmi pr_rp_main.cmx: parserify.cmx mingw-ocaml/ocaml/camlp4/unmaintained/etc/parserify.ml0000644000175000017500000002351412124403240022427 0ustar tootstoots(* camlp4r q_MLast.cmo *) (* FIXME FIXME *) value _loc = Loc.mk "FIXME parserify.ml"; type spc = [ SPCterm of (MLast.patt * option MLast.expr) | SPCnterm of MLast.patt and MLast.expr | SPCsterm of MLast.patt ] ; exception NotImpl; value rec subst v = MLast.Map.Expr.expr (fun [ <:expr@_loc< __strm >> -> <:expr< $lid:v$ >> | e -> e ]) (* FIXME FIXME *) (* match e with [ <:expr< $lid:x$ >> -> if x = "__strm" then <:expr< $lid:v$ >> else e | <:expr< $uid:_$ >> -> e | <:expr< $int:_$ >> -> e | <:expr< $chr:_$ >> -> e | <:expr< $str:_$ >> -> e | <:expr@_loc< $e1$ . $lab$ >> -> <:expr< $subst v e1$ . $lab$ >> | <:expr@_loc< $x$ $y$ >> -> <:expr< $subst v x$ $subst v y$ >> | <:expr@_loc< let $lid:s1$ = $e1$ in $e2$ >> -> if s1 = v then <:expr< let $lid:s1$ = $subst v e1$ in $e2$ >> else <:expr< let $lid:s1$ = $subst v e1$ in $subst v e2$ >> | <:expr@_loc< let _ = $e1$ in $e2$ >> -> <:expr< let _ = $subst v e1$ in $subst v e2$ >> | <:expr@_loc< ($list:el$) >> -> <:expr< ($list:List.map (subst v) el$) >> | _ -> raise NotImpl ] *) ; value rec is_free v = fun [ <:expr< $lid:x$ >> -> x <> v | <:expr< $uid:_$ >> -> True | <:expr< $int:_$ >> -> True | <:expr< $chr:_$ >> -> True | <:expr< $str:_$ >> -> True | <:expr< $e$ . $_$ >> -> is_free v e | <:expr< $x$ $y$ >> -> is_free v x && is_free v y | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> is_free v e1 && (s1 = v || is_free v e2) | <:expr< let _ = $e1$ in $e2$ >> -> is_free v e1 && is_free v e2 | <:expr< ($list:el$) >> -> List.for_all (is_free v) el | _ -> raise NotImpl ] ; value gensym = let cnt = ref 0 in fun () -> do { incr cnt; "pr_rp_symb_" ^ string_of_int cnt.val } ; value free_var_in_expr c e = let rec loop_alpha v = let x = String.make 1 v in if is_free x e then Some x else if v = 'z' then None else loop_alpha (Char.chr (Char.code v + 1)) in let rec loop_count cnt = let x = String.make 1 c ^ string_of_int cnt in if is_free x e then x else loop_count (succ cnt) in try match loop_alpha c with [ Some v -> v | None -> loop_count 1 ] with [ NotImpl -> gensym () ] ; value parserify _loc = fun [ <:expr< $e$ __strm >> -> e | e -> <:expr< fun __strm -> $e$ >> ] ; value is_raise_failure = fun [ <:expr< raise Stream.Failure >> -> True | _ -> False ] ; value is_raise_error = fun [ <:expr< raise (Stream.Error $_$) >> -> True | _ -> False ] ; value semantic _loc e = try if is_free "__strm" e then e else let v = free_var_in_expr 's' e in <:expr< let $lid:v$ = __strm in $subst v e$ >> with [ NotImpl -> e ] ; value rewrite_parser = rewrite True where rec rewrite top ge = match ge with [ <:expr@_loc< let $p$ = try $e$ with [ Stream.Failure -> raise $exc$ ] in $sp_kont$ >> -> let f = parserify _loc e in <:expr< match try Some ($f$ __strm) with [ Stream.Failure -> None ] with [ Some $p$ -> $rewrite False sp_kont$ | _ -> raise $exc$ ] >> | <:expr@_loc< let $p$ = Stream.count __strm in $f$ >> -> try if is_free "__strm" f then ge else let v = free_var_in_expr 's' f in <:expr< let $lid:v$ = __strm in let $p$ = Stream.count __strm in $subst v f$ >> with [ NotImpl -> ge ] | <:expr@_loc< let $p$ = __strm in $e$ >> -> <:expr< let $p$ = __strm in $rewrite False e$ >> | <:expr@_loc< let $p$ = $f$ __strm in $sp_kont$ >> when top -> <:expr< match try Some ($f$ __strm) with [ Stream.Failure -> None ] with [ Some $p$ -> $rewrite False sp_kont$ | _ -> raise Stream.Failure ] >> | <:expr@_loc< let $p$ = $e$ in $sp_kont$ >> -> if match e with [ <:expr< match try Some $_$ with [ Stream.Failure -> None ] with [ $list:_$ ] >> | <:expr< match Stream.peek __strm with [ $list:_$ ] >> | <:expr< try $_$ with [ Stream.Failure -> $_$ ] >> | <:expr< let $_$ = Stream.count __strm in $_$ >> -> True | _ -> False ] then let f = rewrite True <:expr< fun __strm -> $e$ >> in let exc = if top then <:expr< Stream.Failure >> else <:expr< Stream.Error "" >> in <:expr< match try Some ($f$ __strm) with [ Stream.Failure -> None ] with [ Some $p$ -> $rewrite False sp_kont$ | _ -> raise $exc$ ] >> else semantic _loc ge | <:expr@_loc< match try Some $e$ with [ Stream.Failure -> None ] with [ Some $p$ -> $sp_kont$ | _ -> $p_kont$ ] >> -> let f = parserify _loc e in if not top && is_raise_failure p_kont then semantic _loc ge else let (p, f, sp_kont, p_kont) = if top || is_raise_error p_kont then (p, f, rewrite False sp_kont, rewrite top p_kont) else let f = <:expr< fun __strm -> match try Some ($f$ __strm) with [ Stream.Failure -> None ] with [ Some $p$ -> $rewrite False sp_kont$ | _ -> $rewrite top p_kont$ ] >> in (<:patt< a >>, f, <:expr< a >>, <:expr< raise (Stream.Error "") >>) in <:expr< match try Some ($f$ __strm) with [ Stream.Failure -> None ] with [ Some $p$ -> $sp_kont$ | _ -> $p_kont$ ] >> | <:expr< match Stream.peek __strm with [ $list:pel$ ] >> -> let rec iter pel = match pel with [ [(<:patt< Some $p$ >>, eo, <:expr< do { Stream.junk __strm; $sp_kont$ } >>); (<:patt< _ >>, None, p_kont) :: _] -> <:expr< match Stream.peek __strm with [ Some $p$ $when:eo$ -> do { Stream.junk __strm; $rewrite False sp_kont$ } | _ -> $rewrite top p_kont$ ] >> | [(<:patt< Some $p$ >>, eo, <:expr< do { Stream.junk __strm; $sp_kont$ } >>) :: pel] -> let p_kont = iter pel in <:expr< match Stream.peek __strm with [ Some $p$ $when:eo$ -> do { Stream.junk __strm; $rewrite False sp_kont$ } | _ -> $p_kont$ ] >> | _ -> <:expr< match Stream.peek __strm with [ $list:pel$ ] >> ] in iter pel | <:expr@_loc< try Some $e$ with [ Stream.Failure -> $p_kont$ ] >> -> let f = parserify _loc e in let e = <:expr< match try Some ($f$ __strm) with [ Stream.Failure -> None ] with [ Some a -> Some a | _ -> $p_kont$ ] >> in rewrite top e | <:expr@_loc< try $e$ with [ Stream.Failure -> $p_kont$ ] >> -> let f = parserify _loc e in let e = <:expr< match try Some ($f$ __strm) with [ Stream.Failure -> None ] with [ Some a -> a | _ -> $rewrite top p_kont$ ] >> in rewrite top e | <:expr< $f$ __strm >> -> if top then <:expr< match try Some ($f$ __strm) with [ Stream.Failure -> None ] with [ Some a -> a | _ -> raise Stream.Failure ] >> else let v = free_var_in_expr 's' f in <:expr< let $lid:v$ = __strm in $subst v f$ $lid:v$ >> | e -> let loc = MLast.loc_of_expr e in semantic loc e ] ; value spc_of_parser = let rec parser_cases e = match e with [ <:expr< match try Some ($f$ __strm) with [ Stream.Failure -> None ] with [ Some $p$ -> $sp_kont$ | _ -> $p_kont$ ] >> -> let spc = (SPCnterm p f, None) in let (sp, epo, e) = kont sp_kont in [([spc :: sp], epo, e) :: parser_cases p_kont] | <:expr< match Stream.peek __strm with [ Some $p$ $when:wo$ -> do { Stream.junk __strm; $sp_kont$ } | _ -> $p_kont$ ] >> -> let spc = (SPCterm (p, wo), None) in let (sp, epo, e) = kont sp_kont in [([spc :: sp], epo, e) :: parser_cases p_kont] | <:expr< let $p$ = __strm in $sp_kont$ >> -> let spc = (SPCsterm p, None) in let (sp, epo, e) = kont sp_kont in [([spc :: sp], epo, e)] | <:expr< let $p$ = Stream.count __strm in $e$ >> -> [([], Some p, e)] | <:expr< raise Stream.Failure >> -> [] | _ -> [([], None, e)] ] and kont e = match e with [ <:expr< match try Some ($f$ __strm) with [ Stream.Failure -> None ] with [ Some $p$ -> $sp_kont$ | _ -> raise (Stream.Error $err$) ] >> -> let err = match err with [ <:expr< "" >> -> None | _ -> Some err ] in let spc = (SPCnterm p f, err) in let (sp, epo, e) = kont sp_kont in ([spc :: sp], epo, e) | <:expr< match Stream.peek __strm with [ Some $p$ $when:wo$ -> do { Stream.junk __strm; $sp_kont$ } | _ -> raise (Stream.Error $err$) ] >> -> let err = match err with [ <:expr< "" >> -> None | _ -> Some err ] in let spc = (SPCterm (p, wo), err) in let (sp, epo, e) = kont sp_kont in ([spc :: sp], epo, e) | <:expr< let $p$ = __strm in $sp_kont$ >> -> let spc = (SPCsterm p, None) in let (sp, epo, e) = kont sp_kont in ([spc :: sp], epo, e) | <:expr< let $p$ = Stream.count __strm in $e$ >> -> ([], Some p, e) | _ -> ([], None, e) ] in parser_cases ; value parser_of_expr e = spc_of_parser (rewrite_parser e); mingw-ocaml/ocaml/camlp4/unmaintained/etc/pa_fstream.ml0000644000175000017500000001122012124403240022533 0ustar tootstoots(* camlp4r pa_extend.cmo q_MLast.cmo *) open Pcaml; type spat_comp = [ SpTrm of Loc.t and MLast.patt and option MLast.expr | SpNtr of Loc.t and MLast.patt and MLast.expr | SpStr of Loc.t and MLast.patt ] ; type sexp_comp = [ SeTrm of Loc.t and MLast.expr | SeNtr of Loc.t and MLast.expr ] ; (* parsers *) value strm_n = "__strm"; value next_fun _loc = <:expr< Fstream.next >>; value rec pattern_eq_expression p e = match (p, e) with [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) -> pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 | (<:patt< ($list:pl$) >>, <:expr< ($list:el$) >>) -> loop pl el where rec loop pl el = match (pl, el) with [ ([p :: pl], [e :: el]) -> pattern_eq_expression p e && loop pl el | ([], []) -> True | _ -> False ] | _ -> False ] ; value stream_pattern_component skont = fun [ SpTrm _loc p wo -> let p = <:patt< Some ($p$, $lid:strm_n$) >> in if wo = None && pattern_eq_expression p skont then <:expr< $next_fun _loc$ $lid:strm_n$ >> else <:expr< match $next_fun _loc$ $lid:strm_n$ with [ $p$ $when:wo$ -> $skont$ | _ -> None ] >> | SpNtr _loc p e -> let p = <:patt< Some ($p$, $lid:strm_n$) >> in if pattern_eq_expression p skont then <:expr< $e$ $lid:strm_n$ >> else <:expr< match $e$ $lid:strm_n$ with [ $p$ -> $skont$ | _ -> None ] >> | SpStr _loc p -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ; value rec stream_pattern _loc epo e = fun [ [] -> let e = match epo with [ Some ep -> <:expr< let $ep$ = Fstream.count $lid:strm_n$ in $e$ >> | None -> e ] in <:expr< Some ($e$, $lid:strm_n$) >> | [spc :: spcl] -> let skont = stream_pattern _loc epo e spcl in stream_pattern_component skont spc ] ; value rec parser_cases _loc = fun [ [] -> <:expr< None >> | [(spcl, epo, e) :: spel] -> match parser_cases _loc spel with [ <:expr< None >> -> stream_pattern _loc epo e spcl | pc -> <:expr< match $stream_pattern _loc epo e spcl$ with [ Some _ as x -> x | None -> $pc$ ] >> ] ] ; value cparser_match _loc me bpo pc = let pc = parser_cases _loc pc in let e = match bpo with [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> | None -> pc ] in <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ; value cparser _loc bpo pc = let e = parser_cases _loc pc in let e = match bpo with [ Some bp -> <:expr< let $bp$ = Fstream.count $lid:strm_n$ in $e$ >> | None -> e ] in let p = <:patt< ($lid:strm_n$ : Fstream.t _) >> in <:expr< fun $p$ -> $e$ >> ; (* streams *) value slazy _loc x = <:expr< fun () -> $x$ >>; value rec cstream _loc = fun [ [] -> <:expr< Fstream.nil >> | [SeTrm _loc e :: sel] -> let e2 = cstream _loc sel in let x = <:expr< Fstream.cons $e$ $e2$ >> in <:expr< Fstream.flazy $slazy _loc x$ >> | [SeNtr _loc e] -> e | [SeNtr _loc e :: sel] -> let e2 = cstream _loc sel in let x = <:expr< Fstream.app $e$ $e2$ >> in <:expr< Fstream.flazy $slazy _loc x$ >> ] ; EXTEND GLOBAL: expr; expr: LEVEL "top" [ [ "fparser"; po = OPT ipatt; "["; pcl = LIST0 parser_case SEP "|"; "]" -> <:expr< $cparser _loc po pcl$ >> | "fparser"; po = OPT ipatt; pc = parser_case -> <:expr< $cparser _loc po [pc]$ >> | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; "["; pcl = LIST0 parser_case SEP "|"; "]" -> <:expr< $cparser_match _loc e po pcl$ >> | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; pc = parser_case -> <:expr< $cparser_match _loc e po [pc]$ >> ] ] ; parser_case: [ [ "[:"; sp = stream_patt; ":]"; po = OPT ipatt; "->"; e = expr -> (sp, po, e) ] ] ; stream_patt: [ [ spc = stream_patt_comp -> [spc] | spc = stream_patt_comp; ";"; sp = LIST1 stream_patt_comp SEP ";" -> [spc :: sp] | -> [] ] ] ; stream_patt_comp: [ [ "`"; p = patt; eo = OPT [ "when"; e = expr -> e ] -> SpTrm _loc p eo | p = patt; "="; e = expr -> SpNtr _loc p e | p = patt -> SpStr _loc p ] ] ; ipatt: [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ] ; expr: LEVEL "simple" [ [ "fstream"; "[:"; se = LIST0 stream_expr_comp SEP ";"; ":]" -> <:expr< $cstream _loc se$ >> ] ] ; stream_expr_comp: [ [ "`"; e = expr -> SeTrm _loc e | e = expr -> SeNtr _loc e ] ] ; END; mingw-ocaml/ocaml/camlp4/unmaintained/sml/0000755000175000017500000000000012124403240020104 5ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/sml/Makefile0000644000175000017500000000446512124403240021555 0ustar tootstoots######################################################################### # # # OCaml # # # # Camlp4 # # # # Copyright 2004 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../../LICENSE.# # # ######################################################################### # # Makefile for pa_sml # M.Mauny # include ../../config/Makefile.cnf OCAMLTOP=../../.. OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) -nostdlib -I $(OCAMLTOP)/stdlib OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) -nostdlib -I $(OCAMLTOP)/stdlib P4INCLUDES=-I ../../meta -I ../../etc -I ../../lib -I ../../camlp4 OCAMLINCLUDES=-I ../../meta -I ../../lib -I ../../camlp4 CAMLP4=camlp4$(EXE) -nolib OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) SRC=pa_sml.ml OBJS=$(SRC:.ml=.cmo) OBJSX=$(SRC:.ml=.cmx) all: $(OBJS) smllib.cmo opt: $(OBJSX) smllib.cmx depend: cp .depend .depend.bak > .depend for file in $(SRC); do \ $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ done clean: rm -f *.cm* *.o *.bak .*.bak .SUFFIXES: .cmx .cmo .cmi .ml .mli .sml .mli.cmi: $(OCAMLC) $(OCAMLCFLAGS) -c $< .sml.cmo: $(OCAMLC) -I ../../../otherlibs/unix -pp "$(CAMLP4) ./pa_sml.cmo ../../meta/pr_dump.cmo -impl" -c -o $*.cmo -impl $< .sml.cmx: $(OCAMLOPT) -I ../../../otherlibs/unix -pp "$(CAMLP4) ./pa_sml.cmo ../../meta/pr_dump.cmo -impl" -c -o $*.cmx -impl $< .ml.cmo: $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< .ml.cmx: $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< include .depend mingw-ocaml/ocaml/camlp4/unmaintained/sml/pa_sml.ml0000644000175000017500000007553012124403240021723 0ustar tootstoots(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file *) (* ../../../LICENSE. *) (* *) (***********************************************************************) open Stdpp; open Pcaml; value ocaml_records = ref False; Pcaml.no_constructors_arity.val := True; value lexer = Plexer.gmake (); do { Grammar.Unsafe.gram_reinit gram lexer; Grammar.Unsafe.clear_entry interf; Grammar.Unsafe.clear_entry implem; Grammar.Unsafe.clear_entry top_phrase; Grammar.Unsafe.clear_entry use_file; Grammar.Unsafe.clear_entry module_type; Grammar.Unsafe.clear_entry module_expr; Grammar.Unsafe.clear_entry sig_item; Grammar.Unsafe.clear_entry str_item; Grammar.Unsafe.clear_entry expr; Grammar.Unsafe.clear_entry patt; Grammar.Unsafe.clear_entry ctyp; Grammar.Unsafe.clear_entry let_binding; }; Pcaml.parse_interf.val := Grammar.Entry.parse interf; Pcaml.parse_implem.val := Grammar.Entry.parse implem; value not_impl loc s = raise_with_loc loc (Stream.Error ("not implemented feature [" ^ s ^ "]")) ; type altern 'a 'b = [ Left of 'a | Right of 'b ]; value get_seq = fun [ <:expr< do { $list:el$ } >> -> el | e -> [e] ] ; value choose_tvar tpl = let rec find_alpha v = let s = String.make 1 v in if List.mem_assoc s tpl then if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1)) else Some (String.make 1 v) in let rec make_n n = let v = "a" ^ string_of_int n in if List.mem_assoc v tpl then make_n (succ n) else v in match find_alpha 'a' with [ Some x -> x | None -> make_n 1 ] ; value mklistexp loc last = loop True where rec loop top = fun [ [] -> match last with [ Some e -> e | None -> <:expr< [] >> ] | [e1 :: el] -> let loc = if top then loc else (fst (MLast.loc_of_expr e1), snd loc) in <:expr< [$e1$ :: $loop False el$] >> ] ; value mklistpat loc last = loop True where rec loop top = fun [ [] -> match last with [ Some p -> p | None -> <:patt< [] >> ] | [p1 :: pl] -> let loc = if top then loc else (fst (MLast.loc_of_patt p1), snd loc) in <:patt< [$p1$ :: $loop False pl$] >> ] ; value expr_of_patt p = let loc = MLast.loc_of_patt p in match p with [ <:patt< $lid:x$ >> -> <:expr< $lid:x$ >> | _ -> Stdpp.raise_with_loc loc (Stream.Error "identifier expected") ] ; value apply_bind loc e bl = let rec loop e = fun [ [] -> e | [<:str_item< value $p1$ = $e1$ >> :: list] -> loop_let e [(p1, e1)] list | [<:str_item< value rec $p1$ = $e1$ >> :: list] -> loop_letrec e [(p1, e1)] list | [<:str_item< module $s$ = $me$ >> :: list] -> let e = <:expr< let module $s$ = $me$ in $e$ >> in loop e list | [si :: list] -> raise Exit ] and loop_let e pel = fun [ [<:str_item< value $p1$ = $e1$ >> :: list] -> loop_let e [(p1, e1) :: pel] list | list -> let e = <:expr< let $list:pel$ in $e$ >> in loop e list ] and loop_letrec e pel = fun [ [<:str_item< value rec $p1$ = $e1$ >> :: list] -> loop_letrec e [(p1, e1) :: pel] list | list -> let e = <:expr< let rec $list:pel$ in $e$ >> in loop e list ] in loop e (List.rev bl) ; value make_local loc sl1 sl2 = try let pl = List.map (fun [ <:str_item< value $opt:_$ $p$ = $_$ >> -> p | _ -> raise Exit ]) sl2 in let e1 = match List.map expr_of_patt pl with [ [e] -> e | el -> <:expr< ($list:el$) >> ] in let p1 = match pl with [ [p] -> p | pl -> <:patt< ($list:pl$) >> ] in let e = apply_bind loc e1 sl2 in let e = apply_bind loc e sl1 in <:str_item< value $p1$ = $e$ >> with [ Exit -> do { Printf.eprintf "\ *** Warning: a 'local' statement will be defined global because of bindings which cannot be defined as first class values (modules, exceptions, ...)\n"; flush stderr; <:str_item< declare $list:sl1 @ sl2$ end >> } ] ; value str_declare loc = fun [ [d] -> d | dl -> <:str_item< declare $list:dl$ end >> ] ; value sig_declare loc = fun [ [d] -> d | dl -> <:sig_item< declare $list:dl$ end >> ] ; value extract_label_types loc tn tal cdol = let (cdl, aux) = List.fold_right (fun (loc, c, tl, aux_opt) (cdl, aux) -> match aux_opt with [ Some anon_record_type -> let new_tn = tn ^ "_" ^ c in let loc = MLast.loc_of_ctyp anon_record_type in let aux_def = ((loc, new_tn), [], anon_record_type, []) in let tl = [<:ctyp< $lid:new_tn$ >>] in ([(loc, c, tl) :: cdl], [aux_def :: aux]) | None -> ([(loc, c, tl) :: cdl], aux) ]) cdol ([], []) in [((loc, tn), tal, <:ctyp< [ $list:cdl$ ] >>, []) :: aux] ; value function_of_clause_list loc xl = let (fname, fname_loc, nbpat, l) = List.fold_left (fun (fname, fname_loc, nbpat, l) ((x1, loc), x2, x3, x4) -> let (fname, fname_loc, nbpat) = if fname = "" then (x1, loc, List.length x2) else if x1 <> fname then raise_with_loc loc (Stream.Error ("'" ^ fname ^ "' expected")) else if List.length x2 <> nbpat then raise_with_loc loc (Stream.Error "bad number of patterns in that clause") else (fname, fname_loc, nbpat) in let x4 = match x3 with [ Some t -> <:expr< ($x4$ : $t$) >> | _ -> x4 ] in let l = [(x2, x4) :: l] in (fname, fname_loc, nbpat, l)) ("", loc, 0, []) xl in let l = List.rev l in let e = match l with [ [(pl, e)] -> List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl e | _ -> if nbpat = 1 then let pwel = List.map (fun (pl, e) -> (<:patt< $List.hd pl$ >>, None, e)) l in <:expr< fun [ $list:pwel$ ] >> else let sl = loop 0 where rec loop n = if n = nbpat then [] else ["a" ^ string_of_int (n + 1) :: loop (n + 1)] in let e = let el = List.map (fun s -> <:expr< $lid:s$ >>) sl in let pwel = List.map (fun (pl, e) -> (<:patt< ($list:pl$) >>, None, e)) l in <:expr< match ($list:el$) with [ $list:pwel$ ] >> in List.fold_right (fun s e -> <:expr< fun $lid:s$ -> $e$ >>) sl e ] in (let loc = fname_loc in <:patt< $lid:fname$ >>, e) ; value record_expr loc x1 = if ocaml_records.val then <:expr< { $list:x1$ } >> else let list1 = List.map (fun (l, v) -> let id = match l with [ <:patt< $lid:l$ >> -> l | _ -> "" ] in let loc = MLast.loc_of_expr v in <:class_str_item< value $id$ = $v$ >>) x1 in let list2 = List.map (fun (l, v) -> let id = match l with [ <:patt< $lid:l$ >> -> l | _ -> "" ] in let loc = MLast.loc_of_patt l in <:class_str_item< method $id$ = $lid:id$ >>) x1 in <:expr< let module M = struct class a = object $list:list1 @ list2$ end; end in new M.a >> ; value record_match_assoc loc lpl e = if ocaml_records.val then (<:patt< { $list:lpl$ } >>, e) else let pl = List.map (fun (_, p) -> p) lpl in let e = let el = List.map (fun (l, _) -> let s = match l with [ <:patt< $lid:l$ >> -> l | _ -> "" ] in let loc = MLast.loc_of_patt l in <:expr< v # $lid:s$ >>) lpl in let loc = MLast.loc_of_expr e in <:expr< let v = $e$ in ($list:el$) >> in let p = <:patt< ($list:pl$) >> in (p, e) ; value op = Grammar.Entry.of_parser gram "op" (parser [: `("", "op"); `(_, x) :] -> x) ; lexer.Token.tok_using ("", "op"); value special x = if String.length x >= 2 then match x.[0] with [ '+' | '<' | '^' -> True | _ -> False ] else False ; value idd = let p = parser [ [: `("LIDENT", x) :] -> x | [: `("UIDENT", x) :] -> x | [: `("", "op"); `(_, x) :] -> x | [: `("", x) when special x :] -> x ] in Grammar.Entry.of_parser Pcaml.gram "ID" p ; value uncap s = String.uncapitalize s; EXTEND GLOBAL: implem interf top_phrase use_file sig_item str_item ctyp patt expr module_type module_expr; implem: [ [ x = interdec; EOI -> x ] ] ; interf: [ [ x = LIST1 [ s = sig_item; OPT ";" -> (s, loc) ] -> (x, False) ] ] ; top_phrase: [ [ ph = phrase; ";" -> Some ph | EOI -> None ] ] ; use_file: [ [ l = LIST0 phrase; EOI -> (l, False) ] ] ; phrase: [ [ x = str_item -> x | x = expr -> <:str_item< $exp:x$ >> | "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ] ; dir_param: [ [ -> None | e = expr -> Some e ] ] ; sdecs: [ [ x = sdec; l = sdecs -> [x :: l] | ";"; l = sdecs -> l | -> [] ] ] ; fsigb: [ [ -> not_impl loc "fsigb" ] ]; fsigconstraint_op: [ [ -> not_impl loc "fsigconstraint_op" ] ]; fct_exp: [ [ -> not_impl loc "fct_exp" ] ]; exp_pa: [ [ -> not_impl loc "exp_pa" ] ]; rvb: [ [ -> not_impl loc "rvb" ] ]; tyvarseq: [ [ -> not_impl loc "tyvarseq" ] ]; tyvar_pc: [ [ "'"; x1 = LIDENT -> [(x1, (False, False))] | "'"; x1 = LIDENT; ","; l = tyvar_pc -> [(x1, (False, False)) :: l] ] ] ; id: [ [ x1 = idd -> x1 | "*" -> "*" ] ] ; ident: [ [ x1 = idd -> x1 | "*" -> "*" | "=" -> "=" | "<" -> "<" | ">" -> ">" | "<=" -> "<=" | ">=" -> ">=" | "^" -> "^" ] ] ; op_op: [ [ x1 = op -> not_impl loc "op_op 1" | -> () ] ] ; qid: [ [ x1 = idd; "."; x2 = qid -> <:module_expr< $uid:x1$ . $x2$ >> | x1 = idd -> <:module_expr< $uid:x1$ >> | x1 = "*" -> <:module_expr< $uid:x1$ >> | x1 = "=" -> <:module_expr< $uid:x1$ >> ] ] ; eqid: [ [ x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >> | x1 = UIDENT -> <:expr< $uid:x1$ >> | x1 = idd -> <:expr< $lid:x1$ >> | x1 = "*" -> <:expr< $lid:x1$ >> | x1 = "=" -> <:expr< $lid:x1$ >> ] ] ; sqid: [ [ x1 = idd; "."; x2 = sqid -> [x1 :: x2] | x1 = idd -> [x1] | x1 = "*" -> [x1] | x1 = "=" -> [x1] ] ] ; tycon: [ [ LIDENT "real" -> <:ctyp< float >> | x1 = idd; "."; x2 = tycon -> let r = <:ctyp< $uid:x1$ . $x2$ >> in loop r where rec loop = fun [ <:ctyp< $a$ . ($b$ . $c$) >> -> <:ctyp< $a$ . $b$ . $loop c$ >> | x -> x ] | x1 = idd -> <:ctyp< $lid:uncap x1$ >> ] ] ; selector: [ [ x1 = id -> x1 | x1 = INT -> not_impl loc "selector 1" ] ] ; tlabel: [ [ x1 = selector; ":"; x2 = ctyp -> (loc, x1, False, x2) ] ] ; tuple_ty: [ [ x1 = ctyp LEVEL "ty'"; "*"; x2 = tuple_ty -> [x1 :: x2] | x1 = ctyp LEVEL "ty'" -> [x1] ] ] ; ctyp: [ RIGHTA [ x1 = ctyp; "->"; x2 = ctyp -> <:ctyp< $x1$ -> $x2$ >> ] | [ x1 = ctyp; "*"; x2 = tuple_ty -> <:ctyp< ($list:[x1 :: x2]$) >> ] | "ty'" [ "'"; x1 = LIDENT -> <:ctyp< '$x1$ >> | "'"; "'"; x1 = LIDENT -> <:ctyp< '$x1$ >> | "{"; x1 = LIST1 tlabel SEP ","; "}" -> if ocaml_records.val then <:ctyp< { $list:x1$ } >> else let list = List.map (fun (_, l, _, t) -> (l, t)) x1 in <:ctyp< < $list:list$ > >> | "{"; "}" -> not_impl loc "ty' 3" | "("; x1 = ctyp; ","; x2 = LIST1 ctyp SEP ","; ")"; x3 = tycon -> List.fold_left (fun t1 t2 -> <:ctyp< $t1$ $t2$ >>) x3 [x1 :: x2] | "("; x1 = ctyp; ")" -> x1 | x1 = ctyp; x2 = tycon -> <:ctyp< $x2$ $x1$ >> | x1 = tycon -> x1 ] ] ; rule: [ [ x1 = patt; "=>"; x2 = expr -> (x1, None, x2) ] ] ; elabel: [ [ x1 = selector; "="; x2 = expr -> (<:patt< $lid:x1$ >>, x2) ] ] ; exp_ps: [ [ x1 = expr -> x1 | x1 = expr; ";"; x2 = exp_ps -> <:expr< do { $list:[x1 :: get_seq x2]$ } >> ] ] ; expr: [ [ "if"; x1 = expr; "then"; x2 = expr; "else"; x3 = expr -> <:expr< if $x1$ then $x2$ else $x3$ >> | "fn"; x1 = LIST1 rule SEP "|" -> <:expr< fun [$list:x1$] >> | "case"; x1 = expr; "of"; x2 = LIST1 rule SEP "|" -> <:expr< match $x1$ with [$list:x2$] >> | "while"; x1 = expr; "do"; x2 = expr -> <:expr< while $x1$ do { $x2$ } >> | x1 = expr; "handle"; x2 = LIST1 rule SEP "|" -> <:expr< try $x1$ with [$list:x2$] >> ] | RIGHTA [ "raise"; x1 = expr -> <:expr< raise $x1$ >> ] | [ e1 = expr; ":="; e2 = expr -> <:expr< $e1$.val := $e2$ >> ] | LEFTA [ x1 = expr; "orelse"; x2 = expr -> <:expr< $x1$ || $x2$ >> ] | LEFTA [ x1 = expr; "andalso"; x2 = expr -> <:expr< $x1$ && $x2$ >> ] | LEFTA [ x1 = expr; ":"; x2 = ctyp -> <:expr< ($x1$ : $x2$) >> ] | "4" NONA [ x1 = expr; "<"; x2 = expr -> <:expr< $x1$ < $x2$ >> | x1 = expr; ">"; x2 = expr -> <:expr< $x1$ > $x2$ >> | x1 = expr; "<>"; x2 = expr -> <:expr< $x1$ <> $x2$ >> | x1 = expr; "="; x2 = expr -> <:expr< $x1$ = $x2$ >> | x1 = expr; ">="; x2 = expr -> <:expr< $x1$ >= $x2$ >> | x1 = expr; "<="; x2 = expr -> <:expr< $x1$ <= $x2$ >> ] | RIGHTA [ x1 = expr; "^"; x2 = expr -> <:expr< $x1$ ^ $x2$ >> | x1 = expr; "@"; x2 = expr -> <:expr< $x1$ @ $x2$ >> | x1 = expr; "o"; x2 = expr -> <:expr< ooo $x1$ $x2$ >> ] | "5" RIGHTA [ x1 = expr; "::"; x2 = expr -> <:expr< [$x1$ :: $x2$] >> ] | "6" LEFTA [ x1 = expr; "+"; x2 = expr -> <:expr< $x1$ + $x2$ >> | x1 = expr; "-"; x2 = expr -> <:expr< $x1$ - $x2$ >> ] | "7" LEFTA [ x1 = expr; "*"; x2 = expr -> <:expr< $x1$ * $x2$ >> | x1 = expr; "/"; x2 = expr -> <:expr< $x1$ / $x2$ >> | x1 = expr; "div"; x2 = expr -> <:expr< $x1$ / $x2$ >> | x1 = expr; "mod"; x2 = expr -> <:expr< $x1$ mod $x2$ >> ] | LEFTA [ x1 = expr; x2 = expr -> <:expr< $x1$ $x2$ >> ] | [ "#"; x1 = STRING -> <:expr< $chr:x1$ >> | "#"; x1 = selector; x2 = expr -> if ocaml_records.val then <:expr< $x2$ . $lid:x1$ >> else <:expr< $x2$ # $lid:x1$ >> | x1 = expr; "ocaml_record_access"; x2 = expr -> <:expr< $x1$ . $x2$ >> ] | [ "!"; x1 = expr -> <:expr< $x1$ . val >> | "~"; x1 = expr -> <:expr< - $x1$ >> ] | [ x1 = LIDENT -> match x1 with [ "true" | "false" -> <:expr< $uid:String.capitalize x1$ >> | "nil" -> <:expr< [] >> | _ -> <:expr< $lid:x1$ >> ] | x1 = UIDENT -> <:expr< $uid:x1$ >> | x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >> | x1 = INT -> <:expr< $int:x1$ >> | x1 = FLOAT -> <:expr< $flo:x1$ >> | x1 = STRING -> <:expr< $str:x1$ >> | "~"; x1 = INT -> <:expr< $int:"-"^x1$ >> | i = op -> if i = "::" then <:expr< fun (x, y) -> [x :: y] >> else <:expr< fun (x, y) -> $lid:i$ x y >> | "let"; x1 = ldecs; "in"; x2 = exp_ps; "end" -> List.fold_right (fun pel x2 -> let loc = match pel with [ [(p, _) :: _] -> (fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr x2)) | _ -> loc ] in match pel with [ [(_, <:expr< fun [$list:_$] >>) :: _] -> <:expr< let rec $list:pel$ in $x2$ >> | _ -> let pel = List.map (fun (p, e) -> match p with [ <:patt< { $list:lpl$ } >> -> record_match_assoc (MLast.loc_of_patt p) lpl e | _ -> (p, e) ]) pel in <:expr< let $list:pel$ in $x2$ >> ]) x1 x2 | "{"; x1 = LIST1 elabel SEP ","; "}" -> record_expr loc x1 | "["; "]" -> <:expr< [] >> | "["; x1 = expr; "]" -> <:expr< [$x1$] >> | "["; x1 = expr; ","; x2 = LIST1 SELF SEP ","; "]" -> mklistexp loc None [x1 :: x2] | "("; ")" -> <:expr< () >> | "("; x1 = expr; ","; x2 = LIST1 SELF SEP ","; ")" -> <:expr< ($list:[x1::x2]$) >> | "("; x1 = expr; ";"; x2 = LIST1 SELF SEP ";"; ")" -> <:expr< do { $list:[x1::x2]$ } >> | "("; x1 = expr; ")" -> x1 ] ] ; fixity: [ [ "infix" -> ("infix", None) | "infix"; x1 = INT -> not_impl loc "fixity 2" | "infixr" -> not_impl loc "fixity 3" | "infixr"; x1 = INT -> ("infixr", Some x1) | "nonfix" -> not_impl loc "fixity 5" ] ] ; patt: [ [ x1 = patt; "as"; x2 = patt -> <:patt< ($x1$ as $x2$) >> ] | LEFTA [ x1 = patt; ":"; x2 = ctyp -> <:patt< ($x1$ : $x2$) >> ] | RIGHTA [ x1 = patt; "::"; x2 = patt -> <:patt< [$x1$ :: $x2$] >> ] | [ x1 = patt; x2 = patt -> match x1 with [ <:patt< ref >> -> <:patt< {contents = $x2$} >> | _ -> <:patt< $x1$ $x2$ >> ] ] | "apat" [ x1 = patt; "."; x2 = patt -> <:patt< $x1$ . $x2$ >> | x1 = INT -> <:patt< $int:x1$ >> | x1 = UIDENT -> <:patt< $uid:x1$ >> | x1 = STRING -> <:patt< $str:x1$ >> | "#"; x1 = STRING -> <:patt< $chr:x1$ >> | "~"; x1 = INT -> <:patt< $int:"-"^x1$ >> | LIDENT "nil" -> <:patt< [] >> | LIDENT "false" -> <:patt< False >> | LIDENT "true" -> <:patt< True >> | x1 = id -> <:patt< $lid:x1$ >> | x1 = op -> <:patt< $lid:x1$ >> | "_" -> <:patt< _ >> | "["; "]" -> <:patt< [] >> | "["; x1 = patt; "]" -> <:patt< [$x1$] >> | "["; x1 = patt; ","; x2 = LIST1 SELF SEP ","; "]" -> mklistpat loc None [x1 :: x2] | "{"; x1 = LIST1 plabel SEP ","; "}" -> <:patt< {$list:x1$} >> | "("; ")" -> <:patt< () >> | "("; x1 = patt; ","; x2 = LIST1 SELF SEP ","; ")" -> <:patt< ($list:[x1::x2]$) >> | "("; x1 = patt; ")" -> x1 ] ] ; plabel: [ [ x1 = selector; "="; x2 = patt -> (<:patt< $lid:x1$ >>, x2) | x1 = selector -> (<:patt< $lid:x1$ >>, <:patt< $lid:x1$ >>) ] ] ; vb: [ [ "lazy"; x1 = patt; "="; x2 = expr -> not_impl loc "vb 1" | x1 = patt; "="; x2 = expr -> (x1, x2) ] ] ; constrain: [ [ -> None | ":"; x1 = ctyp -> Some x1 ] ] ; fb: [ [ xl = LIST1 clause SEP "|" -> function_of_clause_list loc xl | "lazy"; x1 = LIST1 clause SEP "|" -> not_impl loc "fb 2" ] ] ; clause: [ [ x1 = patt LEVEL "apat"; x2 = LIST1 (patt LEVEL "apat"); x3 = constrain; "="; x4 = expr -> let x1 = match x1 with [ <:patt< $lid:id$ >> -> (id, MLast.loc_of_patt x1) | _ -> not_impl loc "clause 1" ] in (x1, x2, x3, x4) ] ] ; tb: [ [ x1 = tyvars; x2 = idd; "="; x3 = ctyp -> ((loc, uncap x2), x1, x3, []) | x1 = tyvars; x2 = idd; "="; x3 = ctyp; "=="; x4 = dbrhs -> let x4 = List.map (fun (loc, c, tl, _) -> (loc, c, tl)) x4 in ((loc, uncap x2), x1, <:ctyp< $x3$ == [ $list:x4$ ] >>, []) ] ] ; tyvars: [ [ "'"; x1 = LIDENT -> [(x1, (False, False))] | "("; x1 = tyvar_pc; ")" -> x1 | -> [] ] ] ; db1: [ [ x1 = tyvars; x2 = ident; "="; x3 = dbrhs -> let x2 = uncap x2 in extract_label_types loc x2 x1 x3 | "lazy"; x1 = tyvars; x2 = ident; "="; x3 = dbrhs -> not_impl loc "db 2" ] ] ; db: [ [ x1 = LIST1 db1 SEP "and" -> List.fold_right (fun td tdl -> td @ tdl) x1 [] ] ] ; dbrhs: [ [ x1 = LIST1 constr SEP "|" -> x1 | "datatype"; x1 = tycon -> not_impl loc "dbrhs 2" ] ] ; constr: [ [ x1 = op_op; x2 = ident -> (loc, x2, [], None) | x1 = op_op; x2 = ident; "of"; x3 = ctyp -> match x3 with [ <:ctyp< {$list:_$} >> -> (loc, x2, [], Some x3) | _ -> (loc, x2, [x3], None) ] ] ] ; eb: [ [ x1 = op_op; x2 = ident -> (x2, [], []) | x1 = op_op; x2 = ident; "of"; x3 = ctyp -> (x2, [x3], []) | x1 = op_op; x2 = ident; "="; x3 = sqid -> (x2, [], x3) ] ] ; ldec1: [ [ "val"; x1 = LIST1 vb SEP "and" -> x1 | "fun"; x1 = LIST1 fb SEP "and" -> x1 ] ] ; ldecs: [ [ -> [] | x1 = ldec1; x2 = ldecs -> [x1 :: x2] | ";"; x1 = ldecs -> x1 | "local"; x1 = ldecs; "in"; x2 = ldecs; "end"; x3 = ldecs -> not_impl loc "ldecs 4" ] ] ; spec_s: [ [ -> [] | x1 = spec; x2 = spec_s -> [x1 :: x2] | ";"; x1 = spec_s -> x1 ] ] ; spec: [ [ "structure"; x1 = LIST1 strspec SEP "and" -> sig_declare loc x1 | "functor"; x1 = LIST1 fctspec SEP "and" -> sig_declare loc x1 | "datatype"; x1 = db -> <:sig_item< type $list:x1$ >> | "type"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >> | "eqtype"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >> | "val"; x1 = LIST1 valspec SEP "and" -> sig_declare loc x1 | "exception"; x1 = LIST1 exnspec SEP "and" -> sig_declare loc x1 | "sharing"; x1 = LIST1 sharespec SEP "and" -> <:sig_item< declare end >> | "include"; x1 = module_type -> <:sig_item< include $x1$ >> ] ] ; sig_item: [ [ x = spec -> x ] ] ; strspec: [ [ x1 = ident; ":"; x2 = module_type; x3 = LIST0 sharing_def -> let x2 = List.fold_left (fun mt sdl -> List.fold_right (fun spl mt -> match spl with [ Right ([m1], m2) -> let (m1, m2) = match m2 with [ <:module_expr< $uid:x$ . $_$ >> -> if x = x1 then (m2, m1) else (m1, m2) | _ -> (m1, m2) ] in let m1 = loop m1 where rec loop = fun [ <:module_expr< $uid:x$ >> -> x | <:module_expr< $uid:x$ . $y$ >> -> loop y | _ -> not_impl loc "strspec 2" ] in <:module_type< $mt$ with module $[m1]$ = $m2$ >> | _ -> not_impl loc "strspec 1" ]) sdl mt) x2 x3 in <:sig_item< module $x1$ : $x2$ >> ] ] ; sharing_def: [ [ "sharing"; x3 = LIST1 sharespec SEP "and" -> x3 ] ] ; fctspec: [ [ x1 = ident; x2 = fsig -> <:sig_item< module $x1$ : $x2$ >> ] ] ; tyspec: [ [ x1 = tyvars; x2 = idd -> ((loc, uncap x2), x1, <:ctyp< '$choose_tvar x1$ >>, []) | x1 = tyvars; x2 = idd; "="; x3 = ctyp -> ((loc, uncap x2), x1, x3, []) ] ] ; valspec: [ [ x1 = op_op; x2 = ident; ":"; x3 = ctyp -> <:sig_item< value $x2$ : $x3$ >> ] ] ; exnspec: [ [ x1 = ident -> <:sig_item< exception $x1$ >> | x1 = ident; "of"; x2 = ctyp -> <:sig_item< exception $x1$ of $x2$ >> ] ] ; sharespec: [ [ "type"; x1 = patheqn -> Left x1 | x1 = patheqn -> Right x1 ] ] ; patheqn: [ [ l = patheqn1 -> l ] ] ; patheqn1: [ [ (l, y) = patheqn1; "="; x = qid -> ([y :: l], x) | x = qid -> ([], x) ] ] ; whspec: [ [ "type"; x1 = tyvars; x2 = sqid; "="; x3 = ctyp -> MLast.WcTyp loc x2 x1 x3 | x1 = sqid; "="; x2 = qid -> MLast.WcMod loc x1 x2 ] ] ; module_type: [ [ x1 = ident -> <:module_type< $uid:x1$ >> | "sig"; x1 = spec_s; "end" -> <:module_type< sig $list:x1$ end >> | x1 = module_type; "where"; x2 = LIST1 whspec SEP "and" -> <:module_type< $x1$ with $list:x2$ >> ] ] ; sigconstraint_op: [ [ -> None | ":"; x1 = module_type -> Some x1 | ":>"; x1 = module_type -> not_impl loc "sigconstraint_op 3" ] ] ; sigb: [ [ x1 = ident; "="; x2 = module_type -> <:str_item< module type $x1$ = $x2$ >> ] ] ; fsig: [ [ ":"; x1 = ident -> not_impl loc "fsig 1" | x1 = fparamList; ":"; x2 = module_type -> not_impl loc "fsig 2" ] ] ; module_expr: [ [ x1 = qid -> x1 | "struct"; x1 = strdecs; "end" -> <:module_expr< struct $list:x1$ end >> | x1 = qid; x2 = arg_fct -> match x2 with [ Left [] -> x1 | Left x2 -> <:module_expr< $x1$ (struct $list:x2$ end) >> | Right x2 -> <:module_expr< $x1$ $x2$ >> ] | "let"; x1 = strdecs; "in"; x2 = module_expr; "end" -> not_impl loc "str 4" | x1 = module_expr; ":"; x2 = module_type -> not_impl loc "str 5" | x1 = module_expr; x2 = ":>"; x3 = module_type -> not_impl loc "str 6" ] ] ; arg_fct: [ [ "("; x1 = strdecs; ")"; x2 = arg_fct -> not_impl loc "arg_fct 1" | "("; x1 = module_expr; ")"; x2 = arg_fct -> not_impl loc "arg_fct 2" | "("; x1 = module_expr; ")" -> Right x1 | "("; x2 = strdecs; ")" -> Left x2 ] ] ; strdecs: [ [ x1 = str_item LEVEL "strdec"; x2 = strdecs -> [x1 :: x2] | ";"; x1 = strdecs -> x1 | -> [] ] ] ; str_item: [ [ "signature"; x1 = LIST1 sigb SEP "and" -> str_declare loc x1 | "funsig"; x1 = fsigb -> not_impl loc "sdec 3" ] | "strdec" [ "structure"; x1 = LIST1 strb SEP "and" -> str_declare loc x1 | "functor"; x1 = LIST1 fctb SEP "and" -> str_declare loc x1 | "local"; x1 = sdecs; "in"; x2 = sdecs; "end" -> make_local loc x1 x2 ] | [ "val"; x1 = LIST1 vb SEP "and" -> <:str_item< value $list:x1$ >> | "val"; x1 = tyvarseq; x3 = LIST1 vb SEP "and" -> not_impl loc "ldec 2" | "val"; "rec"; x1 = rvb -> not_impl loc "ldec 3" | "val"; "rec"; x1 = tyvarseq; x2 = rvb -> not_impl loc "ldec 4" | "fun"; x1 = LIST1 fb SEP "and" -> <:str_item< value rec $list:x1$ >> | "fun"; x1 = tyvarseq; x2 = fb -> not_impl loc "ldec 6" | "type"; x1 = LIST1 tb SEP "and" -> <:str_item< type $list:x1$ >> | "datatype"; x1 = db -> <:str_item< type $list:x1$ >> | "datatype"; x1 = db; "withtype"; x2 = tb -> <:str_item< type $list:x1 @ [x2]$ >> | "abstype"; x1 = db; "with"; x2 = ldecs; "end" -> not_impl loc "ldec 10" | "abstype"; x1 = db; "withtype"; x2 = tb; "with"; x3 = ldecs; "end" -> not_impl loc "ldec 11" | "exception"; x1 = LIST1 eb SEP "and" -> let dl = List.map (fun (s, tl, eqn) -> <:str_item< exception $s$ of $list:tl$ = $eqn$ >>) x1 in str_declare loc dl | "open"; x1 = LIST1 sqid -> let dl = List.map (fun sl -> <:str_item< open $sl$ >>) x1 in str_declare loc dl | LIDENT "use"; s = STRING -> <:str_item< #use $str:s$ >> | x1 = fixity; list = LIST1 idd -> match x1 with [ ("infixr", Some n) -> do { List.iter (fun s -> EXTEND expr: LEVEL $n$ [ [ x1 = expr; $s$; x2 = expr -> <:expr< $lid:s$ ($x1$, $x2$) >> ] ] ; END) list; str_declare loc [] } | ("infix", None) -> do { List.iter (fun s -> EXTEND expr: LEVEL "4" [ [ x1 = expr; $s$; x2 = expr -> <:expr< $lid:s$ ($x1$, $x2$) >> ] ] ; clause: [ [ x1 = patt LEVEL "apat"; $s$; x2 = patt LEVEL "apat"; "="; x4 = expr -> ((s, loc), [<:patt< ($x1$, $x2$) >>], None, x4) ] ] ; END) list; str_declare loc [] } | _ -> not_impl loc "ldec 14" ] | "overload"; x1 = ident; ":"; x2 = ctyp; "as"; x3 = exp_pa -> not_impl loc "ldec 15" | x = expr -> <:str_item< $exp:x$ >> ] ] ; sdec: [ [ x = str_item -> x ] ] ; strb: [ [ x1 = ident; x2 = sigconstraint_op; "="; x3 = module_expr -> let x3 = match x2 with [ Some x2 -> <:module_expr< ($x3$ : $x2$) >> | None -> x3 ] in <:str_item< module $x1$ = $x3$ >> ] ] ; fparam: [ [ x1 = idd; ":"; x2 = module_type -> [<:sig_item< module $x1$ : $x2$ >>] | x1 = spec_s -> x1 ] ] ; fparamList: [ [ "("; x1 = fparam; ")" -> [x1] | "("; x1 = fparam; ")"; x2 = fparamList -> [x1 :: x2] ] ] ; fctb: [ [ x1 = ident; x2 = fparamList; x3 = sigconstraint_op; "="; x4 = module_expr -> let list = List.flatten x2 in let x4 = if list = [] then x4 else match x4 with [ <:module_expr< struct $list:list$ end >> -> let si = let loc = (Token.nowhere, Token.nowhere) in <:str_item< open AAA >> in <:module_expr< struct $list:[si :: list]$ end >> | _ -> not_impl loc "fctb 1" ] in let x4 = match x3 with [ Some x3 -> <:module_expr< ($x4$ : $x3$) >> | None -> x4 ] in let x4 = if list = [] then x4 else let mt = let loc = (fst (MLast.loc_of_sig_item (List.hd list)), snd (MLast.loc_of_sig_item (List.hd (List.rev list)))) in <:module_type< sig $list:list$ end >> in <:module_expr< functor (AAA : $mt$) -> $x4$ >> in <:str_item< module $x1$ = $x4$ >> | x1 = ident; x2 = fsigconstraint_op; "="; x3 = fct_exp -> not_impl loc "fctb 2" ] ] ; interdec: [ [ x = LIST1 [ s = str_item; OPT ";" -> (s, loc) ] -> (x, False) | x = expr; OPT ";" -> not_impl loc "interdec 2" ] ] ; END; Pcaml.add_option "-records" (Arg.Set ocaml_records) "Convert record into OCaml records, instead of objects"; mingw-ocaml/ocaml/camlp4/unmaintained/sml/README0000644000175000017500000000104312124403240020762 0ustar tootstootsThis is an application of or an extension for Camlp4. Although it is currently distributed with OCaml/Camlp4, it may or may not be actively maintained. It probably won't be part of future OCaml/Camlp4 distributions but be accessible from the Camlp4 hump. If you are interested in developing this package further and/or actively maintain it, please let us know (caml@inria.fr) This package is distributed under the same license as the OCaml Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny mingw-ocaml/ocaml/camlp4/unmaintained/sml/.depend0000644000175000017500000000000012124403240021332 0ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/sml/smllib.sml0000644000175000017500000002672112124403240022113 0ustar tootstoots(***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) datatype 'a option = SOME of 'a | NONE exception Fail of string exception Domain exception Subscript type 'a vector = 'a array structure OCaml = struct structure List = List structure String = String end structure Time = struct datatype time = TIME of { sec : int, usec : int } fun toString _ = failwith "not implemented Time.toString" fun now _ = failwith "not implemented Time.now" end datatype cpu_timer = CPUT of { gc : Time.time, sys : Time.time, usr : Time.time } datatype real_timer = RealT of Time.time structure Char = struct val ord = Char.code end structure General = struct datatype order = LESS | EQUAL | GREATER end type order = General.order == LESS | EQUAL | GREATER structure OS = struct exception SysErr structure Path = struct fun dir s = let val r = Filename.dirname s in if r = "." then "" else r end val file = Filename.basename fun ext s = let fun loop i = if i < 0 then NONE else if String.get s i = #"." then let val len = String.length s - i - 1 in if len = 0 then NONE else SOME (String.sub s (i + 1) len) end else loop (i - 1) in loop (String.length s - 1) end fun splitDirFile s = {dir = Filename.dirname s, file = Filename.basename s} fun joinDirFile x = let val {dir,file} = x in Filename.concat dir file end end structure FileSys = struct datatype access_mode = A_READ | A_WRITE | A_EXEC val chDir = Sys.chdir fun isDir s = (Unix.stat s) ocaml_record_access Unix.st_kind = Unix.S_DIR handle Unix.Unix_error _ => raise SysErr fun access (s, accs) = let val st = Unix.stat s val prm = st ocaml_record_access Unix.st_perm val prm = if st ocaml_record_access Unix.st_uid = Unix.getuid () then lsr prm 6 else if st ocaml_record_access Unix.st_uid = Unix.getgid () then lsr prm 3 else prm val rf = if List.mem A_READ accs then land prm 4 <> 0 else true val wf = if List.mem A_WRITE accs then land prm 2 <> 0 else true val xf = if List.mem A_EXEC accs then land prm 1 <> 0 else true in rf andalso wf andalso xf end handle Unix.Unix_error (_, f, _) => if f = "stat" then false else raise SysErr end structure Process = struct fun system s = (flush stdout; flush stderr; Sys.command s) fun getEnv s = SOME (Sys.getenv s) handle Not_found => NONE val success = 0 end end exception SysErr = OS.SysErr structure IO = struct exception Io of {cause:exn, function:string, name:string} end structure TextIO = struct type instream = in_channel * char option option ref type outstream = out_channel type elem = char type vector = string fun openIn fname = (open_in fname, ref NONE) handle exn => raise IO.Io {cause = exn, function = "openIn", name = fname} val openOut = open_out fun closeIn (ic, ahc) = (ahc := SOME NONE; close_in ic) val closeOut = close_out val stdIn = (stdin, ref (NONE : char option option)) fun endOfStream (ic, _) = pos_in ic = in_channel_length ic fun inputLine (ic, ahc) = case !ahc of NONE => (input_line ic ^ "\n" handle End_of_file => (ahc := SOME NONE; "")) | SOME NONE => "" | SOME (SOME c) => (ahc := NONE; if c = #"\n" then "\n" else String.make 1 c ^ input_line ic ^ "\n" handle End_of_file => (ahc := SOME NONE; "")) fun input1 (ic, ahc) = case !ahc of NONE => (SOME (input_char ic) handle End_of_file => (ahc := SOME NONE; NONE)) | SOME NONE => NONE | SOME x => (ahc := NONE; x) fun inputN (ins, n) = let fun loop n = if n <= 0 then "" else case input1 ins of SOME c => String.make 1 c ^ loop (n - 1) | NONE => "" in loop n end fun output (oc, v) = output_string oc v fun inputAll ic = failwith "not implemented TextIO.inputAll" fun lookahead (ic, ahc) = case !ahc of NONE => let val r = SOME (input_char ic) in ahc := SOME r; r end | SOME x => x fun print s = (print_string s; flush stdout) end structure Timer = struct fun startRealTimer () = failwith "not implemented Timer.startRealTimer" fun startCPUTimer () = failwith "not implemented Timer.startCPUTimer" fun checkRealTimer _ = failwith "not implemented Timer.checkRealTimer" fun checkCPUTimer _ = failwith "not implemented Timer.checkCPUTimer" end structure Date = struct datatype month = Jan | Feb | Mar | Apr | May | Jun | Jul | Sep | Oct | Nov | Dec datatype wday = Sun | Mon | Tue | Wed | Thu | Fri | Sat datatype date = DATE of {day : int, hour : int, isDst : bool option, minute : int, month : month, offset : int option, second : int, wday : wday, yday : int, year : int} fun fmt _ _ = failwith "not implemented Date.fmt" fun fromTimeLocal _ = failwith "not implemented Date.fromTimeLocal" end structure Posix = struct structure ProcEnv = struct fun getenv s = SOME (Sys.getenv s) handle Not_found => NONE end end structure SMLofNJ = struct fun exportML s = failwith ("not implemented exportML " ^ s) end fun null x = x = [] fun explode s = let fun loop i = if i = String.length s then [] else String.get s i :: loop (i + 1) in loop 0 end val app = List.iter fun implode [] = "" | implode (c :: l) = String.make 1 c ^ implode l fun ooo f g x = f (g x) structure Array = struct fun array (len, v) = Array.create len v fun sub _ = failwith "not implemented Array.sub" fun update _ = failwith "not implemented Array.update" (* for make the profiler work *) val set = Array.set val get = Array.get end structure Vector = struct fun tabulate _ = failwith "not implemented Vector.tabulate" fun sub _ = failwith "not implemented Vector.sub" end structure Bool = struct val toString = string_of_bool end structure String = struct val size = String.length fun substring (s, beg, len) = String.sub s beg len handle Invalid_argument _ => raise Subscript val concat = String.concat "" fun sub (s, i) = String.get s i val str = String.make 1 fun compare (s1, s2) = if s1 < s2 then LESS else if s1 > s2 then GREATER else EQUAL fun isPrefix s1 s2 = let fun loop i1 i2 = if i1 >= String.length s1 then true else if i2 >= String.length s2 then false else if String.get s1 i1 = String.get s2 i2 then loop (i1 + 1) (i2 + 1) else false in loop 0 0 end fun tokens p s = let fun loop tok i = if i >= String.length s then if tok = "" then [] else [tok] else if p (String.get s i) then if tok <> "" then tok :: loop "" (i + 1) else loop "" (i + 1) else loop (tok ^ String.make 1 (String.get s i)) (i + 1) in loop "" 0 end fun extract _ = failwith "not implemented String.extract" end structure Substring = struct type substring = string * int * int fun string (s : substring) = String.substring s fun all s : substring = (s, 0, String.size s) fun splitl f ((s, beg, len) : substring) : substring * substring = let fun loop di = if di = len then ((s, beg, len), (s, 0, 0)) else if f (String.sub (s, beg + di)) then loop (di + 1) else ((s, beg, di), (s, beg + di, len - di)) in loop 0 end fun getc (s, i, len) = if len > 0 andalso i < String.size s then SOME (String.sub (s, i), (s, i+1, len-1)) else NONE fun slice _ = failwith "not implemented: Substring.slice" fun isEmpty (s, beg, len) = len = 0 fun concat sl = String.concat (List.map string sl) end type substring = Substring.substring structure StringCvt = struct datatype radix = BIN | OCT | DEC | HEX type ('a, 'b) reader = 'b -> ('a * 'b) option end structure ListPair = struct fun zip (a1::l1, a2::l2) = (a1, a2) :: zip (l1, l2) | zip _ = [] val unzip = List.split fun all f (x1 :: l1, x2 :: l2) = f (x1, x2) andalso all f (l1, l2) | all _ _ = true fun map f (a1::l1, a2::l2) = let val r = f (a1, a2) in r :: map f (l1, l2) end | map _ _ = [] end structure ListMergeSort = struct fun uniqueSort cmp l = List.sort (fn x => fn y => case cmp (x, y) of LESS => ~1 | EQUAL => 0 | GREATER => 1) l end structure List = struct exception Empty fun hd [] = raise Empty | hd (x :: l) = x fun tl [] = raise Empty | tl (x :: l) = l fun foldr f a l = let fun loop a [] = a | loop a (x :: l) = loop (f (x, a)) l in loop a (List.rev l) end fun foldl f a l = List.fold_left (fn a => fn x => f (x, a)) a l val concat = List.flatten val exists = List.exists val filter = List.filter val length = List.length val map = List.map val rev = List.rev val all = List.for_all fun find f [] = NONE | find f (x :: l) = if f x then SOME x else find f l fun last s = case List.rev s of [] => raise Empty | x :: _ => x fun take _ = failwith "not implemented: List.take" fun partition _ = failwith "not implemented: List.partition" fun mapPartial f [] = [] | mapPartial f (x :: l) = case f x of NONE => mapPartial f l | SOME y => y :: mapPartial f l fun op @ l1 l2 = List.rev_append (List.rev l1) l2 end structure Int = struct type int1 = int type int = int1 val toString = string_of_int fun fromString s = SOME (int_of_string s) handle Failure _ => NONE fun min (x, y) = if x < y then x else y fun max (x, y) = if x > y then x else y fun scan radix getc src = failwith "not impl: Int.scan" end val foldr = List.foldr val exists = List.exists val size = String.size val substring = String.substring val concat = String.concat val length = List.length val op @ = List.op @ val hd = List.hd val tl = List.tl val map = List.map val rev = List.rev val use_hook = ref (fn (s : string) => (failwith "no defined directive use" : unit)) fun use s = !use_hook s fun isSome (SOME _) = true | isSome NONE = false fun valOf (SOME x) = x | valOf NONE = failwith "valOf" val print = TextIO.print mingw-ocaml/ocaml/camlp4/unmaintained/ocpp/0000755000175000017500000000000012124403240020252 5ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/ocpp/.ignore0000644000175000017500000000001412124403240021531 0ustar tootstootsocpp crc.ml mingw-ocaml/ocaml/camlp4/unmaintained/ocpp/Makefile0000644000175000017500000000124612124403240021715 0ustar tootstoots include ../config/Makefile.cnf EXECUTABLES=ocpp OBJS=ocpp.cmo INCLUDES=-I ../camlp4 -I ../lib -I ../odyl -I $(OTOP)/otherlibs/dynlink OCPPM=../lib/debug.cmo ../lib/loc.cmo ../lib/stdpp.cmo ../camlp4/quotation.cmo include ../config/Makefile.base ocpp$(EXE): $(OBJS) $(OCAMLC) $(LINKFLAGS) $(OCPPM) ../odyl/odyl.cma $(OBJS) ../odyl/odyl.cmo -linkall -o $@ ocpp.opt: $(OBJSX) $(OCAMLOPT) $(LINKFLAGS) $(OCPPM:.cmo=.cmx) ../odyl/odyl.cmxa $(OBJSX) ../odyl/odyl.cmx -linkall -o $@ install-local: -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" cp $(OBJS) "$(LIBDIR)/camlp4/." cp ocpp$(EXE) "$(BINDIR)/." if test -f ocpp.opt ; then \ cp ocpp.opt "$(LIBDIR)/camlp4/." ; \ fi mingw-ocaml/ocaml/camlp4/unmaintained/ocpp/ocpp.ml0000644000175000017500000001005112124403240021542 0ustar tootstoots(* camlp4r *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* Automatique. Distributed only by permission. *) (* *) (***********************************************************************) value buff = ref (String.create 80); value store len x = do { if len >= String.length buff.val then buff.val := buff.val ^ String.create (String.length buff.val) else (); buff.val.[len] := x; succ len } ; value get_buff len = String.sub buff.val 0 len; value rec copy_strip_locate cs = match cs with parser [ [: `'$' :] -> maybe_locate cs | [: `c :] -> do { print_char c; copy_strip_locate cs } | [: :] -> () ] and maybe_locate cs = match cs with parser [ [: `'1'..'9' :] -> locate cs | [: :] -> do { print_char '$'; copy_strip_locate cs } ] and locate cs = match cs with parser [ [: `'0'..'9' :] -> locate cs | [: `':' :] -> inside_locate cs | [: :] -> raise (Stream.Error "colon char expected") ] and inside_locate cs = match cs with parser [ [: `'$' :] -> copy_strip_locate cs | [: `'\\'; `c :] -> do { print_char c; inside_locate cs } | [: `c :] -> do { print_char c; inside_locate cs } | [: :] -> raise (Stream.Error "end of file in locate directive") ] ; value file = ref ""; value quot name loc str = let loc = Loc.move `stop (String.length str) loc in let exp = try match Quotation.find name with [ Quotation.ExStr f -> f | _ -> raise Not_found ] with [ Not_found -> Stdpp.raise_with_loc loc Not_found ] in let new_str = try exp True { Quotation.loc = Loc.mk file.val ; loc_name_opt = None } str with [ Loc.Exc_located loc exc -> Stdpp.raise_with_loc loc exc | exc -> Stdpp.raise_with_loc loc exc ] in let cs = Stream.of_string new_str in copy_strip_locate cs ; value rec ident len = parser [ [: `('A'..'Z' | 'a'..'z' | '0'..'9' | '_' | ''' as c); s :] -> ident (store len c) s | [: :] -> get_buff len ] ; value loc_of_ep ep = Loc.set_all `start 1 0 ep (Loc.mk file.val); value rec copy cs = match cs with parser [ [: `'<' :] -> maybe_quot cs | [: `'"' :] -> do { print_char '"'; inside_string cs } | [: `c :] -> do { print_char c; copy cs } | [: :] -> () ] and maybe_quot cs = match cs with parser [ [: `'<' :] ep -> inside_quot "" (loc_of_ep ep) 0 cs | [: `':'; i = ident 0; `'<' ?? "less char expected" :] ep -> inside_quot i (loc_of_ep ep) 0 cs | [: :] -> do { print_char '<'; copy cs } ] and inside_quot name loc len cs = match cs with parser [ [: `'>' :] -> maybe_end_quot name loc len cs | [: `c :] -> inside_quot name loc (store len c) cs | [: :] -> raise (Stream.Error "end of file in quotation") ] and maybe_end_quot name loc len cs = match cs with parser [ [: `'>' :] -> do { quot name loc (get_buff len); copy cs } | [: :] -> inside_quot name loc (store len '>') cs ] and inside_string cs = match cs with parser [ [: `'"' :] -> do { print_char '"'; copy cs } | [: `c :] -> do { print_char c; inside_string cs } | [: :] -> raise (Stream.Error "end of file in string") ] ; value copy_quot cs = do { copy cs; flush stdout; }; Arg.parse [] (fun x -> file.val := x) "ocpp "; value main () = try if file.val <> "" then copy_quot (Stream.of_channel (open_in_bin file.val)) else () with exc -> do { Format.printf "@."; raise (match exc with [ Loc.Exc_located loc exc -> do { Format.eprintf "%a@." Loc.print loc; exc } | exc -> exc ]) } ; Odyl_main.name.val := "ocpp"; Odyl_main.go.val := main; mingw-ocaml/ocaml/camlp4/unmaintained/ocpp/.depend0000644000175000017500000000000012124403240021500 0ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/ocamllex/0000755000175000017500000000000012124403240021115 5ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/ocamllex/Makefile0000644000175000017500000000411112124403240022552 0ustar tootstoots######################################################################### # # # OCaml # # # # Camlp4 # # # # Copyright 2004 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../../LICENSE.# # # ######################################################################### # # Makefile for pa_ocamllex # M.Mauny # include ../../config/Makefile.cnf OCAMLTOP=../../.. CAMLP4=../../camlp4/camlp4$(EXE) OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) P4INCLUDES= -nolib -I ../../etc -I ../../meta OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../camlp4 -I ../../lib -I $(OCAMLTOP)/lex OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) SRC=pa_ocamllex.ml OBJS=pa_ocamllex.cmo OBJSX=$(OBJS:.cmo=.cmx) all: $(OBJS) pa_ocamllex.cma opt: $(OBJSX) pa_ocamllex.cmxa pa_ocamllex.cma: pa_ocamllex.cmo $(OCAMLC) $(OCAMLCFLAGS) cset.cmo syntax.cmo table.cmo lexgen.cmo compact.cmo pa_ocamllex.cmo -a -o pa_ocamllex.cma pa_ocamllex.cmxa: pa_ocamllex.cmo $(OCAMLOPT) $(OCAMLCFLAGS) cset.cmx syntax.cmx table.cmx lexgen.cmx compact.cmx pa_ocamllex.cmx -a -o pa_ocamllex.cmxa clean: rm -f *.cm* *.$(O) *.$(A) *.bak .*.bak depend: .SUFFIXES: .cmx .cmo .cmi .ml .mli .mli.cmi: $(OCAMLC) $(OCAMLCFLAGS) -c $< .ml.cmo: $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< .ml.cmx: $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< mingw-ocaml/ocaml/camlp4/unmaintained/ocamllex/README0000644000175000017500000000104312124403240021773 0ustar tootstootsThis is an application of or an extension for Camlp4. Although it is currently distributed with OCaml/Camlp4, it may or may not be actively maintained. It probably won't be part of future OCaml/Camlp4 distributions but be accessible from the Camlp4 hump. If you are interested in developing this package further and/or actively maintain it, please let us know (caml@inria.fr) This package is distributed under the same license as the OCaml Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny mingw-ocaml/ocaml/camlp4/unmaintained/ocamllex/pa_ocamllex.ml0000644000175000017500000002655212124403240023745 0ustar tootstoots(* pa_o.cmo q_MLast.cmo pa_extend.cmo pr_dump.cmo *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Alain Frisch, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file *) (* ../../../LICENSE. *) (* *) (***********************************************************************) open Syntax open Lexgen open Compact (* Adapted from output.ml *) (**************************) (* Output the DFA tables and its entry points *) (* To output an array of short ints, encoded as a string *) let output_byte buf b = Buffer.add_char buf '\\'; Buffer.add_char buf (Char.chr(48 + b / 100)); Buffer.add_char buf (Char.chr(48 + (b / 10) mod 10)); Buffer.add_char buf (Char.chr(48 + b mod 10)) let loc = (Lexing.dummy_pos,Lexing.dummy_pos) let output_array v = let b = Buffer.create (Array.length v * 3) in for i = 0 to Array.length v - 1 do output_byte b (v.(i) land 0xFF); output_byte b ((v.(i) asr 8) land 0xFF); if i land 7 = 7 then Buffer.add_string b "\\\n " done; let s = Buffer.contents b in <:expr< $str:s$ >> let output_byte_array v = let b = Buffer.create (Array.length v * 2) in for i = 0 to Array.length v - 1 do output_byte b (v.(i) land 0xFF); if i land 15 = 15 then Buffer.add_string b "\\\n " done; let s = Buffer.contents b in <:expr< $str:s$ >> (* Output the tables *) let output_tables tbl = <:str_item< value lex_tables = { Lexing.lex_base = $output_array tbl.tbl_base$; Lexing.lex_backtrk = $output_array tbl.tbl_backtrk$; Lexing.lex_default = $output_array tbl.tbl_default$; Lexing.lex_trans = $output_array tbl.tbl_trans$; Lexing.lex_check = $output_array tbl.tbl_check$; Lexing.lex_base_code = $output_array tbl.tbl_base_code$; Lexing.lex_backtrk_code = $output_array tbl.tbl_backtrk_code$; Lexing.lex_default_code = $output_array tbl.tbl_default_code$; Lexing.lex_trans_code = $output_array tbl.tbl_trans_code$; Lexing.lex_check_code = $output_array tbl.tbl_check_code$; Lexing.lex_code = $output_byte_array tbl.tbl_code$ } >> (* Output the entries *) let rec make_alias n = function | [] -> [] | h::t -> (h, "__ocaml_lex_arg_" ^ (string_of_int n)) :: (make_alias (succ n) t) let abstraction = List.fold_right (fun (p,a) e -> <:expr< fun ($p$ as $lid:a$) -> $e$ >>) let application = List.fold_left (fun f (_,a) -> <:expr< $f$ $lid:a$ >>) let int i = <:expr< $int:string_of_int i$ >> let output_memory_actions acts = let aux = function | Copy (tgt, src) -> <:expr< lexbuf.Lexing.lex_mem.($int tgt$) := lexbuf.Lexing.lex_mem.($int src$) >> | Set tgt -> <:expr< lexbuf.Lexing.lex_mem.($int tgt$) := lexbuf.Lexing.lex_curr_pos >> in <:expr< do { $list:List.map aux acts$ } >> let output_base_mem = function | Mem i -> <:expr< lexbuf.Lexing.lex_mem.($int i$) >> | Start -> <:expr< lexbuf.Lexing.lex_start_pos >> | End -> <:expr< lexbuf.Lexing.lex_curr_pos >> let output_tag_access = function | Sum (a,0) -> output_base_mem a | Sum (a,i) -> <:expr< $output_base_mem a$ + $int i$ >> let rec output_env e = function | [] -> e | (x, Ident_string (o,nstart,nend)) :: rem -> <:expr< let $lid:x$ = Lexing.$lid:if o then "sub_lexeme_opt" else "sub_lexeme"$ lexbuf $output_tag_access nstart$ $output_tag_access nend$ in $output_env e rem$ >> | (x, Ident_char (o,nstart)) :: rem -> <:expr< let $lid:x$ = Lexing.$lid: if o then "sub_lexeme_char_opt" else "sub_lexeme_char"$ lexbuf $output_tag_access nstart$ in $output_env e rem$ >> let output_entry e = let init_num, init_moves = e.auto_initial_state in let args = make_alias 0 (e.auto_args @ [ <:patt< lexbuf >> ]) in let f = "__ocaml_lex_rec_" ^ e.auto_name ^ "_rec" in let call_f = application <:expr< $lid:f$ >> args in let body_wrapper = <:expr< do { lexbuf.Lexing.lex_mem := Array.create $int e.auto_mem_size$ (-1) ; $output_memory_actions init_moves$; $call_f$ $int init_num$ } >> in let cases = List.map (fun (num, env, (loc,e)) -> <:patt< $int:string_of_int num$ >>, None, output_env <:expr< $e$ >> env (* Note: the <:expr<...>> above is there to set the location *) ) e.auto_actions @ [ <:patt< __ocaml_lex_n >>, None, <:expr< do { lexbuf.Lexing.refill_buff lexbuf; $call_f$ __ocaml_lex_n }>> ] in let engine = if e.auto_mem_size = 0 then <:expr< Lexing.engine >> else <:expr< Lexing.new_engine >> in let body = <:expr< fun state -> match $engine$ lex_tables state lexbuf with [ $list:cases$ ] >> in [ <:patt< $lid:e.auto_name$ >>, (abstraction args body_wrapper); <:patt< $lid:f$ >>, (abstraction args body) ] (* Main output function *) exception Table_overflow let output_lexdef tables entry_points = Printf.eprintf "pa_ocamllex: lexer found; %d states, %d transitions, table size %d bytes\n" (Array.length tables.tbl_base) (Array.length tables.tbl_trans) (2 * (Array.length tables.tbl_base + Array.length tables.tbl_backtrk + Array.length tables.tbl_default + Array.length tables.tbl_trans + Array.length tables.tbl_check)); let size_groups = (2 * (Array.length tables.tbl_base_code + Array.length tables.tbl_backtrk_code + Array.length tables.tbl_default_code + Array.length tables.tbl_trans_code + Array.length tables.tbl_check_code) + Array.length tables.tbl_code) in if size_groups > 0 then Printf.eprintf "pa_ocamllex: %d additional bytes used for bindings\n" size_groups ; flush stderr; if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow; let entries = List.map output_entry entry_points in [output_tables tables; <:str_item< value rec $list:List.flatten entries$ >> ] (* Adapted from parser.mly and main.ml *) (***************************************) (* Auxiliaries for the parser. *) let char s = Char.code (Token.eval_char s) let named_regexps = (Hashtbl.create 13 : (string, regular_expression) Hashtbl.t) let regexp_for_string s = let rec re_string n = if n >= String.length s then Epsilon else if succ n = String.length s then Characters (Cset.singleton (Char.code s.[n])) else Sequence (Characters(Cset.singleton (Char.code s.[n])), re_string (succ n)) in re_string 0 let char_class c1 c2 = Cset.interval c1 c2 let all_chars = Cset.all_chars let rec remove_as = function | Bind (e,_) -> remove_as e | Epsilon|Eof|Characters _ as e -> e | Sequence (e1, e2) -> Sequence (remove_as e1, remove_as e2) | Alternative (e1, e2) -> Alternative (remove_as e1, remove_as e2) | Repetition e -> Repetition (remove_as e) let () = Hashtbl.add named_regexps "eof" (Characters Cset.eof) (* The parser *) let let_regexp = Grammar.Entry.create Pcaml.gram "pa_ocamllex let" let header = Grammar.Entry.create Pcaml.gram "pa_ocamllex header" let lexer_def = Grammar.Entry.create Pcaml.gram "pa_ocaml lexerdef" EXTEND GLOBAL: Pcaml.str_item let_regexp header lexer_def; let_regexp: [ [ x = LIDENT; "="; r = regexp -> if Hashtbl.mem named_regexps x then Printf.eprintf "pa_ocamllex (warning): multiple definition of named regexp '%s'\n" x; Hashtbl.add named_regexps x r; ] ]; lexer_def: [ [ def = LIST0 definition SEP "and" -> (try let (entries, transitions) = make_dfa def in let tables = compact_tables transitions in let output = output_lexdef tables entries in <:str_item< declare $list: output$ end >> with |Table_overflow -> failwith "Transition table overflow in lexer, automaton is too big" | Lexgen.Memory_overflow -> failwith "Position memory overflow in lexer, too many as variables") ] ]; Pcaml.str_item: [ [ "pa_ocamllex"; LIDENT "rule"; d = lexer_def -> d | "pa_ocamllex"; "let"; let_regexp -> <:str_item< declare $list: []$ end >> ] ]; definition: [ [ x=LIDENT; pl = LIST0 Pcaml.patt LEVEL "simple"; "="; short=[ LIDENT "parse" -> false | LIDENT "shortest" -> true ]; OPT "|"; l = LIST0 [ r=regexp; a=action -> (r,a) ] SEP "|" -> { name=x ; shortest=short ; args=pl ; clauses = l } ] ]; action: [ [ "{"; e = OPT Pcaml.expr; "}" -> let e = match e with | Some e -> e | None -> <:expr< () >> in (loc,e) ] ]; header: [ [ "{"; e = LIST0 [ si = Pcaml.str_item; OPT ";;" -> si ]; "}" -> [<:str_item< declare $list:e$ end>>, loc] ] | [ -> [] ] ]; regexp: [ [ r = regexp; "as"; i = LIDENT -> Bind (r,i) ] | [ r1 = regexp; "|"; r2 = regexp -> Alternative(r1,r2) ] | [ r1 = regexp; r2 = regexp -> Sequence(r1,r2) ] | [ r = regexp; "*" -> Repetition r | r = regexp; "+" -> Sequence(Repetition (remove_as r), r) | r = regexp; "?" -> Alternative(Epsilon, r) | "("; r = regexp; ")" -> r | "_" -> Characters all_chars | c = CHAR -> Characters (Cset.singleton (char c)) | s = STRING -> regexp_for_string (Token.eval_string loc s) | "["; cc = ch_class; "]" -> Characters cc | x = LIDENT -> try Hashtbl.find named_regexps x with Not_found -> failwith ("pa_ocamllex (error): reference to unbound regexp name `"^x^"'") ] ]; ch_class: [ [ "^"; cc = ch_class -> Cset.complement cc] | [ c1 = CHAR; "-"; c2 = CHAR -> Cset.interval (char c1) (char c2) | c = CHAR -> Cset.singleton (char c) | cc1 = ch_class; cc2 = ch_class -> Cset.union cc1 cc2 ] ]; END (* We have to be careful about "rule"; in standalone mode, it is used as a keyword (otherwise, there is a conflict with named regexp); in normal mode, it is used as LIDENT (we do not want to reserve such an useful identifier). Plexer does not like identifiers used as keyword _and_ as LIDENT ... *) let standalone = let already = ref false in fun () -> if not (!already) then begin already := true; Printf.eprintf "pa_ocamllex: stand-alone mode\n"; DELETE_RULE Pcaml.str_item: "pa_ocamllex"; LIDENT "rule";lexer_def END; DELETE_RULE Pcaml.str_item: "pa_ocamllex"; "let"; let_regexp END; let ocamllex = Grammar.Entry.create Pcaml.gram "pa_ocamllex" in EXTEND GLOBAL: ocamllex let_regexp header lexer_def; ocamllex: [ [ h = header; l = [LIST0 ["let"; let_regexp]; "rule"; d = lexer_def -> (d,loc)]; t = header; EOI -> h @ (l :: t) ,false ] ]; END; Pcaml.parse_implem := Grammar.Entry.parse ocamllex end let () = Pcaml.add_option "-ocamllex" (Arg.Unit standalone) "Activate (standalone) ocamllex emulation mode." mingw-ocaml/ocaml/camlp4/unmaintained/lefteval/0000755000175000017500000000000012124403240021113 5ustar tootstootsmingw-ocaml/ocaml/camlp4/unmaintained/lefteval/Makefile0000644000175000017500000000372512124403240022562 0ustar tootstoots######################################################################### # # # OCaml # # # # Camlp4 # # # # Copyright 2004 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../../LICENSE.# # # ######################################################################### # # Makefile for pa_lefteval # M.Mauny # include ../../config/Makefile.cnf OCAMLTOP=../../.. CAMLP4=../../camlp4/camlp4$(EXE) OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) P4INCLUDES= -nolib -I ../../meta -I ../../etc OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../camlp4 OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) SRC=pa_lefteval.ml OBJS=$(SRC:.ml=.cmo) OBJSX=$(SRC:.ml=.cmx) all: $(OBJS) opt: $(OBJSX) depend: cp .depend .depend.bak > .depend for file in $(SRC); do \ $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ done clean: rm -f *.cm* *.$(O) *.bak .*.bak .SUFFIXES: .cmx .cmo .cmi .ml .mli .mli.cmi: $(OCAMLC) $(OCAMLCFLAGS) -c $< .ml.cmo: $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< .ml.cmx: $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< include .depend mingw-ocaml/ocaml/camlp4/unmaintained/lefteval/README0000644000175000017500000000104312124403240021771 0ustar tootstootsThis is an application of or an extension for Camlp4. Although it is currently distributed with OCaml/Camlp4, it may or may not be actively maintained. It probably won't be part of future OCaml/Camlp4 distributions but be accessible from the Camlp4 hump. If you are interested in developing this package further and/or actively maintain it, please let us know (caml@inria.fr) This package is distributed under the same license as the OCaml Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny mingw-ocaml/ocaml/camlp4/unmaintained/lefteval/pa_lefteval.ml0000644000175000017500000002147112124403240023734 0ustar tootstoots(* pa_r.cmo q_MLast.cmo pr_dump.cmo *) (***********************************************************************) (* *) (* Camlp4 *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file *) (* ../../../LICENSE. *) (* *) (***********************************************************************) value not_impl name x = let desc = if Obj.is_block (Obj.repr x) then "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) else "int_val = " ^ string_of_int (Obj.magic x) in failwith ("pa_lefteval: not impl: " ^ name ^ "; " ^ desc ^ ">") ; value rec expr_fa al = fun [ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f | f -> (f, al) ] ; (* generating let..in before functions calls which evaluates several (more than one) of their arguments *) value no_side_effects_ht = let ht = Hashtbl.create 73 in do { List.iter (fun s -> Hashtbl.add ht s True) ["<"; "="; "@"; "^"; "+"; "-"; "ref"]; ht } ; value no_side_effects = fun [ <:expr< $uid:_$ >> -> True | <:expr< $uid:_$ . $uid:_$ >> -> True | <:expr< $lid:s$ >> -> try Hashtbl.find no_side_effects_ht s with [ Not_found -> False ] | _ -> False ] ; value rec may_side_effect = fun [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $str:_$ >> | <:expr< $chr:_$ >> | <:expr< $int:_$ >> | <:expr< $flo:_$ >> | <:expr< $_$ . $_$ >> | <:expr< fun [ $list:_$ ] >> -> False | <:expr< ($list:el$) >> -> List.exists may_side_effect el | <:expr< $_$ $_$ >> as e -> let (f, el) = expr_fa [] e in not (no_side_effects f) || List.exists may_side_effect el | _ -> True ] ; value rec may_be_side_effect_victim = fun [ <:expr< $lid:_$ . $_$ >> -> True | <:expr< $uid:_$ . $e$ >> -> may_be_side_effect_victim e | _ -> False ] ; value rec may_depend_on_order el = loop False False el where rec loop side_effect_found side_effect_victim_found = fun [ [e :: el] -> if may_side_effect e then if side_effect_found || side_effect_victim_found then True else loop True True el else if may_be_side_effect_victim e then if side_effect_found then True else loop False True el else loop side_effect_found side_effect_victim_found el | [] -> False ] ; value gen_let_in loc expr el = let (pel, el) = loop 0 (List.rev el) where rec loop n = fun [ [e :: el] -> if may_side_effect e || may_be_side_effect_victim e then if n = 0 then let (pel, el) = loop 1 el in (pel, [expr e :: el]) else let id = "xxx" ^ string_of_int n in let (pel, el) = loop (n + 1) el in ([(<:patt< $lid:id$ >>, expr e) :: pel], [<:expr< $lid:id$ >> :: el]) else let (pel, el) = loop n el in (pel, [expr e :: el]) | [] -> ([], []) ] in match List.rev el with [ [e :: el] -> (pel, e, el) | _ -> assert False ] ; value left_eval_apply loc expr e1 e2 = let (f, el) = expr_fa [] <:expr< $e1$ $e2$ >> in if not (may_depend_on_order [f :: el]) then <:expr< $expr e1$ $expr e2$ >> else let (pel, e, el) = gen_let_in loc expr [f :: el] in let e = List.fold_left (fun e e1 -> <:expr< $e$ $e1$ >>) e el in List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel ; value left_eval_tuple loc expr el = if not (may_depend_on_order el) then <:expr< ($list:List.map expr el$) >> else let (pel, e, el) = gen_let_in loc expr el in List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) <:expr< ($list:[e :: el]$) >> pel ; value left_eval_record loc expr lel = let el = List.map snd lel in if not (may_depend_on_order el) then let lel = List.map (fun (p, e) -> (p, expr e)) lel in <:expr< { $list:lel$ } >> else let (pel, e, el) = gen_let_in loc expr el in let e = let lel = List.combine (List.map fst lel) [e :: el] in <:expr< { $list:lel$ } >> in List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel ; value left_eval_assign loc expr e1 e2 = <:expr< $e1$ := $expr e2$ >>; (* scanning the input tree, calling "left_eval_*" functions if necessary *) value map_option f = fun [ Some x -> Some (f x) | None -> None ] ; value class_infos f ci = {MLast.ciLoc = ci.MLast.ciLoc; MLast.ciVir = ci.MLast.ciVir; MLast.ciPrm = ci.MLast.ciPrm; MLast.ciNam = ci.MLast.ciNam; MLast.ciExp = f ci.MLast.ciExp} ; value rec expr x = let loc = MLast.loc_of_expr x in match x with [ <:expr< fun [ $list:pwel$ ] >> -> <:expr< fun [ $list:List.map match_assoc pwel$ ] >> | <:expr< match $e$ with [ $list:pwel$ ] >> -> <:expr< match $expr e$ with [ $list:List.map match_assoc pwel$ ] >> | <:expr< try $e$ with [ $list:pwel$ ] >> -> <:expr< try $expr e$ with [ $list:List.map match_assoc pwel$ ] >> | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> <:expr< let $opt:rf$ $list:List.map let_binding pel$ in $expr e$ >> | <:expr< let module $s$ = $me$ in $e$ >> -> <:expr< let module $s$ = $module_expr me$ in $expr e$ >> | <:expr< if $e1$ then $e2$ else $e3$ >> -> <:expr< if $expr e1$ then $expr e2$ else $expr e3$ >> | <:expr< while $e$ do { $list:el$ } >> -> <:expr< while $expr e$ do { $list:List.map expr el$ } >> | <:expr< do { $list:el$ } >> -> <:expr< do { $list:List.map expr el$ } >> | <:expr< $e$ # $s$ >> -> <:expr< $expr e$ # $s$ >> | <:expr< ($e$ : $t$) >> -> <:expr< ($expr e$ : $t$) >> | <:expr< $e1$ || $e2$ >> -> <:expr< $expr e1$ || $expr e2$ >> | <:expr< $e1$ && $e2$ >> -> <:expr< $expr e1$ && $expr e2$ >> | <:expr< $e1$ $e2$ >> -> left_eval_apply loc expr e1 e2 | <:expr< ($list:el$) >> -> left_eval_tuple loc expr el | <:expr< { $list:lel$ } >> -> left_eval_record loc expr lel | <:expr< $e1$ := $e2$ >> -> left_eval_assign loc expr e1 e2 | <:expr< $_$ . $_$ >> | <:expr< $uid:_$ >> | <:expr< $lid:_$ >> | <:expr< $str:_$ >> | <:expr< $chr:_$ >> | <:expr< $int:_$ >> | <:expr< $flo:_$ >> | <:expr< new $list:_$ >> -> x | x -> not_impl "expr" x ] and let_binding (p, e) = (p, expr e) and match_assoc (p, eo, e) = (p, map_option expr eo, expr e) and module_expr x = let loc = MLast.loc_of_module_expr x in match x with [ <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> <:module_expr< functor ($s$ : $mt$) -> $module_expr me$ >> | <:module_expr< ($me$ : $mt$) >> -> <:module_expr< ($module_expr me$ : $mt$) >> | <:module_expr< struct $list:sil$ end >> -> <:module_expr< struct $list:List.map str_item sil$ end >> | <:module_expr< $_$ . $_$ >> | <:module_expr< $_$ $_$ >> | <:module_expr< $uid:_$ >> -> x ] and str_item x = let loc = MLast.loc_of_str_item x in match x with [ <:str_item< module $s$ = $me$ >> -> <:str_item< module $s$ = $module_expr me$ >> | <:str_item< value $opt:rf$ $list:pel$ >> -> <:str_item< value $opt:rf$ $list:List.map let_binding pel$ >> | <:str_item< declare $list:sil$ end >> -> <:str_item< declare $list:List.map str_item sil$ end >> | <:str_item< class $list:ce$ >> -> <:str_item< class $list:List.map (class_infos class_expr) ce$ >> | <:str_item< $exp:e$ >> -> <:str_item< $exp:expr e$ >> | <:str_item< open $_$ >> | <:str_item< type $list:_$ >> | <:str_item< exception $_$ of $list:_$ = $_$ >> | <:str_item< module type $_$ = $_$ >> | <:str_item< # $_$ $opt:_$ >> -> x | x -> not_impl "str_item" x ] and class_expr x = let loc = MLast.loc_of_class_expr x in match x with [ <:class_expr< object $opt:p$ $list:csil$ end >> -> <:class_expr< object $opt:p$ $list:List.map class_str_item csil$ end >> | x -> not_impl "class_expr" x ] and class_str_item x = let loc = MLast.loc_of_class_str_item x in match x with [ <:class_str_item< value $opt:mf$ $s$ = $e$ >> -> <:class_str_item< value $opt:mf$ $s$ = $expr e$ >> | <:class_str_item< method $s$ = $e$ >> -> <:class_str_item< method $s$ = $expr e$ >> | x -> not_impl "class_str_item" x ] ; value parse_implem = Pcaml.parse_implem.val; value parse_implem_with_left_eval strm = let (r, b) = parse_implem strm in (List.map (fun (si, loc) -> (str_item si, loc)) r, b) ; Pcaml.parse_implem.val := parse_implem_with_left_eval; mingw-ocaml/ocaml/camlp4/unmaintained/lefteval/.depend0000644000175000017500000000000012124403240022341 0ustar tootstootsmingw-ocaml/ocaml/camlp4/camlp4prof.mli0000644000175000017500000000212312124403240017405 0ustar tootstoots(****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) value count : string -> unit; value load : in_channel -> list (string * int); mingw-ocaml/ocaml/camlp4/Camlp4Printers/0000755000175000017500000000000012124403240017504 5ustar tootstootsmingw-ocaml/ocaml/camlp4/Camlp4Printers/Camlp4NullDumper.ml0000644000175000017500000000214512124403240023170 0ustar tootstoots(****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Nicolas Pouillard: initial version *) Camlp4.Register.enable_null_printer (); mingw-ocaml/ocaml/camlp4/Camlp4Printers/Camlp4AutoPrinter.ml0000644000175000017500000000226712124403240023362 0ustar tootstoots(****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Nicolas Pouillard: initial version *) open Camlp4.Register; if Unix.isatty Unix.stdout then enable_ocaml_printer () else enable_dump_ocaml_ast_printer (); mingw-ocaml/ocaml/camlp4/Camlp4Printers/Camlp4OCamlRevisedPrinter.ml0000644000175000017500000000214712124403240024764 0ustar tootstoots(****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Nicolas Pouillard: initial version *) Camlp4.Register.enable_ocamlr_printer (); mingw-ocaml/ocaml/camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml0000644000175000017500000000215712124403240023724 0ustar tootstoots(****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Nicolas Pouillard: initial version *) Camlp4.Register.enable_dump_ocaml_ast_printer (); mingw-ocaml/ocaml/camlp4/Camlp4Printers/Camlp4OCamlPrinter.ml0000644000175000017500000000214612124403240023441 0ustar tootstoots(****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Nicolas Pouillard: initial version *) Camlp4.Register.enable_ocaml_printer (); mingw-ocaml/ocaml/camlp4/Camlp4Printers/Camlp4AstDumper.ml0000644000175000017500000000216012124403240023002 0ustar tootstoots(****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Nicolas Pouillard: initial version *) Camlp4.Register.enable_dump_camlp4_ast_printer (); mingw-ocaml/ocaml/camlp4/mkcamlp4.ml0000644000175000017500000000544512124403240016707 0ustar tootstoots(****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial shell version * - Nicolas Pouillard: rewriting in OCaml *) open Camlp4; open Camlp4_config; open Filename; open Format; value (interfaces, options, includes) = let rec self (interf, opts, incl) = fun [ [] -> (List.rev interf, List.rev opts, List.rev incl) | ["-I"; dir :: args] -> self (interf, opts, [dir; "-I" :: incl]) args | ["-version" :: _] -> do { printf "mkcamlp4, version %s@." version; exit 0 } | ["-vnum" :: _] -> do { printf "%s@." version; exit 0 } | [ arg :: args ] when check_suffix arg ".cmi" -> let basename = String.capitalize (Filename.chop_suffix (Filename.basename arg) ".cmi") in self ([ basename :: interf ], opts, incl) args | [ arg :: args ] -> self (interf, [ arg :: opts ], incl) args ] in self ([], [], ["."; "-I"]) (List.tl (Array.to_list Sys.argv)); value run l = let cmd = String.concat " " l in let () = Format.printf "%s@." cmd in let st = Sys.command cmd (* 0 *) in if st <> 0 then failwith ("Exit: " ^ string_of_int st) else (); value crc_ml = Filename.temp_file "crc_" ".ml"; value crc = Filename.chop_suffix crc_ml ".ml"; value clean () = run ["rm"; "-f"; crc_ml; crc^".cmi"; crc^".cmo"]; try do { run ([ocaml_standard_library^"/extract_crc"; "-I"; camlp4_standard_library] @ includes @ interfaces @ [">"; crc_ml]); let cout = open_out_gen [Open_wronly; Open_append; Open_text] 0o666 crc_ml in do { output_string cout "let _ = Dynlink.add_available_units crc_unit_list\n"; close_out cout }; run (["ocamlc"; "-I"; camlp4_standard_library; "dynlink.cma"; "camlp4lib.cma"; crc_ml] @ includes @ options @ ["Camlp4Bin.cmo"; "-linkall"]); clean(); } with exc -> do { clean (); raise exc }; mingw-ocaml/ocaml/camlp4/Camlp4_config.ml0000644000175000017500000000357312124403240017644 0ustar tootstoots(****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) let ocaml_standard_library = Camlp4_import.Config.standard_library;; let camlp4_standard_library = try Sys.getenv "CAMLP4LIB" with Not_found -> Filename.concat ocaml_standard_library "camlp4";; let version = Sys.ocaml_version;; let program_name = ref "camlp4";; let constructors_arity = ref true;; let unsafe = ref false;; let verbose = ref false;; let antiquotations = ref false;; let quotations = ref true;; let inter_phrases = ref None;; let camlp4_ast_impl_magic_number = "Camlp42006M002";; let camlp4_ast_intf_magic_number = "Camlp42006N002";; let ocaml_ast_intf_magic_number = Camlp4_import.Config.ast_intf_magic_number;; let ocaml_ast_impl_magic_number = Camlp4_import.Config.ast_impl_magic_number;; let current_input_file = ref "";; mingw-ocaml/ocaml/camlp4/top/0000755000175000017500000000000012124403240015437 5ustar tootstootsmingw-ocaml/ocaml/camlp4/top/.gitignore0000644000175000017500000000000012124403240017415 0ustar tootstootsmingw-ocaml/ocaml/camlp4/odyl/0000755000175000017500000000000012124403240015604 5ustar tootstootsmingw-ocaml/ocaml/camlp4/odyl/.gitignore0000644000175000017500000000000012124403240017562 0ustar tootstootsmingw-ocaml/ocaml/camlp4/boot/0000755000175000017500000000000012124403240015600 5ustar tootstootsmingw-ocaml/ocaml/camlp4/boot/.ignore0000644000175000017500000000004312124403240017061 0ustar tootstootscamlp4 camlp4o camlp4r SAVED *.old mingw-ocaml/ocaml/camlp4/boot/Camlp4.ml40000644000175000017500000001034712124403240017343 0ustar tootstootsmodule Debug : sig INCLUDE "camlp4/Camlp4/Debug.mli"; end = struct INCLUDE "camlp4/Camlp4/Debug.ml"; end; module Options : sig INCLUDE "camlp4/Camlp4/Options.mli"; end = struct INCLUDE "camlp4/Camlp4/Options.ml"; end; module Sig = struct INCLUDE "camlp4/Camlp4/Sig.ml"; end; module ErrorHandler : sig INCLUDE "camlp4/Camlp4/ErrorHandler.mli"; end = struct INCLUDE "camlp4/Camlp4/ErrorHandler.ml"; end; module Struct = struct module Loc : sig INCLUDE "camlp4/Camlp4/Struct/Loc.mli"; end = struct INCLUDE "camlp4/Camlp4/Struct/Loc.ml"; end; module Token : sig INCLUDE "camlp4/Camlp4/Struct/Token.mli"; end = struct INCLUDE "camlp4/Camlp4/Struct/Token.ml"; end; module Lexer = struct INCLUDE "camlp4/boot/Lexer.ml"; end; module Camlp4Ast = struct INCLUDE "camlp4/Camlp4/Struct/Camlp4Ast.ml"; end; module DynAst = struct INCLUDE "camlp4/Camlp4/Struct/DynAst.ml"; end; module Quotation = struct INCLUDE "camlp4/Camlp4/Struct/Quotation.ml"; end; module AstFilters = struct INCLUDE "camlp4/Camlp4/Struct/AstFilters.ml"; end; module Camlp4Ast2OCamlAst : sig INCLUDE "camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli"; end = struct INCLUDE "camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml"; end; module CleanAst = struct INCLUDE "camlp4/Camlp4/Struct/CleanAst.ml"; end; module CommentFilter : sig INCLUDE "camlp4/Camlp4/Struct/CommentFilter.mli"; end = struct INCLUDE "camlp4/Camlp4/Struct/CommentFilter.ml"; end; module DynLoader : sig INCLUDE "camlp4/Camlp4/Struct/DynLoader.mli"; end = struct INCLUDE "camlp4/Camlp4/Struct/DynLoader.ml"; end; module EmptyError : sig INCLUDE "camlp4/Camlp4/Struct/EmptyError.mli"; end = struct INCLUDE "camlp4/Camlp4/Struct/EmptyError.ml"; end; module EmptyPrinter : sig INCLUDE "camlp4/Camlp4/Struct/EmptyPrinter.mli"; end = struct INCLUDE "camlp4/Camlp4/Struct/EmptyPrinter.ml"; end; module FreeVars : sig INCLUDE "camlp4/Camlp4/Struct/FreeVars.mli"; end = struct INCLUDE "camlp4/Camlp4/Struct/FreeVars.ml"; end; module Grammar = struct module Structure = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Structure.ml"; end; module Search = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Search.ml"; end; (* module Find = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Find.ml"; end; *) module Tools = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Tools.ml"; end; module Print : sig INCLUDE "camlp4/Camlp4/Struct/Grammar/Print.mli"; end = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Print.ml"; end; module Failed = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Failed.ml"; end; module Parser = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Parser.ml"; end; module Insert = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Insert.ml"; end; module Delete = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Delete.ml"; end; module Fold : sig INCLUDE "camlp4/Camlp4/Struct/Grammar/Fold.mli"; end = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Fold.ml"; end; module Entry = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Entry.ml"; end; module Static = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Static.ml"; end; module Dynamic = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Dynamic.ml"; end; end; end; module Printers = struct module DumpCamlp4Ast : sig INCLUDE "camlp4/Camlp4/Printers/DumpCamlp4Ast.mli"; end = struct INCLUDE "camlp4/Camlp4/Printers/DumpCamlp4Ast.ml"; end; module DumpOCamlAst : sig INCLUDE "camlp4/Camlp4/Printers/DumpOCamlAst.mli"; end = struct INCLUDE "camlp4/Camlp4/Printers/DumpOCamlAst.ml"; end; module Null : sig INCLUDE "camlp4/Camlp4/Printers/Null.mli"; end = struct INCLUDE "camlp4/Camlp4/Printers/Null.ml"; end; module OCaml : sig INCLUDE "camlp4/Camlp4/Printers/OCaml.mli"; end = struct INCLUDE "camlp4/Camlp4/Printers/OCaml.ml"; end; module OCamlr : sig INCLUDE "camlp4/Camlp4/Printers/OCamlr.mli"; end = struct INCLUDE "camlp4/Camlp4/Printers/OCamlr.ml"; end; end; module OCamlInitSyntax = struct INCLUDE "camlp4/Camlp4/OCamlInitSyntax.ml"; end; module PreCast : sig INCLUDE "camlp4/Camlp4/PreCast.mli"; end = struct INCLUDE "camlp4/Camlp4/PreCast.ml"; end; module Register : sig INCLUDE "camlp4/Camlp4/Register.mli"; end = struct INCLUDE "camlp4/Camlp4/Register.ml"; end; mingw-ocaml/ocaml/camlp4/boot/Camlp4.ml0000644000175000017500000400444012124403240017260 0ustar tootstootsmodule Debug : sig (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) (* camlp4r *) type section = string val mode : section -> bool val printf : section -> ('a, Format.formatter, unit) format -> 'a end = struct (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) (* camlp4r *) open Format module Debug = struct let mode _ = false end type section = string let out_channel = try let f = Sys.getenv "CAMLP4_DEBUG_FILE" in open_out_gen [ Open_wronly; Open_creat; Open_append; Open_text ] 0o666 f with | Not_found -> Pervasives.stderr module StringSet = Set.Make(String) let mode = try let str = Sys.getenv "CAMLP4_DEBUG" in let rec loop acc i = try let pos = String.index_from str i ':' in loop (StringSet.add (String.sub str i (pos - i)) acc) (pos + 1) with | Not_found -> StringSet.add (String.sub str i ((String.length str) - i)) acc in let sections = loop StringSet.empty 0 in if StringSet.mem "*" sections then (fun _ -> true) else (fun x -> StringSet.mem x sections) with | Not_found -> (fun _ -> false) let formatter = let header = "camlp4-debug: " in let at_bol = ref true in make_formatter (fun buf pos len -> for i = pos to (pos + len) - 1 do if !at_bol then output_string out_channel header else (); let ch = buf.[i] in (output_char out_channel ch; at_bol := ch = '\n') done) (fun () -> flush out_channel) let printf section fmt = fprintf formatter ("%s: " ^^ fmt) section end module Options : sig (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) type spec_list = (string * Arg.spec * string) list val init : spec_list -> unit val add : string -> Arg.spec -> string -> unit (** Add an option to the command line options. *) val print_usage_list : spec_list -> unit val ext_spec_list : unit -> spec_list val parse : (string -> unit) -> string array -> string list end = struct (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) type spec_list = (string * Arg.spec * string) list open Format let rec action_arg s sl = function | Arg.Unit f -> if s = "" then (f (); Some sl) else None | Arg.Bool f -> if s = "" then (match sl with | s :: sl -> (try (f (bool_of_string s); Some sl) with | Invalid_argument "bool_of_string" -> None) | [] -> None) else (try (f (bool_of_string s); Some sl) with | Invalid_argument "bool_of_string" -> None) | Arg.Set r -> if s = "" then (r := true; Some sl) else None | Arg.Clear r -> if s = "" then (r := false; Some sl) else None | Arg.Rest f -> (List.iter f (s :: sl); Some []) | Arg.String f -> if s = "" then (match sl with | s :: sl -> (f s; Some sl) | [] -> None) else (f s; Some sl) | Arg.Set_string r -> if s = "" then (match sl with | s :: sl -> (r := s; Some sl) | [] -> None) else (r := s; Some sl) | Arg.Int f -> if s = "" then (match sl with | s :: sl -> (try (f (int_of_string s); Some sl) with | Failure "int_of_string" -> None) | [] -> None) else (try (f (int_of_string s); Some sl) with | Failure "int_of_string" -> None) | Arg.Set_int r -> if s = "" then (match sl with | s :: sl -> (try (r := int_of_string s; Some sl) with | Failure "int_of_string" -> None) | [] -> None) else (try (r := int_of_string s; Some sl) with | Failure "int_of_string" -> None) | Arg.Float f -> if s = "" then (match sl with | s :: sl -> (f (float_of_string s); Some sl) | [] -> None) else (f (float_of_string s); Some sl) | Arg.Set_float r -> if s = "" then (match sl with | s :: sl -> (r := float_of_string s; Some sl) | [] -> None) else (r := float_of_string s; Some sl) | Arg.Tuple specs -> let rec action_args s sl = (function | [] -> Some sl | spec :: spec_list -> (match action_arg s sl spec with | None -> action_args "" [] spec_list | Some (s :: sl) -> action_args s sl spec_list | Some sl -> action_args "" sl spec_list)) in action_args s sl specs | Arg.Symbol (syms, f) -> (match if s = "" then sl else s :: sl with | s :: sl when List.mem s syms -> (f s; Some sl) | _ -> None) let common_start s1 s2 = let rec loop i = if (i == (String.length s1)) || (i == (String.length s2)) then i else if s1.[i] == s2.[i] then loop (i + 1) else i in loop 0 let parse_arg fold s sl = fold (fun (name, action, _) acu -> let i = common_start s name in if i == (String.length name) then (try action_arg (String.sub s i ((String.length s) - i)) sl action with | Arg.Bad _ -> acu) else acu) None let rec parse_aux fold anon_fun = function | [] -> [] | s :: sl -> if ((String.length s) > 1) && (s.[0] = '-') then (match parse_arg fold s sl with | Some sl -> parse_aux fold anon_fun sl | None -> s :: (parse_aux fold anon_fun sl)) else ((anon_fun s : unit); parse_aux fold anon_fun sl) let align_doc key s = let s = let rec loop i = if i = (String.length s) then "" else if s.[i] = ' ' then loop (i + 1) else String.sub s i ((String.length s) - i) in loop 0 in let (p, s) = if (String.length s) > 0 then if s.[0] = '<' then (let rec loop i = if i = (String.length s) then ("", s) else if s.[i] <> '>' then loop (i + 1) else (let p = String.sub s 0 (i + 1) in let rec loop i = if i >= (String.length s) then (p, "") else if s.[i] = ' ' then loop (i + 1) else (p, (String.sub s i ((String.length s) - i))) in loop (i + 1)) in loop 0) else ("", s) else ("", "") in let tab = String.make (max 1 ((16 - (String.length key)) - (String.length p))) ' ' in p ^ (tab ^ s) let make_symlist l = match l with | [] -> "" | h :: t -> (List.fold_left (fun x y -> x ^ ("|" ^ y)) ("{" ^ h) t) ^ "}" let print_usage_list l = List.iter (fun (key, spec, doc) -> match spec with | Arg.Symbol (symbs, _) -> let s = make_symlist symbs in let synt = key ^ (" " ^ s) in eprintf " %s %s\n" synt (align_doc synt doc) | _ -> eprintf " %s %s\n" key (align_doc key doc)) l let remaining_args argv = let rec loop l i = if i == (Array.length argv) then l else loop (argv.(i) :: l) (i + 1) in List.rev (loop [] (!Arg.current + 1)) let init_spec_list = ref [] let ext_spec_list = ref [] let init spec_list = init_spec_list := spec_list let add name spec descr = ext_spec_list := (name, spec, descr) :: !ext_spec_list let fold f init = let spec_list = !init_spec_list @ !ext_spec_list in let specs = Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list in List.fold_right f specs init let parse anon_fun argv = let remaining_args = remaining_args argv in parse_aux fold anon_fun remaining_args let ext_spec_list () = !ext_spec_list end module Sig = struct (* camlp4r *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) (** Camlp4 signature repository *) (** {6 Basic signatures} *) (** Signature with just a type. *) module type Type = sig type t end (** Signature for errors modules, an Error modules can be registred with the {!ErrorHandler.Register} functor in order to be well printed. *) module type Error = sig type t exception E of t val to_string : t -> string val print : Format.formatter -> t -> unit end (** A signature for extensions identifiers. *) module type Id = sig (** The name of the extension, typically the module name. *) val name : string (** The version of the extension, typically $ Id$ with a versionning system. *) val version : string end (** A signature for warnings abstract from locations. *) module Warning (Loc : Type) = struct module type S = sig type warning = Loc.t -> string -> unit val default_warning : warning val current_warning : warning ref val print_warning : warning end end (** {6 Advanced signatures} *) (** A signature for locations. *) module type Loc = sig (** The type of locations. Note that, as for OCaml locations, character numbers in locations refer to character numbers in the parsed character stream, while line numbers refer to line numbers in the source file. The source file and the parsed character stream differ, for instance, when the parsed character stream contains a line number directive. The line number directive will only update the file-name field and the line-number field of the position. It makes therefore no sense to use character numbers with the source file if the sources contain line number directives. *) type t (** Return a start location for the given file name. This location starts at the begining of the file. *) val mk : string -> t (** The [ghost] location can be used when no location information is available. *) val ghost : t (** {6 Conversion functions} *) (** Return a location where both positions are set the given position. *) val of_lexing_position : Lexing.position -> t (** Return an OCaml location. *) val to_ocaml_location : t -> Camlp4_import.Location.t (** Return a location from an OCaml location. *) val of_ocaml_location : Camlp4_import.Location.t -> t (** Return a location from ocamllex buffer. *) val of_lexbuf : Lexing.lexbuf -> t (** Return a location from [(file_name, start_line, start_bol, start_off, stop_line, stop_bol, stop_off, ghost)]. *) val of_tuple : (string * int * int * int * int * int * int * bool) -> t (** Return [(file_name, start_line, start_bol, start_off, stop_line, stop_bol, stop_off, ghost)]. *) val to_tuple : t -> (string * int * int * int * int * int * int * bool) (** [merge loc1 loc2] Return a location that starts at [loc1] and end at [loc2]. *) val merge : t -> t -> t (** The stop pos becomes equal to the start pos. *) val join : t -> t (** [move selector n loc] Return the location where positions are moved. Affected positions are chosen with [selector]. Returned positions have their character offset plus [n]. *) val move : [ | `start | `stop | `both ] -> int -> t -> t (** [shift n loc] Return the location where the new start position is the old stop position, and where the new stop position character offset is the old one plus [n]. *) val shift : int -> t -> t (** [move_line n loc] Return the location with the old line count plus [n]. The "begin of line" of both positions become the current offset. *) val move_line : int -> t -> t (** {6 Accessors} *) (** Return the file name *) val file_name : t -> string (** Return the line number of the begining of this location. *) val start_line : t -> int (** Return the line number of the ending of this location. *) val stop_line : t -> int (** Returns the number of characters from the begining of the stream to the begining of the line of location's begining. *) val start_bol : t -> int (** Returns the number of characters from the begining of the stream to the begining of the line of location's ending. *) val stop_bol : t -> int (** Returns the number of characters from the begining of the stream of the begining of this location. *) val start_off : t -> int (** Return the number of characters from the begining of the stream of the ending of this location. *) val stop_off : t -> int (** Return the start position as a Lexing.position. *) val start_pos : t -> Lexing.position (** Return the stop position as a Lexing.position. *) val stop_pos : t -> Lexing.position (** Generally, return true if this location does not come from an input stream. *) val is_ghost : t -> bool (** Return the associated ghost location. *) val ghostify : t -> t (** Return the location with the give file name *) val set_file_name : string -> t -> t (** [strictly_before loc1 loc2] True if the stop position of [loc1] is strictly_before the start position of [loc2]. *) val strictly_before : t -> t -> bool (** Return the location with an absolute file name. *) val make_absolute : t -> t (** Print the location into the formatter in a format suitable for error reporting. *) val print : Format.formatter -> t -> unit (** Print the location in a short format useful for debugging. *) val dump : Format.formatter -> t -> unit (** Same as {!print} but return a string instead of printting it. *) val to_string : t -> string (** [Exc_located loc e] is an encapsulation of the exception [e] with the input location [loc]. To be used in quotation expanders and in grammars to specify some input location for an error. Do not raise this exception directly: rather use the following function [Loc.raise]. *) exception Exc_located of t * exn (** [raise loc e], if [e] is already an [Exc_located] exception, re-raise it, else raise the exception [Exc_located loc e]. *) val raise : t -> exn -> 'a (** The name of the location variable used in grammars and in the predefined quotations for OCaml syntax trees. Default: [_loc]. *) val name : string ref end (** Abstract syntax tree minimal signature. Types of this signature are abstract. See the {!Camlp4Ast} signature for a concrete definition. *) module type Ast = sig (** {6 Syntactic categories as abstract types} *) type loc type meta_bool type 'a meta_option type 'a meta_list type ctyp type patt type expr type module_type type sig_item type with_constr type module_expr type str_item type class_type type class_sig_item type class_expr type class_str_item type match_case type ident type binding type rec_binding type module_binding type rec_flag type direction_flag type mutable_flag type private_flag type virtual_flag type row_var_flag type override_flag (** {6 Location accessors} *) val loc_of_ctyp : ctyp -> loc val loc_of_patt : patt -> loc val loc_of_expr : expr -> loc val loc_of_module_type : module_type -> loc val loc_of_module_expr : module_expr -> loc val loc_of_sig_item : sig_item -> loc val loc_of_str_item : str_item -> loc val loc_of_class_type : class_type -> loc val loc_of_class_sig_item : class_sig_item -> loc val loc_of_class_expr : class_expr -> loc val loc_of_class_str_item : class_str_item -> loc val loc_of_with_constr : with_constr -> loc val loc_of_binding : binding -> loc val loc_of_rec_binding : rec_binding -> loc val loc_of_module_binding : module_binding -> loc val loc_of_match_case : match_case -> loc val loc_of_ident : ident -> loc (** {6 Traversals} *) (** This class is the base class for map traversal on the Ast. To make a custom traversal class one just extend it like that: This example swap pairs expression contents: open Camlp4.PreCast; [class swap = object inherit Ast.map as super; method expr e = match super#expr e with \[ <:expr\@_loc< ($e1$, $e2$) >> -> <:expr< ($e2$, $e1$) >> | e -> e \]; end; value _loc = Loc.ghost; value map = (new swap)#expr; assert (map <:expr< fun x -> (x, 42) >> = <:expr< fun x -> (42, x) >>);] *) class map : object ('self_type) method string : string -> string method list : 'a 'b. ('self_type -> 'a -> 'b) -> 'a list -> 'b list method meta_bool : meta_bool -> meta_bool method meta_option : 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_option -> 'b meta_option method meta_list : 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_list -> 'b meta_list method loc : loc -> loc method expr : expr -> expr method patt : patt -> patt method ctyp : ctyp -> ctyp method str_item : str_item -> str_item method sig_item : sig_item -> sig_item method module_expr : module_expr -> module_expr method module_type : module_type -> module_type method class_expr : class_expr -> class_expr method class_type : class_type -> class_type method class_sig_item : class_sig_item -> class_sig_item method class_str_item : class_str_item -> class_str_item method with_constr : with_constr -> with_constr method binding : binding -> binding method rec_binding : rec_binding -> rec_binding method module_binding : module_binding -> module_binding method match_case : match_case -> match_case method ident : ident -> ident method override_flag : override_flag -> override_flag method mutable_flag : mutable_flag -> mutable_flag method private_flag : private_flag -> private_flag method virtual_flag : virtual_flag -> virtual_flag method direction_flag : direction_flag -> direction_flag method rec_flag : rec_flag -> rec_flag method row_var_flag : row_var_flag -> row_var_flag method unknown : 'a. 'a -> 'a end (** Fold style traversal *) class fold : object ('self_type) method string : string -> 'self_type method list : 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type method meta_bool : meta_bool -> 'self_type method meta_option : 'a. ('self_type -> 'a -> 'self_type) -> 'a meta_option -> 'self_type method meta_list : 'a. ('self_type -> 'a -> 'self_type) -> 'a meta_list -> 'self_type method loc : loc -> 'self_type method expr : expr -> 'self_type method patt : patt -> 'self_type method ctyp : ctyp -> 'self_type method str_item : str_item -> 'self_type method sig_item : sig_item -> 'self_type method module_expr : module_expr -> 'self_type method module_type : module_type -> 'self_type method class_expr : class_expr -> 'self_type method class_type : class_type -> 'self_type method class_sig_item : class_sig_item -> 'self_type method class_str_item : class_str_item -> 'self_type method with_constr : with_constr -> 'self_type method binding : binding -> 'self_type method rec_binding : rec_binding -> 'self_type method module_binding : module_binding -> 'self_type method match_case : match_case -> 'self_type method ident : ident -> 'self_type method rec_flag : rec_flag -> 'self_type method direction_flag : direction_flag -> 'self_type method mutable_flag : mutable_flag -> 'self_type method private_flag : private_flag -> 'self_type method virtual_flag : virtual_flag -> 'self_type method row_var_flag : row_var_flag -> 'self_type method override_flag : override_flag -> 'self_type method unknown : 'a. 'a -> 'self_type end end (** Signature for OCaml syntax trees. *) (* This signature is an extension of {!Ast} It provides: - Types for all kinds of structure. - Map: A base class for map traversals. - Map classes and functions for common kinds. == Core language == ctyp :: Representaion of types patt :: The type of patterns expr :: The type of expressions match_case :: The type of cases for match/function/try constructions ident :: The type of identifiers (including path like Foo(X).Bar.y) binding :: The type of let bindings rec_binding :: The type of record definitions == Modules == module_type :: The type of module types sig_item :: The type of signature items str_item :: The type of structure items module_expr :: The type of module expressions module_binding :: The type of recursive module definitions with_constr :: The type of `with' constraints == Classes == class_type :: The type of class types class_sig_item :: The type of class signature items class_expr :: The type of class expressions class_str_item :: The type of class structure items *) module type Camlp4Ast = sig (** The inner module for locations *) module Loc : Loc (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Note: when you modify these types you must increment ast magic numbers defined in Camlp4_config.ml. *) type loc = Loc. t and meta_bool = | BTrue | BFalse | BAnt of string and rec_flag = | ReRecursive | ReNil | ReAnt of string and direction_flag = | DiTo | DiDownto | DiAnt of string and mutable_flag = | MuMutable | MuNil | MuAnt of string and private_flag = | PrPrivate | PrNil | PrAnt of string and virtual_flag = | ViVirtual | ViNil | ViAnt of string and override_flag = | OvOverride | OvNil | OvAnt of string and row_var_flag = | RvRowVar | RvNil | RvAnt of string and 'a meta_option = | ONone | OSome of 'a | OAnt of string and 'a meta_list = | LNil | LCons of 'a * 'a meta_list | LAnt of string and ident = | IdAcc of loc * ident * ident | (* i . i *) IdApp of loc * ident * ident | (* i i *) IdLid of loc * string | (* foo *) IdUid of loc * string | (* Bar *) IdAnt of loc * string and (* $s$ *) ctyp = | TyNil of loc | TyAli of loc * ctyp * ctyp | (* t as t *) (* list 'a as 'a *) TyAny of loc | (* _ *) TyApp of loc * ctyp * ctyp | (* t t *) (* list 'a *) TyArr of loc * ctyp * ctyp | (* t -> t *) (* int -> string *) TyCls of loc * ident | (* #i *) (* #point *) TyLab of loc * string * ctyp | (* ~s:t *) TyId of loc * ident | (* i *) (* Lazy.t *) TyMan of loc * ctyp * ctyp | (* t == t *) (* type t = [ A | B ] == Foo.t *) (* type t 'a 'b 'c = t constraint t = t constraint t = t *) TyDcl of loc * string * ctyp list * ctyp * (ctyp * ctyp) list | (* < (t)? (..)? > *) (* < move : int -> 'a .. > as 'a *) TyObj of loc * ctyp * row_var_flag | TyOlb of loc * string * ctyp | (* ?s:t *) TyPol of loc * ctyp * ctyp | (* ! t . t *) (* ! 'a . list 'a -> 'a *) TyTypePol of loc * ctyp * ctyp | (* type t . t *) (* type a . list a -> a *) TyQuo of loc * string | (* 's *) TyQuP of loc * string | (* +'s *) TyQuM of loc * string | (* -'s *) TyAnP of loc | (* +_ *) TyAnM of loc | (* -_ *) TyVrn of loc * string | (* `s *) TyRec of loc * ctyp | (* { t } *) (* { foo : int ; bar : mutable string } *) TyCol of loc * ctyp * ctyp | (* t : t *) TySem of loc * ctyp * ctyp | (* t; t *) TyCom of loc * ctyp * ctyp | (* t, t *) TySum of loc * ctyp | (* [ t ] *) (* [ A of int and string | B ] *) TyOf of loc * ctyp * ctyp | (* t of t *) (* A of int *) TyAnd of loc * ctyp * ctyp | (* t and t *) TyOr of loc * ctyp * ctyp | (* t | t *) TyPrv of loc * ctyp | (* private t *) TyMut of loc * ctyp | (* mutable t *) TyTup of loc * ctyp | (* ( t ) *) (* (int * string) *) TySta of loc * ctyp * ctyp | (* t * t *) TyVrnEq of loc * ctyp | (* [ = t ] *) TyVrnSup of loc * ctyp | (* [ > t ] *) TyVrnInf of loc * ctyp | (* [ < t ] *) TyVrnInfSup of loc * ctyp * ctyp | (* [ < t > t ] *) TyAmp of loc * ctyp * ctyp | (* t & t *) TyOfAmp of loc * ctyp * ctyp | (* t of & t *) TyPkg of loc * module_type | (* (module S) *) TyAnt of loc * string and (* $s$ *) patt = | PaNil of loc | PaId of loc * ident | (* i *) PaAli of loc * patt * patt | (* p as p *) (* (Node x y as n) *) PaAnt of loc * string | (* $s$ *) PaAny of loc | (* _ *) PaApp of loc * patt * patt | (* p p *) (* fun x y -> *) PaArr of loc * patt | (* [| p |] *) PaCom of loc * patt * patt | (* p, p *) PaSem of loc * patt * patt | (* p; p *) PaChr of loc * string | (* c *) (* 'x' *) PaInt of loc * string | PaInt32 of loc * string | PaInt64 of loc * string | PaNativeInt of loc * string | PaFlo of loc * string | PaLab of loc * string * patt | (* ~s or ~s:(p) *) (* ?s or ?s:(p) *) PaOlb of loc * string * patt | (* ?s:(p = e) or ?(p = e) *) PaOlbi of loc * string * patt * expr | PaOrp of loc * patt * patt | (* p | p *) PaRng of loc * patt * patt | (* p .. p *) PaRec of loc * patt | (* { p } *) PaEq of loc * ident * patt | (* i = p *) PaStr of loc * string | (* s *) PaTup of loc * patt | (* ( p ) *) PaTyc of loc * patt * ctyp | (* (p : t) *) PaTyp of loc * ident | (* #i *) PaVrn of loc * string | (* `s *) PaLaz of loc * patt | (* lazy p *) PaMod of loc * string and (* (module M) *) expr = | ExNil of loc | ExId of loc * ident | (* i *) ExAcc of loc * expr * expr | (* e.e *) ExAnt of loc * string | (* $s$ *) ExApp of loc * expr * expr | (* e e *) ExAre of loc * expr * expr | (* e.(e) *) ExArr of loc * expr | (* [| e |] *) ExSem of loc * expr * expr | (* e; e *) ExAsf of loc | (* assert False *) ExAsr of loc * expr | (* assert e *) ExAss of loc * expr * expr | (* e := e *) ExChr of loc * string | (* 'c' *) ExCoe of loc * expr * ctyp * ctyp | (* (e : t) or (e : t :> t) *) ExFlo of loc * string | (* 3.14 *) (* for s = e to/downto e do { e } *) ExFor of loc * string * expr * expr * direction_flag * expr | ExFun of loc * match_case | (* fun [ mc ] *) ExIfe of loc * expr * expr * expr | (* if e then e else e *) ExInt of loc * string | (* 42 *) ExInt32 of loc * string | ExInt64 of loc * string | ExNativeInt of loc * string | ExLab of loc * string * expr | (* ~s or ~s:e *) ExLaz of loc * expr | (* lazy e *) (* let b in e or let rec b in e *) ExLet of loc * rec_flag * binding * expr | (* let module s = me in e *) ExLmd of loc * string * module_expr * expr | (* match e with [ mc ] *) ExMat of loc * expr * match_case | (* new i *) ExNew of loc * ident | (* object ((p))? (cst)? end *) ExObj of loc * patt * class_str_item | (* ?s or ?s:e *) ExOlb of loc * string * expr | (* {< rb >} *) ExOvr of loc * rec_binding | (* { rb } or { (e) with rb } *) ExRec of loc * rec_binding * expr | (* do { e } *) ExSeq of loc * expr | (* e#s *) ExSnd of loc * expr * string | (* e.[e] *) ExSte of loc * expr * expr | (* s *) (* "foo" *) ExStr of loc * string | (* try e with [ mc ] *) ExTry of loc * expr * match_case | (* (e) *) ExTup of loc * expr | (* e, e *) ExCom of loc * expr * expr | (* (e : t) *) ExTyc of loc * expr * ctyp | (* `s *) ExVrn of loc * string | (* while e do { e } *) ExWhi of loc * expr * expr | (* let open i in e *) ExOpI of loc * ident * expr | (* fun (type t) -> e *) (* let f x (type t) y z = e *) ExFUN of loc * string * expr | (* (module ME : S) which is represented as (module (ME : S)) *) ExPkg of loc * module_expr and module_type = | MtNil of loc | (* i *) (* A.B.C *) MtId of loc * ident | (* functor (s : mt) -> mt *) MtFun of loc * string * module_type * module_type | (* 's *) MtQuo of loc * string | (* sig sg end *) MtSig of loc * sig_item | (* mt with wc *) MtWit of loc * module_type * with_constr | (* module type of m *) MtOf of loc * module_expr | MtAnt of loc * string and (* $s$ *) sig_item = | SgNil of loc | (* class cict *) SgCls of loc * class_type | (* class type cict *) SgClt of loc * class_type | (* sg ; sg *) SgSem of loc * sig_item * sig_item | (* # s or # s e *) SgDir of loc * string * expr | (* exception t *) SgExc of loc * ctyp | (* external s : t = s ... s *) SgExt of loc * string * ctyp * string meta_list | (* include mt *) SgInc of loc * module_type | (* module s : mt *) SgMod of loc * string * module_type | (* module rec mb *) SgRecMod of loc * module_binding | (* module type s = mt *) SgMty of loc * string * module_type | (* open i *) SgOpn of loc * ident | (* type t *) SgTyp of loc * ctyp | (* value s : t *) SgVal of loc * string * ctyp | SgAnt of loc * string and (* $s$ *) with_constr = | WcNil of loc | (* type t = t *) WcTyp of loc * ctyp * ctyp | (* module i = i *) WcMod of loc * ident * ident | (* type t := t *) WcTyS of loc * ctyp * ctyp | (* module i := i *) WcMoS of loc * ident * ident | (* wc and wc *) WcAnd of loc * with_constr * with_constr | WcAnt of loc * string and (* $s$ *) binding = | BiNil of loc | (* bi and bi *) (* let a = 42 and c = 43 *) BiAnd of loc * binding * binding | (* p = e *) (* let patt = expr *) BiEq of loc * patt * expr | BiAnt of loc * string and (* $s$ *) rec_binding = | RbNil of loc | (* rb ; rb *) RbSem of loc * rec_binding * rec_binding | (* i = e *) RbEq of loc * ident * expr | RbAnt of loc * string and (* $s$ *) module_binding = | MbNil of loc | (* mb and mb *) (* module rec (s : mt) = me and (s : mt) = me *) MbAnd of loc * module_binding * module_binding | (* s : mt = me *) MbColEq of loc * string * module_type * module_expr | (* s : mt *) MbCol of loc * string * module_type | MbAnt of loc * string and (* $s$ *) match_case = | McNil of loc | (* a | a *) McOr of loc * match_case * match_case | (* p (when e)? -> e *) McArr of loc * patt * expr * expr | McAnt of loc * string and (* $s$ *) module_expr = | MeNil of loc | (* i *) MeId of loc * ident | (* me me *) MeApp of loc * module_expr * module_expr | (* functor (s : mt) -> me *) MeFun of loc * string * module_type * module_expr | (* struct st end *) MeStr of loc * str_item | (* (me : mt) *) MeTyc of loc * module_expr * module_type | (* (value e) *) (* (value e : S) which is represented as (value (e : S)) *) MePkg of loc * expr | MeAnt of loc * string and (* $s$ *) str_item = | StNil of loc | (* class cice *) StCls of loc * class_expr | (* class type cict *) StClt of loc * class_type | (* st ; st *) StSem of loc * str_item * str_item | (* # s or # s e *) StDir of loc * string * expr | (* exception t or exception t = i *) StExc of loc * ctyp * (*FIXME*) ident meta_option | (* e *) StExp of loc * expr | (* external s : t = s ... s *) StExt of loc * string * ctyp * string meta_list | (* include me *) StInc of loc * module_expr | (* module s = me *) StMod of loc * string * module_expr | (* module rec mb *) StRecMod of loc * module_binding | (* module type s = mt *) StMty of loc * string * module_type | (* open i *) StOpn of loc * ident | (* type t *) StTyp of loc * ctyp | (* value (rec)? bi *) StVal of loc * rec_flag * binding | StAnt of loc * string and (* $s$ *) class_type = | CtNil of loc | (* (virtual)? i ([ t ])? *) CtCon of loc * virtual_flag * ident * ctyp | (* [t] -> ct *) CtFun of loc * ctyp * class_type | (* object ((t))? (csg)? end *) CtSig of loc * ctyp * class_sig_item | (* ct and ct *) CtAnd of loc * class_type * class_type | (* ct : ct *) CtCol of loc * class_type * class_type | (* ct = ct *) CtEq of loc * class_type * class_type | (* $s$ *) CtAnt of loc * string and class_sig_item = | CgNil of loc | (* type t = t *) CgCtr of loc * ctyp * ctyp | (* csg ; csg *) CgSem of loc * class_sig_item * class_sig_item | (* inherit ct *) CgInh of loc * class_type | (* method s : t or method private s : t *) CgMth of loc * string * private_flag * ctyp | (* value (virtual)? (mutable)? s : t *) CgVal of loc * string * mutable_flag * virtual_flag * ctyp | (* method virtual (private)? s : t *) CgVir of loc * string * private_flag * ctyp | CgAnt of loc * string and (* $s$ *) class_expr = | CeNil of loc | (* ce e *) CeApp of loc * class_expr * expr | (* (virtual)? i ([ t ])? *) CeCon of loc * virtual_flag * ident * ctyp | (* fun p -> ce *) CeFun of loc * patt * class_expr | (* let (rec)? bi in ce *) CeLet of loc * rec_flag * binding * class_expr | (* object ((p))? (cst)? end *) CeStr of loc * patt * class_str_item | (* ce : ct *) CeTyc of loc * class_expr * class_type | (* ce and ce *) CeAnd of loc * class_expr * class_expr | (* ce = ce *) CeEq of loc * class_expr * class_expr | (* $s$ *) CeAnt of loc * string and class_str_item = | CrNil of loc | (* cst ; cst *) CrSem of loc * class_str_item * class_str_item | (* type t = t *) CrCtr of loc * ctyp * ctyp | (* inherit(!)? ce (as s)? *) CrInh of loc * override_flag * class_expr * string | (* initializer e *) CrIni of loc * expr | (* method(!)? (private)? s : t = e or method(!)? (private)? s = e *) CrMth of loc * string * override_flag * private_flag * expr * ctyp | (* value(!)? (mutable)? s = e *) CrVal of loc * string * override_flag * mutable_flag * expr | (* method virtual (private)? s : t *) CrVir of loc * string * private_flag * ctyp | (* value virtual (mutable)? s : t *) CrVvr of loc * string * mutable_flag * ctyp | CrAnt of loc * string val loc_of_ctyp : ctyp -> loc val loc_of_patt : patt -> loc val loc_of_expr : expr -> loc val loc_of_module_type : module_type -> loc val loc_of_module_expr : module_expr -> loc val loc_of_sig_item : sig_item -> loc val loc_of_str_item : str_item -> loc val loc_of_class_type : class_type -> loc val loc_of_class_sig_item : class_sig_item -> loc val loc_of_class_expr : class_expr -> loc val loc_of_class_str_item : class_str_item -> loc val loc_of_with_constr : with_constr -> loc val loc_of_binding : binding -> loc val loc_of_rec_binding : rec_binding -> loc val loc_of_module_binding : module_binding -> loc val loc_of_match_case : match_case -> loc val loc_of_ident : ident -> loc module Meta : sig module type META_LOC = sig val meta_loc_patt : loc -> loc -> patt val meta_loc_expr : loc -> loc -> expr end module MetaLoc : sig val meta_loc_patt : loc -> loc -> patt val meta_loc_expr : loc -> loc -> expr end module MetaGhostLoc : sig val meta_loc_patt : loc -> 'a -> patt val meta_loc_expr : loc -> 'a -> expr end module MetaLocVar : sig val meta_loc_patt : loc -> 'a -> patt val meta_loc_expr : loc -> 'a -> expr end module Make (MetaLoc : META_LOC) : sig module Expr : sig val meta_string : loc -> string -> expr val meta_int : loc -> string -> expr val meta_float : loc -> string -> expr val meta_char : loc -> string -> expr val meta_bool : loc -> bool -> expr val meta_list : (loc -> 'a -> expr) -> loc -> 'a list -> expr val meta_binding : loc -> binding -> expr val meta_rec_binding : loc -> rec_binding -> expr val meta_class_expr : loc -> class_expr -> expr val meta_class_sig_item : loc -> class_sig_item -> expr val meta_class_str_item : loc -> class_str_item -> expr val meta_class_type : loc -> class_type -> expr val meta_ctyp : loc -> ctyp -> expr val meta_expr : loc -> expr -> expr val meta_ident : loc -> ident -> expr val meta_match_case : loc -> match_case -> expr val meta_module_binding : loc -> module_binding -> expr val meta_module_expr : loc -> module_expr -> expr val meta_module_type : loc -> module_type -> expr val meta_patt : loc -> patt -> expr val meta_sig_item : loc -> sig_item -> expr val meta_str_item : loc -> str_item -> expr val meta_with_constr : loc -> with_constr -> expr val meta_rec_flag : loc -> rec_flag -> expr val meta_mutable_flag : loc -> mutable_flag -> expr val meta_virtual_flag : loc -> virtual_flag -> expr val meta_private_flag : loc -> private_flag -> expr val meta_row_var_flag : loc -> row_var_flag -> expr val meta_override_flag : loc -> override_flag -> expr val meta_direction_flag : loc -> direction_flag -> expr end module Patt : sig val meta_string : loc -> string -> patt val meta_int : loc -> string -> patt val meta_float : loc -> string -> patt val meta_char : loc -> string -> patt val meta_bool : loc -> bool -> patt val meta_list : (loc -> 'a -> patt) -> loc -> 'a list -> patt val meta_binding : loc -> binding -> patt val meta_rec_binding : loc -> rec_binding -> patt val meta_class_expr : loc -> class_expr -> patt val meta_class_sig_item : loc -> class_sig_item -> patt val meta_class_str_item : loc -> class_str_item -> patt val meta_class_type : loc -> class_type -> patt val meta_ctyp : loc -> ctyp -> patt val meta_expr : loc -> expr -> patt val meta_ident : loc -> ident -> patt val meta_match_case : loc -> match_case -> patt val meta_module_binding : loc -> module_binding -> patt val meta_module_expr : loc -> module_expr -> patt val meta_module_type : loc -> module_type -> patt val meta_patt : loc -> patt -> patt val meta_sig_item : loc -> sig_item -> patt val meta_str_item : loc -> str_item -> patt val meta_with_constr : loc -> with_constr -> patt val meta_rec_flag : loc -> rec_flag -> patt val meta_mutable_flag : loc -> mutable_flag -> patt val meta_virtual_flag : loc -> virtual_flag -> patt val meta_private_flag : loc -> private_flag -> patt val meta_row_var_flag : loc -> row_var_flag -> patt val meta_override_flag : loc -> override_flag -> patt val meta_direction_flag : loc -> direction_flag -> patt end end end class map : object ('self_type) method string : string -> string method list : 'a 'b. ('self_type -> 'a -> 'b) -> 'a list -> 'b list method meta_bool : meta_bool -> meta_bool method meta_option : 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_option -> 'b meta_option method meta_list : 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_list -> 'b meta_list method loc : loc -> loc method expr : expr -> expr method patt : patt -> patt method ctyp : ctyp -> ctyp method str_item : str_item -> str_item method sig_item : sig_item -> sig_item method module_expr : module_expr -> module_expr method module_type : module_type -> module_type method class_expr : class_expr -> class_expr method class_type : class_type -> class_type method class_sig_item : class_sig_item -> class_sig_item method class_str_item : class_str_item -> class_str_item method with_constr : with_constr -> with_constr method binding : binding -> binding method rec_binding : rec_binding -> rec_binding method module_binding : module_binding -> module_binding method match_case : match_case -> match_case method ident : ident -> ident method mutable_flag : mutable_flag -> mutable_flag method private_flag : private_flag -> private_flag method virtual_flag : virtual_flag -> virtual_flag method direction_flag : direction_flag -> direction_flag method rec_flag : rec_flag -> rec_flag method row_var_flag : row_var_flag -> row_var_flag method override_flag : override_flag -> override_flag method unknown : 'a. 'a -> 'a end class fold : object ('self_type) method string : string -> 'self_type method list : 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type method meta_bool : meta_bool -> 'self_type method meta_option : 'a. ('self_type -> 'a -> 'self_type) -> 'a meta_option -> 'self_type method meta_list : 'a. ('self_type -> 'a -> 'self_type) -> 'a meta_list -> 'self_type method loc : loc -> 'self_type method expr : expr -> 'self_type method patt : patt -> 'self_type method ctyp : ctyp -> 'self_type method str_item : str_item -> 'self_type method sig_item : sig_item -> 'self_type method module_expr : module_expr -> 'self_type method module_type : module_type -> 'self_type method class_expr : class_expr -> 'self_type method class_type : class_type -> 'self_type method class_sig_item : class_sig_item -> 'self_type method class_str_item : class_str_item -> 'self_type method with_constr : with_constr -> 'self_type method binding : binding -> 'self_type method rec_binding : rec_binding -> 'self_type method module_binding : module_binding -> 'self_type method match_case : match_case -> 'self_type method ident : ident -> 'self_type method rec_flag : rec_flag -> 'self_type method direction_flag : direction_flag -> 'self_type method mutable_flag : mutable_flag -> 'self_type method private_flag : private_flag -> 'self_type method virtual_flag : virtual_flag -> 'self_type method row_var_flag : row_var_flag -> 'self_type method override_flag : override_flag -> 'self_type method unknown : 'a. 'a -> 'self_type end val map_expr : (expr -> expr) -> map val map_patt : (patt -> patt) -> map val map_ctyp : (ctyp -> ctyp) -> map val map_str_item : (str_item -> str_item) -> map val map_sig_item : (sig_item -> sig_item) -> map val map_loc : (loc -> loc) -> map val ident_of_expr : expr -> ident val ident_of_patt : patt -> ident val ident_of_ctyp : ctyp -> ident val biAnd_of_list : binding list -> binding val rbSem_of_list : rec_binding list -> rec_binding val paSem_of_list : patt list -> patt val paCom_of_list : patt list -> patt val tyOr_of_list : ctyp list -> ctyp val tyAnd_of_list : ctyp list -> ctyp val tyAmp_of_list : ctyp list -> ctyp val tySem_of_list : ctyp list -> ctyp val tyCom_of_list : ctyp list -> ctyp val tySta_of_list : ctyp list -> ctyp val stSem_of_list : str_item list -> str_item val sgSem_of_list : sig_item list -> sig_item val crSem_of_list : class_str_item list -> class_str_item val cgSem_of_list : class_sig_item list -> class_sig_item val ctAnd_of_list : class_type list -> class_type val ceAnd_of_list : class_expr list -> class_expr val wcAnd_of_list : with_constr list -> with_constr val meApp_of_list : module_expr list -> module_expr val mbAnd_of_list : module_binding list -> module_binding val mcOr_of_list : match_case list -> match_case val idAcc_of_list : ident list -> ident val idApp_of_list : ident list -> ident val exSem_of_list : expr list -> expr val exCom_of_list : expr list -> expr val list_of_ctyp : ctyp -> ctyp list -> ctyp list val list_of_binding : binding -> binding list -> binding list val list_of_rec_binding : rec_binding -> rec_binding list -> rec_binding list val list_of_with_constr : with_constr -> with_constr list -> with_constr list val list_of_patt : patt -> patt list -> patt list val list_of_expr : expr -> expr list -> expr list val list_of_str_item : str_item -> str_item list -> str_item list val list_of_sig_item : sig_item -> sig_item list -> sig_item list val list_of_class_sig_item : class_sig_item -> class_sig_item list -> class_sig_item list val list_of_class_str_item : class_str_item -> class_str_item list -> class_str_item list val list_of_class_type : class_type -> class_type list -> class_type list val list_of_class_expr : class_expr -> class_expr list -> class_expr list val list_of_module_expr : module_expr -> module_expr list -> module_expr list val list_of_module_binding : module_binding -> module_binding list -> module_binding list val list_of_match_case : match_case -> match_case list -> match_case list val list_of_ident : ident -> ident list -> ident list val safe_string_escaped : string -> string val is_irrefut_patt : patt -> bool val is_constructor : ident -> bool val is_patt_constructor : patt -> bool val is_expr_constructor : expr -> bool val ty_of_stl : (Loc.t * string * (ctyp list)) -> ctyp val ty_of_sbt : (Loc.t * string * bool * ctyp) -> ctyp val bi_of_pe : (patt * expr) -> binding val pel_of_binding : binding -> (patt * expr) list val binding_of_pel : (patt * expr) list -> binding val sum_type_of_list : (Loc.t * string * (ctyp list)) list -> ctyp val record_type_of_list : (Loc.t * string * bool * ctyp) list -> ctyp end module Camlp4AstToAst (M : Camlp4Ast) : Ast with type loc = M.loc and type meta_bool = M.meta_bool and type 'a meta_option = 'a M.meta_option and type 'a meta_list = 'a M.meta_list and type ctyp = M.ctyp and type patt = M.patt and type expr = M.expr and type module_type = M.module_type and type sig_item = M.sig_item and type with_constr = M.with_constr and type module_expr = M.module_expr and type str_item = M.str_item and type class_type = M.class_type and type class_sig_item = M.class_sig_item and type class_expr = M.class_expr and type class_str_item = M.class_str_item and type binding = M.binding and type rec_binding = M.rec_binding and type module_binding = M.module_binding and type match_case = M.match_case and type ident = M.ident and type rec_flag = M.rec_flag and type direction_flag = M.direction_flag and type mutable_flag = M.mutable_flag and type private_flag = M.private_flag and type virtual_flag = M.virtual_flag and type row_var_flag = M.row_var_flag and type override_flag = M.override_flag = M module MakeCamlp4Ast (Loc : Type) = struct type loc = Loc. t and meta_bool = | BTrue | BFalse | BAnt of string and rec_flag = | ReRecursive | ReNil | ReAnt of string and direction_flag = | DiTo | DiDownto | DiAnt of string and mutable_flag = | MuMutable | MuNil | MuAnt of string and private_flag = | PrPrivate | PrNil | PrAnt of string and virtual_flag = | ViVirtual | ViNil | ViAnt of string and override_flag = | OvOverride | OvNil | OvAnt of string and row_var_flag = | RvRowVar | RvNil | RvAnt of string and 'a meta_option = | ONone | OSome of 'a | OAnt of string and 'a meta_list = | LNil | LCons of 'a * 'a meta_list | LAnt of string and ident = | IdAcc of loc * ident * ident | IdApp of loc * ident * ident | IdLid of loc * string | IdUid of loc * string | IdAnt of loc * string and ctyp = | TyNil of loc | TyAli of loc * ctyp * ctyp | TyAny of loc | TyApp of loc * ctyp * ctyp | TyArr of loc * ctyp * ctyp | TyCls of loc * ident | TyLab of loc * string * ctyp | TyId of loc * ident | TyMan of loc * ctyp * ctyp | TyDcl of loc * string * ctyp list * ctyp * (ctyp * ctyp) list | TyObj of loc * ctyp * row_var_flag | TyOlb of loc * string * ctyp | TyPol of loc * ctyp * ctyp | TyTypePol of loc * ctyp * ctyp | TyQuo of loc * string | TyQuP of loc * string | TyQuM of loc * string | TyAnP of loc | TyAnM of loc | TyVrn of loc * string | TyRec of loc * ctyp | TyCol of loc * ctyp * ctyp | TySem of loc * ctyp * ctyp | TyCom of loc * ctyp * ctyp | TySum of loc * ctyp | TyOf of loc * ctyp * ctyp | TyAnd of loc * ctyp * ctyp | TyOr of loc * ctyp * ctyp | TyPrv of loc * ctyp | TyMut of loc * ctyp | TyTup of loc * ctyp | TySta of loc * ctyp * ctyp | TyVrnEq of loc * ctyp | TyVrnSup of loc * ctyp | TyVrnInf of loc * ctyp | TyVrnInfSup of loc * ctyp * ctyp | TyAmp of loc * ctyp * ctyp | TyOfAmp of loc * ctyp * ctyp | TyPkg of loc * module_type | TyAnt of loc * string and patt = | PaNil of loc | PaId of loc * ident | PaAli of loc * patt * patt | PaAnt of loc * string | PaAny of loc | PaApp of loc * patt * patt | PaArr of loc * patt | PaCom of loc * patt * patt | PaSem of loc * patt * patt | PaChr of loc * string | PaInt of loc * string | PaInt32 of loc * string | PaInt64 of loc * string | PaNativeInt of loc * string | PaFlo of loc * string | PaLab of loc * string * patt | PaOlb of loc * string * patt | PaOlbi of loc * string * patt * expr | PaOrp of loc * patt * patt | PaRng of loc * patt * patt | PaRec of loc * patt | PaEq of loc * ident * patt | PaStr of loc * string | PaTup of loc * patt | PaTyc of loc * patt * ctyp | PaTyp of loc * ident | PaVrn of loc * string | PaLaz of loc * patt | PaMod of loc * string and expr = | ExNil of loc | ExId of loc * ident | ExAcc of loc * expr * expr | ExAnt of loc * string | ExApp of loc * expr * expr | ExAre of loc * expr * expr | ExArr of loc * expr | ExSem of loc * expr * expr | ExAsf of loc | ExAsr of loc * expr | ExAss of loc * expr * expr | ExChr of loc * string | ExCoe of loc * expr * ctyp * ctyp | ExFlo of loc * string | ExFor of loc * string * expr * expr * direction_flag * expr | ExFun of loc * match_case | ExIfe of loc * expr * expr * expr | ExInt of loc * string | ExInt32 of loc * string | ExInt64 of loc * string | ExNativeInt of loc * string | ExLab of loc * string * expr | ExLaz of loc * expr | ExLet of loc * rec_flag * binding * expr | ExLmd of loc * string * module_expr * expr | ExMat of loc * expr * match_case | ExNew of loc * ident | ExObj of loc * patt * class_str_item | ExOlb of loc * string * expr | ExOvr of loc * rec_binding | ExRec of loc * rec_binding * expr | ExSeq of loc * expr | ExSnd of loc * expr * string | ExSte of loc * expr * expr | ExStr of loc * string | ExTry of loc * expr * match_case | ExTup of loc * expr | ExCom of loc * expr * expr | ExTyc of loc * expr * ctyp | ExVrn of loc * string | ExWhi of loc * expr * expr | ExOpI of loc * ident * expr | ExFUN of loc * string * expr | ExPkg of loc * module_expr and module_type = | MtNil of loc | MtId of loc * ident | MtFun of loc * string * module_type * module_type | MtQuo of loc * string | MtSig of loc * sig_item | MtWit of loc * module_type * with_constr | MtOf of loc * module_expr | MtAnt of loc * string and sig_item = | SgNil of loc | SgCls of loc * class_type | SgClt of loc * class_type | SgSem of loc * sig_item * sig_item | SgDir of loc * string * expr | SgExc of loc * ctyp | SgExt of loc * string * ctyp * string meta_list | SgInc of loc * module_type | SgMod of loc * string * module_type | SgRecMod of loc * module_binding | SgMty of loc * string * module_type | SgOpn of loc * ident | SgTyp of loc * ctyp | SgVal of loc * string * ctyp | SgAnt of loc * string and with_constr = | WcNil of loc | WcTyp of loc * ctyp * ctyp | WcMod of loc * ident * ident | WcTyS of loc * ctyp * ctyp | WcMoS of loc * ident * ident | WcAnd of loc * with_constr * with_constr | WcAnt of loc * string and binding = | BiNil of loc | BiAnd of loc * binding * binding | BiEq of loc * patt * expr | BiAnt of loc * string and rec_binding = | RbNil of loc | RbSem of loc * rec_binding * rec_binding | RbEq of loc * ident * expr | RbAnt of loc * string and module_binding = | MbNil of loc | MbAnd of loc * module_binding * module_binding | MbColEq of loc * string * module_type * module_expr | MbCol of loc * string * module_type | MbAnt of loc * string and match_case = | McNil of loc | McOr of loc * match_case * match_case | McArr of loc * patt * expr * expr | McAnt of loc * string and module_expr = | MeNil of loc | MeId of loc * ident | MeApp of loc * module_expr * module_expr | MeFun of loc * string * module_type * module_expr | MeStr of loc * str_item | MeTyc of loc * module_expr * module_type | MePkg of loc * expr | MeAnt of loc * string and str_item = | StNil of loc | StCls of loc * class_expr | StClt of loc * class_type | StSem of loc * str_item * str_item | StDir of loc * string * expr | StExc of loc * ctyp * ident meta_option | StExp of loc * expr | StExt of loc * string * ctyp * string meta_list | StInc of loc * module_expr | StMod of loc * string * module_expr | StRecMod of loc * module_binding | StMty of loc * string * module_type | StOpn of loc * ident | StTyp of loc * ctyp | StVal of loc * rec_flag * binding | StAnt of loc * string and class_type = | CtNil of loc | CtCon of loc * virtual_flag * ident * ctyp | CtFun of loc * ctyp * class_type | CtSig of loc * ctyp * class_sig_item | CtAnd of loc * class_type * class_type | CtCol of loc * class_type * class_type | CtEq of loc * class_type * class_type | CtAnt of loc * string and class_sig_item = | CgNil of loc | CgCtr of loc * ctyp * ctyp | CgSem of loc * class_sig_item * class_sig_item | CgInh of loc * class_type | CgMth of loc * string * private_flag * ctyp | CgVal of loc * string * mutable_flag * virtual_flag * ctyp | CgVir of loc * string * private_flag * ctyp | CgAnt of loc * string and class_expr = | CeNil of loc | CeApp of loc * class_expr * expr | CeCon of loc * virtual_flag * ident * ctyp | CeFun of loc * patt * class_expr | CeLet of loc * rec_flag * binding * class_expr | CeStr of loc * patt * class_str_item | CeTyc of loc * class_expr * class_type | CeAnd of loc * class_expr * class_expr | CeEq of loc * class_expr * class_expr | CeAnt of loc * string and class_str_item = | CrNil of loc | CrSem of loc * class_str_item * class_str_item | CrCtr of loc * ctyp * ctyp | CrInh of loc * override_flag * class_expr * string | CrIni of loc * expr | CrMth of loc * string * override_flag * private_flag * expr * ctyp | CrVal of loc * string * override_flag * mutable_flag * expr | CrVir of loc * string * private_flag * ctyp | CrVvr of loc * string * mutable_flag * ctyp | CrAnt of loc * string end type ('a, 'loc) stream_filter = ('a * 'loc) Stream.t -> ('a * 'loc) Stream.t module type AstFilters = sig module Ast : Camlp4Ast type 'a filter = 'a -> 'a val register_sig_item_filter : Ast.sig_item filter -> unit val register_str_item_filter : Ast.str_item filter -> unit val register_topphrase_filter : Ast.str_item filter -> unit val fold_interf_filters : ('a -> Ast.sig_item filter -> 'a) -> 'a -> 'a val fold_implem_filters : ('a -> Ast.str_item filter -> 'a) -> 'a -> 'a val fold_topphrase_filters : ('a -> Ast.str_item filter -> 'a) -> 'a -> 'a end module type DynAst = sig module Ast : Ast type 'a tag val ctyp_tag : Ast.ctyp tag val patt_tag : Ast.patt tag val expr_tag : Ast.expr tag val module_type_tag : Ast.module_type tag val sig_item_tag : Ast.sig_item tag val with_constr_tag : Ast.with_constr tag val module_expr_tag : Ast.module_expr tag val str_item_tag : Ast.str_item tag val class_type_tag : Ast.class_type tag val class_sig_item_tag : Ast.class_sig_item tag val class_expr_tag : Ast.class_expr tag val class_str_item_tag : Ast.class_str_item tag val match_case_tag : Ast.match_case tag val ident_tag : Ast.ident tag val binding_tag : Ast.binding tag val rec_binding_tag : Ast.rec_binding tag val module_binding_tag : Ast.module_binding tag val string_of_tag : 'a tag -> string module Pack (X : sig type 'a t end) : sig type pack val pack : 'a tag -> 'a X.t -> pack val unpack : 'a tag -> pack -> 'a X.t val print_tag : Format.formatter -> pack -> unit end end type quotation = { q_name : string; q_loc : string; q_shift : int; q_contents : string } module type Quotation = sig module Ast : Ast module DynAst : DynAst with module Ast = Ast open Ast type 'a expand_fun = loc -> string option -> string -> 'a val add : string -> 'a DynAst.tag -> 'a expand_fun -> unit val find : string -> 'a DynAst.tag -> 'a expand_fun val default : string ref val parse_quotation_result : (loc -> string -> 'a) -> loc -> quotation -> string -> string -> 'a val translate : (string -> string) ref val expand : loc -> quotation -> 'a DynAst.tag -> 'a val dump_file : (string option) ref module Error : Error end module type Token = sig module Loc : Loc type t val to_string : t -> string val print : Format.formatter -> t -> unit val match_keyword : string -> t -> bool val extract_string : t -> string module Filter : sig type token_filter = (t, Loc.t) stream_filter type t val mk : (string -> bool) -> t val define_filter : t -> (token_filter -> token_filter) -> unit val filter : t -> token_filter val keyword_added : t -> string -> bool -> unit val keyword_removed : t -> string -> unit end module Error : Error end type camlp4_token = | KEYWORD of string | SYMBOL of string | LIDENT of string | UIDENT of string | ESCAPED_IDENT of string | INT of int * string | INT32 of int32 * string | INT64 of int64 * string | NATIVEINT of nativeint * string | FLOAT of float * string | CHAR of char * string | STRING of string * string | LABEL of string | OPTLABEL of string | QUOTATION of quotation | ANTIQUOT of string * string | COMMENT of string | BLANKS of string | NEWLINE | LINE_DIRECTIVE of int * string option | EOI module type Camlp4Token = Token with type t = camlp4_token module type DynLoader = sig type t exception Error of string * string val mk : ?ocaml_stdlib: bool -> ?camlp4_stdlib: bool -> unit -> t val fold_load_path : t -> (string -> 'a -> 'a) -> 'a -> 'a val load : t -> string -> unit val include_dir : t -> string -> unit val find_in_path : t -> string -> string val is_native : bool end module Grammar = struct module type Action = sig type t val mk : 'a -> t val get : t -> 'a val getf : t -> 'a -> 'b val getf2 : t -> 'a -> 'b -> 'c end type assoc = | NonA | RightA | LeftA type position = | First | Last | Before of string | After of string | Level of string module type Structure = sig module Loc : Loc module Action : Action module Token : Token with module Loc = Loc type gram type internal_entry type tree type token_pattern = ((Token.t -> bool) * string) type token_info type token_stream = (Token.t * token_info) Stream.t val token_location : token_info -> Loc.t type symbol = | Smeta of string * symbol list * Action.t | Snterm of internal_entry | Snterml of internal_entry * string | Slist0 of symbol | Slist0sep of symbol * symbol | Slist1 of symbol | Slist1sep of symbol * symbol | Sopt of symbol | Stry of symbol | Sself | Snext | Stoken of token_pattern | Skeyword of string | Stree of tree type production_rule = ((symbol list) * Action.t) type single_extend_statment = ((string option) * (assoc option) * (production_rule list)) type extend_statment = ((position option) * (single_extend_statment list)) type delete_statment = symbol list type ('a, 'b, 'c) fold = internal_entry -> symbol list -> ('a Stream.t -> 'b) -> 'a Stream.t -> 'c type ('a, 'b, 'c) foldsep = internal_entry -> symbol list -> ('a Stream.t -> 'b) -> ('a Stream.t -> unit) -> 'a Stream.t -> 'c end module type Dynamic = sig include Structure val mk : unit -> gram module Entry : sig type 'a t val mk : gram -> string -> 'a t val of_parser : gram -> string -> (token_stream -> 'a) -> 'a t val setup_parser : 'a t -> (token_stream -> 'a) -> unit val name : 'a t -> string val print : Format.formatter -> 'a t -> unit val dump : Format.formatter -> 'a t -> unit val obj : 'a t -> internal_entry val clear : 'a t -> unit end val get_filter : gram -> Token.Filter.t type 'a not_filtered val extend : 'a Entry.t -> extend_statment -> unit val delete_rule : 'a Entry.t -> delete_statment -> unit val srules : 'a Entry.t -> ((symbol list) * Action.t) list -> symbol val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) foldsep val lex : gram -> Loc.t -> char Stream.t -> ((Token.t * Loc.t) Stream.t) not_filtered val lex_string : gram -> Loc.t -> string -> ((Token.t * Loc.t) Stream.t) not_filtered val filter : gram -> ((Token.t * Loc.t) Stream.t) not_filtered -> token_stream val parse : 'a Entry.t -> Loc.t -> char Stream.t -> 'a val parse_string : 'a Entry.t -> Loc.t -> string -> 'a val parse_tokens_before_filter : 'a Entry.t -> ((Token.t * Loc.t) Stream.t) not_filtered -> 'a val parse_tokens_after_filter : 'a Entry.t -> token_stream -> 'a end module type Static = sig include Structure module Entry : sig type 'a t val mk : string -> 'a t val of_parser : string -> (token_stream -> 'a) -> 'a t val setup_parser : 'a t -> (token_stream -> 'a) -> unit val name : 'a t -> string val print : Format.formatter -> 'a t -> unit val dump : Format.formatter -> 'a t -> unit val obj : 'a t -> internal_entry val clear : 'a t -> unit end val get_filter : unit -> Token.Filter.t type 'a not_filtered val extend : 'a Entry.t -> extend_statment -> unit val delete_rule : 'a Entry.t -> delete_statment -> unit val srules : 'a Entry.t -> ((symbol list) * Action.t) list -> symbol val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) foldsep val lex : Loc.t -> char Stream.t -> ((Token.t * Loc.t) Stream.t) not_filtered val lex_string : Loc.t -> string -> ((Token.t * Loc.t) Stream.t) not_filtered val filter : ((Token.t * Loc.t) Stream.t) not_filtered -> token_stream val parse : 'a Entry.t -> Loc.t -> char Stream.t -> 'a val parse_string : 'a Entry.t -> Loc.t -> string -> 'a val parse_tokens_before_filter : 'a Entry.t -> ((Token.t * Loc.t) Stream.t) not_filtered -> 'a val parse_tokens_after_filter : 'a Entry.t -> token_stream -> 'a end end module type Lexer = sig module Loc : Loc module Token : Token with module Loc = Loc module Error : Error val mk : unit -> Loc.t -> char Stream.t -> (Token.t * Loc.t) Stream.t end module Parser (Ast : Ast) = struct module type SIMPLE = sig val parse_expr : Ast.loc -> string -> Ast.expr val parse_patt : Ast.loc -> string -> Ast.patt end module type S = sig val parse_implem : ?directive_handler: (Ast.str_item -> Ast.str_item option) -> Ast.loc -> char Stream.t -> Ast.str_item val parse_interf : ?directive_handler: (Ast.sig_item -> Ast.sig_item option) -> Ast.loc -> char Stream.t -> Ast.sig_item end end module Printer (Ast : Ast) = struct module type S = sig val print_interf : ?input_file: string -> ?output_file: string -> Ast.sig_item -> unit val print_implem : ?input_file: string -> ?output_file: string -> Ast.str_item -> unit end end module type Syntax = sig module Loc : Loc module Ast : Ast with type loc = Loc.t module Token : Token with module Loc = Loc module Gram : Grammar.Static with module Loc = Loc and module Token = Token module Quotation : Quotation with module Ast = Ast module AntiquotSyntax : Parser(Ast).SIMPLE include Warning(Loc).S include Parser(Ast).S include Printer(Ast).S end module type Camlp4Syntax = sig module Loc : Loc module Ast : Camlp4Ast with module Loc = Loc module Token : Camlp4Token with module Loc = Loc module Gram : Grammar.Static with module Loc = Loc and module Token = Token module Quotation : Quotation with module Ast = Camlp4AstToAst(Ast) module AntiquotSyntax : Parser(Ast).SIMPLE include Warning(Loc).S include Parser(Ast).S include Printer(Ast).S val interf : ((Ast.sig_item list) * (Loc.t option)) Gram.Entry.t val implem : ((Ast.str_item list) * (Loc.t option)) Gram.Entry.t val top_phrase : (Ast.str_item option) Gram.Entry.t val use_file : ((Ast.str_item list) * (Loc.t option)) Gram.Entry.t val a_CHAR : string Gram.Entry.t val a_FLOAT : string Gram.Entry.t val a_INT : string Gram.Entry.t val a_INT32 : string Gram.Entry.t val a_INT64 : string Gram.Entry.t val a_LABEL : string Gram.Entry.t val a_LIDENT : string Gram.Entry.t val a_NATIVEINT : string Gram.Entry.t val a_OPTLABEL : string Gram.Entry.t val a_STRING : string Gram.Entry.t val a_UIDENT : string Gram.Entry.t val a_ident : string Gram.Entry.t val amp_ctyp : Ast.ctyp Gram.Entry.t val and_ctyp : Ast.ctyp Gram.Entry.t val match_case : Ast.match_case Gram.Entry.t val match_case0 : Ast.match_case Gram.Entry.t val match_case_quot : Ast.match_case Gram.Entry.t val binding : Ast.binding Gram.Entry.t val binding_quot : Ast.binding Gram.Entry.t val rec_binding_quot : Ast.rec_binding Gram.Entry.t val class_declaration : Ast.class_expr Gram.Entry.t val class_description : Ast.class_type Gram.Entry.t val class_expr : Ast.class_expr Gram.Entry.t val class_expr_quot : Ast.class_expr Gram.Entry.t val class_fun_binding : Ast.class_expr Gram.Entry.t val class_fun_def : Ast.class_expr Gram.Entry.t val class_info_for_class_expr : Ast.class_expr Gram.Entry.t val class_info_for_class_type : Ast.class_type Gram.Entry.t val class_longident : Ast.ident Gram.Entry.t val class_longident_and_param : Ast.class_expr Gram.Entry.t val class_name_and_param : (string * Ast.ctyp) Gram.Entry.t val class_sig_item : Ast.class_sig_item Gram.Entry.t val class_sig_item_quot : Ast.class_sig_item Gram.Entry.t val class_signature : Ast.class_sig_item Gram.Entry.t val class_str_item : Ast.class_str_item Gram.Entry.t val class_str_item_quot : Ast.class_str_item Gram.Entry.t val class_structure : Ast.class_str_item Gram.Entry.t val class_type : Ast.class_type Gram.Entry.t val class_type_declaration : Ast.class_type Gram.Entry.t val class_type_longident : Ast.ident Gram.Entry.t val class_type_longident_and_param : Ast.class_type Gram.Entry.t val class_type_plus : Ast.class_type Gram.Entry.t val class_type_quot : Ast.class_type Gram.Entry.t val comma_ctyp : Ast.ctyp Gram.Entry.t val comma_expr : Ast.expr Gram.Entry.t val comma_ipatt : Ast.patt Gram.Entry.t val comma_patt : Ast.patt Gram.Entry.t val comma_type_parameter : Ast.ctyp Gram.Entry.t val constrain : (Ast.ctyp * Ast.ctyp) Gram.Entry.t val constructor_arg_list : Ast.ctyp Gram.Entry.t val constructor_declaration : Ast.ctyp Gram.Entry.t val constructor_declarations : Ast.ctyp Gram.Entry.t val ctyp : Ast.ctyp Gram.Entry.t val ctyp_quot : Ast.ctyp Gram.Entry.t val cvalue_binding : Ast.expr Gram.Entry.t val direction_flag : Ast.direction_flag Gram.Entry.t val direction_flag_quot : Ast.direction_flag Gram.Entry.t val dummy : unit Gram.Entry.t val eq_expr : (string -> Ast.patt -> Ast.patt) Gram.Entry.t val expr : Ast.expr Gram.Entry.t val expr_eoi : Ast.expr Gram.Entry.t val expr_quot : Ast.expr Gram.Entry.t val field_expr : Ast.rec_binding Gram.Entry.t val field_expr_list : Ast.rec_binding Gram.Entry.t val fun_binding : Ast.expr Gram.Entry.t val fun_def : Ast.expr Gram.Entry.t val ident : Ast.ident Gram.Entry.t val ident_quot : Ast.ident Gram.Entry.t val ipatt : Ast.patt Gram.Entry.t val ipatt_tcon : Ast.patt Gram.Entry.t val label : string Gram.Entry.t val label_declaration : Ast.ctyp Gram.Entry.t val label_declaration_list : Ast.ctyp Gram.Entry.t val label_expr : Ast.rec_binding Gram.Entry.t val label_expr_list : Ast.rec_binding Gram.Entry.t val label_ipatt : Ast.patt Gram.Entry.t val label_ipatt_list : Ast.patt Gram.Entry.t val label_longident : Ast.ident Gram.Entry.t val label_patt : Ast.patt Gram.Entry.t val label_patt_list : Ast.patt Gram.Entry.t val labeled_ipatt : Ast.patt Gram.Entry.t val let_binding : Ast.binding Gram.Entry.t val meth_list : (Ast.ctyp * Ast.row_var_flag) Gram.Entry.t val meth_decl : Ast.ctyp Gram.Entry.t val module_binding : Ast.module_binding Gram.Entry.t val module_binding0 : Ast.module_expr Gram.Entry.t val module_binding_quot : Ast.module_binding Gram.Entry.t val module_declaration : Ast.module_type Gram.Entry.t val module_expr : Ast.module_expr Gram.Entry.t val module_expr_quot : Ast.module_expr Gram.Entry.t val module_longident : Ast.ident Gram.Entry.t val module_longident_with_app : Ast.ident Gram.Entry.t val module_rec_declaration : Ast.module_binding Gram.Entry.t val module_type : Ast.module_type Gram.Entry.t val package_type : Ast.module_type Gram.Entry.t val module_type_quot : Ast.module_type Gram.Entry.t val more_ctyp : Ast.ctyp Gram.Entry.t val name_tags : Ast.ctyp Gram.Entry.t val opt_as_lident : string Gram.Entry.t val opt_class_self_patt : Ast.patt Gram.Entry.t val opt_class_self_type : Ast.ctyp Gram.Entry.t val opt_comma_ctyp : Ast.ctyp Gram.Entry.t val opt_dot_dot : Ast.row_var_flag Gram.Entry.t val row_var_flag_quot : Ast.row_var_flag Gram.Entry.t val opt_eq_ctyp : Ast.ctyp Gram.Entry.t val opt_expr : Ast.expr Gram.Entry.t val opt_meth_list : Ast.ctyp Gram.Entry.t val opt_mutable : Ast.mutable_flag Gram.Entry.t val mutable_flag_quot : Ast.mutable_flag Gram.Entry.t val opt_override : Ast.override_flag Gram.Entry.t val override_flag_quot : Ast.override_flag Gram.Entry.t val opt_polyt : Ast.ctyp Gram.Entry.t val opt_private : Ast.private_flag Gram.Entry.t val private_flag_quot : Ast.private_flag Gram.Entry.t val opt_rec : Ast.rec_flag Gram.Entry.t val rec_flag_quot : Ast.rec_flag Gram.Entry.t val opt_virtual : Ast.virtual_flag Gram.Entry.t val virtual_flag_quot : Ast.virtual_flag Gram.Entry.t val opt_when_expr : Ast.expr Gram.Entry.t val patt : Ast.patt Gram.Entry.t val patt_as_patt_opt : Ast.patt Gram.Entry.t val patt_eoi : Ast.patt Gram.Entry.t val patt_quot : Ast.patt Gram.Entry.t val patt_tcon : Ast.patt Gram.Entry.t val phrase : Ast.str_item Gram.Entry.t val poly_type : Ast.ctyp Gram.Entry.t val row_field : Ast.ctyp Gram.Entry.t val sem_expr : Ast.expr Gram.Entry.t val sem_expr_for_list : (Ast.expr -> Ast.expr) Gram.Entry.t val sem_patt : Ast.patt Gram.Entry.t val sem_patt_for_list : (Ast.patt -> Ast.patt) Gram.Entry.t val semi : unit Gram.Entry.t val sequence : Ast.expr Gram.Entry.t val do_sequence : Ast.expr Gram.Entry.t val sig_item : Ast.sig_item Gram.Entry.t val sig_item_quot : Ast.sig_item Gram.Entry.t val sig_items : Ast.sig_item Gram.Entry.t val star_ctyp : Ast.ctyp Gram.Entry.t val str_item : Ast.str_item Gram.Entry.t val str_item_quot : Ast.str_item Gram.Entry.t val str_items : Ast.str_item Gram.Entry.t val type_constraint : unit Gram.Entry.t val type_declaration : Ast.ctyp Gram.Entry.t val type_ident_and_parameters : (string * (Ast.ctyp list)) Gram.Entry.t val type_kind : Ast.ctyp Gram.Entry.t val type_longident : Ast.ident Gram.Entry.t val type_longident_and_parameters : Ast.ctyp Gram.Entry.t val type_parameter : Ast.ctyp Gram.Entry.t val type_parameters : (Ast.ctyp -> Ast.ctyp) Gram.Entry.t val typevars : Ast.ctyp Gram.Entry.t val val_longident : Ast.ident Gram.Entry.t val value_let : unit Gram.Entry.t val value_val : unit Gram.Entry.t val with_constr : Ast.with_constr Gram.Entry.t val with_constr_quot : Ast.with_constr Gram.Entry.t val prefixop : Ast.expr Gram.Entry.t val infixop0 : Ast.expr Gram.Entry.t val infixop1 : Ast.expr Gram.Entry.t val infixop2 : Ast.expr Gram.Entry.t val infixop3 : Ast.expr Gram.Entry.t val infixop4 : Ast.expr Gram.Entry.t end module type SyntaxExtension = functor (Syn : Syntax) -> Syntax with module Loc = Syn.Loc and module Ast = Syn.Ast and module Token = Syn.Token and module Gram = Syn.Gram and module Quotation = Syn.Quotation end module ErrorHandler : sig val print : Format.formatter -> exn -> unit val try_print : Format.formatter -> exn -> unit val to_string : exn -> string val try_to_string : exn -> string val register : (Format.formatter -> exn -> unit) -> unit module Register (Error : Sig.Error) : sig end module ObjTools : sig val print : Format.formatter -> Obj.t -> unit val print_desc : Format.formatter -> Obj.t -> unit val to_string : Obj.t -> string val desc : Obj.t -> string end end = struct open Format module ObjTools = struct let desc obj = if Obj.is_block obj then "tag = " ^ (string_of_int (Obj.tag obj)) else "int_val = " ^ (string_of_int (Obj.obj obj)) let rec to_string r = if Obj.is_int r then (let i : int = Obj.magic r in (string_of_int i) ^ (" | CstTag" ^ (string_of_int (i + 1)))) else (let rec get_fields acc = function | 0 -> acc | n -> let n = n - 1 in get_fields ((Obj.field r n) :: acc) n in let rec is_list r = if Obj.is_int r then r = (Obj.repr 0) else (let s = Obj.size r and t = Obj.tag r in (t = 0) && ((s = 2) && (is_list (Obj.field r 1)))) in let rec get_list r = if Obj.is_int r then [] else (let h = Obj.field r 0 and t = get_list (Obj.field r 1) in h :: t) in let opaque name = "<" ^ (name ^ ">") in let s = Obj.size r and t = Obj.tag r in match t with | _ when is_list r -> let fields = get_list r in "[" ^ ((String.concat "; " (List.map to_string fields)) ^ "]") | 0 -> let fields = get_fields [] s in "(" ^ ((String.concat ", " (List.map to_string fields)) ^ ")") | x when x = Obj.lazy_tag -> opaque "lazy" | x when x = Obj.closure_tag -> opaque "closure" | x when x = Obj.object_tag -> let fields = get_fields [] s in let (_class, id, slots) = (match fields with | h :: h' :: t -> (h, h', t) | _ -> assert false) in "Object #" ^ ((to_string id) ^ (" (" ^ ((String.concat ", " (List.map to_string slots)) ^ ")"))) | x when x = Obj.infix_tag -> opaque "infix" | x when x = Obj.forward_tag -> opaque "forward" | x when x < Obj.no_scan_tag -> let fields = get_fields [] s in "Tag" ^ ((string_of_int t) ^ (" (" ^ ((String.concat ", " (List.map to_string fields)) ^ ")"))) | x when x = Obj.string_tag -> "\"" ^ ((String.escaped (Obj.magic r : string)) ^ "\"") | x when x = Obj.double_tag -> Camlp4_import.Oprint.float_repres (Obj.magic r : float) | x when x = Obj.abstract_tag -> opaque "abstract" | x when x = Obj.custom_tag -> opaque "custom" | x when x = Obj.final_tag -> opaque "final" | _ -> failwith ("ObjTools.to_string: unknown tag (" ^ ((string_of_int t) ^ ")"))) let print ppf x = fprintf ppf "%s" (to_string x) let print_desc ppf x = fprintf ppf "%s" (desc x) end let default_handler ppf x = let x = Obj.repr x in (fprintf ppf "Camlp4: Uncaught exception: %s" (Obj.obj (Obj.field (Obj.field x 0) 0) : string); if (Obj.size x) > 1 then (pp_print_string ppf " ("; for i = 1 to (Obj.size x) - 1 do if i > 1 then pp_print_string ppf ", " else (); ObjTools.print ppf (Obj.field x i) done; pp_print_char ppf ')') else (); fprintf ppf "@.") let handler = ref (fun ppf default_handler exn -> default_handler ppf exn) let register f = let current_handler = !handler in handler := fun ppf default_handler exn -> try f ppf exn with | exn -> current_handler ppf default_handler exn module Register (Error : Sig.Error) = struct let _ = let current_handler = !handler in handler := fun ppf default_handler -> function | Error.E x -> Error.print ppf x | x -> current_handler ppf default_handler x end let gen_print ppf default_handler = function | Out_of_memory -> fprintf ppf "Out of memory" | Assert_failure ((file, line, char)) -> fprintf ppf "Assertion failed, file %S, line %d, char %d" file line char | Match_failure ((file, line, char)) -> fprintf ppf "Pattern matching failed, file %S, line %d, char %d" file line char | Failure str -> fprintf ppf "Failure: %S" str | Invalid_argument str -> fprintf ppf "Invalid argument: %S" str | Sys_error str -> fprintf ppf "I/O error: %S" str | Stream.Failure -> fprintf ppf "Parse failure" | Stream.Error str -> fprintf ppf "Parse error: %s" str | x -> !handler ppf default_handler x let print ppf = gen_print ppf default_handler let try_print ppf = gen_print ppf (fun _ -> raise) let to_string exn = let buf = Buffer.create 128 in let () = bprintf buf "%a" print exn in Buffer.contents buf let try_to_string exn = let buf = Buffer.create 128 in let () = bprintf buf "%a" try_print exn in Buffer.contents buf end module Struct = struct module Loc : sig include Sig.Loc end = struct open Format type pos = { line : int; bol : int; off : int } type t = { file_name : string; start : pos; stop : pos; ghost : bool } let dump_sel f x = let s = match x with | `start -> "`start" | `stop -> "`stop" | `both -> "`both" | _ -> "" in pp_print_string f s let dump_pos f x = fprintf f "@[{ line = %d ;@ bol = %d ;@ off = %d } : pos@]" x.line x.bol x.off let dump_long f x = fprintf f "@[{ file_name = %s ;@ start = %a (%d-%d);@ stop = %a (%d);@ ghost = %b@ } : Loc.t@]" x.file_name dump_pos x.start (x.start.off - x.start.bol) (x.stop.off - x.start.bol) dump_pos x.stop (x.stop.off - x.stop.bol) x.ghost let dump f x = fprintf f "[%S: %d:%d-%d %d:%d%t]" x.file_name x.start.line (x.start.off - x.start.bol) (x.stop.off - x.start.bol) x.stop.line (x.stop.off - x.stop.bol) (fun o -> if x.ghost then fprintf o " (ghost)" else ()) let start_pos = { line = 1; bol = 0; off = 0; } let ghost = { file_name = "ghost-location"; start = start_pos; stop = start_pos; ghost = true; } let mk file_name = { file_name = file_name; start = start_pos; stop = start_pos; ghost = false; } let of_tuple (file_name, start_line, start_bol, start_off, stop_line, stop_bol, stop_off, ghost) = { file_name = file_name; start = { line = start_line; bol = start_bol; off = start_off; }; stop = { line = stop_line; bol = stop_bol; off = stop_off; }; ghost = ghost; } let to_tuple { file_name = file_name; start = { line = start_line; bol = start_bol; off = start_off }; stop = { line = stop_line; bol = stop_bol; off = stop_off }; ghost = ghost } = (file_name, start_line, start_bol, start_off, stop_line, stop_bol, stop_off, ghost) let pos_of_lexing_position p = let pos = { line = p.Lexing.pos_lnum; bol = p.Lexing.pos_bol; off = p.Lexing.pos_cnum; } in pos let pos_to_lexing_position p file_name = { Lexing.pos_fname = file_name; pos_lnum = p.line; pos_bol = p.bol; pos_cnum = p.off; } let better_file_name a b = match (a, b) with | ("", "") -> a | ("", x) -> x | (x, "") -> x | ("-", x) -> x | (x, "-") -> x | (x, _) -> x let of_lexbuf lb = let start = Lexing.lexeme_start_p lb and stop = Lexing.lexeme_end_p lb in let loc = { file_name = better_file_name start.Lexing.pos_fname stop.Lexing.pos_fname; start = pos_of_lexing_position start; stop = pos_of_lexing_position stop; ghost = false; } in loc let of_lexing_position pos = let loc = { file_name = pos.Lexing.pos_fname; start = pos_of_lexing_position pos; stop = pos_of_lexing_position pos; ghost = false; } in loc let to_ocaml_location x = { Camlp4_import.Location.loc_start = pos_to_lexing_position x.start x.file_name; loc_end = pos_to_lexing_position x.stop x.file_name; loc_ghost = x.ghost; } let of_ocaml_location { Camlp4_import.Location.loc_start = a; loc_end = b; loc_ghost = g } = let res = { file_name = better_file_name a.Lexing.pos_fname b.Lexing.pos_fname; start = pos_of_lexing_position a; stop = pos_of_lexing_position b; ghost = g; } in res let start_pos x = pos_to_lexing_position x.start x.file_name let stop_pos x = pos_to_lexing_position x.stop x.file_name let merge a b = if a == b then a else (let r = match ((a.ghost), (b.ghost)) with | (false, false) -> { (a) with stop = b.stop; } | (true, true) -> { (a) with stop = b.stop; } | (true, _) -> { (a) with stop = b.stop; } | (_, true) -> { (b) with start = a.start; } in r) let join x = { (x) with stop = x.start; } let map f start_stop_both x = match start_stop_both with | `start -> { (x) with start = f x.start; } | `stop -> { (x) with stop = f x.stop; } | `both -> { (x) with start = f x.start; stop = f x.stop; } let move_pos chars x = { (x) with off = x.off + chars; } let move s chars x = map (move_pos chars) s x let move_line lines x = let move_line_pos x = { (x) with line = x.line + lines; bol = x.off; } in map move_line_pos `both x let shift width x = { (x) with start = x.stop; stop = move_pos width x.stop; } let file_name x = x.file_name let start_line x = x.start.line let stop_line x = x.stop.line let start_bol x = x.start.bol let stop_bol x = x.stop.bol let start_off x = x.start.off let stop_off x = x.stop.off let is_ghost x = x.ghost let set_file_name s x = { (x) with file_name = s; } let ghostify x = { (x) with ghost = true; } let make_absolute x = let pwd = Sys.getcwd () in if Filename.is_relative x.file_name then { (x) with file_name = Filename.concat pwd x.file_name; } else x let strictly_before x y = let b = (x.stop.off < y.start.off) && (x.file_name = y.file_name) in b let to_string x = let (a, b) = ((x.start), (x.stop)) in let res = sprintf "File \"%s\", line %d, characters %d-%d" x.file_name a.line (a.off - a.bol) (b.off - a.bol) in if x.start.line <> x.stop.line then sprintf "%s (end at line %d, character %d)" res x.stop.line (b.off - b.bol) else res let print out x = pp_print_string out (to_string x) let check x msg = if ((start_line x) > (stop_line x)) || (((start_bol x) > (stop_bol x)) || (((start_off x) > (stop_off x)) || (((start_line x) < 0) || (((stop_line x) < 0) || (((start_bol x) < 0) || (((stop_bol x) < 0) || (((start_off x) < 0) || ((stop_off x) < 0)))))))) then (eprintf "*** Warning: (%s) strange positions ***\n%a@\n" msg print x; false) else true exception Exc_located of t * exn let _ = ErrorHandler.register (fun ppf -> function | Exc_located (loc, exn) -> fprintf ppf "%a:@\n%a" print loc ErrorHandler.print exn | exn -> raise exn) let name = ref "_loc" let raise loc exc = match exc with | Exc_located (_, _) -> raise exc | _ -> raise (Exc_located (loc, exc)) end module Token : sig module Make (Loc : Sig.Loc) : Sig.Camlp4Token with module Loc = Loc module Eval : sig val char : string -> char val string : ?strict: unit -> string -> string end end = struct open Format module Make (Loc : Sig.Loc) : Sig.Camlp4Token with module Loc = Loc = struct module Loc = Loc open Sig type t = camlp4_token type token = t let to_string = function | KEYWORD s -> sprintf "KEYWORD %S" s | SYMBOL s -> sprintf "SYMBOL %S" s | LIDENT s -> sprintf "LIDENT %S" s | UIDENT s -> sprintf "UIDENT %S" s | INT (_, s) -> sprintf "INT %s" s | INT32 (_, s) -> sprintf "INT32 %sd" s | INT64 (_, s) -> sprintf "INT64 %sd" s | NATIVEINT (_, s) -> sprintf "NATIVEINT %sd" s | FLOAT (_, s) -> sprintf "FLOAT %s" s | CHAR (_, s) -> sprintf "CHAR '%s'" s | STRING (_, s) -> sprintf "STRING \"%s\"" s | LABEL s -> sprintf "LABEL %S" s | OPTLABEL s -> sprintf "OPTLABEL %S" s | ANTIQUOT (n, s) -> sprintf "ANTIQUOT %s: %S" n s | QUOTATION x -> sprintf "QUOTATION { q_name=%S; q_loc=%S; q_shift=%d; q_contents=%S }" x.q_name x.q_loc x.q_shift x.q_contents | COMMENT s -> sprintf "COMMENT %S" s | BLANKS s -> sprintf "BLANKS %S" s | NEWLINE -> sprintf "NEWLINE" | EOI -> sprintf "EOI" | ESCAPED_IDENT s -> sprintf "ESCAPED_IDENT %S" s | LINE_DIRECTIVE (i, None) -> sprintf "LINE_DIRECTIVE %d" i | LINE_DIRECTIVE (i, (Some s)) -> sprintf "LINE_DIRECTIVE %d %S" i s let print ppf x = pp_print_string ppf (to_string x) let match_keyword kwd = function | KEYWORD kwd' when kwd = kwd' -> true | _ -> false let extract_string = function | KEYWORD s | SYMBOL s | LIDENT s | UIDENT s | INT (_, s) | INT32 (_, s) | INT64 (_, s) | NATIVEINT (_, s) | FLOAT (_, s) | CHAR (_, s) | STRING (_, s) | LABEL s | OPTLABEL s | COMMENT s | BLANKS s | ESCAPED_IDENT s -> s | tok -> invalid_arg ("Cannot extract a string from this token: " ^ (to_string tok)) module Error = struct type t = | Illegal_token of string | Keyword_as_label of string | Illegal_token_pattern of string * string | Illegal_constructor of string exception E of t let print ppf = function | Illegal_token s -> fprintf ppf "Illegal token (%s)" s | Keyword_as_label kwd -> fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd | Illegal_token_pattern (p_con, p_prm) -> fprintf ppf "Illegal token pattern: %s %S" p_con p_prm | Illegal_constructor con -> fprintf ppf "Illegal constructor %S" con let to_string x = let b = Buffer.create 50 in let () = bprintf b "%a" print x in Buffer.contents b end let _ = let module M = ErrorHandler.Register(Error) in () module Filter = struct type token_filter = (t, Loc.t) stream_filter type t = { is_kwd : string -> bool; mutable filter : token_filter } let err error loc = raise (Loc.Exc_located (loc, (Error.E error))) let keyword_conversion tok is_kwd = match tok with | SYMBOL s | LIDENT s | UIDENT s when is_kwd s -> KEYWORD s | ESCAPED_IDENT s -> LIDENT s | _ -> tok let check_keyword_as_label tok loc is_kwd = let s = match tok with | LABEL s -> s | OPTLABEL s -> s | _ -> "" in if (s <> "") && (is_kwd s) then err (Error.Keyword_as_label s) loc else () let check_unknown_keywords tok loc = match tok with | SYMBOL s -> err (Error.Illegal_token s) loc | _ -> () let error_no_respect_rules p_con p_prm = raise (Error.E (Error.Illegal_token_pattern (p_con, p_prm))) let check_keyword _ = true let error_on_unknown_keywords = ref false let rec ignore_layout (__strm : _ Stream.t) = match Stream.peek __strm with | Some (((COMMENT _ | BLANKS _ | NEWLINE | LINE_DIRECTIVE (_, _)), _)) -> (Stream.junk __strm; ignore_layout __strm) | Some x -> (Stream.junk __strm; let s = __strm in Stream.icons x (Stream.slazy (fun _ -> ignore_layout s))) | _ -> Stream.sempty let mk is_kwd = { is_kwd = is_kwd; filter = ignore_layout; } let filter x = let f tok loc = let tok = keyword_conversion tok x.is_kwd in (check_keyword_as_label tok loc x.is_kwd; if !error_on_unknown_keywords then check_unknown_keywords tok loc else (); (tok, loc)) in let rec filter (__strm : _ Stream.t) = match Stream.peek __strm with | Some ((tok, loc)) -> (Stream.junk __strm; let s = __strm in Stream.lcons (fun _ -> f tok loc) (Stream.slazy (fun _ -> filter s))) | _ -> Stream.sempty in let rec tracer (__strm : _ Stream.t) = match Stream.peek __strm with | Some (((_tok, _loc) as x)) -> (Stream.junk __strm; let xs = __strm in Stream.icons x (Stream.slazy (fun _ -> tracer xs))) | _ -> Stream.sempty in fun strm -> tracer (x.filter (filter strm)) let define_filter x f = x.filter <- f x.filter let keyword_added _ _ _ = () let keyword_removed _ _ = () end end module Eval = struct let valch x = (Char.code x) - (Char.code '0') let valch_hex x = let d = Char.code x in if d >= 97 then d - 87 else if d >= 65 then d - 55 else d - 48 let rec skip_indent (__strm : _ Stream.t) = match Stream.peek __strm with | Some (' ' | '\t') -> (Stream.junk __strm; skip_indent __strm) | _ -> () let skip_opt_linefeed (__strm : _ Stream.t) = match Stream.peek __strm with | Some '\n' -> (Stream.junk __strm; ()) | _ -> () let chr c = if (c < 0) || (c > 255) then failwith "invalid char token" else Char.chr c let rec backslash (__strm : _ Stream.t) = match Stream.peek __strm with | Some '\n' -> (Stream.junk __strm; '\n') | Some '\r' -> (Stream.junk __strm; '\r') | Some 'n' -> (Stream.junk __strm; '\n') | Some 'r' -> (Stream.junk __strm; '\r') | Some 't' -> (Stream.junk __strm; '\t') | Some 'b' -> (Stream.junk __strm; '\b') | Some '\\' -> (Stream.junk __strm; '\\') | Some '"' -> (Stream.junk __strm; '"') | Some '\'' -> (Stream.junk __strm; '\'') | Some ' ' -> (Stream.junk __strm; ' ') | Some (('0' .. '9' as c1)) -> (Stream.junk __strm; (match Stream.peek __strm with | Some (('0' .. '9' as c2)) -> (Stream.junk __strm; (match Stream.peek __strm with | Some (('0' .. '9' as c3)) -> (Stream.junk __strm; chr (((100 * (valch c1)) + (10 * (valch c2))) + (valch c3))) | _ -> raise (Stream.Error ""))) | _ -> raise (Stream.Error ""))) | Some 'x' -> (Stream.junk __strm; (match Stream.peek __strm with | Some (('0' .. '9' | 'a' .. 'f' | 'A' .. 'F' as c1)) -> (Stream.junk __strm; (match Stream.peek __strm with | Some (('0' .. '9' | 'a' .. 'f' | 'A' .. 'F' as c2)) -> (Stream.junk __strm; chr ((16 * (valch_hex c1)) + (valch_hex c2))) | _ -> raise (Stream.Error ""))) | _ -> raise (Stream.Error ""))) | _ -> raise Stream.Failure let rec backslash_in_string strict store (__strm : _ Stream.t) = match Stream.peek __strm with | Some '\n' -> (Stream.junk __strm; skip_indent __strm) | Some '\r' -> (Stream.junk __strm; let s = __strm in (skip_opt_linefeed s; skip_indent s)) | _ -> (match try Some (backslash __strm) with | Stream.Failure -> None with | Some x -> store x | _ -> (match Stream.peek __strm with | Some c when not strict -> (Stream.junk __strm; store '\\'; store c) | _ -> failwith "invalid string token")) let char s = if (String.length s) = 1 then s.[0] else if (String.length s) = 0 then failwith "invalid char token" else (let (__strm : _ Stream.t) = Stream.of_string s in match Stream.peek __strm with | Some '\\' -> (Stream.junk __strm; (try backslash __strm with | Stream.Failure -> raise (Stream.Error ""))) | _ -> failwith "invalid char token") let string ?strict s = let buf = Buffer.create 23 in let store = Buffer.add_char buf in let rec parse (__strm : _ Stream.t) = match Stream.peek __strm with | Some '\\' -> (Stream.junk __strm; let _ = (try backslash_in_string (strict <> None) store __strm with | Stream.Failure -> raise (Stream.Error "")) in parse __strm) | Some c -> (Stream.junk __strm; let s = __strm in (store c; parse s)) | _ -> Buffer.contents buf in parse (Stream.of_string s) end end module Lexer = struct module TokenEval = Token.Eval module Make (Token : Sig.Camlp4Token) = struct module Loc = Token.Loc module Token = Token open Lexing open Sig module Error = struct type t = | Illegal_character of char | Illegal_escape of string | Unterminated_comment | Unterminated_string | Unterminated_quotation | Unterminated_antiquot | Unterminated_string_in_comment | Comment_start | Comment_not_end | Literal_overflow of string exception E of t open Format let print ppf = function | Illegal_character c -> fprintf ppf "Illegal character (%s)" (Char.escaped c) | Illegal_escape s -> fprintf ppf "Illegal backslash escape in string or character (%s)" s | Unterminated_comment -> fprintf ppf "Comment not terminated" | Unterminated_string -> fprintf ppf "String literal not terminated" | Unterminated_string_in_comment -> fprintf ppf "This comment contains an unterminated string literal" | Unterminated_quotation -> fprintf ppf "Quotation not terminated" | Unterminated_antiquot -> fprintf ppf "Antiquotation not terminated" | Literal_overflow ty -> fprintf ppf "Integer literal exceeds the range of representable integers of type %s" ty | Comment_start -> fprintf ppf "this is the start of a comment" | Comment_not_end -> fprintf ppf "this is not the end of a comment" let to_string x = let b = Buffer.create 50 in let () = bprintf b "%a" print x in Buffer.contents b end let _ = let module M = ErrorHandler.Register(Error) in () open Error type context = { loc : Loc.t; in_comment : bool; quotations : bool; antiquots : bool; lexbuf : lexbuf; buffer : Buffer.t } let default_context lb = { loc = Loc.ghost; in_comment = false; quotations = true; antiquots = false; lexbuf = lb; buffer = Buffer.create 256; } let store c = Buffer.add_string c.buffer (Lexing.lexeme c.lexbuf) let istore_char c i = Buffer.add_char c.buffer (Lexing.lexeme_char c.lexbuf i) let buff_contents c = let contents = Buffer.contents c.buffer in (Buffer.reset c.buffer; contents) let loc c = Loc.merge c.loc (Loc.of_lexbuf c.lexbuf) let quotations c = c.quotations let antiquots c = c.antiquots let is_in_comment c = c.in_comment let in_comment c = { (c) with in_comment = true; } let set_start_p c = c.lexbuf.lex_start_p <- Loc.start_pos c.loc let move_start_p shift c = let p = c.lexbuf.lex_start_p in c.lexbuf.lex_start_p <- { (p) with pos_cnum = p.pos_cnum + shift; } let update_loc c = { (c) with loc = Loc.of_lexbuf c.lexbuf; } let with_curr_loc f c = f (update_loc c) c.lexbuf let parse_nested f c = (with_curr_loc f c; set_start_p c; buff_contents c) let shift n c = { (c) with loc = Loc.move `both n c.loc; } let store_parse f c = (store c; f c c.lexbuf) let parse f c = f c c.lexbuf let mk_quotation quotation c name loc shift = let s = parse_nested quotation (update_loc c) in let contents = String.sub s 0 ((String.length s) - 2) in QUOTATION { q_name = name; q_loc = loc; q_shift = shift; q_contents = contents; } let update_loc c file line absolute chars = let lexbuf = c.lexbuf in let pos = lexbuf.lex_curr_p in let new_file = match file with | None -> pos.pos_fname | Some s -> s in lexbuf.lex_curr_p <- { (pos) with pos_fname = new_file; pos_lnum = if absolute then line else pos.pos_lnum + line; pos_bol = pos.pos_cnum - chars; } let cvt_int_literal s = - (int_of_string ("-" ^ s)) let cvt_int32_literal s = Int32.neg (Int32.of_string ("-" ^ s)) let cvt_int64_literal s = Int64.neg (Int64.of_string ("-" ^ s)) let cvt_nativeint_literal s = Nativeint.neg (Nativeint.of_string ("-" ^ s)) let err error loc = raise (Loc.Exc_located (loc, (Error.E error))) let warn error loc = Format.eprintf "Warning: %a: %a@." Loc.print loc Error.print error let __ocaml_lex_tables = { Lexing.lex_base = "\000\000\223\255\224\255\224\000\226\255\253\000\035\001\072\001\ \109\001\146\001\091\000\183\001\068\000\190\001\218\001\227\255\ \122\000\002\002\071\002\110\002\176\000\244\255\129\002\162\002\ \235\002\187\003\154\004\246\004\124\000\001\000\255\255\198\005\ \253\255\150\006\252\255\245\255\246\255\247\255\253\000\224\000\ \086\000\091\000\054\003\006\004\029\002\237\001\182\004\109\000\ \118\007\091\000\253\000\093\000\243\255\242\255\241\255\106\005\ \077\003\108\000\087\003\017\006\151\007\218\007\001\008\068\008\ \107\008\107\000\239\255\126\008\075\001\210\008\249\008\060\009\ \232\255\231\255\230\255\099\009\166\009\205\009\016\010\055\010\ \249\001\228\255\229\255\238\255\090\010\127\010\164\010\201\010\ \238\010\019\011\056\011\091\011\128\011\165\011\202\011\239\011\ \020\012\057\012\094\012\011\007\136\005\004\000\233\255\008\000\ \054\001\245\002\009\000\005\000\233\255\131\012\138\012\175\012\ \212\012\249\012\000\013\037\013\068\013\096\013\133\013\138\013\ \205\013\242\013\023\014\085\014\241\255\006\000\242\255\243\255\ \148\002\251\255\047\015\123\000\109\000\125\000\255\255\254\255\ \253\255\111\015\046\016\254\016\206\017\174\018\129\000\017\001\ \130\000\141\000\249\255\248\255\247\255\237\006\109\003\143\000\ \246\255\035\004\145\000\245\255\160\014\149\000\244\255\086\004\ \247\255\248\255\007\000\249\255\201\018\255\255\250\255\121\016\ \154\004\253\255\091\001\057\001\171\004\252\255\073\017\251\255\ \240\018\051\019\018\020\048\020\255\255\015\021\238\021\015\022\ \079\022\255\255\031\023\254\255\164\001\251\255\010\000\252\255\ \253\255\128\000\079\001\255\255\095\023\030\024\238\024\190\025\ \254\255\190\026\253\255\254\255\153\001\143\027\110\028\255\255\ \167\001\062\029\206\001\251\255\080\001\013\000\253\255\254\255\ \255\255\252\255\126\029\061\030\013\031\221\031"; Lexing.lex_backtrk = "\255\255\255\255\255\255\030\000\255\255\028\000\030\000\030\000\ \030\000\030\000\028\000\028\000\028\000\028\000\028\000\255\255\ \028\000\030\000\030\000\028\000\028\000\255\255\006\000\006\000\ \005\000\004\000\030\000\030\000\001\000\000\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\007\000\ \255\255\255\255\255\255\006\000\006\000\006\000\007\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\014\000\ \014\000\014\000\255\255\255\255\255\255\255\255\255\255\028\000\ \028\000\015\000\255\255\028\000\255\255\255\255\028\000\255\255\ \255\255\255\255\255\255\028\000\028\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\030\000\021\000\020\000\ \018\000\030\000\018\000\018\000\018\000\018\000\028\000\018\000\ \255\255\019\000\030\000\255\255\255\255\022\000\255\255\255\255\ \255\255\255\255\255\255\022\000\255\255\255\255\255\255\255\255\ \028\000\255\255\028\000\255\255\028\000\028\000\028\000\028\000\ \030\000\030\000\030\000\255\255\255\255\013\000\255\255\255\255\ \014\000\255\255\003\000\014\000\014\000\014\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\005\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\006\000\255\255\008\000\255\255\255\255\005\000\ \005\000\255\255\001\000\001\000\255\255\255\255\255\255\255\255\ \000\000\001\000\001\000\255\255\255\255\002\000\002\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\003\000\255\255\ \255\255\004\000\004\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\002\000\002\000\002\000\255\255\ \255\255\255\255\255\255\255\255\004\000\002\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255"; Lexing.lex_default = "\001\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\000\000\ \255\255\255\255\255\255\255\255\049\000\000\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\000\000\255\255\ \000\000\255\255\000\000\000\000\000\000\000\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \054\000\255\255\255\255\255\255\000\000\000\000\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\255\255\255\255\255\255\ \000\000\000\000\000\000\255\255\255\255\255\255\255\255\255\255\ \255\255\000\000\000\000\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\103\000\255\255\255\255\000\000\103\000\ \104\000\103\000\106\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\124\000\000\000\255\255\000\000\000\000\ \142\000\000\000\255\255\255\255\255\255\255\255\000\000\000\000\ \000\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\000\000\000\000\000\000\255\255\255\255\255\255\ \000\000\255\255\255\255\000\000\255\255\255\255\000\000\160\000\ \000\000\000\000\255\255\000\000\166\000\000\000\000\000\255\255\ \255\255\000\000\255\255\255\255\255\255\000\000\255\255\000\000\ \255\255\255\255\255\255\255\255\000\000\255\255\255\255\255\255\ \255\255\000\000\255\255\000\000\189\000\000\000\255\255\000\000\ \000\000\255\255\255\255\000\000\255\255\255\255\255\255\255\255\ \000\000\205\000\000\000\000\000\255\255\255\255\255\255\000\000\ \255\255\255\255\211\000\000\000\255\255\255\255\000\000\000\000\ \000\000\000\000\255\255\255\255\255\255\255\255"; Lexing.lex_trans = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\028\000\030\000\030\000\028\000\029\000\102\000\108\000\ \126\000\163\000\102\000\108\000\191\000\101\000\107\000\214\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \028\000\003\000\021\000\016\000\004\000\009\000\009\000\020\000\ \019\000\005\000\018\000\003\000\015\000\003\000\014\000\009\000\ \023\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\013\000\012\000\017\000\006\000\007\000\026\000\ \009\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\011\000\003\000\005\000\009\000\025\000\ \015\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\010\000\008\000\005\000\027\000\015\000\ \117\000\117\000\053\000\100\000\052\000\028\000\045\000\045\000\ \028\000\115\000\117\000\044\000\044\000\044\000\044\000\044\000\ \044\000\044\000\044\000\053\000\066\000\118\000\135\000\116\000\ \115\000\115\000\100\000\117\000\028\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\134\000\ \148\000\147\000\099\000\099\000\099\000\099\000\099\000\099\000\ \099\000\099\000\099\000\099\000\146\000\138\000\152\000\136\000\ \155\000\117\000\051\000\137\000\158\000\050\000\200\000\000\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\118\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\000\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \002\000\003\000\000\000\000\000\003\000\003\000\003\000\051\000\ \255\255\255\255\003\000\003\000\048\000\003\000\003\000\003\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\003\000\144\000\003\000\003\000\003\000\003\000\ \003\000\000\000\096\000\096\000\052\000\038\000\084\000\000\000\ \047\000\000\000\047\000\084\000\096\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\084\000\ \147\000\084\000\084\000\084\000\003\000\096\000\003\000\039\000\ \102\000\000\000\171\000\101\000\003\000\038\000\000\000\003\000\ \009\000\009\000\000\000\000\000\084\000\003\000\003\000\000\000\ \003\000\006\000\009\000\000\000\068\000\000\000\000\000\068\000\ \106\000\171\000\084\000\096\000\003\000\085\000\003\000\006\000\ \006\000\006\000\003\000\009\000\171\000\171\000\000\000\000\000\ \000\000\003\000\000\000\068\000\003\000\121\000\121\000\000\000\ \000\000\084\000\003\000\003\000\074\000\003\000\007\000\121\000\ \000\000\084\000\084\000\171\000\000\000\000\000\000\000\003\000\ \084\000\009\000\120\000\000\000\007\000\007\000\007\000\003\000\ \121\000\197\000\219\000\195\000\217\000\000\000\003\000\196\000\ \218\000\003\000\009\000\009\000\000\000\000\000\005\000\003\000\ \003\000\000\000\003\000\006\000\009\000\000\000\000\000\085\000\ \084\000\003\000\000\000\000\000\003\000\005\000\121\000\085\000\ \000\000\006\000\006\000\006\000\003\000\009\000\191\000\000\000\ \255\255\190\000\000\000\003\000\000\000\000\000\003\000\009\000\ \009\000\000\000\208\000\094\000\003\000\003\000\000\000\003\000\ \009\000\009\000\000\000\000\000\120\000\005\000\003\000\208\000\ \208\000\003\000\005\000\009\000\098\000\000\000\009\000\009\000\ \009\000\003\000\009\000\203\000\000\000\208\000\000\000\000\000\ \214\000\000\000\000\000\213\000\117\000\117\000\000\000\000\000\ \194\000\203\000\193\000\111\000\111\000\115\000\117\000\005\000\ \000\000\085\000\005\000\003\000\109\000\111\000\003\000\094\000\ \009\000\116\000\216\000\116\000\115\000\115\000\000\000\117\000\ \114\000\000\000\109\000\112\000\112\000\000\000\111\000\111\000\ \111\000\000\000\080\000\084\000\000\000\080\000\000\000\000\000\ \112\000\111\000\212\000\000\000\000\000\000\000\098\000\094\000\ \003\000\000\000\000\000\000\000\110\000\117\000\109\000\109\000\ \109\000\080\000\111\000\005\000\111\000\045\000\045\000\000\000\ \000\000\000\000\081\000\003\000\000\000\000\000\003\000\009\000\ \009\000\000\000\000\000\084\000\003\000\003\000\000\000\003\000\ \006\000\009\000\000\000\116\000\000\000\000\000\255\255\084\000\ \111\000\036\000\110\000\005\000\086\000\000\000\088\000\006\000\ \006\000\003\000\087\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\045\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\000\000\110\000\084\000\ \000\000\037\000\000\000\035\000\000\000\000\000\003\000\084\000\ \009\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \003\000\036\000\000\000\003\000\003\000\003\000\000\000\000\000\ \083\000\003\000\003\000\000\000\003\000\003\000\003\000\060\000\ \000\000\000\000\060\000\000\000\044\000\000\000\085\000\084\000\ \003\000\003\000\000\000\003\000\003\000\003\000\003\000\003\000\ \000\000\037\000\000\000\035\000\000\000\000\000\060\000\061\000\ \000\000\000\000\061\000\064\000\064\000\000\000\000\000\000\000\ \065\000\061\000\000\000\061\000\062\000\064\000\144\000\000\000\ \000\000\143\000\000\000\003\000\192\000\003\000\000\000\000\000\ \063\000\000\000\062\000\062\000\062\000\061\000\064\000\039\000\ \000\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\145\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\003\000\000\000\003\000\038\000\000\000\ \000\000\000\000\061\000\000\000\064\000\036\000\215\000\000\000\ \039\000\000\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\022\000\000\000\000\000\000\000\000\000\ \022\000\000\000\000\000\000\000\040\000\000\000\038\000\038\000\ \000\000\000\000\063\000\000\000\061\000\037\000\036\000\035\000\ \141\000\041\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\042\000\000\000\000\000\000\000\105\000\102\000\ \000\000\022\000\101\000\000\000\040\000\000\000\000\000\038\000\ \000\000\000\000\000\000\000\000\000\000\000\000\037\000\000\000\ \035\000\041\000\024\000\000\000\000\000\105\000\000\000\104\000\ \000\000\000\000\042\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\000\000\000\000\ \000\000\000\000\024\000\000\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\043\000\ \043\000\043\000\043\000\043\000\043\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\000\000\000\000\000\000\255\255\000\000\000\000\043\000\ \043\000\043\000\043\000\043\000\043\000\153\000\153\000\153\000\ \153\000\153\000\153\000\153\000\153\000\153\000\153\000\000\000\ \000\000\000\000\000\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\000\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\025\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\255\255\000\000\000\000\ \000\000\000\000\000\000\000\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\000\000\000\000\ \000\000\000\000\025\000\000\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\043\000\ \043\000\043\000\043\000\043\000\043\000\000\000\000\000\000\000\ \000\000\000\000\036\000\154\000\154\000\154\000\154\000\154\000\ \154\000\154\000\154\000\154\000\154\000\000\000\000\000\000\000\ \163\000\000\000\000\000\162\000\000\000\043\000\000\000\043\000\ \043\000\043\000\043\000\043\000\043\000\000\000\000\000\000\000\ \000\000\000\000\037\000\000\000\035\000\000\000\000\000\000\000\ \165\000\000\000\000\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\000\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\164\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\003\000\000\000\000\000\003\000\003\000\ \003\000\000\000\000\000\000\000\003\000\003\000\000\000\003\000\ \003\000\003\000\172\000\172\000\172\000\172\000\172\000\172\000\ \172\000\172\000\172\000\172\000\003\000\000\000\003\000\003\000\ \003\000\003\000\003\000\173\000\173\000\173\000\173\000\173\000\ \173\000\173\000\173\000\173\000\173\000\000\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \000\000\000\000\000\000\000\000\000\000\000\000\003\000\000\000\ \003\000\033\000\000\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\046\000\003\000\003\000\ \003\000\000\000\003\000\003\000\003\000\000\000\000\000\000\000\ \003\000\003\000\000\000\003\000\003\000\003\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \003\000\000\000\003\000\003\000\003\000\003\000\003\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\003\000\000\000\003\000\031\000\161\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\000\000\003\000\000\000\003\000\000\000\000\000\000\000\ \000\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\100\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\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\ \100\000\000\000\000\000\059\000\059\000\059\000\059\000\059\000\ \059\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \099\000\099\000\099\000\099\000\099\000\099\000\099\000\099\000\ \099\000\099\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\059\000\059\000\059\000\059\000\059\000\ \059\000\000\000\000\000\000\000\000\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\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\ \032\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\031\000\000\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\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\049\000\049\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\049\000\049\000\049\000\049\000\049\000\049\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\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\000\049\000\049\000\049\000\049\000\049\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\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\000\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\ \031\000\031\000\031\000\031\000\031\000\033\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \034\000\000\000\000\000\000\000\000\000\000\000\000\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\000\000\000\000\000\000\000\000\033\000\000\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\000\000\000\000\000\000\105\000\102\000\000\000\000\000\ \101\000\000\000\000\000\000\000\000\000\156\000\156\000\156\000\ \156\000\156\000\156\000\156\000\156\000\156\000\156\000\000\000\ \000\000\000\000\000\000\105\000\000\000\104\000\156\000\156\000\ \156\000\156\000\156\000\156\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\099\000\099\000\099\000\099\000\099\000\ \099\000\099\000\099\000\099\000\099\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\156\000\156\000\ \156\000\156\000\156\000\156\000\000\000\000\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\000\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\000\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\057\000\000\000\ \057\000\000\000\000\000\000\000\000\000\057\000\000\000\000\000\ \060\000\000\000\000\000\060\000\000\000\000\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\060\000\ \078\000\000\000\000\000\078\000\078\000\078\000\000\000\000\000\ \000\000\079\000\078\000\000\000\078\000\078\000\078\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\078\000\057\000\078\000\078\000\078\000\078\000\078\000\ \057\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\068\000\057\000\000\000\068\000\000\000\ \057\000\000\000\057\000\000\000\000\000\000\000\055\000\000\000\ \000\000\000\000\000\000\078\000\000\000\078\000\000\000\000\000\ \000\000\000\000\068\000\069\000\000\000\000\000\069\000\069\000\ \069\000\000\000\000\000\072\000\071\000\069\000\000\000\069\000\ \069\000\069\000\068\000\255\255\000\000\068\000\000\000\000\000\ \000\000\000\000\000\000\078\000\069\000\078\000\069\000\069\000\ \069\000\069\000\069\000\000\000\000\000\000\000\000\000\000\000\ \000\000\068\000\069\000\000\000\000\000\069\000\070\000\070\000\ \000\000\000\000\072\000\071\000\069\000\000\000\069\000\077\000\ \070\000\000\000\000\000\000\000\000\000\000\000\069\000\000\000\ \069\000\000\000\000\000\077\000\000\000\077\000\077\000\077\000\ \069\000\070\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\068\000\000\000\000\000\ \068\000\000\000\000\000\000\000\000\000\000\000\069\000\000\000\ \069\000\000\000\000\000\000\000\000\000\069\000\000\000\070\000\ \000\000\000\000\000\000\000\000\068\000\069\000\000\000\000\000\ \069\000\076\000\076\000\000\000\000\000\072\000\071\000\069\000\ \000\000\069\000\075\000\076\000\068\000\000\000\255\255\068\000\ \000\000\000\000\000\000\000\000\000\000\077\000\075\000\069\000\ \075\000\075\000\075\000\069\000\076\000\000\000\000\000\000\000\ \000\000\000\000\000\000\068\000\069\000\000\000\000\000\069\000\ \070\000\070\000\000\000\067\000\072\000\071\000\069\000\000\000\ \069\000\070\000\070\000\000\000\000\000\000\000\000\000\000\000\ \069\000\000\000\076\000\067\000\067\000\070\000\067\000\070\000\ \070\000\070\000\069\000\070\000\067\000\067\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \067\000\000\000\067\000\067\000\067\000\000\000\067\000\000\000\ \075\000\000\000\069\000\000\000\000\000\000\000\067\000\069\000\ \000\000\070\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\067\000\000\000\068\000\067\000\000\000\068\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\067\000\070\000\ \000\000\069\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\068\000\069\000\000\000\000\000\069\000\069\000\ \069\000\067\000\067\000\073\000\071\000\069\000\000\000\069\000\ \069\000\069\000\068\000\000\000\000\000\068\000\000\000\000\000\ \000\000\000\000\000\000\000\000\069\000\000\000\069\000\069\000\ \069\000\069\000\069\000\000\000\000\000\000\000\000\000\000\000\ \000\000\068\000\069\000\000\000\000\000\069\000\070\000\070\000\ \000\000\067\000\073\000\071\000\069\000\000\000\069\000\070\000\ \070\000\000\000\000\000\000\000\000\000\000\000\069\000\000\000\ \069\000\000\000\000\000\070\000\000\000\070\000\070\000\070\000\ \069\000\070\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\068\000\000\000\000\000\ \068\000\000\000\000\000\000\000\000\000\000\000\069\000\000\000\ \069\000\000\000\000\000\000\000\067\000\069\000\000\000\070\000\ \000\000\000\000\000\000\000\000\068\000\069\000\000\000\000\000\ \069\000\069\000\069\000\000\000\000\000\000\000\071\000\069\000\ \000\000\069\000\069\000\069\000\068\000\000\000\000\000\068\000\ \000\000\000\000\000\000\000\000\067\000\070\000\069\000\069\000\ \069\000\069\000\069\000\069\000\069\000\000\000\000\000\000\000\ \000\000\000\000\000\000\068\000\069\000\000\000\000\000\069\000\ \076\000\076\000\000\000\000\000\073\000\071\000\069\000\000\000\ \069\000\075\000\076\000\000\000\000\000\000\000\000\000\000\000\ \069\000\000\000\069\000\000\000\000\000\075\000\000\000\075\000\ \075\000\075\000\069\000\076\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\068\000\ \000\000\000\000\068\000\000\000\000\000\000\000\000\000\000\000\ \069\000\000\000\069\000\000\000\000\000\000\000\000\000\069\000\ \000\000\076\000\000\000\000\000\000\000\000\000\068\000\069\000\ \000\000\000\000\069\000\076\000\076\000\000\000\067\000\073\000\ \071\000\069\000\000\000\069\000\076\000\076\000\068\000\000\000\ \000\000\068\000\000\000\000\000\000\000\000\000\000\000\075\000\ \076\000\069\000\076\000\076\000\076\000\069\000\076\000\000\000\ \000\000\000\000\000\000\000\000\000\000\068\000\069\000\000\000\ \000\000\069\000\070\000\070\000\000\000\000\000\073\000\071\000\ \069\000\000\000\069\000\077\000\070\000\000\000\000\000\000\000\ \000\000\067\000\069\000\000\000\076\000\000\000\000\000\077\000\ \000\000\077\000\077\000\077\000\069\000\070\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\000\000\080\000\000\000\000\000\000\000\ \000\000\067\000\076\000\000\000\069\000\000\000\000\000\000\000\ \000\000\069\000\000\000\070\000\000\000\000\000\000\000\000\000\ \080\000\078\000\000\000\000\000\078\000\078\000\078\000\000\000\ \000\000\082\000\079\000\078\000\000\000\078\000\078\000\078\000\ \080\000\000\000\000\000\080\000\000\000\000\000\000\000\000\000\ \000\000\077\000\078\000\069\000\078\000\078\000\078\000\078\000\ \078\000\000\000\000\000\000\000\000\000\000\000\000\000\080\000\ \078\000\000\000\000\000\078\000\078\000\078\000\000\000\000\000\ \000\000\079\000\078\000\000\000\078\000\078\000\078\000\000\000\ \000\000\000\000\000\000\000\000\078\000\000\000\078\000\000\000\ \000\000\078\000\000\000\078\000\078\000\078\000\078\000\078\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\096\000\ \096\000\000\000\000\000\084\000\000\000\000\000\000\000\000\000\ \084\000\096\000\000\000\000\000\078\000\000\000\078\000\000\000\ \000\000\000\000\000\000\078\000\084\000\078\000\084\000\084\000\ \084\000\000\000\096\000\000\000\000\000\000\000\000\000\000\000\ \003\000\000\000\000\000\003\000\009\000\009\000\000\000\000\000\ \005\000\003\000\003\000\000\000\003\000\006\000\009\000\000\000\ \000\000\000\000\000\000\078\000\000\000\078\000\000\000\084\000\ \096\000\085\000\000\000\006\000\006\000\006\000\003\000\009\000\ \000\000\000\000\000\000\000\000\000\000\003\000\000\000\000\000\ \003\000\009\000\009\000\000\000\000\000\005\000\003\000\003\000\ \000\000\003\000\006\000\009\000\000\000\000\000\084\000\084\000\ \000\000\000\000\000\000\003\000\084\000\009\000\085\000\000\000\ \006\000\006\000\006\000\003\000\009\000\000\000\000\000\000\000\ \000\000\000\000\003\000\000\000\000\000\003\000\009\000\009\000\ \000\000\000\000\094\000\003\000\003\000\000\000\003\000\009\000\ \009\000\000\000\000\000\085\000\005\000\003\000\000\000\000\000\ \003\000\084\000\009\000\098\000\000\000\009\000\009\000\009\000\ \003\000\009\000\000\000\000\000\000\000\000\000\000\000\090\000\ \000\000\000\000\003\000\093\000\093\000\000\000\000\000\084\000\ \090\000\090\000\000\000\090\000\091\000\093\000\000\000\000\000\ \085\000\005\000\003\000\000\000\000\000\003\000\094\000\009\000\ \092\000\000\000\006\000\091\000\089\000\090\000\093\000\000\000\ \000\000\000\000\000\000\000\000\003\000\000\000\000\000\003\000\ \009\000\009\000\000\000\000\000\084\000\003\000\003\000\000\000\ \003\000\006\000\009\000\000\000\000\000\098\000\094\000\003\000\ \000\000\000\000\090\000\084\000\093\000\085\000\000\000\006\000\ \006\000\097\000\003\000\009\000\000\000\000\000\000\000\000\000\ \000\000\090\000\000\000\000\000\003\000\090\000\090\000\000\000\ \000\000\000\000\090\000\090\000\000\000\090\000\090\000\090\000\ \000\000\000\000\092\000\084\000\090\000\000\000\000\000\003\000\ \084\000\009\000\090\000\000\000\003\000\090\000\003\000\090\000\ \090\000\000\000\000\000\000\000\090\000\000\000\000\000\003\000\ \093\000\093\000\000\000\000\000\084\000\090\000\090\000\000\000\ \090\000\091\000\093\000\000\000\000\000\000\000\000\000\085\000\ \084\000\003\000\000\000\000\000\090\000\092\000\090\000\006\000\ \091\000\006\000\090\000\093\000\000\000\000\000\000\000\000\000\ \000\000\090\000\000\000\000\000\003\000\093\000\093\000\000\000\ \000\000\005\000\090\000\090\000\000\000\090\000\091\000\093\000\ \000\000\000\000\000\000\000\000\090\000\000\000\090\000\090\000\ \084\000\093\000\092\000\000\000\006\000\091\000\006\000\090\000\ \093\000\000\000\000\000\000\000\000\000\000\000\090\000\000\000\ \000\000\003\000\093\000\093\000\000\000\000\000\094\000\090\000\ \090\000\000\000\090\000\093\000\093\000\000\000\000\000\092\000\ \084\000\090\000\000\000\000\000\090\000\084\000\093\000\095\000\ \000\000\009\000\093\000\009\000\090\000\093\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\096\000\ \096\000\000\000\000\000\094\000\000\000\000\000\000\000\000\000\ \096\000\096\000\000\000\000\000\092\000\005\000\090\000\000\000\ \000\000\090\000\094\000\093\000\096\000\000\000\096\000\096\000\ \096\000\000\000\096\000\000\000\000\000\000\000\000\000\000\000\ \090\000\000\000\000\000\003\000\093\000\093\000\000\000\000\000\ \094\000\090\000\090\000\000\000\090\000\093\000\093\000\000\000\ \000\000\095\000\094\000\090\000\000\000\000\000\000\000\094\000\ \096\000\095\000\000\000\009\000\093\000\009\000\090\000\093\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\096\000\096\000\000\000\000\000\094\000\000\000\000\000\ \000\000\000\000\096\000\096\000\000\000\000\000\096\000\094\000\ \000\000\000\000\000\000\090\000\094\000\093\000\096\000\000\000\ \096\000\096\000\096\000\000\000\096\000\000\000\000\000\000\000\ \000\000\000\000\003\000\000\000\000\000\003\000\009\000\009\000\ \000\000\000\000\084\000\003\000\003\000\000\000\003\000\006\000\ \009\000\000\000\000\000\095\000\094\000\090\000\000\000\000\000\ \000\000\094\000\096\000\085\000\000\000\006\000\006\000\006\000\ \003\000\009\000\000\000\000\000\000\000\000\000\000\000\003\000\ \000\000\000\000\003\000\009\000\009\000\000\000\000\000\094\000\ \003\000\003\000\000\000\003\000\009\000\009\000\000\000\000\000\ \096\000\094\000\000\000\000\000\000\000\003\000\084\000\009\000\ \098\000\000\000\009\000\009\000\009\000\003\000\009\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \111\000\111\000\000\000\000\000\084\000\000\000\000\000\111\000\ \111\000\109\000\111\000\005\000\000\000\085\000\084\000\003\000\ \109\000\111\000\003\000\094\000\009\000\110\000\000\000\109\000\ \109\000\109\000\000\000\111\000\110\000\000\000\109\000\109\000\ \109\000\000\000\111\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\111\000\111\000\000\000\000\000\ \094\000\000\000\098\000\094\000\003\000\111\000\111\000\000\000\ \084\000\111\000\000\000\000\000\000\000\000\000\000\000\084\000\ \111\000\113\000\000\000\111\000\111\000\111\000\000\000\111\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\111\000\111\000\000\000\000\000\084\000\000\000\110\000\ \084\000\000\000\109\000\111\000\000\000\000\000\110\000\005\000\ \000\000\000\000\000\000\000\000\094\000\111\000\110\000\000\000\ \109\000\109\000\109\000\000\000\111\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\111\000\111\000\ \000\000\000\000\094\000\000\000\000\000\111\000\111\000\111\000\ \111\000\005\000\000\000\113\000\094\000\000\000\109\000\111\000\ \000\000\084\000\111\000\113\000\000\000\111\000\111\000\111\000\ \000\000\111\000\110\000\000\000\109\000\109\000\109\000\000\000\ \111\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\117\000\117\000\000\000\000\000\000\000\000\000\ \110\000\084\000\000\000\115\000\117\000\000\000\094\000\111\000\ \000\000\000\000\000\000\000\000\000\000\084\000\111\000\115\000\ \000\000\116\000\115\000\115\000\000\000\117\000\000\000\000\000\ \000\000\117\000\117\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\115\000\117\000\000\000\113\000\094\000\000\000\ \000\000\000\000\000\000\000\000\110\000\005\000\115\000\000\000\ \116\000\115\000\115\000\117\000\117\000\117\000\117\000\000\000\ \067\000\000\000\000\000\000\000\000\000\000\000\117\000\117\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\117\000\000\000\117\000\117\000\117\000\000\000\ \117\000\115\000\117\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\119\000\119\000\000\000\000\000\000\000\119\000\ \119\000\000\000\067\000\118\000\119\000\000\000\000\000\000\000\ \119\000\119\000\000\000\067\000\000\000\000\000\117\000\118\000\ \115\000\118\000\118\000\118\000\119\000\119\000\119\000\119\000\ \119\000\000\000\119\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\067\000\117\000\000\000\000\000\000\000\ \000\000\000\000\000\000\119\000\000\000\067\000\000\000\000\000\ \119\000\000\000\000\000\000\000\000\000\000\000\003\000\000\000\ \000\000\003\000\121\000\121\000\000\000\000\000\005\000\003\000\ \003\000\000\000\003\000\007\000\121\000\000\000\000\000\000\000\ \000\000\118\000\000\000\000\000\000\000\067\000\119\000\120\000\ \000\000\007\000\007\000\007\000\003\000\121\000\000\000\000\000\ \000\000\000\000\000\000\003\000\000\000\000\000\003\000\121\000\ \121\000\000\000\000\000\094\000\003\000\003\000\000\000\003\000\ \121\000\121\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\003\000\005\000\121\000\122\000\000\000\121\000\121\000\ \121\000\003\000\121\000\000\000\000\000\000\000\000\000\000\000\ \003\000\000\000\000\000\003\000\121\000\121\000\000\000\000\000\ \094\000\003\000\003\000\000\000\003\000\121\000\121\000\000\000\ \000\000\120\000\005\000\003\000\000\000\000\000\003\000\094\000\ \121\000\122\000\000\000\121\000\121\000\121\000\003\000\121\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\126\000\ \000\000\000\000\125\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\122\000\094\000\ \003\000\000\000\000\000\003\000\094\000\121\000\000\000\129\000\ \000\000\000\000\000\000\000\000\128\000\133\000\000\000\132\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\131\000\000\000\122\000\094\000\003\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \000\000\000\000\000\000\000\000\130\000\000\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \157\000\157\000\157\000\157\000\157\000\157\000\157\000\157\000\ \157\000\157\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\157\000\157\000\157\000\157\000\157\000\157\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\157\000\157\000\157\000\157\000\157\000\157\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\000\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\000\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\127\000\130\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\000\000\000\000\000\000\000\000\130\000\000\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\000\000\000\000\000\000\000\000\000\000\000\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\000\000\000\000\000\000\000\000\140\000\000\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\000\000\000\000\000\000\000\000\000\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\000\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\000\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\000\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\000\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\000\000\000\000\000\000\000\000\139\000\000\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ \174\000\174\000\174\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\174\000\174\000\174\000\174\000\174\000\174\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\174\000\174\000\174\000\174\000\174\000\174\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\000\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \000\000\000\000\136\000\000\000\000\000\000\000\137\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\000\000\000\000\000\000\000\000\139\000\000\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\175\000\175\000\175\000\175\000\175\000\175\000\175\000\ \175\000\175\000\175\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\175\000\175\000\175\000\175\000\175\000\175\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\175\000\175\000\175\000\175\000\175\000\175\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\000\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\140\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \000\000\000\000\136\000\000\000\000\000\000\000\000\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\000\000\000\000\000\000\000\000\140\000\000\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\000\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\000\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\151\000\000\000\ \151\000\000\000\000\000\171\000\000\000\151\000\170\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\150\000\150\000\ \150\000\150\000\150\000\150\000\150\000\150\000\150\000\150\000\ \000\000\169\000\000\000\169\000\000\000\000\000\000\000\000\000\ \169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ \168\000\168\000\168\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\151\000\000\000\000\000\000\000\000\000\000\000\ \151\000\176\000\000\000\000\000\176\000\176\000\176\000\000\000\ \000\000\000\000\176\000\176\000\151\000\176\000\176\000\176\000\ \151\000\000\000\151\000\000\000\000\000\169\000\149\000\000\000\ \000\000\000\000\176\000\169\000\176\000\176\000\176\000\176\000\ \176\000\000\000\000\000\000\000\000\000\000\000\000\000\169\000\ \000\000\000\000\000\000\169\000\000\000\169\000\000\000\000\000\ \000\000\167\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\176\000\000\000\176\000\000\000\ \000\000\000\000\000\000\000\000\178\000\000\000\000\000\178\000\ \178\000\178\000\000\000\000\000\000\000\178\000\178\000\000\000\ \178\000\178\000\178\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\176\000\178\000\176\000\178\000\ \178\000\178\000\178\000\178\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\000\000\178\000\ \000\000\178\000\179\000\000\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\000\000\178\000\ \000\000\178\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\000\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\000\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\178\000\000\000\000\000\178\000\178\000\ \178\000\000\000\000\000\000\000\178\000\178\000\000\000\178\000\ \178\000\178\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\178\000\000\000\178\000\178\000\ \178\000\178\000\178\000\000\000\000\000\000\000\000\000\179\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\000\000\000\000\180\000\000\000\178\000\000\000\ \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\000\000\000\000\000\000\178\000\179\000\ \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\000\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\000\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \182\000\000\000\000\000\182\000\182\000\182\000\000\000\000\000\ \000\000\182\000\182\000\000\000\182\000\182\000\182\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\182\000\000\000\182\000\182\000\182\000\182\000\182\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\000\000\182\000\000\000\182\000\183\000\000\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\000\000\182\000\000\000\182\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\182\000\ \000\000\000\000\182\000\182\000\182\000\000\000\000\000\000\000\ \182\000\182\000\000\000\182\000\182\000\182\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \182\000\000\000\182\000\182\000\182\000\182\000\182\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\183\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\000\000\182\000\185\000\182\000\000\000\000\000\184\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\182\000\000\000\182\000\000\000\183\000\000\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\000\000\000\000\000\000\000\000\000\000\000\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\000\000\000\000\000\000\000\000\186\000\000\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\000\000\000\000\000\000\000\000\000\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\000\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\000\000\000\000\187\000\000\000\000\000\000\000\000\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\000\000\000\000\000\000\000\000\186\000\000\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\000\000\000\000\000\000\000\000\000\000\000\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\000\000\000\000\000\000\000\000\199\000\000\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\000\000\000\000\000\000\000\000\000\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\000\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\000\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\000\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\000\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\000\000\000\000\000\000\000\000\198\000\000\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\000\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \000\000\000\000\195\000\000\000\000\000\000\000\196\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\000\000\000\000\000\000\000\000\198\000\000\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\000\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\199\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \000\000\000\000\195\000\000\000\000\000\000\000\000\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\000\000\000\000\000\000\000\000\199\000\000\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\000\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\000\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\202\000\202\000\ \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ \202\000\202\000\202\000\202\000\202\000\202\000\202\000\204\000\ \202\000\202\000\207\000\202\000\202\000\000\000\202\000\202\000\ \202\000\202\000\202\000\202\000\204\000\202\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \203\000\202\000\202\000\202\000\202\000\202\000\202\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\202\000\202\000\202\000\202\000\000\000\206\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ \202\000\202\000\202\000\202\000\202\000\202\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\202\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\202\000\209\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\255\255\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\203\000\000\000\000\000\000\000\000\000\000\000\000\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\000\000\000\000\000\000\000\000\209\000\000\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\000\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\000\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\208\000\ \000\000\000\000\000\000\000\000\000\000\209\000\000\000\000\000\ \000\000\000\000\000\000\000\000\208\000\000\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \203\000\000\000\000\000\000\000\000\000\000\000\000\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\000\000\000\000\000\000\000\000\209\000\000\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\000\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \203\000\000\000\000\000\000\000\000\000\000\000\000\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\000\000\000\000\000\000\000\000\209\000\000\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\000\000\000\000\000\000\000\000\000\000\000\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\000\000\000\000\000\000\000\000\221\000\000\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\000\000\000\000\000\000\000\000\000\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\000\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\000\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\000\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\000\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \000\000\000\000\000\000\000\000\220\000\000\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\000\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\000\000\ \000\000\217\000\000\000\000\000\000\000\218\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \000\000\000\000\000\000\000\000\220\000\000\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\000\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\221\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\000\000\ \000\000\217\000\000\000\000\000\000\000\000\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \000\000\000\000\000\000\000\000\221\000\000\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\000\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\000\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\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\029\000\000\000\000\000\101\000\107\000\ \125\000\162\000\103\000\106\000\190\000\103\000\106\000\213\000\ \255\255\255\255\255\255\255\255\255\255\255\255\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\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\000\ \010\000\010\000\049\000\016\000\051\000\028\000\040\000\040\000\ \028\000\010\000\010\000\041\000\041\000\041\000\041\000\041\000\ \041\000\041\000\041\000\057\000\065\000\010\000\132\000\010\000\ \010\000\010\000\016\000\010\000\028\000\047\000\047\000\047\000\ \047\000\047\000\047\000\047\000\047\000\047\000\047\000\133\000\ \142\000\144\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\016\000\016\000\145\000\131\000\151\000\131\000\ \154\000\010\000\020\000\131\000\157\000\020\000\193\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\010\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\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\000\000\ \000\000\003\000\255\255\255\255\003\000\003\000\003\000\050\000\ \103\000\106\000\003\000\003\000\020\000\003\000\003\000\003\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ \039\000\039\000\003\000\143\000\003\000\003\000\003\000\003\000\ \003\000\255\255\005\000\005\000\050\000\039\000\005\000\255\255\ \038\000\255\255\038\000\005\000\005\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\005\000\ \143\000\005\000\005\000\005\000\003\000\005\000\003\000\039\000\ \104\000\255\255\171\000\104\000\006\000\039\000\255\255\006\000\ \006\000\006\000\255\255\255\255\006\000\006\000\006\000\255\255\ \006\000\006\000\006\000\255\255\068\000\255\255\255\255\068\000\ \104\000\171\000\005\000\005\000\003\000\006\000\003\000\006\000\ \006\000\006\000\006\000\006\000\170\000\170\000\255\255\255\255\ \255\255\007\000\255\255\068\000\007\000\007\000\007\000\255\255\ \255\255\007\000\007\000\007\000\068\000\007\000\007\000\007\000\ \255\255\005\000\005\000\170\000\255\255\255\255\255\255\006\000\ \006\000\006\000\007\000\255\255\007\000\007\000\007\000\007\000\ \007\000\194\000\212\000\194\000\212\000\255\255\008\000\194\000\ \212\000\008\000\008\000\008\000\255\255\255\255\008\000\008\000\ \008\000\255\255\008\000\008\000\008\000\255\255\255\255\006\000\ \006\000\006\000\255\255\255\255\007\000\007\000\007\000\008\000\ \255\255\008\000\008\000\008\000\008\000\008\000\188\000\255\255\ \020\000\188\000\255\255\009\000\255\255\255\255\009\000\009\000\ \009\000\255\255\204\000\009\000\009\000\009\000\255\255\009\000\ \009\000\009\000\255\255\255\255\007\000\007\000\007\000\204\000\ \208\000\008\000\008\000\008\000\009\000\255\255\009\000\009\000\ \009\000\009\000\009\000\204\000\255\255\208\000\255\255\255\255\ \210\000\255\255\255\255\210\000\011\000\011\000\255\255\255\255\ \188\000\208\000\188\000\013\000\013\000\011\000\011\000\013\000\ \255\255\008\000\008\000\008\000\013\000\013\000\009\000\009\000\ \009\000\011\000\210\000\011\000\011\000\011\000\255\255\011\000\ \013\000\255\255\013\000\013\000\013\000\255\255\013\000\014\000\ \014\000\255\255\080\000\014\000\255\255\080\000\255\255\255\255\ \014\000\014\000\210\000\255\255\255\255\255\255\009\000\009\000\ \009\000\255\255\255\255\255\255\014\000\011\000\014\000\014\000\ \014\000\080\000\014\000\013\000\013\000\045\000\045\000\255\255\ \255\255\255\255\080\000\017\000\255\255\255\255\017\000\017\000\ \017\000\255\255\255\255\017\000\017\000\017\000\255\255\017\000\ \017\000\017\000\255\255\011\000\255\255\255\255\104\000\014\000\ \014\000\045\000\013\000\013\000\017\000\255\255\017\000\017\000\ \017\000\017\000\017\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\045\000\044\000\044\000\044\000\ \044\000\044\000\044\000\044\000\044\000\255\255\014\000\014\000\ \255\255\045\000\255\255\045\000\255\255\255\255\017\000\017\000\ \017\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \018\000\044\000\255\255\018\000\018\000\018\000\255\255\255\255\ \018\000\018\000\018\000\255\255\018\000\018\000\018\000\019\000\ \255\255\255\255\019\000\255\255\044\000\255\255\017\000\017\000\ \017\000\018\000\255\255\018\000\018\000\018\000\018\000\018\000\ \255\255\044\000\255\255\044\000\255\255\255\255\019\000\019\000\ \255\255\255\255\019\000\019\000\019\000\255\255\255\255\255\255\ \019\000\019\000\255\255\019\000\019\000\019\000\128\000\255\255\ \255\255\128\000\255\255\018\000\188\000\018\000\255\255\255\255\ \019\000\255\255\019\000\019\000\019\000\019\000\019\000\022\000\ \255\255\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ \022\000\022\000\022\000\128\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\018\000\255\255\018\000\022\000\255\255\ \255\255\255\255\019\000\255\255\019\000\022\000\210\000\255\255\ \023\000\255\255\023\000\023\000\023\000\023\000\023\000\023\000\ \023\000\023\000\023\000\023\000\255\255\255\255\255\255\255\255\ \022\000\255\255\255\255\255\255\023\000\255\255\022\000\023\000\ \255\255\255\255\019\000\255\255\019\000\022\000\023\000\022\000\ \128\000\023\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\023\000\255\255\255\255\255\255\105\000\105\000\ \255\255\023\000\105\000\255\255\023\000\255\255\255\255\023\000\ \255\255\255\255\255\255\255\255\255\255\255\255\023\000\255\255\ \023\000\023\000\024\000\255\255\255\255\105\000\255\255\105\000\ \255\255\255\255\023\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\255\255\255\255\ \255\255\255\255\024\000\255\255\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\042\000\042\000\ \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\042\000\ \042\000\042\000\042\000\042\000\042\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\255\255\255\255\255\255\128\000\255\255\255\255\042\000\ \042\000\042\000\042\000\042\000\042\000\150\000\150\000\150\000\ \150\000\150\000\150\000\150\000\150\000\150\000\150\000\255\255\ \255\255\255\255\255\255\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\255\255\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\025\000\024\000\024\000\024\000\024\000\024\000\ \024\000\024\000\024\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\105\000\255\255\255\255\ \255\255\255\255\255\255\255\255\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\255\255\255\255\ \255\255\255\255\025\000\255\255\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\043\000\043\000\ \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\043\000\ \043\000\043\000\043\000\043\000\043\000\255\255\255\255\255\255\ \255\255\255\255\043\000\153\000\153\000\153\000\153\000\153\000\ \153\000\153\000\153\000\153\000\153\000\255\255\255\255\255\255\ \159\000\255\255\255\255\159\000\255\255\043\000\255\255\043\000\ \043\000\043\000\043\000\043\000\043\000\255\255\255\255\255\255\ \255\255\255\255\043\000\255\255\043\000\255\255\255\255\255\255\ \159\000\255\255\255\255\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\255\255\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\159\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\026\000\255\255\255\255\026\000\026\000\ \026\000\255\255\255\255\255\255\026\000\026\000\255\255\026\000\ \026\000\026\000\168\000\168\000\168\000\168\000\168\000\168\000\ \168\000\168\000\168\000\168\000\026\000\255\255\026\000\026\000\ \026\000\026\000\026\000\172\000\172\000\172\000\172\000\172\000\ \172\000\172\000\172\000\172\000\172\000\255\255\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \255\255\255\255\255\255\255\255\255\255\255\255\026\000\255\255\ \026\000\026\000\255\255\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\046\000\026\000\027\000\ \026\000\255\255\027\000\027\000\027\000\255\255\255\255\255\255\ \027\000\027\000\255\255\027\000\027\000\027\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \027\000\255\255\027\000\027\000\027\000\027\000\027\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\027\000\255\255\027\000\027\000\159\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \027\000\255\255\027\000\255\255\027\000\255\255\255\255\255\255\ \255\255\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\100\000\026\000\026\000\026\000\026\000\026\000\026\000\ \026\000\026\000\055\000\055\000\055\000\055\000\055\000\055\000\ \055\000\055\000\055\000\055\000\255\255\255\255\255\255\255\255\ \100\000\255\255\255\255\055\000\055\000\055\000\055\000\055\000\ \055\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \100\000\100\000\100\000\100\000\100\000\100\000\100\000\100\000\ \100\000\100\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\055\000\055\000\055\000\055\000\055\000\ \055\000\255\255\255\255\255\255\255\255\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\031\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\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\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\255\255\255\255\255\255\255\255\031\000\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\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\ \255\255\255\255\059\000\059\000\059\000\059\000\059\000\059\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\059\000\059\000\059\000\059\000\059\000\059\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\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\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\031\000\031\000\031\000\031\000\033\000\031\000\031\000\ \031\000\031\000\031\000\031\000\031\000\031\000\033\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\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\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\033\000\255\255\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\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\099\000\099\000\255\255\255\255\ \099\000\255\255\255\255\255\255\255\255\149\000\149\000\149\000\ \149\000\149\000\149\000\149\000\149\000\149\000\149\000\255\255\ \255\255\255\255\255\255\099\000\255\255\099\000\149\000\149\000\ \149\000\149\000\149\000\149\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\099\000\099\000\099\000\099\000\099\000\ \099\000\099\000\099\000\099\000\099\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\149\000\149\000\ \149\000\149\000\149\000\149\000\255\255\255\255\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\255\255\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\255\255\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\048\000\255\255\ \048\000\255\255\255\255\255\255\255\255\048\000\255\255\255\255\ \060\000\255\255\255\255\060\000\255\255\255\255\048\000\048\000\ \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\060\000\ \060\000\255\255\255\255\060\000\060\000\060\000\255\255\255\255\ \255\255\060\000\060\000\255\255\060\000\060\000\060\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\060\000\048\000\060\000\060\000\060\000\060\000\060\000\ \048\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\061\000\048\000\255\255\061\000\255\255\ \048\000\255\255\048\000\255\255\255\255\255\255\048\000\255\255\ \255\255\255\255\255\255\060\000\255\255\060\000\255\255\255\255\ \255\255\255\255\061\000\061\000\255\255\255\255\061\000\061\000\ \061\000\255\255\255\255\061\000\061\000\061\000\255\255\061\000\ \061\000\061\000\062\000\099\000\255\255\062\000\255\255\255\255\ \255\255\255\255\255\255\060\000\061\000\060\000\061\000\061\000\ \061\000\061\000\061\000\255\255\255\255\255\255\255\255\255\255\ \255\255\062\000\062\000\255\255\255\255\062\000\062\000\062\000\ \255\255\255\255\062\000\062\000\062\000\255\255\062\000\062\000\ \062\000\255\255\255\255\255\255\255\255\255\255\061\000\255\255\ \061\000\255\255\255\255\062\000\255\255\062\000\062\000\062\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\063\000\255\255\255\255\ \063\000\255\255\255\255\255\255\255\255\255\255\061\000\255\255\ \061\000\255\255\255\255\255\255\255\255\062\000\255\255\062\000\ \255\255\255\255\255\255\255\255\063\000\063\000\255\255\255\255\ \063\000\063\000\063\000\255\255\255\255\063\000\063\000\063\000\ \255\255\063\000\063\000\063\000\064\000\255\255\048\000\064\000\ \255\255\255\255\255\255\255\255\255\255\062\000\063\000\062\000\ \063\000\063\000\063\000\063\000\063\000\255\255\255\255\255\255\ \255\255\255\255\255\255\064\000\064\000\255\255\255\255\064\000\ \064\000\064\000\255\255\064\000\064\000\064\000\064\000\255\255\ \064\000\064\000\064\000\255\255\255\255\255\255\255\255\255\255\ \063\000\255\255\063\000\067\000\067\000\064\000\067\000\064\000\ \064\000\064\000\064\000\064\000\067\000\067\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \067\000\255\255\067\000\067\000\067\000\255\255\067\000\255\255\ \063\000\255\255\063\000\255\255\255\255\255\255\064\000\064\000\ \255\255\064\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\067\000\255\255\069\000\067\000\255\255\069\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\064\000\064\000\ \255\255\064\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\069\000\069\000\255\255\255\255\069\000\069\000\ \069\000\067\000\067\000\069\000\069\000\069\000\255\255\069\000\ \069\000\069\000\070\000\255\255\255\255\070\000\255\255\255\255\ \255\255\255\255\255\255\255\255\069\000\255\255\069\000\069\000\ \069\000\069\000\069\000\255\255\255\255\255\255\255\255\255\255\ \255\255\070\000\070\000\255\255\255\255\070\000\070\000\070\000\ \255\255\070\000\070\000\070\000\070\000\255\255\070\000\070\000\ \070\000\255\255\255\255\255\255\255\255\255\255\069\000\255\255\ \069\000\255\255\255\255\070\000\255\255\070\000\070\000\070\000\ \070\000\070\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\071\000\255\255\255\255\ \071\000\255\255\255\255\255\255\255\255\255\255\069\000\255\255\ \069\000\255\255\255\255\255\255\070\000\070\000\255\255\070\000\ \255\255\255\255\255\255\255\255\071\000\071\000\255\255\255\255\ \071\000\071\000\071\000\255\255\255\255\255\255\071\000\071\000\ \255\255\071\000\071\000\071\000\075\000\255\255\255\255\075\000\ \255\255\255\255\255\255\255\255\070\000\070\000\071\000\070\000\ \071\000\071\000\071\000\071\000\071\000\255\255\255\255\255\255\ \255\255\255\255\255\255\075\000\075\000\255\255\255\255\075\000\ \075\000\075\000\255\255\255\255\075\000\075\000\075\000\255\255\ \075\000\075\000\075\000\255\255\255\255\255\255\255\255\255\255\ \071\000\255\255\071\000\255\255\255\255\075\000\255\255\075\000\ \075\000\075\000\075\000\075\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\076\000\ \255\255\255\255\076\000\255\255\255\255\255\255\255\255\255\255\ \071\000\255\255\071\000\255\255\255\255\255\255\255\255\075\000\ \255\255\075\000\255\255\255\255\255\255\255\255\076\000\076\000\ \255\255\255\255\076\000\076\000\076\000\255\255\076\000\076\000\ \076\000\076\000\255\255\076\000\076\000\076\000\077\000\255\255\ \255\255\077\000\255\255\255\255\255\255\255\255\255\255\075\000\ \076\000\075\000\076\000\076\000\076\000\076\000\076\000\255\255\ \255\255\255\255\255\255\255\255\255\255\077\000\077\000\255\255\ \255\255\077\000\077\000\077\000\255\255\255\255\077\000\077\000\ \077\000\255\255\077\000\077\000\077\000\255\255\255\255\255\255\ \255\255\076\000\076\000\255\255\076\000\255\255\255\255\077\000\ \255\255\077\000\077\000\077\000\077\000\077\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\078\000\255\255\255\255\078\000\255\255\255\255\255\255\ \255\255\076\000\076\000\255\255\076\000\255\255\255\255\255\255\ \255\255\077\000\255\255\077\000\255\255\255\255\255\255\255\255\ \078\000\078\000\255\255\255\255\078\000\078\000\078\000\255\255\ \255\255\078\000\078\000\078\000\255\255\078\000\078\000\078\000\ \079\000\255\255\255\255\079\000\255\255\255\255\255\255\255\255\ \255\255\077\000\078\000\077\000\078\000\078\000\078\000\078\000\ \078\000\255\255\255\255\255\255\255\255\255\255\255\255\079\000\ \079\000\255\255\255\255\079\000\079\000\079\000\255\255\255\255\ \255\255\079\000\079\000\255\255\079\000\079\000\079\000\255\255\ \255\255\255\255\255\255\255\255\078\000\255\255\078\000\255\255\ \255\255\079\000\255\255\079\000\079\000\079\000\079\000\079\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\084\000\ \084\000\255\255\255\255\084\000\255\255\255\255\255\255\255\255\ \084\000\084\000\255\255\255\255\078\000\255\255\078\000\255\255\ \255\255\255\255\255\255\079\000\084\000\079\000\084\000\084\000\ \084\000\255\255\084\000\255\255\255\255\255\255\255\255\255\255\ \085\000\255\255\255\255\085\000\085\000\085\000\255\255\255\255\ \085\000\085\000\085\000\255\255\085\000\085\000\085\000\255\255\ \255\255\255\255\255\255\079\000\255\255\079\000\255\255\084\000\ \084\000\085\000\255\255\085\000\085\000\085\000\085\000\085\000\ \255\255\255\255\255\255\255\255\255\255\086\000\255\255\255\255\ \086\000\086\000\086\000\255\255\255\255\086\000\086\000\086\000\ \255\255\086\000\086\000\086\000\255\255\255\255\084\000\084\000\ \255\255\255\255\255\255\085\000\085\000\085\000\086\000\255\255\ \086\000\086\000\086\000\086\000\086\000\255\255\255\255\255\255\ \255\255\255\255\087\000\255\255\255\255\087\000\087\000\087\000\ \255\255\255\255\087\000\087\000\087\000\255\255\087\000\087\000\ \087\000\255\255\255\255\085\000\085\000\085\000\255\255\255\255\ \086\000\086\000\086\000\087\000\255\255\087\000\087\000\087\000\ \087\000\087\000\255\255\255\255\255\255\255\255\255\255\088\000\ \255\255\255\255\088\000\088\000\088\000\255\255\255\255\088\000\ \088\000\088\000\255\255\088\000\088\000\088\000\255\255\255\255\ \086\000\086\000\086\000\255\255\255\255\087\000\087\000\087\000\ \088\000\255\255\088\000\088\000\088\000\088\000\088\000\255\255\ \255\255\255\255\255\255\255\255\089\000\255\255\255\255\089\000\ \089\000\089\000\255\255\255\255\089\000\089\000\089\000\255\255\ \089\000\089\000\089\000\255\255\255\255\087\000\087\000\087\000\ \255\255\255\255\088\000\088\000\088\000\089\000\255\255\089\000\ \089\000\089\000\089\000\089\000\255\255\255\255\255\255\255\255\ \255\255\090\000\255\255\255\255\090\000\090\000\090\000\255\255\ \255\255\255\255\090\000\090\000\255\255\090\000\090\000\090\000\ \255\255\255\255\088\000\088\000\088\000\255\255\255\255\089\000\ \089\000\089\000\090\000\255\255\090\000\090\000\090\000\090\000\ \090\000\255\255\255\255\255\255\091\000\255\255\255\255\091\000\ \091\000\091\000\255\255\255\255\091\000\091\000\091\000\255\255\ \091\000\091\000\091\000\255\255\255\255\255\255\255\255\089\000\ \089\000\089\000\255\255\255\255\090\000\091\000\090\000\091\000\ \091\000\091\000\091\000\091\000\255\255\255\255\255\255\255\255\ \255\255\092\000\255\255\255\255\092\000\092\000\092\000\255\255\ \255\255\092\000\092\000\092\000\255\255\092\000\092\000\092\000\ \255\255\255\255\255\255\255\255\090\000\255\255\090\000\091\000\ \091\000\091\000\092\000\255\255\092\000\092\000\092\000\092\000\ \092\000\255\255\255\255\255\255\255\255\255\255\093\000\255\255\ \255\255\093\000\093\000\093\000\255\255\255\255\093\000\093\000\ \093\000\255\255\093\000\093\000\093\000\255\255\255\255\091\000\ \091\000\091\000\255\255\255\255\092\000\092\000\092\000\093\000\ \255\255\093\000\093\000\093\000\093\000\093\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\094\000\ \094\000\255\255\255\255\094\000\255\255\255\255\255\255\255\255\ \094\000\094\000\255\255\255\255\092\000\092\000\092\000\255\255\ \255\255\093\000\093\000\093\000\094\000\255\255\094\000\094\000\ \094\000\255\255\094\000\255\255\255\255\255\255\255\255\255\255\ \095\000\255\255\255\255\095\000\095\000\095\000\255\255\255\255\ \095\000\095\000\095\000\255\255\095\000\095\000\095\000\255\255\ \255\255\093\000\093\000\093\000\255\255\255\255\255\255\094\000\ \094\000\095\000\255\255\095\000\095\000\095\000\095\000\095\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\096\000\096\000\255\255\255\255\096\000\255\255\255\255\ \255\255\255\255\096\000\096\000\255\255\255\255\094\000\094\000\ \255\255\255\255\255\255\095\000\095\000\095\000\096\000\255\255\ \096\000\096\000\096\000\255\255\096\000\255\255\255\255\255\255\ \255\255\255\255\097\000\255\255\255\255\097\000\097\000\097\000\ \255\255\255\255\097\000\097\000\097\000\255\255\097\000\097\000\ \097\000\255\255\255\255\095\000\095\000\095\000\255\255\255\255\ \255\255\096\000\096\000\097\000\255\255\097\000\097\000\097\000\ \097\000\097\000\255\255\255\255\255\255\255\255\255\255\098\000\ \255\255\255\255\098\000\098\000\098\000\255\255\255\255\098\000\ \098\000\098\000\255\255\098\000\098\000\098\000\255\255\255\255\ \096\000\096\000\255\255\255\255\255\255\097\000\097\000\097\000\ \098\000\255\255\098\000\098\000\098\000\098\000\098\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \109\000\109\000\255\255\255\255\109\000\255\255\255\255\110\000\ \110\000\109\000\109\000\110\000\255\255\097\000\097\000\097\000\ \110\000\110\000\098\000\098\000\098\000\109\000\255\255\109\000\ \109\000\109\000\255\255\109\000\110\000\255\255\110\000\110\000\ \110\000\255\255\110\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\111\000\111\000\255\255\255\255\ \111\000\255\255\098\000\098\000\098\000\111\000\111\000\255\255\ \109\000\109\000\255\255\255\255\255\255\255\255\255\255\110\000\ \110\000\111\000\255\255\111\000\111\000\111\000\255\255\111\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\112\000\112\000\255\255\255\255\112\000\255\255\109\000\ \109\000\255\255\112\000\112\000\255\255\255\255\110\000\110\000\ \255\255\255\255\255\255\255\255\111\000\111\000\112\000\255\255\ \112\000\112\000\112\000\255\255\112\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\113\000\113\000\ \255\255\255\255\113\000\255\255\255\255\114\000\114\000\113\000\ \113\000\114\000\255\255\111\000\111\000\255\255\114\000\114\000\ \255\255\112\000\112\000\113\000\255\255\113\000\113\000\113\000\ \255\255\113\000\114\000\255\255\114\000\114\000\114\000\255\255\ \114\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\115\000\115\000\255\255\255\255\255\255\255\255\ \112\000\112\000\255\255\115\000\115\000\255\255\113\000\113\000\ \255\255\255\255\255\255\255\255\255\255\114\000\114\000\115\000\ \255\255\115\000\115\000\115\000\255\255\115\000\255\255\255\255\ \255\255\116\000\116\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\116\000\116\000\255\255\113\000\113\000\255\255\ \255\255\255\255\255\255\255\255\114\000\114\000\116\000\255\255\ \116\000\116\000\116\000\115\000\116\000\117\000\117\000\255\255\ \117\000\255\255\255\255\255\255\255\255\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\117\000\255\255\117\000\117\000\117\000\255\255\ \117\000\115\000\116\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\118\000\118\000\255\255\255\255\255\255\119\000\ \119\000\255\255\119\000\118\000\118\000\255\255\255\255\255\255\ \119\000\119\000\255\255\117\000\255\255\255\255\117\000\118\000\ \116\000\118\000\118\000\118\000\119\000\118\000\119\000\119\000\ \119\000\255\255\119\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\117\000\117\000\255\255\255\255\255\255\ \255\255\255\255\255\255\118\000\255\255\119\000\255\255\255\255\ \119\000\255\255\255\255\255\255\255\255\255\255\120\000\255\255\ \255\255\120\000\120\000\120\000\255\255\255\255\120\000\120\000\ \120\000\255\255\120\000\120\000\120\000\255\255\255\255\255\255\ \255\255\118\000\255\255\255\255\255\255\119\000\119\000\120\000\ \255\255\120\000\120\000\120\000\120\000\120\000\255\255\255\255\ \255\255\255\255\255\255\121\000\255\255\255\255\121\000\121\000\ \121\000\255\255\255\255\121\000\121\000\121\000\255\255\121\000\ \121\000\121\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\120\000\120\000\120\000\121\000\255\255\121\000\121\000\ \121\000\121\000\121\000\255\255\255\255\255\255\255\255\255\255\ \122\000\255\255\255\255\122\000\122\000\122\000\255\255\255\255\ \122\000\122\000\122\000\255\255\122\000\122\000\122\000\255\255\ \255\255\120\000\120\000\120\000\255\255\255\255\121\000\121\000\ \121\000\122\000\255\255\122\000\122\000\122\000\122\000\122\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\123\000\ \255\255\255\255\123\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\121\000\121\000\ \121\000\255\255\255\255\122\000\122\000\122\000\255\255\123\000\ \255\255\255\255\255\255\255\255\123\000\123\000\255\255\123\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\123\000\255\255\122\000\122\000\122\000\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ \255\255\255\255\255\255\255\255\123\000\255\255\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ \156\000\156\000\156\000\156\000\156\000\156\000\156\000\156\000\ \156\000\156\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\156\000\156\000\156\000\156\000\156\000\156\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\156\000\156\000\156\000\156\000\156\000\156\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\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\255\255\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\255\255\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\130\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\255\255\255\255\255\255\255\255\130\000\255\255\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\255\255\255\255\255\255\255\255\255\255\255\255\ \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ \137\000\137\000\255\255\255\255\255\255\255\255\137\000\255\255\ \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ \137\000\137\000\255\255\255\255\255\255\255\255\255\255\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\255\255\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\255\255\130\000\ \130\000\130\000\130\000\130\000\130\000\130\000\130\000\137\000\ \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ \137\000\137\000\137\000\137\000\137\000\137\000\255\255\137\000\ \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ \137\000\137\000\137\000\137\000\137\000\137\000\255\255\137\000\ \137\000\137\000\137\000\137\000\137\000\137\000\137\000\138\000\ \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ \138\000\255\255\255\255\255\255\255\255\138\000\255\255\138\000\ \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ \138\000\167\000\167\000\167\000\167\000\167\000\167\000\167\000\ \167\000\167\000\167\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\167\000\167\000\167\000\167\000\167\000\167\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\167\000\167\000\167\000\167\000\167\000\167\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\138\000\138\000\ \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ \138\000\138\000\138\000\138\000\138\000\255\255\138\000\138\000\ \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ \138\000\138\000\138\000\138\000\138\000\139\000\138\000\138\000\ \138\000\138\000\138\000\138\000\138\000\138\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \255\255\255\255\139\000\255\255\255\255\255\255\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\255\255\255\255\255\255\255\255\139\000\255\255\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ \174\000\174\000\174\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\174\000\174\000\174\000\174\000\174\000\174\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\174\000\174\000\174\000\174\000\174\000\174\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\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\255\255\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\140\000\139\000\139\000\ \139\000\139\000\139\000\139\000\139\000\139\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \255\255\255\255\140\000\255\255\255\255\255\255\255\255\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\255\255\255\255\255\255\255\255\140\000\255\255\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\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\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\255\255\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\255\255\140\000\140\000\ \140\000\140\000\140\000\140\000\140\000\140\000\141\000\255\255\ \141\000\255\255\255\255\164\000\255\255\141\000\164\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\141\000\141\000\ \141\000\141\000\141\000\141\000\141\000\141\000\141\000\141\000\ \255\255\164\000\255\255\164\000\255\255\255\255\255\255\255\255\ \164\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ \164\000\164\000\164\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\141\000\255\255\255\255\255\255\255\255\255\255\ \141\000\176\000\255\255\255\255\176\000\176\000\176\000\255\255\ \255\255\255\255\176\000\176\000\141\000\176\000\176\000\176\000\ \141\000\255\255\141\000\255\255\255\255\164\000\141\000\255\255\ \255\255\255\255\176\000\164\000\176\000\176\000\176\000\176\000\ \176\000\255\255\255\255\255\255\255\255\255\255\255\255\164\000\ \255\255\255\255\255\255\164\000\255\255\164\000\255\255\255\255\ \255\255\164\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\176\000\255\255\176\000\255\255\ \255\255\255\255\255\255\255\255\177\000\255\255\255\255\177\000\ \177\000\177\000\255\255\255\255\255\255\177\000\177\000\255\255\ \177\000\177\000\177\000\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\176\000\177\000\176\000\177\000\ \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ \177\000\177\000\177\000\177\000\177\000\177\000\255\255\177\000\ \255\255\177\000\177\000\255\255\177\000\177\000\177\000\177\000\ \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ \177\000\177\000\177\000\177\000\177\000\177\000\255\255\177\000\ \255\255\177\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\164\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\177\000\177\000\177\000\177\000\177\000\ \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ \177\000\177\000\255\255\177\000\177\000\177\000\177\000\177\000\ \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ \177\000\177\000\255\255\177\000\177\000\177\000\177\000\177\000\ \177\000\177\000\177\000\178\000\255\255\255\255\178\000\178\000\ \178\000\255\255\255\255\255\255\178\000\178\000\255\255\178\000\ \178\000\178\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\178\000\255\255\178\000\178\000\ \178\000\178\000\178\000\255\255\255\255\255\255\255\255\179\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\255\255\255\255\179\000\255\255\178\000\255\255\ \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\255\255\255\255\255\255\178\000\179\000\ \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\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\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\255\255\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\255\255\ \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ \181\000\255\255\255\255\181\000\181\000\181\000\255\255\255\255\ \255\255\181\000\181\000\255\255\181\000\181\000\181\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\181\000\255\255\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\255\255\181\000\255\255\181\000\181\000\255\255\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\255\255\181\000\255\255\181\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\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\255\255\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\255\255\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\182\000\ \255\255\255\255\182\000\182\000\182\000\255\255\255\255\255\255\ \182\000\182\000\255\255\182\000\182\000\182\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \182\000\255\255\182\000\182\000\182\000\182\000\182\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\183\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\255\255\182\000\183\000\182\000\255\255\255\255\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\182\000\255\255\182\000\255\255\183\000\255\255\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\255\255\255\255\255\255\255\255\255\255\255\255\ \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ \184\000\184\000\255\255\255\255\255\255\255\255\184\000\255\255\ \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ \184\000\184\000\255\255\255\255\255\255\255\255\255\255\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\255\255\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\255\255\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\184\000\ \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ \184\000\184\000\184\000\184\000\184\000\184\000\255\255\184\000\ \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ \184\000\184\000\184\000\184\000\184\000\184\000\186\000\184\000\ \184\000\184\000\184\000\184\000\184\000\184\000\184\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\255\255\255\255\186\000\255\255\255\255\255\255\255\255\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\255\255\255\255\255\255\255\255\186\000\255\255\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\255\255\255\255\255\255\255\255\255\255\255\255\ \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ \196\000\196\000\255\255\255\255\255\255\255\255\196\000\255\255\ \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ \196\000\196\000\255\255\255\255\255\255\255\255\255\255\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\255\255\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\255\255\186\000\ \186\000\186\000\186\000\186\000\186\000\186\000\186\000\196\000\ \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ \196\000\196\000\196\000\196\000\196\000\196\000\255\255\196\000\ \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ \196\000\196\000\196\000\196\000\196\000\196\000\255\255\196\000\ \196\000\196\000\196\000\196\000\196\000\196\000\196\000\197\000\ \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ \197\000\255\255\255\255\255\255\255\255\197\000\255\255\197\000\ \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ \197\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\197\000\197\000\ \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ \197\000\197\000\197\000\197\000\197\000\255\255\197\000\197\000\ \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ \197\000\197\000\197\000\197\000\197\000\198\000\197\000\197\000\ \197\000\197\000\197\000\197\000\197\000\197\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \255\255\255\255\198\000\255\255\255\255\255\255\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\255\255\255\255\255\255\255\255\198\000\255\255\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\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\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\255\255\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\199\000\198\000\198\000\ \198\000\198\000\198\000\198\000\198\000\198\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \255\255\255\255\199\000\255\255\255\255\255\255\255\255\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\255\255\255\255\255\255\255\255\199\000\255\255\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\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\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\255\255\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\255\255\199\000\199\000\ \199\000\199\000\199\000\199\000\199\000\199\000\201\000\201\000\ \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ \201\000\201\000\201\000\201\000\201\000\255\255\201\000\201\000\ \201\000\201\000\201\000\201\000\201\000\201\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \201\000\201\000\201\000\201\000\201\000\201\000\201\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\201\000\201\000\201\000\201\000\255\255\201\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\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ \201\000\201\000\201\000\201\000\201\000\201\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\201\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\201\000\205\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\201\000\205\000\ \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ \205\000\205\000\255\255\255\255\255\255\255\255\255\255\255\255\ \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ \205\000\205\000\255\255\255\255\255\255\255\255\205\000\255\255\ \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ \205\000\205\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\205\000\ \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ \205\000\205\000\205\000\205\000\205\000\205\000\255\255\205\000\ \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ \205\000\205\000\205\000\205\000\205\000\205\000\255\255\205\000\ \205\000\205\000\205\000\205\000\205\000\205\000\205\000\206\000\ \255\255\255\255\255\255\255\255\255\255\206\000\255\255\255\255\ \255\255\255\255\255\255\255\255\206\000\255\255\206\000\206\000\ \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ \206\000\255\255\255\255\255\255\255\255\255\255\255\255\206\000\ \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ \206\000\255\255\255\255\255\255\255\255\206\000\255\255\206\000\ \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ \206\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\206\000\206\000\ \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ \206\000\206\000\206\000\206\000\206\000\255\255\206\000\206\000\ \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ \206\000\206\000\206\000\206\000\206\000\209\000\206\000\206\000\ \206\000\206\000\206\000\206\000\206\000\206\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\255\255\255\255\255\255\255\255\255\255\255\255\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\255\255\255\255\255\255\255\255\209\000\255\255\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\255\255\255\255\255\255\255\255\255\255\255\255\218\000\ \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ \218\000\255\255\255\255\255\255\255\255\218\000\255\255\218\000\ \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ \218\000\255\255\255\255\255\255\255\255\255\255\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\255\255\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\255\255\209\000\209\000\ \209\000\209\000\209\000\209\000\209\000\209\000\218\000\218\000\ \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ \218\000\218\000\218\000\218\000\218\000\255\255\218\000\218\000\ \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ \218\000\218\000\218\000\218\000\218\000\255\255\218\000\218\000\ \218\000\218\000\218\000\218\000\218\000\218\000\219\000\219\000\ \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ \255\255\255\255\255\255\255\255\219\000\255\255\219\000\219\000\ \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\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\219\000\219\000\219\000\ \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ \219\000\219\000\219\000\219\000\255\255\219\000\219\000\219\000\ \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ \219\000\219\000\219\000\219\000\220\000\219\000\219\000\219\000\ \219\000\219\000\219\000\219\000\219\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\255\255\ \255\255\220\000\255\255\255\255\255\255\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \255\255\255\255\255\255\255\255\220\000\255\255\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\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\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\255\255\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\221\000\220\000\220\000\220\000\ \220\000\220\000\220\000\220\000\220\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\255\255\ \255\255\221\000\255\255\255\255\255\255\255\255\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \255\255\255\255\255\255\255\255\221\000\255\255\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\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\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\255\255\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\255\255\221\000\221\000\221\000\ \221\000\221\000\221\000\221\000\221\000\255\255"; Lexing.lex_base_code = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\027\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\066\000\101\000\136\000\171\000\ \206\000\000\000\000\000\000\000\000\000\241\000\020\001\055\001\ \000\000\000\000\018\000\090\001\125\001\160\001\195\001\230\001\ \000\000\021\000\026\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\247\001\040\002\000\000\034\000\000\000\ \000\000\003\000\000\000\000\000\049\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \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\000\000\000\000\000\000\000\ \000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\036\002\000\000\244\002\ \000\000\000\000\000\000\061\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\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_backtrk_code = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\034\000\000\000\000\000\ \000\000\000\000\000\000\049\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\061\000\061\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\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_default_code = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \041\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\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_trans_code = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\001\000\000\000\058\000\058\000\000\000\058\000\000\000\ \000\000\000\000\000\000\000\000\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\000\000\000\000\000\001\000\007\000\044\000\000\000\007\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\000\000\007\000\012\000\000\000\000\000\012\000\ \012\000\012\000\000\000\000\000\000\000\000\000\012\000\000\000\ \012\000\012\000\012\000\007\000\000\000\000\000\007\000\000\000\ \000\000\000\000\000\000\000\000\000\000\012\000\000\000\012\000\ \012\000\012\000\012\000\012\000\000\000\000\000\000\000\000\000\ \000\000\000\000\007\000\015\000\000\000\000\000\015\000\015\000\ \015\000\000\000\000\000\000\000\015\000\015\000\000\000\015\000\ \015\000\015\000\000\000\000\000\000\000\000\000\000\000\012\000\ \000\000\012\000\000\000\000\000\015\000\000\000\015\000\015\000\ \015\000\015\000\015\000\000\000\000\000\000\000\012\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\012\000\000\000\000\000\012\000\ \000\000\012\000\000\000\000\000\000\000\000\000\015\000\012\000\ \015\000\012\000\012\000\012\000\012\000\012\000\000\000\000\000\ \000\000\012\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\012\000\ \000\000\000\000\000\000\000\000\000\000\000\000\015\000\000\000\ \015\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ \012\000\000\000\000\000\000\000\012\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\012\000\000\000\000\000\000\000\000\000\000\000\ \000\000\012\000\000\000\012\000\012\000\012\000\012\000\012\000\ \012\000\012\000\012\000\012\000\000\000\000\000\000\000\012\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\012\000\000\000\000\000\ \000\000\000\000\000\000\000\000\012\000\000\000\012\000\012\000\ \012\000\012\000\012\000\012\000\012\000\012\000\012\000\000\000\ \000\000\000\000\012\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\ \012\000\000\000\000\000\000\000\000\000\000\000\000\000\012\000\ \000\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ \012\000\012\000\000\000\000\000\000\000\012\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\012\000\000\000\000\000\000\000\000\000\ \000\000\000\000\012\000\000\000\012\000\012\000\012\000\012\000\ \012\000\012\000\012\000\012\000\012\000\000\000\000\000\000\000\ \012\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\012\000\000\000\ \000\000\000\000\000\000\000\000\000\000\012\000\000\000\012\000\ \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ \000\000\000\000\000\000\012\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\012\000\000\000\000\000\000\000\000\000\000\000\000\000\ \012\000\000\000\012\000\012\000\012\000\012\000\012\000\012\000\ \012\000\012\000\012\000\000\000\000\000\000\000\012\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\012\000\000\000\000\000\000\000\ \000\000\000\000\000\000\012\000\000\000\012\000\012\000\012\000\ \012\000\012\000\012\000\012\000\012\000\012\000\000\000\000\000\ \000\000\012\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\012\000\ \000\000\000\000\000\000\000\000\000\000\000\000\012\000\000\000\ \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ \012\000\000\000\000\000\000\000\015\000\000\000\000\000\015\000\ \015\000\015\000\000\000\000\000\000\000\015\000\015\000\000\000\ \015\000\015\000\015\000\000\000\000\000\000\000\000\000\000\000\ \000\000\012\000\000\000\012\000\012\000\015\000\012\000\015\000\ \015\000\015\000\015\000\015\000\000\000\000\000\000\000\015\000\ \000\000\000\000\015\000\015\000\015\000\000\000\000\000\000\000\ \015\000\015\000\000\000\015\000\015\000\015\000\000\000\000\000\ \000\000\029\000\000\000\000\000\012\000\000\000\012\000\015\000\ \015\000\015\000\015\000\015\000\015\000\015\000\015\000\004\000\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\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\015\000\ \000\000\015\000\015\000\000\000\015\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\ \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ \004\000\004\000\015\000\000\000\015\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\000\000\ \000\000\000\000\000\000\058\000\000\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\000\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\000\000\ \000\000\000\000\000\000\058\000\000\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\000\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\000\000\058\000\058\000\058\000\058\000\ \058\000\058\000\058\000\058\000\000\000"; Lexing.lex_check_code = "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\016\000\104\000\164\000\170\000\104\000\164\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\ \016\000\255\255\104\000\000\000\019\000\105\000\255\255\019\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ \016\000\016\000\255\255\019\000\019\000\255\255\255\255\019\000\ \019\000\019\000\255\255\255\255\255\255\255\255\019\000\255\255\ \019\000\019\000\019\000\060\000\255\255\255\255\060\000\255\255\ \255\255\255\255\255\255\255\255\255\255\019\000\255\255\019\000\ \019\000\019\000\019\000\019\000\255\255\255\255\255\255\255\255\ \255\255\255\255\060\000\060\000\255\255\255\255\060\000\060\000\ \060\000\255\255\255\255\255\255\060\000\060\000\255\255\060\000\ \060\000\060\000\255\255\255\255\255\255\255\255\255\255\019\000\ \255\255\019\000\255\255\255\255\060\000\255\255\060\000\060\000\ \060\000\060\000\060\000\255\255\255\255\255\255\061\000\255\255\ \255\255\061\000\061\000\061\000\255\255\255\255\255\255\061\000\ \061\000\255\255\061\000\061\000\061\000\255\255\255\255\019\000\ \255\255\019\000\255\255\255\255\255\255\255\255\060\000\061\000\ \060\000\061\000\061\000\061\000\061\000\061\000\255\255\255\255\ \255\255\062\000\255\255\255\255\062\000\062\000\062\000\255\255\ \255\255\255\255\062\000\062\000\255\255\062\000\062\000\062\000\ \255\255\255\255\255\255\255\255\255\255\255\255\060\000\255\255\ \060\000\061\000\062\000\061\000\062\000\062\000\062\000\062\000\ \062\000\255\255\255\255\255\255\063\000\255\255\255\255\063\000\ \063\000\063\000\255\255\255\255\255\255\063\000\063\000\255\255\ \063\000\063\000\063\000\255\255\255\255\255\255\255\255\255\255\ \255\255\061\000\255\255\061\000\062\000\063\000\062\000\063\000\ \063\000\063\000\063\000\063\000\255\255\255\255\255\255\064\000\ \255\255\255\255\064\000\064\000\064\000\255\255\255\255\255\255\ \064\000\064\000\255\255\064\000\064\000\064\000\255\255\255\255\ \104\000\255\255\255\255\255\255\062\000\255\255\062\000\063\000\ \064\000\063\000\064\000\064\000\064\000\064\000\064\000\255\255\ \255\255\255\255\069\000\255\255\255\255\069\000\069\000\069\000\ \255\255\255\255\255\255\069\000\069\000\255\255\069\000\069\000\ \069\000\255\255\255\255\255\255\255\255\255\255\255\255\063\000\ \255\255\063\000\064\000\069\000\064\000\069\000\069\000\069\000\ \069\000\069\000\255\255\255\255\255\255\070\000\255\255\255\255\ \070\000\070\000\070\000\255\255\255\255\255\255\070\000\070\000\ \255\255\070\000\070\000\070\000\255\255\255\255\255\255\255\255\ \255\255\255\255\064\000\255\255\064\000\069\000\070\000\069\000\ \070\000\070\000\070\000\070\000\070\000\255\255\255\255\255\255\ \071\000\255\255\255\255\071\000\071\000\071\000\255\255\255\255\ \255\255\071\000\071\000\255\255\071\000\071\000\071\000\255\255\ \255\255\255\255\255\255\255\255\255\255\069\000\255\255\069\000\ \070\000\071\000\070\000\071\000\071\000\071\000\071\000\071\000\ \255\255\255\255\255\255\075\000\255\255\255\255\075\000\075\000\ \075\000\255\255\255\255\255\255\075\000\075\000\255\255\075\000\ \075\000\075\000\255\255\255\255\255\255\255\255\255\255\255\255\ \070\000\255\255\070\000\071\000\075\000\071\000\075\000\075\000\ \075\000\075\000\075\000\255\255\255\255\255\255\076\000\255\255\ \255\255\076\000\076\000\076\000\255\255\255\255\255\255\076\000\ \076\000\255\255\076\000\076\000\076\000\255\255\255\255\255\255\ \255\255\255\255\255\255\071\000\255\255\071\000\075\000\076\000\ \075\000\076\000\076\000\076\000\076\000\076\000\255\255\255\255\ \255\255\077\000\255\255\255\255\077\000\077\000\077\000\255\255\ \255\255\255\255\077\000\077\000\255\255\077\000\077\000\077\000\ \255\255\255\255\255\255\255\255\255\255\255\255\075\000\255\255\ \075\000\076\000\077\000\076\000\077\000\077\000\077\000\077\000\ \077\000\255\255\255\255\255\255\078\000\255\255\255\255\078\000\ \078\000\078\000\255\255\255\255\255\255\078\000\078\000\255\255\ \078\000\078\000\078\000\255\255\255\255\255\255\255\255\255\255\ \255\255\076\000\255\255\076\000\077\000\078\000\077\000\078\000\ \078\000\078\000\078\000\078\000\255\255\255\255\255\255\079\000\ \255\255\255\255\079\000\079\000\079\000\255\255\255\255\255\255\ \079\000\079\000\255\255\079\000\079\000\079\000\255\255\255\255\ \255\255\099\000\255\255\255\255\077\000\255\255\077\000\078\000\ \079\000\078\000\079\000\079\000\079\000\079\000\079\000\099\000\ \099\000\099\000\099\000\099\000\099\000\099\000\099\000\099\000\ \099\000\100\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\078\000\ \255\255\078\000\079\000\255\255\079\000\255\255\255\255\255\255\ \100\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\ \100\000\100\000\100\000\100\000\100\000\100\000\100\000\100\000\ \100\000\100\000\079\000\255\255\079\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\255\255\ \255\255\255\255\255\255\181\000\255\255\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\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\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\255\255\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\183\000\181\000\181\000\181\000\181\000\ \181\000\181\000\181\000\181\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\255\255\ \255\255\255\255\255\255\183\000\255\255\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\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\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\255\255\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\255\255\183\000\183\000\183\000\183\000\ \183\000\183\000\183\000\183\000\255\255"; Lexing.lex_code = "\255\004\255\255\009\255\255\006\255\005\255\255\007\255\255\008\ \255\255\000\007\255\000\006\001\008\255\000\005\255\011\255\010\ \255\255\003\255\000\004\001\009\255\011\255\255\010\255\011\255\ \255\000\004\001\009\003\010\002\011\255\001\255\255\000\001\255\ "; } let rec token c lexbuf = (lexbuf.Lexing.lex_mem <- Array.create 12 (-1); __ocaml_lex_token_rec c lexbuf 0) and __ocaml_lex_token_rec c lexbuf __ocaml_lex_state = match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> (update_loc c None 1 false 0; NEWLINE) | 1 -> let x = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in BLANKS x | 2 -> let x = Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 1) (lexbuf.Lexing.lex_curr_pos + (-1)) in LABEL x | 3 -> let x = Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 1) (lexbuf.Lexing.lex_curr_pos + (-1)) in OPTLABEL x | 4 -> let x = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in LIDENT x | 5 -> let x = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in UIDENT x | 6 -> let i = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in (try INT ((cvt_int_literal i), i) with | Failure _ -> err (Literal_overflow "int") (Loc.of_lexbuf lexbuf)) | 7 -> let f = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in (try FLOAT ((float_of_string f), f) with | Failure _ -> err (Literal_overflow "float") (Loc.of_lexbuf lexbuf)) | 8 -> let i = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + (-1)) in (try INT32 ((cvt_int32_literal i), i) with | Failure _ -> err (Literal_overflow "int32") (Loc.of_lexbuf lexbuf)) | 9 -> let i = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + (-1)) in (try INT64 ((cvt_int64_literal i), i) with | Failure _ -> err (Literal_overflow "int64") (Loc.of_lexbuf lexbuf)) | 10 -> let i = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + (-1)) in (try NATIVEINT ((cvt_nativeint_literal i), i) with | Failure _ -> err (Literal_overflow "nativeint") (Loc.of_lexbuf lexbuf)) | 11 -> (with_curr_loc string c; let s = buff_contents c in STRING ((TokenEval.string s), s)) | 12 -> let x = Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 1) (lexbuf.Lexing.lex_curr_pos + (-1)) in (update_loc c None 1 false 1; CHAR ((TokenEval.char x), x)) | 13 -> let x = Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 1) (lexbuf.Lexing.lex_curr_pos + (-1)) in CHAR ((TokenEval.char x), x) | 14 -> let c = Lexing.sub_lexeme_char lexbuf (lexbuf.Lexing.lex_start_pos + 2) in err (Illegal_escape (String.make 1 c)) (Loc.of_lexbuf lexbuf) | 15 -> (store c; COMMENT (parse_nested comment (in_comment c))) | 16 -> (warn Comment_start (Loc.of_lexbuf lexbuf); parse comment (in_comment c); COMMENT (buff_contents c)) | 17 -> (warn Comment_not_end (Loc.of_lexbuf lexbuf); move_start_p (-1) c; SYMBOL "*") | 18 -> let beginning = Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 2) lexbuf.Lexing.lex_curr_pos in if quotations c then (move_start_p (- (String.length beginning)); mk_quotation quotation c "" "" 2) else parse (symbolchar_star ("<<" ^ beginning)) c | 19 -> if quotations c then QUOTATION { q_name = ""; q_loc = ""; q_shift = 2; q_contents = ""; } else parse (symbolchar_star "<<>>") c | 20 -> if quotations c then with_curr_loc maybe_quotation_at c else parse (symbolchar_star "<@") c | 21 -> if quotations c then with_curr_loc maybe_quotation_colon c else parse (symbolchar_star "<:") c | 22 -> let num = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) lexbuf.Lexing.lex_mem.(1) and name = Lexing.sub_lexeme_opt lexbuf lexbuf.Lexing.lex_mem.(3) lexbuf.Lexing.lex_mem.(2) in let inum = int_of_string num in (update_loc c name inum true 0; LINE_DIRECTIVE (inum, name)) | 23 -> let op = Lexing.sub_lexeme_char lexbuf (lexbuf.Lexing.lex_start_pos + 1) in ESCAPED_IDENT (String.make 1 op) | 24 -> let op = Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 1) (lexbuf.Lexing.lex_curr_pos + (-1)) in ESCAPED_IDENT op | 25 -> let op = Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 1) lexbuf.Lexing.lex_mem.(0) in ESCAPED_IDENT op | 26 -> let op = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) (lexbuf.Lexing.lex_curr_pos + (-1)) in ESCAPED_IDENT op | 27 -> let op = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) lexbuf.Lexing.lex_mem.(1) in ESCAPED_IDENT op | 28 -> let x = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in SYMBOL x | 29 -> if antiquots c then with_curr_loc dollar (shift 1 c) else parse (symbolchar_star "$") c | 30 -> let x = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in SYMBOL x | 31 -> let pos = lexbuf.lex_curr_p in (lexbuf.lex_curr_p <- { (pos) with pos_bol = pos.pos_bol + 1; pos_cnum = pos.pos_cnum + 1; }; EOI) | 32 -> let c = Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in err (Illegal_character c) (Loc.of_lexbuf lexbuf) | __ocaml_lex_state -> (lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_token_rec c lexbuf __ocaml_lex_state) and comment c lexbuf = __ocaml_lex_comment_rec c lexbuf 123 and __ocaml_lex_comment_rec c lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> (store c; with_curr_loc comment c; parse comment c) | 1 -> store c | 2 -> (store c; if quotations c then with_curr_loc quotation c else (); parse comment c) | 3 -> store_parse comment c | 4 -> (store c; (try with_curr_loc string c with | Loc.Exc_located (_, (Error.E Unterminated_string)) -> err Unterminated_string_in_comment (loc c)); Buffer.add_char c.buffer '"'; parse comment c) | 5 -> store_parse comment c | 6 -> store_parse comment c | 7 -> (update_loc c None 1 false 1; store_parse comment c) | 8 -> store_parse comment c | 9 -> store_parse comment c | 10 -> store_parse comment c | 11 -> store_parse comment c | 12 -> err Unterminated_comment (loc c) | 13 -> (update_loc c None 1 false 0; store_parse comment c) | 14 -> store_parse comment c | __ocaml_lex_state -> (lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_comment_rec c lexbuf __ocaml_lex_state) and string c lexbuf = (lexbuf.Lexing.lex_mem <- Array.create 2 (-1); __ocaml_lex_string_rec c lexbuf 159) and __ocaml_lex_string_rec c lexbuf __ocaml_lex_state = match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> set_start_p c | 1 -> let space = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) lexbuf.Lexing.lex_curr_pos in (update_loc c None 1 false (String.length space); store_parse string c) | 2 -> store_parse string c | 3 -> store_parse string c | 4 -> store_parse string c | 5 -> let x = Lexing.sub_lexeme_char lexbuf (lexbuf.Lexing.lex_start_pos + 1) in if is_in_comment c then store_parse string c else (warn (Illegal_escape (String.make 1 x)) (Loc.of_lexbuf lexbuf); store_parse string c) | 6 -> (update_loc c None 1 false 0; store_parse string c) | 7 -> err Unterminated_string (loc c) | 8 -> store_parse string c | __ocaml_lex_state -> (lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_string_rec c lexbuf __ocaml_lex_state) and symbolchar_star beginning c lexbuf = __ocaml_lex_symbolchar_star_rec beginning c lexbuf 176 and __ocaml_lex_symbolchar_star_rec beginning c lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> let tok = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in (move_start_p (- (String.length beginning)) c; SYMBOL (beginning ^ tok)) | __ocaml_lex_state -> (lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_symbolchar_star_rec beginning c lexbuf __ocaml_lex_state) and maybe_quotation_at c lexbuf = __ocaml_lex_maybe_quotation_at_rec c lexbuf 177 and __ocaml_lex_maybe_quotation_at_rec c lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> let loc = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + (-1)) in mk_quotation quotation c "" loc (1 + (String.length loc)) | 1 -> let tok = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in SYMBOL ("<@" ^ tok) | __ocaml_lex_state -> (lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_maybe_quotation_at_rec c lexbuf __ocaml_lex_state) and maybe_quotation_colon c lexbuf = (lexbuf.Lexing.lex_mem <- Array.create 2 (-1); __ocaml_lex_maybe_quotation_colon_rec c lexbuf 181) and __ocaml_lex_maybe_quotation_colon_rec c lexbuf __ocaml_lex_state = match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> let name = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + (-1)) in mk_quotation quotation c name "" (1 + (String.length name)) | 1 -> let name = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_mem.(0) and loc = Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_mem.(0) + 1) (lexbuf.Lexing.lex_curr_pos + (-1)) in mk_quotation quotation c name loc ((2 + (String.length loc)) + (String.length name)) | 2 -> let tok = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in SYMBOL ("<:" ^ tok) | __ocaml_lex_state -> (lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_maybe_quotation_colon_rec c lexbuf __ocaml_lex_state) and quotation c lexbuf = __ocaml_lex_quotation_rec c lexbuf 188 and __ocaml_lex_quotation_rec c lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> (store c; with_curr_loc quotation c; parse quotation c) | 1 -> store c | 2 -> err Unterminated_quotation (loc c) | 3 -> (update_loc c None 1 false 0; store_parse quotation c) | 4 -> store_parse quotation c | __ocaml_lex_state -> (lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_quotation_rec c lexbuf __ocaml_lex_state) and dollar c lexbuf = __ocaml_lex_dollar_rec c lexbuf 201 and __ocaml_lex_dollar_rec c lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> (set_start_p c; ANTIQUOT ("", "")) | 1 -> let name = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + (-1)) in with_curr_loc (antiquot name) (shift (1 + (String.length name)) c) | 2 -> store_parse (antiquot "") c | __ocaml_lex_state -> (lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_dollar_rec c lexbuf __ocaml_lex_state) and antiquot name c lexbuf = __ocaml_lex_antiquot_rec name c lexbuf 210 and __ocaml_lex_antiquot_rec name c lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> (set_start_p c; ANTIQUOT (name, (buff_contents c))) | 1 -> err Unterminated_antiquot (loc c) | 2 -> (update_loc c None 1 false 0; store_parse (antiquot name) c) | 3 -> (store c; with_curr_loc quotation c; parse (antiquot name) c) | 4 -> store_parse (antiquot name) c | __ocaml_lex_state -> (lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_antiquot_rec name c lexbuf __ocaml_lex_state) let lexing_store s buff max = let rec self n s = if n >= max then n else (match Stream.peek s with | Some x -> (Stream.junk s; buff.[n] <- x; succ n) | _ -> n) in self 0 s let from_context c = let next _ = let tok = with_curr_loc token c in let loc = Loc.of_lexbuf c.lexbuf in Some (tok, loc) in Stream.from next let from_lexbuf ?(quotations = true) lb = let c = { (default_context lb) with loc = Loc.of_lexbuf lb; antiquots = !Camlp4_config.antiquotations; quotations = quotations; } in from_context c let setup_loc lb loc = let start_pos = Loc.start_pos loc in (lb.lex_abs_pos <- start_pos.pos_cnum; lb.lex_curr_p <- start_pos) let from_string ?quotations loc str = let lb = Lexing.from_string str in (setup_loc lb loc; from_lexbuf ?quotations lb) let from_stream ?quotations loc strm = let lb = Lexing.from_function (lexing_store strm) in (setup_loc lb loc; from_lexbuf ?quotations lb) let mk () loc strm = from_stream ~quotations: !Camlp4_config.quotations loc strm end end module Camlp4Ast = struct module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = struct module Loc = Loc module Ast = struct include Sig.MakeCamlp4Ast(Loc) let safe_string_escaped s = if ((String.length s) > 2) && ((s.[0] = '\\') && (s.[1] = '$')) then s else String.escaped s end include Ast external loc_of_ctyp : ctyp -> Loc.t = "%field0" external loc_of_patt : patt -> Loc.t = "%field0" external loc_of_expr : expr -> Loc.t = "%field0" external loc_of_module_type : module_type -> Loc.t = "%field0" external loc_of_module_expr : module_expr -> Loc.t = "%field0" external loc_of_sig_item : sig_item -> Loc.t = "%field0" external loc_of_str_item : str_item -> Loc.t = "%field0" external loc_of_class_type : class_type -> Loc.t = "%field0" external loc_of_class_sig_item : class_sig_item -> Loc.t = "%field0" external loc_of_class_expr : class_expr -> Loc.t = "%field0" external loc_of_class_str_item : class_str_item -> Loc.t = "%field0" external loc_of_with_constr : with_constr -> Loc.t = "%field0" external loc_of_binding : binding -> Loc.t = "%field0" external loc_of_rec_binding : rec_binding -> Loc.t = "%field0" external loc_of_module_binding : module_binding -> Loc.t = "%field0" external loc_of_match_case : match_case -> Loc.t = "%field0" external loc_of_ident : ident -> Loc.t = "%field0" let ghost = Loc.ghost let rec is_module_longident = function | Ast.IdAcc (_, _, i) -> is_module_longident i | Ast.IdApp (_, i1, i2) -> (is_module_longident i1) && (is_module_longident i2) | Ast.IdUid (_, _) -> true | _ -> false let ident_of_expr = let error () = invalid_arg "ident_of_expr: this expression is not an identifier" in let rec self = function | Ast.ExApp (_loc, e1, e2) -> Ast.IdApp (_loc, (self e1), (self e2)) | Ast.ExAcc (_loc, e1, e2) -> Ast.IdAcc (_loc, (self e1), (self e2)) | Ast.ExId (_, (Ast.IdLid (_, _))) -> error () | Ast.ExId (_, i) -> if is_module_longident i then i else error () | _ -> error () in function | Ast.ExId (_, i) -> i | Ast.ExApp (_, _, _) -> error () | t -> self t let ident_of_ctyp = let error () = invalid_arg "ident_of_ctyp: this type is not an identifier" in let rec self = function | Ast.TyApp (_loc, t1, t2) -> Ast.IdApp (_loc, (self t1), (self t2)) | Ast.TyId (_, (Ast.IdLid (_, _))) -> error () | Ast.TyId (_, i) -> if is_module_longident i then i else error () | _ -> error () in function | Ast.TyId (_, i) -> i | t -> self t let ident_of_patt = let error () = invalid_arg "ident_of_patt: this pattern is not an identifier" in let rec self = function | Ast.PaApp (_loc, p1, p2) -> Ast.IdApp (_loc, (self p1), (self p2)) | Ast.PaId (_, (Ast.IdLid (_, _))) -> error () | Ast.PaId (_, i) -> if is_module_longident i then i else error () | _ -> error () in function | Ast.PaId (_, i) -> i | p -> self p let rec is_irrefut_patt = function | Ast.PaId (_, (Ast.IdLid (_, _))) -> true | Ast.PaId (_, (Ast.IdUid (_, "()"))) -> true | Ast.PaAny _ -> true | Ast.PaNil _ -> true | Ast.PaAli (_, x, y) -> (is_irrefut_patt x) && (is_irrefut_patt y) | Ast.PaRec (_, p) -> is_irrefut_patt p | Ast.PaEq (_, _, p) -> is_irrefut_patt p | Ast.PaSem (_, p1, p2) -> (is_irrefut_patt p1) && (is_irrefut_patt p2) | Ast.PaCom (_, p1, p2) -> (is_irrefut_patt p1) && (is_irrefut_patt p2) | Ast.PaOrp (_, p1, p2) -> (is_irrefut_patt p1) && (is_irrefut_patt p2) | Ast.PaApp (_, p1, p2) -> (is_irrefut_patt p1) && (is_irrefut_patt p2) | Ast.PaTyc (_, p, _) -> is_irrefut_patt p | Ast.PaTup (_, pl) -> is_irrefut_patt pl | Ast.PaOlb (_, _, (Ast.PaNil _)) -> true | Ast.PaOlb (_, _, p) -> is_irrefut_patt p | Ast.PaOlbi (_, _, p, _) -> is_irrefut_patt p | Ast.PaLab (_, _, (Ast.PaNil _)) -> true | Ast.PaLab (_, _, p) -> is_irrefut_patt p | Ast.PaLaz (_, p) -> is_irrefut_patt p | Ast.PaId (_, _) -> false | Ast.PaMod (_, _) -> true | Ast.PaVrn (_, _) | Ast.PaStr (_, _) | Ast.PaRng (_, _, _) | Ast.PaFlo (_, _) | Ast.PaNativeInt (_, _) | Ast.PaInt64 (_, _) | Ast.PaInt32 (_, _) | Ast.PaInt (_, _) | Ast.PaChr (_, _) | Ast.PaTyp (_, _) | Ast.PaArr (_, _) | Ast.PaAnt (_, _) -> false let rec is_constructor = function | Ast.IdAcc (_, _, i) -> is_constructor i | Ast.IdUid (_, _) -> true | Ast.IdLid (_, _) | Ast.IdApp (_, _, _) -> false | Ast.IdAnt (_, _) -> assert false let is_patt_constructor = function | Ast.PaId (_, i) -> is_constructor i | Ast.PaVrn (_, _) -> true | _ -> false let rec is_expr_constructor = function | Ast.ExId (_, i) -> is_constructor i | Ast.ExAcc (_, e1, e2) -> (is_expr_constructor e1) && (is_expr_constructor e2) | Ast.ExVrn (_, _) -> true | _ -> false let rec tyOr_of_list = function | [] -> Ast.TyNil ghost | [ t ] -> t | t :: ts -> let _loc = loc_of_ctyp t in Ast.TyOr (_loc, t, (tyOr_of_list ts)) let rec tyAnd_of_list = function | [] -> Ast.TyNil ghost | [ t ] -> t | t :: ts -> let _loc = loc_of_ctyp t in Ast.TyAnd (_loc, t, (tyAnd_of_list ts)) let rec tySem_of_list = function | [] -> Ast.TyNil ghost | [ t ] -> t | t :: ts -> let _loc = loc_of_ctyp t in Ast.TySem (_loc, t, (tySem_of_list ts)) let rec tyCom_of_list = function | [] -> Ast.TyNil ghost | [ t ] -> t | t :: ts -> let _loc = loc_of_ctyp t in Ast.TyCom (_loc, t, (tyCom_of_list ts)) let rec tyAmp_of_list = function | [] -> Ast.TyNil ghost | [ t ] -> t | t :: ts -> let _loc = loc_of_ctyp t in Ast.TyAmp (_loc, t, (tyAmp_of_list ts)) let rec tySta_of_list = function | [] -> Ast.TyNil ghost | [ t ] -> t | t :: ts -> let _loc = loc_of_ctyp t in Ast.TySta (_loc, t, (tySta_of_list ts)) let rec stSem_of_list = function | [] -> Ast.StNil ghost | [ t ] -> t | t :: ts -> let _loc = loc_of_str_item t in Ast.StSem (_loc, t, (stSem_of_list ts)) let rec sgSem_of_list = function | [] -> Ast.SgNil ghost | [ t ] -> t | t :: ts -> let _loc = loc_of_sig_item t in Ast.SgSem (_loc, t, (sgSem_of_list ts)) let rec biAnd_of_list = function | [] -> Ast.BiNil ghost | [ b ] -> b | b :: bs -> let _loc = loc_of_binding b in Ast.BiAnd (_loc, b, (biAnd_of_list bs)) let rec rbSem_of_list = function | [] -> Ast.RbNil ghost | [ b ] -> b | b :: bs -> let _loc = loc_of_rec_binding b in Ast.RbSem (_loc, b, (rbSem_of_list bs)) let rec wcAnd_of_list = function | [] -> Ast.WcNil ghost | [ w ] -> w | w :: ws -> let _loc = loc_of_with_constr w in Ast.WcAnd (_loc, w, (wcAnd_of_list ws)) let rec idAcc_of_list = function | [] -> assert false | [ i ] -> i | i :: is -> let _loc = loc_of_ident i in Ast.IdAcc (_loc, i, (idAcc_of_list is)) let rec idApp_of_list = function | [] -> assert false | [ i ] -> i | i :: is -> let _loc = loc_of_ident i in Ast.IdApp (_loc, i, (idApp_of_list is)) let rec mcOr_of_list = function | [] -> Ast.McNil ghost | [ x ] -> x | x :: xs -> let _loc = loc_of_match_case x in Ast.McOr (_loc, x, (mcOr_of_list xs)) let rec mbAnd_of_list = function | [] -> Ast.MbNil ghost | [ x ] -> x | x :: xs -> let _loc = loc_of_module_binding x in Ast.MbAnd (_loc, x, (mbAnd_of_list xs)) let rec meApp_of_list = function | [] -> assert false | [ x ] -> x | x :: xs -> let _loc = loc_of_module_expr x in Ast.MeApp (_loc, x, (meApp_of_list xs)) let rec ceAnd_of_list = function | [] -> Ast.CeNil ghost | [ x ] -> x | x :: xs -> let _loc = loc_of_class_expr x in Ast.CeAnd (_loc, x, (ceAnd_of_list xs)) let rec ctAnd_of_list = function | [] -> Ast.CtNil ghost | [ x ] -> x | x :: xs -> let _loc = loc_of_class_type x in Ast.CtAnd (_loc, x, (ctAnd_of_list xs)) let rec cgSem_of_list = function | [] -> Ast.CgNil ghost | [ x ] -> x | x :: xs -> let _loc = loc_of_class_sig_item x in Ast.CgSem (_loc, x, (cgSem_of_list xs)) let rec crSem_of_list = function | [] -> Ast.CrNil ghost | [ x ] -> x | x :: xs -> let _loc = loc_of_class_str_item x in Ast.CrSem (_loc, x, (crSem_of_list xs)) let rec paSem_of_list = function | [] -> Ast.PaNil ghost | [ x ] -> x | x :: xs -> let _loc = loc_of_patt x in Ast.PaSem (_loc, x, (paSem_of_list xs)) let rec paCom_of_list = function | [] -> Ast.PaNil ghost | [ x ] -> x | x :: xs -> let _loc = loc_of_patt x in Ast.PaCom (_loc, x, (paCom_of_list xs)) let rec exSem_of_list = function | [] -> Ast.ExNil ghost | [ x ] -> x | x :: xs -> let _loc = loc_of_expr x in Ast.ExSem (_loc, x, (exSem_of_list xs)) let rec exCom_of_list = function | [] -> Ast.ExNil ghost | [ x ] -> x | x :: xs -> let _loc = loc_of_expr x in Ast.ExCom (_loc, x, (exCom_of_list xs)) let ty_of_stl = function | (_loc, s, []) -> Ast.TyId (_loc, (Ast.IdUid (_loc, s))) | (_loc, s, tl) -> Ast.TyOf (_loc, (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), (tyAnd_of_list tl)) let ty_of_sbt = function | (_loc, s, true, t) -> Ast.TyCol (_loc, (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), (Ast.TyMut (_loc, t))) | (_loc, s, false, t) -> Ast.TyCol (_loc, (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), t) let bi_of_pe (p, e) = let _loc = loc_of_patt p in Ast.BiEq (_loc, p, e) let sum_type_of_list l = tyOr_of_list (List.map ty_of_stl l) let record_type_of_list l = tySem_of_list (List.map ty_of_sbt l) let binding_of_pel l = biAnd_of_list (List.map bi_of_pe l) let rec pel_of_binding = function | Ast.BiAnd (_, b1, b2) -> (pel_of_binding b1) @ (pel_of_binding b2) | Ast.BiEq (_, p, e) -> [ (p, e) ] | _ -> assert false let rec list_of_binding x acc = match x with | Ast.BiAnd (_, b1, b2) -> list_of_binding b1 (list_of_binding b2 acc) | t -> t :: acc let rec list_of_rec_binding x acc = match x with | Ast.RbSem (_, b1, b2) -> list_of_rec_binding b1 (list_of_rec_binding b2 acc) | t -> t :: acc let rec list_of_with_constr x acc = match x with | Ast.WcAnd (_, w1, w2) -> list_of_with_constr w1 (list_of_with_constr w2 acc) | t -> t :: acc let rec list_of_ctyp x acc = match x with | Ast.TyNil _ -> acc | Ast.TyAmp (_, x, y) | Ast.TyCom (_, x, y) | Ast.TySta (_, x, y) | Ast.TySem (_, x, y) | Ast.TyAnd (_, x, y) | Ast.TyOr (_, x, y) -> list_of_ctyp x (list_of_ctyp y acc) | x -> x :: acc let rec list_of_patt x acc = match x with | Ast.PaNil _ -> acc | Ast.PaCom (_, x, y) | Ast.PaSem (_, x, y) -> list_of_patt x (list_of_patt y acc) | x -> x :: acc let rec list_of_expr x acc = match x with | Ast.ExNil _ -> acc | Ast.ExCom (_, x, y) | Ast.ExSem (_, x, y) -> list_of_expr x (list_of_expr y acc) | x -> x :: acc let rec list_of_str_item x acc = match x with | Ast.StNil _ -> acc | Ast.StSem (_, x, y) -> list_of_str_item x (list_of_str_item y acc) | x -> x :: acc let rec list_of_sig_item x acc = match x with | Ast.SgNil _ -> acc | Ast.SgSem (_, x, y) -> list_of_sig_item x (list_of_sig_item y acc) | x -> x :: acc let rec list_of_class_sig_item x acc = match x with | Ast.CgNil _ -> acc | Ast.CgSem (_, x, y) -> list_of_class_sig_item x (list_of_class_sig_item y acc) | x -> x :: acc let rec list_of_class_str_item x acc = match x with | Ast.CrNil _ -> acc | Ast.CrSem (_, x, y) -> list_of_class_str_item x (list_of_class_str_item y acc) | x -> x :: acc let rec list_of_class_type x acc = match x with | Ast.CtAnd (_, x, y) -> list_of_class_type x (list_of_class_type y acc) | x -> x :: acc let rec list_of_class_expr x acc = match x with | Ast.CeAnd (_, x, y) -> list_of_class_expr x (list_of_class_expr y acc) | x -> x :: acc let rec list_of_module_expr x acc = match x with | Ast.MeApp (_, x, y) -> list_of_module_expr x (list_of_module_expr y acc) | x -> x :: acc let rec list_of_match_case x acc = match x with | Ast.McNil _ -> acc | Ast.McOr (_, x, y) -> list_of_match_case x (list_of_match_case y acc) | x -> x :: acc let rec list_of_ident x acc = match x with | Ast.IdAcc (_, x, y) | Ast.IdApp (_, x, y) -> list_of_ident x (list_of_ident y acc) | x -> x :: acc let rec list_of_module_binding x acc = match x with | Ast.MbAnd (_, x, y) -> list_of_module_binding x (list_of_module_binding y acc) | x -> x :: acc module Meta = struct module type META_LOC = sig val meta_loc_patt : Loc.t -> Loc.t -> Ast.patt val meta_loc_expr : Loc.t -> Loc.t -> Ast.expr end module MetaLoc = struct let meta_loc_patt _loc location = let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), (Ast.IdLid (_loc, "of_tuple")))))), (Ast.PaTup (_loc, (Ast.PaCom (_loc, (Ast.PaStr (_loc, (Ast.safe_string_escaped a))), (Ast.PaCom (_loc, (Ast.PaCom (_loc, (Ast.PaCom (_loc, (Ast.PaCom (_loc, (Ast.PaCom (_loc, (Ast.PaCom (_loc, (Ast.PaInt (_loc, (string_of_int b))), (Ast.PaInt (_loc, (string_of_int c))))), (Ast.PaInt (_loc, (string_of_int d))))), (Ast.PaInt (_loc, (string_of_int e))))), (Ast.PaInt (_loc, (string_of_int f))))), (Ast.PaInt (_loc, (string_of_int g))))), (if h then Ast.PaId (_loc, (Ast.IdUid (_loc, "True"))) else Ast.PaId (_loc, (Ast.IdUid (_loc, "False"))))))))))) let meta_loc_expr _loc location = let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), (Ast.IdLid (_loc, "of_tuple")))))), (Ast.ExTup (_loc, (Ast.ExCom (_loc, (Ast.ExStr (_loc, (Ast.safe_string_escaped a))), (Ast.ExCom (_loc, (Ast.ExCom (_loc, (Ast.ExCom (_loc, (Ast.ExCom (_loc, (Ast.ExCom (_loc, (Ast.ExCom (_loc, (Ast.ExInt (_loc, (string_of_int b))), (Ast.ExInt (_loc, (string_of_int c))))), (Ast.ExInt (_loc, (string_of_int d))))), (Ast.ExInt (_loc, (string_of_int e))))), (Ast.ExInt (_loc, (string_of_int f))))), (Ast.ExInt (_loc, (string_of_int g))))), (if h then Ast.ExId (_loc, (Ast.IdUid (_loc, "True"))) else Ast.ExId (_loc, (Ast.IdUid (_loc, "False"))))))))))) end module MetaGhostLoc = struct let meta_loc_patt _loc _ = Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), (Ast.IdLid (_loc, "ghost"))))) let meta_loc_expr _loc _ = Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), (Ast.IdLid (_loc, "ghost"))))) end module MetaLocVar = struct let meta_loc_patt _loc _ = Ast.PaId (_loc, (Ast.IdLid (_loc, !Loc.name))) let meta_loc_expr _loc _ = Ast.ExId (_loc, (Ast.IdLid (_loc, !Loc.name))) end module Make (MetaLoc : META_LOC) = struct open MetaLoc let meta_loc = meta_loc_expr module Expr = struct let meta_string _loc s = Ast.ExStr (_loc, (safe_string_escaped s)) let meta_int _loc s = Ast.ExInt (_loc, s) let meta_float _loc s = Ast.ExFlo (_loc, s) let meta_char _loc s = Ast.ExChr (_loc, (String.escaped s)) let meta_bool _loc = function | false -> Ast.ExId (_loc, (Ast.IdUid (_loc, "False"))) | true -> Ast.ExId (_loc, (Ast.IdUid (_loc, "True"))) let rec meta_list mf_a _loc = function | [] -> Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))) | x :: xs -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), (mf_a _loc x))), (meta_list mf_a _loc xs)) let rec meta_binding _loc = function | Ast.BiAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.BiEq (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "BiEq")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_expr _loc x2)) | Ast.BiAnd (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "BiAnd")))))), (meta_loc _loc x0))), (meta_binding _loc x1))), (meta_binding _loc x2)) | Ast.BiNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "BiNil")))))), (meta_loc _loc x0)) and meta_class_expr _loc = function | Ast.CeAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.CeEq (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeEq")))))), (meta_loc _loc x0))), (meta_class_expr _loc x1))), (meta_class_expr _loc x2)) | Ast.CeAnd (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeAnd")))))), (meta_loc _loc x0))), (meta_class_expr _loc x1))), (meta_class_expr _loc x2)) | Ast.CeTyc (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeTyc")))))), (meta_loc _loc x0))), (meta_class_expr _loc x1))), (meta_class_type _loc x2)) | Ast.CeStr (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeStr")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_class_str_item _loc x2)) | Ast.CeLet (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeLet")))))), (meta_loc _loc x0))), (meta_rec_flag _loc x1))), (meta_binding _loc x2))), (meta_class_expr _loc x3)) | Ast.CeFun (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeFun")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_class_expr _loc x2)) | Ast.CeCon (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeCon")))))), (meta_loc _loc x0))), (meta_virtual_flag _loc x1))), (meta_ident _loc x2))), (meta_ctyp _loc x3)) | Ast.CeApp (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeApp")))))), (meta_loc _loc x0))), (meta_class_expr _loc x1))), (meta_expr _loc x2)) | Ast.CeNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeNil")))))), (meta_loc _loc x0)) and meta_class_sig_item _loc = function | Ast.CgAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.CgVir (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgVir")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_private_flag _loc x2))), (meta_ctyp _loc x3)) | Ast.CgVal (x0, x1, x2, x3, x4) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgVal")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_mutable_flag _loc x2))), (meta_virtual_flag _loc x3))), (meta_ctyp _loc x4)) | Ast.CgMth (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgMth")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_private_flag _loc x2))), (meta_ctyp _loc x3)) | Ast.CgInh (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgInh")))))), (meta_loc _loc x0))), (meta_class_type _loc x1)) | Ast.CgSem (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgSem")))))), (meta_loc _loc x0))), (meta_class_sig_item _loc x1))), (meta_class_sig_item _loc x2)) | Ast.CgCtr (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgCtr")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.CgNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgNil")))))), (meta_loc _loc x0)) and meta_class_str_item _loc = function | Ast.CrAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.CrVvr (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrVvr")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_mutable_flag _loc x2))), (meta_ctyp _loc x3)) | Ast.CrVir (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrVir")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_private_flag _loc x2))), (meta_ctyp _loc x3)) | Ast.CrVal (x0, x1, x2, x3, x4) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrVal")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_override_flag _loc x2))), (meta_mutable_flag _loc x3))), (meta_expr _loc x4)) | Ast.CrMth (x0, x1, x2, x3, x4, x5) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrMth")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_override_flag _loc x2))), (meta_private_flag _loc x3))), (meta_expr _loc x4))), (meta_ctyp _loc x5)) | Ast.CrIni (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrIni")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.CrInh (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrInh")))))), (meta_loc _loc x0))), (meta_override_flag _loc x1))), (meta_class_expr _loc x2))), (meta_string _loc x3)) | Ast.CrCtr (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrCtr")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.CrSem (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrSem")))))), (meta_loc _loc x0))), (meta_class_str_item _loc x1))), (meta_class_str_item _loc x2)) | Ast.CrNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrNil")))))), (meta_loc _loc x0)) and meta_class_type _loc = function | Ast.CtAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.CtEq (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtEq")))))), (meta_loc _loc x0))), (meta_class_type _loc x1))), (meta_class_type _loc x2)) | Ast.CtCol (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtCol")))))), (meta_loc _loc x0))), (meta_class_type _loc x1))), (meta_class_type _loc x2)) | Ast.CtAnd (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtAnd")))))), (meta_loc _loc x0))), (meta_class_type _loc x1))), (meta_class_type _loc x2)) | Ast.CtSig (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtSig")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_class_sig_item _loc x2)) | Ast.CtFun (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtFun")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_class_type _loc x2)) | Ast.CtCon (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtCon")))))), (meta_loc _loc x0))), (meta_virtual_flag _loc x1))), (meta_ident _loc x2))), (meta_ctyp _loc x3)) | Ast.CtNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtNil")))))), (meta_loc _loc x0)) and meta_ctyp _loc = function | Ast.TyAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.TyPkg (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyPkg")))))), (meta_loc _loc x0))), (meta_module_type _loc x1)) | Ast.TyOfAmp (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyOfAmp")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyAmp (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyAmp")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyVrnInfSup (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyVrnInfSup")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyVrnInf (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyVrnInf")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TyVrnSup (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyVrnSup")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TyVrnEq (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyVrnEq")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TySta (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TySta")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyTup (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyTup")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TyMut (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyMut")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TyPrv (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyPrv")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TyOr (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyOr")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyAnd (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyAnd")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyOf (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyOf")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TySum (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TySum")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TyCom (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyCom")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TySem (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TySem")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyCol (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyCol")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyRec (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyRec")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TyVrn (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyVrn")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.TyAnM x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyAnM")))))), (meta_loc _loc x0)) | Ast.TyAnP x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyAnP")))))), (meta_loc _loc x0)) | Ast.TyQuM (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyQuM")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.TyQuP (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyQuP")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.TyQuo (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyQuo")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.TyTypePol (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyTypePol")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyPol (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyPol")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyOlb (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyOlb")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_ctyp _loc x2)) | Ast.TyObj (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyObj")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_row_var_flag _loc x2)) | Ast.TyDcl (x0, x1, x2, x3, x4) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyDcl")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_list meta_ctyp _loc x2))), (meta_ctyp _loc x3))), (meta_list (fun _loc (x1, x2) -> Ast.ExTup (_loc, (Ast.ExCom (_loc, (meta_ctyp _loc x1), (meta_ctyp _loc x2))))) _loc x4)) | Ast.TyMan (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyMan")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyId (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyId")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.TyLab (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyLab")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_ctyp _loc x2)) | Ast.TyCls (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyCls")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.TyArr (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyArr")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyApp (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyApp")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyAny x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyAny")))))), (meta_loc _loc x0)) | Ast.TyAli (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyAli")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyNil")))))), (meta_loc _loc x0)) and meta_direction_flag _loc = function | Ast.DiAnt x0 -> Ast.ExAnt (_loc, x0) | Ast.DiDownto -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "DiDownto"))))) | Ast.DiTo -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "DiTo"))))) and meta_expr _loc = function | Ast.ExPkg (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExPkg")))))), (meta_loc _loc x0))), (meta_module_expr _loc x1)) | Ast.ExFUN (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExFUN")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_expr _loc x2)) | Ast.ExOpI (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExOpI")))))), (meta_loc _loc x0))), (meta_ident _loc x1))), (meta_expr _loc x2)) | Ast.ExWhi (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExWhi")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExVrn (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExVrn")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExTyc (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExTyc")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_ctyp _loc x2)) | Ast.ExCom (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExCom")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExTup (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExTup")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.ExTry (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExTry")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_match_case _loc x2)) | Ast.ExStr (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExStr")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExSte (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExSte")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExSnd (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExSnd")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_string _loc x2)) | Ast.ExSeq (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExSeq")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.ExRec (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExRec")))))), (meta_loc _loc x0))), (meta_rec_binding _loc x1))), (meta_expr _loc x2)) | Ast.ExOvr (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExOvr")))))), (meta_loc _loc x0))), (meta_rec_binding _loc x1)) | Ast.ExOlb (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExOlb")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_expr _loc x2)) | Ast.ExObj (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExObj")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_class_str_item _loc x2)) | Ast.ExNew (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExNew")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.ExMat (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExMat")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_match_case _loc x2)) | Ast.ExLmd (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExLmd")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_expr _loc x2))), (meta_expr _loc x3)) | Ast.ExLet (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExLet")))))), (meta_loc _loc x0))), (meta_rec_flag _loc x1))), (meta_binding _loc x2))), (meta_expr _loc x3)) | Ast.ExLaz (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExLaz")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.ExLab (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExLab")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_expr _loc x2)) | Ast.ExNativeInt (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExNativeInt")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExInt64 (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExInt64")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExInt32 (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExInt32")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExInt (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExInt")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExIfe (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExIfe")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2))), (meta_expr _loc x3)) | Ast.ExFun (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExFun")))))), (meta_loc _loc x0))), (meta_match_case _loc x1)) | Ast.ExFor (x0, x1, x2, x3, x4, x5) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExFor")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_expr _loc x2))), (meta_expr _loc x3))), (meta_direction_flag _loc x4))), (meta_expr _loc x5)) | Ast.ExFlo (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExFlo")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExCoe (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExCoe")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_ctyp _loc x2))), (meta_ctyp _loc x3)) | Ast.ExChr (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExChr")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExAss (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExAss")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExAsr (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExAsr")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.ExAsf x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExAsf")))))), (meta_loc _loc x0)) | Ast.ExSem (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExSem")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExArr (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExArr")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.ExAre (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExAre")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExApp (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExApp")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.ExAcc (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExAcc")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExId (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExId")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.ExNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExNil")))))), (meta_loc _loc x0)) and meta_ident _loc = function | Ast.IdAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.IdUid (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "IdUid")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.IdLid (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "IdLid")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.IdApp (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "IdApp")))))), (meta_loc _loc x0))), (meta_ident _loc x1))), (meta_ident _loc x2)) | Ast.IdAcc (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "IdAcc")))))), (meta_loc _loc x0))), (meta_ident _loc x1))), (meta_ident _loc x2)) and meta_match_case _loc = function | Ast.McAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.McArr (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "McArr")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_expr _loc x2))), (meta_expr _loc x3)) | Ast.McOr (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "McOr")))))), (meta_loc _loc x0))), (meta_match_case _loc x1))), (meta_match_case _loc x2)) | Ast.McNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "McNil")))))), (meta_loc _loc x0)) and meta_meta_bool _loc = function | Ast.BAnt x0 -> Ast.ExAnt (_loc, x0) | Ast.BFalse -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "BFalse"))))) | Ast.BTrue -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "BTrue"))))) and meta_meta_list mf_a _loc = function | Ast.LAnt x0 -> Ast.ExAnt (_loc, x0) | Ast.LCons (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "LCons")))))), (mf_a _loc x0))), (meta_meta_list mf_a _loc x1)) | Ast.LNil -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "LNil"))))) and meta_meta_option mf_a _loc = function | Ast.OAnt x0 -> Ast.ExAnt (_loc, x0) | Ast.OSome x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "OSome")))))), (mf_a _loc x0)) | Ast.ONone -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ONone"))))) and meta_module_binding _loc = function | Ast.MbAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.MbCol (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MbCol")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_type _loc x2)) | Ast.MbColEq (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MbColEq")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_type _loc x2))), (meta_module_expr _loc x3)) | Ast.MbAnd (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MbAnd")))))), (meta_loc _loc x0))), (meta_module_binding _loc x1))), (meta_module_binding _loc x2)) | Ast.MbNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MbNil")))))), (meta_loc _loc x0)) and meta_module_expr _loc = function | Ast.MeAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.MePkg (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MePkg")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.MeTyc (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MeTyc")))))), (meta_loc _loc x0))), (meta_module_expr _loc x1))), (meta_module_type _loc x2)) | Ast.MeStr (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MeStr")))))), (meta_loc _loc x0))), (meta_str_item _loc x1)) | Ast.MeFun (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MeFun")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_type _loc x2))), (meta_module_expr _loc x3)) | Ast.MeApp (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MeApp")))))), (meta_loc _loc x0))), (meta_module_expr _loc x1))), (meta_module_expr _loc x2)) | Ast.MeId (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MeId")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.MeNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MeNil")))))), (meta_loc _loc x0)) and meta_module_type _loc = function | Ast.MtAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.MtOf (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtOf")))))), (meta_loc _loc x0))), (meta_module_expr _loc x1)) | Ast.MtWit (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtWit")))))), (meta_loc _loc x0))), (meta_module_type _loc x1))), (meta_with_constr _loc x2)) | Ast.MtSig (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtSig")))))), (meta_loc _loc x0))), (meta_sig_item _loc x1)) | Ast.MtQuo (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtQuo")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.MtFun (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtFun")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_type _loc x2))), (meta_module_type _loc x3)) | Ast.MtId (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtId")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.MtNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtNil")))))), (meta_loc _loc x0)) and meta_mutable_flag _loc = function | Ast.MuAnt x0 -> Ast.ExAnt (_loc, x0) | Ast.MuNil -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MuNil"))))) | Ast.MuMutable -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MuMutable"))))) and meta_override_flag _loc = function | Ast.OvAnt x0 -> Ast.ExAnt (_loc, x0) | Ast.OvNil -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "OvNil"))))) | Ast.OvOverride -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "OvOverride"))))) and meta_patt _loc = function | Ast.PaMod (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaMod")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaLaz (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaLaz")))))), (meta_loc _loc x0))), (meta_patt _loc x1)) | Ast.PaVrn (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaVrn")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaTyp (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaTyp")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.PaTyc (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaTyc")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_ctyp _loc x2)) | Ast.PaTup (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaTup")))))), (meta_loc _loc x0))), (meta_patt _loc x1)) | Ast.PaStr (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaStr")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaEq (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaEq")))))), (meta_loc _loc x0))), (meta_ident _loc x1))), (meta_patt _loc x2)) | Ast.PaRec (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaRec")))))), (meta_loc _loc x0))), (meta_patt _loc x1)) | Ast.PaRng (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaRng")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_patt _loc x2)) | Ast.PaOrp (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaOrp")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_patt _loc x2)) | Ast.PaOlbi (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaOlbi")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_patt _loc x2))), (meta_expr _loc x3)) | Ast.PaOlb (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaOlb")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_patt _loc x2)) | Ast.PaLab (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaLab")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_patt _loc x2)) | Ast.PaFlo (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaFlo")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaNativeInt (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaNativeInt")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaInt64 (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaInt64")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaInt32 (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaInt32")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaInt (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaInt")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaChr (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaChr")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaSem (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaSem")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_patt _loc x2)) | Ast.PaCom (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaCom")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_patt _loc x2)) | Ast.PaArr (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaArr")))))), (meta_loc _loc x0))), (meta_patt _loc x1)) | Ast.PaApp (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaApp")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_patt _loc x2)) | Ast.PaAny x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaAny")))))), (meta_loc _loc x0)) | Ast.PaAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.PaAli (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaAli")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_patt _loc x2)) | Ast.PaId (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaId")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.PaNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaNil")))))), (meta_loc _loc x0)) and meta_private_flag _loc = function | Ast.PrAnt x0 -> Ast.ExAnt (_loc, x0) | Ast.PrNil -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PrNil"))))) | Ast.PrPrivate -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PrPrivate"))))) and meta_rec_binding _loc = function | Ast.RbAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.RbEq (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "RbEq")))))), (meta_loc _loc x0))), (meta_ident _loc x1))), (meta_expr _loc x2)) | Ast.RbSem (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "RbSem")))))), (meta_loc _loc x0))), (meta_rec_binding _loc x1))), (meta_rec_binding _loc x2)) | Ast.RbNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "RbNil")))))), (meta_loc _loc x0)) and meta_rec_flag _loc = function | Ast.ReAnt x0 -> Ast.ExAnt (_loc, x0) | Ast.ReNil -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ReNil"))))) | Ast.ReRecursive -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ReRecursive"))))) and meta_row_var_flag _loc = function | Ast.RvAnt x0 -> Ast.ExAnt (_loc, x0) | Ast.RvNil -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "RvNil"))))) | Ast.RvRowVar -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "RvRowVar"))))) and meta_sig_item _loc = function | Ast.SgAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.SgVal (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgVal")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_ctyp _loc x2)) | Ast.SgTyp (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgTyp")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.SgOpn (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgOpn")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.SgMty (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgMty")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_type _loc x2)) | Ast.SgRecMod (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgRecMod")))))), (meta_loc _loc x0))), (meta_module_binding _loc x1)) | Ast.SgMod (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgMod")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_type _loc x2)) | Ast.SgInc (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgInc")))))), (meta_loc _loc x0))), (meta_module_type _loc x1)) | Ast.SgExt (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgExt")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_ctyp _loc x2))), (meta_meta_list meta_string _loc x3)) | Ast.SgExc (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgExc")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.SgDir (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgDir")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_expr _loc x2)) | Ast.SgSem (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgSem")))))), (meta_loc _loc x0))), (meta_sig_item _loc x1))), (meta_sig_item _loc x2)) | Ast.SgClt (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgClt")))))), (meta_loc _loc x0))), (meta_class_type _loc x1)) | Ast.SgCls (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgCls")))))), (meta_loc _loc x0))), (meta_class_type _loc x1)) | Ast.SgNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgNil")))))), (meta_loc _loc x0)) and meta_str_item _loc = function | Ast.StAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.StVal (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StVal")))))), (meta_loc _loc x0))), (meta_rec_flag _loc x1))), (meta_binding _loc x2)) | Ast.StTyp (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StTyp")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.StOpn (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StOpn")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.StMty (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StMty")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_type _loc x2)) | Ast.StRecMod (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StRecMod")))))), (meta_loc _loc x0))), (meta_module_binding _loc x1)) | Ast.StMod (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StMod")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_expr _loc x2)) | Ast.StInc (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StInc")))))), (meta_loc _loc x0))), (meta_module_expr _loc x1)) | Ast.StExt (x0, x1, x2, x3) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StExt")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_ctyp _loc x2))), (meta_meta_list meta_string _loc x3)) | Ast.StExp (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StExp")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.StExc (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StExc")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_meta_option meta_ident _loc x2)) | Ast.StDir (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StDir")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_expr _loc x2)) | Ast.StSem (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StSem")))))), (meta_loc _loc x0))), (meta_str_item _loc x1))), (meta_str_item _loc x2)) | Ast.StClt (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StClt")))))), (meta_loc _loc x0))), (meta_class_type _loc x1)) | Ast.StCls (x0, x1) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StCls")))))), (meta_loc _loc x0))), (meta_class_expr _loc x1)) | Ast.StNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StNil")))))), (meta_loc _loc x0)) and meta_virtual_flag _loc = function | Ast.ViAnt x0 -> Ast.ExAnt (_loc, x0) | Ast.ViNil -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ViNil"))))) | Ast.ViVirtual -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ViVirtual"))))) and meta_with_constr _loc = function | Ast.WcAnt (x0, x1) -> Ast.ExAnt (x0, x1) | Ast.WcAnd (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "WcAnd")))))), (meta_loc _loc x0))), (meta_with_constr _loc x1))), (meta_with_constr _loc x2)) | Ast.WcMoS (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "WcMoS")))))), (meta_loc _loc x0))), (meta_ident _loc x1))), (meta_ident _loc x2)) | Ast.WcTyS (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "WcTyS")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.WcMod (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "WcMod")))))), (meta_loc _loc x0))), (meta_ident _loc x1))), (meta_ident _loc x2)) | Ast.WcTyp (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "WcTyp")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.WcNil x0 -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "WcNil")))))), (meta_loc _loc x0)) end let meta_loc = meta_loc_patt module Patt = struct let meta_string _loc s = Ast.PaStr (_loc, (safe_string_escaped s)) let meta_int _loc s = Ast.PaInt (_loc, s) let meta_float _loc s = Ast.PaFlo (_loc, s) let meta_char _loc s = Ast.PaChr (_loc, (String.escaped s)) let meta_bool _loc = function | false -> Ast.PaId (_loc, (Ast.IdUid (_loc, "False"))) | true -> Ast.PaId (_loc, (Ast.IdUid (_loc, "True"))) let rec meta_list mf_a _loc = function | [] -> Ast.PaId (_loc, (Ast.IdUid (_loc, "[]"))) | x :: xs -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, "::")))), (mf_a _loc x))), (meta_list mf_a _loc xs)) let rec meta_binding _loc = function | Ast.BiAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.BiEq (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "BiEq")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_expr _loc x2)) | Ast.BiAnd (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "BiAnd")))))), (meta_loc _loc x0))), (meta_binding _loc x1))), (meta_binding _loc x2)) | Ast.BiNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "BiNil")))))), (meta_loc _loc x0)) and meta_class_expr _loc = function | Ast.CeAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.CeEq (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeEq")))))), (meta_loc _loc x0))), (meta_class_expr _loc x1))), (meta_class_expr _loc x2)) | Ast.CeAnd (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeAnd")))))), (meta_loc _loc x0))), (meta_class_expr _loc x1))), (meta_class_expr _loc x2)) | Ast.CeTyc (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeTyc")))))), (meta_loc _loc x0))), (meta_class_expr _loc x1))), (meta_class_type _loc x2)) | Ast.CeStr (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeStr")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_class_str_item _loc x2)) | Ast.CeLet (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeLet")))))), (meta_loc _loc x0))), (meta_rec_flag _loc x1))), (meta_binding _loc x2))), (meta_class_expr _loc x3)) | Ast.CeFun (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeFun")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_class_expr _loc x2)) | Ast.CeCon (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeCon")))))), (meta_loc _loc x0))), (meta_virtual_flag _loc x1))), (meta_ident _loc x2))), (meta_ctyp _loc x3)) | Ast.CeApp (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeApp")))))), (meta_loc _loc x0))), (meta_class_expr _loc x1))), (meta_expr _loc x2)) | Ast.CeNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeNil")))))), (meta_loc _loc x0)) and meta_class_sig_item _loc = function | Ast.CgAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.CgVir (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgVir")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_private_flag _loc x2))), (meta_ctyp _loc x3)) | Ast.CgVal (x0, x1, x2, x3, x4) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgVal")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_mutable_flag _loc x2))), (meta_virtual_flag _loc x3))), (meta_ctyp _loc x4)) | Ast.CgMth (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgMth")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_private_flag _loc x2))), (meta_ctyp _loc x3)) | Ast.CgInh (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgInh")))))), (meta_loc _loc x0))), (meta_class_type _loc x1)) | Ast.CgSem (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgSem")))))), (meta_loc _loc x0))), (meta_class_sig_item _loc x1))), (meta_class_sig_item _loc x2)) | Ast.CgCtr (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgCtr")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.CgNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgNil")))))), (meta_loc _loc x0)) and meta_class_str_item _loc = function | Ast.CrAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.CrVvr (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrVvr")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_mutable_flag _loc x2))), (meta_ctyp _loc x3)) | Ast.CrVir (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrVir")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_private_flag _loc x2))), (meta_ctyp _loc x3)) | Ast.CrVal (x0, x1, x2, x3, x4) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrVal")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_override_flag _loc x2))), (meta_mutable_flag _loc x3))), (meta_expr _loc x4)) | Ast.CrMth (x0, x1, x2, x3, x4, x5) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrMth")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_override_flag _loc x2))), (meta_private_flag _loc x3))), (meta_expr _loc x4))), (meta_ctyp _loc x5)) | Ast.CrIni (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrIni")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.CrInh (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrInh")))))), (meta_loc _loc x0))), (meta_override_flag _loc x1))), (meta_class_expr _loc x2))), (meta_string _loc x3)) | Ast.CrCtr (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrCtr")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.CrSem (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrSem")))))), (meta_loc _loc x0))), (meta_class_str_item _loc x1))), (meta_class_str_item _loc x2)) | Ast.CrNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrNil")))))), (meta_loc _loc x0)) and meta_class_type _loc = function | Ast.CtAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.CtEq (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtEq")))))), (meta_loc _loc x0))), (meta_class_type _loc x1))), (meta_class_type _loc x2)) | Ast.CtCol (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtCol")))))), (meta_loc _loc x0))), (meta_class_type _loc x1))), (meta_class_type _loc x2)) | Ast.CtAnd (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtAnd")))))), (meta_loc _loc x0))), (meta_class_type _loc x1))), (meta_class_type _loc x2)) | Ast.CtSig (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtSig")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_class_sig_item _loc x2)) | Ast.CtFun (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtFun")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_class_type _loc x2)) | Ast.CtCon (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtCon")))))), (meta_loc _loc x0))), (meta_virtual_flag _loc x1))), (meta_ident _loc x2))), (meta_ctyp _loc x3)) | Ast.CtNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtNil")))))), (meta_loc _loc x0)) and meta_ctyp _loc = function | Ast.TyAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.TyPkg (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyPkg")))))), (meta_loc _loc x0))), (meta_module_type _loc x1)) | Ast.TyOfAmp (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyOfAmp")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyAmp (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyAmp")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyVrnInfSup (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyVrnInfSup")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyVrnInf (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyVrnInf")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TyVrnSup (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyVrnSup")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TyVrnEq (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyVrnEq")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TySta (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TySta")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyTup (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyTup")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TyMut (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyMut")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TyPrv (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyPrv")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TyOr (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyOr")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyAnd (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyAnd")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyOf (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyOf")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TySum (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TySum")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TyCom (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyCom")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TySem (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TySem")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyCol (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyCol")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyRec (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyRec")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.TyVrn (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyVrn")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.TyAnM x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyAnM")))))), (meta_loc _loc x0)) | Ast.TyAnP x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyAnP")))))), (meta_loc _loc x0)) | Ast.TyQuM (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyQuM")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.TyQuP (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyQuP")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.TyQuo (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyQuo")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.TyTypePol (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyTypePol")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyPol (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyPol")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyOlb (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyOlb")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_ctyp _loc x2)) | Ast.TyObj (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyObj")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_row_var_flag _loc x2)) | Ast.TyDcl (x0, x1, x2, x3, x4) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyDcl")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_list meta_ctyp _loc x2))), (meta_ctyp _loc x3))), (meta_list (fun _loc (x1, x2) -> Ast.PaTup (_loc, (Ast.PaCom (_loc, (meta_ctyp _loc x1), (meta_ctyp _loc x2))))) _loc x4)) | Ast.TyMan (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyMan")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyId (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyId")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.TyLab (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyLab")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_ctyp _loc x2)) | Ast.TyCls (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyCls")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.TyArr (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyArr")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyApp (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyApp")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyAny x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyAny")))))), (meta_loc _loc x0)) | Ast.TyAli (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyAli")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.TyNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyNil")))))), (meta_loc _loc x0)) and meta_direction_flag _loc = function | Ast.DiAnt x0 -> Ast.PaAnt (_loc, x0) | Ast.DiDownto -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "DiDownto"))))) | Ast.DiTo -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "DiTo"))))) and meta_expr _loc = function | Ast.ExPkg (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExPkg")))))), (meta_loc _loc x0))), (meta_module_expr _loc x1)) | Ast.ExFUN (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExFUN")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_expr _loc x2)) | Ast.ExOpI (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExOpI")))))), (meta_loc _loc x0))), (meta_ident _loc x1))), (meta_expr _loc x2)) | Ast.ExWhi (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExWhi")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExVrn (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExVrn")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExTyc (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExTyc")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_ctyp _loc x2)) | Ast.ExCom (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExCom")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExTup (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExTup")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.ExTry (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExTry")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_match_case _loc x2)) | Ast.ExStr (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExStr")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExSte (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExSte")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExSnd (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExSnd")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_string _loc x2)) | Ast.ExSeq (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExSeq")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.ExRec (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExRec")))))), (meta_loc _loc x0))), (meta_rec_binding _loc x1))), (meta_expr _loc x2)) | Ast.ExOvr (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExOvr")))))), (meta_loc _loc x0))), (meta_rec_binding _loc x1)) | Ast.ExOlb (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExOlb")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_expr _loc x2)) | Ast.ExObj (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExObj")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_class_str_item _loc x2)) | Ast.ExNew (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExNew")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.ExMat (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExMat")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_match_case _loc x2)) | Ast.ExLmd (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExLmd")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_expr _loc x2))), (meta_expr _loc x3)) | Ast.ExLet (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExLet")))))), (meta_loc _loc x0))), (meta_rec_flag _loc x1))), (meta_binding _loc x2))), (meta_expr _loc x3)) | Ast.ExLaz (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExLaz")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.ExLab (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExLab")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_expr _loc x2)) | Ast.ExNativeInt (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExNativeInt")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExInt64 (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExInt64")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExInt32 (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExInt32")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExInt (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExInt")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExIfe (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExIfe")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2))), (meta_expr _loc x3)) | Ast.ExFun (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExFun")))))), (meta_loc _loc x0))), (meta_match_case _loc x1)) | Ast.ExFor (x0, x1, x2, x3, x4, x5) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExFor")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_expr _loc x2))), (meta_expr _loc x3))), (meta_direction_flag _loc x4))), (meta_expr _loc x5)) | Ast.ExFlo (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExFlo")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExCoe (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExCoe")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_ctyp _loc x2))), (meta_ctyp _loc x3)) | Ast.ExChr (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExChr")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.ExAss (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExAss")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExAsr (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExAsr")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.ExAsf x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExAsf")))))), (meta_loc _loc x0)) | Ast.ExSem (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExSem")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExArr (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExArr")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.ExAre (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExAre")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExApp (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExApp")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.ExAcc (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExAcc")))))), (meta_loc _loc x0))), (meta_expr _loc x1))), (meta_expr _loc x2)) | Ast.ExId (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExId")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.ExNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExNil")))))), (meta_loc _loc x0)) and meta_ident _loc = function | Ast.IdAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.IdUid (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "IdUid")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.IdLid (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "IdLid")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.IdApp (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "IdApp")))))), (meta_loc _loc x0))), (meta_ident _loc x1))), (meta_ident _loc x2)) | Ast.IdAcc (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "IdAcc")))))), (meta_loc _loc x0))), (meta_ident _loc x1))), (meta_ident _loc x2)) and meta_match_case _loc = function | Ast.McAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.McArr (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "McArr")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_expr _loc x2))), (meta_expr _loc x3)) | Ast.McOr (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "McOr")))))), (meta_loc _loc x0))), (meta_match_case _loc x1))), (meta_match_case _loc x2)) | Ast.McNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "McNil")))))), (meta_loc _loc x0)) and meta_meta_bool _loc = function | Ast.BAnt x0 -> Ast.PaAnt (_loc, x0) | Ast.BFalse -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "BFalse"))))) | Ast.BTrue -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "BTrue"))))) and meta_meta_list mf_a _loc = function | Ast.LAnt x0 -> Ast.PaAnt (_loc, x0) | Ast.LCons (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "LCons")))))), (mf_a _loc x0))), (meta_meta_list mf_a _loc x1)) | Ast.LNil -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "LNil"))))) and meta_meta_option mf_a _loc = function | Ast.OAnt x0 -> Ast.PaAnt (_loc, x0) | Ast.OSome x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "OSome")))))), (mf_a _loc x0)) | Ast.ONone -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ONone"))))) and meta_module_binding _loc = function | Ast.MbAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.MbCol (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MbCol")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_type _loc x2)) | Ast.MbColEq (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MbColEq")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_type _loc x2))), (meta_module_expr _loc x3)) | Ast.MbAnd (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MbAnd")))))), (meta_loc _loc x0))), (meta_module_binding _loc x1))), (meta_module_binding _loc x2)) | Ast.MbNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MbNil")))))), (meta_loc _loc x0)) and meta_module_expr _loc = function | Ast.MeAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.MePkg (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MePkg")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.MeTyc (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MeTyc")))))), (meta_loc _loc x0))), (meta_module_expr _loc x1))), (meta_module_type _loc x2)) | Ast.MeStr (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MeStr")))))), (meta_loc _loc x0))), (meta_str_item _loc x1)) | Ast.MeFun (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MeFun")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_type _loc x2))), (meta_module_expr _loc x3)) | Ast.MeApp (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MeApp")))))), (meta_loc _loc x0))), (meta_module_expr _loc x1))), (meta_module_expr _loc x2)) | Ast.MeId (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MeId")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.MeNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MeNil")))))), (meta_loc _loc x0)) and meta_module_type _loc = function | Ast.MtAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.MtOf (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtOf")))))), (meta_loc _loc x0))), (meta_module_expr _loc x1)) | Ast.MtWit (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtWit")))))), (meta_loc _loc x0))), (meta_module_type _loc x1))), (meta_with_constr _loc x2)) | Ast.MtSig (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtSig")))))), (meta_loc _loc x0))), (meta_sig_item _loc x1)) | Ast.MtQuo (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtQuo")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.MtFun (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtFun")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_type _loc x2))), (meta_module_type _loc x3)) | Ast.MtId (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtId")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.MtNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtNil")))))), (meta_loc _loc x0)) and meta_mutable_flag _loc = function | Ast.MuAnt x0 -> Ast.PaAnt (_loc, x0) | Ast.MuNil -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MuNil"))))) | Ast.MuMutable -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MuMutable"))))) and meta_override_flag _loc = function | Ast.OvAnt x0 -> Ast.PaAnt (_loc, x0) | Ast.OvNil -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "OvNil"))))) | Ast.OvOverride -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "OvOverride"))))) and meta_patt _loc = function | Ast.PaMod (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaMod")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaLaz (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaLaz")))))), (meta_loc _loc x0))), (meta_patt _loc x1)) | Ast.PaVrn (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaVrn")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaTyp (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaTyp")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.PaTyc (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaTyc")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_ctyp _loc x2)) | Ast.PaTup (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaTup")))))), (meta_loc _loc x0))), (meta_patt _loc x1)) | Ast.PaStr (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaStr")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaEq (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaEq")))))), (meta_loc _loc x0))), (meta_ident _loc x1))), (meta_patt _loc x2)) | Ast.PaRec (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaRec")))))), (meta_loc _loc x0))), (meta_patt _loc x1)) | Ast.PaRng (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaRng")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_patt _loc x2)) | Ast.PaOrp (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaOrp")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_patt _loc x2)) | Ast.PaOlbi (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaOlbi")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_patt _loc x2))), (meta_expr _loc x3)) | Ast.PaOlb (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaOlb")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_patt _loc x2)) | Ast.PaLab (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaLab")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_patt _loc x2)) | Ast.PaFlo (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaFlo")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaNativeInt (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaNativeInt")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaInt64 (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaInt64")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaInt32 (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaInt32")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaInt (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaInt")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaChr (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaChr")))))), (meta_loc _loc x0))), (meta_string _loc x1)) | Ast.PaSem (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaSem")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_patt _loc x2)) | Ast.PaCom (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaCom")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_patt _loc x2)) | Ast.PaArr (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaArr")))))), (meta_loc _loc x0))), (meta_patt _loc x1)) | Ast.PaApp (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaApp")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_patt _loc x2)) | Ast.PaAny x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaAny")))))), (meta_loc _loc x0)) | Ast.PaAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.PaAli (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaAli")))))), (meta_loc _loc x0))), (meta_patt _loc x1))), (meta_patt _loc x2)) | Ast.PaId (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaId")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.PaNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaNil")))))), (meta_loc _loc x0)) and meta_private_flag _loc = function | Ast.PrAnt x0 -> Ast.PaAnt (_loc, x0) | Ast.PrNil -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PrNil"))))) | Ast.PrPrivate -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PrPrivate"))))) and meta_rec_binding _loc = function | Ast.RbAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.RbEq (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "RbEq")))))), (meta_loc _loc x0))), (meta_ident _loc x1))), (meta_expr _loc x2)) | Ast.RbSem (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "RbSem")))))), (meta_loc _loc x0))), (meta_rec_binding _loc x1))), (meta_rec_binding _loc x2)) | Ast.RbNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "RbNil")))))), (meta_loc _loc x0)) and meta_rec_flag _loc = function | Ast.ReAnt x0 -> Ast.PaAnt (_loc, x0) | Ast.ReNil -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ReNil"))))) | Ast.ReRecursive -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ReRecursive"))))) and meta_row_var_flag _loc = function | Ast.RvAnt x0 -> Ast.PaAnt (_loc, x0) | Ast.RvNil -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "RvNil"))))) | Ast.RvRowVar -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "RvRowVar"))))) and meta_sig_item _loc = function | Ast.SgAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.SgVal (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgVal")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_ctyp _loc x2)) | Ast.SgTyp (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgTyp")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.SgOpn (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgOpn")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.SgMty (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgMty")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_type _loc x2)) | Ast.SgRecMod (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgRecMod")))))), (meta_loc _loc x0))), (meta_module_binding _loc x1)) | Ast.SgMod (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgMod")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_type _loc x2)) | Ast.SgInc (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgInc")))))), (meta_loc _loc x0))), (meta_module_type _loc x1)) | Ast.SgExt (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgExt")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_ctyp _loc x2))), (meta_meta_list meta_string _loc x3)) | Ast.SgExc (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgExc")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.SgDir (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgDir")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_expr _loc x2)) | Ast.SgSem (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgSem")))))), (meta_loc _loc x0))), (meta_sig_item _loc x1))), (meta_sig_item _loc x2)) | Ast.SgClt (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgClt")))))), (meta_loc _loc x0))), (meta_class_type _loc x1)) | Ast.SgCls (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgCls")))))), (meta_loc _loc x0))), (meta_class_type _loc x1)) | Ast.SgNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgNil")))))), (meta_loc _loc x0)) and meta_str_item _loc = function | Ast.StAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.StVal (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StVal")))))), (meta_loc _loc x0))), (meta_rec_flag _loc x1))), (meta_binding _loc x2)) | Ast.StTyp (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StTyp")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1)) | Ast.StOpn (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StOpn")))))), (meta_loc _loc x0))), (meta_ident _loc x1)) | Ast.StMty (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StMty")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_type _loc x2)) | Ast.StRecMod (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StRecMod")))))), (meta_loc _loc x0))), (meta_module_binding _loc x1)) | Ast.StMod (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StMod")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_module_expr _loc x2)) | Ast.StInc (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StInc")))))), (meta_loc _loc x0))), (meta_module_expr _loc x1)) | Ast.StExt (x0, x1, x2, x3) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StExt")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_ctyp _loc x2))), (meta_meta_list meta_string _loc x3)) | Ast.StExp (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StExp")))))), (meta_loc _loc x0))), (meta_expr _loc x1)) | Ast.StExc (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StExc")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_meta_option meta_ident _loc x2)) | Ast.StDir (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StDir")))))), (meta_loc _loc x0))), (meta_string _loc x1))), (meta_expr _loc x2)) | Ast.StSem (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StSem")))))), (meta_loc _loc x0))), (meta_str_item _loc x1))), (meta_str_item _loc x2)) | Ast.StClt (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StClt")))))), (meta_loc _loc x0))), (meta_class_type _loc x1)) | Ast.StCls (x0, x1) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StCls")))))), (meta_loc _loc x0))), (meta_class_expr _loc x1)) | Ast.StNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StNil")))))), (meta_loc _loc x0)) and meta_virtual_flag _loc = function | Ast.ViAnt x0 -> Ast.PaAnt (_loc, x0) | Ast.ViNil -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ViNil"))))) | Ast.ViVirtual -> Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ViVirtual"))))) and meta_with_constr _loc = function | Ast.WcAnt (x0, x1) -> Ast.PaAnt (x0, x1) | Ast.WcAnd (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "WcAnd")))))), (meta_loc _loc x0))), (meta_with_constr _loc x1))), (meta_with_constr _loc x2)) | Ast.WcMoS (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "WcMoS")))))), (meta_loc _loc x0))), (meta_ident _loc x1))), (meta_ident _loc x2)) | Ast.WcTyS (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "WcTyS")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.WcMod (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "WcMod")))))), (meta_loc _loc x0))), (meta_ident _loc x1))), (meta_ident _loc x2)) | Ast.WcTyp (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "WcTyp")))))), (meta_loc _loc x0))), (meta_ctyp _loc x1))), (meta_ctyp _loc x2)) | Ast.WcNil x0 -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "WcNil")))))), (meta_loc _loc x0)) end end end class map = object ((o : 'self_type)) method string : string -> string = o#unknown method list : 'a 'a_out. ('self_type -> 'a -> 'a_out) -> 'a list -> 'a_out list = fun _f_a -> function | [] -> [] | _x :: _x_i1 -> let _x = _f_a o _x in let _x_i1 = o#list _f_a _x_i1 in _x :: _x_i1 method with_constr : with_constr -> with_constr = function | WcNil _x -> let _x = o#loc _x in WcNil _x | WcTyp (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in WcTyp (_x, _x_i1, _x_i2) | WcMod (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in let _x_i2 = o#ident _x_i2 in WcMod (_x, _x_i1, _x_i2) | WcTyS (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in WcTyS (_x, _x_i1, _x_i2) | WcMoS (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in let _x_i2 = o#ident _x_i2 in WcMoS (_x, _x_i1, _x_i2) | WcAnd (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#with_constr _x_i1 in let _x_i2 = o#with_constr _x_i2 in WcAnd (_x, _x_i1, _x_i2) | WcAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in WcAnt (_x, _x_i1) method virtual_flag : virtual_flag -> virtual_flag = function | ViVirtual -> ViVirtual | ViNil -> ViNil | ViAnt _x -> let _x = o#string _x in ViAnt _x method str_item : str_item -> str_item = function | StNil _x -> let _x = o#loc _x in StNil _x | StCls (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#class_expr _x_i1 in StCls (_x, _x_i1) | StClt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#class_type _x_i1 in StClt (_x, _x_i1) | StSem (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#str_item _x_i1 in let _x_i2 = o#str_item _x_i2 in StSem (_x, _x_i1, _x_i2) | StDir (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#expr _x_i2 in StDir (_x, _x_i1, _x_i2) | StExc (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#meta_option (fun o -> o#ident) _x_i2 in StExc (_x, _x_i1, _x_i2) | StExp (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in StExp (_x, _x_i1) | StExt (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#ctyp _x_i2 in let _x_i3 = o#meta_list (fun o -> o#string) _x_i3 in StExt (_x, _x_i1, _x_i2, _x_i3) | StInc (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#module_expr _x_i1 in StInc (_x, _x_i1) | StMod (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_expr _x_i2 in StMod (_x, _x_i1, _x_i2) | StRecMod (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#module_binding _x_i1 in StRecMod (_x, _x_i1) | StMty (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_type _x_i2 in StMty (_x, _x_i1, _x_i2) | StOpn (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in StOpn (_x, _x_i1) | StTyp (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in StTyp (_x, _x_i1) | StVal (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#rec_flag _x_i1 in let _x_i2 = o#binding _x_i2 in StVal (_x, _x_i1, _x_i2) | StAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in StAnt (_x, _x_i1) method sig_item : sig_item -> sig_item = function | SgNil _x -> let _x = o#loc _x in SgNil _x | SgCls (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#class_type _x_i1 in SgCls (_x, _x_i1) | SgClt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#class_type _x_i1 in SgClt (_x, _x_i1) | SgSem (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#sig_item _x_i1 in let _x_i2 = o#sig_item _x_i2 in SgSem (_x, _x_i1, _x_i2) | SgDir (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#expr _x_i2 in SgDir (_x, _x_i1, _x_i2) | SgExc (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in SgExc (_x, _x_i1) | SgExt (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#ctyp _x_i2 in let _x_i3 = o#meta_list (fun o -> o#string) _x_i3 in SgExt (_x, _x_i1, _x_i2, _x_i3) | SgInc (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#module_type _x_i1 in SgInc (_x, _x_i1) | SgMod (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_type _x_i2 in SgMod (_x, _x_i1, _x_i2) | SgRecMod (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#module_binding _x_i1 in SgRecMod (_x, _x_i1) | SgMty (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_type _x_i2 in SgMty (_x, _x_i1, _x_i2) | SgOpn (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in SgOpn (_x, _x_i1) | SgTyp (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in SgTyp (_x, _x_i1) | SgVal (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#ctyp _x_i2 in SgVal (_x, _x_i1, _x_i2) | SgAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in SgAnt (_x, _x_i1) method row_var_flag : row_var_flag -> row_var_flag = function | RvRowVar -> RvRowVar | RvNil -> RvNil | RvAnt _x -> let _x = o#string _x in RvAnt _x method rec_flag : rec_flag -> rec_flag = function | ReRecursive -> ReRecursive | ReNil -> ReNil | ReAnt _x -> let _x = o#string _x in ReAnt _x method rec_binding : rec_binding -> rec_binding = function | RbNil _x -> let _x = o#loc _x in RbNil _x | RbSem (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#rec_binding _x_i1 in let _x_i2 = o#rec_binding _x_i2 in RbSem (_x, _x_i1, _x_i2) | RbEq (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in let _x_i2 = o#expr _x_i2 in RbEq (_x, _x_i1, _x_i2) | RbAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in RbAnt (_x, _x_i1) method private_flag : private_flag -> private_flag = function | PrPrivate -> PrPrivate | PrNil -> PrNil | PrAnt _x -> let _x = o#string _x in PrAnt _x method patt : patt -> patt = function | PaNil _x -> let _x = o#loc _x in PaNil _x | PaId (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in PaId (_x, _x_i1) | PaAli (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#patt _x_i2 in PaAli (_x, _x_i1, _x_i2) | PaAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaAnt (_x, _x_i1) | PaAny _x -> let _x = o#loc _x in PaAny _x | PaApp (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#patt _x_i2 in PaApp (_x, _x_i1, _x_i2) | PaArr (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaArr (_x, _x_i1) | PaCom (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#patt _x_i2 in PaCom (_x, _x_i1, _x_i2) | PaSem (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#patt _x_i2 in PaSem (_x, _x_i1, _x_i2) | PaChr (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaChr (_x, _x_i1) | PaInt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaInt (_x, _x_i1) | PaInt32 (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaInt32 (_x, _x_i1) | PaInt64 (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaInt64 (_x, _x_i1) | PaNativeInt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaNativeInt (_x, _x_i1) | PaFlo (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaFlo (_x, _x_i1) | PaLab (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#patt _x_i2 in PaLab (_x, _x_i1, _x_i2) | PaOlb (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#patt _x_i2 in PaOlb (_x, _x_i1, _x_i2) | PaOlbi (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#patt _x_i2 in let _x_i3 = o#expr _x_i3 in PaOlbi (_x, _x_i1, _x_i2, _x_i3) | PaOrp (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#patt _x_i2 in PaOrp (_x, _x_i1, _x_i2) | PaRng (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#patt _x_i2 in PaRng (_x, _x_i1, _x_i2) | PaRec (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaRec (_x, _x_i1) | PaEq (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in let _x_i2 = o#patt _x_i2 in PaEq (_x, _x_i1, _x_i2) | PaStr (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaStr (_x, _x_i1) | PaTup (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaTup (_x, _x_i1) | PaTyc (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#ctyp _x_i2 in PaTyc (_x, _x_i1, _x_i2) | PaTyp (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in PaTyp (_x, _x_i1) | PaVrn (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaVrn (_x, _x_i1) | PaLaz (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz (_x, _x_i1) | PaMod (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaMod (_x, _x_i1) method override_flag : override_flag -> override_flag = function | OvOverride -> OvOverride | OvNil -> OvNil | OvAnt _x -> let _x = o#string _x in OvAnt _x method mutable_flag : mutable_flag -> mutable_flag = function | MuMutable -> MuMutable | MuNil -> MuNil | MuAnt _x -> let _x = o#string _x in MuAnt _x method module_type : module_type -> module_type = function | MtNil _x -> let _x = o#loc _x in MtNil _x | MtId (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in MtId (_x, _x_i1) | MtFun (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_type _x_i2 in let _x_i3 = o#module_type _x_i3 in MtFun (_x, _x_i1, _x_i2, _x_i3) | MtQuo (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MtQuo (_x, _x_i1) | MtSig (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#sig_item _x_i1 in MtSig (_x, _x_i1) | MtWit (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#module_type _x_i1 in let _x_i2 = o#with_constr _x_i2 in MtWit (_x, _x_i1, _x_i2) | MtOf (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#module_expr _x_i1 in MtOf (_x, _x_i1) | MtAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MtAnt (_x, _x_i1) method module_expr : module_expr -> module_expr = function | MeNil _x -> let _x = o#loc _x in MeNil _x | MeId (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in MeId (_x, _x_i1) | MeApp (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#module_expr _x_i1 in let _x_i2 = o#module_expr _x_i2 in MeApp (_x, _x_i1, _x_i2) | MeFun (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_type _x_i2 in let _x_i3 = o#module_expr _x_i3 in MeFun (_x, _x_i1, _x_i2, _x_i3) | MeStr (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#str_item _x_i1 in MeStr (_x, _x_i1) | MeTyc (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#module_expr _x_i1 in let _x_i2 = o#module_type _x_i2 in MeTyc (_x, _x_i1, _x_i2) | MePkg (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in MePkg (_x, _x_i1) | MeAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MeAnt (_x, _x_i1) method module_binding : module_binding -> module_binding = function | MbNil _x -> let _x = o#loc _x in MbNil _x | MbAnd (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#module_binding _x_i1 in let _x_i2 = o#module_binding _x_i2 in MbAnd (_x, _x_i1, _x_i2) | MbColEq (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_type _x_i2 in let _x_i3 = o#module_expr _x_i3 in MbColEq (_x, _x_i1, _x_i2, _x_i3) | MbCol (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_type _x_i2 in MbCol (_x, _x_i1, _x_i2) | MbAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MbAnt (_x, _x_i1) method meta_option : 'a 'a_out. ('self_type -> 'a -> 'a_out) -> 'a meta_option -> 'a_out meta_option = fun _f_a -> function | ONone -> ONone | OSome _x -> let _x = _f_a o _x in OSome _x | OAnt _x -> let _x = o#string _x in OAnt _x method meta_list : 'a 'a_out. ('self_type -> 'a -> 'a_out) -> 'a meta_list -> 'a_out meta_list = fun _f_a -> function | LNil -> LNil | LCons (_x, _x_i1) -> let _x = _f_a o _x in let _x_i1 = o#meta_list _f_a _x_i1 in LCons (_x, _x_i1) | LAnt _x -> let _x = o#string _x in LAnt _x method meta_bool : meta_bool -> meta_bool = function | BTrue -> BTrue | BFalse -> BFalse | BAnt _x -> let _x = o#string _x in BAnt _x method match_case : match_case -> match_case = function | McNil _x -> let _x = o#loc _x in McNil _x | McOr (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#match_case _x_i1 in let _x_i2 = o#match_case _x_i2 in McOr (_x, _x_i1, _x_i2) | McArr (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#expr _x_i2 in let _x_i3 = o#expr _x_i3 in McArr (_x, _x_i1, _x_i2, _x_i3) | McAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in McAnt (_x, _x_i1) method loc : loc -> loc = o#unknown method ident : ident -> ident = function | IdAcc (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in let _x_i2 = o#ident _x_i2 in IdAcc (_x, _x_i1, _x_i2) | IdApp (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in let _x_i2 = o#ident _x_i2 in IdApp (_x, _x_i1, _x_i2) | IdLid (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in IdLid (_x, _x_i1) | IdUid (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in IdUid (_x, _x_i1) | IdAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in IdAnt (_x, _x_i1) method expr : expr -> expr = function | ExNil _x -> let _x = o#loc _x in ExNil _x | ExId (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in ExId (_x, _x_i1) | ExAcc (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExAcc (_x, _x_i1, _x_i2) | ExAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExAnt (_x, _x_i1) | ExApp (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExApp (_x, _x_i1, _x_i2) | ExAre (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExAre (_x, _x_i1, _x_i2) | ExArr (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExArr (_x, _x_i1) | ExSem (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExSem (_x, _x_i1, _x_i2) | ExAsf _x -> let _x = o#loc _x in ExAsf _x | ExAsr (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExAsr (_x, _x_i1) | ExAss (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExAss (_x, _x_i1, _x_i2) | ExChr (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExChr (_x, _x_i1) | ExCoe (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#ctyp _x_i2 in let _x_i3 = o#ctyp _x_i3 in ExCoe (_x, _x_i1, _x_i2, _x_i3) | ExFlo (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExFlo (_x, _x_i1) | ExFor (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#expr _x_i2 in let _x_i3 = o#expr _x_i3 in let _x_i4 = o#direction_flag _x_i4 in let _x_i5 = o#expr _x_i5 in ExFor (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) | ExFun (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#match_case _x_i1 in ExFun (_x, _x_i1) | ExIfe (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in let _x_i3 = o#expr _x_i3 in ExIfe (_x, _x_i1, _x_i2, _x_i3) | ExInt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExInt (_x, _x_i1) | ExInt32 (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExInt32 (_x, _x_i1) | ExInt64 (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExInt64 (_x, _x_i1) | ExNativeInt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExNativeInt (_x, _x_i1) | ExLab (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#expr _x_i2 in ExLab (_x, _x_i1, _x_i2) | ExLaz (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExLaz (_x, _x_i1) | ExLet (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#rec_flag _x_i1 in let _x_i2 = o#binding _x_i2 in let _x_i3 = o#expr _x_i3 in ExLet (_x, _x_i1, _x_i2, _x_i3) | ExLmd (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_expr _x_i2 in let _x_i3 = o#expr _x_i3 in ExLmd (_x, _x_i1, _x_i2, _x_i3) | ExMat (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#match_case _x_i2 in ExMat (_x, _x_i1, _x_i2) | ExNew (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in ExNew (_x, _x_i1) | ExObj (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#class_str_item _x_i2 in ExObj (_x, _x_i1, _x_i2) | ExOlb (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#expr _x_i2 in ExOlb (_x, _x_i1, _x_i2) | ExOvr (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#rec_binding _x_i1 in ExOvr (_x, _x_i1) | ExRec (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#rec_binding _x_i1 in let _x_i2 = o#expr _x_i2 in ExRec (_x, _x_i1, _x_i2) | ExSeq (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExSeq (_x, _x_i1) | ExSnd (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#string _x_i2 in ExSnd (_x, _x_i1, _x_i2) | ExSte (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExSte (_x, _x_i1, _x_i2) | ExStr (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExStr (_x, _x_i1) | ExTry (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#match_case _x_i2 in ExTry (_x, _x_i1, _x_i2) | ExTup (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExTup (_x, _x_i1) | ExCom (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExCom (_x, _x_i1, _x_i2) | ExTyc (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#ctyp _x_i2 in ExTyc (_x, _x_i1, _x_i2) | ExVrn (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExVrn (_x, _x_i1) | ExWhi (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExWhi (_x, _x_i1, _x_i2) | ExOpI (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in let _x_i2 = o#expr _x_i2 in ExOpI (_x, _x_i1, _x_i2) | ExFUN (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#expr _x_i2 in ExFUN (_x, _x_i1, _x_i2) | ExPkg (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#module_expr _x_i1 in ExPkg (_x, _x_i1) method direction_flag : direction_flag -> direction_flag = function | DiTo -> DiTo | DiDownto -> DiDownto | DiAnt _x -> let _x = o#string _x in DiAnt _x method ctyp : ctyp -> ctyp = function | TyNil _x -> let _x = o#loc _x in TyNil _x | TyAli (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyAli (_x, _x_i1, _x_i2) | TyAny _x -> let _x = o#loc _x in TyAny _x | TyApp (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyApp (_x, _x_i1, _x_i2) | TyArr (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyArr (_x, _x_i1, _x_i2) | TyCls (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in TyCls (_x, _x_i1) | TyLab (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyLab (_x, _x_i1, _x_i2) | TyId (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in TyId (_x, _x_i1) | TyMan (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyMan (_x, _x_i1, _x_i2) | TyDcl (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#list (fun o -> o#ctyp) _x_i2 in let _x_i3 = o#ctyp _x_i3 in let _x_i4 = o#list (fun o (_x, _x_i1) -> let _x = o#ctyp _x in let _x_i1 = o#ctyp _x_i1 in (_x, _x_i1)) _x_i4 in TyDcl (_x, _x_i1, _x_i2, _x_i3, _x_i4) | TyObj (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#row_var_flag _x_i2 in TyObj (_x, _x_i1, _x_i2) | TyOlb (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyOlb (_x, _x_i1, _x_i2) | TyPol (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyPol (_x, _x_i1, _x_i2) | TyTypePol (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyTypePol (_x, _x_i1, _x_i2) | TyQuo (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyQuo (_x, _x_i1) | TyQuP (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyQuP (_x, _x_i1) | TyQuM (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyQuM (_x, _x_i1) | TyAnP _x -> let _x = o#loc _x in TyAnP _x | TyAnM _x -> let _x = o#loc _x in TyAnM _x | TyVrn (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyVrn (_x, _x_i1) | TyRec (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyRec (_x, _x_i1) | TyCol (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyCol (_x, _x_i1, _x_i2) | TySem (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TySem (_x, _x_i1, _x_i2) | TyCom (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyCom (_x, _x_i1, _x_i2) | TySum (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TySum (_x, _x_i1) | TyOf (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyOf (_x, _x_i1, _x_i2) | TyAnd (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyAnd (_x, _x_i1, _x_i2) | TyOr (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyOr (_x, _x_i1, _x_i2) | TyPrv (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyPrv (_x, _x_i1) | TyMut (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyMut (_x, _x_i1) | TyTup (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyTup (_x, _x_i1) | TySta (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TySta (_x, _x_i1, _x_i2) | TyVrnEq (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyVrnEq (_x, _x_i1) | TyVrnSup (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyVrnSup (_x, _x_i1) | TyVrnInf (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyVrnInf (_x, _x_i1) | TyVrnInfSup (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyVrnInfSup (_x, _x_i1, _x_i2) | TyAmp (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyAmp (_x, _x_i1, _x_i2) | TyOfAmp (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyOfAmp (_x, _x_i1, _x_i2) | TyPkg (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#module_type _x_i1 in TyPkg (_x, _x_i1) | TyAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyAnt (_x, _x_i1) method class_type : class_type -> class_type = function | CtNil _x -> let _x = o#loc _x in CtNil _x | CtCon (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#virtual_flag _x_i1 in let _x_i2 = o#ident _x_i2 in let _x_i3 = o#ctyp _x_i3 in CtCon (_x, _x_i1, _x_i2, _x_i3) | CtFun (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#class_type _x_i2 in CtFun (_x, _x_i1, _x_i2) | CtSig (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#class_sig_item _x_i2 in CtSig (_x, _x_i1, _x_i2) | CtAnd (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#class_type _x_i1 in let _x_i2 = o#class_type _x_i2 in CtAnd (_x, _x_i1, _x_i2) | CtCol (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#class_type _x_i1 in let _x_i2 = o#class_type _x_i2 in CtCol (_x, _x_i1, _x_i2) | CtEq (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#class_type _x_i1 in let _x_i2 = o#class_type _x_i2 in CtEq (_x, _x_i1, _x_i2) | CtAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CtAnt (_x, _x_i1) method class_str_item : class_str_item -> class_str_item = function | CrNil _x -> let _x = o#loc _x in CrNil _x | CrSem (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#class_str_item _x_i1 in let _x_i2 = o#class_str_item _x_i2 in CrSem (_x, _x_i1, _x_i2) | CrCtr (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in CrCtr (_x, _x_i1, _x_i2) | CrInh (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#override_flag _x_i1 in let _x_i2 = o#class_expr _x_i2 in let _x_i3 = o#string _x_i3 in CrInh (_x, _x_i1, _x_i2, _x_i3) | CrIni (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in CrIni (_x, _x_i1) | CrMth (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#override_flag _x_i2 in let _x_i3 = o#private_flag _x_i3 in let _x_i4 = o#expr _x_i4 in let _x_i5 = o#ctyp _x_i5 in CrMth (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) | CrVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#override_flag _x_i2 in let _x_i3 = o#mutable_flag _x_i3 in let _x_i4 = o#expr _x_i4 in CrVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) | CrVir (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#private_flag _x_i2 in let _x_i3 = o#ctyp _x_i3 in CrVir (_x, _x_i1, _x_i2, _x_i3) | CrVvr (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#mutable_flag _x_i2 in let _x_i3 = o#ctyp _x_i3 in CrVvr (_x, _x_i1, _x_i2, _x_i3) | CrAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CrAnt (_x, _x_i1) method class_sig_item : class_sig_item -> class_sig_item = function | CgNil _x -> let _x = o#loc _x in CgNil _x | CgCtr (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in CgCtr (_x, _x_i1, _x_i2) | CgSem (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#class_sig_item _x_i1 in let _x_i2 = o#class_sig_item _x_i2 in CgSem (_x, _x_i1, _x_i2) | CgInh (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#class_type _x_i1 in CgInh (_x, _x_i1) | CgMth (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#private_flag _x_i2 in let _x_i3 = o#ctyp _x_i3 in CgMth (_x, _x_i1, _x_i2, _x_i3) | CgVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#mutable_flag _x_i2 in let _x_i3 = o#virtual_flag _x_i3 in let _x_i4 = o#ctyp _x_i4 in CgVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) | CgVir (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#private_flag _x_i2 in let _x_i3 = o#ctyp _x_i3 in CgVir (_x, _x_i1, _x_i2, _x_i3) | CgAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CgAnt (_x, _x_i1) method class_expr : class_expr -> class_expr = function | CeNil _x -> let _x = o#loc _x in CeNil _x | CeApp (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#class_expr _x_i1 in let _x_i2 = o#expr _x_i2 in CeApp (_x, _x_i1, _x_i2) | CeCon (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#virtual_flag _x_i1 in let _x_i2 = o#ident _x_i2 in let _x_i3 = o#ctyp _x_i3 in CeCon (_x, _x_i1, _x_i2, _x_i3) | CeFun (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#class_expr _x_i2 in CeFun (_x, _x_i1, _x_i2) | CeLet (_x, _x_i1, _x_i2, _x_i3) -> let _x = o#loc _x in let _x_i1 = o#rec_flag _x_i1 in let _x_i2 = o#binding _x_i2 in let _x_i3 = o#class_expr _x_i3 in CeLet (_x, _x_i1, _x_i2, _x_i3) | CeStr (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#class_str_item _x_i2 in CeStr (_x, _x_i1, _x_i2) | CeTyc (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#class_expr _x_i1 in let _x_i2 = o#class_type _x_i2 in CeTyc (_x, _x_i1, _x_i2) | CeAnd (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#class_expr _x_i1 in let _x_i2 = o#class_expr _x_i2 in CeAnd (_x, _x_i1, _x_i2) | CeEq (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#class_expr _x_i1 in let _x_i2 = o#class_expr _x_i2 in CeEq (_x, _x_i1, _x_i2) | CeAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CeAnt (_x, _x_i1) method binding : binding -> binding = function | BiNil _x -> let _x = o#loc _x in BiNil _x | BiAnd (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#binding _x_i1 in let _x_i2 = o#binding _x_i2 in BiAnd (_x, _x_i1, _x_i2) | BiEq (_x, _x_i1, _x_i2) -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#expr _x_i2 in BiEq (_x, _x_i1, _x_i2) | BiAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in BiAnt (_x, _x_i1) method unknown : 'a. 'a -> 'a = fun x -> x end class fold = object ((o : 'self_type)) method string : string -> 'self_type = o#unknown method list : 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type = fun _f_a -> function | [] -> o | _x :: _x_i1 -> let o = _f_a o _x in let o = o#list _f_a _x_i1 in o method with_constr : with_constr -> 'self_type = function | WcNil _x -> let o = o#loc _x in o | WcTyp (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | WcMod (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ident _x_i1 in let o = o#ident _x_i2 in o | WcTyS (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | WcMoS (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ident _x_i1 in let o = o#ident _x_i2 in o | WcAnd (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#with_constr _x_i1 in let o = o#with_constr _x_i2 in o | WcAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method virtual_flag : virtual_flag -> 'self_type = function | ViVirtual -> o | ViNil -> o | ViAnt _x -> let o = o#string _x in o method str_item : str_item -> 'self_type = function | StNil _x -> let o = o#loc _x in o | StCls (_x, _x_i1) -> let o = o#loc _x in let o = o#class_expr _x_i1 in o | StClt (_x, _x_i1) -> let o = o#loc _x in let o = o#class_type _x_i1 in o | StSem (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#str_item _x_i1 in let o = o#str_item _x_i2 in o | StDir (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#expr _x_i2 in o | StExc (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#meta_option (fun o -> o#ident) _x_i2 in o | StExp (_x, _x_i1) -> let o = o#loc _x in let o = o#expr _x_i1 in o | StExt (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#ctyp _x_i2 in let o = o#meta_list (fun o -> o#string) _x_i3 in o | StInc (_x, _x_i1) -> let o = o#loc _x in let o = o#module_expr _x_i1 in o | StMod (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_expr _x_i2 in o | StRecMod (_x, _x_i1) -> let o = o#loc _x in let o = o#module_binding _x_i1 in o | StMty (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_type _x_i2 in o | StOpn (_x, _x_i1) -> let o = o#loc _x in let o = o#ident _x_i1 in o | StTyp (_x, _x_i1) -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | StVal (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#rec_flag _x_i1 in let o = o#binding _x_i2 in o | StAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method sig_item : sig_item -> 'self_type = function | SgNil _x -> let o = o#loc _x in o | SgCls (_x, _x_i1) -> let o = o#loc _x in let o = o#class_type _x_i1 in o | SgClt (_x, _x_i1) -> let o = o#loc _x in let o = o#class_type _x_i1 in o | SgSem (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#sig_item _x_i1 in let o = o#sig_item _x_i2 in o | SgDir (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#expr _x_i2 in o | SgExc (_x, _x_i1) -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | SgExt (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#ctyp _x_i2 in let o = o#meta_list (fun o -> o#string) _x_i3 in o | SgInc (_x, _x_i1) -> let o = o#loc _x in let o = o#module_type _x_i1 in o | SgMod (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_type _x_i2 in o | SgRecMod (_x, _x_i1) -> let o = o#loc _x in let o = o#module_binding _x_i1 in o | SgMty (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_type _x_i2 in o | SgOpn (_x, _x_i1) -> let o = o#loc _x in let o = o#ident _x_i1 in o | SgTyp (_x, _x_i1) -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | SgVal (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o | SgAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method row_var_flag : row_var_flag -> 'self_type = function | RvRowVar -> o | RvNil -> o | RvAnt _x -> let o = o#string _x in o method rec_flag : rec_flag -> 'self_type = function | ReRecursive -> o | ReNil -> o | ReAnt _x -> let o = o#string _x in o method rec_binding : rec_binding -> 'self_type = function | RbNil _x -> let o = o#loc _x in o | RbSem (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#rec_binding _x_i1 in let o = o#rec_binding _x_i2 in o | RbEq (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ident _x_i1 in let o = o#expr _x_i2 in o | RbAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method private_flag : private_flag -> 'self_type = function | PrPrivate -> o | PrNil -> o | PrAnt _x -> let o = o#string _x in o method patt : patt -> 'self_type = function | PaNil _x -> let o = o#loc _x in o | PaId (_x, _x_i1) -> let o = o#loc _x in let o = o#ident _x_i1 in o | PaAli (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#patt _x_i2 in o | PaAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | PaAny _x -> let o = o#loc _x in o | PaApp (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#patt _x_i2 in o | PaArr (_x, _x_i1) -> let o = o#loc _x in let o = o#patt _x_i1 in o | PaCom (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#patt _x_i2 in o | PaSem (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#patt _x_i2 in o | PaChr (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | PaInt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | PaInt32 (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | PaInt64 (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | PaNativeInt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | PaFlo (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | PaLab (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#patt _x_i2 in o | PaOlb (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#patt _x_i2 in o | PaOlbi (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#patt _x_i2 in let o = o#expr _x_i3 in o | PaOrp (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#patt _x_i2 in o | PaRng (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#patt _x_i2 in o | PaRec (_x, _x_i1) -> let o = o#loc _x in let o = o#patt _x_i1 in o | PaEq (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ident _x_i1 in let o = o#patt _x_i2 in o | PaStr (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | PaTup (_x, _x_i1) -> let o = o#loc _x in let o = o#patt _x_i1 in o | PaTyc (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#ctyp _x_i2 in o | PaTyp (_x, _x_i1) -> let o = o#loc _x in let o = o#ident _x_i1 in o | PaVrn (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | PaLaz (_x, _x_i1) -> let o = o#loc _x in let o = o#patt _x_i1 in o | PaMod (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method override_flag : override_flag -> 'self_type = function | OvOverride -> o | OvNil -> o | OvAnt _x -> let o = o#string _x in o method mutable_flag : mutable_flag -> 'self_type = function | MuMutable -> o | MuNil -> o | MuAnt _x -> let o = o#string _x in o method module_type : module_type -> 'self_type = function | MtNil _x -> let o = o#loc _x in o | MtId (_x, _x_i1) -> let o = o#loc _x in let o = o#ident _x_i1 in o | MtFun (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_type _x_i2 in let o = o#module_type _x_i3 in o | MtQuo (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | MtSig (_x, _x_i1) -> let o = o#loc _x in let o = o#sig_item _x_i1 in o | MtWit (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#module_type _x_i1 in let o = o#with_constr _x_i2 in o | MtOf (_x, _x_i1) -> let o = o#loc _x in let o = o#module_expr _x_i1 in o | MtAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method module_expr : module_expr -> 'self_type = function | MeNil _x -> let o = o#loc _x in o | MeId (_x, _x_i1) -> let o = o#loc _x in let o = o#ident _x_i1 in o | MeApp (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#module_expr _x_i1 in let o = o#module_expr _x_i2 in o | MeFun (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_type _x_i2 in let o = o#module_expr _x_i3 in o | MeStr (_x, _x_i1) -> let o = o#loc _x in let o = o#str_item _x_i1 in o | MeTyc (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#module_expr _x_i1 in let o = o#module_type _x_i2 in o | MePkg (_x, _x_i1) -> let o = o#loc _x in let o = o#expr _x_i1 in o | MeAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method module_binding : module_binding -> 'self_type = function | MbNil _x -> let o = o#loc _x in o | MbAnd (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#module_binding _x_i1 in let o = o#module_binding _x_i2 in o | MbColEq (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_type _x_i2 in let o = o#module_expr _x_i3 in o | MbCol (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_type _x_i2 in o | MbAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method meta_option : 'a. ('self_type -> 'a -> 'self_type) -> 'a meta_option -> 'self_type = fun _f_a -> function | ONone -> o | OSome _x -> let o = _f_a o _x in o | OAnt _x -> let o = o#string _x in o method meta_list : 'a. ('self_type -> 'a -> 'self_type) -> 'a meta_list -> 'self_type = fun _f_a -> function | LNil -> o | LCons (_x, _x_i1) -> let o = _f_a o _x in let o = o#meta_list _f_a _x_i1 in o | LAnt _x -> let o = o#string _x in o method meta_bool : meta_bool -> 'self_type = function | BTrue -> o | BFalse -> o | BAnt _x -> let o = o#string _x in o method match_case : match_case -> 'self_type = function | McNil _x -> let o = o#loc _x in o | McOr (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#match_case _x_i1 in let o = o#match_case _x_i2 in o | McArr (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#expr _x_i2 in let o = o#expr _x_i3 in o | McAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method loc : loc -> 'self_type = o#unknown method ident : ident -> 'self_type = function | IdAcc (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ident _x_i1 in let o = o#ident _x_i2 in o | IdApp (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ident _x_i1 in let o = o#ident _x_i2 in o | IdLid (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | IdUid (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | IdAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method expr : expr -> 'self_type = function | ExNil _x -> let o = o#loc _x in o | ExId (_x, _x_i1) -> let o = o#loc _x in let o = o#ident _x_i1 in o | ExAcc (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | ExApp (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExAre (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExArr (_x, _x_i1) -> let o = o#loc _x in let o = o#expr _x_i1 in o | ExSem (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExAsf _x -> let o = o#loc _x in o | ExAsr (_x, _x_i1) -> let o = o#loc _x in let o = o#expr _x_i1 in o | ExAss (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExChr (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | ExCoe (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#ctyp _x_i2 in let o = o#ctyp _x_i3 in o | ExFlo (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | ExFor (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#expr _x_i2 in let o = o#expr _x_i3 in let o = o#direction_flag _x_i4 in let o = o#expr _x_i5 in o | ExFun (_x, _x_i1) -> let o = o#loc _x in let o = o#match_case _x_i1 in o | ExIfe (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in let o = o#expr _x_i3 in o | ExInt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | ExInt32 (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | ExInt64 (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | ExNativeInt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | ExLab (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#expr _x_i2 in o | ExLaz (_x, _x_i1) -> let o = o#loc _x in let o = o#expr _x_i1 in o | ExLet (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#rec_flag _x_i1 in let o = o#binding _x_i2 in let o = o#expr _x_i3 in o | ExLmd (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_expr _x_i2 in let o = o#expr _x_i3 in o | ExMat (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#match_case _x_i2 in o | ExNew (_x, _x_i1) -> let o = o#loc _x in let o = o#ident _x_i1 in o | ExObj (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#class_str_item _x_i2 in o | ExOlb (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#expr _x_i2 in o | ExOvr (_x, _x_i1) -> let o = o#loc _x in let o = o#rec_binding _x_i1 in o | ExRec (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#rec_binding _x_i1 in let o = o#expr _x_i2 in o | ExSeq (_x, _x_i1) -> let o = o#loc _x in let o = o#expr _x_i1 in o | ExSnd (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#string _x_i2 in o | ExSte (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExStr (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | ExTry (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#match_case _x_i2 in o | ExTup (_x, _x_i1) -> let o = o#loc _x in let o = o#expr _x_i1 in o | ExCom (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExTyc (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#ctyp _x_i2 in o | ExVrn (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | ExWhi (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExOpI (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ident _x_i1 in let o = o#expr _x_i2 in o | ExFUN (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#expr _x_i2 in o | ExPkg (_x, _x_i1) -> let o = o#loc _x in let o = o#module_expr _x_i1 in o method direction_flag : direction_flag -> 'self_type = function | DiTo -> o | DiDownto -> o | DiAnt _x -> let o = o#string _x in o method ctyp : ctyp -> 'self_type = function | TyNil _x -> let o = o#loc _x in o | TyAli (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyAny _x -> let o = o#loc _x in o | TyApp (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyArr (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyCls (_x, _x_i1) -> let o = o#loc _x in let o = o#ident _x_i1 in o | TyLab (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o | TyId (_x, _x_i1) -> let o = o#loc _x in let o = o#ident _x_i1 in o | TyMan (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyDcl (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#list (fun o -> o#ctyp) _x_i2 in let o = o#ctyp _x_i3 in let o = o#list (fun o (_x, _x_i1) -> let o = o#ctyp _x in let o = o#ctyp _x_i1 in o) _x_i4 in o | TyObj (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#row_var_flag _x_i2 in o | TyOlb (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o | TyPol (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyTypePol (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyQuo (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | TyQuP (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | TyQuM (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | TyAnP _x -> let o = o#loc _x in o | TyAnM _x -> let o = o#loc _x in o | TyVrn (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o | TyRec (_x, _x_i1) -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TyCol (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TySem (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyCom (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TySum (_x, _x_i1) -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TyOf (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyAnd (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyOr (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyPrv (_x, _x_i1) -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TyMut (_x, _x_i1) -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TyTup (_x, _x_i1) -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TySta (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyVrnEq (_x, _x_i1) -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TyVrnSup (_x, _x_i1) -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TyVrnInf (_x, _x_i1) -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TyVrnInfSup (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyAmp (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyOfAmp (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyPkg (_x, _x_i1) -> let o = o#loc _x in let o = o#module_type _x_i1 in o | TyAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method class_type : class_type -> 'self_type = function | CtNil _x -> let o = o#loc _x in o | CtCon (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#virtual_flag _x_i1 in let o = o#ident _x_i2 in let o = o#ctyp _x_i3 in o | CtFun (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#class_type _x_i2 in o | CtSig (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#class_sig_item _x_i2 in o | CtAnd (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#class_type _x_i1 in let o = o#class_type _x_i2 in o | CtCol (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#class_type _x_i1 in let o = o#class_type _x_i2 in o | CtEq (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#class_type _x_i1 in let o = o#class_type _x_i2 in o | CtAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method class_str_item : class_str_item -> 'self_type = function | CrNil _x -> let o = o#loc _x in o | CrSem (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#class_str_item _x_i1 in let o = o#class_str_item _x_i2 in o | CrCtr (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | CrInh (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#override_flag _x_i1 in let o = o#class_expr _x_i2 in let o = o#string _x_i3 in o | CrIni (_x, _x_i1) -> let o = o#loc _x in let o = o#expr _x_i1 in o | CrMth (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#override_flag _x_i2 in let o = o#private_flag _x_i3 in let o = o#expr _x_i4 in let o = o#ctyp _x_i5 in o | CrVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#override_flag _x_i2 in let o = o#mutable_flag _x_i3 in let o = o#expr _x_i4 in o | CrVir (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#private_flag _x_i2 in let o = o#ctyp _x_i3 in o | CrVvr (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#mutable_flag _x_i2 in let o = o#ctyp _x_i3 in o | CrAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method class_sig_item : class_sig_item -> 'self_type = function | CgNil _x -> let o = o#loc _x in o | CgCtr (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | CgSem (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#class_sig_item _x_i1 in let o = o#class_sig_item _x_i2 in o | CgInh (_x, _x_i1) -> let o = o#loc _x in let o = o#class_type _x_i1 in o | CgMth (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#private_flag _x_i2 in let o = o#ctyp _x_i3 in o | CgVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#mutable_flag _x_i2 in let o = o#virtual_flag _x_i3 in let o = o#ctyp _x_i4 in o | CgVir (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#private_flag _x_i2 in let o = o#ctyp _x_i3 in o | CgAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method class_expr : class_expr -> 'self_type = function | CeNil _x -> let o = o#loc _x in o | CeApp (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#class_expr _x_i1 in let o = o#expr _x_i2 in o | CeCon (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#virtual_flag _x_i1 in let o = o#ident _x_i2 in let o = o#ctyp _x_i3 in o | CeFun (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#class_expr _x_i2 in o | CeLet (_x, _x_i1, _x_i2, _x_i3) -> let o = o#loc _x in let o = o#rec_flag _x_i1 in let o = o#binding _x_i2 in let o = o#class_expr _x_i3 in o | CeStr (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#class_str_item _x_i2 in o | CeTyc (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#class_expr _x_i1 in let o = o#class_type _x_i2 in o | CeAnd (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#class_expr _x_i1 in let o = o#class_expr _x_i2 in o | CeEq (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#class_expr _x_i1 in let o = o#class_expr _x_i2 in o | CeAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method binding : binding -> 'self_type = function | BiNil _x -> let o = o#loc _x in o | BiAnd (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#binding _x_i1 in let o = o#binding _x_i2 in o | BiEq (_x, _x_i1, _x_i2) -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#expr _x_i2 in o | BiAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o method unknown : 'a. 'a -> 'self_type = fun _ -> o end let map_expr f = object inherit map as super method expr = fun x -> f (super#expr x) end let map_patt f = object inherit map as super method patt = fun x -> f (super#patt x) end let map_ctyp f = object inherit map as super method ctyp = fun x -> f (super#ctyp x) end let map_str_item f = object inherit map as super method str_item = fun x -> f (super#str_item x) end let map_sig_item f = object inherit map as super method sig_item = fun x -> f (super#sig_item x) end let map_loc f = object inherit map as super method loc = fun x -> f (super#loc x) end end end module DynAst = struct module Make (Ast : Sig.Ast) : Sig.DynAst with module Ast = Ast = struct module Ast = Ast type 'a tag = | Tag_ctyp | Tag_patt | Tag_expr | Tag_module_type | Tag_sig_item | Tag_with_constr | Tag_module_expr | Tag_str_item | Tag_class_type | Tag_class_sig_item | Tag_class_expr | Tag_class_str_item | Tag_match_case | Tag_ident | Tag_binding | Tag_rec_binding | Tag_module_binding let string_of_tag = function | Tag_ctyp -> "ctyp" | Tag_patt -> "patt" | Tag_expr -> "expr" | Tag_module_type -> "module_type" | Tag_sig_item -> "sig_item" | Tag_with_constr -> "with_constr" | Tag_module_expr -> "module_expr" | Tag_str_item -> "str_item" | Tag_class_type -> "class_type" | Tag_class_sig_item -> "class_sig_item" | Tag_class_expr -> "class_expr" | Tag_class_str_item -> "class_str_item" | Tag_match_case -> "match_case" | Tag_ident -> "ident" | Tag_binding -> "binding" | Tag_rec_binding -> "rec_binding" | Tag_module_binding -> "module_binding" let ctyp_tag = Tag_ctyp let patt_tag = Tag_patt let expr_tag = Tag_expr let module_type_tag = Tag_module_type let sig_item_tag = Tag_sig_item let with_constr_tag = Tag_with_constr let module_expr_tag = Tag_module_expr let str_item_tag = Tag_str_item let class_type_tag = Tag_class_type let class_sig_item_tag = Tag_class_sig_item let class_expr_tag = Tag_class_expr let class_str_item_tag = Tag_class_str_item let match_case_tag = Tag_match_case let ident_tag = Tag_ident let binding_tag = Tag_binding let rec_binding_tag = Tag_rec_binding let module_binding_tag = Tag_module_binding type dyn external dyn_tag : 'a tag -> dyn tag = "%identity" module Pack (X : sig type 'a t end) = struct type pack = ((dyn tag) * Obj.t) exception Pack_error let pack tag v = ((dyn_tag tag), (Obj.repr v)) let unpack (tag : 'a tag) (tag', obj) = if (dyn_tag tag) = tag' then (Obj.obj obj : 'a X.t) else raise Pack_error let print_tag f (tag, _) = Format.pp_print_string f (string_of_tag tag) end end end module Quotation = struct module Make (Ast : Sig.Camlp4Ast) : Sig.Quotation with module Ast = Ast = struct module Ast = Ast module DynAst = DynAst.Make(Ast) module Loc = Ast.Loc open Format open Sig type 'a expand_fun = Loc.t -> string option -> string -> 'a module Exp_key = DynAst.Pack(struct type 'a t = unit end) module Exp_fun = DynAst.Pack(struct type 'a t = 'a expand_fun end) let expanders_table : (((string * Exp_key.pack) * Exp_fun.pack) list) ref = ref [] let default = ref "" let translate = ref (fun x -> x) let expander_name name = match !translate name with | "" -> !default | name -> name let find name tag = let key = ((expander_name name), (Exp_key.pack tag ())) in Exp_fun.unpack tag (List.assoc key !expanders_table) let add name tag f = let elt = ((name, (Exp_key.pack tag ())), (Exp_fun.pack tag f)) in expanders_table := elt :: !expanders_table let dump_file = ref None module Error = struct type error = | Finding | Expanding | ParsingResult of Loc.t * string | Locating type t = (string * string * error * exn) exception E of t let print ppf (name, position, ctx, exn) = let name = if name = "" then !default else name in let pp x = fprintf ppf "@?@[<2>While %s %S in a position of %S:" x name position in let () = match ctx with | Finding -> (pp "finding quotation"; if !expanders_table = [] then fprintf ppf "@ There is no quotation expander available." else (fprintf ppf "@ @[Available quotation expanders are:@\n"; List.iter (fun ((s, t), _) -> fprintf ppf "@[<2>%s@ (in@ a@ position@ of %a)@]@ " s Exp_key.print_tag t) !expanders_table; fprintf ppf "@]")) | Expanding -> pp "expanding quotation" | Locating -> pp "parsing" | ParsingResult (loc, str) -> let () = pp "parsing result of quotation" in (match !dump_file with | Some dump_file -> let () = fprintf ppf " dumping result...\n" in (try let oc = open_out_bin dump_file in (output_string oc str; output_string oc "\n"; flush oc; close_out oc; fprintf ppf "%a:" Loc.print (Loc.set_file_name dump_file loc)) with | _ -> fprintf ppf "Error while dumping result in file %S; dump aborted" dump_file) | None -> fprintf ppf "\n(consider setting variable Quotation.dump_file, or using the -QD option)") in fprintf ppf "@\n%a@]@." ErrorHandler.print exn let to_string x = let b = Buffer.create 50 in let () = bprintf b "%a" print x in Buffer.contents b end let _ = let module M = ErrorHandler.Register(Error) in () open Error let expand_quotation loc expander pos_tag quot = let loc_name_opt = if quot.q_loc = "" then None else Some quot.q_loc in try expander loc loc_name_opt quot.q_contents with | (Loc.Exc_located (_, (Error.E _)) as exc) -> raise exc | Loc.Exc_located (iloc, exc) -> let exc1 = Error.E (((quot.q_name), pos_tag, Expanding, exc)) in raise (Loc.Exc_located (iloc, exc1)) | exc -> let exc1 = Error.E (((quot.q_name), pos_tag, Expanding, exc)) in raise (Loc.Exc_located (loc, exc1)) let parse_quotation_result parse loc quot pos_tag str = try parse loc str with | Loc.Exc_located (iloc, (Error.E ((n, pos_tag, Expanding, exc)))) -> let ctx = ParsingResult (iloc, quot.q_contents) in let exc1 = Error.E ((n, pos_tag, ctx, exc)) in raise (Loc.Exc_located (iloc, exc1)) | Loc.Exc_located (iloc, ((Error.E _ as exc))) -> raise (Loc.Exc_located (iloc, exc)) | Loc.Exc_located (iloc, exc) -> let ctx = ParsingResult (iloc, quot.q_contents) in let exc1 = Error.E (((quot.q_name), pos_tag, ctx, exc)) in raise (Loc.Exc_located (iloc, exc1)) let expand loc quotation tag = let pos_tag = DynAst.string_of_tag tag in let name = quotation.q_name in let expander = try find name tag with | (Loc.Exc_located (_, (Error.E _)) as exc) -> raise exc | Loc.Exc_located (qloc, exc) -> raise (Loc.Exc_located (qloc, (Error.E ((name, pos_tag, Finding, exc))))) | exc -> raise (Loc.Exc_located (loc, (Error.E ((name, pos_tag, Finding, exc))))) in let loc = Loc.join (Loc.move `start quotation.q_shift loc) in expand_quotation loc expander pos_tag quotation end end module AstFilters = struct module Make (Ast : Sig.Camlp4Ast) : Sig.AstFilters with module Ast = Ast = struct module Ast = Ast type 'a filter = 'a -> 'a let interf_filters = Queue.create () let fold_interf_filters f i = Queue.fold f i interf_filters let implem_filters = Queue.create () let fold_implem_filters f i = Queue.fold f i implem_filters let topphrase_filters = Queue.create () let fold_topphrase_filters f i = Queue.fold f i topphrase_filters let register_sig_item_filter f = Queue.add f interf_filters let register_str_item_filter f = Queue.add f implem_filters let register_topphrase_filter f = Queue.add f topphrase_filters end end module Camlp4Ast2OCamlAst : sig module Make (Camlp4Ast : Sig.Camlp4Ast) : sig open Camlp4Ast val sig_item : sig_item -> Camlp4_import.Parsetree.signature val str_item : str_item -> Camlp4_import.Parsetree.structure val phrase : str_item -> Camlp4_import.Parsetree.toplevel_phrase end end = struct module Make (Ast : Sig.Camlp4Ast) = struct open Format open Camlp4_import.Parsetree open Camlp4_import.Longident open Camlp4_import.Asttypes open Ast let constructors_arity () = !Camlp4_config.constructors_arity let error loc str = Loc.raise loc (Failure str) let char_of_char_token loc s = try Token.Eval.char s with | (Failure _ as exn) -> Loc.raise loc exn let string_of_string_token loc s = try Token.Eval.string s with | (Failure _ as exn) -> Loc.raise loc exn let remove_underscores s = let l = String.length s in let rec remove src dst = if src >= l then if dst >= l then s else String.sub s 0 dst else (match s.[src] with | '_' -> remove (src + 1) dst | c -> (s.[dst] <- c; remove (src + 1) (dst + 1))) in remove 0 0 let mkloc = Loc.to_ocaml_location let mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc) let with_loc txt loc = Camlp4_import.Location.mkloc txt (mkloc loc) let mktyp loc d = { ptyp_desc = d; ptyp_loc = mkloc loc; } let mkpat loc d = { ppat_desc = d; ppat_loc = mkloc loc; } let mkghpat loc d = { ppat_desc = d; ppat_loc = mkghloc loc; } let mkexp loc d = { pexp_desc = d; pexp_loc = mkloc loc; } let mkmty loc d = { pmty_desc = d; pmty_loc = mkloc loc; } let mksig loc d = { psig_desc = d; psig_loc = mkloc loc; } let mkmod loc d = { pmod_desc = d; pmod_loc = mkloc loc; } let mkstr loc d = { pstr_desc = d; pstr_loc = mkloc loc; } let mkfield loc d = { pfield_desc = d; pfield_loc = mkloc loc; } let mkcty loc d = { pcty_desc = d; pcty_loc = mkloc loc; } let mkcl loc d = { pcl_desc = d; pcl_loc = mkloc loc; } let mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; } let mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; } let mkpolytype t = match t.ptyp_desc with | Ptyp_poly (_, _) -> t | _ -> { (t) with ptyp_desc = Ptyp_poly ([], t); } let mkvirtual = function | Ast.ViVirtual -> Virtual | Ast.ViNil -> Concrete | _ -> assert false let mkdirection = function | Ast.DiTo -> Upto | Ast.DiDownto -> Downto | _ -> assert false let lident s = Lident s let lident_with_loc s loc = with_loc (Lident s) loc let ldot l s = Ldot (l, s) let lapply l s = Lapply (l, s) let conv_con = let t = Hashtbl.create 73 in (List.iter (fun (s, s') -> Hashtbl.add t s s') [ ("True", "true"); ("False", "false"); (" True", "True"); (" False", "False") ]; fun s -> try Hashtbl.find t s with | Not_found -> s) let conv_lab = let t = Hashtbl.create 73 in (List.iter (fun (s, s') -> Hashtbl.add t s s') [ ("val", "contents") ]; fun s -> try Hashtbl.find t s with | Not_found -> s) let array_function_no_loc str name = ldot (lident str) (if !Camlp4_config.unsafe then "unsafe_" ^ name else name) let array_function loc str name = with_loc (array_function_no_loc str name) loc let mkrf = function | Ast.ReRecursive -> Recursive | Ast.ReNil -> Nonrecursive | _ -> assert false let mkli sloc s list = let rec loop f = function | i :: il -> loop (ldot (f i)) il | [] -> f s in with_loc (loop lident list) sloc let rec ctyp_fa al = function | TyApp (_, f, a) -> ctyp_fa (a :: al) f | f -> (f, al) let ident_tag ?(conv_lid = fun x -> x) i = let rec self i acc = match i with | Ast.IdAcc (_, (Ast.IdLid (_, "*predef*")), (Ast.IdLid (_, "option"))) -> ((ldot (lident "*predef*") "option"), `lident) | Ast.IdAcc (_, i1, i2) -> self i2 (Some (self i1 acc)) | Ast.IdApp (_, i1, i2) -> let i' = Lapply ((fst (self i1 None)), (fst (self i2 None))) in let x = (match acc with | None -> i' | _ -> error (loc_of_ident i) "invalid long identifier") in (x, `app) | Ast.IdUid (_, s) -> let x = (match acc with | None -> lident s | Some ((acc, (`uident | `app))) -> ldot acc s | _ -> error (loc_of_ident i) "invalid long identifier") in (x, `uident) | Ast.IdLid (_, s) -> let x = (match acc with | None -> lident (conv_lid s) | Some ((acc, (`uident | `app))) -> ldot acc (conv_lid s) | _ -> error (loc_of_ident i) "invalid long identifier") in (x, `lident) | _ -> error (loc_of_ident i) "invalid long identifier" in self i None let ident_noloc ?conv_lid i = fst (ident_tag ?conv_lid i) let ident ?conv_lid i = with_loc (ident_noloc ?conv_lid i) (loc_of_ident i) let long_lident msg id = match ident_tag id with | (i, `lident) -> with_loc i (loc_of_ident id) | _ -> error (loc_of_ident id) msg let long_type_ident = long_lident "invalid long identifier type" let long_class_ident = long_lident "invalid class name" let long_uident_noloc ?(conv_con = fun x -> x) i = match ident_tag i with | (Ldot (i, s), `uident) -> ldot i (conv_con s) | (Lident s, `uident) -> lident (conv_con s) | (i, `app) -> i | _ -> error (loc_of_ident i) "uppercase identifier expected" let long_uident ?conv_con i = with_loc (long_uident_noloc ?conv_con i) (loc_of_ident i) let rec ctyp_long_id_prefix t = match t with | Ast.TyId (_, i) -> ident_noloc i | Ast.TyApp (_, m1, m2) -> let li1 = ctyp_long_id_prefix m1 in let li2 = ctyp_long_id_prefix m2 in Lapply (li1, li2) | t -> error (loc_of_ctyp t) "invalid module expression" let ctyp_long_id t = match t with | Ast.TyId (_, i) -> (false, (long_type_ident i)) | TyApp (loc, _, _) -> error loc "invalid type name" | TyCls (_, i) -> (true, (ident i)) | t -> error (loc_of_ctyp t) "invalid type" let rec ty_var_list_of_ctyp = function | Ast.TyApp (_, t1, t2) -> (ty_var_list_of_ctyp t1) @ (ty_var_list_of_ctyp t2) | Ast.TyQuo (_, s) -> [ s ] | _ -> assert false let predef_option loc = TyId ((loc, (IdAcc ((loc, (IdLid ((loc, "*predef*"))), (IdLid ((loc, "option")))))))) let rec ctyp = function | TyId (loc, i) -> let li = long_type_ident i in mktyp loc (Ptyp_constr (li, [])) | TyAli (loc, t1, t2) -> let (t, i) = (match (t1, t2) with | (t, TyQuo (_, s)) -> (t, s) | (TyQuo (_, s), t) -> (t, s) | _ -> error loc "invalid alias type") in mktyp loc (Ptyp_alias ((ctyp t), i)) | TyAny loc -> mktyp loc Ptyp_any | (TyApp (loc, _, _) as f) -> let (f, al) = ctyp_fa [] f in let (is_cls, li) = ctyp_long_id f in if is_cls then mktyp loc (Ptyp_class (li, (List.map ctyp al), [])) else mktyp loc (Ptyp_constr (li, (List.map ctyp al))) | TyArr (loc, (TyLab (_, lab, t1)), t2) -> mktyp loc (Ptyp_arrow (lab, (ctyp t1), (ctyp t2))) | TyArr (loc, (TyOlb (loc1, lab, t1)), t2) -> let t1 = TyApp (loc1, (predef_option loc1), t1) in mktyp loc (Ptyp_arrow (("?" ^ lab), (ctyp t1), (ctyp t2))) | TyArr (loc, t1, t2) -> mktyp loc (Ptyp_arrow ("", (ctyp t1), (ctyp t2))) | Ast.TyObj (loc, fl, Ast.RvNil) -> mktyp loc (Ptyp_object (meth_list fl [])) | Ast.TyObj (loc, fl, Ast.RvRowVar) -> mktyp loc (Ptyp_object (meth_list fl [ mkfield loc Pfield_var ])) | TyCls (loc, id) -> mktyp loc (Ptyp_class ((ident id), [], [])) | Ast.TyPkg (loc, pt) -> let (i, cs) = package_type pt in mktyp loc (Ptyp_package (i, cs)) | TyLab (loc, _, _) -> error loc "labelled type not allowed here" | TyMan (loc, _, _) -> error loc "manifest type not allowed here" | TyOlb (loc, _, _) -> error loc "labelled type not allowed here" | TyPol (loc, t1, t2) -> mktyp loc (Ptyp_poly ((ty_var_list_of_ctyp t1), (ctyp t2))) | TyQuo (loc, s) -> mktyp loc (Ptyp_var s) | TyRec (loc, _) -> error loc "record type not allowed here" | TySum (loc, _) -> error loc "sum type not allowed here" | TyPrv (loc, _) -> error loc "private type not allowed here" | TyMut (loc, _) -> error loc "mutable type not allowed here" | TyOr (loc, _, _) -> error loc "type1 | type2 not allowed here" | TyAnd (loc, _, _) -> error loc "type1 and type2 not allowed here" | TyOf (loc, _, _) -> error loc "type1 of type2 not allowed here" | TyCol (loc, _, _) -> error loc "type1 : type2 not allowed here" | TySem (loc, _, _) -> error loc "type1 ; type2 not allowed here" | Ast.TyTup (loc, (Ast.TySta (_, t1, t2))) -> mktyp loc (Ptyp_tuple (List.map ctyp (list_of_ctyp t1 (list_of_ctyp t2 [])))) | Ast.TyVrnEq (loc, t) -> mktyp loc (Ptyp_variant ((row_field t), true, None)) | Ast.TyVrnSup (loc, t) -> mktyp loc (Ptyp_variant ((row_field t), false, None)) | Ast.TyVrnInf (loc, t) -> mktyp loc (Ptyp_variant ((row_field t), true, (Some []))) | Ast.TyVrnInfSup (loc, t, t') -> mktyp loc (Ptyp_variant ((row_field t), true, (Some (name_tags t')))) | TyAnt (loc, _) -> error loc "antiquotation not allowed here" | TyOfAmp (_, _, _) | TyAmp (_, _, _) | TySta (_, _, _) | TyCom (_, _, _) | TyVrn (_, _) | TyQuM (_, _) | TyQuP (_, _) | TyDcl (_, _, _, _, _) | TyAnP _ | TyAnM _ | TyTypePol (_, _, _) | TyObj (_, _, (RvAnt _)) | TyNil _ | TyTup (_, _) -> assert false and row_field = function | Ast.TyNil _ -> [] | Ast.TyVrn (_, i) -> [ Rtag (i, true, []) ] | Ast.TyOfAmp (_, (Ast.TyVrn (_, i)), t) -> [ Rtag (i, true, (List.map ctyp (list_of_ctyp t []))) ] | Ast.TyOf (_, (Ast.TyVrn (_, i)), t) -> [ Rtag (i, false, (List.map ctyp (list_of_ctyp t []))) ] | Ast.TyOr (_, t1, t2) -> (row_field t1) @ (row_field t2) | t -> [ Rinherit (ctyp t) ] and name_tags = function | Ast.TyApp (_, t1, t2) -> (name_tags t1) @ (name_tags t2) | Ast.TyVrn (_, s) -> [ s ] | _ -> assert false and meth_list fl acc = match fl with | Ast.TyNil _ -> acc | Ast.TySem (_, t1, t2) -> meth_list t1 (meth_list t2 acc) | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (_, lab)))), t) -> (mkfield loc (Pfield (lab, (mkpolytype (ctyp t))))) :: acc | _ -> assert false and package_type_constraints wc acc = match wc with | Ast.WcNil _ -> acc | Ast.WcTyp (_, (Ast.TyId (_, id)), ct) -> ((ident id), (ctyp ct)) :: acc | Ast.WcAnd (_, wc1, wc2) -> package_type_constraints wc1 (package_type_constraints wc2 acc) | _ -> error (loc_of_with_constr wc) "unexpected `with constraint' for a package type" and package_type : module_type -> package_type = function | Ast.MtWit (_, (Ast.MtId (_, i)), wc) -> ((long_uident i), (package_type_constraints wc [])) | Ast.MtId (_, i) -> ((long_uident i), []) | mt -> error (loc_of_module_type mt) "unexpected package type" let mktype loc tl cl tk tp tm = let (params, variance) = List.split tl in { ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; ptype_private = tp; ptype_manifest = tm; ptype_loc = mkloc loc; ptype_variance = variance; } let mkprivate' m = if m then Private else Public let mkprivate = function | Ast.PrPrivate -> Private | Ast.PrNil -> Public | _ -> assert false let mktrecord = function | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (sloc, s)))), (Ast.TyMut (_, t))) -> ((with_loc s sloc), Mutable, (mkpolytype (ctyp t)), (mkloc loc)) | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (sloc, s)))), t) -> ((with_loc s sloc), Immutable, (mkpolytype (ctyp t)), (mkloc loc)) | _ -> assert false let mkvariant = function | Ast.TyId (loc, (Ast.IdUid (sloc, s))) -> ((with_loc (conv_con s) sloc), [], None, (mkloc loc)) | Ast.TyOf (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), t) -> ((with_loc (conv_con s) sloc), (List.map ctyp (list_of_ctyp t [])), None, (mkloc loc)) | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), (Ast.TyArr (_, t, u))) -> ((with_loc (conv_con s) sloc), (List.map ctyp (list_of_ctyp t [])), (Some (ctyp u)), (mkloc loc)) | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), t) -> ((with_loc (conv_con s) sloc), [], (Some (ctyp t)), (mkloc loc)) | _ -> assert false let rec type_decl tl cl loc m pflag = function | Ast.TyMan (_, t1, t2) -> type_decl tl cl loc (Some (ctyp t1)) pflag t2 | Ast.TyPrv (_, t) -> type_decl tl cl loc m true t | Ast.TyRec (_, t) -> mktype loc tl cl (Ptype_record (List.map mktrecord (list_of_ctyp t []))) (mkprivate' pflag) m | Ast.TySum (_, t) -> mktype loc tl cl (Ptype_variant (List.map mkvariant (list_of_ctyp t []))) (mkprivate' pflag) m | t -> if m <> None then error loc "only one manifest type allowed by definition" else (let m = match t with | Ast.TyNil _ -> None | _ -> Some (ctyp t) in mktype loc tl cl Ptype_abstract (mkprivate' pflag) m) let type_decl tl cl t loc = type_decl tl cl loc None false t let mkvalue_desc loc t p = { pval_type = ctyp t; pval_prim = p; pval_loc = mkloc loc; } let rec list_of_meta_list = function | Ast.LNil -> [] | Ast.LCons (x, xs) -> x :: (list_of_meta_list xs) | Ast.LAnt _ -> assert false let mkmutable = function | Ast.MuMutable -> Mutable | Ast.MuNil -> Immutable | _ -> assert false let paolab lab p = match (lab, p) with | ("", (Ast.PaId (_, (Ast.IdLid (_, i))) | Ast.PaTyc (_, (Ast.PaId (_, (Ast.IdLid (_, i)))), _))) -> i | ("", p) -> error (loc_of_patt p) "bad ast in label" | _ -> lab let opt_private_ctyp = function | Ast.TyPrv (_, t) -> (Ptype_abstract, Private, (ctyp t)) | t -> (Ptype_abstract, Public, (ctyp t)) let rec type_parameters t acc = match t with | Ast.TyApp (_, t1, t2) -> type_parameters t1 (type_parameters t2 acc) | Ast.TyQuP (_, s) -> (s, (true, false)) :: acc | Ast.TyQuM (_, s) -> (s, (false, true)) :: acc | Ast.TyQuo (_, s) -> (s, (false, false)) :: acc | _ -> assert false let rec optional_type_parameters t acc = match t with | Ast.TyApp (_, t1, t2) -> optional_type_parameters t1 (optional_type_parameters t2 acc) | Ast.TyQuP (loc, s) -> ((Some (with_loc s loc)), (true, false)) :: acc | Ast.TyAnP _loc -> (None, (true, false)) :: acc | Ast.TyQuM (loc, s) -> ((Some (with_loc s loc)), (false, true)) :: acc | Ast.TyAnM _loc -> (None, (false, true)) :: acc | Ast.TyQuo (loc, s) -> ((Some (with_loc s loc)), (false, false)) :: acc | Ast.TyAny _loc -> (None, (false, false)) :: acc | _ -> assert false let rec class_parameters t acc = match t with | Ast.TyCom (_, t1, t2) -> class_parameters t1 (class_parameters t2 acc) | Ast.TyQuP (loc, s) -> ((with_loc s loc), (true, false)) :: acc | Ast.TyQuM (loc, s) -> ((with_loc s loc), (false, true)) :: acc | Ast.TyQuo (loc, s) -> ((with_loc s loc), (false, false)) :: acc | _ -> assert false let rec type_parameters_and_type_name t acc = match t with | Ast.TyApp (_, t1, t2) -> type_parameters_and_type_name t1 (optional_type_parameters t2 acc) | Ast.TyId (_, i) -> ((ident i), acc) | _ -> assert false let mkwithtyp pwith_type loc id_tpl ct = let (id, tpl) = type_parameters_and_type_name id_tpl [] in let (params, variance) = List.split tpl in let (kind, priv, ct) = opt_private_ctyp ct in (id, (pwith_type { ptype_params = params; ptype_cstrs = []; ptype_kind = kind; ptype_private = priv; ptype_manifest = Some ct; ptype_loc = mkloc loc; ptype_variance = variance; })) let rec mkwithc wc acc = match wc with | Ast.WcNil _ -> acc | Ast.WcTyp (loc, id_tpl, ct) -> (mkwithtyp (fun x -> Pwith_type x) loc id_tpl ct) :: acc | Ast.WcMod (_, i1, i2) -> ((long_uident i1), (Pwith_module (long_uident i2))) :: acc | Ast.WcTyS (loc, id_tpl, ct) -> (mkwithtyp (fun x -> Pwith_typesubst x) loc id_tpl ct) :: acc | Ast.WcMoS (_, i1, i2) -> ((long_uident i1), (Pwith_modsubst (long_uident i2))) :: acc | Ast.WcAnd (_, wc1, wc2) -> mkwithc wc1 (mkwithc wc2 acc) | Ast.WcAnt (loc, _) -> error loc "bad with constraint (antiquotation)" let rec patt_fa al = function | PaApp (_, f, a) -> patt_fa (a :: al) f | f -> (f, al) let rec deep_mkrangepat loc c1 c2 = if c1 = c2 then mkghpat loc (Ppat_constant (Const_char c1)) else mkghpat loc (Ppat_or ((mkghpat loc (Ppat_constant (Const_char c1))), (deep_mkrangepat loc (Char.chr ((Char.code c1) + 1)) c2))) let rec mkrangepat loc c1 c2 = if c1 > c2 then mkrangepat loc c2 c1 else if c1 = c2 then mkpat loc (Ppat_constant (Const_char c1)) else mkpat loc (Ppat_or ((mkghpat loc (Ppat_constant (Const_char c1))), (deep_mkrangepat loc (Char.chr ((Char.code c1) + 1)) c2))) let rec patt = function | Ast.PaId (loc, (Ast.IdLid (sloc, s))) -> mkpat loc (Ppat_var (with_loc s sloc)) | Ast.PaId (loc, i) -> let p = Ppat_construct ((long_uident ~conv_con i), None, (constructors_arity ())) in mkpat loc p | PaAli (loc, p1, p2) -> let (p, i) = (match (p1, p2) with | (p, Ast.PaId (_, (Ast.IdLid (sloc, s)))) -> (p, (with_loc s sloc)) | (Ast.PaId (_, (Ast.IdLid (sloc, s))), p) -> (p, (with_loc s sloc)) | _ -> error loc "invalid alias pattern") in mkpat loc (Ppat_alias ((patt p), i)) | PaAnt (loc, _) -> error loc "antiquotation not allowed here" | PaAny loc -> mkpat loc Ppat_any | Ast.PaApp (loc, (Ast.PaId (_, (Ast.IdUid (sloc, s)))), (Ast.PaTup (_, (Ast.PaAny loc_any)))) -> mkpat loc (Ppat_construct ((lident_with_loc (conv_con s) sloc), (Some (mkpat loc_any Ppat_any)), false)) | (PaApp (loc, _, _) as f) -> let (f, al) = patt_fa [] f in let al = List.map patt al in (match (patt f).ppat_desc with | Ppat_construct (li, None, _) -> if constructors_arity () then mkpat loc (Ppat_construct (li, (Some (mkpat loc (Ppat_tuple al))), true)) else (let a = match al with | [ a ] -> a | _ -> mkpat loc (Ppat_tuple al) in mkpat loc (Ppat_construct (li, (Some a), false))) | Ppat_variant (s, None) -> let a = if constructors_arity () then mkpat loc (Ppat_tuple al) else (match al with | [ a ] -> a | _ -> mkpat loc (Ppat_tuple al)) in mkpat loc (Ppat_variant (s, (Some a))) | _ -> error (loc_of_patt f) "this is not a constructor, it cannot be applied in a pattern") | PaArr (loc, p) -> mkpat loc (Ppat_array (List.map patt (list_of_patt p []))) | PaChr (loc, s) -> mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s))) | PaInt (loc, s) -> let i = (try int_of_string s with | Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int") in mkpat loc (Ppat_constant (Const_int i)) | PaInt32 (loc, s) -> let i32 = (try Int32.of_string s with | Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32") in mkpat loc (Ppat_constant (Const_int32 i32)) | PaInt64 (loc, s) -> let i64 = (try Int64.of_string s with | Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64") in mkpat loc (Ppat_constant (Const_int64 i64)) | PaNativeInt (loc, s) -> let nati = (try Nativeint.of_string s with | Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint") in mkpat loc (Ppat_constant (Const_nativeint nati)) | PaFlo (loc, s) -> mkpat loc (Ppat_constant (Const_float (remove_underscores s))) | PaLab (loc, _, _) -> error loc "labeled pattern not allowed here" | PaOlb (loc, _, _) | PaOlbi (loc, _, _, _) -> error loc "labeled pattern not allowed here" | PaOrp (loc, p1, p2) -> mkpat loc (Ppat_or ((patt p1), (patt p2))) | PaRng (loc, p1, p2) -> (match (p1, p2) with | (PaChr (loc1, c1), PaChr (loc2, c2)) -> let c1 = char_of_char_token loc1 c1 in let c2 = char_of_char_token loc2 c2 in mkrangepat loc c1 c2 | _ -> error loc "range pattern allowed only for characters") | PaRec (loc, p) -> let ps = list_of_patt p [] in let is_wildcard = (function | Ast.PaAny _ -> true | _ -> false) in let (wildcards, ps) = List.partition is_wildcard ps in let is_closed = if wildcards = [] then Closed else Open in mkpat loc (Ppat_record (((List.map mklabpat ps), is_closed))) | PaStr (loc, s) -> mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s))) | Ast.PaTup (loc, (Ast.PaCom (_, p1, p2))) -> mkpat loc (Ppat_tuple (List.map patt (list_of_patt p1 (list_of_patt p2 [])))) | Ast.PaTup (loc, _) -> error loc "singleton tuple pattern" | PaTyc (loc, p, t) -> mkpat loc (Ppat_constraint ((patt p), (ctyp t))) | PaTyp (loc, i) -> mkpat loc (Ppat_type (long_type_ident i)) | PaVrn (loc, s) -> mkpat loc (Ppat_variant ((conv_con s), None)) | PaLaz (loc, p) -> mkpat loc (Ppat_lazy (patt p)) | PaMod (loc, m) -> mkpat loc (Ppat_unpack (with_loc m loc)) | (PaEq (_, _, _) | PaSem (_, _, _) | PaCom (_, _, _) | PaNil _ as p) -> error (loc_of_patt p) "invalid pattern" and mklabpat = function | Ast.PaEq (_, i, p) -> ((ident ~conv_lid: conv_lab i), (patt p)) | p -> error (loc_of_patt p) "invalid pattern" let rec expr_fa al = function | ExApp (_, f, a) -> expr_fa (a :: al) f | f -> (f, al) let rec class_expr_fa al = function | CeApp (_, ce, a) -> class_expr_fa (a :: al) ce | ce -> (ce, al) let rec sep_expr_acc l = function | ExAcc (_, e1, e2) -> sep_expr_acc (sep_expr_acc l e2) e1 | (Ast.ExId (loc, (Ast.IdUid (_, s))) as e) -> (match l with | [] -> [ (loc, [], e) ] | (loc', sl, e) :: l -> ((Loc.merge loc loc'), (s :: sl), e) :: l) | Ast.ExId (_, ((Ast.IdAcc (_, _, _) as i))) -> let rec normalize_acc = (function | Ast.IdAcc (_loc, i1, i2) -> Ast.ExAcc (_loc, (normalize_acc i1), (normalize_acc i2)) | Ast.IdApp (_loc, i1, i2) -> Ast.ExApp (_loc, (normalize_acc i1), (normalize_acc i2)) | (Ast.IdAnt (_loc, _) | Ast.IdUid (_loc, _) | Ast.IdLid (_loc, _) as i) -> Ast.ExId (_loc, i)) in sep_expr_acc l (normalize_acc i) | e -> ((loc_of_expr e), [], e) :: l let override_flag loc = function | Ast.OvOverride -> Override | Ast.OvNil -> Fresh | _ -> error loc "antiquotation not allowed here" let list_of_opt_ctyp ot acc = match ot with | Ast.TyNil _ -> acc | t -> list_of_ctyp t acc let varify_constructors var_names = let rec loop t = let desc = match t.ptyp_desc with | Ptyp_any -> Ptyp_any | Ptyp_var x -> Ptyp_var x | Ptyp_arrow (label, core_type, core_type') -> Ptyp_arrow (label, (loop core_type), (loop core_type')) | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) | Ptyp_constr ({ txt = Lident s }, []) when List.mem s var_names -> Ptyp_var ("&" ^ s) | Ptyp_constr (longident, lst) -> Ptyp_constr (longident, (List.map loop lst)) | Ptyp_object lst -> Ptyp_object (List.map loop_core_field lst) | Ptyp_class (longident, lst, lbl_list) -> Ptyp_class ((longident, (List.map loop lst), lbl_list)) | Ptyp_alias (core_type, string) -> Ptyp_alias (((loop core_type), string)) | Ptyp_variant (row_field_list, flag, lbl_lst_option) -> Ptyp_variant (((List.map loop_row_field row_field_list), flag, lbl_lst_option)) | Ptyp_poly (string_lst, core_type) -> Ptyp_poly ((string_lst, (loop core_type))) | Ptyp_package (longident, lst) -> Ptyp_package ((longident, (List.map (fun (n, typ) -> (n, (loop typ))) lst))) in { (t) with ptyp_desc = desc; } and loop_core_field t = let desc = match t.pfield_desc with | Pfield ((n, typ)) -> Pfield ((n, (loop typ))) | Pfield_var -> Pfield_var in { (t) with pfield_desc = desc; } and loop_row_field x = match x with | Rtag ((label, flag, lst)) -> Rtag ((label, flag, (List.map loop lst))) | Rinherit t -> Rinherit (loop t) in loop let rec expr = function | Ast.ExAcc (loc, x, (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> mkexp loc (Pexp_apply ((mkexp loc (Pexp_ident (lident_with_loc "!" loc))), [ ("", (expr x)) ])) | (ExAcc (loc, _, _) | Ast.ExId (loc, (Ast.IdAcc (_, _, _))) as e) -> let (e, l) = (match sep_expr_acc [] e with | (loc, ml, Ast.ExId (sloc, (Ast.IdUid (_, s)))) :: l -> let ca = constructors_arity () in ((mkexp loc (Pexp_construct ((mkli sloc (conv_con s) ml), None, ca))), l) | (loc, ml, Ast.ExId (sloc, (Ast.IdLid (_, s)))) :: l -> ((mkexp loc (Pexp_ident (mkli sloc s ml))), l) | (_, [], e) :: l -> ((expr e), l) | _ -> error loc "bad ast in expression") in let (_, e) = List.fold_left (fun (loc_bp, e1) (loc_ep, ml, e2) -> match e2 with | Ast.ExId (sloc, (Ast.IdLid (_, s))) -> let loc = Loc.merge loc_bp loc_ep in (loc, (mkexp loc (Pexp_field (e1, (mkli sloc (conv_lab s) ml))))) | _ -> error (loc_of_expr e2) "lowercase identifier expected") (loc, e) l in e | ExAnt (loc, _) -> error loc "antiquotation not allowed here" | (ExApp (loc, _, _) as f) -> let (f, al) = expr_fa [] f in let al = List.map label_expr al in (match (expr f).pexp_desc with | Pexp_construct (li, None, _) -> let al = List.map snd al in if constructors_arity () then mkexp loc (Pexp_construct (li, (Some (mkexp loc (Pexp_tuple al))), true)) else (let a = match al with | [ a ] -> a | _ -> mkexp loc (Pexp_tuple al) in mkexp loc (Pexp_construct (li, (Some a), false))) | Pexp_variant (s, None) -> let al = List.map snd al in let a = if constructors_arity () then mkexp loc (Pexp_tuple al) else (match al with | [ a ] -> a | _ -> mkexp loc (Pexp_tuple al)) in mkexp loc (Pexp_variant (s, (Some a))) | _ -> mkexp loc (Pexp_apply ((expr f), al))) | ExAre (loc, e1, e2) -> mkexp loc (Pexp_apply ((mkexp loc (Pexp_ident (array_function loc "Array" "get"))), [ ("", (expr e1)); ("", (expr e2)) ])) | ExArr (loc, e) -> mkexp loc (Pexp_array (List.map expr (list_of_expr e []))) | ExAsf loc -> mkexp loc Pexp_assertfalse | ExAss (loc, e, v) -> let e = (match e with | Ast.ExAcc (loc, x, (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> Pexp_apply ((mkexp loc (Pexp_ident (lident_with_loc ":=" loc))), [ ("", (expr x)); ("", (expr v)) ]) | ExAcc (loc, _, _) -> (match (expr e).pexp_desc with | Pexp_field (e, lab) -> Pexp_setfield (e, lab, (expr v)) | _ -> error loc "bad record access") | ExAre (loc, e1, e2) -> Pexp_apply ((mkexp loc (Pexp_ident (array_function loc "Array" "set"))), [ ("", (expr e1)); ("", (expr e2)); ("", (expr v)) ]) | Ast.ExId (_, (Ast.IdLid (lloc, lab))) -> Pexp_setinstvar ((with_loc lab lloc), (expr v)) | ExSte (loc, e1, e2) -> Pexp_apply ((mkexp loc (Pexp_ident (array_function loc "String" "set"))), [ ("", (expr e1)); ("", (expr e2)); ("", (expr v)) ]) | _ -> error loc "bad left part of assignment") in mkexp loc e | ExAsr (loc, e) -> mkexp loc (Pexp_assert (expr e)) | ExChr (loc, s) -> mkexp loc (Pexp_constant (Const_char (char_of_char_token loc s))) | ExCoe (loc, e, t1, t2) -> let t1 = (match t1 with | Ast.TyNil _ -> None | t -> Some (ctyp t)) in mkexp loc (Pexp_constraint ((expr e), t1, (Some (ctyp t2)))) | ExFlo (loc, s) -> mkexp loc (Pexp_constant (Const_float (remove_underscores s))) | ExFor (loc, i, e1, e2, df, el) -> let e3 = ExSeq (loc, el) in mkexp loc (Pexp_for ((with_loc i loc), (expr e1), (expr e2), (mkdirection df), (expr e3))) | Ast.ExFun (loc, (Ast.McArr (_, (PaLab (_, lab, po)), w, e))) -> mkexp loc (Pexp_function (lab, None, [ ((patt_of_lab loc lab po), (when_expr e w)) ])) | Ast.ExFun (loc, (Ast.McArr (_, (PaOlbi (_, lab, p, e1)), w, e2))) -> let lab = paolab lab p in mkexp loc (Pexp_function (("?" ^ lab), (Some (expr e1)), [ ((patt p), (when_expr e2 w)) ])) | Ast.ExFun (loc, (Ast.McArr (_, (PaOlb (_, lab, p)), w, e))) -> let lab = paolab lab p in mkexp loc (Pexp_function (("?" ^ lab), None, [ ((patt_of_lab loc lab p), (when_expr e w)) ])) | ExFun (loc, a) -> mkexp loc (Pexp_function ("", None, (match_case a []))) | ExIfe (loc, e1, e2, e3) -> mkexp loc (Pexp_ifthenelse ((expr e1), (expr e2), (Some (expr e3)))) | ExInt (loc, s) -> let i = (try int_of_string s with | Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int") in mkexp loc (Pexp_constant (Const_int i)) | ExInt32 (loc, s) -> let i32 = (try Int32.of_string s with | Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32") in mkexp loc (Pexp_constant (Const_int32 i32)) | ExInt64 (loc, s) -> let i64 = (try Int64.of_string s with | Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64") in mkexp loc (Pexp_constant (Const_int64 i64)) | ExNativeInt (loc, s) -> let nati = (try Nativeint.of_string s with | Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint") in mkexp loc (Pexp_constant (Const_nativeint nati)) | ExLab (loc, _, _) -> error loc "labeled expression not allowed here" | ExLaz (loc, e) -> mkexp loc (Pexp_lazy (expr e)) | ExLet (loc, rf, bi, e) -> mkexp loc (Pexp_let ((mkrf rf), (binding bi []), (expr e))) | ExLmd (loc, i, me, e) -> mkexp loc (Pexp_letmodule ((with_loc i loc), (module_expr me), (expr e))) | ExMat (loc, e, a) -> mkexp loc (Pexp_match ((expr e), (match_case a []))) | ExNew (loc, id) -> mkexp loc (Pexp_new (long_type_ident id)) | ExObj (loc, po, cfl) -> let p = (match po with | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in let cil = class_str_item cfl [] in mkexp loc (Pexp_object { pcstr_pat = patt p; pcstr_fields = cil; }) | ExOlb (loc, _, _) -> error loc "labeled expression not allowed here" | ExOvr (loc, iel) -> mkexp loc (Pexp_override (mkideexp iel [])) | ExRec (loc, lel, eo) -> (match lel with | Ast.RbNil _ -> error loc "empty record" | _ -> let eo = (match eo with | Ast.ExNil _ -> None | e -> Some (expr e)) in mkexp loc (Pexp_record ((mklabexp lel []), eo))) | ExSeq (_loc, e) -> let rec loop = (function | [] -> expr (Ast.ExId (_loc, (Ast.IdUid (_loc, "()")))) | [ e ] -> expr e | e :: el -> let _loc = Loc.merge (loc_of_expr e) _loc in mkexp _loc (Pexp_sequence ((expr e), (loop el)))) in loop (list_of_expr e []) | ExSnd (loc, e, s) -> mkexp loc (Pexp_send ((expr e), s)) | ExSte (loc, e1, e2) -> mkexp loc (Pexp_apply ((mkexp loc (Pexp_ident (array_function loc "String" "get"))), [ ("", (expr e1)); ("", (expr e2)) ])) | ExStr (loc, s) -> mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s))) | ExTry (loc, e, a) -> mkexp loc (Pexp_try ((expr e), (match_case a []))) | Ast.ExTup (loc, (Ast.ExCom (_, e1, e2))) -> mkexp loc (Pexp_tuple (List.map expr (list_of_expr e1 (list_of_expr e2 [])))) | Ast.ExTup (loc, _) -> error loc "singleton tuple" | ExTyc (loc, e, t) -> mkexp loc (Pexp_constraint ((expr e), (Some (ctyp t)), None)) | Ast.ExId (loc, (Ast.IdUid (_, "()"))) -> mkexp loc (Pexp_construct ((lident_with_loc "()" loc), None, true)) | Ast.ExId (loc, (Ast.IdLid (_, s))) -> mkexp loc (Pexp_ident (lident_with_loc s loc)) | Ast.ExId (loc, (Ast.IdUid (_, s))) -> mkexp loc (Pexp_construct ((lident_with_loc (conv_con s) loc), None, true)) | ExVrn (loc, s) -> mkexp loc (Pexp_variant ((conv_con s), None)) | ExWhi (loc, e1, el) -> let e2 = ExSeq (loc, el) in mkexp loc (Pexp_while ((expr e1), (expr e2))) | Ast.ExOpI (loc, i, e) -> mkexp loc (Pexp_open ((long_uident i), (expr e))) | Ast.ExPkg (loc, (Ast.MeTyc (_, me, pt))) -> mkexp loc (Pexp_constraint (((mkexp loc (Pexp_pack (module_expr me))), (Some (mktyp loc (Ptyp_package (package_type pt)))), None))) | Ast.ExPkg (loc, me) -> mkexp loc (Pexp_pack (module_expr me)) | ExFUN (loc, i, e) -> mkexp loc (Pexp_newtype (i, (expr e))) | Ast.ExCom (loc, _, _) -> error loc "expr, expr: not allowed here" | Ast.ExSem (loc, _, _) -> error loc "expr; expr: not allowed here, use do {...} or [|...|] to surround them" | (ExId (_, _) | ExNil _ as e) -> error (loc_of_expr e) "invalid expr" and patt_of_lab _loc lab = function | Ast.PaNil _ -> patt (Ast.PaId (_loc, (Ast.IdLid (_loc, lab)))) | p -> patt p and expr_of_lab _loc lab = function | Ast.ExNil _ -> expr (Ast.ExId (_loc, (Ast.IdLid (_loc, lab)))) | e -> expr e and label_expr = function | ExLab (loc, lab, eo) -> (lab, (expr_of_lab loc lab eo)) | ExOlb (loc, lab, eo) -> (("?" ^ lab), (expr_of_lab loc lab eo)) | e -> ("", (expr e)) and binding x acc = match x with | Ast.BiAnd (_, x, y) -> binding x (binding y acc) | Ast.BiEq (_loc, (Ast.PaId (sloc, (Ast.IdLid (_, bind_name)))), (Ast.ExTyc (_, e, (TyTypePol (_, vs, ty))))) -> let rec id_to_string x = (match x with | Ast.TyId (_, (Ast.IdLid (_, x))) -> [ x ] | Ast.TyApp (_, x, y) -> (id_to_string x) @ (id_to_string y) | _ -> assert false) in let vars = id_to_string vs in let ampersand_vars = List.map (fun x -> "&" ^ x) vars in let ty' = varify_constructors vars (ctyp ty) in let mkexp = mkexp _loc in let mkpat = mkpat _loc in let e = mkexp (Pexp_constraint ((expr e), (Some (ctyp ty)), None)) in let rec mk_newtypes x = (match x with | [ newtype ] -> mkexp (Pexp_newtype ((newtype, e))) | newtype :: newtypes -> mkexp (Pexp_newtype ((newtype, (mk_newtypes newtypes)))) | [] -> assert false) in let pat = mkpat (Ppat_constraint (((mkpat (Ppat_var (with_loc bind_name sloc))), (mktyp _loc (Ptyp_poly (ampersand_vars, ty')))))) in let e = mk_newtypes vars in (pat, e) :: acc | Ast.BiEq (_loc, p, (Ast.ExTyc (_, e, (Ast.TyPol (_, vs, ty))))) -> ((patt (Ast.PaTyc (_loc, p, (Ast.TyPol (_loc, vs, ty))))), (expr e)) :: acc | Ast.BiEq (_, p, e) -> ((patt p), (expr e)) :: acc | Ast.BiNil _ -> acc | _ -> assert false and match_case x acc = match x with | Ast.McOr (_, x, y) -> match_case x (match_case y acc) | Ast.McArr (_, p, w, e) -> ((patt p), (when_expr e w)) :: acc | Ast.McNil _ -> acc | _ -> assert false and when_expr e w = match w with | Ast.ExNil _ -> expr e | w -> mkexp (loc_of_expr w) (Pexp_when ((expr w), (expr e))) and mklabexp x acc = match x with | Ast.RbSem (_, x, y) -> mklabexp x (mklabexp y acc) | Ast.RbEq (_, i, e) -> ((ident ~conv_lid: conv_lab i), (expr e)) :: acc | _ -> assert false and mkideexp x acc = match x with | Ast.RbNil _ -> acc | Ast.RbSem (_, x, y) -> mkideexp x (mkideexp y acc) | Ast.RbEq (_, (Ast.IdLid (sloc, s)), e) -> ((with_loc s sloc), (expr e)) :: acc | _ -> assert false and mktype_decl x acc = match x with | Ast.TyAnd (_, x, y) -> mktype_decl x (mktype_decl y acc) | Ast.TyDcl (cloc, c, tl, td, cl) -> let cl = List.map (fun (t1, t2) -> let loc = Loc.merge (loc_of_ctyp t1) (loc_of_ctyp t2) in ((ctyp t1), (ctyp t2), (mkloc loc))) cl in ((with_loc c cloc), (type_decl (List.fold_right optional_type_parameters tl []) cl td cloc)) :: acc | _ -> assert false and module_type = function | Ast.MtNil loc -> error loc "abstract/nil module type not allowed here" | Ast.MtId (loc, i) -> mkmty loc (Pmty_ident (long_uident i)) | Ast.MtFun (loc, n, nt, mt) -> mkmty loc (Pmty_functor ((with_loc n loc), (module_type nt), (module_type mt))) | Ast.MtQuo (loc, _) -> error loc "module type variable not allowed here" | Ast.MtSig (loc, sl) -> mkmty loc (Pmty_signature (sig_item sl [])) | Ast.MtWit (loc, mt, wc) -> mkmty loc (Pmty_with ((module_type mt), (mkwithc wc []))) | Ast.MtOf (loc, me) -> mkmty loc (Pmty_typeof (module_expr me)) | Ast.MtAnt (_, _) -> assert false and sig_item s l = match s with | Ast.SgNil _ -> l | SgCls (loc, cd) -> (mksig loc (Psig_class (List.map class_info_class_type (list_of_class_type cd [])))) :: l | SgClt (loc, ctd) -> (mksig loc (Psig_class_type (List.map class_info_class_type (list_of_class_type ctd [])))) :: l | Ast.SgSem (_, sg1, sg2) -> sig_item sg1 (sig_item sg2 l) | SgDir (_, _, _) -> l | Ast.SgExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s))))) -> (mksig loc (Psig_exception ((with_loc (conv_con s) loc), []))) :: l | Ast.SgExc (loc, (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t))) -> (mksig loc (Psig_exception ((with_loc (conv_con s) loc), (List.map ctyp (list_of_ctyp t []))))) :: l | SgExc (_, _) -> assert false | SgExt (loc, n, t, sl) -> (mksig loc (Psig_value ((with_loc n loc), (mkvalue_desc loc t (list_of_meta_list sl))))) :: l | SgInc (loc, mt) -> (mksig loc (Psig_include (module_type mt))) :: l | SgMod (loc, n, mt) -> (mksig loc (Psig_module ((with_loc n loc), (module_type mt)))) :: l | SgRecMod (loc, mb) -> (mksig loc (Psig_recmodule (module_sig_binding mb []))) :: l | SgMty (loc, n, mt) -> let si = (match mt with | MtQuo (_, _) -> Pmodtype_abstract | _ -> Pmodtype_manifest (module_type mt)) in (mksig loc (Psig_modtype ((with_loc n loc), si))) :: l | SgOpn (loc, id) -> (mksig loc (Psig_open (long_uident id))) :: l | SgTyp (loc, tdl) -> (mksig loc (Psig_type (mktype_decl tdl []))) :: l | SgVal (loc, n, t) -> (mksig loc (Psig_value ((with_loc n loc), (mkvalue_desc loc t [])))) :: l | Ast.SgAnt (loc, _) -> error loc "antiquotation in sig_item" and module_sig_binding x acc = match x with | Ast.MbAnd (_, x, y) -> module_sig_binding x (module_sig_binding y acc) | Ast.MbCol (loc, s, mt) -> ((with_loc s loc), (module_type mt)) :: acc | _ -> assert false and module_str_binding x acc = match x with | Ast.MbAnd (_, x, y) -> module_str_binding x (module_str_binding y acc) | Ast.MbColEq (loc, s, mt, me) -> ((with_loc s loc), (module_type mt), (module_expr me)) :: acc | _ -> assert false and module_expr = function | Ast.MeNil loc -> error loc "nil module expression" | Ast.MeId (loc, i) -> mkmod loc (Pmod_ident (long_uident i)) | Ast.MeApp (loc, me1, me2) -> mkmod loc (Pmod_apply ((module_expr me1), (module_expr me2))) | Ast.MeFun (loc, n, mt, me) -> mkmod loc (Pmod_functor ((with_loc n loc), (module_type mt), (module_expr me))) | Ast.MeStr (loc, sl) -> mkmod loc (Pmod_structure (str_item sl [])) | Ast.MeTyc (loc, me, mt) -> mkmod loc (Pmod_constraint ((module_expr me), (module_type mt))) | Ast.MePkg (loc, (Ast.ExTyc (_, e, (Ast.TyPkg (_, pt))))) -> mkmod loc (Pmod_unpack (mkexp loc (Pexp_constraint (((expr e), (Some (mktyp loc (Ptyp_package (package_type pt)))), None))))) | Ast.MePkg (loc, e) -> mkmod loc (Pmod_unpack (expr e)) | Ast.MeAnt (loc, _) -> error loc "antiquotation in module_expr" and str_item s l = match s with | Ast.StNil _ -> l | StCls (loc, cd) -> (mkstr loc (Pstr_class (List.map class_info_class_expr (list_of_class_expr cd [])))) :: l | StClt (loc, ctd) -> (mkstr loc (Pstr_class_type (List.map class_info_class_type (list_of_class_type ctd [])))) :: l | Ast.StSem (_, st1, st2) -> str_item st1 (str_item st2 l) | StDir (_, _, _) -> l | Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), Ast. ONone) -> (mkstr loc (Pstr_exception ((with_loc (conv_con s) loc), []))) :: l | Ast.StExc (loc, (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t)), Ast. ONone) -> (mkstr loc (Pstr_exception ((with_loc (conv_con s) loc), (List.map ctyp (list_of_ctyp t []))))) :: l | Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), (Ast.OSome i)) -> (mkstr loc (Pstr_exn_rebind ((with_loc (conv_con s) loc), (ident i)))) :: l | Ast.StExc (loc, (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, _)))), _)), (Ast.OSome _)) -> error loc "type in exception alias" | StExc (_, _, _) -> assert false | StExp (loc, e) -> (mkstr loc (Pstr_eval (expr e))) :: l | StExt (loc, n, t, sl) -> (mkstr loc (Pstr_primitive ((with_loc n loc), (mkvalue_desc loc t (list_of_meta_list sl))))) :: l | StInc (loc, me) -> (mkstr loc (Pstr_include (module_expr me))) :: l | StMod (loc, n, me) -> (mkstr loc (Pstr_module ((with_loc n loc), (module_expr me)))) :: l | StRecMod (loc, mb) -> (mkstr loc (Pstr_recmodule (module_str_binding mb []))) :: l | StMty (loc, n, mt) -> (mkstr loc (Pstr_modtype ((with_loc n loc), (module_type mt)))) :: l | StOpn (loc, id) -> (mkstr loc (Pstr_open (long_uident id))) :: l | StTyp (loc, tdl) -> (mkstr loc (Pstr_type (mktype_decl tdl []))) :: l | StVal (loc, rf, bi) -> (mkstr loc (Pstr_value ((mkrf rf), (binding bi [])))) :: l | Ast.StAnt (loc, _) -> error loc "antiquotation in str_item" and class_type = function | CtCon (loc, ViNil, id, tl) -> mkcty loc (Pcty_constr ((long_class_ident id), (List.map ctyp (list_of_opt_ctyp tl [])))) | CtFun (loc, (TyLab (_, lab, t)), ct) -> mkcty loc (Pcty_fun (lab, (ctyp t), (class_type ct))) | CtFun (loc, (TyOlb (loc1, lab, t)), ct) -> let t = TyApp (loc1, (predef_option loc1), t) in mkcty loc (Pcty_fun (("?" ^ lab), (ctyp t), (class_type ct))) | CtFun (loc, t, ct) -> mkcty loc (Pcty_fun ("", (ctyp t), (class_type ct))) | CtSig (loc, t_o, ctfl) -> let t = (match t_o with | Ast.TyNil _ -> Ast.TyAny loc | t -> t) in let cil = class_sig_item ctfl [] in mkcty loc (Pcty_signature { pcsig_self = ctyp t; pcsig_fields = cil; pcsig_loc = mkloc loc; }) | CtCon (loc, _, _, _) -> error loc "invalid virtual class inside a class type" | CtAnt (_, _) | CtEq (_, _, _) | CtCol (_, _, _) | CtAnd (_, _, _) | CtNil _ -> assert false and class_info_class_expr ci = match ci with | CeEq (_, (CeCon (loc, vir, (IdLid (nloc, name)), params)), ce) -> let (loc_params, (params, variance)) = (match params with | Ast.TyNil _ -> (loc, ([], [])) | t -> ((loc_of_ctyp t), (List.split (class_parameters t [])))) in { pci_virt = mkvirtual vir; pci_params = (params, (mkloc loc_params)); pci_name = with_loc name nloc; pci_expr = class_expr ce; pci_loc = mkloc loc; pci_variance = variance; } | ce -> error (loc_of_class_expr ce) "bad class definition" and class_info_class_type ci = match ci with | CtEq (_, (CtCon (loc, vir, (IdLid (nloc, name)), params)), ct) | CtCol (_, (CtCon (loc, vir, (IdLid (nloc, name)), params)), ct) -> let (loc_params, (params, variance)) = (match params with | Ast.TyNil _ -> (loc, ([], [])) | t -> ((loc_of_ctyp t), (List.split (class_parameters t [])))) in { pci_virt = mkvirtual vir; pci_params = (params, (mkloc loc_params)); pci_name = with_loc name nloc; pci_expr = class_type ct; pci_loc = mkloc loc; pci_variance = variance; } | ct -> error (loc_of_class_type ct) "bad class/class type declaration/definition" and class_sig_item c l = match c with | Ast.CgNil _ -> l | CgCtr (loc, t1, t2) -> (mkctf loc (Pctf_cstr (((ctyp t1), (ctyp t2))))) :: l | Ast.CgSem (_, csg1, csg2) -> class_sig_item csg1 (class_sig_item csg2 l) | CgInh (loc, ct) -> (mkctf loc (Pctf_inher (class_type ct))) :: l | CgMth (loc, s, pf, t) -> (mkctf loc (Pctf_meth ((s, (mkprivate pf), (mkpolytype (ctyp t)))))) :: l | CgVal (loc, s, b, v, t) -> (mkctf loc (Pctf_val ((s, (mkmutable b), (mkvirtual v), (ctyp t))))) :: l | CgVir (loc, s, b, t) -> (mkctf loc (Pctf_virt ((s, (mkprivate b), (mkpolytype (ctyp t)))))) :: l | CgAnt (_, _) -> assert false and class_expr = function | (CeApp (loc, _, _) as c) -> let (ce, el) = class_expr_fa [] c in let el = List.map label_expr el in mkcl loc (Pcl_apply ((class_expr ce), el)) | CeCon (loc, ViNil, id, tl) -> mkcl loc (Pcl_constr ((long_class_ident id), (List.map ctyp (list_of_opt_ctyp tl [])))) | CeFun (loc, (PaLab (_, lab, po)), ce) -> mkcl loc (Pcl_fun (lab, None, (patt_of_lab loc lab po), (class_expr ce))) | CeFun (loc, (PaOlbi (_, lab, p, e)), ce) -> let lab = paolab lab p in mkcl loc (Pcl_fun (("?" ^ lab), (Some (expr e)), (patt p), (class_expr ce))) | CeFun (loc, (PaOlb (_, lab, p)), ce) -> let lab = paolab lab p in mkcl loc (Pcl_fun (("?" ^ lab), None, (patt_of_lab loc lab p), (class_expr ce))) | CeFun (loc, p, ce) -> mkcl loc (Pcl_fun ("", None, (patt p), (class_expr ce))) | CeLet (loc, rf, bi, ce) -> mkcl loc (Pcl_let ((mkrf rf), (binding bi []), (class_expr ce))) | CeStr (loc, po, cfl) -> let p = (match po with | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in let cil = class_str_item cfl [] in mkcl loc (Pcl_structure { pcstr_pat = patt p; pcstr_fields = cil; }) | CeTyc (loc, ce, ct) -> mkcl loc (Pcl_constraint ((class_expr ce), (class_type ct))) | CeCon (loc, _, _, _) -> error loc "invalid virtual class inside a class expression" | CeAnt (_, _) | CeEq (_, _, _) | CeAnd (_, _, _) | CeNil _ -> assert false and class_str_item c l = match c with | CrNil _ -> l | CrCtr (loc, t1, t2) -> (mkcf loc (Pcf_constr (((ctyp t1), (ctyp t2))))) :: l | Ast.CrSem (_, cst1, cst2) -> class_str_item cst1 (class_str_item cst2 l) | CrInh (loc, ov, ce, pb) -> let opb = if pb = "" then None else Some pb in (mkcf loc (Pcf_inher ((override_flag loc ov), (class_expr ce), opb))) :: l | CrIni (loc, e) -> (mkcf loc (Pcf_init (expr e))) :: l | CrMth (loc, s, ov, pf, e, t) -> let t = (match t with | Ast.TyNil _ -> None | t -> Some (mkpolytype (ctyp t))) in let e = mkexp loc (Pexp_poly ((expr e), t)) in (mkcf loc (Pcf_meth (((with_loc s loc), (mkprivate pf), (override_flag loc ov), e)))) :: l | CrVal (loc, s, ov, mf, e) -> (mkcf loc (Pcf_val (((with_loc s loc), (mkmutable mf), (override_flag loc ov), (expr e))))) :: l | CrVir (loc, s, pf, t) -> (mkcf loc (Pcf_virt (((with_loc s loc), (mkprivate pf), (mkpolytype (ctyp t)))))) :: l | CrVvr (loc, s, mf, t) -> (mkcf loc (Pcf_valvirt (((with_loc s loc), (mkmutable mf), (ctyp t))))) :: l | CrAnt (_, _) -> assert false let sig_item ast = sig_item ast [] let str_item ast = str_item ast [] let directive = function | Ast.ExNil _ -> Pdir_none | ExStr (_, s) -> Pdir_string s | ExInt (_, i) -> Pdir_int (int_of_string i) | Ast.ExId (_, (Ast.IdUid (_, "True"))) -> Pdir_bool true | Ast.ExId (_, (Ast.IdUid (_, "False"))) -> Pdir_bool false | e -> Pdir_ident (ident_noloc (ident_of_expr e)) let phrase = function | StDir (_, d, dp) -> Ptop_dir (d, (directive dp)) | si -> Ptop_def (str_item si) end end module CleanAst = struct module Make (Ast : Sig.Camlp4Ast) = struct class clean_ast = object inherit Ast.map as super method with_constr = fun wc -> match super#with_constr wc with | Ast.WcAnd (_, (Ast.WcNil _), wc) | Ast.WcAnd (_, wc, (Ast.WcNil _)) -> wc | wc -> wc method expr = fun e -> match super#expr e with | Ast.ExLet (_, _, (Ast.BiNil _), e) | Ast.ExRec (_, (Ast.RbNil _), e) | Ast.ExCom (_, (Ast.ExNil _), e) | Ast.ExCom (_, e, (Ast.ExNil _)) | Ast.ExSem (_, (Ast.ExNil _), e) | Ast.ExSem (_, e, (Ast.ExNil _)) -> e | e -> e method patt = fun p -> match super#patt p with | Ast.PaAli (_, p, (Ast.PaNil _)) | Ast.PaOrp (_, (Ast.PaNil _), p) | Ast.PaOrp (_, p, (Ast.PaNil _)) | Ast.PaCom (_, (Ast.PaNil _), p) | Ast.PaCom (_, p, (Ast.PaNil _)) | Ast.PaSem (_, (Ast.PaNil _), p) | Ast.PaSem (_, p, (Ast.PaNil _)) -> p | p -> p method match_case = fun mc -> match super#match_case mc with | Ast.McOr (_, (Ast.McNil _), mc) | Ast.McOr (_, mc, (Ast.McNil _)) -> mc | mc -> mc method binding = fun bi -> match super#binding bi with | Ast.BiAnd (_, (Ast.BiNil _), bi) | Ast.BiAnd (_, bi, (Ast.BiNil _)) -> bi | bi -> bi method rec_binding = fun rb -> match super#rec_binding rb with | Ast.RbSem (_, (Ast.RbNil _), bi) | Ast.RbSem (_, bi, (Ast.RbNil _)) -> bi | bi -> bi method module_binding = fun mb -> match super#module_binding mb with | Ast.MbAnd (_, (Ast.MbNil _), mb) | Ast.MbAnd (_, mb, (Ast.MbNil _)) -> mb | mb -> mb method ctyp = fun t -> match super#ctyp t with | Ast.TyPol (_, (Ast.TyNil _), t) | Ast.TyAli (_, (Ast.TyNil _), t) | Ast.TyAli (_, t, (Ast.TyNil _)) | Ast.TyArr (_, t, (Ast.TyNil _)) | Ast.TyArr (_, (Ast.TyNil _), t) | Ast.TyOr (_, (Ast.TyNil _), t) | Ast.TyOr (_, t, (Ast.TyNil _)) | Ast.TyOf (_, t, (Ast.TyNil _)) | Ast.TyAnd (_, (Ast.TyNil _), t) | Ast.TyAnd (_, t, (Ast.TyNil _)) | Ast.TySem (_, t, (Ast.TyNil _)) | Ast.TySem (_, (Ast.TyNil _), t) | Ast.TyCom (_, (Ast.TyNil _), t) | Ast.TyCom (_, t, (Ast.TyNil _)) | Ast.TyAmp (_, t, (Ast.TyNil _)) | Ast.TyAmp (_, (Ast.TyNil _), t) | Ast.TySta (_, (Ast.TyNil _), t) | Ast.TySta (_, t, (Ast.TyNil _)) -> t | t -> t method sig_item = fun sg -> match super#sig_item sg with | Ast.SgSem (_, (Ast.SgNil _), sg) | Ast.SgSem (_, sg, (Ast.SgNil _)) -> sg | Ast.SgTyp (loc, (Ast.TyNil _)) -> Ast.SgNil loc | sg -> sg method str_item = fun st -> match super#str_item st with | Ast.StSem (_, (Ast.StNil _), st) | Ast.StSem (_, st, (Ast.StNil _)) -> st | Ast.StTyp (loc, (Ast.TyNil _)) -> Ast.StNil loc | Ast.StVal (loc, _, (Ast.BiNil _)) -> Ast.StNil loc | st -> st method module_type = fun mt -> match super#module_type mt with | Ast.MtWit (_, mt, (Ast.WcNil _)) -> mt | mt -> mt method class_expr = fun ce -> match super#class_expr ce with | Ast.CeAnd (_, (Ast.CeNil _), ce) | Ast.CeAnd (_, ce, (Ast.CeNil _)) -> ce | ce -> ce method class_type = fun ct -> match super#class_type ct with | Ast.CtAnd (_, (Ast.CtNil _), ct) | Ast.CtAnd (_, ct, (Ast.CtNil _)) -> ct | ct -> ct method class_sig_item = fun csg -> match super#class_sig_item csg with | Ast.CgSem (_, (Ast.CgNil _), csg) | Ast.CgSem (_, csg, (Ast.CgNil _)) -> csg | csg -> csg method class_str_item = fun cst -> match super#class_str_item cst with | Ast.CrSem (_, (Ast.CrNil _), cst) | Ast.CrSem (_, cst, (Ast.CrNil _)) -> cst | cst -> cst end end end module CommentFilter : sig module Make (Token : Sig.Camlp4Token) : sig open Token type t val mk : unit -> t val define : Token.Filter.t -> t -> unit val filter : t -> (Token.t * Loc.t) Stream.t -> (Token.t * Loc.t) Stream.t val take_list : t -> (string * Loc.t) list val take_stream : t -> (string * Loc.t) Stream.t end end = struct module Make (Token : Sig.Camlp4Token) = struct open Token type t = (((string * Loc.t) Stream.t) * ((string * Loc.t) Queue.t)) let mk () = let q = Queue.create () in let f _ = try Some (Queue.take q) with | Queue.Empty -> None in ((Stream.from f), q) let filter (_, q) = let rec self (__strm : _ Stream.t) = match Stream.peek __strm with | Some ((Sig.COMMENT x, loc)) -> (Stream.junk __strm; let xs = __strm in (Queue.add (x, loc) q; self xs)) | Some x -> (Stream.junk __strm; let xs = __strm in Stream.icons x (Stream.slazy (fun _ -> self xs))) | _ -> Stream.sempty in self let take_list (_, q) = let rec self accu = if Queue.is_empty q then accu else self ((Queue.take q) :: accu) in self [] let take_stream = fst let define token_fiter comments_strm = Token.Filter.define_filter token_fiter (fun previous strm -> previous (filter comments_strm strm)) end end module DynLoader : sig include Sig.DynLoader end = struct type t = string Queue.t exception Error of string * string let include_dir x y = Queue.add y x let fold_load_path x f acc = Queue.fold (fun x y -> f y x) acc x let mk ?(ocaml_stdlib = true) ?(camlp4_stdlib = true) () = let q = Queue.create () in (if ocaml_stdlib then include_dir q Camlp4_config.ocaml_standard_library else (); if camlp4_stdlib then (include_dir q Camlp4_config.camlp4_standard_library; include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Parsers"); include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Printers"); include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Filters")) else (); include_dir q "."; q) let find_in_path x name = if not (Filename.is_implicit name) then if Sys.file_exists name then name else raise Not_found else (let res = fold_load_path x (fun dir -> function | None -> let fullname = Filename.concat dir name in if Sys.file_exists fullname then Some fullname else None | x -> x) None in match res with | None -> raise Not_found | Some x -> x) let load = let _initialized = ref false in fun _path file -> (if not !_initialized then (try (Dynlink.init (); Dynlink.allow_unsafe_modules true; _initialized := true) with | Dynlink.Error e -> raise (Error ("Camlp4's dynamic loader initialization", (Dynlink.error_message e)))) else (); let fname = try find_in_path _path file with | Not_found -> raise (Error (file, "file not found in path")) in try Dynlink.loadfile fname with | Dynlink.Error e -> raise (Error (fname, (Dynlink.error_message e)))) let is_native = Dynlink.is_native end module EmptyError : sig include Sig.Error end = struct type t = unit exception E of t let print _ = assert false let to_string _ = assert false end module EmptyPrinter : sig module Make (Ast : Sig.Ast) : Sig.Printer(Ast).S end = struct module Make (Ast : Sig.Ast) = struct let print_interf ?input_file:(_) ?output_file:(_) _ = failwith "No interface printer" let print_implem ?input_file:(_) ?output_file:(_) _ = failwith "No implementation printer" end end module FreeVars : sig module Make (Ast : Sig.Camlp4Ast) : sig module S : Set.S with type elt = string val fold_binding_vars : (string -> 'accu -> 'accu) -> Ast.binding -> 'accu -> 'accu class ['accu] c_fold_pattern_vars : (string -> 'accu -> 'accu) -> 'accu -> object inherit Ast.fold val acc : 'accu method acc : 'accu end val fold_pattern_vars : (string -> 'accu -> 'accu) -> Ast.patt -> 'accu -> 'accu class ['accu] fold_free_vars : (string -> 'accu -> 'accu) -> ?env_init: S.t -> 'accu -> object ('self_type) inherit Ast.fold val free : 'accu val env : S.t method free : 'accu method set_env : S.t -> 'self_type method add_atom : string -> 'self_type method add_patt : Ast.patt -> 'self_type method add_binding : Ast.binding -> 'self_type end val free_vars : S.t -> Ast.expr -> S.t end end = struct module Make (Ast : Sig.Camlp4Ast) = struct module S = Set.Make(String) class ['accu] c_fold_pattern_vars f init = object inherit Ast.fold as super val acc = init method acc : 'accu = acc method patt = function | Ast.PaId (_, (Ast.IdLid (_, s))) | Ast.PaLab (_, s, (Ast.PaNil _)) | Ast.PaOlb (_, s, (Ast.PaNil _)) -> {< acc = f s acc; >} | p -> super#patt p end let fold_pattern_vars f p init = ((new c_fold_pattern_vars f init)#patt p)#acc let rec fold_binding_vars f bi acc = match bi with | Ast.BiAnd (_, bi1, bi2) -> fold_binding_vars f bi1 (fold_binding_vars f bi2 acc) | Ast.BiEq (_, p, _) -> fold_pattern_vars f p acc | Ast.BiNil _ -> acc | Ast.BiAnt (_, _) -> assert false class ['accu] fold_free_vars (f : string -> 'accu -> 'accu) ?(env_init = S.empty) free_init = object (o) inherit Ast.fold as super val free = (free_init : 'accu) val env = (env_init : S.t) method free = free method set_env = fun env -> {< env = env; >} method add_atom = fun s -> {< env = S.add s env; >} method add_patt = fun p -> {< env = fold_pattern_vars S.add p env; >} method add_binding = fun bi -> {< env = fold_binding_vars S.add bi env; >} method expr = function | Ast.ExId (_, (Ast.IdLid (_, s))) | Ast.ExLab (_, s, (Ast.ExNil _)) | Ast.ExOlb (_, s, (Ast.ExNil _)) -> if S.mem s env then o else {< free = f s free; >} | Ast.ExLet (_, Ast.ReNil, bi, e) -> (((o#add_binding bi)#expr e)#set_env env)#binding bi | Ast.ExLet (_, Ast.ReRecursive, bi, e) -> (((o#add_binding bi)#expr e)#binding bi)#set_env env | Ast.ExFor (_, s, e1, e2, _, e3) -> ((((o#expr e1)#expr e2)#add_atom s)#expr e3)#set_env env | Ast.ExId (_, _) | Ast.ExNew (_, _) -> o | Ast.ExObj (_, p, cst) -> ((o#add_patt p)#class_str_item cst)#set_env env | e -> super#expr e method match_case = function | Ast.McArr (_, p, e1, e2) -> (((o#add_patt p)#expr e1)#expr e2)#set_env env | m -> super#match_case m method str_item = function | Ast.StExt (_, s, t, _) -> (o#ctyp t)#add_atom s | Ast.StVal (_, Ast.ReNil, bi) -> (o#binding bi)#add_binding bi | Ast.StVal (_, Ast.ReRecursive, bi) -> (o#add_binding bi)#binding bi | st -> super#str_item st method class_expr = function | Ast.CeFun (_, p, ce) -> ((o#add_patt p)#class_expr ce)#set_env env | Ast.CeLet (_, Ast.ReNil, bi, ce) -> (((o#binding bi)#add_binding bi)#class_expr ce)#set_env env | Ast.CeLet (_, Ast.ReRecursive, bi, ce) -> (((o#add_binding bi)#binding bi)#class_expr ce)#set_env env | Ast.CeStr (_, p, cst) -> ((o#add_patt p)#class_str_item cst)#set_env env | ce -> super#class_expr ce method class_str_item = function | (Ast.CrInh (_, _, _, "") as cst) -> super#class_str_item cst | Ast.CrInh (_, _, ce, s) -> (o#class_expr ce)#add_atom s | Ast.CrVal (_, s, _, _, e) -> (o#expr e)#add_atom s | Ast.CrVvr (_, s, _, t) -> (o#ctyp t)#add_atom s | cst -> super#class_str_item cst method module_expr = function | Ast.MeStr (_, st) -> (o#str_item st)#set_env env | me -> super#module_expr me end let free_vars env_init e = let fold = new fold_free_vars S.add ~env_init S.empty in (fold#expr e)#free end end module Grammar = struct module Structure = struct open Sig.Grammar module type S = sig module Loc : Sig.Loc module Token : Sig.Token with module Loc = Loc module Lexer : Sig.Lexer with module Loc = Loc and module Token = Token module Action : Sig.Grammar.Action type gram = { gfilter : Token.Filter.t; gkeywords : (string, int ref) Hashtbl.t; glexer : Loc.t -> char Stream.t -> (Token.t * Loc.t) Stream.t; warning_verbose : bool ref; error_verbose : bool ref } type token_info = { prev_loc : Loc.t; cur_loc : Loc.t; prev_loc_only : bool } type token_stream = (Token.t * token_info) Stream.t type efun = token_stream -> Action.t type token_pattern = ((Token.t -> bool) * string) type internal_entry = { egram : gram; ename : string; mutable estart : int -> efun; mutable econtinue : int -> Loc.t -> Action.t -> efun; mutable edesc : desc } and desc = | Dlevels of level list | Dparser of (token_stream -> Action.t) and level = { assoc : assoc; lname : string option; lsuffix : tree; lprefix : tree } and symbol = | Smeta of string * symbol list * Action.t | Snterm of internal_entry | Snterml of internal_entry * string | Slist0 of symbol | Slist0sep of symbol * symbol | Slist1 of symbol | Slist1sep of symbol * symbol | Sopt of symbol | Stry of symbol | Sself | Snext | Stoken of token_pattern | Skeyword of string | Stree of tree and tree = | Node of node | LocAct of Action.t * Action.t list | DeadEnd and node = { node : symbol; son : tree; brother : tree } type production_rule = ((symbol list) * Action.t) type single_extend_statment = ((string option) * (assoc option) * (production_rule list)) type extend_statment = ((position option) * (single_extend_statment list)) type delete_statment = symbol list type ('a, 'b, 'c) fold = internal_entry -> symbol list -> ('a Stream.t -> 'b) -> 'a Stream.t -> 'c type ('a, 'b, 'c) foldsep = internal_entry -> symbol list -> ('a Stream.t -> 'b) -> ('a Stream.t -> unit) -> 'a Stream.t -> 'c val get_filter : gram -> Token.Filter.t val using : gram -> string -> unit val removing : gram -> string -> unit end module Make (Lexer : Sig.Lexer) = struct module Loc = Lexer.Loc module Token = Lexer.Token module Action : Sig.Grammar.Action = struct type t = Obj.t let mk = Obj.repr let get = Obj.obj let getf = Obj.obj let getf2 = Obj.obj end module Lexer = Lexer type gram = { gfilter : Token.Filter.t; gkeywords : (string, int ref) Hashtbl.t; glexer : Loc.t -> char Stream.t -> (Token.t * Loc.t) Stream.t; warning_verbose : bool ref; error_verbose : bool ref } type token_info = { prev_loc : Loc.t; cur_loc : Loc.t; prev_loc_only : bool } type token_stream = (Token.t * token_info) Stream.t type efun = token_stream -> Action.t type token_pattern = ((Token.t -> bool) * string) type internal_entry = { egram : gram; ename : string; mutable estart : int -> efun; mutable econtinue : int -> Loc.t -> Action.t -> efun; mutable edesc : desc } and desc = | Dlevels of level list | Dparser of (token_stream -> Action.t) and level = { assoc : assoc; lname : string option; lsuffix : tree; lprefix : tree } and symbol = | Smeta of string * symbol list * Action.t | Snterm of internal_entry | Snterml of internal_entry * string | Slist0 of symbol | Slist0sep of symbol * symbol | Slist1 of symbol | Slist1sep of symbol * symbol | Sopt of symbol | Stry of symbol | Sself | Snext | Stoken of token_pattern | Skeyword of string | Stree of tree and tree = | Node of node | LocAct of Action.t * Action.t list | DeadEnd and node = { node : symbol; son : tree; brother : tree } type production_rule = ((symbol list) * Action.t) type single_extend_statment = ((string option) * (assoc option) * (production_rule list)) type extend_statment = ((position option) * (single_extend_statment list)) type delete_statment = symbol list type ('a, 'b, 'c) fold = internal_entry -> symbol list -> ('a Stream.t -> 'b) -> 'a Stream.t -> 'c type ('a, 'b, 'c) foldsep = internal_entry -> symbol list -> ('a Stream.t -> 'b) -> ('a Stream.t -> unit) -> 'a Stream.t -> 'c let get_filter g = g.gfilter let token_location r = r.cur_loc type 'a not_filtered = 'a let using { gkeywords = table; gfilter = filter } kwd = let r = try Hashtbl.find table kwd with | Not_found -> let r = ref 0 in (Hashtbl.add table kwd r; r) in (Token.Filter.keyword_added filter kwd (!r = 0); incr r) let removing { gkeywords = table; gfilter = filter } kwd = let r = Hashtbl.find table kwd in let () = decr r in if !r = 0 then (Token.Filter.keyword_removed filter kwd; Hashtbl.remove table kwd) else () end end module Search = struct module Make (Structure : Structure.S) = struct open Structure let tree_in_entry prev_symb tree = function | Dlevels levels -> let rec search_levels = (function | [] -> tree | level :: levels -> (match search_level level with | Some tree -> tree | None -> search_levels levels)) and search_level level = (match search_tree level.lsuffix with | Some t -> Some (Node { node = Sself; son = t; brother = DeadEnd; }) | None -> search_tree level.lprefix) and search_tree t = if (tree <> DeadEnd) && (t == tree) then Some t else (match t with | Node n -> (match search_symbol n.node with | Some symb -> Some (Node { node = symb; son = n.son; brother = DeadEnd; }) | None -> (match search_tree n.son with | Some t -> Some (Node { node = n.node; son = t; brother = DeadEnd; }) | None -> search_tree n.brother)) | LocAct (_, _) | DeadEnd -> None) and search_symbol symb = (match symb with | Snterm _ | Snterml (_, _) | Slist0 _ | Slist0sep (_, _) | Slist1 _ | Slist1sep (_, _) | Sopt _ | Stry _ | Stoken _ | Stree _ | Skeyword _ when symb == prev_symb -> Some symb | Slist0 symb -> (match search_symbol symb with | Some symb -> Some (Slist0 symb) | None -> None) | Slist0sep (symb, sep) -> (match search_symbol symb with | Some symb -> Some (Slist0sep (symb, sep)) | None -> (match search_symbol sep with | Some sep -> Some (Slist0sep (symb, sep)) | None -> None)) | Slist1 symb -> (match search_symbol symb with | Some symb -> Some (Slist1 symb) | None -> None) | Slist1sep (symb, sep) -> (match search_symbol symb with | Some symb -> Some (Slist1sep (symb, sep)) | None -> (match search_symbol sep with | Some sep -> Some (Slist1sep (symb, sep)) | None -> None)) | Sopt symb -> (match search_symbol symb with | Some symb -> Some (Sopt symb) | None -> None) | Stry symb -> (match search_symbol symb with | Some symb -> Some (Stry symb) | None -> None) | Stree t -> (match search_tree t with | Some t -> Some (Stree t) | None -> None) | _ -> None) in search_levels levels | Dparser _ -> tree end end module Tools = struct let get_prev_loc_only = ref false module Make (Structure : Structure.S) = struct open Structure let empty_entry ename _ = raise (Stream.Error ("entry [" ^ (ename ^ "] is empty"))) let rec stream_map f (__strm : _ Stream.t) = match Stream.peek __strm with | Some x -> (Stream.junk __strm; let strm = __strm in Stream.lcons (fun _ -> f x) (Stream.slazy (fun _ -> stream_map f strm))) | _ -> Stream.sempty let keep_prev_loc strm = match Stream.peek strm with | None -> Stream.sempty | Some ((tok0, init_loc)) -> let rec go prev_loc strm1 = if !get_prev_loc_only then Stream.lcons (fun _ -> (tok0, { prev_loc = prev_loc; cur_loc = prev_loc; prev_loc_only = true; })) (Stream.slazy (fun _ -> go prev_loc strm1)) else (let (__strm : _ Stream.t) = strm1 in match Stream.peek __strm with | Some ((tok, cur_loc)) -> (Stream.junk __strm; let strm = __strm in Stream.lcons (fun _ -> (tok, { prev_loc = prev_loc; cur_loc = cur_loc; prev_loc_only = false; })) (Stream.slazy (fun _ -> go cur_loc strm))) | _ -> Stream.sempty) in go init_loc strm let drop_prev_loc strm = stream_map (fun (tok, r) -> (tok, (r.cur_loc))) strm let get_cur_loc strm = match Stream.peek strm with | Some ((_, r)) -> r.cur_loc | None -> Loc.ghost let get_prev_loc strm = (get_prev_loc_only := true; let result = match Stream.peek strm with | Some ((_, { prev_loc = prev_loc; prev_loc_only = true })) -> (Stream.junk strm; prev_loc) | Some ((_, { prev_loc = prev_loc; prev_loc_only = false })) -> prev_loc | None -> Loc.ghost in (get_prev_loc_only := false; result)) let is_level_labelled n lev = match lev.lname with | Some n1 -> n = n1 | None -> false let warning_verbose = ref true let rec get_token_list entry tokl last_tok tree = match tree with | Node { node = (Stoken _ | Skeyword _ as tok); son = son; brother = DeadEnd } -> get_token_list entry (last_tok :: tokl) tok son | _ -> if tokl = [] then None else Some (((List.rev (last_tok :: tokl)), last_tok, tree)) let is_antiquot s = let len = String.length s in (len > 1) && (s.[0] = '$') let eq_Stoken_ids s1 s2 = (not (is_antiquot s1)) && ((not (is_antiquot s2)) && (s1 = s2)) let logically_eq_symbols entry = let rec eq_symbols s1 s2 = match (s1, s2) with | (Snterm e1, Snterm e2) -> e1.ename = e2.ename | (Snterm e1, Sself) -> e1.ename = entry.ename | (Sself, Snterm e2) -> entry.ename = e2.ename | (Snterml (e1, l1), Snterml (e2, l2)) -> (e1.ename = e2.ename) && (l1 = l2) | (Slist0 s1, Slist0 s2) | (Slist1 s1, Slist1 s2) | (Sopt s1, Sopt s2) | (Stry s1, Stry s2) -> eq_symbols s1 s2 | (Slist0sep (s1, sep1), Slist0sep (s2, sep2)) | (Slist1sep (s1, sep1), Slist1sep (s2, sep2)) -> (eq_symbols s1 s2) && (eq_symbols sep1 sep2) | (Stree t1, Stree t2) -> eq_trees t1 t2 | (Stoken ((_, s1)), Stoken ((_, s2))) -> eq_Stoken_ids s1 s2 | _ -> s1 = s2 and eq_trees t1 t2 = match (t1, t2) with | (Node n1, Node n2) -> (eq_symbols n1.node n2.node) && ((eq_trees n1.son n2.son) && (eq_trees n1.brother n2.brother)) | ((LocAct (_, _) | DeadEnd), (LocAct (_, _) | DeadEnd)) -> true | _ -> false in eq_symbols let rec eq_symbol s1 s2 = match (s1, s2) with | (Snterm e1, Snterm e2) -> e1 == e2 | (Snterml (e1, l1), Snterml (e2, l2)) -> (e1 == e2) && (l1 = l2) | (Slist0 s1, Slist0 s2) | (Slist1 s1, Slist1 s2) | (Sopt s1, Sopt s2) | (Stry s1, Stry s2) -> eq_symbol s1 s2 | (Slist0sep (s1, sep1), Slist0sep (s2, sep2)) | (Slist1sep (s1, sep1), Slist1sep (s2, sep2)) -> (eq_symbol s1 s2) && (eq_symbol sep1 sep2) | (Stree _, Stree _) -> false | (Stoken ((_, s1)), Stoken ((_, s2))) -> eq_Stoken_ids s1 s2 | _ -> s1 = s2 end end module Print : sig module Make (Structure : Structure.S) : sig val flatten_tree : Structure.tree -> (Structure.symbol list) list val print_symbol : Format.formatter -> Structure.symbol -> unit val print_meta : Format.formatter -> string -> Structure.symbol list -> unit val print_symbol1 : Format.formatter -> Structure.symbol -> unit val print_rule : Format.formatter -> Structure.symbol list -> unit val print_level : Format.formatter -> (Format.formatter -> unit -> unit) -> (Structure.symbol list) list -> unit val levels : Format.formatter -> Structure.level list -> unit val entry : Format.formatter -> Structure.internal_entry -> unit end module MakeDump (Structure : Structure.S) : sig val print_symbol : Format.formatter -> Structure.symbol -> unit val print_meta : Format.formatter -> string -> Structure.symbol list -> unit val print_symbol1 : Format.formatter -> Structure.symbol -> unit val print_rule : Format.formatter -> Structure.symbol list -> unit val print_level : Format.formatter -> (Format.formatter -> unit -> unit) -> (Structure.symbol list) list -> unit val levels : Format.formatter -> Structure.level list -> unit val entry : Format.formatter -> Structure.internal_entry -> unit end end = struct module Make (Structure : Structure.S) = struct open Structure open Format open Sig.Grammar let rec flatten_tree = function | DeadEnd -> [] | LocAct (_, _) -> [ [] ] | Node { node = n; brother = b; son = s } -> (List.map (fun l -> n :: l) (flatten_tree s)) @ (flatten_tree b) let rec print_symbol ppf = function | Smeta (n, sl, _) -> print_meta ppf n sl | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s | Slist0sep (s, t) -> fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s | Slist1sep (s, t) -> fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s | Stry s -> fprintf ppf "TRY %a" print_symbol1 s | Snterml (e, l) -> fprintf ppf "%s@ LEVEL@ %S" e.ename l | (Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s) -> print_symbol1 ppf s and print_meta ppf n sl = let rec loop i = function | [] -> () | s :: sl -> let j = (try String.index_from n i ' ' with | Not_found -> String.length n) in (fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; if sl = [] then () else (fprintf ppf " "; loop (min (j + 1) (String.length n)) sl)) in loop 0 sl and print_symbol1 ppf = function | Snterm e -> pp_print_string ppf e.ename | Sself -> pp_print_string ppf "SELF" | Snext -> pp_print_string ppf "NEXT" | Stoken ((_, descr)) -> pp_print_string ppf descr | Skeyword s -> fprintf ppf "%S" s | Stree t -> print_level ppf pp_print_space (flatten_tree t) | (Smeta (_, _, _) | Snterml (_, _) | Slist0 _ | Slist0sep (_, _) | Slist1 _ | Slist1sep (_, _) | Sopt _ | Stry _ as s) -> fprintf ppf "(%a)" print_symbol s and print_rule ppf symbols = (fprintf ppf "@["; let _ = List.fold_left (fun sep symbol -> (fprintf ppf "%t%a" sep print_symbol symbol; fun ppf -> fprintf ppf ";@ ")) (fun _ -> ()) symbols in fprintf ppf "@]") and print_level ppf pp_print_space rules = (fprintf ppf "@[[ "; let _ = List.fold_left (fun sep rule -> (fprintf ppf "%t%a" sep print_rule rule; fun ppf -> fprintf ppf "%a| " pp_print_space ())) (fun _ -> ()) rules in fprintf ppf " ]@]") let levels ppf elev = let _ = List.fold_left (fun sep lev -> let rules = (List.map (fun t -> Sself :: t) (flatten_tree lev.lsuffix)) @ (flatten_tree lev.lprefix) in (fprintf ppf "%t@[" sep; (match lev.lname with | Some n -> fprintf ppf "%S@;<1 2>" n | None -> ()); (match lev.assoc with | LeftA -> fprintf ppf "LEFTA" | RightA -> fprintf ppf "RIGHTA" | NonA -> fprintf ppf "NONA"); fprintf ppf "@]@;<1 2>"; print_level ppf pp_force_newline rules; fun ppf -> fprintf ppf "@,| ")) (fun _ -> ()) elev in () let entry ppf e = (fprintf ppf "@[%s: [ " e.ename; (match e.edesc with | Dlevels elev -> levels ppf elev | Dparser _ -> fprintf ppf ""); fprintf ppf " ]@]") end module MakeDump (Structure : Structure.S) = struct open Structure open Format open Sig.Grammar type brothers = | Bro of symbol * brothers list let rec print_tree ppf tree = let rec get_brothers acc = function | DeadEnd -> List.rev acc | LocAct (_, _) -> List.rev acc | Node { node = n; brother = b; son = s } -> get_brothers ((Bro (n, (get_brothers [] s))) :: acc) b and print_brothers ppf brothers = if brothers = [] then fprintf ppf "@ []" else List.iter (function | Bro (n, xs) -> (fprintf ppf "@ @[- %a" print_symbol n; (match xs with | [] -> () | [ _ ] -> (try print_children ppf (get_children [] xs) with | Exit -> fprintf ppf ":%a" print_brothers xs) | _ -> fprintf ppf ":%a" print_brothers xs); fprintf ppf "@]")) brothers and print_children ppf = List.iter (fprintf ppf ";@ %a" print_symbol) and get_children acc = function | [] -> List.rev acc | [ Bro (n, x) ] -> get_children (n :: acc) x | _ -> raise Exit in print_brothers ppf (get_brothers [] tree) and print_symbol ppf = function | Smeta (n, sl, _) -> print_meta ppf n sl | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s | Slist0sep (s, t) -> fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s | Slist1sep (s, t) -> fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s | Stry s -> fprintf ppf "TRY %a" print_symbol1 s | Snterml (e, l) -> fprintf ppf "%s@ LEVEL@ %S" e.ename l | (Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s) -> print_symbol1 ppf s and print_meta ppf n sl = let rec loop i = function | [] -> () | s :: sl -> let j = (try String.index_from n i ' ' with | Not_found -> String.length n) in (fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; if sl = [] then () else (fprintf ppf " "; loop (min (j + 1) (String.length n)) sl)) in loop 0 sl and print_symbol1 ppf = function | Snterm e -> pp_print_string ppf e.ename | Sself -> pp_print_string ppf "SELF" | Snext -> pp_print_string ppf "NEXT" | Stoken ((_, descr)) -> pp_print_string ppf descr | Skeyword s -> fprintf ppf "%S" s | Stree t -> print_tree ppf t | (Smeta (_, _, _) | Snterml (_, _) | Slist0 _ | Slist0sep (_, _) | Slist1 _ | Slist1sep (_, _) | Sopt _ | Stry _ as s) -> fprintf ppf "(%a)" print_symbol s and print_rule ppf symbols = (fprintf ppf "@["; let _ = List.fold_left (fun sep symbol -> (fprintf ppf "%t%a" sep print_symbol symbol; fun ppf -> fprintf ppf ";@ ")) (fun _ -> ()) symbols in fprintf ppf "@]") and print_level ppf pp_print_space rules = (fprintf ppf "@[[ "; let _ = List.fold_left (fun sep rule -> (fprintf ppf "%t%a" sep print_rule rule; fun ppf -> fprintf ppf "%a| " pp_print_space ())) (fun _ -> ()) rules in fprintf ppf " ]@]") let levels ppf elev = let _ = List.fold_left (fun sep lev -> (fprintf ppf "%t@[" sep; (match lev.lname with | Some n -> fprintf ppf "%S@;<1 2>" n | None -> ()); (match lev.assoc with | LeftA -> fprintf ppf "LEFTA" | RightA -> fprintf ppf "RIGHTA" | NonA -> fprintf ppf "NONA"); fprintf ppf "@]@;<1 2>"; fprintf ppf "@[suffix:@ "; print_tree ppf lev.lsuffix; fprintf ppf "@]@ @[prefix:@ "; print_tree ppf lev.lprefix; fprintf ppf "@]"; fun ppf -> fprintf ppf "@,| ")) (fun _ -> ()) elev in () let entry ppf e = (fprintf ppf "@[%s: [ " e.ename; (match e.edesc with | Dlevels elev -> levels ppf elev | Dparser _ -> fprintf ppf ""); fprintf ppf " ]@]") end end module Failed = struct module Make (Structure : Structure.S) = struct module Tools = Tools.Make(Structure) module Search = Search.Make(Structure) module Print = Print.Make(Structure) open Structure open Format let rec name_of_symbol entry = function | Snterm e -> "[" ^ (e.ename ^ "]") | Snterml (e, l) -> "[" ^ (e.ename ^ (" level " ^ (l ^ "]"))) | Sself | Snext -> "[" ^ (entry.ename ^ "]") | Stoken ((_, descr)) -> descr | Skeyword kwd -> "\"" ^ (kwd ^ "\"") | _ -> "???" let rec name_of_symbol_failed entry = function | Slist0 s | Slist0sep (s, _) | Slist1 s | Slist1sep (s, _) | Sopt s | Stry s -> name_of_symbol_failed entry s | Stree t -> name_of_tree_failed entry t | s -> name_of_symbol entry s and name_of_tree_failed entry = function | Node { node = s; brother = bro; son = son } -> let tokl = (match s with | Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son | _ -> None) in (match tokl with | None -> let txt = name_of_symbol_failed entry s in let txt = (match (s, son) with | (Sopt _, Node _) -> txt ^ (" or " ^ (name_of_tree_failed entry son)) | _ -> txt) in let txt = (match bro with | DeadEnd | LocAct (_, _) -> txt | Node _ -> txt ^ (" or " ^ (name_of_tree_failed entry bro))) in txt | Some ((tokl, _, _)) -> List.fold_left (fun s tok -> (if s = "" then "" else s ^ " then ") ^ (match tok with | Stoken ((_, descr)) -> descr | Skeyword kwd -> kwd | _ -> assert false)) "" tokl) | DeadEnd | LocAct (_, _) -> "???" let magic _s x = Obj.magic x let tree_failed entry prev_symb_result prev_symb tree = let txt = name_of_tree_failed entry tree in let txt = match prev_symb with | Slist0 s -> let txt1 = name_of_symbol_failed entry s in txt1 ^ (" or " ^ (txt ^ " expected")) | Slist1 s -> let txt1 = name_of_symbol_failed entry s in txt1 ^ (" or " ^ (txt ^ " expected")) | Slist0sep (s, sep) -> (match magic "tree_failed: 'a -> list 'b" prev_symb_result with | [] -> let txt1 = name_of_symbol_failed entry s in txt1 ^ (" or " ^ (txt ^ " expected")) | _ -> let txt1 = name_of_symbol_failed entry sep in txt1 ^ (" or " ^ (txt ^ " expected"))) | Slist1sep (s, sep) -> (match magic "tree_failed: 'a -> list 'b" prev_symb_result with | [] -> let txt1 = name_of_symbol_failed entry s in txt1 ^ (" or " ^ (txt ^ " expected")) | _ -> let txt1 = name_of_symbol_failed entry sep in txt1 ^ (" or " ^ (txt ^ " expected"))) | Stry _ | Sopt _ | Stree _ -> txt ^ " expected" | _ -> txt ^ (" expected after " ^ (name_of_symbol entry prev_symb)) in (if !(entry.egram.error_verbose) then (let tree = Search.tree_in_entry prev_symb tree entry.edesc in let ppf = err_formatter in (fprintf ppf "@[@,"; fprintf ppf "----------------------------------@,"; fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename; fprintf ppf "@["; Print.print_level ppf pp_force_newline (Print.flatten_tree tree); fprintf ppf "@]@,"; fprintf ppf "----------------------------------@,"; fprintf ppf "@]@.")) else (); txt ^ (" (in [" ^ (entry.ename ^ "])"))) let symb_failed entry prev_symb_result prev_symb symb = let tree = Node { node = symb; brother = DeadEnd; son = DeadEnd; } in tree_failed entry prev_symb_result prev_symb tree let symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2 end end module Parser = struct module Make (Structure : Structure.S) = struct module Tools = Tools.Make(Structure) module Failed = Failed.Make(Structure) module Print = Print.Make(Structure) open Structure open Sig.Grammar module StreamOrig = Stream let njunk strm n = for i = 1 to n do Stream.junk strm done let loc_bp = Tools.get_cur_loc let loc_ep = Tools.get_prev_loc let drop_prev_loc = Tools.drop_prev_loc let add_loc bp parse_fun strm = let x = parse_fun strm in let ep = loc_ep strm in let loc = if (Loc.start_off bp) > (Loc.stop_off ep) then Loc.join bp else Loc.merge bp ep in (x, loc) let stream_peek_nth strm n = let rec loop i = function | x :: xs -> if i = 1 then Some x else loop (i - 1) xs | [] -> None in loop n (Stream.npeek n strm) module Stream = struct type 'a t = 'a StreamOrig.t exception Failure = StreamOrig.Failure exception Error = StreamOrig.Error let peek = StreamOrig.peek let junk = StreamOrig.junk let dup strm = let peek_nth n = let rec loop n = function | [] -> None | [ x ] -> if n = 0 then Some x else None | _ :: l -> loop (n - 1) l in loop n (Stream.npeek (n + 1) strm) in Stream.from peek_nth end let try_parser ps strm = let strm' = Stream.dup strm in let r = try ps strm' with | Stream.Error _ | Loc.Exc_located (_, (Stream.Error _)) -> raise Stream.Failure | exc -> raise exc in (njunk strm (StreamOrig.count strm'); r) let level_number entry lab = let rec lookup levn = function | [] -> failwith ("unknown level " ^ lab) | lev :: levs -> if Tools.is_level_labelled lab lev then levn else lookup (succ levn) levs in match entry.edesc with | Dlevels elev -> lookup 0 elev | Dparser _ -> raise Not_found let strict_parsing = ref false let strict_parsing_warning = ref false let rec top_symb entry = function | Sself | Snext -> Snterm entry | Snterml (e, _) -> Snterm e | Slist1sep (s, sep) -> Slist1sep ((top_symb entry s), sep) | _ -> raise Stream.Failure let top_tree entry = function | Node { node = s; brother = bro; son = son } -> Node { node = top_symb entry s; brother = bro; son = son; } | LocAct (_, _) | DeadEnd -> raise Stream.Failure let entry_of_symb entry = function | Sself | Snext -> entry | Snterm e -> e | Snterml (e, _) -> e | _ -> raise Stream.Failure let continue entry loc a s son p1 (__strm : _ Stream.t) = let a = (entry_of_symb entry s).econtinue 0 loc a __strm in let act = try p1 __strm with | Stream.Failure -> raise (Stream.Error (Failed.tree_failed entry a s son)) in Action.mk (fun _ -> Action.getf act a) let skip_if_empty bp strm = if (loc_bp strm) = bp then Action.mk (fun _ -> raise Stream.Failure) else raise Stream.Failure let do_recover parser_of_tree entry nlevn alevn loc a s son (__strm : _ Stream.t) = try parser_of_tree entry nlevn alevn (top_tree entry son) __strm with | Stream.Failure -> (try skip_if_empty loc __strm with | Stream.Failure -> continue entry loc a s son (parser_of_tree entry nlevn alevn son) __strm) let recover parser_of_tree entry nlevn alevn loc a s son strm = if !strict_parsing then raise (Stream.Error (Failed.tree_failed entry a s son)) else (let _ = if !strict_parsing_warning then (let msg = Failed.tree_failed entry a s son in (Format.eprintf "Warning: trying to recover from syntax error"; if entry.ename <> "" then Format.eprintf " in [%s]" entry.ename else (); Format.eprintf "\n%s%a@." msg Loc.print loc)) else () in do_recover parser_of_tree entry nlevn alevn loc a s son strm) let rec parser_of_tree entry nlevn alevn = function | DeadEnd -> (fun (__strm : _ Stream.t) -> raise Stream.Failure) | LocAct (act, _) -> (fun (__strm : _ Stream.t) -> act) | Node { node = Sself; son = LocAct (act, _); brother = DeadEnd } -> (fun (__strm : _ Stream.t) -> let a = entry.estart alevn __strm in Action.getf act a) | Node { node = Sself; son = LocAct (act, _); brother = bro } -> let p2 = parser_of_tree entry nlevn alevn bro in (fun (__strm : _ Stream.t) -> match try Some (entry.estart alevn __strm) with | Stream.Failure -> None with | Some a -> Action.getf act a | _ -> p2 __strm) | Node { node = s; son = son; brother = DeadEnd } -> let tokl = (match s with | Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son | _ -> None) in (match tokl with | None -> let ps = parser_of_symbol entry nlevn s in let p1 = parser_of_tree entry nlevn alevn son in let p1 = parser_cont p1 entry nlevn alevn s son in (fun strm -> let bp = loc_bp strm in let (__strm : _ Stream.t) = strm in let a = ps __strm in let act = try p1 bp a __strm with | Stream.Failure -> raise (Stream.Error "") in Action.getf act a) | Some ((tokl, last_tok, son)) -> let p1 = parser_of_tree entry nlevn alevn son in let p1 = parser_cont p1 entry nlevn alevn last_tok son in parser_of_token_list p1 tokl) | Node { node = s; son = son; brother = bro } -> let tokl = (match s with | Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son | _ -> None) in (match tokl with | None -> let ps = parser_of_symbol entry nlevn s in let p1 = parser_of_tree entry nlevn alevn son in let p1 = parser_cont p1 entry nlevn alevn s son in let p2 = parser_of_tree entry nlevn alevn bro in (fun strm -> let bp = loc_bp strm in let (__strm : _ Stream.t) = strm in match try Some (ps __strm) with | Stream.Failure -> None with | Some a -> let act = (try p1 bp a __strm with | Stream.Failure -> raise (Stream.Error "")) in Action.getf act a | _ -> p2 __strm) | Some ((tokl, last_tok, son)) -> let p1 = parser_of_tree entry nlevn alevn son in let p1 = parser_cont p1 entry nlevn alevn last_tok son in let p1 = parser_of_token_list p1 tokl in let p2 = parser_of_tree entry nlevn alevn bro in (fun (__strm : _ Stream.t) -> try p1 __strm with | Stream.Failure -> p2 __strm)) and parser_cont p1 entry nlevn alevn s son loc a (__strm : _ Stream.t) = try p1 __strm with | Stream.Failure -> (try recover parser_of_tree entry nlevn alevn loc a s son __strm with | Stream.Failure -> raise (Stream.Error (Failed.tree_failed entry a s son))) and parser_of_token_list p1 tokl = let rec loop n = function | Stoken ((tematch, _)) :: tokl -> (match tokl with | [] -> let ps strm = (match stream_peek_nth strm n with | Some ((tok, _)) when tematch tok -> (njunk strm n; Action.mk tok) | _ -> raise Stream.Failure) in (fun strm -> let bp = loc_bp strm in let (__strm : _ Stream.t) = strm in let a = ps __strm in let act = try p1 bp a __strm with | Stream.Failure -> raise (Stream.Error "") in Action.getf act a) | _ -> let ps strm = (match stream_peek_nth strm n with | Some ((tok, _)) when tematch tok -> tok | _ -> raise Stream.Failure) in let p1 = loop (n + 1) tokl in (fun (__strm : _ Stream.t) -> let tok = ps __strm in let s = __strm in let act = p1 s in Action.getf act tok)) | Skeyword kwd :: tokl -> (match tokl with | [] -> let ps strm = (match stream_peek_nth strm n with | Some ((tok, _)) when Token.match_keyword kwd tok -> (njunk strm n; Action.mk tok) | _ -> raise Stream.Failure) in (fun strm -> let bp = loc_bp strm in let (__strm : _ Stream.t) = strm in let a = ps __strm in let act = try p1 bp a __strm with | Stream.Failure -> raise (Stream.Error "") in Action.getf act a) | _ -> let ps strm = (match stream_peek_nth strm n with | Some ((tok, _)) when Token.match_keyword kwd tok -> tok | _ -> raise Stream.Failure) in let p1 = loop (n + 1) tokl in (fun (__strm : _ Stream.t) -> let tok = ps __strm in let s = __strm in let act = p1 s in Action.getf act tok)) | _ -> invalid_arg "parser_of_token_list" in loop 1 tokl and parser_of_symbol entry nlevn = function | Smeta (_, symbl, act) -> let act = Obj.magic act entry symbl in let pl = List.map (parser_of_symbol entry nlevn) symbl in Obj.magic (List.fold_left (fun act p -> Obj.magic act p) act pl) | Slist0 s -> let ps = parser_of_symbol entry nlevn s in let rec loop al (__strm : _ Stream.t) = (match try Some (ps __strm) with | Stream.Failure -> None with | Some a -> loop (a :: al) __strm | _ -> al) in (fun (__strm : _ Stream.t) -> let a = loop [] __strm in Action.mk (List.rev a)) | Slist0sep (symb, sep) -> let ps = parser_of_symbol entry nlevn symb in let pt = parser_of_symbol entry nlevn sep in let rec kont al (__strm : _ Stream.t) = (match try Some (pt __strm) with | Stream.Failure -> None with | Some v -> let a = (try ps __strm with | Stream.Failure -> raise (Stream.Error (Failed.symb_failed entry v sep symb))) in kont (a :: al) __strm | _ -> al) in (fun (__strm : _ Stream.t) -> match try Some (ps __strm) with | Stream.Failure -> None with | Some a -> let s = __strm in Action.mk (List.rev (kont [ a ] s)) | _ -> Action.mk []) | Slist1 s -> let ps = parser_of_symbol entry nlevn s in let rec loop al (__strm : _ Stream.t) = (match try Some (ps __strm) with | Stream.Failure -> None with | Some a -> loop (a :: al) __strm | _ -> al) in (fun (__strm : _ Stream.t) -> let a = ps __strm in let s = __strm in Action.mk (List.rev (loop [ a ] s))) | Slist1sep (symb, sep) -> let ps = parser_of_symbol entry nlevn symb in let pt = parser_of_symbol entry nlevn sep in let rec kont al (__strm : _ Stream.t) = (match try Some (pt __strm) with | Stream.Failure -> None with | Some v -> let a = (try ps __strm with | Stream.Failure -> (try parse_top_symb entry symb __strm with | Stream.Failure -> raise (Stream.Error (Failed.symb_failed entry v sep symb)))) in kont (a :: al) __strm | _ -> al) in (fun (__strm : _ Stream.t) -> let a = ps __strm in let s = __strm in Action.mk (List.rev (kont [ a ] s))) | Sopt s -> let ps = parser_of_symbol entry nlevn s in (fun (__strm : _ Stream.t) -> match try Some (ps __strm) with | Stream.Failure -> None with | Some a -> Action.mk (Some a) | _ -> Action.mk None) | Stry s -> let ps = parser_of_symbol entry nlevn s in try_parser ps | Stree t -> let pt = parser_of_tree entry 1 0 t in (fun strm -> let bp = loc_bp strm in let (__strm : _ Stream.t) = strm in let (act, loc) = add_loc bp pt __strm in Action.getf act loc) | Snterm e -> (fun (__strm : _ Stream.t) -> e.estart 0 __strm) | Snterml (e, l) -> (fun (__strm : _ Stream.t) -> e.estart (level_number e l) __strm) | Sself -> (fun (__strm : _ Stream.t) -> entry.estart 0 __strm) | Snext -> (fun (__strm : _ Stream.t) -> entry.estart nlevn __strm) | Skeyword kwd -> (fun (__strm : _ Stream.t) -> match Stream.peek __strm with | Some ((tok, _)) when Token.match_keyword kwd tok -> (Stream.junk __strm; Action.mk tok) | _ -> raise Stream.Failure) | Stoken ((f, _)) -> (fun (__strm : _ Stream.t) -> match Stream.peek __strm with | Some ((tok, _)) when f tok -> (Stream.junk __strm; Action.mk tok) | _ -> raise Stream.Failure) and parse_top_symb entry symb strm = parser_of_symbol entry 0 (top_symb entry symb) strm let rec start_parser_of_levels entry clevn = function | [] -> (fun _ (__strm : _ Stream.t) -> raise Stream.Failure) | lev :: levs -> let p1 = start_parser_of_levels entry (succ clevn) levs in (match lev.lprefix with | DeadEnd -> p1 | tree -> let alevn = (match lev.assoc with | LeftA | NonA -> succ clevn | RightA -> clevn) in let p2 = parser_of_tree entry (succ clevn) alevn tree in (match levs with | [] -> (fun levn strm -> let bp = loc_bp strm in let (__strm : _ Stream.t) = strm in let (act, loc) = add_loc bp p2 __strm in let strm = __strm in let a = Action.getf act loc in entry.econtinue levn loc a strm) | _ -> (fun levn strm -> if levn > clevn then p1 levn strm else (let bp = loc_bp strm in let (__strm : _ Stream.t) = strm in match try Some (add_loc bp p2 __strm) with | Stream.Failure -> None with | Some ((act, loc)) -> let a = Action.getf act loc in entry.econtinue levn loc a strm | _ -> p1 levn __strm)))) let start_parser_of_entry entry = match entry.edesc with | Dlevels [] -> Tools.empty_entry entry.ename | Dlevels elev -> start_parser_of_levels entry 0 elev | Dparser p -> (fun _ -> p) let rec continue_parser_of_levels entry clevn = function | [] -> (fun _ _ _ (__strm : _ Stream.t) -> raise Stream.Failure) | lev :: levs -> let p1 = continue_parser_of_levels entry (succ clevn) levs in (match lev.lsuffix with | DeadEnd -> p1 | tree -> let alevn = (match lev.assoc with | LeftA | NonA -> succ clevn | RightA -> clevn) in let p2 = parser_of_tree entry (succ clevn) alevn tree in (fun levn bp a strm -> if levn > clevn then p1 levn bp a strm else (let (__strm : _ Stream.t) = strm in try p1 levn bp a __strm with | Stream.Failure -> let (act, loc) = add_loc bp p2 __strm in let a = Action.getf2 act a loc in entry.econtinue levn loc a strm))) let continue_parser_of_entry entry = match entry.edesc with | Dlevels elev -> let p = continue_parser_of_levels entry 0 elev in (fun levn bp a (__strm : _ Stream.t) -> try p levn bp a __strm with | Stream.Failure -> a) | Dparser _ -> (fun _ _ _ (__strm : _ Stream.t) -> raise Stream.Failure) end end module Insert = struct module Make (Structure : Structure.S) = struct module Tools = Tools.Make(Structure) module Parser = Parser.Make(Structure) open Structure open Format open Sig.Grammar let is_before s1 s2 = match (s1, s2) with | ((Skeyword _ | Stoken _), (Skeyword _ | Stoken _)) -> false | ((Skeyword _ | Stoken _), _) -> true | _ -> false let rec derive_eps = function | Slist0 _ | Slist0sep (_, _) | Sopt _ -> true | Stry s -> derive_eps s | Stree t -> tree_derive_eps t | Slist1 _ | Slist1sep (_, _) | Stoken _ | Skeyword _ -> false | Smeta (_, _, _) | Snterm _ | Snterml (_, _) | Snext | Sself -> false and tree_derive_eps = function | LocAct (_, _) -> true | Node { node = s; brother = bro; son = son } -> ((derive_eps s) && (tree_derive_eps son)) || (tree_derive_eps bro) | DeadEnd -> false let empty_lev lname assoc = let assoc = match assoc with | Some a -> a | None -> LeftA in { assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd; } let change_lev entry lev n lname assoc = let a = match assoc with | None -> lev.assoc | Some a -> (if (a <> lev.assoc) && !(entry.egram.warning_verbose) then (eprintf " Changing associativity of level \"%s\"\n" n; flush Pervasives.stderr) else (); a) in ((match lname with | Some n -> if (lname <> lev.lname) && !(entry.egram.warning_verbose) then (eprintf " Level label \"%s\" ignored\n" n; flush Pervasives.stderr) else () | None -> ()); { assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix; }) let change_to_self entry = function | Snterm e when e == entry -> Sself | x -> x let get_level entry position levs = match position with | Some First -> ([], empty_lev, levs) | Some Last -> (levs, empty_lev, []) | Some (Level n) -> let rec get = (function | [] -> (eprintf "No level labelled \"%s\" in entry \"%s\"\n" n entry.ename; flush Pervasives.stderr; failwith "Grammar.extend") | lev :: levs -> if Tools.is_level_labelled n lev then ([], (change_lev entry lev n), levs) else (let (levs1, rlev, levs2) = get levs in ((lev :: levs1), rlev, levs2))) in get levs | Some (Before n) -> let rec get = (function | [] -> (eprintf "No level labelled \"%s\" in entry \"%s\"\n" n entry.ename; flush Pervasives.stderr; failwith "Grammar.extend") | lev :: levs -> if Tools.is_level_labelled n lev then ([], empty_lev, (lev :: levs)) else (let (levs1, rlev, levs2) = get levs in ((lev :: levs1), rlev, levs2))) in get levs | Some (After n) -> let rec get = (function | [] -> (eprintf "No level labelled \"%s\" in entry \"%s\"\n" n entry.ename; flush Pervasives.stderr; failwith "Grammar.extend") | lev :: levs -> if Tools.is_level_labelled n lev then ([ lev ], empty_lev, levs) else (let (levs1, rlev, levs2) = get levs in ((lev :: levs1), rlev, levs2))) in get levs | None -> (match levs with | lev :: levs -> ([], (change_lev entry lev ""), levs) | [] -> ([], empty_lev, [])) let rec check_gram entry = function | Snterm e -> if ( != ) e.egram entry.egram then (eprintf "\ Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" entry.ename e.ename; flush Pervasives.stderr; failwith "Grammar.extend error") else () | Snterml (e, _) -> if ( != ) e.egram entry.egram then (eprintf "\ Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" entry.ename e.ename; flush Pervasives.stderr; failwith "Grammar.extend error") else () | Smeta (_, sl, _) -> List.iter (check_gram entry) sl | Slist0sep (s, t) -> (check_gram entry t; check_gram entry s) | Slist1sep (s, t) -> (check_gram entry t; check_gram entry s) | Slist0 s | Slist1 s | Sopt s | Stry s -> check_gram entry s | Stree t -> tree_check_gram entry t | Snext | Sself | Stoken _ | Skeyword _ -> () and tree_check_gram entry = function | Node { node = n; brother = bro; son = son } -> (check_gram entry n; tree_check_gram entry bro; tree_check_gram entry son) | LocAct (_, _) | DeadEnd -> () let get_initial = function | Sself :: symbols -> (true, symbols) | symbols -> (false, symbols) let insert_tokens gram symbols = let rec insert = function | Smeta (_, sl, _) -> List.iter insert sl | Slist0 s | Slist1 s | Sopt s | Stry s -> insert s | Slist0sep (s, t) -> (insert s; insert t) | Slist1sep (s, t) -> (insert s; insert t) | Stree t -> tinsert t | Skeyword kwd -> using gram kwd | Snterm _ | Snterml (_, _) | Snext | Sself | Stoken _ -> () and tinsert = function | Node { node = s; brother = bro; son = son } -> (insert s; tinsert bro; tinsert son) | LocAct (_, _) | DeadEnd -> () in List.iter insert symbols let insert_tree entry gsymbols action tree = let rec insert symbols tree = match symbols with | s :: sl -> insert_in_tree s sl tree | [] -> (match tree with | Node { node = s; son = son; brother = bro } -> Node { node = s; son = son; brother = insert [] bro; } | LocAct (old_action, action_list) -> let () = if !(entry.egram.warning_verbose) then eprintf " Grammar extension: in [%s] some rule has been masked@." entry.ename else () in LocAct (action, (old_action :: action_list)) | DeadEnd -> LocAct (action, [])) and insert_in_tree s sl tree = match try_insert s sl tree with | Some t -> t | None -> Node { node = s; son = insert sl DeadEnd; brother = tree; } and try_insert s sl tree = match tree with | Node { node = s1; son = son; brother = bro } -> if Tools.eq_symbol s s1 then (let t = Node { node = s1; son = insert sl son; brother = bro; } in Some t) else if (is_before s1 s) || ((derive_eps s) && (not (derive_eps s1))) then (let bro = match try_insert s sl bro with | Some bro -> bro | None -> Node { node = s; son = insert sl DeadEnd; brother = bro; } in let t = Node { node = s1; son = son; brother = bro; } in Some t) else (match try_insert s sl bro with | Some bro -> let t = Node { node = s1; son = son; brother = bro; } in Some t | None -> None) | LocAct (_, _) | DeadEnd -> None in insert gsymbols tree let insert_level entry e1 symbols action slev = match e1 with | true -> { assoc = slev.assoc; lname = slev.lname; lsuffix = insert_tree entry symbols action slev.lsuffix; lprefix = slev.lprefix; } | false -> { assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; lprefix = insert_tree entry symbols action slev.lprefix; } let levels_of_rules entry position rules = let elev = match entry.edesc with | Dlevels elev -> elev | Dparser _ -> (eprintf "Error: entry not extensible: \"%s\"\n" entry.ename; flush Pervasives.stderr; failwith "Grammar.extend") in if rules = [] then elev else (let (levs1, make_lev, levs2) = get_level entry position elev in let (levs, _) = List.fold_left (fun (levs, make_lev) (lname, assoc, level) -> let lev = make_lev lname assoc in let lev = List.fold_left (fun lev (symbols, action) -> let symbols = List.map (change_to_self entry) symbols in (List.iter (check_gram entry) symbols; let (e1, symbols) = get_initial symbols in (insert_tokens entry.egram symbols; insert_level entry e1 symbols action lev))) lev level in ((lev :: levs), empty_lev)) ([], make_lev) rules in levs1 @ ((List.rev levs) @ levs2)) let extend entry (position, rules) = let elev = levels_of_rules entry position rules in (entry.edesc <- Dlevels elev; entry.estart <- (fun lev strm -> let f = Parser.start_parser_of_entry entry in (entry.estart <- f; f lev strm)); entry.econtinue <- fun lev bp a strm -> let f = Parser.continue_parser_of_entry entry in (entry.econtinue <- f; f lev bp a strm)) end end module Delete = struct module Make (Structure : Structure.S) = struct module Tools = Tools.Make(Structure) module Parser = Parser.Make(Structure) open Structure let delete_rule_in_tree entry = let rec delete_in_tree symbols tree = match (symbols, tree) with | (s :: sl, Node n) -> if Tools.logically_eq_symbols entry s n.node then delete_son sl n else (match delete_in_tree symbols n.brother with | Some ((dsl, t)) -> Some ((dsl, (Node { node = n.node; son = n.son; brother = t; }))) | None -> None) | (_ :: _, _) -> None | ([], Node n) -> (match delete_in_tree [] n.brother with | Some ((dsl, t)) -> Some ((dsl, (Node { node = n.node; son = n.son; brother = t; }))) | None -> None) | ([], DeadEnd) -> None | ([], LocAct (_, [])) -> Some (((Some []), DeadEnd)) | ([], LocAct (_, (action :: list))) -> Some ((None, (LocAct (action, list)))) and delete_son sl n = match delete_in_tree sl n.son with | Some ((Some dsl, DeadEnd)) -> Some (((Some (n.node :: dsl)), (n.brother))) | Some ((Some dsl, t)) -> let t = Node { node = n.node; son = t; brother = n.brother; } in Some (((Some (n.node :: dsl)), t)) | Some ((None, t)) -> let t = Node { node = n.node; son = t; brother = n.brother; } in Some ((None, t)) | None -> None in delete_in_tree let rec decr_keyw_use gram = function | Skeyword kwd -> removing gram kwd | Smeta (_, sl, _) -> List.iter (decr_keyw_use gram) sl | Slist0 s | Slist1 s | Sopt s | Stry s -> decr_keyw_use gram s | Slist0sep (s1, s2) -> (decr_keyw_use gram s1; decr_keyw_use gram s2) | Slist1sep (s1, s2) -> (decr_keyw_use gram s1; decr_keyw_use gram s2) | Stree t -> decr_keyw_use_in_tree gram t | Sself | Snext | Snterm _ | Snterml (_, _) | Stoken _ -> () and decr_keyw_use_in_tree gram = function | DeadEnd | LocAct (_, _) -> () | Node n -> (decr_keyw_use gram n.node; decr_keyw_use_in_tree gram n.son; decr_keyw_use_in_tree gram n.brother) let rec delete_rule_in_suffix entry symbols = function | lev :: levs -> (match delete_rule_in_tree entry symbols lev.lsuffix with | Some ((dsl, t)) -> ((match dsl with | Some dsl -> List.iter (decr_keyw_use entry.egram) dsl | None -> ()); (match t with | DeadEnd when lev.lprefix == DeadEnd -> levs | _ -> let lev = { assoc = lev.assoc; lname = lev.lname; lsuffix = t; lprefix = lev.lprefix; } in lev :: levs)) | None -> let levs = delete_rule_in_suffix entry symbols levs in lev :: levs) | [] -> raise Not_found let rec delete_rule_in_prefix entry symbols = function | lev :: levs -> (match delete_rule_in_tree entry symbols lev.lprefix with | Some ((dsl, t)) -> ((match dsl with | Some dsl -> List.iter (decr_keyw_use entry.egram) dsl | None -> ()); (match t with | DeadEnd when lev.lsuffix == DeadEnd -> levs | _ -> let lev = { assoc = lev.assoc; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = t; } in lev :: levs)) | None -> let levs = delete_rule_in_prefix entry symbols levs in lev :: levs) | [] -> raise Not_found let rec delete_rule_in_level_list entry symbols levs = match symbols with | Sself :: symbols -> delete_rule_in_suffix entry symbols levs | Snterm e :: symbols when e == entry -> delete_rule_in_suffix entry symbols levs | _ -> delete_rule_in_prefix entry symbols levs let delete_rule entry sl = match entry.edesc with | Dlevels levs -> let levs = delete_rule_in_level_list entry sl levs in (entry.edesc <- Dlevels levs; entry.estart <- (fun lev strm -> let f = Parser.start_parser_of_entry entry in (entry.estart <- f; f lev strm)); entry.econtinue <- (fun lev bp a strm -> let f = Parser.continue_parser_of_entry entry in (entry.econtinue <- f; f lev bp a strm))) | Dparser _ -> () end end module Fold : sig module Make (Structure : Structure.S) : sig open Structure val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) foldsep end end = struct module Make (Structure : Structure.S) = struct open Structure open Format module Parse = Parser.Make(Structure) module Fail = Failed.Make(Structure) open Sig.Grammar module Stream = struct type 'a t = 'a Stream.t exception Failure = Stream.Failure exception Error = Stream.Error end let sfold0 f e _entry _symbl psymb = let rec fold accu (__strm : _ Stream.t) = match try Some (psymb __strm) with | Stream.Failure -> None with | Some a -> fold (f a accu) __strm | _ -> accu in fun (__strm : _ Stream.t) -> fold e __strm let sfold1 f e _entry _symbl psymb = let rec fold accu (__strm : _ Stream.t) = match try Some (psymb __strm) with | Stream.Failure -> None with | Some a -> fold (f a accu) __strm | _ -> accu in fun (__strm : _ Stream.t) -> let a = psymb __strm in try fold (f a e) __strm with | Stream.Failure -> raise (Stream.Error "") let sfold0sep f e entry symbl psymb psep = let failed = function | [ symb; sep ] -> Fail.symb_failed_txt entry sep symb | _ -> "failed" in let rec kont accu (__strm : _ Stream.t) = match try Some (psep __strm) with | Stream.Failure -> None with | Some () -> let a = (try psymb __strm with | Stream.Failure -> raise (Stream.Error (failed symbl))) in kont (f a accu) __strm | _ -> accu in fun (__strm : _ Stream.t) -> match try Some (psymb __strm) with | Stream.Failure -> None with | Some a -> kont (f a e) __strm | _ -> e let sfold1sep f e entry symbl psymb psep = let failed = function | [ symb; sep ] -> Fail.symb_failed_txt entry sep symb | _ -> "failed" in let parse_top = function | [ symb; _ ] -> Parse.parse_top_symb entry symb | _ -> raise Stream.Failure in let rec kont accu (__strm : _ Stream.t) = match try Some (psep __strm) with | Stream.Failure -> None with | Some () -> let a = (try try psymb __strm with | Stream.Failure -> let a = (try parse_top symbl __strm with | Stream.Failure -> raise (Stream.Error (failed symbl))) in Obj.magic a with | Stream.Failure -> raise (Stream.Error "")) in kont (f a accu) __strm | _ -> accu in fun (__strm : _ Stream.t) -> let a = psymb __strm in kont (f a e) __strm end end module Entry = struct module Make (Structure : Structure.S) = struct module Dump = Print.MakeDump(Structure) module Print = Print.Make(Structure) module Tools = Tools.Make(Structure) open Format open Structure open Tools type 'a t = internal_entry let name e = e.ename let print ppf e = fprintf ppf "%a@\n" Print.entry e let dump ppf e = fprintf ppf "%a@\n" Dump.entry e let mk g n = { egram = g; ename = n; estart = empty_entry n; econtinue = (fun _ _ _ (__strm : _ Stream.t) -> raise Stream.Failure); edesc = Dlevels []; } let action_parse entry ts : Action.t = try entry.estart 0 ts with | Stream.Failure -> Loc.raise (get_prev_loc ts) (Stream.Error ("illegal begin of " ^ entry.ename)) | (Loc.Exc_located (_, _) as exc) -> raise exc | exc -> Loc.raise (get_prev_loc ts) exc let lex entry loc cs = entry.egram.glexer loc cs let lex_string entry loc str = lex entry loc (Stream.of_string str) let filter entry ts = keep_prev_loc (Token.Filter.filter (get_filter entry.egram) ts) let parse_tokens_after_filter entry ts = Action.get (action_parse entry ts) let parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter entry ts) let parse entry loc cs = parse_tokens_before_filter entry (lex entry loc cs) let parse_string entry loc str = parse_tokens_before_filter entry (lex_string entry loc str) let of_parser g n (p : (Token.t * token_info) Stream.t -> 'a) : 'a t = let f ts = Action.mk (p ts) in { egram = g; ename = n; estart = (fun _ -> f); econtinue = (fun _ _ _ (__strm : _ Stream.t) -> raise Stream.Failure); edesc = Dparser f; } let setup_parser e (p : (Token.t * token_info) Stream.t -> 'a) = let f ts = Action.mk (p ts) in (e.estart <- (fun _ -> f); e.econtinue <- (fun _ _ _ (__strm : _ Stream.t) -> raise Stream.Failure); e.edesc <- Dparser f) let clear e = (e.estart <- (fun _ (__strm : _ Stream.t) -> raise Stream.Failure); e.econtinue <- (fun _ _ _ (__strm : _ Stream.t) -> raise Stream.Failure); e.edesc <- Dlevels []) let obj x = x end end module Static = struct let uncurry f (x, y) = f x y let flip f x y = f y x module Make (Lexer : Sig.Lexer) : Sig.Grammar.Static with module Loc = Lexer.Loc and module Token = Lexer.Token = struct module Structure = Structure.Make(Lexer) module Delete = Delete.Make(Structure) module Insert = Insert.Make(Structure) module Fold = Fold.Make(Structure) module Tools = Tools.Make(Structure) include Structure let gram = let gkeywords = Hashtbl.create 301 in { gkeywords = gkeywords; gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); glexer = Lexer.mk (); warning_verbose = ref true; error_verbose = Camlp4_config.verbose; } module Entry = struct module E = Entry.Make(Structure) type 'a t = 'a E.t let mk = E.mk gram let of_parser name strm = E.of_parser gram name strm let setup_parser = E.setup_parser let name = E.name let print = E.print let clear = E.clear let dump = E.dump let obj x = x end let get_filter () = gram.gfilter let lex loc cs = gram.glexer loc cs let lex_string loc str = lex loc (Stream.of_string str) let filter ts = Tools.keep_prev_loc (Token.Filter.filter gram.gfilter ts) let parse_tokens_after_filter entry ts = Entry.E.parse_tokens_after_filter entry ts let parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter ts) let parse entry loc cs = parse_tokens_before_filter entry (lex loc cs) let parse_string entry loc str = parse_tokens_before_filter entry (lex_string loc str) let delete_rule = Delete.delete_rule let srules e rl = Stree (List.fold_left (flip (uncurry (Insert.insert_tree e))) DeadEnd rl) let sfold0 = Fold.sfold0 let sfold1 = Fold.sfold1 let sfold0sep = Fold.sfold0sep let extend = Insert.extend end end module Dynamic = struct module Make (Lexer : Sig.Lexer) : Sig.Grammar.Dynamic with module Loc = Lexer.Loc and module Token = Lexer.Token = struct module Structure = Structure.Make(Lexer) module Delete = Delete.Make(Structure) module Insert = Insert.Make(Structure) module Entry = Entry.Make(Structure) module Fold = Fold.Make(Structure) module Tools = Tools.Make(Structure) include Structure let mk () = let gkeywords = Hashtbl.create 301 in { gkeywords = gkeywords; gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); glexer = Lexer.mk (); warning_verbose = ref true; error_verbose = Camlp4_config.verbose; } let get_filter g = g.gfilter let lex g loc cs = g.glexer loc cs let lex_string g loc str = lex g loc (Stream.of_string str) let filter g ts = Tools.keep_prev_loc (Token.Filter.filter g.gfilter ts) let parse_tokens_after_filter entry ts = Entry.parse_tokens_after_filter entry ts let parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter entry.egram ts) let parse entry loc cs = parse_tokens_before_filter entry (lex entry.egram loc cs) let parse_string entry loc str = parse_tokens_before_filter entry (lex_string entry.egram loc str) let delete_rule = Delete.delete_rule let srules e rl = let t = List.fold_left (fun tree (symbols, action) -> Insert.insert_tree e symbols action tree) DeadEnd rl in Stree t let sfold0 = Fold.sfold0 let sfold1 = Fold.sfold1 let sfold0sep = Fold.sfold0sep let extend = Insert.extend end end end end module Printers = struct module DumpCamlp4Ast : sig module Id : Sig.Id module Make (Syntax : Sig.Syntax) : Sig.Printer(Syntax.Ast).S end = struct module Id = struct let name = "Camlp4Printers.DumpCamlp4Ast" let version = Sys.ocaml_version end module Make (Syntax : Sig.Syntax) : Sig.Printer(Syntax.Ast).S = struct include Syntax let with_open_out_file x f = match x with | Some file -> let oc = open_out_bin file in (f oc; flush oc; close_out oc) | None -> (set_binary_mode_out stdout true; f stdout; flush stdout) let dump_ast magic ast oc = (output_string oc magic; output_value oc ast) let print_interf ?input_file:(_) ?output_file ast = with_open_out_file output_file (dump_ast Camlp4_config.camlp4_ast_intf_magic_number ast) let print_implem ?input_file:(_) ?output_file ast = with_open_out_file output_file (dump_ast Camlp4_config.camlp4_ast_impl_magic_number ast) end end module DumpOCamlAst : sig module Id : Sig.Id module Make (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax.Ast).S end = struct module Id : Sig.Id = struct let name = "Camlp4Printers.DumpOCamlAst" let version = Sys.ocaml_version end module Make (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax.Ast).S = struct include Syntax module Ast2pt = Struct.Camlp4Ast2OCamlAst.Make(Ast) let with_open_out_file x f = match x with | Some file -> let oc = open_out_bin file in (f oc; flush oc; close_out oc) | None -> (set_binary_mode_out stdout true; f stdout; flush stdout) let dump_pt magic fname pt oc = (output_string oc magic; output_value oc (if fname = "-" then "" else fname); output_value oc pt) let print_interf ?(input_file = "-") ?output_file ast = let pt = Ast2pt.sig_item ast in with_open_out_file output_file (dump_pt Camlp4_config.ocaml_ast_intf_magic_number input_file pt) let print_implem ?(input_file = "-") ?output_file ast = let pt = Ast2pt.str_item ast in with_open_out_file output_file (dump_pt Camlp4_config.ocaml_ast_impl_magic_number input_file pt) end end module Null : sig module Id : Sig.Id module Make (Syntax : Sig.Syntax) : Sig.Printer(Syntax.Ast).S end = struct module Id = struct let name = "Camlp4.Printers.Null" let version = Sys.ocaml_version end module Make (Syntax : Sig.Syntax) = struct include Syntax let print_interf ?input_file:(_) ?output_file:(_) _ = () let print_implem ?input_file:(_) ?output_file:(_) _ = () end end module OCaml : sig module Id : Sig.Id module Make (Syntax : Sig.Camlp4Syntax) : sig open Format include Sig.Camlp4Syntax with module Loc = Syntax.Loc and module Token = Syntax.Token and module Ast = Syntax.Ast and module Gram = Syntax.Gram type sep = (unit, formatter, unit) format type fun_binding = [ | `patt of Ast.patt | `newtype of string ] val list' : (formatter -> 'a -> unit) -> ('b, formatter, unit) format -> (unit, formatter, unit) format -> formatter -> 'a list -> unit val list : (formatter -> 'a -> unit) -> ('b, formatter, unit) format -> formatter -> 'a list -> unit val lex_string : string -> Token.t val is_infix : string -> bool val is_keyword : string -> bool val ocaml_char : string -> string val get_expr_args : Ast.expr -> Ast.expr list -> (Ast.expr * (Ast.expr list)) val get_patt_args : Ast.patt -> Ast.patt list -> (Ast.patt * (Ast.patt list)) val get_ctyp_args : Ast.ctyp -> Ast.ctyp list -> (Ast.ctyp * (Ast.ctyp list)) val expr_fun_args : Ast.expr -> ((fun_binding list) * Ast.expr) class printer : ?curry_constr: bool -> ?comments: bool -> unit -> object ('a) method interf : formatter -> Ast.sig_item -> unit method implem : formatter -> Ast.str_item -> unit method sig_item : formatter -> Ast.sig_item -> unit method str_item : formatter -> Ast.str_item -> unit val pipe : bool val semi : bool val semisep : sep val no_semisep : sep method value_val : string method value_let : string method andsep : sep method anti : formatter -> string -> unit method class_declaration : formatter -> Ast.class_expr -> unit method class_expr : formatter -> Ast.class_expr -> unit method class_sig_item : formatter -> Ast.class_sig_item -> unit method class_str_item : formatter -> Ast.class_str_item -> unit method class_type : formatter -> Ast.class_type -> unit method constrain : formatter -> (Ast.ctyp * Ast.ctyp) -> unit method ctyp : formatter -> Ast.ctyp -> unit method ctyp1 : formatter -> Ast.ctyp -> unit method constructor_type : formatter -> Ast.ctyp -> unit method dot_expr : formatter -> Ast.expr -> unit method apply_expr : formatter -> Ast.expr -> unit method expr : formatter -> Ast.expr -> unit method expr_list : formatter -> Ast.expr list -> unit method expr_list_cons : bool -> formatter -> Ast.expr -> unit method fun_binding : formatter -> fun_binding -> unit method functor_arg : formatter -> (string * Ast.module_type) -> unit method functor_args : formatter -> (string * Ast.module_type) list -> unit method ident : formatter -> Ast.ident -> unit method numeric : formatter -> string -> string -> unit method binding : formatter -> Ast.binding -> unit method record_binding : formatter -> Ast.rec_binding -> unit method match_case : formatter -> Ast.match_case -> unit method match_case_aux : formatter -> Ast.match_case -> unit method mk_expr_list : Ast.expr -> ((Ast.expr list) * (Ast.expr option)) method mk_patt_list : Ast.patt -> ((Ast.patt list) * (Ast.patt option)) method simple_module_expr : formatter -> Ast.module_expr -> unit method module_expr : formatter -> Ast.module_expr -> unit method module_expr_get_functor_args : (string * Ast.module_type) list -> Ast.module_expr -> (((string * Ast.module_type) list) * Ast. module_expr * (Ast.module_type option)) method module_rec_binding : formatter -> Ast.module_binding -> unit method module_type : formatter -> Ast.module_type -> unit method override_flag : formatter -> Ast.override_flag -> unit method mutable_flag : formatter -> Ast.mutable_flag -> unit method direction_flag : formatter -> Ast.direction_flag -> unit method rec_flag : formatter -> Ast.rec_flag -> unit method node : formatter -> 'b -> ('b -> Loc.t) -> unit method patt : formatter -> Ast.patt -> unit method patt1 : formatter -> Ast.patt -> unit method patt2 : formatter -> Ast.patt -> unit method patt3 : formatter -> Ast.patt -> unit method patt4 : formatter -> Ast.patt -> unit method patt5 : formatter -> Ast.patt -> unit method patt_tycon : formatter -> Ast.patt -> unit method patt_expr_fun_args : formatter -> (fun_binding * Ast.expr) -> unit method patt_class_expr_fun_args : formatter -> (Ast.patt * Ast.class_expr) -> unit method print_comments_before : Loc.t -> formatter -> unit method private_flag : formatter -> Ast.private_flag -> unit method virtual_flag : formatter -> Ast.virtual_flag -> unit method quoted_string : formatter -> string -> unit method raise_match_failure : formatter -> Loc.t -> unit method reset : 'a method reset_semi : 'a method semisep : sep method set_comments : bool -> 'a method set_curry_constr : bool -> 'a method set_loc_and_comments : 'a method set_semisep : sep -> 'a method simple_ctyp : formatter -> Ast.ctyp -> unit method simple_expr : formatter -> Ast.expr -> unit method simple_patt : formatter -> Ast.patt -> unit method seq : formatter -> Ast.expr -> unit method string : formatter -> string -> unit method sum_type : formatter -> Ast.ctyp -> unit method type_params : formatter -> Ast.ctyp list -> unit method class_params : formatter -> Ast.ctyp -> unit method under_pipe : 'a method under_semi : 'a method var : formatter -> string -> unit method with_constraint : formatter -> Ast.with_constr -> unit end val with_outfile : string option -> (formatter -> 'a -> unit) -> 'a -> unit val print : string option -> (printer -> formatter -> 'a -> unit) -> 'a -> unit end module MakeMore (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax. Ast).S end = struct open Format module Id = struct let name = "Camlp4.Printers.OCaml" let version = Sys.ocaml_version end module Make (Syntax : Sig.Camlp4Syntax) = struct include Syntax type sep = (unit, formatter, unit) format type fun_binding = [ | `patt of Ast.patt | `newtype of string ] let pp = fprintf let cut f = fprintf f "@ " let list' elt sep sep' f = let rec loop = function | [] -> () | x :: xs -> (pp f sep; elt f x; pp f sep'; loop xs) in function | [] -> () | [ x ] -> (elt f x; pp f sep') | x :: xs -> (elt f x; pp f sep'; loop xs) let list elt sep f = let rec loop = function | [] -> () | x :: xs -> (pp f sep; elt f x; loop xs) in function | [] -> () | [ x ] -> elt f x | x :: xs -> (elt f x; loop xs) let rec list_of_meta_list = function | Ast.LNil -> [] | Ast.LCons (x, xs) -> x :: (list_of_meta_list xs) | Ast.LAnt _ -> assert false let meta_list elt sep f mxs = let xs = list_of_meta_list mxs in list elt sep f xs module CommentFilter = Struct.CommentFilter.Make(Token) let comment_filter = CommentFilter.mk () let _ = CommentFilter.define (Gram.get_filter ()) comment_filter module StringSet = Set.Make(String) let infix_lidents = [ "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or" ] let is_infix = let first_chars = [ '='; '<'; '>'; '|'; '&'; '$'; '@'; '^'; '+'; '-'; '*'; '/'; '%'; '\\' ] and infixes = List.fold_right StringSet.add infix_lidents StringSet.empty in fun s -> (StringSet.mem s infixes) || ((s <> "") && (List.mem s.[0] first_chars)) let is_keyword = let keywords = List.fold_right StringSet.add [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module"; "mutable"; "new"; "object"; "of"; "open"; "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true"; "try"; "type"; "val"; "virtual"; "when"; "while"; "with" ] StringSet.empty in fun s -> StringSet.mem s keywords module Lexer = Struct.Lexer.Make(Token) let _ = let module M = ErrorHandler.Register(Lexer.Error) in () open Sig let lexer s = Lexer.from_string ~quotations: !Camlp4_config.quotations Loc. ghost s let lex_string str = try let (__strm : _ Stream.t) = lexer str in match Stream.peek __strm with | Some ((tok, _)) -> (Stream.junk __strm; (match Stream.peek __strm with | Some ((EOI, _)) -> (Stream.junk __strm; tok) | _ -> raise (Stream.Error ""))) | _ -> raise Stream.Failure with | Stream.Failure | Stream.Error _ -> failwith (sprintf "Cannot print %S this string contains more than one token" str) | Lexer.Error.E exn -> failwith (sprintf "Cannot print %S this identifier does not respect OCaml lexing rules (%s)" str (Lexer.Error.to_string exn)) let ocaml_char x = Char.escaped (Struct.Token.Eval.char x) let rec get_expr_args a al = match a with | Ast.ExApp (_, a1, a2) -> get_expr_args a1 (a2 :: al) | _ -> (a, al) let rec get_patt_args a al = match a with | Ast.PaApp (_, a1, a2) -> get_patt_args a1 (a2 :: al) | _ -> (a, al) let rec get_ctyp_args a al = match a with | Ast.TyApp (_, a1, a2) -> get_ctyp_args a1 (a2 :: al) | _ -> (a, al) let is_irrefut_patt = Ast.is_irrefut_patt let rec expr_fun_args = function | (Ast.ExFun (_, (Ast.McArr (_, p, (Ast.ExNil _), e))) as ge) -> if is_irrefut_patt p then (let (pl, e) = expr_fun_args e in (((`patt p) :: pl), e)) else ([], ge) | Ast.ExFUN (_, i, e) -> let (pl, e) = expr_fun_args e in (((`newtype i) :: pl), e) | ge -> ([], ge) let rec class_expr_fun_args = function | (Ast.CeFun (_, p, ce) as ge) -> if is_irrefut_patt p then (let (pl, ce) = class_expr_fun_args ce in ((p :: pl), ce)) else ([], ge) | ge -> ([], ge) let rec do_print_comments_before loc f (__strm : _ Stream.t) = match Stream.peek __strm with | Some ((comm, comm_loc)) when Loc.strictly_before comm_loc loc -> (Stream.junk __strm; let s = __strm in let () = f comm comm_loc in do_print_comments_before loc f s) | _ -> () class printer ?curry_constr:(init_curry_constr = false) ?(comments = true) () = object (o) val pipe = false val semi = false method under_pipe = {< pipe = true; >} method under_semi = {< semi = true; >} method reset_semi = {< semi = false; >} method reset = {< pipe = false; semi = false; >} val semisep = (";;" : sep) val no_semisep = ("" : sep) val mode = if comments then `comments else `no_comments val curry_constr = init_curry_constr val var_conversion = false method andsep : sep = "@]@ @[<2>and@ " method value_val = "val" method value_let = "let" method semisep = semisep method set_semisep = fun s -> {< semisep = s; >} method set_comments = fun b -> {< mode = if b then `comments else `no_comments; >} method set_loc_and_comments = {< mode = `loc_and_comments; >} method set_curry_constr = fun b -> {< curry_constr = b; >} method print_comments_before = fun loc f -> match mode with | `comments -> do_print_comments_before loc (fun c _ -> pp f "%s@ " c) (CommentFilter.take_stream comment_filter) | `loc_and_comments -> let () = pp f "(*loc: %a*)@ " Loc.dump loc in do_print_comments_before loc (fun s -> pp f "%s(*comm_loc: %a*)@ " s Loc.dump) (CommentFilter.take_stream comment_filter) | _ -> () method var = fun f -> function | "" -> pp f "$lid:\"\"$" | "[]" -> pp f "[]" | "()" -> pp f "()" | " True" -> pp f "True" | " False" -> pp f "False" | v -> (match (var_conversion, v) with | (true, "val") -> pp f "contents" | (true, "True") -> pp f "true" | (true, "False") -> pp f "false" | _ -> (match lex_string v with | LIDENT s | UIDENT s | ESCAPED_IDENT s when is_keyword s -> pp f "%s__" s | LIDENT s | ESCAPED_IDENT s when List.mem s infix_lidents -> pp f "( %s )" s | SYMBOL s -> pp f "( %s )" s | LIDENT s | UIDENT s | ESCAPED_IDENT s -> pp_print_string f s | tok -> failwith (sprintf "Bad token used as an identifier: %s" (Token.to_string tok)))) method type_params = fun f -> function | [] -> () | [ x ] -> pp f "%a@ " o#ctyp x | l -> pp f "@[<1>(%a)@]@ " (list o#ctyp ",@ ") l method class_params = fun f -> function | Ast.TyCom (_, t1, t2) -> pp f "@[<1>%a,@ %a@]" o#class_params t1 o#class_params t2 | x -> o#ctyp f x method override_flag = fun f -> function | Ast.OvOverride -> pp f "!" | Ast.OvNil -> () | Ast.OvAnt s -> o#anti f s method mutable_flag = fun f -> function | Ast.MuMutable -> pp f "mutable@ " | Ast.MuNil -> () | Ast.MuAnt s -> o#anti f s method rec_flag = fun f -> function | Ast.ReRecursive -> pp f "rec@ " | Ast.ReNil -> () | Ast.ReAnt s -> o#anti f s method virtual_flag = fun f -> function | Ast.ViVirtual -> pp f "virtual@ " | Ast.ViNil -> () | Ast.ViAnt s -> o#anti f s method private_flag = fun f -> function | Ast.PrPrivate -> pp f "private@ " | Ast.PrNil -> () | Ast.PrAnt s -> o#anti f s method anti = fun f s -> pp f "$%s$" s method seq = fun f -> function | Ast.ExSem (_, e1, e2) -> pp f "%a;@ %a" o#under_semi#seq e1 o#seq e2 | Ast.ExSeq (_, e) -> o#seq f e | e -> o#expr f e method match_case = fun f -> function | Ast.McNil _loc -> pp f "@[<2>@ _ ->@ %a@]" o#raise_match_failure _loc | a -> o#match_case_aux f a method match_case_aux = fun f -> function | Ast.McNil _ -> () | Ast.McAnt (_, s) -> o#anti f s | Ast.McOr (_, a1, a2) -> pp f "%a%a" o#match_case_aux a1 o#match_case_aux a2 | Ast.McArr (_, p, (Ast.ExNil _), e) -> pp f "@ | @[<2>%a@ ->@ %a@]" o#patt p o#under_pipe#expr e | Ast.McArr (_, p, w, e) -> pp f "@ | @[<2>%a@ when@ %a@ ->@ %a@]" o#patt p o#under_pipe#expr w o#under_pipe#expr e method fun_binding = fun f -> function | `patt p -> o#simple_patt f p | `newtype i -> pp f "(type %s)" i method binding = fun f bi -> let () = o#node f bi Ast.loc_of_binding in match bi with | Ast.BiNil _ -> () | Ast.BiAnd (_, b1, b2) -> (o#binding f b1; pp f o#andsep; o#binding f b2) | Ast.BiEq (_, p, e) -> let (pl, e') = (match p with | Ast.PaTyc (_, _, _) -> ([], e) | _ -> expr_fun_args e) in (match (p, e') with | (Ast.PaId (_, (Ast.IdLid (_, _))), Ast.ExTyc (_, e', t)) -> pp f "%a :@ %a =@ %a" (list o#fun_binding "@ ") ((`patt p) :: pl) o#ctyp t o#expr e' | (Ast.PaId (_, (Ast.IdLid (_, _))), _) -> pp f "%a @[<0>%a=@]@ %a" o#simple_patt p (list' o#fun_binding "" "@ ") pl o#expr e' | _ -> pp f "%a =@ %a" o#simple_patt p o#expr e) | Ast.BiAnt (_, s) -> o#anti f s method record_binding = fun f bi -> let () = o#node f bi Ast.loc_of_rec_binding in match bi with | Ast.RbNil _ -> () | Ast.RbEq (_, i, e) -> pp f "@ @[<2>%a =@ %a@];" o#var_ident i o#expr e | Ast.RbSem (_, b1, b2) -> (o#under_semi#record_binding f b1; o#under_semi#record_binding f b2) | Ast.RbAnt (_, s) -> o#anti f s method mk_patt_list = function | Ast.PaApp (_, (Ast.PaApp (_, (Ast.PaId (_, (Ast.IdUid (_, "::")))), p1)), p2) -> let (pl, c) = o#mk_patt_list p2 in ((p1 :: pl), c) | Ast.PaId (_, (Ast.IdUid (_, "[]"))) -> ([], None) | p -> ([], (Some p)) method mk_expr_list = function | Ast.ExApp (_, (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdUid (_, "::")))), e1)), e2) -> let (el, c) = o#mk_expr_list e2 in ((e1 :: el), c) | Ast.ExId (_, (Ast.IdUid (_, "[]"))) -> ([], None) | e -> ([], (Some e)) method expr_list = fun f -> function | [] -> pp f "[]" | [ e ] -> pp f "[ %a ]" o#under_semi#expr e | el -> pp f "@[<2>[ %a@] ]" (list o#under_semi#expr ";@ ") el method expr_list_cons = fun simple f e -> let (el, c) = o#mk_expr_list e in match c with | None -> o#expr_list f el | Some x -> (if simple then pp f "@[<2>(%a)@]" else pp f "@[<2>%a@]") (list o#under_semi#dot_expr " ::@ ") (el @ [ x ]) method patt_expr_fun_args = fun f (p, e) -> let (pl, e) = expr_fun_args e in pp f "%a@ ->@ %a" (list o#fun_binding "@ ") (p :: pl) o#expr e method patt_class_expr_fun_args = fun f (p, ce) -> let (pl, ce) = class_expr_fun_args ce in pp f "%a =@]@ %a" (list o#simple_patt "@ ") (p :: pl) o#class_expr ce method constrain = fun f (t1, t2) -> pp f "@[<2>constraint@ %a =@ %a@]" o#ctyp t1 o#ctyp t2 method sum_type = fun f t -> match Ast.list_of_ctyp t [] with | [] -> () | ts -> pp f "@[| %a@]" (list o#constructor_declaration "@ | ") ts method private constructor_declaration = fun f t -> match t with | Ast.TyCol (_, t1, (Ast.TyArr (_, t2, t3))) -> pp f "@[<2>%a :@ @[<2>%a@ ->@ %a@]@]" o#ctyp t1 o#constructor_type t2 o#ctyp t3 | t -> o#ctyp f t method string = fun f -> pp f "%s" method quoted_string = fun f -> pp f "%S" method numeric = fun f num suff -> if num.[0] = '-' then pp f "(%s%s)" num suff else pp f "%s%s" num suff method module_expr_get_functor_args = fun accu -> function | Ast.MeFun (_, s, mt, me) -> o#module_expr_get_functor_args ((s, mt) :: accu) me | Ast.MeTyc (_, me, mt) -> ((List.rev accu), me, (Some mt)) | me -> ((List.rev accu), me, None) method functor_args = fun f -> list o#functor_arg "@ " f method functor_arg = fun f (s, mt) -> pp f "@[<2>(%a :@ %a)@]" o#var s o#module_type mt method module_rec_binding = fun f -> function | Ast.MbNil _ -> () | Ast.MbColEq (_, s, mt, me) -> pp f "@[<2>%a :@ %a =@ %a@]" o#var s o#module_type mt o#module_expr me | Ast.MbCol (_, s, mt) -> pp f "@[<2>%a :@ %a@]" o#var s o#module_type mt | Ast.MbAnd (_, mb1, mb2) -> (o#module_rec_binding f mb1; pp f o#andsep; o#module_rec_binding f mb2) | Ast.MbAnt (_, s) -> o#anti f s method class_declaration = fun f -> function | Ast.CeTyc (_, ce, ct) -> pp f "%a :@ %a" o#class_expr ce o#class_type ct | ce -> o#class_expr f ce method raise_match_failure = fun f _loc -> let n = Loc.file_name _loc in let l = Loc.start_line _loc in let c = (Loc.start_off _loc) - (Loc.start_bol _loc) in o#expr f (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, "raise")))), (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "Match_failure")))), (Ast.ExStr (_loc, (Ast.safe_string_escaped n))))), (Ast.ExInt (_loc, (string_of_int l))))), (Ast.ExInt (_loc, (string_of_int c))))))) method node : 'a. formatter -> 'a -> ('a -> Loc.t) -> unit = fun f node loc_of_node -> o#print_comments_before (loc_of_node node) f method ident = fun f i -> let () = o#node f i Ast.loc_of_ident in match i with | Ast.IdAcc (_, i1, i2) -> pp f "%a.@,%a" o#ident i1 o#ident i2 | Ast.IdApp (_, i1, i2) -> pp f "%a@,(%a)" o#ident i1 o#ident i2 | Ast.IdAnt (_, s) -> o#anti f s | Ast.IdLid (_, s) | Ast.IdUid (_, s) -> o#var f s method private var_ident = {< var_conversion = true; >}#ident method expr = fun f e -> let () = o#node f e Ast.loc_of_expr in match e with | (Ast.ExLet (_, _, _, _) | Ast.ExLmd (_, _, _, _) as e) when semi -> pp f "(%a)" o#reset#expr e | (Ast.ExMat (_, _, _) | Ast.ExTry (_, _, _) | Ast.ExFun (_, _) as e) when pipe || semi -> pp f "(%a)" o#reset#expr e | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "~-")))), x) -> pp f "@[<2>-@ %a@]" o#dot_expr x | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "~-.")))), x) -> pp f "@[<2>-.@ %a@]" o#dot_expr x | Ast.ExApp (_, (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdUid (_, "::")))), _)), _) -> o#expr_list_cons false f e | Ast.ExApp (_loc, (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, n)))), x)), y) when is_infix n -> pp f "@[<2>%a@ %s@ %a@]" o#apply_expr x n o#apply_expr y | Ast.ExApp (_, x, y) -> let (a, al) = get_expr_args x [ y ] in if (not curry_constr) && (Ast.is_expr_constructor a) then (match al with | [ Ast.ExTup (_, _) ] -> pp f "@[<2>%a@ (%a)@]" o#apply_expr x o#expr y | [ _ ] -> pp f "@[<2>%a@ %a@]" o#apply_expr x o#apply_expr y | al -> pp f "@[<2>%a@ (%a)@]" o#apply_expr a (list o#under_pipe#apply_expr ",@ ") al) else pp f "@[<2>%a@]" (list o#apply_expr "@ ") (a :: al) | Ast.ExAss (_, (Ast.ExAcc (_, e1, (Ast.ExId (_, (Ast.IdLid (_, "val")))))), e2) -> pp f "@[<2>%a :=@ %a@]" o#dot_expr e1 o#expr e2 | Ast.ExAss (_, e1, e2) -> pp f "@[<2>%a@ <-@ %a@]" o#dot_expr e1 o#expr e2 | Ast.ExFun (loc, (Ast.McNil _)) -> pp f "@[<2>fun@ _@ ->@ %a@]" o#raise_match_failure loc | Ast.ExFun (_, (Ast.McArr (_, p, (Ast.ExNil _), e))) when is_irrefut_patt p -> pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args ((`patt p), e) | Ast.ExFUN (_, i, e) -> pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args ((`newtype i), e) | Ast.ExFun (_, a) -> pp f "@[function%a@]" o#match_case a | Ast.ExIfe (_, e1, e2, e3) -> pp f "@[@[<2>if@ %a@]@ @[<2>then@ %a@]@ @[<2>else@ %a@]@]" o#expr e1 o#under_semi#expr e2 o#under_semi#expr e3 | Ast.ExLaz (_, e) -> pp f "@[<2>lazy@ %a@]" o#simple_expr e | Ast.ExLet (_, r, bi, e) -> (match e with | Ast.ExLet (_, _, _, _) -> pp f "@[<0>@[<2>let %a%a in@]@ %a@]" o#rec_flag r o#binding bi o#reset_semi#expr e | _ -> pp f "@[@[<2>let %a%a@]@ @[in@ %a@]@]" o#rec_flag r o#binding bi o#reset_semi#expr e) | Ast.ExOpI (_, i, e) -> pp f "@[<2>let open %a@]@ @[<2>in@ %a@]" o#ident i o#reset_semi#expr e | Ast.ExMat (_, e, a) -> pp f "@[@[@[<2>match %a@]@ with@]%a@]" o#expr e o#match_case a | Ast.ExTry (_, e, a) -> pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" o#expr e o#match_case a | Ast.ExAsf _ -> pp f "@[<2>assert@ false@]" | Ast.ExAsr (_, e) -> pp f "@[<2>assert@ %a@]" o#dot_expr e | Ast.ExLmd (_, s, me, e) -> pp f "@[<2>let module %a =@ %a@]@ @[<2>in@ %a@]" o#var s o#module_expr me o#reset_semi#expr e | Ast.ExObj (_, (Ast.PaNil _), cst) -> pp f "@[@[object@ %a@]@ end@]" o#class_str_item cst | Ast.ExObj (_, (Ast.PaTyc (_, p, t)), cst) -> pp f "@[@[object @[<1>(%a :@ %a)@]@ %a@]@ end@]" o#patt p o#ctyp t o#class_str_item cst | Ast.ExObj (_, p, cst) -> pp f "@[@[object @[<2>(%a)@]@ %a@]@ end@]" o#patt p o#class_str_item cst | e -> o#apply_expr f e method apply_expr = fun f e -> let () = o#node f e Ast.loc_of_expr in match e with | Ast.ExNew (_, i) -> pp f "@[<2>new@ %a@]" o#ident i | e -> o#dot_expr f e method dot_expr = fun f e -> let () = o#node f e Ast.loc_of_expr in match e with | Ast.ExAcc (_, e, (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> pp f "@[<2>!@,%a@]" o#simple_expr e | Ast.ExAcc (_, e1, e2) -> pp f "@[<2>%a.@,%a@]" o#dot_expr e1 o#dot_expr e2 | Ast.ExAre (_, e1, e2) -> pp f "@[<2>%a.@,(%a)@]" o#dot_expr e1 o#expr e2 | Ast.ExSte (_, e1, e2) -> pp f "%a.@[<1>[@,%a@]@,]" o#dot_expr e1 o#expr e2 | Ast.ExSnd (_, e, s) -> pp f "@[<2>%a#@,%s@]" o#dot_expr e s | e -> o#simple_expr f e method simple_expr = fun f e -> let () = o#node f e Ast.loc_of_expr in match e with | Ast.ExNil _ -> () | Ast.ExSeq (_, e) -> pp f "@[(%a)@]" o#seq e | Ast.ExApp (_, (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdUid (_, "::")))), _)), _) -> o#expr_list_cons true f e | Ast.ExTup (_, e) -> pp f "@[<1>(%a)@]" o#expr e | Ast.ExArr (_, e) -> pp f "@[<0>@[<2>[|@ %a@]@ |]@]" o#under_semi#expr e | Ast.ExCoe (_, e, (Ast.TyNil _), t) -> pp f "@[<2>(%a :>@ %a)@]" o#expr e o#ctyp t | Ast.ExCoe (_, e, t1, t2) -> pp f "@[<2>(%a :@ %a :>@ %a)@]" o#expr e o#ctyp t1 o#ctyp t2 | Ast.ExTyc (_, e, t) -> pp f "@[<2>(%a :@ %a)@]" o#expr e o#ctyp t | Ast.ExAnt (_, s) -> o#anti f s | Ast.ExFor (_, s, e1, e2, df, e3) -> pp f "@[@[@[<2>for %a =@ %a@ %a@ %a@ do@]@ %a@]@ done@]" o#var s o#expr e1 o#direction_flag df o#expr e2 o#seq e3 | Ast.ExInt (_, s) -> o#numeric f s "" | Ast.ExNativeInt (_, s) -> o#numeric f s "n" | Ast.ExInt64 (_, s) -> o#numeric f s "L" | Ast.ExInt32 (_, s) -> o#numeric f s "l" | Ast.ExFlo (_, s) -> o#numeric f s "" | Ast.ExChr (_, s) -> pp f "'%s'" (ocaml_char s) | Ast.ExId (_, i) -> o#var_ident f i | Ast.ExRec (_, b, (Ast.ExNil _)) -> pp f "@[@[{%a@]@ }@]" o#record_binding b | Ast.ExRec (_, b, e) -> pp f "@[@[{@ (%a)@ with%a@]@ }@]" o#expr e o#record_binding b | Ast.ExStr (_, s) -> pp f "\"%s\"" s | Ast.ExWhi (_, e1, e2) -> pp f "@[<2>while@ %a@ do@ %a@ done@]" o#expr e1 o#seq e2 | Ast.ExLab (_, s, (Ast.ExNil _)) -> pp f "~%s" s | Ast.ExLab (_, s, e) -> pp f "@[<2>~%s:@ %a@]" s o#dot_expr e | Ast.ExOlb (_, s, (Ast.ExNil _)) -> pp f "?%s" s | Ast.ExOlb (_, s, e) -> pp f "@[<2>?%s:@ %a@]" s o#dot_expr e | Ast.ExVrn (_, s) -> pp f "`%a" o#var s | Ast.ExOvr (_, b) -> pp f "@[@[{<%a@]@ >}@]" o#record_binding b | Ast.ExCom (_, e1, e2) -> pp f "%a,@ %a" o#simple_expr e1 o#simple_expr e2 | Ast.ExSem (_, e1, e2) -> pp f "%a;@ %a" o#under_semi#expr e1 o#expr e2 | Ast.ExPkg (_, (Ast.MeTyc (_, me, mt))) -> pp f "@[@[(module %a : %a@])@]" o#module_expr me o#module_type mt | Ast.ExPkg (_, me) -> pp f "@[@[(module %a@])@]" o#module_expr me | Ast.ExApp (_, _, _) | Ast.ExAcc (_, _, _) | Ast.ExAre (_, _, _) | Ast.ExSte (_, _, _) | Ast.ExAss (_, _, _) | Ast.ExSnd (_, _, _) | Ast.ExFun (_, _) | Ast.ExFUN (_, _, _) | Ast.ExMat (_, _, _) | Ast.ExTry (_, _, _) | Ast.ExIfe (_, _, _, _) | Ast.ExLet (_, _, _, _) | Ast.ExLmd (_, _, _, _) | Ast.ExOpI (_, _, _) | Ast.ExAsr (_, _) | Ast.ExAsf _ | Ast.ExLaz (_, _) | Ast.ExNew (_, _) | Ast.ExObj (_, _, _) -> pp f "(%a)" o#reset#expr e method direction_flag = fun f b -> match b with | Ast.DiTo -> pp_print_string f "to" | Ast.DiDownto -> pp_print_string f "downto" | Ast.DiAnt s -> o#anti f s method patt = fun f p -> let () = o#node f p Ast.loc_of_patt in match p with | Ast.PaAli (_, p1, p2) -> pp f "@[<1>(%a@ as@ %a)@]" o#patt p1 o#patt p2 | Ast.PaEq (_, i, p) -> pp f "@[<2>%a =@ %a@]" o#var_ident i o#patt p | Ast.PaSem (_, p1, p2) -> pp f "%a;@ %a" o#patt p1 o#patt p2 | p -> o#patt1 f p method patt1 = fun f -> function | Ast.PaOrp (_, p1, p2) -> pp f "@[<2>%a@ |@ %a@]" o#patt1 p1 o#patt2 p2 | p -> o#patt2 f p method patt2 = fun f p -> o#patt3 f p method patt3 = fun f -> function | Ast.PaRng (_, p1, p2) -> pp f "@[<2>%a@ ..@ %a@]" o#patt3 p1 o#patt4 p2 | Ast.PaCom (_, p1, p2) -> pp f "%a,@ %a" o#patt3 p1 o#patt3 p2 | p -> o#patt4 f p method patt4 = fun f -> function | (Ast.PaApp (_, (Ast.PaApp (_, (Ast.PaId (_, (Ast.IdUid (_, "::")))), _)), _) as p) -> let (pl, c) = o#mk_patt_list p in (match c with | None -> pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl | Some x -> pp f "@[<2>%a@]" (list o#patt5 " ::@ ") (pl @ [ x ])) | p -> o#patt5 f p method patt5 = fun f -> function | (Ast.PaApp (_, (Ast.PaApp (_, (Ast.PaId (_, (Ast.IdUid (_, "::")))), _)), _) as p) -> o#simple_patt f p | Ast.PaLaz (_, p) -> pp f "@[<2>lazy %a@]" o#simple_patt p | Ast.PaApp (_, x, y) -> let (a, al) = get_patt_args x [ y ] in if not (Ast.is_patt_constructor a) then Format.eprintf "WARNING: strange pattern application of a non constructor@." else if curry_constr then pp f "@[<2>%a@]" (list o#simple_patt "@ ") (a :: al) else (match al with | [ Ast.PaTup (_, _) ] -> pp f "@[<2>%a@ (%a)@]" o#simple_patt x o#patt y | [ _ ] -> pp f "@[<2>%a@ %a@]" o#patt5 x o#simple_patt y | al -> pp f "@[<2>%a@ (%a)@]" o#patt5 a (list o#simple_patt ",@ ") al) | p -> o#simple_patt f p method simple_patt = fun f p -> let () = o#node f p Ast.loc_of_patt in match p with | Ast.PaNil _ -> () | Ast.PaId (_, i) -> o#var_ident f i | Ast.PaAnt (_, s) -> o#anti f s | Ast.PaAny _ -> pp f "_" | Ast.PaMod (_, m) -> pp f "(module %s)" m | Ast.PaTup (_, p) -> pp f "@[<1>(%a)@]" o#patt3 p | Ast.PaRec (_, p) -> pp f "@[{@ %a@]@ }" o#patt p | Ast.PaStr (_, s) -> pp f "\"%s\"" s | Ast.PaTyc (_, p, t) -> pp f "@[<1>(%a :@ %a)@]" o#patt p o#ctyp t | Ast.PaNativeInt (_, s) -> o#numeric f s "n" | Ast.PaInt64 (_, s) -> o#numeric f s "L" | Ast.PaInt32 (_, s) -> o#numeric f s "l" | Ast.PaInt (_, s) -> o#numeric f s "" | Ast.PaFlo (_, s) -> o#numeric f s "" | Ast.PaChr (_, s) -> pp f "'%s'" (ocaml_char s) | Ast.PaLab (_, s, (Ast.PaNil _)) -> pp f "~%s" s | Ast.PaVrn (_, s) -> pp f "`%a" o#var s | Ast.PaTyp (_, i) -> pp f "@[<2>#%a@]" o#ident i | Ast.PaArr (_, p) -> pp f "@[<2>[|@ %a@]@ |]" o#patt p | Ast.PaLab (_, s, p) -> pp f "@[<2>~%s:@ (%a)@]" s o#patt p | Ast.PaOlb (_, s, (Ast.PaNil _)) -> pp f "?%s" s | Ast.PaOlb (_, "", p) -> pp f "@[<2>?(%a)@]" o#patt_tycon p | Ast.PaOlb (_, s, p) -> pp f "@[<2>?%s:@,@[<1>(%a)@]@]" s o#patt_tycon p | Ast.PaOlbi (_, "", p, e) -> pp f "@[<2>?(%a =@ %a)@]" o#patt_tycon p o#expr e | Ast.PaOlbi (_, s, p, e) -> pp f "@[<2>?%s:@,@[<1>(%a =@ %a)@]@]" s o#patt_tycon p o#expr e | (Ast.PaApp (_, _, _) | Ast.PaAli (_, _, _) | Ast.PaOrp (_, _, _) | Ast.PaRng (_, _, _) | Ast.PaCom (_, _, _) | Ast.PaSem (_, _, _) | Ast.PaEq (_, _, _) | Ast.PaLaz (_, _) as p) -> pp f "@[<1>(%a)@]" o#patt p method patt_tycon = fun f -> function | Ast.PaTyc (_, p, t) -> pp f "%a :@ %a" o#patt p o#ctyp t | p -> o#patt f p method simple_ctyp = fun f t -> let () = o#node f t Ast.loc_of_ctyp in match t with | Ast.TyId (_, i) -> o#ident f i | Ast.TyAnt (_, s) -> o#anti f s | Ast.TyAny _ -> pp f "_" | Ast.TyAnP _ -> pp f "+_" | Ast.TyAnM _ -> pp f "-_" | Ast.TyLab (_, s, t) -> pp f "@[<2>%s:@ %a@]" s o#simple_ctyp t | Ast.TyOlb (_, s, t) -> pp f "@[<2>?%s:@ %a@]" s o#simple_ctyp t | Ast.TyObj (_, (Ast.TyNil _), Ast.RvNil) -> pp f "< >" | Ast.TyObj (_, (Ast.TyNil _), Ast.RvRowVar) -> pp f "< .. >" | Ast.TyObj (_, t, Ast.RvRowVar) -> pp f "@[<0>@[<2><@ %a;@ ..@]@ >@]" o#ctyp t | Ast.TyObj (_, t, Ast.RvNil) -> pp f "@[<0>@[<2><@ %a@]@ >@]" o#ctyp t | Ast.TyQuo (_, s) -> pp f "'%a" o#var s | Ast.TyRec (_, t) -> pp f "@[<2>{@ %a@]@ }" o#ctyp t | Ast.TySum (_, t) -> pp f "@[<0>%a@]" o#sum_type t | Ast.TyTup (_, t) -> pp f "@[<1>(%a)@]" o#ctyp t | Ast.TyPkg (_, mt) -> pp f "@[<2>(module@ %a@])" o#module_type mt | Ast.TyVrnEq (_, t) -> pp f "@[<2>[@ %a@]@ ]" o#sum_type t | Ast.TyVrnInf (_, t) -> pp f "@[<2>[<@ %a@]@,]" o#sum_type t | Ast.TyVrnInfSup (_, t1, t2) -> let (a, al) = get_ctyp_args t2 [] in pp f "@[<2>[<@ %a@ >@ %a@]@ ]" o#sum_type t1 (list o#simple_ctyp "@ ") (a :: al) | Ast.TyVrnSup (_, t) -> pp f "@[<2>[>@ %a@]@,]" o#sum_type t | Ast.TyCls (_, i) -> pp f "@[<2>#%a@]" o#ident i | Ast.TyVrn (_, s) -> pp f "`%a" o#var s | Ast.TySta (_, t1, t2) -> pp f "%a *@ %a" o#simple_ctyp t1 o#simple_ctyp t2 | Ast.TyNil _ -> assert false | t -> pp f "@[<1>(%a)@]" o#ctyp t method ctyp = fun f t -> let () = o#node f t Ast.loc_of_ctyp in match t with | Ast.TyAli (_, t1, t2) -> pp f "@[<2>%a@ as@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 | Ast.TyArr (_, t1, t2) -> pp f "@[<2>%a@ ->@ %a@]" o#ctyp1 t1 o#ctyp t2 | Ast.TyQuP (_, s) -> pp f "+'%a" o#var s | Ast.TyQuM (_, s) -> pp f "-'%a" o#var s | Ast.TyOr (_, t1, t2) -> pp f "%a@ | %a" o#ctyp t1 o#ctyp t2 | Ast.TyCol (_, t1, (Ast.TyMut (_, t2))) -> pp f "@[mutable@ %a :@ %a@]" o#ctyp t1 o#ctyp t2 | Ast.TyCol (_, t1, t2) -> pp f "@[<2>%a :@ %a@]" o#ctyp t1 o#ctyp t2 | Ast.TySem (_, t1, t2) -> pp f "%a;@ %a" o#ctyp t1 o#ctyp t2 | Ast.TyOf (_, t, (Ast.TyNil _)) -> o#ctyp f t | Ast.TyOf (_, t1, t2) -> pp f "@[%a@ @[<3>of@ %a@]@]" o#ctyp t1 o#constructor_type t2 | Ast.TyOfAmp (_, t1, t2) -> pp f "@[%a@ @[<3>of &@ %a@]@]" o#ctyp t1 o#constructor_type t2 | Ast.TyAnd (_, t1, t2) -> pp f "%a@ and %a" o#ctyp t1 o#ctyp t2 | Ast.TyMut (_, t) -> pp f "@[<2>mutable@ %a@]" o#ctyp t | Ast.TyAmp (_, t1, t2) -> pp f "%a@ &@ %a" o#ctyp t1 o#ctyp t2 | Ast.TyMan (_, t1, t2) -> pp f "@[<2>%a =@ %a@]" o#simple_ctyp t1 o#ctyp t2 | Ast.TyDcl (_, tn, tp, te, cl) -> (pp f "@[<2>%a%a@]" o#type_params tp o#var tn; (match te with | Ast.TyNil _ -> () | _ -> pp f " =@ %a" o#ctyp te); if cl <> [] then pp f "@ %a" (list o#constrain "@ ") cl else ()) | t -> o#ctyp1 f t method ctyp1 = fun f -> function | Ast.TyApp (_, t1, t2) -> (match get_ctyp_args t1 [ t2 ] with | (_, [ _ ]) -> pp f "@[<2>%a@ %a@]" o#simple_ctyp t2 o#simple_ctyp t1 | (a, al) -> pp f "@[<2>(%a)@ %a@]" (list o#ctyp ",@ ") al o#simple_ctyp a) | Ast.TyPol (_, t1, t2) -> let (a, al) = get_ctyp_args t1 [] in pp f "@[<2>%a.@ %a@]" (list o#ctyp "@ ") (a :: al) o#ctyp t2 | Ast.TyTypePol ((_, t1, t2)) -> let (a, al) = get_ctyp_args t1 [] in pp f "@[<2>type %a.@ %a@]" (list o#ctyp "@ ") (a :: al) o#ctyp t2 | Ast.TyPrv (_, t) -> pp f "@[private@ %a@]" o#simple_ctyp t | t -> o#simple_ctyp f t method constructor_type = fun f t -> match t with | Ast.TyAnd (loc, t1, t2) -> let () = o#node f t (fun _ -> loc) in pp f "%a@ * %a" o#constructor_type t1 o#constructor_type t2 | Ast.TyArr (_, _, _) -> pp f "(%a)" o#ctyp t | t -> o#ctyp f t method sig_item = fun f sg -> let () = o#node f sg Ast.loc_of_sig_item in match sg with | Ast.SgNil _ -> () | Ast.SgSem (_, sg, (Ast.SgNil _)) | Ast.SgSem (_, (Ast.SgNil _), sg) -> o#sig_item f sg | Ast.SgSem (_, sg1, sg2) -> (o#sig_item f sg1; cut f; o#sig_item f sg2) | Ast.SgExc (_, t) -> pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep | Ast.SgExt (_, s, t, sl) -> pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]" o#var s o#ctyp t (meta_list o#quoted_string "@ ") sl semisep | Ast.SgMod (_, s1, (Ast.MtFun (_, s2, mt1, mt2))) -> let rec loop accu = (function | Ast.MtFun (_, s, mt1, mt2) -> loop ((s, mt1) :: accu) mt2 | mt -> ((List.rev accu), mt)) in let (al, mt) = loop [ (s2, mt1) ] mt2 in pp f "@[<2>module %a@ @[<0>%a@] :@ %a%(%)@]" o#var s1 o#functor_args al o#module_type mt semisep | Ast.SgMod (_, s, mt) -> pp f "@[<2>module %a :@ %a%(%)@]" o#var s o#module_type mt semisep | Ast.SgMty (_, s, (Ast.MtNil _)) -> pp f "@[<2>module type %a%(%)@]" o#var s semisep | Ast.SgMty (_, s, mt) -> pp f "@[<2>module type %a =@ %a%(%)@]" o#var s o#module_type mt semisep | Ast.SgOpn (_, sl) -> pp f "@[<2>open@ %a%(%)@]" o#ident sl semisep | Ast.SgTyp (_, t) -> pp f "@[@[type %a@]%(%)@]" o#ctyp t semisep | Ast.SgVal (_, s, t) -> pp f "@[<2>%s %a :@ %a%(%)@]" o#value_val o#var s o#ctyp t semisep | Ast.SgInc (_, mt) -> pp f "@[<2>include@ %a%(%)@]" o#module_type mt semisep | Ast.SgClt (_, ct) -> pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep | Ast.SgCls (_, ce) -> pp f "@[<2>class %a%(%)@]" o#class_type ce semisep | Ast.SgRecMod (_, mb) -> pp f "@[<2>module rec %a%(%)@]" o#module_rec_binding mb semisep | Ast.SgDir (_, _, _) -> () | Ast.SgAnt (_, s) -> pp f "%a%(%)" o#anti s semisep method str_item = fun f st -> let () = o#node f st Ast.loc_of_str_item in match st with | Ast.StNil _ -> () | Ast.StSem (_, st, (Ast.StNil _)) | Ast.StSem (_, (Ast.StNil _), st) -> o#str_item f st | Ast.StSem (_, st1, st2) -> (o#str_item f st1; cut f; o#str_item f st2) | Ast.StExc (_, t, Ast.ONone) -> pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep | Ast.StExc (_, t, (Ast.OSome sl)) -> pp f "@[<2>exception@ %a =@ %a%(%)@]" o#ctyp t o#ident sl semisep | Ast.StExt (_, s, t, sl) -> pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]" o#var s o#ctyp t (meta_list o#quoted_string "@ ") sl semisep | Ast.StMod (_, s1, (Ast.MeFun (_, s2, mt1, me))) -> (match o#module_expr_get_functor_args [ (s2, mt1) ] me with | (al, me, Some mt2) -> pp f "@[<2>module %a@ @[<0>%a@] :@ %a =@ %a%(%)@]" o#var s1 o#functor_args al o#module_type mt2 o#module_expr me semisep | (al, me, _) -> pp f "@[<2>module %a@ @[<0>%a@] =@ %a%(%)@]" o#var s1 o#functor_args al o#module_expr me semisep) | Ast.StMod (_, s, (Ast.MeTyc (_, me, mt))) -> pp f "@[<2>module %a :@ %a =@ %a%(%)@]" o#var s o#module_type mt o#module_expr me semisep | Ast.StMod (_, s, me) -> pp f "@[<2>module %a =@ %a%(%)@]" o#var s o#module_expr me semisep | Ast.StMty (_, s, mt) -> pp f "@[<2>module type %a =@ %a%(%)@]" o#var s o#module_type mt semisep | Ast.StOpn (_, sl) -> pp f "@[<2>open@ %a%(%)@]" o#ident sl semisep | Ast.StTyp (_, t) -> pp f "@[@[type %a@]%(%)@]" o#ctyp t semisep | Ast.StVal (_, r, bi) -> pp f "@[<2>%s %a%a%(%)@]" o#value_let o#rec_flag r o#binding bi semisep | Ast.StExp (_, e) -> pp f "@[<2>let _ =@ %a%(%)@]" o#expr e semisep | Ast.StInc (_, me) -> pp f "@[<2>include@ %a%(%)@]" o#simple_module_expr me semisep | Ast.StClt (_, ct) -> pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep | Ast.StCls (_, ce) -> pp f "@[class %a%(%)@]" o#class_declaration ce semisep | Ast.StRecMod (_, mb) -> pp f "@[<2>module rec %a%(%)@]" o#module_rec_binding mb semisep | Ast.StDir (_, _, _) -> () | Ast.StAnt (_, s) -> pp f "%a%(%)" o#anti s semisep | Ast.StExc (_, _, (Ast.OAnt _)) -> assert false method module_type = fun f mt -> let () = o#node f mt Ast.loc_of_module_type in match mt with | Ast.MtNil _ -> assert false | Ast.MtOf (_, me) -> pp f "@[<2>module type of@ %a@]" o#module_expr me | Ast.MtId (_, i) -> o#ident f i | Ast.MtAnt (_, s) -> o#anti f s | Ast.MtFun (_, s, mt1, mt2) -> pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" o#var s o#module_type mt1 o#module_type mt2 | Ast.MtQuo (_, s) -> pp f "'%a" o#var s | Ast.MtSig (_, sg) -> pp f "@[@[sig@ %a@]@ end@]" o#sig_item sg | Ast.MtWit (_, mt, wc) -> pp f "@[<2>%a@ with@ %a@]" o#module_type mt o#with_constraint wc method with_constraint = fun f wc -> let () = o#node f wc Ast.loc_of_with_constr in match wc with | Ast.WcNil _ -> () | Ast.WcTyp (_, t1, t2) -> pp f "@[<2>type@ %a =@ %a@]" o#ctyp t1 o#ctyp t2 | Ast.WcMod (_, i1, i2) -> pp f "@[<2>module@ %a =@ %a@]" o#ident i1 o#ident i2 | Ast.WcTyS (_, t1, t2) -> pp f "@[<2>type@ %a :=@ %a@]" o#ctyp t1 o#ctyp t2 | Ast.WcMoS (_, i1, i2) -> pp f "@[<2>module@ %a :=@ %a@]" o#ident i1 o#ident i2 | Ast.WcAnd (_, wc1, wc2) -> (o#with_constraint f wc1; pp f o#andsep; o#with_constraint f wc2) | Ast.WcAnt (_, s) -> o#anti f s method module_expr = fun f me -> let () = o#node f me Ast.loc_of_module_expr in match me with | Ast.MeNil _ -> assert false | Ast.MeTyc (_, (Ast.MeStr (_, st)), (Ast.MtSig (_, sg))) -> pp f "@[<2>@[struct@ %a@]@ end :@ @[sig@ %a@]@ end@]" o#str_item st o#sig_item sg | _ -> o#simple_module_expr f me method simple_module_expr = fun f me -> let () = o#node f me Ast.loc_of_module_expr in match me with | Ast.MeNil _ -> assert false | Ast.MeId (_, i) -> o#ident f i | Ast.MeAnt (_, s) -> o#anti f s | Ast.MeApp (_, me1, me2) -> pp f "@[<2>%a@,(%a)@]" o#module_expr me1 o#module_expr me2 | Ast.MeFun (_, s, mt, me) -> pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" o#var s o#module_type mt o#module_expr me | Ast.MeStr (_, st) -> pp f "@[@[struct@ %a@]@ end@]" o#str_item st | Ast.MeTyc (_, me, mt) -> pp f "@[<1>(%a :@ %a)@]" o#module_expr me o#module_type mt | Ast.MePkg (_, (Ast.ExTyc (_, e, (Ast.TyPkg (_, mt))))) -> pp f "@[<1>(%s %a :@ %a)@]" o#value_val o#expr e o#module_type mt | Ast.MePkg (_, e) -> pp f "@[<1>(%s %a)@]" o#value_val o#expr e method class_expr = fun f ce -> let () = o#node f ce Ast.loc_of_class_expr in match ce with | Ast.CeApp (_, ce, e) -> pp f "@[<2>%a@ %a@]" o#class_expr ce o#apply_expr e | Ast.CeCon (_, Ast.ViNil, i, (Ast.TyNil _)) -> pp f "@[<2>%a@]" o#ident i | Ast.CeCon (_, Ast.ViNil, i, t) -> pp f "@[<2>@[<1>[%a]@]@ %a@]" o#class_params t o#ident i | Ast.CeCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), (Ast.TyNil _)) -> pp f "@[<2>virtual@ %a@]" o#var i | Ast.CeCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), t) -> pp f "@[<2>virtual@ @[<1>[%a]@]@ %a@]" o#class_params t o#var i | Ast.CeFun (_, p, ce) -> pp f "@[<2>fun@ %a@ ->@ %a@]" o#simple_patt p o#class_expr ce | Ast.CeLet (_, r, bi, ce) -> pp f "@[<2>let %a%a@]@ @[<2>in@ %a@]" o#rec_flag r o#binding bi o#class_expr ce | Ast.CeStr (_, (Ast.PaNil _), cst) -> pp f "@[@[object %a@]@ end@]" o#class_str_item cst | Ast.CeStr (_, p, cst) -> pp f "@[@[object @[<1>(%a)@]@ %a@]@ end@]" o#patt p o#class_str_item cst | Ast.CeTyc (_, ce, ct) -> pp f "@[<1>(%a :@ %a)@]" o#class_expr ce o#class_type ct | Ast.CeAnt (_, s) -> o#anti f s | Ast.CeAnd (_, ce1, ce2) -> (o#class_expr f ce1; pp f o#andsep; o#class_expr f ce2) | Ast.CeEq (_, ce1, (Ast.CeFun (_, p, ce2))) when is_irrefut_patt p -> pp f "@[<2>%a@ %a" o#class_expr ce1 o#patt_class_expr_fun_args (p, ce2) | Ast.CeEq (_, ce1, ce2) -> pp f "@[<2>%a =@]@ %a" o#class_expr ce1 o#class_expr ce2 | _ -> assert false method class_type = fun f ct -> let () = o#node f ct Ast.loc_of_class_type in match ct with | Ast.CtCon (_, Ast.ViNil, i, (Ast.TyNil _)) -> pp f "@[<2>%a@]" o#ident i | Ast.CtCon (_, Ast.ViNil, i, t) -> pp f "@[<2>[@,%a@]@,]@ %a" o#class_params t o#ident i | Ast.CtCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), (Ast.TyNil _)) -> pp f "@[<2>virtual@ %a@]" o#var i | Ast.CtCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), t) -> pp f "@[<2>virtual@ [@,%a@]@,]@ %a" o#class_params t o#var i | Ast.CtFun (_, t, ct) -> pp f "@[<2>%a@ ->@ %a@]" o#simple_ctyp t o#class_type ct | Ast.CtSig (_, (Ast.TyNil _), csg) -> pp f "@[@[object@ %a@]@ end@]" o#class_sig_item csg | Ast.CtSig (_, t, csg) -> pp f "@[@[object @[<1>(%a)@]@ %a@]@ end@]" o#ctyp t o#class_sig_item csg | Ast.CtAnt (_, s) -> o#anti f s | Ast.CtAnd (_, ct1, ct2) -> (o#class_type f ct1; pp f o#andsep; o#class_type f ct2) | Ast.CtCol (_, ct1, ct2) -> pp f "%a :@ %a" o#class_type ct1 o#class_type ct2 | Ast.CtEq (_, ct1, ct2) -> pp f "%a =@ %a" o#class_type ct1 o#class_type ct2 | _ -> assert false method class_sig_item = fun f csg -> let () = o#node f csg Ast.loc_of_class_sig_item in match csg with | Ast.CgNil _ -> () | Ast.CgSem (_, csg, (Ast.CgNil _)) | Ast.CgSem (_, (Ast.CgNil _), csg) -> o#class_sig_item f csg | Ast.CgSem (_, csg1, csg2) -> (o#class_sig_item f csg1; cut f; o#class_sig_item f csg2) | Ast.CgCtr (_, t1, t2) -> pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep | Ast.CgInh (_, ct) -> pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct no_semisep | Ast.CgMth (_, s, pr, t) -> pp f "@[<2>method %a%a :@ %a%(%)@]" o#private_flag pr o#var s o#ctyp t no_semisep | Ast.CgVir (_, s, pr, t) -> pp f "@[<2>method virtual %a%a :@ %a%(%)@]" o#private_flag pr o#var s o#ctyp t no_semisep | Ast.CgVal (_, s, mu, vi, t) -> pp f "@[<2>%s %a%a%a :@ %a%(%)@]" o#value_val o#mutable_flag mu o#virtual_flag vi o#var s o#ctyp t no_semisep | Ast.CgAnt (_, s) -> pp f "%a%(%)" o#anti s no_semisep method class_str_item = fun f cst -> let () = o#node f cst Ast.loc_of_class_str_item in match cst with | Ast.CrNil _ -> () | Ast.CrSem (_, cst, (Ast.CrNil _)) | Ast.CrSem (_, (Ast.CrNil _), cst) -> o#class_str_item f cst | Ast.CrSem (_, cst1, cst2) -> (o#class_str_item f cst1; cut f; o#class_str_item f cst2) | Ast.CrCtr (_, t1, t2) -> pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep | Ast.CrInh (_, ov, ce, "") -> pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov o#class_expr ce no_semisep | Ast.CrInh (_, ov, ce, s) -> pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" o#override_flag ov o#class_expr ce o#var s no_semisep | Ast.CrIni (_, e) -> pp f "@[<2>initializer@ %a%(%)@]" o#expr e no_semisep | Ast.CrMth (_, s, ov, pr, e, (Ast.TyNil _)) -> pp f "@[<2>method%a %a%a =@ %a%(%)@]" o#override_flag ov o#private_flag pr o#var s o#expr e no_semisep | Ast.CrMth (_, s, ov, pr, e, t) -> pp f "@[<2>method%a %a%a :@ %a =@ %a%(%)@]" o#override_flag ov o#private_flag pr o#var s o#ctyp t o#expr e no_semisep | Ast.CrVir (_, s, pr, t) -> pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]" o#private_flag pr o#var s o#ctyp t no_semisep | Ast.CrVvr (_, s, mu, t) -> pp f "@[<2>%s virtual %a%a :@ %a%(%)@]" o#value_val o#mutable_flag mu o#var s o#ctyp t no_semisep | Ast.CrVal (_, s, ov, mu, e) -> pp f "@[<2>%s%a %a%a =@ %a%(%)@]" o#value_val o#override_flag ov o#mutable_flag mu o#var s o#expr e no_semisep | Ast.CrAnt (_, s) -> pp f "%a%(%)" o#anti s no_semisep method implem = fun f st -> match st with | Ast.StExp (_, e) -> pp f "@[<0>%a%(%)@]@." o#expr e semisep | st -> pp f "@[%a@]@." o#str_item st method interf = fun f sg -> pp f "@[%a@]@." o#sig_item sg end let with_outfile output_file fct arg = let call close f = ((try fct f arg with | exn -> (close (); raise exn)); close ()) in match output_file with | None -> call (fun () -> ()) std_formatter | Some s -> let oc = open_out s in let f = formatter_of_out_channel oc in call (fun () -> close_out oc) f let print output_file fct = let o = new printer () in with_outfile output_file (fct o) let print_interf ?input_file:(_) ?output_file sg = print output_file (fun o -> o#interf) sg let print_implem ?input_file:(_) ?output_file st = print output_file (fun o -> o#implem) st end module MakeMore (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax. Ast).S = struct include Make(Syntax) let semisep : sep ref = ref ("@\n" : sep) let margin = ref 78 let comments = ref true let locations = ref false let curry_constr = ref false let print output_file fct = let o = new printer ~comments: !comments ~curry_constr: !curry_constr () in let o = o#set_semisep !semisep in let o = if !locations then o#set_loc_and_comments else o in with_outfile output_file (fun f -> let () = Format.pp_set_margin f !margin in Format.fprintf f "@[%a@]@." (fct o)) let print_interf ?input_file:(_) ?output_file sg = print output_file (fun o -> o#interf) sg let print_implem ?input_file:(_) ?output_file st = print output_file (fun o -> o#implem) st let check_sep s = if String.contains s '%' then failwith "-sep Format error, % found in string" else (Obj.magic (Struct.Token.Eval.string s : string) : sep) let _ = Options.add "-l" (Arg.Int (fun i -> margin := i)) " line length for pretty printing." let _ = Options.add "-ss" (Arg.Unit (fun () -> semisep := ";;")) " Print double semicolons." let _ = Options.add "-no_ss" (Arg.Unit (fun () -> semisep := "")) " Do not print double semicolons (default)." let _ = Options.add "-sep" (Arg.String (fun s -> semisep := check_sep s)) " Use this string between phrases." let _ = Options.add "-curry-constr" (Arg.Set curry_constr) "Use currified constructors." let _ = Options.add "-no_comments" (Arg.Clear comments) "Do not add comments." let _ = Options.add "-add_locations" (Arg.Set locations) "Add locations as comment." end end module OCamlr : sig module Id : Sig.Id module Make (Syntax : Sig.Camlp4Syntax) : sig open Format include Sig.Camlp4Syntax with module Loc = Syntax.Loc and module Token = Syntax.Token and module Ast = Syntax.Ast and module Gram = Syntax.Gram class printer : ?curry_constr: bool -> ?comments: bool -> unit -> object ('a) inherit OCaml.Make(Syntax).printer end val with_outfile : string option -> (formatter -> 'a -> unit) -> 'a -> unit val print : string option -> (printer -> formatter -> 'a -> unit) -> 'a -> unit end module MakeMore (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax. Ast).S end = struct open Format module Id = struct let name = "Camlp4.Printers.OCamlr" let version = Sys.ocaml_version end module Make (Syntax : Sig.Camlp4Syntax) = struct include Syntax open Sig module PP_o = OCaml.Make(Syntax) open PP_o let pp = fprintf let is_keyword = let keywords = [ "where" ] and not_keywords = [ "false"; "function"; "true"; "val" ] in fun s -> (not (List.mem s not_keywords)) && ((is_keyword s) || (List.mem s keywords)) class printer ?curry_constr:(init_curry_constr = true) ?(comments = true) () = object (o) inherit PP_o.printer ~curry_constr: init_curry_constr ~comments () as super val! semisep = (";" : sep) val! no_semisep = (";" : sep) val mode = if comments then `comments else `no_comments val curry_constr = init_curry_constr val first_match_case = true method andsep : sep = "@]@ @[<2>and@ " method value_val = "value" method value_let = "value" method under_pipe = o method under_semi = o method reset_semi = o method reset = o method private unset_first_match_case = {< first_match_case = false; >} method private set_first_match_case = {< first_match_case = true; >} method seq = fun f e -> let rec self right f e = let go_right = self right and go_left = self false in match e with | Ast.ExLet (_, r, bi, e1) -> if right then pp f "@[<2>let %a%a@];@ %a" o#rec_flag r o#binding bi go_right e1 else pp f "(%a)" o#expr e | Ast.ExSeq (_, e) -> go_right f e | Ast.ExSem (_, e1, e2) -> (pp f "%a;@ " go_left e1; (match (right, e2) with | (true, Ast.ExLet (_, r, bi, e3)) -> pp f "@[<2>let %a%a@];@ %a" o#rec_flag r o#binding bi go_right e3 | _ -> go_right f e2)) | e -> o#expr f e in self true f e method var = fun f -> function | "" -> pp f "$lid:\"\"$" | "[]" -> pp f "[]" | "()" -> pp f "()" | " True" -> pp f "True" | " False" -> pp f "False" | v -> (match lex_string v with | LIDENT s | UIDENT s | ESCAPED_IDENT s when is_keyword s -> pp f "%s__" s | SYMBOL s -> pp f "( %s )" s | LIDENT s | UIDENT s | ESCAPED_IDENT s -> pp_print_string f s | tok -> failwith (sprintf "Bad token used as an identifier: %s" (Token.to_string tok))) method type_params = fun f -> function | [] -> () | [ x ] -> pp f "@ %a" o#ctyp x | l -> pp f "@ @[<1>%a@]" (list o#ctyp "@ ") l method match_case = fun f -> function | Ast.McNil _ -> pp f "@ []" | m -> pp f "@ [ %a ]" o#set_first_match_case#match_case_aux m method match_case_aux = fun f -> function | Ast.McNil _ -> () | Ast.McAnt (_, s) -> o#anti f s | Ast.McOr (_, a1, a2) -> pp f "%a%a" o#match_case_aux a1 o#unset_first_match_case#match_case_aux a2 | Ast.McArr (_, p, (Ast.ExNil _), e) -> let () = if first_match_case then () else pp f "@ | " in pp f "@[<2>%a@ ->@ %a@]" o#patt p o#under_pipe#expr e | Ast.McArr (_, p, w, e) -> let () = if first_match_case then () else pp f "@ | " in pp f "@[<2>%a@ when@ %a@ ->@ %a@]" o#patt p o#under_pipe#expr w o#under_pipe#expr e method sum_type = fun f -> function | Ast.TyNil _ -> pp f "[]" | t -> pp f "@[[ %a ]@]" o#ctyp t method ident = fun f i -> let () = o#node f i Ast.loc_of_ident in match i with | Ast.IdApp (_, i1, i2) -> pp f "%a@ %a" o#dot_ident i1 o#dot_ident i2 | i -> o#dot_ident f i method private dot_ident = fun f i -> let () = o#node f i Ast.loc_of_ident in match i with | Ast.IdAcc (_, i1, i2) -> pp f "%a.@,%a" o#dot_ident i1 o#dot_ident i2 | Ast.IdAnt (_, s) -> o#anti f s | Ast.IdLid (_, s) | Ast.IdUid (_, s) -> o#var f s | i -> pp f "(%a)" o#ident i method patt4 = fun f -> function | (Ast.PaApp (_, (Ast.PaApp (_, (Ast.PaId (_, (Ast.IdUid (_, "::")))), _)), _) as p) -> let (pl, c) = o#mk_patt_list p in (match c with | None -> pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl | Some x -> pp f "@[<2>[ %a ::@ %a ]@]" (list o#patt ";@ ") pl o#patt x) | p -> super#patt4 f p method expr_list_cons = fun _ f e -> let (el, c) = o#mk_expr_list e in match c with | None -> o#expr_list f el | Some x -> pp f "@[<2>[ %a ::@ %a ]@]" (list o#expr ";@ ") el o#expr x method expr = fun f e -> let () = o#node f e Ast.loc_of_expr in match e with | Ast.ExAss (_, e1, e2) -> pp f "@[<2>%a@ :=@ %a@]" o#dot_expr e1 o#expr e2 | Ast.ExFun (_, (Ast.McArr (_, p, (Ast.ExNil _), e))) when Ast.is_irrefut_patt p -> pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args ((`patt p), e) | Ast.ExFUN (_, i, e) -> pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args ((`newtype i), e) | Ast.ExFun (_, a) -> pp f "@[fun%a@]" o#match_case a | Ast.ExAsf _ -> pp f "@[<2>assert@ False@]" | e -> super#expr f e method dot_expr = fun f e -> let () = o#node f e Ast.loc_of_expr in match e with | Ast.ExAcc (_, e, (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> pp f "@[<2>%a.@,val@]" o#simple_expr e | e -> super#dot_expr f e method ctyp = fun f t -> let () = o#node f t Ast.loc_of_ctyp in match t with | Ast.TyDcl (_, tn, tp, te, cl) -> (pp f "@[<2>%a%a@]" o#var tn o#type_params tp; (match te with | Ast.TyNil _ -> () | _ -> pp f " =@ %a" o#ctyp te); if cl <> [] then pp f "@ %a" (list o#constrain "@ ") cl else ()) | Ast.TyCol (_, t1, (Ast.TyMut (_, t2))) -> pp f "@[%a :@ mutable %a@]" o#ctyp t1 o#ctyp t2 | Ast.TyMan (_, t1, t2) -> pp f "@[<2>%a ==@ %a@]" o#simple_ctyp t1 o#ctyp t2 | t -> super#ctyp f t method simple_ctyp = fun f t -> let () = o#node f t Ast.loc_of_ctyp in match t with | Ast.TyVrnEq (_, t) -> pp f "@[<2>[ =@ %a@]@ ]" o#ctyp t | Ast.TyVrnInf (_, t) -> pp f "@[<2>[ <@ %a@]@,]" o#ctyp t | Ast.TyVrnInfSup (_, t1, t2) -> pp f "@[<2>[ <@ %a@ >@ %a@]@ ]" o#ctyp t1 o#ctyp t2 | Ast.TyVrnSup (_, t) -> pp f "@[<2>[ >@ %a@]@,]" o#ctyp t | Ast.TyMan (_, t1, t2) -> pp f "@[<2>%a@ ==@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 | Ast.TyLab (_, s, t) -> pp f "@[<2>~%s:@ %a@]" s o#simple_ctyp t | t -> super#simple_ctyp f t method ctyp1 = fun f -> function | Ast.TyApp (_, t1, t2) -> (match get_ctyp_args t1 [ t2 ] with | (_, [ _ ]) -> pp f "@[<2>%a@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 | (a, al) -> pp f "@[<2>%a@]" (list o#simple_ctyp "@ ") (a :: al)) | Ast.TyPol (_, t1, t2) -> let (a, al) = get_ctyp_args t1 [] in pp f "@[<2>! %a.@ %a@]" (list o#ctyp "@ ") (a :: al) o#ctyp t2 | t -> super#ctyp1 f t method constructor_type = fun f t -> match t with | Ast.TyAnd (loc, t1, t2) -> let () = o#node f t (fun _ -> loc) in pp f "%a@ and %a" o#constructor_type t1 o#constructor_type t2 | t -> o#ctyp f t method str_item = fun f st -> match st with | Ast.StExp (_, e) -> pp f "@[<2>%a%(%)@]" o#expr e semisep | st -> super#str_item f st method module_expr = fun f me -> let () = o#node f me Ast.loc_of_module_expr in match me with | Ast.MeApp (_, me1, me2) -> pp f "@[<2>%a@ %a@]" o#module_expr me1 o#simple_module_expr me2 | me -> super#module_expr f me method simple_module_expr = fun f me -> let () = o#node f me Ast.loc_of_module_expr in match me with | Ast.MeApp (_, _, _) -> pp f "(%a)" o#module_expr me | _ -> super#simple_module_expr f me method implem = fun f st -> pp f "@[%a@]@." o#str_item st method class_type = fun f ct -> let () = o#node f ct Ast.loc_of_class_type in match ct with | Ast.CtFun (_, t, ct) -> pp f "@[<2>[ %a ] ->@ %a@]" o#simple_ctyp t o#class_type ct | Ast.CtCon (_, Ast.ViNil, i, (Ast.TyNil _)) -> pp f "@[<2>%a@]" o#ident i | Ast.CtCon (_, Ast.ViNil, i, t) -> pp f "@[<2>%a [@,%a@]@,]" o#ident i o#class_params t | Ast.CtCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), (Ast.TyNil _)) -> pp f "@[<2>virtual@ %a@]" o#var i | Ast.CtCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), t) -> pp f "@[<2>virtual@ %a@ [@,%a@]@,]" o#var i o#class_params t | ct -> super#class_type f ct method class_expr = fun f ce -> let () = o#node f ce Ast.loc_of_class_expr in match ce with | Ast.CeCon (_, Ast.ViNil, i, (Ast.TyNil _)) -> pp f "@[<2>%a@]" o#ident i | Ast.CeCon (_, Ast.ViNil, i, t) -> pp f "@[<2>%a@ @[<1>[%a]@]@]" o#ident i o#class_params t | Ast.CeCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), (Ast.TyNil _)) -> pp f "@[<2>virtual@ %a@]" o#var i | Ast.CeCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), t) -> pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i o#class_params t | ce -> super#class_expr f ce end let with_outfile = with_outfile let print output_file fct = let o = new printer () in with_outfile output_file (fct o) let print_interf ?input_file:(_) ?output_file sg = print output_file (fun o -> o#interf) sg let print_implem ?input_file:(_) ?output_file st = print output_file (fun o -> o#implem) st end module MakeMore (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax. Ast).S = struct include Make(Syntax) let margin = ref 78 let comments = ref true let locations = ref false let curry_constr = ref true let print output_file fct = let o = new printer ~comments: !comments ~curry_constr: !curry_constr () in let o = if !locations then o#set_loc_and_comments else o in with_outfile output_file (fun f -> let () = Format.pp_set_margin f !margin in Format.fprintf f "@[%a@]@." (fct o)) let print_interf ?input_file:(_) ?output_file sg = print output_file (fun o -> o#interf) sg let print_implem ?input_file:(_) ?output_file st = print output_file (fun o -> o#implem) st let _ = Options.add "-l" (Arg.Int (fun i -> margin := i)) " line length for pretty printing." let _ = Options.add "-no_comments" (Arg.Clear comments) "Do not add comments." let _ = Options.add "-add_locations" (Arg.Set locations) "Add locations as comment." end end end module OCamlInitSyntax = struct module Make (Ast : Sig.Camlp4Ast) (Gram : Sig.Grammar.Static with module Loc = Ast.Loc with type Token.t = Sig.camlp4_token) (Quotation : Sig.Quotation with module Ast = Sig.Camlp4AstToAst(Ast)) : Sig.Camlp4Syntax with module Loc = Ast.Loc and module Ast = Ast and module Token = Gram.Token and module Gram = Gram and module Quotation = Quotation = struct module Loc = Ast.Loc module Ast = Ast module Gram = Gram module Token = Gram.Token open Sig type warning = Loc.t -> string -> unit let default_warning loc txt = Format.eprintf " %a: %s@." Loc.print loc txt let current_warning = ref default_warning let print_warning loc txt = !current_warning loc txt let a_CHAR = Gram.Entry.mk "a_CHAR" let a_FLOAT = Gram.Entry.mk "a_FLOAT" let a_INT = Gram.Entry.mk "a_INT" let a_INT32 = Gram.Entry.mk "a_INT32" let a_INT64 = Gram.Entry.mk "a_INT64" let a_LABEL = Gram.Entry.mk "a_LABEL" let a_LIDENT = Gram.Entry.mk "a_LIDENT" let a_NATIVEINT = Gram.Entry.mk "a_NATIVEINT" let a_OPTLABEL = Gram.Entry.mk "a_OPTLABEL" let a_STRING = Gram.Entry.mk "a_STRING" let a_UIDENT = Gram.Entry.mk "a_UIDENT" let a_ident = Gram.Entry.mk "a_ident" let amp_ctyp = Gram.Entry.mk "amp_ctyp" let and_ctyp = Gram.Entry.mk "and_ctyp" let match_case = Gram.Entry.mk "match_case" let match_case0 = Gram.Entry.mk "match_case0" let binding = Gram.Entry.mk "binding" let class_declaration = Gram.Entry.mk "class_declaration" let class_description = Gram.Entry.mk "class_description" let class_expr = Gram.Entry.mk "class_expr" let class_fun_binding = Gram.Entry.mk "class_fun_binding" let class_fun_def = Gram.Entry.mk "class_fun_def" let class_info_for_class_expr = Gram.Entry.mk "class_info_for_class_expr" let class_info_for_class_type = Gram.Entry.mk "class_info_for_class_type" let class_longident = Gram.Entry.mk "class_longident" let class_longident_and_param = Gram.Entry.mk "class_longident_and_param" let class_name_and_param = Gram.Entry.mk "class_name_and_param" let class_sig_item = Gram.Entry.mk "class_sig_item" let class_signature = Gram.Entry.mk "class_signature" let class_str_item = Gram.Entry.mk "class_str_item" let class_structure = Gram.Entry.mk "class_structure" let class_type = Gram.Entry.mk "class_type" let class_type_declaration = Gram.Entry.mk "class_type_declaration" let class_type_longident = Gram.Entry.mk "class_type_longident" let class_type_longident_and_param = Gram.Entry.mk "class_type_longident_and_param" let class_type_plus = Gram.Entry.mk "class_type_plus" let comma_ctyp = Gram.Entry.mk "comma_ctyp" let comma_expr = Gram.Entry.mk "comma_expr" let comma_ipatt = Gram.Entry.mk "comma_ipatt" let comma_patt = Gram.Entry.mk "comma_patt" let comma_type_parameter = Gram.Entry.mk "comma_type_parameter" let constrain = Gram.Entry.mk "constrain" let constructor_arg_list = Gram.Entry.mk "constructor_arg_list" let constructor_declaration = Gram.Entry.mk "constructor_declaration" let constructor_declarations = Gram.Entry.mk "constructor_declarations" let ctyp = Gram.Entry.mk "ctyp" let cvalue_binding = Gram.Entry.mk "cvalue_binding" let direction_flag = Gram.Entry.mk "direction_flag" let direction_flag_quot = Gram.Entry.mk "direction_flag_quot" let dummy = Gram.Entry.mk "dummy" let entry_eoi = Gram.Entry.mk "entry_eoi" let eq_expr = Gram.Entry.mk "eq_expr" let expr = Gram.Entry.mk "expr" let expr_eoi = Gram.Entry.mk "expr_eoi" let field_expr = Gram.Entry.mk "field_expr" let field_expr_list = Gram.Entry.mk "field_expr_list" let fun_binding = Gram.Entry.mk "fun_binding" let fun_def = Gram.Entry.mk "fun_def" let ident = Gram.Entry.mk "ident" let implem = Gram.Entry.mk "implem" let interf = Gram.Entry.mk "interf" let ipatt = Gram.Entry.mk "ipatt" let ipatt_tcon = Gram.Entry.mk "ipatt_tcon" let label = Gram.Entry.mk "label" let label_declaration = Gram.Entry.mk "label_declaration" let label_declaration_list = Gram.Entry.mk "label_declaration_list" let label_expr = Gram.Entry.mk "label_expr" let label_expr_list = Gram.Entry.mk "label_expr_list" let label_ipatt = Gram.Entry.mk "label_ipatt" let label_ipatt_list = Gram.Entry.mk "label_ipatt_list" let label_longident = Gram.Entry.mk "label_longident" let label_patt = Gram.Entry.mk "label_patt" let label_patt_list = Gram.Entry.mk "label_patt_list" let labeled_ipatt = Gram.Entry.mk "labeled_ipatt" let let_binding = Gram.Entry.mk "let_binding" let meth_list = Gram.Entry.mk "meth_list" let meth_decl = Gram.Entry.mk "meth_decl" let module_binding = Gram.Entry.mk "module_binding" let module_binding0 = Gram.Entry.mk "module_binding0" let module_declaration = Gram.Entry.mk "module_declaration" let module_expr = Gram.Entry.mk "module_expr" let module_longident = Gram.Entry.mk "module_longident" let module_longident_with_app = Gram.Entry.mk "module_longident_with_app" let module_rec_declaration = Gram.Entry.mk "module_rec_declaration" let module_type = Gram.Entry.mk "module_type" let package_type = Gram.Entry.mk "package_type" let more_ctyp = Gram.Entry.mk "more_ctyp" let name_tags = Gram.Entry.mk "name_tags" let opt_as_lident = Gram.Entry.mk "opt_as_lident" let opt_class_self_patt = Gram.Entry.mk "opt_class_self_patt" let opt_class_self_type = Gram.Entry.mk "opt_class_self_type" let opt_class_signature = Gram.Entry.mk "opt_class_signature" let opt_class_structure = Gram.Entry.mk "opt_class_structure" let opt_comma_ctyp = Gram.Entry.mk "opt_comma_ctyp" let opt_dot_dot = Gram.Entry.mk "opt_dot_dot" let row_var_flag_quot = Gram.Entry.mk "row_var_flag_quot" let opt_eq_ctyp = Gram.Entry.mk "opt_eq_ctyp" let opt_expr = Gram.Entry.mk "opt_expr" let opt_meth_list = Gram.Entry.mk "opt_meth_list" let opt_mutable = Gram.Entry.mk "opt_mutable" let mutable_flag_quot = Gram.Entry.mk "mutable_flag_quot" let opt_polyt = Gram.Entry.mk "opt_polyt" let opt_private = Gram.Entry.mk "opt_private" let private_flag_quot = Gram.Entry.mk "private_flag_quot" let opt_rec = Gram.Entry.mk "opt_rec" let rec_flag_quot = Gram.Entry.mk "rec_flag_quot" let opt_sig_items = Gram.Entry.mk "opt_sig_items" let opt_str_items = Gram.Entry.mk "opt_str_items" let opt_virtual = Gram.Entry.mk "opt_virtual" let virtual_flag_quot = Gram.Entry.mk "virtual_flag_quot" let opt_override = Gram.Entry.mk "opt_override" let override_flag_quot = Gram.Entry.mk "override_flag_quot" let opt_when_expr = Gram.Entry.mk "opt_when_expr" let patt = Gram.Entry.mk "patt" let patt_as_patt_opt = Gram.Entry.mk "patt_as_patt_opt" let patt_eoi = Gram.Entry.mk "patt_eoi" let patt_tcon = Gram.Entry.mk "patt_tcon" let phrase = Gram.Entry.mk "phrase" let poly_type = Gram.Entry.mk "poly_type" let row_field = Gram.Entry.mk "row_field" let sem_expr = Gram.Entry.mk "sem_expr" let sem_expr_for_list = Gram.Entry.mk "sem_expr_for_list" let sem_patt = Gram.Entry.mk "sem_patt" let sem_patt_for_list = Gram.Entry.mk "sem_patt_for_list" let semi = Gram.Entry.mk "semi" let sequence = Gram.Entry.mk "sequence" let do_sequence = Gram.Entry.mk "do_sequence" let sig_item = Gram.Entry.mk "sig_item" let sig_items = Gram.Entry.mk "sig_items" let star_ctyp = Gram.Entry.mk "star_ctyp" let str_item = Gram.Entry.mk "str_item" let str_items = Gram.Entry.mk "str_items" let top_phrase = Gram.Entry.mk "top_phrase" let type_constraint = Gram.Entry.mk "type_constraint" let type_declaration = Gram.Entry.mk "type_declaration" let type_ident_and_parameters = Gram.Entry.mk "type_ident_and_parameters" let type_kind = Gram.Entry.mk "type_kind" let type_longident = Gram.Entry.mk "type_longident" let type_longident_and_parameters = Gram.Entry.mk "type_longident_and_parameters" let type_parameter = Gram.Entry.mk "type_parameter" let type_parameters = Gram.Entry.mk "type_parameters" let typevars = Gram.Entry.mk "typevars" let use_file = Gram.Entry.mk "use_file" let val_longident = Gram.Entry.mk "val_longident" let value_let = Gram.Entry.mk "value_let" let value_val = Gram.Entry.mk "value_val" let with_constr = Gram.Entry.mk "with_constr" let expr_quot = Gram.Entry.mk "quotation of expression" let patt_quot = Gram.Entry.mk "quotation of pattern" let ctyp_quot = Gram.Entry.mk "quotation of type" let str_item_quot = Gram.Entry.mk "quotation of structure item" let sig_item_quot = Gram.Entry.mk "quotation of signature item" let class_str_item_quot = Gram.Entry.mk "quotation of class structure item" let class_sig_item_quot = Gram.Entry.mk "quotation of class signature item" let module_expr_quot = Gram.Entry.mk "quotation of module expression" let module_type_quot = Gram.Entry.mk "quotation of module type" let class_type_quot = Gram.Entry.mk "quotation of class type" let class_expr_quot = Gram.Entry.mk "quotation of class expression" let with_constr_quot = Gram.Entry.mk "quotation of with constraint" let binding_quot = Gram.Entry.mk "quotation of binding" let rec_binding_quot = Gram.Entry.mk "quotation of record binding" let match_case_quot = Gram.Entry.mk "quotation of match_case (try/match/function case)" let module_binding_quot = Gram.Entry.mk "quotation of module rec binding" let ident_quot = Gram.Entry.mk "quotation of identifier" let prefixop = Gram.Entry.mk "prefix operator (start with '!', '?', '~')" let infixop0 = Gram.Entry.mk "infix operator (level 0) (comparison operators, and some others)" let infixop1 = Gram.Entry.mk "infix operator (level 1) (start with '^', '@')" let infixop2 = Gram.Entry.mk "infix operator (level 2) (start with '+', '-')" let infixop3 = Gram.Entry.mk "infix operator (level 3) (start with '*', '/', '%')" let infixop4 = Gram.Entry.mk "infix operator (level 4) (start with \"**\") (right assoc)" let _ = Gram.extend (top_phrase : 'top_phrase Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | EOI -> true | _ -> false), "EOI")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | EOI -> (None : 'top_phrase) | _ -> assert false))) ]) ])) ()) module AntiquotSyntax = struct module Loc = Ast.Loc module Ast = Sig.Camlp4AstToAst(Ast) module Gram = Gram let antiquot_expr = Gram.Entry.mk "antiquot_expr" let antiquot_patt = Gram.Entry.mk "antiquot_patt" let _ = (Gram.extend (antiquot_expr : 'antiquot_expr Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Stoken (((function | EOI -> true | _ -> false), "EOI")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (x : 'expr) (_loc : Gram.Loc.t) -> match __camlp4_0 with | EOI -> (x : 'antiquot_expr) | _ -> assert false))) ]) ])) ()); Gram.extend (antiquot_patt : 'antiquot_patt Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Stoken (((function | EOI -> true | _ -> false), "EOI")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (x : 'patt) (_loc : Gram.Loc.t) -> match __camlp4_0 with | EOI -> (x : 'antiquot_patt) | _ -> assert false))) ]) ])) ())) let parse_expr loc str = Gram.parse_string antiquot_expr loc str let parse_patt loc str = Gram.parse_string antiquot_patt loc str end module Quotation = Quotation let wrap directive_handler pa init_loc cs = let rec loop loc = let (pl, stopped_at_directive) = pa loc cs in match stopped_at_directive with | Some new_loc -> let pl = (match List.rev pl with | [] -> assert false | x :: xs -> (match directive_handler x with | None -> xs | Some x -> x :: xs)) in (List.rev pl) @ (loop new_loc) | None -> pl in loop init_loc let parse_implem ?(directive_handler = fun _ -> None) _loc cs = let l = wrap directive_handler (Gram.parse implem) _loc cs in Ast.stSem_of_list l let parse_interf ?(directive_handler = fun _ -> None) _loc cs = let l = wrap directive_handler (Gram.parse interf) _loc cs in Ast.sgSem_of_list l let print_interf ?input_file:(_) ?output_file:(_) _ = failwith "No interface printer" let print_implem ?input_file:(_) ?output_file:(_) _ = failwith "No implementation printer" end end module PreCast : sig type camlp4_token = Sig.camlp4_token = | KEYWORD of string | SYMBOL of string | LIDENT of string | UIDENT of string | ESCAPED_IDENT of string | INT of int * string | INT32 of int32 * string | INT64 of int64 * string | NATIVEINT of nativeint * string | FLOAT of float * string | CHAR of char * string | STRING of string * string | LABEL of string | OPTLABEL of string | QUOTATION of Sig.quotation | ANTIQUOT of string * string | COMMENT of string | BLANKS of string | NEWLINE | LINE_DIRECTIVE of int * string option | EOI module Id : Sig.Id module Loc : Sig.Loc module Ast : Sig.Camlp4Ast with module Loc = Loc module Token : Sig.Token with module Loc = Loc and type t = camlp4_token module Lexer : Sig.Lexer with module Loc = Loc and module Token = Token module Gram : Sig.Grammar.Static with module Loc = Loc and module Token = Token module Quotation : Sig.Quotation with module Ast = Sig.Camlp4AstToAst(Ast) module DynLoader : Sig.DynLoader module AstFilters : Sig.AstFilters with module Ast = Ast module Syntax : Sig.Camlp4Syntax with module Loc = Loc and module Token = Token and module Ast = Ast and module Gram = Gram and module Quotation = Quotation module Printers : sig module OCaml : Sig.Printer(Ast).S module OCamlr : Sig.Printer(Ast).S module DumpOCamlAst : Sig.Printer(Ast).S module DumpCamlp4Ast : Sig.Printer(Ast).S module Null : Sig.Printer(Ast).S end module MakeGram (Lexer : Sig.Lexer with module Loc = Loc) : Sig.Grammar.Static with module Loc = Loc and module Token = Lexer.Token module MakeSyntax (U : sig end) : Sig.Syntax end = struct module Id = struct let name = "Camlp4.PreCast" let version = Sys.ocaml_version end type camlp4_token = Sig.camlp4_token = | KEYWORD of string | SYMBOL of string | LIDENT of string | UIDENT of string | ESCAPED_IDENT of string | INT of int * string | INT32 of int32 * string | INT64 of int64 * string | NATIVEINT of nativeint * string | FLOAT of float * string | CHAR of char * string | STRING of string * string | LABEL of string | OPTLABEL of string | QUOTATION of Sig.quotation | ANTIQUOT of string * string | COMMENT of string | BLANKS of string | NEWLINE | LINE_DIRECTIVE of int * string option | EOI module Loc = Struct.Loc module Ast = Struct.Camlp4Ast.Make(Loc) module Token = Struct.Token.Make(Loc) module Lexer = Struct.Lexer.Make(Token) module Gram = Struct.Grammar.Static.Make(Lexer) module DynLoader = Struct.DynLoader module Quotation = Struct.Quotation.Make(Ast) module MakeSyntax (U : sig end) = OCamlInitSyntax.Make(Ast)(Gram)(Quotation) module Syntax = MakeSyntax(struct end) module AstFilters = Struct.AstFilters.Make(Ast) module MakeGram = Struct.Grammar.Static.Make module Printers = struct module OCaml = Printers.OCaml.Make(Syntax) module OCamlr = Printers.OCamlr.Make(Syntax) module DumpOCamlAst = Printers.DumpOCamlAst.Make(Syntax) module DumpCamlp4Ast = Printers.DumpCamlp4Ast.Make(Syntax) module Null = Printers.Null.Make(Syntax) end end module Register : sig module Plugin (Id : Sig.Id) (Plugin : functor (Unit : sig end) -> sig end) : sig end module SyntaxPlugin (Id : Sig.Id) (SyntaxPlugin : functor (Syn : Sig.Syntax) -> sig end) : sig end module SyntaxExtension (Id : Sig.Id) (SyntaxExtension : Sig.SyntaxExtension) : sig end module OCamlSyntaxExtension (Id : Sig.Id) (SyntaxExtension : functor (Syntax : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax) : sig end type 'a parser_fun = ?directive_handler: ('a -> 'a option) -> PreCast.Loc.t -> char Stream.t -> 'a val register_str_item_parser : PreCast.Ast.str_item parser_fun -> unit val register_sig_item_parser : PreCast.Ast.sig_item parser_fun -> unit val register_parser : PreCast.Ast.str_item parser_fun -> PreCast.Ast.sig_item parser_fun -> unit val current_parser : unit -> ((PreCast.Ast.str_item parser_fun) * (PreCast.Ast.sig_item parser_fun)) module Parser (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> Sig.Parser(Ast).S) : sig end module OCamlParser (Id : Sig.Id) (Maker : functor (Ast : Sig.Camlp4Ast) -> Sig.Parser(Ast).S) : sig end module OCamlPreCastParser (Id : Sig.Id) (Parser : Sig.Parser(PreCast.Ast).S) : sig end type 'a printer_fun = ?input_file: string -> ?output_file: string -> 'a -> unit val register_str_item_printer : PreCast.Ast.str_item printer_fun -> unit val register_sig_item_printer : PreCast.Ast.sig_item printer_fun -> unit val register_printer : PreCast.Ast.str_item printer_fun -> PreCast.Ast.sig_item printer_fun -> unit val current_printer : unit -> ((PreCast.Ast.str_item printer_fun) * (PreCast.Ast.sig_item printer_fun)) module Printer (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) -> Sig.Printer(Syn.Ast).S) : sig end module OCamlPrinter (Id : Sig.Id) (Maker : functor (Syn : Sig.Camlp4Syntax) -> Sig.Printer(Syn.Ast).S) : sig end module OCamlPreCastPrinter (Id : Sig.Id) (Printer : Sig.Printer(PreCast.Ast).S) : sig end module AstFilter (Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) : sig end val declare_dyn_module : string -> (unit -> unit) -> unit val iter_and_take_callbacks : ((string * (unit -> unit)) -> unit) -> unit val loaded_modules : (string list) ref module CurrentParser : Sig.Parser(PreCast.Ast).S module CurrentPrinter : Sig.Printer(PreCast.Ast).S val enable_ocaml_printer : unit -> unit val enable_ocamlr_printer : unit -> unit val enable_null_printer : unit -> unit val enable_dump_ocaml_ast_printer : unit -> unit val enable_dump_camlp4_ast_printer : unit -> unit end = struct module PP = Printers open PreCast type 'a parser_fun = ?directive_handler: ('a -> 'a option) -> PreCast.Loc.t -> char Stream.t -> 'a type 'a printer_fun = ?input_file: string -> ?output_file: string -> 'a -> unit let sig_item_parser = ref (fun ?directive_handler:(_) _ _ -> failwith "No interface parser") let str_item_parser = ref (fun ?directive_handler:(_) _ _ -> failwith "No implementation parser") let sig_item_printer = ref (fun ?input_file:(_) ?output_file:(_) _ -> failwith "No interface printer") let str_item_printer = ref (fun ?input_file:(_) ?output_file:(_) _ -> failwith "No implementation printer") let callbacks = Queue.create () let loaded_modules = ref [] let iter_and_take_callbacks f = let rec loop () = loop (f (Queue.take callbacks)) in try loop () with | Queue.Empty -> () let declare_dyn_module m f = (loaded_modules := m :: !loaded_modules; Queue.add (m, f) callbacks) let register_str_item_parser f = str_item_parser := f let register_sig_item_parser f = sig_item_parser := f let register_parser f g = (str_item_parser := f; sig_item_parser := g) let current_parser () = ((!str_item_parser), (!sig_item_parser)) let register_str_item_printer f = str_item_printer := f let register_sig_item_printer f = sig_item_printer := f let register_printer f g = (str_item_printer := f; sig_item_printer := g) let current_printer () = ((!str_item_printer), (!sig_item_printer)) module Plugin (Id : Sig.Id) (Maker : functor (Unit : sig end) -> sig end) = struct let _ = declare_dyn_module Id.name (fun _ -> let module M = Maker(struct end) in ()) end module SyntaxExtension (Id : Sig.Id) (Maker : Sig.SyntaxExtension) = struct let _ = declare_dyn_module Id.name (fun _ -> let module M = Maker(Syntax) in ()) end module OCamlSyntaxExtension (Id : Sig.Id) (Maker : functor (Syn : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax) = struct let _ = declare_dyn_module Id.name (fun _ -> let module M = Maker(Syntax) in ()) end module SyntaxPlugin (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) -> sig end) = struct let _ = declare_dyn_module Id.name (fun _ -> let module M = Maker(Syntax) in ()) end module Printer (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) -> Sig.Printer(Syn.Ast).S) = struct let _ = declare_dyn_module Id.name (fun _ -> let module M = Maker(Syntax) in register_printer M.print_implem M.print_interf) end module OCamlPrinter (Id : Sig.Id) (Maker : functor (Syn : Sig.Camlp4Syntax) -> Sig.Printer(Syn.Ast).S) = struct let _ = declare_dyn_module Id.name (fun _ -> let module M = Maker(Syntax) in register_printer M.print_implem M.print_interf) end module OCamlPreCastPrinter (Id : Sig.Id) (P : Sig.Printer(PreCast.Ast).S) = struct let _ = declare_dyn_module Id.name (fun _ -> register_printer P.print_implem P.print_interf) end module Parser (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> Sig.Parser(Ast).S) = struct let _ = declare_dyn_module Id.name (fun _ -> let module M = Maker(PreCast.Ast) in register_parser M.parse_implem M.parse_interf) end module OCamlParser (Id : Sig.Id) (Maker : functor (Ast : Sig.Camlp4Ast) -> Sig.Parser(Ast).S) = struct let _ = declare_dyn_module Id.name (fun _ -> let module M = Maker(PreCast.Ast) in register_parser M.parse_implem M.parse_interf) end module OCamlPreCastParser (Id : Sig.Id) (P : Sig.Parser(PreCast.Ast).S) = struct let _ = declare_dyn_module Id.name (fun _ -> register_parser P.parse_implem P.parse_interf) end module AstFilter (Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) = struct let _ = declare_dyn_module Id.name (fun _ -> let module M = Maker(AstFilters) in ()) end let _ = sig_item_parser := Syntax.parse_interf let _ = str_item_parser := Syntax.parse_implem module CurrentParser = struct module Ast = Ast let parse_interf ?directive_handler loc strm = !sig_item_parser ?directive_handler loc strm let parse_implem ?directive_handler loc strm = !str_item_parser ?directive_handler loc strm end module CurrentPrinter = struct module Ast = Ast let print_interf ?input_file ?output_file ast = !sig_item_printer ?input_file ?output_file ast let print_implem ?input_file ?output_file ast = !str_item_printer ?input_file ?output_file ast end let enable_ocaml_printer () = let module M = OCamlPrinter(PP.OCaml.Id)(PP.OCaml.MakeMore) in () let enable_ocamlr_printer () = let module M = OCamlPrinter(PP.OCamlr.Id)(PP.OCamlr.MakeMore) in () let enable_dump_ocaml_ast_printer () = let module M = OCamlPrinter(PP.DumpOCamlAst.Id)(PP.DumpOCamlAst.Make) in () let enable_dump_camlp4_ast_printer () = let module M = Printer(PP.DumpCamlp4Ast.Id)(PP.DumpCamlp4Ast.Make) in () let enable_null_printer () = let module M = Printer(PP.Null.Id)(PP.Null.Make) in () end mingw-ocaml/ocaml/camlp4/boot/Camlp4Ast.ml0000644000175000017500000107317112124403240017734 0ustar tootstoots(****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = struct module Loc = Loc; module Ast = struct include (Sig.MakeCamlp4Ast Loc); value safe_string_escaped s = if ((String.length s) > 2) && ((s.[0] = '\\') && (s.[1] = '$')) then s else String.escaped s; end; include Ast; external loc_of_ctyp : ctyp -> Loc.t = "%field0"; external loc_of_patt : patt -> Loc.t = "%field0"; external loc_of_expr : expr -> Loc.t = "%field0"; external loc_of_module_type : module_type -> Loc.t = "%field0"; external loc_of_module_expr : module_expr -> Loc.t = "%field0"; external loc_of_sig_item : sig_item -> Loc.t = "%field0"; external loc_of_str_item : str_item -> Loc.t = "%field0"; external loc_of_class_type : class_type -> Loc.t = "%field0"; external loc_of_class_sig_item : class_sig_item -> Loc.t = "%field0"; external loc_of_class_expr : class_expr -> Loc.t = "%field0"; external loc_of_class_str_item : class_str_item -> Loc.t = "%field0"; external loc_of_with_constr : with_constr -> Loc.t = "%field0"; external loc_of_binding : binding -> Loc.t = "%field0"; external loc_of_rec_binding : rec_binding -> Loc.t = "%field0"; external loc_of_module_binding : module_binding -> Loc.t = "%field0"; external loc_of_match_case : match_case -> Loc.t = "%field0"; external loc_of_ident : ident -> Loc.t = "%field0"; value ghost = Loc.ghost; value rec is_module_longident = fun [ Ast.IdAcc _ _ i -> is_module_longident i | Ast.IdApp _ i1 i2 -> (is_module_longident i1) && (is_module_longident i2) | Ast.IdUid _ _ -> True | _ -> False ]; value ident_of_expr = let error () = invalid_arg "ident_of_expr: this expression is not an identifier" in let rec self = fun [ Ast.ExApp _loc e1 e2 -> Ast.IdApp _loc (self e1) (self e2) | Ast.ExAcc _loc e1 e2 -> Ast.IdAcc _loc (self e1) (self e2) | Ast.ExId _ (Ast.IdLid _ _) -> error () | Ast.ExId _ i -> if is_module_longident i then i else error () | _ -> error () ] in fun [ Ast.ExId _ i -> i | Ast.ExApp _ _ _ -> error () | t -> self t ]; value ident_of_ctyp = let error () = invalid_arg "ident_of_ctyp: this type is not an identifier" in let rec self = fun [ Ast.TyApp _loc t1 t2 -> Ast.IdApp _loc (self t1) (self t2) | Ast.TyId _ (Ast.IdLid _ _) -> error () | Ast.TyId _ i -> if is_module_longident i then i else error () | _ -> error () ] in fun [ Ast.TyId _ i -> i | t -> self t ]; value ident_of_patt = let error () = invalid_arg "ident_of_patt: this pattern is not an identifier" in let rec self = fun [ Ast.PaApp _loc p1 p2 -> Ast.IdApp _loc (self p1) (self p2) | Ast.PaId _ (Ast.IdLid _ _) -> error () | Ast.PaId _ i -> if is_module_longident i then i else error () | _ -> error () ] in fun [ Ast.PaId _ i -> i | p -> self p ]; value rec is_irrefut_patt = fun [ Ast.PaId _ (Ast.IdLid _ _) -> True | Ast.PaId _ (Ast.IdUid _ "()") -> True | Ast.PaAny _ -> True | Ast.PaNil _ -> True | (* why not *) Ast.PaAli _ x y -> (is_irrefut_patt x) && (is_irrefut_patt y) | Ast.PaRec _ p -> is_irrefut_patt p | Ast.PaEq _ _ p -> is_irrefut_patt p | Ast.PaSem _ p1 p2 -> (is_irrefut_patt p1) && (is_irrefut_patt p2) | Ast.PaCom _ p1 p2 -> (is_irrefut_patt p1) && (is_irrefut_patt p2) | Ast.PaOrp _ p1 p2 -> (is_irrefut_patt p1) && (is_irrefut_patt p2) | (* could be more fine grained *) Ast.PaApp _ p1 p2 -> (is_irrefut_patt p1) && (is_irrefut_patt p2) | Ast.PaTyc _ p _ -> is_irrefut_patt p | Ast.PaTup _ pl -> is_irrefut_patt pl | Ast.PaOlb _ _ (Ast.PaNil _) -> True | Ast.PaOlb _ _ p -> is_irrefut_patt p | Ast.PaOlbi _ _ p _ -> is_irrefut_patt p | Ast.PaLab _ _ (Ast.PaNil _) -> True | Ast.PaLab _ _ p -> is_irrefut_patt p | Ast.PaLaz _ p -> is_irrefut_patt p | Ast.PaId _ _ -> False | (* here one need to know the arity of constructors *) Ast.PaMod _ _ -> True | Ast.PaVrn _ _ | Ast.PaStr _ _ | Ast.PaRng _ _ _ | Ast.PaFlo _ _ | Ast.PaNativeInt _ _ | Ast.PaInt64 _ _ | Ast.PaInt32 _ _ | Ast.PaInt _ _ | Ast.PaChr _ _ | Ast.PaTyp _ _ | Ast.PaArr _ _ | Ast.PaAnt _ _ -> False ]; value rec is_constructor = fun [ Ast.IdAcc _ _ i -> is_constructor i | Ast.IdUid _ _ -> True | Ast.IdLid _ _ | Ast.IdApp _ _ _ -> False | Ast.IdAnt _ _ -> assert False ]; value is_patt_constructor = fun [ Ast.PaId _ i -> is_constructor i | Ast.PaVrn _ _ -> True | _ -> False ]; value rec is_expr_constructor = fun [ Ast.ExId _ i -> is_constructor i | Ast.ExAcc _ e1 e2 -> (is_expr_constructor e1) && (is_expr_constructor e2) | Ast.ExVrn _ _ -> True | _ -> False ]; value rec tyOr_of_list = fun [ [] -> Ast.TyNil ghost | [ t ] -> t | [ t :: ts ] -> let _loc = loc_of_ctyp t in Ast.TyOr _loc t (tyOr_of_list ts) ]; value rec tyAnd_of_list = fun [ [] -> Ast.TyNil ghost | [ t ] -> t | [ t :: ts ] -> let _loc = loc_of_ctyp t in Ast.TyAnd _loc t (tyAnd_of_list ts) ]; value rec tySem_of_list = fun [ [] -> Ast.TyNil ghost | [ t ] -> t | [ t :: ts ] -> let _loc = loc_of_ctyp t in Ast.TySem _loc t (tySem_of_list ts) ]; value rec tyCom_of_list = fun [ [] -> Ast.TyNil ghost | [ t ] -> t | [ t :: ts ] -> let _loc = loc_of_ctyp t in Ast.TyCom _loc t (tyCom_of_list ts) ]; value rec tyAmp_of_list = fun [ [] -> Ast.TyNil ghost | [ t ] -> t | [ t :: ts ] -> let _loc = loc_of_ctyp t in Ast.TyAmp _loc t (tyAmp_of_list ts) ]; value rec tySta_of_list = fun [ [] -> Ast.TyNil ghost | [ t ] -> t | [ t :: ts ] -> let _loc = loc_of_ctyp t in Ast.TySta _loc t (tySta_of_list ts) ]; value rec stSem_of_list = fun [ [] -> Ast.StNil ghost | [ t ] -> t | [ t :: ts ] -> let _loc = loc_of_str_item t in Ast.StSem _loc t (stSem_of_list ts) ]; value rec sgSem_of_list = fun [ [] -> Ast.SgNil ghost | [ t ] -> t | [ t :: ts ] -> let _loc = loc_of_sig_item t in Ast.SgSem _loc t (sgSem_of_list ts) ]; value rec biAnd_of_list = fun [ [] -> Ast.BiNil ghost | [ b ] -> b | [ b :: bs ] -> let _loc = loc_of_binding b in Ast.BiAnd _loc b (biAnd_of_list bs) ]; value rec rbSem_of_list = fun [ [] -> Ast.RbNil ghost | [ b ] -> b | [ b :: bs ] -> let _loc = loc_of_rec_binding b in Ast.RbSem _loc b (rbSem_of_list bs) ]; value rec wcAnd_of_list = fun [ [] -> Ast.WcNil ghost | [ w ] -> w | [ w :: ws ] -> let _loc = loc_of_with_constr w in Ast.WcAnd _loc w (wcAnd_of_list ws) ]; value rec idAcc_of_list = fun [ [] -> assert False | [ i ] -> i | [ i :: is ] -> let _loc = loc_of_ident i in Ast.IdAcc _loc i (idAcc_of_list is) ]; value rec idApp_of_list = fun [ [] -> assert False | [ i ] -> i | [ i :: is ] -> let _loc = loc_of_ident i in Ast.IdApp _loc i (idApp_of_list is) ]; value rec mcOr_of_list = fun [ [] -> Ast.McNil ghost | [ x ] -> x | [ x :: xs ] -> let _loc = loc_of_match_case x in Ast.McOr _loc x (mcOr_of_list xs) ]; value rec mbAnd_of_list = fun [ [] -> Ast.MbNil ghost | [ x ] -> x | [ x :: xs ] -> let _loc = loc_of_module_binding x in Ast.MbAnd _loc x (mbAnd_of_list xs) ]; value rec meApp_of_list = fun [ [] -> assert False | [ x ] -> x | [ x :: xs ] -> let _loc = loc_of_module_expr x in Ast.MeApp _loc x (meApp_of_list xs) ]; value rec ceAnd_of_list = fun [ [] -> Ast.CeNil ghost | [ x ] -> x | [ x :: xs ] -> let _loc = loc_of_class_expr x in Ast.CeAnd _loc x (ceAnd_of_list xs) ]; value rec ctAnd_of_list = fun [ [] -> Ast.CtNil ghost | [ x ] -> x | [ x :: xs ] -> let _loc = loc_of_class_type x in Ast.CtAnd _loc x (ctAnd_of_list xs) ]; value rec cgSem_of_list = fun [ [] -> Ast.CgNil ghost | [ x ] -> x | [ x :: xs ] -> let _loc = loc_of_class_sig_item x in Ast.CgSem _loc x (cgSem_of_list xs) ]; value rec crSem_of_list = fun [ [] -> Ast.CrNil ghost | [ x ] -> x | [ x :: xs ] -> let _loc = loc_of_class_str_item x in Ast.CrSem _loc x (crSem_of_list xs) ]; value rec paSem_of_list = fun [ [] -> Ast.PaNil ghost | [ x ] -> x | [ x :: xs ] -> let _loc = loc_of_patt x in Ast.PaSem _loc x (paSem_of_list xs) ]; value rec paCom_of_list = fun [ [] -> Ast.PaNil ghost | [ x ] -> x | [ x :: xs ] -> let _loc = loc_of_patt x in Ast.PaCom _loc x (paCom_of_list xs) ]; value rec exSem_of_list = fun [ [] -> Ast.ExNil ghost | [ x ] -> x | [ x :: xs ] -> let _loc = loc_of_expr x in Ast.ExSem _loc x (exSem_of_list xs) ]; value rec exCom_of_list = fun [ [] -> Ast.ExNil ghost | [ x ] -> x | [ x :: xs ] -> let _loc = loc_of_expr x in Ast.ExCom _loc x (exCom_of_list xs) ]; value ty_of_stl = fun [ (_loc, s, []) -> Ast.TyId _loc (Ast.IdUid _loc s) | (_loc, s, tl) -> Ast.TyOf _loc (Ast.TyId _loc (Ast.IdUid _loc s)) (tyAnd_of_list tl) ]; value ty_of_sbt = fun [ (_loc, s, True, t) -> Ast.TyCol _loc (Ast.TyId _loc (Ast.IdLid _loc s)) (Ast.TyMut _loc t) | (_loc, s, False, t) -> Ast.TyCol _loc (Ast.TyId _loc (Ast.IdLid _loc s)) t ]; value bi_of_pe (p, e) = let _loc = loc_of_patt p in Ast.BiEq _loc p e; value sum_type_of_list l = tyOr_of_list (List.map ty_of_stl l); value record_type_of_list l = tySem_of_list (List.map ty_of_sbt l); value binding_of_pel l = biAnd_of_list (List.map bi_of_pe l); value rec pel_of_binding = fun [ Ast.BiAnd _ b1 b2 -> (pel_of_binding b1) @ (pel_of_binding b2) | Ast.BiEq _ p e -> [ (p, e) ] | _ -> assert False ]; value rec list_of_binding x acc = match x with [ Ast.BiAnd _ b1 b2 -> list_of_binding b1 (list_of_binding b2 acc) | t -> [ t :: acc ] ]; value rec list_of_rec_binding x acc = match x with [ Ast.RbSem _ b1 b2 -> list_of_rec_binding b1 (list_of_rec_binding b2 acc) | t -> [ t :: acc ] ]; value rec list_of_with_constr x acc = match x with [ Ast.WcAnd _ w1 w2 -> list_of_with_constr w1 (list_of_with_constr w2 acc) | t -> [ t :: acc ] ]; value rec list_of_ctyp x acc = match x with [ Ast.TyNil _ -> acc | Ast.TyAmp _ x y | Ast.TyCom _ x y | Ast.TySta _ x y | Ast.TySem _ x y | Ast.TyAnd _ x y | Ast.TyOr _ x y -> list_of_ctyp x (list_of_ctyp y acc) | x -> [ x :: acc ] ]; value rec list_of_patt x acc = match x with [ Ast.PaNil _ -> acc | Ast.PaCom _ x y | Ast.PaSem _ x y -> list_of_patt x (list_of_patt y acc) | x -> [ x :: acc ] ]; value rec list_of_expr x acc = match x with [ Ast.ExNil _ -> acc | Ast.ExCom _ x y | Ast.ExSem _ x y -> list_of_expr x (list_of_expr y acc) | x -> [ x :: acc ] ]; value rec list_of_str_item x acc = match x with [ Ast.StNil _ -> acc | Ast.StSem _ x y -> list_of_str_item x (list_of_str_item y acc) | x -> [ x :: acc ] ]; value rec list_of_sig_item x acc = match x with [ Ast.SgNil _ -> acc | Ast.SgSem _ x y -> list_of_sig_item x (list_of_sig_item y acc) | x -> [ x :: acc ] ]; value rec list_of_class_sig_item x acc = match x with [ Ast.CgNil _ -> acc | Ast.CgSem _ x y -> list_of_class_sig_item x (list_of_class_sig_item y acc) | x -> [ x :: acc ] ]; value rec list_of_class_str_item x acc = match x with [ Ast.CrNil _ -> acc | Ast.CrSem _ x y -> list_of_class_str_item x (list_of_class_str_item y acc) | x -> [ x :: acc ] ]; value rec list_of_class_type x acc = match x with [ Ast.CtAnd _ x y -> list_of_class_type x (list_of_class_type y acc) | x -> [ x :: acc ] ]; value rec list_of_class_expr x acc = match x with [ Ast.CeAnd _ x y -> list_of_class_expr x (list_of_class_expr y acc) | x -> [ x :: acc ] ]; value rec list_of_module_expr x acc = match x with [ Ast.MeApp _ x y -> list_of_module_expr x (list_of_module_expr y acc) | x -> [ x :: acc ] ]; value rec list_of_match_case x acc = match x with [ Ast.McNil _ -> acc | Ast.McOr _ x y -> list_of_match_case x (list_of_match_case y acc) | x -> [ x :: acc ] ]; value rec list_of_ident x acc = match x with [ Ast.IdAcc _ x y | Ast.IdApp _ x y -> list_of_ident x (list_of_ident y acc) | x -> [ x :: acc ] ]; value rec list_of_module_binding x acc = match x with [ Ast.MbAnd _ x y -> list_of_module_binding x (list_of_module_binding y acc) | x -> [ x :: acc ] ]; module Meta = struct module type META_LOC = sig value meta_loc_patt : Loc.t -> Loc.t -> Ast.patt; value meta_loc_expr : Loc.t -> Loc.t -> Ast.expr; end; module MetaLoc = struct value meta_loc_patt _loc location = let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") (Ast.IdLid _loc "of_tuple"))) (Ast.PaTup _loc (Ast.PaCom _loc (Ast.PaStr _loc (Ast.safe_string_escaped a)) (Ast.PaCom _loc (Ast.PaCom _loc (Ast.PaCom _loc (Ast.PaCom _loc (Ast.PaCom _loc (Ast.PaCom _loc (Ast.PaInt _loc (string_of_int b)) (Ast.PaInt _loc (string_of_int c))) (Ast.PaInt _loc (string_of_int d))) (Ast.PaInt _loc (string_of_int e))) (Ast.PaInt _loc (string_of_int f))) (Ast.PaInt _loc (string_of_int g))) (if h then Ast.PaId _loc (Ast.IdUid _loc "True") else Ast.PaId _loc (Ast.IdUid _loc "False"))))); value meta_loc_expr _loc location = let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") (Ast.IdLid _loc "of_tuple"))) (Ast.ExTup _loc (Ast.ExCom _loc (Ast.ExStr _loc (Ast.safe_string_escaped a)) (Ast.ExCom _loc (Ast.ExCom _loc (Ast.ExCom _loc (Ast.ExCom _loc (Ast.ExCom _loc (Ast.ExCom _loc (Ast.ExInt _loc (string_of_int b)) (Ast.ExInt _loc (string_of_int c))) (Ast.ExInt _loc (string_of_int d))) (Ast.ExInt _loc (string_of_int e))) (Ast.ExInt _loc (string_of_int f))) (Ast.ExInt _loc (string_of_int g))) (if h then Ast.ExId _loc (Ast.IdUid _loc "True") else Ast.ExId _loc (Ast.IdUid _loc "False"))))); end; module MetaGhostLoc = struct value meta_loc_patt _loc _ = Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") (Ast.IdLid _loc "ghost")); value meta_loc_expr _loc _ = Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") (Ast.IdLid _loc "ghost")); end; module MetaLocVar = struct value meta_loc_patt _loc _ = Ast.PaId _loc (Ast.IdLid _loc Loc.name.val); value meta_loc_expr _loc _ = Ast.ExId _loc (Ast.IdLid _loc Loc.name.val); end; module Make (MetaLoc : META_LOC) = struct open MetaLoc; value meta_loc = meta_loc_expr; module Expr = struct value meta_string _loc s = Ast.ExStr _loc (safe_string_escaped s); value meta_int _loc s = Ast.ExInt _loc s; value meta_float _loc s = Ast.ExFlo _loc s; value meta_char _loc s = Ast.ExChr _loc (String.escaped s); value meta_bool _loc = fun [ False -> Ast.ExId _loc (Ast.IdUid _loc "False") | True -> Ast.ExId _loc (Ast.IdUid _loc "True") ]; value rec meta_list mf_a _loc = fun [ [] -> Ast.ExId _loc (Ast.IdUid _loc "[]") | [ x :: xs ] -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdUid _loc "::")) (mf_a _loc x)) (meta_list mf_a _loc xs) ]; value rec meta_binding _loc = fun [ Ast.BiAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.BiEq x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "BiEq"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_expr _loc x2) | Ast.BiAnd x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "BiAnd"))) (meta_loc _loc x0)) (meta_binding _loc x1)) (meta_binding _loc x2) | Ast.BiNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "BiNil"))) (meta_loc _loc x0) ] and meta_class_expr _loc = fun [ Ast.CeAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.CeEq x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeEq"))) (meta_loc _loc x0)) (meta_class_expr _loc x1)) (meta_class_expr _loc x2) | Ast.CeAnd x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeAnd"))) (meta_loc _loc x0)) (meta_class_expr _loc x1)) (meta_class_expr _loc x2) | Ast.CeTyc x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeTyc"))) (meta_loc _loc x0)) (meta_class_expr _loc x1)) (meta_class_type _loc x2) | Ast.CeStr x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeStr"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_class_str_item _loc x2) | Ast.CeLet x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeLet"))) (meta_loc _loc x0)) (meta_rec_flag _loc x1)) (meta_binding _loc x2)) (meta_class_expr _loc x3) | Ast.CeFun x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeFun"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_class_expr _loc x2) | Ast.CeCon x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeCon"))) (meta_loc _loc x0)) (meta_virtual_flag _loc x1)) (meta_ident _loc x2)) (meta_ctyp _loc x3) | Ast.CeApp x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeApp"))) (meta_loc _loc x0)) (meta_class_expr _loc x1)) (meta_expr _loc x2) | Ast.CeNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeNil"))) (meta_loc _loc x0) ] and meta_class_sig_item _loc = fun [ Ast.CgAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.CgVir x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CgVir"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_private_flag _loc x2)) (meta_ctyp _loc x3) | Ast.CgVal x0 x1 x2 x3 x4 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CgVal"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_mutable_flag _loc x2)) (meta_virtual_flag _loc x3)) (meta_ctyp _loc x4) | Ast.CgMth x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CgMth"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_private_flag _loc x2)) (meta_ctyp _loc x3) | Ast.CgInh x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CgInh"))) (meta_loc _loc x0)) (meta_class_type _loc x1) | Ast.CgSem x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CgSem"))) (meta_loc _loc x0)) (meta_class_sig_item _loc x1)) (meta_class_sig_item _loc x2) | Ast.CgCtr x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CgCtr"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.CgNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CgNil"))) (meta_loc _loc x0) ] and meta_class_str_item _loc = fun [ Ast.CrAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.CrVvr x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrVvr"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_mutable_flag _loc x2)) (meta_ctyp _loc x3) | Ast.CrVir x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrVir"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_private_flag _loc x2)) (meta_ctyp _loc x3) | Ast.CrVal x0 x1 x2 x3 x4 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrVal"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_override_flag _loc x2)) (meta_mutable_flag _loc x3)) (meta_expr _loc x4) | Ast.CrMth x0 x1 x2 x3 x4 x5 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrMth"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_override_flag _loc x2)) (meta_private_flag _loc x3)) (meta_expr _loc x4)) (meta_ctyp _loc x5) | Ast.CrIni x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrIni"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.CrInh x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrInh"))) (meta_loc _loc x0)) (meta_override_flag _loc x1)) (meta_class_expr _loc x2)) (meta_string _loc x3) | Ast.CrCtr x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrCtr"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.CrSem x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrSem"))) (meta_loc _loc x0)) (meta_class_str_item _loc x1)) (meta_class_str_item _loc x2) | Ast.CrNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrNil"))) (meta_loc _loc x0) ] and meta_class_type _loc = fun [ Ast.CtAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.CtEq x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CtEq"))) (meta_loc _loc x0)) (meta_class_type _loc x1)) (meta_class_type _loc x2) | Ast.CtCol x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CtCol"))) (meta_loc _loc x0)) (meta_class_type _loc x1)) (meta_class_type _loc x2) | Ast.CtAnd x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CtAnd"))) (meta_loc _loc x0)) (meta_class_type _loc x1)) (meta_class_type _loc x2) | Ast.CtSig x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CtSig"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_class_sig_item _loc x2) | Ast.CtFun x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CtFun"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_class_type _loc x2) | Ast.CtCon x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CtCon"))) (meta_loc _loc x0)) (meta_virtual_flag _loc x1)) (meta_ident _loc x2)) (meta_ctyp _loc x3) | Ast.CtNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CtNil"))) (meta_loc _loc x0) ] and meta_ctyp _loc = fun [ Ast.TyAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.TyPkg x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyPkg"))) (meta_loc _loc x0)) (meta_module_type _loc x1) | Ast.TyOfAmp x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyOfAmp"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyAmp x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyAmp"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyVrnInfSup x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyVrnInfSup"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyVrnInf x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyVrnInf"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TyVrnSup x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyVrnSup"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TyVrnEq x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyVrnEq"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TySta x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TySta"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyTup x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyTup"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TyMut x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyMut"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TyPrv x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyPrv"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TyOr x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyOr"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyAnd x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyAnd"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyOf x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyOf"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TySum x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TySum"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TyCom x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyCom"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TySem x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TySem"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyCol x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyCol"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyRec x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyRec"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TyVrn x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyVrn"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.TyAnM x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyAnM"))) (meta_loc _loc x0) | Ast.TyAnP x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyAnP"))) (meta_loc _loc x0) | Ast.TyQuM x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyQuM"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.TyQuP x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyQuP"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.TyQuo x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyQuo"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.TyTypePol x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyTypePol"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyPol x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyPol"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyOlb x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyOlb"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_ctyp _loc x2) | Ast.TyObj x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyObj"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_row_var_flag _loc x2) | Ast.TyDcl x0 x1 x2 x3 x4 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyDcl"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_list meta_ctyp _loc x2)) (meta_ctyp _loc x3)) (meta_list (fun _loc (x1, x2) -> Ast.ExTup _loc (Ast.ExCom _loc (meta_ctyp _loc x1) (meta_ctyp _loc x2))) _loc x4) | Ast.TyMan x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyMan"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyId x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyId"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.TyLab x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyLab"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_ctyp _loc x2) | Ast.TyCls x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyCls"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.TyArr x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyArr"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyApp x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyApp"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyAny x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyAny"))) (meta_loc _loc x0) | Ast.TyAli x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyAli"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyNil"))) (meta_loc _loc x0) ] and meta_direction_flag _loc = fun [ Ast.DiAnt x0 -> Ast.ExAnt _loc x0 | Ast.DiDownto -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "DiDownto")) | Ast.DiTo -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "DiTo")) ] and meta_expr _loc = fun [ Ast.ExPkg x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExPkg"))) (meta_loc _loc x0)) (meta_module_expr _loc x1) | Ast.ExFUN x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExFUN"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_expr _loc x2) | Ast.ExOpI x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExOpI"))) (meta_loc _loc x0)) (meta_ident _loc x1)) (meta_expr _loc x2) | Ast.ExWhi x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExWhi"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExVrn x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExVrn"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExTyc x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExTyc"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_ctyp _loc x2) | Ast.ExCom x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExCom"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExTup x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExTup"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.ExTry x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExTry"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_match_case _loc x2) | Ast.ExStr x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExStr"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExSte x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExSte"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExSnd x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExSnd"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_string _loc x2) | Ast.ExSeq x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExSeq"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.ExRec x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExRec"))) (meta_loc _loc x0)) (meta_rec_binding _loc x1)) (meta_expr _loc x2) | Ast.ExOvr x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExOvr"))) (meta_loc _loc x0)) (meta_rec_binding _loc x1) | Ast.ExOlb x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExOlb"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_expr _loc x2) | Ast.ExObj x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExObj"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_class_str_item _loc x2) | Ast.ExNew x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExNew"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.ExMat x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExMat"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_match_case _loc x2) | Ast.ExLmd x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExLmd"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_expr _loc x2)) (meta_expr _loc x3) | Ast.ExLet x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExLet"))) (meta_loc _loc x0)) (meta_rec_flag _loc x1)) (meta_binding _loc x2)) (meta_expr _loc x3) | Ast.ExLaz x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExLaz"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.ExLab x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExLab"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_expr _loc x2) | Ast.ExNativeInt x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExNativeInt"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExInt64 x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExInt64"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExInt32 x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExInt32"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExInt x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExInt"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExIfe x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExIfe"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2)) (meta_expr _loc x3) | Ast.ExFun x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExFun"))) (meta_loc _loc x0)) (meta_match_case _loc x1) | Ast.ExFor x0 x1 x2 x3 x4 x5 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExFor"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_expr _loc x2)) (meta_expr _loc x3)) (meta_direction_flag _loc x4)) (meta_expr _loc x5) | Ast.ExFlo x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExFlo"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExCoe x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExCoe"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_ctyp _loc x2)) (meta_ctyp _loc x3) | Ast.ExChr x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExChr"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExAss x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExAss"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExAsr x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExAsr"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.ExAsf x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExAsf"))) (meta_loc _loc x0) | Ast.ExSem x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExSem"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExArr x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExArr"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.ExAre x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExAre"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExApp x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExApp"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.ExAcc x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExAcc"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExId x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExId"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.ExNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExNil"))) (meta_loc _loc x0) ] and meta_ident _loc = fun [ Ast.IdAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.IdUid x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "IdUid"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.IdLid x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "IdLid"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.IdApp x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "IdApp"))) (meta_loc _loc x0)) (meta_ident _loc x1)) (meta_ident _loc x2) | Ast.IdAcc x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "IdAcc"))) (meta_loc _loc x0)) (meta_ident _loc x1)) (meta_ident _loc x2) ] and meta_match_case _loc = fun [ Ast.McAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.McArr x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "McArr"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_expr _loc x2)) (meta_expr _loc x3) | Ast.McOr x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "McOr"))) (meta_loc _loc x0)) (meta_match_case _loc x1)) (meta_match_case _loc x2) | Ast.McNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "McNil"))) (meta_loc _loc x0) ] and meta_meta_bool _loc = fun [ Ast.BAnt x0 -> Ast.ExAnt _loc x0 | Ast.BFalse -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "BFalse")) | Ast.BTrue -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "BTrue")) ] and meta_meta_list mf_a _loc = fun [ Ast.LAnt x0 -> Ast.ExAnt _loc x0 | Ast.LCons x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "LCons"))) (mf_a _loc x0)) (meta_meta_list mf_a _loc x1) | Ast.LNil -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "LNil")) ] and meta_meta_option mf_a _loc = fun [ Ast.OAnt x0 -> Ast.ExAnt _loc x0 | Ast.OSome x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "OSome"))) (mf_a _loc x0) | Ast.ONone -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ONone")) ] and meta_module_binding _loc = fun [ Ast.MbAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.MbCol x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MbCol"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_type _loc x2) | Ast.MbColEq x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MbColEq"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_type _loc x2)) (meta_module_expr _loc x3) | Ast.MbAnd x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MbAnd"))) (meta_loc _loc x0)) (meta_module_binding _loc x1)) (meta_module_binding _loc x2) | Ast.MbNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MbNil"))) (meta_loc _loc x0) ] and meta_module_expr _loc = fun [ Ast.MeAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.MePkg x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MePkg"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.MeTyc x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MeTyc"))) (meta_loc _loc x0)) (meta_module_expr _loc x1)) (meta_module_type _loc x2) | Ast.MeStr x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MeStr"))) (meta_loc _loc x0)) (meta_str_item _loc x1) | Ast.MeFun x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MeFun"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_type _loc x2)) (meta_module_expr _loc x3) | Ast.MeApp x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MeApp"))) (meta_loc _loc x0)) (meta_module_expr _loc x1)) (meta_module_expr _loc x2) | Ast.MeId x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MeId"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.MeNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MeNil"))) (meta_loc _loc x0) ] and meta_module_type _loc = fun [ Ast.MtAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.MtOf x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MtOf"))) (meta_loc _loc x0)) (meta_module_expr _loc x1) | Ast.MtWit x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MtWit"))) (meta_loc _loc x0)) (meta_module_type _loc x1)) (meta_with_constr _loc x2) | Ast.MtSig x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MtSig"))) (meta_loc _loc x0)) (meta_sig_item _loc x1) | Ast.MtQuo x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MtQuo"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.MtFun x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MtFun"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_type _loc x2)) (meta_module_type _loc x3) | Ast.MtId x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MtId"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.MtNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MtNil"))) (meta_loc _loc x0) ] and meta_mutable_flag _loc = fun [ Ast.MuAnt x0 -> Ast.ExAnt _loc x0 | Ast.MuNil -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MuNil")) | Ast.MuMutable -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MuMutable")) ] and meta_override_flag _loc = fun [ Ast.OvAnt x0 -> Ast.ExAnt _loc x0 | Ast.OvNil -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "OvNil")) | Ast.OvOverride -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "OvOverride")) ] and meta_patt _loc = fun [ Ast.PaMod x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaMod"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaLaz x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaLaz"))) (meta_loc _loc x0)) (meta_patt _loc x1) | Ast.PaVrn x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaVrn"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaTyp x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaTyp"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.PaTyc x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaTyc"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_ctyp _loc x2) | Ast.PaTup x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaTup"))) (meta_loc _loc x0)) (meta_patt _loc x1) | Ast.PaStr x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaStr"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaEq x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaEq"))) (meta_loc _loc x0)) (meta_ident _loc x1)) (meta_patt _loc x2) | Ast.PaRec x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaRec"))) (meta_loc _loc x0)) (meta_patt _loc x1) | Ast.PaRng x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaRng"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_patt _loc x2) | Ast.PaOrp x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaOrp"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_patt _loc x2) | Ast.PaOlbi x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaOlbi"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_patt _loc x2)) (meta_expr _loc x3) | Ast.PaOlb x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaOlb"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_patt _loc x2) | Ast.PaLab x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaLab"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_patt _loc x2) | Ast.PaFlo x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaFlo"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaNativeInt x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaNativeInt"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaInt64 x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaInt64"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaInt32 x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaInt32"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaInt x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaInt"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaChr x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaChr"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaSem x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaSem"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_patt _loc x2) | Ast.PaCom x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaCom"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_patt _loc x2) | Ast.PaArr x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaArr"))) (meta_loc _loc x0)) (meta_patt _loc x1) | Ast.PaApp x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaApp"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_patt _loc x2) | Ast.PaAny x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaAny"))) (meta_loc _loc x0) | Ast.PaAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.PaAli x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaAli"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_patt _loc x2) | Ast.PaId x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaId"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.PaNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaNil"))) (meta_loc _loc x0) ] and meta_private_flag _loc = fun [ Ast.PrAnt x0 -> Ast.ExAnt _loc x0 | Ast.PrNil -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PrNil")) | Ast.PrPrivate -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PrPrivate")) ] and meta_rec_binding _loc = fun [ Ast.RbAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.RbEq x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "RbEq"))) (meta_loc _loc x0)) (meta_ident _loc x1)) (meta_expr _loc x2) | Ast.RbSem x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "RbSem"))) (meta_loc _loc x0)) (meta_rec_binding _loc x1)) (meta_rec_binding _loc x2) | Ast.RbNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "RbNil"))) (meta_loc _loc x0) ] and meta_rec_flag _loc = fun [ Ast.ReAnt x0 -> Ast.ExAnt _loc x0 | Ast.ReNil -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ReNil")) | Ast.ReRecursive -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ReRecursive")) ] and meta_row_var_flag _loc = fun [ Ast.RvAnt x0 -> Ast.ExAnt _loc x0 | Ast.RvNil -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "RvNil")) | Ast.RvRowVar -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "RvRowVar")) ] and meta_sig_item _loc = fun [ Ast.SgAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.SgVal x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgVal"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_ctyp _loc x2) | Ast.SgTyp x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgTyp"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.SgOpn x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgOpn"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.SgMty x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgMty"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_type _loc x2) | Ast.SgRecMod x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgRecMod"))) (meta_loc _loc x0)) (meta_module_binding _loc x1) | Ast.SgMod x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgMod"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_type _loc x2) | Ast.SgInc x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgInc"))) (meta_loc _loc x0)) (meta_module_type _loc x1) | Ast.SgExt x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgExt"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_ctyp _loc x2)) (meta_meta_list meta_string _loc x3) | Ast.SgExc x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgExc"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.SgDir x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgDir"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_expr _loc x2) | Ast.SgSem x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgSem"))) (meta_loc _loc x0)) (meta_sig_item _loc x1)) (meta_sig_item _loc x2) | Ast.SgClt x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgClt"))) (meta_loc _loc x0)) (meta_class_type _loc x1) | Ast.SgCls x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgCls"))) (meta_loc _loc x0)) (meta_class_type _loc x1) | Ast.SgNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgNil"))) (meta_loc _loc x0) ] and meta_str_item _loc = fun [ Ast.StAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.StVal x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StVal"))) (meta_loc _loc x0)) (meta_rec_flag _loc x1)) (meta_binding _loc x2) | Ast.StTyp x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StTyp"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.StOpn x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StOpn"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.StMty x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StMty"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_type _loc x2) | Ast.StRecMod x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StRecMod"))) (meta_loc _loc x0)) (meta_module_binding _loc x1) | Ast.StMod x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StMod"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_expr _loc x2) | Ast.StInc x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StInc"))) (meta_loc _loc x0)) (meta_module_expr _loc x1) | Ast.StExt x0 x1 x2 x3 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StExt"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_ctyp _loc x2)) (meta_meta_list meta_string _loc x3) | Ast.StExp x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StExp"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.StExc x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StExc"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_meta_option meta_ident _loc x2) | Ast.StDir x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StDir"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_expr _loc x2) | Ast.StSem x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StSem"))) (meta_loc _loc x0)) (meta_str_item _loc x1)) (meta_str_item _loc x2) | Ast.StClt x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StClt"))) (meta_loc _loc x0)) (meta_class_type _loc x1) | Ast.StCls x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StCls"))) (meta_loc _loc x0)) (meta_class_expr _loc x1) | Ast.StNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StNil"))) (meta_loc _loc x0) ] and meta_virtual_flag _loc = fun [ Ast.ViAnt x0 -> Ast.ExAnt _loc x0 | Ast.ViNil -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ViNil")) | Ast.ViVirtual -> Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ViVirtual")) ] and meta_with_constr _loc = fun [ Ast.WcAnt x0 x1 -> Ast.ExAnt x0 x1 | Ast.WcAnd x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "WcAnd"))) (meta_loc _loc x0)) (meta_with_constr _loc x1)) (meta_with_constr _loc x2) | Ast.WcMoS x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "WcMoS"))) (meta_loc _loc x0)) (meta_ident _loc x1)) (meta_ident _loc x2) | Ast.WcTyS x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "WcTyS"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.WcMod x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "WcMod"))) (meta_loc _loc x0)) (meta_ident _loc x1)) (meta_ident _loc x2) | Ast.WcTyp x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "WcTyp"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.WcNil x0 -> Ast.ExApp _loc (Ast.ExId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "WcNil"))) (meta_loc _loc x0) ]; end; value meta_loc = meta_loc_patt; module Patt = struct value meta_string _loc s = Ast.PaStr _loc (safe_string_escaped s); value meta_int _loc s = Ast.PaInt _loc s; value meta_float _loc s = Ast.PaFlo _loc s; value meta_char _loc s = Ast.PaChr _loc (String.escaped s); value meta_bool _loc = fun [ False -> Ast.PaId _loc (Ast.IdUid _loc "False") | True -> Ast.PaId _loc (Ast.IdUid _loc "True") ]; value rec meta_list mf_a _loc = fun [ [] -> Ast.PaId _loc (Ast.IdUid _loc "[]") | [ x :: xs ] -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdUid _loc "::")) (mf_a _loc x)) (meta_list mf_a _loc xs) ]; value rec meta_binding _loc = fun [ Ast.BiAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.BiEq x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "BiEq"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_expr _loc x2) | Ast.BiAnd x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "BiAnd"))) (meta_loc _loc x0)) (meta_binding _loc x1)) (meta_binding _loc x2) | Ast.BiNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "BiNil"))) (meta_loc _loc x0) ] and meta_class_expr _loc = fun [ Ast.CeAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.CeEq x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeEq"))) (meta_loc _loc x0)) (meta_class_expr _loc x1)) (meta_class_expr _loc x2) | Ast.CeAnd x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeAnd"))) (meta_loc _loc x0)) (meta_class_expr _loc x1)) (meta_class_expr _loc x2) | Ast.CeTyc x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeTyc"))) (meta_loc _loc x0)) (meta_class_expr _loc x1)) (meta_class_type _loc x2) | Ast.CeStr x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeStr"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_class_str_item _loc x2) | Ast.CeLet x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeLet"))) (meta_loc _loc x0)) (meta_rec_flag _loc x1)) (meta_binding _loc x2)) (meta_class_expr _loc x3) | Ast.CeFun x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeFun"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_class_expr _loc x2) | Ast.CeCon x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeCon"))) (meta_loc _loc x0)) (meta_virtual_flag _loc x1)) (meta_ident _loc x2)) (meta_ctyp _loc x3) | Ast.CeApp x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeApp"))) (meta_loc _loc x0)) (meta_class_expr _loc x1)) (meta_expr _loc x2) | Ast.CeNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CeNil"))) (meta_loc _loc x0) ] and meta_class_sig_item _loc = fun [ Ast.CgAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.CgVir x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CgVir"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_private_flag _loc x2)) (meta_ctyp _loc x3) | Ast.CgVal x0 x1 x2 x3 x4 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CgVal"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_mutable_flag _loc x2)) (meta_virtual_flag _loc x3)) (meta_ctyp _loc x4) | Ast.CgMth x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CgMth"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_private_flag _loc x2)) (meta_ctyp _loc x3) | Ast.CgInh x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CgInh"))) (meta_loc _loc x0)) (meta_class_type _loc x1) | Ast.CgSem x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CgSem"))) (meta_loc _loc x0)) (meta_class_sig_item _loc x1)) (meta_class_sig_item _loc x2) | Ast.CgCtr x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CgCtr"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.CgNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CgNil"))) (meta_loc _loc x0) ] and meta_class_str_item _loc = fun [ Ast.CrAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.CrVvr x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrVvr"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_mutable_flag _loc x2)) (meta_ctyp _loc x3) | Ast.CrVir x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrVir"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_private_flag _loc x2)) (meta_ctyp _loc x3) | Ast.CrVal x0 x1 x2 x3 x4 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrVal"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_override_flag _loc x2)) (meta_mutable_flag _loc x3)) (meta_expr _loc x4) | Ast.CrMth x0 x1 x2 x3 x4 x5 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrMth"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_override_flag _loc x2)) (meta_private_flag _loc x3)) (meta_expr _loc x4)) (meta_ctyp _loc x5) | Ast.CrIni x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrIni"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.CrInh x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrInh"))) (meta_loc _loc x0)) (meta_override_flag _loc x1)) (meta_class_expr _loc x2)) (meta_string _loc x3) | Ast.CrCtr x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrCtr"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.CrSem x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrSem"))) (meta_loc _loc x0)) (meta_class_str_item _loc x1)) (meta_class_str_item _loc x2) | Ast.CrNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CrNil"))) (meta_loc _loc x0) ] and meta_class_type _loc = fun [ Ast.CtAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.CtEq x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CtEq"))) (meta_loc _loc x0)) (meta_class_type _loc x1)) (meta_class_type _loc x2) | Ast.CtCol x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CtCol"))) (meta_loc _loc x0)) (meta_class_type _loc x1)) (meta_class_type _loc x2) | Ast.CtAnd x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CtAnd"))) (meta_loc _loc x0)) (meta_class_type _loc x1)) (meta_class_type _loc x2) | Ast.CtSig x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CtSig"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_class_sig_item _loc x2) | Ast.CtFun x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CtFun"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_class_type _loc x2) | Ast.CtCon x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CtCon"))) (meta_loc _loc x0)) (meta_virtual_flag _loc x1)) (meta_ident _loc x2)) (meta_ctyp _loc x3) | Ast.CtNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "CtNil"))) (meta_loc _loc x0) ] and meta_ctyp _loc = fun [ Ast.TyAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.TyPkg x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyPkg"))) (meta_loc _loc x0)) (meta_module_type _loc x1) | Ast.TyOfAmp x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyOfAmp"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyAmp x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyAmp"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyVrnInfSup x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyVrnInfSup"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyVrnInf x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyVrnInf"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TyVrnSup x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyVrnSup"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TyVrnEq x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyVrnEq"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TySta x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TySta"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyTup x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyTup"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TyMut x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyMut"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TyPrv x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyPrv"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TyOr x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyOr"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyAnd x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyAnd"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyOf x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyOf"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TySum x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TySum"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TyCom x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyCom"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TySem x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TySem"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyCol x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyCol"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyRec x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyRec"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.TyVrn x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyVrn"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.TyAnM x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyAnM"))) (meta_loc _loc x0) | Ast.TyAnP x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyAnP"))) (meta_loc _loc x0) | Ast.TyQuM x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyQuM"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.TyQuP x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyQuP"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.TyQuo x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyQuo"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.TyTypePol x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyTypePol"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyPol x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyPol"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyOlb x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyOlb"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_ctyp _loc x2) | Ast.TyObj x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyObj"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_row_var_flag _loc x2) | Ast.TyDcl x0 x1 x2 x3 x4 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyDcl"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_list meta_ctyp _loc x2)) (meta_ctyp _loc x3)) (meta_list (fun _loc (x1, x2) -> Ast.PaTup _loc (Ast.PaCom _loc (meta_ctyp _loc x1) (meta_ctyp _loc x2))) _loc x4) | Ast.TyMan x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyMan"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyId x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyId"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.TyLab x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyLab"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_ctyp _loc x2) | Ast.TyCls x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyCls"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.TyArr x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyArr"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyApp x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyApp"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyAny x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyAny"))) (meta_loc _loc x0) | Ast.TyAli x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyAli"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.TyNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "TyNil"))) (meta_loc _loc x0) ] and meta_direction_flag _loc = fun [ Ast.DiAnt x0 -> Ast.PaAnt _loc x0 | Ast.DiDownto -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "DiDownto")) | Ast.DiTo -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "DiTo")) ] and meta_expr _loc = fun [ Ast.ExPkg x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExPkg"))) (meta_loc _loc x0)) (meta_module_expr _loc x1) | Ast.ExFUN x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExFUN"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_expr _loc x2) | Ast.ExOpI x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExOpI"))) (meta_loc _loc x0)) (meta_ident _loc x1)) (meta_expr _loc x2) | Ast.ExWhi x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExWhi"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExVrn x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExVrn"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExTyc x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExTyc"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_ctyp _loc x2) | Ast.ExCom x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExCom"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExTup x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExTup"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.ExTry x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExTry"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_match_case _loc x2) | Ast.ExStr x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExStr"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExSte x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExSte"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExSnd x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExSnd"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_string _loc x2) | Ast.ExSeq x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExSeq"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.ExRec x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExRec"))) (meta_loc _loc x0)) (meta_rec_binding _loc x1)) (meta_expr _loc x2) | Ast.ExOvr x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExOvr"))) (meta_loc _loc x0)) (meta_rec_binding _loc x1) | Ast.ExOlb x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExOlb"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_expr _loc x2) | Ast.ExObj x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExObj"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_class_str_item _loc x2) | Ast.ExNew x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExNew"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.ExMat x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExMat"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_match_case _loc x2) | Ast.ExLmd x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExLmd"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_expr _loc x2)) (meta_expr _loc x3) | Ast.ExLet x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExLet"))) (meta_loc _loc x0)) (meta_rec_flag _loc x1)) (meta_binding _loc x2)) (meta_expr _loc x3) | Ast.ExLaz x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExLaz"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.ExLab x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExLab"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_expr _loc x2) | Ast.ExNativeInt x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExNativeInt"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExInt64 x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExInt64"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExInt32 x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExInt32"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExInt x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExInt"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExIfe x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExIfe"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2)) (meta_expr _loc x3) | Ast.ExFun x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExFun"))) (meta_loc _loc x0)) (meta_match_case _loc x1) | Ast.ExFor x0 x1 x2 x3 x4 x5 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExFor"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_expr _loc x2)) (meta_expr _loc x3)) (meta_direction_flag _loc x4)) (meta_expr _loc x5) | Ast.ExFlo x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExFlo"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExCoe x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExCoe"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_ctyp _loc x2)) (meta_ctyp _loc x3) | Ast.ExChr x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExChr"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.ExAss x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExAss"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExAsr x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExAsr"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.ExAsf x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExAsf"))) (meta_loc _loc x0) | Ast.ExSem x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExSem"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExArr x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExArr"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.ExAre x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExAre"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExApp x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExApp"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.ExAcc x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExAcc"))) (meta_loc _loc x0)) (meta_expr _loc x1)) (meta_expr _loc x2) | Ast.ExId x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExId"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.ExNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ExNil"))) (meta_loc _loc x0) ] and meta_ident _loc = fun [ Ast.IdAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.IdUid x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "IdUid"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.IdLid x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "IdLid"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.IdApp x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "IdApp"))) (meta_loc _loc x0)) (meta_ident _loc x1)) (meta_ident _loc x2) | Ast.IdAcc x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "IdAcc"))) (meta_loc _loc x0)) (meta_ident _loc x1)) (meta_ident _loc x2) ] and meta_match_case _loc = fun [ Ast.McAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.McArr x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "McArr"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_expr _loc x2)) (meta_expr _loc x3) | Ast.McOr x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "McOr"))) (meta_loc _loc x0)) (meta_match_case _loc x1)) (meta_match_case _loc x2) | Ast.McNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "McNil"))) (meta_loc _loc x0) ] and meta_meta_bool _loc = fun [ Ast.BAnt x0 -> Ast.PaAnt _loc x0 | Ast.BFalse -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "BFalse")) | Ast.BTrue -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "BTrue")) ] and meta_meta_list mf_a _loc = fun [ Ast.LAnt x0 -> Ast.PaAnt _loc x0 | Ast.LCons x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "LCons"))) (mf_a _loc x0)) (meta_meta_list mf_a _loc x1) | Ast.LNil -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "LNil")) ] and meta_meta_option mf_a _loc = fun [ Ast.OAnt x0 -> Ast.PaAnt _loc x0 | Ast.OSome x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "OSome"))) (mf_a _loc x0) | Ast.ONone -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ONone")) ] and meta_module_binding _loc = fun [ Ast.MbAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.MbCol x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MbCol"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_type _loc x2) | Ast.MbColEq x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MbColEq"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_type _loc x2)) (meta_module_expr _loc x3) | Ast.MbAnd x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MbAnd"))) (meta_loc _loc x0)) (meta_module_binding _loc x1)) (meta_module_binding _loc x2) | Ast.MbNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MbNil"))) (meta_loc _loc x0) ] and meta_module_expr _loc = fun [ Ast.MeAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.MePkg x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MePkg"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.MeTyc x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MeTyc"))) (meta_loc _loc x0)) (meta_module_expr _loc x1)) (meta_module_type _loc x2) | Ast.MeStr x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MeStr"))) (meta_loc _loc x0)) (meta_str_item _loc x1) | Ast.MeFun x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MeFun"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_type _loc x2)) (meta_module_expr _loc x3) | Ast.MeApp x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MeApp"))) (meta_loc _loc x0)) (meta_module_expr _loc x1)) (meta_module_expr _loc x2) | Ast.MeId x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MeId"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.MeNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MeNil"))) (meta_loc _loc x0) ] and meta_module_type _loc = fun [ Ast.MtAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.MtOf x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MtOf"))) (meta_loc _loc x0)) (meta_module_expr _loc x1) | Ast.MtWit x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MtWit"))) (meta_loc _loc x0)) (meta_module_type _loc x1)) (meta_with_constr _loc x2) | Ast.MtSig x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MtSig"))) (meta_loc _loc x0)) (meta_sig_item _loc x1) | Ast.MtQuo x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MtQuo"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.MtFun x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MtFun"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_type _loc x2)) (meta_module_type _loc x3) | Ast.MtId x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MtId"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.MtNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MtNil"))) (meta_loc _loc x0) ] and meta_mutable_flag _loc = fun [ Ast.MuAnt x0 -> Ast.PaAnt _loc x0 | Ast.MuNil -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MuNil")) | Ast.MuMutable -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "MuMutable")) ] and meta_override_flag _loc = fun [ Ast.OvAnt x0 -> Ast.PaAnt _loc x0 | Ast.OvNil -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "OvNil")) | Ast.OvOverride -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "OvOverride")) ] and meta_patt _loc = fun [ Ast.PaMod x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaMod"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaLaz x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaLaz"))) (meta_loc _loc x0)) (meta_patt _loc x1) | Ast.PaVrn x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaVrn"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaTyp x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaTyp"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.PaTyc x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaTyc"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_ctyp _loc x2) | Ast.PaTup x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaTup"))) (meta_loc _loc x0)) (meta_patt _loc x1) | Ast.PaStr x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaStr"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaEq x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaEq"))) (meta_loc _loc x0)) (meta_ident _loc x1)) (meta_patt _loc x2) | Ast.PaRec x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaRec"))) (meta_loc _loc x0)) (meta_patt _loc x1) | Ast.PaRng x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaRng"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_patt _loc x2) | Ast.PaOrp x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaOrp"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_patt _loc x2) | Ast.PaOlbi x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaOlbi"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_patt _loc x2)) (meta_expr _loc x3) | Ast.PaOlb x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaOlb"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_patt _loc x2) | Ast.PaLab x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaLab"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_patt _loc x2) | Ast.PaFlo x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaFlo"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaNativeInt x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaNativeInt"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaInt64 x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaInt64"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaInt32 x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaInt32"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaInt x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaInt"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaChr x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaChr"))) (meta_loc _loc x0)) (meta_string _loc x1) | Ast.PaSem x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaSem"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_patt _loc x2) | Ast.PaCom x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaCom"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_patt _loc x2) | Ast.PaArr x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaArr"))) (meta_loc _loc x0)) (meta_patt _loc x1) | Ast.PaApp x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaApp"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_patt _loc x2) | Ast.PaAny x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaAny"))) (meta_loc _loc x0) | Ast.PaAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.PaAli x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaAli"))) (meta_loc _loc x0)) (meta_patt _loc x1)) (meta_patt _loc x2) | Ast.PaId x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaId"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.PaNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PaNil"))) (meta_loc _loc x0) ] and meta_private_flag _loc = fun [ Ast.PrAnt x0 -> Ast.PaAnt _loc x0 | Ast.PrNil -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PrNil")) | Ast.PrPrivate -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "PrPrivate")) ] and meta_rec_binding _loc = fun [ Ast.RbAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.RbEq x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "RbEq"))) (meta_loc _loc x0)) (meta_ident _loc x1)) (meta_expr _loc x2) | Ast.RbSem x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "RbSem"))) (meta_loc _loc x0)) (meta_rec_binding _loc x1)) (meta_rec_binding _loc x2) | Ast.RbNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "RbNil"))) (meta_loc _loc x0) ] and meta_rec_flag _loc = fun [ Ast.ReAnt x0 -> Ast.PaAnt _loc x0 | Ast.ReNil -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ReNil")) | Ast.ReRecursive -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ReRecursive")) ] and meta_row_var_flag _loc = fun [ Ast.RvAnt x0 -> Ast.PaAnt _loc x0 | Ast.RvNil -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "RvNil")) | Ast.RvRowVar -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "RvRowVar")) ] and meta_sig_item _loc = fun [ Ast.SgAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.SgVal x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgVal"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_ctyp _loc x2) | Ast.SgTyp x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgTyp"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.SgOpn x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgOpn"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.SgMty x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgMty"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_type _loc x2) | Ast.SgRecMod x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgRecMod"))) (meta_loc _loc x0)) (meta_module_binding _loc x1) | Ast.SgMod x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgMod"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_type _loc x2) | Ast.SgInc x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgInc"))) (meta_loc _loc x0)) (meta_module_type _loc x1) | Ast.SgExt x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgExt"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_ctyp _loc x2)) (meta_meta_list meta_string _loc x3) | Ast.SgExc x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgExc"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.SgDir x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgDir"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_expr _loc x2) | Ast.SgSem x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgSem"))) (meta_loc _loc x0)) (meta_sig_item _loc x1)) (meta_sig_item _loc x2) | Ast.SgClt x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgClt"))) (meta_loc _loc x0)) (meta_class_type _loc x1) | Ast.SgCls x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgCls"))) (meta_loc _loc x0)) (meta_class_type _loc x1) | Ast.SgNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "SgNil"))) (meta_loc _loc x0) ] and meta_str_item _loc = fun [ Ast.StAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.StVal x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StVal"))) (meta_loc _loc x0)) (meta_rec_flag _loc x1)) (meta_binding _loc x2) | Ast.StTyp x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StTyp"))) (meta_loc _loc x0)) (meta_ctyp _loc x1) | Ast.StOpn x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StOpn"))) (meta_loc _loc x0)) (meta_ident _loc x1) | Ast.StMty x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StMty"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_type _loc x2) | Ast.StRecMod x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StRecMod"))) (meta_loc _loc x0)) (meta_module_binding _loc x1) | Ast.StMod x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StMod"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_module_expr _loc x2) | Ast.StInc x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StInc"))) (meta_loc _loc x0)) (meta_module_expr _loc x1) | Ast.StExt x0 x1 x2 x3 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StExt"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_ctyp _loc x2)) (meta_meta_list meta_string _loc x3) | Ast.StExp x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StExp"))) (meta_loc _loc x0)) (meta_expr _loc x1) | Ast.StExc x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StExc"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_meta_option meta_ident _loc x2) | Ast.StDir x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StDir"))) (meta_loc _loc x0)) (meta_string _loc x1)) (meta_expr _loc x2) | Ast.StSem x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StSem"))) (meta_loc _loc x0)) (meta_str_item _loc x1)) (meta_str_item _loc x2) | Ast.StClt x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StClt"))) (meta_loc _loc x0)) (meta_class_type _loc x1) | Ast.StCls x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StCls"))) (meta_loc _loc x0)) (meta_class_expr _loc x1) | Ast.StNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "StNil"))) (meta_loc _loc x0) ] and meta_virtual_flag _loc = fun [ Ast.ViAnt x0 -> Ast.PaAnt _loc x0 | Ast.ViNil -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ViNil")) | Ast.ViVirtual -> Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "ViVirtual")) ] and meta_with_constr _loc = fun [ Ast.WcAnt x0 x1 -> Ast.PaAnt x0 x1 | Ast.WcAnd x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "WcAnd"))) (meta_loc _loc x0)) (meta_with_constr _loc x1)) (meta_with_constr _loc x2) | Ast.WcMoS x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "WcMoS"))) (meta_loc _loc x0)) (meta_ident _loc x1)) (meta_ident _loc x2) | Ast.WcTyS x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "WcTyS"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.WcMod x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "WcMod"))) (meta_loc _loc x0)) (meta_ident _loc x1)) (meta_ident _loc x2) | Ast.WcTyp x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "WcTyp"))) (meta_loc _loc x0)) (meta_ctyp _loc x1)) (meta_ctyp _loc x2) | Ast.WcNil x0 -> Ast.PaApp _loc (Ast.PaId _loc (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") (Ast.IdUid _loc "WcNil"))) (meta_loc _loc x0) ]; end; end; end; class map = object ((o : 'self_type)) method string : string -> string = o#unknown; method list : ! 'a 'a_out. ('self_type -> 'a -> 'a_out) -> list 'a -> list 'a_out = fun _f_a -> fun [ [] -> [] | [ _x :: _x_i1 ] -> let _x = _f_a o _x in let _x_i1 = o#list _f_a _x_i1 in [ _x :: _x_i1 ] ]; method with_constr : with_constr -> with_constr = fun [ WcNil _x -> let _x = o#loc _x in WcNil _x | WcTyp _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in WcTyp _x _x_i1 _x_i2 | WcMod _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in let _x_i2 = o#ident _x_i2 in WcMod _x _x_i1 _x_i2 | WcTyS _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in WcTyS _x _x_i1 _x_i2 | WcMoS _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in let _x_i2 = o#ident _x_i2 in WcMoS _x _x_i1 _x_i2 | WcAnd _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#with_constr _x_i1 in let _x_i2 = o#with_constr _x_i2 in WcAnd _x _x_i1 _x_i2 | WcAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in WcAnt _x _x_i1 ]; method virtual_flag : virtual_flag -> virtual_flag = fun [ ViVirtual -> ViVirtual | ViNil -> ViNil | ViAnt _x -> let _x = o#string _x in ViAnt _x ]; method str_item : str_item -> str_item = fun [ StNil _x -> let _x = o#loc _x in StNil _x | StCls _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#class_expr _x_i1 in StCls _x _x_i1 | StClt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#class_type _x_i1 in StClt _x _x_i1 | StSem _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#str_item _x_i1 in let _x_i2 = o#str_item _x_i2 in StSem _x _x_i1 _x_i2 | StDir _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#expr _x_i2 in StDir _x _x_i1 _x_i2 | StExc _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#meta_option (fun o -> o#ident) _x_i2 in StExc _x _x_i1 _x_i2 | StExp _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in StExp _x _x_i1 | StExt _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#ctyp _x_i2 in let _x_i3 = o#meta_list (fun o -> o#string) _x_i3 in StExt _x _x_i1 _x_i2 _x_i3 | StInc _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#module_expr _x_i1 in StInc _x _x_i1 | StMod _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_expr _x_i2 in StMod _x _x_i1 _x_i2 | StRecMod _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#module_binding _x_i1 in StRecMod _x _x_i1 | StMty _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_type _x_i2 in StMty _x _x_i1 _x_i2 | StOpn _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in StOpn _x _x_i1 | StTyp _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in StTyp _x _x_i1 | StVal _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#rec_flag _x_i1 in let _x_i2 = o#binding _x_i2 in StVal _x _x_i1 _x_i2 | StAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in StAnt _x _x_i1 ]; method sig_item : sig_item -> sig_item = fun [ SgNil _x -> let _x = o#loc _x in SgNil _x | SgCls _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#class_type _x_i1 in SgCls _x _x_i1 | SgClt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#class_type _x_i1 in SgClt _x _x_i1 | SgSem _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#sig_item _x_i1 in let _x_i2 = o#sig_item _x_i2 in SgSem _x _x_i1 _x_i2 | SgDir _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#expr _x_i2 in SgDir _x _x_i1 _x_i2 | SgExc _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in SgExc _x _x_i1 | SgExt _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#ctyp _x_i2 in let _x_i3 = o#meta_list (fun o -> o#string) _x_i3 in SgExt _x _x_i1 _x_i2 _x_i3 | SgInc _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#module_type _x_i1 in SgInc _x _x_i1 | SgMod _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_type _x_i2 in SgMod _x _x_i1 _x_i2 | SgRecMod _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#module_binding _x_i1 in SgRecMod _x _x_i1 | SgMty _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_type _x_i2 in SgMty _x _x_i1 _x_i2 | SgOpn _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in SgOpn _x _x_i1 | SgTyp _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in SgTyp _x _x_i1 | SgVal _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#ctyp _x_i2 in SgVal _x _x_i1 _x_i2 | SgAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in SgAnt _x _x_i1 ]; method row_var_flag : row_var_flag -> row_var_flag = fun [ RvRowVar -> RvRowVar | RvNil -> RvNil | RvAnt _x -> let _x = o#string _x in RvAnt _x ]; method rec_flag : rec_flag -> rec_flag = fun [ ReRecursive -> ReRecursive | ReNil -> ReNil | ReAnt _x -> let _x = o#string _x in ReAnt _x ]; method rec_binding : rec_binding -> rec_binding = fun [ RbNil _x -> let _x = o#loc _x in RbNil _x | RbSem _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#rec_binding _x_i1 in let _x_i2 = o#rec_binding _x_i2 in RbSem _x _x_i1 _x_i2 | RbEq _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in let _x_i2 = o#expr _x_i2 in RbEq _x _x_i1 _x_i2 | RbAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in RbAnt _x _x_i1 ]; method private_flag : private_flag -> private_flag = fun [ PrPrivate -> PrPrivate | PrNil -> PrNil | PrAnt _x -> let _x = o#string _x in PrAnt _x ]; method patt : patt -> patt = fun [ PaNil _x -> let _x = o#loc _x in PaNil _x | PaId _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in PaId _x _x_i1 | PaAli _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#patt _x_i2 in PaAli _x _x_i1 _x_i2 | PaAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaAnt _x _x_i1 | PaAny _x -> let _x = o#loc _x in PaAny _x | PaApp _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#patt _x_i2 in PaApp _x _x_i1 _x_i2 | PaArr _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaArr _x _x_i1 | PaCom _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#patt _x_i2 in PaCom _x _x_i1 _x_i2 | PaSem _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#patt _x_i2 in PaSem _x _x_i1 _x_i2 | PaChr _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaChr _x _x_i1 | PaInt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaInt _x _x_i1 | PaInt32 _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaInt32 _x _x_i1 | PaInt64 _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaInt64 _x _x_i1 | PaNativeInt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaNativeInt _x _x_i1 | PaFlo _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaFlo _x _x_i1 | PaLab _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#patt _x_i2 in PaLab _x _x_i1 _x_i2 | PaOlb _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#patt _x_i2 in PaOlb _x _x_i1 _x_i2 | PaOlbi _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#patt _x_i2 in let _x_i3 = o#expr _x_i3 in PaOlbi _x _x_i1 _x_i2 _x_i3 | PaOrp _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#patt _x_i2 in PaOrp _x _x_i1 _x_i2 | PaRng _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#patt _x_i2 in PaRng _x _x_i1 _x_i2 | PaRec _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaRec _x _x_i1 | PaEq _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in let _x_i2 = o#patt _x_i2 in PaEq _x _x_i1 _x_i2 | PaStr _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaStr _x _x_i1 | PaTup _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaTup _x _x_i1 | PaTyc _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#ctyp _x_i2 in PaTyc _x _x_i1 _x_i2 | PaTyp _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in PaTyp _x _x_i1 | PaVrn _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaVrn _x _x_i1 | PaLaz _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz _x _x_i1 | PaMod _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaMod _x _x_i1 ]; method override_flag : override_flag -> override_flag = fun [ OvOverride -> OvOverride | OvNil -> OvNil | OvAnt _x -> let _x = o#string _x in OvAnt _x ]; method mutable_flag : mutable_flag -> mutable_flag = fun [ MuMutable -> MuMutable | MuNil -> MuNil | MuAnt _x -> let _x = o#string _x in MuAnt _x ]; method module_type : module_type -> module_type = fun [ MtNil _x -> let _x = o#loc _x in MtNil _x | MtId _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in MtId _x _x_i1 | MtFun _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_type _x_i2 in let _x_i3 = o#module_type _x_i3 in MtFun _x _x_i1 _x_i2 _x_i3 | MtQuo _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MtQuo _x _x_i1 | MtSig _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#sig_item _x_i1 in MtSig _x _x_i1 | MtWit _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#module_type _x_i1 in let _x_i2 = o#with_constr _x_i2 in MtWit _x _x_i1 _x_i2 | MtOf _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#module_expr _x_i1 in MtOf _x _x_i1 | MtAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MtAnt _x _x_i1 ]; method module_expr : module_expr -> module_expr = fun [ MeNil _x -> let _x = o#loc _x in MeNil _x | MeId _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in MeId _x _x_i1 | MeApp _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#module_expr _x_i1 in let _x_i2 = o#module_expr _x_i2 in MeApp _x _x_i1 _x_i2 | MeFun _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_type _x_i2 in let _x_i3 = o#module_expr _x_i3 in MeFun _x _x_i1 _x_i2 _x_i3 | MeStr _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#str_item _x_i1 in MeStr _x _x_i1 | MeTyc _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#module_expr _x_i1 in let _x_i2 = o#module_type _x_i2 in MeTyc _x _x_i1 _x_i2 | MePkg _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in MePkg _x _x_i1 | MeAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MeAnt _x _x_i1 ]; method module_binding : module_binding -> module_binding = fun [ MbNil _x -> let _x = o#loc _x in MbNil _x | MbAnd _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#module_binding _x_i1 in let _x_i2 = o#module_binding _x_i2 in MbAnd _x _x_i1 _x_i2 | MbColEq _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_type _x_i2 in let _x_i3 = o#module_expr _x_i3 in MbColEq _x _x_i1 _x_i2 _x_i3 | MbCol _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_type _x_i2 in MbCol _x _x_i1 _x_i2 | MbAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MbAnt _x _x_i1 ]; method meta_option : ! (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Note: when you modify these types you must increment ast magic numbers defined in Camlp4_config.ml. *) 'a 'a_out. ('self_type -> 'a -> 'a_out) -> meta_option 'a -> meta_option 'a_out = fun _f_a -> fun [ ONone -> ONone | OSome _x -> let _x = _f_a o _x in OSome _x | OAnt _x -> let _x = o#string _x in OAnt _x ]; method meta_list : ! 'a 'a_out. ('self_type -> 'a -> 'a_out) -> meta_list 'a -> meta_list 'a_out = fun _f_a -> fun [ LNil -> LNil | LCons _x _x_i1 -> let _x = _f_a o _x in let _x_i1 = o#meta_list _f_a _x_i1 in LCons _x _x_i1 | LAnt _x -> let _x = o#string _x in LAnt _x ]; method meta_bool : meta_bool -> meta_bool = fun [ BTrue -> BTrue | BFalse -> BFalse | BAnt _x -> let _x = o#string _x in BAnt _x ]; method match_case : match_case -> match_case = fun [ McNil _x -> let _x = o#loc _x in McNil _x | McOr _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#match_case _x_i1 in let _x_i2 = o#match_case _x_i2 in McOr _x _x_i1 _x_i2 | McArr _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#expr _x_i2 in let _x_i3 = o#expr _x_i3 in McArr _x _x_i1 _x_i2 _x_i3 | McAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in McAnt _x _x_i1 ]; method loc : loc -> loc = o#unknown; method ident : ident -> ident = fun [ IdAcc _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in let _x_i2 = o#ident _x_i2 in IdAcc _x _x_i1 _x_i2 | IdApp _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in let _x_i2 = o#ident _x_i2 in IdApp _x _x_i1 _x_i2 | IdLid _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in IdLid _x _x_i1 | IdUid _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in IdUid _x _x_i1 | IdAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in IdAnt _x _x_i1 ]; method expr : expr -> expr = fun [ ExNil _x -> let _x = o#loc _x in ExNil _x | ExId _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in ExId _x _x_i1 | ExAcc _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExAcc _x _x_i1 _x_i2 | ExAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExAnt _x _x_i1 | ExApp _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExApp _x _x_i1 _x_i2 | ExAre _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExAre _x _x_i1 _x_i2 | ExArr _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExArr _x _x_i1 | ExSem _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExSem _x _x_i1 _x_i2 | ExAsf _x -> let _x = o#loc _x in ExAsf _x | ExAsr _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExAsr _x _x_i1 | ExAss _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExAss _x _x_i1 _x_i2 | ExChr _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExChr _x _x_i1 | ExCoe _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#ctyp _x_i2 in let _x_i3 = o#ctyp _x_i3 in ExCoe _x _x_i1 _x_i2 _x_i3 | ExFlo _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExFlo _x _x_i1 | ExFor _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#expr _x_i2 in let _x_i3 = o#expr _x_i3 in let _x_i4 = o#direction_flag _x_i4 in let _x_i5 = o#expr _x_i5 in ExFor _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 | ExFun _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#match_case _x_i1 in ExFun _x _x_i1 | ExIfe _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in let _x_i3 = o#expr _x_i3 in ExIfe _x _x_i1 _x_i2 _x_i3 | ExInt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExInt _x _x_i1 | ExInt32 _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExInt32 _x _x_i1 | ExInt64 _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExInt64 _x _x_i1 | ExNativeInt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExNativeInt _x _x_i1 | ExLab _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#expr _x_i2 in ExLab _x _x_i1 _x_i2 | ExLaz _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExLaz _x _x_i1 | ExLet _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#rec_flag _x_i1 in let _x_i2 = o#binding _x_i2 in let _x_i3 = o#expr _x_i3 in ExLet _x _x_i1 _x_i2 _x_i3 | ExLmd _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#module_expr _x_i2 in let _x_i3 = o#expr _x_i3 in ExLmd _x _x_i1 _x_i2 _x_i3 | ExMat _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#match_case _x_i2 in ExMat _x _x_i1 _x_i2 | ExNew _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in ExNew _x _x_i1 | ExObj _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#class_str_item _x_i2 in ExObj _x _x_i1 _x_i2 | ExOlb _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#expr _x_i2 in ExOlb _x _x_i1 _x_i2 | ExOvr _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#rec_binding _x_i1 in ExOvr _x _x_i1 | ExRec _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#rec_binding _x_i1 in let _x_i2 = o#expr _x_i2 in ExRec _x _x_i1 _x_i2 | ExSeq _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExSeq _x _x_i1 | ExSnd _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#string _x_i2 in ExSnd _x _x_i1 _x_i2 | ExSte _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExSte _x _x_i1 _x_i2 | ExStr _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExStr _x _x_i1 | ExTry _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#match_case _x_i2 in ExTry _x _x_i1 _x_i2 | ExTup _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExTup _x _x_i1 | ExCom _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExCom _x _x_i1 _x_i2 | ExTyc _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#ctyp _x_i2 in ExTyc _x _x_i1 _x_i2 | ExVrn _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in ExVrn _x _x_i1 | ExWhi _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in let _x_i2 = o#expr _x_i2 in ExWhi _x _x_i1 _x_i2 | ExOpI _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in let _x_i2 = o#expr _x_i2 in ExOpI _x _x_i1 _x_i2 | ExFUN _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#expr _x_i2 in ExFUN _x _x_i1 _x_i2 | ExPkg _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#module_expr _x_i1 in ExPkg _x _x_i1 ]; method direction_flag : direction_flag -> direction_flag = fun [ DiTo -> DiTo | DiDownto -> DiDownto | DiAnt _x -> let _x = o#string _x in DiAnt _x ]; method ctyp : ctyp -> ctyp = fun [ TyNil _x -> let _x = o#loc _x in TyNil _x | TyAli _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyAli _x _x_i1 _x_i2 | TyAny _x -> let _x = o#loc _x in TyAny _x | TyApp _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyApp _x _x_i1 _x_i2 | TyArr _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyArr _x _x_i1 _x_i2 | TyCls _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in TyCls _x _x_i1 | TyLab _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyLab _x _x_i1 _x_i2 | TyId _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in TyId _x _x_i1 | TyMan _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyMan _x _x_i1 _x_i2 | TyDcl _x _x_i1 _x_i2 _x_i3 _x_i4 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#list (fun o -> o#ctyp) _x_i2 in let _x_i3 = o#ctyp _x_i3 in let _x_i4 = o#list (fun o (_x, _x_i1) -> let _x = o#ctyp _x in let _x_i1 = o#ctyp _x_i1 in (_x, _x_i1)) _x_i4 in TyDcl _x _x_i1 _x_i2 _x_i3 _x_i4 | TyObj _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#row_var_flag _x_i2 in TyObj _x _x_i1 _x_i2 | TyOlb _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyOlb _x _x_i1 _x_i2 | TyPol _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyPol _x _x_i1 _x_i2 | TyTypePol _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyTypePol _x _x_i1 _x_i2 | TyQuo _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyQuo _x _x_i1 | TyQuP _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyQuP _x _x_i1 | TyQuM _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyQuM _x _x_i1 | TyAnP _x -> let _x = o#loc _x in TyAnP _x | TyAnM _x -> let _x = o#loc _x in TyAnM _x | TyVrn _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyVrn _x _x_i1 | TyRec _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyRec _x _x_i1 | TyCol _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyCol _x _x_i1 _x_i2 | TySem _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TySem _x _x_i1 _x_i2 | TyCom _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyCom _x _x_i1 _x_i2 | TySum _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TySum _x _x_i1 | TyOf _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyOf _x _x_i1 _x_i2 | TyAnd _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyAnd _x _x_i1 _x_i2 | TyOr _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyOr _x _x_i1 _x_i2 | TyPrv _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyPrv _x _x_i1 | TyMut _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyMut _x _x_i1 | TyTup _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyTup _x _x_i1 | TySta _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TySta _x _x_i1 _x_i2 | TyVrnEq _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyVrnEq _x _x_i1 | TyVrnSup _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyVrnSup _x _x_i1 | TyVrnInf _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyVrnInf _x _x_i1 | TyVrnInfSup _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyVrnInfSup _x _x_i1 _x_i2 | TyAmp _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyAmp _x _x_i1 _x_i2 | TyOfAmp _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in TyOfAmp _x _x_i1 _x_i2 | TyPkg _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#module_type _x_i1 in TyPkg _x _x_i1 | TyAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyAnt _x _x_i1 ]; method class_type : class_type -> class_type = fun [ CtNil _x -> let _x = o#loc _x in CtNil _x | CtCon _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#virtual_flag _x_i1 in let _x_i2 = o#ident _x_i2 in let _x_i3 = o#ctyp _x_i3 in CtCon _x _x_i1 _x_i2 _x_i3 | CtFun _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#class_type _x_i2 in CtFun _x _x_i1 _x_i2 | CtSig _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#class_sig_item _x_i2 in CtSig _x _x_i1 _x_i2 | CtAnd _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#class_type _x_i1 in let _x_i2 = o#class_type _x_i2 in CtAnd _x _x_i1 _x_i2 | CtCol _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#class_type _x_i1 in let _x_i2 = o#class_type _x_i2 in CtCol _x _x_i1 _x_i2 | CtEq _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#class_type _x_i1 in let _x_i2 = o#class_type _x_i2 in CtEq _x _x_i1 _x_i2 | CtAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CtAnt _x _x_i1 ]; method class_str_item : class_str_item -> class_str_item = fun [ CrNil _x -> let _x = o#loc _x in CrNil _x | CrSem _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#class_str_item _x_i1 in let _x_i2 = o#class_str_item _x_i2 in CrSem _x _x_i1 _x_i2 | CrCtr _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in CrCtr _x _x_i1 _x_i2 | CrInh _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#override_flag _x_i1 in let _x_i2 = o#class_expr _x_i2 in let _x_i3 = o#string _x_i3 in CrInh _x _x_i1 _x_i2 _x_i3 | CrIni _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in CrIni _x _x_i1 | CrMth _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#override_flag _x_i2 in let _x_i3 = o#private_flag _x_i3 in let _x_i4 = o#expr _x_i4 in let _x_i5 = o#ctyp _x_i5 in CrMth _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 | CrVal _x _x_i1 _x_i2 _x_i3 _x_i4 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#override_flag _x_i2 in let _x_i3 = o#mutable_flag _x_i3 in let _x_i4 = o#expr _x_i4 in CrVal _x _x_i1 _x_i2 _x_i3 _x_i4 | CrVir _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#private_flag _x_i2 in let _x_i3 = o#ctyp _x_i3 in CrVir _x _x_i1 _x_i2 _x_i3 | CrVvr _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#mutable_flag _x_i2 in let _x_i3 = o#ctyp _x_i3 in CrVvr _x _x_i1 _x_i2 _x_i3 | CrAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CrAnt _x _x_i1 ]; method class_sig_item : class_sig_item -> class_sig_item = fun [ CgNil _x -> let _x = o#loc _x in CgNil _x | CgCtr _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in let _x_i2 = o#ctyp _x_i2 in CgCtr _x _x_i1 _x_i2 | CgSem _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#class_sig_item _x_i1 in let _x_i2 = o#class_sig_item _x_i2 in CgSem _x _x_i1 _x_i2 | CgInh _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#class_type _x_i1 in CgInh _x _x_i1 | CgMth _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#private_flag _x_i2 in let _x_i3 = o#ctyp _x_i3 in CgMth _x _x_i1 _x_i2 _x_i3 | CgVal _x _x_i1 _x_i2 _x_i3 _x_i4 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#mutable_flag _x_i2 in let _x_i3 = o#virtual_flag _x_i3 in let _x_i4 = o#ctyp _x_i4 in CgVal _x _x_i1 _x_i2 _x_i3 _x_i4 | CgVir _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in let _x_i2 = o#private_flag _x_i2 in let _x_i3 = o#ctyp _x_i3 in CgVir _x _x_i1 _x_i2 _x_i3 | CgAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CgAnt _x _x_i1 ]; method class_expr : class_expr -> class_expr = fun [ CeNil _x -> let _x = o#loc _x in CeNil _x | CeApp _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#class_expr _x_i1 in let _x_i2 = o#expr _x_i2 in CeApp _x _x_i1 _x_i2 | CeCon _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#virtual_flag _x_i1 in let _x_i2 = o#ident _x_i2 in let _x_i3 = o#ctyp _x_i3 in CeCon _x _x_i1 _x_i2 _x_i3 | CeFun _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#class_expr _x_i2 in CeFun _x _x_i1 _x_i2 | CeLet _x _x_i1 _x_i2 _x_i3 -> let _x = o#loc _x in let _x_i1 = o#rec_flag _x_i1 in let _x_i2 = o#binding _x_i2 in let _x_i3 = o#class_expr _x_i3 in CeLet _x _x_i1 _x_i2 _x_i3 | CeStr _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#class_str_item _x_i2 in CeStr _x _x_i1 _x_i2 | CeTyc _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#class_expr _x_i1 in let _x_i2 = o#class_type _x_i2 in CeTyc _x _x_i1 _x_i2 | CeAnd _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#class_expr _x_i1 in let _x_i2 = o#class_expr _x_i2 in CeAnd _x _x_i1 _x_i2 | CeEq _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#class_expr _x_i1 in let _x_i2 = o#class_expr _x_i2 in CeEq _x _x_i1 _x_i2 | CeAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CeAnt _x _x_i1 ]; method binding : binding -> binding = fun [ BiNil _x -> let _x = o#loc _x in BiNil _x | BiAnd _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#binding _x_i1 in let _x_i2 = o#binding _x_i2 in BiAnd _x _x_i1 _x_i2 | BiEq _x _x_i1 _x_i2 -> let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in let _x_i2 = o#expr _x_i2 in BiEq _x _x_i1 _x_i2 | BiAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in BiAnt _x _x_i1 ]; method unknown : ! 'a. 'a -> 'a = fun x -> x; end; class fold = object ((o : 'self_type)) method string : string -> 'self_type = o#unknown; method list : ! 'a. ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type = fun _f_a -> fun [ [] -> o | [ _x :: _x_i1 ] -> let o = _f_a o _x in let o = o#list _f_a _x_i1 in o ]; method with_constr : with_constr -> 'self_type = fun [ WcNil _x -> let o = o#loc _x in o | WcTyp _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | WcMod _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ident _x_i1 in let o = o#ident _x_i2 in o | WcTyS _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | WcMoS _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ident _x_i1 in let o = o#ident _x_i2 in o | WcAnd _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#with_constr _x_i1 in let o = o#with_constr _x_i2 in o | WcAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method virtual_flag : virtual_flag -> 'self_type = fun [ ViVirtual -> o | ViNil -> o | ViAnt _x -> let o = o#string _x in o ]; method str_item : str_item -> 'self_type = fun [ StNil _x -> let o = o#loc _x in o | StCls _x _x_i1 -> let o = o#loc _x in let o = o#class_expr _x_i1 in o | StClt _x _x_i1 -> let o = o#loc _x in let o = o#class_type _x_i1 in o | StSem _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#str_item _x_i1 in let o = o#str_item _x_i2 in o | StDir _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#expr _x_i2 in o | StExc _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#meta_option (fun o -> o#ident) _x_i2 in o | StExp _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o | StExt _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#ctyp _x_i2 in let o = o#meta_list (fun o -> o#string) _x_i3 in o | StInc _x _x_i1 -> let o = o#loc _x in let o = o#module_expr _x_i1 in o | StMod _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_expr _x_i2 in o | StRecMod _x _x_i1 -> let o = o#loc _x in let o = o#module_binding _x_i1 in o | StMty _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_type _x_i2 in o | StOpn _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o | StTyp _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | StVal _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#rec_flag _x_i1 in let o = o#binding _x_i2 in o | StAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method sig_item : sig_item -> 'self_type = fun [ SgNil _x -> let o = o#loc _x in o | SgCls _x _x_i1 -> let o = o#loc _x in let o = o#class_type _x_i1 in o | SgClt _x _x_i1 -> let o = o#loc _x in let o = o#class_type _x_i1 in o | SgSem _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#sig_item _x_i1 in let o = o#sig_item _x_i2 in o | SgDir _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#expr _x_i2 in o | SgExc _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | SgExt _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#ctyp _x_i2 in let o = o#meta_list (fun o -> o#string) _x_i3 in o | SgInc _x _x_i1 -> let o = o#loc _x in let o = o#module_type _x_i1 in o | SgMod _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_type _x_i2 in o | SgRecMod _x _x_i1 -> let o = o#loc _x in let o = o#module_binding _x_i1 in o | SgMty _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_type _x_i2 in o | SgOpn _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o | SgTyp _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | SgVal _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o | SgAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method row_var_flag : row_var_flag -> 'self_type = fun [ RvRowVar -> o | RvNil -> o | RvAnt _x -> let o = o#string _x in o ]; method rec_flag : rec_flag -> 'self_type = fun [ ReRecursive -> o | ReNil -> o | ReAnt _x -> let o = o#string _x in o ]; method rec_binding : rec_binding -> 'self_type = fun [ RbNil _x -> let o = o#loc _x in o | RbSem _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#rec_binding _x_i1 in let o = o#rec_binding _x_i2 in o | RbEq _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ident _x_i1 in let o = o#expr _x_i2 in o | RbAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method private_flag : private_flag -> 'self_type = fun [ PrPrivate -> o | PrNil -> o | PrAnt _x -> let o = o#string _x in o ]; method patt : patt -> 'self_type = fun [ PaNil _x -> let o = o#loc _x in o | PaId _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o | PaAli _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#patt _x_i2 in o | PaAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | PaAny _x -> let o = o#loc _x in o | PaApp _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#patt _x_i2 in o | PaArr _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o | PaCom _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#patt _x_i2 in o | PaSem _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#patt _x_i2 in o | PaChr _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | PaInt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | PaInt32 _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | PaInt64 _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | PaNativeInt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | PaFlo _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | PaLab _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#patt _x_i2 in o | PaOlb _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#patt _x_i2 in o | PaOlbi _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#patt _x_i2 in let o = o#expr _x_i3 in o | PaOrp _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#patt _x_i2 in o | PaRng _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#patt _x_i2 in o | PaRec _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o | PaEq _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ident _x_i1 in let o = o#patt _x_i2 in o | PaStr _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | PaTup _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o | PaTyc _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#ctyp _x_i2 in o | PaTyp _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o | PaVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | PaLaz _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o | PaMod _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method override_flag : override_flag -> 'self_type = fun [ OvOverride -> o | OvNil -> o | OvAnt _x -> let o = o#string _x in o ]; method mutable_flag : mutable_flag -> 'self_type = fun [ MuMutable -> o | MuNil -> o | MuAnt _x -> let o = o#string _x in o ]; method module_type : module_type -> 'self_type = fun [ MtNil _x -> let o = o#loc _x in o | MtId _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o | MtFun _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_type _x_i2 in let o = o#module_type _x_i3 in o | MtQuo _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | MtSig _x _x_i1 -> let o = o#loc _x in let o = o#sig_item _x_i1 in o | MtWit _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#module_type _x_i1 in let o = o#with_constr _x_i2 in o | MtOf _x _x_i1 -> let o = o#loc _x in let o = o#module_expr _x_i1 in o | MtAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method module_expr : module_expr -> 'self_type = fun [ MeNil _x -> let o = o#loc _x in o | MeId _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o | MeApp _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#module_expr _x_i1 in let o = o#module_expr _x_i2 in o | MeFun _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_type _x_i2 in let o = o#module_expr _x_i3 in o | MeStr _x _x_i1 -> let o = o#loc _x in let o = o#str_item _x_i1 in o | MeTyc _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#module_expr _x_i1 in let o = o#module_type _x_i2 in o | MePkg _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o | MeAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method module_binding : module_binding -> 'self_type = fun [ MbNil _x -> let o = o#loc _x in o | MbAnd _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#module_binding _x_i1 in let o = o#module_binding _x_i2 in o | MbColEq _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_type _x_i2 in let o = o#module_expr _x_i3 in o | MbCol _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_type _x_i2 in o | MbAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method meta_option : ! 'a. ('self_type -> 'a -> 'self_type) -> meta_option 'a -> 'self_type = fun _f_a -> fun [ ONone -> o | OSome _x -> let o = _f_a o _x in o | OAnt _x -> let o = o#string _x in o ]; method meta_list : ! 'a. ('self_type -> 'a -> 'self_type) -> meta_list 'a -> 'self_type = fun _f_a -> fun [ LNil -> o | LCons _x _x_i1 -> let o = _f_a o _x in let o = o#meta_list _f_a _x_i1 in o | LAnt _x -> let o = o#string _x in o ]; method meta_bool : meta_bool -> 'self_type = fun [ BTrue -> o | BFalse -> o | BAnt _x -> let o = o#string _x in o ]; method match_case : match_case -> 'self_type = fun [ McNil _x -> let o = o#loc _x in o | McOr _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#match_case _x_i1 in let o = o#match_case _x_i2 in o | McArr _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#expr _x_i2 in let o = o#expr _x_i3 in o | McAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method loc : loc -> 'self_type = o#unknown; method ident : ident -> 'self_type = fun [ IdAcc _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ident _x_i1 in let o = o#ident _x_i2 in o | IdApp _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ident _x_i1 in let o = o#ident _x_i2 in o | IdLid _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | IdUid _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | IdAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method expr : expr -> 'self_type = fun [ ExNil _x -> let o = o#loc _x in o | ExId _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o | ExAcc _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | ExApp _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExAre _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExArr _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o | ExSem _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExAsf _x -> let o = o#loc _x in o | ExAsr _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o | ExAss _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExChr _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | ExCoe _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#ctyp _x_i2 in let o = o#ctyp _x_i3 in o | ExFlo _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | ExFor _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#expr _x_i2 in let o = o#expr _x_i3 in let o = o#direction_flag _x_i4 in let o = o#expr _x_i5 in o | ExFun _x _x_i1 -> let o = o#loc _x in let o = o#match_case _x_i1 in o | ExIfe _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in let o = o#expr _x_i3 in o | ExInt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | ExInt32 _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | ExInt64 _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | ExNativeInt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | ExLab _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#expr _x_i2 in o | ExLaz _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o | ExLet _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#rec_flag _x_i1 in let o = o#binding _x_i2 in let o = o#expr _x_i3 in o | ExLmd _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#module_expr _x_i2 in let o = o#expr _x_i3 in o | ExMat _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#match_case _x_i2 in o | ExNew _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o | ExObj _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#class_str_item _x_i2 in o | ExOlb _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#expr _x_i2 in o | ExOvr _x _x_i1 -> let o = o#loc _x in let o = o#rec_binding _x_i1 in o | ExRec _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#rec_binding _x_i1 in let o = o#expr _x_i2 in o | ExSeq _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o | ExSnd _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#string _x_i2 in o | ExSte _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExStr _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | ExTry _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#match_case _x_i2 in o | ExTup _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o | ExCom _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExTyc _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#ctyp _x_i2 in o | ExVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | ExWhi _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#expr _x_i1 in let o = o#expr _x_i2 in o | ExOpI _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ident _x_i1 in let o = o#expr _x_i2 in o | ExFUN _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#expr _x_i2 in o | ExPkg _x _x_i1 -> let o = o#loc _x in let o = o#module_expr _x_i1 in o ]; method direction_flag : direction_flag -> 'self_type = fun [ DiTo -> o | DiDownto -> o | DiAnt _x -> let o = o#string _x in o ]; method ctyp : ctyp -> 'self_type = fun [ TyNil _x -> let o = o#loc _x in o | TyAli _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyAny _x -> let o = o#loc _x in o | TyApp _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyArr _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyCls _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o | TyLab _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o | TyId _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o | TyMan _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyDcl _x _x_i1 _x_i2 _x_i3 _x_i4 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#list (fun o -> o#ctyp) _x_i2 in let o = o#ctyp _x_i3 in let o = o#list (fun o (_x, _x_i1) -> let o = o#ctyp _x in let o = o#ctyp _x_i1 in o) _x_i4 in o | TyObj _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#row_var_flag _x_i2 in o | TyOlb _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o | TyPol _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyTypePol _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyQuo _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | TyQuP _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | TyQuM _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | TyAnP _x -> let o = o#loc _x in o | TyAnM _x -> let o = o#loc _x in o | TyVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o | TyRec _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TyCol _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TySem _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyCom _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TySum _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TyOf _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyAnd _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyOr _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyPrv _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TyMut _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TyTup _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TySta _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyVrnEq _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TyVrnSup _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TyVrnInf _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o | TyVrnInfSup _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyAmp _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyOfAmp _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | TyPkg _x _x_i1 -> let o = o#loc _x in let o = o#module_type _x_i1 in o | TyAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method class_type : class_type -> 'self_type = fun [ CtNil _x -> let o = o#loc _x in o | CtCon _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#virtual_flag _x_i1 in let o = o#ident _x_i2 in let o = o#ctyp _x_i3 in o | CtFun _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#class_type _x_i2 in o | CtSig _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#class_sig_item _x_i2 in o | CtAnd _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#class_type _x_i1 in let o = o#class_type _x_i2 in o | CtCol _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#class_type _x_i1 in let o = o#class_type _x_i2 in o | CtEq _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#class_type _x_i1 in let o = o#class_type _x_i2 in o | CtAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method class_str_item : class_str_item -> 'self_type = fun [ CrNil _x -> let o = o#loc _x in o | CrSem _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#class_str_item _x_i1 in let o = o#class_str_item _x_i2 in o | CrCtr _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | CrInh _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#override_flag _x_i1 in let o = o#class_expr _x_i2 in let o = o#string _x_i3 in o | CrIni _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o | CrMth _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#override_flag _x_i2 in let o = o#private_flag _x_i3 in let o = o#expr _x_i4 in let o = o#ctyp _x_i5 in o | CrVal _x _x_i1 _x_i2 _x_i3 _x_i4 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#override_flag _x_i2 in let o = o#mutable_flag _x_i3 in let o = o#expr _x_i4 in o | CrVir _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#private_flag _x_i2 in let o = o#ctyp _x_i3 in o | CrVvr _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#mutable_flag _x_i2 in let o = o#ctyp _x_i3 in o | CrAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method class_sig_item : class_sig_item -> 'self_type = fun [ CgNil _x -> let o = o#loc _x in o | CgCtr _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o | CgSem _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#class_sig_item _x_i1 in let o = o#class_sig_item _x_i2 in o | CgInh _x _x_i1 -> let o = o#loc _x in let o = o#class_type _x_i1 in o | CgMth _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#private_flag _x_i2 in let o = o#ctyp _x_i3 in o | CgVal _x _x_i1 _x_i2 _x_i3 _x_i4 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#mutable_flag _x_i2 in let o = o#virtual_flag _x_i3 in let o = o#ctyp _x_i4 in o | CgVir _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#string _x_i1 in let o = o#private_flag _x_i2 in let o = o#ctyp _x_i3 in o | CgAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method class_expr : class_expr -> 'self_type = fun [ CeNil _x -> let o = o#loc _x in o | CeApp _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#class_expr _x_i1 in let o = o#expr _x_i2 in o | CeCon _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#virtual_flag _x_i1 in let o = o#ident _x_i2 in let o = o#ctyp _x_i3 in o | CeFun _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#class_expr _x_i2 in o | CeLet _x _x_i1 _x_i2 _x_i3 -> let o = o#loc _x in let o = o#rec_flag _x_i1 in let o = o#binding _x_i2 in let o = o#class_expr _x_i3 in o | CeStr _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#class_str_item _x_i2 in o | CeTyc _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#class_expr _x_i1 in let o = o#class_type _x_i2 in o | CeAnd _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#class_expr _x_i1 in let o = o#class_expr _x_i2 in o | CeEq _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#class_expr _x_i1 in let o = o#class_expr _x_i2 in o | CeAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method binding : binding -> 'self_type = fun [ BiNil _x -> let o = o#loc _x in o | BiAnd _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#binding _x_i1 in let o = o#binding _x_i2 in o | BiEq _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#patt _x_i1 in let o = o#expr _x_i2 in o | BiAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method unknown : ! 'a. 'a -> 'self_type = fun _ -> o; end; value map_expr f = object inherit map as super; method expr = fun x -> f (super#expr x); end; value map_patt f = object inherit map as super; method patt = fun x -> f (super#patt x); end; value map_ctyp f = object inherit map as super; method ctyp = fun x -> f (super#ctyp x); end; value map_str_item f = object inherit map as super; method str_item = fun x -> f (super#str_item x); end; value map_sig_item f = object inherit map as super; method sig_item = fun x -> f (super#sig_item x); end; value map_loc f = object inherit map as super; method loc = fun x -> f (super#loc x); end; end; mingw-ocaml/ocaml/camlp4/boot/camlp4boot.ml40000644000175000017500000000144112124403240020262 0ustar tootstootsmodule R = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml"; end; module Camlp4QuotationCommon = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml"; end; module Q = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml"; end; module Rp = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml"; end; module G = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4GrammarParser.ml"; end; module M = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4MacroParser.ml"; end; module D = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4DebugParser.ml"; end; module L = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4ListComprehension.ml"; end; module P = struct INCLUDE "camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml"; end; module B = struct INCLUDE "camlp4/Camlp4Bin.ml"; end; mingw-ocaml/ocaml/camlp4/boot/camlp4boot.ml0000644000175000017500000303364712124403240020216 0ustar tootstootsmodule R = struct open Camlp4 (* -*- camlp4r -*- *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) module Id = struct let name = "Camlp4OCamlRevisedParser" let version = Sys.ocaml_version end module Make (Syntax : Sig.Camlp4Syntax) = struct open Sig include Syntax (* Camlp4_config.constructors_arity.val := True; *) let _ = Camlp4_config.constructors_arity := false let help_sequences () = (Printf.eprintf "\ New syntax:\ \n (e1; e2; ... ; en) OR begin e1; e2; ... ; en end\ \n while e do e1; e2; ... ; en done\ \n for v = v1 to/downto v2 do e1; e2; ... ; en done\ \nOld syntax (still supported):\ \n do {e1; e2; ... ; en}\ \n while e do {e1; e2; ... ; en}\ \n for v = v1 to/downto v2 do {e1; e2; ... ; en}\ \nVery old (no more supported) syntax:\ \n do e1; e2; ... ; en-1; return en\ \n while e do e1; e2; ... ; en; done\ \n for v = v1 to/downto v2 do e1; e2; ... ; en; done\ \n"; flush stderr; exit 1) let _ = Options.add "-help_seq" (Arg.Unit help_sequences) "Print explanations about new sequences and exit." let _ = Gram.Entry.clear a_CHAR let _ = Gram.Entry.clear a_FLOAT let _ = Gram.Entry.clear a_INT let _ = Gram.Entry.clear a_INT32 let _ = Gram.Entry.clear a_INT64 let _ = Gram.Entry.clear a_LABEL let _ = Gram.Entry.clear a_LIDENT let _ = Gram.Entry.clear a_NATIVEINT let _ = Gram.Entry.clear a_OPTLABEL let _ = Gram.Entry.clear a_STRING let _ = Gram.Entry.clear a_UIDENT let _ = Gram.Entry.clear a_ident let _ = Gram.Entry.clear amp_ctyp let _ = Gram.Entry.clear and_ctyp let _ = Gram.Entry.clear match_case let _ = Gram.Entry.clear match_case0 let _ = Gram.Entry.clear match_case_quot let _ = Gram.Entry.clear binding let _ = Gram.Entry.clear binding_quot let _ = Gram.Entry.clear rec_binding_quot let _ = Gram.Entry.clear class_declaration let _ = Gram.Entry.clear class_description let _ = Gram.Entry.clear class_expr let _ = Gram.Entry.clear class_expr_quot let _ = Gram.Entry.clear class_fun_binding let _ = Gram.Entry.clear class_fun_def let _ = Gram.Entry.clear class_info_for_class_expr let _ = Gram.Entry.clear class_info_for_class_type let _ = Gram.Entry.clear class_longident let _ = Gram.Entry.clear class_longident_and_param let _ = Gram.Entry.clear class_name_and_param let _ = Gram.Entry.clear class_sig_item let _ = Gram.Entry.clear class_sig_item_quot let _ = Gram.Entry.clear class_signature let _ = Gram.Entry.clear class_str_item let _ = Gram.Entry.clear class_str_item_quot let _ = Gram.Entry.clear class_structure let _ = Gram.Entry.clear class_type let _ = Gram.Entry.clear class_type_declaration let _ = Gram.Entry.clear class_type_longident let _ = Gram.Entry.clear class_type_longident_and_param let _ = Gram.Entry.clear class_type_plus let _ = Gram.Entry.clear class_type_quot let _ = Gram.Entry.clear comma_ctyp let _ = Gram.Entry.clear comma_expr let _ = Gram.Entry.clear comma_ipatt let _ = Gram.Entry.clear comma_patt let _ = Gram.Entry.clear comma_type_parameter let _ = Gram.Entry.clear constrain let _ = Gram.Entry.clear constructor_arg_list let _ = Gram.Entry.clear constructor_declaration let _ = Gram.Entry.clear constructor_declarations let _ = Gram.Entry.clear ctyp let _ = Gram.Entry.clear ctyp_quot let _ = Gram.Entry.clear cvalue_binding let _ = Gram.Entry.clear direction_flag let _ = Gram.Entry.clear dummy let _ = Gram.Entry.clear eq_expr let _ = Gram.Entry.clear expr let _ = Gram.Entry.clear expr_eoi let _ = Gram.Entry.clear expr_quot let _ = Gram.Entry.clear field_expr let _ = Gram.Entry.clear field_expr_list let _ = Gram.Entry.clear fun_binding let _ = Gram.Entry.clear fun_def let _ = Gram.Entry.clear ident let _ = Gram.Entry.clear ident_quot let _ = Gram.Entry.clear implem let _ = Gram.Entry.clear interf let _ = Gram.Entry.clear ipatt let _ = Gram.Entry.clear ipatt_tcon let _ = Gram.Entry.clear label let _ = Gram.Entry.clear label_declaration let _ = Gram.Entry.clear label_declaration_list let _ = Gram.Entry.clear label_expr_list let _ = Gram.Entry.clear label_expr let _ = Gram.Entry.clear label_ipatt let _ = Gram.Entry.clear label_ipatt_list let _ = Gram.Entry.clear label_longident let _ = Gram.Entry.clear label_patt let _ = Gram.Entry.clear label_patt_list let _ = Gram.Entry.clear labeled_ipatt let _ = Gram.Entry.clear let_binding let _ = Gram.Entry.clear meth_list let _ = Gram.Entry.clear meth_decl let _ = Gram.Entry.clear module_binding let _ = Gram.Entry.clear module_binding0 let _ = Gram.Entry.clear module_binding_quot let _ = Gram.Entry.clear module_declaration let _ = Gram.Entry.clear module_expr let _ = Gram.Entry.clear module_expr_quot let _ = Gram.Entry.clear module_longident let _ = Gram.Entry.clear module_longident_with_app let _ = Gram.Entry.clear module_rec_declaration let _ = Gram.Entry.clear module_type let _ = Gram.Entry.clear module_type_quot let _ = Gram.Entry.clear more_ctyp let _ = Gram.Entry.clear name_tags let _ = Gram.Entry.clear opt_as_lident let _ = Gram.Entry.clear opt_class_self_patt let _ = Gram.Entry.clear opt_class_self_type let _ = Gram.Entry.clear opt_comma_ctyp let _ = Gram.Entry.clear opt_dot_dot let _ = Gram.Entry.clear opt_eq_ctyp let _ = Gram.Entry.clear opt_expr let _ = Gram.Entry.clear opt_meth_list let _ = Gram.Entry.clear opt_mutable let _ = Gram.Entry.clear opt_polyt let _ = Gram.Entry.clear opt_private let _ = Gram.Entry.clear opt_rec let _ = Gram.Entry.clear opt_virtual let _ = Gram.Entry.clear opt_when_expr let _ = Gram.Entry.clear patt let _ = Gram.Entry.clear patt_as_patt_opt let _ = Gram.Entry.clear patt_eoi let _ = Gram.Entry.clear patt_quot let _ = Gram.Entry.clear patt_tcon let _ = Gram.Entry.clear phrase let _ = Gram.Entry.clear poly_type let _ = Gram.Entry.clear row_field let _ = Gram.Entry.clear sem_expr let _ = Gram.Entry.clear sem_expr_for_list let _ = Gram.Entry.clear sem_patt let _ = Gram.Entry.clear sem_patt_for_list let _ = Gram.Entry.clear semi let _ = Gram.Entry.clear sequence let _ = Gram.Entry.clear sig_item let _ = Gram.Entry.clear sig_item_quot let _ = Gram.Entry.clear sig_items let _ = Gram.Entry.clear star_ctyp let _ = Gram.Entry.clear str_item let _ = Gram.Entry.clear str_item_quot let _ = Gram.Entry.clear str_items let _ = Gram.Entry.clear top_phrase let _ = Gram.Entry.clear type_constraint let _ = Gram.Entry.clear type_declaration let _ = Gram.Entry.clear type_ident_and_parameters let _ = Gram.Entry.clear type_kind let _ = Gram.Entry.clear type_longident let _ = Gram.Entry.clear type_longident_and_parameters let _ = Gram.Entry.clear type_parameter let _ = Gram.Entry.clear type_parameters let _ = Gram.Entry.clear typevars let _ = Gram.Entry.clear use_file let _ = Gram.Entry.clear val_longident let _ = Gram.Entry.clear value_let let _ = Gram.Entry.clear value_val let _ = Gram.Entry.clear with_constr let _ = Gram.Entry.clear with_constr_quot let neg_string n = let len = String.length n in if (len > 0) && (n.[0] = '-') then String.sub n 1 (len - 1) else "-" ^ n let mkumin _loc f arg = match arg with | Ast.ExInt (_, n) -> Ast.ExInt (_loc, (neg_string n)) | Ast.ExInt32 (_, n) -> Ast.ExInt32 (_loc, (neg_string n)) | Ast.ExInt64 (_, n) -> Ast.ExInt64 (_loc, (neg_string n)) | Ast.ExNativeInt (_, n) -> Ast.ExNativeInt (_loc, (neg_string n)) | Ast.ExFlo (_, n) -> Ast.ExFlo (_loc, (neg_string n)) | _ -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, ("~" ^ f))))), arg) let mklistexp _loc last = let rec loop top = function | [] -> (match last with | Some e -> e | None -> Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) | e1 :: el -> let _loc = if top then _loc else Loc.merge (Ast.loc_of_expr e1) _loc in Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), e1)), (loop false el)) in loop true let mkassert _loc = function | Ast.ExId (_, (Ast.IdUid (_, "False"))) -> Ast.ExAsf _loc | (* this case takes care about the special assert false node *) e -> Ast.ExAsr (_loc, e) let append_eLem el e = el @ [ e ] let mk_anti ?(c = "") n s = "\\$" ^ (n ^ (c ^ (":" ^ s))) let mksequence _loc = function | (Ast.ExSem (_, _, _) | Ast.ExAnt (_, _) as e) -> Ast.ExSeq (_loc, e) | e -> e let mksequence' _loc = function | (Ast.ExSem (_, _, _) as e) -> Ast.ExSeq (_loc, e) | e -> e let rec lid_of_ident = function | Ast.IdAcc (_, _, i) -> lid_of_ident i | Ast.IdLid (_, lid) -> lid | _ -> assert false let module_type_app mt1 mt2 = match (mt1, mt2) with | (Ast.MtId (_loc, i1), Ast.MtId (_, i2)) -> Ast.MtId (_loc, (Ast.IdApp (_loc, i1, i2))) | _ -> raise Stream.Failure let module_type_acc mt1 mt2 = match (mt1, mt2) with | (Ast.MtId (_loc, i1), Ast.MtId (_, i2)) -> Ast.MtId (_loc, (Ast.IdAcc (_loc, i1, i2))) | _ -> raise Stream.Failure let bigarray_get _loc arr arg = let coords = match arg with | Ast.ExTup (_, (Ast.ExCom (_, e1, e2))) | Ast.ExCom (_, e1, e2) -> Ast.list_of_expr e1 (Ast.list_of_expr e2 []) | _ -> [ arg ] in match coords with | [ c1 ] -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Array1")), (Ast.IdLid (_loc, "get")))))))), arr)), c1) | [ c1; c2 ] -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Array2")), (Ast.IdLid (_loc, "get")))))))), arr)), c1)), c2) | [ c1; c2; c3 ] -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Array3")), (Ast.IdLid (_loc, "get")))))))), arr)), c1)), c2)), c3) | (* | coords -> <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ] *) coords -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Genarray")), (Ast.IdLid (_loc, "get")))))))), arr)), (Ast.ExArr (_loc, (Ast.exSem_of_list coords)))) let bigarray_set _loc var newval = match var with | Ast.ExApp (_, (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), (Ast.IdAcc (_, (Ast.IdUid (_, "Array1")), (Ast.IdLid (_, "get")))))))), arr)), c1) -> Some (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Array1")), (Ast.IdLid (_loc, "set")))))))), arr)), c1)), newval)) | Ast.ExApp (_, (Ast.ExApp (_, (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), (Ast.IdAcc (_, (Ast.IdUid (_, "Array2")), (Ast.IdLid (_, "get")))))))), arr)), c1)), c2) -> Some (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Array2")), (Ast.IdLid (_loc, "set")))))))), arr)), c1)), c2)), newval)) | Ast.ExApp (_, (Ast.ExApp (_, (Ast.ExApp (_, (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), (Ast.IdAcc (_, (Ast.IdUid (_, "Array3")), (Ast.IdLid (_, "get")))))))), arr)), c1)), c2)), c3) -> Some (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Array3")), (Ast.IdLid (_loc, "set")))))))), arr)), c1)), c2)), c3)), newval)) | Ast.ExApp (_, (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), (Ast.IdAcc (_, (Ast.IdUid (_, "Genarray")), (Ast.IdLid (_, "get")))))))), arr)), (Ast.ExArr (_, coords))) -> Some (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Genarray")), (Ast.IdLid (_loc, "set")))))))), arr)), (Ast.ExArr (_loc, coords)))), newval)) | _ -> None let stopped_at _loc = Some (Loc.move_line 1 _loc) (* FIXME be more precise *) let rec generalized_type_of_type = function | Ast.TyArr (_, t1, t2) -> let (tl, rt) = generalized_type_of_type t2 in ((t1 :: tl), rt) | t -> ([], t) let symbolchar = let list = [ '$'; '!'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?'; '@'; '^'; '|'; '~'; '\\' ] in let rec loop s i = if i == (String.length s) then true else if List.mem s.[i] list then loop s (i + 1) else false in loop let setup_op_parser entry p = Gram.Entry.setup_parser entry (fun (__strm : _ Stream.t) -> match Stream.peek __strm with | Some (((KEYWORD x | SYMBOL x), ti)) when p x -> (Stream.junk __strm; let _loc = Gram.token_location ti in Ast.ExId (_loc, (Ast.IdLid (_loc, x)))) | _ -> raise Stream.Failure) let _ = let list = [ '!'; '?'; '~' ] in let excl = [ "!="; "??" ] in setup_op_parser prefixop (fun x -> (not (List.mem x excl)) && (((String.length x) >= 2) && ((List.mem x.[0] list) && (symbolchar x 1)))) let _ = let list_ok = [ "<"; ">"; "<="; ">="; "="; "<>"; "=="; "!="; "$" ] in let list_first_char_ok = [ '='; '<'; '>'; '|'; '&'; '$'; '!' ] in let excl = [ "<-"; "||"; "&&" ] in setup_op_parser infixop0 (fun x -> (List.mem x list_ok) || ((not (List.mem x excl)) && (((String.length x) >= 2) && ((List.mem x.[0] list_first_char_ok) && (symbolchar x 1))))) let _ = let list = [ '@'; '^' ] in setup_op_parser infixop1 (fun x -> ((String.length x) >= 1) && ((List.mem x.[0] list) && (symbolchar x 1))) let _ = let list = [ '+'; '-' ] in setup_op_parser infixop2 (fun x -> (x <> "->") && (((String.length x) >= 1) && ((List.mem x.[0] list) && (symbolchar x 1)))) let _ = let list = [ '*'; '/'; '%'; '\\' ] in setup_op_parser infixop3 (fun x -> ((String.length x) >= 1) && ((List.mem x.[0] list) && (((x.[0] <> '*') || (((String.length x) < 2) || (x.[1] <> '*'))) && (symbolchar x 1)))) let _ = setup_op_parser infixop4 (fun x -> ((String.length x) >= 2) && ((x.[0] == '*') && ((x.[1] == '*') && (symbolchar x 2)))) let rec infix_kwds_filter (__strm : _ Stream.t) = match Stream.peek __strm with | Some (((KEYWORD "(", _) as tok)) -> (Stream.junk __strm; let xs = __strm in let (__strm : _ Stream.t) = xs in (match Stream.peek __strm with | Some ((KEYWORD (("or" | "mod" | "land" | "lor" | "lxor" | "lsl" | "lsr" | "asr" as i)), _loc)) -> (Stream.junk __strm; (match Stream.peek __strm with | Some ((KEYWORD ")", _)) -> (Stream.junk __strm; let xs = __strm in Stream.lcons (fun _ -> ((LIDENT i), _loc)) (Stream.slazy (fun _ -> infix_kwds_filter xs))) | _ -> raise (Stream.Error ""))) | _ -> let xs = __strm in Stream.icons tok (Stream.slazy (fun _ -> infix_kwds_filter xs)))) | Some x -> (Stream.junk __strm; let xs = __strm in Stream.icons x (Stream.slazy (fun _ -> infix_kwds_filter xs))) | _ -> raise Stream.Failure let _ = Token.Filter.define_filter (Gram.get_filter ()) (fun f strm -> infix_kwds_filter (f strm)) let _ = Gram.Entry.setup_parser sem_expr (let symb1 = Gram.parse_tokens_after_filter expr in let symb (__strm : _ Stream.t) = match Stream.peek __strm with | Some ((ANTIQUOT ((("list" as n)), s), ti)) -> (Stream.junk __strm; let _loc = Gram.token_location ti in Ast.ExAnt (_loc, (mk_anti ~c: "expr;" n s))) | _ -> symb1 __strm in let rec kont al (__strm : _ Stream.t) = match Stream.peek __strm with | Some ((KEYWORD ";", _)) -> (Stream.junk __strm; let a = (try symb __strm with | Stream.Failure -> raise (Stream.Error "")) in let s = __strm in let _loc = Loc.merge (Ast.loc_of_expr al) (Ast.loc_of_expr a) in kont (Ast.ExSem (_loc, al, a)) s) | _ -> al in fun (__strm : _ Stream.t) -> let a = symb __strm in kont a __strm) let _ = let _ = (a_CHAR : 'a_CHAR Gram.Entry.t) and _ = (override_flag_quot : 'override_flag_quot Gram.Entry.t) and _ = (row_var_flag_quot : 'row_var_flag_quot Gram.Entry.t) and _ = (virtual_flag_quot : 'virtual_flag_quot Gram.Entry.t) and _ = (private_flag_quot : 'private_flag_quot Gram.Entry.t) and _ = (mutable_flag_quot : 'mutable_flag_quot Gram.Entry.t) and _ = (direction_flag_quot : 'direction_flag_quot Gram.Entry.t) and _ = (rec_flag_quot : 'rec_flag_quot Gram.Entry.t) and _ = (package_type : 'package_type Gram.Entry.t) and _ = (do_sequence : 'do_sequence Gram.Entry.t) and _ = (infixop4 : 'infixop4 Gram.Entry.t) and _ = (infixop3 : 'infixop3 Gram.Entry.t) and _ = (infixop2 : 'infixop2 Gram.Entry.t) and _ = (infixop1 : 'infixop1 Gram.Entry.t) and _ = (infixop0 : 'infixop0 Gram.Entry.t) and _ = (with_constr_quot : 'with_constr_quot Gram.Entry.t) and _ = (with_constr : 'with_constr Gram.Entry.t) and _ = (value_val : 'value_val Gram.Entry.t) and _ = (value_let : 'value_let Gram.Entry.t) and _ = (val_longident : 'val_longident Gram.Entry.t) and _ = (use_file : 'use_file Gram.Entry.t) and _ = (typevars : 'typevars Gram.Entry.t) and _ = (type_parameters : 'type_parameters Gram.Entry.t) and _ = (type_parameter : 'type_parameter Gram.Entry.t) and _ = (type_longident_and_parameters : 'type_longident_and_parameters Gram.Entry.t) and _ = (type_longident : 'type_longident Gram.Entry.t) and _ = (type_kind : 'type_kind Gram.Entry.t) and _ = (type_ident_and_parameters : 'type_ident_and_parameters Gram.Entry.t) and _ = (type_declaration : 'type_declaration Gram.Entry.t) and _ = (type_constraint : 'type_constraint Gram.Entry.t) and _ = (top_phrase : 'top_phrase Gram.Entry.t) and _ = (str_items : 'str_items Gram.Entry.t) and _ = (str_item_quot : 'str_item_quot Gram.Entry.t) and _ = (str_item : 'str_item Gram.Entry.t) and _ = (star_ctyp : 'star_ctyp Gram.Entry.t) and _ = (sig_items : 'sig_items Gram.Entry.t) and _ = (sig_item_quot : 'sig_item_quot Gram.Entry.t) and _ = (sig_item : 'sig_item Gram.Entry.t) and _ = (sequence : 'sequence Gram.Entry.t) and _ = (semi : 'semi Gram.Entry.t) and _ = (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t) and _ = (sem_patt : 'sem_patt Gram.Entry.t) and _ = (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t) and _ = (sem_expr : 'sem_expr Gram.Entry.t) and _ = (row_field : 'row_field Gram.Entry.t) and _ = (poly_type : 'poly_type Gram.Entry.t) and _ = (phrase : 'phrase Gram.Entry.t) and _ = (patt_tcon : 'patt_tcon Gram.Entry.t) and _ = (patt_quot : 'patt_quot Gram.Entry.t) and _ = (patt_eoi : 'patt_eoi Gram.Entry.t) and _ = (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t) and _ = (patt : 'patt Gram.Entry.t) and _ = (opt_when_expr : 'opt_when_expr Gram.Entry.t) and _ = (opt_virtual : 'opt_virtual Gram.Entry.t) and _ = (opt_rec : 'opt_rec Gram.Entry.t) and _ = (opt_private : 'opt_private Gram.Entry.t) and _ = (opt_polyt : 'opt_polyt Gram.Entry.t) and _ = (opt_mutable : 'opt_mutable Gram.Entry.t) and _ = (opt_meth_list : 'opt_meth_list Gram.Entry.t) and _ = (opt_expr : 'opt_expr Gram.Entry.t) and _ = (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t) and _ = (opt_dot_dot : 'opt_dot_dot Gram.Entry.t) and _ = (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t) and _ = (opt_class_self_type : 'opt_class_self_type Gram.Entry.t) and _ = (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t) and _ = (opt_as_lident : 'opt_as_lident Gram.Entry.t) and _ = (name_tags : 'name_tags Gram.Entry.t) and _ = (more_ctyp : 'more_ctyp Gram.Entry.t) and _ = (module_type_quot : 'module_type_quot Gram.Entry.t) and _ = (module_type : 'module_type Gram.Entry.t) and _ = (module_rec_declaration : 'module_rec_declaration Gram.Entry.t) and _ = (module_longident_with_app : 'module_longident_with_app Gram.Entry.t) and _ = (module_longident : 'module_longident Gram.Entry.t) and _ = (module_expr_quot : 'module_expr_quot Gram.Entry.t) and _ = (module_expr : 'module_expr Gram.Entry.t) and _ = (module_declaration : 'module_declaration Gram.Entry.t) and _ = (module_binding_quot : 'module_binding_quot Gram.Entry.t) and _ = (module_binding0 : 'module_binding0 Gram.Entry.t) and _ = (module_binding : 'module_binding Gram.Entry.t) and _ = (meth_decl : 'meth_decl Gram.Entry.t) and _ = (meth_list : 'meth_list Gram.Entry.t) and _ = (let_binding : 'let_binding Gram.Entry.t) and _ = (labeled_ipatt : 'labeled_ipatt Gram.Entry.t) and _ = (label_patt_list : 'label_patt_list Gram.Entry.t) and _ = (label_patt : 'label_patt Gram.Entry.t) and _ = (label_longident : 'label_longident Gram.Entry.t) and _ = (label_ipatt_list : 'label_ipatt_list Gram.Entry.t) and _ = (label_ipatt : 'label_ipatt Gram.Entry.t) and _ = (label_expr_list : 'label_expr_list Gram.Entry.t) and _ = (label_expr : 'label_expr Gram.Entry.t) and _ = (label_declaration_list : 'label_declaration_list Gram.Entry.t) and _ = (label_declaration : 'label_declaration Gram.Entry.t) and _ = (label : 'label Gram.Entry.t) and _ = (ipatt_tcon : 'ipatt_tcon Gram.Entry.t) and _ = (ipatt : 'ipatt Gram.Entry.t) and _ = (interf : 'interf Gram.Entry.t) and _ = (implem : 'implem Gram.Entry.t) and _ = (ident_quot : 'ident_quot Gram.Entry.t) and _ = (ident : 'ident Gram.Entry.t) and _ = (fun_def : 'fun_def Gram.Entry.t) and _ = (fun_binding : 'fun_binding Gram.Entry.t) and _ = (field_expr_list : 'field_expr_list Gram.Entry.t) and _ = (field_expr : 'field_expr Gram.Entry.t) and _ = (expr_quot : 'expr_quot Gram.Entry.t) and _ = (expr_eoi : 'expr_eoi Gram.Entry.t) and _ = (expr : 'expr Gram.Entry.t) and _ = (eq_expr : 'eq_expr Gram.Entry.t) and _ = (dummy : 'dummy Gram.Entry.t) and _ = (direction_flag : 'direction_flag Gram.Entry.t) and _ = (cvalue_binding : 'cvalue_binding Gram.Entry.t) and _ = (ctyp_quot : 'ctyp_quot Gram.Entry.t) and _ = (ctyp : 'ctyp Gram.Entry.t) and _ = (constructor_declarations : 'constructor_declarations Gram.Entry.t) and _ = (constructor_declaration : 'constructor_declaration Gram.Entry.t) and _ = (constructor_arg_list : 'constructor_arg_list Gram.Entry.t) and _ = (constrain : 'constrain Gram.Entry.t) and _ = (comma_type_parameter : 'comma_type_parameter Gram.Entry.t) and _ = (comma_patt : 'comma_patt Gram.Entry.t) and _ = (comma_ipatt : 'comma_ipatt Gram.Entry.t) and _ = (comma_expr : 'comma_expr Gram.Entry.t) and _ = (comma_ctyp : 'comma_ctyp Gram.Entry.t) and _ = (class_type_quot : 'class_type_quot Gram.Entry.t) and _ = (class_type_plus : 'class_type_plus Gram.Entry.t) and _ = (class_type_longident_and_param : 'class_type_longident_and_param Gram.Entry.t) and _ = (class_type_longident : 'class_type_longident Gram.Entry.t) and _ = (class_type_declaration : 'class_type_declaration Gram.Entry.t) and _ = (class_type : 'class_type Gram.Entry.t) and _ = (class_structure : 'class_structure Gram.Entry.t) and _ = (class_str_item_quot : 'class_str_item_quot Gram.Entry.t) and _ = (class_str_item : 'class_str_item Gram.Entry.t) and _ = (class_signature : 'class_signature Gram.Entry.t) and _ = (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t) and _ = (class_sig_item : 'class_sig_item Gram.Entry.t) and _ = (class_name_and_param : 'class_name_and_param Gram.Entry.t) and _ = (class_longident_and_param : 'class_longident_and_param Gram.Entry.t) and _ = (class_longident : 'class_longident Gram.Entry.t) and _ = (class_info_for_class_type : 'class_info_for_class_type Gram.Entry.t) and _ = (class_info_for_class_expr : 'class_info_for_class_expr Gram.Entry.t) and _ = (class_fun_def : 'class_fun_def Gram.Entry.t) and _ = (class_fun_binding : 'class_fun_binding Gram.Entry.t) and _ = (class_expr_quot : 'class_expr_quot Gram.Entry.t) and _ = (class_expr : 'class_expr Gram.Entry.t) and _ = (class_description : 'class_description Gram.Entry.t) and _ = (class_declaration : 'class_declaration Gram.Entry.t) and _ = (binding_quot : 'binding_quot Gram.Entry.t) and _ = (binding : 'binding Gram.Entry.t) and _ = (match_case_quot : 'match_case_quot Gram.Entry.t) and _ = (match_case0 : 'match_case0 Gram.Entry.t) and _ = (match_case : 'match_case Gram.Entry.t) and _ = (and_ctyp : 'and_ctyp Gram.Entry.t) and _ = (amp_ctyp : 'amp_ctyp Gram.Entry.t) and _ = (a_ident : 'a_ident Gram.Entry.t) and _ = (a_UIDENT : 'a_UIDENT Gram.Entry.t) and _ = (a_STRING : 'a_STRING Gram.Entry.t) and _ = (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t) and _ = (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t) and _ = (rec_binding_quot : 'rec_binding_quot Gram.Entry.t) and _ = (a_LIDENT : 'a_LIDENT Gram.Entry.t) and _ = (a_LABEL : 'a_LABEL Gram.Entry.t) and _ = (a_INT64 : 'a_INT64 Gram.Entry.t) and _ = (a_INT32 : 'a_INT32 Gram.Entry.t) and _ = (a_INT : 'a_INT Gram.Entry.t) and _ = (a_FLOAT : 'a_FLOAT Gram.Entry.t) in let grammar_entry_create = Gram.Entry.mk in let (* Here it's LABEL and not tilde_label since ~a:b is different than ~a : b *) (* Same remark for ?a:b *) infixop5 : 'infixop5 Gram.Entry.t = grammar_entry_create "infixop5" and (* | i = opt_label; "("; p = patt_tcon; ")" -> *) (* <:patt< ? $i$ : ($p$) >> *) (* | i = opt_label; "("; p = ipatt_tcon; ")" -> <:patt< ? $i$ : ($p$) >> | i = opt_label; "("; p = ipatt_tcon; "="; e = expr; ")" -> <:patt< ? $i$ : ($p$ = $e$) >> *) string_list : 'string_list Gram.Entry.t = grammar_entry_create "string_list" and opt_override : 'opt_override Gram.Entry.t = grammar_entry_create "opt_override" and unquoted_typevars : 'unquoted_typevars Gram.Entry.t = grammar_entry_create "unquoted_typevars" and value_val_opt_override : 'value_val_opt_override Gram.Entry.t = grammar_entry_create "value_val_opt_override" and method_opt_override : 'method_opt_override Gram.Entry.t = grammar_entry_create "method_opt_override" and module_longident_dot_lparen : 'module_longident_dot_lparen Gram.Entry.t = grammar_entry_create "module_longident_dot_lparen" and optional_type_parameter : 'optional_type_parameter Gram.Entry.t = grammar_entry_create "optional_type_parameter" and fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t = grammar_entry_create "fun_def_cont_no_when" and fun_def_cont : 'fun_def_cont Gram.Entry.t = grammar_entry_create "fun_def_cont" and sequence' : 'sequence' Gram.Entry.t = grammar_entry_create "sequence'" and infixop6 : 'infixop6 Gram.Entry.t = grammar_entry_create "infixop6" in (Gram.extend (module_expr : 'module_expr Gram.Entry.t) ((fun () -> (None, [ ((Some "top"), None, [ ([ Gram.Skeyword "struct"; Gram.Snterm (Gram.Entry.obj (str_items : 'str_items Gram.Entry.t)); Gram.Skeyword "end" ], (Gram.Action.mk (fun _ (st : 'str_items) _ (_loc : Gram.Loc.t) -> (Ast.MeStr (_loc, st) : 'module_expr)))); ([ Gram.Skeyword "functor"; Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)); Gram.Skeyword ")"; Gram.Skeyword "->"; Gram.Sself ], (Gram.Action.mk (fun (me : 'module_expr) _ _ (t : 'module_type) _ (i : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> (Ast.MeFun (_loc, i, t, me) : 'module_expr)))) ]); ((Some "apply"), None, [ ([ Gram.Sself; Gram.Sself ], (Gram.Action.mk (fun (me2 : 'module_expr) (me1 : 'module_expr) (_loc : Gram.Loc.t) -> (Ast.MeApp (_loc, me1, me2) : 'module_expr)))) ]); ((Some "simple"), None, [ ([ Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (value_val : 'value_val Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (package_type : 'package_type Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (p : 'package_type) _ (e : 'expr) _ _ (_loc : Gram.Loc.t) -> (Ast.MePkg (_loc, (Ast.ExTyc (_loc, e, (Ast.TyPkg (_loc, p))))) : 'module_expr)))); ([ Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (value_val : 'value_val Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (e : 'expr) _ _ (_loc : Gram.Loc.t) -> (Ast.MePkg (_loc, e) : 'module_expr)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (me : 'module_expr) _ (_loc : Gram.Loc.t) -> (me : 'module_expr)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (mt : 'module_type) _ (me : 'module_expr) _ (_loc : Gram.Loc.t) -> (Ast.MeTyc (_loc, me, mt) : 'module_expr)))); ([ Gram.Snterm (Gram.Entry.obj (module_longident : 'module_longident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'module_longident) (_loc : Gram.Loc.t) -> (Ast.MeId (_loc, i) : 'module_expr)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.module_expr_tag : 'module_expr) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "mexp" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"mexp\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "mexp" | "anti" | "list" as n)), s) -> (Ast.MeAnt (_loc, (mk_anti ~c: "module_expr" n s)) : 'module_expr) | _ -> assert false))) ]) ])) ()); Gram.extend (str_item : 'str_item Gram.Entry.t) ((fun () -> (None, [ ((Some "top"), None, [ ([ Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) (_loc : Gram.Loc.t) -> (Ast.StExp (_loc, e) : 'str_item)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.str_item_tag : 'str_item) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "stri" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "stri" | "anti" | "list" as n)), s) -> (Ast.StAnt (_loc, (mk_anti ~c: "str_item" n s)) : 'str_item) | _ -> assert false))); ([ Gram.Skeyword "class"; Gram.Skeyword "type"; Gram.Snterm (Gram.Entry.obj (class_type_declaration : 'class_type_declaration Gram.Entry.t)) ], (Gram.Action.mk (fun (ctd : 'class_type_declaration) _ _ (_loc : Gram.Loc.t) -> (Ast.StClt (_loc, ctd) : 'str_item)))); ([ Gram.Skeyword "class"; Gram.Snterm (Gram.Entry.obj (class_declaration : 'class_declaration Gram.Entry.t)) ], (Gram.Action.mk (fun (cd : 'class_declaration) _ (_loc : Gram.Loc.t) -> (Ast.StCls (_loc, cd) : 'str_item)))); ([ Gram.Snterm (Gram.Entry.obj (value_let : 'value_let Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_rec : 'opt_rec Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (binding : 'binding Gram.Entry.t)) ], (Gram.Action.mk (fun (bi : 'binding) (r : 'opt_rec) _ (_loc : Gram.Loc.t) -> (Ast.StVal (_loc, r, bi) : 'str_item)))); ([ Gram.Skeyword "type"; Gram.Snterm (Gram.Entry.obj (type_declaration : 'type_declaration Gram.Entry.t)) ], (Gram.Action.mk (fun (td : 'type_declaration) _ (_loc : Gram.Loc.t) -> (Ast.StTyp (_loc, td) : 'str_item)))); ([ Gram.Skeyword "open"; Gram.Snterm (Gram.Entry.obj (module_longident : 'module_longident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'module_longident) _ (_loc : Gram.Loc.t) -> (Ast.StOpn (_loc, i) : 'str_item)))); ([ Gram.Skeyword "module"; Gram.Skeyword "type"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)) ], (Gram.Action.mk (fun (mt : 'module_type) _ (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> (Ast.StMty (_loc, i, mt) : 'str_item)))); ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; Gram.Snterm (Gram.Entry.obj (module_binding : 'module_binding Gram.Entry.t)) ], (Gram.Action.mk (fun (mb : 'module_binding) _ _ (_loc : Gram.Loc.t) -> (Ast.StRecMod (_loc, mb) : 'str_item)))); ([ Gram.Skeyword "module"; Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (module_binding0 : 'module_binding0 Gram.Entry.t)) ], (Gram.Action.mk (fun (mb : 'module_binding0) (i : 'a_UIDENT) _ (_loc : Gram.Loc.t) -> (Ast.StMod (_loc, i, mb) : 'str_item)))); ([ Gram.Skeyword "include"; Gram.Snterm (Gram.Entry.obj (module_expr : 'module_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (me : 'module_expr) _ (_loc : Gram.Loc.t) -> (Ast.StInc (_loc, me) : 'str_item)))); ([ Gram.Skeyword "external"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (string_list : 'string_list Gram.Entry.t)) ], (Gram.Action.mk (fun (sl : 'string_list) _ (t : 'ctyp) _ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.StExt (_loc, i, t, sl) : 'str_item)))); ([ Gram.Skeyword "exception"; Gram.Snterm (Gram.Entry.obj (constructor_declaration : 'constructor_declaration Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (type_longident : 'type_longident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'type_longident) _ (t : 'constructor_declaration) _ (_loc : Gram.Loc.t) -> (Ast.StExc (_loc, t, (Ast.OSome i)) : 'str_item)))); ([ Gram.Skeyword "exception"; Gram.Snterm (Gram.Entry.obj (constructor_declaration : 'constructor_declaration Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'constructor_declaration) _ (_loc : Gram.Loc.t) -> (Ast.StExc (_loc, t, Ast.ONone) : 'str_item)))) ]) ])) ()); Gram.extend (module_binding0 : 'module_binding0 Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.RightA), [ ([ Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (module_expr : 'module_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (me : 'module_expr) _ (_loc : Gram.Loc.t) -> (me : 'module_binding0)))); ([ Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (module_expr : 'module_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (me : 'module_expr) _ (mt : 'module_type) _ (_loc : Gram.Loc.t) -> (Ast.MeTyc (_loc, me, mt) : 'module_binding0)))); ([ Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)); Gram.Skeyword ")"; Gram.Sself ], (Gram.Action.mk (fun (mb : 'module_binding0) _ (mt : 'module_type) _ (m : 'a_UIDENT) _ (_loc : Gram.Loc.t) -> (Ast.MeFun (_loc, m, mt, mb) : 'module_binding0)))) ]) ])) ()); Gram.extend (module_binding : 'module_binding Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (module_expr : 'module_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (me : 'module_expr) _ (mt : 'module_type) _ (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.MbColEq (_loc, m, mt, me) : 'module_binding)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.module_binding_tag : 'module_binding) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("", _) -> true | _ -> false), "ANTIQUOT (\"\", _)")); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (module_expr : 'module_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (me : 'module_expr) _ (mt : 'module_type) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" as n)), m) -> (Ast.MbColEq (_loc, (mk_anti n m), mt, me) : 'module_binding) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("", _) -> true | _ -> false), "ANTIQUOT (\"\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" as n)), s) -> (Ast.MbAnt (_loc, (mk_anti ~c: "module_binding" n s)) : 'module_binding) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("module_binding" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"module_binding\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("module_binding" | "anti" | "list" as n)), s) -> (Ast.MbAnt (_loc, (mk_anti ~c: "module_binding" n s)) : 'module_binding) | _ -> assert false))); ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], (Gram.Action.mk (fun (b2 : 'module_binding) _ (b1 : 'module_binding) (_loc : Gram.Loc.t) -> (Ast.MbAnd (_loc, b1, b2) : 'module_binding)))) ]) ])) ()); Gram.extend (module_type : 'module_type Gram.Entry.t) ((fun () -> (None, [ ((Some "top"), None, [ ([ Gram.Skeyword "functor"; Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Sself; Gram.Skeyword ")"; Gram.Skeyword "->"; Gram.Sself ], (Gram.Action.mk (fun (mt : 'module_type) _ _ (t : 'module_type) _ (i : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> (Ast.MtFun (_loc, i, t, mt) : 'module_type)))) ]); ((Some "with"), None, [ ([ Gram.Sself; Gram.Skeyword "with"; Gram.Snterm (Gram.Entry.obj (with_constr : 'with_constr Gram.Entry.t)) ], (Gram.Action.mk (fun (wc : 'with_constr) _ (mt : 'module_type) (_loc : Gram.Loc.t) -> (Ast.MtWit (_loc, mt, wc) : 'module_type)))) ]); ((Some "apply"), None, [ ([ Gram.Sself; Gram.Sself; Gram.Snterm (Gram.Entry.obj (dummy : 'dummy Gram.Entry.t)) ], (Gram.Action.mk (fun _ (mt2 : 'module_type) (mt1 : 'module_type) (_loc : Gram.Loc.t) -> (module_type_app mt1 mt2 : 'module_type)))) ]); ((Some "."), None, [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (mt2 : 'module_type) _ (mt1 : 'module_type) (_loc : Gram.Loc.t) -> (module_type_acc mt1 mt2 : 'module_type)))) ]); ((Some "sig"), None, [ ([ Gram.Skeyword "sig"; Gram.Snterm (Gram.Entry.obj (sig_items : 'sig_items Gram.Entry.t)); Gram.Skeyword "end" ], (Gram.Action.mk (fun _ (sg : 'sig_items) _ (_loc : Gram.Loc.t) -> (Ast.MtSig (_loc, sg) : 'module_type)))) ]); ((Some "simple"), None, [ ([ Gram.Skeyword "module"; Gram.Skeyword "type"; Gram.Skeyword "of"; Gram.Snterm (Gram.Entry.obj (module_expr : 'module_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (me : 'module_expr) _ _ _ (_loc : Gram.Loc.t) -> (Ast.MtOf (_loc, me) : 'module_type)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (mt : 'module_type) _ (_loc : Gram.Loc.t) -> (mt : 'module_type)))); ([ Gram.Skeyword "'"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> (Ast.MtQuo (_loc, i) : 'module_type)))); ([ Gram.Snterm (Gram.Entry.obj (module_longident_with_app : 'module_longident_with_app Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'module_longident_with_app) (_loc : Gram.Loc.t) -> (Ast.MtId (_loc, i) : 'module_type)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.module_type_tag : 'module_type) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "mtyp" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"mtyp\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "mtyp" | "anti" | "list" as n)), s) -> (Ast.MtAnt (_loc, (mk_anti ~c: "module_type" n s)) : 'module_type) | _ -> assert false))) ]) ])) ()); Gram.extend (sig_item : 'sig_item Gram.Entry.t) ((fun () -> (None, [ ((Some "top"), None, [ ([ Gram.Skeyword "class"; Gram.Skeyword "type"; Gram.Snterm (Gram.Entry.obj (class_type_declaration : 'class_type_declaration Gram.Entry.t)) ], (Gram.Action.mk (fun (ctd : 'class_type_declaration) _ _ (_loc : Gram.Loc.t) -> (Ast.SgClt (_loc, ctd) : 'sig_item)))); ([ Gram.Skeyword "class"; Gram.Snterm (Gram.Entry.obj (class_description : 'class_description Gram.Entry.t)) ], (Gram.Action.mk (fun (cd : 'class_description) _ (_loc : Gram.Loc.t) -> (Ast.SgCls (_loc, cd) : 'sig_item)))); ([ Gram.Snterm (Gram.Entry.obj (value_val : 'value_val Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.SgVal (_loc, i, t) : 'sig_item)))); ([ Gram.Skeyword "type"; Gram.Snterm (Gram.Entry.obj (type_declaration : 'type_declaration Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'type_declaration) _ (_loc : Gram.Loc.t) -> (Ast.SgTyp (_loc, t) : 'sig_item)))); ([ Gram.Skeyword "open"; Gram.Snterm (Gram.Entry.obj (module_longident : 'module_longident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'module_longident) _ (_loc : Gram.Loc.t) -> (Ast.SgOpn (_loc, i) : 'sig_item)))); ([ Gram.Skeyword "module"; Gram.Skeyword "type"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> (Ast.SgMty (_loc, i, (Ast.MtNil _loc)) : 'sig_item)))); ([ Gram.Skeyword "module"; Gram.Skeyword "type"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)) ], (Gram.Action.mk (fun (mt : 'module_type) _ (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> (Ast.SgMty (_loc, i, mt) : 'sig_item)))); ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; Gram.Snterm (Gram.Entry.obj (module_rec_declaration : 'module_rec_declaration Gram.Entry.t)) ], (Gram.Action.mk (fun (mb : 'module_rec_declaration) _ _ (_loc : Gram.Loc.t) -> (Ast.SgRecMod (_loc, mb) : 'sig_item)))); ([ Gram.Skeyword "module"; Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (module_declaration : 'module_declaration Gram.Entry.t)) ], (Gram.Action.mk (fun (mt : 'module_declaration) (i : 'a_UIDENT) _ (_loc : Gram.Loc.t) -> (Ast.SgMod (_loc, i, mt) : 'sig_item)))); ([ Gram.Skeyword "include"; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)) ], (Gram.Action.mk (fun (mt : 'module_type) _ (_loc : Gram.Loc.t) -> (Ast.SgInc (_loc, mt) : 'sig_item)))); ([ Gram.Skeyword "external"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (string_list : 'string_list Gram.Entry.t)) ], (Gram.Action.mk (fun (sl : 'string_list) _ (t : 'ctyp) _ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.SgExt (_loc, i, t, sl) : 'sig_item)))); ([ Gram.Skeyword "exception"; Gram.Snterm (Gram.Entry.obj (constructor_declaration : 'constructor_declaration Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'constructor_declaration) _ (_loc : Gram.Loc.t) -> (Ast.SgExc (_loc, t) : 'sig_item)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.sig_item_tag : 'sig_item) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "sigi" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "sigi" | "anti" | "list" as n)), s) -> (Ast.SgAnt (_loc, (mk_anti ~c: "sig_item" n s)) : 'sig_item) | _ -> assert false))) ]) ])) ()); Gram.extend (module_declaration : 'module_declaration Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.RightA), [ ([ Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)); Gram.Skeyword ")"; Gram.Sself ], (Gram.Action.mk (fun (mt : 'module_declaration) _ (t : 'module_type) _ (i : 'a_UIDENT) _ (_loc : Gram.Loc.t) -> (Ast.MtFun (_loc, i, t, mt) : 'module_declaration)))); ([ Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)) ], (Gram.Action.mk (fun (mt : 'module_type) _ (_loc : Gram.Loc.t) -> (mt : 'module_declaration)))) ]) ])) ()); Gram.extend (module_rec_declaration : 'module_rec_declaration Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)) ], (Gram.Action.mk (fun (mt : 'module_type) _ (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.MbCol (_loc, m, mt) : 'module_rec_declaration)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.module_binding_tag : 'module_rec_declaration) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "module_binding" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"module_binding\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "module_binding" | "anti" | "list" as n)), s) -> (Ast.MbAnt (_loc, (mk_anti ~c: "module_binding" n s)) : 'module_rec_declaration) | _ -> assert false))); ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], (Gram.Action.mk (fun (m2 : 'module_rec_declaration) _ (m1 : 'module_rec_declaration) (_loc : Gram.Loc.t) -> (Ast.MbAnd (_loc, m1, m2) : 'module_rec_declaration)))) ]) ])) ()); Gram.extend (with_constr : 'with_constr Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Skeyword "module"; Gram.Snterm (Gram.Entry.obj (module_longident : 'module_longident Gram.Entry.t)); Gram.Skeyword ":="; Gram.Snterm (Gram.Entry.obj (module_longident_with_app : 'module_longident_with_app Gram.Entry.t)) ], (Gram.Action.mk (fun (i2 : 'module_longident_with_app) _ (i1 : 'module_longident) _ (_loc : Gram.Loc.t) -> (Ast.WcMoS (_loc, i1, i2) : 'with_constr)))); ([ Gram.Skeyword "type"; Gram.Snterm (Gram.Entry.obj (type_longident_and_parameters : 'type_longident_and_parameters Gram.Entry. t)); Gram.Skeyword ":="; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t2 : 'ctyp) _ (t1 : 'type_longident_and_parameters) _ (_loc : Gram.Loc.t) -> (Ast.WcTyS (_loc, t1, t2) : 'with_constr)))); ([ Gram.Skeyword "type"; Gram.Stoken (((function | ANTIQUOT (("" | "typ" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")); Gram.Skeyword ":="; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'ctyp) _ (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" | "anti" as n)), s) -> (Ast.WcTyS (_loc, (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp" n s))), t) : 'with_constr) | _ -> assert false))); ([ Gram.Skeyword "module"; Gram.Snterm (Gram.Entry.obj (module_longident : 'module_longident Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (module_longident_with_app : 'module_longident_with_app Gram.Entry.t)) ], (Gram.Action.mk (fun (i2 : 'module_longident_with_app) _ (i1 : 'module_longident) _ (_loc : Gram.Loc.t) -> (Ast.WcMod (_loc, i1, i2) : 'with_constr)))); ([ Gram.Skeyword "type"; Gram.Snterm (Gram.Entry.obj (type_longident_and_parameters : 'type_longident_and_parameters Gram.Entry. t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t2 : 'ctyp) _ (t1 : 'type_longident_and_parameters) _ (_loc : Gram.Loc.t) -> (Ast.WcTyp (_loc, t1, t2) : 'with_constr)))); ([ Gram.Skeyword "type"; Gram.Stoken (((function | ANTIQUOT (("" | "typ" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'ctyp) _ (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" | "anti" as n)), s) -> (Ast.WcTyp (_loc, (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp" n s))), t) : 'with_constr) | _ -> assert false))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.with_constr_tag : 'with_constr) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "with_constr" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"with_constr\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "with_constr" | "anti" | "list" as n)), s) -> (Ast.WcAnt (_loc, (mk_anti ~c: "with_constr" n s)) : 'with_constr) | _ -> assert false))); ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], (Gram.Action.mk (fun (wc2 : 'with_constr) _ (wc1 : 'with_constr) (_loc : Gram.Loc.t) -> (Ast.WcAnd (_loc, wc1, wc2) : 'with_constr)))) ]) ])) ()); Gram.extend (expr : 'expr Gram.Entry.t) ((fun () -> (None, [ ((Some "top"), (Some Camlp4.Sig.Grammar.RightA), [ ([ Gram.Skeyword "object"; Gram.Snterm (Gram.Entry.obj (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (class_structure : 'class_structure Gram.Entry.t)); Gram.Skeyword "end" ], (Gram.Action.mk (fun _ (cst : 'class_structure) (csp : 'opt_class_self_patt) _ (_loc : Gram.Loc.t) -> (Ast.ExObj (_loc, csp, cst) : 'expr)))); ([ Gram.Skeyword "while"; Gram.Snterm (Gram.Entry.obj (sequence : 'sequence Gram.Entry.t)); Gram.Skeyword "do"; Gram.Snterm (Gram.Entry.obj (do_sequence : 'do_sequence Gram.Entry.t)) ], (Gram.Action.mk (fun (seq : 'do_sequence) _ (e : 'sequence) _ (_loc : Gram.Loc.t) -> (Ast.ExWhi (_loc, (mksequence' _loc e), seq) : 'expr)))); ([ Gram.Skeyword "for"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (sequence : 'sequence Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (direction_flag : 'direction_flag Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (sequence : 'sequence Gram.Entry.t)); Gram.Skeyword "do"; Gram.Snterm (Gram.Entry.obj (do_sequence : 'do_sequence Gram.Entry.t)) ], (Gram.Action.mk (fun (seq : 'do_sequence) _ (e2 : 'sequence) (df : 'direction_flag) (e1 : 'sequence) _ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.ExFor (_loc, i, (mksequence' _loc e1), (mksequence' _loc e2), df, seq) : 'expr)))); ([ Gram.Skeyword "do"; Gram.Snterm (Gram.Entry.obj (do_sequence : 'do_sequence Gram.Entry.t)) ], (Gram.Action.mk (fun (seq : 'do_sequence) _ (_loc : Gram.Loc.t) -> (mksequence _loc seq : 'expr)))); ([ Gram.Skeyword "if"; Gram.Sself; Gram.Skeyword "then"; Gram.Sself; Gram.Skeyword "else"; Gram.Sself ], (Gram.Action.mk (fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr) _ (_loc : Gram.Loc.t) -> (Ast.ExIfe (_loc, e1, e2, e3) : 'expr)))); ([ Gram.Skeyword "try"; Gram.Snterm (Gram.Entry.obj (sequence : 'sequence Gram.Entry.t)); Gram.Skeyword "with"; Gram.Snterm (Gram.Entry.obj (match_case : 'match_case Gram.Entry.t)) ], (Gram.Action.mk (fun (a : 'match_case) _ (e : 'sequence) _ (_loc : Gram.Loc.t) -> (Ast.ExTry (_loc, (mksequence' _loc e), a) : 'expr)))); ([ Gram.Skeyword "match"; Gram.Snterm (Gram.Entry.obj (sequence : 'sequence Gram.Entry.t)); Gram.Skeyword "with"; Gram.Snterm (Gram.Entry.obj (match_case : 'match_case Gram.Entry.t)) ], (Gram.Action.mk (fun (a : 'match_case) _ (e : 'sequence) _ (_loc : Gram.Loc.t) -> (Ast.ExMat (_loc, (mksequence' _loc e), a) : 'expr)))); ([ Gram.Skeyword "fun"; Gram.Snterm (Gram.Entry.obj (fun_def : 'fun_def Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'fun_def) _ (_loc : Gram.Loc.t) -> (e : 'expr)))); ([ Gram.Skeyword "fun"; Gram.Skeyword "["; Gram.Slist0sep ((Gram.Snterm (Gram.Entry.obj (match_case0 : 'match_case0 Gram.Entry.t))), (Gram.Skeyword "|")); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (a : 'match_case0 list) _ _ (_loc : Gram.Loc.t) -> (Ast.ExFun (_loc, (Ast.mcOr_of_list a)) : 'expr)))); ([ Gram.Skeyword "let"; Gram.Skeyword "open"; Gram.Snterm (Gram.Entry.obj (module_longident : 'module_longident Gram.Entry.t)); Gram.Skeyword "in"; Gram.Sself ], (Gram.Action.mk (fun (e : 'expr) _ (i : 'module_longident) _ _ (_loc : Gram.Loc.t) -> (Ast.ExOpI (_loc, i, e) : 'expr)))); ([ Gram.Skeyword "let"; Gram.Skeyword "module"; Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (module_binding0 : 'module_binding0 Gram.Entry.t)); Gram.Skeyword "in"; Gram.Sself ], (Gram.Action.mk (fun (e : 'expr) _ (mb : 'module_binding0) (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> (Ast.ExLmd (_loc, m, mb, e) : 'expr)))); ([ Gram.Skeyword "let"; Gram.Snterm (Gram.Entry.obj (opt_rec : 'opt_rec Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (binding : 'binding Gram.Entry.t)); Gram.Skeyword "in"; Gram.Sself ], (Gram.Action.mk (fun (x : 'expr) _ (bi : 'binding) (r : 'opt_rec) _ (_loc : Gram.Loc.t) -> (Ast.ExLet (_loc, r, bi, x) : 'expr)))) ]); ((Some "where"), None, [ ([ Gram.Sself; Gram.Skeyword "where"; Gram.Snterm (Gram.Entry.obj (opt_rec : 'opt_rec Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (let_binding : 'let_binding Gram.Entry.t)) ], (Gram.Action.mk (fun (lb : 'let_binding) (rf : 'opt_rec) _ (e : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExLet (_loc, rf, lb, e) : 'expr)))) ]); ((Some ":="), (Some Camlp4.Sig.Grammar.NonA), [ ([ Gram.Sself; Gram.Skeyword ":="; Gram.Sself; Gram.Snterm (Gram.Entry.obj (dummy : 'dummy Gram.Entry.t)) ], (Gram.Action.mk (fun _ (e2 : 'expr) _ (e1 : 'expr) (_loc : Gram.Loc.t) -> (match bigarray_set _loc e1 e2 with | Some e -> e | None -> Ast.ExAss (_loc, e1, e2) : 'expr)))) ]); ((Some "||"), (Some Camlp4.Sig.Grammar.RightA), [ ([ Gram.Sself; Gram.Snterm (Gram.Entry.obj (infixop6 : 'infixop6 Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) (op : 'infixop6) (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)), e2) : 'expr)))) ]); ((Some "&&"), (Some Camlp4.Sig.Grammar.RightA), [ ([ Gram.Sself; Gram.Snterm (Gram.Entry.obj (infixop5 : 'infixop5 Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) (op : 'infixop5) (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)), e2) : 'expr)))) ]); ((Some "<"), (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Sself; Gram.Snterm (Gram.Entry.obj (infixop0 : 'infixop0 Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) (op : 'infixop0) (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)), e2) : 'expr)))) ]); ((Some "^"), (Some Camlp4.Sig.Grammar.RightA), [ ([ Gram.Sself; Gram.Snterm (Gram.Entry.obj (infixop1 : 'infixop1 Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) (op : 'infixop1) (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)), e2) : 'expr)))) ]); ((Some "+"), (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Sself; Gram.Snterm (Gram.Entry.obj (infixop2 : 'infixop2 Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) (op : 'infixop2) (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)), e2) : 'expr)))) ]); ((Some "*"), (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Sself; Gram.Snterm (Gram.Entry.obj (infixop3 : 'infixop3 Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) (op : 'infixop3) (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)), e2) : 'expr)))); ([ Gram.Sself; Gram.Skeyword "mod"; Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, "mod")))), e1)), e2) : 'expr)))); ([ Gram.Sself; Gram.Skeyword "lxor"; Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, "lxor")))), e1)), e2) : 'expr)))); ([ Gram.Sself; Gram.Skeyword "lor"; Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, "lor")))), e1)), e2) : 'expr)))); ([ Gram.Sself; Gram.Skeyword "land"; Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, "land")))), e1)), e2) : 'expr)))) ]); ((Some "**"), (Some Camlp4.Sig.Grammar.RightA), [ ([ Gram.Sself; Gram.Snterm (Gram.Entry.obj (infixop4 : 'infixop4 Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) (op : 'infixop4) (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, op, e1)), e2) : 'expr)))); ([ Gram.Sself; Gram.Skeyword "lsr"; Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, "lsr")))), e1)), e2) : 'expr)))); ([ Gram.Sself; Gram.Skeyword "lsl"; Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, "lsl")))), e1)), e2) : 'expr)))); ([ Gram.Sself; Gram.Skeyword "asr"; Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, "asr")))), e1)), e2) : 'expr)))) ]); ((Some "unary minus"), (Some Camlp4.Sig.Grammar.NonA), [ ([ Gram.Skeyword "-."; Gram.Sself ], (Gram.Action.mk (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> (mkumin _loc "-." e : 'expr)))); ([ Gram.Skeyword "-"; Gram.Sself ], (Gram.Action.mk (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> (mkumin _loc "-" e : 'expr)))) ]); ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Skeyword "lazy"; Gram.Sself ], (Gram.Action.mk (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> (Ast.ExLaz (_loc, e) : 'expr)))); ([ Gram.Skeyword "new"; Gram.Snterm (Gram.Entry.obj (class_longident : 'class_longident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'class_longident) _ (_loc : Gram.Loc.t) -> (Ast.ExNew (_loc, i) : 'expr)))); ([ Gram.Skeyword "assert"; Gram.Sself ], (Gram.Action.mk (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> (mkassert _loc e : 'expr)))); ([ Gram.Sself; Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, e1, e2) : 'expr)))) ]); ((Some "label"), (Some Camlp4.Sig.Grammar.NonA), [ ([ Gram.Skeyword "?"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.ExOlb (_loc, i, (Ast.ExNil _loc)) : 'expr)))); ([ Gram.Skeyword "?"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Sself ], (Gram.Action.mk (fun (e : 'expr) _ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.ExOlb (_loc, i, e) : 'expr)))); ([ Gram.Stoken (((function | OPTLABEL _ -> true | _ -> false), "OPTLABEL _")); Gram.Sself ], (Gram.Action.mk (fun (e : 'expr) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | OPTLABEL i -> (Ast.ExOlb (_loc, i, e) : 'expr) | _ -> assert false))); ([ Gram.Stoken (((function | LABEL _ -> true | _ -> false), "LABEL _")); Gram.Sself ], (Gram.Action.mk (fun (e : 'expr) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | LABEL i -> (Ast.ExLab (_loc, i, e) : 'expr) | _ -> assert false))); ([ Gram.Skeyword "~"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.ExLab (_loc, i, (Ast.ExNil _loc)) : 'expr)))); ([ Gram.Skeyword "~"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Sself ], (Gram.Action.mk (fun (e : 'expr) _ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.ExLab (_loc, i, e) : 'expr)))) ]); ((Some "."), (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Sself; Gram.Skeyword "#"; Gram.Snterm (Gram.Entry.obj (label : 'label Gram.Entry.t)) ], (Gram.Action.mk (fun (lab : 'label) _ (e : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExSnd (_loc, e, lab) : 'expr)))); ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExAcc (_loc, e1, e2) : 'expr)))); ([ Gram.Sself; Gram.Skeyword "."; Gram.Skeyword "{"; Gram.Snterm (Gram.Entry.obj (comma_expr : 'comma_expr Gram.Entry.t)); Gram.Skeyword "}" ], (Gram.Action.mk (fun _ (e2 : 'comma_expr) _ _ (e1 : 'expr) (_loc : Gram.Loc.t) -> (bigarray_get _loc e1 e2 : 'expr)))); ([ Gram.Sself; Gram.Skeyword "."; Gram.Skeyword "["; Gram.Sself; Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (e2 : 'expr) _ _ (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExSte (_loc, e1, e2) : 'expr)))); ([ Gram.Sself; Gram.Skeyword "."; Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (e2 : 'expr) _ _ (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExAre (_loc, e1, e2) : 'expr)))) ]); ((Some "~-"), (Some Camlp4.Sig.Grammar.NonA), [ ([ Gram.Snterm (Gram.Entry.obj (prefixop : 'prefixop Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (e : 'expr) (f : 'prefixop) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, f, e) : 'expr)))); ([ Gram.Skeyword "!"; Gram.Sself ], (Gram.Action.mk (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> (Ast.ExAcc (_loc, e, (Ast.ExId (_loc, (Ast.IdLid (_loc, "val"))))) : 'expr)))) ]); ((Some "simple"), None, [ ([ Gram.Skeyword "("; Gram.Skeyword "module"; Gram.Snterm (Gram.Entry.obj (module_expr : 'module_expr Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (package_type : 'package_type Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (pt : 'package_type) _ (me : 'module_expr) _ _ (_loc : Gram.Loc.t) -> (Ast.ExPkg (_loc, (Ast.MeTyc (_loc, me, pt))) : 'expr)))); ([ Gram.Skeyword "("; Gram.Skeyword "module"; Gram.Snterm (Gram.Entry.obj (module_expr : 'module_expr Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (me : 'module_expr) _ _ (_loc : Gram.Loc.t) -> (Ast.ExPkg (_loc, me) : 'expr)))); ([ Gram.Skeyword "begin"; Gram.Skeyword "end" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : 'expr)))); ([ Gram.Skeyword "begin"; Gram.Snterm (Gram.Entry.obj (sequence : 'sequence Gram.Entry.t)); Gram.Skeyword "end" ], (Gram.Action.mk (fun _ (seq : 'sequence) _ (_loc : Gram.Loc.t) -> (mksequence _loc seq : 'expr)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (e : 'expr) _ (_loc : Gram.Loc.t) -> (e : 'expr)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":>"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (t : 'ctyp) _ (e : 'expr) _ (_loc : Gram.Loc.t) -> (Ast.ExCoe (_loc, e, (Ast.TyNil _loc), t) : 'expr)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword ":>"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ (_loc : Gram.Loc.t) -> (Ast.ExCoe (_loc, e, t, t2) : 'expr)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ";"; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ _ (e : 'expr) _ (_loc : Gram.Loc.t) -> (mksequence _loc e : 'expr)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ";"; Gram.Snterm (Gram.Entry.obj (sequence : 'sequence Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (seq : 'sequence) _ (e : 'expr) _ (_loc : Gram.Loc.t) -> (mksequence _loc (Ast.ExSem (_loc, e, seq)) : 'expr)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ","; Gram.Snterm (Gram.Entry.obj (comma_expr : 'comma_expr Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (el : 'comma_expr) _ (e : 'expr) _ (_loc : Gram.Loc.t) -> (Ast.ExTup (_loc, (Ast.ExCom (_loc, e, el))) : 'expr)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (t : 'ctyp) _ (e : 'expr) _ (_loc : Gram.Loc.t) -> (Ast.ExTyc (_loc, e, t) : 'expr)))); ([ Gram.Skeyword "("; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : 'expr)))); ([ Gram.Skeyword "{<"; Gram.Snterm (Gram.Entry.obj (field_expr_list : 'field_expr_list Gram.Entry.t)); Gram.Skeyword ">}" ], (Gram.Action.mk (fun _ (fel : 'field_expr_list) _ (_loc : Gram.Loc.t) -> (Ast.ExOvr (_loc, fel) : 'expr)))); ([ Gram.Skeyword "{<"; Gram.Skeyword ">}" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (Ast.ExOvr (_loc, (Ast.RbNil _loc)) : 'expr)))); ([ Gram.Skeyword "{"; Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")"; Gram.Skeyword "with"; Gram.Snterm (Gram.Entry.obj (label_expr_list : 'label_expr_list Gram.Entry.t)); Gram.Skeyword "}" ], (Gram.Action.mk (fun _ (el : 'label_expr_list) _ _ (e : 'expr) _ _ (_loc : Gram.Loc.t) -> (Ast.ExRec (_loc, el, e) : 'expr)))); ([ Gram.Skeyword "{"; Gram.Snterm (Gram.Entry.obj (label_expr_list : 'label_expr_list Gram.Entry.t)); Gram.Skeyword "}" ], (Gram.Action.mk (fun _ (el : 'label_expr_list) _ (_loc : Gram.Loc.t) -> (Ast.ExRec (_loc, el, (Ast.ExNil _loc)) : 'expr)))); ([ Gram.Skeyword "[|"; Gram.Snterm (Gram.Entry.obj (sem_expr : 'sem_expr Gram.Entry.t)); Gram.Skeyword "|]" ], (Gram.Action.mk (fun _ (el : 'sem_expr) _ (_loc : Gram.Loc.t) -> (Ast.ExArr (_loc, el) : 'expr)))); ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (Ast.ExArr (_loc, (Ast.ExNil _loc)) : 'expr)))); ([ Gram.Skeyword "["; Gram.Snterm (Gram.Entry.obj (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t)); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (mk_list : 'sem_expr_for_list) _ (_loc : Gram.Loc.t) -> (mk_list (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) : 'expr)))); ([ Gram.Skeyword "["; Gram.Snterm (Gram.Entry.obj (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t)); Gram.Skeyword "::"; Gram.Sself; Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (last : 'expr) _ (mk_list : 'sem_expr_for_list) _ (_loc : Gram.Loc.t) -> (mk_list last : 'expr)))); ([ Gram.Skeyword "["; Gram.Skeyword "]" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))) : 'expr)))); ([ Gram.Skeyword "`"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> (Ast.ExVrn (_loc, s) : 'expr)))); ([ Gram.Stry (Gram.Snterm (Gram.Entry.obj (val_longident : 'val_longident Gram.Entry.t))) ], (Gram.Action.mk (fun (i : 'val_longident) (_loc : Gram.Loc.t) -> (Ast.ExId (_loc, i) : 'expr)))); ([ Gram.Stry (Gram.Snterm (Gram.Entry.obj (module_longident_dot_lparen : 'module_longident_dot_lparen Gram. Entry.t))); Gram.Snterm (Gram.Entry.obj (sequence : 'sequence Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (e : 'sequence) (i : 'module_longident_dot_lparen) (_loc : Gram.Loc.t) -> (Ast.ExOpI (_loc, i, e) : 'expr)))); ([ Gram.Snterm (Gram.Entry.obj (a_CHAR : 'a_CHAR Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_CHAR) (_loc : Gram.Loc.t) -> (Ast.ExChr (_loc, s) : 'expr)))); ([ Gram.Snterm (Gram.Entry.obj (a_STRING : 'a_STRING Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_STRING) (_loc : Gram.Loc.t) -> (Ast.ExStr (_loc, s) : 'expr)))); ([ Gram.Snterm (Gram.Entry.obj (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_FLOAT) (_loc : Gram.Loc.t) -> (Ast.ExFlo (_loc, s) : 'expr)))); ([ Gram.Snterm (Gram.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_NATIVEINT) (_loc : Gram.Loc.t) -> (Ast.ExNativeInt (_loc, s) : 'expr)))); ([ Gram.Snterm (Gram.Entry.obj (a_INT64 : 'a_INT64 Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_INT64) (_loc : Gram.Loc.t) -> (Ast.ExInt64 (_loc, s) : 'expr)))); ([ Gram.Snterm (Gram.Entry.obj (a_INT32 : 'a_INT32 Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_INT32) (_loc : Gram.Loc.t) -> (Ast.ExInt32 (_loc, s) : 'expr)))); ([ Gram.Snterm (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_INT) (_loc : Gram.Loc.t) -> (Ast.ExInt (_loc, s) : 'expr)))); ([ Gram.Stoken (((function | ANTIQUOT ("seq", _) -> true | _ -> false), "ANTIQUOT (\"seq\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("seq" as n)), s) -> (Ast.ExSeq (_loc, (Ast.ExAnt (_loc, (mk_anti ~c: "expr" n s)))) : 'expr) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("tup", _) -> true | _ -> false), "ANTIQUOT (\"tup\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("tup" as n)), s) -> (Ast.ExTup (_loc, (Ast.ExAnt (_loc, (mk_anti ~c: "expr" n s)))) : 'expr) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("`bool", _) -> true | _ -> false), "ANTIQUOT (\"`bool\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("`bool" as n)), s) -> (Ast.ExId (_loc, (Ast.IdAnt (_loc, (mk_anti n s)))) : 'expr) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("exp" | "" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"exp\" | \"\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("exp" | "" | "anti" as n)), s) -> (Ast.ExAnt (_loc, (mk_anti ~c: "expr" n s)) : 'expr) | _ -> assert false))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.expr_tag : 'expr) | _ -> assert false))) ]) ])) ()); Gram.extend (do_sequence : 'do_sequence Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "done" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : 'do_sequence)))); ([ Gram.Stry (Gram.srules do_sequence [ ([ Gram.Snterm (Gram.Entry.obj (sequence : 'sequence Gram.Entry.t)); Gram.Skeyword "done" ], (Gram.Action.mk (fun _ (seq : 'sequence) (_loc : Gram.Loc.t) -> (seq : 'e__3)))) ]) ], (Gram.Action.mk (fun (seq : 'e__3) (_loc : Gram.Loc.t) -> (seq : 'do_sequence)))); ([ Gram.Stry (Gram.srules do_sequence [ ([ Gram.Skeyword "{"; Gram.Skeyword "}" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (() : 'e__2)))) ]) ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : 'do_sequence)))); ([ Gram.Stry (Gram.srules do_sequence [ ([ Gram.Skeyword "{"; Gram.Snterm (Gram.Entry.obj (sequence : 'sequence Gram.Entry.t)); Gram.Skeyword "}" ], (Gram.Action.mk (fun _ (seq : 'sequence) _ (_loc : Gram.Loc.t) -> (seq : 'e__1)))) ]) ], (Gram.Action.mk (fun (seq : 'e__1) (_loc : Gram.Loc.t) -> (seq : 'do_sequence)))) ]) ])) ()); Gram.extend (infixop5 : 'infixop5 Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.srules infixop5 [ ([ Gram.Skeyword "&&" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__4)))); ([ Gram.Skeyword "&" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__4)))) ] ], (Gram.Action.mk (fun (x : 'e__4) (_loc : Gram.Loc.t) -> (Ast.ExId (_loc, (Ast.IdLid (_loc, x))) : 'infixop5)))) ]) ])) ()); Gram.extend (infixop6 : 'infixop6 Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.srules infixop6 [ ([ Gram.Skeyword "||" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__5)))); ([ Gram.Skeyword "or" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__5)))) ] ], (Gram.Action.mk (fun (x : 'e__5) (_loc : Gram.Loc.t) -> (Ast.ExId (_loc, (Ast.IdLid (_loc, x))) : 'infixop6)))) ]) ])) ()); Gram.extend (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) (_loc : Gram.Loc.t) -> (fun acc -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), e)), acc) : 'sem_expr_for_list)))); ([ Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Skeyword ";" ], (Gram.Action.mk (fun _ (e : 'expr) (_loc : Gram.Loc.t) -> (fun acc -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), e)), acc) : 'sem_expr_for_list)))); ([ Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Skeyword ";"; Gram.Sself ], (Gram.Action.mk (fun (el : 'sem_expr_for_list) _ (e : 'expr) (_loc : Gram.Loc.t) -> (fun acc -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), e)), (el acc)) : 'sem_expr_for_list)))) ]) ])) ()); Gram.extend (comma_expr : 'comma_expr Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterml ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), "top") ], (Gram.Action.mk (fun (e : 'expr) (_loc : Gram.Loc.t) -> (e : 'comma_expr)))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.ExAnt (_loc, (mk_anti ~c: "expr," n s)) : 'comma_expr) | _ -> assert false))); ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], (Gram.Action.mk (fun (e2 : 'comma_expr) _ (e1 : 'comma_expr) (_loc : Gram.Loc.t) -> (Ast.ExCom (_loc, e1, e2) : 'comma_expr)))) ]) ])) ()); Gram.extend (dummy : 'dummy Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (() : 'dummy)))) ]) ])) ()); Gram.extend (sequence' : 'sequence' Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword ";"; Gram.Snterm (Gram.Entry.obj (sequence : 'sequence Gram.Entry.t)) ], (Gram.Action.mk (fun (el : 'sequence) _ (_loc : Gram.Loc.t) -> (fun e -> Ast.ExSem (_loc, e, el) : 'sequence')))); ([ Gram.Skeyword ";" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (fun e -> e : 'sequence')))); ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (fun e -> e : 'sequence')))) ]) ])) ()); Gram.extend (sequence : 'sequence Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (sequence' : 'sequence' Gram.Entry.t)) ], (Gram.Action.mk (fun (k : 'sequence') (e : 'expr) (_loc : Gram.Loc.t) -> (k e : 'sequence)))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.ExAnt (_loc, (mk_anti ~c: "expr;" n s)) : 'sequence) | _ -> assert false))); ([ Gram.Skeyword "let"; Gram.Skeyword "open"; Gram.Snterm (Gram.Entry.obj (module_longident : 'module_longident Gram.Entry.t)); Gram.Skeyword "in"; Gram.Sself ], (Gram.Action.mk (fun (e : 'sequence) _ (i : 'module_longident) _ _ (_loc : Gram.Loc.t) -> (Ast.ExOpI (_loc, i, e) : 'sequence)))); ([ Gram.Skeyword "let"; Gram.Skeyword "module"; Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (module_binding0 : 'module_binding0 Gram.Entry.t)); Gram.Skeyword ";"; Gram.Sself ], (Gram.Action.mk (fun (el : 'sequence) _ (mb : 'module_binding0) (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> (Ast.ExLmd (_loc, m, mb, (mksequence _loc el)) : 'sequence)))); ([ Gram.Skeyword "let"; Gram.Skeyword "module"; Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (module_binding0 : 'module_binding0 Gram.Entry.t)); Gram.Skeyword "in"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (sequence' : 'sequence' Gram.Entry.t)) ], (Gram.Action.mk (fun (k : 'sequence') (e : 'expr) _ (mb : 'module_binding0) (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> (k (Ast.ExLmd (_loc, m, mb, e)) : 'sequence)))); ([ Gram.Skeyword "let"; Gram.Snterm (Gram.Entry.obj (opt_rec : 'opt_rec Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (binding : 'binding Gram.Entry.t)); Gram.Skeyword ";"; Gram.Sself ], (Gram.Action.mk (fun (el : 'sequence) _ (bi : 'binding) (rf : 'opt_rec) _ (_loc : Gram.Loc.t) -> (Ast.ExLet (_loc, rf, bi, (mksequence _loc el)) : 'sequence)))); ([ Gram.Skeyword "let"; Gram.Snterm (Gram.Entry.obj (opt_rec : 'opt_rec Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (binding : 'binding Gram.Entry.t)); Gram.Skeyword "in"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (sequence' : 'sequence' Gram.Entry.t)) ], (Gram.Action.mk (fun (k : 'sequence') (e : 'expr) _ (bi : 'binding) (rf : 'opt_rec) _ (_loc : Gram.Loc.t) -> (k (Ast.ExLet (_loc, rf, bi, e)) : 'sequence)))) ]) ])) ()); Gram.extend (binding : 'binding Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Snterm (Gram.Entry.obj (let_binding : 'let_binding Gram.Entry.t)) ], (Gram.Action.mk (fun (b : 'let_binding) (_loc : Gram.Loc.t) -> (b : 'binding)))); ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], (Gram.Action.mk (fun (b2 : 'binding) _ (b1 : 'binding) (_loc : Gram.Loc.t) -> (Ast.BiAnd (_loc, b1, b2) : 'binding)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "anti" as n)), s) -> (Ast.BiAnt (_loc, (mk_anti ~c: "binding" n s)) : 'binding) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"anti\"), _)")); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "anti" as n)), s) -> (Ast.BiEq (_loc, (Ast.PaAnt (_loc, (mk_anti ~c: "patt" n s))), e) : 'binding) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("binding" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"binding\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("binding" | "list" as n)), s) -> (Ast.BiAnt (_loc, (mk_anti ~c: "binding" n s)) : 'binding) | _ -> assert false))) ]) ])) ()); Gram.extend (let_binding : 'let_binding Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (fun_binding : 'fun_binding Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'fun_binding) (p : 'ipatt) (_loc : Gram.Loc.t) -> (Ast.BiEq (_loc, p, e) : 'let_binding)))) ]) ])) ()); Gram.extend (fun_binding : 'fun_binding Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.RightA), [ ([ Gram.Snterm (Gram.Entry.obj (cvalue_binding : 'cvalue_binding Gram.Entry.t)) ], (Gram.Action.mk (fun (bi : 'cvalue_binding) (_loc : Gram.Loc.t) -> (bi : 'fun_binding)))); ([ Gram.Stry (Gram.Snterm (Gram.Entry.obj (labeled_ipatt : 'labeled_ipatt Gram.Entry.t))); Gram.Sself ], (Gram.Action.mk (fun (e : 'fun_binding) (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> (Ast.ExFun (_loc, (Ast.McArr (_loc, p, (Ast.ExNil _loc), e))) : 'fun_binding)))); ([ Gram.Stry (Gram.srules fun_binding [ ([ Gram.Skeyword "("; Gram.Skeyword "type" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (() : 'e__6)))) ]); Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword ")"; Gram.Sself ], (Gram.Action.mk (fun (e : 'fun_binding) _ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.ExFUN (_loc, i, e) : 'fun_binding)))) ]) ])) ()); Gram.extend (match_case : 'match_case Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); Gram.Skeyword "->"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (p : 'ipatt) (_loc : Gram.Loc.t) -> (Ast.McArr (_loc, p, (Ast.ExNil _loc), e) : 'match_case)))); ([ Gram.Skeyword "["; Gram.Slist0sep ((Gram.Snterm (Gram.Entry.obj (match_case0 : 'match_case0 Gram.Entry.t))), (Gram.Skeyword "|")); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (l : 'match_case0 list) _ (_loc : Gram.Loc.t) -> (Ast.mcOr_of_list l : 'match_case)))) ]) ])) ()); Gram.extend (match_case0 : 'match_case0 Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_when_expr : 'opt_when_expr Gram.Entry.t)); Gram.Skeyword "->"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (w : 'opt_when_expr) (p : 'patt_as_patt_opt) (_loc : Gram.Loc.t) -> (Ast.McArr (_loc, p, w, e) : 'match_case0)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"anti\"), _)")); Gram.Skeyword "when"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Skeyword "->"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (w : 'expr) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "anti" as n)), s) -> (Ast.McArr (_loc, (Ast.PaAnt (_loc, (mk_anti ~c: "patt" n s))), w, e) : 'match_case0) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"anti\"), _)")); Gram.Skeyword "->"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "anti" as n)), s) -> (Ast.McArr (_loc, (Ast.PaAnt (_loc, (mk_anti ~c: "patt" n s))), (Ast.ExNil _loc), e) : 'match_case0) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "anti" as n)), s) -> (Ast.McAnt (_loc, (mk_anti ~c: "match_case" n s)) : 'match_case0) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("match_case" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"match_case\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("match_case" | "list" as n)), s) -> (Ast.McAnt (_loc, (mk_anti ~c: "match_case" n s)) : 'match_case0) | _ -> assert false))) ]) ])) ()); Gram.extend (opt_when_expr : 'opt_when_expr Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.ExNil _loc : 'opt_when_expr)))); ([ Gram.Skeyword "when"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (w : 'expr) _ (_loc : Gram.Loc.t) -> (w : 'opt_when_expr)))) ]) ])) ()); Gram.extend (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], (Gram.Action.mk (fun (p : 'patt) (_loc : Gram.Loc.t) -> (p : 'patt_as_patt_opt)))); ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Skeyword "as"; Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], (Gram.Action.mk (fun (p2 : 'patt) _ (p1 : 'patt) (_loc : Gram.Loc.t) -> (Ast.PaAli (_loc, p1, p2) : 'patt_as_patt_opt)))) ]) ])) ()); Gram.extend (label_expr_list : 'label_expr_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (label_expr : 'label_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (b1 : 'label_expr) (_loc : Gram.Loc.t) -> (b1 : 'label_expr_list)))); ([ Gram.Snterm (Gram.Entry.obj (label_expr : 'label_expr Gram.Entry.t)); Gram.Skeyword ";" ], (Gram.Action.mk (fun _ (b1 : 'label_expr) (_loc : Gram.Loc.t) -> (b1 : 'label_expr_list)))); ([ Gram.Snterm (Gram.Entry.obj (label_expr : 'label_expr Gram.Entry.t)); Gram.Skeyword ";"; Gram.Sself ], (Gram.Action.mk (fun (b2 : 'label_expr_list) _ (b1 : 'label_expr) (_loc : Gram.Loc.t) -> (Ast.RbSem (_loc, b1, b2) : 'label_expr_list)))) ]) ])) ()); Gram.extend (label_expr : 'label_expr Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (label_longident : 'label_longident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'label_longident) (_loc : Gram.Loc.t) -> (Ast.RbEq (_loc, i, (Ast.ExId (_loc, (Ast.IdLid (_loc, (lid_of_ident i)))))) : 'label_expr)))); ([ Gram.Snterm (Gram.Entry.obj (label_longident : 'label_longident Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (fun_binding : 'fun_binding Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'fun_binding) (i : 'label_longident) (_loc : Gram.Loc.t) -> (Ast.RbEq (_loc, i, e) : 'label_expr)))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.RbAnt (_loc, (mk_anti ~c: "rec_binding" n s)) : 'label_expr) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"anti\"), _)")); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "anti" as n)), s) -> (Ast.RbEq (_loc, (Ast.IdAnt (_loc, (mk_anti ~c: "ident" n s))), e) : 'label_expr) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "anti" as n)), s) -> (Ast.RbAnt (_loc, (mk_anti ~c: "rec_binding" n s)) : 'label_expr) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("rec_binding", _) -> true | _ -> false), "ANTIQUOT (\"rec_binding\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("rec_binding" as n)), s) -> (Ast.RbAnt (_loc, (mk_anti ~c: "rec_binding" n s)) : 'label_expr) | _ -> assert false))) ]) ])) ()); Gram.extend (fun_def : 'fun_def Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stry (Gram.Snterm (Gram.Entry.obj (labeled_ipatt : 'labeled_ipatt Gram.Entry.t))); Gram.Snterm (Gram.Entry.obj (fun_def_cont : 'fun_def_cont Gram.Entry.t)) ], (Gram.Action.mk (fun ((w, e) : 'fun_def_cont) (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> (Ast.ExFun (_loc, (Ast.McArr (_loc, p, w, e))) : 'fun_def)))); ([ Gram.Stry (Gram.srules fun_def [ ([ Gram.Skeyword "("; Gram.Skeyword "type" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (() : 'e__7)))) ]); Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword ")"; Gram.Snterm (Gram.Entry.obj (fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'fun_def_cont_no_when) _ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.ExFUN (_loc, i, e) : 'fun_def)))) ]) ])) ()); Gram.extend (fun_def_cont : 'fun_def_cont Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.RightA), [ ([ Gram.Skeyword "->"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> (((Ast.ExNil _loc), e) : 'fun_def_cont)))); ([ Gram.Skeyword "when"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Skeyword "->"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (w : 'expr) _ (_loc : Gram.Loc.t) -> ((w, e) : 'fun_def_cont)))); ([ Gram.Stry (Gram.Snterm (Gram.Entry.obj (labeled_ipatt : 'labeled_ipatt Gram.Entry.t))); Gram.Sself ], (Gram.Action.mk (fun ((w, e) : 'fun_def_cont) (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> (((Ast.ExNil _loc), (Ast.ExFun (_loc, (Ast.McArr (_loc, p, w, e))))) : 'fun_def_cont)))); ([ Gram.Stry (Gram.srules fun_def_cont [ ([ Gram.Skeyword "("; Gram.Skeyword "type" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (() : 'e__8)))) ]); Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword ")"; Gram.Snterm (Gram.Entry.obj (fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'fun_def_cont_no_when) _ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (((Ast.ExNil _loc), (Ast.ExFUN (_loc, i, e))) : 'fun_def_cont)))) ]) ])) ()); Gram.extend (fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.RightA), [ ([ Gram.Skeyword "->"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> (e : 'fun_def_cont_no_when)))); ([ Gram.Stry (Gram.Snterm (Gram.Entry.obj (labeled_ipatt : 'labeled_ipatt Gram.Entry.t))); Gram.Snterm (Gram.Entry.obj (fun_def_cont : 'fun_def_cont Gram.Entry.t)) ], (Gram.Action.mk (fun ((w, e) : 'fun_def_cont) (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> (Ast.ExFun (_loc, (Ast.McArr (_loc, p, w, e))) : 'fun_def_cont_no_when)))); ([ Gram.Stry (Gram.srules fun_def_cont_no_when [ ([ Gram.Skeyword "("; Gram.Skeyword "type" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (() : 'e__9)))) ]); Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword ")"; Gram.Sself ], (Gram.Action.mk (fun (e : 'fun_def_cont_no_when) _ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.ExFUN (_loc, i, e) : 'fun_def_cont_no_when)))) ]) ])) ()); Gram.extend (patt : 'patt Gram.Entry.t) ((fun () -> (None, [ ((Some "|"), (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], (Gram.Action.mk (fun (p2 : 'patt) _ (p1 : 'patt) (_loc : Gram.Loc.t) -> (Ast.PaOrp (_loc, p1, p2) : 'patt)))) ]); ((Some ".."), (Some Camlp4.Sig.Grammar.NonA), [ ([ Gram.Sself; Gram.Skeyword ".."; Gram.Sself ], (Gram.Action.mk (fun (p2 : 'patt) _ (p1 : 'patt) (_loc : Gram.Loc.t) -> (Ast.PaRng (_loc, p1, p2) : 'patt)))) ]); ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Skeyword "lazy"; Gram.Sself ], (Gram.Action.mk (fun (p : 'patt) _ (_loc : Gram.Loc.t) -> (Ast.PaLaz (_loc, p) : 'patt)))); ([ Gram.Sself; Gram.Sself ], (Gram.Action.mk (fun (p2 : 'patt) (p1 : 'patt) (_loc : Gram.Loc.t) -> (Ast.PaApp (_loc, p1, p2) : 'patt)))) ]); ((Some "simple"), None, [ ([ Gram.Skeyword "?"; Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (patt_tcon : 'patt_tcon Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (e : 'expr) _ (p : 'patt_tcon) _ _ (_loc : Gram.Loc.t) -> (Ast.PaOlbi (_loc, "", p, e) : 'patt)))); ([ Gram.Skeyword "?"; Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (patt_tcon : 'patt_tcon Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (p : 'patt_tcon) _ _ (_loc : Gram.Loc.t) -> (Ast.PaOlb (_loc, "", p) : 'patt)))); ([ Gram.Skeyword "?"; Gram.Stoken (((function | ANTIQUOT (("" | "lid"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"lid\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "lid" as n)), i) -> (Ast.PaOlb (_loc, (mk_anti n i), (Ast.PaNil _loc)) : 'patt) | _ -> assert false))); ([ Gram.Skeyword "?"; Gram.Stoken (((function | LIDENT _ -> true | _ -> false), "LIDENT _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | LIDENT i -> (Ast.PaOlb (_loc, i, (Ast.PaNil _loc)) : 'patt) | _ -> assert false))); ([ Gram.Skeyword "?"; Gram.Stoken (((function | ANTIQUOT (("" | "lid"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"lid\"), _)")); Gram.Skeyword ":"; Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (patt_tcon : 'patt_tcon Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (eq_expr : 'eq_expr Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (f : 'eq_expr) (p : 'patt_tcon) _ _ (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "lid" as n)), i) -> (f (mk_anti n i) p : 'patt) | _ -> assert false))); ([ Gram.Stoken (((function | OPTLABEL _ -> true | _ -> false), "OPTLABEL _")); Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (patt_tcon : 'patt_tcon Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (eq_expr : 'eq_expr Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (f : 'eq_expr) (p : 'patt_tcon) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | OPTLABEL i -> (f i p : 'patt) | _ -> assert false))); ([ Gram.Skeyword "~"; Gram.Stoken (((function | LIDENT _ -> true | _ -> false), "LIDENT _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | LIDENT i -> (Ast.PaLab (_loc, i, (Ast.PaNil _loc)) : 'patt) | _ -> assert false))); ([ Gram.Skeyword "~"; Gram.Stoken (((function | ANTIQUOT (("" | "lid"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"lid\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "lid" as n)), i) -> (Ast.PaLab (_loc, (mk_anti n i), (Ast.PaNil _loc)) : 'patt) | _ -> assert false))); ([ Gram.Skeyword "~"; Gram.Stoken (((function | ANTIQUOT (("" | "lid"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"lid\"), _)")); Gram.Skeyword ":"; Gram.Sself ], (Gram.Action.mk (fun (p : 'patt) _ (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "lid" as n)), i) -> (Ast.PaLab (_loc, (mk_anti n i), p) : 'patt) | _ -> assert false))); ([ Gram.Stoken (((function | LABEL _ -> true | _ -> false), "LABEL _")); Gram.Sself ], (Gram.Action.mk (fun (p : 'patt) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | LABEL i -> (Ast.PaLab (_loc, i, p) : 'patt) | _ -> assert false))); ([ Gram.Skeyword "#"; Gram.Snterm (Gram.Entry.obj (type_longident : 'type_longident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'type_longident) _ (_loc : Gram.Loc.t) -> (Ast.PaTyp (_loc, i) : 'patt)))); ([ Gram.Skeyword "`"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> (Ast.PaVrn (_loc, s) : 'patt)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.patt_tag : 'patt) | _ -> assert false))); ([ Gram.Skeyword "_" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.PaAny _loc : 'patt)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ","; Gram.Snterm (Gram.Entry.obj (comma_patt : 'comma_patt Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (pl : 'comma_patt) _ (p : 'patt) _ (_loc : Gram.Loc.t) -> (Ast.PaTup (_loc, (Ast.PaCom (_loc, p, pl))) : 'patt)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword "as"; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (p2 : 'patt) _ (p : 'patt) _ (_loc : Gram.Loc.t) -> (Ast.PaAli (_loc, p, p2) : 'patt)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (t : 'ctyp) _ (p : 'patt) _ (_loc : Gram.Loc.t) -> (Ast.PaTyc (_loc, p, t) : 'patt)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) -> (p : 'patt)))); ([ Gram.Skeyword "("; Gram.Skeyword "module"; Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (package_type : 'package_type Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)), (Ast.TyPkg (_loc, pt))) : 'patt)))); ([ Gram.Skeyword "("; Gram.Skeyword "module"; Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> (Ast.PaMod (_loc, m) : 'patt)))); ([ Gram.Skeyword "("; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (Ast.PaId (_loc, (Ast.IdUid (_loc, "()"))) : 'patt)))); ([ Gram.Skeyword "{"; Gram.Snterm (Gram.Entry.obj (label_patt_list : 'label_patt_list Gram.Entry.t)); Gram.Skeyword "}" ], (Gram.Action.mk (fun _ (pl : 'label_patt_list) _ (_loc : Gram.Loc.t) -> (Ast.PaRec (_loc, pl) : 'patt)))); ([ Gram.Skeyword "[|"; Gram.Snterm (Gram.Entry.obj (sem_patt : 'sem_patt Gram.Entry.t)); Gram.Skeyword "|]" ], (Gram.Action.mk (fun _ (pl : 'sem_patt) _ (_loc : Gram.Loc.t) -> (Ast.PaArr (_loc, pl) : 'patt)))); ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (Ast.PaArr (_loc, (Ast.PaNil _loc)) : 'patt)))); ([ Gram.Skeyword "["; Gram.Snterm (Gram.Entry.obj (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t)); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (mk_list : 'sem_patt_for_list) _ (_loc : Gram.Loc.t) -> (mk_list (Ast.PaId (_loc, (Ast.IdUid (_loc, "[]")))) : 'patt)))); ([ Gram.Skeyword "["; Gram.Snterm (Gram.Entry.obj (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t)); Gram.Skeyword "::"; Gram.Sself; Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (last : 'patt) _ (mk_list : 'sem_patt_for_list) _ (_loc : Gram.Loc.t) -> (mk_list last : 'patt)))); ([ Gram.Skeyword "["; Gram.Skeyword "]" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (Ast.PaId (_loc, (Ast.IdUid (_loc, "[]"))) : 'patt)))); ([ Gram.Skeyword "-"; Gram.Snterm (Gram.Entry.obj (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_FLOAT) _ (_loc : Gram.Loc.t) -> (Ast.PaFlo (_loc, (neg_string s)) : 'patt)))); ([ Gram.Skeyword "-"; Gram.Snterm (Gram.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_NATIVEINT) _ (_loc : Gram.Loc.t) -> (Ast.PaNativeInt (_loc, (neg_string s)) : 'patt)))); ([ Gram.Skeyword "-"; Gram.Snterm (Gram.Entry.obj (a_INT64 : 'a_INT64 Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_INT64) _ (_loc : Gram.Loc.t) -> (Ast.PaInt64 (_loc, (neg_string s)) : 'patt)))); ([ Gram.Skeyword "-"; Gram.Snterm (Gram.Entry.obj (a_INT32 : 'a_INT32 Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_INT32) _ (_loc : Gram.Loc.t) -> (Ast.PaInt32 (_loc, (neg_string s)) : 'patt)))); ([ Gram.Skeyword "-"; Gram.Snterm (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_INT) _ (_loc : Gram.Loc.t) -> (Ast.PaInt (_loc, (neg_string s)) : 'patt)))); ([ Gram.Snterm (Gram.Entry.obj (a_CHAR : 'a_CHAR Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_CHAR) (_loc : Gram.Loc.t) -> (Ast.PaChr (_loc, s) : 'patt)))); ([ Gram.Snterm (Gram.Entry.obj (a_STRING : 'a_STRING Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_STRING) (_loc : Gram.Loc.t) -> (Ast.PaStr (_loc, s) : 'patt)))); ([ Gram.Snterm (Gram.Entry.obj (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_FLOAT) (_loc : Gram.Loc.t) -> (Ast.PaFlo (_loc, s) : 'patt)))); ([ Gram.Snterm (Gram.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_NATIVEINT) (_loc : Gram.Loc.t) -> (Ast.PaNativeInt (_loc, s) : 'patt)))); ([ Gram.Snterm (Gram.Entry.obj (a_INT64 : 'a_INT64 Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_INT64) (_loc : Gram.Loc.t) -> (Ast.PaInt64 (_loc, s) : 'patt)))); ([ Gram.Snterm (Gram.Entry.obj (a_INT32 : 'a_INT32 Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_INT32) (_loc : Gram.Loc.t) -> (Ast.PaInt32 (_loc, s) : 'patt)))); ([ Gram.Snterm (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_INT) (_loc : Gram.Loc.t) -> (Ast.PaInt (_loc, s) : 'patt)))); ([ Gram.Snterm (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'ident) (_loc : Gram.Loc.t) -> (Ast.PaId (_loc, i) : 'patt)))); ([ Gram.Stoken (((function | ANTIQUOT ("`bool", _) -> true | _ -> false), "ANTIQUOT (\"`bool\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("`bool" as n)), s) -> (Ast.PaId (_loc, (Ast.IdAnt (_loc, (mk_anti n s)))) : 'patt) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("tup", _) -> true | _ -> false), "ANTIQUOT (\"tup\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("tup" as n)), s) -> (Ast.PaTup (_loc, (Ast.PaAnt (_loc, (mk_anti ~c: "patt" n s)))) : 'patt) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "pat" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "pat" | "anti" as n)), s) -> (Ast.PaAnt (_loc, (mk_anti ~c: "patt" n s)) : 'patt) | _ -> assert false))) ]) ])) ()); Gram.extend (comma_patt : 'comma_patt Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], (Gram.Action.mk (fun (p : 'patt) (_loc : Gram.Loc.t) -> (p : 'comma_patt)))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.PaAnt (_loc, (mk_anti ~c: "patt," n s)) : 'comma_patt) | _ -> assert false))); ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], (Gram.Action.mk (fun (p2 : 'comma_patt) _ (p1 : 'comma_patt) (_loc : Gram.Loc.t) -> (Ast.PaCom (_loc, p1, p2) : 'comma_patt)))) ]) ])) ()); Gram.extend (sem_patt : 'sem_patt Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], (Gram.Action.mk (fun (p : 'patt) (_loc : Gram.Loc.t) -> (p : 'sem_patt)))); ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Skeyword ";" ], (Gram.Action.mk (fun _ (p : 'patt) (_loc : Gram.Loc.t) -> (p : 'sem_patt)))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.PaAnt (_loc, (mk_anti ~c: "patt;" n s)) : 'sem_patt) | _ -> assert false))); ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Skeyword ";"; Gram.Sself ], (Gram.Action.mk (fun (p2 : 'sem_patt) _ (p1 : 'patt) (_loc : Gram.Loc.t) -> (Ast.PaSem (_loc, p1, p2) : 'sem_patt)))) ]) ])) ()); Gram.extend (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], (Gram.Action.mk (fun (p : 'patt) (_loc : Gram.Loc.t) -> (fun acc -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, "::")))), p)), acc) : 'sem_patt_for_list)))); ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Skeyword ";" ], (Gram.Action.mk (fun _ (p : 'patt) (_loc : Gram.Loc.t) -> (fun acc -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, "::")))), p)), acc) : 'sem_patt_for_list)))); ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Skeyword ";"; Gram.Sself ], (Gram.Action.mk (fun (pl : 'sem_patt_for_list) _ (p : 'patt) (_loc : Gram.Loc.t) -> (fun acc -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, "::")))), p)), (pl acc)) : 'sem_patt_for_list)))) ]) ])) ()); Gram.extend (label_patt_list : 'label_patt_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (label_patt : 'label_patt Gram.Entry.t)) ], (Gram.Action.mk (fun (p1 : 'label_patt) (_loc : Gram.Loc.t) -> (p1 : 'label_patt_list)))); ([ Gram.Snterm (Gram.Entry.obj (label_patt : 'label_patt Gram.Entry.t)); Gram.Skeyword ";" ], (Gram.Action.mk (fun _ (p1 : 'label_patt) (_loc : Gram.Loc.t) -> (p1 : 'label_patt_list)))); ([ Gram.Snterm (Gram.Entry.obj (label_patt : 'label_patt Gram.Entry.t)); Gram.Skeyword ";"; Gram.Skeyword "_"; Gram.Skeyword ";" ], (Gram.Action.mk (fun _ _ _ (p1 : 'label_patt) (_loc : Gram.Loc.t) -> (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : 'label_patt_list)))); ([ Gram.Snterm (Gram.Entry.obj (label_patt : 'label_patt Gram.Entry.t)); Gram.Skeyword ";"; Gram.Skeyword "_" ], (Gram.Action.mk (fun _ _ (p1 : 'label_patt) (_loc : Gram.Loc.t) -> (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : 'label_patt_list)))); ([ Gram.Snterm (Gram.Entry.obj (label_patt : 'label_patt Gram.Entry.t)); Gram.Skeyword ";"; Gram.Sself ], (Gram.Action.mk (fun (p2 : 'label_patt_list) _ (p1 : 'label_patt) (_loc : Gram.Loc.t) -> (Ast.PaSem (_loc, p1, p2) : 'label_patt_list)))) ]) ])) ()); Gram.extend (label_patt : 'label_patt Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (label_longident : 'label_longident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'label_longident) (_loc : Gram.Loc.t) -> (Ast.PaEq (_loc, i, (Ast.PaId (_loc, (Ast.IdLid (_loc, (lid_of_ident i)))))) : 'label_patt)))); ([ Gram.Snterm (Gram.Entry.obj (label_longident : 'label_longident Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], (Gram.Action.mk (fun (p : 'patt) _ (i : 'label_longident) (_loc : Gram.Loc.t) -> (Ast.PaEq (_loc, i, p) : 'label_patt)))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.PaAnt (_loc, (mk_anti ~c: "patt;" n s)) : 'label_patt) | _ -> assert false))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.patt_tag : 'label_patt) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "pat" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "pat" | "anti" as n)), s) -> (Ast.PaAnt (_loc, (mk_anti ~c: "patt" n s)) : 'label_patt) | _ -> assert false))) ]) ])) ()); Gram.extend (ipatt : 'ipatt Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "_" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.PaAny _loc : 'ipatt)))); ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_LIDENT) (_loc : Gram.Loc.t) -> (Ast.PaId (_loc, (Ast.IdLid (_loc, s))) : 'ipatt)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ","; Gram.Snterm (Gram.Entry.obj (comma_ipatt : 'comma_ipatt Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (pl : 'comma_ipatt) _ (p : 'ipatt) _ (_loc : Gram.Loc.t) -> (Ast.PaTup (_loc, (Ast.PaCom (_loc, p, pl))) : 'ipatt)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword "as"; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ (_loc : Gram.Loc.t) -> (Ast.PaAli (_loc, p, p2) : 'ipatt)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (t : 'ctyp) _ (p : 'ipatt) _ (_loc : Gram.Loc.t) -> (Ast.PaTyc (_loc, p, t) : 'ipatt)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (p : 'ipatt) _ (_loc : Gram.Loc.t) -> (p : 'ipatt)))); ([ Gram.Skeyword "("; Gram.Skeyword "module"; Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (package_type : 'package_type Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)), (Ast.TyPkg (_loc, pt))) : 'ipatt)))); ([ Gram.Skeyword "("; Gram.Skeyword "module"; Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> (Ast.PaMod (_loc, m) : 'ipatt)))); ([ Gram.Skeyword "("; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (Ast.PaId (_loc, (Ast.IdUid (_loc, "()"))) : 'ipatt)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.patt_tag : 'ipatt) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("tup", _) -> true | _ -> false), "ANTIQUOT (\"tup\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("tup" as n)), s) -> (Ast.PaTup (_loc, (Ast.PaAnt (_loc, (mk_anti ~c: "patt" n s)))) : 'ipatt) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "pat" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "pat" | "anti" as n)), s) -> (Ast.PaAnt (_loc, (mk_anti ~c: "patt" n s)) : 'ipatt) | _ -> assert false))); ([ Gram.Skeyword "{"; Gram.Snterm (Gram.Entry.obj (label_ipatt_list : 'label_ipatt_list Gram.Entry.t)); Gram.Skeyword "}" ], (Gram.Action.mk (fun _ (pl : 'label_ipatt_list) _ (_loc : Gram.Loc.t) -> (Ast.PaRec (_loc, pl) : 'ipatt)))) ]) ])) ()); Gram.extend (labeled_ipatt : 'labeled_ipatt Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], (Gram.Action.mk (fun (p : 'ipatt) (_loc : Gram.Loc.t) -> (p : 'labeled_ipatt)))) ]) ])) ()); Gram.extend (comma_ipatt : 'comma_ipatt Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Snterm (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], (Gram.Action.mk (fun (p : 'ipatt) (_loc : Gram.Loc.t) -> (p : 'comma_ipatt)))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.PaAnt (_loc, (mk_anti ~c: "patt," n s)) : 'comma_ipatt) | _ -> assert false))); ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], (Gram.Action.mk (fun (p2 : 'comma_ipatt) _ (p1 : 'comma_ipatt) (_loc : Gram.Loc.t) -> (Ast.PaCom (_loc, p1, p2) : 'comma_ipatt)))) ]) ])) ()); Gram.extend (label_ipatt_list : 'label_ipatt_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (label_ipatt : 'label_ipatt Gram.Entry.t)) ], (Gram.Action.mk (fun (p1 : 'label_ipatt) (_loc : Gram.Loc.t) -> (p1 : 'label_ipatt_list)))); ([ Gram.Snterm (Gram.Entry.obj (label_ipatt : 'label_ipatt Gram.Entry.t)); Gram.Skeyword ";" ], (Gram.Action.mk (fun _ (p1 : 'label_ipatt) (_loc : Gram.Loc.t) -> (p1 : 'label_ipatt_list)))); ([ Gram.Snterm (Gram.Entry.obj (label_ipatt : 'label_ipatt Gram.Entry.t)); Gram.Skeyword ";"; Gram.Skeyword "_"; Gram.Skeyword ";" ], (Gram.Action.mk (fun _ _ _ (p1 : 'label_ipatt) (_loc : Gram.Loc.t) -> (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : 'label_ipatt_list)))); ([ Gram.Snterm (Gram.Entry.obj (label_ipatt : 'label_ipatt Gram.Entry.t)); Gram.Skeyword ";"; Gram.Skeyword "_" ], (Gram.Action.mk (fun _ _ (p1 : 'label_ipatt) (_loc : Gram.Loc.t) -> (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : 'label_ipatt_list)))); ([ Gram.Snterm (Gram.Entry.obj (label_ipatt : 'label_ipatt Gram.Entry.t)); Gram.Skeyword ";"; Gram.Sself ], (Gram.Action.mk (fun (p2 : 'label_ipatt_list) _ (p1 : 'label_ipatt) (_loc : Gram.Loc.t) -> (Ast.PaSem (_loc, p1, p2) : 'label_ipatt_list)))) ]) ])) ()); Gram.extend (label_ipatt : 'label_ipatt Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (label_longident : 'label_longident Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], (Gram.Action.mk (fun (p : 'ipatt) _ (i : 'label_longident) (_loc : Gram.Loc.t) -> (Ast.PaEq (_loc, i, p) : 'label_ipatt)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.patt_tag : 'label_ipatt) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.PaAnt (_loc, (mk_anti ~c: "patt;" n s)) : 'label_ipatt) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "pat" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "pat" | "anti" as n)), s) -> (Ast.PaAnt (_loc, (mk_anti ~c: "patt" n s)) : 'label_ipatt) | _ -> assert false))) ]) ])) ()); Gram.extend (type_declaration : 'type_declaration Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Snterm (Gram.Entry.obj (type_ident_and_parameters : 'type_ident_and_parameters Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t)); Gram.Slist0 (Gram.Snterm (Gram.Entry.obj (constrain : 'constrain Gram.Entry.t))) ], (Gram.Action.mk (fun (cl : 'constrain list) (tk : 'opt_eq_ctyp) ((n, tpl) : 'type_ident_and_parameters) (_loc : Gram.Loc.t) -> (Ast.TyDcl (_loc, n, tpl, tk, cl) : 'type_declaration)))); ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'type_declaration) _ (t1 : 'type_declaration) (_loc : Gram.Loc.t) -> (Ast.TyAnd (_loc, t1, t2) : 'type_declaration)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.ctyp_tag : 'type_declaration) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctypand" n s)) : 'type_declaration) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "typ" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" | "anti" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp" n s)) : 'type_declaration) | _ -> assert false))) ]) ])) ()); Gram.extend (constrain : 'constrain Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "constraint"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (_loc : Gram.Loc.t) -> ((t1, t2) : 'constrain)))) ]) ])) ()); Gram.extend (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.TyNil _loc : 'opt_eq_ctyp)))); ([ Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (type_kind : 'type_kind Gram.Entry.t)) ], (Gram.Action.mk (fun (tk : 'type_kind) _ (_loc : Gram.Loc.t) -> (tk : 'opt_eq_ctyp)))) ]) ])) ()); Gram.extend (type_kind : 'type_kind Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> (t : 'type_kind)))) ]) ])) ()); Gram.extend (type_ident_and_parameters : 'type_ident_and_parameters Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Slist0 (Gram.Snterm (Gram.Entry.obj (optional_type_parameter : 'optional_type_parameter Gram.Entry.t))) ], (Gram.Action.mk (fun (tpl : 'optional_type_parameter list) (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> ((i, tpl) : 'type_ident_and_parameters)))) ]) ])) ()); Gram.extend (type_longident_and_parameters : 'type_longident_and_parameters Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (type_longident : 'type_longident Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (type_parameters : 'type_parameters Gram.Entry.t)) ], (Gram.Action.mk (fun (tpl : 'type_parameters) (i : 'type_longident) (_loc : Gram.Loc.t) -> (tpl (Ast.TyId (_loc, i)) : 'type_longident_and_parameters)))) ]) ])) ()); Gram.extend (type_parameters : 'type_parameters Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (fun t -> t : 'type_parameters)))); ([ Gram.Snterm (Gram.Entry.obj (type_parameter : 'type_parameter Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'type_parameter) (_loc : Gram.Loc.t) -> (fun acc -> Ast.TyApp (_loc, acc, t) : 'type_parameters)))); ([ Gram.Snterm (Gram.Entry.obj (type_parameter : 'type_parameter Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (t2 : 'type_parameters) (t1 : 'type_parameter) (_loc : Gram.Loc.t) -> (fun acc -> t2 (Ast.TyApp (_loc, acc, t1)) : 'type_parameters)))) ]) ])) ()); Gram.extend (type_parameter : 'type_parameter Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "-"; Gram.Skeyword "'"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> (Ast.TyQuM (_loc, i) : 'type_parameter)))); ([ Gram.Skeyword "+"; Gram.Skeyword "'"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> (Ast.TyQuP (_loc, i) : 'type_parameter)))); ([ Gram.Skeyword "'"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> (Ast.TyQuo (_loc, i) : 'type_parameter)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.ctyp_tag : 'type_parameter) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "typ" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" | "anti" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti n s)) : 'type_parameter) | _ -> assert false))) ]) ])) ()); Gram.extend (optional_type_parameter : 'optional_type_parameter Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "_" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.TyAny _loc : 'optional_type_parameter)))); ([ Gram.Skeyword "-"; Gram.Skeyword "_" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (Ast.TyAnM _loc : 'optional_type_parameter)))); ([ Gram.Skeyword "+"; Gram.Skeyword "_" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (Ast.TyAnP _loc : 'optional_type_parameter)))); ([ Gram.Skeyword "-"; Gram.Skeyword "'"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> (Ast.TyQuM (_loc, i) : 'optional_type_parameter)))); ([ Gram.Skeyword "+"; Gram.Skeyword "'"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> (Ast.TyQuP (_loc, i) : 'optional_type_parameter)))); ([ Gram.Skeyword "'"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> (Ast.TyQuo (_loc, i) : 'optional_type_parameter)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.ctyp_tag : 'optional_type_parameter) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "typ" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" | "anti" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti n s)) : 'optional_type_parameter) | _ -> assert false))) ]) ])) ()); Gram.extend (ctyp : 'ctyp Gram.Entry.t) ((fun () -> (None, [ ((Some "=="), (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Sself; Gram.Skeyword "=="; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (_loc : Gram.Loc.t) -> (Ast.TyMan (_loc, t1, t2) : 'ctyp)))) ]); ((Some "private"), (Some Camlp4.Sig.Grammar.NonA), [ ([ Gram.Skeyword "private"; Gram.Snterml ((Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)), "alias") ], (Gram.Action.mk (fun (t : 'ctyp) _ (_loc : Gram.Loc.t) -> (Ast.TyPrv (_loc, t) : 'ctyp)))) ]); ((Some "alias"), (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Sself; Gram.Skeyword "as"; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (_loc : Gram.Loc.t) -> (Ast.TyAli (_loc, t1, t2) : 'ctyp)))) ]); ((Some "forall"), (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Skeyword "!"; Gram.Snterm (Gram.Entry.obj (typevars : 'typevars Gram.Entry.t)); Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'ctyp) _ (t1 : 'typevars) _ (_loc : Gram.Loc.t) -> (Ast.TyPol (_loc, t1, t2) : 'ctyp)))) ]); ((Some "arrow"), (Some Camlp4.Sig.Grammar.RightA), [ ([ Gram.Sself; Gram.Skeyword "->"; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (_loc : Gram.Loc.t) -> (Ast.TyArr (_loc, t1, t2) : 'ctyp)))) ]); ((Some "label"), (Some Camlp4.Sig.Grammar.NonA), [ ([ Gram.Snterm (Gram.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (t : 'ctyp) (i : 'a_OPTLABEL) (_loc : Gram.Loc.t) -> (Ast.TyOlb (_loc, i, t) : 'ctyp)))); ([ Gram.Skeyword "?"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Sself ], (Gram.Action.mk (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.TyOlb (_loc, i, t) : 'ctyp)))); ([ Gram.Snterm (Gram.Entry.obj (a_LABEL : 'a_LABEL Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (t : 'ctyp) (i : 'a_LABEL) (_loc : Gram.Loc.t) -> (Ast.TyLab (_loc, i, t) : 'ctyp)))); ([ Gram.Skeyword "~"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Sself ], (Gram.Action.mk (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.TyLab (_loc, i, t) : 'ctyp)))) ]); ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Sself; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'ctyp) (t1 : 'ctyp) (_loc : Gram.Loc.t) -> (let t = Ast.TyApp (_loc, t1, t2) in try Ast.TyId (_loc, (Ast.ident_of_ctyp t)) with | Invalid_argument _ -> t : 'ctyp)))) ]); ((Some "."), (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (_loc : Gram.Loc.t) -> (try Ast.TyId (_loc, (Ast.IdAcc (_loc, (Ast.ident_of_ctyp t1), (Ast.ident_of_ctyp t2)))) with | Invalid_argument s -> raise (Stream.Error s) : 'ctyp)))) ]); ((Some "simple"), None, [ ([ Gram.Skeyword "("; Gram.Skeyword "module"; Gram.Snterm (Gram.Entry.obj (package_type : 'package_type Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (p : 'package_type) _ _ (_loc : Gram.Loc.t) -> (Ast.TyPkg (_loc, p) : 'ctyp)))); ([ Gram.Skeyword "<"; Gram.Snterm (Gram.Entry.obj (opt_meth_list : 'opt_meth_list Gram.Entry.t)); Gram.Skeyword ">" ], (Gram.Action.mk (fun _ (t : 'opt_meth_list) _ (_loc : Gram.Loc.t) -> (t : 'ctyp)))); ([ Gram.Skeyword "#"; Gram.Snterm (Gram.Entry.obj (class_longident : 'class_longident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'class_longident) _ (_loc : Gram.Loc.t) -> (Ast.TyCls (_loc, i) : 'ctyp)))); ([ Gram.Skeyword "{"; Gram.Snterm (Gram.Entry.obj (label_declaration_list : 'label_declaration_list Gram.Entry.t)); Gram.Skeyword "}" ], (Gram.Action.mk (fun _ (t : 'label_declaration_list) _ (_loc : Gram.Loc.t) -> (Ast.TyRec (_loc, t) : 'ctyp)))); ([ Gram.Skeyword "[<"; Gram.Snterm (Gram.Entry.obj (row_field : 'row_field Gram.Entry.t)); Gram.Skeyword ">"; Gram.Snterm (Gram.Entry.obj (name_tags : 'name_tags Gram.Entry.t)); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (ntl : 'name_tags) _ (rfl : 'row_field) _ (_loc : Gram.Loc.t) -> (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp)))); ([ Gram.Skeyword "[<"; Gram.Snterm (Gram.Entry.obj (row_field : 'row_field Gram.Entry.t)); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (rfl : 'row_field) _ (_loc : Gram.Loc.t) -> (Ast.TyVrnInf (_loc, rfl) : 'ctyp)))); ([ Gram.Skeyword "["; Gram.Skeyword "<"; Gram.Snterm (Gram.Entry.obj (row_field : 'row_field Gram.Entry.t)); Gram.Skeyword ">"; Gram.Snterm (Gram.Entry.obj (name_tags : 'name_tags Gram.Entry.t)); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (ntl : 'name_tags) _ (rfl : 'row_field) _ _ (_loc : Gram.Loc.t) -> (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp)))); ([ Gram.Skeyword "["; Gram.Skeyword "<"; Gram.Snterm (Gram.Entry.obj (row_field : 'row_field Gram.Entry.t)); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (rfl : 'row_field) _ _ (_loc : Gram.Loc.t) -> (Ast.TyVrnInf (_loc, rfl) : 'ctyp)))); ([ Gram.Skeyword "["; Gram.Skeyword ">"; Gram.Snterm (Gram.Entry.obj (row_field : 'row_field Gram.Entry.t)); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (rfl : 'row_field) _ _ (_loc : Gram.Loc.t) -> (Ast.TyVrnSup (_loc, rfl) : 'ctyp)))); ([ Gram.Skeyword "["; Gram.Skeyword ">"; Gram.Skeyword "]" ], (Gram.Action.mk (fun _ _ _ (_loc : Gram.Loc.t) -> (Ast.TyVrnSup (_loc, (Ast.TyNil _loc)) : 'ctyp)))); ([ Gram.Skeyword "["; Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (row_field : 'row_field Gram.Entry.t)); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (rfl : 'row_field) _ _ (_loc : Gram.Loc.t) -> (Ast.TyVrnEq (_loc, rfl) : 'ctyp)))); ([ Gram.Skeyword "["; Gram.Snterm (Gram.Entry.obj (constructor_declarations : 'constructor_declarations Gram.Entry.t)); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (t : 'constructor_declarations) _ (_loc : Gram.Loc.t) -> (Ast.TySum (_loc, t) : 'ctyp)))); ([ Gram.Skeyword "["; Gram.Skeyword "]" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (Ast.TySum (_loc, (Ast.TyNil _loc)) : 'ctyp)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (t : 'ctyp) _ (_loc : Gram.Loc.t) -> (t : 'ctyp)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword "*"; Gram.Snterm (Gram.Entry.obj (star_ctyp : 'star_ctyp Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (tl : 'star_ctyp) _ (t : 'ctyp) _ (_loc : Gram.Loc.t) -> (Ast.TyTup (_loc, (Ast.TySta (_loc, t, tl))) : 'ctyp)))); ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.TyId (_loc, (Ast.IdUid (_loc, i))) : 'ctyp)))); ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> (Ast.TyId (_loc, (Ast.IdLid (_loc, i))) : 'ctyp)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.ctyp_tag : 'ctyp) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("id", _) -> true | _ -> false), "ANTIQUOT (\"id\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("id" as n)), s) -> (Ast.TyId (_loc, (Ast.IdAnt (_loc, (mk_anti ~c: "ident" n s)))) : 'ctyp) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("tup", _) -> true | _ -> false), "ANTIQUOT (\"tup\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("tup" as n)), s) -> (Ast.TyTup (_loc, (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp" n s)))) : 'ctyp) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "typ" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" | "anti" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp" n s)) : 'ctyp) | _ -> assert false))); ([ Gram.Skeyword "_" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.TyAny _loc : 'ctyp)))); ([ Gram.Skeyword "'"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> (Ast.TyQuo (_loc, i) : 'ctyp)))) ]) ])) ()); Gram.extend (star_ctyp : 'star_ctyp Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> (t : 'star_ctyp)))); ([ Gram.Sself; Gram.Skeyword "*"; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'star_ctyp) _ (t1 : 'star_ctyp) (_loc : Gram.Loc.t) -> (Ast.TySta (_loc, t1, t2) : 'star_ctyp)))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp*" n s)) : 'star_ctyp) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "typ"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp" n s)) : 'star_ctyp) | _ -> assert false))) ]) ])) ()); Gram.extend (constructor_declarations : 'constructor_declarations Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.TyId (_loc, (Ast.IdUid (_loc, s))) : 'constructor_declarations)))); ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'ctyp) _ (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> (let (tl, rt) = generalized_type_of_type t in Ast.TyCol (_loc, (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), (Ast.TyArr (_loc, (Ast.tyAnd_of_list tl), rt))) : 'constructor_declarations)))); ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword "of"; Gram.Snterm (Gram.Entry.obj (constructor_arg_list : 'constructor_arg_list Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'constructor_arg_list) _ (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.TyOf (_loc, (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), t) : 'constructor_declarations)))); ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'constructor_declarations) _ (t1 : 'constructor_declarations) (_loc : Gram.Loc.t) -> (Ast.TyOr (_loc, t1, t2) : 'constructor_declarations)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.ctyp_tag : 'constructor_declarations) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp|" n s)) : 'constructor_declarations) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "typ"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp" n s)) : 'constructor_declarations) | _ -> assert false))) ]) ])) ()); Gram.extend (constructor_declaration : 'constructor_declaration Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.TyId (_loc, (Ast.IdUid (_loc, s))) : 'constructor_declaration)))); ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword "of"; Gram.Snterm (Gram.Entry.obj (constructor_arg_list : 'constructor_arg_list Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'constructor_arg_list) _ (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.TyOf (_loc, (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), t) : 'constructor_declaration)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.ctyp_tag : 'constructor_declaration) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "typ"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp" n s)) : 'constructor_declaration) | _ -> assert false))) ]) ])) ()); Gram.extend (constructor_arg_list : 'constructor_arg_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> (t : 'constructor_arg_list)))); ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'constructor_arg_list) _ (t1 : 'constructor_arg_list) (_loc : Gram.Loc.t) -> (Ast.TyAnd (_loc, t1, t2) : 'constructor_arg_list)))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctypand" n s)) : 'constructor_arg_list) | _ -> assert false))) ]) ])) ()); Gram.extend (label_declaration_list : 'label_declaration_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (label_declaration : 'label_declaration Gram.Entry.t)) ], (Gram.Action.mk (fun (t1 : 'label_declaration) (_loc : Gram.Loc.t) -> (t1 : 'label_declaration_list)))); ([ Gram.Snterm (Gram.Entry.obj (label_declaration : 'label_declaration Gram.Entry.t)); Gram.Skeyword ";" ], (Gram.Action.mk (fun _ (t1 : 'label_declaration) (_loc : Gram.Loc.t) -> (t1 : 'label_declaration_list)))); ([ Gram.Snterm (Gram.Entry.obj (label_declaration : 'label_declaration Gram.Entry.t)); Gram.Skeyword ";"; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'label_declaration_list) _ (t1 : 'label_declaration) (_loc : Gram.Loc.t) -> (Ast.TySem (_loc, t1, t2) : 'label_declaration_list)))) ]) ])) ()); Gram.extend (label_declaration : 'label_declaration Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Skeyword "mutable"; Gram.Snterm (Gram.Entry.obj (poly_type : 'poly_type Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'poly_type) _ _ (s : 'a_LIDENT) (_loc : Gram.Loc.t) -> (Ast.TyCol (_loc, (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), (Ast.TyMut (_loc, t))) : 'label_declaration)))); ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (poly_type : 'poly_type Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'poly_type) _ (s : 'a_LIDENT) (_loc : Gram.Loc.t) -> (Ast.TyCol (_loc, (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), t) : 'label_declaration)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.ctyp_tag : 'label_declaration) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp;" n s)) : 'label_declaration) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "typ"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp" n s)) : 'label_declaration) | _ -> assert false))) ]) ])) ()); Gram.extend (a_ident : 'a_ident Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> (i : 'a_ident)))); ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> (i : 'a_ident)))) ]) ])) ()); Gram.extend (ident : 'ident Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (j : 'ident) _ (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.IdAcc (_loc, (Ast.IdUid (_loc, i)), j) : 'ident)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "id" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (i : 'ident) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "id" | "anti" | "list" as n)), s) -> (Ast.IdAcc (_loc, (Ast.IdAnt (_loc, (mk_anti ~c: "ident" n s))), i) : 'ident) | _ -> assert false))); ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> (Ast.IdLid (_loc, i) : 'ident)))); ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.IdUid (_loc, i) : 'ident)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "id" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "id" | "anti" | "list" as n)), s) -> (Ast.IdAnt (_loc, (mk_anti ~c: "ident" n s)) : 'ident) | _ -> assert false))) ]) ])) ()); Gram.extend (module_longident : 'module_longident Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.IdUid (_loc, i) : 'module_longident)))); ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (l : 'module_longident) _ (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) : 'module_longident)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "id" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "id" | "anti" | "list" as n)), s) -> (Ast.IdAnt (_loc, (mk_anti ~c: "ident" n s)) : 'module_longident) | _ -> assert false))) ]) ])) ()); Gram.extend (module_longident_with_app : 'module_longident_with_app Gram.Entry.t) ((fun () -> (None, [ ((Some "apply"), None, [ ([ Gram.Sself; Gram.Sself ], (Gram.Action.mk (fun (j : 'module_longident_with_app) (i : 'module_longident_with_app) (_loc : Gram.Loc.t) -> (Ast.IdApp (_loc, i, j) : 'module_longident_with_app)))) ]); ((Some "."), None, [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (j : 'module_longident_with_app) _ (i : 'module_longident_with_app) (_loc : Gram.Loc.t) -> (Ast.IdAcc (_loc, i, j) : 'module_longident_with_app)))) ]); ((Some "simple"), None, [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (i : 'module_longident_with_app) _ (_loc : Gram.Loc.t) -> (i : 'module_longident_with_app)))); ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.IdUid (_loc, i) : 'module_longident_with_app)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "id" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "id" | "anti" | "list" as n)), s) -> (Ast.IdAnt (_loc, (mk_anti ~c: "ident" n s)) : 'module_longident_with_app) | _ -> assert false))) ]) ])) ()); Gram.extend (module_longident_dot_lparen : 'module_longident_dot_lparen Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword "."; Gram.Skeyword "(" ], (Gram.Action.mk (fun _ _ (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.IdUid (_loc, i) : 'module_longident_dot_lparen)))); ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (l : 'module_longident_dot_lparen) _ (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) : 'module_longident_dot_lparen)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "id" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); Gram.Skeyword "."; Gram.Skeyword "(" ], (Gram.Action.mk (fun _ _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "id" | "anti" | "list" as n)), s) -> (Ast.IdAnt (_loc, (mk_anti ~c: "ident" n s)) : 'module_longident_dot_lparen) | _ -> assert false))) ]) ])) ()); Gram.extend (type_longident : 'type_longident Gram.Entry.t) ((fun () -> (None, [ ((Some "apply"), None, [ ([ Gram.Sself; Gram.Sself ], (Gram.Action.mk (fun (j : 'type_longident) (i : 'type_longident) (_loc : Gram.Loc.t) -> (Ast.IdApp (_loc, i, j) : 'type_longident)))) ]); ((Some "."), None, [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (j : 'type_longident) _ (i : 'type_longident) (_loc : Gram.Loc.t) -> (Ast.IdAcc (_loc, i, j) : 'type_longident)))) ]); ((Some "simple"), None, [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (i : 'type_longident) _ (_loc : Gram.Loc.t) -> (i : 'type_longident)))); ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.IdUid (_loc, i) : 'type_longident)))); ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> (Ast.IdLid (_loc, i) : 'type_longident)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "id" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "id" | "anti" | "list" as n)), s) -> (Ast.IdAnt (_loc, (mk_anti ~c: "ident" n s)) : 'type_longident) | _ -> assert false))) ]) ])) ()); Gram.extend (label_longident : 'label_longident Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> (Ast.IdLid (_loc, i) : 'label_longident)))); ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (l : 'label_longident) _ (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) : 'label_longident)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "id" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "id" | "anti" | "list" as n)), s) -> (Ast.IdAnt (_loc, (mk_anti ~c: "ident" n s)) : 'label_longident) | _ -> assert false))) ]) ])) ()); Gram.extend (class_type_longident : 'class_type_longident Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (type_longident : 'type_longident Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'type_longident) (_loc : Gram.Loc.t) -> (x : 'class_type_longident)))) ]) ])) ()); Gram.extend (val_longident : 'val_longident Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'ident) (_loc : Gram.Loc.t) -> (x : 'val_longident)))) ]) ])) ()); Gram.extend (class_longident : 'class_longident Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (label_longident : 'label_longident Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'label_longident) (_loc : Gram.Loc.t) -> (x : 'class_longident)))) ]) ])) ()); Gram.extend (class_declaration : 'class_declaration Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Snterm (Gram.Entry.obj (class_info_for_class_expr : 'class_info_for_class_expr Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (class_fun_binding : 'class_fun_binding Gram.Entry.t)) ], (Gram.Action.mk (fun (ce : 'class_fun_binding) (ci : 'class_info_for_class_expr) (_loc : Gram.Loc.t) -> (Ast.CeEq (_loc, ci, ce) : 'class_declaration)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.class_expr_tag : 'class_declaration) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "cdcl" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"cdcl\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "cdcl" | "anti" | "list" as n)), s) -> (Ast.CeAnt (_loc, (mk_anti ~c: "class_expr" n s)) : 'class_declaration) | _ -> assert false))); ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], (Gram.Action.mk (fun (c2 : 'class_declaration) _ (c1 : 'class_declaration) (_loc : Gram.Loc.t) -> (Ast.CeAnd (_loc, c1, c2) : 'class_declaration)))) ]) ])) ()); Gram.extend (class_fun_binding : 'class_fun_binding Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (labeled_ipatt : 'labeled_ipatt Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (cfb : 'class_fun_binding) (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> (Ast.CeFun (_loc, p, cfb) : 'class_fun_binding)))); ([ Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (class_type_plus : 'class_type_plus Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (class_expr : 'class_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (ce : 'class_expr) _ (ct : 'class_type_plus) _ (_loc : Gram.Loc.t) -> (Ast.CeTyc (_loc, ce, ct) : 'class_fun_binding)))); ([ Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (class_expr : 'class_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (ce : 'class_expr) _ (_loc : Gram.Loc.t) -> (ce : 'class_fun_binding)))) ]) ])) ()); Gram.extend (class_info_for_class_type : 'class_info_for_class_type Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (opt_virtual : 'opt_virtual Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (class_name_and_param : 'class_name_and_param Gram.Entry.t)) ], (Gram.Action.mk (fun ((i, ot) : 'class_name_and_param) (mv : 'opt_virtual) (_loc : Gram.Loc.t) -> (Ast.CtCon (_loc, mv, (Ast.IdLid (_loc, i)), ot) : 'class_info_for_class_type)))) ]) ])) ()); Gram.extend (class_info_for_class_expr : 'class_info_for_class_expr Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (opt_virtual : 'opt_virtual Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (class_name_and_param : 'class_name_and_param Gram.Entry.t)) ], (Gram.Action.mk (fun ((i, ot) : 'class_name_and_param) (mv : 'opt_virtual) (_loc : Gram.Loc.t) -> (Ast.CeCon (_loc, mv, (Ast.IdLid (_loc, i)), ot) : 'class_info_for_class_expr)))) ]) ])) ()); Gram.extend (class_name_and_param : 'class_name_and_param Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> ((i, (Ast.TyNil _loc)) : 'class_name_and_param)))); ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword "["; Gram.Snterm (Gram.Entry.obj (comma_type_parameter : 'comma_type_parameter Gram.Entry.t)); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (x : 'comma_type_parameter) _ (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> ((i, x) : 'class_name_and_param)))) ]) ])) ()); Gram.extend (comma_type_parameter : 'comma_type_parameter Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (type_parameter : 'type_parameter Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'type_parameter) (_loc : Gram.Loc.t) -> (t : 'comma_type_parameter)))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp," n s)) : 'comma_type_parameter) | _ -> assert false))); ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'comma_type_parameter) _ (t1 : 'comma_type_parameter) (_loc : Gram.Loc.t) -> (Ast.TyCom (_loc, t1, t2) : 'comma_type_parameter)))) ]) ])) ()); Gram.extend (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.TyNil _loc : 'opt_comma_ctyp)))); ([ Gram.Skeyword "["; Gram.Snterm (Gram.Entry.obj (comma_ctyp : 'comma_ctyp Gram.Entry.t)); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (x : 'comma_ctyp) _ (_loc : Gram.Loc.t) -> (x : 'opt_comma_ctyp)))) ]) ])) ()); Gram.extend (comma_ctyp : 'comma_ctyp Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> (t : 'comma_ctyp)))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp," n s)) : 'comma_ctyp) | _ -> assert false))); ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'comma_ctyp) _ (t1 : 'comma_ctyp) (_loc : Gram.Loc.t) -> (Ast.TyCom (_loc, t1, t2) : 'comma_ctyp)))) ]) ])) ()); Gram.extend (class_fun_def : 'class_fun_def Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "->"; Gram.Snterm (Gram.Entry.obj (class_expr : 'class_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (ce : 'class_expr) _ (_loc : Gram.Loc.t) -> (ce : 'class_fun_def)))); ([ Gram.Snterm (Gram.Entry.obj (labeled_ipatt : 'labeled_ipatt Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (ce : 'class_fun_def) (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> (Ast.CeFun (_loc, p, ce) : 'class_fun_def)))) ]) ])) ()); Gram.extend (class_expr : 'class_expr Gram.Entry.t) ((fun () -> (None, [ ((Some "top"), None, [ ([ Gram.Skeyword "let"; Gram.Snterm (Gram.Entry.obj (opt_rec : 'opt_rec Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (binding : 'binding Gram.Entry.t)); Gram.Skeyword "in"; Gram.Sself ], (Gram.Action.mk (fun (ce : 'class_expr) _ (bi : 'binding) (rf : 'opt_rec) _ (_loc : Gram.Loc.t) -> (Ast.CeLet (_loc, rf, bi, ce) : 'class_expr)))); ([ Gram.Skeyword "fun"; Gram.Snterm (Gram.Entry.obj (labeled_ipatt : 'labeled_ipatt Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (class_fun_def : 'class_fun_def Gram.Entry.t)) ], (Gram.Action.mk (fun (ce : 'class_fun_def) (p : 'labeled_ipatt) _ (_loc : Gram.Loc.t) -> (Ast.CeFun (_loc, p, ce) : 'class_expr)))) ]); ((Some "apply"), (Some Camlp4.Sig.Grammar.NonA), [ ([ Gram.Sself; Gram.Snterml ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), "label") ], (Gram.Action.mk (fun (e : 'expr) (ce : 'class_expr) (_loc : Gram.Loc.t) -> (Ast.CeApp (_loc, ce, e) : 'class_expr)))) ]); ((Some "simple"), None, [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (ce : 'class_expr) _ (_loc : Gram.Loc.t) -> (ce : 'class_expr)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (class_type : 'class_type Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (ct : 'class_type) _ (ce : 'class_expr) _ (_loc : Gram.Loc.t) -> (Ast.CeTyc (_loc, ce, ct) : 'class_expr)))); ([ Gram.Skeyword "object"; Gram.Snterm (Gram.Entry.obj (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (class_structure : 'class_structure Gram.Entry.t)); Gram.Skeyword "end" ], (Gram.Action.mk (fun _ (cst : 'class_structure) (csp : 'opt_class_self_patt) _ (_loc : Gram.Loc.t) -> (Ast.CeStr (_loc, csp, cst) : 'class_expr)))); ([ Gram.Snterm (Gram.Entry.obj (class_longident_and_param : 'class_longident_and_param Gram.Entry.t)) ], (Gram.Action.mk (fun (ce : 'class_longident_and_param) (_loc : Gram.Loc.t) -> (ce : 'class_expr)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.class_expr_tag : 'class_expr) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "cexp" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"cexp\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "cexp" | "anti" as n)), s) -> (Ast.CeAnt (_loc, (mk_anti ~c: "class_expr" n s)) : 'class_expr) | _ -> assert false))) ]) ])) ()); Gram.extend (class_longident_and_param : 'class_longident_and_param Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (class_longident : 'class_longident Gram.Entry.t)) ], (Gram.Action.mk (fun (ci : 'class_longident) (_loc : Gram.Loc.t) -> (Ast.CeCon (_loc, Ast.ViNil, ci, (Ast.TyNil _loc)) : 'class_longident_and_param)))); ([ Gram.Snterm (Gram.Entry.obj (class_longident : 'class_longident Gram.Entry.t)); Gram.Skeyword "["; Gram.Snterm (Gram.Entry.obj (comma_ctyp : 'comma_ctyp Gram.Entry.t)); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (t : 'comma_ctyp) _ (ci : 'class_longident) (_loc : Gram.Loc.t) -> (Ast.CeCon (_loc, Ast.ViNil, ci, t) : 'class_longident_and_param)))) ]) ])) ()); Gram.extend (class_structure : 'class_structure Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Slist0 (Gram.srules class_structure [ ([ Gram.Snterm (Gram.Entry.obj (class_str_item : 'class_str_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (cst : 'class_str_item) (_loc : Gram.Loc.t) -> (cst : 'e__10)))) ]) ], (Gram.Action.mk (fun (l : 'e__10 list) (_loc : Gram.Loc.t) -> (Ast.crSem_of_list l : 'class_structure)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "cst" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (cst : 'class_structure) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "cst" | "anti" | "list" as n)), s) -> (Ast.CrSem (_loc, (Ast.CrAnt (_loc, (mk_anti ~c: "class_str_item" n s))), cst) : 'class_structure) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "cst" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "cst" | "anti" | "list" as n)), s) -> (Ast.CrAnt (_loc, (mk_anti ~c: "class_str_item" n s)) : 'class_structure) | _ -> assert false))) ]) ])) ()); Gram.extend (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.PaNil _loc : 'opt_class_self_patt)))); ([ Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (t : 'ctyp) _ (p : 'patt) _ (_loc : Gram.Loc.t) -> (Ast.PaTyc (_loc, p, t) : 'opt_class_self_patt)))); ([ Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) -> (p : 'opt_class_self_patt)))) ]) ])) ()); Gram.extend (class_str_item : 'class_str_item Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Skeyword "initializer"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (se : 'expr) _ (_loc : Gram.Loc.t) -> (Ast.CrIni (_loc, se) : 'class_str_item)))); ([ Gram.Snterm (Gram.Entry.obj (type_constraint : 'type_constraint Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (_loc : Gram.Loc.t) -> (Ast.CrCtr (_loc, t1, t2) : 'class_str_item)))); ([ Gram.Snterm (Gram.Entry.obj (method_opt_override : 'method_opt_override Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_private : 'opt_private Gram.Entry.t)); Gram.Skeyword "virtual"; Gram.Snterm (Gram.Entry.obj (label : 'label Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (poly_type : 'poly_type Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'poly_type) _ (l : 'label) _ (pf : 'opt_private) (o : 'method_opt_override) (_loc : Gram.Loc.t) -> (if o <> Ast.OvNil then raise (Stream.Error "override (!) is incompatible with virtual") else Ast.CrVir (_loc, l, pf, t) : 'class_str_item)))); ([ Gram.Snterm (Gram.Entry.obj (method_opt_override : 'method_opt_override Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_private : 'opt_private Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (label : 'label Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_polyt : 'opt_polyt Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (fun_binding : 'fun_binding Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'fun_binding) (topt : 'opt_polyt) (l : 'label) (pf : 'opt_private) (o : 'method_opt_override) (_loc : Gram.Loc.t) -> (Ast.CrMth (_loc, l, o, pf, e, topt) : 'class_str_item)))); ([ Gram.Snterm (Gram.Entry.obj (method_opt_override : 'method_opt_override Gram.Entry.t)); Gram.Skeyword "virtual"; Gram.Snterm (Gram.Entry.obj (opt_private : 'opt_private Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (label : 'label Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (poly_type : 'poly_type Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'poly_type) _ (l : 'label) (pf : 'opt_private) _ (o : 'method_opt_override) (_loc : Gram.Loc.t) -> (if o <> Ast.OvNil then raise (Stream.Error "override (!) is incompatible with virtual") else Ast.CrVir (_loc, l, pf, t) : 'class_str_item)))); ([ Gram.Snterm (Gram.Entry.obj (value_val_opt_override : 'value_val_opt_override Gram.Entry.t)); Gram.Skeyword "virtual"; Gram.Snterm (Gram.Entry.obj (opt_mutable : 'opt_mutable Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (label : 'label Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (poly_type : 'poly_type Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'poly_type) _ (l : 'label) (mf : 'opt_mutable) _ (o : 'value_val_opt_override) (_loc : Gram.Loc.t) -> (if o <> Ast.OvNil then raise (Stream.Error "override (!) is incompatible with virtual") else Ast.CrVvr (_loc, l, mf, t) : 'class_str_item)))); ([ Gram.Snterm (Gram.Entry.obj (value_val_opt_override : 'value_val_opt_override Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_mutable : 'opt_mutable Gram.Entry.t)); Gram.Skeyword "virtual"; Gram.Snterm (Gram.Entry.obj (label : 'label Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (poly_type : 'poly_type Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'poly_type) _ (l : 'label) _ (mf : 'opt_mutable) (o : 'value_val_opt_override) (_loc : Gram.Loc.t) -> (if o <> Ast.OvNil then raise (Stream.Error "override (!) is incompatible with virtual") else Ast.CrVvr (_loc, l, mf, t) : 'class_str_item)))); ([ Gram.Snterm (Gram.Entry.obj (value_val_opt_override : 'value_val_opt_override Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_mutable : 'opt_mutable Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (label : 'label Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (cvalue_binding : 'cvalue_binding Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'cvalue_binding) (lab : 'label) (mf : 'opt_mutable) (o : 'value_val_opt_override) (_loc : Gram.Loc.t) -> (Ast.CrVal (_loc, lab, o, mf, e) : 'class_str_item)))); ([ Gram.Skeyword "inherit"; Gram.Snterm (Gram.Entry.obj (opt_override : 'opt_override Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (class_expr : 'class_expr Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_as_lident : 'opt_as_lident Gram.Entry.t)) ], (Gram.Action.mk (fun (pb : 'opt_as_lident) (ce : 'class_expr) (o : 'opt_override) _ (_loc : Gram.Loc.t) -> (Ast.CrInh (_loc, o, ce, pb) : 'class_str_item)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.class_str_item_tag : 'class_str_item) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "cst" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "cst" | "anti" | "list" as n)), s) -> (Ast.CrAnt (_loc, (mk_anti ~c: "class_str_item" n s)) : 'class_str_item) | _ -> assert false))) ]) ])) ()); Gram.extend (method_opt_override : 'method_opt_override Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "method" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.OvNil : 'method_opt_override)))); ([ Gram.Skeyword "method"; Gram.Stoken (((function | ANTIQUOT (("!" | "override" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("!" | "override" | "anti" as n)), s) -> (Ast.OvAnt (mk_anti n s) : 'method_opt_override) | _ -> assert false))); ([ Gram.Skeyword "method"; Gram.Skeyword "!" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (Ast.OvOverride : 'method_opt_override)))) ]) ])) ()); Gram.extend (value_val_opt_override : 'value_val_opt_override Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (value_val : 'value_val Gram.Entry.t)) ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.OvNil : 'value_val_opt_override)))); ([ Gram.Snterm (Gram.Entry.obj (value_val : 'value_val Gram.Entry.t)); Gram.Stoken (((function | ANTIQUOT (("!" | "override" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("!" | "override" | "anti" as n)), s) -> (Ast.OvAnt (mk_anti n s) : 'value_val_opt_override) | _ -> assert false))); ([ Gram.Snterm (Gram.Entry.obj (value_val : 'value_val Gram.Entry.t)); Gram.Skeyword "!" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (Ast.OvOverride : 'value_val_opt_override)))) ]) ])) ()); Gram.extend (opt_as_lident : 'opt_as_lident Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> ("" : 'opt_as_lident)))); ([ Gram.Skeyword "as"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (i : 'opt_as_lident)))) ]) ])) ()); Gram.extend (opt_polyt : 'opt_polyt Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.TyNil _loc : 'opt_polyt)))); ([ Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (poly_type : 'poly_type Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'poly_type) _ (_loc : Gram.Loc.t) -> (t : 'opt_polyt)))) ]) ])) ()); Gram.extend (cvalue_binding : 'cvalue_binding Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword ":>"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (t : 'ctyp) _ (_loc : Gram.Loc.t) -> (Ast.ExCoe (_loc, e, (Ast.TyNil _loc), t) : 'cvalue_binding)))); ([ Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (poly_type : 'poly_type Gram.Entry.t)); Gram.Skeyword ":>"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'poly_type) _ (_loc : Gram.Loc.t) -> (match t with | Ast.TyPol (_, _, _) -> raise (Stream.Error "unexpected polytype here") | _ -> Ast.ExCoe (_loc, e, t, t2) : 'cvalue_binding)))); ([ Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (poly_type : 'poly_type Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (t : 'poly_type) _ (_loc : Gram.Loc.t) -> (Ast.ExTyc (_loc, e, t) : 'cvalue_binding)))); ([ Gram.Skeyword ":"; Gram.Skeyword "type"; Gram.Snterm (Gram.Entry.obj (unquoted_typevars : 'unquoted_typevars Gram.Entry.t)); Gram.Skeyword "."; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (t2 : 'ctyp) _ (t1 : 'unquoted_typevars) _ _ (_loc : Gram.Loc.t) -> (let u = Ast.TyTypePol (_loc, t1, t2) in Ast.ExTyc (_loc, e, u) : 'cvalue_binding)))); ([ Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> (e : 'cvalue_binding)))) ]) ])) ()); Gram.extend (label : 'label Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> (i : 'label)))) ]) ])) ()); Gram.extend (class_type : 'class_type Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "object"; Gram.Snterm (Gram.Entry.obj (opt_class_self_type : 'opt_class_self_type Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (class_signature : 'class_signature Gram.Entry.t)); Gram.Skeyword "end" ], (Gram.Action.mk (fun _ (csg : 'class_signature) (cst : 'opt_class_self_type) _ (_loc : Gram.Loc.t) -> (Ast.CtSig (_loc, cst, csg) : 'class_type)))); ([ Gram.Snterm (Gram.Entry.obj (class_type_longident_and_param : 'class_type_longident_and_param Gram. Entry.t)) ], (Gram.Action.mk (fun (ct : 'class_type_longident_and_param) (_loc : Gram.Loc.t) -> (ct : 'class_type)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.class_type_tag : 'class_type) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "ctyp" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"ctyp\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "ctyp" | "anti" as n)), s) -> (Ast.CtAnt (_loc, (mk_anti ~c: "class_type" n s)) : 'class_type) | _ -> assert false))) ]) ])) ()); Gram.extend (class_type_longident_and_param : 'class_type_longident_and_param Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (class_type_longident : 'class_type_longident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'class_type_longident) (_loc : Gram.Loc.t) -> (Ast.CtCon (_loc, Ast.ViNil, i, (Ast.TyNil _loc)) : 'class_type_longident_and_param)))); ([ Gram.Snterm (Gram.Entry.obj (class_type_longident : 'class_type_longident Gram.Entry.t)); Gram.Skeyword "["; Gram.Snterm (Gram.Entry.obj (comma_ctyp : 'comma_ctyp Gram.Entry.t)); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (t : 'comma_ctyp) _ (i : 'class_type_longident) (_loc : Gram.Loc.t) -> (Ast.CtCon (_loc, Ast.ViNil, i, t) : 'class_type_longident_and_param)))) ]) ])) ()); Gram.extend (class_type_plus : 'class_type_plus Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (class_type : 'class_type Gram.Entry.t)) ], (Gram.Action.mk (fun (ct : 'class_type) (_loc : Gram.Loc.t) -> (ct : 'class_type_plus)))); ([ Gram.Skeyword "["; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword "]"; Gram.Skeyword "->"; Gram.Sself ], (Gram.Action.mk (fun (ct : 'class_type_plus) _ _ (t : 'ctyp) _ (_loc : Gram.Loc.t) -> (Ast.CtFun (_loc, t, ct) : 'class_type_plus)))) ]) ])) ()); Gram.extend (opt_class_self_type : 'opt_class_self_type Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.TyNil _loc : 'opt_class_self_type)))); ([ Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (t : 'ctyp) _ (_loc : Gram.Loc.t) -> (t : 'opt_class_self_type)))) ]) ])) ()); Gram.extend (class_signature : 'class_signature Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Slist0 (Gram.srules class_signature [ ([ Gram.Snterm (Gram.Entry.obj (class_sig_item : 'class_sig_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (csg : 'class_sig_item) (_loc : Gram.Loc.t) -> (csg : 'e__11)))) ]) ], (Gram.Action.mk (fun (l : 'e__11 list) (_loc : Gram.Loc.t) -> (Ast.cgSem_of_list l : 'class_signature)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "csg" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (csg : 'class_signature) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "csg" | "anti" | "list" as n)), s) -> (Ast.CgSem (_loc, (Ast.CgAnt (_loc, (mk_anti ~c: "class_sig_item" n s))), csg) : 'class_signature) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "csg" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "csg" | "anti" | "list" as n)), s) -> (Ast.CgAnt (_loc, (mk_anti ~c: "class_sig_item" n s)) : 'class_signature) | _ -> assert false))) ]) ])) ()); Gram.extend (class_sig_item : 'class_sig_item Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (type_constraint : 'type_constraint Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (_loc : Gram.Loc.t) -> (Ast.CgCtr (_loc, t1, t2) : 'class_sig_item)))); ([ Gram.Skeyword "method"; Gram.Snterm (Gram.Entry.obj (opt_private : 'opt_private Gram.Entry.t)); Gram.Skeyword "virtual"; Gram.Snterm (Gram.Entry.obj (label : 'label Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (poly_type : 'poly_type Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'poly_type) _ (l : 'label) _ (pf : 'opt_private) _ (_loc : Gram.Loc.t) -> (Ast.CgVir (_loc, l, pf, t) : 'class_sig_item)))); ([ Gram.Skeyword "method"; Gram.Snterm (Gram.Entry.obj (opt_private : 'opt_private Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (label : 'label Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (poly_type : 'poly_type Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'poly_type) _ (l : 'label) (pf : 'opt_private) _ (_loc : Gram.Loc.t) -> (Ast.CgMth (_loc, l, pf, t) : 'class_sig_item)))); ([ Gram.Skeyword "method"; Gram.Skeyword "virtual"; Gram.Snterm (Gram.Entry.obj (opt_private : 'opt_private Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (label : 'label Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (poly_type : 'poly_type Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'poly_type) _ (l : 'label) (pf : 'opt_private) _ _ (_loc : Gram.Loc.t) -> (Ast.CgVir (_loc, l, pf, t) : 'class_sig_item)))); ([ Gram.Snterm (Gram.Entry.obj (value_val : 'value_val Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_mutable : 'opt_mutable Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_virtual : 'opt_virtual Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (label : 'label Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'ctyp) _ (l : 'label) (mv : 'opt_virtual) (mf : 'opt_mutable) _ (_loc : Gram.Loc.t) -> (Ast.CgVal (_loc, l, mf, mv, t) : 'class_sig_item)))); ([ Gram.Skeyword "inherit"; Gram.Snterm (Gram.Entry.obj (class_type : 'class_type Gram.Entry.t)) ], (Gram.Action.mk (fun (cs : 'class_type) _ (_loc : Gram.Loc.t) -> (Ast.CgInh (_loc, cs) : 'class_sig_item)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.class_sig_item_tag : 'class_sig_item) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "csg" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "csg" | "anti" | "list" as n)), s) -> (Ast.CgAnt (_loc, (mk_anti ~c: "class_sig_item" n s)) : 'class_sig_item) | _ -> assert false))) ]) ])) ()); Gram.extend (type_constraint : 'type_constraint Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "constraint" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (() : 'type_constraint)))); ([ Gram.Skeyword "type" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (() : 'type_constraint)))) ]) ])) ()); Gram.extend (class_description : 'class_description Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (class_info_for_class_type : 'class_info_for_class_type Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (class_type_plus : 'class_type_plus Gram.Entry.t)) ], (Gram.Action.mk (fun (ct : 'class_type_plus) _ (ci : 'class_info_for_class_type) (_loc : Gram.Loc.t) -> (Ast.CtCol (_loc, ci, ct) : 'class_description)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.class_type_tag : 'class_description) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "typ" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" | "anti" | "list" as n)), s) -> (Ast.CtAnt (_loc, (mk_anti ~c: "class_type" n s)) : 'class_description) | _ -> assert false))); ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], (Gram.Action.mk (fun (cd2 : 'class_description) _ (cd1 : 'class_description) (_loc : Gram.Loc.t) -> (Ast.CtAnd (_loc, cd1, cd2) : 'class_description)))) ]) ])) ()); Gram.extend (class_type_declaration : 'class_type_declaration Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Snterm (Gram.Entry.obj (class_info_for_class_type : 'class_info_for_class_type Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (class_type : 'class_type Gram.Entry.t)) ], (Gram.Action.mk (fun (ct : 'class_type) _ (ci : 'class_info_for_class_type) (_loc : Gram.Loc.t) -> (Ast.CtEq (_loc, ci, ct) : 'class_type_declaration)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.class_type_tag : 'class_type_declaration) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "typ" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" | "anti" | "list" as n)), s) -> (Ast.CtAnt (_loc, (mk_anti ~c: "class_type" n s)) : 'class_type_declaration) | _ -> assert false))); ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], (Gram.Action.mk (fun (cd2 : 'class_type_declaration) _ (cd1 : 'class_type_declaration) (_loc : Gram.Loc.t) -> (Ast.CtAnd (_loc, cd1, cd2) : 'class_type_declaration)))) ]) ])) ()); Gram.extend (field_expr_list : 'field_expr_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (field_expr : 'field_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (b1 : 'field_expr) (_loc : Gram.Loc.t) -> (b1 : 'field_expr_list)))); ([ Gram.Snterm (Gram.Entry.obj (field_expr : 'field_expr Gram.Entry.t)); Gram.Skeyword ";" ], (Gram.Action.mk (fun _ (b1 : 'field_expr) (_loc : Gram.Loc.t) -> (b1 : 'field_expr_list)))); ([ Gram.Snterm (Gram.Entry.obj (field_expr : 'field_expr Gram.Entry.t)); Gram.Skeyword ";"; Gram.Sself ], (Gram.Action.mk (fun (b2 : 'field_expr_list) _ (b1 : 'field_expr) (_loc : Gram.Loc.t) -> (Ast.RbSem (_loc, b1, b2) : 'field_expr_list)))) ]) ])) ()); Gram.extend (field_expr : 'field_expr Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (label : 'label Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterml ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), "top") ], (Gram.Action.mk (fun (e : 'expr) _ (l : 'label) (_loc : Gram.Loc.t) -> (Ast.RbEq (_loc, (Ast.IdLid (_loc, l)), e) : 'field_expr)))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.RbAnt (_loc, (mk_anti ~c: "rec_binding" n s)) : 'field_expr) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "bi" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"bi\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "bi" | "anti" as n)), s) -> (Ast.RbAnt (_loc, (mk_anti ~c: "rec_binding" n s)) : 'field_expr) | _ -> assert false))) ]) ])) ()); Gram.extend (meth_list : 'meth_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (meth_decl : 'meth_decl Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], (Gram.Action.mk (fun (v : 'opt_dot_dot) (m : 'meth_decl) (_loc : Gram.Loc.t) -> ((m, v) : 'meth_list)))); ([ Gram.Snterm (Gram.Entry.obj (meth_decl : 'meth_decl Gram.Entry.t)); Gram.Skeyword ";"; Gram.Snterm (Gram.Entry.obj (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], (Gram.Action.mk (fun (v : 'opt_dot_dot) _ (m : 'meth_decl) (_loc : Gram.Loc.t) -> ((m, v) : 'meth_list)))); ([ Gram.Snterm (Gram.Entry.obj (meth_decl : 'meth_decl Gram.Entry.t)); Gram.Skeyword ";"; Gram.Sself ], (Gram.Action.mk (fun ((ml, v) : 'meth_list) _ (m : 'meth_decl) (_loc : Gram.Loc.t) -> (((Ast.TySem (_loc, m, ml)), v) : 'meth_list)))) ]) ])) ()); Gram.extend (meth_decl : 'meth_decl Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (poly_type : 'poly_type Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'poly_type) _ (lab : 'a_LIDENT) (_loc : Gram.Loc.t) -> (Ast.TyCol (_loc, (Ast.TyId (_loc, (Ast.IdLid (_loc, lab)))), t) : 'meth_decl)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.ctyp_tag : 'meth_decl) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp;" n s)) : 'meth_decl) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "typ"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp" n s)) : 'meth_decl) | _ -> assert false))) ]) ])) ()); Gram.extend (opt_meth_list : 'opt_meth_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], (Gram.Action.mk (fun (v : 'opt_dot_dot) (_loc : Gram.Loc.t) -> (Ast.TyObj (_loc, (Ast.TyNil _loc), v) : 'opt_meth_list)))); ([ Gram.Snterm (Gram.Entry.obj (meth_list : 'meth_list Gram.Entry.t)) ], (Gram.Action.mk (fun ((ml, v) : 'meth_list) (_loc : Gram.Loc.t) -> (Ast.TyObj (_loc, ml, v) : 'opt_meth_list)))) ]) ])) ()); Gram.extend (poly_type : 'poly_type Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> (t : 'poly_type)))) ]) ])) ()); Gram.extend (package_type : 'package_type Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)) ], (Gram.Action.mk (fun (p : 'module_type) (_loc : Gram.Loc.t) -> (p : 'package_type)))) ]) ])) ()); Gram.extend (typevars : 'typevars Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Skeyword "'"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> (Ast.TyQuo (_loc, i) : 'typevars)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.ctyp_tag : 'typevars) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "typ"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp" n s)) : 'typevars) | _ -> assert false))); ([ Gram.Sself; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'typevars) (t1 : 'typevars) (_loc : Gram.Loc.t) -> (Ast.TyApp (_loc, t1, t2) : 'typevars)))) ]) ])) ()); Gram.extend (unquoted_typevars : 'unquoted_typevars Gram.Entry.t) ((fun () -> (None, [ (None, (Some Camlp4.Sig.Grammar.LeftA), [ ([ Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_ident) (_loc : Gram.Loc.t) -> (Ast.TyId (_loc, (Ast.IdLid (_loc, i))) : 'unquoted_typevars)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.ctyp_tag : 'unquoted_typevars) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "typ"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp" n s)) : 'unquoted_typevars) | _ -> assert false))); ([ Gram.Sself; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'unquoted_typevars) (t1 : 'unquoted_typevars) (_loc : Gram.Loc.t) -> (Ast.TyApp (_loc, t1, t2) : 'unquoted_typevars)))) ]) ])) ()); Gram.extend (row_field : 'row_field Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> (t : 'row_field)))); ([ Gram.Skeyword "`"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)); Gram.Skeyword "of"; Gram.Snterm (Gram.Entry.obj (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'amp_ctyp) _ (i : 'a_ident) _ (_loc : Gram.Loc.t) -> (Ast.TyOf (_loc, (Ast.TyVrn (_loc, i)), t) : 'row_field)))); ([ Gram.Skeyword "`"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)); Gram.Skeyword "of"; Gram.Skeyword "&"; Gram.Snterm (Gram.Entry.obj (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'amp_ctyp) _ _ (i : 'a_ident) _ (_loc : Gram.Loc.t) -> (Ast.TyOfAmp (_loc, (Ast.TyVrn (_loc, i)), t) : 'row_field)))); ([ Gram.Skeyword "`"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> (Ast.TyVrn (_loc, i) : 'row_field)))); ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'row_field) _ (t1 : 'row_field) (_loc : Gram.Loc.t) -> (Ast.TyOr (_loc, t1, t2) : 'row_field)))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp|" n s)) : 'row_field) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "typ"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp" n s)) : 'row_field) | _ -> assert false))) ]) ])) ()); Gram.extend (amp_ctyp : 'amp_ctyp Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> (t : 'amp_ctyp)))); ([ Gram.Stoken (((function | ANTIQUOT ("list", _) -> true | _ -> false), "ANTIQUOT (\"list\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("list" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp&" n s)) : 'amp_ctyp) | _ -> assert false))); ([ Gram.Sself; Gram.Skeyword "&"; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'amp_ctyp) _ (t1 : 'amp_ctyp) (_loc : Gram.Loc.t) -> (Ast.TyAmp (_loc, t1, t2) : 'amp_ctyp)))) ]) ])) ()); Gram.extend (name_tags : 'name_tags Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "`"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> (Ast.TyVrn (_loc, i) : 'name_tags)))); ([ Gram.Sself; Gram.Sself ], (Gram.Action.mk (fun (t2 : 'name_tags) (t1 : 'name_tags) (_loc : Gram.Loc.t) -> (Ast.TyApp (_loc, t1, t2) : 'name_tags)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "typ"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"typ\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "typ" as n)), s) -> (Ast.TyAnt (_loc, (mk_anti ~c: "ctyp" n s)) : 'name_tags) | _ -> assert false))) ]) ])) ()); Gram.extend (eq_expr : 'eq_expr Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (fun i p -> Ast.PaOlb (_loc, i, p) : 'eq_expr)))); ([ Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> (fun i p -> Ast.PaOlbi (_loc, i, p, e) : 'eq_expr)))) ]) ])) ()); Gram.extend (patt_tcon : 'patt_tcon Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], (Gram.Action.mk (fun (p : 'patt) (_loc : Gram.Loc.t) -> (p : 'patt_tcon)))); ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'ctyp) _ (p : 'patt) (_loc : Gram.Loc.t) -> (Ast.PaTyc (_loc, p, t) : 'patt_tcon)))) ]) ])) ()); Gram.extend (ipatt : 'ipatt Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "?"; Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (e : 'expr) _ (p : 'ipatt_tcon) _ _ (_loc : Gram.Loc.t) -> (Ast.PaOlbi (_loc, "", p, e) : 'ipatt)))); ([ Gram.Skeyword "?"; Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (p : 'ipatt_tcon) _ _ (_loc : Gram.Loc.t) -> (Ast.PaOlb (_loc, "", p) : 'ipatt)))); ([ Gram.Skeyword "?"; Gram.Stoken (((function | ANTIQUOT (("" | "lid"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"lid\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "lid" as n)), i) -> (Ast.PaOlb (_loc, (mk_anti n i), (Ast.PaNil _loc)) : 'ipatt) | _ -> assert false))); ([ Gram.Skeyword "?"; Gram.Stoken (((function | LIDENT _ -> true | _ -> false), "LIDENT _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | LIDENT i -> (Ast.PaOlb (_loc, i, (Ast.PaNil _loc)) : 'ipatt) | _ -> assert false))); ([ Gram.Skeyword "?"; Gram.Stoken (((function | ANTIQUOT (("" | "lid"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"lid\"), _)")); Gram.Skeyword ":"; Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (eq_expr : 'eq_expr Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _ _ (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "lid" as n)), i) -> (f (mk_anti n i) p : 'ipatt) | _ -> assert false))); ([ Gram.Stoken (((function | OPTLABEL _ -> true | _ -> false), "OPTLABEL _")); Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (eq_expr : 'eq_expr Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | OPTLABEL i -> (f i p : 'ipatt) | _ -> assert false))); ([ Gram.Skeyword "~"; Gram.Stoken (((function | LIDENT _ -> true | _ -> false), "LIDENT _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | LIDENT i -> (Ast.PaLab (_loc, i, (Ast.PaNil _loc)) : 'ipatt) | _ -> assert false))); ([ Gram.Skeyword "~"; Gram.Stoken (((function | ANTIQUOT (("" | "lid"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"lid\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "lid" as n)), i) -> (Ast.PaLab (_loc, (mk_anti n i), (Ast.PaNil _loc)) : 'ipatt) | _ -> assert false))); ([ Gram.Skeyword "~"; Gram.Stoken (((function | ANTIQUOT (("" | "lid"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"lid\"), _)")); Gram.Skeyword ":"; Gram.Sself ], (Gram.Action.mk (fun (p : 'ipatt) _ (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "lid" as n)), i) -> (Ast.PaLab (_loc, (mk_anti n i), p) : 'ipatt) | _ -> assert false))); ([ Gram.Stoken (((function | LABEL _ -> true | _ -> false), "LABEL _")); Gram.Sself ], (Gram.Action.mk (fun (p : 'ipatt) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | LABEL i -> (Ast.PaLab (_loc, i, p) : 'ipatt) | _ -> assert false))) ]) ])) ()); Gram.extend (ipatt_tcon : 'ipatt_tcon Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], (Gram.Action.mk (fun (p : 'ipatt) (_loc : Gram.Loc.t) -> (p : 'ipatt_tcon)))); ([ Gram.Snterm (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'ctyp) _ (p : 'ipatt) (_loc : Gram.Loc.t) -> (Ast.PaTyc (_loc, p, t) : 'ipatt_tcon)))) ]) ])) ()); Gram.extend (direction_flag : 'direction_flag Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | ANTIQUOT (("to" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"to\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("to" | "anti" as n)), s) -> (Ast.DiAnt (mk_anti n s) : 'direction_flag) | _ -> assert false))); ([ Gram.Skeyword "downto" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.DiDownto : 'direction_flag)))); ([ Gram.Skeyword "to" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.DiTo : 'direction_flag)))) ]) ])) ()); Gram.extend (opt_private : 'opt_private Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.PrNil : 'opt_private)))); ([ Gram.Stoken (((function | ANTIQUOT (("private" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"private\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("private" | "anti" as n)), s) -> (Ast.PrAnt (mk_anti n s) : 'opt_private) | _ -> assert false))); ([ Gram.Skeyword "private" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.PrPrivate : 'opt_private)))) ]) ])) ()); Gram.extend (opt_mutable : 'opt_mutable Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.MuNil : 'opt_mutable)))); ([ Gram.Stoken (((function | ANTIQUOT (("mutable" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"mutable\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("mutable" | "anti" as n)), s) -> (Ast.MuAnt (mk_anti n s) : 'opt_mutable) | _ -> assert false))); ([ Gram.Skeyword "mutable" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.MuMutable : 'opt_mutable)))) ]) ])) ()); Gram.extend (opt_virtual : 'opt_virtual Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.ViNil : 'opt_virtual)))); ([ Gram.Stoken (((function | ANTIQUOT (("virtual" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"virtual\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("virtual" | "anti" as n)), s) -> (Ast.ViAnt (mk_anti n s) : 'opt_virtual) | _ -> assert false))); ([ Gram.Skeyword "virtual" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.ViVirtual : 'opt_virtual)))) ]) ])) ()); Gram.extend (opt_dot_dot : 'opt_dot_dot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.RvNil : 'opt_dot_dot)))); ([ Gram.Stoken (((function | ANTIQUOT ((".." | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"..\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT (((".." | "anti" as n)), s) -> (Ast.RvAnt (mk_anti n s) : 'opt_dot_dot) | _ -> assert false))); ([ Gram.Skeyword ".." ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.RvRowVar : 'opt_dot_dot)))) ]) ])) ()); Gram.extend (opt_rec : 'opt_rec Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.ReNil : 'opt_rec)))); ([ Gram.Stoken (((function | ANTIQUOT (("rec" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"rec\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("rec" | "anti" as n)), s) -> (Ast.ReAnt (mk_anti n s) : 'opt_rec) | _ -> assert false))); ([ Gram.Skeyword "rec" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.ReRecursive : 'opt_rec)))) ]) ])) ()); Gram.extend (opt_override : 'opt_override Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.OvNil : 'opt_override)))); ([ Gram.Stoken (((function | ANTIQUOT (("!" | "override" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("!" | "override" | "anti" as n)), s) -> (Ast.OvAnt (mk_anti n s) : 'opt_override) | _ -> assert false))); ([ Gram.Skeyword "!" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.OvOverride : 'opt_override)))) ]) ])) ()); Gram.extend (opt_expr : 'opt_expr Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.ExNil _loc : 'opt_expr)))); ([ Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) (_loc : Gram.Loc.t) -> (e : 'opt_expr)))) ]) ])) ()); Gram.extend (interf : 'interf Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | EOI -> true | _ -> false), "EOI")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | EOI -> (([], None) : 'interf) | _ -> assert false))); ([ Gram.Snterm (Gram.Entry.obj (sig_item : 'sig_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun ((sil, stopped) : 'interf) _ (si : 'sig_item) (_loc : Gram.Loc.t) -> (((si :: sil), stopped) : 'interf)))); ([ Gram.Skeyword "#"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_expr : 'opt_expr Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (([ Ast.SgDir (_loc, n, dp) ], (stopped_at _loc)) : 'interf)))) ]) ])) ()); Gram.extend (sig_items : 'sig_items Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Slist0 (Gram.srules sig_items [ ([ Gram.Snterm (Gram.Entry.obj (sig_item : 'sig_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (sg : 'sig_item) (_loc : Gram.Loc.t) -> (sg : 'e__12)))) ]) ], (Gram.Action.mk (fun (l : 'e__12 list) (_loc : Gram.Loc.t) -> (Ast.sgSem_of_list l : 'sig_items)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "sigi" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (sg : 'sig_items) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "sigi" | "anti" | "list" as n)), s) -> (Ast.SgSem (_loc, (Ast.SgAnt (_loc, (mk_anti n ~c: "sig_item" s))), sg) : 'sig_items) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "sigi" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "sigi" | "anti" | "list" as n)), s) -> (Ast.SgAnt (_loc, (mk_anti n ~c: "sig_item" s)) : 'sig_items) | _ -> assert false))) ]) ])) ()); Gram.extend (implem : 'implem Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | EOI -> true | _ -> false), "EOI")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | EOI -> (([], None) : 'implem) | _ -> assert false))); ([ Gram.Snterm (Gram.Entry.obj (str_item : 'str_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun ((sil, stopped) : 'implem) _ (si : 'str_item) (_loc : Gram.Loc.t) -> (((si :: sil), stopped) : 'implem)))); ([ Gram.Skeyword "#"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_expr : 'opt_expr Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (([ Ast.StDir (_loc, n, dp) ], (stopped_at _loc)) : 'implem)))) ]) ])) ()); Gram.extend (str_items : 'str_items Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Slist0 (Gram.srules str_items [ ([ Gram.Snterm (Gram.Entry.obj (str_item : 'str_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (st : 'str_item) (_loc : Gram.Loc.t) -> (st : 'e__13)))) ]) ], (Gram.Action.mk (fun (l : 'e__13 list) (_loc : Gram.Loc.t) -> (Ast.stSem_of_list l : 'str_items)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "stri" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (st : 'str_items) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "stri" | "anti" | "list" as n)), s) -> (Ast.StSem (_loc, (Ast.StAnt (_loc, (mk_anti n ~c: "str_item" s))), st) : 'str_items) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "stri" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "stri" | "anti" | "list" as n)), s) -> (Ast.StAnt (_loc, (mk_anti n ~c: "str_item" s)) : 'str_items) | _ -> assert false))) ]) ])) ()); Gram.extend (top_phrase : 'top_phrase Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | EOI -> true | _ -> false), "EOI")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | EOI -> (None : 'top_phrase) | _ -> assert false))); ([ Gram.Snterm (Gram.Entry.obj (phrase : 'phrase Gram.Entry.t)) ], (Gram.Action.mk (fun (ph : 'phrase) (_loc : Gram.Loc.t) -> (Some ph : 'top_phrase)))) ]) ])) ()); Gram.extend (use_file : 'use_file Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | EOI -> true | _ -> false), "EOI")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | EOI -> (([], None) : 'use_file) | _ -> assert false))); ([ Gram.Snterm (Gram.Entry.obj (str_item : 'str_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun ((sil, stopped) : 'use_file) _ (si : 'str_item) (_loc : Gram.Loc.t) -> (((si :: sil), stopped) : 'use_file)))); ([ Gram.Skeyword "#"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_expr : 'opt_expr Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (([ Ast.StDir (_loc, n, dp) ], (stopped_at _loc)) : 'use_file)))) ]) ])) ()); Gram.extend (phrase : 'phrase Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (str_item : 'str_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (st : 'str_item) (_loc : Gram.Loc.t) -> (st : 'phrase)))); ([ Gram.Skeyword "#"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_expr : 'opt_expr Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.StDir (_loc, n, dp) : 'phrase)))) ]) ])) ()); Gram.extend (a_INT : 'a_INT Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | INT (_, _) -> true | _ -> false), "INT (_, _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | INT (_, s) -> (s : 'a_INT) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "int" | "`int"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"int\" | \"`int\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "int" | "`int" as n)), s) -> (mk_anti n s : 'a_INT) | _ -> assert false))) ]) ])) ()); Gram.extend (a_INT32 : 'a_INT32 Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | INT32 (_, _) -> true | _ -> false), "INT32 (_, _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | INT32 (_, s) -> (s : 'a_INT32) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "int32" | "`int32"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"int32\" | \"`int32\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "int32" | "`int32" as n)), s) -> (mk_anti n s : 'a_INT32) | _ -> assert false))) ]) ])) ()); Gram.extend (a_INT64 : 'a_INT64 Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | INT64 (_, _) -> true | _ -> false), "INT64 (_, _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | INT64 (_, s) -> (s : 'a_INT64) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "int64" | "`int64"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"int64\" | \"`int64\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "int64" | "`int64" as n)), s) -> (mk_anti n s : 'a_INT64) | _ -> assert false))) ]) ])) ()); Gram.extend (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | NATIVEINT (_, _) -> true | _ -> false), "NATIVEINT (_, _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | NATIVEINT (_, s) -> (s : 'a_NATIVEINT) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "nativeint" | "`nativeint"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"nativeint\" | \"`nativeint\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "nativeint" | "`nativeint" as n)), s) -> (mk_anti n s : 'a_NATIVEINT) | _ -> assert false))) ]) ])) ()); Gram.extend (a_FLOAT : 'a_FLOAT Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | FLOAT (_, _) -> true | _ -> false), "FLOAT (_, _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | FLOAT (_, s) -> (s : 'a_FLOAT) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "flo" | "`flo"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"flo\" | \"`flo\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "flo" | "`flo" as n)), s) -> (mk_anti n s : 'a_FLOAT) | _ -> assert false))) ]) ])) ()); Gram.extend (a_CHAR : 'a_CHAR Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | CHAR (_, _) -> true | _ -> false), "CHAR (_, _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | CHAR (_, s) -> (s : 'a_CHAR) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "chr" | "`chr"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"chr\" | \"`chr\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "chr" | "`chr" as n)), s) -> (mk_anti n s : 'a_CHAR) | _ -> assert false))) ]) ])) ()); Gram.extend (a_UIDENT : 'a_UIDENT Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | UIDENT _ -> true | _ -> false), "UIDENT _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT s -> (s : 'a_UIDENT) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "uid"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"uid\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "uid" as n)), s) -> (mk_anti n s : 'a_UIDENT) | _ -> assert false))) ]) ])) ()); Gram.extend (a_LIDENT : 'a_LIDENT Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | LIDENT _ -> true | _ -> false), "LIDENT _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | LIDENT s -> (s : 'a_LIDENT) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "lid"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"lid\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "lid" as n)), s) -> (mk_anti n s : 'a_LIDENT) | _ -> assert false))) ]) ])) ()); Gram.extend (a_LABEL : 'a_LABEL Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | LABEL _ -> true | _ -> false), "LABEL _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | LABEL s -> (s : 'a_LABEL) | _ -> assert false))); ([ Gram.Skeyword "~"; Gram.Stoken (((function | ANTIQUOT ("", _) -> true | _ -> false), "ANTIQUOT (\"\", _)")); Gram.Skeyword ":" ], (Gram.Action.mk (fun _ (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" as n)), s) -> (mk_anti n s : 'a_LABEL) | _ -> assert false))) ]) ])) ()); Gram.extend (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | OPTLABEL _ -> true | _ -> false), "OPTLABEL _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | OPTLABEL s -> (s : 'a_OPTLABEL) | _ -> assert false))); ([ Gram.Skeyword "?"; Gram.Stoken (((function | ANTIQUOT ("", _) -> true | _ -> false), "ANTIQUOT (\"\", _)")); Gram.Skeyword ":" ], (Gram.Action.mk (fun _ (__camlp4_0 : Gram.Token.t) _ (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" as n)), s) -> (mk_anti n s : 'a_OPTLABEL) | _ -> assert false))) ]) ])) ()); Gram.extend (a_STRING : 'a_STRING Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | STRING (_, _) -> true | _ -> false), "STRING (_, _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | STRING (_, s) -> (s : 'a_STRING) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "str" | "`str"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"str\" | \"`str\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "str" | "`str" as n)), s) -> (mk_anti n s : 'a_STRING) | _ -> assert false))) ]) ])) ()); Gram.extend (string_list : 'string_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | STRING (_, _) -> true | _ -> false), "STRING (_, _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | STRING (_, x) -> (Ast.LCons (x, Ast.LNil) : 'string_list) | _ -> assert false))); ([ Gram.Stoken (((function | STRING (_, _) -> true | _ -> false), "STRING (_, _)")); Gram.Sself ], (Gram.Action.mk (fun (xs : 'string_list) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | STRING (_, x) -> (Ast.LCons (x, xs) : 'string_list) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "str_list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"str_list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT (("" | "str_list"), s) -> (Ast.LAnt (mk_anti "str_list" s) : 'string_list) | _ -> assert false))) ]) ])) ()); Gram.extend (value_let : 'value_let Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "value" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (() : 'value_let)))) ]) ])) ()); Gram.extend (value_val : 'value_val Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "value" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (() : 'value_val)))) ]) ])) ()); Gram.extend (semi : 'semi Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword ";" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (() : 'semi)))) ]) ])) ()); Gram.extend (expr_quot : 'expr_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.ExNil _loc : 'expr_quot)))); ([ Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) (_loc : Gram.Loc.t) -> (e : 'expr_quot)))); ([ Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Skeyword ";"; Gram.Snterm (Gram.Entry.obj (sem_expr : 'sem_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e2 : 'sem_expr) _ (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExSem (_loc, e1, e2) : 'expr_quot)))); ([ Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Skeyword ","; Gram.Snterm (Gram.Entry.obj (comma_expr : 'comma_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e2 : 'comma_expr) _ (e1 : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExCom (_loc, e1, e2) : 'expr_quot)))) ]) ])) ()); Gram.extend (patt_quot : 'patt_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.PaNil _loc : 'patt_quot)))); ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'patt) (_loc : Gram.Loc.t) -> (x : 'patt_quot)))); ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], (Gram.Action.mk (fun (y : 'patt) _ (x : 'patt) (_loc : Gram.Loc.t) -> (let i = match x with | Ast.PaAnt (loc, s) -> Ast.IdAnt (loc, s) | p -> Ast.ident_of_patt p in Ast.PaEq (_loc, i, y) : 'patt_quot)))); ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Skeyword ";"; Gram.Snterm (Gram.Entry.obj (sem_patt : 'sem_patt Gram.Entry.t)) ], (Gram.Action.mk (fun (y : 'sem_patt) _ (x : 'patt) (_loc : Gram.Loc.t) -> (Ast.PaSem (_loc, x, y) : 'patt_quot)))); ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Skeyword ","; Gram.Snterm (Gram.Entry.obj (comma_patt : 'comma_patt Gram.Entry.t)) ], (Gram.Action.mk (fun (y : 'comma_patt) _ (x : 'patt) (_loc : Gram.Loc.t) -> (Ast.PaCom (_loc, x, y) : 'patt_quot)))) ]) ])) ()); Gram.extend (ctyp_quot : 'ctyp_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.TyNil _loc : 'ctyp_quot)))); ([ Gram.Snterm (Gram.Entry.obj (more_ctyp : 'more_ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'more_ctyp) (_loc : Gram.Loc.t) -> (x : 'ctyp_quot)))); ([ Gram.Snterm (Gram.Entry.obj (more_ctyp : 'more_ctyp Gram.Entry.t)); Gram.Skeyword "and"; Gram.Snterm (Gram.Entry.obj (constructor_arg_list : 'constructor_arg_list Gram.Entry.t)) ], (Gram.Action.mk (fun (y : 'constructor_arg_list) _ (x : 'more_ctyp) (_loc : Gram.Loc.t) -> (Ast.TyAnd (_loc, x, y) : 'ctyp_quot)))); ([ Gram.Snterm (Gram.Entry.obj (more_ctyp : 'more_ctyp Gram.Entry.t)); Gram.Skeyword "&"; Gram.Snterm (Gram.Entry.obj (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (y : 'amp_ctyp) _ (x : 'more_ctyp) (_loc : Gram.Loc.t) -> (Ast.TyAmp (_loc, x, y) : 'ctyp_quot)))); ([ Gram.Snterm (Gram.Entry.obj (more_ctyp : 'more_ctyp Gram.Entry.t)); Gram.Skeyword "*"; Gram.Snterm (Gram.Entry.obj (star_ctyp : 'star_ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (y : 'star_ctyp) _ (x : 'more_ctyp) (_loc : Gram.Loc.t) -> (Ast.TySta (_loc, x, y) : 'ctyp_quot)))); ([ Gram.Snterm (Gram.Entry.obj (more_ctyp : 'more_ctyp Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (more_ctyp : 'more_ctyp Gram.Entry.t)); Gram.Skeyword ";"; Gram.Snterm (Gram.Entry.obj (label_declaration_list : 'label_declaration_list Gram.Entry.t)) ], (Gram.Action.mk (fun (z : 'label_declaration_list) _ (y : 'more_ctyp) _ (x : 'more_ctyp) (_loc : Gram.Loc.t) -> (Ast.TySem (_loc, (Ast.TyCol (_loc, x, y)), z) : 'ctyp_quot)))); ([ Gram.Snterm (Gram.Entry.obj (more_ctyp : 'more_ctyp Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (more_ctyp : 'more_ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (y : 'more_ctyp) _ (x : 'more_ctyp) (_loc : Gram.Loc.t) -> (Ast.TyCol (_loc, x, y) : 'ctyp_quot)))); ([ Gram.Snterm (Gram.Entry.obj (more_ctyp : 'more_ctyp Gram.Entry.t)); Gram.Skeyword "of"; Gram.Skeyword "&"; Gram.Snterm (Gram.Entry.obj (amp_ctyp : 'amp_ctyp Gram.Entry.t)); Gram.Skeyword "|"; Gram.Snterm (Gram.Entry.obj (row_field : 'row_field Gram.Entry.t)) ], (Gram.Action.mk (fun (z : 'row_field) _ (y : 'amp_ctyp) _ _ (x : 'more_ctyp) (_loc : Gram.Loc.t) -> (Ast.TyOr (_loc, (Ast.TyOfAmp (_loc, x, y)), z) : 'ctyp_quot)))); ([ Gram.Snterm (Gram.Entry.obj (more_ctyp : 'more_ctyp Gram.Entry.t)); Gram.Skeyword "of"; Gram.Skeyword "&"; Gram.Snterm (Gram.Entry.obj (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (y : 'amp_ctyp) _ _ (x : 'more_ctyp) (_loc : Gram.Loc.t) -> (Ast.TyOfAmp (_loc, x, y) : 'ctyp_quot)))); ([ Gram.Snterm (Gram.Entry.obj (more_ctyp : 'more_ctyp Gram.Entry.t)); Gram.Skeyword "of"; Gram.Snterm (Gram.Entry.obj (constructor_arg_list : 'constructor_arg_list Gram.Entry.t)); Gram.Skeyword "|"; Gram.Snterm (Gram.Entry.obj (constructor_declarations : 'constructor_declarations Gram.Entry.t)) ], (Gram.Action.mk (fun (z : 'constructor_declarations) _ (y : 'constructor_arg_list) _ (x : 'more_ctyp) (_loc : Gram.Loc.t) -> (Ast.TyOr (_loc, (Ast.TyOf (_loc, x, y)), z) : 'ctyp_quot)))); ([ Gram.Snterm (Gram.Entry.obj (more_ctyp : 'more_ctyp Gram.Entry.t)); Gram.Skeyword "of"; Gram.Snterm (Gram.Entry.obj (constructor_arg_list : 'constructor_arg_list Gram.Entry.t)) ], (Gram.Action.mk (fun (y : 'constructor_arg_list) _ (x : 'more_ctyp) (_loc : Gram.Loc.t) -> (Ast.TyOf (_loc, x, y) : 'ctyp_quot)))); ([ Gram.Snterm (Gram.Entry.obj (more_ctyp : 'more_ctyp Gram.Entry.t)); Gram.Skeyword "|"; Gram.Snterm (Gram.Entry.obj (constructor_declarations : 'constructor_declarations Gram.Entry.t)) ], (Gram.Action.mk (fun (y : 'constructor_declarations) _ (x : 'more_ctyp) (_loc : Gram.Loc.t) -> (Ast.TyOr (_loc, x, y) : 'ctyp_quot)))); ([ Gram.Snterm (Gram.Entry.obj (more_ctyp : 'more_ctyp Gram.Entry.t)); Gram.Skeyword ";"; Gram.Snterm (Gram.Entry.obj (label_declaration_list : 'label_declaration_list Gram.Entry.t)) ], (Gram.Action.mk (fun (y : 'label_declaration_list) _ (x : 'more_ctyp) (_loc : Gram.Loc.t) -> (Ast.TySem (_loc, x, y) : 'ctyp_quot)))); ([ Gram.Snterm (Gram.Entry.obj (more_ctyp : 'more_ctyp Gram.Entry.t)); Gram.Skeyword ","; Gram.Snterm (Gram.Entry.obj (comma_ctyp : 'comma_ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (y : 'comma_ctyp) _ (x : 'more_ctyp) (_loc : Gram.Loc.t) -> (Ast.TyCom (_loc, x, y) : 'ctyp_quot)))) ]) ])) ()); Gram.extend (more_ctyp : 'more_ctyp Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (type_parameter : 'type_parameter Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'type_parameter) (_loc : Gram.Loc.t) -> (x : 'more_ctyp)))); ([ Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'ctyp) (_loc : Gram.Loc.t) -> (x : 'more_ctyp)))); ([ Gram.Skeyword "`"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'a_ident) _ (_loc : Gram.Loc.t) -> (Ast.TyVrn (_loc, x) : 'more_ctyp)))); ([ Gram.Skeyword "mutable"; Gram.Sself ], (Gram.Action.mk (fun (x : 'more_ctyp) _ (_loc : Gram.Loc.t) -> (Ast.TyMut (_loc, x) : 'more_ctyp)))) ]) ])) ()); Gram.extend (str_item_quot : 'str_item_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.StNil _loc : 'str_item_quot)))); ([ Gram.Snterm (Gram.Entry.obj (str_item : 'str_item Gram.Entry.t)) ], (Gram.Action.mk (fun (st : 'str_item) (_loc : Gram.Loc.t) -> (st : 'str_item_quot)))); ([ Gram.Snterm (Gram.Entry.obj (str_item : 'str_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (st2 : 'str_item_quot) _ (st1 : 'str_item) (_loc : Gram.Loc.t) -> (match st2 with | Ast.StNil _ -> st1 | _ -> Ast.StSem (_loc, st1, st2) : 'str_item_quot)))); ([ Gram.Skeyword "#"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_expr : 'opt_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (dp : 'opt_expr) (n : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.StDir (_loc, n, dp) : 'str_item_quot)))) ]) ])) ()); Gram.extend (sig_item_quot : 'sig_item_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.SgNil _loc : 'sig_item_quot)))); ([ Gram.Snterm (Gram.Entry.obj (sig_item : 'sig_item Gram.Entry.t)) ], (Gram.Action.mk (fun (sg : 'sig_item) (_loc : Gram.Loc.t) -> (sg : 'sig_item_quot)))); ([ Gram.Snterm (Gram.Entry.obj (sig_item : 'sig_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (sg2 : 'sig_item_quot) _ (sg1 : 'sig_item) (_loc : Gram.Loc.t) -> (match sg2 with | Ast.SgNil _ -> sg1 | _ -> Ast.SgSem (_loc, sg1, sg2) : 'sig_item_quot)))); ([ Gram.Skeyword "#"; Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_expr : 'opt_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (dp : 'opt_expr) (n : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> (Ast.SgDir (_loc, n, dp) : 'sig_item_quot)))) ]) ])) ()); Gram.extend (module_type_quot : 'module_type_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.MtNil _loc : 'module_type_quot)))); ([ Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'module_type) (_loc : Gram.Loc.t) -> (x : 'module_type_quot)))) ]) ])) ()); Gram.extend (module_expr_quot : 'module_expr_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.MeNil _loc : 'module_expr_quot)))); ([ Gram.Snterm (Gram.Entry.obj (module_expr : 'module_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'module_expr) (_loc : Gram.Loc.t) -> (x : 'module_expr_quot)))) ]) ])) ()); Gram.extend (match_case_quot : 'match_case_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.McNil _loc : 'match_case_quot)))); ([ Gram.Slist0sep ((Gram.Snterm (Gram.Entry.obj (match_case0 : 'match_case0 Gram.Entry.t))), (Gram.Skeyword "|")) ], (Gram.Action.mk (fun (x : 'match_case0 list) (_loc : Gram.Loc.t) -> (Ast.mcOr_of_list x : 'match_case_quot)))) ]) ])) ()); Gram.extend (binding_quot : 'binding_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.BiNil _loc : 'binding_quot)))); ([ Gram.Snterm (Gram.Entry.obj (binding : 'binding Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'binding) (_loc : Gram.Loc.t) -> (x : 'binding_quot)))) ]) ])) ()); Gram.extend (rec_binding_quot : 'rec_binding_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.RbNil _loc : 'rec_binding_quot)))); ([ Gram.Snterm (Gram.Entry.obj (label_expr_list : 'label_expr_list Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'label_expr_list) (_loc : Gram.Loc.t) -> (x : 'rec_binding_quot)))) ]) ])) ()); Gram.extend (module_binding_quot : 'module_binding_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.MbNil _loc : 'module_binding_quot)))); ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (module_expr : 'module_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (me : 'module_expr) _ (mt : 'module_type) _ (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.MbColEq (_loc, m, mt, me) : 'module_binding_quot)))); ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)) ], (Gram.Action.mk (fun (mt : 'module_type) _ (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.MbCol (_loc, m, mt) : 'module_binding_quot)))); ([ Gram.Stoken (((function | ANTIQUOT ("", _) -> true | _ -> false), "ANTIQUOT (\"\", _)")); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (module_expr : 'module_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (me : 'module_expr) _ (mt : 'module_type) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" as n)), m) -> (Ast.MbColEq (_loc, (mk_anti n m), mt, me) : 'module_binding_quot) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("", _) -> true | _ -> false), "ANTIQUOT (\"\", _)")); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)) ], (Gram.Action.mk (fun (mt : 'module_type) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" as n)), m) -> (Ast.MbCol (_loc, (mk_anti n m), mt) : 'module_binding_quot) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT ("", _) -> true | _ -> false), "ANTIQUOT (\"\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" as n)), s) -> (Ast.MbAnt (_loc, (mk_anti ~c: "module_binding" n s)) : 'module_binding_quot) | _ -> assert false))); ([ Gram.Stoken (((function | ANTIQUOT (("module_binding" | "anti"), _) -> true | _ -> false), "ANTIQUOT ((\"module_binding\" | \"anti\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("module_binding" | "anti" as n)), s) -> (Ast.MbAnt (_loc, (mk_anti ~c: "module_binding" n s)) : 'module_binding_quot) | _ -> assert false))); ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], (Gram.Action.mk (fun (b2 : 'module_binding_quot) _ (b1 : 'module_binding_quot) (_loc : Gram.Loc.t) -> (Ast.MbAnd (_loc, b1, b2) : 'module_binding_quot)))) ]) ])) ()); Gram.extend (ident_quot : 'ident_quot Gram.Entry.t) ((fun () -> (None, [ ((Some "apply"), None, [ ([ Gram.Sself; Gram.Sself ], (Gram.Action.mk (fun (j : 'ident_quot) (i : 'ident_quot) (_loc : Gram.Loc.t) -> (Ast.IdApp (_loc, i, j) : 'ident_quot)))) ]); ((Some "."), None, [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (j : 'ident_quot) _ (i : 'ident_quot) (_loc : Gram.Loc.t) -> (Ast.IdAcc (_loc, i, j) : 'ident_quot)))) ]); ((Some "simple"), None, [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (i : 'ident_quot) _ (_loc : Gram.Loc.t) -> (i : 'ident_quot)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "id" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (i : 'ident_quot) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "id" | "anti" | "list" as n)), s) -> (Ast.IdAcc (_loc, (Ast.IdAnt (_loc, (mk_anti ~c: "ident" n s))), i) : 'ident_quot) | _ -> assert false))); ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> (Ast.IdLid (_loc, i) : 'ident_quot)))); ([ Gram.Snterm (Gram.Entry.obj (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> (Ast.IdUid (_loc, i) : 'ident_quot)))); ([ Gram.Stoken (((function | ANTIQUOT (("" | "id" | "anti" | "list"), _) -> true | _ -> false), "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("" | "id" | "anti" | "list" as n)), s) -> (Ast.IdAnt (_loc, (mk_anti ~c: "ident" n s)) : 'ident_quot) | _ -> assert false))) ]) ])) ()); Gram.extend (class_expr_quot : 'class_expr_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.CeNil _loc : 'class_expr_quot)))); ([ Gram.Snterm (Gram.Entry.obj (class_expr : 'class_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'class_expr) (_loc : Gram.Loc.t) -> (x : 'class_expr_quot)))); ([ Gram.Stoken (((function | ANTIQUOT ("virtual", _) -> true | _ -> false), "ANTIQUOT (\"virtual\", _)")); Gram.Snterm (Gram.Entry.obj (ident : 'ident Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (ot : 'opt_comma_ctyp) (i : 'ident) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("virtual" as n)), s) -> (let anti = Ast.ViAnt (mk_anti ~c: "class_expr" n s) in Ast.CeCon (_loc, anti, i, ot) : 'class_expr_quot) | _ -> assert false))); ([ Gram.Skeyword "virtual"; Gram.Snterm (Gram.Entry.obj (class_name_and_param : 'class_name_and_param Gram.Entry.t)) ], (Gram.Action.mk (fun ((i, ot) : 'class_name_and_param) _ (_loc : Gram.Loc.t) -> (Ast.CeCon (_loc, Ast.ViVirtual, (Ast.IdLid (_loc, i)), ot) : 'class_expr_quot)))); ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ], (Gram.Action.mk (fun (ce2 : 'class_expr_quot) _ (ce1 : 'class_expr_quot) (_loc : Gram.Loc.t) -> (Ast.CeEq (_loc, ce1, ce2) : 'class_expr_quot)))); ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], (Gram.Action.mk (fun (ce2 : 'class_expr_quot) _ (ce1 : 'class_expr_quot) (_loc : Gram.Loc.t) -> (Ast.CeAnd (_loc, ce1, ce2) : 'class_expr_quot)))) ]) ])) ()); Gram.extend (class_type_quot : 'class_type_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.CtNil _loc : 'class_type_quot)))); ([ Gram.Snterm (Gram.Entry.obj (class_type_plus : 'class_type_plus Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'class_type_plus) (_loc : Gram.Loc.t) -> (x : 'class_type_quot)))); ([ Gram.Stoken (((function | ANTIQUOT ("virtual", _) -> true | _ -> false), "ANTIQUOT (\"virtual\", _)")); Gram.Snterm (Gram.Entry.obj (ident : 'ident Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t)) ], (Gram.Action.mk (fun (ot : 'opt_comma_ctyp) (i : 'ident) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ((("virtual" as n)), s) -> (let anti = Ast.ViAnt (mk_anti ~c: "class_type" n s) in Ast.CtCon (_loc, anti, i, ot) : 'class_type_quot) | _ -> assert false))); ([ Gram.Skeyword "virtual"; Gram.Snterm (Gram.Entry.obj (class_name_and_param : 'class_name_and_param Gram.Entry.t)) ], (Gram.Action.mk (fun ((i, ot) : 'class_name_and_param) _ (_loc : Gram.Loc.t) -> (Ast.CtCon (_loc, Ast.ViVirtual, (Ast.IdLid (_loc, i)), ot) : 'class_type_quot)))); ([ Gram.Sself; Gram.Skeyword ":"; Gram.Sself ], (Gram.Action.mk (fun (ct2 : 'class_type_quot) _ (ct1 : 'class_type_quot) (_loc : Gram.Loc.t) -> (Ast.CtCol (_loc, ct1, ct2) : 'class_type_quot)))); ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ], (Gram.Action.mk (fun (ct2 : 'class_type_quot) _ (ct1 : 'class_type_quot) (_loc : Gram.Loc.t) -> (Ast.CtEq (_loc, ct1, ct2) : 'class_type_quot)))); ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], (Gram.Action.mk (fun (ct2 : 'class_type_quot) _ (ct1 : 'class_type_quot) (_loc : Gram.Loc.t) -> (Ast.CtAnd (_loc, ct1, ct2) : 'class_type_quot)))) ]) ])) ()); Gram.extend (class_str_item_quot : 'class_str_item_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.CrNil _loc : 'class_str_item_quot)))); ([ Gram.Snterm (Gram.Entry.obj (class_str_item : 'class_str_item Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'class_str_item) (_loc : Gram.Loc.t) -> (x : 'class_str_item_quot)))); ([ Gram.Snterm (Gram.Entry.obj (class_str_item : 'class_str_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (x2 : 'class_str_item_quot) _ (x1 : 'class_str_item) (_loc : Gram.Loc.t) -> (match x2 with | Ast.CrNil _ -> x1 | _ -> Ast.CrSem (_loc, x1, x2) : 'class_str_item_quot)))) ]) ])) ()); Gram.extend (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.CgNil _loc : 'class_sig_item_quot)))); ([ Gram.Snterm (Gram.Entry.obj (class_sig_item : 'class_sig_item Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'class_sig_item) (_loc : Gram.Loc.t) -> (x : 'class_sig_item_quot)))); ([ Gram.Snterm (Gram.Entry.obj (class_sig_item : 'class_sig_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (x2 : 'class_sig_item_quot) _ (x1 : 'class_sig_item) (_loc : Gram.Loc.t) -> (match x2 with | Ast.CgNil _ -> x1 | _ -> Ast.CgSem (_loc, x1, x2) : 'class_sig_item_quot)))) ]) ])) ()); Gram.extend (with_constr_quot : 'with_constr_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (Ast.WcNil _loc : 'with_constr_quot)))); ([ Gram.Snterm (Gram.Entry.obj (with_constr : 'with_constr Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'with_constr) (_loc : Gram.Loc.t) -> (x : 'with_constr_quot)))) ]) ])) ()); Gram.extend (rec_flag_quot : 'rec_flag_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (opt_rec : 'opt_rec Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'opt_rec) (_loc : Gram.Loc.t) -> (x : 'rec_flag_quot)))) ]) ])) ()); Gram.extend (direction_flag_quot : 'direction_flag_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (direction_flag : 'direction_flag Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'direction_flag) (_loc : Gram.Loc.t) -> (x : 'direction_flag_quot)))) ]) ])) ()); Gram.extend (mutable_flag_quot : 'mutable_flag_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (opt_mutable : 'opt_mutable Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'opt_mutable) (_loc : Gram.Loc.t) -> (x : 'mutable_flag_quot)))) ]) ])) ()); Gram.extend (private_flag_quot : 'private_flag_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (opt_private : 'opt_private Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'opt_private) (_loc : Gram.Loc.t) -> (x : 'private_flag_quot)))) ]) ])) ()); Gram.extend (virtual_flag_quot : 'virtual_flag_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (opt_virtual : 'opt_virtual Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'opt_virtual) (_loc : Gram.Loc.t) -> (x : 'virtual_flag_quot)))) ]) ])) ()); Gram.extend (row_var_flag_quot : 'row_var_flag_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'opt_dot_dot) (_loc : Gram.Loc.t) -> (x : 'row_var_flag_quot)))) ]) ])) ()); Gram.extend (override_flag_quot : 'override_flag_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (opt_override : 'opt_override Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'opt_override) (_loc : Gram.Loc.t) -> (x : 'override_flag_quot)))) ]) ])) ()); Gram.extend (patt_eoi : 'patt_eoi Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Stoken (((function | EOI -> true | _ -> false), "EOI")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (x : 'patt) (_loc : Gram.Loc.t) -> match __camlp4_0 with | EOI -> (x : 'patt_eoi) | _ -> assert false))) ]) ])) ()); Gram.extend (expr_eoi : 'expr_eoi Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Stoken (((function | EOI -> true | _ -> false), "EOI")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (x : 'expr) (_loc : Gram.Loc.t) -> match __camlp4_0 with | EOI -> (x : 'expr_eoi) | _ -> assert false))) ]) ])) ())) end let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () end module Camlp4QuotationCommon = struct open Camlp4 (* -*- camlp4r -*- *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Nicolas Pouillard: initial version *) module Id = struct let name = "Camlp4QuotationCommon" let version = Sys.ocaml_version end module Make (Syntax : Sig.Camlp4Syntax) (TheAntiquotSyntax : Sig.Parser(Syntax.Ast).SIMPLE) = struct open Sig include Syntax (* Be careful an AntiquotSyntax module appears here *) module MetaLocHere = Ast.Meta.MetaLoc module MetaLoc = struct module Ast = Ast let loc_name = ref None let meta_loc_expr _loc loc = match !loc_name with | None -> Ast.ExId (_loc, (Ast.IdLid (_loc, !Loc.name))) | Some "here" -> MetaLocHere.meta_loc_expr _loc loc | Some x -> Ast.ExId (_loc, (Ast.IdLid (_loc, x))) let meta_loc_patt _loc _ = Ast.PaAny _loc end module MetaAst = Ast.Meta.Make(MetaLoc) module ME = MetaAst.Expr module MP = MetaAst.Patt let is_antiquot s = let len = String.length s in (len > 2) && ((s.[0] = '\\') && (s.[1] = '$')) let handle_antiquot_in_string s term parse loc decorate = if is_antiquot s then (let pos = String.index s ':' in let name = String.sub s 2 (pos - 2) and code = String.sub s (pos + 1) (((String.length s) - pos) - 1) in decorate name (parse loc code)) else term let antiquot_expander = object inherit Ast.map as super method patt = function | (Ast.PaAnt (_loc, s) | Ast.PaStr (_loc, s) as p) -> let mloc _loc = MetaLoc.meta_loc_patt _loc _loc in handle_antiquot_in_string s p TheAntiquotSyntax. parse_patt _loc (fun n p -> match n with | "antisig_item" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgAnt")))))), (mloc _loc))), p) | "antistr_item" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StAnt")))))), (mloc _loc))), p) | "antictyp" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyAnt")))))), (mloc _loc))), p) | "antipatt" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaAnt")))))), (mloc _loc))), p) | "antiexpr" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExAnt")))))), (mloc _loc))), p) | "antimodule_type" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtAnt")))))), (mloc _loc))), p) | "antimodule_expr" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MeAnt")))))), (mloc _loc))), p) | "anticlass_type" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtAnt")))))), (mloc _loc))), p) | "anticlass_expr" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeAnt")))))), (mloc _loc))), p) | "anticlass_sig_item" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgAnt")))))), (mloc _loc))), p) | "anticlass_str_item" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrAnt")))))), (mloc _loc))), p) | "antiwith_constr" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "WcAnt")))))), (mloc _loc))), p) | "antibinding" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "BiAnt")))))), (mloc _loc))), p) | "antirec_binding" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "RbAnt")))))), (mloc _loc))), p) | "antimatch_case" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "McAnt")))))), (mloc _loc))), p) | "antimodule_binding" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MbAnt")))))), (mloc _loc))), p) | "antiident" -> Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "IdAnt")))))), (mloc _loc))), p) | _ -> p) | p -> super#patt p method expr = function | (Ast.ExAnt (_loc, s) | Ast.ExStr (_loc, s) as e) -> let mloc _loc = MetaLoc.meta_loc_expr _loc _loc in handle_antiquot_in_string s e TheAntiquotSyntax. parse_expr _loc (fun n e -> match n with | "`int" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, "string_of_int")))), e) | "`int32" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Int32")), (Ast.IdLid (_loc, "to_string")))))), e) | "`int64" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Int64")), (Ast.IdLid (_loc, "to_string")))))), e) | "`nativeint" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Nativeint")), (Ast.IdLid (_loc, "to_string")))))), e) | "`flo" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Camlp4_import")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Oprint")), (Ast.IdLid (_loc, "float_repres")))))))), e) | "`str" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "safe_string_escaped")))))), e) | "`chr" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Char")), (Ast.IdLid (_loc, "escaped")))))), e) | "`bool" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "IdUid")))))), (mloc _loc))), (Ast.ExIfe (_loc, e, (Ast.ExStr (_loc, "True")), (Ast.ExStr (_loc, "False"))))) | "liststr_item" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "stSem_of_list")))))), e) | "listsig_item" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "sgSem_of_list")))))), e) | "listclass_sig_item" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "cgSem_of_list")))))), e) | "listclass_str_item" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "crSem_of_list")))))), e) | "listmodule_expr" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "meApp_of_list")))))), e) | "listmodule_type" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "mtApp_of_list")))))), e) | "listmodule_binding" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "mbAnd_of_list")))))), e) | "listbinding" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "biAnd_of_list")))))), e) | "listbinding;" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "biSem_of_list")))))), e) | "listrec_binding" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "rbSem_of_list")))))), e) | "listclass_type" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "ctAnd_of_list")))))), e) | "listclass_expr" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "ceAnd_of_list")))))), e) | "listident" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "idAcc_of_list")))))), e) | "listctypand" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "tyAnd_of_list")))))), e) | "listctyp;" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "tySem_of_list")))))), e) | "listctyp*" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "tySta_of_list")))))), e) | "listctyp|" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "tyOr_of_list")))))), e) | "listctyp," -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "tyCom_of_list")))))), e) | "listctyp&" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "tyAmp_of_list")))))), e) | "listwith_constr" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "wcAnd_of_list")))))), e) | "listmatch_case" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "mcOr_of_list")))))), e) | "listpatt," -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "paCom_of_list")))))), e) | "listpatt;" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "paSem_of_list")))))), e) | "listexpr," -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "exCom_of_list")))))), e) | "listexpr;" -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdLid (_loc, "exSem_of_list")))))), e) | "antisig_item" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "SgAnt")))))), (mloc _loc))), e) | "antistr_item" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "StAnt")))))), (mloc _loc))), e) | "antictyp" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "TyAnt")))))), (mloc _loc))), e) | "antipatt" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "PaAnt")))))), (mloc _loc))), e) | "antiexpr" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "ExAnt")))))), (mloc _loc))), e) | "antimodule_type" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MtAnt")))))), (mloc _loc))), e) | "antimodule_expr" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MeAnt")))))), (mloc _loc))), e) | "anticlass_type" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CtAnt")))))), (mloc _loc))), e) | "anticlass_expr" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CeAnt")))))), (mloc _loc))), e) | "anticlass_sig_item" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CgAnt")))))), (mloc _loc))), e) | "anticlass_str_item" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "CrAnt")))))), (mloc _loc))), e) | "antiwith_constr" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "WcAnt")))))), (mloc _loc))), e) | "antibinding" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "BiAnt")))))), (mloc _loc))), e) | "antirec_binding" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "RbAnt")))))), (mloc _loc))), e) | "antimatch_case" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "McAnt")))))), (mloc _loc))), e) | "antimodule_binding" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "MbAnt")))))), (mloc _loc))), e) | "antiident" -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, "IdAnt")))))), (mloc _loc))), e) | _ -> e) | e -> super#expr e end let add_quotation name entry mexpr mpatt = let entry_eoi = Gram.Entry.mk (Gram.Entry.name entry) in let parse_quot_string entry loc s = let q = !Camlp4_config.antiquotations in let () = Camlp4_config.antiquotations := true in let res = Gram.parse_string entry loc s in let () = Camlp4_config.antiquotations := q in res in let expand_expr loc loc_name_opt s = let ast = parse_quot_string entry_eoi loc s in let () = MetaLoc.loc_name := loc_name_opt in let meta_ast = mexpr loc ast in let exp_ast = antiquot_expander#expr meta_ast in exp_ast in let expand_str_item loc loc_name_opt s = let exp_ast = expand_expr loc loc_name_opt s in Ast.StExp (loc, exp_ast) in let expand_patt _loc loc_name_opt s = let ast = parse_quot_string entry_eoi _loc s in let meta_ast = mpatt _loc ast in let exp_ast = antiquot_expander#patt meta_ast in match loc_name_opt with | None -> exp_ast | Some name -> let rec subst_first_loc = (function | Ast.PaApp (_loc, (Ast.PaId (_, (Ast.IdAcc (_, (Ast.IdUid (_, "Ast")), (Ast.IdUid (_, u)))))), _) -> Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), (Ast.IdUid (_loc, u)))))), (Ast.PaId (_loc, (Ast.IdLid (_loc, name))))) | Ast.PaApp (_loc, a, b) -> Ast.PaApp (_loc, (subst_first_loc a), b) | p -> p) in subst_first_loc exp_ast in (Gram.extend (entry_eoi : 'entry_eoi Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (entry : 'entry Gram.Entry.t)); Gram.Stoken (((function | EOI -> true | _ -> false), "EOI")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (x : 'entry) (_loc : Gram.Loc.t) -> match __camlp4_0 with | EOI -> (x : 'entry_eoi) | _ -> assert false))) ]) ])) ()); Quotation.add name Quotation.DynAst.expr_tag expand_expr; Quotation.add name Quotation.DynAst.patt_tag expand_patt; Quotation.add name Quotation.DynAst.str_item_tag expand_str_item) let _ = add_quotation "sig_item" sig_item_quot ME.meta_sig_item MP. meta_sig_item let _ = add_quotation "str_item" str_item_quot ME.meta_str_item MP. meta_str_item let _ = add_quotation "ctyp" ctyp_quot ME.meta_ctyp MP.meta_ctyp let _ = add_quotation "patt" patt_quot ME.meta_patt MP.meta_patt let _ = add_quotation "expr" expr_quot ME.meta_expr MP.meta_expr let _ = add_quotation "module_type" module_type_quot ME.meta_module_type MP.meta_module_type let _ = add_quotation "module_expr" module_expr_quot ME.meta_module_expr MP.meta_module_expr let _ = add_quotation "class_type" class_type_quot ME.meta_class_type MP. meta_class_type let _ = add_quotation "class_expr" class_expr_quot ME.meta_class_expr MP. meta_class_expr let _ = add_quotation "class_sig_item" class_sig_item_quot ME. meta_class_sig_item MP.meta_class_sig_item let _ = add_quotation "class_str_item" class_str_item_quot ME. meta_class_str_item MP.meta_class_str_item let _ = add_quotation "with_constr" with_constr_quot ME.meta_with_constr MP.meta_with_constr let _ = add_quotation "binding" binding_quot ME.meta_binding MP. meta_binding let _ = add_quotation "rec_binding" rec_binding_quot ME.meta_rec_binding MP.meta_rec_binding let _ = add_quotation "match_case" match_case_quot ME.meta_match_case MP. meta_match_case let _ = add_quotation "module_binding" module_binding_quot ME. meta_module_binding MP.meta_module_binding let _ = add_quotation "ident" ident_quot ME.meta_ident MP.meta_ident let _ = add_quotation "rec_flag" rec_flag_quot ME.meta_rec_flag MP. meta_rec_flag let _ = add_quotation "private_flag" private_flag_quot ME.meta_private_flag MP.meta_private_flag let _ = add_quotation "row_var_flag" row_var_flag_quot ME.meta_row_var_flag MP.meta_row_var_flag let _ = add_quotation "mutable_flag" mutable_flag_quot ME.meta_mutable_flag MP.meta_mutable_flag let _ = add_quotation "virtual_flag" virtual_flag_quot ME.meta_virtual_flag MP.meta_virtual_flag let _ = add_quotation "override_flag" override_flag_quot ME. meta_override_flag MP.meta_override_flag let _ = add_quotation "direction_flag" direction_flag_quot ME. meta_direction_flag MP.meta_direction_flag end end module Q = struct open Camlp4 (* -*- camlp4r -*- *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) module Id = struct let name = "Camlp4QuotationExpander" let version = Sys.ocaml_version end module Make (Syntax : Sig.Camlp4Syntax) = struct module M = Camlp4QuotationCommon.Make(Syntax)(Syntax.AntiquotSyntax) include M end let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () end module Rp = struct open Camlp4 (* -*- camlp4r -*- *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 1998-2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) module Id : Sig.Id = struct let name = "Camlp4OCamlRevisedParserParser" let version = Sys.ocaml_version end module Make (Syntax : Sig.Camlp4Syntax) = struct open Sig include Syntax type spat_comp = | SpTrm of Loc.t * Ast.patt * Ast.expr option | SpNtr of Loc.t * Ast.patt * Ast.expr | SpStr of Loc.t * Ast.patt type sexp_comp = | SeTrm of Loc.t * Ast.expr | SeNtr of Loc.t * Ast.expr let stream_expr = Gram.Entry.mk "stream_expr" let stream_begin = Gram.Entry.mk "stream_begin" let stream_end = Gram.Entry.mk "stream_end" let stream_quot = Gram.Entry.mk "stream_quot" let parser_case = Gram.Entry.mk "parser_case" let parser_case_list = Gram.Entry.mk "parser_case_list" let strm_n = "__strm" let peek_fun _loc = Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdLid (_loc, "peek"))))) let junk_fun _loc = Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdLid (_loc, "junk"))))) (* Parsers. *) (* In syntax generated, many cases are optimisations. *) let rec pattern_eq_expression p e = match (p, e) with | (Ast.PaId (_, (Ast.IdLid (_, a))), Ast.ExId (_, (Ast.IdLid (_, b)))) -> a = b | (Ast.PaId (_, (Ast.IdUid (_, a))), Ast.ExId (_, (Ast.IdUid (_, b)))) -> a = b | (Ast.PaApp (_, p1, p2), Ast.ExApp (_, e1, e2)) -> (pattern_eq_expression p1 e1) && (pattern_eq_expression p2 e2) | _ -> false let is_raise e = match e with | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "raise")))), _) -> true | _ -> false let is_raise_failure e = match e with | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "raise")))), (Ast.ExId (_, (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), (Ast.IdUid (_, "Failure"))))))) -> true | _ -> false let rec handle_failure e = match e with | Ast.ExTry (_, _, (Ast.McArr (_, (Ast.PaId (_, (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), (Ast.IdUid (_, "Failure")))))), (Ast.ExNil _), e))) -> handle_failure e | Ast.ExMat (_, me, a) -> let rec match_case_handle_failure = (function | Ast.McOr (_, a1, a2) -> (match_case_handle_failure a1) && (match_case_handle_failure a2) | Ast.McArr (_, _, (Ast.ExNil _), e) -> handle_failure e | _ -> false) in (handle_failure me) && (match_case_handle_failure a) | Ast.ExLet (_, Ast.ReNil, bi, e) -> let rec binding_handle_failure = (function | Ast.BiAnd (_, b1, b2) -> (binding_handle_failure b1) && (binding_handle_failure b2) | Ast.BiEq (_, _, e) -> handle_failure e | _ -> false) in (binding_handle_failure bi) && (handle_failure e) | Ast.ExId (_, (Ast.IdLid (_, _))) | Ast.ExInt (_, _) | Ast.ExStr (_, _) | Ast.ExChr (_, _) | Ast.ExFun (_, _) | Ast.ExId (_, (Ast.IdUid (_, _))) -> true | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "raise")))), e) -> (match e with | Ast.ExId (_, (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), (Ast.IdUid (_, "Failure"))))) -> false | _ -> true) | Ast.ExApp (_, f, x) -> (is_constr_apply f) && ((handle_failure f) && (handle_failure x)) | _ -> false and is_constr_apply = function | Ast.ExId (_, (Ast.IdUid (_, _))) -> true | Ast.ExId (_, (Ast.IdLid (_, _))) -> false | Ast.ExApp (_, x, _) -> is_constr_apply x | _ -> false let rec subst v e = let _loc = Ast.loc_of_expr e in match e with | Ast.ExId (_, (Ast.IdLid (_, x))) -> let x = if x = v then strm_n else x in Ast.ExId (_loc, (Ast.IdLid (_loc, x))) | Ast.ExId (_, (Ast.IdUid (_, _))) -> e | Ast.ExInt (_, _) -> e | Ast.ExChr (_, _) -> e | Ast.ExStr (_, _) -> e | Ast.ExAcc (_, _, _) -> e | Ast.ExLet (_, rf, bi, e) -> Ast.ExLet (_loc, rf, (subst_binding v bi), (subst v e)) | Ast.ExApp (_, e1, e2) -> Ast.ExApp (_loc, (subst v e1), (subst v e2)) | Ast.ExTup (_, e) -> Ast.ExTup (_loc, (subst v e)) | Ast.ExCom (_, e1, e2) -> Ast.ExCom (_loc, (subst v e1), (subst v e2)) | _ -> raise Not_found and subst_binding v = function | Ast.BiAnd (_loc, b1, b2) -> Ast.BiAnd (_loc, (subst_binding v b1), (subst_binding v b2)) | Ast.BiEq (_loc, (Ast.PaId (_, (Ast.IdLid (_, v')))), e) -> Ast.BiEq (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, v')))), (if v = v' then e else subst v e)) | _ -> raise Not_found let stream_pattern_component skont ckont = function | SpTrm (_loc, p, None) -> Ast.ExMat (_loc, (Ast.ExApp (_loc, (peek_fun _loc), (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), (Ast.McOr (_loc, (Ast.McArr (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, "Some")))), p)), (Ast.ExNil _loc), (Ast.ExSeq (_loc, (Ast.ExSem (_loc, (Ast.ExApp (_loc, (junk_fun _loc), (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), skont)))))), (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), ckont))))) | SpTrm (_loc, p, (Some w)) -> Ast.ExMat (_loc, (Ast.ExApp (_loc, (peek_fun _loc), (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), (Ast.McOr (_loc, (Ast.McArr (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, "Some")))), p)), w, (Ast.ExSeq (_loc, (Ast.ExSem (_loc, (Ast.ExApp (_loc, (junk_fun _loc), (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), skont)))))), (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), ckont))))) | SpNtr (_loc, p, e) -> let e = (match e with | Ast.ExFun (_, (Ast.McArr (_, (Ast.PaTyc (_, (Ast.PaId (_, (Ast.IdLid (_, v)))), (Ast.TyApp (_, (Ast.TyId (_, (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), (Ast.IdLid (_, "t")))))), (Ast.TyAny _))))), (Ast.ExNil _), e))) when v = strm_n -> e | _ -> Ast.ExApp (_loc, e, (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))) in if pattern_eq_expression p skont then if is_raise_failure ckont then e else if handle_failure e then e else Ast.ExTry (_loc, e, (Ast.McArr (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdUid (_loc, "Failure")))))), (Ast.ExNil _loc), ckont))) else if is_raise_failure ckont then Ast.ExLet (_loc, Ast.ReNil, (Ast.BiEq (_loc, p, e)), skont) else if pattern_eq_expression (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, "Some")))), p)) skont then Ast.ExTry (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "Some")))), e)), (Ast.McArr (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdUid (_loc, "Failure")))))), (Ast.ExNil _loc), ckont))) else if is_raise ckont then (let tst = if handle_failure e then e else Ast.ExTry (_loc, e, (Ast.McArr (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdUid (_loc, "Failure")))))), (Ast.ExNil _loc), ckont))) in Ast.ExLet (_loc, Ast.ReNil, (Ast.BiEq (_loc, p, tst)), skont)) else Ast.ExMat (_loc, (Ast.ExTry (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "Some")))), e)), (Ast.McArr (_loc, (Ast.PaId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdUid (_loc, "Failure")))))), (Ast.ExNil _loc), (Ast.ExId (_loc, (Ast.IdUid (_loc, "None")))))))), (Ast.McOr (_loc, (Ast.McArr (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, "Some")))), p)), (Ast.ExNil _loc), skont)), (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), ckont))))) | SpStr (_loc, p) -> (try match p with | Ast.PaId (_, (Ast.IdLid (_, v))) -> subst v skont | _ -> raise Not_found with | Not_found -> Ast.ExLet (_loc, Ast.ReNil, (Ast.BiEq (_loc, p, (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), skont)) let rec stream_pattern _loc epo e ekont = function | [] -> (match epo with | Some ep -> Ast.ExLet (_loc, Ast.ReNil, (Ast.BiEq (_loc, ep, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdLid (_loc, "count")))))), (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))))), e) | _ -> e) | (spc, err) :: spcl -> let skont = let ekont err = let str = (match err with | Some estr -> estr | _ -> Ast.ExStr (_loc, "")) in Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, "raise")))), (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdUid (_loc, "Error")))))), str))) in stream_pattern _loc epo e ekont spcl in let ckont = ekont err in stream_pattern_component skont ckont spc let stream_patterns_term _loc ekont tspel = let pel = List.fold_right (fun (p, w, _loc, spcl, epo, e) acc -> let p = Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, "Some")))), p) in let e = let ekont err = let str = match err with | Some estr -> estr | _ -> Ast.ExStr (_loc, "") in Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, "raise")))), (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdUid (_loc, "Error")))))), str))) in let skont = stream_pattern _loc epo e ekont spcl in Ast.ExSeq (_loc, (Ast.ExSem (_loc, (Ast.ExApp (_loc, (junk_fun _loc), (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), skont))) in match w with | Some w -> Ast.McOr (_loc, (Ast.McArr (_loc, p, w, e)), acc) | None -> Ast.McOr (_loc, (Ast.McArr (_loc, p, (Ast.ExNil _loc), e)), acc)) tspel (Ast.McNil _loc) in Ast.ExMat (_loc, (Ast.ExApp (_loc, (peek_fun _loc), (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), (Ast.McOr (_loc, pel, (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), (ekont ())))))) let rec group_terms = function | ((SpTrm (_loc, p, w), None) :: spcl, epo, e) :: spel -> let (tspel, spel) = group_terms spel in (((p, w, _loc, spcl, epo, e) :: tspel), spel) | spel -> ([], spel) let rec parser_cases _loc = function | [] -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, "raise")))), (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdUid (_loc, "Failure"))))))) | spel -> (match group_terms spel with | ([], (spcl, epo, e) :: spel) -> stream_pattern _loc epo e (fun _ -> parser_cases _loc spel) spcl | (tspel, spel) -> stream_patterns_term _loc (fun _ -> parser_cases _loc spel) tspel) let cparser _loc bpo pc = let e = parser_cases _loc pc in let e = match bpo with | Some bp -> Ast.ExLet (_loc, Ast.ReNil, (Ast.BiEq (_loc, bp, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdLid (_loc, "count")))))), (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))))), e) | None -> e in let p = Ast.PaTyc (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, strm_n)))), (Ast.TyApp (_loc, (Ast.TyId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdLid (_loc, "t")))))), (Ast.TyAny _loc)))) in Ast.ExFun (_loc, (Ast.McArr (_loc, p, (Ast.ExNil _loc), e))) let cparser_match _loc me bpo pc = let pc = parser_cases _loc pc in let e = match bpo with | Some bp -> Ast.ExLet (_loc, Ast.ReNil, (Ast.BiEq (_loc, bp, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdLid (_loc, "count")))))), (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))))), pc) | None -> pc in let me = match me with | (Ast.ExSem (_loc, _, _) as e) -> Ast.ExSeq (_loc, e) | e -> e in match me with | Ast.ExId (_, (Ast.IdLid (_, x))) when x = strm_n -> e | _ -> Ast.ExLet (_loc, Ast.ReNil, (Ast.BiEq (_loc, (Ast.PaTyc (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, strm_n)))), (Ast.TyApp (_loc, (Ast.TyId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdLid (_loc, "t")))))), (Ast.TyAny _loc))))), me)), e) (* streams *) let rec not_computing = function | Ast.ExId (_, (Ast.IdLid (_, _))) | Ast.ExId (_, (Ast.IdUid (_, _))) | Ast.ExInt (_, _) | Ast.ExFlo (_, _) | Ast.ExChr (_, _) | Ast.ExStr (_, _) -> true | Ast.ExApp (_, x, y) -> (is_cons_apply_not_computing x) && (not_computing y) | _ -> false and is_cons_apply_not_computing = function | Ast.ExId (_, (Ast.IdUid (_, _))) -> true | Ast.ExId (_, (Ast.IdLid (_, _))) -> false | Ast.ExApp (_, x, y) -> (is_cons_apply_not_computing x) && (not_computing y) | _ -> false let slazy _loc e = match e with | Ast.ExApp (_, f, (Ast.ExId (_, (Ast.IdUid (_, "()"))))) -> (match f with | Ast.ExId (_, (Ast.IdLid (_, _))) -> f | _ -> Ast.ExFun (_loc, (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), e)))) | _ -> Ast.ExFun (_loc, (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), e))) let rec cstream gloc = function | [] -> let _loc = gloc in Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdLid (_loc, "sempty"))))) | [ SeTrm (_loc, e) ] -> if not_computing e then Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdLid (_loc, "ising")))))), e) else Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdLid (_loc, "lsing")))))), (slazy _loc e)) | SeTrm (_loc, e) :: secl -> if not_computing e then Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdLid (_loc, "icons")))))), e)), (cstream gloc secl)) else Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdLid (_loc, "lcons")))))), (slazy _loc e))), (cstream gloc secl)) | [ SeNtr (_loc, e) ] -> if not_computing e then e else Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdLid (_loc, "slazy")))))), (slazy _loc e)) | SeNtr (_loc, e) :: secl -> if not_computing e then Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdLid (_loc, "iapp")))))), e)), (cstream gloc secl)) else Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), (Ast.IdLid (_loc, "lapp")))))), (slazy _loc e))), (cstream gloc secl)) (* Syntax extensions in Revised Syntax grammar *) let _ = let _ = (expr : 'expr Gram.Entry.t) and _ = (parser_case_list : 'parser_case_list Gram.Entry.t) and _ = (parser_case : 'parser_case Gram.Entry.t) and _ = (stream_quot : 'stream_quot Gram.Entry.t) and _ = (stream_end : 'stream_end Gram.Entry.t) and _ = (stream_begin : 'stream_begin Gram.Entry.t) and _ = (stream_expr : 'stream_expr Gram.Entry.t) in let grammar_entry_create = Gram.Entry.mk in let stream_patt : 'stream_patt Gram.Entry.t = grammar_entry_create "stream_patt" and stream_expr_comp : 'stream_expr_comp Gram.Entry.t = grammar_entry_create "stream_expr_comp" and stream_expr_comp_list : 'stream_expr_comp_list Gram.Entry.t = grammar_entry_create "stream_expr_comp_list" and parser_ipatt : 'parser_ipatt Gram.Entry.t = grammar_entry_create "parser_ipatt" and stream_patt_comp : 'stream_patt_comp Gram.Entry.t = grammar_entry_create "stream_patt_comp" and stream_patt_comp_err_list : 'stream_patt_comp_err_list Gram.Entry.t = grammar_entry_create "stream_patt_comp_err_list" and stream_patt_comp_err : 'stream_patt_comp_err Gram.Entry.t = grammar_entry_create "stream_patt_comp_err" in (Gram.extend (expr : 'expr Gram.Entry.t) ((fun () -> ((Some (Camlp4.Sig.Grammar.Level "top")), [ (None, None, [ ([ Gram.Skeyword "match"; Gram.Snterm (Gram.Entry.obj (sequence : 'sequence Gram.Entry.t)); Gram.Skeyword "with"; Gram.Skeyword "parser"; Gram.Sopt (Gram.Snterm (Gram.Entry.obj (parser_ipatt : 'parser_ipatt Gram.Entry.t))); Gram.Snterm (Gram.Entry.obj (parser_case_list : 'parser_case_list Gram.Entry.t)) ], (Gram.Action.mk (fun (pcl : 'parser_case_list) (po : 'parser_ipatt option) _ _ (e : 'sequence) _ (_loc : Gram.Loc.t) -> (cparser_match _loc e po pcl : 'expr)))); ([ Gram.Skeyword "parser"; Gram.Sopt (Gram.Snterm (Gram.Entry.obj (parser_ipatt : 'parser_ipatt Gram.Entry.t))); Gram.Snterm (Gram.Entry.obj (parser_case_list : 'parser_case_list Gram.Entry.t)) ], (Gram.Action.mk (fun (pcl : 'parser_case_list) (po : 'parser_ipatt option) _ (_loc : Gram.Loc.t) -> (cparser _loc po pcl : 'expr)))) ]) ])) ()); Gram.extend (parser_case_list : 'parser_case_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (parser_case : 'parser_case Gram.Entry.t)) ], (Gram.Action.mk (fun (pc : 'parser_case) (_loc : Gram.Loc.t) -> ([ pc ] : 'parser_case_list)))); ([ Gram.Skeyword "["; Gram.Slist0sep ((Gram.Snterm (Gram.Entry.obj (parser_case : 'parser_case Gram.Entry.t))), (Gram.Skeyword "|")); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (pcl : 'parser_case list) _ (_loc : Gram.Loc.t) -> (pcl : 'parser_case_list)))) ]) ])) ()); Gram.extend (parser_case : 'parser_case Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (stream_begin : 'stream_begin Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (stream_patt : 'stream_patt Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (stream_end : 'stream_end Gram.Entry.t)); Gram.Sopt (Gram.Snterm (Gram.Entry.obj (parser_ipatt : 'parser_ipatt Gram.Entry.t))); Gram.Skeyword "->"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (po : 'parser_ipatt option) _ (sp : 'stream_patt) _ (_loc : Gram.Loc.t) -> ((sp, po, e) : 'parser_case)))) ]) ])) ()); Gram.extend (stream_begin : 'stream_begin Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "[:" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (() : 'stream_begin)))) ]) ])) ()); Gram.extend (stream_end : 'stream_end Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword ":]" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (() : 'stream_end)))) ]) ])) ()); Gram.extend (stream_quot : 'stream_quot Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "`" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (() : 'stream_quot)))) ]) ])) ()); Gram.extend (stream_expr : 'stream_expr Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) (_loc : Gram.Loc.t) -> (e : 'stream_expr)))) ]) ])) ()); Gram.extend (stream_patt : 'stream_patt Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> ([] : 'stream_patt)))); ([ Gram.Snterm (Gram.Entry.obj (stream_patt_comp : 'stream_patt_comp Gram.Entry.t)); Gram.Skeyword ";"; Gram.Snterm (Gram.Entry.obj (stream_patt_comp_err_list : 'stream_patt_comp_err_list Gram.Entry.t)) ], (Gram.Action.mk (fun (sp : 'stream_patt_comp_err_list) _ (spc : 'stream_patt_comp) (_loc : Gram.Loc.t) -> ((spc, None) :: sp : 'stream_patt)))); ([ Gram.Snterm (Gram.Entry.obj (stream_patt_comp : 'stream_patt_comp Gram.Entry.t)) ], (Gram.Action.mk (fun (spc : 'stream_patt_comp) (_loc : Gram.Loc.t) -> ([ (spc, None) ] : 'stream_patt)))) ]) ])) ()); Gram.extend (stream_patt_comp_err : 'stream_patt_comp_err Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (stream_patt_comp : 'stream_patt_comp Gram.Entry.t)); Gram.Sopt (Gram.srules stream_patt_comp_err [ ([ Gram.Skeyword "??"; Gram.Snterm (Gram.Entry.obj (stream_expr : 'stream_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'stream_expr) _ (_loc : Gram.Loc.t) -> (e : 'e__14)))) ]) ], (Gram.Action.mk (fun (eo : 'e__14 option) (spc : 'stream_patt_comp) (_loc : Gram.Loc.t) -> ((spc, eo) : 'stream_patt_comp_err)))) ]) ])) ()); Gram.extend (stream_patt_comp_err_list : 'stream_patt_comp_err_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (stream_patt_comp_err : 'stream_patt_comp_err Gram.Entry.t)); Gram.Skeyword ";"; Gram.Sself ], (Gram.Action.mk (fun (sp : 'stream_patt_comp_err_list) _ (spc : 'stream_patt_comp_err) (_loc : Gram.Loc.t) -> (spc :: sp : 'stream_patt_comp_err_list)))); ([ Gram.Snterm (Gram.Entry.obj (stream_patt_comp_err : 'stream_patt_comp_err Gram.Entry.t)); Gram.Skeyword ";" ], (Gram.Action.mk (fun _ (spc : 'stream_patt_comp_err) (_loc : Gram.Loc.t) -> ([ spc ] : 'stream_patt_comp_err_list)))); ([ Gram.Snterm (Gram.Entry.obj (stream_patt_comp_err : 'stream_patt_comp_err Gram.Entry.t)) ], (Gram.Action.mk (fun (spc : 'stream_patt_comp_err) (_loc : Gram.Loc.t) -> ([ spc ] : 'stream_patt_comp_err_list)))) ]) ])) ()); Gram.extend (stream_patt_comp : 'stream_patt_comp Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], (Gram.Action.mk (fun (p : 'patt) (_loc : Gram.Loc.t) -> (SpStr (_loc, p) : 'stream_patt_comp)))); ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (stream_expr : 'stream_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'stream_expr) _ (p : 'patt) (_loc : Gram.Loc.t) -> (SpNtr (_loc, p, e) : 'stream_patt_comp)))); ([ Gram.Snterm (Gram.Entry.obj (stream_quot : 'stream_quot Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Sopt (Gram.srules stream_patt_comp [ ([ Gram.Skeyword "when"; Gram.Snterm (Gram.Entry.obj (stream_expr : 'stream_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'stream_expr) _ (_loc : Gram.Loc.t) -> (e : 'e__15)))) ]) ], (Gram.Action.mk (fun (eo : 'e__15 option) (p : 'patt) _ (_loc : Gram.Loc.t) -> (SpTrm (_loc, p, eo) : 'stream_patt_comp)))) ]) ])) ()); Gram.extend (parser_ipatt : 'parser_ipatt Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "_" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.PaAny _loc : 'parser_ipatt)))); ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> (Ast.PaId (_loc, (Ast.IdLid (_loc, i))) : 'parser_ipatt)))) ]) ])) ()); Gram.extend (expr : 'expr Gram.Entry.t) ((fun () -> ((Some (Camlp4.Sig.Grammar.Level "simple")), [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (stream_begin : 'stream_begin Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (stream_expr_comp_list : 'stream_expr_comp_list Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (stream_end : 'stream_end Gram.Entry.t)) ], (Gram.Action.mk (fun _ (sel : 'stream_expr_comp_list) _ (_loc : Gram.Loc.t) -> (cstream _loc sel : 'expr)))); ([ Gram.Snterm (Gram.Entry.obj (stream_begin : 'stream_begin Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (stream_end : 'stream_end Gram.Entry.t)) ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> (cstream _loc [] : 'expr)))) ]) ])) ()); Gram.extend (stream_expr_comp_list : 'stream_expr_comp_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (stream_expr_comp : 'stream_expr_comp Gram.Entry.t)) ], (Gram.Action.mk (fun (se : 'stream_expr_comp) (_loc : Gram.Loc.t) -> ([ se ] : 'stream_expr_comp_list)))); ([ Gram.Snterm (Gram.Entry.obj (stream_expr_comp : 'stream_expr_comp Gram.Entry.t)); Gram.Skeyword ";" ], (Gram.Action.mk (fun _ (se : 'stream_expr_comp) (_loc : Gram.Loc.t) -> ([ se ] : 'stream_expr_comp_list)))); ([ Gram.Snterm (Gram.Entry.obj (stream_expr_comp : 'stream_expr_comp Gram.Entry.t)); Gram.Skeyword ";"; Gram.Sself ], (Gram.Action.mk (fun (sel : 'stream_expr_comp_list) _ (se : 'stream_expr_comp) (_loc : Gram.Loc.t) -> (se :: sel : 'stream_expr_comp_list)))) ]) ])) ()); Gram.extend (stream_expr_comp : 'stream_expr_comp Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (stream_expr : 'stream_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'stream_expr) (_loc : Gram.Loc.t) -> (SeNtr (_loc, e) : 'stream_expr_comp)))); ([ Gram.Snterm (Gram.Entry.obj (stream_quot : 'stream_quot Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (stream_expr : 'stream_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'stream_expr) _ (_loc : Gram.Loc.t) -> (SeTrm (_loc, e) : 'stream_expr_comp)))) ]) ])) ())) end module M = Register.OCamlSyntaxExtension(Id)(Make) end module G = struct open Camlp4 (* -*- camlp4r -*- *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) module Id = struct let name = "Camlp4GrammarParser" let version = Sys.ocaml_version end module Make (Syntax : Sig.Camlp4Syntax) = struct open Sig include Syntax module MetaLoc = Ast.Meta.MetaGhostLoc module MetaAst = Ast.Meta.Make(MetaLoc) module PP = Camlp4.Printers.OCaml.Make(Syntax) let pp = new PP.printer ~comments: false () let string_of_patt patt = let buf = Buffer.create 42 in let () = Format.bprintf buf "%a@?" pp#patt patt in let str = Buffer.contents buf in if str = "" then assert false else str let split_ext = ref false type loc = Loc.t type 'e name = { expr : 'e; tvar : string; loc : loc } type styp = | STlid of loc * string | STapp of loc * styp * styp | STquo of loc * string | STself of loc * string | STtok of loc | STstring_tok of loc | STtyp of Ast.ctyp type ('e, 'p) text = | TXmeta of loc * string * (('e, 'p) text) list * 'e * styp | TXlist of loc * bool * ('e, 'p) symbol * (('e, 'p) symbol) option | TXnext of loc | TXnterm of loc * 'e name * string option | TXopt of loc * ('e, 'p) text | TXtry of loc * ('e, 'p) text | TXrules of loc * (((('e, 'p) text) list) * 'e) list | TXself of loc | TXkwd of loc * string | TXtok of loc * 'e * string and (** The first is the match function expr, the second is the string description. The description string will be used for grammar insertion and left factoring. Keep this string normalized and well comparable. *) ('e, 'p) entry = { name : 'e name; pos : 'e option; levels : (('e, 'p) level) list } and ('e, 'p) level = { label : string option; assoc : 'e option; rules : (('e, 'p) rule) list } and ('e, 'p) rule = { prod : (('e, 'p) symbol) list; action : 'e option } and ('e, 'p) symbol = { used : string list; text : ('e, 'p) text; styp : styp; pattern : 'p option } type used = | Unused | UsedScanned | UsedNotScanned let _loc = Loc.ghost let gm = "Camlp4Grammar__" let mark_used modif ht n = try let rll = Hashtbl.find_all ht n in List.iter (fun (r, _) -> if !r == Unused then (r := UsedNotScanned; modif := true) else ()) rll with | Not_found -> () let rec mark_symbol modif ht symb = List.iter (fun e -> mark_used modif ht e) symb.used let check_use nl el = let ht = Hashtbl.create 301 in let modif = ref false in (List.iter (fun e -> let u = match e.name.expr with | Ast.ExId (_, (Ast.IdLid (_, _))) -> Unused | _ -> UsedNotScanned in Hashtbl.add ht e.name.tvar ((ref u), e)) el; List.iter (fun n -> try let rll = Hashtbl.find_all ht n.tvar in List.iter (fun (r, _) -> r := UsedNotScanned) rll with | _ -> ()) nl; modif := true; while !modif do modif := false; Hashtbl.iter (fun _ (r, e) -> if !r = UsedNotScanned then (r := UsedScanned; List.iter (fun level -> let rules = level.rules in List.iter (fun rule -> List.iter (fun s -> mark_symbol modif ht s) rule.prod) rules) e.levels) else ()) ht done; Hashtbl.iter (fun s (r, e) -> if !r = Unused then print_warning e.name.loc ("Unused local entry \"" ^ (s ^ "\"")) else ()) ht) let new_type_var = let i = ref 0 in fun () -> (incr i; "e__" ^ (string_of_int !i)) let used_of_rule_list rl = List.fold_left (fun nl r -> List.fold_left (fun nl s -> s.used @ nl) nl r.prod) [] rl let retype_rule_list_without_patterns _loc rl = try List.map (function | (* ...; [ "foo" ]; ... ==> ...; (x = [ "foo" ] -> Gram.Token.extract_string x); ... *) { prod = [ ({ pattern = None; styp = STtok _ } as s) ]; action = None } -> { prod = [ { (s) with pattern = Some (Ast.PaId (_loc, (Ast.IdLid (_loc, "x")))); } ]; action = Some (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Token")), (Ast.IdLid (_loc, "extract_string")))))))), (Ast.ExId (_loc, (Ast.IdLid (_loc, "x")))))); } | (* ...; [ symb ]; ... ==> ...; (x = [ symb ] -> x); ... *) { prod = [ ({ pattern = None } as s) ]; action = None } -> { prod = [ { (s) with pattern = Some (Ast.PaId (_loc, (Ast.IdLid (_loc, "x")))); } ]; action = Some (Ast.ExId (_loc, (Ast.IdLid (_loc, "x")))); } | (* ...; ([] -> a); ... *) ({ prod = []; action = Some _ } as r) -> r | _ -> raise Exit) rl with | Exit -> rl let meta_action = ref false let mklistexp _loc = let rec loop top = function | [] -> Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))) | e1 :: el -> let _loc = if top then _loc else Loc.merge (Ast.loc_of_expr e1) _loc in Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), e1)), (loop false el)) in loop true let mklistpat _loc = let rec loop top = function | [] -> Ast.PaId (_loc, (Ast.IdUid (_loc, "[]"))) | p1 :: pl -> let _loc = if top then _loc else Loc.merge (Ast.loc_of_patt p1) _loc in Ast.PaApp (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, "::")))), p1)), (loop false pl)) in loop true let rec expr_fa al = function | Ast.ExApp (_, f, a) -> expr_fa (a :: al) f | f -> (f, al) let rec make_ctyp styp tvar = match styp with | STlid (_loc, s) -> Ast.TyId (_loc, (Ast.IdLid (_loc, s))) | STapp (_loc, t1, t2) -> Ast.TyApp (_loc, (make_ctyp t1 tvar), (make_ctyp t2 tvar)) | STquo (_loc, s) -> Ast.TyQuo (_loc, s) | STself (_loc, x) -> if tvar = "" then Loc.raise _loc (Stream.Error ("'" ^ (x ^ "' illegal in anonymous entry level"))) else Ast.TyQuo (_loc, tvar) | STtok _loc -> Ast.TyId (_loc, (Ast.IdAcc (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Token")))), (Ast.IdLid (_loc, "t"))))) | STstring_tok _loc -> Ast.TyId (_loc, (Ast.IdLid (_loc, "string"))) | STtyp t -> t let make_ctyp_patt styp tvar patt = let styp = match styp with | STstring_tok _loc -> STtok _loc | t -> t in match make_ctyp styp tvar with | Ast.TyAny _ -> patt | t -> let _loc = Ast.loc_of_patt patt in Ast.PaTyc (_loc, patt, t) let make_ctyp_expr styp tvar expr = match make_ctyp styp tvar with | Ast.TyAny _ -> expr | t -> let _loc = Ast.loc_of_expr expr in Ast.ExTyc (_loc, expr, t) let text_of_action _loc psl rtvar act tvar = let locid = Ast.PaId (_loc, (Ast.IdLid (_loc, !Loc.name))) in let act = match act with | Some act -> act | None -> Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) in let (tok_match_pl, act, _) = List.fold_left (fun (((tok_match_pl, act, i) as accu)) -> function | { pattern = None } -> accu | { pattern = Some p } when Ast.is_irrefut_patt p -> accu | { pattern = Some (Ast.PaAli (_, (Ast.PaApp (_, _, (Ast.PaTup (_, (Ast.PaAny _))))), (Ast.PaId (_, (Ast.IdLid (_, s)))))) } -> (tok_match_pl, (Ast.ExLet (_loc, Ast.ReNil, (Ast.BiEq (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, s)))), (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Token")), (Ast.IdLid (_loc, "extract_string")))))))), (Ast.ExId (_loc, (Ast.IdLid (_loc, s)))))))), act)), i) | { pattern = Some p; text = TXtok (_, _, _) } -> let id = "__camlp4_" ^ (string_of_int i) in ((Some (match tok_match_pl with | None -> ((Ast.ExId (_loc, (Ast.IdLid (_loc, id)))), p) | Some ((tok_pl, match_pl)) -> ((Ast.ExCom (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, id)))), tok_pl)), (Ast.PaCom (_loc, p, match_pl))))), act, (succ i)) | _ -> accu) (None, act, 0) psl in let e = let e1 = Ast.ExTyc (_loc, act, (Ast.TyQuo (_loc, rtvar))) in let e2 = match tok_match_pl with | None -> e1 | Some ((Ast.ExCom (_, t1, t2), Ast.PaCom (_, p1, p2))) -> Ast.ExMat (_loc, (Ast.ExTup (_loc, (Ast.ExCom (_loc, t1, t2)))), (Ast.McOr (_loc, (Ast.McArr (_loc, (Ast.PaTup (_loc, (Ast.PaCom (_loc, p1, p2)))), (Ast.ExNil _loc), e1)), (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), (Ast.ExAsf _loc)))))) | Some ((tok, match_)) -> Ast.ExMat (_loc, tok, (Ast.McOr (_loc, (Ast.McArr (_loc, match_, (Ast.ExNil _loc), e1)), (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), (Ast.ExAsf _loc)))))) in Ast.ExFun (_loc, (Ast.McArr (_loc, (Ast.PaTyc (_loc, locid, (Ast.TyId (_loc, (Ast.IdAcc (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Loc")))), (Ast.IdLid (_loc, "t")))))))), (Ast.ExNil _loc), e2))) in let (txt, _) = List.fold_left (fun (txt, i) s -> match s.pattern with | None | Some (Ast.PaAny _) -> ((Ast.ExFun (_loc, (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), txt)))), i) | Some (Ast.PaAli (_, (Ast.PaApp (_, _, (Ast.PaTup (_, (Ast.PaAny _))))), p)) -> let p = make_ctyp_patt s.styp tvar p in ((Ast.ExFun (_loc, (Ast.McArr (_loc, p, (Ast.ExNil _loc), txt)))), i) | Some p when Ast.is_irrefut_patt p -> let p = make_ctyp_patt s.styp tvar p in ((Ast.ExFun (_loc, (Ast.McArr (_loc, p, (Ast.ExNil _loc), txt)))), i) | Some _ -> let p = make_ctyp_patt s.styp tvar (Ast.PaId (_loc, (Ast.IdLid (_loc, ("__camlp4_" ^ (string_of_int i)))))) in ((Ast.ExFun (_loc, (Ast.McArr (_loc, p, (Ast.ExNil _loc), txt)))), (succ i))) (e, 0) psl in let txt = if !meta_action then Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Obj")), (Ast.IdLid (_loc, "magic")))))), (MetaAst.Expr.meta_expr _loc txt)) else txt in Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Action")), (Ast.IdLid (_loc, "mk")))))))), txt) let srules loc t rl tvar = List.map (fun r -> let sl = List.map (fun s -> s.text) r.prod in let ac = text_of_action loc r.prod t r.action tvar in (sl, ac)) rl let rec make_expr entry tvar = function | TXmeta (_loc, n, tl, e, t) -> let el = List.fold_right (fun t el -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), (make_expr entry "" t))), el)) tl (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) in Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Smeta")))))), (Ast.ExStr (_loc, n)))), el)), (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Action")), (Ast.IdLid (_loc, "mk")))))))), (make_ctyp_expr t tvar e)))) | TXlist (_loc, min, t, ts) -> let txt = make_expr entry "" t.text in (match (min, ts) with | (false, None) -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Slist0")))))), txt) | (true, None) -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Slist1")))))), txt) | (false, Some s) -> let x = make_expr entry tvar s.text in Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Slist0sep")))))), txt)), x) | (true, Some s) -> let x = make_expr entry tvar s.text in Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Slist1sep")))))), txt)), x)) | TXnext _loc -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Snext"))))) | TXnterm (_loc, n, lev) -> (match lev with | Some lab -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Snterml")))))), (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Entry")), (Ast.IdLid (_loc, "obj")))))))), (Ast.ExTyc (_loc, n.expr, (Ast.TyApp (_loc, (Ast.TyId (_loc, (Ast.IdAcc (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Entry")))), (Ast.IdLid (_loc, "t")))))), (Ast.TyQuo (_loc, n.tvar)))))))))), (Ast.ExStr (_loc, lab))) | None -> if n.tvar = tvar then Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Sself"))))) else Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Snterm")))))), (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Entry")), (Ast.IdLid (_loc, "obj")))))))), (Ast.ExTyc (_loc, n.expr, (Ast.TyApp (_loc, (Ast.TyId (_loc, (Ast.IdAcc (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Entry")))), (Ast.IdLid (_loc, "t")))))), (Ast.TyQuo (_loc, n.tvar)))))))))) | TXopt (_loc, t) -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Sopt")))))), (make_expr entry "" t)) | TXtry (_loc, t) -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Stry")))))), (make_expr entry "" t)) | TXrules (_loc, rl) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdLid (_loc, "srules")))))), entry.expr)), (make_expr_rules _loc entry rl "")) | TXself _loc -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Sself"))))) | TXkwd (_loc, kwd) -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Skeyword")))))), (Ast.ExStr (_loc, kwd))) | TXtok (_loc, match_fun, descr) -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Stoken")))))), (Ast.ExTup (_loc, (Ast.ExCom (_loc, match_fun, (Ast.ExStr (_loc, (Ast.safe_string_escaped descr)))))))) and make_expr_rules _loc n rl tvar = List.fold_left (fun txt (sl, ac) -> let sl = List.fold_right (fun t txt -> let x = make_expr n tvar t in Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), x)), txt)) sl (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) in Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), (Ast.ExTup (_loc, (Ast.ExCom (_loc, sl, ac)))))), txt)) (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) rl let expr_of_delete_rule _loc n sl = let sl = List.fold_right (fun s e -> Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), (make_expr n "" s.text))), e)) sl (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) in ((n.expr), sl) let rec tvar_of_ident = function | Ast.IdLid (_, x) | Ast.IdUid (_, x) -> x | Ast.IdAcc (_, (Ast.IdUid (_, x)), xs) -> x ^ ("__" ^ (tvar_of_ident xs)) | _ -> failwith "internal error in the Grammar extension" let mk_name _loc i = { expr = Ast.ExId (_loc, i); tvar = tvar_of_ident i; loc = _loc; } let slist loc min sep symb = TXlist (loc, min, symb, sep) (* value sstoken _loc s = let n = mk_name _loc <:ident< $lid:"a_" ^ s$ >> in TXnterm _loc n None ; value mk_symbol p s t = {used = []; text = s; styp = t; pattern=Some p}; value sslist _loc min sep s = let rl = let r1 = let prod = let n = mk_name _loc <:ident< a_list >> in [mk_symbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_list")] in let act = <:expr< a >> in {prod = prod; action = Some act} in let r2 = let prod = [mk_symbol <:patt< a >> (slist _loc min sep s) (STapp _loc (STlid _loc "list") s.styp)] in let act = <:expr< Qast.List a >> in {prod = prod; action = Some act} in [r1; r2] in let used = match sep with [ Some symb -> symb.used @ s.used | None -> s.used ] in let used = ["a_list" :: used] in let text = TXrules _loc (srules _loc "a_list" rl "") in let styp = STquo _loc "a_list" in {used = used; text = text; styp = styp; pattern = None} ; value ssopt _loc s = let rl = let r1 = let prod = let n = mk_name _loc <:ident< a_opt >> in [mk_symbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_opt")] in let act = <:expr< a >> in {prod = prod; action = Some act} in let r2 = let s = match s.text with [ TXkwd _loc _ | TXtok _loc _ _ -> let rl = [{prod = [{ (s) with pattern = Some <:patt< x >> }]; action = Some <:expr< Qast.Str (Token.extract_string x) >>}] in let t = new_type_var () in {used = []; text = TXrules _loc (srules _loc t rl ""); styp = STquo _loc t; pattern = None} | _ -> s ] in let prod = [mk_symbol <:patt< a >> (TXopt _loc s.text) (STapp _loc (STlid _loc "option") s.styp)] in let act = <:expr< Qast.Option a >> in {prod = prod; action = Some act} in [r1; r2] in let used = ["a_opt" :: s.used] in let text = TXrules _loc (srules _loc "a_opt" rl "") in let styp = STquo _loc "a_opt" in {used = used; text = text; styp = styp; pattern = None} ; *) let text_of_entry _loc e = let ent = let x = e.name in let _loc = e.name.loc in Ast.ExTyc (_loc, x.expr, (Ast.TyApp (_loc, (Ast.TyId (_loc, (Ast.IdAcc (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Entry")))), (Ast.IdLid (_loc, "t")))))), (Ast.TyQuo (_loc, x.tvar))))) in let pos = match e.pos with | Some pos -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "Some")))), pos) | None -> Ast.ExId (_loc, (Ast.IdUid (_loc, "None"))) in let txt = List.fold_right (fun level txt -> let lab = match level.label with | Some lab -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "Some")))), (Ast.ExStr (_loc, lab))) | None -> Ast.ExId (_loc, (Ast.IdUid (_loc, "None"))) in let ass = match level.assoc with | Some ass -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "Some")))), ass) | None -> Ast.ExId (_loc, (Ast.IdUid (_loc, "None"))) in let txt = let rl = srules _loc e.name.tvar level.rules e.name.tvar in let e = make_expr_rules _loc e.name rl e.name.tvar in Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), (Ast.ExTup (_loc, (Ast.ExCom (_loc, lab, (Ast.ExCom (_loc, ass, e)))))))), txt) in txt) e.levels (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) in (ent, pos, txt) let let_in_of_extend _loc gram gl el args = match gl with | None -> args | Some nl -> (check_use nl el; let ll = let same_tvar e n = e.name.tvar = n.tvar in List.fold_right (fun e ll -> match e.name.expr with | Ast.ExId (_, (Ast.IdLid (_, _))) -> if List.exists (same_tvar e) nl then ll else if List.exists (same_tvar e) ll then ll else e.name :: ll | _ -> ll) el [] in let local_binding_of_name { expr = e; tvar = x; loc = _loc } = let i = (match e with | Ast.ExId (_, (Ast.IdLid (_, i))) -> i | _ -> failwith "internal error in the Grammar extension") in Ast.BiEq (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, i)))), (Ast.ExTyc (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, "grammar_entry_create")))), (Ast.ExStr (_loc, i)))), (Ast.TyApp (_loc, (Ast.TyId (_loc, (Ast.IdAcc (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Entry")))), (Ast.IdLid (_loc, "t")))))), (Ast.TyQuo (_loc, x))))))) in let expr_of_name { expr = e; tvar = x; loc = _loc } = Ast.ExTyc (_loc, e, (Ast.TyApp (_loc, (Ast.TyId (_loc, (Ast.IdAcc (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdUid (_loc, "Entry")))), (Ast.IdLid (_loc, "t")))))), (Ast.TyQuo (_loc, x))))) in let e = (match ll with | [] -> args | x :: xs -> let locals = List.fold_right (fun name acc -> Ast.BiAnd (_loc, acc, (local_binding_of_name name))) xs (local_binding_of_name x) in let entry_mk = (match gram with | Some g -> Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Entry")), (Ast.IdLid (_loc, "mk")))))))), (Ast.ExId (_loc, g))) | None -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Entry")), (Ast.IdLid (_loc, "mk")))))))) in Ast.ExLet (_loc, Ast.ReNil, (Ast.BiEq (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, "grammar_entry_create")))), entry_mk)), (Ast.ExLet (_loc, Ast.ReNil, locals, args)))) in (match nl with | [] -> e | x :: xs -> let globals = List.fold_right (fun name acc -> Ast.BiAnd (_loc, acc, (Ast.BiEq (_loc, (Ast.PaAny _loc), (expr_of_name name))))) xs (Ast.BiEq (_loc, (Ast.PaAny _loc), (expr_of_name x))) in Ast.ExLet (_loc, Ast.ReNil, globals, e))) class subst gmod = object inherit Ast.map as super method ident = function | Ast.IdUid (_, x) when x = gm -> gmod | x -> super#ident x end let subst_gmod ast gmod = (new subst gmod)#expr ast let text_of_functorial_extend _loc gmod gram gl el = let args = let el = List.map (fun e -> let (ent, pos, txt) = text_of_entry e.name.loc e in let e = Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdLid (_loc, "extend")))))), ent)), (Ast.ExApp (_loc, (Ast.ExFun (_loc, (Ast.McArr (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, "()")))), (Ast.ExNil _loc), (Ast.ExTup (_loc, (Ast.ExCom (_loc, pos, txt)))))))), (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))))))) in if !split_ext then Ast.ExLet (_loc, Ast.ReNil, (Ast.BiEq (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, "aux")))), (Ast.ExFun (_loc, (Ast.McArr (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, "()")))), (Ast.ExNil _loc), e)))))), (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, "aux")))), (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))))))) else e) el in match el with | [] -> Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) | [ e ] -> e | e :: el -> Ast.ExSeq (_loc, (List.fold_left (fun acc x -> Ast.ExSem (_loc, acc, x)) e el)) in subst_gmod (let_in_of_extend _loc gram gl el args) gmod let wildcarder = object (self) inherit Ast.map as super method patt = function | Ast.PaId (_loc, (Ast.IdLid (_, _))) -> Ast.PaAny _loc | Ast.PaAli (_, p, _) -> self#patt p | p -> super#patt p end let mk_tok _loc p t = let p' = wildcarder#patt p in let match_fun = if Ast.is_irrefut_patt p' then Ast.ExFun (_loc, (Ast.McArr (_loc, p', (Ast.ExNil _loc), (Ast.ExId (_loc, (Ast.IdUid (_loc, "True"))))))) else Ast.ExFun (_loc, (Ast.McOr (_loc, (Ast.McArr (_loc, p', (Ast.ExNil _loc), (Ast.ExId (_loc, (Ast.IdUid (_loc, "True")))))), (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), (Ast.ExId (_loc, (Ast.IdUid (_loc, "False"))))))))) in let descr = string_of_patt p' in let text = TXtok (_loc, match_fun, descr) in { used = []; text = text; styp = t; pattern = Some p; } let symbol = Gram.Entry.mk "symbol" let check_not_tok s = match s with | { text = TXtok (_loc, _, _) } -> Loc.raise _loc (Stream.Error ("Deprecated syntax, use a sub rule. " ^ "LIST0 STRING becomes LIST0 [ x = STRING -> x ]")) | _ -> () let _ = Camlp4_config.antiquotations := true let _ = let _ = (expr : 'expr Gram.Entry.t) and _ = (symbol : 'symbol Gram.Entry.t) in let grammar_entry_create = Gram.Entry.mk in let extend_header : 'extend_header Gram.Entry.t = grammar_entry_create "extend_header" and semi_sep : 'semi_sep Gram.Entry.t = grammar_entry_create "semi_sep" and string : 'string Gram.Entry.t = grammar_entry_create "string" and name : 'name Gram.Entry.t = grammar_entry_create "name" and comma_patt : 'comma_patt Gram.Entry.t = grammar_entry_create "comma_patt" and pattern : 'pattern Gram.Entry.t = grammar_entry_create "pattern" and psymbol : 'psymbol Gram.Entry.t = grammar_entry_create "psymbol" and rule : 'rule Gram.Entry.t = grammar_entry_create "rule" and rule_list : 'rule_list Gram.Entry.t = grammar_entry_create "rule_list" and assoc : 'assoc Gram.Entry.t = grammar_entry_create "assoc" and level : 'level Gram.Entry.t = grammar_entry_create "level" and level_list : 'level_list Gram.Entry.t = grammar_entry_create "level_list" and position : 'position Gram.Entry.t = grammar_entry_create "position" and entry : 'entry Gram.Entry.t = grammar_entry_create "entry" and global : 'global Gram.Entry.t = grammar_entry_create "global" and t_qualid : 't_qualid Gram.Entry.t = grammar_entry_create "t_qualid" and qualid : 'qualid Gram.Entry.t = grammar_entry_create "qualid" and qualuid : 'qualuid Gram.Entry.t = grammar_entry_create "qualuid" and delete_rule_body : 'delete_rule_body Gram.Entry.t = grammar_entry_create "delete_rule_body" and extend_body : 'extend_body Gram.Entry.t = grammar_entry_create "extend_body" in (Gram.extend (expr : 'expr Gram.Entry.t) ((fun () -> ((Some (Camlp4.Sig.Grammar.After "top")), [ (None, None, [ ([ Gram.Skeyword "GEXTEND" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Loc.raise _loc (Stream.Error "Deprecated syntax, use EXTEND MyGramModule ... END instead") : 'expr)))); ([ Gram.Skeyword "GDELETE_RULE" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Loc.raise _loc (Stream.Error "Deprecated syntax, use DELETE_RULE MyGramModule ... END instead") : 'expr)))); ([ Gram.Skeyword "DELETE_RULE"; Gram.Snterm (Gram.Entry.obj (delete_rule_body : 'delete_rule_body Gram.Entry.t)); Gram.Skeyword "END" ], (Gram.Action.mk (fun _ (e : 'delete_rule_body) _ (_loc : Gram.Loc.t) -> (e : 'expr)))); ([ Gram.Skeyword "EXTEND"; Gram.Snterm (Gram.Entry.obj (extend_body : 'extend_body Gram.Entry.t)); Gram.Skeyword "END" ], (Gram.Action.mk (fun _ (e : 'extend_body) _ (_loc : Gram.Loc.t) -> (e : 'expr)))) ]) ])) ()); Gram.extend (extend_header : 'extend_header Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (qualuid : 'qualuid Gram.Entry.t)) ], (Gram.Action.mk (fun (g : 'qualuid) (_loc : Gram.Loc.t) -> ((None, g) : 'extend_header)))); ([ Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (qualid : 'qualid Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm (Gram.Entry.obj (t_qualid : 't_qualid Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (t : 't_qualid) _ (i : 'qualid) _ (_loc : Gram.Loc.t) -> (((Some i), t) : 'extend_header)))) ]) ])) ()); Gram.extend (extend_body : 'extend_body Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (extend_header : 'extend_header Gram.Entry.t)); Gram.Sopt (Gram.Snterm (Gram.Entry.obj (global : 'global Gram.Entry.t))); Gram.Slist1 (Gram.srules extend_body [ ([ Gram.Snterm (Gram.Entry.obj (entry : 'entry Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi_sep : 'semi_sep Gram.Entry.t)) ], (Gram.Action.mk (fun _ (e : 'entry) (_loc : Gram.Loc.t) -> (e : 'e__16)))) ]) ], (Gram.Action.mk (fun (el : 'e__16 list) (global_list : 'global option) ((gram, g) : 'extend_header) (_loc : Gram.Loc.t) -> (text_of_functorial_extend _loc g gram global_list el : 'extend_body)))) ]) ])) ()); Gram.extend (delete_rule_body : 'delete_rule_body Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (qualuid : 'qualuid Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (name : 'name Gram.Entry.t)); Gram.Skeyword ":"; Gram.Slist0sep ((Gram.Snterm (Gram.Entry.obj (symbol : 'symbol Gram.Entry.t))), (Gram.Snterm (Gram.Entry.obj (semi_sep : 'semi_sep Gram.Entry.t)))) ], (Gram.Action.mk (fun (sl : 'symbol list) _ (n : 'name) (g : 'qualuid) (_loc : Gram.Loc.t) -> (let (e, b) = expr_of_delete_rule _loc n sl in subst_gmod (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdLid (_loc, "delete_rule")))))), e)), b)) g : 'delete_rule_body)))) ]) ])) ()); Gram.extend (qualuid : 'qualuid Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.srules qualuid [ ([ Gram.Stoken (((function | UIDENT "GLOBAL" -> true | _ -> false), "UIDENT \"GLOBAL\"")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "GLOBAL" -> (() : 'e__17) | _ -> assert false))); ([ Gram.Stoken (((function | LIDENT ((_)) -> true | _ -> false), "LIDENT ((_))")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | LIDENT ((_)) -> (() : 'e__17) | _ -> assert false))) ] ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Loc.raise _loc (Stream.Error "Deprecated syntax, the grammar module is expected") : 'qualuid)))) ]); (None, None, [ ([ Gram.Stoken (((function | UIDENT ((_)) -> true | _ -> false), "UIDENT _")) ], (Gram.Action.mk (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> (let i = Gram.Token.extract_string i in Ast.IdUid (_loc, i) : 'qualuid)))); ([ Gram.Stoken (((function | UIDENT ((_)) -> true | _ -> false), "UIDENT _")); Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (xs : 'qualuid) _ (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (let x = Gram.Token.extract_string x in Ast.IdAcc (_loc, (Ast.IdUid (_loc, x)), xs) : 'qualuid)))) ]) ])) ()); Gram.extend (qualuid : 'qualuid Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.srules qualuid [ ([ Gram.Stoken (((function | UIDENT "GLOBAL" -> true | _ -> false), "UIDENT \"GLOBAL\"")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "GLOBAL" -> (() : 'e__18) | _ -> assert false))); ([ Gram.Stoken (((function | LIDENT ((_)) -> true | _ -> false), "LIDENT ((_))")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | LIDENT ((_)) -> (() : 'e__18) | _ -> assert false))) ] ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Loc.raise _loc (Stream.Error "Deprecated syntax, the grammar module is expected") : 'qualuid)))) ]); (None, None, [ ([ Gram.Stoken (((function | UIDENT ((_)) -> true | _ -> false), "UIDENT _")) ], (Gram.Action.mk (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> (let i = Gram.Token.extract_string i in Ast.IdUid (_loc, i) : 'qualuid)))); ([ Gram.Stoken (((function | UIDENT ((_)) -> true | _ -> false), "UIDENT _")); Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (xs : 'qualuid) _ (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (let x = Gram.Token.extract_string x in Ast.IdAcc (_loc, (Ast.IdUid (_loc, x)), xs) : 'qualuid)))) ]) ])) ()); Gram.extend (qualid : 'qualid Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | LIDENT ((_)) -> true | _ -> false), "LIDENT _")) ], (Gram.Action.mk (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> (let i = Gram.Token.extract_string i in Ast.IdLid (_loc, i) : 'qualid)))); ([ Gram.Stoken (((function | UIDENT ((_)) -> true | _ -> false), "UIDENT _")) ], (Gram.Action.mk (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> (let i = Gram.Token.extract_string i in Ast.IdUid (_loc, i) : 'qualid)))); ([ Gram.Stoken (((function | UIDENT ((_)) -> true | _ -> false), "UIDENT _")); Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (xs : 'qualid) _ (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (let x = Gram.Token.extract_string x in Ast.IdAcc (_loc, (Ast.IdUid (_loc, x)), xs) : 'qualid)))) ]) ])) ()); Gram.extend (t_qualid : 't_qualid Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | LIDENT _ | UIDENT _ -> true | _ -> false), "LIDENT _ | UIDENT _")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | LIDENT _ | UIDENT _ -> (Loc.raise _loc (Stream.Error ("Wrong EXTEND header, the grammar type must finish by 't', " ^ "like in EXTEND (g : Gram.t) ... END")) : 't_qualid) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT ((_)) -> true | _ -> false), "UIDENT _")); Gram.Skeyword "."; Gram.Stoken (((function | LIDENT "t" -> true | _ -> false), "LIDENT \"t\"")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) _ (x : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | LIDENT "t" -> (let x = Gram.Token.extract_string x in Ast.IdUid (_loc, x) : 't_qualid) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT ((_)) -> true | _ -> false), "UIDENT _")); Gram.Skeyword "."; Gram.Sself ], (Gram.Action.mk (fun (xs : 't_qualid) _ (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (let x = Gram.Token.extract_string x in Ast.IdAcc (_loc, (Ast.IdUid (_loc, x)), xs) : 't_qualid)))) ]) ])) ()); Gram.extend (global : 'global Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | UIDENT "GLOBAL" -> true | _ -> false), "UIDENT \"GLOBAL\"")); Gram.Skeyword ":"; Gram.Slist1 (Gram.Snterm (Gram.Entry.obj (name : 'name Gram.Entry.t))); Gram.Snterm (Gram.Entry.obj (semi_sep : 'semi_sep Gram.Entry.t)) ], (Gram.Action.mk (fun _ (sl : 'name list) _ (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "GLOBAL" -> (sl : 'global) | _ -> assert false))) ]) ])) ()); Gram.extend (entry : 'entry Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (name : 'name Gram.Entry.t)); Gram.Skeyword ":"; Gram.Sopt (Gram.Snterm (Gram.Entry.obj (position : 'position Gram.Entry.t))); Gram.Snterm (Gram.Entry.obj (level_list : 'level_list Gram.Entry.t)) ], (Gram.Action.mk (fun (ll : 'level_list) (pos : 'position option) _ (n : 'name) (_loc : Gram.Loc.t) -> ({ name = n; pos = pos; levels = ll; } : 'entry)))) ]) ])) ()); Gram.extend (position : 'position Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | UIDENT "LEVEL" -> true | _ -> false), "UIDENT \"LEVEL\"")); Gram.Snterm (Gram.Entry.obj (string : 'string Gram.Entry.t)) ], (Gram.Action.mk (fun (n : 'string) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "LEVEL" -> (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Camlp4")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Sig")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Grammar")), (Ast.IdUid (_loc, "Level")))))))))), n) : 'position) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT "AFTER" -> true | _ -> false), "UIDENT \"AFTER\"")); Gram.Snterm (Gram.Entry.obj (string : 'string Gram.Entry.t)) ], (Gram.Action.mk (fun (n : 'string) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "AFTER" -> (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Camlp4")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Sig")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Grammar")), (Ast.IdUid (_loc, "After")))))))))), n) : 'position) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT "BEFORE" -> true | _ -> false), "UIDENT \"BEFORE\"")); Gram.Snterm (Gram.Entry.obj (string : 'string Gram.Entry.t)) ], (Gram.Action.mk (fun (n : 'string) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "BEFORE" -> (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Camlp4")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Sig")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Grammar")), (Ast.IdUid (_loc, "Before")))))))))), n) : 'position) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT "LAST" -> true | _ -> false), "UIDENT \"LAST\"")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "LAST" -> (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Camlp4")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Sig")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Grammar")), (Ast.IdUid (_loc, "Last"))))))))) : 'position) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT "FIRST" -> true | _ -> false), "UIDENT \"FIRST\"")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "FIRST" -> (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Camlp4")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Sig")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Grammar")), (Ast.IdUid (_loc, "First"))))))))) : 'position) | _ -> assert false))) ]) ])) ()); Gram.extend (level_list : 'level_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "["; Gram.Slist0sep ((Gram.Snterm (Gram.Entry.obj (level : 'level Gram.Entry.t))), (Gram.Skeyword "|")); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (ll : 'level list) _ (_loc : Gram.Loc.t) -> (ll : 'level_list)))) ]) ])) ()); Gram.extend (level : 'level Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Sopt (Gram.srules level [ ([ Gram.Stoken (((function | STRING ((_)) -> true | _ -> false), "STRING _")) ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (let x = Gram.Token.extract_string x in x : 'e__19)))) ]); Gram.Sopt (Gram.Snterm (Gram.Entry.obj (assoc : 'assoc Gram.Entry.t))); Gram.Snterm (Gram.Entry.obj (rule_list : 'rule_list Gram.Entry.t)) ], (Gram.Action.mk (fun (rules : 'rule_list) (ass : 'assoc option) (lab : 'e__19 option) (_loc : Gram.Loc.t) -> ({ label = lab; assoc = ass; rules = rules; } : 'level)))) ]) ])) ()); Gram.extend (assoc : 'assoc Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | UIDENT "NONA" -> true | _ -> false), "UIDENT \"NONA\"")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "NONA" -> (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Camlp4")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Sig")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Grammar")), (Ast.IdUid (_loc, "NonA"))))))))) : 'assoc) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT "RIGHTA" -> true | _ -> false), "UIDENT \"RIGHTA\"")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "RIGHTA" -> (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Camlp4")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Sig")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Grammar")), (Ast.IdUid (_loc, "RightA"))))))))) : 'assoc) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT "LEFTA" -> true | _ -> false), "UIDENT \"LEFTA\"")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "LEFTA" -> (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Camlp4")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Sig")), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Grammar")), (Ast.IdUid (_loc, "LeftA"))))))))) : 'assoc) | _ -> assert false))) ]) ])) ()); Gram.extend (rule_list : 'rule_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "["; Gram.Slist1sep ((Gram.Snterm (Gram.Entry.obj (rule : 'rule Gram.Entry.t))), (Gram.Skeyword "|")); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (rules : 'rule list) _ (_loc : Gram.Loc.t) -> (retype_rule_list_without_patterns _loc rules : 'rule_list)))); ([ Gram.Skeyword "["; Gram.Skeyword "]" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> ([] : 'rule_list)))) ]) ])) ()); Gram.extend (rule : 'rule Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Slist0sep ((Gram.Snterm (Gram.Entry.obj (psymbol : 'psymbol Gram.Entry.t))), (Gram.Snterm (Gram.Entry.obj (semi_sep : 'semi_sep Gram.Entry.t)))) ], (Gram.Action.mk (fun (psl : 'psymbol list) (_loc : Gram.Loc.t) -> ({ prod = psl; action = None; } : 'rule)))); ([ Gram.Slist0sep ((Gram.Snterm (Gram.Entry.obj (psymbol : 'psymbol Gram.Entry.t))), (Gram.Snterm (Gram.Entry.obj (semi_sep : 'semi_sep Gram.Entry.t)))); Gram.Skeyword "->"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (act : 'expr) _ (psl : 'psymbol list) (_loc : Gram.Loc.t) -> ({ prod = psl; action = Some act; } : 'rule)))) ]) ])) ()); Gram.extend (psymbol : 'psymbol Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (symbol : 'symbol Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'symbol) (_loc : Gram.Loc.t) -> (s : 'psymbol)))); ([ Gram.Snterm (Gram.Entry.obj (pattern : 'pattern Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (symbol : 'symbol Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'symbol) _ (p : 'pattern) (_loc : Gram.Loc.t) -> (match s.pattern with | Some (Ast.PaApp (_, (Ast.PaId (_, (Ast.IdUid (_, u)))), (Ast.PaTup (_, (Ast.PaAny _))))) -> mk_tok _loc (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, u)))), p)) s.styp | _ -> { (s) with pattern = Some p; } : 'psymbol)))); ([ Gram.Stoken (((function | LIDENT ((_)) -> true | _ -> false), "LIDENT _")); Gram.Sopt (Gram.srules psymbol [ ([ Gram.Stoken (((function | UIDENT "LEVEL" -> true | _ -> false), "UIDENT \"LEVEL\"")); Gram.Stoken (((function | STRING ((_)) -> true | _ -> false), "STRING _")) ], (Gram.Action.mk (fun (s : Gram.Token.t) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "LEVEL" -> (let s = Gram.Token.extract_string s in s : 'e__20) | _ -> assert false))) ]) ], (Gram.Action.mk (fun (lev : 'e__20 option) (i : Gram.Token.t) (_loc : Gram.Loc.t) -> (let i = Gram.Token.extract_string i in let name = mk_name _loc (Ast.IdLid (_loc, i)) in let text = TXnterm (_loc, name, lev) in let styp = STquo (_loc, i) in { used = [ i ]; text = text; styp = styp; pattern = None; } : 'psymbol)))); ([ Gram.Stoken (((function | LIDENT ((_)) -> true | _ -> false), "LIDENT _")); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (symbol : 'symbol Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'symbol) _ (p : Gram.Token.t) (_loc : Gram.Loc.t) -> (let p = Gram.Token.extract_string p in match s.pattern with | Some ((Ast.PaApp (_, (Ast.PaId (_, (Ast.IdUid (_, u)))), (Ast.PaTup (_, (Ast.PaAny _)))) as p')) -> let match_fun = Ast.ExFun (_loc, (Ast.McOr (_loc, (Ast.McArr (_loc, p', (Ast.ExNil _loc), (Ast.ExId (_loc, (Ast.IdUid (_loc, "True")))))), (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), (Ast.ExId (_loc, (Ast.IdUid (_loc, "False"))))))))) in let p' = Ast.PaAli (_loc, p', (Ast.PaId (_loc, (Ast.IdLid (_loc, p))))) in let descr = u ^ " _" in let text = TXtok (_loc, match_fun, descr) in { (s) with text = text; pattern = Some p'; } | _ -> { (s) with pattern = Some (Ast.PaId (_loc, (Ast.IdLid (_loc, p)))); } : 'psymbol)))) ]) ])) ()); Gram.extend (symbol : 'symbol Gram.Entry.t) ((fun () -> (None, [ ((Some "top"), (Some Camlp4.Sig.Grammar.NonA), [ ([ Gram.Stoken (((function | UIDENT "TRY" -> true | _ -> false), "UIDENT \"TRY\"")); Gram.Sself ], (Gram.Action.mk (fun (s : 'symbol) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "TRY" -> (let text = TXtry (_loc, s.text) in { used = s.used; text = text; styp = s.styp; pattern = None; } : 'symbol) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT "OPT" -> true | _ -> false), "UIDENT \"OPT\"")); Gram.Sself ], (Gram.Action.mk (fun (s : 'symbol) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "OPT" -> (let () = check_not_tok s in let styp = STapp (_loc, (STlid (_loc, "option")), s.styp) in let text = TXopt (_loc, s.text) in { used = s.used; text = text; styp = styp; pattern = None; } : 'symbol) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT "LIST1" -> true | _ -> false), "UIDENT \"LIST1\"")); Gram.Sself; Gram.Sopt (Gram.srules symbol [ ([ Gram.Stoken (((function | UIDENT "SEP" -> true | _ -> false), "UIDENT \"SEP\"")); Gram.Snterm (Gram.Entry.obj (symbol : 'symbol Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'symbol) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "SEP" -> (t : 'e__22) | _ -> assert false))) ]) ], (Gram.Action.mk (fun (sep : 'e__22 option) (s : 'symbol) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "LIST1" -> (let () = check_not_tok s in let used = (match sep with | Some symb -> symb.used @ s.used | None -> s.used) in let styp = STapp (_loc, (STlid (_loc, "list")), s.styp) in let text = slist _loc true sep s in { used = used; text = text; styp = styp; pattern = None; } : 'symbol) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT "LIST0" -> true | _ -> false), "UIDENT \"LIST0\"")); Gram.Sself; Gram.Sopt (Gram.srules symbol [ ([ Gram.Stoken (((function | UIDENT "SEP" -> true | _ -> false), "UIDENT \"SEP\"")); Gram.Snterm (Gram.Entry.obj (symbol : 'symbol Gram.Entry.t)) ], (Gram.Action.mk (fun (t : 'symbol) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "SEP" -> (t : 'e__21) | _ -> assert false))) ]) ], (Gram.Action.mk (fun (sep : 'e__21 option) (s : 'symbol) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "LIST0" -> (let () = check_not_tok s in let used = (match sep with | Some symb -> symb.used @ s.used | None -> s.used) in let styp = STapp (_loc, (STlid (_loc, "list")), s.styp) in let text = slist _loc false sep s in { used = used; text = text; styp = styp; pattern = None; } : 'symbol) | _ -> assert false))) ]); (None, None, [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (s_t : 'symbol) _ (_loc : Gram.Loc.t) -> (s_t : 'symbol)))); ([ Gram.Snterm (Gram.Entry.obj (name : 'name Gram.Entry.t)); Gram.Sopt (Gram.srules symbol [ ([ Gram.Stoken (((function | UIDENT "LEVEL" -> true | _ -> false), "UIDENT \"LEVEL\"")); Gram.Stoken (((function | STRING ((_)) -> true | _ -> false), "STRING _")) ], (Gram.Action.mk (fun (s : Gram.Token.t) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "LEVEL" -> (let s = Gram.Token.extract_string s in s : 'e__24) | _ -> assert false))) ]) ], (Gram.Action.mk (fun (lev : 'e__24 option) (n : 'name) (_loc : Gram.Loc.t) -> ({ used = [ n.tvar ]; text = TXnterm (_loc, n, lev); styp = STquo (_loc, n.tvar); pattern = None; } : 'symbol)))); ([ Gram.Stoken (((function | UIDENT ((_)) -> true | _ -> false), "UIDENT _")); Gram.Skeyword "."; Gram.Snterm (Gram.Entry.obj (qualid : 'qualid Gram.Entry.t)); Gram.Sopt (Gram.srules symbol [ ([ Gram.Stoken (((function | UIDENT "LEVEL" -> true | _ -> false), "UIDENT \"LEVEL\"")); Gram.Stoken (((function | STRING ((_)) -> true | _ -> false), "STRING _")) ], (Gram.Action.mk (fun (s : Gram.Token.t) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "LEVEL" -> (let s = Gram.Token.extract_string s in s : 'e__23) | _ -> assert false))) ]) ], (Gram.Action.mk (fun (lev : 'e__23 option) (il : 'qualid) _ (i : Gram.Token.t) (_loc : Gram.Loc.t) -> (let i = Gram.Token.extract_string i in let n = mk_name _loc (Ast.IdAcc (_loc, (Ast.IdUid (_loc, i)), il)) in { used = [ n.tvar ]; text = TXnterm (_loc, n, lev); styp = STquo (_loc, n.tvar); pattern = None; } : 'symbol)))); ([ Gram.Stoken (((function | STRING ((_)) -> true | _ -> false), "STRING _")) ], (Gram.Action.mk (fun (s : Gram.Token.t) (_loc : Gram.Loc.t) -> (let s = Gram.Token.extract_string s in { used = []; text = TXkwd (_loc, s); styp = STtok _loc; pattern = None; } : 'symbol)))); ([ Gram.Stoken (((function | UIDENT ((_)) -> true | _ -> false), "UIDENT _")); Gram.Stoken (((function | ANTIQUOT ("", _) -> true | _ -> false), "ANTIQUOT (\"\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (x : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ("", s) -> (let x = Gram.Token.extract_string x in let e = AntiquotSyntax.parse_expr _loc s in let match_fun = Ast.ExFun (_loc, (Ast.McOr (_loc, (Ast.McArr (_loc, (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, x)))), (Ast.PaId (_loc, (Ast.IdLid (_loc, "camlp4_x")))))), (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdLid (_loc, "=")))), (Ast.ExId (_loc, (Ast.IdLid (_loc, "camlp4_x")))))), e)), (Ast.ExId (_loc, (Ast.IdUid (_loc, "True")))))), (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), (Ast.ExId (_loc, (Ast.IdUid (_loc, "False"))))))))) in let descr = "$" ^ (x ^ (" " ^ s)) in let text = TXtok (_loc, match_fun, descr) in let p = Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, x)))), (Ast.PaTup (_loc, (Ast.PaAny _loc)))) in { used = []; text = text; styp = STtok _loc; pattern = Some p; } : 'symbol) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT ((_)) -> true | _ -> false), "UIDENT _")); Gram.Stoken (((function | STRING ((_)) -> true | _ -> false), "STRING _")) ], (Gram.Action.mk (fun (s : Gram.Token.t) (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (let s = Gram.Token.extract_string s in let x = Gram.Token.extract_string x in mk_tok _loc (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, x)))), (Ast.PaStr (_loc, s)))) (STtok _loc) : 'symbol)))); ([ Gram.Stoken (((function | UIDENT ((_)) -> true | _ -> false), "UIDENT _")) ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (let x = Gram.Token.extract_string x in mk_tok _loc (Ast.PaApp (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, x)))), (Ast.PaTup (_loc, (Ast.PaAny _loc))))) (STstring_tok _loc) : 'symbol)))); ([ Gram.Skeyword "`"; Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], (Gram.Action.mk (fun (p : 'patt) _ (_loc : Gram.Loc.t) -> (mk_tok _loc p (STtok _loc) : 'symbol)))); ([ Gram.Skeyword "["; Gram.Slist0sep ((Gram.Snterm (Gram.Entry.obj (rule : 'rule Gram.Entry.t))), (Gram.Skeyword "|")); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (rl : 'rule list) _ (_loc : Gram.Loc.t) -> (let rl = retype_rule_list_without_patterns _loc rl in let t = new_type_var () in { used = used_of_rule_list rl; text = TXrules (_loc, (srules _loc t rl "")); styp = STquo (_loc, t); pattern = None; } : 'symbol)))); ([ Gram.Stoken (((function | UIDENT "NEXT" -> true | _ -> false), "UIDENT \"NEXT\"")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "NEXT" -> ({ used = []; text = TXnext _loc; styp = STself (_loc, "NEXT"); pattern = None; } : 'symbol) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT "SELF" -> true | _ -> false), "UIDENT \"SELF\"")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "SELF" -> ({ used = []; text = TXself _loc; styp = STself (_loc, "SELF"); pattern = None; } : 'symbol) | _ -> assert false))) ]) ])) ()); Gram.extend (pattern : 'pattern Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ","; Gram.Snterm (Gram.Entry.obj (comma_patt : 'comma_patt Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (p2 : 'comma_patt) _ (p1 : 'pattern) _ (_loc : Gram.Loc.t) -> (Ast.PaTup (_loc, (Ast.PaCom (_loc, p1, p2))) : 'pattern)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (p : 'pattern) _ (_loc : Gram.Loc.t) -> (p : 'pattern)))); ([ Gram.Skeyword "_" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.PaAny _loc : 'pattern)))); ([ Gram.Stoken (((function | LIDENT ((_)) -> true | _ -> false), "LIDENT _")) ], (Gram.Action.mk (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> (let i = Gram.Token.extract_string i in Ast.PaId (_loc, (Ast.IdLid (_loc, i))) : 'pattern)))) ]) ])) ()); Gram.extend (comma_patt : 'comma_patt Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (pattern : 'pattern Gram.Entry.t)) ], (Gram.Action.mk (fun (p : 'pattern) (_loc : Gram.Loc.t) -> (p : 'comma_patt)))); ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], (Gram.Action.mk (fun (p2 : 'comma_patt) _ (p1 : 'comma_patt) (_loc : Gram.Loc.t) -> (Ast.PaCom (_loc, p1, p2) : 'comma_patt)))) ]) ])) ()); Gram.extend (name : 'name Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (qualid : 'qualid Gram.Entry.t)) ], (Gram.Action.mk (fun (il : 'qualid) (_loc : Gram.Loc.t) -> (mk_name _loc il : 'name)))) ]) ])) ()); Gram.extend (string : 'string Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | ANTIQUOT ("", _) -> true | _ -> false), "ANTIQUOT (\"\", _)")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | ANTIQUOT ("", s) -> (AntiquotSyntax.parse_expr _loc s : 'string) | _ -> assert false))); ([ Gram.Stoken (((function | STRING ((_)) -> true | _ -> false), "STRING _")) ], (Gram.Action.mk (fun (s : Gram.Token.t) (_loc : Gram.Loc.t) -> (let s = Gram.Token.extract_string s in Ast.ExStr (_loc, s) : 'string)))) ]) ])) ()); Gram.extend (semi_sep : 'semi_sep Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword ";" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (() : 'semi_sep)))) ]) ])) ())) (* EXTEND Gram symbol: LEVEL "top" [ NONA [ min = [ UIDENT "SLIST0" -> False | UIDENT "SLIST1" -> True ]; s = SELF; sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> sslist _loc min sep s | UIDENT "SOPT"; s = SELF -> ssopt _loc s ] ] ; END; *) let sfold _loc n foldfun f e s = let styp = STquo (_loc, (new_type_var ())) in let e = Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdLid (_loc, foldfun)))))), f)), e) in let t = STapp (_loc, (STapp (_loc, (STtyp (Ast.TyApp (_loc, (Ast.TyId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdLid (_loc, "fold")))))), (Ast.TyAny _loc)))), s.styp)), styp) in { used = s.used; text = TXmeta (_loc, n, [ s.text ], e, t); styp = styp; pattern = None; } let sfoldsep _loc n foldfun f e s sep = let styp = STquo (_loc, (new_type_var ())) in let e = Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdLid (_loc, foldfun)))))), f)), e) in let t = STapp (_loc, (STapp (_loc, (STtyp (Ast.TyApp (_loc, (Ast.TyId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), (Ast.IdLid (_loc, "foldsep")))))), (Ast.TyAny _loc)))), s.styp)), styp) in { used = s.used @ sep.used; text = TXmeta (_loc, n, [ s.text; sep.text ], e, t); styp = styp; pattern = None; } let _ = let _ = (symbol : 'symbol Gram.Entry.t) in let grammar_entry_create = Gram.Entry.mk in let simple_expr : 'simple_expr Gram.Entry.t = grammar_entry_create "simple_expr" in (Gram.extend (symbol : 'symbol Gram.Entry.t) ((fun () -> ((Some (Camlp4.Sig.Grammar.Level "top")), [ (None, None, [ ([ Gram.Stoken (((function | UIDENT "FOLD1" -> true | _ -> false), "UIDENT \"FOLD1\"")); Gram.Snterm (Gram.Entry.obj (simple_expr : 'simple_expr Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (simple_expr : 'simple_expr Gram.Entry.t)); Gram.Sself; Gram.Stoken (((function | UIDENT "SEP" -> true | _ -> false), "UIDENT \"SEP\"")); Gram.Sself ], (Gram.Action.mk (fun (sep : 'symbol) (__camlp4_1 : Gram.Token.t) (s : 'symbol) (e : 'simple_expr) (f : 'simple_expr) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match (__camlp4_1, __camlp4_0) with | (UIDENT "SEP", UIDENT "FOLD1") -> (sfoldsep _loc "FOLD1 SEP" "sfold1sep" f e s sep : 'symbol) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT "FOLD0" -> true | _ -> false), "UIDENT \"FOLD0\"")); Gram.Snterm (Gram.Entry.obj (simple_expr : 'simple_expr Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (simple_expr : 'simple_expr Gram.Entry.t)); Gram.Sself; Gram.Stoken (((function | UIDENT "SEP" -> true | _ -> false), "UIDENT \"SEP\"")); Gram.Sself ], (Gram.Action.mk (fun (sep : 'symbol) (__camlp4_1 : Gram.Token.t) (s : 'symbol) (e : 'simple_expr) (f : 'simple_expr) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match (__camlp4_1, __camlp4_0) with | (UIDENT "SEP", UIDENT "FOLD0") -> (sfoldsep _loc "FOLD0 SEP" "sfold0sep" f e s sep : 'symbol) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT "FOLD1" -> true | _ -> false), "UIDENT \"FOLD1\"")); Gram.Snterm (Gram.Entry.obj (simple_expr : 'simple_expr Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (simple_expr : 'simple_expr Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (s : 'symbol) (e : 'simple_expr) (f : 'simple_expr) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "FOLD1" -> (sfold _loc "FOLD1" "sfold1" f e s : 'symbol) | _ -> assert false))); ([ Gram.Stoken (((function | UIDENT "FOLD0" -> true | _ -> false), "UIDENT \"FOLD0\"")); Gram.Snterm (Gram.Entry.obj (simple_expr : 'simple_expr Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (simple_expr : 'simple_expr Gram.Entry.t)); Gram.Sself ], (Gram.Action.mk (fun (s : 'symbol) (e : 'simple_expr) (f : 'simple_expr) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT "FOLD0" -> (sfold _loc "FOLD0" "sfold0" f e s : 'symbol) | _ -> assert false))) ]) ])) ()); Gram.extend (simple_expr : 'simple_expr Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "("; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (e : 'expr) _ (_loc : Gram.Loc.t) -> (e : 'simple_expr)))); ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> (Ast.ExId (_loc, (Ast.IdLid (_loc, i))) : 'simple_expr)))) ]) ])) ())) let _ = Options.add "-split_ext" (Arg.Set split_ext) "Split EXTEND by functions to turn around a PowerPC problem." let _ = Options.add "-split_gext" (Arg.Set split_ext) "Old name for the option -split_ext." let _ = Options.add "-meta_action" (Arg.Set meta_action) "Undocumented" end (* FIXME *) module M = Register.OCamlSyntaxExtension(Id)(Make) end module M = struct open Camlp4 (* -*- camlp4r -*- *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring * - Aleksey Nogin: extra features and bug fixes. * - Christopher Conway: extra feature (-D=) * - Jean-vincent Loddo: definitions inside IFs. *) module Id = struct let name = "Camlp4MacroParser" let version = Sys.ocaml_version end (* Added statements: At toplevel (structure item): DEFINE DEFINE = DEFINE () = IFDEF THEN [ ELSE ] (END | ENDIF) IFNDEF THEN [ ELSE ] (END | ENDIF) INCLUDE At toplevel (signature item): DEFINE IFDEF THEN [ ELSE ] (END | ENDIF) IFNDEF THEN [ ELSE ] (END | ENDIF) INCLUDE In expressions: IFDEF THEN [ ELSE ] (END | ENDIF) IFNDEF THEN [ ELSE ] (END | ENDIF) DEFINE = IN __FILE__ __LOCATION__ LOCATION_OF In patterns: IFDEF THEN ELSE (END | ENDIF) IFNDEF THEN ELSE (END | ENDIF) As Camlp4 options: -D or -D=expr define with optional value -U undefine it -I add to the search path for INCLUDE'd files After having used a DEFINE followed by "= ", you can use it in expressions *and* in patterns. If the expression defining the macro cannot be used as a pattern, there is an error message if it is used in a pattern. You can also define a local macro in an expression usigng the DEFINE ... IN form. Note that local macros have lowercase names and can not take parameters. If a macro is defined to = NOTHING, and then used as an argument to a function, this will be equivalent to function taking one less argument. Similarly, passing NOTHING as an argument to a macro is equivalent to "erasing" the corresponding parameter from the macro body. The toplevel statement INCLUDE can be used to include a file containing macro definitions and also any other toplevel items. The included files are looked up in directories passed in via the -I option, falling back to the current directory. The expression __FILE__ returns the current compiled file name. The expression __LOCATION__ returns the current location of itself. If used inside a macro, it returns the location where the macro is called. The expression (LOCATION_OF parameter) returns the location of the given macro parameter. It cannot be used outside a macro definition. *) open Camlp4 module Make (Syntax : Sig.Camlp4Syntax) = struct open Sig include Syntax type 'a item_or_def = | SdStr of 'a | SdDef of string * ((string list) * Ast.expr) option | SdUnd of string | SdITE of bool * ('a item_or_def) list * ('a item_or_def) list | SdLazy of 'a Lazy.t let rec list_remove x = function | (y, _) :: l when y = x -> l | d :: l -> d :: (list_remove x l) | [] -> [] let defined = ref [] let is_defined i = List.mem_assoc i !defined let bad_patt _loc = Loc.raise _loc (Failure "this macro cannot be used in a pattern (see its definition)") let substp _loc env = let rec loop = function | Ast.ExApp (_, e1, e2) -> Ast.PaApp (_loc, (loop e1), (loop e2)) | Ast.ExNil _ -> Ast.PaNil _loc | Ast.ExId (_, (Ast.IdLid (_, x))) -> (try List.assoc x env with | Not_found -> Ast.PaId (_loc, (Ast.IdLid (_loc, x)))) | Ast.ExId (_, (Ast.IdUid (_, x))) -> (try List.assoc x env with | Not_found -> Ast.PaId (_loc, (Ast.IdUid (_loc, x)))) | Ast.ExInt (_, x) -> Ast.PaInt (_loc, x) | Ast.ExStr (_, s) -> Ast.PaStr (_loc, s) | Ast.ExTup (_, x) -> Ast.PaTup (_loc, (loop x)) | Ast.ExCom (_, x1, x2) -> Ast.PaCom (_loc, (loop x1), (loop x2)) | Ast.ExRec (_, bi, (Ast.ExNil _)) -> let rec substbi = (function | Ast.RbSem (_, b1, b2) -> Ast.PaSem (_loc, (substbi b1), (substbi b2)) | Ast.RbEq (_, i, e) -> Ast.PaEq (_loc, i, (loop e)) | _ -> bad_patt _loc) in Ast.PaRec (_loc, (substbi bi)) | _ -> bad_patt _loc in loop class reloc _loc = object inherit Ast.map as super method loc = fun _ -> _loc end (* method _Loc_t _ = _loc; *) class subst _loc env = object inherit reloc _loc as super method expr = function | (Ast.ExId (_, (Ast.IdLid (_, x))) | Ast.ExId (_, (Ast.IdUid (_, x))) as e) -> (try List.assoc x env with | Not_found -> super#expr e) | (Ast.ExApp (_loc, (Ast.ExId (_, (Ast.IdUid (_, "LOCATION_OF")))), (Ast.ExId (_, (Ast.IdLid (_, x))))) | Ast.ExApp (_loc, (Ast.ExId (_, (Ast.IdUid (_, "LOCATION_OF")))), (Ast.ExId (_, (Ast.IdUid (_, x))))) as e) -> (try let loc = Ast.loc_of_expr (List.assoc x env) in let (a, b, c, d, e, f, g, h) = Loc.to_tuple loc in Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), (Ast.IdLid (_loc, "of_tuple")))))), (Ast.ExTup (_loc, (Ast.ExCom (_loc, (Ast.ExStr (_loc, (Ast.safe_string_escaped a))), (Ast.ExCom (_loc, (Ast.ExCom (_loc, (Ast.ExCom (_loc, (Ast.ExCom (_loc, (Ast.ExCom (_loc, (Ast.ExCom (_loc, (Ast.ExInt (_loc, (string_of_int b))), (Ast.ExInt (_loc, (string_of_int c))))), (Ast.ExInt (_loc, (string_of_int d))))), (Ast.ExInt (_loc, (string_of_int e))))), (Ast.ExInt (_loc, (string_of_int f))))), (Ast.ExInt (_loc, (string_of_int g))))), (if h then Ast.ExId (_loc, (Ast.IdUid (_loc, "True"))) else Ast.ExId (_loc, (Ast.IdUid (_loc, "False"))))))))))) with | Not_found -> super#expr e) | e -> super#expr e method patt = function | (Ast.PaId (_, (Ast.IdLid (_, x))) | Ast.PaId (_, (Ast.IdUid (_, x))) as p) -> (try substp _loc [] (List.assoc x env) with | Not_found -> super#patt p) | p -> super#patt p end let incorrect_number loc l1 l2 = Loc.raise loc (Failure (Printf.sprintf "expected %d parameters; found %d" (List.length l2) (List.length l1))) let define eo x = ((match eo with | Some (([], e)) -> (Gram.extend (expr : 'expr Gram.Entry.t) ((fun () -> ((Some (Camlp4.Sig.Grammar.Level "simple")), [ (None, None, [ ([ Gram.Stoken (((function | UIDENT camlp4_x when camlp4_x = x -> true | _ -> false), "$UIDENT x")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT ((_)) -> ((new reloc _loc)#expr e : 'expr) | _ -> assert false))) ]) ])) ()); Gram.extend (patt : 'patt Gram.Entry.t) ((fun () -> ((Some (Camlp4.Sig.Grammar.Level "simple")), [ (None, None, [ ([ Gram.Stoken (((function | UIDENT camlp4_x when camlp4_x = x -> true | _ -> false), "$UIDENT x")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT ((_)) -> (let p = substp _loc [] e in (new reloc _loc)#patt p : 'patt) | _ -> assert false))) ]) ])) ())) | Some ((sl, e)) -> (Gram.extend (expr : 'expr Gram.Entry.t) ((fun () -> ((Some (Camlp4.Sig.Grammar.Level "apply")), [ (None, None, [ ([ Gram.Stoken (((function | UIDENT camlp4_x when camlp4_x = x -> true | _ -> false), "$UIDENT x")); Gram.Sself ], (Gram.Action.mk (fun (param : 'expr) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT ((_)) -> (let el = (match param with | Ast.ExTup (_, e) -> Ast.list_of_expr e [] | e -> [ e ]) in if (List.length el) = (List.length sl) then (let env = List.combine sl el in (new subst _loc env)#expr e) else incorrect_number _loc el sl : 'expr) | _ -> assert false))) ]) ])) ()); Gram.extend (patt : 'patt Gram.Entry.t) ((fun () -> ((Some (Camlp4.Sig.Grammar.Level "simple")), [ (None, None, [ ([ Gram.Stoken (((function | UIDENT camlp4_x when camlp4_x = x -> true | _ -> false), "$UIDENT x")); Gram.Sself ], (Gram.Action.mk (fun (param : 'patt) (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | UIDENT ((_)) -> (let pl = (match param with | Ast.PaTup (_, p) -> Ast.list_of_patt p [] | p -> [ p ]) in if (List.length pl) = (List.length sl) then (let env = List.combine sl pl in let p = substp _loc env e in (new reloc _loc)#patt p) else incorrect_number _loc pl sl : 'patt) | _ -> assert false))) ]) ])) ())) | None -> ()); defined := (x, eo) :: !defined) let undef x = try ((let eo = List.assoc x !defined in match eo with | Some (([], _)) -> (Gram.delete_rule expr [ Gram.Stoken (((function | UIDENT camlp4_x when camlp4_x = x -> true | _ -> false), "$UIDENT x")) ]; Gram.delete_rule patt [ Gram.Stoken (((function | UIDENT camlp4_x when camlp4_x = x -> true | _ -> false), "$UIDENT x")) ]) | Some ((_, _)) -> (Gram.delete_rule expr [ Gram.Stoken (((function | UIDENT camlp4_x when camlp4_x = x -> true | _ -> false), "$UIDENT x")); Gram.Sself ]; Gram.delete_rule patt [ Gram.Stoken (((function | UIDENT camlp4_x when camlp4_x = x -> true | _ -> false), "$UIDENT x")); Gram.Sself ]) | None -> ()); defined := list_remove x !defined) with | Not_found -> () let parse_def s = match Gram.parse_string expr (Loc.mk "") s with | Ast.ExId (_, (Ast.IdUid (_, n))) -> define None n | Ast.ExApp (_, (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "=")))), (Ast.ExId (_, (Ast.IdUid (_, n)))))), e) -> define (Some (([], e))) n | _ -> invalid_arg s (* This is a list of directories to search for INCLUDE statements. *) let include_dirs = ref [] (* Add something to the above, make sure it ends with a slash. *) let add_include_dir str = if str <> "" then (let str = if (String.get str ((String.length str) - 1)) = '/' then str else str ^ "/" in include_dirs := !include_dirs @ [ str ]) else () let parse_include_file rule = let dir_ok file dir = Sys.file_exists (dir ^ file) in fun file -> let file = try (List.find (dir_ok file) (!include_dirs @ [ "./" ])) ^ file with | Not_found -> file in let ch = open_in file in let st = Stream.of_channel ch in Gram.parse rule (Loc.mk file) st let rec execute_macro nil cons = function | SdStr i -> i | SdDef (x, eo) -> (define eo x; nil) | SdUnd x -> (undef x; nil) | SdITE (b, l1, l2) -> execute_macro_list nil cons (if b then l1 else l2) | SdLazy l -> Lazy.force l and execute_macro_list nil cons = function | [] -> nil | hd :: tl -> (* The evaluation order is important here *) let il1 = execute_macro nil cons hd in let il2 = execute_macro_list nil cons tl in cons il1 il2 (* Stack of conditionals. *) let stack = Stack.create () (* Make an SdITE value by extracting the result of the test from the stack. *) let make_SdITE_result st1 st2 = let test = Stack.pop stack in SdITE (test, st1, st2) type branch = | Then | Else (* Execute macro only if it belongs to the currently active branch. *) let execute_macro_if_active_branch _loc nil cons branch macro_def = let test = Stack.top stack in let item = if (test && (branch = Then)) || ((not test) && (branch = Else)) then execute_macro nil cons macro_def else (* ignore the macro *) nil in SdStr item let _ = let _ = (expr : 'expr Gram.Entry.t) and _ = (sig_item : 'sig_item Gram.Entry.t) and _ = (str_item : 'str_item Gram.Entry.t) and _ = (patt : 'patt Gram.Entry.t) in let grammar_entry_create = Gram.Entry.mk in let macro_def : 'macro_def Gram.Entry.t = grammar_entry_create "macro_def" and uident : 'uident Gram.Entry.t = grammar_entry_create "uident" and opt_macro_value : 'opt_macro_value Gram.Entry.t = grammar_entry_create "opt_macro_value" and endif : 'endif Gram.Entry.t = grammar_entry_create "endif" and sglist_else : 'sglist_else Gram.Entry.t = grammar_entry_create "sglist_else" and sglist_then : 'sglist_then Gram.Entry.t = grammar_entry_create "sglist_then" and smlist_else : 'smlist_else Gram.Entry.t = grammar_entry_create "smlist_else" and smlist_then : 'smlist_then Gram.Entry.t = grammar_entry_create "smlist_then" and else_expr : 'else_expr Gram.Entry.t = grammar_entry_create "else_expr" and else_macro_def_sig : 'else_macro_def_sig Gram.Entry.t = grammar_entry_create "else_macro_def_sig" and else_macro_def : 'else_macro_def Gram.Entry.t = grammar_entry_create "else_macro_def" and uident_eval_ifndef : 'uident_eval_ifndef Gram.Entry.t = grammar_entry_create "uident_eval_ifndef" and uident_eval_ifdef : 'uident_eval_ifdef Gram.Entry.t = grammar_entry_create "uident_eval_ifdef" and macro_def_sig : 'macro_def_sig Gram.Entry.t = grammar_entry_create "macro_def_sig" in (Gram.extend (str_item : 'str_item Gram.Entry.t) ((fun () -> ((Some Camlp4.Sig.Grammar.First), [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (macro_def : 'macro_def Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'macro_def) (_loc : Gram.Loc.t) -> (execute_macro (Ast.StNil _loc) (fun a b -> Ast.StSem (_loc, a, b)) x : 'str_item)))) ]) ])) ()); Gram.extend (sig_item : 'sig_item Gram.Entry.t) ((fun () -> ((Some Camlp4.Sig.Grammar.First), [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (macro_def_sig : 'macro_def_sig Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'macro_def_sig) (_loc : Gram.Loc.t) -> (execute_macro (Ast.SgNil _loc) (fun a b -> Ast.SgSem (_loc, a, b)) x : 'sig_item)))) ]) ])) ()); Gram.extend (macro_def : 'macro_def Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "INCLUDE"; Gram.Stoken (((function | STRING ((_)) -> true | _ -> false), "STRING _")) ], (Gram.Action.mk (fun (fname : Gram.Token.t) _ (_loc : Gram.Loc.t) -> (let fname = Gram.Token.extract_string fname in SdLazy (lazy (parse_include_file str_items fname)) : 'macro_def)))); ([ Gram.Skeyword "IFNDEF"; Gram.Snterm (Gram.Entry.obj (uident_eval_ifndef : 'uident_eval_ifndef Gram.Entry.t)); Gram.Skeyword "THEN"; Gram.Snterm (Gram.Entry.obj (smlist_then : 'smlist_then Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (else_macro_def : 'else_macro_def Gram.Entry.t)) ], (Gram.Action.mk (fun (st2 : 'else_macro_def) (st1 : 'smlist_then) _ _ _ (_loc : Gram.Loc.t) -> (make_SdITE_result st1 st2 : 'macro_def)))); ([ Gram.Skeyword "IFDEF"; Gram.Snterm (Gram.Entry.obj (uident_eval_ifdef : 'uident_eval_ifdef Gram.Entry.t)); Gram.Skeyword "THEN"; Gram.Snterm (Gram.Entry.obj (smlist_then : 'smlist_then Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (else_macro_def : 'else_macro_def Gram.Entry.t)) ], (Gram.Action.mk (fun (st2 : 'else_macro_def) (st1 : 'smlist_then) _ _ _ (_loc : Gram.Loc.t) -> (make_SdITE_result st1 st2 : 'macro_def)))); ([ Gram.Skeyword "UNDEF"; Gram.Snterm (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'uident) _ (_loc : Gram.Loc.t) -> (SdUnd i : 'macro_def)))); ([ Gram.Skeyword "DEFINE"; Gram.Snterm (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (opt_macro_value : 'opt_macro_value Gram.Entry.t)) ], (Gram.Action.mk (fun (def : 'opt_macro_value) (i : 'uident) _ (_loc : Gram.Loc.t) -> (SdDef (i, def) : 'macro_def)))) ]) ])) ()); Gram.extend (macro_def_sig : 'macro_def_sig Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "INCLUDE"; Gram.Stoken (((function | STRING ((_)) -> true | _ -> false), "STRING _")) ], (Gram.Action.mk (fun (fname : Gram.Token.t) _ (_loc : Gram.Loc.t) -> (let fname = Gram.Token.extract_string fname in SdLazy (lazy (parse_include_file sig_items fname)) : 'macro_def_sig)))); ([ Gram.Skeyword "IFNDEF"; Gram.Snterm (Gram.Entry.obj (uident_eval_ifndef : 'uident_eval_ifndef Gram.Entry.t)); Gram.Skeyword "THEN"; Gram.Snterm (Gram.Entry.obj (sglist_then : 'sglist_then Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (else_macro_def_sig : 'else_macro_def_sig Gram.Entry.t)) ], (Gram.Action.mk (fun (sg2 : 'else_macro_def_sig) (sg1 : 'sglist_then) _ _ _ (_loc : Gram.Loc.t) -> (make_SdITE_result sg1 sg2 : 'macro_def_sig)))); ([ Gram.Skeyword "IFDEF"; Gram.Snterm (Gram.Entry.obj (uident_eval_ifdef : 'uident_eval_ifdef Gram.Entry.t)); Gram.Skeyword "THEN"; Gram.Snterm (Gram.Entry.obj (sglist_then : 'sglist_then Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (else_macro_def_sig : 'else_macro_def_sig Gram.Entry.t)) ], (Gram.Action.mk (fun (sg2 : 'else_macro_def_sig) (sg1 : 'sglist_then) _ _ _ (_loc : Gram.Loc.t) -> (make_SdITE_result sg1 sg2 : 'macro_def_sig)))); ([ Gram.Skeyword "UNDEF"; Gram.Snterm (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'uident) _ (_loc : Gram.Loc.t) -> (SdUnd i : 'macro_def_sig)))); ([ Gram.Skeyword "DEFINE"; Gram.Snterm (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'uident) _ (_loc : Gram.Loc.t) -> (SdDef (i, None) : 'macro_def_sig)))) ]) ])) ()); Gram.extend (uident_eval_ifdef : 'uident_eval_ifdef Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'uident) (_loc : Gram.Loc.t) -> (Stack.push (is_defined i) stack : 'uident_eval_ifdef)))) ]) ])) ()); Gram.extend (uident_eval_ifndef : 'uident_eval_ifndef Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], (Gram.Action.mk (fun (i : 'uident) (_loc : Gram.Loc.t) -> (Stack.push (not (is_defined i)) stack : 'uident_eval_ifndef)))) ]) ])) ()); Gram.extend (else_macro_def : 'else_macro_def Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> ([] : 'else_macro_def)))); ([ Gram.Skeyword "ELSE"; Gram.Snterm (Gram.Entry.obj (smlist_else : 'smlist_else Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], (Gram.Action.mk (fun _ (st : 'smlist_else) _ (_loc : Gram.Loc.t) -> (st : 'else_macro_def)))) ]) ])) ()); Gram.extend (else_macro_def_sig : 'else_macro_def_sig Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> ([] : 'else_macro_def_sig)))); ([ Gram.Skeyword "ELSE"; Gram.Snterm (Gram.Entry.obj (sglist_else : 'sglist_else Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], (Gram.Action.mk (fun _ (st : 'sglist_else) _ (_loc : Gram.Loc.t) -> (st : 'else_macro_def_sig)))) ]) ])) ()); Gram.extend (else_expr : 'else_expr Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : 'else_expr)))); ([ Gram.Skeyword "ELSE"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], (Gram.Action.mk (fun _ (e : 'expr) _ (_loc : Gram.Loc.t) -> (e : 'else_expr)))) ]) ])) ()); Gram.extend (smlist_then : 'smlist_then Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Slist1 (Gram.srules smlist_then [ ([ Gram.Snterm (Gram.Entry.obj (str_item : 'str_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (si : 'str_item) (_loc : Gram.Loc.t) -> (SdStr si : 'e__25)))); ([ Gram.Snterm (Gram.Entry.obj (macro_def : 'macro_def Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (d : 'macro_def) (_loc : Gram.Loc.t) -> (execute_macro_if_active_branch _loc (Ast.StNil _loc) (fun a b -> Ast.StSem (_loc, a, b)) Then d : 'e__25)))) ]) ], (Gram.Action.mk (fun (sml : 'e__25 list) (_loc : Gram.Loc.t) -> (sml : 'smlist_then)))) ]) ])) ()); Gram.extend (smlist_else : 'smlist_else Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Slist1 (Gram.srules smlist_else [ ([ Gram.Snterm (Gram.Entry.obj (str_item : 'str_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (si : 'str_item) (_loc : Gram.Loc.t) -> (SdStr si : 'e__26)))); ([ Gram.Snterm (Gram.Entry.obj (macro_def : 'macro_def Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (d : 'macro_def) (_loc : Gram.Loc.t) -> (execute_macro_if_active_branch _loc (Ast.StNil _loc) (fun a b -> Ast.StSem (_loc, a, b)) Else d : 'e__26)))) ]) ], (Gram.Action.mk (fun (sml : 'e__26 list) (_loc : Gram.Loc.t) -> (sml : 'smlist_else)))) ]) ])) ()); Gram.extend (sglist_then : 'sglist_then Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Slist1 (Gram.srules sglist_then [ ([ Gram.Snterm (Gram.Entry.obj (sig_item : 'sig_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (si : 'sig_item) (_loc : Gram.Loc.t) -> (SdStr si : 'e__27)))); ([ Gram.Snterm (Gram.Entry.obj (macro_def_sig : 'macro_def_sig Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (d : 'macro_def_sig) (_loc : Gram.Loc.t) -> (execute_macro_if_active_branch _loc (Ast.SgNil _loc) (fun a b -> Ast.SgSem (_loc, a, b)) Then d : 'e__27)))) ]) ], (Gram.Action.mk (fun (sgl : 'e__27 list) (_loc : Gram.Loc.t) -> (sgl : 'sglist_then)))) ]) ])) ()); Gram.extend (sglist_else : 'sglist_else Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Slist1 (Gram.srules sglist_else [ ([ Gram.Snterm (Gram.Entry.obj (sig_item : 'sig_item Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (si : 'sig_item) (_loc : Gram.Loc.t) -> (SdStr si : 'e__28)))); ([ Gram.Snterm (Gram.Entry.obj (macro_def_sig : 'macro_def_sig Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (d : 'macro_def_sig) (_loc : Gram.Loc.t) -> (execute_macro_if_active_branch _loc (Ast.SgNil _loc) (fun a b -> Ast.SgSem (_loc, a, b)) Else d : 'e__28)))) ]) ], (Gram.Action.mk (fun (sgl : 'e__28 list) (_loc : Gram.Loc.t) -> (sgl : 'sglist_else)))) ]) ])) ()); Gram.extend (endif : 'endif Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "ENDIF" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (() : 'endif)))); ([ Gram.Skeyword "END" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (() : 'endif)))) ]) ])) ()); Gram.extend (opt_macro_value : 'opt_macro_value Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([], (Gram.Action.mk (fun (_loc : Gram.Loc.t) -> (None : 'opt_macro_value)))); ([ Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> (Some (([], e)) : 'opt_macro_value)))); ([ Gram.Skeyword "("; Gram.Slist1sep ((Gram.srules opt_macro_value [ ([ Gram.Stoken (((function | LIDENT ((_)) -> true | _ -> false), "LIDENT _")) ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (let x = Gram.Token.extract_string x in x : 'e__29)))) ]), (Gram.Skeyword ",")); Gram.Skeyword ")"; Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ _ (pl : 'e__29 list) _ (_loc : Gram.Loc.t) -> (Some ((pl, e)) : 'opt_macro_value)))) ]) ])) ()); Gram.extend (expr : 'expr Gram.Entry.t) ((fun () -> ((Some (Camlp4.Sig.Grammar.Level "top")), [ (None, None, [ ([ Gram.Skeyword "DEFINE"; Gram.Stoken (((function | LIDENT ((_)) -> true | _ -> false), "LIDENT _")); Gram.Skeyword "="; Gram.Sself; Gram.Skeyword "IN"; Gram.Sself ], (Gram.Action.mk (fun (body : 'expr) _ (def : 'expr) _ (i : Gram.Token.t) _ (_loc : Gram.Loc.t) -> (let i = Gram.Token.extract_string i in (new subst _loc [ (i, def) ])#expr body : 'expr)))); ([ Gram.Skeyword "IFNDEF"; Gram.Snterm (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); Gram.Skeyword "THEN"; Gram.Sself; Gram.Snterm (Gram.Entry.obj (else_expr : 'else_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e2 : 'else_expr) (e1 : 'expr) _ (i : 'uident) _ (_loc : Gram.Loc.t) -> (if is_defined i then e2 else e1 : 'expr)))); ([ Gram.Skeyword "IFDEF"; Gram.Snterm (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); Gram.Skeyword "THEN"; Gram.Sself; Gram.Snterm (Gram.Entry.obj (else_expr : 'else_expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e2 : 'else_expr) (e1 : 'expr) _ (i : 'uident) _ (_loc : Gram.Loc.t) -> (if is_defined i then e1 else e2 : 'expr)))) ]) ])) ()); Gram.extend (patt : 'patt Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "IFNDEF"; Gram.Snterm (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); Gram.Skeyword "THEN"; Gram.Sself; Gram.Skeyword "ELSE"; Gram.Sself; Gram.Snterm (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], (Gram.Action.mk (fun _ (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _ (_loc : Gram.Loc.t) -> (if is_defined i then p2 else p1 : 'patt)))); ([ Gram.Skeyword "IFDEF"; Gram.Snterm (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); Gram.Skeyword "THEN"; Gram.Sself; Gram.Skeyword "ELSE"; Gram.Sself; Gram.Snterm (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], (Gram.Action.mk (fun _ (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _ (_loc : Gram.Loc.t) -> (if is_defined i then p1 else p2 : 'patt)))) ]) ])) ()); Gram.extend (uident : 'uident Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | UIDENT ((_)) -> true | _ -> false), "UIDENT _")) ], (Gram.Action.mk (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> (let i = Gram.Token.extract_string i in i : 'uident)))) ]) ])) ()); Gram.extend (* dirty hack to allow polymorphic variants using the introduced keywords. *) (expr : 'expr Gram.Entry.t) ((fun () -> ((Some (Camlp4.Sig.Grammar.Before "simple")), [ (None, None, [ ([ Gram.Skeyword "`"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> (Ast.ExVrn (_loc, s) : 'expr)))); ([ Gram.Skeyword "`"; Gram.srules expr [ ([ Gram.Skeyword "IN" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__30)))); ([ Gram.Skeyword "DEFINE" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__30)))); ([ Gram.Skeyword "ENDIF" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__30)))); ([ Gram.Skeyword "END" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__30)))); ([ Gram.Skeyword "ELSE" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__30)))); ([ Gram.Skeyword "THEN" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__30)))); ([ Gram.Skeyword "IFNDEF" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__30)))); ([ Gram.Skeyword "IFDEF" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__30)))) ] ], (Gram.Action.mk (fun (kwd : 'e__30) _ (_loc : Gram.Loc.t) -> (Ast.ExVrn (_loc, kwd) : 'expr)))) ]) ])) ()); Gram.extend (* idem *) (patt : 'patt Gram.Entry.t) ((fun () -> ((Some (Camlp4.Sig.Grammar.Before "simple")), [ (None, None, [ ([ Gram.Skeyword "`"; Gram.Snterm (Gram.Entry.obj (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> (Ast.PaVrn (_loc, s) : 'patt)))); ([ Gram.Skeyword "`"; Gram.srules patt [ ([ Gram.Skeyword "ENDIF" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__31)))); ([ Gram.Skeyword "END" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__31)))); ([ Gram.Skeyword "ELSE" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__31)))); ([ Gram.Skeyword "THEN" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__31)))); ([ Gram.Skeyword "IFNDEF" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__31)))); ([ Gram.Skeyword "IFDEF" ], (Gram.Action.mk (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> (Gram.Token.extract_string x : 'e__31)))) ] ], (Gram.Action.mk (fun (kwd : 'e__31) _ (_loc : Gram.Loc.t) -> (Ast.PaVrn (_loc, kwd) : 'patt)))) ]) ])) ())) let _ = Options.add "-D" (Arg.String parse_def) " Define for IFDEF instruction." let _ = Options.add "-U" (Arg.String undef) " Undefine for IFDEF instruction." let _ = Options.add "-I" (Arg.String add_include_dir) " Add a directory to INCLUDE search path." end let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () module MakeNothing (AstFilters : Camlp4.Sig.AstFilters) = struct open AstFilters open Ast (* Remove NOTHING and expanse __FILE__ and __LOCATION__ *) let map_expr = function | Ast.ExApp (_, e, (Ast.ExId (_, (Ast.IdUid (_, "NOTHING"))))) | Ast.ExFun (_, (Ast.McArr (_, (Ast.PaId (_, (Ast.IdUid (_, "NOTHING")))), (Ast.ExNil _), e))) -> e | Ast.ExId (_loc, (Ast.IdLid (_, "__FILE__"))) -> Ast.ExStr (_loc, (Ast.safe_string_escaped (Loc.file_name _loc))) | Ast.ExId (_loc, (Ast.IdLid (_, "__LOCATION__"))) -> let (a, b, c, d, e, f, g, h) = Loc.to_tuple _loc in Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), (Ast.IdLid (_loc, "of_tuple")))))), (Ast.ExTup (_loc, (Ast.ExCom (_loc, (Ast.ExStr (_loc, (Ast.safe_string_escaped a))), (Ast.ExCom (_loc, (Ast.ExCom (_loc, (Ast.ExCom (_loc, (Ast.ExCom (_loc, (Ast.ExCom (_loc, (Ast.ExCom (_loc, (Ast.ExInt (_loc, (string_of_int b))), (Ast.ExInt (_loc, (string_of_int c))))), (Ast.ExInt (_loc, (string_of_int d))))), (Ast.ExInt (_loc, (string_of_int e))))), (Ast.ExInt (_loc, (string_of_int f))))), (Ast.ExInt (_loc, (string_of_int g))))), (if h then Ast.ExId (_loc, (Ast.IdUid (_loc, "True"))) else Ast.ExId (_loc, (Ast.IdUid (_loc, "False"))))))))))) | e -> e let _ = register_str_item_filter (Ast.map_expr map_expr)#str_item end let _ = let module M = Camlp4.Register.AstFilter(Id)(MakeNothing) in () end module D = struct open Camlp4 (* -*- camlp4r -*- *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Nicolas Pouillard: initial version *) module Id = struct let name = "Camlp4DebugParser" let version = Sys.ocaml_version end module Make (Syntax : Sig.Camlp4Syntax) = struct open Sig include Syntax module StringSet = Set.Make(String) let debug_mode = try let str = Sys.getenv "STATIC_CAMLP4_DEBUG" in let rec loop acc i = try let pos = String.index_from str i ':' in loop (StringSet.add (String.sub str i (pos - i)) acc) (pos + 1) with | Not_found -> StringSet.add (String.sub str i ((String.length str) - i)) acc in let sections = loop StringSet.empty 0 in if StringSet.mem "*" sections then (fun _ -> true) else (fun x -> StringSet.mem x sections) with | Not_found -> (fun _ -> false) let rec apply accu = function | [] -> accu | x :: xs -> let _loc = Ast.loc_of_expr x in apply (Ast.ExApp (_loc, accu, x)) xs let mk_debug_mode _loc = function | None -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Debug")), (Ast.IdLid (_loc, "mode"))))) | Some m -> Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Debug")), (Ast.IdLid (_loc, "mode"))))))) let mk_debug _loc m fmt section args = let call = apply (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Debug")), (Ast.IdLid (_loc, "printf")))))), (Ast.ExStr (_loc, section)))), (Ast.ExStr (_loc, fmt)))) args in Ast.ExIfe (_loc, (Ast.ExApp (_loc, (mk_debug_mode _loc m), (Ast.ExStr (_loc, section)))), call, (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))))) let _ = let _ = (expr : 'expr Gram.Entry.t) in let grammar_entry_create = Gram.Entry.mk in let end_or_in : 'end_or_in Gram.Entry.t = grammar_entry_create "end_or_in" and start_debug : 'start_debug Gram.Entry.t = grammar_entry_create "start_debug" in (Gram.extend (expr : 'expr Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (start_debug : 'start_debug Gram.Entry.t)); Gram.Stoken (((function | LIDENT ((_)) -> true | _ -> false), "LIDENT _")); Gram.Stoken (((function | STRING ((_)) -> true | _ -> false), "STRING _")); Gram.Slist0 (Gram.Snterml ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), ".")); Gram.Snterm (Gram.Entry.obj (end_or_in : 'end_or_in Gram.Entry.t)) ], (Gram.Action.mk (fun (x : 'end_or_in) (args : 'expr list) (fmt : Gram.Token.t) (section : Gram.Token.t) (m : 'start_debug) (_loc : Gram.Loc.t) -> (let fmt = Gram.Token.extract_string fmt in let section = Gram.Token.extract_string section in match (x, (debug_mode section)) with | (None, false) -> Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) | (Some e, false) -> e | (None, _) -> mk_debug _loc m fmt section args | (Some e, _) -> Ast.ExLet (_loc, Ast.ReNil, (Ast.BiEq (_loc, (Ast.PaId (_loc, (Ast.IdUid (_loc, "()")))), (mk_debug _loc m fmt section args))), e) : 'expr)))) ]) ])) ()); Gram.extend (end_or_in : 'end_or_in Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Skeyword "in"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> (Some e : 'end_or_in)))); ([ Gram.Skeyword "end" ], (Gram.Action.mk (fun _ (_loc : Gram.Loc.t) -> (None : 'end_or_in)))) ]) ])) ()); Gram.extend (start_debug : 'start_debug Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Stoken (((function | LIDENT "camlp4_debug" -> true | _ -> false), "LIDENT \"camlp4_debug\"")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | LIDENT "camlp4_debug" -> (Some "Camlp4" : 'start_debug) | _ -> assert false))); ([ Gram.Stoken (((function | LIDENT "debug" -> true | _ -> false), "LIDENT \"debug\"")) ], (Gram.Action.mk (fun (__camlp4_0 : Gram.Token.t) (_loc : Gram.Loc.t) -> match __camlp4_0 with | LIDENT "debug" -> (None : 'start_debug) | _ -> assert false))) ]) ])) ())) end let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () end module L = struct open Camlp4 (* -*- camlp4r -*- *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Nao Hirokawa: initial version * - Nicolas Pouillard: revised syntax version *) module Id = struct let name = "Camlp4ListComprehension" let version = Sys.ocaml_version end module Make (Syntax : Sig.Camlp4Syntax) = struct open Sig include Syntax let rec loop n = function | [] -> None | [ (x, _) ] -> if n = 1 then Some x else None | _ :: l -> loop (n - 1) l let stream_peek_nth n strm = loop n (Stream.npeek n strm) (* usual trick *) let test_patt_lessminus = Gram.Entry.of_parser "test_patt_lessminus" (fun strm -> let rec skip_patt n = match stream_peek_nth n strm with | Some (KEYWORD "<-") -> n | Some (KEYWORD ("[" | "[<")) -> skip_patt ((ignore_upto "]" (n + 1)) + 1) | Some (KEYWORD "(") -> skip_patt ((ignore_upto ")" (n + 1)) + 1) | Some (KEYWORD "{") -> skip_patt ((ignore_upto "}" (n + 1)) + 1) | Some (KEYWORD ("as" | "::" | "," | "_")) | Some (LIDENT _ | UIDENT _) -> skip_patt (n + 1) | Some _ | None -> raise Stream.Failure and ignore_upto end_kwd n = match stream_peek_nth n strm with | Some (KEYWORD prm) when prm = end_kwd -> n | Some (KEYWORD ("[" | "[<")) -> ignore_upto end_kwd ((ignore_upto "]" (n + 1)) + 1) | Some (KEYWORD "(") -> ignore_upto end_kwd ((ignore_upto ")" (n + 1)) + 1) | Some (KEYWORD "{") -> ignore_upto end_kwd ((ignore_upto "}" (n + 1)) + 1) | Some _ -> ignore_upto end_kwd (n + 1) | None -> raise Stream.Failure in skip_patt 1) let map _loc p e l = match (p, e) with | (Ast.PaId (_, (Ast.IdLid (_, x))), Ast.ExId (_, (Ast.IdLid (_, y)))) when x = y -> l | _ -> if Ast.is_irrefut_patt p then Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "List")), (Ast.IdLid (_loc, "map")))))), (Ast.ExFun (_loc, (Ast.McArr (_loc, p, (Ast.ExNil _loc), e)))))), l) else Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "List")), (Ast.IdLid (_loc, "fold_right")))))), (Ast.ExFun (_loc, (Ast.McOr (_loc, (Ast.McArr (_loc, p, (Ast.ExId (_loc, (Ast.IdUid (_loc, "True")))), (Ast.ExApp (_loc, (Ast.ExFun (_loc, (Ast.McArr (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, "x")))), (Ast.ExNil _loc), (Ast.ExFun (_loc, (Ast.McArr (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, "xs")))), (Ast.ExNil _loc), (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), (Ast.ExId (_loc, (Ast.IdLid (_loc, "x")))))), (Ast.ExId (_loc, (Ast.IdLid (_loc, "xs")))))))))))))), e)))), (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), (Ast.ExFun (_loc, (Ast.McArr (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, "l")))), (Ast.ExNil _loc), (Ast.ExId (_loc, (Ast.IdLid (_loc, "l")))))))))))))))), l)), (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))))) let filter _loc p b l = if Ast.is_irrefut_patt p then Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "List")), (Ast.IdLid (_loc, "filter")))))), (Ast.ExFun (_loc, (Ast.McArr (_loc, p, (Ast.ExNil _loc), b)))))), l) else Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "List")), (Ast.IdLid (_loc, "filter")))))), (Ast.ExFun (_loc, (Ast.McOr (_loc, (Ast.McArr (_loc, p, (Ast.ExId (_loc, (Ast.IdUid (_loc, "True")))), b)), (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), (Ast.ExId (_loc, (Ast.IdUid (_loc, "False")))))))))))), l) let concat _loc l = Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "List")), (Ast.IdLid (_loc, "concat")))))), l) let rec compr _loc e = function | [ `gen ((p, l)) ] -> map _loc p e l | `gen ((p, l)) :: `cond b :: items -> compr _loc e ((`gen ((p, (filter _loc p b l)))) :: items) | `gen ((p, l)) :: ((`gen ((_, _)) :: _ as is)) -> concat _loc (map _loc p (compr _loc e is) l) | _ -> raise Stream.Failure let _ = Gram.delete_rule expr [ Gram.Skeyword "["; Gram.Snterm (Gram.Entry.obj (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t)); Gram.Skeyword "]" ] let is_revised = try (Gram.delete_rule expr [ Gram.Skeyword "["; Gram.Snterm (Gram.Entry.obj (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t)); Gram.Skeyword "::"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); Gram.Skeyword "]" ]; true) with | Not_found -> false let comprehension_or_sem_expr_for_list = Gram.Entry.mk "comprehension_or_sem_expr_for_list" let _ = let _ = (expr : 'expr Gram.Entry.t) and _ = (comprehension_or_sem_expr_for_list : 'comprehension_or_sem_expr_for_list Gram.Entry.t) in let grammar_entry_create = Gram.Entry.mk in let item : 'item Gram.Entry.t = grammar_entry_create "item" in (Gram.extend (expr : 'expr Gram.Entry.t) ((fun () -> ((Some (Camlp4.Sig.Grammar.Level "simple")), [ (None, None, [ ([ Gram.Skeyword "["; Gram.Snterm (Gram.Entry.obj (comprehension_or_sem_expr_for_list : 'comprehension_or_sem_expr_for_list Gram. Entry.t)); Gram.Skeyword "]" ], (Gram.Action.mk (fun _ (e : 'comprehension_or_sem_expr_for_list) _ (_loc : Gram.Loc.t) -> (e : 'expr)))) ]) ])) ()); Gram.extend (comprehension_or_sem_expr_for_list : 'comprehension_or_sem_expr_for_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterml ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), "top") ], (Gram.Action.mk (fun (e : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), e)), (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))))) : 'comprehension_or_sem_expr_for_list)))); ([ Gram.Snterml ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), "top"); Gram.Skeyword "|"; Gram.Slist1sep ((Gram.Snterm (Gram.Entry.obj (item : 'item Gram.Entry.t))), (Gram.Skeyword ";")) ], (Gram.Action.mk (fun (l : 'item list) _ (e : 'expr) (_loc : Gram.Loc.t) -> (compr _loc e l : 'comprehension_or_sem_expr_for_list)))); ([ Gram.Snterml ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), "top"); Gram.Skeyword ";" ], (Gram.Action.mk (fun _ (e : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), e)), (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))))) : 'comprehension_or_sem_expr_for_list)))); ([ Gram.Snterml ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), "top"); Gram.Skeyword ";"; Gram.Snterm (Gram.Entry.obj (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t)) ], (Gram.Action.mk (fun (mk : 'sem_expr_for_list) _ (e : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), e)), (mk (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))))) : 'comprehension_or_sem_expr_for_list)))) ]) ])) ()); Gram.extend (item : 'item Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ (* NP: These rules rely on being on this particular order. Which should be improved. *) Gram.Snterml ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), "top") ], (Gram.Action.mk (fun (e : 'expr) (_loc : Gram.Loc.t) -> (`cond e : 'item)))); ([ Gram.Stry (Gram.srules item [ ([ Gram.Snterm (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); Gram.Skeyword "<-" ], (Gram.Action.mk (fun _ (p : 'patt) (_loc : Gram.Loc.t) -> (p : 'e__32)))) ]); Gram.Snterml ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), "top") ], (Gram.Action.mk (fun (e : 'expr) (p : 'e__32) (_loc : Gram.Loc.t) -> (`gen ((p, e)) : 'item)))) ]) ])) ())) let _ = if is_revised then (let _ = (expr : 'expr Gram.Entry.t) and _ = (comprehension_or_sem_expr_for_list : 'comprehension_or_sem_expr_for_list Gram.Entry.t) in Gram.extend (comprehension_or_sem_expr_for_list : 'comprehension_or_sem_expr_for_list Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Snterml ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), "top"); Gram.Skeyword "::"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (last : 'expr) _ (e : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), e)), last) : 'comprehension_or_sem_expr_for_list)))); ([ Gram.Snterml ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), "top"); Gram.Skeyword ";"; Gram.Snterm (Gram.Entry.obj (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t)); Gram.Skeyword "::"; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (last : 'expr) _ (mk : 'sem_expr_for_list) _ (e : 'expr) (_loc : Gram.Loc.t) -> (Ast.ExApp (_loc, (Ast.ExApp (_loc, (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), e)), (mk last)) : 'comprehension_or_sem_expr_for_list)))) ]) ])) ())) else () end let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () end module P = struct (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Nicolas Pouillard: initial version *) let _ = Camlp4.Register.enable_dump_ocaml_ast_printer () end module B = struct (* camlp4r *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) open Camlp4 open PreCast.Syntax open PreCast open Format module CleanAst = Camlp4.Struct.CleanAst.Make(Ast) module SSet = Set.Make(String) let pa_r = "Camlp4OCamlRevisedParser" let pa_rr = "Camlp4OCamlReloadedParser" let pa_o = "Camlp4OCamlParser" let pa_rp = "Camlp4OCamlRevisedParserParser" let pa_op = "Camlp4OCamlParserParser" let pa_g = "Camlp4GrammarParser" let pa_m = "Camlp4MacroParser" let pa_qb = "Camlp4QuotationCommon" let pa_q = "Camlp4QuotationExpander" let pa_rq = "Camlp4OCamlRevisedQuotationExpander" let pa_oq = "Camlp4OCamlOriginalQuotationExpander" let pa_l = "Camlp4ListComprehension" open Register let dyn_loader = ref (fun _ -> raise (Match_failure ("./camlp4/Camlp4Bin.ml", 45, 24))) let rcall_callback = ref (fun () -> ()) let loaded_modules = ref SSet.empty let add_to_loaded_modules name = loaded_modules := SSet.add name !loaded_modules let (objext, libext) = if DynLoader.is_native then (".cmxs", ".cmxs") else (".cmo", ".cma") let rewrite_and_load n x = let dyn_loader = !dyn_loader () in let find_in_path = DynLoader.find_in_path dyn_loader in let real_load name = (add_to_loaded_modules name; DynLoader.load dyn_loader name) in let load = List.iter (fun n -> if (SSet.mem n !loaded_modules) || (List.mem n !Register.loaded_modules) then () else (add_to_loaded_modules n; DynLoader.load dyn_loader (n ^ objext))) in ((match (n, (String.lowercase x)) with | (("Parsers" | ""), ("pa_r.cmo" | "r" | "ocamlr" | "ocamlrevised" | "camlp4ocamlrevisedparser.cmo")) -> load [ pa_r ] | (("Parsers" | ""), ("rr" | "reloaded" | "ocamlreloaded" | "camlp4ocamlreloadedparser.cmo")) -> load [ pa_rr ] | (("Parsers" | ""), ("pa_o.cmo" | "o" | "ocaml" | "camlp4ocamlparser.cmo")) -> load [ pa_r; pa_o ] | (("Parsers" | ""), ("pa_rp.cmo" | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo")) -> load [ pa_r; pa_rp ] | (("Parsers" | ""), ("pa_op.cmo" | "op" | "parser" | "camlp4ocamlparserparser.cmo")) -> load [ pa_r; pa_o; pa_rp; pa_op ] | (("Parsers" | ""), ("pa_extend.cmo" | "pa_extend_m.cmo" | "g" | "grammar" | "camlp4grammarparser.cmo")) -> load [ pa_g ] | (("Parsers" | ""), ("pa_macro.cmo" | "m" | "macro" | "camlp4macroparser.cmo")) -> load [ pa_m ] | (("Parsers" | ""), ("q" | "camlp4quotationexpander.cmo")) -> load [ pa_qb; pa_q ] | (("Parsers" | ""), ("q_mlast.cmo" | "rq" | "camlp4ocamlrevisedquotationexpander.cmo")) -> load [ pa_qb; pa_rq ] | (("Parsers" | ""), ("oq" | "camlp4ocamloriginalquotationexpander.cmo")) -> load [ pa_r; pa_o; pa_qb; pa_oq ] | (("Parsers" | ""), "rf") -> load [ pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m ] | (("Parsers" | ""), "of") -> load [ pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m ] | (("Parsers" | ""), ("comp" | "camlp4listcomprehension.cmo")) -> load [ pa_l ] | (("Filters" | ""), ("lift" | "camlp4astlifter.cmo")) -> load [ "Camlp4AstLifter" ] | (("Filters" | ""), ("exn" | "camlp4exceptiontracer.cmo")) -> load [ "Camlp4ExceptionTracer" ] | (("Filters" | ""), ("prof" | "camlp4profiler.cmo")) -> load [ "Camlp4Profiler" ] | (* map is now an alias of fold since fold handles map too *) (("Filters" | ""), ("map" | "camlp4mapgenerator.cmo")) -> load [ "Camlp4FoldGenerator" ] | (("Filters" | ""), ("fold" | "camlp4foldgenerator.cmo")) -> load [ "Camlp4FoldGenerator" ] | (("Filters" | ""), ("meta" | "camlp4metagenerator.cmo")) -> load [ "Camlp4MetaGenerator" ] | (("Filters" | ""), ("trash" | "camlp4trashremover.cmo")) -> load [ "Camlp4TrashRemover" ] | (("Filters" | ""), ("striploc" | "camlp4locationstripper.cmo")) -> load [ "Camlp4LocationStripper" ] | (("Printers" | ""), ("pr_r.cmo" | "r" | "ocamlr" | "camlp4ocamlrevisedprinter.cmo")) -> Register.enable_ocamlr_printer () | (("Printers" | ""), ("pr_o.cmo" | "o" | "ocaml" | "camlp4ocamlprinter.cmo")) -> Register.enable_ocaml_printer () | (("Printers" | ""), ("pr_dump.cmo" | "p" | "dumpocaml" | "camlp4ocamlastdumper.cmo")) -> Register.enable_dump_ocaml_ast_printer () | (("Printers" | ""), ("d" | "dumpcamlp4" | "camlp4astdumper.cmo")) -> Register.enable_dump_camlp4_ast_printer () | (("Printers" | ""), ("a" | "auto" | "camlp4autoprinter.cmo")) -> load [ "Camlp4AutoPrinter" ] | _ -> let y = "Camlp4" ^ (n ^ ("/" ^ (x ^ objext))) in real_load (try find_in_path y with | Not_found -> x)); !rcall_callback ()) let print_warning = eprintf "%a:\n%s@." Loc.print let rec parse_file dyn_loader name pa getdir = let directive_handler = Some (fun ast -> match getdir ast with | Some x -> (match x with | (_, "load", s) -> (rewrite_and_load "" s; None) | (_, "directory", s) -> (DynLoader.include_dir dyn_loader s; None) | (_, "use", s) -> Some (parse_file dyn_loader s pa getdir) | (_, "default_quotation", s) -> (Quotation.default := s; None) | (loc, _, _) -> Loc.raise loc (Stream.Error "bad directive")) | None -> None) in let loc = Loc.mk name in (current_warning := print_warning; let ic = if name = "-" then stdin else open_in_bin name in let cs = Stream.of_channel ic in let clear () = if name = "-" then () else close_in ic in let phr = try pa ?directive_handler loc cs with | x -> (clear (); raise x) in (clear (); phr)) let output_file = ref None let process dyn_loader name pa pr clean fold_filters getdir = let ast = parse_file dyn_loader name pa getdir in let ast = fold_filters (fun t filter -> filter t) ast in let ast = clean ast in pr ?input_file: (Some name) ?output_file: !output_file ast let gind = function | Ast.SgDir (loc, n, (Ast.ExStr (_, s))) -> Some ((loc, n, s)) | _ -> None let gimd = function | Ast.StDir (loc, n, (Ast.ExStr (_, s))) -> Some ((loc, n, s)) | _ -> None let process_intf dyn_loader name = process dyn_loader name CurrentParser.parse_interf CurrentPrinter. print_interf (new CleanAst.clean_ast)#sig_item AstFilters. fold_interf_filters gind let process_impl dyn_loader name = process dyn_loader name CurrentParser.parse_implem CurrentPrinter. print_implem (new CleanAst.clean_ast)#str_item AstFilters. fold_implem_filters gimd let just_print_the_version () = (printf "%s@." Camlp4_config.version; exit 0) let print_version () = (eprintf "Camlp4 version %s@." Camlp4_config.version; exit 0) let print_stdlib () = (printf "%s@." Camlp4_config.camlp4_standard_library; exit 0) let usage ini_sl ext_sl = (eprintf "\ Usage: camlp4 [load-options] [--] [other-options]\n\ Options:\n\ .ml Parse this implementation file\n\ .mli Parse this interface file\n\ .%s Load this module inside the Camlp4 core@." (if DynLoader.is_native then "cmxs " else "(cmo|cma)"); Options.print_usage_list ini_sl; (* loop (ini_sl @ ext_sl) where rec loop = fun [ [(y, _, _) :: _] when y = "-help" -> () | [_ :: sl] -> loop sl | [] -> eprintf " -help Display this list of options.@." ]; *) if ext_sl <> [] then (eprintf "Options added by loaded object files:@."; Options.print_usage_list ext_sl) else ()) let warn_noassert () = eprintf "\ camlp4 warning: option -noassert is obsolete\n\ You should give the -noassert option to the ocaml compiler instead.@." type file_kind = | Intf of string | Impl of string | Str of string | ModuleImpl of string | IncludeDir of string let search_stdlib = ref true let print_loaded_modules = ref false let (task, do_task) = let t = ref None in let task f x = let () = Camlp4_config.current_input_file := x in t := Some (if !t = None then (fun _ -> f x) else (fun usage -> usage ())) in let do_task usage = match !t with | Some f -> f usage | None -> () in (task, do_task) let input_file x = let dyn_loader = !dyn_loader () in (!rcall_callback (); (match x with | Intf file_name -> task (process_intf dyn_loader) file_name | Impl file_name -> task (process_impl dyn_loader) file_name | Str s -> let (f, o) = Filename.open_temp_file "from_string" ".ml" in (output_string o s; close_out o; task (process_impl dyn_loader) f; at_exit (fun () -> Sys.remove f)) | ModuleImpl file_name -> rewrite_and_load "" file_name | IncludeDir dir -> DynLoader.include_dir dyn_loader dir); !rcall_callback ()) let initial_spec_list = [ ("-I", (Arg.String (fun x -> input_file (IncludeDir x))), " Add directory in search patch for object files."); ("-where", (Arg.Unit print_stdlib), "Print camlp4 library directory and exit."); ("-nolib", (Arg.Clear search_stdlib), "No automatic search for object files in library directory."); ("-intf", (Arg.String (fun x -> input_file (Intf x))), " Parse as an interface, whatever its extension."); ("-impl", (Arg.String (fun x -> input_file (Impl x))), " Parse as an implementation, whatever its extension."); ("-str", (Arg.String (fun x -> input_file (Str x))), " Parse as an implementation."); ("-unsafe", (Arg.Set Camlp4_config.unsafe), "Generate unsafe accesses to array and strings."); ("-noassert", (Arg.Unit warn_noassert), "Obsolete, do not use this option."); ("-verbose", (Arg.Set Camlp4_config.verbose), "More verbose in parsing errors."); ("-loc", (Arg.Set_string Loc.name), (" Name of the location variable (default: " ^ (!Loc.name ^ ")."))); ("-QD", (Arg.String (fun x -> Quotation.dump_file := Some x)), " Dump quotation expander result in case of syntax error."); ("-o", (Arg.String (fun x -> output_file := Some x)), " Output on instead of standard output."); ("-v", (Arg.Unit print_version), "Print Camlp4 version and exit."); ("-version", (Arg.Unit just_print_the_version), "Print Camlp4 version number and exit."); ("-vnum", (Arg.Unit just_print_the_version), "Print Camlp4 version number and exit."); ("-no_quot", (Arg.Clear Camlp4_config.quotations), "Don't parse quotations, allowing to use, e.g. \"<:>\" as token."); ("-loaded-modules", (Arg.Set print_loaded_modules), "Print the list of loaded modules."); ("-parser", (Arg.String (rewrite_and_load "Parsers")), " Load the parser Camlp4Parsers/.cm(o|a|xs)"); ("-printer", (Arg.String (rewrite_and_load "Printers")), " Load the printer Camlp4Printers/.cm(o|a|xs)"); ("-filter", (Arg.String (rewrite_and_load "Filters")), " Load the filter Camlp4Filters/.cm(o|a|xs)"); ("-ignore", (Arg.String ignore), "ignore the next argument"); ("--", (Arg.Unit ignore), "Deprecated, does nothing") ] let _ = Options.init initial_spec_list let anon_fun name = input_file (if Filename.check_suffix name ".mli" then Intf name else if Filename.check_suffix name ".ml" then Impl name else if Filename.check_suffix name objext then ModuleImpl name else if Filename.check_suffix name libext then ModuleImpl name else raise (Arg.Bad ("don't know what to do with " ^ name))) let main argv = let usage () = (usage initial_spec_list (Options.ext_spec_list ()); exit 0) in try let dynloader = DynLoader.mk ~ocaml_stdlib: !search_stdlib ~camlp4_stdlib: !search_stdlib () in (dyn_loader := (fun () -> dynloader); let call_callback () = Register.iter_and_take_callbacks (fun (name, module_callback) -> let () = add_to_loaded_modules name in module_callback ()) in (call_callback (); rcall_callback := call_callback; (match Options.parse anon_fun argv with | [] -> () | ("-help" | "--help" | "-h" | "-?") :: _ -> usage () | s :: _ -> (eprintf "%s: unknown or misused option\n" s; eprintf "Use option -help for usage@."; exit 2)); do_task usage; call_callback (); if !print_loaded_modules then SSet.iter (eprintf "%s@.") !loaded_modules else ())) with | Arg.Bad s -> (eprintf "Error: %s\n" s; eprintf "Use option -help for usage@."; exit 2) | Arg.Help _ -> usage () | exc -> (eprintf "@[%a@]@." ErrorHandler.print exc; exit 2) let _ = main Sys.argv end mingw-ocaml/ocaml/camlp4/Camlp4.mlpack0000644000175000017500000000012012124403240017137 0ustar tootstootsDebug ErrorHandler OCamlInitSyntax Options PreCast Printers Register Sig Struct mingw-ocaml/ocaml/camlp4/Camlp4Top/0000755000175000017500000000000012124403240016440 5ustar tootstootsmingw-ocaml/ocaml/camlp4/Camlp4Top/Rprint.ml0000644000175000017500000004302112124403240020250 0ustar tootstoots(* camlp4r *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) (* There is a few Obj.magic due to the fact that we no longer have compiler files like Parsetree, Location, Longident but Camlp4_import that wrap them to avoid name clashing. *) module Toploop : sig open Format; open Camlp4_import; value print_out_value : ref (formatter -> Outcometree.out_value -> unit); value print_out_type : ref (formatter -> Outcometree.out_type -> unit); value print_out_class_type : ref (formatter -> Outcometree.out_class_type -> unit); value print_out_module_type : ref (formatter -> Outcometree.out_module_type -> unit); value print_out_sig_item : ref (formatter -> Outcometree.out_sig_item -> unit); value print_out_signature : ref (formatter -> list Outcometree.out_sig_item -> unit); value print_out_phrase : ref (formatter -> Outcometree.out_phrase -> unit); end = struct open Toploop; value print_out_value = Obj.magic print_out_value; value print_out_type = Obj.magic print_out_type; value print_out_class_type = Obj.magic print_out_class_type; value print_out_module_type = Obj.magic print_out_module_type; value print_out_sig_item = Obj.magic print_out_sig_item; value print_out_signature = Obj.magic print_out_signature; value print_out_phrase = Obj.magic print_out_phrase; end; (* This file originally come from typing/oprint.ml *) open Format; open Camlp4_import.Outcometree; open Camlp4; exception Ellipsis; value cautious f ppf arg = try f ppf arg with [ Ellipsis -> fprintf ppf "..." ] ; value rec print_ident ppf = fun [ Oide_ident s -> fprintf ppf "%s" s | Oide_dot id s -> fprintf ppf "%a.%s" print_ident id s | Oide_apply id1 id2 -> fprintf ppf "%a(%a)" print_ident id1 print_ident id2 ] ; value value_ident ppf name = if List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] then fprintf ppf "( %s )" name else match name.[0] with [ 'a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' -> fprintf ppf "%s" name | _ -> fprintf ppf "( %s )" name ] ; (* Values *) value print_out_value ppf tree = let rec print_tree ppf = fun [ Oval_constr name ([_ :: _] as params) -> fprintf ppf "@[<1>%a@ %a@]" print_ident name (print_tree_list print_simple_tree "") params | Oval_variant name (Some param) -> fprintf ppf "@[<2>`%s@ %a@]" name print_simple_tree param | tree -> print_simple_tree ppf tree ] and print_simple_tree ppf = fun [ Oval_int i -> fprintf ppf "%i" i | Oval_int32 i -> fprintf ppf "%ldl" i | Oval_int64 i -> fprintf ppf "%LdL" i | Oval_nativeint i -> fprintf ppf "%ndn" i | Oval_float f -> fprintf ppf "%.12g" f | Oval_char c -> fprintf ppf "'%s'" (Char.escaped c) | Oval_string s -> try fprintf ppf "\"%s\"" (String.escaped s) with [ Invalid_argument "String.create" -> fprintf ppf "" ] | Oval_list tl -> fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree ";") tl | Oval_array tl -> fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree ";") tl | Oval_constr (Oide_ident "true") [] -> fprintf ppf "True" | Oval_constr (Oide_ident "false") [] -> fprintf ppf "False" | Oval_constr name [] -> print_ident ppf name | Oval_variant name None -> fprintf ppf "`%s" name | Oval_stuff s -> fprintf ppf "%s" s | Oval_record fel -> fprintf ppf "@[<1>{%a}@]" (cautious (print_fields True)) fel | Oval_tuple tree_list -> fprintf ppf "@[(%a)@]" (print_tree_list print_tree ",") tree_list | Oval_ellipsis -> raise Ellipsis | Oval_printer f -> f ppf | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree) tree ] and print_fields first ppf = fun [ [] -> () | [(name, tree) :: fields] -> let name = match name with [ Oide_ident "contents" -> Oide_ident "val" | x -> x ] in do { if not first then fprintf ppf ";@ " else (); fprintf ppf "@[<1>%a=@,%a@]" print_ident name (cautious print_tree) tree; print_fields False ppf fields } ] and print_tree_list print_item sep ppf tree_list = let rec print_list first ppf = fun [ [] -> () | [tree :: tree_list] -> do { if not first then fprintf ppf "%s@ " sep else (); print_item ppf tree; print_list False ppf tree_list } ] in cautious (print_list True) ppf tree_list in cautious print_tree ppf tree ; value rec print_list pr sep ppf = fun [ [] -> () | [a] -> pr ppf a | [a :: l] -> do { pr ppf a; sep ppf; print_list pr sep ppf l } ] ; value pr_vars = print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ") ; value pr_present = print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") ; (* Types *) value rec print_out_type ppf = fun [ Otyp_alias ty s -> fprintf ppf "@[%a as '%s@]" print_out_type ty s | ty -> print_out_type_1 ppf ty ] and print_out_type_1 ppf = fun [ Otyp_arrow lab ty1 ty2 -> fprintf ppf "@[%a%a ->@ %a@]" print_ty_label lab print_out_type_2 ty1 print_out_type_1 ty2 | Otyp_poly sl ty -> fprintf ppf "@[!%a.@ %a@]" pr_vars sl print_out_type ty | ty -> print_out_type_2 ppf ty ] and print_out_type_2 ppf = fun [ Otyp_constr id ([_ :: _] as tyl) -> fprintf ppf "@[%a@;<1 2>%a@]" print_ident id (print_typlist print_simple_out_type "") tyl | ty -> print_simple_out_type ppf ty ] and print_simple_out_type ppf = let rec print_tkind ppf = fun [ Otyp_var ng s -> fprintf ppf "'%s%s" (if ng then "_" else "") s | Otyp_constr id [] -> fprintf ppf "@[%a@]" print_ident id | Otyp_tuple tyl -> fprintf ppf "@[<1>(%a)@]" (print_typlist print_out_type " *") tyl | Otyp_stuff s -> fprintf ppf "%s" s | Otyp_variant non_gen row_fields closed tags -> let print_present ppf = fun [ None | Some [] -> () | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l ] in let print_fields ppf = fun [ Ovar_fields fields -> print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ") ppf fields | Ovar_name id tyl -> fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id ] in fprintf ppf "%s[%s@[@[%a@]%a ]@]" (if non_gen then "_" else "") (if closed then if tags = None then "= " else "< " else if tags = None then "> " else "? ") print_fields row_fields print_present tags | Otyp_object fields rest -> fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields | Otyp_class ng id tyl -> fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "") print_ident id | Otyp_manifest ty1 ty2 -> fprintf ppf "@[<2>%a ==@ %a@]" print_out_type ty1 print_out_type ty2 | Otyp_sum constrs -> fprintf ppf "@[[ %a ]@]" (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs | Otyp_record lbls -> fprintf ppf "@[{ %a }@]" (print_list print_out_label (fun ppf -> fprintf ppf ";@ ")) lbls | Otyp_abstract -> fprintf ppf "" | Otyp_module (p, n, tyl) -> do { fprintf ppf "@[<1>(module %s" p; let first = ref True in List.iter2 (fun s t -> let sep = if first.val then do { first.val := False; "with" } else "and" in fprintf ppf " %s type %s = %a" sep s print_out_type t ) n tyl; fprintf ppf ")@]" } | Otyp_alias _ _ | Otyp_poly _ _ | Otyp_arrow _ _ _ | Otyp_constr _ [_ :: _] as ty -> fprintf ppf "@[<1>(%a)@]" print_out_type ty ] in print_tkind ppf and print_out_constr ppf (name, tyl, ret) = match (tyl,ret) with [ ([], None) -> fprintf ppf "%s" name | ([], Some r) -> fprintf ppf "@[<2>%s:@ %a@]" name print_out_type r | (_,Some r) -> fprintf ppf "@[<2>%s:@ %a -> %a@]" name (print_typlist print_out_type " and") tyl print_out_type r | (_,None) -> fprintf ppf "@[<2>%s of@ %a@]" name (print_typlist print_out_type " and") tyl ] and print_out_label ppf (name, mut, arg) = fprintf ppf "@[<2>%s :@ %s%a@]" name (if mut then "mutable " else "") print_out_type arg and print_fields rest ppf = fun [ [] -> match rest with [ Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "") | None -> () ] | [(s, t)] -> do { fprintf ppf "%s : %a" s print_out_type t; match rest with [ Some _ -> fprintf ppf ";@ " | None -> () ]; print_fields rest ppf [] } | [(s, t) :: l] -> fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l ] and print_row_field ppf (l, opt_amp, tyl) = let pr_of ppf = if opt_amp then fprintf ppf " of@ &@ " else if tyl <> [] then fprintf ppf " of@ " else fprintf ppf "" in fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") tyl and print_typlist print_elem sep ppf = fun [ [] -> () | [ty] -> print_elem ppf ty | [ty :: tyl] -> fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep) tyl ] and print_typargs ppf = fun [ [] -> () | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1 | tyl -> fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl ] and print_ty_label ppf lab = if lab <> "" then fprintf ppf "%s%s:" (if lab.[0] = '?' then "" else "~") lab else () ; value type_parameter ppf (ty, (co, cn)) = fprintf ppf "%s%s%s" (if not cn then "+" else if not co then "-" else "") (if ty = "_" then "" else "'") ty ; value print_out_class_params ppf = fun [ [] -> () | tyl -> fprintf ppf "@[<1>[%a]@]@ " (print_list type_parameter (fun ppf -> fprintf ppf ", ")) tyl ] ; (* Signature items *) value rec print_out_class_type ppf = fun [ Octy_constr id tyl -> let pr_tyl ppf = fun [ [] -> () | tyl -> fprintf ppf "@[<1>[%a]@]@ " (print_typlist Toploop.print_out_type.val ",") tyl ] in fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id | Octy_fun lab ty cty -> fprintf ppf "@[%a[ %a ] ->@ %a@]" print_ty_label lab Toploop.print_out_type.val ty print_out_class_type cty | Octy_signature self_ty csil -> let pr_param ppf = fun [ Some ty -> fprintf ppf "@ @[(%a)@]" Toploop.print_out_type.val ty | None -> () ] in fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) csil ] and print_out_class_sig_item ppf = fun [ Ocsg_constraint ty1 ty2 -> fprintf ppf "@[<2>type %a =@ %a;@]" Toploop.print_out_type.val ty1 Toploop.print_out_type.val ty2 | Ocsg_method name priv virt ty -> fprintf ppf "@[<2>method %s%s%s :@ %a;@]" (if priv then "private " else "") (if virt then "virtual " else "") name Toploop.print_out_type.val ty | Ocsg_value name mut virt ty -> fprintf ppf "@[<2>value %s%s%s :@ %a;@]" (if mut then "mutable " else "") (if virt then "virtual " else "") name Toploop.print_out_type.val ty ] ; value rec print_out_module_type ppf = fun [ Omty_ident id -> fprintf ppf "%a" print_ident id | Omty_signature sg -> fprintf ppf "@[sig@ %a@;<1 -2>end@]" Toploop.print_out_signature.val sg | Omty_functor name mty_arg mty_res -> fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name print_out_module_type mty_arg print_out_module_type mty_res | Omty_abstract -> () ] and needs_semi = fun [ Osig_class _ _ _ _ rs | Osig_class_type _ _ _ _ rs | Osig_module _ _ rs | Osig_type _ rs -> rs <> Orec_next | Osig_exception _ _ | Osig_modtype _ _ | Osig_value _ _ _ -> True ] and print_out_signature ppf = fun [ [] -> () | [item] -> fprintf ppf "%a;" Toploop.print_out_sig_item.val item | [item :: items] -> let sep = match items with [ [hd :: _] -> if needs_semi hd then ";" else "" | [] -> ";" ] in fprintf ppf "%a%s@ %a" Toploop.print_out_sig_item.val item sep print_out_signature items ] and print_out_sig_item ppf = fun [ Osig_class vir_flag name params clt rs -> fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]" (if rs = Orec_next then "and" else "class") (if vir_flag then " virtual" else "") print_out_class_params params name Toploop.print_out_class_type.val clt | Osig_class_type vir_flag name params clt rs -> fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]" (if rs = Orec_next then "and" else "class type") (if vir_flag then " virtual" else "") print_out_class_params params name Toploop.print_out_class_type.val clt | Osig_exception id tyl -> fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl,None) | Osig_modtype name Omty_abstract -> fprintf ppf "@[<2>module type %s@]" name | Osig_modtype name mty -> fprintf ppf "@[<2>module type %s =@ %a@]" name Toploop.print_out_module_type.val mty | Osig_module name mty rs -> fprintf ppf "@[<2>%s %s :@ %a@]" (match rs with [ Orec_not -> "module" | Orec_first -> "module rec" | Orec_next -> "and" ]) name Toploop.print_out_module_type.val mty | Osig_type td rs -> print_out_type_decl (if rs = Orec_next then "and" else "type") ppf td | Osig_value name ty prims -> let kwd = if prims = [] then "value" else "external" in let pr_prims ppf = fun [ [] -> () | [s :: sl] -> do { fprintf ppf "@ = \"%s\"" s; List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl } ] in fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name Toploop.print_out_type.val ty pr_prims prims ] and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) = let constrain ppf (ty, ty') = fprintf ppf "@ @[<2>constraint %a =@ %a@]" Toploop.print_out_type.val ty Toploop.print_out_type.val ty' in let print_constraints ppf params = List.iter (constrain ppf) params in let type_defined ppf = match args with [ [] -> fprintf ppf "%s" name | [arg] -> fprintf ppf "%s %a" name type_parameter arg | _ -> fprintf ppf "%s@ %a" name (print_list type_parameter (fun ppf -> fprintf ppf "@ ")) args ] and print_kind ppf ty = fprintf ppf "%s@ %a" (if priv = Obj.magic Camlp4_import.Asttypes.Private then " private" else "") Toploop.print_out_type.val ty in let print_types ppf = fun [ Otyp_manifest ty1 ty2 -> fprintf ppf "@ @[<2>%a ==%a@]" Toploop.print_out_type.val ty1 print_kind ty2 | ty -> print_kind ppf ty ] in match ty with [ Otyp_abstract -> fprintf ppf "@[<2>@[@[%s %t@]@]%a@]" kwd type_defined print_constraints constraints | _ -> fprintf ppf "@[<2>@[@[%s %t@] =%a@]%a@]" kwd type_defined print_types ty print_constraints constraints ] ; (* Phrases *) value print_out_exception ppf exn outv = match exn with [ Sys.Break -> fprintf ppf "Interrupted.@." | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." | Stack_overflow -> fprintf ppf "Stack overflow during evaluation (looping recursion?).@." | _ -> fprintf ppf "@[Exception:@ %a.@]@." Toploop.print_out_value.val outv ] ; value rec print_items ppf = fun [ [] -> () | [(tree, valopt) :: items] -> do { match valopt with [ Some v -> fprintf ppf "@[<2>%a =@ %a@]" Toploop.print_out_sig_item.val tree Toploop.print_out_value.val v | None -> fprintf ppf "@[%a@]" Toploop.print_out_sig_item.val tree ]; if items <> [] then fprintf ppf "@ %a" print_items items else () } ] ; value print_out_phrase ppf = fun [ Ophr_eval outv ty -> fprintf ppf "@[- : %a@ =@ %a@]@." Toploop.print_out_type.val ty Toploop.print_out_value.val outv | Ophr_signature [] -> () | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv ] ; Toploop.print_out_value.val := print_out_value; Toploop.print_out_type.val := print_out_type; Toploop.print_out_class_type.val := print_out_class_type; Toploop.print_out_module_type.val := print_out_module_type; Toploop.print_out_sig_item.val := print_out_sig_item; Toploop.print_out_signature.val := print_out_signature; Toploop.print_out_phrase.val := print_out_phrase; mingw-ocaml/ocaml/camlp4/Camlp4Top/Top.ml0000644000175000017500000001132612124403240017537 0ustar tootstoots(* camlp4r q_MLast.cmo *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) (* There is a few Obj.magic due to the fact that we no longer have compiler files like Parsetree, Location, Longident but Camlp4_import that wrap them to avoid name clashing. *) module Toploop : sig value print_location : Format.formatter -> Camlp4_import.Location.t -> unit; value print_warning : Camlp4_import.Location.t -> Format.formatter -> Camlp4_import.Warnings.t -> unit; value parse_toplevel_phrase : ref (Lexing.lexbuf -> Camlp4_import.Parsetree.toplevel_phrase); value parse_use_file : ref (Lexing.lexbuf -> list Camlp4_import.Parsetree.toplevel_phrase); end = struct value print_location fmt loc = Toploop.print_location fmt (Obj.magic loc); value parse_toplevel_phrase = Obj.magic Toploop.parse_toplevel_phrase; value parse_use_file = Obj.magic Toploop.parse_use_file; value print_warning loc fmt w = Toploop.print_warning (Obj.magic loc) fmt (Obj.magic w); end; open Camlp4_import.Parsetree; open Lexing; open Camlp4; open PreCast; open Syntax; open Camlp4.Sig; module Ast2pt = Camlp4.Struct.Camlp4Ast2OCamlAst.Make Ast; module Lexer = Camlp4.Struct.Lexer.Make Token; external not_filtered : 'a -> Gram.not_filtered 'a = "%identity"; value initialization = lazy begin if Sys.interactive.val then Format.printf "\tCamlp4 Parsing version %s\n@." Camlp4_config.version else () end; value wrap parse_fun lb = let () = Lazy.force initialization in let () = Register.iter_and_take_callbacks (fun (_, f) -> f ()) in let not_filtered_token_stream = Lexer.from_lexbuf lb in let token_stream = Gram.filter (not_filtered not_filtered_token_stream) in try match token_stream with parser [ [: `(EOI, _) :] -> raise End_of_file | [: :] -> parse_fun token_stream ] with [ End_of_file | Sys.Break | (Loc.Exc_located _ (End_of_file | Sys.Break)) as x -> raise x | x -> let x = match x with [ Loc.Exc_located loc x -> do { Toploop.print_location Format.err_formatter (Loc.to_ocaml_location loc); x } | x -> x ] in do { Format.eprintf "@[<0>%a@]@." Camlp4.ErrorHandler.print x; raise Exit } ]; value toplevel_phrase token_stream = match Gram.parse_tokens_after_filter Syntax.top_phrase token_stream with [ Some str_item -> let str_item = AstFilters.fold_topphrase_filters (fun t filter -> filter t) str_item in Ast2pt.phrase str_item | None -> raise End_of_file ]; value use_file token_stream = let (pl0, eoi) = loop () where rec loop () = let (pl, stopped_at_directive) = Gram.parse_tokens_after_filter Syntax.use_file token_stream in if stopped_at_directive <> None then match pl with [ [ <:str_item< #load $str:s$ >> ] -> do { Topdirs.dir_load Format.std_formatter s; loop () } | [ <:str_item< #directory $str:s$ >> ] -> do { Topdirs.dir_directory s; loop () } | _ -> (pl, False) ] else (pl, True) in let pl = if eoi then [] else loop () where rec loop () = let (pl, stopped_at_directive) = Gram.parse_tokens_after_filter Syntax.use_file token_stream in if stopped_at_directive <> None then pl @ loop () else pl in List.map Ast2pt.phrase (pl0 @ pl); Toploop.parse_toplevel_phrase.val := wrap toplevel_phrase; Toploop.parse_use_file.val := wrap use_file; current_warning.val := fun loc txt -> Toploop.print_warning (Loc.to_ocaml_location loc) Format.err_formatter (Camlp4_import.Warnings.Camlp4 txt); Register.iter_and_take_callbacks (fun (_, f) -> f ()); mingw-ocaml/ocaml/camlp4/ICHANGES0000644000175000017500000000242112124403240015740 0ustar tootstootsInternal, very small, undocumented, or invisible changes ******************************************************** - [april-may 04] the following interface files changed in order to implement OCaml style locations: camlp4/camlp4/{ast2pt.mli,pcaml.mli,reloc.mli,grammar.mli} camlp4/lib/{stdpp.mli,token.mli} The main changes are occurrences of "int" changed into "Lexing.position" and "int * int" changed into "Lexing.position * Lexing.position" (or an equivalent type). - [20 nov 03], token.mli: eval_string takes a location as a extra argument (needed to issue a warning). Camlp4s Version 3.06+19 ----------------------- - [28 Oct 02] Changed and simplified local entry of pa_o.ml from "cvalue" to "cvalue_binding". - [18 Oct 02] The standard syntax for antiquotations in object class_types and object class_expr are now: <:class_type< $opt:x$ $list:y$ >> and <:class_expr< $opt:x$ $list:y$ >>: the syntax without the "opt" is accepted but deprecated (a warning is displayed). - [15 Oct 02] Changed Plexer which now manages better the line directives (applied only on begin of lines, no error if parsing error in the directive). - [14 Sep 02] Grammar.print_entry does not end any more with Format.print_flush. The "flush" is done by Grammar.Entry.print. mingw-ocaml/ocaml/camlp4/camlp4prof.ml0000644000175000017500000000325212124403240017240 0ustar tootstoots(****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) module Debug = struct value mode _ = False; end; value count = let h = Hashtbl.create 1007 in let () = at_exit (fun () -> let assoc = Hashtbl.fold (fun k v a -> [ (k, v.val) :: a ]) h [] in let out = open_out "camlp4_profiler.out" in let () = Marshal.to_channel out assoc [] in close_out out) in fun s -> try incr (Hashtbl.find h s) with [ Not_found -> Hashtbl.add h s (ref 1) ]; value load = Marshal.from_channel; value main () = let profile = List.sort (fun (_, v1) (_, v2) -> compare v1 v2) (load stdin) in List.iter (fun (k, v) -> Format.printf "%-75s: %d@." k v) profile; if Sys.argv.(0) = "camlp4prof" then main () else (); mingw-ocaml/ocaml/camlp4/Camlp4Filters/0000755000175000017500000000000012124403240017306 5ustar tootstootsmingw-ocaml/ocaml/camlp4/Camlp4Filters/Camlp4TrashRemover.ml0000644000175000017500000000301012124403240023314 0ustar tootstoots(* camlp4r *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Nicolas Pouillard: initial version *) open Camlp4; module Id = struct value name = "Camlp4TrashRemover"; value version = Sys.ocaml_version; end; module Make (AstFilters : Camlp4.Sig.AstFilters) = struct open AstFilters; open Ast; register_str_item_filter (Ast.map_str_item (fun [ <:str_item@_loc< module Camlp4Trash = $_$ >> -> <:str_item<>> | st -> st ]))#str_item; end; let module M = Camlp4.Register.AstFilter Id Make in (); mingw-ocaml/ocaml/camlp4/Camlp4Filters/Camlp4AstLifter.ml0000644000175000017500000000326512124403240022604 0ustar tootstoots(* camlp4r *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Nicolas Pouillard: initial version *) open Camlp4; module Id = struct value name = "Camlp4AstLifter"; value version = Sys.ocaml_version; end; module Make (AstFilters : Camlp4.Sig.AstFilters) = struct open AstFilters; module MetaLoc = struct module Ast = Ast; value meta_loc_patt _loc _ = <:patt< loc >>; value meta_loc_expr _loc _ = <:expr< loc >>; end; module MetaAst = Ast.Meta.Make MetaLoc; register_str_item_filter (fun ast -> let _loc = Ast.loc_of_str_item ast in <:str_item< let loc = Loc.ghost in $exp:MetaAst.Expr.meta_str_item _loc ast$ >>); end; let module M = Camlp4.Register.AstFilter Id Make in (); mingw-ocaml/ocaml/camlp4/Camlp4Filters/Camlp4MapGenerator.ml0000644000175000017500000000226012124403240023265 0ustar tootstoots(****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* This module is useless now. Camlp4FoldGenerator handles map too. *) module Id = struct value name = "Camlp4MapGenerator"; value version = Sys.ocaml_version; end; mingw-ocaml/ocaml/camlp4/Camlp4Filters/Camlp4Profiler.ml0000644000175000017500000000556012124403240022471 0ustar tootstoots(* camlp4r *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Nicolas Pouillard: initial version *) open Camlp4; module Id = struct value name = "Camlp4Profiler"; value version = Sys.ocaml_version; end; module Make (AstFilters : Camlp4.Sig.AstFilters) = struct open AstFilters; open Ast; value decorate_binding decorate_fun = object inherit Ast.map as super; method binding = fun [ <:binding@_loc< $lid:id$ = $(<:expr< fun [ $_$ ] >> as e)$ >> -> <:binding< $lid:id$ = $decorate_fun id e$ >> | b -> super#binding b ]; end#binding; value decorate decorate_fun = object (o) inherit Ast.map as super; method str_item = fun [ <:str_item@_loc< value $rec:r$ $b$ >> -> <:str_item< value $rec:r$ $decorate_binding decorate_fun b$ >> | st -> super#str_item st ]; method expr = fun [ <:expr@_loc< let $rec:r$ $b$ in $e$ >> -> <:expr< let $rec:r$ $decorate_binding decorate_fun b$ in $o#expr e$ >> | <:expr@_loc< fun [ $_$ ] >> as e -> decorate_fun "" e | e -> super#expr e ]; end; value decorate_this_expr e id = let buf = Buffer.create 42 in let _loc = Ast.loc_of_expr e in let () = Format.bprintf buf "%s @@ %a@?" id Loc.dump _loc in let s = Buffer.contents buf in <:expr< let () = Camlp4prof.count $`str:s$ in $e$ >>; value rec decorate_fun id = let decorate = decorate decorate_fun in let decorate_expr = decorate#expr in let decorate_match_case = decorate#match_case in fun [ <:expr@_loc< fun $p$ -> $e$ >> -> <:expr< fun $p$ -> $decorate_fun id e$ >> | <:expr@_loc< fun [ $m$ ] >> -> decorate_this_expr <:expr< fun [ $decorate_match_case m$ ] >> id | e -> decorate_this_expr (decorate_expr e) id ]; register_str_item_filter (decorate decorate_fun)#str_item; end; let module M = Camlp4.Register.AstFilter Id Make in (); mingw-ocaml/ocaml/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml0000644000175000017500000005410112124403240023435 0ustar tootstoots(* camlp4r *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2006-2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Nicolas Pouillard: initial version *) open Camlp4; module Id = struct value name = "Camlp4FoldGenerator"; value version = Sys.ocaml_version; end; module Make (AstFilters : Camlp4.Sig.AstFilters) = struct open AstFilters; module StringMap = Map.Make String; open Ast; value _loc = Loc.ghost; value sf = Printf.sprintf; value xik i k = let i = if i < 0 then assert False else if i = 0 then "" else sf "_i%d" i in let k = if k < 1 then assert False else if k = 1 then "" else sf "_k%d" k in sf "_x%s%s" i k; value exik i k = <:expr< $lid:xik i k$ >>; value pxik i k = <:patt< $lid:xik i k$ >>; value elidk y k = <:expr< $lid:sf "%s_%d" y k$ >>; value plidk y k = <:patt< $lid:sf "%s_%d" y k$ >>; value xs s = "_x_" ^ s; value xsk = sf "_x_%s_%d"; value exsk s k = <:expr< $lid:xsk s k$>>; value rec apply_expr accu = fun [ [] -> accu | [x :: xs] -> let _loc = Ast.loc_of_expr x in apply_expr <:expr< $accu$ $x$ >> xs ]; value rec apply_patt accu = fun [ [] -> accu | [x :: xs] -> let _loc = Ast.loc_of_patt x in apply_patt <:patt< $accu$ $x$ >> xs ]; value rec apply_ctyp accu = fun [ [] -> accu | [x :: xs] -> let _loc = Ast.loc_of_ctyp x in apply_ctyp <:ctyp< $accu$ $x$ >> xs ]; value opt_map f = fun [ Some x -> Some (f x) | None -> None ]; value list_init f n = let rec self m = if m = n then [] else [f m :: self (succ m)] in self 0; value rec lid_of_ident sep = fun [ <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> s | <:ident< $i1$.$i2$ >> -> lid_of_ident sep i1 ^ sep ^ lid_of_ident sep i2 | _ -> assert False ]; type type_decl = (string * Ast.ident * list Ast.ctyp * Ast.ctyp * bool); value builtin_types = let tyMap = StringMap.empty in let tyMap = let abstr = ["string"; "int"; "float"; "int32"; "int64"; "nativeint"; "char"] in List.fold_right (fun name -> StringMap.add name (name, <:ident< $lid:name$ >>, [], <:ctyp<>>, False)) abstr tyMap in let tyMap = let concr = [("bool", <:ident>, [], <:ctyp< [ False | True ] >>, False); ("list", <:ident>, [ <:ctyp< 'a >> ], <:ctyp< [ $uid:"[]"$ | $uid:"::"$ of 'a and list 'a ] >>, False); ("option", <:ident add to the search path for INCLUDE'd files After having used a DEFINE followed by "= ", you can use it in expressions *and* in patterns. If the expression defining the macro cannot be used as a pattern, there is an error message if it is used in a pattern. You can also define a local macro in an expression usigng the DEFINE ... IN form. Note that local macros have lowercase names and can not take parameters. If a macro is defined to = NOTHING, and then used as an argument to a function, this will be equivalent to function taking one less argument. Similarly, passing NOTHING as an argument to a macro is equivalent to "erasing" the corresponding parameter from the macro body. The toplevel statement INCLUDE can be used to include a file containing macro definitions and also any other toplevel items. The included files are looked up in directories passed in via the -I option, falling back to the current directory. The expression __FILE__ returns the current compiled file name. The expression __LOCATION__ returns the current location of itself. If used inside a macro, it returns the location where the macro is called. The expression (LOCATION_OF parameter) returns the location of the given macro parameter. It cannot be used outside a macro definition. *) open Camlp4; module Make (Syntax : Sig.Camlp4Syntax) = struct open Sig; include Syntax; type item_or_def 'a = [ SdStr of 'a | SdDef of string and option (list string * Ast.expr) | SdUnd of string | SdITE of bool and list (item_or_def 'a) and list (item_or_def 'a) | SdLazy of Lazy.t 'a ]; value rec list_remove x = fun [ [(y, _) :: l] when y = x -> l | [d :: l] -> [d :: list_remove x l] | [] -> [] ]; value defined = ref []; value is_defined i = List.mem_assoc i defined.val; value bad_patt _loc = Loc.raise _loc (Failure "this macro cannot be used in a pattern (see its definition)"); value substp _loc env = loop where rec loop = fun [ <:expr< $e1$ $e2$ >> -> <:patt< $loop e1$ $loop e2$ >> | <:expr< >> -> <:patt< >> | <:expr< $lid:x$ >> -> try List.assoc x env with [ Not_found -> <:patt< $lid:x$ >> ] | <:expr< $uid:x$ >> -> try List.assoc x env with [ Not_found -> <:patt< $uid:x$ >> ] | <:expr< $int:x$ >> -> <:patt< $int:x$ >> | <:expr< $str:s$ >> -> <:patt< $str:s$ >> | <:expr< ($tup:x$) >> -> <:patt< ($tup:loop x$) >> | <:expr< $x1$, $x2$ >> -> <:patt< $loop x1$, $loop x2$ >> | <:expr< { $bi$ } >> -> let rec substbi = fun [ <:rec_binding< $b1$; $b2$ >> -> <:patt< $substbi b1$; $substbi b2$ >> | <:rec_binding< $i$ = $e$ >> -> <:patt< $i$ = $loop e$ >> | _ -> bad_patt _loc ] in <:patt< { $substbi bi$ } >> | _ -> bad_patt _loc ]; class reloc _loc = object inherit Ast.map as super; method loc _ = _loc; (* method _Loc_t _ = _loc; *) end; class subst _loc env = object inherit reloc _loc as super; method expr = fun [ <:expr< $lid:x$ >> | <:expr< $uid:x$ >> as e -> try List.assoc x env with [ Not_found -> super#expr e ] | <:expr@_loc< LOCATION_OF $lid:x$ >> | <:expr@_loc< LOCATION_OF $uid:x$ >> as e -> try let loc = Ast.loc_of_expr (List.assoc x env) in let (a, b, c, d, e, f, g, h) = Loc.to_tuple loc in <:expr< Loc.of_tuple ($`str:a$, $`int:b$, $`int:c$, $`int:d$, $`int:e$, $`int:f$, $`int:g$, $if h then <:expr< True >> else <:expr< False >> $) >> with [ Not_found -> super#expr e ] | e -> super#expr e ]; method patt = fun [ <:patt< $lid:x$ >> | <:patt< $uid:x$ >> as p -> try substp _loc [] (List.assoc x env) with [ Not_found -> super#patt p ] | p -> super#patt p ]; end; value incorrect_number loc l1 l2 = Loc.raise loc (Failure (Printf.sprintf "expected %d parameters; found %d" (List.length l2) (List.length l1))); value define eo x = do { match eo with [ Some ([], e) -> EXTEND Gram expr: LEVEL "simple" [ [ UIDENT $x$ -> (new reloc _loc)#expr e ]] ; patt: LEVEL "simple" [ [ UIDENT $x$ -> let p = substp _loc [] e in (new reloc _loc)#patt p ]] ; END | Some (sl, e) -> EXTEND Gram expr: LEVEL "apply" [ [ UIDENT $x$; param = SELF -> let el = match param with [ <:expr< ($tup:e$) >> -> Ast.list_of_expr e [] | e -> [e] ] in if List.length el = List.length sl then let env = List.combine sl el in (new subst _loc env)#expr e else incorrect_number _loc el sl ] ] ; patt: LEVEL "simple" [ [ UIDENT $x$; param = SELF -> let pl = match param with [ <:patt< ($tup:p$) >> -> Ast.list_of_patt p [] | p -> [p] ] in if List.length pl = List.length sl then let env = List.combine sl pl in let p = substp _loc env e in (new reloc _loc)#patt p else incorrect_number _loc pl sl ] ] ; END | None -> () ]; defined.val := [(x, eo) :: defined.val]; }; value undef x = try do { let eo = List.assoc x defined.val in match eo with [ Some ([], _) -> do { DELETE_RULE Gram expr: UIDENT $x$ END; DELETE_RULE Gram patt: UIDENT $x$ END; } | Some (_, _) -> do { DELETE_RULE Gram expr: UIDENT $x$; SELF END; DELETE_RULE Gram patt: UIDENT $x$; SELF END; } | None -> () ]; defined.val := list_remove x defined.val; } with [ Not_found -> () ]; value parse_def s = match Gram.parse_string expr (Loc.mk "") s with [ <:expr< $uid:n$ >> -> define None n | <:expr< $uid:n$ = $e$ >> -> define (Some ([],e)) n | _ -> invalid_arg s ]; (* This is a list of directories to search for INCLUDE statements. *) value include_dirs = ref []; (* Add something to the above, make sure it ends with a slash. *) value add_include_dir str = if str <> "" then let str = if String.get str ((String.length str)-1) = '/' then str else str ^ "/" in include_dirs.val := include_dirs.val @ [str] else (); value parse_include_file rule = let dir_ok file dir = Sys.file_exists (dir ^ file) in fun file -> let file = try (List.find (dir_ok file) (include_dirs.val @ ["./"])) ^ file with [ Not_found -> file ] in let ch = open_in file in let st = Stream.of_channel ch in Gram.parse rule (Loc.mk file) st; value rec execute_macro nil cons = fun [ SdStr i -> i | SdDef x eo -> do { define eo x; nil } | SdUnd x -> do { undef x; nil } | SdITE b l1 l2 -> execute_macro_list nil cons (if b then l1 else l2) | SdLazy l -> Lazy.force l ] and execute_macro_list nil cons = fun [ [] -> nil | [hd::tl] -> (* The evaluation order is important here *) let il1 = execute_macro nil cons hd in let il2 = execute_macro_list nil cons tl in cons il1 il2 ] ; (* Stack of conditionals. *) value stack = Stack.create () ; (* Make an SdITE value by extracting the result of the test from the stack. *) value make_SdITE_result st1 st2 = let test = Stack.pop stack in SdITE test st1 st2 ; type branch = [ Then | Else ]; (* Execute macro only if it belongs to the currently active branch. *) value execute_macro_if_active_branch _loc nil cons branch macro_def = let test = Stack.top stack in let item = if (test && branch=Then) || ((not test) && branch=Else) then execute_macro nil cons macro_def else (* ignore the macro *) nil in SdStr(item) ; EXTEND Gram GLOBAL: expr patt str_item sig_item; str_item: FIRST [ [ x = macro_def -> execute_macro <:str_item<>> (fun a b -> <:str_item< $a$; $b$ >>) x ] ] ; sig_item: FIRST [ [ x = macro_def_sig -> execute_macro <:sig_item<>> (fun a b -> <:sig_item< $a$; $b$ >>) x ] ] ; macro_def: [ [ "DEFINE"; i = uident; def = opt_macro_value -> SdDef i def | "UNDEF"; i = uident -> SdUnd i | "IFDEF"; uident_eval_ifdef; "THEN"; st1 = smlist_then; st2 = else_macro_def -> make_SdITE_result st1 st2 | "IFNDEF"; uident_eval_ifndef; "THEN"; st1 = smlist_then; st2 = else_macro_def -> make_SdITE_result st1 st2 | "INCLUDE"; fname = STRING -> SdLazy (lazy (parse_include_file str_items fname)) ] ] ; macro_def_sig: [ [ "DEFINE"; i = uident -> SdDef i None | "UNDEF"; i = uident -> SdUnd i | "IFDEF"; uident_eval_ifdef; "THEN"; sg1 = sglist_then; sg2 = else_macro_def_sig -> make_SdITE_result sg1 sg2 | "IFNDEF"; uident_eval_ifndef; "THEN"; sg1 = sglist_then; sg2 = else_macro_def_sig -> make_SdITE_result sg1 sg2 | "INCLUDE"; fname = STRING -> SdLazy (lazy (parse_include_file sig_items fname)) ] ] ; uident_eval_ifdef: [ [ i = uident -> Stack.push (is_defined i) stack ]] ; uident_eval_ifndef: [ [ i = uident -> Stack.push (not (is_defined i)) stack ]] ; else_macro_def: [ [ "ELSE"; st = smlist_else; endif -> st | endif -> [] ] ] ; else_macro_def_sig: [ [ "ELSE"; st = sglist_else; endif -> st | endif -> [] ] ] ; else_expr: [ [ "ELSE"; e = expr; endif -> e | endif -> <:expr< () >> ] ] ; smlist_then: [ [ sml = LIST1 [ d = macro_def; semi -> execute_macro_if_active_branch _loc <:str_item<>> (fun a b -> <:str_item< $a$; $b$ >>) Then d | si = str_item; semi -> SdStr si ] -> sml ] ] ; smlist_else: [ [ sml = LIST1 [ d = macro_def; semi -> execute_macro_if_active_branch _loc <:str_item<>> (fun a b -> <:str_item< $a$; $b$ >>) Else d | si = str_item; semi -> SdStr si ] -> sml ] ] ; sglist_then: [ [ sgl = LIST1 [ d = macro_def_sig; semi -> execute_macro_if_active_branch _loc <:sig_item<>> (fun a b -> <:sig_item< $a$; $b$ >>) Then d | si = sig_item; semi -> SdStr si ] -> sgl ] ] ; sglist_else: [ [ sgl = LIST1 [ d = macro_def_sig; semi -> execute_macro_if_active_branch _loc <:sig_item<>> (fun a b -> <:sig_item< $a$; $b$ >>) Else d | si = sig_item; semi -> SdStr si ] -> sgl ] ] ; endif: [ [ "END" -> () | "ENDIF" -> () ] ] ; opt_macro_value: [ [ "("; pl = LIST1 [ x = LIDENT -> x ] SEP ","; ")"; "="; e = expr -> Some (pl, e) | "="; e = expr -> Some ([], e) | -> None ] ] ; expr: LEVEL "top" [ [ "IFDEF"; i = uident; "THEN"; e1 = expr; e2 = else_expr -> if is_defined i then e1 else e2 | "IFNDEF"; i = uident; "THEN"; e1 = expr; e2 = else_expr -> if is_defined i then e2 else e1 | "DEFINE"; i = LIDENT; "="; def = expr; "IN"; body = expr -> (new subst _loc [(i, def)])#expr body ] ] ; patt: [ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; endif -> if is_defined i then p1 else p2 | "IFNDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; endif -> if is_defined i then p2 else p1 ] ] ; uident: [ [ i = UIDENT -> i ] ] ; (* dirty hack to allow polymorphic variants using the introduced keywords. *) expr: BEFORE "simple" [ [ "`"; kwd = [ "IFDEF" | "IFNDEF" | "THEN" | "ELSE" | "END" | "ENDIF" | "DEFINE" | "IN" ] -> <:expr< `$uid:kwd$ >> | "`"; s = a_ident -> <:expr< ` $s$ >> ] ] ; (* idem *) patt: BEFORE "simple" [ [ "`"; kwd = [ "IFDEF" | "IFNDEF" | "THEN" | "ELSE" | "END" | "ENDIF" ] -> <:patt< `$uid:kwd$ >> | "`"; s = a_ident -> <:patt< ` $s$ >> ] ] ; END; Options.add "-D" (Arg.String parse_def) " Define for IFDEF instruction."; Options.add "-U" (Arg.String undef) " Undefine for IFDEF instruction."; Options.add "-I" (Arg.String add_include_dir) " Add a directory to INCLUDE search path."; end; let module M = Register.OCamlSyntaxExtension Id Make in (); module MakeNothing (AstFilters : Camlp4.Sig.AstFilters) = struct open AstFilters; open Ast; (* Remove NOTHING and expanse __FILE__ and __LOCATION__ *) value map_expr = fun [ <:expr< $e$ NOTHING >> | <:expr< fun $ <:patt< NOTHING >> $ -> $e$ >> -> e | <:expr@_loc< $lid:"__FILE__"$ >> -> <:expr< $`str:Loc.file_name _loc$ >> | <:expr@_loc< $lid:"__LOCATION__"$ >> -> let (a, b, c, d, e, f, g, h) = Loc.to_tuple _loc in <:expr< Loc.of_tuple ($`str:a$, $`int:b$, $`int:c$, $`int:d$, $`int:e$, $`int:f$, $`int:g$, $if h then <:expr< True >> else <:expr< False >> $) >> | e -> e]; register_str_item_filter (Ast.map_expr map_expr)#str_item; end; let module M = Camlp4.Register.AstFilter Id MakeNothing in (); mingw-ocaml/ocaml/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml0000644000175000017500000007435212124403240023466 0ustar tootstootsopen Camlp4; (* -*- camlp4r -*- *) (****************************************************************************) (* *) (* OCaml *) (* *) (* INRIA Rocquencourt *) (* *) (* Copyright 2002-2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed under *) (* the terms of the GNU Library General Public License, with the special *) (* exception on linking described in LICENSE at the top of the OCaml *) (* source tree. *) (* *) (****************************************************************************) (* Authors: * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) module Id = struct value name = "Camlp4GrammarParser"; value version = Sys.ocaml_version; end; module Make (Syntax : Sig.Camlp4Syntax) = struct open Sig; include Syntax; module MetaLoc = Ast.Meta.MetaGhostLoc; module MetaAst = Ast.Meta.Make MetaLoc; module PP = Camlp4.Printers.OCaml.Make Syntax; value pp = new PP.printer ~comments:False (); value string_of_patt patt = let buf = Buffer.create 42 in let () = Format.bprintf buf "%a@?" pp#patt patt in let str = Buffer.contents buf in if str = "" then assert False else str; value split_ext = ref False; type loc = Loc.t; type name 'e = { expr : 'e; tvar : string; loc : loc }; type styp = [ STlid of loc and string | STapp of loc and styp and styp | STquo of loc and string | STself of loc and string | STtok of loc | STstring_tok of loc | STtyp of Ast.ctyp ] ; type text 'e 'p = [ TXmeta of loc and string and list (text 'e 'p) and 'e and styp | TXlist of loc and bool and symbol 'e 'p and option (symbol 'e 'p) | TXnext of loc | TXnterm of loc and name 'e and option string | TXopt of loc and text 'e 'p | TXtry of loc and text 'e 'p | TXrules of loc and list (list (text 'e 'p) * 'e) | TXself of loc | TXkwd of loc and string | TXtok of loc and 'e and string (** The first is the match function expr, the second is the string description. The description string will be used for grammar insertion and left factoring. Keep this string normalized and well comparable. *) ] and entry 'e 'p = { name : name 'e; pos : option 'e; levels : list (level 'e 'p) } and level 'e 'p = { label : option string; assoc : option 'e; rules : list (rule 'e 'p) } and rule 'e 'p = { prod : list (symbol 'e 'p); action : option 'e } and symbol 'e 'p = { used : list string; text : text 'e 'p; styp : styp; pattern : option 'p } ; type used = [ Unused | UsedScanned | UsedNotScanned ]; value _loc = Loc.ghost; value gm = "Camlp4Grammar__"; value mark_used modif ht n = try let rll = Hashtbl.find_all ht n in List.iter (fun (r, _) -> if r.val == Unused then do { r.val := UsedNotScanned; modif.val := True; } else ()) rll with [ Not_found -> () ] ; value rec mark_symbol modif ht symb = List.iter (fun e -> mark_used modif ht e) symb.used ; value check_use nl el = let ht = Hashtbl.create 301 in let modif = ref False in do { List.iter (fun e -> let u = match e.name.expr with [ <:expr< $lid:_$ >> -> Unused | _ -> UsedNotScanned ] in Hashtbl.add ht e.name.tvar (ref u, e)) el; List.iter (fun n -> try let rll = Hashtbl.find_all ht n.tvar in List.iter (fun (r, _) -> r.val := UsedNotScanned) rll with _ -> ()) nl; modif.val := True; while modif.val do { modif.val := False; Hashtbl.iter (fun _ (r, e) -> if r.val = UsedNotScanned then do { r.val := UsedScanned; List.iter (fun level -> let rules = level.rules in List.iter (fun rule -> List.iter (fun s -> mark_symbol modif ht s) rule.prod) rules) e.levels } else ()) ht }; Hashtbl.iter (fun s (r, e) -> if r.val = Unused then print_warning e.name.loc ("Unused local entry \"" ^ s ^ "\"") else ()) ht; } ; value new_type_var = let i = ref 0 in fun () -> do { incr i; "e__" ^ string_of_int i.val } ; value used_of_rule_list rl = List.fold_left (fun nl r -> List.fold_left (fun nl s -> s.used @ nl) nl r.prod) [] rl ; value retype_rule_list_without_patterns _loc rl = try List.map (fun (* ...; [ "foo" ]; ... ==> ...; (x = [ "foo" ] -> Gram.Token.extract_string x); ... *) [ {prod = [({pattern = None; styp = STtok _} as s)]; action = None} -> {prod = [{ (s) with pattern = Some <:patt< x >> }]; action = Some <:expr< $uid:gm$.Token.extract_string x >>} (* ...; [ symb ]; ... ==> ...; (x = [ symb ] -> x); ... *) | {prod = [({pattern = None} as s)]; action = None} -> {prod = [{ (s) with pattern = Some <:patt< x >> }]; action = Some <:expr< x >>} (* ...; ([] -> a); ... *) | {prod = []; action = Some _} as r -> r | _ -> raise Exit ]) rl with [ Exit -> rl ] ; value meta_action = ref False; value mklistexp _loc = loop True where rec loop top = fun [ [] -> <:expr< [] >> | [e1 :: el] -> let _loc = if top then _loc else Loc.merge (Ast.loc_of_expr e1) _loc in <:expr< [$e1$ :: $loop False el$] >> ] ; value mklistpat _loc = loop True where rec loop top = fun [ [] -> <:patt< [] >> | [p1 :: pl] -> let _loc = if top then _loc else Loc.merge (Ast.loc_of_patt p1) _loc in <:patt< [$p1$ :: $loop False pl$] >> ] ; value rec expr_fa al = fun [ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f | f -> (f, al) ] ; value rec make_ctyp styp tvar = match styp with [ STlid _loc s -> <:ctyp< $lid:s$ >> | STapp _loc t1 t2 -> <:ctyp< $make_ctyp t1 tvar$ $make_ctyp t2 tvar$ >> | STquo _loc s -> <:ctyp< '$s$ >> | STself _loc x -> if tvar = "" then Loc.raise _loc (Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level")) else <:ctyp< '$tvar$ >> | STtok _loc -> <:ctyp< $uid:gm$.Token.t >> | STstring_tok _loc -> <:ctyp< string >> | STtyp t -> t ] ; value make_ctyp_patt styp tvar patt = let styp = match styp with [ STstring_tok _loc -> STtok _loc | t -> t ] in match make_ctyp styp tvar with [ <:ctyp< _ >> -> patt | t -> let _loc = Ast.loc_of_patt patt in <:patt< ($patt$ : $t$) >> ]; value make_ctyp_expr styp tvar expr = match make_ctyp styp tvar with [ <:ctyp< _ >> -> expr | t -> let _loc = Ast.loc_of_expr expr in <:expr< ($expr$ : $t$) >> ]; value text_of_action _loc psl rtvar act tvar = let locid = <:patt< $lid:Loc.name.val$ >> in let act = match act with [ Some act -> act | None -> <:expr< () >> ] in let (tok_match_pl, act, _) = List.fold_left (fun ((tok_match_pl, act, i) as accu) -> fun [ { pattern = None } -> accu | { pattern = Some p } when Ast.is_irrefut_patt p -> accu | { pattern = Some <:patt< ($_$ ($tup:<:patt< _ >>$) as $lid:s$) >> } -> (tok_match_pl, <:expr< let $lid:s$ = $uid:gm$.Token.extract_string $lid:s$ in $act$ >>, i) | { pattern = Some p; text=TXtok _ _ _ } -> let id = "__camlp4_"^string_of_int i in (Some (match (tok_match_pl) with [ None -> (<:expr< $lid:id$ >>, p) | Some (tok_pl, match_pl) -> (<:expr< $lid:id$, $tok_pl$ >>, <:patt< $p$, $match_pl$ >>)]), act, succ i) | _ -> accu ]) (None, act, 0) psl in let e = let e1 = <:expr< ($act$ : '$rtvar$) >> in let e2 = match (tok_match_pl) with [ None -> e1 | Some (<:expr< $t1$, $t2$ >>, <:patt< $p1$, $p2$ >>) -> <:expr< match ($t1$, $t2$) with [ ($p1$, $p2$) -> $e1$ | _ -> assert False ] >> | Some (tok, match_) -> <:expr< match $tok$ with [ $pat:match_$ -> $e1$ | _ -> assert False ] >> ] in <:expr< fun ($locid$ : $uid:gm$.Loc.t) -> $e2$ >> in let (txt, _) = List.fold_left (fun (txt, i) s -> match s.pattern with [ None | Some <:patt< _ >> -> (<:expr< fun _ -> $txt$ >>, i) | Some <:patt< ($_$ ($tup:<:patt< _ >>$) as $p$) >> -> let p = make_ctyp_patt s.styp tvar p in (<:expr< fun $p$ -> $txt$ >>, i) | Some p when Ast.is_irrefut_patt p -> let p = make_ctyp_patt s.styp tvar p in (<:expr< fun $p$ -> $txt$ >>, i) | Some _ -> let p = make_ctyp_patt s.styp tvar <:patt< $lid:"__camlp4_"^string_of_int i$ >> in (<:expr< fun $p$ -> $txt$ >>, succ i) ]) (e, 0) psl in let txt = if meta_action.val then <:expr< Obj.magic $MetaAst.Expr.meta_expr _loc txt$ >> else txt in <:expr< $uid:gm$.Action.mk $txt$ >> ; value srules loc t rl tvar = List.map (fun r -> let sl = [ s.text | s <- r.prod ] in let ac = text_of_action loc r.prod t r.action tvar in (sl, ac)) rl ; value rec make_expr entry tvar = fun [ TXmeta _loc n tl e t -> let el = List.fold_right (fun t el -> <:expr< [$make_expr entry "" t$ :: $el$] >>) tl <:expr< [] >> in <:expr< $uid:gm$.Smeta $str:n$ $el$ ($uid:gm$.Action.mk ($make_ctyp_expr t tvar e$)) >> | TXlist _loc min t ts -> let txt = make_expr entry "" t.text in match (min, ts) with [ (False, None) -> <:expr< $uid:gm$.Slist0 $txt$ >> | (True, None) -> <:expr< $uid:gm$.Slist1 $txt$ >> | (False, Some s) -> let x = make_expr entry tvar s.text in <:expr< $uid:gm$.Slist0sep $txt$ $x$ >> | (True, Some s) -> let x = make_expr entry tvar s.text in <:expr< $uid:gm$.Slist1sep $txt$ $x$ >> ] | TXnext _loc -> <:expr< $uid:gm$.Snext >> | TXnterm _loc n lev -> match lev with [ Some lab -> <:expr< $uid:gm$.Snterml ($uid:gm$.Entry.obj ($n.expr$ : $uid:gm$.Entry.t '$n.tvar$)) $str:lab$ >> | None -> if n.tvar = tvar then <:expr< $uid:gm$.Sself >> else <:expr< $uid:gm$.Snterm ($uid:gm$.Entry.obj ($n.expr$ : $uid:gm$.Entry.t '$n.tvar$)) >> ] | TXopt _loc t -> <:expr< $uid:gm$.Sopt $make_expr entry "" t$ >> | TXtry _loc t -> <:expr< $uid:gm$.Stry $make_expr entry "" t$ >> | TXrules _loc rl -> <:expr< $uid:gm$.srules $entry.expr$ $make_expr_rules _loc entry rl ""$ >> | TXself _loc -> <:expr< $uid:gm$.Sself >> | TXkwd _loc kwd -> <:expr< $uid:gm$.Skeyword $str:kwd$ >> | TXtok _loc match_fun descr -> <:expr< $uid:gm$.Stoken ($match_fun$, $`str:descr$) >> ] and make_expr_rules _loc n rl tvar = List.fold_left (fun txt (sl, ac) -> let sl = List.fold_right (fun t txt -> let x = make_expr n tvar t in <:expr< [$x$ :: $txt$] >>) sl <:expr< [] >> in <:expr< [($sl$, $ac$) :: $txt$] >>) <:expr< [] >> rl ; value expr_of_delete_rule _loc n sl = let sl = List.fold_right (fun s e -> <:expr< [$make_expr n "" s.text$ :: $e$] >>) sl <:expr< [] >> in (<:expr< $n.expr$ >>, sl) ; value rec tvar_of_ident = fun [ <:ident< $lid:x$ >> | <:ident< $uid:x$ >> -> x | <:ident< $uid:x$.$xs$ >> -> x ^ "__" ^ tvar_of_ident xs | _ -> failwith "internal error in the Grammar extension" ] ; value mk_name _loc i = {expr = <:expr< $id:i$ >>; tvar = tvar_of_ident i; loc = _loc}; value slist loc min sep symb = TXlist loc min symb sep ; (* value sstoken _loc s = let n = mk_name _loc <:ident< $lid:"a_" ^ s$ >> in TXnterm _loc n None ; value mk_symbol p s t = {used = []; text = s; styp = t; pattern=Some p}; value sslist _loc min sep s = let rl = let r1 = let prod = let n = mk_name _loc <:ident< a_list >> in [mk_symbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_list")] in let act = <:expr< a >> in {prod = prod; action = Some act} in let r2 = let prod = [mk_symbol <:patt< a >> (slist _loc min sep s) (STapp _loc (STlid _loc "list") s.styp)] in let act = <:expr< Qast.List a >> in {prod = prod; action = Some act} in [r1; r2] in let used = match sep with [ Some symb -> symb.used @ s.used | None -> s.used ] in let used = ["a_list" :: used] in let text = TXrules _loc (srules _loc "a_list" rl "") in let styp = STquo _loc "a_list" in {used = used; text = text; styp = styp; pattern = None} ; value ssopt _loc s = let rl = let r1 = let prod = let n = mk_name _loc <:ident< a_opt >> in [mk_symbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_opt")] in let act = <:expr< a >> in {prod = prod; action = Some act} in let r2 = let s = match s.text with [ TXkwd _loc _ | TXtok _loc _ _ -> let rl = [{prod = [{ (s) with pattern = Some <:patt< x >> }]; action = Some <:expr< Qast.Str (Token.extract_string x) >>}] in let t = new_type_var () in {used = []; text = TXrules _loc (srules _loc t rl ""); styp = STquo _loc t; pattern = None} | _ -> s ] in let prod = [mk_symbol <:patt< a >> (TXopt _loc s.text) (STapp _loc (STlid _loc "option") s.styp)] in let act = <:expr< Qast.Option a >> in {prod = prod; action = Some act} in [r1; r2] in let used = ["a_opt" :: s.used] in let text = TXrules _loc (srules _loc "a_opt" rl "") in let styp = STquo _loc "a_opt" in {used = used; text = text; styp = styp; pattern = None} ; *) value text_of_entry _loc e = let ent = let x = e.name in let _loc = e.name.loc in <:expr< ($x.expr$ : $uid:gm$.Entry.t '$x.tvar$) >> in let pos = match e.pos with [ Some pos -> <:expr< Some $pos$ >> | None -> <:expr< None >> ] in let txt = List.fold_right (fun level txt -> let lab = match level.label with [ Some lab -> <:expr< Some $str:lab$ >> | None -> <:expr< None >> ] in let ass = match level.assoc with [ Some ass -> <:expr< Some $ass$ >> | None -> <:expr< None >> ] in let txt = let rl = srules _loc e.name.tvar level.rules e.name.tvar in let e = make_expr_rules _loc e.name rl e.name.tvar in <:expr< [($lab$, $ass$, $e$) :: $txt$] >> in txt) e.levels <:expr< [] >> in (ent, pos, txt) ; value let_in_of_extend _loc gram gl el args = match gl with [ None -> args | Some nl -> do { check_use nl el; let ll = let same_tvar e n = e.name.tvar = n.tvar in List.fold_right (fun e ll -> match e.name.expr with [ <:expr< $lid:_$ >> -> if List.exists (same_tvar e) nl then ll else if List.exists (same_tvar e) ll then ll else [e.name :: ll] | _ -> ll ]) el [] in let local_binding_of_name {expr = e; tvar = x; loc = _loc} = let i = match e with [ <:expr< $lid:i$ >> -> i | _ -> failwith "internal error in the Grammar extension" ] in <:binding< $lid:i$ = (grammar_entry_create $str:i$ : $uid:gm$.Entry.t '$x$) >> in let expr_of_name {expr = e; tvar = x; loc = _loc} = <:expr< ($e$ : $uid:gm$.Entry.t '$x$) >> in let e = match ll with [ [] -> args | [x::xs] -> let locals = List.fold_right (fun name acc -> <:binding< $acc$ and $local_binding_of_name name$ >>) xs (local_binding_of_name x) in let entry_mk = match gram with [ Some g -> <:expr< $uid:gm$.Entry.mk $id:g$ >> | None -> <:expr< $uid:gm$.Entry.mk >> ] in <:expr< let grammar_entry_create = $entry_mk$ in let $locals$ in $args$ >> ] in match nl with [ [] -> e | [x::xs] -> let globals = List.fold_right (fun name acc -> <:binding< $acc$ and _ = $expr_of_name name$ >>) xs <:binding< _ = $expr_of_name x$ >> in <:expr< let $globals$ in $e$ >> ] } ] ; class subst gmod = object inherit Ast.map as super; method ident = fun [ <:ident< $uid:x$ >> when x = gm -> gmod | x -> super#ident x ]; end; value subst_gmod ast gmod = (new subst gmod)#expr ast; value text_of_functorial_extend _loc gmod gram gl el = let args = let el = List.map (fun e -> let (ent, pos, txt) = text_of_entry e.name.loc e in let e = <:expr< $uid:gm$.extend $ent$ ((fun () -> ($pos$, $txt$)) ()) >> in if split_ext.val then <:expr< let aux () = $e$ in aux () >> else e) el in match el with [ [] -> <:expr< () >> | [e] -> e | [e::el] -> <:expr< do { $List.fold_left (fun acc x -> <:expr< $acc$; $x$ >>) e el$ } >> ] in subst_gmod (let_in_of_extend _loc gram gl el args) gmod; value wildcarder = object (self) inherit Ast.map as super; method patt = fun [ <:patt@_loc< $lid:_$ >> -> <:patt< _ >> | <:patt< ($p$ as $_$) >> -> self#patt p | p -> super#patt p ]; end; value mk_tok _loc p t = let p' = wildcarder#patt p in let match_fun = if Ast.is_irrefut_patt p' then <:expr< fun [ $pat:p'$ -> True ] >> else <:expr< fun [ $pat:p'$ -> True | _ -> False ] >> in let descr = string_of_patt p' in let text = TXtok _loc match_fun descr in {used = []; text = text; styp = t; pattern = Some p }; value symbol = Gram.Entry.mk "symbol"; value check_not_tok s = match s with [ {text = TXtok _loc _ _ } -> Loc.raise _loc (Stream.Error ("Deprecated syntax, use a sub rule. "^ "LIST0 STRING becomes LIST0 [ x = STRING -> x ]")) | _ -> () ]; Camlp4_config.antiquotations.val := True; EXTEND Gram GLOBAL: expr symbol; expr: AFTER "top" [ [ "EXTEND"; e = extend_body; "END" -> e | "DELETE_RULE"; e = delete_rule_body; "END" -> e | "GDELETE_RULE" -> Loc.raise _loc (Stream.Error "Deprecated syntax, use DELETE_RULE MyGramModule ... END instead") | "GEXTEND" -> Loc.raise _loc (Stream.Error "Deprecated syntax, use EXTEND MyGramModule ... END instead") ] ] ; extend_header: [ [ "("; i = qualid; ":"; t = t_qualid; ")" -> (Some i, t) | g = qualuid -> (None, g) ] ] ; extend_body: [ [ (gram, g) = extend_header; global_list = OPT global; el = LIST1 [ e = entry; semi_sep -> e ] -> text_of_functorial_extend _loc g gram global_list el ] ] ; delete_rule_body: [ [ g = qualuid; n = name; ":"; sl = LIST0 symbol SEP semi_sep -> let (e, b) = expr_of_delete_rule _loc n sl in subst_gmod <:expr< $uid:gm$.delete_rule $e$ $b$ >> g ] ] ; qualuid: [ [ [ LIDENT | UIDENT "GLOBAL" ] -> Loc.raise _loc (Stream.Error "Deprecated syntax, the grammar module is expected") ] | [ x = UIDENT; "."; xs = SELF -> <:ident< $uid:x$.$xs$ >> | i = UIDENT -> <:ident< $uid:i$ >> ] ] ; qualuid: [ [ [ LIDENT | UIDENT "GLOBAL" ] -> Loc.raise _loc (Stream.Error "Deprecated syntax, the grammar module is expected") ] | [ x = UIDENT; "."; xs = SELF -> <:ident< $uid:x$.$xs$ >> | i = UIDENT -> <:ident< $uid:i$ >> ] ] ; qualid: [ [ x = UIDENT; "."; xs = SELF -> <:ident< $uid:x$.$xs$ >> | i = UIDENT -> <:ident< $uid:i$ >> | i = LIDENT -> <:ident< $lid:i$ >> ] ] ; t_qualid: [ [ x = UIDENT; "."; xs = SELF -> <:ident< $uid:x$.$xs$ >> | x = UIDENT; "."; `LIDENT "t" -> <:ident< $uid:x$ >> | `(LIDENT _ | UIDENT _) -> Loc.raise _loc (Stream.Error ("Wrong EXTEND header, the grammar type must finish by 't', "^ "like in EXTEND (g : Gram.t) ... END")) ] ] ; global: [ [ UIDENT "GLOBAL"; ":"; sl = LIST1 name; semi_sep -> sl ] ] ; entry: [ [ n = name; ":"; pos = OPT position; ll = level_list -> {name = n; pos = pos; levels = ll} ] ] ; position: [ [ UIDENT "FIRST" -> <:expr< Camlp4.Sig.Grammar.First >> | UIDENT "LAST" -> <:expr< Camlp4.Sig.Grammar.Last >> | UIDENT "BEFORE"; n = string -> <:expr< Camlp4.Sig.Grammar.Before $n$ >> | UIDENT "AFTER"; n = string -> <:expr< Camlp4.Sig.Grammar.After $n$ >> | UIDENT "LEVEL"; n = string -> <:expr< Camlp4.Sig.Grammar.Level $n$ >> ] ] ; level_list: [ [ "["; ll = LIST0 level SEP "|"; "]" -> ll ] ] ; level: [ [ lab = OPT [ x = STRING -> x ]; ass = OPT assoc; rules = rule_list -> {label = lab; assoc = ass; rules = rules} ] ] ; assoc: [ [ UIDENT "LEFTA" -> <:expr< Camlp4.Sig.Grammar.LeftA >> | UIDENT "RIGHTA" -> <:expr< Camlp4.Sig.Grammar.RightA >> | UIDENT "NONA" -> <:expr< Camlp4.Sig.Grammar.NonA >> ] ] ; rule_list: [ [ "["; "]" -> [] | "["; rules = LIST1 rule SEP "|"; "]" -> retype_rule_list_without_patterns _loc rules ] ] ; rule: [ [ psl = LIST0 psymbol SEP semi_sep; "->"; act = expr -> {prod = psl; action = Some act} | psl = LIST0 psymbol SEP semi_sep -> {prod = psl; action = None} ] ] ; psymbol: [ [ p = LIDENT; "="; s = symbol -> match s.pattern with [ Some (<:patt< $uid:u$ ($tup:<:patt< _ >>$) >> as p') -> let match_fun = <:expr< fun [ $pat:p'$ -> True | _ -> False ] >> in let p' = <:patt< ($p'$ as $lid:p$) >> in let descr = u ^ " _" in let text = TXtok _loc match_fun descr in { (s) with text = text; pattern = Some p' } | _ -> { (s) with pattern = Some <:patt< $lid:p$ >> } ] | i = LIDENT; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] -> let name = mk_name _loc <:ident< $lid:i$ >> in let text = TXnterm _loc name lev in let styp = STquo _loc i in {used = [i]; text = text; styp = styp; pattern = None} | p = pattern; "="; s = symbol -> match s.pattern with [ Some <:patt< $uid:u$ ($tup:<:patt< _ >>$) >> -> mk_tok _loc <:patt< $uid:u$ $p$ >> s.styp | _ -> { (s) with pattern = Some p } ] | s = symbol -> s ] ] ; symbol: [ "top" NONA [ UIDENT "LIST0"; s = SELF; sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> let () = check_not_tok s in let used = match sep with [ Some symb -> symb.used @ s.used | None -> s.used ] in let styp = STapp _loc (STlid _loc "list") s.styp in let text = slist _loc False sep s in {used = used; text = text; styp = styp; pattern = None} | UIDENT "LIST1"; s = SELF; sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> let () = check_not_tok s in let used = match sep with [ Some symb -> symb.used @ s.used | None -> s.used ] in let styp = STapp _loc (STlid _loc "list") s.styp in let text = slist _loc True sep s in {used = used; text = text; styp = styp; pattern = None} | UIDENT "OPT"; s = SELF -> let () = check_not_tok s in let styp = STapp _loc (STlid _loc "option") s.styp in let text = TXopt _loc s.text in {used = s.used; text = text; styp = styp; pattern = None} | UIDENT "TRY"; s = SELF -> let text = TXtry _loc s.text in {used = s.used; text = text; styp = s.styp; pattern = None} ] | [ UIDENT "SELF" -> {used = []; text = TXself _loc; styp = STself _loc "SELF"; pattern = None} | UIDENT "NEXT" -> {used = []; text = TXnext _loc; styp = STself _loc "NEXT"; pattern = None} | "["; rl = LIST0 rule SEP "|"; "]" -> let rl = retype_rule_list_without_patterns _loc rl in let t = new_type_var () in {used = used_of_rule_list rl; text = TXrules _loc (srules _loc t rl ""); styp = STquo _loc t; pattern = None} | "`"; p = patt -> mk_tok _loc p (STtok _loc) | x = UIDENT -> mk_tok _loc <:patt< $uid:x$ ($tup:<:patt< _ >>$) >> (STstring_tok _loc) | x = UIDENT; s = STRING -> mk_tok _loc <:patt< $uid:x$ $str:s$ >> (STtok _loc) | x = UIDENT; `ANTIQUOT "" s -> let e = AntiquotSyntax.parse_expr _loc s in let match_fun = <:expr< fun [ $uid:x$ camlp4_x when camlp4_x = $e$ -> True | _ -> False ] >> in let descr = "$" ^ x ^ " " ^ s in let text = TXtok _loc match_fun descr in let p = <:patt< $uid:x$ ($tup:<:patt< _ >>$) >> in {used = []; text = text; styp = STtok _loc; pattern = Some p } | s = STRING -> {used = []; text = TXkwd _loc s; styp = STtok _loc; pattern = None } | i = UIDENT; "."; il = qualid; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] -> let n = mk_name _loc <:ident< $uid:i$.$il$ >> in {used = [n.tvar]; text = TXnterm _loc n lev; styp = STquo _loc n.tvar; pattern = None} | n = name; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] -> {used = [n.tvar]; text = TXnterm _loc n lev; styp = STquo _loc n.tvar; pattern = None} | "("; s_t = SELF; ")" -> s_t ] ] ; pattern: [ [ i = LIDENT -> <:patt< $lid:i$ >> | "_" -> <:patt< _ >> | "("; p = pattern; ")" -> <:patt< $p$ >> | "("; p1 = pattern; ","; p2 = comma_patt; ")" -> <:patt< ( $p1$, $p2$ ) >> ] ] ; comma_patt: [ [ p1 = SELF; ","; p2 = SELF -> <:patt< $p1$, $p2$ >> | p = pattern -> p ] ] ; name: [ [ il = qualid -> mk_name _loc il ] ] ; string: [ [ s = STRING -> <:expr< $str:s$ >> | `ANTIQUOT "" s -> AntiquotSyntax.parse_expr _loc s ] ] ; semi_sep: [ [ ";" -> () ] ] ; END; (* EXTEND Gram symbol: LEVEL "top" [ NONA [ min = [ UIDENT "SLIST0" -> False | UIDENT "SLIST1" -> True ]; s = SELF; sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> sslist _loc min sep s | UIDENT "SOPT"; s = SELF -> ssopt _loc s ] ] ; END; *) value sfold _loc n foldfun f e s = let styp = STquo _loc (new_type_var ()) in let e = <:expr< $uid:gm$.$lid:foldfun$ $f$ $e$ >> in let t = STapp _loc (STapp _loc (STtyp <:ctyp< $uid:gm$.fold _ >>) s.styp) styp in {used = s.used; text = TXmeta _loc n [s.text] e t; styp = styp; pattern = None } ; value sfoldsep _loc n foldfun f e s sep = let styp = STquo _loc (new_type_var ()) in let e = <:expr< $uid:gm$.$lid:foldfun$ $f$ $e$ >> in let t = STapp _loc (STapp _loc (STtyp <:ctyp< $uid:gm$.foldsep _ >>) s.styp) styp in {used = s.used @ sep.used; text = TXmeta _loc n [s.text; sep.text] e t; styp = styp; pattern = None} ; EXTEND Gram GLOBAL: symbol; symbol: LEVEL "top" [ [ UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF -> sfold _loc "FOLD0" "sfold0" f e s | UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF -> sfold _loc "FOLD1" "sfold1" f e s | UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF; UIDENT "SEP"; sep = symbol -> sfoldsep _loc "FOLD0 SEP" "sfold0sep" f e s sep | UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF; UIDENT "SEP"; sep = symbol -> sfoldsep _loc "FOLD1 SEP" "sfold1sep" f e s sep ] ] ; simple_expr: [ [ i = a_LIDENT -> <:expr< $lid:i$ >> | "("; e = expr; ")" -> e ] ] ; END; Options.add "-split_ext" (Arg.Set split_ext) "Split EXTEND by functions to turn around a PowerPC problem."; Options.add "-split_gext" (Arg.Set split_ext) "Old name for the option -split_ext."; Options.add "-meta_action" (Arg.Set meta_action) "Undocumented"; (* FIXME *) end; module M = Register.OCamlSyntaxExtension Id Make; mingw-ocaml/ocaml/camlp4/test/0000755000175000017500000000000012124403240015614 5ustar tootstootsmingw-ocaml/ocaml/camlp4/test/fixtures/0000755000175000017500000000000012124403240017465 5ustar tootstootsmingw-ocaml/ocaml/camlp4/test/fixtures/assert.ml0000644000175000017500000000013012124403240021312 0ustar tootstootsmodule MySet = Set.Make(String);; let set = MySet.empty;; assert (MySet.is_empty set);; mingw-ocaml/ocaml/camlp4/test/fixtures/gram-tree.ml0000644000175000017500000000113212124403240021677 0ustar tootstootsopen Camlp4.PreCast; module G = MakeGram Lexer; type t = [ A of t and t | B of string ]; value main = G.Entry.mk "main"; (* value rec length x acc = match x with [ A x y -> length x (length y acc) | B _ -> succ acc ]; *) value length _ _ = -1; EXTEND G GLOBAL: main; main: [ [ x = SELF; y = SELF -> A x y | i = ident -> B i ] ]; ident: [ [ `LIDENT s -> s ] ]; END; try let f = Sys.argv.(1) in Format.printf "%d@." (length (G.parse main (Loc.mk f) (Stream.of_channel (open_in f))) 0) with e -> Format.eprintf "error: %a@." Camlp4.ErrorHandler.print e; mingw-ocaml/ocaml/camlp4/test/fixtures/backquoted_record.ml0000644000175000017500000000015212124403240023475 0ustar tootstootsEXTEND Gram raw_string: [[ `QUOTATION { Sig.Quotation.q_contents = c; q_name = n } -> (c, n) ]]; END; mingw-ocaml/ocaml/camlp4/test/fixtures/pr4314gram2.ml0000644000175000017500000000132612124403240021707 0ustar tootstootsopen Camlp4.PreCast ; module G = Camlp4.PreCast.Gram ; value exp = G.Entry.mk "exp" ; value prog = G.Entry.mk "prog" ; EXTEND G exp: [ "apply" [ e1 = exp LEVEL "simple"; e2 = SELF -> let p = Loc.dump in let () = Format.eprintf "e1: %a,@.e2: %a,@.e1-e2: %a,@._loc: %a@." p e1 p e2 p (Loc.merge e1 e2) p _loc in _loc ] | "simple" [ _ = LIDENT -> _loc ] ]; prog: [[ e = exp; `EOI -> e ]]; END ; (* and the following function: *) value parse_string entry s = try G.parse_string entry (Loc.mk "") s with [ Loc.Exc_located loc exn -> begin print_endline (Loc.to_string loc); print_endline (Printexc.to_string exn); failwith "Syntax Error" end ] ; parse_string prog "f x"; mingw-ocaml/ocaml/camlp4/test/fixtures/pr4314gram1.ml0000644000175000017500000000131012124403240021677 0ustar tootstootsopen Camlp4.PreCast ; module G = Camlp4.PreCast.Gram ; value exp = G.Entry.mk "exp" ; value prog = G.Entry.mk "prog" ; EXTEND G exp: [ "apply" [ e1 = SELF; e2 = SELF -> let p = Loc.dump in let () = Format.eprintf "e1: %a,@.e2: %a,@.e1-e2: %a,@._loc: %a@." p e1 p e2 p (Loc.merge e1 e2) p _loc in _loc ] | "simple" [ _ = LIDENT -> _loc ] ]; prog: [[ e = exp; `EOI -> e ]]; END ; (* and the following function: *) value parse_string entry s = try G.parse_string entry (Loc.mk "") s with [ Loc.Exc_located loc exn -> begin print_endline (Loc.to_string loc); print_endline (Printexc.to_string exn); failwith "Syntax Error" end ] ; parse_string prog "f x"; mingw-ocaml/ocaml/camlp4/test/fixtures/meta_multi_term.ml0000644000175000017500000000046612124403240023214 0ustar tootstootsopen Camlp4.PreCast; value _loc = Loc.ghost; module Term = struct type patt = [ PApp of patt and patt | PAny | PVar of string | POlb of string and expr ] and expr = [ EApp of expr and expr | EVar of string | ELam of patt and expr ]; end; module MetaTerm = MetaGenerator Term; mingw-ocaml/ocaml/camlp4/test/fixtures/big-tab2.ml0000644000175000017500000032616612124403240021424 0ustar tootstoots[| aaaa; aaab; aaac; aaad; aaae; aaaf; aaag; aaah; aaai; aaaj; aaak; aaal; aaam; aaan; aaao; aaap; aaaq; aaar; aaas; aaat; aaau; aaav; aaaw; aaax; aaay; aaaz; aaba; aabb; aabc; aabd; aabe; aabf; aabg; aabh; aabi; aabj; aabk; aabl; aabm; aabn; aabo; aabp; aabq; aabr; aabs; aabt; aabu; aabv; aabw; aabx; aaby; aabz; aaca; aacb; aacc; aacd; aace; aacf; aacg; aach; aaci; aacj; aack; aacl; aacm; aacn; aaco; aacp; aacq; aacr; aacs; aact; aacu; aacv; aacw; aacx; aacy; aacz; aada; aadb; aadc; aadd; aade; aadf; aadg; aadh; aadi; aadj; aadk; aadl; aadm; aadn; aado; aadp; aadq; aadr; aads; aadt; aadu; aadv; aadw; aadx; aady; aadz; aaea; aaeb; aaec; aaed; aaee; aaef; aaeg; aaeh; aaei; aaej; aaek; aael; aaem; aaen; aaeo; aaep; aaeq; aaer; aaes; aaet; aaeu; aaev; aaew; aaex; aaey; aaez; aafa; aafb; aafc; aafd; aafe; aaff; aafg; aafh; aafi; aafj; aafk; aafl; aafm; aafn; aafo; aafp; aafq; aafr; aafs; aaft; aafu; aafv; aafw; aafx; aafy; aafz; aaga; aagb; aagc; aagd; aage; aagf; aagg; aagh; aagi; aagj; aagk; aagl; aagm; aagn; aago; aagp; aagq; aagr; aags; aagt; aagu; aagv; aagw; aagx; aagy; aagz; aaha; aahb; aahc; aahd; aahe; aahf; aahg; aahh; aahi; aahj; aahk; aahl; aahm; aahn; aaho; aahp; aahq; aahr; aahs; aaht; aahu; aahv; aahw; aahx; aahy; aahz; aaia; aaib; aaic; aaid; aaie; aaif; aaig; aaih; aaii; aaij; aaik; aail; aaim; aain; aaio; aaip; aaiq; aair; aais; aait; aaiu; aaiv; aaiw; aaix; aaiy; aaiz; aaja; aajb; aajc; aajd; aaje; aajf; aajg; aajh; aaji; aajj; aajk; aajl; aajm; aajn; aajo; aajp; aajq; aajr; aajs; aajt; aaju; aajv; aajw; aajx; aajy; aajz; aaka; aakb; aakc; aakd; aake; aakf; aakg; aakh; aaki; aakj; aakk; aakl; aakm; aakn; aako; aakp; aakq; aakr; aaks; aakt; aaku; aakv; aakw; aakx; aaky; aakz; aala; aalb; aalc; aald; aale; aalf; aalg; aalh; aali; aalj; aalk; aall; aalm; aaln; aalo; aalp; aalq; aalr; aals; aalt; aalu; aalv; aalw; aalx; aaly; aalz; aama; aamb; aamc; aamd; aame; aamf; aamg; aamh; aami; aamj; aamk; aaml; aamm; aamn; aamo; aamp; aamq; aamr; aams; aamt; aamu; aamv; aamw; aamx; aamy; aamz; aana; aanb; aanc; aand; aane; aanf; aang; aanh; aani; aanj; aank; aanl; aanm; aann; aano; aanp; aanq; aanr; aans; aant; aanu; aanv; aanw; aanx; aany; aanz; aaoa; aaob; aaoc; aaod; aaoe; aaof; aaog; aaoh; aaoi; aaoj; aaok; aaol; aaom; aaon; aaoo; aaop; aaoq; aaor; aaos; aaot; aaou; aaov; aaow; aaox; aaoy; aaoz; aapa; aapb; aapc; aapd; aape; aapf; aapg; aaph; aapi; aapj; aapk; aapl; aapm; aapn; aapo; aapp; aapq; aapr; aaps; aapt; aapu; aapv; aapw; aapx; aapy; aapz; aaqa; aaqb; aaqc; aaqd; aaqe; aaqf; aaqg; aaqh; aaqi; aaqj; aaqk; aaql; aaqm; aaqn; aaqo; aaqp; aaqq; aaqr; aaqs; aaqt; aaqu; aaqv; aaqw; aaqx; aaqy; aaqz; aara; aarb; aarc; aard; aare; aarf; aarg; aarh; aari; aarj; aark; aarl; aarm; aarn; aaro; aarp; aarq; aarr; aars; aart; aaru; aarv; aarw; aarx; aary; aarz; aasa; aasb; aasc; aasd; aase; aasf; aasg; aash; aasi; aasj; aask; aasl; aasm; aasn; aaso; aasp; aasq; aasr; aass; aast; aasu; aasv; aasw; aasx; aasy; aasz; aata; aatb; aatc; aatd; aate; aatf; aatg; aath; aati; aatj; aatk; aatl; aatm; aatn; aato; aatp; aatq; aatr; aats; aatt; aatu; aatv; aatw; aatx; aaty; aatz; aaua; aaub; aauc; aaud; aaue; aauf; aaug; aauh; aaui; aauj; aauk; aaul; aaum; aaun; aauo; aaup; aauq; aaur; aaus; aaut; aauu; aauv; aauw; aaux; aauy; aauz; aava; aavb; aavc; aavd; aave; aavf; aavg; aavh; aavi; aavj; aavk; aavl; aavm; aavn; aavo; aavp; aavq; aavr; aavs; aavt; aavu; aavv; aavw; aavx; aavy; aavz; aawa; aawb; aawc; aawd; aawe; aawf; aawg; aawh; aawi; aawj; aawk; aawl; aawm; aawn; aawo; aawp; aawq; aawr; aaws; aawt; aawu; aawv; aaww; aawx; aawy; aawz; aaxa; aaxb; aaxc; aaxd; aaxe; aaxf; aaxg; aaxh; aaxi; aaxj; aaxk; aaxl; aaxm; aaxn; aaxo; aaxp; aaxq; aaxr; aaxs; aaxt; aaxu; aaxv; aaxw; aaxx; aaxy; aaxz; aaya; aayb; aayc; aayd; aaye; aayf; aayg; aayh; aayi; aayj; aayk; aayl; aaym; aayn; aayo; aayp; aayq; aayr; aays; aayt; aayu; aayv; aayw; aayx; aayy; aayz; aaza; aazb; aazc; aazd; aaze; aazf; aazg; aazh; aazi; aazj; aazk; aazl; aazm; aazn; aazo; aazp; aazq; aazr; aazs; aazt; aazu; aazv; aazw; aazx; aazy; aazz; abaa; abab; abac; abad; abae; abaf; abag; abah; abai; abaj; abak; abal; abam; aban; abao; abap; abaq; abar; abas; abat; abau; abav; abaw; abax; abay; abaz; abba; abbb; abbc; abbd; abbe; abbf; abbg; abbh; abbi; abbj; abbk; abbl; abbm; abbn; abbo; abbp; abbq; abbr; abbs; abbt; abbu; abbv; abbw; abbx; abby; abbz; abca; abcb; abcc; abcd; abce; abcf; abcg; abch; abci; abcj; abck; abcl; abcm; abcn; abco; abcp; abcq; abcr; abcs; abct; abcu; abcv; abcw; abcx; abcy; abcz; abda; abdb; abdc; abdd; abde; abdf; abdg; abdh; abdi; abdj; abdk; abdl; abdm; abdn; abdo; abdp; abdq; abdr; abds; abdt; abdu; abdv; abdw; abdx; abdy; abdz; abea; abeb; abec; abed; abee; abef; abeg; abeh; abei; abej; abek; abel; abem; aben; abeo; abep; abeq; aber; abes; abet; abeu; abev; abew; abex; abey; abez; abfa; abfb; abfc; abfd; abfe; abff; abfg; abfh; abfi; abfj; abfk; abfl; abfm; abfn; abfo; abfp; abfq; abfr; abfs; abft; abfu; abfv; abfw; abfx; abfy; abfz; abga; abgb; abgc; abgd; abge; abgf; abgg; abgh; abgi; abgj; abgk; abgl; abgm; abgn; abgo; abgp; abgq; abgr; abgs; abgt; abgu; abgv; abgw; abgx; abgy; abgz; abha; abhb; abhc; abhd; abhe; abhf; abhg; abhh; abhi; abhj; abhk; abhl; abhm; abhn; abho; abhp; abhq; abhr; abhs; abht; abhu; abhv; abhw; abhx; abhy; abhz; abia; abib; abic; abid; abie; abif; abig; abih; abii; abij; abik; abil; abim; abin; abio; abip; abiq; abir; abis; abit; abiu; abiv; abiw; abix; abiy; abiz; abja; abjb; abjc; abjd; abje; abjf; abjg; abjh; abji; abjj; abjk; abjl; abjm; abjn; abjo; abjp; abjq; abjr; abjs; abjt; abju; abjv; abjw; abjx; abjy; abjz; abka; abkb; abkc; abkd; abke; abkf; abkg; abkh; abki; abkj; abkk; abkl; abkm; abkn; abko; abkp; abkq; abkr; abks; abkt; abku; abkv; abkw; abkx; abky; abkz; abla; ablb; ablc; abld; able; ablf; ablg; ablh; abli; ablj; ablk; abll; ablm; abln; ablo; ablp; ablq; ablr; abls; ablt; ablu; ablv; ablw; ablx; ably; ablz; abma; abmb; abmc; abmd; abme; abmf; abmg; abmh; abmi; abmj; abmk; abml; abmm; abmn; abmo; abmp; abmq; abmr; abms; abmt; abmu; abmv; abmw; abmx; abmy; abmz; abna; abnb; abnc; abnd; abne; abnf; abng; abnh; abni; abnj; abnk; abnl; abnm; abnn; abno; abnp; abnq; abnr; abns; abnt; abnu; abnv; abnw; abnx; abny; abnz; aboa; abob; aboc; abod; aboe; abof; abog; aboh; aboi; aboj; abok; abol; abom; abon; aboo; abop; aboq; abor; abos; abot; abou; abov; abow; abox; aboy; aboz; abpa; abpb; abpc; abpd; abpe; abpf; abpg; abph; abpi; abpj; abpk; abpl; abpm; abpn; abpo; abpp; abpq; abpr; abps; abpt; abpu; abpv; abpw; abpx; abpy; abpz; abqa; abqb; abqc; abqd; abqe; abqf; abqg; abqh; abqi; abqj; abqk; abql; abqm; abqn; abqo; abqp; abqq; abqr; abqs; abqt; abqu; abqv; abqw; abqx; abqy; abqz; abra; abrb; abrc; abrd; abre; abrf; abrg; abrh; abri; abrj; abrk; abrl; abrm; abrn; abro; abrp; abrq; abrr; abrs; abrt; abru; abrv; abrw; abrx; abry; abrz; absa; absb; absc; absd; abse; absf; absg; absh; absi; absj; absk; absl; absm; absn; abso; absp; absq; absr; abss; abst; absu; absv; absw; absx; absy; absz; abta; abtb; abtc; abtd; abte; abtf; abtg; abth; abti; abtj; abtk; abtl; abtm; abtn; abto; abtp; abtq; abtr; abts; abtt; abtu; abtv; abtw; abtx; abty; abtz; abua; abub; abuc; abud; abue; abuf; abug; abuh; abui; abuj; abuk; abul; abum; abun; abuo; abup; abuq; abur; abus; abut; abuu; abuv; abuw; abux; abuy; abuz; abva; abvb; abvc; abvd; abve; abvf; abvg; abvh; abvi; abvj; abvk; abvl; abvm; abvn; abvo; abvp; abvq; abvr; abvs; abvt; abvu; abvv; abvw; abvx; abvy; abvz; abwa; abwb; abwc; abwd; abwe; abwf; abwg; abwh; abwi; abwj; abwk; abwl; abwm; abwn; abwo; abwp; abwq; abwr; abws; abwt; abwu; abwv; abww; abwx; abwy; abwz; abxa; abxb; abxc; abxd; abxe; abxf; abxg; abxh; abxi; abxj; abxk; abxl; abxm; abxn; abxo; abxp; abxq; abxr; abxs; abxt; abxu; abxv; abxw; abxx; abxy; abxz; abya; abyb; abyc; abyd; abye; abyf; abyg; abyh; abyi; abyj; abyk; abyl; abym; abyn; abyo; abyp; abyq; abyr; abys; abyt; abyu; abyv; abyw; abyx; abyy; abyz; abza; abzb; abzc; abzd; abze; abzf; abzg; abzh; abzi; abzj; abzk; abzl; abzm; abzn; abzo; abzp; abzq; abzr; abzs; abzt; abzu; abzv; abzw; abzx; abzy; abzz; acaa; acab; acac; acad; acae; acaf; acag; acah; acai; acaj; acak; acal; acam; acan; acao; acap; acaq; acar; acas; acat; acau; acav; acaw; acax; acay; acaz; acba; acbb; acbc; acbd; acbe; acbf; acbg; acbh; acbi; acbj; acbk; acbl; acbm; acbn; acbo; acbp; acbq; acbr; acbs; acbt; acbu; acbv; acbw; acbx; acby; acbz; acca; accb; accc; accd; acce; accf; accg; acch; acci; accj; acck; accl; accm; accn; acco; accp; accq; accr; accs; acct; accu; accv; accw; accx; accy; accz; acda; acdb; acdc; acdd; acde; acdf; acdg; acdh; acdi; acdj; acdk; acdl; acdm; acdn; acdo; acdp; acdq; acdr; acds; acdt; acdu; acdv; acdw; acdx; acdy; acdz; acea; aceb; acec; aced; acee; acef; aceg; aceh; acei; acej; acek; acel; acem; acen; aceo; acep; aceq; acer; aces; acet; aceu; acev; acew; acex; acey; acez; acfa; acfb; acfc; acfd; acfe; acff; acfg; acfh; acfi; acfj; acfk; acfl; acfm; acfn; acfo; acfp; acfq; acfr; acfs; acft; acfu; acfv; acfw; acfx; acfy; acfz; acga; acgb; acgc; acgd; acge; acgf; acgg; acgh; acgi; acgj; acgk; acgl; acgm; acgn; acgo; acgp; acgq; acgr; acgs; acgt; acgu; acgv; acgw; acgx; acgy; acgz; acha; achb; achc; achd; ache; achf; achg; achh; achi; achj; achk; achl; achm; achn; acho; achp; achq; achr; achs; acht; achu; achv; achw; achx; achy; achz; acia; acib; acic; acid; acie; acif; acig; acih; acii; acij; acik; acil; acim; acin; acio; acip; aciq; acir; acis; acit; aciu; aciv; aciw; acix; aciy; aciz; acja; acjb; acjc; acjd; acje; acjf; acjg; acjh; acji; acjj; acjk; acjl; acjm; acjn; acjo; acjp; acjq; acjr; acjs; acjt; acju; acjv; acjw; acjx; acjy; acjz; acka; ackb; ackc; ackd; acke; ackf; ackg; ackh; acki; ackj; ackk; ackl; ackm; ackn; acko; ackp; ackq; ackr; acks; ackt; acku; ackv; ackw; ackx; acky; ackz; acla; aclb; aclc; acld; acle; aclf; aclg; aclh; acli; aclj; aclk; acll; aclm; acln; aclo; aclp; aclq; aclr; acls; aclt; aclu; aclv; aclw; aclx; acly; aclz; acma; acmb; acmc; acmd; acme; acmf; acmg; acmh; acmi; acmj; acmk; acml; acmm; acmn; acmo; acmp; acmq; acmr; acms; acmt; acmu; acmv; acmw; acmx; acmy; acmz; acna; acnb; acnc; acnd; acne; acnf; acng; acnh; acni; acnj; acnk; acnl; acnm; acnn; acno; acnp; acnq; acnr; acns; acnt; acnu; acnv; acnw; acnx; acny; acnz; acoa; acob; acoc; acod; acoe; acof; acog; acoh; acoi; acoj; acok; acol; acom; acon; acoo; acop; acoq; acor; acos; acot; acou; acov; acow; acox; acoy; acoz; acpa; acpb; acpc; acpd; acpe; acpf; acpg; acph; acpi; acpj; acpk; acpl; acpm; acpn; acpo; acpp; acpq; acpr; acps; acpt; acpu; acpv; acpw; acpx; acpy; acpz; acqa; acqb; acqc; acqd; acqe; acqf; acqg; acqh; acqi; acqj; acqk; acql; acqm; acqn; acqo; acqp; acqq; acqr; acqs; acqt; acqu; acqv; acqw; acqx; acqy; acqz; acra; acrb; acrc; acrd; acre; acrf; acrg; acrh; acri; acrj; acrk; acrl; acrm; acrn; acro; acrp; acrq; acrr; acrs; acrt; acru; acrv; acrw; acrx; acry; acrz; acsa; acsb; acsc; acsd; acse; acsf; acsg; acsh; acsi; acsj; acsk; acsl; acsm; acsn; acso; acsp; acsq; acsr; acss; acst; acsu; acsv; acsw; acsx; acsy; acsz; acta; actb; actc; actd; acte; actf; actg; acth; acti; actj; actk; actl; actm; actn; acto; actp; actq; actr; acts; actt; actu; actv; actw; actx; acty; actz; acua; acub; acuc; acud; acue; acuf; acug; acuh; acui; acuj; acuk; acul; acum; acun; acuo; acup; acuq; acur; acus; acut; acuu; acuv; acuw; acux; acuy; acuz; acva; acvb; acvc; acvd; acve; acvf; acvg; acvh; acvi; acvj; acvk; acvl; acvm; acvn; acvo; acvp; acvq; acvr; acvs; acvt; acvu; acvv; acvw; acvx; acvy; acvz; acwa; acwb; acwc; acwd; acwe; acwf; acwg; acwh; acwi; acwj; acwk; acwl; acwm; acwn; acwo; acwp; acwq; acwr; acws; acwt; acwu; acwv; acww; acwx; acwy; acwz; acxa; acxb; acxc; acxd; acxe; acxf; acxg; acxh; acxi; acxj; acxk; acxl; acxm; acxn; acxo; acxp; acxq; acxr; acxs; acxt; acxu; acxv; acxw; acxx; acxy; acxz; acya; acyb; acyc; acyd; acye; acyf; acyg; acyh; acyi; acyj; acyk; acyl; acym; acyn; acyo; acyp; acyq; acyr; acys; acyt; acyu; acyv; acyw; acyx; acyy; acyz; acza; aczb; aczc; aczd; acze; aczf; aczg; aczh; aczi; aczj; aczk; aczl; aczm; aczn; aczo; aczp; aczq; aczr; aczs; aczt; aczu; aczv; aczw; aczx; aczy; aczz; adaa; adab; adac; adad; adae; adaf; adag; adah; adai; adaj; adak; adal; adam; adan; adao; adap; adaq; adar; adas; adat; adau; adav; adaw; adax; aday; adaz; adba; adbb; adbc; adbd; adbe; adbf; adbg; adbh; adbi; adbj; adbk; adbl; adbm; adbn; adbo; adbp; adbq; adbr; adbs; adbt; adbu; adbv; adbw; adbx; adby; adbz; adca; adcb; adcc; adcd; adce; adcf; adcg; adch; adci; adcj; adck; adcl; adcm; adcn; adco; adcp; adcq; adcr; adcs; adct; adcu; adcv; adcw; adcx; adcy; adcz; adda; addb; addc; addd; adde; addf; addg; addh; addi; addj; addk; addl; addm; addn; addo; addp; addq; addr; adds; addt; addu; addv; addw; addx; addy; addz; adea; adeb; adec; aded; adee; adef; adeg; adeh; adei; adej; adek; adel; adem; aden; adeo; adep; adeq; ader; ades; adet; adeu; adev; adew; adex; adey; adez; adfa; adfb; adfc; adfd; adfe; adff; adfg; adfh; adfi; adfj; adfk; adfl; adfm; adfn; adfo; adfp; adfq; adfr; adfs; adft; adfu; adfv; adfw; adfx; adfy; adfz; adga; adgb; adgc; adgd; adge; adgf; adgg; adgh; adgi; adgj; adgk; adgl; adgm; adgn; adgo; adgp; adgq; adgr; adgs; adgt; adgu; adgv; adgw; adgx; adgy; adgz; adha; adhb; adhc; adhd; adhe; adhf; adhg; adhh; adhi; adhj; adhk; adhl; adhm; adhn; adho; adhp; adhq; adhr; adhs; adht; adhu; adhv; adhw; adhx; adhy; adhz; adia; adib; adic; adid; adie; adif; adig; adih; adii; adij; adik; adil; adim; adin; adio; adip; adiq; adir; adis; adit; adiu; adiv; adiw; adix; adiy; adiz; adja; adjb; adjc; adjd; adje; adjf; adjg; adjh; adji; adjj; adjk; adjl; adjm; adjn; adjo; adjp; adjq; adjr; adjs; adjt; adju; adjv; adjw; adjx; adjy; adjz; adka; adkb; adkc; adkd; adke; adkf; adkg; adkh; adki; adkj; adkk; adkl; adkm; adkn; adko; adkp; adkq; adkr; adks; adkt; adku; adkv; adkw; adkx; adky; adkz; adla; adlb; adlc; adld; adle; adlf; adlg; adlh; adli; adlj; adlk; adll; adlm; adln; adlo; adlp; adlq; adlr; adls; adlt; adlu; adlv; adlw; adlx; adly; adlz; adma; admb; admc; admd; adme; admf; admg; admh; admi; admj; admk; adml; admm; admn; admo; admp; admq; admr; adms; admt; admu; admv; admw; admx; admy; admz; adna; adnb; adnc; adnd; adne; adnf; adng; adnh; adni; adnj; adnk; adnl; adnm; adnn; adno; adnp; adnq; adnr; adns; adnt; adnu; adnv; adnw; adnx; adny; adnz; adoa; adob; adoc; adod; adoe; adof; adog; adoh; adoi; adoj; adok; adol; adom; adon; adoo; adop; adoq; ador; ados; adot; adou; adov; adow; adox; adoy; adoz; adpa; adpb; adpc; adpd; adpe; adpf; adpg; adph; adpi; adpj; adpk; adpl; adpm; adpn; adpo; adpp; adpq; adpr; adps; adpt; adpu; adpv; adpw; adpx; adpy; adpz; adqa; adqb; adqc; adqd; adqe; adqf; adqg; adqh; adqi; adqj; adqk; adql; adqm; adqn; adqo; adqp; adqq; adqr; adqs; adqt; adqu; adqv; adqw; adqx; adqy; adqz; adra; adrb; adrc; adrd; adre; adrf; adrg; adrh; adri; adrj; adrk; adrl; adrm; adrn; adro; adrp; adrq; adrr; adrs; adrt; adru; adrv; adrw; adrx; adry; adrz; adsa; adsb; adsc; adsd; adse; adsf; adsg; adsh; adsi; adsj; adsk; adsl; adsm; adsn; adso; adsp; adsq; adsr; adss; adst; adsu; adsv; adsw; adsx; adsy; adsz; adta; adtb; adtc; adtd; adte; adtf; adtg; adth; adti; adtj; adtk; adtl; adtm; adtn; adto; adtp; adtq; adtr; adts; adtt; adtu; adtv; adtw; adtx; adty; adtz; adua; adub; aduc; adud; adue; aduf; adug; aduh; adui; aduj; aduk; adul; adum; adun; aduo; adup; aduq; adur; adus; adut; aduu; aduv; aduw; adux; aduy; aduz; adva; advb; advc; advd; adve; advf; advg; advh; advi; advj; advk; advl; advm; advn; advo; advp; advq; advr; advs; advt; advu; advv; advw; advx; advy; advz; adwa; adwb; adwc; adwd; adwe; adwf; adwg; adwh; adwi; adwj; adwk; adwl; adwm; adwn; adwo; adwp; adwq; adwr; adws; adwt; adwu; adwv; adww; adwx; adwy; adwz; adxa; adxb; adxc; adxd; adxe; adxf; adxg; adxh; adxi; adxj; adxk; adxl; adxm; adxn; adxo; adxp; adxq; adxr; adxs; adxt; adxu; adxv; adxw; adxx; adxy; adxz; adya; adyb; adyc; adyd; adye; adyf; adyg; adyh; adyi; adyj; adyk; adyl; adym; adyn; adyo; adyp; adyq; adyr; adys; adyt; adyu; adyv; adyw; adyx; adyy; adyz; adza; adzb; adzc; adzd; adze; adzf; adzg; adzh; adzi; adzj; adzk; adzl; adzm; adzn; adzo; adzp; adzq; adzr; adzs; adzt; adzu; adzv; adzw; adzx; adzy; adzz; aeaa; aeab; aeac; aead; aeae; aeaf; aeag; aeah; aeai; aeaj; aeak; aeal; aeam; aean; aeao; aeap; aeaq; aear; aeas; aeat; aeau; aeav; aeaw; aeax; aeay; aeaz; aeba; aebb; aebc; aebd; aebe; aebf; aebg; aebh; aebi; aebj; aebk; aebl; aebm; aebn; aebo; aebp; aebq; aebr; aebs; aebt; aebu; aebv; aebw; aebx; aeby; aebz; aeca; aecb; aecc; aecd; aece; aecf; aecg; aech; aeci; aecj; aeck; aecl; aecm; aecn; aeco; aecp; aecq; aecr; aecs; aect; aecu; aecv; aecw; aecx; aecy; aecz; aeda; aedb; aedc; aedd; aede; aedf; aedg; aedh; aedi; aedj; aedk; aedl; aedm; aedn; aedo; aedp; aedq; aedr; aeds; aedt; aedu; aedv; aedw; aedx; aedy; aedz; aeea; aeeb; aeec; aeed; aeee; aeef; aeeg; aeeh; aeei; aeej; aeek; aeel; aeem; aeen; aeeo; aeep; aeeq; aeer; aees; aeet; aeeu; aeev; aeew; aeex; aeey; aeez; aefa; aefb; aefc; aefd; aefe; aeff; aefg; aefh; aefi; aefj; aefk; aefl; aefm; aefn; aefo; aefp; aefq; aefr; aefs; aeft; aefu; aefv; aefw; aefx; aefy; aefz; aega; aegb; aegc; aegd; aege; aegf; aegg; aegh; aegi; aegj; aegk; aegl; aegm; aegn; aego; aegp; aegq; aegr; aegs; aegt; aegu; aegv; aegw; aegx; aegy; aegz; aeha; aehb; aehc; aehd; aehe; aehf; aehg; aehh; aehi; aehj; aehk; aehl; aehm; aehn; aeho; aehp; aehq; aehr; aehs; aeht; aehu; aehv; aehw; aehx; aehy; aehz; aeia; aeib; aeic; aeid; aeie; aeif; aeig; aeih; aeii; aeij; aeik; aeil; aeim; aein; aeio; aeip; aeiq; aeir; aeis; aeit; aeiu; aeiv; aeiw; aeix; aeiy; aeiz; aeja; aejb; aejc; aejd; aeje; aejf; aejg; aejh; aeji; aejj; aejk; aejl; aejm; aejn; aejo; aejp; aejq; aejr; aejs; aejt; aeju; aejv; aejw; aejx; aejy; aejz; aeka; aekb; aekc; aekd; aeke; aekf; aekg; aekh; aeki; aekj; aekk; aekl; aekm; aekn; aeko; aekp; aekq; aekr; aeks; aekt; aeku; aekv; aekw; aekx; aeky; aekz; aela; aelb; aelc; aeld; aele; aelf; aelg; aelh; aeli; aelj; aelk; aell; aelm; aeln; aelo; aelp; aelq; aelr; aels; aelt; aelu; aelv; aelw; aelx; aely; aelz; aema; aemb; aemc; aemd; aeme; aemf; aemg; aemh; aemi; aemj; aemk; aeml; aemm; aemn; aemo; aemp; aemq; aemr; aems; aemt; aemu; aemv; aemw; aemx; aemy; aemz; aena; aenb; aenc; aend; aene; aenf; aeng; aenh; aeni; aenj; aenk; aenl; aenm; aenn; aeno; aenp; aenq; aenr; aens; aent; aenu; aenv; aenw; aenx; aeny; aenz; aeoa; aeob; aeoc; aeod; aeoe; aeof; aeog; aeoh; aeoi; aeoj; aeok; aeol; aeom; aeon; aeoo; aeop; aeoq; aeor; aeos; aeot; aeou; aeov; aeow; aeox; aeoy; aeoz; aepa; aepb; aepc; aepd; aepe; aepf; aepg; aeph; aepi; aepj; aepk; aepl; aepm; aepn; aepo; aepp; aepq; aepr; aeps; aept; aepu; aepv; aepw; aepx; aepy; aepz; aeqa; aeqb; aeqc; aeqd; aeqe; aeqf; aeqg; aeqh; aeqi; aeqj; aeqk; aeql; aeqm; aeqn; aeqo; aeqp; aeqq; aeqr; aeqs; aeqt; aequ; aeqv; aeqw; aeqx; aeqy; aeqz; aera; aerb; aerc; aerd; aere; aerf; aerg; aerh; aeri; aerj; aerk; aerl; aerm; aern; aero; aerp; aerq; aerr; aers; aert; aeru; aerv; aerw; aerx; aery; aerz; aesa; aesb; aesc; aesd; aese; aesf; aesg; aesh; aesi; aesj; aesk; aesl; aesm; aesn; aeso; aesp; aesq; aesr; aess; aest; aesu; aesv; aesw; aesx; aesy; aesz; aeta; aetb; aetc; aetd; aete; aetf; aetg; aeth; aeti; aetj; aetk; aetl; aetm; aetn; aeto; aetp; aetq; aetr; aets; aett; aetu; aetv; aetw; aetx; aety; aetz; aeua; aeub; aeuc; aeud; aeue; aeuf; aeug; aeuh; aeui; aeuj; aeuk; aeul; aeum; aeun; aeuo; aeup; aeuq; aeur; aeus; aeut; aeuu; aeuv; aeuw; aeux; aeuy; aeuz; aeva; aevb; aevc; aevd; aeve; aevf; aevg; aevh; aevi; aevj; aevk; aevl; aevm; aevn; aevo; aevp; aevq; aevr; aevs; aevt; aevu; aevv; aevw; aevx; aevy; aevz; aewa; aewb; aewc; aewd; aewe; aewf; aewg; aewh; aewi; aewj; aewk; aewl; aewm; aewn; aewo; aewp; aewq; aewr; aews; aewt; aewu; aewv; aeww; aewx; aewy; aewz; aexa; aexb; aexc; aexd; aexe; aexf; aexg; aexh; aexi; aexj; aexk; aexl; aexm; aexn; aexo; aexp; aexq; aexr; aexs; aext; aexu; aexv; aexw; aexx; aexy; aexz; aeya; aeyb; aeyc; aeyd; aeye; aeyf; aeyg; aeyh; aeyi; aeyj; aeyk; aeyl; aeym; aeyn; aeyo; aeyp; aeyq; aeyr; aeys; aeyt; aeyu; aeyv; aeyw; aeyx; aeyy; aeyz; aeza; aezb; aezc; aezd; aeze; aezf; aezg; aezh; aezi; aezj; aezk; aezl; aezm; aezn; aezo; aezp; aezq; aezr; aezs; aezt; aezu; aezv; aezw; aezx; aezy; aezz; afaa; afab; afac; afad; afae; afaf; afag; afah; afai; afaj; afak; afal; afam; afan; afao; afap; afaq; afar; afas; afat; afau; afav; afaw; afax; afay; afaz; afba; afbb; afbc; afbd; afbe; afbf; afbg; afbh; afbi; afbj; afbk; afbl; afbm; afbn; afbo; afbp; afbq; afbr; afbs; afbt; afbu; afbv; afbw; afbx; afby; afbz; afca; afcb; afcc; afcd; afce; afcf; afcg; afch; afci; afcj; afck; afcl; afcm; afcn; afco; afcp; afcq; afcr; afcs; afct; afcu; afcv; afcw; afcx; afcy; afcz; afda; afdb; afdc; afdd; afde; afdf; afdg; afdh; afdi; afdj; afdk; afdl; afdm; afdn; afdo; afdp; afdq; afdr; afds; afdt; afdu; afdv; afdw; afdx; afdy; afdz; afea; afeb; afec; afed; afee; afef; afeg; afeh; afei; afej; afek; afel; afem; afen; afeo; afep; afeq; afer; afes; afet; afeu; afev; afew; afex; afey; afez; affa; affb; affc; affd; affe; afff; affg; affh; affi; affj; affk; affl; affm; affn; affo; affp; affq; affr; affs; afft; affu; affv; affw; affx; affy; affz; afga; afgb; afgc; afgd; afge; afgf; afgg; afgh; afgi; afgj; afgk; afgl; afgm; afgn; afgo; afgp; afgq; afgr; afgs; afgt; afgu; afgv; afgw; afgx; afgy; afgz; afha; afhb; afhc; afhd; afhe; afhf; afhg; afhh; afhi; afhj; afhk; afhl; afhm; afhn; afho; afhp; afhq; afhr; afhs; afht; afhu; afhv; afhw; afhx; afhy; afhz; afia; afib; afic; afid; afie; afif; afig; afih; afii; afij; afik; afil; afim; afin; afio; afip; afiq; afir; afis; afit; afiu; afiv; afiw; afix; afiy; afiz; afja; afjb; afjc; afjd; afje; afjf; afjg; afjh; afji; afjj; afjk; afjl; afjm; afjn; afjo; afjp; afjq; afjr; afjs; afjt; afju; afjv; afjw; afjx; afjy; afjz; afka; afkb; afkc; afkd; afke; afkf; afkg; afkh; afki; afkj; afkk; afkl; afkm; afkn; afko; afkp; afkq; afkr; afks; afkt; afku; afkv; afkw; afkx; afky; afkz; afla; aflb; aflc; afld; afle; aflf; aflg; aflh; afli; aflj; aflk; afll; aflm; afln; aflo; aflp; aflq; aflr; afls; aflt; aflu; aflv; aflw; aflx; afly; aflz; afma; afmb; afmc; afmd; afme; afmf; afmg; afmh; afmi; afmj; afmk; afml; afmm; afmn; afmo; afmp; afmq; afmr; afms; afmt; afmu; afmv; afmw; afmx; afmy; afmz; afna; afnb; afnc; afnd; afne; afnf; afng; afnh; afni; afnj; afnk; afnl; afnm; afnn; afno; afnp; afnq; afnr; afns; afnt; afnu; afnv; afnw; afnx; afny; afnz; afoa; afob; afoc; afod; afoe; afof; afog; afoh; afoi; afoj; afok; afol; afom; afon; afoo; afop; afoq; afor; afos; afot; afou; afov; afow; afox; afoy; afoz; afpa; afpb; afpc; afpd; afpe; afpf; afpg; afph; afpi; afpj; afpk; afpl; afpm; afpn; afpo; afpp; afpq; afpr; afps; afpt; afpu; afpv; afpw; afpx; afpy; afpz; afqa; afqb; afqc; afqd; afqe; afqf; afqg; afqh; afqi; afqj; afqk; afql; afqm; afqn; afqo; afqp; afqq; afqr; afqs; afqt; afqu; afqv; afqw; afqx; afqy; afqz; afra; afrb; afrc; afrd; afre; afrf; afrg; afrh; afri; afrj; afrk; afrl; afrm; afrn; afro; afrp; afrq; afrr; afrs; afrt; afru; afrv; afrw; afrx; afry; afrz; afsa; afsb; afsc; afsd; afse; afsf; afsg; afsh; afsi; afsj; afsk; afsl; afsm; afsn; afso; afsp; afsq; afsr; afss; afst; afsu; afsv; afsw; afsx; afsy; afsz; afta; aftb; aftc; aftd; afte; aftf; aftg; afth; afti; aftj; aftk; aftl; aftm; aftn; afto; aftp; aftq; aftr; afts; aftt; aftu; aftv; aftw; aftx; afty; aftz; afua; afub; afuc; afud; afue; afuf; afug; afuh; afui; afuj; afuk; aful; afum; afun; afuo; afup; afuq; afur; afus; afut; afuu; afuv; afuw; afux; afuy; afuz; afva; afvb; afvc; afvd; afve; afvf; afvg; afvh; afvi; afvj; afvk; afvl; afvm; afvn; afvo; afvp; afvq; afvr; afvs; afvt; afvu; afvv; afvw; afvx; afvy; afvz; afwa; afwb; afwc; afwd; afwe; afwf; afwg; afwh; afwi; afwj; afwk; afwl; afwm; afwn; afwo; afwp; afwq; afwr; afws; afwt; afwu; afwv; afww; afwx; afwy; afwz; afxa; afxb; afxc; afxd; afxe; afxf; afxg; afxh; afxi; afxj; afxk; afxl; afxm; afxn; afxo; afxp; afxq; afxr; afxs; afxt; afxu; afxv; afxw; afxx; afxy; afxz; afya; afyb; afyc; afyd; afye; afyf; afyg; afyh; afyi; afyj; afyk; afyl; afym; afyn; afyo; afyp; afyq; afyr; afys; afyt; afyu; afyv; afyw; afyx; afyy; afyz; afza; afzb; afzc; afzd; afze; afzf; afzg; afzh; afzi; afzj; afzk; afzl; afzm; afzn; afzo; afzp; afzq; afzr; afzs; afzt; afzu; afzv; afzw; afzx; afzy; afzz; agaa; agab; agac; agad; agae; agaf; agag; agah; agai; agaj; agak; agal; agam; agan; agao; agap; agaq; agar; agas; agat; agau; agav; agaw; agax; agay; agaz; agba; agbb; agbc; agbd; agbe; agbf; agbg; agbh; agbi; agbj; agbk; agbl; agbm; agbn; agbo; agbp; agbq; agbr; agbs; agbt; agbu; agbv; agbw; agbx; agby; agbz; agca; agcb; agcc; agcd; agce; agcf; agcg; agch; agci; agcj; agck; agcl; agcm; agcn; agco; agcp; agcq; agcr; agcs; agct; agcu; agcv; agcw; agcx; agcy; agcz; agda; agdb; agdc; agdd; agde; agdf; agdg; agdh; agdi; agdj; agdk; agdl; agdm; agdn; agdo; agdp; agdq; agdr; agds; agdt; agdu; agdv; agdw; agdx; agdy; agdz; agea; ageb; agec; aged; agee; agef; ageg; ageh; agei; agej; agek; agel; agem; agen; ageo; agep; ageq; ager; ages; aget; ageu; agev; agew; agex; agey; agez; agfa; agfb; agfc; agfd; agfe; agff; agfg; agfh; agfi; agfj; agfk; agfl; agfm; agfn; agfo; agfp; agfq; agfr; agfs; agft; agfu; agfv; agfw; agfx; agfy; agfz; agga; aggb; aggc; aggd; agge; aggf; aggg; aggh; aggi; aggj; aggk; aggl; aggm; aggn; aggo; aggp; aggq; aggr; aggs; aggt; aggu; aggv; aggw; aggx; aggy; aggz; agha; aghb; aghc; aghd; aghe; aghf; aghg; aghh; aghi; aghj; aghk; aghl; aghm; aghn; agho; aghp; aghq; aghr; aghs; aght; aghu; aghv; aghw; aghx; aghy; aghz; agia; agib; agic; agid; agie; agif; agig; agih; agii; agij; agik; agil; agim; agin; agio; agip; agiq; agir; agis; agit; agiu; agiv; agiw; agix; agiy; agiz; agja; agjb; agjc; agjd; agje; agjf; agjg; agjh; agji; agjj; agjk; agjl; agjm; agjn; agjo; agjp; agjq; agjr; agjs; agjt; agju; agjv; agjw; agjx; agjy; agjz; agka; agkb; agkc; agkd; agke; agkf; agkg; agkh; agki; agkj; agkk; agkl; agkm; agkn; agko; agkp; agkq; agkr; agks; agkt; agku; agkv; agkw; agkx; agky; agkz; agla; aglb; aglc; agld; agle; aglf; aglg; aglh; agli; aglj; aglk; agll; aglm; agln; aglo; aglp; aglq; aglr; agls; aglt; aglu; aglv; aglw; aglx; agly; aglz; agma; agmb; agmc; agmd; agme; agmf; agmg; agmh; agmi; agmj; agmk; agml; agmm; agmn; agmo; agmp; agmq; agmr; agms; agmt; agmu; agmv; agmw; agmx; agmy; agmz; agna; agnb; agnc; agnd; agne; agnf; agng; agnh; agni; agnj; agnk; agnl; agnm; agnn; agno; agnp; agnq; agnr; agns; agnt; agnu; agnv; agnw; agnx; agny; agnz; agoa; agob; agoc; agod; agoe; agof; agog; agoh; agoi; agoj; agok; agol; agom; agon; agoo; agop; agoq; agor; agos; agot; agou; agov; agow; agox; agoy; agoz; agpa; agpb; agpc; agpd; agpe; agpf; agpg; agph; agpi; agpj; agpk; agpl; agpm; agpn; agpo; agpp; agpq; agpr; agps; agpt; agpu; agpv; agpw; agpx; agpy; agpz; agqa; agqb; agqc; agqd; agqe; agqf; agqg; agqh; agqi; agqj; agqk; agql; agqm; agqn; agqo; agqp; agqq; agqr; agqs; agqt; agqu; agqv; agqw; agqx; agqy; agqz; agra; agrb; agrc; agrd; agre; agrf; agrg; agrh; agri; agrj; agrk; agrl; agrm; agrn; agro; agrp; agrq; agrr; agrs; agrt; agru; agrv; agrw; agrx; agry; agrz; agsa; agsb; agsc; agsd; agse; agsf; agsg; agsh; agsi; agsj; agsk; agsl; agsm; agsn; agso; agsp; agsq; agsr; agss; agst; agsu; agsv; agsw; agsx; agsy; agsz; agta; agtb; agtc; agtd; agte; agtf; agtg; agth; agti; agtj; agtk; agtl; agtm; agtn; agto; agtp; agtq; agtr; agts; agtt; agtu; agtv; agtw; agtx; agty; agtz; agua; agub; aguc; agud; ague; aguf; agug; aguh; agui; aguj; aguk; agul; agum; agun; aguo; agup; aguq; agur; agus; agut; aguu; aguv; aguw; agux; aguy; aguz; agva; agvb; agvc; agvd; agve; agvf; agvg; agvh; agvi; agvj; agvk; agvl; agvm; agvn; agvo; agvp; agvq; agvr; agvs; agvt; agvu; agvv; agvw; agvx; agvy; agvz; agwa; agwb; agwc; agwd; agwe; agwf; agwg; agwh; agwi; agwj; agwk; agwl; agwm; agwn; agwo; agwp; agwq; agwr; agws; agwt; agwu; agwv; agww; agwx; agwy; agwz; agxa; agxb; agxc; agxd; agxe; agxf; agxg; agxh; agxi; agxj; agxk; agxl; agxm; agxn; agxo; agxp; agxq; agxr; agxs; agxt; agxu; agxv; agxw; agxx; agxy; agxz; agya; agyb; agyc; agyd; agye; agyf; agyg; agyh; agyi; agyj; agyk; agyl; agym; agyn; agyo; agyp; agyq; agyr; agys; agyt; agyu; agyv; agyw; agyx; agyy; agyz; agza; agzb; agzc; agzd; agze; agzf; agzg; agzh; agzi; agzj; agzk; agzl; agzm; agzn; agzo; agzp; agzq; agzr; agzs; agzt; agzu; agzv; agzw; agzx; agzy; agzz; ahaa; ahab; ahac; ahad; ahae; ahaf; ahag; ahah; ahai; ahaj; ahak; ahal; aham; ahan; ahao; ahap; ahaq; ahar; ahas; ahat; ahau; ahav; ahaw; ahax; ahay; ahaz; ahba; ahbb; ahbc; ahbd; ahbe; ahbf; ahbg; ahbh; ahbi; ahbj; ahbk; ahbl; ahbm; ahbn; ahbo; ahbp; ahbq; ahbr; ahbs; ahbt; ahbu; ahbv; ahbw; ahbx; ahby; ahbz; ahca; ahcb; ahcc; ahcd; ahce; ahcf; ahcg; ahch; ahci; ahcj; ahck; ahcl; ahcm; ahcn; ahco; ahcp; ahcq; ahcr; ahcs; ahct; ahcu; ahcv; ahcw; ahcx; ahcy; ahcz; ahda; ahdb; ahdc; ahdd; ahde; ahdf; ahdg; ahdh; ahdi; ahdj; ahdk; ahdl; ahdm; ahdn; ahdo; ahdp; ahdq; ahdr; ahds; ahdt; ahdu; ahdv; ahdw; ahdx; ahdy; ahdz; ahea; aheb; ahec; ahed; ahee; ahef; aheg; aheh; ahei; ahej; ahek; ahel; ahem; ahen; aheo; ahep; aheq; aher; ahes; ahet; aheu; ahev; ahew; ahex; ahey; ahez; ahfa; ahfb; ahfc; ahfd; ahfe; ahff; ahfg; ahfh; ahfi; ahfj; ahfk; ahfl; ahfm; ahfn; ahfo; ahfp; ahfq; ahfr; ahfs; ahft; ahfu; ahfv; ahfw; ahfx; ahfy; ahfz; ahga; ahgb; ahgc; ahgd; ahge; ahgf; ahgg; ahgh; ahgi; ahgj; ahgk; ahgl; ahgm; ahgn; ahgo; ahgp; ahgq; ahgr; ahgs; ahgt; ahgu; ahgv; ahgw; ahgx; ahgy; ahgz; ahha; ahhb; ahhc; ahhd; ahhe; ahhf; ahhg; ahhh; ahhi; ahhj; ahhk; ahhl; ahhm; ahhn; ahho; ahhp; ahhq; ahhr; ahhs; ahht; ahhu; ahhv; ahhw; ahhx; ahhy; ahhz; ahia; ahib; ahic; ahid; ahie; ahif; ahig; ahih; ahii; ahij; ahik; ahil; ahim; ahin; ahio; ahip; ahiq; ahir; ahis; ahit; ahiu; ahiv; ahiw; ahix; ahiy; ahiz; ahja; ahjb; ahjc; ahjd; ahje; ahjf; ahjg; ahjh; ahji; ahjj; ahjk; ahjl; ahjm; ahjn; ahjo; ahjp; ahjq; ahjr; ahjs; ahjt; ahju; ahjv; ahjw; ahjx; ahjy; ahjz; ahka; ahkb; ahkc; ahkd; ahke; ahkf; ahkg; ahkh; ahki; ahkj; ahkk; ahkl; ahkm; ahkn; ahko; ahkp; ahkq; ahkr; ahks; ahkt; ahku; ahkv; ahkw; ahkx; ahky; ahkz; ahla; ahlb; ahlc; ahld; ahle; ahlf; ahlg; ahlh; ahli; ahlj; ahlk; ahll; ahlm; ahln; ahlo; ahlp; ahlq; ahlr; ahls; ahlt; ahlu; ahlv; ahlw; ahlx; ahly; ahlz; ahma; ahmb; ahmc; ahmd; ahme; ahmf; ahmg; ahmh; ahmi; ahmj; ahmk; ahml; ahmm; ahmn; ahmo; ahmp; ahmq; ahmr; ahms; ahmt; ahmu; ahmv; ahmw; ahmx; ahmy; ahmz; ahna; ahnb; ahnc; ahnd; ahne; ahnf; ahng; ahnh; ahni; ahnj; ahnk; ahnl; ahnm; ahnn; ahno; ahnp; ahnq; ahnr; ahns; ahnt; ahnu; ahnv; ahnw; ahnx; ahny; ahnz; ahoa; ahob; ahoc; ahod; ahoe; ahof; ahog; ahoh; ahoi; ahoj; ahok; ahol; ahom; ahon; ahoo; ahop; ahoq; ahor; ahos; ahot; ahou; ahov; ahow; ahox; ahoy; ahoz; ahpa; ahpb; ahpc; ahpd; ahpe; ahpf; ahpg; ahph; ahpi; ahpj; ahpk; ahpl; ahpm; ahpn; ahpo; ahpp; ahpq; ahpr; ahps; ahpt; ahpu; ahpv; ahpw; ahpx; ahpy; ahpz; ahqa; ahqb; ahqc; ahqd; ahqe; ahqf; ahqg; ahqh; ahqi; ahqj; ahqk; ahql; ahqm; ahqn; ahqo; ahqp; ahqq; ahqr; ahqs; ahqt; ahqu; ahqv; ahqw; ahqx; ahqy; ahqz; ahra; ahrb; ahrc; ahrd; ahre; ahrf; ahrg; ahrh; ahri; ahrj; ahrk; ahrl; ahrm; ahrn; ahro; ahrp; ahrq; ahrr; ahrs; ahrt; ahru; ahrv; ahrw; ahrx; ahry; ahrz; ahsa; ahsb; ahsc; ahsd; ahse; ahsf; ahsg; ahsh; ahsi; ahsj; ahsk; ahsl; ahsm; ahsn; ahso; ahsp; ahsq; ahsr; ahss; ahst; ahsu; ahsv; ahsw; ahsx; ahsy; ahsz; ahta; ahtb; ahtc; ahtd; ahte; ahtf; ahtg; ahth; ahti; ahtj; ahtk; ahtl; ahtm; ahtn; ahto; ahtp; ahtq; ahtr; ahts; ahtt; ahtu; ahtv; ahtw; ahtx; ahty; ahtz; ahua; ahub; ahuc; ahud; ahue; ahuf; ahug; ahuh; ahui; ahuj; ahuk; ahul; ahum; ahun; ahuo; ahup; ahuq; ahur; ahus; ahut; ahuu; ahuv; ahuw; ahux; ahuy; ahuz; ahva; ahvb; ahvc; ahvd; ahve; ahvf; ahvg; ahvh; ahvi; ahvj; ahvk; ahvl; ahvm; ahvn; ahvo; ahvp; ahvq; ahvr; ahvs; ahvt; ahvu; ahvv; ahvw; ahvx; ahvy; ahvz; ahwa; ahwb; ahwc; ahwd; ahwe; ahwf; ahwg; ahwh; ahwi; ahwj; ahwk; ahwl; ahwm; ahwn; ahwo; ahwp; ahwq; ahwr; ahws; ahwt; ahwu; ahwv; ahww; ahwx; ahwy; ahwz; ahxa; ahxb; ahxc; ahxd; ahxe; ahxf; ahxg; ahxh; ahxi; ahxj; ahxk; ahxl; ahxm; ahxn; ahxo; ahxp; ahxq; ahxr; ahxs; ahxt; ahxu; ahxv; ahxw; ahxx; ahxy; ahxz; ahya; ahyb; ahyc; ahyd; ahye; ahyf; ahyg; ahyh; ahyi; ahyj; ahyk; ahyl; ahym; ahyn; ahyo; ahyp; ahyq; ahyr; ahys; ahyt; ahyu; ahyv; ahyw; ahyx; ahyy; ahyz; ahza; ahzb; ahzc; ahzd; ahze; ahzf; ahzg; ahzh; ahzi; ahzj; ahzk; ahzl; ahzm; ahzn; ahzo; ahzp; ahzq; ahzr; ahzs; ahzt; ahzu; ahzv; ahzw; ahzx; ahzy; ahzz; aiaa; aiab; aiac; aiad; aiae; aiaf; aiag; aiah; aiai; aiaj; aiak; aial; aiam; aian; aiao; aiap; aiaq; aiar; aias; aiat; aiau; aiav; aiaw; aiax; aiay; aiaz; aiba; aibb; aibc; aibd; aibe; aibf; aibg; aibh; aibi; aibj; aibk; aibl; aibm; aibn; aibo; aibp; aibq; aibr; aibs; aibt; aibu; aibv; aibw; aibx; aiby; aibz; aica; aicb; aicc; aicd; aice; aicf; aicg; aich; aici; aicj; aick; aicl; aicm; aicn; aico; aicp; aicq; aicr; aics; aict; aicu; aicv; aicw; aicx; aicy; aicz; aida; aidb; aidc; aidd; aide; aidf; aidg; aidh; aidi; aidj; aidk; aidl; aidm; aidn; aido; aidp; aidq; aidr; aids; aidt; aidu; aidv; aidw; aidx; aidy; aidz; aiea; aieb; aiec; aied; aiee; aief; aieg; aieh; aiei; aiej; aiek; aiel; aiem; aien; aieo; aiep; aieq; aier; aies; aiet; aieu; aiev; aiew; aiex; aiey; aiez; aifa; aifb; aifc; aifd; aife; aiff; aifg; aifh; aifi; aifj; aifk; aifl; aifm; aifn; aifo; aifp; aifq; aifr; aifs; aift; aifu; aifv; aifw; aifx; aify; aifz; aiga; aigb; aigc; aigd; aige; aigf; aigg; aigh; aigi; aigj; aigk; aigl; aigm; aign; aigo; aigp; aigq; aigr; aigs; aigt; aigu; aigv; aigw; aigx; aigy; aigz; aiha; aihb; aihc; aihd; aihe; aihf; aihg; aihh; aihi; aihj; aihk; aihl; aihm; aihn; aiho; aihp; aihq; aihr; aihs; aiht; aihu; aihv; aihw; aihx; aihy; aihz; aiia; aiib; aiic; aiid; aiie; aiif; aiig; aiih; aiii; aiij; aiik; aiil; aiim; aiin; aiio; aiip; aiiq; aiir; aiis; aiit; aiiu; aiiv; aiiw; aiix; aiiy; aiiz; aija; aijb; aijc; aijd; aije; aijf; aijg; aijh; aiji; aijj; aijk; aijl; aijm; aijn; aijo; aijp; aijq; aijr; aijs; aijt; aiju; aijv; aijw; aijx; aijy; aijz; aika; aikb; aikc; aikd; aike; aikf; aikg; aikh; aiki; aikj; aikk; aikl; aikm; aikn; aiko; aikp; aikq; aikr; aiks; aikt; aiku; aikv; aikw; aikx; aiky; aikz; aila; ailb; ailc; aild; aile; ailf; ailg; ailh; aili; ailj; ailk; aill; ailm; ailn; ailo; ailp; ailq; ailr; ails; ailt; ailu; ailv; ailw; ailx; aily; ailz; aima; aimb; aimc; aimd; aime; aimf; aimg; aimh; aimi; aimj; aimk; aiml; aimm; aimn; aimo; aimp; aimq; aimr; aims; aimt; aimu; aimv; aimw; aimx; aimy; aimz; aina; ainb; ainc; aind; aine; ainf; aing; ainh; aini; ainj; aink; ainl; ainm; ainn; aino; ainp; ainq; ainr; ains; aint; ainu; ainv; ainw; ainx; ainy; ainz; aioa; aiob; aioc; aiod; aioe; aiof; aiog; aioh; aioi; aioj; aiok; aiol; aiom; aion; aioo; aiop; aioq; aior; aios; aiot; aiou; aiov; aiow; aiox; aioy; aioz; aipa; aipb; aipc; aipd; aipe; aipf; aipg; aiph; aipi; aipj; aipk; aipl; aipm; aipn; aipo; aipp; aipq; aipr; aips; aipt; aipu; aipv; aipw; aipx; aipy; aipz; aiqa; aiqb; aiqc; aiqd; aiqe; aiqf; aiqg; aiqh; aiqi; aiqj; aiqk; aiql; aiqm; aiqn; aiqo; aiqp; aiqq; aiqr; aiqs; aiqt; aiqu; aiqv; aiqw; aiqx; aiqy; aiqz; aira; airb; airc; aird; aire; airf; airg; airh; airi; airj; airk; airl; airm; airn; airo; airp; airq; airr; airs; airt; airu; airv; airw; airx; airy; airz; aisa; aisb; aisc; aisd; aise; aisf; aisg; aish; aisi; aisj; aisk; aisl; aism; aisn; aiso; aisp; aisq; aisr; aiss; aist; aisu; aisv; aisw; aisx; aisy; aisz; aita; aitb; aitc; aitd; aite; aitf; aitg; aith; aiti; aitj; aitk; aitl; aitm; aitn; aito; aitp; aitq; aitr; aits; aitt; aitu; aitv; aitw; aitx; aity; aitz; aiua; aiub; aiuc; aiud; aiue; aiuf; aiug; aiuh; aiui; aiuj; aiuk; aiul; aium; aiun; aiuo; aiup; aiuq; aiur; aius; aiut; aiuu; aiuv; aiuw; aiux; aiuy; aiuz; aiva; aivb; aivc; aivd; aive; aivf; aivg; aivh; aivi; aivj; aivk; aivl; aivm; aivn; aivo; aivp; aivq; aivr; aivs; aivt; aivu; aivv; aivw; aivx; aivy; aivz; aiwa; aiwb; aiwc; aiwd; aiwe; aiwf; aiwg; aiwh; aiwi; aiwj; aiwk; aiwl; aiwm; aiwn; aiwo; aiwp; aiwq; aiwr; aiws; aiwt; aiwu; aiwv; aiww; aiwx; aiwy; aiwz; aixa; aixb; aixc; aixd; aixe; aixf; aixg; aixh; aixi; aixj; aixk; aixl; aixm; aixn; aixo; aixp; aixq; aixr; aixs; aixt; aixu; aixv; aixw; aixx; aixy; aixz; aiya; aiyb; aiyc; aiyd; aiye; aiyf; aiyg; aiyh; aiyi; aiyj; aiyk; aiyl; aiym; aiyn; aiyo; aiyp; aiyq; aiyr; aiys; aiyt; aiyu; aiyv; aiyw; aiyx; aiyy; aiyz; aiza; aizb; aizc; aizd; aize; aizf; aizg; aizh; aizi; aizj; aizk; aizl; aizm; aizn; aizo; aizp; aizq; aizr; aizs; aizt; aizu; aizv; aizw; aizx; aizy; aizz; ajaa; ajab; ajac; ajad; ajae; ajaf; ajag; ajah; ajai; ajaj; ajak; ajal; ajam; ajan; ajao; ajap; ajaq; ajar; ajas; ajat; ajau; ajav; ajaw; ajax; ajay; ajaz; ajba; ajbb; ajbc; ajbd; ajbe; ajbf; ajbg; ajbh; ajbi; ajbj; ajbk; ajbl; ajbm; ajbn; ajbo; ajbp; ajbq; ajbr; ajbs; ajbt; ajbu; ajbv; ajbw; ajbx; ajby; ajbz; ajca; ajcb; ajcc; ajcd; ajce; ajcf; ajcg; ajch; ajci; ajcj; ajck; ajcl; ajcm; ajcn; ajco; ajcp; ajcq; ajcr; ajcs; ajct; ajcu; ajcv; ajcw; ajcx; ajcy; ajcz; ajda; ajdb; ajdc; ajdd; ajde; ajdf; ajdg; ajdh; ajdi; ajdj; ajdk; ajdl; ajdm; ajdn; ajdo; ajdp; ajdq; ajdr; ajds; ajdt; ajdu; ajdv; ajdw; ajdx; ajdy; ajdz; ajea; ajeb; ajec; ajed; ajee; ajef; ajeg; ajeh; ajei; ajej; ajek; ajel; ajem; ajen; ajeo; ajep; ajeq; ajer; ajes; ajet; ajeu; ajev; ajew; ajex; ajey; ajez; ajfa; ajfb; ajfc; ajfd; ajfe; ajff; ajfg; ajfh; ajfi; ajfj; ajfk; ajfl; ajfm; ajfn; ajfo; ajfp; ajfq; ajfr; ajfs; ajft; ajfu; ajfv; ajfw; ajfx; ajfy; ajfz; ajga; ajgb; ajgc; ajgd; ajge; ajgf; ajgg; ajgh; ajgi; ajgj; ajgk; ajgl; ajgm; ajgn; ajgo; ajgp; ajgq; ajgr; ajgs; ajgt; ajgu; ajgv; ajgw; ajgx; ajgy; ajgz; ajha; ajhb; ajhc; ajhd; ajhe; ajhf; ajhg; ajhh; ajhi; ajhj; ajhk; ajhl; ajhm; ajhn; ajho; ajhp; ajhq; ajhr; ajhs; ajht; ajhu; ajhv; ajhw; ajhx; ajhy; ajhz; ajia; ajib; ajic; ajid; ajie; ajif; ajig; ajih; ajii; ajij; ajik; ajil; ajim; ajin; ajio; ajip; ajiq; ajir; ajis; ajit; ajiu; ajiv; ajiw; ajix; ajiy; ajiz; ajja; ajjb; ajjc; ajjd; ajje; ajjf; ajjg; ajjh; ajji; ajjj; ajjk; ajjl; ajjm; ajjn; ajjo; ajjp; ajjq; ajjr; ajjs; ajjt; ajju; ajjv; ajjw; ajjx; ajjy; ajjz; ajka; ajkb; ajkc; ajkd; ajke; ajkf; ajkg; ajkh; ajki; ajkj; ajkk; ajkl; ajkm; ajkn; ajko; ajkp; ajkq; ajkr; ajks; ajkt; ajku; ajkv; ajkw; ajkx; ajky; ajkz; ajla; ajlb; ajlc; ajld; ajle; ajlf; ajlg; ajlh; ajli; ajlj; ajlk; ajll; ajlm; ajln; ajlo; ajlp; ajlq; ajlr; ajls; ajlt; ajlu; ajlv; ajlw; ajlx; ajly; ajlz; ajma; ajmb; ajmc; ajmd; ajme; ajmf; ajmg; ajmh; ajmi; ajmj; ajmk; ajml; ajmm; ajmn; ajmo; ajmp; ajmq; ajmr; ajms; ajmt; ajmu; ajmv; ajmw; ajmx; ajmy; ajmz; ajna; ajnb; ajnc; ajnd; ajne; ajnf; ajng; ajnh; ajni; ajnj; ajnk; ajnl; ajnm; ajnn; ajno; ajnp; ajnq; ajnr; ajns; ajnt; ajnu; ajnv; ajnw; ajnx; ajny; ajnz; ajoa; ajob; ajoc; ajod; ajoe; ajof; ajog; ajoh; ajoi; ajoj; ajok; ajol; ajom; ajon; ajoo; ajop; ajoq; ajor; ajos; ajot; ajou; ajov; ajow; ajox; ajoy; ajoz; ajpa; ajpb; ajpc; ajpd; ajpe; ajpf; ajpg; ajph; ajpi; ajpj; ajpk; ajpl; ajpm; ajpn; ajpo; ajpp; ajpq; ajpr; ajps; ajpt; ajpu; ajpv; ajpw; ajpx; ajpy; ajpz; ajqa; ajqb; ajqc; ajqd; ajqe; ajqf; ajqg; ajqh; ajqi; ajqj; ajqk; ajql; ajqm; ajqn; ajqo; ajqp; ajqq; ajqr; ajqs; ajqt; ajqu; ajqv; ajqw; ajqx; ajqy; ajqz; ajra; ajrb; ajrc; ajrd; ajre; ajrf; ajrg; ajrh; ajri; ajrj; ajrk; ajrl; ajrm; ajrn; ajro; ajrp; ajrq; ajrr; ajrs; ajrt; ajru; ajrv; ajrw; ajrx; ajry; ajrz; ajsa; ajsb; ajsc; ajsd; ajse; ajsf; ajsg; ajsh; ajsi; ajsj; ajsk; ajsl; ajsm; ajsn; ajso; ajsp; ajsq; ajsr; ajss; ajst; ajsu; ajsv; ajsw; ajsx; ajsy; ajsz; ajta; ajtb; ajtc; ajtd; ajte; ajtf; ajtg; ajth; ajti; ajtj; ajtk; ajtl; ajtm; ajtn; ajto; ajtp; ajtq; ajtr; ajts; ajtt; ajtu; ajtv; ajtw; ajtx; ajty; ajtz; ajua; ajub; ajuc; ajud; ajue; ajuf; ajug; ajuh; ajui; ajuj; ajuk; ajul; ajum; ajun; ajuo; ajup; ajuq; ajur; ajus; ajut; ajuu; ajuv; ajuw; ajux; ajuy; ajuz; ajva; ajvb; ajvc; ajvd; ajve; ajvf; ajvg; ajvh; ajvi; ajvj; ajvk; ajvl; ajvm; ajvn; ajvo; ajvp; ajvq; ajvr; ajvs; ajvt; ajvu; ajvv; ajvw; ajvx; ajvy; ajvz; ajwa; ajwb; ajwc; ajwd; ajwe; ajwf; ajwg; ajwh; ajwi; ajwj; ajwk; ajwl; ajwm; ajwn; ajwo; ajwp; ajwq; ajwr; ajws; ajwt; ajwu; ajwv; ajww; ajwx; ajwy; ajwz; ajxa; ajxb; ajxc; ajxd; ajxe; ajxf; ajxg; ajxh; ajxi; ajxj; ajxk; ajxl; ajxm; ajxn; ajxo; ajxp; ajxq; ajxr; ajxs; ajxt; ajxu; ajxv; ajxw; ajxx; ajxy; ajxz; ajya; ajyb; ajyc; ajyd; ajye; ajyf; ajyg; ajyh; ajyi; ajyj; ajyk; ajyl; ajym; ajyn; ajyo; ajyp; ajyq; ajyr; ajys; ajyt; ajyu; ajyv; ajyw; ajyx; ajyy; ajyz; ajza; ajzb; ajzc; ajzd; ajze; ajzf; ajzg; ajzh; ajzi; ajzj; ajzk; ajzl; ajzm; ajzn; ajzo; ajzp; ajzq; ajzr; ajzs; ajzt; ajzu; ajzv; ajzw; ajzx; ajzy; ajzz; akaa; akab; akac; akad; akae; akaf; akag; akah; akai; akaj; akak; akal; akam; akan; akao; akap; akaq; akar; akas; akat; akau; akav; akaw; akax; akay; akaz; akba; akbb; akbc; akbd; akbe; akbf; akbg; akbh; akbi; akbj; akbk; akbl; akbm; akbn; akbo; akbp; akbq; akbr; akbs; akbt; akbu; akbv; akbw; akbx; akby; akbz; akca; akcb; akcc; akcd; akce; akcf; akcg; akch; akci; akcj; akck; akcl; akcm; akcn; akco; akcp; akcq; akcr; akcs; akct; akcu; akcv; akcw; akcx; akcy; akcz; akda; akdb; akdc; akdd; akde; akdf; akdg; akdh; akdi; akdj; akdk; akdl; akdm; akdn; akdo; akdp; akdq; akdr; akds; akdt; akdu; akdv; akdw; akdx; akdy; akdz; akea; akeb; akec; aked; akee; akef; akeg; akeh; akei; akej; akek; akel; akem; aken; akeo; akep; akeq; aker; akes; aket; akeu; akev; akew; akex; akey; akez; akfa; akfb; akfc; akfd; akfe; akff; akfg; akfh; akfi; akfj; akfk; akfl; akfm; akfn; akfo; akfp; akfq; akfr; akfs; akft; akfu; akfv; akfw; akfx; akfy; akfz; akga; akgb; akgc; akgd; akge; akgf; akgg; akgh; akgi; akgj; akgk; akgl; akgm; akgn; akgo; akgp; akgq; akgr; akgs; akgt; akgu; akgv; akgw; akgx; akgy; akgz; akha; akhb; akhc; akhd; akhe; akhf; akhg; akhh; akhi; akhj; akhk; akhl; akhm; akhn; akho; akhp; akhq; akhr; akhs; akht; akhu; akhv; akhw; akhx; akhy; akhz; akia; akib; akic; akid; akie; akif; akig; akih; akii; akij; akik; akil; akim; akin; akio; akip; akiq; akir; akis; akit; akiu; akiv; akiw; akix; akiy; akiz; akja; akjb; akjc; akjd; akje; akjf; akjg; akjh; akji; akjj; akjk; akjl; akjm; akjn; akjo; akjp; akjq; akjr; akjs; akjt; akju; akjv; akjw; akjx; akjy; akjz; akka; akkb; akkc; akkd; akke; akkf; akkg; akkh; akki; akkj; akkk; akkl; akkm; akkn; akko; akkp; akkq; akkr; akks; akkt; akku; akkv; akkw; akkx; akky; akkz; akla; aklb; aklc; akld; akle; aklf; aklg; aklh; akli; aklj; aklk; akll; aklm; akln; aklo; aklp; aklq; aklr; akls; aklt; aklu; aklv; aklw; aklx; akly; aklz; akma; akmb; akmc; akmd; akme; akmf; akmg; akmh; akmi; akmj; akmk; akml; akmm; akmn; akmo; akmp; akmq; akmr; akms; akmt; akmu; akmv; akmw; akmx; akmy; akmz; akna; aknb; aknc; aknd; akne; aknf; akng; aknh; akni; aknj; aknk; aknl; aknm; aknn; akno; aknp; aknq; aknr; akns; aknt; aknu; aknv; aknw; aknx; akny; aknz; akoa; akob; akoc; akod; akoe; akof; akog; akoh; akoi; akoj; akok; akol; akom; akon; akoo; akop; akoq; akor; akos; akot; akou; akov; akow; akox; akoy; akoz; akpa; akpb; akpc; akpd; akpe; akpf; akpg; akph; akpi; akpj; akpk; akpl; akpm; akpn; akpo; akpp; akpq; akpr; akps; akpt; akpu; akpv; akpw; akpx; akpy; akpz; akqa; akqb; akqc; akqd; akqe; akqf; akqg; akqh; akqi; akqj; akqk; akql; akqm; akqn; akqo; akqp; akqq; akqr; akqs; akqt; akqu; akqv; akqw; akqx; akqy; akqz; akra; akrb; akrc; akrd; akre; akrf; akrg; akrh; akri; akrj; akrk; akrl; akrm; akrn; akro; akrp; akrq; akrr; akrs; akrt; akru; akrv; akrw; akrx; akry; akrz; aksa; aksb; aksc; aksd; akse; aksf; aksg; aksh; aksi; aksj; aksk; aksl; aksm; aksn; akso; aksp; aksq; aksr; akss; akst; aksu; aksv; aksw; aksx; aksy; aksz; akta; aktb; aktc; aktd; akte; aktf; aktg; akth; akti; aktj; aktk; aktl; aktm; aktn; akto; aktp; aktq; aktr; akts; aktt; aktu; aktv; aktw; aktx; akty; aktz; akua; akub; akuc; akud; akue; akuf; akug; akuh; akui; akuj; akuk; akul; akum; akun; akuo; akup; akuq; akur; akus; akut; akuu; akuv; akuw; akux; akuy; akuz; akva; akvb; akvc; akvd; akve; akvf; akvg; akvh; akvi; akvj; akvk; akvl; akvm; akvn; akvo; akvp; akvq; akvr; akvs; akvt; akvu; akvv; akvw; akvx; akvy; akvz; akwa; akwb; akwc; akwd; akwe; akwf; akwg; akwh; akwi; akwj; akwk; akwl; akwm; akwn; akwo; akwp; akwq; akwr; akws; akwt; akwu; akwv; akww; akwx; akwy; akwz; akxa; akxb; akxc; akxd; akxe; akxf; akxg; akxh; akxi; akxj; akxk; akxl; akxm; akxn; akxo; akxp; akxq; akxr; akxs; akxt; akxu; akxv; akxw; akxx; akxy; akxz; akya; akyb; akyc; akyd; akye; akyf; akyg; akyh; akyi; akyj; akyk; akyl; akym; akyn; akyo; akyp; akyq; akyr; akys; akyt; akyu; akyv; akyw; akyx; akyy; akyz; akza; akzb; akzc; akzd; akze; akzf; akzg; akzh; akzi; akzj; akzk; akzl; akzm; akzn; akzo; akzp; akzq; akzr; akzs; akzt; akzu; akzv; akzw; akzx; akzy; akzz; alaa; alab; alac; alad; alae; alaf; alag; alah; alai; alaj; alak; alal; alam; alan; alao; alap; alaq; alar; alas; alat; alau; alav; alaw; alax; alay; alaz; alba; albb; albc; albd; albe; albf; albg; albh; albi; albj; albk; albl; albm; albn; albo; albp; albq; albr; albs; albt; albu; albv; albw; albx; alby; albz; alca; alcb; alcc; alcd; alce; alcf; alcg; alch; alci; alcj; alck; alcl; alcm; alcn; alco; alcp; alcq; alcr; alcs; alct; alcu; alcv; alcw; alcx; alcy; alcz; alda; aldb; aldc; aldd; alde; aldf; aldg; aldh; aldi; aldj; aldk; aldl; aldm; aldn; aldo; aldp; aldq; aldr; alds; aldt; aldu; aldv; aldw; aldx; aldy; aldz; alea; aleb; alec; aled; alee; alef; aleg; aleh; alei; alej; alek; alel; alem; alen; aleo; alep; aleq; aler; ales; alet; aleu; alev; alew; alex; aley; alez; alfa; alfb; alfc; alfd; alfe; alff; alfg; alfh; alfi; alfj; alfk; alfl; alfm; alfn; alfo; alfp; alfq; alfr; alfs; alft; alfu; alfv; alfw; alfx; alfy; alfz; alga; algb; algc; algd; alge; algf; algg; algh; algi; algj; algk; algl; algm; algn; algo; algp; algq; algr; algs; algt; algu; algv; algw; algx; algy; algz; alha; alhb; alhc; alhd; alhe; alhf; alhg; alhh; alhi; alhj; alhk; alhl; alhm; alhn; alho; alhp; alhq; alhr; alhs; alht; alhu; alhv; alhw; alhx; alhy; alhz; alia; alib; alic; alid; alie; alif; alig; alih; alii; alij; alik; alil; alim; alin; alio; alip; aliq; alir; alis; alit; aliu; aliv; aliw; alix; aliy; aliz; alja; aljb; aljc; aljd; alje; aljf; aljg; aljh; alji; aljj; aljk; aljl; aljm; aljn; aljo; aljp; aljq; aljr; aljs; aljt; alju; aljv; aljw; aljx; aljy; aljz; alka; alkb; alkc; alkd; alke; alkf; alkg; alkh; alki; alkj; alkk; alkl; alkm; alkn; alko; alkp; alkq; alkr; alks; alkt; alku; alkv; alkw; alkx; alky; alkz; alla; allb; allc; alld; alle; allf; allg; allh; alli; allj; allk; alll; allm; alln; allo; allp; allq; allr; alls; allt; allu; allv; allw; allx; ally; allz; alma; almb; almc; almd; alme; almf; almg; almh; almi; almj; almk; alml; almm; almn; almo; almp; almq; almr; alms; almt; almu; almv; almw; almx; almy; almz; alna; alnb; alnc; alnd; alne; alnf; alng; alnh; alni; alnj; alnk; alnl; alnm; alnn; alno; alnp; alnq; alnr; alns; alnt; alnu; alnv; alnw; alnx; alny; alnz; aloa; alob; aloc; alod; aloe; alof; alog; aloh; aloi; aloj; alok; alol; alom; alon; aloo; alop; aloq; alor; alos; alot; alou; alov; alow; alox; aloy; aloz; alpa; alpb; alpc; alpd; alpe; alpf; alpg; alph; alpi; alpj; alpk; alpl; alpm; alpn; alpo; alpp; alpq; alpr; alps; alpt; alpu; alpv; alpw; alpx; alpy; alpz; alqa; alqb; alqc; alqd; alqe; alqf; alqg; alqh; alqi; alqj; alqk; alql; alqm; alqn; alqo; alqp; alqq; alqr; alqs; alqt; alqu; alqv; alqw; alqx; alqy; alqz; alra; alrb; alrc; alrd; alre; alrf; alrg; alrh; alri; alrj; alrk; alrl; alrm; alrn; alro; alrp; alrq; alrr; alrs; alrt; alru; alrv; alrw; alrx; alry; alrz; alsa; alsb; alsc; alsd; alse; alsf; alsg; alsh; alsi; alsj; alsk; alsl; alsm; alsn; also; alsp; alsq; alsr; alss; alst; alsu; alsv; alsw; alsx; alsy; alsz; alta; altb; altc; altd; alte; altf; altg; alth; alti; altj; altk; altl; altm; altn; alto; altp; altq; altr; alts; altt; altu; altv; altw; altx; alty; altz; alua; alub; aluc; alud; alue; aluf; alug; aluh; alui; aluj; aluk; alul; alum; alun; aluo; alup; aluq; alur; alus; alut; aluu; aluv; aluw; alux; aluy; aluz; alva; alvb; alvc; alvd; alve; alvf; alvg; alvh; alvi; alvj; alvk; alvl; alvm; alvn; alvo; alvp; alvq; alvr; alvs; alvt; alvu; alvv; alvw; alvx; alvy; alvz; alwa; alwb; alwc; alwd; alwe; alwf; alwg; alwh; alwi; alwj; alwk; alwl; alwm; alwn; alwo; alwp; alwq; alwr; alws; alwt; alwu; alwv; alww; alwx; alwy; alwz; alxa; alxb; alxc; alxd; alxe; alxf; alxg; alxh; alxi; alxj; alxk; alxl; alxm; alxn; alxo; alxp; alxq; alxr; alxs; alxt; alxu; alxv; alxw; alxx; alxy; alxz; alya; alyb; alyc; alyd; alye; alyf; alyg; alyh; alyi; alyj; alyk; alyl; alym; alyn; alyo; alyp; alyq; alyr; alys; alyt; alyu; alyv; alyw; alyx; alyy; alyz; alza; alzb; alzc; alzd; alze; alzf; alzg; alzh; alzi; alzj; alzk; alzl; alzm; alzn; alzo; alzp; alzq; alzr; alzs; alzt; alzu; alzv; alzw; alzx; alzy; alzz; amaa; amab; amac; amad; amae; amaf; amag; amah; amai; amaj; amak; amal; amam; aman; amao; amap; amaq; amar; amas; amat; amau; amav; amaw; amax; amay; amaz; amba; ambb; ambc; ambd; ambe; ambf; ambg; ambh; ambi; ambj; ambk; ambl; ambm; ambn; ambo; ambp; ambq; ambr; ambs; ambt; ambu; ambv; ambw; ambx; amby; ambz; amca; amcb; amcc; amcd; amce; amcf; amcg; amch; amci; amcj; amck; amcl; amcm; amcn; amco; amcp; amcq; amcr; amcs; amct; amcu; amcv; amcw; amcx; amcy; amcz; amda; amdb; amdc; amdd; amde; amdf; amdg; amdh; amdi; amdj; amdk; amdl; amdm; amdn; amdo; amdp; amdq; amdr; amds; amdt; amdu; amdv; amdw; amdx; amdy; amdz; amea; ameb; amec; amed; amee; amef; ameg; ameh; amei; amej; amek; amel; amem; amen; ameo; amep; ameq; amer; ames; amet; ameu; amev; amew; amex; amey; amez; amfa; amfb; amfc; amfd; amfe; amff; amfg; amfh; amfi; amfj; amfk; amfl; amfm; amfn; amfo; amfp; amfq; amfr; amfs; amft; amfu; amfv; amfw; amfx; amfy; amfz; amga; amgb; amgc; amgd; amge; amgf; amgg; amgh; amgi; amgj; amgk; amgl; amgm; amgn; amgo; amgp; amgq; amgr; amgs; amgt; amgu; amgv; amgw; amgx; amgy; amgz; amha; amhb; amhc; amhd; amhe; amhf; amhg; amhh; amhi; amhj; amhk; amhl; amhm; amhn; amho; amhp; amhq; amhr; amhs; amht; amhu; amhv; amhw; amhx; amhy; amhz; amia; amib; amic; amid; amie; amif; amig; amih; amii; amij; amik; amil; amim; amin; amio; amip; amiq; amir; amis; amit; amiu; amiv; amiw; amix; amiy; amiz; amja; amjb; amjc; amjd; amje; amjf; amjg; amjh; amji; amjj; amjk; amjl; amjm; amjn; amjo; amjp; amjq; amjr; amjs; amjt; amju; amjv; amjw; amjx; amjy; amjz; amka; amkb; amkc; amkd; amke; amkf; amkg; amkh; amki; amkj; amkk; amkl; amkm; amkn; amko; amkp; amkq; amkr; amks; amkt; amku; amkv; amkw; amkx; amky; amkz; amla; amlb; amlc; amld; amle; amlf; amlg; amlh; amli; amlj; amlk; amll; amlm; amln; amlo; amlp; amlq; amlr; amls; amlt; amlu; amlv; amlw; amlx; amly; amlz; amma; ammb; ammc; ammd; amme; ammf; ammg; ammh; ammi; ammj; ammk; amml; ammm; ammn; ammo; ammp; ammq; ammr; amms; ammt; ammu; ammv; ammw; ammx; ammy; ammz; amna; amnb; amnc; amnd; amne; amnf; amng; amnh; amni; amnj; amnk; amnl; amnm; amnn; amno; amnp; amnq; amnr; amns; amnt; amnu; amnv; amnw; amnx; amny; amnz; amoa; amob; amoc; amod; amoe; amof; amog; amoh; amoi; amoj; amok; amol; amom; amon; amoo; amop; amoq; amor; amos; amot; amou; amov; amow; amox; amoy; amoz; ampa; ampb; ampc; ampd; ampe; ampf; ampg; amph; ampi; ampj; ampk; ampl; ampm; ampn; ampo; ampp; ampq; ampr; amps; ampt; ampu; ampv; ampw; ampx; ampy; ampz; amqa; amqb; amqc; amqd; amqe; amqf; amqg; amqh; amqi; amqj; amqk; amql; amqm; amqn; amqo; amqp; amqq; amqr; amqs; amqt; amqu; amqv; amqw; amqx; amqy; amqz; amra; amrb; amrc; amrd; amre; amrf; amrg; amrh; amri; amrj; amrk; amrl; amrm; amrn; amro; amrp; amrq; amrr; amrs; amrt; amru; amrv; amrw; amrx; amry; amrz; amsa; amsb; amsc; amsd; amse; amsf; amsg; amsh; amsi; amsj; amsk; amsl; amsm; amsn; amso; amsp; amsq; amsr; amss; amst; amsu; amsv; amsw; amsx; amsy; amsz; amta; amtb; amtc; amtd; amte; amtf; amtg; amth; amti; amtj; amtk; amtl; amtm; amtn; amto; amtp; amtq; amtr; amts; amtt; amtu; amtv; amtw; amtx; amty; amtz; amua; amub; amuc; amud; amue; amuf; amug; amuh; amui; amuj; amuk; amul; amum; amun; amuo; amup; amuq; amur; amus; amut; amuu; amuv; amuw; amux; amuy; amuz; amva; amvb; amvc; amvd; amve; amvf; amvg; amvh; amvi; amvj; amvk; amvl; amvm; amvn; amvo; amvp; amvq; amvr; amvs; amvt; amvu; amvv; amvw; amvx; amvy; amvz; amwa; amwb; amwc; amwd; amwe; amwf; amwg; amwh; amwi; amwj; amwk; amwl; amwm; amwn; amwo; amwp; amwq; amwr; amws; amwt; amwu; amwv; amww; amwx; amwy; amwz; amxa; amxb; amxc; amxd; amxe; amxf; amxg; amxh; amxi; amxj; amxk; amxl; amxm; amxn; amxo; amxp; amxq; amxr; amxs; amxt; amxu; amxv; amxw; amxx; amxy; amxz; amya; amyb; amyc; amyd; amye; amyf; amyg; amyh; amyi; amyj; amyk; amyl; amym; amyn; amyo; amyp; amyq; amyr; amys; amyt; amyu; amyv; amyw; amyx; amyy; amyz; amza; amzb; amzc; amzd; amze; amzf; amzg; amzh; amzi; amzj; amzk; amzl; amzm; amzn; amzo; amzp; amzq; amzr; amzs; amzt; amzu; amzv; amzw; amzx; amzy; amzz; anaa; anab; anac; anad; anae; anaf; anag; anah; anai; anaj; anak; anal; anam; anan; anao; anap; anaq; anar; anas; anat; anau; anav; anaw; anax; anay; anaz; anba; anbb; anbc; anbd; anbe; anbf; anbg; anbh; anbi; anbj; anbk; anbl; anbm; anbn; anbo; anbp; anbq; anbr; anbs; anbt; anbu; anbv; anbw; anbx; anby; anbz; anca; ancb; ancc; ancd; ance; ancf; ancg; anch; anci; ancj; anck; ancl; ancm; ancn; anco; ancp; ancq; ancr; ancs; anct; ancu; ancv; ancw; ancx; ancy; ancz; anda; andb; andc; andd; ande; andf; andg; andh; andi; andj; andk; andl; andm; andn; ando; andp; andq; andr; ands; andt; andu; andv; andw; andx; andy; andz; anea; aneb; anec; aned; anee; anef; aneg; aneh; anei; anej; anek; anel; anem; anen; aneo; anep; aneq; aner; anes; anet; aneu; anev; anew; anex; aney; anez; anfa; anfb; anfc; anfd; anfe; anff; anfg; anfh; anfi; anfj; anfk; anfl; anfm; anfn; anfo; anfp; anfq; anfr; anfs; anft; anfu; anfv; anfw; anfx; anfy; anfz; anga; angb; angc; angd; ange; angf; angg; angh; angi; angj; angk; angl; angm; angn; ango; angp; angq; angr; angs; angt; angu; angv; angw; angx; angy; angz; anha; anhb; anhc; anhd; anhe; anhf; anhg; anhh; anhi; anhj; anhk; anhl; anhm; anhn; anho; anhp; anhq; anhr; anhs; anht; anhu; anhv; anhw; anhx; anhy; anhz; ania; anib; anic; anid; anie; anif; anig; anih; anii; anij; anik; anil; anim; anin; anio; anip; aniq; anir; anis; anit; aniu; aniv; aniw; anix; aniy; aniz; anja; anjb; anjc; anjd; anje; anjf; anjg; anjh; anji; anjj; anjk; anjl; anjm; anjn; anjo; anjp; anjq; anjr; anjs; anjt; anju; anjv; anjw; anjx; anjy; anjz; anka; ankb; ankc; ankd; anke; ankf; ankg; ankh; anki; ankj; ankk; ankl; ankm; ankn; anko; ankp; ankq; ankr; anks; ankt; anku; ankv; ankw; ankx; anky; ankz; anla; anlb; anlc; anld; anle; anlf; anlg; anlh; anli; anlj; anlk; anll; anlm; anln; anlo; anlp; anlq; anlr; anls; anlt; anlu; anlv; anlw; anlx; anly; anlz; anma; anmb; anmc; anmd; anme; anmf; anmg; anmh; anmi; anmj; anmk; anml; anmm; anmn; anmo; anmp; anmq; anmr; anms; anmt; anmu; anmv; anmw; anmx; anmy; anmz; anna; annb; annc; annd; anne; annf; anng; annh; anni; annj; annk; annl; annm; annn; anno; annp; annq; annr; anns; annt; annu; annv; annw; annx; anny; annz; anoa; anob; anoc; anod; anoe; anof; anog; anoh; anoi; anoj; anok; anol; anom; anon; anoo; anop; anoq; anor; anos; anot; anou; anov; anow; anox; anoy; anoz; anpa; anpb; anpc; anpd; anpe; anpf; anpg; anph; anpi; anpj; anpk; anpl; anpm; anpn; anpo; anpp; anpq; anpr; anps; anpt; anpu; anpv; anpw; anpx; anpy; anpz; anqa; anqb; anqc; anqd; anqe; anqf; anqg; anqh; anqi; anqj; anqk; anql; anqm; anqn; anqo; anqp; anqq; anqr; anqs; anqt; anqu; anqv; anqw; anqx; anqy; anqz; anra; anrb; anrc; anrd; anre; anrf; anrg; anrh; anri; anrj; anrk; anrl; anrm; anrn; anro; anrp; anrq; anrr; anrs; anrt; anru; anrv; anrw; anrx; anry; anrz; ansa; ansb; ansc; ansd; anse; ansf; ansg; ansh; ansi; ansj; ansk; ansl; ansm; ansn; anso; ansp; ansq; ansr; anss; anst; ansu; ansv; answ; ansx; ansy; ansz; anta; antb; antc; antd; ante; antf; antg; anth; anti; antj; antk; antl; antm; antn; anto; antp; antq; antr; ants; antt; antu; antv; antw; antx; anty; antz; anua; anub; anuc; anud; anue; anuf; anug; anuh; anui; anuj; anuk; anul; anum; anun; anuo; anup; anuq; anur; anus; anut; anuu; anuv; anuw; anux; anuy; anuz; anva; anvb; anvc; anvd; anve; anvf; anvg; anvh; anvi; anvj; anvk; anvl; anvm; anvn; anvo; anvp; anvq; anvr; anvs; anvt; anvu; anvv; anvw; anvx; anvy; anvz; anwa; anwb; anwc; anwd; anwe; anwf; anwg; anwh; anwi; anwj; anwk; anwl; anwm; anwn; anwo; anwp; anwq; anwr; anws; anwt; anwu; anwv; anww; anwx; anwy; anwz; anxa; anxb; anxc; anxd; anxe; anxf; anxg; anxh; anxi; anxj; anxk; anxl; anxm; anxn; anxo; anxp; anxq; anxr; anxs; anxt; anxu; anxv; anxw; anxx; anxy; anxz; anya; anyb; anyc; anyd; anye; anyf; anyg; anyh; anyi; anyj; anyk; anyl; anym; anyn; anyo; anyp; anyq; anyr; anys; anyt; anyu; anyv; anyw; anyx; anyy; anyz; anza; anzb; anzc; anzd; anze; anzf; anzg; anzh; anzi; anzj; anzk; anzl; anzm; anzn; anzo; anzp; anzq; anzr; anzs; anzt; anzu; anzv; anzw; anzx; anzy; anzz; aoaa; aoab; aoac; aoad; aoae; aoaf; aoag; aoah; aoai; aoaj; aoak; aoal; aoam; aoan; aoao; aoap; aoaq; aoar; aoas; aoat; aoau; aoav; aoaw; aoax; aoay; aoaz; aoba; aobb; aobc; aobd; aobe; aobf; aobg; aobh; aobi; aobj; aobk; aobl; aobm; aobn; aobo; aobp; aobq; aobr; aobs; aobt; aobu; aobv; aobw; aobx; aoby; aobz; aoca; aocb; aocc; aocd; aoce; aocf; aocg; aoch; aoci; aocj; aock; aocl; aocm; aocn; aoco; aocp; aocq; aocr; aocs; aoct; aocu; aocv; aocw; aocx; aocy; aocz; aoda; aodb; aodc; aodd; aode; aodf; aodg; aodh; aodi; aodj; aodk; aodl; aodm; aodn; aodo; aodp; aodq; aodr; aods; aodt; aodu; aodv; aodw; aodx; aody; aodz; aoea; aoeb; aoec; aoed; aoee; aoef; aoeg; aoeh; aoei; aoej; aoek; aoel; aoem; aoen; aoeo; aoep; aoeq; aoer; aoes; aoet; aoeu; aoev; aoew; aoex; aoey; aoez; aofa; aofb; aofc; aofd; aofe; aoff; aofg; aofh; aofi; aofj; aofk; aofl; aofm; aofn; aofo; aofp; aofq; aofr; aofs; aoft; aofu; aofv; aofw; aofx; aofy; aofz; aoga; aogb; aogc; aogd; aoge; aogf; aogg; aogh; aogi; aogj; aogk; aogl; aogm; aogn; aogo; aogp; aogq; aogr; aogs; aogt; aogu; aogv; aogw; aogx; aogy; aogz; aoha; aohb; aohc; aohd; aohe; aohf; aohg; aohh; aohi; aohj; aohk; aohl; aohm; aohn; aoho; aohp; aohq; aohr; aohs; aoht; aohu; aohv; aohw; aohx; aohy; aohz; aoia; aoib; aoic; aoid; aoie; aoif; aoig; aoih; aoii; aoij; aoik; aoil; aoim; aoin; aoio; aoip; aoiq; aoir; aois; aoit; aoiu; aoiv; aoiw; aoix; aoiy; aoiz; aoja; aojb; aojc; aojd; aoje; aojf; aojg; aojh; aoji; aojj; aojk; aojl; aojm; aojn; aojo; aojp; aojq; aojr; aojs; aojt; aoju; aojv; aojw; aojx; aojy; aojz; aoka; aokb; aokc; aokd; aoke; aokf; aokg; aokh; aoki; aokj; aokk; aokl; aokm; aokn; aoko; aokp; aokq; aokr; aoks; aokt; aoku; aokv; aokw; aokx; aoky; aokz; aola; aolb; aolc; aold; aole; aolf; aolg; aolh; aoli; aolj; aolk; aoll; aolm; aoln; aolo; aolp; aolq; aolr; aols; aolt; aolu; aolv; aolw; aolx; aoly; aolz; aoma; aomb; aomc; aomd; aome; aomf; aomg; aomh; aomi; aomj; aomk; aoml; aomm; aomn; aomo; aomp; aomq; aomr; aoms; aomt; aomu; aomv; aomw; aomx; aomy; aomz; aona; aonb; aonc; aond; aone; aonf; aong; aonh; aoni; aonj; aonk; aonl; aonm; aonn; aono; aonp; aonq; aonr; aons; aont; aonu; aonv; aonw; aonx; aony; aonz; aooa; aoob; aooc; aood; aooe; aoof; aoog; aooh; aooi; aooj; aook; aool; aoom; aoon; aooo; aoop; aooq; aoor; aoos; aoot; aoou; aoov; aoow; aoox; aooy; aooz; aopa; aopb; aopc; aopd; aope; aopf; aopg; aoph; aopi; aopj; aopk; aopl; aopm; aopn; aopo; aopp; aopq; aopr; aops; aopt; aopu; aopv; aopw; aopx; aopy; aopz; aoqa; aoqb; aoqc; aoqd; aoqe; aoqf; aoqg; aoqh; aoqi; aoqj; aoqk; aoql; aoqm; aoqn; aoqo; aoqp; aoqq; aoqr; aoqs; aoqt; aoqu; aoqv; aoqw; aoqx; aoqy; aoqz; aora; aorb; aorc; aord; aore; aorf; aorg; aorh; aori; aorj; aork; aorl; aorm; aorn; aoro; aorp; aorq; aorr; aors; aort; aoru; aorv; aorw; aorx; aory; aorz; aosa; aosb; aosc; aosd; aose; aosf; aosg; aosh; aosi; aosj; aosk; aosl; aosm; aosn; aoso; aosp; aosq; aosr; aoss; aost; aosu; aosv; aosw; aosx; aosy; aosz; aota; aotb; aotc; aotd; aote; aotf; aotg; aoth; aoti; aotj; aotk; aotl; aotm; aotn; aoto; aotp; aotq; aotr; aots; aott; aotu; aotv; aotw; aotx; aoty; aotz; aoua; aoub; aouc; aoud; aoue; aouf; aoug; aouh; aoui; aouj; aouk; aoul; aoum; aoun; aouo; aoup; aouq; aour; aous; aout; aouu; aouv; aouw; aoux; aouy; aouz; aova; aovb; aovc; aovd; aove; aovf; aovg; aovh; aovi; aovj; aovk; aovl; aovm; aovn; aovo; aovp; aovq; aovr; aovs; aovt; aovu; aovv; aovw; aovx; aovy; aovz; aowa; aowb; aowc; aowd; aowe; aowf; aowg; aowh; aowi; aowj; aowk; aowl; aowm; aown; aowo; aowp; aowq; aowr; aows; aowt; aowu; aowv; aoww; aowx; aowy; aowz; aoxa; aoxb; aoxc; aoxd; aoxe; aoxf; aoxg; aoxh; aoxi; aoxj; aoxk; aoxl; aoxm; aoxn; aoxo; aoxp; aoxq; aoxr; aoxs; aoxt; aoxu; aoxv; aoxw; aoxx; aoxy; aoxz; aoya; aoyb; aoyc; aoyd; aoye; aoyf; aoyg; aoyh; aoyi; aoyj; aoyk; aoyl; aoym; aoyn; aoyo; aoyp; aoyq; aoyr; aoys; aoyt; aoyu; aoyv; aoyw; aoyx; aoyy; aoyz; aoza; aozb; aozc; aozd; aoze; aozf; aozg; aozh; aozi; aozj; aozk; aozl; aozm; aozn; aozo; aozp; aozq; aozr; aozs; aozt; aozu; aozv; aozw; aozx; aozy; aozz; apaa; apab; apac; apad; apae; apaf; apag; apah; apai; apaj; apak; apal; apam; apan; apao; apap; apaq; apar; apas; apat; apau; apav; apaw; apax; apay; apaz; apba; apbb; apbc; apbd; apbe; apbf; apbg; apbh; apbi; apbj; apbk; apbl; apbm; apbn; apbo; apbp; apbq; apbr; apbs; apbt; apbu; apbv; apbw; apbx; apby; apbz; apca; apcb; apcc; apcd; apce; apcf; apcg; apch; apci; apcj; apck; apcl; apcm; apcn; apco; apcp; apcq; apcr; apcs; apct; apcu; apcv; apcw; apcx; apcy; apcz; apda; apdb; apdc; apdd; apde; apdf; apdg; apdh; apdi; apdj; apdk; apdl; apdm; apdn; apdo; apdp; apdq; apdr; apds; apdt; apdu; apdv; apdw; apdx; apdy; apdz; apea; apeb; apec; aped; apee; apef; apeg; apeh; apei; apej; apek; apel; apem; apen; apeo; apep; apeq; aper; apes; apet; apeu; apev; apew; apex; apey; apez; apfa; apfb; apfc; apfd; apfe; apff; apfg; apfh; apfi; apfj; apfk; apfl; apfm; apfn; apfo; apfp; apfq; apfr; apfs; apft; apfu; apfv; apfw; apfx; apfy; apfz; apga; apgb; apgc; apgd; apge; apgf; apgg; apgh; apgi; apgj; apgk; apgl; apgm; apgn; apgo; apgp; apgq; apgr; apgs; apgt; apgu; apgv; apgw; apgx; apgy; apgz; apha; aphb; aphc; aphd; aphe; aphf; aphg; aphh; aphi; aphj; aphk; aphl; aphm; aphn; apho; aphp; aphq; aphr; aphs; apht; aphu; aphv; aphw; aphx; aphy; aphz; apia; apib; apic; apid; apie; apif; apig; apih; apii; apij; apik; apil; apim; apin; apio; apip; apiq; apir; apis; apit; apiu; apiv; apiw; apix; apiy; apiz; apja; apjb; apjc; apjd; apje; apjf; apjg; apjh; apji; apjj; apjk; apjl; apjm; apjn; apjo; apjp; apjq; apjr; apjs; apjt; apju; apjv; apjw; apjx; apjy; apjz; apka; apkb; apkc; apkd; apke; apkf; apkg; apkh; apki; apkj; apkk; apkl; apkm; apkn; apko; apkp; apkq; apkr; apks; apkt; apku; apkv; apkw; apkx; apky; apkz; apla; aplb; aplc; apld; aple; aplf; aplg; aplh; apli; aplj; aplk; apll; aplm; apln; aplo; aplp; aplq; aplr; apls; aplt; aplu; aplv; aplw; aplx; aply; aplz; apma; apmb; apmc; apmd; apme; apmf; apmg; apmh; apmi; apmj; apmk; apml; apmm; apmn; apmo; apmp; apmq; apmr; apms; apmt; apmu; apmv; apmw; apmx; apmy; apmz; apna; apnb; apnc; apnd; apne; apnf; apng; apnh; apni; apnj; apnk; apnl; apnm; apnn; apno; apnp; apnq; apnr; apns; apnt; apnu; apnv; apnw; apnx; apny; apnz; apoa; apob; apoc; apod; apoe; apof; apog; apoh; apoi; apoj; apok; apol; apom; apon; apoo; apop; apoq; apor; apos; apot; apou; apov; apow; apox; apoy; apoz; appa; appb; appc; appd; appe; appf; appg; apph; appi; appj; appk; appl; appm; appn; appo; appp; appq; appr; apps; appt; appu; appv; appw; appx; appy; appz; apqa; apqb; apqc; apqd; apqe; apqf; apqg; apqh; apqi; apqj; apqk; apql; apqm; apqn; apqo; apqp; apqq; apqr; apqs; apqt; apqu; apqv; apqw; apqx; apqy; apqz; apra; aprb; aprc; aprd; apre; aprf; aprg; aprh; apri; aprj; aprk; aprl; aprm; aprn; apro; aprp; aprq; aprr; aprs; aprt; apru; aprv; aprw; aprx; apry; aprz; apsa; apsb; apsc; apsd; apse; apsf; apsg; apsh; apsi; apsj; apsk; apsl; apsm; apsn; apso; apsp; apsq; apsr; apss; apst; apsu; apsv; apsw; apsx; apsy; apsz; apta; aptb; aptc; aptd; apte; aptf; aptg; apth; apti; aptj; aptk; aptl; aptm; aptn; apto; aptp; aptq; aptr; apts; aptt; aptu; aptv; aptw; aptx; apty; aptz; apua; apub; apuc; apud; apue; apuf; apug; apuh; apui; apuj; apuk; apul; apum; apun; apuo; apup; apuq; apur; apus; aput; apuu; apuv; apuw; apux; apuy; apuz; apva; apvb; apvc; apvd; apve; apvf; apvg; apvh; apvi; apvj; apvk; apvl; apvm; apvn; apvo; apvp; apvq; apvr; apvs; apvt; apvu; apvv; apvw; apvx; apvy; apvz; apwa; apwb; apwc; apwd; apwe; apwf; apwg; apwh; apwi; apwj; apwk; apwl; apwm; apwn; apwo; apwp; apwq; apwr; apws; apwt; apwu; apwv; apww; apwx; apwy; apwz; apxa; apxb; apxc; apxd; apxe; apxf; apxg; apxh; apxi; apxj; apxk; apxl; apxm; apxn; apxo; apxp; apxq; apxr; apxs; apxt; apxu; apxv; apxw; apxx; apxy; apxz; apya; apyb; apyc; apyd; apye; apyf; apyg; apyh; apyi; apyj; apyk; apyl; apym; apyn; apyo; apyp; apyq; apyr; apys; apyt; apyu; apyv; apyw; apyx; apyy; apyz; apza; apzb; apzc; apzd; apze; apzf; apzg; apzh; apzi; apzj; apzk; apzl; apzm; apzn; apzo; apzp; apzq; apzr; apzs; apzt; apzu; apzv; apzw; apzx; apzy; apzz; aqaa; aqab; aqac; aqad; aqae; aqaf; aqag; aqah; aqai; aqaj; aqak; aqal; aqam; aqan; aqao; aqap; aqaq; aqar; aqas; aqat; aqau; aqav; aqaw; aqax; aqay; aqaz; aqba; aqbb; aqbc; aqbd; aqbe; aqbf; aqbg; aqbh; aqbi; aqbj; aqbk; aqbl; aqbm; aqbn; aqbo; aqbp; aqbq; aqbr; aqbs; aqbt; aqbu; aqbv; aqbw; aqbx; aqby; aqbz; aqca; aqcb; aqcc; aqcd; aqce; aqcf; aqcg; aqch; aqci; aqcj; aqck; aqcl; aqcm; aqcn; aqco; aqcp; aqcq; aqcr; aqcs; aqct; aqcu; aqcv; aqcw; aqcx; aqcy; aqcz; aqda; aqdb; aqdc; aqdd; aqde; aqdf; aqdg; aqdh; aqdi; aqdj; aqdk; aqdl; aqdm; aqdn; aqdo; aqdp; aqdq; aqdr; aqds; aqdt; aqdu; aqdv; aqdw; aqdx; aqdy; aqdz; aqea; aqeb; aqec; aqed; aqee; aqef; aqeg; aqeh; aqei; aqej; aqek; aqel; aqem; aqen; aqeo; aqep; aqeq; aqer; aqes; aqet; aqeu; aqev; aqew; aqex; aqey; aqez; aqfa; aqfb; aqfc; aqfd; aqfe; aqff; aqfg; aqfh; aqfi; aqfj; aqfk; aqfl; aqfm; aqfn; aqfo; aqfp; aqfq; aqfr; aqfs; aqft; aqfu; aqfv; aqfw; aqfx; aqfy; aqfz; aqga; aqgb; aqgc; aqgd; aqge; aqgf; aqgg; aqgh; aqgi; aqgj; aqgk; aqgl; aqgm; aqgn; aqgo; aqgp; aqgq; aqgr; aqgs; aqgt; aqgu; aqgv; aqgw; aqgx; aqgy; aqgz; aqha; aqhb; aqhc; aqhd; aqhe; aqhf; aqhg; aqhh; aqhi; aqhj; aqhk; aqhl; aqhm; aqhn; aqho; aqhp; aqhq; aqhr; aqhs; aqht; aqhu; aqhv; aqhw; aqhx; aqhy; aqhz; aqia; aqib; aqic; aqid; aqie; aqif; aqig; aqih; aqii; aqij; aqik; aqil; aqim; aqin; aqio; aqip; aqiq; aqir; aqis; aqit; aqiu; aqiv; aqiw; aqix; aqiy; aqiz; aqja; aqjb; aqjc; aqjd; aqje; aqjf; aqjg; aqjh; aqji; aqjj; aqjk; aqjl; aqjm; aqjn; aqjo; aqjp; aqjq; aqjr; aqjs; aqjt; aqju; aqjv; aqjw; aqjx; aqjy; aqjz; aqka; aqkb; aqkc; aqkd; aqke; aqkf; aqkg; aqkh; aqki; aqkj; aqkk; aqkl; aqkm; aqkn; aqko; aqkp; aqkq; aqkr; aqks; aqkt; aqku; aqkv; aqkw; aqkx; aqky; aqkz; aqla; aqlb; aqlc; aqld; aqle; aqlf; aqlg; aqlh; aqli; aqlj; aqlk; aqll; aqlm; aqln; aqlo; aqlp; aqlq; aqlr; aqls; aqlt; aqlu; aqlv; aqlw; aqlx; aqly; aqlz; aqma; aqmb; aqmc; aqmd; aqme; aqmf; aqmg; aqmh; aqmi; aqmj; aqmk; aqml; aqmm; aqmn; aqmo; aqmp; aqmq; aqmr; aqms; aqmt; aqmu; aqmv; aqmw; aqmx; aqmy; aqmz; aqna; aqnb; aqnc; aqnd; aqne; aqnf; aqng; aqnh; aqni; aqnj; aqnk; aqnl; aqnm; aqnn; aqno; aqnp; aqnq; aqnr; aqns; aqnt; aqnu; aqnv; aqnw; aqnx; aqny; aqnz; aqoa; aqob; aqoc; aqod; aqoe; aqof; aqog; aqoh; aqoi; aqoj; aqok; aqol; aqom; aqon; aqoo; aqop; aqoq; aqor; aqos; aqot; aqou; aqov; aqow; aqox; aqoy; aqoz; aqpa; aqpb; aqpc; aqpd; aqpe; aqpf; aqpg; aqph; aqpi; aqpj; aqpk; aqpl; aqpm; aqpn; aqpo; aqpp; aqpq; aqpr; aqps; aqpt; aqpu; aqpv; aqpw; aqpx; aqpy; aqpz; aqqa; aqqb; aqqc; aqqd; aqqe; aqqf; aqqg; aqqh; aqqi; aqqj; aqqk; aqql; aqqm; aqqn; aqqo; aqqp; aqqq; aqqr; aqqs; aqqt; aqqu; aqqv; aqqw; aqqx; aqqy; aqqz; aqra; aqrb; aqrc; aqrd; aqre; aqrf; aqrg; aqrh; aqri; aqrj; aqrk; aqrl; aqrm; aqrn; aqro; aqrp; aqrq; aqrr; aqrs; aqrt; aqru; aqrv; aqrw; aqrx; aqry; aqrz; aqsa; aqsb; aqsc; aqsd; aqse; aqsf; aqsg; aqsh; aqsi; aqsj; aqsk; aqsl; aqsm; aqsn; aqso; aqsp; aqsq; aqsr; aqss; aqst; aqsu; aqsv; aqsw; aqsx; aqsy; aqsz; aqta; aqtb; aqtc; aqtd; aqte; aqtf; aqtg; aqth; aqti; aqtj; aqtk; aqtl; aqtm; aqtn; aqto; aqtp; aqtq; aqtr; aqts; aqtt; aqtu; aqtv; aqtw; aqtx; aqty; aqtz; aqua; aqub; aquc; aqud; aque; aquf; aqug; aquh; aqui; aquj; aquk; aqul; aqum; aqun; aquo; aqup; aquq; aqur; aqus; aqut; aquu; aquv; aquw; aqux; aquy; aquz; aqva; aqvb; aqvc; aqvd; aqve; aqvf; aqvg; aqvh; aqvi; aqvj; aqvk; aqvl; aqvm; aqvn; aqvo; aqvp; aqvq; aqvr; aqvs; aqvt; aqvu; aqvv; aqvw; aqvx; aqvy; aqvz; aqwa; aqwb; aqwc; aqwd; aqwe; aqwf; aqwg; aqwh; aqwi; aqwj; aqwk; aqwl; aqwm; aqwn; aqwo; aqwp; aqwq; aqwr; aqws; aqwt; aqwu; aqwv; aqww; aqwx; aqwy; aqwz; aqxa; aqxb; aqxc; aqxd; aqxe; aqxf; aqxg; aqxh; aqxi; aqxj; aqxk; aqxl; aqxm; aqxn; aqxo; aqxp; aqxq; aqxr; aqxs; aqxt; aqxu; aqxv; aqxw; aqxx; aqxy; aqxz; aqya; aqyb; aqyc; aqyd; aqye; aqyf; aqyg; aqyh; aqyi; aqyj; aqyk; aqyl; aqym; aqyn; aqyo; aqyp; aqyq; aqyr; aqys; aqyt; aqyu; aqyv; aqyw; aqyx; aqyy; aqyz; aqza; aqzb; aqzc; aqzd; aqze; aqzf; aqzg; aqzh; aqzi; aqzj; aqzk; aqzl; aqzm; aqzn; aqzo; aqzp; aqzq; aqzr; aqzs; aqzt; aqzu; aqzv; aqzw; aqzx; aqzy; aqzz; araa; arab; arac; arad; arae; araf; arag; arah; arai; araj; arak; aral; aram; aran; arao; arap; araq; arar; aras; arat; arau; arav; araw; arax; aray; araz; arba; arbb; arbc; arbd; arbe; arbf; arbg; arbh; arbi; arbj; arbk; arbl; arbm; arbn; arbo; arbp; arbq; arbr; arbs; arbt; arbu; arbv; arbw; arbx; arby; arbz; arca; arcb; arcc; arcd; arce; arcf; arcg; arch; arci; arcj; arck; arcl; arcm; arcn; arco; arcp; arcq; arcr; arcs; arct; arcu; arcv; arcw; arcx; arcy; arcz; arda; ardb; ardc; ardd; arde; ardf; ardg; ardh; ardi; ardj; ardk; ardl; ardm; ardn; ardo; ardp; ardq; ardr; ards; ardt; ardu; ardv; ardw; ardx; ardy; ardz; area; areb; arec; ared; aree; aref; areg; areh; arei; arej; arek; arel; arem; aren; areo; arep; areq; arer; ares; aret; areu; arev; arew; arex; arey; arez; arfa; arfb; arfc; arfd; arfe; arff; arfg; arfh; arfi; arfj; arfk; arfl; arfm; arfn; arfo; arfp; arfq; arfr; arfs; arft; arfu; arfv; arfw; arfx; arfy; arfz; arga; argb; argc; argd; arge; argf; argg; argh; argi; argj; argk; argl; argm; argn; argo; argp; argq; argr; args; argt; argu; argv; argw; argx; argy; argz; arha; arhb; arhc; arhd; arhe; arhf; arhg; arhh; arhi; arhj; arhk; arhl; arhm; arhn; arho; arhp; arhq; arhr; arhs; arht; arhu; arhv; arhw; arhx; arhy; arhz; aria; arib; aric; arid; arie; arif; arig; arih; arii; arij; arik; aril; arim; arin; ario; arip; ariq; arir; aris; arit; ariu; ariv; ariw; arix; ariy; ariz; arja; arjb; arjc; arjd; arje; arjf; arjg; arjh; arji; arjj; arjk; arjl; arjm; arjn; arjo; arjp; arjq; arjr; arjs; arjt; arju; arjv; arjw; arjx; arjy; arjz; arka; arkb; arkc; arkd; arke; arkf; arkg; arkh; arki; arkj; arkk; arkl; arkm; arkn; arko; arkp; arkq; arkr; arks; arkt; arku; arkv; arkw; arkx; arky; arkz; arla; arlb; arlc; arld; arle; arlf; arlg; arlh; arli; arlj; arlk; arll; arlm; arln; arlo; arlp; arlq; arlr; arls; arlt; arlu; arlv; arlw; arlx; arly; arlz; arma; armb; armc; armd; arme; armf; armg; armh; armi; armj; armk; arml; armm; armn; armo; armp; armq; armr; arms; armt; armu; armv; armw; armx; army; armz; arna; arnb; arnc; arnd; arne; arnf; arng; arnh; arni; arnj; arnk; arnl; arnm; arnn; arno; arnp; arnq; arnr; arns; arnt; arnu; arnv; arnw; arnx; arny; arnz; aroa; arob; aroc; arod; aroe; arof; arog; aroh; aroi; aroj; arok; arol; arom; aron; aroo; arop; aroq; aror; aros; arot; arou; arov; arow; arox; aroy; aroz; arpa; arpb; arpc; arpd; arpe; arpf; arpg; arph; arpi; arpj; arpk; arpl; arpm; arpn; arpo; arpp; arpq; arpr; arps; arpt; arpu; arpv; arpw; arpx; arpy; arpz; arqa; arqb; arqc; arqd; arqe; arqf; arqg; arqh; arqi; arqj; arqk; arql; arqm; arqn; arqo; arqp; arqq; arqr; arqs; arqt; arqu; arqv; arqw; arqx; arqy; arqz; arra; arrb; arrc; arrd; arre; arrf; arrg; arrh; arri; arrj; arrk; arrl; arrm; arrn; arro; arrp; arrq; arrr; arrs; arrt; arru; arrv; arrw; arrx; arry; arrz; arsa; arsb; arsc; arsd; arse; arsf; arsg; arsh; arsi; arsj; arsk; arsl; arsm; arsn; arso; arsp; arsq; arsr; arss; arst; arsu; arsv; arsw; arsx; arsy; arsz; arta; artb; artc; artd; arte; artf; artg; arth; arti; artj; artk; artl; artm; artn; arto; artp; artq; artr; arts; artt; artu; artv; artw; artx; arty; artz; arua; arub; aruc; arud; arue; aruf; arug; aruh; arui; aruj; aruk; arul; arum; arun; aruo; arup; aruq; arur; arus; arut; aruu; aruv; aruw; arux; aruy; aruz; arva; arvb; arvc; arvd; arve; arvf; arvg; arvh; arvi; arvj; arvk; arvl; arvm; arvn; arvo; arvp; arvq; arvr; arvs; arvt; arvu; arvv; arvw; arvx; arvy; arvz; arwa; arwb; arwc; arwd; arwe; arwf; arwg; arwh; arwi; arwj; arwk; arwl; arwm; arwn; arwo; arwp; arwq; arwr; arws; arwt; arwu; arwv; arww; arwx; arwy; arwz; arxa; arxb; arxc; arxd; arxe; arxf; arxg; arxh; arxi; arxj; arxk; arxl; arxm; arxn; arxo; arxp; arxq; arxr; arxs; arxt; arxu; arxv; arxw; arxx; arxy; arxz; arya; aryb; aryc; aryd; arye; aryf; aryg; aryh; aryi; aryj; aryk; aryl; arym; aryn; aryo; aryp; aryq; aryr; arys; aryt; aryu; aryv; aryw; aryx; aryy; aryz; arza; arzb; arzc; arzd; arze; arzf; arzg; arzh; arzi; arzj; arzk; arzl; arzm; arzn; arzo; arzp; arzq; arzr; arzs; arzt; arzu; arzv; arzw; arzx; arzy; arzz; asaa; asab; asac; asad; asae; asaf; asag; asah; asai; asaj; asak; asal; asam; asan; asao; asap; asaq; asar; asas; asat; asau; asav; asaw; asax; asay; asaz; asba; asbb; asbc; asbd; asbe; asbf; asbg; asbh; asbi; asbj; asbk; asbl; asbm; asbn; asbo; asbp; asbq; asbr; asbs; asbt; asbu; asbv; asbw; asbx; asby; asbz; asca; ascb; ascc; ascd; asce; ascf; ascg; asch; asci; ascj; asck; ascl; ascm; ascn; asco; ascp; ascq; ascr; ascs; asct; ascu; ascv; ascw; ascx; ascy; ascz; asda; asdb; asdc; asdd; asde; asdf; asdg; asdh; asdi; asdj; asdk; asdl; asdm; asdn; asdo; asdp; asdq; asdr; asds; asdt; asdu; asdv; asdw; asdx; asdy; asdz; asea; aseb; asec; ased; asee; asef; aseg; aseh; asei; asej; asek; asel; asem; asen; aseo; asep; aseq; aser; ases; aset; aseu; asev; asew; asex; asey; asez; asfa; asfb; asfc; asfd; asfe; asff; asfg; asfh; asfi; asfj; asfk; asfl; asfm; asfn; asfo; asfp; asfq; asfr; asfs; asft; asfu; asfv; asfw; asfx; asfy; asfz; asga; asgb; asgc; asgd; asge; asgf; asgg; asgh; asgi; asgj; asgk; asgl; asgm; asgn; asgo; asgp; asgq; asgr; asgs; asgt; asgu; asgv; asgw; asgx; asgy; asgz; asha; ashb; ashc; ashd; ashe; ashf; ashg; ashh; ashi; ashj; ashk; ashl; ashm; ashn; asho; ashp; ashq; ashr; ashs; asht; ashu; ashv; ashw; ashx; ashy; ashz; asia; asib; asic; asid; asie; asif; asig; asih; asii; asij; asik; asil; asim; asin; asio; asip; asiq; asir; asis; asit; asiu; asiv; asiw; asix; asiy; asiz; asja; asjb; asjc; asjd; asje; asjf; asjg; asjh; asji; asjj; asjk; asjl; asjm; asjn; asjo; asjp; asjq; asjr; asjs; asjt; asju; asjv; asjw; asjx; asjy; asjz; aska; askb; askc; askd; aske; askf; askg; askh; aski; askj; askk; askl; askm; askn; asko; askp; askq; askr; asks; askt; asku; askv; askw; askx; asky; askz; asla; aslb; aslc; asld; asle; aslf; aslg; aslh; asli; aslj; aslk; asll; aslm; asln; aslo; aslp; aslq; aslr; asls; aslt; aslu; aslv; aslw; aslx; asly; aslz; asma; asmb; asmc; asmd; asme; asmf; asmg; asmh; asmi; asmj; asmk; asml; asmm; asmn; asmo; asmp; asmq; asmr; asms; asmt; asmu; asmv; asmw; asmx; asmy; asmz; asna; asnb; asnc; asnd; asne; asnf; asng; asnh; asni; asnj; asnk; asnl; asnm; asnn; asno; asnp; asnq; asnr; asns; asnt; asnu; asnv; asnw; asnx; asny; asnz; asoa; asob; asoc; asod; asoe; asof; asog; asoh; asoi; asoj; asok; asol; asom; ason; asoo; asop; asoq; asor; asos; asot; asou; asov; asow; asox; asoy; asoz; aspa; aspb; aspc; aspd; aspe; aspf; aspg; asph; aspi; aspj; aspk; aspl; aspm; aspn; aspo; aspp; aspq; aspr; asps; aspt; aspu; aspv; aspw; aspx; aspy; aspz; asqa; asqb; asqc; asqd; asqe; asqf; asqg; asqh; asqi; asqj; asqk; asql; asqm; asqn; asqo; asqp; asqq; asqr; asqs; asqt; asqu; asqv; asqw; asqx; asqy; asqz; asra; asrb; asrc; asrd; asre; asrf; asrg; asrh; asri; asrj; asrk; asrl; asrm; asrn; asro; asrp; asrq; asrr; asrs; asrt; asru; asrv; asrw; asrx; asry; asrz; assa; assb; assc; assd; asse; assf; assg; assh; assi; assj; assk; assl; assm; assn; asso; assp; assq; assr; asss; asst; assu; assv; assw; assx; assy; assz; asta; astb; astc; astd; aste; astf; astg; asth; asti; astj; astk; astl; astm; astn; asto; astp; astq; astr; asts; astt; astu; astv; astw; astx; asty; astz; asua; asub; asuc; asud; asue; asuf; asug; asuh; asui; asuj; asuk; asul; asum; asun; asuo; asup; asuq; asur; asus; asut; asuu; asuv; asuw; asux; asuy; asuz; asva; asvb; asvc; asvd; asve; asvf; asvg; asvh; asvi; asvj; asvk; asvl; asvm; asvn; asvo; asvp; asvq; asvr; asvs; asvt; asvu; asvv; asvw; asvx; asvy; asvz; aswa; aswb; aswc; aswd; aswe; aswf; aswg; aswh; aswi; aswj; aswk; aswl; aswm; aswn; aswo; aswp; aswq; aswr; asws; aswt; aswu; aswv; asww; aswx; aswy; aswz; asxa; asxb; asxc; asxd; asxe; asxf; asxg; asxh; asxi; asxj; asxk; asxl; asxm; asxn; asxo; asxp; asxq; asxr; asxs; asxt; asxu; asxv; asxw; asxx; asxy; asxz; asya; asyb; asyc; asyd; asye; asyf; asyg; asyh; asyi; asyj; asyk; asyl; asym; asyn; asyo; asyp; asyq; asyr; asys; asyt; asyu; asyv; asyw; asyx; asyy; asyz; asza; aszb; aszc; aszd; asze; aszf; aszg; aszh; aszi; aszj; aszk; aszl; aszm; aszn; aszo; aszp; aszq; aszr; aszs; aszt; aszu; aszv; aszw; aszx; aszy; aszz; ataa; atab; atac; atad; atae; ataf; atag; atah; atai; ataj; atak; atal; atam; atan; atao; atap; ataq; atar; atas; atat; atau; atav; ataw; atax; atay; ataz; atba; atbb; atbc; atbd; atbe; atbf; atbg; atbh; atbi; atbj; atbk; atbl; atbm; atbn; atbo; atbp; atbq; atbr; atbs; atbt; atbu; atbv; atbw; atbx; atby; atbz; atca; atcb; atcc; atcd; atce; atcf; atcg; atch; atci; atcj; atck; atcl; atcm; atcn; atco; atcp; atcq; atcr; atcs; atct; atcu; atcv; atcw; atcx; atcy; atcz; atda; atdb; atdc; atdd; atde; atdf; atdg; atdh; atdi; atdj; atdk; atdl; atdm; atdn; atdo; atdp; atdq; atdr; atds; atdt; atdu; atdv; atdw; atdx; atdy; atdz; atea; ateb; atec; ated; atee; atef; ateg; ateh; atei; atej; atek; atel; atem; aten; ateo; atep; ateq; ater; ates; atet; ateu; atev; atew; atex; atey; atez; atfa; atfb; atfc; atfd; atfe; atff; atfg; atfh; atfi; atfj; atfk; atfl; atfm; atfn; atfo; atfp; atfq; atfr; atfs; atft; atfu; atfv; atfw; atfx; atfy; atfz; atga; atgb; atgc; atgd; atge; atgf; atgg; atgh; atgi; atgj; atgk; atgl; atgm; atgn; atgo; atgp; atgq; atgr; atgs; atgt; atgu; atgv; atgw; atgx; atgy; atgz; atha; athb; athc; athd; athe; athf; athg; athh; athi; athj; athk; athl; athm; athn; atho; athp; athq; athr; aths; atht; athu; athv; athw; athx; athy; athz; atia; atib; atic; atid; atie; atif; atig; atih; atii; atij; atik; atil; atim; atin; atio; atip; atiq; atir; atis; atit; atiu; ativ; atiw; atix; atiy; atiz; atja; atjb; atjc; atjd; atje; atjf; atjg; atjh; atji; atjj; atjk; atjl; atjm; atjn; atjo; atjp; atjq; atjr; atjs; atjt; atju; atjv; atjw; atjx; atjy; atjz; atka; atkb; atkc; atkd; atke; atkf; atkg; atkh; atki; atkj; atkk; atkl; atkm; atkn; atko; atkp; atkq; atkr; atks; atkt; atku; atkv; atkw; atkx; atky; atkz; atla; atlb; atlc; atld; atle; atlf; atlg; atlh; atli; atlj; atlk; atll; atlm; atln; atlo; atlp; atlq; atlr; atls; atlt; atlu; atlv; atlw; atlx; atly; atlz; atma; atmb; atmc; atmd; atme; atmf; atmg; atmh; atmi; atmj; atmk; atml; atmm; atmn; atmo; atmp; atmq; atmr; atms; atmt; atmu; atmv; atmw; atmx; atmy; atmz; atna; atnb; atnc; atnd; atne; atnf; atng; atnh; atni; atnj; atnk; atnl; atnm; atnn; atno; atnp; atnq; atnr; atns; atnt; atnu; atnv; atnw; atnx; atny; atnz; atoa; atob; atoc; atod; atoe; atof; atog; atoh; atoi; atoj; atok; atol; atom; aton; atoo; atop; atoq; ator; atos; atot; atou; atov; atow; atox; atoy; atoz; atpa; atpb; atpc; atpd; atpe; atpf; atpg; atph; atpi; atpj; atpk; atpl; atpm; atpn; atpo; atpp; atpq; atpr; atps; atpt; atpu; atpv; atpw; atpx; atpy; atpz; atqa; atqb; atqc; atqd; atqe; atqf; atqg; atqh; atqi; atqj; atqk; atql; atqm; atqn; atqo; atqp; atqq; atqr; atqs; atqt; atqu; atqv; atqw; atqx; atqy; atqz; atra; atrb; atrc; atrd; atre; atrf; atrg; atrh; atri; atrj; atrk; atrl; atrm; atrn; atro; atrp; atrq; atrr; atrs; atrt; atru; atrv; atrw; atrx; atry; atrz; atsa; atsb; atsc; atsd; atse; atsf; atsg; atsh; atsi; atsj; atsk; atsl; atsm; atsn; atso; atsp; atsq; atsr; atss; atst; atsu; atsv; atsw; atsx; atsy; atsz; atta; attb; attc; attd; atte; attf; attg; atth; atti; attj; attk; attl; attm; attn; atto; attp; attq; attr; atts; attt; attu; attv; attw; attx; atty; attz; atua; atub; atuc; atud; atue; atuf; atug; atuh; atui; atuj; atuk; atul; atum; atun; atuo; atup; atuq; atur; atus; atut; atuu; atuv; atuw; atux; atuy; atuz; atva; atvb; atvc; atvd; atve; atvf; atvg; atvh; atvi; atvj; atvk; atvl; atvm; atvn; atvo; atvp; atvq; atvr; atvs; atvt; atvu; atvv; atvw; atvx; atvy; atvz; atwa; atwb; atwc; atwd; atwe; atwf; atwg; atwh; atwi; atwj; atwk; atwl; atwm; atwn; atwo; atwp; atwq; atwr; atws; atwt; atwu; atwv; atww; atwx; atwy; atwz; atxa; atxb; atxc; atxd; atxe; atxf; atxg; atxh; atxi; atxj; atxk; atxl; atxm; atxn; atxo; atxp; atxq; atxr; atxs; atxt; atxu; atxv; atxw; atxx; atxy; atxz; atya; atyb; atyc; atyd; atye; atyf; atyg; atyh; atyi; atyj; atyk; atyl; atym; atyn; atyo; atyp; atyq; atyr; atys; atyt; atyu; atyv; atyw; atyx; atyy; atyz; atza; atzb; atzc; atzd; atze; atzf; atzg; atzh; atzi; atzj; atzk; atzl; atzm; atzn; atzo; atzp; atzq; atzr; atzs; atzt; atzu; atzv; atzw; atzx; atzy; atzz; auaa; auab; auac; auad; auae; auaf; auag; auah; auai; auaj; auak; aual; auam; auan; auao; auap; auaq; auar; auas; auat; auau; auav; auaw; auax; auay; auaz; auba; aubb; aubc; aubd; aube; aubf; aubg; aubh; aubi; aubj; aubk; aubl; aubm; aubn; aubo; aubp; aubq; aubr; aubs; aubt; aubu; aubv; aubw; aubx; auby; aubz; auca; aucb; aucc; aucd; auce; aucf; aucg; auch; auci; aucj; auck; aucl; aucm; aucn; auco; aucp; aucq; aucr; aucs; auct; aucu; aucv; aucw; aucx; aucy; aucz; auda; audb; audc; audd; aude; audf; audg; audh; audi; audj; audk; audl; audm; audn; audo; audp; audq; audr; auds; audt; audu; audv; audw; audx; audy; audz; auea; aueb; auec; aued; auee; auef; aueg; aueh; auei; auej; auek; auel; auem; auen; aueo; auep; aueq; auer; aues; auet; aueu; auev; auew; auex; auey; auez; aufa; aufb; aufc; aufd; aufe; auff; aufg; aufh; aufi; aufj; aufk; aufl; aufm; aufn; aufo; aufp; aufq; aufr; aufs; auft; aufu; aufv; aufw; aufx; aufy; aufz; auga; augb; augc; augd; auge; augf; augg; augh; augi; augj; augk; augl; augm; augn; augo; augp; augq; augr; augs; augt; augu; augv; augw; augx; augy; augz; auha; auhb; auhc; auhd; auhe; auhf; auhg; auhh; auhi; auhj; auhk; auhl; auhm; auhn; auho; auhp; auhq; auhr; auhs; auht; auhu; auhv; auhw; auhx; auhy; auhz; auia; auib; auic; auid; auie; auif; auig; auih; auii; auij; auik; auil; auim; auin; auio; auip; auiq; auir; auis; auit; auiu; auiv; auiw; auix; auiy; auiz; auja; aujb; aujc; aujd; auje; aujf; aujg; aujh; auji; aujj; aujk; aujl; aujm; aujn; aujo; aujp; aujq; aujr; aujs; aujt; auju; aujv; aujw; aujx; aujy; aujz; auka; aukb; aukc; aukd; auke; aukf; aukg; aukh; auki; aukj; aukk; aukl; aukm; aukn; auko; aukp; aukq; aukr; auks; aukt; auku; aukv; aukw; aukx; auky; aukz; aula; aulb; aulc; auld; aule; aulf; aulg; aulh; auli; aulj; aulk; aull; aulm; auln; aulo; aulp; aulq; aulr; auls; ault; aulu; aulv; aulw; aulx; auly; aulz; auma; aumb; aumc; aumd; aume; aumf; aumg; aumh; aumi; aumj; aumk; auml; aumm; aumn; aumo; aump; aumq; aumr; aums; aumt; aumu; aumv; aumw; aumx; aumy; aumz; auna; aunb; aunc; aund; aune; aunf; aung; aunh; auni; aunj; aunk; aunl; aunm; aunn; auno; aunp; aunq; aunr; auns; aunt; aunu; aunv; aunw; aunx; auny; aunz; auoa; auob; auoc; auod; auoe; auof; auog; auoh; auoi; auoj; auok; auol; auom; auon; auoo; auop; auoq; auor; auos; auot; auou; auov; auow; auox; auoy; auoz; aupa; aupb; aupc; aupd; aupe; aupf; aupg; auph; aupi; aupj; aupk; aupl; aupm; aupn; aupo; aupp; aupq; aupr; aups; aupt; aupu; aupv; aupw; aupx; aupy; aupz; auqa; auqb; auqc; auqd; auqe; auqf; auqg; auqh; auqi; auqj; auqk; auql; auqm; auqn; auqo; auqp; auqq; auqr; auqs; auqt; auqu; auqv; auqw; auqx; auqy; auqz; aura; aurb; aurc; aurd; aure; aurf; aurg; aurh; auri; aurj; aurk; aurl; aurm; aurn; auro; aurp; aurq; aurr; aurs; aurt; auru; aurv; aurw; aurx; aury; aurz; ausa; ausb; ausc; ausd; ause; ausf; ausg; aush; ausi; ausj; ausk; ausl; ausm; ausn; auso; ausp; ausq; ausr; auss; aust; ausu; ausv; ausw; ausx; ausy; ausz; auta; autb; autc; autd; aute; autf; autg; auth; auti; autj; autk; autl; autm; autn; auto; autp; autq; autr; auts; autt; autu; autv; autw; autx; auty; autz; auua; auub; auuc; auud; auue; auuf; auug; auuh; auui; auuj; auuk; auul; auum; auun; auuo; auup; auuq; auur; auus; auut; auuu; auuv; auuw; auux; auuy; auuz; auva; auvb; auvc; auvd; auve; auvf; auvg; auvh; auvi; auvj; auvk; auvl; auvm; auvn; auvo; auvp; auvq; auvr; auvs; auvt; auvu; auvv; auvw; auvx; auvy; auvz; auwa; auwb; auwc; auwd; auwe; auwf; auwg; auwh; auwi; auwj; auwk; auwl; auwm; auwn; auwo; auwp; auwq; auwr; auws; auwt; auwu; auwv; auww; auwx; auwy; auwz; auxa; auxb; auxc; auxd; auxe; auxf; auxg; auxh; auxi; auxj; auxk; auxl; auxm; auxn; auxo; auxp; auxq; auxr; auxs; auxt; auxu; auxv; auxw; auxx; auxy; auxz; auya; auyb; auyc; auyd; auye; auyf; auyg; auyh; auyi; auyj; auyk; auyl; auym; auyn; auyo; auyp; auyq; auyr; auys; auyt; auyu; auyv; auyw; auyx; auyy; auyz; auza; auzb; auzc; auzd; auze; auzf; auzg; auzh; auzi; auzj; auzk; auzl; auzm; auzn; auzo; auzp; auzq; auzr; auzs; auzt; auzu; auzv; auzw; auzx; auzy; auzz; avaa; avab; avac; avad; avae; avaf; avag; avah; avai; avaj; avak; aval; avam; avan; avao; avap; avaq; avar; avas; avat; avau; avav; avaw; avax; avay; avaz; avba; avbb; avbc; avbd; avbe; avbf; avbg; avbh; avbi; avbj; avbk; avbl; avbm; avbn; avbo; avbp; avbq; avbr; avbs; avbt; avbu; avbv; avbw; avbx; avby; avbz; avca; avcb; avcc; avcd; avce; avcf; avcg; avch; avci; avcj; avck; avcl; avcm; avcn; avco; avcp; avcq; avcr; avcs; avct; avcu; avcv; avcw; avcx; avcy; avcz; avda; avdb; avdc; avdd; avde; avdf; avdg; avdh; avdi; avdj; avdk; avdl; avdm; avdn; avdo; avdp; avdq; avdr; avds; avdt; avdu; avdv; avdw; avdx; avdy; avdz; avea; aveb; avec; aved; avee; avef; aveg; aveh; avei; avej; avek; avel; avem; aven; aveo; avep; aveq; aver; aves; avet; aveu; avev; avew; avex; avey; avez; avfa; avfb; avfc; avfd; avfe; avff; avfg; avfh; avfi; avfj; avfk; avfl; avfm; avfn; avfo; avfp; avfq; avfr; avfs; avft; avfu; avfv; avfw; avfx; avfy; avfz; avga; avgb; avgc; avgd; avge; avgf; avgg; avgh; avgi; avgj; avgk; avgl; avgm; avgn; avgo; avgp; avgq; avgr; avgs; avgt; avgu; avgv; avgw; avgx; avgy; avgz; avha; avhb; avhc; avhd; avhe; avhf; avhg; avhh; avhi; avhj; avhk; avhl; avhm; avhn; avho; avhp; avhq; avhr; avhs; avht; avhu; avhv; avhw; avhx; avhy; avhz; avia; avib; avic; avid; avie; avif; avig; avih; avii; avij; avik; avil; avim; avin; avio; avip; aviq; avir; avis; avit; aviu; aviv; aviw; avix; aviy; aviz; avja; avjb; avjc; avjd; avje; avjf; avjg; avjh; avji; avjj; avjk; avjl; avjm; avjn; avjo; avjp; avjq; avjr; avjs; avjt; avju; avjv; avjw; avjx; avjy; avjz; avka; avkb; avkc; avkd; avke; avkf; avkg; avkh; avki; avkj; avkk; avkl; avkm; avkn; avko; avkp; avkq; avkr; avks; avkt; avku; avkv; avkw; avkx; avky; avkz; avla; avlb; avlc; avld; avle; avlf; avlg; avlh; avli; avlj; avlk; avll; avlm; avln; avlo; avlp; avlq; avlr; avls; avlt; avlu; avlv; avlw; avlx; avly; avlz; avma; avmb; avmc; avmd; avme; avmf; avmg; avmh; avmi; avmj; avmk; avml; avmm; avmn; avmo; avmp; avmq; avmr; avms; avmt; avmu; avmv; avmw; avmx; avmy; avmz; avna; avnb; avnc; avnd; avne; avnf; avng; avnh; avni; avnj; avnk; avnl; avnm; avnn; avno; avnp; avnq; avnr; avns; avnt; avnu; avnv; avnw; avnx; avny; avnz; avoa; avob; avoc; avod; avoe; avof; avog; avoh; avoi; avoj; avok; avol; avom; avon; avoo; avop; avoq; avor; avos; avot; avou; avov; avow; avox; avoy; avoz; avpa; avpb; avpc; avpd; avpe; avpf; avpg; avph; avpi; avpj; avpk; avpl; avpm; avpn; avpo; avpp; avpq; avpr; avps; avpt; avpu; avpv; avpw; avpx; avpy; avpz; avqa; avqb; avqc; avqd; avqe; avqf; avqg; avqh; avqi; avqj; avqk; avql; avqm; avqn; avqo; avqp; avqq; avqr; avqs; avqt; avqu; avqv; avqw; avqx; avqy; avqz; avra; avrb; avrc; avrd; avre; avrf; avrg; avrh; avri; avrj; avrk; avrl; avrm; avrn; avro; avrp; avrq; avrr; avrs; avrt; avru; avrv; avrw; avrx; avry; avrz; avsa; avsb; avsc; avsd; avse; avsf; avsg; avsh; avsi; avsj; avsk; avsl; avsm; avsn; avso; avsp; avsq; avsr; avss; avst; avsu; avsv; avsw; avsx; avsy; avsz; avta; avtb; avtc; avtd; avte; avtf; avtg; avth; avti; avtj; avtk; avtl; avtm; avtn; avto; avtp; avtq; avtr; avts; avtt; avtu; avtv; avtw; avtx; avty; avtz; avua; avub; avuc; avud; avue; avuf; avug; avuh; avui; avuj; avuk; avul; avum; avun; avuo; avup; avuq; avur; avus; avut; avuu; avuv; avuw; avux; avuy; avuz; avva; avvb; avvc; avvd; avve; avvf; avvg; avvh; avvi; avvj; avvk; avvl; avvm; avvn; avvo; avvp; avvq; avvr; avvs; avvt; avvu; avvv; avvw; avvx; avvy; avvz; avwa; avwb; avwc; avwd; avwe; avwf; avwg; avwh; avwi; avwj; avwk; avwl; avwm; avwn; avwo; avwp; avwq; avwr; avws; avwt; avwu; avwv; avww; avwx; avwy; avwz; avxa; avxb; avxc; avxd; avxe; avxf; avxg; avxh; avxi; avxj; avxk; avxl; avxm; avxn; avxo; avxp; avxq; avxr; avxs; avxt; avxu; avxv; avxw; avxx; avxy; avxz; avya; avyb; avyc; avyd; avye; avyf; avyg; avyh; avyi; avyj; avyk; avyl; avym; avyn; avyo; avyp; avyq; avyr; avys; avyt; avyu; avyv; avyw; avyx; avyy; avyz; avza; avzb; avzc; avzd; avze; avzf; avzg; avzh; avzi; avzj; avzk; avzl; avzm; avzn; avzo; avzp; avzq; avzr; avzs; avzt; avzu; avzv; avzw; avzx; avzy; avzz; awaa; awab; awac; awad; awae; awaf; awag; awah; awai; awaj; awak; awal; awam; awan; awao; awap; awaq; awar; awas; awat; awau; awav; awaw; awax; away; awaz; awba; awbb; awbc; awbd; awbe; awbf; awbg; awbh; awbi; awbj; awbk; awbl; awbm; awbn; awbo; awbp; awbq; awbr; awbs; awbt; awbu; awbv; awbw; awbx; awby; awbz; awca; awcb; awcc; awcd; awce; awcf; awcg; awch; awci; awcj; awck; awcl; awcm; awcn; awco; awcp; awcq; awcr; awcs; awct; awcu; awcv; awcw; awcx; awcy; awcz; awda; awdb; awdc; awdd; awde; awdf; awdg; awdh; awdi; awdj; awdk; awdl; awdm; awdn; awdo; awdp; awdq; awdr; awds; awdt; awdu; awdv; awdw; awdx; awdy; awdz; awea; aweb; awec; awed; awee; awef; aweg; aweh; awei; awej; awek; awel; awem; awen; aweo; awep; aweq; awer; awes; awet; aweu; awev; awew; awex; awey; awez; awfa; awfb; awfc; awfd; awfe; awff; awfg; awfh; awfi; awfj; awfk; awfl; awfm; awfn; awfo; awfp; awfq; awfr; awfs; awft; awfu; awfv; awfw; awfx; awfy; awfz; awga; awgb; awgc; awgd; awge; awgf; awgg; awgh; awgi; awgj; awgk; awgl; awgm; awgn; awgo; awgp; awgq; awgr; awgs; awgt; awgu; awgv; awgw; awgx; awgy; awgz; awha; awhb; awhc; awhd; awhe; awhf; awhg; awhh; awhi; awhj; awhk; awhl; awhm; awhn; awho; awhp; awhq; awhr; awhs; awht; awhu; awhv; awhw; awhx; awhy; awhz; awia; awib; awic; awid; awie; awif; awig; awih; awii; awij; awik; awil; awim; awin; awio; awip; awiq; awir; awis; awit; awiu; awiv; awiw; awix; awiy; awiz; awja; awjb; awjc; awjd; awje; awjf; awjg; awjh; awji; awjj; awjk; awjl; awjm; awjn; awjo; awjp; awjq; awjr; awjs; awjt; awju; awjv; awjw; awjx; awjy; awjz; awka; awkb; awkc; awkd; awke; awkf; awkg; awkh; awki; awkj; awkk; awkl; awkm; awkn; awko; awkp; awkq; awkr; awks; awkt; awku; awkv; awkw; awkx; awky; awkz; awla; awlb; awlc; awld; awle; awlf; awlg; awlh; awli; awlj; awlk; awll; awlm; awln; awlo; awlp; awlq; awlr; awls; awlt; awlu; awlv; awlw; awlx; awly; awlz; awma; awmb; awmc; awmd; awme; awmf; awmg; awmh; awmi; awmj; awmk; awml; awmm; awmn; awmo; awmp; awmq; awmr; awms; awmt; awmu; awmv; awmw; awmx; awmy; awmz; awna; awnb; awnc; awnd; awne; awnf; awng; awnh; awni; awnj; awnk; awnl; awnm; awnn; awno; awnp; awnq; awnr; awns; awnt; awnu; awnv; awnw; awnx; awny; awnz; awoa; awob; awoc; awod; awoe; awof; awog; awoh; awoi; awoj; awok; awol; awom; awon; awoo; awop; awoq; awor; awos; awot; awou; awov; awow; awox; awoy; awoz; awpa; awpb; awpc; awpd; awpe; awpf; awpg; awph; awpi; awpj; awpk; awpl; awpm; awpn; awpo; awpp; awpq; awpr; awps; awpt; awpu; awpv; awpw; awpx; awpy; awpz; awqa; awqb; awqc; awqd; awqe; awqf; awqg; awqh; awqi; awqj; awqk; awql; awqm; awqn; awqo; awqp; awqq; awqr; awqs; awqt; awqu; awqv; awqw; awqx; awqy; awqz; awra; awrb; awrc; awrd; awre; awrf; awrg; awrh; awri; awrj; awrk; awrl; awrm; awrn; awro; awrp; awrq; awrr; awrs; awrt; awru; awrv; awrw; awrx; awry; awrz; awsa; awsb; awsc; awsd; awse; awsf; awsg; awsh; awsi; awsj; awsk; awsl; awsm; awsn; awso; awsp; awsq; awsr; awss; awst; awsu; awsv; awsw; awsx; awsy; awsz; awta; awtb; awtc; awtd; awte; awtf; awtg; awth; awti; awtj; awtk; awtl; awtm; awtn; awto; awtp; awtq; awtr; awts; awtt; awtu; awtv; awtw; awtx; awty; awtz; awua; awub; awuc; awud; awue; awuf; awug; awuh; awui; awuj; awuk; awul; awum; awun; awuo; awup; awuq; awur; awus; awut; awuu; awuv; awuw; awux; awuy; awuz; awva; awvb; awvc; awvd; awve; awvf; awvg; awvh; awvi; awvj; awvk; awvl; awvm; awvn; awvo; awvp; awvq; awvr; awvs; awvt; awvu; awvv; awvw; awvx; awvy; awvz; awwa; awwb; awwc; awwd; awwe; awwf; awwg; awwh; awwi; awwj; awwk; awwl; awwm; awwn; awwo; awwp; awwq; awwr; awws; awwt; awwu; awwv; awww; awwx; awwy; awwz; awxa; awxb; awxc; awxd; awxe; awxf; awxg; awxh; awxi; awxj; awxk; awxl; awxm; awxn; awxo; awxp; awxq; awxr; awxs; awxt; awxu; awxv; awxw; awxx; awxy; awxz; awya; awyb; awyc; awyd; awye; awyf; awyg; awyh; awyi; awyj; awyk; awyl; awym; awyn; awyo; awyp; awyq; awyr; awys; awyt; awyu; awyv; awyw; awyx; awyy; awyz; awza; awzb; awzc; awzd; awze; awzf; awzg; awzh; awzi; awzj; awzk; awzl; awzm; awzn; awzo; awzp; awzq; awzr; awzs; awzt; awzu; awzv; awzw; awzx; awzy; awzz; axaa; axab; axac; axad; axae; axaf; axag; axah; axai; axaj; axak; axal; axam; axan; axao; axap; axaq; axar; axas; axat; axau; axav; axaw; axax; axay; axaz; axba; axbb; axbc; axbd; axbe; axbf; axbg; axbh; axbi; axbj; axbk; axbl; axbm; axbn; axbo; axbp; axbq; axbr; axbs; axbt; axbu; axbv; axbw; axbx; axby; axbz; axca; axcb; axcc; axcd; axce; axcf; axcg; axch; axci; axcj; axck; axcl; axcm; axcn; axco; axcp; axcq; axcr; axcs; axct; axcu; axcv; axcw; axcx; axcy; axcz; axda; axdb; axdc; axdd; axde; axdf; axdg; axdh; axdi; axdj; axdk; axdl; axdm; axdn; axdo; axdp; axdq; axdr; axds; axdt; axdu; axdv; axdw; axdx; axdy; axdz; axea; axeb; axec; axed; axee; axef; axeg; axeh; axei; axej; axek; axel; axem; axen; axeo; axep; axeq; axer; axes; axet; axeu; axev; axew; axex; axey; axez; axfa; axfb; axfc; axfd; axfe; axff; axfg; axfh; axfi; axfj; axfk; axfl; axfm; axfn; axfo; axfp; axfq; axfr; axfs; axft; axfu; axfv; axfw; axfx; axfy; axfz; axga; axgb; axgc; axgd; axge; axgf; axgg; axgh; axgi; axgj; axgk; axgl; axgm; axgn; axgo; axgp; axgq; axgr; axgs; axgt; axgu; axgv; axgw; axgx; axgy; axgz; axha; axhb; axhc; axhd; axhe; axhf; axhg; axhh; axhi; axhj; axhk; axhl; axhm; axhn; axho; axhp; axhq; axhr; axhs; axht; axhu; axhv; axhw; axhx; axhy; axhz; axia; axib; axic; axid; axie; axif; axig; axih; axii; axij; axik; axil; axim; axin; axio; axip; axiq; axir; axis; axit; axiu; axiv; axiw; axix; axiy; axiz; axja; axjb; axjc; axjd; axje; axjf; axjg; axjh; axji; axjj; axjk; axjl; axjm; axjn; axjo; axjp; axjq; axjr; axjs; axjt; axju; axjv; axjw; axjx; axjy; axjz; axka; axkb; axkc; axkd; axke; axkf; axkg; axkh; axki; axkj; axkk; axkl; axkm; axkn; axko; axkp; axkq; axkr; axks; axkt; axku; axkv; axkw; axkx; axky; axkz; axla; axlb; axlc; axld; axle; axlf; axlg; axlh; axli; axlj; axlk; axll; axlm; axln; axlo; axlp; axlq; axlr; axls; axlt; axlu; axlv; axlw; axlx; axly; axlz; axma; axmb; axmc; axmd; axme; axmf; axmg; axmh; axmi; axmj; axmk; axml; axmm; axmn; axmo; axmp; axmq; axmr; axms; axmt; axmu; axmv; axmw; axmx; axmy; axmz; axna; axnb; axnc; axnd; axne; axnf; axng; axnh; axni; axnj; axnk; axnl; axnm; axnn; axno; axnp; axnq; axnr; axns; axnt; axnu; axnv; axnw; axnx; axny; axnz; axoa; axob; axoc; axod; axoe; axof; axog; axoh; axoi; axoj; axok; axol; axom; axon; axoo; axop; axoq; axor; axos; axot; axou; axov; axow; axox; axoy; axoz; axpa; axpb; axpc; axpd; axpe; axpf; axpg; axph; axpi; axpj; axpk; axpl; axpm; axpn; axpo; axpp; axpq; axpr; axps; axpt; axpu; axpv; axpw; axpx; axpy; axpz; axqa; axqb; axqc; axqd; axqe; axqf; axqg; axqh; axqi; axqj; axqk; axql; axqm; axqn; axqo; axqp; axqq; axqr; axqs; axqt; axqu; axqv; axqw; axqx; axqy; axqz; axra; axrb; axrc; axrd; axre; axrf; axrg; axrh; axri; axrj; axrk; axrl; axrm; axrn; axro; axrp; axrq; axrr; axrs; axrt; axru; axrv; axrw; axrx; axry; axrz; axsa; axsb; axsc; axsd; axse; axsf; axsg; axsh; axsi; axsj; axsk; axsl; axsm; axsn; axso; axsp; axsq; axsr; axss; axst; axsu; axsv; axsw; axsx; axsy; axsz; axta; axtb; axtc; axtd; axte; axtf; axtg; axth; axti; axtj; axtk; axtl; axtm; axtn; axto; axtp; axtq; axtr; axts; axtt; axtu; axtv; axtw; axtx; axty; axtz; axua; axub; axuc; axud; axue; axuf; axug; axuh; axui; axuj; axuk; axul; axum; axun; axuo; axup; axuq; axur; axus; axut; axuu; axuv; axuw; axux; axuy; axuz; axva; axvb; axvc; axvd; axve; axvf; axvg; axvh; axvi; axvj; axvk; axvl; axvm; axvn; axvo; axvp; axvq; axvr; axvs; axvt; axvu; axvv; axvw; axvx; axvy; axvz; axwa; axwb; axwc; axwd; axwe; axwf; axwg; axwh; axwi; axwj; axwk; axwl; axwm; axwn; axwo; axwp; axwq; axwr; axws; axwt; axwu; axwv; axww; axwx; axwy; axwz; axxa; axxb; axxc; axxd; axxe; axxf; axxg; axxh; axxi; axxj; axxk; axxl; axxm; axxn; axxo; axxp; axxq; axxr; axxs; axxt; axxu; axxv; axxw; axxx; axxy; axxz; axya; axyb; axyc; axyd; axye; axyf; axyg; axyh; axyi; axyj; axyk; axyl; axym; axyn; axyo; axyp; axyq; axyr; axys; axyt; axyu; axyv; axyw; axyx; axyy; axyz; axza; axzb; axzc; axzd; axze; axzf; axzg; axzh; axzi; axzj; axzk; axzl; axzm; axzn; axzo; axzp; axzq; axzr; axzs; axzt; axzu; axzv; axzw; axzx; axzy; axzz; ayaa; ayab; ayac; ayad; ayae; ayaf; ayag; ayah; ayai; ayaj; ayak; ayal; ayam; ayan; ayao; ayap; ayaq; ayar; ayas; ayat; ayau; ayav; ayaw; ayax; ayay; ayaz; ayba; aybb; aybc; aybd; aybe; aybf; aybg; aybh; aybi; aybj; aybk; aybl; aybm; aybn; aybo; aybp; aybq; aybr; aybs; aybt; aybu; aybv; aybw; aybx; ayby; aybz; ayca; aycb; aycc; aycd; ayce; aycf; aycg; aych; ayci; aycj; ayck; aycl; aycm; aycn; ayco; aycp; aycq; aycr; aycs; ayct; aycu; aycv; aycw; aycx; aycy; aycz; ayda; aydb; aydc; aydd; ayde; aydf; aydg; aydh; aydi; aydj; aydk; aydl; aydm; aydn; aydo; aydp; aydq; aydr; ayds; aydt; aydu; aydv; aydw; aydx; aydy; aydz; ayea; ayeb; ayec; ayed; ayee; ayef; ayeg; ayeh; ayei; ayej; ayek; ayel; ayem; ayen; ayeo; ayep; ayeq; ayer; ayes; ayet; ayeu; ayev; ayew; ayex; ayey; ayez; ayfa; ayfb; ayfc; ayfd; ayfe; ayff; ayfg; ayfh; ayfi; ayfj; ayfk; ayfl; ayfm; ayfn; ayfo; ayfp; ayfq; ayfr; ayfs; ayft; ayfu; ayfv; ayfw; ayfx; ayfy; ayfz; ayga; aygb; aygc; aygd; ayge; aygf; aygg; aygh; aygi; aygj; aygk; aygl; aygm; aygn; aygo; aygp; aygq; aygr; aygs; aygt; aygu; aygv; aygw; aygx; aygy; aygz; ayha; ayhb; ayhc; ayhd; ayhe; ayhf; ayhg; ayhh; ayhi; ayhj; ayhk; ayhl; ayhm; ayhn; ayho; ayhp; ayhq; ayhr; ayhs; ayht; ayhu; ayhv; ayhw; ayhx; ayhy; ayhz; ayia; ayib; ayic; ayid; ayie; ayif; ayig; ayih; ayii; ayij; ayik; ayil; ayim; ayin; ayio; ayip; ayiq; ayir; ayis; ayit; ayiu; ayiv; ayiw; ayix; ayiy; ayiz; ayja; ayjb; ayjc; ayjd; ayje; ayjf; ayjg; ayjh; ayji; ayjj; ayjk; ayjl; ayjm; ayjn; ayjo; ayjp; ayjq; ayjr; ayjs; ayjt; ayju; ayjv; ayjw; ayjx; ayjy; ayjz; ayka; aykb; aykc; aykd; ayke; aykf; aykg; aykh; ayki; aykj; aykk; aykl; aykm; aykn; ayko; aykp; aykq; aykr; ayks; aykt; ayku; aykv; aykw; aykx; ayky; aykz; ayla; aylb; aylc; ayld; ayle; aylf; aylg; aylh; ayli; aylj; aylk; ayll; aylm; ayln; aylo; aylp; aylq; aylr; ayls; aylt; aylu; aylv; aylw; aylx; ayly; aylz; ayma; aymb; aymc; aymd; ayme; aymf; aymg; aymh; aymi; aymj; aymk; ayml; aymm; aymn; aymo; aymp; aymq; aymr; ayms; aymt; aymu; aymv; aymw; aymx; aymy; aymz; ayna; aynb; aync; aynd; ayne; aynf; ayng; aynh; ayni; aynj; aynk; aynl; aynm; aynn; ayno; aynp; aynq; aynr; ayns; aynt; aynu; aynv; aynw; aynx; ayny; aynz; ayoa; ayob; ayoc; ayod; ayoe; ayof; ayog; ayoh; ayoi; ayoj; ayok; ayol; ayom; ayon; ayoo; ayop; ayoq; ayor; ayos; ayot; ayou; ayov; ayow; ayox; ayoy; ayoz; aypa; aypb; aypc; aypd; aype; aypf; aypg; ayph; aypi; aypj; aypk; aypl; aypm; aypn; aypo; aypp; aypq; aypr; ayps; aypt; aypu; aypv; aypw; aypx; aypy; aypz; ayqa; ayqb; ayqc; ayqd; ayqe; ayqf; ayqg; ayqh; ayqi; ayqj; ayqk; ayql; ayqm; ayqn; ayqo; ayqp; ayqq; ayqr; ayqs; ayqt; ayqu; ayqv; ayqw; ayqx; ayqy; ayqz; ayra; ayrb; ayrc; ayrd; ayre; ayrf; ayrg; ayrh; ayri; ayrj; ayrk; ayrl; ayrm; ayrn; ayro; ayrp; ayrq; ayrr; ayrs; ayrt; ayru; ayrv; ayrw; ayrx; ayry; ayrz; aysa; aysb; aysc; aysd; ayse; aysf; aysg; aysh; aysi; aysj; aysk; aysl; aysm; aysn; ayso; aysp; aysq; aysr; ayss; ayst; aysu; aysv; aysw; aysx; aysy; aysz; ayta; aytb; aytc; aytd; ayte; aytf; aytg; ayth; ayti; aytj; aytk; aytl; aytm; aytn; ayto; aytp; aytq; aytr; ayts; aytt; aytu; aytv; aytw; aytx; ayty; aytz; ayua; ayub; ayuc; ayud; ayue; ayuf; ayug; ayuh; ayui; ayuj; ayuk; ayul; ayum; ayun; ayuo; ayup; ayuq; ayur; ayus; ayut; ayuu; ayuv; ayuw; ayux; ayuy; ayuz; ayva; ayvb; ayvc; ayvd; ayve; ayvf; ayvg; ayvh; ayvi; ayvj; ayvk; ayvl; ayvm; ayvn; ayvo; ayvp; ayvq; ayvr; ayvs; ayvt; ayvu; ayvv; ayvw; ayvx; ayvy; ayvz; aywa; aywb; aywc; aywd; aywe; aywf; aywg; aywh; aywi; aywj; aywk; aywl; aywm; aywn; aywo; aywp; aywq; aywr; ayws; aywt; aywu; aywv; ayww; aywx; aywy; aywz; ayxa; ayxb; ayxc; ayxd; ayxe; ayxf; ayxg; ayxh; ayxi; ayxj; ayxk; ayxl; ayxm; ayxn; ayxo; ayxp; ayxq; ayxr; ayxs; ayxt; ayxu; ayxv; ayxw; ayxx; ayxy; ayxz; ayya; ayyb; ayyc; ayyd; ayye; ayyf; ayyg; ayyh; ayyi; ayyj; ayyk; ayyl; ayym; ayyn; ayyo; ayyp; ayyq; ayyr; ayys; ayyt; ayyu; ayyv; ayyw; ayyx; ayyy; ayyz; ayza; ayzb; ayzc; ayzd; ayze; ayzf; ayzg; ayzh; ayzi; ayzj; ayzk; ayzl; ayzm; ayzn; ayzo; ayzp; ayzq; ayzr; ayzs; ayzt; ayzu; ayzv; ayzw; ayzx; ayzy; ayzz; azaa; azab; azac; azad; azae; azaf; azag; azah; azai; azaj; azak; azal; azam; azan; azao; azap; azaq; azar; azas; azat; azau; azav; azaw; azax; azay; azaz; azba; azbb; azbc; azbd; azbe; azbf; azbg; azbh; azbi; azbj; azbk; azbl; azbm; azbn; azbo; azbp; azbq; azbr; azbs; azbt; azbu; azbv; azbw; azbx; azby; azbz; azca; azcb; azcc; azcd; azce; azcf; azcg; azch; azci; azcj; azck; azcl; azcm; azcn; azco; azcp; azcq; azcr; azcs; azct; azcu; azcv; azcw; azcx; azcy; azcz; azda; azdb; azdc; azdd; azde; azdf; azdg; azdh; azdi; azdj; azdk; azdl; azdm; azdn; azdo; azdp; azdq; azdr; azds; azdt; azdu; azdv; azdw; azdx; azdy; azdz; azea; azeb; azec; azed; azee; azef; azeg; azeh; azei; azej; azek; azel; azem; azen; azeo; azep; azeq; azer; azes; azet; azeu; azev; azew; azex; azey; azez; azfa; azfb; azfc; azfd; azfe; azff; azfg; azfh; azfi; azfj; azfk; azfl; azfm; azfn; azfo; azfp; azfq; azfr; azfs; azft; azfu; azfv; azfw; azfx; azfy; azfz; azga; azgb; azgc; azgd; azge; azgf; azgg; azgh; azgi; azgj; azgk; azgl; azgm; azgn; azgo; azgp; azgq; azgr; azgs; azgt; azgu; azgv; azgw; azgx; azgy; azgz; azha; azhb; azhc; azhd; azhe; azhf; azhg; azhh; azhi; azhj; azhk; azhl; azhm; azhn; azho; azhp; azhq; azhr; azhs; azht; azhu; azhv; azhw; azhx; azhy; azhz; azia; azib; azic; azid; azie; azif; azig; azih; azii; azij; azik; azil; azim; azin; azio; azip; aziq; azir; azis; azit; aziu; aziv; aziw; azix; aziy; aziz; azja; azjb; azjc; azjd; azje; azjf; azjg; azjh; azji; azjj; azjk; azjl; azjm; azjn; azjo; azjp; azjq; azjr; azjs; azjt; azju; azjv; azjw; azjx; azjy; azjz; azka; azkb; azkc; azkd; azke; azkf; azkg; azkh; azki; azkj; azkk; azkl; azkm; azkn; azko; azkp; azkq; azkr; azks; azkt; azku; azkv; azkw; azkx; azky; azkz; azla; azlb; azlc; azld; azle; azlf; azlg; azlh; azli; azlj; azlk; azll; azlm; azln; azlo; azlp; azlq; azlr; azls; azlt; azlu; azlv; azlw; azlx; azly; azlz; azma; azmb; azmc; azmd; azme; azmf; azmg; azmh; azmi; azmj; azmk; azml; azmm; azmn; azmo; azmp; azmq; azmr; azms; azmt; azmu; azmv; azmw; azmx; azmy; azmz; azna; aznb; aznc; aznd; azne; aznf; azng; aznh; azni; aznj; aznk; aznl; aznm; aznn; azno; aznp; aznq; aznr; azns; aznt; aznu; aznv; aznw; aznx; azny; aznz; azoa; azob; azoc; azod; azoe; azof; azog; azoh; azoi; azoj; azok; azol; azom; azon; azoo; azop; azoq; azor; azos; azot; azou; azov; azow; azox; azoy; azoz; azpa; azpb; azpc; azpd; azpe; azpf; azpg; azph; azpi; azpj; azpk; azpl; azpm; azpn; azpo; azpp; azpq; azpr; azps; azpt; azpu; azpv; azpw; azpx; azpy; azpz; azqa; azqb; azqc; azqd; azqe; azqf; azqg; azqh; azqi; azqj; azqk; azql; azqm; azqn; azqo; azqp; azqq; azqr; azqs; azqt; azqu; azqv; azqw; azqx; azqy; azqz; azra; azrb; azrc; azrd; azre; azrf; azrg; azrh; azri; azrj; azrk; azrl; azrm; azrn; azro; azrp; azrq; azrr; azrs; azrt; azru; azrv; azrw; azrx; azry; azrz; azsa; azsb; azsc; azsd; azse; azsf; azsg; azsh; azsi; azsj; azsk; azsl; azsm; azsn; azso; azsp; azsq; azsr; azss; azst; azsu; azsv; azsw; azsx; azsy; azsz; azta; aztb; aztc; aztd; azte; aztf; aztg; azth; azti; aztj; aztk; aztl; aztm; aztn; azto; aztp; aztq; aztr; azts; aztt; aztu; aztv; aztw; aztx; azty; aztz; azua; azub; azuc; azud; azue; azuf; azug; azuh; azui; azuj; azuk; azul; azum; azun; azuo; azup; azuq; azur; azus; azut; azuu; azuv; azuw; azux; azuy; azuz; azva; azvb; azvc; azvd; azve; azvf; azvg; azvh; azvi; azvj; azvk; azvl; azvm; azvn; azvo; azvp; azvq; azvr; azvs; azvt; azvu; azvv; azvw; azvx; azvy; azvz; azwa; azwb; azwc; azwd; azwe; azwf; azwg; azwh; azwi; azwj; azwk; azwl; azwm; azwn; azwo; azwp; azwq; azwr; azws; azwt; azwu; azwv; azww; azwx; azwy; azwz; azxa; azxb; azxc; azxd; azxe; azxf; azxg; azxh; azxi; azxj; azxk; azxl; azxm; azxn; azxo; azxp; azxq; azxr; azxs; azxt; azxu; azxv; azxw; azxx; azxy; azxz; azya; azyb; azyc; azyd; azye; azyf; azyg; azyh; azyi; azyj; azyk; azyl; azym; azyn; azyo; azyp; azyq; azyr; azys; azyt; azyu; azyv; azyw; azyx; azyy; azyz; azza; azzb; azzc; azzd; azze; azzf; azzg; azzh; azzi; azzj; azzk; azzl; azzm; azzn; azzo; azzp; azzq; azzr; azzs; azzt; azzu; azzv; azzw; azzx; azzy; azzz; baaa; baab; baac; baad; baae; baaf; baag; baah; baai; baaj; baak; baal; baam; baan; baao; baap; baaq; baar; baas; baat; baau; baav; baaw; baax; baay; baaz; baba; babb; babc; babd; babe; babf; babg; babh; babi; babj; babk; babl; babm; babn; babo; babp; babq; babr; babs; babt; babu; babv; babw; babx; baby; babz; baca; bacb; bacc; bacd; bace; bacf; bacg; bach; baci; bacj; back; bacl; bacm; bacn; baco; bacp; bacq; bacr; bacs; bact; bacu; bacv; bacw; bacx; bacy; bacz; bada; badb; badc; badd; bade; badf; badg; badh; badi; badj; badk; badl; badm; badn; bado; badp; badq; badr; bads; badt; badu; badv; badw; badx; bady; badz; baea; baeb; baec; baed; baee; baef; baeg; baeh; baei; baej; baek; bael; baem; baen; baeo; baep; baeq; baer; baes; baet; baeu; baev; baew; baex; baey; baez; bafa; bafb; bafc; bafd; bafe; baff; bafg; bafh; bafi; bafj; bafk; bafl; bafm; bafn; bafo; bafp; bafq; bafr; bafs; baft; bafu; bafv; bafw; bafx; bafy; bafz; baga; bagb; bagc; bagd; bage; bagf; bagg; bagh; bagi; bagj; bagk; bagl; bagm; bagn; bago; bagp; bagq; bagr; bags; bagt; bagu; bagv; bagw; bagx; bagy; bagz; baha; bahb; bahc; bahd; bahe; bahf; bahg; bahh; bahi; bahj; bahk; bahl; bahm; bahn; baho; bahp; bahq; bahr; bahs; baht; bahu; bahv; bahw; bahx; bahy; bahz; baia; baib; baic; baid; baie; baif; baig; baih; baii; baij; baik; bail; baim; bain; baio; baip; baiq; bair; bais; bait; baiu; baiv; baiw; baix; baiy; baiz; baja; bajb; bajc; bajd; baje; bajf; bajg; bajh; baji; bajj; bajk; bajl; bajm; bajn; bajo; bajp; bajq; bajr; bajs; bajt; baju; bajv; bajw; bajx; bajy; bajz; baka; bakb; bakc; bakd; bake; bakf; bakg; bakh; baki; bakj; bakk; bakl; bakm; bakn; bako; bakp; bakq; bakr; baks; bakt; baku; bakv; bakw; bakx; baky; bakz; bala; balb; balc; bald; bale; balf; balg; balh; bali; balj; balk; ball; balm; baln; balo; balp; balq; balr; bals; balt; balu; balv; balw; balx; baly; balz; bama; bamb; bamc; bamd; bame; bamf; bamg; bamh; bami; bamj; bamk; baml; bamm; bamn; bamo; bamp; bamq; bamr; bams; bamt; bamu; bamv; bamw; bamx; bamy; bamz; bana; banb; banc; band; bane; banf; bang; banh; bani; banj; bank; banl; banm; bann; bano; banp; banq; banr; bans; bant; banu; banv; banw; banx; bany; banz; baoa; baob; baoc; baod; baoe; baof; baog; baoh; baoi; baoj; baok; baol; baom; baon; baoo; baop; baoq; baor; baos; baot; baou; baov; baow; baox; baoy; baoz; bapa; bapb; bapc; bapd; bape; bapf; bapg; baph; bapi; bapj; bapk; bapl; bapm; bapn; bapo; bapp; bapq; bapr; baps; bapt; bapu; bapv; bapw; bapx; bapy; bapz; baqa; baqb; baqc; baqd; baqe; baqf; baqg; baqh; baqi; baqj; baqk; baql; baqm; baqn; baqo; baqp; baqq; baqr; baqs; baqt; baqu; baqv; baqw; baqx; baqy; baqz; bara; barb; barc; bard; bare; barf; barg; barh; bari; barj; bark; barl; barm; barn; baro; barp; barq; barr; bars; bart; baru; barv; barw; barx; bary; barz; basa; basb; basc; basd; base; basf; basg; bash; basi; basj; bask; basl; basm; basn; baso; basp; basq; basr; bass; bast; basu; basv; basw; basx; basy; basz; bata; batb; batc; batd; bate; batf; batg; bath; bati; batj; batk; batl; batm; batn; bato; batp; batq; batr; bats; batt; batu; batv; batw; batx; baty; batz; baua; baub; bauc; baud; baue; bauf; baug; bauh; baui; bauj; bauk; baul; baum; baun; bauo; baup; bauq; baur; baus; baut; bauu; bauv; bauw; baux; bauy; bauz; bava; bavb; bavc; bavd; bave; bavf; bavg; bavh; bavi; bavj; bavk; bavl; bavm; bavn; bavo; bavp; bavq; bavr; bavs; bavt; bavu; bavv; bavw; bavx; bavy; bavz; bawa; bawb; bawc; bawd; bawe; bawf; bawg; bawh; bawi; bawj; bawk; bawl; bawm; bawn; bawo; bawp; bawq; bawr; baws; bawt; bawu; bawv; baww; bawx; bawy; bawz; baxa; baxb; baxc; baxd; baxe; baxf; baxg; baxh; baxi; baxj; baxk; baxl; baxm; baxn; baxo; baxp; baxq; baxr; baxs; baxt; baxu; baxv; baxw; baxx; baxy; baxz; baya; bayb; bayc; bayd; baye; bayf; bayg; bayh; bayi; bayj; bayk; bayl; baym; bayn; bayo; bayp; bayq; bayr; bays; bayt; bayu; bayv; bayw; bayx; bayy; bayz; baza; bazb; bazc; bazd; baze; bazf; bazg; bazh; bazi; bazj; bazk; bazl; bazm; bazn; bazo; bazp; bazq; bazr; bazs; bazt; bazu; bazv; bazw; bazx; bazy; bazz; bbaa; bbab; bbac; bbad; bbae; bbaf; bbag; bbah; bbai; bbaj; bbak; bbal; bbam; bban; bbao; bbap; bbaq; bbar; bbas; bbat; bbau; bbav; bbaw; bbax; bbay; bbaz; bbba; bbbb |]; mingw-ocaml/ocaml/camlp4/test/fixtures/string.ml0000644000175000017500000000000712124403240021322 0ustar tootstoots"abc"; mingw-ocaml/ocaml/camlp4/test/fixtures/mod2.ml0000644000175000017500000000025012124403240020655 0ustar tootstootsmodule type S = sig type t = 'a; end; module F (A : S) = struct type t2 = A.t; end; module A = struct type t = int; end; module type S2 = S with type t = (F A).t2; mingw-ocaml/ocaml/camlp4/test/fixtures/where.o.ml0000644000175000017500000000001712124403240021364 0ustar tootstootslet where = 42 mingw-ocaml/ocaml/camlp4/test/fixtures/functor-perf.ml0000644000175000017500000014176112124403240022443 0ustar tootstootsmodule type S = sig (* <%- for i in 0 .. 1000 do -%> val f<%= i %> : int -> int -> int <%- end -%> *) val f0 : int -> int -> int val f1 : int -> int -> int val f2 : int -> int -> int val f3 : int -> int -> int val f4 : int -> int -> int val f5 : int -> int -> int val f6 : int -> int -> int val f7 : int -> int -> int val f8 : int -> int -> int val f9 : int -> int -> int val f10 : int -> int -> int val f11 : int -> int -> int val f12 : int -> int -> int val f13 : int -> int -> int val f14 : int -> int -> int val f15 : int -> int -> int val f16 : int -> int -> int val f17 : int -> int -> int val f18 : int -> int -> int val f19 : int -> int -> int val f20 : int -> int -> int val f21 : int -> int -> int val f22 : int -> int -> int val f23 : int -> int -> int val f24 : int -> int -> int val f25 : int -> int -> int val f26 : int -> int -> int val f27 : int -> int -> int val f28 : int -> int -> int val f29 : int -> int -> int val f30 : int -> int -> int val f31 : int -> int -> int val f32 : int -> int -> int val f33 : int -> int -> int val f34 : int -> int -> int val f35 : int -> int -> int val f36 : int -> int -> int val f37 : int -> int -> int val f38 : int -> int -> int val f39 : int -> int -> int val f40 : int -> int -> int val f41 : int -> int -> int val f42 : int -> int -> int val f43 : int -> int -> int val f44 : int -> int -> int val f45 : int -> int -> int val f46 : int -> int -> int val f47 : int -> int -> int val f48 : int -> int -> int val f49 : int -> int -> int val f50 : int -> int -> int val f51 : int -> int -> int val f52 : int -> int -> int val f53 : int -> int -> int val f54 : int -> int -> int val f55 : int -> int -> int val f56 : int -> int -> int val f57 : int -> int -> int val f58 : int -> int -> int val f59 : int -> int -> int val f60 : int -> int -> int val f61 : int -> int -> int val f62 : int -> int -> int val f63 : int -> int -> int val f64 : int -> int -> int val f65 : int -> int -> int val f66 : int -> int -> int val f67 : int -> int -> int val f68 : int -> int -> int val f69 : int -> int -> int val f70 : int -> int -> int val f71 : int -> int -> int val f72 : int -> int -> int val f73 : int -> int -> int val f74 : int -> int -> int val f75 : int -> int -> int val f76 : int -> int -> int val f77 : int -> int -> int val f78 : int -> int -> int val f79 : int -> int -> int val f80 : int -> int -> int val f81 : int -> int -> int val f82 : int -> int -> int val f83 : int -> int -> int val f84 : int -> int -> int val f85 : int -> int -> int val f86 : int -> int -> int val f87 : int -> int -> int val f88 : int -> int -> int val f89 : int -> int -> int val f90 : int -> int -> int val f91 : int -> int -> int val f92 : int -> int -> int val f93 : int -> int -> int val f94 : int -> int -> int val f95 : int -> int -> int val f96 : int -> int -> int val f97 : int -> int -> int val f98 : int -> int -> int val f99 : int -> int -> int val f100 : int -> int -> int val f101 : int -> int -> int val f102 : int -> int -> int val f103 : int -> int -> int val f104 : int -> int -> int val f105 : int -> int -> int val f106 : int -> int -> int val f107 : int -> int -> int val f108 : int -> int -> int val f109 : int -> int -> int val f110 : int -> int -> int val f111 : int -> int -> int val f112 : int -> int -> int val f113 : int -> int -> int val f114 : int -> int -> int val f115 : int -> int -> int val f116 : int -> int -> int val f117 : int -> int -> int val f118 : int -> int -> int val f119 : int -> int -> int val f120 : int -> int -> int val f121 : int -> int -> int val f122 : int -> int -> int val f123 : int -> int -> int val f124 : int -> int -> int val f125 : int -> int -> int val f126 : int -> int -> int val f127 : int -> int -> int val f128 : int -> int -> int val f129 : int -> int -> int val f130 : int -> int -> int val f131 : int -> int -> int val f132 : int -> int -> int val f133 : int -> int -> int val f134 : int -> int -> int val f135 : int -> int -> int val f136 : int -> int -> int val f137 : int -> int -> int val f138 : int -> int -> int val f139 : int -> int -> int val f140 : int -> int -> int val f141 : int -> int -> int val f142 : int -> int -> int val f143 : int -> int -> int val f144 : int -> int -> int val f145 : int -> int -> int val f146 : int -> int -> int val f147 : int -> int -> int val f148 : int -> int -> int val f149 : int -> int -> int val f150 : int -> int -> int val f151 : int -> int -> int val f152 : int -> int -> int val f153 : int -> int -> int val f154 : int -> int -> int val f155 : int -> int -> int val f156 : int -> int -> int val f157 : int -> int -> int val f158 : int -> int -> int val f159 : int -> int -> int val f160 : int -> int -> int val f161 : int -> int -> int val f162 : int -> int -> int val f163 : int -> int -> int val f164 : int -> int -> int val f165 : int -> int -> int val f166 : int -> int -> int val f167 : int -> int -> int val f168 : int -> int -> int val f169 : int -> int -> int val f170 : int -> int -> int val f171 : int -> int -> int val f172 : int -> int -> int val f173 : int -> int -> int val f174 : int -> int -> int val f175 : int -> int -> int val f176 : int -> int -> int val f177 : int -> int -> int val f178 : int -> int -> int val f179 : int -> int -> int val f180 : int -> int -> int val f181 : int -> int -> int val f182 : int -> int -> int val f183 : int -> int -> int val f184 : int -> int -> int val f185 : int -> int -> int val f186 : int -> int -> int val f187 : int -> int -> int val f188 : int -> int -> int val f189 : int -> int -> int val f190 : int -> int -> int val f191 : int -> int -> int val f192 : int -> int -> int val f193 : int -> int -> int val f194 : int -> int -> int val f195 : int -> int -> int val f196 : int -> int -> int val f197 : int -> int -> int val f198 : int -> int -> int val f199 : int -> int -> int val f200 : int -> int -> int val f201 : int -> int -> int val f202 : int -> int -> int val f203 : int -> int -> int val f204 : int -> int -> int val f205 : int -> int -> int val f206 : int -> int -> int val f207 : int -> int -> int val f208 : int -> int -> int val f209 : int -> int -> int val f210 : int -> int -> int val f211 : int -> int -> int val f212 : int -> int -> int val f213 : int -> int -> int val f214 : int -> int -> int val f215 : int -> int -> int val f216 : int -> int -> int val f217 : int -> int -> int val f218 : int -> int -> int val f219 : int -> int -> int val f220 : int -> int -> int val f221 : int -> int -> int val f222 : int -> int -> int val f223 : int -> int -> int val f224 : int -> int -> int val f225 : int -> int -> int val f226 : int -> int -> int val f227 : int -> int -> int val f228 : int -> int -> int val f229 : int -> int -> int val f230 : int -> int -> int val f231 : int -> int -> int val f232 : int -> int -> int val f233 : int -> int -> int val f234 : int -> int -> int val f235 : int -> int -> int val f236 : int -> int -> int val f237 : int -> int -> int val f238 : int -> int -> int val f239 : int -> int -> int val f240 : int -> int -> int val f241 : int -> int -> int val f242 : int -> int -> int val f243 : int -> int -> int val f244 : int -> int -> int val f245 : int -> int -> int val f246 : int -> int -> int val f247 : int -> int -> int val f248 : int -> int -> int val f249 : int -> int -> int val f250 : int -> int -> int val f251 : int -> int -> int val f252 : int -> int -> int val f253 : int -> int -> int val f254 : int -> int -> int val f255 : int -> int -> int val f256 : int -> int -> int val f257 : int -> int -> int val f258 : int -> int -> int val f259 : int -> int -> int val f260 : int -> int -> int val f261 : int -> int -> int val f262 : int -> int -> int val f263 : int -> int -> int val f264 : int -> int -> int val f265 : int -> int -> int val f266 : int -> int -> int val f267 : int -> int -> int val f268 : int -> int -> int val f269 : int -> int -> int val f270 : int -> int -> int val f271 : int -> int -> int val f272 : int -> int -> int val f273 : int -> int -> int val f274 : int -> int -> int val f275 : int -> int -> int val f276 : int -> int -> int val f277 : int -> int -> int val f278 : int -> int -> int val f279 : int -> int -> int val f280 : int -> int -> int val f281 : int -> int -> int val f282 : int -> int -> int val f283 : int -> int -> int val f284 : int -> int -> int val f285 : int -> int -> int val f286 : int -> int -> int val f287 : int -> int -> int val f288 : int -> int -> int val f289 : int -> int -> int val f290 : int -> int -> int val f291 : int -> int -> int val f292 : int -> int -> int val f293 : int -> int -> int val f294 : int -> int -> int val f295 : int -> int -> int val f296 : int -> int -> int val f297 : int -> int -> int val f298 : int -> int -> int val f299 : int -> int -> int val f300 : int -> int -> int val f301 : int -> int -> int val f302 : int -> int -> int val f303 : int -> int -> int val f304 : int -> int -> int val f305 : int -> int -> int val f306 : int -> int -> int val f307 : int -> int -> int val f308 : int -> int -> int val f309 : int -> int -> int val f310 : int -> int -> int val f311 : int -> int -> int val f312 : int -> int -> int val f313 : int -> int -> int val f314 : int -> int -> int val f315 : int -> int -> int val f316 : int -> int -> int val f317 : int -> int -> int val f318 : int -> int -> int val f319 : int -> int -> int val f320 : int -> int -> int val f321 : int -> int -> int val f322 : int -> int -> int val f323 : int -> int -> int val f324 : int -> int -> int val f325 : int -> int -> int val f326 : int -> int -> int val f327 : int -> int -> int val f328 : int -> int -> int val f329 : int -> int -> int val f330 : int -> int -> int val f331 : int -> int -> int val f332 : int -> int -> int val f333 : int -> int -> int val f334 : int -> int -> int val f335 : int -> int -> int val f336 : int -> int -> int val f337 : int -> int -> int val f338 : int -> int -> int val f339 : int -> int -> int val f340 : int -> int -> int val f341 : int -> int -> int val f342 : int -> int -> int val f343 : int -> int -> int val f344 : int -> int -> int val f345 : int -> int -> int val f346 : int -> int -> int val f347 : int -> int -> int val f348 : int -> int -> int val f349 : int -> int -> int val f350 : int -> int -> int val f351 : int -> int -> int val f352 : int -> int -> int val f353 : int -> int -> int val f354 : int -> int -> int val f355 : int -> int -> int val f356 : int -> int -> int val f357 : int -> int -> int val f358 : int -> int -> int val f359 : int -> int -> int val f360 : int -> int -> int val f361 : int -> int -> int val f362 : int -> int -> int val f363 : int -> int -> int val f364 : int -> int -> int val f365 : int -> int -> int val f366 : int -> int -> int val f367 : int -> int -> int val f368 : int -> int -> int val f369 : int -> int -> int val f370 : int -> int -> int val f371 : int -> int -> int val f372 : int -> int -> int val f373 : int -> int -> int val f374 : int -> int -> int val f375 : int -> int -> int val f376 : int -> int -> int val f377 : int -> int -> int val f378 : int -> int -> int val f379 : int -> int -> int val f380 : int -> int -> int val f381 : int -> int -> int val f382 : int -> int -> int val f383 : int -> int -> int val f384 : int -> int -> int val f385 : int -> int -> int val f386 : int -> int -> int val f387 : int -> int -> int val f388 : int -> int -> int val f389 : int -> int -> int val f390 : int -> int -> int val f391 : int -> int -> int val f392 : int -> int -> int val f393 : int -> int -> int val f394 : int -> int -> int val f395 : int -> int -> int val f396 : int -> int -> int val f397 : int -> int -> int val f398 : int -> int -> int val f399 : int -> int -> int val f400 : int -> int -> int val f401 : int -> int -> int val f402 : int -> int -> int val f403 : int -> int -> int val f404 : int -> int -> int val f405 : int -> int -> int val f406 : int -> int -> int val f407 : int -> int -> int val f408 : int -> int -> int val f409 : int -> int -> int val f410 : int -> int -> int val f411 : int -> int -> int val f412 : int -> int -> int val f413 : int -> int -> int val f414 : int -> int -> int val f415 : int -> int -> int val f416 : int -> int -> int val f417 : int -> int -> int val f418 : int -> int -> int val f419 : int -> int -> int val f420 : int -> int -> int val f421 : int -> int -> int val f422 : int -> int -> int val f423 : int -> int -> int val f424 : int -> int -> int val f425 : int -> int -> int val f426 : int -> int -> int val f427 : int -> int -> int val f428 : int -> int -> int val f429 : int -> int -> int val f430 : int -> int -> int val f431 : int -> int -> int val f432 : int -> int -> int val f433 : int -> int -> int val f434 : int -> int -> int val f435 : int -> int -> int val f436 : int -> int -> int val f437 : int -> int -> int val f438 : int -> int -> int val f439 : int -> int -> int val f440 : int -> int -> int val f441 : int -> int -> int val f442 : int -> int -> int val f443 : int -> int -> int val f444 : int -> int -> int val f445 : int -> int -> int val f446 : int -> int -> int val f447 : int -> int -> int val f448 : int -> int -> int val f449 : int -> int -> int val f450 : int -> int -> int val f451 : int -> int -> int val f452 : int -> int -> int val f453 : int -> int -> int val f454 : int -> int -> int val f455 : int -> int -> int val f456 : int -> int -> int val f457 : int -> int -> int val f458 : int -> int -> int val f459 : int -> int -> int val f460 : int -> int -> int val f461 : int -> int -> int val f462 : int -> int -> int val f463 : int -> int -> int val f464 : int -> int -> int val f465 : int -> int -> int val f466 : int -> int -> int val f467 : int -> int -> int val f468 : int -> int -> int val f469 : int -> int -> int val f470 : int -> int -> int val f471 : int -> int -> int val f472 : int -> int -> int val f473 : int -> int -> int val f474 : int -> int -> int val f475 : int -> int -> int val f476 : int -> int -> int val f477 : int -> int -> int val f478 : int -> int -> int val f479 : int -> int -> int val f480 : int -> int -> int val f481 : int -> int -> int val f482 : int -> int -> int val f483 : int -> int -> int val f484 : int -> int -> int val f485 : int -> int -> int val f486 : int -> int -> int val f487 : int -> int -> int val f488 : int -> int -> int val f489 : int -> int -> int val f490 : int -> int -> int val f491 : int -> int -> int val f492 : int -> int -> int val f493 : int -> int -> int val f494 : int -> int -> int val f495 : int -> int -> int val f496 : int -> int -> int val f497 : int -> int -> int val f498 : int -> int -> int val f499 : int -> int -> int val f500 : int -> int -> int val f501 : int -> int -> int val f502 : int -> int -> int val f503 : int -> int -> int val f504 : int -> int -> int val f505 : int -> int -> int val f506 : int -> int -> int val f507 : int -> int -> int val f508 : int -> int -> int val f509 : int -> int -> int val f510 : int -> int -> int val f511 : int -> int -> int val f512 : int -> int -> int val f513 : int -> int -> int val f514 : int -> int -> int val f515 : int -> int -> int val f516 : int -> int -> int val f517 : int -> int -> int val f518 : int -> int -> int val f519 : int -> int -> int val f520 : int -> int -> int val f521 : int -> int -> int val f522 : int -> int -> int val f523 : int -> int -> int val f524 : int -> int -> int val f525 : int -> int -> int val f526 : int -> int -> int val f527 : int -> int -> int val f528 : int -> int -> int val f529 : int -> int -> int val f530 : int -> int -> int val f531 : int -> int -> int val f532 : int -> int -> int val f533 : int -> int -> int val f534 : int -> int -> int val f535 : int -> int -> int val f536 : int -> int -> int val f537 : int -> int -> int val f538 : int -> int -> int val f539 : int -> int -> int val f540 : int -> int -> int val f541 : int -> int -> int val f542 : int -> int -> int val f543 : int -> int -> int val f544 : int -> int -> int val f545 : int -> int -> int val f546 : int -> int -> int val f547 : int -> int -> int val f548 : int -> int -> int val f549 : int -> int -> int val f550 : int -> int -> int val f551 : int -> int -> int val f552 : int -> int -> int val f553 : int -> int -> int val f554 : int -> int -> int val f555 : int -> int -> int val f556 : int -> int -> int val f557 : int -> int -> int val f558 : int -> int -> int val f559 : int -> int -> int val f560 : int -> int -> int val f561 : int -> int -> int val f562 : int -> int -> int val f563 : int -> int -> int val f564 : int -> int -> int val f565 : int -> int -> int val f566 : int -> int -> int val f567 : int -> int -> int val f568 : int -> int -> int val f569 : int -> int -> int val f570 : int -> int -> int val f571 : int -> int -> int val f572 : int -> int -> int val f573 : int -> int -> int val f574 : int -> int -> int val f575 : int -> int -> int val f576 : int -> int -> int val f577 : int -> int -> int val f578 : int -> int -> int val f579 : int -> int -> int val f580 : int -> int -> int val f581 : int -> int -> int val f582 : int -> int -> int val f583 : int -> int -> int val f584 : int -> int -> int val f585 : int -> int -> int val f586 : int -> int -> int val f587 : int -> int -> int val f588 : int -> int -> int val f589 : int -> int -> int val f590 : int -> int -> int val f591 : int -> int -> int val f592 : int -> int -> int val f593 : int -> int -> int val f594 : int -> int -> int val f595 : int -> int -> int val f596 : int -> int -> int val f597 : int -> int -> int val f598 : int -> int -> int val f599 : int -> int -> int val f600 : int -> int -> int val f601 : int -> int -> int val f602 : int -> int -> int val f603 : int -> int -> int val f604 : int -> int -> int val f605 : int -> int -> int val f606 : int -> int -> int val f607 : int -> int -> int val f608 : int -> int -> int val f609 : int -> int -> int val f610 : int -> int -> int val f611 : int -> int -> int val f612 : int -> int -> int val f613 : int -> int -> int val f614 : int -> int -> int val f615 : int -> int -> int val f616 : int -> int -> int val f617 : int -> int -> int val f618 : int -> int -> int val f619 : int -> int -> int val f620 : int -> int -> int val f621 : int -> int -> int val f622 : int -> int -> int val f623 : int -> int -> int val f624 : int -> int -> int val f625 : int -> int -> int val f626 : int -> int -> int val f627 : int -> int -> int val f628 : int -> int -> int val f629 : int -> int -> int val f630 : int -> int -> int val f631 : int -> int -> int val f632 : int -> int -> int val f633 : int -> int -> int val f634 : int -> int -> int val f635 : int -> int -> int val f636 : int -> int -> int val f637 : int -> int -> int val f638 : int -> int -> int val f639 : int -> int -> int val f640 : int -> int -> int val f641 : int -> int -> int val f642 : int -> int -> int val f643 : int -> int -> int val f644 : int -> int -> int val f645 : int -> int -> int val f646 : int -> int -> int val f647 : int -> int -> int val f648 : int -> int -> int val f649 : int -> int -> int val f650 : int -> int -> int val f651 : int -> int -> int val f652 : int -> int -> int val f653 : int -> int -> int val f654 : int -> int -> int val f655 : int -> int -> int val f656 : int -> int -> int val f657 : int -> int -> int val f658 : int -> int -> int val f659 : int -> int -> int val f660 : int -> int -> int val f661 : int -> int -> int val f662 : int -> int -> int val f663 : int -> int -> int val f664 : int -> int -> int val f665 : int -> int -> int val f666 : int -> int -> int val f667 : int -> int -> int val f668 : int -> int -> int val f669 : int -> int -> int val f670 : int -> int -> int val f671 : int -> int -> int val f672 : int -> int -> int val f673 : int -> int -> int val f674 : int -> int -> int val f675 : int -> int -> int val f676 : int -> int -> int val f677 : int -> int -> int val f678 : int -> int -> int val f679 : int -> int -> int val f680 : int -> int -> int val f681 : int -> int -> int val f682 : int -> int -> int val f683 : int -> int -> int val f684 : int -> int -> int val f685 : int -> int -> int val f686 : int -> int -> int val f687 : int -> int -> int val f688 : int -> int -> int val f689 : int -> int -> int val f690 : int -> int -> int val f691 : int -> int -> int val f692 : int -> int -> int val f693 : int -> int -> int val f694 : int -> int -> int val f695 : int -> int -> int val f696 : int -> int -> int val f697 : int -> int -> int val f698 : int -> int -> int val f699 : int -> int -> int val f700 : int -> int -> int val f701 : int -> int -> int val f702 : int -> int -> int val f703 : int -> int -> int val f704 : int -> int -> int val f705 : int -> int -> int val f706 : int -> int -> int val f707 : int -> int -> int val f708 : int -> int -> int val f709 : int -> int -> int val f710 : int -> int -> int val f711 : int -> int -> int val f712 : int -> int -> int val f713 : int -> int -> int val f714 : int -> int -> int val f715 : int -> int -> int val f716 : int -> int -> int val f717 : int -> int -> int val f718 : int -> int -> int val f719 : int -> int -> int val f720 : int -> int -> int val f721 : int -> int -> int val f722 : int -> int -> int val f723 : int -> int -> int val f724 : int -> int -> int val f725 : int -> int -> int val f726 : int -> int -> int val f727 : int -> int -> int val f728 : int -> int -> int val f729 : int -> int -> int val f730 : int -> int -> int val f731 : int -> int -> int val f732 : int -> int -> int val f733 : int -> int -> int val f734 : int -> int -> int val f735 : int -> int -> int val f736 : int -> int -> int val f737 : int -> int -> int val f738 : int -> int -> int val f739 : int -> int -> int val f740 : int -> int -> int val f741 : int -> int -> int val f742 : int -> int -> int val f743 : int -> int -> int val f744 : int -> int -> int val f745 : int -> int -> int val f746 : int -> int -> int val f747 : int -> int -> int val f748 : int -> int -> int val f749 : int -> int -> int val f750 : int -> int -> int val f751 : int -> int -> int val f752 : int -> int -> int val f753 : int -> int -> int val f754 : int -> int -> int val f755 : int -> int -> int val f756 : int -> int -> int val f757 : int -> int -> int val f758 : int -> int -> int val f759 : int -> int -> int val f760 : int -> int -> int val f761 : int -> int -> int val f762 : int -> int -> int val f763 : int -> int -> int val f764 : int -> int -> int val f765 : int -> int -> int val f766 : int -> int -> int val f767 : int -> int -> int val f768 : int -> int -> int val f769 : int -> int -> int val f770 : int -> int -> int val f771 : int -> int -> int val f772 : int -> int -> int val f773 : int -> int -> int val f774 : int -> int -> int val f775 : int -> int -> int val f776 : int -> int -> int val f777 : int -> int -> int val f778 : int -> int -> int val f779 : int -> int -> int val f780 : int -> int -> int val f781 : int -> int -> int val f782 : int -> int -> int val f783 : int -> int -> int val f784 : int -> int -> int val f785 : int -> int -> int val f786 : int -> int -> int val f787 : int -> int -> int val f788 : int -> int -> int val f789 : int -> int -> int val f790 : int -> int -> int val f791 : int -> int -> int val f792 : int -> int -> int val f793 : int -> int -> int val f794 : int -> int -> int val f795 : int -> int -> int val f796 : int -> int -> int val f797 : int -> int -> int val f798 : int -> int -> int val f799 : int -> int -> int val f800 : int -> int -> int val f801 : int -> int -> int val f802 : int -> int -> int val f803 : int -> int -> int val f804 : int -> int -> int val f805 : int -> int -> int val f806 : int -> int -> int val f807 : int -> int -> int val f808 : int -> int -> int val f809 : int -> int -> int val f810 : int -> int -> int val f811 : int -> int -> int val f812 : int -> int -> int val f813 : int -> int -> int val f814 : int -> int -> int val f815 : int -> int -> int val f816 : int -> int -> int val f817 : int -> int -> int val f818 : int -> int -> int val f819 : int -> int -> int val f820 : int -> int -> int val f821 : int -> int -> int val f822 : int -> int -> int val f823 : int -> int -> int val f824 : int -> int -> int val f825 : int -> int -> int val f826 : int -> int -> int val f827 : int -> int -> int val f828 : int -> int -> int val f829 : int -> int -> int val f830 : int -> int -> int val f831 : int -> int -> int val f832 : int -> int -> int val f833 : int -> int -> int val f834 : int -> int -> int val f835 : int -> int -> int val f836 : int -> int -> int val f837 : int -> int -> int val f838 : int -> int -> int val f839 : int -> int -> int val f840 : int -> int -> int val f841 : int -> int -> int val f842 : int -> int -> int val f843 : int -> int -> int val f844 : int -> int -> int val f845 : int -> int -> int val f846 : int -> int -> int val f847 : int -> int -> int val f848 : int -> int -> int val f849 : int -> int -> int val f850 : int -> int -> int val f851 : int -> int -> int val f852 : int -> int -> int val f853 : int -> int -> int val f854 : int -> int -> int val f855 : int -> int -> int val f856 : int -> int -> int val f857 : int -> int -> int val f858 : int -> int -> int val f859 : int -> int -> int val f860 : int -> int -> int val f861 : int -> int -> int val f862 : int -> int -> int val f863 : int -> int -> int val f864 : int -> int -> int val f865 : int -> int -> int val f866 : int -> int -> int val f867 : int -> int -> int val f868 : int -> int -> int val f869 : int -> int -> int val f870 : int -> int -> int val f871 : int -> int -> int val f872 : int -> int -> int val f873 : int -> int -> int val f874 : int -> int -> int val f875 : int -> int -> int val f876 : int -> int -> int val f877 : int -> int -> int val f878 : int -> int -> int val f879 : int -> int -> int val f880 : int -> int -> int val f881 : int -> int -> int val f882 : int -> int -> int val f883 : int -> int -> int val f884 : int -> int -> int val f885 : int -> int -> int val f886 : int -> int -> int val f887 : int -> int -> int val f888 : int -> int -> int val f889 : int -> int -> int val f890 : int -> int -> int val f891 : int -> int -> int val f892 : int -> int -> int val f893 : int -> int -> int val f894 : int -> int -> int val f895 : int -> int -> int val f896 : int -> int -> int val f897 : int -> int -> int val f898 : int -> int -> int val f899 : int -> int -> int val f900 : int -> int -> int val f901 : int -> int -> int val f902 : int -> int -> int val f903 : int -> int -> int val f904 : int -> int -> int val f905 : int -> int -> int val f906 : int -> int -> int val f907 : int -> int -> int val f908 : int -> int -> int val f909 : int -> int -> int val f910 : int -> int -> int val f911 : int -> int -> int val f912 : int -> int -> int val f913 : int -> int -> int val f914 : int -> int -> int val f915 : int -> int -> int val f916 : int -> int -> int val f917 : int -> int -> int val f918 : int -> int -> int val f919 : int -> int -> int val f920 : int -> int -> int val f921 : int -> int -> int val f922 : int -> int -> int val f923 : int -> int -> int val f924 : int -> int -> int val f925 : int -> int -> int val f926 : int -> int -> int val f927 : int -> int -> int val f928 : int -> int -> int val f929 : int -> int -> int val f930 : int -> int -> int val f931 : int -> int -> int val f932 : int -> int -> int val f933 : int -> int -> int val f934 : int -> int -> int val f935 : int -> int -> int val f936 : int -> int -> int val f937 : int -> int -> int val f938 : int -> int -> int val f939 : int -> int -> int val f940 : int -> int -> int val f941 : int -> int -> int val f942 : int -> int -> int val f943 : int -> int -> int val f944 : int -> int -> int val f945 : int -> int -> int val f946 : int -> int -> int val f947 : int -> int -> int val f948 : int -> int -> int val f949 : int -> int -> int val f950 : int -> int -> int val f951 : int -> int -> int val f952 : int -> int -> int val f953 : int -> int -> int val f954 : int -> int -> int val f955 : int -> int -> int val f956 : int -> int -> int val f957 : int -> int -> int val f958 : int -> int -> int val f959 : int -> int -> int val f960 : int -> int -> int val f961 : int -> int -> int val f962 : int -> int -> int val f963 : int -> int -> int val f964 : int -> int -> int val f965 : int -> int -> int val f966 : int -> int -> int val f967 : int -> int -> int val f968 : int -> int -> int val f969 : int -> int -> int val f970 : int -> int -> int val f971 : int -> int -> int val f972 : int -> int -> int val f973 : int -> int -> int val f974 : int -> int -> int val f975 : int -> int -> int val f976 : int -> int -> int val f977 : int -> int -> int val f978 : int -> int -> int val f979 : int -> int -> int val f980 : int -> int -> int val f981 : int -> int -> int val f982 : int -> int -> int val f983 : int -> int -> int val f984 : int -> int -> int val f985 : int -> int -> int val f986 : int -> int -> int val f987 : int -> int -> int val f988 : int -> int -> int val f989 : int -> int -> int val f990 : int -> int -> int val f991 : int -> int -> int val f992 : int -> int -> int val f993 : int -> int -> int val f994 : int -> int -> int val f995 : int -> int -> int val f996 : int -> int -> int val f997 : int -> int -> int val f998 : int -> int -> int val f999 : int -> int -> int val f1000 : int -> int -> int end module Make (M : S) = struct include M end module M = struct (* <%- for i in 0 .. 1000 do -%> let f<%= i %> = ( + ) <%- end -%> *) let f0 = ( + ) let f1 = ( + ) let f2 = ( + ) let f3 = ( + ) let f4 = ( + ) let f5 = ( + ) let f6 = ( + ) let f7 = ( + ) let f8 = ( + ) let f9 = ( + ) let f10 = ( + ) let f11 = ( + ) let f12 = ( + ) let f13 = ( + ) let f14 = ( + ) let f15 = ( + ) let f16 = ( + ) let f17 = ( + ) let f18 = ( + ) let f19 = ( + ) let f20 = ( + ) let f21 = ( + ) let f22 = ( + ) let f23 = ( + ) let f24 = ( + ) let f25 = ( + ) let f26 = ( + ) let f27 = ( + ) let f28 = ( + ) let f29 = ( + ) let f30 = ( + ) let f31 = ( + ) let f32 = ( + ) let f33 = ( + ) let f34 = ( + ) let f35 = ( + ) let f36 = ( + ) let f37 = ( + ) let f38 = ( + ) let f39 = ( + ) let f40 = ( + ) let f41 = ( + ) let f42 = ( + ) let f43 = ( + ) let f44 = ( + ) let f45 = ( + ) let f46 = ( + ) let f47 = ( + ) let f48 = ( + ) let f49 = ( + ) let f50 = ( + ) let f51 = ( + ) let f52 = ( + ) let f53 = ( + ) let f54 = ( + ) let f55 = ( + ) let f56 = ( + ) let f57 = ( + ) let f58 = ( + ) let f59 = ( + ) let f60 = ( + ) let f61 = ( + ) let f62 = ( + ) let f63 = ( + ) let f64 = ( + ) let f65 = ( + ) let f66 = ( + ) let f67 = ( + ) let f68 = ( + ) let f69 = ( + ) let f70 = ( + ) let f71 = ( + ) let f72 = ( + ) let f73 = ( + ) let f74 = ( + ) let f75 = ( + ) let f76 = ( + ) let f77 = ( + ) let f78 = ( + ) let f79 = ( + ) let f80 = ( + ) let f81 = ( + ) let f82 = ( + ) let f83 = ( + ) let f84 = ( + ) let f85 = ( + ) let f86 = ( + ) let f87 = ( + ) let f88 = ( + ) let f89 = ( + ) let f90 = ( + ) let f91 = ( + ) let f92 = ( + ) let f93 = ( + ) let f94 = ( + ) let f95 = ( + ) let f96 = ( + ) let f97 = ( + ) let f98 = ( + ) let f99 = ( + ) let f100 = ( + ) let f101 = ( + ) let f102 = ( + ) let f103 = ( + ) let f104 = ( + ) let f105 = ( + ) let f106 = ( + ) let f107 = ( + ) let f108 = ( + ) let f109 = ( + ) let f110 = ( + ) let f111 = ( + ) let f112 = ( + ) let f113 = ( + ) let f114 = ( + ) let f115 = ( + ) let f116 = ( + ) let f117 = ( + ) let f118 = ( + ) let f119 = ( + ) let f120 = ( + ) let f121 = ( + ) let f122 = ( + ) let f123 = ( + ) let f124 = ( + ) let f125 = ( + ) let f126 = ( + ) let f127 = ( + ) let f128 = ( + ) let f129 = ( + ) let f130 = ( + ) let f131 = ( + ) let f132 = ( + ) let f133 = ( + ) let f134 = ( + ) let f135 = ( + ) let f136 = ( + ) let f137 = ( + ) let f138 = ( + ) let f139 = ( + ) let f140 = ( + ) let f141 = ( + ) let f142 = ( + ) let f143 = ( + ) let f144 = ( + ) let f145 = ( + ) let f146 = ( + ) let f147 = ( + ) let f148 = ( + ) let f149 = ( + ) let f150 = ( + ) let f151 = ( + ) let f152 = ( + ) let f153 = ( + ) let f154 = ( + ) let f155 = ( + ) let f156 = ( + ) let f157 = ( + ) let f158 = ( + ) let f159 = ( + ) let f160 = ( + ) let f161 = ( + ) let f162 = ( + ) let f163 = ( + ) let f164 = ( + ) let f165 = ( + ) let f166 = ( + ) let f167 = ( + ) let f168 = ( + ) let f169 = ( + ) let f170 = ( + ) let f171 = ( + ) let f172 = ( + ) let f173 = ( + ) let f174 = ( + ) let f175 = ( + ) let f176 = ( + ) let f177 = ( + ) let f178 = ( + ) let f179 = ( + ) let f180 = ( + ) let f181 = ( + ) let f182 = ( + ) let f183 = ( + ) let f184 = ( + ) let f185 = ( + ) let f186 = ( + ) let f187 = ( + ) let f188 = ( + ) let f189 = ( + ) let f190 = ( + ) let f191 = ( + ) let f192 = ( + ) let f193 = ( + ) let f194 = ( + ) let f195 = ( + ) let f196 = ( + ) let f197 = ( + ) let f198 = ( + ) let f199 = ( + ) let f200 = ( + ) let f201 = ( + ) let f202 = ( + ) let f203 = ( + ) let f204 = ( + ) let f205 = ( + ) let f206 = ( + ) let f207 = ( + ) let f208 = ( + ) let f209 = ( + ) let f210 = ( + ) let f211 = ( + ) let f212 = ( + ) let f213 = ( + ) let f214 = ( + ) let f215 = ( + ) let f216 = ( + ) let f217 = ( + ) let f218 = ( + ) let f219 = ( + ) let f220 = ( + ) let f221 = ( + ) let f222 = ( + ) let f223 = ( + ) let f224 = ( + ) let f225 = ( + ) let f226 = ( + ) let f227 = ( + ) let f228 = ( + ) let f229 = ( + ) let f230 = ( + ) let f231 = ( + ) let f232 = ( + ) let f233 = ( + ) let f234 = ( + ) let f235 = ( + ) let f236 = ( + ) let f237 = ( + ) let f238 = ( + ) let f239 = ( + ) let f240 = ( + ) let f241 = ( + ) let f242 = ( + ) let f243 = ( + ) let f244 = ( + ) let f245 = ( + ) let f246 = ( + ) let f247 = ( + ) let f248 = ( + ) let f249 = ( + ) let f250 = ( + ) let f251 = ( + ) let f252 = ( + ) let f253 = ( + ) let f254 = ( + ) let f255 = ( + ) let f256 = ( + ) let f257 = ( + ) let f258 = ( + ) let f259 = ( + ) let f260 = ( + ) let f261 = ( + ) let f262 = ( + ) let f263 = ( + ) let f264 = ( + ) let f265 = ( + ) let f266 = ( + ) let f267 = ( + ) let f268 = ( + ) let f269 = ( + ) let f270 = ( + ) let f271 = ( + ) let f272 = ( + ) let f273 = ( + ) let f274 = ( + ) let f275 = ( + ) let f276 = ( + ) let f277 = ( + ) let f278 = ( + ) let f279 = ( + ) let f280 = ( + ) let f281 = ( + ) let f282 = ( + ) let f283 = ( + ) let f284 = ( + ) let f285 = ( + ) let f286 = ( + ) let f287 = ( + ) let f288 = ( + ) let f289 = ( + ) let f290 = ( + ) let f291 = ( + ) let f292 = ( + ) let f293 = ( + ) let f294 = ( + ) let f295 = ( + ) let f296 = ( + ) let f297 = ( + ) let f298 = ( + ) let f299 = ( + ) let f300 = ( + ) let f301 = ( + ) let f302 = ( + ) let f303 = ( + ) let f304 = ( + ) let f305 = ( + ) let f306 = ( + ) let f307 = ( + ) let f308 = ( + ) let f309 = ( + ) let f310 = ( + ) let f311 = ( + ) let f312 = ( + ) let f313 = ( + ) let f314 = ( + ) let f315 = ( + ) let f316 = ( + ) let f317 = ( + ) let f318 = ( + ) let f319 = ( + ) let f320 = ( + ) let f321 = ( + ) let f322 = ( + ) let f323 = ( + ) let f324 = ( + ) let f325 = ( + ) let f326 = ( + ) let f327 = ( + ) let f328 = ( + ) let f329 = ( + ) let f330 = ( + ) let f331 = ( + ) let f332 = ( + ) let f333 = ( + ) let f334 = ( + ) let f335 = ( + ) let f336 = ( + ) let f337 = ( + ) let f338 = ( + ) let f339 = ( + ) let f340 = ( + ) let f341 = ( + ) let f342 = ( + ) let f343 = ( + ) let f344 = ( + ) let f345 = ( + ) let f346 = ( + ) let f347 = ( + ) let f348 = ( + ) let f349 = ( + ) let f350 = ( + ) let f351 = ( + ) let f352 = ( + ) let f353 = ( + ) let f354 = ( + ) let f355 = ( + ) let f356 = ( + ) let f357 = ( + ) let f358 = ( + ) let f359 = ( + ) let f360 = ( + ) let f361 = ( + ) let f362 = ( + ) let f363 = ( + ) let f364 = ( + ) let f365 = ( + ) let f366 = ( + ) let f367 = ( + ) let f368 = ( + ) let f369 = ( + ) let f370 = ( + ) let f371 = ( + ) let f372 = ( + ) let f373 = ( + ) let f374 = ( + ) let f375 = ( + ) let f376 = ( + ) let f377 = ( + ) let f378 = ( + ) let f379 = ( + ) let f380 = ( + ) let f381 = ( + ) let f382 = ( + ) let f383 = ( + ) let f384 = ( + ) let f385 = ( + ) let f386 = ( + ) let f387 = ( + ) let f388 = ( + ) let f389 = ( + ) let f390 = ( + ) let f391 = ( + ) let f392 = ( + ) let f393 = ( + ) let f394 = ( + ) let f395 = ( + ) let f396 = ( + ) let f397 = ( + ) let f398 = ( + ) let f399 = ( + ) let f400 = ( + ) let f401 = ( + ) let f402 = ( + ) let f403 = ( + ) let f404 = ( + ) let f405 = ( + ) let f406 = ( + ) let f407 = ( + ) let f408 = ( + ) let f409 = ( + ) let f410 = ( + ) let f411 = ( + ) let f412 = ( + ) let f413 = ( + ) let f414 = ( + ) let f415 = ( + ) let f416 = ( + ) let f417 = ( + ) let f418 = ( + ) let f419 = ( + ) let f420 = ( + ) let f421 = ( + ) let f422 = ( + ) let f423 = ( + ) let f424 = ( + ) let f425 = ( + ) let f426 = ( + ) let f427 = ( + ) let f428 = ( + ) let f429 = ( + ) let f430 = ( + ) let f431 = ( + ) let f432 = ( + ) let f433 = ( + ) let f434 = ( + ) let f435 = ( + ) let f436 = ( + ) let f437 = ( + ) let f438 = ( + ) let f439 = ( + ) let f440 = ( + ) let f441 = ( + ) let f442 = ( + ) let f443 = ( + ) let f444 = ( + ) let f445 = ( + ) let f446 = ( + ) let f447 = ( + ) let f448 = ( + ) let f449 = ( + ) let f450 = ( + ) let f451 = ( + ) let f452 = ( + ) let f453 = ( + ) let f454 = ( + ) let f455 = ( + ) let f456 = ( + ) let f457 = ( + ) let f458 = ( + ) let f459 = ( + ) let f460 = ( + ) let f461 = ( + ) let f462 = ( + ) let f463 = ( + ) let f464 = ( + ) let f465 = ( + ) let f466 = ( + ) let f467 = ( + ) let f468 = ( + ) let f469 = ( + ) let f470 = ( + ) let f471 = ( + ) let f472 = ( + ) let f473 = ( + ) let f474 = ( + ) let f475 = ( + ) let f476 = ( + ) let f477 = ( + ) let f478 = ( + ) let f479 = ( + ) let f480 = ( + ) let f481 = ( + ) let f482 = ( + ) let f483 = ( + ) let f484 = ( + ) let f485 = ( + ) let f486 = ( + ) let f487 = ( + ) let f488 = ( + ) let f489 = ( + ) let f490 = ( + ) let f491 = ( + ) let f492 = ( + ) let f493 = ( + ) let f494 = ( + ) let f495 = ( + ) let f496 = ( + ) let f497 = ( + ) let f498 = ( + ) let f499 = ( + ) let f500 = ( + ) let f501 = ( + ) let f502 = ( + ) let f503 = ( + ) let f504 = ( + ) let f505 = ( + ) let f506 = ( + ) let f507 = ( + ) let f508 = ( + ) let f509 = ( + ) let f510 = ( + ) let f511 = ( + ) let f512 = ( + ) let f513 = ( + ) let f514 = ( + ) let f515 = ( + ) let f516 = ( + ) let f517 = ( + ) let f518 = ( + ) let f519 = ( + ) let f520 = ( + ) let f521 = ( + ) let f522 = ( + ) let f523 = ( + ) let f524 = ( + ) let f525 = ( + ) let f526 = ( + ) let f527 = ( + ) let f528 = ( + ) let f529 = ( + ) let f530 = ( + ) let f531 = ( + ) let f532 = ( + ) let f533 = ( + ) let f534 = ( + ) let f535 = ( + ) let f536 = ( + ) let f537 = ( + ) let f538 = ( + ) let f539 = ( + ) let f540 = ( + ) let f541 = ( + ) let f542 = ( + ) let f543 = ( + ) let f544 = ( + ) let f545 = ( + ) let f546 = ( + ) let f547 = ( + ) let f548 = ( + ) let f549 = ( + ) let f550 = ( + ) let f551 = ( + ) let f552 = ( + ) let f553 = ( + ) let f554 = ( + ) let f555 = ( + ) let f556 = ( + ) let f557 = ( + ) let f558 = ( + ) let f559 = ( + ) let f560 = ( + ) let f561 = ( + ) let f562 = ( + ) let f563 = ( + ) let f564 = ( + ) let f565 = ( + ) let f566 = ( + ) let f567 = ( + ) let f568 = ( + ) let f569 = ( + ) let f570 = ( + ) let f571 = ( + ) let f572 = ( + ) let f573 = ( + ) let f574 = ( + ) let f575 = ( + ) let f576 = ( + ) let f577 = ( + ) let f578 = ( + ) let f579 = ( + ) let f580 = ( + ) let f581 = ( + ) let f582 = ( + ) let f583 = ( + ) let f584 = ( + ) let f585 = ( + ) let f586 = ( + ) let f587 = ( + ) let f588 = ( + ) let f589 = ( + ) let f590 = ( + ) let f591 = ( + ) let f592 = ( + ) let f593 = ( + ) let f594 = ( + ) let f595 = ( + ) let f596 = ( + ) let f597 = ( + ) let f598 = ( + ) let f599 = ( + ) let f600 = ( + ) let f601 = ( + ) let f602 = ( + ) let f603 = ( + ) let f604 = ( + ) let f605 = ( + ) let f606 = ( + ) let f607 = ( + ) let f608 = ( + ) let f609 = ( + ) let f610 = ( + ) let f611 = ( + ) let f612 = ( + ) let f613 = ( + ) let f614 = ( + ) let f615 = ( + ) let f616 = ( + ) let f617 = ( + ) let f618 = ( + ) let f619 = ( + ) let f620 = ( + ) let f621 = ( + ) let f622 = ( + ) let f623 = ( + ) let f624 = ( + ) let f625 = ( + ) let f626 = ( + ) let f627 = ( + ) let f628 = ( + ) let f629 = ( + ) let f630 = ( + ) let f631 = ( + ) let f632 = ( + ) let f633 = ( + ) let f634 = ( + ) let f635 = ( + ) let f636 = ( + ) let f637 = ( + ) let f638 = ( + ) let f639 = ( + ) let f640 = ( + ) let f641 = ( + ) let f642 = ( + ) let f643 = ( + ) let f644 = ( + ) let f645 = ( + ) let f646 = ( + ) let f647 = ( + ) let f648 = ( + ) let f649 = ( + ) let f650 = ( + ) let f651 = ( + ) let f652 = ( + ) let f653 = ( + ) let f654 = ( + ) let f655 = ( + ) let f656 = ( + ) let f657 = ( + ) let f658 = ( + ) let f659 = ( + ) let f660 = ( + ) let f661 = ( + ) let f662 = ( + ) let f663 = ( + ) let f664 = ( + ) let f665 = ( + ) let f666 = ( + ) let f667 = ( + ) let f668 = ( + ) let f669 = ( + ) let f670 = ( + ) let f671 = ( + ) let f672 = ( + ) let f673 = ( + ) let f674 = ( + ) let f675 = ( + ) let f676 = ( + ) let f677 = ( + ) let f678 = ( + ) let f679 = ( + ) let f680 = ( + ) let f681 = ( + ) let f682 = ( + ) let f683 = ( + ) let f684 = ( + ) let f685 = ( + ) let f686 = ( + ) let f687 = ( + ) let f688 = ( + ) let f689 = ( + ) let f690 = ( + ) let f691 = ( + ) let f692 = ( + ) let f693 = ( + ) let f694 = ( + ) let f695 = ( + ) let f696 = ( + ) let f697 = ( + ) let f698 = ( + ) let f699 = ( + ) let f700 = ( + ) let f701 = ( + ) let f702 = ( + ) let f703 = ( + ) let f704 = ( + ) let f705 = ( + ) let f706 = ( + ) let f707 = ( + ) let f708 = ( + ) let f709 = ( + ) let f710 = ( + ) let f711 = ( + ) let f712 = ( + ) let f713 = ( + ) let f714 = ( + ) let f715 = ( + ) let f716 = ( + ) let f717 = ( + ) let f718 = ( + ) let f719 = ( + ) let f720 = ( + ) let f721 = ( + ) let f722 = ( + ) let f723 = ( + ) let f724 = ( + ) let f725 = ( + ) let f726 = ( + ) let f727 = ( + ) let f728 = ( + ) let f729 = ( + ) let f730 = ( + ) let f731 = ( + ) let f732 = ( + ) let f733 = ( + ) let f734 = ( + ) let f735 = ( + ) let f736 = ( + ) let f737 = ( + ) let f738 = ( + ) let f739 = ( + ) let f740 = ( + ) let f741 = ( + ) let f742 = ( + ) let f743 = ( + ) let f744 = ( + ) let f745 = ( + ) let f746 = ( + ) let f747 = ( + ) let f748 = ( + ) let f749 = ( + ) let f750 = ( + ) let f751 = ( + ) let f752 = ( + ) let f753 = ( + ) let f754 = ( + ) let f755 = ( + ) let f756 = ( + ) let f757 = ( + ) let f758 = ( + ) let f759 = ( + ) let f760 = ( + ) let f761 = ( + ) let f762 = ( + ) let f763 = ( + ) let f764 = ( + ) let f765 = ( + ) let f766 = ( + ) let f767 = ( + ) let f768 = ( + ) let f769 = ( + ) let f770 = ( + ) let f771 = ( + ) let f772 = ( + ) let f773 = ( + ) let f774 = ( + ) let f775 = ( + ) let f776 = ( + ) let f777 = ( + ) let f778 = ( + ) let f779 = ( + ) let f780 = ( + ) let f781 = ( + ) let f782 = ( + ) let f783 = ( + ) let f784 = ( + ) let f785 = ( + ) let f786 = ( + ) let f787 = ( + ) let f788 = ( + ) let f789 = ( + ) let f790 = ( + ) let f791 = ( + ) let f792 = ( + ) let f793 = ( + ) let f794 = ( + ) let f795 = ( + ) let f796 = ( + ) let f797 = ( + ) let f798 = ( + ) let f799 = ( + ) let f800 = ( + ) let f801 = ( + ) let f802 = ( + ) let f803 = ( + ) let f804 = ( + ) let f805 = ( + ) let f806 = ( + ) let f807 = ( + ) let f808 = ( + ) let f809 = ( + ) let f810 = ( + ) let f811 = ( + ) let f812 = ( + ) let f813 = ( + ) let f814 = ( + ) let f815 = ( + ) let f816 = ( + ) let f817 = ( + ) let f818 = ( + ) let f819 = ( + ) let f820 = ( + ) let f821 = ( + ) let f822 = ( + ) let f823 = ( + ) let f824 = ( + ) let f825 = ( + ) let f826 = ( + ) let f827 = ( + ) let f828 = ( + ) let f829 = ( + ) let f830 = ( + ) let f831 = ( + ) let f832 = ( + ) let f833 = ( + ) let f834 = ( + ) let f835 = ( + ) let f836 = ( + ) let f837 = ( + ) let f838 = ( + ) let f839 = ( + ) let f840 = ( + ) let f841 = ( + ) let f842 = ( + ) let f843 = ( + ) let f844 = ( + ) let f845 = ( + ) let f846 = ( + ) let f847 = ( + ) let f848 = ( + ) let f849 = ( + ) let f850 = ( + ) let f851 = ( + ) let f852 = ( + ) let f853 = ( + ) let f854 = ( + ) let f855 = ( + ) let f856 = ( + ) let f857 = ( + ) let f858 = ( + ) let f859 = ( + ) let f860 = ( + ) let f861 = ( + ) let f862 = ( + ) let f863 = ( + ) let f864 = ( + ) let f865 = ( + ) let f866 = ( + ) let f867 = ( + ) let f868 = ( + ) let f869 = ( + ) let f870 = ( + ) let f871 = ( + ) let f872 = ( + ) let f873 = ( + ) let f874 = ( + ) let f875 = ( + ) let f876 = ( + ) let f877 = ( + ) let f878 = ( + ) let f879 = ( + ) let f880 = ( + ) let f881 = ( + ) let f882 = ( + ) let f883 = ( + ) let f884 = ( + ) let f885 = ( + ) let f886 = ( + ) let f887 = ( + ) let f888 = ( + ) let f889 = ( + ) let f890 = ( + ) let f891 = ( + ) let f892 = ( + ) let f893 = ( + ) let f894 = ( + ) let f895 = ( + ) let f896 = ( + ) let f897 = ( + ) let f898 = ( + ) let f899 = ( + ) let f900 = ( + ) let f901 = ( + ) let f902 = ( + ) let f903 = ( + ) let f904 = ( + ) let f905 = ( + ) let f906 = ( + ) let f907 = ( + ) let f908 = ( + ) let f909 = ( + ) let f910 = ( + ) let f911 = ( + ) let f912 = ( + ) let f913 = ( + ) let f914 = ( + ) let f915 = ( + ) let f916 = ( + ) let f917 = ( + ) let f918 = ( + ) let f919 = ( + ) let f920 = ( + ) let f921 = ( + ) let f922 = ( + ) let f923 = ( + ) let f924 = ( + ) let f925 = ( + ) let f926 = ( + ) let f927 = ( + ) let f928 = ( + ) let f929 = ( + ) let f930 = ( + ) let f931 = ( + ) let f932 = ( + ) let f933 = ( + ) let f934 = ( + ) let f935 = ( + ) let f936 = ( + ) let f937 = ( + ) let f938 = ( + ) let f939 = ( + ) let f940 = ( + ) let f941 = ( + ) let f942 = ( + ) let f943 = ( + ) let f944 = ( + ) let f945 = ( + ) let f946 = ( + ) let f947 = ( + ) let f948 = ( + ) let f949 = ( + ) let f950 = ( + ) let f951 = ( + ) let f952 = ( + ) let f953 = ( + ) let f954 = ( + ) let f955 = ( + ) let f956 = ( + ) let f957 = ( + ) let f958 = ( + ) let f959 = ( + ) let f960 = ( + ) let f961 = ( + ) let f962 = ( + ) let f963 = ( + ) let f964 = ( + ) let f965 = ( + ) let f966 = ( + ) let f967 = ( + ) let f968 = ( + ) let f969 = ( + ) let f970 = ( + ) let f971 = ( + ) let f972 = ( + ) let f973 = ( + ) let f974 = ( + ) let f975 = ( + ) let f976 = ( + ) let f977 = ( + ) let f978 = ( + ) let f979 = ( + ) let f980 = ( + ) let f981 = ( + ) let f982 = ( + ) let f983 = ( + ) let f984 = ( + ) let f985 = ( + ) let f986 = ( + ) let f987 = ( + ) let f988 = ( + ) let f989 = ( + ) let f990 = ( + ) let f991 = ( + ) let f992 = ( + ) let f993 = ( + ) let f994 = ( + ) let f995 = ( + ) let f996 = ( + ) let f997 = ( + ) let f998 = ( + ) let f999 = ( + ) let f1000 = ( + ) end module X = Make(Make(Make(M))) mingw-ocaml/ocaml/camlp4/test/fixtures/bug-camlp4o-benjamin-monate.ml0000644000175000017500000000053112124403240025172 0ustar tootstootstype t = A of t | B ;; let f = function A A B -> B | B | A B | A (A _) -> B ;; exception True let qexists f q = try Queue.iter (fun v -> if f v then raise True) q; false with True -> true type u = True | False let g x = function | True -> () | False -> () type v = [`True | `False] let h x = function | `True -> () | `False -> () mingw-ocaml/ocaml/camlp4/test/fixtures/loc-bug.ml0000644000175000017500000000006312124403240021346 0ustar tootstoots#default_quotation "expr";; Lwt.return << 3 + >> mingw-ocaml/ocaml/camlp4/test/fixtures/seq.ml0000644000175000017500000002543212124403240020615 0ustar tootstootsmodule M = struct foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; end; mingw-ocaml/ocaml/camlp4/test/fixtures/original_syntax.ml0000644000175000017500000000033512124403240023232 0ustar tootstootsfun x when x <> 0 -> x / 42 ;; object val virtual mutable x : int val mutable virtual y : int end ;; - !r ;; ! -r ;; -32 ;; - - 32 ;; !(r.b) ;; (!r).b = !r.b ;; let l : (unit -> int) list = [(fun _ -> 42); (fun _ -> 42)] mingw-ocaml/ocaml/camlp4/test/fixtures/bug-4058.ml0000644000175000017500000000014312124403240021170 0ustar tootstootslet _ = (fun x -> x), 1 let _ = (x := 1), 2 let _ = (x <- 1), 2 let _ = (if true then 1 else 2), 1 mingw-ocaml/ocaml/camlp4/test/fixtures/try.ml0000644000175000017500000000025712124403240020641 0ustar tootstootstry let f = Sys.getenv "CAMLP4_DEBUG_FILE" in foo bar foo bar foo bar foo bar foo bar foo bar foo bar foo bar foo bar foo bar foo bar foo bar with Not_found -> stderr mingw-ocaml/ocaml/camlp4/test/fixtures/stream-parser-bug.ml0000644000175000017500000000015112124403240023354 0ustar tootstootslet foo = parser | [< '42; ps >] -> let ps = ps + 42 in type_phrases ps | [< >] -> [< >] mingw-ocaml/ocaml/camlp4/test/fixtures/unit.ml0000644000175000017500000000010412124403240020771 0ustar tootstootstype t1 = ();; type t2 = unit;; let x : t1 = ();; let y : t2 = ();; mingw-ocaml/ocaml/camlp4/test/fixtures/type_decl.ml0000644000175000017500000000130012124403240021761 0ustar tootstootsmodule M = struct type t = A of int * int * int * int * int * int * int * int * int * int | B | B | B | B | B | B | B | B and t2 = | B | B | B | B | B | B | B | B and t3 = | B | B | B of a * a * a * a * a * a * a * a * a * a * a | B | B | B | B | B and t4 = | B | B | B | B | B | B | B | B and t5 = | B | B | B | B | B | B | B | B and t6 = | B | B | B | A of int * int * int * int * int * int * int * int * int * int * int * int * int * int * int * int * int * int * int | B | B | B | B | B and t7 = | B | B | B | B | B | B | B | B and t8 = | B | B | B | B | B | B | B | B and t9 = | B | B | B | B | B | B | B | B and t10 = | A of (a * a) end mingw-ocaml/ocaml/camlp4/test/fixtures/pp_let_in2.ml0000644000175000017500000000010012124403240022041 0ustar tootstootslet i = "toto" in ((let i = 42 in print_int i); print_string i) mingw-ocaml/ocaml/camlp4/test/fixtures/gram-loc-lost.ml0000644000175000017500000000151112124403240022475 0ustar tootstootsopen Camlp4.PreCast; module G = MakeGram Lexer; (* type t = [ A of Loc.t and t and t | B of Loc.t and string ]; *) value main = G.Entry.mk "main"; (* value rec length x acc = match x with [ A x y -> length x (length y acc) | B _ -> succ acc ]; value length _ _ = -1; *) EXTEND G GLOBAL: main; main: [ RIGHTA [ x = SELF; y = SELF -> let l = Loc.merge x y in if l = _loc then _loc else do { Format.eprintf "bad loc: %a <> %a + %a@." Loc.dump _loc Loc.dump x Loc.dump y; _loc } | i = ident -> i ] ]; ident: [ [ `LIDENT _ -> _loc ] ]; END; try let f = Sys.argv.(1) in Format.printf "%a@." Loc.dump (G.parse main (Loc.mk f) (Stream.of_channel (open_in f))) with e -> Format.eprintf "error: %a@." Camlp4.ErrorHandler.print e; mingw-ocaml/ocaml/camlp4/test/fixtures/pr4314gram5.ml0000644000175000017500000000151412124403240021711 0ustar tootstootsopen Camlp4.PreCast ; module G = Camlp4.PreCast.Gram ; value exp = G.Entry.mk "exp" ; value prog = G.Entry.mk "prog" ; EXTEND G exp: [ "apply" [ e1 = SELF; e2 = exp LEVEL "simple"; e3 = SELF -> let p = Loc.dump in let () = Format.eprintf "e1: %a,@.e2: %a,@.e3: %a,@._loc: %a@." p e1 p e2 p e3 p _loc in _loc ] | "simple" [ x = LIDENT; y = LIDENT -> let () = Format.eprintf "reduce expr simple (%S, %S) at %a@." x y Loc.dump _loc in _loc ] ]; prog: [[ e = exp; `EOI -> e ]]; END ; (* and the following function: *) value parse_string entry s = try print_endline s; G.parse_string entry (Loc.mk "") s with [ Loc.Exc_located loc exn -> begin print_endline (Loc.to_string loc); print_endline (Printexc.to_string exn); failwith "Syntax Error" end ] ; parse_string prog "f1 f2 x1 x2 y1 y2"; mingw-ocaml/ocaml/camlp4/test/fixtures/operators.mli0000644000175000017500000000003412124403240022203 0ustar tootstootsval (+) : int -> int -> int mingw-ocaml/ocaml/camlp4/test/fixtures/pr4314.ml0000644000175000017500000000003412124403240020751 0ustar tootstoots(int_of_string "1" : unit); mingw-ocaml/ocaml/camlp4/test/fixtures/match_parser.ml0000644000175000017500000000032712124403240022471 0ustar tootstootsopen Camlp4.PreCast; let _loc = Loc.ghost in let e = <:expr< parser [: `"a" :] -> t >> in let a = match e with [ <:expr< parser [: `$str:x$ :] -> t >> -> x | _ -> assert False ] in Format.printf "a: %S@." a; mingw-ocaml/ocaml/camlp4/test/fixtures/gram-list.ml0000644000175000017500000000046512124403240021723 0ustar tootstootsopen Camlp4.PreCast; module G = MakeGram Lexer; value main = G.Entry.mk "main"; EXTEND G GLOBAL: main; main: [ [ l = LIST1 ident -> l ] ]; ident: [ [ `LIDENT s -> s ] ]; END; let f = Sys.argv.(1) in Format.printf "%d@." (List.length (G.parse main (Loc.mk f) (Stream.of_channel (open_in f)))); mingw-ocaml/ocaml/camlp4/test/fixtures/lambda_free.ml0000644000175000017500000000402112124403240022235 0ustar tootstootsopen Format; module S = Set.Make String; type term = [ Lambda of string and term | Atom of string | App of term and term | Opt of term and option term and term ]; value free_vars = let rec fv t env free = match t with [ Lambda x t -> fv t (S.add x env) free | Atom x -> if S.mem x env then free else S.add x free | App t1 t2 -> fv t1 env (fv t2 env free) | Opt _ _ _ -> assert False ] in fun t -> fv t S.empty S.empty; value print_set f s = do { fprintf f "@[<2>{ "; S.iter (fprintf f "%s@ ") s; fprintf f "}@]"; }; value t1 = Lambda "x" (App (Lambda "y" (App (Atom "y") (Atom "x"))) (Lambda "x" (Atom "x"))); value t2 = Lambda "x" (App (Lambda "y" (App (Atom "y") (Atom "x"))) (Lambda "z" (Atom "z"))); value t3 = Lambda "x" (App (Lambda "y" (App (Atom "y") (Atom "x"))) (Lambda "x" (Atom "z"))); value t4 = Lambda "a" (App (Lambda "y" (App (Atom "y") (Atom "x"))) (Lambda "x" (Atom "z"))); printf "t1: %a@." print_set (free_vars t1); printf "t2: %a@." print_set (free_vars t2); printf "t3: %a@." print_set (free_vars t3); printf "t4: %a@." print_set (free_vars t4); class fold ['accu] init = object (o : 'self_type) value accu : 'accu = init; method accu = accu; method term t = match t with [ Lambda x t -> (o#string x)#term t | Atom x -> o#string x | App t1 t2 -> (o#term t1)#term t2 | Opt t1 ot t2 -> ((o#term t1)#option (fun o -> o#term) ot)#term t2 ]; method string : string -> 'self_type = fun _ -> o; method option : ! 'a. ('self_type -> 'a -> 'self_type) -> option 'a -> 'self_type = fun f opt -> match opt with [ None -> o | Some x -> f o x ]; end; class fold_atoms ['accu] f init = object (o : 'self_type) inherit fold ['accu] init as super; method term t = match t with [ Atom x -> {< accu = f x accu >} | _ -> super#term t ]; end; value t5 = Opt (Atom "a") (Some (Atom "b")) (Atom "c"); value atoms = ((new fold_atoms S.add S.empty)#term t5)#accu; printf "atoms: %a@." print_set atoms; mingw-ocaml/ocaml/camlp4/test/fixtures/pr4329.ml0000644000175000017500000000336312124403240020767 0ustar tootstootsopen Camlp4.PreCast ; module G = Camlp4.PreCast.Gram; value ab_eoi = G.Entry.mk "ab_eoi" ; value a_or_ab = G.Entry.mk "a_or_ab" ; value a_or_ab_eoi = G.Entry.mk "a_or_ab_eoi" ; value c_a_or_ab_eoi = G.Entry.mk "c_a_or_ab_eoi" ; EXTEND G ab_eoi: [[ "a"; "b"; `EOI -> () ]]; a_or_ab: [[ "a" -> () | "a"; "b" -> () ]]; a_or_ab_eoi: [[ a_or_ab; `EOI -> () ]]; c_a_or_ab_eoi: [[ "c"; a_or_ab; `EOI -> () ]]; END ; value parse_string entry s = try G.parse_string entry (Loc.mk "") s with [ Loc.Exc_located loc exn -> begin print_endline (Loc.to_string loc); print_endline (Printexc.to_string exn); (* failwith "Syntax Error" *) end ] ; (* Consider the following syntax errors: *) parse_string ab_eoi "a c" ; (* File "", line 1, characters 2-3 Stream.Error("illegal begin of ab_eoi") Exception: Failure "Syntax Error". --> "Illegal begin": at least the first symbol was correct --> nevertheless, the reported position is correct --> The message used to be: "b" then EOI expected after "a" in [ab_eoi] *) parse_string a_or_ab_eoi "a c" ; (* File "", line 1, characters 0-1 Stream.Error("illegal begin of a_or_ab_eoi") Exception: Failure "Syntax Error". --> "Illegal begin": at least the first non-terminal was correct --> the reported position is weird --> I think the message used to be either: "b" expected after "a" in [a_or_ab] or: EOI expected after [a_or_ab] in [a_or_ab_eoi] *) parse_string c_a_or_ab_eoi "c a c" ; (* File "", line 1, characters 2-3 Stream.Error("[a_or_ab] expected after \"c\" (in [c_a_or_ab_eoi])") Exception: Failure "Syntax Error". --> "[a_or_ab] expected": this is very confusing: there is a valid a_or_ab there, namely "a" *) mingw-ocaml/ocaml/camlp4/test/fixtures/parser.ml0000644000175000017500000000325312124403240021316 0ustar tootstootsopen Camlp4.PreCast; type t = [ A of t and t | B of string ]; value lex = Lexer.mk (); (* value list0 symb = let rec loop al = parser [ [: a = symb; s :] -> loop [a :: al] s | [: :] -> al ] in parser [: a = loop [] :] -> List.rev a ; value list0sep symb sep = let rec kont al = parser [ [: v = sep; a = symb; s :] -> kont [a :: al] s | [: :] -> al ] in parser [ [: a = symb; s :] -> List.rev (kont [a] s) | [: :] -> [] ] ; value list1 symb = let rec loop al = parser [ [: a = symb; s :] -> loop [a :: al] s | [: :] -> al ] in parser [: a = symb; s :] -> List.rev (loop [a] s) ; value list1sep symb sep = let rec kont al = parser [ [: v = sep; a = symb; s :] -> kont [a :: al] s | [: :] -> al ] in parser [: a = symb; s :] -> List.rev (kont [a] s) ; *) value list1 = let rec self stream acc = match stream with parser [ [: `(EOI, _) :] -> acc | [: `(LIDENT x, _); xs :] -> self xs (A acc (B x)) | [: `(BLANKS _ | NEWLINE, _); xs :] -> self xs acc ] in parser [: `(LIDENT x, _); xs :] -> self xs (B x); value rec length x acc = match x with [ A x y -> length x (length y acc) | B _ -> succ acc ]; (* value length _ _ = -1; *) open Format; try let f = Sys.argv.(1) in let () = printf "parsing...@." in let a = list1 (lex (Loc.mk f) (Stream.of_channel (open_in f))) in let () = printf "counting...@." in let n = length a 0 in printf "%d@." n with e -> eprintf "error: %a@." Camlp4.ErrorHandler.print e; mingw-ocaml/ocaml/camlp4/test/fixtures/bug-by-vincent-balat.ml0000644000175000017500000000004212124403240023725 0ustar tootstootsfun a -> x <- !x + 1; x <- !x + 2 mingw-ocaml/ocaml/camlp4/test/fixtures/comments.mli0000644000175000017500000000536412124403240022025 0ustar tootstoots(** The first special comment of the file is the comment associated with the whole module.*) (** Special comments can be placed between elements and are kept by the OCamldoc tool, but are not associated to any element. @-tags in these comments are ignored.*) (*******************************************************************) (** Comments like the one above, with more than two asterisks, are ignored. *) (** The comment for function f. *) val f : int -> int -> int (** The continuation of the comment for function f. *) (** Comment for exception My_exception, even with a simple comment between the special comment and the exception.*) (* Hello, I'm a simple comment :-) *) exception My_exception of (int -> int) * int (** Comment for type weather *) type weather = | Rain of int (** The comment for construtor Rain *) | Sun (** The comment for constructor Sun *) (** Comment for type weather2 *) type weather2 = | Rain of int (** The comment for construtor Rain *) | Sun (** The comment for constructor Sun *) (** I can continue the comment for type weather2 here because there is already a comment associated to the last constructor.*) (** The comment for type my_record *) type my_record = { foo : int ; (** Comment for field foo *) bar : string ; (** Comment for field bar *) } (** Continuation of comment for type my_record *) (** Comment for foo *) val foo : string (** This comment is associated to foo and not to bar. *) val bar : string (** This comment is assciated to bar. *) (** The comment for class my_class *) class my_class : object (** A comment to describe inheritance from cl *) inherit cl (** The comment for attribute tutu *) val mutable tutu : string (** The comment for attribute toto. *) val toto : int (** This comment is not attached to titi since there is a blank line before titi, but is kept as a comment in the class. *) val titi : string (** Comment for method toto *) method toto : string (** Comment for method m *) method m : float -> int end (** The comment for the class type my_class_type *) class type my_class_type = object (** The comment for variable x. *) val mutable x : int (** The commend for method m. *) method m : int -> int end (** The comment for module Foo *) module Foo : sig (** The comment for x *) val x : int (** A special comment that is kept but not associated to any element *) end (** The comment for module type my_module_type. *) module type MY_MODULE_TYPE = sig (** The comment for value x. *) val x : int (** The comment for module M. *) module M : sig (** The comment for value y. *) val y : int (* ... *) end end mingw-ocaml/ocaml/camlp4/test/fixtures/use.ml0000644000175000017500000000011112124403240020604 0ustar tootstoots(* use.ml *) #use "test/fixtures/rec.ml"; (* value use *) value use = 3; mingw-ocaml/ocaml/camlp4/test/fixtures/outside-scope.ml0000644000175000017500000000073112124403240022603 0ustar tootstootstype t 'a = [ Nil | Cons of 'a and t 'a ]; module A : sig value app_hd : t 'a -> ('a -> 'a) -> option 'a; end = struct value app_hd x f = match x with [ Nil -> None | Cons x _ -> Some (f x) ]; end; open A; module M = struct external mk_nil : unit -> t 'a = "%identity"; value nil = mk_nil (); (* value is_nil x = x = nil; *) end; (* M.app_hd succ (M.Cons 1 M.Nil); *) (* M.hd (M.Cons 1 M.Nil); *) app_hd (M.nil : t 'a) (fun (x : int) -> (x : 'a)); mingw-ocaml/ocaml/camlp4/test/fixtures/pp_xml.ml0000644000175000017500000000133112124403240021314 0ustar tootstoots type xml = Elt of string * xml list | Pcdata of string let pp = Format.fprintf let rec print_elt f = function | Elt (tag, contents) -> pp f "@[@[<%s>@,%a@]@,@]" tag print_list_elts contents tag | Pcdata s -> Format.pp_print_string f s and print_list_elts f = let rec loop = function | [] -> () | x::xs -> (pp f "@,"; print_elt f x; loop xs) in function | [] -> () | [x] -> print_elt f x | x::xs -> (print_elt f x; loop xs) let tree = Elt ("div", [ Elt ("p", [Pcdata "a short text"]); Elt ("p", [Pcdata "a looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong text"]) ]) let () = Format.printf "%a@." print_elt tree mingw-ocaml/ocaml/camlp4/test/fixtures/gram-sub-rule.ml0000644000175000017500000000203112124403240022475 0ustar tootstootsopen Camlp4.PreCast.Syntax; value mo _loc = fun [ None -> <:expr< None >> | Some e -> <:expr< Some $e$ >> ]; EXTEND Gram GLOBAL: expr; expr: [ [ "testbegin"; lb = [ "("; l = LIST0 a_LIDENT SEP ","; ")" -> l | "()" -> [] ]; b = bar; "testend" -> let e = List.fold_right (fun i acc -> <:expr< [ $lid:i$ :: $acc$ ] >>) lb <:expr< [] >> in <:expr< ($e$, $b$) >> ] ]; bar: [ [ x = OPT [ o = OPT [ x = "testb" -> <:expr< $str:Token.extract_string x$ >> ]; "testc"; b = baz -> <:expr< ($mo _loc o$, $b$) >> ] -> mo _loc x ] ]; (* bar: [ [ o = OPT [ o = OPT [ "bar" -> <:expr< bar >> ]; b = baz -> <:expr< ($mo _loc o$, $b$) >> ] -> mo _loc o ] ]; *) (* bar: [ [ o = OPT [ "bar" -> <:expr< bar >> ]; b = baz -> <:expr< ($mo _loc o$, $b$) >> ] ]; *) baz: [ [ "baz" -> <:expr< baz >> ] ]; END; mingw-ocaml/ocaml/camlp4/test/fixtures/exception-with-eqn-bug.ml0000644000175000017500000000003612124403240024321 0ustar tootstootsexception Foo of string = Bar mingw-ocaml/ocaml/camlp4/test/fixtures/idents0000644000175000017500000000540012124403240020675 0ustar tootstootsaaa aab aac aad aae aaf aag aah aai aaj aak aal aam aan aao aap aaq aar aas aat aau aav aaw aax aay aaz aba abb abc abd abe abf abg abh abi abj abk abl abm abn abo abp abq abr abs abt abu abv abw abx aby abz aca acb acc acd ace acf acg ach aci acj ack acl acm acn aco acp acq acr acs act acu acv acw acx acy acz ada adb adc add ade adf adg adh adi adj adk adl adm adn ado adp adq adr ads adt adu adv adw adx ady adz aea aeb aec aed aee aef aeg aeh aei aej aek ael aem aen aeo aep aeq aer aes aet aeu aev aew aex aey aez afa afb afc afd afe aff afg afh afi afj afk afl afm afn afo afp afq afr afs aft afu afv afw afx afy afz aga agb agc agd age agf agg agh agi agj agk agl agm agn ago agp agq agr ags agt agu agv agw agx agy agz aha ahb ahc ahd ahe ahf ahg ahh ahi ahj ahk ahl ahm ahn aho ahp ahq ahr ahs aht ahu ahv ahw ahx ahy ahz aia aib aic aid aie aif aig aih aii aij aik ail aim ain aio aip aiq air ais ait aiu aiv aiw aix aiy aiz aja ajb ajc ajd aje ajf ajg ajh aji ajj ajk ajl ajm ajn ajo ajp ajq ajr ajs ajt aju ajv ajw ajx ajy ajz aka akb akc akd ake akf akg akh aki akj akk akl akm akn ako akp akq akr aks akt aku akv akw akx aky akz ala alb alc ald ale alf alg alh ali alj alk all alm aln alo alp alq alr als alt alu alv alw alx aly alz ama amb amc amd ame amf amg amh ami amj amk aml amm amn amo amp amq amr ams amt amu amv amw amx amy amz ana anb anc and ane anf ang anh ani anj ank anl anm ann ano anp anq anr ans ant anu anv anw anx any anz aoa aob aoc aod aoe aof aog aoh aoi aoj aok aol aom aon aoo aop aoq aor aos aot aou aov aow aox aoy aoz apa apb apc apd ape apf apg aph api apj apk apl apm apn apo app apq apr aps apt apu apv apw apx apy apz aqa aqb aqc aqd aqe aqf aqg aqh aqi aqj aqk aql aqm aqn aqo aqp aqq aqr aqs aqt aqu aqv aqw aqx aqy aqz ara arb arc ard are arf arg arh ari arj ark arl arm arn aro arp arq arr ars art aru arv arw arx ary arz asa asb asc asd ase asf asg ash asi asj ask asl asm asn aso asp asq asr ass ast asu asv asw asx asy asz ata atb atc atd ate atf atg ath ati atj atk atl atm atn ato atp atq atr ats att atu atv atw atx aty atz aua aub auc aud aue auf aug auh aui auj auk aul aum aun auo aup auq aur aus aut auu auv auw aux auy auz ava avb avc avd ave avf avg avh avi avj avk avl avm avn avo avp avq avr avs avt avu avv avw avx avy avz awa awb awc awd awe awf awg awh awi awj awk awl awm awn awo awp awq awr aws awt awu awv aww awx awy awz axa axb axc axd axe axf axg axh axi axj axk axl axm axn axo axp axq axr axs axt axu axv axw axx axy axz aya ayb ayc ayd aye ayf ayg ayh ayi ayj ayk ayl aym ayn ayo ayp ayq ayr ays ayt ayu ayv ayw ayx ayy ayz aza azb azc azd aze azf azg azh azi azj azk azl azm azn azo azp azq azr azs azt azu azv azw azx azy azz baa bab bac bad bae baf bag bah bai baj bak bal bam ban bao bap baq bar bas bat bau bav baw bax bay baz bba bbb mingw-ocaml/ocaml/camlp4/test/fixtures/bug-camlp4o-constr-arity-expr.ml0000644000175000017500000000027112124403240025541 0ustar tootstoots(* Some Some Some None;; *) (* ((Some None) None) None;; *) ((Some) None);; (* ((Some Some) Some) None;; *) type t = A of int * int * int;; A (1, 2, 3);; (A) (1, 2, 3);; (A (1, 2)) 3;; mingw-ocaml/ocaml/camlp4/test/fixtures/idents10000644000175000017500000011106112124403240020757 0ustar tootstootsaaaa aaab aaac aaad aaae aaaf aaag aaah aaai aaaj aaak aaal aaam aaan aaao aaap aaaq aaar aaas aaat aaau aaav aaaw aaax aaay aaaz aaba aabb aabc aabd aabe aabf aabg aabh aabi aabj aabk aabl aabm aabn aabo aabp aabq aabr aabs aabt aabu aabv aabw aabx aaby aabz aaca aacb aacc aacd aace aacf aacg aach aaci aacj aack aacl aacm aacn aaco aacp aacq aacr aacs aact aacu aacv aacw aacx aacy aacz aada aadb aadc aadd aade aadf aadg aadh aadi aadj aadk aadl aadm aadn aado aadp aadq aadr aads aadt aadu aadv aadw aadx aady aadz aaea aaeb aaec aaed aaee aaef aaeg aaeh aaei aaej aaek aael aaem aaen aaeo aaep aaeq aaer aaes aaet aaeu aaev aaew aaex aaey aaez aafa aafb aafc aafd aafe aaff aafg aafh aafi aafj aafk aafl aafm aafn aafo aafp aafq aafr aafs aaft aafu aafv aafw aafx aafy aafz aaga aagb aagc aagd aage aagf aagg aagh aagi aagj aagk aagl aagm aagn aago aagp aagq aagr aags aagt aagu aagv aagw aagx aagy aagz aaha aahb aahc aahd aahe aahf aahg aahh aahi aahj aahk aahl aahm aahn aaho aahp aahq aahr aahs aaht aahu aahv aahw aahx aahy aahz aaia aaib aaic aaid aaie aaif aaig aaih aaii aaij aaik aail aaim aain aaio aaip aaiq aair aais aait aaiu aaiv aaiw aaix aaiy aaiz aaja aajb aajc aajd aaje aajf aajg aajh aaji aajj aajk aajl aajm aajn aajo aajp aajq aajr aajs aajt aaju aajv aajw aajx aajy aajz aaka aakb aakc aakd aake aakf aakg aakh aaki aakj aakk aakl aakm aakn aako aakp aakq aakr aaks aakt aaku aakv aakw aakx aaky aakz aala aalb aalc aald aale aalf aalg aalh aali aalj aalk aall aalm aaln aalo aalp aalq aalr aals aalt aalu aalv aalw aalx aaly aalz aama aamb aamc aamd aame aamf aamg aamh aami aamj aamk aaml aamm aamn aamo aamp aamq aamr aams aamt aamu aamv aamw aamx aamy aamz aana aanb aanc aand aane aanf aang aanh aani aanj aank aanl aanm aann aano aanp aanq aanr aans aant aanu aanv aanw aanx aany aanz aaoa aaob aaoc aaod aaoe aaof aaog aaoh aaoi aaoj aaok aaol aaom aaon aaoo aaop aaoq aaor aaos aaot aaou aaov aaow aaox aaoy aaoz aapa aapb aapc aapd aape aapf aapg aaph aapi aapj aapk aapl aapm aapn aapo aapp aapq aapr aaps aapt aapu aapv aapw aapx aapy aapz aaqa aaqb aaqc aaqd aaqe aaqf aaqg aaqh aaqi aaqj aaqk aaql aaqm aaqn aaqo aaqp aaqq aaqr aaqs aaqt aaqu aaqv aaqw aaqx aaqy aaqz aara aarb aarc aard aare aarf aarg aarh aari aarj aark aarl aarm aarn aaro aarp aarq aarr aars aart aaru aarv aarw aarx aary aarz aasa aasb aasc aasd aase aasf aasg aash aasi aasj aask aasl aasm aasn aaso aasp aasq aasr aass aast aasu aasv aasw aasx aasy aasz aata aatb aatc aatd aate aatf aatg aath aati aatj aatk aatl aatm aatn aato aatp aatq aatr aats aatt aatu aatv aatw aatx aaty aatz aaua aaub aauc aaud aaue aauf aaug aauh aaui aauj aauk aaul aaum aaun aauo aaup aauq aaur aaus aaut aauu aauv aauw aaux aauy aauz aava aavb aavc aavd aave aavf aavg aavh aavi aavj aavk aavl aavm aavn aavo aavp aavq aavr aavs aavt aavu aavv aavw aavx aavy aavz aawa aawb aawc aawd aawe aawf aawg aawh aawi aawj aawk aawl aawm aawn aawo aawp aawq aawr aaws aawt aawu aawv aaww aawx aawy aawz aaxa aaxb aaxc aaxd aaxe aaxf aaxg aaxh aaxi aaxj aaxk aaxl aaxm aaxn aaxo aaxp aaxq aaxr aaxs aaxt aaxu aaxv aaxw aaxx aaxy aaxz aaya aayb aayc aayd aaye aayf aayg aayh aayi aayj aayk aayl aaym aayn aayo aayp aayq aayr aays aayt aayu aayv aayw aayx aayy aayz aaza aazb aazc aazd aaze aazf aazg aazh aazi aazj aazk aazl aazm aazn aazo aazp aazq aazr aazs aazt aazu aazv aazw aazx aazy aazz abaa abab abac abad abae abaf abag abah abai abaj abak abal abam aban abao abap abaq abar abas abat abau abav abaw abax abay abaz abba abbb abbc abbd abbe abbf abbg abbh abbi abbj abbk abbl abbm abbn abbo abbp abbq abbr abbs abbt abbu abbv abbw abbx abby abbz abca abcb abcc abcd abce abcf abcg abch abci abcj abck abcl abcm abcn abco abcp abcq abcr abcs abct abcu abcv abcw abcx abcy abcz abda abdb abdc abdd abde abdf abdg abdh abdi abdj abdk abdl abdm abdn abdo abdp abdq abdr abds abdt abdu abdv abdw abdx abdy abdz abea abeb abec abed abee abef abeg abeh abei abej abek abel abem aben abeo abep abeq aber abes abet abeu abev abew abex abey abez abfa abfb abfc abfd abfe abff abfg abfh abfi abfj abfk abfl abfm abfn abfo abfp abfq abfr abfs abft abfu abfv abfw abfx abfy abfz abga abgb abgc abgd abge abgf abgg abgh abgi abgj abgk abgl abgm abgn abgo abgp abgq abgr abgs abgt abgu abgv abgw abgx abgy abgz abha abhb abhc abhd abhe abhf abhg abhh abhi abhj abhk abhl abhm abhn abho abhp abhq abhr abhs abht abhu abhv abhw abhx abhy abhz abia abib abic abid abie abif abig abih abii abij abik abil abim abin abio abip abiq abir abis abit abiu abiv abiw abix abiy abiz abja abjb abjc abjd abje abjf abjg abjh abji abjj abjk abjl abjm abjn abjo abjp abjq abjr abjs abjt abju abjv abjw abjx abjy abjz abka abkb abkc abkd abke abkf abkg abkh abki abkj abkk abkl abkm abkn abko abkp abkq abkr abks abkt abku abkv abkw abkx abky abkz abla ablb ablc abld able ablf ablg ablh abli ablj ablk abll ablm abln ablo ablp ablq ablr abls ablt ablu ablv ablw ablx ably ablz abma abmb abmc abmd abme abmf abmg abmh abmi abmj abmk abml abmm abmn abmo abmp abmq abmr abms abmt abmu abmv abmw abmx abmy abmz abna abnb abnc abnd abne abnf abng abnh abni abnj abnk abnl abnm abnn abno abnp abnq abnr abns abnt abnu abnv abnw abnx abny abnz aboa abob aboc abod aboe abof abog aboh aboi aboj abok abol abom abon aboo abop aboq abor abos abot abou abov abow abox aboy aboz abpa abpb abpc abpd abpe abpf abpg abph abpi abpj abpk abpl abpm abpn abpo abpp abpq abpr abps abpt abpu abpv abpw abpx abpy abpz abqa abqb abqc abqd abqe abqf abqg abqh abqi abqj abqk abql abqm abqn abqo abqp abqq abqr abqs abqt abqu abqv abqw abqx abqy abqz abra abrb abrc abrd abre abrf abrg abrh abri abrj abrk abrl abrm abrn abro abrp abrq abrr abrs abrt abru abrv abrw abrx abry abrz absa absb absc absd abse absf absg absh absi absj absk absl absm absn abso absp absq absr abss abst absu absv absw absx absy absz abta abtb abtc abtd abte abtf abtg abth abti abtj abtk abtl abtm abtn abto abtp abtq abtr abts abtt abtu abtv abtw abtx abty abtz abua abub abuc abud abue abuf abug abuh abui abuj abuk abul abum abun abuo abup abuq abur abus abut abuu abuv abuw abux abuy abuz abva abvb abvc abvd abve abvf abvg abvh abvi abvj abvk abvl abvm abvn abvo abvp abvq abvr abvs abvt abvu abvv abvw abvx abvy abvz abwa abwb abwc abwd abwe abwf abwg abwh abwi abwj abwk abwl abwm abwn abwo abwp abwq abwr abws abwt abwu abwv abww abwx abwy abwz abxa abxb abxc abxd abxe abxf abxg abxh abxi abxj abxk abxl abxm abxn abxo abxp abxq abxr abxs abxt abxu abxv abxw abxx abxy abxz abya abyb abyc abyd abye abyf abyg abyh abyi abyj abyk abyl abym abyn abyo abyp abyq abyr abys abyt abyu abyv abyw abyx abyy abyz abza abzb abzc abzd abze abzf abzg abzh abzi abzj abzk abzl abzm abzn abzo abzp abzq abzr abzs abzt abzu abzv abzw abzx abzy abzz acaa acab acac acad acae acaf acag acah acai acaj acak acal acam acan acao acap acaq acar acas acat acau acav acaw acax acay acaz acba acbb acbc acbd acbe acbf acbg acbh acbi acbj acbk acbl acbm acbn acbo acbp acbq acbr acbs acbt acbu acbv acbw acbx acby acbz acca accb accc accd acce accf accg acch acci accj acck accl accm accn acco accp accq accr accs acct accu accv accw accx accy accz acda acdb acdc acdd acde acdf acdg acdh acdi acdj acdk acdl acdm acdn acdo acdp acdq acdr acds acdt acdu acdv acdw acdx acdy acdz acea aceb acec aced acee acef aceg aceh acei acej acek acel acem acen aceo acep aceq acer aces acet aceu acev acew acex acey acez acfa acfb acfc acfd acfe acff acfg acfh acfi acfj acfk acfl acfm acfn acfo acfp acfq acfr acfs acft acfu acfv acfw acfx acfy acfz acga acgb acgc acgd acge acgf acgg acgh acgi acgj acgk acgl acgm acgn acgo acgp acgq acgr acgs acgt acgu acgv acgw acgx acgy acgz acha achb achc achd ache achf achg achh achi achj achk achl achm achn acho achp achq achr achs acht achu achv achw achx achy achz acia acib acic acid acie acif acig acih acii acij acik acil acim acin acio acip aciq acir acis acit aciu aciv aciw acix aciy aciz acja acjb acjc acjd acje acjf acjg acjh acji acjj acjk acjl acjm acjn acjo acjp acjq acjr acjs acjt acju acjv acjw acjx acjy acjz acka ackb ackc ackd acke ackf ackg ackh acki ackj ackk ackl ackm ackn acko ackp ackq ackr acks ackt acku ackv ackw ackx acky ackz acla aclb aclc acld acle aclf aclg aclh acli aclj aclk acll aclm acln aclo aclp aclq aclr acls aclt aclu aclv aclw aclx acly aclz acma acmb acmc acmd acme acmf acmg acmh acmi acmj acmk acml acmm acmn acmo acmp acmq acmr acms acmt acmu acmv acmw acmx acmy acmz acna acnb acnc acnd acne acnf acng acnh acni acnj acnk acnl acnm acnn acno acnp acnq acnr acns acnt acnu acnv acnw acnx acny acnz acoa acob acoc acod acoe acof acog acoh acoi acoj acok acol acom acon acoo acop acoq acor acos acot acou acov acow acox acoy acoz acpa acpb acpc acpd acpe acpf acpg acph acpi acpj acpk acpl acpm acpn acpo acpp acpq acpr acps acpt acpu acpv acpw acpx acpy acpz acqa acqb acqc acqd acqe acqf acqg acqh acqi acqj acqk acql acqm acqn acqo acqp acqq acqr acqs acqt acqu acqv acqw acqx acqy acqz acra acrb acrc acrd acre acrf acrg acrh acri acrj acrk acrl acrm acrn acro acrp acrq acrr acrs acrt acru acrv acrw acrx acry acrz acsa acsb acsc acsd acse acsf acsg acsh acsi acsj acsk acsl acsm acsn acso acsp acsq acsr acss acst acsu acsv acsw acsx acsy acsz acta actb actc actd acte actf actg acth acti actj actk actl actm actn acto actp actq actr acts actt actu actv actw actx acty actz acua acub acuc acud acue acuf acug acuh acui acuj acuk acul acum acun acuo acup acuq acur acus acut acuu acuv acuw acux acuy acuz acva acvb acvc acvd acve acvf acvg acvh acvi acvj acvk acvl acvm acvn acvo acvp acvq acvr acvs acvt acvu acvv acvw acvx acvy acvz acwa acwb acwc acwd acwe acwf acwg acwh acwi acwj acwk acwl acwm acwn acwo acwp acwq acwr acws acwt acwu acwv acww acwx acwy acwz acxa acxb acxc acxd acxe acxf acxg acxh acxi acxj acxk acxl acxm acxn acxo acxp acxq acxr acxs acxt acxu acxv acxw acxx acxy acxz acya acyb acyc acyd acye acyf acyg acyh acyi acyj acyk acyl acym acyn acyo acyp acyq acyr acys acyt acyu acyv acyw acyx acyy acyz acza aczb aczc aczd acze aczf aczg aczh aczi aczj aczk aczl aczm aczn aczo aczp aczq aczr aczs aczt aczu aczv aczw aczx aczy aczz adaa adab adac adad adae adaf adag adah adai adaj adak adal adam adan adao adap adaq adar adas adat adau adav adaw adax aday adaz adba adbb adbc adbd adbe adbf adbg adbh adbi adbj adbk adbl adbm adbn adbo adbp adbq adbr adbs adbt adbu adbv adbw adbx adby adbz adca adcb adcc adcd adce adcf adcg adch adci adcj adck adcl adcm adcn adco adcp adcq adcr adcs adct adcu adcv adcw adcx adcy adcz adda addb addc addd adde addf addg addh addi addj addk addl addm addn addo addp addq addr adds addt addu addv addw addx addy addz adea adeb adec aded adee adef adeg adeh adei adej adek adel adem aden adeo adep adeq ader ades adet adeu adev adew adex adey adez adfa adfb adfc adfd adfe adff adfg adfh adfi adfj adfk adfl adfm adfn adfo adfp adfq adfr adfs adft adfu adfv adfw adfx adfy adfz adga adgb adgc adgd adge adgf adgg adgh adgi adgj adgk adgl adgm adgn adgo adgp adgq adgr adgs adgt adgu adgv adgw adgx adgy adgz adha adhb adhc adhd adhe adhf adhg adhh adhi adhj adhk adhl adhm adhn adho adhp adhq adhr adhs adht adhu adhv adhw adhx adhy adhz adia adib adic adid adie adif adig adih adii adij adik adil adim adin adio adip adiq adir adis adit adiu adiv adiw adix adiy adiz adja adjb adjc adjd adje adjf adjg adjh adji adjj adjk adjl adjm adjn adjo adjp adjq adjr adjs adjt adju adjv adjw adjx adjy adjz adka adkb adkc adkd adke adkf adkg adkh adki adkj adkk adkl adkm adkn adko adkp adkq adkr adks adkt adku adkv adkw adkx adky adkz adla adlb adlc adld adle adlf adlg adlh adli adlj adlk adll adlm adln adlo adlp adlq adlr adls adlt adlu adlv adlw adlx adly adlz adma admb admc admd adme admf admg admh admi admj admk adml admm admn admo admp admq admr adms admt admu admv admw admx admy admz adna adnb adnc adnd adne adnf adng adnh adni adnj adnk adnl adnm adnn adno adnp adnq adnr adns adnt adnu adnv adnw adnx adny adnz adoa adob adoc adod adoe adof adog adoh adoi adoj adok adol adom adon adoo adop adoq ador ados adot adou adov adow adox adoy adoz adpa adpb adpc adpd adpe adpf adpg adph adpi adpj adpk adpl adpm adpn adpo adpp adpq adpr adps adpt adpu adpv adpw adpx adpy adpz adqa adqb adqc adqd adqe adqf adqg adqh adqi adqj adqk adql adqm adqn adqo adqp adqq adqr adqs adqt adqu adqv adqw adqx adqy adqz adra adrb adrc adrd adre adrf adrg adrh adri adrj adrk adrl adrm adrn adro adrp adrq adrr adrs adrt adru adrv adrw adrx adry adrz adsa adsb adsc adsd adse adsf adsg adsh adsi adsj adsk adsl adsm adsn adso adsp adsq adsr adss adst adsu adsv adsw adsx adsy adsz adta adtb adtc adtd adte adtf adtg adth adti adtj adtk adtl adtm adtn adto adtp adtq adtr adts adtt adtu adtv adtw adtx adty adtz adua adub aduc adud adue aduf adug aduh adui aduj aduk adul adum adun aduo adup aduq adur adus adut aduu aduv aduw adux aduy aduz adva advb advc advd adve advf advg advh advi advj advk advl advm advn advo advp advq advr advs advt advu advv advw advx advy advz adwa adwb adwc adwd adwe adwf adwg adwh adwi adwj adwk adwl adwm adwn adwo adwp adwq adwr adws adwt adwu adwv adww adwx adwy adwz adxa adxb adxc adxd adxe adxf adxg adxh adxi adxj adxk adxl adxm adxn adxo adxp adxq adxr adxs adxt adxu adxv adxw adxx adxy adxz adya adyb adyc adyd adye adyf adyg adyh adyi adyj adyk adyl adym adyn adyo adyp adyq adyr adys adyt adyu adyv adyw adyx adyy adyz adza adzb adzc adzd adze adzf adzg adzh adzi adzj adzk adzl adzm adzn adzo adzp adzq adzr adzs adzt adzu adzv adzw adzx adzy adzz aeaa aeab aeac aead aeae aeaf aeag aeah aeai aeaj aeak aeal aeam aean aeao aeap aeaq aear aeas aeat aeau aeav aeaw aeax aeay aeaz aeba aebb aebc aebd aebe aebf aebg aebh aebi aebj aebk aebl aebm aebn aebo aebp aebq aebr aebs aebt aebu aebv aebw aebx aeby aebz aeca aecb aecc aecd aece aecf aecg aech aeci aecj aeck aecl aecm aecn aeco aecp aecq aecr aecs aect aecu aecv aecw aecx aecy aecz aeda aedb aedc aedd aede aedf aedg aedh aedi aedj aedk aedl aedm aedn aedo aedp aedq aedr aeds aedt aedu aedv aedw aedx aedy aedz aeea aeeb aeec aeed aeee aeef aeeg aeeh aeei aeej aeek aeel aeem aeen aeeo aeep aeeq aeer aees aeet aeeu aeev aeew aeex aeey aeez aefa aefb aefc aefd aefe aeff aefg aefh aefi aefj aefk aefl aefm aefn aefo aefp aefq aefr aefs aeft aefu aefv aefw aefx aefy aefz aega aegb aegc aegd aege aegf aegg aegh aegi aegj aegk aegl aegm aegn aego aegp aegq aegr aegs aegt aegu aegv aegw aegx aegy aegz aeha aehb aehc aehd aehe aehf aehg aehh aehi aehj aehk aehl aehm aehn aeho aehp aehq aehr aehs aeht aehu aehv aehw aehx aehy aehz aeia aeib aeic aeid aeie aeif aeig aeih aeii aeij aeik aeil aeim aein aeio aeip aeiq aeir aeis aeit aeiu aeiv aeiw aeix aeiy aeiz aeja aejb aejc aejd aeje aejf aejg aejh aeji aejj aejk aejl aejm aejn aejo aejp aejq aejr aejs aejt aeju aejv aejw aejx aejy aejz aeka aekb aekc aekd aeke aekf aekg aekh aeki aekj aekk aekl aekm aekn aeko aekp aekq aekr aeks aekt aeku aekv aekw aekx aeky aekz aela aelb aelc aeld aele aelf aelg aelh aeli aelj aelk aell aelm aeln aelo aelp aelq aelr aels aelt aelu aelv aelw aelx aely aelz aema aemb aemc aemd aeme aemf aemg aemh aemi aemj aemk aeml aemm aemn aemo aemp aemq aemr aems aemt aemu aemv aemw aemx aemy aemz aena aenb aenc aend aene aenf aeng aenh aeni aenj aenk aenl aenm aenn aeno aenp aenq aenr aens aent aenu aenv aenw aenx aeny aenz aeoa aeob aeoc aeod aeoe aeof aeog aeoh aeoi aeoj aeok aeol aeom aeon aeoo aeop aeoq aeor aeos aeot aeou aeov aeow aeox aeoy aeoz aepa aepb aepc aepd aepe aepf aepg aeph aepi aepj aepk aepl aepm aepn aepo aepp aepq aepr aeps aept aepu aepv aepw aepx aepy aepz aeqa aeqb aeqc aeqd aeqe aeqf aeqg aeqh aeqi aeqj aeqk aeql aeqm aeqn aeqo aeqp aeqq aeqr aeqs aeqt aequ aeqv aeqw aeqx aeqy aeqz aera aerb aerc aerd aere aerf aerg aerh aeri aerj aerk aerl aerm aern aero aerp aerq aerr aers aert aeru aerv aerw aerx aery aerz aesa aesb aesc aesd aese aesf aesg aesh aesi aesj aesk aesl aesm aesn aeso aesp aesq aesr aess aest aesu aesv aesw aesx aesy aesz aeta aetb aetc aetd aete aetf aetg aeth aeti aetj aetk aetl aetm aetn aeto aetp aetq aetr aets aett aetu aetv aetw aetx aety aetz aeua aeub aeuc aeud aeue aeuf aeug aeuh aeui aeuj aeuk aeul aeum aeun aeuo aeup aeuq aeur aeus aeut aeuu aeuv aeuw aeux aeuy aeuz aeva aevb aevc aevd aeve aevf aevg aevh aevi aevj aevk aevl aevm aevn aevo aevp aevq aevr aevs aevt aevu aevv aevw aevx aevy aevz aewa aewb aewc aewd aewe aewf aewg aewh aewi aewj aewk aewl aewm aewn aewo aewp aewq aewr aews aewt aewu aewv aeww aewx aewy aewz aexa aexb aexc aexd aexe aexf aexg aexh aexi aexj aexk aexl aexm aexn aexo aexp aexq aexr aexs aext aexu aexv aexw aexx aexy aexz aeya aeyb aeyc aeyd aeye aeyf aeyg aeyh aeyi aeyj aeyk aeyl aeym aeyn aeyo aeyp aeyq aeyr aeys aeyt aeyu aeyv aeyw aeyx aeyy aeyz aeza aezb aezc aezd aeze aezf aezg aezh aezi aezj aezk aezl aezm aezn aezo aezp aezq aezr aezs aezt aezu aezv aezw aezx aezy aezz afaa afab afac afad afae afaf afag afah afai afaj afak afal afam afan afao afap afaq afar afas afat afau afav afaw afax afay afaz afba afbb afbc afbd afbe afbf afbg afbh afbi afbj afbk afbl afbm afbn afbo afbp afbq afbr afbs afbt afbu afbv afbw afbx afby afbz afca afcb afcc afcd afce afcf afcg afch afci afcj afck afcl afcm afcn afco afcp afcq afcr afcs afct afcu afcv afcw afcx afcy afcz afda afdb afdc afdd afde afdf afdg afdh afdi afdj afdk afdl afdm afdn afdo afdp afdq afdr afds afdt afdu afdv afdw afdx afdy afdz afea afeb afec afed afee afef afeg afeh afei afej afek afel afem afen afeo afep afeq afer afes afet afeu afev afew afex afey afez affa affb affc affd affe afff affg affh affi affj affk affl affm affn affo affp affq affr affs afft affu affv affw affx affy affz afga afgb afgc afgd afge afgf afgg afgh afgi afgj afgk afgl afgm afgn afgo afgp afgq afgr afgs afgt afgu afgv afgw afgx afgy afgz afha afhb afhc afhd afhe afhf afhg afhh afhi afhj afhk afhl afhm afhn afho afhp afhq afhr afhs afht afhu afhv afhw afhx afhy afhz afia afib afic afid afie afif afig afih afii afij afik afil afim afin afio afip afiq afir afis afit afiu afiv afiw afix afiy afiz afja afjb afjc afjd afje afjf afjg afjh afji afjj afjk afjl afjm afjn afjo afjp afjq afjr afjs afjt afju afjv afjw afjx afjy afjz afka afkb afkc afkd afke afkf afkg afkh afki afkj afkk afkl afkm afkn afko afkp afkq afkr afks afkt afku afkv afkw afkx afky afkz afla aflb aflc afld afle aflf aflg aflh afli aflj aflk afll aflm afln aflo aflp aflq aflr afls aflt aflu aflv aflw aflx afly aflz afma afmb afmc afmd afme afmf afmg afmh afmi afmj afmk afml afmm afmn afmo afmp afmq afmr afms afmt afmu afmv afmw afmx afmy afmz afna afnb afnc afnd afne afnf afng afnh afni afnj afnk afnl afnm afnn afno afnp afnq afnr afns afnt afnu afnv afnw afnx afny afnz afoa afob afoc afod afoe afof afog afoh afoi afoj afok afol afom afon afoo afop afoq afor afos afot afou afov afow afox afoy afoz afpa afpb afpc afpd afpe afpf afpg afph afpi afpj afpk afpl afpm afpn afpo afpp afpq afpr afps afpt afpu afpv afpw afpx afpy afpz afqa afqb afqc afqd afqe afqf afqg afqh afqi afqj afqk afql afqm afqn afqo afqp afqq afqr afqs afqt afqu afqv afqw afqx afqy afqz afra afrb afrc afrd afre afrf afrg afrh afri afrj afrk afrl afrm afrn afro afrp afrq afrr afrs afrt afru afrv afrw afrx afry afrz afsa afsb afsc afsd afse afsf afsg afsh afsi afsj afsk afsl afsm afsn afso afsp afsq afsr afss afst afsu afsv afsw afsx afsy afsz afta aftb aftc aftd afte aftf aftg afth afti aftj aftk aftl aftm aftn afto aftp aftq aftr afts aftt aftu aftv aftw aftx afty aftz afua afub afuc afud afue afuf afug afuh afui afuj afuk aful afum afun afuo afup afuq afur afus afut afuu afuv afuw afux afuy afuz afva afvb afvc afvd afve afvf afvg afvh afvi afvj afvk afvl afvm afvn afvo afvp afvq afvr afvs afvt afvu afvv afvw afvx afvy afvz afwa afwb afwc afwd afwe afwf afwg afwh afwi afwj afwk afwl afwm afwn afwo afwp afwq afwr afws afwt afwu afwv afww afwx afwy afwz afxa afxb afxc afxd afxe afxf afxg afxh afxi afxj afxk afxl afxm afxn afxo afxp afxq afxr afxs afxt afxu afxv afxw afxx afxy afxz afya afyb afyc afyd afye afyf afyg afyh afyi afyj afyk afyl afym afyn afyo afyp afyq afyr afys afyt afyu afyv afyw afyx afyy afyz afza afzb afzc afzd afze afzf afzg afzh afzi afzj afzk afzl afzm afzn afzo afzp afzq afzr afzs afzt afzu afzv afzw afzx afzy afzz agaa agab agac agad agae agaf agag agah agai agaj agak agal agam agan agao agap agaq agar agas agat agau agav agaw agax agay agaz agba agbb agbc agbd agbe agbf agbg agbh agbi agbj agbk agbl agbm agbn agbo agbp agbq agbr agbs agbt agbu agbv agbw agbx agby agbz agca agcb agcc agcd agce agcf agcg agch agci agcj agck agcl agcm agcn agco agcp agcq agcr agcs agct agcu agcv agcw agcx agcy agcz agda agdb agdc agdd agde agdf agdg agdh agdi agdj agdk agdl agdm agdn agdo agdp agdq agdr agds agdt agdu agdv agdw agdx agdy agdz agea ageb agec aged agee agef ageg ageh agei agej agek agel agem agen ageo agep ageq ager ages aget ageu agev agew agex agey agez agfa agfb agfc agfd agfe agff agfg agfh agfi agfj agfk agfl agfm agfn agfo agfp agfq agfr agfs agft agfu agfv agfw agfx agfy agfz agga aggb aggc aggd agge aggf aggg aggh aggi aggj aggk aggl aggm aggn aggo aggp aggq aggr aggs aggt aggu aggv aggw aggx aggy aggz agha aghb aghc aghd aghe aghf aghg aghh aghi aghj aghk aghl aghm aghn agho aghp aghq aghr aghs aght aghu aghv aghw aghx aghy aghz agia agib agic agid agie agif agig agih agii agij agik agil agim agin agio agip agiq agir agis agit agiu agiv agiw agix agiy agiz agja agjb agjc agjd agje agjf agjg agjh agji agjj agjk agjl agjm agjn agjo agjp agjq agjr agjs agjt agju agjv agjw agjx agjy agjz agka agkb agkc agkd agke agkf agkg agkh agki agkj agkk agkl agkm agkn agko agkp agkq agkr agks agkt agku agkv agkw agkx agky agkz agla aglb aglc agld agle aglf aglg aglh agli aglj aglk agll aglm agln aglo aglp aglq aglr agls aglt aglu aglv aglw aglx agly aglz agma agmb agmc agmd agme agmf agmg agmh agmi agmj agmk agml agmm agmn agmo agmp agmq agmr agms agmt agmu agmv agmw agmx agmy agmz agna agnb agnc agnd agne agnf agng agnh agni agnj agnk agnl agnm agnn agno agnp agnq agnr agns agnt agnu agnv agnw agnx agny agnz agoa agob agoc agod agoe agof agog agoh agoi agoj agok agol agom agon agoo agop agoq agor agos agot agou agov agow agox agoy agoz agpa agpb agpc agpd agpe agpf agpg agph agpi agpj agpk agpl agpm agpn agpo agpp agpq agpr agps agpt agpu agpv agpw agpx agpy agpz agqa agqb agqc agqd agqe agqf agqg agqh agqi agqj agqk agql agqm agqn agqo agqp agqq agqr agqs agqt agqu agqv agqw agqx agqy agqz agra agrb agrc agrd agre agrf agrg agrh agri agrj agrk agrl agrm agrn agro agrp agrq agrr agrs agrt agru agrv agrw agrx agry agrz agsa agsb agsc agsd agse agsf agsg agsh agsi agsj agsk agsl agsm agsn agso agsp agsq agsr agss agst agsu agsv agsw agsx agsy agsz agta agtb agtc agtd agte agtf agtg agth agti agtj agtk agtl agtm agtn agto agtp agtq agtr agts agtt agtu agtv agtw agtx agty agtz agua agub aguc agud ague aguf agug aguh agui aguj aguk agul agum agun aguo agup aguq agur agus agut aguu aguv aguw agux aguy aguz agva agvb agvc agvd agve agvf agvg agvh agvi agvj agvk agvl agvm agvn agvo agvp agvq agvr agvs agvt agvu agvv agvw agvx agvy agvz agwa agwb agwc agwd agwe agwf agwg agwh agwi agwj agwk agwl agwm agwn agwo agwp agwq agwr agws agwt agwu agwv agww agwx agwy agwz agxa agxb agxc agxd agxe agxf agxg agxh agxi agxj agxk agxl agxm agxn agxo agxp agxq agxr agxs agxt agxu agxv agxw agxx agxy agxz agya agyb agyc agyd agye agyf agyg agyh agyi agyj agyk agyl agym agyn agyo agyp agyq agyr agys agyt agyu agyv agyw agyx agyy agyz agza agzb agzc agzd agze agzf agzg agzh agzi agzj agzk agzl agzm agzn agzo agzp agzq agzr agzs agzt agzu agzv agzw agzx agzy agzz ahaa ahab ahac ahad ahae ahaf ahag ahah ahai ahaj ahak ahal aham ahan ahao ahap ahaq ahar ahas ahat ahau ahav ahaw ahax ahay ahaz ahba ahbb ahbc ahbd ahbe ahbf ahbg ahbh ahbi ahbj ahbk ahbl ahbm ahbn ahbo ahbp ahbq ahbr ahbs ahbt ahbu ahbv ahbw ahbx ahby ahbz ahca ahcb ahcc ahcd ahce ahcf ahcg ahch ahci ahcj ahck ahcl ahcm ahcn ahco ahcp ahcq ahcr ahcs ahct ahcu ahcv ahcw ahcx ahcy ahcz ahda ahdb ahdc ahdd ahde ahdf ahdg ahdh ahdi ahdj ahdk ahdl ahdm ahdn ahdo ahdp ahdq ahdr ahds ahdt ahdu ahdv ahdw ahdx ahdy ahdz ahea aheb ahec ahed ahee ahef aheg aheh ahei ahej ahek ahel ahem ahen aheo ahep aheq aher ahes ahet aheu ahev ahew ahex ahey ahez ahfa ahfb ahfc ahfd ahfe ahff ahfg ahfh ahfi ahfj ahfk ahfl ahfm ahfn ahfo ahfp ahfq ahfr ahfs ahft ahfu ahfv ahfw ahfx ahfy ahfz ahga ahgb ahgc ahgd ahge ahgf ahgg ahgh ahgi ahgj ahgk ahgl ahgm ahgn ahgo ahgp ahgq ahgr ahgs ahgt ahgu ahgv ahgw ahgx ahgy ahgz ahha ahhb ahhc ahhd ahhe ahhf ahhg ahhh ahhi ahhj ahhk ahhl ahhm ahhn ahho ahhp ahhq ahhr ahhs ahht ahhu ahhv ahhw ahhx ahhy ahhz ahia ahib ahic ahid ahie ahif ahig ahih ahii ahij ahik ahil ahim ahin ahio ahip ahiq ahir ahis ahit ahiu ahiv ahiw ahix ahiy ahiz ahja ahjb ahjc ahjd ahje ahjf ahjg ahjh ahji ahjj ahjk ahjl ahjm ahjn ahjo ahjp ahjq ahjr ahjs ahjt ahju ahjv ahjw ahjx ahjy ahjz ahka ahkb ahkc ahkd ahke ahkf ahkg ahkh ahki ahkj ahkk ahkl ahkm ahkn ahko ahkp ahkq ahkr ahks ahkt ahku ahkv ahkw ahkx ahky ahkz ahla ahlb ahlc ahld ahle ahlf ahlg ahlh ahli ahlj ahlk ahll ahlm ahln ahlo ahlp ahlq ahlr ahls ahlt ahlu ahlv ahlw ahlx ahly ahlz ahma ahmb ahmc ahmd ahme ahmf ahmg ahmh ahmi ahmj ahmk ahml ahmm ahmn ahmo ahmp ahmq ahmr ahms ahmt ahmu ahmv ahmw ahmx ahmy ahmz ahna ahnb ahnc ahnd ahne ahnf ahng ahnh ahni ahnj ahnk ahnl ahnm ahnn ahno ahnp ahnq ahnr ahns ahnt ahnu ahnv ahnw ahnx ahny ahnz ahoa ahob ahoc ahod ahoe ahof ahog ahoh ahoi ahoj ahok ahol ahom ahon ahoo ahop ahoq ahor ahos ahot ahou ahov ahow ahox ahoy ahoz ahpa ahpb ahpc ahpd ahpe ahpf ahpg ahph ahpi ahpj ahpk ahpl ahpm ahpn ahpo ahpp ahpq ahpr ahps ahpt ahpu ahpv ahpw ahpx ahpy ahpz ahqa ahqb ahqc ahqd ahqe ahqf ahqg ahqh ahqi ahqj ahqk ahql ahqm ahqn ahqo ahqp ahqq ahqr ahqs ahqt ahqu ahqv ahqw ahqx ahqy ahqz ahra ahrb ahrc ahrd ahre ahrf ahrg ahrh ahri ahrj ahrk ahrl ahrm ahrn ahro ahrp ahrq ahrr ahrs ahrt ahru ahrv ahrw ahrx ahry ahrz ahsa ahsb ahsc ahsd ahse ahsf ahsg ahsh ahsi ahsj ahsk ahsl ahsm ahsn ahso ahsp ahsq ahsr ahss ahst ahsu ahsv ahsw ahsx ahsy ahsz ahta ahtb ahtc ahtd ahte ahtf ahtg ahth ahti ahtj ahtk ahtl ahtm ahtn ahto ahtp ahtq ahtr ahts ahtt ahtu ahtv ahtw ahtx ahty ahtz ahua ahub ahuc ahud ahue ahuf ahug ahuh ahui ahuj ahuk ahul ahum ahun ahuo ahup ahuq ahur ahus ahut ahuu ahuv ahuw ahux ahuy ahuz ahva ahvb ahvc ahvd ahve ahvf ahvg ahvh ahvi ahvj ahvk ahvl ahvm ahvn ahvo ahvp ahvq ahvr ahvs ahvt ahvu ahvv ahvw ahvx ahvy ahvz ahwa ahwb ahwc ahwd ahwe ahwf ahwg ahwh ahwi ahwj ahwk ahwl ahwm ahwn ahwo ahwp ahwq ahwr ahws ahwt ahwu ahwv ahww ahwx ahwy ahwz ahxa ahxb ahxc ahxd ahxe ahxf ahxg ahxh ahxi ahxj ahxk ahxl ahxm ahxn ahxo ahxp ahxq ahxr ahxs ahxt ahxu ahxv ahxw ahxx ahxy ahxz ahya ahyb ahyc ahyd ahye ahyf ahyg ahyh ahyi ahyj ahyk ahyl ahym ahyn ahyo ahyp ahyq ahyr ahys ahyt ahyu ahyv ahyw ahyx ahyy ahyz ahza ahzb ahzc ahzd ahze ahzf ahzg ahzh ahzi ahzj ahzk ahzl ahzm ahzn ahzo ahzp ahzq ahzr ahzs ahzt ahzu ahzv ahzw ahzx ahzy ahzz aiaa aiab aiac aiad aiae aiaf aiag aiah aiai aiaj aiak aial aiam aian aiao aiap aiaq aiar aias aiat aiau aiav aiaw aiax aiay aiaz aiba aibb aibc aibd aibe aibf aibg aibh aibi aibj aibk aibl aibm aibn aibo aibp aibq aibr aibs aibt aibu aibv aibw aibx aiby aibz aica aicb aicc aicd aice aicf aicg aich aici aicj aick aicl aicm aicn aico aicp aicq aicr aics aict aicu aicv aicw aicx aicy aicz aida aidb aidc aidd aide aidf aidg aidh aidi aidj aidk aidl aidm aidn aido aidp aidq aidr aids aidt aidu aidv aidw aidx aidy aidz aiea aieb aiec aied aiee aief aieg aieh aiei aiej aiek aiel aiem aien aieo aiep aieq aier aies aiet aieu aiev aiew aiex aiey aiez aifa aifb aifc aifd aife aiff aifg aifh aifi aifj aifk aifl aifm aifn aifo aifp aifq aifr aifs aift aifu aifv aifw aifx aify aifz aiga aigb aigc aigd aige aigf aigg aigh aigi aigj aigk aigl aigm aign aigo aigp aigq aigr aigs aigt aigu aigv aigw aigx aigy aigz aiha aihb aihc aihd aihe aihf aihg aihh aihi aihj aihk aihl aihm aihn aiho aihp aihq aihr aihs aiht aihu aihv aihw aihx aihy aihz aiia aiib aiic aiid aiie aiif aiig aiih aiii aiij aiik aiil aiim aiin aiio aiip aiiq aiir aiis aiit aiiu aiiv aiiw aiix aiiy aiiz aija aijb aijc aijd aije aijf aijg aijh aiji aijj aijk aijl aijm aijn aijo aijp aijq aijr aijs aijt aiju aijv aijw aijx aijy aijz aika aikb aikc aikd aike aikf aikg aikh aiki aikj aikk aikl aikm aikn aiko aikp aikq aikr aiks aikt aiku aikv aikw aikx aiky aikz aila ailb ailc aild aile ailf ailg ailh aili ailj ailk aill ailm ailn ailo ailp ailq ailr ails ailt ailu ailv ailw ailx aily ailz aima aimb aimc aimd aime aimf aimg aimh aimi aimj aimk aiml aimm aimn aimo aimp aimq aimr aims aimt aimu aimv aimw aimx aimy aimz aina ainb ainc aind aine ainf aing ainh aini ainj aink ainl ainm ainn aino ainp ainq ainr ains aint ainu ainv ainw ainx ainy ainz aioa aiob aioc aiod aioe aiof aiog aioh aioi aioj aiok aiol aiom aion aioo aiop aioq aior aios aiot aiou aiov aiow aiox aioy aioz aipa aipb aipc aipd aipe aipf aipg aiph aipi aipj aipk aipl aipm aipn aipo aipp aipq aipr aips aipt aipu aipv aipw aipx aipy aipz aiqa aiqb aiqc aiqd aiqe aiqf aiqg aiqh aiqi aiqj aiqk aiql aiqm aiqn aiqo aiqp aiqq aiqr aiqs aiqt aiqu aiqv aiqw aiqx aiqy aiqz aira airb airc aird aire airf airg airh airi airj airk airl airm airn airo airp airq airr airs airt airu airv airw airx airy airz aisa aisb aisc aisd aise aisf aisg aish aisi aisj aisk aisl aism aisn aiso aisp aisq aisr aiss aist aisu aisv aisw aisx aisy aisz aita aitb aitc aitd aite aitf aitg aith aiti aitj aitk aitl aitm aitn aito aitp aitq aitr aits aitt aitu aitv aitw aitx aity aitz aiua aiub aiuc aiud aiue aiuf aiug aiuh aiui aiuj aiuk aiul aium aiun aiuo aiup aiuq aiur aius aiut aiuu aiuv aiuw aiux aiuy aiuz aiva aivb aivc aivd aive aivf aivg aivh aivi aivj aivk aivl aivm aivn aivo aivp aivq aivr aivs aivt aivu aivv aivw aivx aivy aivz aiwa aiwb aiwc aiwd aiwe aiwf aiwg aiwh aiwi aiwj aiwk aiwl aiwm aiwn aiwo aiwp aiwq aiwr aiws aiwt aiwu aiwv aiww aiwx aiwy aiwz aixa aixb aixc aixd aixe aixf aixg aixh aixi aixj aixk aixl aixm aixn aixo aixp aixq aixr aixs aixt aixu aixv aixw aixx aixy aixz aiya aiyb aiyc aiyd aiye aiyf aiyg aiyh aiyi aiyj aiyk aiyl aiym aiyn aiyo aiyp aiyq aiyr aiys aiyt aiyu aiyv aiyw aiyx aiyy aiyz aiza aizb aizc aizd aize aizf aizg aizh aizi aizj aizk aizl aizm aizn aizo aizp aizq aizr aizs aizt aizu aizv aizw aizx aizy aizz ajaa ajab ajac ajad ajae ajaf ajag ajah ajai ajaj ajak ajal ajam ajan ajao ajap ajaq ajar ajas ajat ajau ajav ajaw ajax ajay ajaz ajba ajbb ajbc ajbd ajbe ajbf ajbg ajbh ajbi ajbj ajbk ajbl ajbm ajbn ajbo ajbp ajbq ajbr ajbs ajbt ajbu ajbv ajbw ajbx ajby ajbz ajca ajcb ajcc ajcd ajce ajcf ajcg ajch ajci ajcj ajck ajcl ajcm ajcn ajco ajcp ajcq ajcr ajcs ajct ajcu ajcv ajcw ajcx ajcy ajcz ajda ajdb ajdc ajdd ajde ajdf ajdg ajdh ajdi ajdj ajdk ajdl ajdm ajdn ajdo ajdp ajdq ajdr ajds ajdt ajdu ajdv ajdw ajdx ajdy ajdz ajea ajeb ajec ajed ajee ajef ajeg ajeh ajei ajej ajek ajel ajem ajen ajeo ajep ajeq ajer ajes ajet ajeu ajev ajew ajex ajey ajez ajfa ajfb ajfc ajfd ajfe ajff ajfg ajfh ajfi ajfj ajfk ajfl ajfm ajfn ajfo ajfp ajfq ajfr ajfs ajft ajfu ajfv ajfw ajfx ajfy ajfz ajga ajgb ajgc ajgd ajge ajgf ajgg ajgh ajgi ajgj ajgk ajgl ajgm ajgn ajgo ajgp ajgq ajgr ajgs ajgt ajgu ajgv ajgw ajgx ajgy ajgz ajha ajhb ajhc ajhd ajhe ajhf ajhg ajhh ajhi ajhj ajhk ajhl ajhm ajhn ajho ajhp ajhq ajhr ajhs ajht ajhu ajhv ajhw ajhx ajhy ajhz ajia ajib ajic ajid ajie ajif ajig ajih ajii ajij ajik ajil ajim ajin ajio ajip ajiq ajir ajis ajit ajiu ajiv ajiw ajix ajiy ajiz ajja ajjb ajjc ajjd ajje ajjf ajjg ajjh ajji ajjj ajjk ajjl ajjm ajjn ajjo ajjp ajjq ajjr ajjs ajjt ajju ajjv ajjw ajjx ajjy ajjz ajka ajkb ajkc ajkd ajke ajkf ajkg ajkh ajki ajkj ajkk ajkl ajkm ajkn ajko ajkp ajkq ajkr ajks ajkt ajku ajkv ajkw ajkx ajky ajkz ajla ajlb ajlc ajld ajle ajlf ajlg ajlh ajli ajlj ajlk ajll ajlm ajln ajlo ajlp ajlq ajlr ajls ajlt ajlu ajlv ajlw ajlx ajly ajlz ajma ajmb ajmc ajmd ajme ajmf ajmg ajmh ajmi ajmj ajmk ajml ajmm ajmn ajmo ajmp ajmq ajmr ajms ajmt ajmu ajmv ajmw ajmx ajmy ajmz ajna ajnb ajnc ajnd ajne ajnf ajng ajnh ajni ajnj ajnk ajnl ajnm ajnn ajno ajnp ajnq ajnr ajns ajnt ajnu ajnv ajnw ajnx ajny ajnz ajoa ajob ajoc ajod ajoe ajof ajog ajoh ajoi ajoj ajok ajol ajom ajon ajoo ajop ajoq ajor ajos ajot ajou ajov ajow ajox ajoy ajoz ajpa ajpb ajpc ajpd ajpe ajpf ajpg ajph ajpi ajpj ajpk ajpl ajpm ajpn ajpo ajpp ajpq ajpr ajps ajpt ajpu ajpv ajpw ajpx ajpy ajpz ajqa ajqb ajqc ajqd ajqe ajqf ajqg ajqh ajqi ajqj ajqk ajql ajqm ajqn ajqo ajqp ajqq ajqr ajqs ajqt ajqu ajqv ajqw ajqx ajqy ajqz ajra ajrb ajrc ajrd ajre ajrf ajrg ajrh ajri ajrj ajrk ajrl ajrm ajrn ajro ajrp ajrq ajrr ajrs ajrt ajru ajrv ajrw ajrx ajry ajrz ajsa ajsb ajsc ajsd ajse ajsf ajsg ajsh ajsi ajsj ajsk ajsl ajsm ajsn ajso ajsp ajsq ajsr ajss ajst ajsu ajsv ajsw ajsx ajsy ajsz ajta ajtb ajtc ajtd ajte ajtf ajtg ajth ajti ajtj ajtk ajtl ajtm ajtn ajto ajtp ajtq ajtr ajts ajtt ajtu ajtv ajtw ajtx ajty ajtz ajua ajub ajuc ajud ajue ajuf ajug ajuh ajui ajuj ajuk ajul ajum ajun ajuo ajup ajuq ajur ajus ajut ajuu ajuv ajuw ajux ajuy ajuz ajva ajvb ajvc ajvd ajve ajvf ajvg ajvh ajvi ajvj ajvk ajvl ajvm ajvn ajvo ajvp ajvq ajvr ajvs ajvt ajvu ajvv ajvw ajvx ajvy ajvz ajwa ajwb ajwc ajwd ajwe ajwf ajwg ajwh ajwi ajwj ajwk ajwl ajwm ajwn ajwo ajwp ajwq ajwr ajws ajwt ajwu ajwv ajww ajwx ajwy ajwz ajxa ajxb ajxc ajxd ajxe ajxf ajxg ajxh ajxi ajxj ajxk ajxl ajxm ajxn ajxo ajxp ajxq ajxr ajxs ajxt ajxu ajxv ajxw ajxx ajxy ajxz ajya ajyb ajyc ajyd ajye ajyf ajyg ajyh ajyi ajyj ajyk ajyl ajym ajyn ajyo ajyp ajyq ajyr ajys ajyt ajyu ajyv ajyw ajyx ajyy ajyz ajza ajzb ajzc ajzd ajze ajzf ajzg ajzh ajzi ajzj ajzk ajzl ajzm ajzn ajzo ajzp ajzq ajzr ajzs ajzt ajzu ajzv ajzw ajzx ajzy ajzz akaa akab akac akad akae akaf akag akah akai akaj akak akal akam akan akao akap akaq akar akas akat akau akav akaw akax akay akaz akba akbb akbc akbd akbe akbf akbg akbh akbi akbj akbk akbl akbm akbn akbo akbp akbq akbr akbs akbt akbu akbv akbw akbx akby akbz akca akcb akcc akcd akce akcf akcg akch akci akcj akck akcl akcm akcn akco akcp akcq akcr akcs akct akcu akcv akcw akcx akcy akcz akda akdb akdc akdd akde akdf akdg akdh akdi akdj akdk akdl akdm akdn akdo akdp akdq akdr akds akdt akdu akdv akdw akdx akdy akdz akea akeb akec aked akee akef akeg akeh akei akej akek akel akem aken akeo akep akeq aker akes aket akeu akev akew akex akey akez akfa akfb akfc akfd akfe akff akfg akfh akfi akfj akfk akfl akfm akfn akfo akfp akfq akfr akfs akft akfu akfv akfw akfx akfy akfz akga akgb akgc akgd akge akgf akgg akgh akgi akgj akgk akgl akgm akgn akgo akgp akgq akgr akgs akgt akgu akgv akgw akgx akgy akgz akha akhb akhc akhd akhe akhf akhg akhh akhi akhj akhk akhl akhm akhn akho akhp akhq akhr akhs akht akhu akhv akhw akhx akhy akhz akia akib akic akid akie akif akig akih akii akij akik akil akim akin akio akip akiq akir akis akit akiu akiv akiw akix akiy akiz akja akjb akjc akjd akje akjf akjg akjh akji akjj akjk akjl akjm akjn akjo akjp akjq akjr akjs akjt akju akjv akjw akjx akjy akjz akka akkb akkc akkd akke akkf akkg akkh akki akkj akkk akkl akkm akkn akko akkp akkq akkr akks akkt akku akkv akkw akkx akky akkz akla aklb aklc akld akle aklf aklg aklh akli aklj aklk akll aklm akln aklo aklp aklq aklr akls aklt aklu aklv aklw aklx akly aklz akma akmb akmc akmd akme akmf akmg akmh akmi akmj akmk akml akmm akmn akmo akmp akmq akmr akms akmt akmu akmv akmw akmx akmy akmz akna aknb aknc aknd akne aknf akng aknh akni aknj aknk aknl aknm aknn akno aknp aknq aknr akns aknt aknu aknv aknw aknx akny aknz akoa akob akoc akod akoe akof akog akoh akoi akoj akok akol akom akon akoo akop akoq akor akos akot akou akov akow akox akoy akoz akpa akpb akpc akpd akpe akpf akpg akph akpi akpj akpk akpl akpm akpn akpo akpp akpq akpr akps akpt akpu akpv akpw akpx akpy akpz akqa akqb akqc akqd akqe akqf akqg akqh akqi akqj akqk akql akqm akqn akqo akqp akqq akqr akqs akqt akqu akqv akqw akqx akqy akqz akra akrb akrc akrd akre akrf akrg akrh akri akrj akrk akrl akrm akrn akro akrp akrq akrr akrs akrt akru akrv akrw akrx akry akrz aksa aksb aksc aksd akse aksf aksg aksh aksi aksj aksk aksl aksm aksn akso aksp aksq aksr akss akst aksu aksv aksw aksx aksy aksz akta aktb aktc aktd akte aktf aktg akth akti aktj aktk aktl aktm aktn akto aktp aktq aktr akts aktt aktu aktv aktw aktx akty aktz akua akub akuc akud akue akuf akug akuh akui akuj akuk akul akum akun akuo akup akuq akur akus akut akuu akuv akuw akux akuy akuz akva akvb akvc akvd akve akvf akvg akvh akvi akvj akvk akvl akvm akvn akvo akvp akvq akvr akvs akvt akvu akvv akvw akvx akvy akvz akwa akwb akwc akwd akwe akwf akwg akwh akwi akwj akwk akwl akwm akwn akwo akwp akwq akwr akws akwt akwu akwv akww akwx akwy akwz akxa akxb akxc akxd akxe akxf akxg akxh akxi akxj akxk akxl akxm akxn akxo akxp akxq akxr akxs akxt akxu akxv akxw akxx akxy akxz akya akyb akyc akyd akye akyf akyg akyh akyi akyj akyk akyl akym akyn akyo akyp akyq akyr akys akyt akyu akyv akyw akyx akyy akyz akza akzb akzc akzd akze akzf akzg akzh akzi akzj akzk akzl akzm akzn akzo akzp akzq akzr akzs akzt akzu akzv akzw akzx akzy akzz alaa alab alac alad alae alaf alag alah alai alaj alak alal alam alan alao alap alaq alar alas alat alau alav alaw alax alay alaz alba albb albc albd albe albf albg albh albi albj albk albl albm albn albo albp albq albr albs albt albu albv albw mingw-ocaml/ocaml/camlp4/test/fixtures/tuple_as_retval.ml0000644000175000017500000000006412124403240023210 0ustar tootstootsEXTEND Gram abc: [ [ (x,y) = foo -> x+y ] ]; END; mingw-ocaml/ocaml/camlp4/test/fixtures/method_private_virtual.ml0000644000175000017500000000111112124403240024571 0ustar tootstootsclass virtual c1 = object method virtual private f : unit end;; class virtual c2 = object method private virtual f : unit end;; <:str_item< class virtual c1 = object method virtual private f : unit; end >>;; <:str_item< class virtual c2 = object method private virtual f : unit; end >>;; <:str_item< class virtual c2 = object method $private:p$ virtual f : unit; end >>;; <:str_item< class virtual c2 = object method virtual $private:p$ f : unit; end >>;; <:str_item< class $virtual:v$ c2 [$t1$] = object ($pat:self$) method virtual $private:p$ $lid:f$ : $t2$; end >>;; mingw-ocaml/ocaml/camlp4/test/fixtures/pp_let_in.ml0000644000175000017500000000047012124403240021771 0ustar tootstootslet i = "toto" in do { (let i = 42 in print_int i); print_string i }; let i = "toto" in do { print_string i; let i = 42 in print_int i; print_int i }; let i = "toto" in do { (let i = 42 in print_int i); let i = i ^ i; let i = i ^ i; print_string i; print_string i; let i = i ^ i; print_string i }; mingw-ocaml/ocaml/camlp4/test/fixtures/pr4330.ml0000644000175000017500000000331312124403240020752 0ustar tootstootsopen Camlp4.PreCast ; module G = Camlp4.PreCast.Gram ; value a = G.Entry.mk "a" ; value a_eoi = G.Entry.mk "a_eoi" ; EXTEND G a: [[ "one" -> 1 | x = a; "plus"; y = a -> x+y ]]; a_eoi: [[ x = a; `EOI -> x ]]; END ; (* and the following function: *) value parse_string entry s o = try Printf.eprintf "Parsing %S\n%!" s; assert (o = Some (G.parse_string entry (Loc.mk "") s)) with [ Loc.Exc_located loc exn when o <> None -> begin print_endline (Loc.to_string loc); print_endline (Printexc.to_string exn); assert (o = None) end | exn when o = None -> Printf.eprintf "Fail as expected\n%!" | exn -> begin Printf.eprintf "Unexpected exception: \n%!"; print_endline (Printexc.to_string exn); assert (o = None) end ] ; (* The following is correct: *) parse_string a_eoi "one plus one" (Some 2); (* While all of the following inputs should be rejected because they are not *) (* legal according to the grammar: *) parse_string a_eoi "one plus" None; (* - : int = 1 *) parse_string a_eoi "one plus plus" None; (* - : int = 1 *) parse_string a_eoi "one plus one plus" None; (* - : int = 2 *) parse_string a_eoi "one plus one plus plus" None; (* - : int = 2 *) (* Curiously, you may only repeat the operator twice. If you specify it three times, gramlib complains. *) parse_string a_eoi "one plus plus plus" None ; (* File "", line 1, characters 9-13 *) (* Stream.Error("EOI expected after [a] (in [a_eoi])") *) (* Exception: Failure "Syntax Error". *) parse_string a_eoi "one plus one plus plus plus" None ; (* File "", line 1, characters 18-22 *) (* Stream.Error("EOI expected after [a] (in [a_eoi])") *) (* Exception: Failure "Syntax Error". *) mingw-ocaml/ocaml/camlp4/test/fixtures/chars.ml0000644000175000017500000000000412124403240021111 0ustar tootstoots'"' mingw-ocaml/ocaml/camlp4/test/fixtures/pr4452.ml0000644000175000017500000000106212124403240020756 0ustar tootstootsopen Camlp4.PreCast let _loc = Loc.mk "?" let base base fields ty = let fields = List.fold_right (fun field acc -> let c = <:ctyp< $lid:field$ : $uid:field$.record >> in <:ctyp< $c$ ; $acc$ >>) fields <:ctyp< >> in <:module_binding< $uid:base$ : sig type record = { key : $ty$; $fields$ } end = struct type record = { key : $ty$; $fields$ } end >> let _ = let b = base "b" ["f1"; "f2"] <:ctyp< int >> in Camlp4.PreCast.Printers.OCaml.print_implem <:str_item< module rec $b$ >> mingw-ocaml/ocaml/camlp4/test/fixtures/gram-fold.ml0000644000175000017500000000076312124403240021675 0ustar tootstootsopen Camlp4.PreCast; module G = MakeGram Lexer; type t = [ A of t and t | B of string | C ]; value main = G.Entry.mk "main"; value rec length x acc = match x with [ A x y -> length x (length y acc) | B _ -> succ acc | C -> acc ]; EXTEND G GLOBAL: main; main: [ [ l = FOLD1 (fun a b -> A (B a) b) (C) ident -> l ] ]; ident: [ [ `LIDENT s -> s ] ]; END; let f = Sys.argv.(1) in Format.printf "%d@." (length (G.parse main (Loc.mk f) (Stream.of_channel (open_in f))) 0); mingw-ocaml/ocaml/camlp4/test/fixtures/functor-perf2.ml0000644000175000017500000000102612124403240022512 0ustar tootstoots<% types, with_constrs, module_application = ARGV.map { |x| x.to_i } %> module type S = sig <%- for i in 0 .. types do -%> type t<%= i %> <%- end -%> end module Make (M : S) : S with type t0 = M.t0 <%- for i in 1 .. with_constrs do -%> and type t<%= i %> = M.t<%= i %> <%- end -%> = struct include M end module M = struct <%- for i in 0 .. types do -%> type t<%= i %> = int -> int -> int <%- end -%> end module X = Make <%- module_application.times do -%> (Make <%- end -%> (M)<%= ')' * module_application %> mingw-ocaml/ocaml/camlp4/test/fixtures/comments2.ml0000644000175000017500000000340112124403240021724 0ustar tootstoots(** The first special comment of the file is the comment associated to the whole module.*) (** The comment for function f *) let f x y = x + y (** This comment is not attached to any element since there is another special comment just before the next element. *) (** Comment for exception My_exception, even with a simple comment between the special comment and the exception.*) (* A simple comment. *) exception My_exception of (int -> int) * int (** Comment for type weather *) type weather = (** The comment for constructor Rain *) | Rain of int (** The comment for constructor Sun *) | Sun (** The comment for type my_record *) type my_record = { (** Comment for field foo *) foo : int ; (** Comment for field bar *) bar : string ; } (** The comment for class my_class *) class my_class = object (** A comment to describe inheritance from cl *) inherit cl (** The comment for the instance variable tutu *) val mutable tutu = "tutu" (** The comment for toto *) val toto = 1 val titi = "titi" (** Comment for method toto *) method toto = tutu ^ "!" (** Comment for method m *) method m (f : float) = 1 end (** The comment for class type my_class_type *) class type my_class_type = object (** The comment for the instance variable x. *) val mutable x : int (** The commend for method m. *) method m : int -> int end (** The comment for module Foo *) module Foo = struct (** The comment for x *) let x = 42 (** A special comment in the class, but not associated to any element. *) end (** The comment for module type my_module_type. *) module type MY_MODULE_TYPE = sig (* Comment for value x. *) val x : int (* ... *) end mingw-ocaml/ocaml/camlp4/test/fixtures/bug-4337.ml0000644000175000017500000000004412124403240021170 0ustar tootstootsmatch [] with []°-> () | _ -> ();; mingw-ocaml/ocaml/camlp4/test/fixtures/pprecordtyp.ml0000644000175000017500000000121712124403240022373 0ustar tootstootsopen Camlp4.PreCast let _loc = Loc.mk "?" let base base fields ty = let fields = List.fold_right (fun field acc -> let c = <:ctyp< $lid:field$ : $uid:field$.record >> in <:ctyp< $c$ ; $acc$ >>) fields <:ctyp< >> in <:module_binding< $uid:base$ : sig type record = { key : $ty$; $fields$ } end = struct type record = { key : $ty$; $fields$ } end >> module CleanAst = Camlp4.Struct.CleanAst.Make(Ast) let _ = let b = base "b" ["f1"; "f2"] <:ctyp< int >> in Camlp4.PreCast.Printers.OCaml.print_implem ((new CleanAst.clean_ast)#str_item <:str_item< module rec $b$ >>) mingw-ocaml/ocaml/camlp4/test/fixtures/functor-perf2.gen.ml0000644000175000017500000021424612124403240023274 0ustar tootstoots module type S = sig type t0 type t1 type t2 type t3 type t4 type t5 type t6 type t7 type t8 type t9 type t10 type t11 type t12 type t13 type t14 type t15 type t16 type t17 type t18 type t19 type t20 type t21 type t22 type t23 type t24 type t25 type t26 type t27 type t28 type t29 type t30 type t31 type t32 type t33 type t34 type t35 type t36 type t37 type t38 type t39 type t40 type t41 type t42 type t43 type t44 type t45 type t46 type t47 type t48 type t49 type t50 type t51 type t52 type t53 type t54 type t55 type t56 type t57 type t58 type t59 type t60 type t61 type t62 type t63 type t64 type t65 type t66 type t67 type t68 type t69 type t70 type t71 type t72 type t73 type t74 type t75 type t76 type t77 type t78 type t79 type t80 type t81 type t82 type t83 type t84 type t85 type t86 type t87 type t88 type t89 type t90 type t91 type t92 type t93 type t94 type t95 type t96 type t97 type t98 type t99 type t100 type t101 type t102 type t103 type t104 type t105 type t106 type t107 type t108 type t109 type t110 type t111 type t112 type t113 type t114 type t115 type t116 type t117 type t118 type t119 type t120 type t121 type t122 type t123 type t124 type t125 type t126 type t127 type t128 type t129 type t130 type t131 type t132 type t133 type t134 type t135 type t136 type t137 type t138 type t139 type t140 type t141 type t142 type t143 type t144 type t145 type t146 type t147 type t148 type t149 type t150 type t151 type t152 type t153 type t154 type t155 type t156 type t157 type t158 type t159 type t160 type t161 type t162 type t163 type t164 type t165 type t166 type t167 type t168 type t169 type t170 type t171 type t172 type t173 type t174 type t175 type t176 type t177 type t178 type t179 type t180 type t181 type t182 type t183 type t184 type t185 type t186 type t187 type t188 type t189 type t190 type t191 type t192 type t193 type t194 type t195 type t196 type t197 type t198 type t199 type t200 type t201 type t202 type t203 type t204 type t205 type t206 type t207 type t208 type t209 type t210 type t211 type t212 type t213 type t214 type t215 type t216 type t217 type t218 type t219 type t220 type t221 type t222 type t223 type t224 type t225 type t226 type t227 type t228 type t229 type t230 type t231 type t232 type t233 type t234 type t235 type t236 type t237 type t238 type t239 type t240 type t241 type t242 type t243 type t244 type t245 type t246 type t247 type t248 type t249 type t250 type t251 type t252 type t253 type t254 type t255 type t256 type t257 type t258 type t259 type t260 type t261 type t262 type t263 type t264 type t265 type t266 type t267 type t268 type t269 type t270 type t271 type t272 type t273 type t274 type t275 type t276 type t277 type t278 type t279 type t280 type t281 type t282 type t283 type t284 type t285 type t286 type t287 type t288 type t289 type t290 type t291 type t292 type t293 type t294 type t295 type t296 type t297 type t298 type t299 type t300 type t301 type t302 type t303 type t304 type t305 type t306 type t307 type t308 type t309 type t310 type t311 type t312 type t313 type t314 type t315 type t316 type t317 type t318 type t319 type t320 type t321 type t322 type t323 type t324 type t325 type t326 type t327 type t328 type t329 type t330 type t331 type t332 type t333 type t334 type t335 type t336 type t337 type t338 type t339 type t340 type t341 type t342 type t343 type t344 type t345 type t346 type t347 type t348 type t349 type t350 type t351 type t352 type t353 type t354 type t355 type t356 type t357 type t358 type t359 type t360 type t361 type t362 type t363 type t364 type t365 type t366 type t367 type t368 type t369 type t370 type t371 type t372 type t373 type t374 type t375 type t376 type t377 type t378 type t379 type t380 type t381 type t382 type t383 type t384 type t385 type t386 type t387 type t388 type t389 type t390 type t391 type t392 type t393 type t394 type t395 type t396 type t397 type t398 type t399 type t400 type t401 type t402 type t403 type t404 type t405 type t406 type t407 type t408 type t409 type t410 type t411 type t412 type t413 type t414 type t415 type t416 type t417 type t418 type t419 type t420 type t421 type t422 type t423 type t424 type t425 type t426 type t427 type t428 type t429 type t430 type t431 type t432 type t433 type t434 type t435 type t436 type t437 type t438 type t439 type t440 type t441 type t442 type t443 type t444 type t445 type t446 type t447 type t448 type t449 type t450 type t451 type t452 type t453 type t454 type t455 type t456 type t457 type t458 type t459 type t460 type t461 type t462 type t463 type t464 type t465 type t466 type t467 type t468 type t469 type t470 type t471 type t472 type t473 type t474 type t475 type t476 type t477 type t478 type t479 type t480 type t481 type t482 type t483 type t484 type t485 type t486 type t487 type t488 type t489 type t490 type t491 type t492 type t493 type t494 type t495 type t496 type t497 type t498 type t499 type t500 type t501 type t502 type t503 type t504 type t505 type t506 type t507 type t508 type t509 type t510 type t511 type t512 type t513 type t514 type t515 type t516 type t517 type t518 type t519 type t520 type t521 type t522 type t523 type t524 type t525 type t526 type t527 type t528 type t529 type t530 type t531 type t532 type t533 type t534 type t535 type t536 type t537 type t538 type t539 type t540 type t541 type t542 type t543 type t544 type t545 type t546 type t547 type t548 type t549 type t550 type t551 type t552 type t553 type t554 type t555 type t556 type t557 type t558 type t559 type t560 type t561 type t562 type t563 type t564 type t565 type t566 type t567 type t568 type t569 type t570 type t571 type t572 type t573 type t574 type t575 type t576 type t577 type t578 type t579 type t580 type t581 type t582 type t583 type t584 type t585 type t586 type t587 type t588 type t589 type t590 type t591 type t592 type t593 type t594 type t595 type t596 type t597 type t598 type t599 type t600 type t601 type t602 type t603 type t604 type t605 type t606 type t607 type t608 type t609 type t610 type t611 type t612 type t613 type t614 type t615 type t616 type t617 type t618 type t619 type t620 type t621 type t622 type t623 type t624 type t625 type t626 type t627 type t628 type t629 type t630 type t631 type t632 type t633 type t634 type t635 type t636 type t637 type t638 type t639 type t640 type t641 type t642 type t643 type t644 type t645 type t646 type t647 type t648 type t649 type t650 type t651 type t652 type t653 type t654 type t655 type t656 type t657 type t658 type t659 type t660 type t661 type t662 type t663 type t664 type t665 type t666 type t667 type t668 type t669 type t670 type t671 type t672 type t673 type t674 type t675 type t676 type t677 type t678 type t679 type t680 type t681 type t682 type t683 type t684 type t685 type t686 type t687 type t688 type t689 type t690 type t691 type t692 type t693 type t694 type t695 type t696 type t697 type t698 type t699 type t700 type t701 type t702 type t703 type t704 type t705 type t706 type t707 type t708 type t709 type t710 type t711 type t712 type t713 type t714 type t715 type t716 type t717 type t718 type t719 type t720 type t721 type t722 type t723 type t724 type t725 type t726 type t727 type t728 type t729 type t730 type t731 type t732 type t733 type t734 type t735 type t736 type t737 type t738 type t739 type t740 type t741 type t742 type t743 type t744 type t745 type t746 type t747 type t748 type t749 type t750 type t751 type t752 type t753 type t754 type t755 type t756 type t757 type t758 type t759 type t760 type t761 type t762 type t763 type t764 type t765 type t766 type t767 type t768 type t769 type t770 type t771 type t772 type t773 type t774 type t775 type t776 type t777 type t778 type t779 type t780 type t781 type t782 type t783 type t784 type t785 type t786 type t787 type t788 type t789 type t790 type t791 type t792 type t793 type t794 type t795 type t796 type t797 type t798 type t799 type t800 type t801 type t802 type t803 type t804 type t805 type t806 type t807 type t808 type t809 type t810 type t811 type t812 type t813 type t814 type t815 type t816 type t817 type t818 type t819 type t820 type t821 type t822 type t823 type t824 type t825 type t826 type t827 type t828 type t829 type t830 type t831 type t832 type t833 type t834 type t835 type t836 type t837 type t838 type t839 type t840 type t841 type t842 type t843 type t844 type t845 type t846 type t847 type t848 type t849 type t850 type t851 type t852 type t853 type t854 type t855 type t856 type t857 type t858 type t859 type t860 type t861 type t862 type t863 type t864 type t865 type t866 type t867 type t868 type t869 type t870 type t871 type t872 type t873 type t874 type t875 type t876 type t877 type t878 type t879 type t880 type t881 type t882 type t883 type t884 type t885 type t886 type t887 type t888 type t889 type t890 type t891 type t892 type t893 type t894 type t895 type t896 type t897 type t898 type t899 type t900 type t901 type t902 type t903 type t904 type t905 type t906 type t907 type t908 type t909 type t910 type t911 type t912 type t913 type t914 type t915 type t916 type t917 type t918 type t919 type t920 type t921 type t922 type t923 type t924 type t925 type t926 type t927 type t928 type t929 type t930 type t931 type t932 type t933 type t934 type t935 type t936 type t937 type t938 type t939 type t940 type t941 type t942 type t943 type t944 type t945 type t946 type t947 type t948 type t949 type t950 type t951 type t952 type t953 type t954 type t955 type t956 type t957 type t958 type t959 type t960 type t961 type t962 type t963 type t964 type t965 type t966 type t967 type t968 type t969 type t970 type t971 type t972 type t973 type t974 type t975 type t976 type t977 type t978 type t979 type t980 type t981 type t982 type t983 type t984 type t985 type t986 type t987 type t988 type t989 type t990 type t991 type t992 type t993 type t994 type t995 type t996 type t997 type t998 type t999 type t1000 end module Make (M : S) : S with type t0 = M.t0 and type t1 = M.t1 and type t2 = M.t2 and type t3 = M.t3 and type t4 = M.t4 and type t5 = M.t5 and type t6 = M.t6 and type t7 = M.t7 and type t8 = M.t8 and type t9 = M.t9 and type t10 = M.t10 and type t11 = M.t11 and type t12 = M.t12 and type t13 = M.t13 and type t14 = M.t14 and type t15 = M.t15 and type t16 = M.t16 and type t17 = M.t17 and type t18 = M.t18 and type t19 = M.t19 and type t20 = M.t20 and type t21 = M.t21 and type t22 = M.t22 and type t23 = M.t23 and type t24 = M.t24 and type t25 = M.t25 and type t26 = M.t26 and type t27 = M.t27 and type t28 = M.t28 and type t29 = M.t29 and type t30 = M.t30 and type t31 = M.t31 and type t32 = M.t32 and type t33 = M.t33 and type t34 = M.t34 and type t35 = M.t35 and type t36 = M.t36 and type t37 = M.t37 and type t38 = M.t38 and type t39 = M.t39 and type t40 = M.t40 and type t41 = M.t41 and type t42 = M.t42 and type t43 = M.t43 and type t44 = M.t44 and type t45 = M.t45 and type t46 = M.t46 and type t47 = M.t47 and type t48 = M.t48 and type t49 = M.t49 and type t50 = M.t50 and type t51 = M.t51 and type t52 = M.t52 and type t53 = M.t53 and type t54 = M.t54 and type t55 = M.t55 and type t56 = M.t56 and type t57 = M.t57 and type t58 = M.t58 and type t59 = M.t59 and type t60 = M.t60 and type t61 = M.t61 and type t62 = M.t62 and type t63 = M.t63 and type t64 = M.t64 and type t65 = M.t65 and type t66 = M.t66 and type t67 = M.t67 and type t68 = M.t68 and type t69 = M.t69 and type t70 = M.t70 and type t71 = M.t71 and type t72 = M.t72 and type t73 = M.t73 and type t74 = M.t74 and type t75 = M.t75 and type t76 = M.t76 and type t77 = M.t77 and type t78 = M.t78 and type t79 = M.t79 and type t80 = M.t80 and type t81 = M.t81 and type t82 = M.t82 and type t83 = M.t83 and type t84 = M.t84 and type t85 = M.t85 and type t86 = M.t86 and type t87 = M.t87 and type t88 = M.t88 and type t89 = M.t89 and type t90 = M.t90 and type t91 = M.t91 and type t92 = M.t92 and type t93 = M.t93 and type t94 = M.t94 and type t95 = M.t95 and type t96 = M.t96 and type t97 = M.t97 and type t98 = M.t98 and type t99 = M.t99 and type t100 = M.t100 and type t101 = M.t101 and type t102 = M.t102 and type t103 = M.t103 and type t104 = M.t104 and type t105 = M.t105 and type t106 = M.t106 and type t107 = M.t107 and type t108 = M.t108 and type t109 = M.t109 and type t110 = M.t110 and type t111 = M.t111 and type t112 = M.t112 and type t113 = M.t113 and type t114 = M.t114 and type t115 = M.t115 and type t116 = M.t116 and type t117 = M.t117 and type t118 = M.t118 and type t119 = M.t119 and type t120 = M.t120 and type t121 = M.t121 and type t122 = M.t122 and type t123 = M.t123 and type t124 = M.t124 and type t125 = M.t125 and type t126 = M.t126 and type t127 = M.t127 and type t128 = M.t128 and type t129 = M.t129 and type t130 = M.t130 and type t131 = M.t131 and type t132 = M.t132 and type t133 = M.t133 and type t134 = M.t134 and type t135 = M.t135 and type t136 = M.t136 and type t137 = M.t137 and type t138 = M.t138 and type t139 = M.t139 and type t140 = M.t140 and type t141 = M.t141 and type t142 = M.t142 and type t143 = M.t143 and type t144 = M.t144 and type t145 = M.t145 and type t146 = M.t146 and type t147 = M.t147 and type t148 = M.t148 and type t149 = M.t149 and type t150 = M.t150 and type t151 = M.t151 and type t152 = M.t152 and type t153 = M.t153 and type t154 = M.t154 and type t155 = M.t155 and type t156 = M.t156 and type t157 = M.t157 and type t158 = M.t158 and type t159 = M.t159 and type t160 = M.t160 and type t161 = M.t161 and type t162 = M.t162 and type t163 = M.t163 and type t164 = M.t164 and type t165 = M.t165 and type t166 = M.t166 and type t167 = M.t167 and type t168 = M.t168 and type t169 = M.t169 and type t170 = M.t170 and type t171 = M.t171 and type t172 = M.t172 and type t173 = M.t173 and type t174 = M.t174 and type t175 = M.t175 and type t176 = M.t176 and type t177 = M.t177 and type t178 = M.t178 and type t179 = M.t179 and type t180 = M.t180 and type t181 = M.t181 and type t182 = M.t182 and type t183 = M.t183 and type t184 = M.t184 and type t185 = M.t185 and type t186 = M.t186 and type t187 = M.t187 and type t188 = M.t188 and type t189 = M.t189 and type t190 = M.t190 and type t191 = M.t191 and type t192 = M.t192 and type t193 = M.t193 and type t194 = M.t194 and type t195 = M.t195 and type t196 = M.t196 and type t197 = M.t197 and type t198 = M.t198 and type t199 = M.t199 and type t200 = M.t200 and type t201 = M.t201 and type t202 = M.t202 and type t203 = M.t203 and type t204 = M.t204 and type t205 = M.t205 and type t206 = M.t206 and type t207 = M.t207 and type t208 = M.t208 and type t209 = M.t209 and type t210 = M.t210 and type t211 = M.t211 and type t212 = M.t212 and type t213 = M.t213 and type t214 = M.t214 and type t215 = M.t215 and type t216 = M.t216 and type t217 = M.t217 and type t218 = M.t218 and type t219 = M.t219 and type t220 = M.t220 and type t221 = M.t221 and type t222 = M.t222 and type t223 = M.t223 and type t224 = M.t224 and type t225 = M.t225 and type t226 = M.t226 and type t227 = M.t227 and type t228 = M.t228 and type t229 = M.t229 and type t230 = M.t230 and type t231 = M.t231 and type t232 = M.t232 and type t233 = M.t233 and type t234 = M.t234 and type t235 = M.t235 and type t236 = M.t236 and type t237 = M.t237 and type t238 = M.t238 and type t239 = M.t239 and type t240 = M.t240 and type t241 = M.t241 and type t242 = M.t242 and type t243 = M.t243 and type t244 = M.t244 and type t245 = M.t245 and type t246 = M.t246 and type t247 = M.t247 and type t248 = M.t248 and type t249 = M.t249 and type t250 = M.t250 and type t251 = M.t251 and type t252 = M.t252 and type t253 = M.t253 and type t254 = M.t254 and type t255 = M.t255 and type t256 = M.t256 and type t257 = M.t257 and type t258 = M.t258 and type t259 = M.t259 and type t260 = M.t260 and type t261 = M.t261 and type t262 = M.t262 and type t263 = M.t263 and type t264 = M.t264 and type t265 = M.t265 and type t266 = M.t266 and type t267 = M.t267 and type t268 = M.t268 and type t269 = M.t269 and type t270 = M.t270 and type t271 = M.t271 and type t272 = M.t272 and type t273 = M.t273 and type t274 = M.t274 and type t275 = M.t275 and type t276 = M.t276 and type t277 = M.t277 and type t278 = M.t278 and type t279 = M.t279 and type t280 = M.t280 and type t281 = M.t281 and type t282 = M.t282 and type t283 = M.t283 and type t284 = M.t284 and type t285 = M.t285 and type t286 = M.t286 and type t287 = M.t287 and type t288 = M.t288 and type t289 = M.t289 and type t290 = M.t290 and type t291 = M.t291 and type t292 = M.t292 and type t293 = M.t293 and type t294 = M.t294 and type t295 = M.t295 and type t296 = M.t296 and type t297 = M.t297 and type t298 = M.t298 and type t299 = M.t299 and type t300 = M.t300 and type t301 = M.t301 and type t302 = M.t302 and type t303 = M.t303 and type t304 = M.t304 and type t305 = M.t305 and type t306 = M.t306 and type t307 = M.t307 and type t308 = M.t308 and type t309 = M.t309 and type t310 = M.t310 and type t311 = M.t311 and type t312 = M.t312 and type t313 = M.t313 and type t314 = M.t314 and type t315 = M.t315 and type t316 = M.t316 and type t317 = M.t317 and type t318 = M.t318 and type t319 = M.t319 and type t320 = M.t320 and type t321 = M.t321 and type t322 = M.t322 and type t323 = M.t323 and type t324 = M.t324 and type t325 = M.t325 and type t326 = M.t326 and type t327 = M.t327 and type t328 = M.t328 and type t329 = M.t329 and type t330 = M.t330 and type t331 = M.t331 and type t332 = M.t332 and type t333 = M.t333 and type t334 = M.t334 and type t335 = M.t335 and type t336 = M.t336 and type t337 = M.t337 and type t338 = M.t338 and type t339 = M.t339 and type t340 = M.t340 and type t341 = M.t341 and type t342 = M.t342 and type t343 = M.t343 and type t344 = M.t344 and type t345 = M.t345 and type t346 = M.t346 and type t347 = M.t347 and type t348 = M.t348 and type t349 = M.t349 and type t350 = M.t350 and type t351 = M.t351 and type t352 = M.t352 and type t353 = M.t353 and type t354 = M.t354 and type t355 = M.t355 and type t356 = M.t356 and type t357 = M.t357 and type t358 = M.t358 and type t359 = M.t359 and type t360 = M.t360 and type t361 = M.t361 and type t362 = M.t362 and type t363 = M.t363 and type t364 = M.t364 and type t365 = M.t365 and type t366 = M.t366 and type t367 = M.t367 and type t368 = M.t368 and type t369 = M.t369 and type t370 = M.t370 and type t371 = M.t371 and type t372 = M.t372 and type t373 = M.t373 and type t374 = M.t374 and type t375 = M.t375 and type t376 = M.t376 and type t377 = M.t377 and type t378 = M.t378 and type t379 = M.t379 and type t380 = M.t380 and type t381 = M.t381 and type t382 = M.t382 and type t383 = M.t383 and type t384 = M.t384 and type t385 = M.t385 and type t386 = M.t386 and type t387 = M.t387 and type t388 = M.t388 and type t389 = M.t389 and type t390 = M.t390 and type t391 = M.t391 and type t392 = M.t392 and type t393 = M.t393 and type t394 = M.t394 and type t395 = M.t395 and type t396 = M.t396 and type t397 = M.t397 and type t398 = M.t398 and type t399 = M.t399 and type t400 = M.t400 and type t401 = M.t401 and type t402 = M.t402 and type t403 = M.t403 and type t404 = M.t404 and type t405 = M.t405 and type t406 = M.t406 and type t407 = M.t407 and type t408 = M.t408 and type t409 = M.t409 and type t410 = M.t410 and type t411 = M.t411 and type t412 = M.t412 and type t413 = M.t413 and type t414 = M.t414 and type t415 = M.t415 and type t416 = M.t416 and type t417 = M.t417 and type t418 = M.t418 and type t419 = M.t419 and type t420 = M.t420 and type t421 = M.t421 and type t422 = M.t422 and type t423 = M.t423 and type t424 = M.t424 and type t425 = M.t425 and type t426 = M.t426 and type t427 = M.t427 and type t428 = M.t428 and type t429 = M.t429 and type t430 = M.t430 and type t431 = M.t431 and type t432 = M.t432 and type t433 = M.t433 and type t434 = M.t434 and type t435 = M.t435 and type t436 = M.t436 and type t437 = M.t437 and type t438 = M.t438 and type t439 = M.t439 and type t440 = M.t440 and type t441 = M.t441 and type t442 = M.t442 and type t443 = M.t443 and type t444 = M.t444 and type t445 = M.t445 and type t446 = M.t446 and type t447 = M.t447 and type t448 = M.t448 and type t449 = M.t449 and type t450 = M.t450 and type t451 = M.t451 and type t452 = M.t452 and type t453 = M.t453 and type t454 = M.t454 and type t455 = M.t455 and type t456 = M.t456 and type t457 = M.t457 and type t458 = M.t458 and type t459 = M.t459 and type t460 = M.t460 and type t461 = M.t461 and type t462 = M.t462 and type t463 = M.t463 and type t464 = M.t464 and type t465 = M.t465 and type t466 = M.t466 and type t467 = M.t467 and type t468 = M.t468 and type t469 = M.t469 and type t470 = M.t470 and type t471 = M.t471 and type t472 = M.t472 and type t473 = M.t473 and type t474 = M.t474 and type t475 = M.t475 and type t476 = M.t476 and type t477 = M.t477 and type t478 = M.t478 and type t479 = M.t479 and type t480 = M.t480 and type t481 = M.t481 and type t482 = M.t482 and type t483 = M.t483 and type t484 = M.t484 and type t485 = M.t485 and type t486 = M.t486 and type t487 = M.t487 and type t488 = M.t488 and type t489 = M.t489 and type t490 = M.t490 and type t491 = M.t491 and type t492 = M.t492 and type t493 = M.t493 and type t494 = M.t494 and type t495 = M.t495 and type t496 = M.t496 and type t497 = M.t497 and type t498 = M.t498 and type t499 = M.t499 and type t500 = M.t500 and type t501 = M.t501 and type t502 = M.t502 and type t503 = M.t503 and type t504 = M.t504 and type t505 = M.t505 and type t506 = M.t506 and type t507 = M.t507 and type t508 = M.t508 and type t509 = M.t509 and type t510 = M.t510 and type t511 = M.t511 and type t512 = M.t512 and type t513 = M.t513 and type t514 = M.t514 and type t515 = M.t515 and type t516 = M.t516 and type t517 = M.t517 and type t518 = M.t518 and type t519 = M.t519 and type t520 = M.t520 and type t521 = M.t521 and type t522 = M.t522 and type t523 = M.t523 and type t524 = M.t524 and type t525 = M.t525 and type t526 = M.t526 and type t527 = M.t527 and type t528 = M.t528 and type t529 = M.t529 and type t530 = M.t530 and type t531 = M.t531 and type t532 = M.t532 and type t533 = M.t533 and type t534 = M.t534 and type t535 = M.t535 and type t536 = M.t536 and type t537 = M.t537 and type t538 = M.t538 and type t539 = M.t539 and type t540 = M.t540 and type t541 = M.t541 and type t542 = M.t542 and type t543 = M.t543 and type t544 = M.t544 and type t545 = M.t545 and type t546 = M.t546 and type t547 = M.t547 and type t548 = M.t548 and type t549 = M.t549 and type t550 = M.t550 and type t551 = M.t551 and type t552 = M.t552 and type t553 = M.t553 and type t554 = M.t554 and type t555 = M.t555 and type t556 = M.t556 and type t557 = M.t557 and type t558 = M.t558 and type t559 = M.t559 and type t560 = M.t560 and type t561 = M.t561 and type t562 = M.t562 and type t563 = M.t563 and type t564 = M.t564 and type t565 = M.t565 and type t566 = M.t566 and type t567 = M.t567 and type t568 = M.t568 and type t569 = M.t569 and type t570 = M.t570 and type t571 = M.t571 and type t572 = M.t572 and type t573 = M.t573 and type t574 = M.t574 and type t575 = M.t575 and type t576 = M.t576 and type t577 = M.t577 and type t578 = M.t578 and type t579 = M.t579 and type t580 = M.t580 and type t581 = M.t581 and type t582 = M.t582 and type t583 = M.t583 and type t584 = M.t584 and type t585 = M.t585 and type t586 = M.t586 and type t587 = M.t587 and type t588 = M.t588 and type t589 = M.t589 and type t590 = M.t590 and type t591 = M.t591 and type t592 = M.t592 and type t593 = M.t593 and type t594 = M.t594 and type t595 = M.t595 and type t596 = M.t596 and type t597 = M.t597 and type t598 = M.t598 and type t599 = M.t599 and type t600 = M.t600 and type t601 = M.t601 and type t602 = M.t602 and type t603 = M.t603 and type t604 = M.t604 and type t605 = M.t605 and type t606 = M.t606 and type t607 = M.t607 and type t608 = M.t608 and type t609 = M.t609 and type t610 = M.t610 and type t611 = M.t611 and type t612 = M.t612 and type t613 = M.t613 and type t614 = M.t614 and type t615 = M.t615 and type t616 = M.t616 and type t617 = M.t617 and type t618 = M.t618 and type t619 = M.t619 and type t620 = M.t620 and type t621 = M.t621 and type t622 = M.t622 and type t623 = M.t623 and type t624 = M.t624 and type t625 = M.t625 and type t626 = M.t626 and type t627 = M.t627 and type t628 = M.t628 and type t629 = M.t629 and type t630 = M.t630 and type t631 = M.t631 and type t632 = M.t632 and type t633 = M.t633 and type t634 = M.t634 and type t635 = M.t635 and type t636 = M.t636 and type t637 = M.t637 and type t638 = M.t638 and type t639 = M.t639 and type t640 = M.t640 and type t641 = M.t641 and type t642 = M.t642 and type t643 = M.t643 and type t644 = M.t644 and type t645 = M.t645 and type t646 = M.t646 and type t647 = M.t647 and type t648 = M.t648 and type t649 = M.t649 and type t650 = M.t650 and type t651 = M.t651 and type t652 = M.t652 and type t653 = M.t653 and type t654 = M.t654 and type t655 = M.t655 and type t656 = M.t656 and type t657 = M.t657 and type t658 = M.t658 and type t659 = M.t659 and type t660 = M.t660 and type t661 = M.t661 and type t662 = M.t662 and type t663 = M.t663 and type t664 = M.t664 and type t665 = M.t665 and type t666 = M.t666 and type t667 = M.t667 and type t668 = M.t668 and type t669 = M.t669 and type t670 = M.t670 and type t671 = M.t671 and type t672 = M.t672 and type t673 = M.t673 and type t674 = M.t674 and type t675 = M.t675 and type t676 = M.t676 and type t677 = M.t677 and type t678 = M.t678 and type t679 = M.t679 and type t680 = M.t680 and type t681 = M.t681 and type t682 = M.t682 and type t683 = M.t683 and type t684 = M.t684 and type t685 = M.t685 and type t686 = M.t686 and type t687 = M.t687 and type t688 = M.t688 and type t689 = M.t689 and type t690 = M.t690 and type t691 = M.t691 and type t692 = M.t692 and type t693 = M.t693 and type t694 = M.t694 and type t695 = M.t695 and type t696 = M.t696 and type t697 = M.t697 and type t698 = M.t698 and type t699 = M.t699 and type t700 = M.t700 and type t701 = M.t701 and type t702 = M.t702 and type t703 = M.t703 and type t704 = M.t704 and type t705 = M.t705 and type t706 = M.t706 and type t707 = M.t707 and type t708 = M.t708 and type t709 = M.t709 and type t710 = M.t710 and type t711 = M.t711 and type t712 = M.t712 and type t713 = M.t713 and type t714 = M.t714 and type t715 = M.t715 and type t716 = M.t716 and type t717 = M.t717 and type t718 = M.t718 and type t719 = M.t719 and type t720 = M.t720 and type t721 = M.t721 and type t722 = M.t722 and type t723 = M.t723 and type t724 = M.t724 and type t725 = M.t725 and type t726 = M.t726 and type t727 = M.t727 and type t728 = M.t728 and type t729 = M.t729 and type t730 = M.t730 and type t731 = M.t731 and type t732 = M.t732 and type t733 = M.t733 and type t734 = M.t734 and type t735 = M.t735 and type t736 = M.t736 and type t737 = M.t737 and type t738 = M.t738 and type t739 = M.t739 and type t740 = M.t740 and type t741 = M.t741 and type t742 = M.t742 and type t743 = M.t743 and type t744 = M.t744 and type t745 = M.t745 and type t746 = M.t746 and type t747 = M.t747 and type t748 = M.t748 and type t749 = M.t749 and type t750 = M.t750 and type t751 = M.t751 and type t752 = M.t752 and type t753 = M.t753 and type t754 = M.t754 and type t755 = M.t755 and type t756 = M.t756 and type t757 = M.t757 and type t758 = M.t758 and type t759 = M.t759 and type t760 = M.t760 and type t761 = M.t761 and type t762 = M.t762 and type t763 = M.t763 and type t764 = M.t764 and type t765 = M.t765 and type t766 = M.t766 and type t767 = M.t767 and type t768 = M.t768 and type t769 = M.t769 and type t770 = M.t770 and type t771 = M.t771 and type t772 = M.t772 and type t773 = M.t773 and type t774 = M.t774 and type t775 = M.t775 and type t776 = M.t776 and type t777 = M.t777 and type t778 = M.t778 and type t779 = M.t779 and type t780 = M.t780 and type t781 = M.t781 and type t782 = M.t782 and type t783 = M.t783 and type t784 = M.t784 and type t785 = M.t785 and type t786 = M.t786 and type t787 = M.t787 and type t788 = M.t788 and type t789 = M.t789 and type t790 = M.t790 and type t791 = M.t791 and type t792 = M.t792 and type t793 = M.t793 and type t794 = M.t794 and type t795 = M.t795 and type t796 = M.t796 and type t797 = M.t797 and type t798 = M.t798 and type t799 = M.t799 and type t800 = M.t800 and type t801 = M.t801 and type t802 = M.t802 and type t803 = M.t803 and type t804 = M.t804 and type t805 = M.t805 and type t806 = M.t806 and type t807 = M.t807 and type t808 = M.t808 and type t809 = M.t809 and type t810 = M.t810 and type t811 = M.t811 and type t812 = M.t812 and type t813 = M.t813 and type t814 = M.t814 and type t815 = M.t815 and type t816 = M.t816 and type t817 = M.t817 and type t818 = M.t818 and type t819 = M.t819 and type t820 = M.t820 and type t821 = M.t821 and type t822 = M.t822 and type t823 = M.t823 and type t824 = M.t824 and type t825 = M.t825 and type t826 = M.t826 and type t827 = M.t827 and type t828 = M.t828 and type t829 = M.t829 and type t830 = M.t830 and type t831 = M.t831 and type t832 = M.t832 and type t833 = M.t833 and type t834 = M.t834 and type t835 = M.t835 and type t836 = M.t836 and type t837 = M.t837 and type t838 = M.t838 and type t839 = M.t839 and type t840 = M.t840 and type t841 = M.t841 and type t842 = M.t842 and type t843 = M.t843 and type t844 = M.t844 and type t845 = M.t845 and type t846 = M.t846 and type t847 = M.t847 and type t848 = M.t848 and type t849 = M.t849 and type t850 = M.t850 and type t851 = M.t851 and type t852 = M.t852 and type t853 = M.t853 and type t854 = M.t854 and type t855 = M.t855 and type t856 = M.t856 and type t857 = M.t857 and type t858 = M.t858 and type t859 = M.t859 and type t860 = M.t860 and type t861 = M.t861 and type t862 = M.t862 and type t863 = M.t863 and type t864 = M.t864 and type t865 = M.t865 and type t866 = M.t866 and type t867 = M.t867 and type t868 = M.t868 and type t869 = M.t869 and type t870 = M.t870 and type t871 = M.t871 and type t872 = M.t872 and type t873 = M.t873 and type t874 = M.t874 and type t875 = M.t875 and type t876 = M.t876 and type t877 = M.t877 and type t878 = M.t878 and type t879 = M.t879 and type t880 = M.t880 and type t881 = M.t881 and type t882 = M.t882 and type t883 = M.t883 and type t884 = M.t884 and type t885 = M.t885 and type t886 = M.t886 and type t887 = M.t887 and type t888 = M.t888 and type t889 = M.t889 and type t890 = M.t890 and type t891 = M.t891 and type t892 = M.t892 and type t893 = M.t893 and type t894 = M.t894 and type t895 = M.t895 and type t896 = M.t896 and type t897 = M.t897 and type t898 = M.t898 and type t899 = M.t899 and type t900 = M.t900 and type t901 = M.t901 and type t902 = M.t902 and type t903 = M.t903 and type t904 = M.t904 and type t905 = M.t905 and type t906 = M.t906 and type t907 = M.t907 and type t908 = M.t908 and type t909 = M.t909 and type t910 = M.t910 and type t911 = M.t911 and type t912 = M.t912 and type t913 = M.t913 and type t914 = M.t914 and type t915 = M.t915 and type t916 = M.t916 and type t917 = M.t917 and type t918 = M.t918 and type t919 = M.t919 and type t920 = M.t920 and type t921 = M.t921 and type t922 = M.t922 and type t923 = M.t923 and type t924 = M.t924 and type t925 = M.t925 and type t926 = M.t926 and type t927 = M.t927 and type t928 = M.t928 and type t929 = M.t929 and type t930 = M.t930 and type t931 = M.t931 and type t932 = M.t932 and type t933 = M.t933 and type t934 = M.t934 and type t935 = M.t935 and type t936 = M.t936 and type t937 = M.t937 and type t938 = M.t938 and type t939 = M.t939 and type t940 = M.t940 and type t941 = M.t941 and type t942 = M.t942 and type t943 = M.t943 and type t944 = M.t944 and type t945 = M.t945 and type t946 = M.t946 and type t947 = M.t947 and type t948 = M.t948 and type t949 = M.t949 and type t950 = M.t950 and type t951 = M.t951 and type t952 = M.t952 and type t953 = M.t953 and type t954 = M.t954 and type t955 = M.t955 and type t956 = M.t956 and type t957 = M.t957 and type t958 = M.t958 and type t959 = M.t959 and type t960 = M.t960 and type t961 = M.t961 and type t962 = M.t962 and type t963 = M.t963 and type t964 = M.t964 and type t965 = M.t965 and type t966 = M.t966 and type t967 = M.t967 and type t968 = M.t968 and type t969 = M.t969 and type t970 = M.t970 and type t971 = M.t971 and type t972 = M.t972 and type t973 = M.t973 and type t974 = M.t974 and type t975 = M.t975 and type t976 = M.t976 and type t977 = M.t977 and type t978 = M.t978 and type t979 = M.t979 and type t980 = M.t980 and type t981 = M.t981 and type t982 = M.t982 and type t983 = M.t983 and type t984 = M.t984 and type t985 = M.t985 and type t986 = M.t986 and type t987 = M.t987 and type t988 = M.t988 and type t989 = M.t989 and type t990 = M.t990 and type t991 = M.t991 and type t992 = M.t992 and type t993 = M.t993 and type t994 = M.t994 and type t995 = M.t995 and type t996 = M.t996 and type t997 = M.t997 and type t998 = M.t998 and type t999 = M.t999 and type t1000 = M.t1000 = struct include M end module M = struct type t0 = int -> int -> int type t1 = int -> int -> int type t2 = int -> int -> int type t3 = int -> int -> int type t4 = int -> int -> int type t5 = int -> int -> int type t6 = int -> int -> int type t7 = int -> int -> int type t8 = int -> int -> int type t9 = int -> int -> int type t10 = int -> int -> int type t11 = int -> int -> int type t12 = int -> int -> int type t13 = int -> int -> int type t14 = int -> int -> int type t15 = int -> int -> int type t16 = int -> int -> int type t17 = int -> int -> int type t18 = int -> int -> int type t19 = int -> int -> int type t20 = int -> int -> int type t21 = int -> int -> int type t22 = int -> int -> int type t23 = int -> int -> int type t24 = int -> int -> int type t25 = int -> int -> int type t26 = int -> int -> int type t27 = int -> int -> int type t28 = int -> int -> int type t29 = int -> int -> int type t30 = int -> int -> int type t31 = int -> int -> int type t32 = int -> int -> int type t33 = int -> int -> int type t34 = int -> int -> int type t35 = int -> int -> int type t36 = int -> int -> int type t37 = int -> int -> int type t38 = int -> int -> int type t39 = int -> int -> int type t40 = int -> int -> int type t41 = int -> int -> int type t42 = int -> int -> int type t43 = int -> int -> int type t44 = int -> int -> int type t45 = int -> int -> int type t46 = int -> int -> int type t47 = int -> int -> int type t48 = int -> int -> int type t49 = int -> int -> int type t50 = int -> int -> int type t51 = int -> int -> int type t52 = int -> int -> int type t53 = int -> int -> int type t54 = int -> int -> int type t55 = int -> int -> int type t56 = int -> int -> int type t57 = int -> int -> int type t58 = int -> int -> int type t59 = int -> int -> int type t60 = int -> int -> int type t61 = int -> int -> int type t62 = int -> int -> int type t63 = int -> int -> int type t64 = int -> int -> int type t65 = int -> int -> int type t66 = int -> int -> int type t67 = int -> int -> int type t68 = int -> int -> int type t69 = int -> int -> int type t70 = int -> int -> int type t71 = int -> int -> int type t72 = int -> int -> int type t73 = int -> int -> int type t74 = int -> int -> int type t75 = int -> int -> int type t76 = int -> int -> int type t77 = int -> int -> int type t78 = int -> int -> int type t79 = int -> int -> int type t80 = int -> int -> int type t81 = int -> int -> int type t82 = int -> int -> int type t83 = int -> int -> int type t84 = int -> int -> int type t85 = int -> int -> int type t86 = int -> int -> int type t87 = int -> int -> int type t88 = int -> int -> int type t89 = int -> int -> int type t90 = int -> int -> int type t91 = int -> int -> int type t92 = int -> int -> int type t93 = int -> int -> int type t94 = int -> int -> int type t95 = int -> int -> int type t96 = int -> int -> int type t97 = int -> int -> int type t98 = int -> int -> int type t99 = int -> int -> int type t100 = int -> int -> int type t101 = int -> int -> int type t102 = int -> int -> int type t103 = int -> int -> int type t104 = int -> int -> int type t105 = int -> int -> int type t106 = int -> int -> int type t107 = int -> int -> int type t108 = int -> int -> int type t109 = int -> int -> int type t110 = int -> int -> int type t111 = int -> int -> int type t112 = int -> int -> int type t113 = int -> int -> int type t114 = int -> int -> int type t115 = int -> int -> int type t116 = int -> int -> int type t117 = int -> int -> int type t118 = int -> int -> int type t119 = int -> int -> int type t120 = int -> int -> int type t121 = int -> int -> int type t122 = int -> int -> int type t123 = int -> int -> int type t124 = int -> int -> int type t125 = int -> int -> int type t126 = int -> int -> int type t127 = int -> int -> int type t128 = int -> int -> int type t129 = int -> int -> int type t130 = int -> int -> int type t131 = int -> int -> int type t132 = int -> int -> int type t133 = int -> int -> int type t134 = int -> int -> int type t135 = int -> int -> int type t136 = int -> int -> int type t137 = int -> int -> int type t138 = int -> int -> int type t139 = int -> int -> int type t140 = int -> int -> int type t141 = int -> int -> int type t142 = int -> int -> int type t143 = int -> int -> int type t144 = int -> int -> int type t145 = int -> int -> int type t146 = int -> int -> int type t147 = int -> int -> int type t148 = int -> int -> int type t149 = int -> int -> int type t150 = int -> int -> int type t151 = int -> int -> int type t152 = int -> int -> int type t153 = int -> int -> int type t154 = int -> int -> int type t155 = int -> int -> int type t156 = int -> int -> int type t157 = int -> int -> int type t158 = int -> int -> int type t159 = int -> int -> int type t160 = int -> int -> int type t161 = int -> int -> int type t162 = int -> int -> int type t163 = int -> int -> int type t164 = int -> int -> int type t165 = int -> int -> int type t166 = int -> int -> int type t167 = int -> int -> int type t168 = int -> int -> int type t169 = int -> int -> int type t170 = int -> int -> int type t171 = int -> int -> int type t172 = int -> int -> int type t173 = int -> int -> int type t174 = int -> int -> int type t175 = int -> int -> int type t176 = int -> int -> int type t177 = int -> int -> int type t178 = int -> int -> int type t179 = int -> int -> int type t180 = int -> int -> int type t181 = int -> int -> int type t182 = int -> int -> int type t183 = int -> int -> int type t184 = int -> int -> int type t185 = int -> int -> int type t186 = int -> int -> int type t187 = int -> int -> int type t188 = int -> int -> int type t189 = int -> int -> int type t190 = int -> int -> int type t191 = int -> int -> int type t192 = int -> int -> int type t193 = int -> int -> int type t194 = int -> int -> int type t195 = int -> int -> int type t196 = int -> int -> int type t197 = int -> int -> int type t198 = int -> int -> int type t199 = int -> int -> int type t200 = int -> int -> int type t201 = int -> int -> int type t202 = int -> int -> int type t203 = int -> int -> int type t204 = int -> int -> int type t205 = int -> int -> int type t206 = int -> int -> int type t207 = int -> int -> int type t208 = int -> int -> int type t209 = int -> int -> int type t210 = int -> int -> int type t211 = int -> int -> int type t212 = int -> int -> int type t213 = int -> int -> int type t214 = int -> int -> int type t215 = int -> int -> int type t216 = int -> int -> int type t217 = int -> int -> int type t218 = int -> int -> int type t219 = int -> int -> int type t220 = int -> int -> int type t221 = int -> int -> int type t222 = int -> int -> int type t223 = int -> int -> int type t224 = int -> int -> int type t225 = int -> int -> int type t226 = int -> int -> int type t227 = int -> int -> int type t228 = int -> int -> int type t229 = int -> int -> int type t230 = int -> int -> int type t231 = int -> int -> int type t232 = int -> int -> int type t233 = int -> int -> int type t234 = int -> int -> int type t235 = int -> int -> int type t236 = int -> int -> int type t237 = int -> int -> int type t238 = int -> int -> int type t239 = int -> int -> int type t240 = int -> int -> int type t241 = int -> int -> int type t242 = int -> int -> int type t243 = int -> int -> int type t244 = int -> int -> int type t245 = int -> int -> int type t246 = int -> int -> int type t247 = int -> int -> int type t248 = int -> int -> int type t249 = int -> int -> int type t250 = int -> int -> int type t251 = int -> int -> int type t252 = int -> int -> int type t253 = int -> int -> int type t254 = int -> int -> int type t255 = int -> int -> int type t256 = int -> int -> int type t257 = int -> int -> int type t258 = int -> int -> int type t259 = int -> int -> int type t260 = int -> int -> int type t261 = int -> int -> int type t262 = int -> int -> int type t263 = int -> int -> int type t264 = int -> int -> int type t265 = int -> int -> int type t266 = int -> int -> int type t267 = int -> int -> int type t268 = int -> int -> int type t269 = int -> int -> int type t270 = int -> int -> int type t271 = int -> int -> int type t272 = int -> int -> int type t273 = int -> int -> int type t274 = int -> int -> int type t275 = int -> int -> int type t276 = int -> int -> int type t277 = int -> int -> int type t278 = int -> int -> int type t279 = int -> int -> int type t280 = int -> int -> int type t281 = int -> int -> int type t282 = int -> int -> int type t283 = int -> int -> int type t284 = int -> int -> int type t285 = int -> int -> int type t286 = int -> int -> int type t287 = int -> int -> int type t288 = int -> int -> int type t289 = int -> int -> int type t290 = int -> int -> int type t291 = int -> int -> int type t292 = int -> int -> int type t293 = int -> int -> int type t294 = int -> int -> int type t295 = int -> int -> int type t296 = int -> int -> int type t297 = int -> int -> int type t298 = int -> int -> int type t299 = int -> int -> int type t300 = int -> int -> int type t301 = int -> int -> int type t302 = int -> int -> int type t303 = int -> int -> int type t304 = int -> int -> int type t305 = int -> int -> int type t306 = int -> int -> int type t307 = int -> int -> int type t308 = int -> int -> int type t309 = int -> int -> int type t310 = int -> int -> int type t311 = int -> int -> int type t312 = int -> int -> int type t313 = int -> int -> int type t314 = int -> int -> int type t315 = int -> int -> int type t316 = int -> int -> int type t317 = int -> int -> int type t318 = int -> int -> int type t319 = int -> int -> int type t320 = int -> int -> int type t321 = int -> int -> int type t322 = int -> int -> int type t323 = int -> int -> int type t324 = int -> int -> int type t325 = int -> int -> int type t326 = int -> int -> int type t327 = int -> int -> int type t328 = int -> int -> int type t329 = int -> int -> int type t330 = int -> int -> int type t331 = int -> int -> int type t332 = int -> int -> int type t333 = int -> int -> int type t334 = int -> int -> int type t335 = int -> int -> int type t336 = int -> int -> int type t337 = int -> int -> int type t338 = int -> int -> int type t339 = int -> int -> int type t340 = int -> int -> int type t341 = int -> int -> int type t342 = int -> int -> int type t343 = int -> int -> int type t344 = int -> int -> int type t345 = int -> int -> int type t346 = int -> int -> int type t347 = int -> int -> int type t348 = int -> int -> int type t349 = int -> int -> int type t350 = int -> int -> int type t351 = int -> int -> int type t352 = int -> int -> int type t353 = int -> int -> int type t354 = int -> int -> int type t355 = int -> int -> int type t356 = int -> int -> int type t357 = int -> int -> int type t358 = int -> int -> int type t359 = int -> int -> int type t360 = int -> int -> int type t361 = int -> int -> int type t362 = int -> int -> int type t363 = int -> int -> int type t364 = int -> int -> int type t365 = int -> int -> int type t366 = int -> int -> int type t367 = int -> int -> int type t368 = int -> int -> int type t369 = int -> int -> int type t370 = int -> int -> int type t371 = int -> int -> int type t372 = int -> int -> int type t373 = int -> int -> int type t374 = int -> int -> int type t375 = int -> int -> int type t376 = int -> int -> int type t377 = int -> int -> int type t378 = int -> int -> int type t379 = int -> int -> int type t380 = int -> int -> int type t381 = int -> int -> int type t382 = int -> int -> int type t383 = int -> int -> int type t384 = int -> int -> int type t385 = int -> int -> int type t386 = int -> int -> int type t387 = int -> int -> int type t388 = int -> int -> int type t389 = int -> int -> int type t390 = int -> int -> int type t391 = int -> int -> int type t392 = int -> int -> int type t393 = int -> int -> int type t394 = int -> int -> int type t395 = int -> int -> int type t396 = int -> int -> int type t397 = int -> int -> int type t398 = int -> int -> int type t399 = int -> int -> int type t400 = int -> int -> int type t401 = int -> int -> int type t402 = int -> int -> int type t403 = int -> int -> int type t404 = int -> int -> int type t405 = int -> int -> int type t406 = int -> int -> int type t407 = int -> int -> int type t408 = int -> int -> int type t409 = int -> int -> int type t410 = int -> int -> int type t411 = int -> int -> int type t412 = int -> int -> int type t413 = int -> int -> int type t414 = int -> int -> int type t415 = int -> int -> int type t416 = int -> int -> int type t417 = int -> int -> int type t418 = int -> int -> int type t419 = int -> int -> int type t420 = int -> int -> int type t421 = int -> int -> int type t422 = int -> int -> int type t423 = int -> int -> int type t424 = int -> int -> int type t425 = int -> int -> int type t426 = int -> int -> int type t427 = int -> int -> int type t428 = int -> int -> int type t429 = int -> int -> int type t430 = int -> int -> int type t431 = int -> int -> int type t432 = int -> int -> int type t433 = int -> int -> int type t434 = int -> int -> int type t435 = int -> int -> int type t436 = int -> int -> int type t437 = int -> int -> int type t438 = int -> int -> int type t439 = int -> int -> int type t440 = int -> int -> int type t441 = int -> int -> int type t442 = int -> int -> int type t443 = int -> int -> int type t444 = int -> int -> int type t445 = int -> int -> int type t446 = int -> int -> int type t447 = int -> int -> int type t448 = int -> int -> int type t449 = int -> int -> int type t450 = int -> int -> int type t451 = int -> int -> int type t452 = int -> int -> int type t453 = int -> int -> int type t454 = int -> int -> int type t455 = int -> int -> int type t456 = int -> int -> int type t457 = int -> int -> int type t458 = int -> int -> int type t459 = int -> int -> int type t460 = int -> int -> int type t461 = int -> int -> int type t462 = int -> int -> int type t463 = int -> int -> int type t464 = int -> int -> int type t465 = int -> int -> int type t466 = int -> int -> int type t467 = int -> int -> int type t468 = int -> int -> int type t469 = int -> int -> int type t470 = int -> int -> int type t471 = int -> int -> int type t472 = int -> int -> int type t473 = int -> int -> int type t474 = int -> int -> int type t475 = int -> int -> int type t476 = int -> int -> int type t477 = int -> int -> int type t478 = int -> int -> int type t479 = int -> int -> int type t480 = int -> int -> int type t481 = int -> int -> int type t482 = int -> int -> int type t483 = int -> int -> int type t484 = int -> int -> int type t485 = int -> int -> int type t486 = int -> int -> int type t487 = int -> int -> int type t488 = int -> int -> int type t489 = int -> int -> int type t490 = int -> int -> int type t491 = int -> int -> int type t492 = int -> int -> int type t493 = int -> int -> int type t494 = int -> int -> int type t495 = int -> int -> int type t496 = int -> int -> int type t497 = int -> int -> int type t498 = int -> int -> int type t499 = int -> int -> int type t500 = int -> int -> int type t501 = int -> int -> int type t502 = int -> int -> int type t503 = int -> int -> int type t504 = int -> int -> int type t505 = int -> int -> int type t506 = int -> int -> int type t507 = int -> int -> int type t508 = int -> int -> int type t509 = int -> int -> int type t510 = int -> int -> int type t511 = int -> int -> int type t512 = int -> int -> int type t513 = int -> int -> int type t514 = int -> int -> int type t515 = int -> int -> int type t516 = int -> int -> int type t517 = int -> int -> int type t518 = int -> int -> int type t519 = int -> int -> int type t520 = int -> int -> int type t521 = int -> int -> int type t522 = int -> int -> int type t523 = int -> int -> int type t524 = int -> int -> int type t525 = int -> int -> int type t526 = int -> int -> int type t527 = int -> int -> int type t528 = int -> int -> int type t529 = int -> int -> int type t530 = int -> int -> int type t531 = int -> int -> int type t532 = int -> int -> int type t533 = int -> int -> int type t534 = int -> int -> int type t535 = int -> int -> int type t536 = int -> int -> int type t537 = int -> int -> int type t538 = int -> int -> int type t539 = int -> int -> int type t540 = int -> int -> int type t541 = int -> int -> int type t542 = int -> int -> int type t543 = int -> int -> int type t544 = int -> int -> int type t545 = int -> int -> int type t546 = int -> int -> int type t547 = int -> int -> int type t548 = int -> int -> int type t549 = int -> int -> int type t550 = int -> int -> int type t551 = int -> int -> int type t552 = int -> int -> int type t553 = int -> int -> int type t554 = int -> int -> int type t555 = int -> int -> int type t556 = int -> int -> int type t557 = int -> int -> int type t558 = int -> int -> int type t559 = int -> int -> int type t560 = int -> int -> int type t561 = int -> int -> int type t562 = int -> int -> int type t563 = int -> int -> int type t564 = int -> int -> int type t565 = int -> int -> int type t566 = int -> int -> int type t567 = int -> int -> int type t568 = int -> int -> int type t569 = int -> int -> int type t570 = int -> int -> int type t571 = int -> int -> int type t572 = int -> int -> int type t573 = int -> int -> int type t574 = int -> int -> int type t575 = int -> int -> int type t576 = int -> int -> int type t577 = int -> int -> int type t578 = int -> int -> int type t579 = int -> int -> int type t580 = int -> int -> int type t581 = int -> int -> int type t582 = int -> int -> int type t583 = int -> int -> int type t584 = int -> int -> int type t585 = int -> int -> int type t586 = int -> int -> int type t587 = int -> int -> int type t588 = int -> int -> int type t589 = int -> int -> int type t590 = int -> int -> int type t591 = int -> int -> int type t592 = int -> int -> int type t593 = int -> int -> int type t594 = int -> int -> int type t595 = int -> int -> int type t596 = int -> int -> int type t597 = int -> int -> int type t598 = int -> int -> int type t599 = int -> int -> int type t600 = int -> int -> int type t601 = int -> int -> int type t602 = int -> int -> int type t603 = int -> int -> int type t604 = int -> int -> int type t605 = int -> int -> int type t606 = int -> int -> int type t607 = int -> int -> int type t608 = int -> int -> int type t609 = int -> int -> int type t610 = int -> int -> int type t611 = int -> int -> int type t612 = int -> int -> int type t613 = int -> int -> int type t614 = int -> int -> int type t615 = int -> int -> int type t616 = int -> int -> int type t617 = int -> int -> int type t618 = int -> int -> int type t619 = int -> int -> int type t620 = int -> int -> int type t621 = int -> int -> int type t622 = int -> int -> int type t623 = int -> int -> int type t624 = int -> int -> int type t625 = int -> int -> int type t626 = int -> int -> int type t627 = int -> int -> int type t628 = int -> int -> int type t629 = int -> int -> int type t630 = int -> int -> int type t631 = int -> int -> int type t632 = int -> int -> int type t633 = int -> int -> int type t634 = int -> int -> int type t635 = int -> int -> int type t636 = int -> int -> int type t637 = int -> int -> int type t638 = int -> int -> int type t639 = int -> int -> int type t640 = int -> int -> int type t641 = int -> int -> int type t642 = int -> int -> int type t643 = int -> int -> int type t644 = int -> int -> int type t645 = int -> int -> int type t646 = int -> int -> int type t647 = int -> int -> int type t648 = int -> int -> int type t649 = int -> int -> int type t650 = int -> int -> int type t651 = int -> int -> int type t652 = int -> int -> int type t653 = int -> int -> int type t654 = int -> int -> int type t655 = int -> int -> int type t656 = int -> int -> int type t657 = int -> int -> int type t658 = int -> int -> int type t659 = int -> int -> int type t660 = int -> int -> int type t661 = int -> int -> int type t662 = int -> int -> int type t663 = int -> int -> int type t664 = int -> int -> int type t665 = int -> int -> int type t666 = int -> int -> int type t667 = int -> int -> int type t668 = int -> int -> int type t669 = int -> int -> int type t670 = int -> int -> int type t671 = int -> int -> int type t672 = int -> int -> int type t673 = int -> int -> int type t674 = int -> int -> int type t675 = int -> int -> int type t676 = int -> int -> int type t677 = int -> int -> int type t678 = int -> int -> int type t679 = int -> int -> int type t680 = int -> int -> int type t681 = int -> int -> int type t682 = int -> int -> int type t683 = int -> int -> int type t684 = int -> int -> int type t685 = int -> int -> int type t686 = int -> int -> int type t687 = int -> int -> int type t688 = int -> int -> int type t689 = int -> int -> int type t690 = int -> int -> int type t691 = int -> int -> int type t692 = int -> int -> int type t693 = int -> int -> int type t694 = int -> int -> int type t695 = int -> int -> int type t696 = int -> int -> int type t697 = int -> int -> int type t698 = int -> int -> int type t699 = int -> int -> int type t700 = int -> int -> int type t701 = int -> int -> int type t702 = int -> int -> int type t703 = int -> int -> int type t704 = int -> int -> int type t705 = int -> int -> int type t706 = int -> int -> int type t707 = int -> int -> int type t708 = int -> int -> int type t709 = int -> int -> int type t710 = int -> int -> int type t711 = int -> int -> int type t712 = int -> int -> int type t713 = int -> int -> int type t714 = int -> int -> int type t715 = int -> int -> int type t716 = int -> int -> int type t717 = int -> int -> int type t718 = int -> int -> int type t719 = int -> int -> int type t720 = int -> int -> int type t721 = int -> int -> int type t722 = int -> int -> int type t723 = int -> int -> int type t724 = int -> int -> int type t725 = int -> int -> int type t726 = int -> int -> int type t727 = int -> int -> int type t728 = int -> int -> int type t729 = int -> int -> int type t730 = int -> int -> int type t731 = int -> int -> int type t732 = int -> int -> int type t733 = int -> int -> int type t734 = int -> int -> int type t735 = int -> int -> int type t736 = int -> int -> int type t737 = int -> int -> int type t738 = int -> int -> int type t739 = int -> int -> int type t740 = int -> int -> int type t741 = int -> int -> int type t742 = int -> int -> int type t743 = int -> int -> int type t744 = int -> int -> int type t745 = int -> int -> int type t746 = int -> int -> int type t747 = int -> int -> int type t748 = int -> int -> int type t749 = int -> int -> int type t750 = int -> int -> int type t751 = int -> int -> int type t752 = int -> int -> int type t753 = int -> int -> int type t754 = int -> int -> int type t755 = int -> int -> int type t756 = int -> int -> int type t757 = int -> int -> int type t758 = int -> int -> int type t759 = int -> int -> int type t760 = int -> int -> int type t761 = int -> int -> int type t762 = int -> int -> int type t763 = int -> int -> int type t764 = int -> int -> int type t765 = int -> int -> int type t766 = int -> int -> int type t767 = int -> int -> int type t768 = int -> int -> int type t769 = int -> int -> int type t770 = int -> int -> int type t771 = int -> int -> int type t772 = int -> int -> int type t773 = int -> int -> int type t774 = int -> int -> int type t775 = int -> int -> int type t776 = int -> int -> int type t777 = int -> int -> int type t778 = int -> int -> int type t779 = int -> int -> int type t780 = int -> int -> int type t781 = int -> int -> int type t782 = int -> int -> int type t783 = int -> int -> int type t784 = int -> int -> int type t785 = int -> int -> int type t786 = int -> int -> int type t787 = int -> int -> int type t788 = int -> int -> int type t789 = int -> int -> int type t790 = int -> int -> int type t791 = int -> int -> int type t792 = int -> int -> int type t793 = int -> int -> int type t794 = int -> int -> int type t795 = int -> int -> int type t796 = int -> int -> int type t797 = int -> int -> int type t798 = int -> int -> int type t799 = int -> int -> int type t800 = int -> int -> int type t801 = int -> int -> int type t802 = int -> int -> int type t803 = int -> int -> int type t804 = int -> int -> int type t805 = int -> int -> int type t806 = int -> int -> int type t807 = int -> int -> int type t808 = int -> int -> int type t809 = int -> int -> int type t810 = int -> int -> int type t811 = int -> int -> int type t812 = int -> int -> int type t813 = int -> int -> int type t814 = int -> int -> int type t815 = int -> int -> int type t816 = int -> int -> int type t817 = int -> int -> int type t818 = int -> int -> int type t819 = int -> int -> int type t820 = int -> int -> int type t821 = int -> int -> int type t822 = int -> int -> int type t823 = int -> int -> int type t824 = int -> int -> int type t825 = int -> int -> int type t826 = int -> int -> int type t827 = int -> int -> int type t828 = int -> int -> int type t829 = int -> int -> int type t830 = int -> int -> int type t831 = int -> int -> int type t832 = int -> int -> int type t833 = int -> int -> int type t834 = int -> int -> int type t835 = int -> int -> int type t836 = int -> int -> int type t837 = int -> int -> int type t838 = int -> int -> int type t839 = int -> int -> int type t840 = int -> int -> int type t841 = int -> int -> int type t842 = int -> int -> int type t843 = int -> int -> int type t844 = int -> int -> int type t845 = int -> int -> int type t846 = int -> int -> int type t847 = int -> int -> int type t848 = int -> int -> int type t849 = int -> int -> int type t850 = int -> int -> int type t851 = int -> int -> int type t852 = int -> int -> int type t853 = int -> int -> int type t854 = int -> int -> int type t855 = int -> int -> int type t856 = int -> int -> int type t857 = int -> int -> int type t858 = int -> int -> int type t859 = int -> int -> int type t860 = int -> int -> int type t861 = int -> int -> int type t862 = int -> int -> int type t863 = int -> int -> int type t864 = int -> int -> int type t865 = int -> int -> int type t866 = int -> int -> int type t867 = int -> int -> int type t868 = int -> int -> int type t869 = int -> int -> int type t870 = int -> int -> int type t871 = int -> int -> int type t872 = int -> int -> int type t873 = int -> int -> int type t874 = int -> int -> int type t875 = int -> int -> int type t876 = int -> int -> int type t877 = int -> int -> int type t878 = int -> int -> int type t879 = int -> int -> int type t880 = int -> int -> int type t881 = int -> int -> int type t882 = int -> int -> int type t883 = int -> int -> int type t884 = int -> int -> int type t885 = int -> int -> int type t886 = int -> int -> int type t887 = int -> int -> int type t888 = int -> int -> int type t889 = int -> int -> int type t890 = int -> int -> int type t891 = int -> int -> int type t892 = int -> int -> int type t893 = int -> int -> int type t894 = int -> int -> int type t895 = int -> int -> int type t896 = int -> int -> int type t897 = int -> int -> int type t898 = int -> int -> int type t899 = int -> int -> int type t900 = int -> int -> int type t901 = int -> int -> int type t902 = int -> int -> int type t903 = int -> int -> int type t904 = int -> int -> int type t905 = int -> int -> int type t906 = int -> int -> int type t907 = int -> int -> int type t908 = int -> int -> int type t909 = int -> int -> int type t910 = int -> int -> int type t911 = int -> int -> int type t912 = int -> int -> int type t913 = int -> int -> int type t914 = int -> int -> int type t915 = int -> int -> int type t916 = int -> int -> int type t917 = int -> int -> int type t918 = int -> int -> int type t919 = int -> int -> int type t920 = int -> int -> int type t921 = int -> int -> int type t922 = int -> int -> int type t923 = int -> int -> int type t924 = int -> int -> int type t925 = int -> int -> int type t926 = int -> int -> int type t927 = int -> int -> int type t928 = int -> int -> int type t929 = int -> int -> int type t930 = int -> int -> int type t931 = int -> int -> int type t932 = int -> int -> int type t933 = int -> int -> int type t934 = int -> int -> int type t935 = int -> int -> int type t936 = int -> int -> int type t937 = int -> int -> int type t938 = int -> int -> int type t939 = int -> int -> int type t940 = int -> int -> int type t941 = int -> int -> int type t942 = int -> int -> int type t943 = int -> int -> int type t944 = int -> int -> int type t945 = int -> int -> int type t946 = int -> int -> int type t947 = int -> int -> int type t948 = int -> int -> int type t949 = int -> int -> int type t950 = int -> int -> int type t951 = int -> int -> int type t952 = int -> int -> int type t953 = int -> int -> int type t954 = int -> int -> int type t955 = int -> int -> int type t956 = int -> int -> int type t957 = int -> int -> int type t958 = int -> int -> int type t959 = int -> int -> int type t960 = int -> int -> int type t961 = int -> int -> int type t962 = int -> int -> int type t963 = int -> int -> int type t964 = int -> int -> int type t965 = int -> int -> int type t966 = int -> int -> int type t967 = int -> int -> int type t968 = int -> int -> int type t969 = int -> int -> int type t970 = int -> int -> int type t971 = int -> int -> int type t972 = int -> int -> int type t973 = int -> int -> int type t974 = int -> int -> int type t975 = int -> int -> int type t976 = int -> int -> int type t977 = int -> int -> int type t978 = int -> int -> int type t979 = int -> int -> int type t980 = int -> int -> int type t981 = int -> int -> int type t982 = int -> int -> int type t983 = int -> int -> int type t984 = int -> int -> int type t985 = int -> int -> int type t986 = int -> int -> int type t987 = int -> int -> int type t988 = int -> int -> int type t989 = int -> int -> int type t990 = int -> int -> int type t991 = int -> int -> int type t992 = int -> int -> int type t993 = int -> int -> int type t994 = int -> int -> int type t995 = int -> int -> int type t996 = int -> int -> int type t997 = int -> int -> int type t998 = int -> int -> int type t999 = int -> int -> int type t1000 = int -> int -> int end module X = Make (Make (Make (Make (Make (Make (Make (Make (Make (Make (Make (M))))))))))) mingw-ocaml/ocaml/camlp4/test/fixtures/comments.ml0000644000175000017500000000337012124403240021647 0ustar tootstoots(** The first special comment of the file is the comment associated to the whole module.*) (** The comment for function f *) let f x y = x + y (** This comment is not attached to any element since there is another special comment just before the next element. *) (** Comment for exception My_exception, even with a simple comment between the special comment and the exception.*) (* A simple comment. *) exception My_exception of (int -> int) * int (** Comment for type weather *) type weather = | Rain of int (** The comment for constructor Rain *) | Sun (** The comment for constructor Sun *) (** The comment for type my_record *) type my_record = { foo : int ; (** Comment for field foo *) bar : string ; (** Comment for field bar *) } (** The comment for class my_class *) class my_class = object (** A comment to describe inheritance from cl *) inherit cl (** The comment for the instance variable tutu *) val mutable tutu = "tutu" (** The comment for toto *) val toto = 1 val titi = "titi" (** Comment for method toto *) method toto = tutu ^ "!" (** Comment for method m *) method m (f : float) = 1 end (** The comment for class type my_class_type *) class type my_class_type = object (** The comment for the instance variable x. *) val mutable x : int (** The commend for method m. *) method m : int -> int end (** The comment for module Foo *) module Foo = struct (** The comment for x *) let x = 42 (** A special comment in the class, but not associated to any element. *) end (** The comment for module type my_module_type. *) module type MY_MODULE_TYPE = sig (* Comment for value x. *) val x : int (* ... *) end mingw-ocaml/ocaml/camlp4/test/fixtures/class_expr_quot.ml0000644000175000017500000000151612124403240023235 0ustar tootstoots<:class_expr< a >>; <:class_expr< A.a B.b >>; <:class_expr< a [ t ] >>; <:class_expr< virtual a >>; <:class_expr< virtual $a$ >>; <:class_expr< virtual $lid:a$ >>; <:class_expr< virtual $lid:a$ [ 't ] >>; (* <:class_expr< virtual a [ t ] >>; *) <:class_expr< $opt:v$ a >>; <:class_expr< $opt:v$ a [ t ] >>; <:class_expr< $opt:v$ $a$ >>; <:class_expr< $opt:v$ $id:a$ >>; <:class_expr< $opt:v$ $a$ [ $t$ ] >>; (* <:class_expr< $opt:v$ a [ $t$ ] >>; *) (* <:class_expr< $opt:v$ a $opt:t$ >>; *) (* <:class_expr< $opt:v$ $a$ $opt:t$ >>; *) <:class_type< a >>; <:class_type< a [ t ] >>; <:class_type< virtual a >>; <:class_type< virtual $a$ >>; <:class_type< virtual $lid:a$ >>; <:class_type< virtual $lid:a$ [ 't ] >>; <:class_type< $opt:v$ a >>; <:class_type< $opt:v$ a [ t ] >>; <:class_type< $opt:v$ $a$ >>; <:class_type< $opt:v$ $a$ [ $t$ ] >>; mingw-ocaml/ocaml/camlp4/test/fixtures/metalib.ml0000644000175000017500000000024512124403240021435 0ustar tootstoots#load "camlp4of.cma";; open Camlp4.PreCast;; module M = Ast.Meta.Make(Ast.Meta.MetaGhostLoc);; let ghost = Loc.ghost;; M.Expr.meta_ctyp ghost <:ctyp@ghost< int >>;; mingw-ocaml/ocaml/camlp4/test/fixtures/match.ml0000644000175000017500000000035412124403240021115 0ustar tootstootslet x = match y with | A z -> z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z | B l -> (match l with | [] -> () | x::xs -> p x; self xs) | C -> () in x mingw-ocaml/ocaml/camlp4/test/fixtures/big-tab1.ml0000644000175000017500000000667412124403240021422 0ustar tootstoots[| aaa; aab; aac; aad; aae; aaf; aag; aah; aai; aaj; aak; aal; aam; aan; aao; aap; aaq; aar; aas; aat; aau; aav; aaw; aax; aay; aaz; aba; abb; abc; abd; abe; abf; abg; abh; abi; abj; abk; abl; abm; abn; abo; abp; abq; abr; abs; abt; abu; abv; abw; abx; aby; abz; aca; acb; acc; acd; ace; acf; acg; ach; aci; acj; ack; acl; acm; acn; aco; acp; acq; acr; acs; act; acu; acv; acw; acx; acy; acz; ada; adb; adc; add; ade; adf; adg; adh; adi; adj; adk; adl; adm; adn; ado; adp; adq; adr; ads; adt; adu; adv; adw; adx; ady; adz; aea; aeb; aec; aed; aee; aef; aeg; aeh; aei; aej; aek; ael; aem; aen; aeo; aep; aeq; aer; aes; aet; aeu; aev; aew; aex; aey; aez; afa; afb; afc; afd; afe; aff; afg; afh; afi; afj; afk; afl; afm; afn; afo; afp; afq; afr; afs; aft; afu; afv; afw; afx; afy; afz; aga; agb; agc; agd; age; agf; agg; agh; agi; agj; agk; agl; agm; agn; ago; agp; agq; agr; ags; agt; agu; agv; agw; agx; agy; agz; aha; ahb; ahc; ahd; ahe; ahf; ahg; ahh; ahi; ahj; ahk; ahl; ahm; ahn; aho; ahp; ahq; ahr; ahs; aht; ahu; ahv; ahw; ahx; ahy; ahz; aia; aib; aic; aid; aie; aif; aig; aih; aii; aij; aik; ail; aim; ain; aio; aip; aiq; air; ais; ait; aiu; aiv; aiw; aix; aiy; aiz; aja; ajb; ajc; ajd; aje; ajf; ajg; ajh; aji; ajj; ajk; ajl; ajm; ajn; ajo; ajp; ajq; ajr; ajs; ajt; aju; ajv; ajw; ajx; ajy; ajz; aka; akb; akc; akd; ake; akf; akg; akh; aki; akj; akk; akl; akm; akn; ako; akp; akq; akr; aks; akt; aku; akv; akw; akx; aky; akz; ala; alb; alc; ald; ale; alf; alg; alh; ali; alj; alk; all; alm; aln; alo; alp; alq; alr; als; alt; alu; alv; alw; alx; aly; alz; ama; amb; amc; amd; ame; amf; amg; amh; ami; amj; amk; aml; amm; amn; amo; amp; amq; amr; ams; amt; amu; amv; amw; amx; amy; amz; ana; anb; anc; ane; anf; ang; anh; ani; anj; ank; anl; anm; ann; ano; anp; anq; anr; ans; ant; anu; anv; anw; anx; any; anz; aoa; aob; aoc; aod; aoe; aof; aog; aoh; aoi; aoj; aok; aol; aom; aon; aoo; aop; aoq; aor; aos; aot; aou; aov; aow; aox; aoy; aoz; apa; apb; apc; apd; ape; apf; apg; aph; api; apj; apk; apl; apm; apn; apo; app; apq; apr; aps; apt; apu; apv; apw; apx; apy; apz; aqa; aqb; aqc; aqd; aqe; aqf; aqg; aqh; aqi; aqj; aqk; aql; aqm; aqn; aqo; aqp; aqq; aqr; aqs; aqt; aqu; aqv; aqw; aqx; aqy; aqz; ara; arb; arc; ard; are; arf; arg; arh; ari; arj; ark; arl; arm; arn; aro; arp; arq; arr; ars; art; aru; arv; arw; arx; ary; arz; asa; asb; asc; asd; ase; asf; asg; ash; asi; asj; ask; asl; asm; asn; aso; asp; asq; ass; ast; asu; asv; asw; asx; asy; asz; ata; atb; atc; atd; ate; atf; atg; ath; ati; atj; atk; atl; atm; atn; ato; atp; atq; atr; ats; att; atu; atv; atw; atx; aty; atz; aua; aub; auc; aud; aue; auf; aug; auh; aui; auj; auk; aul; aum; aun; auo; aup; auq; aur; aus; aut; auu; auv; auw; aux; auy; auz; ava; avb; avc; avd; ave; avf; avg; avh; avi; avj; avk; avl; avm; avn; avo; avp; avq; avr; avs; avt; avu; avv; avw; avx; avy; avz; awa; awb; awc; awd; awe; awf; awg; awh; awi; awj; awk; awl; awm; awn; awo; awp; awq; awr; aws; awt; awu; awv; aww; awx; awy; awz; axa; axb; axc; axd; axe; axf; axg; axh; axi; axj; axk; axl; axm; axn; axo; axp; axq; axr; axs; axt; axu; axv; axw; axx; axy; axz; aya; ayb; ayc; ayd; aye; ayf; ayg; ayh; ayi; ayj; ayk; ayl; aym; ayn; ayo; ayp; ayq; ayr; ays; ayt; ayu; ayv; ayw; ayx; ayy; ayz; aza; azb; azc; azd; aze; azf; azg; azh; azi; azj; azk; azl; azm; azn; azo; azp; azq; azr; azs; azt; azu; azv; azw; azx; azy; azz; baa; bab; bac; bad; bae; baf; bag; bah; bai; baj; bak; bal; bam; ban; bao; bap; baq; bar; bas; bat; bau; bav; baw; bax; bay; baz; bba; bbb |]; mingw-ocaml/ocaml/camlp4/test/fixtures/bug-camlp4o-constr-arity.ml0000644000175000017500000000263212124403240024570 0ustar tootstootstype t = A of t * t | B;; type t2 = C of (t2 * t2) | D;; type 'a t3 = S of 'a | T;; fun B B B -> ();; fun B (A (B, B)) B -> ();; fun D (D, D) -> ();; fun (C (D, D)) -> ();; let A (b, B) = A (B, B);; let f (A (B, B)) = ();; let f B (A (B, B)) = ();; let (D, d) = (D, D);; let (C (D, d)) = (C (D, D));; function S S T -> ();; function Some (A (B, B)) -> ();; function S (A (B, B)) -> ();; function S (D, D) -> ();; function (C (D, D)) -> ();; function | Some Some Some x -> x (* | None None None x -> x *) | _ -> assert false;; fun None None None -> ();; fun (Some None) None None -> ();; let Some a = Some 42;; let Some a :: y = [Some 42];; let Some a, b = Some 42, 43;; let (Some a), b = Some 42, 43;; let Some a as b = let _ = b = 42 in Some 42;; (* let Some (a as b) = let _ = b = None in Some 42;; *) (* let Some (a as b) = let _ = b = 42 in Some 42;; *) (* let (Some a) as b = let _ = b = 42 in Some 42;; *) (* let (Some a) as b = let _ = b = None in Some 42;; *) let Some a | Some a = Some 42;; let x,y as r = 1,2 ;; let ((x, y) as r) = (1, 2);; type top = Top of (int * int);; match Top (1,2) with Top min as t -> ();; match Top (1,2) with Top (min,max) as t -> ();; (* let Some 'a' .. 'b' = Some 'b';; *) let rec f x y = ();; fun x y -> ();; fun (x, y) -> ();; function x, y -> ();; let rec next line pos0 = () in ();; (* fun Some None None None -> ();; *) (* fun x, y -> ();; |+ syntax error +| *) mingw-ocaml/ocaml/camlp4/test/fixtures/pr4314gram3.ml0000644000175000017500000000132612124403240021710 0ustar tootstootsopen Camlp4.PreCast ; module G = Camlp4.PreCast.Gram ; value exp = G.Entry.mk "exp" ; value prog = G.Entry.mk "prog" ; EXTEND G exp: [ "apply" [ e1 = SELF; e2 = exp LEVEL "simple" -> let p = Loc.dump in let () = Format.eprintf "e1: %a,@.e2: %a,@.e1-e2: %a,@._loc: %a@." p e1 p e2 p (Loc.merge e1 e2) p _loc in _loc ] | "simple" [ _ = LIDENT -> _loc ] ]; prog: [[ e = exp; `EOI -> e ]]; END ; (* and the following function: *) value parse_string entry s = try G.parse_string entry (Loc.mk "") s with [ Loc.Exc_located loc exn -> begin print_endline (Loc.to_string loc); print_endline (Printexc.to_string exn); failwith "Syntax Error" end ] ; parse_string prog "f x"; mingw-ocaml/ocaml/camlp4/test/fixtures/bug_escaping_quot.ml0000644000175000017500000000042212124403240023513 0ustar tootstootsopen Camlp4.PreCast;; Camlp4_config.antiquotations := true;; let expand_my_quot_expr _loc _loc_name_opt quotation_contents = Printf.eprintf "%S\n%!" quotation_contents; <:expr< dummy >> ;; Syntax.Quotation.add "my" Syntax.Quotation.DynAst.expr_tag expand_my_quot_expr;; mingw-ocaml/ocaml/camlp4/test/fixtures/mod.ml0000644000175000017500000000037712124403240020605 0ustar tootstootsmodule type S = sig type t end module F (A : S) = struct type t2 = A.t module A = A end module A = struct type t = int end module type S3 = sig module M : S end module type S2 = S with type t = F(A).t2 module type S4 = S3 with module M = F(A).A mingw-ocaml/ocaml/camlp4/test/fixtures/big-tab3.ml0000644000175000017500000042133712124403240021421 0ustar tootstoots[| aaaaa; aaaab; aaaac; aaaad; aaaae; aaaaf; aaaag; aaaah; aaaai; aaaaj; aaaak; aaaal; aaaam; aaaan; aaaao; aaaap; aaaaq; aaaar; aaaas; aaaat; aaaau; aaaav; aaaaw; aaaax; aaaay; aaaaz; aaaba; aaabb; aaabc; aaabd; aaabe; aaabf; aaabg; aaabh; aaabi; aaabj; aaabk; aaabl; aaabm; aaabn; aaabo; aaabp; aaabq; aaabr; aaabs; aaabt; aaabu; aaabv; aaabw; aaabx; aaaby; aaabz; aaaca; aaacb; aaacc; aaacd; aaace; aaacf; aaacg; aaach; aaaci; aaacj; aaack; aaacl; aaacm; aaacn; aaaco; aaacp; aaacq; aaacr; aaacs; aaact; aaacu; aaacv; aaacw; aaacx; aaacy; aaacz; aaada; aaadb; aaadc; aaadd; aaade; aaadf; aaadg; aaadh; aaadi; aaadj; aaadk; aaadl; aaadm; aaadn; aaado; aaadp; aaadq; aaadr; aaads; aaadt; aaadu; aaadv; aaadw; aaadx; aaady; aaadz; aaaea; aaaeb; aaaec; aaaed; aaaee; aaaef; aaaeg; aaaeh; aaaei; aaaej; aaaek; aaael; aaaem; aaaen; aaaeo; aaaep; aaaeq; aaaer; aaaes; aaaet; aaaeu; aaaev; aaaew; aaaex; aaaey; aaaez; aaafa; aaafb; aaafc; aaafd; aaafe; aaaff; aaafg; aaafh; aaafi; aaafj; aaafk; aaafl; aaafm; aaafn; aaafo; aaafp; aaafq; aaafr; aaafs; aaaft; aaafu; aaafv; aaafw; aaafx; aaafy; aaafz; aaaga; aaagb; aaagc; aaagd; aaage; aaagf; aaagg; aaagh; aaagi; aaagj; aaagk; aaagl; aaagm; aaagn; aaago; aaagp; aaagq; aaagr; aaags; aaagt; aaagu; aaagv; aaagw; aaagx; aaagy; aaagz; aaaha; aaahb; aaahc; aaahd; aaahe; aaahf; aaahg; aaahh; aaahi; aaahj; aaahk; aaahl; aaahm; aaahn; aaaho; aaahp; aaahq; aaahr; aaahs; aaaht; aaahu; aaahv; aaahw; aaahx; aaahy; aaahz; aaaia; aaaib; aaaic; aaaid; aaaie; aaaif; aaaig; aaaih; aaaii; aaaij; aaaik; aaail; aaaim; aaain; aaaio; aaaip; aaaiq; aaair; aaais; aaait; aaaiu; aaaiv; aaaiw; aaaix; aaaiy; aaaiz; aaaja; aaajb; aaajc; aaajd; aaaje; aaajf; aaajg; aaajh; aaaji; aaajj; aaajk; aaajl; aaajm; aaajn; aaajo; aaajp; aaajq; aaajr; aaajs; aaajt; aaaju; aaajv; aaajw; aaajx; aaajy; aaajz; aaaka; aaakb; aaakc; aaakd; aaake; aaakf; aaakg; aaakh; aaaki; aaakj; aaakk; aaakl; aaakm; aaakn; aaako; aaakp; aaakq; aaakr; aaaks; aaakt; aaaku; aaakv; aaakw; aaakx; aaaky; aaakz; aaala; aaalb; aaalc; aaald; aaale; aaalf; aaalg; aaalh; aaali; aaalj; aaalk; aaall; aaalm; aaaln; aaalo; aaalp; aaalq; aaalr; aaals; aaalt; aaalu; aaalv; aaalw; aaalx; aaaly; aaalz; aaama; aaamb; aaamc; aaamd; aaame; aaamf; aaamg; aaamh; aaami; aaamj; aaamk; aaaml; aaamm; aaamn; aaamo; aaamp; aaamq; aaamr; aaams; aaamt; aaamu; aaamv; aaamw; aaamx; aaamy; aaamz; aaana; aaanb; aaanc; aaand; aaane; aaanf; aaang; aaanh; aaani; aaanj; aaank; aaanl; aaanm; aaann; aaano; aaanp; aaanq; aaanr; aaans; aaant; aaanu; aaanv; aaanw; aaanx; aaany; aaanz; aaaoa; aaaob; aaaoc; aaaod; aaaoe; aaaof; aaaog; aaaoh; aaaoi; aaaoj; aaaok; aaaol; aaaom; aaaon; aaaoo; aaaop; aaaoq; aaaor; aaaos; aaaot; aaaou; aaaov; aaaow; aaaox; aaaoy; aaaoz; aaapa; aaapb; aaapc; aaapd; aaape; aaapf; aaapg; aaaph; aaapi; aaapj; aaapk; aaapl; aaapm; aaapn; aaapo; aaapp; aaapq; aaapr; aaaps; aaapt; aaapu; aaapv; aaapw; aaapx; aaapy; aaapz; aaaqa; aaaqb; aaaqc; aaaqd; aaaqe; aaaqf; aaaqg; aaaqh; aaaqi; aaaqj; aaaqk; aaaql; aaaqm; aaaqn; aaaqo; aaaqp; aaaqq; aaaqr; aaaqs; aaaqt; aaaqu; aaaqv; aaaqw; aaaqx; aaaqy; aaaqz; aaara; aaarb; aaarc; aaard; aaare; aaarf; aaarg; aaarh; aaari; aaarj; aaark; aaarl; aaarm; aaarn; aaaro; aaarp; aaarq; aaarr; aaars; aaart; aaaru; aaarv; aaarw; aaarx; aaary; aaarz; aaasa; aaasb; aaasc; aaasd; aaase; aaasf; aaasg; aaash; aaasi; aaasj; aaask; aaasl; aaasm; aaasn; aaaso; aaasp; aaasq; aaasr; aaass; aaast; aaasu; aaasv; aaasw; aaasx; aaasy; aaasz; aaata; aaatb; aaatc; aaatd; aaate; aaatf; aaatg; aaath; aaati; aaatj; aaatk; aaatl; aaatm; aaatn; aaato; aaatp; aaatq; aaatr; aaats; aaatt; aaatu; aaatv; aaatw; aaatx; aaaty; aaatz; aaaua; aaaub; aaauc; aaaud; aaaue; aaauf; aaaug; aaauh; aaaui; aaauj; aaauk; aaaul; aaaum; aaaun; aaauo; aaaup; aaauq; aaaur; aaaus; aaaut; aaauu; aaauv; aaauw; aaaux; aaauy; aaauz; aaava; aaavb; aaavc; aaavd; aaave; aaavf; aaavg; aaavh; aaavi; aaavj; aaavk; aaavl; aaavm; aaavn; aaavo; aaavp; aaavq; aaavr; aaavs; aaavt; aaavu; aaavv; aaavw; aaavx; aaavy; aaavz; aaawa; aaawb; aaawc; aaawd; aaawe; aaawf; aaawg; aaawh; aaawi; aaawj; aaawk; aaawl; aaawm; aaawn; aaawo; aaawp; aaawq; aaawr; aaaws; aaawt; aaawu; aaawv; aaaww; aaawx; aaawy; aaawz; aaaxa; aaaxb; aaaxc; aaaxd; aaaxe; aaaxf; aaaxg; aaaxh; aaaxi; aaaxj; aaaxk; aaaxl; aaaxm; aaaxn; aaaxo; aaaxp; aaaxq; aaaxr; aaaxs; aaaxt; aaaxu; aaaxv; aaaxw; aaaxx; aaaxy; aaaxz; aaaya; aaayb; aaayc; aaayd; aaaye; aaayf; aaayg; aaayh; aaayi; aaayj; aaayk; aaayl; aaaym; aaayn; aaayo; aaayp; aaayq; aaayr; aaays; aaayt; aaayu; aaayv; aaayw; aaayx; aaayy; aaayz; aaaza; aaazb; aaazc; aaazd; aaaze; aaazf; aaazg; aaazh; aaazi; aaazj; aaazk; aaazl; aaazm; aaazn; aaazo; aaazp; aaazq; aaazr; aaazs; aaazt; aaazu; aaazv; aaazw; aaazx; aaazy; aaazz; aabaa; aabab; aabac; aabad; aabae; aabaf; aabag; aabah; aabai; aabaj; aabak; aabal; aabam; aaban; aabao; aabap; aabaq; aabar; aabas; aabat; aabau; aabav; aabaw; aabax; aabay; aabaz; aabba; aabbb; aabbc; aabbd; aabbe; aabbf; aabbg; aabbh; aabbi; aabbj; aabbk; aabbl; aabbm; aabbn; aabbo; aabbp; aabbq; aabbr; aabbs; aabbt; aabbu; aabbv; aabbw; aabbx; aabby; aabbz; aabca; aabcb; aabcc; aabcd; aabce; aabcf; aabcg; aabch; aabci; aabcj; aabck; aabcl; aabcm; aabcn; aabco; aabcp; aabcq; aabcr; aabcs; aabct; aabcu; aabcv; aabcw; aabcx; aabcy; aabcz; aabda; aabdb; aabdc; aabdd; aabde; aabdf; aabdg; aabdh; aabdi; aabdj; aabdk; aabdl; aabdm; aabdn; aabdo; aabdp; aabdq; aabdr; aabds; aabdt; aabdu; aabdv; aabdw; aabdx; aabdy; aabdz; aabea; aabeb; aabec; aabed; aabee; aabef; aabeg; aabeh; aabei; aabej; aabek; aabel; aabem; aaben; aabeo; aabep; aabeq; aaber; aabes; aabet; aabeu; aabev; aabew; aabex; aabey; aabez; aabfa; aabfb; aabfc; aabfd; aabfe; aabff; aabfg; aabfh; aabfi; aabfj; aabfk; aabfl; aabfm; aabfn; aabfo; aabfp; aabfq; aabfr; aabfs; aabft; aabfu; aabfv; aabfw; aabfx; aabfy; aabfz; aabga; aabgb; aabgc; aabgd; aabge; aabgf; aabgg; aabgh; aabgi; aabgj; aabgk; aabgl; aabgm; aabgn; aabgo; aabgp; aabgq; aabgr; aabgs; aabgt; aabgu; aabgv; aabgw; aabgx; aabgy; aabgz; aabha; aabhb; aabhc; aabhd; aabhe; aabhf; aabhg; aabhh; aabhi; aabhj; aabhk; aabhl; aabhm; aabhn; aabho; aabhp; aabhq; aabhr; aabhs; aabht; aabhu; aabhv; aabhw; aabhx; aabhy; aabhz; aabia; aabib; aabic; aabid; aabie; aabif; aabig; aabih; aabii; aabij; aabik; aabil; aabim; aabin; aabio; aabip; aabiq; aabir; aabis; aabit; aabiu; aabiv; aabiw; aabix; aabiy; aabiz; aabja; aabjb; aabjc; aabjd; aabje; aabjf; aabjg; aabjh; aabji; aabjj; aabjk; aabjl; aabjm; aabjn; aabjo; aabjp; aabjq; aabjr; aabjs; aabjt; aabju; aabjv; aabjw; aabjx; aabjy; aabjz; aabka; aabkb; aabkc; aabkd; aabke; aabkf; aabkg; aabkh; aabki; aabkj; aabkk; aabkl; aabkm; aabkn; aabko; aabkp; aabkq; aabkr; aabks; aabkt; aabku; aabkv; aabkw; aabkx; aabky; aabkz; aabla; aablb; aablc; aabld; aable; aablf; aablg; aablh; aabli; aablj; aablk; aabll; aablm; aabln; aablo; aablp; aablq; aablr; aabls; aablt; aablu; aablv; aablw; aablx; aably; aablz; aabma; aabmb; aabmc; aabmd; aabme; aabmf; aabmg; aabmh; aabmi; aabmj; aabmk; aabml; aabmm; aabmn; aabmo; aabmp; aabmq; aabmr; aabms; aabmt; aabmu; aabmv; aabmw; aabmx; aabmy; aabmz; aabna; aabnb; aabnc; aabnd; aabne; aabnf; aabng; aabnh; aabni; aabnj; aabnk; aabnl; aabnm; aabnn; aabno; aabnp; aabnq; aabnr; aabns; aabnt; aabnu; aabnv; aabnw; aabnx; aabny; aabnz; aaboa; aabob; aaboc; aabod; aaboe; aabof; aabog; aaboh; aaboi; aaboj; aabok; aabol; aabom; aabon; aaboo; aabop; aaboq; aabor; aabos; aabot; aabou; aabov; aabow; aabox; aaboy; aaboz; aabpa; aabpb; aabpc; aabpd; aabpe; aabpf; aabpg; aabph; aabpi; aabpj; aabpk; aabpl; aabpm; aabpn; aabpo; aabpp; aabpq; aabpr; aabps; aabpt; aabpu; aabpv; aabpw; aabpx; aabpy; aabpz; aabqa; aabqb; aabqc; aabqd; aabqe; aabqf; aabqg; aabqh; aabqi; aabqj; aabqk; aabql; aabqm; aabqn; aabqo; aabqp; aabqq; aabqr; aabqs; aabqt; aabqu; aabqv; aabqw; aabqx; aabqy; aabqz; aabra; aabrb; aabrc; aabrd; aabre; aabrf; aabrg; aabrh; aabri; aabrj; aabrk; aabrl; aabrm; aabrn; aabro; aabrp; aabrq; aabrr; aabrs; aabrt; aabru; aabrv; aabrw; aabrx; aabry; aabrz; aabsa; aabsb; aabsc; aabsd; aabse; aabsf; aabsg; aabsh; aabsi; aabsj; aabsk; aabsl; aabsm; aabsn; aabso; aabsp; aabsq; aabsr; aabss; aabst; aabsu; aabsv; aabsw; aabsx; aabsy; aabsz; aabta; aabtb; aabtc; aabtd; aabte; aabtf; aabtg; aabth; aabti; aabtj; aabtk; aabtl; aabtm; aabtn; aabto; aabtp; aabtq; aabtr; aabts; aabtt; aabtu; aabtv; aabtw; aabtx; aabty; aabtz; aabua; aabub; aabuc; aabud; aabue; aabuf; aabug; aabuh; aabui; aabuj; aabuk; aabul; aabum; aabun; aabuo; aabup; aabuq; aabur; aabus; aabut; aabuu; aabuv; aabuw; aabux; aabuy; aabuz; aabva; aabvb; aabvc; aabvd; aabve; aabvf; aabvg; aabvh; aabvi; aabvj; aabvk; aabvl; aabvm; aabvn; aabvo; aabvp; aabvq; aabvr; aabvs; aabvt; aabvu; aabvv; aabvw; aabvx; aabvy; aabvz; aabwa; aabwb; aabwc; aabwd; aabwe; aabwf; aabwg; aabwh; aabwi; aabwj; aabwk; aabwl; aabwm; aabwn; aabwo; aabwp; aabwq; aabwr; aabws; aabwt; aabwu; aabwv; aabww; aabwx; aabwy; aabwz; aabxa; aabxb; aabxc; aabxd; aabxe; aabxf; aabxg; aabxh; aabxi; aabxj; aabxk; aabxl; aabxm; aabxn; aabxo; aabxp; aabxq; aabxr; aabxs; aabxt; aabxu; aabxv; aabxw; aabxx; aabxy; aabxz; aabya; aabyb; aabyc; aabyd; aabye; aabyf; aabyg; aabyh; aabyi; aabyj; aabyk; aabyl; aabym; aabyn; aabyo; aabyp; aabyq; aabyr; aabys; aabyt; aabyu; aabyv; aabyw; aabyx; aabyy; aabyz; aabza; aabzb; aabzc; aabzd; aabze; aabzf; aabzg; aabzh; aabzi; aabzj; aabzk; aabzl; aabzm; aabzn; aabzo; aabzp; aabzq; aabzr; aabzs; aabzt; aabzu; aabzv; aabzw; aabzx; aabzy; aabzz; aacaa; aacab; aacac; aacad; aacae; aacaf; aacag; aacah; aacai; aacaj; aacak; aacal; aacam; aacan; aacao; aacap; aacaq; aacar; aacas; aacat; aacau; aacav; aacaw; aacax; aacay; aacaz; aacba; aacbb; aacbc; aacbd; aacbe; aacbf; aacbg; aacbh; aacbi; aacbj; aacbk; aacbl; aacbm; aacbn; aacbo; aacbp; aacbq; aacbr; aacbs; aacbt; aacbu; aacbv; aacbw; aacbx; aacby; aacbz; aacca; aaccb; aaccc; aaccd; aacce; aaccf; aaccg; aacch; aacci; aaccj; aacck; aaccl; aaccm; aaccn; aacco; aaccp; aaccq; aaccr; aaccs; aacct; aaccu; aaccv; aaccw; aaccx; aaccy; aaccz; aacda; aacdb; aacdc; aacdd; aacde; aacdf; aacdg; aacdh; aacdi; aacdj; aacdk; aacdl; aacdm; aacdn; aacdo; aacdp; aacdq; aacdr; aacds; aacdt; aacdu; aacdv; aacdw; aacdx; aacdy; aacdz; aacea; aaceb; aacec; aaced; aacee; aacef; aaceg; aaceh; aacei; aacej; aacek; aacel; aacem; aacen; aaceo; aacep; aaceq; aacer; aaces; aacet; aaceu; aacev; aacew; aacex; aacey; aacez; aacfa; aacfb; aacfc; aacfd; aacfe; aacff; aacfg; aacfh; aacfi; aacfj; aacfk; aacfl; aacfm; aacfn; aacfo; aacfp; aacfq; aacfr; aacfs; aacft; aacfu; aacfv; aacfw; aacfx; aacfy; aacfz; aacga; aacgb; aacgc; aacgd; aacge; aacgf; aacgg; aacgh; aacgi; aacgj; aacgk; aacgl; aacgm; aacgn; aacgo; aacgp; aacgq; aacgr; aacgs; aacgt; aacgu; aacgv; aacgw; aacgx; aacgy; aacgz; aacha; aachb; aachc; aachd; aache; aachf; aachg; aachh; aachi; aachj; aachk; aachl; aachm; aachn; aacho; aachp; aachq; aachr; aachs; aacht; aachu; aachv; aachw; aachx; aachy; aachz; aacia; aacib; aacic; aacid; aacie; aacif; aacig; aacih; aacii; aacij; aacik; aacil; aacim; aacin; aacio; aacip; aaciq; aacir; aacis; aacit; aaciu; aaciv; aaciw; aacix; aaciy; aaciz; aacja; aacjb; aacjc; aacjd; aacje; aacjf; aacjg; aacjh; aacji; aacjj; aacjk; aacjl; aacjm; aacjn; aacjo; aacjp; aacjq; aacjr; aacjs; aacjt; aacju; aacjv; aacjw; aacjx; aacjy; aacjz; aacka; aackb; aackc; aackd; aacke; aackf; aackg; aackh; aacki; aackj; aackk; aackl; aackm; aackn; aacko; aackp; aackq; aackr; aacks; aackt; aacku; aackv; aackw; aackx; aacky; aackz; aacla; aaclb; aaclc; aacld; aacle; aaclf; aaclg; aaclh; aacli; aaclj; aaclk; aacll; aaclm; aacln; aaclo; aaclp; aaclq; aaclr; aacls; aaclt; aaclu; aaclv; aaclw; aaclx; aacly; aaclz; aacma; aacmb; aacmc; aacmd; aacme; aacmf; aacmg; aacmh; aacmi; aacmj; aacmk; aacml; aacmm; aacmn; aacmo; aacmp; aacmq; aacmr; aacms; aacmt; aacmu; aacmv; aacmw; aacmx; aacmy; aacmz; aacna; aacnb; aacnc; aacnd; aacne; aacnf; aacng; aacnh; aacni; aacnj; aacnk; aacnl; aacnm; aacnn; aacno; aacnp; aacnq; aacnr; aacns; aacnt; aacnu; aacnv; aacnw; aacnx; aacny; aacnz; aacoa; aacob; aacoc; aacod; aacoe; aacof; aacog; aacoh; aacoi; aacoj; aacok; aacol; aacom; aacon; aacoo; aacop; aacoq; aacor; aacos; aacot; aacou; aacov; aacow; aacox; aacoy; aacoz; aacpa; aacpb; aacpc; aacpd; aacpe; aacpf; aacpg; aacph; aacpi; aacpj; aacpk; aacpl; aacpm; aacpn; aacpo; aacpp; aacpq; aacpr; aacps; aacpt; aacpu; aacpv; aacpw; aacpx; aacpy; aacpz; aacqa; aacqb; aacqc; aacqd; aacqe; aacqf; aacqg; aacqh; aacqi; aacqj; aacqk; aacql; aacqm; aacqn; aacqo; aacqp; aacqq; aacqr; aacqs; aacqt; aacqu; aacqv; aacqw; aacqx; aacqy; aacqz; aacra; aacrb; aacrc; aacrd; aacre; aacrf; aacrg; aacrh; aacri; aacrj; aacrk; aacrl; aacrm; aacrn; aacro; aacrp; aacrq; aacrr; aacrs; aacrt; aacru; aacrv; aacrw; aacrx; aacry; aacrz; aacsa; aacsb; aacsc; aacsd; aacse; aacsf; aacsg; aacsh; aacsi; aacsj; aacsk; aacsl; aacsm; aacsn; aacso; aacsp; aacsq; aacsr; aacss; aacst; aacsu; aacsv; aacsw; aacsx; aacsy; aacsz; aacta; aactb; aactc; aactd; aacte; aactf; aactg; aacth; aacti; aactj; aactk; aactl; aactm; aactn; aacto; aactp; aactq; aactr; aacts; aactt; aactu; aactv; aactw; aactx; aacty; aactz; aacua; aacub; aacuc; aacud; aacue; aacuf; aacug; aacuh; aacui; aacuj; aacuk; aacul; aacum; aacun; aacuo; aacup; aacuq; aacur; aacus; aacut; aacuu; aacuv; aacuw; aacux; aacuy; aacuz; aacva; aacvb; aacvc; aacvd; aacve; aacvf; aacvg; aacvh; aacvi; aacvj; aacvk; aacvl; aacvm; aacvn; aacvo; aacvp; aacvq; aacvr; aacvs; aacvt; aacvu; aacvv; aacvw; aacvx; aacvy; aacvz; aacwa; aacwb; aacwc; aacwd; aacwe; aacwf; aacwg; aacwh; aacwi; aacwj; aacwk; aacwl; aacwm; aacwn; aacwo; aacwp; aacwq; aacwr; aacws; aacwt; aacwu; aacwv; aacww; aacwx; aacwy; aacwz; aacxa; aacxb; aacxc; aacxd; aacxe; aacxf; aacxg; aacxh; aacxi; aacxj; aacxk; aacxl; aacxm; aacxn; aacxo; aacxp; aacxq; aacxr; aacxs; aacxt; aacxu; aacxv; aacxw; aacxx; aacxy; aacxz; aacya; aacyb; aacyc; aacyd; aacye; aacyf; aacyg; aacyh; aacyi; aacyj; aacyk; aacyl; aacym; aacyn; aacyo; aacyp; aacyq; aacyr; aacys; aacyt; aacyu; aacyv; aacyw; aacyx; aacyy; aacyz; aacza; aaczb; aaczc; aaczd; aacze; aaczf; aaczg; aaczh; aaczi; aaczj; aaczk; aaczl; aaczm; aaczn; aaczo; aaczp; aaczq; aaczr; aaczs; aaczt; aaczu; aaczv; aaczw; aaczx; aaczy; aaczz; aadaa; aadab; aadac; aadad; aadae; aadaf; aadag; aadah; aadai; aadaj; aadak; aadal; aadam; aadan; aadao; aadap; aadaq; aadar; aadas; aadat; aadau; aadav; aadaw; aadax; aaday; aadaz; aadba; aadbb; aadbc; aadbd; aadbe; aadbf; aadbg; aadbh; aadbi; aadbj; aadbk; aadbl; aadbm; aadbn; aadbo; aadbp; aadbq; aadbr; aadbs; aadbt; aadbu; aadbv; aadbw; aadbx; aadby; aadbz; aadca; aadcb; aadcc; aadcd; aadce; aadcf; aadcg; aadch; aadci; aadcj; aadck; aadcl; aadcm; aadcn; aadco; aadcp; aadcq; aadcr; aadcs; aadct; aadcu; aadcv; aadcw; aadcx; aadcy; aadcz; aadda; aaddb; aaddc; aaddd; aadde; aaddf; aaddg; aaddh; aaddi; aaddj; aaddk; aaddl; aaddm; aaddn; aaddo; aaddp; aaddq; aaddr; aadds; aaddt; aaddu; aaddv; aaddw; aaddx; aaddy; aaddz; aadea; aadeb; aadec; aaded; aadee; aadef; aadeg; aadeh; aadei; aadej; aadek; aadel; aadem; aaden; aadeo; aadep; aadeq; aader; aades; aadet; aadeu; aadev; aadew; aadex; aadey; aadez; aadfa; aadfb; aadfc; aadfd; aadfe; aadff; aadfg; aadfh; aadfi; aadfj; aadfk; aadfl; aadfm; aadfn; aadfo; aadfp; aadfq; aadfr; aadfs; aadft; aadfu; aadfv; aadfw; aadfx; aadfy; aadfz; aadga; aadgb; aadgc; aadgd; aadge; aadgf; aadgg; aadgh; aadgi; aadgj; aadgk; aadgl; aadgm; aadgn; aadgo; aadgp; aadgq; aadgr; aadgs; aadgt; aadgu; aadgv; aadgw; aadgx; aadgy; aadgz; aadha; aadhb; aadhc; aadhd; aadhe; aadhf; aadhg; aadhh; aadhi; aadhj; aadhk; aadhl; aadhm; aadhn; aadho; aadhp; aadhq; aadhr; aadhs; aadht; aadhu; aadhv; aadhw; aadhx; aadhy; aadhz; aadia; aadib; aadic; aadid; aadie; aadif; aadig; aadih; aadii; aadij; aadik; aadil; aadim; aadin; aadio; aadip; aadiq; aadir; aadis; aadit; aadiu; aadiv; aadiw; aadix; aadiy; aadiz; aadja; aadjb; aadjc; aadjd; aadje; aadjf; aadjg; aadjh; aadji; aadjj; aadjk; aadjl; aadjm; aadjn; aadjo; aadjp; aadjq; aadjr; aadjs; aadjt; aadju; aadjv; aadjw; aadjx; aadjy; aadjz; aadka; aadkb; aadkc; aadkd; aadke; aadkf; aadkg; aadkh; aadki; aadkj; aadkk; aadkl; aadkm; aadkn; aadko; aadkp; aadkq; aadkr; aadks; aadkt; aadku; aadkv; aadkw; aadkx; aadky; aadkz; aadla; aadlb; aadlc; aadld; aadle; aadlf; aadlg; aadlh; aadli; aadlj; aadlk; aadll; aadlm; aadln; aadlo; aadlp; aadlq; aadlr; aadls; aadlt; aadlu; aadlv; aadlw; aadlx; aadly; aadlz; aadma; aadmb; aadmc; aadmd; aadme; aadmf; aadmg; aadmh; aadmi; aadmj; aadmk; aadml; aadmm; aadmn; aadmo; aadmp; aadmq; aadmr; aadms; aadmt; aadmu; aadmv; aadmw; aadmx; aadmy; aadmz; aadna; aadnb; aadnc; aadnd; aadne; aadnf; aadng; aadnh; aadni; aadnj; aadnk; aadnl; aadnm; aadnn; aadno; aadnp; aadnq; aadnr; aadns; aadnt; aadnu; aadnv; aadnw; aadnx; aadny; aadnz; aadoa; aadob; aadoc; aadod; aadoe; aadof; aadog; aadoh; aadoi; aadoj; aadok; aadol; aadom; aadon; aadoo; aadop; aadoq; aador; aados; aadot; aadou; aadov; aadow; aadox; aadoy; aadoz; aadpa; aadpb; aadpc; aadpd; aadpe; aadpf; aadpg; aadph; aadpi; aadpj; aadpk; aadpl; aadpm; aadpn; aadpo; aadpp; aadpq; aadpr; aadps; aadpt; aadpu; aadpv; aadpw; aadpx; aadpy; aadpz; aadqa; aadqb; aadqc; aadqd; aadqe; aadqf; aadqg; aadqh; aadqi; aadqj; aadqk; aadql; aadqm; aadqn; aadqo; aadqp; aadqq; aadqr; aadqs; aadqt; aadqu; aadqv; aadqw; aadqx; aadqy; aadqz; aadra; aadrb; aadrc; aadrd; aadre; aadrf; aadrg; aadrh; aadri; aadrj; aadrk; aadrl; aadrm; aadrn; aadro; aadrp; aadrq; aadrr; aadrs; aadrt; aadru; aadrv; aadrw; aadrx; aadry; aadrz; aadsa; aadsb; aadsc; aadsd; aadse; aadsf; aadsg; aadsh; aadsi; aadsj; aadsk; aadsl; aadsm; aadsn; aadso; aadsp; aadsq; aadsr; aadss; aadst; aadsu; aadsv; aadsw; aadsx; aadsy; aadsz; aadta; aadtb; aadtc; aadtd; aadte; aadtf; aadtg; aadth; aadti; aadtj; aadtk; aadtl; aadtm; aadtn; aadto; aadtp; aadtq; aadtr; aadts; aadtt; aadtu; aadtv; aadtw; aadtx; aadty; aadtz; aadua; aadub; aaduc; aadud; aadue; aaduf; aadug; aaduh; aadui; aaduj; aaduk; aadul; aadum; aadun; aaduo; aadup; aaduq; aadur; aadus; aadut; aaduu; aaduv; aaduw; aadux; aaduy; aaduz; aadva; aadvb; aadvc; aadvd; aadve; aadvf; aadvg; aadvh; aadvi; aadvj; aadvk; aadvl; aadvm; aadvn; aadvo; aadvp; aadvq; aadvr; aadvs; aadvt; aadvu; aadvv; aadvw; aadvx; aadvy; aadvz; aadwa; aadwb; aadwc; aadwd; aadwe; aadwf; aadwg; aadwh; aadwi; aadwj; aadwk; aadwl; aadwm; aadwn; aadwo; aadwp; aadwq; aadwr; aadws; aadwt; aadwu; aadwv; aadww; aadwx; aadwy; aadwz; aadxa; aadxb; aadxc; aadxd; aadxe; aadxf; aadxg; aadxh; aadxi; aadxj; aadxk; aadxl; aadxm; aadxn; aadxo; aadxp; aadxq; aadxr; aadxs; aadxt; aadxu; aadxv; aadxw; aadxx; aadxy; aadxz; aadya; aadyb; aadyc; aadyd; aadye; aadyf; aadyg; aadyh; aadyi; aadyj; aadyk; aadyl; aadym; aadyn; aadyo; aadyp; aadyq; aadyr; aadys; aadyt; aadyu; aadyv; aadyw; aadyx; aadyy; aadyz; aadza; aadzb; aadzc; aadzd; aadze; aadzf; aadzg; aadzh; aadzi; aadzj; aadzk; aadzl; aadzm; aadzn; aadzo; aadzp; aadzq; aadzr; aadzs; aadzt; aadzu; aadzv; aadzw; aadzx; aadzy; aadzz; aaeaa; aaeab; aaeac; aaead; aaeae; aaeaf; aaeag; aaeah; aaeai; aaeaj; aaeak; aaeal; aaeam; aaean; aaeao; aaeap; aaeaq; aaear; aaeas; aaeat; aaeau; aaeav; aaeaw; aaeax; aaeay; aaeaz; aaeba; aaebb; aaebc; aaebd; aaebe; aaebf; aaebg; aaebh; aaebi; aaebj; aaebk; aaebl; aaebm; aaebn; aaebo; aaebp; aaebq; aaebr; aaebs; aaebt; aaebu; aaebv; aaebw; aaebx; aaeby; aaebz; aaeca; aaecb; aaecc; aaecd; aaece; aaecf; aaecg; aaech; aaeci; aaecj; aaeck; aaecl; aaecm; aaecn; aaeco; aaecp; aaecq; aaecr; aaecs; aaect; aaecu; aaecv; aaecw; aaecx; aaecy; aaecz; aaeda; aaedb; aaedc; aaedd; aaede; aaedf; aaedg; aaedh; aaedi; aaedj; aaedk; aaedl; aaedm; aaedn; aaedo; aaedp; aaedq; aaedr; aaeds; aaedt; aaedu; aaedv; aaedw; aaedx; aaedy; aaedz; aaeea; aaeeb; aaeec; aaeed; aaeee; aaeef; aaeeg; aaeeh; aaeei; aaeej; aaeek; aaeel; aaeem; aaeen; aaeeo; aaeep; aaeeq; aaeer; aaees; aaeet; aaeeu; aaeev; aaeew; aaeex; aaeey; aaeez; aaefa; aaefb; aaefc; aaefd; aaefe; aaeff; aaefg; aaefh; aaefi; aaefj; aaefk; aaefl; aaefm; aaefn; aaefo; aaefp; aaefq; aaefr; aaefs; aaeft; aaefu; aaefv; aaefw; aaefx; aaefy; aaefz; aaega; aaegb; aaegc; aaegd; aaege; aaegf; aaegg; aaegh; aaegi; aaegj; aaegk; aaegl; aaegm; aaegn; aaego; aaegp; aaegq; aaegr; aaegs; aaegt; aaegu; aaegv; aaegw; aaegx; aaegy; aaegz; aaeha; aaehb; aaehc; aaehd; aaehe; aaehf; aaehg; aaehh; aaehi; aaehj; aaehk; aaehl; aaehm; aaehn; aaeho; aaehp; aaehq; aaehr; aaehs; aaeht; aaehu; aaehv; aaehw; aaehx; aaehy; aaehz; aaeia; aaeib; aaeic; aaeid; aaeie; aaeif; aaeig; aaeih; aaeii; aaeij; aaeik; aaeil; aaeim; aaein; aaeio; aaeip; aaeiq; aaeir; aaeis; aaeit; aaeiu; aaeiv; aaeiw; aaeix; aaeiy; aaeiz; aaeja; aaejb; aaejc; aaejd; aaeje; aaejf; aaejg; aaejh; aaeji; aaejj; aaejk; aaejl; aaejm; aaejn; aaejo; aaejp; aaejq; aaejr; aaejs; aaejt; aaeju; aaejv; aaejw; aaejx; aaejy; aaejz; aaeka; aaekb; aaekc; aaekd; aaeke; aaekf; aaekg; aaekh; aaeki; aaekj; aaekk; aaekl; aaekm; aaekn; aaeko; aaekp; aaekq; aaekr; aaeks; aaekt; aaeku; aaekv; aaekw; aaekx; aaeky; aaekz; aaela; aaelb; aaelc; aaeld; aaele; aaelf; aaelg; aaelh; aaeli; aaelj; aaelk; aaell; aaelm; aaeln; aaelo; aaelp; aaelq; aaelr; aaels; aaelt; aaelu; aaelv; aaelw; aaelx; aaely; aaelz; aaema; aaemb; aaemc; aaemd; aaeme; aaemf; aaemg; aaemh; aaemi; aaemj; aaemk; aaeml; aaemm; aaemn; aaemo; aaemp; aaemq; aaemr; aaems; aaemt; aaemu; aaemv; aaemw; aaemx; aaemy; aaemz; aaena; aaenb; aaenc; aaend; aaene; aaenf; aaeng; aaenh; aaeni; aaenj; aaenk; aaenl; aaenm; aaenn; aaeno; aaenp; aaenq; aaenr; aaens; aaent; aaenu; aaenv; aaenw; aaenx; aaeny; aaenz; aaeoa; aaeob; aaeoc; aaeod; aaeoe; aaeof; aaeog; aaeoh; aaeoi; aaeoj; aaeok; aaeol; aaeom; aaeon; aaeoo; aaeop; aaeoq; aaeor; aaeos; aaeot; aaeou; aaeov; aaeow; aaeox; aaeoy; aaeoz; aaepa; aaepb; aaepc; aaepd; aaepe; aaepf; aaepg; aaeph; aaepi; aaepj; aaepk; aaepl; aaepm; aaepn; aaepo; aaepp; aaepq; aaepr; aaeps; aaept; aaepu; aaepv; aaepw; aaepx; aaepy; aaepz; aaeqa; aaeqb; aaeqc; aaeqd; aaeqe; aaeqf; aaeqg; aaeqh; aaeqi; aaeqj; aaeqk; aaeql; aaeqm; aaeqn; aaeqo; aaeqp; aaeqq; aaeqr; aaeqs; aaeqt; aaequ; aaeqv; aaeqw; aaeqx; aaeqy; aaeqz; aaera; aaerb; aaerc; aaerd; aaere; aaerf; aaerg; aaerh; aaeri; aaerj; aaerk; aaerl; aaerm; aaern; aaero; aaerp; aaerq; aaerr; aaers; aaert; aaeru; aaerv; aaerw; aaerx; aaery; aaerz; aaesa; aaesb; aaesc; aaesd; aaese; aaesf; aaesg; aaesh; aaesi; aaesj; aaesk; aaesl; aaesm; aaesn; aaeso; aaesp; aaesq; aaesr; aaess; aaest; aaesu; aaesv; aaesw; aaesx; aaesy; aaesz; aaeta; aaetb; aaetc; aaetd; aaete; aaetf; aaetg; aaeth; aaeti; aaetj; aaetk; aaetl; aaetm; aaetn; aaeto; aaetp; aaetq; aaetr; aaets; aaett; aaetu; aaetv; aaetw; aaetx; aaety; aaetz; aaeua; aaeub; aaeuc; aaeud; aaeue; aaeuf; aaeug; aaeuh; aaeui; aaeuj; aaeuk; aaeul; aaeum; aaeun; aaeuo; aaeup; aaeuq; aaeur; aaeus; aaeut; aaeuu; aaeuv; aaeuw; aaeux; aaeuy; aaeuz; aaeva; aaevb; aaevc; aaevd; aaeve; aaevf; aaevg; aaevh; aaevi; aaevj; aaevk; aaevl; aaevm; aaevn; aaevo; aaevp; aaevq; aaevr; aaevs; aaevt; aaevu; aaevv; aaevw; aaevx; aaevy; aaevz; aaewa; aaewb; aaewc; aaewd; aaewe; aaewf; aaewg; aaewh; aaewi; aaewj; aaewk; aaewl; aaewm; aaewn; aaewo; aaewp; aaewq; aaewr; aaews; aaewt; aaewu; aaewv; aaeww; aaewx; aaewy; aaewz; aaexa; aaexb; aaexc; aaexd; aaexe; aaexf; aaexg; aaexh; aaexi; aaexj; aaexk; aaexl; aaexm; aaexn; aaexo; aaexp; aaexq; aaexr; aaexs; aaext; aaexu; aaexv; aaexw; aaexx; aaexy; aaexz; aaeya; aaeyb; aaeyc; aaeyd; aaeye; aaeyf; aaeyg; aaeyh; aaeyi; aaeyj; aaeyk; aaeyl; aaeym; aaeyn; aaeyo; aaeyp; aaeyq; aaeyr; aaeys; aaeyt; aaeyu; aaeyv; aaeyw; aaeyx; aaeyy; aaeyz; aaeza; aaezb; aaezc; aaezd; aaeze; aaezf; aaezg; aaezh; aaezi; aaezj; aaezk; aaezl; aaezm; aaezn; aaezo; aaezp; aaezq; aaezr; aaezs; aaezt; aaezu; aaezv; aaezw; aaezx; aaezy; aaezz; aafaa; aafab; aafac; aafad; aafae; aafaf; aafag; aafah; aafai; aafaj; aafak; aafal; aafam; aafan; aafao; aafap; aafaq; aafar; aafas; aafat; aafau; aafav; aafaw; aafax; aafay; aafaz; aafba; aafbb; aafbc; aafbd; aafbe; aafbf; aafbg; aafbh; aafbi; aafbj; aafbk; aafbl; aafbm; aafbn; aafbo; aafbp; aafbq; aafbr; aafbs; aafbt; aafbu; aafbv; aafbw; aafbx; aafby; aafbz; aafca; aafcb; aafcc; aafcd; aafce; aafcf; aafcg; aafch; aafci; aafcj; aafck; aafcl; aafcm; aafcn; aafco; aafcp; aafcq; aafcr; aafcs; aafct; aafcu; aafcv; aafcw; aafcx; aafcy; aafcz; aafda; aafdb; aafdc; aafdd; aafde; aafdf; aafdg; aafdh; aafdi; aafdj; aafdk; aafdl; aafdm; aafdn; aafdo; aafdp; aafdq; aafdr; aafds; aafdt; aafdu; aafdv; aafdw; aafdx; aafdy; aafdz; aafea; aafeb; aafec; aafed; aafee; aafef; aafeg; aafeh; aafei; aafej; aafek; aafel; aafem; aafen; aafeo; aafep; aafeq; aafer; aafes; aafet; aafeu; aafev; aafew; aafex; aafey; aafez; aaffa; aaffb; aaffc; aaffd; aaffe; aafff; aaffg; aaffh; aaffi; aaffj; aaffk; aaffl; aaffm; aaffn; aaffo; aaffp; aaffq; aaffr; aaffs; aafft; aaffu; aaffv; aaffw; aaffx; aaffy; aaffz; aafga; aafgb; aafgc; aafgd; aafge; aafgf; aafgg; aafgh; aafgi; aafgj; aafgk; aafgl; aafgm; aafgn; aafgo; aafgp; aafgq; aafgr; aafgs; aafgt; aafgu; aafgv; aafgw; aafgx; aafgy; aafgz; aafha; aafhb; aafhc; aafhd; aafhe; aafhf; aafhg; aafhh; aafhi; aafhj; aafhk; aafhl; aafhm; aafhn; aafho; aafhp; aafhq; aafhr; aafhs; aafht; aafhu; aafhv; aafhw; aafhx; aafhy; aafhz; aafia; aafib; aafic; aafid; aafie; aafif; aafig; aafih; aafii; aafij; aafik; aafil; aafim; aafin; aafio; aafip; aafiq; aafir; aafis; aafit; aafiu; aafiv; aafiw; aafix; aafiy; aafiz; aafja; aafjb; aafjc; aafjd; aafje; aafjf; aafjg; aafjh; aafji; aafjj; aafjk; aafjl; aafjm; aafjn; aafjo; aafjp; aafjq; aafjr; aafjs; aafjt; aafju; aafjv; aafjw; aafjx; aafjy; aafjz; aafka; aafkb; aafkc; aafkd; aafke; aafkf; aafkg; aafkh; aafki; aafkj; aafkk; aafkl; aafkm; aafkn; aafko; aafkp; aafkq; aafkr; aafks; aafkt; aafku; aafkv; aafkw; aafkx; aafky; aafkz; aafla; aaflb; aaflc; aafld; aafle; aaflf; aaflg; aaflh; aafli; aaflj; aaflk; aafll; aaflm; aafln; aaflo; aaflp; aaflq; aaflr; aafls; aaflt; aaflu; aaflv; aaflw; aaflx; aafly; aaflz; aafma; aafmb; aafmc; aafmd; aafme; aafmf; aafmg; aafmh; aafmi; aafmj; aafmk; aafml; aafmm; aafmn; aafmo; aafmp; aafmq; aafmr; aafms; aafmt; aafmu; aafmv; aafmw; aafmx; aafmy; aafmz; aafna; aafnb; aafnc; aafnd; aafne; aafnf; aafng; aafnh; aafni; aafnj; aafnk; aafnl; aafnm; aafnn; aafno; aafnp; aafnq; aafnr; aafns; aafnt; aafnu; aafnv; aafnw; aafnx; aafny; aafnz; aafoa; aafob; aafoc; aafod; aafoe; aafof; aafog; aafoh; aafoi; aafoj; aafok; aafol; aafom; aafon; aafoo; aafop; aafoq; aafor; aafos; aafot; aafou; aafov; aafow; aafox; aafoy; aafoz; aafpa; aafpb; aafpc; aafpd; aafpe; aafpf; aafpg; aafph; aafpi; aafpj; aafpk; aafpl; aafpm; aafpn; aafpo; aafpp; aafpq; aafpr; aafps; aafpt; aafpu; aafpv; aafpw; aafpx; aafpy; aafpz; aafqa; aafqb; aafqc; aafqd; aafqe; aafqf; aafqg; aafqh; aafqi; aafqj; aafqk; aafql; aafqm; aafqn; aafqo; aafqp; aafqq; aafqr; aafqs; aafqt; aafqu; aafqv; aafqw; aafqx; aafqy; aafqz; aafra; aafrb; aafrc; aafrd; aafre; aafrf; aafrg; aafrh; aafri; aafrj; aafrk; aafrl; aafrm; aafrn; aafro; aafrp; aafrq; aafrr; aafrs; aafrt; aafru; aafrv; aafrw; aafrx; aafry; aafrz; aafsa; aafsb; aafsc; aafsd; aafse; aafsf; aafsg; aafsh; aafsi; aafsj; aafsk; aafsl; aafsm; aafsn; aafso; aafsp; aafsq; aafsr; aafss; aafst; aafsu; aafsv; aafsw; aafsx; aafsy; aafsz; aafta; aaftb; aaftc; aaftd; aafte; aaftf; aaftg; aafth; aafti; aaftj; aaftk; aaftl; aaftm; aaftn; aafto; aaftp; aaftq; aaftr; aafts; aaftt; aaftu; aaftv; aaftw; aaftx; aafty; aaftz; aafua; aafub; aafuc; aafud; aafue; aafuf; aafug; aafuh; aafui; aafuj; aafuk; aaful; aafum; aafun; aafuo; aafup; aafuq; aafur; aafus; aafut; aafuu; aafuv; aafuw; aafux; aafuy; aafuz; aafva; aafvb; aafvc; aafvd; aafve; aafvf; aafvg; aafvh; aafvi; aafvj; aafvk; aafvl; aafvm; aafvn; aafvo; aafvp; aafvq; aafvr; aafvs; aafvt; aafvu; aafvv; aafvw; aafvx; aafvy; aafvz; aafwa; aafwb; aafwc; aafwd; aafwe; aafwf; aafwg; aafwh; aafwi; aafwj; aafwk; aafwl; aafwm; aafwn; aafwo; aafwp; aafwq; aafwr; aafws; aafwt; aafwu; aafwv; aafww; aafwx; aafwy; aafwz; aafxa; aafxb; aafxc; aafxd; aafxe; aafxf; aafxg; aafxh; aafxi; aafxj; aafxk; aafxl; aafxm; aafxn; aafxo; aafxp; aafxq; aafxr; aafxs; aafxt; aafxu; aafxv; aafxw; aafxx; aafxy; aafxz; aafya; aafyb; aafyc; aafyd; aafye; aafyf; aafyg; aafyh; aafyi; aafyj; aafyk; aafyl; aafym; aafyn; aafyo; aafyp; aafyq; aafyr; aafys; aafyt; aafyu; aafyv; aafyw; aafyx; aafyy; aafyz; aafza; aafzb; aafzc; aafzd; aafze; aafzf; aafzg; aafzh; aafzi; aafzj; aafzk; aafzl; aafzm; aafzn; aafzo; aafzp; aafzq; aafzr; aafzs; aafzt; aafzu; aafzv; aafzw; aafzx; aafzy; aafzz; aagaa; aagab; aagac; aagad; aagae; aagaf; aagag; aagah; aagai; aagaj; aagak; aagal; aagam; aagan; aagao; aagap; aagaq; aagar; aagas; aagat; aagau; aagav; aagaw; aagax; aagay; aagaz; aagba; aagbb; aagbc; aagbd; aagbe; aagbf; aagbg; aagbh; aagbi; aagbj; aagbk; aagbl; aagbm; aagbn; aagbo; aagbp; aagbq; aagbr; aagbs; aagbt; aagbu; aagbv; aagbw; aagbx; aagby; aagbz; aagca; aagcb; aagcc; aagcd; aagce; aagcf; aagcg; aagch; aagci; aagcj; aagck; aagcl; aagcm; aagcn; aagco; aagcp; aagcq; aagcr; aagcs; aagct; aagcu; aagcv; aagcw; aagcx; aagcy; aagcz; aagda; aagdb; aagdc; aagdd; aagde; aagdf; aagdg; aagdh; aagdi; aagdj; aagdk; aagdl; aagdm; aagdn; aagdo; aagdp; aagdq; aagdr; aagds; aagdt; aagdu; aagdv; aagdw; aagdx; aagdy; aagdz; aagea; aageb; aagec; aaged; aagee; aagef; aageg; aageh; aagei; aagej; aagek; aagel; aagem; aagen; aageo; aagep; aageq; aager; aages; aaget; aageu; aagev; aagew; aagex; aagey; aagez; aagfa; aagfb; aagfc; aagfd; aagfe; aagff; aagfg; aagfh; aagfi; aagfj; aagfk; aagfl; aagfm; aagfn; aagfo; aagfp; aagfq; aagfr; aagfs; aagft; aagfu; aagfv; aagfw; aagfx; aagfy; aagfz; aagga; aaggb; aaggc; aaggd; aagge; aaggf; aaggg; aaggh; aaggi; aaggj; aaggk; aaggl; aaggm; aaggn; aaggo; aaggp; aaggq; aaggr; aaggs; aaggt; aaggu; aaggv; aaggw; aaggx; aaggy; aaggz; aagha; aaghb; aaghc; aaghd; aaghe; aaghf; aaghg; aaghh; aaghi; aaghj; aaghk; aaghl; aaghm; aaghn; aagho; aaghp; aaghq; aaghr; aaghs; aaght; aaghu; aaghv; aaghw; aaghx; aaghy; aaghz; aagia; aagib; aagic; aagid; aagie; aagif; aagig; aagih; aagii; aagij; aagik; aagil; aagim; aagin; aagio; aagip; aagiq; aagir; aagis; aagit; aagiu; aagiv; aagiw; aagix; aagiy; aagiz; aagja; aagjb; aagjc; aagjd; aagje; aagjf; aagjg; aagjh; aagji; aagjj; aagjk; aagjl; aagjm; aagjn; aagjo; aagjp; aagjq; aagjr; aagjs; aagjt; aagju; aagjv; aagjw; aagjx; aagjy; aagjz; aagka; aagkb; aagkc; aagkd; aagke; aagkf; aagkg; aagkh; aagki; aagkj; aagkk; aagkl; aagkm; aagkn; aagko; aagkp; aagkq; aagkr; aagks; aagkt; aagku; aagkv; aagkw; aagkx; aagky; aagkz; aagla; aaglb; aaglc; aagld; aagle; aaglf; aaglg; aaglh; aagli; aaglj; aaglk; aagll; aaglm; aagln; aaglo; aaglp; aaglq; aaglr; aagls; aaglt; aaglu; aaglv; aaglw; aaglx; aagly; aaglz; aagma; aagmb; aagmc; aagmd; aagme; aagmf; aagmg; aagmh; aagmi; aagmj; aagmk; aagml; aagmm; aagmn; aagmo; aagmp; aagmq; aagmr; aagms; aagmt; aagmu; aagmv; aagmw; aagmx; aagmy; aagmz; aagna; aagnb; aagnc; aagnd; aagne; aagnf; aagng; aagnh; aagni; aagnj; aagnk; aagnl; aagnm; aagnn; aagno; aagnp; aagnq; aagnr; aagns; aagnt; aagnu; aagnv; aagnw; aagnx; aagny; aagnz; aagoa; aagob; aagoc; aagod; aagoe; aagof; aagog; aagoh; aagoi; aagoj; aagok; aagol; aagom; aagon; aagoo; aagop; aagoq; aagor; aagos; aagot; aagou; aagov; aagow; aagox; aagoy; aagoz; aagpa; aagpb; aagpc; aagpd; aagpe; aagpf; aagpg; aagph; aagpi; aagpj; aagpk; aagpl; aagpm; aagpn; aagpo; aagpp; aagpq; aagpr; aagps; aagpt; aagpu; aagpv; aagpw; aagpx; aagpy; aagpz; aagqa; aagqb; aagqc; aagqd; aagqe; aagqf; aagqg; aagqh; aagqi; aagqj; aagqk; aagql; aagqm; aagqn; aagqo; aagqp; aagqq; aagqr; aagqs; aagqt; aagqu; aagqv; aagqw; aagqx; aagqy; aagqz; aagra; aagrb; aagrc; aagrd; aagre; aagrf; aagrg; aagrh; aagri; aagrj; aagrk; aagrl; aagrm; aagrn; aagro; aagrp; aagrq; aagrr; aagrs; aagrt; aagru; aagrv; aagrw; aagrx; aagry; aagrz; aagsa; aagsb; aagsc; aagsd; aagse; aagsf; aagsg; aagsh; aagsi; aagsj; aagsk; aagsl; aagsm; aagsn; aagso; aagsp; aagsq; aagsr; aagss; aagst; aagsu; aagsv; aagsw; aagsx; aagsy; aagsz; aagta; aagtb; aagtc; aagtd; aagte; aagtf; aagtg; aagth; aagti; aagtj; aagtk; aagtl; aagtm; aagtn; aagto; aagtp; aagtq; aagtr; aagts; aagtt; aagtu; aagtv; aagtw; aagtx; aagty; aagtz; aagua; aagub; aaguc; aagud; aague; aaguf; aagug; aaguh; aagui; aaguj; aaguk; aagul; aagum; aagun; aaguo; aagup; aaguq; aagur; aagus; aagut; aaguu; aaguv; aaguw; aagux; aaguy; aaguz; aagva; aagvb; aagvc; aagvd; aagve; aagvf; aagvg; aagvh; aagvi; aagvj; aagvk; aagvl; aagvm; aagvn; aagvo; aagvp; aagvq; aagvr; aagvs; aagvt; aagvu; aagvv; aagvw; aagvx; aagvy; aagvz; aagwa; aagwb; aagwc; aagwd; aagwe; aagwf; aagwg; aagwh; aagwi; aagwj; aagwk; aagwl; aagwm; aagwn; aagwo; aagwp; aagwq; aagwr; aagws; aagwt; aagwu; aagwv; aagww; aagwx; aagwy; aagwz; aagxa; aagxb; aagxc; aagxd; aagxe; aagxf; aagxg; aagxh; aagxi; aagxj; aagxk; aagxl; aagxm; aagxn; aagxo; aagxp; aagxq; aagxr; aagxs; aagxt; aagxu; aagxv; aagxw; aagxx; aagxy; aagxz; aagya; aagyb; aagyc; aagyd; aagye; aagyf; aagyg; aagyh; aagyi; aagyj; aagyk; aagyl; aagym; aagyn; aagyo; aagyp; aagyq; aagyr; aagys; aagyt; aagyu; aagyv; aagyw; aagyx; aagyy; aagyz; aagza; aagzb; aagzc; aagzd; aagze; aagzf; aagzg; aagzh; aagzi; aagzj; aagzk; aagzl; aagzm; aagzn; aagzo; aagzp; aagzq; aagzr; aagzs; aagzt; aagzu; aagzv; aagzw; aagzx; aagzy; aagzz; aahaa; aahab; aahac; aahad; aahae; aahaf; aahag; aahah; aahai; aahaj; aahak; aahal; aaham; aahan; aahao; aahap; aahaq; aahar; aahas; aahat; aahau; aahav; aahaw; aahax; aahay; aahaz; aahba; aahbb; aahbc; aahbd; aahbe; aahbf; aahbg; aahbh; aahbi; aahbj; aahbk; aahbl; aahbm; aahbn; aahbo; aahbp; aahbq; aahbr; aahbs; aahbt; aahbu; aahbv; aahbw; aahbx; aahby; aahbz; aahca; aahcb; aahcc; aahcd; aahce; aahcf; aahcg; aahch; aahci; aahcj; aahck; aahcl; aahcm; aahcn; aahco; aahcp; aahcq; aahcr; aahcs; aahct; aahcu; aahcv; aahcw; aahcx; aahcy; aahcz; aahda; aahdb; aahdc; aahdd; aahde; aahdf; aahdg; aahdh; aahdi; aahdj; aahdk; aahdl; aahdm; aahdn; aahdo; aahdp; aahdq; aahdr; aahds; aahdt; aahdu; aahdv; aahdw; aahdx; aahdy; aahdz; aahea; aaheb; aahec; aahed; aahee; aahef; aaheg; aaheh; aahei; aahej; aahek; aahel; aahem; aahen; aaheo; aahep; aaheq; aaher; aahes; aahet; aaheu; aahev; aahew; aahex; aahey; aahez; aahfa; aahfb; aahfc; aahfd; aahfe; aahff; aahfg; aahfh; aahfi; aahfj; aahfk; aahfl; aahfm; aahfn; aahfo; aahfp; aahfq; aahfr; aahfs; aahft; aahfu; aahfv; aahfw; aahfx; aahfy; aahfz; aahga; aahgb; aahgc; aahgd; aahge; aahgf; aahgg; aahgh; aahgi; aahgj; aahgk; aahgl; aahgm; aahgn; aahgo; aahgp; aahgq; aahgr; aahgs; aahgt; aahgu; aahgv; aahgw; aahgx; aahgy; aahgz; aahha; aahhb; aahhc; aahhd; aahhe; aahhf; aahhg; aahhh; aahhi; aahhj; aahhk; aahhl; aahhm; aahhn; aahho; aahhp; aahhq; aahhr; aahhs; aahht; aahhu; aahhv; aahhw; aahhx; aahhy; aahhz; aahia; aahib; aahic; aahid; aahie; aahif; aahig; aahih; aahii; aahij; aahik; aahil; aahim; aahin; aahio; aahip; aahiq; aahir; aahis; aahit; aahiu; aahiv; aahiw; aahix; aahiy; aahiz; aahja; aahjb; aahjc; aahjd; aahje; aahjf; aahjg; aahjh; aahji; aahjj; aahjk; aahjl; aahjm; aahjn; aahjo; aahjp; aahjq; aahjr; aahjs; aahjt; aahju; aahjv; aahjw; aahjx; aahjy; aahjz; aahka; aahkb; aahkc; aahkd; aahke; aahkf; aahkg; aahkh; aahki; aahkj; aahkk; aahkl; aahkm; aahkn; aahko; aahkp; aahkq; aahkr; aahks; aahkt; aahku; aahkv; aahkw; aahkx; aahky; aahkz; aahla; aahlb; aahlc; aahld; aahle; aahlf; aahlg; aahlh; aahli; aahlj; aahlk; aahll; aahlm; aahln; aahlo; aahlp; aahlq; aahlr; aahls; aahlt; aahlu; aahlv; aahlw; aahlx; aahly; aahlz; aahma; aahmb; aahmc; aahmd; aahme; aahmf; aahmg; aahmh; aahmi; aahmj; aahmk; aahml; aahmm; aahmn; aahmo; aahmp; aahmq; aahmr; aahms; aahmt; aahmu; aahmv; aahmw; aahmx; aahmy; aahmz; aahna; aahnb; aahnc; aahnd; aahne; aahnf; aahng; aahnh; aahni; aahnj; aahnk; aahnl; aahnm; aahnn; aahno; aahnp; aahnq; aahnr; aahns; aahnt; aahnu; aahnv; aahnw; aahnx; aahny; aahnz; aahoa; aahob; aahoc; aahod; aahoe; aahof; aahog; aahoh; aahoi; aahoj; aahok; aahol; aahom; aahon; aahoo; aahop; aahoq; aahor; aahos; aahot; aahou; aahov; aahow; aahox; aahoy; aahoz; aahpa; aahpb; aahpc; aahpd; aahpe; aahpf; aahpg; aahph; aahpi; aahpj; aahpk; aahpl; aahpm; aahpn; aahpo; aahpp; aahpq; aahpr; aahps; aahpt; aahpu; aahpv; aahpw; aahpx; aahpy; aahpz; aahqa; aahqb; aahqc; aahqd; aahqe; aahqf; aahqg; aahqh; aahqi; aahqj; aahqk; aahql; aahqm; aahqn; aahqo; aahqp; aahqq; aahqr; aahqs; aahqt; aahqu; aahqv; aahqw; aahqx; aahqy; aahqz; aahra; aahrb; aahrc; aahrd; aahre; aahrf; aahrg; aahrh; aahri; aahrj; aahrk; aahrl; aahrm; aahrn; aahro; aahrp; aahrq; aahrr; aahrs; aahrt; aahru; aahrv; aahrw; aahrx; aahry; aahrz; aahsa; aahsb; aahsc; aahsd; aahse; aahsf; aahsg; aahsh; aahsi; aahsj; aahsk; aahsl; aahsm; aahsn; aahso; aahsp; aahsq; aahsr; aahss; aahst; aahsu; aahsv; aahsw; aahsx; aahsy; aahsz; aahta; aahtb; aahtc; aahtd; aahte; aahtf; aahtg; aahth; aahti; aahtj; aahtk; aahtl; aahtm; aahtn; aahto; aahtp; aahtq; aahtr; aahts; aahtt; aahtu; aahtv; aahtw; aahtx; aahty; aahtz; aahua; aahub; aahuc; aahud; aahue; aahuf; aahug; aahuh; aahui; aahuj; aahuk; aahul; aahum; aahun; aahuo; aahup; aahuq; aahur; aahus; aahut; aahuu; aahuv; aahuw; aahux; aahuy; aahuz; aahva; aahvb; aahvc; aahvd; aahve; aahvf; aahvg; aahvh; aahvi; aahvj; aahvk; aahvl; aahvm; aahvn; aahvo; aahvp; aahvq; aahvr; aahvs; aahvt; aahvu; aahvv; aahvw; aahvx; aahvy; aahvz; aahwa; aahwb; aahwc; aahwd; aahwe; aahwf; aahwg; aahwh; aahwi; aahwj; aahwk; aahwl; aahwm; aahwn; aahwo; aahwp; aahwq; aahwr; aahws; aahwt; aahwu; aahwv; aahww; aahwx; aahwy; aahwz; aahxa; aahxb; aahxc; aahxd; aahxe; aahxf; aahxg; aahxh; aahxi; aahxj; aahxk; aahxl; aahxm; aahxn; aahxo; aahxp; aahxq; aahxr; aahxs; aahxt; aahxu; aahxv; aahxw; aahxx; aahxy; aahxz; aahya; aahyb; aahyc; aahyd; aahye; aahyf; aahyg; aahyh; aahyi; aahyj; aahyk; aahyl; aahym; aahyn; aahyo; aahyp; aahyq; aahyr; aahys; aahyt; aahyu; aahyv; aahyw; aahyx; aahyy; aahyz; aahza; aahzb; aahzc; aahzd; aahze; aahzf; aahzg; aahzh; aahzi; aahzj; aahzk; aahzl; aahzm; aahzn; aahzo; aahzp; aahzq; aahzr; aahzs; aahzt; aahzu; aahzv; aahzw; aahzx; aahzy; aahzz; aaiaa; aaiab; aaiac; aaiad; aaiae; aaiaf; aaiag; aaiah; aaiai; aaiaj; aaiak; aaial; aaiam; aaian; aaiao; aaiap; aaiaq; aaiar; aaias; aaiat; aaiau; aaiav; aaiaw; aaiax; aaiay; aaiaz; aaiba; aaibb; aaibc; aaibd; aaibe; aaibf; aaibg; aaibh; aaibi; aaibj; aaibk; aaibl; aaibm; aaibn; aaibo; aaibp; aaibq; aaibr; aaibs; aaibt; aaibu; aaibv; aaibw; aaibx; aaiby; aaibz; aaica; aaicb; aaicc; aaicd; aaice; aaicf; aaicg; aaich; aaici; aaicj; aaick; aaicl; aaicm; aaicn; aaico; aaicp; aaicq; aaicr; aaics; aaict; aaicu; aaicv; aaicw; aaicx; aaicy; aaicz; aaida; aaidb; aaidc; aaidd; aaide; aaidf; aaidg; aaidh; aaidi; aaidj; aaidk; aaidl; aaidm; aaidn; aaido; aaidp; aaidq; aaidr; aaids; aaidt; aaidu; aaidv; aaidw; aaidx; aaidy; aaidz; aaiea; aaieb; aaiec; aaied; aaiee; aaief; aaieg; aaieh; aaiei; aaiej; aaiek; aaiel; aaiem; aaien; aaieo; aaiep; aaieq; aaier; aaies; aaiet; aaieu; aaiev; aaiew; aaiex; aaiey; aaiez; aaifa; aaifb; aaifc; aaifd; aaife; aaiff; aaifg; aaifh; aaifi; aaifj; aaifk; aaifl; aaifm; aaifn; aaifo; aaifp; aaifq; aaifr; aaifs; aaift; aaifu; aaifv; aaifw; aaifx; aaify; aaifz; aaiga; aaigb; aaigc; aaigd; aaige; aaigf; aaigg; aaigh; aaigi; aaigj; aaigk; aaigl; aaigm; aaign; aaigo; aaigp; aaigq; aaigr; aaigs; aaigt; aaigu; aaigv; aaigw; aaigx; aaigy; aaigz; aaiha; aaihb; aaihc; aaihd; aaihe; aaihf; aaihg; aaihh; aaihi; aaihj; aaihk; aaihl; aaihm; aaihn; aaiho; aaihp; aaihq; aaihr; aaihs; aaiht; aaihu; aaihv; aaihw; aaihx; aaihy; aaihz; aaiia; aaiib; aaiic; aaiid; aaiie; aaiif; aaiig; aaiih; aaiii; aaiij; aaiik; aaiil; aaiim; aaiin; aaiio; aaiip; aaiiq; aaiir; aaiis; aaiit; aaiiu; aaiiv; aaiiw; aaiix; aaiiy; aaiiz; aaija; aaijb; aaijc; aaijd; aaije; aaijf; aaijg; aaijh; aaiji; aaijj; aaijk; aaijl; aaijm; aaijn; aaijo; aaijp; aaijq; aaijr; aaijs; aaijt; aaiju; aaijv; aaijw; aaijx; aaijy; aaijz; aaika; aaikb; aaikc; aaikd; aaike; aaikf; aaikg; aaikh; aaiki; aaikj; aaikk; aaikl; aaikm; aaikn; aaiko; aaikp; aaikq; aaikr; aaiks; aaikt; aaiku; aaikv; aaikw; aaikx; aaiky; aaikz; aaila; aailb; aailc; aaild; aaile; aailf; aailg; aailh; aaili; aailj; aailk; aaill; aailm; aailn; aailo; aailp; aailq; aailr; aails; aailt; aailu; aailv; aailw; aailx; aaily; aailz; aaima; aaimb; aaimc; aaimd; aaime; aaimf; aaimg; aaimh; aaimi; aaimj; aaimk; aaiml; aaimm; aaimn; aaimo; aaimp; aaimq; aaimr; aaims; aaimt; aaimu; aaimv; aaimw; aaimx; aaimy; aaimz; aaina; aainb; aainc; aaind; aaine; aainf; aaing; aainh; aaini; aainj; aaink; aainl; aainm; aainn; aaino; aainp; aainq; aainr; aains; aaint; aainu; aainv; aainw; aainx; aainy; aainz; aaioa; aaiob; aaioc; aaiod; aaioe; aaiof; aaiog; aaioh; aaioi; aaioj; aaiok; aaiol; aaiom; aaion; aaioo; aaiop; aaioq; aaior; aaios; aaiot; aaiou; aaiov; aaiow; aaiox; aaioy; aaioz; aaipa; aaipb; aaipc; aaipd; aaipe; aaipf; aaipg; aaiph; aaipi; aaipj; aaipk; aaipl; aaipm; aaipn; aaipo; aaipp; aaipq; aaipr; aaips; aaipt; aaipu; aaipv; aaipw; aaipx; aaipy; aaipz; aaiqa; aaiqb; aaiqc; aaiqd; aaiqe; aaiqf; aaiqg; aaiqh; aaiqi; aaiqj; aaiqk; aaiql; aaiqm; aaiqn; aaiqo; aaiqp; aaiqq; aaiqr; aaiqs; aaiqt; aaiqu; aaiqv; aaiqw; aaiqx; aaiqy; aaiqz; aaira; aairb; aairc; aaird; aaire; aairf; aairg; aairh; aairi; aairj; aairk; aairl; aairm; aairn; aairo; aairp; aairq; aairr; aairs; aairt; aairu; aairv; aairw; aairx; aairy; aairz; aaisa; aaisb; aaisc; aaisd; aaise; aaisf; aaisg; aaish; aaisi; aaisj; aaisk; aaisl; aaism; aaisn; aaiso; aaisp; aaisq; aaisr; aaiss; aaist; aaisu; aaisv; aaisw; aaisx; aaisy; aaisz; aaita; aaitb; aaitc; aaitd; aaite; aaitf; aaitg; aaith; aaiti; aaitj; aaitk; aaitl; aaitm; aaitn; aaito; aaitp; aaitq; aaitr; aaits; aaitt; aaitu; aaitv; aaitw; aaitx; aaity; aaitz; aaiua; aaiub; aaiuc; aaiud; aaiue; aaiuf; aaiug; aaiuh; aaiui; aaiuj; aaiuk; aaiul; aaium; aaiun; aaiuo; aaiup; aaiuq; aaiur; aaius; aaiut; aaiuu; aaiuv; aaiuw; aaiux; aaiuy; aaiuz; aaiva; aaivb; aaivc; aaivd; aaive; aaivf; aaivg; aaivh; aaivi; aaivj; aaivk; aaivl; aaivm; aaivn; aaivo; aaivp; aaivq; aaivr; aaivs; aaivt; aaivu; aaivv; aaivw; aaivx; aaivy; aaivz; aaiwa; aaiwb; aaiwc; aaiwd; aaiwe; aaiwf; aaiwg; aaiwh; aaiwi; aaiwj; aaiwk; aaiwl; aaiwm; aaiwn; aaiwo; aaiwp; aaiwq; aaiwr; aaiws; aaiwt; aaiwu; aaiwv; aaiww; aaiwx; aaiwy; aaiwz; aaixa; aaixb; aaixc; aaixd; aaixe; aaixf; aaixg; aaixh; aaixi; aaixj; aaixk; aaixl; aaixm; aaixn; aaixo; aaixp; aaixq; aaixr; aaixs; aaixt; aaixu; aaixv; aaixw; aaixx; aaixy; aaixz; aaiya; aaiyb; aaiyc; aaiyd; aaiye; aaiyf; aaiyg; aaiyh; aaiyi; aaiyj; aaiyk; aaiyl; aaiym; aaiyn; aaiyo; aaiyp; aaiyq; aaiyr; aaiys; aaiyt; aaiyu; aaiyv; aaiyw; aaiyx; aaiyy; aaiyz; aaiza; aaizb; aaizc; aaizd; aaize; aaizf; aaizg; aaizh; aaizi; aaizj; aaizk; aaizl; aaizm; aaizn; aaizo; aaizp; aaizq; aaizr; aaizs; aaizt; aaizu; aaizv; aaizw; aaizx; aaizy; aaizz; aajaa; aajab; aajac; aajad; aajae; aajaf; aajag; aajah; aajai; aajaj; aajak; aajal; aajam; aajan; aajao; aajap; aajaq; aajar; aajas; aajat; aajau; aajav; aajaw; aajax; aajay; aajaz; aajba; aajbb; aajbc; aajbd; aajbe; aajbf; aajbg; aajbh; aajbi; aajbj; aajbk; aajbl; aajbm; aajbn; aajbo; aajbp; aajbq; aajbr; aajbs; aajbt; aajbu; aajbv; aajbw; aajbx; aajby; aajbz; aajca; aajcb; aajcc; aajcd; aajce; aajcf; aajcg; aajch; aajci; aajcj; aajck; aajcl; aajcm; aajcn; aajco; aajcp; aajcq; aajcr; aajcs; aajct; aajcu; aajcv; aajcw; aajcx; aajcy; aajcz; aajda; aajdb; aajdc; aajdd; aajde; aajdf; aajdg; aajdh; aajdi; aajdj; aajdk; aajdl; aajdm; aajdn; aajdo; aajdp; aajdq; aajdr; aajds; aajdt; aajdu; aajdv; aajdw; aajdx; aajdy; aajdz; aajea; aajeb; aajec; aajed; aajee; aajef; aajeg; aajeh; aajei; aajej; aajek; aajel; aajem; aajen; aajeo; aajep; aajeq; aajer; aajes; aajet; aajeu; aajev; aajew; aajex; aajey; aajez; aajfa; aajfb; aajfc; aajfd; aajfe; aajff; aajfg; aajfh; aajfi; aajfj; aajfk; aajfl; aajfm; aajfn; aajfo; aajfp; aajfq; aajfr; aajfs; aajft; aajfu; aajfv; aajfw; aajfx; aajfy; aajfz; aajga; aajgb; aajgc; aajgd; aajge; aajgf; aajgg; aajgh; aajgi; aajgj; aajgk; aajgl; aajgm; aajgn; aajgo; aajgp; aajgq; aajgr; aajgs; aajgt; aajgu; aajgv; aajgw; aajgx; aajgy; aajgz; aajha; aajhb; aajhc; aajhd; aajhe; aajhf; aajhg; aajhh; aajhi; aajhj; aajhk; aajhl; aajhm; aajhn; aajho; aajhp; aajhq; aajhr; aajhs; aajht; aajhu; aajhv; aajhw; aajhx; aajhy; aajhz; aajia; aajib; aajic; aajid; aajie; aajif; aajig; aajih; aajii; aajij; aajik; aajil; aajim; aajin; aajio; aajip; aajiq; aajir; aajis; aajit; aajiu; aajiv; aajiw; aajix; aajiy; aajiz; aajja; aajjb; aajjc; aajjd; aajje; aajjf; aajjg; aajjh; aajji; aajjj; aajjk; aajjl; aajjm; aajjn; aajjo; aajjp; aajjq; aajjr; aajjs; aajjt; aajju; aajjv; aajjw; aajjx; aajjy; aajjz; aajka; aajkb; aajkc; aajkd; aajke; aajkf; aajkg; aajkh; aajki; aajkj; aajkk; aajkl; aajkm; aajkn; aajko; aajkp; aajkq; aajkr; aajks; aajkt; aajku; aajkv; aajkw; aajkx; aajky; aajkz; aajla; aajlb; aajlc; aajld; aajle; aajlf; aajlg; aajlh; aajli; aajlj; aajlk; aajll; aajlm; aajln; aajlo; aajlp; aajlq; aajlr; aajls; aajlt; aajlu; aajlv; aajlw; aajlx; aajly; aajlz; aajma; aajmb; aajmc; aajmd; aajme; aajmf; aajmg; aajmh; aajmi; aajmj; aajmk; aajml; aajmm; aajmn; aajmo; aajmp; aajmq; aajmr; aajms; aajmt; aajmu; aajmv; aajmw; aajmx; aajmy; aajmz; aajna; aajnb; aajnc; aajnd; aajne; aajnf; aajng; aajnh; aajni; aajnj; aajnk; aajnl; aajnm; aajnn; aajno; aajnp; aajnq; aajnr; aajns; aajnt; aajnu; aajnv; aajnw; aajnx; aajny; aajnz; aajoa; aajob; aajoc; aajod; aajoe; aajof; aajog; aajoh; aajoi; aajoj; aajok; aajol; aajom; aajon; aajoo; aajop; aajoq; aajor; aajos; aajot; aajou; aajov; aajow; aajox; aajoy; aajoz; aajpa; aajpb; aajpc; aajpd; aajpe; aajpf; aajpg; aajph; aajpi; aajpj; aajpk; aajpl; aajpm; aajpn; aajpo; aajpp; aajpq; aajpr; aajps; aajpt; aajpu; aajpv; aajpw; aajpx; aajpy; aajpz; aajqa; aajqb; aajqc; aajqd; aajqe; aajqf; aajqg; aajqh; aajqi; aajqj; aajqk; aajql; aajqm; aajqn; aajqo; aajqp; aajqq; aajqr; aajqs; aajqt; aajqu; aajqv; aajqw; aajqx; aajqy; aajqz; aajra; aajrb; aajrc; aajrd; aajre; aajrf; aajrg; aajrh; aajri; aajrj; aajrk; aajrl; aajrm; aajrn; aajro; aajrp; aajrq; aajrr; aajrs; aajrt; aajru; aajrv; aajrw; aajrx; aajry; aajrz; aajsa; aajsb; aajsc; aajsd; aajse; aajsf; aajsg; aajsh; aajsi; aajsj; aajsk; aajsl; aajsm; aajsn; aajso; aajsp; aajsq; aajsr; aajss; aajst; aajsu; aajsv; aajsw; aajsx; aajsy; aajsz; aajta; aajtb; aajtc; aajtd; aajte; aajtf; aajtg; aajth; aajti; aajtj; aajtk; aajtl; aajtm; aajtn; aajto; aajtp; aajtq; aajtr; aajts; aajtt; aajtu; aajtv; aajtw; aajtx; aajty; aajtz; aajua; aajub; aajuc; aajud; aajue; aajuf; aajug; aajuh; aajui; aajuj; aajuk; aajul; aajum; aajun; aajuo; aajup; aajuq; aajur; aajus; aajut; aajuu; aajuv; aajuw; aajux; aajuy; aajuz; aajva; aajvb; aajvc; aajvd; aajve; aajvf; aajvg; aajvh; aajvi; aajvj; aajvk; aajvl; aajvm; aajvn; aajvo; aajvp; aajvq; aajvr; aajvs; aajvt; aajvu; aajvv; aajvw; aajvx; aajvy; aajvz; aajwa; aajwb; aajwc; aajwd; aajwe; aajwf; aajwg; aajwh; aajwi; aajwj; aajwk; aajwl; aajwm; aajwn; aajwo; aajwp; aajwq; aajwr; aajws; aajwt; aajwu; aajwv; aajww; aajwx; aajwy; aajwz; aajxa; aajxb; aajxc; aajxd; aajxe; aajxf; aajxg; aajxh; aajxi; aajxj; aajxk; aajxl; aajxm; aajxn; aajxo; aajxp; aajxq; aajxr; aajxs; aajxt; aajxu; aajxv; aajxw; aajxx; aajxy; aajxz; aajya; aajyb; aajyc; aajyd; aajye; aajyf; aajyg; aajyh; aajyi; aajyj; aajyk; aajyl; aajym; aajyn; aajyo; aajyp; aajyq; aajyr; aajys; aajyt; aajyu; aajyv; aajyw; aajyx; aajyy; aajyz; aajza; aajzb; aajzc; aajzd; aajze; aajzf; aajzg; aajzh; aajzi; aajzj; aajzk; aajzl; aajzm; aajzn; aajzo; aajzp; aajzq; aajzr; aajzs; aajzt; aajzu; aajzv; aajzw; aajzx; aajzy; aajzz; aakaa; aakab; aakac; aakad; aakae; aakaf; aakag; aakah; aakai; aakaj; aakak; aakal; aakam; aakan; aakao; aakap; aakaq; aakar; aakas; aakat; aakau; aakav; aakaw; aakax; aakay; aakaz; aakba; aakbb; aakbc; aakbd; aakbe; aakbf; aakbg; aakbh; aakbi; aakbj; aakbk; aakbl; aakbm; aakbn; aakbo; aakbp; aakbq; aakbr; aakbs; aakbt; aakbu; aakbv; aakbw; aakbx; aakby; aakbz; aakca; aakcb; aakcc; aakcd; aakce; aakcf; aakcg; aakch; aakci; aakcj; aakck; aakcl; aakcm; aakcn; aakco; aakcp; aakcq; aakcr; aakcs; aakct; aakcu; aakcv; aakcw; aakcx; aakcy; aakcz; aakda; aakdb; aakdc; aakdd; aakde; aakdf; aakdg; aakdh; aakdi; aakdj; aakdk; aakdl; aakdm; aakdn; aakdo; aakdp; aakdq; aakdr; aakds; aakdt; aakdu; aakdv; aakdw; aakdx; aakdy; aakdz; aakea; aakeb; aakec; aaked; aakee; aakef; aakeg; aakeh; aakei; aakej; aakek; aakel; aakem; aaken; aakeo; aakep; aakeq; aaker; aakes; aaket; aakeu; aakev; aakew; aakex; aakey; aakez; aakfa; aakfb; aakfc; aakfd; aakfe; aakff; aakfg; aakfh; aakfi; aakfj; aakfk; aakfl; aakfm; aakfn; aakfo; aakfp; aakfq; aakfr; aakfs; aakft; aakfu; aakfv; aakfw; aakfx; aakfy; aakfz; aakga; aakgb; aakgc; aakgd; aakge; aakgf; aakgg; aakgh; aakgi; aakgj; aakgk; aakgl; aakgm; aakgn; aakgo; aakgp; aakgq; aakgr; aakgs; aakgt; aakgu; aakgv; aakgw; aakgx; aakgy; aakgz; aakha; aakhb; aakhc; aakhd; aakhe; aakhf; aakhg; aakhh; aakhi; aakhj; aakhk; aakhl; aakhm; aakhn; aakho; aakhp; aakhq; aakhr; aakhs; aakht; aakhu; aakhv; aakhw; aakhx; aakhy; aakhz; aakia; aakib; aakic; aakid; aakie; aakif; aakig; aakih; aakii; aakij; aakik; aakil; aakim; aakin; aakio; aakip; aakiq; aakir; aakis; aakit; aakiu; aakiv; aakiw; aakix; aakiy; aakiz; aakja; aakjb; aakjc; aakjd; aakje; aakjf; aakjg; aakjh; aakji; aakjj; aakjk; aakjl; aakjm; aakjn; aakjo; aakjp; aakjq; aakjr; aakjs; aakjt; aakju; aakjv; aakjw; aakjx; aakjy; aakjz; aakka; aakkb; aakkc; aakkd; aakke; aakkf; aakkg; aakkh; aakki; aakkj; aakkk; aakkl; aakkm; aakkn; aakko; aakkp; aakkq; aakkr; aakks; aakkt; aakku; aakkv; aakkw; aakkx; aakky; aakkz; aakla; aaklb; aaklc; aakld; aakle; aaklf; aaklg; aaklh; aakli; aaklj; aaklk; aakll; aaklm; aakln; aaklo; aaklp; aaklq; aaklr; aakls; aaklt; aaklu; aaklv; aaklw; aaklx; aakly; aaklz; aakma; aakmb; aakmc; aakmd; aakme; aakmf; aakmg; aakmh; aakmi; aakmj; aakmk; aakml; aakmm; aakmn; aakmo; aakmp; aakmq; aakmr; aakms; aakmt; aakmu; aakmv; aakmw; aakmx; aakmy; aakmz; aakna; aaknb; aaknc; aaknd; aakne; aaknf; aakng; aaknh; aakni; aaknj; aaknk; aaknl; aaknm; aaknn; aakno; aaknp; aaknq; aaknr; aakns; aaknt; aaknu; aaknv; aaknw; aaknx; aakny; aaknz; aakoa; aakob; aakoc; aakod; aakoe; aakof; aakog; aakoh; aakoi; aakoj; aakok; aakol; aakom; aakon; aakoo; aakop; aakoq; aakor; aakos; aakot; aakou; aakov; aakow; aakox; aakoy; aakoz; aakpa; aakpb; aakpc; aakpd; aakpe; aakpf; aakpg; aakph; aakpi; aakpj; aakpk; aakpl; aakpm; aakpn; aakpo; aakpp; aakpq; aakpr; aakps; aakpt; aakpu; aakpv; aakpw; aakpx; aakpy; aakpz; aakqa; aakqb; aakqc; aakqd; aakqe; aakqf; aakqg; aakqh; aakqi; aakqj; aakqk; aakql; aakqm; aakqn; aakqo; aakqp; aakqq; aakqr; aakqs; aakqt; aakqu; aakqv; aakqw; aakqx; aakqy; aakqz; aakra; aakrb; aakrc; aakrd; aakre; aakrf; aakrg; aakrh; aakri; aakrj; aakrk; aakrl; aakrm; aakrn; aakro; aakrp; aakrq; aakrr; aakrs; aakrt; aakru; aakrv; aakrw; aakrx; aakry; aakrz; aaksa; aaksb; aaksc; aaksd; aakse; aaksf; aaksg; aaksh; aaksi; aaksj; aaksk; aaksl; aaksm; aaksn; aakso; aaksp; aaksq; aaksr; aakss; aakst; aaksu; aaksv; aaksw; aaksx; aaksy; aaksz; aakta; aaktb; aaktc; aaktd; aakte; aaktf; aaktg; aakth; aakti; aaktj; aaktk; aaktl; aaktm; aaktn; aakto; aaktp; aaktq; aaktr; aakts; aaktt; aaktu; aaktv; aaktw; aaktx; aakty; aaktz; aakua; aakub; aakuc; aakud; aakue; aakuf; aakug; aakuh; aakui; aakuj; aakuk; aakul; aakum; aakun; aakuo; aakup; aakuq; aakur; aakus; aakut; aakuu; aakuv; aakuw; aakux; aakuy; aakuz; aakva; aakvb; aakvc; aakvd; aakve; aakvf; aakvg; aakvh; aakvi; aakvj; aakvk; aakvl; aakvm; aakvn; aakvo; aakvp; aakvq; aakvr; aakvs; aakvt; aakvu; aakvv; aakvw; aakvx; aakvy; aakvz; aakwa; aakwb; aakwc; aakwd; aakwe; aakwf; aakwg; aakwh; aakwi; aakwj; aakwk; aakwl; aakwm; aakwn; aakwo; aakwp; aakwq; aakwr; aakws; aakwt; aakwu; aakwv; aakww; aakwx; aakwy; aakwz; aakxa; aakxb; aakxc; aakxd; aakxe; aakxf; aakxg; aakxh; aakxi; aakxj; aakxk; aakxl; aakxm; aakxn; aakxo; aakxp; aakxq; aakxr; aakxs; aakxt; aakxu; aakxv; aakxw; aakxx; aakxy; aakxz; aakya; aakyb; aakyc; aakyd; aakye; aakyf; aakyg; aakyh; aakyi; aakyj; aakyk; aakyl; aakym; aakyn; aakyo; aakyp; aakyq; aakyr; aakys; aakyt; aakyu; aakyv; aakyw; aakyx; aakyy; aakyz; aakza; aakzb; aakzc; aakzd; aakze; aakzf; aakzg; aakzh; aakzi; aakzj; aakzk; aakzl; aakzm; aakzn; aakzo; aakzp; aakzq; aakzr; aakzs; aakzt; aakzu; aakzv; aakzw; aakzx; aakzy; aakzz; aalaa; aalab; aalac; aalad; aalae; aalaf; aalag; aalah; aalai; aalaj; aalak; aalal; aalam; aalan; aalao; aalap; aalaq; aalar; aalas; aalat; aalau; aalav; aalaw; aalax; aalay; aalaz; aalba; aalbb; aalbc; aalbd; aalbe; aalbf; aalbg; aalbh; aalbi; aalbj; aalbk; aalbl; aalbm; aalbn; aalbo; aalbp; aalbq; aalbr; aalbs; aalbt; aalbu; aalbv; aalbw; aalbx; aalby; aalbz; aalca; aalcb; aalcc; aalcd; aalce; aalcf; aalcg; aalch; aalci; aalcj; aalck; aalcl; aalcm; aalcn; aalco; aalcp; aalcq; aalcr; aalcs; aalct; aalcu; aalcv; aalcw; aalcx; aalcy; aalcz; aalda; aaldb; aaldc; aaldd; aalde; aaldf; aaldg; aaldh; aaldi; aaldj; aaldk; aaldl; aaldm; aaldn; aaldo; aaldp; aaldq; aaldr; aalds; aaldt; aaldu; aaldv; aaldw; aaldx; aaldy; aaldz; aalea; aaleb; aalec; aaled; aalee; aalef; aaleg; aaleh; aalei; aalej; aalek; aalel; aalem; aalen; aaleo; aalep; aaleq; aaler; aales; aalet; aaleu; aalev; aalew; aalex; aaley; aalez; aalfa; aalfb; aalfc; aalfd; aalfe; aalff; aalfg; aalfh; aalfi; aalfj; aalfk; aalfl; aalfm; aalfn; aalfo; aalfp; aalfq; aalfr; aalfs; aalft; aalfu; aalfv; aalfw; aalfx; aalfy; aalfz; aalga; aalgb; aalgc; aalgd; aalge; aalgf; aalgg; aalgh; aalgi; aalgj; aalgk; aalgl; aalgm; aalgn; aalgo; aalgp; aalgq; aalgr; aalgs; aalgt; aalgu; aalgv; aalgw; aalgx; aalgy; aalgz; aalha; aalhb; aalhc; aalhd; aalhe; aalhf; aalhg; aalhh; aalhi; aalhj; aalhk; aalhl; aalhm; aalhn; aalho; aalhp; aalhq; aalhr; aalhs; aalht; aalhu; aalhv; aalhw; aalhx; aalhy; aalhz; aalia; aalib; aalic; aalid; aalie; aalif; aalig; aalih; aalii; aalij; aalik; aalil; aalim; aalin; aalio; aalip; aaliq; aalir; aalis; aalit; aaliu; aaliv; aaliw; aalix; aaliy; aaliz; aalja; aaljb; aaljc; aaljd; aalje; aaljf; aaljg; aaljh; aalji; aaljj; aaljk; aaljl; aaljm; aaljn; aaljo; aaljp; aaljq; aaljr; aaljs; aaljt; aalju; aaljv; aaljw; aaljx; aaljy; aaljz; aalka; aalkb; aalkc; aalkd; aalke; aalkf; aalkg; aalkh; aalki; aalkj; aalkk; aalkl; aalkm; aalkn; aalko; aalkp; aalkq; aalkr; aalks; aalkt; aalku; aalkv; aalkw; aalkx; aalky; aalkz; aalla; aallb; aallc; aalld; aalle; aallf; aallg; aallh; aalli; aallj; aallk; aalll; aallm; aalln; aallo; aallp; aallq; aallr; aalls; aallt; aallu; aallv; aallw; aallx; aally; aallz; aalma; aalmb; aalmc; aalmd; aalme; aalmf; aalmg; aalmh; aalmi; aalmj; aalmk; aalml; aalmm; aalmn; aalmo; aalmp; aalmq; aalmr; aalms; aalmt; aalmu; aalmv; aalmw; aalmx; aalmy; aalmz; aalna; aalnb; aalnc; aalnd; aalne; aalnf; aalng; aalnh; aalni; aalnj; aalnk; aalnl; aalnm; aalnn; aalno; aalnp; aalnq; aalnr; aalns; aalnt; aalnu; aalnv; aalnw; aalnx; aalny; aalnz; aaloa; aalob; aaloc; aalod; aaloe; aalof; aalog; aaloh; aaloi; aaloj; aalok; aalol; aalom; aalon; aaloo; aalop; aaloq; aalor; aalos; aalot; aalou; aalov; aalow; aalox; aaloy; aaloz; aalpa; aalpb; aalpc; aalpd; aalpe; aalpf; aalpg; aalph; aalpi; aalpj; aalpk; aalpl; aalpm; aalpn; aalpo; aalpp; aalpq; aalpr; aalps; aalpt; aalpu; aalpv; aalpw; aalpx; aalpy; aalpz; aalqa; aalqb; aalqc; aalqd; aalqe; aalqf; aalqg; aalqh; aalqi; aalqj; aalqk; aalql; aalqm; aalqn; aalqo; aalqp; aalqq; aalqr; aalqs; aalqt; aalqu; aalqv; aalqw; aalqx; aalqy; aalqz; aalra; aalrb; aalrc; aalrd; aalre; aalrf; aalrg; aalrh; aalri; aalrj; aalrk; aalrl; aalrm; aalrn; aalro; aalrp; aalrq; aalrr; aalrs; aalrt; aalru; aalrv; aalrw; aalrx; aalry; aalrz; aalsa; aalsb; aalsc; aalsd; aalse; aalsf; aalsg; aalsh; aalsi; aalsj; aalsk; aalsl; aalsm; aalsn; aalso; aalsp; aalsq; aalsr; aalss; aalst; aalsu; aalsv; aalsw; aalsx; aalsy; aalsz; aalta; aaltb; aaltc; aaltd; aalte; aaltf; aaltg; aalth; aalti; aaltj; aaltk; aaltl; aaltm; aaltn; aalto; aaltp; aaltq; aaltr; aalts; aaltt; aaltu; aaltv; aaltw; aaltx; aalty; aaltz; aalua; aalub; aaluc; aalud; aalue; aaluf; aalug; aaluh; aalui; aaluj; aaluk; aalul; aalum; aalun; aaluo; aalup; aaluq; aalur; aalus; aalut; aaluu; aaluv; aaluw; aalux; aaluy; aaluz; aalva; aalvb; aalvc; aalvd; aalve; aalvf; aalvg; aalvh; aalvi; aalvj; aalvk; aalvl; aalvm; aalvn; aalvo; aalvp; aalvq; aalvr; aalvs; aalvt; aalvu; aalvv; aalvw; aalvx; aalvy; aalvz; aalwa; aalwb; aalwc; aalwd; aalwe; aalwf; aalwg; aalwh; aalwi; aalwj; aalwk; aalwl; aalwm; aalwn; aalwo; aalwp; aalwq; aalwr; aalws; aalwt; aalwu; aalwv; aalww; aalwx; aalwy; aalwz; aalxa; aalxb; aalxc; aalxd; aalxe; aalxf; aalxg; aalxh; aalxi; aalxj; aalxk; aalxl; aalxm; aalxn; aalxo; aalxp; aalxq; aalxr; aalxs; aalxt; aalxu; aalxv; aalxw; aalxx; aalxy; aalxz; aalya; aalyb; aalyc; aalyd; aalye; aalyf; aalyg; aalyh; aalyi; aalyj; aalyk; aalyl; aalym; aalyn; aalyo; aalyp; aalyq; aalyr; aalys; aalyt; aalyu; aalyv; aalyw; aalyx; aalyy; aalyz; aalza; aalzb; aalzc; aalzd; aalze; aalzf; aalzg; aalzh; aalzi; aalzj; aalzk; aalzl; aalzm; aalzn; aalzo; aalzp; aalzq; aalzr; aalzs; aalzt; aalzu; aalzv; aalzw; aalzx; aalzy; aalzz; aamaa; aamab; aamac; aamad; aamae; aamaf; aamag; aamah; aamai; aamaj; aamak; aamal; aamam; aaman; aamao; aamap; aamaq; aamar; aamas; aamat; aamau; aamav; aamaw; aamax; aamay; aamaz; aamba; aambb; aambc; aambd; aambe; aambf; aambg; aambh; aambi; aambj; aambk; aambl; aambm; aambn; aambo; aambp; aambq; aambr; aambs; aambt; aambu; aambv; aambw; aambx; aamby; aambz; aamca; aamcb; aamcc; aamcd; aamce; aamcf; aamcg; aamch; aamci; aamcj; aamck; aamcl; aamcm; aamcn; aamco; aamcp; aamcq; aamcr; aamcs; aamct; aamcu; aamcv; aamcw; aamcx; aamcy; aamcz; aamda; aamdb; aamdc; aamdd; aamde; aamdf; aamdg; aamdh; aamdi; aamdj; aamdk; aamdl; aamdm; aamdn; aamdo; aamdp; aamdq; aamdr; aamds; aamdt; aamdu; aamdv; aamdw; aamdx; aamdy; aamdz; aamea; aameb; aamec; aamed; aamee; aamef; aameg; aameh; aamei; aamej; aamek; aamel; aamem; aamen; aameo; aamep; aameq; aamer; aames; aamet; aameu; aamev; aamew; aamex; aamey; aamez; aamfa; aamfb; aamfc; aamfd; aamfe; aamff; aamfg; aamfh; aamfi; aamfj; aamfk; aamfl; aamfm; aamfn; aamfo; aamfp; aamfq; aamfr; aamfs; aamft; aamfu; aamfv; aamfw; aamfx; aamfy; aamfz; aamga; aamgb; aamgc; aamgd; aamge; aamgf; aamgg; aamgh; aamgi; aamgj; aamgk; aamgl; aamgm; aamgn; aamgo; aamgp; aamgq; aamgr; aamgs; aamgt; aamgu; aamgv; aamgw; aamgx; aamgy; aamgz; aamha; aamhb; aamhc; aamhd; aamhe; aamhf; aamhg; aamhh; aamhi; aamhj; aamhk; aamhl; aamhm; aamhn; aamho; aamhp; aamhq; aamhr; aamhs; aamht; aamhu; aamhv; aamhw; aamhx; aamhy; aamhz; aamia; aamib; aamic; aamid; aamie; aamif; aamig; aamih; aamii; aamij; aamik; aamil; aamim; aamin; aamio; aamip; aamiq; aamir; aamis; aamit; aamiu; aamiv; aamiw; aamix; aamiy; aamiz; aamja; aamjb; aamjc; aamjd; aamje; aamjf; aamjg; aamjh; aamji; aamjj; aamjk; aamjl; aamjm; aamjn; aamjo; aamjp; aamjq; aamjr; aamjs; aamjt; aamju; aamjv; aamjw; aamjx; aamjy; aamjz; aamka; aamkb; aamkc; aamkd; aamke; aamkf; aamkg; aamkh; aamki; aamkj; aamkk; aamkl; aamkm; aamkn; aamko; aamkp; aamkq; aamkr; aamks; aamkt; aamku; aamkv; aamkw; aamkx; aamky; aamkz; aamla; aamlb; aamlc; aamld; aamle; aamlf; aamlg; aamlh; aamli; aamlj; aamlk; aamll; aamlm; aamln; aamlo; aamlp; aamlq; aamlr; aamls; aamlt; aamlu; aamlv; aamlw; aamlx; aamly; aamlz; aamma; aammb; aammc; aammd; aamme; aammf; aammg; aammh; aammi; aammj; aammk; aamml; aammm; aammn; aammo; aammp; aammq; aammr; aamms; aammt; aammu; aammv; aammw; aammx; aammy; aammz; aamna; aamnb; aamnc; aamnd; aamne; aamnf; aamng; aamnh; aamni; aamnj; aamnk; aamnl; aamnm; aamnn; aamno; aamnp; aamnq; aamnr; aamns; aamnt; aamnu; aamnv; aamnw; aamnx; aamny; aamnz; aamoa; aamob; aamoc; aamod; aamoe; aamof; aamog; aamoh; aamoi; aamoj; aamok; aamol; aamom; aamon; aamoo; aamop; aamoq; aamor; aamos; aamot; aamou; aamov; aamow; aamox; aamoy; aamoz; aampa; aampb; aampc; aampd; aampe; aampf; aampg; aamph; aampi; aampj; aampk; aampl; aampm; aampn; aampo; aampp; aampq; aampr; aamps; aampt; aampu; aampv; aampw; aampx; aampy; aampz; aamqa; aamqb; aamqc; aamqd; aamqe; aamqf; aamqg; aamqh; aamqi; aamqj; aamqk; aamql; aamqm; aamqn; aamqo; aamqp; aamqq; aamqr; aamqs; aamqt; aamqu; aamqv; aamqw; aamqx; aamqy; aamqz; aamra; aamrb; aamrc; aamrd; aamre; aamrf; aamrg; aamrh; aamri; aamrj; aamrk; aamrl; aamrm; aamrn; aamro; aamrp; aamrq; aamrr; aamrs; aamrt; aamru; aamrv; aamrw; aamrx; aamry; aamrz; aamsa; aamsb; aamsc; aamsd; aamse; aamsf; aamsg; aamsh; aamsi; aamsj; aamsk; aamsl; aamsm; aamsn; aamso; aamsp; aamsq; aamsr; aamss; aamst; aamsu; aamsv; aamsw; aamsx; aamsy; aamsz; aamta; aamtb; aamtc; aamtd; aamte; aamtf; aamtg; aamth; aamti; aamtj; aamtk; aamtl; aamtm; aamtn; aamto; aamtp; aamtq; aamtr; aamts; aamtt; aamtu; aamtv; aamtw; aamtx; aamty; aamtz; aamua; aamub; aamuc; aamud; aamue; aamuf; aamug; aamuh; aamui; aamuj; aamuk; aamul; aamum; aamun; aamuo; aamup; aamuq; aamur; aamus; aamut; aamuu; aamuv; aamuw; aamux; aamuy; aamuz; aamva; aamvb; aamvc; aamvd; aamve; aamvf; aamvg; aamvh; aamvi; aamvj; aamvk; aamvl; aamvm; aamvn; aamvo; aamvp; aamvq; aamvr; aamvs; aamvt; aamvu; aamvv; aamvw; aamvx; aamvy; aamvz; aamwa; aamwb; aamwc; aamwd; aamwe; aamwf; aamwg; aamwh; aamwi; aamwj; aamwk; aamwl; aamwm; aamwn; aamwo; aamwp; aamwq; aamwr; aamws; aamwt; aamwu; aamwv; aamww; aamwx; aamwy; aamwz; aamxa; aamxb; aamxc; aamxd; aamxe; aamxf; aamxg; aamxh; aamxi; aamxj; aamxk; aamxl; aamxm; aamxn; aamxo; aamxp; aamxq; aamxr; aamxs; aamxt; aamxu; aamxv; aamxw; aamxx; aamxy; aamxz; aamya; aamyb; aamyc; aamyd; aamye; aamyf; aamyg; aamyh; aamyi; aamyj; aamyk; aamyl; aamym; aamyn; aamyo; aamyp; aamyq; aamyr; aamys; aamyt; aamyu; aamyv; aamyw; aamyx; aamyy; aamyz; aamza; aamzb; aamzc; aamzd; aamze; aamzf; aamzg; aamzh; aamzi; aamzj; aamzk; aamzl; aamzm; aamzn; aamzo; aamzp; aamzq; aamzr; aamzs; aamzt; aamzu; aamzv; aamzw; aamzx; aamzy; aamzz; aanaa; aanab; aanac; aanad; aanae; aanaf; aanag; aanah; aanai; aanaj; aanak; aanal; aanam; aanan; aanao; aanap; aanaq; aanar; aanas; aanat; aanau; aanav; aanaw; aanax; aanay; aanaz; aanba; aanbb; aanbc; aanbd; aanbe; aanbf; aanbg; aanbh; aanbi; aanbj; aanbk; aanbl; aanbm; aanbn; aanbo; aanbp; aanbq; aanbr; aanbs; aanbt; aanbu; aanbv; aanbw; aanbx; aanby; aanbz; aanca; aancb; aancc; aancd; aance; aancf; aancg; aanch; aanci; aancj; aanck; aancl; aancm; aancn; aanco; aancp; aancq; aancr; aancs; aanct; aancu; aancv; aancw; aancx; aancy; aancz; aanda; aandb; aandc; aandd; aande; aandf; aandg; aandh; aandi; aandj; aandk; aandl; aandm; aandn; aando; aandp; aandq; aandr; aands; aandt; aandu; aandv; aandw; aandx; aandy; aandz; aanea; aaneb; aanec; aaned; aanee; aanef; aaneg; aaneh; aanei; aanej; aanek; aanel; aanem; aanen; aaneo; aanep; aaneq; aaner; aanes; aanet; aaneu; aanev; aanew; aanex; aaney; aanez; aanfa; aanfb; aanfc; aanfd; aanfe; aanff; aanfg; aanfh; aanfi; aanfj; aanfk; aanfl; aanfm; aanfn; aanfo; aanfp; aanfq; aanfr; aanfs; aanft; aanfu; aanfv; aanfw; aanfx; aanfy; aanfz; aanga; aangb; aangc; aangd; aange; aangf; aangg; aangh; aangi; aangj; aangk; aangl; aangm; aangn; aango; aangp; aangq; aangr; aangs; aangt; aangu; aangv; aangw; aangx; aangy; aangz; aanha; aanhb; aanhc; aanhd; aanhe; aanhf; aanhg; aanhh; aanhi; aanhj; aanhk; aanhl; aanhm; aanhn; aanho; aanhp; aanhq; aanhr; aanhs; aanht; aanhu; aanhv; aanhw; aanhx; aanhy; aanhz; aania; aanib; aanic; aanid; aanie; aanif; aanig; aanih; aanii; aanij; aanik; aanil; aanim; aanin; aanio; aanip; aaniq; aanir; aanis; aanit; aaniu; aaniv; aaniw; aanix; aaniy; aaniz; aanja; aanjb; aanjc; aanjd; aanje; aanjf; aanjg; aanjh; aanji; aanjj; aanjk; aanjl; aanjm; aanjn; aanjo; aanjp; aanjq; aanjr; aanjs; aanjt; aanju; aanjv; aanjw; aanjx; aanjy; aanjz; aanka; aankb; aankc; aankd; aanke; aankf; aankg; aankh; aanki; aankj; aankk; aankl; aankm; aankn; aanko; aankp; aankq; aankr; aanks; aankt; aanku; aankv; aankw; aankx; aanky; aankz; aanla; aanlb; aanlc; aanld; aanle; aanlf; aanlg; aanlh; aanli; aanlj; aanlk; aanll; aanlm; aanln; aanlo; aanlp; aanlq; aanlr; aanls; aanlt; aanlu; aanlv; aanlw; aanlx; aanly; aanlz; aanma; aanmb; aanmc; aanmd; aanme; aanmf; aanmg; aanmh; aanmi; aanmj; aanmk; aanml; aanmm; aanmn; aanmo; aanmp; aanmq; aanmr; aanms; aanmt; aanmu; aanmv; aanmw; aanmx; aanmy; aanmz; aanna; aannb; aannc; aannd; aanne; aannf; aanng; aannh; aanni; aannj; aannk; aannl; aannm; aannn; aanno; aannp; aannq; aannr; aanns; aannt; aannu; aannv; aannw; aannx; aanny; aannz; aanoa; aanob; aanoc; aanod; aanoe; aanof; aanog; aanoh; aanoi; aanoj; aanok; aanol; aanom; aanon; aanoo; aanop; aanoq; aanor; aanos; aanot; aanou; aanov; aanow; aanox; aanoy; aanoz; aanpa; aanpb; aanpc; aanpd; aanpe; aanpf; aanpg; aanph; aanpi; aanpj; aanpk; aanpl; aanpm; aanpn; aanpo; aanpp; aanpq; aanpr; aanps; aanpt; aanpu; aanpv; aanpw; aanpx; aanpy; aanpz; aanqa; aanqb; aanqc; aanqd; aanqe; aanqf; aanqg; aanqh; aanqi; aanqj; aanqk; aanql; aanqm; aanqn; aanqo; aanqp; aanqq; aanqr; aanqs; aanqt; aanqu; aanqv; aanqw; aanqx; aanqy; aanqz; aanra; aanrb; aanrc; aanrd; aanre; aanrf; aanrg; aanrh; aanri; aanrj; aanrk; aanrl; aanrm; aanrn; aanro; aanrp; aanrq; aanrr; aanrs; aanrt; aanru; aanrv; aanrw; aanrx; aanry; aanrz; aansa; aansb; aansc; aansd; aanse; aansf; aansg; aansh; aansi; aansj; aansk; aansl; aansm; aansn; aanso; aansp; aansq; aansr; aanss; aanst; aansu; aansv; aansw; aansx; aansy; aansz; aanta; aantb; aantc; aantd; aante; aantf; aantg; aanth; aanti; aantj; aantk; aantl; aantm; aantn; aanto; aantp; aantq; aantr; aants; aantt; aantu; aantv; aantw; aantx; aanty; aantz; aanua; aanub; aanuc; aanud; aanue; aanuf; aanug; aanuh; aanui; aanuj; aanuk; aanul; aanum; aanun; aanuo; aanup; aanuq; aanur; aanus; aanut; aanuu; aanuv; aanuw; aanux; aanuy; aanuz; aanva; aanvb; aanvc; aanvd; aanve; aanvf; aanvg; aanvh; aanvi; aanvj; aanvk; aanvl; aanvm; aanvn; aanvo; aanvp; aanvq; aanvr; aanvs; aanvt; aanvu; aanvv; aanvw; aanvx; aanvy; aanvz; aanwa; aanwb; aanwc; aanwd; aanwe; aanwf; aanwg; aanwh; aanwi; aanwj; aanwk; aanwl; aanwm; aanwn; aanwo; aanwp; aanwq; aanwr; aanws; aanwt; aanwu; aanwv; aanww; aanwx; aanwy; aanwz; aanxa; aanxb; aanxc; aanxd; aanxe; aanxf; aanxg; aanxh; aanxi; aanxj; aanxk; aanxl; aanxm; aanxn; aanxo; aanxp; aanxq; aanxr; aanxs; aanxt; aanxu; aanxv; aanxw; aanxx; aanxy; aanxz; aanya; aanyb; aanyc; aanyd; aanye; aanyf; aanyg; aanyh; aanyi; aanyj; aanyk; aanyl; aanym; aanyn; aanyo; aanyp; aanyq; aanyr; aanys; aanyt; aanyu; aanyv; aanyw; aanyx; aanyy; aanyz; aanza; aanzb; aanzc; aanzd; aanze; aanzf; aanzg; aanzh; aanzi; aanzj; aanzk; aanzl; aanzm; aanzn; aanzo; aanzp; aanzq; aanzr; aanzs; aanzt; aanzu; aanzv; aanzw; aanzx; aanzy; aanzz; aaoaa; aaoab; aaoac; aaoad; aaoae; aaoaf; aaoag; aaoah; aaoai; aaoaj; aaoak; aaoal; aaoam; aaoan; aaoao; aaoap; aaoaq; aaoar; aaoas; aaoat; aaoau; aaoav; aaoaw; aaoax; aaoay; aaoaz; aaoba; aaobb; aaobc; aaobd; aaobe; aaobf; aaobg; aaobh; aaobi; aaobj; aaobk; aaobl; aaobm; aaobn; aaobo; aaobp; aaobq; aaobr; aaobs; aaobt; aaobu; aaobv; aaobw; aaobx; aaoby; aaobz; aaoca; aaocb; aaocc; aaocd; aaoce; aaocf; aaocg; aaoch; aaoci; aaocj; aaock; aaocl; aaocm; aaocn; aaoco; aaocp; aaocq; aaocr; aaocs; aaoct; aaocu; aaocv; aaocw; aaocx; aaocy; aaocz; aaoda; aaodb; aaodc; aaodd; aaode; aaodf; aaodg; aaodh; aaodi; aaodj; aaodk; aaodl; aaodm; aaodn; aaodo; aaodp; aaodq; aaodr; aaods; aaodt; aaodu; aaodv; aaodw; aaodx; aaody; aaodz; aaoea; aaoeb; aaoec; aaoed; aaoee; aaoef; aaoeg; aaoeh; aaoei; aaoej; aaoek; aaoel; aaoem; aaoen; aaoeo; aaoep; aaoeq; aaoer; aaoes; aaoet; aaoeu; aaoev; aaoew; aaoex; aaoey; aaoez; aaofa; aaofb; aaofc; aaofd; aaofe; aaoff; aaofg; aaofh; aaofi; aaofj; aaofk; aaofl; aaofm; aaofn; aaofo; aaofp; aaofq; aaofr; aaofs; aaoft; aaofu; aaofv; aaofw; aaofx; aaofy; aaofz; aaoga; aaogb; aaogc; aaogd; aaoge; aaogf; aaogg; aaogh; aaogi; aaogj; aaogk; aaogl; aaogm; aaogn; aaogo; aaogp; aaogq; aaogr; aaogs; aaogt; aaogu; aaogv; aaogw; aaogx; aaogy; aaogz; aaoha; aaohb; aaohc; aaohd; aaohe; aaohf; aaohg; aaohh; aaohi; aaohj; aaohk; aaohl; aaohm; aaohn; aaoho; aaohp; aaohq; aaohr; aaohs; aaoht; aaohu; aaohv; aaohw; aaohx; aaohy; aaohz; aaoia; aaoib; aaoic; aaoid; aaoie; aaoif; aaoig; aaoih; aaoii; aaoij; aaoik; aaoil; aaoim; aaoin; aaoio; aaoip; aaoiq; aaoir; aaois; aaoit; aaoiu; aaoiv; aaoiw; aaoix; aaoiy; aaoiz; aaoja; aaojb; aaojc; aaojd; aaoje; aaojf; aaojg; aaojh; aaoji; aaojj; aaojk; aaojl; aaojm; aaojn; aaojo; aaojp; aaojq; aaojr; aaojs; aaojt; aaoju; aaojv; aaojw; aaojx; aaojy; aaojz; aaoka; aaokb; aaokc; aaokd; aaoke; aaokf; aaokg; aaokh; aaoki; aaokj; aaokk; aaokl; aaokm; aaokn; aaoko; aaokp; aaokq; aaokr; aaoks; aaokt; aaoku; aaokv; aaokw; aaokx; aaoky; aaokz; aaola; aaolb; aaolc; aaold; aaole; aaolf; aaolg; aaolh; aaoli; aaolj; aaolk; aaoll; aaolm; aaoln; aaolo; aaolp; aaolq; aaolr; aaols; aaolt; aaolu; aaolv; aaolw; aaolx; aaoly; aaolz; aaoma; aaomb; aaomc; aaomd; aaome; aaomf; aaomg; aaomh; aaomi; aaomj; aaomk; aaoml; aaomm; aaomn; aaomo; aaomp; aaomq; aaomr; aaoms; aaomt; aaomu; aaomv; aaomw; aaomx; aaomy; aaomz; aaona; aaonb; aaonc; aaond; aaone; aaonf; aaong; aaonh; aaoni; aaonj; aaonk; aaonl; aaonm; aaonn; aaono; aaonp; aaonq; aaonr; aaons; aaont; aaonu; aaonv; aaonw; aaonx; aaony; aaonz; aaooa; aaoob; aaooc; aaood; aaooe; aaoof; aaoog; aaooh; aaooi; aaooj; aaook; aaool; aaoom; aaoon; aaooo; aaoop; aaooq; aaoor; aaoos; aaoot; aaoou; aaoov; aaoow; aaoox; aaooy; aaooz; aaopa; aaopb; aaopc; aaopd; aaope; aaopf; aaopg; aaoph; aaopi; aaopj; aaopk; aaopl; aaopm; aaopn; aaopo; aaopp; aaopq; aaopr; aaops; aaopt; aaopu; aaopv; aaopw; aaopx; aaopy; aaopz; aaoqa; aaoqb; aaoqc; aaoqd; aaoqe; aaoqf; aaoqg; aaoqh; aaoqi; aaoqj; aaoqk; aaoql; aaoqm; aaoqn; aaoqo; aaoqp; aaoqq; aaoqr; aaoqs; aaoqt; aaoqu; aaoqv; aaoqw; aaoqx; aaoqy; aaoqz; aaora; aaorb; aaorc; aaord; aaore; aaorf; aaorg; aaorh; aaori; aaorj; aaork; aaorl; aaorm; aaorn; aaoro; aaorp; aaorq; aaorr; aaors; aaort; aaoru; aaorv; aaorw; aaorx; aaory; aaorz; aaosa; aaosb; aaosc; aaosd; aaose; aaosf; aaosg; aaosh; aaosi; aaosj; aaosk; aaosl; aaosm; aaosn; aaoso; aaosp; aaosq; aaosr; aaoss; aaost; aaosu; aaosv; aaosw; aaosx; aaosy; aaosz; aaota; aaotb; aaotc; aaotd; aaote; aaotf; aaotg; aaoth; aaoti; aaotj; aaotk; aaotl; aaotm; aaotn; aaoto; aaotp; aaotq; aaotr; aaots; aaott; aaotu; aaotv; aaotw; aaotx; aaoty; aaotz; aaoua; aaoub; aaouc; aaoud; aaoue; aaouf; aaoug; aaouh; aaoui; aaouj; aaouk; aaoul; aaoum; aaoun; aaouo; aaoup; aaouq; aaour; aaous; aaout; aaouu; aaouv; aaouw; aaoux; aaouy; aaouz; aaova; aaovb; aaovc; aaovd; aaove; aaovf; aaovg; aaovh; aaovi; aaovj; aaovk; aaovl; aaovm; aaovn; aaovo; aaovp; aaovq; aaovr; aaovs; aaovt; aaovu; aaovv; aaovw; aaovx; aaovy; aaovz; aaowa; aaowb; aaowc; aaowd; aaowe; aaowf; aaowg; aaowh; aaowi; aaowj; aaowk; aaowl; aaowm; aaown; aaowo; aaowp; aaowq; aaowr; aaows; aaowt; aaowu; aaowv; aaoww; aaowx; aaowy; aaowz; aaoxa; aaoxb; aaoxc; aaoxd; aaoxe; aaoxf; aaoxg; aaoxh; aaoxi; aaoxj; aaoxk; aaoxl; aaoxm; aaoxn; aaoxo; aaoxp; aaoxq; aaoxr; aaoxs; aaoxt; aaoxu; aaoxv; aaoxw; aaoxx; aaoxy; aaoxz; aaoya; aaoyb; aaoyc; aaoyd; aaoye; aaoyf; aaoyg; aaoyh; aaoyi; aaoyj; aaoyk; aaoyl; aaoym; aaoyn; aaoyo; aaoyp; aaoyq; aaoyr; aaoys; aaoyt; aaoyu; aaoyv; aaoyw; aaoyx; aaoyy; aaoyz; aaoza; aaozb; aaozc; aaozd; aaoze; aaozf; aaozg; aaozh; aaozi; aaozj; aaozk; aaozl; aaozm; aaozn; aaozo; aaozp; aaozq; aaozr; aaozs; aaozt; aaozu; aaozv; aaozw; aaozx; aaozy; aaozz; aapaa; aapab; aapac; aapad; aapae; aapaf; aapag; aapah; aapai; aapaj; aapak; aapal; aapam; aapan; aapao; aapap; aapaq; aapar; aapas; aapat; aapau; aapav; aapaw; aapax; aapay; aapaz; aapba; aapbb; aapbc; aapbd; aapbe; aapbf; aapbg; aapbh; aapbi; aapbj; aapbk; aapbl; aapbm; aapbn; aapbo; aapbp; aapbq; aapbr; aapbs; aapbt; aapbu; aapbv; aapbw; aapbx; aapby; aapbz; aapca; aapcb; aapcc; aapcd; aapce; aapcf; aapcg; aapch; aapci; aapcj; aapck; aapcl; aapcm; aapcn; aapco; aapcp; aapcq; aapcr; aapcs; aapct; aapcu; aapcv; aapcw; aapcx; aapcy; aapcz; aapda; aapdb; aapdc; aapdd; aapde; aapdf; aapdg; aapdh; aapdi; aapdj; aapdk; aapdl; aapdm; aapdn; aapdo; aapdp; aapdq; aapdr; aapds; aapdt; aapdu; aapdv; aapdw; aapdx; aapdy; aapdz; aapea; aapeb; aapec; aaped; aapee; aapef; aapeg; aapeh; aapei; aapej; aapek; aapel; aapem; aapen; aapeo; aapep; aapeq; aaper; aapes; aapet; aapeu; aapev; aapew; aapex; aapey; aapez; aapfa; aapfb; aapfc; aapfd; aapfe; aapff; aapfg; aapfh; aapfi; aapfj; aapfk; aapfl; aapfm; aapfn; aapfo; aapfp; aapfq; aapfr; aapfs; aapft; aapfu; aapfv; aapfw; aapfx; aapfy; aapfz; aapga; aapgb; aapgc; aapgd; aapge; aapgf; aapgg; aapgh; aapgi; aapgj; aapgk; aapgl; aapgm; aapgn; aapgo; aapgp; aapgq; aapgr; aapgs; aapgt; aapgu; aapgv; aapgw; aapgx; aapgy; aapgz; aapha; aaphb; aaphc; aaphd; aaphe; aaphf; aaphg; aaphh; aaphi; aaphj; aaphk; aaphl; aaphm; aaphn; aapho; aaphp; aaphq; aaphr; aaphs; aapht; aaphu; aaphv; aaphw; aaphx; aaphy; aaphz; aapia; aapib; aapic; aapid; aapie; aapif; aapig; aapih; aapii; aapij; aapik; aapil; aapim; aapin; aapio; aapip; aapiq; aapir; aapis; aapit; aapiu; aapiv; aapiw; aapix; aapiy; aapiz; aapja; aapjb; aapjc; aapjd; aapje; aapjf; aapjg; aapjh; aapji; aapjj; aapjk; aapjl; aapjm; aapjn; aapjo; aapjp; aapjq; aapjr; aapjs; aapjt; aapju; aapjv; aapjw; aapjx; aapjy; aapjz; aapka; aapkb; aapkc; aapkd; aapke; aapkf; aapkg; aapkh; aapki; aapkj; aapkk; aapkl; aapkm; aapkn; aapko; aapkp; aapkq; aapkr; aapks; aapkt; aapku; aapkv; aapkw; aapkx; aapky; aapkz; aapla; aaplb; aaplc; aapld; aaple; aaplf; aaplg; aaplh; aapli; aaplj; aaplk; aapll; aaplm; aapln; aaplo; aaplp; aaplq; aaplr; aapls; aaplt; aaplu; aaplv; aaplw; aaplx; aaply; aaplz; aapma; aapmb; aapmc; aapmd; aapme; aapmf; aapmg; aapmh; aapmi; aapmj; aapmk; aapml; aapmm; aapmn; aapmo; aapmp; aapmq; aapmr; aapms; aapmt; aapmu; aapmv; aapmw; aapmx; aapmy; aapmz; aapna; aapnb; aapnc; aapnd; aapne; aapnf; aapng; aapnh; aapni; aapnj; aapnk; aapnl; aapnm; aapnn; aapno; aapnp; aapnq; aapnr; aapns; aapnt; aapnu; aapnv; aapnw; aapnx; aapny; aapnz; aapoa; aapob; aapoc; aapod; aapoe; aapof; aapog; aapoh; aapoi; aapoj; aapok; aapol; aapom; aapon; aapoo; aapop; aapoq; aapor; aapos; aapot; aapou; aapov; aapow; aapox; aapoy; aapoz; aappa; aappb; aappc; aappd; aappe; aappf; aappg; aapph; aappi; aappj; aappk; aappl; aappm; aappn; aappo; aappp; aappq; aappr; aapps; aappt; aappu; aappv; aappw; aappx; aappy; aappz; aapqa; aapqb; aapqc; aapqd; aapqe; aapqf; aapqg; aapqh; aapqi; aapqj; aapqk; aapql; aapqm; aapqn; aapqo; aapqp; aapqq; aapqr; aapqs; aapqt; aapqu; aapqv; aapqw; aapqx; aapqy; aapqz; aapra; aaprb; aaprc; aaprd; aapre; aaprf; aaprg; aaprh; aapri; aaprj; aaprk; aaprl; aaprm; aaprn; aapro; aaprp; aaprq; aaprr; aaprs; aaprt; aapru; aaprv; aaprw; aaprx; aapry; aaprz; aapsa; aapsb; aapsc; aapsd; aapse; aapsf; aapsg; aapsh; aapsi; aapsj; aapsk; aapsl; aapsm; aapsn; aapso; aapsp; aapsq; aapsr; aapss; aapst; aapsu; aapsv; aapsw; aapsx; aapsy; aapsz; aapta; aaptb; aaptc; aaptd; aapte; aaptf; aaptg; aapth; aapti; aaptj; aaptk; aaptl; aaptm; aaptn; aapto; aaptp; aaptq; aaptr; aapts; aaptt; aaptu; aaptv; aaptw; aaptx; aapty; aaptz; aapua; aapub; aapuc; aapud; aapue; aapuf; aapug; aapuh; aapui; aapuj; aapuk; aapul; aapum; aapun; aapuo; aapup; aapuq; aapur; aapus; aaput; aapuu; aapuv; aapuw; aapux; aapuy; aapuz; aapva; aapvb; aapvc; aapvd; aapve; aapvf; aapvg; aapvh; aapvi; aapvj; aapvk; aapvl; aapvm; aapvn; aapvo; aapvp; aapvq; aapvr; aapvs; aapvt; aapvu; aapvv; aapvw; aapvx; aapvy; aapvz; aapwa; aapwb; aapwc; aapwd; aapwe; aapwf; aapwg; aapwh; aapwi; aapwj; aapwk; aapwl; aapwm; aapwn; aapwo; aapwp; aapwq; aapwr; aapws; aapwt; aapwu; aapwv; aapww; aapwx; aapwy; aapwz; aapxa; aapxb; aapxc; aapxd; aapxe; aapxf; aapxg; aapxh; aapxi; aapxj; aapxk; aapxl; aapxm; aapxn; aapxo; aapxp; aapxq; aapxr; aapxs; aapxt; aapxu; aapxv; aapxw; aapxx; aapxy; aapxz; aapya; aapyb; aapyc; aapyd; aapye; aapyf; aapyg; aapyh; aapyi; aapyj; aapyk; aapyl; aapym; aapyn; aapyo; aapyp; aapyq; aapyr; aapys; aapyt; aapyu; aapyv; aapyw; aapyx; aapyy; aapyz; aapza; aapzb; aapzc; aapzd; aapze; aapzf; aapzg; aapzh; aapzi; aapzj; aapzk; aapzl; aapzm; aapzn; aapzo; aapzp; aapzq; aapzr; aapzs; aapzt; aapzu; aapzv; aapzw; aapzx; aapzy; aapzz; aaqaa; aaqab; aaqac; aaqad; aaqae; aaqaf; aaqag; aaqah; aaqai; aaqaj; aaqak; aaqal; aaqam; aaqan; aaqao; aaqap; aaqaq; aaqar; aaqas; aaqat; aaqau; aaqav; aaqaw; aaqax; aaqay; aaqaz; aaqba; aaqbb; aaqbc; aaqbd; aaqbe; aaqbf; aaqbg; aaqbh; aaqbi; aaqbj; aaqbk; aaqbl; aaqbm; aaqbn; aaqbo; aaqbp; aaqbq; aaqbr; aaqbs; aaqbt; aaqbu; aaqbv; aaqbw; aaqbx; aaqby; aaqbz; aaqca; aaqcb; aaqcc; aaqcd; aaqce; aaqcf; aaqcg; aaqch; aaqci; aaqcj; aaqck; aaqcl; aaqcm; aaqcn; aaqco; aaqcp; aaqcq; aaqcr; aaqcs; aaqct; aaqcu; aaqcv; aaqcw; aaqcx; aaqcy; aaqcz; aaqda; aaqdb; aaqdc; aaqdd; aaqde; aaqdf; aaqdg; aaqdh; aaqdi; aaqdj; aaqdk; aaqdl; aaqdm; aaqdn; aaqdo; aaqdp; aaqdq; aaqdr; aaqds; aaqdt; aaqdu; aaqdv; aaqdw; aaqdx; aaqdy; aaqdz; aaqea; aaqeb; aaqec; aaqed; aaqee; aaqef; aaqeg; aaqeh; aaqei; aaqej; aaqek; aaqel; aaqem; aaqen; aaqeo; aaqep; aaqeq; aaqer; aaqes; aaqet; aaqeu; aaqev; aaqew; aaqex; aaqey; aaqez; aaqfa; aaqfb; aaqfc; aaqfd; aaqfe; aaqff; aaqfg; aaqfh; aaqfi; aaqfj; aaqfk; aaqfl; aaqfm; aaqfn; aaqfo; aaqfp; aaqfq; aaqfr; aaqfs; aaqft; aaqfu; aaqfv; aaqfw; aaqfx; aaqfy; aaqfz; aaqga; aaqgb; aaqgc; aaqgd; aaqge; aaqgf; aaqgg; aaqgh; aaqgi; aaqgj; aaqgk; aaqgl; aaqgm; aaqgn; aaqgo; aaqgp; aaqgq; aaqgr; aaqgs; aaqgt; aaqgu; aaqgv; aaqgw; aaqgx; aaqgy; aaqgz; aaqha; aaqhb; aaqhc; aaqhd; aaqhe; aaqhf; aaqhg; aaqhh; aaqhi; aaqhj; aaqhk; aaqhl; aaqhm; aaqhn; aaqho; aaqhp; aaqhq; aaqhr; aaqhs; aaqht; aaqhu; aaqhv; aaqhw; aaqhx; aaqhy; aaqhz; aaqia; aaqib; aaqic; aaqid; aaqie; aaqif; aaqig; aaqih; aaqii; aaqij; aaqik; aaqil; aaqim; aaqin; aaqio; aaqip; aaqiq; aaqir; aaqis; aaqit; aaqiu; aaqiv; aaqiw; aaqix; aaqiy; aaqiz; aaqja; aaqjb; aaqjc; aaqjd; aaqje; aaqjf; aaqjg; aaqjh; aaqji; aaqjj; aaqjk; aaqjl; aaqjm; aaqjn; aaqjo; aaqjp; aaqjq; aaqjr; aaqjs; aaqjt; aaqju; aaqjv; aaqjw; aaqjx; aaqjy; aaqjz; aaqka; aaqkb; aaqkc; aaqkd; aaqke; aaqkf; aaqkg; aaqkh; aaqki; aaqkj; aaqkk; aaqkl; aaqkm; aaqkn; aaqko; aaqkp; aaqkq; aaqkr; aaqks; aaqkt; aaqku; aaqkv; aaqkw; aaqkx; aaqky; aaqkz; aaqla; aaqlb; aaqlc; aaqld; aaqle; aaqlf; aaqlg; aaqlh; aaqli; aaqlj; aaqlk; aaqll; aaqlm; aaqln; aaqlo; aaqlp; aaqlq; aaqlr; aaqls; aaqlt; aaqlu; aaqlv; aaqlw; aaqlx; aaqly; aaqlz; aaqma; aaqmb; aaqmc; aaqmd; aaqme; aaqmf; aaqmg; aaqmh; aaqmi; aaqmj; aaqmk; aaqml; aaqmm; aaqmn; aaqmo; aaqmp; aaqmq; aaqmr; aaqms; aaqmt; aaqmu; aaqmv; aaqmw; aaqmx; aaqmy; aaqmz; aaqna; aaqnb; aaqnc; aaqnd; aaqne; aaqnf; aaqng; aaqnh; aaqni; aaqnj; aaqnk; aaqnl; aaqnm; aaqnn; aaqno; aaqnp; aaqnq; aaqnr; aaqns; aaqnt; aaqnu; aaqnv; aaqnw; aaqnx; aaqny; aaqnz; aaqoa; aaqob; aaqoc; aaqod; aaqoe; aaqof; aaqog; aaqoh; aaqoi; aaqoj; aaqok; aaqol; aaqom; aaqon; aaqoo; aaqop; aaqoq; aaqor; aaqos; aaqot; aaqou; aaqov; aaqow; aaqox; aaqoy; aaqoz; aaqpa; aaqpb; aaqpc; aaqpd; aaqpe; aaqpf; aaqpg; aaqph; aaqpi; aaqpj; aaqpk; aaqpl; aaqpm; aaqpn; aaqpo; aaqpp; aaqpq; aaqpr; aaqps; aaqpt; aaqpu; aaqpv; aaqpw; aaqpx; aaqpy; aaqpz; aaqqa; aaqqb; aaqqc; aaqqd; aaqqe; aaqqf; aaqqg; aaqqh; aaqqi; aaqqj; aaqqk; aaqql; aaqqm; aaqqn; aaqqo; aaqqp; aaqqq; aaqqr; aaqqs; aaqqt; aaqqu; aaqqv; aaqqw; aaqqx; aaqqy; aaqqz; aaqra; aaqrb; aaqrc; aaqrd; aaqre; aaqrf; aaqrg; aaqrh; aaqri; aaqrj; aaqrk; aaqrl; aaqrm; aaqrn; aaqro; aaqrp; aaqrq; aaqrr; aaqrs; aaqrt; aaqru; aaqrv; aaqrw; aaqrx; aaqry; aaqrz; aaqsa; aaqsb; aaqsc; aaqsd; aaqse; aaqsf; aaqsg; aaqsh; aaqsi; aaqsj; aaqsk; aaqsl; aaqsm; aaqsn; aaqso; aaqsp; aaqsq; aaqsr; aaqss; aaqst; aaqsu; aaqsv; aaqsw; aaqsx; aaqsy; aaqsz; aaqta; aaqtb; aaqtc; aaqtd; aaqte; aaqtf; aaqtg; aaqth; aaqti; aaqtj; aaqtk; aaqtl; aaqtm; aaqtn; aaqto; aaqtp; aaqtq; aaqtr; aaqts; aaqtt; aaqtu; aaqtv; aaqtw; aaqtx; aaqty; aaqtz; aaqua; aaqub; aaquc; aaqud; aaque; aaquf; aaqug; aaquh; aaqui; aaquj; aaquk; aaqul; aaqum; aaqun; aaquo; aaqup; aaquq; aaqur; aaqus; aaqut; aaquu; aaquv; aaquw; aaqux; aaquy; aaquz; aaqva; aaqvb; aaqvc; aaqvd; aaqve; aaqvf; aaqvg; aaqvh; aaqvi; aaqvj; aaqvk; aaqvl; aaqvm; aaqvn; aaqvo; aaqvp; aaqvq; aaqvr; aaqvs; aaqvt; aaqvu; aaqvv; aaqvw; aaqvx; aaqvy; aaqvz; aaqwa; aaqwb; aaqwc; aaqwd; aaqwe; aaqwf; aaqwg; aaqwh; aaqwi; aaqwj; aaqwk; aaqwl; aaqwm; aaqwn; aaqwo; aaqwp; aaqwq; aaqwr; aaqws; aaqwt; aaqwu; aaqwv; aaqww; aaqwx; aaqwy; aaqwz; aaqxa; aaqxb; aaqxc; aaqxd; aaqxe; aaqxf; aaqxg; aaqxh; aaqxi; aaqxj; aaqxk; aaqxl; aaqxm; aaqxn; aaqxo; aaqxp; aaqxq; aaqxr; aaqxs; aaqxt; aaqxu; aaqxv; aaqxw; aaqxx; aaqxy; aaqxz; aaqya; aaqyb; aaqyc; aaqyd; aaqye; aaqyf; aaqyg; aaqyh; aaqyi; aaqyj; aaqyk; aaqyl; aaqym; aaqyn; aaqyo; aaqyp; aaqyq; aaqyr; aaqys; aaqyt; aaqyu; aaqyv; aaqyw; aaqyx; aaqyy; aaqyz; aaqza; aaqzb; aaqzc; aaqzd; aaqze; aaqzf; aaqzg; aaqzh; aaqzi; aaqzj; aaqzk; aaqzl; aaqzm; aaqzn; aaqzo; aaqzp; aaqzq; aaqzr; aaqzs; aaqzt; aaqzu; aaqzv; aaqzw; aaqzx; aaqzy; aaqzz; aaraa; aarab; aarac; aarad; aarae; aaraf; aarag; aarah; aarai; aaraj; aarak; aaral; aaram; aaran; aarao; aarap; aaraq; aarar; aaras; aarat; aarau; aarav; aaraw; aarax; aaray; aaraz; aarba; aarbb; aarbc; aarbd; aarbe; aarbf; aarbg; aarbh; aarbi; aarbj; aarbk; aarbl; aarbm; aarbn; aarbo; aarbp; aarbq; aarbr; aarbs; aarbt; aarbu; aarbv; aarbw; aarbx; aarby; aarbz; aarca; aarcb; aarcc; aarcd; aarce; aarcf; aarcg; aarch; aarci; aarcj; aarck; aarcl; aarcm; aarcn; aarco; aarcp; aarcq; aarcr; aarcs; aarct; aarcu; aarcv; aarcw; aarcx; aarcy; aarcz; aarda; aardb; aardc; aardd; aarde; aardf; aardg; aardh; aardi; aardj; aardk; aardl; aardm; aardn; aardo; aardp; aardq; aardr; aards; aardt; aardu; aardv; aardw; aardx; aardy; aardz; aarea; aareb; aarec; aared; aaree; aaref; aareg; aareh; aarei; aarej; aarek; aarel; aarem; aaren; aareo; aarep; aareq; aarer; aares; aaret; aareu; aarev; aarew; aarex; aarey; aarez; aarfa; aarfb; aarfc; aarfd; aarfe; aarff; aarfg; aarfh; aarfi; aarfj; aarfk; aarfl; aarfm; aarfn; aarfo; aarfp; aarfq; aarfr; aarfs; aarft; aarfu; aarfv; aarfw; aarfx; aarfy; aarfz; aarga; aargb; aargc; aargd; aarge; aargf; aargg; aargh; aargi; aargj; aargk; aargl; aargm; aargn; aargo; aargp; aargq; aargr; aargs; aargt; aargu; aargv; aargw; aargx; aargy; aargz; aarha; aarhb; aarhc; aarhd; aarhe; aarhf; aarhg; aarhh; aarhi; aarhj; aarhk; aarhl; aarhm; aarhn; aarho; aarhp; aarhq; aarhr; aarhs; aarht; aarhu; aarhv; aarhw; aarhx; aarhy; aarhz; aaria; aarib; aaric; aarid; aarie; aarif; aarig; aarih; aarii; aarij; aarik; aaril; aarim; aarin; aario; aarip; aariq; aarir; aaris; aarit; aariu; aariv; aariw; aarix; aariy; aariz; aarja; aarjb; aarjc; aarjd; aarje; aarjf; aarjg; aarjh; aarji; aarjj; aarjk; aarjl; aarjm; aarjn; aarjo; aarjp; aarjq; aarjr; aarjs; aarjt; aarju; aarjv; aarjw; aarjx; aarjy; aarjz; aarka; aarkb; aarkc; aarkd; aarke; aarkf; aarkg; aarkh; aarki; aarkj; aarkk; aarkl; aarkm; aarkn; aarko; aarkp; aarkq; aarkr; aarks; aarkt; aarku; aarkv; aarkw; aarkx; aarky; aarkz; aarla; aarlb; aarlc; aarld; aarle; aarlf; aarlg; aarlh; aarli; aarlj; aarlk; aarll; aarlm; aarln; aarlo; aarlp; aarlq; aarlr; aarls; aarlt; aarlu; aarlv; aarlw; aarlx; aarly; aarlz; aarma; aarmb; aarmc; aarmd; aarme; aarmf; aarmg; aarmh; aarmi; aarmj; aarmk; aarml; aarmm; aarmn; aarmo; aarmp; aarmq; aarmr; aarms; aarmt; aarmu; aarmv; aarmw; aarmx; aarmy; aarmz; aarna; aarnb; aarnc; aarnd; aarne; aarnf; aarng; aarnh; aarni; aarnj; aarnk; aarnl; aarnm; aarnn; aarno; aarnp; aarnq; aarnr; aarns; aarnt; aarnu; aarnv; aarnw; aarnx; aarny; aarnz; aaroa; aarob; aaroc; aarod; aaroe; aarof; aarog; aaroh; aaroi; aaroj; aarok; aarol; aarom; aaron; aaroo; aarop; aaroq; aaror; aaros; aarot; aarou; aarov; aarow; aarox; aaroy; aaroz; aarpa; aarpb; aarpc; aarpd; aarpe; aarpf; aarpg; aarph; aarpi; aarpj; aarpk; aarpl; aarpm; aarpn; aarpo; aarpp; aarpq; aarpr; aarps; aarpt; aarpu; aarpv; aarpw; aarpx; aarpy; aarpz; aarqa; aarqb; aarqc; aarqd; aarqe; aarqf; aarqg; aarqh; aarqi; aarqj; aarqk; aarql; aarqm; aarqn; aarqo; aarqp; aarqq; aarqr; aarqs; aarqt; aarqu; aarqv; aarqw; aarqx; aarqy; aarqz; aarra; aarrb; aarrc; aarrd; aarre; aarrf; aarrg; aarrh; aarri; aarrj; aarrk; aarrl; aarrm; aarrn; aarro; aarrp; aarrq; aarrr; aarrs; aarrt; aarru; aarrv; aarrw; aarrx; aarry; aarrz; aarsa; aarsb; aarsc; aarsd; aarse; aarsf; aarsg; aarsh; aarsi; aarsj; aarsk; aarsl; aarsm; aarsn; aarso; aarsp; aarsq; aarsr; aarss; aarst; aarsu; aarsv; aarsw; aarsx; aarsy; aarsz; aarta; aartb; aartc; aartd; aarte; aartf; aartg; aarth; aarti; aartj; aartk; aartl; aartm; aartn; aarto; aartp; aartq; aartr; aarts; aartt; aartu; aartv; aartw; aartx; aarty; aartz; aarua; aarub; aaruc; aarud; aarue; aaruf; aarug; aaruh; aarui; aaruj; aaruk; aarul; aarum; aarun; aaruo; aarup; aaruq; aarur; aarus; aarut; aaruu; aaruv; aaruw; aarux; aaruy; aaruz; aarva; aarvb; aarvc; aarvd; aarve; aarvf; aarvg; aarvh; aarvi; aarvj; aarvk; aarvl; aarvm; aarvn; aarvo; aarvp; aarvq; aarvr; aarvs; aarvt; aarvu; aarvv; aarvw; aarvx; aarvy; aarvz; aarwa; aarwb; aarwc; aarwd; aarwe; aarwf; aarwg; aarwh; aarwi; aarwj; aarwk; aarwl; aarwm; aarwn; aarwo; aarwp; aarwq; aarwr; aarws; aarwt; aarwu; aarwv; aarww; aarwx; aarwy; aarwz; aarxa; aarxb; aarxc; aarxd; aarxe; aarxf; aarxg; aarxh; aarxi; aarxj; aarxk; aarxl; aarxm; aarxn; aarxo; aarxp; aarxq; aarxr; aarxs; aarxt; aarxu; aarxv; aarxw; aarxx; aarxy; aarxz; aarya; aaryb; aaryc; aaryd; aarye; aaryf; aaryg; aaryh; aaryi; aaryj; aaryk; aaryl; aarym; aaryn; aaryo; aaryp; aaryq; aaryr; aarys; aaryt; aaryu; aaryv; aaryw; aaryx; aaryy; aaryz; aarza; aarzb; aarzc; aarzd; aarze; aarzf; aarzg; aarzh; aarzi; aarzj; aarzk; aarzl; aarzm; aarzn; aarzo; aarzp; aarzq; aarzr; aarzs; aarzt; aarzu; aarzv; aarzw; aarzx; aarzy; aarzz; aasaa; aasab; aasac; aasad; aasae; aasaf; aasag; aasah; aasai; aasaj; aasak; aasal; aasam; aasan; aasao; aasap; aasaq; aasar; aasas; aasat; aasau; aasav; aasaw; aasax; aasay; aasaz; aasba; aasbb; aasbc; aasbd; aasbe; aasbf; aasbg; aasbh; aasbi; aasbj; aasbk; aasbl; aasbm; aasbn; aasbo; aasbp; aasbq; aasbr; aasbs; aasbt; aasbu; aasbv; aasbw; aasbx; aasby; aasbz; aasca; aascb; aascc; aascd; aasce; aascf; aascg; aasch; aasci; aascj; aasck; aascl; aascm; aascn; aasco; aascp; aascq; aascr; aascs; aasct; aascu; aascv; aascw; aascx; aascy; aascz; aasda; aasdb; aasdc; aasdd; aasde; aasdf; aasdg; aasdh; aasdi; aasdj; aasdk; aasdl; aasdm; aasdn; aasdo; aasdp; aasdq; aasdr; aasds; aasdt; aasdu; aasdv; aasdw; aasdx; aasdy; aasdz; aasea; aaseb; aasec; aased; aasee; aasef; aaseg; aaseh; aasei; aasej; aasek; aasel; aasem; aasen; aaseo; aasep; aaseq; aaser; aases; aaset; aaseu; aasev; aasew; aasex; aasey; aasez; aasfa; aasfb; aasfc; aasfd; aasfe; aasff; aasfg; aasfh; aasfi; aasfj; aasfk; aasfl; aasfm; aasfn; aasfo; aasfp; aasfq; aasfr; aasfs; aasft; aasfu; aasfv; aasfw; aasfx; aasfy; aasfz; aasga; aasgb; aasgc; aasgd; aasge; aasgf; aasgg; aasgh; aasgi; aasgj; aasgk; aasgl; aasgm; aasgn; aasgo; aasgp; aasgq; aasgr; aasgs; aasgt; aasgu; aasgv; aasgw; aasgx; aasgy; aasgz; aasha; aashb; aashc; aashd; aashe; aashf; aashg; aashh; aashi; aashj; aashk; aashl; aashm; aashn; aasho; aashp; aashq; aashr; aashs; aasht; aashu; aashv; aashw; aashx; aashy; aashz; aasia; aasib; aasic; aasid; aasie; aasif; aasig; aasih; aasii; aasij; aasik; aasil; aasim; aasin; aasio; aasip; aasiq; aasir; aasis; aasit; aasiu; aasiv; aasiw; aasix; aasiy; aasiz; aasja; aasjb; aasjc; aasjd; aasje; aasjf; aasjg; aasjh; aasji; aasjj; aasjk; aasjl; aasjm; aasjn; aasjo; aasjp; aasjq; aasjr; aasjs; aasjt; aasju; aasjv; aasjw; aasjx; aasjy; aasjz; aaska; aaskb; aaskc; aaskd; aaske; aaskf; aaskg; aaskh; aaski; aaskj; aaskk; aaskl; aaskm; aaskn; aasko; aaskp; aaskq; aaskr; aasks; aaskt; aasku; aaskv; aaskw; aaskx; aasky; aaskz; aasla; aaslb; aaslc; aasld; aasle; aaslf; aaslg; aaslh; aasli; aaslj; aaslk; aasll; aaslm; aasln; aaslo; aaslp; aaslq; aaslr; aasls; aaslt; aaslu; aaslv; aaslw; aaslx; aasly; aaslz; aasma; aasmb; aasmc; aasmd; aasme; aasmf; aasmg; aasmh; aasmi; aasmj; aasmk; aasml; aasmm; aasmn; aasmo; aasmp; aasmq; aasmr; aasms; aasmt; aasmu; aasmv; aasmw; aasmx; aasmy; aasmz; aasna; aasnb; aasnc; aasnd; aasne; aasnf; aasng; aasnh; aasni; aasnj; aasnk; aasnl; aasnm; aasnn; aasno; aasnp; aasnq; aasnr; aasns; aasnt; aasnu; aasnv; aasnw; aasnx; aasny; aasnz; aasoa; aasob; aasoc; aasod; aasoe; aasof; aasog; aasoh; aasoi; aasoj; aasok; aasol; aasom; aason; aasoo; aasop; aasoq; aasor; aasos; aasot; aasou; aasov; aasow; aasox; aasoy; aasoz; aaspa; aaspb; aaspc; aaspd; aaspe; aaspf; aaspg; aasph; aaspi; aaspj; aaspk; aaspl; aaspm; aaspn; aaspo; aaspp; aaspq; aaspr; aasps; aaspt; aaspu; aaspv; aaspw; aaspx; aaspy; aaspz; aasqa; aasqb; aasqc; aasqd; aasqe; aasqf; aasqg; aasqh; aasqi; aasqj; aasqk; aasql; aasqm; aasqn; aasqo; aasqp; aasqq; aasqr; aasqs; aasqt; aasqu; aasqv; aasqw; aasqx; aasqy; aasqz; aasra; aasrb; aasrc; aasrd; aasre; aasrf; aasrg; aasrh; aasri; aasrj; aasrk; aasrl; aasrm; aasrn; aasro; aasrp; aasrq; aasrr; aasrs; aasrt; aasru; aasrv; aasrw; aasrx; aasry; aasrz; aassa; aassb; aassc; aassd; aasse; aassf; aassg; aassh; aassi; aassj; aassk; aassl; aassm; aassn; aasso; aassp; aassq; aassr; aasss; aasst; aassu; aassv; aassw; aassx; aassy; aassz; aasta; aastb; aastc; aastd; aaste; aastf; aastg; aasth; aasti; aastj; aastk; aastl; aastm; aastn; aasto; aastp; aastq; aastr; aasts; aastt; aastu; aastv; aastw; aastx; aasty; aastz; aasua; aasub; aasuc; aasud; aasue; aasuf; aasug; aasuh; aasui; aasuj; aasuk; aasul; aasum; aasun; aasuo; aasup; aasuq; aasur; aasus; aasut; aasuu; aasuv; aasuw; aasux; aasuy; aasuz; aasva; aasvb; aasvc; aasvd; aasve; aasvf; aasvg; aasvh; aasvi; aasvj; aasvk; aasvl; aasvm; aasvn; aasvo; aasvp; aasvq; aasvr; aasvs; aasvt; aasvu; aasvv; aasvw; aasvx; aasvy; aasvz; aaswa; aaswb; aaswc; aaswd; aaswe; aaswf; aaswg; aaswh; aaswi; aaswj; aaswk; aaswl; aaswm; aaswn; aaswo; aaswp; aaswq; aaswr; aasws; aaswt; aaswu; aaswv; aasww; aaswx; aaswy; aaswz; aasxa; aasxb; aasxc; aasxd; aasxe; aasxf; aasxg; aasxh; aasxi; aasxj; aasxk; aasxl; aasxm; aasxn; aasxo; aasxp; aasxq; aasxr; aasxs; aasxt; aasxu; aasxv; aasxw; aasxx; aasxy; aasxz; aasya; aasyb; aasyc; aasyd; aasye; aasyf; aasyg; aasyh; aasyi; aasyj; aasyk; aasyl; aasym; aasyn; aasyo; aasyp; aasyq; aasyr; aasys; aasyt; aasyu; aasyv; aasyw; aasyx; aasyy; aasyz; aasza; aaszb; aaszc; aaszd; aasze; aaszf; aaszg; aaszh; aaszi; aaszj; aaszk; aaszl; aaszm; aaszn; aaszo; aaszp; aaszq; aaszr; aaszs; aaszt; aaszu; aaszv; aaszw; aaszx; aaszy; aaszz; aataa; aatab; aatac; aatad; aatae; aataf; aatag; aatah; aatai; aataj; aatak; aatal; aatam; aatan; aatao; aatap; aataq; aatar; aatas; aatat; aatau; aatav; aataw; aatax; aatay; aataz; aatba; aatbb; aatbc; aatbd; aatbe; aatbf; aatbg; aatbh; aatbi; aatbj; aatbk; aatbl; aatbm; aatbn; aatbo; aatbp; aatbq; aatbr; aatbs; aatbt; aatbu; aatbv; aatbw; aatbx; aatby; aatbz; aatca; aatcb; aatcc; aatcd; aatce; aatcf; aatcg; aatch; aatci; aatcj; aatck; aatcl; aatcm; aatcn; aatco; aatcp; aatcq; aatcr; aatcs; aatct; aatcu; aatcv; aatcw; aatcx; aatcy; aatcz; aatda; aatdb; aatdc; aatdd; aatde; aatdf; aatdg; aatdh; aatdi; aatdj; aatdk; aatdl; aatdm; aatdn; aatdo; aatdp; aatdq; aatdr; aatds; aatdt; aatdu; aatdv; aatdw; aatdx; aatdy; aatdz; aatea; aateb; aatec; aated; aatee; aatef; aateg; aateh; aatei; aatej; aatek; aatel; aatem; aaten; aateo; aatep; aateq; aater; aates; aatet; aateu; aatev; aatew; aatex; aatey; aatez; aatfa; aatfb; aatfc; aatfd; aatfe; aatff; aatfg; aatfh; aatfi; aatfj; aatfk; aatfl; aatfm; aatfn; aatfo; aatfp; aatfq; aatfr; aatfs; aatft; aatfu; aatfv; aatfw; aatfx; aatfy; aatfz; aatga; aatgb; aatgc; aatgd; aatge; aatgf; aatgg; aatgh; aatgi; aatgj; aatgk; aatgl; aatgm; aatgn; aatgo; aatgp; aatgq; aatgr; aatgs; aatgt; aatgu; aatgv; aatgw; aatgx; aatgy; aatgz; aatha; aathb; aathc; aathd; aathe; aathf; aathg; aathh; aathi; aathj; aathk; aathl; aathm; aathn; aatho; aathp; aathq; aathr; aaths; aatht; aathu; aathv; aathw; aathx; aathy; aathz; aatia; aatib; aatic; aatid; aatie; aatif; aatig; aatih; aatii; aatij; aatik; aatil; aatim; aatin; aatio; aatip; aatiq; aatir; aatis; aatit; aatiu; aativ; aatiw; aatix; aatiy; aatiz; aatja; aatjb; aatjc; aatjd; aatje; aatjf; aatjg; aatjh; aatji; aatjj; aatjk; aatjl; aatjm; aatjn; aatjo; aatjp; aatjq; aatjr; aatjs; aatjt; aatju; aatjv; aatjw; aatjx; aatjy; aatjz; aatka; aatkb; aatkc; aatkd; aatke; aatkf; aatkg; aatkh; aatki; aatkj; aatkk; aatkl; aatkm; aatkn; aatko; aatkp; aatkq; aatkr; aatks; aatkt; aatku; aatkv; aatkw; aatkx; aatky; aatkz; aatla; aatlb; aatlc; aatld; aatle; aatlf; aatlg; aatlh; aatli; aatlj; aatlk; aatll; aatlm; aatln; aatlo; aatlp; aatlq; aatlr; aatls; aatlt; aatlu; aatlv; aatlw; aatlx; aatly; aatlz; aatma; aatmb; aatmc; aatmd; aatme; aatmf; aatmg; aatmh; aatmi; aatmj; aatmk; aatml; aatmm; aatmn; aatmo; aatmp; aatmq; aatmr; aatms; aatmt; aatmu; aatmv; aatmw; aatmx; aatmy; aatmz; aatna; aatnb; aatnc; aatnd; aatne; aatnf; aatng; aatnh; aatni; aatnj; aatnk; aatnl; aatnm; aatnn; aatno; aatnp; aatnq; aatnr; aatns; aatnt; aatnu; aatnv; aatnw; aatnx; aatny; aatnz; aatoa; aatob; aatoc; aatod; aatoe; aatof; aatog; aatoh; aatoi; aatoj; aatok; aatol; aatom; aaton; aatoo; aatop; aatoq; aator; aatos; aatot; aatou; aatov; aatow; aatox; aatoy; aatoz; aatpa; aatpb; aatpc; aatpd; aatpe; aatpf; aatpg; aatph; aatpi; aatpj; aatpk; aatpl; aatpm; aatpn; aatpo; aatpp; aatpq; aatpr; aatps; aatpt; aatpu; aatpv; aatpw; aatpx; aatpy; aatpz; aatqa; aatqb; aatqc; aatqd; aatqe; aatqf; aatqg; aatqh; aatqi; aatqj; aatqk; aatql; aatqm; aatqn; aatqo; aatqp; aatqq; aatqr; aatqs; aatqt; aatqu; aatqv; aatqw; aatqx; aatqy; aatqz; aatra; aatrb; aatrc; aatrd; aatre; aatrf; aatrg; aatrh; aatri; aatrj; aatrk; aatrl; aatrm; aatrn; aatro; aatrp; aatrq; aatrr; aatrs; aatrt; aatru; aatrv; aatrw; aatrx; aatry; aatrz; aatsa; aatsb; aatsc; aatsd; aatse; aatsf; aatsg; aatsh; aatsi; aatsj; aatsk; aatsl; aatsm; aatsn; aatso; aatsp; aatsq; aatsr; aatss; aatst; aatsu; aatsv; aatsw; aatsx; aatsy; aatsz; aatta; aattb; aattc; aattd; aatte; aattf; aattg; aatth; aatti; aattj; aattk; aattl; aattm; aattn; aatto; aattp; aattq; aattr; aatts; aattt; aattu; aattv; aattw; aattx; aatty; aattz; aatua; aatub; aatuc; aatud; aatue; aatuf; aatug; aatuh; aatui; aatuj; aatuk; aatul; aatum; aatun; aatuo; aatup; aatuq; aatur; aatus; aatut; aatuu; aatuv; aatuw; aatux; aatuy; aatuz; aatva; aatvb; aatvc; aatvd; aatve; aatvf; aatvg; aatvh; aatvi; aatvj; aatvk; aatvl; aatvm; aatvn; aatvo; aatvp; aatvq; aatvr; aatvs; aatvt; aatvu; aatvv; aatvw; aatvx; aatvy; aatvz; aatwa; aatwb; aatwc; aatwd; aatwe; aatwf; aatwg; aatwh; aatwi; aatwj; aatwk; aatwl; aatwm; aatwn; aatwo; aatwp; aatwq; aatwr; aatws; aatwt; aatwu; aatwv; aatww; aatwx; aatwy; aatwz; aatxa; aatxb; aatxc; aatxd; aatxe; aatxf; aatxg; aatxh; aatxi; aatxj; aatxk; aatxl; aatxm; aatxn; aatxo; aatxp; aatxq; aatxr; aatxs; aatxt; aatxu; aatxv; aatxw; aatxx; aatxy; aatxz; aatya; aatyb; aatyc; aatyd; aatye; aatyf; aatyg; aatyh; aatyi; aatyj; aatyk; aatyl; aatym; aatyn; aatyo; aatyp; aatyq; aatyr; aatys; aatyt; aatyu; aatyv; aatyw; aatyx; aatyy; aatyz; aatza; aatzb; aatzc; aatzd; aatze; aatzf; aatzg; aatzh; aatzi; aatzj; aatzk; aatzl; aatzm; aatzn; aatzo; aatzp; aatzq; aatzr; aatzs; aatzt; aatzu; aatzv; aatzw; aatzx; aatzy; aatzz; aauaa; aauab; aauac; aauad; aauae; aauaf; aauag; aauah; aauai; aauaj; aauak; aaual; aauam; aauan; aauao; aauap; aauaq; aauar; aauas; aauat; aauau; aauav; aauaw; aauax; aauay; aauaz; aauba; aaubb; aaubc; aaubd; aaube; aaubf; aaubg; aaubh; aaubi; aaubj; aaubk; aaubl; aaubm; aaubn; aaubo; aaubp; aaubq; aaubr; aaubs; aaubt; aaubu; aaubv; aaubw; aaubx; aauby; aaubz; aauca; aaucb; aaucc; aaucd; aauce; aaucf; aaucg; aauch; aauci; aaucj; aauck; aaucl; aaucm; aaucn; aauco; aaucp; aaucq; aaucr; aaucs; aauct; aaucu; aaucv; aaucw; aaucx; aaucy; aaucz; aauda; aaudb; aaudc; aaudd; aaude; aaudf; aaudg; aaudh; aaudi; aaudj; aaudk; aaudl; aaudm; aaudn; aaudo; aaudp; aaudq; aaudr; aauds; aaudt; aaudu; aaudv; aaudw; aaudx; aaudy; aaudz; aauea; aaueb; aauec; aaued; aauee; aauef; aaueg; aaueh; aauei; aauej; aauek; aauel; aauem; aauen; aaueo; aauep; aaueq; aauer; aaues; aauet; aaueu; aauev; aauew; aauex; aauey; aauez; aaufa; aaufb; aaufc; aaufd; aaufe; aauff; aaufg; aaufh; aaufi; aaufj; aaufk; aaufl; aaufm; aaufn; aaufo; aaufp; aaufq; aaufr; aaufs; aauft; aaufu; aaufv; aaufw; aaufx; aaufy; aaufz; aauga; aaugb; aaugc; aaugd; aauge; aaugf; aaugg; aaugh; aaugi; aaugj; aaugk; aaugl; aaugm; aaugn; aaugo; aaugp; aaugq; aaugr; aaugs; aaugt; aaugu; aaugv; aaugw; aaugx; aaugy; aaugz; aauha; aauhb; aauhc; aauhd; aauhe; aauhf; aauhg; aauhh; aauhi; aauhj; aauhk; aauhl; aauhm; aauhn; aauho; aauhp; aauhq; aauhr; aauhs; aauht; aauhu; aauhv; aauhw; aauhx; aauhy; aauhz; aauia; aauib; aauic; aauid; aauie; aauif; aauig; aauih; aauii; aauij; aauik; aauil; aauim; aauin; aauio; aauip; aauiq; aauir; aauis; aauit; aauiu; aauiv; aauiw; aauix; aauiy; aauiz; aauja; aaujb; aaujc; aaujd; aauje; aaujf; aaujg; aaujh; aauji; aaujj; aaujk; aaujl; aaujm; aaujn; aaujo; aaujp; aaujq; aaujr; aaujs; aaujt; aauju; aaujv; aaujw; aaujx; aaujy; aaujz; aauka; aaukb; aaukc; aaukd; aauke; aaukf; aaukg; aaukh; aauki; aaukj; aaukk; aaukl; aaukm; aaukn; aauko; aaukp; aaukq; aaukr; aauks; aaukt; aauku; aaukv; aaukw; aaukx; aauky; aaukz; aaula; aaulb; aaulc; aauld; aaule; aaulf; aaulg; aaulh; aauli; aaulj; aaulk; aaull; aaulm; aauln; aaulo; aaulp; aaulq; aaulr; aauls; aault; aaulu; aaulv; aaulw; aaulx; aauly; aaulz; aauma; aaumb; aaumc; aaumd; aaume; aaumf; aaumg; aaumh; aaumi; aaumj; aaumk; aauml; aaumm; aaumn; aaumo; aaump; aaumq; aaumr; aaums; aaumt; aaumu; aaumv; aaumw; aaumx; aaumy; aaumz; aauna; aaunb; aaunc; aaund; aaune; aaunf; aaung; aaunh; aauni; aaunj; aaunk; aaunl; aaunm; aaunn; aauno; aaunp; aaunq; aaunr; aauns; aaunt; aaunu; aaunv; aaunw; aaunx; aauny; aaunz; aauoa; aauob; aauoc; aauod; aauoe; aauof; aauog; aauoh; aauoi; aauoj; aauok; aauol; aauom; aauon; aauoo; aauop; aauoq; aauor; aauos; aauot; aauou; aauov; aauow; aauox; aauoy; aauoz; aaupa; aaupb; aaupc; aaupd; aaupe; aaupf; aaupg; aauph; aaupi; aaupj; aaupk; aaupl; aaupm; aaupn; aaupo; aaupp; aaupq; aaupr; aaups; aaupt; aaupu; aaupv; aaupw; aaupx; aaupy; aaupz; aauqa; aauqb; aauqc; aauqd; aauqe; aauqf; aauqg; aauqh; aauqi; aauqj; aauqk; aauql; aauqm; aauqn; aauqo; aauqp; aauqq; aauqr; aauqs; aauqt; aauqu; aauqv; aauqw; aauqx; aauqy; aauqz; aaura; aaurb; aaurc; aaurd; aaure; aaurf; aaurg; aaurh; aauri; aaurj; aaurk; aaurl; aaurm; aaurn; aauro; aaurp; aaurq; aaurr; aaurs; aaurt; aauru; aaurv; aaurw; aaurx; aaury; aaurz; aausa; aausb; aausc; aausd; aause; aausf; aausg; aaush; aausi; aausj; aausk; aausl; aausm; aausn; aauso; aausp; aausq; aausr; aauss; aaust; aausu; aausv; aausw; aausx; aausy; aausz; aauta; aautb; aautc; aautd; aaute; aautf; aautg; aauth; aauti; aautj; aautk; aautl; aautm; aautn; aauto; aautp; aautq; aautr; aauts; aautt; aautu; aautv; aautw; aautx; aauty; aautz; aauua; aauub; aauuc; aauud; aauue; aauuf; aauug; aauuh; aauui; aauuj; aauuk; aauul; aauum; aauun; aauuo; aauup; aauuq; aauur; aauus; aauut; aauuu; aauuv; aauuw; aauux; aauuy; aauuz; aauva; aauvb; aauvc; aauvd; aauve; aauvf; aauvg; aauvh; aauvi; aauvj; aauvk; aauvl; aauvm; aauvn; aauvo; aauvp; aauvq; aauvr; aauvs; aauvt; aauvu; aauvv; aauvw; aauvx; aauvy; aauvz; aauwa; aauwb; aauwc; aauwd; aauwe; aauwf; aauwg; aauwh; aauwi; aauwj; aauwk; aauwl; aauwm; aauwn; aauwo; aauwp; aauwq; aauwr; aauws; aauwt; aauwu; aauwv; aauww; aauwx; aauwy; aauwz; aauxa; aauxb; aauxc; aauxd; aauxe; aauxf; aauxg; aauxh; aauxi; aauxj; aauxk; aauxl; aauxm; aauxn; aauxo; aauxp; aauxq; aauxr; aauxs; aauxt; aauxu; aauxv; aauxw; aauxx; aauxy; aauxz; aauya; aauyb; aauyc; aauyd; aauye; aauyf; aauyg; aauyh; aauyi; aauyj; aauyk; aauyl; aauym; aauyn; aauyo; aauyp; aauyq; aauyr; aauys; aauyt; aauyu; aauyv; aauyw; aauyx; aauyy; aauyz; aauza; aauzb; aauzc; aauzd; aauze; aauzf; aauzg; aauzh; aauzi; aauzj; aauzk; aauzl; aauzm; aauzn; aauzo; aauzp; aauzq; aauzr; aauzs; aauzt; aauzu; aauzv; aauzw; aauzx; aauzy; aauzz; aavaa; aavab; aavac; aavad; aavae; aavaf; aavag; aavah; aavai; aavaj; aavak; aaval; aavam; aavan; aavao; aavap; aavaq; aavar; aavas; aavat; aavau; aavav; aavaw; aavax; aavay; aavaz; aavba; aavbb; aavbc; aavbd; aavbe; aavbf; aavbg; aavbh; aavbi; aavbj; aavbk; aavbl; aavbm; aavbn; aavbo; aavbp; aavbq; aavbr; aavbs; aavbt; aavbu; aavbv; aavbw; aavbx; aavby; aavbz; aavca; aavcb; aavcc; aavcd; aavce; aavcf; aavcg; aavch; aavci; aavcj; aavck; aavcl; aavcm; aavcn; aavco; aavcp; aavcq; aavcr; aavcs; aavct; aavcu; aavcv; aavcw; aavcx; aavcy; aavcz; aavda; aavdb; aavdc; aavdd; aavde; aavdf; aavdg; aavdh; aavdi; aavdj; aavdk; aavdl; aavdm; aavdn; aavdo; aavdp; aavdq; aavdr; aavds; aavdt; aavdu; aavdv; aavdw; aavdx; aavdy; aavdz; aavea; aaveb; aavec; aaved; aavee; aavef; aaveg; aaveh; aavei; aavej; aavek; aavel; aavem; aaven; aaveo; aavep; aaveq; aaver; aaves; aavet; aaveu; aavev; aavew; aavex; aavey; aavez; aavfa; aavfb; aavfc; aavfd; aavfe; aavff; aavfg; aavfh; aavfi; aavfj; aavfk; aavfl; aavfm; aavfn; aavfo; aavfp; aavfq; aavfr; aavfs; aavft; aavfu; aavfv; aavfw; aavfx; aavfy; aavfz; aavga; aavgb; aavgc; aavgd; aavge; aavgf; aavgg; aavgh; aavgi; aavgj; aavgk; aavgl; aavgm; aavgn; aavgo; aavgp; aavgq; aavgr; aavgs; aavgt; aavgu; aavgv; aavgw; aavgx; aavgy; aavgz; aavha; aavhb; aavhc; aavhd; aavhe; aavhf; aavhg; aavhh; aavhi; aavhj; aavhk; aavhl; aavhm; aavhn; aavho; aavhp; aavhq; aavhr; aavhs; aavht; aavhu; aavhv; aavhw; aavhx; aavhy; aavhz; aavia; aavib; aavic; aavid; aavie; aavif; aavig; aavih; aavii; aavij; aavik; aavil; aavim; aavin; aavio; aavip; aaviq; aavir; aavis; aavit; aaviu; aaviv; aaviw; aavix; aaviy; aaviz; aavja; aavjb; aavjc; aavjd; aavje; aavjf; aavjg; aavjh; aavji; aavjj; aavjk; aavjl; aavjm; aavjn; aavjo; aavjp; aavjq; aavjr; aavjs; aavjt; aavju; aavjv; aavjw; aavjx; aavjy; aavjz; aavka; aavkb; aavkc; aavkd; aavke; aavkf; aavkg; aavkh; aavki; aavkj; aavkk; aavkl; aavkm; aavkn; aavko; aavkp; aavkq; aavkr; aavks; aavkt; aavku; aavkv; aavkw; aavkx; aavky; aavkz; aavla; aavlb; aavlc; aavld; aavle; aavlf; aavlg; aavlh; aavli; aavlj; aavlk; aavll; aavlm; aavln; aavlo; aavlp; aavlq; aavlr; aavls; aavlt; aavlu; aavlv; aavlw; aavlx; aavly; aavlz; aavma; aavmb; aavmc; aavmd; aavme; aavmf; aavmg; aavmh; aavmi; aavmj; aavmk; aavml; aavmm; aavmn; aavmo; aavmp; aavmq; aavmr; aavms; aavmt; aavmu; aavmv; aavmw; aavmx; aavmy; aavmz; aavna; aavnb; aavnc; aavnd; aavne; aavnf; aavng; aavnh; aavni; aavnj; aavnk; aavnl; aavnm; aavnn; aavno; aavnp; aavnq; aavnr; aavns; aavnt; aavnu; aavnv; aavnw; aavnx; aavny; aavnz; aavoa; aavob; aavoc; aavod; aavoe; aavof; aavog; aavoh; aavoi; aavoj; aavok; aavol; aavom; aavon; aavoo; aavop; aavoq; aavor; aavos; aavot; aavou; aavov; aavow; aavox; aavoy; aavoz; aavpa; aavpb; aavpc; aavpd; aavpe; aavpf; aavpg; aavph; aavpi; aavpj; aavpk; aavpl; aavpm; aavpn; aavpo; aavpp; aavpq; aavpr; aavps; aavpt; aavpu; aavpv; aavpw; aavpx; aavpy; aavpz; aavqa; aavqb; aavqc; aavqd; aavqe; aavqf; aavqg; aavqh; aavqi; aavqj; aavqk; aavql; aavqm; aavqn; aavqo; aavqp; aavqq; aavqr; aavqs; aavqt; aavqu; aavqv; aavqw; aavqx; aavqy; aavqz; aavra; aavrb; aavrc; aavrd; aavre; aavrf; aavrg; aavrh; aavri; aavrj; aavrk; aavrl; aavrm; aavrn; aavro; aavrp; aavrq; aavrr; aavrs; aavrt; aavru; aavrv; aavrw; aavrx; aavry; aavrz; aavsa; aavsb; aavsc; aavsd; aavse; aavsf; aavsg; aavsh; aavsi; aavsj; aavsk; aavsl; aavsm; aavsn; aavso; aavsp; aavsq; aavsr; aavss; aavst; aavsu; aavsv; aavsw; aavsx; aavsy; aavsz; aavta; aavtb; aavtc; aavtd; aavte; aavtf; aavtg; aavth; aavti; aavtj; aavtk; aavtl; aavtm; aavtn; aavto; aavtp; aavtq; aavtr; aavts; aavtt; aavtu; aavtv; aavtw; aavtx; aavty; aavtz; aavua; aavub; aavuc; aavud; aavue; aavuf; aavug; aavuh; aavui; aavuj; aavuk; aavul; aavum; aavun; aavuo; aavup; aavuq; aavur; aavus; aavut; aavuu; aavuv; aavuw; aavux; aavuy; aavuz; aavva; aavvb; aavvc; aavvd; aavve; aavvf; aavvg; aavvh; aavvi; aavvj; aavvk; aavvl; aavvm; aavvn; aavvo; aavvp; aavvq; aavvr; aavvs; aavvt; aavvu; aavvv; aavvw; aavvx; aavvy; aavvz; aavwa; aavwb; aavwc; aavwd; aavwe; aavwf; aavwg; aavwh; aavwi; aavwj; aavwk; aavwl; aavwm; aavwn; aavwo; aavwp; aavwq; aavwr; aavws; aavwt; aavwu; aavwv; aavww; aavwx; aavwy; aavwz; aavxa; aavxb; aavxc; aavxd; aavxe; aavxf; aavxg; aavxh; aavxi; aavxj; aavxk; aavxl; aavxm; aavxn; aavxo; aavxp; aavxq; aavxr; aavxs; aavxt; aavxu; aavxv; aavxw; aavxx; aavxy; aavxz; aavya; aavyb; aavyc; aavyd; aavye; aavyf; aavyg; aavyh; aavyi; aavyj; aavyk; aavyl; aavym; aavyn; aavyo; aavyp; aavyq; aavyr; aavys; aavyt; aavyu; aavyv; aavyw; aavyx; aavyy; aavyz; aavza; aavzb; aavzc; aavzd; aavze; aavzf; aavzg; aavzh; aavzi; aavzj; aavzk; aavzl; aavzm; aavzn; aavzo; aavzp; aavzq; aavzr; aavzs; aavzt; aavzu; aavzv; aavzw; aavzx; aavzy; aavzz; aawaa; aawab; aawac; aawad; aawae; aawaf; aawag; aawah; aawai; aawaj; aawak; aawal; aawam; aawan; aawao; aawap; aawaq; aawar; aawas; aawat; aawau; aawav; aawaw; aawax; aaway; aawaz; aawba; aawbb; aawbc; aawbd; aawbe; aawbf; aawbg; aawbh; aawbi; aawbj; aawbk; aawbl; aawbm; aawbn; aawbo; aawbp; aawbq; aawbr; aawbs; aawbt; aawbu; aawbv; aawbw; aawbx; aawby; aawbz; aawca; aawcb; aawcc; aawcd; aawce; aawcf; aawcg; aawch; aawci; aawcj; aawck; aawcl; aawcm; aawcn; aawco; aawcp; aawcq; aawcr; aawcs; aawct; aawcu; aawcv; aawcw; aawcx; aawcy; aawcz; aawda; aawdb; aawdc; aawdd; aawde; aawdf; aawdg; aawdh; aawdi; aawdj; aawdk; aawdl; aawdm; aawdn; aawdo; aawdp; aawdq; aawdr; aawds; aawdt; aawdu; aawdv; aawdw; aawdx; aawdy; aawdz; aawea; aaweb; aawec; aawed; aawee; aawef; aaweg; aaweh; aawei; aawej; aawek; aawel; aawem; aawen; aaweo; aawep; aaweq; aawer; aawes; aawet; aaweu; aawev; aawew; aawex; aawey; aawez; aawfa; aawfb; aawfc; aawfd; aawfe; aawff; aawfg; aawfh; aawfi; aawfj; aawfk; aawfl; aawfm; aawfn; aawfo; aawfp; aawfq; aawfr; aawfs; aawft; aawfu; aawfv; aawfw; aawfx; aawfy; aawfz; aawga; aawgb; aawgc; aawgd; aawge; aawgf; aawgg; aawgh; aawgi; aawgj; aawgk; aawgl; aawgm; aawgn; aawgo; aawgp; aawgq; aawgr; aawgs; aawgt; aawgu; aawgv; aawgw; aawgx; aawgy; aawgz; aawha; aawhb; aawhc; aawhd; aawhe; aawhf; aawhg; aawhh; aawhi; aawhj; aawhk; aawhl; aawhm; aawhn; aawho; aawhp; aawhq; aawhr; aawhs; aawht; aawhu; aawhv; aawhw; aawhx; aawhy; aawhz; aawia; aawib; aawic; aawid; aawie; aawif; aawig; aawih; aawii; aawij; aawik; aawil; aawim; aawin; aawio; aawip; aawiq; aawir; aawis; aawit; aawiu; aawiv; aawiw; aawix; aawiy; aawiz; aawja; aawjb; aawjc; aawjd; aawje; aawjf; aawjg; aawjh; aawji; aawjj; aawjk; aawjl; aawjm; aawjn; aawjo; aawjp; aawjq; aawjr; aawjs; aawjt; aawju; aawjv; aawjw; aawjx; aawjy; aawjz; aawka; aawkb; aawkc; aawkd; aawke; aawkf; aawkg; aawkh; aawki; aawkj; aawkk; aawkl; aawkm; aawkn; aawko; aawkp; aawkq; aawkr; aawks; aawkt; aawku; aawkv; aawkw; aawkx; aawky; aawkz; aawla; aawlb; aawlc; aawld; aawle; aawlf; aawlg; aawlh; aawli; aawlj; aawlk; aawll; aawlm; aawln; aawlo; aawlp; aawlq; aawlr; aawls; aawlt; aawlu; aawlv; aawlw; aawlx; aawly; aawlz; aawma; aawmb; aawmc; aawmd; aawme; aawmf; aawmg; aawmh; aawmi; aawmj; aawmk; aawml; aawmm; aawmn; aawmo; aawmp; aawmq; aawmr; aawms; aawmt; aawmu; aawmv; aawmw; aawmx; aawmy; aawmz; aawna; aawnb; aawnc; aawnd; aawne; aawnf; aawng; aawnh; aawni; aawnj; aawnk; aawnl; aawnm; aawnn; aawno; aawnp; aawnq; aawnr; aawns; aawnt; aawnu; aawnv; aawnw; aawnx; aawny; aawnz; aawoa; aawob; aawoc; aawod; aawoe; aawof; aawog; aawoh; aawoi; aawoj; aawok; aawol; aawom; aawon; aawoo; aawop; aawoq; aawor; aawos; aawot; aawou; aawov; aawow; aawox; aawoy; aawoz; aawpa; aawpb; aawpc; aawpd; aawpe; aawpf; aawpg; aawph; aawpi; aawpj; aawpk; aawpl; aawpm; aawpn; aawpo; aawpp; aawpq; aawpr; aawps; aawpt; aawpu; aawpv; aawpw; aawpx; aawpy; aawpz; aawqa; aawqb; aawqc; aawqd; aawqe; aawqf; aawqg; aawqh; aawqi; aawqj; aawqk; aawql; aawqm; aawqn; aawqo; aawqp; aawqq; aawqr; aawqs; aawqt; aawqu; aawqv; aawqw; aawqx; aawqy; aawqz; aawra; aawrb; aawrc; aawrd; aawre; aawrf; aawrg; aawrh; aawri; aawrj; aawrk; aawrl; aawrm; aawrn; aawro; aawrp; aawrq; aawrr; aawrs; aawrt; aawru; aawrv; aawrw; aawrx; aawry; aawrz; aawsa; aawsb; aawsc; aawsd; aawse; aawsf; aawsg; aawsh; aawsi; aawsj; aawsk; aawsl; aawsm; aawsn; aawso; aawsp; aawsq; aawsr; aawss; aawst; aawsu; aawsv; aawsw; aawsx; aawsy; aawsz; aawta; aawtb; aawtc; aawtd; aawte; aawtf; aawtg; aawth; aawti; aawtj; aawtk; aawtl; aawtm; aawtn; aawto; aawtp; aawtq; aawtr; aawts; aawtt; aawtu; aawtv; aawtw; aawtx; aawty; aawtz; aawua; aawub; aawuc; aawud; aawue; aawuf; aawug; aawuh; aawui; aawuj; aawuk; aawul; aawum; aawun; aawuo; aawup; aawuq; aawur; aawus; aawut; aawuu; aawuv; aawuw; aawux; aawuy; aawuz; aawva; aawvb; aawvc; aawvd; aawve; aawvf; aawvg; aawvh; aawvi; aawvj; aawvk; aawvl; aawvm; aawvn; aawvo; aawvp; aawvq; aawvr; aawvs; aawvt; aawvu; aawvv; aawvw; aawvx; aawvy; aawvz; aawwa; aawwb; aawwc; aawwd; aawwe; aawwf; aawwg; aawwh; aawwi; aawwj; aawwk; aawwl; aawwm; aawwn; aawwo; aawwp; aawwq; aawwr; aawws; aawwt; aawwu; aawwv; aawww; aawwx; aawwy; aawwz; aawxa; aawxb; aawxc; aawxd; aawxe; aawxf; aawxg; aawxh; aawxi; aawxj; aawxk; aawxl; aawxm; aawxn; aawxo; aawxp; aawxq; aawxr; aawxs; aawxt; aawxu; aawxv; aawxw; aawxx; aawxy; aawxz; aawya; aawyb; aawyc; aawyd; aawye; aawyf; aawyg; aawyh; aawyi; aawyj; aawyk; aawyl; aawym; aawyn; aawyo; aawyp; aawyq; aawyr; aawys; aawyt; aawyu; aawyv; aawyw; aawyx; aawyy; aawyz; aawza; aawzb; aawzc; aawzd; aawze; aawzf; aawzg; aawzh; aawzi; aawzj; aawzk; aawzl; aawzm; aawzn; aawzo; aawzp; aawzq; aawzr; aawzs; aawzt; aawzu; aawzv; aawzw; aawzx; aawzy; aawzz; aaxaa; aaxab; aaxac; aaxad; aaxae; aaxaf; aaxag; aaxah; aaxai; aaxaj; aaxak; aaxal; aaxam; aaxan; aaxao; aaxap; aaxaq; aaxar; aaxas; aaxat; aaxau; aaxav; aaxaw; aaxax; aaxay; aaxaz; aaxba; aaxbb; aaxbc; aaxbd; aaxbe; aaxbf; aaxbg; aaxbh; aaxbi; aaxbj; aaxbk; aaxbl; aaxbm; aaxbn; aaxbo; aaxbp; aaxbq; aaxbr; aaxbs; aaxbt; aaxbu; aaxbv; aaxbw; aaxbx; aaxby; aaxbz; aaxca; aaxcb; aaxcc; aaxcd; aaxce; aaxcf; aaxcg; aaxch; aaxci; aaxcj; aaxck; aaxcl; aaxcm; aaxcn; aaxco; aaxcp; aaxcq; aaxcr; aaxcs; aaxct; aaxcu; aaxcv; aaxcw; aaxcx; aaxcy; aaxcz; aaxda; aaxdb; aaxdc; aaxdd; aaxde; aaxdf; aaxdg; aaxdh; aaxdi; aaxdj; aaxdk; aaxdl; aaxdm; aaxdn; aaxdo; aaxdp; aaxdq; aaxdr; aaxds; aaxdt; aaxdu; aaxdv; aaxdw; aaxdx; aaxdy; aaxdz; aaxea; aaxeb; aaxec; aaxed; aaxee; aaxef; aaxeg; aaxeh; aaxei; aaxej; aaxek; aaxel; aaxem; aaxen; aaxeo; aaxep; aaxeq; aaxer; aaxes; aaxet; aaxeu; aaxev; aaxew; aaxex; aaxey; aaxez; aaxfa; aaxfb; aaxfc; aaxfd; aaxfe; aaxff; aaxfg; aaxfh; aaxfi; aaxfj; aaxfk; aaxfl; aaxfm; aaxfn; aaxfo; aaxfp; aaxfq; aaxfr; aaxfs; aaxft; aaxfu; aaxfv; aaxfw; aaxfx; aaxfy; aaxfz; aaxga; aaxgb; aaxgc; aaxgd; aaxge; aaxgf; aaxgg; aaxgh; aaxgi; aaxgj; aaxgk; aaxgl; aaxgm; aaxgn; aaxgo; aaxgp; aaxgq; aaxgr; aaxgs; aaxgt; aaxgu; aaxgv; aaxgw; aaxgx; aaxgy; aaxgz; aaxha; aaxhb; aaxhc; aaxhd; aaxhe; aaxhf; aaxhg; aaxhh; aaxhi; aaxhj; aaxhk; aaxhl; aaxhm; aaxhn; aaxho; aaxhp; aaxhq; aaxhr; aaxhs; aaxht; aaxhu; aaxhv; aaxhw; aaxhx; aaxhy; aaxhz; aaxia; aaxib; aaxic; aaxid; aaxie; aaxif; aaxig; aaxih; aaxii; aaxij; aaxik; aaxil; aaxim; aaxin; aaxio; aaxip; aaxiq; aaxir; aaxis; aaxit; aaxiu; aaxiv; aaxiw; aaxix; aaxiy; aaxiz; aaxja; aaxjb; aaxjc; aaxjd; aaxje; aaxjf; aaxjg; aaxjh; aaxji; aaxjj; aaxjk; aaxjl; aaxjm; aaxjn; aaxjo; aaxjp; aaxjq; aaxjr; aaxjs; aaxjt; aaxju; aaxjv; aaxjw; aaxjx; aaxjy; aaxjz; aaxka; aaxkb; aaxkc; aaxkd; aaxke; aaxkf; aaxkg; aaxkh; aaxki; aaxkj; aaxkk; aaxkl; aaxkm; aaxkn; aaxko; aaxkp; aaxkq; aaxkr; aaxks; aaxkt; aaxku; aaxkv; aaxkw; aaxkx; aaxky; aaxkz; aaxla; aaxlb; aaxlc; aaxld; aaxle; aaxlf; aaxlg; aaxlh; aaxli; aaxlj; aaxlk; aaxll; aaxlm; aaxln; aaxlo; aaxlp; aaxlq; aaxlr; aaxls; aaxlt; aaxlu; aaxlv; aaxlw; aaxlx; aaxly; aaxlz; aaxma; aaxmb; aaxmc; aaxmd; aaxme; aaxmf; aaxmg; aaxmh; aaxmi; aaxmj; aaxmk; aaxml; aaxmm; aaxmn; aaxmo; aaxmp; aaxmq; aaxmr; aaxms; aaxmt; aaxmu; aaxmv; aaxmw; aaxmx; aaxmy; aaxmz; aaxna; aaxnb; aaxnc; aaxnd; aaxne; aaxnf; aaxng; aaxnh; aaxni; aaxnj; aaxnk; aaxnl; aaxnm; aaxnn; aaxno; aaxnp; aaxnq; aaxnr; aaxns; aaxnt; aaxnu; aaxnv; aaxnw; aaxnx; aaxny; aaxnz; aaxoa; aaxob; aaxoc; aaxod; aaxoe; aaxof; aaxog; aaxoh; aaxoi; aaxoj; aaxok; aaxol; aaxom; aaxon; aaxoo; aaxop; aaxoq; aaxor; aaxos; aaxot; aaxou; aaxov; aaxow; aaxox; aaxoy; aaxoz; aaxpa; aaxpb; aaxpc; aaxpd; aaxpe; aaxpf; aaxpg; aaxph; aaxpi; aaxpj; aaxpk; aaxpl; aaxpm; aaxpn; aaxpo; aaxpp; aaxpq; aaxpr; aaxps; aaxpt; aaxpu; aaxpv; aaxpw; aaxpx; aaxpy; aaxpz; aaxqa; aaxqb; aaxqc; aaxqd; aaxqe; aaxqf; aaxqg; aaxqh; aaxqi; aaxqj; aaxqk; aaxql; aaxqm; aaxqn; aaxqo; aaxqp; aaxqq; aaxqr; aaxqs; aaxqt; aaxqu; aaxqv; aaxqw; aaxqx; aaxqy; aaxqz; aaxra; aaxrb; aaxrc; aaxrd; aaxre; aaxrf; aaxrg; aaxrh; aaxri; aaxrj; aaxrk; aaxrl; aaxrm; aaxrn; aaxro; aaxrp; aaxrq; aaxrr; aaxrs; aaxrt; aaxru; aaxrv; aaxrw; aaxrx; aaxry; aaxrz; aaxsa; aaxsb; aaxsc; aaxsd; aaxse; aaxsf; aaxsg; aaxsh; aaxsi; aaxsj; aaxsk; aaxsl; aaxsm; aaxsn; aaxso; aaxsp; aaxsq; aaxsr; aaxss; aaxst; aaxsu; aaxsv; aaxsw; aaxsx; aaxsy; aaxsz; aaxta; aaxtb; aaxtc; aaxtd; aaxte; aaxtf; aaxtg; aaxth; aaxti; aaxtj; aaxtk; aaxtl; aaxtm; aaxtn; aaxto; aaxtp; aaxtq; aaxtr; aaxts; aaxtt; aaxtu; aaxtv; aaxtw; aaxtx; aaxty; aaxtz; aaxua; aaxub; aaxuc; aaxud; aaxue; aaxuf; aaxug; aaxuh; aaxui; aaxuj; aaxuk; aaxul; aaxum; aaxun; aaxuo; aaxup; aaxuq; aaxur; aaxus; aaxut; aaxuu; aaxuv; aaxuw; aaxux; aaxuy; aaxuz; aaxva; aaxvb; aaxvc; aaxvd; aaxve; aaxvf; aaxvg; aaxvh; aaxvi; aaxvj; aaxvk; aaxvl; aaxvm; aaxvn; aaxvo; aaxvp; aaxvq; aaxvr; aaxvs; aaxvt; aaxvu; aaxvv; aaxvw; aaxvx; aaxvy; aaxvz; aaxwa; aaxwb; aaxwc; aaxwd; aaxwe; aaxwf; aaxwg; aaxwh; aaxwi; aaxwj; aaxwk; aaxwl; aaxwm; aaxwn; aaxwo; aaxwp; aaxwq; aaxwr; aaxws; aaxwt; aaxwu; aaxwv; aaxww; aaxwx; aaxwy; aaxwz; aaxxa; aaxxb; aaxxc; aaxxd; aaxxe; aaxxf; aaxxg; aaxxh; aaxxi; aaxxj; aaxxk; aaxxl; aaxxm; aaxxn; aaxxo; aaxxp; aaxxq; aaxxr; aaxxs; aaxxt; aaxxu; aaxxv; aaxxw; aaxxx; aaxxy; aaxxz; aaxya; aaxyb; aaxyc; aaxyd; aaxye; aaxyf; aaxyg; aaxyh; aaxyi; aaxyj; aaxyk; aaxyl; aaxym; aaxyn; aaxyo; aaxyp; aaxyq; aaxyr; aaxys; aaxyt; aaxyu; aaxyv; aaxyw; aaxyx; aaxyy; aaxyz; aaxza; aaxzb; aaxzc; aaxzd; aaxze; aaxzf; aaxzg; aaxzh; aaxzi; aaxzj; aaxzk; aaxzl; aaxzm; aaxzn; aaxzo; aaxzp; aaxzq; aaxzr; aaxzs; aaxzt; aaxzu; aaxzv; aaxzw; aaxzx; aaxzy; aaxzz; aayaa; aayab; aayac; aayad; aayae; aayaf; aayag; aayah; aayai; aayaj; aayak; aayal; aayam; aayan; aayao; aayap; aayaq; aayar; aayas; aayat; aayau; aayav; aayaw; aayax; aayay; aayaz; aayba; aaybb; aaybc; aaybd; aaybe; aaybf; aaybg; aaybh; aaybi; aaybj; aaybk; aaybl; aaybm; aaybn; aaybo; aaybp; aaybq; aaybr; aaybs; aaybt; aaybu; aaybv; aaybw; aaybx; aayby; aaybz; aayca; aaycb; aaycc; aaycd; aayce; aaycf; aaycg; aaych; aayci; aaycj; aayck; aaycl; aaycm; aaycn; aayco; aaycp; aaycq; aaycr; aaycs; aayct; aaycu; aaycv; aaycw; aaycx; aaycy; aaycz; aayda; aaydb; aaydc; aaydd; aayde; aaydf; aaydg; aaydh; aaydi; aaydj; aaydk; aaydl; aaydm; aaydn; aaydo; aaydp; aaydq; aaydr; aayds; aaydt; aaydu; aaydv; aaydw; aaydx; aaydy; aaydz; aayea; aayeb; aayec; aayed; aayee; aayef; aayeg; aayeh; aayei; aayej; aayek; aayel; aayem; aayen; aayeo; aayep; aayeq; aayer; aayes; aayet; aayeu; aayev; aayew; aayex; aayey; aayez; aayfa; aayfb; aayfc; aayfd; aayfe; aayff; aayfg; aayfh; aayfi; aayfj; aayfk; aayfl; aayfm; aayfn; aayfo; aayfp; aayfq; aayfr; aayfs; aayft; aayfu; aayfv; aayfw; aayfx; aayfy; aayfz; aayga; aaygb; aaygc; aaygd; aayge; aaygf; aaygg; aaygh; aaygi; aaygj; aaygk; aaygl; aaygm; aaygn; aaygo; aaygp; aaygq; aaygr; aaygs; aaygt; aaygu; aaygv; aaygw; aaygx; aaygy; aaygz; aayha; aayhb; aayhc; aayhd; aayhe; aayhf; aayhg; aayhh; aayhi; aayhj; aayhk; aayhl; aayhm; aayhn; aayho; aayhp; aayhq; aayhr; aayhs; aayht; aayhu; aayhv; aayhw; aayhx; aayhy; aayhz; aayia; aayib; aayic; aayid; aayie; aayif; aayig; aayih; aayii; aayij; aayik; aayil; aayim; aayin; aayio; aayip; aayiq; aayir; aayis; aayit; aayiu; aayiv; aayiw; aayix; aayiy; aayiz; aayja; aayjb; aayjc; aayjd; aayje; aayjf; aayjg; aayjh; aayji; aayjj; aayjk; aayjl; aayjm; aayjn; aayjo; aayjp; aayjq; aayjr; aayjs; aayjt; aayju; aayjv; aayjw; aayjx; aayjy; aayjz; aayka; aaykb; aaykc; aaykd; aayke; aaykf; aaykg; aaykh; aayki; aaykj; aaykk; aaykl; aaykm; aaykn; aayko; aaykp; aaykq; aaykr; aayks; aaykt; aayku; aaykv; aaykw; aaykx; aayky; aaykz; aayla; aaylb; aaylc; aayld; aayle; aaylf; aaylg; aaylh; aayli; aaylj; aaylk; aayll; aaylm; aayln; aaylo; aaylp; aaylq; aaylr; aayls; aaylt; aaylu; aaylv; aaylw; aaylx; aayly; aaylz; aayma; aaymb; aaymc; aaymd; aayme; aaymf; aaymg; aaymh; aaymi; aaymj; aaymk; aayml; aaymm; aaymn; aaymo; aaymp; aaymq; aaymr; aayms; aaymt; aaymu; aaymv; aaymw; aaymx; aaymy; aaymz; aayna; aaynb; aaync; aaynd; aayne; aaynf; aayng; aaynh; aayni; aaynj; aaynk; aaynl; aaynm; aaynn; aayno; aaynp; aaynq; aaynr; aayns; aaynt; aaynu; aaynv; aaynw; aaynx; aayny; aaynz; aayoa; aayob; aayoc; aayod; aayoe; aayof; aayog; aayoh; aayoi; aayoj; aayok; aayol; aayom; aayon; aayoo; aayop; aayoq; aayor; aayos; aayot; aayou; aayov; aayow; aayox; aayoy; aayoz; aaypa; aaypb; aaypc; aaypd; aaype; aaypf; aaypg; aayph; aaypi; aaypj; aaypk; aaypl; aaypm; aaypn; aaypo; aaypp; aaypq; aaypr; aayps; aaypt; aaypu; aaypv; aaypw; aaypx; aaypy; aaypz; aayqa; aayqb; aayqc; aayqd; aayqe; aayqf; aayqg; aayqh; aayqi; aayqj; aayqk; aayql; aayqm; aayqn; aayqo; aayqp; aayqq; aayqr; aayqs; aayqt; aayqu; aayqv; aayqw; aayqx; aayqy; aayqz; aayra; aayrb; aayrc; aayrd; aayre; aayrf; aayrg; aayrh; aayri; aayrj; aayrk; aayrl; aayrm; aayrn; aayro; aayrp; aayrq; aayrr; aayrs; aayrt; aayru; aayrv; aayrw; aayrx; aayry; aayrz; aaysa; aaysb; aaysc; aaysd; aayse; aaysf; aaysg; aaysh; aaysi; aaysj; aaysk; aaysl; aaysm; aaysn; aayso; aaysp; aaysq; aaysr; aayss; aayst; aaysu; aaysv; aaysw; aaysx; aaysy; aaysz; aayta; aaytb; aaytc; aaytd; aayte; aaytf; aaytg; aayth; aayti; aaytj; aaytk; aaytl; aaytm; aaytn; aayto; aaytp; aaytq; aaytr; aayts; aaytt; aaytu; aaytv; aaytw; aaytx; aayty; aaytz; aayua; aayub; aayuc; aayud; aayue; aayuf; aayug; aayuh; aayui; aayuj; aayuk; aayul; aayum; aayun; aayuo; aayup; aayuq; aayur; aayus; aayut; aayuu; aayuv; aayuw; aayux; aayuy; aayuz; aayva; aayvb; aayvc; aayvd; aayve; aayvf; aayvg; aayvh; aayvi; aayvj; aayvk; aayvl; aayvm; aayvn; aayvo; aayvp; aayvq; aayvr; aayvs; aayvt; aayvu; aayvv; aayvw; aayvx; aayvy; aayvz; aaywa; aaywb; aaywc; aaywd; aaywe; aaywf; aaywg; aaywh; aaywi; aaywj; aaywk; aaywl; aaywm; aaywn; aaywo; aaywp; aaywq; aaywr; aayws; aaywt; aaywu; aaywv; aayww; aaywx; aaywy; aaywz; aayxa; aayxb; aayxc; aayxd; aayxe; aayxf; aayxg; aayxh; aayxi; aayxj; aayxk; aayxl; aayxm; aayxn; aayxo; aayxp; aayxq; aayxr; aayxs; aayxt; aayxu; aayxv; aayxw; aayxx; aayxy; aayxz; aayya; aayyb; aayyc; aayyd; aayye; aayyf; aayyg; aayyh; aayyi; aayyj; aayyk; aayyl; aayym; aayyn; aayyo; aayyp; aayyq; aayyr; aayys; aayyt; aayyu; aayyv; aayyw; aayyx; aayyy; aayyz; aayza; aayzb; aayzc; aayzd; aayze; aayzf; aayzg; aayzh; aayzi; aayzj; aayzk; aayzl; aayzm; aayzn; aayzo; aayzp; aayzq; aayzr; aayzs; aayzt; aayzu; aayzv; aayzw; aayzx; aayzy; aayzz; aazaa; aazab; aazac; aazad; aazae; aazaf; aazag; aazah; aazai; aazaj; aazak; aazal; aazam; aazan; aazao; aazap; aazaq; aazar; aazas; aazat; aazau; aazav; aazaw; aazax; aazay; aazaz; aazba; aazbb; aazbc; aazbd; aazbe; aazbf; aazbg; aazbh; aazbi; aazbj; aazbk; aazbl; aazbm; aazbn; aazbo; aazbp; aazbq; aazbr; aazbs; aazbt; aazbu; aazbv; aazbw; aazbx; aazby; aazbz; aazca; aazcb; aazcc; aazcd; aazce; aazcf; aazcg; aazch; aazci; aazcj; aazck; aazcl; aazcm; aazcn; aazco; aazcp; aazcq; aazcr; aazcs; aazct; aazcu; aazcv; aazcw; aazcx; aazcy; aazcz; aazda; aazdb; aazdc; aazdd; aazde; aazdf; aazdg; aazdh; aazdi; aazdj; aazdk; aazdl; aazdm; aazdn; aazdo; aazdp; aazdq; aazdr; aazds; aazdt; aazdu; aazdv; aazdw; aazdx; aazdy; aazdz; aazea; aazeb; aazec; aazed; aazee; aazef; aazeg; aazeh; aazei; aazej; aazek; aazel; aazem; aazen; aazeo; aazep; aazeq; aazer; aazes; aazet; aazeu; aazev; aazew; aazex; aazey; aazez; aazfa; aazfb; aazfc; aazfd; aazfe; aazff; aazfg; aazfh; aazfi; aazfj; aazfk; aazfl; aazfm; aazfn; aazfo; aazfp; aazfq; aazfr; aazfs; aazft; aazfu; aazfv; aazfw; aazfx; aazfy; aazfz; aazga; aazgb; aazgc; aazgd; aazge; aazgf; aazgg; aazgh; aazgi; aazgj; aazgk; aazgl; aazgm; aazgn; aazgo; aazgp; aazgq; aazgr; aazgs; aazgt; aazgu; aazgv; aazgw; aazgx; aazgy; aazgz; aazha; aazhb; aazhc; aazhd; aazhe; aazhf; aazhg; aazhh; aazhi; aazhj; aazhk; aazhl; aazhm; aazhn; aazho; aazhp; aazhq; aazhr; aazhs; aazht; aazhu; aazhv; aazhw; aazhx; aazhy; aazhz; aazia; aazib; aazic; aazid; aazie; aazif; aazig; aazih; aazii; aazij; aazik; aazil; aazim; aazin; aazio; aazip; aaziq; aazir; aazis; aazit; aaziu; aaziv; aaziw; aazix; aaziy; aaziz; aazja; aazjb; aazjc; aazjd; aazje; aazjf; aazjg; aazjh; aazji; aazjj; aazjk; aazjl; aazjm; aazjn; aazjo; aazjp; aazjq; aazjr; aazjs; aazjt; aazju; aazjv; aazjw; aazjx; aazjy; aazjz; aazka; aazkb; aazkc; aazkd; aazke; aazkf; aazkg; aazkh; aazki; aazkj; aazkk; aazkl; aazkm; aazkn; aazko; aazkp; aazkq; aazkr; aazks; aazkt; aazku; aazkv; aazkw; aazkx; aazky; aazkz; aazla; aazlb; aazlc; aazld; aazle; aazlf; aazlg; aazlh; aazli; aazlj; aazlk; aazll; aazlm; aazln; aazlo; aazlp; aazlq; aazlr; aazls; aazlt; aazlu; aazlv; aazlw; aazlx; aazly; aazlz; aazma; aazmb; aazmc; aazmd; aazme; aazmf; aazmg; aazmh; aazmi; aazmj; aazmk; aazml; aazmm; aazmn; aazmo; aazmp; aazmq; aazmr; aazms; aazmt; aazmu; aazmv; aazmw; aazmx; aazmy; aazmz; aazna; aaznb; aaznc; aaznd; aazne; aaznf; aazng; aaznh; aazni; aaznj; aaznk; aaznl; aaznm; aaznn; aazno; aaznp; aaznq; aaznr; aazns; aaznt; aaznu; aaznv; aaznw; aaznx; aazny; aaznz; aazoa; aazob; aazoc; aazod; aazoe; aazof; aazog; aazoh; aazoi; aazoj; aazok; aazol; aazom; aazon; aazoo; aazop; aazoq; aazor; aazos; aazot; aazou; aazov; aazow; aazox; aazoy; aazoz; aazpa; aazpb; aazpc; aazpd; aazpe; aazpf; aazpg; aazph; aazpi; aazpj; aazpk; aazpl; aazpm; aazpn; aazpo; aazpp; aazpq; aazpr; aazps; aazpt; aazpu; aazpv; aazpw; aazpx; aazpy; aazpz; aazqa; aazqb; aazqc; aazqd; aazqe; aazqf; aazqg; aazqh; aazqi; aazqj; aazqk; aazql; aazqm; aazqn; aazqo; aazqp; aazqq; aazqr; aazqs; aazqt; aazqu; aazqv; aazqw; aazqx; aazqy; aazqz; aazra; aazrb; aazrc; aazrd; aazre; aazrf; aazrg; aazrh; aazri; aazrj; aazrk; aazrl; aazrm; aazrn; aazro; aazrp; aazrq; aazrr; aazrs; aazrt; aazru; aazrv; aazrw; aazrx; aazry; aazrz; aazsa; aazsb; aazsc; aazsd; aazse; aazsf; aazsg; aazsh; aazsi; aazsj; aazsk; aazsl; aazsm; aazsn; aazso; aazsp; aazsq; aazsr; aazss; aazst; aazsu; aazsv; aazsw; aazsx; aazsy; aazsz; aazta; aaztb; aaztc; aaztd; aazte; aaztf; aaztg; aazth; aazti; aaztj; aaztk; aaztl; aaztm; aaztn; aazto; aaztp; aaztq; aaztr; aazts; aaztt; aaztu; aaztv; aaztw; aaztx; aazty; aaztz; aazua; aazub; aazuc; aazud; aazue; aazuf; aazug; aazuh; aazui; aazuj; aazuk; aazul; aazum; aazun; aazuo; aazup; aazuq; aazur; aazus; aazut; aazuu; aazuv; aazuw; aazux; aazuy; aazuz; aazva; aazvb; aazvc; aazvd; aazve; aazvf; aazvg; aazvh; aazvi; aazvj; aazvk; aazvl; aazvm; aazvn; aazvo; aazvp; aazvq; aazvr; aazvs; aazvt; aazvu; aazvv; aazvw; aazvx; aazvy; aazvz; aazwa; aazwb; aazwc; aazwd; aazwe; aazwf; aazwg; aazwh; aazwi; aazwj; aazwk; aazwl; aazwm; aazwn; aazwo; aazwp; aazwq; aazwr; aazws; aazwt; aazwu; aazwv; aazww; aazwx; aazwy; aazwz; aazxa; aazxb; aazxc; aazxd; aazxe; aazxf; aazxg; aazxh; aazxi; aazxj; aazxk; aazxl; aazxm; aazxn; aazxo; aazxp; aazxq; aazxr; aazxs; aazxt; aazxu; aazxv; aazxw; aazxx; aazxy; aazxz; aazya; aazyb; aazyc; aazyd; aazye; aazyf; aazyg; aazyh; aazyi; aazyj; aazyk; aazyl; aazym; aazyn; aazyo; aazyp; aazyq; aazyr; aazys; aazyt; aazyu; aazyv; aazyw; aazyx; aazyy; aazyz; aazza; aazzb; aazzc; aazzd; aazze; aazzf; aazzg; aazzh; aazzi; aazzj; aazzk; aazzl; aazzm; aazzn; aazzo; aazzp; aazzq; aazzr; aazzs; aazzt; aazzu; aazzv; aazzw; aazzx; aazzy; aazzz; abaaa; abaab; abaac; abaad; abaae; abaaf; abaag; abaah; abaai; abaaj; abaak; abaal; abaam; abaan; abaao; abaap; abaaq; abaar; abaas; abaat; abaau; abaav; abaaw; abaax; abaay; abaaz; ababa; ababb; ababc; ababd; ababe; ababf; ababg; ababh; ababi; ababj; ababk; ababl; ababm; ababn; ababo; ababp; ababq; ababr; ababs; ababt; ababu; ababv; ababw; ababx; ababy; ababz; abaca; abacb; abacc; abacd; abace; abacf; abacg; abach; abaci; abacj; aback; abacl; abacm; abacn; abaco; abacp; abacq; abacr; abacs; abact; abacu; abacv; abacw; abacx; abacy; abacz; abada; abadb; abadc; abadd; abade; abadf; abadg; abadh; abadi; abadj; abadk; abadl; abadm; abadn; abado; abadp; abadq; abadr; abads; abadt; abadu; abadv; abadw; abadx; abady; abadz; abaea; abaeb; abaec; abaed; abaee; abaef; abaeg; abaeh; abaei; abaej; abaek; abael; abaem; abaen; abaeo; abaep; abaeq; abaer; abaes; abaet; abaeu; abaev; abaew; abaex; abaey; abaez; abafa; abafb; abafc; abafd; abafe; abaff; abafg; abafh; abafi; abafj; abafk; abafl; abafm; abafn; abafo; abafp; abafq; abafr; abafs; abaft; abafu; abafv; abafw; abafx; abafy; abafz; abaga; abagb; abagc; abagd; abage; abagf; abagg; abagh; abagi; abagj; abagk; abagl; abagm; abagn; abago; abagp; abagq; abagr; abags; abagt; abagu; abagv; abagw; abagx; abagy; abagz; abaha; abahb; abahc; abahd; abahe; abahf; abahg; abahh; abahi; abahj; abahk; abahl; abahm; abahn; abaho; abahp; abahq; abahr; abahs; abaht; abahu; abahv; abahw; abahx; abahy; abahz; abaia; abaib; abaic; abaid; abaie; abaif; abaig; abaih; abaii; abaij; abaik; abail; abaim; abain; abaio; abaip; abaiq; abair; abais; abait; abaiu; abaiv; abaiw; abaix; abaiy; abaiz; abaja; abajb; abajc; abajd; abaje; abajf; abajg; abajh; abaji; abajj; abajk; abajl; abajm; abajn; abajo; abajp; abajq; abajr; abajs; abajt; abaju; abajv; abajw; abajx; abajy; abajz; abaka; abakb; abakc; abakd; abake; abakf; abakg; abakh; abaki; abakj; abakk; abakl; abakm; abakn; abako; abakp; abakq; abakr; abaks; abakt; abaku; abakv; abakw; abakx; abaky; abakz; abala; abalb; abalc; abald; abale; abalf; abalg; abalh; abali; abalj; abalk; aball; abalm; abaln; abalo; abalp; abalq; abalr; abals; abalt; abalu; abalv; abalw; abalx; abaly; abalz; abama; abamb; abamc; abamd; abame; abamf; abamg; abamh; abami; abamj; abamk; abaml; abamm; abamn; abamo; abamp; abamq; abamr; abams; abamt; abamu; abamv; abamw; abamx; abamy; abamz; abana; abanb; abanc; aband; abane; abanf; abang; abanh; abani; abanj; abank; abanl; abanm; abann; abano; abanp; abanq; abanr; abans; abant; abanu; abanv; abanw; abanx; abany; abanz; abaoa; abaob; abaoc; abaod; abaoe; abaof; abaog; abaoh; abaoi; abaoj; abaok; abaol; abaom; abaon; abaoo; abaop; abaoq; abaor; abaos; abaot; abaou; abaov; abaow; abaox; abaoy; abaoz; abapa; abapb; abapc; abapd; abape; abapf; abapg; abaph; abapi; abapj; abapk; abapl; abapm; abapn; abapo; abapp; abapq; abapr; abaps; abapt; abapu; abapv; abapw; abapx; abapy; abapz; abaqa; abaqb; abaqc; abaqd; abaqe; abaqf; abaqg; abaqh; abaqi; abaqj; abaqk; abaql; abaqm; abaqn; abaqo; abaqp; abaqq; abaqr; abaqs; abaqt; abaqu; abaqv; abaqw; abaqx; abaqy; abaqz; abara; abarb; abarc; abard; abare; abarf; abarg; abarh; abari; abarj; abark; abarl; abarm; abarn; abaro; abarp; abarq; abarr; abars; abart; abaru; abarv; abarw; abarx; abary; abarz; abasa; abasb; abasc; abasd; abase; abasf; abasg; abash; abasi; abasj; abask; abasl; abasm; abasn; abaso; abasp; abasq; abasr; abass; abast; abasu; abasv; abasw; abasx; abasy; abasz; abata; abatb; abatc; abatd; abate; abatf; abatg; abath; abati; abatj; abatk; abatl; abatm; abatn; abato; abatp; abatq; abatr; abats; abatt; abatu; abatv; abatw; abatx; abaty; abatz; abaua; abaub; abauc; abaud; abaue; abauf; abaug; abauh; abaui; abauj; abauk; abaul; abaum; abaun; abauo; abaup; abauq; abaur; abaus; abaut; abauu; abauv; abauw; abaux; abauy; abauz; abava; abavb; abavc; abavd; abave; abavf; abavg; abavh; abavi; abavj; abavk; abavl; abavm; abavn; abavo; abavp; abavq; abavr; abavs; abavt; abavu; abavv; abavw; abavx; abavy; abavz; abawa; abawb; abawc; abawd; abawe; abawf; abawg; abawh; abawi; abawj; abawk; abawl; abawm; abawn; abawo; abawp; abawq; abawr; abaws; abawt; abawu; abawv; abaww; abawx; abawy; abawz; abaxa; abaxb; abaxc; abaxd; abaxe; abaxf; abaxg; abaxh; abaxi; abaxj; abaxk; abaxl; abaxm; abaxn; abaxo; abaxp; abaxq; abaxr; abaxs; abaxt; abaxu; abaxv; abaxw; abaxx; abaxy; abaxz; abaya; abayb; abayc; abayd; abaye; abayf; abayg; abayh; abayi; abayj; abayk; abayl; abaym; abayn; abayo; abayp; abayq; abayr; abays; abayt; abayu; abayv; abayw; abayx; abayy; abayz; abaza; abazb; abazc; abazd; abaze; abazf; abazg; abazh; abazi; abazj; abazk; abazl; abazm; abazn; abazo; abazp; abazq; abazr; abazs; abazt; abazu; abazv; abazw; abazx; abazy; abazz; abbaa; abbab; abbac; abbad; abbae; abbaf; abbag; abbah; abbai; abbaj; abbak; abbal; abbam; abban; abbao; abbap; abbaq; abbar; abbas; abbat; abbau; abbav; abbaw; abbax; abbay; abbaz; abbba; abbbb; abbbc; abbbd; abbbe; abbbf; abbbg; abbbh; abbbi; abbbj; abbbk; abbbl; abbbm; abbbn; abbbo; abbbp; abbbq; abbbr; abbbs; abbbt; abbbu; abbbv; abbbw; abbbx; abbby; abbbz; abbca; abbcb; abbcc; abbcd; abbce; abbcf; abbcg; abbch; abbci; abbcj; abbck; abbcl; abbcm; abbcn; abbco; abbcp; abbcq; abbcr; abbcs; abbct; abbcu; abbcv; abbcw; abbcx; abbcy; abbcz; abbda; abbdb; abbdc; abbdd; abbde; abbdf; abbdg; abbdh; abbdi; abbdj; abbdk; abbdl; abbdm; abbdn; abbdo; abbdp; abbdq; abbdr; abbds; abbdt; abbdu; abbdv; abbdw; abbdx; abbdy; abbdz; abbea; abbeb; abbec; abbed; abbee; abbef; abbeg; abbeh; abbei; abbej; abbek; abbel; abbem; abben; abbeo; abbep; abbeq; abber; abbes; abbet; abbeu; abbev; abbew; abbex; abbey; abbez; abbfa; abbfb; abbfc; abbfd; abbfe; abbff; abbfg; abbfh; abbfi; abbfj; abbfk; abbfl; abbfm; abbfn; abbfo; abbfp; abbfq; abbfr; abbfs; abbft; abbfu; abbfv; abbfw; abbfx; abbfy; abbfz; abbga; abbgb; abbgc; abbgd; abbge; abbgf; abbgg; abbgh; abbgi; abbgj; abbgk; abbgl; abbgm; abbgn; abbgo; abbgp; abbgq; abbgr; abbgs; abbgt; abbgu; abbgv; abbgw; abbgx; abbgy; abbgz; abbha; abbhb; abbhc; abbhd; abbhe; abbhf; abbhg; abbhh; abbhi; abbhj; abbhk; abbhl; abbhm; abbhn; abbho; abbhp; abbhq; abbhr; abbhs; abbht; abbhu; abbhv; abbhw; abbhx; abbhy; abbhz; abbia; abbib; abbic; abbid; abbie; abbif; abbig; abbih; abbii; abbij; abbik; abbil; abbim; abbin; abbio; abbip; abbiq; abbir; abbis; abbit; abbiu; abbiv; abbiw; abbix; abbiy; abbiz; abbja; abbjb; abbjc; abbjd; abbje; abbjf; abbjg; abbjh; abbji; abbjj; abbjk; abbjl; abbjm; abbjn; abbjo; abbjp; abbjq; abbjr; abbjs; abbjt; abbju; abbjv; abbjw; abbjx; abbjy; abbjz; abbka; abbkb; abbkc; abbkd; abbke; abbkf; abbkg; abbkh; abbki; abbkj; abbkk; abbkl; abbkm; abbkn; abbko; abbkp; abbkq; abbkr; abbks; abbkt; abbku; abbkv; abbkw; abbkx; abbky; abbkz; abbla; abblb; abblc; abbld; abble; abblf; abblg; abblh; abbli; abblj; abblk; abbll; abblm; abbln; abblo; abblp; abblq; abblr; abbls; abblt; abblu; abblv; abblw; abblx; abbly; abblz; abbma; abbmb; abbmc; abbmd; abbme; abbmf; abbmg; abbmh; abbmi; abbmj; abbmk; abbml; abbmm; abbmn; abbmo; abbmp; abbmq; abbmr; abbms; abbmt; abbmu; abbmv; abbmw; abbmx; abbmy; abbmz; abbna; abbnb; abbnc; abbnd; abbne; abbnf; abbng; abbnh; abbni; abbnj; abbnk; abbnl; abbnm; abbnn; abbno; abbnp; abbnq; abbnr; abbns; abbnt; abbnu; abbnv; abbnw; abbnx; abbny; abbnz; abboa; abbob; abboc; abbod; abboe; abbof; abbog; abboh; abboi; abboj; abbok; abbol; abbom; abbon; abboo; abbop; abboq; abbor; abbos; abbot; abbou; abbov; abbow; abbox; abboy; abboz; abbpa; abbpb; abbpc; abbpd; abbpe; abbpf; abbpg; abbph; abbpi; abbpj; abbpk; abbpl; abbpm; abbpn; abbpo; abbpp; abbpq; abbpr; abbps; abbpt; abbpu; abbpv; abbpw; abbpx; abbpy; abbpz; abbqa; abbqb; abbqc; abbqd; abbqe; abbqf; abbqg; abbqh; abbqi; abbqj; abbqk; abbql; abbqm; abbqn; abbqo; abbqp; abbqq; abbqr; abbqs; abbqt; abbqu; abbqv; abbqw; abbqx; abbqy; abbqz; abbra; abbrb; abbrc; abbrd; abbre; abbrf; abbrg; abbrh; abbri; abbrj; abbrk; abbrl; abbrm; abbrn; abbro; abbrp; abbrq; abbrr; abbrs; abbrt; abbru; abbrv; abbrw; abbrx; abbry; abbrz; abbsa; abbsb; abbsc; abbsd; abbse; abbsf; abbsg; abbsh; abbsi; abbsj; abbsk; abbsl; abbsm; abbsn; abbso; abbsp; abbsq; abbsr; abbss; abbst; abbsu; abbsv; abbsw; abbsx; abbsy; abbsz; abbta; abbtb; abbtc; abbtd; abbte; abbtf; abbtg; abbth; abbti; abbtj; abbtk; abbtl; abbtm; abbtn; abbto; abbtp; abbtq; abbtr; abbts; abbtt; abbtu; abbtv; abbtw; abbtx; abbty; abbtz; abbua; abbub; abbuc; abbud; abbue; abbuf; abbug; abbuh; abbui; abbuj; abbuk; abbul; abbum; abbun; abbuo; abbup; abbuq; abbur; abbus; abbut; abbuu; abbuv; abbuw; abbux; abbuy; abbuz; abbva; abbvb; abbvc; abbvd; abbve; abbvf; abbvg; abbvh; abbvi; abbvj; abbvk; abbvl; abbvm; abbvn; abbvo; abbvp; abbvq; abbvr; abbvs; abbvt; abbvu; abbvv; abbvw; abbvx; abbvy; abbvz; abbwa; abbwb; abbwc; abbwd; abbwe; abbwf; abbwg; abbwh; abbwi; abbwj; abbwk; abbwl; abbwm; abbwn; abbwo; abbwp; abbwq; abbwr; abbws; abbwt; abbwu; abbwv; abbww; abbwx; abbwy; abbwz; abbxa; abbxb; abbxc; abbxd; abbxe; abbxf; abbxg; abbxh; abbxi; abbxj; abbxk; abbxl; abbxm; abbxn; abbxo; abbxp; abbxq; abbxr; abbxs; abbxt; abbxu; abbxv; abbxw; abbxx; abbxy; abbxz; abbya; abbyb; abbyc; abbyd; abbye; abbyf; abbyg; abbyh; abbyi; abbyj; abbyk; abbyl; abbym; abbyn; abbyo; abbyp; abbyq; abbyr; abbys; abbyt; abbyu; abbyv; abbyw; abbyx; abbyy; abbyz; abbza; abbzb; abbzc; abbzd; abbze; abbzf; abbzg; abbzh; abbzi; abbzj; abbzk; abbzl; abbzm; abbzn; abbzo; abbzp; abbzq; abbzr; abbzs; abbzt; abbzu; abbzv; abbzw; abbzx; abbzy; abbzz; abcaa; abcab; abcac; abcad; abcae; abcaf; abcag; abcah; abcai; abcaj; abcak; abcal; abcam; abcan; abcao; abcap; abcaq; abcar; abcas; abcat; abcau; abcav; abcaw; abcax; abcay; abcaz; abcba; abcbb; abcbc; abcbd; abcbe; abcbf; abcbg; abcbh; abcbi; abcbj; abcbk; abcbl; abcbm; abcbn; abcbo; abcbp; abcbq; abcbr; abcbs; abcbt; abcbu; abcbv; abcbw; abcbx; abcby; abcbz; abcca; abccb; abccc; abccd; abcce; abccf; abccg; abcch; abcci; abccj; abcck; abccl; abccm; abccn; abcco; abccp; abccq; abccr; abccs; abcct; abccu; abccv; abccw; abccx; abccy; abccz; abcda; abcdb; abcdc; abcdd; abcde; abcdf; abcdg; abcdh; abcdi; abcdj; abcdk; abcdl; abcdm; abcdn; abcdo; abcdp; abcdq; abcdr; abcds; abcdt; abcdu; abcdv; abcdw; abcdx; abcdy; abcdz; abcea; abceb; abcec; abced; abcee; abcef; abceg; abceh; abcei; abcej; abcek; abcel; abcem; abcen; abceo; abcep; abceq; abcer; abces; abcet; abceu; abcev; abcew; abcex; abcey; abcez; abcfa; abcfb; abcfc; abcfd; abcfe; abcff; abcfg; abcfh; abcfi; abcfj; abcfk; abcfl; abcfm; abcfn; abcfo; abcfp; abcfq; abcfr; abcfs; abcft; abcfu; abcfv; abcfw; abcfx; abcfy; abcfz; abcga; abcgb; abcgc; abcgd; abcge; abcgf; abcgg; abcgh; abcgi; abcgj; abcgk; abcgl; abcgm; abcgn; abcgo; abcgp; abcgq; abcgr; abcgs; abcgt; abcgu; abcgv; abcgw; abcgx; abcgy; abcgz; abcha; abchb; abchc; abchd; abche; abchf; abchg; abchh; abchi; abchj; abchk; abchl; abchm; abchn; abcho; abchp; abchq; abchr; abchs; abcht; abchu; abchv; abchw; abchx; abchy; abchz; abcia; abcib; abcic; abcid; abcie; abcif; abcig; abcih; abcii; abcij; abcik; abcil; abcim; abcin; abcio; abcip; abciq; abcir; abcis; abcit; abciu; abciv; abciw; abcix; abciy; abciz; abcja; abcjb; abcjc; abcjd; abcje; abcjf; abcjg; abcjh; abcji; abcjj; abcjk; abcjl; abcjm; abcjn; abcjo; abcjp; abcjq; abcjr; abcjs; abcjt; abcju; abcjv; abcjw; abcjx; abcjy; abcjz; abcka; abckb; abckc; abckd; abcke; abckf; abckg; abckh; abcki; abckj; abckk; abckl; abckm; abckn; abcko; abckp; abckq; abckr; abcks; abckt; abcku; abckv; abckw; abckx; abcky; abckz; abcla; abclb; abclc; abcld; abcle; abclf; abclg; abclh; abcli; abclj; abclk; abcll; abclm; abcln; abclo; abclp; abclq; abclr; abcls; abclt; abclu; abclv; abclw; abclx; abcly; abclz; abcma; abcmb; abcmc; abcmd; abcme; abcmf; abcmg; abcmh; abcmi; abcmj; abcmk; abcml; abcmm; abcmn; abcmo; abcmp; abcmq; abcmr; abcms; abcmt; abcmu; abcmv; abcmw; abcmx; abcmy; abcmz; abcna; abcnb; abcnc; abcnd; abcne; abcnf; abcng; abcnh; abcni; abcnj; abcnk; abcnl; abcnm; abcnn; abcno; abcnp; abcnq; abcnr; abcns; abcnt; abcnu; abcnv; abcnw; abcnx; abcny; abcnz; abcoa; abcob; abcoc; abcod; abcoe; abcof; abcog; abcoh; abcoi; abcoj; abcok; abcol; abcom; abcon; abcoo; abcop; abcoq; abcor; abcos; abcot; abcou; abcov; abcow; abcox; abcoy; abcoz; abcpa; abcpb; abcpc; abcpd; abcpe; abcpf; abcpg; abcph; abcpi; abcpj; abcpk; abcpl; abcpm; abcpn; abcpo; abcpp; abcpq; abcpr; abcps; abcpt; abcpu; abcpv; abcpw; abcpx; abcpy; abcpz; abcqa; abcqb; abcqc; abcqd; abcqe; abcqf; abcqg; abcqh; abcqi; abcqj; abcqk; abcql; abcqm; abcqn; abcqo; abcqp; abcqq; abcqr; abcqs; abcqt; abcqu; abcqv; abcqw; abcqx; abcqy; abcqz; abcra; abcrb; abcrc; abcrd; abcre; abcrf; abcrg; abcrh; abcri; abcrj; abcrk; abcrl; abcrm; abcrn; abcro; abcrp; abcrq; abcrr; abcrs; abcrt; abcru; abcrv; abcrw; abcrx; abcry; abcrz; abcsa; abcsb; abcsc; abcsd; abcse; abcsf; abcsg; abcsh; abcsi; abcsj; abcsk; abcsl; abcsm; abcsn; abcso; abcsp; abcsq; abcsr; abcss; abcst; abcsu; abcsv; abcsw; abcsx; abcsy; abcsz; abcta; abctb; abctc; abctd; abcte; abctf; abctg; abcth; abcti; abctj; abctk; abctl; abctm; abctn; abcto; abctp; abctq; abctr; abcts; abctt; abctu; abctv; abctw; abctx; abcty; abctz; abcua; abcub; abcuc; abcud; abcue; abcuf; abcug; abcuh; abcui; abcuj; abcuk; abcul; abcum; abcun; abcuo; abcup; abcuq; abcur; abcus; abcut; abcuu; abcuv; abcuw; abcux; abcuy; abcuz; abcva; abcvb; abcvc; abcvd; abcve; abcvf; abcvg; abcvh; abcvi; abcvj; abcvk; abcvl; abcvm; abcvn; abcvo; abcvp; abcvq; abcvr; abcvs; abcvt; abcvu; abcvv; abcvw; abcvx; abcvy; abcvz; abcwa; abcwb; abcwc; abcwd; abcwe; abcwf; abcwg; abcwh; abcwi; abcwj; abcwk; abcwl; abcwm; abcwn; abcwo; abcwp; abcwq; abcwr; abcws; abcwt; abcwu; abcwv; abcww; abcwx; abcwy; abcwz; abcxa; abcxb; abcxc; abcxd; abcxe; abcxf; abcxg; abcxh; abcxi; abcxj; abcxk; abcxl; abcxm; abcxn; abcxo; abcxp; abcxq; abcxr; abcxs; abcxt; abcxu; abcxv; abcxw; abcxx; abcxy; abcxz; abcya; abcyb; abcyc; abcyd; abcye; abcyf; abcyg; abcyh; abcyi; abcyj; abcyk; abcyl; abcym; abcyn; abcyo; abcyp; abcyq; abcyr; abcys; abcyt; abcyu; abcyv; abcyw; abcyx; abcyy; abcyz; abcza; abczb; abczc; abczd; abcze; abczf; abczg; abczh; abczi; abczj; abczk; abczl; abczm; abczn; abczo; abczp; abczq; abczr; abczs; abczt; abczu; abczv; abczw; abczx; abczy; abczz; abdaa; abdab; abdac; abdad; abdae; abdaf; abdag; abdah; abdai; abdaj; abdak; abdal; abdam; abdan; abdao; abdap; abdaq; abdar; abdas; abdat; abdau; abdav; abdaw; abdax; abday; abdaz; abdba; abdbb; abdbc; abdbd; abdbe; abdbf; abdbg; abdbh; abdbi; abdbj; abdbk; abdbl; abdbm; abdbn; abdbo; abdbp; abdbq; abdbr; abdbs; abdbt; abdbu; abdbv; abdbw; abdbx; abdby; abdbz; abdca; abdcb; abdcc; abdcd; abdce; abdcf; abdcg; abdch; abdci; abdcj; abdck; abdcl; abdcm; abdcn; abdco; abdcp; abdcq; abdcr; abdcs; abdct; abdcu; abdcv; abdcw; abdcx; abdcy; abdcz; abdda; abddb; abddc; abddd; abdde; abddf; abddg; abddh; abddi; abddj; abddk; abddl; abddm; abddn; abddo; abddp; abddq; abddr; abdds; abddt; abddu; abddv; abddw; abddx; abddy; abddz; abdea; abdeb; abdec; abded; abdee; abdef; abdeg; abdeh; abdei; abdej; abdek; abdel; abdem; abden; abdeo; abdep; abdeq; abder; abdes; abdet; abdeu; abdev; abdew; abdex; abdey; abdez; abdfa; abdfb; abdfc; abdfd; abdfe; abdff; abdfg; abdfh; abdfi; abdfj; abdfk; abdfl; abdfm; abdfn; abdfo; abdfp; abdfq; abdfr; abdfs; abdft; abdfu; abdfv; abdfw; abdfx; abdfy; abdfz; abdga; abdgb; abdgc; abdgd; abdge; abdgf; abdgg; abdgh; abdgi; abdgj; abdgk; abdgl; abdgm; abdgn; abdgo; abdgp; abdgq; abdgr; abdgs; abdgt; abdgu; abdgv; abdgw; abdgx; abdgy; abdgz; abdha; abdhb; abdhc; abdhd; abdhe; abdhf; abdhg; abdhh; abdhi; abdhj; abdhk; abdhl; abdhm; abdhn; abdho; abdhp; abdhq; abdhr; abdhs; abdht; abdhu; abdhv; abdhw; abdhx; abdhy; abdhz; abdia; abdib; abdic; abdid; abdie; abdif; abdig; abdih; abdii; abdij; abdik; abdil; abdim; abdin; abdio; abdip; abdiq; abdir; abdis; abdit; abdiu; abdiv; abdiw; abdix; abdiy; abdiz; abdja; abdjb; abdjc; abdjd; abdje; abdjf; abdjg; abdjh; abdji; abdjj; abdjk; abdjl; abdjm; abdjn; abdjo; abdjp; abdjq; abdjr; abdjs; abdjt; abdju; abdjv; abdjw; abdjx; abdjy; abdjz; abdka; abdkb; abdkc; abdkd; abdke; abdkf; abdkg; abdkh; abdki; abdkj; abdkk; abdkl; abdkm; abdkn; abdko; abdkp; abdkq; abdkr; abdks; abdkt; abdku; abdkv; abdkw; abdkx; abdky; abdkz; abdla; abdlb; abdlc; abdld; abdle; abdlf; abdlg; abdlh; abdli; abdlj; abdlk; abdll; abdlm; abdln; abdlo; abdlp; abdlq; abdlr; abdls; abdlt; abdlu; abdlv; abdlw; abdlx; abdly; abdlz; abdma; abdmb; abdmc; abdmd; abdme; abdmf; abdmg; abdmh; abdmi; abdmj; abdmk; abdml; abdmm; abdmn; abdmo; abdmp; abdmq; abdmr; abdms; abdmt; abdmu; abdmv; abdmw; abdmx; abdmy; abdmz; abdna; abdnb; abdnc; abdnd; abdne; abdnf; abdng; abdnh; abdni; abdnj; abdnk; abdnl; abdnm; abdnn; abdno; abdnp; abdnq; abdnr; abdns; abdnt; abdnu; abdnv; abdnw; abdnx; abdny; abdnz; abdoa; abdob; abdoc; abdod; abdoe; abdof; abdog; abdoh; abdoi; abdoj; abdok; abdol; abdom; abdon; abdoo; abdop; abdoq; abdor; abdos; abdot; abdou; abdov; abdow; abdox; abdoy; abdoz; abdpa; abdpb; abdpc; abdpd; aljwf |]; mingw-ocaml/ocaml/camlp4/test/fixtures/macrotest.ml0000644000175000017500000000212712124403240022022 0ustar tootstootsDEFINE A = 42; DEFINE B = 51; IFDEF A THEN value a_should_be_present = B + 2; print_int (a_should_be_present + 1); ENDIF; print_int (a_should_be_present + 2); IFNDEF C THEN print_int (a_should_be_present + 3); ENDIF; IFNDEF C THEN print_int (a_should_be_present + 4); ELSE print_int (c_should_not_be_present + 1); ENDIF; IFDEF C THEN print_int (c_should_not_be_present + 2); ELSIF print_int (A * a_should_be_present + 5); ENDIF; IFDEF DNE THEN print_int (c_should_not_be_present + 2); ELSIF print_int (A * a_should_be_present + 5); ENDIF; IFDEF OPT THEN print_int (c_should_not_be_present + 2); ELSIF print_int (A * a_should_be_present + 5); ENDIF; value e = IFDEF DNE THEN print_int (c_should_not_be_present + 2) ELSE print_int (A * a_should_be_present + 5) ENDIF; value f = fun _ -> IFDEF DNE THEN print_int (c_should_not_be_present + 2) ELSE print_int (A * a_should_be_present + 5) ENDIF; IFDEF A THEN DEFINE Z = "ok"; ELSE DEFINE Z = "ko"; ENDIF; Z; IFDEF DNE THEN DEFINE Z = "ko2"; ELSE DEFINE Z = "ok2"; ENDIF; Z; pouet; mingw-ocaml/ocaml/camlp4/test/fixtures/default_quotation.ml0000644000175000017500000000015412124403240023546 0ustar tootstoots#default_quotation "expr"; open Camlp4.PreCast; fun [ << $x$ - $y$ >> when x = y -> << 0 >> | e -> e ]; mingw-ocaml/ocaml/camlp4/test/fixtures/functor-perf3.ml0000644000175000017500000000135212124403240022515 0ustar tootstoots<% types, with_constrs, make, make2 = ARGV.map { |x| x.to_i } %> module type S = sig <%- for i in 0 .. types do -%> type t<%= i %> <%- end -%> end module Make (M : S) : S with type t0 = M.t0 <%- for i in 1 .. with_constrs do -%> and type t<%= i %> = M.t<%= i %> <%- end -%> = struct include M end module type S2 = sig module M : S end module Make2 (M2 : S2) : S2 with module M = M2.M = struct include M2 end module M = struct <%- for i in 0 .. types do -%> type t<%= i %> = int -> int -> int <%- end -%> end module M1 = Make <%- make.times do -%> (Make <%- end -%> (M)<%= ')' * make %> module M2 = struct module M = M1 end module X = Make2 <%- make2.times do -%> (Make2 <%- end -%> (M2)<%= ')' * make2 %> mingw-ocaml/ocaml/camlp4/test/fixtures/gram-tree2.ml0000644000175000017500000000113712124403240021766 0ustar tootstootsopen Camlp4.PreCast; module G = MakeGram Lexer; type t = [ A of t and t | B of string ]; value main = G.Entry.mk "main"; (* value rec length x acc = match x with [ A x y -> length x (length y acc) | B _ -> succ acc ]; *) value length _ _ = -1; EXTEND G GLOBAL: main; main: [ [ i = ident; x = SELF -> A (B i) x | i = ident -> B i ] ]; ident: [ [ `LIDENT s -> s ] ]; END; try let f = Sys.argv.(1) in Format.printf "%d@." (length (G.parse main (Loc.mk f) (Stream.of_channel (open_in f))) 0) with e -> Format.eprintf "error: %a@." Camlp4.ErrorHandler.print e; mingw-ocaml/ocaml/camlp4/test/fixtures/external.ml0000644000175000017500000000004512124403240021640 0ustar tootstootsexternal f : 'a -> 'b = "%identity"; mingw-ocaml/ocaml/camlp4/test/fixtures/pr4314gram4.ml0000644000175000017500000000133612124403240021712 0ustar tootstootsopen Camlp4.PreCast ; module G = Camlp4.PreCast.Gram ; value exp = G.Entry.mk "exp" ; value prog = G.Entry.mk "prog" ; EXTEND G exp: [ "apply" [ e1 = SELF; e2 = exp LEVEL "simple"; e3 = exp LEVEL "simple" -> let p = Loc.dump in let () = Format.eprintf "e1: %a,@.e2: %a,@.e3: %a,@._loc: %a@." p e1 p e2 p e3 p _loc in _loc ] | "simple" [ _ = LIDENT -> _loc ] ]; prog: [[ e = exp; `EOI -> e ]]; END ; (* and the following function: *) value parse_string entry s = try G.parse_string entry (Loc.mk "") s with [ Loc.Exc_located loc exn -> begin print_endline (Loc.to_string loc); print_endline (Printexc.to_string exn); failwith "Syntax Error" end ] ; parse_string prog "f x y"; mingw-ocaml/ocaml/camlp4/test/fixtures/fun.ml0000644000175000017500000000022512124403240020606 0ustar tootstootsvalue f = fun []; value f = fun [ [] -> fun [ 4 -> () ] ]; value f = fun []; value f = fun []; value f = fun []; value f = g x y; value f = (g x) y; mingw-ocaml/ocaml/camlp4/test/fixtures/where.r.ml0000644000175000017500000000002012124403240021361 0ustar tootstootsx where x = 42; mingw-ocaml/ocaml/camlp4/test/fixtures/backquoted_tuple.ml0000644000175000017500000000005512124403240023352 0ustar tootstootsEXTEND Gram abc: [ [ `(A,y) -> y ] ]; END; mingw-ocaml/ocaml/camlp4/test/fixtures/gen_map.ml0000644000175000017500000000020612124403240021423 0ustar tootstootstype t = A of int * t * t | B of int list | C of option t module Map = struct module T = Camlp4Filters.GenerateMap.Generated end mingw-ocaml/ocaml/camlp4/test/fixtures/operators.ml0000644000175000017500000000025612124403240022040 0ustar tootstootslet _ : int = 42 let (+) = M.(+) let (+) = M.(+) in 42 let (+) : int -> int -> int = (+) let (+) : int -> int -> int = (+) in 42 let None = None let None : int option = None mingw-ocaml/ocaml/camlp4/test/fixtures/gram-tree3.ml0000644000175000017500000000114712124403240021770 0ustar tootstootsopen Camlp4.PreCast; module G = MakeGram Lexer; type t = [ A of t and t | B of string ]; value main = G.Entry.mk "main"; (* value rec length x acc = match x with [ A x y -> length x (length y acc) | B _ -> succ acc ]; *) value length _ _ = -1; EXTEND G GLOBAL: main; main: [ RIGHTA [ x = SELF; y = SELF -> A x y | i = ident -> B i ] ]; ident: [ [ `LIDENT s -> s ] ]; END; try let f = Sys.argv.(1) in Format.printf "%d@." (length (G.parse main (Loc.mk f) (Stream.of_channel (open_in f))) 0) with e -> Format.eprintf "error: %a@." Camlp4.ErrorHandler.print e; mingw-ocaml/ocaml/camlp4/test/fixtures/macrotest2.ml0000644000175000017500000000023612124403240022103 0ustar tootstootsIFNDEF UNDEFINED_VARIABLE THEN DEFINE SQUARE (x) = x * x ;; DEFINE DOUBLE_SQUARE (x) = (SQUARE x) * 2 ;; END;; Printf.printf "%d\n" (DOUBLE_SQUARE(42)) ;; mingw-ocaml/ocaml/camlp4/test/fixtures/simplify.ml0000644000175000017500000000037712124403240021662 0ustar tootstootsopen Camlp4.PreCast let simplify = object inherit Ast.map as super method expr e = match super#expr e with | <:expr< $x$ + 0 >> | <:expr< 0 + $x$ >> -> x | x -> x end in AstFilters.register_str_item_filter simplify#str_item mingw-ocaml/ocaml/camlp4/test/fixtures/if.ml0000644000175000017500000000030212124403240020410 0ustar tootstootslet x = if x then a else b in x let x = if StringSet.mem "*" sections then a else b in x let x = if StringSet.mem "*" sections then fun _ -> true else fun x -> StringSet.mem x sections in x mingw-ocaml/ocaml/camlp4/test/fixtures/curry-constr.ml0000644000175000017500000000007612124403240022474 0ustar tootstootstype t = A of int type u = B of t let f = function B A x -> x mingw-ocaml/ocaml/camlp4/test/fixtures/pr4357sample2.ml0000644000175000017500000000014612124403240022250 0ustar tootstoots#default_quotation "sample";; let u = "Hello";; let s = <>;; let s = <:sample>;; print_string s mingw-ocaml/ocaml/camlp4/test/fixtures/pr4357.ml0000644000175000017500000000047412124403240020770 0ustar tootstootsopen Camlp4.PreCast let sample_expr _loc _loc_name s = Printf.eprintf "file=%s line=%d offset=%d bol=%d\n%!" (Loc.file_name _loc) (Loc.start_line _loc) (Loc.start_off _loc) (Loc.start_bol _loc); <:expr< $lid:s$ >> ;; Quotation.add "sample" Syntax.Quotation.DynAst.expr_tag sample_expr ;; mingw-ocaml/ocaml/camlp4/test/fixtures/private_row.ml0000644000175000017500000000110612124403240022356 0ustar tootstoots module type Ops = sig type expr val eval : expr -> int end ;; module Plus = struct type 'a expr0 = [`Num of int | `Plus of 'a * 'a ] module F(X : Ops with type expr = private ([> 'a expr0] as 'a)) = struct type expr = X.expr expr0 let eval : expr -> int = function `Num n -> n |`Plus(e1,e2) -> X.eval e1 + X.eval e2 end module rec L : (Ops with type expr = L.expr expr0) = F(L) end ;; open Printf ;; let _ = Printf.printf "%d\n%!" (Plus.L.eval (`Plus ((`Num 5),(`Num 2))));; mingw-ocaml/ocaml/camlp4/test/fixtures/idents20000644000175000017500000026241012124403240020765 0ustar tootstootsaaaa aaab aaac aaad aaae aaaf aaag aaah aaai aaaj aaak aaal aaam aaan aaao aaap aaaq aaar aaas aaat aaau aaav aaaw aaax aaay aaaz aaba aabb aabc aabd aabe aabf aabg aabh aabi aabj aabk aabl aabm aabn aabo aabp aabq aabr aabs aabt aabu aabv aabw aabx aaby aabz aaca aacb aacc aacd aace aacf aacg aach aaci aacj aack aacl aacm aacn aaco aacp aacq aacr aacs aact aacu aacv aacw aacx aacy aacz aada aadb aadc aadd aade aadf aadg aadh aadi aadj aadk aadl aadm aadn aado aadp aadq aadr aads aadt aadu aadv aadw aadx aady aadz aaea aaeb aaec aaed aaee aaef aaeg aaeh aaei aaej aaek aael aaem aaen aaeo aaep aaeq aaer aaes aaet aaeu aaev aaew aaex aaey aaez aafa aafb aafc aafd aafe aaff aafg aafh aafi aafj aafk aafl aafm aafn aafo aafp aafq aafr aafs aaft aafu aafv aafw aafx aafy aafz aaga aagb aagc aagd aage aagf aagg aagh aagi aagj aagk aagl aagm aagn aago aagp aagq aagr aags aagt aagu aagv aagw aagx aagy aagz aaha aahb aahc aahd aahe aahf aahg aahh aahi aahj aahk aahl aahm aahn aaho aahp aahq aahr aahs aaht aahu aahv aahw aahx aahy aahz aaia aaib aaic aaid aaie aaif aaig aaih aaii aaij aaik aail aaim aain aaio aaip aaiq aair aais aait aaiu aaiv aaiw aaix aaiy aaiz aaja aajb aajc aajd aaje aajf aajg aajh aaji aajj aajk aajl aajm aajn aajo aajp aajq aajr aajs aajt aaju aajv aajw aajx aajy aajz aaka aakb aakc aakd aake aakf aakg aakh aaki aakj aakk aakl aakm aakn aako aakp aakq aakr aaks aakt aaku aakv aakw aakx aaky aakz aala aalb aalc aald aale aalf aalg aalh aali aalj aalk aall aalm aaln aalo aalp aalq aalr aals aalt aalu aalv aalw aalx aaly aalz aama aamb aamc aamd aame aamf aamg aamh aami aamj aamk aaml aamm aamn aamo aamp aamq aamr aams aamt aamu aamv aamw aamx aamy aamz aana aanb aanc aand aane aanf aang aanh aani aanj aank aanl aanm aann aano aanp aanq aanr aans aant aanu aanv aanw aanx aany aanz aaoa aaob aaoc aaod aaoe aaof aaog aaoh aaoi aaoj aaok aaol aaom aaon aaoo aaop aaoq aaor aaos aaot aaou aaov aaow aaox aaoy aaoz aapa aapb aapc aapd aape aapf aapg aaph aapi aapj aapk aapl aapm aapn aapo aapp aapq aapr aaps aapt aapu aapv aapw aapx aapy aapz aaqa aaqb aaqc aaqd aaqe aaqf aaqg aaqh aaqi aaqj aaqk aaql aaqm aaqn aaqo aaqp aaqq aaqr aaqs aaqt aaqu aaqv aaqw aaqx aaqy aaqz aara aarb aarc aard aare aarf aarg aarh aari aarj aark aarl aarm aarn aaro aarp aarq aarr aars aart aaru aarv aarw aarx aary aarz aasa aasb aasc aasd aase aasf aasg aash aasi aasj aask aasl aasm aasn aaso aasp aasq aasr aass aast aasu aasv aasw aasx aasy aasz aata aatb aatc aatd aate aatf aatg aath aati aatj aatk aatl aatm aatn aato aatp aatq aatr aats aatt aatu aatv aatw aatx aaty aatz aaua aaub aauc aaud aaue aauf aaug aauh aaui aauj aauk aaul aaum aaun aauo aaup aauq aaur aaus aaut aauu aauv aauw aaux aauy aauz aava aavb aavc aavd aave aavf aavg aavh aavi aavj aavk aavl aavm aavn aavo aavp aavq aavr aavs aavt aavu aavv aavw aavx aavy aavz aawa aawb aawc aawd aawe aawf aawg aawh aawi aawj aawk aawl aawm aawn aawo aawp aawq aawr aaws aawt aawu aawv aaww aawx aawy aawz aaxa aaxb aaxc aaxd aaxe aaxf aaxg aaxh aaxi aaxj aaxk aaxl aaxm aaxn aaxo aaxp aaxq aaxr aaxs aaxt aaxu aaxv aaxw aaxx aaxy aaxz aaya aayb aayc aayd aaye aayf aayg aayh aayi aayj aayk aayl aaym aayn aayo aayp aayq aayr aays aayt aayu aayv aayw aayx aayy aayz aaza aazb aazc aazd aaze aazf aazg aazh aazi aazj aazk aazl aazm aazn aazo aazp aazq aazr aazs aazt aazu aazv aazw aazx aazy aazz abaa abab abac abad abae abaf abag abah abai abaj abak abal abam aban abao abap abaq abar abas abat abau abav abaw abax abay abaz abba abbb abbc abbd abbe abbf abbg abbh abbi abbj abbk abbl abbm abbn abbo abbp abbq abbr abbs abbt abbu abbv abbw abbx abby abbz abca abcb abcc abcd abce abcf abcg abch abci abcj abck abcl abcm abcn abco abcp abcq abcr abcs abct abcu abcv abcw abcx abcy abcz abda abdb abdc abdd abde abdf abdg abdh abdi abdj abdk abdl abdm abdn abdo abdp abdq abdr abds abdt abdu abdv abdw abdx abdy abdz abea abeb abec abed abee abef abeg abeh abei abej abek abel abem aben abeo abep abeq aber abes abet abeu abev abew abex abey abez abfa abfb abfc abfd abfe abff abfg abfh abfi abfj abfk abfl abfm abfn abfo abfp abfq abfr abfs abft abfu abfv abfw abfx abfy abfz abga abgb abgc abgd abge abgf abgg abgh abgi abgj abgk abgl abgm abgn abgo abgp abgq abgr abgs abgt abgu abgv abgw abgx abgy abgz abha abhb abhc abhd abhe abhf abhg abhh abhi abhj abhk abhl abhm abhn abho abhp abhq abhr abhs abht abhu abhv abhw abhx abhy abhz abia abib abic abid abie abif abig abih abii abij abik abil abim abin abio abip abiq abir abis abit abiu abiv abiw abix abiy abiz abja abjb abjc abjd abje abjf abjg abjh abji abjj abjk abjl abjm abjn abjo abjp abjq abjr abjs abjt abju abjv abjw abjx abjy abjz abka abkb abkc abkd abke abkf abkg abkh abki abkj abkk abkl abkm abkn abko abkp abkq abkr abks abkt abku abkv abkw abkx abky abkz abla ablb ablc abld able ablf ablg ablh abli ablj ablk abll ablm abln ablo ablp ablq ablr abls ablt ablu ablv ablw ablx ably ablz abma abmb abmc abmd abme abmf abmg abmh abmi abmj abmk abml abmm abmn abmo abmp abmq abmr abms abmt abmu abmv abmw abmx abmy abmz abna abnb abnc abnd abne abnf abng abnh abni abnj abnk abnl abnm abnn abno abnp abnq abnr abns abnt abnu abnv abnw abnx abny abnz aboa abob aboc abod aboe abof abog aboh aboi aboj abok abol abom abon aboo abop aboq abor abos abot abou abov abow abox aboy aboz abpa abpb abpc abpd abpe abpf abpg abph abpi abpj abpk abpl abpm abpn abpo abpp abpq abpr abps abpt abpu abpv abpw abpx abpy abpz abqa abqb abqc abqd abqe abqf abqg abqh abqi abqj abqk abql abqm abqn abqo abqp abqq abqr abqs abqt abqu abqv abqw abqx abqy abqz abra abrb abrc abrd abre abrf abrg abrh abri abrj abrk abrl abrm abrn abro abrp abrq abrr abrs abrt abru abrv abrw abrx abry abrz absa absb absc absd abse absf absg absh absi absj absk absl absm absn abso absp absq absr abss abst absu absv absw absx absy absz abta abtb abtc abtd abte abtf abtg abth abti abtj abtk abtl abtm abtn abto abtp abtq abtr abts abtt abtu abtv abtw abtx abty abtz abua abub abuc abud abue abuf abug abuh abui abuj abuk abul abum abun abuo abup abuq abur abus abut abuu abuv abuw abux abuy abuz abva abvb abvc abvd abve abvf abvg abvh abvi abvj abvk abvl abvm abvn abvo abvp abvq abvr abvs abvt abvu abvv abvw abvx abvy abvz abwa abwb abwc abwd abwe abwf abwg abwh abwi abwj abwk abwl abwm abwn abwo abwp abwq abwr abws abwt abwu abwv abww abwx abwy abwz abxa abxb abxc abxd abxe abxf abxg abxh abxi abxj abxk abxl abxm abxn abxo abxp abxq abxr abxs abxt abxu abxv abxw abxx abxy abxz abya abyb abyc abyd abye abyf abyg abyh abyi abyj abyk abyl abym abyn abyo abyp abyq abyr abys abyt abyu abyv abyw abyx abyy abyz abza abzb abzc abzd abze abzf abzg abzh abzi abzj abzk abzl abzm abzn abzo abzp abzq abzr abzs abzt abzu abzv abzw abzx abzy abzz acaa acab acac acad acae acaf acag acah acai acaj acak acal acam acan acao acap acaq acar acas acat acau acav acaw acax acay acaz acba acbb acbc acbd acbe acbf acbg acbh acbi acbj acbk acbl acbm acbn acbo acbp acbq acbr acbs acbt acbu acbv acbw acbx acby acbz acca accb accc accd acce accf accg acch acci accj acck accl accm accn acco accp accq accr accs acct accu accv accw accx accy accz acda acdb acdc acdd acde acdf acdg acdh acdi acdj acdk acdl acdm acdn acdo acdp acdq acdr acds acdt acdu acdv acdw acdx acdy acdz acea aceb acec aced acee acef aceg aceh acei acej acek acel acem acen aceo acep aceq acer aces acet aceu acev acew acex acey acez acfa acfb acfc acfd acfe acff acfg acfh acfi acfj acfk acfl acfm acfn acfo acfp acfq acfr acfs acft acfu acfv acfw acfx acfy acfz acga acgb acgc acgd acge acgf acgg acgh acgi acgj acgk acgl acgm acgn acgo acgp acgq acgr acgs acgt acgu acgv acgw acgx acgy acgz acha achb achc achd ache achf achg achh achi achj achk achl achm achn acho achp achq achr achs acht achu achv achw achx achy achz acia acib acic acid acie acif acig acih acii acij acik acil acim acin acio acip aciq acir acis acit aciu aciv aciw acix aciy aciz acja acjb acjc acjd acje acjf acjg acjh acji acjj acjk acjl acjm acjn acjo acjp acjq acjr acjs acjt acju acjv acjw acjx acjy acjz acka ackb ackc ackd acke ackf ackg ackh acki ackj ackk ackl ackm ackn acko ackp ackq ackr acks ackt acku ackv ackw ackx acky ackz acla aclb aclc acld acle aclf aclg aclh acli aclj aclk acll aclm acln aclo aclp aclq aclr acls aclt aclu aclv aclw aclx acly aclz acma acmb acmc acmd acme acmf acmg acmh acmi acmj acmk acml acmm acmn acmo acmp acmq acmr acms acmt acmu acmv acmw acmx acmy acmz acna acnb acnc acnd acne acnf acng acnh acni acnj acnk acnl acnm acnn acno acnp acnq acnr acns acnt acnu acnv acnw acnx acny acnz acoa acob acoc acod acoe acof acog acoh acoi acoj acok acol acom acon acoo acop acoq acor acos acot acou acov acow acox acoy acoz acpa acpb acpc acpd acpe acpf acpg acph acpi acpj acpk acpl acpm acpn acpo acpp acpq acpr acps acpt acpu acpv acpw acpx acpy acpz acqa acqb acqc acqd acqe acqf acqg acqh acqi acqj acqk acql acqm acqn acqo acqp acqq acqr acqs acqt acqu acqv acqw acqx acqy acqz acra acrb acrc acrd acre acrf acrg acrh acri acrj acrk acrl acrm acrn acro acrp acrq acrr acrs acrt acru acrv acrw acrx acry acrz acsa acsb acsc acsd acse acsf acsg acsh acsi acsj acsk acsl acsm acsn acso acsp acsq acsr acss acst acsu acsv acsw acsx acsy acsz acta actb actc actd acte actf actg acth acti actj actk actl actm actn acto actp actq actr acts actt actu actv actw actx acty actz acua acub acuc acud acue acuf acug acuh acui acuj acuk acul acum acun acuo acup acuq acur acus acut acuu acuv acuw acux acuy acuz acva acvb acvc acvd acve acvf acvg acvh acvi acvj acvk acvl acvm acvn acvo acvp acvq acvr acvs acvt acvu acvv acvw acvx acvy acvz acwa acwb acwc acwd acwe acwf acwg acwh acwi acwj acwk acwl acwm acwn acwo acwp acwq acwr acws acwt acwu acwv acww acwx acwy acwz acxa acxb acxc acxd acxe acxf acxg acxh acxi acxj acxk acxl acxm acxn acxo acxp acxq acxr acxs acxt acxu acxv acxw acxx acxy acxz acya acyb acyc acyd acye acyf acyg acyh acyi acyj acyk acyl acym acyn acyo acyp acyq acyr acys acyt acyu acyv acyw acyx acyy acyz acza aczb aczc aczd acze aczf aczg aczh aczi aczj aczk aczl aczm aczn aczo aczp aczq aczr aczs aczt aczu aczv aczw aczx aczy aczz adaa adab adac adad adae adaf adag adah adai adaj adak adal adam adan adao adap adaq adar adas adat adau adav adaw adax aday adaz adba adbb adbc adbd adbe adbf adbg adbh adbi adbj adbk adbl adbm adbn adbo adbp adbq adbr adbs adbt adbu adbv adbw adbx adby adbz adca adcb adcc adcd adce adcf adcg adch adci adcj adck adcl adcm adcn adco adcp adcq adcr adcs adct adcu adcv adcw adcx adcy adcz adda addb addc addd adde addf addg addh addi addj addk addl addm addn addo addp addq addr adds addt addu addv addw addx addy addz adea adeb adec aded adee adef adeg adeh adei adej adek adel adem aden adeo adep adeq ader ades adet adeu adev adew adex adey adez adfa adfb adfc adfd adfe adff adfg adfh adfi adfj adfk adfl adfm adfn adfo adfp adfq adfr adfs adft adfu adfv adfw adfx adfy adfz adga adgb adgc adgd adge adgf adgg adgh adgi adgj adgk adgl adgm adgn adgo adgp adgq adgr adgs adgt adgu adgv adgw adgx adgy adgz adha adhb adhc adhd adhe adhf adhg adhh adhi adhj adhk adhl adhm adhn adho adhp adhq adhr adhs adht adhu adhv adhw adhx adhy adhz adia adib adic adid adie adif adig adih adii adij adik adil adim adin adio adip adiq adir adis adit adiu adiv adiw adix adiy adiz adja adjb adjc adjd adje adjf adjg adjh adji adjj adjk adjl adjm adjn adjo adjp adjq adjr adjs adjt adju adjv adjw adjx adjy adjz adka adkb adkc adkd adke adkf adkg adkh adki adkj adkk adkl adkm adkn adko adkp adkq adkr adks adkt adku adkv adkw adkx adky adkz adla adlb adlc adld adle adlf adlg adlh adli adlj adlk adll adlm adln adlo adlp adlq adlr adls adlt adlu adlv adlw adlx adly adlz adma admb admc admd adme admf admg admh admi admj admk adml admm admn admo admp admq admr adms admt admu admv admw admx admy admz adna adnb adnc adnd adne adnf adng adnh adni adnj adnk adnl adnm adnn adno adnp adnq adnr adns adnt adnu adnv adnw adnx adny adnz adoa adob adoc adod adoe adof adog adoh adoi adoj adok adol adom adon adoo adop adoq ador ados adot adou adov adow adox adoy adoz adpa adpb adpc adpd adpe adpf adpg adph adpi adpj adpk adpl adpm adpn adpo adpp adpq adpr adps adpt adpu adpv adpw adpx adpy adpz adqa adqb adqc adqd adqe adqf adqg adqh adqi adqj adqk adql adqm adqn adqo adqp adqq adqr adqs adqt adqu adqv adqw adqx adqy adqz adra adrb adrc adrd adre adrf adrg adrh adri adrj adrk adrl adrm adrn adro adrp adrq adrr adrs adrt adru adrv adrw adrx adry adrz adsa adsb adsc adsd adse adsf adsg adsh adsi adsj adsk adsl adsm adsn adso adsp adsq adsr adss adst adsu adsv adsw adsx adsy adsz adta adtb adtc adtd adte adtf adtg adth adti adtj adtk adtl adtm adtn adto adtp adtq adtr adts adtt adtu adtv adtw adtx adty adtz adua adub aduc adud adue aduf adug aduh adui aduj aduk adul adum adun aduo adup aduq adur adus adut aduu aduv aduw adux aduy aduz adva advb advc advd adve advf advg advh advi advj advk advl advm advn advo advp advq advr advs advt advu advv advw advx advy advz adwa adwb adwc adwd adwe adwf adwg adwh adwi adwj adwk adwl adwm adwn adwo adwp adwq adwr adws adwt adwu adwv adww adwx adwy adwz adxa adxb adxc adxd adxe adxf adxg adxh adxi adxj adxk adxl adxm adxn adxo adxp adxq adxr adxs adxt adxu adxv adxw adxx adxy adxz adya adyb adyc adyd adye adyf adyg adyh adyi adyj adyk adyl adym adyn adyo adyp adyq adyr adys adyt adyu adyv adyw adyx adyy adyz adza adzb adzc adzd adze adzf adzg adzh adzi adzj adzk adzl adzm adzn adzo adzp adzq adzr adzs adzt adzu adzv adzw adzx adzy adzz aeaa aeab aeac aead aeae aeaf aeag aeah aeai aeaj aeak aeal aeam aean aeao aeap aeaq aear aeas aeat aeau aeav aeaw aeax aeay aeaz aeba aebb aebc aebd aebe aebf aebg aebh aebi aebj aebk aebl aebm aebn aebo aebp aebq aebr aebs aebt aebu aebv aebw aebx aeby aebz aeca aecb aecc aecd aece aecf aecg aech aeci aecj aeck aecl aecm aecn aeco aecp aecq aecr aecs aect aecu aecv aecw aecx aecy aecz aeda aedb aedc aedd aede aedf aedg aedh aedi aedj aedk aedl aedm aedn aedo aedp aedq aedr aeds aedt aedu aedv aedw aedx aedy aedz aeea aeeb aeec aeed aeee aeef aeeg aeeh aeei aeej aeek aeel aeem aeen aeeo aeep aeeq aeer aees aeet aeeu aeev aeew aeex aeey aeez aefa aefb aefc aefd aefe aeff aefg aefh aefi aefj aefk aefl aefm aefn aefo aefp aefq aefr aefs aeft aefu aefv aefw aefx aefy aefz aega aegb aegc aegd aege aegf aegg aegh aegi aegj aegk aegl aegm aegn aego aegp aegq aegr aegs aegt aegu aegv aegw aegx aegy aegz aeha aehb aehc aehd aehe aehf aehg aehh aehi aehj aehk aehl aehm aehn aeho aehp aehq aehr aehs aeht aehu aehv aehw aehx aehy aehz aeia aeib aeic aeid aeie aeif aeig aeih aeii aeij aeik aeil aeim aein aeio aeip aeiq aeir aeis aeit aeiu aeiv aeiw aeix aeiy aeiz aeja aejb aejc aejd aeje aejf aejg aejh aeji aejj aejk aejl aejm aejn aejo aejp aejq aejr aejs aejt aeju aejv aejw aejx aejy aejz aeka aekb aekc aekd aeke aekf aekg aekh aeki aekj aekk aekl aekm aekn aeko aekp aekq aekr aeks aekt aeku aekv aekw aekx aeky aekz aela aelb aelc aeld aele aelf aelg aelh aeli aelj aelk aell aelm aeln aelo aelp aelq aelr aels aelt aelu aelv aelw aelx aely aelz aema aemb aemc aemd aeme aemf aemg aemh aemi aemj aemk aeml aemm aemn aemo aemp aemq aemr aems aemt aemu aemv aemw aemx aemy aemz aena aenb aenc aend aene aenf aeng aenh aeni aenj aenk aenl aenm aenn aeno aenp aenq aenr aens aent aenu aenv aenw aenx aeny aenz aeoa aeob aeoc aeod aeoe aeof aeog aeoh aeoi aeoj aeok aeol aeom aeon aeoo aeop aeoq aeor aeos aeot aeou aeov aeow aeox aeoy aeoz aepa aepb aepc aepd aepe aepf aepg aeph aepi aepj aepk aepl aepm aepn aepo aepp aepq aepr aeps aept aepu aepv aepw aepx aepy aepz aeqa aeqb aeqc aeqd aeqe aeqf aeqg aeqh aeqi aeqj aeqk aeql aeqm aeqn aeqo aeqp aeqq aeqr aeqs aeqt aequ aeqv aeqw aeqx aeqy aeqz aera aerb aerc aerd aere aerf aerg aerh aeri aerj aerk aerl aerm aern aero aerp aerq aerr aers aert aeru aerv aerw aerx aery aerz aesa aesb aesc aesd aese aesf aesg aesh aesi aesj aesk aesl aesm aesn aeso aesp aesq aesr aess aest aesu aesv aesw aesx aesy aesz aeta aetb aetc aetd aete aetf aetg aeth aeti aetj aetk aetl aetm aetn aeto aetp aetq aetr aets aett aetu aetv aetw aetx aety aetz aeua aeub aeuc aeud aeue aeuf aeug aeuh aeui aeuj aeuk aeul aeum aeun aeuo aeup aeuq aeur aeus aeut aeuu aeuv aeuw aeux aeuy aeuz aeva aevb aevc aevd aeve aevf aevg aevh aevi aevj aevk aevl aevm aevn aevo aevp aevq aevr aevs aevt aevu aevv aevw aevx aevy aevz aewa aewb aewc aewd aewe aewf aewg aewh aewi aewj aewk aewl aewm aewn aewo aewp aewq aewr aews aewt aewu aewv aeww aewx aewy aewz aexa aexb aexc aexd aexe aexf aexg aexh aexi aexj aexk aexl aexm aexn aexo aexp aexq aexr aexs aext aexu aexv aexw aexx aexy aexz aeya aeyb aeyc aeyd aeye aeyf aeyg aeyh aeyi aeyj aeyk aeyl aeym aeyn aeyo aeyp aeyq aeyr aeys aeyt aeyu aeyv aeyw aeyx aeyy aeyz aeza aezb aezc aezd aeze aezf aezg aezh aezi aezj aezk aezl aezm aezn aezo aezp aezq aezr aezs aezt aezu aezv aezw aezx aezy aezz afaa afab afac afad afae afaf afag afah afai afaj afak afal afam afan afao afap afaq afar afas afat afau afav afaw afax afay afaz afba afbb afbc afbd afbe afbf afbg afbh afbi afbj afbk afbl afbm afbn afbo afbp afbq afbr afbs afbt afbu afbv afbw afbx afby afbz afca afcb afcc afcd afce afcf afcg afch afci afcj afck afcl afcm afcn afco afcp afcq afcr afcs afct afcu afcv afcw afcx afcy afcz afda afdb afdc afdd afde afdf afdg afdh afdi afdj afdk afdl afdm afdn afdo afdp afdq afdr afds afdt afdu afdv afdw afdx afdy afdz afea afeb afec afed afee afef afeg afeh afei afej afek afel afem afen afeo afep afeq afer afes afet afeu afev afew afex afey afez affa affb affc affd affe afff affg affh affi affj affk affl affm affn affo affp affq affr affs afft affu affv affw affx affy affz afga afgb afgc afgd afge afgf afgg afgh afgi afgj afgk afgl afgm afgn afgo afgp afgq afgr afgs afgt afgu afgv afgw afgx afgy afgz afha afhb afhc afhd afhe afhf afhg afhh afhi afhj afhk afhl afhm afhn afho afhp afhq afhr afhs afht afhu afhv afhw afhx afhy afhz afia afib afic afid afie afif afig afih afii afij afik afil afim afin afio afip afiq afir afis afit afiu afiv afiw afix afiy afiz afja afjb afjc afjd afje afjf afjg afjh afji afjj afjk afjl afjm afjn afjo afjp afjq afjr afjs afjt afju afjv afjw afjx afjy afjz afka afkb afkc afkd afke afkf afkg afkh afki afkj afkk afkl afkm afkn afko afkp afkq afkr afks afkt afku afkv afkw afkx afky afkz afla aflb aflc afld afle aflf aflg aflh afli aflj aflk afll aflm afln aflo aflp aflq aflr afls aflt aflu aflv aflw aflx afly aflz afma afmb afmc afmd afme afmf afmg afmh afmi afmj afmk afml afmm afmn afmo afmp afmq afmr afms afmt afmu afmv afmw afmx afmy afmz afna afnb afnc afnd afne afnf afng afnh afni afnj afnk afnl afnm afnn afno afnp afnq afnr afns afnt afnu afnv afnw afnx afny afnz afoa afob afoc afod afoe afof afog afoh afoi afoj afok afol afom afon afoo afop afoq afor afos afot afou afov afow afox afoy afoz afpa afpb afpc afpd afpe afpf afpg afph afpi afpj afpk afpl afpm afpn afpo afpp afpq afpr afps afpt afpu afpv afpw afpx afpy afpz afqa afqb afqc afqd afqe afqf afqg afqh afqi afqj afqk afql afqm afqn afqo afqp afqq afqr afqs afqt afqu afqv afqw afqx afqy afqz afra afrb afrc afrd afre afrf afrg afrh afri afrj afrk afrl afrm afrn afro afrp afrq afrr afrs afrt afru afrv afrw afrx afry afrz afsa afsb afsc afsd afse afsf afsg afsh afsi afsj afsk afsl afsm afsn afso afsp afsq afsr afss afst afsu afsv afsw afsx afsy afsz afta aftb aftc aftd afte aftf aftg afth afti aftj aftk aftl aftm aftn afto aftp aftq aftr afts aftt aftu aftv aftw aftx afty aftz afua afub afuc afud afue afuf afug afuh afui afuj afuk aful afum afun afuo afup afuq afur afus afut afuu afuv afuw afux afuy afuz afva afvb afvc afvd afve afvf afvg afvh afvi afvj afvk afvl afvm afvn afvo afvp afvq afvr afvs afvt afvu afvv afvw afvx afvy afvz afwa afwb afwc afwd afwe afwf afwg afwh afwi afwj afwk afwl afwm afwn afwo afwp afwq afwr afws afwt afwu afwv afww afwx afwy afwz afxa afxb afxc afxd afxe afxf afxg afxh afxi afxj afxk afxl afxm afxn afxo afxp afxq afxr afxs afxt afxu afxv afxw afxx afxy afxz afya afyb afyc afyd afye afyf afyg afyh afyi afyj afyk afyl afym afyn afyo afyp afyq afyr afys afyt afyu afyv afyw afyx afyy afyz afza afzb afzc afzd afze afzf afzg afzh afzi afzj afzk afzl afzm afzn afzo afzp afzq afzr afzs afzt afzu afzv afzw afzx afzy afzz agaa agab agac agad agae agaf agag agah agai agaj agak agal agam agan agao agap agaq agar agas agat agau agav agaw agax agay agaz agba agbb agbc agbd agbe agbf agbg agbh agbi agbj agbk agbl agbm agbn agbo agbp agbq agbr agbs agbt agbu agbv agbw agbx agby agbz agca agcb agcc agcd agce agcf agcg agch agci agcj agck agcl agcm agcn agco agcp agcq agcr agcs agct agcu agcv agcw agcx agcy agcz agda agdb agdc agdd agde agdf agdg agdh agdi agdj agdk agdl agdm agdn agdo agdp agdq agdr agds agdt agdu agdv agdw agdx agdy agdz agea ageb agec aged agee agef ageg ageh agei agej agek agel agem agen ageo agep ageq ager ages aget ageu agev agew agex agey agez agfa agfb agfc agfd agfe agff agfg agfh agfi agfj agfk agfl agfm agfn agfo agfp agfq agfr agfs agft agfu agfv agfw agfx agfy agfz agga aggb aggc aggd agge aggf aggg aggh aggi aggj aggk aggl aggm aggn aggo aggp aggq aggr aggs aggt aggu aggv aggw aggx aggy aggz agha aghb aghc aghd aghe aghf aghg aghh aghi aghj aghk aghl aghm aghn agho aghp aghq aghr aghs aght aghu aghv aghw aghx aghy aghz agia agib agic agid agie agif agig agih agii agij agik agil agim agin agio agip agiq agir agis agit agiu agiv agiw agix agiy agiz agja agjb agjc agjd agje agjf agjg agjh agji agjj agjk agjl agjm agjn agjo agjp agjq agjr agjs agjt agju agjv agjw agjx agjy agjz agka agkb agkc agkd agke agkf agkg agkh agki agkj agkk agkl agkm agkn agko agkp agkq agkr agks agkt agku agkv agkw agkx agky agkz agla aglb aglc agld agle aglf aglg aglh agli aglj aglk agll aglm agln aglo aglp aglq aglr agls aglt aglu aglv aglw aglx agly aglz agma agmb agmc agmd agme agmf agmg agmh agmi agmj agmk agml agmm agmn agmo agmp agmq agmr agms agmt agmu agmv agmw agmx agmy agmz agna agnb agnc agnd agne agnf agng agnh agni agnj agnk agnl agnm agnn agno agnp agnq agnr agns agnt agnu agnv agnw agnx agny agnz agoa agob agoc agod agoe agof agog agoh agoi agoj agok agol agom agon agoo agop agoq agor agos agot agou agov agow agox agoy agoz agpa agpb agpc agpd agpe agpf agpg agph agpi agpj agpk agpl agpm agpn agpo agpp agpq agpr agps agpt agpu agpv agpw agpx agpy agpz agqa agqb agqc agqd agqe agqf agqg agqh agqi agqj agqk agql agqm agqn agqo agqp agqq agqr agqs agqt agqu agqv agqw agqx agqy agqz agra agrb agrc agrd agre agrf agrg agrh agri agrj agrk agrl agrm agrn agro agrp agrq agrr agrs agrt agru agrv agrw agrx agry agrz agsa agsb agsc agsd agse agsf agsg agsh agsi agsj agsk agsl agsm agsn agso agsp agsq agsr agss agst agsu agsv agsw agsx agsy agsz agta agtb agtc agtd agte agtf agtg agth agti agtj agtk agtl agtm agtn agto agtp agtq agtr agts agtt agtu agtv agtw agtx agty agtz agua agub aguc agud ague aguf agug aguh agui aguj aguk agul agum agun aguo agup aguq agur agus agut aguu aguv aguw agux aguy aguz agva agvb agvc agvd agve agvf agvg agvh agvi agvj agvk agvl agvm agvn agvo agvp agvq agvr agvs agvt agvu agvv agvw agvx agvy agvz agwa agwb agwc agwd agwe agwf agwg agwh agwi agwj agwk agwl agwm agwn agwo agwp agwq agwr agws agwt agwu agwv agww agwx agwy agwz agxa agxb agxc agxd agxe agxf agxg agxh agxi agxj agxk agxl agxm agxn agxo agxp agxq agxr agxs agxt agxu agxv agxw agxx agxy agxz agya agyb agyc agyd agye agyf agyg agyh agyi agyj agyk agyl agym agyn agyo agyp agyq agyr agys agyt agyu agyv agyw agyx agyy agyz agza agzb agzc agzd agze agzf agzg agzh agzi agzj agzk agzl agzm agzn agzo agzp agzq agzr agzs agzt agzu agzv agzw agzx agzy agzz ahaa ahab ahac ahad ahae ahaf ahag ahah ahai ahaj ahak ahal aham ahan ahao ahap ahaq ahar ahas ahat ahau ahav ahaw ahax ahay ahaz ahba ahbb ahbc ahbd ahbe ahbf ahbg ahbh ahbi ahbj ahbk ahbl ahbm ahbn ahbo ahbp ahbq ahbr ahbs ahbt ahbu ahbv ahbw ahbx ahby ahbz ahca ahcb ahcc ahcd ahce ahcf ahcg ahch ahci ahcj ahck ahcl ahcm ahcn ahco ahcp ahcq ahcr ahcs ahct ahcu ahcv ahcw ahcx ahcy ahcz ahda ahdb ahdc ahdd ahde ahdf ahdg ahdh ahdi ahdj ahdk ahdl ahdm ahdn ahdo ahdp ahdq ahdr ahds ahdt ahdu ahdv ahdw ahdx ahdy ahdz ahea aheb ahec ahed ahee ahef aheg aheh ahei ahej ahek ahel ahem ahen aheo ahep aheq aher ahes ahet aheu ahev ahew ahex ahey ahez ahfa ahfb ahfc ahfd ahfe ahff ahfg ahfh ahfi ahfj ahfk ahfl ahfm ahfn ahfo ahfp ahfq ahfr ahfs ahft ahfu ahfv ahfw ahfx ahfy ahfz ahga ahgb ahgc ahgd ahge ahgf ahgg ahgh ahgi ahgj ahgk ahgl ahgm ahgn ahgo ahgp ahgq ahgr ahgs ahgt ahgu ahgv ahgw ahgx ahgy ahgz ahha ahhb ahhc ahhd ahhe ahhf ahhg ahhh ahhi ahhj ahhk ahhl ahhm ahhn ahho ahhp ahhq ahhr ahhs ahht ahhu ahhv ahhw ahhx ahhy ahhz ahia ahib ahic ahid ahie ahif ahig ahih ahii ahij ahik ahil ahim ahin ahio ahip ahiq ahir ahis ahit ahiu ahiv ahiw ahix ahiy ahiz ahja ahjb ahjc ahjd ahje ahjf ahjg ahjh ahji ahjj ahjk ahjl ahjm ahjn ahjo ahjp ahjq ahjr ahjs ahjt ahju ahjv ahjw ahjx ahjy ahjz ahka ahkb ahkc ahkd ahke ahkf ahkg ahkh ahki ahkj ahkk ahkl ahkm ahkn ahko ahkp ahkq ahkr ahks ahkt ahku ahkv ahkw ahkx ahky ahkz ahla ahlb ahlc ahld ahle ahlf ahlg ahlh ahli ahlj ahlk ahll ahlm ahln ahlo ahlp ahlq ahlr ahls ahlt ahlu ahlv ahlw ahlx ahly ahlz ahma ahmb ahmc ahmd ahme ahmf ahmg ahmh ahmi ahmj ahmk ahml ahmm ahmn ahmo ahmp ahmq ahmr ahms ahmt ahmu ahmv ahmw ahmx ahmy ahmz ahna ahnb ahnc ahnd ahne ahnf ahng ahnh ahni ahnj ahnk ahnl ahnm ahnn ahno ahnp ahnq ahnr ahns ahnt ahnu ahnv ahnw ahnx ahny ahnz ahoa ahob ahoc ahod ahoe ahof ahog ahoh ahoi ahoj ahok ahol ahom ahon ahoo ahop ahoq ahor ahos ahot ahou ahov ahow ahox ahoy ahoz ahpa ahpb ahpc ahpd ahpe ahpf ahpg ahph ahpi ahpj ahpk ahpl ahpm ahpn ahpo ahpp ahpq ahpr ahps ahpt ahpu ahpv ahpw ahpx ahpy ahpz ahqa ahqb ahqc ahqd ahqe ahqf ahqg ahqh ahqi ahqj ahqk ahql ahqm ahqn ahqo ahqp ahqq ahqr ahqs ahqt ahqu ahqv ahqw ahqx ahqy ahqz ahra ahrb ahrc ahrd ahre ahrf ahrg ahrh ahri ahrj ahrk ahrl ahrm ahrn ahro ahrp ahrq ahrr ahrs ahrt ahru ahrv ahrw ahrx ahry ahrz ahsa ahsb ahsc ahsd ahse ahsf ahsg ahsh ahsi ahsj ahsk ahsl ahsm ahsn ahso ahsp ahsq ahsr ahss ahst ahsu ahsv ahsw ahsx ahsy ahsz ahta ahtb ahtc ahtd ahte ahtf ahtg ahth ahti ahtj ahtk ahtl ahtm ahtn ahto ahtp ahtq ahtr ahts ahtt ahtu ahtv ahtw ahtx ahty ahtz ahua ahub ahuc ahud ahue ahuf ahug ahuh ahui ahuj ahuk ahul ahum ahun ahuo ahup ahuq ahur ahus ahut ahuu ahuv ahuw ahux ahuy ahuz ahva ahvb ahvc ahvd ahve ahvf ahvg ahvh ahvi ahvj ahvk ahvl ahvm ahvn ahvo ahvp ahvq ahvr ahvs ahvt ahvu ahvv ahvw ahvx ahvy ahvz ahwa ahwb ahwc ahwd ahwe ahwf ahwg ahwh ahwi ahwj ahwk ahwl ahwm ahwn ahwo ahwp ahwq ahwr ahws ahwt ahwu ahwv ahww ahwx ahwy ahwz ahxa ahxb ahxc ahxd ahxe ahxf ahxg ahxh ahxi ahxj ahxk ahxl ahxm ahxn ahxo ahxp ahxq ahxr ahxs ahxt ahxu ahxv ahxw ahxx ahxy ahxz ahya ahyb ahyc ahyd ahye ahyf ahyg ahyh ahyi ahyj ahyk ahyl ahym ahyn ahyo ahyp ahyq ahyr ahys ahyt ahyu ahyv ahyw ahyx ahyy ahyz ahza ahzb ahzc ahzd ahze ahzf ahzg ahzh ahzi ahzj ahzk ahzl ahzm ahzn ahzo ahzp ahzq ahzr ahzs ahzt ahzu ahzv ahzw ahzx ahzy ahzz aiaa aiab aiac aiad aiae aiaf aiag aiah aiai aiaj aiak aial aiam aian aiao aiap aiaq aiar aias aiat aiau aiav aiaw aiax aiay aiaz aiba aibb aibc aibd aibe aibf aibg aibh aibi aibj aibk aibl aibm aibn aibo aibp aibq aibr aibs aibt aibu aibv aibw aibx aiby aibz aica aicb aicc aicd aice aicf aicg aich aici aicj aick aicl aicm aicn aico aicp aicq aicr aics aict aicu aicv aicw aicx aicy aicz aida aidb aidc aidd aide aidf aidg aidh aidi aidj aidk aidl aidm aidn aido aidp aidq aidr aids aidt aidu aidv aidw aidx aidy aidz aiea aieb aiec aied aiee aief aieg aieh aiei aiej aiek aiel aiem aien aieo aiep aieq aier aies aiet aieu aiev aiew aiex aiey aiez aifa aifb aifc aifd aife aiff aifg aifh aifi aifj aifk aifl aifm aifn aifo aifp aifq aifr aifs aift aifu aifv aifw aifx aify aifz aiga aigb aigc aigd aige aigf aigg aigh aigi aigj aigk aigl aigm aign aigo aigp aigq aigr aigs aigt aigu aigv aigw aigx aigy aigz aiha aihb aihc aihd aihe aihf aihg aihh aihi aihj aihk aihl aihm aihn aiho aihp aihq aihr aihs aiht aihu aihv aihw aihx aihy aihz aiia aiib aiic aiid aiie aiif aiig aiih aiii aiij aiik aiil aiim aiin aiio aiip aiiq aiir aiis aiit aiiu aiiv aiiw aiix aiiy aiiz aija aijb aijc aijd aije aijf aijg aijh aiji aijj aijk aijl aijm aijn aijo aijp aijq aijr aijs aijt aiju aijv aijw aijx aijy aijz aika aikb aikc aikd aike aikf aikg aikh aiki aikj aikk aikl aikm aikn aiko aikp aikq aikr aiks aikt aiku aikv aikw aikx aiky aikz aila ailb ailc aild aile ailf ailg ailh aili ailj ailk aill ailm ailn ailo ailp ailq ailr ails ailt ailu ailv ailw ailx aily ailz aima aimb aimc aimd aime aimf aimg aimh aimi aimj aimk aiml aimm aimn aimo aimp aimq aimr aims aimt aimu aimv aimw aimx aimy aimz aina ainb ainc aind aine ainf aing ainh aini ainj aink ainl ainm ainn aino ainp ainq ainr ains aint ainu ainv ainw ainx ainy ainz aioa aiob aioc aiod aioe aiof aiog aioh aioi aioj aiok aiol aiom aion aioo aiop aioq aior aios aiot aiou aiov aiow aiox aioy aioz aipa aipb aipc aipd aipe aipf aipg aiph aipi aipj aipk aipl aipm aipn aipo aipp aipq aipr aips aipt aipu aipv aipw aipx aipy aipz aiqa aiqb aiqc aiqd aiqe aiqf aiqg aiqh aiqi aiqj aiqk aiql aiqm aiqn aiqo aiqp aiqq aiqr aiqs aiqt aiqu aiqv aiqw aiqx aiqy aiqz aira airb airc aird aire airf airg airh airi airj airk airl airm airn airo airp airq airr airs airt airu airv airw airx airy airz aisa aisb aisc aisd aise aisf aisg aish aisi aisj aisk aisl aism aisn aiso aisp aisq aisr aiss aist aisu aisv aisw aisx aisy aisz aita aitb aitc aitd aite aitf aitg aith aiti aitj aitk aitl aitm aitn aito aitp aitq aitr aits aitt aitu aitv aitw aitx aity aitz aiua aiub aiuc aiud aiue aiuf aiug aiuh aiui aiuj aiuk aiul aium aiun aiuo aiup aiuq aiur aius aiut aiuu aiuv aiuw aiux aiuy aiuz aiva aivb aivc aivd aive aivf aivg aivh aivi aivj aivk aivl aivm aivn aivo aivp aivq aivr aivs aivt aivu aivv aivw aivx aivy aivz aiwa aiwb aiwc aiwd aiwe aiwf aiwg aiwh aiwi aiwj aiwk aiwl aiwm aiwn aiwo aiwp aiwq aiwr aiws aiwt aiwu aiwv aiww aiwx aiwy aiwz aixa aixb aixc aixd aixe aixf aixg aixh aixi aixj aixk aixl aixm aixn aixo aixp aixq aixr aixs aixt aixu aixv aixw aixx aixy aixz aiya aiyb aiyc aiyd aiye aiyf aiyg aiyh aiyi aiyj aiyk aiyl aiym aiyn aiyo aiyp aiyq aiyr aiys aiyt aiyu aiyv aiyw aiyx aiyy aiyz aiza aizb aizc aizd aize aizf aizg aizh aizi aizj aizk aizl aizm aizn aizo aizp aizq aizr aizs aizt aizu aizv aizw aizx aizy aizz ajaa ajab ajac ajad ajae ajaf ajag ajah ajai ajaj ajak ajal ajam ajan ajao ajap ajaq ajar ajas ajat ajau ajav ajaw ajax ajay ajaz ajba ajbb ajbc ajbd ajbe ajbf ajbg ajbh ajbi ajbj ajbk ajbl ajbm ajbn ajbo ajbp ajbq ajbr ajbs ajbt ajbu ajbv ajbw ajbx ajby ajbz ajca ajcb ajcc ajcd ajce ajcf ajcg ajch ajci ajcj ajck ajcl ajcm ajcn ajco ajcp ajcq ajcr ajcs ajct ajcu ajcv ajcw ajcx ajcy ajcz ajda ajdb ajdc ajdd ajde ajdf ajdg ajdh ajdi ajdj ajdk ajdl ajdm ajdn ajdo ajdp ajdq ajdr ajds ajdt ajdu ajdv ajdw ajdx ajdy ajdz ajea ajeb ajec ajed ajee ajef ajeg ajeh ajei ajej ajek ajel ajem ajen ajeo ajep ajeq ajer ajes ajet ajeu ajev ajew ajex ajey ajez ajfa ajfb ajfc ajfd ajfe ajff ajfg ajfh ajfi ajfj ajfk ajfl ajfm ajfn ajfo ajfp ajfq ajfr ajfs ajft ajfu ajfv ajfw ajfx ajfy ajfz ajga ajgb ajgc ajgd ajge ajgf ajgg ajgh ajgi ajgj ajgk ajgl ajgm ajgn ajgo ajgp ajgq ajgr ajgs ajgt ajgu ajgv ajgw ajgx ajgy ajgz ajha ajhb ajhc ajhd ajhe ajhf ajhg ajhh ajhi ajhj ajhk ajhl ajhm ajhn ajho ajhp ajhq ajhr ajhs ajht ajhu ajhv ajhw ajhx ajhy ajhz ajia ajib ajic ajid ajie ajif ajig ajih ajii ajij ajik ajil ajim ajin ajio ajip ajiq ajir ajis ajit ajiu ajiv ajiw ajix ajiy ajiz ajja ajjb ajjc ajjd ajje ajjf ajjg ajjh ajji ajjj ajjk ajjl ajjm ajjn ajjo ajjp ajjq ajjr ajjs ajjt ajju ajjv ajjw ajjx ajjy ajjz ajka ajkb ajkc ajkd ajke ajkf ajkg ajkh ajki ajkj ajkk ajkl ajkm ajkn ajko ajkp ajkq ajkr ajks ajkt ajku ajkv ajkw ajkx ajky ajkz ajla ajlb ajlc ajld ajle ajlf ajlg ajlh ajli ajlj ajlk ajll ajlm ajln ajlo ajlp ajlq ajlr ajls ajlt ajlu ajlv ajlw ajlx ajly ajlz ajma ajmb ajmc ajmd ajme ajmf ajmg ajmh ajmi ajmj ajmk ajml ajmm ajmn ajmo ajmp ajmq ajmr ajms ajmt ajmu ajmv ajmw ajmx ajmy ajmz ajna ajnb ajnc ajnd ajne ajnf ajng ajnh ajni ajnj ajnk ajnl ajnm ajnn ajno ajnp ajnq ajnr ajns ajnt ajnu ajnv ajnw ajnx ajny ajnz ajoa ajob ajoc ajod ajoe ajof ajog ajoh ajoi ajoj ajok ajol ajom ajon ajoo ajop ajoq ajor ajos ajot ajou ajov ajow ajox ajoy ajoz ajpa ajpb ajpc ajpd ajpe ajpf ajpg ajph ajpi ajpj ajpk ajpl ajpm ajpn ajpo ajpp ajpq ajpr ajps ajpt ajpu ajpv ajpw ajpx ajpy ajpz ajqa ajqb ajqc ajqd ajqe ajqf ajqg ajqh ajqi ajqj ajqk ajql ajqm ajqn ajqo ajqp ajqq ajqr ajqs ajqt ajqu ajqv ajqw ajqx ajqy ajqz ajra ajrb ajrc ajrd ajre ajrf ajrg ajrh ajri ajrj ajrk ajrl ajrm ajrn ajro ajrp ajrq ajrr ajrs ajrt ajru ajrv ajrw ajrx ajry ajrz ajsa ajsb ajsc ajsd ajse ajsf ajsg ajsh ajsi ajsj ajsk ajsl ajsm ajsn ajso ajsp ajsq ajsr ajss ajst ajsu ajsv ajsw ajsx ajsy ajsz ajta ajtb ajtc ajtd ajte ajtf ajtg ajth ajti ajtj ajtk ajtl ajtm ajtn ajto ajtp ajtq ajtr ajts ajtt ajtu ajtv ajtw ajtx ajty ajtz ajua ajub ajuc ajud ajue ajuf ajug ajuh ajui ajuj ajuk ajul ajum ajun ajuo ajup ajuq ajur ajus ajut ajuu ajuv ajuw ajux ajuy ajuz ajva ajvb ajvc ajvd ajve ajvf ajvg ajvh ajvi ajvj ajvk ajvl ajvm ajvn ajvo ajvp ajvq ajvr ajvs ajvt ajvu ajvv ajvw ajvx ajvy ajvz ajwa ajwb ajwc ajwd ajwe ajwf ajwg ajwh ajwi ajwj ajwk ajwl ajwm ajwn ajwo ajwp ajwq ajwr ajws ajwt ajwu ajwv ajww ajwx ajwy ajwz ajxa ajxb ajxc ajxd ajxe ajxf ajxg ajxh ajxi ajxj ajxk ajxl ajxm ajxn ajxo ajxp ajxq ajxr ajxs ajxt ajxu ajxv ajxw ajxx ajxy ajxz ajya ajyb ajyc ajyd ajye ajyf ajyg ajyh ajyi ajyj ajyk ajyl ajym ajyn ajyo ajyp ajyq ajyr ajys ajyt ajyu ajyv ajyw ajyx ajyy ajyz ajza ajzb ajzc ajzd ajze ajzf ajzg ajzh ajzi ajzj ajzk ajzl ajzm ajzn ajzo ajzp ajzq ajzr ajzs ajzt ajzu ajzv ajzw ajzx ajzy ajzz akaa akab akac akad akae akaf akag akah akai akaj akak akal akam akan akao akap akaq akar akas akat akau akav akaw akax akay akaz akba akbb akbc akbd akbe akbf akbg akbh akbi akbj akbk akbl akbm akbn akbo akbp akbq akbr akbs akbt akbu akbv akbw akbx akby akbz akca akcb akcc akcd akce akcf akcg akch akci akcj akck akcl akcm akcn akco akcp akcq akcr akcs akct akcu akcv akcw akcx akcy akcz akda akdb akdc akdd akde akdf akdg akdh akdi akdj akdk akdl akdm akdn akdo akdp akdq akdr akds akdt akdu akdv akdw akdx akdy akdz akea akeb akec aked akee akef akeg akeh akei akej akek akel akem aken akeo akep akeq aker akes aket akeu akev akew akex akey akez akfa akfb akfc akfd akfe akff akfg akfh akfi akfj akfk akfl akfm akfn akfo akfp akfq akfr akfs akft akfu akfv akfw akfx akfy akfz akga akgb akgc akgd akge akgf akgg akgh akgi akgj akgk akgl akgm akgn akgo akgp akgq akgr akgs akgt akgu akgv akgw akgx akgy akgz akha akhb akhc akhd akhe akhf akhg akhh akhi akhj akhk akhl akhm akhn akho akhp akhq akhr akhs akht akhu akhv akhw akhx akhy akhz akia akib akic akid akie akif akig akih akii akij akik akil akim akin akio akip akiq akir akis akit akiu akiv akiw akix akiy akiz akja akjb akjc akjd akje akjf akjg akjh akji akjj akjk akjl akjm akjn akjo akjp akjq akjr akjs akjt akju akjv akjw akjx akjy akjz akka akkb akkc akkd akke akkf akkg akkh akki akkj akkk akkl akkm akkn akko akkp akkq akkr akks akkt akku akkv akkw akkx akky akkz akla aklb aklc akld akle aklf aklg aklh akli aklj aklk akll aklm akln aklo aklp aklq aklr akls aklt aklu aklv aklw aklx akly aklz akma akmb akmc akmd akme akmf akmg akmh akmi akmj akmk akml akmm akmn akmo akmp akmq akmr akms akmt akmu akmv akmw akmx akmy akmz akna aknb aknc aknd akne aknf akng aknh akni aknj aknk aknl aknm aknn akno aknp aknq aknr akns aknt aknu aknv aknw aknx akny aknz akoa akob akoc akod akoe akof akog akoh akoi akoj akok akol akom akon akoo akop akoq akor akos akot akou akov akow akox akoy akoz akpa akpb akpc akpd akpe akpf akpg akph akpi akpj akpk akpl akpm akpn akpo akpp akpq akpr akps akpt akpu akpv akpw akpx akpy akpz akqa akqb akqc akqd akqe akqf akqg akqh akqi akqj akqk akql akqm akqn akqo akqp akqq akqr akqs akqt akqu akqv akqw akqx akqy akqz akra akrb akrc akrd akre akrf akrg akrh akri akrj akrk akrl akrm akrn akro akrp akrq akrr akrs akrt akru akrv akrw akrx akry akrz aksa aksb aksc aksd akse aksf aksg aksh aksi aksj aksk aksl aksm aksn akso aksp aksq aksr akss akst aksu aksv aksw aksx aksy aksz akta aktb aktc aktd akte aktf aktg akth akti aktj aktk aktl aktm aktn akto aktp aktq aktr akts aktt aktu aktv aktw aktx akty aktz akua akub akuc akud akue akuf akug akuh akui akuj akuk akul akum akun akuo akup akuq akur akus akut akuu akuv akuw akux akuy akuz akva akvb akvc akvd akve akvf akvg akvh akvi akvj akvk akvl akvm akvn akvo akvp akvq akvr akvs akvt akvu akvv akvw akvx akvy akvz akwa akwb akwc akwd akwe akwf akwg akwh akwi akwj akwk akwl akwm akwn akwo akwp akwq akwr akws akwt akwu akwv akww akwx akwy akwz akxa akxb akxc akxd akxe akxf akxg akxh akxi akxj akxk akxl akxm akxn akxo akxp akxq akxr akxs akxt akxu akxv akxw akxx akxy akxz akya akyb akyc akyd akye akyf akyg akyh akyi akyj akyk akyl akym akyn akyo akyp akyq akyr akys akyt akyu akyv akyw akyx akyy akyz akza akzb akzc akzd akze akzf akzg akzh akzi akzj akzk akzl akzm akzn akzo akzp akzq akzr akzs akzt akzu akzv akzw akzx akzy akzz alaa alab alac alad alae alaf alag alah alai alaj alak alal alam alan alao alap alaq alar alas alat alau alav alaw alax alay alaz alba albb albc albd albe albf albg albh albi albj albk albl albm albn albo albp albq albr albs albt albu albv albw albx alby albz alca alcb alcc alcd alce alcf alcg alch alci alcj alck alcl alcm alcn alco alcp alcq alcr alcs alct alcu alcv alcw alcx alcy alcz alda aldb aldc aldd alde aldf aldg aldh aldi aldj aldk aldl aldm aldn aldo aldp aldq aldr alds aldt aldu aldv aldw aldx aldy aldz alea aleb alec aled alee alef aleg aleh alei alej alek alel alem alen aleo alep aleq aler ales alet aleu alev alew alex aley alez alfa alfb alfc alfd alfe alff alfg alfh alfi alfj alfk alfl alfm alfn alfo alfp alfq alfr alfs alft alfu alfv alfw alfx alfy alfz alga algb algc algd alge algf algg algh algi algj algk algl algm algn algo algp algq algr algs algt algu algv algw algx algy algz alha alhb alhc alhd alhe alhf alhg alhh alhi alhj alhk alhl alhm alhn alho alhp alhq alhr alhs alht alhu alhv alhw alhx alhy alhz alia alib alic alid alie alif alig alih alii alij alik alil alim alin alio alip aliq alir alis alit aliu aliv aliw alix aliy aliz alja aljb aljc aljd alje aljf aljg aljh alji aljj aljk aljl aljm aljn aljo aljp aljq aljr aljs aljt alju aljv aljw aljx aljy aljz alka alkb alkc alkd alke alkf alkg alkh alki alkj alkk alkl alkm alkn alko alkp alkq alkr alks alkt alku alkv alkw alkx alky alkz alla allb allc alld alle allf allg allh alli allj allk alll allm alln allo allp allq allr alls allt allu allv allw allx ally allz alma almb almc almd alme almf almg almh almi almj almk alml almm almn almo almp almq almr alms almt almu almv almw almx almy almz alna alnb alnc alnd alne alnf alng alnh alni alnj alnk alnl alnm alnn alno alnp alnq alnr alns alnt alnu alnv alnw alnx alny alnz aloa alob aloc alod aloe alof alog aloh aloi aloj alok alol alom alon aloo alop aloq alor alos alot alou alov alow alox aloy aloz alpa alpb alpc alpd alpe alpf alpg alph alpi alpj alpk alpl alpm alpn alpo alpp alpq alpr alps alpt alpu alpv alpw alpx alpy alpz alqa alqb alqc alqd alqe alqf alqg alqh alqi alqj alqk alql alqm alqn alqo alqp alqq alqr alqs alqt alqu alqv alqw alqx alqy alqz alra alrb alrc alrd alre alrf alrg alrh alri alrj alrk alrl alrm alrn alro alrp alrq alrr alrs alrt alru alrv alrw alrx alry alrz alsa alsb alsc alsd alse alsf alsg alsh alsi alsj alsk alsl alsm alsn also alsp alsq alsr alss alst alsu alsv alsw alsx alsy alsz alta altb altc altd alte altf altg alth alti altj altk altl altm altn alto altp altq altr alts altt altu altv altw altx alty altz alua alub aluc alud alue aluf alug aluh alui aluj aluk alul alum alun aluo alup aluq alur alus alut aluu aluv aluw alux aluy aluz alva alvb alvc alvd alve alvf alvg alvh alvi alvj alvk alvl alvm alvn alvo alvp alvq alvr alvs alvt alvu alvv alvw alvx alvy alvz alwa alwb alwc alwd alwe alwf alwg alwh alwi alwj alwk alwl alwm alwn alwo alwp alwq alwr alws alwt alwu alwv alww alwx alwy alwz alxa alxb alxc alxd alxe alxf alxg alxh alxi alxj alxk alxl alxm alxn alxo alxp alxq alxr alxs alxt alxu alxv alxw alxx alxy alxz alya alyb alyc alyd alye alyf alyg alyh alyi alyj alyk alyl alym alyn alyo alyp alyq alyr alys alyt alyu alyv alyw alyx alyy alyz alza alzb alzc alzd alze alzf alzg alzh alzi alzj alzk alzl alzm alzn alzo alzp alzq alzr alzs alzt alzu alzv alzw alzx alzy alzz amaa amab amac amad amae amaf amag amah amai amaj amak amal amam aman amao amap amaq amar amas amat amau amav amaw amax amay amaz amba ambb ambc ambd ambe ambf ambg ambh ambi ambj ambk ambl ambm ambn ambo ambp ambq ambr ambs ambt ambu ambv ambw ambx amby ambz amca amcb amcc amcd amce amcf amcg amch amci amcj amck amcl amcm amcn amco amcp amcq amcr amcs amct amcu amcv amcw amcx amcy amcz amda amdb amdc amdd amde amdf amdg amdh amdi amdj amdk amdl amdm amdn amdo amdp amdq amdr amds amdt amdu amdv amdw amdx amdy amdz amea ameb amec amed amee amef ameg ameh amei amej amek amel amem amen ameo amep ameq amer ames amet ameu amev amew amex amey amez amfa amfb amfc amfd amfe amff amfg amfh amfi amfj amfk amfl amfm amfn amfo amfp amfq amfr amfs amft amfu amfv amfw amfx amfy amfz amga amgb amgc amgd amge amgf amgg amgh amgi amgj amgk amgl amgm amgn amgo amgp amgq amgr amgs amgt amgu amgv amgw amgx amgy amgz amha amhb amhc amhd amhe amhf amhg amhh amhi amhj amhk amhl amhm amhn amho amhp amhq amhr amhs amht amhu amhv amhw amhx amhy amhz amia amib amic amid amie amif amig amih amii amij amik amil amim amin amio amip amiq amir amis amit amiu amiv amiw amix amiy amiz amja amjb amjc amjd amje amjf amjg amjh amji amjj amjk amjl amjm amjn amjo amjp amjq amjr amjs amjt amju amjv amjw amjx amjy amjz amka amkb amkc amkd amke amkf amkg amkh amki amkj amkk amkl amkm amkn amko amkp amkq amkr amks amkt amku amkv amkw amkx amky amkz amla amlb amlc amld amle amlf amlg amlh amli amlj amlk amll amlm amln amlo amlp amlq amlr amls amlt amlu amlv amlw amlx amly amlz amma ammb ammc ammd amme ammf ammg ammh ammi ammj ammk amml ammm ammn ammo ammp ammq ammr amms ammt ammu ammv ammw ammx ammy ammz amna amnb amnc amnd amne amnf amng amnh amni amnj amnk amnl amnm amnn amno amnp amnq amnr amns amnt amnu amnv amnw amnx amny amnz amoa amob amoc amod amoe amof amog amoh amoi amoj amok amol amom amon amoo amop amoq amor amos amot amou amov amow amox amoy amoz ampa ampb ampc ampd ampe ampf ampg amph ampi ampj ampk ampl ampm ampn ampo ampp ampq ampr amps ampt ampu ampv ampw ampx ampy ampz amqa amqb amqc amqd amqe amqf amqg amqh amqi amqj amqk amql amqm amqn amqo amqp amqq amqr amqs amqt amqu amqv amqw amqx amqy amqz amra amrb amrc amrd amre amrf amrg amrh amri amrj amrk amrl amrm amrn amro amrp amrq amrr amrs amrt amru amrv amrw amrx amry amrz amsa amsb amsc amsd amse amsf amsg amsh amsi amsj amsk amsl amsm amsn amso amsp amsq amsr amss amst amsu amsv amsw amsx amsy amsz amta amtb amtc amtd amte amtf amtg amth amti amtj amtk amtl amtm amtn amto amtp amtq amtr amts amtt amtu amtv amtw amtx amty amtz amua amub amuc amud amue amuf amug amuh amui amuj amuk amul amum amun amuo amup amuq amur amus amut amuu amuv amuw amux amuy amuz amva amvb amvc amvd amve amvf amvg amvh amvi amvj amvk amvl amvm amvn amvo amvp amvq amvr amvs amvt amvu amvv amvw amvx amvy amvz amwa amwb amwc amwd amwe amwf amwg amwh amwi amwj amwk amwl amwm amwn amwo amwp amwq amwr amws amwt amwu amwv amww amwx amwy amwz amxa amxb amxc amxd amxe amxf amxg amxh amxi amxj amxk amxl amxm amxn amxo amxp amxq amxr amxs amxt amxu amxv amxw amxx amxy amxz amya amyb amyc amyd amye amyf amyg amyh amyi amyj amyk amyl amym amyn amyo amyp amyq amyr amys amyt amyu amyv amyw amyx amyy amyz amza amzb amzc amzd amze amzf amzg amzh amzi amzj amzk amzl amzm amzn amzo amzp amzq amzr amzs amzt amzu amzv amzw amzx amzy amzz anaa anab anac anad anae anaf anag anah anai anaj anak anal anam anan anao anap anaq anar anas anat anau anav anaw anax anay anaz anba anbb anbc anbd anbe anbf anbg anbh anbi anbj anbk anbl anbm anbn anbo anbp anbq anbr anbs anbt anbu anbv anbw anbx anby anbz anca ancb ancc ancd ance ancf ancg anch anci ancj anck ancl ancm ancn anco ancp ancq ancr ancs anct ancu ancv ancw ancx ancy ancz anda andb andc andd ande andf andg andh andi andj andk andl andm andn ando andp andq andr ands andt andu andv andw andx andy andz anea aneb anec aned anee anef aneg aneh anei anej anek anel anem anen aneo anep aneq aner anes anet aneu anev anew anex aney anez anfa anfb anfc anfd anfe anff anfg anfh anfi anfj anfk anfl anfm anfn anfo anfp anfq anfr anfs anft anfu anfv anfw anfx anfy anfz anga angb angc angd ange angf angg angh angi angj angk angl angm angn ango angp angq angr angs angt angu angv angw angx angy angz anha anhb anhc anhd anhe anhf anhg anhh anhi anhj anhk anhl anhm anhn anho anhp anhq anhr anhs anht anhu anhv anhw anhx anhy anhz ania anib anic anid anie anif anig anih anii anij anik anil anim anin anio anip aniq anir anis anit aniu aniv aniw anix aniy aniz anja anjb anjc anjd anje anjf anjg anjh anji anjj anjk anjl anjm anjn anjo anjp anjq anjr anjs anjt anju anjv anjw anjx anjy anjz anka ankb ankc ankd anke ankf ankg ankh anki ankj ankk ankl ankm ankn anko ankp ankq ankr anks ankt anku ankv ankw ankx anky ankz anla anlb anlc anld anle anlf anlg anlh anli anlj anlk anll anlm anln anlo anlp anlq anlr anls anlt anlu anlv anlw anlx anly anlz anma anmb anmc anmd anme anmf anmg anmh anmi anmj anmk anml anmm anmn anmo anmp anmq anmr anms anmt anmu anmv anmw anmx anmy anmz anna annb annc annd anne annf anng annh anni annj annk annl annm annn anno annp annq annr anns annt annu annv annw annx anny annz anoa anob anoc anod anoe anof anog anoh anoi anoj anok anol anom anon anoo anop anoq anor anos anot anou anov anow anox anoy anoz anpa anpb anpc anpd anpe anpf anpg anph anpi anpj anpk anpl anpm anpn anpo anpp anpq anpr anps anpt anpu anpv anpw anpx anpy anpz anqa anqb anqc anqd anqe anqf anqg anqh anqi anqj anqk anql anqm anqn anqo anqp anqq anqr anqs anqt anqu anqv anqw anqx anqy anqz anra anrb anrc anrd anre anrf anrg anrh anri anrj anrk anrl anrm anrn anro anrp anrq anrr anrs anrt anru anrv anrw anrx anry anrz ansa ansb ansc ansd anse ansf ansg ansh ansi ansj ansk ansl ansm ansn anso ansp ansq ansr anss anst ansu ansv answ ansx ansy ansz anta antb antc antd ante antf antg anth anti antj antk antl antm antn anto antp antq antr ants antt antu antv antw antx anty antz anua anub anuc anud anue anuf anug anuh anui anuj anuk anul anum anun anuo anup anuq anur anus anut anuu anuv anuw anux anuy anuz anva anvb anvc anvd anve anvf anvg anvh anvi anvj anvk anvl anvm anvn anvo anvp anvq anvr anvs anvt anvu anvv anvw anvx anvy anvz anwa anwb anwc anwd anwe anwf anwg anwh anwi anwj anwk anwl anwm anwn anwo anwp anwq anwr anws anwt anwu anwv anww anwx anwy anwz anxa anxb anxc anxd anxe anxf anxg anxh anxi anxj anxk anxl anxm anxn anxo anxp anxq anxr anxs anxt anxu anxv anxw anxx anxy anxz anya anyb anyc anyd anye anyf anyg anyh anyi anyj anyk anyl anym anyn anyo anyp anyq anyr anys anyt anyu anyv anyw anyx anyy anyz anza anzb anzc anzd anze anzf anzg anzh anzi anzj anzk anzl anzm anzn anzo anzp anzq anzr anzs anzt anzu anzv anzw anzx anzy anzz aoaa aoab aoac aoad aoae aoaf aoag aoah aoai aoaj aoak aoal aoam aoan aoao aoap aoaq aoar aoas aoat aoau aoav aoaw aoax aoay aoaz aoba aobb aobc aobd aobe aobf aobg aobh aobi aobj aobk aobl aobm aobn aobo aobp aobq aobr aobs aobt aobu aobv aobw aobx aoby aobz aoca aocb aocc aocd aoce aocf aocg aoch aoci aocj aock aocl aocm aocn aoco aocp aocq aocr aocs aoct aocu aocv aocw aocx aocy aocz aoda aodb aodc aodd aode aodf aodg aodh aodi aodj aodk aodl aodm aodn aodo aodp aodq aodr aods aodt aodu aodv aodw aodx aody aodz aoea aoeb aoec aoed aoee aoef aoeg aoeh aoei aoej aoek aoel aoem aoen aoeo aoep aoeq aoer aoes aoet aoeu aoev aoew aoex aoey aoez aofa aofb aofc aofd aofe aoff aofg aofh aofi aofj aofk aofl aofm aofn aofo aofp aofq aofr aofs aoft aofu aofv aofw aofx aofy aofz aoga aogb aogc aogd aoge aogf aogg aogh aogi aogj aogk aogl aogm aogn aogo aogp aogq aogr aogs aogt aogu aogv aogw aogx aogy aogz aoha aohb aohc aohd aohe aohf aohg aohh aohi aohj aohk aohl aohm aohn aoho aohp aohq aohr aohs aoht aohu aohv aohw aohx aohy aohz aoia aoib aoic aoid aoie aoif aoig aoih aoii aoij aoik aoil aoim aoin aoio aoip aoiq aoir aois aoit aoiu aoiv aoiw aoix aoiy aoiz aoja aojb aojc aojd aoje aojf aojg aojh aoji aojj aojk aojl aojm aojn aojo aojp aojq aojr aojs aojt aoju aojv aojw aojx aojy aojz aoka aokb aokc aokd aoke aokf aokg aokh aoki aokj aokk aokl aokm aokn aoko aokp aokq aokr aoks aokt aoku aokv aokw aokx aoky aokz aola aolb aolc aold aole aolf aolg aolh aoli aolj aolk aoll aolm aoln aolo aolp aolq aolr aols aolt aolu aolv aolw aolx aoly aolz aoma aomb aomc aomd aome aomf aomg aomh aomi aomj aomk aoml aomm aomn aomo aomp aomq aomr aoms aomt aomu aomv aomw aomx aomy aomz aona aonb aonc aond aone aonf aong aonh aoni aonj aonk aonl aonm aonn aono aonp aonq aonr aons aont aonu aonv aonw aonx aony aonz aooa aoob aooc aood aooe aoof aoog aooh aooi aooj aook aool aoom aoon aooo aoop aooq aoor aoos aoot aoou aoov aoow aoox aooy aooz aopa aopb aopc aopd aope aopf aopg aoph aopi aopj aopk aopl aopm aopn aopo aopp aopq aopr aops aopt aopu aopv aopw aopx aopy aopz aoqa aoqb aoqc aoqd aoqe aoqf aoqg aoqh aoqi aoqj aoqk aoql aoqm aoqn aoqo aoqp aoqq aoqr aoqs aoqt aoqu aoqv aoqw aoqx aoqy aoqz aora aorb aorc aord aore aorf aorg aorh aori aorj aork aorl aorm aorn aoro aorp aorq aorr aors aort aoru aorv aorw aorx aory aorz aosa aosb aosc aosd aose aosf aosg aosh aosi aosj aosk aosl aosm aosn aoso aosp aosq aosr aoss aost aosu aosv aosw aosx aosy aosz aota aotb aotc aotd aote aotf aotg aoth aoti aotj aotk aotl aotm aotn aoto aotp aotq aotr aots aott aotu aotv aotw aotx aoty aotz aoua aoub aouc aoud aoue aouf aoug aouh aoui aouj aouk aoul aoum aoun aouo aoup aouq aour aous aout aouu aouv aouw aoux aouy aouz aova aovb aovc aovd aove aovf aovg aovh aovi aovj aovk aovl aovm aovn aovo aovp aovq aovr aovs aovt aovu aovv aovw aovx aovy aovz aowa aowb aowc aowd aowe aowf aowg aowh aowi aowj aowk aowl aowm aown aowo aowp aowq aowr aows aowt aowu aowv aoww aowx aowy aowz aoxa aoxb aoxc aoxd aoxe aoxf aoxg aoxh aoxi aoxj aoxk aoxl aoxm aoxn aoxo aoxp aoxq aoxr aoxs aoxt aoxu aoxv aoxw aoxx aoxy aoxz aoya aoyb aoyc aoyd aoye aoyf aoyg aoyh aoyi aoyj aoyk aoyl aoym aoyn aoyo aoyp aoyq aoyr aoys aoyt aoyu aoyv aoyw aoyx aoyy aoyz aoza aozb aozc aozd aoze aozf aozg aozh aozi aozj aozk aozl aozm aozn aozo aozp aozq aozr aozs aozt aozu aozv aozw aozx aozy aozz apaa apab apac apad apae apaf apag apah apai apaj apak apal apam apan apao apap apaq apar apas apat apau apav apaw apax apay apaz apba apbb apbc apbd apbe apbf apbg apbh apbi apbj apbk apbl apbm apbn apbo apbp apbq apbr apbs apbt apbu apbv apbw apbx apby apbz apca apcb apcc apcd apce apcf apcg apch apci apcj apck apcl apcm apcn apco apcp apcq apcr apcs apct apcu apcv apcw apcx apcy apcz apda apdb apdc apdd apde apdf apdg apdh apdi apdj apdk apdl apdm apdn apdo apdp apdq apdr apds apdt apdu apdv apdw apdx apdy apdz apea apeb apec aped apee apef apeg apeh apei apej apek apel apem apen apeo apep apeq aper apes apet apeu apev apew apex apey apez apfa apfb apfc apfd apfe apff apfg apfh apfi apfj apfk apfl apfm apfn apfo apfp apfq apfr apfs apft apfu apfv apfw apfx apfy apfz apga apgb apgc apgd apge apgf apgg apgh apgi apgj apgk apgl apgm apgn apgo apgp apgq apgr apgs apgt apgu apgv apgw apgx apgy apgz apha aphb aphc aphd aphe aphf aphg aphh aphi aphj aphk aphl aphm aphn apho aphp aphq aphr aphs apht aphu aphv aphw aphx aphy aphz apia apib apic apid apie apif apig apih apii apij apik apil apim apin apio apip apiq apir apis apit apiu apiv apiw apix apiy apiz apja apjb apjc apjd apje apjf apjg apjh apji apjj apjk apjl apjm apjn apjo apjp apjq apjr apjs apjt apju apjv apjw apjx apjy apjz apka apkb apkc apkd apke apkf apkg apkh apki apkj apkk apkl apkm apkn apko apkp apkq apkr apks apkt apku apkv apkw apkx apky apkz apla aplb aplc apld aple aplf aplg aplh apli aplj aplk apll aplm apln aplo aplp aplq aplr apls aplt aplu aplv aplw aplx aply aplz apma apmb apmc apmd apme apmf apmg apmh apmi apmj apmk apml apmm apmn apmo apmp apmq apmr apms apmt apmu apmv apmw apmx apmy apmz apna apnb apnc apnd apne apnf apng apnh apni apnj apnk apnl apnm apnn apno apnp apnq apnr apns apnt apnu apnv apnw apnx apny apnz apoa apob apoc apod apoe apof apog apoh apoi apoj apok apol apom apon apoo apop apoq apor apos apot apou apov apow apox apoy apoz appa appb appc appd appe appf appg apph appi appj appk appl appm appn appo appp appq appr apps appt appu appv appw appx appy appz apqa apqb apqc apqd apqe apqf apqg apqh apqi apqj apqk apql apqm apqn apqo apqp apqq apqr apqs apqt apqu apqv apqw apqx apqy apqz apra aprb aprc aprd apre aprf aprg aprh apri aprj aprk aprl aprm aprn apro aprp aprq aprr aprs aprt apru aprv aprw aprx apry aprz apsa apsb apsc apsd apse apsf apsg apsh apsi apsj apsk apsl apsm apsn apso apsp apsq apsr apss apst apsu apsv apsw apsx apsy apsz apta aptb aptc aptd apte aptf aptg apth apti aptj aptk aptl aptm aptn apto aptp aptq aptr apts aptt aptu aptv aptw aptx apty aptz apua apub apuc apud apue apuf apug apuh apui apuj apuk apul apum apun apuo apup apuq apur apus aput apuu apuv apuw apux apuy apuz apva apvb apvc apvd apve apvf apvg apvh apvi apvj apvk apvl apvm apvn apvo apvp apvq apvr apvs apvt apvu apvv apvw apvx apvy apvz apwa apwb apwc apwd apwe apwf apwg apwh apwi apwj apwk apwl apwm apwn apwo apwp apwq apwr apws apwt apwu apwv apww apwx apwy apwz apxa apxb apxc apxd apxe apxf apxg apxh apxi apxj apxk apxl apxm apxn apxo apxp apxq apxr apxs apxt apxu apxv apxw apxx apxy apxz apya apyb apyc apyd apye apyf apyg apyh apyi apyj apyk apyl apym apyn apyo apyp apyq apyr apys apyt apyu apyv apyw apyx apyy apyz apza apzb apzc apzd apze apzf apzg apzh apzi apzj apzk apzl apzm apzn apzo apzp apzq apzr apzs apzt apzu apzv apzw apzx apzy apzz aqaa aqab aqac aqad aqae aqaf aqag aqah aqai aqaj aqak aqal aqam aqan aqao aqap aqaq aqar aqas aqat aqau aqav aqaw aqax aqay aqaz aqba aqbb aqbc aqbd aqbe aqbf aqbg aqbh aqbi aqbj aqbk aqbl aqbm aqbn aqbo aqbp aqbq aqbr aqbs aqbt aqbu aqbv aqbw aqbx aqby aqbz aqca aqcb aqcc aqcd aqce aqcf aqcg aqch aqci aqcj aqck aqcl aqcm aqcn aqco aqcp aqcq aqcr aqcs aqct aqcu aqcv aqcw aqcx aqcy aqcz aqda aqdb aqdc aqdd aqde aqdf aqdg aqdh aqdi aqdj aqdk aqdl aqdm aqdn aqdo aqdp aqdq aqdr aqds aqdt aqdu aqdv aqdw aqdx aqdy aqdz aqea aqeb aqec aqed aqee aqef aqeg aqeh aqei aqej aqek aqel aqem aqen aqeo aqep aqeq aqer aqes aqet aqeu aqev aqew aqex aqey aqez aqfa aqfb aqfc aqfd aqfe aqff aqfg aqfh aqfi aqfj aqfk aqfl aqfm aqfn aqfo aqfp aqfq aqfr aqfs aqft aqfu aqfv aqfw aqfx aqfy aqfz aqga aqgb aqgc aqgd aqge aqgf aqgg aqgh aqgi aqgj aqgk aqgl aqgm aqgn aqgo aqgp aqgq aqgr aqgs aqgt aqgu aqgv aqgw aqgx aqgy aqgz aqha aqhb aqhc aqhd aqhe aqhf aqhg aqhh aqhi aqhj aqhk aqhl aqhm aqhn aqho aqhp aqhq aqhr aqhs aqht aqhu aqhv aqhw aqhx aqhy aqhz aqia aqib aqic aqid aqie aqif aqig aqih aqii aqij aqik aqil aqim aqin aqio aqip aqiq aqir aqis aqit aqiu aqiv aqiw aqix aqiy aqiz aqja aqjb aqjc aqjd aqje aqjf aqjg aqjh aqji aqjj aqjk aqjl aqjm aqjn aqjo aqjp aqjq aqjr aqjs aqjt aqju aqjv aqjw aqjx aqjy aqjz aqka aqkb aqkc aqkd aqke aqkf aqkg aqkh aqki aqkj aqkk aqkl aqkm aqkn aqko aqkp aqkq aqkr aqks aqkt aqku aqkv aqkw aqkx aqky aqkz aqla aqlb aqlc aqld aqle aqlf aqlg aqlh aqli aqlj aqlk aqll aqlm aqln aqlo aqlp aqlq aqlr aqls aqlt aqlu aqlv aqlw aqlx aqly aqlz aqma aqmb aqmc aqmd aqme aqmf aqmg aqmh aqmi aqmj aqmk aqml aqmm aqmn aqmo aqmp aqmq aqmr aqms aqmt aqmu aqmv aqmw aqmx aqmy aqmz aqna aqnb aqnc aqnd aqne aqnf aqng aqnh aqni aqnj aqnk aqnl aqnm aqnn aqno aqnp aqnq aqnr aqns aqnt aqnu aqnv aqnw aqnx aqny aqnz aqoa aqob aqoc aqod aqoe aqof aqog aqoh aqoi aqoj aqok aqol aqom aqon aqoo aqop aqoq aqor aqos aqot aqou aqov aqow aqox aqoy aqoz aqpa aqpb aqpc aqpd aqpe aqpf aqpg aqph aqpi aqpj aqpk aqpl aqpm aqpn aqpo aqpp aqpq aqpr aqps aqpt aqpu aqpv aqpw aqpx aqpy aqpz aqqa aqqb aqqc aqqd aqqe aqqf aqqg aqqh aqqi aqqj aqqk aqql aqqm aqqn aqqo aqqp aqqq aqqr aqqs aqqt aqqu aqqv aqqw aqqx aqqy aqqz aqra aqrb aqrc aqrd aqre aqrf aqrg aqrh aqri aqrj aqrk aqrl aqrm aqrn aqro aqrp aqrq aqrr aqrs aqrt aqru aqrv aqrw aqrx aqry aqrz aqsa aqsb aqsc aqsd aqse aqsf aqsg aqsh aqsi aqsj aqsk aqsl aqsm aqsn aqso aqsp aqsq aqsr aqss aqst aqsu aqsv aqsw aqsx aqsy aqsz aqta aqtb aqtc aqtd aqte aqtf aqtg aqth aqti aqtj aqtk aqtl aqtm aqtn aqto aqtp aqtq aqtr aqts aqtt aqtu aqtv aqtw aqtx aqty aqtz aqua aqub aquc aqud aque aquf aqug aquh aqui aquj aquk aqul aqum aqun aquo aqup aquq aqur aqus aqut aquu aquv aquw aqux aquy aquz aqva aqvb aqvc aqvd aqve aqvf aqvg aqvh aqvi aqvj aqvk aqvl aqvm aqvn aqvo aqvp aqvq aqvr aqvs aqvt aqvu aqvv aqvw aqvx aqvy aqvz aqwa aqwb aqwc aqwd aqwe aqwf aqwg aqwh aqwi aqwj aqwk aqwl aqwm aqwn aqwo aqwp aqwq aqwr aqws aqwt aqwu aqwv aqww aqwx aqwy aqwz aqxa aqxb aqxc aqxd aqxe aqxf aqxg aqxh aqxi aqxj aqxk aqxl aqxm aqxn aqxo aqxp aqxq aqxr aqxs aqxt aqxu aqxv aqxw aqxx aqxy aqxz aqya aqyb aqyc aqyd aqye aqyf aqyg aqyh aqyi aqyj aqyk aqyl aqym aqyn aqyo aqyp aqyq aqyr aqys aqyt aqyu aqyv aqyw aqyx aqyy aqyz aqza aqzb aqzc aqzd aqze aqzf aqzg aqzh aqzi aqzj aqzk aqzl aqzm aqzn aqzo aqzp aqzq aqzr aqzs aqzt aqzu aqzv aqzw aqzx aqzy aqzz araa arab arac arad arae araf arag arah arai araj arak aral aram aran arao arap araq arar aras arat arau arav araw arax aray araz arba arbb arbc arbd arbe arbf arbg arbh arbi arbj arbk arbl arbm arbn arbo arbp arbq arbr arbs arbt arbu arbv arbw arbx arby arbz arca arcb arcc arcd arce arcf arcg arch arci arcj arck arcl arcm arcn arco arcp arcq arcr arcs arct arcu arcv arcw arcx arcy arcz arda ardb ardc ardd arde ardf ardg ardh ardi ardj ardk ardl ardm ardn ardo ardp ardq ardr ards ardt ardu ardv ardw ardx ardy ardz area areb arec ared aree aref areg areh arei arej arek arel arem aren areo arep areq arer ares aret areu arev arew arex arey arez arfa arfb arfc arfd arfe arff arfg arfh arfi arfj arfk arfl arfm arfn arfo arfp arfq arfr arfs arft arfu arfv arfw arfx arfy arfz arga argb argc argd arge argf argg argh argi argj argk argl argm argn argo argp argq argr args argt argu argv argw argx argy argz arha arhb arhc arhd arhe arhf arhg arhh arhi arhj arhk arhl arhm arhn arho arhp arhq arhr arhs arht arhu arhv arhw arhx arhy arhz aria arib aric arid arie arif arig arih arii arij arik aril arim arin ario arip ariq arir aris arit ariu ariv ariw arix ariy ariz arja arjb arjc arjd arje arjf arjg arjh arji arjj arjk arjl arjm arjn arjo arjp arjq arjr arjs arjt arju arjv arjw arjx arjy arjz arka arkb arkc arkd arke arkf arkg arkh arki arkj arkk arkl arkm arkn arko arkp arkq arkr arks arkt arku arkv arkw arkx arky arkz arla arlb arlc arld arle arlf arlg arlh arli arlj arlk arll arlm arln arlo arlp arlq arlr arls arlt arlu arlv arlw arlx arly arlz arma armb armc armd arme armf armg armh armi armj armk arml armm armn armo armp armq armr arms armt armu armv armw armx army armz arna arnb arnc arnd arne arnf arng arnh arni arnj arnk arnl arnm arnn arno arnp arnq arnr arns arnt arnu arnv arnw arnx arny arnz aroa arob aroc arod aroe arof arog aroh aroi aroj arok arol arom aron aroo arop aroq aror aros arot arou arov arow arox aroy aroz arpa arpb arpc arpd arpe arpf arpg arph arpi arpj arpk arpl arpm arpn arpo arpp arpq arpr arps arpt arpu arpv arpw arpx arpy arpz arqa arqb arqc arqd arqe arqf arqg arqh arqi arqj arqk arql arqm arqn arqo arqp arqq arqr arqs arqt arqu arqv arqw arqx arqy arqz arra arrb arrc arrd arre arrf arrg arrh arri arrj arrk arrl arrm arrn arro arrp arrq arrr arrs arrt arru arrv arrw arrx arry arrz arsa arsb arsc arsd arse arsf arsg arsh arsi arsj arsk arsl arsm arsn arso arsp arsq arsr arss arst arsu arsv arsw arsx arsy arsz arta artb artc artd arte artf artg arth arti artj artk artl artm artn arto artp artq artr arts artt artu artv artw artx arty artz arua arub aruc arud arue aruf arug aruh arui aruj aruk arul arum arun aruo arup aruq arur arus arut aruu aruv aruw arux aruy aruz arva arvb arvc arvd arve arvf arvg arvh arvi arvj arvk arvl arvm arvn arvo arvp arvq arvr arvs arvt arvu arvv arvw arvx arvy arvz arwa arwb arwc arwd arwe arwf arwg arwh arwi arwj arwk arwl arwm arwn arwo arwp arwq arwr arws arwt arwu arwv arww arwx arwy arwz arxa arxb arxc arxd arxe arxf arxg arxh arxi arxj arxk arxl arxm arxn arxo arxp arxq arxr arxs arxt arxu arxv arxw arxx arxy arxz arya aryb aryc aryd arye aryf aryg aryh aryi aryj aryk aryl arym aryn aryo aryp aryq aryr arys aryt aryu aryv aryw aryx aryy aryz arza arzb arzc arzd arze arzf arzg arzh arzi arzj arzk arzl arzm arzn arzo arzp arzq arzr arzs arzt arzu arzv arzw arzx arzy arzz asaa asab asac asad asae asaf asag asah asai asaj asak asal asam asan asao asap asaq asar asas asat asau asav asaw asax asay asaz asba asbb asbc asbd asbe asbf asbg asbh asbi asbj asbk asbl asbm asbn asbo asbp asbq asbr asbs asbt asbu asbv asbw asbx asby asbz asca ascb ascc ascd asce ascf ascg asch asci ascj asck ascl ascm ascn asco ascp ascq ascr ascs asct ascu ascv ascw ascx ascy ascz asda asdb asdc asdd asde asdf asdg asdh asdi asdj asdk asdl asdm asdn asdo asdp asdq asdr asds asdt asdu asdv asdw asdx asdy asdz asea aseb asec ased asee asef aseg aseh asei asej asek asel asem asen aseo asep aseq aser ases aset aseu asev asew asex asey asez asfa asfb asfc asfd asfe asff asfg asfh asfi asfj asfk asfl asfm asfn asfo asfp asfq asfr asfs asft asfu asfv asfw asfx asfy asfz asga asgb asgc asgd asge asgf asgg asgh asgi asgj asgk asgl asgm asgn asgo asgp asgq asgr asgs asgt asgu asgv asgw asgx asgy asgz asha ashb ashc ashd ashe ashf ashg ashh ashi ashj ashk ashl ashm ashn asho ashp ashq ashr ashs asht ashu ashv ashw ashx ashy ashz asia asib asic asid asie asif asig asih asii asij asik asil asim asin asio asip asiq asir asis asit asiu asiv asiw asix asiy asiz asja asjb asjc asjd asje asjf asjg asjh asji asjj asjk asjl asjm asjn asjo asjp asjq asjr asjs asjt asju asjv asjw asjx asjy asjz aska askb askc askd aske askf askg askh aski askj askk askl askm askn asko askp askq askr asks askt asku askv askw askx asky askz asla aslb aslc asld asle aslf aslg aslh asli aslj aslk asll aslm asln aslo aslp aslq aslr asls aslt aslu aslv aslw aslx asly aslz asma asmb asmc asmd asme asmf asmg asmh asmi asmj asmk asml asmm asmn asmo asmp asmq asmr asms asmt asmu asmv asmw asmx asmy asmz asna asnb asnc asnd asne asnf asng asnh asni asnj asnk asnl asnm asnn asno asnp asnq asnr asns asnt asnu asnv asnw asnx asny asnz asoa asob asoc asod asoe asof asog asoh asoi asoj asok asol asom ason asoo asop asoq asor asos asot asou asov asow asox asoy asoz aspa aspb aspc aspd aspe aspf aspg asph aspi aspj aspk aspl aspm aspn aspo aspp aspq aspr asps aspt aspu aspv aspw aspx aspy aspz asqa asqb asqc asqd asqe asqf asqg asqh asqi asqj asqk asql asqm asqn asqo asqp asqq asqr asqs asqt asqu asqv asqw asqx asqy asqz asra asrb asrc asrd asre asrf asrg asrh asri asrj asrk asrl asrm asrn asro asrp asrq asrr asrs asrt asru asrv asrw asrx asry asrz assa assb assc assd asse assf assg assh assi assj assk assl assm assn asso assp assq assr asss asst assu assv assw assx assy assz asta astb astc astd aste astf astg asth asti astj astk astl astm astn asto astp astq astr asts astt astu astv astw astx asty astz asua asub asuc asud asue asuf asug asuh asui asuj asuk asul asum asun asuo asup asuq asur asus asut asuu asuv asuw asux asuy asuz asva asvb asvc asvd asve asvf asvg asvh asvi asvj asvk asvl asvm asvn asvo asvp asvq asvr asvs asvt asvu asvv asvw asvx asvy asvz aswa aswb aswc aswd aswe aswf aswg aswh aswi aswj aswk aswl aswm aswn aswo aswp aswq aswr asws aswt aswu aswv asww aswx aswy aswz asxa asxb asxc asxd asxe asxf asxg asxh asxi asxj asxk asxl asxm asxn asxo asxp asxq asxr asxs asxt asxu asxv asxw asxx asxy asxz asya asyb asyc asyd asye asyf asyg asyh asyi asyj asyk asyl asym asyn asyo asyp asyq asyr asys asyt asyu asyv asyw asyx asyy asyz asza aszb aszc aszd asze aszf aszg aszh aszi aszj aszk aszl aszm aszn aszo aszp aszq aszr aszs aszt aszu aszv aszw aszx aszy aszz ataa atab atac atad atae ataf atag atah atai ataj atak atal atam atan atao atap ataq atar atas atat atau atav ataw atax atay ataz atba atbb atbc atbd atbe atbf atbg atbh atbi atbj atbk atbl atbm atbn atbo atbp atbq atbr atbs atbt atbu atbv atbw atbx atby atbz atca atcb atcc atcd atce atcf atcg atch atci atcj atck atcl atcm atcn atco atcp atcq atcr atcs atct atcu atcv atcw atcx atcy atcz atda atdb atdc atdd atde atdf atdg atdh atdi atdj atdk atdl atdm atdn atdo atdp atdq atdr atds atdt atdu atdv atdw atdx atdy atdz atea ateb atec ated atee atef ateg ateh atei atej atek atel atem aten ateo atep ateq ater ates atet ateu atev atew atex atey atez atfa atfb atfc atfd atfe atff atfg atfh atfi atfj atfk atfl atfm atfn atfo atfp atfq atfr atfs atft atfu atfv atfw atfx atfy atfz atga atgb atgc atgd atge atgf atgg atgh atgi atgj atgk atgl atgm atgn atgo atgp atgq atgr atgs atgt atgu atgv atgw atgx atgy atgz atha athb athc athd athe athf athg athh athi athj athk athl athm athn atho athp athq athr aths atht athu athv athw athx athy athz atia atib atic atid atie atif atig atih atii atij atik atil atim atin atio atip atiq atir atis atit atiu ativ atiw atix atiy atiz atja atjb atjc atjd atje atjf atjg atjh atji atjj atjk atjl atjm atjn atjo atjp atjq atjr atjs atjt atju atjv atjw atjx atjy atjz atka atkb atkc atkd atke atkf atkg atkh atki atkj atkk atkl atkm atkn atko atkp atkq atkr atks atkt atku atkv atkw atkx atky atkz atla atlb atlc atld atle atlf atlg atlh atli atlj atlk atll atlm atln atlo atlp atlq atlr atls atlt atlu atlv atlw atlx atly atlz atma atmb atmc atmd atme atmf atmg atmh atmi atmj atmk atml atmm atmn atmo atmp atmq atmr atms atmt atmu atmv atmw atmx atmy atmz atna atnb atnc atnd atne atnf atng atnh atni atnj atnk atnl atnm atnn atno atnp atnq atnr atns atnt atnu atnv atnw atnx atny atnz atoa atob atoc atod atoe atof atog atoh atoi atoj atok atol atom aton atoo atop atoq ator atos atot atou atov atow atox atoy atoz atpa atpb atpc atpd atpe atpf atpg atph atpi atpj atpk atpl atpm atpn atpo atpp atpq atpr atps atpt atpu atpv atpw atpx atpy atpz atqa atqb atqc atqd atqe atqf atqg atqh atqi atqj atqk atql atqm atqn atqo atqp atqq atqr atqs atqt atqu atqv atqw atqx atqy atqz atra atrb atrc atrd atre atrf atrg atrh atri atrj atrk atrl atrm atrn atro atrp atrq atrr atrs atrt atru atrv atrw atrx atry atrz atsa atsb atsc atsd atse atsf atsg atsh atsi atsj atsk atsl atsm atsn atso atsp atsq atsr atss atst atsu atsv atsw atsx atsy atsz atta attb attc attd atte attf attg atth atti attj attk attl attm attn atto attp attq attr atts attt attu attv attw attx atty attz atua atub atuc atud atue atuf atug atuh atui atuj atuk atul atum atun atuo atup atuq atur atus atut atuu atuv atuw atux atuy atuz atva atvb atvc atvd atve atvf atvg atvh atvi atvj atvk atvl atvm atvn atvo atvp atvq atvr atvs atvt atvu atvv atvw atvx atvy atvz atwa atwb atwc atwd atwe atwf atwg atwh atwi atwj atwk atwl atwm atwn atwo atwp atwq atwr atws atwt atwu atwv atww atwx atwy atwz atxa atxb atxc atxd atxe atxf atxg atxh atxi atxj atxk atxl atxm atxn atxo atxp atxq atxr atxs atxt atxu atxv atxw atxx atxy atxz atya atyb atyc atyd atye atyf atyg atyh atyi atyj atyk atyl atym atyn atyo atyp atyq atyr atys atyt atyu atyv atyw atyx atyy atyz atza atzb atzc atzd atze atzf atzg atzh atzi atzj atzk atzl atzm atzn atzo atzp atzq atzr atzs atzt atzu atzv atzw atzx atzy atzz auaa auab auac auad auae auaf auag auah auai auaj auak aual auam auan auao auap auaq auar auas auat auau auav auaw auax auay auaz auba aubb aubc aubd aube aubf aubg aubh aubi aubj aubk aubl aubm aubn aubo aubp aubq aubr aubs aubt aubu aubv aubw aubx auby aubz auca aucb aucc aucd auce aucf aucg auch auci aucj auck aucl aucm aucn auco aucp aucq aucr aucs auct aucu aucv aucw aucx aucy aucz auda audb audc audd aude audf audg audh audi audj audk audl audm audn audo audp audq audr auds audt audu audv audw audx audy audz auea aueb auec aued auee auef aueg aueh auei auej auek auel auem auen aueo auep aueq auer aues auet aueu auev auew auex auey auez aufa aufb aufc aufd aufe auff aufg aufh aufi aufj aufk aufl aufm aufn aufo aufp aufq aufr aufs auft aufu aufv aufw aufx aufy aufz auga augb augc augd auge augf augg augh augi augj augk augl augm augn augo augp augq augr augs augt augu augv augw augx augy augz auha auhb auhc auhd auhe auhf auhg auhh auhi auhj auhk auhl auhm auhn auho auhp auhq auhr auhs auht auhu auhv auhw auhx auhy auhz auia auib auic auid auie auif auig auih auii auij auik auil auim auin auio auip auiq auir auis auit auiu auiv auiw auix auiy auiz auja aujb aujc aujd auje aujf aujg aujh auji aujj aujk aujl aujm aujn aujo aujp aujq aujr aujs aujt auju aujv aujw aujx aujy aujz auka aukb aukc aukd auke aukf aukg aukh auki aukj aukk aukl aukm aukn auko aukp aukq aukr auks aukt auku aukv aukw aukx auky aukz aula aulb aulc auld aule aulf aulg aulh auli aulj aulk aull aulm auln aulo aulp aulq aulr auls ault aulu aulv aulw aulx auly aulz auma aumb aumc aumd aume aumf aumg aumh aumi aumj aumk auml aumm aumn aumo aump aumq aumr aums aumt aumu aumv aumw aumx aumy aumz auna aunb aunc aund aune aunf aung aunh auni aunj aunk aunl aunm aunn auno aunp aunq aunr auns aunt aunu aunv aunw aunx auny aunz auoa auob auoc auod auoe auof auog auoh auoi auoj auok auol auom auon auoo auop auoq auor auos auot auou auov auow auox auoy auoz aupa aupb aupc aupd aupe aupf aupg auph aupi aupj aupk aupl aupm aupn aupo aupp aupq aupr aups aupt aupu aupv aupw aupx aupy aupz auqa auqb auqc auqd auqe auqf auqg auqh auqi auqj auqk auql auqm auqn auqo auqp auqq auqr auqs auqt auqu auqv auqw auqx auqy auqz aura aurb aurc aurd aure aurf aurg aurh auri aurj aurk aurl aurm aurn auro aurp aurq aurr aurs aurt auru aurv aurw aurx aury aurz ausa ausb ausc ausd ause ausf ausg aush ausi ausj ausk ausl ausm ausn auso ausp ausq ausr auss aust ausu ausv ausw ausx ausy ausz auta autb autc autd aute autf autg auth auti autj autk autl autm autn auto autp autq autr auts autt autu autv autw autx auty autz auua auub auuc auud auue auuf auug auuh auui auuj auuk auul auum auun auuo auup auuq auur auus auut auuu auuv auuw auux auuy auuz auva auvb auvc auvd auve auvf auvg auvh auvi auvj auvk auvl auvm auvn auvo auvp auvq auvr auvs auvt auvu auvv auvw auvx auvy auvz auwa auwb auwc auwd auwe auwf auwg auwh auwi auwj auwk auwl auwm auwn auwo auwp auwq auwr auws auwt auwu auwv auww auwx auwy auwz auxa auxb auxc auxd auxe auxf auxg auxh auxi auxj auxk auxl auxm auxn auxo auxp auxq auxr auxs auxt auxu auxv auxw auxx auxy auxz auya auyb auyc auyd auye auyf auyg auyh auyi auyj auyk auyl auym auyn auyo auyp auyq auyr auys auyt auyu auyv auyw auyx auyy auyz auza auzb auzc auzd auze auzf auzg auzh auzi auzj auzk auzl auzm auzn auzo auzp auzq auzr auzs auzt auzu auzv auzw auzx auzy auzz avaa avab avac avad avae avaf avag avah avai avaj avak aval avam avan avao avap avaq avar avas avat avau avav avaw avax avay avaz avba avbb avbc avbd avbe avbf avbg avbh avbi avbj avbk avbl avbm avbn avbo avbp avbq avbr avbs avbt avbu avbv avbw avbx avby avbz avca avcb avcc avcd avce avcf avcg avch avci avcj avck avcl avcm avcn avco avcp avcq avcr avcs avct avcu avcv avcw avcx avcy avcz avda avdb avdc avdd avde avdf avdg avdh avdi avdj avdk avdl avdm avdn avdo avdp avdq avdr avds avdt avdu avdv avdw avdx avdy avdz avea aveb avec aved avee avef aveg aveh avei avej avek avel avem aven aveo avep aveq aver aves avet aveu avev avew avex avey avez avfa avfb avfc avfd avfe avff avfg avfh avfi avfj avfk avfl avfm avfn avfo avfp avfq avfr avfs avft avfu avfv avfw avfx avfy avfz avga avgb avgc avgd avge avgf avgg avgh avgi avgj avgk avgl avgm avgn avgo avgp avgq avgr avgs avgt avgu avgv avgw avgx avgy avgz avha avhb avhc avhd avhe avhf avhg avhh avhi avhj avhk avhl avhm avhn avho avhp avhq avhr avhs avht avhu avhv avhw avhx avhy avhz avia avib avic avid avie avif avig avih avii avij avik avil avim avin avio avip aviq avir avis avit aviu aviv aviw avix aviy aviz avja avjb avjc avjd avje avjf avjg avjh avji avjj avjk avjl avjm avjn avjo avjp avjq avjr avjs avjt avju avjv avjw avjx avjy avjz avka avkb avkc avkd avke avkf avkg avkh avki avkj avkk avkl avkm avkn avko avkp avkq avkr avks avkt avku avkv avkw avkx avky avkz avla avlb avlc avld avle avlf avlg avlh avli avlj avlk avll avlm avln avlo avlp avlq avlr avls avlt avlu avlv avlw avlx avly avlz avma avmb avmc avmd avme avmf avmg avmh avmi avmj avmk avml avmm avmn avmo avmp avmq avmr avms avmt avmu avmv avmw avmx avmy avmz avna avnb avnc avnd avne avnf avng avnh avni avnj avnk avnl avnm avnn avno avnp avnq avnr avns avnt avnu avnv avnw avnx avny avnz avoa avob avoc avod avoe avof avog avoh avoi avoj avok avol avom avon avoo avop avoq avor avos avot avou avov avow avox avoy avoz avpa avpb avpc avpd avpe avpf avpg avph avpi avpj avpk avpl avpm avpn avpo avpp avpq avpr avps avpt avpu avpv avpw avpx avpy avpz avqa avqb avqc avqd avqe avqf avqg avqh avqi avqj avqk avql avqm avqn avqo avqp avqq avqr avqs avqt avqu avqv avqw avqx avqy avqz avra avrb avrc avrd avre avrf avrg avrh avri avrj avrk avrl avrm avrn avro avrp avrq avrr avrs avrt avru avrv avrw avrx avry avrz avsa avsb avsc avsd avse avsf avsg avsh avsi avsj avsk avsl avsm avsn avso avsp avsq avsr avss avst avsu avsv avsw avsx avsy avsz avta avtb avtc avtd avte avtf avtg avth avti avtj avtk avtl avtm avtn avto avtp avtq avtr avts avtt avtu avtv avtw avtx avty avtz avua avub avuc avud avue avuf avug avuh avui avuj avuk avul avum avun avuo avup avuq avur avus avut avuu avuv avuw avux avuy avuz avva avvb avvc avvd avve avvf avvg avvh avvi avvj avvk avvl avvm avvn avvo avvp avvq avvr avvs avvt avvu avvv avvw avvx avvy avvz avwa avwb avwc avwd avwe avwf avwg avwh avwi avwj avwk avwl avwm avwn avwo avwp avwq avwr avws avwt avwu avwv avww avwx avwy avwz avxa avxb avxc avxd avxe avxf avxg avxh avxi avxj avxk avxl avxm avxn avxo avxp avxq avxr avxs avxt avxu avxv avxw avxx avxy avxz avya avyb avyc avyd avye avyf avyg avyh avyi avyj avyk avyl avym avyn avyo avyp avyq avyr avys avyt avyu avyv avyw avyx avyy avyz avza avzb avzc avzd avze avzf avzg avzh avzi avzj avzk avzl avzm avzn avzo avzp avzq avzr avzs avzt avzu avzv avzw avzx avzy avzz awaa awab awac awad awae awaf awag awah awai awaj awak awal awam awan awao awap awaq awar awas awat awau awav awaw awax away awaz awba awbb awbc awbd awbe awbf awbg awbh awbi awbj awbk awbl awbm awbn awbo awbp awbq awbr awbs awbt awbu awbv awbw awbx awby awbz awca awcb awcc awcd awce awcf awcg awch awci awcj awck awcl awcm awcn awco awcp awcq awcr awcs awct awcu awcv awcw awcx awcy awcz awda awdb awdc awdd awde awdf awdg awdh awdi awdj awdk awdl awdm awdn awdo awdp awdq awdr awds awdt awdu awdv awdw awdx awdy awdz awea aweb awec awed awee awef aweg aweh awei awej awek awel awem awen aweo awep aweq awer awes awet aweu awev awew awex awey awez awfa awfb awfc awfd awfe awff awfg awfh awfi awfj awfk awfl awfm awfn awfo awfp awfq awfr awfs awft awfu awfv awfw awfx awfy awfz awga awgb awgc awgd awge awgf awgg awgh awgi awgj awgk awgl awgm awgn awgo awgp awgq awgr awgs awgt awgu awgv awgw awgx awgy awgz awha awhb awhc awhd awhe awhf awhg awhh awhi awhj awhk awhl awhm awhn awho awhp awhq awhr awhs awht awhu awhv awhw awhx awhy awhz awia awib awic awid awie awif awig awih awii awij awik awil awim awin awio awip awiq awir awis awit awiu awiv awiw awix awiy awiz awja awjb awjc awjd awje awjf awjg awjh awji awjj awjk awjl awjm awjn awjo awjp awjq awjr awjs awjt awju awjv awjw awjx awjy awjz awka awkb awkc awkd awke awkf awkg awkh awki awkj awkk awkl awkm awkn awko awkp awkq awkr awks awkt awku awkv awkw awkx awky awkz awla awlb awlc awld awle awlf awlg awlh awli awlj awlk awll awlm awln awlo awlp awlq awlr awls awlt awlu awlv awlw awlx awly awlz awma awmb awmc awmd awme awmf awmg awmh awmi awmj awmk awml awmm awmn awmo awmp awmq awmr awms awmt awmu awmv awmw awmx awmy awmz awna awnb awnc awnd awne awnf awng awnh awni awnj awnk awnl awnm awnn awno awnp awnq awnr awns awnt awnu awnv awnw awnx awny awnz awoa awob awoc awod awoe awof awog awoh awoi awoj awok awol awom awon awoo awop awoq awor awos awot awou awov awow awox awoy awoz awpa awpb awpc awpd awpe awpf awpg awph awpi awpj awpk awpl awpm awpn awpo awpp awpq awpr awps awpt awpu awpv awpw awpx awpy awpz awqa awqb awqc awqd awqe awqf awqg awqh awqi awqj awqk awql awqm awqn awqo awqp awqq awqr awqs awqt awqu awqv awqw awqx awqy awqz awra awrb awrc awrd awre awrf awrg awrh awri awrj awrk awrl awrm awrn awro awrp awrq awrr awrs awrt awru awrv awrw awrx awry awrz awsa awsb awsc awsd awse awsf awsg awsh awsi awsj awsk awsl awsm awsn awso awsp awsq awsr awss awst awsu awsv awsw awsx awsy awsz awta awtb awtc awtd awte awtf awtg awth awti awtj awtk awtl awtm awtn awto awtp awtq awtr awts awtt awtu awtv awtw awtx awty awtz awua awub awuc awud awue awuf awug awuh awui awuj awuk awul awum awun awuo awup awuq awur awus awut awuu awuv awuw awux awuy awuz awva awvb awvc awvd awve awvf awvg awvh awvi awvj awvk awvl awvm awvn awvo awvp awvq awvr awvs awvt awvu awvv awvw awvx awvy awvz awwa awwb awwc awwd awwe awwf awwg awwh awwi awwj awwk awwl awwm awwn awwo awwp awwq awwr awws awwt awwu awwv awww awwx awwy awwz awxa awxb awxc awxd awxe awxf awxg awxh awxi awxj awxk awxl awxm awxn awxo awxp awxq awxr awxs awxt awxu awxv awxw awxx awxy awxz awya awyb awyc awyd awye awyf awyg awyh awyi awyj awyk awyl awym awyn awyo awyp awyq awyr awys awyt awyu awyv awyw awyx awyy awyz awza awzb awzc awzd awze awzf awzg awzh awzi awzj awzk awzl awzm awzn awzo awzp awzq awzr awzs awzt awzu awzv awzw awzx awzy awzz axaa axab axac axad axae axaf axag axah axai axaj axak axal axam axan axao axap axaq axar axas axat axau axav axaw axax axay axaz axba axbb axbc axbd axbe axbf axbg axbh axbi axbj axbk axbl axbm axbn axbo axbp axbq axbr axbs axbt axbu axbv axbw axbx axby axbz axca axcb axcc axcd axce axcf axcg axch axci axcj axck axcl axcm axcn axco axcp axcq axcr axcs axct axcu axcv axcw axcx axcy axcz axda axdb axdc axdd axde axdf axdg axdh axdi axdj axdk axdl axdm axdn axdo axdp axdq axdr axds axdt axdu axdv axdw axdx axdy axdz axea axeb axec axed axee axef axeg axeh axei axej axek axel axem axen axeo axep axeq axer axes axet axeu axev axew axex axey axez axfa axfb axfc axfd axfe axff axfg axfh axfi axfj axfk axfl axfm axfn axfo axfp axfq axfr axfs axft axfu axfv axfw axfx axfy axfz axga axgb axgc axgd axge axgf axgg axgh axgi axgj axgk axgl axgm axgn axgo axgp axgq axgr axgs axgt axgu axgv axgw axgx axgy axgz axha axhb axhc axhd axhe axhf axhg axhh axhi axhj axhk axhl axhm axhn axho axhp axhq axhr axhs axht axhu axhv axhw axhx axhy axhz axia axib axic axid axie axif axig axih axii axij axik axil axim axin axio axip axiq axir axis axit axiu axiv axiw axix axiy axiz axja axjb axjc axjd axje axjf axjg axjh axji axjj axjk axjl axjm axjn axjo axjp axjq axjr axjs axjt axju axjv axjw axjx axjy axjz axka axkb axkc axkd axke axkf axkg axkh axki axkj axkk axkl axkm axkn axko axkp axkq axkr axks axkt axku axkv axkw axkx axky axkz axla axlb axlc axld axle axlf axlg axlh axli axlj axlk axll axlm axln axlo axlp axlq axlr axls axlt axlu axlv axlw axlx axly axlz axma axmb axmc axmd axme axmf axmg axmh axmi axmj axmk axml axmm axmn axmo axmp axmq axmr axms axmt axmu axmv axmw axmx axmy axmz axna axnb axnc axnd axne axnf axng axnh axni axnj axnk axnl axnm axnn axno axnp axnq axnr axns axnt axnu axnv axnw axnx axny axnz axoa axob axoc axod axoe axof axog axoh axoi axoj axok axol axom axon axoo axop axoq axor axos axot axou axov axow axox axoy axoz axpa axpb axpc axpd axpe axpf axpg axph axpi axpj axpk axpl axpm axpn axpo axpp axpq axpr axps axpt axpu axpv axpw axpx axpy axpz axqa axqb axqc axqd axqe axqf axqg axqh axqi axqj axqk axql axqm axqn axqo axqp axqq axqr axqs axqt axqu axqv axqw axqx axqy axqz axra axrb axrc axrd axre axrf axrg axrh axri axrj axrk axrl axrm axrn axro axrp axrq axrr axrs axrt axru axrv axrw axrx axry axrz axsa axsb axsc axsd axse axsf axsg axsh axsi axsj axsk axsl axsm axsn axso axsp axsq axsr axss axst axsu axsv axsw axsx axsy axsz axta axtb axtc axtd axte axtf axtg axth axti axtj axtk axtl axtm axtn axto axtp axtq axtr axts axtt axtu axtv axtw axtx axty axtz axua axub axuc axud axue axuf axug axuh axui axuj axuk axul axum axun axuo axup axuq axur axus axut axuu axuv axuw axux axuy axuz axva axvb axvc axvd axve axvf axvg axvh axvi axvj axvk axvl axvm axvn axvo axvp axvq axvr axvs axvt axvu axvv axvw axvx axvy axvz axwa axwb axwc axwd axwe axwf axwg axwh axwi axwj axwk axwl axwm axwn axwo axwp axwq axwr axws axwt axwu axwv axww axwx axwy axwz axxa axxb axxc axxd axxe axxf axxg axxh axxi axxj axxk axxl axxm axxn axxo axxp axxq axxr axxs axxt axxu axxv axxw axxx axxy axxz axya axyb axyc axyd axye axyf axyg axyh axyi axyj axyk axyl axym axyn axyo axyp axyq axyr axys axyt axyu axyv axyw axyx axyy axyz axza axzb axzc axzd axze axzf axzg axzh axzi axzj axzk axzl axzm axzn axzo axzp axzq axzr axzs axzt axzu axzv axzw axzx axzy axzz ayaa ayab ayac ayad ayae ayaf ayag ayah ayai ayaj ayak ayal ayam ayan ayao ayap ayaq ayar ayas ayat ayau ayav ayaw ayax ayay ayaz ayba aybb aybc aybd aybe aybf aybg aybh aybi aybj aybk aybl aybm aybn aybo aybp aybq aybr aybs aybt aybu aybv aybw aybx ayby aybz ayca aycb aycc aycd ayce aycf aycg aych ayci aycj ayck aycl aycm aycn ayco aycp aycq aycr aycs ayct aycu aycv aycw aycx aycy aycz ayda aydb aydc aydd ayde aydf aydg aydh aydi aydj aydk aydl aydm aydn aydo aydp aydq aydr ayds aydt aydu aydv aydw aydx aydy aydz ayea ayeb ayec ayed ayee ayef ayeg ayeh ayei ayej ayek ayel ayem ayen ayeo ayep ayeq ayer ayes ayet ayeu ayev ayew ayex ayey ayez ayfa ayfb ayfc ayfd ayfe ayff ayfg ayfh ayfi ayfj ayfk ayfl ayfm ayfn ayfo ayfp ayfq ayfr ayfs ayft ayfu ayfv ayfw ayfx ayfy ayfz ayga aygb aygc aygd ayge aygf aygg aygh aygi aygj aygk aygl aygm aygn aygo aygp aygq aygr aygs aygt aygu aygv aygw aygx aygy aygz ayha ayhb ayhc ayhd ayhe ayhf ayhg ayhh ayhi ayhj ayhk ayhl ayhm ayhn ayho ayhp ayhq ayhr ayhs ayht ayhu ayhv ayhw ayhx ayhy ayhz ayia ayib ayic ayid ayie ayif ayig ayih ayii ayij ayik ayil ayim ayin ayio ayip ayiq ayir ayis ayit ayiu ayiv ayiw ayix ayiy ayiz ayja ayjb ayjc ayjd ayje ayjf ayjg ayjh ayji ayjj ayjk ayjl ayjm ayjn ayjo ayjp ayjq ayjr ayjs ayjt ayju ayjv ayjw ayjx ayjy ayjz ayka aykb aykc aykd ayke aykf aykg aykh ayki aykj aykk aykl aykm aykn ayko aykp aykq aykr ayks aykt ayku aykv aykw aykx ayky aykz ayla aylb aylc ayld ayle aylf aylg aylh ayli aylj aylk ayll aylm ayln aylo aylp aylq aylr ayls aylt aylu aylv aylw aylx ayly aylz ayma aymb aymc aymd ayme aymf aymg aymh aymi aymj aymk ayml aymm aymn aymo aymp aymq aymr ayms aymt aymu aymv aymw aymx aymy aymz ayna aynb aync aynd ayne aynf ayng aynh ayni aynj aynk aynl aynm aynn ayno aynp aynq aynr ayns aynt aynu aynv aynw aynx ayny aynz ayoa ayob ayoc ayod ayoe ayof ayog ayoh ayoi ayoj ayok ayol ayom ayon ayoo ayop ayoq ayor ayos ayot ayou ayov ayow ayox ayoy ayoz aypa aypb aypc aypd aype aypf aypg ayph aypi aypj aypk aypl aypm aypn aypo aypp aypq aypr ayps aypt aypu aypv aypw aypx aypy aypz ayqa ayqb ayqc ayqd ayqe ayqf ayqg ayqh ayqi ayqj ayqk ayql ayqm ayqn ayqo ayqp ayqq ayqr ayqs ayqt ayqu ayqv ayqw ayqx ayqy ayqz ayra ayrb ayrc ayrd ayre ayrf ayrg ayrh ayri ayrj ayrk ayrl ayrm ayrn ayro ayrp ayrq ayrr ayrs ayrt ayru ayrv ayrw ayrx ayry ayrz aysa aysb aysc aysd ayse aysf aysg aysh aysi aysj aysk aysl aysm aysn ayso aysp aysq aysr ayss ayst aysu aysv aysw aysx aysy aysz ayta aytb aytc aytd ayte aytf aytg ayth ayti aytj aytk aytl aytm aytn ayto aytp aytq aytr ayts aytt aytu aytv aytw aytx ayty aytz ayua ayub ayuc ayud ayue ayuf ayug ayuh ayui ayuj ayuk ayul ayum ayun ayuo ayup ayuq ayur ayus ayut ayuu ayuv ayuw ayux ayuy ayuz ayva ayvb ayvc ayvd ayve ayvf ayvg ayvh ayvi ayvj ayvk ayvl ayvm ayvn ayvo ayvp ayvq ayvr ayvs ayvt ayvu ayvv ayvw ayvx ayvy ayvz aywa aywb aywc aywd aywe aywf aywg aywh aywi aywj aywk aywl aywm aywn aywo aywp aywq aywr ayws aywt aywu aywv ayww aywx aywy aywz ayxa ayxb ayxc ayxd ayxe ayxf ayxg ayxh ayxi ayxj ayxk ayxl ayxm ayxn ayxo ayxp ayxq ayxr ayxs ayxt ayxu ayxv ayxw ayxx ayxy ayxz ayya ayyb ayyc ayyd ayye ayyf ayyg ayyh ayyi ayyj ayyk ayyl ayym ayyn ayyo ayyp ayyq ayyr ayys ayyt ayyu ayyv ayyw ayyx ayyy ayyz ayza ayzb ayzc ayzd ayze ayzf ayzg ayzh ayzi ayzj ayzk ayzl ayzm ayzn ayzo ayzp ayzq ayzr ayzs ayzt ayzu ayzv ayzw ayzx ayzy ayzz azaa azab azac azad azae azaf azag azah azai azaj azak azal azam azan azao azap azaq azar azas azat azau azav azaw azax azay azaz azba azbb azbc azbd azbe azbf azbg azbh azbi azbj azbk azbl azbm azbn azbo azbp azbq azbr azbs azbt azbu azbv azbw azbx azby azbz azca azcb azcc azcd azce azcf azcg azch azci azcj azck azcl azcm azcn azco azcp azcq azcr azcs azct azcu azcv azcw azcx azcy azcz azda azdb azdc azdd azde azdf azdg azdh azdi azdj azdk azdl azdm azdn azdo azdp azdq azdr azds azdt azdu azdv azdw azdx azdy azdz azea azeb azec azed azee azef azeg azeh azei azej azek azel azem azen azeo azep azeq azer azes azet azeu azev azew azex azey azez azfa azfb azfc azfd azfe azff azfg azfh azfi azfj azfk azfl azfm azfn azfo azfp azfq azfr azfs azft azfu azfv azfw azfx azfy azfz azga azgb azgc azgd azge azgf azgg azgh azgi azgj azgk azgl azgm azgn azgo azgp azgq azgr azgs azgt azgu azgv azgw azgx azgy azgz azha azhb azhc azhd azhe azhf azhg azhh azhi azhj azhk azhl azhm azhn azho azhp azhq azhr azhs azht azhu azhv azhw azhx azhy azhz azia azib azic azid azie azif azig azih azii azij azik azil azim azin azio azip aziq azir azis azit aziu aziv aziw azix aziy aziz azja azjb azjc azjd azje azjf azjg azjh azji azjj azjk azjl azjm azjn azjo azjp azjq azjr azjs azjt azju azjv azjw azjx azjy azjz azka azkb azkc azkd azke azkf azkg azkh azki azkj azkk azkl azkm azkn azko azkp azkq azkr azks azkt azku azkv azkw azkx azky azkz azla azlb azlc azld azle azlf azlg azlh azli azlj azlk azll azlm azln azlo azlp azlq azlr azls azlt azlu azlv azlw azlx azly azlz azma azmb azmc azmd azme azmf azmg azmh azmi azmj azmk azml azmm azmn azmo azmp azmq azmr azms azmt azmu azmv azmw azmx azmy azmz azna aznb aznc aznd azne aznf azng aznh azni aznj aznk aznl aznm aznn azno aznp aznq aznr azns aznt aznu aznv aznw aznx azny aznz azoa azob azoc azod azoe azof azog azoh azoi azoj azok azol azom azon azoo azop azoq azor azos azot azou azov azow azox azoy azoz azpa azpb azpc azpd azpe azpf azpg azph azpi azpj azpk azpl azpm azpn azpo azpp azpq azpr azps azpt azpu azpv azpw azpx azpy azpz azqa azqb azqc azqd azqe azqf azqg azqh azqi azqj azqk azql azqm azqn azqo azqp azqq azqr azqs azqt azqu azqv azqw azqx azqy azqz azra azrb azrc azrd azre azrf azrg azrh azri azrj azrk azrl azrm azrn azro azrp azrq azrr azrs azrt azru azrv azrw azrx azry azrz azsa azsb azsc azsd azse azsf azsg azsh azsi azsj azsk azsl azsm azsn azso azsp azsq azsr azss azst azsu azsv azsw azsx azsy azsz azta aztb aztc aztd azte aztf aztg azth azti aztj aztk aztl aztm aztn azto aztp aztq aztr azts aztt aztu aztv aztw aztx azty aztz azua azub azuc azud azue azuf azug azuh azui azuj azuk azul azum azun azuo azup azuq azur azus azut azuu azuv azuw azux azuy azuz azva azvb azvc azvd azve azvf azvg azvh azvi azvj azvk azvl azvm azvn azvo azvp azvq azvr azvs azvt azvu azvv azvw azvx azvy azvz azwa azwb azwc azwd azwe azwf azwg azwh azwi azwj azwk azwl azwm azwn azwo azwp azwq azwr azws azwt azwu azwv azww azwx azwy azwz azxa azxb azxc azxd azxe azxf azxg azxh azxi azxj azxk azxl azxm azxn azxo azxp azxq azxr azxs azxt azxu azxv azxw azxx azxy azxz azya azyb azyc azyd azye azyf azyg azyh azyi azyj azyk azyl azym azyn azyo azyp azyq azyr azys azyt azyu azyv azyw azyx azyy azyz azza azzb azzc azzd azze azzf azzg azzh azzi azzj azzk azzl azzm azzn azzo azzp azzq azzr azzs azzt azzu azzv azzw azzx azzy azzz baaa baab baac baad baae baaf baag baah baai baaj baak baal baam baan baao baap baaq baar baas baat baau baav baaw baax baay baaz baba babb babc babd babe babf babg babh babi babj babk babl babm babn babo babp babq babr babs babt babu babv babw babx baby babz baca bacb bacc bacd bace bacf bacg bach baci bacj back bacl bacm bacn baco bacp bacq bacr bacs bact bacu bacv bacw bacx bacy bacz bada badb badc badd bade badf badg badh badi badj badk badl badm badn bado badp badq badr bads badt badu badv badw badx bady badz baea baeb baec baed baee baef baeg baeh baei baej baek bael baem baen baeo baep baeq baer baes baet baeu baev baew baex baey baez bafa bafb bafc bafd bafe baff bafg bafh bafi bafj bafk bafl bafm bafn bafo bafp bafq bafr bafs baft bafu bafv bafw bafx bafy bafz baga bagb bagc bagd bage bagf bagg bagh bagi bagj bagk bagl bagm bagn bago bagp bagq bagr bags bagt bagu bagv bagw bagx bagy bagz baha bahb bahc bahd bahe bahf bahg bahh bahi bahj bahk bahl bahm bahn baho bahp bahq bahr bahs baht bahu bahv bahw bahx bahy bahz baia baib baic baid baie baif baig baih baii baij baik bail baim bain baio baip baiq bair bais bait baiu baiv baiw baix baiy baiz baja bajb bajc bajd baje bajf bajg bajh baji bajj bajk bajl bajm bajn bajo bajp bajq bajr bajs bajt baju bajv bajw bajx bajy bajz baka bakb bakc bakd bake bakf bakg bakh baki bakj bakk bakl bakm bakn bako bakp bakq bakr baks bakt baku bakv bakw bakx baky bakz bala balb balc bald bale balf balg balh bali balj balk ball balm baln balo balp balq balr bals balt balu balv balw balx baly balz bama bamb bamc bamd bame bamf bamg bamh bami bamj bamk baml bamm bamn bamo bamp bamq bamr bams bamt bamu bamv bamw bamx bamy bamz bana banb banc band bane banf bang banh bani banj bank banl banm bann bano banp banq banr bans bant banu banv banw banx bany banz baoa baob baoc baod baoe baof baog baoh baoi baoj baok baol baom baon baoo baop baoq baor baos baot baou baov baow baox baoy baoz bapa bapb bapc bapd bape bapf bapg baph bapi bapj bapk bapl bapm bapn bapo bapp bapq bapr baps bapt bapu bapv bapw bapx bapy bapz baqa baqb baqc baqd baqe baqf baqg baqh baqi baqj baqk baql baqm baqn baqo baqp baqq baqr baqs baqt baqu baqv baqw baqx baqy baqz bara barb barc bard bare barf barg barh bari barj bark barl barm barn baro barp barq barr bars bart baru barv barw barx bary barz basa basb basc basd base basf basg bash basi basj bask basl basm basn baso basp basq basr bass bast basu basv basw basx basy basz bata batb batc batd bate batf batg bath bati batj batk batl batm batn bato batp batq batr bats batt batu batv batw batx baty batz baua baub bauc baud baue bauf baug bauh baui bauj bauk baul baum baun bauo baup bauq baur baus baut bauu bauv bauw baux bauy bauz bava bavb bavc bavd bave bavf bavg bavh bavi bavj bavk bavl bavm bavn bavo bavp bavq bavr bavs bavt bavu bavv bavw bavx bavy bavz bawa bawb bawc bawd bawe bawf bawg bawh bawi bawj bawk bawl bawm bawn bawo bawp bawq bawr baws bawt bawu bawv baww bawx bawy bawz baxa baxb baxc baxd baxe baxf baxg baxh baxi baxj baxk baxl baxm baxn baxo baxp baxq baxr baxs baxt baxu baxv baxw baxx baxy baxz baya bayb bayc bayd baye bayf bayg bayh bayi bayj bayk bayl baym bayn bayo bayp bayq bayr bays bayt bayu bayv bayw bayx bayy bayz baza bazb bazc bazd baze bazf bazg bazh bazi bazj bazk bazl bazm bazn bazo bazp bazq bazr bazs bazt bazu bazv bazw bazx bazy bazz bbaa bbab bbac bbad bbae bbaf bbag bbah bbai bbaj bbak bbal bbam bban bbao bbap bbaq bbar bbas bbat bbau bbav bbaw bbax bbay bbaz bbba bbbb mingw-ocaml/ocaml/camlp4/test/fixtures/make_extend.ml0000644000175000017500000000007612124403240022306 0ustar tootstoots<:expr< EXTEND G expr: [[ "foo" -> <:expr< foo >> ]]; END >>; mingw-ocaml/ocaml/camlp4/test/fixtures/label.ml0000644000175000017500000000003012124403240021067 0ustar tootstootsvalue f ~a:_ ?b:_ = (); mingw-ocaml/ocaml/camlp4/test/fixtures/superfluous.ml0000644000175000017500000000057112124403240022416 0ustar tootstootsopen Camlp4.PreCast;; open Syntax;; let _loc = Loc.ghost;; let st = <:str_item< >>;; let e = <:expr< 1 >> let bi = <:binding< x = 0 >>;; (* none of these holds due to superfluous StSem and StNil *) assert (Ast.StSem (_loc, st, st) = <:str_item< $st$ $st$ >>);; assert (Ast.StExp (_loc, e) = <:str_item< $exp:e$ >>);; assert (Ast.StVal (_loc, bi) = <:str_item< let $bi$ >>);; mingw-ocaml/ocaml/camlp4/test/fixtures/simplify_r.ml0000644000175000017500000000040512124403240022173 0ustar tootstootsopen Camlp4.PreCast; let simplify = object inherit Ast.map as super; method expr e = match super#expr e with [ <:expr< $x$ + 0 >> | <:expr< 0 + $x$ >> -> x | x -> x ]; end in AstFilters.register_str_item_filter simplify#str_item; mingw-ocaml/ocaml/camlp4/test/fixtures/macrotest.mli0000644000175000017500000000062112124403240022170 0ustar tootstootsDEFINE A; DEFINE B; IFDEF A THEN value a_should_be_present : int; ENDIF; IFNDEF C THEN value b_should_be_present : int; ENDIF; IFNDEF C THEN value c_should_be_present : int; ELSE value a_should_NOT_be_present : int; END; IFDEF C THEN value b_should_NOT_be_present : int; ELSE value d_should_be_present : int; value e_should_be_present : int; ENDIF; value f_should_be_present : int; mingw-ocaml/ocaml/camlp4/test/fixtures/transform-examples.ml0000644000175000017500000000014412124403240023645 0ustar tootstoots<:expr< $x$ + $y$ - $z$ >> -> <:expr< plus_minus $x$ $y$ $z$ >> << List.rev (List.rev $l$) >> -> l mingw-ocaml/ocaml/camlp4/test/fixtures/rec.ml0000644000175000017500000000003712124403240020570 0ustar tootstoots(* rec.ml *) value rec x = 42; mingw-ocaml/ocaml/camlp4/test/fixtures/macrotest3.ml0000644000175000017500000000034012124403240022100 0ustar tootstootsIFNDEF UNDEFINED_VARIABLE THEN DEFINE UNDEFINED_VARIABLE IFDEF UNDEFINED_VARIABLE THEN DEFINE SQUARE (x) = x * x ;; DEFINE DOUBLE_SQUARE (x) = (SQUARE x) * 2 ;; END END;; Printf.printf "%d\n" (DOUBLE_SQUARE(42)) ;; mingw-ocaml/ocaml/camlp4/test/fixtures/gram.ml0000644000175000017500000000015712124403240020750 0ustar tootstootsEXTEND G expr: [[ l = LIST0 STRING -> l ]]; END; EXTEND G expr: [[ l = LIST0 [ x = STRING -> x ] -> l ]]; END; mingw-ocaml/ocaml/camlp4/test/fixtures/seq2.ml0000644000175000017500000010041212124403240020667 0ustar tootstootsmodule M = struct foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; foo bar; end; mingw-ocaml/ocaml/camlp4/test/fixtures/pr4357sample.ml0000644000175000017500000000007012124403240022162 0ustar tootstootslet u = "Hello";; let s = <:sample>;; print_string s mingw-ocaml/ocaml/camlp4/test/fixtures/constant-parser.ml0000644000175000017500000001051212124403240023141 0ustar tootstootsopen Camlp4 module Id = struct let name = "Camlp4Parsers.LoadCamlp4Ast" let version = Sys.ocaml_version end module Make (Ast : Camlp4.Sig.Camlp4Ast.S) = struct module Ast = Ast open Ast let _loc = Loc.ghost let parse_implem ?directive_handler:(_) _ _ = let e = Ast.ExApp (_loc, Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdAcc (_loc, Ast.IdUid (_loc, "G"), Ast.IdLid (_loc, "extend"))), Ast.ExTyc (_loc, Ast.ExId (_loc, Ast.IdLid (_loc, "expr")), Ast.TyApp (_loc, Ast.TyId (_loc, Ast.IdAcc (_loc, Ast.IdUid (_loc, "G"), Ast.IdAcc (_loc, Ast.IdUid (_loc, "Entry"), Ast.IdLid (_loc, "t")))), Ast.TyQuo (_loc, "expr")))), Ast.ExTup (_loc, Ast.ExCom (_loc, Ast.ExId (_loc, Ast.IdUid (_loc, "None")), Ast.ExApp (_loc, Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdUid (_loc, "::")), Ast.ExTup (_loc, Ast.ExCom (_loc, Ast.ExId (_loc, Ast.IdUid (_loc, "None")), Ast.ExCom (_loc, Ast.ExId (_loc, Ast.IdUid (_loc, "None")), Ast.ExApp (_loc, Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdUid (_loc, "::")), Ast.ExTup (_loc, Ast.ExCom (_loc, Ast.ExApp (_loc, Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdUid (_loc, "::")), Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdAcc (_loc, Ast.IdUid (_loc, "G"), Ast.IdUid (_loc, "Skeyword"))), Ast.ExStr (_loc, "foo"))), Ast.ExId (_loc, Ast.IdUid (_loc, "[]"))), Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdAcc (_loc, Ast.IdUid (_loc, "G"), Ast.IdAcc (_loc, Ast.IdUid (_loc, "Action"), Ast.IdLid (_loc, "mk")))), Ast.ExFun (_loc, Ast.AsArr (_loc, Ast.PaAny _loc, Ast.ONone, Ast.ExFun (_loc, Ast.AsArr (_loc, Ast.PaTyc (_loc, Ast.PaId (_loc, Ast.IdLid (_loc, "_loc")), Ast.TyId (_loc, Ast.IdAcc (_loc, Ast.IdUid (_loc, "Loc"), Ast.IdLid (_loc, "t")))), Ast.ONone, Ast.ExTyc (_loc, Ast.ExApp (_loc, Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), Ast.IdUid (_loc, "ExId"))), Ast.ExId (_loc, Ast.IdLid (_loc, "_loc"))), Ast.ExApp (_loc, Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), Ast.IdUid (_loc, "IdLid"))), Ast.ExId (_loc, Ast.IdLid (_loc, "_loc"))), Ast.ExStr (_loc, "foo"))), Ast.TyQuo (_loc, "expr")))))))))), Ast.ExId (_loc, Ast.IdUid (_loc, "[]"))))))), Ast.ExId (_loc, Ast.IdUid (_loc, "[]")))))) in Ast.StExp (_loc, e) let parse_interf ?directive_handler:(_) _ _ = assert false;; end;; let module M = Camlp4.Register.OCamlParser(Id)(Make) in () mingw-ocaml/ocaml/camlp4/test/fixtures/backquoted_irrefutable_tuple.ml0000644000175000017500000000006112124403240025733 0ustar tootstootsEXTEND Gram abc: [ [ `(x,y) -> x + y ] ]; END; mingw-ocaml/ocaml/camlp4/test/fixtures/type.ml0000644000175000017500000000014212124403240020775 0ustar tootstootstype t = [ A of int | B of t ]; type t2 = [ A of int | B of t ]; type t3 = [ A of int | B of t ]; mingw-ocaml/ocaml/camlp4/camlp4fulllib.mllib0000644000175000017500000000177112124403240020416 0ustar tootstootsCamlp4 Camlp4_import Camlp4_config Camlp4Parsers/Camlp4AstLoader Camlp4Parsers/Camlp4DebugParser Camlp4Parsers/Camlp4GrammarParser Camlp4Parsers/Camlp4ListComprehension Camlp4Parsers/Camlp4MacroParser Camlp4Parsers/Camlp4OCamlOriginalQuotationExpander Camlp4Parsers/Camlp4OCamlParser Camlp4Parsers/Camlp4OCamlParserParser Camlp4Parsers/Camlp4OCamlRevisedParser Camlp4Parsers/Camlp4OCamlRevisedParserParser Camlp4Parsers/Camlp4OCamlRevisedQuotationExpander Camlp4Parsers/Camlp4QuotationCommon Camlp4Parsers/Camlp4QuotationExpander Camlp4Printers/Camlp4AstDumper Camlp4Printers/Camlp4AutoPrinter Camlp4Printers/Camlp4NullDumper Camlp4Printers/Camlp4OCamlAstDumper Camlp4Printers/Camlp4OCamlPrinter Camlp4Printers/Camlp4OCamlRevisedPrinter Camlp4Filters/Camlp4AstLifter Camlp4Filters/Camlp4ExceptionTracer Camlp4Filters/Camlp4FoldGenerator Camlp4Filters/Camlp4LocationStripper Camlp4Filters/Camlp4MapGenerator Camlp4Filters/Camlp4MetaGenerator Camlp4Filters/Camlp4Profiler Camlp4Filters/Camlp4TrashRemover Camlp4Top mingw-ocaml/ocaml/camlp4/camlp4.odocl0000644000175000017500000000001312124403240017031 0ustar tootstootsCamlp4/Sig mingw-ocaml/ocaml/man/0000755000175000017500000000000012124403240014230 5ustar tootstootsmingw-ocaml/ocaml/man/ocamlopt.m0000644000175000017500000004354512124403240016237 0ustar tootstoots.\"*********************************************************************** .\"* * .\"* OCaml * .\"* * .\"* Xavier Leroy, projet Cristal, INRIA Rocquencourt * .\"* * .\"* Copyright 1996 Institut National de Recherche en Informatique et * .\"* en Automatique. All rights reserved. This file is distributed * .\"* under the terms of the Q Public License version 1.0. * .\"* * .\"*********************************************************************** .\" .\" $Id$ .\" .TH OCAMLOPT 1 .SH NAME ocamlopt \- The OCaml native-code compiler .SH SYNOPSIS .B ocamlopt [ .I options ] .IR filename \ ... .B ocamlopt.opt (same options) .SH DESCRIPTION The OCaml high-performance native-code compiler .BR ocamlopt (1) compiles OCaml source files to native code object files and link these object files to produce standalone executables. The .BR ocamlopt (1) command has a command-line interface very close to that of .BR ocamlc (1). It accepts the same types of arguments and processes them sequentially: Arguments ending in .mli are taken to be source files for compilation unit interfaces. Interfaces specify the names exported by compilation units: they declare value names with their types, define public data types, declare abstract data types, and so on. From the file .IR x .mli, the .BR ocamlopt (1) compiler produces a compiled interface in the file .IR x .cmi. The interface produced is identical to that produced by the bytecode compiler .BR ocamlc (1). Arguments ending in .ml are taken to be source files for compilation unit implementations. Implementations provide definitions for the names exported by the unit, and also contain expressions to be evaluated for their side-effects. From the file .IR x .ml, the .BR ocamlopt (1) compiler produces two files: .IR x .o, containing native object code, and .IR x .cmx, containing extra information for linking and optimization of the clients of the unit. The compiled implementation should always be referred to under the name .IR x .cmx (when given a .o file, .BR ocamlopt (1) assumes that it contains code compiled from C, not from OCaml). The implementation is checked against the interface file .IR x .mli (if it exists) as described in the manual for .BR ocamlc (1). Arguments ending in .cmx are taken to be compiled object code. These files are linked together, along with the object files obtained by compiling .ml arguments (if any), and the OCaml standard library, to produce a native-code executable program. The order in which .cmx and .ml arguments are presented on the command line is relevant: compilation units are initialized in that order at run-time, and it is a link-time error to use a component of a unit before having initialized it. Hence, a given .IR x .cmx file must come before all .cmx files that refer to the unit .IR x . Arguments ending in .cmxa are taken to be libraries of object code. Such a library packs in two files .IR lib .cmxa and .IR lib .a a set of object files (.cmx/.o files). Libraries are build with .B ocamlopt \-a (see the description of the .B \-a option below). The object files contained in the library are linked as regular .cmx files (see above), in the order specified when the library was built. The only difference is that if an object file contained in a library is not referenced anywhere in the program, then it is not linked in. Arguments ending in .c are passed to the C compiler, which generates a .o object file. This object file is linked with the program. Arguments ending in .o or .a are assumed to be C object files and libraries. They are linked with the program. The output of the linking phase is a regular Unix executable file. It does not need .BR ocamlrun (1) to run. .B ocamlopt.opt is the same compiler as .BR ocamlopt , but compiled with itself instead of with the bytecode compiler .BR ocamlc (1). Thus, it behaves exactly like .BR ocamlopt , but compiles faster. .B ocamlopt.opt is not available in all installations of OCaml. .SH OPTIONS The following command-line options are recognized by .BR ocamlopt (1). .TP .B \-a Build a library (.cmxa/.a file) with the object files (.cmx/.o files) given on the command line, instead of linking them into an executable file. The name of the library must be set with the .B \-o option. If .BR \-cclib \ or \ \-ccopt options are passed on the command line, these options are stored in the resulting .cmxa library. Then, linking with this library automatically adds back the .BR \-cclib \ and \ \-ccopt options as if they had been provided on the command line, unless the .B \-noautolink option is given. .TP .B \-annot Dump detailed information about the compilation (types, bindings, tail-calls, etc). The information for file .IR src .ml is put into file .IR src .annot. In case of a type error, dump all the information inferred by the type-checker before the error. The .IR src .annot file can be used with the emacs commands given in .B emacs/caml\-types.el to display types and other annotations interactively. .TP .B \-dtypes Has been deprecated. Please use .BI \-annot instead. .TP .B \-c Compile only. Suppress the linking phase of the compilation. Source code files are turned into compiled files, but no executable file is produced. This option is useful to compile modules separately. .TP .BI \-cc \ ccomp Use .I ccomp as the C linker called to build the final executable and as the C compiler for compiling .c source files. .TP .BI \-cclib\ \-l libname Pass the .BI \-l libname option to the linker. This causes the given C library to be linked with the program. .TP .BI \-ccopt \ option Pass the given option to the C compiler and linker. For instance, .BI \-ccopt\ \-L dir causes the C linker to search for C libraries in directory .IR dir . .TP .B \-compact Optimize the produced code for space rather than for time. This results in smaller but slightly slower programs. The default is to optimize for speed. .TP .B \-config Print the version number of .BR ocamlopt (1) and a detailed summary of its configuration, then exit. .TP .BI \-for\-pack \ module\-path Generate an object file (.cmx and .o files) that can later be included as a sub-module (with the given access path) of a compilation unit constructed with .BR \-pack . For instance, .B ocamlopt\ \-for\-pack\ P\ \-c\ A.ml will generate a.cmx and a.o files that can later be used with .BR "ocamlopt -pack -o P.cmx a.cmx" . .TP .B \-g Add debugging information while compiling and linking. This option is required in order to produce stack backtraces when the program terminates on an uncaught exception (see .BR ocamlrun (1)). .TP .B \-i Cause the compiler to print all defined names (with their inferred types or their definitions) when compiling an implementation (.ml file). No compiled files (.cmo and .cmi files) are produced. This can be useful to check the types inferred by the compiler. Also, since the output follows the syntax of interfaces, it can help in writing an explicit interface (.mli file) for a file: just redirect the standard output of the compiler to a .mli file, and edit that file to remove all declarations of unexported names. .TP .BI \-I \ directory Add the given directory to the list of directories searched for compiled interface files (.cmi) and compiled object code files (.cmo). By default, the current directory is searched first, then the standard library directory. Directories added with \-I are searched after the current directory, in the order in which they were given on the command line, but before the standard library directory. If the given directory starts with .BR + , it is taken relative to the standard library directory. For instance, .B \-I\ +labltk adds the subdirectory .B labltk of the standard library to the search path. .TP .BI \-inline \ n Set aggressiveness of inlining to .IR n , where .I n is a positive integer. Specifying .B \-inline 0 prevents all functions from being inlined, except those whose body is smaller than the call site. Thus, inlining causes no expansion in code size. The default aggressiveness, .BR \-inline\ 1 , allows slightly larger functions to be inlined, resulting in a slight expansion in code size. Higher values for the .B \-inline option cause larger and larger functions to become candidate for inlining, but can result in a serious increase in code size. .TP .BI \-intf \ filename Compile the file .I filename as an interface file, even if its extension is not .mli. .TP .BI \-intf\-suffix \ string Recognize file names ending with .I string as interface files (instead of the default .mli). .TP .B \-labels Labels are not ignored in types, labels may be used in applications, and labelled parameters can be given in any order. This is the default. .TP .B \-linkall Force all modules contained in libraries to be linked in. If this flag is not given, unreferenced modules are not linked in. When building a library .RB ( \-a flag), setting the .B \-linkall flag forces all subsequent links of programs involving that library to link all the modules contained in the library. .TP .B \-noassert Do not compile assertion checks. Note that the special form .B assert\ false is always compiled because it is typed specially. This flag has no effect when linking already-compiled files. .TP .B \-noautolink When linking .cmxa libraries, ignore .BR \-cclib \ and \ \-ccopt options potentially contained in the libraries (if these options were given when building the libraries). This can be useful if a library contains incorrect specifications of C libraries or C options; in this case, during linking, set .B -noautolink and pass the correct C libraries and options on the command line. .TP .B \-nodynlink Allow the compiler to use some optimizations that are valid only for code that is never dynlinked. .TP .B \-nolabels Ignore non-optional labels in types. Labels cannot be used in applications, and parameter order becomes strict. .TP .BI \-o \ exec\-file Specify the name of the output file produced by the linker. The default output name is a.out, in keeping with the Unix tradition. If the .B \-a option is given, specify the name of the library produced. If the .B \-pack option is given, specify the name of the packed object file produced. If the .B \-output\-obj option is given, specify the name of the output file produced. If the .B \-shared option is given, specify the name of plugin file produced. .TP .B \-output\-obj Cause the linker to produce a C object file instead of an executable file. This is useful to wrap OCaml code as a C library, callable from any C program. The name of the output object file must be set with the .B \-o option. This option can also be used to produce a compiled shared/dynamic library (.so extension). .TP .B \-p Generate extra code to write profile information when the program is executed. The profile information can then be examined with the analysis program .BR gprof (1). The .B \-p option must be given both at compile-time and at link-time. Linking object files not compiled with .B \-p is possible, but results in less precise profiling. See the .BR gprof (1) man page for more information about the profiles. Full support for .BR gprof (1) is only available for certain platforms (currently: Intel x86/Linux and Alpha/Digital Unix). On other platforms, the .B \-p option will result in a less precise profile (no call graph information, only a time profile). .TP .B \-pack Build an object file (.cmx and .o files) and its associated compiled interface (.cmi) that combines the .cmx object files given on the command line, making them appear as sub-modules of the output .cmx file. The name of the output .cmx file must be given with the .B \-o option. For instance, .B ocamlopt\ -pack\ -o\ P.cmx\ A.cmx\ B.cmx\ C.cmx generates compiled files P.cmx, P.o and P.cmi describing a compilation unit having three sub-modules A, B and C, corresponding to the contents of the object files A.cmx, B.cmx and C.cmx. These contents can be referenced as P.A, P.B and P.C in the remainder of the program. The .cmx object files being combined must have been compiled with the appropriate .B \-for\-pack option. In the example above, A.cmx, B.cmx and C.cmx must have been compiled with .BR ocamlopt\ \-for\-pack\ P . Multiple levels of packing can be achieved by combining .B \-pack with .BR \-for\-pack . See .IR "The OCaml user's manual" , chapter "Native-code compilation" for more details. .TP .BI \-pp \ command Cause the compiler to call the given .I command as a preprocessor for each source file. The output of .I command is redirected to an intermediate file, which is compiled. If there are no compilation errors, the intermediate file is deleted afterwards. .TP .B \-principal Check information path during type-checking, to make sure that all types are derived in a principal way. All programs accepted in .B \-principal mode are also accepted in default mode with equivalent types, but different binary signatures. .TP .B \-rectypes Allow arbitrary recursive types during type-checking. By default, only recursive types where the recursion goes through an object type are supported. Note that once you have created an interface using this flag, you must use it again for all dependencies. .TP .BI \-runtime\-variant \ suffix Add .I suffix to the name of the runtime library that will be used by the program. If OCaml was configured with option .BR \-with\-debug\-runtime , then the .B d suffix is supported and gives a debug version of the runtime. .TP .B \-S Keep the assembly code produced during the compilation. The assembly code for the source file .IR x .ml is saved in the file .IR x .s. .TP .B \-shared Build a plugin (usually .cmxs) that can be dynamically loaded with the .B Dynlink module. The name of the plugin must be set with the .B \-o option. A plugin can include a number of OCaml modules and libraries, and extra native objects (.o, .a files). Building native plugins is only supported for some operating system. Under some systems (currently, only Linux AMD 64), all the OCaml code linked in a plugin must have been compiled without the .B \-nodynlink flag. Some constraints might also apply to the way the extra native objects have been compiled (under Linux AMD 64, they must contain only position-independent code). .TP .B \-strict\-sequence The left-hand part of a sequence must have type unit. .TP .B \-thread Compile or link multithreaded programs, in combination with the system threads library described in .IR "The OCaml user's manual" . .TP .B \-unsafe Turn bound checking off for array and string accesses (the .BR v.(i) and s.[i] constructs). Programs compiled with .B \-unsafe are therefore faster, but unsafe: anything can happen if the program accesses an array or string outside of its bounds. Additionally, turn off the check for zero divisor in integer division and modulus operations. With .BR \-unsafe , an integer division (or modulus) by zero can halt the program or continue with an unspecified result instead of raising a .B Division_by_zero exception. .TP .B \-v Print the version number of the compiler and the location of the standard library directory, then exit. .TP .B \-verbose Print all external commands before they are executed, in particular invocations of the assembler, C compiler, and linker. .TP .BR \-vnum or \-version Print the version number of the compiler in short form (e.g. "3.11.0"), then exit. .TP .BI \-w \ warning\-list Enable, disable, or mark as errors the warnings specified by the argument .IR warning\-list . See .BR ocamlc (1) for the syntax of .IR warning-list . .TP .BI \-warn\-error \ warning\-list Mark as errors the warnings specified in the argument .IR warning\-list . The compiler will stop with an error when one of these warnings is emitted. The .I warning\-list has the same meaning as for the .B \-w option: a .B + sign (or an uppercase letter) turns the corresponding warnings into errors, a .B \- sign (or a lowercase letter) turns them back into warnings, and a .B @ sign both enables and marks the corresponding warnings. Note: it is not recommended to use the .B \-warn\-error option in production code, because it will almost certainly prevent compiling your program with later versions of OCaml when they add new warnings. The default setting is .B \-warn\-error\ -a (none of the warnings is treated as an error). .TP .B \-where Print the location of the standard library, then exit. .TP .BI \- \ file Process .I file as a file name, even if it starts with a dash (-) character. .TP .BR \-help \ or \ \-\-help Display a short usage summary and exit. .SH OPTIONS FOR THE IA32 ARCHITECTURE The IA32 code generator (Intel Pentium, AMD Athlon) supports the following additional option: .TP .B \-ffast\-math Use the IA32 instructions to compute trigonometric and exponential functions, instead of calling the corresponding library routines. The functions affected are: .BR atan , .BR atan2 , .BR cos , .BR log , .BR log10 , .BR sin , .B sqrt and .BR tan . The resulting code runs faster, but the range of supported arguments and the precision of the result can be reduced. In particular, trigonometric operations .BR cos , .BR sin , .B tan have their range reduced to [\-2^64, 2^64]. .SH OPTIONS FOR THE AMD64 ARCHITECTURE The AMD64 code generator (64-bit versions of Intel Pentium and AMD Athlon) supports the following additional options: .TP .B \-fPIC Generate position-independent machine code. This is the default. .TP .B \-fno\-PIC Generate position-dependent machine code. .SH OPTIONS FOR THE SPARC ARCHITECTURE The Sparc code generator supports the following additional options: .TP .B \-march=v8 Generate SPARC version 8 code. .TP .B \-march=v9 Generate SPARC version 9 code. .P The default is to generate code for SPARC version 7, which runs on all SPARC processors. .SH SEE ALSO .BR ocamlc (1). .br .IR "The OCaml user's manual" , chapter "Native-code compilation". mingw-ocaml/ocaml/man/ocamlcp.m0000644000175000017500000000620212124403240016024 0ustar tootstoots.\"*********************************************************************** .\"* * .\"* OCaml * .\"* * .\"* Xavier Leroy, projet Cristal, INRIA Rocquencourt * .\"* * .\"* Copyright 1996 Institut National de Recherche en Informatique et * .\"* en Automatique. All rights reserved. This file is distributed * .\"* under the terms of the Q Public License version 1.0. * .\"* * .\"*********************************************************************** .\" .\" $Id$ .\" .TH "OCAMLCP" 1 .SH NAME ocamlcp, ocamloptp \- The OCaml profiling compilers .SH SYNOPSIS .B ocamlcp [ .I ocamlc options ] [ .BI \-P \ flags ] .I filename ... .B ocamloptp [ .I ocamlopt options ] [ .BI \-P \ flags ] .I filename ... .SH DESCRIPTION The .B ocamlcp and .B ocamloptp commands are front-ends to .BR ocamlc (1) and .BR ocamlopt (1) that instrument the source code, adding code to record how many times functions are called, branches of conditionals are taken, etc. Execution of instrumented code produces an execution profile in the file ocamlprof.dump, which can be read using .BR ocamlprof (1). .B ocamlcp accepts the same arguments and options as .BR ocamlc (1) and .B ocamloptp accepts the same arguments and options as .BR ocamlopt (1). There is only one exception: in both cases, the .B \-pp option is not supported. If you need to preprocess your source files, you will have to do it separately before calling .B ocamlcp or .BR ocamloptp . .SH OPTIONS In addition to the .BR ocamlc (1) or .BR ocamlopt (1) options, .B ocamlcp and .B ocamloptp accept one option to control the kind of profiling information, the .BI \-P \ letters option. The .I letters indicate which parts of the program should be profiled: .TP .B a all options .TP .B f function calls : a count point is set at the beginning of each function body .TP .B i .BR if \ ... \ then \ ... \ else : count points are set in both .BR then \ and \ else branches .TP .B l .BR while , \ for loops: a count point is set at the beginning of the loop body .TP .B m .B match branches: a count point is set at the beginning of the body of each branch of a pattern-matching .TP .B t .BR try \ ... \ with branches: a count point is set at the beginning of the body of each branch of an exception catcher .PP For instance, compiling with .B ocamlcp \-P film profiles function calls, .BR if \ ... \ then \ ... \ else \ ..., loops, and pattern matching. Calling .BR ocamlcp (1) or .BR ocamloptp (1) without the .B \-P option defaults to .BR \-P\ fm , meaning that only function calls and pattern matching are profiled. Note: for compatibility with previous versions, .BR ocamlcp (1) also accepts the option .B \-p with the same argument and meaning as .BR \-P . .SH SEE ALSO .BR ocamlc (1), .BR ocamlopt (1), .BR ocamlprof (1). .br .IR "The OCaml user's manual" , chapter "Profiling". mingw-ocaml/ocaml/man/ocamlyacc.m0000644000175000017500000000562212124403240016346 0ustar tootstoots.\"*********************************************************************** .\"* * .\"* OCaml * .\"* * .\"* Xavier Leroy, projet Cristal, INRIA Rocquencourt * .\"* * .\"* Copyright 1996 Institut National de Recherche en Informatique et * .\"* en Automatique. All rights reserved. This file is distributed * .\"* under the terms of the Q Public License version 1.0. * .\"* * .\"*********************************************************************** .\" .\" $Id$ .\" .TH OCAMLYACC 1 .SH NAME ocamlyacc \- The OCaml parser generator .SH SYNOPSIS .B ocamlyacc [ .BI \-b prefix ] [ .B \-q ] [ .B \-v ] [ .B \-version ] [ .B \-vnum ] .I filename.mly .SH DESCRIPTION The .BR ocamlyacc (1) command produces a parser from a LALR(1) context-free grammar specification with attached semantic actions, in the style of .BR yacc (1). Assuming the input file is .IR grammar \&.mly, running .B ocamlyacc produces OCaml code for a parser in the file .IR grammar \&.ml, and its interface in file .IR grammar \&.mli. The generated module defines one parsing function per entry point in the grammar. These functions have the same names as the entry points. Parsing functions take as arguments a lexical analyzer (a function from lexer buffers to tokens) and a lexer buffer, and return the semantic attribute of the corresponding entry point. Lexical analyzer functions are usually generated from a lexer specification by the .BR ocamllex (1) program. Lexer buffers are an abstract data type implemented in the standard library module Lexing. Tokens are values from the concrete type token, defined in the interface file .IR grammar \&.mli produced by .BR ocamlyacc (1). .SH OPTIONS The .BR ocamlyacc (1) command recognizes the following options: .TP .BI \-b prefix Name the output files .IR prefix \&.ml, .IR prefix \&.mli, .IR prefix \&.output, instead of the default naming convention. .TP .B \-q This option has no effect. .TP .B \-v Generate a description of the parsing tables and a report on conflicts resulting from ambiguities in the grammar. The description is put in file .IR grammar .output. .TP .B \-version Print version string and exit. .TP .B \-vnum Print short version number and exit. .TP .B \- Read the grammar specification from standard input. The default output file names are stdin.ml and stdin.mli. .TP .BI \-\- \ file Process .I file as the grammar specification, even if its name starts with a dash (-) character. This option must be the last on the command line. .SH SEE ALSO .BR ocamllex (1). .br .IR "The OCaml user's manual" , chapter "Lexer and parser generators". mingw-ocaml/ocaml/man/Makefile0000644000175000017500000000222612124403240015672 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # $Id$ include ../config/Makefile DIR=$(MANDIR)/man$(MANEXT) install: for i in *.m; do cp $$i $(DIR)/`basename $$i .m`.$(MANEXT); done echo '.so man$(MANEXT)/ocamlc.$(MANEXT)' > $(DIR)/ocamlc.opt.$(MANEXT) echo '.so man$(MANEXT)/ocamlopt.$(MANEXT)' > $(DIR)/ocamlopt.opt.$(MANEXT) echo '.so man$(MANEXT)/ocamlcp.$(MANEXT)' > $(DIR)/ocamloptp.$(MANEXT) mingw-ocaml/ocaml/man/ocamlc.m0000644000175000017500000005214412124403240015652 0ustar tootstoots.\"*********************************************************************** .\"* * .\"* OCaml * .\"* * .\"* Xavier Leroy, projet Cristal, INRIA Rocquencourt * .\"* * .\"* Copyright 1996 Institut National de Recherche en Informatique et * .\"* en Automatique. All rights reserved. This file is distributed * .\"* under the terms of the Q Public License version 1.0. * .\"* * .\"*********************************************************************** .\" .\" $Id$ .\" .TH OCAMLC 1 .SH NAME ocamlc \- The OCaml bytecode compiler .SH SYNOPSIS .B ocamlc [ .I options ] .I filename ... .B ocamlc.opt [ .I options ] .I filename ... .SH DESCRIPTION The OCaml bytecode compiler .BR ocamlc (1) compiles OCaml source files to bytecode object files and links these object files to produce standalone bytecode executable files. These executable files are then run by the bytecode interpreter .BR ocamlrun (1). The .BR ocamlc (1) command has a command-line interface similar to the one of most C compilers. It accepts several types of arguments and processes them sequentially: Arguments ending in .mli are taken to be source files for compilation unit interfaces. Interfaces specify the names exported by compilation units: they declare value names with their types, define public data types, declare abstract data types, and so on. From the file .IR x \&.mli, the .BR ocamlc (1) compiler produces a compiled interface in the file .IR x \&.cmi. Arguments ending in .ml are taken to be source files for compilation unit implementations. Implementations provide definitions for the names exported by the unit, and also contain expressions to be evaluated for their side-effects. From the file .IR x \&.ml, the .BR ocamlc (1) compiler produces compiled object bytecode in the file .IR x \&.cmo. If the interface file .IR x \&.mli exists, the implementation .IR x \&.ml is checked against the corresponding compiled interface .IR x \&.cmi, which is assumed to exist. If no interface .IR x \&.mli is provided, the compilation of .IR x \&.ml produces a compiled interface file .IR x \&.cmi in addition to the compiled object code file .IR x \&.cmo. The file .IR x \&.cmi produced corresponds to an interface that exports everything that is defined in the implementation .IR x \&.ml. Arguments ending in .cmo are taken to be compiled object bytecode. These files are linked together, along with the object files obtained by compiling .ml arguments (if any), and the OCaml standard library, to produce a standalone executable program. The order in which .cmo and.ml arguments are presented on the command line is relevant: compilation units are initialized in that order at run-time, and it is a link-time error to use a component of a unit before having initialized it. Hence, a given .IR x \&.cmo file must come before all .cmo files that refer to the unit .IR x . Arguments ending in .cma are taken to be libraries of object bytecode. A library of object bytecode packs in a single file a set of object bytecode files (.cmo files). Libraries are built with .B ocamlc\ \-a (see the description of the .B \-a option below). The object files contained in the library are linked as regular .cmo files (see above), in the order specified when the .cma file was built. The only difference is that if an object file contained in a library is not referenced anywhere in the program, then it is not linked in. Arguments ending in .c are passed to the C compiler, which generates a .o object file. This object file is linked with the program if the .B \-custom flag is set (see the description of .B \-custom below). Arguments ending in .o or .a are assumed to be C object files and libraries. They are passed to the C linker when linking in .B \-custom mode (see the description of .B \-custom below). Arguments ending in .so are assumed to be C shared libraries (DLLs). During linking, they are searched for external C functions referenced from the OCaml code, and their names are written in the generated bytecode executable. The run-time system .BR ocamlrun (1) then loads them dynamically at program start-up time. The output of the linking phase is a file containing compiled bytecode that can be executed by the OCaml bytecode interpreter: the command .BR ocamlrun (1). If .B caml.out is the name of the file produced by the linking phase, the command .B ocamlrun caml.out .IR arg1 \ \ arg2 \ ... \ argn executes the compiled code contained in .BR caml.out , passing it as arguments the character strings .I arg1 to .IR argn . (See .BR ocamlrun (1) for more details.) On most systems, the file produced by the linking phase can be run directly, as in: .B ./caml.out .IR arg1 \ \ arg2 \ ... \ argn . The produced file has the executable bit set, and it manages to launch the bytecode interpreter by itself. .B ocamlc.opt is the same compiler as .BR ocamlc , but compiled with the native-code compiler .BR ocamlopt (1). Thus, it behaves exactly like .BR ocamlc , but compiles faster. .B ocamlc.opt may not be available in all installations of OCaml. .SH OPTIONS The following command-line options are recognized by .BR ocamlc (1). .TP .B \-a Build a library (.cma file) with the object files (.cmo files) given on the command line, instead of linking them into an executable file. The name of the library must be set with the .B \-o option. .IP If .BR \-custom , \ \-cclib \ or \ \-ccopt options are passed on the command line, these options are stored in the resulting .cma library. Then, linking with this library automatically adds back the .BR \-custom , \ \-cclib \ and \ \-ccopt options as if they had been provided on the command line, unless the .B -noautolink option is given. .TP .B \-annot Dump detailed information about the compilation (types, bindings, tail-calls, etc). The information for file .IR src .ml is put into file .IR src .annot. In case of a type error, dump all the information inferred by the type-checker before the error. The .IR src .annot file can be used with the emacs commands given in .B emacs/caml\-types.el to display types and other annotations interactively. .TP .B \-dtypes Has been deprecated. Please use .B \-annot instead. .TP .B \-c Compile only. Suppress the linking phase of the compilation. Source code files are turned into compiled files, but no executable file is produced. This option is useful to compile modules separately. .TP .BI \-cc \ ccomp Use .I ccomp as the C linker when linking in "custom runtime" mode (see the .B \-custom option) and as the C compiler for compiling .c source files. .TP .BI \-cclib\ -l libname Pass the .BI \-l libname option to the C linker when linking in "custom runtime" mode (see the .B \-custom option). This causes the given C library to be linked with the program. .TP .B \-ccopt Pass the given option to the C compiler and linker, when linking in "custom runtime" mode (see the .B \-custom option). For instance, .BI \-ccopt\ \-L dir causes the C linker to search for C libraries in directory .IR dir . .TP .B \-config Print the version number of .BR ocamlc (1) and a detailed summary of its configuration, then exit. .TP .B \-custom Link in "custom runtime" mode. In the default linking mode, the linker produces bytecode that is intended to be executed with the shared runtime system, .BR ocamlrun (1). In the custom runtime mode, the linker produces an output file that contains both the runtime system and the bytecode for the program. The resulting file is larger, but it can be executed directly, even if the .BR ocamlrun (1) command is not installed. Moreover, the "custom runtime" mode enables linking OCaml code with user-defined C functions. Never use the .BR strip (1) command on executables produced by .BR ocamlc\ \-custom , this would remove the bytecode part of the executable. .TP .BI \-dllib\ \-l libname Arrange for the C shared library .BI dll libname .so to be loaded dynamically by the run-time system .BR ocamlrun (1) at program start-up time. .TP .BI \-dllpath \ dir Adds the directory .I dir to the run-time search path for shared C libraries. At link-time, shared libraries are searched in the standard search path (the one corresponding to the .B \-I option). The .B \-dllpath option simply stores .I dir in the produced executable file, where .BR ocamlrun (1) can find it and use it. .TP .B \-g Add debugging information while compiling and linking. This option is required in order to be able to debug the program with .BR ocamldebug (1) and to produce stack backtraces when the program terminates on an uncaught exception. .TP .B \-i Cause the compiler to print all defined names (with their inferred types or their definitions) when compiling an implementation (.ml file). No compiled files (.cmo and .cmi files) are produced. This can be useful to check the types inferred by the compiler. Also, since the output follows the syntax of interfaces, it can help in writing an explicit interface (.mli file) for a file: just redirect the standard output of the compiler to a .mli file, and edit that file to remove all declarations of unexported names. .TP .BI \-I \ directory Add the given directory to the list of directories searched for compiled interface files (.cmi), compiled object code files (.cmo), libraries (.cma), and C libraries specified with .B \-cclib\ \-l .IR xxx . By default, the current directory is searched first, then the standard library directory. Directories added with .B -I are searched after the current directory, in the order in which they were given on the command line, but before the standard library directory. If the given directory starts with .BR + , it is taken relative to the standard library directory. For instance, .B \-I\ +labltk adds the subdirectory .B labltk of the standard library to the search path. .TP .BI \-impl \ filename Compile the file .I filename as an implementation file, even if its extension is not .ml. .TP .BI \-intf \ filename Compile the file .I filename as an interface file, even if its extension is not .mli. .TP .BI \-intf\-suffix \ string Recognize file names ending with .I string as interface files (instead of the default .mli). .TP .B \-labels Labels are not ignored in types, labels may be used in applications, and labelled parameters can be given in any order. This is the default. .TP .B \-linkall Force all modules contained in libraries to be linked in. If this flag is not given, unreferenced modules are not linked in. When building a library (option .BR \-a ), setting the .B \-linkall option forces all subsequent links of programs involving that library to link all the modules contained in the library. .TP .B \-make\-runtime Build a custom runtime system (in the file specified by option .BR \-o ) incorporating the C object files and libraries given on the command line. This custom runtime system can be used later to execute bytecode executables produced with the option .B ocamlc\ \-use\-runtime .IR runtime-name . .TP .B \-noassert Do not compile assertion checks. Note that the special form .B assert\ false is always compiled because it is typed specially. This flag has no effect when linking already-compiled files. .TP .B \-noautolink When linking .cma libraries, ignore .BR \-custom , \ \-cclib \ and \ \-ccopt options potentially contained in the libraries (if these options were given when building the libraries). This can be useful if a library contains incorrect specifications of C libraries or C options; in this case, during linking, set .B \-noautolink and pass the correct C libraries and options on the command line. .TP .B \-nolabels Ignore non-optional labels in types. Labels cannot be used in applications, and parameter order becomes strict. .TP .BI \-o \ exec\-file Specify the name of the output file produced by the linker. The default output name is .BR a.out , in keeping with the Unix tradition. If the .B \-a option is given, specify the name of the library produced. If the .B \-pack option is given, specify the name of the packed object file produced. If the .B \-output\-obj option is given, specify the name of the output file produced. .TP .B \-output\-obj Cause the linker to produce a C object file instead of a bytecode executable file. This is useful to wrap OCaml code as a C library, callable from any C program. The name of the output object file must be set with the .B \-o option. This option can also be used to produce a C source file (.c extension) or a compiled shared/dynamic library (.so extension). .TP .B \-pack Build a bytecode object file (.cmo file) and its associated compiled interface (.cmi) that combines the object files given on the command line, making them appear as sub-modules of the output .cmo file. The name of the output .cmo file must be given with the .B \-o option. For instance, .B ocamlc\ \-pack\ \-o\ p.cmo\ a.cmo\ b.cmo\ c.cmo generates compiled files p.cmo and p.cmi describing a compilation unit having three sub-modules A, B and C, corresponding to the contents of the object files a.cmo, b.cmo and c.cmo. These contents can be referenced as P.A, P.B and P.C in the remainder of the program. .TP .BI \-pp \ command Cause the compiler to call the given .I command as a preprocessor for each source file. The output of .I command is redirected to an intermediate file, which is compiled. If there are no compilation errors, the intermediate file is deleted afterwards. The name of this file is built from the basename of the source file with the extension .ppi for an interface (.mli) file and .ppo for an implementation (.ml) file. .TP .B \-principal Check information path during type-checking, to make sure that all types are derived in a principal way. When using labelled arguments and/or polymorphic methods, this flag is required to ensure future versions of the compiler will be able to infer types correctly, even if internal algorithms change. All programs accepted in .B \-principal mode are also accepted in the default mode with equivalent types, but different binary signatures, and this may slow down type checking; yet it is a good idea to use it once before publishing source code. .TP .B \-rectypes Allow arbitrary recursive types during type-checking. By default, only recursive types where the recursion goes through an object type are supported. Note that once you have created an interface using this flag, you must use it again for all dependencies. .TP .BI \-runtime\-variant \ suffix Add .I suffix to the name of the runtime library that will be used by the program. If OCaml was configured with option .BR \-with\-debug\-runtime , then the .B d suffix is supported and gives a debug version of the runtime. .TP .B \-strict\-sequence The left-hand part of a sequence must have type unit. .TP .B \-thread Compile or link multithreaded programs, in combination with the system "threads" library described in .IR The\ OCaml\ user's\ manual . .TP .B \-unsafe Turn bound checking off for array and string accesses (the .BR v.(i) and s.[i] constructs). Programs compiled with .B \-unsafe are therefore slightly faster, but unsafe: anything can happen if the program accesses an array or string outside of its bounds. .TP .BI \-use\-runtime \ runtime\-name Generate a bytecode executable file that can be executed on the custom runtime system .IR runtime\-name , built earlier with .B ocamlc\ \-make\-runtime .IR runtime\-name . .TP .B \-v Print the version number of the compiler and the location of the standard library directory, then exit. .TP .B \-verbose Print all external commands before they are executed, in particular invocations of the C compiler and linker in .B \-custom mode. Useful to debug C library problems. .TP .BR \-vnum \ or\ \-version Print the version number of the compiler in short form (e.g. "3.11.0"), then exit. .TP .B \-vmthread Compile or link multithreaded programs, in combination with the VM-level threads library described in .IR The\ OCaml\ user's\ manual . .TP .BI \-w \ warning\-list Enable, disable, or mark as errors the warnings specified by the argument .IR warning\-list . Each warning can be .IR enabled \ or\ disabled , and each warning can be .I marked (as error) or .IR unmarked . If a warning is disabled, it isn't displayed and doesn't affect compilation in any way (even if it is marked). If a warning is enabled, it is displayed normally by the compiler whenever the source code triggers it. If it is enabled and marked, the compiler will stop with an error after displaying the warnings if the source code triggers it. The .I warning\-list argument is a sequence of warning specifiers, with no separators between them. A warning specifier is one of the following: .BI + num \ \ Enable warning number .IR num . .BI \- num \ \ Disable warning number .IR num . .BI @ num \ \ Enable and mark warning number .IR num . .BI + num1 .. num2 \ \ Enable all warnings between .I num1 and .I num2 (inclusive). .BI \- num1 .. num2 \ \ Disable all warnings between .I num1 and .I num2 (inclusive). .BI @ num1 .. num2 \ \ Enable and mark all warnings between .I num1 and .I num2 (inclusive). .BI + letter \ \ Enable the set of warnings corresponding to .IR letter . The letter may be uppercase or lowercase. .BI \- letter \ \ Disable the set of warnings corresponding to .IR letter . The letter may be uppercase or lowercase. .BI @ letter \ \ Enable and mark the set of warnings corresponding to .IR letter . The letter may be uppercase or lowercase. .I uppercase\-letter \ \ Enable the set of warnings corresponding to .IR uppercase\-letter . .I lowercase\-letter \ \ Disable the set of warnings corresponding to .IR lowercase\-letter . The warning numbers are as follows. 1 \ \ \ Suspicious-looking start-of-comment mark. 2 \ \ \ Suspicious-looking end-of-comment mark. 3 \ \ \ Deprecated syntax. 4 \ \ \ Fragile pattern matching: matching that will remain complete even if additional constructors are added to one of the variant types matched. 5 \ \ \ Partially applied function: expression whose result has function type and is ignored. 6 \ \ \ Label omitted in function application. 7 \ \ \ Method overridden without using the "method!" keyword 8 \ \ \ Partial match: missing cases in pattern-matching. 9 \ \ \ Missing fields in a record pattern. 10 \ \ Expression on the left-hand side of a sequence that doesn't have type .B unit (and that is not a function, see warning number 5). 11 \ \ Redundant case in a pattern matching (unused match case). 12 \ \ Redundant sub-pattern in a pattern-matching. 13 \ \ Override of an instance variable. 14 \ \ Illegal backslash escape in a string constant. 15 \ \ Private method made public implicitly. 16 \ \ Unerasable optional argument. 17 \ \ Undeclared virtual method. 18 \ \ Non-principal type. 19 \ \ Type without principality. 20 \ \ Unused function argument. 21 \ \ Non-returning statement. 22 \ \ Camlp4 warning. 23 \ \ Useless record .B with clause. 24 \ \ Bad module name: the source file name is not a valid OCaml module name. 25 \ \ Pattern-matching with all clauses guarded. 26 \ \ Suspicious unused variable: unused variable that is bound with .BR let \ or \ as , and doesn't start with an underscore (_) character. 27 \ \ Innocuous unused variable: unused variable that is not bound with .BR let \ nor \ as , and doesn't start with an underscore (_) character. 28 \ \ A pattern contains a constant constructor applied to the underscore (_) pattern. 29 \ \ A non-escaped end-of-line was found in a string constant. This may cause portability problems between Unix and Windows. The letters stand for the following sets of warnings. Any letter not mentioned here corresponds to the empty set. .B A \ all warnings .B C \ 1, 2 .B D \ 3 .B E \ 4 .B F \ 5 .B K \ 32, 33, 34, 35, 36, 37 .B L \ 6 .B M \ 7 .B P \ 8 .B R \ 9 .B S \ 10 .B U \ 11, 12 .B V \ 13 .B X \ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 30 .B Y \ 26 .B Z \ 27 .IP The default setting is .BR \-w\ +a\-4\-6\-9\-27\-29\-32..39 . Note that warnings .BR 5 \ and \ 10 are not always triggered, depending on the internals of the type checker. .TP .BI \-warn\-error \ warning\-list Mark as errors the warnings specified in the argument .IR warning\-list . The compiler will stop with an error when one of these warnings is emitted. The .I warning\-list has the same meaning as for the .B \-w option: a .B + sign (or an uppercase letter) turns the corresponding warnings into errors, a .B \- sign (or a lowercase letter) turns them back into warnings, and a .B @ sign both enables and marks the corresponding warnings. Note: it is not recommended to use the .B \-warn\-error option in production code, because it will almost certainly prevent compiling your program with later versions of OCaml when they add new warnings. The default setting is .B \-warn\-error\ -a (none of the warnings is treated as an error). .TP .B \-where Print the location of the standard library, then exit. .TP .BI \- \ file Process .I file as a file name, even if it starts with a dash (-) character. .TP .BR \-help \ or \ \-\-help Display a short usage summary and exit. .SH SEE ALSO .BR ocamlopt (1), \ ocamlrun (1), \ ocaml (1). .br .IR "The OCaml user's manual" , chapter "Batch compilation". mingw-ocaml/ocaml/man/ocaml.m0000644000175000017500000001370612124403240015510 0ustar tootstoots.\"*********************************************************************** .\"* * .\"* OCaml * .\"* * .\"* Xavier Leroy, projet Cristal, INRIA Rocquencourt * .\"* * .\"* Copyright 1996 Institut National de Recherche en Informatique et * .\"* en Automatique. All rights reserved. This file is distributed * .\"* under the terms of the Q Public License version 1.0. * .\"* * .\"*********************************************************************** .\" .\" $Id$ .\" .TH OCAML 1 .SH NAME ocaml \- The OCaml interactive toplevel .SH SYNOPSIS .B ocaml [ .I options ] [ .I object-files ] [ .I script-file ] .SH DESCRIPTION The .BR ocaml (1) command is the toplevel system for OCaml, that permits interactive use of the OCaml system through a read-eval-print loop. In this mode, the system repeatedly reads OCaml phrases from the input, then typechecks, compiles and evaluates them, then prints the inferred type and result value, if any. The system prints a # (sharp) prompt before reading each phrase. A toplevel phrase can span several lines. It is terminated by ;; (a double-semicolon). The syntax of toplevel phrases is as follows. The toplevel system is started by the command .BR ocaml (1). Phrases are read on standard input, results are printed on standard output, errors on standard error. End-of-file on standard input terminates .BR ocaml (1). If one or more .I object-files (ending in .cmo or .cma) are given, they are loaded silently before starting the toplevel. If a .I script-file is given, phrases are read silently from the file, errors printed on standard error. .BR ocaml (1) exits after the execution of the last phrase. .SH OPTIONS The following command-line options are recognized by .BR ocaml (1). .TP .BI \-I \ directory Add the given directory to the list of directories searched for source and compiled files. By default, the current directory is searched first, then the standard library directory. Directories added with .B \-I are searched after the current directory, in the order in which they were given on the command line, but before the standard library directory. .IP If the given directory starts with .BR + , it is taken relative to the standard library directory. For instance, .B \-I\ +labltk adds the subdirectory .B labltk of the standard library to the search path. .IP Directories can also be added to the search path once the toplevel is running with the .B #directory directive. .TP .BI \-init \ file Load the given file instead of the default initialization file. The default file is .B .ocamlinit in the current directory if it exists, otherwise .B .ocamlinit in the user's home directory. .TP .B \-labels Labels are not ignored in types, labels may be used in applications, and labelled parameters can be given in any order. This is the default. .TP .B \-noassert Do not compile assertion checks. Note that the special form .B assert\ false is always compiled because it is typed specially. .TP .B \-nolabels Ignore non-optional labels in types. Labels cannot be used in applications, and parameter order becomes strict. .TP .B \-noprompt Do not display any prompt when waiting for input. .TP .B \-nopromptcont Do not display the secondary prompt when waiting for continuation lines in multi-line inputs. This should be used e.g. when running .BR ocaml (1) in an .BR emacs (1) window. .TP .B \-nostdlib Do not include the standard library directory in the list of directories searched for source and compiled files. .TP .B \-principal Check information path during type-checking, to make sure that all types are derived in a principal way. When using labelled arguments and/or polymorphic methods, this flag is required to ensure future versions of the compiler will be able to infer types correctly, even if internal algorithms change. All programs accepted in .B \-principal mode are also accepted in the default mode with equivalent types, but different binary signatures, and this may slow down type checking; yet it is a good idea to use it once before publishing source code. .TP .B \-rectypes Allow arbitrary recursive types during type-checking. By default, only recursive types where the recursion goes through an object type are supported. .TP .B \-unsafe Turn bound checking off on array and string accesses (the .BR v.(i) and s.[i] constructs). Programs compiled with .B \-unsafe are therefore slightly faster, but unsafe: anything can happen if the program accesses an array or string outside of its bounds. .TP .B \-version Print version string and exit. .TP .B \-vnum Print short version number and exit. .TP .BI \-w \ warning-list Enable or disable warnings according to the argument .IR warning-list . See .BR ocamlc (1) for the syntax of the .I warning\-list argument. .TP .BI \-warn-error \ warning-list Treat as errors the warnings described by the argument .IR warning\-list . Note that a warning is not triggered (and not treated as error) if it is disabled by the .B \-w option. See .BR ocamlc (1) for the syntax of the .I warning\-list argument. .TP .BR \-help \ or \ \-\-help Display a short usage summary and exit. .SH ENVIRONMENT VARIABLES .TP .B LC_CTYPE If set to iso_8859_1, accented characters (from the ISO Latin-1 character set) in string and character literals are printed as is; otherwise, they are printed as decimal escape sequences. .TP .B TERM When printing error messages, the toplevel system attempts to underline visually the location of the error. It consults the TERM variable to determines the type of output terminal and look up its capabilities in the terminal database. .SH SEE ALSO .BR ocamlc (1), \ ocamlopt (1), \ ocamlrun (1). .br .IR The\ OCaml\ user's\ manual , chapter "The toplevel system". mingw-ocaml/ocaml/man/ocamlmktop.m0000644000175000017500000000467012124403240016563 0ustar tootstoots.\"*********************************************************************** .\"* * .\"* OCaml * .\"* * .\"* Xavier Leroy, projet Cristal, INRIA Rocquencourt * .\"* * .\"* Copyright 1999 Institut National de Recherche en Informatique et * .\"* en Automatique. All rights reserved. This file is distributed * .\"* under the terms of the Q Public License version 1.0. * .\"* * .\"*********************************************************************** .\" .\" $Id$ .\" .TH OCAMLMKTOP 1 .SH NAME ocamlmktop \- Building custom toplevel systems .SH SYNOPSIS .B ocamlmktop [ .BR \-v | \-version | \-vnum ] [ .BI \-cclib \ libname ] [ .BI \-ccopt \ option ] [ .B \-custom [ .BI \-o \ exec-file ] [ .BI \-I \ lib-dir ] .I filename ... .SH DESCRIPTION The .BR ocamlmktop (1) command builds OCaml toplevels that contain user code preloaded at start-up. The .BR ocamlmktop (1) command takes as argument a set of .IR x .cmo and .IR x .cma files, and links them with the object files that implement the OCaml toplevel. If the .B \-custom flag is given, C object files and libraries (.o and .a files) can also be given on the command line and are linked in the resulting toplevel. .SH OPTIONS The following command-line options are recognized by .BR ocamlmktop (1). .TP .B \-v Print the version string of the compiler and exit. .TP .BR \-vnum or \-version Print the version number of the compiler in short form and exit. .TP .BI \-cclib\ \-l libname Pass the .BI \-l libname option to the C linker when linking in ``custom runtime'' mode (see the corresponding option for .BR ocamlc (1). .TP .B \-ccopt Pass the given option to the C compiler and linker, when linking in ``custom runtime'' mode. See the corresponding option for .BR ocamlc (1). .TP .B \-custom Link in ``custom runtime'' mode. See the corresponding option for .BR ocamlc (1). .TP .BI \-I \ directory Add the given directory to the list of directories searched for compiled interface files (.cmo and .cma). .TP .BI \-o \ exec\-file Specify the name of the toplevel file produced by the linker. The default is is .BR a.out . .SH SEE ALSO .BR ocamlc (1). mingw-ocaml/ocaml/man/ocamldep.m0000644000175000017500000000755012124403240016201 0ustar tootstoots.\"*********************************************************************** .\"* * .\"* OCaml * .\"* * .\"* Xavier Leroy, projet Cristal, INRIA Rocquencourt * .\"* * .\"* Copyright 1996 Institut National de Recherche en Informatique et * .\"* en Automatique. All rights reserved. This file is distributed * .\"* under the terms of the Q Public License version 1.0. * .\"* * .\"*********************************************************************** .\" .\" $Id$ .\" .TH OCAMLDEP 1 .SH NAME ocamldep \- Dependency generator for OCaml .SH SYNOPSIS .B ocamldep [ .I options ] .I filename ... .SH DESCRIPTION The .BR ocamldep (1) command scans a set of OCaml source files (.ml and .mli files) for references to external compilation units, and outputs dependency lines in a format suitable for the .BR make (1) utility. This ensures that make will compile the source files in the correct order, and recompile those files that need to when a source file is modified. The typical usage is: .P ocamldep .I options *.mli *.ml > .depend .P where .depend is the file that should contain the dependencies. Dependencies are generated both for compiling with the bytecode compiler .BR ocamlc (1) and with the native-code compiler .BR ocamlopt (1). .SH OPTIONS The following command-line options are recognized by .BR ocamldep (1). .TP .BI \-I \ directory Add the given directory to the list of directories searched for source files. If a source file foo.ml mentions an external compilation unit Bar, a dependency on that unit's interface bar.cmi is generated only if the source for bar is found in the current directory or in one of the directories specified with .BR \-I . Otherwise, Bar is assumed to be a module from the standard library, and no dependencies are generated. For programs that span multiple directories, it is recommended to pass .BR ocamldep (1) the same .B \-I options that are passed to the compiler. .TP .BI \-ml\-synonym \ .ext Consider the given extension (with leading dot) to be a synonym for .ml. .TP .BI \-mli\-synonym \ .ext Consider the given extension (with leading dot) to be a synonym for .mli. .TP .B \-modules Output raw dependencies of the form .IR filename : \ Module1\ Module2 \ ... \ ModuleN where .IR Module1 ,\ ..., \ ModuleN are the names of the compilation units referenced within the file .IR filename , but these names are not resolved to source file names. Such raw dependencies cannot be used by .BR make (1), but can be post-processed by other tools such as .BR Omake (1). .TP .BI \-native Generate dependencies for a pure native-code program (no bytecode version). When an implementation file (.ml file) has no explicit interface file (.mli file), .BR ocamldep (1) generates dependencies on the bytecode compiled file (.cmo file) to reflect interface changes. This can cause unnecessary bytecode recompilations for programs that are compiled to native-code only. The flag .B \-native causes dependencies on native compiled files (.cmx) to be generated instead of on .cmo files. (This flag makes no difference if all source files have explicit .mli interface files.) .TP .BI \-pp \ command Cause .BR ocamldep (1) to call the given .I command as a preprocessor for each source file. .TP .B \-slash Under Unix, this option does nothing. .TP .B \-version Print version string and exit. .TP .B \-vnum Print short version number and exit. .TP .BR \-help \ or \ \-\-help Display a short usage summary and exit. .SH SEE ALSO .BR ocamlc (1), .BR ocamlopt (1). .br .IR The\ OCaml\ user's\ manual , chapter "Dependency generator". mingw-ocaml/ocaml/man/ocamllex.m0000644000175000017500000000555412124403240016223 0ustar tootstoots.\"*********************************************************************** .\"* * .\"* OCaml * .\"* * .\"* Xavier Leroy, projet Cristal, INRIA Rocquencourt * .\"* * .\"* Copyright 1996 Institut National de Recherche en Informatique et * .\"* en Automatique. All rights reserved. This file is distributed * .\"* under the terms of the Q Public License version 1.0. * .\"* * .\"*********************************************************************** .\" .\" $Id$ .\" .TH OCAMLLEX 1 .SH NAME ocamllex \- The OCaml lexer generator .SH SYNOPSIS .B ocamllex [ .BI \-o \ output-file ] [ .B \-ml ] .I filename.mll .SH DESCRIPTION The .BR ocamllex (1) command generates OCaml lexers from a set of regular expressions with associated semantic actions, in the style of .BR lex (1). Running .BR ocamllex (1) on the input file .IR lexer \&.mll produces OCaml code for a lexical analyzer in file .IR lexer \&.ml. This file defines one lexing function per entry point in the lexer definition. These functions have the same names as the entry points. Lexing functions take as argument a lexer buffer, and return the semantic attribute of the corresponding entry point. Lexer buffers are an abstract data type implemented in the standard library module Lexing. The functions Lexing.from_channel, Lexing.from_string and Lexing.from_function create lexer buffers that read from an input channel, a character string, or any reading function, respectively. When used in conjunction with a parser generated by .BR ocamlyacc (1), the semantic actions compute a value belonging to the type token defined by the generated parsing module. .SH OPTIONS The .BR ocamllex (1) command recognizes the following options: .TP .B \-ml Output code that does not use OCaml's built-in automata interpreter. Instead, the automaton is encoded by OCaml functions. This option is mainly useful for debugging .BR ocamllex (1), using it for production lexers is not recommended. .TP .BI \-o \ output\-file Specify the name of the output file produced by .BR ocamllex (1). The default is the input file name, with its extension replaced by .ml. .TP .B \-q Quiet mode. .BR ocamllex (1) normally outputs informational messages to standard output. They are suppressed if option .B \-q is used. .TP .BR \-v \ or \ \-version Print version string and exit. .TP .B \-vnum Print short version number and exit. .TP .BR \-help \ or \ \-\-help Display a short usage summary and exit. .SH SEE ALSO .BR ocamlyacc (1). .br .IR "The OCaml user's manual" , chapter "Lexer and parser generators". mingw-ocaml/ocaml/man/ocamlprof.m0000644000175000017500000000456212124403240016377 0ustar tootstoots.\"*********************************************************************** .\"* * .\"* OCaml * .\"* * .\"* Xavier Leroy, projet Cristal, INRIA Rocquencourt * .\"* * .\"* Copyright 1996 Institut National de Recherche en Informatique et * .\"* en Automatique. All rights reserved. This file is distributed * .\"* under the terms of the Q Public License version 1.0. * .\"* * .\"*********************************************************************** .\" .\" $Id$ .\" .TH OCAMLPROF 1 .SH NAME ocamlprof \- The OCaml profiler .SH SYNOPSIS .B ocamlprof [ .I options ] .I filename ... .SH DESCRIPTION The .B ocamlprof command prints execution counts gathered during the execution of a OCaml program instrumented with .BR ocamlcp (1). It produces a source listing of the program modules given as arguments where execution counts have been inserted as comments. For instance, .B ocamlprof foo.ml prints the source code for the foo module, with comments indicating how many times the functions in this module have been called. Naturally, this information is accurate only if the source file has not been modified since the profiling execution took place. .SH OPTIONS .TP .BI \-f \ dumpfile Specifies an alternate dump file of profiling information. .TP .BI \-F \ string Specifies an additional string to be output with profiling information. By default, .BR ocamlprof (1) will annotate programs with comments of the form .BI (* \ n \ *) where .I n is the counter value for a profiling point. With option .BI \-F \ s the annotation will be .BI (* \ sn \ *) .TP .BI \-impl \ filename Compile the file .I filename as an implementation file, even if its extension is not .ml. .TP .BI \-intf \ filename Compile the file .I filename as an interface file, even if its extension is not .mli. .TP .B \-version Print version string and exit. .TP .B \-vnum Print short version number and exit. .TP .BR \-help \ or \ \-\-help Display a short usage summary and exit. .SH SEE ALSO .BR ocamlcp (1). .br .IR "The OCaml user's manual" , chapter "Profiling". mingw-ocaml/ocaml/man/ocamldoc.m0000644000175000017500000002643512124403240016201 0ustar tootstoots.\"*********************************************************************** .\"* * .\"* OCaml * .\"* * .\"* Maxence Guesdon, projet Cristal, INRIA Rocquencourt * .\"* * .\"* Copyright 2004 Institut National de Recherche en Informatique et * .\"* en Automatique. All rights reserved. This file is distributed * .\"* under the terms of the Q Public License version 1.0. * .\"* * .\"*********************************************************************** .\" .\" $Id$ .\" .TH OCAMLDOC 1 \" .de Sh \" Subsection heading \" .br \" .if t .Sp \" .ne 5 \" .PP \" \fB\\$1\fR \" .PP \" .. .SH NAME ocamldoc \- The OCaml documentation generator .SH SYNOPSIS .B ocamldoc [ .I options ] .IR filename \ ... .SH DESCRIPTION The OCaml documentation generator .BR ocamldoc (1) generates documentation from special comments embedded in source files. The comments used by .B ocamldoc are of the form .I (** ... *) and follow the format described in the .IR "The OCaml user's manual" . .B ocamldoc can produce documentation in various formats: HTML, LaTeX, TeXinfo, Unix man pages, and .BR dot (1) dependency graphs. Moreover, users can add their own custom generators. In this manpage, we use the word .I element to refer to any of the following parts of an OCaml source file: a type declaration, a value, a module, an exception, a module type, a type constructor, a record field, a class, a class type, a class method, a class value or a class inheritance clause. .SH OPTIONS The following command-line options determine the format for the generated documentation generated by .BR ocamldoc (1). .SS "Options for choosing the output format" .TP .B \-html Generate documentation in HTML default format. The generated HTML pages are stored in the current directory, or in the directory specified with the .B \-d option. You can customize the style of the generated pages by editing the generated .I style.css file, or by providing your own style sheet using option .BR \-css\-style . The file .I style.css is not generated if it already exists. .TP .B \-latex Generate documentation in LaTeX default format. The generated LaTeX document is saved in file .IR ocamldoc.out , or in the file specified with the .B -o option. The document uses the style file .IR ocamldoc.sty . This file is generated when using the .B \-latex option, if it does not already exist. You can change this file to customize the style of your LaTeX documentation. .TP .B \-texi Generate documentation in TeXinfo default format. The generated LaTeX document is saved in file .IR ocamldoc.out , or in the file specified with the .B -o option. .TP .B \-man Generate documentation as a set of Unix man pages. The generated pages are stored in the current directory, or in the directory specified with the .B \-d option. .TP .B \-dot Generate a dependency graph for the toplevel modules, in a format suitable for displaying and processing by .IR dot (1). The .IR dot (1) tool is available from .IR http://www.research.att.com/sw/tools/graphviz/ . The textual representation of the graph is written to the file .IR ocamldoc.out , or to the file specified with the .B -o option. Use .BI dot \ ocamldoc.out to display it. .TP .BI \-g \ file Dynamically load the given file (which extension usually is .cmo or .cma), which defines a custom documentation generator. If the given file is a simple one and does not exist in the current directory, then .B ocamldoc looks for it in the custom generators default directory, and in the directories specified with the .B \-i option. .TP .BI \-customdir Display the custom generators default directory. .TP .BI \-i \ directory Add the given directory to the path where to look for custom generators. .SS "General options" .TP .BI \-d \ dir Generate files in directory .IR dir , rather than the current directory. .TP .BI \-dump \ file Dump collected information into .IR file . This information can be read with the .B \-load option in a subsequent invocation of .BR ocamldoc (1). .TP .BI \-hide \ modules Hide the given complete module names in the generated documentation. .I modules is a list of complete module names are separated by commas (,), without blanks. For instance: .IR Pervasives,M2.M3 . .TP .B \-inv\-merge\-ml\-mli Reverse the precedence of implementations and interfaces when merging. All elements in implementation files are kept, and the .B \-m option indicates which parts of the comments in interface files are merged with the comments in implementation files. .TP .B \-keep\-code Always keep the source code for values, methods and instance variables, when available. The source code is always kept when a .ml file is given, but is by default discarded when a .mli is given. This option allows to always keep the source code. .TP .BI \-load \ file Load information from .IR file , which has been produced by .BR ocamldoc\ \-dump . Several .B -load options can be given. .TP .BI \-m flags Specify merge options between interfaces and implementations. .I flags can be one or several of the following characters: .B d merge description .B a merge @author .B v merge @version .B l merge @see .B s merge @since .B o merge @deprecated .B p merge @param .B e merge @raise .B r merge @return .B A merge everything .TP .B \-no\-custom\-tags Do not allow custom @-tags. .TP .B \-no\-stop Keep elements placed after the .B (**/**) special comment. .TP .BI \-o \ file Output the generated documentation to .I file instead of .IR ocamldoc.out . This option is meaningful only in conjunction with the .BR \-latex , \ \-texi ,\ or \ \-dot options. .TP .BI \-pp \ command Pipe sources through preprocessor .IR command . .TP .B \-sort Sort the list of top-level modules before generating the documentation. .TP .B \-stars Remove blank characters until the first asterisk ('*') in each line of comments. .TP .BI \-t \ title Use .I title as the title for the generated documentation. .TP .BI \-intro \ file Use content of .I file as .B ocamldoc text to use as introduction (HTML, LaTeX and TeXinfo only). For HTML, the file is used to create the whole "index.html" file. .TP .B \-v Verbose mode. Display progress information. .TP .B \-version Print version string and exit. .TP .B \-vnum Print short version number and exit. .TP .B \-warn\-error Treat .B ocamldoc warnings as errors. .TP .B \-hide\-warnings Do not print .B ocamldoc warnings. .TP .BR \-help \ or \ \-\-help Display a short usage summary and exit. .SS "Type-checking options" .BR ocamldoc (1) calls the OCaml type-checker to obtain type information. The following options impact the type-checking phase. They have the same meaning as for the .BR ocamlc (1)\ and \ ocamlopt (1) commands. .TP .BI \-I \ directory Add .I directory to the list of directories search for compiled interface files (.cmi files). .TP .B \-nolabels Ignore non-optional labels in types. .TP .B \-rectypes Allow arbitrary recursive types. (See the .B \-rectypes option to .BR ocamlc (1).) .SS "Options for generating HTML pages" The following options apply in conjunction with the .B \-html option: .TP .B \-all\-params Display the complete list of parameters for functions and methods. .TP .BI \-css\-style \ filename Use .I filename as the Cascading Style Sheet file. .TP .B \-colorize\-code Colorize the OCaml code enclosed in [ ] and \\{[ ]\\}, using colors to emphasize keywords, etc. If the code fragments are not syntactically correct, no color is added. .TP .B \-index\-only Generate only index files. .TP .B \-short\-functors Use a short form to display functors: .B "module M : functor (A:Module) -> functor (B:Module2) -> sig .. end" is displayed as .BR "module M (A:Module) (B:Module2) : sig .. end" . .SS "Options for generating LaTeX files" The following options apply in conjunction with the .B \-latex option: .TP .B \-latex\-value\-prefix prefix Give a prefix to use for the labels of the values in the generated LaTeX document. The default prefix is the empty string. You can also use the options .BR -latex-type-prefix , .BR -latex-exception-prefix , .BR -latex-module-prefix , .BR -latex-module-type-prefix , .BR -latex-class-prefix , .BR -latex-class-type-prefix , .BR -latex-attribute-prefix ,\ and .BR -latex-method-prefix . These options are useful when you have, for example, a type and a value with the same name. If you do not specify prefixes, LaTeX will complain about multiply defined labels. .TP .BI \-latextitle \ n,style Associate style number .I n to the given LaTeX sectioning command .IR style , e.g. .BR section or subsection . (LaTeX only.) This is useful when including the generated document in another LaTeX document, at a given sectioning level. The default association is 1 for section, 2 for subsection, 3 for subsubsection, 4 for paragraph and 5 for subparagraph. .TP .B \-noheader Suppress header in generated documentation. .TP .B \-notoc Do not generate a table of contents. .TP .B \-notrailer Suppress trailer in generated documentation. .TP .B \-sepfiles Generate one .tex file per toplevel module, instead of the global .I ocamldoc.out file. .SS "Options for generating TeXinfo files" The following options apply in conjunction with the .B -texi option: .TP .B \-esc8 Escape accented characters in Info files. .TP .B \-info\-entry Specify Info directory entry. .TP .B \-info\-section Specify section of Info directory. .TP .B \-noheader Suppress header in generated documentation. .TP .B \-noindex Do not build index for Info files. .TP .B \-notrailer Suppress trailer in generated documentation. .SS "Options for generating dot graphs" The following options apply in conjunction with the .B \-dot option: .TP .BI \-dot\-colors \ colors Specify the colors to use in the generated dot code. When generating module dependencies, .BR ocamldoc (1) uses different colors for modules, depending on the directories in which they reside. When generating types dependencies, .BR ocamldoc (1) uses different colors for types, depending on the modules in which they are defined. .I colors is a list of color names separated by commas (,), as in .BR Red,Blue,Green . The available colors are the ones supported by the .BR dot (1) tool. .TP .B \-dot\-include\-all Include all modules in the .BR dot (1) output, not only modules given on the command line or loaded with the .B \-load option. .TP .B \-dot\-reduce Perform a transitive reduction of the dependency graph before outputting the dot code. This can be useful if there are a lot of transitive dependencies that clutter the graph. .TP .B \-dot\-types Output dot code describing the type dependency graph instead of the module dependency graph. .SS "Options for generating man files" The following options apply in conjunction with the .B \-man option: .TP .B \-man\-mini Generate man pages only for modules, module types, classes and class types, instead of pages for all elements. .TP .BI \-man\-suffix suffix Set the suffix used for generated man filenames. Default is o, as in .IR List.o . .TP .BI \-man\-section section Set the section number used for generated man filenames. Default is 3. .SH SEE ALSO .BR ocaml (1), .BR ocamlc (1), .BR ocamlopt (1). .br .IR "The OCaml user's manual", chapter "The documentation generator". mingw-ocaml/ocaml/man/ocamldebug.m0000644000175000017500000000545512124403240016521 0ustar tootstoots.\"*********************************************************************** .\"* * .\"* OCaml * .\"* * .\"* Xavier Leroy, projet Cristal, INRIA Rocquencourt * .\"* * .\"* Copyright 2001 Institut National de Recherche en Informatique et * .\"* en Automatique. All rights reserved. This file is distributed * .\"* under the terms of the Q Public License version 1.0. * .\"* * .\"*********************************************************************** .\" .\" $Id$ .\" .TH OCAMLDEBUG 1 .SH NAME ocamldebug \- the OCaml source-level replay debugger. .SH SYNOPSIS .B ocamldebug .RI [\ options \ ]\ program \ [\ arguments \ ] .SH DESCRIPTION .B ocamldebug is the OCaml source-level replay debugger. Before the debugger can be used, the program must be compiled and linked with the .B \-g option: all .cmo and .cma files that are part of the program should have been created with .BR ocamlc\ \-g , and they must be linked together with .BR ocamlc\ \-g . Compiling with .B \-g entails no penalty on the running time of programs: object files and bytecode executable files are bigger and take longer to produce, but the executable files run at exactly the same speed as if they had been compiled without .BR \-g . .SH OPTIONS A summary of options are included below. For a complete description, see the html documentation in the ocaml-doc package. .TP .BI \-c \ count Set the maximum number of simultaneously live checkpoints to .IR count . .TP .BI \-cd \ dir Run the debugger program from the working directory .IR dir , instead of the current working directory. (See also the .B cd command.) .TP .B \-emacs Tell the debugger it is executed under Emacs. (See .I "The OCaml user's manual" for information on how to run the debugger under Emacs.) .TP .BI \-I \ directory Add .I directory to the list of directories searched for source files and compiled files. (See also the .B directory command.) .TP .BI \-s \ socket Use .I socket for communicating with the debugged program. See the description of the command .B set\ socket in .I "The OCaml user's manual" for the format of .IR socket . .TP .B \-version Print version string and exit. .TP .B \-vnum Print short version number and exit. .TP .BR \-help \ or \ \-\-help Display a short usage summary and exit. .SH SEE ALSO .BR ocamlc (1) .br .IR "The OCaml user's manual" , chapter "The debugger". .SH AUTHOR This manual page was written by Sven LUTHER , for the Debian GNU/Linux system (but may be used by others). mingw-ocaml/ocaml/man/ocamlrun.m0000644000175000017500000001357512124403240016241 0ustar tootstoots.\"*********************************************************************** .\"* * .\"* OCaml * .\"* * .\"* Xavier Leroy, projet Cristal, INRIA Rocquencourt * .\"* * .\"* Copyright 1996 Institut National de Recherche en Informatique et * .\"* en Automatique. All rights reserved. This file is distributed * .\"* under the terms of the Q Public License version 1.0. * .\"* * .\"*********************************************************************** .\" .\" $Id$ .\" .TH OCAMLRUN 1 .SH NAME ocamlrun \- The OCaml bytecode interpreter .SH SYNOPSIS .B ocamlrun [ .I options ] .I filename argument ... .SH DESCRIPTION The .BR ocamlrun (1) command executes bytecode files produced by the linking phase of the .BR ocamlc (1) command. The first non-option argument is taken to be the name of the file containing the executable bytecode. (That file is searched in the executable path as well as in the current directory.) The remaining arguments are passed to the OCaml program, in the string array .BR Sys.argv . Element 0 of this array is the name of the bytecode executable file; elements 1 to .I n are the remaining arguments. In most cases, the bytecode executable files produced by the .BR ocamlc (1) command are self-executable, and manage to launch the .BR ocamlrun (1) command on themselves automatically. .SH OPTIONS The following command-line options are recognized by .BR ocamlrun (1). .TP .B \-b When the program aborts due to an uncaught exception, print a detailed "back trace" of the execution, showing where the exception was raised and which function calls were outstanding at this point. The back trace is printed only if the bytecode executable contains debugging information, i.e. was compiled and linked with the .B \-g option to .BR ocamlc (1) set. This option is equivalent to setting the .B b flag in the OCAMLRUNPARAM environment variable (see below). .TP .BI \-I \ dir Search the directory .I dir for dynamically-loaded libraries, in addition to the standard search path. .TP .B \-p Print the names of the primitives known to this version of .BR ocamlrun (1) and exit. .TP .B \-v Direct the memory manager to print verbose messages on standard error. This is equivalent to setting .B v=63 in the OCAMLRUNPARAM environment variable (see below). .TP .B \-version Print version string and exit. .TP .B \-vnum Print short version number and exit. .SH ENVIRONMENT VARIABLES The following environment variable are also consulted: .TP .B CAML_LD_LIBRARY_PATH Additional directories to search for dynamically-loaded libraries. .TP .B OCAMLLIB The directory containing the OCaml standard library. (If .B OCAMLLIB is not set, .B CAMLLIB will be used instead.) Used to locate the ld.conf configuration file for dynamic loading. If not set, default to the library directory specified when compiling OCaml. .TP .B OCAMLRUNPARAM Set the runtime system options and garbage collection parameters. (If OCAMLRUNPARAM is not set, CAMLRUNPARAM will be used instead.) This variable must be a sequence of parameter specifications. A parameter specification is an option letter followed by an = sign, a decimal number (or a hexadecimal number prefixed by .BR 0x ), and an optional multiplier. There are nine options, six of which correspond to the fields of the .B control record documented in .IR "The OCaml user's manual", chapter "Standard Library", section "Gc". .TP .B b Trigger the printing of a stack backtrace when an uncaught exception aborts the program. This option takes no argument. .TP .B p Turn on debugging support for .BR ocamlyacc -generated parsers. When this option is on, the pushdown automaton that executes the parsers prints a trace of its actions. This option takes no argument. .TP .BR a \ (allocation_policy) The policy used for allocating in the OCaml heap. Possible values are 0 for the next-fit policy, and 1 for the first-fit policy. Next-fit is somewhat faster, but first-fit is better for avoiding fragmentation and the associated heap compactions. .TP .BR s \ (minor_heap_size) The size of the minor heap (in words). .TP .BR i \ (major_heap_increment) The default size increment for the major heap (in words). .TP .BR o \ (space_overhead) The major GC speed setting. .TP .BR O \ (max_overhead) The heap compaction trigger setting. .TP .BR l \ (stack_limit) The limit (in words) of the stack size. .TP .BR h The initial size of the major heap (in words). .TP .BR v \ (verbose) What GC messages to print to stderr. This is a sum of values selected from the following: .B 0x001 Start of major GC cycle. .B 0x002 Minor collection and major GC slice. .B 0x004 Growing and shrinking of the heap. .B 0x008 Resizing of stacks and memory manager tables. .B 0x010 Heap compaction. .BR 0x020 Change of GC parameters. .BR 0x040 Computation of major GC slice size. .BR 0x080 Calling of finalisation functions. .BR 0x100 Startup messages (loading the bytecode executable file, resolving shared libraries). The multiplier is .BR k , .BR M \ or .BR G , for multiplication by 2^10, 2^20, and 2^30 respectively. For example, on a 32-bit machine under bash, the command .B export OCAMLRUNPARAM='s=256k,v=1' tells a subsequent .B ocamlrun to set its initial minor heap size to 1 megabyte and to print a message at the start of each major GC cycle. .TP .B CAMLRUNPARAM If OCAMLRUNPARAM is not found in the environment, then CAMLRUNPARAM will be used instead. If CAMLRUNPARAM is not found, then the default values will be used. .TP .B PATH List of directories searched to find the bytecode executable file. .SH SEE ALSO .BR ocamlc (1). .br .IR "The OCaml user's manual" , chapter "Runtime system". mingw-ocaml/ocaml/Makefile0000644000175000017500000005705512124403240015131 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # $Id$ # The main Makefile include config/Makefile include stdlib/StdlibModules CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink COMPFLAGS= -strict-sequence -warn-error A $(INCLUDES) LINKFLAGS= CAMLYACC=boot/ocamlyacc YACCFLAGS=-v CAMLLEX=boot/ocamlrun boot/ocamllex CAMLDEP=boot/ocamlrun tools/ocamldep DEPFLAGS=$(INCLUDES) CAMLRUN=byterun/ocamlrun SHELL=/bin/sh MKDIR=mkdir -p CAMLP4OUT=$(CAMLP4:=out) CAMLP4OPT=$(CAMLP4:=opt) INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \ -I toplevel UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ utils/consistbl.cmo PARSING=parsing/location.cmo parsing/longident.cmo \ parsing/syntaxerr.cmo parsing/parser.cmo \ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo TYPING=typing/ident.cmo typing/path.cmo \ typing/primitive.cmo typing/types.cmo \ typing/btype.cmo typing/oprint.cmo \ typing/subst.cmo typing/predef.cmo \ typing/datarepr.cmo typing/cmi_format.cmo typing/env.cmo \ typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \ typing/printtyp.cmo typing/includeclass.cmo \ typing/mtype.cmo typing/includecore.cmo \ typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \ typing/cmt_format.cmo typing/stypes.cmo typing/typecore.cmo \ typing/typedecl.cmo typing/typeclass.cmo \ typing/typemod.cmo COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \ bytecomp/translobj.cmo bytecomp/translcore.cmo \ bytecomp/translclass.cmo bytecomp/translmod.cmo \ bytecomp/simplif.cmo bytecomp/runtimedef.cmo \ driver/pparse.cmo driver/main_args.cmo COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP) BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \ bytecomp/printinstr.cmo bytecomp/opcodes.cmo bytecomp/emitcode.cmo \ bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \ bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo \ driver/errors.cmo driver/compile.cmo ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \ asmcomp/closure.cmo asmcomp/cmmgen.cmo \ asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ asmcomp/comballoc.cmo asmcomp/liveness.cmo \ asmcomp/spill.cmo asmcomp/split.cmo \ asmcomp/interf.cmo asmcomp/coloring.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \ driver/opterrors.cmo driver/optcompile.cmo TOPLEVEL=toplevel/genprintval.cmo toplevel/toploop.cmo \ toplevel/trace.cmo toplevel/topdirs.cmo toplevel/topmain.cmo BYTESTART=driver/main.cmo OPTSTART=driver/optmain.cmo TOPLEVELSTART=toplevel/topstart.cmo NATTOPOBJS=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) \ toplevel/genprintval.cmo toplevel/opttoploop.cmo toplevel/opttopdirs.cmo \ toplevel/opttopmain.cmo toplevel/opttopstart.cmo PERVASIVES=$(STDLIB_MODULES) outcometree topdirs toploop # For users who don't read the INSTALL file defaultentry: @echo "Please refer to the installation instructions in file INSTALL." @echo "If you've just unpacked the distribution, something like" @echo " ./configure" @echo " make world.opt" @echo " make install" @echo "should work. But see the file INSTALL for more details." # Recompile the system using the bootstrap compiler all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \ otherlibraries ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) ocamldoc # Compile everything the first time world: $(MAKE) coldstart $(MAKE) all # Compile also native code compiler and libraries, fast world.opt: $(MAKE) coldstart $(MAKE) opt.opt # Hard bootstrap how-to: # (only necessary in some cases, for example if you remove some primitive) # # make coreboot [old system -- you were in a stable state] # # make core [cross-compiler] # make partialclean [if you get "inconsistent assumptions"] # # make core [cross-compiler] # make coreboot [new system -- now you are in a stable state] # Core bootstrapping cycle coreboot: # Save the original bootstrap compiler $(MAKE) backup # Promote the new compiler but keep the old runtime # This compiler runs on boot/ocamlrun and produces bytecode for # byterun/ocamlrun $(MAKE) promote-cross # Rebuild ocamlc and ocamllex (run on byterun/ocamlrun) $(MAKE) partialclean $(MAKE) ocamlc ocamllex ocamltools # Rebuild the library (using byterun/ocamlrun ./ocamlc) $(MAKE) library-cross # Promote the new compiler and the new runtime $(MAKE) promote # Rebuild the core system $(MAKE) partialclean $(MAKE) core # Check if fixpoint reached $(MAKE) compare # Bootstrap and rebuild the whole system. # The compilation of ocaml will fail if the runtime has changed. # Never mind, just do make bootstrap to reach fixpoint again. bootstrap: $(MAKE) coreboot $(MAKE) all $(MAKE) compare LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader # Start up the system from the distribution compiler coldstart: cd byterun; $(MAKE) all cp byterun/ocamlrun$(EXE) boot/ocamlrun$(EXE) cd yacc; $(MAKE) all cp yacc/ocamlyacc$(EXE) boot/ocamlyacc$(EXE) cd stdlib; $(MAKE) COMPILER=../boot/ocamlc all cd stdlib; cp $(LIBFILES) ../boot if test -f boot/libcamlrun.a; then :; else \ ln -s ../byterun/libcamlrun.a boot/libcamlrun.a; fi if test -d stdlib/caml; then :; else \ ln -s ../byterun stdlib/caml; fi # Build the core system: the minimum needed to make depend and bootstrap core: coldstart ocamlc ocamllex ocamlyacc ocamltools library # Recompile the core system using the bootstrap compiler coreall: ocamlc ocamllex ocamlyacc ocamltools library # Save the current bootstrap compiler MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev backup: if test -d boot/Saved; then : ; else mkdir boot/Saved; fi if test -d $(MAXSAVED); then rm -r $(MAXSAVED); else : ; fi mv boot/Saved boot/Saved.prev mkdir boot/Saved mv boot/Saved.prev boot/Saved/Saved.prev cp boot/ocamlrun$(EXE) boot/Saved mv boot/ocamlc boot/ocamllex boot/ocamlyacc$(EXE) boot/ocamldep \ boot/Saved cd boot; cp $(LIBFILES) Saved # Promote the newly compiled system to the rank of cross compiler # (Runs on the old runtime, produces code for the new runtime) promote-cross: cp ocamlc boot/ocamlc cp lex/ocamllex boot/ocamllex cp yacc/ocamlyacc$(EXE) boot/ocamlyacc$(EXE) cp tools/ocamldep boot/ocamldep cd stdlib; cp $(LIBFILES) ../boot # Promote the newly compiled system to the rank of bootstrap compiler # (Runs on the new runtime, produces code for the new runtime) promote: promote-cross cp byterun/ocamlrun$(EXE) boot/ocamlrun$(EXE) # Restore the saved bootstrap compiler if a problem arises restore: mv boot/Saved/* boot rmdir boot/Saved mv boot/Saved.prev boot/Saved # Check if fixpoint reached compare: @if cmp boot/ocamlc ocamlc && cmp boot/ocamllex lex/ocamllex \ && cmp boot/ocamldep tools/ocamldep; \ then echo "Fixpoint reached, bootstrap succeeded."; \ else echo "Fixpoint not reached, try one more bootstrapping cycle."; \ fi # Remove old bootstrap compilers cleanboot: rm -rf boot/Saved/Saved.prev/* # Compile the native-code compiler opt-core: $(MAKE) runtimeopt $(MAKE) ocamlopt $(MAKE) libraryopt opt: $(MAKE) runtimeopt $(MAKE) ocamlopt $(MAKE) libraryopt $(MAKE) otherlibrariesopt $(MAKE) ocamltoolsopt $(MAKE) ocamlbuildlib.native # Native-code versions of the tools opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ $(DEBUGGER) ocamldoc ocamlbuild.byte $(CAMLP4OUT) \ ocamlopt.opt otherlibrariesopt ocamllex.opt \ ocamltoolsopt ocamltoolsopt.opt ocamldoc.opt ocamlbuild.native \ $(CAMLP4OPT) base.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) ocamldoc ocamlopt.opt \ otherlibrariesopt # Installation COMPLIBDIR=$(LIBDIR)/compiler-libs install: if test -d $(BINDIR); then : ; else $(MKDIR) $(BINDIR); fi if test -d $(LIBDIR); then : ; else $(MKDIR) $(LIBDIR); fi if test -d $(STUBLIBDIR); then : ; else $(MKDIR) $(STUBLIBDIR); fi if test -d $(COMPLIBDIR); then : ; else $(MKDIR) $(COMPLIBDIR); fi if test -d $(MANDIR)/man$(MANEXT); then : ; \ else $(MKDIR) $(MANDIR)/man$(MANEXT); fi cp VERSION $(LIBDIR)/ cd $(LIBDIR); rm -f dllbigarray.so dlllabltk.so dllnums.so \ dllthreads.so dllunix.so dllgraphics.so dllstr.so \ dlltkanim.so cd byterun; $(MAKE) install cp ocamlc $(BINDIR)/ocamlc$(EXE) cp ocaml $(BINDIR)/ocaml$(EXE) cd stdlib; $(MAKE) install cp lex/ocamllex $(BINDIR)/ocamllex$(EXE) cp yacc/ocamlyacc$(EXE) $(BINDIR)/ocamlyacc$(EXE) cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi toplevel/*.cmi $(COMPLIBDIR) cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) $(COMPLIBDIR) cp expunge $(LIBDIR)/expunge$(EXE) cp toplevel/topdirs.cmi $(LIBDIR) cd tools; $(MAKE) install -cd man; $(MAKE) install for i in $(OTHERLIBRARIES); do \ (cd otherlibs/$$i; $(MAKE) install) || exit $$?; \ done cd ocamldoc; $(MAKE) install if test -f ocamlopt; then $(MAKE) installopt; else :; fi if test -f debugger/ocamldebug; then (cd debugger; $(MAKE) install); \ else :; fi cp config/Makefile $(LIBDIR)/Makefile.config BINDIR=$(BINDIR) LIBDIR=$(LIBDIR) PREFIX=$(PREFIX) \ ./build/partial-install.sh # Installation of the native-code compiler installopt: cd asmrun; $(MAKE) install cp ocamlopt $(BINDIR)/ocamlopt$(EXE) cd stdlib; $(MAKE) installopt cp asmcomp/*.cmi $(COMPLIBDIR) cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(COMPLIBDIR) cd ocamldoc; $(MAKE) installopt for i in $(OTHERLIBRARIES); \ do (cd otherlibs/$$i; $(MAKE) installopt) || exit $$?; done if test -f ocamlopt.opt ; then $(MAKE) installoptopt; fi cd tools; $(MAKE) installopt installoptopt: cp ocamlc.opt $(BINDIR)/ocamlc.opt$(EXE) cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE) cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE) cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a \ compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a \ compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a \ $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.o) \ $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.o) \ $(COMPLIBDIR) cd $(COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a ocamloptcomp.a clean:: partialclean # Shared parts of the system compilerlibs/ocamlcommon.cma: $(COMMON) $(CAMLC) -a -o $@ $(COMMON) partialclean:: rm -f compilerlibs/ocamlcommon.cma # The bytecode compiler compilerlibs/ocamlbytecomp.cma: $(BYTECOMP) $(CAMLC) -a -o $@ $(BYTECOMP) partialclean:: rm -f compilerlibs/ocamlbytecomp.cma ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) $(CAMLC) $(LINKFLAGS) -o ocamlc \ compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \ driver/ocamlcomp.sh.in > ocamlcomp.sh @chmod +x ocamlcomp.sh # The native-code compiler compilerlibs/ocamloptcomp.cma: $(ASMCOMP) $(CAMLC) -a -o $@ $(ASMCOMP) partialclean:: rm -f compilerlibs/ocamloptcomp.cma ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) $(CAMLC) $(LINKFLAGS) -o ocamlopt \ compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \ driver/ocamlcomp.sh.in > ocamlcompopt.sh @chmod +x ocamlcompopt.sh partialclean:: rm -f ocamlopt ocamlcompopt.sh # The toplevel compilerlibs/ocamltoplevel.cma: $(TOPLEVEL) $(CAMLC) -a -o $@ $(TOPLEVEL) partialclean:: rm -f compilerlibs/ocamltoplevel.cma ocaml: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) expunge $(CAMLC) $(LINKFLAGS) -linkall -o ocaml.tmp \ compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) - $(CAMLRUN) ./expunge ocaml.tmp ocaml $(PERVASIVES) rm -f ocaml.tmp partialclean:: rm -f ocaml # The native toplevel ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat \ $(NATTOPOBJS:.cmo=.cmx) -linkall toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml cd otherlibs/dynlink && $(MAKE) allopt # The configuration file utils/config.ml: utils/config.mlp config/Makefile @rm -f utils/config.ml sed -e 's|%%LIBDIR%%|$(LIBDIR)|' \ -e 's|%%BYTERUN%%|$(BINDIR)/ocamlrun|' \ -e 's|%%CCOMPTYPE%%|cc|' \ -e 's|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)|' \ -e 's|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|' \ -e 's|%%PACKLD%%|$(PACKLD)|' \ -e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \ -e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \ -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \ -e 's|%%ARCMD%%|$(ARCMD)|' \ -e 's|%%CC_PROFILE%%|$(CC_PROFILE)|' \ -e 's|%%ARCH%%|$(ARCH)|' \ -e 's|%%MODEL%%|$(MODEL)|' \ -e 's|%%SYSTEM%%|$(SYSTEM)|' \ -e 's|%%EXT_OBJ%%|.o|' \ -e 's|%%EXT_ASM%%|.s|' \ -e 's|%%EXT_LIB%%|.a|' \ -e 's|%%EXT_DLL%%|.so|' \ -e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \ -e 's|%%ASM%%|$(ASM)|' \ -e 's|%%ASM_CFI_SUPPORTED%%|$(ASM_CFI_SUPPORTED)|' \ -e 's|%%MKDLL%%|$(MKDLL)|' \ -e 's|%%MKEXE%%|$(MKEXE)|' \ -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ utils/config.mlp > utils/config.ml @chmod -w utils/config.ml partialclean:: rm -f utils/config.ml beforedepend:: utils/config.ml # The parser parsing/parser.mli parsing/parser.ml: parsing/parser.mly $(CAMLYACC) $(YACCFLAGS) parsing/parser.mly partialclean:: rm -f parsing/parser.mli parsing/parser.ml parsing/parser.output beforedepend:: parsing/parser.mli parsing/parser.ml # The lexer parsing/lexer.ml: parsing/lexer.mll $(CAMLLEX) parsing/lexer.mll partialclean:: rm -f parsing/lexer.ml beforedepend:: parsing/lexer.ml # Shared parts of the system compiled with the native-code compiler compilerlibs/ocamlcommon.cmxa: $(COMMON:.cmo=.cmx) $(CAMLOPT) -a -o $@ $(COMMON:.cmo=.cmx) partialclean:: rm -f compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a # The bytecode compiler compiled with the native-code compiler compilerlibs/ocamlbytecomp.cmxa: $(BYTECOMP:.cmo=.cmx) $(CAMLOPT) -a -o $@ $(BYTECOMP:.cmo=.cmx) partialclean:: rm -f compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa $(BYTESTART:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)" @sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \ driver/ocamlcomp.sh.in > ocamlcomp.sh @chmod +x ocamlcomp.sh partialclean:: rm -f ocamlc.opt # The native-code compiler compiled with itself compilerlibs/ocamloptcomp.cmxa: $(ASMCOMP:.cmo=.cmx) $(CAMLOPT) -a -o $@ $(ASMCOMP:.cmo=.cmx) partialclean:: rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa $(OPTSTART:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(OPTSTART:.cmo=.cmx) @sed -e 's|@compiler@|$$topdir/ocamlopt.opt|' \ driver/ocamlcomp.sh.in > ocamlcompopt.sh @chmod +x ocamlcompopt.sh partialclean:: rm -f ocamlopt.opt $(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx): ocamlopt # The numeric opcodes bytecomp/opcodes.ml: byterun/instruct.h sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' byterun/instruct.h | \ awk -f tools/make-opcodes > bytecomp/opcodes.ml partialclean:: rm -f bytecomp/opcodes.ml beforedepend:: bytecomp/opcodes.ml # The predefined exceptions and primitives byterun/primitives: cd byterun; $(MAKE) primitives bytecomp/runtimedef.ml: byterun/primitives byterun/fail.h (echo 'let builtin_exceptions = [|'; \ sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/fail.h | \ sed -e '$$s/;$$//'; \ echo '|]'; \ echo 'let builtin_primitives = [|'; \ sed -e 's/.*/ "&";/' -e '$$s/;$$//' byterun/primitives; \ echo '|]') > bytecomp/runtimedef.ml partialclean:: rm -f bytecomp/runtimedef.ml beforedepend:: bytecomp/runtimedef.ml # Choose the right machine-dependent files asmcomp/arch.ml: asmcomp/$(ARCH)/arch.ml ln -s $(ARCH)/arch.ml asmcomp/arch.ml partialclean:: rm -f asmcomp/arch.ml beforedepend:: asmcomp/arch.ml asmcomp/proc.ml: asmcomp/$(ARCH)/proc.ml ln -s $(ARCH)/proc.ml asmcomp/proc.ml partialclean:: rm -f asmcomp/proc.ml beforedepend:: asmcomp/proc.ml asmcomp/selection.ml: asmcomp/$(ARCH)/selection.ml ln -s $(ARCH)/selection.ml asmcomp/selection.ml partialclean:: rm -f asmcomp/selection.ml beforedepend:: asmcomp/selection.ml asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml ln -s $(ARCH)/reload.ml asmcomp/reload.ml partialclean:: rm -f asmcomp/reload.ml beforedepend:: asmcomp/reload.ml asmcomp/scheduling.ml: asmcomp/$(ARCH)/scheduling.ml ln -s $(ARCH)/scheduling.ml asmcomp/scheduling.ml partialclean:: rm -f asmcomp/scheduling.ml beforedepend:: asmcomp/scheduling.ml # Preprocess the code emitters asmcomp/emit.ml: asmcomp/$(ARCH)/emit.mlp tools/cvt_emit $(CAMLRUN) tools/cvt_emit < asmcomp/$(ARCH)/emit.mlp > asmcomp/emit.ml \ || { rm -f asmcomp/emit.ml; exit 2; } partialclean:: rm -f asmcomp/emit.ml beforedepend:: asmcomp/emit.ml tools/cvt_emit: tools/cvt_emit.mll cd tools; \ $(MAKE) CAMLC="../$(CAMLRUN) ../boot/ocamlc -I ../stdlib" cvt_emit # The "expunge" utility expunge: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo $(CAMLC) $(LINKFLAGS) -o expunge \ compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo partialclean:: rm -f expunge # The runtime system for the bytecode compiler runtime: cd byterun; $(MAKE) all if test -f stdlib/libcamlrun.a; then :; else \ ln -s ../byterun/libcamlrun.a stdlib/libcamlrun.a; fi clean:: cd byterun; $(MAKE) clean rm -f stdlib/libcamlrun.a rm -f stdlib/caml alldepend:: cd byterun; $(MAKE) depend # The runtime system for the native-code compiler runtimeopt: makeruntimeopt cp asmrun/libasmrun.a stdlib/libasmrun.a makeruntimeopt: cd asmrun; $(MAKE) all clean:: cd asmrun; $(MAKE) clean rm -f stdlib/libasmrun.a alldepend:: cd asmrun; $(MAKE) depend # The library library: ocamlc cd stdlib; $(MAKE) all library-cross: cd stdlib; $(MAKE) RUNTIME=../byterun/ocamlrun all libraryopt: cd stdlib; $(MAKE) allopt partialclean:: cd stdlib; $(MAKE) clean alldepend:: cd stdlib; $(MAKE) depend # The lexer and parser generators ocamllex: ocamlyacc ocamlc cd lex; $(MAKE) all ocamllex.opt: ocamlopt cd lex; $(MAKE) allopt partialclean:: cd lex; $(MAKE) clean alldepend:: cd lex; $(MAKE) depend ocamlyacc: cd yacc; $(MAKE) all clean:: cd yacc; $(MAKE) clean # Tools ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi cd tools; $(MAKE) all ocamltoolsopt: ocamlopt cd tools; $(MAKE) opt ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi cd tools; $(MAKE) opt.opt partialclean:: cd tools; $(MAKE) clean alldepend:: cd tools; $(MAKE) depend # OCamldoc ocamldoc: ocamlc ocamlyacc ocamllex otherlibraries cd ocamldoc && $(MAKE) all ocamldoc.opt: ocamlc.opt ocamlyacc ocamllex cd ocamldoc && $(MAKE) opt.opt partialclean:: cd ocamldoc && $(MAKE) clean alldepend:: cd ocamldoc && $(MAKE) depend # The extra libraries otherlibraries: ocamltools for i in $(OTHERLIBRARIES); do \ (cd otherlibs/$$i; $(MAKE) RUNTIME=$(RUNTIME) all) || exit $$?; \ done otherlibrariesopt: for i in $(OTHERLIBRARIES); do \ (cd otherlibs/$$i; $(MAKE) allopt) || exit $$?; \ done partialclean:: for i in $(OTHERLIBRARIES); do \ (cd otherlibs/$$i; $(MAKE) partialclean); \ done clean:: for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) clean); done alldepend:: for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) depend); done # The replay debugger ocamldebugger: ocamlc ocamlyacc ocamllex otherlibraries cd debugger; $(MAKE) all partialclean:: cd debugger; $(MAKE) clean alldepend:: cd debugger; $(MAKE) depend # Camlp4 camlp4out: ocamlc ocamlbuild.byte ./build/camlp4-byte-only.sh camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native ./build/camlp4-native-only.sh # Ocamlbuild ocamlbuild.byte: ocamlc ocamlbuild-mixed-boot ./build/ocamlbuild-byte-only.sh ocamlbuild.native: ocamlopt ocamlbuild-mixed-boot ./build/ocamlbuild-native-only.sh ocamlbuildlib.native: ocamlopt ocamlbuild-mixed-boot ./build/ocamlbuildlib-native-only.sh ocamlbuild-mixed-boot: ocamlc ./build/mixed-boot.sh touch ocamlbuild-mixed-boot partialclean:: rm -rf _build ocamlbuild-mixed-boot # Check that the stack limit is reasonable. checkstack: @if $(BYTECC) -o tools/checkstack tools/checkstack.c; \ then tools/checkstack; \ else :; \ fi @rm -f tools/checkstack # Make clean in the test suite clean:: cd testsuite; $(MAKE) clean # Make MacOS X package package-macosx: sudo rm -rf package-macosx/root $(MAKE) PREFIX="`pwd`"/package-macosx/root install tools/make-package-macosx sudo rm -rf package-macosx/root clean:: rm -rf package-macosx/*.pkg package-macosx/*.dmg # Default rules .SUFFIXES: .ml .mli .cmo .cmi .cmx .ml.cmo: $(CAMLC) $(COMPFLAGS) -c $< .mli.cmi: $(CAMLC) $(COMPFLAGS) -c $< .ml.cmx: $(CAMLOPT) $(COMPFLAGS) -c $< partialclean:: for d in utils parsing typing bytecomp asmcomp driver toplevel tools; \ do rm -f $$d/*.cm[iox] $$d/*.annot $$d/*.[so] $$d/*~; done rm -f *~ depend: beforedepend (for d in utils parsing typing bytecomp asmcomp driver toplevel; \ do $(CAMLDEP) $(DEPFLAGS) $$d/*.mli $$d/*.ml; \ done) > .depend alldepend:: depend distclean: ./build/distclean.sh .PHONY: all backup bootstrap camlp4opt camlp4out checkstack clean .PHONY: partialclean beforedepend alldepend cleanboot coldstart .PHONY: compare core coreall .PHONY: coreboot defaultentry depend distclean install installopt .PHONY: library library-cross libraryopt .PHONY: ocamlbuild.byte ocamlbuild.native ocamldebugger ocamldoc .PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltoolsopt .PHONY: ocamltoolsopt.opt ocamlyacc opt-core opt opt.opt otherlibraries .PHONY: otherlibrariesopt package-macosx promote promote-cross .PHONY: restore runtime runtimeopt makeruntimeopt world world.opt include .depend mingw-ocaml/ocaml/maccaml/0000755000175000017500000000000012124403240015052 5ustar tootstootsmingw-ocaml/ocaml/maccaml/.gitignore0000644000175000017500000000000012124403240017030 0ustar tootstootsmingw-ocaml/ocaml/debugger/0000755000175000017500000000000012124403240015241 5ustar tootstootsmingw-ocaml/ocaml/debugger/exec.mli0000644000175000017500000000177012124403240016675 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Handling of keyboard interrupts *) val protect : (unit -> unit) -> unit val unprotect : (unit -> unit) -> unit mingw-ocaml/ocaml/debugger/.ignore0000644000175000017500000000011712124403240016524 0ustar tootstootslexer.ml parser.ml parser.mli ocamldebug ocamldebug.exe dynlink.ml dynlink.mli mingw-ocaml/ocaml/debugger/time_travel.mli0000644000175000017500000000274212124403240020264 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (**************************** Time travel ******************************) open Primitives exception Current_checkpoint_lost exception Current_checkpoint_lost_start_at of int64 * int64 val new_checkpoint : int -> io_channel -> unit val set_file_descriptor : int -> io_channel -> bool val kill_all_checkpoints : unit -> unit val forget_process : io_channel -> int -> unit val recover : unit -> unit val go_to : int64 -> unit val run : unit -> unit val back_run : unit -> unit val step : int64 -> unit val finish : unit -> unit val next : int -> unit val start : unit -> unit val previous : int -> unit mingw-ocaml/ocaml/debugger/symbols.mli0000644000175000017500000000357212124403240017443 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Modules used by the program. *) val modules : string list ref (* Read debugging info from executable file *) val read_symbols : string -> unit (* Flip "event" bit on all instructions *) val set_all_events : unit -> unit (* Return event at given PC, or raise Not_found *) (* Can also return pseudo-event at beginning of functions *) val any_event_at_pc : int -> Instruct.debug_event (* Return event at given PC, or raise Not_found *) val event_at_pc : int -> Instruct.debug_event (* Set event at given PC *) val set_event_at_pc : int -> unit (* List the events in `module'. *) val events_in_module : string -> Instruct.debug_event list (* First event after the given position. *) (* --- Raise `Not_found' if no such event. *) val event_at_pos : string -> int -> Instruct.debug_event (* Closest event from given position. *) (* --- Raise `Not_found' if no such event. *) val event_near_pos : string -> int -> Instruct.debug_event (* Recompute the current event *) val update_current_event : unit -> unit mingw-ocaml/ocaml/debugger/program_management.ml0000644000175000017500000001110212124403240021431 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Manage the loading of the program *) open Int64ops open Unix open Unix_tools open Debugger_config open Primitives open Parameters open Input_handling open Question open Program_loading open Time_travel (*** Connection opening and control. ***) (* Name of the file if the socket is in the unix domain.*) let file_name = ref (None : string option) (* Default connection handler. *) let buffer = String.create 1024 let control_connection pid fd = if (read fd.io_fd buffer 0 1024) = 0 then forget_process fd pid else begin prerr_string "Garbage data from process "; prerr_int pid; prerr_endline "" end (* Accept a connection from another process. *) let accept_connection continue fd = let (sock, _) = accept fd.io_fd in let io_chan = io_channel_of_descr sock in let pid = input_binary_int io_chan.io_in in if pid = -1 then begin let pid' = input_binary_int io_chan.io_in in new_checkpoint pid' io_chan; Input_handling.add_file io_chan (control_connection pid'); continue () end else begin if set_file_descriptor pid io_chan then Input_handling.add_file io_chan (control_connection pid) end (* Initialize the socket. *) let open_connection address continue = try let (sock_domain, sock_address) = convert_address address in file_name := (match sock_address with ADDR_UNIX file -> Some file | _ -> None); let sock = socket sock_domain SOCK_STREAM 0 in (try bind sock sock_address; setsockopt sock SO_REUSEADDR true; listen sock 3; connection := io_channel_of_descr sock; Input_handling.add_file !connection (accept_connection continue); connection_opened := true with x -> close sock; raise x) with Failure _ -> raise Toplevel | (Unix_error _) as err -> report_error err; raise Toplevel (* Close the socket. *) let close_connection () = if !connection_opened then begin connection_opened := false; Input_handling.remove_file !connection; close_io !connection; match !file_name with Some file -> unlink file | None -> () end (*** Kill program. ***) let loaded = ref false let kill_program () = Breakpoints.remove_all_breakpoints (); History.empty_history (); kill_all_checkpoints (); loaded := false; close_connection () let ask_kill_program () = if not !loaded then true else let answer = yes_or_no "A program is being debugged already. Kill it" in if answer then kill_program (); answer (*** Program loading and initializations. ***) let initialize_loading () = if !debug_loading then begin prerr_endline "Loading debugging information..."; Printf.fprintf Pervasives.stderr "\tProgram: [%s]\n%!" !program_name; end; begin try access !program_name [F_OK] with Unix_error _ -> prerr_endline "Program not found."; raise Toplevel; end; Symbols.read_symbols !program_name; if !debug_loading then prerr_endline "Opening a socket..."; open_connection !socket_name (function () -> go_to _0; Symbols.set_all_events(); exit_main_loop ()) (* Ensure the program is already loaded. *) let ensure_loaded () = if not !loaded then begin print_string "Loading program... "; flush Pervasives.stdout; if !program_name = "" then begin prerr_endline "No program specified."; raise Toplevel end; try initialize_loading(); !launching_func (); if !debug_loading then prerr_endline "Waiting for connection..."; main_loop (); loaded := true; prerr_endline "done." with x -> kill_program(); raise x end mingw-ocaml/ocaml/debugger/input_handling.mli0000644000175000017500000000410612124403240020750 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (***************************** Input control ***************************) open Primitives (*** Actives files. ***) (* Add a file to the list of active files. *) val add_file : io_channel -> (io_channel -> unit) -> unit (* Remove a file from the list of actives files. *) val remove_file : io_channel -> unit (* Return the controller currently attached to the given file. *) val current_controller : io_channel -> (io_channel -> unit) (* Execute a function with `controller' attached to `file'. *) (* ### controller file funct *) val execute_with_other_controller : (io_channel -> unit) -> io_channel -> (unit -> 'a) -> 'a (*** The "Main Loop" ***) (* Call this function for exiting the main loop. *) val exit_main_loop : 'a -> unit (* Handle active files until `continue_main_loop' is false. *) val main_loop : unit -> unit (*** Managing user inputs ***) (* Are we in interactive mode ? *) val interactif : bool ref val current_prompt : string ref (* Where the user input come from. *) val user_channel : io_channel ref val read_user_input : string -> int -> int (* Stop reading user input. *) val stop_user_input : unit -> unit (* Resume reading user input. *) val resume_user_input : unit -> unit mingw-ocaml/ocaml/debugger/events.mli0000644000175000017500000000236212124403240017253 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Instruct val get_pos : debug_event -> Lexing.position;; (** Current events. **) (* The event at current position. *) val current_event : debug_event option ref (* Current position in source. *) (* Raise `Not_found' if not on an event (beginning or end of program). *) val get_current_event : unit -> debug_event val current_event_is_before : unit -> bool mingw-ocaml/ocaml/debugger/command_line.mli0000644000175000017500000000211712124403240020372 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (************************ Reading and executing commands ***************) open Lexing;; open Format;; val interprete_line : formatter -> string -> bool;; val line_loop : formatter -> lexbuf -> unit;; mingw-ocaml/ocaml/debugger/envaux.mli0000644000175000017500000000244712124403240017261 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Format (* Convert environment summaries to environments *) val env_from_summary : Env.summary -> Subst.t -> Env.t val env_of_event: Instruct.debug_event option -> Env.t (* Empty the environment caches. To be called when load_path changes. *) val reset_cache: unit -> unit (* Error report *) type error = Module_not_found of Path.t exception Error of error val report_error: formatter -> error -> unit mingw-ocaml/ocaml/debugger/program_management.mli0000644000175000017500000000230112124403240021603 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (*** Program loading and initializations. ***) val loaded : bool ref val ensure_loaded : unit -> unit (*** Kill program. ***) val kill_program : unit -> unit (* Ask wether to kill the program or not. *) (* If yes, kill it. *) (* Return true iff the program has been killed. *) val ask_kill_program : unit -> bool mingw-ocaml/ocaml/debugger/unix_tools.mli0000644000175000017500000000256712124403240020161 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (**************************** Tools for Unix ***************************) open Unix (* Convert a socket name into a socket address. *) val convert_address : string -> socket_domain * sockaddr (* Report an unix error. *) val report_error : exn -> unit (* Find program `name' in `PATH'. *) (* Return the full path if found. *) (* Raise `Not_found' otherwise. *) val search_in_path : string -> string (* Path expansion. *) val expand_path : string -> string val make_absolute : string -> string mingw-ocaml/ocaml/debugger/symbols.ml0000644000175000017500000001415512124403240017271 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Handling of symbol tables (globals and events) *) open Instruct open Debugger_config (* Toplevel *) open Program_loading let modules = ref ([] : string list) let events = ref ([] : debug_event list) let events_by_pc = (Hashtbl.create 257 : (int, debug_event) Hashtbl.t) let events_by_module = (Hashtbl.create 17 : (string, debug_event array) Hashtbl.t) let all_events_by_module = (Hashtbl.create 17 : (string, debug_event list) Hashtbl.t) let relocate_event orig ev = ev.ev_pos <- orig + ev.ev_pos; match ev.ev_repr with Event_parent repr -> repr := ev.ev_pos | _ -> () let read_symbols' bytecode_file = let ic = open_in_bin bytecode_file in begin try Bytesections.read_toc ic; ignore(Bytesections.seek_section ic "SYMB"); with Bytesections.Bad_magic_number | Not_found -> prerr_string bytecode_file; prerr_endline " is not a bytecode file."; raise Toplevel end; Symtable.restore_state (input_value ic); begin try ignore (Bytesections.seek_section ic "DBUG") with Not_found -> prerr_string bytecode_file; prerr_endline " has no debugging info."; raise Toplevel end; let num_eventlists = input_binary_int ic in let eventlists = ref [] in for i = 1 to num_eventlists do let orig = input_binary_int ic in let evl = (input_value ic : debug_event list) in (* Relocate events in event list *) List.iter (relocate_event orig) evl; eventlists := evl :: !eventlists done; begin try ignore (Bytesections.seek_section ic "CODE") with Not_found -> (* The file contains only debugging info, loading mode is forced to "manual" *) set_launching_function (List.assoc "manual" loading_modes) end; close_in_noerr ic; !eventlists let read_symbols bytecode_file = let all_events = read_symbols' bytecode_file in modules := []; events := []; Hashtbl.clear events_by_pc; Hashtbl.clear events_by_module; Hashtbl.clear all_events_by_module; List.iter (fun evl -> List.iter (fun ev -> events := ev :: !events; Hashtbl.add events_by_pc ev.ev_pos ev) evl) all_events; List.iter (function [] -> () | ev :: _ as evl -> let md = ev.ev_module in let cmp ev1 ev2 = compare (Events.get_pos ev1).Lexing.pos_cnum (Events.get_pos ev2).Lexing.pos_cnum in let sorted_evl = List.sort cmp evl in modules := md :: !modules; Hashtbl.add all_events_by_module md sorted_evl; let real_evl = List.filter (function {ev_kind = Event_pseudo} -> false | _ -> true) sorted_evl in Hashtbl.add events_by_module md (Array.of_list real_evl)) all_events let any_event_at_pc pc = Hashtbl.find events_by_pc pc let event_at_pc pc = let ev = any_event_at_pc pc in match ev.ev_kind with Event_pseudo -> raise Not_found | _ -> ev let set_event_at_pc pc = try ignore(event_at_pc pc); Debugcom.set_event pc with Not_found -> () (* List all events in module *) let events_in_module mdle = try Hashtbl.find all_events_by_module mdle with Not_found -> [] (* Binary search of event at or just after char *) let find_event ev char = let rec bsearch lo hi = if lo >= hi then begin if (Events.get_pos ev.(hi)).Lexing.pos_cnum < char then raise Not_found else hi end else begin let pivot = (lo + hi) / 2 in let e = ev.(pivot) in if char <= (Events.get_pos e).Lexing.pos_cnum then bsearch lo pivot else bsearch (pivot + 1) hi end in bsearch 0 (Array.length ev - 1) (* Return first event after the given position. *) (* Raise [Not_found] if module is unknown or no event is found. *) let event_at_pos md char = let ev = Hashtbl.find events_by_module md in ev.(find_event ev char) (* Return event closest to given position *) (* Raise [Not_found] if module is unknown or no event is found. *) let event_near_pos md char = let ev = Hashtbl.find events_by_module md in try let pos = find_event ev char in (* Desired event is either ev.(pos) or ev.(pos - 1), whichever is closest *) if pos > 0 && char - (Events.get_pos ev.(pos - 1)).Lexing.pos_cnum <= (Events.get_pos ev.(pos)).Lexing.pos_cnum - char then ev.(pos - 1) else ev.(pos) with Not_found -> let pos = Array.length ev - 1 in if pos < 0 then raise Not_found; ev.(pos) (* Flip "event" bit on all instructions *) let set_all_events () = Hashtbl.iter (fun pc ev -> match ev.ev_kind with Event_pseudo -> () | _ -> Debugcom.set_event ev.ev_pos) events_by_pc (* Previous `pc'. *) (* Save time if `update_current_event' is called *) (* several times at the same point. *) let old_pc = ref (None : int option) (* Recompute the current event *) let update_current_event () = match Checkpoints.current_pc () with None -> Events.current_event := None; old_pc := None | (Some pc) as opt_pc when opt_pc <> !old_pc -> Events.current_event := begin try Some (event_at_pc pc) with Not_found -> None end; old_pc := opt_pc | _ -> () mingw-ocaml/ocaml/debugger/debugger_config.mli0000644000175000017500000000274412124403240021064 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (********************** Configuration file *****************************) exception Toplevel (*** Miscellaneous parameters. ***) val debugger_prompt : string val event_mark_before : string val event_mark_after : string val shell : string val runtime_program : string val history_size : int ref val load_path_for : (string, string list) Hashtbl.t (*** Time travel paramaters. ***) val checkpoint_big_step : int64 ref val checkpoint_small_step : int64 ref val checkpoint_max_count : int ref val make_checkpoints : bool ref (*** Environment variables for debugee. ***) val environment : string list ref mingw-ocaml/ocaml/debugger/unix_tools.ml0000644000175000017500000001225312124403240020001 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (****************** Tools for Unix *************************************) open Misc open Unix open Primitives (*** Convert a socket name into a socket address. ***) let convert_address address = try let n = String.index address ':' in let host = String.sub address 0 n and port = String.sub address (n + 1) (String.length address - n - 1) in (PF_INET, ADDR_INET ((try inet_addr_of_string host with Failure _ -> try (gethostbyname host).h_addr_list.(0) with Not_found -> prerr_endline ("Unknown host : " ^ host); failwith "Can't convert address"), (try int_of_string port with Failure _ -> prerr_endline "The port number should be an integer"; failwith "Can't convert address"))) with Not_found -> match Sys.os_type with "Win32" -> failwith "Unix sockets not supported" | _ -> (PF_UNIX, ADDR_UNIX address) (*** Report a unix error. ***) let report_error = function | Unix_error (err, fun_name, arg) -> prerr_string "Unix error : '"; prerr_string fun_name; prerr_string "' failed"; if String.length arg > 0 then (prerr_string " on '"; prerr_string arg; prerr_string "'"); prerr_string " : "; prerr_endline (error_message err) | _ -> fatal_error "report_error: not a Unix error" (* Find program `name' in `PATH'. *) (* Return the full path if found. *) (* Raise `Not_found' otherwise. *) let search_in_path name = Printf.fprintf Pervasives.stderr "search_in_path [%s]\n%!" name; let check name = try access name [X_OK]; name with Unix_error _ -> raise Not_found in if not (Filename.is_implicit name) then check name else let path = Sys.getenv "PATH" in let length = String.length path in let rec traverse pointer = if (pointer >= length) || (path.[pointer] = ':') then pointer else traverse (pointer + 1) in let rec find pos = let pos2 = traverse pos in let directory = (String.sub path pos (pos2 - pos)) in let fullname = if directory = "" then name else directory ^ "/" ^ name in try check fullname with | Not_found -> if pos2 < length then find (pos2 + 1) else raise Not_found in find 0 (* Expand a path. *) (* ### path -> path' *) let rec expand_path ch = let rec subst_variable ch = try let pos = String.index ch '$' in if (pos + 1 < String.length ch) && (ch.[pos + 1] = '$') then (String.sub ch 0 (pos + 1)) ^ (subst_variable (String.sub ch (pos + 2) (String.length ch - pos - 2))) else (String.sub ch 0 pos) ^ (subst2 (String.sub ch (pos + 1) (String.length ch - pos - 1))) with Not_found -> ch and subst2 ch = let suiv = let i = ref 0 in while !i < String.length ch && (let c = ch.[!i] in (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9') || c = '_') do incr i done; !i in (Sys.getenv (String.sub ch 0 suiv)) ^ (subst_variable (String.sub ch suiv (String.length ch - suiv))) in let ch = subst_variable ch in let concat_root nom ch2 = try Filename.concat (getpwnam nom).pw_dir ch2 with Not_found -> "~" ^ nom in if ch.[0] = '~' then try match String.index ch '/' with 1 -> (let tail = String.sub ch 2 (String.length ch - 2) in try Filename.concat (Sys.getenv "HOME") tail with Not_found -> concat_root (Sys.getenv "LOGNAME") tail) | n -> concat_root (String.sub ch 1 (n - 1)) (String.sub ch (n + 1) (String.length ch - n - 1)) with Not_found -> expand_path (ch ^ "/") else ch let make_absolute name = if Filename.is_relative name then Filename.concat (getcwd ()) name else name ;; mingw-ocaml/ocaml/debugger/int64ops.mli0000644000175000017500000000223512124403240017434 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocqencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (****************** arithmetic operators for Int64 *********************) val ( ++ ) : int64 -> int64 -> int64;; val ( -- ) : int64 -> int64 -> int64;; val suc64 : int64 -> int64;; val pre64 : int64 -> int64;; val _0 : int64;; val _1 : int64;; val _minus1 : int64;; val ( ~~ ) : string -> int64;; val max_small_int : int64;; val to_int : int64 -> int;; mingw-ocaml/ocaml/debugger/primitives.ml0000644000175000017500000000725112124403240017773 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (*********************** Basic functions and types *********************) (*** Miscellaneous ***) exception Out_of_range let nothing _ = () (*** Operations on lists. ***) (* Remove an element from a list *) let except e l = let rec except_e = function [] -> [] | elem::l -> if e = elem then l else elem::except_e l in except_e l (* Position of an element in a list. Head of list has position 0. *) let index a l = let rec index_rec i = function [] -> raise Not_found | b::l -> if a = b then i else index_rec (i + 1) l in index_rec 0 l (* Return the `n' first elements of `l' *) (* ### n l -> l' *) let rec list_truncate = fun p0 p1 -> match (p0,p1) with (0, _) -> [] | (_, []) -> [] | (n, (a::l)) -> a::(list_truncate (n - 1) l) (* Separe the `n' first elements of `l' and the others *) (* ### n list -> (first, last) *) let rec list_truncate2 = fun p0 p1 -> match (p0,p1) with (0, l) -> ([], l) | (_, []) -> ([], []) | (n, (a::l)) -> let (first, last) = (list_truncate2 (n - 1) l) in (a::first, last) (* Replace x by y in list l *) (* ### x y l -> l' *) let list_replace x y = let rec repl = function [] -> [] | a::l -> if a == x then y::l else a::(repl l) in repl (*** Operations on strings. ***) (* Remove blanks (spaces and tabs) at beginning and end of a string. *) let is_space = function | ' ' | '\t' -> true | _ -> false let string_trim s = let l = String.length s and i = ref 0 in while !i < l && is_space (String.get s !i) do incr i done; let j = ref (l - 1) in while !j >= !i && is_space (String.get s !j) do decr j done; String.sub s !i (!j - !i + 1) (* isprefix s1 s2 returns true if s1 is a prefix of s2. *) let isprefix s1 s2 = let l1 = String.length s1 and l2 = String.length s2 in (l1 = l2 && s1 = s2) || (l1 < l2 && s1 = String.sub s2 0 l1) (* Split a string at the given delimiter char *) let split_string sep str = let rec split i j = if j >= String.length str then if i >= j then [] else [String.sub str i (j-i)] else if str.[j] = sep then if i >= j then skip_sep (j+1) else String.sub str i (j-i) :: skip_sep (j+1) else split i (j+1) and skip_sep j = if j < String.length str && str.[j] = sep then skip_sep (j+1) else split j j in split 0 0 (*** I/O channels ***) type io_channel = { io_in : in_channel; io_out : out_channel; io_fd : Unix.file_descr } let io_channel_of_descr fd = { io_in = Unix.in_channel_of_descr fd; io_out = Unix.out_channel_of_descr fd; io_fd = fd } let close_io io_channel = close_out_noerr io_channel.io_out; close_in_noerr io_channel.io_in; ;; let std_io = { io_in = stdin; io_out = stdout; io_fd = Unix.stdin } mingw-ocaml/ocaml/debugger/events.ml0000644000175000017500000000317412124403240017104 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (********************************* Events ******************************) open Instruct let get_pos ev = match ev.ev_kind with | Event_before -> ev.ev_loc.Location.loc_start | Event_after _ -> ev.ev_loc.Location.loc_end | _ -> ev.ev_loc.Location.loc_start ;; (*** Current events. ***) (* Event at current position *) let current_event = ref (None : debug_event option) (* Current position in source. *) (* Raise `Not_found' if not on an event (beginning or end of program). *) let get_current_event () = match !current_event with | None -> raise Not_found | Some ev -> ev let current_event_is_before () = match !current_event with None -> raise Not_found | Some {ev_kind = Event_before} -> true | _ -> false mingw-ocaml/ocaml/debugger/show_information.mli0000644000175000017500000000243712124403240021337 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Format;; (* Display information about the current event. *) val show_current_event : formatter -> unit;; (* Display information about the current frame. *) (* --- `select frame' must have succeded before calling this function. *) val show_current_frame : formatter -> bool -> unit;; (* Display short information about one frame. *) val show_one_frame : int -> formatter -> Instruct.debug_event -> unit mingw-ocaml/ocaml/debugger/question.mli0000644000175000017500000000156312124403240017620 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Nicolas Pouillard, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* Ask user a yes or no question. *) val yes_or_no : string -> bool mingw-ocaml/ocaml/debugger/parameters.ml0000644000175000017500000000265712124403240017750 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Miscellaneous parameters *) open Primitives open Config open Debugger_config let program_loaded = ref false let program_name = ref "" let socket_name = ref "" let arguments = ref "" let default_load_path = ref [ Filename.current_dir_name; Config.standard_library ] let add_path dir = load_path := dir :: except dir !load_path; Envaux.reset_cache() let add_path_for mdl dir = let old = try Hashtbl.find load_path_for mdl with Not_found -> [] in Hashtbl.replace load_path_for mdl (dir :: old) (* Used by emacs ? *) let emacs = ref false mingw-ocaml/ocaml/debugger/Makefile0000644000175000017500000000155112124403240016703 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # $Id$ UNIXDIR=../otherlibs/unix include Makefile.shared mingw-ocaml/ocaml/debugger/debugcom.mli0000644000175000017500000000611112124403240017530 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Low-level communication with the debuggee *) type execution_summary = Event | Breakpoint | Exited | Trap_barrier | Uncaught_exc type report = { rep_type : execution_summary; rep_event_count : int; rep_stack_pointer : int; rep_program_pointer : int } type checkpoint_report = Checkpoint_done of int | Checkpoint_failed type follow_fork_mode = Fork_child | Fork_parent (* Set the current connection with the debuggee *) val set_current_connection : Primitives.io_channel -> unit (* Put an event at given pc *) val set_event : int -> unit (* Put a breakpoint at given pc *) val set_breakpoint : int -> unit (* Remove breakpoint or event at given pc *) val reset_instr : int -> unit (* Create a new checkpoint (the current process forks). *) val do_checkpoint : unit -> checkpoint_report (* Step N events. *) val do_go : int64 -> report (* Tell given process to terminate *) val stop : Primitives.io_channel -> unit (* Tell given process to wait for its children *) val wait_child : Primitives.io_channel -> unit (* Move to initial frame (that of current function). *) (* Return stack position and current pc *) val initial_frame : unit -> int * int val set_initial_frame : unit -> unit (* Get the current frame position *) (* Return stack position and current pc *) val get_frame : unit -> int * int (* Set the current frame *) val set_frame : int -> unit (* Move up one frame *) (* Return stack position and current pc. If there's no frame above, return (-1, 0). *) val up_frame : int -> int * int (* Set the trap barrier to given stack position. *) val set_trap_barrier : int -> unit (* Set whether the debugger follow the child or the parent process on fork *) val fork_mode : follow_fork_mode ref val update_follow_fork_mode : unit -> unit (* Handling of remote values *) exception Marshalling_error module Remote_value : sig type t val obj : t -> 'a val is_block : t -> bool val tag : t -> int val size : t -> int val field : t -> int -> t val same : t -> t -> bool val of_int : int -> t val local : int -> t val from_environment : int -> t val global : int -> t val accu : unit -> t val closure_code : t -> int end mingw-ocaml/ocaml/debugger/parameters.mli0000644000175000017500000000223212124403240020106 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Miscellaneous parameters *) val program_name : string ref val socket_name : string ref val arguments : string ref val default_load_path : string list ref val add_path : string -> unit val add_path_for : string -> string -> unit (* Used by emacs ? *) val emacs : bool ref mingw-ocaml/ocaml/debugger/pattern_matching.ml0000644000175000017500000002160712124403240021130 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (************************ Simple pattern matching **********************) open Debugger_config (*open Primitives*) open Misc (*open Const*) (*open Globals*) (*open Builtins*) open Typedtree (*open Modules*) (*open Symtable*) (*open Value*) open Parser_aux (* let rec find_constr tag = function [] -> fatal_error "find_constr: unknown constructor for this type" | constr::rest -> match constr.info.cs_tag with ConstrRegular(t, _) -> if t == tag then constr else find_constr tag rest | ConstrExtensible _ -> fatal_error "find_constr: extensible" let find_exception tag = let (qualid, stamp) = get_exn_of_num tag in let rec select_exn = function [] -> raise Not_found | constr :: rest -> match constr.info.cs_tag with ConstrExtensible(_,st) -> if st == stamp then constr else select_exn rest | ConstrRegular(_,_) -> fatal_error "find_exception: regular" in select_exn(hashtbl__find_all (find_module qualid.qual).mod_constrs qualid.id) *) let error_matching () = prerr_endline "Pattern matching failed"; raise Toplevel (* let same_name {qualid = name1} = function GRname name2 -> (name2 = "") || (name1.id = name2) | GRmodname name2 -> name1 = name2 let check_same_constr constr constr2 = try if not (same_name constr constr2) then error_matching () with Desc_not_found -> prerr_endline "Undefined constructor."; raise Toplevel *) let rec pattern_matching pattern obj ty = match pattern with P_dummy -> [] | P_variable var -> [var, obj, ty] | _ -> match (Ctype.repr ty).desc with Tvar | Tarrow _ -> error_matching () | Ttuple(ty_list) -> (match pattern with P_tuple pattern_list -> pattern_matching_list pattern_list obj ty_list | P_nth (n, patt) -> if n >= List.length ty_list then (prerr_endline "Out of range."; raise Toplevel); pattern_matching patt (Debugcom.get_field obj n) (List.nth ty_list n) | _ -> error_matching ()) | Tconstr(cstr, [ty_arg],_) when same_type_constr cstr constr_type_list -> (match pattern with P_list pattern_list -> let (last, list) = it_list (fun (current, list) pattern -> if value_tag current = 0 then error_matching (); (Debugcom.get_field current 1, (pattern, Debugcom.get_field current 0)::list)) (obj, []) pattern_list in if value_tag last <> 0 then error_matching (); flat_map (function (x, y) -> pattern_matching x y ty_arg) (rev list) | P_nth (n, patt) -> let rec find k current = if value_tag current = 0 then (prerr_endline "Out of range."; raise Toplevel); if k = 0 then pattern_matching patt (Debugcom.get_field current 0) ty_arg else find (k - 1) (Debugcom.get_field current 1) in find n obj | P_concat (pattern1, pattern2) -> if value_tag obj == 0 then error_matching (); (pattern_matching pattern1 (Debugcom.get_field obj 0) ty_arg) @ (pattern_matching pattern2 (Debugcom.get_field obj 1) ty) | _ -> error_matching ()) | Tconstr(cstr, [ty_arg]) when same_type_constr cstr constr_type_vect -> (match pattern with P_nth (n, patt) -> if n >= value_size obj then (prerr_endline "Out of range."; raise Toplevel); pattern_matching patt (Debugcom.get_field obj n) ty_arg | _ -> error_matching ()) | Tconstr(cstr, ty_list) -> (match cstr.info.ty_abbr with Tabbrev(params, body) -> pattern_matching pattern obj (expand_abbrev params body ty_list) | _ -> match_concrete_type pattern obj cstr ty ty_list) and match_concrete_type pattern obj cstr ty ty_list = let typ_descr = type_descr_of_type_constr cstr in match typ_descr.info.ty_desc with Abstract_type -> error_matching () | Variant_type constr_list -> let tag = value_tag obj in (try let constr = if same_type_constr cstr constr_type_exn then find_exception tag else find_constr tag constr_list in let (ty_res, ty_arg) = type_pair_instance (constr.info.cs_res, constr.info.cs_arg) in filter (ty_res, ty); match constr.info.cs_kind with Constr_constant -> error_matching () | Constr_regular -> (match pattern with P_constr (constr2, patt) -> check_same_constr constr constr2; pattern_matching patt (Debugcom.get_field obj 0) ty_arg | _ -> error_matching ()) | Constr_superfluous n -> (match pattern with P_constr (constr2, patt) -> check_same_constr constr constr2; (match patt with P_tuple pattern_list -> pattern_matching_list pattern_list obj (filter_product n ty_arg) | P_nth (n2, patt) -> let ty_list = filter_product n ty_arg in if n2 >= n then (prerr_endline "Out of range."; raise Toplevel); pattern_matching patt (Debugcom.get_field obj n2) (List.nth ty_list n2) | P_variable var -> [var, obj, {typ_desc = Tproduct (filter_product n ty_arg); typ_level = generic}] | P_dummy -> [] | _ -> error_matching ()) | _ -> error_matching ()) with Not_found -> error_matching () | Unify -> fatal_error "pattern_matching: types should match") | Record_type label_list -> let match_field (label, patt) = let lbl = try primitives__find (function l -> same_name l label) label_list with Not_found -> prerr_endline "Label not found."; raise Toplevel in let (ty_res, ty_arg) = type_pair_instance (lbl.info.lbl_res, lbl.info.lbl_arg) in (try filter (ty_res, ty) with Unify -> fatal_error "pattern_matching: types should match"); pattern_matching patt (Debugcom.get_field obj lbl.info.lbl_pos) ty_arg in (match pattern with P_record pattern_label_list -> flat_map match_field pattern_label_list | _ -> error_matching ()) | Abbrev_type(_,_) -> fatal_error "pattern_matching: abbrev type" and pattern_matching_list pattern_list obj ty_list = let val_list = try pair__combine (pattern_list, ty_list) with Invalid_argument _ -> error_matching () in flat_map (function (x, y, z) -> pattern_matching x y z) (rev (snd (it_list (fun (num, list) (pattern, typ) -> (num + 1, (pattern, Debugcom.get_field obj num, typ)::list)) (0, []) val_list))) mingw-ocaml/ocaml/debugger/frames.ml0000644000175000017500000001030412124403240017046 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (***************************** Frames **********************************) open Instruct open Debugcom open Events open Symbols (* Current frame number *) let current_frame = ref 0 (* Event at selected position *) let selected_event = ref (None : debug_event option) (* Selected position in source. *) (* Raise `Not_found' if not on an event. *) let selected_point () = match !selected_event with None -> raise Not_found | Some ev -> (ev.ev_module, (Events.get_pos ev).Lexing.pos_lnum, (Events.get_pos ev).Lexing.pos_cnum - (Events.get_pos ev).Lexing.pos_bol) let selected_event_is_before () = match !selected_event with None -> raise Not_found | Some {ev_kind = Event_before} -> true | _ -> false (* Move up `frame_count' frames, assuming current frame pointer corresponds to event `event'. Return event of final frame. *) let rec move_up frame_count event = if frame_count <= 0 then event else begin let (sp, pc) = up_frame event.ev_stacksize in if sp < 0 then raise Not_found; move_up (frame_count - 1) (any_event_at_pc pc) end (* Select a frame. *) (* Raise `Not_found' if no such frame. *) (* --- Assume the current events have already been updated. *) let select_frame frame_number = if frame_number < 0 then raise Not_found; let (initial_sp, _) = get_frame() in try match !current_event with None -> raise Not_found | Some curr_event -> match !selected_event with Some sel_event when frame_number >= !current_frame -> selected_event := Some(move_up (frame_number - !current_frame) sel_event); current_frame := frame_number | _ -> set_initial_frame(); selected_event := Some(move_up frame_number curr_event); current_frame := frame_number with Not_found -> set_frame initial_sp; raise Not_found (* Select a frame. *) (* Same as `select_frame' but raise no exception if the frame is not found. *) (* --- Assume the currents events have already been updated. *) let try_select_frame frame_number = try select_frame frame_number with Not_found -> () (* Return to default frame (frame 0). *) let reset_frame () = set_initial_frame(); selected_event := !current_event; current_frame := 0 (* Perform a stack backtrace. Call the given function with the events for each stack frame, or None if we've encountered a stack frame with no debugging info attached. Stop when the function returns false, or frame with no debugging info reached, or top of stack reached. *) let do_backtrace action = match !current_event with None -> Misc.fatal_error "Frames.do_backtrace" | Some curr_ev -> let (initial_sp, _) = get_frame() in set_initial_frame(); let event = ref curr_ev in begin try while action (Some !event) do let (sp, pc) = up_frame !event.ev_stacksize in if sp < 0 then raise Exit; event := any_event_at_pc pc done with Exit -> () | Not_found -> ignore (action None) end; set_frame initial_sp (* Return the number of frames in the stack *) let stack_depth () = let num_frames = ref 0 in do_backtrace (function Some ev -> incr num_frames; true | None -> num_frames := -1; false); !num_frames mingw-ocaml/ocaml/debugger/main.ml0000644000175000017500000001601712124403240016524 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Input_handling open Question open Command_line open Debugger_config open Checkpoints open Time_travel open Parameters open Program_management open Frames open Show_information open Format open Primitives let line_buffer = Lexing.from_function read_user_input let rec loop ppf = line_loop ppf line_buffer; if !loaded && (not (yes_or_no "The program is running. Quit anyway")) then loop ppf let current_duration = ref (-1L) let rec protect ppf restart loop = try loop ppf with | End_of_file -> protect ppf restart (function ppf -> forget_process !current_checkpoint.c_fd !current_checkpoint.c_pid; pp_print_flush ppf (); stop_user_input (); restart ppf) | Toplevel -> protect ppf restart (function ppf -> pp_print_flush ppf (); stop_user_input (); restart ppf) | Sys.Break -> protect ppf restart (function ppf -> fprintf ppf "Interrupted.@."; Exec.protect (function () -> stop_user_input (); if !loaded then begin try_select_frame 0; show_current_event ppf; end); restart ppf) | Current_checkpoint_lost -> protect ppf restart (function ppf -> fprintf ppf "Trying to recover...@."; stop_user_input (); recover (); try_select_frame 0; show_current_event ppf; restart ppf) | Current_checkpoint_lost_start_at (time, init_duration) -> protect ppf restart (function ppf -> let b = if !current_duration = -1L then begin let msg = sprintf "Restart from time %Ld and try to get closer of the problem" time in stop_user_input (); if yes_or_no msg then (current_duration := init_duration; true) else false end else true in if b then begin go_to time; current_duration := Int64.div !current_duration 10L; if !current_duration > 0L then while true do step !current_duration done else begin current_duration := -1L; stop_user_input (); show_current_event ppf; restart ppf; end end else begin recover (); show_current_event ppf; restart ppf end) | x -> kill_program (); raise x let execute_file_if_any () = let buffer = Buffer.create 128 in begin try let base = ".ocamldebug" in let file = if Sys.file_exists base then base else Filename.concat (Sys.getenv "HOME") base in let ch = open_in file in fprintf Format.std_formatter "Executing file %s@." file; while true do let line = string_trim (input_line ch) in if line <> "" && line.[0] <> '#' then begin Buffer.add_string buffer line; Buffer.add_char buffer '\n' end done; with _ -> () end; let len = Buffer.length buffer in if len > 0 then let commands = Buffer.sub buffer 0 (pred len) in line_loop Format.std_formatter (Lexing.from_string commands) let toplevel_loop () = interactif := false; current_prompt := ""; execute_file_if_any (); interactif := true; current_prompt := debugger_prompt; protect Format.std_formatter loop loop (* Parsing of command-line arguments *) exception Found_program_name let anonymous s = program_name := Unix_tools.make_absolute s; raise Found_program_name let add_include d = default_load_path := Misc.expand_directory Config.standard_library d :: !default_load_path let set_socket s = socket_name := s let set_checkpoints n = checkpoint_max_count := n let set_directory dir = Sys.chdir dir let print_version () = printf "The OCaml debugger, version %s@." Sys.ocaml_version; exit 0; ;; let print_version_num () = printf "%s@." Sys.ocaml_version; exit 0; ;; let speclist = [ "-c", Arg.Int set_checkpoints, " Set max number of checkpoints kept"; "-cd", Arg.String set_directory, " Change working directory"; "-emacs", Arg.Set emacs, "For running the debugger under emacs"; "-I", Arg.String add_include, " Add to the list of include directories"; "-s", Arg.String set_socket, " Set the name of the communication socket"; "-version", Arg.Unit print_version, " Print version and exit"; "-vnum", Arg.Unit print_version_num, " Print version number and exit"; ] let function_placeholder () = raise Not_found let main () = Callback.register "Debugger.function_placeholder" function_placeholder; try socket_name := (match Sys.os_type with "Win32" -> (Unix.string_of_inet_addr Unix.inet_addr_loopback)^ ":"^ (string_of_int (10000 + ((Unix.getpid ()) mod 10000))) | _ -> Filename.concat Filename.temp_dir_name ("camldebug" ^ (string_of_int (Unix.getpid ()))) ); begin try Arg.parse speclist anonymous ""; Arg.usage speclist "No program name specified\n\ Usage: ocamldebug [options] [arguments]\n\ Options are:"; exit 2 with Found_program_name -> for j = !Arg.current + 1 to Array.length Sys.argv - 1 do arguments := !arguments ^ " " ^ (Filename.quote Sys.argv.(j)) done end; printf "\tOCaml Debugger version %s@.@." Config.version; Config.load_path := !default_load_path; Clflags.recursive_types := true; (* Allow recursive types. *) toplevel_loop (); (* Toplevel. *) kill_program (); exit 0 with Toplevel -> exit 2 | Env.Error e -> eprintf "Debugger [version %s] environment error:@ @[@;" Config.version; Env.report_error err_formatter e; eprintf "@]@."; exit 2 | Cmi_format.Error e -> eprintf "Debugger [version %s] environment error:@ @[@;" Config.version; Cmi_format.report_error err_formatter e; eprintf "@]@."; exit 2 let _ = Printexc.catch (Unix.handle_unix_error main) () mingw-ocaml/ocaml/debugger/Makefile.nt0000644000175000017500000000155612124403240017330 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # $Id$ UNIXDIR=../otherlibs/win32unix include Makefile.shared mingw-ocaml/ocaml/debugger/trap_barrier.mli0000644000175000017500000000242312124403240020421 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (************************* Trap barrier ********************************) val install_trap_barrier : int -> unit val remove_trap_barrier : unit -> unit (* Ensure the trap barrier state is up to date in current checkpoint. *) val update_trap_barrier : unit -> unit (* Execute `funct' with a trap barrier. *) (* --- Used by `finish'. *) val exec_with_trap_barrier : int -> (unit -> unit) -> unit mingw-ocaml/ocaml/debugger/loadprinter.mli0000644000175000017500000000247112124403240020273 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Loading and installation of user-defined printer functions *) open Format val loadfile : formatter -> string -> unit val install_printer : formatter -> Longident.t -> unit val remove_printer : Longident.t -> unit (* Error report *) type error = | Load_failure of Dynlink.error | Unbound_identifier of Longident.t | Unavailable_module of string * Longident.t | Wrong_type of Longident.t | No_active_printer of Longident.t exception Error of error val report_error: formatter -> error -> unit mingw-ocaml/ocaml/debugger/lexer.mli0000644000175000017500000000205612124403240017066 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) val line: Lexing.lexbuf -> string val lexeme: Lexing.lexbuf -> Parser.token val argument: Lexing.lexbuf -> Parser.token val line_argument: Lexing.lexbuf -> Parser.token mingw-ocaml/ocaml/debugger/frames.mli0000644000175000017500000000434312124403240017225 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (****************************** Frames *********************************) open Instruct open Primitives (* Current frame number *) val current_frame : int ref (* Event at selected position. *) val selected_event : debug_event option ref (* Selected position in source (module, line, column). *) (* Raise `Not_found' if not on an event. *) val selected_point : unit -> string * int * int val selected_event_is_before : unit -> bool (* Select a frame. *) (* Raise `Not_found' if no such frame. *) (* --- Assume the currents events have already been updated. *) val select_frame : int -> unit (* Select a frame. *) (* Same as `select_frame' but raise no exception if the frame is not found. *) (* --- Assume the currents events have already been updated. *) val try_select_frame : int -> unit (* Return to default frame (frame 0). *) val reset_frame : unit -> unit (* Perform a stack backtrace. Call the given function with the events for each stack frame, or None if we've encountered a stack frame with no debugging info attached. Stop when the function returns false, or frame with no debugging info reached, or top of stack reached. *) val do_backtrace : (debug_event option -> bool) -> unit (* Return the number of frames in the stack, or (-1) if it can't be determined because some frames have no debugging info. *) val stack_depth : unit -> int mingw-ocaml/ocaml/debugger/lexer.mll0000644000175000017500000000520312124403240017066 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) { open Parser } rule line = (* Read a whole line *) parse ([ ^ '\n' '\r' ]* as s) ('\n' | '\r' | "\r\n") { s } | [ ^ '\n' '\r' ]* { Lexing.lexeme lexbuf } | eof { raise Exit } and argument = (* Read a raw argument *) parse [ ^ ' ' '\t' ]+ { ARGUMENT (Lexing.lexeme lexbuf) } | [' ' '\t']+ { argument lexbuf } | eof { EOL } | _ { raise Parsing.Parse_error } and line_argument = parse _ * { ARGUMENT (Lexing.lexeme lexbuf) } | eof { EOL } and lexeme = (* Read a lexeme *) parse [' ' '\t'] + { lexeme lexbuf } | ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] (['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9' ]) * { LIDENT(Lexing.lexeme lexbuf) } | ['A'-'Z' '\192'-'\214' '\216'-'\222' ] (['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9' ]) * { UIDENT(Lexing.lexeme lexbuf) } | '"' [^ '"']* "\"" { let s = Lexing.lexeme lexbuf in LIDENT(String.sub s 1 (String.length s - 2)) } | ['0'-'9']+ | '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ | '0' ['o' 'O'] ['0'-'7']+ | '0' ['b' 'B'] ['0'-'1']+ { INTEGER (Int64.of_string (Lexing.lexeme lexbuf)) } | '*' { STAR } | "-" { MINUS } | "." { DOT } | "#" { SHARP } | "@" { AT } | "$" { DOLLAR } | "!" { BANG } | "(" { LPAREN } | ")" { RPAREN } | "[" { LBRACKET } | "]" { RBRACKET } | ['!' '?' '~' '=' '<' '>' '|' '&' '$' '@' '^' '+' '-' '*' '/' '%'] ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] * { OPERATOR (Lexing.lexeme lexbuf) } | eof { EOL } | _ { raise Parsing.Parse_error } mingw-ocaml/ocaml/debugger/eval.ml0000644000175000017500000001716612124403240016535 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Misc open Path open Instruct open Types open Parser_aux type error = Unbound_identifier of Ident.t | Not_initialized_yet of Path.t | Unbound_long_identifier of Longident.t | Unknown_name of int | Tuple_index of type_expr * int * int | Array_index of int * int | List_index of int * int | String_index of string * int * int | Wrong_item_type of type_expr * int | Wrong_label of type_expr * string | Not_a_record of type_expr | No_result exception Error of error let abstract_type = Btype.newgenty (Tconstr (Pident (Ident.create ""), [], ref Mnil)) let rec path event = function Pident id -> if Ident.global id then try Debugcom.Remote_value.global (Symtable.get_global_position id) with Symtable.Error _ -> raise(Error(Unbound_identifier id)) else begin match event with Some ev -> begin try let pos = Ident.find_same id ev.ev_compenv.ce_stack in Debugcom.Remote_value.local (ev.ev_stacksize - pos) with Not_found -> try let pos = Ident.find_same id ev.ev_compenv.ce_heap in Debugcom.Remote_value.from_environment pos with Not_found -> raise(Error(Unbound_identifier id)) end | None -> raise(Error(Unbound_identifier id)) end | Pdot(root, fieldname, pos) -> let v = path event root in if not (Debugcom.Remote_value.is_block v) then raise(Error(Not_initialized_yet root)); Debugcom.Remote_value.field v pos | Papply(p1, p2) -> fatal_error "Eval.path: Papply" let rec expression event env = function E_ident lid -> begin try let (p, valdesc) = Env.lookup_value lid env in (begin match valdesc.val_kind with Val_ivar (_, cl_num) -> let (p0, _) = Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env in let v = path event p0 in let i = path event p in Debugcom.Remote_value.field v (Debugcom.Remote_value.obj i) | _ -> path event p end, Ctype.correct_levels valdesc.val_type) with Not_found -> raise(Error(Unbound_long_identifier lid)) end | E_result -> begin match event with Some {ev_kind = Event_after ty; ev_typsubst = subst} when !Frames.current_frame = 0 -> (Debugcom.Remote_value.accu(), Subst.type_expr subst ty) | _ -> raise(Error(No_result)) end | E_name n -> begin try Printval.find_named_value n with Not_found -> raise(Error(Unknown_name n)) end | E_item(arg, n) -> let (v, ty) = expression event env arg in begin match (Ctype.repr(Ctype.expand_head_opt env ty)).desc with Ttuple ty_list -> if n < 1 || n > List.length ty_list then raise(Error(Tuple_index(ty, List.length ty_list, n))) else (Debugcom.Remote_value.field v (n-1), List.nth ty_list (n-1)) | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array -> let size = Debugcom.Remote_value.size v in if n >= size then raise(Error(Array_index(size, n))) else (Debugcom.Remote_value.field v n, ty_arg) | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list -> let rec nth pos v = if not (Debugcom.Remote_value.is_block v) then raise(Error(List_index(pos, n))) else if pos = n then (Debugcom.Remote_value.field v 0, ty_arg) else nth (pos + 1) (Debugcom.Remote_value.field v 1) in nth 0 v | Tconstr(path, [], _) when Path.same path Predef.path_string -> let s = (Debugcom.Remote_value.obj v : string) in if n >= String.length s then raise(Error(String_index(s, String.length s, n))) else (Debugcom.Remote_value.of_int(Char.code s.[n]), Predef.type_char) | _ -> raise(Error(Wrong_item_type(ty, n))) end | E_field(arg, lbl) -> let (v, ty) = expression event env arg in begin match (Ctype.repr(Ctype.expand_head_opt env ty)).desc with Tconstr(path, args, _) -> let tydesc = Env.find_type path env in begin match tydesc.type_kind with Type_record(lbl_list, repr) -> let (pos, ty_res) = find_label lbl env ty path tydesc 0 lbl_list in (Debugcom.Remote_value.field v pos, ty_res) | _ -> raise(Error(Not_a_record ty)) end | _ -> raise(Error(Not_a_record ty)) end and find_label lbl env ty path tydesc pos = function [] -> raise(Error(Wrong_label(ty, lbl))) | (name, mut, ty_arg) :: rem -> if Ident.name name = lbl then begin let ty_res = Btype.newgenty(Tconstr(path, tydesc.type_params, ref Mnil)) in (pos, try Ctype.apply env [ty_res] ty_arg [ty] with Ctype.Cannot_apply -> abstract_type) end else find_label lbl env ty path tydesc (pos + 1) rem (* Error report *) open Format let report_error ppf = function | Unbound_identifier id -> fprintf ppf "@[Unbound identifier %s@]@." (Ident.name id) | Not_initialized_yet path -> fprintf ppf "@[The module path %a is not yet initialized.@ \ Please run program forward@ \ until its initialization code is executed.@]@." Printtyp.path path | Unbound_long_identifier lid -> fprintf ppf "@[Unbound identifier %a@]@." Printtyp.longident lid | Unknown_name n -> fprintf ppf "@[Unknown value name $%i@]@." n | Tuple_index(ty, len, pos) -> Printtyp.reset_and_mark_loops ty; fprintf ppf "@[Cannot extract field number %i from a %i-tuple of type@ %a@]@." pos len Printtyp.type_expr ty | Array_index(len, pos) -> fprintf ppf "@[Cannot extract element number %i from an array of length %i@]@." pos len | List_index(len, pos) -> fprintf ppf "@[Cannot extract element number %i from a list of length %i@]@." pos len | String_index(s, len, pos) -> fprintf ppf "@[Cannot extract character number %i@ \ from the following string of length %i:@ %S@]@." pos len s | Wrong_item_type(ty, pos) -> fprintf ppf "@[Cannot extract item number %i from a value of type@ %a@]@." pos Printtyp.type_expr ty | Wrong_label(ty, lbl) -> fprintf ppf "@[The record type@ %a@ has no label named %s@]@." Printtyp.type_expr ty lbl | Not_a_record ty -> fprintf ppf "@[The type@ %a@ is not a record type@]@." Printtyp.type_expr ty | No_result -> fprintf ppf "@[No result available at current program event@]@." mingw-ocaml/ocaml/debugger/history.mli0000644000175000017500000000175712124403240017457 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) val empty_history : unit -> unit val add_current_time : unit -> unit val previous_time : int64 -> int64 mingw-ocaml/ocaml/debugger/pos.mli0000644000175000017500000000155312124403240016551 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocquencourt *) (* *) (* Copyright 2003 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) val get_desc : Instruct.debug_event -> string;; mingw-ocaml/ocaml/debugger/show_information.ml0000644000175000017500000000705612124403240021170 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Instruct open Format open Debugcom open Checkpoints open Events open Symbols open Frames open Source open Show_source open Breakpoints (* Display information about the current event. *) let show_current_event ppf = fprintf ppf "Time : %Li" (current_time ()); (match current_pc () with | Some pc -> fprintf ppf " - pc : %i" pc | _ -> ()); update_current_event (); reset_frame (); match current_report () with | None -> fprintf ppf "@.Beginning of program.@."; show_no_point () | Some {rep_type = (Event | Breakpoint); rep_program_pointer = pc} -> let ev = get_current_event () in fprintf ppf " - module %s@." ev.ev_module; (match breakpoints_at_pc pc with | [] -> () | [breakpoint] -> fprintf ppf "Breakpoint : %i@." breakpoint | breakpoints -> fprintf ppf "Breakpoints : %a@." (fun ppf l -> List.iter (function x -> fprintf ppf "%i " x) l) (List.sort compare breakpoints)); show_point ev true | Some {rep_type = Exited} -> fprintf ppf "@.Program exit.@."; show_no_point () | Some {rep_type = Uncaught_exc} -> fprintf ppf "@.Program end.@.\ @[Uncaught exception:@ %a@]@." Printval.print_exception (Debugcom.Remote_value.accu ()); show_no_point () | Some {rep_type = Trap_barrier} -> (* Trap_barrier not visible outside *) (* of module `time_travel'. *) Misc.fatal_error "Show_information.show_current_event" (* Display short information about one frame. *) let show_one_frame framenum ppf event = let pos = Events.get_pos event in let cnum = try let buffer = get_buffer pos event.ev_module in snd (start_and_cnum buffer pos) with _ -> pos.Lexing.pos_cnum in fprintf ppf "#%i Pc : %i %s char %i@." framenum event.ev_pos event.ev_module cnum (* Display information about the current frame. *) (* --- `select frame' must have succeded before calling this function. *) let show_current_frame ppf selected = match !selected_event with | None -> fprintf ppf "@.No frame selected.@." | Some sel_ev -> show_one_frame !current_frame ppf sel_ev; begin match breakpoints_at_pc sel_ev.ev_pos with | [] -> () | [breakpoint] -> fprintf ppf "Breakpoint : %i@." breakpoint | breakpoints -> fprintf ppf "Breakpoints : %a@." (fun ppf l -> List.iter (function x -> fprintf ppf "%i " x) l) (List.sort compare breakpoints); end; show_point sel_ev selected mingw-ocaml/ocaml/debugger/trap_barrier.ml0000644000175000017500000000333612124403240020254 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (************************** Trap barrier *******************************) open Debugcom open Checkpoints let current_trap_barrier = ref 0 let install_trap_barrier pos = current_trap_barrier := pos let remove_trap_barrier () = current_trap_barrier := 0 (* Ensure the trap barrier state is up to date in current checkpoint. *) let update_trap_barrier () = if !current_checkpoint.c_trap_barrier <> !current_trap_barrier then Exec.protect (function () -> set_trap_barrier !current_trap_barrier; !current_checkpoint.c_trap_barrier <- !current_trap_barrier) (* Execute `funct' with a trap barrier. *) (* --- Used by `finish'. *) let exec_with_trap_barrier trap_barrier funct = try install_trap_barrier trap_barrier; funct (); remove_trap_barrier () with x -> remove_trap_barrier (); raise x mingw-ocaml/ocaml/debugger/command_line.ml0000644000175000017500000011517012124403240020225 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (************************ Reading and executing commands ***************) open Int64ops open Format open Misc open Instruct open Unix open Debugger_config open Types open Primitives open Unix_tools open Parser open Parser_aux open Lexer open Input_handling open Question open Debugcom open Program_loading open Program_management open Lexing open Parameters open Show_source open Show_information open Time_travel open Events open Symbols open Source open Breakpoints open Checkpoints open Frames open Printval (** Instructions, variables and infos lists. **) type dbg_instruction = { instr_name: string; (* Name of command *) instr_prio: bool; (* Has priority *) instr_action: formatter -> lexbuf -> unit; (* What to do *) instr_repeat: bool; (* Can be repeated *) instr_help: string } (* Help message *) let instruction_list = ref ([] : dbg_instruction list) type dbg_variable = { var_name: string; (* Name of variable *) var_action: (lexbuf -> unit) * (formatter -> unit); (* Reading, writing fns *) var_help: string } (* Help message *) let variable_list = ref ([] : dbg_variable list) type dbg_info = { info_name: string; (* Name of info *) info_action: lexbuf -> unit; (* What to do *) info_help: string } (* Help message *) let info_list = ref ([] : dbg_info list) (** Utilities. **) let error text = eprintf "%s@." text; raise Toplevel let check_not_windows feature = match Sys.os_type with | "Win32" -> error ("'"^feature^"' feature not supported on Windows") | _ -> () let eol = end_of_line Lexer.lexeme let matching_elements list name instr = List.filter (function a -> isprefix instr (name a)) !list let all_matching_instructions = matching_elements instruction_list (fun i -> i.instr_name) (* itz 04-21-96 don't do priority completion in emacs mode *) (* XL 25-02-97 why? I find it very confusing. *) let matching_instructions instr = let all = all_matching_instructions instr in let prio = List.filter (fun i -> i.instr_prio) all in if prio = [] then all else prio let matching_variables = matching_elements variable_list (fun v -> v.var_name) let matching_infos = matching_elements info_list (fun i -> i.info_name) let find_ident name matcher action alternative ppf lexbuf = match identifier_or_eol Lexer.lexeme lexbuf with | None -> alternative ppf | Some ident -> match matcher ident with | [] -> error ("Unknown " ^ name ^ ".") | [a] -> action a ppf lexbuf | _ -> error ("Ambiguous " ^ name ^ ".") let find_variable action alternative ppf lexbuf = find_ident "variable name" matching_variables action alternative ppf lexbuf let find_info action alternative ppf lexbuf = find_ident "info command" matching_infos action alternative ppf lexbuf let add_breakpoint_at_pc pc = try new_breakpoint (any_event_at_pc pc) with | Not_found -> eprintf "Can't add breakpoint at pc %i : no event there.@." pc; raise Toplevel let add_breakpoint_after_pc pc = let rec try_add n = if n < 3 then begin try new_breakpoint (any_event_at_pc (pc + n * 4)) with | Not_found -> try_add (n+1) end else begin error "Can't add breakpoint at beginning of function: no event there" end in try_add 0 let module_of_longident id = match id with | Some x -> Some (String.concat "." (Longident.flatten x)) | None -> None let convert_module mdle = match mdle with | Some m -> (* Strip .ml extension if any, and capitalize *) String.capitalize(if Filename.check_suffix m ".ml" then Filename.chop_suffix m ".ml" else m) | None -> try (get_current_event ()).ev_module with | Not_found -> error "Not in a module." (** Toplevel. **) let current_line = ref "" let interprete_line ppf line = current_line := line; let lexbuf = Lexing.from_string line in try match identifier_or_eol Lexer.lexeme lexbuf with | Some x -> begin match matching_instructions x with | [] -> error "Unknown command." | [i] -> i.instr_action ppf lexbuf; resume_user_input (); i.instr_repeat | l -> error "Ambiguous command." end | None -> resume_user_input (); false with | Parsing.Parse_error -> error "Syntax error." let line_loop ppf line_buffer = resume_user_input (); let previous_line = ref "" in try while true do if !loaded then History.add_current_time (); let new_line = string_trim (line line_buffer) in let line = if new_line <> "" then new_line else !previous_line in previous_line := ""; if interprete_line ppf line then previous_line := line done with | Exit -> stop_user_input () (* | Sys_error s -> error ("System error : " ^ s) *) (** Instructions. **) let instr_cd ppf lexbuf = let dir = argument_eol argument lexbuf in if ask_kill_program () then try Sys.chdir (expand_path dir) with | Sys_error s -> error s let instr_shell ppf lexbuf = let cmdarg = argument_list_eol argument lexbuf in let cmd = String.concat " " cmdarg in (* perhaps we should use $SHELL -c ? *) let err = Sys.command cmd in if (err != 0) then eprintf "Shell command %S failed with exit code %d\n%!" cmd err let instr_env ppf lexbuf = let cmdarg = argument_list_eol argument lexbuf in let cmdarg = string_trim (String.concat " " cmdarg) in if cmdarg <> "" then try if (String.index cmdarg '=') > 0 then Debugger_config.environment := cmdarg :: !Debugger_config.environment else eprintf "Environment variables should not have an empty name\n%!" with Not_found -> eprintf "Environment variables should have the \"name=value\" format\n%!" else List.iter (printf "%s\n%!") (List.rev !Debugger_config.environment) let instr_pwd ppf lexbuf = eol lexbuf; fprintf ppf "%s@." (Sys.getcwd ()) let instr_dir ppf lexbuf = let new_directory = argument_list_eol argument lexbuf in if new_directory = [] then begin if yes_or_no "Reinitialize directory list" then begin Config.load_path := !default_load_path; Envaux.reset_cache (); Hashtbl.clear Debugger_config.load_path_for; flush_buffer_list () end end else begin let new_directory' = List.rev new_directory in match new_directory' with | mdl :: for_keyw :: tl when (String.lowercase for_keyw) = "for" && (List.length tl) > 0 -> List.iter (function x -> add_path_for mdl (expand_path x)) tl | _ -> List.iter (function x -> add_path (expand_path x)) new_directory' end; let print_dirs ppf l = List.iter (function x -> fprintf ppf "@ %s" x) l in fprintf ppf "@[<2>Directories :%a@]@." print_dirs !Config.load_path; Hashtbl.iter (fun mdl dirs -> fprintf ppf "@[<2>Source directories for %s :%a@]@." mdl print_dirs dirs) Debugger_config.load_path_for let instr_kill ppf lexbuf = eol lexbuf; if not !loaded then error "The program is not being run."; if (yes_or_no "Kill the program being debugged") then begin kill_program (); show_no_point() end let instr_run ppf lexbuf = eol lexbuf; ensure_loaded (); reset_named_values (); run (); show_current_event ppf;; let instr_reverse ppf lexbuf = eol lexbuf; check_not_windows "reverse"; ensure_loaded (); reset_named_values(); back_run (); show_current_event ppf let instr_step ppf lexbuf = let step_count = match opt_signed_int64_eol Lexer.lexeme lexbuf with | None -> _1 | Some x -> x in ensure_loaded (); reset_named_values(); step step_count; show_current_event ppf let instr_back ppf lexbuf = let step_count = match opt_signed_int64_eol Lexer.lexeme lexbuf with | None -> _1 | Some x -> x in check_not_windows "backstep"; ensure_loaded (); reset_named_values(); step (_0 -- step_count); show_current_event ppf let instr_finish ppf lexbuf = eol lexbuf; ensure_loaded (); reset_named_values(); finish (); show_current_event ppf let instr_next ppf lexbuf = let step_count = match opt_integer_eol Lexer.lexeme lexbuf with | None -> 1 | Some x -> x in ensure_loaded (); reset_named_values(); next step_count; show_current_event ppf let instr_start ppf lexbuf = eol lexbuf; check_not_windows "start"; ensure_loaded (); reset_named_values(); start (); show_current_event ppf let instr_previous ppf lexbuf = let step_count = match opt_integer_eol Lexer.lexeme lexbuf with | None -> 1 | Some x -> x in check_not_windows "previous"; ensure_loaded (); reset_named_values(); previous step_count; show_current_event ppf let instr_goto ppf lexbuf = let time = int64_eol Lexer.lexeme lexbuf in ensure_loaded (); reset_named_values(); go_to time; show_current_event ppf let instr_quit _ = raise Exit let print_variable_list ppf = let pr_vars ppf = List.iter (fun v -> fprintf ppf "%s@ " v.var_name) in fprintf ppf "List of variables :%a@." pr_vars !variable_list let print_info_list ppf = let pr_infos ppf = List.iter (fun i -> fprintf ppf "%s@ " i.info_name) in fprintf ppf "List of info commands :%a@." pr_infos !info_list let instr_complete ppf lexbuf = let ppf = Format.err_formatter in let rec print_list l = try eol lexbuf; List.iter (function i -> fprintf ppf "%s@." i) l with _ -> remove_file !user_channel and match_list lexbuf = match identifier_or_eol Lexer.lexeme lexbuf with | None -> List.map (fun i -> i.instr_name) !instruction_list | Some x -> match matching_instructions x with | [ {instr_name = ("set" | "show" as i_full)} ] -> if x = i_full then begin match identifier_or_eol Lexer.lexeme lexbuf with | Some ident -> begin match matching_variables ident with | [v] -> if v.var_name = ident then [] else [v.var_name] | l -> List.map (fun v -> v.var_name) l end | None -> List.map (fun v -> v.var_name) !variable_list end else [i_full] | [ {instr_name = "info"} ] -> if x = "info" then begin match identifier_or_eol Lexer.lexeme lexbuf with | Some ident -> begin match matching_infos ident with | [i] -> if i.info_name = ident then [] else [i.info_name] | l -> List.map (fun i -> i.info_name) l end | None -> List.map (fun i -> i.info_name) !info_list end else ["info"] | [ {instr_name = "help"} ] -> if x = "help" then match_list lexbuf else ["help"] | [ i ] -> if x = i.instr_name then [] else [i.instr_name] | l -> List.map (fun i -> i.instr_name) l in print_list(match_list lexbuf) let instr_help ppf lexbuf = let pr_instrs ppf = List.iter (fun i -> fprintf ppf "%s@ " i.instr_name) in match identifier_or_eol Lexer.lexeme lexbuf with | Some x -> let print_help nm hlp = eol lexbuf; fprintf ppf "%s : %s@." nm hlp in begin match matching_instructions x with | [] -> eol lexbuf; fprintf ppf "No matching command.@." | [ {instr_name = "set"} ] -> find_variable (fun v _ _ -> print_help ("set " ^ v.var_name) ("set " ^ v.var_help)) (fun ppf -> print_help "set" "set debugger variable."; print_variable_list ppf) ppf lexbuf | [ {instr_name = "show"} ] -> find_variable (fun v _ _ -> print_help ("show " ^ v.var_name) ("show " ^ v.var_help)) (fun v -> print_help "show" "display debugger variable."; print_variable_list ppf) ppf lexbuf | [ {instr_name = "info"} ] -> find_info (fun i _ _ -> print_help ("info " ^ i.info_name) i.info_help) (fun ppf -> print_help "info" "display infos about the program being debugged."; print_info_list ppf) ppf lexbuf | [i] -> print_help i.instr_name i.instr_help | l -> eol lexbuf; fprintf ppf "Ambiguous command \"%s\" : %a@." x pr_instrs l end | None -> fprintf ppf "List of commands : %a@." pr_instrs !instruction_list (* Printing values *) let print_expr depth ev env ppf expr = try let (v, ty) = Eval.expression ev env expr in print_named_value depth expr env v ppf ty with | Eval.Error msg -> Eval.report_error ppf msg; raise Toplevel let print_command depth ppf lexbuf = let exprs = expression_list_eol Lexer.lexeme lexbuf in ensure_loaded (); let env = try Envaux.env_of_event !selected_event with | Envaux.Error msg -> Envaux.report_error ppf msg; raise Toplevel in List.iter (print_expr depth !selected_event env ppf) exprs let instr_print ppf lexbuf = print_command !max_printer_depth ppf lexbuf let instr_display ppf lexbuf = print_command 1 ppf lexbuf (* Loading of command files *) let extract_filename arg = (* Allow enclosing filename in quotes *) let l = String.length arg in let pos1 = if l > 0 && arg.[0] = '"' then 1 else 0 in let pos2 = if l > 0 && arg.[l-1] = '"' then l-1 else l in String.sub arg pos1 (pos2 - pos1) let instr_source ppf lexbuf = let file = extract_filename(argument_eol argument lexbuf) and old_state = !interactif and old_channel = !user_channel in let io_chan = try io_channel_of_descr (openfile (find_in_path !Config.load_path (expand_path file)) [O_RDONLY] 0) with | Not_found -> error "Source file not found." | (Unix_error _) as x -> Unix_tools.report_error x; raise Toplevel in try interactif := false; user_channel := io_chan; line_loop ppf (Lexing.from_function read_user_input); close_io io_chan; interactif := old_state; user_channel := old_channel with | x -> stop_user_input (); close_io io_chan; interactif := old_state; user_channel := old_channel; raise x let instr_set = find_variable (fun {var_action = (funct, _)} ppf lexbuf -> funct lexbuf) (function ppf -> error "Argument required.") let instr_show = find_variable (fun {var_action = (_, funct)} ppf lexbuf -> eol lexbuf; funct ppf) (function ppf -> List.iter (function {var_name = nm; var_action = (_, funct)} -> fprintf ppf "%s : " nm; funct ppf) !variable_list) let instr_info = find_info (fun i ppf lexbuf -> i.info_action lexbuf) (function ppf -> error "\"info\" must be followed by the name of an info command.") let instr_break ppf lexbuf = let argument = break_argument_eol Lexer.lexeme lexbuf in ensure_loaded (); match argument with | BA_none -> (* break *) (match !selected_event with | Some ev -> new_breakpoint ev | None -> error "Can't add breakpoint at this point.") | BA_pc pc -> (* break PC *) add_breakpoint_at_pc pc | BA_function expr -> (* break FUNCTION *) let env = try Envaux.env_of_event !selected_event with | Envaux.Error msg -> Envaux.report_error ppf msg; raise Toplevel in begin try let (v, ty) = Eval.expression !selected_event env expr in match (Ctype.repr ty).desc with | Tarrow _ -> add_breakpoint_after_pc (Remote_value.closure_code v) | _ -> eprintf "Not a function.@."; raise Toplevel with | Eval.Error msg -> Eval.report_error ppf msg; raise Toplevel end | BA_pos1 (mdle, line, column) -> (* break @ [MODULE] LINE [COL] *) let module_name = convert_module (module_of_longident mdle) in new_breakpoint (try let buffer = try get_buffer Lexing.dummy_pos module_name with | Not_found -> eprintf "No source file for %s.@." module_name; raise Toplevel in match column with | None -> event_at_pos module_name (fst (pos_of_line buffer line)) | Some col -> event_near_pos module_name (point_of_coord buffer line col) with | Not_found -> (* event_at_pos / event_near pos *) eprintf "Can't find any event there.@."; raise Toplevel | Out_of_range -> (* pos_of_line / point_of_coord *) eprintf "Position out of range.@."; raise Toplevel) | BA_pos2 (mdle, position) -> (* break @ [MODULE] # POSITION *) try new_breakpoint (event_near_pos (convert_module (module_of_longident mdle)) position) with | Not_found -> eprintf "Can't find any event there.@." let instr_delete ppf lexbuf = match integer_list_eol Lexer.lexeme lexbuf with | [] -> if breakpoints_count () <> 0 && yes_or_no "Delete all breakpoints" then remove_all_breakpoints () | breakpoints -> List.iter (function x -> try remove_breakpoint x with | Not_found -> ()) breakpoints let instr_frame ppf lexbuf = let frame_number = match opt_integer_eol Lexer.lexeme lexbuf with | None -> !current_frame | Some x -> x in ensure_loaded (); try select_frame frame_number; show_current_frame ppf true with | Not_found -> error ("No frame number " ^ string_of_int frame_number ^ ".") let instr_backtrace ppf lexbuf = let number = match opt_signed_integer_eol Lexer.lexeme lexbuf with | None -> 0 | Some x -> x in ensure_loaded (); match current_report() with | None | Some {rep_type = Exited | Uncaught_exc} -> () | Some _ -> let frame_counter = ref 0 in let print_frame first_frame last_frame = function | None -> fprintf ppf "(Encountered a function with no debugging information)@."; false | Some event -> if !frame_counter >= first_frame then show_one_frame !frame_counter ppf event; incr frame_counter; if !frame_counter >= last_frame then begin fprintf ppf "(More frames follow)@." end; !frame_counter < last_frame in fprintf ppf "Backtrace:@."; if number = 0 then do_backtrace (print_frame 0 max_int) else if number > 0 then do_backtrace (print_frame 0 number) else begin let num_frames = stack_depth() in if num_frames < 0 then fprintf ppf "(Encountered a function with no debugging information)@." else do_backtrace (print_frame (num_frames + number) max_int) end let instr_up ppf lexbuf = let offset = match opt_signed_integer_eol Lexer.lexeme lexbuf with | None -> 1 | Some x -> x in ensure_loaded (); try select_frame (!current_frame + offset); show_current_frame ppf true with | Not_found -> error "No such frame." let instr_down ppf lexbuf = let offset = match opt_signed_integer_eol Lexer.lexeme lexbuf with | None -> 1 | Some x -> x in ensure_loaded (); try select_frame (!current_frame - offset); show_current_frame ppf true with | Not_found -> error "No such frame." let instr_last ppf lexbuf = let count = match opt_signed_int64_eol Lexer.lexeme lexbuf with | None -> _1 | Some x -> x in check_not_windows "last"; reset_named_values(); go_to (History.previous_time count); show_current_event ppf let instr_list ppf lexbuf = let (mo, beg, e) = list_arguments_eol Lexer.lexeme lexbuf in let (curr_mod, line, column) = try selected_point () with | Not_found -> ("", -1, -1) in let mdle = convert_module (module_of_longident mo) in let pos = Lexing.dummy_pos in let buffer = try get_buffer pos mdle with | Not_found -> error ("No source file for " ^ mdle ^ ".") in let point = if column <> -1 then (point_of_coord buffer line 1) + column else -1 in let beginning = match beg with | None when (mo <> None) || (line = -1) -> 1 | None -> begin try max 1 (line - 10) with Out_of_range -> 1 end | Some x -> x in let en = match e with | None -> beginning + 20 | Some x -> x in if mdle = curr_mod then show_listing pos mdle beginning en point (current_event_is_before ()) else show_listing pos mdle beginning en (-1) true (** Variables. **) let raw_variable kill name = (function lexbuf -> let argument = argument_eol argument lexbuf in if (not kill) || ask_kill_program () then name := argument), function ppf -> fprintf ppf "%s@." !name let raw_line_variable kill name = (function lexbuf -> let argument = argument_eol line_argument lexbuf in if (not kill) || ask_kill_program () then name := argument), function ppf -> fprintf ppf "%s@." !name let integer_variable kill min msg name = (function lexbuf -> let argument = integer_eol Lexer.lexeme lexbuf in if argument < min then print_endline msg else if (not kill) || ask_kill_program () then name := argument), function ppf -> fprintf ppf "%i@." !name let int64_variable kill min msg name = (function lexbuf -> let argument = int64_eol Lexer.lexeme lexbuf in if argument < min then print_endline msg else if (not kill) || ask_kill_program () then name := argument), function ppf -> fprintf ppf "%Li@." !name let boolean_variable kill name = (function lexbuf -> let argument = match identifier_eol Lexer.lexeme lexbuf with | "on" -> true | "of" | "off" -> false | _ -> error "Syntax error." in if (not kill) || ask_kill_program () then name := argument), function ppf -> fprintf ppf "%s@." (if !name then "on" else "off") let path_variable kill name = (function lexbuf -> let argument = argument_eol argument lexbuf in if (not kill) || ask_kill_program () then name := make_absolute (expand_path argument)), function ppf -> fprintf ppf "%s@." !name let loading_mode_variable ppf = (find_ident "loading mode" (matching_elements (ref loading_modes) fst) (fun (_, mode) ppf lexbuf -> eol lexbuf; set_launching_function mode) (function ppf -> error "Syntax error.") ppf), function ppf -> let rec find = function | [] -> () | (name, funct) :: l -> if funct == !launching_func then fprintf ppf "%s" name else find l in find loading_modes; fprintf ppf "@." let follow_fork_variable = (function lexbuf -> let mode = match identifier_eol Lexer.lexeme lexbuf with | "child" -> Fork_child | "parent" -> Fork_parent | _ -> error "Syntax error." in fork_mode := mode; if !loaded then update_follow_fork_mode ()), function ppf -> fprintf ppf "%s@." (match !fork_mode with Fork_child -> "child" | Fork_parent -> "parent") (** Infos. **) let pr_modules ppf mods = let pr_mods ppf = List.iter (function x -> fprintf ppf "%s@ " x) in fprintf ppf "Used modules :@.%a@?" pr_mods mods let info_modules ppf lexbuf = eol lexbuf; ensure_loaded (); pr_modules ppf !modules (******** print_endline "Opened modules :"; if !opened_modules_names = [] then print_endline "(no module opened)." else (List.iter (function x -> print_string x; print_space) !opened_modules_names; print_newline ()) *********) let info_checkpoints ppf lexbuf = eol lexbuf; if !checkpoints = [] then fprintf ppf "No checkpoint.@." else (if !debug_breakpoints then (prerr_endline " Time Pid Version"; List.iter (function {c_time = time; c_pid = pid; c_breakpoint_version = version} -> Printf.printf "%19Ld %5d %d\n" time pid version) !checkpoints) else (print_endline " Time Pid"; List.iter (function {c_time = time; c_pid = pid} -> Printf.printf "%19Ld %5d\n" time pid) !checkpoints)) let info_one_breakpoint ppf (num, ev) = fprintf ppf "%3d %10d %s@." num ev.ev_pos (Pos.get_desc ev); ;; let info_breakpoints ppf lexbuf = eol lexbuf; if !breakpoints = [] then fprintf ppf "No breakpoints.@." else begin fprintf ppf "Num Address Where@."; List.iter (info_one_breakpoint ppf) (List.rev !breakpoints); end ;; let info_events ppf lexbuf = ensure_loaded (); let mdle = convert_module (module_of_longident (opt_longident_eol Lexer.lexeme lexbuf)) in print_endline ("Module : " ^ mdle); print_endline " Address Characters Kind Repr."; List.iter (function ev -> let start_char, end_char = try let buffer = get_buffer (Events.get_pos ev) ev.ev_module in (snd (start_and_cnum buffer ev.ev_loc.Location.loc_start)), (snd (start_and_cnum buffer ev.ev_loc.Location.loc_end)) with _ -> ev.ev_loc.Location.loc_start.Lexing.pos_cnum, ev.ev_loc.Location.loc_end.Lexing.pos_cnum in Printf.printf "%10d %6d-%-6d %10s %10s\n" ev.ev_pos start_char end_char ((match ev.ev_kind with Event_before -> "before" | Event_after _ -> "after" | Event_pseudo -> "pseudo") ^ (match ev.ev_info with Event_function -> "/fun" | Event_return _ -> "/ret" | Event_other -> "")) (match ev.ev_repr with Event_none -> "" | Event_parent _ -> "(repr)" | Event_child repr -> string_of_int !repr)) (events_in_module mdle) (** User-defined printers **) let instr_load_printer ppf lexbuf = let filename = extract_filename(argument_eol argument lexbuf) in try Loadprinter.loadfile ppf filename with Loadprinter.Error e -> Loadprinter.report_error ppf e; raise Toplevel let instr_install_printer ppf lexbuf = let lid = longident_eol Lexer.lexeme lexbuf in try Loadprinter.install_printer ppf lid with Loadprinter.Error e -> Loadprinter.report_error ppf e; raise Toplevel let instr_remove_printer ppf lexbuf = let lid = longident_eol Lexer.lexeme lexbuf in try Loadprinter.remove_printer lid with Loadprinter.Error e -> Loadprinter.report_error ppf e; raise Toplevel (** Initialization. **) let init ppf = instruction_list := [ { instr_name = "cd"; instr_prio = false; instr_action = instr_cd; instr_repeat = true; instr_help = "set working directory to DIR for debugger and program being debugged." }; { instr_name = "complete"; instr_prio = false; instr_action = instr_complete; instr_repeat = false; instr_help = "complete word at cursor according to context. Useful for Emacs." }; { instr_name = "pwd"; instr_prio = false; instr_action = instr_pwd; instr_repeat = true; instr_help = "print working directory." }; { instr_name = "directory"; instr_prio = false; instr_action = instr_dir; instr_repeat = false; instr_help = "add directory DIR to beginning of search path for source and\n\ interface files.\n\ Forget cached info on source file locations and line positions.\n\ With no argument, reset the search path." }; { instr_name = "kill"; instr_prio = false; instr_action = instr_kill; instr_repeat = true; instr_help = "kill the program being debugged." }; { instr_name = "help"; instr_prio = false; instr_action = instr_help; instr_repeat = true; instr_help = "print list of commands." }; { instr_name = "quit"; instr_prio = false; instr_action = instr_quit; instr_repeat = false; instr_help = "exit the debugger." }; { instr_name = "shell"; instr_prio = false; instr_action = instr_shell; instr_repeat = true; instr_help = "Execute a given COMMAND thru the system shell." }; { instr_name = "environment"; instr_prio = false; instr_action = instr_env; instr_repeat = false; instr_help = "environment variable to give to program being debugged when it is started." }; (* Displacements *) { instr_name = "run"; instr_prio = true; instr_action = instr_run; instr_repeat = true; instr_help = "run the program from current position." }; { instr_name = "reverse"; instr_prio = false; instr_action = instr_reverse; instr_repeat = true; instr_help = "run the program backward from current position." }; { instr_name = "step"; instr_prio = true; instr_action = instr_step; instr_repeat = true; instr_help = "step program until it reaches the next event.\n\ Argument N means do this N times (or till program stops for another reason)." }; { instr_name = "backstep"; instr_prio = true; instr_action = instr_back; instr_repeat = true; instr_help = "step program backward until it reaches the previous event.\n\ Argument N means do this N times (or till program stops for another reason)." }; { instr_name = "goto"; instr_prio = false; instr_action = instr_goto; instr_repeat = true; instr_help = "go to the given time." }; { instr_name = "finish"; instr_prio = true; instr_action = instr_finish; instr_repeat = true; instr_help = "execute until topmost stack frame returns." }; { instr_name = "next"; instr_prio = true; instr_action = instr_next; instr_repeat = true; instr_help = "step program until it reaches the next event.\n\ Skip over function calls.\n\ Argument N means do this N times (or till program stops for another reason)." }; { instr_name = "start"; instr_prio = false; instr_action = instr_start; instr_repeat = true; instr_help = "execute backward until the current function is exited." }; { instr_name = "previous"; instr_prio = false; instr_action = instr_previous; instr_repeat = true; instr_help = "step program until it reaches the previous event.\n\ Skip over function calls.\n\ Argument N means do this N times (or till program stops for another reason)." }; { instr_name = "print"; instr_prio = true; instr_action = instr_print; instr_repeat = true; instr_help = "print value of expressions (deep printing)." }; { instr_name = "display"; instr_prio = true; instr_action = instr_display; instr_repeat = true; instr_help = "print value of expressions (shallow printing)." }; { instr_name = "source"; instr_prio = false; instr_action = instr_source; instr_repeat = true; instr_help = "read command from file FILE." }; (* Breakpoints *) { instr_name = "break"; instr_prio = false; instr_action = instr_break; instr_repeat = false; instr_help = "Set breakpoint at specified line or function.\ \nSyntax: break function-name\ \n break @ [module] linenum\ \n break @ [module] # characternum" }; { instr_name = "delete"; instr_prio = false; instr_action = instr_delete; instr_repeat = false; instr_help = "delete some breakpoints.\n\ Arguments are breakpoint numbers with spaces in between.\n\ To delete all breakpoints, give no argument." }; { instr_name = "set"; instr_prio = false; instr_action = instr_set; instr_repeat = false; instr_help = "--unused--" }; { instr_name = "show"; instr_prio = false; instr_action = instr_show; instr_repeat = true; instr_help = "--unused--" }; { instr_name = "info"; instr_prio = false; instr_action = instr_info; instr_repeat = true; instr_help = "--unused--" }; (* Frames *) { instr_name = "frame"; instr_prio = false; instr_action = instr_frame; instr_repeat = true; instr_help = "select and print a stack frame.\n\ With no argument, print the selected stack frame.\n\ An argument specifies the frame to select." }; { instr_name = "backtrace"; instr_prio = false; instr_action = instr_backtrace; instr_repeat = true; instr_help = "print backtrace of all stack frames, or innermost COUNT frames.\n\ With a negative argument, print outermost -COUNT frames." }; { instr_name = "bt"; instr_prio = false; instr_action = instr_backtrace; instr_repeat = true; instr_help = "print backtrace of all stack frames, or innermost COUNT frames.\n\ With a negative argument, print outermost -COUNT frames." }; { instr_name = "up"; instr_prio = false; instr_action = instr_up; instr_repeat = true; instr_help = "select and print stack frame that called this one.\n\ An argument says how many frames up to go." }; { instr_name = "down"; instr_prio = false; instr_action = instr_down; instr_repeat = true; instr_help = "select and print stack frame called by this one.\n\ An argument says how many frames down to go." }; { instr_name = "last"; instr_prio = true; instr_action = instr_last; instr_repeat = true; instr_help = "go back to previous time." }; { instr_name = "list"; instr_prio = false; instr_action = instr_list; instr_repeat = true; instr_help = "list the source code." }; (* User-defined printers *) { instr_name = "load_printer"; instr_prio = false; instr_action = instr_load_printer; instr_repeat = false; instr_help = "load in the debugger a .cmo or .cma file containing printing functions." }; { instr_name = "install_printer"; instr_prio = false; instr_action = instr_install_printer; instr_repeat = false; instr_help = "use the given function for printing values of its input type.\n\ The code for the function must have previously been loaded in the debugger\n\ using \"load_printer\"." }; { instr_name = "remove_printer"; instr_prio = false; instr_action = instr_remove_printer; instr_repeat = false; instr_help = "stop using the given function for printing values of its input type." } ]; variable_list := [ (* variable name, (writing, reading), help reading, help writing *) { var_name = "arguments"; var_action = raw_line_variable true arguments; var_help = "arguments to give program being debugged when it is started." }; { var_name = "program"; var_action = path_variable true program_name; var_help = "name of program to be debugged." }; { var_name = "loadingmode"; var_action = loading_mode_variable ppf; var_help = "mode of loading.\n\ It can be either :\n\ direct : the program is directly called by the debugger.\n\ runtime : the debugger execute `ocamlrun programname arguments'.\n\ manual : the program is not launched by the debugger,\n\ but manually by the user." }; { var_name = "processcount"; var_action = integer_variable false 1 "Must be >= 1." checkpoint_max_count; var_help = "maximum number of process to keep." }; { var_name = "checkpoints"; var_action = boolean_variable false make_checkpoints; var_help = "whether to make checkpoints or not." }; { var_name = "bigstep"; var_action = int64_variable false _1 "Must be >= 1." checkpoint_big_step; var_help = "step between checkpoints during long displacements." }; { var_name = "smallstep"; var_action = int64_variable false _1 "Must be >= 1." checkpoint_small_step; var_help = "step between checkpoints during small displacements." }; { var_name = "socket"; var_action = raw_variable true socket_name; var_help = "name of the socket used by communications debugger-runtime." }; { var_name = "history"; var_action = integer_variable false 0 "" history_size; var_help = "history size." }; { var_name = "print_depth"; var_action = integer_variable false 1 "Must be at least 1" max_printer_depth; var_help = "maximal depth for printing of values." }; { var_name = "print_length"; var_action = integer_variable false 1 "Must be at least 1" max_printer_steps; var_help = "maximal number of value nodes printed." }; { var_name = "follow_fork_mode"; var_action = follow_fork_variable; var_help = "process to follow after forking.\n\ It can be either : child : the newly created process.\n\ parent : the process that called fork.\n" }]; info_list := (* info name, function, help *) [{ info_name = "modules"; info_action = info_modules ppf; info_help = "list opened modules." }; { info_name = "checkpoints"; info_action = info_checkpoints ppf; info_help = "list checkpoints." }; { info_name = "breakpoints"; info_action = info_breakpoints ppf; info_help = "list breakpoints." }; { info_name = "events"; info_action = info_events ppf; info_help = "list events in MODULE (default is current module)." }] let _ = init std_formatter mingw-ocaml/ocaml/debugger/envaux.ml0000644000175000017500000000577512124403240017117 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Misc open Types open Env type error = Module_not_found of Path.t exception Error of error let env_cache = (Hashtbl.create 59 : ((Env.summary * Subst.t), Env.t) Hashtbl.t) let reset_cache () = Hashtbl.clear env_cache; Env.reset_cache() let extract_sig env mty = match Mtype.scrape env mty with Mty_signature sg -> sg | _ -> fatal_error "Envaux.extract_sig" let rec env_from_summary sum subst = try Hashtbl.find env_cache (sum, subst) with Not_found -> let env = match sum with Env_empty -> Env.empty | Env_value(s, id, desc) -> Env.add_value id (Subst.value_description subst desc) (env_from_summary s subst) | Env_type(s, id, desc) -> Env.add_type id (Subst.type_declaration subst desc) (env_from_summary s subst) | Env_exception(s, id, desc) -> Env.add_exception id (Subst.exception_declaration subst desc) (env_from_summary s subst) | Env_module(s, id, desc) -> Env.add_module id (Subst.modtype subst desc) (env_from_summary s subst) | Env_modtype(s, id, desc) -> Env.add_modtype id (Subst.modtype_declaration subst desc) (env_from_summary s subst) | Env_class(s, id, desc) -> Env.add_class id (Subst.class_declaration subst desc) (env_from_summary s subst) | Env_cltype (s, id, desc) -> Env.add_cltype id (Subst.cltype_declaration subst desc) (env_from_summary s subst) | Env_open(s, path) -> let env = env_from_summary s subst in let path' = Subst.module_path subst path in let mty = try Env.find_module path' env with Not_found -> raise (Error (Module_not_found path')) in Env.open_signature path' (extract_sig env mty) env in Hashtbl.add env_cache (sum, subst) env; env let env_of_event = function None -> Env.empty | Some ev -> env_from_summary ev.Instruct.ev_typenv ev.Instruct.ev_typsubst (* Error report *) open Format let report_error ppf = function | Module_not_found p -> fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p mingw-ocaml/ocaml/debugger/program_loading.ml0000644000175000017500000001253312124403240020743 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Program loading *) open Unix open Debugger_config open Parameters open Input_handling (*** Debugging. ***) let debug_loading = ref false (*** Load a program. ***) (* Function used for launching the program. *) let launching_func = ref (function () -> ()) let load_program () = !launching_func (); main_loop () (*** Launching functions. ***) (* Returns the environment to be passed to debugee *) let get_environment () = let env = Unix.environment () in let have_same_name x y = let split = Primitives.split_string '=' in match split x, split y with (hd1 :: _), (hd2 :: _) -> hd1 = hd2 | _ -> false in let have_name_in_config_env x = List.exists (have_same_name x) !Debugger_config.environment in let env = Array.fold_right (fun elem acc -> if have_name_in_config_env elem then acc else elem :: acc) env [] in Array.of_list (env @ !Debugger_config.environment) (* Returns the environment to be passed to debugee *) let get_win32_environment () = let res = Buffer.create 256 in let env = get_environment () in let len = Array.length env in for i = 0 to pred len do Buffer.add_string res (Printf.sprintf "set %s && " env.(i)) done; Buffer.contents res (* A generic function for launching the program *) let generic_exec_unix cmdline = function () -> if !debug_loading then prerr_endline "Launching program..."; let child = try fork () with x -> Unix_tools.report_error x; raise Toplevel in match child with 0 -> begin try match fork () with 0 -> (* Try to detach the process from the controlling terminal, so that it does not receive SIGINT on ctrl-C. *) begin try ignore(setsid()) with Invalid_argument _ -> () end; execve shell [| shell; "-c"; cmdline() |] (get_environment ()) | _ -> exit 0 with x -> Unix_tools.report_error x; exit 1 end | _ -> match wait () with (_, WEXITED 0) -> () | _ -> raise Toplevel let generic_exec_win cmdline = function () -> if !debug_loading then prerr_endline "Launching program..."; try ignore(create_process "cmd.exe" [| "/C"; cmdline() |] stdin stdout stderr) with x -> Unix_tools.report_error x; raise Toplevel let generic_exec = match Sys.os_type with "Win32" -> generic_exec_win | _ -> generic_exec_unix (* Execute the program by calling the runtime explicitly *) let exec_with_runtime = generic_exec (function () -> match Sys.os_type with "Win32" -> (* This fould fail on a file name with spaces but quoting is even worse because Unix.create_process thinks each command line parameter is a file. So no good solution so far *) Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s && %s %s %s" (get_win32_environment ()) !socket_name runtime_program !program_name !arguments | _ -> Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s %s" !socket_name (Filename.quote runtime_program) (Filename.quote !program_name) !arguments) (* Excute the program directly *) let exec_direct = generic_exec (function () -> match Sys.os_type with "Win32" -> (* See the comment above *) Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s && %s %s" (get_win32_environment ()) !socket_name !program_name !arguments | _ -> Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s" !socket_name (Filename.quote !program_name) !arguments) (* Ask the user. *) let exec_manual = function () -> print_newline (); print_string "Waiting for connection..."; print_string ("(the socket is " ^ !socket_name ^ ")"); print_newline () (*** Selection of the launching function. ***) type launching_function = (unit -> unit) let loading_modes = ["direct", exec_direct; "runtime", exec_with_runtime; "manual", exec_manual] let set_launching_function func = launching_func := func (* Initialization *) let _ = set_launching_function exec_direct (*** Connection. ***) let connection = ref Primitives.std_io let connection_opened = ref false mingw-ocaml/ocaml/debugger/Makefile.shared0000644000175000017500000000666412124403240020162 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # $Id$ include ../config/Makefile CAMLC=../ocamlcomp.sh COMPFLAGS=-warn-error A $(INCLUDES) LINKFLAGS=-linkall -I $(UNIXDIR) CAMLYACC=../boot/ocamlyacc YACCFLAGS= CAMLLEX=../boot/ocamlrun ../boot/ocamllex CAMLDEP=../boot/ocamlrun ../tools/ocamldep DEPFLAGS=$(INCLUDES) INCLUDES=\ -I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../toplevel \ -I $(UNIXDIR) OTHEROBJS=\ $(UNIXDIR)/unix.cma \ ../utils/misc.cmo ../utils/config.cmo ../utils/tbl.cmo \ ../utils/clflags.cmo ../utils/consistbl.cmo ../utils/warnings.cmo \ ../parsing/location.cmo ../parsing/longident.cmo \ ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \ ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \ ../typing/subst.cmo ../typing/predef.cmo \ ../typing/datarepr.cmo ../typing/cmi_format.cmo ../typing/env.cmo ../typing/oprint.cmo \ ../typing/ctype.cmo ../typing/printtyp.cmo ../typing/mtype.cmo \ ../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \ ../bytecomp/dll.cmo ../bytecomp/meta.cmo ../bytecomp/symtable.cmo \ ../bytecomp/opcodes.cmo \ ../toplevel/genprintval.cmo OBJS=\ dynlink.cmo \ int64ops.cmo \ primitives.cmo \ unix_tools.cmo \ debugger_config.cmo \ envaux.cmo \ parameters.cmo \ lexer.cmo \ input_handling.cmo \ question.cmo \ debugcom.cmo \ exec.cmo \ source.cmo \ pos.cmo \ checkpoints.cmo \ events.cmo \ program_loading.cmo \ symbols.cmo \ breakpoints.cmo \ trap_barrier.cmo \ history.cmo \ printval.cmo \ show_source.cmo \ time_travel.cmo \ program_management.cmo \ frames.cmo \ eval.cmo \ show_information.cmo \ loadprinter.cmo \ parser.cmo \ command_line.cmo \ main.cmo all: ocamldebug$(EXE) ocamldebug$(EXE): $(OBJS) $(OTHEROBJS) $(CAMLC) $(LINKFLAGS) -o ocamldebug$(EXE) -linkall $(OTHEROBJS) $(OBJS) install: cp ocamldebug$(EXE) $(BINDIR)/ocamldebug$(EXE) clean:: rm -f ocamldebug$(EXE) rm -f *.cmo *.cmi .SUFFIXES: .SUFFIXES: .ml .cmo .mli .cmi .ml.cmo: $(CAMLC) -c $(COMPFLAGS) $< .mli.cmi: $(CAMLC) -c $(COMPFLAGS) $< depend: beforedepend $(CAMLDEP) $(DEPFLAGS) *.mli *.ml \ | sed -e 's,$(UNIXDIR)/,$$(UNIXDIR)/,' > .depend lexer.ml: lexer.mll $(CAMLLEX) lexer.mll clean:: rm -f lexer.ml beforedepend:: lexer.ml parser.ml parser.mli: parser.mly $(CAMLYACC) parser.mly clean:: rm -f parser.ml parser.mli beforedepend:: parser.ml parser.mli dynlink.ml: ../otherlibs/dynlink/dynlink.ml grep -v 'REMOVE_ME for ../../debugger/dynlink.ml' \ ../otherlibs/dynlink/dynlink.ml >dynlink.ml dynlink.mli: ../otherlibs/dynlink/dynlink.mli cp ../otherlibs/dynlink/dynlink.mli . clean:: rm -f dynlink.ml dynlink.mli beforedepend:: dynlink.ml dynlink.mli include .depend mingw-ocaml/ocaml/debugger/show_source.mli0000644000175000017500000000226112124403240020305 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Print the line containing the point *) val show_point : Instruct.debug_event -> bool -> unit;; (* Tell Emacs we are nowhere in the source. *) val show_no_point : unit -> unit;; (* Display part of the source. *) val show_listing : Lexing.position -> string -> int -> int -> int -> bool -> unit;; mingw-ocaml/ocaml/debugger/loadprinter.ml0000644000175000017500000001333312124403240020121 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Loading and installation of user-defined printer functions *) open Misc open Longident open Path open Types (* Error report *) type error = | Load_failure of Dynlink.error | Unbound_identifier of Longident.t | Unavailable_module of string * Longident.t | Wrong_type of Longident.t | No_active_printer of Longident.t exception Error of error (* Symtable has global state, and normally holds the symbol table for the debuggee. We need to switch it temporarily to the symbol table for the debugger. *) let debugger_symtable = ref (None: Symtable.global_map option) let use_debugger_symtable fn arg = let old_symtable = Symtable.current_state() in begin match !debugger_symtable with | None -> Dynlink.init(); Dynlink.allow_unsafe_modules true; debugger_symtable := Some(Symtable.current_state()) | Some st -> Symtable.restore_state st end; try let result = fn arg in debugger_symtable := Some(Symtable.current_state()); Symtable.restore_state old_symtable; result with exn -> Symtable.restore_state old_symtable; raise exn (* Load a .cmo or .cma file *) open Format let rec loadfiles ppf name = try let filename = find_in_path !Config.load_path name in use_debugger_symtable Dynlink.loadfile filename; let d = Filename.dirname name in if d <> Filename.current_dir_name then begin if not (List.mem d !Config.load_path) then Config.load_path := d :: !Config.load_path; end; fprintf ppf "File %s loaded@." filename; true with | Dynlink.Error (Dynlink.Unavailable_unit unit) -> loadfiles ppf (String.uncapitalize unit ^ ".cmo") && loadfiles ppf name | Not_found -> fprintf ppf "Cannot find file %s@." name; false | Dynlink.Error e -> raise(Error(Load_failure e)) let loadfile ppf name = ignore(loadfiles ppf name) (* Return the value referred to by a path (as in toplevel/topdirs) *) (* Note: evaluation proceeds in the debugger memory space, not in the debuggee. *) let rec eval_path = function Pident id -> Symtable.get_global_value id | Pdot(p, s, pos) -> Obj.field (eval_path p) pos | Papply(p1, p2) -> fatal_error "Loadprinter.eval_path" (* Install, remove a printer (as in toplevel/topdirs) *) (* since 4.00, "topdirs.cmi" is not in the same directory as the standard libray, so we load it beforehand as it cannot be found in the search path. *) let () = let compiler_libs = Filename.concat Config.standard_library "compiler-libs" in let topdirs = Filename.concat compiler_libs "topdirs.cmi" in ignore (Env.read_signature "Topdirs" topdirs) let match_printer_type desc typename = let (printer_type, _) = try Env.lookup_type (Ldot(Lident "Topdirs", typename)) Env.empty with Not_found -> raise (Error(Unbound_identifier(Ldot(Lident "Topdirs", typename)))) in Ctype.init_def(Ident.current_time()); Ctype.begin_def(); let ty_arg = Ctype.newvar() in Ctype.unify Env.empty (Ctype.newconstr printer_type [ty_arg]) (Ctype.instance Env.empty desc.val_type); Ctype.end_def(); Ctype.generalize ty_arg; ty_arg let find_printer_type lid = try let (path, desc) = Env.lookup_value lid Env.empty in let (ty_arg, is_old_style) = try (match_printer_type desc "printer_type_new", false) with Ctype.Unify _ -> (match_printer_type desc "printer_type_old", true) in (ty_arg, path, is_old_style) with | Not_found -> raise(Error(Unbound_identifier lid)) | Ctype.Unify _ -> raise(Error(Wrong_type lid)) let install_printer ppf lid = let (ty_arg, path, is_old_style) = find_printer_type lid in let v = try use_debugger_symtable eval_path path with Symtable.Error(Symtable.Undefined_global s) -> raise(Error(Unavailable_module(s, lid))) in let print_function = if is_old_style then (fun formatter repr -> Obj.obj v (Obj.obj repr)) else (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in Printval.install_printer path ty_arg ppf print_function let remove_printer lid = let (ty_arg, path, is_old_style) = find_printer_type lid in try Printval.remove_printer path with Not_found -> raise(Error(No_active_printer lid)) (* Error report *) open Format let report_error ppf = function | Load_failure e -> fprintf ppf "@[Error during code loading: %s@]@." (Dynlink.error_message e) | Unbound_identifier lid -> fprintf ppf "@[Unbound identifier %a@]@." Printtyp.longident lid | Unavailable_module(md, lid) -> fprintf ppf "@[The debugger does not contain the code for@ %a.@ \ Please load an implementation of %s first.@]@." Printtyp.longident lid md | Wrong_type lid -> fprintf ppf "@[%a has the wrong type for a printing function.@]@." Printtyp.longident lid | No_active_printer lid -> fprintf ppf "@[%a is not currently active as a printing function.@]@." Printtyp.longident lid mingw-ocaml/ocaml/debugger/pattern_matching.mli0000644000175000017500000000216312124403240021275 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (************************ Simple pattern matching **********************) open Parser_aux val pattern_matching : pattern -> Debugcom.remote_value -> Typedtree.type_expr -> (string * Debugcom.remote_value * Typedtree.type_expr) list;; mingw-ocaml/ocaml/debugger/debugger_config.ml0000644000175000017500000000522412124403240020707 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (**************************** Configuration file ***********************) open Int64ops exception Toplevel (*** Miscellaneous parameters. ***) (*ISO 6429 color sequences 00 to restore default color 01 for brighter colors 04 for underlined text 05 for flashing text 30 for black foreground 31 for red foreground 32 for green foreground 33 for yellow (or brown) foreground 34 for blue foreground 35 for purple foreground 36 for cyan foreground 37 for white (or gray) foreground 40 for black background 41 for red background 42 for green background 43 for yellow (or brown) background 44 for blue background 45 for purple background 46 for cyan background 47 for white (or gray) background let debugger_prompt = "\027[1;04m(ocd)\027[0m " and event_mark_before = "\027[1;31m$\027[0m" and event_mark_after = "\027[1;34m$\027[0m" *) let debugger_prompt = "(ocd) " let event_mark_before = "<|b|>" let event_mark_after = "<|a|>" (* Name of shell used to launch the debuggee *) let shell = match Sys.os_type with "Win32" -> "cmd" | _ -> "/bin/sh" (* Name of the OCaml runtime. *) let runtime_program = "ocamlrun" (* Time history size (for `last') *) let history_size = ref 30 let load_path_for = Hashtbl.create 7 (*** Time travel parameters. ***) (* Step between checkpoints for long displacements.*) let checkpoint_big_step = ref (~~ "10000") (* Idem for small ones. *) let checkpoint_small_step = ref (~~ "1000") (* Maximum number of checkpoints. *) let checkpoint_max_count = ref 15 (* Whether to keep checkpoints or not. *) let make_checkpoints = ref (match Sys.os_type with "Win32" -> false | _ -> true) (*** Environment variables for debugee. ***) let environment = ref [] mingw-ocaml/ocaml/debugger/int64ops.ml0000644000175000017500000000223312124403240017261 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocqencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (****************** arithmetic operators for Int64 *********************) let ( ++ ) = Int64.add;; let ( -- ) = Int64.sub;; let suc64 = Int64.succ;; let pre64 = Int64.pred;; let _0 = Int64.zero;; let _1 = Int64.one;; let _minus1 = Int64.minus_one;; let ( ~~ ) = Int64.of_string;; let max_small_int = Int64.of_int max_int;; let to_int = Int64.to_int;; mingw-ocaml/ocaml/debugger/exec.ml0000644000175000017500000000331112124403240016515 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Handling of keyboard interrupts *) let interrupted = ref false let is_protected = ref false let break signum = if !is_protected then interrupted := true else raise Sys.Break let _ = match Sys.os_type with "Win32" -> () | _ -> Sys.set_signal Sys.sigint (Sys.Signal_handle break); Sys.set_signal Sys.sigpipe (Sys.Signal_handle (fun _ -> raise End_of_file)) let protect f = if !is_protected then f () else begin is_protected := true; if not !interrupted then f (); is_protected := false; if !interrupted then begin interrupted := false; raise Sys.Break end end let unprotect f = if not !is_protected then f () else begin is_protected := false; if !interrupted then begin interrupted := false; raise Sys.Break end; f (); is_protected := true end mingw-ocaml/ocaml/debugger/eval.mli0000644000175000017500000000277712124403240016710 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Types open Parser_aux open Format val expression : Instruct.debug_event option -> Env.t -> expression -> Debugcom.Remote_value.t * type_expr type error = | Unbound_identifier of Ident.t | Not_initialized_yet of Path.t | Unbound_long_identifier of Longident.t | Unknown_name of int | Tuple_index of type_expr * int * int | Array_index of int * int | List_index of int * int | String_index of string * int * int | Wrong_item_type of type_expr * int | Wrong_label of type_expr * string | Not_a_record of type_expr | No_result exception Error of error val report_error: formatter -> error -> unit mingw-ocaml/ocaml/debugger/source.mli0000644000175000017500000000442112124403240017245 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (************************ Source management ****************************) (*** Conversion function. ***) val source_of_module: Lexing.position -> string -> string (*** buffer cache ***) type buffer val buffer_max_count : int ref val flush_buffer_list : unit -> unit val get_buffer : Lexing.position -> string -> buffer val buffer_content : buffer -> string val buffer_length : buffer -> int (*** Position conversions. ***) (* Pair (position, line) where `position' is the position in character of *) (* the beginning of the line (first character is 0) and `line' is its *) (* number (first line number is 1). *) type position = int * int (* Position of the next linefeed after `pos'. *) (* Position just after the buffer end if no linefeed found. *) (* Raise `Out_of_range' if already there. *) val next_linefeed : buffer -> int -> int (* Go to next line. *) val next_line : buffer -> position -> position (* Convert a position in the buffer to a line number. *) val line_of_pos : buffer -> int -> position (* Convert a line number to a position. *) val pos_of_line : buffer -> int -> position (* Convert a coordinate (line / column) into a position. *) (* --- The first line and column are line 1 and column 1. *) val point_of_coord : buffer -> int -> int -> int (* Return the offsets of both line start and cnum for the passed position. *) val start_and_cnum : buffer -> Lexing.position -> (int * int) mingw-ocaml/ocaml/debugger/parser.mly0000644000175000017500000001445612124403240017272 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Jerome Vouillon, projet Cristal, INRIA Rocquencourt */ /* OCaml port by John Malecki and Xavier Leroy */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* $Id$ */ %{ open Int64ops open Input_handling open Longident open Parser_aux %} %token ARGUMENT %token LIDENT %token UIDENT %token OPERATOR %token INTEGER %token STAR /* * */ %token MINUS /* - */ %token DOT /* . */ %token SHARP /* # */ %token AT /* @ */ %token DOLLAR /* $ */ %token BANG /* ! */ %token LPAREN /* ( */ %token RPAREN /* ) */ %token LBRACKET /* [ */ %token RBRACKET /* ] */ %token EOL %right DOT %right BANG %start argument_list_eol %type argument_list_eol %start argument_eol %type argument_eol %start integer_list_eol %type integer_list_eol %start integer_eol %type integer_eol %start int64_eol %type int64_eol %start integer %type integer %start opt_integer_eol %type opt_integer_eol %start opt_signed_integer_eol %type opt_signed_integer_eol %start opt_signed_int64_eol %type opt_signed_int64_eol %start identifier %type identifier %start identifier_eol %type identifier_eol %start identifier_or_eol %type identifier_or_eol %start opt_identifier %type opt_identifier %start opt_identifier_eol %type opt_identifier_eol %start expression_list_eol %type expression_list_eol %start break_argument_eol %type break_argument_eol %start list_arguments_eol %type list_arguments_eol %start end_of_line %type end_of_line %start longident_eol %type longident_eol %start opt_longident %type opt_longident %start opt_longident_eol %type opt_longident_eol %% /* Raw arguments */ argument_list_eol : ARGUMENT argument_list_eol { $1::$2 } | end_of_line { [] }; argument_eol : ARGUMENT end_of_line { $1 }; /* Integer */ integer_list_eol : INTEGER integer_list_eol { (to_int $1) :: $2 } | end_of_line { [] }; integer_eol : INTEGER end_of_line { to_int $1 }; int64_eol : INTEGER end_of_line { $1 }; integer : INTEGER { to_int $1 }; opt_integer_eol : INTEGER end_of_line { Some (to_int $1) } | end_of_line { None }; opt_int64_eol : INTEGER end_of_line { Some $1 } | end_of_line { None }; opt_signed_integer_eol : MINUS integer_eol { Some (- $2) } | opt_integer_eol { $1 }; opt_signed_int64_eol : MINUS int64_eol { Some (Int64.neg $2) } | opt_int64_eol { $1 }; /* Identifiers and long identifiers */ longident : LIDENT { Lident $1 } | module_path DOT LIDENT { Ldot($1, $3) } | OPERATOR { Lident $1 } | module_path DOT OPERATOR { Ldot($1, $3) } | module_path DOT LPAREN OPERATOR RPAREN { Ldot($1, $4) } ; module_path : UIDENT { Lident $1 } | module_path DOT UIDENT { Ldot($1, $3) } ; longident_eol : longident end_of_line { $1 }; opt_longident : UIDENT { Some (Lident $1) } | LIDENT { Some (Lident $1) } | module_path DOT UIDENT { Some (Ldot($1, $3)) } | { None }; opt_longident_eol : opt_longident end_of_line { $1 }; identifier : LIDENT { $1 } | UIDENT { $1 }; identifier_eol : identifier end_of_line { $1 }; identifier_or_eol : identifier { Some $1 } | end_of_line { None }; opt_identifier : identifier { Some $1 } | { None }; opt_identifier_eol : opt_identifier end_of_line { $1 }; /* Expressions */ expression: longident { E_ident $1 } | STAR { E_result } | DOLLAR INTEGER { E_name (to_int $2) } | expression DOT INTEGER { E_item($1, (to_int $3)) } | expression DOT LBRACKET INTEGER RBRACKET { E_item($1, (to_int $4)) } | expression DOT LPAREN INTEGER RPAREN { E_item($1, (to_int $4)) } | expression DOT LIDENT { E_field($1, $3) } | BANG expression { E_field($2, "contents") } | LPAREN expression RPAREN { $2 } ; /* Lists of expressions */ expression_list_eol : expression expression_list_eol { $1::$2 } | end_of_line { [] } ; /* Arguments for breakpoint */ break_argument_eol : end_of_line { BA_none } | integer_eol { BA_pc $1 } | expression end_of_line { BA_function $1 } | AT opt_longident INTEGER opt_integer_eol { BA_pos1 ($2, (to_int $3), $4)} | AT opt_longident SHARP integer_eol { BA_pos2 ($2, $4) } ; /* Arguments for list */ list_arguments_eol : opt_longident integer opt_integer_eol { ($1, Some $2, $3) } | opt_longident_eol { ($1, None, None) }; /* End of line */ end_of_line : EOL { stop_user_input () } ; mingw-ocaml/ocaml/debugger/checkpoints.ml0000644000175000017500000000515612124403240020114 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (*************************** Checkpoints *******************************) open Int64ops open Debugcom open Primitives (*** A type for checkpoints. ***) type checkpoint_state = C_stopped | C_running of int64 (* `c_valid' is true if and only if the corresponding * process is connected to the debugger. * `c_parent' is the checkpoint whose process is parent * of the checkpoint one (`root' if no parent). * c_pid = -2 for root pseudo-checkpoint. * c_pid = 0 for ghost checkpoints. * c_pid = -1 for kill checkpoints. *) type checkpoint = { mutable c_time : int64; mutable c_pid : int; mutable c_fd : io_channel; mutable c_valid : bool; mutable c_report : report option; mutable c_state : checkpoint_state; mutable c_parent : checkpoint; mutable c_breakpoint_version : int; mutable c_breakpoints : (int * int ref) list; mutable c_trap_barrier : int } (*** Pseudo-checkpoint `root'. ***) (* --- Parents of all checkpoints which have no parent. *) let rec root = { c_time = _0; c_pid = -2; c_fd = std_io; c_valid = false; c_report = None; c_state = C_stopped; c_parent = root; c_breakpoint_version = 0; c_breakpoints = []; c_trap_barrier = 0 } (*** Current state ***) let checkpoints = ref ([] : checkpoint list) let current_checkpoint = ref root let current_time () = !current_checkpoint.c_time let current_report () = !current_checkpoint.c_report let current_pc () = match current_report () with None | Some {rep_type = Exited | Uncaught_exc} -> None | Some {rep_program_pointer = pc } -> Some pc let current_pc_sp () = match current_report () with None | Some {rep_type = Exited | Uncaught_exc} -> None | Some {rep_program_pointer = pc; rep_stack_pointer = sp } -> Some (pc, sp) mingw-ocaml/ocaml/debugger/checkpoints.mli0000644000175000017500000000416012124403240020257 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (***************************** Checkpoints *****************************) open Primitives open Debugcom (*** A type for checkpoints. ***) type checkpoint_state = C_stopped | C_running of int64 (* `c_valid' is true if and only if the corresponding * process is connected to the debugger. * `c_parent' is the checkpoint whose process is parent * of the checkpoint one (`root' if no parent). * c_pid = 2 for root pseudo-checkpoint. * c_pid = 0 for ghost checkpoints. * c_pid = -1 for kill checkpoints. *) type checkpoint = {mutable c_time : int64; mutable c_pid : int; mutable c_fd : io_channel; mutable c_valid : bool; mutable c_report : report option; mutable c_state : checkpoint_state; mutable c_parent : checkpoint; mutable c_breakpoint_version : int; mutable c_breakpoints : (int * int ref) list; mutable c_trap_barrier : int} (*** Pseudo-checkpoint `root'. ***) (* --- Parents of all checkpoints which have no parent. *) val root : checkpoint (*** Current state ***) val checkpoints : checkpoint list ref val current_checkpoint : checkpoint ref val current_time : unit -> int64 val current_report : unit -> report option val current_pc : unit -> int option val current_pc_sp : unit -> (int * int) option mingw-ocaml/ocaml/debugger/breakpoints.mli0000644000175000017500000000422712124403240020272 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (******************************* Breakpoints ***************************) open Primitives open Instruct (*** Debugging. ***) val debug_breakpoints : bool ref (*** Information about breakpoints. ***) val breakpoints_count : unit -> int (* Breakpoint number -> debug_event_kind. *) val breakpoints : (int * debug_event) list ref (* Is there a breakpoint at `pc' ? *) val breakpoint_at_pc : int -> bool (* List of breakpoints at `pc'. *) val breakpoints_at_pc : int -> int list (*** Set and remove breakpoints ***) (* Ensure the current version in installed in current checkpoint. *) val update_breakpoints : unit -> unit (* Execute given function with no breakpoint in current checkpoint. *) (* --- `goto' run faster so (does not stop on each breakpoint). *) val execute_without_breakpoints : (unit -> unit) -> unit (* Insert a new breakpoint in lists. *) val new_breakpoint : debug_event -> unit (* Remove a breakpoint from lists. *) val remove_breakpoint : int -> unit val remove_all_breakpoints : unit -> unit (*** Temporary breakpoints. ***) (* Temporary breakpoint position. *) val temporary_breakpoint_position : int option ref (* Execute `funct' with a breakpoint added at `pc'. *) (* --- Used by `finish'. *) val exec_with_temporary_breakpoint : int -> (unit -> unit) -> unit mingw-ocaml/ocaml/debugger/source.ml0000644000175000017500000001250712124403240017100 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (************************ Source management ****************************) open Misc open Primitives let source_extensions = [".ml"] (*** Conversion function. ***) let source_of_module pos mdle = let is_submodule m m' = let len' = String.length m' in try (String.sub m 0 len') = m' && (String.get m len') = '.' with Invalid_argument _ -> false in let path = Hashtbl.fold (fun mdl dirs acc -> if is_submodule mdle mdl then dirs else acc) Debugger_config.load_path_for !Config.load_path in let fname = pos.Lexing.pos_fname in if fname = "" then let innermost_module = try let dot_index = String.rindex mdle '.' in String.sub mdle (succ dot_index) (pred ((String.length mdle) - dot_index)) with Not_found -> mdle in let rec loop = function | [] -> raise Not_found | ext :: exts -> try find_in_path_uncap path (innermost_module ^ ext) with Not_found -> loop exts in loop source_extensions else if Filename.is_implicit fname then find_in_path path fname else fname (*** Buffer cache ***) (* Buffer and cache (to associate lines and positions in the buffer). *) type buffer = string * (int * int) list ref let buffer_max_count = ref 10 let cache_size = 30 let buffer_list = ref ([] : (string * buffer) list) let flush_buffer_list () = buffer_list := [] let get_buffer pos mdle = try List.assoc mdle !buffer_list with Not_found -> let inchan = open_in_bin (source_of_module pos mdle) in let content = Misc.input_bytes inchan (in_channel_length inchan) in let buffer = (content, ref []) in buffer_list := (list_truncate !buffer_max_count ((mdle, buffer)::!buffer_list)); buffer let buffer_content = (fst : buffer -> string) let buffer_length x = String.length (buffer_content x) (*** Position conversions. ***) type position = int * int (* Insert a new pair (position, line) in the cache of the given buffer. *) let insert_pos buffer ((position, line) as pair) = let rec new_list = function [] -> [(position, line)] | ((pos, lin) as a::l) as l' -> if lin < line then pair::l' else if lin = line then l' else a::(new_list l) in let buffer_cache = snd buffer in buffer_cache := new_list !buffer_cache (* Position of the next linefeed after `pos'. *) (* Position just after the buffer end if no linefeed found. *) (* Raise `Out_of_range' if already there. *) let next_linefeed (buffer, _) pos = let len = String.length buffer in if pos >= len then raise Out_of_range else let rec search p = if p = len || String.get buffer p = '\n' then p else search (succ p) in search pos (* Go to next line. *) let next_line buffer (pos, line) = (next_linefeed buffer pos + 1, line + 1) (* Convert a position in the buffer to a line number. *) let line_of_pos buffer position = let rec find = function | [] -> if position < 0 then raise Out_of_range else (0, 1) | ((pos, line) as pair)::l -> if pos > position then find l else pair and find_line previous = let (pos, line) as next = next_line buffer previous in if pos <= position then find_line next else previous in let result = find_line (find !(snd buffer)) in insert_pos buffer result; result (* Convert a line number to a position. *) let pos_of_line buffer line = let rec find = function [] -> if line <= 0 then raise Out_of_range else (0, 1) | ((pos, lin) as pair)::l -> if lin > line then find l else pair and find_pos previous = let (_, lin) as next = next_line buffer previous in if lin <= line then find_pos next else previous in let result = find_pos (find !(snd buffer)) in insert_pos buffer result; result (* Convert a coordinate (line / column) into a position. *) (* --- The first line and column are line 1 and column 1. *) let point_of_coord buffer line column = fst (pos_of_line buffer line) + (pred column) let start_and_cnum buffer pos = let line_number = pos.Lexing.pos_lnum in let start = point_of_coord buffer line_number 1 in start, start + (pos.Lexing.pos_cnum - pos.Lexing.pos_bol) mingw-ocaml/ocaml/debugger/parser_aux.mli0000644000175000017500000000305112124403240020114 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (*open Globals*) open Primitives type expression = E_ident of Longident.t (* x or Mod.x *) | E_name of int (* $xxx *) | E_item of expression * int (* x.1 x.[2] x.(3) *) | E_field of expression * string (* x.lbl !x *) | E_result type break_arg = BA_none (* break *) | BA_pc of int (* break PC *) | BA_function of expression (* break FUNCTION *) | BA_pos1 of Longident.t option * int * int option (* break @ [MODULE] LINE [POS] *) | BA_pos2 of Longident.t option * int (* break @ [MODULE] # OFFSET *) mingw-ocaml/ocaml/debugger/debugcom.ml0000644000175000017500000002014212124403240017357 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Low-level communication with the debuggee *) open Int64ops open Primitives (* The current connection with the debuggee *) let conn = ref Primitives.std_io (* Set which process the debugger follows on fork. *) type follow_fork_mode = Fork_child | Fork_parent let fork_mode = ref Fork_parent let update_follow_fork_mode () = let a = match !fork_mode with Fork_child -> 0 | Fork_parent -> 1 in output_char !conn.io_out 'K'; output_binary_int !conn.io_out a (* Set the current connection, and update the fork mode in case it has * changed. *) let set_current_connection io_chan = conn := io_chan; update_follow_fork_mode () (* Modify the program code *) let set_event pos = output_char !conn.io_out 'e'; output_binary_int !conn.io_out pos let set_breakpoint pos = output_char !conn.io_out 'B'; output_binary_int !conn.io_out pos let reset_instr pos = output_char !conn.io_out 'i'; output_binary_int !conn.io_out pos (* Basic commands for flow control *) type execution_summary = Event | Breakpoint | Exited | Trap_barrier | Uncaught_exc type report = { rep_type : execution_summary; rep_event_count : int; rep_stack_pointer : int; rep_program_pointer : int } type checkpoint_report = Checkpoint_done of int | Checkpoint_failed (* Run the debuggee for N events *) let do_go_smallint n = output_char !conn.io_out 'g'; output_binary_int !conn.io_out n; flush !conn.io_out; Input_handling.execute_with_other_controller Input_handling.exit_main_loop !conn (function () -> Input_handling.main_loop (); let summary = match input_char !conn.io_in with 'e' -> Event | 'b' -> Breakpoint | 'x' -> Exited | 's' -> Trap_barrier | 'u' -> Uncaught_exc | _ -> Misc.fatal_error "Debugcom.do_go" in let event_counter = input_binary_int !conn.io_in in let stack_pos = input_binary_int !conn.io_in in let pc = input_binary_int !conn.io_in in { rep_type = summary; rep_event_count = event_counter; rep_stack_pointer = stack_pos; rep_program_pointer = pc }) let rec do_go n = assert (n >= _0); if n > max_small_int then( ignore (do_go_smallint max_int); do_go (n -- max_small_int) )else( do_go_smallint (Int64.to_int n) ) ;; (* Perform a checkpoint *) let do_checkpoint () = match Sys.os_type with "Win32" -> failwith "do_checkpoint" | _ -> output_char !conn.io_out 'c'; flush !conn.io_out; let pid = input_binary_int !conn.io_in in if pid = -1 then Checkpoint_failed else Checkpoint_done pid (* Kill the given process. *) let stop chan = try output_char chan.io_out 's'; flush chan.io_out with Sys_error _ | End_of_file -> () (* Ask a process to wait for its child which has been killed. *) (* (so as to eliminate zombies). *) let wait_child chan = try output_char chan.io_out 'w' with Sys_error _ | End_of_file -> () (* Move to initial frame (that of current function). *) (* Return stack position and current pc *) let initial_frame () = output_char !conn.io_out '0'; flush !conn.io_out; let stack_pos = input_binary_int !conn.io_in in let pc = input_binary_int !conn.io_in in (stack_pos, pc) let set_initial_frame () = ignore(initial_frame ()) (* Move up one frame *) (* Return stack position and current pc. If there's no frame above, return (-1, 0). *) let up_frame stacksize = output_char !conn.io_out 'U'; output_binary_int !conn.io_out stacksize; flush !conn.io_out; let stack_pos = input_binary_int !conn.io_in in let pc = if stack_pos = -1 then 0 else input_binary_int !conn.io_in in (stack_pos, pc) (* Get and set the current frame position *) let get_frame () = output_char !conn.io_out 'f'; flush !conn.io_out; let stack_pos = input_binary_int !conn.io_in in let pc = input_binary_int !conn.io_in in (stack_pos, pc) let set_frame stack_pos = output_char !conn.io_out 'S'; output_binary_int !conn.io_out stack_pos (* Set the trap barrier to given stack position. *) let set_trap_barrier pos = output_char !conn.io_out 'b'; output_binary_int !conn.io_out pos (* Handling of remote values *) let value_size = if 1 lsl 31 = 0 then 4 else 8 let input_remote_value ic = Misc.input_bytes ic value_size let output_remote_value ic v = output ic v 0 value_size exception Marshalling_error module Remote_value = struct type t = Remote of string | Local of Obj.t let obj = function | Local obj -> Obj.obj obj | Remote v -> output_char !conn.io_out 'M'; output_remote_value !conn.io_out v; flush !conn.io_out; try input_value !conn.io_in with End_of_file | Failure _ -> raise Marshalling_error let is_block = function | Local obj -> Obj.is_block obj | Remote v -> Obj.is_block (Array.unsafe_get (Obj.magic v : Obj.t array) 0) let tag = function | Local obj -> Obj.tag obj | Remote v -> output_char !conn.io_out 'H'; output_remote_value !conn.io_out v; flush !conn.io_out; let header = input_binary_int !conn.io_in in header land 0xFF let size = function | Local obj -> Obj.size obj | Remote v -> output_char !conn.io_out 'H'; output_remote_value !conn.io_out v; flush !conn.io_out; let header = input_binary_int !conn.io_in in if header land 0xFF = Obj.double_array_tag && Sys.word_size = 32 then header lsr 11 else header lsr 10 let field v n = match v with | Local obj -> Local(Obj.field obj n) | Remote v -> output_char !conn.io_out 'F'; output_remote_value !conn.io_out v; output_binary_int !conn.io_out n; flush !conn.io_out; if input_byte !conn.io_in = 0 then Remote(input_remote_value !conn.io_in) else begin let buf = Misc.input_bytes !conn.io_in 8 in let floatbuf = float n (* force allocation of a new float *) in String.unsafe_blit buf 0 (Obj.magic floatbuf) 0 8; Local(Obj.repr floatbuf) end let of_int n = Local(Obj.repr n) let local pos = output_char !conn.io_out 'L'; output_binary_int !conn.io_out pos; flush !conn.io_out; Remote(input_remote_value !conn.io_in) let from_environment pos = output_char !conn.io_out 'E'; output_binary_int !conn.io_out pos; flush !conn.io_out; Remote(input_remote_value !conn.io_in) let global pos = output_char !conn.io_out 'G'; output_binary_int !conn.io_out pos; flush !conn.io_out; Remote(input_remote_value !conn.io_in) let accu () = output_char !conn.io_out 'A'; flush !conn.io_out; Remote(input_remote_value !conn.io_in) let closure_code = function | Local obj -> assert false | Remote v -> output_char !conn.io_out 'C'; output_remote_value !conn.io_out v; flush !conn.io_out; input_binary_int !conn.io_in let same rv1 rv2 = match (rv1, rv2) with (Local obj1, Local obj2) -> obj1 == obj2 | (Remote v1, Remote v2) -> v1 = v2 (* string equality -> equality of remote pointers *) | (_, _) -> false end mingw-ocaml/ocaml/debugger/printval.mli0000644000175000017500000000263712124403240017613 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Format val max_printer_depth : int ref val max_printer_steps : int ref val print_exception: formatter -> Debugcom.Remote_value.t -> unit val print_named_value : int -> Parser_aux.expression -> Env.t -> Debugcom.Remote_value.t -> formatter -> Types.type_expr -> unit val reset_named_values : unit -> unit val find_named_value : int -> Debugcom.Remote_value.t * Types.type_expr val install_printer : Path.t -> Types.type_expr -> formatter -> (formatter -> Obj.t -> unit) -> unit val remove_printer : Path.t -> unit mingw-ocaml/ocaml/debugger/input_handling.ml0000644000175000017500000000700512124403240020600 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (**************************** Input control ****************************) open Unix open Primitives (*** Actives files. ***) (* List of the actives files. *) let active_files = ref ([] : (file_descr * ((io_channel -> unit) * io_channel)) list) (* Add a file to the list of actives files. *) let add_file file controller = active_files := (file.io_fd, (controller, file))::!active_files (* Remove a file from the list of actives files. *) let remove_file file = active_files := List.remove_assoc file.io_fd !active_files (* Change the controller for the given file. *) let change_controller file controller = remove_file file; add_file file controller (* Return the controller currently attached to the given file. *) let current_controller file = fst (List.assoc file.io_fd !active_files) (* Execute a function with `controller' attached to `file'. *) (* ### controller file funct *) let execute_with_other_controller controller file funct = let old_controller = current_controller file in change_controller file controller; try let result = funct () in change_controller file old_controller; result with x -> change_controller file old_controller; raise x (*** The "Main Loop" ***) let continue_main_loop = ref true let exit_main_loop _ = continue_main_loop := false (* Handle active files until `continue_main_loop' is false. *) let main_loop () = let old_state = !continue_main_loop in try continue_main_loop := true; while !continue_main_loop do try let (input, _, _) = select (List.map fst !active_files) [] [] (-1.) in List.iter (function fd -> let (funct, iochan) = (List.assoc fd !active_files) in funct iochan) input with Unix_error (EINTR, _, _) -> () done; continue_main_loop := old_state with x -> continue_main_loop := old_state; raise x (*** Managing user inputs ***) (* Are we in interactive mode ? *) let interactif = ref true let current_prompt = ref "" (* Where the user input come from. *) let user_channel = ref std_io let read_user_input buffer length = main_loop (); input !user_channel.io_in buffer 0 length (* Stop reading user input. *) let stop_user_input () = remove_file !user_channel (* Resume reading user input. *) let resume_user_input () = if not (List.mem_assoc !user_channel.io_fd !active_files) then begin if !interactif then begin print_string !current_prompt; flush Pervasives.stdout end; add_file !user_channel exit_main_loop end mingw-ocaml/ocaml/debugger/pos.ml0000644000175000017500000000227012124403240016375 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocquencourt *) (* *) (* Copyright 2003 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Instruct;; open Lexing;; open Location;; open Primitives;; open Source;; let get_desc ev = let loc = ev.ev_loc in Printf.sprintf "file %s, line %d, characters %d-%d" loc.loc_start.pos_fname loc.loc_start.pos_lnum (loc.loc_start.pos_cnum - loc.loc_start.pos_bol + 1) (loc.loc_end.pos_cnum - loc.loc_start.pos_bol + 1) ;; mingw-ocaml/ocaml/debugger/question.ml0000644000175000017500000000334312124403240017445 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Nicolas Pouillard, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) open Input_handling open Primitives (* Ask user a yes or no question. *) let yes_or_no message = if !interactif then let old_prompt = !current_prompt in try current_prompt := message ^ " ? (y or n) "; let answer = let rec ask () = resume_user_input (); let line = string_trim (Lexer.line (Lexing.from_function read_user_input)) in stop_user_input (); match (if String.length line > 0 then line.[0] else ' ') with 'y' -> true | 'n' -> false | _ -> print_string "Please answer y or n."; print_newline (); ask () in ask () in current_prompt := old_prompt; answer with x -> current_prompt := old_prompt; stop_user_input (); raise x else false mingw-ocaml/ocaml/debugger/time_travel.ml0000644000175000017500000005024512124403240020114 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (**************************** Time travel ******************************) open Int64ops open Instruct open Events open Debugcom open Primitives open Checkpoints open Breakpoints open Trap_barrier open Input_handling open Debugger_config open Program_loading open Question exception Current_checkpoint_lost exception Current_checkpoint_lost_start_at of int64 * int64 let remove_1st key list = let rec remove = function [] -> [] | a::l -> if a == key then l else a::(remove l) in remove list (*** Debugging. ***) let debug_time_travel = ref false (*** Internal utilities. ***) (* Insert a checkpoint in the checkpoint list. * Raise `Exit' if there is already a checkpoint at the same time. *) let insert_checkpoint ({c_time = time} as checkpoint) = let rec traverse = function [] -> [checkpoint] | (({c_time = t} as a)::l) as l' -> if t > time then a::(traverse l) else if t = time then raise Exit else checkpoint::l' in checkpoints := traverse !checkpoints (* Remove a checkpoint from the checkpoint list. * --- No error if not found. *) let remove_checkpoint checkpoint = checkpoints := remove_1st checkpoint !checkpoints (* Wait for the process used by `checkpoint' to connect. * --- Usually not called (the process is already connected). *) let wait_for_connection checkpoint = try Exec.unprotect (function () -> let old_controller = Input_handling.current_controller !connection in execute_with_other_controller (function fd -> old_controller fd; if checkpoint.c_valid = true then exit_main_loop ()) !connection main_loop) with Sys.Break -> checkpoint.c_parent <- root; remove_checkpoint checkpoint; checkpoint.c_pid <- -1; raise Sys.Break (* Select a checkpoint as current. *) let set_current_checkpoint checkpoint = if !debug_time_travel then prerr_endline ("Select : " ^ (string_of_int checkpoint.c_pid)); if not checkpoint.c_valid then wait_for_connection checkpoint; current_checkpoint := checkpoint; set_current_connection checkpoint.c_fd (* Kill `checkpoint'. *) let kill_checkpoint checkpoint = if !debug_time_travel then prerr_endline ("Kill : " ^ (string_of_int checkpoint.c_pid)); if checkpoint.c_pid > 0 then (* Ghosts don't have to be killed ! *) (if not checkpoint.c_valid then wait_for_connection checkpoint; stop checkpoint.c_fd; if checkpoint.c_parent.c_pid > 0 then wait_child checkpoint.c_parent.c_fd; checkpoint.c_parent <- root; close_io checkpoint.c_fd; remove_file checkpoint.c_fd; remove_checkpoint checkpoint); checkpoint.c_pid <- -1 (* Don't exist anymore *) (*** Cleaning the checkpoint list. ***) (* Separe checkpoints before (<=) and after (>) `t'. *) (* ### t checkpoints -> (after, before) *) let cut t = let rec cut_t = function [] -> ([], []) | ({c_time = t'} as a::l) as l' -> if t' <= t then ([], l') else let (b, e) = cut_t l in (a::b, e) in cut_t (* Partition the checkpoints list. *) let cut2 t0 t l = let rec cut2_t0 t = function [] -> [] | l -> let (after, before) = cut (t0 -- t -- _1) l in let l = cut2_t0 (t ++ t) before in after::l in let (after, before) = cut (t0 -- _1) l in after::(cut2_t0 t before) (* Separe first elements and last element of a list of checkpoint. *) let chk_merge2 cont = let rec chk_merge2_cont = function [] -> cont | [a] -> let (accepted, rejected) = cont in (a::accepted, rejected) | a::l -> let (accepted, rejected) = chk_merge2_cont l in (accepted, a::rejected) in chk_merge2_cont (* Separe the checkpoint list. *) (* ### list -> accepted * rejected *) let rec chk_merge = function [] -> ([], []) | l::tail -> chk_merge2 (chk_merge tail) l let new_checkpoint_list checkpoint_count accepted rejected = if List.length accepted >= checkpoint_count then let (k, l) = list_truncate2 checkpoint_count accepted in (k, l @ rejected) else let (k, l) = list_truncate2 (checkpoint_count - List.length accepted) rejected in (List.merge (fun {c_time = t1} {c_time = t2} -> compare t2 t1) accepted k, l) (* Clean the checkpoint list. *) (* Reference time is `time'. *) let clean_checkpoints time checkpoint_count = let (after, before) = cut time !checkpoints in let (accepted, rejected) = chk_merge (cut2 time !checkpoint_small_step before) in let (kept, lost) = new_checkpoint_list checkpoint_count accepted after in List.iter kill_checkpoint (lost @ rejected); checkpoints := kept (*** Internal functions for moving. ***) (* Find the first checkpoint before (or at) `time'. * Ask for reloading the program if necessary. *) let find_checkpoint_before time = let rec find = function [] -> print_string "Can't go that far in the past !"; print_newline (); if yes_or_no "Reload program" then begin load_program (); find !checkpoints end else raise Toplevel | { c_time = t } as a::l -> if t > time then find l else a in find !checkpoints (* Make a copy of the current checkpoint and clean the checkpoint list. *) (* --- The new checkpoint in not put in the list. *) let duplicate_current_checkpoint () = let checkpoint = !current_checkpoint in if not checkpoint.c_valid then wait_for_connection checkpoint; let new_checkpoint = (* Ghost *) {c_time = checkpoint.c_time; c_pid = 0; c_fd = checkpoint.c_fd; c_valid = false; c_report = checkpoint.c_report; c_state = C_stopped; c_parent = checkpoint; c_breakpoint_version = checkpoint.c_breakpoint_version; c_breakpoints = checkpoint.c_breakpoints; c_trap_barrier = checkpoint.c_trap_barrier} in checkpoints := list_replace checkpoint new_checkpoint !checkpoints; set_current_checkpoint checkpoint; clean_checkpoints (checkpoint.c_time ++ _1) (!checkpoint_max_count - 1); if new_checkpoint.c_pid = 0 then (* The ghost has not been killed *) (match do_checkpoint () with (* Duplicate checkpoint *) Checkpoint_done pid -> (new_checkpoint.c_pid <- pid; if !debug_time_travel then prerr_endline ("Waiting for connection : " ^ (string_of_int pid))) | Checkpoint_failed -> prerr_endline "A fork failed. Reducing maximum number of checkpoints."; checkpoint_max_count := List.length !checkpoints - 1; remove_checkpoint new_checkpoint) (* Was the movement interrupted ? *) (* --- An exception could have been used instead, *) (* --- but it is not clear where it should be caught. *) (* --- For instance, it should not be caught in `step' *) (* --- (as `step' is used in `next_1'). *) (* --- On the other side, other modules does not need to know *) (* --- about this exception. *) let interrupted = ref false (* Informations about last breakpoint encountered *) let last_breakpoint = ref None (* Ensure we stop on an event. *) let rec stop_on_event report = match report with {rep_type = Breakpoint; rep_program_pointer = pc; rep_stack_pointer = sp} -> last_breakpoint := Some (pc, sp); Symbols.update_current_event (); begin match !current_event with None -> find_event () | Some _ -> () end | {rep_type = Trap_barrier; rep_stack_pointer = trap_frame} -> (* No event at current position. *) find_event () | _ -> () and find_event () = if !debug_time_travel then begin print_string "Searching next event..."; print_newline () end; let report = do_go _1 in !current_checkpoint.c_report <- Some report; stop_on_event report (* Internal function for running debugged program. * Requires `duration > 0'. *) let internal_step duration = match current_report () with Some {rep_type = Exited | Uncaught_exc} -> () | _ -> Exec.protect (function () -> if !make_checkpoints then duplicate_current_checkpoint () else remove_checkpoint !current_checkpoint; update_breakpoints (); update_trap_barrier (); !current_checkpoint.c_state <- C_running duration; let report = do_go duration in !current_checkpoint.c_report <- Some report; !current_checkpoint.c_state <- C_stopped; if report.rep_type = Event then begin !current_checkpoint.c_time <- !current_checkpoint.c_time ++ duration; interrupted := false; last_breakpoint := None end else begin !current_checkpoint.c_time <- !current_checkpoint.c_time ++ duration -- (Int64.of_int report.rep_event_count) ++ _1; interrupted := true; last_breakpoint := None; stop_on_event report end; (try insert_checkpoint !current_checkpoint with Exit -> kill_checkpoint !current_checkpoint; set_current_checkpoint (find_checkpoint_before (current_time ())))); if !debug_time_travel then begin print_string "Checkpoints : pid(time)"; print_newline (); List.iter (function {c_time = time; c_pid = pid; c_valid = valid} -> Printf.printf "%d(%Ld)%s " pid time (if valid then "" else "(invalid)")) !checkpoints; print_newline () end (*** Miscellaneous functions (exported). ***) (* Create a checkpoint at time 0 (new program). *) let new_checkpoint pid fd = let new_checkpoint = {c_time = _0; c_pid = pid; c_fd = fd; c_valid = true; c_report = None; c_state = C_stopped; c_parent = root; c_breakpoint_version = 0; c_breakpoints = []; c_trap_barrier = 0} in insert_checkpoint new_checkpoint (* Set the file descriptor of a checkpoint *) (* (a new process has connected with the debugger). *) (* --- Return `true' on success (close the connection otherwise). *) let set_file_descriptor pid fd = let rec find = function [] -> prerr_endline "Unexpected connection"; close_io fd; false | ({c_pid = pid'} as checkpoint)::l -> if pid <> pid' then find l else (checkpoint.c_fd <- fd; checkpoint.c_valid <- true; true) in if !debug_time_travel then prerr_endline ("New connection : " ^(string_of_int pid)); find (!current_checkpoint::!checkpoints) (* Kill all the checkpoints. *) let kill_all_checkpoints () = List.iter kill_checkpoint (!current_checkpoint::!checkpoints) (* Kill a checkpoint without killing the process. *) (* (used when connection with the process is lost). *) (* --- Assume that the checkpoint is valid. *) let forget_process fd pid = let checkpoint = List.find (function c -> c.c_pid = pid) (!current_checkpoint::!checkpoints) in Printf.eprintf "Lost connection with process %d" pid; let kont = if checkpoint == !current_checkpoint then begin Printf.eprintf " (active process)\n"; match !current_checkpoint.c_state with C_stopped -> Printf.eprintf "at time %Ld" !current_checkpoint.c_time; fun () -> raise Current_checkpoint_lost | C_running duration -> Printf.eprintf "between time %Ld and time %Ld" !current_checkpoint.c_time (!current_checkpoint.c_time ++ duration); fun () -> raise (Current_checkpoint_lost_start_at (!current_checkpoint.c_time, duration)) end else ignore in Printf.eprintf "\n"; flush stderr; Input_handling.remove_file fd; close_io checkpoint.c_fd; remove_file checkpoint.c_fd; remove_checkpoint checkpoint; checkpoint.c_pid <- -1; (* Don't exist anymore *) if checkpoint.c_parent.c_pid > 0 then wait_child checkpoint.c_parent.c_fd; kont () (* Try to recover when the current checkpoint is lost. *) let recover () = set_current_checkpoint (find_checkpoint_before (current_time ())) (*** Simple movements. ***) (* Forward stepping. Requires `duration >= 0'. *) let rec step_forward duration = if duration > !checkpoint_small_step then begin let first_step = if duration > !checkpoint_big_step then !checkpoint_big_step else !checkpoint_small_step in internal_step first_step; if not !interrupted then step_forward (duration -- first_step) end else if duration != _0 then internal_step duration (* Go to time `time' from current checkpoint (internal). *) let internal_go_to time = let duration = time -- (current_time ()) in if duration > _0 then execute_without_breakpoints (function () -> step_forward duration) (* Move to a given time. *) let go_to time = let checkpoint = find_checkpoint_before time in set_current_checkpoint checkpoint; internal_go_to time (* Return the time of the last breakpoint *) (* between current time and `max_time'. *) let rec find_last_breakpoint max_time = let rec find break = let time = current_time () in step_forward (max_time -- time); match !last_breakpoint, !temporary_breakpoint_position with (Some _, _) when current_time () < max_time -> find !last_breakpoint | (Some (pc, _), Some pc') when pc = pc' -> (max_time, !last_breakpoint) | _ -> (time, break) in find (match current_pc_sp () with (Some (pc, _)) as state when breakpoint_at_pc pc -> state | _ -> None) (* Run from `time_max' back to `time'. *) (* --- Assume 0 <= time < time_max *) let rec back_to time time_max = let {c_time = t} = find_checkpoint_before (pre64 time_max) in go_to (max time t); let (new_time, break) = find_last_breakpoint time_max in if break <> None || (new_time <= time) then begin go_to new_time; interrupted := break <> None; last_breakpoint := break end else back_to time new_time (* Backward stepping. *) (* --- Assume duration > 1 *) let step_backward duration = let time = current_time () in if time > _0 then back_to (max _0 (time -- duration)) time (* Run the program from current time. *) (* Stop at the first breakpoint, or at the end of the program. *) let rec run () = internal_step !checkpoint_big_step; if not !interrupted then run () (* Run backward the program form current time. *) (* Stop at the first breakpoint, or at the beginning of the program. *) let back_run () = if current_time () > _0 then back_to _0 (current_time ()) (* Step in any direction. *) (* Stop at the first brakpoint, or after `duration' steps. *) let step duration = if duration >= _0 then step_forward duration else step_backward (_0 -- duration) (*** Next, finish. ***) (* Finish current function. *) let finish () = Symbols.update_current_event (); match !current_event with None -> prerr_endline "`finish' not meaningful in outermost frame."; raise Toplevel | Some curr_event -> set_initial_frame(); let (frame, pc) = up_frame curr_event.ev_stacksize in if frame < 0 then begin prerr_endline "`finish' not meaningful in outermost frame."; raise Toplevel end; begin try ignore(Symbols.any_event_at_pc pc) with Not_found -> prerr_endline "Calling function has no debugging information."; raise Toplevel end; exec_with_trap_barrier frame (fun () -> exec_with_temporary_breakpoint pc (fun () -> while run (); match !last_breakpoint with Some (pc', frame') when pc = pc' -> interrupted := false; frame <> frame' | _ -> false do () done)) let next_1 () = Symbols.update_current_event (); match !current_event with None -> (* Beginning of the program. *) step _1 | Some event1 -> let (frame1, pc1) = initial_frame() in step _1; if not !interrupted then begin Symbols.update_current_event (); match !current_event with None -> () | Some event2 -> let (frame2, pc2) = initial_frame() in (* Call `finish' if we've entered a function. *) if frame1 >= 0 && frame2 >= 0 && frame2 - event2.ev_stacksize > frame1 - event1.ev_stacksize then finish() end (* Same as `step' (forward) but skip over function calls. *) let rec next = function 0 -> () | n -> next_1 (); if not !interrupted then next (n - 1) (* Run backward until just before current function. *) let start () = Symbols.update_current_event (); match !current_event with None -> prerr_endline "`start not meaningful in outermost frame."; raise Toplevel | Some curr_event -> let (frame, _) = initial_frame() in let (frame', pc) = up_frame curr_event.ev_stacksize in if frame' < 0 then begin prerr_endline "`start not meaningful in outermost frame."; raise Toplevel end; let nargs = match try Symbols.any_event_at_pc pc with Not_found -> prerr_endline "Calling function has no debugging information."; raise Toplevel with {ev_info = Event_return nargs} -> nargs | _ -> Misc.fatal_error "Time_travel.start" in let offset = if nargs < 4 then 1 else 2 in let pc = pc - 4 * offset in while exec_with_temporary_breakpoint pc back_run; match !last_breakpoint with Some (pc', frame') when pc = pc' -> step _minus1; (not !interrupted) && (frame' - nargs > frame - curr_event.ev_stacksize) | _ -> false do () done let previous_1 () = Symbols.update_current_event (); match !current_event with None -> (* End of the program. *) step _minus1 | Some event1 -> let (frame1, pc1) = initial_frame() in step _minus1; if not !interrupted then begin Symbols.update_current_event (); match !current_event with None -> () | Some event2 -> let (frame2, pc2) = initial_frame() in (* Call `start' if we've entered a function. *) if frame1 >= 0 && frame2 >= 0 && frame2 - event2.ev_stacksize > frame1 - event1.ev_stacksize then start() end (* Same as `step' (backward) but skip over function calls. *) let rec previous = function 0 -> () | n -> previous_1 (); if not !interrupted then previous (n - 1) mingw-ocaml/ocaml/debugger/breakpoints.ml0000644000175000017500000001511212124403240020114 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (******************************* Breakpoints ***************************) open Checkpoints open Debugcom open Instruct open Primitives open Printf (*** Debugging. ***) let debug_breakpoints = ref false (*** Data. ***) (* Number of the last added breakpoint. *) let breakpoint_number = ref 0 (* Breakpoint number -> event. *) let breakpoints = ref ([] : (int * debug_event) list) (* Program counter -> breakpoint count. *) let positions = ref ([] : (int * int ref) list) (* Versions of the breakpoint list. *) let current_version = ref 0 let max_version = ref 0 (*** Miscellaneous. ***) (* Mark breakpoints as installed in current checkpoint. *) let copy_breakpoints () = !current_checkpoint.c_breakpoints <- !positions; !current_checkpoint.c_breakpoint_version <- !current_version (* Announce a new version of the breakpoint list. *) let new_version () = incr max_version; current_version := !max_version (*** Information about breakpoints. ***) let breakpoints_count () = List.length !breakpoints (* List of breakpoints at `pc'. *) let rec breakpoints_at_pc pc = begin try let ev = Symbols.event_at_pc pc in match ev.ev_repr with Event_child {contents = pc'} -> breakpoints_at_pc pc' | _ -> [] with Not_found -> [] end @ List.map fst (List.filter (function (_, {ev_pos = pos}) -> pos = pc) !breakpoints) (* Is there a breakpoint at `pc' ? *) let breakpoint_at_pc pc = breakpoints_at_pc pc <> [] (*** Set and remove breakpoints ***) (* Remove all breakpoints. *) let remove_breakpoints pos = if !debug_breakpoints then (print_string "Removing breakpoints..."; print_newline ()); List.iter (function (pos, _) -> if !debug_breakpoints then begin print_int pos; print_newline() end; reset_instr pos; Symbols.set_event_at_pc pos) pos (* Set all breakpoints. *) let set_breakpoints pos = if !debug_breakpoints then (print_string "Setting breakpoints..."; print_newline ()); List.iter (function (pos, _) -> if !debug_breakpoints then begin print_int pos; print_newline() end; set_breakpoint pos) pos (* Ensure the current version in installed in current checkpoint. *) let update_breakpoints () = if !debug_breakpoints then begin prerr_string "Updating breakpoints... "; prerr_int !current_checkpoint.c_breakpoint_version; prerr_string " "; prerr_int !current_version; prerr_endline "" end; if !current_checkpoint.c_breakpoint_version <> !current_version then Exec.protect (function () -> remove_breakpoints !current_checkpoint.c_breakpoints; set_breakpoints !positions; copy_breakpoints ()) let change_version version pos = Exec.protect (function () -> current_version := version; positions := pos) (* Execute given function with no breakpoint in current checkpoint. *) (* --- `goto' runs faster this way (does not stop on each breakpoint). *) let execute_without_breakpoints f = let version = !current_version and pos = !positions in change_version 0 []; try f (); change_version version pos with x -> change_version version pos (* Add a position in the position list. *) (* Change version if necessary. *) let insert_position pos = try incr (List.assoc pos !positions) with Not_found -> positions := (pos, ref 1) :: !positions; new_version () (* Remove a position in the position list. *) (* Change version if necessary. *) let remove_position pos = let count = List.assoc pos !positions in decr count; if !count = 0 then begin positions := List.remove_assoc pos !positions; new_version () end (* Insert a new breakpoint in lists. *) let rec new_breakpoint = function {ev_repr = Event_child pc} -> new_breakpoint (Symbols.any_event_at_pc !pc) | event -> Exec.protect (function () -> incr breakpoint_number; insert_position event.ev_pos; breakpoints := (!breakpoint_number, event) :: !breakpoints); printf "Breakpoint %d at %d : %s" !breakpoint_number event.ev_pos (Pos.get_desc event); print_newline () (* Remove a breakpoint from lists. *) let remove_breakpoint number = try let ev = List.assoc number !breakpoints in let pos = ev.ev_pos in Exec.protect (function () -> breakpoints := List.remove_assoc number !breakpoints; remove_position pos; printf "Removed breakpoint %d at %d : %s" number ev.ev_pos (Pos.get_desc ev); print_newline () ) with Not_found -> prerr_endline ("No breakpoint number " ^ (string_of_int number) ^ "."); raise Not_found let remove_all_breakpoints () = List.iter (function (number, _) -> remove_breakpoint number) !breakpoints (*** Temporary breakpoints. ***) (* Temporary breakpoint position. *) let temporary_breakpoint_position = ref (None : int option) (* Execute `funct' with a breakpoint added at `pc'. *) (* --- Used by `finish'. *) let exec_with_temporary_breakpoint pc funct = let previous_version = !current_version in let remove () = temporary_breakpoint_position := None; current_version := previous_version; let count = List.assoc pc !positions in decr count; if !count = 0 then begin positions := List.remove_assoc pc !positions; reset_instr pc; Symbols.set_event_at_pc pc end in Exec.protect (function () -> insert_position pc); temporary_breakpoint_position := Some pc; try funct (); Exec.protect remove with x -> Exec.protect remove; raise x mingw-ocaml/ocaml/debugger/history.ml0000644000175000017500000000303412124403240017274 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Int64ops open Checkpoints open Primitives open Debugger_config let history = ref ([] : int64 list) let empty_history () = history := [] let add_current_time () = let time = current_time () in if !history = [] then history := [time] else if time <> List.hd !history then history := list_truncate !history_size (time::!history) let previous_time_1 () = match !history with _::((time::_) as hist) -> history := hist; time | _ -> prerr_endline "No more information."; raise Toplevel let rec previous_time n = if n = _1 then previous_time_1() else begin ignore(previous_time_1()); previous_time(pre64 n) end mingw-ocaml/ocaml/debugger/program_loading.mli0000644000175000017500000000250312124403240021110 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (*** Debugging. ***) val debug_loading : bool ref (*** Load program ***) (* Function used for launching the program. *) val launching_func : (unit -> unit) ref val load_program : unit -> unit type launching_function = (unit -> unit) val loading_modes : (string * launching_function) list val set_launching_function : launching_function -> unit (** Connection **) val connection : Primitives.io_channel ref val connection_opened : bool ref mingw-ocaml/ocaml/debugger/show_source.ml0000644000175000017500000000661512124403240020143 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Debugger_config open Instruct open Parameters open Primitives open Printf open Source (* Print a line; return the beginning of the next line *) let print_line buffer line_number start point before = let next = next_linefeed buffer start and content = buffer_content buffer in printf "%i " line_number; if point <= next && point >= start then (print_string (String.sub content start (point - start)); print_string (if before then event_mark_before else event_mark_after); print_string (String.sub content point (next - point))) else print_string (String.sub content start (next - start)); print_newline (); next (* Tell Emacs we are nowhere in the source. *) let show_no_point () = if !emacs then printf "\026\026H\n" (* Print the line containing the point *) let show_point ev selected = let mdle = ev.ev_module in let before = (ev.ev_kind = Event_before) in if !emacs && selected then begin try let buffer = get_buffer (Events.get_pos ev) mdle in let source = source_of_module ev.ev_loc.Location.loc_start mdle in printf "\026\026M%s:%i:%i" source (snd (start_and_cnum buffer ev.ev_loc.Location.loc_start)) (snd (start_and_cnum buffer ev.ev_loc.Location.loc_end)); printf "%s\n" (if before then ":before" else ":after") with Out_of_range -> (* point_of_coord *) prerr_endline "Position out of range." | Not_found -> (* Events.get_pos || get_buffer *) prerr_endline ("No source file for " ^ mdle ^ "."); show_no_point () end else begin try let pos = Events.get_pos ev in let buffer = get_buffer pos mdle in let start, point = start_and_cnum buffer pos in ignore(print_line buffer pos.Lexing.pos_lnum start point before) with Out_of_range -> (* point_of_coord *) prerr_endline "Position out of range." | Not_found -> (* Events.get_pos || get_buffer *) prerr_endline ("No source file for " ^ mdle ^ ".") end (* Display part of the source. *) let show_listing pos mdle start stop point before = try let buffer = get_buffer pos mdle in let rec aff (line_start, line_number) = if line_number <= stop then aff (print_line buffer line_number line_start point before + 1, line_number + 1) in aff (pos_of_line buffer start) with Out_of_range -> (* pos_of_line *) prerr_endline "Position out of range." | Not_found -> (* get_buffer *) prerr_endline ("No source file for " ^ mdle ^ ".") mingw-ocaml/ocaml/debugger/.depend0000644000175000017500000002753612124403240016516 0ustar tootstootsbreakpoints.cmi : primitives.cmi ../bytecomp/instruct.cmi checkpoints.cmi : primitives.cmi debugcom.cmi command_line.cmi : debugcom.cmi : primitives.cmi debugger_config.cmi : dynlink.cmi : envaux.cmi : ../typing/subst.cmi ../typing/path.cmi ../bytecomp/instruct.cmi \ ../typing/env.cmi eval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \ ../typing/env.cmi debugcom.cmi events.cmi : ../bytecomp/instruct.cmi exec.cmi : frames.cmi : primitives.cmi ../bytecomp/instruct.cmi history.cmi : input_handling.cmi : primitives.cmi int64ops.cmi : lexer.cmi : parser.cmi loadprinter.cmi : ../parsing/longident.cmi dynlink.cmi parameters.cmi : parser.cmi : parser_aux.cmi ../parsing/longident.cmi parser_aux.cmi : primitives.cmi ../parsing/longident.cmi pattern_matching.cmi : ../typing/typedtree.cmi parser_aux.cmi debugcom.cmi pos.cmi : ../bytecomp/instruct.cmi primitives.cmi : $(UNIXDIR)/unix.cmi printval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ ../typing/env.cmi debugcom.cmi program_loading.cmi : primitives.cmi program_management.cmi : question.cmi : show_information.cmi : ../bytecomp/instruct.cmi show_source.cmi : ../bytecomp/instruct.cmi source.cmi : symbols.cmi : ../bytecomp/instruct.cmi time_travel.cmi : primitives.cmi trap_barrier.cmi : unix_tools.cmi : $(UNIXDIR)/unix.cmi breakpoints.cmo : symbols.cmi primitives.cmi pos.cmi \ ../bytecomp/instruct.cmi exec.cmi debugcom.cmi checkpoints.cmi \ breakpoints.cmi breakpoints.cmx : symbols.cmx primitives.cmx pos.cmx \ ../bytecomp/instruct.cmx exec.cmx debugcom.cmx checkpoints.cmx \ breakpoints.cmi checkpoints.cmo : primitives.cmi int64ops.cmi debugcom.cmi checkpoints.cmi checkpoints.cmx : primitives.cmx int64ops.cmx debugcom.cmx checkpoints.cmi command_line.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \ ../typing/types.cmi time_travel.cmi symbols.cmi source.cmi \ show_source.cmi show_information.cmi question.cmi program_management.cmi \ program_loading.cmi printval.cmi primitives.cmi pos.cmi parser_aux.cmi \ parser.cmi parameters.cmi ../utils/misc.cmi ../parsing/longident.cmi \ ../parsing/location.cmi loadprinter.cmi lexer.cmi int64ops.cmi \ ../bytecomp/instruct.cmi input_handling.cmi history.cmi frames.cmi \ events.cmi eval.cmi envaux.cmi debugger_config.cmi debugcom.cmi \ ../typing/ctype.cmi ../utils/config.cmi checkpoints.cmi breakpoints.cmi \ command_line.cmi command_line.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \ ../typing/types.cmx time_travel.cmx symbols.cmx source.cmx \ show_source.cmx show_information.cmx question.cmx program_management.cmx \ program_loading.cmx printval.cmx primitives.cmx pos.cmx parser_aux.cmi \ parser.cmx parameters.cmx ../utils/misc.cmx ../parsing/longident.cmx \ ../parsing/location.cmx loadprinter.cmx lexer.cmx int64ops.cmx \ ../bytecomp/instruct.cmx input_handling.cmx history.cmx frames.cmx \ events.cmx eval.cmx envaux.cmx debugger_config.cmx debugcom.cmx \ ../typing/ctype.cmx ../utils/config.cmx checkpoints.cmx breakpoints.cmx \ command_line.cmi debugcom.cmo : primitives.cmi ../utils/misc.cmi int64ops.cmi \ input_handling.cmi debugcom.cmi debugcom.cmx : primitives.cmx ../utils/misc.cmx int64ops.cmx \ input_handling.cmx debugcom.cmi debugger_config.cmo : int64ops.cmi debugger_config.cmi debugger_config.cmx : int64ops.cmx debugger_config.cmi dynlink.cmo : ../bytecomp/symtable.cmi ../bytecomp/opcodes.cmo \ ../utils/misc.cmi ../bytecomp/meta.cmi ../bytecomp/dll.cmi \ ../utils/consistbl.cmi ../utils/config.cmi ../bytecomp/cmo_format.cmi \ ../typing/cmi_format.cmi dynlink.cmi dynlink.cmx : ../bytecomp/symtable.cmx ../bytecomp/opcodes.cmx \ ../utils/misc.cmx ../bytecomp/meta.cmx ../bytecomp/dll.cmx \ ../utils/consistbl.cmx ../utils/config.cmx ../bytecomp/cmo_format.cmi \ ../typing/cmi_format.cmx dynlink.cmi envaux.cmo : ../typing/types.cmi ../typing/subst.cmi ../typing/printtyp.cmi \ ../typing/path.cmi ../typing/mtype.cmi ../utils/misc.cmi \ ../bytecomp/instruct.cmi ../typing/env.cmi envaux.cmi envaux.cmx : ../typing/types.cmx ../typing/subst.cmx ../typing/printtyp.cmx \ ../typing/path.cmx ../typing/mtype.cmx ../utils/misc.cmx \ ../bytecomp/instruct.cmx ../typing/env.cmx envaux.cmi eval.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi ../typing/subst.cmi \ printval.cmi ../typing/printtyp.cmi ../typing/predef.cmi \ ../typing/path.cmi parser_aux.cmi ../utils/misc.cmi \ ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \ frames.cmi ../typing/env.cmi debugcom.cmi ../typing/ctype.cmi \ ../typing/btype.cmi eval.cmi eval.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx ../typing/subst.cmx \ printval.cmx ../typing/printtyp.cmx ../typing/predef.cmx \ ../typing/path.cmx parser_aux.cmi ../utils/misc.cmx \ ../parsing/longident.cmx ../bytecomp/instruct.cmx ../typing/ident.cmx \ frames.cmx ../typing/env.cmx debugcom.cmx ../typing/ctype.cmx \ ../typing/btype.cmx eval.cmi events.cmo : ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi events.cmx : ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmi exec.cmo : exec.cmi exec.cmx : exec.cmi frames.cmo : symbols.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi \ events.cmi debugcom.cmi frames.cmi frames.cmx : symbols.cmx ../utils/misc.cmx ../bytecomp/instruct.cmx \ events.cmx debugcom.cmx frames.cmi history.cmo : primitives.cmi int64ops.cmi debugger_config.cmi \ checkpoints.cmi history.cmi history.cmx : primitives.cmx int64ops.cmx debugger_config.cmx \ checkpoints.cmx history.cmi input_handling.cmo : $(UNIXDIR)/unix.cmi primitives.cmi \ input_handling.cmi input_handling.cmx : $(UNIXDIR)/unix.cmx primitives.cmx \ input_handling.cmi int64ops.cmo : int64ops.cmi int64ops.cmx : int64ops.cmi lexer.cmo : parser.cmi lexer.cmi lexer.cmx : parser.cmx lexer.cmi loadprinter.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi printval.cmi \ ../typing/printtyp.cmi ../typing/path.cmi ../utils/misc.cmi \ ../parsing/longident.cmi ../typing/ident.cmi ../typing/env.cmi \ dynlink.cmi ../typing/ctype.cmi ../utils/config.cmi loadprinter.cmi loadprinter.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx printval.cmx \ ../typing/printtyp.cmx ../typing/path.cmx ../utils/misc.cmx \ ../parsing/longident.cmx ../typing/ident.cmx ../typing/env.cmx \ dynlink.cmx ../typing/ctype.cmx ../utils/config.cmx loadprinter.cmi main.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi time_travel.cmi \ show_information.cmi question.cmi program_management.cmi primitives.cmi \ parameters.cmi ../utils/misc.cmi input_handling.cmi frames.cmi exec.cmi \ ../typing/env.cmi debugger_config.cmi ../utils/config.cmi \ command_line.cmi ../typing/cmi_format.cmi ../utils/clflags.cmi \ checkpoints.cmi main.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx time_travel.cmx \ show_information.cmx question.cmx program_management.cmx primitives.cmx \ parameters.cmx ../utils/misc.cmx input_handling.cmx frames.cmx exec.cmx \ ../typing/env.cmx debugger_config.cmx ../utils/config.cmx \ command_line.cmx ../typing/cmi_format.cmx ../utils/clflags.cmx \ checkpoints.cmx parameters.cmo : primitives.cmi envaux.cmi debugger_config.cmi \ ../utils/config.cmi parameters.cmi parameters.cmx : primitives.cmx envaux.cmx debugger_config.cmx \ ../utils/config.cmx parameters.cmi parser.cmo : parser_aux.cmi ../parsing/longident.cmi int64ops.cmi \ input_handling.cmi parser.cmi parser.cmx : parser_aux.cmi ../parsing/longident.cmx int64ops.cmx \ input_handling.cmx parser.cmi pattern_matching.cmo : ../typing/typedtree.cmi parser_aux.cmi \ ../utils/misc.cmi debugger_config.cmi debugcom.cmi ../typing/ctype.cmi \ pattern_matching.cmi pattern_matching.cmx : ../typing/typedtree.cmx parser_aux.cmi \ ../utils/misc.cmx debugger_config.cmx debugcom.cmx ../typing/ctype.cmx \ pattern_matching.cmi pos.cmo : source.cmi primitives.cmi ../parsing/location.cmi \ ../bytecomp/instruct.cmi pos.cmi pos.cmx : source.cmx primitives.cmx ../parsing/location.cmx \ ../bytecomp/instruct.cmx pos.cmi primitives.cmo : $(UNIXDIR)/unix.cmi primitives.cmi primitives.cmx : $(UNIXDIR)/unix.cmx primitives.cmi printval.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi \ ../typing/printtyp.cmi ../typing/path.cmi parser_aux.cmi \ ../typing/outcometree.cmi ../typing/oprint.cmi \ ../toplevel/genprintval.cmi debugcom.cmi printval.cmi printval.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx \ ../typing/printtyp.cmx ../typing/path.cmx parser_aux.cmi \ ../typing/outcometree.cmi ../typing/oprint.cmx \ ../toplevel/genprintval.cmx debugcom.cmx printval.cmi program_loading.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \ primitives.cmi parameters.cmi input_handling.cmi debugger_config.cmi \ program_loading.cmi program_loading.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \ primitives.cmx parameters.cmx input_handling.cmx debugger_config.cmx \ program_loading.cmi program_management.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \ time_travel.cmi symbols.cmi question.cmi program_loading.cmi \ primitives.cmi parameters.cmi int64ops.cmi input_handling.cmi history.cmi \ debugger_config.cmi breakpoints.cmi program_management.cmi program_management.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \ time_travel.cmx symbols.cmx question.cmx program_loading.cmx \ primitives.cmx parameters.cmx int64ops.cmx input_handling.cmx history.cmx \ debugger_config.cmx breakpoints.cmx program_management.cmi question.cmo : primitives.cmi lexer.cmi input_handling.cmi question.cmi question.cmx : primitives.cmx lexer.cmx input_handling.cmx question.cmi show_information.cmo : symbols.cmi source.cmi show_source.cmi printval.cmi \ ../utils/misc.cmi ../bytecomp/instruct.cmi frames.cmi events.cmi \ debugcom.cmi checkpoints.cmi breakpoints.cmi show_information.cmi show_information.cmx : symbols.cmx source.cmx show_source.cmx printval.cmx \ ../utils/misc.cmx ../bytecomp/instruct.cmx frames.cmx events.cmx \ debugcom.cmx checkpoints.cmx breakpoints.cmx show_information.cmi show_source.cmo : source.cmi primitives.cmi parameters.cmi \ ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi \ debugger_config.cmi show_source.cmi show_source.cmx : source.cmx primitives.cmx parameters.cmx \ ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmx \ debugger_config.cmx show_source.cmi source.cmo : primitives.cmi ../utils/misc.cmi debugger_config.cmi \ ../utils/config.cmi source.cmi source.cmx : primitives.cmx ../utils/misc.cmx debugger_config.cmx \ ../utils/config.cmx source.cmi symbols.cmo : ../bytecomp/symtable.cmi program_loading.cmi \ ../bytecomp/instruct.cmi events.cmi debugger_config.cmi debugcom.cmi \ checkpoints.cmi ../bytecomp/bytesections.cmi symbols.cmi symbols.cmx : ../bytecomp/symtable.cmx program_loading.cmx \ ../bytecomp/instruct.cmx events.cmx debugger_config.cmx debugcom.cmx \ checkpoints.cmx ../bytecomp/bytesections.cmx symbols.cmi time_travel.cmo : trap_barrier.cmi symbols.cmi question.cmi \ program_loading.cmi primitives.cmi ../utils/misc.cmi int64ops.cmi \ ../bytecomp/instruct.cmi input_handling.cmi exec.cmi events.cmi \ debugger_config.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi \ time_travel.cmi time_travel.cmx : trap_barrier.cmx symbols.cmx question.cmx \ program_loading.cmx primitives.cmx ../utils/misc.cmx int64ops.cmx \ ../bytecomp/instruct.cmx input_handling.cmx exec.cmx events.cmx \ debugger_config.cmx debugcom.cmx checkpoints.cmx breakpoints.cmx \ time_travel.cmi trap_barrier.cmo : exec.cmi debugcom.cmi checkpoints.cmi trap_barrier.cmi trap_barrier.cmx : exec.cmx debugcom.cmx checkpoints.cmx trap_barrier.cmi unix_tools.cmo : $(UNIXDIR)/unix.cmi primitives.cmi ../utils/misc.cmi \ unix_tools.cmi unix_tools.cmx : $(UNIXDIR)/unix.cmx primitives.cmx ../utils/misc.cmx \ unix_tools.cmi mingw-ocaml/ocaml/debugger/primitives.mli0000644000175000017500000000427212124403240020144 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (********************* Basic functions and types ***********************) (*** Miscellaneous ***) val nothing : 'a -> unit (*** Types and exceptions. ***) exception Out_of_range (*** Operations on lists. ***) (* Remove an element from a list *) val except : 'a -> 'a list -> 'a list (* Position of an element in a list. Head of list has position 0. *) val index : 'a -> 'a list -> int (* Return the `n' first elements of `l'. *) (* ### n l -> l' *) val list_truncate : int -> 'a list -> 'a list (* Separe the `n' first elements of `l' and the others. *) (* ### n list -> (first, last) *) val list_truncate2 : int -> 'a list -> 'a list * 'a list (* Replace x by y in list l *) (* ### x y l -> l' *) val list_replace : 'a -> 'a -> 'a list -> 'a list (*** Operations on strings. ***) (* Remove blanks (spaces and tabs) at beginning and end of a string. *) val string_trim : string -> string (* isprefix s1 s2 returns true if s1 is a prefix of s2. *) val isprefix : string -> string -> bool (* Split a string at the given delimiter char *) val split_string : char -> string -> string list (*** I/O channels ***) type io_channel = { io_in : in_channel; io_out : out_channel; io_fd : Unix.file_descr } val io_channel_of_descr : Unix.file_descr -> io_channel val close_io : io_channel -> unit val std_io : io_channel mingw-ocaml/ocaml/debugger/printval.ml0000644000175000017500000000640412124403240017436 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* OCaml port by John Malecki and Xavier Leroy *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* To print values *) open Format open Parser_aux open Path open Types (* To name printed and ellipsed values *) let named_values = (Hashtbl.create 29 : (int, Debugcom.Remote_value.t * type_expr) Hashtbl.t) let next_name = ref 1 let reset_named_values () = Hashtbl.clear named_values; next_name := 1 let name_value v ty = let name = !next_name in incr next_name; Hashtbl.add named_values name (v, ty); name let find_named_value name = Hashtbl.find named_values name let check_depth ppf depth obj ty = if depth <= 0 then begin let n = name_value obj ty in Some (Outcometree.Oval_stuff ("$" ^ string_of_int n)) end else None module EvalPath = struct type valu = Debugcom.Remote_value.t exception Error let rec eval_path = function Pident id -> begin try Debugcom.Remote_value.global (Symtable.get_global_position id) with Symtable.Error _ -> raise Error end | Pdot(root, fieldname, pos) -> let v = eval_path root in if not (Debugcom.Remote_value.is_block v) then raise Error else Debugcom.Remote_value.field v pos | Papply(p1, p2) -> raise Error let same_value = Debugcom.Remote_value.same end module Printer = Genprintval.Make(Debugcom.Remote_value)(EvalPath) let install_printer path ty ppf fn = Printer.install_printer path ty (fun ppf remote_val -> try fn ppf (Obj.repr (Debugcom.Remote_value.obj remote_val)) with Debugcom.Marshalling_error -> fprintf ppf "") let remove_printer = Printer.remove_printer let max_printer_depth = ref 20 let max_printer_steps = ref 300 let print_exception ppf obj = let t = Printer.outval_of_untyped_exception obj in !Oprint.out_value ppf t let print_value max_depth env obj (ppf : Format.formatter) ty = let t = Printer.outval_of_value !max_printer_steps max_depth (check_depth ppf) env obj ty in !Oprint.out_value ppf t let print_named_value max_depth exp env obj ppf ty = let print_value_name ppf = function | E_ident lid -> Printtyp.longident ppf lid | E_name n -> fprintf ppf "$%i" n | _ -> let n = name_value obj ty in fprintf ppf "$%i" n in Printtyp.reset_and_mark_loops ty; fprintf ppf "@[<2>%a :@ %a@ =@ %a@]@." print_value_name exp Printtyp.type_expr ty (print_value max_depth env obj) ty mingw-ocaml/ocaml/Upgrading0000644000175000017500000001102412124403240015316 0ustar tootstoots FAQ: how to upgrade from Objective Caml 3.02 to 3.03 I Installation Q1: When compiling the distribution, I am getting strange linking errors in "otherlibraries". A1: This is probably a problem with dynamic linking. You can disable it with ./configure -no-shared-libs. If you really want to use shared libraries, look in the manual pages of your system for how to get some debugging output from the dynamic linker. II Non-label changes Q2: I get a syntax error when I try to compile a program using stream parsers. A2: Stream parser now require camlp4. It is included in the distribution, and you just need to use "ocamlc -pp camlp4o" in place of "ocamlc". You can also use it under the toplevel with #load"camlp4o.cma". Q3: I get a warning when I use the syntax "#variant" inside type expressions. A3: The new syntax is [< variant], which just a special case of the more general new syntax, which allows type expressions like [ variant1 | variant2] or [> variant]. See the reference manual for details. III Label changes Q4: I was using labels before, and now I get lots of type errors. A4: The handling of labels changed with 3.03-alpha. The new default is a more flexible version of the commuting label mode, allowing one to omit labels in total applications. There is still a -nolabels mode, but it does not allow non-optional labels in applications (this was unsound). To keep full compatibility with Objective Caml 2, labels were removed from the standard libraries. Some labelized libraries are kept as StdLabels (contains Array, List and String), MoreLabels (contains Hashtbl, Map and Set), and UnixLabels. Note that MoreLabels' status is not yet decided. Q5: Why isn't there a ThreadUnixLabels module ? A5: ThreadUnix is deprecated. It only calls directly the Unix module. Q6: I was using commuting label mode, how can I upgrade ? A6: The new behaviour is compatible with commuting label mode, but standard libraries have no labels. You can add the following lines at the beginning of your files (according to your needs): open Stdlabels open MoreLabels module Unix = UnixLabels Alternatively, if you already have a common module opened by everybody, you can add these: include StdLabels include MoreLabels module Unix = UnixLabels You will then need to remove labels in functions from other modules. This can be automated by using the scrapelabels tool, installed in the Objective Caml library directory, which both removes labels and inserts needed `open' clauses (see -help for details). $CAMLLIB/scrapelabels -keepstd *.ml or $CAMLLIB/scrapelabels -keepmore *.ml Note that scrapelabels is not guaranteed to be sound for commuting label programs, since it will just remove labels, and not reorder arguments. Q7: I was using a few labels in classic mode, and now I get all these errors. I just want to get rid of all these silly labels. A7: scrapelabels will do it for you. $CAMLLIB/scrapelabels [-all] *.ml $CAMLLIB/scrapelabels -intf *.mli You should specify the -all option only if you are sure that your sources do not contain calls to functions with optional parameters, as those labels would also be removed. Q8: I was using labels in classic mode, and I was actually pretty fond of them. How much more labels will I have to write now ? How can I convert my programs and libraries ? A8: The new default mode is more flexible than the original commuting mode, so that you shouldn't see too much differences when using labeled libraries. Labels are only compulsory in partial applications (including the special case of function with an unknown return type), or if you wrote some of them. On the other hand, for definitions, labels present in the interface must also be present in the implementation. The addlabels tool can help you to do that. Suppose that you have mymod.ml and mymod.mli, where mymod.mli adds some labels. Then doing $CAMLLIB/addlabels mymod.ml will insert labels from the interface inside the implementation. It also takes care of inserting them in recursive calls, as the return type of the function is not known while typing it. If you used labels from standard libraries, you will also have problems with them. You can proceed as described in A6. Since you used classic mode, you do not need to bother about changed argument order. mingw-ocaml/ocaml/utils/0000755000175000017500000000000012124403240014615 5ustar tootstootsmingw-ocaml/ocaml/utils/warnings.ml0000644000175000017500000003615512124403240017011 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis && Damien Doligez, INRIA Rocquencourt *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* When you change this, you need to update the documentation: - man/ocamlc.m in ocaml - man/ocamlopt.m in ocaml - manual/cmds/comp.etex in the doc sources - manual/cmds/native.etex in the doc sources *) type t = | Comment_start (* 1 *) | Comment_not_end (* 2 *) | Deprecated (* 3 *) | Fragile_match of string (* 4 *) | Partial_application (* 5 *) | Labels_omitted (* 6 *) | Method_override of string list (* 7 *) | Partial_match of string (* 8 *) | Non_closed_record_pattern of string (* 9 *) | Statement_type (* 10 *) | Unused_match (* 11 *) | Unused_pat (* 12 *) | Instance_variable_override of string list (* 13 *) | Illegal_backslash (* 14 *) | Implicit_public_methods of string list (* 15 *) | Unerasable_optional_argument (* 16 *) | Undeclared_virtual_method of string (* 17 *) | Not_principal of string (* 18 *) | Without_principality of string (* 19 *) | Unused_argument (* 20 *) | Nonreturning_statement (* 21 *) | Camlp4 of string (* 22 *) | Useless_record_with (* 23 *) | Bad_module_name of string (* 24 *) | All_clauses_guarded (* 25 *) | Unused_var of string (* 26 *) | Unused_var_strict of string (* 27 *) | Wildcard_arg_to_constant_constr (* 28 *) | Eol_in_string (* 29 *) | Duplicate_definitions of string * string * string * string (*30 *) | Multiple_definition of string * string * string (* 31 *) | Unused_value_declaration of string (* 32 *) | Unused_open of string (* 33 *) | Unused_type_declaration of string (* 34 *) | Unused_for_index of string (* 35 *) | Unused_ancestor of string (* 36 *) | Unused_constructor of string * bool * bool (* 37 *) | Unused_exception of string * bool (* 38 *) | Unused_rec_flag (* 39 *) ;; (* If you remove a warning, leave a hole in the numbering. NEVER change the numbers of existing warnings. If you add a new warning, add it at the end with a new number; do NOT reuse one of the holes. *) let number = function | Comment_start -> 1 | Comment_not_end -> 2 | Deprecated -> 3 | Fragile_match _ -> 4 | Partial_application -> 5 | Labels_omitted -> 6 | Method_override _ -> 7 | Partial_match _ -> 8 | Non_closed_record_pattern _ -> 9 | Statement_type -> 10 | Unused_match -> 11 | Unused_pat -> 12 | Instance_variable_override _ -> 13 | Illegal_backslash -> 14 | Implicit_public_methods _ -> 15 | Unerasable_optional_argument -> 16 | Undeclared_virtual_method _ -> 17 | Not_principal _ -> 18 | Without_principality _ -> 19 | Unused_argument -> 20 | Nonreturning_statement -> 21 | Camlp4 _ -> 22 | Useless_record_with -> 23 | Bad_module_name _ -> 24 | All_clauses_guarded -> 25 | Unused_var _ -> 26 | Unused_var_strict _ -> 27 | Wildcard_arg_to_constant_constr -> 28 | Eol_in_string -> 29 | Duplicate_definitions _ -> 30 | Multiple_definition _ -> 31 | Unused_value_declaration _ -> 32 | Unused_open _ -> 33 | Unused_type_declaration _ -> 34 | Unused_for_index _ -> 35 | Unused_ancestor _ -> 36 | Unused_constructor _ -> 37 | Unused_exception _ -> 38 | Unused_rec_flag -> 39 ;; let last_warning_number = 39 (* Must be the max number returned by the [number] function. *) let letter = function | 'a' -> let rec loop i = if i = 0 then [] else i :: loop (i - 1) in loop last_warning_number | 'b' -> [] | 'c' -> [1; 2] | 'd' -> [3] | 'e' -> [4] | 'f' -> [5] | 'g' -> [] | 'h' -> [] | 'i' -> [] | 'j' -> [] | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39] | 'l' -> [6] | 'm' -> [7] | 'n' -> [] | 'o' -> [] | 'p' -> [8] | 'q' -> [] | 'r' -> [9] | 's' -> [10] | 't' -> [] | 'u' -> [11; 12] | 'v' -> [13] | 'w' -> [] | 'x' -> [14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 25; 30] | 'y' -> [26] | 'z' -> [27] | _ -> assert false ;; let active = Array.create (last_warning_number + 1) true;; let error = Array.create (last_warning_number + 1) false;; let is_active x = active.(number x);; let is_error x = error.(number x);; let parse_opt flags s = let set i = flags.(i) <- true in let clear i = flags.(i) <- false in let set_all i = active.(i) <- true; error.(i) <- true in let error () = raise (Arg.Bad "Ill-formed list of warnings") in let rec get_num n i = if i >= String.length s then i, n else match s.[i] with | '0'..'9' -> get_num (10 * n + Char.code s.[i] - Char.code '0') (i + 1) | _ -> i, n in let get_range i = let i, n1 = get_num 0 i in if i + 2 < String.length s && s.[i] = '.' && s.[i + 1] = '.' then let i, n2 = get_num 0 (i + 2) in if n2 < n1 then error (); i, n1, n2 else i, n1, n1 in let rec loop i = if i >= String.length s then () else match s.[i] with | 'A' .. 'Z' -> List.iter set (letter (Char.lowercase s.[i])); loop (i+1) | 'a' .. 'z' -> List.iter clear (letter s.[i]); loop (i+1) | '+' -> loop_letter_num set (i+1) | '-' -> loop_letter_num clear (i+1) | '@' -> loop_letter_num set_all (i+1) | c -> error () and loop_letter_num myset i = if i >= String.length s then error () else match s.[i] with | '0' .. '9' -> let i, n1, n2 = get_range i in for n = n1 to min n2 last_warning_number do myset n done; loop i | 'A' .. 'Z' -> List.iter myset (letter (Char.lowercase s.[i])); loop (i+1) | 'a' .. 'z' -> List.iter myset (letter s.[i]); loop (i+1) | _ -> error () in loop 0 ;; let parse_options errflag s = parse_opt (if errflag then error else active) s;; (* If you change these, don't forget to change them in man/ocamlc.m *) let defaults_w = "+a-4-6-7-9-27-29-32..39";; let defaults_warn_error = "-a";; let () = parse_options false defaults_w;; let () = parse_options true defaults_warn_error;; let message = function | Comment_start -> "this is the start of a comment." | Comment_not_end -> "this is not the end of a comment." | Deprecated -> "this syntax is deprecated." | Fragile_match "" -> "this pattern-matching is fragile." | Fragile_match s -> "this pattern-matching is fragile.\n\ It will remain exhaustive when constructors are added to type " ^ s ^ "." | Partial_application -> "this function application is partial,\n\ maybe some arguments are missing." | Labels_omitted -> "labels were omitted in the application of this function." | Method_override [lab] -> "the method " ^ lab ^ " is overridden." | Method_override (cname :: slist) -> String.concat " " ("the following methods are overridden by the class" :: cname :: ":\n " :: slist) | Method_override [] -> assert false | Partial_match "" -> "this pattern-matching is not exhaustive." | Partial_match s -> "this pattern-matching is not exhaustive.\n\ Here is an example of a value that is not matched:\n" ^ s | Non_closed_record_pattern s -> "the following labels are not bound in this record pattern:\n" ^ s ^ "\nEither bind these labels explicitly or add '; _' to the pattern." | Statement_type -> "this expression should have type unit." | Unused_match -> "this match case is unused." | Unused_pat -> "this sub-pattern is unused." | Instance_variable_override [lab] -> "the instance variable " ^ lab ^ " is overridden.\n" ^ "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" | Instance_variable_override (cname :: slist) -> String.concat " " ("the following instance variables are overridden by the class" :: cname :: ":\n " :: slist) ^ "\nThe behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" | Instance_variable_override [] -> assert false | Illegal_backslash -> "illegal backslash escape in string." | Implicit_public_methods l -> "the following private methods were made public implicitly:\n " ^ String.concat " " l ^ "." | Unerasable_optional_argument -> "this optional argument cannot be erased." | Undeclared_virtual_method m -> "the virtual method "^m^" is not declared." | Not_principal s -> s^" is not principal." | Without_principality s -> s^" without principality." | Unused_argument -> "this argument will not be used by the function." | Nonreturning_statement -> "this statement never returns (or has an unsound type.)" | Camlp4 s -> s | Useless_record_with -> "all the fields are explicitly listed in this record:\n\ the 'with' clause is useless." | Bad_module_name (modname) -> "bad source file name: \"" ^ modname ^ "\" is not a valid module name." | All_clauses_guarded -> "bad style, all clauses in this pattern-matching are guarded." | Unused_var v | Unused_var_strict v -> "unused variable " ^ v ^ "." | Wildcard_arg_to_constant_constr -> "wildcard pattern given as argument to a constant constructor" | Eol_in_string -> "unescaped end-of-line in a string constant (non-portable code)" | Duplicate_definitions (kind, cname, tc1, tc2) -> Printf.sprintf "the %s %s is defined in both types %s and %s." kind cname tc1 tc2 | Multiple_definition(modname, file1, file2) -> Printf.sprintf "files %s and %s both define a module named %s" file1 file2 modname | Unused_value_declaration v -> "unused value " ^ v ^ "." | Unused_open s -> "unused open " ^ s ^ "." | Unused_type_declaration s -> "unused type " ^ s ^ "." | Unused_for_index s -> "unused for-loop index " ^ s ^ "." | Unused_ancestor s -> "unused ancestor variable " ^ s ^ "." | Unused_constructor (s, false, false) -> "unused constructor " ^ s ^ "." | Unused_constructor (s, true, _) -> "constructor " ^ s ^ " is never used to build values.\n\ (However, this constructor appears in patterns.)" | Unused_constructor (s, false, true) -> "constructor " ^ s ^ " is never used to build values.\n\ Its type is exported as a private type." | Unused_exception (s, false) -> "unused exception constructor " ^ s ^ "." | Unused_exception (s, true) -> "exception constructor " ^ s ^ " is never raised or used to build values.\n\ (However, this constructor appears in patterns.)" | Unused_rec_flag -> "unused rec flag." ;; let nerrors = ref 0;; let print ppf w = let msg = message w in let num = number w in let newlines = ref 0 in for i = 0 to String.length msg - 1 do if msg.[i] = '\n' then incr newlines; done; let (out, flush, newline, space) = Format.pp_get_all_formatter_output_functions ppf () in let countnewline x = incr newlines; newline x in Format.pp_set_all_formatter_output_functions ppf out flush countnewline space; Format.fprintf ppf "%d: %s" num msg; Format.pp_print_flush ppf (); Format.pp_set_all_formatter_output_functions ppf out flush newline space; if error.(num) then incr nerrors; !newlines ;; exception Errors of int;; let check_fatal () = if !nerrors > 0 then begin let e = Errors !nerrors in nerrors := 0; raise e; end; ;; let descriptions = [ 1, "Suspicious-looking start-of-comment mark."; 2, "Suspicious-looking end-of-comment mark."; 3, "Deprecated syntax."; 4, "Fragile pattern matching: matching that will remain complete even\n\ \ if additional constructors are added to one of the variant types\n\ \ matched."; 5, "Partially applied function: expression whose result has function\n\ \ type and is ignored."; 6, "Label omitted in function application."; 7, "Method overridden."; 8, "Partial match: missing cases in pattern-matching."; 9, "Missing fields in a record pattern."; 10, "Expression on the left-hand side of a sequence that doesn't have type\n\ \ \"unit\" (and that is not a function, see warning number 5)."; 11, "Redundant case in a pattern matching (unused match case)."; 12, "Redundant sub-pattern in a pattern-matching."; 13, "Instance variable overridden."; 14, "Illegal backslash escape in a string constant."; 15, "Private method made public implicitly."; 16, "Unerasable optional argument."; 17, "Undeclared virtual method."; 18, "Non-principal type."; 19, "Type without principality."; 20, "Unused function argument."; 21, "Non-returning statement."; 22, "Camlp4 warning."; 23, "Useless record \"with\" clause."; 24, "Bad module name: the source file name is not a valid OCaml module \ name."; 25, "Pattern-matching with all clauses guarded. Exhaustiveness cannot be\n\ \ checked."; 26, "Suspicious unused variable: unused variable that is bound\n\ \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ \ character."; 27, "Innocuous unused variable: unused variable that is not bound with\n\ \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ \ character."; 28, "Wildcard pattern given as argument to a constant constructor."; 29, "Unescaped end-of-line in a string constant (non-portable code)."; 30, "Two labels or constructors of the same name are defined in two\n\ \ mutually recursive types."; 31, "A module is linked twice in the same executable."; 32, "Unused value declaration."; 33, "Unused open statement."; 34, "Unused type declaration."; 35, "Unused for-loop index."; 36, "Unused ancestor variable."; 37, "Unused constructor."; 38, "Unused exception constructor."; 39, "Unused rec flag."; ] ;; let help_warnings () = List.iter (fun (i, s) -> Printf.printf "%3i %s\n" i s) descriptions; print_endline " A All warnings."; for i = Char.code 'b' to Char.code 'z' do let c = Char.chr i in match letter c with | [] -> () | [n] -> Printf.printf " %c Synonym for warning %i.\n" (Char.uppercase c) n | l -> Printf.printf " %c Set of warnings %s.\n" (Char.uppercase c) (String.concat ", " (List.map string_of_int l)) done; exit 0 ;; mingw-ocaml/ocaml/utils/.ignore0000644000175000017500000000001212124403240016072 0ustar tootstootsconfig.ml mingw-ocaml/ocaml/utils/terminfo.ml0000644000175000017500000000224112124403240016771 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Basic interface to the terminfo database *) type status = | Uninitialised | Bad_term | Good_term of int ;; external setup : out_channel -> status = "caml_terminfo_setup";; external backup : int -> unit = "caml_terminfo_backup";; external standout : bool -> unit = "caml_terminfo_standout";; external resume : int -> unit = "caml_terminfo_resume";; mingw-ocaml/ocaml/utils/config.mlbuild0000644000175000017500000001065512124403240017443 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (***********************************************************************) (** **) (** WARNING WARNING WARNING **) (** **) (** When you change this file, you must make the parallel change **) (** in config.mlp **) (** **) (***********************************************************************) (* The main OCaml version string has moved to ../VERSION *) let version = Sys.ocaml_version module C = Myocamlbuild_config let standard_library_default = C.libdir let standard_library = try Sys.getenv "OCAMLLIB" with Not_found -> try Sys.getenv "CAMLLIB" with Not_found -> standard_library_default let windows = match Sys.os_type with | "Win32" -> true | _ -> false let sf = Printf.sprintf let standard_runtime = if windows then "ocamlrun" else C.bindir^"/ocamlrun" let ccomp_type = C.ccomptype let bytecomp_c_compiler = sf "%s %s %s" C.bytecc C.bytecccompopts C.sharedcccompopts let bytecomp_c_libraries = C.bytecclibs let native_c_compiler = sf "%s %s" C.nativecc C.nativecccompopts let native_c_libraries = C.nativecclibs let native_pack_linker = C.packld let ranlib = C.ranlibcmd let ar = C.arcmd let cc_profile = C.cc_profile let mkdll = C.mkdll let mkexe = C.mkexe let mkmaindll = C.mkmaindll let exec_magic_number = "Caml1999X008" and cmi_magic_number = "Caml1999I014" and cmo_magic_number = "Caml1999O007" and cma_magic_number = "Caml1999A008" and cmx_magic_number = "Caml1999Y011" and cmxa_magic_number = "Caml1999Z010" and ast_impl_magic_number = "Caml1999M015" and ast_intf_magic_number = "Caml1999N014" and cmxs_magic_number = "Caml2007D001" and cmt_magic_number = "Caml2012T001" let load_path = ref ([] : string list) let interface_suffix = ref ".mli" let max_tag = 245 (* This is normally the same as in obj.ml, but we have to define it separately because it can differ when we're in the middle of a bootstrapping phase. *) let lazy_tag = 246 let max_young_wosize = 256 let stack_threshold = 256 (* see byterun/config.h *) let architecture = C.arch let model = C.model let system = C.system let asm = C.asm let asm_cfi_supported = C.asm_cfi_supported let ext_obj = C.ext_obj let ext_asm = C.ext_asm let ext_lib = C.ext_lib let ext_dll = C.ext_dll let default_executable_name = match Sys.os_type with "Unix" -> "a.out" | "Win32" | "Cygwin" -> "camlprog.exe" | _ -> "camlprog" let systhread_supported = C.systhread_support;; let print_config oc = let p name valu = Printf.fprintf oc "%s: %s\n" name valu in let p_bool name valu = Printf.fprintf oc "%s: %B\n" name valu in p "version" version; p "standard_library_default" standard_library_default; p "standard_library" standard_library; p "standard_runtime" standard_runtime; p "ccomp_type" ccomp_type; p "bytecomp_c_compiler" bytecomp_c_compiler; p "bytecomp_c_libraries" bytecomp_c_libraries; p "native_c_compiler" native_c_compiler; p "native_c_libraries" native_c_libraries; p "native_pack_linker" native_pack_linker; p "ranlib" ranlib; p "cc_profile" cc_profile; p "architecture" architecture; p "model" model; p "system" system; p "asm" asm; p_bool "asm_cfi_supported" asm_cfi_supported; p "ext_obj" ext_obj; p "ext_asm" ext_asm; p "ext_lib" ext_lib; p "ext_dll" ext_dll; p "os_type" Sys.os_type; p "default_executable_name" default_executable_name; p_bool "systhread_supported" systhread_supported; flush oc; ;; mingw-ocaml/ocaml/utils/clflags.mli0000644000175000017500000000541312124403240016736 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2005 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) val objfiles : string list ref val ccobjs : string list ref val dllibs : string list ref val compile_only : bool ref val output_name : string option ref val include_dirs : string list ref val no_std_include : bool ref val print_types : bool ref val make_archive : bool ref val debug : bool ref val fast : bool ref val link_everything : bool ref val custom_runtime : bool ref val output_c_object : bool ref val ccopts : string list ref val classic : bool ref val nopervasives : bool ref val preprocessor : string option ref val annotations : bool ref val binary_annotations : bool ref val use_threads : bool ref val use_vmthreads : bool ref val noassert : bool ref val verbose : bool ref val noprompt : bool ref val nopromptcont : bool ref val init_file : string option ref val use_prims : string ref val use_runtime : string ref val principal : bool ref val recursive_types : bool ref val strict_sequence : bool ref val applicative_functors : bool ref val make_runtime : bool ref val gprofile : bool ref val c_compiler : string option ref val no_auto_link : bool ref val dllpaths : string list ref val make_package : bool ref val for_package : string option ref val error_size : int ref val dump_parsetree : bool ref val dump_rawlambda : bool ref val dump_lambda : bool ref val dump_clambda : bool ref val dump_instr : bool ref val keep_asm_file : bool ref val optimize_for_speed : bool ref val dump_cmm : bool ref val dump_selection : bool ref val dump_live : bool ref val dump_spill : bool ref val dump_split : bool ref val dump_interf : bool ref val dump_prefer : bool ref val dump_regalloc : bool ref val dump_reload : bool ref val dump_scheduling : bool ref val dump_linear : bool ref val keep_startup_file : bool ref val dump_combine : bool ref val native_code : bool ref val inline_threshold : int ref val dont_write_files : bool ref val std_include_flag : string -> string val std_include_dir : unit -> string list val shared : bool ref val dlcode : bool ref val runtime_variant : string ref mingw-ocaml/ocaml/utils/tbl.mli0000644000175000017500000000261612124403240016106 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Association tables from any ordered type to any type. We use the generic ordering to compare keys. *) type ('a, 'b) t val empty: ('a, 'b) t val add: 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t val find: 'a -> ('a, 'b) t -> 'b val mem: 'a -> ('a, 'b) t -> bool val remove: 'a -> ('a, 'b) t -> ('a, 'b) t val iter: ('a -> 'b -> unit) -> ('a, 'b) t -> unit val map: ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t val fold: ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c open Format val print: (formatter -> 'a -> unit) -> (formatter -> 'b -> unit) -> formatter -> ('a, 'b) t -> unit mingw-ocaml/ocaml/utils/consistbl.ml0000644000175000017500000000375412124403240017160 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Consistency tables: for checking consistency of module CRCs *) type t = (string, Digest.t * string) Hashtbl.t let create () = Hashtbl.create 13 let clear = Hashtbl.clear exception Inconsistency of string * string * string exception Not_available of string let check tbl name crc source = try let (old_crc, old_source) = Hashtbl.find tbl name in if crc <> old_crc then raise(Inconsistency(name, source, old_source)) with Not_found -> Hashtbl.add tbl name (crc, source) let check_noadd tbl name crc source = try let (old_crc, old_source) = Hashtbl.find tbl name in if crc <> old_crc then raise(Inconsistency(name, source, old_source)) with Not_found -> raise (Not_available name) let set tbl name crc source = Hashtbl.add tbl name (crc, source) let source tbl name = snd (Hashtbl.find tbl name) let extract tbl = Hashtbl.fold (fun name (crc, auth) accu -> (name, crc) :: accu) tbl [] let filter p tbl = let to_remove = ref [] in Hashtbl.iter (fun name (crc, auth) -> if not (p name) then to_remove := name :: !to_remove) tbl; List.iter (fun name -> while Hashtbl.mem tbl name do Hashtbl.remove tbl name done) !to_remove mingw-ocaml/ocaml/utils/config.mli0000644000175000017500000001202512124403240016565 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* System configuration *) val version: string (* The current version number of the system *) val standard_library: string (* The directory containing the standard libraries *) val standard_runtime: string (* The full path to the standard bytecode interpreter ocamlrun *) val ccomp_type: string (* The "kind" of the C compiler, assembler and linker used: one of "cc" (for Unix-style C compilers) "msvc" (for Microsoft Visual C++ and MASM) *) val bytecomp_c_compiler: string (* The C compiler to use for compiling C files with the bytecode compiler *) val bytecomp_c_libraries: string (* The C libraries to link with custom runtimes *) val native_c_compiler: string (* The C compiler to use for compiling C files with the native-code compiler *) val native_c_libraries: string (* The C libraries to link with native-code programs *) val native_pack_linker: string (* The linker to use for packaging (ocamlopt -pack) and for partial links (ocamlopt -output-obj). *) val mkdll: string (* The linker command line to build dynamic libraries. *) val mkexe: string (* The linker command line to build executables. *) val mkmaindll: string (* The linker command line to build main programs as dlls. *) val ranlib: string (* Command to randomize a library, or "" if not needed *) val ar: string (* Name of the ar command, or "" if not needed (MSVC) *) val cc_profile : string (* The command line option to the C compiler to enable profiling. *) val load_path: string list ref (* Directories in the search path for .cmi and .cmo files *) val interface_suffix: string ref (* Suffix for interface file names *) val exec_magic_number: string (* Magic number for bytecode executable files *) val cmi_magic_number: string (* Magic number for compiled interface files *) val cmo_magic_number: string (* Magic number for object bytecode files *) val cma_magic_number: string (* Magic number for archive files *) val cmx_magic_number: string (* Magic number for compilation unit descriptions *) val cmxa_magic_number: string (* Magic number for libraries of compilation unit descriptions *) val ast_intf_magic_number: string (* Magic number for file holding an interface syntax tree *) val ast_impl_magic_number: string (* Magic number for file holding an implementation syntax tree *) val cmxs_magic_number: string (* Magic number for dynamically-loadable plugins *) val cmt_magic_number: string (* Magic number for compiled interface files *) val max_tag: int (* Biggest tag that can be stored in the header of a regular block. *) val lazy_tag : int (* Normally the same as Obj.lazy_tag. Separate definition because of technical reasons for bootstrapping. *) val max_young_wosize: int (* Maximal size of arrays that are directly allocated in the minor heap *) val stack_threshold: int (* Size in words of safe area at bottom of VM stack, see byterun/config.h *) val architecture: string (* Name of processor type for the native-code compiler *) val model: string (* Name of processor submodel for the native-code compiler *) val system: string (* Name of operating system for the native-code compiler *) val asm: string (* The assembler (and flags) to use for assembling ocamlopt-generated code. *) val asm_cfi_supported: bool (* Whether assembler understands CFI directives *) val ext_obj: string (* Extension for object files, e.g. [.o] under Unix. *) val ext_asm: string (* Extension for assembler files, e.g. [.s] under Unix. *) val ext_lib: string (* Extension for library files, e.g. [.a] under Unix. *) val ext_dll: string (* Extension for dynamically-loaded libraries, e.g. [.so] under Unix.*) val default_executable_name: string (* Name of executable produced by linking if none is given with -o, e.g. [a.out] under Unix. *) val systhread_supported : bool (* Whether the system thread library is implemented *) val print_config : out_channel -> unit;; mingw-ocaml/ocaml/utils/tbl.ml0000644000175000017500000000650612124403240015737 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) type ('a, 'b) t = Empty | Node of ('a, 'b) t * 'a * 'b * ('a, 'b) t * int let empty = Empty let height = function Empty -> 0 | Node(_,_,_,_,h) -> h let create l x d r = let hl = height l and hr = height r in Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let bal l x d r = let hl = height l and hr = height r in if hl > hr + 1 then match l with | Node (ll, lv, ld, lr, _) when height ll >= height lr -> create ll lv ld (create lr x d r) | Node (ll, lv, ld, Node (lrl, lrv, lrd, lrr, _), _) -> create (create ll lv ld lrl) lrv lrd (create lrr x d r) | _ -> assert false else if hr > hl + 1 then match r with | Node (rl, rv, rd, rr, _) when height rr >= height rl -> create (create l x d rl) rv rd rr | Node (Node (rll, rlv, rld, rlr, _), rv, rd, rr, _) -> create (create l x d rll) rlv rld (create rlr rv rd rr) | _ -> assert false else create l x d r let rec add x data = function Empty -> Node(Empty, x, data, Empty, 1) | Node(l, v, d, r, h) -> let c = compare x v in if c = 0 then Node(l, x, data, r, h) else if c < 0 then bal (add x data l) v d r else bal l v d (add x data r) let rec find x = function Empty -> raise Not_found | Node(l, v, d, r, _) -> let c = compare x v in if c = 0 then d else find x (if c < 0 then l else r) let rec mem x = function Empty -> false | Node(l, v, d, r, _) -> let c = compare x v in c = 0 || mem x (if c < 0 then l else r) let rec merge t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (Node(l1, v1, d1, r1, h1), Node(l2, v2, d2, r2, h2)) -> bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2) let rec remove x = function Empty -> Empty | Node(l, v, d, r, h) -> let c = compare x v in if c = 0 then merge l r else if c < 0 then bal (remove x l) v d r else bal l v d (remove x r) let rec iter f = function Empty -> () | Node(l, v, d, r, _) -> iter f l; f v d; iter f r let rec map f = function Empty -> Empty | Node(l, v, d, r, h) -> Node(map f l, v, f v d, map f r, h) let rec fold f m accu = match m with | Empty -> accu | Node(l, v, d, r, _) -> fold f r (f v d (fold f l accu)) open Format let print print_key print_data ppf tbl = let print_tbl ppf tbl = iter (fun k d -> fprintf ppf "@[<2>%a ->@ %a;@]@ " print_key k print_data d) tbl in fprintf ppf "@[[[%a]]@]" print_tbl tbl mingw-ocaml/ocaml/utils/warnings.mli0000644000175000017500000000635412124403240017160 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis && Damien Doligez, INRIA Rocquencourt *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Format type t = | Comment_start (* 1 *) | Comment_not_end (* 2 *) | Deprecated (* 3 *) | Fragile_match of string (* 4 *) | Partial_application (* 5 *) | Labels_omitted (* 6 *) | Method_override of string list (* 7 *) | Partial_match of string (* 8 *) | Non_closed_record_pattern of string (* 9 *) | Statement_type (* 10 *) | Unused_match (* 11 *) | Unused_pat (* 12 *) | Instance_variable_override of string list (* 13 *) | Illegal_backslash (* 14 *) | Implicit_public_methods of string list (* 15 *) | Unerasable_optional_argument (* 16 *) | Undeclared_virtual_method of string (* 17 *) | Not_principal of string (* 18 *) | Without_principality of string (* 19 *) | Unused_argument (* 20 *) | Nonreturning_statement (* 21 *) | Camlp4 of string (* 22 *) | Useless_record_with (* 23 *) | Bad_module_name of string (* 24 *) | All_clauses_guarded (* 25 *) | Unused_var of string (* 26 *) | Unused_var_strict of string (* 27 *) | Wildcard_arg_to_constant_constr (* 28 *) | Eol_in_string (* 29 *) | Duplicate_definitions of string * string * string * string (*30 *) | Multiple_definition of string * string * string (* 31 *) | Unused_value_declaration of string (* 32 *) | Unused_open of string (* 33 *) | Unused_type_declaration of string (* 34 *) | Unused_for_index of string (* 35 *) | Unused_ancestor of string (* 36 *) | Unused_constructor of string * bool * bool (* 37 *) | Unused_exception of string * bool (* 38 *) | Unused_rec_flag (* 39 *) ;; val parse_options : bool -> string -> unit;; val is_active : t -> bool;; val is_error : t -> bool;; val defaults_w : string;; val defaults_warn_error : string;; val print : formatter -> t -> int;; (* returns the number of newlines in the printed string *) exception Errors of int;; val check_fatal : unit -> unit;; val help_warnings: unit -> unit mingw-ocaml/ocaml/utils/misc.ml0000644000175000017500000001367012124403240016111 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Errors *) exception Fatal_error let fatal_error msg = prerr_string ">> Fatal error: "; prerr_endline msg; raise Fatal_error (* Exceptions *) let try_finally work cleanup = let result = (try work () with e -> cleanup (); raise e) in cleanup (); result ;; (* List functions *) let rec map_end f l1 l2 = match l1 with [] -> l2 | hd::tl -> f hd :: map_end f tl l2 let rec map_left_right f = function [] -> [] | hd::tl -> let res = f hd in res :: map_left_right f tl let rec for_all2 pred l1 l2 = match (l1, l2) with ([], []) -> true | (hd1::tl1, hd2::tl2) -> pred hd1 hd2 && for_all2 pred tl1 tl2 | (_, _) -> false let rec replicate_list elem n = if n <= 0 then [] else elem :: replicate_list elem (n-1) let rec list_remove x = function [] -> [] | hd :: tl -> if hd = x then tl else hd :: list_remove x tl let rec split_last = function [] -> assert false | [x] -> ([], x) | hd :: tl -> let (lst, last) = split_last tl in (hd :: lst, last) let rec samelist pred l1 l2 = match (l1, l2) with | ([], []) -> true | (hd1 :: tl1, hd2 :: tl2) -> pred hd1 hd2 && samelist pred tl1 tl2 | (_, _) -> false (* Options *) let may f = function Some x -> f x | None -> () let may_map f = function Some x -> Some (f x) | None -> None (* File functions *) let find_in_path path name = if not (Filename.is_implicit name) then if Sys.file_exists name then name else raise Not_found else begin let rec try_dir = function [] -> raise Not_found | dir::rem -> let fullname = Filename.concat dir name in if Sys.file_exists fullname then fullname else try_dir rem in try_dir path end let find_in_path_uncap path name = let uname = String.uncapitalize name in let rec try_dir = function [] -> raise Not_found | dir::rem -> let fullname = Filename.concat dir name and ufullname = Filename.concat dir uname in if Sys.file_exists ufullname then ufullname else if Sys.file_exists fullname then fullname else try_dir rem in try_dir path let remove_file filename = try Sys.remove filename with Sys_error msg -> () (* Expand a -I option: if it starts with +, make it relative to the standard library directory *) let expand_directory alt s = if String.length s > 0 && s.[0] = '+' then Filename.concat alt (String.sub s 1 (String.length s - 1)) else s (* Hashtable functions *) let create_hashtable size init = let tbl = Hashtbl.create size in List.iter (fun (key, data) -> Hashtbl.add tbl key data) init; tbl (* File copy *) let copy_file ic oc = let buff = String.create 0x1000 in let rec copy () = let n = input ic buff 0 0x1000 in if n = 0 then () else (output oc buff 0 n; copy()) in copy() let copy_file_chunk ic oc len = let buff = String.create 0x1000 in let rec copy n = if n <= 0 then () else begin let r = input ic buff 0 (min n 0x1000) in if r = 0 then raise End_of_file else (output oc buff 0 r; copy(n-r)) end in copy len let string_of_file ic = let b = Buffer.create 0x10000 in let buff = String.create 0x1000 in let rec copy () = let n = input ic buff 0 0x1000 in if n = 0 then Buffer.contents b else (Buffer.add_substring b buff 0 n; copy()) in copy() (* Reading from a channel *) let input_bytes ic n = let result = String.create n in really_input ic result 0 n; result ;; (* Integer operations *) let rec log2 n = if n <= 1 then 0 else 1 + log2(n asr 1) let align n a = if n >= 0 then (n + a - 1) land (-a) else n land (-a) let no_overflow_add a b = (a lxor b) lor (a lxor (lnot (a+b))) < 0 let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0 let no_overflow_lsl a = min_int asr 1 <= a && a <= max_int asr 1 (* String operations *) let chop_extension_if_any fname = try Filename.chop_extension fname with Invalid_argument _ -> fname let chop_extensions file = let dirname = Filename.dirname file and basename = Filename.basename file in try let pos = String.index basename '.' in let basename = String.sub basename 0 pos in if Filename.is_implicit file && dirname = Filename.current_dir_name then basename else Filename.concat dirname basename with Not_found -> file let search_substring pat str start = let rec search i j = if j >= String.length pat then i else if i + j >= String.length str then raise Not_found else if str.[i + j] = pat.[j] then search i (j+1) else search (i+1) 0 in search start 0 let rev_split_words s = let rec split1 res i = if i >= String.length s then res else begin match s.[i] with ' ' | '\t' | '\r' | '\n' -> split1 res (i+1) | _ -> split2 res i (i+1) end and split2 res i j = if j >= String.length s then String.sub s i (j-i) :: res else begin match s.[j] with ' ' | '\t' | '\r' | '\n' -> split1 (String.sub s i (j-i) :: res) (j+1) | _ -> split2 res i (j+1) end in split1 [] 0 let get_ref r = let v = !r in r := []; v let fst3 (x, _, _) = x let snd3 (_,x,_) = x let thd3 (_,_,x) = x let fst4 (x, _, _, _) = x let snd4 (_,x,_, _) = x let thd4 (_,_,x,_) = x mingw-ocaml/ocaml/utils/consistbl.mli0000644000175000017500000000517012124403240017323 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Consistency tables: for checking consistency of module CRCs *) type t val create: unit -> t val clear: t -> unit val check: t -> string -> Digest.t -> string -> unit (* [check tbl name crc source] checks consistency of ([name], [crc]) with infos previously stored in [tbl]. If no CRC was previously associated with [name], record ([name], [crc]) in [tbl]. [source] is the name of the file from which the information comes from. This is used for error reporting. *) val check_noadd: t -> string -> Digest.t -> string -> unit (* Same as [check], but raise [Not_available] if no CRC was previously associated with [name]. *) val set: t -> string -> Digest.t -> string -> unit (* [set tbl name crc source] forcefully associates [name] with [crc] in [tbl], even if [name] already had a different CRC associated with [name] in [tbl]. *) val source: t -> string -> string (* [source tbl name] returns the file name associated with [name] if the latter has an associated CRC in [tbl]. Raise [Not_found] otherwise. *) val extract: t -> (string * Digest.t) list (* Return all bindings ([name], [crc]) contained in the given table. *) val filter: (string -> bool) -> t -> unit (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs such that [pred name] is [false]. *) exception Inconsistency of string * string * string (* Raised by [check] when a CRC mismatch is detected. First string is the name of the compilation unit. Second string is the source that caused the inconsistency. Third string is the source that set the CRC. *) exception Not_available of string (* Raised by [check_noadd] when a name doesn't have an associated CRC. *) mingw-ocaml/ocaml/utils/terminfo.mli0000644000175000017500000000231012124403240017137 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Basic interface to the terminfo database *) type status = | Uninitialised | Bad_term | Good_term of int (* number of lines of the terminal *) ;; external setup : out_channel -> status = "caml_terminfo_setup";; external backup : int -> unit = "caml_terminfo_backup";; external standout : bool -> unit = "caml_terminfo_standout";; external resume : int -> unit = "caml_terminfo_resume";; mingw-ocaml/ocaml/utils/misc.mli0000644000175000017500000001324212124403240016255 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Miscellaneous useful types and functions *) val fatal_error: string -> 'a exception Fatal_error val try_finally : (unit -> 'a) -> (unit -> unit) -> 'a;; val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list (* [map_end f l t] is [map f l @ t], just more efficient. *) val map_left_right: ('a -> 'b) -> 'a list -> 'b list (* Like [List.map], with guaranteed left-to-right evaluation order *) val for_all2: ('a -> 'b -> bool) -> 'a list -> 'b list -> bool (* Same as [List.for_all] but for a binary predicate. In addition, this [for_all2] never fails: given two lists with different lengths, it returns false. *) val replicate_list: 'a -> int -> 'a list (* [replicate_list elem n] is the list with [n] elements all identical to [elem]. *) val list_remove: 'a -> 'a list -> 'a list (* [list_remove x l] returns a copy of [l] with the first element equal to [x] removed. *) val split_last: 'a list -> 'a list * 'a (* Return the last element and the other elements of the given list. *) val samelist: ('a -> 'a -> bool) -> 'a list -> 'a list -> bool (* Like [List.for_all2] but returns [false] if the two lists have different length. *) val may: ('a -> unit) -> 'a option -> unit val may_map: ('a -> 'b) -> 'a option -> 'b option val find_in_path: string list -> string -> string (* Search a file in a list of directories. *) val find_in_path_uncap: string list -> string -> string (* Same, but search also for uncapitalized name, i.e. if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml to match. *) val remove_file: string -> unit (* Delete the given file if it exists. Never raise an error. *) val expand_directory: string -> string -> string (* [expand_directory alt file] eventually expands a [+] at the beginning of file into [alt] (an alternate root directory) *) val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t (* Create a hashtable of the given size and fills it with the given bindings. *) val copy_file: in_channel -> out_channel -> unit (* [copy_file ic oc] reads the contents of file [ic] and copies them to [oc]. It stops when encountering EOF on [ic]. *) val copy_file_chunk: in_channel -> out_channel -> int -> unit (* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies them to [oc]. It raises [End_of_file] when encountering EOF on [ic]. *) val string_of_file: in_channel -> string (* [string_of_file ic] reads the contents of file [ic] and copies them to a string. It stops when encountering EOF on [ic]. *) val input_bytes : in_channel -> int -> string;; (* [input_bytes ic n] reads [n] bytes from [ic] and returns them in a new string. It raises [End_of_file] if EOF is encountered before all the bytes are read. *) val log2: int -> int (* [log2 n] returns [s] such that [n = 1 lsl s] if [n] is a power of 2*) val align: int -> int -> int (* [align n a] rounds [n] upwards to a multiple of [a] (a power of 2). *) val no_overflow_add: int -> int -> bool (* [no_overflow_add n1 n2] returns [true] if the computation of [n1 + n2] does not overflow. *) val no_overflow_sub: int -> int -> bool (* [no_overflow_add n1 n2] returns [true] if the computation of [n1 - n2] does not overflow. *) val no_overflow_lsl: int -> bool (* [no_overflow_add n] returns [true] if the computation of [n lsl 1] does not overflow. *) val chop_extension_if_any: string -> string (* Like Filename.chop_extension but returns the initial file name if it has no extension *) val chop_extensions: string -> string (* Return the given file name without its extensions. The extensions is the longest suffix starting with a period and not including a directory separator, [.xyz.uvw] for instance. Return the given name if it does not contain an extension. *) val search_substring: string -> string -> int -> int (* [search_substring pat str start] returns the position of the first occurrence of string [pat] in string [str]. Search starts at offset [start] in [str]. Raise [Not_found] if [pat] does not occur. *) val rev_split_words: string -> string list (* [rev_split_words s] splits [s] in blank-separated words, and return the list of words in reverse order. *) val get_ref: 'a list ref -> 'a list (* [get_ref lr] returns the content of the list reference [lr] and reset its content to the empty list. *) val fst3: 'a * 'b * 'c -> 'a val snd3: 'a * 'b * 'c -> 'b val thd3: 'a * 'b * 'c -> 'c val fst4: 'a * 'b * 'c * 'd -> 'a val snd4: 'a * 'b * 'c * 'd -> 'b val thd4: 'a * 'b * 'c * 'd -> 'c mingw-ocaml/ocaml/utils/config.mlp0000644000175000017500000001040012124403240016567 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (***********************************************************************) (** **) (** WARNING WARNING WARNING **) (** **) (** When you change this file, you must make the parallel change **) (** in config.mlbuild **) (** **) (***********************************************************************) (* The main OCaml version string has moved to ../VERSION *) let version = Sys.ocaml_version let standard_library_default = "%%LIBDIR%%" let standard_library = try Sys.getenv "OCAMLLIB" with Not_found -> try Sys.getenv "CAMLLIB" with Not_found -> standard_library_default let standard_runtime = "%%BYTERUN%%" let ccomp_type = "%%CCOMPTYPE%%" let bytecomp_c_compiler = "%%BYTECC%%" let bytecomp_c_libraries = "%%BYTECCLIBS%%" let native_c_compiler = "%%NATIVECC%%" let native_c_libraries = "%%NATIVECCLIBS%%" let native_pack_linker = "%%PACKLD%%" let ranlib = "%%RANLIBCMD%%" let ar = "%%ARCMD%%" let cc_profile = "%%CC_PROFILE%%" let mkdll = "%%MKDLL%%" let mkexe = "%%MKEXE%%" let mkmaindll = "%%MKMAINDLL%%" let exec_magic_number = "Caml1999X008" and cmi_magic_number = "Caml1999I014" and cmo_magic_number = "Caml1999O007" and cma_magic_number = "Caml1999A008" and cmx_magic_number = "Caml1999Y011" and cmxa_magic_number = "Caml1999Z010" and ast_impl_magic_number = "Caml1999M015" and ast_intf_magic_number = "Caml1999N014" and cmxs_magic_number = "Caml2007D001" and cmt_magic_number = "Caml2012T001" let load_path = ref ([] : string list) let interface_suffix = ref ".mli" let max_tag = 245 (* This is normally the same as in obj.ml, but we have to define it separately because it can differ when we're in the middle of a bootstrapping phase. *) let lazy_tag = 246 let max_young_wosize = 256 let stack_threshold = 256 (* see byterun/config.h *) let architecture = "%%ARCH%%" let model = "%%MODEL%%" let system = "%%SYSTEM%%" let asm = "%%ASM%%" let asm_cfi_supported = %%ASM_CFI_SUPPORTED%% let ext_obj = "%%EXT_OBJ%%" let ext_asm = "%%EXT_ASM%%" let ext_lib = "%%EXT_LIB%%" let ext_dll = "%%EXT_DLL%%" let default_executable_name = match Sys.os_type with "Unix" -> "a.out" | "Win32" | "Cygwin" -> "camlprog.exe" | _ -> "camlprog" let systhread_supported = %%SYSTHREAD_SUPPORT%%;; let print_config oc = let p name valu = Printf.fprintf oc "%s: %s\n" name valu in let p_bool name valu = Printf.fprintf oc "%s: %B\n" name valu in p "version" version; p "standard_library_default" standard_library_default; p "standard_library" standard_library; p "standard_runtime" standard_runtime; p "ccomp_type" ccomp_type; p "bytecomp_c_compiler" bytecomp_c_compiler; p "bytecomp_c_libraries" bytecomp_c_libraries; p "native_c_compiler" native_c_compiler; p "native_c_libraries" native_c_libraries; p "native_pack_linker" native_pack_linker; p "ranlib" ranlib; p "cc_profile" cc_profile; p "architecture" architecture; p "model" model; p "system" system; p "asm" asm; p_bool "asm_cfi_supported" asm_cfi_supported; p "ext_obj" ext_obj; p "ext_asm" ext_asm; p "ext_lib" ext_lib; p "ext_dll" ext_dll; p "os_type" Sys.os_type; p "default_executable_name" default_executable_name; p_bool "systhread_supported" systhread_supported; flush oc; ;; mingw-ocaml/ocaml/utils/clflags.ml0000644000175000017500000001137212124403240016566 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Command-line parameters *) let objfiles = ref ([] : string list) (* .cmo and .cma files *) and ccobjs = ref ([] : string list) (* .o, .a, .so and -cclib -lxxx *) and dllibs = ref ([] : string list) (* .so and -dllib -lxxx *) let compile_only = ref false (* -c *) and output_name = ref (None : string option) (* -o *) and include_dirs = ref ([] : string list)(* -I *) and no_std_include = ref false (* -nostdlib *) and print_types = ref false (* -i *) and make_archive = ref false (* -a *) and debug = ref false (* -g *) and fast = ref false (* -unsafe *) and link_everything = ref false (* -linkall *) and custom_runtime = ref false (* -custom *) and output_c_object = ref false (* -output-obj *) and ccopts = ref ([] : string list) (* -ccopt *) and classic = ref false (* -nolabels *) and nopervasives = ref false (* -nopervasives *) and preprocessor = ref(None : string option) (* -pp *) let annotations = ref false (* -annot *) let binary_annotations = ref false (* -annot *) and use_threads = ref false (* -thread *) and use_vmthreads = ref false (* -vmthread *) and noassert = ref false (* -noassert *) and verbose = ref false (* -verbose *) and noprompt = ref false (* -noprompt *) and nopromptcont = ref false (* -nopromptcont *) and init_file = ref (None : string option) (* -init *) and use_prims = ref "" (* -use-prims ... *) and use_runtime = ref "" (* -use-runtime ... *) and principal = ref false (* -principal *) and recursive_types = ref false (* -rectypes *) and strict_sequence = ref false (* -strict-sequence *) and applicative_functors = ref true (* -no-app-funct *) and make_runtime = ref false (* -make-runtime *) and gprofile = ref false (* -p *) and c_compiler = ref (None: string option) (* -cc *) and no_auto_link = ref false (* -noautolink *) and dllpaths = ref ([] : string list) (* -dllpath *) and make_package = ref false (* -pack *) and for_package = ref (None: string option) (* -for-pack *) and error_size = ref 500 (* -error-size *) let dump_parsetree = ref false (* -dparsetree *) and dump_rawlambda = ref false (* -drawlambda *) and dump_lambda = ref false (* -dlambda *) and dump_clambda = ref false (* -dclambda *) and dump_instr = ref false (* -dinstr *) let keep_asm_file = ref false (* -S *) let optimize_for_speed = ref true (* -compact *) and dump_cmm = ref false (* -dcmm *) let dump_selection = ref false (* -dsel *) let dump_live = ref false (* -dlive *) let dump_spill = ref false (* -dspill *) let dump_split = ref false (* -dsplit *) let dump_scheduling = ref false (* -dscheduling *) let dump_interf = ref false (* -dinterf *) let dump_prefer = ref false (* -dprefer *) let dump_regalloc = ref false (* -dalloc *) let dump_reload = ref false (* -dreload *) let dump_scheduling = ref false (* -dscheduling *) let dump_linear = ref false (* -dlinear *) let keep_startup_file = ref false (* -dstartup *) let dump_combine = ref false (* -dcombine *) let native_code = ref false (* set to true under ocamlopt *) let inline_threshold = ref 10 let dont_write_files = ref false (* set to true under ocamldoc *) let std_include_flag prefix = if !no_std_include then "" else (prefix ^ (Filename.quote Config.standard_library)) ;; let std_include_dir () = if !no_std_include then [] else [Config.standard_library] ;; let shared = ref false (* -shared *) let dlcode = ref true (* not -nodynlink *) let runtime_variant = ref "";; (* -runtime-variant *) mingw-ocaml/ocaml/utils/ccomp.mli0000644000175000017500000000244212124403240016423 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Compiling C files and building C libraries *) val command: string -> int val run_command: string -> unit val compile_file: string -> int val create_archive: string -> string list -> int val expand_libname: string -> string val quote_files: string list -> string val quote_optfile: string option -> string (*val make_link_options: string list -> string*) type link_mode = | Exe | Dll | MainDll | Partial val call_linker: link_mode -> string -> string list -> string -> bool mingw-ocaml/ocaml/utils/ccomp.ml0000644000175000017500000001010112124403240016241 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Compiling C files and building C libraries *) let command cmdline = if !Clflags.verbose then begin prerr_string "+ "; prerr_string cmdline; prerr_newline() end; Sys.command cmdline let run_command cmdline = ignore(command cmdline) (* Build @responsefile to work around Windows limitations on command-line length *) let build_diversion lst = let (responsefile, oc) = Filename.open_temp_file "camlresp" "" in List.iter (fun f -> Printf.fprintf oc "%s\n" f) lst; close_out oc; at_exit (fun () -> Misc.remove_file responsefile); "@" ^ responsefile let quote_files lst = let lst = List.filter (fun f -> f <> "") lst in let quoted = List.map Filename.quote lst in let s = String.concat " " quoted in if String.length s >= 4096 && Sys.os_type = "Win32" then build_diversion quoted else s let quote_prefixed pr lst = let lst = List.filter (fun f -> f <> "") lst in let lst = List.map (fun f -> pr ^ f) lst in quote_files lst let quote_optfile = function | None -> "" | Some f -> Filename.quote f let compile_file name = command (Printf.sprintf "%s -c %s %s %s %s" (match !Clflags.c_compiler with | Some cc -> cc | None -> if !Clflags.native_code then Config.native_c_compiler else Config.bytecomp_c_compiler) (String.concat " " (List.rev !Clflags.ccopts)) (quote_prefixed "-I" (List.rev !Clflags.include_dirs)) (Clflags.std_include_flag "-I") (Filename.quote name)) let create_archive archive file_list = Misc.remove_file archive; let quoted_archive = Filename.quote archive in match Config.ccomp_type with "msvc" -> command(Printf.sprintf "link /lib /nologo /out:%s %s" quoted_archive (quote_files file_list)) | _ -> assert(String.length Config.ar > 0); let r1 = command(Printf.sprintf "%s rc %s %s" Config.ar quoted_archive (quote_files file_list)) in if r1 <> 0 || String.length Config.ranlib = 0 then r1 else command(Config.ranlib ^ " " ^ quoted_archive) let expand_libname name = if String.length name < 2 || String.sub name 0 2 <> "-l" then name else begin let libname = "lib" ^ String.sub name 2 (String.length name - 2) ^ Config.ext_lib in try Misc.find_in_path !Config.load_path libname with Not_found -> libname end type link_mode = | Exe | Dll | MainDll | Partial let call_linker mode output_name files extra = let files = quote_files files in let cmd = if mode = Partial then Printf.sprintf "%s%s %s %s" Config.native_pack_linker (Filename.quote output_name) files extra else Printf.sprintf "%s -o %s %s %s %s %s %s %s" (match !Clflags.c_compiler, mode with | Some cc, _ -> cc | None, Exe -> Config.mkexe | None, Dll -> Config.mkdll | None, MainDll -> Config.mkmaindll | None, Partial -> assert false ) (Filename.quote output_name) (if !Clflags.gprofile then Config.cc_profile else "") "" (*(Clflags.std_include_flag "-I")*) (quote_prefixed "-L" !Config.load_path) (String.concat " " (List.rev !Clflags.ccopts)) files extra in command cmd = 0 mingw-ocaml/ocaml/Makefile.nt0000644000175000017500000005177512124403240015554 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # $Id$ # The main Makefile include config/Makefile include stdlib/StdlibModules CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink COMPFLAGS=-strict-sequence -warn-error A $(INCLUDES) LINKFLAGS= CAMLYACC=boot/ocamlyacc YACCFLAGS= CAMLLEX=boot/ocamlrun boot/ocamllex CAMLDEP=boot/ocamlrun tools/ocamldep DEPFLAGS=$(INCLUDES) CAMLRUN=byterun/ocamlrun CAMLP4OUT=$(CAMLP4:=out) CAMLP4OPT=$(CAMLP4:=opt) INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \ -I toplevel UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ utils/consistbl.cmo PARSING=parsing/location.cmo parsing/longident.cmo \ parsing/syntaxerr.cmo parsing/parser.cmo \ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo TYPING=typing/ident.cmo typing/path.cmo \ typing/primitive.cmo typing/types.cmo \ typing/btype.cmo typing/oprint.cmo \ typing/subst.cmo typing/predef.cmo \ typing/datarepr.cmo typing/cmi_format.cmo typing/env.cmo \ typing/typedtree.cmo typing/ctype.cmo \ typing/printtyp.cmo typing/includeclass.cmo \ typing/mtype.cmo typing/includecore.cmo \ typing/includemod.cmo typing/parmatch.cmo \ typing/typetexp.cmo \ typing/cmt_format.cmo typing/stypes.cmo typing/typecore.cmo \ typing/typedecl.cmo typing/typeclass.cmo \ typing/typemod.cmo COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \ bytecomp/translobj.cmo bytecomp/translcore.cmo \ bytecomp/translclass.cmo bytecomp/translmod.cmo \ bytecomp/simplif.cmo bytecomp/runtimedef.cmo \ driver/pparse.cmo driver/main_args.cmo COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP) BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \ bytecomp/printinstr.cmo bytecomp/opcodes.cmo bytecomp/emitcode.cmo \ bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \ bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo \ driver/errors.cmo driver/compile.cmo ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ asmcomp/clambda.cmo asmcomp/compilenv.cmo \ asmcomp/closure.cmo asmcomp/cmmgen.cmo \ asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ asmcomp/comballoc.cmo asmcomp/liveness.cmo \ asmcomp/spill.cmo asmcomp/split.cmo \ asmcomp/interf.cmo asmcomp/coloring.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \ driver/opterrors.cmo driver/optcompile.cmo TOPLEVEL=toplevel/genprintval.cmo toplevel/toploop.cmo \ toplevel/trace.cmo toplevel/topdirs.cmo toplevel/topmain.cmo BYTESTART=driver/main.cmo OPTSTART=driver/optmain.cmo TOPLEVELSTART=toplevel/topstart.cmo PERVASIVES=$(STDLIB_MODULES) topdirs toploop outcometree # For users who don't read the INSTALL file defaultentry: @echo "Please refer to the installation instructions in file README.win32." # Recompile the system using the bootstrap compiler all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \ otherlibraries ocamldoc.byte ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) # The compilation of ocaml will fail if the runtime has changed. # Never mind, just do make bootstrap to reach fixpoint again. # Compile everything the first time world: coldstart all # Complete bootstrapping cycle bootstrap: # Save the original bootstrap compiler $(MAKEREC) backup # Promote the new compiler but keep the old runtime # This compiler runs on boot/ocamlrun and produces bytecode for byterun/ocamlrun $(MAKEREC) promote-cross # Rebuild ocamlc and ocamllex (run on byterun/ocamlrun) $(MAKEREC) partialclean $(MAKEREC) ocamlc ocamllex ocamltools # Rebuild the library (using byterun/ocamlrun ./ocamlc) $(MAKEREC) library-cross # Promote the new compiler and the new runtime $(MAKEREC) promote # Rebuild everything, including ocaml and the tools $(MAKEREC) partialclean $(MAKEREC) all # Check if fixpoint reached $(MAKEREC) compare LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader # Start up the system from the distribution compiler coldstart: cd byterun ; $(MAKEREC) all cp byterun/ocamlrun.exe boot/ocamlrun.exe cd yacc ; $(MAKEREC) all cp yacc/ocamlyacc.exe boot/ocamlyacc.exe cd stdlib ; $(MAKEREC) COMPILER=../boot/ocamlc all cd stdlib ; cp $(LIBFILES) ../boot # Build the core system: the minimum needed to make depend and bootstrap core : runtime ocamlc ocamllex ocamlyacc ocamltools library # Save the current bootstrap compiler MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev backup: mkdir -p boot/Saved if test -d $(MAXSAVED); then rm -r $(MAXSAVED); fi mv boot/Saved boot/Saved.prev mkdir boot/Saved mv boot/Saved.prev boot/Saved/Saved.prev cp boot/ocamlrun.exe boot/Saved/ocamlrun.exe cd boot ; mv ocamlc ocamllex ocamldep ocamlyacc.exe Saved cd boot ; cp $(LIBFILES) Saved # Promote the newly compiled system to the rank of cross compiler # (Runs on the old runtime, produces code for the new runtime) promote-cross: cp ocamlc boot/ocamlc cp lex/ocamllex boot/ocamllex cp yacc/ocamlyacc.exe boot/ocamlyacc.exe cp tools/ocamldep boot/ocamldep cd stdlib ; cp $(LIBFILES) ../boot # Promote the newly compiled system to the rank of bootstrap compiler # (Runs on the new runtime, produces code for the new runtime) promote: promote-cross cp byterun/ocamlrun.exe boot/ocamlrun.exe # Restore the saved bootstrap compiler if a problem arises restore: cd boot/Saved ; mv * .. rmdir boot/Saved mv boot/Saved.prev boot/Saved # Check if fixpoint reached compare: - cmp -i 4096 boot/ocamlc ocamlc - cmp -i 4096 boot/ocamllex lex/ocamllex - cmp -i 4096 boot/ocamldep tools/ocamldep # Remove old bootstrap compilers cleanboot: rm -rf boot/Saved/Saved.prev/* # Compile the native-code compiler opt-core: runtimeopt ocamlopt libraryopt opt: opt-core otherlibrariesopt ocamlbuildlib.native # Native-code versions of the tools opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \ ocamltoolsopt.opt ocamlbuild.native $(CAMLP4OPT) ocamldoc.opt # Complete build using fast compilers world.opt: coldstart opt.opt # Installation COMPLIBDIR=$(LIBDIR)/compiler-libs install: installbyt installopt installbyt: mkdir -p $(BINDIR) mkdir -p $(LIBDIR) mkdir -p $(COMPLIBDIR) cd byterun ; $(MAKEREC) install cp ocamlc $(BINDIR)/ocamlc.exe cp ocaml $(BINDIR)/ocaml.exe cd stdlib ; $(MAKEREC) install cp lex/ocamllex $(BINDIR)/ocamllex.exe cp yacc/ocamlyacc.exe $(BINDIR)/ocamlyacc.exe cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi toplevel/*.cmi $(COMPLIBDIR) cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) $(COMPLIBDIR) cp expunge $(LIBDIR)/expunge.exe cp toplevel/topdirs.cmi $(LIBDIR) cd tools ; $(MAKEREC) install cd ocamldoc ; $(MAKEREC) install mkdir -p $(STUBLIBDIR) for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done if test -f debugger/ocamldebug.exe; then (cd debugger; $(MAKEREC) install); \ else :; fi ./build/partial-install.sh cp config/Makefile $(LIBDIR)/Makefile.config cp README $(DISTRIB)/Readme.general.txt cp README.win32 $(DISTRIB)/Readme.windows.txt cp LICENSE $(DISTRIB)/License.txt cp Changes $(DISTRIB)/Changes.txt # Installation of the native-code compiler installopt: cd asmrun ; $(MAKEREC) install cp ocamlopt $(BINDIR)/ocamlopt.exe cd stdlib ; $(MAKEREC) installopt cp asmcomp/*.cmi driver/*.cmi $(COMPLIBDIR) cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(COMPLIBDIR) cd ocamldoc ; $(MAKEREC) installopt for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i installopt; done if test -f ocamlopt.opt ; then $(MAKEREC) installoptopt; fi installoptopt: cp ocamlc.opt $(BINDIR)/ocamlc.opt$(EXE) cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE) cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE) cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \ compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \ compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) \ $(COMPLIBDIR) clean:: partialclean # The compiler compilerlibs/ocamlcommon.cma: $(COMMON) $(CAMLC) -a -o $@ $(COMMON) partialclean:: rm -f compilerlibs/ocamlcommon.cma # The bytecode compiler compilerlibs/ocamlbytecomp.cma: $(BYTECOMP) $(CAMLC) -a -o $@ $(BYTECOMP) partialclean:: rm -f compilerlibs/ocamlbytecomp.cma ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) $(CAMLC) $(LINKFLAGS) -o ocamlc \ compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \ driver/ocamlcomp.sh.in > ocamlcomp.sh @chmod +x ocamlcomp.sh partialclean:: rm -f ocamlc ocamlcomp.sh # The native-code compiler compilerlibs/ocamloptcomp.cma: $(ASMCOMP) $(CAMLC) -a -o $@ $(ASMCOMP) partialclean:: rm -f compilerlibs/ocamloptcomp.cma ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) $(CAMLC) $(LINKFLAGS) -o ocamlopt \ compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \ driver/ocamlcomp.sh.in > ocamlcompopt.sh @chmod +x ocamlcompopt.sh partialclean:: rm -f ocamlopt ocamlcompopt.sh # The toplevel compilerlibs/ocamltoplevel.cma: $(TOPLEVEL) $(CAMLC) -a -o $@ $(TOPLEVEL) partialclean:: rm -f compilerlibs/ocamltoplevel.cma ocaml: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) expunge $(CAMLC) $(LINKFLAGS) -linkall -o ocaml.tmp \ compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ compilerlibs/ocamltoplevel.cma $(TOPLEVELSTART) - $(CAMLRUN) ./expunge ocaml.tmp ocaml $(PERVASIVES) rm -f ocaml.tmp partialclean:: rm -f ocaml # The native toplevel ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat $(NATTOPOBJS:.cmo=.cmx) -linkall toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml cd otherlibs/dynlink && $(MAKE) allopt # The configuration file utils/config.ml: utils/config.mlp config/Makefile @rm -f utils/config.ml sed -e "s|%%LIBDIR%%|$(LIBDIR)|" \ -e "s|%%BYTERUN%%|ocamlrun|" \ -e 's|%%CCOMPTYPE%%|$(CCOMPTYPE)|' \ -e "s|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS)|" \ -e "s|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|" \ -e "s|%%PARTIALLD%%|$(PARTIALLD)|" \ -e "s|%%PACKLD%%|$(PACKLD)|" \ -e "s|%%BYTECCLIBS%%|$(BYTECCLIBS)|" \ -e "s|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|" \ -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \ -e 's|%%ARCMD%%|$(ARCMD)|' \ -e 's|%%BINUTILS_NM%%|$(BINUTILS_NM)|' \ -e 's|%%BINUTILS_OBJCOPY%%|$(BINUTILS_OBJCOPY)|' \ -e "s|%%ARCH%%|$(ARCH)|" \ -e "s|%%MODEL%%|$(MODEL)|" \ -e "s|%%SYSTEM%%|$(SYSTEM)|" \ -e "s|%%EXT_OBJ%%|.$(O)|" \ -e "s|%%EXT_ASM%%|.$(S)|" \ -e "s|%%EXT_LIB%%|.$(A)|" \ -e "s|%%EXT_DLL%%|.dll|" \ -e "s|%%SYSTHREAD_SUPPORT%%|true|" \ -e 's|%%ASM%%|$(ASM)|' \ -e 's|%%ASM_CFI_SUPPORTED%%|false|' \ -e 's|%%MKDLL%%|$(MKDLL)|' \ -e 's|%%MKEXE%%|$(MKEXE)|' \ -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ -e 's|%%CC_PROFILE%%||' \ utils/config.mlp > utils/config.ml @chmod -w utils/config.ml partialclean:: rm -f utils/config.ml beforedepend:: utils/config.ml # The parser parsing/parser.mli parsing/parser.ml: parsing/parser.mly $(CAMLYACC) $(YACCFLAGS) parsing/parser.mly partialclean:: rm -f parsing/parser.mli parsing/parser.ml parsing/parser.output beforedepend:: parsing/parser.mli parsing/parser.ml # The lexer parsing/lexer.ml: parsing/lexer.mll $(CAMLLEX) parsing/lexer.mll partialclean:: rm -f parsing/lexer.ml beforedepend:: parsing/lexer.ml # Shared parts of the system compiled with the native-code compiler compilerlibs/ocamlcommon.cmxa: $(COMMON:.cmo=.cmx) $(CAMLOPT) -a -o $@ $(COMMON:.cmo=.cmx) partialclean:: rm -f compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) # The bytecode compiler compiled with the native-code compiler compilerlibs/ocamlbytecomp.cmxa: $(BYTECOMP:.cmo=.cmx) $(CAMLOPT) -a -o $@ $(BYTECOMP:.cmo=.cmx) partialclean:: rm -f compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa $(BYTESTART:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)" @sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \ driver/ocamlcomp.sh.in > ocamlcomp.sh @chmod +x ocamlcomp.sh partialclean:: rm -f ocamlc.opt # The native-code compiler compiled with itself compilerlibs/ocamloptcomp.cmxa: $(ASMCOMP:.cmo=.cmx) $(CAMLOPT) -a -o $@ $(ASMCOMP:.cmo=.cmx) partialclean:: rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa $(OPTSTART:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(OPTSTART:.cmo=.cmx) @sed -e 's|@compiler@|$$topdir/ocamlopt.opt|' \ driver/ocamlcomp.sh.in > ocamlcompopt.sh @chmod +x ocamlcompopt.sh partialclean:: rm -f ocamlopt.opt $(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx): ocamlopt # The numeric opcodes bytecomp/opcodes.ml: byterun/instruct.h sed -n -e "/^enum/p" -e "s|,||g" -e "/^ /p" byterun/instruct.h | \ gawk -f tools/make-opcodes > bytecomp/opcodes.ml partialclean:: rm -f bytecomp/opcodes.ml beforedepend:: bytecomp/opcodes.ml # The predefined exceptions and primitives byterun/primitives: cd byterun ; $(MAKEREC) primitives bytecomp/runtimedef.ml: byterun/primitives byterun/fail.h (echo 'let builtin_exceptions = [|'; \ sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/fail.h | \ sed -e '$$s/;$$//'; \ echo '|]'; \ echo 'let builtin_primitives = [|'; \ sed -e 's/.*/ "&";/' -e '$$s/;$$//' byterun/primitives; \ echo '|]') > bytecomp/runtimedef.ml partialclean:: rm -f bytecomp/runtimedef.ml beforedepend:: bytecomp/runtimedef.ml # Choose the right machine-dependent files asmcomp/arch.ml: asmcomp/$(ARCH)/arch.ml cp asmcomp/$(ARCH)/arch.ml asmcomp/arch.ml partialclean:: rm -f asmcomp/arch.ml beforedepend:: asmcomp/arch.ml ifeq ($(TOOLCHAIN),msvc) ASMCOMP_EMIT=asmcomp/$(ARCH)/emit_nt.mlp else ASMCOMP_EMIT=asmcomp/$(ARCH)/emit.mlp endif asmcomp/proc.ml: asmcomp/$(ARCH)/proc.ml cp asmcomp/$(ARCH)/proc.ml asmcomp/proc.ml partialclean:: rm -f asmcomp/proc.ml beforedepend:: asmcomp/proc.ml asmcomp/selection.ml: asmcomp/$(ARCH)/selection.ml cp asmcomp/$(ARCH)/selection.ml asmcomp/selection.ml partialclean:: rm -f asmcomp/selection.ml beforedepend:: asmcomp/selection.ml asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml cp asmcomp/$(ARCH)/reload.ml asmcomp/reload.ml partialclean:: rm -f asmcomp/reload.ml beforedepend:: asmcomp/reload.ml asmcomp/scheduling.ml: asmcomp/$(ARCH)/scheduling.ml cp asmcomp/$(ARCH)/scheduling.ml asmcomp/scheduling.ml partialclean:: rm -f asmcomp/scheduling.ml beforedepend:: asmcomp/scheduling.ml # Preprocess the code emitters asmcomp/emit.ml: $(ASMCOMP_EMIT) tools/cvt_emit boot/ocamlrun tools/cvt_emit < $(ASMCOMP_EMIT) > asmcomp/emit.ml partialclean:: rm -f asmcomp/emit.ml beforedepend:: asmcomp/emit.ml tools/cvt_emit: tools/cvt_emit.mll cd tools ; $(MAKEREC) cvt_emit # The "expunge" utility expunge: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo $(CAMLC) $(LINKFLAGS) -o expunge \ compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma toplevel/expunge.cmo partialclean:: rm -f expunge # The runtime system for the bytecode compiler runtime: makeruntime stdlib/libcamlrun.$(A) makeruntime: cd byterun ; $(MAKEREC) all stdlib/libcamlrun.$(A): byterun/libcamlrun.$(A) cp byterun/libcamlrun.$(A) stdlib/libcamlrun.$(A) clean:: cd byterun ; $(MAKEREC) clean rm -f stdlib/libcamlrun.$(A) alldepend:: cd byterun ; $(MAKEREC) depend # The runtime system for the native-code compiler runtimeopt: makeruntimeopt stdlib/libasmrun.$(A) makeruntimeopt: cd asmrun ; $(MAKEREC) all stdlib/libasmrun.$(A): asmrun/libasmrun.$(A) cp asmrun/libasmrun.$(A) stdlib/libasmrun.$(A) clean:: cd asmrun ; $(MAKEREC) clean rm -f stdlib/libasmrun.$(A) alldepend:: cd asmrun ; $(MAKEREC) depend # The library library: cd stdlib ; $(MAKEREC) all library-cross: cd stdlib ; $(MAKEREC) RUNTIME=../byterun/ocamlrun all libraryopt: cd stdlib ; $(MAKEREC) allopt partialclean:: cd stdlib ; $(MAKEREC) clean alldepend:: cd stdlib ; $(MAKEREC) depend # The lexer and parser generators ocamllex: cd lex ; $(MAKEREC) all ocamllex.opt: cd lex ; $(MAKEREC) allopt partialclean:: cd lex ; $(MAKEREC) clean alldepend:: cd lex ; $(MAKEREC) depend ocamlyacc: cd yacc ; $(MAKEREC) all clean:: cd yacc ; $(MAKEREC) clean # Tools ocamltools: asmcomp/cmx_format.cmi cd tools ; $(MAKEREC) all ocamltoolsopt.opt: asmcomp/cmx_format.cmi cd tools ; $(MAKEREC) opt.opt partialclean:: cd tools ; $(MAKEREC) clean alldepend:: cd tools ; $(MAKEREC) depend # OCamldoc ocamldoc.byte: cd ocamldoc ; $(MAKEREC) all ocamldoc.opt: cd ocamldoc ; $(MAKEREC) opt.opt partialclean:: cd ocamldoc ; $(MAKEREC) clean alldepend:: cd ocamldoc ; $(MAKEREC) depend # The extra libraries otherlibraries: for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i all; done otherlibrariesopt: for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i allopt; done partialclean:: for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i partialclean; done clean:: for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i clean; done alldepend:: for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i depend; done # The replay debugger ocamldebugger: ocamlc ocamlyacc ocamllex cd debugger; $(MAKEREC) all partialclean:: cd debugger; $(MAKEREC) clean alldepend:: cd debugger; $(MAKEREC) depend # Camlp4 camlp4out: ocamlc otherlibraries ocamlbuild-mixed-boot ocamlbuild.byte ./build/camlp4-byte-only.sh camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native ./build/camlp4-native-only.sh # Ocamlbuild ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-mixed-boot ./build/ocamlbuild-byte-only.sh ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ./build/ocamlbuild-native-only.sh ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ./build/ocamlbuildlib-native-only.sh .PHONY: ocamlbuild-mixed-boot ocamlbuild-mixed-boot: ./build/mixed-boot.sh partialclean:: rm -rf _build # Default rules .SUFFIXES: .ml .mli .cmo .cmi .cmx .ml.cmo: $(CAMLC) $(COMPFLAGS) -c $< .mli.cmi: $(CAMLC) $(COMPFLAGS) -c $< .ml.cmx: $(CAMLOPT) $(COMPFLAGS) -c $< partialclean:: rm -f utils/*.cm* utils/*.$(O) utils/*.$(S) rm -f parsing/*.cm* parsing/*.$(O) parsing/*.$(S) rm -f typing/*.cm* typing/*.$(O) typing/*.$(S) rm -f bytecomp/*.cm* bytecomp/*.$(O) bytecomp/*.$(S) rm -f asmcomp/*.cm* asmcomp/*.$(O) asmcomp/*.$(S) rm -f driver/*.cm* driver/*.$(O) driver/*.$(S) rm -f toplevel/*.cm* toplevel/*.$(O) toplevel/*.$(S) rm -f tools/*.cm* tools/*.$(O) tools/*.$(S) depend: beforedepend (for d in utils parsing typing bytecomp asmcomp driver toplevel; \ do $(CAMLDEP) $(DEPFLAGS) $$d/*.mli $$d/*.ml; \ done) > .depend alldepend:: depend distclean: ./build/distclean.sh .PHONY: all backup bootstrap camlp4opt camlp4out checkstack clean .PHONY: partialclean beforedepend alldepend cleanboot coldstart .PHONY: compare core coreall .PHONY: coreboot defaultentry depend distclean install installopt .PHONY: library library-cross libraryopt ocamlbuild-mixed-boot .PHONY: ocamlbuild.byte ocamlbuild.native ocamldebugger ocamldoc .PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltools.opt .PHONY: ocamlyacc opt-core opt opt.opt otherlibraries .PHONY: otherlibrariesopt promote promote-cross .PHONY: restore runtime runtimeopt makeruntimeopt world world.opt include .depend mingw-ocaml/ocaml/README0000644000175000017500000001172512124403240014343 0ustar tootstootsOVERVIEW: OCaml is an implementation of the ML language, based on the Caml Light dialect extended with a complete class-based object system and a powerful module system in the style of Standard ML. OCaml comprises two compilers. One generates bytecode which is then interpreted by a C program. This compiler runs quickly, generates compact code with moderate memory requirements, and is portable to essentially any 32 or 64 bit Unix platform. Performance of generated programs is quite good for a bytecoded implementation. This compiler can be used either as a standalone, batch-oriented compiler that produces standalone programs, or as an interactive, toplevel-based system. The other compiler generates high-performance native code for a number of processors. Compilation takes longer and generates bigger code, but the generated programs deliver excellent performance, while retaining the moderate memory requirements of the bytecode compiler. The native-code compiler currently runs on the following platforms: Tier 1 (actively used and maintained by the core OCaml team): AMD64 (Opteron) Linux, MacOS X, MS Windows IA32 (Pentium) Linux, FreeBSD, MacOS X, MS Windows PowerPC Linux, MacOS X ARM Linux Tier 2 (maintained when possible, with help from users): AMD64 FreeBSD, OpenBSD IA32 (Pentium) NetBSD, OpenBSD, Solaris 9 PowerPC NetBSD SPARC Solaris, Linux, NetBSD Other operating systems for the processors above have not been tested, but the compiler may work under other operating systems with little work. Before the introduction of objects, OCaml was known as Caml Special Light. OCaml is almost upwards compatible with Caml Special Light, except for a few additional reserved keywords that have forced some renaming of standard library functions. CONTENTS: Changes what's new with each release INSTALL instructions for installation LICENSE license and copyright notice Makefile main Makefile README this file README.win32 infos on the MS Windows ports of OCaml asmcomp/ native-code compiler and linker asmrun/ native-code runtime library boot/ bootstrap compiler bytecomp/ bytecode compiler and linker byterun/ bytecode interpreter and runtime system camlp4/ the Camlp4 preprocessor config/ autoconfiguration stuff debugger/ source-level replay debugger driver/ driver code for the compilers emacs/ OCaml editing mode and debugger interface for GNU Emacs lex/ lexer generator maccaml/ the Macintosh GUI ocamldoc/ documentation generator otherlibs/ several external libraries parsing/ syntax analysis stdlib/ standard library tools/ various utilities toplevel/ interactive system typing/ typechecking utils/ utility libraries yacc/ parser generator COPYRIGHT: All files marked "Copyright INRIA" in this distribution are copyright 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Institut National de Recherche en Informatique et en Automatique (INRIA) and distributed under the conditions stated in file LICENSE. INSTALLATION: See the file INSTALL for installation instructions on Unix, Linux and MacOS X machines. For MS Windows, see README.win32. DOCUMENTATION: The OCaml manual is distributed in HTML, PDF, Postscript, DVI, and Emacs Info files. It is available on the World Wide Web, at http://caml.inria.fr/ AVAILABILITY: The complete OCaml distribution can be accessed at http://caml.inria.fr/ KEEPING IN TOUCH WITH THE CAML COMMUNITY: There exists a mailing list of users of the OCaml implementations developed at INRIA. The purpose of this list is to share experience, exchange ideas (and even code), and report on applications of the OCaml language. Messages can be written in English or in French. The list has more than 1000 subscribers. Messages to the list should be sent to: caml-list@inria.fr You can subscribe to this list via the Web interface at https://sympa-roc.inria.fr/wws/info/caml-list Archives of the list are available on the Web site above. The Usenet news groups comp.lang.ml and comp.lang.functional also contains discussions about the ML family of programming languages, including OCaml. BUG REPORTS AND USER FEEDBACK: Please report bugs using the Web interface to the bug-tracking system at http://caml.inria.fr/bin/caml-bugs To be effective, bug reports should include a complete program (preferably small) that exhibits the unexpected behavior, and the configuration you are using (machine type, etc). You can also contact the implementors directly at caml@inria.fr. ---- $Id$ mingw-ocaml/ocaml/experimental/0000755000175000017500000000000012124403240016152 5ustar tootstootsmingw-ocaml/ocaml/experimental/doligez/0000755000175000017500000000000012124403240017607 5ustar tootstootsmingw-ocaml/ocaml/experimental/doligez/checkheaders0000755000175000017500000001232312124403240022147 0ustar tootstoots#!/bin/sh ####################################################################### # # # OCaml # # # # Damien Doligez, projet Gallium, INRIA Rocquencourt # # # # Copyright 2011 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ####################################################################### ( case $# in 0) find . -type f -print;; *) echo $1;; esac ) | \ while read f; do awk -f - "$f" <<\EOF function checkline (x) { return ( $0 ~ ("^.{0,4}" x) ); } function hrule () { return (checkline("[*#]{69}")); } function blank () { return (checkline(" {69}")); } function ocaml () { return (checkline(" {32}OCaml {32}") \ || checkline(" {35}OCaml {32}") \ || checkline(" MLTk, Tcl/Tk interface of OCaml ") \ || checkline(" OCaml LablTk library ") \ || checkline(" ocamlbuild ") \ || checkline(" OCamldoc ") \ ); } function any () { return (checkline(".{69}")); } function copy1 () { return (checkline(" Copyright +[-0-9]+ +Institut +National +de +Recherche +en +Informatique +et ")); } function copy2 () { return (checkline(" en Automatique")); } function err () { printf ("File \"%s\", line %d:\n", FILENAME, FNR); printf (" Error: line %d of header is wrong.\n", FNR + offset); print $0; } function add_ignore_re (x) { ignore_re[++ignore_re_index] = x; } function add_exception (x) { exception[++exception_index] = x; } FNR == 1 { offset = 0; add_ignore_re("/\\.svn/"); add_ignore_re("/\\.depend(\\.nt)?$"); add_ignore_re("/\\.ignore$"); add_ignore_re("\\.gif$"); add_ignore_re("/[A-Z]*$"); add_ignore_re("/README\\.[^/]*$"); add_ignore_re("/Changes$"); add_ignore_re("\\.mlpack$"); add_ignore_re("\\.mllib$"); add_ignore_re("\\.mltop$"); add_ignore_re("\\.clib$"); add_ignore_re("\\.odocl$"); add_ignore_re("\\.itarget$"); add_ignore_re("^\\./boot/"); add_ignore_re("^\\./camlp4/test/"); add_ignore_re("^\\./camlp4/unmaintained/"); add_ignore_re("^\\./config/gnu/"); add_ignore_re("^\\./experimental/"); add_ignore_re("^\\./ocamlbuild/examples/"); add_ignore_re("^\\./ocamlbuild/test/"); add_ignore_re("^\\./otherlibs/labltk/builtin/"); add_ignore_re("^\\./otherlibs/labltk/examples_"); add_ignore_re("^\\./testsuite/"); for (i in ignore_re){ if (FILENAME ~ ignore_re[i]) { nextfile; } } add_exception("./asmrun/m68k.S"); # obsolete add_exception("./build/camlp4-bootstrap-recipe.txt"); add_exception("./build/new-build-system"); add_exception("./ocamlbuild/ChangeLog"); add_exception("./ocamlbuild/manual/myocamlbuild.ml"); # TeX input file ? add_exception("./ocamlbuild/manual/trace.out"); # TeX input file add_exception("./ocamldoc/Changes.txt"); add_exception("./ocamldoc/ocamldoc.sty"); # public domain add_exception("./otherlibs/labltk/browser/help.txt"); add_exception("./otherlibs/labltk/camltk/modules"); # generated add_exception("./otherlibs/labltk/labltk/modules"); # generated add_exception("./tools/objinfo_helper.c"); # non-INRIA add_exception("./tools/magic"); # public domain ? add_exception("./Upgrading"); add_exception("./win32caml/inriares.h"); # generated add_exception("./win32caml/ocaml.rc"); # generated add_exception("./win32caml/resource.h"); # generated for (i in exception){ if (FILENAME == exception[i]) { nextfile; } } } # 1 [!hrule] #! # 2 [!hrule] empty # 3 hrule # 4 [blank] # 5 ocaml title # 6 blank # 7 any author # 8 [!blank] author # 9 [!blank] author #10 blank #11 copy1 copyright #12 copy2 copyright #13 any copyright #14 [!blank] copyright #15 [!blank] copyright #16 blank #17 hrule FNR + offset == 1 && hrule() { ++offset; } FNR + offset == 2 && hrule() { ++offset; } FNR + offset == 3 && ! hrule() { err(); nextfile; } FNR + offset == 4 && ! blank() { ++offset; } FNR + offset == 5 && ! ocaml() { err(); nextfile; } FNR + offset == 6 && ! blank() { err(); nextfile; } FNR + offset == 7 && ! any() { err(); nextfile; } FNR + offset == 8 && blank() { ++offset; } FNR + offset == 9 && blank() { ++offset; } FNR + offset ==10 && ! blank() { err(); nextfile; } FNR + offset ==11 && ! copy1() { err(); nextfile; } FNR + offset ==12 && ! copy2() { err(); nextfile; } FNR + offset ==13 && ! any() { err(); nextfile; } FNR + offset ==14 && blank() { ++offset; } FNR + offset ==15 && blank() { ++offset; } FNR + offset ==16 && ! blank() { err(); nextfile; } FNR + offset ==17 && ! hrule() { err(); nextfile; } EOF done mingw-ocaml/ocaml/experimental/garrigue/0000755000175000017500000000000012124403240017757 5ustar tootstootsmingw-ocaml/ocaml/experimental/garrigue/varunion.ml0000644000175000017500000002747112124403240022165 0ustar tootstoots(* cvs update -r varunion parsing typing bytecomp toplevel *) type t = private [> ];; type u = private [> ] ~ [t];; type v = [t | u];; let f x = (x : t :> v);; (* bad *) module Mix(X: sig type t = private [> ] end) (Y: sig type t = private [> ] end) = struct type t = [X.t | Y.t] end;; (* bad *) module Mix(X: sig type t = private [> `A of int ] end) (Y: sig type t = private [> `A of bool] ~ [X.t] end) = struct type t = [X.t | Y.t] end;; (* ok *) module Mix(X: sig type t = private [> `A of int ] end) (Y: sig type t = private [> `A of int] ~ [X.t] end) = struct type t = [X.t | Y.t] end;; (* bad *) module Mix(X: sig type t = private [> `A of int ] end) (Y: sig type t = private [> `B of bool] ~ [X.t] end) = struct type t = [X.t | Y.t] end;; type 'a t = private [> `L of 'a] ~ [`L];; (* ok *) module Mix(X: sig type t = private [> `A of int ] ~ [`B] end) (Y: sig type t = private [> `B of bool] ~ [X.t] end) = struct type t = [X.t | Y.t] let is_t = function #t -> true | _ -> false end;; module Mix(X: sig type t = private [> `A of int ] ~ [`B] end) (Y: sig type t = private [> `B of bool] ~ [X.t] end) = struct type t = [X.t | Y.t] let which = function #X.t -> `X | #Y.t -> `Y end;; module Mix(I: sig type t = private [> ] ~ [`A;`B] end) (X: sig type t = private [> I.t | `A of int ] ~ [`B] end) (Y: sig type t = private [> I.t | `B of bool] ~ [X.t] end) = struct type t = [X.t | Y.t] let which = function #X.t -> `X | #Y.t -> `Y end;; (* ok *) module M = Mix(struct type t = [`C of char] end) (struct type t = [`A of int | `C of char] end) (struct type t = [`B of bool | `C of char] end);; (* bad *) module M = Mix(struct type t = [`B of bool] end) (struct type t = [`A of int | `B of bool] end) (struct type t = [`B of bool | `C of char] end);; (* ok *) module M1 = struct type t = [`A of int | `C of char] end module M2 = struct type t = [`B of bool | `C of char] end module I = struct type t = [`C of char] end module M = Mix(I)(M1)(M2) ;; let c = (`C 'c' : M.t) ;; module M(X : sig type t = private [> `A] end) = struct let f (#X.t as x) = x end;; (* code generation *) type t = private [> `A ] ~ [`B];; match `B with #t -> 1 | `B -> 2;; module M : sig type t = private [> `A of int | `B] ~ [`C] end = struct type t = [`A of int | `B | `D of bool] end;; let f = function (`C | #M.t) -> 1+1 ;; let f = function (`A _ | `B #M.t) -> 1+1 ;; (* expression *) module Mix(X:sig type t = private [> ] val show: t -> string end) (Y:sig type t = private [> ] ~ [X.t] val show: t -> string end) = struct type t = [X.t | Y.t] let show : t -> string = function #X.t as x -> X.show x | #Y.t as y -> Y.show y end;; module EStr = struct type t = [`Str of string] let show (`Str s) = s end module EInt = struct type t = [`Int of int] let show (`Int i) = string_of_int i end module M = Mix(EStr)(EInt);; module type T = sig type t = private [> ] val show: t -> string end module Mix(X:T)(Y:T with type t = private [> ] ~ [X.t]) : T with type t = [X.t | Y.t] = struct type t = [X.t | Y.t] let show = function #X.t as x -> X.show x | #Y.t as y -> Y.show y end;; module M = Mix(EStr)(EInt);; (* deep *) module M : sig type t = private [> `A] end = struct type t = [`A] end module M' : sig type t = private [> ] end = struct type t = [M.t | `A] end;; (* bad *) type t = private [> ] type u = private [> `A of int] ~ [t] ;; (* ok *) type t = private [> `A of int] type u = private [> `A of int] ~ [t] ;; module F(X: sig type t = private [> ] ~ [`A;`B;`C;`D] type u = private [> `A|`B|`C] ~ [t; `D] end) : sig type v = private [< X.t | X.u | `D] end = struct open X let f = function #u -> 1 | #t -> 2 | `D -> 3 let g = function #u|#t|`D -> 2 type v = [t|u|`D] end (* ok *) module M = struct type t = private [> `A] end;; module M' : sig type t = private [> ] ~ [`A] end = M;; (* ok *) module type T = sig type t = private [> ] ~ [`A] end;; module type T' = T with type t = private [> `A];; (* ok *) type t = private [> ] ~ [`A] let f = function `A x -> x | #t -> 0 type t' = private [< `A of int | t];; (* should be ok *) module F(X:sig end) : sig type t = private [> ] type u = private [> ] ~ [t] end = struct type t = [ `A] type u = [`B] end module M = F(String) let f = function #M.t -> 1 | #M.u -> 2 let f = function #M.t -> 1 | _ -> 2 type t = [M.t | M.u] let f = function #t -> 1 | _ -> 2;; module G(X : sig type t = private [> ] type u = private [> ] ~ [t] end) = struct let f = function #X.t -> 1 | _ -> 2 end;; module M1 = G(struct module N = F(String) type t = N.t type u = N.u end) ;; module M1 = G(struct type t = M.t type u = M.u end) ;; (* bad *) let f = function #F(String).t -> 1 | _ -> 2;; type t = [F(String).t | M.u] let f = function #t -> 1 | _ -> 2;; module N : sig type t = private [> ] end = struct type t = [F(String).t | M.u] end;; (* compatibility improvement *) type a = [`A of int | `B] type b = [`A of bool | `B] type c = private [> ] ~ [a;b] let f = function #c -> 1 | `A x -> truncate x type d = private [> ] ~ [a] let g = function #d -> 1 | `A x -> truncate x;; (* Expression Problem: functorial form *) type num = [ `Num of int ] module type Exp = sig type t = private [> num] val eval : t -> t val show : t -> string end module Num(X : Exp) = struct type t = num let eval (`Num _ as x) : X.t = x let show (`Num n) = string_of_int n end type 'a add = [ `Add of 'a * 'a ] module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct type t = X.t add let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")" let eval (`Add(e1, e2) : t) = let e1 = X.eval e1 and e2 = X.eval e2 in match e1, e2 with `Num n1, `Num n2 -> `Num (n1+n2) | `Num 0, e | e, `Num 0 -> e | e12 -> `Add e12 end type 'a mul = [`Mul of 'a * 'a] module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct type t = X.t mul let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")" let eval (`Mul(e1, e2) : t) = let e1 = X.eval e1 and e2 = X.eval e2 in match e1, e2 with `Num n1, `Num n2 -> `Num (n1*n2) | `Num 0, e | e, `Num 0 -> `Num 0 | `Num 1, e | e, `Num 1 -> e | e12 -> `Mul e12 end module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct module type S = sig type t = private [> ] ~ [ X.t ] val eval : t -> Y.t val show : t -> string end end module Dummy = struct type t = [`Dummy] end module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) = struct type t = [E1.t | E2.t] let eval = function #E1.t as x -> E1.eval x | #E2.t as x -> E2.eval x let show = function #E1.t as x -> E1.show x | #E2.t as x -> E2.show x end module rec EAdd : (Exp with type t = [num | EAdd.t add]) = Mix(EAdd)(Num(EAdd))(Add(EAdd)) (* A bit heavy: one must pass E to everybody *) module rec E : Exp with type t = [num | E.t add | E.t mul] = Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E)) let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1)) (* Alternatives *) (* Direct approach, no need of Mix *) module rec E : (Exp with type t = [num | E.t add | E.t mul]) = struct module E1 = Num(E) module E2 = Add(E) module E3 = Mul(E) type t = E.t let show = function | #num as x -> E1.show x | #add as x -> E2.show x | #mul as x -> E3.show x let eval = function | #num as x -> E1.eval x | #add as x -> E2.eval x | #mul as x -> E3.eval x end (* Do functor applications in Mix *) module type T = sig type t = private [> ] end module type Tnum = sig type t = private [> num] end module Ext(E : Tnum) = struct module type S = functor (Y : Exp with type t = E.t) -> sig type t = private [> num] val eval : t -> Y.t val show : t -> string end end module Ext'(E : Tnum)(X : T) = struct module type S = functor (Y : Exp with type t = E.t) -> sig type t = private [> ] ~ [ X.t ] val eval : t -> Y.t val show : t -> string end end module Mix(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S) = struct module E1 = F1(E) module E2 = F2(E) type t = [E1.t | E2.t] let eval = function #E1.t as x -> E1.eval x | #E2.t as x -> E2.eval x let show = function #E1.t as x -> E1.show x | #E2.t as x -> E2.show x end module Join(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S) (E' : Exp with type t = E.t) = Mix(E)(F1)(F2) module rec EAdd : (Exp with type t = [num | EAdd.t add]) = Mix(EAdd)(Num)(Add) module rec EMul : (Exp with type t = [num | EMul.t mul]) = Mix(EMul)(Num)(Mul) module rec E : (Exp with type t = [num | E.t add | E.t mul]) = Mix(E)(Join(E)(Num)(Add))(Mul) (* Linear extension by the end: not so nice *) module LExt(X : T) = struct module type S = sig type t val eval : t -> X.t val show : t -> string end end module LNum(E: Exp)(X : LExt(E).S with type t = private [> ] ~ [num]) = struct type t = [num | X.t] let show = function `Num n -> string_of_int n | #X.t as x -> X.show x let eval = function #num as x -> x | #X.t as x -> X.eval x end module LAdd(E : Exp with type t = private [> num | 'a add] as 'a) (X : LExt(E).S with type t = private [> ] ~ [add]) = struct type t = [E.t add | X.t] let show = function `Add(e1,e2) -> "("^ E.show e1 ^"+"^ E.show e2 ^")" | #X.t as x -> X.show x let eval = function `Add(e1,e2) -> let e1 = E.eval e1 and e2 = E.eval e2 in begin match e1, e2 with `Num n1, `Num n2 -> `Num (n1+n2) | `Num 0, e | e, `Num 0 -> e | e12 -> `Add e12 end | #X.t as x -> X.eval x end module LEnd = struct type t = [`Dummy] let show `Dummy = "" let eval `Dummy = `Dummy end module rec L : Exp with type t = [num | L.t add | `Dummy] = LAdd(L)(LNum(L)(LEnd)) (* Back to first form, but add map *) module Num(X : Exp) = struct type t = num let map f x = x let eval1 (`Num _ as x) : X.t = x let show (`Num n) = string_of_int n end module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct type t = X.t add let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")" let map f (`Add(e1, e2) : t) = `Add(f e1, f e2) let eval1 (`Add(e1, e2) as e : t) = match e1, e2 with `Num n1, `Num n2 -> `Num (n1+n2) | `Num 0, e | e, `Num 0 -> e | _ -> e end module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct type t = X.t mul let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")" let map f (`Mul(e1, e2) : t) = `Mul(f e1, f e2) let eval1 (`Mul(e1, e2) as e : t) = match e1, e2 with `Num n1, `Num n2 -> `Num (n1*n2) | `Num 0, e | e, `Num 0 -> `Num 0 | `Num 1, e | e, `Num 1 -> e | _ -> e end module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct module type S = sig type t = private [> ] ~ [ X.t ] val map : (Y.t -> Y.t) -> t -> t val eval1 : t -> Y.t val show : t -> string end end module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) = struct type t = [E1.t | E2.t] let map f = function #E1.t as x -> (E1.map f x : E1.t :> t) | #E2.t as x -> (E2.map f x : E2.t :> t) let eval1 = function #E1.t as x -> E1.eval1 x | #E2.t as x -> E2.eval1 x let show = function #E1.t as x -> E1.show x | #E2.t as x -> E2.show x end module type ET = sig type t val map : (t -> t) -> t -> t val eval1 : t -> t val show : t -> string end module Fin(E : ET) = struct include E let rec eval e = eval1 (map eval e) end module rec EAdd : (Exp with type t = [num | EAdd.t add]) = Fin(Mix(EAdd)(Num(EAdd))(Add(EAdd))) module rec E : Exp with type t = [num | E.t add | E.t mul] = Fin(Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E))) let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1)) mingw-ocaml/ocaml/experimental/garrigue/parser-lessminus.diffs0000644000175000017500000000577212124403240024323 0ustar tootstootsIndex: parsing/parser.mly =================================================================== --- parsing/parser.mly (revision 11929) +++ parsing/parser.mly (working copy) @@ -319,6 +319,11 @@ let polyvars, core_type = varify_constructors newtypes core_type in (exp, ghtyp(Ptyp_poly(polyvars,core_type))) +let no_lessminus = + List.map (fun (p,e,b) -> + match b with None -> (p,e) + | Some loc -> raise (Syntaxerr.Error (Syntaxerr.Other loc))) + %} /* Tokens */ @@ -597,8 +602,9 @@ structure_item: LET rec_flag let_bindings { match $3 with - [{ ppat_desc = Ppat_any; ppat_loc = _ }, exp] -> mkstr(Pstr_eval exp) - | _ -> mkstr(Pstr_value($2, List.rev $3)) } + [{ ppat_desc = Ppat_any; ppat_loc = _ }, exp, None] -> + mkstr(Pstr_eval exp) + | _ -> mkstr(Pstr_value($2, no_lessminus (List.rev $3))) } | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration { mkstr(Pstr_primitive($2, {pval_type = $4; pval_prim = $6})) } | TYPE type_declarations @@ -744,7 +750,7 @@ | class_simple_expr simple_labeled_expr_list { mkclass(Pcl_apply($1, List.rev $2)) } | LET rec_flag let_bindings IN class_expr - { mkclass(Pcl_let ($2, List.rev $3, $5)) } + { mkclass(Pcl_let ($2, no_lessminus (List.rev $3), $5)) } ; class_simple_expr: LBRACKET core_type_comma_list RBRACKET class_longident @@ -981,9 +987,15 @@ | simple_expr simple_labeled_expr_list { mkexp(Pexp_apply($1, List.rev $2)) } | LET rec_flag let_bindings IN seq_expr - { mkexp(Pexp_let($2, List.rev $3, $5)) } + { match $3 with + | [pat, expr, Some loc] when $2 = Nonrecursive -> + mkexp(Pexp_apply( + {pexp_desc = Pexp_ident(Lident "bind"); pexp_loc = loc}, + ["", expr; "", ghexp(Pexp_function("", None, [pat, $5]))])) + | bindings -> + mkexp(Pexp_let($2, no_lessminus (List.rev $3), $5)) } | LET DOT simple_expr let_binding IN seq_expr - { let (pat, expr) = $4 in + { let (pat, expr, _) = $4 in mkexp(Pexp_apply($3, ["", expr; "", ghexp(Pexp_function("", None, [pat, $6]))])) } | LET MODULE UIDENT module_binding IN seq_expr { mkexp(Pexp_letmodule($3, $4, $6)) } @@ -1197,14 +1209,17 @@ ; let_binding: val_ident fun_binding - { (mkpatvar $1 1, $2) } + { (mkpatvar $1 1, $2, None) } | val_ident COLON typevar_list DOT core_type EQUAL seq_expr - { (ghpat(Ppat_constraint(mkpatvar $1 1, ghtyp(Ptyp_poly($3,$5)))), $7) } + { (ghpat(Ppat_constraint(mkpatvar $1 1, ghtyp(Ptyp_poly($3,$5)))), $7, + None) } | val_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr { let exp, poly = wrap_type_annotation $4 $6 $8 in - (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp) } + (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp, None) } | pattern EQUAL seq_expr - { ($1, $3) } + { ($1, $3, None) } + | pattern LESSMINUS seq_expr + { ($1, $3, Some (rhs_loc 2)) } ; fun_binding: strict_binding mingw-ocaml/ocaml/experimental/garrigue/.cvsignore0000644000175000017500000000001512124403240021753 0ustar tootstoots*.out *.out2 mingw-ocaml/ocaml/experimental/garrigue/gadt-escape-check.diffs0000644000175000017500000004340612124403240024233 0ustar tootstootsIndex: typing/env.ml =================================================================== --- typing/env.ml (revision 11214) +++ typing/env.ml (working copy) @@ -20,6 +20,7 @@ open Longident open Path open Types +open Btype type error = @@ -56,7 +57,7 @@ cltypes: (Path.t * cltype_declaration) Ident.tbl; summary: summary; local_constraints: bool; - level_map: (int * int) list; + gadt_instances: (int * TypeSet.t ref) list; } and module_components = module_components_repr Lazy.t @@ -96,7 +97,7 @@ modules = Ident.empty; modtypes = Ident.empty; components = Ident.empty; classes = Ident.empty; cltypes = Ident.empty; - summary = Env_empty; local_constraints = false; level_map = [] } + summary = Env_empty; local_constraints = false; gadt_instances = [] } let diff_keys is_local tbl1 tbl2 = let keys2 = Ident.keys tbl2 in @@ -286,13 +287,14 @@ (* the level is changed when updating newtype definitions *) if !Clflags.principal then begin match level, decl.type_newtype_level with - Some level, Some def_level when level < def_level -> raise Not_found + Some level, Some (_, exp_level) when level < exp_level -> raise Not_found | _ -> () end; match decl.type_manifest with | Some body when decl.type_private = Public || decl.type_kind <> Type_abstract - || Btype.has_constr_row body -> (decl.type_params, body) + || Btype.has_constr_row body -> + (decl.type_params, body, may_map snd decl.type_newtype_level) (* The manifest type of Private abstract data types without private row are still considered unknown to the type system. Hence, this case is caught by the following clause that also handles @@ -308,7 +310,7 @@ match decl.type_manifest with (* The manifest type of Private abstract data types can still get an approximation using their manifest type. *) - | Some body -> (decl.type_params, body) + | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level) | _ -> raise Not_found let find_modtype_expansion path env = @@ -453,32 +455,42 @@ and lookup_cltype = lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) -(* Level handling *) +(* GADT instance tracking *) -(* The level map is a list of pairs describing separate segments (lv,lv'), - lv < lv', organized in decreasing order. - The definition level is obtained by mapping a level in a segment to the - high limit of this segment. - The definition level of a newtype should be greater or equal to - the highest level of the newtypes in its manifest type. - *) +let add_gadt_instance_level lv env = + {env with + gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances} -let rec map_level lv = function - | [] -> lv - | (lv1, lv2) :: rem -> - if lv > lv2 then lv else - if lv >= lv1 then lv2 else map_level lv rem +let is_Tlink = function {desc = Tlink _} -> true | _ -> false -let map_newtype_level env lv = map_level lv env.level_map +let gadt_instance_level env t = + let rec find_instance = function + [] -> None + | (lv, r) :: rem -> + if TypeSet.exists is_Tlink !r then + r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty; + if TypeSet.mem t !r then Some lv else find_instance rem + in find_instance env.gadt_instances -(* precondition: lv < lv' *) -let rec add_level lv lv' = function - | [] -> [lv, lv'] - | (lv1, lv2) :: rem as l -> - if lv2 < lv then (lv, lv') :: l else - if lv' < lv1 then (lv1, lv2) :: add_level lv lv' rem - else add_level (max lv lv1) (min lv' lv2) rem +let add_gadt_instances env lv tl = + let r = + try List.assoc lv env.gadt_instances with Not_found -> assert false in + r := List.fold_right TypeSet.add tl !r +(* Only use this after expand_head! *) +let add_gadt_instance_chain env lv t = + let r = + try List.assoc lv env.gadt_instances with Not_found -> assert false in + let rec add_instance t = + let t = repr t in + if not (TypeSet.mem t !r) then begin + r := TypeSet.add t !r; + match t.desc with + Tconstr (p, _, memo) -> + may add_instance (find_expans Private p !memo) + | _ -> () + end + in add_instance t (* Expand manifest module type names at the top of the given module type *) @@ -497,7 +509,7 @@ let constructors_of_type ty_path decl = let handle_variants cstrs = Datarepr.constructor_descrs - (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) + (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) cstrs decl.type_private in match decl.type_kind with @@ -510,7 +522,7 @@ match decl.type_kind with Type_record(labels, rep) -> Datarepr.label_descrs - (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) + (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) labels rep decl.type_private | Type_variant _ | Type_abstract -> [] @@ -773,14 +785,13 @@ and add_cltype id ty env = store_cltype id (Pident id) ty env -let add_local_constraint id info mlv env = +let add_local_constraint id info elv env = match info with - {type_manifest = Some ty; type_newtype_level = Some lv} -> - (* use the newtype level for this definition, lv is the old one *) - let env = add_type id {info with type_newtype_level = Some mlv} env in - let level_map = - if lv < mlv then add_level lv mlv env.level_map else env.level_map in - { env with local_constraints = true; level_map = level_map } + {type_manifest = Some ty; type_newtype_level = Some (lv, _)} -> + (* elv is the expansion level, lv is the definition level *) + let env = + add_type id {info with type_newtype_level = Some (lv, elv)} env in + { env with local_constraints = true } | _ -> assert false (* Insertion of bindings by name *) Index: typing/typecore.ml =================================================================== --- typing/typecore.ml (revision 11214) +++ typing/typecore.ml (working copy) @@ -1989,6 +1989,7 @@ end | Pexp_newtype(name, sbody) -> (* Create a fake abstract type declaration for name. *) + let level = get_current_level () in let decl = { type_params = []; type_arity = 0; @@ -1996,7 +1997,7 @@ type_private = Public; type_manifest = None; type_variance = []; - type_newtype_level = Some (get_current_level ()); + type_newtype_level = Some (level, level); } in let ty = newvar () in @@ -2421,6 +2422,7 @@ begin_def (); Ident.set_current_time (get_current_level ()); let lev = Ident.current_time () in + let env = Env.add_gadt_instance_level lev env in Ctype.init_def (lev+1000); if !Clflags.principal then begin_def (); (* propagation of the argument *) let ty_arg' = newvar () in Index: typing/typedecl.ml =================================================================== --- typing/typedecl.ml (revision 11214) +++ typing/typedecl.ml (working copy) @@ -404,7 +404,7 @@ else if to_check path' && not (List.mem path' prev_exp) then begin try (* Attempt expansion *) - let (params0, body0) = Env.find_type_expansion path' env in + let (params0, body0, _) = Env.find_type_expansion path' env in let (params, body) = Ctype.instance_parameterized_type params0 body0 in begin Index: typing/types.mli =================================================================== --- typing/types.mli (revision 11214) +++ typing/types.mli (working copy) @@ -144,9 +144,9 @@ type_manifest: type_expr option; type_variance: (bool * bool * bool) list; (* covariant, contravariant, weakly contravariant *) - type_newtype_level: int option } + type_newtype_level: (int * int) option } + (* definition level * expansion level *) - and type_kind = Type_abstract | Type_record of Index: typing/ctype.ml =================================================================== --- typing/ctype.ml (revision 11214) +++ typing/ctype.ml (working copy) @@ -470,7 +470,7 @@ free_variables := (ty, real) :: !free_variables | Tconstr (path, tl, _), Some env -> begin try - let (_, body) = Env.find_type_expansion path env in + let (_, body, _) = Env.find_type_expansion path env in if (repr body).level <> generic_level then free_variables := (ty, real) :: !free_variables with Not_found -> () @@ -687,7 +687,7 @@ try match (Env.find_type p env).type_newtype_level with | None -> Path.binding_time p - | Some x -> x + | Some (x, _) -> x with | _ -> (* no newtypes in predef *) @@ -696,9 +696,13 @@ let rec update_level env level ty = let ty = repr ty in if ty.level > level then begin + if !Clflags.principal && Env.has_local_constraints env then begin + match Env.gadt_instance_level env ty with + Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)]) + | None -> () + end; match ty.desc with - Tconstr(p, tl, abbrev) - when level < Env.map_newtype_level env (get_level env p) -> + Tconstr(p, tl, abbrev) when level < get_level env p -> (* Try first to replace an abbreviation by its expansion. *) begin try (* if is_newtype env p then raise Cannot_expand; *) @@ -1025,7 +1029,7 @@ | Some (env, newtype_lev) -> let existentials = List.map copy cstr.cstr_existentials in let process existential = - let decl = new_declaration (Some newtype_lev) None in + let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in let (id, new_env) = Env.enter_type (get_new_abstract_name ()) decl !env in env := new_env; @@ -1271,7 +1275,7 @@ end; ty | None -> - let (params, body) = + let (params, body, lv) = try find_type_expansion level path env with Not_found -> raise Cannot_expand in @@ -1284,6 +1288,15 @@ ty.desc <- Tvariant { row with row_name = Some (path, args) } | _ -> () end; + (* For gadts, remember type as non exportable *) + if !Clflags.principal then begin + match lv with + Some lv -> Env.add_gadt_instances env lv [ty; ty'] + | None -> + match Env.gadt_instance_level env ty with + Some lv -> Env.add_gadt_instances env lv [ty'] + | None -> () + end; ty' end | _ -> @@ -1306,15 +1319,7 @@ let try_expand_once env ty = let ty = repr ty in match ty.desc with - Tconstr (p, _, _) -> - let ty' = repr (expand_abbrev env ty) in - if !Clflags.principal then begin - match (Env.find_type p env).type_newtype_level with - Some lv when ty.level < Env.map_newtype_level env lv -> - link_type ty ty' - | _ -> () - end; - ty' + Tconstr (p, _, _) -> repr (expand_abbrev env ty) | _ -> raise Cannot_expand let _ = forward_try_expand_once := try_expand_once @@ -1324,11 +1329,16 @@ May raise Unify, if a recursion was hidden in the type. *) let rec try_expand_head env ty = let ty' = try_expand_once env ty in - begin try - try_expand_head env ty' - with Cannot_expand -> - ty' - end + let ty'' = + try try_expand_head env ty' + with Cannot_expand -> ty' + in + if !Clflags.principal then begin + match Env.gadt_instance_level env ty'' with + None -> () + | Some lv -> Env.add_gadt_instance_chain env lv ty + end; + ty'' (* Expand once the head of a type *) let expand_head_once env ty = @@ -1405,7 +1415,7 @@ *) let generic_abbrev env path = try - let (_, body) = Env.find_type_expansion path env in + let (_, body, _) = Env.find_type_expansion path env in (repr body).level = generic_level with Not_found -> @@ -1742,7 +1752,7 @@ let reify env t = let newtype_level = get_newtype_level () in let create_fresh_constr lev row = - let decl = new_declaration (Some (newtype_level)) None in + let decl = new_declaration (Some (newtype_level, newtype_level)) None in let name = let name = get_new_abstract_name () in if row then name ^ "#row" else name @@ -2065,7 +2075,7 @@ update_level !env t1.level t2; link_type t1 t2 | (Tconstr (p1, [], a1), Tconstr (p2, [], a2)) - when Path.same p1 p2 && actual_mode !env = Old + when Path.same p1 p2 (* && actual_mode !env = Old *) (* This optimization assumes that t1 does not expand to t2 (and conversely), so we fall back to the general case when any of the types has a cached expansion. *) @@ -2091,6 +2101,15 @@ if unify_eq !env t1' t2' then () else let t1 = repr t1 and t2 = repr t2 in + if !Clflags.principal then begin + match Env.gadt_instance_level !env t1',Env.gadt_instance_level !env t2' with + Some lv1, Some lv2 -> + if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else + if lv2 > lv2 then Env.add_gadt_instance_chain !env lv2 t1 + | Some lv1, None -> Env.add_gadt_instance_chain !env lv1 t2 + | None, Some lv2 -> Env.add_gadt_instance_chain !env lv2 t1 + | None, None -> () + end; if unify_eq !env t1 t1' || not (unify_eq !env t2 t2') then unify3 env t1 t1' t2 t2' else Index: typing/env.mli =================================================================== --- typing/env.mli (revision 11214) +++ typing/env.mli (working copy) @@ -33,14 +33,19 @@ val find_cltype: Path.t -> t -> cltype_declaration val find_type_expansion: - ?use_local:bool -> ?level:int -> Path.t -> t -> type_expr list * type_expr -val find_type_expansion_opt: Path.t -> t -> type_expr list * type_expr + ?use_local:bool -> ?level:int -> Path.t -> t -> + type_expr list * type_expr * int option +val find_type_expansion_opt: + Path.t -> t -> type_expr list * type_expr * int option (* Find the manifest type information associated to a type for the sake of the compiler's type-based optimisations. *) val find_modtype_expansion: Path.t -> t -> Types.module_type val has_local_constraints: t -> bool -val map_newtype_level: t -> int -> int +val add_gadt_instance_level: int -> t -> t +val gadt_instance_level: t -> type_expr -> int option +val add_gadt_instances: t -> int -> type_expr list -> unit +val add_gadt_instance_chain: t -> int -> type_expr -> unit (* Lookup by long identifiers *) Index: typing/types.ml =================================================================== --- typing/types.ml (revision 11214) +++ typing/types.ml (working copy) @@ -146,8 +146,8 @@ type_private: private_flag; type_manifest: type_expr option; type_variance: (bool * bool * bool) list; - type_newtype_level: int option } (* covariant, contravariant, weakly contravariant *) + type_newtype_level: (int * int) option } and type_kind = Type_abstract Index: testsuite/tests/typing-gadts/test.ml =================================================================== --- testsuite/tests/typing-gadts/test.ml (revision 11214) +++ testsuite/tests/typing-gadts/test.ml (working copy) @@ -159,17 +159,21 @@ let ky x y = ignore (x = y); x ;; +let test : type a. a t -> a = + function Int -> ky (1 : a) 1 +;; + let test : type a. a t -> a = fun x -> - let r = match x with Int -> ky (1 : a) 1 + let r = match x with Int -> ky (1 : a) 1 (* fails *) in r ;; let test : type a. a t -> a = fun x -> - let r = match x with Int -> ky 1 (1 : a) + let r = match x with Int -> ky 1 (1 : a) (* fails *) in r ;; let test : type a. a t -> a = fun x -> - let r = match x with Int -> (1 : a) - in r (* fails too *) + let r = match x with Int -> (1 : a) (* ok! *) + in r ;; let test : type a. a t -> a = fun x -> let r : a = match x with Int -> 1 @@ -178,7 +182,7 @@ let test2 : type a. a t -> a option = fun x -> let r = ref None in begin match x with Int -> r := Some (1 : a) end; - !r (* normalized to int option *) + !r (* ok *) ;; let test2 : type a. a t -> a option = fun x -> let r : a option ref = ref None in @@ -190,19 +194,19 @@ let u = ref None in begin match x with Int -> r := Some 1; u := !r end; !u -;; (* fail *) +;; (* ok (u non-ambiguous) *) let test2 : type a. a t -> a option = fun x -> let r : a option ref = ref None in let u = ref None in begin match x with Int -> u := Some 1; r := !u end; !u -;; (* fail *) +;; (* fails because u : (int | a) option ref *) let test2 : type a. a t -> a option = fun x -> let u = ref None in let r : a option ref = ref None in begin match x with Int -> r := Some 1; u := !r end; !u -;; (* fail *) +;; (* ok *) let test2 : type a. a t -> a option = fun x -> let u = ref None in let a = @@ -210,32 +214,32 @@ begin match x with Int -> r := Some 1; u := !r end; !u in a -;; (* fail *) +;; (* ok *) (* Effect of external consraints *) let f (type a) (x : a t) y = ignore (y : a); - let r = match x with Int -> (y : a) in (* fails *) + let r = match x with Int -> (y : a) in (* ok *) r ;; let f (type a) (x : a t) y = let r = match x with Int -> (y : a) in - ignore (y : a); (* fails *) + ignore (y : a); (* ok *) r ;; let f (type a) (x : a t) y = ignore (y : a); - let r = match x with Int -> y in + let r = match x with Int -> y in (* ok *) r ;; let f (type a) (x : a t) y = let r = match x with Int -> y in - ignore (y : a); + ignore (y : a); (* ok *) r ;; let f (type a) (x : a t) (y : a) = - match x with Int -> y (* should return an int! *) + match x with Int -> y (* returns 'a *) ;; (* Pattern matching *) @@ -307,4 +311,4 @@ | {left=TE TC; right=D [|1.0|]} -> 14 | {left=TA; right=D 0} -> -1 | {left=TA; right=D z} -> z -;; (* warn *) +;; (* ok *) mingw-ocaml/ocaml/experimental/garrigue/dirs_poly0000644000175000017500000000015112124403240021703 0ustar tootstootsbytecomp byterun driver parsing stdlib tools toplevel typing utils otherlibs/labltk/browser/searchpos.ml mingw-ocaml/ocaml/experimental/garrigue/multimatch.ml0000644000175000017500000000722412124403240022465 0ustar tootstoots(* Simple example *) let f x = (multimatch x with `A -> 1 | `B -> true), (multimatch x with `A -> 1. | `B -> "1");; (* OK *) module M : sig val f : [< `A & 'a = int & 'b = float | `B & 'b =string & 'a = bool] -> 'a * 'b end = struct let f = f end;; (* Bad *) module M : sig val f : [< `A & 'a = int & 'b = float | `B & 'b =string & 'a = int] -> 'a * 'b end = struct let f = f end;; (* Should be good! *) module M : sig val f : [< `A & 'a = int * float | `B & 'a = bool * string] -> 'a end = struct let f = f end;; let f = multifun `A|`B as x -> f x;; (* Two-level example *) let f = multifun `A -> (multifun `C -> 1 | `D -> 1.) | `B -> (multifun `C -> true | `D -> "1");; (* OK *) module M : sig val f : [< `A & 'b = [< `C & 'a = int | `D & 'a = float & 'c = bool] -> 'a | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b end = struct let f = f end;; (* Bad *) module M : sig val f : [< `A & 'b = [< `C & 'a = int | `D & 'a = bool] -> 'a | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b end = struct let f = f end;; module M : sig val f : [< `A & 'b = [< `C & 'a = int | `D] -> 'a | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b end = struct let f = f end;; (* Examples with hidden sharing *) let r = ref [] let f = multifun `A -> 1 | `B -> true let g x = r := [f x];; (* Bad! *) module M : sig val g : [< `A & 'a = int | `B & 'a = bool] -> unit end = struct let g = g end;; let r = ref [] let f = multifun `A -> r | `B -> ref [];; (* Now OK *) module M : sig val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b end = struct let f = f end;; (* Still OK *) let l : int list ref = r;; module M : sig val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b end = struct let f = f end;; (* Examples that would need unification *) let f = multifun `A -> (1, []) | `B -> (true, []) let g x = fst (f x);; (* Didn't work, now Ok *) module M : sig val g : [< `A & 'a * 'b = int * bool | `B & 'a * 'b = bool * int] -> 'a end = struct let g = g end;; let g = multifun (`A|`B) as x -> g x;; (* Other examples *) let f x = let a = multimatch x with `A -> 1 | `B -> "1" in (multifun `A -> print_int | `B -> print_string) x a ;; let f = multifun (`A|`B) as x -> f x;; type unit_op = [`Set of int | `Move of int] type int_op = [`Get] let op r = multifun `Get -> !r | `Set x -> r := x | `Move dx -> r := !r + dx ;; let rec trace r = function [] -> [] | op1 :: ops -> multimatch op1 with #int_op as op1 -> let x = op r op1 in x :: trace r ops | #unit_op as op1 -> op r op1; trace r ops ;; class point x = object val mutable x : int = x method get = x method set y = x <- y method move dx = x <- x + dx end;; let poly sort coeffs x = let add, mul, zero = multimatch sort with `Int -> (+), ( * ), 0 | `Float -> (+.), ( *. ), 0. in let rec compute = function [] -> zero | c :: cs -> add c (mul x (compute cs)) in compute coeffs ;; module M : sig val poly : [< `Int & 'a = int | `Float & 'a = float] -> 'a list -> 'a -> 'a end = struct let poly = poly end;; type ('a,'b) num_sort = 'b constraint 'b = [< `Int & 'a = int | `Float & 'a = float] module M : sig val poly : ('a,_) num_sort -> 'a list -> 'a -> 'a end = struct let poly = poly end;; (* type dispatch *) type num = [ `Int | `Float ] let print0 = multifun `Int -> print_int | `Float -> print_float ;; let print1 = multifun #num as x -> print0 x | `List t -> List.iter (print0 t) | `Pair(t1,t2) -> (fun (x,y) -> print0 t1 x; print0 t2 y) ;; print1 (`Pair(`Int,`Float)) (1,1.0);; mingw-ocaml/ocaml/experimental/garrigue/caml_set_oid.diffs0000644000175000017500000001025412124403240023420 0ustar tootstootsIndex: byterun/intern.c =================================================================== --- byterun/intern.c (revision 11929) +++ byterun/intern.c (working copy) @@ -27,6 +27,7 @@ #include "memory.h" #include "mlvalues.h" #include "misc.h" +#include "obj.h" #include "reverse.h" static unsigned char * intern_src; @@ -139,6 +140,14 @@ dest = (value *) (intern_dest + 1); *intern_dest = Make_header(size, tag, intern_color); intern_dest += 1 + size; + /* For objects, we need to freshen the oid */ + if (tag == Object_tag) { + intern_rec(dest++); + intern_rec(dest++); + caml_set_oid((value)(dest-2)); + size -= 2; + if (size == 0) return; + } for(/*nothing*/; size > 1; size--, dest++) intern_rec(dest); goto tailcall; Index: byterun/obj.c =================================================================== --- byterun/obj.c (revision 11929) +++ byterun/obj.c (working copy) @@ -25,6 +25,7 @@ #include "minor_gc.h" #include "misc.h" #include "mlvalues.h" +#include "obj.h" #include "prims.h" CAMLprim value caml_static_alloc(value size) @@ -212,6 +213,16 @@ return (tag == Field(meths,li) ? Field (meths, li-1) : 0); } +/* Generate ids on the C side, to avoid races */ + +CAMLprim value caml_set_oid (value obj) +{ + static value last_oid = 1; + Field(obj,1) = last_oid; + last_oid += 2; + return obj; +} + /* these two functions might be useful to an hypothetical JIT */ #ifdef CAML_JIT Index: byterun/obj.h =================================================================== --- byterun/obj.h (revision 0) +++ byterun/obj.h (revision 0) @@ -0,0 +1,28 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Jacques Garrigue, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +/* Primitives for the Obj and CamlinternalOO modules */ + +#ifndef CAML_OBJ_H +#define CAML_OBJ_H + +#include "misc.h" +#include "mlvalues.h" + +/* Set the OID of an object to a fresh value */ +/* returns the same object as result */ +value caml_set_oid (value obj); + +#endif /* CAML_OBJ_H */ Index: stdlib/camlinternalOO.ml =================================================================== --- stdlib/camlinternalOO.ml (revision 11929) +++ stdlib/camlinternalOO.ml (working copy) @@ -15,23 +15,15 @@ open Obj -(**** Object representation ****) +(**** OID handling ****) -let last_id = ref 0 -let new_id () = - let id = !last_id in incr last_id; id +external set_oid : t -> t = "caml_set_oid" "noalloc" -let set_id o id = - let id0 = !id in - Array.unsafe_set (Obj.magic o : int array) 1 id0; - id := id0 + 1 - (**** Object copy ****) let copy o = - let o = (Obj.obj (Obj.dup (Obj.repr o))) in - set_id o last_id; - o + let o = Obj.dup (Obj.repr o) in + Obj.obj (set_oid o) (**** Compression options ****) (* Parameters *) @@ -355,8 +347,7 @@ let obj = Obj.new_block Obj.object_tag table.size in (* XXX Appel de [caml_modify] *) Obj.set_field obj 0 (Obj.repr table.methods); - set_id obj last_id; - (Obj.obj obj) + Obj.obj (set_oid obj) let create_object_opt obj_0 table = if (Obj.magic obj_0 : bool) then obj_0 else begin @@ -364,8 +355,7 @@ let obj = Obj.new_block Obj.object_tag table.size in (* XXX Appel de [caml_modify] *) Obj.set_field obj 0 (Obj.repr table.methods); - set_id obj last_id; - (Obj.obj obj) + Obj.obj (set_oid obj) end let rec iter_f obj = mingw-ocaml/ocaml/experimental/garrigue/with-module-type.diffs0000644000175000017500000001616412124403240024221 0ustar tootstootsIndex: parsing/parser.mly =================================================================== --- parsing/parser.mly (revision 12005) +++ parsing/parser.mly (working copy) @@ -1504,6 +1504,10 @@ { ($2, Pwith_module $4) } | MODULE mod_longident COLONEQUAL mod_ext_longident { ($2, Pwith_modsubst $4) } + | MODULE TYPE mod_longident EQUAL module_type + { ($3, Pwith_modtype $5) } + | MODULE TYPE mod_longident COLONEQUAL module_type + { ($3, Pwith_modtypesubst $5) } ; with_type_binder: EQUAL { Public } Index: parsing/parsetree.mli =================================================================== --- parsing/parsetree.mli (revision 12005) +++ parsing/parsetree.mli (working copy) @@ -239,6 +239,8 @@ | Pwith_module of Longident.t | Pwith_typesubst of type_declaration | Pwith_modsubst of Longident.t + | Pwith_modtype of module_type + | Pwith_modtypesubst of module_type (* Value expressions for the module language *) Index: parsing/printast.ml =================================================================== --- parsing/printast.ml (revision 12005) +++ parsing/printast.ml (working copy) @@ -575,6 +575,12 @@ type_declaration (i+1) ppf td; | Pwith_module (li) -> line i ppf "Pwith_module %a\n" fmt_longident li; | Pwith_modsubst (li) -> line i ppf "Pwith_modsubst %a\n" fmt_longident li; + | Pwith_modtype (mty) -> + line i ppf "Pwith_modtype\n"; + module_type (i+1) ppf mty; + | Pwith_modtypesubst (mty) -> + line i ppf "Pwith_modtype\n"; + module_type (i+1) ppf mty; and module_expr i ppf x = line i ppf "module_expr %a\n" fmt_location x.pmod_loc; Index: typing/typemod.ml =================================================================== --- typing/typemod.ml (revision 12005) +++ typing/typemod.ml (working copy) @@ -74,6 +74,8 @@ : (Env.t -> Parsetree.module_expr -> module_type) ref = ref (fun env m -> assert false) +let transl_modtype_fwd = ref (fun env m -> assert false) + (* Merge one "with" constraint in a signature *) let rec add_rec_types env = function @@ -163,6 +165,19 @@ ignore(Includemod.modtypes env newmty mty); real_id := Some id; make_next_first rs rem + | (Tsig_modtype(id, mtd) :: rem, [s], Pwith_modtype pmty) + when Ident.name id = s -> + let mty = !transl_modtype_fwd initial_env pmty in + let mtd' = Tmodtype_manifest mty in + Includemod.modtype_declarations env id mtd' mtd; + Tsig_modtype(id, mtd') :: rem + | (Tsig_modtype(id, mtd) :: rem, [s], Pwith_modtypesubst pmty) + when Ident.name id = s -> + let mty = !transl_modtype_fwd initial_env pmty in + let mtd' = Tmodtype_manifest mty in + Includemod.modtype_declarations env id mtd' mtd; + real_id := Some id; + rem | (Tsig_module(id, mty, rs) :: rem, s :: namelist, _) when Ident.name id = s -> let newsg = merge env (extract_sig env loc mty) namelist None in @@ -200,6 +215,12 @@ let (path, _) = Typetexp.find_module initial_env loc lid in let sub = Subst.add_module id path Subst.identity in Subst.signature sub sg + | [s], Pwith_modtypesubst pmty -> + let id = + match !real_id with None -> assert false | Some id -> id in + let mty = !transl_modtype_fwd initial_env pmty in + let sub = Subst.add_modtype id mty Subst.identity in + Subst.signature sub sg | _ -> sg with Includemod.Error explanation -> @@ -499,6 +520,8 @@ check_recmod_typedecls env2 sdecls dcl2; (dcl2, env2) +let () = transl_modtype_fwd := transl_modtype + (* Try to convert a module expression to a module path. *) exception Not_a_path Index: typing/includemod.ml =================================================================== --- typing/includemod.ml (revision 12005) +++ typing/includemod.ml (working copy) @@ -326,10 +326,10 @@ (* Hide the context and substitution parameters to the outside world *) -let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2 -let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2 -let type_declarations env id decl1 decl2 = - type_declarations env [] Subst.identity id decl1 decl2 +let modtypes env = modtypes env [] Subst.identity +let signatures env = signatures env [] Subst.identity +let type_declarations env = type_declarations env [] Subst.identity +let modtype_declarations env = modtype_infos env [] Subst.identity (* Error report *) Index: typing/includemod.mli =================================================================== --- typing/includemod.mli (revision 12005) +++ typing/includemod.mli (working copy) @@ -23,6 +23,8 @@ val compunit: string -> signature -> string -> signature -> module_coercion val type_declarations: Env.t -> Ident.t -> type_declaration -> type_declaration -> unit +val modtype_declarations: + Env.t -> Ident.t -> modtype_declaration -> modtype_declaration -> unit type symptom = Missing_field of Ident.t Index: testsuite/tests/typing-modules/Test.ml.reference =================================================================== --- testsuite/tests/typing-modules/Test.ml.reference (revision 12005) +++ testsuite/tests/typing-modules/Test.ml.reference (working copy) @@ -6,4 +6,12 @@ # type -'a t class type c = object method m : [ `A ] t end # module M : sig val v : (#c as 'a) -> 'a end +# module type S = sig module type T module F : functor (X : T) -> T end +# module type T0 = sig type t end +# module type S1 = sig module type T = T0 module F : functor (X : T) -> T end +# module type S2 = sig module F : functor (X : T0) -> T0 end +# module type S3 = + sig + module F : functor (X : sig type t = int end) -> sig type t = int end + end # Index: testsuite/tests/typing-modules/Test.ml.principal.reference =================================================================== --- testsuite/tests/typing-modules/Test.ml.principal.reference (revision 12005) +++ testsuite/tests/typing-modules/Test.ml.principal.reference (working copy) @@ -6,4 +6,12 @@ # type -'a t class type c = object method m : [ `A ] t end # module M : sig val v : (#c as 'a) -> 'a end +# module type S = sig module type T module F : functor (X : T) -> T end +# module type T0 = sig type t end +# module type S1 = sig module type T = T0 module F : functor (X : T) -> T end +# module type S2 = sig module F : functor (X : T0) -> T0 end +# module type S3 = + sig + module F : functor (X : sig type t = int end) -> sig type t = int end + end # Index: testsuite/tests/typing-modules/Test.ml =================================================================== --- testsuite/tests/typing-modules/Test.ml (revision 12005) +++ testsuite/tests/typing-modules/Test.ml (working copy) @@ -9,3 +9,11 @@ class type c = object method m : [ `A ] t end;; module M : sig val v : (#c as 'a) -> 'a end = struct let v x = ignore (x :> c); x end;; + +(* with module type *) + +module type S = sig module type T module F(X:T) : T end;; +module type T0 = sig type t end;; +module type S1 = S with module type T = T0;; +module type S2 = S with module type T := T0;; +module type S3 = S with module type T := sig type t = int end;; mingw-ocaml/ocaml/experimental/garrigue/dirs_multimatch0000644000175000017500000000005012124403240023065 0ustar tootstootsparsing typing bytecomp driver toplevel mingw-ocaml/ocaml/experimental/garrigue/newlabels.ps0000644000175000017500000026251712124403240022314 0ustar tootstoots%!PS-Adobe-2.0 %%Creator: dvipsk 5.78 p1.4 Copyright 1996-98 ASCII Corp.(www-ptex@ascii.co.jp) %%dvipsk 5.78 Copyright 1998 Radical Eye Software (www.radicaleye.com) %%Title: newlabels.dvi %%Pages: 2 0 %%PageOrder: Ascend %%BoundingBox: 0 0 596 842 %%EndComments %%BeginProcSet: PStoPS 1 15 userdict begin [/showpage/erasepage/copypage]{dup where{pop dup load type/operatortype eq{1 array cvx dup 0 3 index cvx put bind def}{pop}ifelse}{pop}ifelse}forall [/letter/legal/executivepage/a4/a4small/b5/com10envelope /monarchenvelope/c5envelope/dlenvelope/lettersmall/note /folio/quarto/a5]{dup where{dup wcheck{exch{}put} {pop{}def}ifelse}{pop}ifelse}forall /setpagedevice {pop}bind 1 index where{dup wcheck{3 1 roll put} {pop def}ifelse}{def}ifelse /PStoPSmatrix matrix currentmatrix def /PStoPSxform matrix def/PStoPSclip{clippath}def /defaultmatrix{PStoPSmatrix exch PStoPSxform exch concatmatrix}bind def /initmatrix{matrix defaultmatrix setmatrix}bind def /initclip[{matrix currentmatrix PStoPSmatrix setmatrix [{currentpoint}stopped{$error/newerror false put{newpath}} {/newpath cvx 3 1 roll/moveto cvx 4 array astore cvx}ifelse] {[/newpath cvx{/moveto cvx}{/lineto cvx} {/curveto cvx}{/closepath cvx}pathforall]cvx exch pop} stopped{$error/errorname get/invalidaccess eq{cleartomark $error/newerror false put cvx exec}{stop}ifelse}if}bind aload pop /initclip dup load dup type dup/operatortype eq{pop exch pop} {dup/arraytype eq exch/packedarraytype eq or {dup xcheck{exch pop aload pop}{pop cvx}ifelse} {pop cvx}ifelse}ifelse {newpath PStoPSclip clip newpath exec setmatrix} bind aload pop]cvx def /initgraphics{initmatrix newpath initclip 1 setlinewidth 0 setlinecap 0 setlinejoin []0 setdash 0 setgray 10 setmiterlimit}bind def end %%EndProcSet %DVIPSCommandLine: dvips -f newlabels %DVIPSParameters: dpi=300 %DVIPSSource: TeX output 1999.10.26:1616 %%BeginProcSet: tex.pro %! /TeXDict 300 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N /X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72 mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1} ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul TR[matrix currentmatrix{dup dup round sub abs 0.00001 lt{round}if} forall round exch round exch]setmatrix}N /@landscape{/isls true N}B /@manualfeed{statusdict /manualfeed true put}B /@copies{/#copies X}B /FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{ /nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N string /base X array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{ /sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0] N df-tail}B /E{pop nn dup definefont setfont}B /ch-width{ch-data dup length 5 sub get}B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{ 128 ch-data dup length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub get 127 sub}B /ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data dup type /stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N /rc 0 N /gp 0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup /base get 2 index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx 0 ch-xoff ch-yoff ch-height sub ch-xoff ch-width add ch-yoff setcachedevice ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff .1 sub]{ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]} if nn /base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup length 1 sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{ cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin 0 0 moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul add .99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore userdict /eop-hook known{eop-hook}if showpage}N /@start{userdict /start-hook known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X /IE 256 array N 2 string 0 1 255{IE S dup 360 add 36 4 index cvrs cvn put}for pop 65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N /RMat[1 0 0 -1 0 0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley X /rulex X V}B /V{}B /RV statusdict begin /product where{pop false[ (Display)(NeXT)(LaserWriter 16/600)]{dup length product length le{dup length product exch 0 exch getinterval eq{pop true exit}if}{pop}ifelse} forall}{false}ifelse end{{gsave TR -.1 .1 TR 1 1 scale rulex ruley false RMat{BDot}imagemask grestore}}{{gsave TR -.1 .1 TR rulex ruley scale 1 1 false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave newpath transform round exch round exch itransform moveto rulex 0 rlineto 0 ruley neg rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta 0 N /tail {dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M} B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{3 M}B /k{ 4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p -1 w}B /q{ p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{3 2 roll p a}B /bos{/SS save N}B /eos{SS restore}B end %%EndProcSet TeXDict begin 39158280 55380996 1000 300 300 (newlabels.dvi) @start %DVIPSBitmapFont: Fa cmr6 6 2 /Fa 2 51 df<187898181818181818181818181818FF08107D8F0F> 49 D<1F00618040C08060C0600060006000C00180030006000C00102020207FC0FFC00B107F 8F0F> I E %EndDVIPSBitmapFont %DVIPSBitmapFont: Fb cmmi8 8 4 /Fb 4 111 df 85 D<0300038003000000000000000000000000001C00240046 0046008C000C0018001800180031003100320032001C0009177F960C> 105 D<383C1E0044C6630047028100460301008E0703000C0603000C0603000C060300180C06 00180C0620180C0C20180C0C40301804C0301807001B0E7F8D1F> 109 D<383C0044C6004702004602008E06000C06000C06000C0600180C00180C401818401818 80300980300E00120E7F8D15> I E %EndDVIPSBitmapFont %DVIPSBitmapFont: Fc cmbx8 8 4 /Fc 4 111 df<01800780FF80FF80078007800780078007800780078007800780078007 800780078007800780FFF8FFF80D157D9414> 49 D<387C7C7C3800000000FCFC3C3C3C 3C3C3C3C3C3C3C3CFFFF08187F970B> 105 D 109 D I E %EndDVIPSBitmapFont %DVIPSBitmapFont: Fd cmsy8 8 3 /Fd 3 93 df 0 D<020002000200C218F2783AE00F800F80 3AE0F278C2180200020002000D0E7E8E12> 3 D<03F8001FFF003C07806000C0C00060C0 0060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C0 006040002013137E9218> 92 D E %EndDVIPSBitmapFont %DVIPSBitmapFont: Fe cmtt12 12 43 /Fe 43 125 df<01818003C3C003C3C003C3C003C3C003C3C003C3C07FFFF0FFFFF8FFFF F87FFFF00787800787800787800F8F800F0F000F0F000F0F000F0F007FFFF0FFFFF8FFFF F87FFFF01E1E001E1E001E1E001E1E001E1E001E1E000C0C00151E7E9D1A> 35 D<00E00003F00007F8000738000E1C000E1C000E1C000E1C000E38000E39FC0E71FC07F1 FC07E1C007C1C00781C00783800F83801FC3803DC70078E70070EE00E07E00E07E00E03C 08E03C1CE07E1C70FF1C7FE7F83FC3F80F00E0161E7F9D1A> 38 D<0038007800F001E003C007800F000E001C001C0038003800700070007000E000E000E0 00E000E000E000E000E000E000E000700070007000380038001C001C000E000F00078003 C001E000F8007800380D2878A21A> 40 D<6000F00078003C001E000F000780038001C0 01C000E000E0007000700070003800380038003800380038003800380038003800700070 007000E000E001C001C0038007800F001E003C007800F00060000D287CA21A> I<7FFFC0 FFFFE0FFFFE07FFFC013047D901A> 45 D<00C001C001C003C007C00FC07FC0FDC071C0 01C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C0 7FFF7FFF7FFF101E7B9D1A> 49 D<03F8000FFE001FFF803C07C07801E07000E0E00070 F00070F000706000700000700000700000E00000E00001C00003C0000780000F00001E00 003C0000780000F00003E00007C0000F00001E00703C00707FFFF0FFFFF07FFFF0141E7D 9D1A> I<03FC000FFF003FFFC03C03E07800E07800707800700000700000700000E00001 E00007C003FF8003FF0003FFC00003E00000E0000070000078000038000038600038F000 38F00078E000707000E07E03E03FFFC00FFF0001FC00151E7E9D1A> I<01FC0007FF001F FFC01F07C03C01E07800F07000707000707000707800F03800E01E03C00FFF8003FE0007 FF001F8FC03C01E07800F0700070E00038E00038E00038E00038F000787000707800F03E 03E01FFFC007FF0001FC00151E7E9D1A> 56 D<01F00007FC001FFE003E0F0038078070 03807001C0E001C0E001C0E001E0E000E0E000E0E001E07001E07803E03C0FE01FFFE00F FCE003F0E00001C00001C00001C0000380600380F00700F00F00F03E007FFC003FF0000F C000131E7D9D1A> I<3078FCFC78300000000000000000003078FCFC7830061576941A> I<183C7E7E3C18000000000000000000183C7E7E3E1E0E0E1C3CF8F060071C77941A> I< 0000C00003E00007E0000FC0003F80007E0000FC0003F80007E0000FC0003F80007E0000 FC0000FC00007E00003F80000FC00007E00003F80000FC00007E00003F80000FC00007E0 0003E00000C0131A7D9B1A> I<7FFFF0FFFFF8FFFFF87FFFF00000000000000000000000 007FFFF0FFFFF8FFFFF87FFFF0150C7E941A> I<600000F80000FC00007E00003F80000F C00007E00003F80000FC00007E00003F80000FC00007E00007E0000FC0003F80007E0000 FC0003F80007E0000FC0003F80007E0000FC0000F80000600000131A7D9B1A> I<007C38 01FF3807FFF80F83F81E00F81C0078380078380038700038700038700000E00000E00000 E00000E00000E00000E00000E00000E000007000007000387000383800383800381C0070 1E00F00F83E007FFC001FF80007C00151E7E9D1A> 67 D 78 D<03F8E00FFEE01FFFE03C07E07801E0F001E0E000E0 E000E0E000E0E000007000007800003F80001FF80007FF00007FC00007E00000F0000070 000038000038600038E00038E00038E00070F000F0FE01E0FFFFC0EFFF80E1FE00151E7E 9D1A> 83 D<7FFFFEFFFFFEFFFFFEE0380EE0380EE0380EE0380E003800003800003800 003800003800003800003800003800003800003800003800003800003800003800003800 00380000380000380000380000380003FF8003FF8003FF80171E7F9D1A> I 91 D 93 D<1FF0003FFC007FFE00780F 00300700000380000380007F8007FF801FFF803F8380780380700380E00380E00380E003 80700780780F803FFFFC1FFDFC07F0FC16157D941A> 97 D<7E0000FE00007E00000E00 000E00000E00000E00000E00000E00000E3E000EFF800FFFE00FC1F00F80700F00380E00 380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF C00EFF80063E00161E7F9D1A> I<00FF8003FFC00FFFE01F01E03C00C078000070000070 0000E00000E00000E00000E00000E000007000007000007800703C00701F01F00FFFE003 FFC000FE0014157D941A> I<000FC0001FC0000FC00001C00001C00001C00001C00001C0 0001C001F1C007FDC00FFFC01E0FC03C07C07803C07001C0E001C0E001C0E001C0E001C0 E001C0E001C0E001C07003C07003C03807C03E0FC01FFFF807FDFC01F1F8161E7E9D1A> I<01F80007FF000FFF801E07C03C01C07800E07000E0E00070E00070FFFFF0FFFFF0FFFF F0E000007000007000007800703C00701F01F00FFFE003FF8000FE0014157D941A> I<00 07E0001FF0003FF800787800F03000E00000E00000E00000E0007FFFF0FFFFF0FFFFF000 E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000 E00000E00000E0003FFF807FFFC03FFF80151E7F9D1A> I<7E0000FE00007E00000E0000 0E00000E00000E00000E00000E00000E3E000EFF800FFFC00FC1C00F80E00F00E00E00E0 0E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E07FC3FC FFE7FE7FC3FC171E7F9D1A> 104 D<00C00001E00001E00000C000000000000000000000 0000000000000000007FE0007FE0007FE00000E00000E00000E00000E00000E00000E000 00E00000E00000E00000E00000E00000E00000E00000E00000E0007FFF80FFFFC07FFF80 121F7C9E1A> I<7FE000FFE0007FE00000E00000E00000E00000E00000E00000E00000E0 0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0 0000E00000E00000E00000E00000E0007FFFC0FFFFE07FFFC0131E7D9D1A> 108 D<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C001C1C1C001C1C1C 001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C 007F1F1F00FFBFBF807F1F1F00191580941A> I<7E3E00FEFF807FFFC00FC1C00F80E00F 00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E 00E07FC3FCFFE7FE7FC3FC17157F941A> I<01F00007FC001FFF003E0F803C07807803C0 7001C0E000E0E000E0E000E0E000E0E000E0E000E0F001E07001C07803C03C07803E0F80 1FFF0007FC0001F00013157D941A> I<7E3E00FEFF807FFFE00FC1F00F80700F00380E00 380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF C00EFF800E3E000E00000E00000E00000E00000E00000E00000E00000E00007FC000FFE0 007FC00016207F941A> I<7F81F8FF8FFC7F9FFE03FE1E03F80C03E00003E00003C00003 80000380000380000380000380000380000380000380000380000380007FFF00FFFF007F FF0017157F941A> 114 D<07FB801FFF807FFF80780780E00380E00380E003807800007F C0001FFC0007FE00003F800007806001C0E001C0E001C0F003C0FC0780FFFF00EFFE00E3 F80012157C941A> I<0180000380000380000380000380000380000380007FFFE0FFFFE0 FFFFE0038000038000038000038000038000038000038000038000038000038000038070 03807003807003807001C1E001FFE000FF80003F00141C7F9B1A> I<7E07E0FE0FE07E07 E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00 E00E00E00E01E00F03E007FFFC03FFFE00FCFC17157F941A> I<7F83FCFFC7FE7F83FC0E 00E00E00E00E00E00701C00701C00701C003838003838003838001C70001C70001C70000 EE0000EE0000EE00007C00007C0000380017157F941A> I I<7FC7F87FCFFC7FC7F80703C00383 8003C70001EF0000FE00007C00007800003800007C0000EE0001EE0001C7000383800783 C00F01C07FC7FCFFC7FE7FC7FC17157F941A> I<7F83FCFFC7FE7F83FC0E00E00E00E007 00E00701C00701C00381C003838003C38001C38001C70000E70000E70000E60000660000 6E00003C00003C00003C0000380000380000380000700000700030F00078E00071E0007F C0003F80001E000017207F941A> I<60F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0 F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F060042775A21A> 124 D E %EndDVIPSBitmapFont %DVIPSBitmapFont: Ff cmr8 8 3 /Ff 3 51 df<003000003000003000003000003000003000003000003000003000003000 003000FFFFFCFFFFFC003000003000003000003000003000003000003000003000003000 00300000300016187E931B> 43 D<06000E00FE000E000E000E000E000E000E000E000E 000E000E000E000E000E000E000E000E000E00FFE00B157D9412> 49 D<0F8030E040708030C038E0384038003800700070006000C00180030006000C08080810 183FF07FF0FFF00D157E9412> I E %EndDVIPSBitmapFont %DVIPSBitmapFont: Fg cmmi12 12 13 /Fg 13 121 df<0FFFF81FFFFC3FFFF870200040200080200080600000600000600000C0 0000C00000C00000C00001C0000180000180000380000380000380000700000300001615 7E9415> 28 D<0000100000002000000020000000200000002000000040000000400000 004000000040000000800000008000000080000000800000010000000FE00000711C0001 C10600030203000E0203801C020180180201C0380401C0700401C0700401C0700401C0E0 080380E0080380E00807006008070070100E0030101C00301038001C10E0000623800001 FE0000002000000020000000400000004000000040000000400000008000000080000000 800000008000001A2D7EA21D> 30 D<70F8F8F87005057C840E> 58 D<70F8FCFC7404040404080810102040060F7C840E> I<00008000018000018000030000 0300000300000600000600000600000C00000C00000C0000180000180000180000300000 300000300000600000600000600000C00000C00000C00001800001800001800001800003 00000300000300000600000600000600000C00000C00000C000018000018000018000030 0000300000300000600000600000600000C00000C00000C0000011317DA418> 61 D<00FFFC00000F8000000F0000000F0000001E0000001E0000001E0000001E0000003C00 00003C0000003C0000003C00000078000000780000007800000078000000F0000000F000 0000F0000000F0000001E0000001E0000001E0002001E0002003C0004003C0004003C000 8003C0008007800180078001000780030007800F000F803E00FFFFFE001B227DA121> 76 D<1FFFFFFE1E01E00E1801E0063001E0062003C0062003C0064003C0044003C004400780 04800780048007800400078000000F0000000F0000000F0000000F0000001E0000001E00 00001E0000001E0000003C0000003C0000003C0000003C00000078000000780000007800 000078000000F0000000F0000000F0000000F0000001F000007FFFC0001F227EA11D> 84 D<3FFE01FF8003C0003C0003C000300003C0001000078000200007800020000780002000 07800020000F000040000F000040000F000040000F000040001E000080001E000080001E 000080001E000080003C000100003C000100003C000100003C0001000078000200007800 020000780002000078000200007000040000F000040000F0000800007000080000700010 00007000200000380040000038008000001C01000000060600000001F800000021237DA1 21> I<007E000381000700800E00801C0080380080780100700600FFF800F00000F00000 E00000E00000E00000E00000E00080E000807003003004001838000FC00011157D9417> 101 D<01E00FC001C001C001C0038003800380038007000700070007000E000E000E000E 001C001C001C001C0038003800380038007000700070007080E100E100E100620062003C 000B237EA20F> 108 D<03C0F004631C04740E08780E08700708700708700F00E00F00E0 0F00E00F00E00F01C01E01C01E01C01E01C03C03803803803803C07003C0E0072180071E 000700000700000E00000E00000E00000E00001C00001C00001C0000FF8000181F819418 > 112 D<3C0F004630C04741C08783C08783C08701808700000E00000E00000E00000E00 001C00001C00001C00001C000038000038000038000038000070000030000012157E9416 > 114 D<01E0F006310C081A1C101A3C201C3C201C18201C000038000038000038000038 0000700000700000700000700860E010F0E010F0E020E170404230803C1F0016157E941C > 120 D E %EndDVIPSBitmapFont %DVIPSBitmapFont: Fh cmti12 12 22 /Fh 22 122 df 45 D<70F8F8F0E005057A840F> I<00F8 C00185C00705C00E03800E03801C03803C0380380700780700780700780700F00E00F00E 00F00E00F00E10F01C20701C20703C20305C40308C400F078014157B9419> 97 D<03C01F8003800380038007000700070007000E000E000E000E001C001CF81D0C1E0E3C 0638073807380F700F700F700F700FE01EE01EE01EE03CE038E038607060E031C01F0010 237BA216> I<007E0001C1000301800703800E07801C07803C0000380000780000780000 780000F00000F00000F00000F00000F00100700100700200300C001830000FC00011157B 9416> I<00003C0003F80000380000380000380000700000700000700000700000E00000 E00000E00000E00001C000F9C00185C00705C00E03800E03801C03803C03803807007807 00780700780700F00E00F00E00F00E00F00E10F01C20701C20703C20305C40308C400F07 8016237BA219> I<00F803840E021C023C0238027804F018FFE0F000F000E000E000E000 E000E002E0026004701830600F800F157A9416> I<00003E0000470000CF00018F000186 000380000380000380000700000700000700000700000700000E0000FFF0000E00000E00 000E00001C00001C00001C00001C00001C00003800003800003800003800003800007000 00700000700000700000700000E00000E00000E00000E00000C00001C00001C000718000 F18000F300006200003C0000182D82A20F> I<001F180030B800E0B801C07001C0700380 700780700700E00F00E00F00E00F00E01E01C01E01C01E01C01E01C01E03800E03800E07 80060B8006170001E700000700000700000E00000E00000E00701C00F01800F0300060E0 003F8000151F7E9416> I<00C001E001C001C0000000000000000000000000000000001E 002300430043008700870087000E000E001C001C001C0038003800384070807080708071 0032001C000B217BA00F> 105 D<00F00007E00000E00000E00000E00001C00001C00001 C00001C0000380000380000380000380000700000701E00702100704700E08F00E10F00E 20600E40001D80001E00001FC0001C7000383800383800381C00381C2070384070384070 3840701880E01880600F0014237DA216> 107 D<01E00FC001C001C001C0038003800380 038007000700070007000E000E000E000E001C001C001C001C0038003800380038007000 700070007100E200E200E200E200640038000B237CA20C> I<1C0F80F8002610C10C0047 6066060087807807008780780700870070070087007007000E00E00E000E00E00E000E00 E00E000E00E00E001C01C01C001C01C01C001C01C01C001C01C038203803803840380380 70403803807080380380308070070031003003001E0023157B9428> I<380F804C30C04E 40608E80708F00708E00708E00701C00E01C00E01C00E01C00E03801C03801C03801C038 0384700388700308700708700310E003106001E016157B941B> I<007E0001C300038180 0701C00E01C01C01E03C01E03801E07801E07801E07801E0F003C0F003C0F00380F00780 700700700E00700C0030180018700007C00013157B9419> I<01C1F002621804741C0878 0C08700E08700E08701E00E01E00E01E00E01E00E01E01C03C01C03C01C03C01C0780380 7003807003C0E003C1C0072380071E000700000700000E00000E00000E00000E00001C00 001C00001C0000FFC000171F7F9419> I<1C1F002620804741C08783C08703C087018087 00000E00000E00000E00000E00001C00001C00001C00001C000038000038000038000038 000070000030000012157B9415> 114 D<00FC000183000200800401800C03800C03000C 00000F00000FF00007FC0003FE00003E00000F00000700700700F00600F00600E0040040 08002030001FC00011157D9414> I<00C001C001C001C001C003800380038003800700FF F8070007000E000E000E000E001C001C001C001C00380038003800381070207020704070 8031001E000D1F7C9E10> I<1E0060E02300E0F04380E1F04381C0F08381C0708701C030 8701C030070380200E0380200E0380200E0380201C0700401C0700401C0700401C070080 1C0700801C0701001C0F01000C0B02000613840003E0F8001C157B9420> 119 D<03C1E0046210083470103CF02038F020386020380000700000700000700000700000E0 0000E00000E00000E02061C040F1C040F1C080E2C100446200383C0014157D9416> I<1E 00302300704380704380E08380E08700E08700E00701C00E01C00E01C00E01C01C03801C 03801C03801C03801C07001C07001C07001C0F000C3E0003CE00000E00000E00001C0060 1C00F03800F03000E0600080C0004380003E0000141F7B9418> I E %EndDVIPSBitmapFont %DVIPSBitmapFont: Fi cmbx12 12 20 /Fi 20 122 df 68 D<01FE0207FF861F01FE3C007E7C001E78000E78000EF80006F80006FC0006 FC0000FF0000FFE0007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FE00007F 00003F00003FC0001FC0001FC0001FE0001EE0001EF0003CFC003CFF00F8C7FFE080FF80 18227DA11F> 83 D<7FFFFFFF807FFFFFFF807E03F80F807803F807807003F803806003 F80180E003F801C0E003F801C0C003F800C0C003F800C0C003F800C0C003F800C00003F8 00000003F800000003F800000003F800000003F800000003F800000003F800000003F800 000003F800000003F800000003F800000003F800000003F800000003F800000003F80000 0003F800000003F800000003F800000003F800000003F8000001FFFFF00001FFFFF00022 227EA127> I<0FFC003FFF807E07C07E03E07E01E07E01F03C01F00001F00001F0003FF0 03FDF01FC1F03F01F07E01F0FC01F0FC01F0FC01F0FC01F07E02F07E0CF81FF87F07E03F 18167E951B> 97 D I<00FF8007FFE00F83F01F03F03E03F07E03F07C01E07C0000 FC0000FC0000FC0000FC0000FC0000FC00007C00007E00007E00003E00181F00300FC060 07FFC000FF0015167E9519> I<00FE0007FF800F87C01E01E03E01F07C00F07C00F8FC00 F8FC00F8FFFFF8FFFFF8FC0000FC0000FC00007C00007C00007E00003E00181F00300FC0 7003FFC000FF0015167E951A> 101 D<001FC0007FE000F1F001E3F003E3F007C3F007C1 E007C00007C00007C00007C00007C00007C000FFFE00FFFE0007C00007C00007C00007C0 0007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C0 0007C00007C0003FFC003FFC00142380A211> I<01FE0F0007FFBF800F87C7801F03E780 1E01E0003E01F0003E01F0003E01F0003E01F0003E01F0001E01E0001F03E0000F87C000 0FFF800009FE000018000000180000001C0000001FFFE0000FFFF80007FFFE001FFFFF00 3C003F0078000F80F0000780F0000780F0000780F000078078000F003C001E001F007C00 0FFFF80001FFC00019217F951C> I<1C003E007F007F007F003E001C0000000000000000 00000000000000FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F 001F001F001F001F001F00FFE0FFE00B247EA310> 105 D 108 D I I<00FE0007FFC00F83E01E00F03E00F87C00 7C7C007C7C007CFC007EFC007EFC007EFC007EFC007EFC007EFC007E7C007C7C007C3E00 F81F01F00F83E007FFC000FE0017167E951C> I I<0FF3003FFF00781F00600700E00300E00300F00300FC00007F E0007FF8003FFE000FFF0001FF00000F80C00780C00380E00380E00380F00700FC0E00EF FC00C7F00011167E9516> 115 D<01800001800001800001800003800003800007800007 80000F80003F8000FFFF00FFFF000F80000F80000F80000F80000F80000F80000F80000F 80000F80000F80000F80000F81800F81800F81800F81800F81800F830007C30003FE0000 F80011207F9F16> I I 120 D I E %EndDVIPSBitmapFont %DVIPSBitmapFont: Fj cmsy10 12 15 /Fj 15 107 df 0 D<03F0000FFC001FFE003FFF007F FF807FFF80FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC07FFF807FFF803F FF001FFE000FFC0003F00012147D9519> 15 D<000FFFFC007FFFFC01F0000003800000 060000000C0000001800000030000000300000006000000060000000C0000000C0000000 C0000000C0000000C0000000C0000000C0000000C0000000600000006000000030000000 30000000180000000C000000060000000380000001E00000007FFFFC001FFFFC1E1E7C9A 27> 26 D<00000001800000000001800000000001800000000001800000000000C00000 000000C000000000006000000000003000000000003000000000001C00000000000E0000 0000000700FFFFFFFFFFE0FFFFFFFFFFE0000000000700000000000E00000000001C0000 000000300000000000300000000000600000000000C00000000000C00000000001800000 00000180000000000180000000000180002B1A7D9832> 33 D<001FFF007FFF01E00003 80000600000C0000180000300000300000600000600000600000C00000C00000FFFFFFFF FFFFC00000C000006000006000006000003000003000001800000C000006000003800001 E000007FFF001FFF181E7C9A21> 50 D<00000300000300000600000600000C00000C00 00180000180000300000300000600000600000C00000C00000C000018000018000030000 0300000600000600000C00000C0000180000180000300000300000600000600000C00000 C0000180000180000300000300000300000600000600000C00000C000018000018000030 0000300000600000600000C00000400000183079A300> 54 D I<00008000018001F980070F000C0300180380180780 3006C03006C0700CE0600C60600C60600C60E01870E01870E01870E03070E03070E03070 E06070E06070E06070E06070E0C070E0C070E0C070E18070E180706180606300607300E0 7300E03300C03600C01E01801E01800C03000F0E000DF800180000180000180000142A7E A519> 59 D<000100000003000000030000000300000003000000030000000300000003 000000030000000300000003000000030000000300000003000000030000000300000003 000000030000000300000003000000030000000300000003000000030000000300000003 000000030000000300000003000000030000FFFFFFFEFFFFFFFE1F207C9F27> 63 D<40000040C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000 C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000 C0C00000C0C00000C0C00000C0C00000C0C00000C0600001806000018030000300180006 000E001C000780780001FFE000007F80001A1F7D9D21> 91 D<007F800001FFE0000780 78000E001C0018000600300003006000018060000180C00000C0C00000C0C00000C0C000 00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000 00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000 00C0400000401A1F7D9D21> I<000C0000000C0000001E0000001E0000001E0000003300 0000330000006180000061800000C0C00000C0C00000C0C0000180600001806000030030 00030030000300300006001800060018000C000C000C000C000C000C0018000600180006 003000030030000300600001806000018060000180C00000C0C00000401A1F7D9D21> 94 D<0003C0001E0000380000700000E00000E00000E00000E00000E00000E00000E00000E0 0000E00000E00000E00000E00000E00000E00000E00000E00000E00001C0000380000F00 00F800000F000003800001C00000E00000E00000E00000E00000E00000E00000E00000E0 0000E00000E00000E00000E00000E00000E00000E00000E00000E000007000003800001E 000003C012317DA419> 102 D I 106 D E %EndDVIPSBitmapFont %DVIPSBitmapFont: Fk cmr12 12 65 /Fk 65 125 df<001FC1F00070371800C03E3C01807C3C0380783C070038000700380007 003800070038000700380007003800070038000700380007003800FFFFFFC00700380007 003800070038000700380007003800070038000700380007003800070038000700380007 0038000700380007003800070038000700380007003800070038000700380007003C007F E1FFC01E2380A21C> 11 D<001FC0000070200000C01000018038000380780007007800 0700300007000000070000000700000007000000070000000700000007000000FFFFF800 070078000700380007003800070038000700380007003800070038000700380007003800 070038000700380007003800070038000700380007003800070038000700380007003800 070038007FE1FF80192380A21B> I<001FD8000070380000C07800018078000380780007 0038000700380007003800070038000700380007003800070038000700380007003800FF FFF800070038000700380007003800070038000700380007003800070038000700380007 003800070038000700380007003800070038000700380007003800070038000700380007 003800070038007FF3FF80192380A21B> I<000FC07F00007031C08000E00B004001801E 00E003803E01E007003C01E007001C00C007001C000007001C000007001C000007001C00 0007001C000007001C000007001C0000FFFFFFFFE007001C01E007001C00E007001C00E0 07001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007 001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E00700 1C00E007001C00E07FF1FFCFFE272380A229> I<70F8FCFC740404040408081010204006 0F7CA20E> 39 D<00200040008001000300060004000C000C0018001800300030003000 7000600060006000E000E000E000E000E000E000E000E000E000E000E000E000E000E000 6000600060007000300030003000180018000C000C000400060003000100008000400020 0B327CA413> I<800040002000100018000C000400060006000300030001800180018001 C000C000C000C000E000E000E000E000E000E000E000E000E000E000E000E000E000E000 C000C000C001C0018001800180030003000600060004000C00180010002000400080000B 327DA413> I<70F8FCFC7404040404080810102040060F7C840E> 44 D I<70F8F8F87005057C840E> I<01F000071C000C0600180300 3803803803807001C07001C07001C07001C0F001E0F001E0F001E0F001E0F001E0F001E0 F001E0F001E0F001E0F001E0F001E0F001E0F001E0F001E07001C07001C07001C07803C0 3803803803801C07000C0600071C0001F00013227EA018> 48 D<008003800F80F38003 800380038003800380038003800380038003800380038003800380038003800380038003 800380038003800380038003800380038007C0FFFE0F217CA018> I<03F0000C1C001007 002007804003C04003C08003E0F003E0F801E0F801E0F801E02003E00003E00003C00003 C0000780000700000E00001C0000180000300000600000C0000180000100000200200400 200800201800603000403FFFC07FFFC0FFFFC013217EA018> I<03F8000C1E00100F0020 07804007C07807C07803C07807C03807C0000780000780000700000F00000C0000380003 F000001C00000F000007800007800003C00003C00003E02003E07003E0F803E0F803E0F0 03C04003C0400780200780100F000C1C0003F00013227EA018> I<000300000300000700 000700000F00001700001700002700006700004700008700018700010700020700060700 040700080700080700100700200700200700400700C00700FFFFF8000700000700000700 000700000700000700000700000F80007FF015217FA018> I<70F8F8F870000000000000 000000000070F8F8F87005157C940E> 58 D 61 D<07E01838201C400E800FF00FF00FF00F000F000E001C00380030006000C000C0 00800080018001000100010001000100010000000000000000000000038007C007C007C0 038010237DA217> 63 D<0001800000018000000180000003C0000003C0000003C00000 05E0000005E0000009F0000008F0000008F00000107800001078000010780000203C0000 203C0000203C0000401E0000401E0000C01F0000800F0000800F0001FFFF800100078001 000780020003C0020003C0020003C0040001E0040001E0040001E0080000F01C0000F03E 0001F8FF800FFF20237EA225> 65 D I<0007E0100038183000E0063001C00170038000F007 0000F00E0000701E0000701C0000303C0000303C0000307C0000107800001078000010F8 000000F8000000F8000000F8000000F8000000F8000000F8000000F80000007800000078 0000107C0000103C0000103C0000101C0000201E0000200E000040070000400380008001 C0010000E0020000381C000007E0001C247DA223> I I 70 D<0007F008003C0C1800E0021801C0 01B8038000F8070000780F0000381E0000381E0000183C0000183C0000187C0000087800 000878000008F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800 1FFF780000F8780000787C0000783C0000783C0000781E0000781E0000780F0000780700 0078038000B801C000B800E00318003C0C080007F00020247DA226> I I I 75 D I 78 D<000FE00000783C0000E00E0003C00780078003C00F0001E00E0000E01E0000F03C 0000783C0000787C00007C7C00007C7800003C7800003CF800003EF800003EF800003EF8 00003EF800003EF800003EF800003EF800003EF800003E7800003C7C00007C7C00007C3C 0000783E0000F81E0000F00F0001E00F0001E0078003C003C0078000E00E0000783C0000 0FE0001F247DA226> I I 82 D<03F0200C0C601802603001E07000E0600060E00060E000 60E00020E00020E00020F00000F000007800007F00003FF0001FFE000FFF0003FF80003F C00007E00001E00000F00000F0000070800070800070800070800070C00060C00060E000 C0F000C0C80180C6070081FC0014247DA21B> I<7FFFFFF8780780786007801840078008 4007800840078008C007800C800780048007800480078004800780040007800000078000 000780000007800000078000000780000007800000078000000780000007800000078000 000780000007800000078000000780000007800000078000000780000007800000078000 00078000000FC00001FFFE001E227EA123> I 86 D I 91 D 93 D<1FE000303800780C00780E0030070000070000070000070000FF0007C7001E07003C07 00780700700700F00708F00708F00708F00F087817083C23900FC1E015157E9418> 97 D<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00 000E00000E00000E1F000E61C00E80600F00300E00380E003C0E001C0E001E0E001E0E00 1E0E001E0E001E0E001E0E001E0E001C0E003C0E00380F00700C80600C41C0083F001723 7FA21B> I<01FE000703000C07801C0780380300780000700000F00000F00000F00000F0 0000F00000F00000F000007000007800403800401C00800C010007060001F80012157E94 16> I<0000E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E0 0000E00000E00000E001F8E00704E00C02E01C01E03800E07800E07000E0F000E0F000E0 F000E0F000E0F000E0F000E0F000E07000E07800E03800E01801E00C02E0070CF001F0FE 17237EA21B> I<01FC000707000C03801C01C03801C07801E07000E0F000E0FFFFE0F000 00F00000F00000F00000F000007000007800203800201C00400E008007030000FC001315 7F9416> I<003E0000E30001C78003878003078007000007000007000007000007000007 0000070000070000070000FFF80007000007000007000007000007000007000007000007 00000700000700000700000700000700000700000700000700000700000700000780007F F000112380A20F> I<00007003F1980E1E181C0E18380700380700780780780780780780 7807803807003807001C0E001E1C0033F0002000002000003000003800003FFE001FFFC0 0FFFE03000F0600030C00018C00018C00018C000186000306000303800E00E038003FE00 15217F9518> I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00 000E00000E00000E00000E00000E1F800E60C00E80E00F00700F00700E00700E00700E00 700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00 70FFE7FF18237FA21B> I<1C003E003E003E001C00000000000000000000000000000000 000E007E001E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E 000E000E00FFC00A227FA10E> I<00E001F001F001F000E0000000000000000000000000 00000000007007F000F00070007000700070007000700070007000700070007000700070 00700070007000700070007000700070007000706070F0E0F0C061803F000C2C83A10F> I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00 000E00000E00000E03FC0E01F00E01C00E01800E02000E04000E08000E10000E38000EF8 000F1C000E1E000E0E000E07000E07800E03C00E01C00E01E00E00F00E00F8FFE3FE1723 7FA21A> I<0E00FE001E000E000E000E000E000E000E000E000E000E000E000E000E000E 000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E 00FFE00B237FA20E> I<0E1FC07F00FE60E183801E807201C00F003C00E00F003C00E00E 003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E00 3800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E0038 00E0FFE3FF8FFE27157F942A> I<0E1F80FE60C01E80E00F00700F00700E00700E00700E 00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E 0070FFE7FF18157F941B> I<01FC000707000C01801800C03800E0700070700070F00078 F00078F00078F00078F00078F00078F000787000707800F03800E01C01C00E0380070700 01FC0015157F9418> I<0E1F00FE61C00E80600F00700E00380E003C0E003C0E001E0E00 1E0E001E0E001E0E001E0E001E0E001E0E003C0E003C0E00380F00700E80E00E41C00E3F 000E00000E00000E00000E00000E00000E00000E00000E00000E0000FFE000171F7F941B > I<01F8200704600E02601C01603801E07800E07800E0F000E0F000E0F000E0F000E0F0 00E0F000E0F000E07800E07800E03801E01C01E00C02E0070CE001F0E00000E00000E000 00E00000E00000E00000E00000E00000E00000E0000FFE171F7E941A> I<0E3CFE461E8F 0F0F0F060F000E000E000E000E000E000E000E000E000E000E000E000E000E000F00FFF0 10157F9413> I<0F8830786018C018C008C008E008F0007F003FE00FF001F8003C801C80 0C800CC00CC008E018D0308FC00E157E9413> I<02000200020002000600060006000E00 1E003E00FFFC0E000E000E000E000E000E000E000E000E000E000E000E040E040E040E04 0E040E040708030801F00E1F7F9E13> I<0E0070FE07F01E00F00E00700E00700E00700E 00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00F00E00F006 017003827800FC7F18157F941B> I I I I I<3FFFC0380380300780200700600E 00401C00403C0040380000700000E00001E00001C0000380400700400F00400E00C01C00 80380080780180700780FFFF8012157F9416> I 124 D E %EndDVIPSBitmapFont %DVIPSBitmapFont: Fl cmbx12 14.4 19 /Fl 19 118 df<00007FE0030007FFFC07001FFFFF0F007FF00F9F00FF0001FF01FC0000 FF03F800007F07F000003F0FE000001F1FC000001F1FC000000F3F8000000F3F80000007 7F800000077F800000077F00000000FF00000000FF00000000FF00000000FF00000000FF 00000000FF00000000FF00000000FF00000000FF000000007F000000007F800000007F80 0000073F800000073F800000071FC00000071FC000000E0FE000000E07F000001C03F800 003C01FC00007800FF0001F0007FF007C0001FFFFF800007FFFE0000007FF00028297CA8 31> 67 D 76 D<0000FFC00000000FFFFC0000003F807F000000FE001FC00001F80007E00003F000 03F00007E00001F8000FE00001FC001FC00000FE001FC00000FE003F8000007F003F8000 007F007F8000007F807F0000003F807F0000003F807F0000003F80FF0000003FC0FF0000 003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000 003FC0FF0000003FC0FF0000003FC07F0000003F807F8000007F807F8000007F803F8000 007F003F8000007F001FC00000FE001FC00000FE000FE00001FC0007F00003F80003F800 07F00001FC000FE00000FE001FC000003FC0FF0000000FFFFC00000000FFC000002A297C A833> 79 D 86 D<03FF80000FFFF0001F01FC003F80FE003F807F003F803F003F803F 801F003F8000003F8000003F8000003F8000003F80003FFF8001FC3F800FE03F801F803F 803F003F807E003F80FC003F80FC003F80FC003F80FC003F80FC005F807E00DF803F839F FC1FFE0FFC03FC03FC1E1B7E9A21> 97 D I<00007FF000007FF000007FF0000007F0000007F0000007 F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007 F0003F87F001FFF7F007F03FF00FC00FF01F8007F03F0007F03F0007F07E0007F07E0007 F07E0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007 F07E0007F07E0007F03F0007F03F0007F01F800FF00FC01FF007E07FFF01FFE7FF007F87 FF202A7EA925> 100 D<003FC00001FFF00003E07C000F803E001F801F001F001F003F00 0F807E000F807E000FC07E000FC0FE0007C0FE0007C0FFFFFFC0FFFFFFC0FE000000FE00 0000FE0000007E0000007E0000007F0000003F0001C01F0001C00F80038007C0070003F0 1E0000FFFC00003FE0001A1B7E9A1F> I<0007F8003FFC007E3E01FC7F03F87F03F07F07 F07F07F03E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007 F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007 F00007F00007F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF8018 2A7EA915> I 104 D<07000F801FC03FE03FE03FE01FC00F8007000000000000000000000000000000FF E0FFE0FFE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F E00FE00FE00FE00FE00FE0FFFEFFFEFFFE0F2B7EAA12> I 108 D 110 D<003FE00001FFFC0003F07E000FC01F801F80 0FC03F0007E03F0007E07E0003F07E0003F07E0003F0FE0003F8FE0003F8FE0003F8FE00 03F8FE0003F8FE0003F8FE0003F8FE0003F87E0003F07E0003F03F0007E03F0007E01F80 0FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22> I I 114 D<03FE300FFFF03E03F078 00F07000F0F00070F00070F80070FE0000FFE0007FFF007FFFC03FFFE01FFFF007FFF800 FFF80007FC0000FCE0007CE0003CF0003CF00038F80038FC0070FF01E0E7FFC0C1FF0016 1B7E9A1B> I<00E00000E00000E00000E00001E00001E00001E00003E00003E00007E000 0FE0001FFFE0FFFFE0FFFFE00FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE000 0FE0000FE0000FE0000FE0000FE0000FE0700FE0700FE0700FE0700FE0700FE0700FE070 07F0E003F0C001FF80007F0014267FA51A> I I E %EndDVIPSBitmapFont %DVIPSBitmapFont: Fm cmr12 14.4 20 /Fm 20 118 df<78FCFCFEFE7A02020202040404080810204007127B8510> 44 D<00200000E00001E0000FE000FFE000F1E00001E00001E00001E00001E00001E00001E0 0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0 0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0 0001E00003F000FFFFC0FFFFC012287BA71D> 49 D<01FC0007FF000C0FC01803E02001 F06001F04000F84000F8F800FCFC00FCFC007CFC007CFC007C7800FC0000FC0000F80000 F80001F00001F00003E00003C0000780000700000E00001C0000380000300000600000C0 000180000300040200040400080800081000082000183FFFF87FFFF0FFFFF0FFFFF01628 7DA71D> I<000FC0003FF000F01801C01803803C07007C0F007C0E00381E00003C00003C 00003C0000780000780000780000F83F00F8C1C0F900E0FA0070FA0038FC003CFC001EFC 001EF8001EF8001FF8001FF8001FF8001F78001F78001F78001F78001F3C001E3C001E1C 003C1E003C0E007807007003C1E001FFC0007E0018297EA71D> 54 D<007E0001FF800781C00F00E01E00703C00383C003878003C78003CF8001EF8001EF800 1EF8001EF8001FF8001FF8001FF8001F78001F78003F78003F3C003F1C005F0E005F0700 9F03831F00FC1F00001E00001E00001E00003E00003C00003C0000381C00783E00703E00 E03C01C01803801C0F000FFE0003F80018297EA71D> 57 D<0000FF00100007FFE03000 1FC07830003E000C7000F80006F001F00003F003E00001F007C00000F00F800000700F80 0000701F000000303F000000303E000000303E000000107E000000107E000000107C0000 0000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC000000 00FC00000000FC0000FFFF7C0000FFFF7E000003F07E000001F03E000001F03E000001F0 3F000001F01F000001F00F800001F00F800001F007C00001F003E00001F001F00002F000 F80002F0003E000C70001FC038300007FFE0100000FF8000282B7DA92E> 71 D<01FFFE01FFFE0007E00003E00003E00003E00003E00003E00003E00003E00003E00003 E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003 E00003E00003E00003E00003E00003E00003E00003E03003E07803E0FC03E0FC03E0FC03 C0F807C0400780200F00300E000C3C0003F000172A7DA81E> 74 D<0001FF0000000F01E000003C0078000078003C0000E0000E0001E0000F0003C0000780 07800003C00F800003E01F000001F01F000001F03E000000F83E000000F87E000000FC7E 000000FC7C0000007C7C0000007CFC0000007EFC0000007EFC0000007EFC0000007EFC00 00007EFC0000007EFC0000007EFC0000007EFC0000007E7C0000007C7E000000FC7E0000 00FC7E000000FC3E000000F83F000001F81F000001F01F000001F00F800003E007800003 C007C00007C003E0000F8000F0001E000078003C00003C007800000F01E0000001FF0000 272B7DA92E> 79 D<03FC00000C070000100380003C01C0003E01E0003E00F0001C00F0 000800F0000000F0000000F0000000F000007FF00003E0F0000F80F0001E00F0003C00F0 007C00F0007800F040F800F040F800F040F800F040F801F0407C01F0403C0278801E0C7F 8007F01E001A1A7E991D> 97 D<0F000000FF000000FF0000001F0000000F0000000F00 00000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F00 00000F0000000F07E0000F1838000F600E000F8007000F8007800F0003C00F0003C00F00 01E00F0001E00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F00 01E00F0001E00F0003E00F0003C00F0003800F8007800E800F000E401C000C303800080F C0001C2A7EA921> I<007F0001C0E00700100E00781E00F83C00F83C00707C0020780000 F80000F80000F80000F80000F80000F80000F80000F800007800007C00003C00083C0008 1E00100E002007006001C180007E00151A7E991A> I<00FC000387800701C00E01E01C00 E03C00F03C00F0780078780078F80078F80078FFFFF8F80000F80000F80000F80000F800 007800007800003C00083C00081E00100E002007004001C180007E00151A7E991A> 101 D<00000F0001FC3080070743800E03C3801E03C1003C01E0003C01E0007C01F0007C01F0 007C01F0007C01F0007C01F0003C01E0003C01E0001E03C0000E0380001707000011FC00 0030000000300000003000000030000000180000001FFF80000FFFF00007FFF80018007C 0030001E0070000E0060000700E0000700E0000700E0000700E000070070000E0070000E 0038001C001C0038000781E00000FF000019287E9A1D> 103 D<1E003F003F003F003F00 1E000000000000000000000000000000000000000F00FF00FF001F000F000F000F000F00 0F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F00FFF0FFF0 0C297EA811> 105 D<007E0003C3C00700E00E00701C00383C003C3C003C78001E78001E F8001FF8001FF8001FF8001FF8001FF8001FF8001FF8001F78001E78001E3C003C3C003C 1C00380E00700700E003C3C0007E00181A7E991D> 111 D<003F010001E0830003804300 0F0027001E0017001E001F003C000F007C000F007C000F0078000F00F8000F00F8000F00 F8000F00F8000F00F8000F00F8000F00F8000F007C000F007C000F003C000F003E001F00 1E001F000F002F0007804F0001C18F00007E0F0000000F0000000F0000000F0000000F00 00000F0000000F0000000F0000000F0000000F0000000F000000FFF00000FFF01C267E99 1F> 113 D<0F0F80FF11C0FF23E01F43E00F83E00F81C00F80000F00000F00000F00000F 00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F 00000F8000FFFC00FFFC00131A7E9917> I<07F0801C0D80300380600180E00180E00080 E00080F00080F800007E00007FE0003FFC001FFE0007FF00003F800007808003C08003C0 8001C0C001C0C001C0E00180E00380F00300CC0E0083F800121A7E9917> I<0080000080 000080000080000180000180000180000380000380000780000F80001FFF80FFFF800780 000780000780000780000780000780000780000780000780000780000780000780000780 0007804007804007804007804007804007804007804003C08001C08000E100003E001225 7FA417> I<0F000F00FF00FF00FF00FF001F001F000F000F000F000F000F000F000F000F 000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F 000F000F000F000F000F000F000F001F000F001F0007002F0003804F8001C08FF0007F0F F01C1A7E9921> I E %EndDVIPSBitmapFont %DVIPSBitmapFont: Fn cmr17 20.74 18 /Fn 18 119 df<000001FF00008000001FFFE0018000007F007801800001F8000E038000 03E000070780000FC000018780001F000000CF80003E0000006F80007C0000003F8000F8 0000003F8001F00000001F8003F00000000F8007E00000000F8007C000000007800FC000 000007800FC000000007801F8000000003801F8000000003803F8000000003803F000000 0001803F0000000001807F0000000001807F0000000001807E0000000000007E00000000 0000FE000000000000FE000000000000FE000000000000FE000000000000FE0000000000 00FE000000000000FE000000000000FE000000000000FE000000000000FE000000000000 FE0000000000007E0000000000007E0000000000007F0000000000007F0000000001803F 0000000001803F0000000001803F8000000001801F8000000001801F8000000003000FC0 00000003000FC0000000030007E0000000060007E0000000060003F0000000060001F000 00000C0000F80000001800007C0000001800003E0000003000001F0000006000000FC000 01C0000003E0000380000001F8000E000000007F007C000000001FFFF00000000001FF00 0000313D7CBB39> 67 D 76 D<000003FF00000000001E01E000000000F0003C000000 03C0000F000000078000078000000F000003C000003E000001F000007C000000F80000F8 0000007C0001F00000003E0001F00000003E0003E00000001F0007E00000001F8007C000 00000F800FC00000000FC00F8000000007C01F8000000007E01F8000000007E03F000000 0003F03F0000000003F03F0000000003F07F0000000003F87E0000000001F87E00000000 01F87E0000000001F8FE0000000001FCFE0000000001FCFE0000000001FCFE0000000001 FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FC FE0000000001FCFE0000000001FC7E0000000001F87F0000000003F87F0000000003F87F 0000000003F87F0000000003F83F0000000003F03F8000000007F01F8000000007E01F80 00000007E01FC00000000FE00FC00000000FC007C00000000F8007E00000001F8003E000 00001F0001F00000003E0001F80000007E0000F80000007C00007C000000F800003E0000 01F000000F000003C000000780000780000003E0001F00000000F8007C000000001E01E0 0000000003FF000000363D7CBB3E> 79 D<003F80000001C0F0000003003C000004001E 00000C000F000018000780001C0007C0003E0003C0003F0003E0003F0003E0003F0003E0 001E0003E000000003E000000003E000000003E00000003FE000000FF3E000007E03E000 01F803E00003E003E0000FC003E0001F8003E0003F0003E0003E0003E0007E0003E0007E 0003E060FC0003E060FC0003E060FC0003E060FC0007E060FC0007E0607C000BE0607E00 0BE0603E0011F0C01F0060F0C007C1807F8000FE003E0023257CA427> 97 D<03E0000000FFE0000000FFE000000007E000000003E000000003E000000003E0000000 03E000000003E000000003E000000003E000000003E000000003E000000003E000000003 E000000003E000000003E000000003E000000003E000000003E000000003E000000003E0 00000003E000000003E03FC00003E0E0780003E3001C0003E6000F0003E800078003F800 03C003F00001E003E00001F003E00000F003E00000F803E00000F803E00000FC03E00000 7C03E000007C03E000007E03E000007E03E000007E03E000007E03E000007E03E000007E 03E000007E03E000007E03E000007E03E000007C03E000007C03E00000FC03E00000F803 E00000F803E00001F003E00001E003F00003E003D80003C003C80007800384000E000383 001C000381C0F00003003F8000273C7EBB2C> I<0007F800003C0E0000F0018001E000C0 03C00060078000300F0000701F0000F81F0001F83E0001F83E0001F87E0000F07C000000 7C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000 FC0000007C0000007C0000007E0000003E0000003E00000C1F00000C1F0000180F800018 0780003003C0006001E000C000F00180003C0E000007F8001E257DA423> I<0007F80000 3C1E0000F0078001C003C003C001E0078000F00F0000F81F0000781E00007C3E00007C3E 00007C7E00003E7C00003E7C00003EFC00003EFC00003EFFFFFFFEFC000000FC000000FC 000000FC000000FC000000FC0000007C0000007C0000007E0000003E0000003E0000061F 0000060F00000C0F80000C0780001803C0003000E00060007000C0001E07000003FC001F 257EA423> 101 D<0000FC0000078300000E0380001C07C0003C0FC000780FC000F80FC0 00F8078000F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000 01F0000001F0000001F0000001F0000001F0000001F0000001F00000FFFFFC00FFFFFC00 01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000 01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000 01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000 01F0000001F0000001F0000001F0000001F0000003F800007FFFE0007FFFE0001A3C7FBB 18> I<07000F801FC01FC01FC00F80070000000000000000000000000000000000000000 0000000000000007C0FFC0FFC00FC007C007C007C007C007C007C007C007C007C007C007 C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007 C007C00FE0FFFEFFFE0F397DB815> 105 D<0003800007C0000FE0000FE0000FE00007C0 000380000000000000000000000000000000000000000000000000000000000000000000 0000000000000007E000FFE000FFE0000FE00003E00003E00003E00003E00003E00003E0 0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0 0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0 0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0 7803C0FC07C0FC0780FC0780FC0F00780E00381C000FE000134A82B818> I<07C0FFC0FF C00FC007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007 C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007 C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007 C00FE0FFFEFFFE0F3C7DBB15> 108 D<03E01FE0003FC000FFE0607C00C0F800FFE0801E 01003C0007E3000F06001E0003E4000F88001F0003E4000F88001F0003E8000790000F00 03E80007D0000F8003F00007E0000F8003F00007E0000F8003E00007C0000F8003E00007 C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80 03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007 C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80 03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007 C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80 07F0000FE0001FC0FFFF81FFFF03FFFEFFFF81FFFF03FFFE3F257EA443> I<03E01FE000 FFE0607C00FFE0801E0007E3000F0003E4000F8003E4000F8003E800078003E80007C003 F00007C003F00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E0 0007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E000 07C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007 C003E00007C003E00007C003E00007C003E00007C007F0000FE0FFFF81FFFFFFFF81FFFF 28257EA42C> I<0007FC0000001C070000007001C00001E000F00003C00078000780003C 000F00001E001F00001F001E00000F003E00000F803E00000F807C000007C07C000007C0 7C000007C0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC 000007E0FC000007E0FC000007E07C000007C07C000007C07E00000FC03E00000F803E00 000F801E00000F001F00001F000F00001E000780003C0003C000780001E000F000007001 C000001C0700000007FC000023257EA427> I<03E03E00FFE0C300FFE1078007E20FC003 E40FC003E80FC003E8078003E8030003F0000003F0000003F0000003E0000003E0000003 E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003 E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003 E0000003E0000003E0000007F00000FFFFC000FFFFC0001A257EA41E> 114 D<00FF02000700C6000C002E0010001E0030001E0060000E0060000E00E0000600E00006 00E0000600F0000600F8000600FC0000007F0000003FF000003FFF80000FFFE00007FFF0 0001FFFC00003FFE000001FE0000003F00C0001F00C0000F80C0000780E0000380E00003 80E0000380E0000380F0000300F0000300F8000700F8000600E4000C00E2001800C18070 00807F800019257DA41F> I<003000000030000000300000003000000030000000300000 0070000000700000007000000070000000F0000000F0000001F0000001F0000003F00000 07F000001FFFFE00FFFFFE0001F0000001F0000001F0000001F0000001F0000001F00000 01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000 01F0000001F0000001F0000001F0000001F0018001F0018001F0018001F0018001F00180 01F0018001F0018001F0018001F0018000F0010000F8030000F8030000780200003C0400 000E08000003F00019357FB41E> I 118 D E %EndDVIPSBitmapFont end %%EndProlog %%BeginSetup %%Feature: *Resolution 300dpi TeXDict begin %%PaperSize: a4 userdict/PStoPSxform PStoPSmatrix matrix currentmatrix matrix invertmatrix matrix concatmatrix matrix invertmatrix put %%EndSetup %%Page: (0,1) 1 userdict/PStoPSsaved save put PStoPSmatrix setmatrix 595.000000 0.271378 translate 90 rotate 0.706651 dup scale userdict/PStoPSmatrix matrix currentmatrix put userdict/PStoPSclip{0 0 moveto 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto closepath}put initclip /showpage{}def/copypage{}def/erasepage{}def PStoPSxform concat 1 0 bop Fn 281 370 a(Cleaner) p 570 370 a(seman) n(tics) p 927 370 a(for) p 1047 370 a(Ob) t(jectiv) n(e) p 1404 370 a(Lab) r(el) p Fm 717 518 a(Jacques) p 934 518 a(Garrigue) 719 634 y(Octob) r(er) p 945 634 a(26,) p 1040 634 a(1999) p Fl 11 836 a(Credits) p Fk 11 929 a(This) p 122 929 a(prop) q(osal) p 319 929 a(con) o(tains) p 510 929 a(ideas) p 632 929 a(from) p 747 929 a(Damien) p 928 929 a(Doligez) p 1101 929 a(and) p 1196 929 a(Pierre) p 1340 929 a(W) l(eis.) p Fl 11 1073 a(Lab) r(els) p 221 1073 a(and) p 351 1073 a(optionals) p Fk 11 1165 a(Lab) q(els) p 165 1165 a(and) p 259 1165 a(optional) p 449 1165 a(argumen) o(ts) p 687 1165 a(had) p 781 1165 a(t) o(w) o(o) p 873 1165 a(problems) p 1082 1165 a(in) p 1139 1165 a(Ob) s(jectiv) o(e) p 1360 1165 a(Lab) q(el.) p Fj 83 1280 a(\017) p Fk 133 1280 a(They) p 259 1280 a(w) o(ere) p 372 1280 a(not) p 459 1280 a(fully) p 570 1280 a(coheren) o(t) p 767 1280 a(with) p 878 1280 a(the) p 963 1280 a(original) p 1139 1280 a(call-b) o(y-v) m (alue) p 1423 1280 a(seman) o(tics) p 1644 1280 a(of) p 1700 1280 a(the) p 1784 1280 a(lan-) 133 1340 y(guage.) p 303 1340 a(In) p 368 1340 a(some) p 495 1340 a(\(subtle\)) p 681 1340 a(cases,) p 823 1340 a(a) p 868 1340 a(side-e\013ect) p 1099 1340 a(migh) o(t) p 1243 1340 a(get) p 1329 1340 a(dela) o(y) o(ed) p 1508 1340 a(more) p 1635 1340 a(than) p 1753 1340 a(in) p 1814 1340 a(an) 133 1400 y(un) o(t) o(yp) q(ed) p 322 1400 a(seman) o(tics.) p Fj 83 1502 a(\017) p Fk 133 1502 a(F) l(or) p 220 1502 a(optional) p 410 1502 a(argumen) o(ts,) p 660 1502 a(no) p 728 1502 a(un) o(t) o(yp) q(ed) p 918 1502 a(seman) o(tics) p 1139 1502 a(existed.) 84 1616 y(This) p 195 1616 a(new) p 295 1616 a(prop) q(osal) p 492 1616 a(corrects) p 674 1616 a(these) p 799 1616 a(t) o(w) o(o) p 891 1616 a(\015a) o(ws.) p Fi 11 1746 a(Syn) n(tax) p Fk 11 1838 a(W) l(e) p 95 1838 a(k) o(eep) p 206 1838 a(Ob) s(jectiv) o(e) p 426 1838 a(Lab) q(el's) p 594 1838 a(syn) o(tax,) p 764 1838 a(except) p 917 1838 a(for) p 991 1838 a(default) p 1155 1838 a(v) m(alues) p 1301 1838 a(in) p 1357 1838 a(optional) p 1547 1838 a(argumen) o(ts.) p Fh 329 1944 a(typ) n(expr) p Fk 528 1944 a(::=) p Fg 634 1944 a(:) p 656 1944 a(:) p 678 1944 a(:) p Fj 579 2004 a(j) p Fh 634 2004 a(typ) n(expr) p Fj 806 2004 a(!) p Fh 870 2004 a(typ) n(expr) p Fj 579 2064 a(j) p Fk 634 2064 a([?]) p Fi(lab) r(el) p Fk 801 2064 a(:) p Fh(typ) n(expr) p Fj 987 2064 a(!) p Fh 1050 2064 a(typ) n(expr) 391 2124 y(expr) p Fk 528 2124 a(::=) p Fg 634 2124 a(:) p 656 2124 a(:) p 678 2124 a(:) p Fj 579 2185 a(j) p Fh 634 2185 a(expr) p 746 2185 a(lab) n(ele) n(d-expr) p Ff 991 2163 a(+) p Fj 579 2245 a(j) p Fe 634 2245 a(fun) p Fj 728 2245 a(f) p Fh(lab) n(ele) n(d-simple-p) n(attern) p Fj 1209 2245 a(g) p Ff 1234 2227 a(+) p Fk 1280 2245 a([) p Fe(when) p Fh 1412 2245 a(expr) p Fk 1507 2245 a(]) p Fj 1535 2245 a(!) p Fh 1599 2245 a(expr) p Fj 579 2305 a(j) p Fe 634 2305 a(function) p Fh 856 2305 a(lab) n(ele) n(d-p) n(attern) p Fk 1177 2305 a([) p Fe(when) p Fh 1309 2305 a(expr) p Fk 1404 2305 a(]) p Fj 1432 2305 a(!) p Fh 1496 2305 a(expr) p Fj 785 2365 a(f) p Fe(|) p Fh 851 2365 a(lab) n(ele) n(d-p) n(attern) p Fk 1172 2365 a([) p Fe(when) p Fg 1305 2365 a(expr) p Fk 1403 2365 a(]) p Fj 1430 2365 a(!) p Fh 1494 2365 a(expr) p Fj 1589 2365 a(g) p Fd 1614 2347 a(\003) p Fh 242 2425 a(lab) n(ele) n(d-expr) p Fk 528 2425 a(::=) p 634 2425 a([?]) p Fh(expr) p Fj 579 2486 a(j) p Fk 634 2486 a([?]) p Fi(lab) r(el) p Fk 801 2486 a(:) p Fh(expr) 182 2546 y(lab) n(ele) n(d-p) n(attern) p Fk 528 2546 a(::=) p Fh 634 2546 a(p) n(attern) p Fj 579 2606 a(j) p Fi 634 2606 a(lab) r(el) p Fk 751 2606 a(:) p Fh(p) n(attern) p Fj 579 2666 a(j) p Fk 634 2666 a(?[) p Fe(\() p Fh(expr) p Fe(\)) p Fk(]) p Fi(lab) r(el) p Fk 943 2666 a(:) p Fh 956 2666 a(p) n(attern) p Fk 926 2937 a(1) p eop PStoPSsaved restore userdict/PStoPSsaved save put PStoPSmatrix setmatrix 595.000000 421.271378 translate 90 rotate 0.706651 dup scale userdict/PStoPSmatrix matrix currentmatrix put userdict/PStoPSclip{0 0 moveto 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto closepath}put initclip PStoPSxform concat 2 1 bop Fi 11 168 a(Dynamic) p 247 168 a(seman) n(tics) p Fj 11 261 a(;) p Fk 52 261 a(is) p 101 261 a(a) p 141 261 a(notation) p 337 261 a(for) p 411 261 a(the) p 495 261 a(empt) o(y) p 644 261 a(lab) q(el.) 86 366 y(\() p Fe(fun) p Fi 198 366 a(l) p Fc 214 373 a(i) p Fk 227 366 a(:) p Fg(x) p Fj 282 366 a(!) p Fg 346 366 a(e) p Fk(\)) p Fi 404 366 a(l) p Fc 420 373 a(1) p Fk 442 366 a(:) p Fg 455 366 a(e) p Ff 478 373 a(1) p Fg 506 366 a(:) p 528 366 a(:) p 550 366 a(:) p Fi 571 366 a(l) p Fc 587 373 a(n) p Fk 612 366 a(:) p Fg 625 366 a(e) p Fb 648 373 a(n) p Fj 515 427 a(!) p Fk 579 427 a(\() p Fg(e) p Fk([) p Fg(e) p Fb 658 434 a(i) p Fg 671 427 a(=x) p Fk(]) p Fi 752 427 a(l) p Fc 768 434 a(1) p Fk 790 427 a(:) p Fg(e) p Ff 827 434 a(1) p Fg 855 427 a(:) p 877 427 a(:) p 899 427 a(:) p Fi 920 427 a(l) p Fc 936 434 a(i) p Fd(\000) p Fc(1) p Fk 997 427 a(:) p Fg 1010 427 a(e) p Fb 1033 434 a(i) p Fd(\000) p Ff(1) p Fi 1108 427 a(l) p Fc 1124 434 a(i) p Ff(+) p Fc(1) p Fk 1185 427 a(:) p Fg(e) p Fb 1222 434 a(i) p Ff(+1) p Fg 1289 427 a(:) p 1311 427 a(:) p 1333 427 a(:) p Fi 1354 427 a(l) p Fc 1370 434 a(n) p Fk 1395 427 a(:) p Fg 1408 427 a(e) p Fb 1431 434 a(n) p Fk 86 487 a(\() p Fe(fun) p Fk 198 487 a(?) p Fi(l) p Fc 237 494 a(i) p Fk 250 487 a(:) p Fg(x) p Fj 305 487 a(!) p Fg 369 487 a(e) p Fk(\)) p Fi 427 487 a(l) p Fc 443 494 a(1) p Fk 465 487 a(:) p Fg 478 487 a(e) p Ff 501 494 a(1) p Fg 529 487 a(:) p 551 487 a(:) p 573 487 a(:) p Fi 594 487 a(l) p Fc 610 494 a(n) p Fk 635 487 a(:) p Fg 648 487 a(e) p Fb 671 494 a(n) p Fj 515 547 a(!) p Fg 579 547 a(e) p Fk([) p Fe(Some) p Fk 717 547 a(\() p Fg(e) p Fb 759 554 a(i) p Fk 773 547 a(\)) p Fg(=x) p Fk(]) p Fi 874 547 a(l) p Fc 890 554 a(1) p Fk 912 547 a(:) p Fg 925 547 a(e) p Ff 948 554 a(1) p Fg 976 547 a(:) p 998 547 a(:) p 1020 547 a(:) p Fi 1042 547 a(l) p Fc 1058 554 a(i) p Fd(\000) p Fc(1) p Fk 1118 547 a(:) p Fg(e) p Fb 1155 554 a(i) p Fd(\000) p Ff(1) p Fi 1230 547 a(l) p Fc 1246 554 a(i) p Ff(+) p Fc(1) p Fk 1307 547 a(:) p Fg 1320 547 a(e) p Fb 1343 554 a(i) p Ff(+1) p Fg 1410 547 a(:) p 1432 547 a(:) p 1454 547 a(:) p Fi 1476 547 a(l) p Fc 1492 554 a(n) p Fk 1516 547 a(:) p Fg(e) p Fb 1553 554 a(n) p Fk 86 607 a(\() p Fe(fun) p Fk 198 607 a(?) p Fi(l) p Fk(:) p Fg 250 607 a(x) p Fj 292 607 a(!) p Fg 356 607 a(e) p Fk(\)) p Fi 413 607 a(l) p Fc 429 614 a(1) p Fk 451 607 a(:) p Fg(e) p Ff 488 614 a(1) p Fg 516 607 a(:) p 538 607 a(:) p 560 607 a(:) p Fi 581 607 a(l) p Fc 597 614 a(n) p Fk 621 607 a(:) p Fg(e) p Fb 658 614 a(n) p Fk 1154 607 a(when) p Fi 1281 607 a(l) p Fc 1297 614 a(i) p Fk 1324 607 a(=) p Fj 1376 607 a(;) p Fk 1417 607 a(and) p Fg 1512 607 a(l) p Fj 1541 607 a(62) p 1588 607 a(f) p Fi(l) p Fc 1629 614 a(1) p Fg 1660 607 a(:) p 1682 607 a(:) p 1704 607 a(:) p Fi 1725 607 a(l) p Fc 1741 614 a(n) p Fj 1765 607 a(g) 515 667 y(!) p Fg 579 667 a(e) p Fk([) p Fe(None) p Fg 717 667 a(=x) p Fk(]) p Fi 799 667 a(l) p Fc 815 674 a(1) p Fk 837 667 a(:) p Fg(e) p Ff 874 674 a(1) p Fg 901 667 a(:) p 923 667 a(:) p 945 667 a(:) p Fi 967 667 a(l) p Fc 983 674 a(n) p Fk 1007 667 a(:) p Fg(e) p Fb 1044 674 a(n) p Fk 86 728 a(\(\() p Fe(fun) p Fi 217 728 a(l) p Fk(:) p Fg 246 728 a(x) p Fj 288 728 a(!) p Fg 352 728 a(e) p Fk(\)) p Fi 409 728 a(l) p Fc 425 735 a(1) p Fk 447 728 a(:) p Fg(e) p Ff 484 735 a(1) p Fg 511 728 a(:) p 533 728 a(:) p 555 728 a(:) p Fi 577 728 a(l) p Fc 593 735 a(m) p Fk 629 728 a(:) p Fg 642 728 a(e) p Fb 665 735 a(m) p Fk 698 728 a(\)) p Fi 733 728 a(l) p Fc 749 735 a(m) p Ff(+) p Fc(1) p Fk 833 728 a(:) p Fg 846 728 a(e) p Fb 869 735 a(m) p Ff(+1) p Fg 955 728 a(:) p 977 728 a(:) p 999 728 a(:) p Fi 1021 728 a(l) p Fc 1037 735 a(n) p Fk 1061 728 a(:) p Fg(e) p Fb 1098 735 a(n) p Fk 1373 728 a(when) p Fi 1501 728 a(l) p Fj 1530 728 a(62) p 1577 728 a(f) p Fi(l) p Fc 1618 735 a(1) p Fg 1648 728 a(:) p 1670 728 a(:) p 1692 728 a(:) p Fi 1714 728 a(l) p Fc 1730 735 a(m) p Fj 1765 728 a(g) 515 788 y(!) p Fk 579 788 a(\() p Fe(fun) p Fi 691 788 a(l) p Fk(:) p Fg 720 788 a(x) p Fj 761 788 a(!) p Fg 825 788 a(e) p Fk(\)) p Fi 883 788 a(l) p Fc 899 795 a(1) p Fk 921 788 a(:) p Fg 934 788 a(e) p Ff 957 795 a(1) p Fg 985 788 a(:) p 1007 788 a(:) p 1029 788 a(:) p Fi 1051 788 a(l) p Fc 1067 795 a(n) p Fk 1091 788 a(:) p Fg 1104 788 a(e) p Fb 1127 795 a(n) p Fk 86 848 a(\(\() p Fe(fun) p Fk 217 848 a(?) p Fi(l) p Fk(:) p Fg 269 848 a(x) p Fj 311 848 a(!) p Fg 375 848 a(e) p Fk(\)) p Fi 432 848 a(l) p Fc 448 855 a(1) p Fk 470 848 a(:) p Fg(e) p Ff 507 855 a(1) p Fg 535 848 a(:) p 557 848 a(:) p 579 848 a(:) p Fi 600 848 a(l) p Fc 616 855 a(m) p Fk 652 848 a(:) p Fg 665 848 a(e) p Fb 688 855 a(m) p Fk 721 848 a(\)) p Fi 756 848 a(l) p Fc 772 855 a(m) p Ff(+) p Fc(1) p Fk 856 848 a(:) p Fg 869 848 a(e) p Fb 892 855 a(m) p Ff(+1) p Fg 978 848 a(:) p 1000 848 a(:) p 1022 848 a(:) p Fi 1044 848 a(l) p Fc 1060 855 a(n) p Fk 1084 848 a(:) p Fg(e) p Fb 1121 855 a(n) p Fk 1261 848 a(when) p Fj 1388 848 a(f) p Fi(l) p Fg(;) p Fj 1451 848 a(;g) p 1530 848 a(6) m(\\) p 1577 848 a(f) p Fi(l) p Fc 1618 855 a(1) p Fg 1648 848 a(:) p 1670 848 a(:) p 1692 848 a(:) p Fi 1714 848 a(l) p Fc 1730 855 a(m) p Fj 1765 848 a(g) 515 908 y(!) p Fk 579 908 a(\() p Fe(fun) p Fk 691 908 a(?) p Fi(l) p Fk(:) p Fg 743 908 a(x) p Fj 785 908 a(!) p Fg 848 908 a(e) p Fk(\)) p Fi 906 908 a(l) p Fc 922 915 a(1) p Fk 944 908 a(:) p Fg(e) p Ff 981 915 a(1) p Fg 1008 908 a(:) p 1030 908 a(:) p 1052 908 a(:) p Fi 1074 908 a(l) p Fc 1090 915 a(n) p Fk 1114 908 a(:) p Fg 1127 908 a(e) p Fb 1150 915 a(n) p Fi 11 1035 a(T) n(yping) p Fk 11 1127 a(Seman) o(tics) p 240 1127 a(are) p 321 1127 a(k) o(ept) p 430 1127 a(throughout) p 685 1127 a(compilation) p 950 1127 a(b) o(y) p 1018 1127 a(disallo) o(wing) p 1269 1127 a(lab) q(el) p 1387 1127 a(comm) o(utation) p 1684 1127 a(for) p 1759 1127 a(func-) 11 1187 y(tion) p 116 1187 a(t) o(yp) q(es.) p 278 1187 a(Ho) o(w) o(ev) o(er,) p 494 1187 a(the) p 583 1187 a(original) p 764 1187 a(comfort) p 949 1187 a(of) p 1009 1187 a(out-of-order) p 1283 1187 a(application) p 1540 1187 a(is) p 1594 1187 a(reco) o(v) o(ered) p 1814 1187 a(b) o(y) 11 1247 y(allo) o(wing) p 207 1247 a(argumen) o(t) p 431 1247 a(reordering) p 670 1247 a(in) p 732 1247 a(application,) p 1005 1247 a(when) p 1138 1247 a(the) p 1227 1247 a(function's) p 1457 1247 a(t) o(yp) q(e) p 1572 1247 a(is) p Fh 1626 1247 a(wel) r(l) p 1731 1247 a(known) p Fk 11 1308 a(\() p Fh(c.f.) p Fk 118 1308 a(p) q(olymorphic) p 400 1308 a(metho) q(ds\).) p Fl 11 1452 a(V) p 56 1452 a(arian) n(ts) p Fk 11 1544 a(V) l(arian) o(t) p 187 1544 a(t) o(yping,) p 355 1544 a(as) p 417 1544 a(it) p 468 1544 a(is) p 519 1544 a(presen) o(ted) p 739 1544 a(in) p 798 1544 a(the) p 884 1544 a(user's) p 1022 1544 a(man) o(ual,) p 1210 1544 a(is) p 1261 1544 a(not) p 1350 1544 a(principal:) p 1576 1544 a(in) p 1635 1544 a(some) p 1760 1544 a(cases) 11 1605 y(t) o(ypabilit) o(y) p 239 1605 a(of) p 301 1605 a(an) p 375 1605 a(expression) p 616 1605 a(ma) o(y) p 728 1605 a(dep) q(end) p 904 1605 a(on) p 978 1605 a(the) p 1069 1605 a(order) p 1202 1605 a(in) p 1265 1605 a(whic) o(h) p 1411 1605 a(the) p 1502 1605 a(t) o(yping) p 1660 1605 a(algorithm) 11 1665 y(pro) q(ceeds.) p Fe 133 1779 a(#) p 184 1779 a(let) p 286 1779 a(f1) p 363 1779 a(\(x) p 440 1779 a(:) p 491 1779 a([<) p 568 1779 a(a) p 620 1779 a(b\(int\)]\)) p 850 1779 a(=) p 902 1779 a(\(\)) 184 1839 y(let) p 286 1839 a(f2) p 363 1839 a(\(x) p 440 1839 a(:) p 491 1839 a([<) p 568 1839 a(a]\)) p 671 1839 a(=) p 722 1839 a(\(\)) 184 1899 y(let) p 286 1899 a(f3) p 363 1899 a(\(x) p 440 1899 a(:) p 491 1899 a([<) p 568 1899 a(a) p 620 1899 a(b\(bool\)]\)) p 876 1899 a(=) p 927 1899 a(\(\);;) 133 1960 y(val) p 235 1960 a(f1) p 312 1960 a(:) p 363 1960 a([<) p 440 1960 a(a) p 491 1960 a(b\(int\)]) p 696 1960 a(->) p 773 1960 a(unit) p 902 1960 a(=) p 953 1960 a() 133 2020 y(val) p 235 2020 a(f2) p 312 2020 a(:) p 363 2020 a([<) p 440 2020 a(a]) p 517 2020 a(->) p 594 2020 a(unit) p 722 2020 a(=) p 773 2020 a() 133 2080 y(val) p 235 2080 a(f3) p 312 2080 a(:) p 363 2080 a([<) p 440 2080 a(a) p 491 2080 a(b\(bool\)]) p 722 2080 a(->) p 799 2080 a(unit) p 927 2080 a(=) p 978 2080 a() 133 2140 y(#) p 184 2140 a(fun) p 286 2140 a(x) p 338 2140 a(->) p 414 2140 a(f1) p 491 2140 a(x;) p 568 2140 a(f2) p 645 2140 a(x;) p 722 2140 a(f3) p 799 2140 a(x;;) 133 2200 y(-) p 184 2200 a(:) p 235 2200 a([<) p 312 2200 a(a]) p 389 2200 a(->) p 466 2200 a(unit) p 594 2200 a(=) p 645 2200 a() 133 2260 y(#) p 184 2260 a(fun) p 286 2260 a(x) p 338 2260 a(->) p 414 2260 a(f1) p 491 2260 a(x;) p 568 2260 a(f3) p 645 2260 a(x;;) 133 2321 y(Character) o(s) p 414 2321 a(18-19:) 133 2381 y(This) p 261 2381 a(expressio) o(n) p 543 2381 a(has) p 645 2381 a(type) p 773 2381 a([<) p 850 2381 a(a) p 902 2381 a(b\(int\)]) p 1107 2381 a(but) p 1209 2381 a(is) p 1286 2381 a(here) p 1414 2381 a(used) p 1542 2381 a(with) p 1670 2381 a(type) 184 2441 y([<) p 261 2441 a(a) p 312 2441 a(b\(bool\)]) p Fk 84 2555 a(Here) p 204 2555 a(the) p 292 2555 a(constrain) o(t) p 526 2555 a(in) o(tro) q(duced) p 775 2555 a(b) o(y) p Fe 848 2555 a(f2) p Fk 920 2555 a(hides) p 1049 2555 a(the) p 1138 2555 a(constructor) p Fe 1401 2555 a(b) p Fk(,) p 1462 2555 a(and) p 1562 2555 a(a) o(v) o(oids) p 1714 2555 a(a) p 1760 2555 a(clash) 11 2615 y(b) q(et) o(w) o(een) p Fe 199 2615 a(int) p Fk 292 2615 a(and) p Fe 387 2615 a(bool) p Fk(.) 84 2676 y(An) p 163 2676 a(easy) p 270 2676 a(w) o(a) o(y) p 369 2676 a(to) p 428 2676 a(solv) o(e) p 547 2676 a(this) p 642 2676 a(w) o(ould) p 784 2676 a(b) q(e) p 850 2676 a(to) p 909 2676 a(restrict) p 1077 2676 a(hiding) p 1226 2676 a(absen) o(t) p 1379 2676 a(lab) q(els) p 1515 2676 a(to) p 1575 2676 a(generic) p 1739 2676 a(t) o(yp) q(es.) 11 2736 y(This) p 124 2736 a(w) o(a) o(y) p 224 2736 a(the) p 310 2736 a(second) p 469 2736 a(case) p 574 2736 a(w) o(ould) p 718 2736 a(still) p 814 2736 a(fail,) p 913 2736 a(since) p Fe 1034 2736 a(x) p Fk 1077 2736 a(has) p 1166 2736 a(a) p 1208 2736 a(monorphic) p 1451 2736 a(t) o(yp) q(e.) p 1584 2736 a(This) p 1697 2736 a(solution) 11 2796 y(w) o(ould) p 153 2796 a(b) q(e) p 219 2796 a(correct) p 382 2796 a(and) p 477 2796 a(principal.) 926 2937 y(2) p eop PStoPSsaved restore %%Page: (2,3) 2 userdict/PStoPSsaved save put PStoPSmatrix setmatrix 595.000000 0.271378 translate 90 rotate 0.706651 dup scale userdict/PStoPSmatrix matrix currentmatrix put userdict/PStoPSclip{0 0 moveto 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto closepath}put initclip /showpage{}def/copypage{}def/erasepage{}def PStoPSxform concat 3 2 bop Fk 84 168 a(Ho) o(w) o(ev) o(er,) p 293 168 a(one) p 382 168 a(can) p 472 168 a(easily) p 606 168 a(see) p 684 168 a(that) p 789 168 a(this) p 884 168 a(solution) p 1068 168 a(is) p 1117 168 a(coun) o(ter-in) o(tuitiv) o(e.) p 1504 168 a(F) l(or) p 1591 168 a(the) p 1675 168 a(user,) p Fe 1791 168 a(b) p Fk 1833 168 a(is) 11 229 y(already) p 183 229 a(an) p 250 229 a(imp) q(ossible) p 488 229 a(constructor,) p 759 229 a(and) p 854 229 a(ha) o(ving) p 1011 229 a(a) p 1052 229 a(clash) p 1174 229 a(on) p 1242 229 a(it) p 1291 229 a(is) p 1340 229 a(hard) p 1453 229 a(to) p 1513 229 a(understand.) 84 289 y(Another) p 277 289 a(solution) p 463 289 a(is) p 514 289 a(to) p 575 289 a(go) p 642 289 a(the) p 728 289 a(opp) q(osite) p 924 289 a(w) o(a) o(y) l(.) p 1044 289 a(T) l(o) p 1117 289 a(accept) p 1271 289 a(more) p 1395 289 a(programs.) p 1634 289 a(This) p 1747 289 a(is) p 1798 289 a(the) 11 349 y(w) o(a) o(y) p 109 349 a(w) o(e) p 181 349 a(explore) p 351 349 a(here,) p 470 349 a(with) p 581 349 a(an) p 649 349 a(unc) o(hanged) p 891 349 a(syn) o(tax.) p Fi 11 479 a(T) n(yping) p Fk 11 571 a(The) p 114 571 a(idea) p 220 571 a(is) p 273 571 a(to) p 336 571 a(dela) o(y) p 466 571 a(uni\014cation) p 711 571 a(on) p 782 571 a(constructor) p 1043 571 a(un) o(til) p 1161 571 a(they) p 1274 571 a(are) p 1359 571 a(explicitely) p 1595 571 a(kno) o(wn) p 1753 571 a(to) p 1816 571 a(b) q(e) 11 631 y(presen) o(t.) p 199 631 a(W) l(e) p 280 631 a(k) o(eep) p 390 631 a(the) p 472 631 a(\() p Fg(T) t(;) p 546 631 a(U;) p 601 631 a(L) p Fk(\)) p 666 631 a(represen) o(tation) p 983 631 a(of) p 1036 631 a(v) m(arian) o(t) p 1200 631 a(t) o(yp) q(es,) p 1341 631 a(but) p Fg 1428 631 a(T) p Fk 1478 631 a(is) p 1525 631 a(no) p 1591 631 a(longer) p 1735 631 a(a) p 1774 631 a(map) 11 692 y(from) p 126 692 a(constructors) p 403 692 a(to) p 462 692 a(t) o(yp) q(es,) p 605 692 a(but) p 694 692 a(from) p 809 692 a(constructors) p 1086 692 a(to) p 1146 692 a(sets) p 1241 692 a(of) p 1297 692 a(t) o(yp) q(es.) 84 752 y(When) p 230 752 a(w) o(e) p 307 752 a(unify) p 436 752 a(t) o(w) o(o) p 532 752 a(v) m(arian) o(t) p 702 752 a(t) o(yp) q(es,) p 850 752 a(the) p 938 752 a(\014rst) p 1043 752 a(step) p 1150 752 a(is) p 1204 752 a(just) p 1305 752 a(to) p 1369 752 a(tak) o(e) p 1479 752 a(the) p 1567 752 a(union) p 1707 752 a(of) p 1767 752 a(b) q(oth) 11 812 y(t) o(yping) p 162 812 a(en) o(vironmen) o (ts,) p 476 812 a(dropping) p 682 812 a(unnecessary) p 952 812 a(t) o(yp) q(es.) 204 932 y(\() p Fg(T) p Ff 252 939 a(1) p Fg 272 932 a(;) p 294 932 a(U) p Ff 327 939 a(1) p Fg 346 932 a(;) p 368 932 a(L) p Ff 401 939 a(1) p Fk 421 932 a(\)) p Fj 451 932 a(^) p Fk 495 932 a(\() p Fg(T) p Ff 543 939 a(2) p Fg 563 932 a(;) p 585 932 a(U) p Ff 618 939 a(2) p Fg 637 932 a(;) p 659 932 a(L) p Ff 692 939 a(2) p Fk 712 932 a(\)) p 745 932 a(=) p 797 932 a(\(\() p Fg(T) p Ff 864 939 a(1) p Fj 883 932 a(j) p Fb 897 939 a(U) p Fa 921 944 a(1) p Fd 938 939 a(\\) p Fb(U) p Fa 986 944 a(2) p Fk 1005 932 a(\)) p Fj 1035 932 a([) p Fk 1079 932 a(\() p Fg(T) p Ff 1127 939 a(2) p Fj 1146 932 a(j) p Fb 1160 939 a(U) p Fa 1184 944 a(1) p Fd 1201 939 a(\\) p Fb(U) p Fa 1249 944 a(2) p Fk 1268 932 a(\)) p Fg(;) p 1309 932 a(U) p Ff 1342 939 a(1) p Fj 1373 932 a(\\) p Fg 1417 932 a(U) p Ff 1450 939 a(2) p Fg 1470 932 a(;) p 1492 932 a(L) p Ff 1525 939 a(1) p Fj 1556 932 a([) p Fg 1600 932 a(L) p Ff 1633 939 a(2) p Fk 1653 932 a(\)) 84 1042 y(Here) p 203 1042 a(the) p 291 1042 a(union) p 431 1042 a(of) p 490 1042 a(t) o(w) o(o) p 587 1042 a(t) o(yping) p 742 1042 a(en) o(vironmen) o (ts) p 1046 1042 a(is) p 1099 1042 a(the) p 1187 1042 a(p) q(oin) o(t) o(wise) p 1407 1042 a(union) p 1547 1042 a(of) p 1606 1042 a(their) p 1727 1042 a(sets) p 1826 1042 a(of) 11 1102 y(t) o(yp) q(es) p 140 1102 a(for) p 214 1102 a(eac) o(h) p 324 1102 a(constructor.) 84 1162 y(This) p 195 1162 a(\014rst) p 296 1162 a(step) p 399 1162 a(nev) o(er) p 529 1162 a(fails.) 84 1222 y(In) p 145 1222 a(a) p 186 1222 a(second) p 343 1222 a(step,) p 460 1222 a(structural) p 685 1222 a(constrain) o(ts) p 934 1222 a(are) p 1015 1222 a(enforced) p 1209 1222 a(on) p 1277 1222 a(the) p 1361 1222 a(resulting) p 1562 1222 a(t) o(yp) q(e) p 1672 1222 a(\() p Fg(T) t(;) p 1746 1222 a(U;) p 1801 1222 a(L) p Fk(\).) 11 1282 y(First,) p Fg 144 1282 a(L) p Fk 195 1282 a(should) p 351 1282 a(b) q(e) p 418 1282 a(included) p 614 1282 a(in) p Fg 672 1282 a(U) p Fk 710 1282 a(.) p 749 1282 a(Then,) p 892 1282 a(for) p 967 1282 a(all) p 1036 1282 a(constructors) p 1314 1282 a(app) q(earing) p 1542 1282 a(in) p Fg 1600 1282 a(L) p Fk(,) p 1664 1282 a(the) p 1749 1282 a(set) p 1826 1282 a(of) 11 1343 y(t) o(yp) q(es) p 136 1343 a(asso) q(ciated) p 365 1343 a(with) p 472 1343 a(eac) o(h) p 578 1343 a(constructor) p 833 1343 a(is) p 878 1343 a(collapsed) p 1084 1343 a(b) o(y) p 1148 1343 a(uni\014cation.) p 1407 1343 a(This) p 1515 1343 a(can) p 1600 1343 a(b) q(e) p 1663 1343 a(expressed) 11 1403 y(b) o(y) p 78 1403 a(rewriting) p 287 1403 a(rules,) p 417 1403 a(where) p Fg 558 1403 a(e) p Fk 597 1403 a(is) p 646 1403 a(a) p 687 1403 a(m) o(ulti-equation) p 1015 1403 a(and) p Fg 1109 1403 a(\036) p Fk 1155 1403 a(a) p 1195 1403 a(set) p 1271 1403 a(of) p 1327 1403 a(m) o(ultiequations) 249 1509 y(if) p Fg 294 1509 a(L) p Fj 341 1509 a(6\032) p Fg 393 1509 a(U) p Fk 448 1509 a(then) p 559 1509 a(\() p Fg(T) t(;) p 633 1509 a(U;) p 688 1509 a(L) p Fk(\)) p 753 1509 a(=) p Fg 805 1509 a(e) p Fj 839 1509 a(^) p Fg 883 1509 a(\036) p Fj 926 1509 a(\000) p 956 1509 a(!) p 1020 1509 a(?) p Fk 249 1629 a(if) p Fg 294 1629 a(l) p Fj 323 1629 a(2) p Fg 370 1629 a(L) p Fk 420 1629 a(and) p Fg 515 1629 a(T) p Fk 551 1629 a(\() p Fg(l) p Fk 586 1629 a(\)) p 617 1629 a(=) p Fj 669 1629 a(f) p Fg(\034) p Ff 715 1636 a(1) p Fg 735 1629 a(;) p 757 1629 a(:) p 779 1629 a(:) p 801 1629 a(:) p 822 1629 a(;) p 844 1629 a(\034) p Fb 865 1636 a(n) p Fj 889 1629 a(g) p Fk 930 1629 a(then) 298 1689 y(\() p Fg(T) t(;) p 372 1689 a(U;) p 427 1689 a(L) p Fk(\)) p 492 1689 a(=) p Fg 544 1689 a(e) p Fj 577 1689 a(^) p Fg 622 1689 a(\036) p Fj 664 1689 a(\000) p 695 1689 a(!) p Fk 759 1689 a(\() p Fg(T) p Fj 814 1689 a(f) p Fg(l) p Fj 867 1689 a(7!) p Fg 931 1689 a(\034) p Ff 952 1696 a(1) p Fj 972 1689 a(g) p Fg(;) p 1019 1689 a(U;) p 1074 1689 a(L) p Fk(\)) p 1139 1689 a(=) p Fg 1191 1689 a(e) p Fj 1225 1689 a(^) p Fg 1269 1689 a(\034) p Ff 1290 1696 a(1) p Fk 1324 1689 a(=) p Fg 1376 1689 a(:) p 1398 1689 a(:) p 1420 1689 a(:) p Fk 1447 1689 a(=) p Fg 1498 1689 a(\034) p Fb 1519 1696 a(n) p Fj 1554 1689 a(^) p Fg 1598 1689 a(\036) p Fk 84 1796 a(Optionally) p 331 1796 a(one) p 425 1796 a(can) p 519 1796 a(add) p 619 1796 a(rules) p 740 1796 a(that) p 850 1796 a(remo) o(v) o(e) p 1022 1796 a(a) p 1067 1796 a(constructor) p Fg 1329 1796 a(l) p Fk 1366 1796 a(from) p Fg 1486 1796 a(U) p Fk 1545 1796 a(if) p 1594 1796 a(the) p 1683 1796 a(equation) 11 1856 y(obtained) p 211 1856 a(from) p Fg 326 1856 a(T) p Fk 362 1856 a(\() p Fg(l) p Fk 397 1856 a(\)) p 431 1856 a(has) p 518 1856 a(no) p 586 1856 a(solution.) p 790 1856 a(Suc) o(h) p 908 1856 a(rules) p 1024 1856 a(w) o(ould) p 1167 1856 a(b) q(e) p 1233 1856 a(sound) p 1374 1856 a(and) p 1469 1856 a(complete.) p Fi 11 1986 a(Syn) n(tax) p 198 1986 a(of) p 262 1986 a(t) n(yp) r(es) p Fk 11 2078 a(Thanks) p 188 2078 a(to) p 250 2078 a(the) p 336 2078 a(go) q(o) q(d) p 458 2078 a(prop) q(erties) p 689 2078 a(of) p 747 2078 a(these) p 874 2078 a(constrain) o(ts,) p 1139 2078 a(the) p 1226 2078 a(surface) p 1392 2078 a(syn) o(tax) p 1551 2078 a(of) p 1608 2078 a(t) o(yp) q(es) p 1740 2078 a(w) o(ould) 11 2138 y(only) p 118 2138 a(ha) o(v) o(e) p 230 2138 a(to) p 290 2138 a(b) q(e) p 356 2138 a(sligh) o(tly) p 527 2138 a(extended.) p Fh 590 2244 a(tag-typ) n(e) p Fk 798 2244 a(::=) p Fh 904 2244 a(ident) p Fj 849 2304 a(j) p Fh 904 2304 a(ident) p Fe 1031 2304 a(\() p Fh(typ) n(expr-list) p Fe(\)) p Fh 523 2365 a(typ) n(expr-list) p Fk 798 2365 a(::=) p Fh 904 2365 a(typ) n(expr) p Fj 849 2425 a(j) p Fh 904 2425 a(typ) n(expr) p Fe 1078 2425 a(&) p Fh 1120 2425 a(typ) n(expr-list) p Fk 84 2531 a(Notice) p 234 2531 a(that) p 336 2531 a(a) p 373 2531 a(0-ary) p 496 2531 a(constructor) p 751 2531 a(and) p 842 2531 a(an) p 907 2531 a(1-ary) p 1030 2531 a(construtor) p 1262 2531 a(are) p 1340 2531 a(con) o(tradictory) l(,) p 1648 2531 a(and) p 1740 2531 a(w) o(ould) 11 2592 y(result) p 146 2592 a(in) p 203 2592 a(the) p 287 2592 a(absence) p 466 2592 a(of) p 522 2592 a(this) p 617 2592 a(constructor.) 926 2937 y(3) p eop PStoPSsaved restore userdict/PStoPSsaved save put PStoPSmatrix setmatrix 595.000000 421.271378 translate 90 rotate 0.706651 dup scale userdict/PStoPSmatrix matrix currentmatrix put userdict/PStoPSclip{0 0 moveto 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto closepath}put initclip PStoPSxform concat 4 3 bop Fi 11 168 a(Discussion) p Fk 11 261 a(Suc) o(h) p 133 261 a(a) p 179 261 a(c) o(hange) p 345 261 a(has) p 436 261 a(the) p 525 261 a(ma) s(jor) p 672 261 a(adv) m(an) o(tage) p 907 261 a(of) p 967 261 a(b) q(oth) p 1087 261 a(reco) o(v) o(ering) p 1324 261 a(principalit) o(y) p 1589 261 a(and) p 1688 261 a(a) o(v) o(oiding) 11 321 y(unin) o(tuitiv) o(e) p 266 321 a(error) p 392 321 a(messages.) p 640 321 a(Constrain) o(ts) p 909 321 a(created) p 1087 321 a(in) p 1152 321 a(suc) o(h) p 1269 321 a(a) p 1317 321 a(w) o(a) o(y) p 1423 321 a(are) p 1512 321 a(v) o(ery) p 1626 321 a(ligh) o(t:) p 1772 321 a(they) 11 381 y(alw) o(a) o(ys) p 165 381 a(app) q(ear) p 325 381 a(inside) p 463 381 a(a) p 502 381 a(v) m(arian) o(t) p 666 381 a(t) o(yp) q(e,) p 788 381 a(and) p 882 381 a(if) p 926 381 a(the) p 1008 381 a(v) m(arian) o(t) p 1172 381 a(t) o(yp) q(e) p 1281 381 a(do) q(es) p 1390 381 a(not) p 1475 381 a(app) q(ear) p 1635 381 a(in) p 1691 381 a(the) p 1774 381 a(\014nal) 11 441 y(t) o(yp) q(e) p 120 441 a(sc) o(heme,) p 301 441 a(then) p 412 441 a(the) p 496 441 a(constrain) o(t) p 725 441 a(can) p 815 441 a(b) q(e) p 881 441 a(discarded) p 1098 441 a(safely) l(.) 84 501 y(On) p 165 501 a(the) p 249 501 a(other) p 376 501 a(hand,) p 512 501 a(there) p 637 501 a(are) p 718 501 a(t) o(w) o(o) p 810 501 a(dra) o(wbac) o(ks.) p Fj 83 616 a(\017) p Fk 133 616 a(Some) p 259 616 a(errors) p 393 616 a(will) p 482 616 a(b) q(e) p 544 616 a(dela) o(y) o(ed) p 715 616 a(longer) p 858 616 a(than) p 968 616 a(no) o(w,) p 1080 616 a(un) o(til) p 1191 616 a(a) p 1228 616 a(construtor) p 1460 616 a(is) p 1505 616 a(actually) p 1687 616 a(included) 133 676 y(in) p Fg 189 676 a(L) p Fk(.) p 258 676 a(It) p 311 676 a(is) p 360 676 a(not) p 446 676 a(clear) p 563 676 a(ho) o(w) p 665 676 a(damageable) p 930 676 a(it) p 979 676 a(is.) p Fj 83 777 a(\017) p Fk 133 777 a(While) p 272 777 a(t) o(yp) q(e) p 378 777 a(inference) p 579 777 a(is) p 625 777 a(simple) p 774 777 a(and) p 865 777 a(costless) p 1036 777 a(for) p 1108 777 a(this) p 1200 777 a(extension,) p 1426 777 a(simpli\014cation) p 1724 777 a(of) p 1776 777 a(con-) 133 838 y(strain) o(ts) p 310 838 a(|marking) p 551 838 a(constructors) p 830 838 a(with) p 943 838 a(unsolv) m(able) p 1182 838 a(constrain) o(ts) p 1432 838 a(as) p 1494 838 a(absen) o(t,) p 1663 838 a(and) p 1760 838 a(elim-) 133 898 y(inating) p 300 898 a(redundan) o(t) p 536 898 a(t) o(yp) q(es) p 667 898 a(in) p 726 898 a(constrain) o(ts|) p 1025 898 a(is) p 1076 898 a(a) p 1119 898 a(bit) p 1197 898 a(more) p 1320 898 a(exp) q(ensiv) o(e.) p 1565 898 a(Also,) p 1691 898 a(allo) o(wing) 133 958 y(suc) o(h) p 244 958 a(constrained) p 506 958 a(t) o(yp) q(es) p 637 958 a(inside) p 777 958 a(signatures) p 1010 958 a(w) o(ould) p 1154 958 a(mean) p 1286 958 a(ha) o(ving) p 1444 958 a(to) p 1506 958 a(solv) o(e) p 1627 958 a(a) p 1669 958 a(matc) o(hing) 133 1018 y(problem,) p 333 1018 a(whic) o(h) p 469 1018 a(is) p 514 1018 a(exp) q(onen) o(tial) p 772 1018 a(in) p 825 1018 a(the) p 906 1018 a(n) o(um) o(b) q(er) p 1080 1018 a(of) p 1132 1018 a(connected) p 1356 1018 a(constrain) o(ts) p 1600 1018 a(inside) p 1735 1018 a(a) p 1772 1018 a(t) o(yp) q(e) 133 1078 y(sc) o(heme.) 84 1193 y(Reasonably) p 340 1193 a(e\016cien) o(t) p 516 1193 a(algorithms) p 754 1193 a(exist) p 866 1193 a(to) p 922 1193 a(solv) o(e) p 1038 1193 a(these) p 1159 1193 a(problems,) p 1379 1193 a(so) p 1435 1193 a(the) p 1515 1193 a(di\016cult) o(y) p 1715 1193 a(is) p 1760 1193 a(more) 11 1253 y(in) p 67 1253 a(the) p 151 1253 a(increased) p 363 1253 a(complexit) o(y) p 611 1253 a(of) p 667 1253 a(the) p 751 1253 a(t) o(yp) q(e-c) o(hec) o(k) o(er) p 1031 1253 a(than) p 1145 1253 a(in) p 1202 1253 a(run-time) p 1402 1253 a(cost.) p Fl 11 1397 a(Other) p 205 1397 a(features) p Fk 11 1490 a(Ob) s(jectiv) o(e) p 238 1490 a(Lab) q(el) p 380 1490 a(con) o(tains) p 579 1490 a(t) o(w) o(o) p 678 1490 a(other) p 812 1490 a(features:) p 1029 1490 a(p) q(olymorphic) p 1318 1490 a(metho) q(ds) p 1521 1490 a(and) p 1623 1490 a(t) o(yp) q(e-driv) o(en) 11 1550 y(access) p 153 1550 a(of) p 208 1550 a(records.) p 394 1550 a(Both) p 514 1550 a(of) p 568 1550 a(them) p 692 1550 a(use) p 775 1550 a(the) p 857 1550 a(same) p 978 1550 a(metho) q(d) p 1154 1550 a(of) p 1209 1550 a(enforcing) p 1417 1550 a(principalit) o(y) p 1676 1550 a(of) p 1730 1550 a(t) o(yping) 11 1610 y(through) p 191 1610 a(tracing) p 351 1610 a(user) p 450 1610 a(pro) o(vided) p 647 1610 a(t) o(yp) q(e) p 752 1610 a(information.) p 1034 1610 a(With) p 1155 1610 a(this) p 1246 1610 a(tracing,) p 1422 1610 a(their) p 1534 1610 a(implem) o(en) n(tation) 11 1670 y(is) p 60 1670 a(v) o(ery) p 167 1670 a(easy) l(,) p 283 1670 a(but) p 373 1670 a(without) p 554 1670 a(it) p 603 1670 a(they) p 713 1670 a(lo) q(ose) p 834 1670 a(principalit) o(y) l(.) 84 1730 y(While) p 229 1730 a(these) p 357 1730 a(features) p 543 1730 a(pro) o(vide) p 720 1730 a(some) p 845 1730 a(comfort) p 1029 1730 a(in) p 1089 1730 a(writing) p 1260 1730 a(user) p 1366 1730 a(programs,) p 1598 1730 a(they) p 1711 1730 a(are) p 1795 1730 a(not) 11 1791 y(strictly) p 182 1791 a(necessary) p 403 1791 a(for) p 482 1791 a(the) p 571 1791 a(v) m(arious) p 742 1791 a(libraries) p 934 1791 a(coming) p 1107 1791 a(with) p 1223 1791 a(O'Labl) p 1391 1791 a(\(LablTk,) p 1602 1791 a(LablGL) p 1787 1791 a(and) 11 1851 y(LablGTK\).) 926 2937 y(4) p eop PStoPSsaved restore %%Trailer end userdict /end-hook known{end-hook}if %%EOF mingw-ocaml/ocaml/experimental/garrigue/variable-names-Tvar.diffs0000644000175000017500000016474112124403240024611 0ustar tootstootsIndex: VERSION =================================================================== --- VERSION (リビジョン 11207) +++ VERSION (作業コピー) @@ -1,4 +1,4 @@ -3.13.0+dev6 (2011-07-29) +3.13.0+dev7 (2011-09-22) # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli Index: typing/typemod.ml =================================================================== --- typing/typemod.ml (リビジョン 11207) +++ typing/typemod.ml (作業コピー) @@ -764,7 +764,7 @@ Location.prerr_warning smod.pmod_loc (Warnings.Not_principal "this module unpacking"); modtype_of_package env smod.pmod_loc p nl tl - | {desc = Tvar} -> + | {desc = Tvar _} -> raise (Typecore.Error (smod.pmod_loc, Typecore.Cannot_infer_signature)) | _ -> Index: typing/typetexp.ml =================================================================== --- typing/typetexp.ml (リビジョン 11207) +++ typing/typetexp.ml (作業コピー) @@ -150,7 +150,7 @@ if strict then raise Already_bound; v with Not_found -> - let v = new_global_var() in + let v = new_global_var ~name () in type_variables := Tbl.add name v !type_variables; v @@ -165,8 +165,8 @@ Tpoly _ -> ty | _ -> Ctype.newty (Tpoly (ty, [])) -let new_pre_univar () = - let v = newvar () in pre_univars := v :: !pre_univars; v +let new_pre_univar ?name () = + let v = newvar ?name () in pre_univars := v :: !pre_univars; v let rec swap_list = function x :: y :: l -> y :: x :: swap_list l @@ -190,7 +190,8 @@ instance (fst(Tbl.find name !used_variables)) with Not_found -> let v = - if policy = Univars then new_pre_univar () else newvar () in + if policy = Univars then new_pre_univar ~name () else newvar ~name () + in used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables; v end @@ -333,7 +334,14 @@ end_def (); generalize_structure t; end; - instance t + let t = instance t in + let px = Btype.proxy t in + begin match px.desc with + | Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias) + | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias) + | _ -> () + end; + t end | Ptyp_variant(fields, closed, present) -> let name = ref None in @@ -388,7 +396,7 @@ {desc=Tvariant row}, _ when Btype.static_row row -> let row = Btype.row_repr row in row.row_fields - | {desc=Tvar}, Some(p, _) -> + | {desc=Tvar _}, Some(p, _) -> raise(Error(sty.ptyp_loc, Unbound_type_constructor_2 p)) | _ -> raise(Error(sty.ptyp_loc, Not_a_variant ty)) @@ -431,7 +439,7 @@ newty (Tvariant row) | Ptyp_poly(vars, st) -> begin_def(); - let new_univars = List.map (fun name -> name, newvar()) vars in + let new_univars = List.map (fun name -> name, newvar ~name ()) vars in let old_univars = !univars in univars := new_univars @ !univars; let ty = transl_type env policy st in @@ -443,10 +451,12 @@ (fun tyl (name, ty1) -> let v = Btype.proxy ty1 in if deep_occur v ty then begin - if v.level <> Btype.generic_level || v.desc <> Tvar then - raise (Error (styp.ptyp_loc, Cannot_quantify (name, v))); - v.desc <- Tunivar; - v :: tyl + match v.desc with + Tvar name when v.level = Btype.generic_level -> + v.desc <- Tunivar name; + v :: tyl + | _ -> + raise (Error (styp.ptyp_loc, Cannot_quantify (name, v))) end else tyl) [] new_univars in @@ -483,7 +493,7 @@ match ty.desc with | Tvariant row -> let row = Btype.row_repr row in - if (Btype.row_more row).desc = Tunivar then + if Btype.is_Tunivar (Btype.row_more row) then ty.desc <- Tvariant {row with row_fixed=true; row_fields = List.map @@ -512,7 +522,7 @@ then try r := (loc, v, Tbl.find name !type_variables) :: !r with Not_found -> - if fixed && (repr ty).desc = Tvar then + if fixed && Btype.is_Tvar (repr ty) then raise(Error(loc, Unbound_type_variable ("'"^name))); let v2 = new_global_var () in r := (loc, v, v2) :: !r; @@ -552,8 +562,10 @@ List.fold_left (fun acc v -> let v = repr v in - if v.level <> Btype.generic_level || v.desc <> Tvar then acc - else (v.desc <- Tunivar ; v :: acc)) + match v.desc with + Tvar name when v.level = Btype.generic_level -> + v.desc <- Tunivar name; v :: acc + | _ -> acc) [] !pre_univars in make_fixed_univars typ; @@ -635,8 +647,8 @@ fprintf ppf "The type variable name %s is not allowed in programs" name | Cannot_quantify (name, v) -> fprintf ppf "This type scheme cannot quantify '%s :@ %s." name - (if v.desc = Tvar then "it escapes this scope" else - if v.desc = Tunivar then "it is aliased to another variable" + (if Btype.is_Tvar v then "it escapes this scope" else + if Btype.is_Tunivar v then "it is aliased to another variable" else "it is not a variable") | Multiple_constraints_on_type s -> fprintf ppf "Multiple constraints for type %s" s Index: typing/btype.ml =================================================================== --- typing/btype.ml (リビジョン 11207) +++ typing/btype.ml (作業コピー) @@ -35,9 +35,9 @@ let new_id = ref (-1) let newty2 level desc = - incr new_id; { desc = desc; level = level; id = !new_id } + incr new_id; { desc; level; id = !new_id } let newgenty desc = newty2 generic_level desc -let newgenvar () = newgenty Tvar +let newgenvar ?name () = newgenty (Tvar name) (* let newmarkedvar level = incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id } @@ -46,6 +46,11 @@ { desc = Tvar; level = pivot_level - generic_level; id = !new_id } *) +(**** Check some types ****) + +let is_Tvar = function {desc=Tvar _} -> true | _ -> false +let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false + (**** Representative of a type ****) let rec field_kind_repr = @@ -139,7 +144,7 @@ let rec proxy_obj ty = match ty.desc with Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty - | Tvar | Tunivar | Tconstr _ -> ty + | Tvar _ | Tunivar _ | Tconstr _ -> ty | Tnil -> ty0 | _ -> assert false in proxy_obj ty @@ -180,13 +185,13 @@ row.row_fields; match (repr row.row_more).desc with Tvariant row -> iter_row f row - | Tvar | Tunivar | Tsubst _ | Tconstr _ -> + | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ -> Misc.may (fun (_,l) -> List.iter f l) row.row_name | _ -> assert false let iter_type_expr f ty = match ty.desc with - Tvar -> () + Tvar _ -> () | Tarrow (_, ty1, ty2, _) -> f ty1; f ty2 | Ttuple l -> List.iter f l | Tconstr (_, l, _) -> List.iter f l @@ -198,7 +203,7 @@ | Tnil -> () | Tlink ty -> f ty | Tsubst ty -> f ty - | Tunivar -> () + | Tunivar _ -> () | Tpoly (ty, tyl) -> f ty; List.iter f tyl | Tpackage (_, _, l) -> List.iter f l @@ -239,13 +244,13 @@ encoding during substitution *) let rec norm_univar ty = match ty.desc with - Tunivar | Tsubst _ -> ty + Tunivar _ | Tsubst _ -> ty | Tlink ty -> norm_univar ty | Ttuple (ty :: _) -> norm_univar ty | _ -> assert false let rec copy_type_desc f = function - Tvar -> Tvar + Tvar _ -> Tvar None (* forget the name *) | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c) | Ttuple l -> Ttuple (List.map f l) | Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil) @@ -258,7 +263,7 @@ | Tnil -> Tnil | Tlink ty -> copy_type_desc f ty.desc | Tsubst ty -> assert false - | Tunivar -> Tunivar + | Tunivar _ as ty -> ty (* keep the name *) | Tpoly (ty, tyl) -> let tyl = List.map (fun x -> norm_univar (f x)) tyl in Tpoly (f ty, tyl) @@ -447,7 +452,7 @@ | Cuniv of type_expr option ref * type_expr option let undo_change = function - Ctype (ty, desc) -> ty.desc <- desc + Ctype (ty, desc) -> ty.desc <- desc | Clevel (ty, level) -> ty.level <- level | Cname (r, v) -> r := v | Crow (r, v) -> r := v @@ -474,7 +479,22 @@ let log_type ty = if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) -let link_type ty ty' = log_type ty; ty.desc <- Tlink ty' +let link_type ty ty' = + log_type ty; + let desc = ty.desc in + ty.desc <- Tlink ty'; + (* Name is a user-supplied name for this unification variable (obtained + * through a type annotation for instance). *) + match desc, ty'.desc with + Tvar name, Tvar name' -> + begin match name, name' with + | Some _, None -> log_type ty'; ty'.desc <- Tvar name + | None, Some _ -> () + | Some _, Some _ -> + if ty.level < ty'.level then (log_type ty'; ty'.desc <- Tvar name) + | None, None -> () + end + | _ -> () (* ; assert (check_memorized_abbrevs ()) *) (* ; check_expans [] ty' *) let set_level ty level = Index: typing/typecore.ml =================================================================== --- typing/typecore.ml (リビジョン 11207) +++ typing/typecore.ml (作業コピー) @@ -633,7 +633,7 @@ List.iter generalize vars; let instantiated tv = let tv = expand_head !env tv in - tv.desc <> Tvar || tv.level <> generic_level in + not (is_Tvar tv) || tv.level <> generic_level in if List.exists instantiated vars then raise (Error(loc, Polymorphic_label (lid_of_label label))) end; @@ -1126,7 +1126,7 @@ Tarrow (l, _, ty_res, _) -> list_labels_aux env (ty::visited) (l::ls) ty_res | _ -> - List.rev ls, ty.desc = Tvar + List.rev ls, is_Tvar ty let list_labels env ty = list_labels_aux env [] [] ty @@ -1142,9 +1142,10 @@ (fun t -> let t = repr t in generalize t; - if t.desc = Tvar && t.level = generic_level then - (log_type t; t.desc <- Tunivar; true) - else false) + match t.desc with + Tvar name when t.level = generic_level -> + log_type t; t.desc <- Tunivar name; true + | _ -> false) vars in if List.length vars = List.length vars' then () else let ty = newgenty (Tpoly(repr exp.exp_type, vars')) @@ -1158,7 +1159,7 @@ match (expand_head env exp.exp_type).desc with | Tarrow _ -> Location.prerr_warning exp.exp_loc Warnings.Partial_application - | Tvar -> () + | Tvar _ -> () | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () | _ -> if statement then @@ -1742,7 +1743,7 @@ let (id, typ) = filter_self_method env met Private meths privty in - if (repr typ).desc = Tvar then + if is_Tvar (repr typ) then Location.prerr_warning loc (Warnings.Undeclared_virtual_method met); (Texp_send(obj, Tmeth_val id), typ) @@ -1797,7 +1798,7 @@ Location.prerr_warning loc (Warnings.Not_principal "this use of a polymorphic method"); snd (instance_poly false tl ty) - | {desc = Tvar} as ty -> + | {desc = Tvar _} as ty -> let ty' = newvar () in unify env (instance ty) (newty(Tpoly(ty',[]))); (* if not !Clflags.nolabels then @@ -1979,7 +1980,7 @@ end_def (); check_univars env false "method" exp ty_expected vars; re { exp with exp_type = instance ty } - | Tvar -> + | Tvar _ -> let exp = type_exp env sbody in let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in unify_exp env exp ty; @@ -2038,7 +2039,7 @@ Location.prerr_warning loc (Warnings.Not_principal "this module packing"); (p, nl, tl) - | {desc = Tvar} -> + | {desc = Tvar _} -> raise (Error (loc, Cannot_infer_signature)) | _ -> raise (Error (loc, Not_a_packed_module ty_expected)) @@ -2128,7 +2129,7 @@ ty_fun | Tarrow (l,_,ty_res',_) when l = "" || !Clflags.classic -> args, ty_fun, no_labels ty_res' - | Tvar -> args, ty_fun, false + | Tvar _ -> args, ty_fun, false | _ -> [], texp.exp_type, false in let args, ty_fun', simple_res = make_args [] texp.exp_type in @@ -2192,7 +2193,7 @@ let (ty1, ty2) = let ty_fun = expand_head env ty_fun in match ty_fun.desc with - Tvar -> + Tvar _ -> let t1 = newvar () and t2 = newvar () in let not_identity = function Texp_ident(_,{val_kind=Val_prim @@ -2335,7 +2336,7 @@ begin match (expand_head env exp.exp_type).desc with | Tarrow _ -> Location.prerr_warning exp.exp_loc Warnings.Partial_application - | Tvar -> + | Tvar _ -> add_delayed_check (fun () -> check_application_result env false exp) | _ -> () end; @@ -2404,9 +2405,9 @@ | Tarrow _ -> Location.prerr_warning loc Warnings.Partial_application | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () - | Tvar when ty.level > tv.level -> + | Tvar _ when ty.level > tv.level -> Location.prerr_warning loc Warnings.Nonreturning_statement - | Tvar -> + | Tvar _ -> add_delayed_check (fun () -> check_application_result env true exp) | _ -> Location.prerr_warning loc Warnings.Statement_type Index: typing/btype.mli =================================================================== --- typing/btype.mli (リビジョン 11207) +++ typing/btype.mli (作業コピー) @@ -23,7 +23,7 @@ (* Create a type *) val newgenty: type_desc -> type_expr (* Create a generic type *) -val newgenvar: unit -> type_expr +val newgenvar: ?name:string -> unit -> type_expr (* Return a fresh generic variable *) (* Use Tsubst instead @@ -33,6 +33,9 @@ (* Return a fresh marked generic variable *) *) +val is_Tvar: type_expr -> bool +val is_Tunivar: type_expr -> bool + val repr: type_expr -> type_expr (* Return the canonical representative of a type. *) Index: typing/ctype.mli =================================================================== --- typing/ctype.mli (リビジョン 11207) +++ typing/ctype.mli (作業コピー) @@ -41,9 +41,10 @@ (* This pair of functions is only used in Typetexp *) val newty: type_desc -> type_expr -val newvar: unit -> type_expr +val newvar: ?name:string -> unit -> type_expr +val newvar2: ?name:string -> int -> type_expr (* Return a fresh variable *) -val new_global_var: unit -> type_expr +val new_global_var: ?name:string -> unit -> type_expr (* Return a fresh variable, bound at toplevel (as type variables ['a] in type constraints). *) val newobj: type_expr -> type_expr Index: typing/datarepr.ml =================================================================== --- typing/datarepr.ml (リビジョン 11207) +++ typing/datarepr.ml (作業コピー) @@ -28,7 +28,7 @@ if ty.level >= lowest_level then begin ty.level <- pivot_level - ty.level; match ty.desc with - | Tvar -> + | Tvar _ -> ret := TypeSet.add ty !ret | Tvariant row -> let row = row_repr row in Index: typing/typeclass.ml =================================================================== --- typing/typeclass.ml (リビジョン 11207) +++ typing/typeclass.ml (作業コピー) @@ -532,7 +532,7 @@ (Typetexp.transl_simple_type val_env false sty) ty end; begin match (Ctype.repr ty).desc with - Tvar -> + Tvar _ -> let ty' = Ctype.newvar () in Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty; Ctype.unify val_env (type_approx val_env sbody) ty' Index: typing/typedecl.ml =================================================================== --- typing/typedecl.ml (リビジョン 11207) +++ typing/typedecl.ml (作業コピー) @@ -111,7 +111,7 @@ | _ -> raise (Error (loc, Bad_fixed_type "is not an object or variant")) in - if rv.desc <> Tvar then + if not (Btype.is_Tvar rv) then raise (Error (loc, Bad_fixed_type "has no row variable")); rv.desc <- Tconstr (p, decl.type_params, ref Mnil) @@ -503,7 +503,7 @@ compute_same row.row_more | Tpoly (ty, _) -> compute_same ty - | Tvar | Tnil | Tlink _ | Tunivar -> () + | Tvar _ | Tnil | Tlink _ | Tunivar _ -> () | Tpackage (_, _, tyl) -> List.iter (compute_variance_rec true true true) tyl end @@ -546,7 +546,7 @@ in List.iter2 (fun (ty, co, cn, ct) (c, n) -> - if ty.desc <> Tvar then begin + if not (Btype.is_Tvar ty) then begin co := c; cn := n; ct := n; compute_variance env tvl2 c n n ty end) @@ -571,7 +571,7 @@ let rec anonymous env ty = match (Ctype.expand_head env ty).desc with - | Tvar -> false + | Tvar _ -> false | Tobject (fi, _) -> let _, rv = Ctype.flatten_fields fi in anonymous env rv | Tvariant row -> Index: typing/types.mli =================================================================== --- typing/types.mli (リビジョン 11207) +++ typing/types.mli (作業コピー) @@ -24,7 +24,7 @@ mutable id: int } and type_desc = - Tvar + Tvar of string option | Tarrow of label * type_expr * type_expr * commutable | Ttuple of type_expr list | Tconstr of Path.t * type_expr list * abbrev_memo ref @@ -34,7 +34,7 @@ | Tlink of type_expr | Tsubst of type_expr (* for copying *) | Tvariant of row_desc - | Tunivar + | Tunivar of string option | Tpoly of type_expr * type_expr list | Tpackage of Path.t * string list * type_expr list Index: typing/ctype.ml =================================================================== --- typing/ctype.ml (リビジョン 11207) +++ typing/ctype.ml (作業コピー) @@ -153,9 +153,9 @@ let newty desc = newty2 !current_level desc let new_global_ty desc = newty2 !global_level desc -let newvar () = newty2 !current_level Tvar -let newvar2 level = newty2 level Tvar -let new_global_var () = newty2 !global_level Tvar +let newvar ?name () = newty2 !current_level (Tvar name) +let newvar2 ?name level = newty2 level (Tvar name) +let new_global_var ?name () = newty2 !global_level (Tvar name) let newobj fields = newty (Tobject (fields, ref None)) @@ -297,14 +297,12 @@ let opened_object ty = match (object_row ty).desc with - | Tvar -> true - | Tunivar -> true - | Tconstr _ -> true - | _ -> false + | Tvar _ | Tunivar _ | Tconstr _ -> true + | _ -> false let concrete_object ty = match (object_row ty).desc with - | Tvar -> false + | Tvar _ -> false | _ -> true (**** Close an object ****) @@ -313,7 +311,7 @@ let rec close ty = let ty = repr ty in match ty.desc with - Tvar -> + Tvar _ -> link_type ty (newty2 ty.level Tnil) | Tfield(_, _, _, ty') -> close ty' | _ -> assert false @@ -329,7 +327,7 @@ let ty = repr ty in match ty.desc with Tfield (_, _, _, ty) -> find ty - | Tvar -> ty + | Tvar _ -> ty | _ -> assert false in match (repr ty).desc with @@ -434,7 +432,7 @@ let level = ty.level in ty.level <- pivot_level - level; match ty.desc with - Tvar when level <> generic_level -> + Tvar _ when level <> generic_level -> raise Non_closed | Tfield(_, kind, t1, t2) -> if field_kind_repr kind = Fpresent then @@ -468,7 +466,7 @@ if ty.level >= lowest_level then begin ty.level <- pivot_level - ty.level; begin match ty.desc, !really_closed with - Tvar, _ -> + Tvar _, _ -> free_variables := (ty, real) :: !free_variables | Tconstr (path, tl, _), Some env -> begin try @@ -639,7 +637,7 @@ let rec generalize_structure var_level ty = let ty = repr ty in if ty.level <> generic_level then begin - if ty.desc = Tvar && ty.level > var_level then + if is_Tvar ty && ty.level > var_level then set_level ty var_level else if ty.level > !current_level then begin set_level ty generic_level; @@ -858,7 +856,7 @@ TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ)); List.iter (add_univar univ) inv.inv_parents in - TypeHash.iter (fun ty inv -> if ty.desc = Tunivar then add_univar ty inv) + TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv) inverted; fun ty -> try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty @@ -913,7 +911,7 @@ if keep then ty.level else !current_level else generic_level in - if forget <> generic_level then newty2 forget Tvar else + if forget <> generic_level then newty2 forget (Tvar None) else let desc = ty.desc in save_desc ty desc; let t = newvar() in (* Stub *) @@ -959,7 +957,7 @@ | Tconstr _ -> if keep then save_desc more more.desc; copy more - | Tvar | Tunivar -> + | Tvar _ | Tunivar _ -> save_desc more more.desc; if keep then more else newty more.desc | _ -> assert false @@ -1117,7 +1115,7 @@ t else try let t, bound_t = List.assq ty visited in - let dl = if ty.desc = Tunivar then [] else diff_list bound bound_t in + let dl = if is_Tunivar ty then [] else diff_list bound bound_t in if dl <> [] && conflicts univars dl then raise Not_found; t with Not_found -> begin @@ -1134,14 +1132,14 @@ let row = row_repr row0 in let more = repr row.row_more in (* We shall really check the level on the row variable *) - let keep = more.desc = Tvar && more.level <> generic_level in + let keep = is_Tvar more && more.level <> generic_level in let more' = copy_rec more in - let fixed' = fixed && (repr more').desc = Tvar in + let fixed' = fixed && is_Tvar (repr more') in let row = copy_row copy_rec fixed' row keep more' in Tvariant row | Tpoly (t1, tl) -> let tl = List.map repr tl in - let tl' = List.map (fun t -> newty Tunivar) tl in + let tl' = List.map (fun t -> newty t.desc) tl in let bound = tl @ bound in let visited = List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in @@ -1395,7 +1393,7 @@ let rec full_expand env ty = let ty = repr (expand_head env ty) in match ty.desc with - Tobject (fi, {contents = Some (_, v::_)}) when (repr v).desc = Tvar -> + Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) -> newty2 ty.level (Tobject (fi, ref None)) | _ -> ty @@ -1570,8 +1568,8 @@ true then match ty.desc with - Tunivar -> - if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()]) + Tunivar _ -> + if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar ()]) | Tpoly (ty, tyl) -> let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in occur_rec bound ty @@ -1620,7 +1618,7 @@ Tpoly (t, tl) -> if List.exists (fun t -> TypeSet.mem (repr t) family) tl then () else occur t - | Tunivar -> + | Tunivar _ -> if TypeSet.mem t family then raise Occur | Tconstr (_, [], _) -> () | Tconstr (p, tl, _) -> @@ -1784,7 +1782,7 @@ t end; iter_type_expr (iterator visited) ty - | Tvar -> + | Tvar _ -> let t = create_fresh_constr ty.level false in link_type ty t | _ -> @@ -1862,8 +1860,8 @@ let t2 = repr t2 in if t1 == t2 then () else match (t1.desc, t2.desc) with - | (Tvar, _) - | (_, Tvar) -> + | (Tvar _, _) + | (_, Tvar _) -> fatal_error "types should not include variables" | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> () @@ -1877,7 +1875,7 @@ with Not_found -> TypePairs.add type_pairs (t1', t2') (); match (t1'.desc, t2'.desc) with - (Tvar, Tvar) -> + (Tvar _, Tvar _) -> fatal_error "types should not include variables" | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 || !Clflags.classic && not (is_optional l1 || is_optional l2) -> @@ -1903,7 +1901,7 @@ | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> enter_poly env univar_pairs t1 tl1 t2 tl2 (mcomp type_pairs subst env) - | (Tunivar, Tunivar) -> + | (Tunivar _, Tunivar _) -> unify_univar t1' t2' !univar_pairs | (_, _) -> raise (Unify []) @@ -2048,21 +2046,21 @@ try type_changed := true; match (t1.desc, t2.desc) with - (Tvar, Tconstr _) when deep_occur t1 t2 -> + (Tvar _, Tconstr _) when deep_occur t1 t2 -> unify2 env t1 t2 - | (Tconstr _, Tvar) when deep_occur t2 t1 -> + | (Tconstr _, Tvar _) when deep_occur t2 t1 -> unify2 env t1 t2 - | (Tvar, _) -> + | (Tvar _, _) -> occur !env t1 t2; occur_univar !env t2; link_type t1 t2; update_level !env t1.level t2 - | (_, Tvar) -> + | (_, Tvar _) -> occur !env t2 t1; occur_univar !env t1; link_type t2 t1; update_level !env t2.level t1 - | (Tunivar, Tunivar) -> + | (Tunivar _, Tunivar _) -> unify_univar t1 t2 !univar_pairs; update_level !env t1.level t2; link_type t1 t2 @@ -2104,7 +2102,7 @@ (* Assumes either [t1 == t1'] or [t2 != t2'] *) let d1 = t1'.desc and d2 = t2'.desc in match (d1, d2) with (* handle univars specially *) - (Tunivar, Tunivar) -> + (Tunivar _, Tunivar _) -> unify_univar t1' t2' !univar_pairs; update_level !env t1'.level t2'; link_type t1' t2' @@ -2127,12 +2125,12 @@ | Old -> f () (* old_link was already called *) in match d1, d2 with - | Tvar,_ -> + | Tvar _, _ -> occur !env t1 t2'; occur_univar !env t2; update_level !env t1'.level t2; link_type t1' t2; - | _, Tvar -> + | _, Tvar _ -> occur !env t2 t1'; occur_univar !env t1; update_level !env t2'.level t1; @@ -2149,8 +2147,8 @@ add_type_equality t1' t2' end; try begin match (d1, d2) with - | (Tvar, _) - | (_, Tvar) -> + | (Tvar _, _) + | (_, Tvar _) -> (* cases taken care of *) assert false | (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 @@ -2214,8 +2212,9 @@ (* Type [t2'] may have been instantiated by [unify_fields] *) (* XXX One should do some kind of unification... *) begin match (repr t2').desc with - Tobject (_, {contents = Some (_, va::_)}) - when let va = repr va in List.mem va.desc [Tvar; Tunivar; Tnil] -> + Tobject (_, {contents = Some (_, va::_)}) when + (match (repr va).desc with + Tvar _|Tunivar _|Tnil -> true | _ -> false) -> () | Tobject (_, nm2) -> set_name nm2 !nm1 @@ -2290,16 +2289,32 @@ raise (Unify []); List.iter2 (unify env) tl1 tl2 +(* Build a fresh row variable for unification *) +and make_rowvar level use1 rest1 use2 rest2 = + let set_name ty name = + match ty.desc with + Tvar None -> log_type ty; ty.desc <- Tvar name + | _ -> () + in + let name = + match rest1.desc, rest2.desc with + Tvar (Some _ as name1), Tvar (Some _ as name2) -> + if rest1.level <= rest2.level then name1 else name2 + | Tvar (Some _ as name), _ -> + if use2 then set_name rest2 name; name + | _, Tvar (Some _ as name) -> + if use1 then set_name rest2 name; name + | _ -> None + in + if use1 then rest1 else + if use2 then rest2 else newvar2 ?name level + and unify_fields env ty1 ty2 = (* Optimization *) let (fields1, rest1) = flatten_fields ty1 and (fields2, rest2) = flatten_fields ty2 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in let l1 = (repr ty1).level and l2 = (repr ty2).level in - let va = - if miss1 = [] then rest2 - else if miss2 = [] then rest1 - else newty2 (min l1 l2) Tvar - in + let va = make_rowvar (min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in let d1 = rest1.desc and d2 = rest2.desc in try unify env (build_fields l1 miss1 va) rest2; @@ -2390,7 +2405,7 @@ let rm = row_more row in if row.row_fixed then if row0.row_more == rm then () else - if rm.desc = Tvar then link_type rm row0.row_more else + if is_Tvar rm then link_type rm row0.row_more else unify env rm row0.row_more else let ty = newty2 generic_level (Tvariant {row0 with row_fields = rest}) in @@ -2489,7 +2504,7 @@ let t1 = repr t1 and t2 = repr t2 in if t1 == t2 then () else match t1.desc with - Tvar -> + Tvar _ -> begin try occur env t1 t2; update_level env t1.level t2; @@ -2527,7 +2542,7 @@ let rec filter_arrow env t l = let t = expand_head_unif env t in match t.desc with - Tvar -> + Tvar _ -> let lv = t.level in let t1 = newvar2 lv and t2 = newvar2 lv in let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in @@ -2543,7 +2558,7 @@ let rec filter_method_field env name priv ty = let ty = repr ty in match ty.desc with - Tvar -> + Tvar _ -> let level = ty.level in let ty1 = newvar2 level and ty2 = newvar2 level in let ty' = newty2 level (Tfield (name, @@ -2570,7 +2585,7 @@ let rec filter_method env name priv ty = let ty = expand_head_unif env ty in match ty.desc with - Tvar -> + Tvar _ -> let ty1 = newvar () in let ty' = newobj ty1 in update_level env ty.level ty'; @@ -2606,7 +2621,7 @@ let rec occur ty = let ty = repr ty in if ty.level > level then begin - if ty.desc = Tvar && ty.level >= generic_level - 1 then raise Occur; + if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur; ty.level <- pivot_level - ty.level; match ty.desc with Tvariant row when static_row row -> @@ -2636,7 +2651,7 @@ try match (t1.desc, t2.desc) with - (Tvar, _) when may_instantiate inst_nongen t1 -> + (Tvar _, _) when may_instantiate inst_nongen t1 -> moregen_occur env t1.level t2; occur env t1 t2; link_type t1 t2 @@ -2653,7 +2668,7 @@ with Not_found -> TypePairs.add type_pairs (t1', t2') (); match (t1'.desc, t2'.desc) with - (Tvar, _) when may_instantiate inst_nongen t1' -> + (Tvar _, _) when may_instantiate inst_nongen t1' -> moregen_occur env t1'.level t2; link_type t1' t2 | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 @@ -2684,7 +2699,7 @@ | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> enter_poly env univar_pairs t1 tl1 t2 tl2 (moregen inst_nongen type_pairs env) - | (Tunivar, Tunivar) -> + | (Tunivar _, Tunivar _) -> unify_univar t1' t2' !univar_pairs | (_, _) -> raise (Unify []) @@ -2725,7 +2740,7 @@ let row1 = row_repr row1 and row2 = row_repr row2 in let rm1 = repr row1.row_more and rm2 = repr row2.row_more in if rm1 == rm2 then () else - let may_inst = rm1.desc = Tvar && may_instantiate inst_nongen rm1 in + let may_inst = is_Tvar rm1 && may_instantiate inst_nongen rm1 in let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in let r1, r2 = if row2.row_closed then @@ -2735,9 +2750,9 @@ if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> []) then raise (Unify []); begin match rm1.desc, rm2.desc with - Tunivar, Tunivar -> + Tunivar _, Tunivar _ -> unify_univar rm1 rm2 !univar_pairs - | Tunivar, _ | _, Tunivar -> + | Tunivar _, _ | _, Tunivar _ -> raise (Unify []) | _ when static_row row1 -> () | _ when may_inst -> @@ -2828,13 +2843,13 @@ if ty.level >= lowest_level then begin ty.level <- pivot_level - ty.level; match ty.desc with - | Tvar -> + | Tvar _ -> if not (List.memq ty !vars) then vars := ty :: !vars | Tvariant row -> let row = row_repr row in let more = repr row.row_more in - if more.desc = Tvar && not row.row_fixed then begin - let more' = newty2 more.level Tvar in + if is_Tvar more && not row.row_fixed then begin + let more' = newty2 more.level more.desc in let row' = {row with row_fixed=true; row_fields=[]; row_more=more'} in link_type more (newty2 ty.level (Tvariant row')) end; @@ -2857,7 +2872,7 @@ (fun ty -> let ty = expand_head env ty in if List.memq ty !tyl then false else - (tyl := ty :: !tyl; ty.desc = Tvar)) + (tyl := ty :: !tyl; is_Tvar ty)) vars let matches env ty ty' = @@ -2901,7 +2916,7 @@ try match (t1.desc, t2.desc) with - (Tvar, Tvar) when rename -> + (Tvar _, Tvar _) when rename -> begin try normalize_subst subst; if List.assq t1 !subst != t2 then raise (Unify []) @@ -2922,7 +2937,7 @@ with Not_found -> TypePairs.add type_pairs (t1', t2') (); match (t1'.desc, t2'.desc) with - (Tvar, Tvar) when rename -> + (Tvar _, Tvar _) when rename -> begin try normalize_subst subst; if List.assq t1' !subst != t2' then raise (Unify []) @@ -2956,7 +2971,7 @@ | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> enter_poly env univar_pairs t1 tl1 t2 tl2 (eqtype rename type_pairs subst env) - | (Tunivar, Tunivar) -> + | (Tunivar _, Tunivar _) -> unify_univar t1' t2' !univar_pairs | (_, _) -> raise (Unify []) @@ -3405,7 +3420,7 @@ let rec build_subtype env visited loops posi level t = let t = repr t in match t.desc with - Tvar -> + Tvar _ -> if posi then try let t' = List.assq t loops in @@ -3454,13 +3469,13 @@ as this occurence might break the occur check. XXX not clear whether this correct anyway... *) if List.exists (deep_occur ty) tl1 then raise Not_found; - ty.desc <- Tvar; + ty.desc <- Tvar None; let t'' = newvar () in let loops = (ty, t'') :: loops in (* May discard [visited] as level is going down *) let (ty1', c) = build_subtype env [t'] loops posi (pred_enlarge level') ty1 in - assert (t''.desc = Tvar); + assert (is_Tvar t''); let nm = if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in t''.desc <- Tobject (ty1', ref nm); @@ -3559,7 +3574,7 @@ let (t1', c) = build_subtype env visited loops posi level t1 in if c > Unchanged then (newty (Tpoly(t1', tl)), c) else (t, Unchanged) - | Tunivar | Tpackage _ -> + | Tunivar _ | Tpackage _ -> (t, Unchanged) let enlarge_type env ty = @@ -3623,7 +3638,7 @@ with Not_found -> TypePairs.add subtypes (t1, t2) (); match (t1.desc, t2.desc) with - (Tvar, _) | (_, Tvar) -> + (Tvar _, _) | (_, Tvar _) -> (trace, t1, t2, !univar_pairs)::cstrs | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2 || !Clflags.classic && not (is_optional l1 || is_optional l2) -> @@ -3659,7 +3674,7 @@ | (Tconstr(p1, tl1, _), _) when private_abbrev env p1 -> subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs | (Tobject (f1, _), Tobject (f2, _)) - when (object_row f1).desc = Tvar && (object_row f2).desc = Tvar -> + when is_Tvar (object_row f1) && is_Tvar (object_row f2) -> (* Same row variable implies same object. *) (trace, t1, t2, !univar_pairs)::cstrs | (Tobject (f1, _), Tobject (f2, _)) -> @@ -3731,7 +3746,7 @@ match more1.desc, more2.desc with Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 -> subtype_rec env ((more1,more2)::trace) more1 more2 cstrs - | (Tvar|Tconstr _), (Tvar|Tconstr _) + | (Tvar _|Tconstr _), (Tvar _|Tconstr _) when row1.row_closed && r1 = [] -> List.fold_left (fun cstrs (_,f1,f2) -> @@ -3745,7 +3760,7 @@ | Rabsent, _ -> cstrs | _ -> raise Exit) cstrs pairs - | Tunivar, Tunivar + | Tunivar _, Tunivar _ when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] -> let cstrs = subtype_rec env ((more1,more2)::trace) more1 more2 cstrs in @@ -3789,19 +3804,19 @@ match ty.desc with Tfield (s, k, t1, t2) -> newty2 ty.level (Tfield (s, k, t1, unalias_object t2)) - | Tvar | Tnil -> + | Tvar _ | Tnil -> newty2 ty.level ty.desc - | Tunivar -> + | Tunivar _ -> ty | Tconstr _ -> - newty2 ty.level Tvar + newvar2 ty.level | _ -> assert false let unalias ty = let ty = repr ty in match ty.desc with - Tvar | Tunivar -> + Tvar _ | Tunivar _ -> ty | Tvariant row -> let row = row_repr row in @@ -3875,7 +3890,7 @@ set_name nm None else let v' = repr v in begin match v'.desc with - | Tvar|Tunivar -> + | Tvar _ | Tunivar _ -> if v' != v then set_name nm (Some (n, v' :: l)) | Tnil -> log_type ty; ty.desc <- Tconstr (n, l, ref Mnil) @@ -3917,7 +3932,7 @@ let rec nondep_type_rec env id ty = match ty.desc with - Tvar | Tunivar -> ty + Tvar _ | Tunivar _ -> ty | Tlink ty -> nondep_type_rec env id ty | _ -> try TypeHash.find nondep_hash ty with Not_found -> @@ -3987,7 +4002,7 @@ let unroll_abbrev id tl ty = let ty = repr ty and path = Path.Pident id in - if (ty.desc = Tvar) || (List.exists (deep_occur ty) tl) + if is_Tvar ty || (List.exists (deep_occur ty) tl) || is_object_type path then ty else Index: typing/printtyp.ml =================================================================== --- typing/printtyp.ml (リビジョン 11207) +++ typing/printtyp.ml (作業コピー) @@ -109,6 +109,10 @@ | Mcons (priv, p, t1, t2, rem) -> p :: list_of_memo rem | Mlink rem -> list_of_memo !rem +let print_name ppf = function + None -> fprintf ppf "None" + | Some name -> fprintf ppf "\"%s\"" name + let visited = ref [] let rec raw_type ppf ty = let ty = safe_repr [] ty in @@ -119,7 +123,7 @@ end and raw_type_list tl = raw_list raw_type tl and raw_type_desc ppf = function - Tvar -> fprintf ppf "Tvar" + Tvar name -> fprintf ppf "Tvar %a" print_name name | Tarrow(l,t1,t2,c) -> fprintf ppf "@[Tarrow(%s,@,%a,@,%a,@,%s)@]" l raw_type t1 raw_type t2 @@ -143,7 +147,7 @@ | Tnil -> fprintf ppf "Tnil" | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t - | Tunivar -> fprintf ppf "Tunivar" + | Tunivar name -> fprintf ppf "Tunivar %a" print_name name | Tpoly (t, tl) -> fprintf ppf "@[Tpoly(@,%a,@,%a)@]" raw_type t @@ -189,28 +193,61 @@ let names = ref ([] : (type_expr * string) list) let name_counter = ref 0 +let named_vars = ref ([] : string list) -let reset_names () = names := []; name_counter := 0 +let reset_names () = names := []; name_counter := 0; named_vars := [] +let add_named_var ty = + match ty.desc with + Tvar (Some name) | Tunivar (Some name) -> + if List.mem name !named_vars then () else + named_vars := name :: !named_vars + | _ -> () -let new_name () = +let rec new_name () = let name = if !name_counter < 26 then String.make 1 (Char.chr(97 + !name_counter)) else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^ string_of_int(!name_counter / 26) in incr name_counter; - name + if List.mem name !named_vars + || List.exists (fun (_, name') -> name = name') !names + then new_name () + else name let name_of_type t = + (* We've already been through repr at this stage, so t is our representative + of the union-find class. *) try List.assq t !names with Not_found -> - let name = new_name () in + let name = + match t.desc with + Tvar (Some name) | Tunivar (Some name) -> + (* Some part of the type we've already printed has assigned another + * unification variable to that name. We want to keep the name, so try + * adding a number until we find a name that's not taken. *) + let current_name = ref name in + let i = ref 0 in + while List.exists (fun (_, name') -> !current_name = name') !names do + current_name := name ^ (string_of_int !i); + i := !i + 1; + done; + !current_name + | _ -> + (* No name available, create a new one *) + new_name () + in names := (t, name) :: !names; name let check_name_of_type t = ignore(name_of_type t) +let remove_names tyl = + let tyl = List.map repr tyl in + names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names + + let non_gen_mark sch ty = - if sch && ty.desc = Tvar && ty.level <> generic_level then "_" else "" + if sch && is_Tvar ty && ty.level <> generic_level then "_" else "" let print_name_of_type sch ppf t = fprintf ppf "'%s%s" (non_gen_mark sch t) (name_of_type t) @@ -225,9 +262,13 @@ let is_aliased ty = List.memq (proxy ty) !aliased let add_alias ty = let px = proxy ty in - if not (is_aliased px) then aliased := px :: !aliased + if not (is_aliased px) then begin + aliased := px :: !aliased; + add_named_var px + end + let aliasable ty = - match ty.desc with Tvar | Tunivar | Tpoly _ -> false | _ -> true + match ty.desc with Tvar _ | Tunivar _ | Tpoly _ -> false | _ -> true let namable_row row = row.row_name <> None && @@ -245,7 +286,7 @@ if List.memq px visited && aliasable ty then add_alias px else let visited = px :: visited in match ty.desc with - | Tvar -> () + | Tvar _ -> add_named_var ty | Tarrow(_, ty1, ty2, _) -> mark_loops_rec visited ty1; mark_loops_rec visited ty2 | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl @@ -290,7 +331,7 @@ | Tpoly (ty, tyl) -> List.iter (fun t -> add_alias t) tyl; mark_loops_rec visited ty - | Tunivar -> () + | Tunivar _ -> add_named_var ty let mark_loops ty = normalize_type Env.empty ty; @@ -322,7 +363,7 @@ let pr_typ () = match ty.desc with - | Tvar -> + | Tvar _ -> Otyp_var (is_non_gen sch ty, name_of_type ty) | Tarrow(l, ty1, ty2, _) -> let pr_arrow l ty1 ty2 = @@ -387,16 +428,22 @@ | Tpoly (ty, []) -> tree_of_typexp sch ty | Tpoly (ty, tyl) -> + (*let print_names () = + List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; + prerr_string "; " in *) let tyl = List.map repr tyl in - (* let tyl = List.filter is_aliased tyl in *) if tyl = [] then tree_of_typexp sch ty else begin let old_delayed = !delayed in + (* Make the names delayed, so that the real type is + printed once when used as proxy *) List.iter add_delayed tyl; let tl = List.map name_of_type tyl in let tr = Otyp_poly (tl, tree_of_typexp sch ty) in + (* Forget names when we leave scope *) + remove_names tyl; delayed := old_delayed; tr end - | Tunivar -> + | Tunivar _ -> Otyp_var (false, name_of_type ty) | Tpackage (p, n, tyl) -> Otyp_module (Path.name p, n, tree_of_typlist sch tyl) @@ -446,13 +493,13 @@ end and is_non_gen sch ty = - sch && ty.desc = Tvar && ty.level <> generic_level + sch && is_Tvar ty && ty.level <> generic_level and tree_of_typfields sch rest = function | [] -> let rest = match rest.desc with - | Tvar | Tunivar -> Some (is_non_gen sch rest) + | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest) | Tconstr _ -> Some false | Tnil -> None | _ -> fatal_error "typfields (1)" @@ -564,7 +611,7 @@ let vari = List.map2 (fun ty (co,cn,ct) -> - if abstr || (repr ty).desc <> Tvar then (co,cn) else (true,true)) + if abstr || not (is_Tvar (repr ty)) then (co,cn) else (true,true)) decl.type_params decl.type_variance in (Ident.name id, @@ -645,16 +692,18 @@ let method_type (_, kind, ty) = match field_kind_repr kind, repr ty with - Fpresent, {desc=Tpoly(ty, _)} -> ty - | _ , ty -> ty + Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl) + | _ , ty -> (ty, []) let tree_of_metho sch concrete csil (lab, kind, ty) = if lab <> dummy_method then begin let kind = field_kind_repr kind in let priv = kind <> Fpresent in let virt = not (Concr.mem lab concrete) in - let ty = method_type (lab, kind, ty) in - Ocsg_method (lab, priv, virt, tree_of_typexp sch ty) :: csil + let (ty, tyl) = method_type (lab, kind, ty) in + let tty = tree_of_typexp sch ty in + remove_names tyl; + Ocsg_method (lab, priv, virt, tty) :: csil end else csil @@ -662,7 +711,7 @@ | Tcty_constr (p, tyl, cty) -> let sty = Ctype.self_type cty in if List.memq (proxy sty) !visited_objects - || List.exists (fun ty -> (repr ty).desc <> Tvar) params + || not (List.for_all is_Tvar params) || List.exists (deep_occur sty) tyl then prepare_class_type params cty else List.iter mark_loops tyl @@ -675,7 +724,7 @@ let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in - List.iter (fun met -> mark_loops (method_type met)) fields; + List.iter (fun met -> mark_loops (fst (method_type met))) fields; Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars | Tcty_fun (_, ty, cty) -> mark_loops ty; @@ -686,7 +735,7 @@ | Tcty_constr (p', tyl, cty) -> let sty = Ctype.self_type cty in if List.memq (proxy sty) !visited_objects - || List.exists (fun ty -> (repr ty).desc <> Tvar) params + || not (List.for_all is_Tvar params) then tree_of_class_type sch params cty else @@ -743,7 +792,7 @@ (match tree_of_typexp true param with Otyp_var (_, s) -> s | _ -> "?"), - if (repr param).desc = Tvar then (true, true) else variance + if is_Tvar (repr param) then (true, true) else variance let tree_of_class_params params = let tyl = tree_of_typlist true params in @@ -890,7 +939,7 @@ | {desc = Tvariant row} as t when (row_repr row).row_name <> None -> newty2 t.level (Tvariant {(row_repr row) with row_name = None; - row_more = newty2 (row_more row).level Tvar}) + row_more = newvar2 (row_more row).level}) | _ -> t let prepare_expansion (t, t') = @@ -913,9 +962,9 @@ let has_explanation unif t3 t4 = match t3.desc, t4.desc with Tfield _, _ | _, Tfield _ - | Tunivar, Tvar | Tvar, Tunivar + | Tunivar _, Tvar _ | Tvar _, Tunivar _ | Tvariant _, Tvariant _ -> true - | Tconstr (p, _, _), Tvar | Tvar, Tconstr (p, _, _) -> + | Tconstr (p, _, _), Tvar _ | Tvar _, Tconstr (p, _, _) -> unif && min t3.level t4.level < Path.binding_time p | _ -> false @@ -931,21 +980,21 @@ let explanation unif t3 t4 ppf = match t3.desc, t4.desc with - | Tfield _, Tvar | Tvar, Tfield _ -> + | Tfield _, Tvar _ | Tvar _, Tfield _ -> fprintf ppf "@,Self type cannot escape its class" - | Tconstr (p, tl, _), Tvar + | Tconstr (p, tl, _), Tvar _ when unif && (tl = [] || t4.level < Path.binding_time p) -> fprintf ppf "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" path p - | Tvar, Tconstr (p, tl, _) + | Tvar _, Tconstr (p, tl, _) when unif && (tl = [] || t3.level < Path.binding_time p) -> fprintf ppf "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" path p - | Tvar, Tunivar | Tunivar, Tvar -> + | Tvar _, Tunivar _ | Tunivar _, Tvar _ -> fprintf ppf "@,The universal variable %a would escape its scope" - type_expr (if t3.desc = Tunivar then t3 else t4) + type_expr (if is_Tunivar t3 then t3 else t4) | Tfield (lab, _, _, _), _ | _, Tfield (lab, _, _, _) when lab = dummy_method -> fprintf ppf Index: typing/includecore.ml =================================================================== --- typing/includecore.ml (リビジョン 11207) +++ typing/includecore.ml (作業コピー) @@ -61,7 +61,7 @@ Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) -> let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in Ctype.equal env true (ty1::params1) (row2.row_more::params2) && - (match row1.row_more with {desc=Tvar|Tconstr _} -> true | _ -> false) && + (match row1.row_more with {desc=Tvar _|Tconstr _} -> true | _ -> false) && let r1, r2, pairs = Ctype.merge_row_fields row1.row_fields row2.row_fields in (not row2.row_closed || @@ -91,7 +91,7 @@ let (fields2,rest2) = Ctype.flatten_fields fi2 in Ctype.equal env true (ty1::params1) (rest2::params2) && let (fields1,rest1) = Ctype.flatten_fields fi1 in - (match rest1 with {desc=Tnil|Tvar|Tconstr _} -> true | _ -> false) && + (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) && let pairs, miss1, miss2 = Ctype.associate_fields fields1 fields2 in miss2 = [] && let tl1, tl2 = @@ -251,7 +251,7 @@ let encode_val (mut, ty) rem = begin match mut with Asttypes.Mutable -> Predef.type_unit - | Asttypes.Immutable -> Btype.newgenty Tvar + | Asttypes.Immutable -> Btype.newgenvar () end ::ty::rem Index: typing/subst.ml =================================================================== --- typing/subst.ml (リビジョン 11207) +++ typing/subst.ml (作業コピー) @@ -71,16 +71,19 @@ let reset_for_saving () = new_id := -1 let newpersty desc = - decr new_id; { desc = desc; level = generic_level; id = !new_id } + decr new_id; + { desc = desc; level = generic_level; id = !new_id } (* Similar to [Ctype.nondep_type_rec]. *) let rec typexp s ty = let ty = repr ty in match ty.desc with - Tvar | Tunivar -> + Tvar _ | Tunivar _ -> if s.for_saving || ty.id < 0 then + let desc = match ty.desc with (* Tvar _ -> Tvar None *) | d -> d in let ty' = - if s.for_saving then newpersty ty.desc else newty2 ty.level ty.desc + if s.for_saving then newpersty desc + else newty2 ty.level desc in save_desc ty ty.desc; ty.desc <- Tsubst ty'; ty' else ty @@ -94,7 +97,7 @@ let desc = ty.desc in save_desc ty desc; (* Make a stub *) - let ty' = if s.for_saving then newpersty Tvar else newgenvar () in + let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in ty.desc <- Tsubst ty'; ty'.desc <- begin match desc with @@ -127,10 +130,10 @@ match more.desc with Tsubst ty -> ty | Tconstr _ -> typexp s more - | Tunivar | Tvar -> + | Tunivar _ | Tvar _ -> save_desc more more.desc; if s.for_saving then newpersty more.desc else - if dup && more.desc <> Tunivar then newgenvar () else more + if dup && is_Tvar more then newgenty more.desc else more | _ -> assert false in (* Register new type first for recursion *) Index: typing/types.ml =================================================================== --- typing/types.ml (リビジョン 11207) +++ typing/types.ml (作業コピー) @@ -25,7 +25,7 @@ mutable id: int } and type_desc = - Tvar + Tvar of string option | Tarrow of label * type_expr * type_expr * commutable | Ttuple of type_expr list | Tconstr of Path.t * type_expr list * abbrev_memo ref @@ -35,7 +35,7 @@ | Tlink of type_expr | Tsubst of type_expr (* for copying *) | Tvariant of row_desc - | Tunivar + | Tunivar of string option | Tpoly of type_expr * type_expr list | Tpackage of Path.t * string list * type_expr list Index: ocamldoc/odoc_str.ml =================================================================== --- ocamldoc/odoc_str.ml (リビジョン 11207) +++ ocamldoc/odoc_str.ml (作業コピー) @@ -31,7 +31,7 @@ | Types.Tlink t2 | Types.Tsubst t2 -> is_arrow_type t2 | Types.Ttuple _ | Types.Tconstr _ - | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _ + | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _ | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false let raw_string_of_type_list sep type_list = @@ -43,7 +43,7 @@ | Types.Tlink t2 | Types.Tsubst t2 -> need_parent t2 | Types.Tconstr _ -> false - | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _ + | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _ | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false in let print_one_type variance t = Index: ocamldoc/odoc_value.ml =================================================================== --- ocamldoc/odoc_value.ml (リビジョン 11207) +++ ocamldoc/odoc_value.ml (作業コピー) @@ -77,13 +77,13 @@ | Types.Tsubst texp -> iter texp | Types.Tpoly (texp, _) -> iter texp - | Types.Tvar + | Types.Tvar _ | Types.Ttuple _ | Types.Tconstr _ | Types.Tobject _ | Types.Tfield _ | Types.Tnil - | Types.Tunivar + | Types.Tunivar _ | Types.Tpackage _ | Types.Tvariant _ -> [] Index: ocamldoc/odoc_misc.ml =================================================================== --- ocamldoc/odoc_misc.ml (リビジョン 11207) +++ ocamldoc/odoc_misc.ml (作業コピー) @@ -478,8 +478,8 @@ match t with | Types.Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty.Types.desc | Types.Tconstr _ - | Types.Tvar - | Types.Tunivar + | Types.Tvar _ + | Types.Tunivar _ | Types.Tpoly _ | Types.Tarrow _ | Types.Ttuple _ Index: bytecomp/typeopt.ml =================================================================== --- bytecomp/typeopt.ml (リビジョン 11207) +++ bytecomp/typeopt.ml (作業コピー) @@ -50,7 +50,7 @@ let array_element_kind env ty = match scrape env ty with - | Tvar | Tunivar -> + | Tvar _ | Tunivar _ -> Pgenarray | Tconstr(p, args, abbrev) -> if Path.same p Predef.path_int || Path.same p Predef.path_char then Index: bytecomp/translcore.ml =================================================================== --- bytecomp/translcore.ml (リビジョン 11207) +++ bytecomp/translcore.ml (作業コピー) @@ -780,12 +780,13 @@ begin match e.exp_type.desc with (* the following may represent a float/forward/lazy: need a forward_tag *) - | Tvar | Tlink _ | Tsubst _ | Tunivar + | Tvar _ | Tlink _ | Tsubst _ | Tunivar _ | Tpoly(_,_) | Tfield(_,_,_,_) -> Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) (* the following cannot be represented as float/forward/lazy: optimize *) - | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil | Tvariant _ + | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil + | Tvariant _ -> transl_exp e (* optimize predefined types (excepted float) *) | Tconstr(_,_,_) -> Index: testsuite/tests/lib-hashtbl/htbl.ml =================================================================== --- testsuite/tests/lib-hashtbl/htbl.ml (リビジョン 11207) +++ testsuite/tests/lib-hashtbl/htbl.ml (作業コピー) @@ -76,7 +76,7 @@ struct type key = M.key type 'a t = (key, 'a) Hashtbl.t - let create = Hashtbl.create + let create s = Hashtbl.create s let clear = Hashtbl.clear let copy = Hashtbl.copy let add = Hashtbl.add Index: toplevel/genprintval.ml =================================================================== --- toplevel/genprintval.ml (リビジョン 11207) +++ toplevel/genprintval.ml (作業コピー) @@ -180,7 +180,7 @@ find_printer env ty obj with Not_found -> match (Ctype.repr ty).desc with - | Tvar -> + | Tvar _ | Tunivar _ -> Oval_stuff "" | Tarrow(_, ty1, ty2, _) -> Oval_stuff "" @@ -327,8 +327,6 @@ fatal_error "Printval.outval_of_value" | Tpoly (ty, _) -> tree_of_val (depth - 1) obj ty - | Tunivar -> - Oval_stuff "" | Tpackage _ -> Oval_stuff "" end Index: otherlibs/labltk/browser/searchid.ml =================================================================== --- otherlibs/labltk/browser/searchid.ml (リビジョン 11207) +++ otherlibs/labltk/browser/searchid.ml (作業コピー) @@ -101,7 +101,7 @@ let rec equal ~prefix t1 t2 = match (repr t1).desc, (repr t2).desc with - Tvar, Tvar -> true + Tvar _, Tvar _ -> true | Tvariant row1, Tvariant row2 -> let row1 = row_repr row1 and row2 = row_repr row2 in let fields1 = filter_row_fields false row1.row_fields @@ -144,7 +144,7 @@ let rec included ~prefix t1 t2 = match (repr t1).desc, (repr t2).desc with - Tvar, _ -> true + Tvar _, _ -> true | Tvariant row1, Tvariant row2 -> let row1 = row_repr row1 and row2 = row_repr row2 in let fields1 = filter_row_fields false row1.row_fields mingw-ocaml/ocaml/experimental/garrigue/fixedtypes.ml0000644000175000017500000000337612124403240022506 0ustar tootstoots(* cvs update -r fixedtypes parsing typing *) (* recursive types *) class c = object (self) method m = 1 method s = self end module type S = sig type t = private #c end;; module M : S = struct type t = c end module type S' = S with type t = c;; class d = object inherit c method n = 2 end module type S2 = S with type t = private #d;; module M2 : S = struct type t = d end;; module M3 : S = struct type t = private #d end;; module T1 = struct type ('a,'b) a = [`A of 'a | `B of 'b] type ('a,'b) b = [`Z | ('a,'b) a] end module type T2 = sig type a and b val evala : a -> int val evalb : b -> int end module type T3 = sig type a0 = private [> (a0,b0) T1.a] and b0 = private [> (a0,b0) T1.b] end module type T4 = sig include T3 include T2 with type a = a0 and type b = b0 end module F(X:T4) = struct type a = X.a and b = X.b let a = X.evala (`B `Z) let b = X.evalb (`A(`B `Z)) let a2b (x : a) : b = `A x let b2a (x : b) : a = `B x end module M4 = struct type a = [`A of a | `B of b | `ZA] and b = [`A of a | `B of b | `Z] type a0 = a type b0 = b let rec eval0 = function `A a -> evala a | `B b -> evalb b and evala : a -> int = function #T1.a as x -> 1 + eval0 x | `ZA -> 3 and evalb : b -> int = function #T1.a as x -> 1 + eval0 x | `Z -> 7 end module M5 = F(M4) module M6 : sig class ci : int -> object val x : int method x : int method move : int -> unit end type c = private #ci val create : int -> c end = struct class ci x = object val mutable x : int = x method x = x method move d = x <- x+d end type c = ci let create = new ci end let f (x : M6.c) = x#move 3; x#x;; module M : sig type t = private [> `A of bool] end = struct type t = [`A of int] end mingw-ocaml/ocaml/experimental/garrigue/show_types.diffs0000644000175000017500000001277012124403240023207 0ustar tootstootsIndex: typing/printtyp.ml =================================================================== --- typing/printtyp.ml (revision 11316) +++ typing/printtyp.ml (working copy) @@ -894,8 +894,10 @@ tree_of_class_declaration id decl rs :: tree_of_signature rem | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> tree_of_cltype_declaration id decl rs :: tree_of_signature rem - | _ -> - assert false + | Tsig_class(id, decl, rs) :: _ -> + tree_of_class_declaration id decl rs :: [] + | Tsig_cltype(id, decl, rs) :: _ -> + tree_of_cltype_declaration id decl rs :: [] and tree_of_modtype_declaration id decl = let mty = Index: toplevel/topdirs.ml =================================================================== --- toplevel/topdirs.ml (revision 11316) +++ toplevel/topdirs.ml (working copy) @@ -297,10 +297,92 @@ !traced_functions; traced_functions := [] +(* Warnings *) + let parse_warnings ppf iserr s = try Warnings.parse_options iserr s with Arg.Bad err -> fprintf ppf "%s.@." err +(* Typing information *) + +type pkind = + Pvalue + | Ptype + | Pexception + | Pmodule + | Pmodtype + | Pclass + | Pcltype + +let name_of_kind = function + Pvalue -> "value" + | Ptype -> "type" + | Pexception -> "exception" + | Pmodule -> "module" + | Pmodtype -> "module type" + | Pclass -> "class" + | Pcltype -> "class type" + +let rec trim_modtype = function + Tmty_signature _ -> Tmty_signature [] + | Tmty_functor (id, mty, mty') -> + Tmty_functor (id, mty, trim_modtype mty') + | Tmty_ident _ as mty -> mty + +let trim_signature = function + Tmty_signature sg -> + Tmty_signature + (List.map + (function + Tsig_module (id, mty, rs) -> + Tsig_module (id, trim_modtype mty, rs) + (*| Tsig_modtype (id, Tmodtype_manifest mty) -> + Tsig_modtype (id, Tmodtype_manifest (trim_modtype mty))*) + | item -> item) + sg) + | mty -> mty + +let show_type ppf kind lid = + let env = !Toploop.toplevel_env in + try + let id = + let s = match lid with + Longident.Lident s -> s + | Longident.Ldot (_,s) -> s + | Longident.Lapply _ -> failwith "invalid" + in Ident.create_persistent s + in + let item = + match kind with + Pvalue -> + let path, desc = Env.lookup_value lid env in + Tsig_value (id, desc) + | Ptype -> + let path, desc = Env.lookup_type lid env in + Tsig_type (id, desc, Trec_not) + | Pexception -> + let desc = Env.lookup_constructor lid env in + Tsig_exception (id, desc.cstr_args) + | Pmodule -> + let path, desc = Env.lookup_module lid env in + Tsig_module (id, trim_signature desc, Trec_not) + | Pmodtype -> + let path, desc = Env.lookup_modtype lid env in + Tsig_modtype (id, desc) + | Pclass -> + let path, desc = Env.lookup_class lid env in + Tsig_class (id, desc, Trec_not) + | Pcltype -> + let path, desc = Env.lookup_cltype lid env in + Tsig_cltype (id, desc, Trec_not) + in + fprintf ppf "%a@." Printtyp.signature [item] + with + Not_found -> + fprintf ppf "Unknown %s.@." (name_of_kind kind) + | Failure "invalid" -> + fprintf ppf "Invalid path %a@." Printtyp.longident lid + let _ = Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out)); Hashtbl.add directive_table "untrace" (Directive_ident (dir_untrace std_out)); @@ -329,4 +411,19 @@ (Directive_string (parse_warnings std_out false)); Hashtbl.add directive_table "warn_error" - (Directive_string (parse_warnings std_out true)) + (Directive_string (parse_warnings std_out true)); + + Hashtbl.add directive_table "show_value" + (Directive_ident (show_type std_out Pvalue)); + Hashtbl.add directive_table "show_type" + (Directive_ident (show_type std_out Ptype)); + Hashtbl.add directive_table "show_exception" + (Directive_ident (show_type std_out Pexception)); + Hashtbl.add directive_table "show_module" + (Directive_ident (show_type std_out Pmodule)); + Hashtbl.add directive_table "show_module_type" + (Directive_ident (show_type std_out Pmodtype)); + Hashtbl.add directive_table "show_class" + (Directive_ident (show_type std_out Pclass)); + Hashtbl.add directive_table "show_class_type" + (Directive_ident (show_type std_out Pcltype)) Index: parsing/parser.mly =================================================================== --- parsing/parser.mly (revision 11316) +++ parsing/parser.mly (working copy) @@ -1769,6 +1769,11 @@ LIDENT { Lident $1 } | mod_longident DOT LIDENT { Ldot($1, $3) } ; +any_longident: + val_ident { Lident $1 } + | mod_longident DOT val_ident { Ldot($1, $3) } + | mod_longident { $1 } +; /* Toplevel directives */ @@ -1776,7 +1781,7 @@ SHARP ident { Ptop_dir($2, Pdir_none) } | SHARP ident STRING { Ptop_dir($2, Pdir_string $3) } | SHARP ident INT { Ptop_dir($2, Pdir_int $3) } - | SHARP ident val_longident { Ptop_dir($2, Pdir_ident $3) } + | SHARP ident any_longident { Ptop_dir($2, Pdir_ident $3) } | SHARP ident FALSE { Ptop_dir($2, Pdir_bool false) } | SHARP ident TRUE { Ptop_dir($2, Pdir_bool true) } ; mingw-ocaml/ocaml/experimental/garrigue/printers.ml0000644000175000017500000000026512124403240022162 0ustar tootstoots(* $Id$ *) open Types let ignore_abbrevs ppf ab = let s = match ab with Mnil -> "Mnil" | Mlink _ -> "Mlink _" | Mcons _ -> "Mcons _" in Format.pp_print_string ppf s mingw-ocaml/ocaml/experimental/garrigue/multimatch.diffs0000644000175000017500000015457612124403240023165 0ustar tootstootsIndex: parsing/lexer.mll =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/parsing/lexer.mll,v retrieving revision 1.73 diff -u -r1.73 lexer.mll --- parsing/lexer.mll 11 Apr 2005 16:44:26 -0000 1.73 +++ parsing/lexer.mll 2 Feb 2006 06:28:32 -0000 @@ -63,6 +63,8 @@ "match", MATCH; "method", METHOD; "module", MODULE; + "multifun", MULTIFUN; + "multimatch", MULTIMATCH; "mutable", MUTABLE; "new", NEW; "object", OBJECT; Index: parsing/parser.mly =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v retrieving revision 1.123 diff -u -r1.123 parser.mly --- parsing/parser.mly 23 Mar 2005 03:08:37 -0000 1.123 +++ parsing/parser.mly 2 Feb 2006 06:28:32 -0000 @@ -257,6 +257,8 @@ %token MINUSDOT %token MINUSGREATER %token MODULE +%token MULTIFUN +%token MULTIMATCH %token MUTABLE %token NATIVEINT %token NEW @@ -325,7 +327,7 @@ %nonassoc SEMI /* below EQUAL ({lbl=...; lbl=...}) */ %nonassoc LET /* above SEMI ( ...; let ... in ...) */ %nonassoc below_WITH -%nonassoc FUNCTION WITH /* below BAR (match ... with ...) */ +%nonassoc FUNCTION WITH MULTIFUN /* below BAR (match ... with ...) */ %nonassoc AND /* above WITH (module rec A: SIG with ... and ...) */ %nonassoc THEN /* below ELSE (if ... then ...) */ %nonassoc ELSE /* (if ... then ... else ...) */ @@ -804,8 +806,12 @@ { mkexp(Pexp_function("", None, List.rev $3)) } | FUN labeled_simple_pattern fun_def { let (l,o,p) = $2 in mkexp(Pexp_function(l, o, [p, $3])) } + | MULTIFUN opt_bar match_cases + { mkexp(Pexp_multifun(List.rev $3)) } | MATCH seq_expr WITH opt_bar match_cases - { mkexp(Pexp_match($2, List.rev $5)) } + { mkexp(Pexp_match($2, List.rev $5, false)) } + | MULTIMATCH seq_expr WITH opt_bar match_cases + { mkexp(Pexp_match($2, List.rev $5, true)) } | TRY seq_expr WITH opt_bar match_cases { mkexp(Pexp_try($2, List.rev $5)) } | TRY seq_expr WITH error @@ -1318,10 +1324,10 @@ | simple_core_type2 { Rinherit $1 } ; tag_field: - name_tag OF opt_ampersand amper_type_list - { Rtag ($1, $3, List.rev $4) } - | name_tag - { Rtag ($1, true, []) } + name_tag OF opt_ampersand amper_type_list amper_type_pair_list + { Rtag ($1, $3, List.rev $4, $5) } + | name_tag amper_type_pair_list + { Rtag ($1, true, [], $2) } ; opt_ampersand: AMPERSAND { true } @@ -1331,6 +1337,11 @@ core_type { [$1] } | amper_type_list AMPERSAND core_type { $3 :: $1 } ; +amper_type_pair_list: + AMPERSAND core_type EQUAL core_type amper_type_pair_list + { ($2, $4) :: $5 } + | /* empty */ + { [] } opt_present: LBRACKETGREATER name_tag_list RBRACKET { List.rev $2 } | /* empty */ { [] } Index: parsing/parsetree.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v retrieving revision 1.42 diff -u -r1.42 parsetree.mli --- parsing/parsetree.mli 23 Mar 2005 03:08:37 -0000 1.42 +++ parsing/parsetree.mli 2 Feb 2006 06:28:32 -0000 @@ -43,7 +43,7 @@ | Pfield_var and row_field = - Rtag of label * bool * core_type list + Rtag of label * bool * core_type list * (core_type * core_type) list | Rinherit of core_type (* XXX Type expressions for the class language *) @@ -86,7 +86,7 @@ | Pexp_let of rec_flag * (pattern * expression) list * expression | Pexp_function of label * expression option * (pattern * expression) list | Pexp_apply of expression * (label * expression) list - | Pexp_match of expression * (pattern * expression) list + | Pexp_match of expression * (pattern * expression) list * bool | Pexp_try of expression * (pattern * expression) list | Pexp_tuple of expression list | Pexp_construct of Longident.t * expression option * bool @@ -111,6 +111,7 @@ | Pexp_lazy of expression | Pexp_poly of expression * core_type option | Pexp_object of class_structure + | Pexp_multifun of (pattern * expression) list (* Value descriptions *) Index: parsing/printast.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v retrieving revision 1.29 diff -u -r1.29 printast.ml --- parsing/printast.ml 4 Jan 2006 16:55:50 -0000 1.29 +++ parsing/printast.ml 2 Feb 2006 06:28:32 -0000 @@ -205,10 +205,14 @@ line i ppf "Pexp_apply\n"; expression i ppf e; list i label_x_expression ppf l; - | Pexp_match (e, l) -> + | Pexp_match (e, l, b) -> line i ppf "Pexp_match\n"; expression i ppf e; list i pattern_x_expression_case ppf l; + bool i ppf b + | Pexp_multifun l -> + line i ppf "Pexp_multifun\n"; + list i pattern_x_expression_case ppf l; | Pexp_try (e, l) -> line i ppf "Pexp_try\n"; expression i ppf e; @@ -653,7 +657,7 @@ and label_x_bool_x_core_type_list i ppf x = match x with - Rtag (l, b, ctl) -> + Rtag (l, b, ctl, cstr) -> line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b); list (i+1) core_type ppf ctl | Rinherit (ct) -> Index: typing/btype.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v retrieving revision 1.38 diff -u -r1.38 btype.ml --- typing/btype.ml 4 Jan 2006 16:55:50 -0000 1.38 +++ typing/btype.ml 2 Feb 2006 06:28:32 -0000 @@ -66,16 +66,16 @@ Clink r when !r <> Cunknown -> commu_repr !r | c -> c -let rec row_field_repr_aux tl = function - Reither(_, tl', _, {contents = Some fi}) -> - row_field_repr_aux (tl@tl') fi - | Reither(c, tl', m, r) -> - Reither(c, tl@tl', m, r) +let rec row_field_repr_aux tl tl2 = function + Reither(_, tl', _, tl2', {contents = Some fi}) -> + row_field_repr_aux (tl@tl') (tl2@tl2') fi + | Reither(c, tl', m, tl2', r) -> + Reither(c, tl@tl', m, tl2@tl2', r) | Rpresent (Some _) when tl <> [] -> Rpresent (Some (List.hd tl)) | fi -> fi -let row_field_repr fi = row_field_repr_aux [] fi +let row_field_repr fi = row_field_repr_aux [] [] fi let rec rev_concat l ll = match ll with @@ -170,7 +170,8 @@ (fun (_, fi) -> match row_field_repr fi with | Rpresent(Some ty) -> f ty - | Reither(_, tl, _, _) -> List.iter f tl + | Reither(_, tl, _, tl2, _) -> + List.iter f tl; List.iter (fun (t1,t2) -> f t1; f t2) tl2 | _ -> ()) row.row_fields; match (repr row.row_more).desc with @@ -208,15 +209,17 @@ (fun (l, fi) -> l, match row_field_repr fi with | Rpresent(Some ty) -> Rpresent(Some(f ty)) - | Reither(c, tl, m, e) -> + | Reither(c, tl, m, tpl, e) -> let e = if keep then e else ref None in let m = if row.row_fixed then fixed else m in let tl = List.map f tl in + let tl1 = List.map (fun (t1,_) -> repr (f t1)) tpl + and tl2 = List.map (fun (_,t2) -> repr (f t2)) tpl in bound := List.filter (function {desc=Tconstr(_,[],_)} -> false | _ -> true) - (List.map repr tl) + (List.map repr tl @ tl1 @ tl2) @ !bound; - Reither(c, tl, m, e) + Reither(c, tl, m, List.combine tl1 tl2, e) | _ -> fi) row.row_fields in let name = Index: typing/ctype.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v retrieving revision 1.200 diff -u -r1.200 ctype.ml --- typing/ctype.ml 6 Jan 2006 02:16:24 -0000 1.200 +++ typing/ctype.ml 2 Feb 2006 06:28:32 -0000 @@ -340,7 +340,7 @@ let fi = filter_row_fields erase fi in match row_field_repr f with Rabsent -> fi - | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi + | Reither(_,_,false,_,e) when erase -> set_row_field e Rabsent; fi | _ -> p :: fi (**************************************) @@ -1286,6 +1286,10 @@ module TypeMap = Map.Make (TypeOps) + +(* A list of univars which may appear free in a type, but only if generic *) +let allowed_univars = ref TypeSet.empty + (* Test the occurence of free univars in a type *) (* that's way too expansive. Must do some kind of cacheing *) let occur_univar env ty = @@ -1307,7 +1311,12 @@ then match ty.desc with Tunivar -> - if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()]) + if TypeSet.mem ty bound then () else + if TypeSet.mem ty !allowed_univars && + (ty.level = generic_level || + ty.level = pivot_level - generic_level) + then () + else raise (Unify [ty, newgenvar()]) | Tpoly (ty, tyl) -> let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in occur_rec bound ty @@ -1393,6 +1402,7 @@ with exn -> univar_pairs := old_univars; raise exn let univar_pairs = ref [] +let delayed_conditionals = ref [] (*****************) @@ -1691,9 +1701,11 @@ with Not_found -> (h,l)::hl) (List.map (fun (l,_) -> (hash_variant l, l)) row1.row_fields) (List.map fst r2)); + let fixed1 = row1.row_fixed || rm1.desc <> Tvar + and fixed2 = row2.row_fixed || rm2.desc <> Tvar in let more = - if row1.row_fixed then rm1 else - if row2.row_fixed then rm2 else + if fixed1 then rm1 else + if fixed2 then rm2 else newgenvar () in update_level env (min rm1.level rm2.level) more; let fixed = row1.row_fixed || row2.row_fixed @@ -1726,18 +1738,18 @@ let bound = row1.row_bound @ row2.row_bound in let row0 = {row_fields = []; row_more = more; row_bound = bound; row_closed = closed; row_fixed = fixed; row_name = name} in - let set_more row rest = + let set_more row row_fixed rest = let rest = if closed then filter_row_fields row.row_closed rest else rest in - if rest <> [] && (row.row_closed || row.row_fixed) - || closed && row.row_fixed && not row.row_closed then begin + if rest <> [] && (row.row_closed || row_fixed) + || closed && row_fixed && not row.row_closed then begin let t1 = mkvariant [] true and t2 = mkvariant rest false in raise (Unify [if row == row1 then (t1,t2) else (t2,t1)]) end; let rm = row_more row in - if row.row_fixed then + if row_fixed then if row0.row_more == rm then () else if rm.desc = Tvar then link_type rm row0.row_more else unify env rm row0.row_more @@ -1748,11 +1760,11 @@ in let md1 = rm1.desc and md2 = rm2.desc in begin try - set_more row1 r2; - set_more row2 r1; + set_more row1 fixed1 r2; + set_more row2 fixed2 r1; List.iter (fun (l,f1,f2) -> - try unify_row_field env row1.row_fixed row2.row_fixed l f1 f2 + try unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 with Unify trace -> raise (Unify ((mkvariant [l,f1] true, mkvariant [l,f2] true) :: trace))) @@ -1761,13 +1773,13 @@ log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn end -and unify_row_field env fixed1 fixed2 l f1 f2 = +and unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 = let f1 = row_field_repr f1 and f2 = row_field_repr f2 in if f1 == f2 then () else match f1, f2 with Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2 | Rpresent None, Rpresent None -> () - | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) -> + | Reither(c1, tl1, m1, tp1, e1), Reither(c2, tl2, m2, tp2, e2) -> if e1 == e2 then () else let redo = (m1 || m2) && @@ -1777,32 +1789,70 @@ List.iter (unify env t1) tl; !e1 <> None || !e2 <> None end in - if redo then unify_row_field env fixed1 fixed2 l f1 f2 else + let redo = + redo || begin + if tp1 = [] && fixed1 then unify_pairs env tp2; + if tp2 = [] && fixed2 then unify_pairs env tp1; + !e1 <> None || !e2 <> None + end + in + if redo then unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 else let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in let rec remq tl = function [] -> [] | ty :: tl' -> if List.memq ty tl then remq tl tl' else ty :: remq tl tl' in let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in + let repr_pairs = List.map (fun (t1,t2) -> repr t1, repr t2) in + let tp1 = repr_pairs tp1 and tp2 = repr_pairs tp2 in + let rec rempq tp = function [] -> [] + | (t1,t2 as p) :: tp' -> + if List.exists (fun (t1',t2') -> t1==t1' && t2==t2') (tp@tp') then + rempq tp tp' + else p :: rempq tp tp' + in + let tp1' = + if fixed2 then begin + delayed_conditionals := + (!univar_pairs, tp1, l, row2) :: !delayed_conditionals; + [] + end else rempq tp2 tp1 + and tp2' = + if fixed1 then begin + delayed_conditionals := + (!univar_pairs, tp2, l, row1) :: !delayed_conditionals; + [] + end else rempq tp1 tp2 + in let e = ref None in - let f1' = Reither(c1 || c2, tl1', m1 || m2, e) - and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in - set_row_field e1 f1'; set_row_field e2 f2'; - | Reither(_, _, false, e1), Rabsent -> set_row_field e1 f2 - | Rabsent, Reither(_, _, false, e2) -> set_row_field e2 f1 + let f1' = Reither(c1 || c2, tl1', m1 || m2, tp2', e) + and f2' = Reither(c1 || c2, tl2', m1 || m2, tp1', e) in + set_row_field e1 f1'; set_row_field e2 f2' + | Reither(_, _, false, _, e1), Rabsent -> set_row_field e1 f2 + | Rabsent, Reither(_, _, false, _, e2) -> set_row_field e2 f1 | Rabsent, Rabsent -> () - | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 -> + | Reither(false, tl, _, tp, e1), Rpresent(Some t2) when not fixed1 -> set_row_field e1 f2; - (try List.iter (fun t1 -> unify env t1 t2) tl + begin try + List.iter (fun t1 -> unify env t1 t2) tl; + List.iter (fun (t1,t2) -> unify env t1 t2) tp + with exn -> e1 := None; raise exn + end + | Rpresent(Some t1), Reither(false, tl, _, tp, e2) when not fixed2 -> + set_row_field e2 f1; + begin try + List.iter (unify env t1) tl; + List.iter (fun (t1,t2) -> unify env t1 t2) tp + with exn -> e2 := None; raise exn + end + | Reither(true, [], _, tpl, e1), Rpresent None when not fixed1 -> + set_row_field e1 f2; + (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl with exn -> e1 := None; raise exn) - | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 -> + | Rpresent None, Reither(true, [], _, tpl, e2) when not fixed2 -> set_row_field e2 f1; - (try List.iter (unify env t1) tl + (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl with exn -> e2 := None; raise exn) - | Reither(true, [], _, e1), Rpresent None when not fixed1 -> - set_row_field e1 f2 - | Rpresent None, Reither(true, [], _, e2) when not fixed2 -> - set_row_field e2 f1 | _ -> raise (Unify []) @@ -1920,6 +1970,166 @@ (* Matching between type schemes *) (***********************************) +(* Forward declaration (order should be reversed...) *) +let equal' = ref (fun _ -> failwith "Ctype.equal'") + +let make_generics_univars tyl = + let polyvars = ref TypeSet.empty in + let rec make_rec ty = + let ty = repr ty in + if ty.level = generic_level then begin + if ty.desc = Tvar then begin + log_type ty; + ty.desc <- Tunivar; + polyvars := TypeSet.add ty !polyvars + end + else if ty.desc = Tunivar then set_level ty (generic_level - 1); + ty.level <- pivot_level - generic_level; + iter_type_expr make_rec ty + end + in + List.iter make_rec tyl; + List.iter unmark_type tyl; + !polyvars + +(* New version of moregeneral, using unification *) + +let copy_cond (p,tpl,l,row) = + let row = + match repr (copy (newgenty (Tvariant row))) with + {desc=Tvariant row} -> row + | _ -> assert false + and pairs = + List.map (fun (t1,t2) -> copy t1, copy t2) tpl in + (p, pairs, l, row) + +let get_row_field l row = + try row_field_repr (List.assoc l (row_repr row).row_fields) + with Not_found -> Rabsent + +let rec check_conditional_list env cdtls pattvars tpls = + match cdtls with + [] -> + let finished = + List.for_all (fun (_,t1,t2) -> !equal' env false [t1] [t2]) tpls in + if not finished then begin + let polyvars = make_generics_univars pattvars in + delayed_conditionals := []; + allowed_univars := polyvars; + List.iter (fun (pairs, ty1, ty2) -> unify_pairs env ty1 ty2 pairs) + tpls; + check_conditionals env polyvars !delayed_conditionals + end + | (pairs, tpl1, l, row2 as cond) :: cdtls -> + let cont = check_conditional_list env cdtls pattvars in + let tpl1 = + List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in + let included = + List.for_all + (fun (t1,t2) -> + List.exists + (fun (_,t1',t2') -> !equal' env false [t1;t2] [t1';t2']) + tpls) + tpl1 in + if included then cont tpls else + match get_row_field l row2 with + Rpresent _ -> + cont (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls) + | Rabsent -> cont tpls + | Reither (c, tl2, _, _, _) -> + cont tpls; + if c && tl2 <> [] then () (* cannot succeed *) else + let (pairs, tpl1, l, row2) = copy_cond cond + and tpls = List.map (fun (p,t1,t2) -> p, copy t1, copy t2) tpls + and pattvars = List.map copy pattvars + and cdtls = List.map copy_cond cdtls in + cleanup_types (); + let tl2, tpl2, e2 = + match get_row_field l row2 with + Reither (c, tl2, _, tpl2, e2) -> tl2, tpl2, e2 + | _ -> assert false + in + let snap = Btype.snapshot () in + let ok = + try + begin match tl2 with + [] -> + set_row_field e2 (Rpresent None) + | t::tl -> + set_row_field e2 (Rpresent (Some t)); + List.iter (unify env t) tl + end; + List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2; + true + with exn -> + Btype.backtrack snap; + false + in + (* This is not [cont] : types have been copied *) + if ok then + check_conditional_list env cdtls pattvars + (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls) + +and check_conditionals env polyvars cdtls = + let cdtls = List.map copy_cond cdtls in + let pattvars = ref [] in + TypeSet.iter + (fun ty -> + let ty = repr ty in + match ty.desc with + Tsubst ty -> + let ty = repr ty in + begin match ty.desc with + Tunivar -> + log_type ty; + ty.desc <- Tvar; + pattvars := ty :: !pattvars + | Ttuple [tv;_] -> + if tv.desc = Tunivar then + (log_type tv; tv.desc <- Tvar; pattvars := ty :: !pattvars) + else if tv.desc <> Tvar then assert false + | Tvar -> () + | _ -> assert false + end + | _ -> ()) + polyvars; + cleanup_types (); + check_conditional_list env cdtls !pattvars [] + + +(* Must empty univar_pairs first *) +let unify_poly env polyvars subj patt = + let old_level = !current_level in + current_level := generic_level; + delayed_conditionals := []; + allowed_univars := polyvars; + try + unify env subj patt; + check_conditionals env polyvars !delayed_conditionals; + current_level := old_level; + allowed_univars := TypeSet.empty; + delayed_conditionals := [] + with exn -> + current_level := old_level; + allowed_univars := TypeSet.empty; + delayed_conditionals := []; + raise exn + +let moregeneral env _ subj patt = + let old_level = !current_level in + current_level := generic_level; + let subj = instance subj + and patt = instance patt in + let polyvars = make_generics_univars [patt] in + current_level := old_level; + let snap = Btype.snapshot () in + try + unify_poly env polyvars subj patt; + true + with Unify _ -> + Btype.backtrack snap; + false + (* Update the level of [ty]. First check that the levels of generic variables from the subject are not lowered. @@ -2072,35 +2282,101 @@ Rpresent(Some t1), Rpresent(Some t2) -> moregen inst_nongen type_pairs env t1 t2 | Rpresent None, Rpresent None -> () - | Reither(false, tl1, _, e1), Rpresent(Some t2) when not univ -> + | Reither(false, tl1, _, [], e1), Rpresent(Some t2) when not univ -> set_row_field e1 f2; List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1 - | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) -> + | Reither(c1, tl1, _, tpl1, e1), Reither(c2, tl2, m2, tpl2, e2) -> if e1 != e2 then begin if c1 && not c2 then raise(Unify []); - set_row_field e1 (Reither (c2, [], m2, e2)); - if List.length tl1 = List.length tl2 then - List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 - else match tl2 with - t2 :: _ -> + let tpl' = if tpl1 = [] then tpl2 else [] in + set_row_field e1 (Reither (c2, [], m2, tpl', e2)); + begin match tl2 with + [t2] -> List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1 - | [] -> - if tl1 <> [] then raise (Unify []) + | _ -> + if List.length tl1 <> List.length tl2 then raise (Unify []); + List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 + end; + if tpl1 <> [] then + delayed_conditionals := + (!univar_pairs, tpl1, l, row2) :: !delayed_conditionals end - | Reither(true, [], _, e1), Rpresent None when not univ -> + | Reither(true, [], _, [], e1), Rpresent None when not univ -> set_row_field e1 f2 - | Reither(_, _, _, e1), Rabsent when not univ -> + | Reither(_, _, _, [], e1), Rabsent when not univ -> set_row_field e1 f2 | Rabsent, Rabsent -> () | _ -> raise (Unify [])) pairs +let check_conditional env (pairs, tpl1, l, row2) tpls cont = + let tpl1 = + List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in + let included = + List.for_all + (fun (t1,t2) -> + List.exists (fun (t1',t2') -> !equal' env false [t1;t2] [t1';t2']) + tpls) + tpl1 in + if tpl1 = [] || included then cont tpls else + match get_row_field l row2 with + Rpresent _ -> cont (tpl1 @ tpls) + | Rabsent -> cont tpls + | Reither (c, tl2, _, tpl2, e2) -> + if not c || tl2 = [] then begin + let snap = Btype.snapshot () in + let ok = + try + begin match tl2 with + [] -> + set_row_field e2 (Rpresent None) + | t::tl -> + set_row_field e2 (Rpresent (Some t)); + List.iter (unify env t) tl + end; + List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2; + true + with Unify _ -> false + in + if ok then cont (tpl1 @ tpls); + Btype.backtrack snap + end; + cont tpls + +let rec check_conditionals inst_nongen env cdtls tpls = + match cdtls with + [] -> + let tpls = + List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpls in + if tpls = [] then () else begin + delayed_conditionals := []; + let tl1, tl2 = List.split tpls in + let type_pairs = TypePairs.create 13 in + List.iter2 (moregen false type_pairs env) tl2 tl1; + check_conditionals inst_nongen env !delayed_conditionals [] + end + | cdtl :: cdtls -> + check_conditional env cdtl tpls + (check_conditionals inst_nongen env cdtls) + + (* Must empty univar_pairs first *) let moregen inst_nongen type_pairs env patt subj = univar_pairs := []; - moregen inst_nongen type_pairs env patt subj + delayed_conditionals := []; + try + moregen inst_nongen type_pairs env patt subj; + check_conditionals inst_nongen env !delayed_conditionals []; + univar_pairs := []; + delayed_conditionals := [] + with exn -> + univar_pairs := []; + delayed_conditionals := []; + raise exn + +(* old implementation (* Non-generic variable can be instanciated only if [inst_nongen] is true. So, [inst_nongen] should be set to false if the subject might @@ -2128,6 +2404,7 @@ in current_level := old_level; res +*) (* Alternative approach: "rigidify" a type scheme, @@ -2296,30 +2573,36 @@ {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2 | _ -> raise Cannot_expand with Cannot_expand -> + let eqtype_rec = eqtype rename type_pairs subst env in let row1 = row_repr row1 and row2 = row_repr row2 in let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in if row1.row_closed <> row2.row_closed || not row1.row_closed && (r1 <> [] || r2 <> []) || filter_row_fields false (r1 @ r2) <> [] then raise (Unify []); - if not (static_row row1) then - eqtype rename type_pairs subst env row1.row_more row2.row_more; + if not (static_row row1) then eqtype_rec row1.row_more row2.row_more; List.iter (fun (_,f1,f2) -> match row_field_repr f1, row_field_repr f2 with Rpresent(Some t1), Rpresent(Some t2) -> - eqtype rename type_pairs subst env t1 t2 - | Reither(true, [], _, _), Reither(true, [], _, _) -> - () - | Reither(false, t1::tl1, _, _), Reither(false, t2::tl2, _, _) -> - eqtype rename type_pairs subst env t1 t2; + eqtype_rec t1 t2 + | Reither(true, [], _, tp1, _), Reither(true, [], _, tp2, _) -> + List.iter2 + (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2') + tp1 tp2 + | Reither(false, t1::tl1, _, tpl1, _), + Reither(false, t2::tl2, _, tpl2, _) -> + eqtype_rec t1 t2; + List.iter2 + (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2') + tpl1 tpl2; if List.length tl1 = List.length tl2 then (* if same length allow different types (meaning?) *) - List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 + List.iter2 eqtype_rec tl1 tl2 else begin (* otherwise everything must be equal *) - List.iter (eqtype rename type_pairs subst env t1) tl2; - List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1 + List.iter (eqtype_rec t1) tl2; + List.iter (fun t1 -> eqtype_rec t1 t2) tl1 end | Rpresent None, Rpresent None -> () | Rabsent, Rabsent -> () @@ -2334,6 +2617,8 @@ with Unify _ -> false +let () = equal' := equal + (* Must empty univar_pairs first *) let eqtype rename type_pairs subst env t1 t2 = univar_pairs := []; @@ -2770,14 +3055,14 @@ (fun (l,f as orig) -> match row_field_repr f with Rpresent None -> if posi then - (l, Reither(true, [], false, ref None)), Unchanged + (l, Reither(true, [], false, [], ref None)), Unchanged else orig, Unchanged | Rpresent(Some t) -> let (t', c) = build_subtype env visited loops posi level' t in if posi && level > 0 then begin bound := t' :: !bound; - (l, Reither(false, [t'], false, ref None)), c + (l, Reither(false, [t'], false, [], ref None)), c end else (l, Rpresent(Some t')), c | _ -> assert false) @@ -2960,11 +3245,11 @@ List.fold_left (fun cstrs (_,f1,f2) -> match row_field_repr f1, row_field_repr f2 with - (Rpresent None|Reither(true,_,_,_)), Rpresent None -> + (Rpresent None|Reither(true,_,_,[],_)), Rpresent None -> cstrs | Rpresent(Some t1), Rpresent(Some t2) -> subtype_rec env ((t1, t2)::trace) t1 t2 cstrs - | Reither(false, t1::_, _, _), Rpresent(Some t2) -> + | Reither(false, t1::_, _, [], _), Rpresent(Some t2) -> subtype_rec env ((t1, t2)::trace) t1 t2 cstrs | Rabsent, _ -> cstrs | _ -> raise Exit) @@ -2977,11 +3262,11 @@ (fun cstrs (_,f1,f2) -> match row_field_repr f1, row_field_repr f2 with Rpresent None, Rpresent None - | Reither(true,[],_,_), Reither(true,[],_,_) + | Reither(true,[],_,[],_), Reither(true,[],_,[],_) | Rabsent, Rabsent -> cstrs | Rpresent(Some t1), Rpresent(Some t2) - | Reither(false,[t1],_,_), Reither(false,[t2],_,_) -> + | Reither(false,[t1],_,[],_), Reither(false,[t2],_,[],_) -> subtype_rec env ((t1, t2)::trace) t1 t2 cstrs | _ -> raise Exit) cstrs pairs @@ -3079,16 +3364,26 @@ let fields = List.map (fun (l,f) -> let f = row_field_repr f in l, - match f with Reither(b, ty::(_::_ as tyl), m, e) -> - let tyl' = - List.fold_left - (fun tyl ty -> - if List.exists (fun ty' -> equal env false [ty] [ty']) tyl - then tyl else ty::tyl) - [ty] tyl + match f with Reither(b, tyl, m, tp, e) -> + let rem_dbl eq l = + List.rev + (List.fold_left + (fun xs x -> if List.exists (eq x) xs then xs else x::xs) + [] l) + in + let tyl' = rem_dbl (fun t1 t2 -> equal env false [t1] [t2]) tyl + and tp' = + List.filter + (fun (ty1,ty2) -> not (equal env false [ty1] [ty2])) tp + in + let tp' = + rem_dbl + (fun (t1,t2) (t1',t2') -> equal env false [t1;t2] [t1';t2']) + tp' in - if List.length tyl' <= List.length tyl then - let f = Reither(b, List.rev tyl', m, ref None) in + if List.length tyl' < List.length tyl + || List.length tp' < List.length tp then + let f = Reither(b, tyl', m, tp', ref None) in set_row_field e f; f else f @@ -3344,9 +3639,9 @@ List.iter (fun (l,fi) -> match row_field_repr fi with - Reither (c, t1::(_::_ as tl), m, e) -> + Reither (c, t1::(_::_ as tl), m, tp, e) -> List.iter (unify env t1) tl; - set_row_field e (Reither (c, [t1], m, ref None)) + set_row_field e (Reither (c, [t1], m, tp, ref None)) | _ -> ()) row.row_fields; Index: typing/includecore.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/includecore.ml,v retrieving revision 1.32 diff -u -r1.32 includecore.ml --- typing/includecore.ml 8 Aug 2005 05:40:52 -0000 1.32 +++ typing/includecore.ml 2 Feb 2006 06:28:32 -0000 @@ -71,10 +71,10 @@ (fun (_, f1, f2) -> match Btype.row_field_repr f1, Btype.row_field_repr f2 with Rpresent(Some t1), - (Rpresent(Some t2) | Reither(false, [t2], _, _)) -> + (Rpresent(Some t2) | Reither(false,[t2],_,[],_)) -> to_equal := (t1,t2) :: !to_equal; true - | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true - | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_) + | Rpresent None, (Rpresent None | Reither(true,[],_,[],_)) -> true + | Reither(c1,tl1,_,[],_), Reither(c2,tl2,_,[],_) when List.length tl1 = List.length tl2 && c1 = c2 -> to_equal := List.combine tl1 tl2 @ !to_equal; true | Rabsent, (Reither _ | Rabsent) -> true Index: typing/oprint.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v retrieving revision 1.22 diff -u -r1.22 oprint.ml --- typing/oprint.ml 23 Mar 2005 03:08:37 -0000 1.22 +++ typing/oprint.ml 2 Feb 2006 06:28:33 -0000 @@ -223,14 +223,18 @@ print_fields rest ppf [] | (s, t) :: l -> fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l -and print_row_field ppf (l, opt_amp, tyl) = +and print_row_field ppf (l, opt_amp, tyl, tpl) = let pr_of ppf = if opt_amp then fprintf ppf " of@ &@ " else if tyl <> [] then fprintf ppf " of@ " - else fprintf ppf "" - in - fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") - tyl + and pr_tp ppf (t1,t2) = + fprintf ppf "@[%a =@ %a@]" + print_out_type t1 + print_out_type t2 + in + fprintf ppf "@[`%s%t%a%a@]" l pr_of + (print_typlist print_out_type " &") tyl + (print_list_init pr_tp (fun ppf -> fprintf ppf " &@ ")) tpl and print_typlist print_elem sep ppf = function [] -> () Index: typing/outcometree.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v retrieving revision 1.14 diff -u -r1.14 outcometree.mli --- typing/outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14 +++ typing/outcometree.mli 2 Feb 2006 06:28:33 -0000 @@ -61,7 +61,8 @@ bool * out_variant * bool * (string list) option | Otyp_poly of string list * out_type and out_variant = - | Ovar_fields of (string * bool * out_type list) list + | Ovar_fields of + (string * bool * out_type list * (out_type * out_type) list ) list | Ovar_name of out_ident * out_type list type out_class_type = Index: typing/parmatch.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/parmatch.ml,v retrieving revision 1.70 diff -u -r1.70 parmatch.ml --- typing/parmatch.ml 24 Mar 2005 17:20:54 -0000 1.70 +++ typing/parmatch.ml 2 Feb 2006 06:28:33 -0000 @@ -568,11 +568,11 @@ List.fold_left (fun nm (tag,f) -> match Btype.row_field_repr f with - | Reither(_, _, false, e) -> + | Reither(_, _, false, _, e) -> (* m=false means that this tag is not explicitly matched *) Btype.set_row_field e Rabsent; None - | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm) + | Rabsent | Reither (_, _, true, _, _) | Rpresent _ -> nm) row.row_name row.row_fields in if not row.row_closed || nm != row.row_name then begin (* this unification cannot fail *) @@ -605,8 +605,8 @@ List.for_all (fun (tag,f) -> match Btype.row_field_repr f with - Rabsent | Reither(_, _, false, _) -> true - | Reither (_, _, true, _) + Rabsent | Reither(_, _, false, _, _) -> true + | Reither (_, _, true, _, _) (* m=true, do not discard matched tags, rather warn *) | Rpresent _ -> List.mem tag fields) row.row_fields @@ -739,7 +739,7 @@ match Btype.row_field_repr f with Rabsent (* | Reither _ *) -> others (* This one is called after erasing pattern info *) - | Reither (c, _, _, _) -> make_other_pat tag c :: others + | Reither (c, _, _, _, _) -> make_other_pat tag c :: others | Rpresent arg -> make_other_pat tag (arg = None) :: others) [] row.row_fields with Index: typing/printtyp.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v retrieving revision 1.140 diff -u -r1.140 printtyp.ml --- typing/printtyp.ml 4 Jan 2006 16:55:50 -0000 1.140 +++ typing/printtyp.ml 2 Feb 2006 06:28:33 -0000 @@ -157,9 +157,12 @@ and raw_field ppf = function Rpresent None -> fprintf ppf "Rpresent None" | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t - | Reither (c,tl,m,e) -> - fprintf ppf "@[Reither(%b,@,%a,@,%b,@,@[<1>ref%t@])@]" c - raw_type_list tl m + | Reither (c,tl,m,tpl,e) -> + fprintf ppf "@[Reither(%b,@,%a,@,%b,@,%a,@,@[<1>ref%t@])@]" + c raw_type_list tl m + (raw_list + (fun ppf (t1,t2) -> + fprintf ppf "@[%a,@,%a@]" raw_type t1 raw_type t2)) tpl (fun ppf -> match !e with None -> fprintf ppf " None" | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f) @@ -219,8 +222,9 @@ List.for_all (fun (_, f) -> match row_field_repr f with - | Reither(c, l, _, _) -> - row.row_closed && if c then l = [] else List.length l = 1 + | Reither(c, l, _, pl, _) -> + row.row_closed && pl = [] && + if c then l = [] else List.length l = 1 | _ -> true) row.row_fields @@ -392,13 +396,16 @@ and tree_of_row_field sch (l, f) = match row_field_repr f with - | Rpresent None | Reither(true, [], _, _) -> (l, false, []) - | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty]) - | Reither(c, tyl, _, _) -> - if c (* contradiction: un constructeur constant qui a un argument *) - then (l, true, tree_of_typlist sch tyl) - else (l, false, tree_of_typlist sch tyl) - | Rabsent -> (l, false, [] (* une erreur, en fait *)) + | Rpresent None | Reither(true, [], _, [], _) -> (l, false, [], []) + | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty], []) + | Reither(c, tyl, _, tpl, _) -> + let ttpl = + List.map + (fun (t1,t2) -> tree_of_typexp sch t1, tree_of_typexp sch t2) + tpl + in + (l, c && tpl = [], tree_of_typlist sch tyl, ttpl) + | Rabsent -> (l, false, [], [] (* une erreur, en fait *)) and tree_of_typlist sch tyl = List.map (tree_of_typexp sch) tyl Index: typing/typeclass.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v retrieving revision 1.85 diff -u -r1.85 typeclass.ml --- typing/typeclass.ml 22 Jul 2005 06:42:36 -0000 1.85 +++ typing/typeclass.ml 2 Feb 2006 06:28:33 -0000 @@ -727,7 +727,7 @@ {pexp_loc = loc; pexp_desc = Pexp_match({pexp_loc = loc; pexp_desc = Pexp_ident(Longident.Lident"*opt*")}, - scases)} in + scases, false)} in let sfun = {pcl_loc = scl.pcl_loc; pcl_desc = Pcl_fun(l, None, {ppat_loc = loc; ppat_desc = Ppat_var"*opt*"}, Index: typing/typecore.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v retrieving revision 1.178 diff -u -r1.178 typecore.ml --- typing/typecore.ml 6 Jan 2006 02:25:37 -0000 1.178 +++ typing/typecore.ml 2 Feb 2006 06:28:33 -0000 @@ -156,15 +156,21 @@ let field = row_field tag row in begin match field with | Rabsent -> assert false - | Reither (true, [], _, e) when not row.row_closed -> - set_row_field e (Rpresent None) - | Reither (false, ty::tl, _, e) when not row.row_closed -> + | Reither (true, [], _, tpl, e) when not row.row_closed -> + set_row_field e (Rpresent None); + List.iter + (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2) + tpl + | Reither (false, ty::tl, _, tpl, e) when not row.row_closed -> set_row_field e (Rpresent (Some ty)); + List.iter + (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2) + tpl; begin match opat with None -> assert false | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl) end - | Reither (c, l, true, e) when not row.row_fixed -> - set_row_field e (Reither (c, [], false, ref None)) + | Reither (c, l, true, tpl, e) when not row.row_fixed -> + set_row_field e (Reither (c, [], false, [], ref None)) | _ -> () end; (* Force check of well-formedness *) @@ -307,13 +313,13 @@ match row_field_repr f with Rpresent None -> (l,None) :: pats, - (l, Reither(true,[], true, ref None)) :: fields + (l, Reither(true,[], true, [], ref None)) :: fields | Rpresent (Some ty) -> bound := ty :: !bound; (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; pat_type=ty}) :: pats, - (l, Reither(false, [ty], true, ref None)) :: fields + (l, Reither(false, [ty], true, [], ref None)) :: fields | _ -> pats, fields) ([],[]) fields in let row = @@ -337,6 +343,18 @@ pat pats in rp { r with pat_loc = loc } +let rec flatten_or_pat pat = + match pat.pat_desc with + Tpat_or (p1, p2, _) -> + flatten_or_pat p1 @ flatten_or_pat p2 + | _ -> + [pat] + +let all_variants pat = + List.for_all + (function {pat_desc=Tpat_variant _} -> true | _ -> false) + (flatten_or_pat pat) + let rec find_record_qual = function | [] -> None | (Longident.Ldot (modname, _), _) :: _ -> Some modname @@ -423,7 +441,7 @@ let arg = may_map (type_pat env) sarg in let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in let row = { row_fields = - [l, Reither(arg = None, arg_type, true, ref None)]; + [l, Reither(arg = None, arg_type, true, [], ref None)]; row_bound = arg_type; row_closed = false; row_more = newvar (); @@ -788,7 +806,7 @@ newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok)) | Pexp_function (p,_,(_,e)::_) -> newty (Tarrow(p, newvar (), type_approx env e, Cok)) - | Pexp_match (_, (_,e)::_) -> type_approx env e + | Pexp_match (_, (_,e)::_, false) -> type_approx env e | Pexp_try (e, _) -> type_approx env e | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l)) | Pexp_ifthenelse (_,e,_) -> type_approx env e @@ -939,17 +957,26 @@ exp_loc = sexp.pexp_loc; exp_type = ty_res; exp_env = env } - | Pexp_match(sarg, caselist) -> + | Pexp_match(sarg, caselist, multi) -> let arg = type_exp env sarg in let ty_res = newvar() in let cases, partial = - type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist + type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist ~multi in re { exp_desc = Texp_match(arg, cases, partial); exp_loc = sexp.pexp_loc; exp_type = ty_res; exp_env = env } + | Pexp_multifun caselist -> + let ty_arg = newvar() and ty_res = newvar() in + let cases, partial = + type_cases env ty_arg ty_res (Some sexp.pexp_loc) caselist ~multi:true + in + { exp_desc = Texp_function (cases, partial); + exp_loc = sexp.pexp_loc; + exp_type = newty (Tarrow ("", ty_arg, ty_res, Cok)); + exp_env = env } | Pexp_try(sbody, caselist) -> let body = type_exp env sbody in let cases, _ = @@ -1758,7 +1785,7 @@ {pexp_loc = loc; pexp_desc = Pexp_match({pexp_loc = loc; pexp_desc = Pexp_ident(Longident.Lident"*opt*")}, - scases)} in + scases, false)} in let sfun = {pexp_loc = sexp.pexp_loc; pexp_desc = Pexp_function(l, None,[{ppat_loc = loc; ppat_desc = Ppat_var"*opt*"}, @@ -1864,7 +1891,8 @@ (* Typing of match cases *) -and type_cases ?in_function env ty_arg ty_res partial_loc caselist = +and type_cases ?in_function ?(multi=false) + env ty_arg ty_res partial_loc caselist = let ty_arg' = newvar () in let pattern_force = ref [] in let pat_env_list = @@ -1898,10 +1926,64 @@ let cases = List.map2 (fun (pat, ext_env) (spat, sexp) -> - let exp = type_expect ?in_function ext_env sexp ty_res in - (pat, exp)) - pat_env_list caselist - in + let add_variant_case lab row ty_res ty_res' = + let fi = List.assoc lab (row_repr row).row_fields in + begin match row_field_repr fi with + Reither (c, _, m, _, e) -> + let row' = + { row_fields = + [lab, Reither(c,[],false,[ty_res,ty_res'], ref None)]; + row_more = newvar (); row_bound = [ty_res; ty_res']; + row_closed = false; row_fixed = false; row_name = None } + in + unify_pat ext_env {pat with pat_type= newty (Tvariant row)} + (newty (Tvariant row')) + | _ -> + unify_exp ext_env + { exp_desc = Texp_tuple []; exp_type = ty_res; + exp_env = ext_env; exp_loc = sexp.pexp_loc } + ty_res' + end + in + pat, + match pat.pat_desc with + _ when multi && all_variants pat -> + let ty_res' = newvar () in + List.iter + (function {pat_desc=Tpat_variant(lab,_,row)} -> + add_variant_case lab row ty_res ty_res' + | _ -> assert false) + (flatten_or_pat pat); + type_expect ?in_function ext_env sexp ty_res' + | Tpat_alias (p, id) when multi && all_variants p -> + let vd = Env.find_value (Path.Pident id) ext_env in + let row' = + match repr vd.val_type with + {desc=Tvariant row'} -> row' + | _ -> assert false + in + begin_def (); + let tv = newvar () in + let env = Env.add_value id {vd with val_type=tv} ext_env in + let exp = type_exp env sexp in + end_def (); + generalize exp.exp_type; + generalize tv; + List.iter + (function {pat_desc=Tpat_variant(lab,_,row)}, [tv'; ty'] -> + let fi' = List.assoc lab (row_repr row').row_fields in + let row' = + {row' with row_fields=[lab,fi']; row_more=newvar()} in + unify_pat ext_env {pat with pat_type=tv'} + (newty (Tvariant row')); + add_variant_case lab row ty_res ty' + | _ -> assert false) + (List.map (fun p -> p, instance_list [tv; exp.exp_type]) + (flatten_or_pat p)); + {exp with exp_type = instance exp.exp_type} + | _ -> + type_expect ?in_function ext_env sexp ty_res) + pat_env_list caselist in let partial = match partial_loc with None -> Partial | Some loc -> Parmatch.check_partial loc cases Index: typing/typedecl.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/typedecl.ml,v retrieving revision 1.75 diff -u -r1.75 typedecl.ml --- typing/typedecl.ml 16 Aug 2005 00:48:56 -0000 1.75 +++ typing/typedecl.ml 2 Feb 2006 06:28:33 -0000 @@ -432,8 +432,10 @@ match Btype.row_field_repr f with Rpresent (Some ty) -> compute_same ty - | Reither (_, tyl, _, _) -> - List.iter compute_same tyl + | Reither (_, tyl, _, tpl, _) -> + List.iter compute_same tyl; + List.iter (compute_variance_rec true true true) + (List.map fst tpl @ List.map snd tpl) | _ -> ()) row.row_fields; compute_same row.row_more @@ -856,8 +858,8 @@ explain row.row_fields (fun (l,f) -> match Btype.row_field_repr f with Rpresent (Some t) -> t - | Reither (_,[t],_,_) -> t - | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl) + | Reither (_,[t],_,_,_) -> t + | Reither (_,tl,_,_,_) -> Btype.newgenty (Ttuple tl) | _ -> Btype.newgenty (Ttuple[])) "case" (fun (lab,_) -> "`" ^ lab ^ " of ") | _ -> trivial ty' Index: typing/types.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v retrieving revision 1.25 diff -u -r1.25 types.ml --- typing/types.ml 9 Dec 2004 12:40:53 -0000 1.25 +++ typing/types.ml 2 Feb 2006 06:28:33 -0000 @@ -48,7 +48,9 @@ and row_field = Rpresent of type_expr option - | Reither of bool * type_expr list * bool * row_field option ref + | Reither of + bool * type_expr list * bool * + (type_expr * type_expr) list * row_field option ref | Rabsent and abbrev_memo = Index: typing/types.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v retrieving revision 1.25 diff -u -r1.25 types.mli --- typing/types.mli 9 Dec 2004 12:40:53 -0000 1.25 +++ typing/types.mli 2 Feb 2006 06:28:33 -0000 @@ -47,7 +47,9 @@ and row_field = Rpresent of type_expr option - | Reither of bool * type_expr list * bool * row_field option ref + | Reither of + bool * type_expr list * bool * + (type_expr * type_expr) list * row_field option ref (* 1st true denotes a constant constructor *) (* 2nd true denotes a tag in a pattern matching, and is erased later *) Index: typing/typetexp.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v retrieving revision 1.54 diff -u -r1.54 typetexp.ml --- typing/typetexp.ml 22 Jul 2005 06:42:36 -0000 1.54 +++ typing/typetexp.ml 2 Feb 2006 06:28:33 -0000 @@ -207,9 +207,9 @@ match Btype.row_field_repr f with | Rpresent (Some ty) -> bound := ty :: !bound; - Reither(false, [ty], false, ref None) + Reither(false, [ty], false, [], ref None) | Rpresent None -> - Reither (true, [], false, ref None) + Reither (true, [], false, [], ref None) | _ -> f) row.row_fields in @@ -273,13 +273,16 @@ (l, f) :: fields in let rec add_field fields = function - Rtag (l, c, stl) -> + Rtag (l, c, stl, stpl) -> name := None; let f = match present with Some present when not (List.mem l present) -> - let tl = List.map (transl_type env policy) stl in - bound := tl @ !bound; - Reither(c, tl, false, ref None) + let transl_list = List.map (transl_type env policy) in + let tl = transl_list stl in + let stpl1, stpl2 = List.split stpl in + let tpl1 = transl_list stpl1 and tpl2 = transl_list stpl2 in + bound := tl @ tpl1 @ tpl2 @ !bound; + Reither(c, tl, false, List.combine tpl1 tpl2, ref None) | _ -> if List.length stl > 1 || c && stl <> [] then raise(Error(styp.ptyp_loc, Present_has_conjunction l)); @@ -311,9 +314,9 @@ begin match f with Rpresent(Some ty) -> bound := ty :: !bound; - Reither(false, [ty], false, ref None) + Reither(false, [ty], false, [], ref None) | Rpresent None -> - Reither(true, [], false, ref None) + Reither(true, [], false, [], ref None) | _ -> assert false end @@ -406,7 +409,8 @@ {row with row_fixed=true; row_fields = List.map (fun (s,f as p) -> match Btype.row_field_repr f with - Reither (c, tl, m, r) -> s, Reither (c, tl, true, r) + Reither (c, tl, m, tpl, r) -> + s, Reither (c, tl, true, tpl, r) | _ -> p) row.row_fields}; Btype.iter_row make_fixed_univars row Index: typing/unused_var.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v retrieving revision 1.5 diff -u -r1.5 unused_var.ml --- typing/unused_var.ml 4 Jan 2006 16:55:50 -0000 1.5 +++ typing/unused_var.ml 2 Feb 2006 06:28:33 -0000 @@ -122,9 +122,11 @@ | Pexp_apply (e, lel) -> expression ppf tbl e; List.iter (fun (_, e) -> expression ppf tbl e) lel; - | Pexp_match (e, pel) -> + | Pexp_match (e, pel, _) -> expression ppf tbl e; match_pel ppf tbl pel; + | Pexp_multifun pel -> + match_pel ppf tbl pel; | Pexp_try (e, pel) -> expression ppf tbl e; match_pel ppf tbl pel; Index: bytecomp/matching.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/matching.ml,v retrieving revision 1.67 diff -u -r1.67 matching.ml --- bytecomp/matching.ml 7 Sep 2005 16:07:48 -0000 1.67 +++ bytecomp/matching.ml 2 Feb 2006 06:28:33 -0000 @@ -1991,7 +1991,7 @@ List.iter (fun (_, f) -> match Btype.row_field_repr f with - Rabsent | Reither(true, _::_, _, _) -> () + Rabsent | Reither(true, _::_, _, _, _) -> () | _ -> incr num_constr) row.row_fields else Index: toplevel/genprintval.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/toplevel/genprintval.ml,v retrieving revision 1.38 diff -u -r1.38 genprintval.ml --- toplevel/genprintval.ml 13 Jun 2005 04:55:53 -0000 1.38 +++ toplevel/genprintval.ml 2 Feb 2006 06:28:33 -0000 @@ -293,7 +293,7 @@ | (l, f) :: fields -> if Btype.hash_variant l = tag then match Btype.row_field_repr f with - | Rpresent(Some ty) | Reither(_,[ty],_,_) -> + | Rpresent(Some ty) | Reither(_,[ty],_,_,_) -> let args = tree_of_val (depth - 1) (O.field obj 1) ty in Oval_variant (l, Some args) mingw-ocaml/ocaml/experimental/garrigue/tests.ml0000644000175000017500000000114112124403240021450 0ustar tootstoots(* $Id$ *) let f1 = function `a x -> x=1 | `b -> true let f2 = function `a x -> x | `b -> true let f3 = function `b -> true let f x = f1 x && f2 x let sub s ?:pos{=0} ?:len{=String.length s - pos} () = String.sub s pos len let cCAMLtoTKpack_options w = function `After v1 -> "-after" | `Anchor v1 -> "-anchor" | `Before v1 -> "-before" | `Expand v1 -> "-expand" | `Fill v1 -> "-fill" | `In v1 -> "-in" | `Ipadx v1 -> "-ipadx" | `Ipady v1 -> "-ipady" | `Padx v1 -> "-padx" | `Pady v1 -> "-pady" | `Side v1 -> "-side" mingw-ocaml/ocaml/experimental/garrigue/variable-names.ml0000644000175000017500000000043512124403240023201 0ustar tootstootslet f (x : < a:int; .. > as 'me1) = (x : < b:bool; .. > as 'me2);; let f (x : < a:int; .. > as 'me1) = (x : < a:int; b:bool; .. > as 'me2);; let f (x : [> `A of int] as 'me1) = (x : [> `B of bool] as 'me2);; let f (x : [> `A of int] as 'me1) = (x : [`A of int | `B of 'me2] as 'me2);; mingw-ocaml/ocaml/experimental/garrigue/objvariant.ml0000644000175000017500000000174012124403240022452 0ustar tootstoots(* use with [cvs update -r objvariants typing] *) let f (x : [> ]) = x#m 3;; let o = object method m x = x+2 end;; f (`A o);; let l = [`A o; `B(object method m x = x -2 method y = 3 end)];; List.map f l;; let g = function `A x -> x#m 3 | `B x -> x#y;; List.map g l;; fun x -> ignore (x=f); List.map x l;; fun (x : [< `A of _ | `B of _] -> int) -> ignore (x=f); List.map x l;; class cvar name = object method name = name method print ppf = Format.pp_print_string ppf name end type var = [`Var of cvar] class cint n = object method n = n method print ppf = Format.pp_print_int ppf n end class ['a] cadd (e1 : 'a) (e2 : 'a) = object constraint 'a = [> ] method e1 = e1 method e2 = e2 method print ppf = Format.fprintf ppf "(%t, %t)" e1#print e2#print end type 'a expr = [var | `Int of cint | `Add of 'a cadd] type expr1 = expr1 expr let print = Format.printf "%t@." let e1 : expr1 = `Add (new cadd (`Var (new cvar "x")) (`Int (new cint 2))) mingw-ocaml/ocaml/experimental/garrigue/objvariant.diffs0000644000175000017500000003460412124403240023142 0ustar tootstoots? objvariants-3.09.1.diffs ? objvariants.diffs Index: btype.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v retrieving revision 1.37.4.1 diff -u -r1.37.4.1 btype.ml --- btype.ml 5 Dec 2005 13:18:42 -0000 1.37.4.1 +++ btype.ml 16 Jan 2006 02:23:14 -0000 @@ -177,7 +177,8 @@ Tvariant row -> iter_row f row | Tvar | Tunivar | Tsubst _ | Tconstr _ -> Misc.may (fun (_,l) -> List.iter f l) row.row_name; - List.iter f row.row_bound + List.iter f row.row_bound; + List.iter (fun (s,k,t) -> f t) row.row_object | _ -> assert false let iter_type_expr f ty = @@ -224,7 +225,9 @@ | Some (path, tl) -> Some (path, List.map f tl) in { row_fields = fields; row_more = more; row_bound = !bound; row_fixed = row.row_fixed && fixed; - row_closed = row.row_closed; row_name = name; } + row_closed = row.row_closed; row_name = name; + row_object = List.map (fun (s,k,t) -> (s,k,f t)) row.row_object; + } let rec copy_kind = function Fvar{contents = Some k} -> copy_kind k Index: ctype.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v retrieving revision 1.197.2.6 diff -u -r1.197.2.6 ctype.ml --- ctype.ml 15 Dec 2005 02:28:38 -0000 1.197.2.6 +++ ctype.ml 16 Jan 2006 02:23:15 -0000 @@ -1421,7 +1421,7 @@ newgenty (Tvariant {row_fields = fields; row_closed = closed; row_more = newvar(); - row_bound = []; row_fixed = false; row_name = None }) + row_bound = []; row_fixed = false; row_name = None; row_object=[]}) (**** Unification ****) @@ -1724,8 +1724,11 @@ else None in let bound = row1.row_bound @ row2.row_bound in + let opairs, _, miss2 = associate_fields row1.row_object row2.row_object in + let row_object = row1.row_object @ miss2 in let row0 = {row_fields = []; row_more = more; row_bound = bound; - row_closed = closed; row_fixed = fixed; row_name = name} in + row_closed = closed; row_fixed = fixed; row_name = name; + row_object = row_object } in let set_more row rest = let rest = if closed then @@ -1758,6 +1761,18 @@ raise (Unify ((mkvariant [l,f1] true, mkvariant [l,f2] true) :: trace))) pairs; + List.iter (fun (s,_,ty1,_,ty2) -> unify env ty1 ty2) opairs; + if row_object <> [] then begin + List.iter + (fun (l,f) -> + match row_field_repr f with + Rpresent (Some ty) -> + let fi = build_fields generic_level row_object (newgenvar()) in + unify env (newgenty (Tobject (fi, ref None))) ty + | Rpresent None -> raise (Unify []) + | _ -> ()) + (row_repr row1).row_fields + end; with exn -> log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn end @@ -2789,7 +2804,8 @@ let row = { row_fields = List.map fst fields; row_more = newvar(); row_bound = !bound; row_closed = posi; row_fixed = false; - row_name = if c > Unchanged then None else row.row_name } + row_name = if c > Unchanged then None else row.row_name; + row_object = [] } in (newty (Tvariant row), Changed) | Tobject (t1, _) -> Index: oprint.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v retrieving revision 1.22 diff -u -r1.22 oprint.ml --- oprint.ml 23 Mar 2005 03:08:37 -0000 1.22 +++ oprint.ml 16 Jan 2006 02:23:15 -0000 @@ -185,7 +185,7 @@ fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields | Otyp_stuff s -> fprintf ppf "%s" s | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s - | Otyp_variant (non_gen, row_fields, closed, tags) -> + | Otyp_variant (non_gen, row_fields, closed, tags, obj) -> let print_present ppf = function None | Some [] -> () @@ -198,12 +198,17 @@ ppf fields | Ovar_name (id, tyl) -> fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id + and print_object ppf obj = + if obj <> [] then + fprintf ppf "@ as @[<2>< %a >@]" (print_fields (Some false)) obj in - fprintf ppf "%s[%s@[@[%a@]%a ]@]" (if non_gen then "_" else "") + fprintf ppf "%s[%s@[@[%a@]%a%a ]@]" + (if non_gen then "_" else "") (if closed then if tags = None then " " else "< " else if tags = None then "> " else "? ") print_fields row_fields print_present tags + print_object obj | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty -> fprintf ppf "@[<1>(%a)@]" print_out_type ty | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> () Index: outcometree.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v retrieving revision 1.14 diff -u -r1.14 outcometree.mli --- outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14 +++ outcometree.mli 16 Jan 2006 02:23:15 -0000 @@ -59,6 +59,7 @@ | Otyp_var of bool * string | Otyp_variant of bool * out_variant * bool * (string list) option + * (string * out_type) list | Otyp_poly of string list * out_type and out_variant = | Ovar_fields of (string * bool * out_type list) list Index: printtyp.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v retrieving revision 1.139.2.2 diff -u -r1.139.2.2 printtyp.ml --- printtyp.ml 7 Dec 2005 23:37:27 -0000 1.139.2.2 +++ printtyp.ml 16 Jan 2006 02:23:15 -0000 @@ -244,7 +244,10 @@ visited_objects := px :: !visited_objects; match row.row_name with | Some(p, tyl) when namable_row row -> - List.iter (mark_loops_rec visited) tyl + List.iter (mark_loops_rec visited) tyl; + if not (static_row row) then + List.iter (fun (s,k,t) -> mark_loops_rec visited t) + row.row_object | _ -> iter_row (mark_loops_rec visited) {row with row_bound = []} end @@ -343,25 +346,27 @@ | _ -> false) fields in let all_present = List.length present = List.length fields in + let static = row.row_closed && all_present in + let obj = + if static then [] else + List.map (fun (s,k,t) -> (s, tree_of_typexp sch t)) row.row_object + in + let tags = if all_present then None else Some (List.map fst present) in begin match row.row_name with | Some(p, tyl) when namable_row row -> let id = tree_of_path p in let args = tree_of_typlist sch tyl in - if row.row_closed && all_present then + if static then Otyp_constr (id, args) else let non_gen = is_non_gen sch px in - let tags = - if all_present then None else Some (List.map fst present) in Otyp_variant (non_gen, Ovar_name(tree_of_path p, args), - row.row_closed, tags) + row.row_closed, tags, obj) | _ -> - let non_gen = - not (row.row_closed && all_present) && is_non_gen sch px in + let non_gen = not static && is_non_gen sch px in let fields = List.map (tree_of_row_field sch) fields in - let tags = - if all_present then None else Some (List.map fst present) in - Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags) + Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, + tags, obj) end | Tobject (fi, nm) -> tree_of_typobject sch fi nm Index: typecore.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v retrieving revision 1.176.2.2 diff -u -r1.176.2.2 typecore.ml --- typecore.ml 11 Dec 2005 09:56:33 -0000 1.176.2.2 +++ typecore.ml 16 Jan 2006 02:23:15 -0000 @@ -170,7 +170,8 @@ (* Force check of well-formedness *) unify_pat pat.pat_env pat (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false; - row_bound=[]; row_fixed=false; row_name=None})); + row_bound=[]; row_fixed=false; row_name=None; + row_object=[]})); | _ -> () let rec iter_pattern f p = @@ -251,7 +252,7 @@ let ty = may_map (build_as_type env) p' in newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar(); row_bound=[]; row_name=None; - row_fixed=false; row_closed=false}) + row_fixed=false; row_closed=false; row_object=[]}) | Tpat_record lpl -> let lbl = fst(List.hd lpl) in if lbl.lbl_private = Private then p.pat_type else @@ -318,7 +319,8 @@ ([],[]) fields in let row = { row_fields = List.rev fields; row_more = newvar(); row_bound = !bound; - row_closed = false; row_fixed = false; row_name = Some (path, tyl) } + row_closed = false; row_fixed = false; row_name = Some (path, tyl); + row_object = [] } in let ty = newty (Tvariant row) in let gloc = {loc with Location.loc_ghost=true} in @@ -428,7 +430,8 @@ row_closed = false; row_more = newvar (); row_fixed = false; - row_name = None } in + row_name = None; + row_object = [] } in rp { pat_desc = Tpat_variant(l, arg, row); pat_loc = sp.ppat_loc; @@ -976,7 +979,8 @@ row_bound = []; row_closed = false; row_fixed = false; - row_name = None}); + row_name = None; + row_object = []}); exp_env = env } | Pexp_record(lid_sexp_list, opt_sexp) -> let ty = newvar() in @@ -1261,8 +1265,30 @@ assert false end | _ -> - (Texp_send(obj, Tmeth_name met), - filter_method env met Public obj.exp_type) + let obj, met_ty = + match expand_head env obj.exp_type with + {desc = Tvariant _} -> + let exp_ty = newvar () in + let met_ty = filter_method env met Public exp_ty in + let row = + {row_fields=[]; row_more=newvar(); + row_bound=[]; row_closed=false; + row_fixed=false; row_name=None; + row_object=[met, Fpresent, met_ty]} in + unify_exp env obj (newty (Tvariant row)); + let prim = Primitive.parse_declaration 1 ["%field1"] in + let ty = newty(Tarrow("", obj.exp_type, exp_ty, Cok)) in + let vd = {val_type = ty; val_kind = Val_prim prim} in + let esnd = + {exp_desc=Texp_ident(Path.Pident(Ident.create"snd"), vd); + exp_loc = Location.none; exp_type = ty; exp_env = env} + in + ({obj with exp_type = exp_ty; + exp_desc = Texp_apply(esnd,[Some obj, Required])}, + met_ty) + | _ -> (obj, filter_method env met Public obj.exp_type) + in + (Texp_send(obj, Tmeth_name met), met_ty) in if !Clflags.principal then begin end_def (); Index: types.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v retrieving revision 1.25 diff -u -r1.25 types.ml --- types.ml 9 Dec 2004 12:40:53 -0000 1.25 +++ types.ml 16 Jan 2006 02:23:15 -0000 @@ -44,7 +44,9 @@ row_bound: type_expr list; row_closed: bool; row_fixed: bool; - row_name: (Path.t * type_expr list) option } + row_name: (Path.t * type_expr list) option; + row_object: (string * field_kind * type_expr) list; + } and row_field = Rpresent of type_expr option Index: types.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v retrieving revision 1.25 diff -u -r1.25 types.mli --- types.mli 9 Dec 2004 12:40:53 -0000 1.25 +++ types.mli 16 Jan 2006 02:23:15 -0000 @@ -43,7 +43,9 @@ row_bound: type_expr list; row_closed: bool; row_fixed: bool; - row_name: (Path.t * type_expr list) option } + row_name: (Path.t * type_expr list) option; + row_object: (string * field_kind * type_expr) list; + } and row_field = Rpresent of type_expr option Index: typetexp.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v retrieving revision 1.54 diff -u -r1.54 typetexp.ml --- typetexp.ml 22 Jul 2005 06:42:36 -0000 1.54 +++ typetexp.ml 16 Jan 2006 02:23:15 -0000 @@ -215,7 +215,8 @@ in let row = { row_closed = true; row_fields = fields; row_bound = !bound; row_name = Some (path, args); - row_fixed = false; row_more = newvar () } in + row_fixed = false; row_more = newvar (); + row_object = [] } in let static = Btype.static_row row in let row = if static then row else @@ -262,7 +263,7 @@ let mkfield l f = newty (Tvariant {row_fields=[l,f]; row_more=newvar(); row_bound=[]; row_closed=true; - row_fixed=false; row_name=None}) in + row_fixed=false; row_name=None; row_object=[]}) in let add_typed_field loc l f fields = try let f' = List.assoc l fields in @@ -345,7 +346,7 @@ let row = { row_fields = List.rev fields; row_more = newvar (); row_bound = !bound; row_closed = closed; - row_fixed = false; row_name = !name } in + row_fixed = false; row_name = !name; row_object = [] } in let static = Btype.static_row row in let row = if static then row else mingw-ocaml/ocaml/experimental/garrigue/module-errors.diffs0000644000175000017500000003714612124403240023606 0ustar tootstootsIndex: typing/includemod.ml =================================================================== --- typing/includemod.ml (revision 11161) +++ typing/includemod.ml (working copy) @@ -19,7 +19,7 @@ open Types open Typedtree -type error = +type symptom = Missing_field of Ident.t | Value_descriptions of Ident.t * value_description * value_description | Type_declarations of Ident.t * type_declaration @@ -38,6 +38,10 @@ Ctype.class_match_failure list | Unbound_modtype_path of Path.t +type pos = + Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t +type error = pos list * symptom + exception Error of error list (* All functions "blah env x1 x2" check that x1 is included in x2, @@ -46,51 +50,52 @@ (* Inclusion between value descriptions *) -let value_descriptions env subst id vd1 vd2 = +let value_descriptions env cxt subst id vd1 vd2 = let vd2 = Subst.value_description subst vd2 in try Includecore.value_descriptions env vd1 vd2 with Includecore.Dont_match -> - raise(Error[Value_descriptions(id, vd1, vd2)]) + raise(Error[cxt, Value_descriptions(id, vd1, vd2)]) (* Inclusion between type declarations *) -let type_declarations env subst id decl1 decl2 = +let type_declarations env cxt subst id decl1 decl2 = let decl2 = Subst.type_declaration subst decl2 in let err = Includecore.type_declarations env id decl1 decl2 in - if err <> [] then raise(Error[Type_declarations(id, decl1, decl2, err)]) + if err <> [] then raise(Error[cxt, Type_declarations(id, decl1, decl2, err)]) (* Inclusion between exception declarations *) -let exception_declarations env subst id decl1 decl2 = +let exception_declarations env cxt subst id decl1 decl2 = let decl2 = Subst.exception_declaration subst decl2 in if Includecore.exception_declarations env decl1 decl2 then () - else raise(Error[Exception_declarations(id, decl1, decl2)]) + else raise(Error[cxt, Exception_declarations(id, decl1, decl2)]) (* Inclusion between class declarations *) -let class_type_declarations env subst id decl1 decl2 = +let class_type_declarations env cxt subst id decl1 decl2 = let decl2 = Subst.cltype_declaration subst decl2 in match Includeclass.class_type_declarations env decl1 decl2 with [] -> () - | reason -> raise(Error[Class_type_declarations(id, decl1, decl2, reason)]) + | reason -> + raise(Error[cxt, Class_type_declarations(id, decl1, decl2, reason)]) -let class_declarations env subst id decl1 decl2 = +let class_declarations env cxt subst id decl1 decl2 = let decl2 = Subst.class_declaration subst decl2 in match Includeclass.class_declarations env decl1 decl2 with [] -> () - | reason -> raise(Error[Class_declarations(id, decl1, decl2, reason)]) + | reason -> raise(Error[cxt, Class_declarations(id, decl1, decl2, reason)]) (* Expand a module type identifier when possible *) exception Dont_match -let expand_module_path env path = +let expand_module_path env cxt path = try Env.find_modtype_expansion path env with Not_found -> - raise(Error[Unbound_modtype_path path]) + raise(Error[cxt, Unbound_modtype_path path]) (* Extract name, kind and ident from a signature item *) @@ -128,28 +133,29 @@ Return the restriction that transforms a value of the smaller type into a value of the bigger type. *) -let rec modtypes env subst mty1 mty2 = +let rec modtypes env cxt subst mty1 mty2 = try - try_modtypes env subst mty1 mty2 + try_modtypes env cxt subst mty1 mty2 with Dont_match -> - raise(Error[Module_types(mty1, Subst.modtype subst mty2)]) + raise(Error[cxt, Module_types(mty1, Subst.modtype subst mty2)]) | Error reasons -> - raise(Error(Module_types(mty1, Subst.modtype subst mty2) :: reasons)) + raise(Error((cxt, Module_types(mty1, Subst.modtype subst mty2)) + :: reasons)) -and try_modtypes env subst mty1 mty2 = +and try_modtypes env cxt subst mty1 mty2 = match (mty1, mty2) with (_, Tmty_ident p2) -> - try_modtypes2 env mty1 (Subst.modtype subst mty2) + try_modtypes2 env cxt mty1 (Subst.modtype subst mty2) | (Tmty_ident p1, _) -> - try_modtypes env subst (expand_module_path env p1) mty2 + try_modtypes env cxt subst (expand_module_path env cxt p1) mty2 | (Tmty_signature sig1, Tmty_signature sig2) -> - signatures env subst sig1 sig2 + signatures env cxt subst sig1 sig2 | (Tmty_functor(param1, arg1, res1), Tmty_functor(param2, arg2, res2)) -> let arg2' = Subst.modtype subst arg2 in - let cc_arg = modtypes env Subst.identity arg2' arg1 in + let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in let cc_res = - modtypes (Env.add_module param1 arg2' env) + modtypes (Env.add_module param1 arg2' env) (Body param1::cxt) (Subst.add_module param2 (Pident param1) subst) res1 res2 in begin match (cc_arg, cc_res) with (Tcoerce_none, Tcoerce_none) -> Tcoerce_none @@ -158,19 +164,19 @@ | (_, _) -> raise Dont_match -and try_modtypes2 env mty1 mty2 = +and try_modtypes2 env cxt mty1 mty2 = (* mty2 is an identifier *) match (mty1, mty2) with (Tmty_ident p1, Tmty_ident p2) when Path.same p1 p2 -> Tcoerce_none | (_, Tmty_ident p2) -> - try_modtypes env Subst.identity mty1 (expand_module_path env p2) + try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2) | (_, _) -> assert false (* Inclusion between signatures *) -and signatures env subst sig1 sig2 = +and signatures env cxt subst sig1 sig2 = (* Environment used to check inclusion of components *) let new_env = Env.add_signature sig1 env in @@ -202,7 +208,7 @@ let rec pair_components subst paired unpaired = function [] -> begin match unpaired with - [] -> signature_components new_env subst (List.rev paired) + [] -> signature_components new_env cxt subst (List.rev paired) | _ -> raise(Error unpaired) end | item2 :: rem -> @@ -234,7 +240,7 @@ ((item1, item2, pos1) :: paired) unpaired rem with Not_found -> let unpaired = - if report then Missing_field id2 :: unpaired else unpaired in + if report then (cxt, Missing_field id2) :: unpaired else unpaired in pair_components subst paired unpaired rem end in (* Do the pairing and checking, and return the final coercion *) @@ -242,65 +248,67 @@ (* Inclusion between signature components *) -and signature_components env subst = function +and signature_components env cxt subst = function [] -> [] | (Tsig_value(id1, valdecl1), Tsig_value(id2, valdecl2), pos) :: rem -> - let cc = value_descriptions env subst id1 valdecl1 valdecl2 in + let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in begin match valdecl2.val_kind with - Val_prim p -> signature_components env subst rem - | _ -> (pos, cc) :: signature_components env subst rem + Val_prim p -> signature_components env cxt subst rem + | _ -> (pos, cc) :: signature_components env cxt subst rem end | (Tsig_type(id1, tydecl1, _), Tsig_type(id2, tydecl2, _), pos) :: rem -> - type_declarations env subst id1 tydecl1 tydecl2; - signature_components env subst rem + type_declarations env cxt subst id1 tydecl1 tydecl2; + signature_components env cxt subst rem | (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos) :: rem -> - exception_declarations env subst id1 excdecl1 excdecl2; - (pos, Tcoerce_none) :: signature_components env subst rem + exception_declarations env cxt subst id1 excdecl1 excdecl2; + (pos, Tcoerce_none) :: signature_components env cxt subst rem | (Tsig_module(id1, mty1, _), Tsig_module(id2, mty2, _), pos) :: rem -> let cc = - modtypes env subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in - (pos, cc) :: signature_components env subst rem + modtypes env (Module id1::cxt) subst + (Mtype.strengthen env mty1 (Pident id1)) mty2 in + (pos, cc) :: signature_components env cxt subst rem | (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem -> - modtype_infos env subst id1 info1 info2; - signature_components env subst rem + modtype_infos env cxt subst id1 info1 info2; + signature_components env cxt subst rem | (Tsig_class(id1, decl1, _), Tsig_class(id2, decl2, _), pos) :: rem -> - class_declarations env subst id1 decl1 decl2; - (pos, Tcoerce_none) :: signature_components env subst rem + class_declarations env cxt subst id1 decl1 decl2; + (pos, Tcoerce_none) :: signature_components env cxt subst rem | (Tsig_cltype(id1, info1, _), Tsig_cltype(id2, info2, _), pos) :: rem -> - class_type_declarations env subst id1 info1 info2; - signature_components env subst rem + class_type_declarations env cxt subst id1 info1 info2; + signature_components env cxt subst rem | _ -> assert false (* Inclusion between module type specifications *) -and modtype_infos env subst id info1 info2 = +and modtype_infos env cxt subst id info1 info2 = let info2 = Subst.modtype_declaration subst info2 in + let cxt' = Modtype id :: cxt in try match (info1, info2) with (Tmodtype_abstract, Tmodtype_abstract) -> () | (Tmodtype_manifest mty1, Tmodtype_abstract) -> () | (Tmodtype_manifest mty1, Tmodtype_manifest mty2) -> - check_modtype_equiv env mty1 mty2 + check_modtype_equiv env cxt' mty1 mty2 | (Tmodtype_abstract, Tmodtype_manifest mty2) -> - check_modtype_equiv env (Tmty_ident(Pident id)) mty2 + check_modtype_equiv env cxt' (Tmty_ident(Pident id)) mty2 with Error reasons -> - raise(Error(Modtype_infos(id, info1, info2) :: reasons)) + raise(Error((cxt, Modtype_infos(id, info1, info2)) :: reasons)) -and check_modtype_equiv env mty1 mty2 = +and check_modtype_equiv env cxt mty1 mty2 = match - (modtypes env Subst.identity mty1 mty2, - modtypes env Subst.identity mty2 mty1) + (modtypes env cxt Subst.identity mty1 mty2, + modtypes env cxt Subst.identity mty2 mty1) with (Tcoerce_none, Tcoerce_none) -> () - | (_, _) -> raise(Error [Modtype_permutation]) + | (_, _) -> raise(Error [cxt, Modtype_permutation]) (* Simplified inclusion check between module types (for Env) *) let check_modtype_inclusion env mty1 path1 mty2 = try - ignore(modtypes env Subst.identity + ignore(modtypes env [] Subst.identity (Mtype.strengthen env mty1 path1) mty2) with Error reasons -> raise Not_found @@ -312,16 +320,16 @@ let compunit impl_name impl_sig intf_name intf_sig = try - signatures Env.initial Subst.identity impl_sig intf_sig + signatures Env.initial [] Subst.identity impl_sig intf_sig with Error reasons -> - raise(Error(Interface_mismatch(impl_name, intf_name) :: reasons)) + raise(Error(([], Interface_mismatch(impl_name, intf_name)) :: reasons)) -(* Hide the substitution parameter to the outside world *) +(* Hide the context and substitution parameters to the outside world *) -let modtypes env mty1 mty2 = modtypes env Subst.identity mty1 mty2 -let signatures env sig1 sig2 = signatures env Subst.identity sig1 sig2 +let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2 +let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2 let type_declarations env id decl1 decl2 = - type_declarations env Subst.identity id decl1 decl2 + type_declarations env [] Subst.identity id decl1 decl2 (* Error report *) @@ -384,9 +392,62 @@ | Unbound_modtype_path path -> fprintf ppf "Unbound module type %a" Printtyp.path path -let report_error ppf = function - | [] -> () - | err :: errs -> - let print_errs ppf errs = - List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in - fprintf ppf "@[%a%a@]" include_err err print_errs errs +let rec context ppf = function + Module id :: rem -> + fprintf ppf "@[<2>module %a%a@]" ident id args rem + | Modtype id :: rem -> + fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem + | Body x :: rem -> + fprintf ppf "functor (%a) ->@ %a" ident x context_mty rem + | Arg x :: rem -> + fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem + | [] -> + fprintf ppf "" +and context_mty ppf = function + (Module _ | Modtype _) :: _ as rem -> + fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem + | cxt -> context ppf cxt +and args ppf = function + Body x :: rem -> + fprintf ppf "(%a)%a" ident x args rem + | Arg x :: rem -> + fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem + | cxt -> + fprintf ppf " :@ %a" context_mty cxt + +let path_of_context = function + Module id :: rem -> + let rec subm path = function + [] -> path + | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem + | _ -> assert false + in subm (Pident id) rem + | _ -> assert false + +let context ppf cxt = + if cxt = [] then () else + if List.for_all (function Module _ -> true | _ -> false) cxt then + fprintf ppf "In module %a:@ " path (path_of_context cxt) + else + fprintf ppf "@[At position@ %a@]@ " context cxt + +let include_err ppf (cxt, err) = + fprintf ppf "@[%a%a@]" context (List.rev cxt) include_err err + +let max_size = 500 +let buffer = String.create max_size +let is_big obj = + try ignore (Marshal.to_buffer buffer 0 max_size obj []); false + with _ -> true + +let report_error ppf errs = + if errs = [] then () else + let (errs , err) = split_last errs in + let pe = ref true in + let include_err' ppf err = + if !Clflags.show_trace || not (is_big err) then + fprintf ppf "%a@ " include_err err + else if !pe then (fprintf ppf "...@ "; pe := false) + in + let print_errs ppf = List.iter (include_err' ppf) in + fprintf ppf "@[%a%a@]" print_errs errs include_err err Index: typing/includemod.mli =================================================================== --- typing/includemod.mli (revision 11161) +++ typing/includemod.mli (working copy) @@ -24,7 +24,7 @@ val type_declarations: Env.t -> Ident.t -> type_declaration -> type_declaration -> unit -type error = +type symptom = Missing_field of Ident.t | Value_descriptions of Ident.t * value_description * value_description | Type_declarations of Ident.t * type_declaration @@ -43,6 +43,10 @@ Ctype.class_match_failure list | Unbound_modtype_path of Path.t +type pos = + Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t +type error = pos list * symptom + exception Error of error list val report_error: formatter -> error list -> unit Index: utils/clflags.ml =================================================================== --- utils/clflags.ml (revision 11161) +++ utils/clflags.ml (working copy) @@ -53,6 +53,7 @@ and dllpaths = ref ([] : string list) (* -dllpath *) and make_package = ref false (* -pack *) and for_package = ref (None: string option) (* -for-pack *) +and show_trace = ref false (* -show-trace *) let dump_parsetree = ref false (* -dparsetree *) and dump_rawlambda = ref false (* -drawlambda *) and dump_lambda = ref false (* -dlambda *) Index: utils/clflags.mli =================================================================== --- utils/clflags.mli (revision 11161) +++ utils/clflags.mli (working copy) @@ -50,6 +50,7 @@ val dllpaths : string list ref val make_package : bool ref val for_package : string option ref +val show_trace : bool ref val dump_parsetree : bool ref val dump_rawlambda : bool ref val dump_lambda : bool ref mingw-ocaml/ocaml/experimental/garrigue/countchars.ml0000644000175000017500000000057512124403240022471 0ustar tootstootslet rec long_lines name n ic = let l = input_line ic in if String.length l > 80 then Printf.printf "%s: %d\n%!" name n; long_lines name (n+1) ic let process_file name = try let ic = open_in name in try long_lines name 1 ic with End_of_file -> close_in ic with _ ->() let () = for i = 1 to Array.length Sys.argv - 1 do process_file Sys.argv.(i) done mingw-ocaml/ocaml/experimental/garrigue/coerce.diffs0000644000175000017500000000674212124403240022245 0ustar tootstootsIndex: typing/ctype.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v retrieving revision 1.201 diff -u -r1.201 ctype.ml --- typing/ctype.ml 5 Apr 2006 02:28:13 -0000 1.201 +++ typing/ctype.ml 17 May 2006 23:48:22 -0000 @@ -490,6 +490,31 @@ unmark_class_signature sign; Some reason +(* Variant for checking principality *) + +let rec free_nodes_rec ty = + let ty = repr ty in + if ty.level >= lowest_level then begin + if ty.level <= !current_level then raise Exit; + ty.level <- pivot_level - ty.level; + begin match ty.desc with + Tvar -> + raise Exit + | Tobject (ty, _) -> + free_nodes_rec ty + | Tfield (_, _, ty1, ty2) -> + free_nodes_rec ty1; free_nodes_rec ty2 + | Tvariant row -> + let row = row_repr row in + iter_row free_nodes_rec {row with row_bound = []}; + if not (static_row row) then free_nodes_rec row.row_more + | _ -> + iter_type_expr free_nodes_rec ty + end; + end + +let has_free_nodes ty = + try free_nodes_rec ty; false with Exit -> true (**********************) (* Type duplication *) Index: typing/ctype.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v retrieving revision 1.54 diff -u -r1.54 ctype.mli --- typing/ctype.mli 5 Apr 2006 02:28:13 -0000 1.54 +++ typing/ctype.mli 17 May 2006 23:48:22 -0000 @@ -228,6 +228,9 @@ val closed_class: type_expr list -> class_signature -> closed_class_failure option (* Check whether all type variables are bound *) +val has_free_nodes: type_expr -> bool + (* Check whether there are free type variables, or nodes with + level lower or equal to !current_level *) val unalias: type_expr -> type_expr val signature_of_class_type: class_type -> class_signature Index: typing/typecore.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v retrieving revision 1.181 diff -u -r1.181 typecore.ml --- typing/typecore.ml 16 Apr 2006 23:28:22 -0000 1.181 +++ typing/typecore.ml 17 May 2006 23:48:22 -0000 @@ -1183,12 +1183,29 @@ let (ty', force) = Typetexp.transl_simple_type_delayed env sty' in + if !Clflags.principal then begin_def (); let arg = type_exp env sarg in + let has_fv = + if !Clflags.principal then begin + end_def (); + let b = has_free_nodes arg.exp_type in + Ctype.unify env arg.exp_type (newvar ()); + b + end else + free_variables arg.exp_type <> [] + in begin match arg.exp_desc, !self_coercion, (repr ty').desc with Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _, Tconstr(path',_,_) when Path.same path path' -> r := sexp.pexp_loc :: !r; force () + | _ when not has_fv -> + begin try + let force' = subtype env arg.exp_type ty' in + force (); force' () + with Subtype (tr1, tr2) -> + raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2))) + end | _ -> let ty, b = enlarge_type env ty' in force (); mingw-ocaml/ocaml/experimental/garrigue/valvirt.diffs0000644000175000017500000027633612124403240022504 0ustar tootstootsIndex: utils/warnings.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.ml,v retrieving revision 1.23 diff -u -r1.23 warnings.ml --- utils/warnings.ml 15 Sep 2005 03:09:26 -0000 1.23 +++ utils/warnings.ml 5 Apr 2006 02:25:59 -0000 @@ -26,7 +26,7 @@ | Statement_type (* S *) | Unused_match (* U *) | Unused_pat - | Hide_instance_variable of string (* V *) + | Instance_variable_override of string (* V *) | Illegal_backslash (* X *) | Implicit_public_methods of string list | Unerasable_optional_argument @@ -54,7 +54,7 @@ | Statement_type -> 's' | Unused_match | Unused_pat -> 'u' - | Hide_instance_variable _ -> 'v' + | Instance_variable_override _ -> 'v' | Illegal_backslash | Implicit_public_methods _ | Unerasable_optional_argument @@ -126,9 +126,9 @@ String.concat " " ("the following methods are overridden \ by the inherited class:\n " :: slist) - | Hide_instance_variable lab -> - "this definition of an instance variable " ^ lab ^ - " hides a previously\ndefined instance variable of the same name." + | Instance_variable_override lab -> + "the instance variable " ^ lab ^ " is overridden.\n" ^ + "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" | Partial_application -> "this function application is partial,\n\ maybe some arguments are missing." Index: utils/warnings.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.mli,v retrieving revision 1.16 diff -u -r1.16 warnings.mli --- utils/warnings.mli 15 Sep 2005 03:09:26 -0000 1.16 +++ utils/warnings.mli 5 Apr 2006 02:25:59 -0000 @@ -26,7 +26,7 @@ | Statement_type (* S *) | Unused_match (* U *) | Unused_pat - | Hide_instance_variable of string (* V *) + | Instance_variable_override of string (* V *) | Illegal_backslash (* X *) | Implicit_public_methods of string list | Unerasable_optional_argument Index: parsing/parser.mly =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v retrieving revision 1.123 diff -u -r1.123 parser.mly --- parsing/parser.mly 23 Mar 2005 03:08:37 -0000 1.123 +++ parsing/parser.mly 5 Apr 2006 02:25:59 -0000 @@ -623,6 +623,8 @@ { [] } | class_fields INHERIT class_expr parent_binder { Pcf_inher ($3, $4) :: $1 } + | class_fields VAL virtual_value + { Pcf_valvirt $3 :: $1 } | class_fields VAL value { Pcf_val $3 :: $1 } | class_fields virtual_method @@ -638,14 +640,20 @@ AS LIDENT { Some $2 } | /* empty */ - {None} + { None } +; +virtual_value: + MUTABLE VIRTUAL label COLON core_type + { $3, Mutable, $5, symbol_rloc () } + | VIRTUAL mutable_flag label COLON core_type + { $3, $2, $5, symbol_rloc () } ; value: - mutable_flag label EQUAL seq_expr - { $2, $1, $4, symbol_rloc () } - | mutable_flag label type_constraint EQUAL seq_expr - { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))), - symbol_rloc () } + mutable_flag label EQUAL seq_expr + { $2, $1, $4, symbol_rloc () } + | mutable_flag label type_constraint EQUAL seq_expr + { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))), + symbol_rloc () } ; virtual_method: METHOD PRIVATE VIRTUAL label COLON poly_type @@ -711,8 +719,12 @@ | class_sig_fields CONSTRAINT constrain { Pctf_cstr $3 :: $1 } ; value_type: - mutable_flag label COLON core_type - { $2, $1, Some $4, symbol_rloc () } + VIRTUAL mutable_flag label COLON core_type + { $3, $2, Virtual, $5, symbol_rloc () } + | MUTABLE virtual_flag label COLON core_type + { $3, Mutable, $2, $5, symbol_rloc () } + | label COLON core_type + { $1, Immutable, Concrete, $3, symbol_rloc () } ; method_type: METHOD private_flag label COLON poly_type Index: parsing/parsetree.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v retrieving revision 1.42 diff -u -r1.42 parsetree.mli --- parsing/parsetree.mli 23 Mar 2005 03:08:37 -0000 1.42 +++ parsing/parsetree.mli 5 Apr 2006 02:25:59 -0000 @@ -152,7 +152,7 @@ and class_type_field = Pctf_inher of class_type - | Pctf_val of (string * mutable_flag * core_type option * Location.t) + | Pctf_val of (string * mutable_flag * virtual_flag * core_type * Location.t) | Pctf_virt of (string * private_flag * core_type * Location.t) | Pctf_meth of (string * private_flag * core_type * Location.t) | Pctf_cstr of (core_type * core_type * Location.t) @@ -179,6 +179,7 @@ and class_field = Pcf_inher of class_expr * string option + | Pcf_valvirt of (string * mutable_flag * core_type * Location.t) | Pcf_val of (string * mutable_flag * expression * Location.t) | Pcf_virt of (string * private_flag * core_type * Location.t) | Pcf_meth of (string * private_flag * expression * Location.t) Index: parsing/printast.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v retrieving revision 1.29 diff -u -r1.29 printast.ml --- parsing/printast.ml 4 Jan 2006 16:55:50 -0000 1.29 +++ parsing/printast.ml 5 Apr 2006 02:25:59 -0000 @@ -353,10 +353,11 @@ | Pctf_inher (ct) -> line i ppf "Pctf_inher\n"; class_type i ppf ct; - | Pctf_val (s, mf, cto, loc) -> + | Pctf_val (s, mf, vf, ct, loc) -> line i ppf - "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc; - option i core_type ppf cto; + "Pctf_val \"%s\" %a %a %a\n" s + fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc; + core_type (i+1) ppf ct; | Pctf_virt (s, pf, ct, loc) -> line i ppf "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; @@ -428,6 +429,10 @@ line i ppf "Pcf_inher\n"; class_expr (i+1) ppf ce; option (i+1) string ppf so; + | Pcf_valvirt (s, mf, ct, loc) -> + line i ppf + "Pcf_valvirt \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc; + core_type (i+1) ppf ct; | Pcf_val (s, mf, e, loc) -> line i ppf "Pcf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc; Index: typing/btype.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v retrieving revision 1.38 diff -u -r1.38 btype.ml --- typing/btype.ml 4 Jan 2006 16:55:50 -0000 1.38 +++ typing/btype.ml 5 Apr 2006 02:25:59 -0000 @@ -330,7 +330,7 @@ let unmark_class_signature sign = unmark_type sign.cty_self; - Vars.iter (fun l (m, t) -> unmark_type t) sign.cty_vars + Vars.iter (fun l (m, v, t) -> unmark_type t) sign.cty_vars let rec unmark_class_type = function Index: typing/ctype.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v retrieving revision 1.200 diff -u -r1.200 ctype.ml --- typing/ctype.ml 6 Jan 2006 02:16:24 -0000 1.200 +++ typing/ctype.ml 5 Apr 2006 02:25:59 -0000 @@ -857,7 +857,7 @@ Tcty_signature {cty_self = copy sign.cty_self; cty_vars = - Vars.map (function (mut, ty) -> (mut, copy ty)) sign.cty_vars; + Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.cty_vars; cty_concr = sign.cty_concr; cty_inher = List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher} @@ -2354,10 +2354,11 @@ | CM_Val_type_mismatch of string * (type_expr * type_expr) list | CM_Meth_type_mismatch of string * (type_expr * type_expr) list | CM_Non_mutable_value of string + | CM_Non_concrete_value of string | CM_Missing_value of string | CM_Missing_method of string | CM_Hide_public of string - | CM_Hide_virtual of string + | CM_Hide_virtual of string * string | CM_Public_method of string | CM_Private_method of string | CM_Virtual_method of string @@ -2390,8 +2391,8 @@ end) pairs; Vars.iter - (fun lab (mut, ty) -> - let (mut', ty') = Vars.find lab sign1.cty_vars in + (fun lab (mut, v, ty) -> + let (mut', v', ty') = Vars.find lab sign1.cty_vars in try moregen true type_pairs env ty' ty with Unify trace -> raise (Failure [CM_Val_type_mismatch (lab, expand_trace env trace)])) @@ -2437,7 +2438,7 @@ end in if Concr.mem lab sign1.cty_concr then err - else CM_Hide_virtual lab::err) + else CM_Hide_virtual ("method", lab) :: err) miss1 [] in let missing_method = List.map (fun (m, _, _) -> m) miss2 in @@ -2455,11 +2456,13 @@ in let error = Vars.fold - (fun lab (mut, ty) err -> + (fun lab (mut, vr, ty) err -> try - let (mut', ty') = Vars.find lab sign1.cty_vars in + let (mut', vr', ty') = Vars.find lab sign1.cty_vars in if mut = Mutable && mut' <> Mutable then CM_Non_mutable_value lab::err + else if vr = Concrete && vr' <> Concrete then + CM_Non_concrete_value lab::err else err with Not_found -> @@ -2467,6 +2470,14 @@ sign2.cty_vars error in let error = + Vars.fold + (fun lab (_,vr,_) err -> + if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then + CM_Hide_virtual ("instance variable", lab) :: err + else err) + sign1.cty_vars error + in + let error = List.fold_right (fun e l -> if List.mem e missing_method then l else CM_Virtual_method e::l) @@ -2516,8 +2527,8 @@ end) pairs; Vars.iter - (fun lab (mut, ty) -> - let (mut', ty') = Vars.find lab sign1.cty_vars in + (fun lab (_, _, ty) -> + let (_, _, ty') = Vars.find lab sign1.cty_vars in try eqtype true type_pairs subst env ty ty' with Unify trace -> raise (Failure [CM_Val_type_mismatch (lab, expand_trace env trace)])) @@ -2554,7 +2565,7 @@ end in if Concr.mem lab sign1.cty_concr then err - else CM_Hide_virtual lab::err) + else CM_Hide_virtual ("method", lab) :: err) miss1 [] in let missing_method = List.map (fun (m, _, _) -> m) miss2 in @@ -2578,11 +2589,13 @@ in let error = Vars.fold - (fun lab (mut, ty) err -> + (fun lab (mut, vr, ty) err -> try - let (mut', ty') = Vars.find lab sign1.cty_vars in + let (mut', vr', ty') = Vars.find lab sign1.cty_vars in if mut = Mutable && mut' <> Mutable then CM_Non_mutable_value lab::err + else if vr = Concrete && vr' <> Concrete then + CM_Non_concrete_value lab::err else err with Not_found -> @@ -2590,6 +2603,14 @@ sign2.cty_vars error in let error = + Vars.fold + (fun lab (_,vr,_) err -> + if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then + CM_Hide_virtual ("instance variable", lab) :: err + else err) + sign1.cty_vars error + in + let error = List.fold_right (fun e l -> if List.mem e missing_method then l else CM_Virtual_method e::l) @@ -3279,7 +3300,7 @@ let nondep_class_signature env id sign = { cty_self = nondep_type_rec env id sign.cty_self; cty_vars = - Vars.map (function (m, t) -> (m, nondep_type_rec env id t)) + Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t)) sign.cty_vars; cty_concr = sign.cty_concr; cty_inher = Index: typing/ctype.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v retrieving revision 1.53 diff -u -r1.53 ctype.mli --- typing/ctype.mli 9 Dec 2004 12:40:53 -0000 1.53 +++ typing/ctype.mli 5 Apr 2006 02:25:59 -0000 @@ -170,10 +170,11 @@ | CM_Val_type_mismatch of string * (type_expr * type_expr) list | CM_Meth_type_mismatch of string * (type_expr * type_expr) list | CM_Non_mutable_value of string + | CM_Non_concrete_value of string | CM_Missing_value of string | CM_Missing_method of string | CM_Hide_public of string - | CM_Hide_virtual of string + | CM_Hide_virtual of string * string | CM_Public_method of string | CM_Private_method of string | CM_Virtual_method of string Index: typing/includeclass.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/includeclass.ml,v retrieving revision 1.7 diff -u -r1.7 includeclass.ml --- typing/includeclass.ml 6 Mar 2000 22:11:57 -0000 1.7 +++ typing/includeclass.ml 5 Apr 2006 02:25:59 -0000 @@ -78,14 +78,17 @@ | CM_Non_mutable_value lab -> fprintf ppf "@[The non-mutable instance variable %s cannot become mutable@]" lab + | CM_Non_concrete_value lab -> + fprintf ppf + "@[The virtual instance variable %s cannot become concrete@]" lab | CM_Missing_value lab -> fprintf ppf "@[The first class type has no instance variable %s@]" lab | CM_Missing_method lab -> fprintf ppf "@[The first class type has no method %s@]" lab | CM_Hide_public lab -> fprintf ppf "@[The public method %s cannot be hidden@]" lab - | CM_Hide_virtual lab -> - fprintf ppf "@[The virtual method %s cannot be hidden@]" lab + | CM_Hide_virtual (k, lab) -> + fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab | CM_Public_method lab -> fprintf ppf "@[The public method %s cannot become private" lab | CM_Virtual_method lab -> Index: typing/oprint.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v retrieving revision 1.22 diff -u -r1.22 oprint.ml --- typing/oprint.ml 23 Mar 2005 03:08:37 -0000 1.22 +++ typing/oprint.ml 5 Apr 2006 02:25:59 -0000 @@ -291,8 +291,10 @@ fprintf ppf "@[<2>method %s%s%s :@ %a@]" (if priv then "private " else "") (if virt then "virtual " else "") name !out_type ty - | Ocsg_value (name, mut, ty) -> - fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "") + | Ocsg_value (name, mut, vr, ty) -> + fprintf ppf "@[<2>val %s%s%s :@ %a@]" + (if mut then "mutable " else "") + (if vr then "virtual " else "") name !out_type ty let out_class_type = ref print_out_class_type Index: typing/outcometree.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v retrieving revision 1.14 diff -u -r1.14 outcometree.mli --- typing/outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14 +++ typing/outcometree.mli 5 Apr 2006 02:25:59 -0000 @@ -71,7 +71,7 @@ and out_class_sig_item = | Ocsg_constraint of out_type * out_type | Ocsg_method of string * bool * bool * out_type - | Ocsg_value of string * bool * out_type + | Ocsg_value of string * bool * bool * out_type type out_module_type = | Omty_abstract Index: typing/printtyp.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v retrieving revision 1.140 diff -u -r1.140 printtyp.ml --- typing/printtyp.ml 4 Jan 2006 16:55:50 -0000 1.140 +++ typing/printtyp.ml 5 Apr 2006 02:26:00 -0000 @@ -650,7 +650,7 @@ Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in List.iter (fun met -> mark_loops (method_type met)) fields; - Vars.iter (fun _ (_, ty) -> mark_loops ty) sign.cty_vars + Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars | Tcty_fun (_, ty, cty) -> mark_loops ty; prepare_class_type params cty @@ -682,13 +682,15 @@ csil (tree_of_constraints params) in let all_vars = - Vars.fold (fun l (m, t) all -> (l, m, t) :: all) sign.cty_vars [] in + Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.cty_vars [] + in (* Consequence of PR#3607: order of Map.fold has changed! *) let all_vars = List.rev all_vars in let csil = List.fold_left - (fun csil (l, m, t) -> - Ocsg_value (l, m = Mutable, tree_of_typexp sch t) :: csil) + (fun csil (l, m, v, t) -> + Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t) + :: csil) csil all_vars in let csil = @@ -763,7 +765,9 @@ List.exists (fun (lab, _, ty) -> not (lab = dummy_method || Concr.mem lab sign.cty_concr)) - fields in + fields + || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.cty_vars false + in Osig_class_type (virt, Ident.name id, Index: typing/subst.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/subst.ml,v retrieving revision 1.49 diff -u -r1.49 subst.ml --- typing/subst.ml 4 Jan 2006 16:55:50 -0000 1.49 +++ typing/subst.ml 5 Apr 2006 02:26:00 -0000 @@ -178,7 +178,8 @@ let class_signature s sign = { cty_self = typexp s sign.cty_self; - cty_vars = Vars.map (function (m, t) -> (m, typexp s t)) sign.cty_vars; + cty_vars = + Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.cty_vars; cty_concr = sign.cty_concr; cty_inher = List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl)) Index: typing/typeclass.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v retrieving revision 1.85 diff -u -r1.85 typeclass.ml --- typing/typeclass.ml 22 Jul 2005 06:42:36 -0000 1.85 +++ typing/typeclass.ml 5 Apr 2006 02:26:00 -0000 @@ -24,7 +24,7 @@ type error = Unconsistent_constraint of (type_expr * type_expr) list - | Method_type_mismatch of string * (type_expr * type_expr) list + | Field_type_mismatch of string * string * (type_expr * type_expr) list | Structure_expected of class_type | Cannot_apply of class_type | Apply_wrong_label of label @@ -36,7 +36,7 @@ | Unbound_class_type_2 of Longident.t | Abbrev_type_clash of type_expr * type_expr * type_expr | Constructor_type_mismatch of string * (type_expr * type_expr) list - | Virtual_class of bool * string list + | Virtual_class of bool * string list * string list | Parameter_arity_mismatch of Longident.t * int * int | Parameter_mismatch of (type_expr * type_expr) list | Bad_parameters of Ident.t * type_expr * type_expr @@ -49,6 +49,7 @@ | Non_collapsable_conjunction of Ident.t * Types.class_declaration * (type_expr * type_expr) list | Final_self_clash of (type_expr * type_expr) list + | Mutability_mismatch of string * mutable_flag exception Error of Location.t * error @@ -90,7 +91,7 @@ generalize_class_type cty | Tcty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} -> Ctype.generalize sty; - Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars; + Vars.iter (fun _ (_, _, ty) -> Ctype.generalize ty) vars; List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher | Tcty_fun (_, ty, cty) -> Ctype.generalize ty; @@ -152,7 +153,7 @@ | Tcty_signature sign -> Ctype.closed_schema sign.cty_self && - Vars.fold (fun _ (_, ty) cc -> Ctype.closed_schema ty && cc) + Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc) sign.cty_vars true | Tcty_fun (_, ty, cty) -> @@ -172,7 +173,7 @@ limited_generalize rv cty | Tcty_signature sign -> Ctype.limited_generalize rv sign.cty_self; - Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty) + Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty) sign.cty_vars; List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl) sign.cty_inher @@ -201,11 +202,25 @@ Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env) (* Enter an instance variable in the environment *) -let enter_val cl_num vars lab mut ty val_env met_env par_env = - let (id, val_env, met_env, par_env) as result = - enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env +let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc = + let (id, virt) = + try + let (id, mut', virt', ty') = Vars.find lab !vars in + if mut' <> mut then raise (Error(loc, Mutability_mismatch(lab, mut))); + Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty'); + (if not inh then Some id else None), + (if virt' = Concrete then virt' else virt) + with + Ctype.Unify tr -> + raise (Error(loc, Field_type_mismatch("instance variable", lab, tr))) + | Not_found -> None, virt + in + let (id, _, _, _) as result = + match id with Some id -> (id, val_env, met_env, par_env) + | None -> + enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env in - vars := Vars.add lab (id, mut, ty) !vars; + vars := Vars.add lab (id, mut, virt, ty) !vars; result let inheritance self_type env concr_meths warn_meths loc parent = @@ -218,7 +233,7 @@ with Ctype.Unify trace -> match trace with _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem -> - raise(Error(loc, Method_type_mismatch (n, rem))) + raise(Error(loc, Field_type_mismatch ("method", n, rem))) | _ -> assert false end; @@ -243,7 +258,7 @@ in let ty = transl_simple_type val_env false sty in try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, Method_type_mismatch (lab, trace))) + raise(Error(loc, Field_type_mismatch ("method", lab, trace))) let delayed_meth_specs = ref [] @@ -253,7 +268,7 @@ in let unif ty = try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, Method_type_mismatch (lab, trace))) + raise(Error(loc, Field_type_mismatch ("method", lab, trace))) in match sty.ptyp_desc, priv with Ptyp_poly ([],sty), Public -> @@ -279,6 +294,15 @@ (*******************************) +let add_val env loc lab (mut, virt, ty) val_sig = + let virt = + try + let (mut', virt', ty') = Vars.find lab val_sig in + if virt' = Concrete then virt' else virt + with Not_found -> virt + in + Vars.add lab (mut, virt, ty) val_sig + let rec class_type_field env self_type meths (val_sig, concr_meths, inher) = function Pctf_inher sparent -> @@ -293,25 +317,12 @@ parent in let val_sig = - Vars.fold - (fun lab (mut, ty) val_sig -> Vars.add lab (mut, ty) val_sig) - cl_sig.cty_vars val_sig - in + Vars.fold (add_val env sparent.pcty_loc) cl_sig.cty_vars val_sig in (val_sig, concr_meths, inher) - | Pctf_val (lab, mut, sty_opt, loc) -> - let (mut, ty) = - match sty_opt with - None -> - let (mut', ty) = - try Vars.find lab val_sig with Not_found -> - raise(Error(loc, Unbound_val lab)) - in - (if mut = Mutable then mut' else Immutable), ty - | Some sty -> - mut, transl_simple_type env false sty - in - (Vars.add lab (mut, ty) val_sig, concr_meths, inher) + | Pctf_val (lab, mut, virt, sty, loc) -> + let ty = transl_simple_type env false sty in + (add_val env loc lab (mut, virt, ty) val_sig, concr_meths, inher) | Pctf_virt (lab, priv, sty, loc) -> declare_method env meths self_type lab priv sty loc; @@ -397,7 +408,7 @@ let rec class_field cl_num self_type meths vars (val_env, met_env, par_env, fields, concr_meths, warn_meths, - inh_vals, inher) = + warn_vals, inher) = function Pcf_inher (sparent, super) -> let parent = class_expr cl_num val_env par_env sparent in @@ -411,18 +422,23 @@ parent.cl_type in (* Variables *) - let (val_env, met_env, par_env, inh_vars, inh_vals) = + let (val_env, met_env, par_env, inh_vars, warn_vals) = Vars.fold - (fun lab (mut, ty) (val_env, met_env, par_env, inh_vars, inh_vals) -> + (fun lab info (val_env, met_env, par_env, inh_vars, warn_vals) -> + let mut, vr, ty = info in let (id, val_env, met_env, par_env) = - enter_val cl_num vars lab mut ty val_env met_env par_env + enter_val cl_num vars true lab mut vr ty val_env met_env par_env + sparent.pcl_loc in - if StringSet.mem lab inh_vals then - Location.prerr_warning sparent.pcl_loc - (Warnings.Hide_instance_variable lab); - (val_env, met_env, par_env, (lab, id) :: inh_vars, - StringSet.add lab inh_vals)) - cl_sig.cty_vars (val_env, met_env, par_env, [], inh_vals) + let warn_vals = + if vr = Virtual then warn_vals else + if StringSet.mem lab warn_vals then + (Location.prerr_warning sparent.pcl_loc + (Warnings.Instance_variable_override lab); warn_vals) + else StringSet.add lab warn_vals + in + (val_env, met_env, par_env, (lab, id) :: inh_vars, warn_vals)) + cl_sig.cty_vars (val_env, met_env, par_env, [], warn_vals) in (* Inherited concrete methods *) let inh_meths = @@ -443,11 +459,26 @@ in (val_env, met_env, par_env, lazy(Cf_inher (parent, inh_vars, inh_meths))::fields, - concr_meths, warn_meths, inh_vals, inher) + concr_meths, warn_meths, warn_vals, inher) + + | Pcf_valvirt (lab, mut, styp, loc) -> + if !Clflags.principal then Ctype.begin_def (); + let ty = Typetexp.transl_simple_type val_env false styp in + if !Clflags.principal then begin + Ctype.end_def (); + Ctype.generalize_structure ty + end; + let (id, val_env, met_env', par_env) = + enter_val cl_num vars false lab mut Virtual ty + val_env met_env par_env loc + in + (val_env, met_env', par_env, + lazy(Cf_val (lab, id, None, met_env' == met_env)) :: fields, + concr_meths, warn_meths, StringSet.remove lab warn_vals, inher) | Pcf_val (lab, mut, sexp, loc) -> - if StringSet.mem lab inh_vals then - Location.prerr_warning loc (Warnings.Hide_instance_variable lab); + if StringSet.mem lab warn_vals then + Location.prerr_warning loc (Warnings.Instance_variable_override lab); if !Clflags.principal then Ctype.begin_def (); let exp = try type_exp val_env sexp with Ctype.Unify [(ty, _)] -> @@ -457,17 +488,19 @@ Ctype.end_def (); Ctype.generalize_structure exp.exp_type end; - let (id, val_env, met_env, par_env) = - enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env - in - (val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields, - concr_meths, warn_meths, inh_vals, inher) + let (id, val_env, met_env', par_env) = + enter_val cl_num vars false lab mut Concrete exp.exp_type + val_env met_env par_env loc + in + (val_env, met_env', par_env, + lazy(Cf_val (lab, id, Some exp, met_env' == met_env)) :: fields, + concr_meths, warn_meths, StringSet.add lab warn_vals, inher) | Pcf_virt (lab, priv, sty, loc) -> virtual_method val_env meths self_type lab priv sty loc; let warn_meths = Concr.remove lab warn_meths in (val_env, met_env, par_env, fields, concr_meths, warn_meths, - inh_vals, inher) + warn_vals, inher) | Pcf_meth (lab, priv, expr, loc) -> let (_, ty) = @@ -493,7 +526,7 @@ end | _ -> assert false with Ctype.Unify trace -> - raise(Error(loc, Method_type_mismatch (lab, trace))) + raise(Error(loc, Field_type_mismatch ("method", lab, trace))) end; let meth_expr = make_method cl_num expr in (* backup variables for Pexp_override *) @@ -510,12 +543,12 @@ Cf_meth (lab, texp) end in (val_env, met_env, par_env, field::fields, - Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals, inher) + Concr.add lab concr_meths, Concr.add lab warn_meths, warn_vals, inher) | Pcf_cstr (sty, sty', loc) -> type_constraint val_env sty sty' loc; (val_env, met_env, par_env, fields, concr_meths, warn_meths, - inh_vals, inher) + warn_vals, inher) | Pcf_let (rec_flag, sdefs, loc) -> let (defs, val_env) = @@ -545,7 +578,7 @@ ([], met_env, par_env) in (val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields, - concr_meths, warn_meths, inh_vals, inher) + concr_meths, warn_meths, warn_vals, inher) | Pcf_init expr -> let expr = make_method cl_num expr in @@ -562,7 +595,7 @@ Cf_init texp end in (val_env, met_env, par_env, field::fields, - concr_meths, warn_meths, inh_vals, inher) + concr_meths, warn_meths, warn_vals, inher) and class_structure cl_num final val_env met_env loc (spat, str) = (* Environment for substructures *) @@ -616,7 +649,7 @@ Ctype.unify val_env self_type (Ctype.newvar ()); let sign = {cty_self = public_self; - cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars; + cty_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars; cty_concr = concr_meths; cty_inher = inher} in let methods = get_methods self_type in @@ -628,7 +661,11 @@ be modified after this point *) Ctype.close_object self_type; let mets = virtual_methods {sign with cty_self = self_type} in - if mets <> [] then raise(Error(loc, Virtual_class(true, mets))); + let vals = + Vars.fold + (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) + sign.cty_vars [] in + if mets <> [] then raise(Error(loc, Virtual_class(true, mets, vals))); let self_methods = List.fold_right (fun (lab,kind,ty) rem -> @@ -1135,9 +1172,14 @@ in if cl.pci_virt = Concrete then begin - match virtual_methods (Ctype.signature_of_class_type typ) with - [] -> () - | mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets))) + let sign = Ctype.signature_of_class_type typ in + let mets = virtual_methods sign in + let vals = + Vars.fold + (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) + sign.cty_vars [] in + if mets <> [] || vals <> [] then + raise(Error(cl.pci_loc, Virtual_class(true, mets, vals))); end; (* Misc. *) @@ -1400,10 +1442,10 @@ Printtyp.report_unification_error ppf trace (fun ppf -> fprintf ppf "Type") (fun ppf -> fprintf ppf "is not compatible with type") - | Method_type_mismatch (m, trace) -> + | Field_type_mismatch (k, m, trace) -> Printtyp.report_unification_error ppf trace (function ppf -> - fprintf ppf "The method %s@ has type" m) + fprintf ppf "The %s %s@ has type" k m) (function ppf -> fprintf ppf "but is expected to have type") | Structure_expected clty -> @@ -1451,15 +1493,20 @@ fprintf ppf "The expression \"new %s\" has type" c) (function ppf -> fprintf ppf "but is used with type") - | Virtual_class (cl, mets) -> + | Virtual_class (cl, mets, vals) -> let print_mets ppf mets = List.iter (function met -> fprintf ppf "@ %s" met) mets in let cl_mark = if cl then "" else " type" in + let missings = + match mets, vals with + [], _ -> "variables" + | _, [] -> "methods" + | _ -> "methods and variables" + in fprintf ppf - "@[This class%s should be virtual@ \ - @[<2>The following methods are undefined :%a@] - @]" - cl_mark print_mets mets + "@[This class%s should be virtual.@ \ + @[<2>The following %s are undefined :%a@]@]" + cl_mark missings print_mets (mets @ vals) | Parameter_arity_mismatch(lid, expected, provided) -> fprintf ppf "@[The class constructor %a@ expects %i type argument(s),@ \ @@ -1532,3 +1579,10 @@ fprintf ppf "This object is expected to have type") (function ppf -> fprintf ppf "but has actually type") + | Mutability_mismatch (lab, mut) -> + let mut1, mut2 = + if mut = Immutable then "mutable", "immutable" + else "immutable", "mutable" in + fprintf ppf + "@[The instance variable is %s,@ it cannot be redefined as %s@]" + mut1 mut2 Index: typing/typeclass.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.mli,v retrieving revision 1.18 diff -u -r1.18 typeclass.mli --- typing/typeclass.mli 1 Dec 2003 00:32:11 -0000 1.18 +++ typing/typeclass.mli 5 Apr 2006 02:26:00 -0000 @@ -49,7 +49,7 @@ type error = Unconsistent_constraint of (type_expr * type_expr) list - | Method_type_mismatch of string * (type_expr * type_expr) list + | Field_type_mismatch of string * string * (type_expr * type_expr) list | Structure_expected of class_type | Cannot_apply of class_type | Apply_wrong_label of label @@ -61,7 +61,7 @@ | Unbound_class_type_2 of Longident.t | Abbrev_type_clash of type_expr * type_expr * type_expr | Constructor_type_mismatch of string * (type_expr * type_expr) list - | Virtual_class of bool * string list + | Virtual_class of bool * string list * string list | Parameter_arity_mismatch of Longident.t * int * int | Parameter_mismatch of (type_expr * type_expr) list | Bad_parameters of Ident.t * type_expr * type_expr @@ -74,6 +74,7 @@ | Non_collapsable_conjunction of Ident.t * Types.class_declaration * (type_expr * type_expr) list | Final_self_clash of (type_expr * type_expr) list + | Mutability_mismatch of string * mutable_flag exception Error of Location.t * error Index: typing/typecore.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v retrieving revision 1.178 diff -u -r1.178 typecore.ml --- typing/typecore.ml 6 Jan 2006 02:25:37 -0000 1.178 +++ typing/typecore.ml 5 Apr 2006 02:26:00 -0000 @@ -611,11 +611,11 @@ List.for_all (function Cf_meth _ -> true - | Cf_val (_,_,e) -> incr count; is_nonexpansive e + | Cf_val (_,_,e,_) -> incr count; is_nonexpansive_opt e | Cf_init e -> is_nonexpansive e | Cf_inher _ | Cf_let _ -> false) fields && - Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable) + Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable) vars true && !count = 0 | _ -> false @@ -1356,7 +1356,7 @@ (path_self, _) -> let type_override (lab, snewval) = begin try - let (id, _, ty) = Vars.find lab !vars in + let (id, _, _, ty) = Vars.find lab !vars in (Path.Pident id, type_expect env snewval (instance ty)) with Not_found -> Index: typing/typecore.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.mli,v retrieving revision 1.37 diff -u -r1.37 typecore.mli --- typing/typecore.mli 4 Mar 2005 14:51:31 -0000 1.37 +++ typing/typecore.mli 5 Apr 2006 02:26:00 -0000 @@ -38,7 +38,8 @@ string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern -> Typedtree.pattern * (Ident.t * type_expr) Meths.t ref * - (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref * + (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) + Vars.t ref * Env.t * Env.t * Env.t val type_expect: ?in_function:(Location.t * type_expr) -> Index: typing/typedtree.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.ml,v retrieving revision 1.36 diff -u -r1.36 typedtree.ml --- typing/typedtree.ml 25 Nov 2003 09:20:43 -0000 1.36 +++ typing/typedtree.ml 5 Apr 2006 02:26:00 -0000 @@ -106,7 +106,7 @@ and class_field = Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list - | Cf_val of string * Ident.t * expression + | Cf_val of string * Ident.t * expression option * bool | Cf_meth of string * expression | Cf_let of rec_flag * (pattern * expression) list * (Ident.t * expression) list @@ -140,7 +140,8 @@ | Tstr_recmodule of (Ident.t * module_expr) list | Tstr_modtype of Ident.t * module_type | Tstr_open of Path.t - | Tstr_class of (Ident.t * int * string list * class_expr) list + | Tstr_class of + (Ident.t * int * string list * class_expr * virtual_flag) list | Tstr_cltype of (Ident.t * cltype_declaration) list | Tstr_include of module_expr * Ident.t list Index: typing/typedtree.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.mli,v retrieving revision 1.34 diff -u -r1.34 typedtree.mli --- typing/typedtree.mli 25 Nov 2003 09:20:43 -0000 1.34 +++ typing/typedtree.mli 5 Apr 2006 02:26:00 -0000 @@ -107,7 +107,8 @@ and class_field = Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list (* Inherited instance variables and concrete methods *) - | Cf_val of string * Ident.t * expression + | Cf_val of string * Ident.t * expression option * bool + (* None = virtual, true = override *) | Cf_meth of string * expression | Cf_let of rec_flag * (pattern * expression) list * (Ident.t * expression) list @@ -141,7 +142,8 @@ | Tstr_recmodule of (Ident.t * module_expr) list | Tstr_modtype of Ident.t * module_type | Tstr_open of Path.t - | Tstr_class of (Ident.t * int * string list * class_expr) list + | Tstr_class of + (Ident.t * int * string list * class_expr * virtual_flag) list | Tstr_cltype of (Ident.t * cltype_declaration) list | Tstr_include of module_expr * Ident.t list Index: typing/typemod.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/typemod.ml,v retrieving revision 1.73 diff -u -r1.73 typemod.ml --- typing/typemod.ml 8 Aug 2005 09:41:51 -0000 1.73 +++ typing/typemod.ml 5 Apr 2006 02:26:00 -0000 @@ -17,6 +17,7 @@ open Misc open Longident open Path +open Asttypes open Parsetree open Types open Typedtree @@ -667,8 +668,9 @@ let (classes, new_env) = Typeclass.class_declarations env cl in let (str_rem, sig_rem, final_env) = type_struct new_env srem in (Tstr_class - (List.map (fun (i, _,_,_,_,_,_,_, s, m, c) -> - (i, s, m, c)) classes) :: + (List.map (fun (i, d, _,_,_,_,_,_, s, m, c) -> + let vf = if d.cty_new = None then Virtual else Concrete in + (i, s, m, c, vf)) classes) :: Tstr_cltype (List.map (fun (_,_, i, d, _,_,_,_,_,_,_) -> (i, d)) classes) :: Tstr_type Index: typing/types.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v retrieving revision 1.25 diff -u -r1.25 types.ml --- typing/types.ml 9 Dec 2004 12:40:53 -0000 1.25 +++ typing/types.ml 5 Apr 2006 02:26:00 -0000 @@ -90,7 +90,8 @@ | Val_prim of Primitive.description (* Primitive *) | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) | Val_self of (Ident.t * type_expr) Meths.t ref * - (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref * + (Ident.t * Asttypes.mutable_flag * + Asttypes.virtual_flag * type_expr) Vars.t ref * string * type_expr (* Self *) | Val_anc of (string * Ident.t) list * string @@ -156,7 +157,8 @@ and class_signature = { cty_self: type_expr; - cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t; + cty_vars: + (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; cty_concr: Concr.t; cty_inher: (Path.t * type_expr list) list } Index: typing/types.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v retrieving revision 1.25 diff -u -r1.25 types.mli --- typing/types.mli 9 Dec 2004 12:40:53 -0000 1.25 +++ typing/types.mli 5 Apr 2006 02:26:00 -0000 @@ -91,7 +91,8 @@ | Val_prim of Primitive.description (* Primitive *) | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) | Val_self of (Ident.t * type_expr) Meths.t ref * - (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref * + (Ident.t * Asttypes.mutable_flag * + Asttypes.virtual_flag * type_expr) Vars.t ref * string * type_expr (* Self *) | Val_anc of (string * Ident.t) list * string @@ -158,7 +159,8 @@ and class_signature = { cty_self: type_expr; - cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t; + cty_vars: + (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; cty_concr: Concr.t; cty_inher: (Path.t * type_expr list) list } Index: typing/unused_var.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v retrieving revision 1.5 diff -u -r1.5 unused_var.ml --- typing/unused_var.ml 4 Jan 2006 16:55:50 -0000 1.5 +++ typing/unused_var.ml 5 Apr 2006 02:26:00 -0000 @@ -245,7 +245,7 @@ match cf with | Pcf_inher (ce, _) -> class_expr ppf tbl ce; | Pcf_val (_, _, e, _) -> expression ppf tbl e; - | Pcf_virt _ -> () + | Pcf_virt _ | Pcf_valvirt _ -> () | Pcf_meth (_, _, e, _) -> expression ppf tbl e; | Pcf_cstr _ -> () | Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None; Index: bytecomp/translclass.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v retrieving revision 1.38 diff -u -r1.38 translclass.ml --- bytecomp/translclass.ml 13 Aug 2005 20:59:37 -0000 1.38 +++ bytecomp/translclass.ml 5 Apr 2006 02:26:00 -0000 @@ -133,10 +133,10 @@ (fun _ -> lambda_unit) cl in (inh_init, lsequence obj_init' obj_init, true) - | Cf_val (_, id, exp) -> + | Cf_val (_, id, Some exp, _) -> (inh_init, lsequence (set_inst_var obj id exp) obj_init, has_init) - | Cf_meth _ -> + | Cf_meth _ | Cf_val _ -> (inh_init, obj_init, has_init) | Cf_init _ -> (inh_init, obj_init, true) @@ -213,27 +213,17 @@ if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else let ids = Ident.create "ids" in - let i = ref len in - let getter, names, cl_init = - match vals with [] -> "get_method_labels", [], cl_init - | (_,id0)::vals' -> - incr i; - let i = ref (List.length vals) in - "new_methods_variables", - [transl_meth_list (List.map fst vals)], - Llet(Strict, id0, lfield ids 0, - List.fold_right - (fun (name,id) rem -> - decr i; - Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem)) - vals' cl_init) + let i = ref (len + nvals) in + let getter, names = + if nvals = 0 then "get_method_labels", [] else + "new_methods_variables", [transl_meth_list (List.map fst vals)] in Llet(StrictOpt, ids, Lapply (oo_prim getter, [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), List.fold_right (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam)) - methl cl_init) + (methl @ vals) cl_init) let output_methods tbl methods lam = match methods with @@ -283,8 +273,9 @@ (vals, meths_super cla str.cl_meths meths) inh_init cl_init msubst top cl in (inh_init, cl_init, [], values) - | Cf_val (name, id, exp) -> - (inh_init, cl_init, methods, (name, id)::values) + | Cf_val (name, id, exp, over) -> + let values = if over then values else (name, id) :: values in + (inh_init, cl_init, methods, values) | Cf_meth (name, exp) -> let met_code = msubst true (transl_exp exp) in let met_code = @@ -342,27 +333,24 @@ assert (Path.same path path'); let lpath = transl_path path in let inh = Ident.create "inh" - and inh_vals = Ident.create "vals" - and inh_meths = Ident.create "meths" + and ofs = List.length vals + 1 and valids, methids = super in let cl_init = List.fold_left (fun init (nm, id, _) -> - Llet(StrictOpt, id, lfield inh_meths (index nm concr_meths), + Llet(StrictOpt, id, lfield inh (index nm concr_meths + ofs), init)) cl_init methids in let cl_init = List.fold_left (fun init (nm, id) -> - Llet(StrictOpt, id, lfield inh_vals (index nm vals), init)) + Llet(StrictOpt, id, lfield inh (index nm vals + 1), init)) cl_init valids in (inh_init, Llet (Strict, inh, Lapply(oo_prim "inherits", narrow_args @ [lpath; Lconst(Const_pointer(if top then 1 else 0))]), - Llet(StrictOpt, obj_init, lfield inh 0, - Llet(Alias, inh_vals, lfield inh 1, - Llet(Alias, inh_meths, lfield inh 2, cl_init))))) + Llet(StrictOpt, obj_init, lfield inh 0, cl_init))) | _ -> let core cl_init = build_class_init cla true super inh_init cl_init msubst top cl @@ -397,12 +385,16 @@ XXX Il devrait etre peu couteux d'ecrire des classes : class c x y = d e f *) -let rec transl_class_rebind obj_init cl = +let rec transl_class_rebind obj_init cl vf = match cl.cl_desc with Tclass_ident path -> + if vf = Concrete then begin + try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit + with Not_found -> raise Exit + end; (path, obj_init) | Tclass_fun (pat, _, cl, partial) -> - let path, obj_init = transl_class_rebind obj_init cl in + let path, obj_init = transl_class_rebind obj_init cl vf in let build params rem = let param = name_pattern "param" [pat, ()] in Lfunction (Curried, param::params, @@ -414,14 +406,14 @@ Lfunction (Curried, params, rem) -> build params rem | rem -> build [] rem) | Tclass_apply (cl, oexprs) -> - let path, obj_init = transl_class_rebind obj_init cl in + let path, obj_init = transl_class_rebind obj_init cl vf in (path, transl_apply obj_init oexprs) | Tclass_let (rec_flag, defs, vals, cl) -> - let path, obj_init = transl_class_rebind obj_init cl in + let path, obj_init = transl_class_rebind obj_init cl vf in (path, Translcore.transl_let rec_flag defs obj_init) | Tclass_structure _ -> raise Exit | Tclass_constraint (cl', _, _, _) -> - let path, obj_init = transl_class_rebind obj_init cl' in + let path, obj_init = transl_class_rebind obj_init cl' vf in let rec check_constraint = function Tcty_constr(path', _, _) when Path.same path path' -> () | Tcty_fun (_, _, cty) -> check_constraint cty @@ -430,21 +422,21 @@ check_constraint cl.cl_type; (path, obj_init) -let rec transl_class_rebind_0 self obj_init cl = +let rec transl_class_rebind_0 self obj_init cl vf = match cl.cl_desc with Tclass_let (rec_flag, defs, vals, cl) -> - let path, obj_init = transl_class_rebind_0 self obj_init cl in + let path, obj_init = transl_class_rebind_0 self obj_init cl vf in (path, Translcore.transl_let rec_flag defs obj_init) | _ -> - let path, obj_init = transl_class_rebind obj_init cl in + let path, obj_init = transl_class_rebind obj_init cl vf in (path, lfunction [self] obj_init) -let transl_class_rebind ids cl = +let transl_class_rebind ids cl vf = try let obj_init = Ident.create "obj_init" and self = Ident.create "self" in let obj_init0 = lapply (Lvar obj_init) [Lvar self] in - let path, obj_init' = transl_class_rebind_0 self obj_init0 cl in + let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in if not (Translcore.check_recursive_lambda ids obj_init') then raise(Error(cl.cl_loc, Illegal_class_expr)); let id = (obj_init' = lfunction [self] obj_init0) in @@ -592,9 +584,9 @@ *) -let transl_class ids cl_id arity pub_meths cl = +let transl_class ids cl_id arity pub_meths cl vflag = (* First check if it is not only a rebind *) - let rebind = transl_class_rebind ids cl in + let rebind = transl_class_rebind ids cl vflag in if rebind <> lambda_unit then rebind else (* Prepare for heavy environment handling *) @@ -696,9 +688,7 @@ (* Simplest case: an object defined at toplevel (ids=[]) *) if top && ids = [] then llets (ltable cla (ldirect obj_init)) else - let concrete = - ids = [] || - Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = [] + let concrete = (vflag = Concrete) and lclass lam = let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in Llet(Strict, class_init, cl_init, lam (free_variables cl_init)) @@ -800,11 +790,11 @@ (* Wrapper for class compilation *) -let transl_class ids cl_id arity pub_meths cl = - oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl +let transl_class ids cl_id arity pub_meths cl vf = + oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths cl) vf let () = - transl_object := (fun id meths cl -> transl_class [] id 0 meths cl) + transl_object := (fun id meths cl -> transl_class [] id 0 meths cl Concrete) (* Error report *) Index: bytecomp/translclass.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.mli,v retrieving revision 1.11 diff -u -r1.11 translclass.mli --- bytecomp/translclass.mli 12 Aug 2004 12:55:11 -0000 1.11 +++ bytecomp/translclass.mli 5 Apr 2006 02:26:00 -0000 @@ -16,7 +16,8 @@ open Lambda val transl_class : - Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;; + Ident.t list -> Ident.t -> + int -> string list -> class_expr -> Asttypes.virtual_flag -> lambda;; type error = Illegal_class_expr | Tags of string * string Index: bytecomp/translmod.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translmod.ml,v retrieving revision 1.51 diff -u -r1.51 translmod.ml --- bytecomp/translmod.ml 12 Aug 2004 12:55:11 -0000 1.51 +++ bytecomp/translmod.ml 5 Apr 2006 02:26:00 -0000 @@ -317,10 +317,10 @@ | Tstr_open path :: rem -> transl_structure fields cc rootpath rem | Tstr_class cl_list :: rem -> - let ids = List.map (fun (i, _, _, _) -> i) cl_list in + let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in Lletrec(List.map - (fun (id, arity, meths, cl) -> - (id, transl_class ids id arity meths cl)) + (fun (id, arity, meths, cl, vf) -> + (id, transl_class ids id arity meths cl vf)) cl_list, transl_structure (List.rev ids @ fields) cc rootpath rem) | Tstr_cltype cl_list :: rem -> @@ -414,11 +414,11 @@ | Tstr_open path :: rem -> transl_store subst rem | Tstr_class cl_list :: rem -> - let ids = List.map (fun (i, _, _, _) -> i) cl_list in + let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in let lam = Lletrec(List.map - (fun (id, arity, meths, cl) -> - (id, transl_class ids id arity meths cl)) + (fun (id, arity, meths, cl, vf) -> + (id, transl_class ids id arity meths cl vf)) cl_list, store_idents ids) in Lsequence(subst_lambda subst lam, @@ -485,7 +485,7 @@ | Tstr_modtype(id, decl) :: rem -> defined_idents rem | Tstr_open path :: rem -> defined_idents rem | Tstr_class cl_list :: rem -> - List.map (fun (i, _, _, _) -> i) cl_list @ defined_idents rem + List.map (fun (i, _, _, _, _) -> i) cl_list @ defined_idents rem | Tstr_cltype cl_list :: rem -> defined_idents rem | Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem @@ -603,14 +603,14 @@ | Tstr_class cl_list -> (* we need to use unique names for the classes because there might be a value named identically *) - let ids = List.map (fun (i, _, _, _) -> i) cl_list in + let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in List.iter set_toplevel_unique_name ids; Lletrec(List.map - (fun (id, arity, meths, cl) -> - (id, transl_class ids id arity meths cl)) + (fun (id, arity, meths, cl, vf) -> + (id, transl_class ids id arity meths cl vf)) cl_list, make_sequence - (fun (id, _, _, _) -> toploop_setvalue_id id) + (fun (id, _, _, _, _) -> toploop_setvalue_id id) cl_list) | Tstr_cltype cl_list -> lambda_unit Index: driver/main_args.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/driver/main_args.ml,v retrieving revision 1.48 diff -u -r1.48 main_args.ml --- driver/main_args.ml 4 Jan 2006 16:55:49 -0000 1.48 +++ driver/main_args.ml 5 Apr 2006 02:26:00 -0000 @@ -136,11 +136,11 @@ \032 E/e enable/disable fragile match\n\ \032 F/f enable/disable partially applied function\n\ \032 L/l enable/disable labels omitted in application\n\ - \032 M/m enable/disable overridden method\n\ + \032 M/m enable/disable overridden methods\n\ \032 P/p enable/disable partial match\n\ \032 S/s enable/disable non-unit statement\n\ \032 U/u enable/disable unused match case\n\ - \032 V/v enable/disable hidden instance variable\n\ + \032 V/v enable/disable overridden instance variables\n\ \032 Y/y enable/disable suspicious unused variables\n\ \032 Z/z enable/disable all other unused variables\n\ \032 X/x enable/disable all other warnings\n\ Index: driver/optmain.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/driver/optmain.ml,v retrieving revision 1.87 diff -u -r1.87 optmain.ml --- driver/optmain.ml 4 Jan 2006 16:55:49 -0000 1.87 +++ driver/optmain.ml 5 Apr 2006 02:26:00 -0000 @@ -173,7 +173,7 @@ \032 P/p enable/disable partial match\n\ \032 S/s enable/disable non-unit statement\n\ \032 U/u enable/disable unused match case\n\ - \032 V/v enable/disable hidden instance variables\n\ + \032 V/v enable/disable overridden instance variables\n\ \032 Y/y enable/disable suspicious unused variables\n\ \032 Z/z enable/disable all other unused variables\n\ \032 X/x enable/disable all other warnings\n\ Index: stdlib/camlinternalOO.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v retrieving revision 1.14 diff -u -r1.14 camlinternalOO.ml --- stdlib/camlinternalOO.ml 25 Oct 2005 18:34:07 -0000 1.14 +++ stdlib/camlinternalOO.ml 5 Apr 2006 02:26:00 -0000 @@ -206,7 +206,11 @@ (table.methods_by_name, table.methods_by_label, table.hidden_meths, table.vars, virt_meth_labs, vars) :: table.previous_states; - table.vars <- Vars.empty; + table.vars <- + Vars.fold + (fun lab info tvars -> + if List.mem lab vars then Vars.add lab info tvars else tvars) + table.vars Vars.empty; let by_name = ref Meths.empty in let by_label = ref Labs.empty in List.iter2 @@ -255,9 +259,11 @@ index let new_variable table name = - let index = new_slot table in - table.vars <- Vars.add name index table.vars; - index + try Vars.find name table.vars + with Not_found -> + let index = new_slot table in + table.vars <- Vars.add name index table.vars; + index let to_array arr = if arr = Obj.magic 0 then [||] else arr @@ -265,16 +271,17 @@ let new_methods_variables table meths vals = let meths = to_array meths in let nmeths = Array.length meths and nvals = Array.length vals in - let index = new_variable table vals.(0) in - let res = Array.create (nmeths + 1) index in - for i = 1 to nvals - 1 do ignore (new_variable table vals.(i)) done; + let res = Array.create (nmeths + nvals) 0 in for i = 0 to nmeths - 1 do - res.(i+1) <- get_method_label table meths.(i) + res.(i) <- get_method_label table meths.(i) + done; + for i = 0 to nvals - 1 do + res.(i+nmeths) <- new_variable table vals.(i) done; res let get_variable table name = - Vars.find name table.vars + try Vars.find name table.vars with Not_found -> assert false let get_variables table names = Array.map (get_variable table) names @@ -315,9 +322,12 @@ let init = if top then super cla env else Obj.repr (super cla) in widen cla; - (init, Array.map (get_variable cla) (to_array vals), - Array.map (fun nm -> get_method cla (get_method_label cla nm)) - (to_array concr_meths)) + Array.concat + [[| repr init |]; + magic (Array.map (get_variable cla) (to_array vals) : int array); + Array.map + (fun nm -> repr (get_method cla (get_method_label cla nm) : closure)) + (to_array concr_meths) ] let make_class pub_meths class_init = let table = create_table pub_meths in Index: stdlib/camlinternalOO.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v retrieving revision 1.9 diff -u -r1.9 camlinternalOO.mli --- stdlib/camlinternalOO.mli 25 Oct 2005 18:34:07 -0000 1.9 +++ stdlib/camlinternalOO.mli 5 Apr 2006 02:26:00 -0000 @@ -46,8 +46,7 @@ val init_class : table -> unit val inherits : table -> string array -> string array -> string array -> - (t * (table -> obj -> Obj.t) * t * obj) -> bool -> - (Obj.t * int array * closure array) + (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t array val make_class : string array -> (table -> Obj.t -> t) -> (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t) @@ -79,6 +78,7 @@ (** {6 Builtins to reduce code size} *) +(* val get_const : t -> closure val get_var : int -> closure val get_env : int -> int -> closure @@ -103,6 +103,7 @@ val send_var : tag -> int -> int -> closure val send_env : tag -> int -> int -> int -> closure val send_meth : tag -> label -> int -> closure +*) type impl = GetConst Index: stdlib/sys.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/stdlib/sys.ml,v retrieving revision 1.142 diff -u -r1.142 sys.ml --- stdlib/sys.ml 22 Mar 2006 12:39:39 -0000 1.142 +++ stdlib/sys.ml 5 Apr 2006 02:26:00 -0000 @@ -78,4 +78,4 @@ (* OCaml version string, must be in the format described in sys.mli. *) -let ocaml_version = "3.10+dev4 (2006-03-22)";; +let ocaml_version = "3.10+dev5 (2006-04-05)";; Index: tools/depend.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/tools/depend.ml,v retrieving revision 1.9 diff -u -r1.9 depend.ml --- tools/depend.ml 23 Mar 2005 03:08:37 -0000 1.9 +++ tools/depend.ml 5 Apr 2006 02:26:00 -0000 @@ -87,7 +87,7 @@ and add_class_type_field bv = function Pctf_inher cty -> add_class_type bv cty - | Pctf_val(_, _, oty, _) -> add_opt add_type bv oty + | Pctf_val(_, _, _, ty, _) -> add_type bv ty | Pctf_virt(_, _, ty, _) -> add_type bv ty | Pctf_meth(_, _, ty, _) -> add_type bv ty | Pctf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2 @@ -280,6 +280,7 @@ and add_class_field bv = function Pcf_inher(ce, _) -> add_class_expr bv ce | Pcf_val(_, _, e, _) -> add_expr bv e + | Pcf_valvirt(_, _, ty, _) | Pcf_virt(_, _, ty, _) -> add_type bv ty | Pcf_meth(_, _, e, _) -> add_expr bv e | Pcf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2 Index: tools/ocamlprof.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/tools/ocamlprof.ml,v retrieving revision 1.38 diff -u -r1.38 ocamlprof.ml --- tools/ocamlprof.ml 24 Mar 2005 17:20:54 -0000 1.38 +++ tools/ocamlprof.ml 5 Apr 2006 02:26:00 -0000 @@ -328,7 +328,7 @@ rewrite_patexp_list iflag spat_sexp_list | Pcf_init sexp -> rewrite_exp iflag sexp - | Pcf_virt _ | Pcf_cstr _ -> () + | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> () and rewrite_class_expr iflag cexpr = match cexpr.pcl_desc with Index: otherlibs/labltk/browser/searchpos.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/otherlibs/labltk/browser/searchpos.ml,v retrieving revision 1.48 diff -u -r1.48 searchpos.ml --- otherlibs/labltk/browser/searchpos.ml 23 Mar 2005 03:08:37 -0000 1.48 +++ otherlibs/labltk/browser/searchpos.ml 5 Apr 2006 02:26:01 -0000 @@ -141,9 +141,8 @@ List.iter cfl ~f: begin function Pctf_inher cty -> search_pos_class_type cty ~pos ~env - | Pctf_val (_, _, Some ty, loc) -> + | Pctf_val (_, _, _, ty, loc) -> if in_loc loc ~pos then search_pos_type ty ~pos ~env - | Pctf_val _ -> () | Pctf_virt (_, _, ty, loc) -> if in_loc loc ~pos then search_pos_type ty ~pos ~env | Pctf_meth (_, _, ty, loc) -> @@ -675,7 +674,7 @@ | Tstr_modtype _ -> () | Tstr_open _ -> () | Tstr_class l -> - List.iter l ~f:(fun (id, _, _, cl) -> search_pos_class_expr cl ~pos) + List.iter l ~f:(fun (id, _, _, cl, _) -> search_pos_class_expr cl ~pos) | Tstr_cltype _ -> () | Tstr_include (m, _) -> search_pos_module_expr m ~pos end @@ -685,7 +684,8 @@ begin function Cf_inher (cl, _, _) -> search_pos_class_expr cl ~pos - | Cf_val (_, _, exp) -> search_pos_expr exp ~pos + | Cf_val (_, _, Some exp, _) -> search_pos_expr exp ~pos + | Cf_val _ -> () | Cf_meth (_, exp) -> search_pos_expr exp ~pos | Cf_let (_, pel, iel) -> List.iter pel ~f: Index: ocamldoc/Makefile =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/Makefile,v retrieving revision 1.61 diff -u -r1.61 Makefile --- ocamldoc/Makefile 4 Jan 2006 16:55:49 -0000 1.61 +++ ocamldoc/Makefile 5 Apr 2006 02:26:01 -0000 @@ -31,7 +31,7 @@ MKDIR=mkdir -p CP=cp -f OCAMLDOC=ocamldoc -OCAMLDOC_RUN=sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES) +OCAMLDOC_RUN=./ocamldoc.opt #sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES) OCAMLDOC_OPT=$(OCAMLDOC).opt OCAMLDOC_LIBCMA=odoc_info.cma OCAMLDOC_LIBCMI=odoc_info.cmi @@ -188,12 +188,12 @@ ../otherlibs/num/num.mli all: exe lib - $(MAKE) manpages exe: $(OCAMLDOC) lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST) opt.opt: exeopt libopt + $(MAKE) manpages exeopt: $(OCAMLDOC_OPT) libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) debug: Index: ocamldoc/odoc_ast.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_ast.ml,v retrieving revision 1.27 diff -u -r1.27 odoc_ast.ml --- ocamldoc/odoc_ast.ml 4 Jan 2006 16:55:49 -0000 1.27 +++ ocamldoc/odoc_ast.ml 5 Apr 2006 02:26:01 -0000 @@ -88,7 +88,7 @@ ident_type_decl_list | Typedtree.Tstr_class info_list -> List.iter - (fun ((id,_,_,_) as ci) -> + (fun ((id,_,_,_,_) as ci) -> Hashtbl.add table (C (Name.from_ident id)) (Typedtree.Tstr_class [ci])) info_list @@ -146,7 +146,7 @@ let search_class_exp table name = match Hashtbl.find table (C name) with - | (Typedtree.Tstr_class [(_,_,_,ce)]) -> + | (Typedtree.Tstr_class [(_,_,_,ce,_)]) -> ( try let type_decl = search_type_declaration table name in @@ -184,7 +184,7 @@ let rec iter = function | [] -> raise Not_found - | Typedtree.Cf_val (_, ident, exp) :: q + | Typedtree.Cf_val (_, ident, Some exp, _) :: q when Name.from_ident ident = name -> exp.Typedtree.exp_type | _ :: q -> @@ -523,7 +523,8 @@ p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum q - | (Parsetree.Pcf_val (label, mutable_flag, expression, loc)) :: q -> + | (Parsetree.Pcf_val (label, mutable_flag, _, loc) | + Parsetree.Pcf_valvirt (label, mutable_flag, _, loc)) :: q -> let complete_name = Name.concat current_class_name label in let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let type_exp = Index: ocamldoc/odoc_sig.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_sig.ml,v retrieving revision 1.37 diff -u -r1.37 odoc_sig.ml --- ocamldoc/odoc_sig.ml 4 Jan 2006 16:55:50 -0000 1.37 +++ ocamldoc/odoc_sig.ml 5 Apr 2006 02:26:01 -0000 @@ -107,7 +107,7 @@ | _ -> assert false let search_attribute_type name class_sig = - let (_, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in + let (_, _, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in type_expr let search_method_type name class_sig = @@ -269,7 +269,7 @@ [] -> pos_limit | ele2 :: _ -> match ele2 with - Parsetree.Pctf_val (_, _, _, loc) + Parsetree.Pctf_val (_, _, _, _, loc) | Parsetree.Pctf_virt (_, _, _, loc) | Parsetree.Pctf_meth (_, _, _, loc) | Parsetree.Pctf_cstr (_, _, loc) -> loc.Location.loc_start.Lexing.pos_cnum @@ -330,7 +330,7 @@ in ([], ele_comments) - | Parsetree.Pctf_val (name, mutable_flag, _, loc) :: q -> + | Parsetree.Pctf_val (name, mutable_flag, _, _, loc) :: q -> (* of (string * mutable_flag * core_type option * Location.t)*) let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let complete_name = Name.concat current_class_name name in Index: camlp4/camlp4/ast2pt.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/ast2pt.ml,v retrieving revision 1.36 diff -u -r1.36 ast2pt.ml --- camlp4/camlp4/ast2pt.ml 29 Jun 2005 04:11:26 -0000 1.36 +++ camlp4/camlp4/ast2pt.ml 5 Apr 2006 02:26:01 -0000 @@ -244,6 +244,7 @@ ; value mkmutable m = if m then Mutable else Immutable; value mkprivate m = if m then Private else Public; +value mkvirtual m = if m then Virtual else Concrete; value mktrecord (loc, n, m, t) = (n, mkmutable m, ctyp (mkpolytype t), mkloc loc); value mkvariant (loc, c, tl) = (c, List.map ctyp tl, mkloc loc); @@ -862,8 +863,8 @@ | CgInh loc ct -> [Pctf_inher (class_type ct) :: l] | CgMth loc s pf t -> [Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l] - | CgVal loc s b t -> - [Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l] + | CgVal loc s b v t -> + [Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l] | CgVir loc s b t -> [Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ] and class_expr = @@ -907,7 +908,9 @@ [Pcf_meth (s, mkprivate b, e, mkloc loc) :: l] | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l] | CrVir loc s b t -> - [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ] + [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] + | CrVvr loc s b t -> + [Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l] ] ; value interf ast = List.fold_right sig_item ast []; Index: camlp4/camlp4/mLast.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/mLast.mli,v retrieving revision 1.18 diff -u -r1.18 mLast.mli --- camlp4/camlp4/mLast.mli 29 Jun 2005 04:11:26 -0000 1.18 +++ camlp4/camlp4/mLast.mli 5 Apr 2006 02:26:01 -0000 @@ -180,7 +180,7 @@ | CgDcl of loc and list class_sig_item | CgInh of loc and class_type | CgMth of loc and string and bool and ctyp - | CgVal of loc and string and bool and ctyp + | CgVal of loc and string and bool and bool and ctyp | CgVir of loc and string and bool and ctyp ] and class_expr = [ CeApp of loc and class_expr and expr @@ -196,7 +196,8 @@ | CrIni of loc and expr | CrMth of loc and string and bool and expr and option ctyp | CrVal of loc and string and bool and expr - | CrVir of loc and string and bool and ctyp ] + | CrVir of loc and string and bool and ctyp + | CrVvr of loc and string and bool and ctyp ] ; external loc_of_ctyp : ctyp -> loc = "%field0"; Index: camlp4/camlp4/reloc.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/reloc.ml,v retrieving revision 1.18 diff -u -r1.18 reloc.ml --- camlp4/camlp4/reloc.ml 29 Jun 2005 04:11:26 -0000 1.18 +++ camlp4/camlp4/reloc.ml 5 Apr 2006 02:26:01 -0000 @@ -350,7 +350,7 @@ | CgDcl loc x1 -> let nloc = floc loc in CgDcl nloc (List.map (class_sig_item floc sh) x1) | CgInh loc x1 -> let nloc = floc loc in CgInh nloc (class_type floc sh x1) | CgMth loc x1 x2 x3 -> let nloc = floc loc in CgMth nloc x1 x2 (ctyp floc sh x3) - | CgVal loc x1 x2 x3 -> let nloc = floc loc in CgVal nloc x1 x2 (ctyp floc sh x3) + | CgVal loc x1 x2 x3 x4 -> let nloc = floc loc in CgVal nloc x1 x2 x3 (ctyp floc sh x4) | CgVir loc x1 x2 x3 -> let nloc = floc loc in CgVir nloc x1 x2 (ctyp floc sh x3) ] and class_expr floc sh = self where rec self = @@ -377,5 +377,6 @@ | CrMth loc x1 x2 x3 x4 -> let nloc = floc loc in CrMth nloc x1 x2 (expr floc sh x3) (option_map (ctyp floc sh) x4) | CrVal loc x1 x2 x3 -> let nloc = floc loc in CrVal nloc x1 x2 (expr floc sh x3) - | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3) ] + | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3) + | CrVvr loc x1 x2 x3 -> let nloc = floc loc in CrVvr nloc x1 x2 (ctyp floc sh x3) ] ; Index: camlp4/etc/pa_o.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pa_o.ml,v retrieving revision 1.66 diff -u -r1.66 pa_o.ml --- camlp4/etc/pa_o.ml 29 Jun 2005 04:11:26 -0000 1.66 +++ camlp4/etc/pa_o.ml 5 Apr 2006 02:26:01 -0000 @@ -1037,8 +1037,14 @@ class_str_item: [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] -> <:class_str_item< inherit $ce$ $opt:pb$ >> - | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding -> - <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> + | "val"; "mutable"; lab = label; e = cvalue_binding -> + <:class_str_item< value mutable $lab$ = $e$ >> + | "val"; lab = label; e = cvalue_binding -> + <:class_str_item< value $lab$ = $e$ >> + | "val"; "mutable"; "virtual"; lab = label; ":"; t = ctyp -> + <:class_str_item< value virtual mutable $lab$ : $t$ >> + | "val"; "virtual"; mf = OPT "mutable"; lab = label; ":"; t = ctyp -> + <:class_str_item< value virtual $opt:o2b mf$ $lab$ : $t$ >> | "method"; "private"; "virtual"; l = label; ":"; t = poly_type -> <:class_str_item< method virtual private $l$ : $t$ >> | "method"; "virtual"; "private"; l = label; ":"; t = poly_type -> @@ -1087,8 +1093,9 @@ ; class_sig_item: [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >> - | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> - <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> + | "val"; mf = OPT "mutable"; vf = OPT "virtual"; + l = label; ":"; t = ctyp -> + <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >> | "method"; "private"; "virtual"; l = label; ":"; t = poly_type -> <:class_sig_item< method virtual private $l$ : $t$ >> | "method"; "virtual"; "private"; l = label; ":"; t = poly_type -> Index: camlp4/etc/pr_o.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pr_o.ml,v retrieving revision 1.51 diff -u -r1.51 pr_o.ml --- camlp4/etc/pr_o.ml 5 Jan 2006 10:44:29 -0000 1.51 +++ camlp4/etc/pr_o.ml 5 Apr 2006 02:26:01 -0000 @@ -1768,10 +1768,11 @@ [: `S LR "method"; private_flag pf; `label lab; `S LR ":" :]; `ctyp t "" k :] - | MLast.CgVal _ lab mf t -> + | MLast.CgVal _ lab mf vf t -> fun curr next dg k -> [: `HVbox - [: `S LR "val"; mutable_flag mf; `label lab; `S LR ":" :]; + [: `S LR "val"; mutable_flag mf; virtual_flag vf; + `label lab; `S LR ":" :]; `ctyp t "" k :] | MLast.CgVir _ lab pf t -> fun curr next dg k -> Index: camlp4/meta/pa_r.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/pa_r.ml,v retrieving revision 1.64 diff -u -r1.64 pa_r.ml --- camlp4/meta/pa_r.ml 29 Jun 2005 04:11:26 -0000 1.64 +++ camlp4/meta/pa_r.ml 5 Apr 2006 02:26:01 -0000 @@ -658,7 +658,9 @@ | "inherit"; ce = class_expr; pb = OPT as_lident -> <:class_str_item< inherit $ce$ $opt:pb$ >> | "value"; mf = OPT "mutable"; lab = label; e = cvalue_binding -> - <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> + <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> + | "value"; "virtual"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> + <:class_str_item< value virtual $opt:o2b mf$ $l$ : $t$ >> | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp -> <:class_str_item< method virtual $opt:o2b pf$ $l$ : $t$ >> | "method"; pf = OPT "private"; l = label; topt = OPT polyt; @@ -701,8 +703,9 @@ [ [ "declare"; st = LIST0 [ s = class_sig_item; ";" -> s ]; "end" -> <:class_sig_item< declare $list:st$ end >> | "inherit"; cs = class_type -> <:class_sig_item< inherit $cs$ >> - | "value"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> - <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> + | "value"; mf = OPT "mutable"; vf = OPT "virtual"; + l = label; ":"; t = ctyp -> + <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >> | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp -> <:class_sig_item< method virtual $opt:o2b pf$ $l$ : $t$ >> | "method"; pf = OPT "private"; l = label; ":"; t = ctyp -> Index: camlp4/meta/q_MLast.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/q_MLast.ml,v retrieving revision 1.60 diff -u -r1.60 q_MLast.ml --- camlp4/meta/q_MLast.ml 29 Jun 2005 04:11:26 -0000 1.60 +++ camlp4/meta/q_MLast.ml 5 Apr 2006 02:26:01 -0000 @@ -947,6 +947,8 @@ Qast.Node "CrDcl" [Qast.Loc; st] | "inherit"; ce = class_expr; pb = SOPT as_lident -> Qast.Node "CrInh" [Qast.Loc; ce; pb] + | "value"; "virtual"; mf = SOPT "mutable"; l = label; ":"; t = ctyp -> + Qast.Node "CrVvr" [Qast.Loc; l; o2b mf; t] | "value"; mf = SOPT "mutable"; lab = label; e = cvalue_binding -> Qast.Node "CrVal" [Qast.Loc; lab; o2b mf; e] | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp -> @@ -992,8 +994,9 @@ [ [ "declare"; st = SLIST0 [ s = class_sig_item; ";" -> s ]; "end" -> Qast.Node "CgDcl" [Qast.Loc; st] | "inherit"; cs = class_type -> Qast.Node "CgInh" [Qast.Loc; cs] - | "value"; mf = SOPT "mutable"; l = label; ":"; t = ctyp -> - Qast.Node "CgVal" [Qast.Loc; l; o2b mf; t] + | "value"; mf = SOPT "mutable"; vf = SOPT "virtual"; + l = label; ":"; t = ctyp -> + Qast.Node "CgVal" [Qast.Loc; l; o2b mf; o2b vf; t] | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp -> Qast.Node "CgVir" [Qast.Loc; l; o2b pf; t] | "method"; pf = SOPT "private"; l = label; ":"; t = ctyp -> Index: camlp4/ocaml_src/camlp4/ast2pt.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/ast2pt.ml,v retrieving revision 1.36 diff -u -r1.36 ast2pt.ml --- camlp4/ocaml_src/camlp4/ast2pt.ml 29 Jun 2005 04:11:26 -0000 1.36 +++ camlp4/ocaml_src/camlp4/ast2pt.ml 5 Apr 2006 02:26:01 -0000 @@ -227,6 +227,7 @@ ;; let mkmutable m = if m then Mutable else Immutable;; let mkprivate m = if m then Private else Public;; +let mkvirtual m = if m then Virtual else Concrete;; let mktrecord (loc, n, m, t) = n, mkmutable m, ctyp (mkpolytype t), mkloc loc ;; @@ -878,8 +879,8 @@ | CgInh (loc, ct) -> Pctf_inher (class_type ct) :: l | CgMth (loc, s, pf, t) -> Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l - | CgVal (loc, s, b, t) -> - Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l + | CgVal (loc, s, b, v, t) -> + Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l | CgVir (loc, s, b, t) -> Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l and class_expr = @@ -923,6 +924,8 @@ | CrVal (loc, s, b, e) -> Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l | CrVir (loc, s, b, t) -> Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l + | CrVvr (loc, s, b, t) -> + Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l ;; let interf ast = List.fold_right sig_item ast [];; Index: camlp4/ocaml_src/camlp4/mLast.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/mLast.mli,v retrieving revision 1.20 diff -u -r1.20 mLast.mli --- camlp4/ocaml_src/camlp4/mLast.mli 29 Jun 2005 04:11:26 -0000 1.20 +++ camlp4/ocaml_src/camlp4/mLast.mli 5 Apr 2006 02:26:01 -0000 @@ -180,7 +180,7 @@ | CgDcl of loc * class_sig_item list | CgInh of loc * class_type | CgMth of loc * string * bool * ctyp - | CgVal of loc * string * bool * ctyp + | CgVal of loc * string * bool * bool * ctyp | CgVir of loc * string * bool * ctyp and class_expr = CeApp of loc * class_expr * expr @@ -197,6 +197,7 @@ | CrMth of loc * string * bool * expr * ctyp option | CrVal of loc * string * bool * expr | CrVir of loc * string * bool * ctyp + | CrVvr of loc * string * bool * ctyp ;; external loc_of_ctyp : ctyp -> loc = "%field0";; Index: camlp4/ocaml_src/camlp4/reloc.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/reloc.ml,v retrieving revision 1.20 diff -u -r1.20 reloc.ml --- camlp4/ocaml_src/camlp4/reloc.ml 29 Jun 2005 04:11:26 -0000 1.20 +++ camlp4/ocaml_src/camlp4/reloc.ml 5 Apr 2006 02:26:01 -0000 @@ -430,8 +430,8 @@ let nloc = floc loc in CgInh (nloc, class_type floc sh x1) | CgMth (loc, x1, x2, x3) -> let nloc = floc loc in CgMth (nloc, x1, x2, ctyp floc sh x3) - | CgVal (loc, x1, x2, x3) -> - let nloc = floc loc in CgVal (nloc, x1, x2, ctyp floc sh x3) + | CgVal (loc, x1, x2, x3, x4) -> + let nloc = floc loc in CgVal (nloc, x1, x2, x3, ctyp floc sh x4) | CgVir (loc, x1, x2, x3) -> let nloc = floc loc in CgVir (nloc, x1, x2, ctyp floc sh x3) in @@ -478,6 +478,8 @@ let nloc = floc loc in CrVal (nloc, x1, x2, expr floc sh x3) | CrVir (loc, x1, x2, x3) -> let nloc = floc loc in CrVir (nloc, x1, x2, ctyp floc sh x3) + | CrVvr (loc, x1, x2, x3) -> + let nloc = floc loc in CrVvr (nloc, x1, x2, ctyp floc sh x3) in self ;; Index: camlp4/ocaml_src/meta/pa_r.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/pa_r.ml,v retrieving revision 1.59 diff -u -r1.59 pa_r.ml --- camlp4/ocaml_src/meta/pa_r.ml 29 Jun 2005 04:11:26 -0000 1.59 +++ camlp4/ocaml_src/meta/pa_r.ml 5 Apr 2006 02:26:01 -0000 @@ -2161,6 +2161,15 @@ (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _ (_loc : Lexing.position * Lexing.position) -> (MLast.CrVir (_loc, l, o2b pf, t) : 'class_str_item)); + [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual"); + Gramext.Sopt (Gramext.Stoken ("", "mutable")); + Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); + Gramext.Stoken ("", ":"); + Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], + Gramext.action + (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _ _ + (_loc : Lexing.position * Lexing.position) -> + (MLast.CrVvr (_loc, l, o2b mf, t) : 'class_str_item)); [Gramext.Stoken ("", "value"); Gramext.Sopt (Gramext.Stoken ("", "mutable")); Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); @@ -2338,13 +2347,15 @@ (MLast.CgVir (_loc, l, o2b pf, t) : 'class_sig_item)); [Gramext.Stoken ("", "value"); Gramext.Sopt (Gramext.Stoken ("", "mutable")); + Gramext.Sopt (Gramext.Stoken ("", "virtual")); Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _ + (fun (t : 'ctyp) _ (l : 'label) (vf : string option) + (mf : string option) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.CgVal (_loc, l, o2b mf, t) : 'class_sig_item)); + (MLast.CgVal (_loc, l, o2b mf, o2b vf, t) : 'class_sig_item)); [Gramext.Stoken ("", "inherit"); Gramext.Snterm (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], Index: camlp4/ocaml_src/meta/q_MLast.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/q_MLast.ml,v retrieving revision 1.65 diff -u -r1.65 q_MLast.ml --- camlp4/ocaml_src/meta/q_MLast.ml 12 Jan 2006 08:54:21 -0000 1.65 +++ camlp4/ocaml_src/meta/q_MLast.ml 5 Apr 2006 02:26:01 -0000 @@ -3152,9 +3152,9 @@ Gramext.action (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__17))])], + (Qast.Str x : 'e__18))])], Gramext.action - (fun (a : 'e__17 option) + (fun (a : 'e__18 option) (_loc : Lexing.position * Lexing.position) -> (Qast.Option a : 'a_opt)); [Gramext.Snterm @@ -3191,9 +3191,9 @@ Gramext.action (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__16))])], + (Qast.Str x : 'e__17))])], Gramext.action - (fun (a : 'e__16 option) + (fun (a : 'e__17 option) (_loc : Lexing.position * Lexing.position) -> (Qast.Option a : 'a_opt)); [Gramext.Snterm @@ -3216,9 +3216,9 @@ Gramext.action (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__15))])], + (Qast.Str x : 'e__16))])], Gramext.action - (fun (a : 'e__15 option) + (fun (a : 'e__16 option) (_loc : Lexing.position * Lexing.position) -> (Qast.Option a : 'a_opt)); [Gramext.Snterm @@ -3235,6 +3235,31 @@ (_loc : Lexing.position * Lexing.position) -> (Qast.Node ("CrVal", [Qast.Loc; lab; o2b mf; e]) : 'class_str_item)); + [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual"); + Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "mutable")], + Gramext.action + (fun (x : string) + (_loc : Lexing.position * Lexing.position) -> + (Qast.Str x : 'e__15))])], + Gramext.action + (fun (a : 'e__15 option) + (_loc : Lexing.position * Lexing.position) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; + Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); + Gramext.Stoken ("", ":"); + Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], + Gramext.action + (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ _ + (_loc : Lexing.position * Lexing.position) -> + (Qast.Node ("CrVvr", [Qast.Loc; l; o2b mf; t]) : 'class_str_item)); [Gramext.Stoken ("", "inherit"); Gramext.Snterm (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); @@ -3366,9 +3391,9 @@ Gramext.action (fun _ (csf : 'class_sig_item) (_loc : Lexing.position * Lexing.position) -> - (csf : 'e__18))])], + (csf : 'e__19))])], Gramext.action - (fun (a : 'e__18 list) + (fun (a : 'e__19 list) (_loc : Lexing.position * Lexing.position) -> (Qast.List a : 'a_list)); [Gramext.Snterm @@ -3446,9 +3471,9 @@ Gramext.action (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__22))])], + (Qast.Str x : 'e__24))])], Gramext.action - (fun (a : 'e__22 option) + (fun (a : 'e__24 option) (_loc : Lexing.position * Lexing.position) -> (Qast.Option a : 'a_opt)); [Gramext.Snterm @@ -3471,9 +3496,9 @@ Gramext.action (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__21))])], + (Qast.Str x : 'e__23))])], Gramext.action - (fun (a : 'e__21 option) + (fun (a : 'e__23 option) (_loc : Lexing.position * Lexing.position) -> (Qast.Option a : 'a_opt)); [Gramext.Snterm @@ -3496,9 +3521,26 @@ Gramext.action (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__20))])], + (Qast.Str x : 'e__21))])], Gramext.action - (fun (a : 'e__20 option) + (fun (a : 'e__21 option) + (_loc : Lexing.position * Lexing.position) -> + (Qast.Option a : 'a_opt)); + [Gramext.Snterm + (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], + Gramext.action + (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> + (a : 'a_opt))]; + Gramext.srules + [[Gramext.Sopt + (Gramext.srules + [[Gramext.Stoken ("", "virtual")], + Gramext.action + (fun (x : string) + (_loc : Lexing.position * Lexing.position) -> + (Qast.Str x : 'e__22))])], + Gramext.action + (fun (a : 'e__22 option) (_loc : Lexing.position * Lexing.position) -> (Qast.Option a : 'a_opt)); [Gramext.Snterm @@ -3510,9 +3552,10 @@ Gramext.Stoken ("", ":"); Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ + (fun (t : 'ctyp) _ (l : 'label) (vf : 'a_opt) (mf : 'a_opt) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; t]) : 'class_sig_item)); + (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; o2b vf; t]) : + 'class_sig_item)); [Gramext.Stoken ("", "inherit"); Gramext.Snterm (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], @@ -3531,9 +3574,9 @@ Gramext.action (fun _ (s : 'class_sig_item) (_loc : Lexing.position * Lexing.position) -> - (s : 'e__19))])], + (s : 'e__20))])], Gramext.action - (fun (a : 'e__19 list) + (fun (a : 'e__20 list) (_loc : Lexing.position * Lexing.position) -> (Qast.List a : 'a_list)); [Gramext.Snterm @@ -3556,9 +3599,9 @@ Gramext.action (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__23))])], + (Qast.Str x : 'e__25))])], Gramext.action - (fun (a : 'e__23 option) + (fun (a : 'e__25 option) (_loc : Lexing.position * Lexing.position) -> (Qast.Option a : 'a_opt)); [Gramext.Snterm @@ -3593,9 +3636,9 @@ Gramext.action (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__24))])], + (Qast.Str x : 'e__26))])], Gramext.action - (fun (a : 'e__24 option) + (fun (a : 'e__26 option) (_loc : Lexing.position * Lexing.position) -> (Qast.Option a : 'a_opt)); [Gramext.Snterm @@ -3713,9 +3756,9 @@ Gramext.action (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__25))])], + (Qast.Str x : 'e__27))])], Gramext.action - (fun (a : 'e__25 option) + (fun (a : 'e__27 option) (_loc : Lexing.position * Lexing.position) -> (Qast.Option a : 'a_opt)); [Gramext.Snterm @@ -3922,9 +3965,9 @@ Gramext.action (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__26))])], + (Qast.Str x : 'e__28))])], Gramext.action - (fun (a : 'e__26 option) + (fun (a : 'e__28 option) (_loc : Lexing.position * Lexing.position) -> (Qast.Option a : 'a_opt)); [Gramext.Snterm @@ -4390,9 +4433,9 @@ Gramext.action (fun _ (e : 'expr) (_loc : Lexing.position * Lexing.position) -> - (e : 'e__29))])], + (e : 'e__31))])], Gramext.action - (fun (a : 'e__29 list) + (fun (a : 'e__31 list) (_loc : Lexing.position * Lexing.position) -> (Qast.List a : 'a_list)); [Gramext.Snterm @@ -4425,9 +4468,9 @@ Gramext.action (fun _ (e : 'expr) (_loc : Lexing.position * Lexing.position) -> - (e : 'e__28))])], + (e : 'e__30))])], Gramext.action - (fun (a : 'e__28 list) + (fun (a : 'e__30 list) (_loc : Lexing.position * Lexing.position) -> (Qast.List a : 'a_list)); [Gramext.Snterm @@ -4454,9 +4497,9 @@ Gramext.action (fun _ (e : 'expr) (_loc : Lexing.position * Lexing.position) -> - (e : 'e__27))])], + (e : 'e__29))])], Gramext.action - (fun (a : 'e__27 list) + (fun (a : 'e__29 list) (_loc : Lexing.position * Lexing.position) -> (Qast.List a : 'a_list)); [Gramext.Snterm @@ -4547,9 +4590,9 @@ Gramext.action (fun _ (cf : 'class_str_item) (_loc : Lexing.position * Lexing.position) -> - (cf : 'e__30))])], + (cf : 'e__32))])], Gramext.action - (fun (a : 'e__30 list) + (fun (a : 'e__32 list) (_loc : Lexing.position * Lexing.position) -> (Qast.List a : 'a_list)); [Gramext.Snterm @@ -4592,9 +4635,9 @@ Gramext.action (fun _ (csf : 'class_sig_item) (_loc : Lexing.position * Lexing.position) -> - (csf : 'e__32))])], + (csf : 'e__34))])], Gramext.action - (fun (a : 'e__32 list) + (fun (a : 'e__34 list) (_loc : Lexing.position * Lexing.position) -> (Qast.List a : 'a_list)); [Gramext.Snterm @@ -4623,9 +4666,9 @@ Gramext.action (fun _ (csf : 'class_sig_item) (_loc : Lexing.position * Lexing.position) -> - (csf : 'e__31))])], + (csf : 'e__33))])], Gramext.action - (fun (a : 'e__31 list) + (fun (a : 'e__33 list) (_loc : Lexing.position * Lexing.position) -> (Qast.List a : 'a_list)); [Gramext.Snterm Index: camlp4/top/rprint.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/camlp4/top/rprint.ml,v retrieving revision 1.18 diff -u -r1.18 rprint.ml --- camlp4/top/rprint.ml 29 Jun 2005 04:11:26 -0000 1.18 +++ camlp4/top/rprint.ml 5 Apr 2006 02:26:01 -0000 @@ -288,8 +288,9 @@ fprintf ppf "@[<2>method %s%s%s :@ %a;@]" (if priv then "private " else "") (if virt then "virtual " else "") name Toploop.print_out_type.val ty - | Ocsg_value name mut ty -> - fprintf ppf "@[<2>value %s%s :@ %a;@]" (if mut then "mutable " else "") + | Ocsg_value name mut virt ty -> + fprintf ppf "@[<2>value %s%s%s :@ %a;@]" + (if mut then "mutable " else "") (if virt then "virtual " else "") name Toploop.print_out_type.val ty ] ; mingw-ocaml/ocaml/experimental/garrigue/marshal_objects.diffs0000644000175000017500000007366212124403240024152 0ustar tootstoots? bytecomp/alpha_eq.ml Index: bytecomp/lambda.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.ml,v retrieving revision 1.44 diff -u -r1.44 lambda.ml --- bytecomp/lambda.ml 25 Aug 2005 15:35:16 -0000 1.44 +++ bytecomp/lambda.ml 2 Feb 2006 05:08:56 -0000 @@ -287,9 +287,10 @@ let compare = compare end) -let free_ids get l = +let free_ids get used l = let fv = ref IdentSet.empty in let rec free l = + let old = !fv in iter free l; fv := List.fold_right IdentSet.add (get l) !fv; match l with @@ -307,17 +308,20 @@ fv := IdentSet.remove v !fv | Lassign(id, e) -> fv := IdentSet.add id !fv + | Lifused(id, e) -> + if used && not (IdentSet.mem id old) then fv := IdentSet.remove id !fv | Lvar _ | Lconst _ | Lapply _ | Lprim _ | Lswitch _ | Lstaticraise _ | Lifthenelse _ | Lsequence _ | Lwhile _ - | Lsend _ | Levent _ | Lifused _ -> () + | Lsend _ | Levent _ -> () in free l; !fv -let free_variables l = - free_ids (function Lvar id -> [id] | _ -> []) l +let free_variables ?(ifused=false) l = + free_ids (function Lvar id -> [id] | _ -> []) ifused l let free_methods l = - free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l + free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) + false l (* Check if an action has a "when" guard *) let raise_count = ref 0 Index: bytecomp/lambda.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.mli,v retrieving revision 1.42 diff -u -r1.42 lambda.mli --- bytecomp/lambda.mli 25 Aug 2005 15:35:16 -0000 1.42 +++ bytecomp/lambda.mli 2 Feb 2006 05:08:56 -0000 @@ -177,7 +177,7 @@ val iter: (lambda -> unit) -> lambda -> unit module IdentSet: Set.S with type elt = Ident.t -val free_variables: lambda -> IdentSet.t +val free_variables: ?ifused:bool -> lambda -> IdentSet.t val free_methods: lambda -> IdentSet.t val transl_path: Path.t -> lambda Index: bytecomp/translclass.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v retrieving revision 1.38 diff -u -r1.38 translclass.ml --- bytecomp/translclass.ml 13 Aug 2005 20:59:37 -0000 1.38 +++ bytecomp/translclass.ml 2 Feb 2006 05:08:56 -0000 @@ -46,6 +46,10 @@ let lfield v i = Lprim(Pfield i, [Lvar v]) +let ltuple l = Lprim(Pmakeblock(0,Immutable), l) + +let lprim name args = Lapply(oo_prim name, args) + let transl_label l = share (Const_immstring l) let rec transl_meth_list lst = @@ -68,8 +72,8 @@ Lvar offset])])])) let transl_val tbl create name = - Lapply (oo_prim (if create then "new_variable" else "get_variable"), - [Lvar tbl; transl_label name]) + lprim (if create then "new_variable" else "get_variable") + [Lvar tbl; transl_label name] let transl_vals tbl create vals rem = List.fold_right @@ -82,7 +86,7 @@ (fun (nm, id) rem -> try (nm, id, - Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)])) + lprim "get_method" [Lvar tbl; Lvar (Meths.find nm meths)]) :: rem with Not_found -> rem) inh_meths [] @@ -97,17 +101,15 @@ let (inh_init, obj_init, has_init) = init obj' in if obj_init = lambda_unit then (inh_init, - Lapply (oo_prim (if has_init then "create_object_and_run_initializers" - else"create_object_opt"), - [obj; Lvar cl])) + lprim (if has_init then "create_object_and_run_initializers" + else"create_object_opt") + [obj; Lvar cl]) else begin (inh_init, - Llet(Strict, obj', - Lapply (oo_prim "create_object_opt", [obj; Lvar cl]), + Llet(Strict, obj', lprim "create_object_opt" [obj; Lvar cl], Lsequence(obj_init, if not has_init then Lvar obj' else - Lapply (oo_prim "run_initializers_opt", - [obj; Lvar obj'; Lvar cl])))) + lprim "run_initializers_opt" [obj; Lvar obj'; Lvar cl]))) end let rec build_object_init cl_table obj params inh_init obj_init cl = @@ -203,14 +205,13 @@ let bind_method tbl lab id cl_init = - Llet(StrictOpt, id, Lapply (oo_prim "get_method_label", - [Lvar tbl; transl_label lab]), + Llet(StrictOpt, id, lprim "get_method_label" [Lvar tbl; transl_label lab], cl_init) -let bind_methods tbl meths vals cl_init = - let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in +let bind_methods tbl methl vals cl_init = let len = List.length methl and nvals = List.length vals in - if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else + if len < 2 && nvals = 0 then + List.fold_right (fun (n,i) -> bind_method tbl n i) methl cl_init else if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else let ids = Ident.create "ids" in let i = ref len in @@ -229,21 +230,19 @@ vals' cl_init) in Llet(StrictOpt, ids, - Lapply (oo_prim getter, - [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), + lprim getter + ([Lvar tbl; transl_meth_list (List.map fst methl)] @ names), List.fold_right - (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam)) + (fun (lab,id) lam -> decr i; Llet(Alias, id, lfield ids !i, lam)) methl cl_init) let output_methods tbl methods lam = match methods with [] -> lam | [lab; code] -> - lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam + lsequence (lprim "set_method" [Lvar tbl; lab; code]) lam | _ -> - lsequence (Lapply(oo_prim "set_methods", - [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)])) - lam + lsequence (lprim "set_methods" [Lvar tbl; ltuple methods]) lam let rec ignore_cstrs cl = match cl.cl_desc with @@ -266,7 +265,8 @@ Llet (Strict, obj_init, Lapply(Lprim(Pfield 1, [lpath]), Lvar cla :: if top then [Lprim(Pfield 3, [lpath])] else []), - bind_super cla super cl_init)) + bind_super cla super cl_init), + [], []) | _ -> assert false end @@ -278,10 +278,11 @@ match field with Cf_inher (cl, vals, meths) -> let cl_init = output_methods cla methods cl_init in - let inh_init, cl_init = + let (inh_init, cl_init, meths', vals') = build_class_init cla false (vals, meths_super cla str.cl_meths meths) inh_init cl_init msubst top cl in + let cl_init = bind_methods cla meths' vals' cl_init in (inh_init, cl_init, [], values) | Cf_val (name, id, exp) -> (inh_init, cl_init, methods, (name, id)::values) @@ -304,29 +305,37 @@ (inh_init, cl_init, methods, vals @ values) | Cf_init exp -> (inh_init, - Lsequence(Lapply (oo_prim "add_initializer", - Lvar cla :: msubst false (transl_exp exp)), + Lsequence(lprim "add_initializer" + (Lvar cla :: msubst false (transl_exp exp)), cl_init), methods, values)) str.cl_field (inh_init, cl_init, [], []) in let cl_init = output_methods cla methods cl_init in - (inh_init, bind_methods cla str.cl_meths values cl_init) + (* inh_init, bind_methods cla str.cl_meths values cl_init *) + let methods = Meths.fold (fun n i l -> (n,i)::l) str.cl_meths [] in + (inh_init, cl_init, methods, values) | Tclass_fun (pat, vals, cl, _) -> - let (inh_init, cl_init) = + let (inh_init, cl_init, methods, values) = build_class_init cla cstr super inh_init cl_init msubst top cl in + let fv = free_variables ~ifused:true cl_init in + let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in - (inh_init, transl_vals cla true vals cl_init) + (* inh_init, transl_vals cla true vals cl_init *) + (inh_init, cl_init, methods, vals @ values) | Tclass_apply (cl, exprs) -> build_class_init cla cstr super inh_init cl_init msubst top cl | Tclass_let (rec_flag, defs, vals, cl) -> - let (inh_init, cl_init) = + let (inh_init, cl_init, methods, values) = build_class_init cla cstr super inh_init cl_init msubst top cl in + let fv = free_variables ~ifused:true cl_init in + let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in - (inh_init, transl_vals cla true vals cl_init) + (* inh_init, transl_vals cla true vals cl_init *) + (inh_init, cl_init, methods, vals @ values) | Tclass_constraint (cl, vals, meths, concr_meths) -> let virt_meths = List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in @@ -358,23 +367,34 @@ cl_init valids in (inh_init, Llet (Strict, inh, - Lapply(oo_prim "inherits", narrow_args @ - [lpath; Lconst(Const_pointer(if top then 1 else 0))]), + lprim "inherits" + (narrow_args @ + [lpath; Lconst(Const_pointer(if top then 1 else 0))]), Llet(StrictOpt, obj_init, lfield inh 0, Llet(Alias, inh_vals, lfield inh 1, - Llet(Alias, inh_meths, lfield inh 2, cl_init))))) + Llet(Alias, inh_meths, lfield inh 2, cl_init)))), + [], []) | _ -> let core cl_init = build_class_init cla true super inh_init cl_init msubst top cl in if cstr then core cl_init else - let (inh_init, cl_init) = - core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init)) + let (inh_init, cl_init, methods, values) = + core (Lsequence (lprim "widen" [Lvar cla], cl_init)) in - (inh_init, - Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init)) + let cl_init = bind_methods cla methods values cl_init in + (inh_init, Lsequence(lprim "narrow" narrow_args, cl_init), [], []) end +let build_class_init cla env inh_init obj_init msubst top cl = + let inh_init = List.rev inh_init in + let (inh_init, cl_init, methods, values) = + build_class_init cla true ([],[]) inh_init obj_init msubst top cl in + assert (inh_init = []); + if IdentSet.mem env (free_variables ~ifused:true cl_init) + then bind_methods cla methods (("", env) :: values) cl_init + else Llet(Alias, env, lambda_unit, bind_methods cla methods values cl_init) + let rec build_class_lets cl = match cl.cl_desc with Tclass_let (rec_flag, defs, vals, cl) -> @@ -459,16 +479,16 @@ Strict, new_init, lfunction [obj_init] obj_init', Llet( Alias, cla, transl_path path, - Lprim(Pmakeblock(0, Immutable), - [Lapply(Lvar new_init, [lfield cla 0]); - lfunction [table] - (Llet(Strict, env_init, - Lapply(lfield cla 1, [Lvar table]), - lfunction [envs] - (Lapply(Lvar new_init, - [Lapply(Lvar env_init, [Lvar envs])])))); - lfield cla 2; - lfield cla 3]))) + ltuple + [Lapply(Lvar new_init, [lfield cla 0]); + lfunction [table] + (Llet(Strict, env_init, + Lapply(lfield cla 1, [Lvar table]), + lfunction [envs] + (Lapply(Lvar new_init, + [Lapply(Lvar env_init, [Lvar envs])])))); + lfield cla 2; + lfield cla 3])) with Exit -> lambda_unit @@ -541,7 +561,7 @@ open CamlinternalOO let builtin_meths arr self env env2 body = let builtin, args = builtin_meths self env env2 body in - if not arr then [Lapply(oo_prim builtin, args)] else + if not arr then [lprim builtin args] else let tag = match builtin with "get_const" -> GetConst | "get_var" -> GetVar @@ -599,7 +619,8 @@ (* Prepare for heavy environment handling *) let tables = Ident.create (Ident.name cl_id ^ "_tables") in - let (top_env, req) = oo_add_class tables in + let table_init = ref None in + let (top_env, req) = oo_add_class tables table_init in let top = not req in let cl_env, llets = build_class_lets cl in let new_ids = if top then [] else Env.diff top_env cl_env in @@ -633,6 +654,7 @@ begin try (* Doesn't seem to improve size for bytecode *) (* if not !Clflags.native_code then raise Not_found; *) + if !Clflags.debug then raise Not_found; builtin_meths arr [self] env env2 (lfunction args body') with Not_found -> [lfunction (self :: args) @@ -665,15 +687,8 @@ build_object_init_0 cla [] cl copy_env subst_env top ids in if not (Translcore.check_recursive_lambda ids obj_init) then raise(Error(cl.cl_loc, Illegal_class_expr)); - let inh_init' = List.rev inh_init in - let (inh_init', cl_init) = - build_class_init cla true ([],[]) inh_init' obj_init msubst top cl - in - assert (inh_init' = []); - let table = Ident.create "table" - and class_init = Ident.create (Ident.name cl_id ^ "_init") - and env_init = Ident.create "env_init" - and obj_init = Ident.create "obj_init" in + let cl_init = build_class_init cla env2 inh_init obj_init msubst top cl in + let obj_init = Ident.create "obj_init" in let pub_meths = List.sort (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s')) @@ -685,42 +700,44 @@ let name' = List.assoc tag rev_map in if name' <> name then raise(Error(cl.cl_loc, Tags(name, name')))) tags pub_meths; + let pos = cl.cl_loc.Location.loc_end in + let filepos = [transl_label pos.Lexing.pos_fname; + Lconst(Const_base(Const_int pos.Lexing.pos_cnum))] in let ltable table lam = - Llet(Strict, table, - Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam) + Llet(Strict, table, lprim "create_table" [transl_meth_list pub_meths], lam) and ldirect obj_init = Llet(Strict, obj_init, cl_init, - Lsequence(Lapply (oo_prim "init_class", [Lvar cla]), + Lsequence(lprim "init_class_shared" (Lvar cla :: filepos), Lapply(Lvar obj_init, [lambda_unit]))) in (* Simplest case: an object defined at toplevel (ids=[]) *) if top && ids = [] then llets (ltable cla (ldirect obj_init)) else + let table = Ident.create "table" + and class_init = Ident.create (Ident.name cl_id ^ "_init") + and env_init = Ident.create (Ident.name cl_id ^ "_env_init") in + let cl_init_fun = Lfunction(Curried, [cla], cl_init) in let concrete = ids = [] || Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = [] - and lclass lam = - let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in + and lclass cl_init lam = Llet(Strict, class_init, cl_init, lam (free_variables cl_init)) and lbody fv = if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then - Lapply (oo_prim "make_class",[transl_meth_list pub_meths; - Lvar class_init]) + lprim "make_class" + (transl_meth_list pub_meths :: Lvar class_init :: filepos) else ltable table ( Llet( Strict, env_init, Lapply(Lvar class_init, [Lvar table]), - Lsequence( - Lapply (oo_prim "init_class", [Lvar table]), - Lprim(Pmakeblock(0, Immutable), - [Lapply(Lvar env_init, [lambda_unit]); - Lvar class_init; Lvar env_init; lambda_unit])))) + Lsequence(lprim "init_class_shared" (Lvar table :: filepos), + ltuple [Lapply(Lvar env_init, [lambda_unit]); + Lvar class_init; Lvar env_init; lambda_unit]))) and lbody_virt lenvs = - Lprim(Pmakeblock(0, Immutable), - [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs]) + ltuple [lambda_unit; cl_init_fun; lambda_unit; lenvs] in (* Still easy: a class defined at toplevel *) - if top && concrete then lclass lbody else + if top && concrete then lclass (llets cl_init_fun) lbody else if top then llets (lbody_virt lambda_unit) else (* Now for the hard stuff: prepare for table cacheing *) @@ -733,23 +750,16 @@ let lenv = let menv = if !new_ids_meths = [] then lambda_unit else - Lprim(Pmakeblock(0, Immutable), - List.map (fun id -> Lvar id) !new_ids_meths) in + ltuple (List.map (fun id -> Lvar id) !new_ids_meths) in if !new_ids_init = [] then menv else - Lprim(Pmakeblock(0, Immutable), - menv :: List.map (fun id -> Lvar id) !new_ids_init) + ltuple (menv :: List.map (fun id -> Lvar id) !new_ids_init) and linh_envs = List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p])) (List.rev inh_init) in let make_envs lam = Llet(StrictOpt, envs, - (if linh_envs = [] then lenv else - Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs)), - lam) - and def_ids cla lam = - Llet(StrictOpt, env2, - Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]), + (if linh_envs = [] then lenv else ltuple (lenv :: linh_envs)), lam) in let inh_paths = @@ -757,46 +767,53 @@ (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in let inh_keys = List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in - let lclass lam = - Llet(Strict, class_init, - Lfunction(Curried, [cla], def_ids cla cl_init), lam) + let lclass_init lam = + Llet(Strict, class_init, cl_init_fun, lam) and lcache lam = if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else - Llet(Strict, cached, - Lapply(oo_prim "lookup_tables", - [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]), + Llet(Strict, cached, lprim "lookup_tables" [Lvar tables; ltuple inh_keys], lam) and lset cached i lam = Lprim(Psetfield(i, true), [Lvar cached; lam]) in - let ldirect () = - ltable cla - (Llet(Strict, env_init, def_ids cla cl_init, - Lsequence(Lapply (oo_prim "init_class", [Lvar cla]), - lset cached 0 (Lvar env_init)))) - and lclass_virt () = - lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init)) + let ldirect prim pos = + ltable cla ( + Llet(Strict, env_init, cl_init, + Lsequence(lprim prim (Lvar cla :: pos), Lvar env_init))) + and lclass_concrete cached = + ltuple [Lapply (lfield cached 0, [lenvs]); + lfield cached 1; lfield cached 0; lenvs] in + llets ( - lcache ( - Lsequence( - Lifthenelse(lfield cached 0, lambda_unit, - if ids = [] then ldirect () else - if not concrete then lclass_virt () else - lclass ( - Lapply (oo_prim "make_class_store", - [transl_meth_list pub_meths; - Lvar class_init; Lvar cached]))), make_envs ( - if ids = [] then Lapply(lfield cached 0, [lenvs]) else - Lprim(Pmakeblock(0, Immutable), - if concrete then - [Lapply(lfield cached 0, [lenvs]); - lfield cached 1; - lfield cached 0; - lenvs] - else [lambda_unit; lfield cached 0; lambda_unit; lenvs] - ))))) + if inh_paths = [] && concrete then + if ids = [] then begin + table_init := Some (ldirect "init_class_shared" filepos); + Lapply (Lvar tables, [lenvs]) + end else begin + let init = + lclass cl_init_fun (fun _ -> + lprim "make_class_env" + (transl_meth_list pub_meths :: Lvar class_init :: filepos)) + in table_init := Some init; + lclass_concrete tables + end + else begin + lcache ( + Lsequence( + Lifthenelse(lfield cached 0, lambda_unit, + if ids = [] then lset cached 0 (ldirect "init_class" []) else + if not concrete then lset cached 0 cl_init_fun else + lclass_init ( + lprim "make_class_store" + [transl_meth_list pub_meths; Lvar class_init; Lvar cached])), + llets ( + make_envs ( + if ids = [] then Lapply(lfield cached 0, [lenvs]) else + if concrete then lclass_concrete cached else + ltuple [lambda_unit; lfield cached 0; lambda_unit; lenvs])))) + end)) (* Wrapper for class compilation *) Index: bytecomp/translobj.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.ml,v retrieving revision 1.9 diff -u -r1.9 translobj.ml --- bytecomp/translobj.ml 26 May 2004 11:10:51 -0000 1.9 +++ bytecomp/translobj.ml 2 Feb 2006 05:08:56 -0000 @@ -88,7 +88,6 @@ (* Insert labels *) -let string s = Lconst (Const_base (Const_string s)) let int n = Lconst (Const_base (Const_int n)) let prim_makearray = @@ -124,8 +123,8 @@ let top_env = ref Env.empty let classes = ref [] -let oo_add_class id = - classes := id :: !classes; +let oo_add_class id init = + classes := (id, init) :: !classes; (!top_env, !cache_required) let oo_wrap env req f x = @@ -141,10 +140,12 @@ let lambda = f x in let lambda = List.fold_left - (fun lambda id -> + (fun lambda (id, init) -> Llet(StrictOpt, id, - Lprim(Pmakeblock(0, Mutable), - [lambda_unit; lambda_unit; lambda_unit]), + (match !init with + Some lam -> lam + | None -> Lprim(Pmakeblock(0, Mutable), + [lambda_unit; lambda_unit; lambda_unit])), lambda)) lambda !classes in Index: bytecomp/translobj.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.mli,v retrieving revision 1.6 diff -u -r1.6 translobj.mli --- bytecomp/translobj.mli 26 May 2004 11:10:51 -0000 1.6 +++ bytecomp/translobj.mli 2 Feb 2006 05:08:56 -0000 @@ -25,4 +25,4 @@ Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda -val oo_add_class: Ident.t -> Env.t * bool +val oo_add_class: Ident.t -> Lambda.lambda option ref -> Env.t * bool Index: byterun/compare.h =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/byterun/compare.h,v retrieving revision 1.2 diff -u -r1.2 compare.h --- byterun/compare.h 31 Dec 2003 14:20:35 -0000 1.2 +++ byterun/compare.h 2 Feb 2006 05:08:56 -0000 @@ -17,5 +17,6 @@ #define CAML_COMPARE_H CAMLextern int caml_compare_unordered; +CAMLextern value caml_compare(value, value); #endif /* CAML_COMPARE_H */ Index: byterun/extern.c =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/byterun/extern.c,v retrieving revision 1.59 diff -u -r1.59 extern.c --- byterun/extern.c 4 Jan 2006 16:55:49 -0000 1.59 +++ byterun/extern.c 2 Feb 2006 05:08:56 -0000 @@ -411,6 +411,22 @@ extern_record_location(v); break; } + case Object_tag: { + value field0; + mlsize_t i; + i = Wosize_val(Field(v, 0)) - 1; + field0 = Field(Field(v, 0),i); + if (Wosize_val(field0) > 0) { + writecode32(CODE_OBJECT, Wosize_hd (hd)); + extern_record_location(v); + extern_rec(field0); + for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i)); + v = Field(v, i); + goto tailcall; + } + if (!extern_closures) + extern_invalid_argument("output_value: dynamic class"); + } /* may fall through */ default: { value field0; mlsize_t i; Index: byterun/intern.c =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/byterun/intern.c,v retrieving revision 1.60 diff -u -r1.60 intern.c --- byterun/intern.c 22 Sep 2005 14:21:50 -0000 1.60 +++ byterun/intern.c 2 Feb 2006 05:08:56 -0000 @@ -28,6 +28,8 @@ #include "mlvalues.h" #include "misc.h" #include "reverse.h" +#include "callback.h" +#include "compare.h" static unsigned char * intern_src; /* Reading pointer in block holding input data. */ @@ -98,6 +100,25 @@ #define readblock(dest,len) \ (memmove((dest), intern_src, (len)), intern_src += (len)) +static value get_method_table (value key) +{ + static value *classes = NULL; + value current; + if (classes == NULL) { + classes = caml_named_value("caml_oo_classes"); + if (classes == NULL) return 0; + caml_register_global_root(classes); + } + for (current = Field(*classes, 0); Is_block(current); + current = Field(current, 1)) + { + value head = Field(current, 0); + if (caml_compare(key, Field(head, 0)) == Val_int(0)) + return Field(head, 1); + } + return 0; +} + static void intern_cleanup(void) { if (intern_input_malloced) caml_stat_free(intern_input); @@ -315,6 +336,24 @@ Custom_ops_val(v) = ops; intern_dest += 1 + size; break; + case CODE_OBJECT: + size = read32u(); + v = Val_hp(intern_dest); + *dest = v; + if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; + dest = (value *) (intern_dest + 1); + *intern_dest = Make_header(size, Object_tag, intern_color); + intern_dest += 1 + size; + intern_rec(dest); + *dest = get_method_table(*dest); + if (*dest == 0) { + intern_cleanup(); + caml_failwith("input_value: unknown class"); + } + for(size--, dest++; size > 1; size--, dest++) + intern_rec(dest); + goto tailcall; + default: intern_cleanup(); caml_failwith("input_value: ill-formed message"); Index: byterun/intext.h =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/byterun/intext.h,v retrieving revision 1.32 diff -u -r1.32 intext.h --- byterun/intext.h 22 Sep 2005 14:21:50 -0000 1.32 +++ byterun/intext.h 2 Feb 2006 05:08:56 -0000 @@ -56,6 +56,7 @@ #define CODE_CODEPOINTER 0x10 #define CODE_INFIXPOINTER 0x11 #define CODE_CUSTOM 0x12 +#define CODE_OBJECT 0x14 #if ARCH_FLOAT_ENDIANNESS == 0x76543210 #define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG Index: stdlib/camlinternalOO.ml =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v retrieving revision 1.14 diff -u -r1.14 camlinternalOO.ml --- stdlib/camlinternalOO.ml 25 Oct 2005 18:34:07 -0000 1.14 +++ stdlib/camlinternalOO.ml 2 Feb 2006 05:08:56 -0000 @@ -305,10 +305,38 @@ public_methods; table +(* +let create_table_variables pub_meths priv_meths vars = + let tbl = create_table pub_meths in + let pub_meths = to_array pub_meths + and priv_meths = to_array priv_meths + and vars = to_array vars in + let len = 2 + Array.length pub_meths + Array.length priv_meths in + let res = Array.create len tbl in + let mv = new_methods_variables tbl pub_meths vars in + Array.blit mv 0 res 1; + res +*) + let init_class table = inst_var_count := !inst_var_count + table.size - 1; table.initializers <- List.rev table.initializers; - resize table (3 + magic table.methods.(1) * 16 / Sys.word_size) + let len = 3 + magic table.methods.(1) * 16 / Sys.word_size in + (* keep 1 more for extra info *) + let len = if len > Array.length table.methods then len else len+1 in + resize table len + +let classes = ref [] +let () = Callback.register "caml_oo_classes" classes + +let init_class_shared table (file : string) (pos : int) = + init_class table; + let rec unique_pos pos = + if List.mem_assoc (file, pos) !classes then unique_pos (pos + 0x100000) + else pos in + let pos = unique_pos pos in + table.methods.(Array.length table.methods - 1) <- Obj.magic (file, pos); + classes := ((file, pos), table.methods) :: !classes let inherits cla vals virt_meths concr_meths (_, super, _, env) top = narrow cla vals virt_meths concr_meths; @@ -319,12 +347,18 @@ Array.map (fun nm -> get_method cla (get_method_label cla nm)) (to_array concr_meths)) -let make_class pub_meths class_init = +let make_class pub_meths class_init file pos = let table = create_table pub_meths in let env_init = class_init table in - init_class table; + init_class_shared table file pos; (env_init (Obj.repr 0), class_init, env_init, Obj.repr 0) +let make_class_env pub_meths class_init file pos = + let table = create_table pub_meths in + let env_init = class_init table in + init_class_shared table file pos; + (env_init, class_init) + type init_table = { mutable env_init: t; mutable class_init: table -> t } let make_class_store pub_meths class_init init_table = Index: stdlib/camlinternalOO.mli =================================================================== RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v retrieving revision 1.9 diff -u -r1.9 camlinternalOO.mli --- stdlib/camlinternalOO.mli 25 Oct 2005 18:34:07 -0000 1.9 +++ stdlib/camlinternalOO.mli 2 Feb 2006 05:08:56 -0000 @@ -43,14 +43,20 @@ val add_initializer : table -> (obj -> unit) -> unit val dummy_table : table val create_table : string array -> table +(* val create_table_variables : + string array -> string array -> string array -> table *) val init_class : table -> unit +val init_class_shared : table -> string -> int -> unit val inherits : table -> string array -> string array -> string array -> (t * (table -> obj -> Obj.t) * t * obj) -> bool -> (Obj.t * int array * closure array) val make_class : - string array -> (table -> Obj.t -> t) -> + string array -> (table -> Obj.t -> t) -> string -> int -> (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t) +val make_class_env : + string array -> (table -> Obj.t -> t) -> string -> int -> + (Obj.t -> t) * (table -> Obj.t -> t) type init_table val make_class_store : string array -> (table -> t) -> init_table -> unit mingw-ocaml/ocaml/stdlib/0000755000175000017500000000000012124403240014736 5ustar tootstootsmingw-ocaml/ocaml/stdlib/arg.mli0000644000175000017500000001575712124403240016231 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Parsing of command line arguments. This module provides a general mechanism for extracting options and arguments from the command line to the program. Syntax of command lines: A keyword is a character string starting with a [-]. An option is a keyword alone or followed by an argument. The types of keywords are: [Unit], [Bool], [Set], [Clear], [String], [Set_string], [Int], [Set_int], [Float], [Set_float], [Tuple], [Symbol], and [Rest]. [Unit], [Set] and [Clear] keywords take no argument. A [Rest] keyword takes the remaining of the command line as arguments. Every other keyword takes the following word on the command line as argument. Arguments not preceded by a keyword are called anonymous arguments. Examples ([cmd] is assumed to be the command name): - [cmd -flag ](a unit option) - [cmd -int 1 ](an int option with argument [1]) - [cmd -string foobar ](a string option with argument ["foobar"]) - [cmd -float 12.34 ](a float option with argument [12.34]) - [cmd a b c ](three anonymous arguments: ["a"], ["b"], and ["c"]) - [cmd a b -- c d ](two anonymous arguments and a rest option with two arguments) *) type spec = | Unit of (unit -> unit) (** Call the function with unit argument *) | Bool of (bool -> unit) (** Call the function with a bool argument *) | Set of bool ref (** Set the reference to true *) | Clear of bool ref (** Set the reference to false *) | String of (string -> unit) (** Call the function with a string argument *) | Set_string of string ref (** Set the reference to the string argument *) | Int of (int -> unit) (** Call the function with an int argument *) | Set_int of int ref (** Set the reference to the int argument *) | Float of (float -> unit) (** Call the function with a float argument *) | Set_float of float ref (** Set the reference to the float argument *) | Tuple of spec list (** Take several arguments according to the spec list *) | Symbol of string list * (string -> unit) (** Take one of the symbols as argument and call the function with the symbol *) | Rest of (string -> unit) (** Stop interpreting keywords and call the function with each remaining argument *) (** The concrete type describing the behavior associated with a keyword. *) type key = string type doc = string type usage_msg = string type anon_fun = (string -> unit) val parse : (key * spec * doc) list -> anon_fun -> usage_msg -> unit (** [Arg.parse speclist anon_fun usage_msg] parses the command line. [speclist] is a list of triples [(key, spec, doc)]. [key] is the option keyword, it must start with a ['-'] character. [spec] gives the option type and the function to call when this option is found on the command line. [doc] is a one-line description of this option. [anon_fun] is called on anonymous arguments. The functions in [spec] and [anon_fun] are called in the same order as their arguments appear on the command line. If an error occurs, [Arg.parse] exits the program, after printing to standard error an error message as follows: - The reason for the error: unknown option, invalid or missing argument, etc. - [usage_msg] - The list of options, each followed by the corresponding [doc] string. Beware: options that have an empty [doc] string will not be included in the list. For the user to be able to specify anonymous arguments starting with a [-], include for example [("-", String anon_fun, doc)] in [speclist]. By default, [parse] recognizes two unit options, [-help] and [--help], which will print to standard output [usage_msg] and the list of options, and exit the program. You can override this behaviour by specifying your own [-help] and [--help] options in [speclist]. *) val parse_argv : ?current: int ref -> string array -> (key * spec * doc) list -> anon_fun -> usage_msg -> unit (** [Arg.parse_argv ~current args speclist anon_fun usage_msg] parses the array [args] as if it were the command line. It uses and updates the value of [~current] (if given), or [Arg.current]. You must set it before calling [parse_argv]. The initial value of [current] is the index of the program name (argument 0) in the array. If an error occurs, [Arg.parse_argv] raises [Arg.Bad] with the error message as argument. If option [-help] or [--help] is given, [Arg.parse_argv] raises [Arg.Help] with the help message as argument. *) exception Help of string (** Raised by [Arg.parse_argv] when the user asks for help. *) exception Bad of string (** Functions in [spec] or [anon_fun] can raise [Arg.Bad] with an error message to reject invalid arguments. [Arg.Bad] is also raised by [Arg.parse_argv] in case of an error. *) val usage : (key * spec * doc) list -> usage_msg -> unit (** [Arg.usage speclist usage_msg] prints to standard error an error message that includes the list of valid options. This is the same message that {!Arg.parse} prints in case of error. [speclist] and [usage_msg] are the same as for [Arg.parse]. *) val usage_string : (key * spec * doc) list -> usage_msg -> string (** Returns the message that would have been printed by {!Arg.usage}, if provided with the same parameters. *) val align: (key * spec * doc) list -> (key * spec * doc) list;; (** Align the documentation strings by inserting spaces at the first space, according to the length of the keyword. Use a space as the first character in a doc string if you want to align the whole string. The doc strings corresponding to [Symbol] arguments are aligned on the next line. *) val current : int ref (** Position (in {!Sys.argv}) of the argument being processed. You can change this value, e.g. to force {!Arg.parse} to skip some arguments. {!Arg.parse} uses the initial value of {!Arg.current} as the index of argument 0 (the program name) and starts parsing arguments at the next element. *) mingw-ocaml/ocaml/stdlib/array.mli0000644000175000017500000002115112124403240016557 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Array operations. *) external length : 'a array -> int = "%array_length" (** Return the length (number of elements) of the given array. *) external get : 'a array -> int -> 'a = "%array_safe_get" (** [Array.get a n] returns the element number [n] of array [a]. The first element has number 0. The last element has number [Array.length a - 1]. You can also write [a.(n)] instead of [Array.get a n]. Raise [Invalid_argument "index out of bounds"] if [n] is outside the range 0 to [(Array.length a - 1)]. *) external set : 'a array -> int -> 'a -> unit = "%array_safe_set" (** [Array.set a n x] modifies array [a] in place, replacing element number [n] with [x]. You can also write [a.(n) <- x] instead of [Array.set a n x]. Raise [Invalid_argument "index out of bounds"] if [n] is outside the range 0 to [Array.length a - 1]. *) external make : int -> 'a -> 'a array = "caml_make_vect" (** [Array.make n x] returns a fresh array of length [n], initialized with [x]. All the elements of this new array are initially physically equal to [x] (in the sense of the [==] predicate). Consequently, if [x] is mutable, it is shared among all elements of the array, and modifying [x] through one of the array entries will modify all other entries at the same time. Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. If the value of [x] is a floating-point number, then the maximum size is only [Sys.max_array_length / 2].*) external create : int -> 'a -> 'a array = "caml_make_vect" (** @deprecated [Array.create] is an alias for {!Array.make}. *) val init : int -> (int -> 'a) -> 'a array (** [Array.init n f] returns a fresh array of length [n], with element number [i] initialized to the result of [f i]. In other terms, [Array.init n f] tabulates the results of [f] applied to the integers [0] to [n-1]. Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. If the return type of [f] is [float], then the maximum size is only [Sys.max_array_length / 2].*) val make_matrix : int -> int -> 'a -> 'a array array (** [Array.make_matrix dimx dimy e] returns a two-dimensional array (an array of arrays) with first dimension [dimx] and second dimension [dimy]. All the elements of this new matrix are initially physically equal to [e]. The element ([x,y]) of a matrix [m] is accessed with the notation [m.(x).(y)]. Raise [Invalid_argument] if [dimx] or [dimy] is negative or greater than [Sys.max_array_length]. If the value of [e] is a floating-point number, then the maximum size is only [Sys.max_array_length / 2]. *) val create_matrix : int -> int -> 'a -> 'a array array (** @deprecated [Array.create_matrix] is an alias for {!Array.make_matrix}. *) val append : 'a array -> 'a array -> 'a array (** [Array.append v1 v2] returns a fresh array containing the concatenation of the arrays [v1] and [v2]. *) val concat : 'a array list -> 'a array (** Same as [Array.append], but concatenates a list of arrays. *) val sub : 'a array -> int -> int -> 'a array (** [Array.sub a start len] returns a fresh array of length [len], containing the elements number [start] to [start + len - 1] of array [a]. Raise [Invalid_argument "Array.sub"] if [start] and [len] do not designate a valid subarray of [a]; that is, if [start < 0], or [len < 0], or [start + len > Array.length a]. *) val copy : 'a array -> 'a array (** [Array.copy a] returns a copy of [a], that is, a fresh array containing the same elements as [a]. *) val fill : 'a array -> int -> int -> 'a -> unit (** [Array.fill a ofs len x] modifies the array [a] in place, storing [x] in elements number [ofs] to [ofs + len - 1]. Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not designate a valid subarray of [a]. *) val blit : 'a array -> int -> 'a array -> int -> int -> unit (** [Array.blit v1 o1 v2 o2 len] copies [len] elements from array [v1], starting at element number [o1], to array [v2], starting at element number [o2]. It works correctly even if [v1] and [v2] are the same array, and the source and destination chunks overlap. Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not designate a valid subarray of [v1], or if [o2] and [len] do not designate a valid subarray of [v2]. *) val to_list : 'a array -> 'a list (** [Array.to_list a] returns the list of all the elements of [a]. *) val of_list : 'a list -> 'a array (** [Array.of_list l] returns a fresh array containing the elements of [l]. *) val iter : ('a -> unit) -> 'a array -> unit (** [Array.iter f a] applies function [f] in turn to all the elements of [a]. It is equivalent to [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *) val map : ('a -> 'b) -> 'a array -> 'b array (** [Array.map f a] applies function [f] to all the elements of [a], and builds an array with the results returned by [f]: [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *) val iteri : (int -> 'a -> unit) -> 'a array -> unit (** Same as {!Array.iter}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array (** Same as {!Array.map}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a (** [Array.fold_left f x a] computes [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], where [n] is the length of the array [a]. *) val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a (** [Array.fold_right f a x] computes [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))], where [n] is the length of the array [a]. *) (** {6 Sorting} *) val sort : ('a -> 'a -> int) -> 'a array -> unit (** Sort an array in increasing order according to a comparison function. The comparison function must return 0 if its arguments compare as equal, a positive integer if the first is greater, and a negative integer if the first is smaller (see below for a complete specification). For example, {!Pervasives.compare} is a suitable comparison function, provided there are no floating-point NaN values in the data. After calling [Array.sort], the array is sorted in place in increasing order. [Array.sort] is guaranteed to run in constant heap space and (at most) logarithmic stack space. The current implementation uses Heap Sort. It runs in constant stack space. Specification of the comparison function: Let [a] be the array and [cmp] the comparison function. The following must be true for all x, y, z in a : - [cmp x y] > 0 if and only if [cmp y x] < 0 - if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0 When [Array.sort] returns, [a] contains the same elements as before, reordered in such a way that for all i and j valid indices of [a] : - [cmp a.(i) a.(j)] >= 0 if and only if i >= j *) val stable_sort : ('a -> 'a -> int) -> 'a array -> unit (** Same as {!Array.sort}, but the sorting algorithm is stable (i.e. elements that compare equal are kept in their original order) and not guaranteed to run in constant heap space. The current implementation uses Merge Sort. It uses [n/2] words of heap space, where [n] is the length of the array. It is usually faster than the current implementation of {!Array.sort}. *) val fast_sort : ('a -> 'a -> int) -> 'a array -> unit (** Same as {!Array.sort} or {!Array.stable_sort}, whichever is faster on typical input. *) (**/**) (** {6 Undocumented functions} *) (* The following is for system use only. Do not call directly. *) external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" mingw-ocaml/ocaml/stdlib/printf.mli0000644000175000017500000002231312124403240016744 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Pierre Weis, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Formatted output functions. *) val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a (** [fprintf outchan format arg1 ... argN] formats the arguments [arg1] to [argN] according to the format string [format], and outputs the resulting string on the channel [outchan]. The format string is a character string which contains two types of objects: plain characters, which are simply copied to the output channel, and conversion specifications, each of which causes conversion and printing of arguments. Conversion specifications have the following form: [% [flags] [width] [.precision] type] In short, a conversion specification consists in the [%] character, followed by optional modifiers and a type which is made of one or two characters. The types and their meanings are: - [d], [i]: convert an integer argument to signed decimal. - [u], [n], [l], [L], or [N]: convert an integer argument to unsigned decimal. Warning: [n], [l], [L], and [N] are used for [scanf], and should not be used for [printf]. - [x]: convert an integer argument to unsigned hexadecimal, using lowercase letters. - [X]: convert an integer argument to unsigned hexadecimal, using uppercase letters. - [o]: convert an integer argument to unsigned octal. - [s]: insert a string argument. - [S]: convert a string argument to OCaml syntax (double quotes, escapes). - [c]: insert a character argument. - [C]: convert a character argument to OCaml syntax (single quotes, escapes). - [f]: convert a floating-point argument to decimal notation, in the style [dddd.ddd]. - [F]: convert a floating-point argument to OCaml syntax ([dddd.] or [dddd.ddd] or [d.ddd e+-dd]). - [e] or [E]: convert a floating-point argument to decimal notation, in the style [d.ddd e+-dd] (mantissa and exponent). - [g] or [G]: convert a floating-point argument to decimal notation, in style [f] or [e], [E] (whichever is more compact). - [B]: convert a boolean argument to the string [true] or [false] - [b]: convert a boolean argument (deprecated; do not use in new programs). - [ld], [li], [lu], [lx], [lX], [lo]: convert an [int32] argument to the format specified by the second letter (decimal, hexadecimal, etc). - [nd], [ni], [nu], [nx], [nX], [no]: convert a [nativeint] argument to the format specified by the second letter. - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: convert an [int64] argument to the format specified by the second letter. - [a]: user-defined printer. Take two arguments and apply the first one to [outchan] (the current output channel) and to the second argument. The first argument must therefore have type [out_channel -> 'b -> unit] and the second ['b]. The output produced by the function is inserted in the output of [fprintf] at the current point. - [t]: same as [%a], but take only one argument (with type [out_channel -> unit]) and apply it to [outchan]. - [\{ fmt %\}]: convert a format string argument. The argument must have the same type as the internal format string [fmt]. - [( fmt %)]: format string substitution. Take a format string argument and substitute it to the internal format string [fmt] to print following arguments. The argument must have the same type as the internal format string [fmt]. - [!]: take no argument and flush the output. - [%]: take no argument and output one [%] character. - [\@]: take no argument and output one [\@] character. - [,]: take no argument and do nothing. The optional [flags] are: - [-]: left-justify the output (default is right justification). - [0]: for numerical conversions, pad with zeroes instead of spaces. - [+]: for signed numerical conversions, prefix number with a [+] sign if positive. - space: for signed numerical conversions, prefix number with a space if positive. - [#]: request an alternate formatting style for numbers. The optional [width] is an integer indicating the minimal width of the result. For instance, [%6d] prints an integer, prefixing it with spaces to fill at least 6 characters. The optional [precision] is a dot [.] followed by an integer indicating how many digits follow the decimal point in the [%f], [%e], and [%E] conversions. For instance, [%.4f] prints a [float] with 4 fractional digits. The integer in a [width] or [precision] can also be specified as [*], in which case an extra integer argument is taken to specify the corresponding [width] or [precision]. This integer argument precedes immediately the argument to print. For instance, [%.*f] prints a [float] with as many fractional digits as the value of the argument given before the float. *) val printf : ('a, out_channel, unit) format -> 'a (** Same as {!Printf.fprintf}, but output on [stdout]. *) val eprintf : ('a, out_channel, unit) format -> 'a (** Same as {!Printf.fprintf}, but output on [stderr]. *) val ifprintf : 'a -> ('b, 'a, unit) format -> 'b (** Same as {!Printf.fprintf}, but does not print anything. Useful to ignore some material when conditionally printing. @since 3.10.0 *) val sprintf : ('a, unit, string) format -> 'a (** Same as {!Printf.fprintf}, but instead of printing on an output channel, return a string containing the result of formatting the arguments. *) val bprintf : Buffer.t -> ('a, Buffer.t, unit) format -> 'a (** Same as {!Printf.fprintf}, but instead of printing on an output channel, append the formatted arguments to the given extensible buffer (see module {!Buffer}). *) (** Formatted output functions with continuations. *) val kfprintf : (out_channel -> 'a) -> out_channel -> ('b, out_channel, unit, 'a) format4 -> 'b;; (** Same as [fprintf], but instead of returning immediately, passes the out channel to its first argument at the end of printing. @since 3.09.0 *) val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; (** Same as [sprintf] above, but instead of returning the string, passes it to the first argument. @since 3.09.0 *) val kbprintf : (Buffer.t -> 'a) -> Buffer.t -> ('b, Buffer.t, unit, 'a) format4 -> 'b;; (** Same as [bprintf], but instead of returning immediately, passes the buffer to its first argument at the end of printing. @since 3.10.0 *) (** Deprecated *) val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; (** A deprecated synonym for [ksprintf]. *) (**/**) (* The following is for system use only. Do not call directly. *) module CamlinternalPr : sig module Sformat : sig type index;; val index_of_int : int -> index;; external int_of_index : index -> int = "%identity";; external unsafe_index_of_int : int -> index = "%identity";; val succ_index : index -> index;; val sub : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> index -> int -> string;; val to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string;; external length : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int = "%string_length";; external get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char = "%string_safe_get";; external unsafe_to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity";; external unsafe_get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char = "%string_unsafe_get";; end;; module Tformat : sig type ac = { mutable ac_rglr : int; mutable ac_skip : int; mutable ac_rdrs : int; };; val ac_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ac;; val sub_format : (('a, 'b, 'c, 'd, 'e, 'f) format6 -> int) -> (('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char -> int) -> char -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> int val summarize_format_type : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string val scan_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g array -> Sformat.index -> int -> (Sformat.index -> string -> int -> 'h) -> (Sformat.index -> 'i -> 'j -> int -> 'h) -> (Sformat.index -> 'k -> int -> 'h) -> (Sformat.index -> int -> 'h) -> (Sformat.index -> ('l, 'm, 'n, 'o, 'p, 'q) format6 -> int -> 'h) -> 'h val kapr : (('a, 'b, 'c, 'd, 'e, 'f) format6 -> Obj.t array -> 'g) -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g end;; end;; mingw-ocaml/ocaml/stdlib/camlinternalOO.ml0000644000175000017500000004327012124403240020205 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) open Obj (**** Object representation ****) let last_id = ref 0 let () = Callback.register "CamlinternalOO.last_id" last_id let set_id o id = let id0 = !id in Array.unsafe_set (Obj.magic o : int array) 1 id0; id := id0 + 1 (**** Object copy ****) let copy o = let o = (Obj.obj (Obj.dup (Obj.repr o))) in set_id o last_id; o (**** Compression options ****) (* Parameters *) type params = { mutable compact_table : bool; mutable copy_parent : bool; mutable clean_when_copying : bool; mutable retry_count : int; mutable bucket_small_size : int } let params = { compact_table = true; copy_parent = true; clean_when_copying = true; retry_count = 3; bucket_small_size = 16 } (**** Parameters ****) let step = Sys.word_size / 16 let initial_object_size = 2 (**** Items ****) type item = DummyA | DummyB | DummyC of int let dummy_item = (magic () : item) (**** Types ****) type tag type label = int type closure = item type t = DummyA | DummyB | DummyC of int type obj = t array external ret : (obj -> 'a) -> closure = "%identity" (**** Labels ****) let public_method_label s : tag = let accu = ref 0 in for i = 0 to String.length s - 1 do accu := 223 * !accu + Char.code s.[i] done; (* reduce to 31 bits *) accu := !accu land (1 lsl 31 - 1); (* make it signed for 64 bits architectures *) let tag = if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu in (* Printf.eprintf "%s = %d\n" s tag; flush stderr; *) magic tag (**** Sparse array ****) module Vars = Map.Make(struct type t = string let compare = compare end) type vars = int Vars.t module Meths = Map.Make(struct type t = string let compare = compare end) type meths = label Meths.t module Labs = Map.Make(struct type t = label let compare = compare end) type labs = bool Labs.t (* The compiler assumes that the first field of this structure is [size]. *) type table = { mutable size: int; mutable methods: closure array; mutable methods_by_name: meths; mutable methods_by_label: labs; mutable previous_states: (meths * labs * (label * item) list * vars * label list * string list) list; mutable hidden_meths: (label * item) list; mutable vars: vars; mutable initializers: (obj -> unit) list } let dummy_table = { methods = [| dummy_item |]; methods_by_name = Meths.empty; methods_by_label = Labs.empty; previous_states = []; hidden_meths = []; vars = Vars.empty; initializers = []; size = 0 } let table_count = ref 0 (* dummy_met should be a pointer, so use an atom *) let dummy_met : item = obj (Obj.new_block 0 0) (* if debugging is needed, this could be a good idea: *) (* let dummy_met () = failwith "Undefined method" *) let rec fit_size n = if n <= 2 then n else fit_size ((n+1)/2) * 2 let new_table pub_labels = incr table_count; let len = Array.length pub_labels in let methods = Array.create (len*2+2) dummy_met in methods.(0) <- magic len; methods.(1) <- magic (fit_size len * Sys.word_size / 8 - 1); for i = 0 to len - 1 do methods.(i*2+3) <- magic pub_labels.(i) done; { methods = methods; methods_by_name = Meths.empty; methods_by_label = Labs.empty; previous_states = []; hidden_meths = []; vars = Vars.empty; initializers = []; size = initial_object_size } let resize array new_size = let old_size = Array.length array.methods in if new_size > old_size then begin let new_buck = Array.create new_size dummy_met in Array.blit array.methods 0 new_buck 0 old_size; array.methods <- new_buck end let put array label element = resize array (label + 1); array.methods.(label) <- element (**** Classes ****) let method_count = ref 0 let inst_var_count = ref 0 (* type t *) type meth = item let new_method table = let index = Array.length table.methods in resize table (index + 1); index let get_method_label table name = try Meths.find name table.methods_by_name with Not_found -> let label = new_method table in table.methods_by_name <- Meths.add name label table.methods_by_name; table.methods_by_label <- Labs.add label true table.methods_by_label; label let get_method_labels table names = Array.map (get_method_label table) names let set_method table label element = incr method_count; if Labs.find label table.methods_by_label then put table label element else table.hidden_meths <- (label, element) :: table.hidden_meths let get_method table label = try List.assoc label table.hidden_meths with Not_found -> table.methods.(label) let to_list arr = if arr == magic 0 then [] else Array.to_list arr let narrow table vars virt_meths concr_meths = let vars = to_list vars and virt_meths = to_list virt_meths and concr_meths = to_list concr_meths in let virt_meth_labs = List.map (get_method_label table) virt_meths in let concr_meth_labs = List.map (get_method_label table) concr_meths in table.previous_states <- (table.methods_by_name, table.methods_by_label, table.hidden_meths, table.vars, virt_meth_labs, vars) :: table.previous_states; table.vars <- Vars.fold (fun lab info tvars -> if List.mem lab vars then Vars.add lab info tvars else tvars) table.vars Vars.empty; let by_name = ref Meths.empty in let by_label = ref Labs.empty in List.iter2 (fun met label -> by_name := Meths.add met label !by_name; by_label := Labs.add label (try Labs.find label table.methods_by_label with Not_found -> true) !by_label) concr_meths concr_meth_labs; List.iter2 (fun met label -> by_name := Meths.add met label !by_name; by_label := Labs.add label false !by_label) virt_meths virt_meth_labs; table.methods_by_name <- !by_name; table.methods_by_label <- !by_label; table.hidden_meths <- List.fold_right (fun ((lab, _) as met) hm -> if List.mem lab virt_meth_labs then hm else met::hm) table.hidden_meths [] let widen table = let (by_name, by_label, saved_hidden_meths, saved_vars, virt_meths, vars) = List.hd table.previous_states in table.previous_states <- List.tl table.previous_states; table.vars <- List.fold_left (fun s v -> Vars.add v (Vars.find v table.vars) s) saved_vars vars; table.methods_by_name <- by_name; table.methods_by_label <- by_label; table.hidden_meths <- List.fold_right (fun ((lab, _) as met) hm -> if List.mem lab virt_meths then hm else met::hm) table.hidden_meths saved_hidden_meths let new_slot table = let index = table.size in table.size <- index + 1; index let new_variable table name = try Vars.find name table.vars with Not_found -> let index = new_slot table in if name <> "" then table.vars <- Vars.add name index table.vars; index let to_array arr = if arr = Obj.magic 0 then [||] else arr let new_methods_variables table meths vals = let meths = to_array meths in let nmeths = Array.length meths and nvals = Array.length vals in let res = Array.create (nmeths + nvals) 0 in for i = 0 to nmeths - 1 do res.(i) <- get_method_label table meths.(i) done; for i = 0 to nvals - 1 do res.(i+nmeths) <- new_variable table vals.(i) done; res let get_variable table name = try Vars.find name table.vars with Not_found -> assert false let get_variables table names = Array.map (get_variable table) names let add_initializer table f = table.initializers <- f::table.initializers (* module Keys = Map.Make(struct type t = tag array let compare = compare end) let key_map = ref Keys.empty let get_key tags : item = try magic (Keys.find tags !key_map : tag array) with Not_found -> key_map := Keys.add tags tags !key_map; magic tags *) let create_table public_methods = if public_methods == magic 0 then new_table [||] else (* [public_methods] must be in ascending order for bytecode *) let tags = Array.map public_method_label public_methods in let table = new_table tags in Array.iteri (fun i met -> let lab = i*2+2 in table.methods_by_name <- Meths.add met lab table.methods_by_name; table.methods_by_label <- Labs.add lab true table.methods_by_label) public_methods; table let init_class table = inst_var_count := !inst_var_count + table.size - 1; table.initializers <- List.rev table.initializers; resize table (3 + magic table.methods.(1) * 16 / Sys.word_size) let inherits cla vals virt_meths concr_meths (_, super, _, env) top = narrow cla vals virt_meths concr_meths; let init = if top then super cla env else Obj.repr (super cla) in widen cla; Array.concat [[| repr init |]; magic (Array.map (get_variable cla) (to_array vals) : int array); Array.map (fun nm -> repr (get_method cla (get_method_label cla nm) : closure)) (to_array concr_meths) ] let make_class pub_meths class_init = let table = create_table pub_meths in let env_init = class_init table in init_class table; (env_init (Obj.repr 0), class_init, env_init, Obj.repr 0) type init_table = { mutable env_init: t; mutable class_init: table -> t } let make_class_store pub_meths class_init init_table = let table = create_table pub_meths in let env_init = class_init table in init_class table; init_table.class_init <- class_init; init_table.env_init <- env_init let dummy_class loc = let undef = fun _ -> raise (Undefined_recursive_module loc) in (Obj.magic undef, undef, undef, Obj.repr 0) (**** Objects ****) let create_object table = (* XXX Appel de [obj_block] *) let obj = Obj.new_block Obj.object_tag table.size in (* XXX Appel de [caml_modify] *) Obj.set_field obj 0 (Obj.repr table.methods); set_id obj last_id; (Obj.obj obj) let create_object_opt obj_0 table = if (Obj.magic obj_0 : bool) then obj_0 else begin (* XXX Appel de [obj_block] *) let obj = Obj.new_block Obj.object_tag table.size in (* XXX Appel de [caml_modify] *) Obj.set_field obj 0 (Obj.repr table.methods); set_id obj last_id; (Obj.obj obj) end let rec iter_f obj = function [] -> () | f::l -> f obj; iter_f obj l let run_initializers obj table = let inits = table.initializers in if inits <> [] then iter_f obj inits let run_initializers_opt obj_0 obj table = if (Obj.magic obj_0 : bool) then obj else begin let inits = table.initializers in if inits <> [] then iter_f obj inits; obj end let create_object_and_run_initializers obj_0 table = if (Obj.magic obj_0 : bool) then obj_0 else begin let obj = create_object table in run_initializers obj table; obj end (* Equivalent primitive below let sendself obj lab = (magic obj : (obj -> t) array array).(0).(lab) obj *) external send : obj -> tag -> 'a = "%send" external sendcache : obj -> tag -> t -> int -> 'a = "%sendcache" external sendself : obj -> label -> 'a = "%sendself" external get_public_method : obj -> tag -> closure = "caml_get_public_method" "noalloc" (**** table collection access ****) type tables = Empty | Cons of closure * tables * tables type mut_tables = {key: closure; mutable data: tables; mutable next: tables} external mut : tables -> mut_tables = "%identity" let build_path n keys tables = let res = Cons (Obj.magic 0, Empty, Empty) in let r = ref res in for i = 0 to n do r := Cons (keys.(i), !r, Empty) done; tables.data <- !r; res let rec lookup_keys i keys tables = if i < 0 then tables else let key = keys.(i) in let rec lookup_key tables = if tables.key == key then lookup_keys (i-1) keys tables.data else if tables.next <> Empty then lookup_key (mut tables.next) else let next = Cons (key, Empty, Empty) in tables.next <- next; build_path (i-1) keys (mut next) in lookup_key (mut tables) let lookup_tables root keys = let root = mut root in if root.data <> Empty then lookup_keys (Array.length keys - 1) keys root.data else build_path (Array.length keys - 1) keys root (**** builtin methods ****) let get_const x = ret (fun obj -> x) let get_var n = ret (fun obj -> Array.unsafe_get obj n) let get_env e n = ret (fun obj -> Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n) let get_meth n = ret (fun obj -> sendself obj n) let set_var n = ret (fun obj x -> Array.unsafe_set obj n x) let app_const f x = ret (fun obj -> f x) let app_var f n = ret (fun obj -> f (Array.unsafe_get obj n)) let app_env f e n = ret (fun obj -> f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n)) let app_meth f n = ret (fun obj -> f (sendself obj n)) let app_const_const f x y = ret (fun obj -> f x y) let app_const_var f x n = ret (fun obj -> f x (Array.unsafe_get obj n)) let app_const_meth f x n = ret (fun obj -> f x (sendself obj n)) let app_var_const f n x = ret (fun obj -> f (Array.unsafe_get obj n) x) let app_meth_const f n x = ret (fun obj -> f (sendself obj n) x) let app_const_env f x e n = ret (fun obj -> f x (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n)) let app_env_const f e n x = ret (fun obj -> f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n) x) let meth_app_const n x = ret (fun obj -> (sendself obj n : _ -> _) x) let meth_app_var n m = ret (fun obj -> (sendself obj n : _ -> _) (Array.unsafe_get obj m)) let meth_app_env n e m = ret (fun obj -> (sendself obj n : _ -> _) (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) m)) let meth_app_meth n m = ret (fun obj -> (sendself obj n : _ -> _) (sendself obj m)) let send_const m x c = ret (fun obj -> sendcache x m (Array.unsafe_get obj 0) c) let send_var m n c = ret (fun obj -> sendcache (Obj.magic (Array.unsafe_get obj n) : obj) m (Array.unsafe_get obj 0) c) let send_env m e n c = ret (fun obj -> sendcache (Obj.magic (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n) : obj) m (Array.unsafe_get obj 0) c) let send_meth m n c = ret (fun obj -> sendcache (sendself obj n) m (Array.unsafe_get obj 0) c) let new_cache table = let n = new_method table in let n = if n mod 2 = 0 || n > 2 + magic table.methods.(1) * 16 / Sys.word_size then n else new_method table in table.methods.(n) <- Obj.magic 0; n type impl = GetConst | GetVar | GetEnv | GetMeth | SetVar | AppConst | AppVar | AppEnv | AppMeth | AppConstConst | AppConstVar | AppConstEnv | AppConstMeth | AppVarConst | AppEnvConst | AppMethConst | MethAppConst | MethAppVar | MethAppEnv | MethAppMeth | SendConst | SendVar | SendEnv | SendMeth | Closure of closure let method_impl table i arr = let next () = incr i; magic arr.(!i) in match next() with GetConst -> let x : t = next() in get_const x | GetVar -> let n = next() in get_var n | GetEnv -> let e = next() and n = next() in get_env e n | GetMeth -> let n = next() in get_meth n | SetVar -> let n = next() in set_var n | AppConst -> let f = next() and x = next() in app_const f x | AppVar -> let f = next() and n = next () in app_var f n | AppEnv -> let f = next() and e = next() and n = next() in app_env f e n | AppMeth -> let f = next() and n = next () in app_meth f n | AppConstConst -> let f = next() and x = next() and y = next() in app_const_const f x y | AppConstVar -> let f = next() and x = next() and n = next() in app_const_var f x n | AppConstEnv -> let f = next() and x = next() and e = next () and n = next() in app_const_env f x e n | AppConstMeth -> let f = next() and x = next() and n = next() in app_const_meth f x n | AppVarConst -> let f = next() and n = next() and x = next() in app_var_const f n x | AppEnvConst -> let f = next() and e = next () and n = next() and x = next() in app_env_const f e n x | AppMethConst -> let f = next() and n = next() and x = next() in app_meth_const f n x | MethAppConst -> let n = next() and x = next() in meth_app_const n x | MethAppVar -> let n = next() and m = next() in meth_app_var n m | MethAppEnv -> let n = next() and e = next() and m = next() in meth_app_env n e m | MethAppMeth -> let n = next() and m = next() in meth_app_meth n m | SendConst -> let m = next() and x = next() in send_const m x (new_cache table) | SendVar -> let m = next() and n = next () in send_var m n (new_cache table) | SendEnv -> let m = next() and e = next() and n = next() in send_env m e n (new_cache table) | SendMeth -> let m = next() and n = next () in send_meth m n (new_cache table) | Closure _ as clo -> magic clo let set_methods table methods = let len = Array.length methods and i = ref 0 in while !i < len do let label = methods.(!i) and clo = method_impl table i methods in set_method table label clo; incr i done (**** Statistics ****) type stats = { classes: int; methods: int; inst_vars: int; } let stats () = { classes = !table_count; methods = !method_count; inst_vars = !inst_var_count; } mingw-ocaml/ocaml/stdlib/.ignore0000644000175000017500000000007412124403240016223 0ustar tootstootscamlheader camlheaderd camlheader_ur labelled-* caml sys.ml mingw-ocaml/ocaml/stdlib/obj.ml0000644000175000017500000000430512124403240016044 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Operations on internal representations of values *) type t external repr : 'a -> t = "%identity" external obj : t -> 'a = "%identity" external magic : 'a -> 'b = "%identity" external is_block : t -> bool = "caml_obj_is_block" external is_int : t -> bool = "%obj_is_int" external tag : t -> int = "caml_obj_tag" external set_tag : t -> int -> unit = "caml_obj_set_tag" external size : t -> int = "%obj_size" external field : t -> int -> t = "%obj_field" external set_field : t -> int -> t -> unit = "%obj_set_field" let double_field x i = Array.get (obj x : float array) i let set_double_field x i v = Array.set (obj x : float array) i v external new_block : int -> int -> t = "caml_obj_block" external dup : t -> t = "caml_obj_dup" external truncate : t -> int -> unit = "caml_obj_truncate" external add_offset : t -> Int32.t -> t = "caml_obj_add_offset" let marshal (obj : t) = Marshal.to_string obj [] let unmarshal str pos = (Marshal.from_string str pos, pos + Marshal.total_size str pos) let lazy_tag = 246 let closure_tag = 247 let object_tag = 248 let infix_tag = 249 let forward_tag = 250 let no_scan_tag = 251 let abstract_tag = 251 let string_tag = 252 let double_tag = 253 let double_array_tag = 254 let custom_tag = 255 let final_tag = custom_tag let int_tag = 1000 let out_of_heap_tag = 1001 let unaligned_tag = 1002 mingw-ocaml/ocaml/stdlib/buffer.ml0000644000175000017500000001340612124403240016545 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Extensible buffers *) type t = {mutable buffer : string; mutable position : int; mutable length : int; initial_buffer : string} let create n = let n = if n < 1 then 1 else n in let n = if n > Sys.max_string_length then Sys.max_string_length else n in let s = String.create n in {buffer = s; position = 0; length = n; initial_buffer = s} let contents b = String.sub b.buffer 0 b.position let sub b ofs len = if ofs < 0 || len < 0 || ofs > b.position - len then invalid_arg "Buffer.sub" else begin let r = String.create len in String.blit b.buffer ofs r 0 len; r end ;; let blit src srcoff dst dstoff len = if len < 0 || srcoff < 0 || srcoff > src.position - len || dstoff < 0 || dstoff > (String.length dst) - len then invalid_arg "Buffer.blit" else String.blit src.buffer srcoff dst dstoff len ;; let nth b ofs = if ofs < 0 || ofs >= b.position then invalid_arg "Buffer.nth" else String.get b.buffer ofs ;; let length b = b.position let clear b = b.position <- 0 let reset b = b.position <- 0; b.buffer <- b.initial_buffer; b.length <- String.length b.buffer let resize b more = let len = b.length in let new_len = ref len in while b.position + more > !new_len do new_len := 2 * !new_len done; if !new_len > Sys.max_string_length then begin if b.position + more <= Sys.max_string_length then new_len := Sys.max_string_length else failwith "Buffer.add: cannot grow buffer" end; let new_buffer = String.create !new_len in String.blit b.buffer 0 new_buffer 0 b.position; b.buffer <- new_buffer; b.length <- !new_len let add_char b c = let pos = b.position in if pos >= b.length then resize b 1; b.buffer.[pos] <- c; b.position <- pos + 1 let add_substring b s offset len = if offset < 0 || len < 0 || offset > String.length s - len then invalid_arg "Buffer.add_substring"; let new_position = b.position + len in if new_position > b.length then resize b len; String.blit s offset b.buffer b.position len; b.position <- new_position let add_string b s = let len = String.length s in let new_position = b.position + len in if new_position > b.length then resize b len; String.blit s 0 b.buffer b.position len; b.position <- new_position let add_buffer b bs = add_substring b bs.buffer 0 bs.position let add_channel b ic len = if len < 0 || len > Sys.max_string_length then (* PR#5004 *) invalid_arg "Buffer.add_channel"; if b.position + len > b.length then resize b len; really_input ic b.buffer b.position len; b.position <- b.position + len let output_buffer oc b = output oc b.buffer 0 b.position let closing = function | '(' -> ')' | '{' -> '}' | _ -> assert false;; (* opening and closing: open and close characters, typically ( and ) k: balance of opening and closing chars s: the string where we are searching start: the index where we start the search. *) let advance_to_closing opening closing k s start = let rec advance k i lim = if i >= lim then raise Not_found else if s.[i] = opening then advance (k + 1) (i + 1) lim else if s.[i] = closing then if k = 0 then i else advance (k - 1) (i + 1) lim else advance k (i + 1) lim in advance k start (String.length s);; let advance_to_non_alpha s start = let rec advance i lim = if i >= lim then lim else match s.[i] with | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | ''|''|''|''|''|''|''| ''|''|''|''|''|''|''| ''|''|''|''|''|''|''| ''|''|''|''|''|''|'' -> advance (i + 1) lim | _ -> i in advance start (String.length s);; (* We are just at the beginning of an ident in s, starting at start. *) let find_ident s start lim = if start >= lim then raise Not_found else match s.[start] with (* Parenthesized ident ? *) | '(' | '{' as c -> let new_start = start + 1 in let stop = advance_to_closing c (closing c) 0 s new_start in String.sub s new_start (stop - start - 1), stop + 1 (* Regular ident *) | _ -> let stop = advance_to_non_alpha s (start + 1) in String.sub s start (stop - start), stop;; (* Substitute $ident, $(ident), or ${ident} in s, according to the function mapping f. *) let add_substitute b f s = let lim = String.length s in let rec subst previous i = if i < lim then begin match s.[i] with | '$' as current when previous = '\\' -> add_char b current; subst ' ' (i + 1) | '$' -> let j = i + 1 in let ident, next_i = find_ident s j lim in add_string b (f ident); subst ' ' next_i | current when previous == '\\' -> add_char b '\\'; add_char b current; subst ' ' (i + 1) | '\\' as current -> subst current (i + 1) | current -> add_char b current; subst current (i + 1) end else if previous = '\\' then add_char b previous in subst ' ' 0;; mingw-ocaml/ocaml/stdlib/hashtbl.mli0000644000175000017500000003416312124403240017075 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Hash tables and hash functions. Hash tables are hashed association tables, with in-place modification. *) (** {6 Generic interface} *) type ('a, 'b) t (** The type of hash tables from type ['a] to type ['b]. *) val create : ?random:bool -> int -> ('a, 'b) t (** [Hashtbl.create n] creates a new, empty hash table, with initial size [n]. For best results, [n] should be on the order of the expected number of elements that will be in the table. The table grows as needed, so [n] is just an initial guess. The optional [random] parameter (a boolean) controls whether the internal organization of the hash table is randomized at each execution of [Hashtbl.create] or deterministic over all executions. A hash table that is created with [~random:false] uses a fixed hash function ({!Hashtbl.hash}) to distribute keys among buckets. As a consequence, collisions between keys happen deterministically. In Web-facing applications or other security-sensitive applications, the deterministic collision patterns can be exploited by a malicious user to create a denial-of-service attack: the attacker sends input crafted to create many collisions in the table, slowing the application down. A hash table that is created with [~random:true] uses the seeded hash function {!Hashtbl.seeded_hash} with a seed that is randomly chosen at hash table creation time. In effect, the hash function used is randomly selected among [2^{30}] different hash functions. All these hash functions have different collision patterns, rendering ineffective the denial-of-service attack described above. However, because of randomization, enumerating all elements of the hash table using {!Hashtbl.fold} or {!Hashtbl.iter} is no longer deterministic: elements are enumerated in different orders at different runs of the program. If no [~random] parameter is given, hash tables are created in non-random mode by default. This default can be changed either programmatically by calling {!Hashtbl.randomize} or by setting the [R] flag in the [OCAMLRUNPARAM] environment variable. @before 4.00.0 the [random] parameter was not present and all hash tables were created in non-randomized mode. *) val clear : ('a, 'b) t -> unit (** Empty a hash table. Use [reset] instead of [clear] to shrink the size of the bucket table to its initial size. *) val reset : ('a, 'b) t -> unit (** Empty a hash table and shrink the size of the bucket table to its initial size. *) val copy : ('a, 'b) t -> ('a, 'b) t (** Return a copy of the given hashtable. *) val add : ('a, 'b) t -> 'a -> 'b -> unit (** [Hashtbl.add tbl x y] adds a binding of [x] to [y] in table [tbl]. Previous bindings for [x] are not removed, but simply hidden. That is, after performing {!Hashtbl.remove}[ tbl x], the previous binding for [x], if any, is restored. (Same behavior as with association lists.) *) val find : ('a, 'b) t -> 'a -> 'b (** [Hashtbl.find tbl x] returns the current binding of [x] in [tbl], or raises [Not_found] if no such binding exists. *) val find_all : ('a, 'b) t -> 'a -> 'b list (** [Hashtbl.find_all tbl x] returns the list of all data associated with [x] in [tbl]. The current binding is returned first, then the previous bindings, in reverse order of introduction in the table. *) val mem : ('a, 'b) t -> 'a -> bool (** [Hashtbl.mem tbl x] checks if [x] is bound in [tbl]. *) val remove : ('a, 'b) t -> 'a -> unit (** [Hashtbl.remove tbl x] removes the current binding of [x] in [tbl], restoring the previous binding if it exists. It does nothing if [x] is not bound in [tbl]. *) val replace : ('a, 'b) t -> 'a -> 'b -> unit (** [Hashtbl.replace tbl x y] replaces the current binding of [x] in [tbl] by a binding of [x] to [y]. If [x] is unbound in [tbl], a binding of [x] to [y] is added to [tbl]. This is functionally equivalent to {!Hashtbl.remove}[ tbl x] followed by {!Hashtbl.add}[ tbl x y]. *) val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit (** [Hashtbl.iter f tbl] applies [f] to all bindings in table [tbl]. [f] receives the key as first argument, and the associated value as second argument. Each binding is presented exactly once to [f]. The order in which the bindings are passed to [f] is unspecified. However, if the table contains several bindings for the same key, they are passed to [f] in reverse order of introduction, that is, the most recent binding is passed first. If the hash table was created in non-randomized mode, the order in which the bindings are enumerated is reproducible between successive runs of the program, and even between minor versions of OCaml. For randomized hash tables, the order of enumeration is entirely random. *) val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c (** [Hashtbl.fold f tbl init] computes [(f kN dN ... (f k1 d1 init)...)], where [k1 ... kN] are the keys of all bindings in [tbl], and [d1 ... dN] are the associated values. Each binding is presented exactly once to [f]. The order in which the bindings are passed to [f] is unspecified. However, if the table contains several bindings for the same key, they are passed to [f] in reverse order of introduction, that is, the most recent binding is passed first. If the hash table was created in non-randomized mode, the order in which the bindings are enumerated is reproducible between successive runs of the program, and even between minor versions of OCaml. For randomized hash tables, the order of enumeration is entirely random. *) val length : ('a, 'b) t -> int (** [Hashtbl.length tbl] returns the number of bindings in [tbl]. It takes constant time. Multiple bindings are counted once each, so [Hashtbl.length] gives the number of times [Hashtbl.iter] calls its first argument. *) val randomize : unit -> unit (** After a call to [Hashtbl.randomize()], hash tables are created in randomized mode by default: {!Hashtbl.create} returns randomized hash tables, unless the [~random:false] optional parameter is given. The same effect can be achieved by setting the [R] parameter in the [OCAMLRUNPARAM] environment variable. It is recommended that applications or Web frameworks that need to protect themselves against the denial-of-service attack described in {!Hashtbl.create} call [Hashtbl.randomize()] at initialization time. Note that once [Hashtbl.randomize()] was called, there is no way to revert to the non-randomized default behavior of {!Hashtbl.create}. This is intentional. Non-randomized hash tables can still be created using [Hashtbl.create ~random:false]. @since 4.00.0 *) type statistics = { num_bindings: int; (** Number of bindings present in the table. Same value as returned by {!Hashtbl.length}. *) num_buckets: int; (** Number of buckets in the table. *) max_bucket_length: int; (** Maximal number of bindings per bucket. *) bucket_histogram: int array (** Histogram of bucket sizes. This array [histo] has length [max_bucket_length + 1]. The value of [histo.(i)] is the number of buckets whose size is [i]. *) } val stats : ('a, 'b) t -> statistics (** [Hashtbl.stats tbl] returns statistics about the table [tbl]: number of buckets, size of the biggest bucket, distribution of buckets by size. @since 4.00.0 *) (** {6 Functorial interface} *) module type HashedType = sig type t (** The type of the hashtable keys. *) val equal : t -> t -> bool (** The equality predicate used to compare keys. *) val hash : t -> int (** A hashing function on keys. It must be such that if two keys are equal according to [equal], then they have identical hash values as computed by [hash]. Examples: suitable ([equal], [hash]) pairs for arbitrary key types include - ([(=)], {!Hashtbl.hash}) for comparing objects by structure (provided objects do not contain floats) - ([(fun x y -> compare x y = 0)], {!Hashtbl.hash}) for comparing objects by structure and handling {!Pervasives.nan} correctly - ([(==)], {!Hashtbl.hash}) for comparing objects by physical equality (e.g. for mutable or cyclic objects). *) end (** The input signature of the functor {!Hashtbl.Make}. *) module type S = sig type key type 'a t val create : int -> 'a t val clear : 'a t -> unit val reset : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key -> 'a -> unit val remove : 'a t -> key -> unit val find : 'a t -> key -> 'a val find_all : 'a t -> key -> 'a list val replace : 'a t -> key -> 'a -> unit val mem : 'a t -> key -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val length : 'a t -> int val stats: 'a t -> statistics end (** The output signature of the functor {!Hashtbl.Make}. *) module Make (H : HashedType) : S with type key = H.t (** Functor building an implementation of the hashtable structure. The functor [Hashtbl.Make] returns a structure containing a type [key] of keys and a type ['a t] of hash tables associating data of type ['a] to keys of type [key]. The operations perform similarly to those of the generic interface, but use the hashing and equality functions specified in the functor argument [H] instead of generic equality and hashing. Since the hash function is not seeded, the [create] operation of the result structure always returns non-randomized hash tables. *) module type SeededHashedType = sig type t (** The type of the hashtable keys. *) val equal: t -> t -> bool (** The equality predicate used to compare keys. *) val hash: int -> t -> int (** A seeded hashing function on keys. The first argument is the seed. It must be the case that if [equal x y] is true, then [hash seed x = hash seed y] for any value of [seed]. A suitable choice for [hash] is the function {!Hashtbl.seeded_hash} below. *) end (** The input signature of the functor {!Hashtbl.MakeSeeded}. @since 4.00.0 *) module type SeededS = sig type key type 'a t val create : ?random:bool -> int -> 'a t val clear : 'a t -> unit val reset : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key -> 'a -> unit val remove : 'a t -> key -> unit val find : 'a t -> key -> 'a val find_all : 'a t -> key -> 'a list val replace : 'a t -> key -> 'a -> unit val mem : 'a t -> key -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val length : 'a t -> int val stats: 'a t -> statistics end (** The output signature of the functor {!Hashtbl.MakeSeeded}. @since 4.00.0 *) module MakeSeeded (H : SeededHashedType) : SeededS with type key = H.t (** Functor building an implementation of the hashtable structure. The functor [Hashtbl.MakeSeeded] returns a structure containing a type [key] of keys and a type ['a t] of hash tables associating data of type ['a] to keys of type [key]. The operations perform similarly to those of the generic interface, but use the seeded hashing and equality functions specified in the functor argument [H] instead of generic equality and hashing. The [create] operation of the result structure supports the [~random] optional parameter and returns randomized hash tables if [~random:true] is passed or if randomization is globally on (see {!Hashtbl.randomize}). @since 4.00.0 *) (** {6 The polymorphic hash functions} *) val hash : 'a -> int (** [Hashtbl.hash x] associates a nonnegative integer to any value of any type. It is guaranteed that if [x = y] or [Pervasives.compare x y = 0], then [hash x = hash y]. Moreover, [hash] always terminates, even on cyclic structures. *) val seeded_hash : int -> 'a -> int (** A variant of {!Hashtbl.hash} that is further parameterized by an integer seed. @since 4.00.0 *) val hash_param : int -> int -> 'a -> int (** [Hashtbl.hash_param meaningful total x] computes a hash value for [x], with the same properties as for [hash]. The two extra integer parameters [meaningful] and [total] give more precise control over hashing. Hashing performs a breadth-first, left-to-right traversal of the structure [x], stopping after [meaningful] meaningful nodes were encountered, or [total] nodes (meaningful or not) were encountered. Meaningful nodes are: integers; floating-point numbers; strings; characters; booleans; and constant constructors. Larger values of [meaningful] and [total] means that more nodes are taken into account to compute the final hash value, and therefore collisions are less likely to happen. However, hashing takes longer. The parameters [meaningful] and [total] govern the tradeoff between accuracy and speed. As default choices, {!Hashtbl.hash} and {!Hashtbl.seeded_hash} take [meaningful = 10] and [total = 100]. *) val seeded_hash_param : int -> int -> int -> 'a -> int (** A variant of {!Hashtbl.hash_param} that is further parameterized by an integer seed. Usage: [Hashtbl.seeded_hash_param meaningful total seed x]. @since 4.00.0 *) mingw-ocaml/ocaml/stdlib/format.ml0000644000175000017500000012563112124403240016570 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* A pretty-printing facility and definition of formatters for ``parallel'' (i.e. unrelated or independent) pretty-printing on multiple out channels. *) (************************************************************** Data structures definitions. **************************************************************) type size;; external size_of_int : int -> size = "%identity" ;; external int_of_size : size -> int = "%identity" ;; (* Tokens are one of the following : *) type pp_token = | Pp_text of string (* normal text *) | Pp_break of int * int (* complete break *) | Pp_tbreak of int * int (* go to next tabulation *) | Pp_stab (* set a tabulation *) | Pp_begin of int * block_type (* beginning of a block *) | Pp_end (* end of a block *) | Pp_tbegin of tblock (* beginning of a tabulation block *) | Pp_tend (* end of a tabulation block *) | Pp_newline (* to force a newline inside a block *) | Pp_if_newline (* to do something only if this very line has been broken *) | Pp_open_tag of string (* opening a tag name *) | Pp_close_tag (* closing the most recently opened tag *) and tag = string and block_type = | Pp_hbox (* Horizontal block no line breaking *) | Pp_vbox (* Vertical block each break leads to a new line *) | Pp_hvbox (* Horizontal-vertical block: same as vbox, except if this block is small enough to fit on a single line *) | Pp_hovbox (* Horizontal or Vertical block: breaks lead to new line only when necessary to print the content of the block *) | Pp_box (* Horizontal or Indent block: breaks lead to new line only when necessary to print the content of the block, or when it leads to a new indentation of the current line *) | Pp_fits (* Internal usage: when a block fits on a single line *) and tblock = | Pp_tbox of int list ref (* Tabulation box *) ;; (* The Queue: contains all formatting elements. elements are tuples (size, token, length), where size is set when the size of the block is known len is the declared length of the token. *) type pp_queue_elem = { mutable elem_size : size; token : pp_token; length : int; } ;; (* Scan stack: each element is (left_total, queue element) where left_total is the value of pp_left_total when the element has been enqueued. *) type pp_scan_elem = Scan_elem of int * pp_queue_elem;; (* Formatting stack: used to break the lines while printing tokens. The formatting stack contains the description of the currently active blocks. *) type pp_format_elem = Format_elem of block_type * int;; (* General purpose queues, used in the formatter. *) type 'a queue_elem = | Nil | Cons of 'a queue_cell and 'a queue_cell = { mutable head : 'a; mutable tail : 'a queue_elem; } ;; type 'a queue = { mutable insert : 'a queue_elem; mutable body : 'a queue_elem; } ;; (* The formatter specific tag handling functions. *) type formatter_tag_functions = { mark_open_tag : tag -> string; mark_close_tag : tag -> string; print_open_tag : tag -> unit; print_close_tag : tag -> unit; } ;; (* A formatter with all its machinery. *) type formatter = { mutable pp_scan_stack : pp_scan_elem list; mutable pp_format_stack : pp_format_elem list; mutable pp_tbox_stack : tblock list; mutable pp_tag_stack : tag list; mutable pp_mark_stack : tag list; (* Global variables: default initialization is set_margin 78 set_min_space_left 0. *) (* Value of right margin. *) mutable pp_margin : int; (* Minimal space left before margin, when opening a block. *) mutable pp_min_space_left : int; (* Maximum value of indentation: no blocks can be opened further. *) mutable pp_max_indent : int; (* Space remaining on the current line. *) mutable pp_space_left : int; (* Current value of indentation. *) mutable pp_current_indent : int; (* True when the line has been broken by the pretty-printer. *) mutable pp_is_new_line : bool; (* Total width of tokens already printed. *) mutable pp_left_total : int; (* Total width of tokens ever put in queue. *) mutable pp_right_total : int; (* Current number of opened blocks. *) mutable pp_curr_depth : int; (* Maximum number of blocks which can be simultaneously opened. *) mutable pp_max_boxes : int; (* Ellipsis string. *) mutable pp_ellipsis : string; (* Output function. *) mutable pp_output_function : string -> int -> int -> unit; (* Flushing function. *) mutable pp_flush_function : unit -> unit; (* Output of new lines. *) mutable pp_output_newline : unit -> unit; (* Output of indentation spaces. *) mutable pp_output_spaces : int -> unit; (* Are tags printed ? *) mutable pp_print_tags : bool; (* Are tags marked ? *) mutable pp_mark_tags : bool; (* Find opening and closing markers of tags. *) mutable pp_mark_open_tag : tag -> string; mutable pp_mark_close_tag : tag -> string; mutable pp_print_open_tag : tag -> unit; mutable pp_print_close_tag : tag -> unit; (* The pretty-printer queue. *) mutable pp_queue : pp_queue_elem queue; } ;; (************************************************************** Auxilliaries and basic functions. **************************************************************) (* Queues auxilliaries. *) let make_queue () = { insert = Nil; body = Nil; };; let clear_queue q = q.insert <- Nil; q.body <- Nil;; let add_queue x q = let c = Cons { head = x; tail = Nil; } in match q with | { insert = Cons cell; body = _; } -> q.insert <- c; cell.tail <- c (* Invariant: when insert is Nil body should be Nil. *) | { insert = Nil; body = _; } -> q.insert <- c; q.body <- c ;; exception Empty_queue;; let peek_queue = function | { body = Cons { head = x; tail = _; }; _ } -> x | { body = Nil; insert = _; } -> raise Empty_queue ;; let take_queue = function | { body = Cons { head = x; tail = tl; }; _ } as q -> q.body <- tl; if tl = Nil then q.insert <- Nil; (* Maintain the invariant. *) x | { body = Nil; insert = _; } -> raise Empty_queue ;; (* Enter a token in the pretty-printer queue. *) let pp_enqueue state ({ length = len; _} as token) = state.pp_right_total <- state.pp_right_total + len; add_queue token state.pp_queue ;; let pp_clear_queue state = state.pp_left_total <- 1; state.pp_right_total <- 1; clear_queue state.pp_queue ;; (* Pp_infinity: large value for default tokens size. Pp_infinity is documented as being greater than 1e10; to avoid confusion about the word ``greater'', we choose pp_infinity greater than 1e10 + 1; for correct handling of tests in the algorithm, pp_infinity must be even one more than 1e10 + 1; let's stand on the safe side by choosing 1.e10+10. Pp_infinity could probably be 1073741823 that is 2^30 - 1, that is the minimal upper bound for integers; now that max_int is defined, this limit could also be defined as max_int - 1. However, before setting pp_infinity to something around max_int, we must carefully double-check all the integer arithmetic operations that involve pp_infinity, since any overflow would wreck havoc the pretty-printing algorithm's invariants. Given that this arithmetic correctness check is difficult and error prone and given that 1e10 + 1 is in practice large enough, there is no need to attempt to set pp_infinity to the theoretically maximum limit. It is not worth the burden ! *) let pp_infinity = 1000000010;; (* Output functions for the formatter. *) let pp_output_string state s = state.pp_output_function s 0 (String.length s) and pp_output_newline state = state.pp_output_newline () and pp_display_blanks state n = state.pp_output_spaces n ;; (* To format a break, indenting a new line. *) let break_new_line state offset width = pp_output_newline state; state.pp_is_new_line <- true; let indent = state.pp_margin - width + offset in (* Don't indent more than pp_max_indent. *) let real_indent = min state.pp_max_indent indent in state.pp_current_indent <- real_indent; state.pp_space_left <- state.pp_margin - state.pp_current_indent; pp_display_blanks state state.pp_current_indent ;; (* To force a line break inside a block: no offset is added. *) let break_line state width = break_new_line state 0 width;; (* To format a break that fits on the current line. *) let break_same_line state width = state.pp_space_left <- state.pp_space_left - width; pp_display_blanks state width ;; (* To indent no more than pp_max_indent, if one tries to open a block beyond pp_max_indent, then the block is rejected on the left by simulating a break. *) let pp_force_break_line state = match state.pp_format_stack with | Format_elem (bl_ty, width) :: _ -> if width > state.pp_space_left then (match bl_ty with | Pp_fits -> () | Pp_hbox -> () | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box -> break_line state width) | [] -> pp_output_newline state ;; (* To skip a token, if the previous line has been broken. *) let pp_skip_token state = (* When calling pp_skip_token the queue cannot be empty. *) match take_queue state.pp_queue with | { elem_size = size; length = len; token = _; } -> state.pp_left_total <- state.pp_left_total - len; state.pp_space_left <- state.pp_space_left + int_of_size size ;; (************************************************************** The main pretty printing functions. **************************************************************) (* To format a token. *) let format_pp_token state size = function | Pp_text s -> state.pp_space_left <- state.pp_space_left - size; pp_output_string state s; state.pp_is_new_line <- false | Pp_begin (off, ty) -> let insertion_point = state.pp_margin - state.pp_space_left in if insertion_point > state.pp_max_indent then (* can't open a block right there. *) begin pp_force_break_line state end; let offset = state.pp_space_left - off in let bl_type = begin match ty with | Pp_vbox -> Pp_vbox | Pp_hbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits -> if size > state.pp_space_left then ty else Pp_fits end in state.pp_format_stack <- Format_elem (bl_type, offset) :: state.pp_format_stack | Pp_end -> begin match state.pp_format_stack with | _ :: ls -> state.pp_format_stack <- ls | [] -> () (* No more block to close. *) end | Pp_tbegin (Pp_tbox _ as tbox) -> state.pp_tbox_stack <- tbox :: state.pp_tbox_stack | Pp_tend -> begin match state.pp_tbox_stack with | _ :: ls -> state.pp_tbox_stack <- ls | [] -> () (* No more tabulation block to close. *) end | Pp_stab -> begin match state.pp_tbox_stack with | Pp_tbox tabs :: _ -> let rec add_tab n = function | [] -> [n] | x :: l as ls -> if n < x then n :: ls else x :: add_tab n l in tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs | [] -> () (* No opened tabulation block. *) end | Pp_tbreak (n, off) -> let insertion_point = state.pp_margin - state.pp_space_left in begin match state.pp_tbox_stack with | Pp_tbox tabs :: _ -> let rec find n = function | x :: l -> if x >= n then x else find n l | [] -> raise Not_found in let tab = match !tabs with | x :: _ -> begin try find insertion_point !tabs with | Not_found -> x end | _ -> insertion_point in let offset = tab - insertion_point in if offset >= 0 then break_same_line state (offset + n) else break_new_line state (tab + off) state.pp_margin | [] -> () (* No opened tabulation block. *) end | Pp_newline -> begin match state.pp_format_stack with | Format_elem (_, width) :: _ -> break_line state width | [] -> pp_output_newline state (* No opened block. *) end | Pp_if_newline -> if state.pp_current_indent != state.pp_margin - state.pp_space_left then pp_skip_token state | Pp_break (n, off) -> begin match state.pp_format_stack with | Format_elem (ty, width) :: _ -> begin match ty with | Pp_hovbox -> if size > state.pp_space_left then break_new_line state off width else break_same_line state n | Pp_box -> (* Have the line just been broken here ? *) if state.pp_is_new_line then break_same_line state n else if size > state.pp_space_left then break_new_line state off width else (* break the line here leads to new indentation ? *) if state.pp_current_indent > state.pp_margin - width + off then break_new_line state off width else break_same_line state n | Pp_hvbox -> break_new_line state off width | Pp_fits -> break_same_line state n | Pp_vbox -> break_new_line state off width | Pp_hbox -> break_same_line state n end | [] -> () (* No opened block. *) end | Pp_open_tag tag_name -> let marker = state.pp_mark_open_tag tag_name in pp_output_string state marker; state.pp_mark_stack <- tag_name :: state.pp_mark_stack | Pp_close_tag -> begin match state.pp_mark_stack with | tag_name :: tags -> let marker = state.pp_mark_close_tag tag_name in pp_output_string state marker; state.pp_mark_stack <- tags | [] -> () (* No more tag to close. *) end ;; (* Print if token size is known or printing is delayed. Size is known when not negative. Printing is delayed when the text waiting in the queue requires more room to format than exists on the current line. Note: [advance_loop] must be tail recursive to prevent stack overflows. *) let rec advance_loop state = match peek_queue state.pp_queue with | {elem_size = size; token = tok; length = len} -> let size = int_of_size size in if not (size < 0 && (state.pp_right_total - state.pp_left_total < state.pp_space_left)) then begin ignore (take_queue state.pp_queue); format_pp_token state (if size < 0 then pp_infinity else size) tok; state.pp_left_total <- len + state.pp_left_total; advance_loop state end ;; let advance_left state = try advance_loop state with | Empty_queue -> () ;; let enqueue_advance state tok = pp_enqueue state tok; advance_left state;; (* To enqueue a string : try to advance. *) let make_queue_elem size tok len = { elem_size = size; token = tok; length = len; };; let enqueue_string_as state size s = let len = int_of_size size in enqueue_advance state (make_queue_elem size (Pp_text s) len) ;; let enqueue_string state s = let len = String.length s in enqueue_string_as state (size_of_int len) s ;; (* Routines for scan stack determine sizes of blocks. *) (* The scan_stack is never empty. *) let scan_stack_bottom = let q_elem = make_queue_elem (size_of_int (-1)) (Pp_text "") 0 in [Scan_elem (-1, q_elem)] ;; (* Set size of blocks on scan stack: if ty = true then size of break is set else size of block is set; in each case pp_scan_stack is popped. *) let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom;; (* Pattern matching on scan stack is exhaustive, since scan_stack is never empty. Pattern matching on token in scan stack is also exhaustive, since scan_push is used on breaks and opening of boxes. *) let set_size state ty = match state.pp_scan_stack with | Scan_elem (left_tot, ({ elem_size = size; token = tok; length = _; } as queue_elem)) :: t -> let size = int_of_size size in (* test if scan stack contains any data that is not obsolete. *) if left_tot < state.pp_left_total then clear_scan_stack state else begin match tok with | Pp_break (_, _) | Pp_tbreak (_, _) -> if ty then begin queue_elem.elem_size <- size_of_int (state.pp_right_total + size); state.pp_scan_stack <- t end | Pp_begin (_, _) -> if not ty then begin queue_elem.elem_size <- size_of_int (state.pp_right_total + size); state.pp_scan_stack <- t end | Pp_text _ | Pp_stab | Pp_tbegin _ | Pp_tend | Pp_end | Pp_newline | Pp_if_newline | Pp_open_tag _ | Pp_close_tag -> () (* scan_push is only used for breaks and boxes. *) end | [] -> () (* scan_stack is never empty. *) ;; (* Push a token on scan stack. If b is true set_size is called. *) let scan_push state b tok = pp_enqueue state tok; if b then set_size state true; state.pp_scan_stack <- Scan_elem (state.pp_right_total, tok) :: state.pp_scan_stack ;; (* To open a new block : the user may set the depth bound pp_max_boxes any text nested deeper is printed as the ellipsis string. *) let pp_open_box_gen state indent br_ty = state.pp_curr_depth <- state.pp_curr_depth + 1; if state.pp_curr_depth < state.pp_max_boxes then let elem = make_queue_elem (size_of_int (- state.pp_right_total)) (Pp_begin (indent, br_ty)) 0 in scan_push state false elem else if state.pp_curr_depth = state.pp_max_boxes then enqueue_string state state.pp_ellipsis ;; (* The box which is always opened. *) let pp_open_sys_box state = pp_open_box_gen state 0 Pp_hovbox;; (* Close a block, setting sizes of its sub blocks. *) let pp_close_box state () = if state.pp_curr_depth > 1 then begin if state.pp_curr_depth < state.pp_max_boxes then begin pp_enqueue state { elem_size = size_of_int 0; token = Pp_end; length = 0; }; set_size state true; set_size state false end; state.pp_curr_depth <- state.pp_curr_depth - 1; end ;; (* Open a tag, pushing it on the tag stack. *) let pp_open_tag state tag_name = if state.pp_print_tags then begin state.pp_tag_stack <- tag_name :: state.pp_tag_stack; state.pp_print_open_tag tag_name end; if state.pp_mark_tags then pp_enqueue state { elem_size = size_of_int 0; token = Pp_open_tag tag_name; length = 0; } ;; (* Close a tag, popping it from the tag stack. *) let pp_close_tag state () = if state.pp_mark_tags then pp_enqueue state { elem_size = size_of_int 0; token = Pp_close_tag; length = 0; }; if state.pp_print_tags then begin match state.pp_tag_stack with | tag_name :: tags -> state.pp_print_close_tag tag_name; state.pp_tag_stack <- tags | _ -> () (* No more tag to close. *) end ;; let pp_set_print_tags state b = state.pp_print_tags <- b;; let pp_set_mark_tags state b = state.pp_mark_tags <- b;; let pp_get_print_tags state () = state.pp_print_tags;; let pp_get_mark_tags state () = state.pp_mark_tags;; let pp_set_tags state b = pp_set_print_tags state b; pp_set_mark_tags state b;; let pp_get_formatter_tag_functions state () = { mark_open_tag = state.pp_mark_open_tag; mark_close_tag = state.pp_mark_close_tag; print_open_tag = state.pp_print_open_tag; print_close_tag = state.pp_print_close_tag; } ;; let pp_set_formatter_tag_functions state { mark_open_tag = mot; mark_close_tag = mct; print_open_tag = pot; print_close_tag = pct; } = state.pp_mark_open_tag <- mot; state.pp_mark_close_tag <- mct; state.pp_print_open_tag <- pot; state.pp_print_close_tag <- pct ;; (* Initialize pretty-printer. *) let pp_rinit state = pp_clear_queue state; clear_scan_stack state; state.pp_format_stack <- []; state.pp_tbox_stack <- []; state.pp_tag_stack <- []; state.pp_mark_stack <- []; state.pp_current_indent <- 0; state.pp_curr_depth <- 0; state.pp_space_left <- state.pp_margin; pp_open_sys_box state;; (* Flushing pretty-printer queue. *) let pp_flush_queue state b = while state.pp_curr_depth > 1 do pp_close_box state () done; state.pp_right_total <- pp_infinity; advance_left state; if b then pp_output_newline state; pp_rinit state ;; (************************************************************** Procedures to format objects, and use boxes **************************************************************) (* To format a string. *) let pp_print_as_size state size s = if state.pp_curr_depth < state.pp_max_boxes then enqueue_string_as state size s ;; let pp_print_as state isize s = pp_print_as_size state (size_of_int isize) s ;; let pp_print_string state s = pp_print_as state (String.length s) s ;; (* To format an integer. *) let pp_print_int state i = pp_print_string state (string_of_int i);; (* To format a float. *) let pp_print_float state f = pp_print_string state (string_of_float f);; (* To format a boolean. *) let pp_print_bool state b = pp_print_string state (string_of_bool b);; (* To format a char. *) let pp_print_char state c = let s = String.create 1 in s.[0] <- c; pp_print_as state 1 s ;; (* Opening boxes. *) let pp_open_hbox state () = pp_open_box_gen state 0 Pp_hbox and pp_open_vbox state indent = pp_open_box_gen state indent Pp_vbox and pp_open_hvbox state indent = pp_open_box_gen state indent Pp_hvbox and pp_open_hovbox state indent = pp_open_box_gen state indent Pp_hovbox and pp_open_box state indent = pp_open_box_gen state indent Pp_box;; (* Print a new line after printing all queued text (same for print_flush but without a newline). *) let pp_print_newline state () = pp_flush_queue state true; state.pp_flush_function () and pp_print_flush state () = pp_flush_queue state false; state.pp_flush_function ();; (* To get a newline when one does not want to close the current block. *) let pp_force_newline state () = if state.pp_curr_depth < state.pp_max_boxes then enqueue_advance state (make_queue_elem (size_of_int 0) Pp_newline 0) ;; (* To format something if the line has just been broken. *) let pp_print_if_newline state () = if state.pp_curr_depth < state.pp_max_boxes then enqueue_advance state (make_queue_elem (size_of_int 0) Pp_if_newline 0) ;; (* Breaks: indicate where a block may be broken. If line is broken then offset is added to the indentation of the current block else (the value of) width blanks are printed. To do (?) : add a maximum width and offset value. *) let pp_print_break state width offset = if state.pp_curr_depth < state.pp_max_boxes then let elem = make_queue_elem (size_of_int (- state.pp_right_total)) (Pp_break (width, offset)) width in scan_push state true elem ;; let pp_print_space state () = pp_print_break state 1 0 and pp_print_cut state () = pp_print_break state 0 0 ;; (* Tabulation boxes. *) let pp_open_tbox state () = state.pp_curr_depth <- state.pp_curr_depth + 1; if state.pp_curr_depth < state.pp_max_boxes then let elem = make_queue_elem (size_of_int 0) (Pp_tbegin (Pp_tbox (ref []))) 0 in enqueue_advance state elem ;; (* Close a tabulation block. *) let pp_close_tbox state () = if state.pp_curr_depth > 1 then begin if state.pp_curr_depth < state.pp_max_boxes then let elem = make_queue_elem (size_of_int 0) Pp_tend 0 in enqueue_advance state elem; state.pp_curr_depth <- state.pp_curr_depth - 1 end ;; (* Print a tabulation break. *) let pp_print_tbreak state width offset = if state.pp_curr_depth < state.pp_max_boxes then let elem = make_queue_elem (size_of_int (- state.pp_right_total)) (Pp_tbreak (width, offset)) width in scan_push state true elem ;; let pp_print_tab state () = pp_print_tbreak state 0 0;; let pp_set_tab state () = if state.pp_curr_depth < state.pp_max_boxes then let elem = make_queue_elem (size_of_int 0) Pp_stab 0 in enqueue_advance state elem ;; (************************************************************** Procedures to control the pretty-printers **************************************************************) (* Fit max_boxes. *) let pp_set_max_boxes state n = if n > 1 then state.pp_max_boxes <- n;; (* To know the current maximum number of boxes allowed. *) let pp_get_max_boxes state () = state.pp_max_boxes;; let pp_over_max_boxes state () = state.pp_curr_depth = state.pp_max_boxes;; (* Ellipsis. *) let pp_set_ellipsis_text state s = state.pp_ellipsis <- s and pp_get_ellipsis_text state () = state.pp_ellipsis ;; (* To set the margin of pretty-printer. *) let pp_limit n = if n < pp_infinity then n else pred pp_infinity ;; let pp_set_min_space_left state n = if n >= 1 then let n = pp_limit n in state.pp_min_space_left <- n; state.pp_max_indent <- state.pp_margin - state.pp_min_space_left; pp_rinit state ;; (* Initially, we have : pp_max_indent = pp_margin - pp_min_space_left, and pp_space_left = pp_margin. *) let pp_set_max_indent state n = pp_set_min_space_left state (state.pp_margin - n) ;; let pp_get_max_indent state () = state.pp_max_indent;; let pp_set_margin state n = if n >= 1 then let n = pp_limit n in state.pp_margin <- n; let new_max_indent = (* Try to maintain max_indent to its actual value. *) if state.pp_max_indent <= state.pp_margin then state.pp_max_indent else (* If possible maintain pp_min_space_left to its actual value, if this leads to a too small max_indent, take half of the new margin, if it is greater than 1. *) max (max (state.pp_margin - state.pp_min_space_left) (state.pp_margin / 2)) 1 in (* Rebuild invariants. *) pp_set_max_indent state new_max_indent ;; let pp_get_margin state () = state.pp_margin;; let pp_set_formatter_output_functions state f g = state.pp_output_function <- f; state.pp_flush_function <- g;; let pp_get_formatter_output_functions state () = (state.pp_output_function, state.pp_flush_function) ;; let pp_set_all_formatter_output_functions state ~out:f ~flush:g ~newline:h ~spaces:i = pp_set_formatter_output_functions state f g; state.pp_output_newline <- h; state.pp_output_spaces <- i; ;; let pp_get_all_formatter_output_functions state () = (state.pp_output_function, state.pp_flush_function, state.pp_output_newline, state.pp_output_spaces) ;; (* Default function to output new lines. *) let display_newline state () = state.pp_output_function "\n" 0 1;; (* Default function to output spaces. *) let blank_line = String.make 80 ' ';; let rec display_blanks state n = if n > 0 then if n <= 80 then state.pp_output_function blank_line 0 n else begin state.pp_output_function blank_line 0 80; display_blanks state (n - 80) end ;; let pp_set_formatter_out_channel state os = state.pp_output_function <- output os; state.pp_flush_function <- (fun () -> flush os); state.pp_output_newline <- display_newline state; state.pp_output_spaces <- display_blanks state; ;; (************************************************************** Creation of specific formatters **************************************************************) let default_pp_mark_open_tag s = "<" ^ s ^ ">";; let default_pp_mark_close_tag s = "";; let default_pp_print_open_tag _ = ();; let default_pp_print_close_tag = default_pp_print_open_tag;; let pp_make_formatter f g h i = (* The initial state of the formatter contains a dummy box. *) let pp_q = make_queue () in let sys_tok = make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0 in add_queue sys_tok pp_q; let sys_scan_stack = (Scan_elem (1, sys_tok)) :: scan_stack_bottom in { pp_scan_stack = sys_scan_stack; pp_format_stack = []; pp_tbox_stack = []; pp_tag_stack = []; pp_mark_stack = []; pp_margin = 78; pp_min_space_left = 10; pp_max_indent = 78 - 10; pp_space_left = 78; pp_current_indent = 0; pp_is_new_line = true; pp_left_total = 1; pp_right_total = 1; pp_curr_depth = 1; pp_max_boxes = max_int; pp_ellipsis = "."; pp_output_function = f; pp_flush_function = g; pp_output_newline = h; pp_output_spaces = i; pp_print_tags = false; pp_mark_tags = false; pp_mark_open_tag = default_pp_mark_open_tag; pp_mark_close_tag = default_pp_mark_close_tag; pp_print_open_tag = default_pp_print_open_tag; pp_print_close_tag = default_pp_print_close_tag; pp_queue = pp_q; } ;; (* Make a formatter with default functions to output spaces and new lines. *) let make_formatter output flush = let ppf = pp_make_formatter output flush ignore ignore in ppf.pp_output_newline <- display_newline ppf; ppf.pp_output_spaces <- display_blanks ppf; ppf ;; let formatter_of_out_channel oc = make_formatter (output oc) (fun () -> flush oc) ;; let formatter_of_buffer b = make_formatter (Buffer.add_substring b) ignore ;; let stdbuf = Buffer.create 512;; (* Predefined formatters. *) let std_formatter = formatter_of_out_channel Pervasives.stdout and err_formatter = formatter_of_out_channel Pervasives.stderr and str_formatter = formatter_of_buffer stdbuf ;; let flush_str_formatter () = pp_flush_queue str_formatter false; let s = Buffer.contents stdbuf in Buffer.reset stdbuf; s ;; (************************************************************** Basic functions on the standard formatter **************************************************************) let open_hbox = pp_open_hbox std_formatter and open_vbox = pp_open_vbox std_formatter and open_hvbox = pp_open_hvbox std_formatter and open_hovbox = pp_open_hovbox std_formatter and open_box = pp_open_box std_formatter and close_box = pp_close_box std_formatter and open_tag = pp_open_tag std_formatter and close_tag = pp_close_tag std_formatter and print_as = pp_print_as std_formatter and print_string = pp_print_string std_formatter and print_int = pp_print_int std_formatter and print_float = pp_print_float std_formatter and print_char = pp_print_char std_formatter and print_bool = pp_print_bool std_formatter and print_break = pp_print_break std_formatter and print_cut = pp_print_cut std_formatter and print_space = pp_print_space std_formatter and force_newline = pp_force_newline std_formatter and print_flush = pp_print_flush std_formatter and print_newline = pp_print_newline std_formatter and print_if_newline = pp_print_if_newline std_formatter and open_tbox = pp_open_tbox std_formatter and close_tbox = pp_close_tbox std_formatter and print_tbreak = pp_print_tbreak std_formatter and set_tab = pp_set_tab std_formatter and print_tab = pp_print_tab std_formatter and set_margin = pp_set_margin std_formatter and get_margin = pp_get_margin std_formatter and set_max_indent = pp_set_max_indent std_formatter and get_max_indent = pp_get_max_indent std_formatter and set_max_boxes = pp_set_max_boxes std_formatter and get_max_boxes = pp_get_max_boxes std_formatter and over_max_boxes = pp_over_max_boxes std_formatter and set_ellipsis_text = pp_set_ellipsis_text std_formatter and get_ellipsis_text = pp_get_ellipsis_text std_formatter and set_formatter_out_channel = pp_set_formatter_out_channel std_formatter and set_formatter_output_functions = pp_set_formatter_output_functions std_formatter and get_formatter_output_functions = pp_get_formatter_output_functions std_formatter and set_all_formatter_output_functions = pp_set_all_formatter_output_functions std_formatter and get_all_formatter_output_functions = pp_get_all_formatter_output_functions std_formatter and set_formatter_tag_functions = pp_set_formatter_tag_functions std_formatter and get_formatter_tag_functions = pp_get_formatter_tag_functions std_formatter and set_print_tags = pp_set_print_tags std_formatter and get_print_tags = pp_get_print_tags std_formatter and set_mark_tags = pp_set_mark_tags std_formatter and get_mark_tags = pp_get_mark_tags std_formatter and set_tags = pp_set_tags std_formatter ;; (************************************************************** Printf implementation. **************************************************************) module Sformat = Printf.CamlinternalPr.Sformat;; module Tformat = Printf.CamlinternalPr.Tformat;; (* Error messages when processing formats. *) (* Trailer: giving up at character number ... *) let giving_up mess fmt i = Printf.sprintf "Format.fprintf: %s ``%s'', giving up at character number %d%s" mess (Sformat.to_string fmt) i (if i < Sformat.length fmt then Printf.sprintf " (%c)." (Sformat.get fmt i) else Printf.sprintf "%c" '.') ;; (* When an invalid format deserves a special error explanation. *) let format_invalid_arg mess fmt i = invalid_arg (giving_up mess fmt i);; (* Standard invalid format. *) let invalid_format fmt i = format_invalid_arg "bad format" fmt i;; (* Cannot find a valid integer into that format. *) let invalid_integer fmt i = invalid_arg (giving_up "bad integer specification" fmt i);; (* Finding an integer size out of a sub-string of the format. *) let format_int_of_string fmt i s = let sz = try int_of_string s with | Failure _ -> invalid_integer fmt i in size_of_int sz ;; (* Getting strings out of buffers. *) let get_buffer_out b = let s = Buffer.contents b in Buffer.reset b; s ;; (* [ppf] is supposed to be a pretty-printer that outputs to buffer [b]: to extract the contents of [ppf] as a string we flush [ppf] and get the string out of [b]. *) let string_out b ppf = pp_flush_queue ppf false; get_buffer_out b ;; (* Applies [printer] to a formatter that outputs on a fresh buffer, then returns the resulting material. *) let exstring printer arg = let b = Buffer.create 512 in let ppf = formatter_of_buffer b in printer ppf arg; string_out b ppf ;; (* To turn out a character accumulator into the proper string result. *) let implode_rev s0 = function | [] -> s0 | l -> String.concat "" (List.rev (s0 :: l)) ;; (* [mkprintf] is the printf-like function generator: given the - [to_s] flag that tells if we are printing into a string, - the [get_out] function that has to be called to get a [ppf] function to output onto, it generates a [kprintf] function that takes as arguments a [k] continuation function to be called at the end of formatting, and a printing format string to print the rest of the arguments according to the format string. Regular [fprintf]-like functions of this module are obtained via partial applications of [mkprintf]. *) let mkprintf to_s get_out = let rec kprintf k fmt = let len = Sformat.length fmt in let kpr fmt v = let ppf = get_out fmt in let print_as = ref None in let pp_print_as_char c = match !print_as with | None -> pp_print_char ppf c | Some size -> pp_print_as_size ppf size (String.make 1 c); print_as := None and pp_print_as_string s = match !print_as with | None -> pp_print_string ppf s | Some size -> pp_print_as_size ppf size s; print_as := None in let rec doprn n i = if i >= len then Obj.magic (k ppf) else match Sformat.get fmt i with | '%' -> Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m | '@' -> let i = succ i in if i >= len then invalid_format fmt i else begin match Sformat.get fmt i with | '[' -> do_pp_open_box ppf n (succ i) | ']' -> pp_close_box ppf (); doprn n (succ i) | '{' -> do_pp_open_tag ppf n (succ i) | '}' -> pp_close_tag ppf (); doprn n (succ i) | ' ' -> pp_print_space ppf (); doprn n (succ i) | ',' -> pp_print_cut ppf (); doprn n (succ i) | '?' -> pp_print_flush ppf (); doprn n (succ i) | '.' -> pp_print_newline ppf (); doprn n (succ i) | '\n' -> pp_force_newline ppf (); doprn n (succ i) | ';' -> do_pp_break ppf n (succ i) | '<' -> let got_size size n i = print_as := Some size; doprn n (skip_gt i) in get_int n (succ i) got_size | '@' | '%' as c -> pp_print_as_char c; doprn n (succ i) | _ -> invalid_format fmt i end | c -> pp_print_as_char c; doprn n (succ i) and cont_s n s i = pp_print_as_string s; doprn n i and cont_a n printer arg i = if to_s then pp_print_as_string ((Obj.magic printer : unit -> _ -> string) () arg) else printer ppf arg; doprn n i and cont_t n printer i = if to_s then pp_print_as_string ((Obj.magic printer : unit -> string) ()) else printer ppf; doprn n i and cont_f n i = pp_print_flush ppf (); doprn n i and cont_m n sfmt i = kprintf (Obj.magic (fun _ -> doprn n i)) sfmt and get_int n i c = if i >= len then invalid_integer fmt i else match Sformat.get fmt i with | ' ' -> get_int n (succ i) c | '%' -> let cont_s n s i = c (format_int_of_string fmt i s) n i and cont_a _n _printer _arg i = invalid_integer fmt i and cont_t _n _printer i = invalid_integer fmt i and cont_f _n i = invalid_integer fmt i and cont_m _n _sfmt i = invalid_integer fmt i in Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m | _ -> let rec get j = if j >= len then invalid_integer fmt j else match Sformat.get fmt j with | '0' .. '9' | '-' -> get (succ j) | _ -> let size = if j = i then size_of_int 0 else let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in format_int_of_string fmt j s in c size n j in get i and skip_gt i = if i >= len then invalid_format fmt i else match Sformat.get fmt i with | ' ' -> skip_gt (succ i) | '>' -> succ i | _ -> invalid_format fmt i and get_box_kind i = if i >= len then Pp_box, i else match Sformat.get fmt i with | 'h' -> let i = succ i in if i >= len then Pp_hbox, i else begin match Sformat.get fmt i with | 'o' -> let i = succ i in if i >= len then format_invalid_arg "bad box format" fmt i else begin match Sformat.get fmt i with | 'v' -> Pp_hovbox, succ i | c -> format_invalid_arg ("bad box name ho" ^ String.make 1 c) fmt i end | 'v' -> Pp_hvbox, succ i | _ -> Pp_hbox, i end | 'b' -> Pp_box, succ i | 'v' -> Pp_vbox, succ i | _ -> Pp_box, i and get_tag_name n i c = let rec get accu n i j = if j >= len then c (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu) n j else match Sformat.get fmt j with | '>' -> c (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu) n j | '%' -> let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in let cont_s n s i = get (s :: s0 :: accu) n i i and cont_a n printer arg i = let s = if to_s then (Obj.magic printer : unit -> _ -> string) () arg else exstring printer arg in get (s :: s0 :: accu) n i i and cont_t n printer i = let s = if to_s then (Obj.magic printer : unit -> string) () else exstring (fun ppf () -> printer ppf) () in get (s :: s0 :: accu) n i i and cont_f _n i = format_invalid_arg "bad tag name specification" fmt i and cont_m _n _sfmt i = format_invalid_arg "bad tag name specification" fmt i in Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m | _ -> get accu n i (succ j) in get [] n i i and do_pp_break ppf n i = if i >= len then begin pp_print_space ppf (); doprn n i end else match Sformat.get fmt i with | '<' -> let rec got_nspaces nspaces n i = get_int n i (got_offset nspaces) and got_offset nspaces offset n i = pp_print_break ppf (int_of_size nspaces) (int_of_size offset); doprn n (skip_gt i) in get_int n (succ i) got_nspaces | _c -> pp_print_space ppf (); doprn n i and do_pp_open_box ppf n i = if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else match Sformat.get fmt i with | '<' -> let kind, i = get_box_kind (succ i) in let got_size size n i = pp_open_box_gen ppf (int_of_size size) kind; doprn n (skip_gt i) in get_int n i got_size | _c -> pp_open_box_gen ppf 0 Pp_box; doprn n i and do_pp_open_tag ppf n i = if i >= len then begin pp_open_tag ppf ""; doprn n i end else match Sformat.get fmt i with | '<' -> let got_name tag_name n i = pp_open_tag ppf tag_name; doprn n (skip_gt i) in get_tag_name n (succ i) got_name | _c -> pp_open_tag ppf ""; doprn n i in doprn (Sformat.index_of_int 0) 0 in Tformat.kapr kpr fmt in kprintf ;; (************************************************************** Defining [fprintf] and various flavors of [fprintf]. **************************************************************) let kfprintf k ppf = mkprintf false (fun _ -> ppf) k;; let ikfprintf k ppf = Tformat.kapr (fun _ _ -> Obj.magic (k ppf));; let fprintf ppf = kfprintf ignore ppf;; let ifprintf ppf = ikfprintf ignore ppf;; let printf fmt = fprintf std_formatter fmt;; let eprintf fmt = fprintf err_formatter fmt;; let ksprintf k = let b = Buffer.create 512 in let k ppf = k (string_out b ppf) in mkprintf true (fun _ -> formatter_of_buffer b) k ;; let sprintf fmt = ksprintf (fun s -> s) fmt;; (************************************************************** Deprecated stuff. **************************************************************) let kbprintf k b = mkprintf false (fun _ -> formatter_of_buffer b) k ;; (* Deprecated error prone function bprintf. *) let bprintf b = let k ppf = pp_flush_queue ppf false in kbprintf k b ;; (* Deprecated alias for ksprintf. *) let kprintf = ksprintf;; at_exit print_flush ;; mingw-ocaml/ocaml/stdlib/map.mli0000644000175000017500000001671712124403240016232 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Association tables over ordered types. This module implements applicative association tables, also known as finite maps or dictionaries, given a total ordering function over the keys. All operations over maps are purely applicative (no side-effects). The implementation uses balanced binary trees, and therefore searching and insertion take time logarithmic in the size of the map. *) module type OrderedType = sig type t (** The type of the map keys. *) val compare : t -> t -> int (** A total ordering function over the keys. This is a two-argument function [f] such that [f e1 e2] is zero if the keys [e1] and [e2] are equal, [f e1 e2] is strictly negative if [e1] is smaller than [e2], and [f e1 e2] is strictly positive if [e1] is greater than [e2]. Example: a suitable ordering function is the generic structural comparison function {!Pervasives.compare}. *) end (** Input signature of the functor {!Map.Make}. *) module type S = sig type key (** The type of the map keys. *) type (+'a) t (** The type of maps from type [key] to type ['a]. *) val empty: 'a t (** The empty map. *) val is_empty: 'a t -> bool (** Test whether a map is empty or not. *) val mem: key -> 'a t -> bool (** [mem x m] returns [true] if [m] contains a binding for [x], and [false] otherwise. *) val add: key -> 'a -> 'a t -> 'a t (** [add x y m] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. *) val singleton: key -> 'a -> 'a t (** [singleton x y] returns the one-element map that contains a binding [y] for [x]. @since 3.12.0 *) val remove: key -> 'a t -> 'a t (** [remove x m] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map. *) val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] and of [m2]. The presence of each such binding, and the corresponding value, is determined with the function [f]. @since 3.12.0 *) val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int (** Total ordering between maps. The first argument is a total ordering used to compare data associated with equal keys in the two maps. *) val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, that is, contain equal keys and associate them with equal data. [cmp] is the equality predicate used to compare the data associated with the keys. *) val iter: (key -> 'a -> unit) -> 'a t -> unit (** [iter f m] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated value as second argument. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. *) val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], where [k1 ... kN] are the keys of all bindings in [m] (in increasing order), and [d1 ... dN] are the associated data. *) val for_all: (key -> 'a -> bool) -> 'a t -> bool (** [for_all p m] checks if all the bindings of the map satisfy the predicate [p]. @since 3.12.0 *) val exists: (key -> 'a -> bool) -> 'a t -> bool (** [exists p m] checks if at least one binding of the map satisfy the predicate [p]. @since 3.12.0 *) val filter: (key -> 'a -> bool) -> 'a t -> 'a t (** [filter p m] returns the map with all the bindings in [m] that satisfy predicate [p]. @since 3.12.0 *) val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t (** [partition p m] returns a pair of maps [(m1, m2)], where [m1] contains all the bindings of [s] that satisfy the predicate [p], and [m2] is the map with all the bindings of [s] that do not satisfy [p]. @since 3.12.0 *) val cardinal: 'a t -> int (** Return the number of bindings of a map. @since 3.12.0 *) val bindings: 'a t -> (key * 'a) list (** Return the list of all bindings of the given map. The returned list is sorted in increasing order with respect to the ordering [Ord.compare], where [Ord] is the argument given to {!Map.Make}. @since 3.12.0 *) val min_binding: 'a t -> (key * 'a) (** Return the smallest binding of the given map (with respect to the [Ord.compare] ordering), or raise [Not_found] if the map is empty. @since 3.12.0 *) val max_binding: 'a t -> (key * 'a) (** Same as {!Map.S.min_binding}, but returns the largest binding of the given map. @since 3.12.0 *) val choose: 'a t -> (key * 'a) (** Return one binding of the given map, or raise [Not_found] if the map is empty. Which binding is chosen is unspecified, but equal bindings will be chosen for equal maps. @since 3.12.0 *) val split: key -> 'a t -> 'a t * 'a option * 'a t (** [split x m] returns a triple [(l, data, r)], where [l] is the map with all the bindings of [m] whose key is strictly less than [x]; [r] is the map with all the bindings of [m] whose key is strictly greater than [x]; [data] is [None] if [m] contains no binding for [x], or [Some v] if [m] binds [v] to [x]. @since 3.12.0 *) val find: key -> 'a t -> 'a (** [find x m] returns the current binding of [x] in [m], or raises [Not_found] if no such binding exists. *) val map: ('a -> 'b) -> 'a t -> 'b t (** [map f m] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been replaced by the result of the application of [f] to [a]. The bindings are passed to [f] in increasing order with respect to the ordering over the type of the keys. *) val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t (** Same as {!Map.S.map}, but the function receives as arguments both the key and the associated value for each binding of the map. *) end (** Output signature of the functor {!Map.Make}. *) module Make (Ord : OrderedType) : S with type key = Ord.t (** Functor building an implementation of the map structure given a totally ordered type. *) mingw-ocaml/ocaml/stdlib/string.ml0000644000175000017500000001437312124403240016606 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* String operations *) external length : string -> int = "%string_length" external get : string -> int -> char = "%string_safe_get" external set : string -> int -> char -> unit = "%string_safe_set" external create : int -> string = "caml_create_string" external unsafe_get : string -> int -> char = "%string_unsafe_get" external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" external unsafe_blit : string -> int -> string -> int -> int -> unit = "caml_blit_string" "noalloc" external unsafe_fill : string -> int -> int -> char -> unit = "caml_fill_string" "noalloc" let make n c = let s = create n in unsafe_fill s 0 n c; s let copy s = let len = length s in let r = create len in unsafe_blit s 0 r 0 len; r let sub s ofs len = if ofs < 0 || len < 0 || ofs > length s - len then invalid_arg "String.sub" else begin let r = create len in unsafe_blit s ofs r 0 len; r end let fill s ofs len c = if ofs < 0 || len < 0 || ofs > length s - len then invalid_arg "String.fill" else unsafe_fill s ofs len c let blit s1 ofs1 s2 ofs2 len = if len < 0 || ofs1 < 0 || ofs1 > length s1 - len || ofs2 < 0 || ofs2 > length s2 - len then invalid_arg "String.blit" else unsafe_blit s1 ofs1 s2 ofs2 len let iter f a = for i = 0 to length a - 1 do f(unsafe_get a i) done let iteri f a = for i = 0 to length a - 1 do f i (unsafe_get a i) done let concat sep l = match l with [] -> "" | hd :: tl -> let num = ref 0 and len = ref 0 in List.iter (fun s -> incr num; len := !len + length s) l; let r = create (!len + length sep * (!num - 1)) in unsafe_blit hd 0 r 0 (length hd); let pos = ref(length hd) in List.iter (fun s -> unsafe_blit sep 0 r !pos (length sep); pos := !pos + length sep; unsafe_blit s 0 r !pos (length s); pos := !pos + length s) tl; r external is_printable: char -> bool = "caml_is_printable" external char_code: char -> int = "%identity" external char_chr: int -> char = "%identity" let is_space = function | ' ' | '\012' | '\n' | '\r' | '\t' -> true | _ -> false let trim s = let len = length s in let i = ref 0 in while !i < len && is_space (unsafe_get s !i) do incr i done; let j = ref (len - 1) in while !j >= !i && is_space (unsafe_get s !j) do decr j done; if !i = 0 && !j = len - 1 then s else if !j >= !i then sub s !i (!j - !i + 1) else "" let escaped s = let n = ref 0 in for i = 0 to length s - 1 do n := !n + (match unsafe_get s i with | '"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 | c -> if is_printable c then 1 else 4) done; if !n = length s then s else begin let s' = create !n in n := 0; for i = 0 to length s - 1 do begin match unsafe_get s i with | ('"' | '\\') as c -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n c | '\n' -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'n' | '\t' -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 't' | '\r' -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'r' | '\b' -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'b' | c -> if is_printable c then unsafe_set s' !n c else begin let a = char_code c in unsafe_set s' !n '\\'; incr n; unsafe_set s' !n (char_chr (48 + a / 100)); incr n; unsafe_set s' !n (char_chr (48 + (a / 10) mod 10)); incr n; unsafe_set s' !n (char_chr (48 + a mod 10)) end end; incr n done; s' end let map f s = let l = length s in if l = 0 then s else begin let r = create l in for i = 0 to l - 1 do unsafe_set r i (f(unsafe_get s i)) done; r end let uppercase s = map Char.uppercase s let lowercase s = map Char.lowercase s let apply1 f s = if length s = 0 then s else begin let r = copy s in unsafe_set r 0 (f(unsafe_get s 0)); r end let capitalize s = apply1 Char.uppercase s let uncapitalize s = apply1 Char.lowercase s let rec index_rec s lim i c = if i >= lim then raise Not_found else if unsafe_get s i = c then i else index_rec s lim (i + 1) c;; let index s c = index_rec s (length s) 0 c;; let index_from s i c = let l = length s in if i < 0 || i > l then invalid_arg "String.index_from" else index_rec s l i c;; let rec rindex_rec s i c = if i < 0 then raise Not_found else if unsafe_get s i = c then i else rindex_rec s (i - 1) c;; let rindex s c = rindex_rec s (length s - 1) c;; let rindex_from s i c = if i < -1 || i >= length s then invalid_arg "String.rindex_from" else rindex_rec s i c;; let contains_from s i c = let l = length s in if i < 0 || i > l then invalid_arg "String.contains_from" else try ignore (index_rec s l i c); true with Not_found -> false;; let contains s c = contains_from s 0 c;; let rcontains_from s i c = if i < 0 || i >= length s then invalid_arg "String.rcontains_from" else try ignore (rindex_rec s i c); true with Not_found -> false;; type t = string let compare (x: t) (y: t) = Pervasives.compare x y mingw-ocaml/ocaml/stdlib/printf.ml0000644000175000017500000005666412124403240016613 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Pierre Weis, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) external format_float: string -> float -> string = "caml_format_float" external format_int: string -> int -> string = "caml_format_int" external format_int32: string -> int32 -> string = "caml_int32_format" external format_nativeint: string -> nativeint -> string = "caml_nativeint_format" external format_int64: string -> int64 -> string = "caml_int64_format" module Sformat = struct type index;; external unsafe_index_of_int : int -> index = "%identity" ;; let index_of_int i = if i >= 0 then unsafe_index_of_int i else failwith ("Sformat.index_of_int: negative argument " ^ string_of_int i) ;; external int_of_index : index -> int = "%identity" ;; let add_int_index i idx = index_of_int (i + int_of_index idx);; let succ_index = add_int_index 1;; (* Literal position are one-based (hence pred p instead of p). *) let index_of_literal_position p = index_of_int (pred p);; external length : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int = "%string_length" ;; external get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char = "%string_safe_get" ;; external unsafe_get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char = "%string_unsafe_get" ;; external unsafe_to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity" ;; let sub fmt idx len = String.sub (unsafe_to_string fmt) (int_of_index idx) len ;; let to_string fmt = sub fmt (unsafe_index_of_int 0) (length fmt) ;; end ;; let bad_conversion sfmt i c = invalid_arg ("Printf: bad conversion %" ^ String.make 1 c ^ ", at char number " ^ string_of_int i ^ " in format string ``" ^ sfmt ^ "''") ;; let bad_conversion_format fmt i c = bad_conversion (Sformat.to_string fmt) i c ;; let incomplete_format fmt = invalid_arg ("Printf: premature end of format string ``" ^ Sformat.to_string fmt ^ "''") ;; (* Parses a string conversion to return the specified length and the padding direction. *) let parse_string_conversion sfmt = let rec parse neg i = if i >= String.length sfmt then (0, neg) else match String.unsafe_get sfmt i with | '1'..'9' -> (int_of_string (String.sub sfmt i (String.length sfmt - i - 1)), neg) | '-' -> parse true (succ i) | _ -> parse neg (succ i) in try parse false 1 with | Failure _ -> bad_conversion sfmt 0 's' ;; (* Pad a (sub) string into a blank string of length [p], on the right if [neg] is true, on the left otherwise. *) let pad_string pad_char p neg s i len = if p = len && i = 0 then s else if p <= len then String.sub s i len else let res = String.make p pad_char in if neg then String.blit s i res 0 len else String.blit s i res (p - len) len; res ;; (* Format a string given a %s format, e.g. %40s or %-20s. To do ?: ignore other flags (#, +, etc). *) let format_string sfmt s = let (p, neg) = parse_string_conversion sfmt in pad_string ' ' p neg s 0 (String.length s) ;; (* Extract a format string out of [fmt] between [start] and [stop] inclusive. ['*'] in the format are replaced by integers taken from the [widths] list. [extract_format] returns a string which is the string representation of the resulting format string. *) let extract_format fmt start stop widths = let skip_positional_spec start = match Sformat.unsafe_get fmt start with | '0'..'9' -> let rec skip_int_literal i = match Sformat.unsafe_get fmt i with | '0'..'9' -> skip_int_literal (succ i) | '$' -> succ i | _ -> start in skip_int_literal (succ start) | _ -> start in let start = skip_positional_spec (succ start) in let b = Buffer.create (stop - start + 10) in Buffer.add_char b '%'; let rec fill_format i widths = if i <= stop then match (Sformat.unsafe_get fmt i, widths) with | ('*', h :: t) -> Buffer.add_string b (string_of_int h); let i = skip_positional_spec (succ i) in fill_format i t | ('*', []) -> assert false (* Should not happen since this is ill-typed. *) | (c, _) -> Buffer.add_char b c; fill_format (succ i) widths in fill_format start (List.rev widths); Buffer.contents b ;; let extract_format_int conv fmt start stop widths = let sfmt = extract_format fmt start stop widths in match conv with | 'n' | 'N' -> sfmt.[String.length sfmt - 1] <- 'u'; sfmt | _ -> sfmt ;; let extract_format_float conv fmt start stop widths = let sfmt = extract_format fmt start stop widths in match conv with | 'F' -> sfmt.[String.length sfmt - 1] <- 'g'; sfmt | _ -> sfmt ;; (* Returns the position of the next character following the meta format string, starting from position [i], inside a given format [fmt]. According to the character [conv], the meta format string is enclosed by the delimiters %{ and %} (when [conv = '{']) or %( and %) (when [conv = '(']). Hence, [sub_format] returns the index of the character following the [')'] or ['}'] that ends the meta format, according to the character [conv]. *) let sub_format incomplete_format bad_conversion_format conv fmt i = let len = Sformat.length fmt in let rec sub_fmt c i = let close = if c = '(' then ')' else (* '{' *) '}' in let rec sub j = if j >= len then incomplete_format fmt else match Sformat.get fmt j with | '%' -> sub_sub (succ j) | _ -> sub (succ j) and sub_sub j = if j >= len then incomplete_format fmt else match Sformat.get fmt j with | '(' | '{' as c -> let j = sub_fmt c (succ j) in sub (succ j) | '}' | ')' as c -> if c = close then succ j else bad_conversion_format fmt i c | _ -> sub (succ j) in sub i in sub_fmt conv i ;; let sub_format_for_printf conv = sub_format incomplete_format bad_conversion_format conv ;; let iter_on_format_args fmt add_conv add_char = let lim = Sformat.length fmt - 1 in let rec scan_flags skip i = if i > lim then incomplete_format fmt else match Sformat.unsafe_get fmt i with | '*' -> scan_flags skip (add_conv skip i 'i') (* | '$' -> scan_flags skip (succ i) *** PR#4321 *) | '#' | '-' | ' ' | '+' -> scan_flags skip (succ i) | '_' -> scan_flags true (succ i) | '0'..'9' | '.' -> scan_flags skip (succ i) | _ -> scan_conv skip i and scan_conv skip i = if i > lim then incomplete_format fmt else match Sformat.unsafe_get fmt i with | '%' | '@' | '!' | ',' -> succ i | 's' | 'S' | '[' -> add_conv skip i 's' | 'c' | 'C' -> add_conv skip i 'c' | 'd' | 'i' |'o' | 'u' | 'x' | 'X' | 'N' -> add_conv skip i 'i' | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> add_conv skip i 'f' | 'B' | 'b' -> add_conv skip i 'B' | 'a' | 'r' | 't' as conv -> add_conv skip i conv | 'l' | 'n' | 'L' as conv -> let j = succ i in if j > lim then add_conv skip i 'i' else begin match Sformat.get fmt j with | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> add_char (add_conv skip i conv) 'i' | _ -> add_conv skip i 'i' end | '{' as conv -> (* Just get a regular argument, skipping the specification. *) let i = add_conv skip i conv in (* To go on, find the index of the next char after the meta format. *) let j = sub_format_for_printf conv fmt i in (* Add the meta specification to the summary anyway. *) let rec loop i = if i < j - 2 then loop (add_char i (Sformat.get fmt i)) in loop i; (* Go on, starting at the closing brace to properly close the meta specification in the summary. *) scan_conv skip (j - 1) | '(' as conv -> (* Use the static format argument specification instead of the runtime format argument value: they must have the same type anyway. *) scan_fmt (add_conv skip i conv) | '}' | ')' as conv -> add_conv skip i conv | conv -> bad_conversion_format fmt i conv and scan_fmt i = if i < lim then if Sformat.get fmt i = '%' then scan_fmt (scan_flags false (succ i)) else scan_fmt (succ i) else i in ignore (scan_fmt 0) ;; (* Returns a string that summarizes the typing information that a given format string contains. For instance, [summarize_format_type "A number %d\n"] is "%i". It also checks the well-formedness of the format string. *) let summarize_format_type fmt = let len = Sformat.length fmt in let b = Buffer.create len in let add_char i c = Buffer.add_char b c; succ i in let add_conv skip i c = if skip then Buffer.add_string b "%_" else Buffer.add_char b '%'; add_char i c in iter_on_format_args fmt add_conv add_char; Buffer.contents b ;; module Ac = struct type ac = { mutable ac_rglr : int; mutable ac_skip : int; mutable ac_rdrs : int; } end ;; open Ac;; (* Computes the number of arguments of a format (including the flag arguments if any). *) let ac_of_format fmt = let ac = { ac_rglr = 0; ac_skip = 0; ac_rdrs = 0; } in let incr_ac skip c = let inc = if c = 'a' then 2 else 1 in if c = 'r' then ac.ac_rdrs <- ac.ac_rdrs + 1; if skip then ac.ac_skip <- ac.ac_skip + inc else ac.ac_rglr <- ac.ac_rglr + inc in let add_conv skip i c = (* Just finishing a meta format: no additional argument to record. *) if c <> ')' && c <> '}' then incr_ac skip c; succ i and add_char i _ = succ i in iter_on_format_args fmt add_conv add_char; ac ;; let count_arguments_of_format fmt = let ac = ac_of_format fmt in (* For printing, only the regular arguments have to be counted. *) ac.ac_rglr ;; let list_iter_i f l = let rec loop i = function | [] -> () | [x] -> f i x (* Tail calling [f] *) | x :: xs -> f i x; loop (succ i) xs in loop 0 l ;; (* ``Abstracting'' version of kprintf: returns a (curried) function that will print when totally applied. Note: in the following, we are careful not to be badly caught by the compiler optimizations for the representation of arrays. *) let kapr kpr fmt = match count_arguments_of_format fmt with | 0 -> kpr fmt [||] | 1 -> Obj.magic (fun x -> let a = Array.make 1 (Obj.repr 0) in a.(0) <- x; kpr fmt a) | 2 -> Obj.magic (fun x y -> let a = Array.make 2 (Obj.repr 0) in a.(0) <- x; a.(1) <- y; kpr fmt a) | 3 -> Obj.magic (fun x y z -> let a = Array.make 3 (Obj.repr 0) in a.(0) <- x; a.(1) <- y; a.(2) <- z; kpr fmt a) | 4 -> Obj.magic (fun x y z t -> let a = Array.make 4 (Obj.repr 0) in a.(0) <- x; a.(1) <- y; a.(2) <- z; a.(3) <- t; kpr fmt a) | 5 -> Obj.magic (fun x y z t u -> let a = Array.make 5 (Obj.repr 0) in a.(0) <- x; a.(1) <- y; a.(2) <- z; a.(3) <- t; a.(4) <- u; kpr fmt a) | 6 -> Obj.magic (fun x y z t u v -> let a = Array.make 6 (Obj.repr 0) in a.(0) <- x; a.(1) <- y; a.(2) <- z; a.(3) <- t; a.(4) <- u; a.(5) <- v; kpr fmt a) | nargs -> let rec loop i args = if i >= nargs then let a = Array.make nargs (Obj.repr 0) in list_iter_i (fun i arg -> a.(nargs - i - 1) <- arg) args; kpr fmt a else Obj.magic (fun x -> loop (succ i) (x :: args)) in loop 0 [] ;; type positional_specification = | Spec_none | Spec_index of Sformat.index ;; (* To scan an optional positional parameter specification, i.e. an integer followed by a [$]. Calling [got_spec] with appropriate arguments, we ``return'' a positional specification and an index to go on scanning the [fmt] format at hand. Note that this is optimized for the regular case, i.e. no positional parameter, since in this case we juste ``return'' the constant [Spec_none]; in case we have a positional parameter, we ``return'' a [Spec_index] [positional_specification] which is a bit more costly. Note also that we do not support [*$] specifications, since this would lead to type checking problems: a [*$] positional specification means ``take the next argument to [printf] (which must be an integer value)'', name this integer value $n$; [*$] now designates parameter $n$. Unfortunately, the type of a parameter specified via a [*$] positional specification should be the type of the corresponding argument to [printf], hence this should be the type of the $n$-th argument to [printf] with $n$ being the {\em value} of the integer argument defining [*]; we clearly cannot statically guess the value of this parameter in the general case. Put it another way: this means type dependency, which is completely out of scope of the OCaml type algebra. *) let scan_positional_spec fmt got_spec i = match Sformat.unsafe_get fmt i with | '0'..'9' as d -> let rec get_int_literal accu j = match Sformat.unsafe_get fmt j with | '0'..'9' as d -> get_int_literal (10 * accu + (int_of_char d - 48)) (succ j) | '$' -> if accu = 0 then failwith "printf: bad positional specification (0)." else got_spec (Spec_index (Sformat.index_of_literal_position accu)) (succ j) (* Not a positional specification: tell so the caller, and go back to scanning the format from the original [i] position we were called at first. *) | _ -> got_spec Spec_none i in get_int_literal (int_of_char d - 48) (succ i) (* No positional specification: tell so the caller, and go back to scanning the format from the original [i] position. *) | _ -> got_spec Spec_none i ;; (* Get the index of the next argument to printf, according to the given positional specification. *) let next_index spec n = match spec with | Spec_none -> Sformat.succ_index n | Spec_index _ -> n ;; (* Get the index of the actual argument to printf, according to its optional positional specification. *) let get_index spec n = match spec with | Spec_none -> n | Spec_index p -> p ;; (* Format a float argument as a valid OCaml lexeme. *) let format_float_lexeme = (* To be revised: this procedure should be a unique loop that performs the validity check and the string lexeme modification at the same time. Otherwise, it is too difficult to handle the strange padding facilities given by printf. Let alone handling the correct widths indication, knowing that we have sometime to add a '.' at the end of the result! *) let make_valid_float_lexeme s = (* Check if s is already a valid lexeme: in this case do nothing, otherwise turn s into a valid OCaml lexeme. *) let l = String.length s in let rec valid_float_loop i = if i >= l then s ^ "." else match s.[i] with (* Sure, this is already a valid float lexeme. *) | '.' | 'e' | 'E' -> s | _ -> valid_float_loop (i + 1) in valid_float_loop 0 in (fun sfmt x -> let s = format_float sfmt x in match classify_float x with | FP_normal | FP_subnormal | FP_zero -> make_valid_float_lexeme s | FP_nan | FP_infinite -> s) ;; (* Decode a format string and act on it. [fmt] is the [printf] format string, and [pos] points to a [%] character in the format string. After consuming the appropriate number of arguments and formatting them, one of the following five continuations described below is called: - [cont_s] for outputting a string (arguments: arg num, string, next pos) - [cont_a] for performing a %a action (arguments: arg num, fn, arg, next pos) - [cont_t] for performing a %t action (arguments: arg num, fn, next pos) - [cont_f] for performing a flush action (arguments: arg num, next pos) - [cont_m] for performing a %( action (arguments: arg num, sfmt, next pos) "arg num" is the index in array [args] of the next argument to [printf]. "next pos" is the position in [fmt] of the first character following the %conversion specification in [fmt]. *) (* Note: here, rather than test explicitly against [Sformat.length fmt] to detect the end of the format, we use [Sformat.unsafe_get] and rely on the fact that we'll get a "null" character if we access one past the end of the string. These "null" characters are then caught by the [_ -> bad_conversion] clauses below. Don't do this at home, kids. *) let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = let get_arg spec n = Obj.magic (args.(Sformat.int_of_index (get_index spec n))) in let rec scan_positional n widths i = let got_spec spec i = scan_flags spec n widths i in scan_positional_spec fmt got_spec i and scan_flags spec n widths i = match Sformat.unsafe_get fmt i with | '*' -> let got_spec wspec i = let (width : int) = get_arg wspec n in scan_flags spec (next_index wspec n) (width :: widths) i in scan_positional_spec fmt got_spec (succ i) | '0'..'9' | '.' | '#' | '-' | ' ' | '+' -> scan_flags spec n widths (succ i) | _ -> scan_conv spec n widths i and scan_conv spec n widths i = match Sformat.unsafe_get fmt i with | '%' | '@' as c -> cont_s n (String.make 1 c) (succ i) | '!' -> cont_f n (succ i) | ',' -> cont_s n "" (succ i) | 's' | 'S' as conv -> let (x : string) = get_arg spec n in let x = if conv = 's' then x else "\"" ^ String.escaped x ^ "\"" in let s = (* Optimize for common case %s *) if i = succ pos then x else format_string (extract_format fmt pos i widths) x in cont_s (next_index spec n) s (succ i) | '[' as conv -> bad_conversion_format fmt i conv | 'c' | 'C' as conv -> let (x : char) = get_arg spec n in let s = if conv = 'c' then String.make 1 x else "'" ^ Char.escaped x ^ "'" in cont_s (next_index spec n) s (succ i) | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' as conv -> let (x : int) = get_arg spec n in let s = format_int (extract_format_int conv fmt pos i widths) x in cont_s (next_index spec n) s (succ i) | 'f' | 'e' | 'E' | 'g' | 'G' -> let (x : float) = get_arg spec n in let s = format_float (extract_format fmt pos i widths) x in cont_s (next_index spec n) s (succ i) | 'F' as conv -> let (x : float) = get_arg spec n in let s = if widths = [] then Pervasives.string_of_float x else format_float_lexeme (extract_format_float conv fmt pos i widths) x in cont_s (next_index spec n) s (succ i) | 'B' | 'b' -> let (x : bool) = get_arg spec n in cont_s (next_index spec n) (string_of_bool x) (succ i) | 'a' -> let printer = get_arg spec n in (* If the printer spec is Spec_none, go on as usual. If the printer spec is Spec_index p, printer's argument spec is Spec_index (succ_index p). *) let n = Sformat.succ_index (get_index spec n) in let arg = get_arg Spec_none n in cont_a (next_index spec n) printer arg (succ i) | 'r' as conv -> bad_conversion_format fmt i conv | 't' -> let printer = get_arg spec n in cont_t (next_index spec n) printer (succ i) | 'l' | 'n' | 'L' as conv -> begin match Sformat.unsafe_get fmt (succ i) with | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> let i = succ i in let s = match conv with | 'l' -> let (x : int32) = get_arg spec n in format_int32 (extract_format fmt pos i widths) x | 'n' -> let (x : nativeint) = get_arg spec n in format_nativeint (extract_format fmt pos i widths) x | _ -> let (x : int64) = get_arg spec n in format_int64 (extract_format fmt pos i widths) x in cont_s (next_index spec n) s (succ i) | _ -> let (x : int) = get_arg spec n in let s = format_int (extract_format_int 'n' fmt pos i widths) x in cont_s (next_index spec n) s (succ i) end | '{' | '(' as conv (* ')' '}' *) -> let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg spec n in let i = succ i in let j = sub_format_for_printf conv fmt i in if conv = '{' (* '}' *) then (* Just print the format argument as a specification. *) cont_s (next_index spec n) (summarize_format_type xf) j else (* Use the format argument instead of the format specification. *) cont_m (next_index spec n) xf j | (* '(' *) ')' -> cont_s n "" (succ i) | conv -> bad_conversion_format fmt i conv in scan_positional n [] (succ pos) ;; let mkprintf to_s get_out outc outs flush k fmt = (* [out] is global to this definition of [pr], and must be shared by all its recursive calls (if any). *) let out = get_out fmt in let rec pr k n fmt v = let len = Sformat.length fmt in let rec doprn n i = if i >= len then Obj.magic (k out) else match Sformat.unsafe_get fmt i with | '%' -> scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m | c -> outc out c; doprn n (succ i) and cont_s n s i = outs out s; doprn n i and cont_a n printer arg i = if to_s then outs out ((Obj.magic printer : unit -> _ -> string) () arg) else printer out arg; doprn n i and cont_t n printer i = if to_s then outs out ((Obj.magic printer : unit -> string) ()) else printer out; doprn n i and cont_f n i = flush out; doprn n i and cont_m n xf i = let m = Sformat.add_int_index (count_arguments_of_format xf) n in pr (Obj.magic (fun _ -> doprn m i)) n xf v in doprn n 0 in let kpr = pr k (Sformat.index_of_int 0) in kapr kpr fmt ;; let kfprintf k oc = mkprintf false (fun _ -> oc) output_char output_string flush k ;; let ifprintf _ = kapr (fun _ -> Obj.magic ignore);; let fprintf oc = kfprintf ignore oc;; let printf fmt = fprintf stdout fmt;; let eprintf fmt = fprintf stderr fmt;; let kbprintf k b = mkprintf false (fun _ -> b) Buffer.add_char Buffer.add_string ignore k ;; let bprintf b = kbprintf ignore b;; let get_buff fmt = let len = 2 * Sformat.length fmt in Buffer.create len ;; let get_contents b = let s = Buffer.contents b in Buffer.clear b; s ;; let get_cont k b = k (get_contents b);; let ksprintf k = mkprintf true get_buff Buffer.add_char Buffer.add_string ignore (get_cont k) ;; let sprintf fmt = ksprintf (fun s -> s) fmt;; (* Obsolete and deprecated. *) let kprintf = ksprintf;; (* For OCaml system internal use only: needed to implement modules [Format] and [Scanf]. *) module CamlinternalPr = struct module Sformat = Sformat;; module Tformat = struct type ac = Ac.ac = { mutable ac_rglr : int; mutable ac_skip : int; mutable ac_rdrs : int; } ;; let ac_of_format = ac_of_format;; let sub_format = sub_format;; let summarize_format_type = summarize_format_type;; let scan_format = scan_format;; let kapr = kapr;; end ;; end ;; mingw-ocaml/ocaml/stdlib/parsing.mli0000644000175000017500000000764712124403240017122 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** The run-time library for parsers generated by [ocamlyacc]. *) val symbol_start : unit -> int (** [symbol_start] and {!Parsing.symbol_end} are to be called in the action part of a grammar rule only. They return the offset of the string that matches the left-hand side of the rule: [symbol_start()] returns the offset of the first character; [symbol_end()] returns the offset after the last character. The first character in a file is at offset 0. *) val symbol_end : unit -> int (** See {!Parsing.symbol_start}. *) val rhs_start : int -> int (** Same as {!Parsing.symbol_start} and {!Parsing.symbol_end}, but return the offset of the string matching the [n]th item on the right-hand side of the rule, where [n] is the integer parameter to [rhs_start] and [rhs_end]. [n] is 1 for the leftmost item. *) val rhs_end : int -> int (** See {!Parsing.rhs_start}. *) val symbol_start_pos : unit -> Lexing.position;; (** Same as [symbol_start], but return a [position] instead of an offset. *) val symbol_end_pos : unit -> Lexing.position (** Same as [symbol_end], but return a [position] instead of an offset. *) val rhs_start_pos : int -> Lexing.position (** Same as [rhs_start], but return a [position] instead of an offset. *) val rhs_end_pos : int -> Lexing.position (** Same as [rhs_end], but return a [position] instead of an offset. *) val clear_parser : unit -> unit (** Empty the parser stack. Call it just after a parsing function has returned, to remove all pointers from the parser stack to structures that were built by semantic actions during parsing. This is optional, but lowers the memory requirements of the programs. *) exception Parse_error (** Raised when a parser encounters a syntax error. Can also be raised from the action part of a grammar rule, to initiate error recovery. *) val set_trace: bool -> bool (** Control debugging support for [ocamlyacc]-generated parsers. After [Parsing.set_trace true], the pushdown automaton that executes the parsers prints a trace of its actions (reading a token, shifting a state, reducing by a rule) on standard output. [Parsing.set_trace false] turns this debugging trace off. The boolean returned is the previous state of the trace flag. @since 3.11.0 *) (**/**) (** {6 } *) (** The following definitions are used by the generated parsers only. They are not intended to be used directly by user programs. *) type parser_env type parse_tables = { actions : (parser_env -> Obj.t) array; transl_const : int array; transl_block : int array; lhs : string; len : string; defred : string; dgoto : string; sindex : string; rindex : string; gindex : string; tablesize : int; table : string; check : string; error_function : string -> unit; names_const : string; names_block : string } exception YYexit of Obj.t val yyparse : parse_tables -> int -> (Lexing.lexbuf -> 'a) -> Lexing.lexbuf -> 'b val peek_val : parser_env -> int -> 'a val is_current_lookahead : 'a -> bool val parse_error : string -> unit mingw-ocaml/ocaml/stdlib/camlinternalLazy.ml0000644000175000017500000000502512124403240020603 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Internals of forcing lazy values. *) exception Undefined;; let raise_undefined = Obj.repr (fun () -> raise Undefined);; (* Assume [blk] is a block with tag lazy *) let force_lazy_block (blk : 'arg lazy_t) = let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in Obj.set_field (Obj.repr blk) 0 raise_undefined; try let result = closure () in Obj.set_field (Obj.repr blk) 0 (Obj.repr result); (* do set_field BEFORE set_tag *) Obj.set_tag (Obj.repr blk) Obj.forward_tag; result with e -> Obj.set_field (Obj.repr blk) 0 (Obj.repr (fun () -> raise e)); raise e ;; (* Assume [blk] is a block with tag lazy *) let force_val_lazy_block (blk : 'arg lazy_t) = let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in Obj.set_field (Obj.repr blk) 0 raise_undefined; let result = closure () in Obj.set_field (Obj.repr blk) 0 (Obj.repr result); (* do set_field BEFORE set_tag *) Obj.set_tag (Obj.repr blk) (Obj.forward_tag); result ;; (* [force] is not used, since [Lazy.force] is declared as a primitive whose code inlines the tag tests of its argument. This function is here for the sake of completeness, and for debugging purpose. *) let force (lzv : 'arg lazy_t) = let x = Obj.repr lzv in let t = Obj.tag x in if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else if t <> Obj.lazy_tag then (Obj.obj x : 'arg) else force_lazy_block lzv ;; let force_val (lzv : 'arg lazy_t) = let x = Obj.repr lzv in let t = Obj.tag x in if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else if t <> Obj.lazy_tag then (Obj.obj x : 'arg) else force_val_lazy_block lzv ;; mingw-ocaml/ocaml/stdlib/queue.ml0000644000175000017500000001007412124403240016416 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Franois Pottier, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) exception Empty (* OCaml currently does not allow the components of a sum type to be mutable. Yet, for optimal space efficiency, we must have cons cells whose [next] field is mutable. This leads us to define a type of cyclic lists, so as to eliminate the [Nil] case and the sum type. *) type 'a cell = { content: 'a; mutable next: 'a cell } (* A queue is a reference to either nothing or some cell of a cyclic list. By convention, that cell is to be viewed as the last cell in the queue. The first cell in the queue is then found in constant time: it is the next cell in the cyclic list. The queue's length is also recorded, so as to make [length] a constant-time operation. The [tail] field should really be of type ['a cell option], but then it would be [None] when [length] is 0 and [Some] otherwise, leading to redundant memory allocation and accesses. We avoid this overhead by filling [tail] with a dummy value when [length] is 0. Of course, this requires bending the type system's arm slightly, because it does not have dependent sums. *) type 'a t = { mutable length: int; mutable tail: 'a cell } let create () = { length = 0; tail = Obj.magic None } let clear q = q.length <- 0; q.tail <- Obj.magic None let add x q = if q.length = 0 then let rec cell = { content = x; next = cell } in q.length <- 1; q.tail <- cell else let tail = q.tail in let head = tail.next in let cell = { content = x; next = head } in q.length <- q.length + 1; tail.next <- cell; q.tail <- cell let push = add let peek q = if q.length = 0 then raise Empty else q.tail.next.content let top = peek let take q = if q.length = 0 then raise Empty; q.length <- q.length - 1; let tail = q.tail in let head = tail.next in if head == tail then q.tail <- Obj.magic None else tail.next <- head.next; head.content let pop = take let copy q = if q.length = 0 then create() else let tail = q.tail in let rec tail' = { content = tail.content; next = tail' } in let rec copy cell = if cell == tail then tail' else { content = cell.content; next = copy cell.next } in tail'.next <- copy tail.next; { length = q.length; tail = tail' } let is_empty q = q.length = 0 let length q = q.length let iter f q = if q.length > 0 then let tail = q.tail in let rec iter cell = f cell.content; if cell != tail then iter cell.next in iter tail.next let fold f accu q = if q.length = 0 then accu else let tail = q.tail in let rec fold accu cell = let accu = f accu cell.content in if cell == tail then accu else fold accu cell.next in fold accu tail.next let transfer q1 q2 = let length1 = q1.length in if length1 > 0 then let tail1 = q1.tail in clear q1; if q2.length > 0 then begin let tail2 = q2.tail in let head1 = tail1.next in let head2 = tail2.next in tail1.next <- head2; tail2.next <- head1 end; q2.length <- q2.length + length1; q2.tail <- tail1 mingw-ocaml/ocaml/stdlib/lazy.mli0000644000175000017500000000706312124403240016426 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Deferred computations. *) type 'a t = 'a lazy_t;; (** A value of type ['a Lazy.t] is a deferred computation, called a suspension, that has a result of type ['a]. The special expression syntax [lazy (expr)] makes a suspension of the computation of [expr], without computing [expr] itself yet. "Forcing" the suspension will then compute [expr] and return its result. Note: [lazy_t] is the built-in type constructor used by the compiler for the [lazy] keyword. You should not use it directly. Always use [Lazy.t] instead. Note: [Lazy.force] is not thread-safe. If you use this module in a multi-threaded program, you will need to add some locks. Note: if the program is compiled with the [-rectypes] option, ill-founded recursive definitions of the form [let rec x = lazy x] or [let rec x = lazy(lazy(...(lazy x)))] are accepted by the type-checker and lead, when forced, to ill-formed values that trigger infinite loops in the garbage collector and other parts of the run-time system. Without the [-rectypes] option, such ill-founded recursive definitions are rejected by the type-checker. *) exception Undefined;; (* val force : 'a t -> 'a ;; *) external force : 'a t -> 'a = "%lazy_force";; (** [force x] forces the suspension [x] and returns its result. If [x] has already been forced, [Lazy.force x] returns the same value again without recomputing it. If it raised an exception, the same exception is raised again. Raise [Undefined] if the forcing of [x] tries to force [x] itself recursively. *) val force_val : 'a t -> 'a;; (** [force_val x] forces the suspension [x] and returns its result. If [x] has already been forced, [force_val x] returns the same value again without recomputing it. Raise [Undefined] if the forcing of [x] tries to force [x] itself recursively. If the computation of [x] raises an exception, it is unspecified whether [force_val x] raises the same exception or [Undefined]. *) val from_fun : (unit -> 'a) -> 'a t;; (** [from_fun f] is the same as [lazy (f ())] but slightly more efficient. @since 4.00.0 *) val from_val : 'a -> 'a t;; (** [from_val v] returns an already-forced suspension of [v]. This is for special purposes only and should not be confused with [lazy (v)]. @since 4.00.0 *) val is_val : 'a t -> bool;; (** [is_val x] returns [true] if [x] has already been forced and did not raise an exception. @since 4.00.0 *) val lazy_from_fun : (unit -> 'a) -> 'a t;; (** @deprecated synonym for [from_fun]. *) val lazy_from_val : 'a -> 'a t;; (** @deprecated synonym for [from_val]. *) val lazy_is_val : 'a t -> bool;; (** @deprecated synonym for [is_val]. *) mingw-ocaml/ocaml/stdlib/scanf.ml0000644000175000017500000014430312124403240016367 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* The run-time library for scanners. *) (* Scanning buffers. *) module type SCANNING = sig type in_channel;; type scanbuf = in_channel;; type file_name = string;; val stdin : in_channel;; (* The scanning buffer reading from [Pervasives.stdin]. [stdib] is equivalent to [Scanning.from_channel Pervasives.stdin]. *) val stdib : in_channel;; (* An alias for [Scanf.stdin], the scanning buffer reading from [Pervasives.stdin]. *) val next_char : scanbuf -> char;; (* [Scanning.next_char ib] advance the scanning buffer for one character. If no more character can be read, sets a end of file condition and returns '\000'. *) val invalidate_current_char : scanbuf -> unit;; (* [Scanning.invalidate_current_char ib] mark the current_char as already scanned. *) val peek_char : scanbuf -> char;; (* [Scanning.peek_char ib] returns the current char available in the buffer or reads one if necessary (when the current character is already scanned). If no character can be read, sets an end of file condition and returns '\000'. *) val checked_peek_char : scanbuf -> char;; (* Same as above but always returns a valid char or fails: instead of returning a null char when the reading method of the input buffer has reached an end of file, the function raises exception [End_of_file]. *) val store_char : int -> scanbuf -> char -> int;; (* [Scanning.store_char lim ib c] adds [c] to the token buffer of the scanning buffer. It also advances the scanning buffer for one character and returns [lim - 1], indicating the new limit for the length of the current token. *) val skip_char : int -> scanbuf -> int;; (* [Scanning.skip_char lim ib] ignores the current character. *) val ignore_char : int -> scanbuf -> int;; (* [Scanning.ignore_char ib lim] ignores the current character and decrements the limit. *) val token : scanbuf -> string;; (* [Scanning.token ib] returns the string stored into the token buffer of the scanning buffer: it returns the token matched by the format. *) val reset_token : scanbuf -> unit;; (* [Scanning.reset_token ib] resets the token buffer of the given scanning buffer. *) val char_count : scanbuf -> int;; (* [Scanning.char_count ib] returns the number of characters read so far from the given buffer. *) val line_count : scanbuf -> int;; (* [Scanning.line_count ib] returns the number of new line characters read so far from the given buffer. *) val token_count : scanbuf -> int;; (* [Scanning.token_count ib] returns the number of tokens read so far from [ib]. *) val eof : scanbuf -> bool;; (* [Scanning.eof ib] returns the end of input condition of the given buffer. *) val end_of_input : scanbuf -> bool;; (* [Scanning.end_of_input ib] tests the end of input condition of the given buffer (if no char has ever been read, an attempt to read one is performed). *) val beginning_of_input : scanbuf -> bool;; (* [Scanning.beginning_of_input ib] tests the beginning of input condition of the given buffer. *) val name_of_input : scanbuf -> string;; (* [Scanning.name_of_input ib] returns the name of the character source for input buffer [ib]. *) val open_in : file_name -> in_channel;; val open_in_bin : file_name -> in_channel;; val from_file : file_name -> in_channel;; val from_file_bin : file_name -> in_channel;; val from_string : string -> in_channel;; val from_function : (unit -> char) -> in_channel;; val from_channel : Pervasives.in_channel -> in_channel;; val close_in : in_channel -> unit;; end ;; module Scanning : SCANNING = struct (* The run-time library for scanf. *) type in_channel_name = | From_file of string * Pervasives.in_channel | From_string | From_function | From_channel of Pervasives.in_channel ;; type in_channel = { mutable eof : bool; mutable current_char : char; mutable current_char_is_valid : bool; mutable char_count : int; mutable line_count : int; mutable token_count : int; mutable get_next_char : unit -> char; tokbuf : Buffer.t; input_name : in_channel_name; } ;; type scanbuf = in_channel;; type file_name = string;; let null_char = '\000';; (* Reads a new character from input buffer. Next_char never fails, even in case of end of input: it then simply sets the end of file condition. *) let next_char ib = try let c = ib.get_next_char () in ib.current_char <- c; ib.current_char_is_valid <- true; ib.char_count <- succ ib.char_count; if c = '\n' then ib.line_count <- succ ib.line_count; c with | End_of_file -> let c = null_char in ib.current_char <- c; ib.current_char_is_valid <- false; ib.eof <- true; c ;; let peek_char ib = if ib.current_char_is_valid then ib.current_char else next_char ib;; (* Returns a valid current char for the input buffer. In particular no irrelevant null character (as set by [next_char] in case of end of input) is returned, since [End_of_file] is raised when [next_char] sets the end of file condition while trying to read a new character. *) let checked_peek_char ib = let c = peek_char ib in if ib.eof then raise End_of_file; c ;; let end_of_input ib = ignore (peek_char ib); ib.eof ;; let eof ib = ib.eof;; let beginning_of_input ib = ib.char_count = 0;; let name_of_input ib = match ib.input_name with | From_file (fname, _ic) -> fname | From_string -> "unnamed character string" | From_function -> "unnamed function" | From_channel _ic -> "unnamed pervasives input channel" ;; let char_count ib = if ib.current_char_is_valid then ib.char_count - 1 else ib.char_count ;; let line_count ib = ib.line_count;; let reset_token ib = Buffer.reset ib.tokbuf;; let invalidate_current_char ib = ib.current_char_is_valid <- false;; let token ib = let tokbuf = ib.tokbuf in let tok = Buffer.contents tokbuf in Buffer.clear tokbuf; ib.token_count <- succ ib.token_count; tok ;; let token_count ib = ib.token_count;; let skip_char width ib = invalidate_current_char ib; width ;; let ignore_char width ib = skip_char (width - 1) ib;; let store_char width ib c = Buffer.add_char ib.tokbuf c; ignore_char width ib ;; let default_token_buffer_size = 1024;; let create iname next = { eof = false; current_char = null_char; current_char_is_valid = false; char_count = 0; line_count = 0; token_count = 0; get_next_char = next; tokbuf = Buffer.create default_token_buffer_size; input_name = iname; } ;; let from_string s = let i = ref 0 in let len = String.length s in let next () = if !i >= len then raise End_of_file else let c = s.[!i] in incr i; c in create From_string next ;; let from_function = create From_function;; (* Scanning from an input channel. *) (* Position of the problem: We cannot prevent the scanning mechanism to use one lookahead character, if needed by the semantics of the format string specifications (e.g. a trailing ``skip space'' specification in the format string); in this case, the mandatory lookahead character is indeed read from the input and not used to return the token read. It is thus mandatory to be able to store an unused lookahead character somewhere to get it as the first character of the next scan. To circumvent this problem, all the scanning functions get a low level input buffer argument where they store the lookahead character when needed; additionally, the input buffer is the only source of character of a scanner. The [scanbuf] input buffers are defined in module {!Scanning}. Now we understand that it is extremely important that related successive calls to scanners indeed read from the same input buffer. In effect, if a scanner [scan1] is reading from [ib1] and stores an unused lookahead character [c1] into its input buffer [ib1], then another scanner [scan2] not reading from the same buffer [ib1] will miss the character [c], seemingly vanished in the air from the point of view of [scan2]. This mechanism works perfectly to read from strings, from files, and from functions, since in those cases, allocating two buffers reading from the same source is unnatural. Still, there is a difficulty in the case of scanning from an input channel. In effect, when scanning from an input channel [ic], this channel may not have been allocated from within this library. Hence, it may be shared (two functions of the user's program may successively read from [ic]). This is highly error prone since, one of the function may seek the input channel, while the other function has still an unused lookahead character in its input buffer. In conclusion, you should never mix direct low level reading and high level scanning from the same input channel. This phenomenon of reading mess is even worse when one defines more than one scanning buffer reading from the same input channel [ic]. Unfortunately, we have no simple way to get rid of this problem (unless the basic input channel API is modified to offer a ``consider this char as unread'' procedure to keep back the unused lookahead character as available in the input channel for further reading). To prevent some of the confusion the scanning buffer allocation function is a memo function that never allocates two different scanning buffers for the same input channel. This way, the user can naively perform successive call to [fscanf] below, without allocating a new scanning buffer at each invocation and hence preserving the expected semantics. As mentioned above, a more ambitious fix could be to change the input channel API to allow arbitrary mixing of direct and formatted reading from input channels. *) (* Perform bufferized input to improve efficiency. *) let file_buffer_size = ref 1024;; (* The scanner closes the input channel at end of input. *) let scan_close_at_end ic = close_in ic; raise End_of_file;; (* The scanner does not close the input channel at end of input: it just raises [End_of_file]. *) let scan_raise_at_end _ic = raise End_of_file;; let from_ic scan_close_ic iname ic = let len = !file_buffer_size in let buf = String.create len in let i = ref 0 in let lim = ref 0 in let eof = ref false in let next () = if !i < !lim then begin let c = buf.[!i] in incr i; c end else if !eof then raise End_of_file else begin lim := input ic buf 0 len; if !lim = 0 then begin eof := true; scan_close_ic ic end else begin i := 1; buf.[0] end end in create iname next ;; let from_ic_close_at_end = from_ic scan_close_at_end;; (* The scanning buffer reading from [Pervasives.stdin]. One could try to define [stdib] as a scanning buffer reading a character at a time (no bufferization at all), but unfortunately the top-level interaction would be wrong. This is due to some kind of ``race condition'' when reading from [Pervasives.stdin], since the interactive compiler and [scanf] will simultaneously read the material they need from [Pervasives.stdin]; then, confusion will result from what should be read by the top-level and what should be read by [scanf]. This is even more complicated by the one character lookahead that [scanf] is sometimes obliged to maintain: the lookahead character will be available for the next ([scanf]) entry, seemingly coming from nowhere. Also no [End_of_file] is raised when reading from stdin: if not enough characters have been read, we simply ask to read more. *) let stdin = from_ic scan_raise_at_end (From_file ("-", Pervasives.stdin)) Pervasives.stdin ;; let stdib = stdin;; let open_in fname = match fname with | "-" -> stdin | fname -> let ic = open_in fname in from_ic_close_at_end (From_file (fname, ic)) ic ;; let open_in_bin fname = match fname with | "-" -> stdin | fname -> let ic = open_in_bin fname in from_ic_close_at_end (From_file (fname, ic)) ic ;; let from_file = open_in;; let from_file_bin = open_in_bin;; let memo_from_ic = let memo = ref [] in (fun scan_close_ic ic -> try List.assq ic !memo with | Not_found -> let ib = from_ic scan_close_ic (From_channel ic) ic in memo := (ic, ib) :: !memo; ib) ;; let from_channel = memo_from_ic scan_raise_at_end;; let close_in ib = match ib.input_name with | From_file (_fname, ic) -> Pervasives.close_in ic | From_string | From_function -> () | From_channel ic -> Pervasives.close_in ic ;; end ;; (* Formatted input functions. *) type ('a, 'b, 'c, 'd) scanner = ('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c ;; external string_to_format : string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" ;; (* Reporting errors. *) exception Scan_failure of string;; let bad_input s = raise (Scan_failure s);; let bad_input_escape c = bad_input (Printf.sprintf "illegal escape character %C" c) ;; let bad_token_length message = bad_input (Printf.sprintf "scanning of %s failed: \ the specified length was too short for token" message) ;; let bad_end_of_input message = bad_input (Printf.sprintf "scanning of %s failed: \ premature end of file occurred before end of token" message) ;; let int_of_width_opt = function | None -> max_int | Some width -> width ;; let int_of_prec_opt = function | None -> max_int | Some prec -> prec ;; module Sformat = Printf.CamlinternalPr.Sformat;; module Tformat = Printf.CamlinternalPr.Tformat;; let bad_conversion fmt i c = invalid_arg (Printf.sprintf "scanf: bad conversion %%%C, at char number %i \ in format string ``%s''" c i (Sformat.to_string fmt)) ;; let incomplete_format fmt = invalid_arg (Printf.sprintf "scanf: premature end of format string ``%s''" (Sformat.to_string fmt)) ;; let bad_float () = bad_input "no dot or exponent part found in float token" ;; let character_mismatch_err c ci = Printf.sprintf "looking for %C, found %C" c ci ;; let character_mismatch c ci = bad_input (character_mismatch_err c ci) ;; let format_mismatch_err fmt1 fmt2 = Printf.sprintf "format read ``%s'' does not match specification ``%s''" fmt1 fmt2 ;; let format_mismatch fmt1 fmt2 = bad_input (format_mismatch_err fmt1 fmt2);; (* Checking that 2 format strings are type compatible. *) let compatible_format_type fmt1 fmt2 = Tformat.summarize_format_type (string_to_format fmt1) = Tformat.summarize_format_type (string_to_format fmt2);; (* Checking that [c] is indeed in the input, then skips it. In this case, the character c has been explicitly specified in the format as being mandatory in the input; hence we should fail with End_of_file in case of end_of_input. (Remember that Scan_failure is raised only when (we can prove by evidence) that the input does not match the format string given. We must thus differentiate End_of_file as an error due to lack of input, and Scan_failure which is due to provably wrong input. I am not sure this is worth to burden: it is complex and somehow subliminal; should be clearer to fail with Scan_failure "Not enough input to complete scanning"!) That's why, waiting for a better solution, we use checked_peek_char here. We are also careful to treat "\r\n" in the input as a end of line marker: it always matches a '\n' specification in the input format string. *) let rec check_char ib c = let ci = Scanning.checked_peek_char ib in if ci = c then Scanning.invalidate_current_char ib else begin match ci with | '\r' when c = '\n' -> Scanning.invalidate_current_char ib; check_char ib '\n' | _ -> character_mismatch c ci end ;; (* Checks that the current char is indeed one of the stopper characters, then skips it. Be careful that if ib has no more character this procedure should just do nothing (since %s@c defaults to the entire rest of the buffer, when no character c can be found in the input). *) let ignore_stoppers stps ib = if stps <> [] && not (Scanning.eof ib) then let ci = Scanning.peek_char ib in if List.memq ci stps then Scanning.invalidate_current_char ib else let sr = String.concat "" (List.map (String.make 1) stps) in bad_input (Printf.sprintf "looking for one of range %S, found %C" sr ci) ;; (* Extracting tokens from the output token buffer. *) let token_char ib = (Scanning.token ib).[0];; let token_string = Scanning.token;; let token_bool ib = match Scanning.token ib with | "true" -> true | "false" -> false | s -> bad_input (Printf.sprintf "invalid boolean %S" s) ;; (* Extract an integer literal token. Since the functions Pervasives.*int*_of_string do not accept a leading +, we skip it if necessary. *) let token_int_literal conv ib = let tok = match conv with | 'd' | 'i' | 'u' -> Scanning.token ib | 'o' -> "0o" ^ Scanning.token ib | 'x' | 'X' -> "0x" ^ Scanning.token ib | 'b' -> "0b" ^ Scanning.token ib | _ -> assert false in let l = String.length tok in if l = 0 || tok.[0] <> '+' then tok else String.sub tok 1 (l - 1) ;; (* All the functions that convert a string to a number raise the exception Failure when the conversion is not possible. This exception is then trapped in [kscanf]. *) let token_int conv ib = int_of_string (token_int_literal conv ib);; let token_float ib = float_of_string (Scanning.token ib);; (* To scan native ints, int32 and int64 integers. We cannot access to conversions to/from strings for those types, Nativeint.of_string, Int32.of_string, and Int64.of_string, since those modules are not available to [Scanf]. However, we can bind and use the corresponding primitives that are available in the runtime. *) external nativeint_of_string : string -> nativeint = "caml_nativeint_of_string" ;; external int32_of_string : string -> int32 = "caml_int32_of_string" ;; external int64_of_string : string -> int64 = "caml_int64_of_string" ;; let token_nativeint conv ib = nativeint_of_string (token_int_literal conv ib);; let token_int32 conv ib = int32_of_string (token_int_literal conv ib);; let token_int64 conv ib = int64_of_string (token_int_literal conv ib);; (* Scanning numbers. *) (* Digits scanning functions suppose that one character has been checked and is available, since they return at end of file with the currently found token selected. Put it in another way, the digits scanning functions scan for a possibly empty sequence of digits, (hence, a successful scanning from one of those functions does not imply that the token is a well-formed number: to get a true number, it is mandatory to check that at least one valid digit is available before calling one of the digit scanning functions). *) (* The decimal case is treated especially for optimization purposes. *) let rec scan_decimal_digits width ib = if width = 0 then width else let c = Scanning.peek_char ib in if Scanning.eof ib then width else match c with | '0' .. '9' as c -> let width = Scanning.store_char width ib c in scan_decimal_digits width ib | '_' -> let width = Scanning.ignore_char width ib in scan_decimal_digits width ib | _ -> width ;; let scan_decimal_digits_plus width ib = if width = 0 then bad_token_length "decimal digits" else let c = Scanning.checked_peek_char ib in match c with | '0' .. '9' -> let width = Scanning.store_char width ib c in scan_decimal_digits width ib | c -> bad_input (Printf.sprintf "character %C is not a decimal digit" c) ;; let scan_digits_plus digitp width ib = (* To scan numbers from other bases, we use a predicate argument to scan_digits. *) let rec scan_digits width = if width = 0 then width else let c = Scanning.peek_char ib in if Scanning.eof ib then width else match c with | c when digitp c -> let width = Scanning.store_char width ib c in scan_digits width | '_' -> let width = Scanning.ignore_char width ib in scan_digits width | _ -> width in (* Ensure we have got enough width left, and read at list one digit. *) if width = 0 then bad_token_length "digits" else let c = Scanning.checked_peek_char ib in if digitp c then let width = Scanning.store_char width ib c in scan_digits width else bad_input (Printf.sprintf "character %C is not a digit" c) ;; let is_binary_digit = function | '0' .. '1' -> true | _ -> false ;; let scan_binary_int = scan_digits_plus is_binary_digit;; let is_octal_digit = function | '0' .. '7' -> true | _ -> false ;; let scan_octal_int = scan_digits_plus is_octal_digit;; let is_hexa_digit = function | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false ;; let scan_hexadecimal_int = scan_digits_plus is_hexa_digit;; (* Scan a decimal integer. *) let scan_unsigned_decimal_int = scan_decimal_digits_plus;; let scan_sign width ib = let c = Scanning.checked_peek_char ib in match c with | '+' -> Scanning.store_char width ib c | '-' -> Scanning.store_char width ib c | _ -> width ;; let scan_optionally_signed_decimal_int width ib = let width = scan_sign width ib in scan_unsigned_decimal_int width ib ;; (* Scan an unsigned integer that could be given in any (common) basis. If digits are prefixed by one of 0x, 0X, 0o, or 0b, the number is assumed to be written respectively in hexadecimal, hexadecimal, octal, or binary. *) let scan_unsigned_int width ib = match Scanning.checked_peek_char ib with | '0' as c -> let width = Scanning.store_char width ib c in if width = 0 then width else let c = Scanning.peek_char ib in if Scanning.eof ib then width else begin match c with | 'x' | 'X' -> scan_hexadecimal_int (Scanning.store_char width ib c) ib | 'o' -> scan_octal_int (Scanning.store_char width ib c) ib | 'b' -> scan_binary_int (Scanning.store_char width ib c) ib | _ -> scan_decimal_digits width ib end | _ -> scan_unsigned_decimal_int width ib ;; let scan_optionally_signed_int width ib = let width = scan_sign width ib in scan_unsigned_int width ib ;; let scan_int_conv conv width _prec ib = match conv with | 'b' -> scan_binary_int width ib | 'd' -> scan_optionally_signed_decimal_int width ib | 'i' -> scan_optionally_signed_int width ib | 'o' -> scan_octal_int width ib | 'u' -> scan_unsigned_decimal_int width ib | 'x' | 'X' -> scan_hexadecimal_int width ib | _ -> assert false ;; (* Scanning floating point numbers. *) (* Fractional part is optional and can be reduced to 0 digits. *) let scan_frac_part width ib = if width = 0 then width else let c = Scanning.peek_char ib in if Scanning.eof ib then width else match c with | '0' .. '9' as c -> scan_decimal_digits (Scanning.store_char width ib c) ib | _ -> width ;; (* Exp part is optional and can be reduced to 0 digits. *) let scan_exp_part width ib = if width = 0 then width else let c = Scanning.peek_char ib in if Scanning.eof ib then width else match c with | 'e' | 'E' as c -> scan_optionally_signed_decimal_int (Scanning.store_char width ib c) ib | _ -> width ;; (* Scan the integer part of a floating point number, (not using the OCaml lexical convention since the integer part can be empty): an optional sign, followed by a possibly empty sequence of decimal digits (e.g. -.1). *) let scan_int_part width ib = let width = scan_sign width ib in scan_decimal_digits width ib ;; (* For the time being we have (as found in scanf.mli): The field width is composed of an optional integer literal indicating the maximal width of the token to read. Unfortunately, the type-checker let the user write an optional precision, since this is valid for printf format strings. Thus, the next step for Scanf is to support a full width and precision indication, more or less similar to the one for printf, possibly extended to the specification of a [max, min] range for the width of the token read for strings. Something like the following spec for scanf.mli: The optional [width] is an integer indicating the maximal width of the token read. For instance, [%6d] reads an integer, having at most 6 characters. The optional [precision] is a dot [.] followed by an integer: - in the floating point number conversions ([%f], [%e], [%g], [%F], [%E], and [%F] conversions, the [precision] indicates the maximum number of digits that may follow the decimal point. For instance, [%.4f] reads a [float] with at most 4 fractional digits, - in the string conversions ([%s], [%S], [%\[ range \]]), and in the integer number conversions ([%i], [%d], [%u], [%x], [%o], and their [int32], [int64], and [native_int] correspondent), the [precision] indicates the required minimum width of the token read, - on all other conversions, the width and precision are meaningless and ignored (FIXME: lead to a runtime error ? type checking error ?). *) let scan_float width precision ib = let width = scan_int_part width ib in if width = 0 then width, precision else let c = Scanning.peek_char ib in if Scanning.eof ib then width, precision else match c with | '.' -> let width = Scanning.store_char width ib c in let precision = min width precision in let width = width - (precision - scan_frac_part precision ib) in scan_exp_part width ib, precision | _ -> scan_exp_part width ib, precision ;; let scan_Float width precision ib = let width = scan_optionally_signed_decimal_int width ib in if width = 0 then bad_float () else let c = Scanning.peek_char ib in if Scanning.eof ib then bad_float () else match c with | '.' -> let width = Scanning.store_char width ib c in let precision = min width precision in let width = width - (precision - scan_frac_part precision ib) in scan_exp_part width ib | 'e' | 'E' -> scan_exp_part width ib | _ -> bad_float () ;; (* Scan a regular string: stops when encountering a space, if no scanning indication has been given; otherwise, stops when encountering one of the characters in the scanning indication list [stp]. It also stops at end of file or when the maximum number of characters has been read.*) let scan_string stp width ib = let rec loop width = if width = 0 then width else let c = Scanning.peek_char ib in if Scanning.eof ib then width else if stp = [] then match c with | ' ' | '\t' | '\n' | '\r' -> width | c -> loop (Scanning.store_char width ib c) else if List.memq c stp then Scanning.skip_char width ib else loop (Scanning.store_char width ib c) in loop width ;; (* Scan a char: peek strictly one character in the input, whatsoever. *) let scan_char width ib = (* The case width = 0 could not happen here, since it is tested before calling scan_char, in the main scanning function. if width = 0 then bad_token_length "a character" else *) Scanning.store_char width ib (Scanning.checked_peek_char ib) ;; let char_for_backslash = function | 'n' -> '\010' | 'r' -> '\013' | 'b' -> '\008' | 't' -> '\009' | c -> c ;; (* The integer value corresponding to the facial value of a valid decimal digit character. *) let decimal_value_of_char c = int_of_char c - int_of_char '0';; let char_for_decimal_code c0 c1 c2 = let c = 100 * decimal_value_of_char c0 + 10 * decimal_value_of_char c1 + decimal_value_of_char c2 in if c < 0 || c > 255 then bad_input (Printf.sprintf "bad character decimal encoding \\%c%c%c" c0 c1 c2) else char_of_int c ;; (* The integer value corresponding to the facial value of a valid hexadecimal digit character. *) let hexadecimal_value_of_char c = let d = int_of_char c in (* Could also be: if d <= int_of_char '9' then d - int_of_char '0' else if d <= int_of_char 'F' then 10 + d - int_of_char 'A' else if d <= int_of_char 'f' then 10 + d - int_of_char 'a' else assert false *) if d >= int_of_char 'a' then d - 87 (* 10 + int_of_char c - int_of_char 'a' *) else if d >= int_of_char 'A' then d - 55 (* 10 + int_of_char c - int_of_char 'A' *) else d - int_of_char '0' ;; let char_for_hexadecimal_code c1 c2 = let c = 16 * hexadecimal_value_of_char c1 + hexadecimal_value_of_char c2 in if c < 0 || c > 255 then bad_input (Printf.sprintf "bad character hexadecimal encoding \\%c%c" c1 c2) else char_of_int c ;; (* Called in particular when encountering '\\' as starter of a char. Stops before the corresponding '\''. *) let check_next_char message width ib = if width = 0 then bad_token_length message else let c = Scanning.peek_char ib in if Scanning.eof ib then bad_end_of_input message else c ;; let check_next_char_for_char = check_next_char "a Char";; let check_next_char_for_string = check_next_char "a String";; let scan_backslash_char width ib = match check_next_char_for_char width ib with | '\\' | '\'' | '\"' | 'n' | 't' | 'b' | 'r' as c -> Scanning.store_char width ib (char_for_backslash c) | '0' .. '9' as c -> let get_digit () = let c = Scanning.next_char ib in match c with | '0' .. '9' as c -> c | c -> bad_input_escape c in let c0 = c in let c1 = get_digit () in let c2 = get_digit () in Scanning.store_char (width - 2) ib (char_for_decimal_code c0 c1 c2) | 'x' -> let get_digit () = let c = Scanning.next_char ib in match c with | '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' as c -> c | c -> bad_input_escape c in let c1 = get_digit () in let c2 = get_digit () in Scanning.store_char (width - 2) ib (char_for_hexadecimal_code c1 c2) | c -> bad_input_escape c ;; (* Scan a character (an OCaml token). *) let scan_Char width ib = let rec find_start width = match Scanning.checked_peek_char ib with | '\'' -> find_char (Scanning.ignore_char width ib) | c -> character_mismatch '\'' c and find_char width = match check_next_char_for_char width ib with | '\\' -> find_stop (scan_backslash_char (Scanning.ignore_char width ib) ib) | c -> find_stop (Scanning.store_char width ib c) and find_stop width = match check_next_char_for_char width ib with | '\'' -> Scanning.ignore_char width ib | c -> character_mismatch '\'' c in find_start width ;; (* Scan a delimited string (an OCaml token). *) let scan_String width ib = let rec find_start width = match Scanning.checked_peek_char ib with | '\"' -> find_stop (Scanning.ignore_char width ib) | c -> character_mismatch '\"' c and find_stop width = match check_next_char_for_string width ib with | '\"' -> Scanning.ignore_char width ib | '\\' -> scan_backslash (Scanning.ignore_char width ib) | c -> find_stop (Scanning.store_char width ib c) and scan_backslash width = match check_next_char_for_string width ib with | '\r' -> skip_newline (Scanning.ignore_char width ib) | '\n' -> skip_spaces (Scanning.ignore_char width ib) | _ -> find_stop (scan_backslash_char width ib) and skip_newline width = match check_next_char_for_string width ib with | '\n' -> skip_spaces (Scanning.ignore_char width ib) | _ -> find_stop (Scanning.store_char width ib '\r') and skip_spaces width = match check_next_char_for_string width ib with | ' ' -> skip_spaces (Scanning.ignore_char width ib) | _ -> find_stop width in find_start width ;; (* Scan a boolean (an OCaml token). *) let scan_bool width ib = if width < 4 then bad_token_length "a boolean" else let c = Scanning.checked_peek_char ib in let m = match c with | 't' -> 4 | 'f' -> 5 | c -> bad_input (Printf.sprintf "the character %C cannot start a boolean" c) in scan_string [] (min width m) ib ;; (* Reading char sets in %[...] conversions. *) type char_set = | Pos_set of string (* Positive (regular) set. *) | Neg_set of string (* Negative (complementary) set. *) ;; (* Char sets are read as sub-strings in the format string. *) let scan_range fmt j = let len = Sformat.length fmt in let buffer = Buffer.create len in let rec scan_closing j = if j >= len then incomplete_format fmt else match Sformat.get fmt j with | ']' -> j, Buffer.contents buffer | '%' -> let j = j + 1 in if j >= len then incomplete_format fmt else begin match Sformat.get fmt j with | '%' | '@' as c -> Buffer.add_char buffer c; scan_closing (j + 1) | c -> bad_conversion fmt j c end | c -> Buffer.add_char buffer c; scan_closing (j + 1) in let scan_first_pos j = if j >= len then incomplete_format fmt else match Sformat.get fmt j with | ']' as c -> Buffer.add_char buffer c; scan_closing (j + 1) | _ -> scan_closing j in let scan_first_neg j = if j >= len then incomplete_format fmt else match Sformat.get fmt j with | '^' -> let j = j + 1 in let k, char_set = scan_first_pos j in k, Neg_set char_set | _ -> let k, char_set = scan_first_pos j in k, Pos_set char_set in scan_first_neg j ;; (* Char sets are now represented as bit vectors that are represented as byte strings. *) (* Bit manipulations into bytes. *) let set_bit_of_byte byte idx b = (b lsl idx) lor (byte land (* mask idx *) (lnot (1 lsl idx))) ;; let get_bit_of_byte byte idx = (byte lsr idx) land 1;; (* Bit manipulations in vectors of bytes represented as strings. *) let set_bit_of_range r c b = let idx = c land 0x7 in let ydx = c lsr 3 in let byte = r.[ydx] in r.[ydx] <- char_of_int (set_bit_of_byte (int_of_char byte) idx b) ;; let get_bit_of_range r c = let idx = c land 0x7 in let ydx = c lsr 3 in let byte = r.[ydx] in get_bit_of_byte (int_of_char byte) idx ;; (* Char sets represented as bit vectors represented as fixed length byte strings. *) (* Create a full or empty set of chars. *) let make_range bit = let c = char_of_int (if bit = 0 then 0 else 0xFF) in String.make 32 c ;; (* Test if a char belongs to a set of chars. *) let get_char_in_range r c = get_bit_of_range r (int_of_char c);; let bit_not b = (lnot b) land 1;; (* Build the bit vector corresponding to the set of characters that belongs to the string argument [set]. (In the [Scanf] module [set] is always a sub-string of the format.) *) let make_char_bit_vect bit set = let r = make_range (bit_not bit) in let lim = String.length set - 1 in let rec loop bit rp i = if i <= lim then match set.[i] with | '-' when rp -> (* if i = 0 then rp is false (since the initial call is loop bit false 0). Hence i >= 1 and the following is safe. *) let c1 = set.[i - 1] in let i = succ i in if i > lim then loop bit false (i - 1) else let c2 = set.[i] in for j = int_of_char c1 to int_of_char c2 do set_bit_of_range r j bit done; loop bit false (succ i) | _ -> set_bit_of_range r (int_of_char set.[i]) bit; loop bit true (succ i) in loop bit false 0; r ;; (* Compute the predicate on chars corresponding to a char set. *) let make_predicate bit set stp = let r = make_char_bit_vect bit set in List.iter (fun c -> set_bit_of_range r (int_of_char c) (bit_not bit)) stp; (fun c -> get_char_in_range r c) ;; let make_setp stp char_set = match char_set with | Pos_set set -> begin match String.length set with | 0 -> (fun _ -> 0) | 1 -> let p = set.[0] in (fun c -> if c == p then 1 else 0) | 2 -> let p1 = set.[0] and p2 = set.[1] in (fun c -> if c == p1 || c == p2 then 1 else 0) | 3 -> let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in if p2 = '-' then make_predicate 1 set stp else (fun c -> if c == p1 || c == p2 || c == p3 then 1 else 0) | _ -> make_predicate 1 set stp end | Neg_set set -> begin match String.length set with | 0 -> (fun _ -> 1) | 1 -> let p = set.[0] in (fun c -> if c != p then 1 else 0) | 2 -> let p1 = set.[0] and p2 = set.[1] in (fun c -> if c != p1 && c != p2 then 1 else 0) | 3 -> let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in if p2 = '-' then make_predicate 0 set stp else (fun c -> if c != p1 && c != p2 && c != p3 then 1 else 0) | _ -> make_predicate 0 set stp end ;; let setp_table = Hashtbl.create 7;; let add_setp stp char_set setp = let char_set_tbl = try Hashtbl.find setp_table char_set with | Not_found -> let char_set_tbl = Hashtbl.create 3 in Hashtbl.add setp_table char_set char_set_tbl; char_set_tbl in Hashtbl.add char_set_tbl stp setp ;; let find_setp stp char_set = try Hashtbl.find (Hashtbl.find setp_table char_set) stp with | Not_found -> let setp = make_setp stp char_set in add_setp stp char_set setp; setp ;; let scan_chars_in_char_set stp char_set width ib = let rec loop_pos1 cp1 width = if width = 0 then width else let c = Scanning.peek_char ib in if Scanning.eof ib then width else if c == cp1 then loop_pos1 cp1 (Scanning.store_char width ib c) else width and loop_pos2 cp1 cp2 width = if width = 0 then width else let c = Scanning.peek_char ib in if Scanning.eof ib then width else if c == cp1 || c == cp2 then loop_pos2 cp1 cp2 (Scanning.store_char width ib c) else width and loop_pos3 cp1 cp2 cp3 width = if width = 0 then width else let c = Scanning.peek_char ib in if Scanning.eof ib then width else if c == cp1 || c == cp2 || c == cp3 then loop_pos3 cp1 cp2 cp3 (Scanning.store_char width ib c) else width and loop_neg1 cp1 width = if width = 0 then width else let c = Scanning.peek_char ib in if Scanning.eof ib then width else if c != cp1 then loop_neg1 cp1 (Scanning.store_char width ib c) else width and loop_neg2 cp1 cp2 width = if width = 0 then width else let c = Scanning.peek_char ib in if Scanning.eof ib then width else if c != cp1 && c != cp2 then loop_neg2 cp1 cp2 (Scanning.store_char width ib c) else width and loop_neg3 cp1 cp2 cp3 width = if width = 0 then width else let c = Scanning.peek_char ib in if Scanning.eof ib then width else if c != cp1 && c != cp2 && c != cp3 then loop_neg3 cp1 cp2 cp3 (Scanning.store_char width ib c) else width and loop setp width = if width = 0 then width else let c = Scanning.peek_char ib in if Scanning.eof ib then width else if setp c == 1 then loop setp (Scanning.store_char width ib c) else width in let width = match char_set with | Pos_set set -> begin match String.length set with | 0 -> loop (fun _ -> 0) width | 1 -> loop_pos1 set.[0] width | 2 -> loop_pos2 set.[0] set.[1] width | 3 when set.[1] != '-' -> loop_pos3 set.[0] set.[1] set.[2] width | _ -> loop (find_setp stp char_set) width end | Neg_set set -> begin match String.length set with | 0 -> loop (fun _ -> 1) width | 1 -> loop_neg1 set.[0] width | 2 -> loop_neg2 set.[0] set.[1] width | 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] width | _ -> loop (find_setp stp char_set) width end in ignore_stoppers stp ib; width ;; let get_count t ib = match t with | 'l' -> Scanning.line_count ib | 'n' -> Scanning.char_count ib | _ -> Scanning.token_count ib ;; let rec skip_whites ib = let c = Scanning.peek_char ib in if not (Scanning.eof ib) then begin match c with | ' ' | '\t' | '\n' | '\r' -> Scanning.invalidate_current_char ib; skip_whites ib | _ -> () end ;; (* The global error report function for [Scanf]. *) let scanf_bad_input ib = function | Scan_failure s | Failure s -> let i = Scanning.char_count ib in bad_input (Printf.sprintf "scanf: bad input at char number %i: ``%s''" i s) | x -> raise x ;; let list_iter_i f l = let rec loop i = function | [] -> () | [x] -> f i x (* Tail calling [f] *) | x :: xs -> f i x; loop (succ i) xs in loop 0 l ;; let ascanf sc fmt = let ac = Tformat.ac_of_format fmt in match ac.Tformat.ac_rdrs with | 0 -> Obj.magic (fun f -> sc fmt [||] f) | 1 -> Obj.magic (fun x f -> sc fmt [| Obj.repr x |] f) | 2 -> Obj.magic (fun x y f -> sc fmt [| Obj.repr x; Obj.repr y; |] f) | 3 -> Obj.magic (fun x y z f -> sc fmt [| Obj.repr x; Obj.repr y; Obj.repr z; |] f) | nargs -> let rec loop i args = if i >= nargs then let a = Array.make nargs (Obj.repr 0) in list_iter_i (fun i arg -> a.(nargs - i - 1) <- arg) args; Obj.magic (fun f -> sc fmt a f) else Obj.magic (fun x -> loop (succ i) (x :: args)) in loop 0 [] ;; (* The [scan_format] main scanning function. It takes as arguments: - an input buffer [ib] from which to read characters, - an error handling function [ef], - a format [fmt] that specifies what to read in the input, - a vector of user's defined readers [rv], - and a function [f] to pass the tokens read to. Then [scan_format] scans the format and the input buffer in parallel to find out tokens as specified by the format; when it finds one token, it converts it as specified, remembers the converted value as a future argument to the function [f], and continues scanning. If the entire scanning succeeds (i.e. the format string has been exhausted and the buffer has provided tokens according to the format string), [f] is applied to the tokens read. If the scanning or some conversion fails, the main scanning function aborts and applies the scanning buffer and a string that explains the error to the error handling function [ef] (the error continuation). *) let scan_format ib ef fmt rv f = let limr = Array.length rv - 1 in let return v = Obj.magic v () in let delay f x () = f x in let stack f = delay (return f) in let no_stack f _x = f in let rec scan fmt = let lim = Sformat.length fmt - 1 in let rec scan_fmt ir f i = if i > lim then ir, f else match Sformat.unsafe_get fmt i with | '%' -> scan_skip ir f (succ i) | ' ' -> skip_whites ib; scan_fmt ir f (succ i) | c -> check_char ib c; scan_fmt ir f (succ i) and scan_skip ir f i = if i > lim then ir, f else match Sformat.get fmt i with | '_' -> scan_limits true ir f (succ i) | _ -> scan_limits false ir f i and scan_limits skip ir f i = let rec scan_width i = if i > lim then incomplete_format fmt else match Sformat.get fmt i with | '0' .. '9' as conv -> let width, i = read_int_literal (decimal_value_of_char conv) (succ i) in Some width, i | _ -> None, i and scan_precision i = begin match Sformat.get fmt i with | '.' -> let precision, i = read_int_literal 0 (succ i) in (Some precision, i) | _ -> None, i end and read_int_literal accu i = if i > lim then accu, i else match Sformat.unsafe_get fmt i with | '0' .. '9' as c -> let accu = 10 * accu + decimal_value_of_char c in read_int_literal accu (succ i) | _ -> accu, i in if i > lim then ir, f else let width_opt, i = scan_width i in let prec_opt, i = scan_precision i in scan_conversion skip width_opt prec_opt ir f i and scan_conversion skip width_opt prec_opt ir f i = let stack = if skip then no_stack else stack in let width = int_of_width_opt width_opt in let prec = int_of_prec_opt prec_opt in match Sformat.get fmt i with | '%' | '@' as c -> check_char ib c; scan_fmt ir f (succ i) | '!' -> if not (Scanning.end_of_input ib) then bad_input "end of input not found" else scan_fmt ir f (succ i) | ',' -> scan_fmt ir f (succ i) | 's' -> let i, stp = scan_indication (succ i) in let _x = scan_string stp width ib in scan_fmt ir (stack f (token_string ib)) (succ i) | 'S' -> let _x = scan_String width ib in scan_fmt ir (stack f (token_string ib)) (succ i) | '[' (* ']' *) -> let i, char_set = scan_range fmt (succ i) in let i, stp = scan_indication (succ i) in let _x = scan_chars_in_char_set stp char_set width ib in scan_fmt ir (stack f (token_string ib)) (succ i) | ('c' | 'C') when width = 0 -> let c = Scanning.checked_peek_char ib in scan_fmt ir (stack f c) (succ i) | 'c' -> let _x = scan_char width ib in scan_fmt ir (stack f (token_char ib)) (succ i) | 'C' -> let _x = scan_Char width ib in scan_fmt ir (stack f (token_char ib)) (succ i) | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv -> let _x = scan_int_conv conv width prec ib in scan_fmt ir (stack f (token_int conv ib)) (succ i) | 'N' as conv -> scan_fmt ir (stack f (get_count conv ib)) (succ i) | 'f' | 'e' | 'E' | 'g' | 'G' -> let _x = scan_float width prec ib in scan_fmt ir (stack f (token_float ib)) (succ i) | 'F' -> let _x = scan_Float width prec ib in scan_fmt ir (stack f (token_float ib)) (succ i) (* | 'B' | 'b' when width = Some 0 -> let _x = scan_bool width ib in scan_fmt ir (stack f (token_int ib)) (succ i) *) | 'B' | 'b' -> let _x = scan_bool width ib in scan_fmt ir (stack f (token_bool ib)) (succ i) | 'r' -> if ir > limr then assert false else let token = Obj.magic rv.(ir) ib in scan_fmt (succ ir) (stack f token) (succ i) | 'l' | 'n' | 'L' as conv0 -> let i = succ i in if i > lim then scan_fmt ir (stack f (get_count conv0 ib)) i else begin match Sformat.get fmt i with (* This is in fact an integer conversion (e.g. %ld, %ni, or %Lo). *) | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv1 -> let _x = scan_int_conv conv1 width prec ib in (* Look back to the character that triggered the integer conversion (this character is either 'l', 'n' or 'L') to find the conversion to apply to the integer token read. *) begin match conv0 with | 'l' -> scan_fmt ir (stack f (token_int32 conv1 ib)) (succ i) | 'n' -> scan_fmt ir (stack f (token_nativeint conv1 ib)) (succ i) | _ -> scan_fmt ir (stack f (token_int64 conv1 ib)) (succ i) end (* This is not an integer conversion, but a regular %l, %n or %L. *) | _ -> scan_fmt ir (stack f (get_count conv0 ib)) i end | '(' | '{' as conv (* ')' '}' *) -> let i = succ i in (* Find the static specification for the format to read. *) let j = Tformat.sub_format incomplete_format bad_conversion conv fmt i in let mf = Sformat.sub fmt (Sformat.index_of_int i) (j - 2 - i) in (* Read the specified format string in the input buffer, and check its correctness. *) let _x = scan_String width ib in let rf = token_string ib in if not (compatible_format_type rf mf) then format_mismatch rf mf else (* For conversion %{%}, just return this format string as the token read. *) if conv = '{' (* '}' *) then scan_fmt ir (stack f rf) j else (* Or else, read according to the format string just read. *) let ir, nf = scan (string_to_format rf) ir (stack f rf) 0 in (* Return the format string read and the value just read, then go on with the rest of the format. *) scan_fmt ir nf j | c -> bad_conversion fmt i c and scan_indication j = if j > lim then j - 1, [] else match Sformat.get fmt j with | '@' -> let k = j + 1 in if k > lim then j - 1, [] else begin match Sformat.get fmt k with | '%' -> let k = k + 1 in if k > lim then j - 1, [] else begin match Sformat.get fmt k with | '%' | '@' as c -> k, [ c ] | _c -> j - 1, [] end | c -> k, [ c ] end | _c -> j - 1, [] in scan_fmt in Scanning.reset_token ib; let v = try snd (scan fmt 0 (fun () -> f) 0) with | (Scan_failure _ | Failure _ | End_of_file) as exc -> stack (delay ef ib) exc in return v ;; let mkscanf ib ef fmt = let sc = scan_format ib ef in ascanf sc fmt ;; let kscanf ib ef fmt = mkscanf ib ef fmt;; let bscanf ib = kscanf ib scanf_bad_input;; let fscanf ic = bscanf (Scanning.from_channel ic);; let sscanf : string -> ('a, 'b, 'c, 'd) scanner = fun s -> bscanf (Scanning.from_string s);; let scanf fmt = bscanf Scanning.stdib fmt;; let bscanf_format ib fmt f = let fmt = Sformat.unsafe_to_string fmt in let fmt1 = ignore (scan_String max_int ib); token_string ib in if not (compatible_format_type fmt1 fmt) then format_mismatch fmt1 fmt else f (string_to_format fmt1) ;; let sscanf_format s fmt = bscanf_format (Scanning.from_string s) fmt;; let string_to_String s = let l = String.length s in let b = Buffer.create (l + 2) in Buffer.add_char b '\"'; for i = 0 to l - 1 do let c = s.[i] in if c = '\"' then Buffer.add_char b '\\'; Buffer.add_char b c; done; Buffer.add_char b '\"'; Buffer.contents b ;; let format_from_string s fmt = sscanf_format (string_to_String s) fmt (fun x -> x) ;; let unescaped s = sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x) (* Local Variables: compile-command: "cd ..; make world" End: *) mingw-ocaml/ocaml/stdlib/sharpbang0000644000175000017500000000000312124403240016617 0ustar tootstoots#! mingw-ocaml/ocaml/stdlib/queue.mli0000644000175000017500000000532712124403240016574 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** First-in first-out queues. This module implements queues (FIFOs), with in-place modification. *) type 'a t (** The type of queues containing elements of type ['a]. *) exception Empty (** Raised when {!Queue.take} or {!Queue.peek} is applied to an empty queue. *) val create : unit -> 'a t (** Return a new queue, initially empty. *) val add : 'a -> 'a t -> unit (** [add x q] adds the element [x] at the end of the queue [q]. *) val push : 'a -> 'a t -> unit (** [push] is a synonym for [add]. *) val take : 'a t -> 'a (** [take q] removes and returns the first element in queue [q], or raises [Empty] if the queue is empty. *) val pop : 'a t -> 'a (** [pop] is a synonym for [take]. *) val peek : 'a t -> 'a (** [peek q] returns the first element in queue [q], without removing it from the queue, or raises [Empty] if the queue is empty. *) val top : 'a t -> 'a (** [top] is a synonym for [peek]. *) val clear : 'a t -> unit (** Discard all elements from a queue. *) val copy : 'a t -> 'a t (** Return a copy of the given queue. *) val is_empty : 'a t -> bool (** Return [true] if the given queue is empty, [false] otherwise. *) val length : 'a t -> int (** Return the number of elements in a queue. *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f q] applies [f] in turn to all elements of [q], from the least recently entered to the most recently entered. The queue itself is unchanged. *) val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b (** [fold f accu q] is equivalent to [List.fold_left f accu l], where [l] is the list of [q]'s elements. The queue remains unchanged. *) val transfer : 'a t -> 'a t -> unit (** [transfer q1 q2] adds all of [q1]'s elements at the end of the queue [q2], then clears [q1]. It is equivalent to the sequence [iter (fun x -> add x q2) q1; clear q1], but runs in constant time. *) mingw-ocaml/ocaml/stdlib/weak.ml0000644000175000017500000002206012124403240016217 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Weak array operations *) type 'a t;; external create: int -> 'a t = "caml_weak_create";; let length x = Obj.size(Obj.repr x) - 1;; external set : 'a t -> int -> 'a option -> unit = "caml_weak_set";; external get: 'a t -> int -> 'a option = "caml_weak_get";; external get_copy: 'a t -> int -> 'a option = "caml_weak_get_copy";; external check: 'a t -> int -> bool = "caml_weak_check";; external blit: 'a t -> int -> 'a t -> int -> int -> unit = "caml_weak_blit";; (* blit: src srcoff dst dstoff len *) let fill ar ofs len x = if ofs < 0 || len < 0 || ofs + len > length ar then raise (Invalid_argument "Weak.fill") else begin for i = ofs to (ofs + len - 1) do set ar i x done end ;; (** Weak hash tables *) module type S = sig type data type t val create : int -> t val clear : t -> unit val merge : t -> data -> data val add : t -> data -> unit val remove : t -> data -> unit val find : t -> data -> data val find_all : t -> data -> data list val mem : t -> data -> bool val iter : (data -> unit) -> t -> unit val fold : (data -> 'a -> 'a) -> t -> 'a -> 'a val count : t -> int val stats : t -> int * int * int * int * int * int end;; module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct type 'a weak_t = 'a t;; let weak_create = create;; let emptybucket = weak_create 0;; type data = H.t;; type t = { mutable table : data weak_t array; mutable hashes : int array array; mutable limit : int; (* bucket size limit *) mutable oversize : int; (* number of oversize buckets *) mutable rover : int; (* for internal bookkeeping *) };; let get_index t h = (h land max_int) mod (Array.length t.table);; let limit = 7;; let over_limit = 2;; let create sz = let sz = if sz < 7 then 7 else sz in let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in { table = Array.create sz emptybucket; hashes = Array.create sz [| |]; limit = limit; oversize = 0; rover = 0; };; let clear t = for i = 0 to Array.length t.table - 1 do t.table.(i) <- emptybucket; t.hashes.(i) <- [| |]; done; t.limit <- limit; t.oversize <- 0; ;; let fold f t init = let rec fold_bucket i b accu = if i >= length b then accu else match get b i with | Some v -> fold_bucket (i+1) b (f v accu) | None -> fold_bucket (i+1) b accu in Array.fold_right (fold_bucket 0) t.table init ;; let iter f t = let rec iter_bucket i b = if i >= length b then () else match get b i with | Some v -> f v; iter_bucket (i+1) b | None -> iter_bucket (i+1) b in Array.iter (iter_bucket 0) t.table ;; let iter_weak f t = let rec iter_bucket i j b = if i >= length b then () else match check b i with | true -> f b t.hashes.(j) i; iter_bucket (i+1) j b | false -> iter_bucket (i+1) j b in Array.iteri (iter_bucket 0) t.table ;; let rec count_bucket i b accu = if i >= length b then accu else count_bucket (i+1) b (accu + (if check b i then 1 else 0)) ;; let count t = Array.fold_right (count_bucket 0) t.table 0 ;; let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length;; let prev_sz n = ((n - 3) * 2 + 2) / 3;; let test_shrink_bucket t = let bucket = t.table.(t.rover) in let hbucket = t.hashes.(t.rover) in let len = length bucket in let prev_len = prev_sz len in let live = count_bucket 0 bucket 0 in if live <= prev_len then begin let rec loop i j = if j >= prev_len then begin if check bucket i then loop (i + 1) j else if check bucket j then begin blit bucket j bucket i 1; hbucket.(i) <- hbucket.(j); loop (i + 1) (j - 1); end else loop i (j - 1); end; in loop 0 (length bucket - 1); if prev_len = 0 then begin t.table.(t.rover) <- emptybucket; t.hashes.(t.rover) <- [| |]; end else begin Obj.truncate (Obj.repr bucket) (prev_len + 1); Obj.truncate (Obj.repr hbucket) prev_len; end; if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1; end; t.rover <- (t.rover + 1) mod (Array.length t.table); ;; let rec resize t = let oldlen = Array.length t.table in let newlen = next_sz oldlen in if newlen > oldlen then begin let newt = create newlen in let add_weak ob oh oi = let setter nb ni _ = blit ob oi nb ni 1 in let h = oh.(oi) in add_aux newt setter None h (get_index newt h); in iter_weak add_weak t; t.table <- newt.table; t.hashes <- newt.hashes; t.limit <- newt.limit; t.oversize <- newt.oversize; t.rover <- t.rover mod Array.length newt.table; end else begin t.limit <- max_int; (* maximum size already reached *) t.oversize <- 0; end and add_aux t setter d h index = let bucket = t.table.(index) in let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i = if i >= sz then begin let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more"; let newbucket = weak_create newsz in let newhashes = Array.make newsz 0 in blit bucket 0 newbucket 0 sz; Array.blit hashes 0 newhashes 0 sz; setter newbucket sz d; newhashes.(sz) <- h; t.table.(index) <- newbucket; t.hashes.(index) <- newhashes; if sz <= t.limit && newsz > t.limit then begin t.oversize <- t.oversize + 1; for i = 0 to over_limit do test_shrink_bucket t done; end; if t.oversize > Array.length t.table / over_limit then resize t; end else if check bucket i then begin loop (i + 1) end else begin setter bucket i d; hashes.(i) <- h; end; in loop 0; ;; let add t d = let h = H.hash d in add_aux t set (Some d) h (get_index t h); ;; let find_or t d ifnotfound = let h = H.hash d in let index = get_index t h in let bucket = t.table.(index) in let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i = if i >= sz then ifnotfound h index else if h = hashes.(i) then begin match get_copy bucket i with | Some v when H.equal v d -> begin match get bucket i with | Some v -> v | None -> loop (i + 1) end | _ -> loop (i + 1) end else loop (i + 1) in loop 0 ;; let merge t d = find_or t d (fun h index -> add_aux t set (Some d) h index; d) ;; let find t d = find_or t d (fun h index -> raise Not_found);; let find_shadow t d iffound ifnotfound = let h = H.hash d in let index = get_index t h in let bucket = t.table.(index) in let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i = if i >= sz then ifnotfound else if h = hashes.(i) then begin match get_copy bucket i with | Some v when H.equal v d -> iffound bucket i | _ -> loop (i + 1) end else loop (i + 1) in loop 0 ;; let remove t d = find_shadow t d (fun w i -> set w i None) ();; let mem t d = find_shadow t d (fun w i -> true) false;; let find_all t d = let h = H.hash d in let index = get_index t h in let bucket = t.table.(index) in let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i accu = if i >= sz then accu else if h = hashes.(i) then begin match get_copy bucket i with | Some v when H.equal v d -> begin match get bucket i with | Some v -> loop (i + 1) (v :: accu) | None -> loop (i + 1) accu end | _ -> loop (i + 1) accu end else loop (i + 1) accu in loop 0 [] ;; let stats t = let len = Array.length t.table in let lens = Array.map length t.table in Array.sort compare lens; let totlen = Array.fold_left ( + ) 0 lens in (len, count t, totlen, lens.(0), lens.(len/2), lens.(len-1)) ;; end;; mingw-ocaml/ocaml/stdlib/listLabels.ml0000644000175000017500000000170312124403240017367 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [ListLabels]: labelled List module *) include List mingw-ocaml/ocaml/stdlib/Makefile0000644000175000017500000000506112124403240016400 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### # $Id$ include Makefile.shared allopt: stdlib.cmxa std_exit.cmx allopt-$(PROFILING) allopt-noprof: allopt-prof: stdlib.p.cmxa std_exit.p.cmx rm -f std_exit.p.cmi installopt: installopt-default installopt-$(PROFILING) installopt-default: cp stdlib.cmxa stdlib.a std_exit.o *.cmx $(LIBDIR) cd $(LIBDIR); $(RANLIB) stdlib.a installopt-noprof: rm -f $(LIBDIR)/stdlib.p.cmxa; ln -s stdlib.cmxa $(LIBDIR)/stdlib.p.cmxa rm -f $(LIBDIR)/stdlib.p.a; ln -s stdlib.a $(LIBDIR)/stdlib.p.a rm -f $(LIBDIR)/std_exit.p.cmx; \ ln -s std_exit.cmx $(LIBDIR)/std_exit.p.cmx rm -f $(LIBDIR)/std_exit.p.o; ln -s std_exit.o $(LIBDIR)/std_exit.p.o installopt-prof: cp stdlib.p.cmxa stdlib.p.a std_exit.p.cmx std_exit.p.o $(LIBDIR) cd $(LIBDIR); $(RANLIB) stdlib.p.a stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx) $(CAMLOPT) -a -o stdlib.p.cmxa $(OBJS:.cmo=.p.cmx) camlheader camlheaderd camlheader_ur: header.c ../config/Makefile if $(SHARPBANGSCRIPTS); then \ echo '#!$(BINDIR)/ocamlrun' > camlheader && \ echo '#!$(BINDIR)/ocamlrund' > camlheaderd && \ echo '#!' | tr -d '\012' > camlheader_ur; \ else \ $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \ -DRUNTIME_NAME='"$(BINDIR)/ocamlrun"' \ header.c -o tmpheader$(EXE) && \ strip tmpheader$(EXE) && \ mv tmpheader$(EXE) camlheader && \ cp camlheader camlheader_ur && \ $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \ -DRUNTIME_NAME='"$(BINDIR)/ocamlrund"' \ header.c -o tmpheader$(EXE) && \ strip tmpheader$(EXE) && \ mv tmpheader$(EXE) camlheaderd; \ fi .PHONY: all allopt allopt-noprof allopt-prof install installopt .PHONY: installopt-default installopt-noprof installopt-prof clean depend mingw-ocaml/ocaml/stdlib/lexing.ml0000644000175000017500000001617712124403240016572 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* The run-time library for lexers generated by camllex *) type position = { pos_fname : string; pos_lnum : int; pos_bol : int; pos_cnum : int; } let dummy_pos = { pos_fname = ""; pos_lnum = 0; pos_bol = 0; pos_cnum = -1; } type lexbuf = { refill_buff : lexbuf -> unit; mutable lex_buffer : string; mutable lex_buffer_len : int; mutable lex_abs_pos : int; mutable lex_start_pos : int; mutable lex_curr_pos : int; mutable lex_last_pos : int; mutable lex_last_action : int; mutable lex_eof_reached : bool; mutable lex_mem : int array; mutable lex_start_p : position; mutable lex_curr_p : position; } type lex_tables = { lex_base: string; lex_backtrk: string; lex_default: string; lex_trans: string; lex_check: string; lex_base_code : string; lex_backtrk_code : string; lex_default_code : string; lex_trans_code : string; lex_check_code : string; lex_code: string;} external c_engine : lex_tables -> int -> lexbuf -> int = "caml_lex_engine" external c_new_engine : lex_tables -> int -> lexbuf -> int = "caml_new_lex_engine" let engine tbl state buf = let result = c_engine tbl state buf in if result >= 0 then begin buf.lex_start_p <- buf.lex_curr_p; buf.lex_curr_p <- {buf.lex_curr_p with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos}; end; result ;; let new_engine tbl state buf = let result = c_new_engine tbl state buf in if result >= 0 then begin buf.lex_start_p <- buf.lex_curr_p; buf.lex_curr_p <- {buf.lex_curr_p with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos}; end; result ;; let lex_refill read_fun aux_buffer lexbuf = let read = read_fun aux_buffer (String.length aux_buffer) in let n = if read > 0 then read else (lexbuf.lex_eof_reached <- true; 0) in (* Current state of the buffer: <-------|---------------------|-----------> | junk | valid data | junk | ^ ^ ^ ^ 0 start_pos buffer_end String.length buffer *) if lexbuf.lex_buffer_len + n > String.length lexbuf.lex_buffer then begin (* There is not enough space at the end of the buffer *) if lexbuf.lex_buffer_len - lexbuf.lex_start_pos + n <= String.length lexbuf.lex_buffer then begin (* But there is enough space if we reclaim the junk at the beginning of the buffer *) String.blit lexbuf.lex_buffer lexbuf.lex_start_pos lexbuf.lex_buffer 0 (lexbuf.lex_buffer_len - lexbuf.lex_start_pos) end else begin (* We must grow the buffer. Doubling its size will provide enough space since n <= String.length aux_buffer <= String.length buffer. Watch out for string length overflow, though. *) let newlen = min (2 * String.length lexbuf.lex_buffer) Sys.max_string_length in if lexbuf.lex_buffer_len - lexbuf.lex_start_pos + n > newlen then failwith "Lexing.lex_refill: cannot grow buffer"; let newbuf = String.create newlen in (* Copy the valid data to the beginning of the new buffer *) String.blit lexbuf.lex_buffer lexbuf.lex_start_pos newbuf 0 (lexbuf.lex_buffer_len - lexbuf.lex_start_pos); lexbuf.lex_buffer <- newbuf end; (* Reallocation or not, we have shifted the data left by start_pos characters; update the positions *) let s = lexbuf.lex_start_pos in lexbuf.lex_abs_pos <- lexbuf.lex_abs_pos + s; lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - s; lexbuf.lex_start_pos <- 0; lexbuf.lex_last_pos <- lexbuf.lex_last_pos - s; lexbuf.lex_buffer_len <- lexbuf.lex_buffer_len - s ; let t = lexbuf.lex_mem in for i = 0 to Array.length t-1 do let v = t.(i) in if v >= 0 then t.(i) <- v-s done end; (* There is now enough space at the end of the buffer *) String.blit aux_buffer 0 lexbuf.lex_buffer lexbuf.lex_buffer_len n; lexbuf.lex_buffer_len <- lexbuf.lex_buffer_len + n let zero_pos = { pos_fname = ""; pos_lnum = 1; pos_bol = 0; pos_cnum = 0; };; let from_function f = { refill_buff = lex_refill f (String.create 512); lex_buffer = String.create 1024; lex_buffer_len = 0; lex_abs_pos = 0; lex_start_pos = 0; lex_curr_pos = 0; lex_last_pos = 0; lex_last_action = 0; lex_mem = [||]; lex_eof_reached = false; lex_start_p = zero_pos; lex_curr_p = zero_pos; } let from_channel ic = from_function (fun buf n -> input ic buf 0 n) let from_string s = { refill_buff = (fun lexbuf -> lexbuf.lex_eof_reached <- true); lex_buffer = s ^ ""; lex_buffer_len = String.length s; lex_abs_pos = 0; lex_start_pos = 0; lex_curr_pos = 0; lex_last_pos = 0; lex_last_action = 0; lex_mem = [||]; lex_eof_reached = true; lex_start_p = zero_pos; lex_curr_p = zero_pos; } let lexeme lexbuf = let len = lexbuf.lex_curr_pos - lexbuf.lex_start_pos in let s = String.create len in String.unsafe_blit lexbuf.lex_buffer lexbuf.lex_start_pos s 0 len; s let sub_lexeme lexbuf i1 i2 = let len = i2-i1 in let s = String.create len in String.unsafe_blit lexbuf.lex_buffer i1 s 0 len; s let sub_lexeme_opt lexbuf i1 i2 = if i1 >= 0 then begin let len = i2-i1 in let s = String.create len in String.unsafe_blit lexbuf.lex_buffer i1 s 0 len; Some s end else begin None end let sub_lexeme_char lexbuf i = lexbuf.lex_buffer.[i] let sub_lexeme_char_opt lexbuf i = if i >= 0 then Some lexbuf.lex_buffer.[i] else None let lexeme_char lexbuf i = String.get lexbuf.lex_buffer (lexbuf.lex_start_pos + i) let lexeme_start lexbuf = lexbuf.lex_start_p.pos_cnum;; let lexeme_end lexbuf = lexbuf.lex_curr_p.pos_cnum;; let lexeme_start_p lexbuf = lexbuf.lex_start_p;; let lexeme_end_p lexbuf = lexbuf.lex_curr_p;; let new_line lexbuf = let lcp = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { lcp with pos_lnum = lcp.pos_lnum + 1; pos_bol = lcp.pos_cnum; } ;; (* Discard data left in lexer buffer. *) let flush_input lb = lb.lex_curr_pos <- 0; lb.lex_abs_pos <- 0; lb.lex_curr_p <- {lb.lex_curr_p with pos_cnum = 0}; lb.lex_buffer_len <- 0; ;; mingw-ocaml/ocaml/stdlib/arrayLabels.mli0000644000175000017500000002137312124403240017710 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Array operations. *) external length : 'a array -> int = "%array_length" (** Return the length (number of elements) of the given array. *) external get : 'a array -> int -> 'a = "%array_safe_get" (** [Array.get a n] returns the element number [n] of array [a]. The first element has number 0. The last element has number [Array.length a - 1]. You can also write [a.(n)] instead of [Array.get a n]. Raise [Invalid_argument "index out of bounds"] if [n] is outside the range 0 to [(Array.length a - 1)]. *) external set : 'a array -> int -> 'a -> unit = "%array_safe_set" (** [Array.set a n x] modifies array [a] in place, replacing element number [n] with [x]. You can also write [a.(n) <- x] instead of [Array.set a n x]. Raise [Invalid_argument "index out of bounds"] if [n] is outside the range 0 to [Array.length a - 1]. *) external make : int -> 'a -> 'a array = "caml_make_vect" (** [Array.make n x] returns a fresh array of length [n], initialized with [x]. All the elements of this new array are initially physically equal to [x] (in the sense of the [==] predicate). Consequently, if [x] is mutable, it is shared among all elements of the array, and modifying [x] through one of the array entries will modify all other entries at the same time. Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. If the value of [x] is a floating-point number, then the maximum size is only [Sys.max_array_length / 2].*) external create : int -> 'a -> 'a array = "caml_make_vect" (** @deprecated [Array.create] is an alias for {!ArrayLabels.make}. *) val init : int -> f:(int -> 'a) -> 'a array (** [Array.init n f] returns a fresh array of length [n], with element number [i] initialized to the result of [f i]. In other terms, [Array.init n f] tabulates the results of [f] applied to the integers [0] to [n-1]. Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. If the return type of [f] is [float], then the maximum size is only [Sys.max_array_length / 2].*) val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array (** [Array.make_matrix dimx dimy e] returns a two-dimensional array (an array of arrays) with first dimension [dimx] and second dimension [dimy]. All the elements of this new matrix are initially physically equal to [e]. The element ([x,y]) of a matrix [m] is accessed with the notation [m.(x).(y)]. Raise [Invalid_argument] if [dimx] or [dimy] is negative or greater than [Sys.max_array_length]. If the value of [e] is a floating-point number, then the maximum size is only [Sys.max_array_length / 2]. *) val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array (** @deprecated [Array.create_matrix] is an alias for {!ArrayLabels.make_matrix}. *) val append : 'a array -> 'a array -> 'a array (** [Array.append v1 v2] returns a fresh array containing the concatenation of the arrays [v1] and [v2]. *) val concat : 'a array list -> 'a array (** Same as [Array.append], but concatenates a list of arrays. *) val sub : 'a array -> pos:int -> len:int -> 'a array (** [Array.sub a start len] returns a fresh array of length [len], containing the elements number [start] to [start + len - 1] of array [a]. Raise [Invalid_argument "Array.sub"] if [start] and [len] do not designate a valid subarray of [a]; that is, if [start < 0], or [len < 0], or [start + len > Array.length a]. *) val copy : 'a array -> 'a array (** [Array.copy a] returns a copy of [a], that is, a fresh array containing the same elements as [a]. *) val fill : 'a array -> pos:int -> len:int -> 'a -> unit (** [Array.fill a ofs len x] modifies the array [a] in place, storing [x] in elements number [ofs] to [ofs + len - 1]. Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not designate a valid subarray of [a]. *) val blit : src:'a array -> src_pos:int -> dst:'a array -> dst_pos:int -> len:int -> unit (** [Array.blit v1 o1 v2 o2 len] copies [len] elements from array [v1], starting at element number [o1], to array [v2], starting at element number [o2]. It works correctly even if [v1] and [v2] are the same array, and the source and destination chunks overlap. Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not designate a valid subarray of [v1], or if [o2] and [len] do not designate a valid subarray of [v2]. *) val to_list : 'a array -> 'a list (** [Array.to_list a] returns the list of all the elements of [a]. *) val of_list : 'a list -> 'a array (** [Array.of_list l] returns a fresh array containing the elements of [l]. *) val iter : f:('a -> unit) -> 'a array -> unit (** [Array.iter f a] applies function [f] in turn to all the elements of [a]. It is equivalent to [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *) val map : f:('a -> 'b) -> 'a array -> 'b array (** [Array.map f a] applies function [f] to all the elements of [a], and builds an array with the results returned by [f]: [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *) val iteri : f:(int -> 'a -> unit) -> 'a array -> unit (** Same as {!ArrayLabels.iter}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) val mapi : f:(int -> 'a -> 'b) -> 'a array -> 'b array (** Same as {!ArrayLabels.map}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b array -> 'a (** [Array.fold_left f x a] computes [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], where [n] is the length of the array [a]. *) val fold_right : f:('b -> 'a -> 'a) -> 'b array -> init:'a -> 'a (** [Array.fold_right f a x] computes [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))], where [n] is the length of the array [a]. *) (** {6 Sorting} *) val sort : cmp:('a -> 'a -> int) -> 'a array -> unit (** Sort an array in increasing order according to a comparison function. The comparison function must return 0 if its arguments compare as equal, a positive integer if the first is greater, and a negative integer if the first is smaller (see below for a complete specification). For example, {!Pervasives.compare} is a suitable comparison function, provided there are no floating-point NaN values in the data. After calling [Array.sort], the array is sorted in place in increasing order. [Array.sort] is guaranteed to run in constant heap space and (at most) logarithmic stack space. The current implementation uses Heap Sort. It runs in constant stack space. Specification of the comparison function: Let [a] be the array and [cmp] the comparison function. The following must be true for all x, y, z in a : - [cmp x y] > 0 if and only if [cmp y x] < 0 - if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0 When [Array.sort] returns, [a] contains the same elements as before, reordered in such a way that for all i and j valid indices of [a] : - [cmp a.(i) a.(j)] >= 0 if and only if i >= j *) val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit (** Same as {!ArrayLabels.sort}, but the sorting algorithm is stable (i.e. elements that compare equal are kept in their original order) and not guaranteed to run in constant heap space. The current implementation uses Merge Sort. It uses [n/2] words of heap space, where [n] is the length of the array. It is usually faster than the current implementation of {!ArrayLabels.sort}. *) val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit (** Same as {!Array.sort} or {!Array.stable_sort}, whichever is faster on typical input. *) (**/**) (** {6 Undocumented functions} *) (* The following is for system use only. Do not call directly. *) external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" mingw-ocaml/ocaml/stdlib/sys.mlp0000644000175000017500000000547212124403240016276 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* WARNING: sys.ml is generated from sys.mlp. DO NOT EDIT sys.ml or your changes will be lost. *) (* System interface *) external get_config: unit -> string * int * bool = "caml_sys_get_config" external get_argv: unit -> string * string array = "caml_sys_get_argv" let (executable_name, argv) = get_argv() let (os_type, word_size, big_endian) = get_config() let max_array_length = (1 lsl (word_size - 10)) - 1;; let max_string_length = word_size / 8 * max_array_length - 1;; external file_exists: string -> bool = "caml_sys_file_exists" external is_directory : string -> bool = "caml_sys_is_directory" external remove: string -> unit = "caml_sys_remove" external rename : string -> string -> unit = "caml_sys_rename" external getenv: string -> string = "caml_sys_getenv" external command: string -> int = "caml_sys_system_command" external time: unit -> float = "caml_sys_time" external chdir: string -> unit = "caml_sys_chdir" external getcwd: unit -> string = "caml_sys_getcwd" external readdir : string -> string array = "caml_sys_read_directory" let interactive = ref false type signal_behavior = Signal_default | Signal_ignore | Signal_handle of (int -> unit) external signal : int -> signal_behavior -> signal_behavior = "caml_install_signal_handler" let set_signal sig_num sig_beh = ignore(signal sig_num sig_beh) let sigabrt = -1 let sigalrm = -2 let sigfpe = -3 let sighup = -4 let sigill = -5 let sigint = -6 let sigkill = -7 let sigpipe = -8 let sigquit = -9 let sigsegv = -10 let sigterm = -11 let sigusr1 = -12 let sigusr2 = -13 let sigchld = -14 let sigcont = -15 let sigstop = -16 let sigtstp = -17 let sigttin = -18 let sigttou = -19 let sigvtalrm = -20 let sigprof = -21 exception Break let catch_break on = if on then set_signal sigint (Signal_handle(fun _ -> raise Break)) else set_signal sigint Signal_default (* The version string is found in file ../VERSION *) let ocaml_version = "%%VERSION%%";; mingw-ocaml/ocaml/stdlib/hashtbl.ml0000644000175000017500000002577512124403240016735 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Hash tables *) external seeded_hash_param : int -> int -> int -> 'a -> int = "caml_hash" "noalloc" external old_hash_param : int -> int -> 'a -> int = "caml_hash_univ_param" "noalloc" let hash x = seeded_hash_param 10 100 0 x let hash_param n1 n2 x = seeded_hash_param n1 n2 0 x let seeded_hash seed x = seeded_hash_param 10 100 seed x (* We do dynamic hashing, and resize the table and rehash the elements when buckets become too long. *) type ('a, 'b) t = { mutable size: int; (* number of entries *) mutable data: ('a, 'b) bucketlist array; (* the buckets *) mutable seed: int; (* for randomization *) initial_size: int; (* initial array size *) } and ('a, 'b) bucketlist = Empty | Cons of 'a * 'b * ('a, 'b) bucketlist (* To pick random seeds if requested *) let randomized_default = let params = try Sys.getenv "OCAMLRUNPARAM" with Not_found -> try Sys.getenv "CAMLRUNPARAM" with Not_found -> "" in String.contains params 'R' let randomized = ref randomized_default let randomize () = randomized := true let prng = lazy (Random.State.make_self_init()) (* Creating a fresh, empty table *) let rec power_2_above x n = if x >= n then x else if x * 2 > Sys.max_array_length then x else power_2_above (x * 2) n let create ?(random = !randomized) initial_size = let s = power_2_above 16 initial_size in let seed = if random then Random.State.bits (Lazy.force prng) else 0 in { initial_size = s; size = 0; seed = seed; data = Array.make s Empty } let clear h = h.size <- 0; let len = Array.length h.data in for i = 0 to len - 1 do h.data.(i) <- Empty done let reset h = let len = Array.length h.data in if Obj.size (Obj.repr h) < 4 (* compatibility with old hash tables *) || len = h.initial_size then clear h else begin h.size <- 0; h.data <- Array.make h.initial_size Empty end let copy h = { h with data = Array.copy h.data } let length h = h.size let resize indexfun h = let odata = h.data in let osize = Array.length odata in let nsize = osize * 2 in if nsize < Sys.max_array_length then begin let ndata = Array.make nsize Empty in h.data <- ndata; (* so that indexfun sees the new bucket count *) let rec insert_bucket = function Empty -> () | Cons(key, data, rest) -> insert_bucket rest; (* preserve original order of elements *) let nidx = indexfun h key in ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in for i = 0 to osize - 1 do insert_bucket odata.(i) done end let key_index h key = (* compatibility with old hash tables *) if Obj.size (Obj.repr h) >= 3 then (seeded_hash_param 10 100 h.seed key) land (Array.length h.data - 1) else (old_hash_param 10 100 key) mod (Array.length h.data) let add h key info = let i = key_index h key in let bucket = Cons(key, info, h.data.(i)) in h.data.(i) <- bucket; h.size <- h.size + 1; if h.size > Array.length h.data lsl 1 then resize key_index h let remove h key = let rec remove_bucket = function | Empty -> Empty | Cons(k, i, next) -> if compare k key = 0 then begin h.size <- h.size - 1; next end else Cons(k, i, remove_bucket next) in let i = key_index h key in h.data.(i) <- remove_bucket h.data.(i) let rec find_rec key = function | Empty -> raise Not_found | Cons(k, d, rest) -> if compare key k = 0 then d else find_rec key rest let find h key = match h.data.(key_index h key) with | Empty -> raise Not_found | Cons(k1, d1, rest1) -> if compare key k1 = 0 then d1 else match rest1 with | Empty -> raise Not_found | Cons(k2, d2, rest2) -> if compare key k2 = 0 then d2 else match rest2 with | Empty -> raise Not_found | Cons(k3, d3, rest3) -> if compare key k3 = 0 then d3 else find_rec key rest3 let find_all h key = let rec find_in_bucket = function | Empty -> [] | Cons(k, d, rest) -> if compare k key = 0 then d :: find_in_bucket rest else find_in_bucket rest in find_in_bucket h.data.(key_index h key) let replace h key info = let rec replace_bucket = function | Empty -> raise Not_found | Cons(k, i, next) -> if compare k key = 0 then Cons(key, info, next) else Cons(k, i, replace_bucket next) in let i = key_index h key in let l = h.data.(i) in try h.data.(i) <- replace_bucket l with Not_found -> h.data.(i) <- Cons(key, info, l); h.size <- h.size + 1; if h.size > Array.length h.data lsl 1 then resize key_index h let mem h key = let rec mem_in_bucket = function | Empty -> false | Cons(k, d, rest) -> compare k key = 0 || mem_in_bucket rest in mem_in_bucket h.data.(key_index h key) let iter f h = let rec do_bucket = function | Empty -> () | Cons(k, d, rest) -> f k d; do_bucket rest in let d = h.data in for i = 0 to Array.length d - 1 do do_bucket d.(i) done let fold f h init = let rec do_bucket b accu = match b with Empty -> accu | Cons(k, d, rest) -> do_bucket rest (f k d accu) in let d = h.data in let accu = ref init in for i = 0 to Array.length d - 1 do accu := do_bucket d.(i) !accu done; !accu type statistics = { num_bindings: int; num_buckets: int; max_bucket_length: int; bucket_histogram: int array } let rec bucket_length accu = function | Empty -> accu | Cons(_, _, rest) -> bucket_length (accu + 1) rest let stats h = let mbl = Array.fold_left (fun m b -> max m (bucket_length 0 b)) 0 h.data in let histo = Array.make (mbl + 1) 0 in Array.iter (fun b -> let l = bucket_length 0 b in histo.(l) <- histo.(l) + 1) h.data; { num_bindings = h.size; num_buckets = Array.length h.data; max_bucket_length = mbl; bucket_histogram = histo } (* Functorial interface *) module type HashedType = sig type t val equal: t -> t -> bool val hash: t -> int end module type SeededHashedType = sig type t val equal: t -> t -> bool val hash: int -> t -> int end module type S = sig type key type 'a t val create: int -> 'a t val clear : 'a t -> unit val reset : 'a t -> unit val copy: 'a t -> 'a t val add: 'a t -> key -> 'a -> unit val remove: 'a t -> key -> unit val find: 'a t -> key -> 'a val find_all: 'a t -> key -> 'a list val replace : 'a t -> key -> 'a -> unit val mem : 'a t -> key -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val length: 'a t -> int val stats: 'a t -> statistics end module type SeededS = sig type key type 'a t val create : ?random:bool -> int -> 'a t val clear : 'a t -> unit val reset : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key -> 'a -> unit val remove : 'a t -> key -> unit val find : 'a t -> key -> 'a val find_all : 'a t -> key -> 'a list val replace : 'a t -> key -> 'a -> unit val mem : 'a t -> key -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val length : 'a t -> int val stats: 'a t -> statistics end module MakeSeeded(H: SeededHashedType): (SeededS with type key = H.t) = struct type key = H.t type 'a hashtbl = (key, 'a) t type 'a t = 'a hashtbl let create = create let clear = clear let reset = reset let copy = copy let key_index h key = (H.hash h.seed key) land (Array.length h.data - 1) let add h key info = let i = key_index h key in let bucket = Cons(key, info, h.data.(i)) in h.data.(i) <- bucket; h.size <- h.size + 1; if h.size > Array.length h.data lsl 1 then resize key_index h let remove h key = let rec remove_bucket = function | Empty -> Empty | Cons(k, i, next) -> if H.equal k key then begin h.size <- h.size - 1; next end else Cons(k, i, remove_bucket next) in let i = key_index h key in h.data.(i) <- remove_bucket h.data.(i) let rec find_rec key = function | Empty -> raise Not_found | Cons(k, d, rest) -> if H.equal key k then d else find_rec key rest let find h key = match h.data.(key_index h key) with | Empty -> raise Not_found | Cons(k1, d1, rest1) -> if H.equal key k1 then d1 else match rest1 with | Empty -> raise Not_found | Cons(k2, d2, rest2) -> if H.equal key k2 then d2 else match rest2 with | Empty -> raise Not_found | Cons(k3, d3, rest3) -> if H.equal key k3 then d3 else find_rec key rest3 let find_all h key = let rec find_in_bucket = function | Empty -> [] | Cons(k, d, rest) -> if H.equal k key then d :: find_in_bucket rest else find_in_bucket rest in find_in_bucket h.data.(key_index h key) let replace h key info = let rec replace_bucket = function | Empty -> raise Not_found | Cons(k, i, next) -> if H.equal k key then Cons(key, info, next) else Cons(k, i, replace_bucket next) in let i = key_index h key in let l = h.data.(i) in try h.data.(i) <- replace_bucket l with Not_found -> h.data.(i) <- Cons(key, info, l); h.size <- h.size + 1; if h.size > Array.length h.data lsl 1 then resize key_index h let mem h key = let rec mem_in_bucket = function | Empty -> false | Cons(k, d, rest) -> H.equal k key || mem_in_bucket rest in mem_in_bucket h.data.(key_index h key) let iter = iter let fold = fold let length = length let stats = stats end module Make(H: HashedType): (S with type key = H.t) = struct include MakeSeeded(struct type t = H.t let equal = H.equal let hash (seed: int) x = H.hash x end) let create sz = create ~random:false sz end mingw-ocaml/ocaml/stdlib/lexing.mli0000644000175000017500000001506612124403240016737 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** The run-time library for lexers generated by [ocamllex]. *) (** {6 Positions} *) type position = { pos_fname : string; pos_lnum : int; pos_bol : int; pos_cnum : int; } (** A value of type [position] describes a point in a source file. [pos_fname] is the file name; [pos_lnum] is the line number; [pos_bol] is the offset of the beginning of the line (number of characters between the beginning of the lexbuf and the beginning of the line); [pos_cnum] is the offset of the position (number of characters between the beginning of the lexbuf and the position). The difference between [pos_cnum] and [pos_bol] is the character offset within the line (i.e. the column number, assuming each character is one column wide). See the documentation of type [lexbuf] for information about how the lexing engine will manage positions. *) val dummy_pos : position;; (** A value of type [position], guaranteed to be different from any valid position. *) (** {6 Lexer buffers} *) type lexbuf = { refill_buff : lexbuf -> unit; mutable lex_buffer : string; mutable lex_buffer_len : int; mutable lex_abs_pos : int; mutable lex_start_pos : int; mutable lex_curr_pos : int; mutable lex_last_pos : int; mutable lex_last_action : int; mutable lex_eof_reached : bool; mutable lex_mem : int array; mutable lex_start_p : position; mutable lex_curr_p : position; } (** The type of lexer buffers. A lexer buffer is the argument passed to the scanning functions defined by the generated scanners. The lexer buffer holds the current state of the scanner, plus a function to refill the buffer from the input. At each token, the lexing engine will copy [lex_curr_p] to [lex_start_p], then change the [pos_cnum] field of [lex_curr_p] by updating it with the number of characters read since the start of the [lexbuf]. The other fields are left unchanged by the lexing engine. In order to keep them accurate, they must be initialised before the first use of the lexbuf, and updated by the relevant lexer actions (i.e. at each end of line -- see also [new_line]). *) val from_channel : in_channel -> lexbuf (** Create a lexer buffer on the given input channel. [Lexing.from_channel inchan] returns a lexer buffer which reads from the input channel [inchan], at the current reading position. *) val from_string : string -> lexbuf (** Create a lexer buffer which reads from the given string. Reading starts from the first character in the string. An end-of-input condition is generated when the end of the string is reached. *) val from_function : (string -> int -> int) -> lexbuf (** Create a lexer buffer with the given function as its reading method. When the scanner needs more characters, it will call the given function, giving it a character string [s] and a character count [n]. The function should put [n] characters or less in [s], starting at character number 0, and return the number of characters provided. A return value of 0 means end of input. *) (** {6 Functions for lexer semantic actions} *) (** The following functions can be called from the semantic actions of lexer definitions (the ML code enclosed in braces that computes the value returned by lexing functions). They give access to the character string matched by the regular expression associated with the semantic action. These functions must be applied to the argument [lexbuf], which, in the code generated by [ocamllex], is bound to the lexer buffer passed to the parsing function. *) val lexeme : lexbuf -> string (** [Lexing.lexeme lexbuf] returns the string matched by the regular expression. *) val lexeme_char : lexbuf -> int -> char (** [Lexing.lexeme_char lexbuf i] returns character number [i] in the matched string. *) val lexeme_start : lexbuf -> int (** [Lexing.lexeme_start lexbuf] returns the offset in the input stream of the first character of the matched string. The first character of the stream has offset 0. *) val lexeme_end : lexbuf -> int (** [Lexing.lexeme_end lexbuf] returns the offset in the input stream of the character following the last character of the matched string. The first character of the stream has offset 0. *) val lexeme_start_p : lexbuf -> position (** Like [lexeme_start], but return a complete [position] instead of an offset. *) val lexeme_end_p : lexbuf -> position (** Like [lexeme_end], but return a complete [position] instead of an offset. *) val new_line : lexbuf -> unit (** Update the [lex_curr_p] field of the lexbuf to reflect the start of a new line. You can call this function in the semantic action of the rule that matches the end-of-line character. @since 3.11.0 *) (** {6 Miscellaneous functions} *) val flush_input : lexbuf -> unit (** Discard the contents of the buffer and reset the current position to 0. The next use of the lexbuf will trigger a refill. *) (**/**) (** {6 } *) (** The following definitions are used by the generated scanners only. They are not intended to be used directly by user programs. *) val sub_lexeme : lexbuf -> int -> int -> string val sub_lexeme_opt : lexbuf -> int -> int -> string option val sub_lexeme_char : lexbuf -> int -> char val sub_lexeme_char_opt : lexbuf -> int -> char option type lex_tables = { lex_base : string; lex_backtrk : string; lex_default : string; lex_trans : string; lex_check : string; lex_base_code : string; lex_backtrk_code : string; lex_default_code : string; lex_trans_code : string; lex_check_code : string; lex_code: string;} val engine : lex_tables -> int -> lexbuf -> int val new_engine : lex_tables -> int -> lexbuf -> int mingw-ocaml/ocaml/stdlib/stdLabels.ml0000644000175000017500000000202612124403240017205 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [StdLabels]: meta-module for labelled libraries *) module Array = ArrayLabels module List = ListLabels module String = StringLabels mingw-ocaml/ocaml/stdlib/StdlibModules0000644000175000017500000000302512124403240017433 0ustar tootstoots# -*- Makefile -*- ######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 2002 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### # $Id$ # This file lists all standard library modules. # It is used in particular to know what to expunge in toplevels. STDLIB_MODULES=\ arg \ array \ arrayLabels \ buffer \ callback \ camlinternalLazy \ camlinternalMod \ camlinternalOO \ char \ complex \ digest \ filename \ format \ gc \ genlex \ hashtbl \ int32 \ int64 \ lazy \ lexing \ list \ listLabels \ map \ marshal \ moreLabels \ nativeint \ obj \ oo \ parsing \ pervasives \ printexc \ printf \ queue \ random \ scanf \ set \ sort \ stack \ stdLabels \ stream \ string \ stringLabels \ sys \ weak mingw-ocaml/ocaml/stdlib/array.ml0000644000175000017500000001552712124403240016420 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Array operations *) external length : 'a array -> int = "%array_length" external get: 'a array -> int -> 'a = "%array_safe_get" external set: 'a array -> int -> 'a -> unit = "%array_safe_set" external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get" external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set" external make: int -> 'a -> 'a array = "caml_make_vect" external create: int -> 'a -> 'a array = "caml_make_vect" external unsafe_sub : 'a array -> int -> int -> 'a array = "caml_array_sub" external append_prim : 'a array -> 'a array -> 'a array = "caml_array_append" external concat : 'a array list -> 'a array = "caml_array_concat" external unsafe_blit : 'a array -> int -> 'a array -> int -> int -> unit = "caml_array_blit" let init l f = if l = 0 then [||] else let res = create l (f 0) in for i = 1 to pred l do unsafe_set res i (f i) done; res let make_matrix sx sy init = let res = create sx [||] in for x = 0 to pred sx do unsafe_set res x (create sy init) done; res let create_matrix = make_matrix let copy a = let l = length a in if l = 0 then [||] else unsafe_sub a 0 l let append a1 a2 = let l1 = length a1 in if l1 = 0 then copy a2 else if length a2 = 0 then unsafe_sub a1 0 l1 else append_prim a1 a2 let sub a ofs len = if len < 0 || ofs > length a - len then invalid_arg "Array.sub" else unsafe_sub a ofs len let fill a ofs len v = if ofs < 0 || len < 0 || ofs > length a - len then invalid_arg "Array.fill" else for i = ofs to ofs + len - 1 do unsafe_set a i v done let blit a1 ofs1 a2 ofs2 len = if len < 0 || ofs1 < 0 || ofs1 > length a1 - len || ofs2 < 0 || ofs2 > length a2 - len then invalid_arg "Array.blit" else unsafe_blit a1 ofs1 a2 ofs2 len let iter f a = for i = 0 to length a - 1 do f(unsafe_get a i) done let map f a = let l = length a in if l = 0 then [||] else begin let r = create l (f(unsafe_get a 0)) in for i = 1 to l - 1 do unsafe_set r i (f(unsafe_get a i)) done; r end let iteri f a = for i = 0 to length a - 1 do f i (unsafe_get a i) done let mapi f a = let l = length a in if l = 0 then [||] else begin let r = create l (f 0 (unsafe_get a 0)) in for i = 1 to l - 1 do unsafe_set r i (f i (unsafe_get a i)) done; r end let to_list a = let rec tolist i res = if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in tolist (length a - 1) [] (* Cannot use List.length here because the List module depends on Array. *) let rec list_length accu = function | [] -> accu | h::t -> list_length (succ accu) t ;; let of_list = function [] -> [||] | hd::tl as l -> let a = create (list_length 0 l) hd in let rec fill i = function [] -> a | hd::tl -> unsafe_set a i hd; fill (i+1) tl in fill 1 tl let fold_left f x a = let r = ref x in for i = 0 to length a - 1 do r := f !r (unsafe_get a i) done; !r let fold_right f a x = let r = ref x in for i = length a - 1 downto 0 do r := f (unsafe_get a i) !r done; !r exception Bottom of int;; let sort cmp a = let maxson l i = let i31 = i+i+i+1 in let x = ref i31 in if i31+2 < l then begin if cmp (get a i31) (get a (i31+1)) < 0 then x := i31+1; if cmp (get a !x) (get a (i31+2)) < 0 then x := i31+2; !x end else if i31+1 < l && cmp (get a i31) (get a (i31+1)) < 0 then i31+1 else if i31 < l then i31 else raise (Bottom i) in let rec trickledown l i e = let j = maxson l i in if cmp (get a j) e > 0 then begin set a i (get a j); trickledown l j e; end else begin set a i e; end; in let rec trickle l i e = try trickledown l i e with Bottom i -> set a i e in let rec bubbledown l i = let j = maxson l i in set a i (get a j); bubbledown l j in let bubble l i = try bubbledown l i with Bottom i -> i in let rec trickleup i e = let father = (i - 1) / 3 in assert (i <> father); if cmp (get a father) e < 0 then begin set a i (get a father); if father > 0 then trickleup father e else set a 0 e; end else begin set a i e; end; in let l = length a in for i = (l + 1) / 3 - 1 downto 0 do trickle l i (get a i); done; for i = l - 1 downto 2 do let e = (get a i) in set a i (get a 0); trickleup (bubble i 0) e; done; if l > 1 then (let e = (get a 1) in set a 1 (get a 0); set a 0 e); ;; let cutoff = 5;; let stable_sort cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let src1r = src1ofs + src1len and src2r = src2ofs + src2len in let rec loop i1 s1 i2 s2 d = if cmp s1 s2 <= 0 then begin set dst d s1; let i1 = i1 + 1 in if i1 < src1r then loop i1 (get a i1) i2 s2 (d + 1) else blit src2 i2 dst (d + 1) (src2r - i2) end else begin set dst d s2; let i2 = i2 + 1 in if i2 < src2r then loop i1 s1 i2 (get src2 i2) (d + 1) else blit a i1 dst (d + 1) (src1r - i1) end in loop src1ofs (get a src1ofs) src2ofs (get src2 src2ofs) dstofs; in let isortto srcofs dst dstofs len = for i = 0 to len - 1 do let e = (get a (srcofs + i)) in let j = ref (dstofs + i - 1) in while (!j >= dstofs && cmp (get dst !j) e > 0) do set dst (!j + 1) (get dst !j); decr j; done; set dst (!j + 1) e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else begin let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs + l1) dst (dstofs + l1) l2; sortto srcofs a (srcofs + l2) l1; merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; end; in let l = length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = make l2 (get a 0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let fast_sort = stable_sort;; mingw-ocaml/ocaml/stdlib/arg.ml0000644000175000017500000002136012124403240016043 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) type key = string type doc = string type usage_msg = string type anon_fun = (string -> unit) type spec = | Unit of (unit -> unit) (* Call the function with unit argument *) | Bool of (bool -> unit) (* Call the function with a bool argument *) | Set of bool ref (* Set the reference to true *) | Clear of bool ref (* Set the reference to false *) | String of (string -> unit) (* Call the function with a string argument *) | Set_string of string ref (* Set the reference to the string argument *) | Int of (int -> unit) (* Call the function with an int argument *) | Set_int of int ref (* Set the reference to the int argument *) | Float of (float -> unit) (* Call the function with a float argument *) | Set_float of float ref (* Set the reference to the float argument *) | Tuple of spec list (* Take several arguments according to the spec list *) | Symbol of string list * (string -> unit) (* Take one of the symbols as argument and call the function with the symbol. *) | Rest of (string -> unit) (* Stop interpreting keywords and call the function with each remaining argument *) exception Bad of string exception Help of string type error = | Unknown of string | Wrong of string * string * string (* option, actual, expected *) | Missing of string | Message of string exception Stop of error;; (* used internally *) open Printf let rec assoc3 x l = match l with | [] -> raise Not_found | (y1, y2, y3) :: t when y1 = x -> y2 | _ :: t -> assoc3 x t ;; let make_symlist prefix sep suffix l = match l with | [] -> "" | h::t -> (List.fold_left (fun x y -> x ^ sep ^ y) (prefix ^ h) t) ^ suffix ;; let print_spec buf (key, spec, doc) = if String.length doc > 0 then match spec with | Symbol (l, _) -> bprintf buf " %s %s%s\n" key (make_symlist "{" "|" "}" l) doc | _ -> bprintf buf " %s %s\n" key doc ;; let help_action () = raise (Stop (Unknown "-help"));; let add_help speclist = let add1 = try ignore (assoc3 "-help" speclist); [] with Not_found -> ["-help", Unit help_action, " Display this list of options"] and add2 = try ignore (assoc3 "--help" speclist); [] with Not_found -> ["--help", Unit help_action, " Display this list of options"] in speclist @ (add1 @ add2) ;; let usage_b buf speclist errmsg = bprintf buf "%s\n" errmsg; List.iter (print_spec buf) (add_help speclist); ;; let usage_string speclist errmsg = let b = Buffer.create 200 in usage_b b speclist errmsg; Buffer.contents b; ;; let usage speclist errmsg = eprintf "%s" (usage_string speclist errmsg); ;; let current = ref 0;; let parse_argv ?(current=current) argv speclist anonfun errmsg = let l = Array.length argv in let b = Buffer.create 200 in let initpos = !current in let stop error = let progname = if initpos < l then argv.(initpos) else "(?)" in begin match error with | Unknown "-help" -> () | Unknown "--help" -> () | Unknown s -> bprintf b "%s: unknown option `%s'.\n" progname s | Missing s -> bprintf b "%s: option `%s' needs an argument.\n" progname s | Wrong (opt, arg, expected) -> bprintf b "%s: wrong argument `%s'; option `%s' expects %s.\n" progname arg opt expected | Message s -> bprintf b "%s: %s.\n" progname s end; usage_b b speclist errmsg; if error = Unknown "-help" || error = Unknown "--help" then raise (Help (Buffer.contents b)) else raise (Bad (Buffer.contents b)) in incr current; while !current < l do let s = argv.(!current) in if String.length s >= 1 && String.get s 0 = '-' then begin let action = try assoc3 s speclist with Not_found -> stop (Unknown s) in begin try let rec treat_action = function | Unit f -> f (); | Bool f when !current + 1 < l -> let arg = argv.(!current + 1) in begin try f (bool_of_string arg) with Invalid_argument "bool_of_string" -> raise (Stop (Wrong (s, arg, "a boolean"))) end; incr current; | Set r -> r := true; | Clear r -> r := false; | String f when !current + 1 < l -> f argv.(!current + 1); incr current; | Symbol (symb, f) when !current + 1 < l -> let arg = argv.(!current + 1) in if List.mem arg symb then begin f argv.(!current + 1); incr current; end else begin raise (Stop (Wrong (s, arg, "one of: " ^ (make_symlist "" " " "" symb)))) end | Set_string r when !current + 1 < l -> r := argv.(!current + 1); incr current; | Int f when !current + 1 < l -> let arg = argv.(!current + 1) in begin try f (int_of_string arg) with Failure "int_of_string" -> raise (Stop (Wrong (s, arg, "an integer"))) end; incr current; | Set_int r when !current + 1 < l -> let arg = argv.(!current + 1) in begin try r := (int_of_string arg) with Failure "int_of_string" -> raise (Stop (Wrong (s, arg, "an integer"))) end; incr current; | Float f when !current + 1 < l -> let arg = argv.(!current + 1) in begin try f (float_of_string arg); with Failure "float_of_string" -> raise (Stop (Wrong (s, arg, "a float"))) end; incr current; | Set_float r when !current + 1 < l -> let arg = argv.(!current + 1) in begin try r := (float_of_string arg); with Failure "float_of_string" -> raise (Stop (Wrong (s, arg, "a float"))) end; incr current; | Tuple specs -> List.iter treat_action specs; | Rest f -> while !current < l - 1 do f argv.(!current + 1); incr current; done; | _ -> raise (Stop (Missing s)) in treat_action action with Bad m -> stop (Message m); | Stop e -> stop e; end; incr current; end else begin (try anonfun s with Bad m -> stop (Message m)); incr current; end; done; ;; let parse l f msg = try parse_argv Sys.argv l f msg; with | Bad msg -> eprintf "%s" msg; exit 2; | Help msg -> printf "%s" msg; exit 0; ;; let rec second_word s = let len = String.length s in let rec loop n = if n >= len then len else if s.[n] = ' ' then loop (n+1) else n in try loop (String.index s ' ') with Not_found -> len ;; let max_arg_len cur (kwd, spec, doc) = match spec with | Symbol _ -> max cur (String.length kwd) | _ -> max cur (String.length kwd + second_word doc) ;; let add_padding len ksd = match ksd with | (_, _, "") -> (* Do not pad undocumented options, so that they still don't show up when * run through [usage] or [parse]. *) ksd | (kwd, (Symbol (l, _) as spec), msg) -> let cutcol = second_word msg in let spaces = String.make (len - cutcol + 3) ' ' in (kwd, spec, "\n" ^ spaces ^ msg) | (kwd, spec, msg) -> let cutcol = second_word msg in let spaces = String.make (len - String.length kwd - cutcol) ' ' in let prefix = String.sub msg 0 cutcol in let suffix = String.sub msg cutcol (String.length msg - cutcol) in (kwd, spec, prefix ^ spaces ^ suffix) ;; let align speclist = let completed = add_help speclist in let len = List.fold_left max_arg_len 0 completed in List.map (add_padding len) completed ;; mingw-ocaml/ocaml/stdlib/headernt.c0000644000175000017500000001307612124403240016703 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1998 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #define STRICT #define WIN32_LEAN_AND_MEAN #include #include "mlvalues.h" #include "exec.h" #ifndef __MINGW32__ #pragma comment(linker , "/entry:headerentry") #pragma comment(linker , "/subsystem:console") #pragma comment(lib , "kernel32") #endif char * default_runtime_name = RUNTIME_NAME; static #if _MSC_VER >= 1200 __forceinline #else __inline #endif unsigned long read_size(const char * const ptr) { const unsigned char * const p = (const unsigned char * const) ptr; return ((unsigned long) p[0] << 24) | ((unsigned long) p[1] << 16) | ((unsigned long) p[2] << 8) | p[3]; } static __inline char * read_runtime_path(HANDLE h) { char buffer[TRAILER_SIZE]; static char runtime_path[MAX_PATH]; DWORD nread; int num_sections, path_size, i; long ofs; if (SetFilePointer(h, -TRAILER_SIZE, NULL, FILE_END) == -1) return NULL; if (! ReadFile(h, buffer, TRAILER_SIZE, &nread, NULL)) return NULL; if (nread != TRAILER_SIZE) return NULL; num_sections = read_size(buffer); ofs = TRAILER_SIZE + num_sections * 8; if (SetFilePointer(h, - ofs, NULL, FILE_END) == -1) return NULL; path_size = 0; for (i = 0; i < num_sections; i++) { if (! ReadFile(h, buffer, 8, &nread, NULL) || nread != 8) return NULL; if (buffer[0] == 'R' && buffer[1] == 'N' && buffer[2] == 'T' && buffer[3] == 'M') { path_size = read_size(buffer + 4); ofs += path_size; } else if (path_size > 0) ofs += read_size(buffer + 4); } if (path_size == 0) return default_runtime_name; if (path_size >= MAX_PATH) return NULL; if (SetFilePointer(h, -ofs, NULL, FILE_END) == -1) return NULL; if (! ReadFile(h, runtime_path, path_size, &nread, NULL)) return NULL; if (nread != path_size) return NULL; runtime_path[path_size - 1] = 0; return runtime_path; } static BOOL WINAPI ctrl_handler(DWORD event) { if (event == CTRL_C_EVENT || event == CTRL_BREAK_EVENT) return TRUE; /* pretend we've handled them */ else return FALSE; } #define msg_and_length(msg) msg , (sizeof(msg) - 1) static __inline void __declspec(noreturn) run_runtime(char * runtime, char * const cmdline) { char path[MAX_PATH]; STARTUPINFO stinfo; PROCESS_INFORMATION procinfo; DWORD retcode; if (SearchPath(NULL, runtime, ".exe", MAX_PATH, path, &runtime) == 0) { HANDLE errh; DWORD numwritten; errh = GetStdHandle(STD_ERROR_HANDLE); WriteFile(errh, msg_and_length("Cannot exec "), &numwritten, NULL); WriteFile(errh, runtime, strlen(runtime), &numwritten, NULL); WriteFile(errh, msg_and_length("\r\n"), &numwritten, NULL); ExitProcess(2); #if _MSC_VER >= 1200 __assume(0); /* Not reached */ #endif } /* Need to ignore ctrl-C and ctrl-break, otherwise we'll die and take the underlying OCaml program with us! */ SetConsoleCtrlHandler(ctrl_handler, TRUE); stinfo.cb = sizeof(stinfo); stinfo.lpReserved = NULL; stinfo.lpDesktop = NULL; stinfo.lpTitle = NULL; stinfo.dwFlags = 0; stinfo.cbReserved2 = 0; stinfo.lpReserved2 = NULL; if (!CreateProcess(path, cmdline, NULL, NULL, TRUE, 0, NULL, NULL, &stinfo, &procinfo)) { HANDLE errh; DWORD numwritten; errh = GetStdHandle(STD_ERROR_HANDLE); WriteFile(errh, msg_and_length("Cannot exec "), &numwritten, NULL); WriteFile(errh, runtime, strlen(runtime), &numwritten, NULL); WriteFile(errh, msg_and_length("\r\n"), &numwritten, NULL); ExitProcess(2); #if _MSC_VER >= 1200 __assume(0); /* Not reached */ #endif } CloseHandle(procinfo.hThread); WaitForSingleObject(procinfo.hProcess , INFINITE); GetExitCodeProcess(procinfo.hProcess , &retcode); CloseHandle(procinfo.hProcess); ExitProcess(retcode); #if _MSC_VER >= 1200 __assume(0); /* Not reached */ #endif } #ifdef __MINGW32__ int main() #else void __declspec(noreturn) __cdecl headerentry() #endif { char truename[MAX_PATH]; char * cmdline = GetCommandLine(); char * runtime_path; HANDLE h; GetModuleFileName(NULL, truename, sizeof(truename)); h = CreateFile(truename, GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, 0, NULL); if (h == INVALID_HANDLE_VALUE || (runtime_path = read_runtime_path(h)) == NULL) { HANDLE errh; DWORD numwritten; errh = GetStdHandle(STD_ERROR_HANDLE); WriteFile(errh, truename, strlen(truename), &numwritten, NULL); WriteFile(errh, msg_and_length(" not found or is not a bytecode executable file\r\n"), &numwritten, NULL); ExitProcess(2); #if _MSC_VER >= 1200 __assume(0); /* Not reached */ #endif } CloseHandle(h); run_runtime(runtime_path , cmdline); #if _MSC_VER >= 1200 __assume(0); /* Not reached */ #endif #ifdef __MINGW32__ return 0; #endif } mingw-ocaml/ocaml/stdlib/digest.ml0000644000175000017500000000430212124403240016546 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Message digest (MD5) *) type t = string let compare = String.compare external unsafe_string: string -> int -> int -> t = "caml_md5_string" external channel: in_channel -> int -> t = "caml_md5_chan" let string str = unsafe_string str 0 (String.length str) let substring str ofs len = if ofs < 0 || len < 0 || ofs > String.length str - len then invalid_arg "Digest.substring" else unsafe_string str ofs len let file filename = let ic = open_in_bin filename in let d = channel ic (-1) in close_in ic; d let output chan digest = output chan digest 0 16 let input chan = let digest = String.create 16 in really_input chan digest 0 16; digest let to_hex d = let result = String.create 32 in for i = 0 to 15 do String.blit (Printf.sprintf "%02x" (int_of_char d.[i])) 0 result (2*i) 2; done; result let from_hex s = if String.length s <> 32 then raise (Invalid_argument "Digest.from_hex"); let digit c = match c with | '0'..'9' -> Char.code c - Char.code '0' | 'A'..'F' -> Char.code c - Char.code 'A' + 10 | 'a'..'f' -> Char.code c - Char.code 'a' + 10 | _ -> raise (Invalid_argument "Digest.from_hex") in let byte i = digit s.[i] lsl 4 + digit s.[i+1] in let result = String.create 16 in for i = 0 to 15 do result.[i] <- Char.chr (byte (2 * i)); done; result mingw-ocaml/ocaml/stdlib/weak.mli0000644000175000017500000001611212124403240016371 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Arrays of weak pointers and hash tables of weak pointers. *) (** {6 Low-level functions} *) type 'a t (** The type of arrays of weak pointers (weak arrays). A weak pointer is a value that the garbage collector may erase whenever the value is not used any more (through normal pointers) by the program. Note that finalisation functions are run after the weak pointers are erased. A weak pointer is said to be full if it points to a value, empty if the value was erased by the GC. Notes: - Integers are not allocated and cannot be stored in weak arrays. - Weak arrays cannot be marshaled using {!Pervasives.output_value} nor the functions of the {!Marshal} module. *) val create : int -> 'a t (** [Weak.create n] returns a new weak array of length [n]. All the pointers are initially empty. Raise [Invalid_argument] if [n] is negative or greater than {!Sys.max_array_length}[-1].*) val length : 'a t -> int (** [Weak.length ar] returns the length (number of elements) of [ar].*) val set : 'a t -> int -> 'a option -> unit (** [Weak.set ar n (Some el)] sets the [n]th cell of [ar] to be a (full) pointer to [el]; [Weak.set ar n None] sets the [n]th cell of [ar] to empty. Raise [Invalid_argument "Weak.set"] if [n] is not in the range 0 to {!Weak.length}[ a - 1].*) val get : 'a t -> int -> 'a option (** [Weak.get ar n] returns None if the [n]th cell of [ar] is empty, [Some x] (where [x] is the value) if it is full. Raise [Invalid_argument "Weak.get"] if [n] is not in the range 0 to {!Weak.length}[ a - 1].*) val get_copy : 'a t -> int -> 'a option (** [Weak.get_copy ar n] returns None if the [n]th cell of [ar] is empty, [Some x] (where [x] is a (shallow) copy of the value) if it is full. In addition to pitfalls with mutable values, the interesting difference with [get] is that [get_copy] does not prevent the incremental GC from erasing the value in its current cycle ([get] may delay the erasure to the next GC cycle). Raise [Invalid_argument "Weak.get"] if [n] is not in the range 0 to {!Weak.length}[ a - 1].*) val check : 'a t -> int -> bool (** [Weak.check ar n] returns [true] if the [n]th cell of [ar] is full, [false] if it is empty. Note that even if [Weak.check ar n] returns [true], a subsequent {!Weak.get}[ ar n] can return [None].*) val fill : 'a t -> int -> int -> 'a option -> unit (** [Weak.fill ar ofs len el] sets to [el] all pointers of [ar] from [ofs] to [ofs + len - 1]. Raise [Invalid_argument "Weak.fill"] if [ofs] and [len] do not designate a valid subarray of [a].*) val blit : 'a t -> int -> 'a t -> int -> int -> unit (** [Weak.blit ar1 off1 ar2 off2 len] copies [len] weak pointers from [ar1] (starting at [off1]) to [ar2] (starting at [off2]). It works correctly even if [ar1] and [ar2] are the same. Raise [Invalid_argument "Weak.blit"] if [off1] and [len] do not designate a valid subarray of [ar1], or if [off2] and [len] do not designate a valid subarray of [ar2].*) (** {6 Weak hash tables} *) (** A weak hash table is a hashed set of values. Each value may magically disappear from the set when it is not used by the rest of the program any more. This is normally used to share data structures without inducing memory leaks. Weak hash tables are defined on values from a {!Hashtbl.HashedType} module; the [equal] relation and [hash] function are taken from that module. We will say that [v] is an instance of [x] if [equal x v] is [true]. The [equal] relation must be able to work on a shallow copy of the values and give the same result as with the values themselves. *) module type S = sig type data (** The type of the elements stored in the table. *) type t (** The type of tables that contain elements of type [data]. Note that weak hash tables cannot be marshaled using {!Pervasives.output_value} or the functions of the {!Marshal} module. *) val create : int -> t (** [create n] creates a new empty weak hash table, of initial size [n]. The table will grow as needed. *) val clear : t -> unit (** Remove all elements from the table. *) val merge : t -> data -> data (** [merge t x] returns an instance of [x] found in [t] if any, or else adds [x] to [t] and return [x]. *) val add : t -> data -> unit (** [add t x] adds [x] to [t]. If there is already an instance of [x] in [t], it is unspecified which one will be returned by subsequent calls to [find] and [merge]. *) val remove : t -> data -> unit (** [remove t x] removes from [t] one instance of [x]. Does nothing if there is no instance of [x] in [t]. *) val find : t -> data -> data (** [find t x] returns an instance of [x] found in [t]. Raise [Not_found] if there is no such element. *) val find_all : t -> data -> data list (** [find_all t x] returns a list of all the instances of [x] found in [t]. *) val mem : t -> data -> bool (** [mem t x] returns [true] if there is at least one instance of [x] in [t], false otherwise. *) val iter : (data -> unit) -> t -> unit (** [iter f t] calls [f] on each element of [t], in some unspecified order. It is not specified what happens if [f] tries to change [t] itself. *) val fold : (data -> 'a -> 'a) -> t -> 'a -> 'a (** [fold f t init] computes [(f d1 (... (f dN init)))] where [d1 ... dN] are the elements of [t] in some unspecified order. It is not specified what happens if [f] tries to change [t] itself. *) val count : t -> int (** Count the number of elements in the table. [count t] gives the same result as [fold (fun _ n -> n+1) t 0] but does not delay the deallocation of the dead elements. *) val stats : t -> int * int * int * int * int * int (** Return statistics on the table. The numbers are, in order: table length, number of entries, sum of bucket lengths, smallest bucket length, median bucket length, biggest bucket length. *) end;; (** The output signature of the functor {!Weak.Make}. *) module Make (H : Hashtbl.HashedType) : S with type data = H.t;; (** Functor building an implementation of the weak hash table structure. *) mingw-ocaml/ocaml/stdlib/Makefile.nt0000644000175000017500000000313412124403240017017 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### # $Id$ include Makefile.shared allopt: stdlib.cmxa std_exit.cmx installopt: cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx $(LIBDIR) camlheader camlheader_ur: headernt.c ../config/Makefile $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \ -DRUNTIME_NAME='"ocamlrun"' headernt.c $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS) rm -f camlheader.exe mv tmpheader.exe camlheader cp camlheader camlheader_ur camlheaderd: headernt.c ../config/Makefile $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \ -DRUNTIME_NAME='"ocamlrund"' headernt.c $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS) mv tmpheader.exe camlheaderd # TODO: do not call flexlink to build tmpheader.exe (we don't need # the export table) mingw-ocaml/ocaml/stdlib/oo.ml0000644000175000017500000000207512124403240015711 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) let copy = CamlinternalOO.copy external id : < .. > -> int = "%field1" let new_method = CamlinternalOO.public_method_label let public_method_label = CamlinternalOO.public_method_label mingw-ocaml/ocaml/stdlib/stdlib.mllib0000644000175000017500000000076112124403240017244 0ustar tootstoots# This file lists all standard library modules # (in the same order as Makefile.shared). # It is used in particular to know what to expunge in toplevels. # $Id$ Pervasives Array List Char String Sys Hashtbl Sort Marshal Obj Int32 Int64 Nativeint Lexing Parsing Set Map Stack Queue CamlinternalLazy Lazy Stream Buffer Printf Format Scanf Arg Printexc Gc Digest Random Callback CamlinternalOO Oo CamlinternalMod Genlex Weak Filename Complex ArrayLabels ListLabels StringLabels MoreLabels StdLabels mingw-ocaml/ocaml/stdlib/parsing.ml0000644000175000017500000001544312124403240016742 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* The parsing engine *) open Lexing (* Internal interface to the parsing engine *) type parser_env = { mutable s_stack : int array; (* States *) mutable v_stack : Obj.t array; (* Semantic attributes *) mutable symb_start_stack : position array; (* Start positions *) mutable symb_end_stack : position array; (* End positions *) mutable stacksize : int; (* Size of the stacks *) mutable stackbase : int; (* Base sp for current parse *) mutable curr_char : int; (* Last token read *) mutable lval : Obj.t; (* Its semantic attribute *) mutable symb_start : position; (* Start pos. of the current symbol*) mutable symb_end : position; (* End pos. of the current symbol *) mutable asp : int; (* The stack pointer for attributes *) mutable rule_len : int; (* Number of rhs items in the rule *) mutable rule_number : int; (* Rule number to reduce by *) mutable sp : int; (* Saved sp for parse_engine *) mutable state : int; (* Saved state for parse_engine *) mutable errflag : int } (* Saved error flag for parse_engine *) type parse_tables = { actions : (parser_env -> Obj.t) array; transl_const : int array; transl_block : int array; lhs : string; len : string; defred : string; dgoto : string; sindex : string; rindex : string; gindex : string; tablesize : int; table : string; check : string; error_function : string -> unit; names_const : string; names_block : string } exception YYexit of Obj.t exception Parse_error type parser_input = Start | Token_read | Stacks_grown_1 | Stacks_grown_2 | Semantic_action_computed | Error_detected type parser_output = Read_token | Raise_parse_error | Grow_stacks_1 | Grow_stacks_2 | Compute_semantic_action | Call_error_function external parse_engine : parse_tables -> parser_env -> parser_input -> Obj.t -> parser_output = "caml_parse_engine" external set_trace: bool -> bool = "caml_set_parser_trace" let env = { s_stack = Array.create 100 0; v_stack = Array.create 100 (Obj.repr ()); symb_start_stack = Array.create 100 dummy_pos; symb_end_stack = Array.create 100 dummy_pos; stacksize = 100; stackbase = 0; curr_char = 0; lval = Obj.repr (); symb_start = dummy_pos; symb_end = dummy_pos; asp = 0; rule_len = 0; rule_number = 0; sp = 0; state = 0; errflag = 0 } let grow_stacks() = let oldsize = env.stacksize in let newsize = oldsize * 2 in let new_s = Array.create newsize 0 and new_v = Array.create newsize (Obj.repr ()) and new_start = Array.create newsize dummy_pos and new_end = Array.create newsize dummy_pos in Array.blit env.s_stack 0 new_s 0 oldsize; env.s_stack <- new_s; Array.blit env.v_stack 0 new_v 0 oldsize; env.v_stack <- new_v; Array.blit env.symb_start_stack 0 new_start 0 oldsize; env.symb_start_stack <- new_start; Array.blit env.symb_end_stack 0 new_end 0 oldsize; env.symb_end_stack <- new_end; env.stacksize <- newsize let clear_parser() = Array.fill env.v_stack 0 env.stacksize (Obj.repr ()); env.lval <- Obj.repr () let current_lookahead_fun = ref (fun (x : Obj.t) -> false) let yyparse tables start lexer lexbuf = let rec loop cmd arg = match parse_engine tables env cmd arg with Read_token -> let t = Obj.repr(lexer lexbuf) in env.symb_start <- lexbuf.lex_start_p; env.symb_end <- lexbuf.lex_curr_p; loop Token_read t | Raise_parse_error -> raise Parse_error | Compute_semantic_action -> let (action, value) = try (Semantic_action_computed, tables.actions.(env.rule_number) env) with Parse_error -> (Error_detected, Obj.repr ()) in loop action value | Grow_stacks_1 -> grow_stacks(); loop Stacks_grown_1 (Obj.repr ()) | Grow_stacks_2 -> grow_stacks(); loop Stacks_grown_2 (Obj.repr ()) | Call_error_function -> tables.error_function "syntax error"; loop Error_detected (Obj.repr ()) in let init_asp = env.asp and init_sp = env.sp and init_stackbase = env.stackbase and init_state = env.state and init_curr_char = env.curr_char and init_lval = env.lval and init_errflag = env.errflag in env.stackbase <- env.sp + 1; env.curr_char <- start; env.symb_end <- lexbuf.lex_curr_p; try loop Start (Obj.repr ()) with exn -> let curr_char = env.curr_char in env.asp <- init_asp; env.sp <- init_sp; env.stackbase <- init_stackbase; env.state <- init_state; env.curr_char <- init_curr_char; env.lval <- init_lval; env.errflag <- init_errflag; match exn with YYexit v -> Obj.magic v | _ -> current_lookahead_fun := (fun tok -> if Obj.is_block tok then tables.transl_block.(Obj.tag tok) = curr_char else tables.transl_const.(Obj.magic tok) = curr_char); raise exn let peek_val env n = Obj.magic env.v_stack.(env.asp - n) let symbol_start_pos () = let rec loop i = if i <= 0 then env.symb_end_stack.(env.asp) else begin let st = env.symb_start_stack.(env.asp - i + 1) in let en = env.symb_end_stack.(env.asp - i + 1) in if st <> en then st else loop (i - 1) end in loop env.rule_len ;; let symbol_end_pos () = env.symb_end_stack.(env.asp);; let rhs_start_pos n = env.symb_start_stack.(env.asp - (env.rule_len - n));; let rhs_end_pos n = env.symb_end_stack.(env.asp - (env.rule_len - n));; let symbol_start () = (symbol_start_pos ()).pos_cnum;; let symbol_end () = (symbol_end_pos ()).pos_cnum;; let rhs_start n = (rhs_start_pos n).pos_cnum;; let rhs_end n = (rhs_end_pos n).pos_cnum;; let is_current_lookahead tok = (!current_lookahead_fun)(Obj.repr tok) let parse_error (msg : string) = () mingw-ocaml/ocaml/stdlib/stack.ml0000644000175000017500000000244212124403240016377 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) type 'a t = { mutable c : 'a list } exception Empty let create () = { c = [] } let clear s = s.c <- [] let copy s = { c = s.c } let push x s = s.c <- x :: s.c let pop s = match s.c with hd::tl -> s.c <- tl; hd | [] -> raise Empty let top s = match s.c with hd::_ -> hd | [] -> raise Empty let is_empty s = (s.c = []) let length s = List.length s.c let iter f s = List.iter f s.c mingw-ocaml/ocaml/stdlib/random.ml0000644000175000017500000002152112124403240016551 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Pseudo-random number generator This is a lagged-Fibonacci F(55, 24, +) with a modified addition function to enhance the mixing of bits. If we use normal addition, the low-order bit fails tests 1 and 7 of the Diehard test suite, and bits 1 and 2 also fail test 7. If we use multiplication as suggested by Marsaglia, it doesn't fare much better. By mixing the bits of one of the numbers before addition (XOR the 5 high-order bits into the low-order bits), we get a generator that passes all the Diehard tests. *) external random_seed: unit -> int array = "caml_sys_random_seed";; module State = struct type t = { st : int array; mutable idx : int };; let new_state () = { st = Array.make 55 0; idx = 0 };; let assign st1 st2 = Array.blit st2.st 0 st1.st 0 55; st1.idx <- st2.idx; ;; let full_init s seed = let combine accu x = Digest.string (accu ^ string_of_int x) in let extract d = Char.code d.[0] + (Char.code d.[1] lsl 8) + (Char.code d.[2] lsl 16) + (Char.code d.[3] lsl 24) in let seed = if Array.length seed = 0 then [| 0 |] else seed in let l = Array.length seed in for i = 0 to 54 do s.st.(i) <- i; done; let accu = ref "x" in for i = 0 to 54 + max 55 l do let j = i mod 55 in let k = i mod l in accu := combine !accu seed.(k); s.st.(j) <- (s.st.(j) lxor extract !accu) land 0x3FFFFFFF; (* PR#5575 *) done; s.idx <- 0; ;; let make seed = let result = new_state () in full_init result seed; result ;; let make_self_init () = make (random_seed ());; let copy s = let result = new_state () in assign result s; result ;; (* Returns 30 random bits as an integer 0 <= x < 1073741824 *) let bits s = s.idx <- (s.idx + 1) mod 55; let curval = s.st.(s.idx) in let newval = s.st.((s.idx + 24) mod 55) + (curval lxor ((curval lsr 25) land 0x1F)) in let newval30 = newval land 0x3FFFFFFF in (* PR#5575 *) s.st.(s.idx) <- newval30; newval30 ;; let rec intaux s n = let r = bits s in let v = r mod n in if r - v > 0x3FFFFFFF - n + 1 then intaux s n else v ;; let int s bound = if bound > 0x3FFFFFFF || bound <= 0 then invalid_arg "Random.int" else intaux s bound ;; let rec int32aux s n = let b1 = Int32.of_int (bits s) in let b2 = Int32.shift_left (Int32.of_int (bits s land 1)) 30 in let r = Int32.logor b1 b2 in let v = Int32.rem r n in if Int32.sub r v > Int32.add (Int32.sub Int32.max_int n) 1l then int32aux s n else v ;; let int32 s bound = if bound <= 0l then invalid_arg "Random.int32" else int32aux s bound ;; let rec int64aux s n = let b1 = Int64.of_int (bits s) in let b2 = Int64.shift_left (Int64.of_int (bits s)) 30 in let b3 = Int64.shift_left (Int64.of_int (bits s land 7)) 60 in let r = Int64.logor b1 (Int64.logor b2 b3) in let v = Int64.rem r n in if Int64.sub r v > Int64.add (Int64.sub Int64.max_int n) 1L then int64aux s n else v ;; let int64 s bound = if bound <= 0L then invalid_arg "Random.int64" else int64aux s bound ;; let nativeint = if Nativeint.size = 32 then fun s bound -> Nativeint.of_int32 (int32 s (Nativeint.to_int32 bound)) else fun s bound -> Int64.to_nativeint (int64 s (Int64.of_nativeint bound)) ;; (* Returns a float 0 <= x <= 1 with at most 60 bits of precision. *) let rawfloat s = let scale = 1073741824.0 (* 2^30 *) and r1 = Pervasives.float (bits s) and r2 = Pervasives.float (bits s) in (r1 /. scale +. r2) /. scale ;; let float s bound = rawfloat s *. bound;; let bool s = (bits s land 1 = 0);; end;; (* This is the state you get with [init 27182818]. *) let default = { State.st = [| 0x7ae2522b; 0x5d8d4634; 0x15b4fad0; 0x18b14ace; 0x12f8a3c4; 0x7b086c47; 0x16d467d6; 0x501d91c7; 0x321df177; 0x4176c193; 0x1ff72bf1; 0x5e889109; 0x0b464b18; 0x6b86b97c; 0x4891da48; 0x03137463; 0x485ac5a1; 0x15d61f2f; 0x7bced359; 0x69c1c132; 0x7a86766e; 0x366d8c86; 0x1f5b6222; 0x7ce1b59f; 0x2ebf78e1; 0x67cd1b86; 0x658f3dc3; 0x789a8194; 0x42e4c44c; 0x58c43f7d; 0x0f6e534f; 0x1e7df359; 0x455d0b7e; 0x10e84e7e; 0x126198e4; 0x4e7722cb; 0x5cbede28; 0x7391b964; 0x7d40e92a; 0x4c59933d; 0x0b8cd0b7; 0x64efff1c; 0x2803fdaa; 0x08ebc72e; 0x4f522e32; 0x45398edc; 0x2144a04c; 0x4aef3cbd; 0x41ad4719; 0x75b93cd6; 0x2a559d4f; 0x5e6fd768; 0x66e27f36; 0x186f18c3; 0x2fbf967a; |]; State.idx = 0; };; let bits () = State.bits default;; let int bound = State.int default bound;; let int32 bound = State.int32 default bound;; let nativeint bound = State.nativeint default bound;; let int64 bound = State.int64 default bound;; let float scale = State.float default scale;; let bool () = State.bool default;; let full_init seed = State.full_init default seed;; let init seed = State.full_init default [| seed |];; let self_init () = full_init (random_seed());; (* Manipulating the current state. *) let get_state () = State.copy default;; let set_state s = State.assign default s;; (******************** (* Test functions. Not included in the library. The [chisquare] function should be called with n > 10r. It returns a triple (low, actual, high). If low <= actual <= high, the [g] function passed the test, otherwise it failed. Some results: init 27182818; chisquare int 100000 1000;; init 27182818; chisquare int 100000 100;; init 27182818; chisquare int 100000 5000;; init 27182818; chisquare int 1000000 1000;; init 27182818; chisquare int 100000 1024;; init 299792643; chisquare int 100000 1024;; init 14142136; chisquare int 100000 1024;; init 27182818; init_diff 1024; chisquare diff 100000 1024;; init 27182818; init_diff 100; chisquare diff 100000 100;; init 27182818; init_diff2 1024; chisquare diff2 100000 1024;; init 27182818; init_diff2 100; chisquare diff2 100000 100;; init 14142136; init_diff2 100; chisquare diff2 100000 100;; init 299792643; init_diff2 100; chisquare diff2 100000 100;; - : float * float * float = (936.754446796632465, 997.5, 1063.24555320336754) # - : float * float * float = (80., 89.7400000000052387, 120.) # - : float * float * float = (4858.57864376269, 5045.5, 5141.42135623731) # - : float * float * float = (936.754446796632465, 944.805999999982305, 1063.24555320336754) # - : float * float * float = (960., 1019.19744000000355, 1088.) # - : float * float * float = (960., 1059.31776000000536, 1088.) # - : float * float * float = (960., 1039.98463999999512, 1088.) # - : float * float * float = (960., 1054.38207999999577, 1088.) # - : float * float * float = (80., 90.096000000005, 120.) # - : float * float * float = (960., 1076.78720000000612, 1088.) # - : float * float * float = (80., 85.1760000000067521, 120.) # - : float * float * float = (80., 85.2160000000003492, 120.) # - : float * float * float = (80., 80.6220000000030268, 120.) *) (* Return the sum of the squares of v[i0,i1[ *) let rec sumsq v i0 i1 = if i0 >= i1 then 0.0 else if i1 = i0 + 1 then Pervasives.float v.(i0) *. Pervasives.float v.(i0) else sumsq v i0 ((i0+i1)/2) +. sumsq v ((i0+i1)/2) i1 ;; let chisquare g n r = if n <= 10 * r then invalid_arg "chisquare"; let f = Array.make r 0 in for i = 1 to n do let t = g r in f.(t) <- f.(t) + 1 done; let t = sumsq f 0 r and r = Pervasives.float r and n = Pervasives.float n in let sr = 2.0 *. sqrt r in (r -. sr, (r *. t /. n) -. n, r +. sr) ;; (* This is to test for linear dependencies between successive random numbers. *) let st = ref 0;; let init_diff r = st := int r;; let diff r = let x1 = !st and x2 = int r in st := x2; if x1 >= x2 then x1 - x2 else r + x1 - x2 ;; let st1 = ref 0 and st2 = ref 0 ;; (* This is to test for quadratic dependencies between successive random numbers. *) let init_diff2 r = st1 := int r; st2 := int r;; let diff2 r = let x1 = !st1 and x2 = !st2 and x3 = int r in st1 := x2; st2 := x3; (x3 - x2 - x2 + x1 + 2*r) mod r ;; ********************) mingw-ocaml/ocaml/stdlib/printexc.ml0000644000175000017500000001106212124403240017124 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) open Printf;; let printers = ref [] let locfmt = format_of_string "File \"%s\", line %d, characters %d-%d: %s";; let field x i = let f = Obj.field x i in if not (Obj.is_block f) then sprintf "%d" (Obj.magic f : int) (* can also be a char *) else if Obj.tag f = Obj.string_tag then sprintf "%S" (Obj.magic f : string) else if Obj.tag f = Obj.double_tag then string_of_float (Obj.magic f : float) else "_" ;; let rec other_fields x i = if i >= Obj.size x then "" else sprintf ", %s%s" (field x i) (other_fields x (i+1)) ;; let fields x = match Obj.size x with | 0 -> "" | 1 -> "" | 2 -> sprintf "(%s)" (field x 1) | n -> sprintf "(%s%s)" (field x 1) (other_fields x 2) ;; let to_string x = let rec conv = function | hd :: tl -> (match try hd x with _ -> None with | Some s -> s | None -> conv tl) | [] -> match x with | Out_of_memory -> "Out of memory" | Stack_overflow -> "Stack overflow" | Match_failure(file, line, char) -> sprintf locfmt file line char (char+5) "Pattern matching failed" | Assert_failure(file, line, char) -> sprintf locfmt file line char (char+6) "Assertion failed" | Undefined_recursive_module(file, line, char) -> sprintf locfmt file line char (char+6) "Undefined recursive module" | _ -> let x = Obj.repr x in let constructor = (Obj.magic(Obj.field (Obj.field x 0) 0) : string) in constructor ^ (fields x) in conv !printers let print fct arg = try fct arg with x -> eprintf "Uncaught exception: %s\n" (to_string x); flush stderr; raise x let catch fct arg = try fct arg with x -> flush stdout; eprintf "Uncaught exception: %s\n" (to_string x); exit 2 type loc_info = | Known_location of bool (* is_raise *) * string (* filename *) * int (* line number *) * int (* start char *) * int (* end char *) | Unknown_location of bool (*is_raise*) external get_exception_backtrace: unit -> loc_info array option = "caml_get_exception_backtrace" let format_loc_info pos li = let is_raise = match li with | Known_location(is_raise, _, _, _, _) -> is_raise | Unknown_location(is_raise) -> is_raise in let info = if is_raise then if pos = 0 then "Raised at" else "Re-raised at" else if pos = 0 then "Raised by primitive operation at" else "Called from" in match li with | Known_location(is_raise, filename, lineno, startchar, endchar) -> sprintf "%s file \"%s\", line %d, characters %d-%d" info filename lineno startchar endchar | Unknown_location(is_raise) -> sprintf "%s unknown location" info let print_backtrace outchan = match get_exception_backtrace() with | None -> fprintf outchan "(Program not linked with -g, cannot print stack backtrace)\n" | Some a -> for i = 0 to Array.length a - 1 do if a.(i) <> Unknown_location true then fprintf outchan "%s\n" (format_loc_info i a.(i)) done let get_backtrace () = match get_exception_backtrace() with | None -> "(Program not linked with -g, cannot print stack backtrace)\n" | Some a -> let b = Buffer.create 1024 in for i = 0 to Array.length a - 1 do if a.(i) <> Unknown_location true then bprintf b "%s\n" (format_loc_info i a.(i)) done; Buffer.contents b external record_backtrace: bool -> unit = "caml_record_backtrace" external backtrace_status: unit -> bool = "caml_backtrace_status" let register_printer fn = printers := fn :: !printers mingw-ocaml/ocaml/stdlib/moreLabels.ml0000644000175000017500000000201712124403240017355 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [MoreLabels]: meta-module for compatibility labelled libraries *) module Hashtbl = Hashtbl module Map = Map module Set = Set mingw-ocaml/ocaml/stdlib/stack.mli0000644000175000017500000000411712124403240016551 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Last-in first-out stacks. This module implements stacks (LIFOs), with in-place modification. *) type 'a t (** The type of stacks containing elements of type ['a]. *) exception Empty (** Raised when {!Stack.pop} or {!Stack.top} is applied to an empty stack. *) val create : unit -> 'a t (** Return a new stack, initially empty. *) val push : 'a -> 'a t -> unit (** [push x s] adds the element [x] at the top of stack [s]. *) val pop : 'a t -> 'a (** [pop s] removes and returns the topmost element in stack [s], or raises [Empty] if the stack is empty. *) val top : 'a t -> 'a (** [top s] returns the topmost element in stack [s], or raises [Empty] if the stack is empty. *) val clear : 'a t -> unit (** Discard all elements from a stack. *) val copy : 'a t -> 'a t (** Return a copy of the given stack. *) val is_empty : 'a t -> bool (** Return [true] if the given stack is empty, [false] otherwise. *) val length : 'a t -> int (** Return the number of elements in a stack. *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f s] applies [f] in turn to all elements of [s], from the element at the top of the stack to the element at the bottom of the stack. The stack itself is unchanged. *) mingw-ocaml/ocaml/stdlib/listLabels.mli0000644000175000017500000002563512124403240017552 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** List operations. Some functions are flagged as not tail-recursive. A tail-recursive function uses constant stack space, while a non-tail-recursive function uses stack space proportional to the length of its list argument, which can be a problem with very long lists. When the function takes several list arguments, an approximate formula giving stack usage (in some unspecified constant unit) is shown in parentheses. The above considerations can usually be ignored if your lists are not longer than about 10000 elements. *) val length : 'a list -> int (** Return the length (number of elements) of the given list. *) val hd : 'a list -> 'a (** Return the first element of the given list. Raise [Failure "hd"] if the list is empty. *) val tl : 'a list -> 'a list (** Return the given list without its first element. Raise [Failure "tl"] if the list is empty. *) val nth : 'a list -> int -> 'a (** Return the [n]-th element of the given list. The first element (head of the list) is at position 0. Raise [Failure "nth"] if the list is too short. Raise [Invalid_argument "List.nth"] if [n] is negative. *) val rev : 'a list -> 'a list (** List reversal. *) val append : 'a list -> 'a list -> 'a list (** Catenate two lists. Same function as the infix operator [@]. Not tail-recursive (length of the first argument). The [@] operator is not tail-recursive either. *) val rev_append : 'a list -> 'a list -> 'a list (** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2]. This is equivalent to {!ListLabels.rev}[ l1 @ l2], but [rev_append] is tail-recursive and more efficient. *) val concat : 'a list list -> 'a list (** Concatenate a list of lists. The elements of the argument are all concatenated together (in the same order) to give the result. Not tail-recursive (length of the argument + length of the longest sub-list). *) val flatten : 'a list list -> 'a list (** Same as [concat]. Not tail-recursive (length of the argument + length of the longest sub-list). *) (** {6 Iterators} *) val iter : f:('a -> unit) -> 'a list -> unit (** [List.iter f [a1; ...; an]] applies function [f] in turn to [a1; ...; an]. It is equivalent to [begin f a1; f a2; ...; f an; () end]. *) val iteri : f:(int -> 'a -> unit) -> 'a list -> unit (** Same as {!List.iter}, but the function is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. @since 4.00.0 *) val map : f:('a -> 'b) -> 'a list -> 'b list (** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an], and builds the list [[f a1; ...; f an]] with the results returned by [f]. Not tail-recursive. *) val mapi : f:(int -> 'a -> 'b) -> 'a list -> 'b list (** Same as {!List.map}, but the function is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. @since 4.00.0 *) val rev_map : f:('a -> 'b) -> 'a list -> 'b list (** [List.rev_map f l] gives the same result as {!ListLabels.rev}[ (]{!ListLabels.map}[ f l)], but is tail-recursive and more efficient. *) val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b list -> 'a (** [List.fold_left f a [b1; ...; bn]] is [f (... (f (f a b1) b2) ...) bn]. *) val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b (** [List.fold_right f [a1; ...; an] b] is [f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. *) (** {6 Iterators on two lists} *) val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit (** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn [f a1 b1; ...; f an bn]. Raise [Invalid_argument] if the two lists have different lengths. *) val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.map2 f [a1; ...; an] [b1; ...; bn]] is [[f a1 b1; ...; f an bn]]. Raise [Invalid_argument] if the two lists have different lengths. Not tail-recursive. *) val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.rev_map2 f l1 l2] gives the same result as {!ListLabels.rev}[ (]{!ListLabels.map2}[ f l1 l2)], but is tail-recursive and more efficient. *) val fold_left2 : f:('a -> 'b -> 'c -> 'a) -> init:'a -> 'b list -> 'c list -> 'a (** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is [f (... (f (f a b1 c1) b2 c2) ...) bn cn]. Raise [Invalid_argument] if the two lists have different lengths. *) val fold_right2 : f:('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> init:'c -> 'c (** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is [f a1 b1 (f a2 b2 (... (f an bn c) ...))]. Raise [Invalid_argument] if the two lists have different lengths. Not tail-recursive. *) (** {6 List scanning} *) val for_all : f:('a -> bool) -> 'a list -> bool (** [for_all p [a1; ...; an]] checks if all elements of the list satisfy the predicate [p]. That is, it returns [(p a1) && (p a2) && ... && (p an)]. *) val exists : f:('a -> bool) -> 'a list -> bool (** [exists p [a1; ...; an]] checks if at least one element of the list satisfies the predicate [p]. That is, it returns [(p a1) || (p a2) || ... || (p an)]. *) val for_all2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!ListLabels.for_all}, but for a two-argument predicate. Raise [Invalid_argument] if the two lists have different lengths. *) val exists2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!ListLabels.exists}, but for a two-argument predicate. Raise [Invalid_argument] if the two lists have different lengths. *) val mem : 'a -> set:'a list -> bool (** [mem a l] is true if and only if [a] is equal to an element of [l]. *) val memq : 'a -> set:'a list -> bool (** Same as {!ListLabels.mem}, but uses physical equality instead of structural equality to compare list elements. *) (** {6 List searching} *) val find : f:('a -> bool) -> 'a list -> 'a (** [find p l] returns the first element of the list [l] that satisfies the predicate [p]. Raise [Not_found] if there is no value that satisfies [p] in the list [l]. *) val filter : f:('a -> bool) -> 'a list -> 'a list (** [filter p l] returns all the elements of the list [l] that satisfy the predicate [p]. The order of the elements in the input list is preserved. *) val find_all : f:('a -> bool) -> 'a list -> 'a list (** [find_all] is another name for {!ListLabels.filter}. *) val partition : f:('a -> bool) -> 'a list -> 'a list * 'a list (** [partition p l] returns a pair of lists [(l1, l2)], where [l1] is the list of all the elements of [l] that satisfy the predicate [p], and [l2] is the list of all the elements of [l] that do not satisfy [p]. The order of the elements in the input list is preserved. *) (** {6 Association lists} *) val assoc : 'a -> ('a * 'b) list -> 'b (** [assoc a l] returns the value associated with key [a] in the list of pairs [l]. That is, [assoc a [ ...; (a,b); ...] = b] if [(a,b)] is the leftmost binding of [a] in list [l]. Raise [Not_found] if there is no value associated with [a] in the list [l]. *) val assq : 'a -> ('a * 'b) list -> 'b (** Same as {!ListLabels.assoc}, but uses physical equality instead of structural equality to compare keys. *) val mem_assoc : 'a -> map:('a * 'b) list -> bool (** Same as {!ListLabels.assoc}, but simply return true if a binding exists, and false if no bindings exist for the given key. *) val mem_assq : 'a -> map:('a * 'b) list -> bool (** Same as {!ListLabels.mem_assoc}, but uses physical equality instead of structural equality to compare keys. *) val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list (** [remove_assoc a l] returns the list of pairs [l] without the first pair with key [a], if any. Not tail-recursive. *) val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list (** Same as {!ListLabels.remove_assoc}, but uses physical equality instead of structural equality to compare keys. Not tail-recursive. *) (** {6 Lists of pairs} *) val split : ('a * 'b) list -> 'a list * 'b list (** Transform a list of pairs into a pair of lists: [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])]. Not tail-recursive. *) val combine : 'a list -> 'b list -> ('a * 'b) list (** Transform a pair of lists into a list of pairs: [combine [a1; ...; an] [b1; ...; bn]] is [[(a1,b1); ...; (an,bn)]]. Raise [Invalid_argument] if the two lists have different lengths. Not tail-recursive. *) (** {6 Sorting} *) val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list (** Sort a list in increasing order according to a comparison function. The comparison function must return 0 if its arguments compare as equal, a positive integer if the first is greater, and a negative integer if the first is smaller (see Array.sort for a complete specification). For example, {!Pervasives.compare} is a suitable comparison function. The resulting list is sorted in increasing order. [List.sort] is guaranteed to run in constant heap space (in addition to the size of the result list) and logarithmic stack space. The current implementation uses Merge Sort. It runs in constant heap space and logarithmic stack space. *) val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list (** Same as {!ListLabels.sort}, but the sorting algorithm is guaranteed to be stable (i.e. elements that compare equal are kept in their original order) . The current implementation uses Merge Sort. It runs in constant heap space and logarithmic stack space. *) val fast_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list (** Same as {!List.sort} or {!List.stable_sort}, whichever is faster on typical input. *) val merge : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list (** Merge two lists: Assuming that [l1] and [l2] are sorted according to the comparison function [cmp], [merge cmp l1 l2] will return a sorted list containting all the elements of [l1] and [l2]. If several elements compare equal, the elements of [l1] will be before the elements of [l2]. Not tail-recursive (sum of the lengths of the arguments). *) mingw-ocaml/ocaml/stdlib/scanf.mli0000644000175000017500000005622012124403240016540 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Formatted input functions. *) (** {6 Introduction} *) (** {7 Functional input with format strings} *) (** The module [Scanf] provides formatted input functions or {e scanners}. The formatted input functions can read from any kind of input, including strings, files, or anything that can return characters. The more general source of characters is named a {e formatted input channel} (or {e scanning buffer}) and has type {!Scanning.in_channel}. The more general formatted input function reads from any scanning buffer and is named [bscanf]. Generally speaking, the formatted input functions have 3 arguments: - the first argument is a source of characters for the input, - the second argument is a format string that specifies the values to read, - the third argument is a {e receiver function} that is applied to the values read. Hence, a typical call to the formatted input function {!Scanf.bscanf} is [bscanf ic fmt f], where: - [ic] is a source of characters (typically a {e formatted input channel} with type {!Scanning.in_channel}), - [fmt] is a format string (the same format strings as those used to print material with module {!Printf} or {!Format}), - [f] is a function that has as many arguments as the number of values to read in the input. *) (** {7 A simple example} *) (** As suggested above, the expression [bscanf ic "%d" f] reads a decimal integer [n] from the source of characters [ic] and returns [f n]. For instance, - if we use [stdin] as the source of characters ({!Scanning.stdin} is the predefined formatted input channel that reads from standard input), - if we define the receiver [f] as [let f x = x + 1], then [bscanf Scanning.stdin "%d" f] reads an integer [n] from the standard input and returns [f n] (that is [n + 1]). Thus, if we evaluate [bscanf stdin "%d" f], and then enter [41] at the keyboard, we get [42] as the final result. *) (** {7 Formatted input as a functional feature} *) (** The OCaml scanning facility is reminiscent of the corresponding C feature. However, it is also largely different, simpler, and yet more powerful: the formatted input functions are higher-order functionals and the parameter passing mechanism is just the regular function application not the variable assignment based mechanism which is typical for formatted input in imperative languages; the OCaml format strings also feature useful additions to easily define complex tokens; as expected within a functional programming language, the formatted input functions also support polymorphism, in particular arbitrary interaction with polymorphic user-defined scanners. Furthermore, the OCaml formatted input facility is fully type-checked at compile time. *) (** {6 Formatted input channel} *) module Scanning : sig type in_channel;; (** The notion of input channel for the [Scanf] module: those channels provide all the machinery necessary to read from a given [Pervasives.in_channel] value. A [Scanf.Scanning.in_channel] value is also called a {i formatted input channel} or equivalently a {i scanning buffer}. The type [scanbuf] below is an alias for [in_channel]. @since 3.12.0 *) type scanbuf = in_channel;; (** The type of scanning buffers. A scanning buffer is the source from which a formatted input function gets characters. The scanning buffer holds the current state of the scan, plus a function to get the next char from the input, and a token buffer to store the string matched so far. Note: a scanning action may often require to examine one character in advance; when this ``lookahead'' character does not belong to the token read, it is stored back in the scanning buffer and becomes the next character yet to be read. *) val stdin : in_channel;; (** The standard input notion for the [Scanf] module. [Scanning.stdin] is the formatted input channel attached to [Pervasives.stdin]. Note: in the interactive system, when input is read from [stdin], the newline character that triggers the evaluation is incorporated in the input; thus, the scanning specifications must properly skip this additional newline character (for instance, simply add a ['\n'] as the last character of the format string). @since 3.12.0 *) type file_name = string;; (** A convenient alias to designate a file name. @since 4.00.0 *) val open_in : file_name -> in_channel;; (** [Scanning.open_in fname] returns a formatted input channel for bufferized reading in text mode of file [fname]. Note: [open_in] returns a formatted input channel that efficiently reads characters in large chunks; in contrast, [from_channel] below returns formatted input channels that must read one character at a time, leading to a much slower scanning rate. @since 3.12.0 *) val open_in_bin : file_name -> in_channel;; (** [Scanning.open_in_bin fname] returns a formatted input channel for bufferized reading in binary mode of file [fname]. @since 3.12.0 *) val close_in : in_channel -> unit;; (** Closes the [Pervasives.in_channel] associated with the given [Scanning.in_channel] formatted input channel. @since 3.12.0 *) val from_file : file_name -> in_channel;; (** An alias for [open_in] above. *) val from_file_bin : string -> in_channel;; (** An alias for [open_in_bin] above. *) val from_string : string -> in_channel;; (** [Scanning.from_string s] returns a formatted input channel which reads from the given string. Reading starts from the first character in the string. The end-of-input condition is set when the end of the string is reached. *) val from_function : (unit -> char) -> in_channel;; (** [Scanning.from_function f] returns a formatted input channel with the given function as its reading method. When scanning needs one more character, the given function is called. When the function has no more character to provide, it {e must} signal an end-of-input condition by raising the exception [End_of_file]. *) val from_channel : Pervasives.in_channel -> in_channel;; (** [Scanning.from_channel ic] returns a formatted input channel which reads from the regular input channel [ic] argument, starting at the current reading position. *) val end_of_input : in_channel -> bool;; (** [Scanning.end_of_input ic] tests the end-of-input condition of the given formatted input channel. *) val beginning_of_input : in_channel -> bool;; (** [Scanning.beginning_of_input ic] tests the beginning of input condition of the given formatted input channel. *) val name_of_input : in_channel -> string;; (** [Scanning.name_of_input ic] returns the name of the character source for the formatted input channel [ic]. @since 3.09.0 *) val stdib : in_channel;; (** A deprecated alias for [Scanning.stdin], the scanning buffer reading from [Pervasives.stdin]. *) end;; (** {6 Type of formatted input functions} *) type ('a, 'b, 'c, 'd) scanner = ('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c;; (** The type of formatted input scanners: [('a, 'b, 'c, 'd) scanner] is the type of a formatted input function that reads from some formatted input channel according to some format string; more precisely, if [scan] is some formatted input function, then [scan ic fmt f] applies [f] to the arguments specified by the format string [fmt], when [scan] has read those arguments from the formatted input channel [ic]. For instance, the [scanf] function below has type [('a, 'b, 'c, 'd) scanner], since it is a formatted input function that reads from [Scanning.stdin]: [scanf fmt f] applies [f] to the arguments specified by [fmt], reading those arguments from [Pervasives.stdin] as expected. If the format [fmt] has some [%r] indications, the corresponding input functions must be provided before the receiver [f] argument. For instance, if [read_elem] is an input function for values of type [t], then [bscanf ic "%r;" read_elem f] reads a value [v] of type [t] followed by a [';'] character, and returns [f v]. @since 3.10.0 *) exception Scan_failure of string;; (** The exception that formatted input functions raise when the input cannot be read according to the given format. *) (** {6 The general formatted input function} *) val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;; (** [bscanf ic fmt r1 ... rN f] reads arguments for the function [f], from the formatted input channel [ic], according to the format string [fmt], and applies [f] to these values. The result of this call to [f] is returned as the result of the entire [bscanf] call. For instance, if [f] is the function [fun s i -> i + 1], then [Scanf.sscanf "x= 1" "%s = %i" f] returns [2]. Arguments [r1] to [rN] are user-defined input functions that read the argument corresponding to a [%r] conversion. *) (** {6 Format string description} *) (** The format is a character string which contains three types of objects: - plain characters, which are simply matched with the characters of the input (with a special case for space and line feed, see {!Scanf.space}), - conversion specifications, each of which causes reading and conversion of one argument for the function [f] (see {!Scanf.conversion}), - scanning indications to specify boundaries of tokens (see scanning {!Scanf.indication}). *) (** {7:space The space character in format strings} *) (** As mentioned above, a plain character in the format string is just matched with the next character of the input; however, two characters are special exceptions to this rule: the space character ([' '] or ASCII code 32) and the line feed character (['\n'] or ASCII code 10). A space does not match a single space character, but any amount of ``whitespace'' in the input. More precisely, a space inside the format string matches {e any number} of tab, space, line feed and carriage return characters. Similarly, a line feed character in the format string matches either a single line feed or a carriage return followed by a line feed. Matching {e any} amount of whitespace, a space in the format string also matches no amount of whitespace at all; hence, the call [bscanf ib "Price = %d $" (fun p -> p)] succeeds and returns [1] when reading an input with various whitespace in it, such as [Price = 1 $], [Price = 1 $], or even [Price=1$]. *) (** {7:conversion Conversion specifications in format strings} *) (** Conversion specifications consist in the [%] character, followed by an optional flag, an optional field width, and followed by one or two conversion characters. The conversion characters and their meanings are: - [d]: reads an optionally signed decimal integer. - [i]: reads an optionally signed integer (usual input conventions for decimal ([0-9]+), hexadecimal ([0x[0-9a-f]+] and [0X[0-9A-F]+]), octal ([0o[0-7]+]), and binary ([0b[0-1]+]) notations are understood). - [u]: reads an unsigned decimal integer. - [x] or [X]: reads an unsigned hexadecimal integer ([[0-9a-fA-F]+]). - [o]: reads an unsigned octal integer ([[0-7]+]). - [s]: reads a string argument that spreads as much as possible, until the following bounding condition holds: {ul {- a whitespace has been found (see {!Scanf.space}),} {- a scanning indication (see scanning {!Scanf.indication}) has been encountered,} {- the end-of-input has been reached.}} Hence, this conversion always succeeds: it returns an empty string if the bounding condition holds when the scan begins. - [S]: reads a delimited string argument (delimiters and special escaped characters follow the lexical conventions of OCaml). - [c]: reads a single character. To test the current input character without reading it, specify a null field width, i.e. use specification [%0c]. Raise [Invalid_argument], if the field width specification is greater than 1. - [C]: reads a single delimited character (delimiters and special escaped characters follow the lexical conventions of OCaml). - [f], [e], [E], [g], [G]: reads an optionally signed floating-point number in decimal notation, in the style [dddd.ddd e/E+-dd]. - [F]: reads a floating point number according to the lexical conventions of OCaml (hence the decimal point is mandatory if the exponent part is not mentioned). - [B]: reads a boolean argument ([true] or [false]). - [b]: reads a boolean argument (for backward compatibility; do not use in new programs). - [ld], [li], [lu], [lx], [lX], [lo]: reads an [int32] argument to the format specified by the second letter for regular integers. - [nd], [ni], [nu], [nx], [nX], [no]: reads a [nativeint] argument to the format specified by the second letter for regular integers. - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: reads an [int64] argument to the format specified by the second letter for regular integers. - [\[ range \]]: reads characters that matches one of the characters mentioned in the range of characters [range] (or not mentioned in it, if the range starts with [^]). Reads a [string] that can be empty, if the next input character does not match the range. The set of characters from [c1] to [c2] (inclusively) is denoted by [c1-c2]. Hence, [%\[0-9\]] returns a string representing a decimal number or an empty string if no decimal digit is found; similarly, [%\[\\048-\\057\\065-\\070\]] returns a string of hexadecimal digits. If a closing bracket appears in a range, it must occur as the first character of the range (or just after the [^] in case of range negation); hence [\[\]\]] matches a [\]] character and [\[^\]\]] matches any character that is not [\]]. Use [%%] and [%\@] to include a [%] or a [\@] in a range. - [r]: user-defined reader. Takes the next [ri] formatted input function and applies it to the scanning buffer [ib] to read the next argument. The input function [ri] must therefore have type [Scanning.in_channel -> 'a] and the argument read has type ['a]. - [\{ fmt %\}]: reads a format string argument. The format string read must have the same type as the format string specification [fmt]. For instance, ["%{ %i %}"] reads any format string that can read a value of type [int]; hence, if [s] is the string ["fmt:\"number is %u\""], then [Scanf.sscanf s "fmt: %{%i%}"] succeeds and returns the format string ["number is %u"]. - [\( fmt %\)]: scanning format substitution. Reads a format string and then goes on scanning with the format string read, instead of using [fmt]. The format string read must have the same type as the format string specification [fmt] that it replaces. For instance, ["%( %i %)"] reads any format string that can read a value of type [int]. Returns the format string read, and the value read using the format string read. Hence, if [s] is the string ["\"%4d\"1234.00"], then [Scanf.sscanf s "%(%i%)" (fun fmt i -> fmt, i)] evaluates to [("%4d", 1234)]. If the special flag [_] is used, the conversion discards the format string read and only returns the value read with the format string read. Hence, if [s] is the string ["\"%4d\"1234.00"], then [Scanf.sscanf s "%_(%i%)"] is simply equivalent to [Scanf.sscanf "1234.00" "%4d"]. - [l]: returns the number of lines read so far. - [n]: returns the number of characters read so far. - [N] or [L]: returns the number of tokens read so far. - [!]: matches the end of input condition. - [%]: matches one [%] character in the input. - [\@]: matches one [\@] character in the input. - [,]: does nothing. Following the [%] character that introduces a conversion, there may be the special flag [_]: the conversion that follows occurs as usual, but the resulting value is discarded. For instance, if [f] is the function [fun i -> i + 1], and [s] is the string ["x = 1"], then [Scanf.sscanf s "%_s = %i" f] returns [2]. The field width is composed of an optional integer literal indicating the maximal width of the token to read. For instance, [%6d] reads an integer, having at most 6 decimal digits; [%4f] reads a float with at most 4 characters; and [%8[\\000-\\255]] returns the next 8 characters (or all the characters still available, if fewer than 8 characters are available in the input). Notes: - as mentioned above, a [%s] conversion always succeeds, even if there is nothing to read in the input: in this case, it simply returns [""]. - in addition to the relevant digits, ['_'] characters may appear inside numbers (this is reminiscent to the usual OCaml lexical conventions). If stricter scanning is desired, use the range conversion facility instead of the number conversions. - the [scanf] facility is not intended for heavy duty lexical analysis and parsing. If it appears not expressive enough for your needs, several alternative exists: regular expressions (module [Str]), stream parsers, [ocamllex]-generated lexers, [ocamlyacc]-generated parsers. *) (** {7:indication Scanning indications in format strings} *) (** Scanning indications appear just after the string conversions [%s] and [%[ range ]] to delimit the end of the token. A scanning indication is introduced by a [\@] character, followed by some plain character [c]. It means that the string token should end just before the next matching [c] (which is skipped). If no [c] character is encountered, the string token spreads as much as possible. For instance, ["%s@\t"] reads a string up to the next tab character or to the end of input. If a [\@] character appears anywhere else in the format string, it is treated as a plain character. Note: - As usual in format strings, [%] characters must be escaped using [%%] and [%\@] is equivalent to [\@]; this rule still holds within range specifications and scanning indications. For instance, ["%s@%%"] reads a string up to the next [%] character. - The scanning indications introduce slight differences in the syntax of [Scanf] format strings, compared to those used for the [Printf] module. However, the scanning indications are similar to those used in the [Format] module; hence, when producing formatted text to be scanned by [!Scanf.bscanf], it is wise to use printing functions from the [Format] module (or, if you need to use functions from [Printf], banish or carefully double check the format strings that contain ['\@'] characters). *) (** {7 Exceptions during scanning} *) (** Scanners may raise the following exceptions when the input cannot be read according to the format string: - Raise [Scanf.Scan_failure] if the input does not match the format. - Raise [Failure] if a conversion to a number is not possible. - Raise [End_of_file] if the end of input is encountered while some more characters are needed to read the current conversion specification. - Raise [Invalid_argument] if the format string is invalid. Note: - as a consequence, scanning a [%s] conversion never raises exception [End_of_file]: if the end of input is reached the conversion succeeds and simply returns the characters read so far, or [""] if none were ever read. *) (** {6 Specialised formatted input functions} *) val fscanf : Pervasives.in_channel -> ('a, 'b, 'c, 'd) scanner;; (** Same as {!Scanf.bscanf}, but reads from the given regular input channel. Warning: since all formatted input functions operate from a {e formatted input channel}, be aware that each [fscanf] invocation will operate with a formatted input channel reading from the given channel. This extra level of bufferization can lead to a strange scanning behaviour if you use low level primitives on the channel (reading characters, seeking the reading position, and so on). As a consequence, never mix direct low level reading and high level scanning from the same regular input channel. *) val sscanf : string -> ('a, 'b, 'c, 'd) scanner;; (** Same as {!Scanf.bscanf}, but reads from the given string. *) val scanf : ('a, 'b, 'c, 'd) scanner;; (** Same as {!Scanf.bscanf}, but reads from the predefined formatted input channel {!Scanf.Scanning.stdin} that is connected to [Pervasives.stdin]. *) val kscanf : Scanning.in_channel -> (Scanning.in_channel -> exn -> 'd) -> ('a, 'b, 'c, 'd) scanner;; (** Same as {!Scanf.bscanf}, but takes an additional function argument [ef] that is called in case of error: if the scanning process or some conversion fails, the scanning function aborts and calls the error handling function [ef] with the formatted input channel and the exception that aborted the scanning process as arguments. *) (** {6 Reading format strings from input} *) val bscanf_format : Scanning.in_channel -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g;; (** [bscanf_format ic fmt f] reads a format string token from the formatted input channel [ic], according to the given format string [fmt], and applies [f] to the resulting format string value. Raise [Scan_failure] if the format string value read does not have the same type as [fmt]. @since 3.09.0 *) val sscanf_format : string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g;; (** Same as {!Scanf.bscanf_format}, but reads from the given string. @since 3.09.0 *) val format_from_string : string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6;; (** [format_from_string s fmt] converts a string argument to a format string, according to the given format string [fmt]. Raise [Scan_failure] if [s], considered as a format string, does not have the same type as [fmt]. @since 3.10.0 *) val unescaped : string -> string (** Return a copy of the argument with escape sequences, following the lexical conventions of OCaml, replaced by their corresponding special characters. If there is no escape sequence in the argument, still return a copy, contrary to String.escaped. @since 4.00.0 *) mingw-ocaml/ocaml/stdlib/pervasives.ml0000644000175000017500000003666512124403240017477 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* type 'a option = None | Some of 'a *) (* Exceptions *) external raise : exn -> 'a = "%raise" let failwith s = raise(Failure s) let invalid_arg s = raise(Invalid_argument s) exception Exit (* Comparisons *) external ( = ) : 'a -> 'a -> bool = "%equal" external ( <> ) : 'a -> 'a -> bool = "%notequal" external ( < ) : 'a -> 'a -> bool = "%lessthan" external ( > ) : 'a -> 'a -> bool = "%greaterthan" external ( <= ) : 'a -> 'a -> bool = "%lessequal" external ( >= ) : 'a -> 'a -> bool = "%greaterequal" external compare : 'a -> 'a -> int = "%compare" let min x y = if x <= y then x else y let max x y = if x >= y then x else y external ( == ) : 'a -> 'a -> bool = "%eq" external ( != ) : 'a -> 'a -> bool = "%noteq" (* Boolean operations *) external not : bool -> bool = "%boolnot" external ( & ) : bool -> bool -> bool = "%sequand" external ( && ) : bool -> bool -> bool = "%sequand" external ( or ) : bool -> bool -> bool = "%sequor" external ( || ) : bool -> bool -> bool = "%sequor" (* Integer operations *) external ( ~- ) : int -> int = "%negint" external ( ~+ ) : int -> int = "%identity" external succ : int -> int = "%succint" external pred : int -> int = "%predint" external ( + ) : int -> int -> int = "%addint" external ( - ) : int -> int -> int = "%subint" external ( * ) : int -> int -> int = "%mulint" external ( / ) : int -> int -> int = "%divint" external ( mod ) : int -> int -> int = "%modint" let abs x = if x >= 0 then x else -x external ( land ) : int -> int -> int = "%andint" external ( lor ) : int -> int -> int = "%orint" external ( lxor ) : int -> int -> int = "%xorint" let lnot x = x lxor (-1) external ( lsl ) : int -> int -> int = "%lslint" external ( lsr ) : int -> int -> int = "%lsrint" external ( asr ) : int -> int -> int = "%asrint" let min_int = 1 lsl (if 1 lsl 31 = 0 then 30 else 62) let max_int = min_int - 1 (* Floating-point operations *) external ( ~-. ) : float -> float = "%negfloat" external ( ~+. ) : float -> float = "%identity" external ( +. ) : float -> float -> float = "%addfloat" external ( -. ) : float -> float -> float = "%subfloat" external ( *. ) : float -> float -> float = "%mulfloat" external ( /. ) : float -> float -> float = "%divfloat" external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float" external exp : float -> float = "caml_exp_float" "exp" "float" external expm1 : float -> float = "caml_expm1_float" "caml_expm1" "float" external acos : float -> float = "caml_acos_float" "acos" "float" external asin : float -> float = "caml_asin_float" "asin" "float" external atan : float -> float = "caml_atan_float" "atan" "float" external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float" external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot" "float" external cos : float -> float = "caml_cos_float" "cos" "float" external cosh : float -> float = "caml_cosh_float" "cosh" "float" external log : float -> float = "caml_log_float" "log" "float" external log10 : float -> float = "caml_log10_float" "log10" "float" external log1p : float -> float = "caml_log1p_float" "caml_log1p" "float" external sin : float -> float = "caml_sin_float" "sin" "float" external sinh : float -> float = "caml_sinh_float" "sinh" "float" external sqrt : float -> float = "caml_sqrt_float" "sqrt" "float" external tan : float -> float = "caml_tan_float" "tan" "float" external tanh : float -> float = "caml_tanh_float" "tanh" "float" external ceil : float -> float = "caml_ceil_float" "ceil" "float" external floor : float -> float = "caml_floor_float" "floor" "float" external abs_float : float -> float = "%absfloat" external copysign : float -> float -> float = "caml_copysign_float" "caml_copysign" "float" external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float" external frexp : float -> float * int = "caml_frexp_float" external ldexp : float -> int -> float = "caml_ldexp_float" external modf : float -> float * float = "caml_modf_float" external float : int -> float = "%floatofint" external float_of_int : int -> float = "%floatofint" external truncate : float -> int = "%intoffloat" external int_of_float : float -> int = "%intoffloat" external float_of_bits : int64 -> float = "caml_int64_float_of_bits" let infinity = float_of_bits 0x7F_F0_00_00_00_00_00_00L let neg_infinity = float_of_bits 0xFF_F0_00_00_00_00_00_00L let nan = float_of_bits 0x7F_F0_00_00_00_00_00_01L let max_float = float_of_bits 0x7F_EF_FF_FF_FF_FF_FF_FFL let min_float = float_of_bits 0x00_10_00_00_00_00_00_00L let epsilon_float = float_of_bits 0x3C_B0_00_00_00_00_00_00L type fpclass = FP_normal | FP_subnormal | FP_zero | FP_infinite | FP_nan external classify_float : float -> fpclass = "caml_classify_float" (* String operations -- more in module String *) external string_length : string -> int = "%string_length" external string_create : int -> string = "caml_create_string" external string_blit : string -> int -> string -> int -> int -> unit = "caml_blit_string" "noalloc" let ( ^ ) s1 s2 = let l1 = string_length s1 and l2 = string_length s2 in let s = string_create (l1 + l2) in string_blit s1 0 s 0 l1; string_blit s2 0 s l1 l2; s (* Character operations -- more in module Char *) external int_of_char : char -> int = "%identity" external unsafe_char_of_int : int -> char = "%identity" let char_of_int n = if n < 0 || n > 255 then invalid_arg "char_of_int" else unsafe_char_of_int n (* Unit operations *) external ignore : 'a -> unit = "%ignore" (* Pair operations *) external fst : 'a * 'b -> 'a = "%field0" external snd : 'a * 'b -> 'b = "%field1" (* String conversion functions *) external format_int : string -> int -> string = "caml_format_int" external format_float : string -> float -> string = "caml_format_float" let string_of_bool b = if b then "true" else "false" let bool_of_string = function | "true" -> true | "false" -> false | _ -> invalid_arg "bool_of_string" let string_of_int n = format_int "%d" n external int_of_string : string -> int = "caml_int_of_string" module String = struct external get : string -> int -> char = "%string_safe_get" end let valid_float_lexem s = let l = string_length s in let rec loop i = if i >= l then s ^ "." else match s.[i] with | '0' .. '9' | '-' -> loop (i + 1) | _ -> s in loop 0 ;; let string_of_float f = valid_float_lexem (format_float "%.12g" f);; external float_of_string : string -> float = "caml_float_of_string" (* List operations -- more in module List *) let rec ( @ ) l1 l2 = match l1 with [] -> l2 | hd :: tl -> hd :: (tl @ l2) (* I/O operations *) type in_channel type out_channel external open_descriptor_out : int -> out_channel = "caml_ml_open_descriptor_out" external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in" let stdin = open_descriptor_in 0 let stdout = open_descriptor_out 1 let stderr = open_descriptor_out 2 (* General output functions *) type open_flag = Open_rdonly | Open_wronly | Open_append | Open_creat | Open_trunc | Open_excl | Open_binary | Open_text | Open_nonblock external open_desc : string -> open_flag list -> int -> int = "caml_sys_open" let open_out_gen mode perm name = open_descriptor_out(open_desc name mode perm) let open_out name = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name let open_out_bin name = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name external flush : out_channel -> unit = "caml_ml_flush" external out_channels_list : unit -> out_channel list = "caml_ml_out_channels_list" let flush_all () = let rec iter = function [] -> () | a :: l -> (try flush a with _ -> ()); iter l in iter (out_channels_list ()) external unsafe_output : out_channel -> string -> int -> int -> unit = "caml_ml_output" external output_char : out_channel -> char -> unit = "caml_ml_output_char" let output_string oc s = unsafe_output oc s 0 (string_length s) let output oc s ofs len = if ofs < 0 || len < 0 || ofs > string_length s - len then invalid_arg "output" else unsafe_output oc s ofs len external output_byte : out_channel -> int -> unit = "caml_ml_output_char" external output_binary_int : out_channel -> int -> unit = "caml_ml_output_int" external marshal_to_channel : out_channel -> 'a -> unit list -> unit = "caml_output_value" let output_value chan v = marshal_to_channel chan v [] external seek_out : out_channel -> int -> unit = "caml_ml_seek_out" external pos_out : out_channel -> int = "caml_ml_pos_out" external out_channel_length : out_channel -> int = "caml_ml_channel_size" external close_out_channel : out_channel -> unit = "caml_ml_close_channel" let close_out oc = flush oc; close_out_channel oc let close_out_noerr oc = (try flush oc with _ -> ()); (try close_out_channel oc with _ -> ()) external set_binary_mode_out : out_channel -> bool -> unit = "caml_ml_set_binary_mode" (* General input functions *) let open_in_gen mode perm name = open_descriptor_in(open_desc name mode perm) let open_in name = open_in_gen [Open_rdonly; Open_text] 0 name let open_in_bin name = open_in_gen [Open_rdonly; Open_binary] 0 name external input_char : in_channel -> char = "caml_ml_input_char" external unsafe_input : in_channel -> string -> int -> int -> int = "caml_ml_input" let input ic s ofs len = if ofs < 0 || len < 0 || ofs > string_length s - len then invalid_arg "input" else unsafe_input ic s ofs len let rec unsafe_really_input ic s ofs len = if len <= 0 then () else begin let r = unsafe_input ic s ofs len in if r = 0 then raise End_of_file else unsafe_really_input ic s (ofs + r) (len - r) end let really_input ic s ofs len = if ofs < 0 || len < 0 || ofs > string_length s - len then invalid_arg "really_input" else unsafe_really_input ic s ofs len external input_scan_line : in_channel -> int = "caml_ml_input_scan_line" let input_line chan = let rec build_result buf pos = function [] -> buf | hd :: tl -> let len = string_length hd in string_blit hd 0 buf (pos - len) len; build_result buf (pos - len) tl in let rec scan accu len = let n = input_scan_line chan in if n = 0 then begin (* n = 0: we are at EOF *) match accu with [] -> raise End_of_file | _ -> build_result (string_create len) len accu end else if n > 0 then begin (* n > 0: newline found in buffer *) let res = string_create (n - 1) in ignore (unsafe_input chan res 0 (n - 1)); ignore (input_char chan); (* skip the newline *) match accu with [] -> res | _ -> let len = len + n - 1 in build_result (string_create len) len (res :: accu) end else begin (* n < 0: newline not found *) let beg = string_create (-n) in ignore(unsafe_input chan beg 0 (-n)); scan (beg :: accu) (len - n) end in scan [] 0 external input_byte : in_channel -> int = "caml_ml_input_char" external input_binary_int : in_channel -> int = "caml_ml_input_int" external input_value : in_channel -> 'a = "caml_input_value" external seek_in : in_channel -> int -> unit = "caml_ml_seek_in" external pos_in : in_channel -> int = "caml_ml_pos_in" external in_channel_length : in_channel -> int = "caml_ml_channel_size" external close_in : in_channel -> unit = "caml_ml_close_channel" let close_in_noerr ic = (try close_in ic with _ -> ());; external set_binary_mode_in : in_channel -> bool -> unit = "caml_ml_set_binary_mode" (* Output functions on standard output *) let print_char c = output_char stdout c let print_string s = output_string stdout s let print_int i = output_string stdout (string_of_int i) let print_float f = output_string stdout (string_of_float f) let print_endline s = output_string stdout s; output_char stdout '\n'; flush stdout let print_newline () = output_char stdout '\n'; flush stdout (* Output functions on standard error *) let prerr_char c = output_char stderr c let prerr_string s = output_string stderr s let prerr_int i = output_string stderr (string_of_int i) let prerr_float f = output_string stderr (string_of_float f) let prerr_endline s = output_string stderr s; output_char stderr '\n'; flush stderr let prerr_newline () = output_char stderr '\n'; flush stderr (* Input functions on standard input *) let read_line () = flush stdout; input_line stdin let read_int () = int_of_string(read_line()) let read_float () = float_of_string(read_line()) (* Operations on large files *) module LargeFile = struct external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64" external pos_out : out_channel -> int64 = "caml_ml_pos_out_64" external out_channel_length : out_channel -> int64 = "caml_ml_channel_size_64" external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64" external pos_in : in_channel -> int64 = "caml_ml_pos_in_64" external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64" end (* References *) type 'a ref = { mutable contents : 'a } external ref : 'a -> 'a ref = "%makemutable" external ( ! ) : 'a ref -> 'a = "%field0" external ( := ) : 'a ref -> 'a -> unit = "%setfield0" external incr : int ref -> unit = "%incr" external decr : int ref -> unit = "%decr" (* Formats *) type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 external format_of_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" external format_to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity" external string_to_format : string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" let (( ^^ ) : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('f, 'b, 'c, 'e, 'g, 'h) format6 -> ('a, 'b, 'c, 'd, 'g, 'h) format6) = fun fmt1 fmt2 -> string_to_format (format_to_string fmt1 ^ "%," ^ format_to_string fmt2) ;; let string_of_format fmt = let s = format_to_string fmt in let l = string_length s in let r = string_create l in string_blit s 0 r 0 l; r (* Miscellaneous *) external sys_exit : int -> 'a = "caml_sys_exit" let exit_function = ref flush_all let at_exit f = let g = !exit_function in exit_function := (fun () -> f(); g()) let do_at_exit () = (!exit_function) () let exit retcode = do_at_exit (); sys_exit retcode external register_named_value : string -> 'a -> unit = "caml_register_named_value" let _ = register_named_value "Pervasives.do_at_exit" do_at_exit mingw-ocaml/ocaml/stdlib/camlinternalLazy.mli0000644000175000017500000000227112124403240020754 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Run-time support for lazy values. All functions in this module are for system use only, not for the casual user. *) exception Undefined;; val force_lazy_block : 'a lazy_t -> 'a ;; val force_val_lazy_block : 'a lazy_t -> 'a ;; val force : 'a lazy_t -> 'a ;; val force_val : 'a lazy_t -> 'a ;; mingw-ocaml/ocaml/stdlib/printexc.mli0000644000175000017500000000745312124403240017306 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Facilities for printing exceptions. *) val to_string: exn -> string (** [Printexc.to_string e] returns a string representation of the exception [e]. *) val print: ('a -> 'b) -> 'a -> 'b (** [Printexc.print fn x] applies [fn] to [x] and returns the result. If the evaluation of [fn x] raises any exception, the name of the exception is printed on standard error output, and the exception is raised again. The typical use is to catch and report exceptions that escape a function application. *) val catch: ('a -> 'b) -> 'a -> 'b (** [Printexc.catch fn x] is similar to {!Printexc.print}, but aborts the program with exit code 2 after printing the uncaught exception. This function is deprecated: the runtime system is now able to print uncaught exceptions as precisely as [Printexc.catch] does. Moreover, calling [Printexc.catch] makes it harder to track the location of the exception using the debugger or the stack backtrace facility. So, do not use [Printexc.catch] in new code. *) val print_backtrace: out_channel -> unit (** [Printexc.print_backtrace oc] prints an exception backtrace on the output channel [oc]. The backtrace lists the program locations where the most-recently raised exception was raised and where it was propagated through function calls. @since 3.11.0 *) val get_backtrace: unit -> string (** [Printexc.get_backtrace ()] returns a string containing the same exception backtrace that [Printexc.print_backtrace] would print. @since 3.11.0 *) val record_backtrace: bool -> unit (** [Printexc.record_backtrace b] turns recording of exception backtraces on (if [b = true]) or off (if [b = false]). Initially, backtraces are not recorded, unless the [b] flag is given to the program through the [OCAMLRUNPARAM] variable. @since 3.11.0 *) val backtrace_status: unit -> bool (** [Printexc.backtrace_status()] returns [true] if exception backtraces are currently recorded, [false] if not. @since 3.11.0 *) val register_printer: (exn -> string option) -> unit (** [Printexc.register_printer fn] registers [fn] as an exception printer. The printer should return [None] or raise an exception if it does not know how to convert the passed exception, and [Some s] with [s] the resulting string if it can convert the passed exception. Exceptions raised by the printer are ignored. When converting an exception into a string, the printers will be invoked in the reverse order of their registrations, until a printer returns a [Some s] value (if no such printer exists, the runtime will use a generic printer). When using this mechanism, one should be aware that an exception backtrace is attached to the thread that saw it raised, rather than to the exception itself. Practically, it means that the code related to [fn] should not use the backtrace if it has itself raised an exception before. @since 3.11.2 *) mingw-ocaml/ocaml/stdlib/camlinternalMod.mli0000644000175000017500000000226712124403240020561 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2004 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Run-time support for recursive modules. All functions in this module are for system use only, not for the casual user. *) type shape = | Function | Lazy | Class | Module of shape array val init_mod: string * int * int -> shape -> Obj.t val update_mod: shape -> Obj.t -> Obj.t -> unit mingw-ocaml/ocaml/stdlib/moreLabels.mli0000644000175000017500000001412512124403240017531 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Extra labeled libraries. This meta-module provides labelized version of the {!Hashtbl}, {!Map} and {!Set} modules. They only differ by their labels. They are provided to help porting from previous versions of OCaml. The contents of this module are subject to change. *) module Hashtbl : sig type ('a, 'b) t = ('a, 'b) Hashtbl.t val create : ?random:bool -> int -> ('a, 'b) t val clear : ('a, 'b) t -> unit val reset : ('a, 'b) t -> unit val copy : ('a, 'b) t -> ('a, 'b) t val add : ('a, 'b) t -> key:'a -> data:'b -> unit val find : ('a, 'b) t -> 'a -> 'b val find_all : ('a, 'b) t -> 'a -> 'b list val mem : ('a, 'b) t -> 'a -> bool val remove : ('a, 'b) t -> 'a -> unit val replace : ('a, 'b) t -> key:'a -> data:'b -> unit val iter : f:(key:'a -> data:'b -> unit) -> ('a, 'b) t -> unit val fold : f:(key:'a -> data:'b -> 'c -> 'c) -> ('a, 'b) t -> init:'c -> 'c val length : ('a, 'b) t -> int val randomize : unit -> unit type statistics = Hashtbl.statistics val stats : ('a, 'b) t -> statistics module type HashedType = Hashtbl.HashedType module type SeededHashedType = Hashtbl.SeededHashedType module type S = sig type key and 'a t val create : int -> 'a t val clear : 'a t -> unit val reset : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key:key -> data:'a -> unit val remove : 'a t -> key -> unit val find : 'a t -> key -> 'a val find_all : 'a t -> key -> 'a list val replace : 'a t -> key:key -> data:'a -> unit val mem : 'a t -> key -> bool val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit val fold : f:(key:key -> data:'a -> 'b -> 'b) -> 'a t -> init:'b -> 'b val length : 'a t -> int val stats: 'a t -> statistics end module type SeededS = sig type key and 'a t val create : ?random:bool -> int -> 'a t val clear : 'a t -> unit val reset : 'a t -> unit val copy : 'a t -> 'a t val add : 'a t -> key:key -> data:'a -> unit val remove : 'a t -> key -> unit val find : 'a t -> key -> 'a val find_all : 'a t -> key -> 'a list val replace : 'a t -> key:key -> data:'a -> unit val mem : 'a t -> key -> bool val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit val fold : f:(key:key -> data:'a -> 'b -> 'b) -> 'a t -> init:'b -> 'b val length : 'a t -> int val stats: 'a t -> statistics end module Make : functor (H : HashedType) -> S with type key = H.t module MakeSeeded (H : SeededHashedType) : SeededS with type key = H.t val hash : 'a -> int val seeded_hash : int -> 'a -> int val hash_param : int -> int -> 'a -> int val seeded_hash_param : int -> int -> int -> 'a -> int end module Map : sig module type OrderedType = Map.OrderedType module type S = sig type key and (+'a) t val empty : 'a t val is_empty: 'a t -> bool val mem : key -> 'a t -> bool val add : key:key -> data:'a -> 'a t -> 'a t val singleton: key -> 'a -> 'a t val remove : key -> 'a t -> 'a t val merge: f:(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t val compare: cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: cmp:('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit val fold : f:(key:key -> data:'a -> 'b -> 'b) -> 'a t -> init:'b -> 'b val for_all: f:(key -> 'a -> bool) -> 'a t -> bool val exists: f:(key -> 'a -> bool) -> 'a t -> bool val filter: f:(key -> 'a -> bool) -> 'a t -> 'a t val partition: f:(key -> 'a -> bool) -> 'a t -> 'a t * 'a t val cardinal: 'a t -> int val bindings: 'a t -> (key * 'a) list val min_binding: 'a t -> (key * 'a) val max_binding: 'a t -> (key * 'a) val choose: 'a t -> (key * 'a) val split: key -> 'a t -> 'a t * 'a option * 'a t val find : key -> 'a t -> 'a val map : f:('a -> 'b) -> 'a t -> 'b t val mapi : f:(key -> 'a -> 'b) -> 'a t -> 'b t end module Make : functor (Ord : OrderedType) -> S with type key = Ord.t end module Set : sig module type OrderedType = Set.OrderedType module type S = sig type elt and t val empty : t val is_empty : t -> bool val mem : elt -> t -> bool val add : elt -> t -> t val singleton : elt -> t val remove : elt -> t -> 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 val subset : t -> t -> bool val iter : f:(elt -> unit) -> t -> unit val fold : f:(elt -> 'a -> 'a) -> t -> init:'a -> 'a val for_all : f:(elt -> bool) -> t -> bool val exists : f:(elt -> bool) -> t -> bool val filter : f:(elt -> bool) -> t -> t val partition : f:(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 split: elt -> t -> t * bool * t end module Make : functor (Ord : OrderedType) -> S with type elt = Ord.t end mingw-ocaml/ocaml/stdlib/sort.ml0000644000175000017500000000711212124403240016260 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Merging and sorting *) open Array let rec merge order l1 l2 = match l1 with [] -> l2 | h1 :: t1 -> match l2 with [] -> l1 | h2 :: t2 -> if order h1 h2 then h1 :: merge order t1 l2 else h2 :: merge order l1 t2 let list order l = let rec initlist = function [] -> [] | [e] -> [[e]] | e1::e2::rest -> (if order e1 e2 then [e1;e2] else [e2;e1]) :: initlist rest in let rec merge2 = function l1::l2::rest -> merge order l1 l2 :: merge2 rest | x -> x in let rec mergeall = function [] -> [] | [l] -> l | llist -> mergeall (merge2 llist) in mergeall(initlist l) let swap arr i j = let tmp = unsafe_get arr i in unsafe_set arr i (unsafe_get arr j); unsafe_set arr j tmp (* There is a known performance bug in the code below. If you find it, don't bother reporting it. You're not supposed to use this module anyway. *) let array cmp arr = let rec qsort lo hi = if hi - lo >= 6 then begin let mid = (lo + hi) lsr 1 in (* Select median value from among LO, MID, and HI. Rearrange LO and HI so the three values are sorted. This lowers the probability of picking a pathological pivot. It also avoids extra comparisons on i and j in the two tight "while" loops below. *) if cmp (unsafe_get arr mid) (unsafe_get arr lo) then swap arr mid lo; if cmp (unsafe_get arr hi) (unsafe_get arr mid) then begin swap arr mid hi; if cmp (unsafe_get arr mid) (unsafe_get arr lo) then swap arr mid lo end; let pivot = unsafe_get arr mid in let i = ref (lo + 1) and j = ref (hi - 1) in if not (cmp pivot (unsafe_get arr hi)) || not (cmp (unsafe_get arr lo) pivot) then raise (Invalid_argument "Sort.array"); while !i < !j do while not (cmp pivot (unsafe_get arr !i)) do incr i done; while not (cmp (unsafe_get arr !j) pivot) do decr j done; if !i < !j then swap arr !i !j; incr i; decr j done; (* Recursion on smaller half, tail-call on larger half *) if !j - lo <= hi - !i then begin qsort lo !j; qsort !i hi end else begin qsort !i hi; qsort lo !j end end in qsort 0 (Array.length arr - 1); (* Finish sorting by insertion sort *) for i = 1 to Array.length arr - 1 do let val_i = (unsafe_get arr i) in if not (cmp (unsafe_get arr (i - 1)) val_i) then begin unsafe_set arr i (unsafe_get arr (i - 1)); let j = ref (i - 1) in while !j >= 1 && not (cmp (unsafe_get arr (!j - 1)) val_i) do unsafe_set arr !j (unsafe_get arr (!j - 1)); decr j done; unsafe_set arr !j val_i end done mingw-ocaml/ocaml/stdlib/buffer.mli0000644000175000017500000001223612124403240016716 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Extensible string buffers. This module implements string buffers that automatically expand as necessary. It provides accumulative concatenation of strings in quasi-linear time (instead of quadratic time when strings are concatenated pairwise). *) type t (** The abstract type of buffers. *) val create : int -> t (** [create n] returns a fresh buffer, initially empty. The [n] parameter is the initial size of the internal string that holds the buffer contents. That string is automatically reallocated when more than [n] characters are stored in the buffer, but shrinks back to [n] characters when [reset] is called. For best performance, [n] should be of the same order of magnitude as the number of characters that are expected to be stored in the buffer (for instance, 80 for a buffer that holds one output line). Nothing bad will happen if the buffer grows beyond that limit, however. In doubt, take [n = 16] for instance. If [n] is not between 1 and {!Sys.max_string_length}, it will be clipped to that interval. *) val contents : t -> string (** Return a copy of the current contents of the buffer. The buffer itself is unchanged. *) val sub : t -> int -> int -> string (** [Buffer.sub b off len] returns (a copy of) the substring of the current contents of the buffer [b] starting at offset [off] of length [len] bytes. May raise [Invalid_argument] if out of bounds request. The buffer itself is unaffected. *) val blit : t -> int -> string -> int -> int -> unit (** [Buffer.blit src srcoff dst dstoff len] copies [len] characters from the current contents of the buffer [src], starting at offset [srcoff] to string [dst], starting at character [dstoff]. Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid substring of [src], or if [dstoff] and [len] do not designate a valid substring of [dst]. @since 3.11.2 *) val nth : t -> int -> char (** get the n-th character of the buffer. Raise [Invalid_argument] if index out of bounds *) val length : t -> int (** Return the number of characters currently contained in the buffer. *) val clear : t -> unit (** Empty the buffer. *) val reset : t -> unit (** Empty the buffer and deallocate the internal string holding the buffer contents, replacing it with the initial internal string of length [n] that was allocated by {!Buffer.create} [n]. For long-lived buffers that may have grown a lot, [reset] allows faster reclamation of the space used by the buffer. *) val add_char : t -> char -> unit (** [add_char b c] appends the character [c] at the end of the buffer [b]. *) val add_string : t -> string -> unit (** [add_string b s] appends the string [s] at the end of the buffer [b]. *) val add_substring : t -> string -> int -> int -> unit (** [add_substring b s ofs len] takes [len] characters from offset [ofs] in string [s] and appends them at the end of the buffer [b]. *) val add_substitute : t -> (string -> string) -> string -> unit (** [add_substitute b f s] appends the string pattern [s] at the end of the buffer [b] with substitution. The substitution process looks for variables into the pattern and substitutes each variable name by its value, as obtained by applying the mapping [f] to the variable name. Inside the string pattern, a variable name immediately follows a non-escaped [$] character and is one of the following: - a non empty sequence of alphanumeric or [_] characters, - an arbitrary sequence of characters enclosed by a pair of matching parentheses or curly brackets. An escaped [$] character is a [$] that immediately follows a backslash character; it then stands for a plain [$]. Raise [Not_found] if the closing character of a parenthesized variable cannot be found. *) val add_buffer : t -> t -> unit (** [add_buffer b1 b2] appends the current contents of buffer [b2] at the end of buffer [b1]. [b2] is not modified. *) val add_channel : t -> in_channel -> int -> unit (** [add_channel b ic n] reads exactly [n] character from the input channel [ic] and stores them at the end of buffer [b]. Raise [End_of_file] if the channel contains fewer than [n] characters. *) val output_buffer : out_channel -> t -> unit (** [output_buffer oc b] writes the current contents of buffer [b] on the output channel [oc]. *) mingw-ocaml/ocaml/stdlib/pervasives.mli0000644000175000017500000010706612124403240017642 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** The initially opened module. This module provides the basic operations over the built-in types (numbers, booleans, strings, exceptions, references, lists, arrays, input-output channels, ...). This module is automatically opened at the beginning of each compilation. All components of this module can therefore be referred by their short name, without prefixing them by [Pervasives]. *) (** {6 Exceptions} *) external raise : exn -> 'a = "%raise" (** Raise the given exception value *) val invalid_arg : string -> 'a (** Raise exception [Invalid_argument] with the given string. *) val failwith : string -> 'a (** Raise exception [Failure] with the given string. *) exception Exit (** The [Exit] exception is not raised by any library function. It is provided for use in your programs.*) (** {6 Comparisons} *) external ( = ) : 'a -> 'a -> bool = "%equal" (** [e1 = e2] tests for structural equality of [e1] and [e2]. Mutable structures (e.g. references and arrays) are equal if and only if their current contents are structurally equal, even if the two mutable objects are not the same physical object. Equality between functional values raises [Invalid_argument]. Equality between cyclic data structures may not terminate. *) external ( <> ) : 'a -> 'a -> bool = "%notequal" (** Negation of {!Pervasives.( = )}. *) external ( < ) : 'a -> 'a -> bool = "%lessthan" (** See {!Pervasives.( >= )}. *) external ( > ) : 'a -> 'a -> bool = "%greaterthan" (** See {!Pervasives.( >= )}. *) external ( <= ) : 'a -> 'a -> bool = "%lessequal" (** See {!Pervasives.( >= )}. *) external ( >= ) : 'a -> 'a -> bool = "%greaterequal" (** Structural ordering functions. These functions coincide with the usual orderings over integers, characters, strings and floating-point numbers, and extend them to a total ordering over all types. The ordering is compatible with [( = )]. As in the case of [( = )], mutable structures are compared by contents. Comparison between functional values raises [Invalid_argument]. Comparison between cyclic structures may not terminate. *) external compare : 'a -> 'a -> int = "%compare" (** [compare x y] returns [0] if [x] is equal to [y], a negative integer if [x] is less than [y], and a positive integer if [x] is greater than [y]. The ordering implemented by [compare] is compatible with the comparison predicates [=], [<] and [>] defined above, with one difference on the treatment of the float value {!Pervasives.nan}. Namely, the comparison predicates treat [nan] as different from any other float value, including itself; while [compare] treats [nan] as equal to itself and less than any other float value. This treatment of [nan] ensures that [compare] defines a total ordering relation. [compare] applied to functional values may raise [Invalid_argument]. [compare] applied to cyclic structures may not terminate. The [compare] function can be used as the comparison function required by the {!Set.Make} and {!Map.Make} functors, as well as the {!List.sort} and {!Array.sort} functions. *) val min : 'a -> 'a -> 'a (** Return the smaller of the two arguments. The result is unspecified if one of the arguments contains the float value [nan]. *) val max : 'a -> 'a -> 'a (** Return the greater of the two arguments. The result is unspecified if one of the arguments contains the float value [nan]. *) external ( == ) : 'a -> 'a -> bool = "%eq" (** [e1 == e2] tests for physical equality of [e1] and [e2]. On mutable types such as references, arrays, strings, records with mutable fields and objects with mutable instance variables, [e1 == e2] is true if and only if physical modification of [e1] also affects [e2]. On non-mutable types, the behavior of [( == )] is implementation-dependent; however, it is guaranteed that [e1 == e2] implies [compare e1 e2 = 0]. *) external ( != ) : 'a -> 'a -> bool = "%noteq" (** Negation of {!Pervasives.( == )}. *) (** {6 Boolean operations} *) external not : bool -> bool = "%boolnot" (** The boolean negation. *) external ( && ) : bool -> bool -> bool = "%sequand" (** The boolean ``and''. Evaluation is sequential, left-to-right: in [e1 && e2], [e1] is evaluated first, and if it returns [false], [e2] is not evaluated at all. *) external ( & ) : bool -> bool -> bool = "%sequand" (** @deprecated {!Pervasives.( && )} should be used instead. *) external ( || ) : bool -> bool -> bool = "%sequor" (** The boolean ``or''. Evaluation is sequential, left-to-right: in [e1 || e2], [e1] is evaluated first, and if it returns [true], [e2] is not evaluated at all. *) external ( or ) : bool -> bool -> bool = "%sequor" (** @deprecated {!Pervasives.( || )} should be used instead.*) (** {6 Integer arithmetic} *) (** Integers are 31 bits wide (or 63 bits on 64-bit processors). All operations are taken modulo 2{^31} (or 2{^63}). They do not fail on overflow. *) external ( ~- ) : int -> int = "%negint" (** Unary negation. You can also write [- e] instead of [~- e]. *) external ( ~+ ) : int -> int = "%identity" (** Unary addition. You can also write [+ e] instead of [~+ e]. @since 3.12.0 *) external succ : int -> int = "%succint" (** [succ x] is [x + 1]. *) external pred : int -> int = "%predint" (** [pred x] is [x - 1]. *) external ( + ) : int -> int -> int = "%addint" (** Integer addition. *) external ( - ) : int -> int -> int = "%subint" (** Integer subtraction. *) external ( * ) : int -> int -> int = "%mulint" (** Integer multiplication. *) external ( / ) : int -> int -> int = "%divint" (** Integer division. Raise [Division_by_zero] if the second argument is 0. Integer division rounds the real quotient of its arguments towards zero. More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer less than or equal to the real quotient of [x] by [y]. Moreover, [(- x) / y = x / (- y) = - (x / y)]. *) external ( mod ) : int -> int -> int = "%modint" (** Integer remainder. If [y] is not zero, the result of [x mod y] satisfies the following properties: [x = (x / y) * y + x mod y] and [abs(x mod y) <= abs(y) - 1]. If [y = 0], [x mod y] raises [Division_by_zero]. Note that [x mod y] is negative only if [x < 0]. Raise [Division_by_zero] if [y] is zero. *) val abs : int -> int (** Return the absolute value of the argument. Note that this may be negative if the argument is [min_int]. *) val max_int : int (** The greatest representable integer. *) val min_int : int (** The smallest representable integer. *) (** {7 Bitwise operations} *) external ( land ) : int -> int -> int = "%andint" (** Bitwise logical and. *) external ( lor ) : int -> int -> int = "%orint" (** Bitwise logical or. *) external ( lxor ) : int -> int -> int = "%xorint" (** Bitwise logical exclusive or. *) val lnot : int -> int (** Bitwise logical negation. *) external ( lsl ) : int -> int -> int = "%lslint" (** [n lsl m] shifts [n] to the left by [m] bits. The result is unspecified if [m < 0] or [m >= bitsize], where [bitsize] is [32] on a 32-bit platform and [64] on a 64-bit platform. *) external ( lsr ) : int -> int -> int = "%lsrint" (** [n lsr m] shifts [n] to the right by [m] bits. This is a logical shift: zeroes are inserted regardless of the sign of [n]. The result is unspecified if [m < 0] or [m >= bitsize]. *) external ( asr ) : int -> int -> int = "%asrint" (** [n asr m] shifts [n] to the right by [m] bits. This is an arithmetic shift: the sign bit of [n] is replicated. The result is unspecified if [m < 0] or [m >= bitsize]. *) (** {6 Floating-point arithmetic} OCaml's floating-point numbers follow the IEEE 754 standard, using double precision (64 bits) numbers. Floating-point operations never raise an exception on overflow, underflow, division by zero, etc. Instead, special IEEE numbers are returned as appropriate, such as [infinity] for [1.0 /. 0.0], [neg_infinity] for [-1.0 /. 0.0], and [nan] (``not a number'') for [0.0 /. 0.0]. These special numbers then propagate through floating-point computations as expected: for instance, [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan] as argument returns [nan] as result. *) external ( ~-. ) : float -> float = "%negfloat" (** Unary negation. You can also write [-. e] instead of [~-. e]. *) external ( ~+. ) : float -> float = "%identity" (** Unary addition. You can also write [+. e] instead of [~+. e]. @since 3.12.0 *) external ( +. ) : float -> float -> float = "%addfloat" (** Floating-point addition *) external ( -. ) : float -> float -> float = "%subfloat" (** Floating-point subtraction *) external ( *. ) : float -> float -> float = "%mulfloat" (** Floating-point multiplication *) external ( /. ) : float -> float -> float = "%divfloat" (** Floating-point division. *) external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float" (** Exponentiation. *) external sqrt : float -> float = "caml_sqrt_float" "sqrt" "float" (** Square root. *) external exp : float -> float = "caml_exp_float" "exp" "float" (** Exponential. *) external log : float -> float = "caml_log_float" "log" "float" (** Natural logarithm. *) external log10 : float -> float = "caml_log10_float" "log10" "float" (** Base 10 logarithm. *) external expm1 : float -> float = "caml_expm1_float" "caml_expm1" "float" (** [expm1 x] computes [exp x -. 1.0], giving numerically-accurate results even if [x] is close to [0.0]. @since 3.12.0 *) external log1p : float -> float = "caml_log1p_float" "caml_log1p" "float" (** [log1p x] computes [log(1.0 +. x)] (natural logarithm), giving numerically-accurate results even if [x] is close to [0.0]. @since 3.12.0 *) external cos : float -> float = "caml_cos_float" "cos" "float" (** Cosine. Argument is in radians. *) external sin : float -> float = "caml_sin_float" "sin" "float" (** Sine. Argument is in radians. *) external tan : float -> float = "caml_tan_float" "tan" "float" (** Tangent. Argument is in radians. *) external acos : float -> float = "caml_acos_float" "acos" "float" (** Arc cosine. The argument must fall within the range [[-1.0, 1.0]]. Result is in radians and is between [0.0] and [pi]. *) external asin : float -> float = "caml_asin_float" "asin" "float" (** Arc sine. The argument must fall within the range [[-1.0, 1.0]]. Result is in radians and is between [-pi/2] and [pi/2]. *) external atan : float -> float = "caml_atan_float" "atan" "float" (** Arc tangent. Result is in radians and is between [-pi/2] and [pi/2]. *) external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float" (** [atan2 y x] returns the arc tangent of [y /. x]. The signs of [x] and [y] are used to determine the quadrant of the result. Result is in radians and is between [-pi] and [pi]. *) external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot" "float" (** [hypot x y] returns [sqrt(x *. x + y *. y)], that is, the length of the hypotenuse of a right-angled triangle with sides of length [x] and [y], or, equivalently, the distance of the point [(x,y)] to origin. @since 4.00.0 *) external cosh : float -> float = "caml_cosh_float" "cosh" "float" (** Hyperbolic cosine. Argument is in radians. *) external sinh : float -> float = "caml_sinh_float" "sinh" "float" (** Hyperbolic sine. Argument is in radians. *) external tanh : float -> float = "caml_tanh_float" "tanh" "float" (** Hyperbolic tangent. Argument is in radians. *) external ceil : float -> float = "caml_ceil_float" "ceil" "float" (** Round above to an integer value. [ceil f] returns the least integer value greater than or equal to [f]. The result is returned as a float. *) external floor : float -> float = "caml_floor_float" "floor" "float" (** Round below to an integer value. [floor f] returns the greatest integer value less than or equal to [f]. The result is returned as a float. *) external abs_float : float -> float = "%absfloat" (** [abs_float f] returns the absolute value of [f]. *) external copysign : float -> float -> float = "caml_copysign_float" "caml_copysign" "float" (** [copysign x y] returns a float whose absolute value is that of [x] and whose sign is that of [y]. If [x] is [nan], returns [nan]. If [y] is [nan], returns either [x] or [-. x], but it is not specified which. @since 4.00.0 *) external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float" (** [mod_float a b] returns the remainder of [a] with respect to [b]. The returned value is [a -. n *. b], where [n] is the quotient [a /. b] rounded towards zero to an integer. *) external frexp : float -> float * int = "caml_frexp_float" (** [frexp f] returns the pair of the significant and the exponent of [f]. When [f] is zero, the significant [x] and the exponent [n] of [f] are equal to zero. When [f] is non-zero, they are defined by [f = x *. 2 ** n] and [0.5 <= x < 1.0]. *) external ldexp : float -> int -> float = "caml_ldexp_float" (** [ldexp x n] returns [x *. 2 ** n]. *) external modf : float -> float * float = "caml_modf_float" (** [modf f] returns the pair of the fractional and integral part of [f]. *) external float : int -> float = "%floatofint" (** Same as {!Pervasives.float_of_int}. *) external float_of_int : int -> float = "%floatofint" (** Convert an integer to floating-point. *) external truncate : float -> int = "%intoffloat" (** Same as {!Pervasives.int_of_float}. *) external int_of_float : float -> int = "%intoffloat" (** Truncate the given floating-point number to an integer. The result is unspecified if the argument is [nan] or falls outside the range of representable integers. *) val infinity : float (** Positive infinity. *) val neg_infinity : float (** Negative infinity. *) val nan : float (** A special floating-point value denoting the result of an undefined operation such as [0.0 /. 0.0]. Stands for ``not a number''. Any floating-point operation with [nan] as argument returns [nan] as result. As for floating-point comparisons, [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true] if one or both of their arguments is [nan]. *) val max_float : float (** The largest positive finite value of type [float]. *) val min_float : float (** The smallest positive, non-zero, non-denormalized value of type [float]. *) val epsilon_float : float (** The difference between [1.0] and the smallest exactly representable floating-point number greater than [1.0]. *) type fpclass = FP_normal (** Normal number, none of the below *) | FP_subnormal (** Number very close to 0.0, has reduced precision *) | FP_zero (** Number is 0.0 or -0.0 *) | FP_infinite (** Number is positive or negative infinity *) | FP_nan (** Not a number: result of an undefined operation *) (** The five classes of floating-point numbers, as determined by the {!Pervasives.classify_float} function. *) external classify_float : float -> fpclass = "caml_classify_float" (** Return the class of the given floating-point number: normal, subnormal, zero, infinite, or not a number. *) (** {6 String operations} More string operations are provided in module {!String}. *) val ( ^ ) : string -> string -> string (** String concatenation. *) (** {6 Character operations} More character operations are provided in module {!Char}. *) external int_of_char : char -> int = "%identity" (** Return the ASCII code of the argument. *) val char_of_int : int -> char (** Return the character with the given ASCII code. Raise [Invalid_argument "char_of_int"] if the argument is outside the range 0--255. *) (** {6 Unit operations} *) external ignore : 'a -> unit = "%ignore" (** Discard the value of its argument and return [()]. For instance, [ignore(f x)] discards the result of the side-effecting function [f]. It is equivalent to [f x; ()], except that the latter may generate a compiler warning; writing [ignore(f x)] instead avoids the warning. *) (** {6 String conversion functions} *) val string_of_bool : bool -> string (** Return the string representation of a boolean. As the returned values may be shared, the user should not modify them directly. *) val bool_of_string : string -> bool (** Convert the given string to a boolean. Raise [Invalid_argument "bool_of_string"] if the string is not ["true"] or ["false"]. *) val string_of_int : int -> string (** Return the string representation of an integer, in decimal. *) external int_of_string : string -> int = "caml_int_of_string" (** Convert the given string to an integer. The string is read in decimal (by default) or in hexadecimal (if it begins with [0x] or [0X]), octal (if it begins with [0o] or [0O]), or binary (if it begins with [0b] or [0B]). Raise [Failure "int_of_string"] if the given string is not a valid representation of an integer, or if the integer represented exceeds the range of integers representable in type [int]. *) val string_of_float : float -> string (** Return the string representation of a floating-point number. *) external float_of_string : string -> float = "caml_float_of_string" (** Convert the given string to a float. Raise [Failure "float_of_string"] if the given string is not a valid representation of a float. *) (** {6 Pair operations} *) external fst : 'a * 'b -> 'a = "%field0" (** Return the first component of a pair. *) external snd : 'a * 'b -> 'b = "%field1" (** Return the second component of a pair. *) (** {6 List operations} More list operations are provided in module {!List}. *) val ( @ ) : 'a list -> 'a list -> 'a list (** List concatenation. *) (** {6 Input/output} Note: all input/output functions can raise [Sys_error] when the system calls they invoke fail. *) type in_channel (** The type of input channel. *) type out_channel (** The type of output channel. *) val stdin : in_channel (** The standard input for the process. *) val stdout : out_channel (** The standard output for the process. *) val stderr : out_channel (** The standard error output for the process. *) (** {7 Output functions on standard output} *) val print_char : char -> unit (** Print a character on standard output. *) val print_string : string -> unit (** Print a string on standard output. *) val print_int : int -> unit (** Print an integer, in decimal, on standard output. *) val print_float : float -> unit (** Print a floating-point number, in decimal, on standard output. *) val print_endline : string -> unit (** Print a string, followed by a newline character, on standard output and flush standard output. *) val print_newline : unit -> unit (** Print a newline character on standard output, and flush standard output. This can be used to simulate line buffering of standard output. *) (** {7 Output functions on standard error} *) val prerr_char : char -> unit (** Print a character on standard error. *) val prerr_string : string -> unit (** Print a string on standard error. *) val prerr_int : int -> unit (** Print an integer, in decimal, on standard error. *) val prerr_float : float -> unit (** Print a floating-point number, in decimal, on standard error. *) val prerr_endline : string -> unit (** Print a string, followed by a newline character on standard error and flush standard error. *) val prerr_newline : unit -> unit (** Print a newline character on standard error, and flush standard error. *) (** {7 Input functions on standard input} *) val read_line : unit -> string (** Flush standard output, then read characters from standard input until a newline character is encountered. Return the string of all characters read, without the newline character at the end. *) val read_int : unit -> int (** Flush standard output, then read one line from standard input and convert it to an integer. Raise [Failure "int_of_string"] if the line read is not a valid representation of an integer. *) val read_float : unit -> float (** Flush standard output, then read one line from standard input and convert it to a floating-point number. The result is unspecified if the line read is not a valid representation of a floating-point number. *) (** {7 General output functions} *) type open_flag = Open_rdonly (** open for reading. *) | Open_wronly (** open for writing. *) | Open_append (** open for appending: always write at end of file. *) | Open_creat (** create the file if it does not exist. *) | Open_trunc (** empty the file if it already exists. *) | Open_excl (** fail if Open_creat and the file already exists. *) | Open_binary (** open in binary mode (no conversion). *) | Open_text (** open in text mode (may perform conversions). *) | Open_nonblock (** open in non-blocking mode. *) (** Opening modes for {!Pervasives.open_out_gen} and {!Pervasives.open_in_gen}. *) val open_out : string -> out_channel (** Open the named file for writing, and return a new output channel on that file, positionned at the beginning of the file. The file is truncated to zero length if it already exists. It is created if it does not already exists. Raise [Sys_error] if the file could not be opened. *) val open_out_bin : string -> out_channel (** Same as {!Pervasives.open_out}, but the file is opened in binary mode, so that no translation takes place during writes. On operating systems that do not distinguish between text mode and binary mode, this function behaves like {!Pervasives.open_out}. *) val open_out_gen : open_flag list -> int -> string -> out_channel (** [open_out_gen mode perm filename] opens the named file for writing, as described above. The extra argument [mode] specify the opening mode. The extra argument [perm] specifies the file permissions, in case the file must be created. {!Pervasives.open_out} and {!Pervasives.open_out_bin} are special cases of this function. *) val flush : out_channel -> unit (** Flush the buffer associated with the given output channel, performing all pending writes on that channel. Interactive programs must be careful about flushing standard output and standard error at the right time. *) val flush_all : unit -> unit (** Flush all open output channels; ignore errors. *) val output_char : out_channel -> char -> unit (** Write the character on the given output channel. *) val output_string : out_channel -> string -> unit (** Write the string on the given output channel. *) val output : out_channel -> string -> int -> int -> unit (** [output oc buf pos len] writes [len] characters from string [buf], starting at offset [pos], to the given output channel [oc]. Raise [Invalid_argument "output"] if [pos] and [len] do not designate a valid substring of [buf]. *) val output_byte : out_channel -> int -> unit (** Write one 8-bit integer (as the single character with that code) on the given output channel. The given integer is taken modulo 256. *) val output_binary_int : out_channel -> int -> unit (** Write one integer in binary format (4 bytes, big-endian) on the given output channel. The given integer is taken modulo 2{^32}. The only reliable way to read it back is through the {!Pervasives.input_binary_int} function. The format is compatible across all machines for a given version of OCaml. *) val output_value : out_channel -> 'a -> unit (** Write the representation of a structured value of any type to a channel. Circularities and sharing inside the value are detected and preserved. The object can be read back, by the function {!Pervasives.input_value}. See the description of module {!Marshal} for more information. {!Pervasives.output_value} is equivalent to {!Marshal.to_channel} with an empty list of flags. *) val seek_out : out_channel -> int -> unit (** [seek_out chan pos] sets the current writing position to [pos] for channel [chan]. This works only for regular files. On files of other kinds (such as terminals, pipes and sockets), the behavior is unspecified. *) val pos_out : out_channel -> int (** Return the current writing position for the given channel. Does not work on channels opened with the [Open_append] flag (returns unspecified results). *) val out_channel_length : out_channel -> int (** Return the size (number of characters) of the regular file on which the given channel is opened. If the channel is opened on a file that is not a regular file, the result is meaningless. *) val close_out : out_channel -> unit (** Close the given channel, flushing all buffered write operations. Output functions raise a [Sys_error] exception when they are applied to a closed output channel, except [close_out] and [flush], which do nothing when applied to an already closed channel. Note that [close_out] may raise [Sys_error] if the operating system signals an error when flushing or closing. *) val close_out_noerr : out_channel -> unit (** Same as [close_out], but ignore all errors. *) val set_binary_mode_out : out_channel -> bool -> unit (** [set_binary_mode_out oc true] sets the channel [oc] to binary mode: no translations take place during output. [set_binary_mode_out oc false] sets the channel [oc] to text mode: depending on the operating system, some translations may take place during output. For instance, under Windows, end-of-lines will be translated from [\n] to [\r\n]. This function has no effect under operating systems that do not distinguish between text mode and binary mode. *) (** {7 General input functions} *) val open_in : string -> in_channel (** Open the named file for reading, and return a new input channel on that file, positionned at the beginning of the file. Raise [Sys_error] if the file could not be opened. *) val open_in_bin : string -> in_channel (** Same as {!Pervasives.open_in}, but the file is opened in binary mode, so that no translation takes place during reads. On operating systems that do not distinguish between text mode and binary mode, this function behaves like {!Pervasives.open_in}. *) val open_in_gen : open_flag list -> int -> string -> in_channel (** [open_in_gen mode perm filename] opens the named file for reading, as described above. The extra arguments [mode] and [perm] specify the opening mode and file permissions. {!Pervasives.open_in} and {!Pervasives.open_in_bin} are special cases of this function. *) val input_char : in_channel -> char (** Read one character from the given input channel. Raise [End_of_file] if there are no more characters to read. *) val input_line : in_channel -> string (** Read characters from the given input channel, until a newline character is encountered. Return the string of all characters read, without the newline character at the end. Raise [End_of_file] if the end of the file is reached at the beginning of line. *) val input : in_channel -> string -> int -> int -> int (** [input ic buf pos len] reads up to [len] characters from the given channel [ic], storing them in string [buf], starting at character number [pos]. It returns the actual number of characters read, between 0 and [len] (inclusive). A return value of 0 means that the end of file was reached. A return value between 0 and [len] exclusive means that not all requested [len] characters were read, either because no more characters were available at that time, or because the implementation found it convenient to do a partial read; [input] must be called again to read the remaining characters, if desired. (See also {!Pervasives.really_input} for reading exactly [len] characters.) Exception [Invalid_argument "input"] is raised if [pos] and [len] do not designate a valid substring of [buf]. *) val really_input : in_channel -> string -> int -> int -> unit (** [really_input ic buf pos len] reads [len] characters from channel [ic], storing them in string [buf], starting at character number [pos]. Raise [End_of_file] if the end of file is reached before [len] characters have been read. Raise [Invalid_argument "really_input"] if [pos] and [len] do not designate a valid substring of [buf]. *) val input_byte : in_channel -> int (** Same as {!Pervasives.input_char}, but return the 8-bit integer representing the character. Raise [End_of_file] if an end of file was reached. *) val input_binary_int : in_channel -> int (** Read an integer encoded in binary format (4 bytes, big-endian) from the given input channel. See {!Pervasives.output_binary_int}. Raise [End_of_file] if an end of file was reached while reading the integer. *) val input_value : in_channel -> 'a (** Read the representation of a structured value, as produced by {!Pervasives.output_value}, and return the corresponding value. This function is identical to {!Marshal.from_channel}; see the description of module {!Marshal} for more information, in particular concerning the lack of type safety. *) val seek_in : in_channel -> int -> unit (** [seek_in chan pos] sets the current reading position to [pos] for channel [chan]. This works only for regular files. On files of other kinds, the behavior is unspecified. *) val pos_in : in_channel -> int (** Return the current reading position for the given channel. *) val in_channel_length : in_channel -> int (** Return the size (number of characters) of the regular file on which the given channel is opened. If the channel is opened on a file that is not a regular file, the result is meaningless. The returned size does not take into account the end-of-line translations that can be performed when reading from a channel opened in text mode. *) val close_in : in_channel -> unit (** Close the given channel. Input functions raise a [Sys_error] exception when they are applied to a closed input channel, except [close_in], which does nothing when applied to an already closed channel. Note that [close_in] may raise [Sys_error] if the operating system signals an error. *) val close_in_noerr : in_channel -> unit (** Same as [close_in], but ignore all errors. *) val set_binary_mode_in : in_channel -> bool -> unit (** [set_binary_mode_in ic true] sets the channel [ic] to binary mode: no translations take place during input. [set_binary_mode_out ic false] sets the channel [ic] to text mode: depending on the operating system, some translations may take place during input. For instance, under Windows, end-of-lines will be translated from [\r\n] to [\n]. This function has no effect under operating systems that do not distinguish between text mode and binary mode. *) (** {7 Operations on large files} *) module LargeFile : sig val seek_out : out_channel -> int64 -> unit val pos_out : out_channel -> int64 val out_channel_length : out_channel -> int64 val seek_in : in_channel -> int64 -> unit val pos_in : in_channel -> int64 val in_channel_length : in_channel -> int64 end (** Operations on large files. This sub-module provides 64-bit variants of the channel functions that manipulate file positions and file sizes. By representing positions and sizes by 64-bit integers (type [int64]) instead of regular integers (type [int]), these alternate functions allow operating on files whose sizes are greater than [max_int]. *) (** {6 References} *) type 'a ref = { mutable contents : 'a } (** The type of references (mutable indirection cells) containing a value of type ['a]. *) external ref : 'a -> 'a ref = "%makemutable" (** Return a fresh reference containing the given value. *) external ( ! ) : 'a ref -> 'a = "%field0" (** [!r] returns the current contents of reference [r]. Equivalent to [fun r -> r.contents]. *) external ( := ) : 'a ref -> 'a -> unit = "%setfield0" (** [r := a] stores the value of [a] in reference [r]. Equivalent to [fun r v -> r.contents <- v]. *) external incr : int ref -> unit = "%incr" (** Increment the integer contained in the given reference. Equivalent to [fun r -> r := succ !r]. *) external decr : int ref -> unit = "%decr" (** Decrement the integer contained in the given reference. Equivalent to [fun r -> r := pred !r]. *) (** {6 Operations on format strings} *) (** Format strings are used to read and print data using formatted input functions in module {!Scanf} and formatted output in modules {!Printf} and {!Format}. *) (** Format strings have a general and highly polymorphic type [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in. The two simplified types, [format] and [format4] below are included for backward compatibility with earlier releases of OCaml. ['a] is the type of the parameters of the format, ['b] is the type of the first argument given to [%a] and [%t] printing functions, ['c] is the type of the result of the [%a] and [%t] functions, and also the type of the argument transmitted to the first argument of [kprintf]-style functions, ['d] is the result type for the [scanf]-style functions, ['e] is the type of the receiver function for the [scanf]-style functions, ['f] is the result type for the [printf]-style function. *) type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 val string_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string (** Converts a format string into a string. *) external format_of_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" (** [format_of_string s] returns a format string read from the string literal [s]. *) val ( ^^ ) : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('f, 'b, 'c, 'e, 'g, 'h) format6 -> ('a, 'b, 'c, 'd, 'g, 'h) format6 (** [f1 ^^ f2] catenates formats [f1] and [f2]. The result is a format that accepts arguments from [f1], then arguments from [f2]. *) (** {6 Program termination} *) val exit : int -> 'a (** Terminate the process, returning the given status code to the operating system: usually 0 to indicate no errors, and a small positive integer to indicate failure. All open output channels are flushed with [flush_all]. An implicit [exit 0] is performed each time a program terminates normally. An implicit [exit 2] is performed if the program terminates early because of an uncaught exception. *) val at_exit : (unit -> unit) -> unit (** Register the given function to be called at program termination time. The functions registered with [at_exit] will be called when the program executes {!Pervasives.exit}, or terminates, either normally or because of an uncaught exception. The functions are called in ``last in, first out'' order: the function most recently added with [at_exit] is called first. *) (**/**) (* The following is for system use only. Do not call directly. *) val valid_float_lexem : string -> string val unsafe_really_input : in_channel -> string -> int -> int -> unit val do_at_exit : unit -> unit mingw-ocaml/ocaml/stdlib/sys.mli0000644000175000017500000001542012124403240016261 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** System interface. *) val argv : string array (** The command line arguments given to the process. The first element is the command name used to invoke the program. The following elements are the command-line arguments given to the program. *) val executable_name : string (** The name of the file containing the executable currently running. *) external file_exists : string -> bool = "caml_sys_file_exists" (** Test if a file with the given name exists. *) external is_directory : string -> bool = "caml_sys_is_directory" (** Returns [true] if the given name refers to a directory, [false] if it refers to another kind of file. Raise [Sys_error] if no file exists with the given name. @since 3.10.0 *) external remove : string -> unit = "caml_sys_remove" (** Remove the given file name from the file system. *) external rename : string -> string -> unit = "caml_sys_rename" (** Rename a file. The first argument is the old name and the second is the new name. If there is already another file under the new name, [rename] may replace it, or raise an exception, depending on your operating system. *) external getenv : string -> string = "caml_sys_getenv" (** Return the value associated to a variable in the process environment. Raise [Not_found] if the variable is unbound. *) external command : string -> int = "caml_sys_system_command" (** Execute the given shell command and return its exit code. *) external time : unit -> float = "caml_sys_time" (** Return the processor time, in seconds, used by the program since the beginning of execution. *) external chdir : string -> unit = "caml_sys_chdir" (** Change the current working directory of the process. *) external getcwd : unit -> string = "caml_sys_getcwd" (** Return the current working directory of the process. *) external readdir : string -> string array = "caml_sys_read_directory" (** Return the names of all files present in the given directory. Names denoting the current directory and the parent directory (["."] and [".."] in Unix) are not returned. Each string in the result is a file name rather than a complete path. There is no guarantee that the name strings in the resulting array will appear in any specific order; they are not, in particular, guaranteed to appear in alphabetical order. *) val interactive : bool ref (** This reference is initially set to [false] in standalone programs and to [true] if the code is being executed under the interactive toplevel system [ocaml]. *) val os_type : string (** Operating system currently executing the OCaml program. One of - ["Unix"] (for all Unix versions, including Linux and Mac OS X), - ["Win32"] (for MS-Windows, OCaml compiled with MSVC++ or Mingw), - ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin). *) val word_size : int (** Size of one word on the machine currently executing the OCaml program, in bits: 32 or 64. *) val big_endian : bool (** Whether the machine currently executing the Caml program is big-endian. @since 4.00.0 *) val max_string_length : int (** Maximum length of a string. *) val max_array_length : int (** Maximum length of a normal array. The maximum length of a float array is [max_array_length/2] on 32-bit machines and [max_array_length] on 64-bit machines. *) (** {6 Signal handling} *) type signal_behavior = Signal_default | Signal_ignore | Signal_handle of (int -> unit) (** What to do when receiving a signal: - [Signal_default]: take the default behavior (usually: abort the program) - [Signal_ignore]: ignore the signal - [Signal_handle f]: call function [f], giving it the signal number as argument. *) external signal : int -> signal_behavior -> signal_behavior = "caml_install_signal_handler" (** Set the behavior of the system on receipt of a given signal. The first argument is the signal number. Return the behavior previously associated with the signal. If the signal number is invalid (or not available on your system), an [Invalid_argument] exception is raised. *) val set_signal : int -> signal_behavior -> unit (** Same as {!Sys.signal} but return value is ignored. *) (** {7 Signal numbers for the standard POSIX signals.} *) val sigabrt : int (** Abnormal termination *) val sigalrm : int (** Timeout *) val sigfpe : int (** Arithmetic exception *) val sighup : int (** Hangup on controlling terminal *) val sigill : int (** Invalid hardware instruction *) val sigint : int (** Interactive interrupt (ctrl-C) *) val sigkill : int (** Termination (cannot be ignored) *) val sigpipe : int (** Broken pipe *) val sigquit : int (** Interactive termination *) val sigsegv : int (** Invalid memory reference *) val sigterm : int (** Termination *) val sigusr1 : int (** Application-defined signal 1 *) val sigusr2 : int (** Application-defined signal 2 *) val sigchld : int (** Child process terminated *) val sigcont : int (** Continue *) val sigstop : int (** Stop *) val sigtstp : int (** Interactive stop *) val sigttin : int (** Terminal read from background process *) val sigttou : int (** Terminal write from background process *) val sigvtalrm : int (** Timeout in virtual time *) val sigprof : int (** Profiling interrupt *) exception Break (** Exception raised on interactive interrupt if {!Sys.catch_break} is on. *) val catch_break : bool -> unit (** [catch_break] governs whether interactive interrupt (ctrl-C) terminates the program or raises the [Break] exception. Call [catch_break true] to enable raising [Break], and [catch_break false] to let the system terminate the program on user interrupt. *) val ocaml_version : string;; (** [ocaml_version] is the version of OCaml. It is a string of the form ["major.minor[.patchlevel][+additional-info]"], where [major], [minor], and [patchlevel] are integers, and [additional-info] is an arbitrary string. The [[.patchlevel]] and [[+additional-info]] parts may be absent. *) mingw-ocaml/ocaml/stdlib/int32.ml0000644000175000017500000000455212124403240016235 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [Int32]: 32-bit integers *) external neg : int32 -> int32 = "%int32_neg" external add : int32 -> int32 -> int32 = "%int32_add" external sub : int32 -> int32 -> int32 = "%int32_sub" external mul : int32 -> int32 -> int32 = "%int32_mul" external div : int32 -> int32 -> int32 = "%int32_div" external rem : int32 -> int32 -> int32 = "%int32_mod" external logand : int32 -> int32 -> int32 = "%int32_and" external logor : int32 -> int32 -> int32 = "%int32_or" external logxor : int32 -> int32 -> int32 = "%int32_xor" external shift_left : int32 -> int -> int32 = "%int32_lsl" external shift_right : int32 -> int -> int32 = "%int32_asr" external shift_right_logical : int32 -> int -> int32 = "%int32_lsr" external of_int : int -> int32 = "%int32_of_int" external to_int : int32 -> int = "%int32_to_int" external of_float : float -> int32 = "caml_int32_of_float" external to_float : int32 -> float = "caml_int32_to_float" external bits_of_float : float -> int32 = "caml_int32_bits_of_float" external float_of_bits : int32 -> float = "caml_int32_float_of_bits" let zero = 0l let one = 1l let minus_one = -1l let succ n = add n 1l let pred n = sub n 1l let abs n = if n >= 0l then n else neg n let min_int = 0x80000000l let max_int = 0x7FFFFFFFl let lognot n = logxor n (-1l) external format : string -> int32 -> string = "caml_int32_format" let to_string n = format "%d" n external of_string : string -> int32 = "caml_int32_of_string" type t = int32 let compare (x: t) (y: t) = Pervasives.compare x y mingw-ocaml/ocaml/stdlib/obj.mli0000644000175000017500000000450412124403240016216 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Operations on internal representations of values. Not for the casual user. *) type t external repr : 'a -> t = "%identity" external obj : t -> 'a = "%identity" external magic : 'a -> 'b = "%identity" external is_block : t -> bool = "caml_obj_is_block" external is_int : t -> bool = "%obj_is_int" external tag : t -> int = "caml_obj_tag" external set_tag : t -> int -> unit = "caml_obj_set_tag" external size : t -> int = "%obj_size" external field : t -> int -> t = "%obj_field" external set_field : t -> int -> t -> unit = "%obj_set_field" val double_field : t -> int -> float (* @since 3.11.2 *) val set_double_field : t -> int -> float -> unit (* @since 3.11.2 *) external new_block : int -> int -> t = "caml_obj_block" external dup : t -> t = "caml_obj_dup" external truncate : t -> int -> unit = "caml_obj_truncate" external add_offset : t -> Int32.t -> t = "caml_obj_add_offset" (* @since 3.12.0 *) val lazy_tag : int val closure_tag : int val object_tag : int val infix_tag : int val forward_tag : int val no_scan_tag : int val abstract_tag : int val string_tag : int val double_tag : int val double_array_tag : int val custom_tag : int val final_tag : int (* DEPRECATED *) val int_tag : int val out_of_heap_tag : int val unaligned_tag : int (* should never happen @since 3.11.0 *) (** The following two functions are deprecated. Use module {!Marshal} instead. *) val marshal : t -> string val unmarshal : string -> int -> t * int mingw-ocaml/ocaml/stdlib/digest.mli0000644000175000017500000000577512124403240016736 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** MD5 message digest. This module provides functions to compute 128-bit ``digests'' of arbitrary-length strings or files. The digests are of cryptographic quality: it is very hard, given a digest, to forge a string having that digest. The algorithm used is MD5. This module should not be used for secure and sensitive cryptographic applications. For these kind of applications more recent and stronger cryptographic primitives should be used instead. *) type t = string (** The type of digests: 16-character strings. *) val compare : t -> t -> int (** The comparison function for 16-character digest, with the same specification as {!Pervasives.compare} and the implementation shared with {!String.compare}. Along with the type [t], this function [compare] allows the module [Digest] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. @since 4.00.0 *) val string : string -> t (** Return the digest of the given string. *) val substring : string -> int -> int -> t (** [Digest.substring s ofs len] returns the digest of the substring of [s] starting at character number [ofs] and containing [len] characters. *) external channel : in_channel -> int -> t = "caml_md5_chan" (** If [len] is nonnegative, [Digest.channel ic len] reads [len] characters from channel [ic] and returns their digest, or raises [End_of_file] if end-of-file is reached before [len] characters are read. If [len] is negative, [Digest.channel ic len] reads all characters from [ic] until end-of-file is reached and return their digest. *) val file : string -> t (** Return the digest of the file whose name is given. *) val output : out_channel -> t -> unit (** Write a digest on the given output channel. *) val input : in_channel -> t (** Read a digest from the given input channel. *) val to_hex : t -> string (** Return the printable hexadecimal representation of the given digest. *) val from_hex : string -> t (** Convert a hexadecimal representation back into the corresponding digest. Raise [Invalid_argument] if the argument is not exactly 32 hexadecimal characters. @since 4.00.0 *) mingw-ocaml/ocaml/stdlib/char.mli0000644000175000017500000000375712124403240016372 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Character operations. *) external code : char -> int = "%identity" (** Return the ASCII code of the argument. *) val chr : int -> char (** Return the character with the given ASCII code. Raise [Invalid_argument "Char.chr"] if the argument is outside the range 0--255. *) val escaped : char -> string (** Return a string representing the given character, with special characters escaped following the lexical conventions of OCaml. *) val lowercase : char -> char (** Convert the given character to its equivalent lowercase character. *) val uppercase : char -> char (** Convert the given character to its equivalent uppercase character. *) type t = char (** An alias for the type of characters. *) val compare: t -> t -> int (** The comparison function for characters, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [Char] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) (**/**) (* The following is for system use only. Do not call directly. *) external unsafe_chr : int -> char = "%identity" mingw-ocaml/ocaml/stdlib/Makefile.shared0000755000175000017500000000646712124403240017663 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### # $Id$ include ../config/Makefile RUNTIME=../boot/ocamlrun COMPILER=../ocamlc CAMLC=$(RUNTIME) $(COMPILER) COMPFLAGS=-strict-sequence -g -warn-error A -nostdlib OPTCOMPILER=../ocamlopt CAMLOPT=$(RUNTIME) $(OPTCOMPILER) OPTCOMPFLAGS=-warn-error A -nostdlib -g CAMLDEP=../boot/ocamlrun ../tools/ocamldep OBJS=pervasives.cmo $(OTHERS) OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \ sort.cmo marshal.cmo obj.cmo \ int32.cmo int64.cmo nativeint.cmo \ lexing.cmo parsing.cmo \ set.cmo map.cmo stack.cmo queue.cmo \ camlinternalLazy.cmo lazy.cmo stream.cmo \ buffer.cmo printf.cmo \ arg.cmo printexc.cmo gc.cmo \ digest.cmo random.cmo hashtbl.cmo format.cmo scanf.cmo callback.cmo \ camlinternalOO.cmo oo.cmo camlinternalMod.cmo \ genlex.cmo weak.cmo \ filename.cmo complex.cmo \ arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo all: stdlib.cma std_exit.cmo camlheader camlheader_ur install: install-$(RUNTIMED) cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur \ $(LIBDIR) install-noruntimed: .PHONY: install-noruntimed install-runtimed: camlheaderd cp camlheaderd $(LIBDIR) .PHONY: install-runtimed stdlib.cma: $(OBJS) $(CAMLC) -a -o stdlib.cma $(OBJS) stdlib.cmxa: $(OBJS:.cmo=.cmx) $(CAMLOPT) -a -o stdlib.cmxa $(OBJS:.cmo=.cmx) sys.ml: sys.mlp ../VERSION sed -e "s|%%VERSION%%|`sed -e 1q ../VERSION`|" sys.mlp >sys.ml clean:: rm -f sys.ml clean:: rm -f camlheader camlheader_ur camlheaderd .SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx .mli.cmi: $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $< .ml.cmo: $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $< .ml.cmx: $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -c $< .ml.p.cmx: $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -p -c -o $*.p.cmx $< # Dependencies on the compiler $(OBJS) std_exit.cmo: $(COMPILER) $(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER) $(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER) $(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER) # Dependencies on Pervasives (not tracked by ocamldep) $(OBJS) std_exit.cmo: pervasives.cmi $(OTHERS:.cmo=.cmi) std_exit.cmi: pervasives.cmi $(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi $(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi $(OTHERS:.cmo=.cmx) std_exit.cmx: pervasives.cmx $(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmx clean:: rm -f *.cm* *.$(O) *.$(A) rm -f *~ include .depend depend: $(CAMLDEP) *.mli *.ml > .depend $(CAMLDEP) *.ml | sed -e 's/\.cmx/.p.cmx/g' >>.depend mingw-ocaml/ocaml/stdlib/list.mli0000644000175000017500000002537612124403240016431 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** List operations. Some functions are flagged as not tail-recursive. A tail-recursive function uses constant stack space, while a non-tail-recursive function uses stack space proportional to the length of its list argument, which can be a problem with very long lists. When the function takes several list arguments, an approximate formula giving stack usage (in some unspecified constant unit) is shown in parentheses. The above considerations can usually be ignored if your lists are not longer than about 10000 elements. *) val length : 'a list -> int (** Return the length (number of elements) of the given list. *) val hd : 'a list -> 'a (** Return the first element of the given list. Raise [Failure "hd"] if the list is empty. *) val tl : 'a list -> 'a list (** Return the given list without its first element. Raise [Failure "tl"] if the list is empty. *) val nth : 'a list -> int -> 'a (** Return the [n]-th element of the given list. The first element (head of the list) is at position 0. Raise [Failure "nth"] if the list is too short. Raise [Invalid_argument "List.nth"] if [n] is negative. *) val rev : 'a list -> 'a list (** List reversal. *) val append : 'a list -> 'a list -> 'a list (** Catenate two lists. Same function as the infix operator [@]. Not tail-recursive (length of the first argument). The [@] operator is not tail-recursive either. *) val rev_append : 'a list -> 'a list -> 'a list (** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2]. This is equivalent to {!List.rev}[ l1 @ l2], but [rev_append] is tail-recursive and more efficient. *) val concat : 'a list list -> 'a list (** Concatenate a list of lists. The elements of the argument are all concatenated together (in the same order) to give the result. Not tail-recursive (length of the argument + length of the longest sub-list). *) val flatten : 'a list list -> 'a list (** Same as [concat]. Not tail-recursive (length of the argument + length of the longest sub-list). *) (** {6 Iterators} *) val iter : ('a -> unit) -> 'a list -> unit (** [List.iter f [a1; ...; an]] applies function [f] in turn to [a1; ...; an]. It is equivalent to [begin f a1; f a2; ...; f an; () end]. *) val iteri : (int -> 'a -> unit) -> 'a list -> unit (** Same as {!List.iter}, but the function is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. @since 4.00.0 *) val map : ('a -> 'b) -> 'a list -> 'b list (** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an], and builds the list [[f a1; ...; f an]] with the results returned by [f]. Not tail-recursive. *) val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list (** Same as {!List.map}, but the function is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. Not tail-recursive. @since 4.00.0 *) val rev_map : ('a -> 'b) -> 'a list -> 'b list (** [List.rev_map f l] gives the same result as {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and more efficient. *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a (** [List.fold_left f a [b1; ...; bn]] is [f (... (f (f a b1) b2) ...) bn]. *) val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b (** [List.fold_right f [a1; ...; an] b] is [f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. *) (** {6 Iterators on two lists} *) val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit (** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn [f a1 b1; ...; f an bn]. Raise [Invalid_argument] if the two lists have different lengths. *) val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.map2 f [a1; ...; an] [b1; ...; bn]] is [[f a1 b1; ...; f an bn]]. Raise [Invalid_argument] if the two lists have different lengths. Not tail-recursive. *) val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.rev_map2 f l1 l2] gives the same result as {!List.rev}[ (]{!List.map2}[ f l1 l2)], but is tail-recursive and more efficient. *) val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a (** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is [f (... (f (f a b1 c1) b2 c2) ...) bn cn]. Raise [Invalid_argument] if the two lists have different lengths. *) val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c (** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is [f a1 b1 (f a2 b2 (... (f an bn c) ...))]. Raise [Invalid_argument] if the two lists have different lengths. Not tail-recursive. *) (** {6 List scanning} *) val for_all : ('a -> bool) -> 'a list -> bool (** [for_all p [a1; ...; an]] checks if all elements of the list satisfy the predicate [p]. That is, it returns [(p a1) && (p a2) && ... && (p an)]. *) val exists : ('a -> bool) -> 'a list -> bool (** [exists p [a1; ...; an]] checks if at least one element of the list satisfies the predicate [p]. That is, it returns [(p a1) || (p a2) || ... || (p an)]. *) val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!List.for_all}, but for a two-argument predicate. Raise [Invalid_argument] if the two lists have different lengths. *) val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!List.exists}, but for a two-argument predicate. Raise [Invalid_argument] if the two lists have different lengths. *) val mem : 'a -> 'a list -> bool (** [mem a l] is true if and only if [a] is equal to an element of [l]. *) val memq : 'a -> 'a list -> bool (** Same as {!List.mem}, but uses physical equality instead of structural equality to compare list elements. *) (** {6 List searching} *) val find : ('a -> bool) -> 'a list -> 'a (** [find p l] returns the first element of the list [l] that satisfies the predicate [p]. Raise [Not_found] if there is no value that satisfies [p] in the list [l]. *) val filter : ('a -> bool) -> 'a list -> 'a list (** [filter p l] returns all the elements of the list [l] that satisfy the predicate [p]. The order of the elements in the input list is preserved. *) val find_all : ('a -> bool) -> 'a list -> 'a list (** [find_all] is another name for {!List.filter}. *) val partition : ('a -> bool) -> 'a list -> 'a list * 'a list (** [partition p l] returns a pair of lists [(l1, l2)], where [l1] is the list of all the elements of [l] that satisfy the predicate [p], and [l2] is the list of all the elements of [l] that do not satisfy [p]. The order of the elements in the input list is preserved. *) (** {6 Association lists} *) val assoc : 'a -> ('a * 'b) list -> 'b (** [assoc a l] returns the value associated with key [a] in the list of pairs [l]. That is, [assoc a [ ...; (a,b); ...] = b] if [(a,b)] is the leftmost binding of [a] in list [l]. Raise [Not_found] if there is no value associated with [a] in the list [l]. *) val assq : 'a -> ('a * 'b) list -> 'b (** Same as {!List.assoc}, but uses physical equality instead of structural equality to compare keys. *) val mem_assoc : 'a -> ('a * 'b) list -> bool (** Same as {!List.assoc}, but simply return true if a binding exists, and false if no bindings exist for the given key. *) val mem_assq : 'a -> ('a * 'b) list -> bool (** Same as {!List.mem_assoc}, but uses physical equality instead of structural equality to compare keys. *) val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list (** [remove_assoc a l] returns the list of pairs [l] without the first pair with key [a], if any. Not tail-recursive. *) val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list (** Same as {!List.remove_assoc}, but uses physical equality instead of structural equality to compare keys. Not tail-recursive. *) (** {6 Lists of pairs} *) val split : ('a * 'b) list -> 'a list * 'b list (** Transform a list of pairs into a pair of lists: [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])]. Not tail-recursive. *) val combine : 'a list -> 'b list -> ('a * 'b) list (** Transform a pair of lists into a list of pairs: [combine [a1; ...; an] [b1; ...; bn]] is [[(a1,b1); ...; (an,bn)]]. Raise [Invalid_argument] if the two lists have different lengths. Not tail-recursive. *) (** {6 Sorting} *) val sort : ('a -> 'a -> int) -> 'a list -> 'a list (** Sort a list in increasing order according to a comparison function. The comparison function must return 0 if its arguments compare as equal, a positive integer if the first is greater, and a negative integer if the first is smaller (see Array.sort for a complete specification). For example, {!Pervasives.compare} is a suitable comparison function. The resulting list is sorted in increasing order. [List.sort] is guaranteed to run in constant heap space (in addition to the size of the result list) and logarithmic stack space. The current implementation uses Merge Sort. It runs in constant heap space and logarithmic stack space. *) val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list (** Same as {!List.sort}, but the sorting algorithm is guaranteed to be stable (i.e. elements that compare equal are kept in their original order) . The current implementation uses Merge Sort. It runs in constant heap space and logarithmic stack space. *) val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list (** Same as {!List.sort} or {!List.stable_sort}, whichever is faster on typical input. *) val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list (** Merge two lists: Assuming that [l1] and [l2] are sorted according to the comparison function [cmp], [merge cmp l1 l2] will return a sorted list containting all the elements of [l1] and [l2]. If several elements compare equal, the elements of [l1] will be before the elements of [l2]. Not tail-recursive (sum of the lengths of the arguments). *) mingw-ocaml/ocaml/stdlib/nativeint.ml0000644000175000017500000000515012124403240017272 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [Nativeint]: processor-native integers *) external neg: nativeint -> nativeint = "%nativeint_neg" external add: nativeint -> nativeint -> nativeint = "%nativeint_add" external sub: nativeint -> nativeint -> nativeint = "%nativeint_sub" external mul: nativeint -> nativeint -> nativeint = "%nativeint_mul" external div: nativeint -> nativeint -> nativeint = "%nativeint_div" external rem: nativeint -> nativeint -> nativeint = "%nativeint_mod" external logand: nativeint -> nativeint -> nativeint = "%nativeint_and" external logor: nativeint -> nativeint -> nativeint = "%nativeint_or" external logxor: nativeint -> nativeint -> nativeint = "%nativeint_xor" external shift_left: nativeint -> int -> nativeint = "%nativeint_lsl" external shift_right: nativeint -> int -> nativeint = "%nativeint_asr" external shift_right_logical: nativeint -> int -> nativeint = "%nativeint_lsr" external of_int: int -> nativeint = "%nativeint_of_int" external to_int: nativeint -> int = "%nativeint_to_int" external of_float : float -> nativeint = "caml_nativeint_of_float" external to_float : nativeint -> float = "caml_nativeint_to_float" external of_int32: int32 -> nativeint = "%nativeint_of_int32" external to_int32: nativeint -> int32 = "%nativeint_to_int32" let zero = 0n let one = 1n let minus_one = -1n let succ n = add n 1n let pred n = sub n 1n let abs n = if n >= 0n then n else neg n let size = Sys.word_size let min_int = shift_left 1n (size - 1) let max_int = sub min_int 1n let lognot n = logxor n (-1n) external format : string -> nativeint -> string = "caml_nativeint_format" let to_string n = format "%d" n external of_string: string -> nativeint = "caml_nativeint_of_string" type t = nativeint let compare (x: t) (y: t) = Pervasives.compare x y mingw-ocaml/ocaml/stdlib/std_exit.ml0000644000175000017500000000175012124403240017116 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Ensure that [at_exit] functions are called at the end of every program *) let _ = do_at_exit() mingw-ocaml/ocaml/stdlib/Compflags0000755000175000017500000000267312124403240016607 0ustar tootstoots#!/bin/sh ######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 2004 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../LICENSE. # # # ######################################################################### # $Id$ case $1 in pervasives.cm[iox]|pervasives.p.cmx) echo ' -nopervasives';; camlinternalOO.cmi) echo ' -nopervasives';; camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';; buffer.cm[io]|printf.cm[io]|format.cm[io]|scanf.cm[io]) echo ' -w A';; scanf.cmx|scanf.p.cmx) echo ' -inline 9';; arrayLabels.cm[ox]|arrayLabels.p.cmx) echo ' -nolabels';; listLabels.cm[ox]|listLabels.p.cmx) echo ' -nolabels';; stringLabels.cm[ox]|stringLabels.p.cmx) echo ' -nolabels';; moreLabels.cm[ox]|moreLabels.p.cmx) echo ' -nolabels';; *) echo ' ';; esac mingw-ocaml/ocaml/stdlib/oo.mli0000644000175000017500000000342112124403240016056 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Operations on objects *) val copy : (< .. > as 'a) -> 'a (** [Oo.copy o] returns a copy of object [o], that is a fresh object with the same methods and instance variables as [o]. *) external id : < .. > -> int = "%field1" (** Return an integer identifying this object, unique for the current execution of the program. The generic comparison and hashing functions are based on this integer. When an object is obtained by unmarshaling, the id is refreshed, and thus different from the original object. As a consequence, the internal invariants of data structures such as hash table or sets containing objects are broken after unmarshaling the data structures. *) (**/**) (* The following is for system use only. Do not call directly. *) (** For internal use (CamlIDL) *) val new_method : string -> CamlinternalOO.tag val public_method_label : string -> CamlinternalOO.tag mingw-ocaml/ocaml/stdlib/list.ml0000644000175000017500000002027712124403240016253 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* List operations *) let rec length_aux len = function [] -> len | a::l -> length_aux (len + 1) l let length l = length_aux 0 l let hd = function [] -> failwith "hd" | a::l -> a let tl = function [] -> failwith "tl" | a::l -> l let nth l n = if n < 0 then invalid_arg "List.nth" else let rec nth_aux l n = match l with | [] -> failwith "nth" | a::l -> if n = 0 then a else nth_aux l (n-1) in nth_aux l n let append = (@) let rec rev_append l1 l2 = match l1 with [] -> l2 | a :: l -> rev_append l (a :: l2) let rev l = rev_append l [] let rec flatten = function [] -> [] | l::r -> l @ flatten r let concat = flatten let rec map f = function [] -> [] | a::l -> let r = f a in r :: map f l let rec mapi i f = function [] -> [] | a::l -> let r = f i a in r :: mapi (i + 1) f l let mapi f l = mapi 0 f l let rev_map f l = let rec rmap_f accu = function | [] -> accu | a::l -> rmap_f (f a :: accu) l in rmap_f [] l ;; let rec iter f = function [] -> () | a::l -> f a; iter f l let rec iteri i f = function [] -> () | a::l -> f i a; iteri (i + 1) f l let iteri f l = iteri 0 f l let rec fold_left f accu l = match l with [] -> accu | a::l -> fold_left f (f accu a) l let rec fold_right f l accu = match l with [] -> accu | a::l -> f a (fold_right f l accu) let rec map2 f l1 l2 = match (l1, l2) with ([], []) -> [] | (a1::l1, a2::l2) -> let r = f a1 a2 in r :: map2 f l1 l2 | (_, _) -> invalid_arg "List.map2" let rev_map2 f l1 l2 = let rec rmap2_f accu l1 l2 = match (l1, l2) with | ([], []) -> accu | (a1::l1, a2::l2) -> rmap2_f (f a1 a2 :: accu) l1 l2 | (_, _) -> invalid_arg "List.rev_map2" in rmap2_f [] l1 l2 ;; let rec iter2 f l1 l2 = match (l1, l2) with ([], []) -> () | (a1::l1, a2::l2) -> f a1 a2; iter2 f l1 l2 | (_, _) -> invalid_arg "List.iter2" let rec fold_left2 f accu l1 l2 = match (l1, l2) with ([], []) -> accu | (a1::l1, a2::l2) -> fold_left2 f (f accu a1 a2) l1 l2 | (_, _) -> invalid_arg "List.fold_left2" let rec fold_right2 f l1 l2 accu = match (l1, l2) with ([], []) -> accu | (a1::l1, a2::l2) -> f a1 a2 (fold_right2 f l1 l2 accu) | (_, _) -> invalid_arg "List.fold_right2" let rec for_all p = function [] -> true | a::l -> p a && for_all p l let rec exists p = function [] -> false | a::l -> p a || exists p l let rec for_all2 p l1 l2 = match (l1, l2) with ([], []) -> true | (a1::l1, a2::l2) -> p a1 a2 && for_all2 p l1 l2 | (_, _) -> invalid_arg "List.for_all2" let rec exists2 p l1 l2 = match (l1, l2) with ([], []) -> false | (a1::l1, a2::l2) -> p a1 a2 || exists2 p l1 l2 | (_, _) -> invalid_arg "List.exists2" let rec mem x = function [] -> false | a::l -> compare a x = 0 || mem x l let rec memq x = function [] -> false | a::l -> a == x || memq x l let rec assoc x = function [] -> raise Not_found | (a,b)::l -> if compare a x = 0 then b else assoc x l let rec assq x = function [] -> raise Not_found | (a,b)::l -> if a == x then b else assq x l let rec mem_assoc x = function | [] -> false | (a, b) :: l -> compare a x = 0 || mem_assoc x l let rec mem_assq x = function | [] -> false | (a, b) :: l -> a == x || mem_assq x l let rec remove_assoc x = function | [] -> [] | (a, b as pair) :: l -> if compare a x = 0 then l else pair :: remove_assoc x l let rec remove_assq x = function | [] -> [] | (a, b as pair) :: l -> if a == x then l else pair :: remove_assq x l let rec find p = function | [] -> raise Not_found | x :: l -> if p x then x else find p l let find_all p = let rec find accu = function | [] -> rev accu | x :: l -> if p x then find (x :: accu) l else find accu l in find [] let filter = find_all let partition p l = let rec part yes no = function | [] -> (rev yes, rev no) | x :: l -> if p x then part (x :: yes) no l else part yes (x :: no) l in part [] [] l let rec split = function [] -> ([], []) | (x,y)::l -> let (rx, ry) = split l in (x::rx, y::ry) let rec combine l1 l2 = match (l1, l2) with ([], []) -> [] | (a1::l1, a2::l2) -> (a1, a2) :: combine l1 l2 | (_, _) -> invalid_arg "List.combine" (** sorting *) let rec merge cmp l1 l2 = match l1, l2 with | [], l2 -> l2 | l1, [] -> l1 | h1 :: t1, h2 :: t2 -> if cmp h1 h2 <= 0 then h1 :: merge cmp t1 l2 else h2 :: merge cmp l1 t2 ;; let rec chop k l = if k = 0 then l else begin match l with | x::t -> chop (k-1) t | _ -> assert false end ;; let stable_sort cmp l = let rec rev_merge l1 l2 accu = match l1, l2 with | [], l2 -> rev_append l2 accu | l1, [] -> rev_append l1 accu | h1::t1, h2::t2 -> if cmp h1 h2 <= 0 then rev_merge t1 l2 (h1::accu) else rev_merge l1 t2 (h2::accu) in let rec rev_merge_rev l1 l2 accu = match l1, l2 with | [], l2 -> rev_append l2 accu | l1, [] -> rev_append l1 accu | h1::t1, h2::t2 -> if cmp h1 h2 > 0 then rev_merge_rev t1 l2 (h1::accu) else rev_merge_rev l1 t2 (h2::accu) in let rec sort n l = match n, l with | 2, x1 :: x2 :: _ -> if cmp x1 x2 <= 0 then [x1; x2] else [x2; x1] | 3, x1 :: x2 :: x3 :: _ -> if cmp x1 x2 <= 0 then begin if cmp x2 x3 <= 0 then [x1; x2; x3] else if cmp x1 x3 <= 0 then [x1; x3; x2] else [x3; x1; x2] end else begin if cmp x1 x3 <= 0 then [x2; x1; x3] else if cmp x2 x3 <= 0 then [x2; x3; x1] else [x3; x2; x1] end | n, l -> let n1 = n asr 1 in let n2 = n - n1 in let l2 = chop n1 l in let s1 = rev_sort n1 l in let s2 = rev_sort n2 l2 in rev_merge_rev s1 s2 [] and rev_sort n l = match n, l with | 2, x1 :: x2 :: _ -> if cmp x1 x2 > 0 then [x1; x2] else [x2; x1] | 3, x1 :: x2 :: x3 :: _ -> if cmp x1 x2 > 0 then begin if cmp x2 x3 > 0 then [x1; x2; x3] else if cmp x1 x3 > 0 then [x1; x3; x2] else [x3; x1; x2] end else begin if cmp x1 x3 > 0 then [x2; x1; x3] else if cmp x2 x3 > 0 then [x2; x3; x1] else [x3; x2; x1] end | n, l -> let n1 = n asr 1 in let n2 = n - n1 in let l2 = chop n1 l in let s1 = sort n1 l in let s2 = sort n2 l2 in rev_merge s1 s2 [] in let len = length l in if len < 2 then l else sort len l ;; let sort = stable_sort;; let fast_sort = stable_sort;; (* Note: on a list of length between about 100000 (depending on the minor heap size and the type of the list) and Sys.max_array_size, it is actually faster to use the following, but it might also use more memory because the argument list cannot be deallocated incrementally. Also, there seems to be a bug in this code or in the implementation of obj_truncate. external obj_truncate : 'a array -> int -> unit = "caml_obj_truncate" let array_to_list_in_place a = let l = Array.length a in let rec loop accu n p = if p <= 0 then accu else begin if p = n then begin obj_truncate a p; loop (a.(p-1) :: accu) (n-1000) (p-1) end else begin loop (a.(p-1) :: accu) n (p-1) end end in loop [] (l-1000) l ;; let stable_sort cmp l = let a = Array.of_list l in Array.stable_sort cmp a; array_to_list_in_place a ;; *) mingw-ocaml/ocaml/stdlib/random.mli0000644000175000017500000000770312124403240016730 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Pseudo-random number generators (PRNG). *) (** {6 Basic functions} *) val init : int -> unit (** Initialize the generator, using the argument as a seed. The same seed will always yield the same sequence of numbers. *) val full_init : int array -> unit (** Same as {!Random.init} but takes more data as seed. *) val self_init : unit -> unit (** Initialize the generator with a random seed chosen in a system-dependent way. If [/dev/urandom] is available on the host machine, it is used to provide a highly random initial seed. Otherwise, a less random seed is computed from system parameters (current time, process IDs). *) val bits : unit -> int (** Return 30 random bits in a nonnegative integer. @before 3.12.0 used a different algorithm (affects all the following functions) *) val int : int -> int (** [Random.int bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0 and less than 2{^30}. *) val int32 : Int32.t -> Int32.t;; (** [Random.int32 bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0. *) val nativeint : Nativeint.t -> Nativeint.t;; (** [Random.nativeint bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0. *) val int64 : Int64.t -> Int64.t;; (** [Random.int64 bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0. *) val float : float -> float (** [Random.float bound] returns a random floating-point number between 0 and [bound] (inclusive). If [bound] is negative, the result is negative or zero. If [bound] is 0, the result is 0. *) val bool : unit -> bool (** [Random.bool ()] returns [true] or [false] with probability 0.5 each. *) (** {6 Advanced functions} *) (** The functions from module [State] manipulate the current state of the random generator explicitly. This allows using one or several deterministic PRNGs, even in a multi-threaded program, without interference from other parts of the program. *) module State : sig type t (** The type of PRNG states. *) val make : int array -> t (** Create a new state and initialize it with the given seed. *) val make_self_init : unit -> t (** Create a new state and initialize it with a system-dependent low-entropy seed. *) val copy : t -> t (** Return a copy of the given state. *) val bits : t -> int val int : t -> int -> int val int32 : t -> Int32.t -> Int32.t val nativeint : t -> Nativeint.t -> Nativeint.t val int64 : t -> Int64.t -> Int64.t val float : t -> float -> float val bool : t -> bool (** These functions are the same as the basic functions, except that they use (and update) the given PRNG state instead of the default one. *) end;; val get_state : unit -> State.t (** Return the current state of the generator used by the basic functions. *) val set_state : State.t -> unit (** Set the state of the generator used by the basic functions. *) mingw-ocaml/ocaml/stdlib/marshal.ml0000644000175000017500000000442512124403240016724 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) type extern_flags = No_sharing | Closures (* note: this type definition is used in 'byterun/debugger.c' *) external to_channel: out_channel -> 'a -> extern_flags list -> unit = "caml_output_value" external to_string: 'a -> extern_flags list -> string = "caml_output_value_to_string" external to_buffer_unsafe: string -> int -> int -> 'a -> extern_flags list -> int = "caml_output_value_to_buffer" let to_buffer buff ofs len v flags = if ofs < 0 || len < 0 || ofs > String.length buff - len then invalid_arg "Marshal.to_buffer: substring out of bounds" else to_buffer_unsafe buff ofs len v flags external from_channel: in_channel -> 'a = "caml_input_value" external from_string_unsafe: string -> int -> 'a = "caml_input_value_from_string" external data_size_unsafe: string -> int -> int = "caml_marshal_data_size" let header_size = 20 let data_size buff ofs = if ofs < 0 || ofs > String.length buff - header_size then invalid_arg "Marshal.data_size" else data_size_unsafe buff ofs let total_size buff ofs = header_size + data_size buff ofs let from_string buff ofs = if ofs < 0 || ofs > String.length buff - header_size then invalid_arg "Marshal.from_size" else begin let len = data_size_unsafe buff ofs in if ofs > String.length buff - (header_size + len) then invalid_arg "Marshal.from_string" else from_string_unsafe buff ofs end mingw-ocaml/ocaml/stdlib/camlinternalOO.mli0000644000175000017500000001146712124403240020361 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Run-time support for objects and classes. All functions in this module are for system use only, not for the casual user. *) (** {6 Classes} *) type tag type label type table type meth type t type obj type closure val public_method_label : string -> tag val new_method : table -> label val new_variable : table -> string -> int val new_methods_variables : table -> string array -> string array -> label array val get_variable : table -> string -> int val get_variables : table -> string array -> int array val get_method_label : table -> string -> label val get_method_labels : table -> string array -> label array val get_method : table -> label -> meth val set_method : table -> label -> meth -> unit val set_methods : table -> label array -> unit val narrow : table -> string array -> string array -> string array -> unit val widen : table -> unit val add_initializer : table -> (obj -> unit) -> unit val dummy_table : table val create_table : string array -> table val init_class : table -> unit val inherits : table -> string array -> string array -> string array -> (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t array val make_class : string array -> (table -> Obj.t -> t) -> (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t) type init_table val make_class_store : string array -> (table -> t) -> init_table -> unit val dummy_class : string * int * int -> (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t) (** {6 Objects} *) val copy : (< .. > as 'a) -> 'a val create_object : table -> obj val create_object_opt : obj -> table -> obj val run_initializers : obj -> table -> unit val run_initializers_opt : obj -> obj -> table -> obj val create_object_and_run_initializers : obj -> table -> obj external send : obj -> tag -> t = "%send" external sendcache : obj -> tag -> t -> int -> t = "%sendcache" external sendself : obj -> label -> t = "%sendself" external get_public_method : obj -> tag -> closure = "caml_get_public_method" "noalloc" (** {6 Table cache} *) type tables val lookup_tables : tables -> closure array -> tables (** {6 Builtins to reduce code size} *) (* val get_const : t -> closure val get_var : int -> closure val get_env : int -> int -> closure val get_meth : label -> closure val set_var : int -> closure val app_const : (t -> t) -> t -> closure val app_var : (t -> t) -> int -> closure val app_env : (t -> t) -> int -> int -> closure val app_meth : (t -> t) -> label -> closure val app_const_const : (t -> t -> t) -> t -> t -> closure val app_const_var : (t -> t -> t) -> t -> int -> closure val app_const_env : (t -> t -> t) -> t -> int -> int -> closure val app_const_meth : (t -> t -> t) -> t -> label -> closure val app_var_const : (t -> t -> t) -> int -> t -> closure val app_env_const : (t -> t -> t) -> int -> int -> t -> closure val app_meth_const : (t -> t -> t) -> label -> t -> closure val meth_app_const : label -> t -> closure val meth_app_var : label -> int -> closure val meth_app_env : label -> int -> int -> closure val meth_app_meth : label -> label -> closure val send_const : tag -> obj -> int -> closure val send_var : tag -> int -> int -> closure val send_env : tag -> int -> int -> int -> closure val send_meth : tag -> label -> int -> closure *) type impl = GetConst | GetVar | GetEnv | GetMeth | SetVar | AppConst | AppVar | AppEnv | AppMeth | AppConstConst | AppConstVar | AppConstEnv | AppConstMeth | AppVarConst | AppEnvConst | AppMethConst | MethAppConst | MethAppVar | MethAppEnv | MethAppMeth | SendConst | SendVar | SendEnv | SendMeth | Closure of closure (** {6 Parameters} *) (* currently disabled *) type params = { mutable compact_table : bool; mutable copy_parent : bool; mutable clean_when_copying : bool; mutable retry_count : int; mutable bucket_small_size : int } val params : params (** {6 Statistics} *) type stats = { classes : int; methods : int; inst_vars : int } val stats : unit -> stats mingw-ocaml/ocaml/stdlib/complex.mli0000644000175000017500000000532412124403240017114 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Complex numbers. This module provides arithmetic operations on complex numbers. Complex numbers are represented by their real and imaginary parts (cartesian representation). Each part is represented by a double-precision floating-point number (type [float]). *) type t = { re: float; im: float } (** The type of complex numbers. [re] is the real part and [im] the imaginary part. *) val zero: t (** The complex number [0]. *) val one: t (** The complex number [1]. *) val i: t (** The complex number [i]. *) val neg: t -> t (** Unary negation. *) val conj: t -> t (** Conjugate: given the complex [x + i.y], returns [x - i.y]. *) val add: t -> t -> t (** Addition *) val sub: t -> t -> t (** Subtraction *) val mul: t -> t -> t (** Multiplication *) val inv: t -> t (** Multiplicative inverse ([1/z]). *) val div: t -> t -> t (** Division *) val sqrt: t -> t (** Square root. The result [x + i.y] is such that [x > 0] or [x = 0] and [y >= 0]. This function has a discontinuity along the negative real axis. *) val norm2: t -> float (** Norm squared: given [x + i.y], returns [x^2 + y^2]. *) val norm: t -> float (** Norm: given [x + i.y], returns [sqrt(x^2 + y^2)]. *) val arg: t -> float (** Argument. The argument of a complex number is the angle in the complex plane between the positive real axis and a line passing through zero and the number. This angle ranges from [-pi] to [pi]. This function has a discontinuity along the negative real axis. *) val polar: float -> float -> t (** [polar norm arg] returns the complex having norm [norm] and argument [arg]. *) val exp: t -> t (** Exponentiation. [exp z] returns [e] to the [z] power. *) val log: t -> t (** Natural logarithm (in base [e]). *) val pow: t -> t -> t (** Power function. [pow z1 z2] returns [z1] to the [z2] power. *) mingw-ocaml/ocaml/stdlib/map.ml0000644000175000017500000002526712124403240016061 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) module type OrderedType = sig type t val compare: t -> t -> int end module type S = sig type key type +'a t val empty: 'a t val is_empty: 'a t -> bool val mem: key -> 'a t -> bool val add: key -> 'a -> 'a t -> 'a t val singleton: key -> 'a -> 'a t val remove: key -> 'a t -> 'a t val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val for_all: (key -> 'a -> bool) -> 'a t -> bool val exists: (key -> 'a -> bool) -> 'a t -> bool val filter: (key -> 'a -> bool) -> 'a t -> 'a t val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t val cardinal: 'a t -> int val bindings: 'a t -> (key * 'a) list val min_binding: 'a t -> (key * 'a) val max_binding: 'a t -> (key * 'a) val choose: 'a t -> (key * 'a) val split: key -> 'a t -> 'a t * 'a option * 'a t val find: key -> 'a t -> 'a val map: ('a -> 'b) -> 'a t -> 'b t val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t end module Make(Ord: OrderedType) = struct type key = Ord.t type 'a t = Empty | Node of 'a t * key * 'a * 'a t * int let height = function Empty -> 0 | Node(_,_,_,_,h) -> h let create l x d r = let hl = height l and hr = height r in Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let singleton x d = Node(Empty, x, d, Empty, 1) let bal l x d r = let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in if hl > hr + 2 then begin match l with Empty -> invalid_arg "Map.bal" | Node(ll, lv, ld, lr, _) -> if height ll >= height lr then create ll lv ld (create lr x d r) else begin match lr with Empty -> invalid_arg "Map.bal" | Node(lrl, lrv, lrd, lrr, _)-> create (create ll lv ld lrl) lrv lrd (create lrr x d r) end end else if hr > hl + 2 then begin match r with Empty -> invalid_arg "Map.bal" | Node(rl, rv, rd, rr, _) -> if height rr >= height rl then create (create l x d rl) rv rd rr else begin match rl with Empty -> invalid_arg "Map.bal" | Node(rll, rlv, rld, rlr, _) -> create (create l x d rll) rlv rld (create rlr rv rd rr) end end else Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) let empty = Empty let is_empty = function Empty -> true | _ -> false let rec add x data = function Empty -> Node(Empty, x, data, Empty, 1) | Node(l, v, d, r, h) -> let c = Ord.compare x v in if c = 0 then Node(l, x, data, r, h) else if c < 0 then bal (add x data l) v d r else bal l v d (add x data r) let rec find x = function Empty -> raise Not_found | Node(l, v, d, r, _) -> let c = Ord.compare x v in if c = 0 then d else find x (if c < 0 then l else r) let rec mem x = function Empty -> false | Node(l, v, d, r, _) -> let c = Ord.compare x v in c = 0 || mem x (if c < 0 then l else r) let rec min_binding = function Empty -> raise Not_found | Node(Empty, x, d, r, _) -> (x, d) | Node(l, x, d, r, _) -> min_binding l let rec max_binding = function Empty -> raise Not_found | Node(l, x, d, Empty, _) -> (x, d) | Node(l, x, d, r, _) -> max_binding r let rec remove_min_binding = function Empty -> invalid_arg "Map.remove_min_elt" | Node(Empty, x, d, r, _) -> r | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r let merge t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (_, _) -> let (x, d) = min_binding t2 in bal t1 x d (remove_min_binding t2) let rec remove x = function Empty -> Empty | Node(l, v, d, r, h) -> let c = Ord.compare x v in if c = 0 then merge l r else if c < 0 then bal (remove x l) v d r else bal l v d (remove x r) let rec iter f = function Empty -> () | Node(l, v, d, r, _) -> iter f l; f v d; iter f r let rec map f = function Empty -> Empty | Node(l, v, d, r, h) -> let l' = map f l in let d' = f d in let r' = map f r in Node(l', v, d', r', h) let rec mapi f = function Empty -> Empty | Node(l, v, d, r, h) -> let l' = mapi f l in let d' = f v d in let r' = mapi f r in Node(l', v, d', r', h) let rec fold f m accu = match m with Empty -> accu | Node(l, v, d, r, _) -> fold f r (f v d (fold f l accu)) let rec for_all p = function Empty -> true | Node(l, v, d, r, _) -> p v d && for_all p l && for_all p r let rec exists p = function Empty -> false | Node(l, v, d, r, _) -> p v d || exists p l || exists p r (* Beware: those two functions assume that the added k is *strictly* smaller (or bigger) than all the present keys in the tree; it does not test for equality with the current min (or max) key. Indeed, they are only used during the "join" operation which respects this precondition. *) let rec add_min_binding k v = function | Empty -> singleton k v | Node (l, x, d, r, h) -> bal (add_min_binding k v l) x d r let rec add_max_binding k v = function | Empty -> singleton k v | Node (l, x, d, r, h) -> bal l x d (add_max_binding k v r) (* Same as create and bal, but no assumptions are made on the relative heights of l and r. *) let rec join l v d r = match (l, r) with (Empty, _) -> add_min_binding v d r | (_, Empty) -> add_max_binding v d l | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) -> if lh > rh + 2 then bal ll lv ld (join lr v d r) else if rh > lh + 2 then bal (join l v d rl) rv rd rr else create l v d r (* Merge two trees l and r into one. All elements of l must precede the elements of r. No assumption on the heights of l and r. *) let concat t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (_, _) -> let (x, d) = min_binding t2 in join t1 x d (remove_min_binding t2) let concat_or_join t1 v d t2 = match d with | Some d -> join t1 v d t2 | None -> concat t1 t2 let rec split x = function Empty -> (Empty, None, Empty) | Node(l, v, d, r, _) -> let c = Ord.compare x v in if c = 0 then (l, Some d, r) else if c < 0 then let (ll, pres, rl) = split x l in (ll, pres, join rl v d r) else let (lr, pres, rr) = split x r in (join l v d lr, pres, rr) let rec merge f s1 s2 = match (s1, s2) with (Empty, Empty) -> Empty | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 -> let (l2, d2, r2) = split v1 s2 in concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2) | (_, Node (l2, v2, d2, r2, h2)) -> let (l1, d1, r1) = split v2 s1 in concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2) | _ -> assert false let rec filter p = function Empty -> Empty | Node(l, v, d, r, _) -> (* call [p] in the expected left-to-right order *) let l' = filter p l in let pvd = p v d in let r' = filter p r in if pvd then join l' v d r' else concat l' r' let rec partition p = function Empty -> (Empty, Empty) | Node(l, v, d, r, _) -> (* call [p] in the expected left-to-right order *) let (lt, lf) = partition p l in let pvd = p v d in let (rt, rf) = partition p r in if pvd then (join lt v d rt, concat lf rf) else (concat lt rt, join lf v d rf) type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration let rec cons_enum m e = match m with Empty -> e | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e)) let compare cmp m1 m2 = let rec compare_aux e1 e2 = match (e1, e2) with (End, End) -> 0 | (End, _) -> -1 | (_, End) -> 1 | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> let c = Ord.compare v1 v2 in if c <> 0 then c else let c = cmp d1 d2 in if c <> 0 then c else compare_aux (cons_enum r1 e1) (cons_enum r2 e2) in compare_aux (cons_enum m1 End) (cons_enum m2 End) let equal cmp m1 m2 = let rec equal_aux e1 e2 = match (e1, e2) with (End, End) -> true | (End, _) -> false | (_, End) -> false | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> Ord.compare v1 v2 = 0 && cmp d1 d2 && equal_aux (cons_enum r1 e1) (cons_enum r2 e2) in equal_aux (cons_enum m1 End) (cons_enum m2 End) let rec cardinal = function Empty -> 0 | Node(l, _, _, r, _) -> cardinal l + 1 + cardinal r let rec bindings_aux accu = function Empty -> accu | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l let bindings s = bindings_aux [] s let choose = min_binding end mingw-ocaml/ocaml/stdlib/header.c0000644000175000017500000001204612124403240016335 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1998 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* The launcher for bytecode executables (if #! is not working) */ #include #include #include #include "../config/s.h" #ifdef HAS_UNISTD #include #endif #include #include #include #include "../byterun/mlvalues.h" #include "../byterun/exec.h" char * default_runtime_path = RUNTIME_NAME; #ifndef MAXPATHLEN #define MAXPATHLEN 1024 #endif #ifndef S_ISREG #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) #endif #ifndef SEEK_END #define SEEK_END 2 #endif #ifndef __CYGWIN32__ /* Normal Unix search path function */ static char * searchpath(char * name) { static char fullname[MAXPATHLEN + 1]; char * path; char * p; char * q; struct stat st; for (p = name; *p != 0; p++) { if (*p == '/') return name; } path = getenv("PATH"); if (path == NULL) return name; while(1) { for (p = fullname; *path != 0 && *path != ':'; p++, path++) if (p < fullname + MAXPATHLEN) *p = *path; if (p != fullname && p < fullname + MAXPATHLEN) *p++ = '/'; for (q = name; *q != 0; p++, q++) if (p < fullname + MAXPATHLEN) *p = *q; *p = 0; if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) break; if (*path == 0) return name; path++; } return fullname; } #else /* Special version for Cygwin32: takes care of the ".exe" implicit suffix */ static int file_ok(char * name) { int fd; /* Cannot use stat() here because it adds ".exe" implicitly */ fd = open(name, O_RDONLY); if (fd == -1) return 0; close(fd); return 1; } static char * searchpath(char * name) { char * path, * fullname, * p; path = getenv("PATH"); fullname = malloc(strlen(name) + (path == NULL ? 0 : strlen(path)) + 6); /* 6 = "/" plus ".exe" plus final "\0" */ if (fullname == NULL) return name; /* Check for absolute path name */ for (p = name; *p != 0; p++) { if (*p == '/' || *p == '\\') { if (file_ok(name)) return name; strcpy(fullname, name); strcat(fullname, ".exe"); if (file_ok(fullname)) return fullname; return name; } } /* Search in path */ if (path == NULL) return name; while(1) { for (p = fullname; *path != 0 && *path != ':'; p++, path++) *p = *path; if (p != fullname) *p++ = '/'; strcpy(p, name); if (file_ok(fullname)) return fullname; strcat(fullname, ".exe"); if (file_ok(fullname)) return fullname; if (*path == 0) break; path++; } return name; } #endif static unsigned long read_size(char * ptr) { unsigned char * p = (unsigned char *) ptr; return ((unsigned long) p[0] << 24) + ((unsigned long) p[1] << 16) + ((unsigned long) p[2] << 8) + p[3]; } static char * read_runtime_path(int fd) { char buffer[TRAILER_SIZE]; static char runtime_path[MAXPATHLEN]; int num_sections, i; uint32 path_size; long ofs; lseek(fd, (long) -TRAILER_SIZE, SEEK_END); if (read(fd, buffer, TRAILER_SIZE) < TRAILER_SIZE) return NULL; num_sections = read_size(buffer); ofs = TRAILER_SIZE + num_sections * 8; lseek(fd, -ofs, SEEK_END); path_size = 0; for (i = 0; i < num_sections; i++) { if (read(fd, buffer, 8) < 8) return NULL; if (buffer[0] == 'R' && buffer[1] == 'N' && buffer[2] == 'T' && buffer[3] == 'M') { path_size = read_size(buffer + 4); ofs += path_size; } else if (path_size > 0) ofs += read_size(buffer + 4); } if (path_size == 0) return default_runtime_path; if (path_size >= MAXPATHLEN) return NULL; lseek(fd, -ofs, SEEK_END); if (read(fd, runtime_path, path_size) != path_size) return NULL; runtime_path[path_size - 1] = 0; return runtime_path; } static void errwrite(char * msg) { write(2, msg, strlen(msg)); } #ifndef O_BINARY #define O_BINARY 0 #endif int main(int argc, char ** argv) { char * truename, * runtime_path; int fd; truename = searchpath(argv[0]); fd = open(truename, O_RDONLY | O_BINARY); if (fd == -1 || (runtime_path = read_runtime_path(fd)) == NULL) { errwrite(truename); errwrite(" not found or is not a bytecode executable file\n"); return 2; } argv[0] = truename; execv(runtime_path, argv); errwrite("Cannot exec "); errwrite(runtime_path); errwrite("\n"); return 2; } mingw-ocaml/ocaml/stdlib/stringLabels.mli0000644000175000017500000001745012124403240020101 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** String operations. *) external length : string -> int = "%string_length" (** Return the length (number of characters) of the given string. *) external get : string -> int -> char = "%string_safe_get" (** [String.get s n] returns character number [n] in string [s]. The first character is character number 0. The last character is character number [String.length s - 1]. You can also write [s.[n]] instead of [String.get s n]. Raise [Invalid_argument "index out of bounds"] if [n] is outside the range 0 to [(String.length s - 1)]. *) external set : string -> int -> char -> unit = "%string_safe_set" (** [String.set s n c] modifies string [s] in place, replacing the character number [n] by [c]. You can also write [s.[n] <- c] instead of [String.set s n c]. Raise [Invalid_argument "index out of bounds"] if [n] is outside the range 0 to [(String.length s - 1)]. *) external create : int -> string = "caml_create_string" (** [String.create n] returns a fresh string of length [n]. The string initially contains arbitrary characters. Raise [Invalid_argument] if [n < 0] or [n > Sys.max_string_length]. *) val make : int -> char -> string (** [String.make n c] returns a fresh string of length [n], filled with the character [c]. Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.*) val copy : string -> string (** Return a copy of the given string. *) val sub : string -> pos:int -> len:int -> string (** [String.sub s start len] returns a fresh string of length [len], containing the characters number [start] to [start + len - 1] of string [s]. Raise [Invalid_argument] if [start] and [len] do not designate a valid substring of [s]; that is, if [start < 0], or [len < 0], or [start + len > ]{!StringLabels.length}[ s]. *) val fill : string -> pos:int -> len:int -> char -> unit (** [String.fill s start len c] modifies string [s] in place, replacing the characters number [start] to [start + len - 1] by [c]. Raise [Invalid_argument] if [start] and [len] do not designate a valid substring of [s]. *) val blit : src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int -> unit (** [String.blit src srcoff dst dstoff len] copies [len] characters from string [src], starting at character number [srcoff], to string [dst], starting at character number [dstoff]. It works correctly even if [src] and [dst] are the same string, and the source and destination chunks overlap. Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid substring of [src], or if [dstoff] and [len] do not designate a valid substring of [dst]. *) val concat : sep:string -> string list -> string (** [String.concat sep sl] concatenates the list of strings [sl], inserting the separator string [sep] between each. *) val iter : f:(char -> unit) -> string -> unit (** [String.iter f s] applies function [f] in turn to all the characters of [s]. It is equivalent to [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *) val iteri : f:(int -> char -> unit) -> string -> unit (** Same as {!String.iter}, but the function is applied to the index of the element as first argument (counting from 0), and the character itself as second argument. @since 4.00.0 *) val map : f:(char -> char) -> string -> string (** [String.map f s] applies function [f] in turn to all the characters of [s] and stores the results in a new string that is returned. @since 4.00.0 *) val trim : string -> string (** Return a copy of the argument, without leading and trailing whitespace. The characters regarded as whitespace are: [' '], ['\012'], ['\n'], ['\r'], and ['\t']. If there is no whitespace character in the argument, return the original string itself, not a copy. @since 4.00.0 *) val escaped : string -> string (** Return a copy of the argument, with special characters represented by escape sequences, following the lexical conventions of OCaml. If there is no special character in the argument, return the original string itself, not a copy. *) val index : string -> char -> int (** [String.index s c] returns the position of the leftmost occurrence of character [c] in string [s]. Raise [Not_found] if [c] does not occur in [s]. *) val rindex : string -> char -> int (** [String.rindex s c] returns the position of the rightmost occurrence of character [c] in string [s]. Raise [Not_found] if [c] does not occur in [s]. *) val index_from : string -> int -> char -> int (** Same as {!StringLabels.index}, but start searching at the character position given as second argument. [String.index s c] is equivalent to [String.index_from s 0 c].*) val rindex_from : string -> int -> char -> int (** Same as {!StringLabels.rindex}, but start searching at the character position given as second argument. [String.rindex s c] is equivalent to [String.rindex_from s (String.length s - 1) c]. *) val contains : string -> char -> bool (** [String.contains s c] tests if character [c] appears in the string [s]. *) val contains_from : string -> int -> char -> bool (** [String.contains_from s start c] tests if character [c] appears in the substring of [s] starting from [start] to the end of [s]. Raise [Invalid_argument] if [start] is not a valid index of [s]. *) val rcontains_from : string -> int -> char -> bool (** [String.rcontains_from s stop c] tests if character [c] appears in the substring of [s] starting from the beginning of [s] to index [stop]. Raise [Invalid_argument] if [stop] is not a valid index of [s]. *) val uppercase : string -> string (** Return a copy of the argument, with all lowercase letters translated to uppercase, including accented letters of the ISO Latin-1 (8859-1) character set. *) val lowercase : string -> string (** Return a copy of the argument, with all uppercase letters translated to lowercase, including accented letters of the ISO Latin-1 (8859-1) character set. *) val capitalize : string -> string (** Return a copy of the argument, with the first character set to uppercase. *) val uncapitalize : string -> string (** Return a copy of the argument, with the first character set to lowercase. *) type t = string (** An alias for the type of strings. *) val compare: t -> t -> int (** The comparison function for strings, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [String] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) (**/**) (* The following is for system use only. Do not call directly. *) external unsafe_get : string -> int -> char = "%string_unsafe_get" external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" external unsafe_blit : src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int -> unit = "caml_blit_string" "noalloc" external unsafe_fill : string -> pos:int -> len:int -> char -> unit = "caml_fill_string" "noalloc" mingw-ocaml/ocaml/stdlib/filename.ml0000644000175000017500000002157112124403240017056 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) let generic_quote quotequote s = let l = String.length s in let b = Buffer.create (l + 20) in Buffer.add_char b '\''; for i = 0 to l - 1 do if s.[i] = '\'' then Buffer.add_string b quotequote else Buffer.add_char b s.[i] done; Buffer.add_char b '\''; Buffer.contents b (* This function implements the Open Group specification found here: [[1]] http://pubs.opengroup.org/onlinepubs/9699919799/utilities/basename.html In step 1 of [[1]], we choose to return "." for empty input. (for compatibility with previous versions of OCaml) In step 2, we choose to process "//" normally. Step 6 is not implemented: we consider that the [suffix] operand is always absent. Suffixes are handled by [chop_suffix] and [chop_extension]. *) let generic_basename is_dir_sep current_dir_name name = let rec find_end n = if n < 0 then String.sub name 0 1 else if is_dir_sep name n then find_end (n - 1) else find_beg n (n + 1) and find_beg n p = if n < 0 then String.sub name 0 p else if is_dir_sep name n then String.sub name (n + 1) (p - n - 1) else find_beg (n - 1) p in if name = "" then current_dir_name else find_end (String.length name - 1) (* This function implements the Open Group specification found here: [[2]] http://pubs.opengroup.org/onlinepubs/9699919799/utilities/dirname.html In step 6 of [[2]], we choose to process "//" normally. *) let generic_dirname is_dir_sep current_dir_name name = let rec trailing_sep n = if n < 0 then String.sub name 0 1 else if is_dir_sep name n then trailing_sep (n - 1) else base n and base n = if n < 0 then current_dir_name else if is_dir_sep name n then intermediate_sep n else base (n - 1) and intermediate_sep n = if n < 0 then String.sub name 0 1 else if is_dir_sep name n then intermediate_sep (n - 1) else String.sub name 0 (n + 1) in if name = "" then current_dir_name else trailing_sep (String.length name - 1) module Unix = struct let current_dir_name = "." let parent_dir_name = ".." let dir_sep = "/" let is_dir_sep s i = s.[i] = '/' let is_relative n = String.length n < 1 || n.[0] <> '/';; let is_implicit n = is_relative n && (String.length n < 2 || String.sub n 0 2 <> "./") && (String.length n < 3 || String.sub n 0 3 <> "../") let check_suffix name suff = String.length name >= String.length suff && String.sub name (String.length name - String.length suff) (String.length suff) = suff let temp_dir_name = try Sys.getenv "TMPDIR" with Not_found -> "/tmp" let quote = generic_quote "'\\''" let basename = generic_basename is_dir_sep current_dir_name let dirname = generic_dirname is_dir_sep current_dir_name end module Win32 = struct let current_dir_name = "." let parent_dir_name = ".." let dir_sep = "\\" let is_dir_sep s i = let c = s.[i] in c = '/' || c = '\\' || c = ':' let is_relative n = (String.length n < 1 || n.[0] <> '/') && (String.length n < 1 || n.[0] <> '\\') && (String.length n < 2 || n.[1] <> ':') let is_implicit n = is_relative n && (String.length n < 2 || String.sub n 0 2 <> "./") && (String.length n < 2 || String.sub n 0 2 <> ".\\") && (String.length n < 3 || String.sub n 0 3 <> "../") && (String.length n < 3 || String.sub n 0 3 <> "..\\") let check_suffix name suff = String.length name >= String.length suff && (let s = String.sub name (String.length name - String.length suff) (String.length suff) in String.lowercase s = String.lowercase suff) let temp_dir_name = try Sys.getenv "TEMP" with Not_found -> "." let quote s = let l = String.length s in let b = Buffer.create (l + 20) in Buffer.add_char b '\"'; let rec loop i = if i = l then Buffer.add_char b '\"' else match s.[i] with | '\"' -> loop_bs 0 i; | '\\' -> loop_bs 0 i; | c -> Buffer.add_char b c; loop (i+1); and loop_bs n i = if i = l then begin Buffer.add_char b '\"'; add_bs n; end else begin match s.[i] with | '\"' -> add_bs (2*n+1); Buffer.add_char b '\"'; loop (i+1); | '\\' -> loop_bs (n+1) (i+1); | c -> add_bs n; loop i end and add_bs n = for j = 1 to n do Buffer.add_char b '\\'; done in loop 0; Buffer.contents b let has_drive s = let is_letter = function | 'A' .. 'Z' | 'a' .. 'z' -> true | _ -> false in String.length s >= 2 && is_letter s.[0] && s.[1] = ':' let drive_and_path s = if has_drive s then (String.sub s 0 2, String.sub s 2 (String.length s - 2)) else ("", s) let dirname s = let (drive, path) = drive_and_path s in let dir = generic_dirname is_dir_sep current_dir_name path in drive ^ dir let basename s = let (drive, path) = drive_and_path s in generic_basename is_dir_sep current_dir_name path end module Cygwin = struct let current_dir_name = "." let parent_dir_name = ".." let dir_sep = "/" let is_dir_sep = Win32.is_dir_sep let is_relative = Win32.is_relative let is_implicit = Win32.is_implicit let check_suffix = Win32.check_suffix let temp_dir_name = Unix.temp_dir_name let quote = Unix.quote let basename = generic_basename is_dir_sep current_dir_name let dirname = generic_dirname is_dir_sep current_dir_name end let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep, is_relative, is_implicit, check_suffix, temp_dir_name, quote, basename, dirname) = match Sys.os_type with "Unix" -> (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep, Unix.is_dir_sep, Unix.is_relative, Unix.is_implicit, Unix.check_suffix, Unix.temp_dir_name, Unix.quote, Unix.basename, Unix.dirname) | "Win32" -> (Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep, Win32.is_dir_sep, Win32.is_relative, Win32.is_implicit, Win32.check_suffix, Win32.temp_dir_name, Win32.quote, Win32.basename, Win32.dirname) | "Cygwin" -> (Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.dir_sep, Cygwin.is_dir_sep, Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix, Cygwin.temp_dir_name, Cygwin.quote, Cygwin.basename, Cygwin.dirname) | _ -> assert false let concat dirname filename = let l = String.length dirname in if l = 0 || is_dir_sep dirname (l-1) then dirname ^ filename else dirname ^ dir_sep ^ filename let chop_suffix name suff = let n = String.length name - String.length suff in if n < 0 then invalid_arg "Filename.chop_suffix" else String.sub name 0 n let chop_extension name = let rec search_dot i = if i < 0 || is_dir_sep name i then invalid_arg "Filename.chop_extension" else if name.[i] = '.' then String.sub name 0 i else search_dot (i - 1) in search_dot (String.length name - 1) external open_desc: string -> open_flag list -> int -> int = "caml_sys_open" external close_desc: int -> unit = "caml_sys_close" let prng = lazy(Random.State.make_self_init ());; let temp_file_name temp_dir prefix suffix = let rnd = (Random.State.bits (Lazy.force prng)) land 0xFFFFFF in concat temp_dir (Printf.sprintf "%s%06x%s" prefix rnd suffix) ;; let current_temp_dir_name = ref temp_dir_name let set_temp_dir_name s = current_temp_dir_name := s let get_temp_dir_name () = !current_temp_dir_name let temp_file ?(temp_dir = !current_temp_dir_name) prefix suffix = let rec try_name counter = let name = temp_file_name temp_dir prefix suffix in try close_desc(open_desc name [Open_wronly; Open_creat; Open_excl] 0o600); name with Sys_error _ as e -> if counter >= 1000 then raise e else try_name (counter + 1) in try_name 0 let open_temp_file ?(mode = [Open_text]) ?(temp_dir = !current_temp_dir_name) prefix suffix = let rec try_name counter = let name = temp_file_name temp_dir prefix suffix in try (name, open_out_gen (Open_wronly::Open_creat::Open_excl::mode) 0o600 name) with Sys_error _ as e -> if counter >= 1000 then raise e else try_name (counter + 1) in try_name 0 mingw-ocaml/ocaml/stdlib/stream.ml0000644000175000017500000001526712124403240016576 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* The fields of type t are not mutable to preserve polymorphism of the empty stream. This is type safe because the empty stream is never patched. *) type 'a t = { count : int; data : 'a data } and 'a data = Sempty | Scons of 'a * 'a data | Sapp of 'a data * 'a t | Slazy of 'a t Lazy.t | Sgen of 'a gen | Sbuffio of buffio and 'a gen = { mutable curr : 'a option option; func : int -> 'a option } and buffio = { ic : in_channel; buff : string; mutable len : int; mutable ind : int } ;; exception Failure;; exception Error of string;; external count : 'a t -> int = "%field0";; external set_count : 'a t -> int -> unit = "%setfield0";; let set_data (s : 'a t) (d : 'a data) = Obj.set_field (Obj.repr s) 1 (Obj.repr d) ;; let fill_buff b = b.len <- input b.ic b.buff 0 (String.length b.buff); b.ind <- 0 ;; let rec get_data s d = match d with (* Only return a "forced stream", that is either Sempty or Scons(a,_). If d is a generator or a buffer, the item a is seen as extracted from the generator/buffer. Forcing also updates the "count" field of the delayed stream, in the Sapp and Slazy cases (see slazy/lapp implementation below). *) Sempty | Scons (_, _) -> d | Sapp (d1, s2) -> begin match get_data s d1 with Scons (a, d11) -> Scons (a, Sapp (d11, s2)) | Sempty -> set_count s s2.count; get_data s s2.data | _ -> assert false end | Sgen {curr = Some None; _ } -> Sempty | Sgen ({curr = Some(Some a); _ } as g) -> g.curr <- None; Scons(a, d) | Sgen ({curr = None; _} as g) -> (* Warning: anyone using g thinks that an item has been read *) begin match g.func s.count with None -> g.curr <- Some(None); Sempty | Some a -> (* One must not update g.curr here, because there Scons(a,d) result of get_data, if the outer stream s was a Sapp, will be used to update the outer stream to Scons(a,s): there is already a memoization process at the outer layer. If g.curr was updated here, the saved element would be produced twice, once by the outer layer, once by Sgen/g.curr. *) Scons(a, d) end | Sbuffio b -> if b.ind >= b.len then fill_buff b; if b.len == 0 then Sempty else let r = Obj.magic (String.unsafe_get b.buff b.ind) in (* Warning: anyone using g thinks that an item has been read *) b.ind <- succ b.ind; Scons(r, d) | Slazy f -> let s2 = Lazy.force f in set_count s s2.count; get_data s s2.data ;; let rec peek s = (* consult the first item of s *) match s.data with Sempty -> None | Scons (a, _) -> Some a | Sapp (_, _) -> begin match get_data s s.data with | Scons(a, _) as d -> set_data s d; Some a | Sempty -> None | _ -> assert false end | Slazy f -> let s2 = Lazy.force f in set_count s s2.count; set_data s s2.data; peek s | Sgen {curr = Some a; _ } -> a | Sgen ({curr = None; _ } as g) -> let x = g.func s.count in g.curr <- Some x; x | Sbuffio b -> if b.ind >= b.len then fill_buff b; if b.len == 0 then begin set_data s Sempty; None end else Some (Obj.magic (String.unsafe_get b.buff b.ind)) ;; let rec junk s = match s.data with Scons (_, d) -> set_count s (succ s.count); set_data s d | Sgen ({curr = Some _} as g) -> set_count s (succ s.count); g.curr <- None | Sbuffio b -> set_count s (succ s.count); b.ind <- succ b.ind | _ -> match peek s with None -> () | Some _ -> junk s ;; let rec nget n s = if n <= 0 then [], s.data, 0 else match peek s with Some a -> junk s; let (al, d, k) = nget (pred n) s in a :: al, Scons (a, d), succ k | None -> [], s.data, 0 ;; let npeek n s = let (al, d, len) = nget n s in set_count s (s.count - len); set_data s d; al ;; let next s = match peek s with Some a -> junk s; a | None -> raise Failure ;; let empty s = match peek s with Some _ -> raise Failure | None -> () ;; let iter f strm = let rec do_rec () = match peek strm with Some a -> junk strm; ignore(f a); do_rec () | None -> () in do_rec () ;; (* Stream building functions *) let from f = {count = 0; data = Sgen {curr = None; func = f}};; let of_list l = {count = 0; data = List.fold_right (fun x l -> Scons (x, l)) l Sempty} ;; let of_string s = from (fun c -> if c < String.length s then Some s.[c] else None) ;; let of_channel ic = {count = 0; data = Sbuffio {ic = ic; buff = String.create 4096; len = 0; ind = 0}} ;; (* Stream expressions builders *) (* In the slazy and lapp case, we can't statically predict the value of the "count" field. We put a dummy 0 value, which will be updated when the parameter stream is forced (see update code in [get_data] and [peek]). *) let ising i = {count = 0; data = Scons (i, Sempty)};; let icons i s = {count = s.count - 1; data = Scons (i, s.data)};; let iapp i s = {count = i.count; data = Sapp (i.data, s)};; let sempty = {count = 0; data = Sempty};; let slazy f = {count = 0; data = Slazy (lazy (f()))};; let lsing f = {count = 0; data = Slazy (lazy (ising (f())))};; let lcons f s = {count = 0; data = Slazy (lazy (icons (f()) s))};; let lapp f s = {count = 0; data = Slazy (lazy(iapp (f()) s))};; (* For debugging use *) let rec dump f s = print_string "{count = "; print_int s.count; print_string "; data = "; dump_data f s.data; print_string "}"; print_newline () and dump_data f = function Sempty -> print_string "Sempty" | Scons (a, d) -> print_string "Scons ("; f a; print_string ", "; dump_data f d; print_string ")" | Sapp (d1, s2) -> print_string "Sapp ("; dump_data f d1; print_string ", "; dump f s2; print_string ")" | Slazy _ -> print_string "Slazy" | Sgen _ -> print_string "Sgen" | Sbuffio b -> print_string "Sbuffio" ;; mingw-ocaml/ocaml/stdlib/int32.mli0000644000175000017500000001466512124403240016414 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** 32-bit integers. This module provides operations on the type [int32] of signed 32-bit integers. Unlike the built-in [int] type, the type [int32] is guaranteed to be exactly 32-bit wide on all platforms. All arithmetic operations over [int32] are taken modulo 2{^32}. Performance notice: values of type [int32] occupy more memory space than values of type [int], and arithmetic operations on [int32] are generally slower than those on [int]. Use [int32] only when the application requires exact 32-bit arithmetic. *) val zero : int32 (** The 32-bit integer 0. *) val one : int32 (** The 32-bit integer 1. *) val minus_one : int32 (** The 32-bit integer -1. *) external neg : int32 -> int32 = "%int32_neg" (** Unary negation. *) external add : int32 -> int32 -> int32 = "%int32_add" (** Addition. *) external sub : int32 -> int32 -> int32 = "%int32_sub" (** Subtraction. *) external mul : int32 -> int32 -> int32 = "%int32_mul" (** Multiplication. *) external div : int32 -> int32 -> int32 = "%int32_div" (** Integer division. Raise [Division_by_zero] if the second argument is zero. This division rounds the real quotient of its arguments towards zero, as specified for {!Pervasives.(/)}. *) external rem : int32 -> int32 -> int32 = "%int32_mod" (** Integer remainder. If [y] is not zero, the result of [Int32.rem x y] satisfies the following property: [x = Int32.add (Int32.mul (Int32.div x y) y) (Int32.rem x y)]. If [y = 0], [Int32.rem x y] raises [Division_by_zero]. *) val succ : int32 -> int32 (** Successor. [Int32.succ x] is [Int32.add x Int32.one]. *) val pred : int32 -> int32 (** Predecessor. [Int32.pred x] is [Int32.sub x Int32.one]. *) val abs : int32 -> int32 (** Return the absolute value of its argument. *) val max_int : int32 (** The greatest representable 32-bit integer, 2{^31} - 1. *) val min_int : int32 (** The smallest representable 32-bit integer, -2{^31}. *) external logand : int32 -> int32 -> int32 = "%int32_and" (** Bitwise logical and. *) external logor : int32 -> int32 -> int32 = "%int32_or" (** Bitwise logical or. *) external logxor : int32 -> int32 -> int32 = "%int32_xor" (** Bitwise logical exclusive or. *) val lognot : int32 -> int32 (** Bitwise logical negation *) external shift_left : int32 -> int -> int32 = "%int32_lsl" (** [Int32.shift_left x y] shifts [x] to the left by [y] bits. The result is unspecified if [y < 0] or [y >= 32]. *) external shift_right : int32 -> int -> int32 = "%int32_asr" (** [Int32.shift_right x y] shifts [x] to the right by [y] bits. This is an arithmetic shift: the sign bit of [x] is replicated and inserted in the vacated bits. The result is unspecified if [y < 0] or [y >= 32]. *) external shift_right_logical : int32 -> int -> int32 = "%int32_lsr" (** [Int32.shift_right_logical x y] shifts [x] to the right by [y] bits. This is a logical shift: zeroes are inserted in the vacated bits regardless of the sign of [x]. The result is unspecified if [y < 0] or [y >= 32]. *) external of_int : int -> int32 = "%int32_of_int" (** Convert the given integer (type [int]) to a 32-bit integer (type [int32]). *) external to_int : int32 -> int = "%int32_to_int" (** Convert the given 32-bit integer (type [int32]) to an integer (type [int]). On 32-bit platforms, the 32-bit integer is taken modulo 2{^31}, i.e. the high-order bit is lost during the conversion. On 64-bit platforms, the conversion is exact. *) external of_float : float -> int32 = "caml_int32_of_float" (** Convert the given floating-point number to a 32-bit integer, discarding the fractional part (truncate towards 0). The result of the conversion is undefined if, after truncation, the number is outside the range \[{!Int32.min_int}, {!Int32.max_int}\]. *) external to_float : int32 -> float = "caml_int32_to_float" (** Convert the given 32-bit integer to a floating-point number. *) external of_string : string -> int32 = "caml_int32_of_string" (** Convert the given string to a 32-bit integer. The string is read in decimal (by default) or in hexadecimal, octal or binary if the string begins with [0x], [0o] or [0b] respectively. Raise [Failure "int_of_string"] if the given string is not a valid representation of an integer, or if the integer represented exceeds the range of integers representable in type [int32]. *) val to_string : int32 -> string (** Return the string representation of its argument, in signed decimal. *) external bits_of_float : float -> int32 = "caml_int32_bits_of_float" (** Return the internal representation of the given float according to the IEEE 754 floating-point ``single format'' bit layout. Bit 31 of the result represents the sign of the float; bits 30 to 23 represent the (biased) exponent; bits 22 to 0 represent the mantissa. *) external float_of_bits : int32 -> float = "caml_int32_float_of_bits" (** Return the floating-point number whose internal representation, according to the IEEE 754 floating-point ``single format'' bit layout, is the given [int32]. *) type t = int32 (** An alias for the type of 32-bit integers. *) val compare: t -> t -> int (** The comparison function for 32-bit integers, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [Int32] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) (**/**) (** {6 Deprecated functions} *) external format : string -> int32 -> string = "caml_int32_format" (** Do not use this deprecated function. Instead, used {!Printf.sprintf} with a [%l...] format. *) mingw-ocaml/ocaml/stdlib/genlex.ml0000644000175000017500000001743412124403240016563 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) type token = Kwd of string | Ident of string | Int of int | Float of float | String of string | Char of char (* The string buffering machinery *) let initial_buffer = String.create 32 let buffer = ref initial_buffer let bufpos = ref 0 let reset_buffer () = buffer := initial_buffer; bufpos := 0 let store c = if !bufpos >= String.length !buffer then begin let newbuffer = String.create (2 * !bufpos) in String.blit !buffer 0 newbuffer 0 !bufpos; buffer := newbuffer end; String.set !buffer !bufpos c; incr bufpos let get_string () = let s = String.sub !buffer 0 !bufpos in buffer := initial_buffer; s (* The lexer *) let make_lexer keywords = let kwd_table = Hashtbl.create 17 in List.iter (fun s -> Hashtbl.add kwd_table s (Kwd s)) keywords; let ident_or_keyword id = try Hashtbl.find kwd_table id with Not_found -> Ident id and keyword_or_error c = let s = String.make 1 c in try Hashtbl.find kwd_table s with Not_found -> raise (Stream.Error ("Illegal character " ^ s)) in let rec next_token (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (' ' | '\010' | '\013' | '\009' | '\026' | '\012') -> Stream.junk strm__; next_token strm__ | Some ('A'..'Z' | 'a'..'z' | '_' | '\192'..'\255' as c) -> Stream.junk strm__; let s = strm__ in reset_buffer (); store c; ident s | Some ('!' | '%' | '&' | '$' | '#' | '+' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) -> Stream.junk strm__; let s = strm__ in reset_buffer (); store c; ident2 s | Some ('0'..'9' as c) -> Stream.junk strm__; let s = strm__ in reset_buffer (); store c; number s | Some '\'' -> Stream.junk strm__; let c = try char strm__ with Stream.Failure -> raise (Stream.Error "") in begin match Stream.peek strm__ with Some '\'' -> Stream.junk strm__; Some (Char c) | _ -> raise (Stream.Error "") end | Some '"' -> Stream.junk strm__; let s = strm__ in reset_buffer (); Some (String (string s)) | Some '-' -> Stream.junk strm__; neg_number strm__ | Some '(' -> Stream.junk strm__; maybe_comment strm__ | Some c -> Stream.junk strm__; Some (keyword_or_error c) | _ -> None and ident (strm__ : _ Stream.t) = match Stream.peek strm__ with Some ('A'..'Z' | 'a'..'z' | '\192'..'\255' | '0'..'9' | '_' | '\'' as c) -> Stream.junk strm__; let s = strm__ in store c; ident s | _ -> Some (ident_or_keyword (get_string ())) and ident2 (strm__ : _ Stream.t) = match Stream.peek strm__ with Some ('!' | '%' | '&' | '$' | '#' | '+' | '-' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '\\' | '~' | '^' | '|' | '*' as c) -> Stream.junk strm__; let s = strm__ in store c; ident2 s | _ -> Some (ident_or_keyword (get_string ())) and neg_number (strm__ : _ Stream.t) = match Stream.peek strm__ with Some ('0'..'9' as c) -> Stream.junk strm__; let s = strm__ in reset_buffer (); store '-'; store c; number s | _ -> let s = strm__ in reset_buffer (); store '-'; ident2 s and number (strm__ : _ Stream.t) = match Stream.peek strm__ with Some ('0'..'9' as c) -> Stream.junk strm__; let s = strm__ in store c; number s | Some '.' -> Stream.junk strm__; let s = strm__ in store '.'; decimal_part s | Some ('e' | 'E') -> Stream.junk strm__; let s = strm__ in store 'E'; exponent_part s | _ -> Some (Int (int_of_string (get_string ()))) and decimal_part (strm__ : _ Stream.t) = match Stream.peek strm__ with Some ('0'..'9' as c) -> Stream.junk strm__; let s = strm__ in store c; decimal_part s | Some ('e' | 'E') -> Stream.junk strm__; let s = strm__ in store 'E'; exponent_part s | _ -> Some (Float (float_of_string (get_string ()))) and exponent_part (strm__ : _ Stream.t) = match Stream.peek strm__ with Some ('+' | '-' as c) -> Stream.junk strm__; let s = strm__ in store c; end_exponent_part s | _ -> end_exponent_part strm__ and end_exponent_part (strm__ : _ Stream.t) = match Stream.peek strm__ with Some ('0'..'9' as c) -> Stream.junk strm__; let s = strm__ in store c; end_exponent_part s | _ -> Some (Float (float_of_string (get_string ()))) and string (strm__ : _ Stream.t) = match Stream.peek strm__ with Some '"' -> Stream.junk strm__; get_string () | Some '\\' -> Stream.junk strm__; let c = try escape strm__ with Stream.Failure -> raise (Stream.Error "") in let s = strm__ in store c; string s | Some c -> Stream.junk strm__; let s = strm__ in store c; string s | _ -> raise Stream.Failure and char (strm__ : _ Stream.t) = match Stream.peek strm__ with Some '\\' -> Stream.junk strm__; begin try escape strm__ with Stream.Failure -> raise (Stream.Error "") end | Some c -> Stream.junk strm__; c | _ -> raise Stream.Failure and escape (strm__ : _ Stream.t) = match Stream.peek strm__ with Some 'n' -> Stream.junk strm__; '\n' | Some 'r' -> Stream.junk strm__; '\r' | Some 't' -> Stream.junk strm__; '\t' | Some ('0'..'9' as c1) -> Stream.junk strm__; begin match Stream.peek strm__ with Some ('0'..'9' as c2) -> Stream.junk strm__; begin match Stream.peek strm__ with Some ('0'..'9' as c3) -> Stream.junk strm__; Char.chr ((Char.code c1 - 48) * 100 + (Char.code c2 - 48) * 10 + (Char.code c3 - 48)) | _ -> raise (Stream.Error "") end | _ -> raise (Stream.Error "") end | Some c -> Stream.junk strm__; c | _ -> raise Stream.Failure and maybe_comment (strm__ : _ Stream.t) = match Stream.peek strm__ with Some '*' -> Stream.junk strm__; let s = strm__ in comment s; next_token s | _ -> Some (keyword_or_error '(') and comment (strm__ : _ Stream.t) = match Stream.peek strm__ with Some '(' -> Stream.junk strm__; maybe_nested_comment strm__ | Some '*' -> Stream.junk strm__; maybe_end_comment strm__ | Some c -> Stream.junk strm__; comment strm__ | _ -> raise Stream.Failure and maybe_nested_comment (strm__ : _ Stream.t) = match Stream.peek strm__ with Some '*' -> Stream.junk strm__; let s = strm__ in comment s; comment s | Some c -> Stream.junk strm__; comment strm__ | _ -> raise Stream.Failure and maybe_end_comment (strm__ : _ Stream.t) = match Stream.peek strm__ with Some ')' -> Stream.junk strm__; () | Some '*' -> Stream.junk strm__; maybe_end_comment strm__ | Some c -> Stream.junk strm__; comment strm__ | _ -> raise Stream.Failure in fun input -> Stream.from (fun count -> next_token input) mingw-ocaml/ocaml/stdlib/set.ml0000644000175000017500000002623212124403240016070 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Sets over ordered types *) module type OrderedType = sig type t val compare: t -> t -> int end module type S = sig type elt type t val empty: t val is_empty: t -> bool val mem: elt -> t -> bool val add: elt -> t -> t val singleton: elt -> t val remove: elt -> t -> 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 val subset: t -> t -> bool val iter: (elt -> unit) -> t -> unit val fold: (elt -> 'a -> 'a) -> t -> 'a -> '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 split: elt -> t -> t * bool * t end module Make(Ord: OrderedType) = struct type elt = Ord.t type t = Empty | Node of t * elt * t * int (* Sets are represented by balanced binary trees (the heights of the children differ by at most 2 *) let height = function Empty -> 0 | Node(_, _, _, h) -> h (* Creates a new node with left son l, value v and right son r. We must have all elements of l < v < all elements of r. l and r must be balanced and | height l - height r | <= 2. Inline expansion of height for better speed. *) let create l v r = let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) (* Same as create, but performs one step of rebalancing if necessary. Assumes l and r balanced and | height l - height r | <= 3. Inline expansion of create for better speed in the most frequent case where no rebalancing is required. *) let bal l v r = let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in if hl > hr + 2 then begin match l with Empty -> invalid_arg "Set.bal" | Node(ll, lv, lr, _) -> if height ll >= height lr then create ll lv (create lr v r) else begin match lr with Empty -> invalid_arg "Set.bal" | Node(lrl, lrv, lrr, _)-> create (create ll lv lrl) lrv (create lrr v r) end end else if hr > hl + 2 then begin match r with Empty -> invalid_arg "Set.bal" | Node(rl, rv, rr, _) -> if height rr >= height rl then create (create l v rl) rv rr else begin match rl with Empty -> invalid_arg "Set.bal" | Node(rll, rlv, rlr, _) -> create (create l v rll) rlv (create rlr rv rr) end end else Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) (* Insertion of one element *) let rec add x = function Empty -> Node(Empty, x, Empty, 1) | Node(l, v, r, _) as t -> let c = Ord.compare x v in if c = 0 then t else if c < 0 then bal (add x l) v r else bal l v (add x r) let singleton x = Node(Empty, x, Empty, 1) (* Beware: those two functions assume that the added v is *strictly* smaller (or bigger) than all the present elements in the tree; it does not test for equality with the current min (or max) element. Indeed, they are only used during the "join" operation which respects this precondition. *) let rec add_min_element v = function | Empty -> singleton v | Node (l, x, r, h) -> bal (add_min_element v l) x r let rec add_max_element v = function | Empty -> singleton v | Node (l, x, r, h) -> bal l x (add_max_element v r) (* Same as create and bal, but no assumptions are made on the relative heights of l and r. *) let rec join l v r = match (l, r) with (Empty, _) -> add_min_element v r | (_, Empty) -> add_max_element v l | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) -> if lh > rh + 2 then bal ll lv (join lr v r) else if rh > lh + 2 then bal (join l v rl) rv rr else create l v r (* Smallest and greatest element of a set *) let rec min_elt = function Empty -> raise Not_found | Node(Empty, v, r, _) -> v | Node(l, v, r, _) -> min_elt l let rec max_elt = function Empty -> raise Not_found | Node(l, v, Empty, _) -> v | Node(l, v, r, _) -> max_elt r (* Remove the smallest element of the given set *) let rec remove_min_elt = function Empty -> invalid_arg "Set.remove_min_elt" | Node(Empty, v, r, _) -> r | Node(l, v, r, _) -> bal (remove_min_elt l) v r (* Merge two trees l and r into one. All elements of l must precede the elements of r. Assume | height l - height r | <= 2. *) let merge t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (_, _) -> bal t1 (min_elt t2) (remove_min_elt t2) (* Merge two trees l and r into one. All elements of l must precede the elements of r. No assumption on the heights of l and r. *) let concat t1 t2 = match (t1, t2) with (Empty, t) -> t | (t, Empty) -> t | (_, _) -> join t1 (min_elt t2) (remove_min_elt t2) (* Splitting. split x s returns a triple (l, present, r) where - l is the set of elements of s that are < x - r is the set of elements of s that are > x - present is false if s contains no element equal to x, or true if s contains an element equal to x. *) let rec split x = function Empty -> (Empty, false, Empty) | Node(l, v, r, _) -> let c = Ord.compare x v in if c = 0 then (l, true, r) else if c < 0 then let (ll, pres, rl) = split x l in (ll, pres, join rl v r) else let (lr, pres, rr) = split x r in (join l v lr, pres, rr) (* Implementation of the set operations *) let empty = Empty let is_empty = function Empty -> true | _ -> false let rec mem x = function Empty -> false | Node(l, v, r, _) -> let c = Ord.compare x v in c = 0 || mem x (if c < 0 then l else r) let rec remove x = function Empty -> Empty | Node(l, v, r, _) -> let c = Ord.compare x v in if c = 0 then merge l r else if c < 0 then bal (remove x l) v r else bal l v (remove x r) let rec union s1 s2 = match (s1, s2) with (Empty, t2) -> t2 | (t1, Empty) -> t1 | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> if h1 >= h2 then if h2 = 1 then add v2 s1 else begin let (l2, _, r2) = split v1 s2 in join (union l1 l2) v1 (union r1 r2) end else if h1 = 1 then add v1 s2 else begin let (l1, _, r1) = split v2 s1 in join (union l1 l2) v2 (union r1 r2) end let rec inter s1 s2 = match (s1, s2) with (Empty, t2) -> Empty | (t1, Empty) -> Empty | (Node(l1, v1, r1, _), t2) -> match split v1 t2 with (l2, false, r2) -> concat (inter l1 l2) (inter r1 r2) | (l2, true, r2) -> join (inter l1 l2) v1 (inter r1 r2) let rec diff s1 s2 = match (s1, s2) with (Empty, t2) -> Empty | (t1, Empty) -> t1 | (Node(l1, v1, r1, _), t2) -> match split v1 t2 with (l2, false, r2) -> join (diff l1 l2) v1 (diff r1 r2) | (l2, true, r2) -> concat (diff l1 l2) (diff r1 r2) type enumeration = End | More of elt * t * enumeration let rec cons_enum s e = match s with Empty -> e | Node(l, v, r, _) -> cons_enum l (More(v, r, e)) let rec compare_aux e1 e2 = match (e1, e2) with (End, End) -> 0 | (End, _) -> -1 | (_, End) -> 1 | (More(v1, r1, e1), More(v2, r2, e2)) -> let c = Ord.compare v1 v2 in if c <> 0 then c else compare_aux (cons_enum r1 e1) (cons_enum r2 e2) let compare s1 s2 = compare_aux (cons_enum s1 End) (cons_enum s2 End) let equal s1 s2 = compare s1 s2 = 0 let rec subset s1 s2 = match (s1, s2) with Empty, _ -> true | _, Empty -> false | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) -> let c = Ord.compare v1 v2 in if c = 0 then subset l1 l2 && subset r1 r2 else if c < 0 then subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2 else subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2 let rec iter f = function Empty -> () | Node(l, v, r, _) -> iter f l; f v; iter f r let rec fold f s accu = match s with Empty -> accu | Node(l, v, r, _) -> fold f r (f v (fold f l accu)) let rec for_all p = function Empty -> true | Node(l, v, r, _) -> p v && for_all p l && for_all p r let rec exists p = function Empty -> false | Node(l, v, r, _) -> p v || exists p l || exists p r let rec filter p = function Empty -> Empty | Node(l, v, r, _) -> (* call [p] in the expected left-to-right order *) let l' = filter p l in let pv = p v in let r' = filter p r in if pv then join l' v r' else concat l' r' let rec partition p = function Empty -> (Empty, Empty) | Node(l, v, r, _) -> (* call [p] in the expected left-to-right order *) let (lt, lf) = partition p l in let pv = p v in let (rt, rf) = partition p r in if pv then (join lt v rt, concat lf rf) else (concat lt rt, join lf v rf) let rec cardinal = function Empty -> 0 | Node(l, v, r, _) -> cardinal l + 1 + cardinal r let rec elements_aux accu = function Empty -> accu | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l let elements s = elements_aux [] s let choose = min_elt end mingw-ocaml/ocaml/stdlib/callback.mli0000644000175000017500000000331512124403240017177 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Registering OCaml values with the C runtime. This module allows OCaml values to be registered with the C runtime under a symbolic name, so that C code can later call back registered OCaml functions, or raise registered OCaml exceptions. *) val register : string -> 'a -> unit (** [Callback.register n v] registers the value [v] under the name [n]. C code can later retrieve a handle to [v] by calling [caml_named_value(n)]. *) val register_exception : string -> exn -> unit (** [Callback.register_exception n exn] registers the exception contained in the exception value [exn] under the name [n]. C code can later retrieve a handle to the exception by calling [caml_named_value(n)]. The exception value thus obtained is suitable for passing as first argument to [raise_constant] or [raise_with_arg]. *) mingw-ocaml/ocaml/stdlib/int64.ml0000644000175000017500000000515712124403240016244 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [Int64]: 64-bit integers *) external neg : int64 -> int64 = "%int64_neg" external add : int64 -> int64 -> int64 = "%int64_add" external sub : int64 -> int64 -> int64 = "%int64_sub" external mul : int64 -> int64 -> int64 = "%int64_mul" external div : int64 -> int64 -> int64 = "%int64_div" external rem : int64 -> int64 -> int64 = "%int64_mod" external logand : int64 -> int64 -> int64 = "%int64_and" external logor : int64 -> int64 -> int64 = "%int64_or" external logxor : int64 -> int64 -> int64 = "%int64_xor" external shift_left : int64 -> int -> int64 = "%int64_lsl" external shift_right : int64 -> int -> int64 = "%int64_asr" external shift_right_logical : int64 -> int -> int64 = "%int64_lsr" external of_int : int -> int64 = "%int64_of_int" external to_int : int64 -> int = "%int64_to_int" external of_float : float -> int64 = "caml_int64_of_float" external to_float : int64 -> float = "caml_int64_to_float" external of_int32 : int32 -> int64 = "%int64_of_int32" external to_int32 : int64 -> int32 = "%int64_to_int32" external of_nativeint : nativeint -> int64 = "%int64_of_nativeint" external to_nativeint : int64 -> nativeint = "%int64_to_nativeint" let zero = 0L let one = 1L let minus_one = -1L let succ n = add n 1L let pred n = sub n 1L let abs n = if n >= 0L then n else neg n let min_int = 0x8000000000000000L let max_int = 0x7FFFFFFFFFFFFFFFL let lognot n = logxor n (-1L) external format : string -> int64 -> string = "caml_int64_format" let to_string n = format "%d" n external of_string : string -> int64 = "caml_int64_of_string" external bits_of_float : float -> int64 = "caml_int64_bits_of_float" external float_of_bits : int64 -> float = "caml_int64_float_of_bits" type t = int64 let compare (x: t) (y: t) = Pervasives.compare x y mingw-ocaml/ocaml/stdlib/nativeint.mli0000644000175000017500000001656212124403240017454 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Processor-native integers. This module provides operations on the type [nativeint] of signed 32-bit integers (on 32-bit platforms) or signed 64-bit integers (on 64-bit platforms). This integer type has exactly the same width as that of a [long] integer type in the C compiler. All arithmetic operations over [nativeint] are taken modulo 2{^32} or 2{^64} depending on the word size of the architecture. Performance notice: values of type [nativeint] occupy more memory space than values of type [int], and arithmetic operations on [nativeint] are generally slower than those on [int]. Use [nativeint] only when the application requires the extra bit of precision over the [int] type. *) val zero : nativeint (** The native integer 0.*) val one : nativeint (** The native integer 1.*) val minus_one : nativeint (** The native integer -1.*) external neg : nativeint -> nativeint = "%nativeint_neg" (** Unary negation. *) external add : nativeint -> nativeint -> nativeint = "%nativeint_add" (** Addition. *) external sub : nativeint -> nativeint -> nativeint = "%nativeint_sub" (** Subtraction. *) external mul : nativeint -> nativeint -> nativeint = "%nativeint_mul" (** Multiplication. *) external div : nativeint -> nativeint -> nativeint = "%nativeint_div" (** Integer division. Raise [Division_by_zero] if the second argument is zero. This division rounds the real quotient of its arguments towards zero, as specified for {!Pervasives.(/)}. *) external rem : nativeint -> nativeint -> nativeint = "%nativeint_mod" (** Integer remainder. If [y] is not zero, the result of [Nativeint.rem x y] satisfies the following properties: [Nativeint.zero <= Nativeint.rem x y < Nativeint.abs y] and [x = Nativeint.add (Nativeint.mul (Nativeint.div x y) y) (Nativeint.rem x y)]. If [y = 0], [Nativeint.rem x y] raises [Division_by_zero]. *) val succ : nativeint -> nativeint (** Successor. [Nativeint.succ x] is [Nativeint.add x Nativeint.one]. *) val pred : nativeint -> nativeint (** Predecessor. [Nativeint.pred x] is [Nativeint.sub x Nativeint.one]. *) val abs : nativeint -> nativeint (** Return the absolute value of its argument. *) val size : int (** The size in bits of a native integer. This is equal to [32] on a 32-bit platform and to [64] on a 64-bit platform. *) val max_int : nativeint (** The greatest representable native integer, either 2{^31} - 1 on a 32-bit platform, or 2{^63} - 1 on a 64-bit platform. *) val min_int : nativeint (** The greatest representable native integer, either -2{^31} on a 32-bit platform, or -2{^63} on a 64-bit platform. *) external logand : nativeint -> nativeint -> nativeint = "%nativeint_and" (** Bitwise logical and. *) external logor : nativeint -> nativeint -> nativeint = "%nativeint_or" (** Bitwise logical or. *) external logxor : nativeint -> nativeint -> nativeint = "%nativeint_xor" (** Bitwise logical exclusive or. *) val lognot : nativeint -> nativeint (** Bitwise logical negation *) external shift_left : nativeint -> int -> nativeint = "%nativeint_lsl" (** [Nativeint.shift_left x y] shifts [x] to the left by [y] bits. The result is unspecified if [y < 0] or [y >= bitsize], where [bitsize] is [32] on a 32-bit platform and [64] on a 64-bit platform. *) external shift_right : nativeint -> int -> nativeint = "%nativeint_asr" (** [Nativeint.shift_right x y] shifts [x] to the right by [y] bits. This is an arithmetic shift: the sign bit of [x] is replicated and inserted in the vacated bits. The result is unspecified if [y < 0] or [y >= bitsize]. *) external shift_right_logical : nativeint -> int -> nativeint = "%nativeint_lsr" (** [Nativeint.shift_right_logical x y] shifts [x] to the right by [y] bits. This is a logical shift: zeroes are inserted in the vacated bits regardless of the sign of [x]. The result is unspecified if [y < 0] or [y >= bitsize]. *) external of_int : int -> nativeint = "%nativeint_of_int" (** Convert the given integer (type [int]) to a native integer (type [nativeint]). *) external to_int : nativeint -> int = "%nativeint_to_int" (** Convert the given native integer (type [nativeint]) to an integer (type [int]). The high-order bit is lost during the conversion. *) external of_float : float -> nativeint = "caml_nativeint_of_float" (** Convert the given floating-point number to a native integer, discarding the fractional part (truncate towards 0). The result of the conversion is undefined if, after truncation, the number is outside the range \[{!Nativeint.min_int}, {!Nativeint.max_int}\]. *) external to_float : nativeint -> float = "caml_nativeint_to_float" (** Convert the given native integer to a floating-point number. *) external of_int32 : int32 -> nativeint = "%nativeint_of_int32" (** Convert the given 32-bit integer (type [int32]) to a native integer. *) external to_int32 : nativeint -> int32 = "%nativeint_to_int32" (** Convert the given native integer to a 32-bit integer (type [int32]). On 64-bit platforms, the 64-bit native integer is taken modulo 2{^32}, i.e. the top 32 bits are lost. On 32-bit platforms, the conversion is exact. *) external of_string : string -> nativeint = "caml_nativeint_of_string" (** Convert the given string to a native integer. The string is read in decimal (by default) or in hexadecimal, octal or binary if the string begins with [0x], [0o] or [0b] respectively. Raise [Failure "int_of_string"] if the given string is not a valid representation of an integer, or if the integer represented exceeds the range of integers representable in type [nativeint]. *) val to_string : nativeint -> string (** Return the string representation of its argument, in decimal. *) type t = nativeint (** An alias for the type of native integers. *) val compare: t -> t -> int (** The comparison function for native integers, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [Nativeint] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) (**/**) (** {6 Deprecated functions} *) external format : string -> nativeint -> string = "caml_nativeint_format" (** [Nativeint.format fmt n] return the string representation of the native integer [n] in the format specified by [fmt]. [fmt] is a [Printf]-style format consisting of exactly one [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification. This function is deprecated; use {!Printf.sprintf} with a [%nx] format instead. *) mingw-ocaml/ocaml/stdlib/complex.ml0000644000175000017500000000541412124403240016743 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Complex numbers *) type t = { re: float; im: float } let zero = { re = 0.0; im = 0.0 } let one = { re = 1.0; im = 0.0 } let i = { re = 0.0; im = 1.0 } let add x y = { re = x.re +. y.re; im = x.im +. y.im } let sub x y = { re = x.re -. y.re; im = x.im -. y.im } let neg x = { re = -. x.re; im = -. x.im } let conj x = { re = x.re; im = -. x.im } let mul x y = { re = x.re *. y.re -. x.im *. y.im; im = x.re *. y.im +. x.im *. y.re } let div x y = if abs_float y.re >= abs_float y.im then let r = y.im /. y.re in let d = y.re +. r *. y.im in { re = (x.re +. r *. x.im) /. d; im = (x.im -. r *. x.re) /. d } else let r = y.re /. y.im in let d = y.im +. r *. y.re in { re = (r *. x.re +. x.im) /. d; im = (r *. x.im -. x.re) /. d } let inv x = div one x let norm2 x = x.re *. x.re +. x.im *. x.im let norm x = (* Watch out for overflow in computing re^2 + im^2 *) let r = abs_float x.re and i = abs_float x.im in if r = 0.0 then i else if i = 0.0 then r else if r >= i then let q = i /. r in r *. sqrt(1.0 +. q *. q) else let q = r /. i in i *. sqrt(1.0 +. q *. q) let arg x = atan2 x.im x.re let polar n a = { re = cos a *. n; im = sin a *. n } let sqrt x = if x.re = 0.0 && x.im = 0.0 then { re = 0.0; im = 0.0 } else begin let r = abs_float x.re and i = abs_float x.im in let w = if r >= i then begin let q = i /. r in sqrt(r) *. sqrt(0.5 *. (1.0 +. sqrt(1.0 +. q *. q))) end else begin let q = r /. i in sqrt(i) *. sqrt(0.5 *. (q +. sqrt(1.0 +. q *. q))) end in if x.re >= 0.0 then { re = w; im = 0.5 *. x.im /. w } else { re = 0.5 *. i /. w; im = if x.im >= 0.0 then w else -. w } end let exp x = let e = exp x.re in { re = e *. cos x.im; im = e *. sin x.im } let log x = { re = log (norm x); im = atan2 x.im x.re } let pow x y = exp (mul y (log x)) mingw-ocaml/ocaml/stdlib/char.ml0000644000175000017500000000441712124403240016213 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Character operations *) external code: char -> int = "%identity" external unsafe_chr: int -> char = "%identity" let chr n = if n < 0 || n > 255 then invalid_arg "Char.chr" else unsafe_chr n external is_printable: char -> bool = "caml_is_printable" external string_create: int -> string = "caml_create_string" external string_unsafe_get : string -> int -> char = "%string_unsafe_get" external string_unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" let escaped = function | '\'' -> "\\'" | '\\' -> "\\\\" | '\n' -> "\\n" | '\t' -> "\\t" | '\r' -> "\\r" | '\b' -> "\\b" | c -> if is_printable c then begin let s = string_create 1 in string_unsafe_set s 0 c; s end else begin let n = code c in let s = string_create 4 in string_unsafe_set s 0 '\\'; string_unsafe_set s 1 (unsafe_chr (48 + n / 100)); string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10)); string_unsafe_set s 3 (unsafe_chr (48 + n mod 10)); s end let lowercase c = if (c >= 'A' && c <= 'Z') || (c >= '\192' && c <= '\214') || (c >= '\216' && c <= '\222') then unsafe_chr(code c + 32) else c let uppercase c = if (c >= 'a' && c <= 'z') || (c >= '\224' && c <= '\246') || (c >= '\248' && c <= '\254') then unsafe_chr(code c - 32) else c type t = char let compare c1 c2 = code c1 - code c2 mingw-ocaml/ocaml/stdlib/format.mli0000644000175000017500000007320412124403240016737 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Pretty printing. This module implements a pretty-printing facility to format text within ``pretty-printing boxes''. The pretty-printer breaks lines at specified break hints, and indents lines according to the box structure. For a gentle introduction to the basics of pretty-printing using [Format], read {{:http://caml.inria.fr/resources/doc/guides/format.en.html} http://caml.inria.fr/resources/doc/guides/format.en.html}. You may consider this module as providing an extension to the [printf] facility to provide automatic line breaking. The addition of pretty-printing annotations to your regular [printf] formats gives you fancy indentation and line breaks. Pretty-printing annotations are described below in the documentation of the function {!Format.fprintf}. You may also use the explicit box management and printing functions provided by this module. This style is more basic but more verbose than the [fprintf] concise formats. For instance, the sequence [open_box 0; print_string "x ="; print_space (); print_int 1; close_box (); print_newline ()] that prints [x = 1] within a pretty-printing box, can be abbreviated as [printf "@[%s@ %i@]@." "x =" 1], or even shorter [printf "@[x =@ %i@]@." 1]. Rule of thumb for casual users of this library: - use simple boxes (as obtained by [open_box 0]); - use simple break hints (as obtained by [print_cut ()] that outputs a simple break hint, or by [print_space ()] that outputs a space indicating a break hint); - once a box is opened, display its material with basic printing functions (e. g. [print_int] and [print_string]); - when the material for a box has been printed, call [close_box ()] to close the box; - at the end of your routine, flush the pretty-printer to display all the remaining material, e.g. evaluate [print_newline ()]. The behaviour of pretty-printing commands is unspecified if there is no opened pretty-printing box. Each box opened via one of the [open_] functions below must be closed using [close_box] for proper formatting. Otherwise, some of the material printed in the boxes may not be output, or may be formatted incorrectly. In case of interactive use, the system closes all opened boxes and flushes all pending text (as with the [print_newline] function) after each phrase. Each phrase is therefore executed in the initial state of the pretty-printer. Warning: the material output by the following functions is delayed in the pretty-printer queue in order to compute the proper line breaking. Hence, you should not mix calls to the printing functions of the basic I/O system with calls to the functions of this module: this could result in some strange output seemingly unrelated with the evaluation order of printing commands. *) (** {6 Boxes} *) val open_box : int -> unit;; (** [open_box d] opens a new pretty-printing box with offset [d]. This box is the general purpose pretty-printing box. Material in this box is displayed ``horizontal or vertical'': break hints inside the box may lead to a new line, if there is no more room on the line to print the remainder of the box, or if a new line may lead to a new indentation (demonstrating the indentation of the box). When a new line is printed in the box, [d] is added to the current indentation. *) val close_box : unit -> unit;; (** Closes the most recently opened pretty-printing box. *) (** {6 Formatting functions} *) val print_string : string -> unit;; (** [print_string str] prints [str] in the current box. *) val print_as : int -> string -> unit;; (** [print_as len str] prints [str] in the current box. The pretty-printer formats [str] as if it were of length [len]. *) val print_int : int -> unit;; (** Prints an integer in the current box. *) val print_float : float -> unit;; (** Prints a floating point number in the current box. *) val print_char : char -> unit;; (** Prints a character in the current box. *) val print_bool : bool -> unit;; (** Prints a boolean in the current box. *) (** {6 Break hints} *) val print_space : unit -> unit;; (** [print_space ()] is used to separate items (typically to print a space between two words). It indicates that the line may be split at this point. It either prints one space or splits the line. It is equivalent to [print_break 1 0]. *) val print_cut : unit -> unit;; (** [print_cut ()] is used to mark a good break position. It indicates that the line may be split at this point. It either prints nothing or splits the line. This allows line splitting at the current point, without printing spaces or adding indentation. It is equivalent to [print_break 0 0]. *) val print_break : int -> int -> unit;; (** Inserts a break hint in a pretty-printing box. [print_break nspaces offset] indicates that the line may be split (a newline character is printed) at this point, if the contents of the current box does not fit on the current line. If the line is split at that point, [offset] is added to the current indentation. If the line is not split, [nspaces] spaces are printed. *) val print_flush : unit -> unit;; (** Flushes the pretty printer: all opened boxes are closed, and all pending text is displayed. *) val print_newline : unit -> unit;; (** Equivalent to [print_flush] followed by a new line. *) val force_newline : unit -> unit;; (** Forces a newline in the current box. Not the normal way of pretty-printing, you should prefer break hints. *) val print_if_newline : unit -> unit;; (** Executes the next formatting command if the preceding line has just been split. Otherwise, ignore the next formatting command. *) (** {6 Margin} *) val set_margin : int -> unit;; (** [set_margin d] sets the value of the right margin to [d] (in characters): this value is used to detect line overflows that leads to split lines. Nothing happens if [d] is smaller than 2. If [d] is too large, the right margin is set to the maximum admissible value (which is greater than [10^9]). *) val get_margin : unit -> int;; (** Returns the position of the right margin. *) (** {6 Maximum indentation limit} *) val set_max_indent : int -> unit;; (** [set_max_indent d] sets the value of the maximum indentation limit to [d] (in characters): once this limit is reached, boxes are rejected to the left, if they do not fit on the current line. Nothing happens if [d] is smaller than 2. If [d] is too large, the limit is set to the maximum admissible value (which is greater than [10^9]). *) val get_max_indent : unit -> int;; (** Return the value of the maximum indentation limit (in characters). *) (** {6 Formatting depth: maximum number of boxes allowed before ellipsis} *) val set_max_boxes : int -> unit;; (** [set_max_boxes max] sets the maximum number of boxes simultaneously opened. Material inside boxes nested deeper is printed as an ellipsis (more precisely as the text returned by [get_ellipsis_text ()]). Nothing happens if [max] is smaller than 2. *) val get_max_boxes : unit -> int;; (** Returns the maximum number of boxes allowed before ellipsis. *) val over_max_boxes : unit -> bool;; (** Tests if the maximum number of boxes allowed have already been opened. *) (** {6 Advanced formatting} *) val open_hbox : unit -> unit;; (** [open_hbox ()] opens a new pretty-printing box. This box is ``horizontal'': the line is not split in this box (new lines may still occur inside boxes nested deeper). *) val open_vbox : int -> unit;; (** [open_vbox d] opens a new pretty-printing box with offset [d]. This box is ``vertical'': every break hint inside this box leads to a new line. When a new line is printed in the box, [d] is added to the current indentation. *) val open_hvbox : int -> unit;; (** [open_hvbox d] opens a new pretty-printing box with offset [d]. This box is ``horizontal-vertical'': it behaves as an ``horizontal'' box if it fits on a single line, otherwise it behaves as a ``vertical'' box. When a new line is printed in the box, [d] is added to the current indentation. *) val open_hovbox : int -> unit;; (** [open_hovbox d] opens a new pretty-printing box with offset [d]. This box is ``horizontal or vertical'': break hints inside this box may lead to a new line, if there is no more room on the line to print the remainder of the box. When a new line is printed in the box, [d] is added to the current indentation. *) (** {6 Tabulations} *) val open_tbox : unit -> unit;; (** Opens a tabulation box. *) val close_tbox : unit -> unit;; (** Closes the most recently opened tabulation box. *) val print_tbreak : int -> int -> unit;; (** Break hint in a tabulation box. [print_tbreak spaces offset] moves the insertion point to the next tabulation ([spaces] being added to this position). Nothing occurs if insertion point is already on a tabulation mark. If there is no next tabulation on the line, then a newline is printed and the insertion point moves to the first tabulation of the box. If a new line is printed, [offset] is added to the current indentation. *) val set_tab : unit -> unit;; (** Sets a tabulation mark at the current insertion point. *) val print_tab : unit -> unit;; (** [print_tab ()] is equivalent to [print_tbreak 0 0]. *) (** {6 Ellipsis} *) val set_ellipsis_text : string -> unit;; (** Set the text of the ellipsis printed when too many boxes are opened (a single dot, [.], by default). *) val get_ellipsis_text : unit -> string;; (** Return the text of the ellipsis. *) (** {6:tags Semantics Tags} *) type tag = string;; (** {i Semantics tags} (or simply {e tags}) are used to decorate printed entities for user's defined purposes, e.g. setting font and giving size indications for a display device, or marking delimitation of semantics entities (e.g. HTML or TeX elements or terminal escape sequences). By default, those tags do not influence line breaking calculation: the tag ``markers'' are not considered as part of the printing material that drives line breaking (in other words, the length of those strings is considered as zero for line breaking). Thus, tag handling is in some sense transparent to pretty-printing and does not interfere with usual pretty-printing. Hence, a single pretty printing routine can output both simple ``verbatim'' material or richer decorated output depending on the treatment of tags. By default, tags are not active, hence the output is not decorated with tag information. Once [set_tags] is set to [true], the pretty printer engine honours tags and decorates the output accordingly. When a tag has been opened (or closed), it is both and successively ``printed'' and ``marked''. Printing a tag means calling a formatter specific function with the name of the tag as argument: that ``tag printing'' function can then print any regular material to the formatter (so that this material is enqueued as usual in the formatter queue for further line-breaking computation). Marking a tag means to output an arbitrary string (the ``tag marker''), directly into the output device of the formatter. Hence, the formatter specific ``tag marking'' function must return the tag marker string associated to its tag argument. Being flushed directly into the output device of the formatter, tag marker strings are not considered as part of the printing material that drives line breaking (in other words, the length of the strings corresponding to tag markers is considered as zero for line breaking). In addition, advanced users may take advantage of the specificity of tag markers to be precisely output when the pretty printer has already decided where to break the lines, and precisely when the queue is flushed into the output device. In the spirit of HTML tags, the default tag marking functions output tags enclosed in "<" and ">": hence, the opening marker of tag [t] is [""] and the closing marker [""]. Default tag printing functions just do nothing. Tag marking and tag printing functions are user definable and can be set by calling [set_formatter_tag_functions]. *) val open_tag : tag -> unit;; (** [open_tag t] opens the tag named [t]; the [print_open_tag] function of the formatter is called with [t] as argument; the tag marker [mark_open_tag t] will be flushed into the output device of the formatter. *) val close_tag : unit -> unit;; (** [close_tag ()] closes the most recently opened tag [t]. In addition, the [print_close_tag] function of the formatter is called with [t] as argument. The marker [mark_close_tag t] will be flushed into the output device of the formatter. *) val set_tags : bool -> unit;; (** [set_tags b] turns on or off the treatment of tags (default is off). *) val set_print_tags : bool -> unit;; val set_mark_tags : bool -> unit;; (** [set_print_tags b] turns on or off the printing of tags, while [set_mark_tags b] turns on or off the output of tag markers. *) val get_print_tags : unit -> bool;; val get_mark_tags : unit -> bool;; (** Return the current status of tags printing and tags marking. *) (** {6 Redirecting the standard formatter output} *) val set_formatter_out_channel : Pervasives.out_channel -> unit;; (** Redirect the pretty-printer output to the given channel. (All the output functions of the standard formatter are set to the default output functions printing to the given channel.) *) val set_formatter_output_functions : (string -> int -> int -> unit) -> (unit -> unit) -> unit ;; (** [set_formatter_output_functions out flush] redirects the relevant pretty-printer output functions to the functions [out] and [flush]. The [out] function performs the pretty-printer string output. It is called with a string [s], a start position [p], and a number of characters [n]; it is supposed to output characters [p] to [p + n - 1] of [s]. The [flush] function is called whenever the pretty-printer is flushed (via conversion [%!], pretty-printing indications [@?] or [@.], or using low level function [print_flush] or [print_newline]). *) val get_formatter_output_functions : unit -> (string -> int -> int -> unit) * (unit -> unit) ;; (** Return the current output functions of the pretty-printer. *) (** {6:meaning Changing the meaning of standard formatter pretty printing} *) (** The [Format] module is versatile enough to let you completely redefine the meaning of pretty printing: you may provide your own functions to define how to handle indentation, line breaking, and even printing of all the characters that have to be printed! *) val set_all_formatter_output_functions : out:(string -> int -> int -> unit) -> flush:(unit -> unit) -> newline:(unit -> unit) -> spaces:(int -> unit) -> unit ;; (** [set_all_formatter_output_functions out flush outnewline outspace] redirects the pretty-printer output to the functions [out] and [flush] as described in [set_formatter_output_functions]. In addition, the pretty-printer function that outputs a newline is set to the function [outnewline] and the function that outputs indentation spaces is set to the function [outspace]. This way, you can change the meaning of indentation (which can be something else than just printing space characters) and the meaning of new lines opening (which can be connected to any other action needed by the application at hand). The two functions [outspace] and [outnewline] are normally connected to [out] and [flush]: respective default values for [outspace] and [outnewline] are [out (String.make n ' ') 0 n] and [out "\n" 0 1]. *) val get_all_formatter_output_functions : unit -> (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) * (int -> unit) ;; (** Return the current output functions of the pretty-printer, including line breaking and indentation functions. Useful to record the current setting and restore it afterwards. *) (** {6:tagsmeaning Changing the meaning of printing semantics tags} *) type formatter_tag_functions = { mark_open_tag : tag -> string; mark_close_tag : tag -> string; print_open_tag : tag -> unit; print_close_tag : tag -> unit; } ;; (** The tag handling functions specific to a formatter: [mark] versions are the ``tag marking'' functions that associate a string marker to a tag in order for the pretty-printing engine to flush those markers as 0 length tokens in the output device of the formatter. [print] versions are the ``tag printing'' functions that can perform regular printing when a tag is closed or opened. *) val set_formatter_tag_functions : formatter_tag_functions -> unit ;; (** [set_formatter_tag_functions tag_funs] changes the meaning of opening and closing tags to use the functions in [tag_funs]. When opening a tag name [t], the string [t] is passed to the opening tag marking function (the [mark_open_tag] field of the record [tag_funs]), that must return the opening tag marker for that name. When the next call to [close_tag ()] happens, the tag name [t] is sent back to the closing tag marking function (the [mark_close_tag] field of record [tag_funs]), that must return a closing tag marker for that name. The [print_] field of the record contains the functions that are called at tag opening and tag closing time, to output regular material in the pretty-printer queue. *) val get_formatter_tag_functions : unit -> formatter_tag_functions ;; (** Return the current tag functions of the pretty-printer. *) (** {6 Multiple formatted output} *) type formatter;; (** Abstract data corresponding to a pretty-printer (also called a formatter) and all its machinery. Defining new pretty-printers permits unrelated output of material in parallel on several output channels. All the parameters of a pretty-printer are local to this pretty-printer: margin, maximum indentation limit, maximum number of boxes simultaneously opened, ellipsis, and so on, are specific to each pretty-printer and may be fixed independently. Given a [Pervasives.out_channel] output channel [oc], a new formatter writing to that channel is simply obtained by calling [formatter_of_out_channel oc]. Alternatively, the [make_formatter] function allocates a new formatter with explicit output and flushing functions (convenient to output material to strings for instance). *) val formatter_of_out_channel : out_channel -> formatter;; (** [formatter_of_out_channel oc] returns a new formatter that writes to the corresponding channel [oc]. *) val std_formatter : formatter;; (** The standard formatter used by the formatting functions above. It is defined as [formatter_of_out_channel stdout]. *) val err_formatter : formatter;; (** A formatter to use with formatting functions below for output to standard error. It is defined as [formatter_of_out_channel stderr]. *) val formatter_of_buffer : Buffer.t -> formatter;; (** [formatter_of_buffer b] returns a new formatter writing to buffer [b]. As usual, the formatter has to be flushed at the end of pretty printing, using [pp_print_flush] or [pp_print_newline], to display all the pending material. *) val stdbuf : Buffer.t;; (** The string buffer in which [str_formatter] writes. *) val str_formatter : formatter;; (** A formatter to use with formatting functions below for output to the [stdbuf] string buffer. [str_formatter] is defined as [formatter_of_buffer stdbuf]. *) val flush_str_formatter : unit -> string;; (** Returns the material printed with [str_formatter], flushes the formatter and resets the corresponding buffer. *) val make_formatter : (string -> int -> int -> unit) -> (unit -> unit) -> formatter ;; (** [make_formatter out flush] returns a new formatter that writes according to the output function [out], and the flushing function [flush]. For instance, a formatter to the [Pervasives.out_channel] [oc] is returned by [make_formatter (Pervasives.output oc) (fun () -> Pervasives.flush oc)]. *) (** {6 Basic functions to use with formatters} *) 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_open_tag : formatter -> string -> unit;; val pp_close_tag : 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_tags : formatter -> bool -> unit;; val pp_set_print_tags : formatter -> bool -> unit;; val pp_set_mark_tags : formatter -> bool -> unit;; val pp_get_print_tags : formatter -> unit -> bool;; val pp_get_mark_tags : formatter -> unit -> bool;; 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_formatter_output_functions : formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit) ;; val pp_set_all_formatter_output_functions : formatter -> out:(string -> int -> int -> unit) -> flush:(unit -> unit) -> newline:(unit -> unit) -> spaces:(int -> unit) -> unit ;; val pp_get_all_formatter_output_functions : formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) * (int -> unit) ;; val pp_set_formatter_tag_functions : formatter -> formatter_tag_functions -> unit ;; val pp_get_formatter_tag_functions : formatter -> unit -> formatter_tag_functions ;; (** These functions are the basic ones: usual functions operating on the standard formatter are defined via partial evaluation of these primitives. For instance, [print_string] is equal to [pp_print_string std_formatter]. *) (** {6 [printf] like functions for pretty-printing.} *) val fprintf : formatter -> ('a, formatter, unit) format -> 'a;; (** [fprintf ff fmt arg1 ... argN] formats the arguments [arg1] to [argN] according to the format string [fmt], and outputs the resulting string on the formatter [ff]. The format [fmt] is a character string which contains three types of objects: plain characters and conversion specifications as specified in the [Printf] module, and pretty-printing indications specific to the [Format] module. The pretty-printing indication characters are introduced by a [@] character, and their meanings are: - [@\[]: open a pretty-printing box. The type and offset of the box may be optionally specified with the following syntax: the [<] character, followed by an optional box type indication, then an optional integer offset, and the closing [>] character. Box type is one of [h], [v], [hv], [b], or [hov], which stand respectively for an horizontal box, a vertical box, an ``horizontal-vertical'' box, or an ``horizontal or vertical'' box ([b] standing for an ``horizontal or vertical'' box demonstrating indentation and [hov] standing for a regular``horizontal or vertical'' box). For instance, [@\[] opens an ``horizontal or vertical'' box with indentation 2 as obtained with [open_hovbox 2]. For more details about boxes, see the various box opening functions [open_*box]. - [@\]]: close the most recently opened pretty-printing box. - [@,]: output a good break as with [print_cut ()]. - [@ ]: output a space, as with [print_space ()]. - [@\n]: force a newline, as with [force_newline ()]. - [@;]: output a good break as with [print_break]. The [nspaces] and [offset] parameters of the break may be optionally specified with the following syntax: the [<] character, followed by an integer [nspaces] value, then an integer [offset], and a closing [>] character. If no parameters are provided, the good break defaults to a space. - [@?]: flush the pretty printer as with [print_flush ()]. This is equivalent to the conversion [%!]. - [@.]: flush the pretty printer and output a new line, as with [print_newline ()]. - [@]: print the following item as if it were of length [n]. Hence, [printf "@<0>%s" arg] prints [arg] as a zero length string. If [@] is not followed by a conversion specification, then the following character of the format is printed as if it were of length [n]. - [@\{]: open a tag. The name of the tag may be optionally specified with the following syntax: the [<] character, followed by an optional string specification, and the closing [>] character. The string specification is any character string that does not contain the closing character ['>']. If omitted, the tag name defaults to the empty string. For more details about tags, see the functions [open_tag] and [close_tag]. - [@\}]: close the most recently opened tag. Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to [open_box (); print_string "x ="; print_space (); print_int 1; close_box (); print_newline ()]. It prints [x = 1] within a pretty-printing box. Note: the old [@@] ``pretty-printing indication'' is now deprecated, since it had no pretty-printing indication semantics. If you need to prevent the pretty-printing indication interpretation of a [@] character, simply use the regular way to escape a character in format string: write [%@]. @since 3.12.2. *) val printf : ('a, formatter, unit) format -> 'a;; (** Same as [fprintf] above, but output on [std_formatter]. *) val eprintf : ('a, formatter, unit) format -> 'a;; (** Same as [fprintf] above, but output on [err_formatter]. *) val sprintf : ('a, unit, string) format -> 'a;; (** Same as [printf] above, but instead of printing on a formatter, returns a string containing the result of formatting the arguments. Note that the pretty-printer queue is flushed at the end of {e each call} to [sprintf]. In case of multiple and related calls to [sprintf] to output material on a single string, you should consider using [fprintf] with the predefined formatter [str_formatter] and call [flush_str_formatter ()] to get the final result. Alternatively, you can use [Format.fprintf] with a formatter writing to a buffer of your own: flushing the formatter and the buffer at the end of pretty-printing returns the desired string. *) val ifprintf : formatter -> ('a, formatter, unit) format -> 'a;; (** Same as [fprintf] above, but does not print anything. Useful to ignore some material when conditionally printing. @since 3.10.0 *) (** Formatted output functions with continuations. *) val kfprintf : (formatter -> 'a) -> formatter -> ('b, formatter, unit, 'a) format4 -> 'b ;; (** Same as [fprintf] above, but instead of returning immediately, passes the formatter to its first argument at the end of printing. *) val ikfprintf : (formatter -> 'a) -> formatter -> ('b, formatter, unit, 'a) format4 -> 'b ;; (** Same as [kfprintf] above, but does not print anything. Useful to ignore some material when conditionally printing. @since 3.12.0 *) val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; (** Same as [sprintf] above, but instead of returning the string, passes it to the first argument. *) (** {6 Deprecated} *) val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a;; (** A deprecated and error prone function. Do not use it. If you need to print to some buffer [b], you must first define a formatter writing to [b], using [let to_b = formatter_of_buffer b]; then use regular calls to [Format.fprintf] on formatter [to_b]. *) val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; (** A deprecated synonym for [ksprintf]. *) mingw-ocaml/ocaml/stdlib/int64.mli0000644000175000017500000001647112124403240016416 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** 64-bit integers. This module provides operations on the type [int64] of signed 64-bit integers. Unlike the built-in [int] type, the type [int64] is guaranteed to be exactly 64-bit wide on all platforms. All arithmetic operations over [int64] are taken modulo 2{^64} Performance notice: values of type [int64] occupy more memory space than values of type [int], and arithmetic operations on [int64] are generally slower than those on [int]. Use [int64] only when the application requires exact 64-bit arithmetic. *) val zero : int64 (** The 64-bit integer 0. *) val one : int64 (** The 64-bit integer 1. *) val minus_one : int64 (** The 64-bit integer -1. *) external neg : int64 -> int64 = "%int64_neg" (** Unary negation. *) external add : int64 -> int64 -> int64 = "%int64_add" (** Addition. *) external sub : int64 -> int64 -> int64 = "%int64_sub" (** Subtraction. *) external mul : int64 -> int64 -> int64 = "%int64_mul" (** Multiplication. *) external div : int64 -> int64 -> int64 = "%int64_div" (** Integer division. Raise [Division_by_zero] if the second argument is zero. This division rounds the real quotient of its arguments towards zero, as specified for {!Pervasives.(/)}. *) external rem : int64 -> int64 -> int64 = "%int64_mod" (** Integer remainder. If [y] is not zero, the result of [Int64.rem x y] satisfies the following property: [x = Int64.add (Int64.mul (Int64.div x y) y) (Int64.rem x y)]. If [y = 0], [Int64.rem x y] raises [Division_by_zero]. *) val succ : int64 -> int64 (** Successor. [Int64.succ x] is [Int64.add x Int64.one]. *) val pred : int64 -> int64 (** Predecessor. [Int64.pred x] is [Int64.sub x Int64.one]. *) val abs : int64 -> int64 (** Return the absolute value of its argument. *) val max_int : int64 (** The greatest representable 64-bit integer, 2{^63} - 1. *) val min_int : int64 (** The smallest representable 64-bit integer, -2{^63}. *) external logand : int64 -> int64 -> int64 = "%int64_and" (** Bitwise logical and. *) external logor : int64 -> int64 -> int64 = "%int64_or" (** Bitwise logical or. *) external logxor : int64 -> int64 -> int64 = "%int64_xor" (** Bitwise logical exclusive or. *) val lognot : int64 -> int64 (** Bitwise logical negation *) external shift_left : int64 -> int -> int64 = "%int64_lsl" (** [Int64.shift_left x y] shifts [x] to the left by [y] bits. The result is unspecified if [y < 0] or [y >= 64]. *) external shift_right : int64 -> int -> int64 = "%int64_asr" (** [Int64.shift_right x y] shifts [x] to the right by [y] bits. This is an arithmetic shift: the sign bit of [x] is replicated and inserted in the vacated bits. The result is unspecified if [y < 0] or [y >= 64]. *) external shift_right_logical : int64 -> int -> int64 = "%int64_lsr" (** [Int64.shift_right_logical x y] shifts [x] to the right by [y] bits. This is a logical shift: zeroes are inserted in the vacated bits regardless of the sign of [x]. The result is unspecified if [y < 0] or [y >= 64]. *) external of_int : int -> int64 = "%int64_of_int" (** Convert the given integer (type [int]) to a 64-bit integer (type [int64]). *) external to_int : int64 -> int = "%int64_to_int" (** Convert the given 64-bit integer (type [int64]) to an integer (type [int]). On 64-bit platforms, the 64-bit integer is taken modulo 2{^63}, i.e. the high-order bit is lost during the conversion. On 32-bit platforms, the 64-bit integer is taken modulo 2{^31}, i.e. the top 33 bits are lost during the conversion. *) external of_float : float -> int64 = "caml_int64_of_float" (** Convert the given floating-point number to a 64-bit integer, discarding the fractional part (truncate towards 0). The result of the conversion is undefined if, after truncation, the number is outside the range \[{!Int64.min_int}, {!Int64.max_int}\]. *) external to_float : int64 -> float = "caml_int64_to_float" (** Convert the given 64-bit integer to a floating-point number. *) external of_int32 : int32 -> int64 = "%int64_of_int32" (** Convert the given 32-bit integer (type [int32]) to a 64-bit integer (type [int64]). *) external to_int32 : int64 -> int32 = "%int64_to_int32" (** Convert the given 64-bit integer (type [int64]) to a 32-bit integer (type [int32]). The 64-bit integer is taken modulo 2{^32}, i.e. the top 32 bits are lost during the conversion. *) external of_nativeint : nativeint -> int64 = "%int64_of_nativeint" (** Convert the given native integer (type [nativeint]) to a 64-bit integer (type [int64]). *) external to_nativeint : int64 -> nativeint = "%int64_to_nativeint" (** Convert the given 64-bit integer (type [int64]) to a native integer. On 32-bit platforms, the 64-bit integer is taken modulo 2{^32}. On 64-bit platforms, the conversion is exact. *) external of_string : string -> int64 = "caml_int64_of_string" (** Convert the given string to a 64-bit integer. The string is read in decimal (by default) or in hexadecimal, octal or binary if the string begins with [0x], [0o] or [0b] respectively. Raise [Failure "int_of_string"] if the given string is not a valid representation of an integer, or if the integer represented exceeds the range of integers representable in type [int64]. *) val to_string : int64 -> string (** Return the string representation of its argument, in decimal. *) external bits_of_float : float -> int64 = "caml_int64_bits_of_float" (** Return the internal representation of the given float according to the IEEE 754 floating-point ``double format'' bit layout. Bit 63 of the result represents the sign of the float; bits 62 to 52 represent the (biased) exponent; bits 51 to 0 represent the mantissa. *) external float_of_bits : int64 -> float = "caml_int64_float_of_bits" (** Return the floating-point number whose internal representation, according to the IEEE 754 floating-point ``double format'' bit layout, is the given [int64]. *) type t = int64 (** An alias for the type of 64-bit integers. *) val compare: t -> t -> int (** The comparison function for 64-bit integers, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [Int64] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) (**/**) (** {6 Deprecated functions} *) external format : string -> int64 -> string = "caml_int64_format" (** Do not use this deprecated function. Instead, used {!Printf.sprintf} with a [%L...] format. *) mingw-ocaml/ocaml/stdlib/genlex.mli0000644000175000017500000000621012124403240016722 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** A generic lexical analyzer. This module implements a simple ``standard'' lexical analyzer, presented as a function from character streams to token streams. It implements roughly the lexical conventions of OCaml, but is parameterized by the set of keywords of your language. Example: a lexer suitable for a desk calculator is obtained by {[ let lexer = make_lexer ["+";"-";"*";"/";"let";"="; "("; ")"] ]} The associated parser would be a function from [token stream] to, for instance, [int], and would have rules such as: {[ let parse_expr = parser [< 'Int n >] -> n | [< 'Kwd "("; n = parse_expr; 'Kwd ")" >] -> n | [< n1 = parse_expr; n2 = parse_remainder n1 >] -> n2 and parse_remainder n1 = parser [< 'Kwd "+"; n2 = parse_expr >] -> n1+n2 | ... ]} One should notice that the use of the [parser] keyword and associated notation for streams are only available through camlp4 extensions. This means that one has to preprocess its sources {i e. g.} by using the ["-pp"] command-line switch of the compilers. *) (** The type of tokens. The lexical classes are: [Int] and [Float] for integer and floating-point numbers; [String] for string literals, enclosed in double quotes; [Char] for character literals, enclosed in single quotes; [Ident] for identifiers (either sequences of letters, digits, underscores and quotes, or sequences of ``operator characters'' such as [+], [*], etc); and [Kwd] for keywords (either identifiers or single ``special characters'' such as [(], [}], etc). *) type token = Kwd of string | Ident of string | Int of int | Float of float | String of string | Char of char val make_lexer : string list -> char Stream.t -> token Stream.t (** Construct the lexer function. The first argument is the list of keywords. An identifier [s] is returned as [Kwd s] if [s] belongs to this list, and as [Ident s] otherwise. A special character [s] is returned as [Kwd s] if [s] belongs to this list, and cause a lexical error (exception [Parse_error]) otherwise. Blanks and newlines are skipped. Comments delimited by [(*] and [*)] are skipped as well, and can be nested. *) mingw-ocaml/ocaml/stdlib/arrayLabels.ml0000644000175000017500000000170612124403240017535 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [ArrayLabels]: labelled Array module *) include Array mingw-ocaml/ocaml/stdlib/stdLabels.mli0000644000175000017500000001530512124403240017362 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Standard labeled libraries. This meta-module provides labelized version of the {!Array}, {!List} and {!String} modules. They only differ by their labels. Detailed interfaces can be found in [arrayLabels.mli], [listLabels.mli] and [stringLabels.mli]. *) module Array : sig external length : 'a array -> int = "%array_length" external get : 'a array -> int -> 'a = "%array_safe_get" external set : 'a array -> int -> 'a -> unit = "%array_safe_set" external make : int -> 'a -> 'a array = "caml_make_vect" external create : int -> 'a -> 'a array = "caml_make_vect" val init : int -> f:(int -> 'a) -> 'a array val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array val append : 'a array -> 'a array -> 'a array val concat : 'a array list -> 'a array val sub : 'a array -> pos:int -> len:int -> 'a array val copy : 'a array -> 'a array val fill : 'a array -> pos:int -> len:int -> 'a -> unit val blit : src:'a array -> src_pos:int -> dst:'a array -> dst_pos:int -> len:int -> unit val to_list : 'a array -> 'a list val of_list : 'a list -> 'a array val iter : f:('a -> unit) -> 'a array -> unit val map : f:('a -> 'b) -> 'a array -> 'b array val iteri : f:(int -> 'a -> unit) -> 'a array -> unit val mapi : f:(int -> 'a -> 'b) -> 'a array -> 'b array val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b array -> 'a val fold_right : f:('a -> 'b -> 'b) -> 'a array -> init:'b -> 'b val sort : cmp:('a -> 'a -> int) -> 'a array -> unit val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" end module List : sig val length : 'a list -> int val hd : 'a list -> 'a val tl : 'a list -> 'a list val nth : 'a list -> int -> 'a val rev : 'a list -> 'a list val append : 'a list -> 'a list -> 'a list val rev_append : 'a list -> 'a list -> 'a list val concat : 'a list list -> 'a list val flatten : 'a list list -> 'a list val iter : f:('a -> unit) -> 'a list -> unit val map : f:('a -> 'b) -> 'a list -> 'b list val rev_map : f:('a -> 'b) -> 'a list -> 'b list val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b list -> 'a val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val fold_left2 : f:('a -> 'b -> 'c -> 'a) -> init:'a -> 'b list -> 'c list -> 'a val fold_right2 : f:('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> init:'c -> 'c val for_all : f:('a -> bool) -> 'a list -> bool val exists : f:('a -> bool) -> 'a list -> bool val for_all2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool val exists2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool val mem : 'a -> set:'a list -> bool val memq : 'a -> set:'a list -> bool val find : f:('a -> bool) -> 'a list -> 'a val filter : f:('a -> bool) -> 'a list -> 'a list val find_all : f:('a -> bool) -> 'a list -> 'a list val partition : f:('a -> bool) -> 'a list -> 'a list * 'a list val assoc : 'a -> ('a * 'b) list -> 'b val assq : 'a -> ('a * 'b) list -> 'b val mem_assoc : 'a -> map:('a * 'b) list -> bool val mem_assq : 'a -> map:('a * 'b) list -> bool val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list val split : ('a * 'b) list -> 'a list * 'b list val combine : 'a list -> 'b list -> ('a * 'b) list val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list val fast_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list val merge : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list end module String : sig external length : string -> int = "%string_length" external get : string -> int -> char = "%string_safe_get" external set : string -> int -> char -> unit = "%string_safe_set" external create : int -> string = "caml_create_string" val make : int -> char -> string val copy : string -> string val sub : string -> pos:int -> len:int -> string val fill : string -> pos:int -> len:int -> char -> unit val blit : src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int -> unit val concat : sep:string -> string list -> string val iter : f:(char -> unit) -> string -> unit val iteri : f:(int -> char -> unit) -> string -> unit val map : f:(char -> char) -> string -> string val trim : string -> string val escaped : string -> string val index : string -> char -> int val rindex : string -> char -> int val index_from : string -> int -> char -> int val rindex_from : string -> int -> char -> int val contains : string -> char -> bool val contains_from : string -> int -> char -> bool val rcontains_from : string -> int -> char -> bool val uppercase : string -> string val lowercase : string -> string val capitalize : string -> string val uncapitalize : string -> string type t = string val compare: t -> t -> int external unsafe_get : string -> int -> char = "%string_unsafe_get" external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" external unsafe_blit : src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int -> unit = "caml_blit_string" "noalloc" external unsafe_fill : string -> pos:int -> len:int -> char -> unit = "caml_fill_string" "noalloc" end mingw-ocaml/ocaml/stdlib/stream.mli0000644000175000017500000000646112124403240016743 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Streams and parsers. *) type 'a t (** The type of streams holding values of type ['a]. *) exception Failure (** Raised by parsers when none of the first components of the stream patterns is accepted. *) exception Error of string (** Raised by parsers when the first component of a stream pattern is accepted, but one of the following components is rejected. *) (** {6 Stream builders} *) val from : (int -> 'a option) -> 'a t (** [Stream.from f] returns a stream built from the function [f]. To create a new stream element, the function [f] is called with the current stream count. The user function [f] must return either [Some ] for a value or [None] to specify the end of the stream. *) val of_list : 'a list -> 'a t (** Return the stream holding the elements of the list in the same order. *) val of_string : string -> char t (** Return the stream of the characters of the string parameter. *) val of_channel : in_channel -> char t (** Return the stream of the characters read from the input channel. *) (** {6 Stream iterator} *) val iter : ('a -> unit) -> 'a t -> unit (** [Stream.iter f s] scans the whole stream s, applying function [f] in turn to each stream element encountered. *) (** {6 Predefined parsers} *) val next : 'a t -> 'a (** Return the first element of the stream and remove it from the stream. Raise Stream.Failure if the stream is empty. *) val empty : 'a t -> unit (** Return [()] if the stream is empty, else raise [Stream.Failure]. *) (** {6 Useful functions} *) val peek : 'a t -> 'a option (** Return [Some] of "the first element" of the stream, or [None] if the stream is empty. *) val junk : 'a t -> unit (** Remove the first element of the stream, possibly unfreezing it before. *) val count : 'a t -> int (** Return the current count of the stream elements, i.e. the number of the stream elements discarded. *) val npeek : int -> 'a t -> 'a list (** [npeek n] returns the list of the [n] first elements of the stream, or all its remaining elements if less than [n] elements are available. *) (**/**) (* The following is for system use only. Do not call directly. *) val iapp : 'a t -> 'a t -> 'a t val icons : 'a -> 'a t -> 'a t val ising : 'a -> 'a t val lapp : (unit -> 'a t) -> 'a t -> 'a t val lcons : (unit -> 'a) -> 'a t -> 'a t val lsing : (unit -> 'a) -> 'a t val sempty : 'a t val slazy : (unit -> 'a t) -> 'a t val dump : ('a -> unit) -> 'a t -> unit mingw-ocaml/ocaml/stdlib/.depend0000644000175000017500000002502612124403240016203 0ustar tootstootsarg.cmi : array.cmi : arrayLabels.cmi : buffer.cmi : callback.cmi : camlinternalLazy.cmi : camlinternalMod.cmi : obj.cmi camlinternalOO.cmi : obj.cmi char.cmi : complex.cmi : digest.cmi : filename.cmi : format.cmi : pervasives.cmi buffer.cmi gc.cmi : genlex.cmi : stream.cmi hashtbl.cmi : int32.cmi : int64.cmi : lazy.cmi : lexing.cmi : list.cmi : listLabels.cmi : map.cmi : marshal.cmi : moreLabels.cmi : set.cmi map.cmi hashtbl.cmi nativeint.cmi : obj.cmi : int32.cmi oo.cmi : camlinternalOO.cmi parsing.cmi : obj.cmi lexing.cmi pervasives.cmi : printexc.cmi : printf.cmi : obj.cmi buffer.cmi queue.cmi : random.cmi : nativeint.cmi int64.cmi int32.cmi scanf.cmi : pervasives.cmi set.cmi : sort.cmi : stack.cmi : stdLabels.cmi : stream.cmi : string.cmi : stringLabels.cmi : sys.cmi : weak.cmi : hashtbl.cmi arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \ arg.cmi arg.cmx : sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx \ arg.cmi array.cmo : array.cmi array.cmx : array.cmi arrayLabels.cmo : array.cmi arrayLabels.cmi arrayLabels.cmx : array.cmx arrayLabels.cmi buffer.cmo : sys.cmi string.cmi buffer.cmi buffer.cmx : sys.cmx string.cmx buffer.cmi callback.cmo : obj.cmi callback.cmi callback.cmx : obj.cmx callback.cmi camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi camlinternalLazy.cmx : obj.cmx camlinternalLazy.cmi camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \ camlinternalMod.cmi camlinternalMod.cmx : obj.cmx camlinternalOO.cmx array.cmx \ camlinternalMod.cmi camlinternalOO.cmo : sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \ callback.cmi array.cmi camlinternalOO.cmi camlinternalOO.cmx : sys.cmx string.cmx obj.cmx map.cmx list.cmx char.cmx \ callback.cmx array.cmx camlinternalOO.cmi char.cmo : char.cmi char.cmx : char.cmi complex.cmo : complex.cmi complex.cmx : complex.cmi digest.cmo : string.cmi printf.cmi char.cmi digest.cmi digest.cmx : string.cmx printf.cmx char.cmx digest.cmi filename.cmo : sys.cmi string.cmi random.cmi printf.cmi lazy.cmi buffer.cmi \ filename.cmi filename.cmx : sys.cmx string.cmx random.cmx printf.cmx lazy.cmx buffer.cmx \ filename.cmi format.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \ buffer.cmi format.cmi format.cmx : string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx \ buffer.cmx format.cmi gc.cmo : sys.cmi printf.cmi gc.cmi gc.cmx : sys.cmx printf.cmx gc.cmi genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi genlex.cmx : string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx genlex.cmi hashtbl.cmo : sys.cmi string.cmi random.cmi obj.cmi lazy.cmi array.cmi \ hashtbl.cmi hashtbl.cmx : sys.cmx string.cmx random.cmx obj.cmx lazy.cmx array.cmx \ hashtbl.cmi int32.cmo : pervasives.cmi int32.cmi int32.cmx : pervasives.cmx int32.cmi int64.cmo : pervasives.cmi int64.cmi int64.cmx : pervasives.cmx int64.cmi lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi lazy.cmx : obj.cmx camlinternalLazy.cmx lazy.cmi lexing.cmo : sys.cmi string.cmi array.cmi lexing.cmi lexing.cmx : sys.cmx string.cmx array.cmx lexing.cmi list.cmo : list.cmi list.cmx : list.cmi listLabels.cmo : list.cmi listLabels.cmi listLabels.cmx : list.cmx listLabels.cmi map.cmo : map.cmi map.cmx : map.cmi marshal.cmo : string.cmi marshal.cmi marshal.cmx : string.cmx marshal.cmi moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi moreLabels.cmx : set.cmx map.cmx hashtbl.cmx moreLabels.cmi nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi nativeint.cmx : sys.cmx pervasives.cmx nativeint.cmi obj.cmo : marshal.cmi int32.cmi array.cmi obj.cmi obj.cmx : marshal.cmx int32.cmx array.cmx obj.cmi oo.cmo : camlinternalOO.cmi oo.cmi oo.cmx : camlinternalOO.cmx oo.cmi parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi parsing.cmx : obj.cmx lexing.cmx array.cmx parsing.cmi pervasives.cmo : pervasives.cmi pervasives.cmx : pervasives.cmi printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi printexc.cmx : printf.cmx obj.cmx buffer.cmx array.cmx printexc.cmi printf.cmo : string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \ array.cmi printf.cmi printf.cmx : string.cmx pervasives.cmx obj.cmx list.cmx char.cmx buffer.cmx \ array.cmx printf.cmi queue.cmo : obj.cmi queue.cmi queue.cmx : obj.cmx queue.cmi random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \ digest.cmi char.cmi array.cmi random.cmi random.cmx : string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \ digest.cmx char.cmx array.cmx random.cmi scanf.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \ hashtbl.cmi buffer.cmi array.cmi scanf.cmi scanf.cmx : string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx \ hashtbl.cmx buffer.cmx array.cmx scanf.cmi set.cmo : set.cmi set.cmx : set.cmi sort.cmo : array.cmi sort.cmi sort.cmx : array.cmx sort.cmi stack.cmo : list.cmi stack.cmi stack.cmx : list.cmx stack.cmi stdLabels.cmo : stringLabels.cmi listLabels.cmi arrayLabels.cmi \ stdLabels.cmi stdLabels.cmx : stringLabels.cmx listLabels.cmx arrayLabels.cmx \ stdLabels.cmi std_exit.cmo : std_exit.cmx : stream.cmo : string.cmi obj.cmi list.cmi lazy.cmi stream.cmi stream.cmx : string.cmx obj.cmx list.cmx lazy.cmx stream.cmi string.cmo : pervasives.cmi list.cmi char.cmi string.cmi string.cmx : pervasives.cmx list.cmx char.cmx string.cmi stringLabels.cmo : string.cmi stringLabels.cmi stringLabels.cmx : string.cmx stringLabels.cmi sys.cmo : sys.cmi sys.cmx : sys.cmi weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi weak.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \ arg.cmi arg.p.cmx : sys.p.cmx string.p.cmx printf.p.cmx list.p.cmx buffer.p.cmx array.p.cmx \ arg.cmi array.cmo : array.cmi array.p.cmx : array.cmi arrayLabels.cmo : array.cmi arrayLabels.cmi arrayLabels.p.cmx : array.p.cmx arrayLabels.cmi buffer.cmo : sys.cmi string.cmi buffer.cmi buffer.p.cmx : sys.p.cmx string.p.cmx buffer.cmi callback.cmo : obj.cmi callback.cmi callback.p.cmx : obj.p.cmx callback.cmi camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi camlinternalLazy.p.cmx : obj.p.cmx camlinternalLazy.cmi camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \ camlinternalMod.cmi camlinternalMod.p.cmx : obj.p.cmx camlinternalOO.p.cmx array.p.cmx \ camlinternalMod.cmi camlinternalOO.cmo : sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \ callback.cmi array.cmi camlinternalOO.cmi camlinternalOO.p.cmx : sys.p.cmx string.p.cmx obj.p.cmx map.p.cmx list.p.cmx char.p.cmx \ callback.p.cmx array.p.cmx camlinternalOO.cmi char.cmo : char.cmi char.p.cmx : char.cmi complex.cmo : complex.cmi complex.p.cmx : complex.cmi digest.cmo : string.cmi printf.cmi char.cmi digest.cmi digest.p.cmx : string.p.cmx printf.p.cmx char.p.cmx digest.cmi filename.cmo : sys.cmi string.cmi random.cmi printf.cmi lazy.cmi buffer.cmi \ filename.cmi filename.p.cmx : sys.p.cmx string.p.cmx random.p.cmx printf.p.cmx lazy.p.cmx buffer.p.cmx \ filename.cmi format.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \ buffer.cmi format.cmi format.p.cmx : string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx \ buffer.p.cmx format.cmi gc.cmo : sys.cmi printf.cmi gc.cmi gc.p.cmx : sys.p.cmx printf.p.cmx gc.cmi genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi genlex.p.cmx : string.p.cmx stream.p.cmx list.p.cmx hashtbl.p.cmx char.p.cmx genlex.cmi hashtbl.cmo : sys.cmi string.cmi random.cmi obj.cmi lazy.cmi array.cmi \ hashtbl.cmi hashtbl.p.cmx : sys.p.cmx string.p.cmx random.p.cmx obj.p.cmx lazy.p.cmx array.p.cmx \ hashtbl.cmi int32.cmo : pervasives.cmi int32.cmi int32.p.cmx : pervasives.p.cmx int32.cmi int64.cmo : pervasives.cmi int64.cmi int64.p.cmx : pervasives.p.cmx int64.cmi lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi lazy.p.cmx : obj.p.cmx camlinternalLazy.p.cmx lazy.cmi lexing.cmo : sys.cmi string.cmi array.cmi lexing.cmi lexing.p.cmx : sys.p.cmx string.p.cmx array.p.cmx lexing.cmi list.cmo : list.cmi list.p.cmx : list.cmi listLabels.cmo : list.cmi listLabels.cmi listLabels.p.cmx : list.p.cmx listLabels.cmi map.cmo : map.cmi map.p.cmx : map.cmi marshal.cmo : string.cmi marshal.cmi marshal.p.cmx : string.p.cmx marshal.cmi moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi moreLabels.p.cmx : set.p.cmx map.p.cmx hashtbl.p.cmx moreLabels.cmi nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi nativeint.p.cmx : sys.p.cmx pervasives.p.cmx nativeint.cmi obj.cmo : marshal.cmi int32.cmi array.cmi obj.cmi obj.p.cmx : marshal.p.cmx int32.p.cmx array.p.cmx obj.cmi oo.cmo : camlinternalOO.cmi oo.cmi oo.p.cmx : camlinternalOO.p.cmx oo.cmi parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi parsing.p.cmx : obj.p.cmx lexing.p.cmx array.p.cmx parsing.cmi pervasives.cmo : pervasives.cmi pervasives.p.cmx : pervasives.cmi printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi printexc.p.cmx : printf.p.cmx obj.p.cmx buffer.p.cmx array.p.cmx printexc.cmi printf.cmo : string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \ array.cmi printf.cmi printf.p.cmx : string.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx char.p.cmx buffer.p.cmx \ array.p.cmx printf.cmi queue.cmo : obj.cmi queue.cmi queue.p.cmx : obj.p.cmx queue.cmi random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \ digest.cmi char.cmi array.cmi random.cmi random.p.cmx : string.p.cmx pervasives.p.cmx nativeint.p.cmx int64.p.cmx int32.p.cmx \ digest.p.cmx char.p.cmx array.p.cmx random.cmi scanf.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \ hashtbl.cmi buffer.cmi array.cmi scanf.cmi scanf.p.cmx : string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx \ hashtbl.p.cmx buffer.p.cmx array.p.cmx scanf.cmi set.cmo : set.cmi set.p.cmx : set.cmi sort.cmo : array.cmi sort.cmi sort.p.cmx : array.p.cmx sort.cmi stack.cmo : list.cmi stack.cmi stack.p.cmx : list.p.cmx stack.cmi stdLabels.cmo : stringLabels.cmi listLabels.cmi arrayLabels.cmi \ stdLabels.cmi stdLabels.p.cmx : stringLabels.p.cmx listLabels.p.cmx arrayLabels.p.cmx \ stdLabels.cmi std_exit.cmo : std_exit.p.cmx : stream.cmo : string.cmi obj.cmi list.cmi lazy.cmi stream.cmi stream.p.cmx : string.p.cmx obj.p.cmx list.p.cmx lazy.p.cmx stream.cmi string.cmo : pervasives.cmi list.cmi char.cmi string.cmi string.p.cmx : pervasives.p.cmx list.p.cmx char.p.cmx string.cmi stringLabels.cmo : string.cmi stringLabels.cmi stringLabels.p.cmx : string.p.cmx stringLabels.cmi sys.cmo : sys.cmi sys.p.cmx : sys.cmi weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi weak.p.cmx : sys.p.cmx obj.p.cmx hashtbl.p.cmx array.p.cmx weak.cmi mingw-ocaml/ocaml/stdlib/callback.ml0000644000175000017500000000234412124403240017027 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Registering OCaml values with the C runtime for later callbacks *) external register_named_value : string -> Obj.t -> unit = "caml_register_named_value" let register name v = register_named_value name (Obj.repr v) let register_exception name (exn : exn) = register_named_value name (Obj.field (Obj.repr exn) 0) mingw-ocaml/ocaml/stdlib/filename.mli0000644000175000017500000001371412124403240017227 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Operations on file names. *) val current_dir_name : string (** The conventional name for the current directory (e.g. [.] in Unix). *) val parent_dir_name : string (** The conventional name for the parent of the current directory (e.g. [..] in Unix). *) val dir_sep : string (** The directory separator (e.g. [/] in Unix). @since 3.11.2 *) val concat : string -> string -> string (** [concat dir file] returns a file name that designates file [file] in directory [dir]. *) val is_relative : string -> bool (** Return [true] if the file name is relative to the current directory, [false] if it is absolute (i.e. in Unix, starts with [/]). *) val is_implicit : string -> bool (** Return [true] if the file name is relative and does not start with an explicit reference to the current directory ([./] or [../] in Unix), [false] if it starts with an explicit reference to the root directory or the current directory. *) val check_suffix : string -> string -> bool (** [check_suffix name suff] returns [true] if the filename [name] ends with the suffix [suff]. *) val chop_suffix : string -> string -> string (** [chop_suffix name suff] removes the suffix [suff] from the filename [name]. The behavior is undefined if [name] does not end with the suffix [suff]. *) val chop_extension : string -> string (** Return the given file name without its extension. The extension is the shortest suffix starting with a period and not including a directory separator, [.xyz] for instance. Raise [Invalid_argument] if the given name does not contain an extension. *) val basename : string -> string (** Split a file name into directory name / base file name. If [name] is a valid file name, then [concat (dirname name) (basename name)] returns a file name which is equivalent to [name]. Moreover, after setting the current directory to [dirname name] (with {!Sys.chdir}), references to [basename name] (which is a relative file name) designate the same file as [name] before the call to {!Sys.chdir}. This function conforms to the specification of POSIX.1-2008 for the [basename] utility. *) val dirname : string -> string (** See {!Filename.basename}. This function conforms to the specification of POSIX.1-2008 for the [dirname] utility. *) val temp_file : ?temp_dir: string -> string -> string -> string (** [temp_file prefix suffix] returns the name of a fresh temporary file in the temporary directory. The base name of the temporary file is formed by concatenating [prefix], then a suitably chosen integer number, then [suffix]. The optional argument [temp_dir] indicates the temporary directory to use, defaulting to the current result of {!Filename.get_temp_dir_name}. The temporary file is created empty, with permissions [0o600] (readable and writable only by the file owner). The file is guaranteed to be different from any other file that existed when [temp_file] was called. Raise [Sys_error] if the file could not be created. @before 3.11.2 no ?temp_dir optional argument *) val open_temp_file : ?mode: open_flag list -> ?temp_dir: string -> string -> string -> string * out_channel (** Same as {!Filename.temp_file}, but returns both the name of a fresh temporary file, and an output channel opened (atomically) on this file. This function is more secure than [temp_file]: there is no risk that the temporary file will be modified (e.g. replaced by a symbolic link) before the program opens it. The optional argument [mode] is a list of additional flags to control the opening of the file. It can contain one or several of [Open_append], [Open_binary], and [Open_text]. The default is [[Open_text]] (open in text mode). Raise [Sys_error] if the file could not be opened. @before 3.11.2 no ?temp_dir optional argument *) val get_temp_dir_name : unit -> string (** The name of the temporary directory: Under Unix, the value of the [TMPDIR] environment variable, or "/tmp" if the variable is not set. Under Windows, the value of the [TEMP] environment variable, or "." if the variable is not set. The temporary directory can be changed with {!Filename.set_temp_dir_name}. @since 4.00.0 *) val set_temp_dir_name : string -> unit (** Change the temporary directory returned by {!Filename.get_temp_dir_name} and used by {!Filename.temp_file} and {!Filename.open_temp_file}. @since 4.00.0 *) val temp_dir_name : string (** @deprecated The name of the initial temporary directory: Under Unix, the value of the [TMPDIR] environment variable, or "/tmp" if the variable is not set. Under Windows, the value of the [TEMP] environment variable, or "." if the variable is not set. This function is deprecated; {!Filename.get_temp_dir_name} should be used instead. @since 3.09.1 *) val quote : string -> string (** Return a quoted version of a file name, suitable for use as one argument in a command line, escaping all meta-characters. Warning: under Windows, the output is only suitable for use with programs that follow the standard Windows quoting conventions. *) mingw-ocaml/ocaml/stdlib/string.mli0000644000175000017500000002265612124403240016762 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** String operations. Given a string [s] of length [l], we call character number in [s] the index of a character in [s]. Indexes start at [0], and we will call a character number valid in [s] if it falls within the range [[0...l-1]]. A position is the point between two characters or at the beginning or end of the string. We call a position valid in [s] if it falls within the range [[0...l]]. Note that character number [n] is between positions [n] and [n+1]. Two parameters [start] and [len] are said to designate a valid substring of [s] if [len >= 0] and [start] and [start+len] are valid positions in [s]. OCaml strings can be modified in place, for instance via the {!String.set} and {!String.blit} functions described below. This possibility should be used rarely and with much care, however, since both the OCaml compiler and most OCaml libraries share strings as if they were immutable, rather than copying them. In particular, string literals are shared: a single copy of the string is created at program loading time and returned by all evaluations of the string literal. Consider for example: {[ # let f () = "foo";; val f : unit -> string = # (f ()).[0] <- 'b';; - : unit = () # f ();; - : string = "boo" ]} Likewise, many functions from the standard library can return string literals or one of their string arguments. Therefore, the returned strings must not be modified directly. If mutation is absolutely necessary, it should be performed on a fresh copy of the string, as produced by {!String.copy}. *) external length : string -> int = "%string_length" (** Return the length (number of characters) of the given string. *) external get : string -> int -> char = "%string_safe_get" (** [String.get s n] returns character number [n] in string [s]. You can also write [s.[n]] instead of [String.get s n]. Raise [Invalid_argument] if [n] not a valid character number in [s]. *) external set : string -> int -> char -> unit = "%string_safe_set" (** [String.set s n c] modifies string [s] in place, replacing the character number [n] by [c]. You can also write [s.[n] <- c] instead of [String.set s n c]. Raise [Invalid_argument] if [n] is not a valid character number in [s]. *) external create : int -> string = "caml_create_string" (** [String.create n] returns a fresh string of length [n]. The string initially contains arbitrary characters. Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) val make : int -> char -> string (** [String.make n c] returns a fresh string of length [n], filled with the character [c]. Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.*) val copy : string -> string (** Return a copy of the given string. *) val sub : string -> int -> int -> string (** [String.sub s start len] returns a fresh string of length [len], containing the substring of [s] that starts at position [start] and has length [len]. Raise [Invalid_argument] if [start] and [len] do not designate a valid substring of [s]. *) val fill : string -> int -> int -> char -> unit (** [String.fill s start len c] modifies string [s] in place, replacing [len] characters by [c], starting at [start]. Raise [Invalid_argument] if [start] and [len] do not designate a valid substring of [s]. *) val blit : string -> int -> string -> int -> int -> unit (** [String.blit src srcoff dst dstoff len] copies [len] characters from string [src], starting at character number [srcoff], to string [dst], starting at character number [dstoff]. It works correctly even if [src] and [dst] are the same string, and the source and destination intervals overlap. Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid substring of [src], or if [dstoff] and [len] do not designate a valid substring of [dst]. *) val concat : string -> string list -> string (** [String.concat sep sl] concatenates the list of strings [sl], inserting the separator string [sep] between each. *) val iter : (char -> unit) -> string -> unit (** [String.iter f s] applies function [f] in turn to all the characters of [s]. It is equivalent to [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *) val iteri : (int -> char -> unit) -> string -> unit (** Same as {!String.iter}, but the function is applied to the index of the element as first argument (counting from 0), and the character itself as second argument. @since 4.00.0 *) val map : (char -> char) -> string -> string (** [String.map f s] applies function [f] in turn to all the characters of [s] and stores the results in a new string that is returned. @since 4.00.0 *) val trim : string -> string (** Return a copy of the argument, without leading and trailing whitespace. The characters regarded as whitespace are: [' '], ['\012'], ['\n'], ['\r'], and ['\t']. If there is no leading nor trailing whitespace character in the argument, return the original string itself, not a copy. @since 4.00.0 *) val escaped : string -> string (** Return a copy of the argument, with special characters represented by escape sequences, following the lexical conventions of OCaml. If there is no special character in the argument, return the original string itself, not a copy. Its inverse function is Scanf.unescaped. *) val index : string -> char -> int (** [String.index s c] returns the character number of the first occurrence of character [c] in string [s]. Raise [Not_found] if [c] does not occur in [s]. *) val rindex : string -> char -> int (** [String.rindex s c] returns the character number of the last occurrence of character [c] in string [s]. Raise [Not_found] if [c] does not occur in [s]. *) val index_from : string -> int -> char -> int (** [String.index_from s i c] returns the character number of the first occurrence of character [c] in string [s] after position [i]. [String.index s c] is equivalent to [String.index_from s 0 c]. Raise [Invalid_argument] if [i] is not a valid position in [s]. Raise [Not_found] if [c] does not occur in [s] after position [i]. *) val rindex_from : string -> int -> char -> int (** [String.rindex_from s i c] returns the character number of the last occurrence of character [c] in string [s] before position [i+1]. [String.rindex s c] is equivalent to [String.rindex_from s (String.length s - 1) c]. Raise [Invalid_argument] if [i+1] is not a valid position in [s]. Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *) val contains : string -> char -> bool (** [String.contains s c] tests if character [c] appears in the string [s]. *) val contains_from : string -> int -> char -> bool (** [String.contains_from s start c] tests if character [c] appears in [s] after position [start]. [String.contains s c] is equivalent to [String.contains_from s 0 c]. Raise [Invalid_argument] if [start] is not a valid position in [s]. *) val rcontains_from : string -> int -> char -> bool (** [String.rcontains_from s stop c] tests if character [c] appears in [s] before position [stop+1]. Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid position in [s]. *) val uppercase : string -> string (** Return a copy of the argument, with all lowercase letters translated to uppercase, including accented letters of the ISO Latin-1 (8859-1) character set. *) val lowercase : string -> string (** Return a copy of the argument, with all uppercase letters translated to lowercase, including accented letters of the ISO Latin-1 (8859-1) character set. *) val capitalize : string -> string (** Return a copy of the argument, with the first character set to uppercase. *) val uncapitalize : string -> string (** Return a copy of the argument, with the first character set to lowercase. *) type t = string (** An alias for the type of strings. *) val compare: t -> t -> int (** The comparison function for strings, with the same specification as {!Pervasives.compare}. Along with the type [t], this function [compare] allows the module [String] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) (**/**) (* The following is for system use only. Do not call directly. *) external unsafe_get : string -> int -> char = "%string_unsafe_get" external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" external unsafe_blit : string -> int -> string -> int -> int -> unit = "caml_blit_string" "noalloc" external unsafe_fill : string -> int -> int -> char -> unit = "caml_fill_string" "noalloc" mingw-ocaml/ocaml/stdlib/stringLabels.ml0000644000175000017500000000171112124403240017721 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [StringLabels]: labelled String module *) include String mingw-ocaml/ocaml/stdlib/lazy.ml0000644000175000017500000000531012124403240016246 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [Lazy]: deferred computations *) (* WARNING: some purple magic is going on here. Do not take this file as an example of how to program in OCaml. *) (* We make use of two special tags provided by the runtime: [lazy_tag] and [forward_tag]. A value of type ['a Lazy.t] can be one of three things: 1. A block of size 1 with tag [lazy_tag]. Its field is a closure of type [unit -> 'a] that computes the value. 2. A block of size 1 with tag [forward_tag]. Its field is the value of type ['a] that was computed. 3. Anything else except a float. This has type ['a] and is the value that was computed. Exceptions are stored in format (1). The GC will magically change things from (2) to (3) according to its fancy. We cannot use representation (3) for a [float Lazy.t] because [caml_make_array] assumes that only a [float] value can have tag [Double_tag]. We have to use the built-in type constructor [lazy_t] to let the compiler implement the special typing and compilation rules for the [lazy] keyword. *) type 'a t = 'a lazy_t;; exception Undefined = CamlinternalLazy.Undefined;; external make_forward : 'a -> 'a lazy_t = "caml_lazy_make_forward";; external force : 'a t -> 'a = "%lazy_force";; (* let force = force;; *) let force_val = CamlinternalLazy.force_val;; let from_fun (f : unit -> 'arg) = let x = Obj.new_block Obj.lazy_tag 1 in Obj.set_field x 0 (Obj.repr f); (Obj.obj x : 'arg t) ;; let from_val (v : 'arg) = let t = Obj.tag (Obj.repr v) in if t = Obj.forward_tag || t = Obj.lazy_tag || t = Obj.double_tag then begin make_forward v end else begin (Obj.magic v : 'arg t) end ;; let is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag;; let lazy_from_fun = from_fun;; let lazy_from_val = from_val;; let lazy_is_val = is_val;; mingw-ocaml/ocaml/stdlib/set.mli0000644000175000017500000001340512124403240016237 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Sets over ordered types. This module implements the set data structure, given a total ordering function over the set elements. All operations over sets are purely applicative (no side-effects). The implementation uses balanced binary trees, and is therefore reasonably efficient: insertion and membership take time logarithmic in the size of the set, for instance. *) module type OrderedType = sig type t (** The type of the set elements. *) val compare : t -> t -> int (** A total ordering function over the set elements. This is a two-argument function [f] such that [f e1 e2] is zero if the elements [e1] and [e2] are equal, [f e1 e2] is strictly negative if [e1] is smaller than [e2], and [f e1 e2] is strictly positive if [e1] is greater than [e2]. Example: a suitable ordering function is the generic structural comparison function {!Pervasives.compare}. *) end (** Input signature of the functor {!Set.Make}. *) module type S = sig type elt (** The type of the set elements. *) type t (** The type of sets. *) val empty: t (** The empty set. *) val is_empty: t -> bool (** Test whether a set is empty or not. *) val mem: elt -> t -> bool (** [mem x s] tests whether [x] belongs to the set [s]. *) val add: elt -> t -> t (** [add x s] returns a set containing all elements of [s], plus [x]. If [x] was already in [s], [s] is returned unchanged. *) val singleton: elt -> t (** [singleton x] returns the one-element set containing only [x]. *) val remove: elt -> t -> t (** [remove x s] returns a set containing all elements of [s], except [x]. If [x] was not in [s], [s] is returned unchanged. *) val union: t -> t -> t (** Set union. *) val inter: t -> t -> t (** Set intersection. *) (** Set difference. *) val diff: t -> t -> t val compare: t -> t -> int (** Total ordering between sets. Can be used as the ordering function for doing sets of sets. *) val equal: t -> t -> bool (** [equal s1 s2] tests whether the sets [s1] and [s2] are equal, that is, contain equal elements. *) val subset: t -> t -> bool (** [subset s1 s2] tests whether the set [s1] is a subset of the set [s2]. *) val iter: (elt -> unit) -> t -> unit (** [iter f s] applies [f] in turn to all elements of [s]. The elements of [s] are presented to [f] in increasing order with respect to the ordering over the type of the elements. *) val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], where [x1 ... xN] are the elements of [s], in increasing order. *) val for_all: (elt -> bool) -> t -> bool (** [for_all p s] checks if all elements of the set satisfy the predicate [p]. *) val exists: (elt -> bool) -> t -> bool (** [exists p s] checks if at least one element of the set satisfies the predicate [p]. *) val filter: (elt -> bool) -> t -> t (** [filter p s] returns the set of all elements in [s] that satisfy predicate [p]. *) val partition: (elt -> bool) -> t -> t * t (** [partition p s] returns a pair of sets [(s1, s2)], where [s1] is the set of all the elements of [s] that satisfy the predicate [p], and [s2] is the set of all the elements of [s] that do not satisfy [p]. *) val cardinal: t -> int (** Return the number of elements of a set. *) val elements: t -> elt list (** Return the list of all elements of the given set. The returned list is sorted in increasing order with respect to the ordering [Ord.compare], where [Ord] is the argument given to {!Set.Make}. *) val min_elt: t -> elt (** Return the smallest element of the given set (with respect to the [Ord.compare] ordering), or raise [Not_found] if the set is empty. *) val max_elt: t -> elt (** Same as {!Set.S.min_elt}, but returns the largest element of the given set. *) val choose: t -> elt (** Return one element of the given set, or raise [Not_found] if the set is empty. Which element is chosen is unspecified, but equal elements will be chosen for equal sets. *) val split: elt -> t -> t * bool * t (** [split x s] returns a triple [(l, present, r)], where [l] is the set of elements of [s] that are strictly less than [x]; [r] is the set of elements of [s] that are strictly greater than [x]; [present] is [false] if [s] contains no element equal to [x], or [true] if [s] contains an element equal to [x]. *) end (** Output signature of the functor {!Set.Make}. *) module Make (Ord : OrderedType) : S with type elt = Ord.t (** Functor building an implementation of the set structure given a totally ordered type. *) mingw-ocaml/ocaml/stdlib/marshal.mli0000644000175000017500000001531212124403240017072 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Marshaling of data structures. This module provides functions to encode arbitrary data structures as sequences of bytes, which can then be written on a file or sent over a pipe or network connection. The bytes can then be read back later, possibly in another process, and decoded back into a data structure. The format for the byte sequences is compatible across all machines for a given version of OCaml. Warning: marshaling is currently not type-safe. The type of marshaled data is not transmitted along the value of the data, making it impossible to check that the data read back possesses the type expected by the context. In particular, the result type of the [Marshal.from_*] functions is given as ['a], but this is misleading: the returned OCaml value does not possess type ['a] for all ['a]; it has one, unique type which cannot be determined at compile-type. The programmer should explicitly give the expected type of the returned value, using the following syntax: - [(Marshal.from_channel chan : type)]. Anything can happen at run-time if the object in the file does not belong to the given type. The representation of marshaled values is not human-readable, and uses bytes that are not printable characters. Therefore, input and output channels used in conjunction with [Marshal.to_channel] and [Marshal.from_channel] must be opened in binary mode, using e.g. [open_out_bin] or [open_in_bin]; channels opened in text mode will cause unmarshaling errors on platforms where text channels behave differently than binary channels, e.g. Windows. *) type extern_flags = No_sharing (** Don't preserve sharing *) | Closures (** Send function closures *) (** The flags to the [Marshal.to_*] functions below. *) val to_channel : out_channel -> 'a -> extern_flags list -> unit (** [Marshal.to_channel chan v flags] writes the representation of [v] on channel [chan]. The [flags] argument is a possibly empty list of flags that governs the marshaling behavior with respect to sharing and functional values. If [flags] does not contain [Marshal.No_sharing], circularities and sharing inside the value [v] are detected and preserved in the sequence of bytes produced. In particular, this guarantees that marshaling always terminates. Sharing between values marshaled by successive calls to [Marshal.to_channel] is not detected, though. If [flags] contains [Marshal.No_sharing], sharing is ignored. This results in faster marshaling if [v] contains no shared substructures, but may cause slower marshaling and larger byte representations if [v] actually contains sharing, or even non-termination if [v] contains cycles. If [flags] does not contain [Marshal.Closures], marshaling fails when it encounters a functional value inside [v]: only ``pure'' data structures, containing neither functions nor objects, can safely be transmitted between different programs. If [flags] contains [Marshal.Closures], functional values will be marshaled as a position in the code of the program. In this case, the output of marshaling can only be read back in processes that run exactly the same program, with exactly the same compiled code. (This is checked at un-marshaling time, using an MD5 digest of the code transmitted along with the code position.) *) external to_string : 'a -> extern_flags list -> string = "caml_output_value_to_string" (** [Marshal.to_string v flags] returns a string containing the representation of [v] as a sequence of bytes. The [flags] argument has the same meaning as for {!Marshal.to_channel}. *) val to_buffer : string -> int -> int -> 'a -> extern_flags list -> int (** [Marshal.to_buffer buff ofs len v flags] marshals the value [v], storing its byte representation in the string [buff], starting at character number [ofs], and writing at most [len] characters. It returns the number of characters actually written to the string. If the byte representation of [v] does not fit in [len] characters, the exception [Failure] is raised. *) val from_channel : in_channel -> 'a (** [Marshal.from_channel chan] reads from channel [chan] the byte representation of a structured value, as produced by one of the [Marshal.to_*] functions, and reconstructs and returns the corresponding value.*) val from_string : string -> int -> 'a (** [Marshal.from_string buff ofs] unmarshals a structured value like {!Marshal.from_channel} does, except that the byte representation is not read from a channel, but taken from the string [buff], starting at position [ofs]. *) val header_size : int (** The bytes representing a marshaled value are composed of a fixed-size header and a variable-sized data part, whose size can be determined from the header. {!Marshal.header_size} is the size, in characters, of the header. {!Marshal.data_size}[ buff ofs] is the size, in characters, of the data part, assuming a valid header is stored in [buff] starting at position [ofs]. Finally, {!Marshal.total_size} [buff ofs] is the total size, in characters, of the marshaled value. Both {!Marshal.data_size} and {!Marshal.total_size} raise [Failure] if [buff], [ofs] does not contain a valid header. To read the byte representation of a marshaled value into a string buffer, the program needs to read first {!Marshal.header_size} characters into the buffer, then determine the length of the remainder of the representation using {!Marshal.data_size}, make sure the buffer is large enough to hold the remaining data, then read it, and finally call {!Marshal.from_string} to unmarshal the value. *) val data_size : string -> int -> int (** See {!Marshal.header_size}.*) val total_size : string -> int -> int (** See {!Marshal.header_size}.*) mingw-ocaml/ocaml/stdlib/sort.mli0000644000175000017500000000372712124403240016441 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Sorting and merging lists. @deprecated This module is obsolete and exists only for backward compatibility. The sorting functions in {!Array} and {!List} should be used instead. The new functions are faster and use less memory. *) val list : ('a -> 'a -> bool) -> 'a list -> 'a list (** Sort a list in increasing order according to an ordering predicate. The predicate should return [true] if its first argument is less than or equal to its second argument. *) val array : ('a -> 'a -> bool) -> 'a array -> unit (** Sort an array in increasing order according to an ordering predicate. The predicate should return [true] if its first argument is less than or equal to its second argument. The array is sorted in place. *) val merge : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list (** Merge two lists according to the given predicate. Assuming the two argument lists are sorted according to the predicate, [merge] returns a sorted list containing the elements from the two lists. The behavior is undefined if the two argument lists were not sorted. *) mingw-ocaml/ocaml/stdlib/gc.mli0000644000175000017500000002725712124403240016047 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Memory management control and statistics; finalised values. *) type stat = { minor_words : float; (** Number of words allocated in the minor heap since the program was started. This number is accurate in byte-code programs, but only an approximation in programs compiled to native code. *) promoted_words : float; (** Number of words allocated in the minor heap that survived a minor collection and were moved to the major heap since the program was started. *) major_words : float; (** Number of words allocated in the major heap, including the promoted words, since the program was started. *) minor_collections : int; (** Number of minor collections since the program was started. *) major_collections : int; (** Number of major collection cycles completed since the program was started. *) heap_words : int; (** Total size of the major heap, in words. *) heap_chunks : int; (** Number of contiguous pieces of memory that make up the major heap. *) live_words : int; (** Number of words of live data in the major heap, including the header words. *) live_blocks : int; (** Number of live blocks in the major heap. *) free_words : int; (** Number of words in the free list. *) free_blocks : int; (** Number of blocks in the free list. *) largest_free : int; (** Size (in words) of the largest block in the free list. *) fragments : int; (** Number of wasted words due to fragmentation. These are 1-words free blocks placed between two live blocks. They are not available for allocation. *) compactions : int; (** Number of heap compactions since the program was started. *) top_heap_words : int; (** Maximum size reached by the major heap, in words. *) stack_size: int; (** Current size of the stack, in words. @since 3.12.0 *) } (** The memory management counters are returned in a [stat] record. The total amount of memory allocated by the program since it was started is (in words) [minor_words + major_words - promoted_words]. Multiply by the word size (4 on a 32-bit machine, 8 on a 64-bit machine) to get the number of bytes. *) type control = { mutable minor_heap_size : int; (** The size (in words) of the minor heap. Changing this parameter will trigger a minor collection. Default: 32k. *) mutable major_heap_increment : int; (** The minimum number of words to add to the major heap when increasing it. Default: 124k. *) mutable space_overhead : int; (** The major GC speed is computed from this parameter. This is the memory that will be "wasted" because the GC does not immediatly collect unreachable blocks. It is expressed as a percentage of the memory used for live data. The GC will work more (use more CPU time and collect blocks more eagerly) if [space_overhead] is smaller. Default: 80. *) mutable verbose : int; (** This value controls the GC messages on standard error output. It is a sum of some of the following flags, to print messages on the corresponding events: - [0x001] Start of major GC cycle. - [0x002] Minor collection and major GC slice. - [0x004] Growing and shrinking of the heap. - [0x008] Resizing of stacks and memory manager tables. - [0x010] Heap compaction. - [0x020] Change of GC parameters. - [0x040] Computation of major GC slice size. - [0x080] Calling of finalisation functions. - [0x100] Bytecode executable search at start-up. - [0x200] Computation of compaction triggering condition. Default: 0. *) mutable max_overhead : int; (** Heap compaction is triggered when the estimated amount of "wasted" memory is more than [max_overhead] percent of the amount of live data. If [max_overhead] is set to 0, heap compaction is triggered at the end of each major GC cycle (this setting is intended for testing purposes only). If [max_overhead >= 1000000], compaction is never triggered. If compaction is permanently disabled, it is strongly suggested to set [allocation_policy] to 1. Default: 500. *) mutable stack_limit : int; (** The maximum size of the stack (in words). This is only relevant to the byte-code runtime, as the native code runtime uses the operating system's stack. Default: 256k. *) mutable allocation_policy : int; (** The policy used for allocating in the heap. Possible values are 0 and 1. 0 is the next-fit policy, which is quite fast but can result in fragmentation. 1 is the first-fit policy, which can be slower in some cases but can be better for programs with fragmentation problems. Default: 0. @since 3.11.0 *) } (** The GC parameters are given as a [control] record. Note that these parameters can also be initialised by setting the OCAMLRUNPARAM environment variable. See the documentation of [ocamlrun]. *) external stat : unit -> stat = "caml_gc_stat" (** Return the current values of the memory management counters in a [stat] record. This function examines every heap block to get the statistics. *) external quick_stat : unit -> stat = "caml_gc_quick_stat" (** Same as [stat] except that [live_words], [live_blocks], [free_words], [free_blocks], [largest_free], and [fragments] are set to 0. This function is much faster than [stat] because it does not need to go through the heap. *) external counters : unit -> float * float * float = "caml_gc_counters" (** Return [(minor_words, promoted_words, major_words)]. This function is as fast as [quick_stat]. *) external get : unit -> control = "caml_gc_get" (** Return the current values of the GC parameters in a [control] record. *) external set : control -> unit = "caml_gc_set" (** [set r] changes the GC parameters according to the [control] record [r]. The normal usage is: [Gc.set { (Gc.get()) with Gc.verbose = 0x00d }] *) external minor : unit -> unit = "caml_gc_minor" (** Trigger a minor collection. *) external major_slice : int -> int = "caml_gc_major_slice";; (** Do a minor collection and a slice of major collection. The argument is the size of the slice, 0 to use the automatically-computed slice size. In all cases, the result is the computed slice size. *) external major : unit -> unit = "caml_gc_major" (** Do a minor collection and finish the current major collection cycle. *) external full_major : unit -> unit = "caml_gc_full_major" (** Do a minor collection, finish the current major collection cycle, and perform a complete new cycle. This will collect all currently unreachable blocks. *) external compact : unit -> unit = "caml_gc_compaction" (** Perform a full major collection and compact the heap. Note that heap compaction is a lengthy operation. *) val print_stat : out_channel -> unit (** Print the current values of the memory management counters (in human-readable form) into the channel argument. *) val allocated_bytes : unit -> float (** Return the total number of bytes allocated since the program was started. It is returned as a [float] to avoid overflow problems with [int] on 32-bit machines. *) val finalise : ('a -> unit) -> 'a -> unit (** [finalise f v] registers [f] as a finalisation function for [v]. [v] must be heap-allocated. [f] will be called with [v] as argument at some point between the first time [v] becomes unreachable and the time [v] is collected by the GC. Several functions can be registered for the same value, or even several instances of the same function. Each instance will be called once (or never, if the program terminates before [v] becomes unreachable). The GC will call the finalisation functions in the order of deallocation. When several values become unreachable at the same time (i.e. during the same GC cycle), the finalisation functions will be called in the reverse order of the corresponding calls to [finalise]. If [finalise] is called in the same order as the values are allocated, that means each value is finalised before the values it depends upon. Of course, this becomes false if additional dependencies are introduced by assignments. Anything reachable from the closure of finalisation functions is considered reachable, so the following code will not work as expected: - [ let v = ... in Gc.finalise (fun x -> ...) v ] Instead you should write: - [ let f = fun x -> ... ;; let v = ... in Gc.finalise f v ] The [f] function can use all features of OCaml, including assignments that make the value reachable again. It can also loop forever (in this case, the other finalisation functions will not be called during the execution of f, unless it calls [finalise_release]). It can call [finalise] on [v] or other values to register other functions or even itself. It can raise an exception; in this case the exception will interrupt whatever the program was doing when the function was called. [finalise] will raise [Invalid_argument] if [v] is not heap-allocated. Some examples of values that are not heap-allocated are integers, constant constructors, booleans, the empty array, the empty list, the unit value. The exact list of what is heap-allocated or not is implementation-dependent. Some constant values can be heap-allocated but never deallocated during the lifetime of the program, for example a list of integer constants; this is also implementation-dependent. You should also be aware that compiler optimisations may duplicate some immutable values, for example floating-point numbers when stored into arrays, so they can be finalised and collected while another copy is still in use by the program. The results of calling {!String.make}, {!String.create}, {!Array.make}, and {!Pervasives.ref} are guaranteed to be heap-allocated and non-constant except when the length argument is [0]. *) val finalise_release : unit -> unit;; (** A finalisation function may call [finalise_release] to tell the GC that it can launch the next finalisation function without waiting for the current one to return. *) type alarm (** An alarm is a piece of data that calls a user function at the end of each major GC cycle. The following functions are provided to create and delete alarms. *) val create_alarm : (unit -> unit) -> alarm (** [create_alarm f] will arrange for [f] to be called at the end of each major GC cycle, starting with the current cycle or the next one. A value of type [alarm] is returned that you can use to call [delete_alarm]. *) val delete_alarm : alarm -> unit (** [delete_alarm a] will stop the calls to the function associated to [a]. Calling [delete_alarm a] again has no effect. *) mingw-ocaml/ocaml/stdlib/gc.ml0000644000175000017500000000664512124403240015674 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) type stat = { minor_words : float; promoted_words : float; major_words : float; minor_collections : int; major_collections : int; heap_words : int; heap_chunks : int; live_words : int; live_blocks : int; free_words : int; free_blocks : int; largest_free : int; fragments : int; compactions : int; top_heap_words : int; stack_size : int; };; type control = { mutable minor_heap_size : int; mutable major_heap_increment : int; mutable space_overhead : int; mutable verbose : int; mutable max_overhead : int; mutable stack_limit : int; mutable allocation_policy : int; };; external stat : unit -> stat = "caml_gc_stat";; external quick_stat : unit -> stat = "caml_gc_quick_stat";; external counters : unit -> (float * float * float) = "caml_gc_counters";; external get : unit -> control = "caml_gc_get";; external set : control -> unit = "caml_gc_set";; external minor : unit -> unit = "caml_gc_minor";; external major_slice : int -> int = "caml_gc_major_slice";; external major : unit -> unit = "caml_gc_major";; external full_major : unit -> unit = "caml_gc_full_major";; external compact : unit -> unit = "caml_gc_compaction";; open Printf;; let print_stat c = let st = stat () in fprintf c "minor_words: %.0f\n" st.minor_words; fprintf c "promoted_words: %.0f\n" st.promoted_words; fprintf c "major_words: %.0f\n" st.major_words; fprintf c "minor_collections: %d\n" st.minor_collections; fprintf c "major_collections: %d\n" st.major_collections; fprintf c "heap_words: %d\n" st.heap_words; fprintf c "heap_chunks: %d\n" st.heap_chunks; fprintf c "top_heap_words: %d\n" st.top_heap_words; fprintf c "live_words: %d\n" st.live_words; fprintf c "live_blocks: %d\n" st.live_blocks; fprintf c "free_words: %d\n" st.free_words; fprintf c "free_blocks: %d\n" st.free_blocks; fprintf c "largest_free: %d\n" st.largest_free; fprintf c "fragments: %d\n" st.fragments; fprintf c "compactions: %d\n" st.compactions; ;; let allocated_bytes () = let (mi, pro, ma) = counters () in (mi +. ma -. pro) *. float_of_int (Sys.word_size / 8) ;; external finalise : ('a -> unit) -> 'a -> unit = "caml_final_register";; external finalise_release : unit -> unit = "caml_final_release";; type alarm = bool ref;; type alarm_rec = {active : alarm; f : unit -> unit};; let rec call_alarm arec = if !(arec.active) then begin finalise call_alarm arec; arec.f (); end; ;; let create_alarm f = let arec = { active = ref true; f = f } in finalise call_alarm arec; arec.active ;; let delete_alarm a = a := false;; mingw-ocaml/ocaml/stdlib/camlinternalMod.ml0000644000175000017500000000512212124403240020401 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2004 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) type shape = | Function | Lazy | Class | Module of shape array let rec init_mod loc shape = match shape with | Function -> let pad1 = 1 and pad2 = 2 and pad3 = 3 and pad4 = 4 and pad5 = 5 and pad6 = 6 and pad7 = 7 and pad8 = 8 in Obj.repr(fun _ -> ignore pad1; ignore pad2; ignore pad3; ignore pad4; ignore pad5; ignore pad6; ignore pad7; ignore pad8; raise (Undefined_recursive_module loc)) | Lazy -> Obj.repr (lazy (raise (Undefined_recursive_module loc))) | Class -> Obj.repr (CamlinternalOO.dummy_class loc) | Module comps -> Obj.repr (Array.map (init_mod loc) comps) let overwrite o n = assert (Obj.size o >= Obj.size n); for i = 0 to Obj.size n - 1 do Obj.set_field o i (Obj.field n i) done let rec update_mod shape o n = match shape with | Function -> if Obj.tag n = Obj.closure_tag && Obj.size n <= Obj.size o then begin overwrite o n; Obj.truncate o (Obj.size n) (* PR #4008 *) end else overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x)) | Lazy -> if Obj.tag n = Obj.lazy_tag then Obj.set_field o 0 (Obj.field n 0) else if Obj.tag n = Obj.forward_tag then begin (* PR#4316 *) Obj.set_tag o Obj.forward_tag; Obj.set_field o 0 (Obj.field n 0) end else begin (* forwarding pointer was shortcut by GC *) Obj.set_tag o Obj.forward_tag; Obj.set_field o 0 n end | Class -> assert (Obj.tag n = 0 && Obj.size n = 4); overwrite o n | Module comps -> assert (Obj.tag n = 0 && Obj.size n >= Array.length comps); for i = 0 to Array.length comps - 1 do update_mod comps.(i) (Obj.field o i) (Obj.field n i) done mingw-ocaml/ocaml/asmcomp/0000755000175000017500000000000012124403240015114 5ustar tootstootsmingw-ocaml/ocaml/asmcomp/asmpackager.ml0000644000175000017500000001613012124403240017725 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* "Package" a set of .cmx/.o files into one .cmx/.o file having the original compilation units as sub-modules. *) open Printf open Misc open Lambda open Clambda open Cmx_format type error = Illegal_renaming of string * string | Forward_reference of string * string | Wrong_for_pack of string * string | Linking_error | Assembler_error of string | File_not_found of string exception Error of error (* Read the unit information from a .cmx file. *) type pack_member_kind = PM_intf | PM_impl of unit_infos type pack_member = { pm_file: string; pm_name: string; pm_kind: pack_member_kind } let read_member_info pack_path file = let name = String.capitalize(Filename.basename(chop_extensions file)) in let kind = if Filename.check_suffix file ".cmx" then begin let (info, crc) = Compilenv.read_unit_info file in if info.ui_name <> name then raise(Error(Illegal_renaming(file, info.ui_name))); if info.ui_symbol <> (Compilenv.current_unit_infos()).ui_symbol ^ "__" ^ info.ui_name then raise(Error(Wrong_for_pack(file, pack_path))); Asmlink.check_consistency file info crc; Compilenv.cache_unit_info info; PM_impl info end else PM_intf in { pm_file = file; pm_name = name; pm_kind = kind } (* Check absence of forward references *) let check_units members = let rec check forbidden = function [] -> () | mb :: tl -> begin match mb.pm_kind with | PM_intf -> () | PM_impl infos -> List.iter (fun (unit, _) -> if List.mem unit forbidden then raise(Error(Forward_reference(mb.pm_file, unit)))) infos.ui_imports_cmx end; check (list_remove mb.pm_name forbidden) tl in check (List.map (fun mb -> mb.pm_name) members) members (* Make the .o file for the package *) let make_package_object ppf members targetobj targetname coercion = let objtemp = if !Clflags.keep_asm_file then chop_extension_if_any targetobj ^ ".pack" ^ Config.ext_obj else (* Put the full name of the module in the temporary file name to avoid collisions with MSVC's link /lib in case of successive packs *) Filename.temp_file (Compilenv.make_symbol (Some "")) Config.ext_obj in let components = List.map (fun m -> match m.pm_kind with | PM_intf -> None | PM_impl _ -> Some(Ident.create_persistent m.pm_name)) members in Asmgen.compile_implementation (chop_extension_if_any objtemp) ppf (Translmod.transl_store_package components (Ident.create_persistent targetname) coercion); let objfiles = List.map (fun m -> chop_extension_if_any m.pm_file ^ Config.ext_obj) (List.filter (fun m -> m.pm_kind <> PM_intf) members) in let ok = Ccomp.call_linker Ccomp.Partial targetobj (objtemp :: objfiles) "" in remove_file objtemp; if not ok then raise(Error Linking_error) (* Make the .cmx file for the package *) let build_package_cmx members cmxfile = let unit_names = List.map (fun m -> m.pm_name) members in let filter lst = List.filter (fun (name, crc) -> not (List.mem name unit_names)) lst in let union lst = List.fold_left (List.fold_left (fun accu n -> if List.mem n accu then accu else n :: accu)) [] lst in let units = List.fold_right (fun m accu -> match m.pm_kind with PM_intf -> accu | PM_impl info -> info :: accu) members [] in let ui = Compilenv.current_unit_infos() in let pkg_infos = { ui_name = ui.ui_name; ui_symbol = ui.ui_symbol; ui_defines = List.flatten (List.map (fun info -> info.ui_defines) units) @ [ui.ui_symbol]; ui_imports_cmi = (ui.ui_name, Env.crc_of_unit ui.ui_name) :: filter(Asmlink.extract_crc_interfaces()); ui_imports_cmx = filter(Asmlink.extract_crc_implementations()); ui_approx = ui.ui_approx; ui_curry_fun = union(List.map (fun info -> info.ui_curry_fun) units); ui_apply_fun = union(List.map (fun info -> info.ui_apply_fun) units); ui_send_fun = union(List.map (fun info -> info.ui_send_fun) units); ui_force_link = List.exists (fun info -> info.ui_force_link) units; } in Compilenv.write_unit_info pkg_infos cmxfile (* Make the .cmx and the .o for the package *) let package_object_files ppf files targetcmx targetobj targetname coercion = let pack_path = match !Clflags.for_package with | None -> targetname | Some p -> p ^ "." ^ targetname in let members = map_left_right (read_member_info pack_path) files in check_units members; make_package_object ppf members targetobj targetname coercion; build_package_cmx members targetcmx (* The entry point *) let package_files ppf files targetcmx = let files = List.map (fun f -> try find_in_path !Config.load_path f with Not_found -> raise(Error(File_not_found f))) files in let prefix = chop_extensions targetcmx in let targetcmi = prefix ^ ".cmi" in let targetobj = chop_extension_if_any targetcmx ^ Config.ext_obj in let targetname = String.capitalize(Filename.basename prefix) in (* Set the name of the current "input" *) Location.input_name := targetcmx; (* Set the name of the current compunit *) Compilenv.reset ?packname:!Clflags.for_package targetname; try let coercion = Typemod.package_units files targetcmi targetname in package_object_files ppf files targetcmx targetobj targetname coercion with x -> remove_file targetcmx; remove_file targetobj; raise x (* Error report *) open Format let report_error ppf = function Illegal_renaming(file, id) -> fprintf ppf "Wrong file naming: %a@ contains the code for@ %s" Location.print_filename file id | Forward_reference(file, ident) -> fprintf ppf "Forward reference to %s in file %a" ident Location.print_filename file | Wrong_for_pack(file, path) -> fprintf ppf "File %a@ was not compiled with the `-for-pack %s' option" Location.print_filename file path | File_not_found file -> fprintf ppf "File %s not found" file | Assembler_error file -> fprintf ppf "Error while assembling %s" file | Linking_error -> fprintf ppf "Error during partial linking" mingw-ocaml/ocaml/asmcomp/.ignore0000644000175000017500000000007512124403240016402 0ustar tootstootsemit.ml arch.ml proc.ml selection.ml reload.ml scheduling.ml mingw-ocaml/ocaml/asmcomp/asmlibrarian.mli0000644000175000017500000000205712124403240020267 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Build libraries of .cmx files *) open Format val create_archive: string list -> string -> unit type error = File_not_found of string | Archiver_error of string exception Error of error val report_error: formatter -> error -> unit mingw-ocaml/ocaml/asmcomp/debuginfo.mli0000644000175000017500000000222512124403240017562 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) type kind = Dinfo_call | Dinfo_raise type t = private { dinfo_kind: kind; dinfo_file: string; dinfo_line: int; dinfo_char_start: int; dinfo_char_end: int } val none: t val is_none: t -> bool val to_string: t -> string val from_location: kind -> Location.t -> t val from_call: Lambda.lambda_event -> t val from_raise: Lambda.lambda_event -> t mingw-ocaml/ocaml/asmcomp/cmx_format.mli0000644000175000017500000000546112124403240017764 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2010 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Format of .cmx, .cmxa and .cmxs files *) (* Each .o file has a matching .cmx file that provides the following infos on the compilation unit: - list of other units imported, with MD5s of their .cmx files - approximation of the structure implemented (includes descriptions of known functions: arity and direct entry points) - list of currying functions and application functions needed The .cmx file contains these infos (as an externed record) plus a MD5 of these infos *) type unit_infos = { mutable ui_name: string; (* Name of unit implemented *) mutable ui_symbol: string; (* Prefix for symbols *) mutable ui_defines: string list; (* Unit and sub-units implemented *) mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *) mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *) mutable ui_approx: Clambda.value_approximation; (* Approx of the structure *) mutable ui_curry_fun: int list; (* Currying functions needed *) mutable ui_apply_fun: int list; (* Apply functions needed *) mutable ui_send_fun: int list; (* Send functions needed *) mutable ui_force_link: bool } (* Always linked *) (* Each .a library has a matching .cmxa file that provides the following infos on the library: *) type library_infos = { lib_units: (unit_infos * Digest.t) list; (* List of unit infos w/ MD5s *) lib_ccobjs: string list; (* C object files needed *) lib_ccopts: string list } (* Extra opts to C compiler *) (* Each .cmxs dynamically-loaded plugin contains a symbol "caml_plugin_header" containing the following info (as an externed record) *) type dynunit = { dynu_name: string; dynu_crc: Digest.t; dynu_imports_cmi: (string * Digest.t) list; dynu_imports_cmx: (string * Digest.t) list; dynu_defines: string list; } type dynheader = { dynu_magic: string; dynu_units: dynunit list; } mingw-ocaml/ocaml/asmcomp/cmmgen.ml0000644000175000017500000023242512124403240016724 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Translation from closed lambda to C-- *) open Misc open Arch open Asttypes open Primitive open Types open Lambda open Clambda open Cmm open Cmx_format (* Local binding of complex expressions *) let bind name arg fn = match arg with Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ -> fn arg | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) let bind_nonvar name arg fn = match arg with Cconst_int _ | Cconst_natint _ | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ -> fn arg | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) (* Block headers. Meaning of the tag field: see stdlib/obj.ml *) let float_tag = Cconst_int Obj.double_tag let floatarray_tag = Cconst_int Obj.double_array_tag let block_header tag sz = Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10) (Nativeint.of_int tag) let closure_header sz = block_header Obj.closure_tag sz let infix_header ofs = block_header Obj.infix_tag ofs let float_header = block_header Obj.double_tag (size_float / size_addr) let floatarray_header len = block_header Obj.double_array_tag (len * size_float / size_addr) let string_header len = block_header Obj.string_tag ((len + size_addr) / size_addr) let boxedint32_header = block_header Obj.custom_tag 2 let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr) let boxedintnat_header = block_header Obj.custom_tag 2 let alloc_block_header tag sz = Cconst_natint(block_header tag sz) let alloc_float_header = Cconst_natint(float_header) let alloc_floatarray_header len = Cconst_natint(floatarray_header len) let alloc_closure_header sz = Cconst_natint(closure_header sz) let alloc_infix_header ofs = Cconst_natint(infix_header ofs) let alloc_boxedint32_header = Cconst_natint(boxedint32_header) let alloc_boxedint64_header = Cconst_natint(boxedint64_header) let alloc_boxedintnat_header = Cconst_natint(boxedintnat_header) (* Integers *) let max_repr_int = max_int asr 1 let min_repr_int = min_int asr 1 let int_const n = if n <= max_repr_int && n >= min_repr_int then Cconst_int((n lsl 1) + 1) else Cconst_natint (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) let add_const c n = if n = 0 then c else Cop(Caddi, [c; Cconst_int n]) let incr_int = function Cconst_int n when n < max_int -> Cconst_int(n+1) | Cop(Caddi, [c; Cconst_int n]) when n < max_int -> add_const c (n + 1) | c -> add_const c 1 let decr_int = function Cconst_int n when n > min_int -> Cconst_int(n-1) | Cop(Caddi, [c; Cconst_int n]) when n > min_int -> add_const c (n - 1) | c -> add_const c (-1) let add_int c1 c2 = match (c1, c2) with (Cop(Caddi, [c1; Cconst_int n1]), Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_add n1 n2 -> add_const (Cop(Caddi, [c1; c2])) (n1 + n2) | (Cop(Caddi, [c1; Cconst_int n1]), c2) -> add_const (Cop(Caddi, [c1; c2])) n1 | (c1, Cop(Caddi, [c2; Cconst_int n2])) -> add_const (Cop(Caddi, [c1; c2])) n2 | (Cconst_int _, _) -> Cop(Caddi, [c2; c1]) | (_, _) -> Cop(Caddi, [c1; c2]) let sub_int c1 c2 = match (c1, c2) with (Cop(Caddi, [c1; Cconst_int n1]), Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_sub n1 n2 -> add_const (Cop(Csubi, [c1; c2])) (n1 - n2) | (Cop(Caddi, [c1; Cconst_int n1]), c2) -> add_const (Cop(Csubi, [c1; c2])) n1 | (c1, Cop(Caddi, [c2; Cconst_int n2])) when n2 <> min_int -> add_const (Cop(Csubi, [c1; c2])) (-n2) | (c1, Cconst_int n) when n <> min_int -> add_const c1 (-n) | (c1, c2) -> Cop(Csubi, [c1; c2]) let mul_int c1 c2 = match (c1, c2) with (Cconst_int 0, _) -> c1 | (Cconst_int 1, _) -> c2 | (_, Cconst_int 0) -> c2 | (_, Cconst_int 1) -> c1 | (_, _) -> Cop(Cmuli, [c1; c2]) let tag_int = function Cconst_int n -> int_const n | c -> Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) let force_tag_int = function Cconst_int n -> int_const n | c -> Cop(Cor, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) let untag_int = function Cconst_int n -> Cconst_int(n asr 1) | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c | Cop(Cor, [Cop(Casr, [c; Cconst_int n]); Cconst_int 1]) when n > 0 && n < size_int * 8 -> Cop(Casr, [c; Cconst_int (n+1)]) | Cop(Cor, [Cop(Clsr, [c; Cconst_int n]); Cconst_int 1]) when n > 0 && n < size_int * 8 -> Cop(Clsr, [c; Cconst_int (n+1)]) | Cop(Cor, [c; Cconst_int 1]) -> Cop(Casr, [c; Cconst_int 1]) | c -> Cop(Casr, [c; Cconst_int 1]) let lsl_int c1 c2 = match (c1, c2) with (Cop(Clsl, [c; Cconst_int n1]), Cconst_int n2) when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 -> Cop(Clsl, [c; Cconst_int (n1 + n2)]) | (_, _) -> Cop(Clsl, [c1; c2]) let ignore_low_bit_int = function Cop(Caddi, [(Cop(Clsl, [_; Cconst_int 1]) as c); Cconst_int 1]) -> c | Cop(Cor, [c; Cconst_int 1]) -> c | c -> c (* Division or modulo on tagged integers. The overflow case min_int / -1 cannot occur, but we must guard against division by zero. *) let is_different_from x = function Cconst_int n -> n <> x | Cconst_natint n -> n <> Nativeint.of_int x | _ -> false let safe_divmod op c1 c2 dbg = if !Clflags.fast || is_different_from 0 c2 then Cop(op, [c1; c2]) else bind "divisor" c2 (fun c2 -> Cifthenelse(c2, Cop(op, [c1; c2]), Cop(Craise dbg, [Cconst_symbol "caml_bucket_Division_by_zero"]))) (* Division or modulo on boxed integers. The overflow case min_int / -1 can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *) let safe_divmod_bi mkop mkm1 c1 c2 bi dbg = bind "dividend" c1 (fun c1 -> bind "divisor" c2 (fun c2 -> let c3 = if Arch.division_crashes_on_overflow && (size_int = 4 || bi <> Pint32) && not (is_different_from (-1) c2) then Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)]), mkop c1 c2, mkm1 c1) else mkop c1 c2 in if !Clflags.fast || is_different_from 0 c2 then c3 else Cifthenelse(c2, c3, Cop(Craise dbg, [Cconst_symbol "caml_bucket_Division_by_zero"])))) let safe_div_bi = safe_divmod_bi (fun c1 c2 -> Cop(Cdivi, [c1;c2])) (fun c1 -> Cop(Csubi, [Cconst_int 0; c1])) let safe_mod_bi = safe_divmod_bi (fun c1 c2 -> Cop(Cmodi, [c1;c2])) (fun c1 -> Cconst_int 0) (* Bool *) let test_bool = function Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c | Cop(Clsl, [c; Cconst_int 1]) -> c | c -> Cop(Ccmpi Cne, [c; Cconst_int 1]) (* Float *) let box_float c = Cop(Calloc, [alloc_float_header; c]) let rec unbox_float = function Cop(Calloc, [header; c]) -> c | Clet(id, exp, body) -> Clet(id, exp, unbox_float body) | Cifthenelse(cond, e1, e2) -> Cifthenelse(cond, unbox_float e1, unbox_float e2) | Csequence(e1, e2) -> Csequence(e1, unbox_float e2) | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map unbox_float el) | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_float e1, unbox_float e2) | Ctrywith(e1, id, e2) -> Ctrywith(unbox_float e1, id, unbox_float e2) | c -> Cop(Cload Double_u, [c]) (* Complex *) let box_complex c_re c_im = Cop(Calloc, [alloc_floatarray_header 2; c_re; c_im]) let complex_re c = Cop(Cload Double_u, [c]) let complex_im c = Cop(Cload Double_u, [Cop(Cadda, [c; Cconst_int size_float])]) (* Unit *) let return_unit c = Csequence(c, Cconst_pointer 1) let rec remove_unit = function Cconst_pointer 1 -> Ctuple [] | Csequence(c, Cconst_pointer 1) -> c | Csequence(c1, c2) -> Csequence(c1, remove_unit c2) | Cifthenelse(cond, ifso, ifnot) -> Cifthenelse(cond, remove_unit ifso, remove_unit ifnot) | Cswitch(sel, index, cases) -> Cswitch(sel, index, Array.map remove_unit cases) | Ccatch(io, ids, body, handler) -> Ccatch(io, ids, remove_unit body, remove_unit handler) | Ctrywith(body, exn, handler) -> Ctrywith(remove_unit body, exn, remove_unit handler) | Clet(id, c1, c2) -> Clet(id, c1, remove_unit c2) | Cop(Capply (mty, dbg), args) -> Cop(Capply (typ_void, dbg), args) | Cop(Cextcall(proc, mty, alloc, dbg), args) -> Cop(Cextcall(proc, typ_void, alloc, dbg), args) | Cexit (_,_) as c -> c | Ctuple [] as c -> c | c -> Csequence(c, Ctuple []) (* Access to block fields *) let field_address ptr n = if n = 0 then ptr else Cop(Cadda, [ptr; Cconst_int(n * size_addr)]) let get_field ptr n = Cop(Cload Word, [field_address ptr n]) let set_field ptr n newval = Cop(Cstore Word, [field_address ptr n; newval]) let header ptr = Cop(Cload Word, [Cop(Cadda, [ptr; Cconst_int(-size_int)])]) let tag_offset = if big_endian then -1 else -size_int let get_tag ptr = if Proc.word_addressed then (* If byte loads are slow *) Cop(Cand, [header ptr; Cconst_int 255]) else (* If byte loads are efficient *) Cop(Cload Byte_unsigned, [Cop(Cadda, [ptr; Cconst_int(tag_offset)])]) let get_size ptr = Cop(Clsr, [header ptr; Cconst_int 10]) (* Array indexing *) let log2_size_addr = Misc.log2 size_addr let log2_size_float = Misc.log2 size_float let wordsize_shift = 9 let numfloat_shift = 9 + log2_size_float - log2_size_addr let is_addr_array_hdr hdr = Cop(Ccmpi Cne, [Cop(Cand, [hdr; Cconst_int 255]); floatarray_tag]) let is_addr_array_ptr ptr = Cop(Ccmpi Cne, [get_tag ptr; floatarray_tag]) let addr_array_length hdr = Cop(Clsr, [hdr; Cconst_int wordsize_shift]) let float_array_length hdr = Cop(Clsr, [hdr; Cconst_int numfloat_shift]) let lsl_const c n = Cop(Clsl, [c; Cconst_int n]) let array_indexing log2size ptr ofs = match ofs with Cconst_int n -> let i = n asr 1 in if i = 0 then ptr else Cop(Cadda, [ptr; Cconst_int(i lsl log2size)]) | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> Cop(Cadda, [ptr; lsl_const c log2size]) | Cop(Caddi, [c; Cconst_int n]) -> Cop(Cadda, [Cop(Cadda, [ptr; lsl_const c (log2size - 1)]); Cconst_int((n-1) lsl (log2size - 1))]) | _ -> Cop(Cadda, [Cop(Cadda, [ptr; lsl_const ofs (log2size - 1)]); Cconst_int((-1) lsl (log2size - 1))]) let addr_array_ref arr ofs = Cop(Cload Word, [array_indexing log2_size_addr arr ofs]) let unboxed_float_array_ref arr ofs = Cop(Cload Double_u, [array_indexing log2_size_float arr ofs]) let float_array_ref arr ofs = box_float(unboxed_float_array_ref arr ofs) let addr_array_set arr ofs newval = Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none), [array_indexing log2_size_addr arr ofs; newval]) let int_array_set arr ofs newval = Cop(Cstore Word, [array_indexing log2_size_addr arr ofs; newval]) let float_array_set arr ofs newval = Cop(Cstore Double_u, [array_indexing log2_size_float arr ofs; newval]) (* String length *) let string_length exp = bind "str" exp (fun str -> let tmp_var = Ident.create "tmp" in Clet(tmp_var, Cop(Csubi, [Cop(Clsl, [Cop(Clsr, [header str; Cconst_int 10]); Cconst_int log2_size_addr]); Cconst_int 1]), Cop(Csubi, [Cvar tmp_var; Cop(Cload Byte_unsigned, [Cop(Cadda, [str; Cvar tmp_var])])]))) (* Message sending *) let lookup_tag obj tag = bind "tag" tag (fun tag -> Cop(Cextcall("caml_get_public_method", typ_addr, false, Debuginfo.none), [obj; tag])) let lookup_label obj lab = bind "lab" lab (fun lab -> let table = Cop (Cload Word, [obj]) in addr_array_ref table lab) let call_cached_method obj tag cache pos args dbg = let arity = List.length args in let cache = array_indexing log2_size_addr cache pos in Compilenv.need_send_fun arity; Cop(Capply (typ_addr, dbg), Cconst_symbol("caml_send" ^ string_of_int arity) :: obj :: tag :: cache :: args) (* Allocation *) let make_alloc_generic set_fn tag wordsize args = if wordsize <= Config.max_young_wosize then Cop(Calloc, Cconst_natint(block_header tag wordsize) :: args) else begin let id = Ident.create "alloc" in let rec fill_fields idx = function [] -> Cvar id | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1, fill_fields (idx + 2) el) in Clet(id, Cop(Cextcall("caml_alloc", typ_addr, true, Debuginfo.none), [Cconst_int wordsize; Cconst_int tag]), fill_fields 1 args) end let make_alloc tag args = make_alloc_generic addr_array_set tag (List.length args) args let make_float_alloc tag args = make_alloc_generic float_array_set tag (List.length args * size_float / size_addr) args (* Bounds checking *) let make_checkbound dbg = function | [Cop(Clsr, [a1; Cconst_int n]); Cconst_int m] when (m lsl n) > n -> Cop(Ccheckbound dbg, [a1; Cconst_int(m lsl n + 1 lsl n - 1)]) | args -> Cop(Ccheckbound dbg, args) (* To compile "let rec" over values *) let fundecls_size fundecls = let sz = ref (-1) in List.iter (fun f -> sz := !sz + 1 + (if f.arity = 1 then 2 else 3)) fundecls; !sz type rhs_kind = | RHS_block of int | RHS_floatblock of int | RHS_nonrec ;; let rec expr_size = function | Uclosure(fundecls, clos_vars) -> RHS_block (fundecls_size fundecls + List.length clos_vars) | Ulet(id, exp, body) -> expr_size body | Uletrec(bindings, body) -> expr_size body | Uprim(Pmakeblock(tag, mut), args, _) -> RHS_block (List.length args) | Uprim(Pmakearray(Paddrarray | Pintarray), args, _) -> RHS_block (List.length args) | Uprim(Pmakearray(Pfloatarray), args, _) -> RHS_floatblock (List.length args) | Usequence(exp, exp') -> expr_size exp' | _ -> RHS_nonrec (* Record application and currying functions *) let apply_function n = Compilenv.need_apply_fun n; "caml_apply" ^ string_of_int n let curry_function n = Compilenv.need_curry_fun n; if n >= 0 then "caml_curry" ^ string_of_int n else "caml_tuplify" ^ string_of_int (-n) (* Comparisons *) let transl_comparison = function Lambda.Ceq -> Ceq | Lambda.Cneq -> Cne | Lambda.Cge -> Cge | Lambda.Cgt -> Cgt | Lambda.Cle -> Cle | Lambda.Clt -> Clt (* Translate structured constants *) (* Fabrice: moved to compilenv.ml ---- let const_label = ref 0 let new_const_label () = incr const_label; !const_label let new_const_symbol () = incr const_label; Compilenv.make_symbol (Some (string_of_int !const_label)) let structured_constants = ref ([] : (string * structured_constant) list) *) let transl_constant = function Const_base(Const_int n) -> int_const n | Const_base(Const_char c) -> Cconst_int(((Char.code c) lsl 1) + 1) | Const_pointer n -> if n <= max_repr_int && n >= min_repr_int then Cconst_pointer((n lsl 1) + 1) else Cconst_natpointer (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) | cst -> Cconst_symbol (Compilenv.new_structured_constant cst false) (* Translate constant closures *) let constant_closures = ref ([] : (string * ufunction list) list) (* Boxed integers *) let box_int_constant bi n = match bi with Pnativeint -> Const_base(Const_nativeint n) | Pint32 -> Const_base(Const_int32 (Nativeint.to_int32 n)) | Pint64 -> Const_base(Const_int64 (Int64.of_nativeint n)) let operations_boxed_int bi = match bi with Pnativeint -> "caml_nativeint_ops" | Pint32 -> "caml_int32_ops" | Pint64 -> "caml_int64_ops" let alloc_header_boxed_int bi = match bi with Pnativeint -> alloc_boxedintnat_header | Pint32 -> alloc_boxedint32_header | Pint64 -> alloc_boxedint64_header let box_int bi arg = match arg with Cconst_int n -> transl_constant (box_int_constant bi (Nativeint.of_int n)) | Cconst_natint n -> transl_constant (box_int_constant bi n) | _ -> let arg' = if bi = Pint32 && size_int = 8 && big_endian then Cop(Clsl, [arg; Cconst_int 32]) else arg in Cop(Calloc, [alloc_header_boxed_int bi; Cconst_symbol(operations_boxed_int bi); arg']) let rec unbox_int bi arg = match arg with Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int 32])]) when bi = Pint32 && size_int = 8 && big_endian -> (* Force sign-extension of low 32 bits *) Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32]) | Cop(Calloc, [hdr; ops; contents]) when bi = Pint32 && size_int = 8 && not big_endian -> (* Force sign-extension of low 32 bits *) Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32]) | Cop(Calloc, [hdr; ops; contents]) -> contents | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body) | Cifthenelse(cond, e1, e2) -> Cifthenelse(cond, unbox_int bi e1, unbox_int bi e2) | Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2) | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map (unbox_int bi) el) | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_int bi e1, unbox_int bi e2) | Ctrywith(e1, id, e2) -> Ctrywith(unbox_int bi e1, id, unbox_int bi e2) | _ -> Cop(Cload(if bi = Pint32 then Thirtytwo_signed else Word), [Cop(Cadda, [arg; Cconst_int size_addr])]) let make_unsigned_int bi arg = if bi = Pint32 && size_int = 8 then Cop(Cand, [arg; Cconst_natint 0xFFFFFFFFn]) else arg (* Big arrays *) let bigarray_elt_size = function Pbigarray_unknown -> assert false | Pbigarray_float32 -> 4 | Pbigarray_float64 -> 8 | Pbigarray_sint8 -> 1 | Pbigarray_uint8 -> 1 | Pbigarray_sint16 -> 2 | Pbigarray_uint16 -> 2 | Pbigarray_int32 -> 4 | Pbigarray_int64 -> 8 | Pbigarray_caml_int -> size_int | Pbigarray_native_int -> size_int | Pbigarray_complex32 -> 8 | Pbigarray_complex64 -> 16 let bigarray_indexing unsafe elt_kind layout b args dbg = let check_bound a1 a2 k = if unsafe then k else Csequence(make_checkbound dbg [a1;a2], k) in let rec ba_indexing dim_ofs delta_ofs = function [] -> assert false | [arg] -> bind "idx" (untag_int arg) (fun idx -> check_bound (Cop(Cload Word,[field_address b dim_ofs])) idx idx) | arg1 :: argl -> let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in bind "idx" (untag_int arg1) (fun idx -> bind "bound" (Cop(Cload Word, [field_address b dim_ofs])) (fun bound -> check_bound bound idx (add_int (mul_int rem bound) idx))) in let offset = match layout with Pbigarray_unknown_layout -> assert false | Pbigarray_c_layout -> ba_indexing (4 + List.length args) (-1) (List.rev args) | Pbigarray_fortran_layout -> ba_indexing 5 1 (List.map (fun idx -> sub_int idx (Cconst_int 2)) args) and elt_size = bigarray_elt_size elt_kind in let byte_offset = if elt_size = 1 then offset else Cop(Clsl, [offset; Cconst_int(log2 elt_size)]) in Cop(Cadda, [Cop(Cload Word, [field_address b 1]); byte_offset]) let bigarray_word_kind = function Pbigarray_unknown -> assert false | Pbigarray_float32 -> Single | Pbigarray_float64 -> Double | Pbigarray_sint8 -> Byte_signed | Pbigarray_uint8 -> Byte_unsigned | Pbigarray_sint16 -> Sixteen_signed | Pbigarray_uint16 -> Sixteen_unsigned | Pbigarray_int32 -> Thirtytwo_signed | Pbigarray_int64 -> Word | Pbigarray_caml_int -> Word | Pbigarray_native_int -> Word | Pbigarray_complex32 -> Single | Pbigarray_complex64 -> Double let bigarray_get unsafe elt_kind layout b args dbg = bind "ba" b (fun b -> match elt_kind with Pbigarray_complex32 | Pbigarray_complex64 -> let kind = bigarray_word_kind elt_kind in let sz = bigarray_elt_size elt_kind / 2 in bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> box_complex (Cop(Cload kind, [addr])) (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])]))) | _ -> Cop(Cload (bigarray_word_kind elt_kind), [bigarray_indexing unsafe elt_kind layout b args dbg])) let bigarray_set unsafe elt_kind layout b args newval dbg = bind "ba" b (fun b -> match elt_kind with Pbigarray_complex32 | Pbigarray_complex64 -> let kind = bigarray_word_kind elt_kind in let sz = bigarray_elt_size elt_kind / 2 in bind "newval" newval (fun newv -> bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> Csequence( Cop(Cstore kind, [addr; complex_re newv]), Cop(Cstore kind, [Cop(Cadda, [addr; Cconst_int sz]); complex_im newv])))) | _ -> Cop(Cstore (bigarray_word_kind elt_kind), [bigarray_indexing unsafe elt_kind layout b args dbg; newval])) (* Simplification of some primitives into C calls *) let default_prim name = { prim_name = name; prim_arity = 0 (*ignored*); prim_alloc = true; prim_native_name = ""; prim_native_float = false } let simplif_primitive_32bits = function Pbintofint Pint64 -> Pccall (default_prim "caml_int64_of_int") | Pintofbint Pint64 -> Pccall (default_prim "caml_int64_to_int") | Pcvtbint(Pint32, Pint64) -> Pccall (default_prim "caml_int64_of_int32") | Pcvtbint(Pint64, Pint32) -> Pccall (default_prim "caml_int64_to_int32") | Pcvtbint(Pnativeint, Pint64) -> Pccall (default_prim "caml_int64_of_nativeint") | Pcvtbint(Pint64, Pnativeint) -> Pccall (default_prim "caml_int64_to_nativeint") | Pnegbint Pint64 -> Pccall (default_prim "caml_int64_neg") | Paddbint Pint64 -> Pccall (default_prim "caml_int64_add") | Psubbint Pint64 -> Pccall (default_prim "caml_int64_sub") | Pmulbint Pint64 -> Pccall (default_prim "caml_int64_mul") | Pdivbint Pint64 -> Pccall (default_prim "caml_int64_div") | Pmodbint Pint64 -> Pccall (default_prim "caml_int64_mod") | Pandbint Pint64 -> Pccall (default_prim "caml_int64_and") | Porbint Pint64 -> Pccall (default_prim "caml_int64_or") | Pxorbint Pint64 -> Pccall (default_prim "caml_int64_xor") | Plslbint Pint64 -> Pccall (default_prim "caml_int64_shift_left") | Plsrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right_unsigned") | Pasrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right") | Pbintcomp(Pint64, Lambda.Ceq) -> Pccall (default_prim "caml_equal") | Pbintcomp(Pint64, Lambda.Cneq) -> Pccall (default_prim "caml_notequal") | Pbintcomp(Pint64, Lambda.Clt) -> Pccall (default_prim "caml_lessthan") | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan") | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal") | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal") | Pbigarrayref(unsafe, n, Pbigarray_int64, layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) | Pbigarrayset(unsafe, n, Pbigarray_int64, layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | p -> p let simplif_primitive p = match p with | Pduprecord _ -> Pccall (default_prim "caml_obj_dup") | Pbigarrayref(unsafe, n, Pbigarray_unknown, layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) | Pbigarrayset(unsafe, n, Pbigarray_unknown, layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | Pbigarrayref(unsafe, n, kind, Pbigarray_unknown_layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) | Pbigarrayset(unsafe, n, kind, Pbigarray_unknown_layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | p -> if size_int = 8 then p else simplif_primitive_32bits p (* Build switchers both for constants and blocks *) (* constants first *) let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg])) exception Found of int let make_switch_gen arg cases acts = let lcases = Array.length cases in let new_cases = Array.create lcases 0 in let store = Switch.mk_store (=) in for i = 0 to Array.length cases-1 do let act = cases.(i) in let new_act = store.Switch.act_store act in new_cases.(i) <- new_act done ; Cswitch (arg, new_cases, Array.map (fun n -> acts.(n)) (store.Switch.act_get ())) (* Then for blocks *) module SArgBlocks = struct type primitive = operation let eqint = Ccmpi Ceq let neint = Ccmpi Cne let leint = Ccmpi Cle let ltint = Ccmpi Clt let geint = Ccmpi Cge let gtint = Ccmpi Cgt type act = expression let default = Cexit (0,[]) let make_prim p args = Cop (p,args) let make_offset arg n = add_const arg n let make_isout h arg = Cop (Ccmpa Clt, [h ; arg]) let make_isin h arg = Cop (Ccmpa Cge, [h ; arg]) let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot) let make_switch arg cases actions = make_switch_gen arg cases actions let bind arg body = bind "switcher" arg body end module SwitcherBlocks = Switch.Make(SArgBlocks) (* Auxiliary functions for optimizing "let" of boxed numbers (floats and boxed integers *) type unboxed_number_kind = No_unboxing | Boxed_float | Boxed_integer of boxed_integer let is_unboxed_number = function Uconst(Const_base(Const_float f), _) -> Boxed_float | Uprim(p, _, _) -> begin match simplif_primitive p with Pccall p -> if p.prim_native_float then Boxed_float else No_unboxing | Pfloatfield _ -> Boxed_float | Pfloatofint -> Boxed_float | Pnegfloat -> Boxed_float | Pabsfloat -> Boxed_float | Paddfloat -> Boxed_float | Psubfloat -> Boxed_float | Pmulfloat -> Boxed_float | Pdivfloat -> Boxed_float | Parrayrefu Pfloatarray -> Boxed_float | Parrayrefs Pfloatarray -> Boxed_float | Pbintofint bi -> Boxed_integer bi | Pcvtbint(src, dst) -> Boxed_integer dst | Pnegbint bi -> Boxed_integer bi | Paddbint bi -> Boxed_integer bi | Psubbint bi -> Boxed_integer bi | Pmulbint bi -> Boxed_integer bi | Pdivbint bi -> Boxed_integer bi | Pmodbint bi -> Boxed_integer bi | Pandbint bi -> Boxed_integer bi | Porbint bi -> Boxed_integer bi | Pxorbint bi -> Boxed_integer bi | Plslbint bi -> Boxed_integer bi | Plsrbint bi -> Boxed_integer bi | Pasrbint bi -> Boxed_integer bi | Pbigarrayref(_, _, (Pbigarray_float32 | Pbigarray_float64), _) -> Boxed_float | Pbigarrayref(_, _, Pbigarray_int32, _) -> Boxed_integer Pint32 | Pbigarrayref(_, _, Pbigarray_int64, _) -> Boxed_integer Pint64 | Pbigarrayref(_, _, Pbigarray_native_int, _) -> Boxed_integer Pnativeint | _ -> No_unboxing end | _ -> No_unboxing let subst_boxed_number unbox_fn boxed_id unboxed_id exp = let need_boxed = ref false in let assigned = ref false in let rec subst = function Cvar id as e -> if Ident.same id boxed_id then need_boxed := true; e | Clet(id, arg, body) -> Clet(id, subst arg, subst body) | Cassign(id, arg) -> if Ident.same id boxed_id then begin assigned := true; Cassign(unboxed_id, subst(unbox_fn arg)) end else Cassign(id, subst arg) | Ctuple argv -> Ctuple(List.map subst argv) | Cop(Cload _, [Cvar id]) as e -> if Ident.same id boxed_id then Cvar unboxed_id else e | Cop(Cload _, [Cop(Cadda, [Cvar id; _])]) as e -> if Ident.same id boxed_id then Cvar unboxed_id else e | Cop(op, argv) -> Cop(op, List.map subst argv) | Csequence(e1, e2) -> Csequence(subst e1, subst e2) | Cifthenelse(e1, e2, e3) -> Cifthenelse(subst e1, subst e2, subst e3) | Cswitch(arg, index, cases) -> Cswitch(subst arg, index, Array.map subst cases) | Cloop e -> Cloop(subst e) | Ccatch(nfail, ids, e1, e2) -> Ccatch(nfail, ids, subst e1, subst e2) | Cexit (nfail, el) -> Cexit (nfail, List.map subst el) | Ctrywith(e1, id, e2) -> Ctrywith(subst e1, id, subst e2) | e -> e in let res = subst exp in (res, !need_boxed, !assigned) (* Translate an expression *) let functions = (Queue.create() : ufunction Queue.t) let rec transl = function Uvar id -> Cvar id | Uconst (sc, Some const_label) -> Cconst_symbol const_label | Uconst (sc, None) -> transl_constant sc | Uclosure(fundecls, []) -> let lbl = Compilenv.new_const_symbol() in constant_closures := (lbl, fundecls) :: !constant_closures; List.iter (fun f -> Queue.add f functions) fundecls; Cconst_symbol lbl | Uclosure(fundecls, clos_vars) -> let block_size = fundecls_size fundecls + List.length clos_vars in let rec transl_fundecls pos = function [] -> List.map transl clos_vars | f :: rem -> Queue.add f functions; let header = if pos = 0 then alloc_closure_header block_size else alloc_infix_header pos in if f.arity = 1 then header :: Cconst_symbol f.label :: int_const 1 :: transl_fundecls (pos + 3) rem else header :: Cconst_symbol(curry_function f.arity) :: int_const f.arity :: Cconst_symbol f.label :: transl_fundecls (pos + 4) rem in Cop(Calloc, transl_fundecls 0 fundecls) | Uoffset(arg, offset) -> field_address (transl arg) offset | Udirect_apply(lbl, args, dbg) -> Cop(Capply(typ_addr, dbg), Cconst_symbol lbl :: List.map transl args) | Ugeneric_apply(clos, [arg], dbg) -> bind "fun" (transl clos) (fun clos -> Cop(Capply(typ_addr, dbg), [get_field clos 0; transl arg; clos])) | Ugeneric_apply(clos, args, dbg) -> let arity = List.length args in let cargs = Cconst_symbol(apply_function arity) :: List.map transl (args @ [clos]) in Cop(Capply(typ_addr, dbg), cargs) | Usend(kind, met, obj, args, dbg) -> let call_met obj args clos = if args = [] then Cop(Capply(typ_addr, dbg), [get_field clos 0;obj;clos]) else let arity = List.length args + 1 in let cargs = Cconst_symbol(apply_function arity) :: obj :: (List.map transl args) @ [clos] in Cop(Capply(typ_addr, dbg), cargs) in bind "obj" (transl obj) (fun obj -> match kind, args with Self, _ -> bind "met" (lookup_label obj (transl met)) (call_met obj args) | Cached, cache :: pos :: args -> call_cached_method obj (transl met) (transl cache) (transl pos) (List.map transl args) dbg | _ -> bind "met" (lookup_tag obj (transl met)) (call_met obj args)) | Ulet(id, exp, body) -> begin match is_unboxed_number exp with No_unboxing -> Clet(id, transl exp, transl body) | Boxed_float -> transl_unbox_let box_float unbox_float transl_unbox_float id exp body | Boxed_integer bi -> transl_unbox_let (box_int bi) (unbox_int bi) (transl_unbox_int bi) id exp body end | Uletrec(bindings, body) -> transl_letrec bindings (transl body) (* Primitives *) | Uprim(prim, args, dbg) -> begin match (simplif_primitive prim, args) with (Pgetglobal id, []) -> Cconst_symbol (Ident.name id) | (Pmakeblock(tag, mut), []) -> transl_constant(Const_block(tag, [])) | (Pmakeblock(tag, mut), args) -> make_alloc tag (List.map transl args) | (Pccall prim, args) -> if prim.prim_native_float then box_float (Cop(Cextcall(prim.prim_native_name, typ_float, false, dbg), List.map transl_unbox_float args)) else Cop(Cextcall(Primitive.native_name prim, typ_addr, prim.prim_alloc, dbg), List.map transl args) | (Pmakearray kind, []) -> transl_constant(Const_block(0, [])) | (Pmakearray kind, args) -> begin match kind with Pgenarray -> Cop(Cextcall("caml_make_array", typ_addr, true, Debuginfo.none), [make_alloc 0 (List.map transl args)]) | Paddrarray | Pintarray -> make_alloc 0 (List.map transl args) | Pfloatarray -> make_float_alloc Obj.double_array_tag (List.map transl_unbox_float args) end | (Pbigarrayref(unsafe, num_dims, elt_kind, layout), arg1 :: argl) -> let elt = bigarray_get unsafe elt_kind layout (transl arg1) (List.map transl argl) dbg in begin match elt_kind with Pbigarray_float32 | Pbigarray_float64 -> box_float elt | Pbigarray_complex32 | Pbigarray_complex64 -> elt | Pbigarray_int32 -> box_int Pint32 elt | Pbigarray_int64 -> box_int Pint64 elt | Pbigarray_native_int -> box_int Pnativeint elt | Pbigarray_caml_int -> force_tag_int elt | _ -> tag_int elt end | (Pbigarrayset(unsafe, num_dims, elt_kind, layout), arg1 :: argl) -> let (argidx, argnewval) = split_last argl in return_unit(bigarray_set unsafe elt_kind layout (transl arg1) (List.map transl argidx) (match elt_kind with Pbigarray_float32 | Pbigarray_float64 -> transl_unbox_float argnewval | Pbigarray_complex32 | Pbigarray_complex64 -> transl argnewval | Pbigarray_int32 -> transl_unbox_int Pint32 argnewval | Pbigarray_int64 -> transl_unbox_int Pint64 argnewval | Pbigarray_native_int -> transl_unbox_int Pnativeint argnewval | _ -> untag_int (transl argnewval)) dbg) | (p, [arg]) -> transl_prim_1 p arg dbg | (p, [arg1; arg2]) -> transl_prim_2 p arg1 arg2 dbg | (p, [arg1; arg2; arg3]) -> transl_prim_3 p arg1 arg2 arg3 dbg | (_, _) -> fatal_error "Cmmgen.transl:prim" end (* Control structures *) | Uswitch(arg, s) -> (* As in the bytecode interpreter, only matching against constants can be checked *) if Array.length s.us_index_blocks = 0 then Cswitch (untag_int (transl arg), s.us_index_consts, Array.map transl s.us_actions_consts) else if Array.length s.us_index_consts = 0 then transl_switch (get_tag (transl arg)) s.us_index_blocks s.us_actions_blocks else bind "switch" (transl arg) (fun arg -> Cifthenelse( Cop(Cand, [arg; Cconst_int 1]), transl_switch (untag_int arg) s.us_index_consts s.us_actions_consts, transl_switch (get_tag arg) s.us_index_blocks s.us_actions_blocks)) | Ustaticfail (nfail, args) -> Cexit (nfail, List.map transl args) | Ucatch(nfail, [], body, handler) -> make_catch nfail (transl body) (transl handler) | Ucatch(nfail, ids, body, handler) -> Ccatch(nfail, ids, transl body, transl handler) | Utrywith(body, exn, handler) -> Ctrywith(transl body, exn, transl handler) | Uifthenelse(Uprim(Pnot, [arg], _), ifso, ifnot) -> transl (Uifthenelse(arg, ifnot, ifso)) | Uifthenelse(cond, ifso, Ustaticfail (nfail, [])) -> exit_if_false cond (transl ifso) nfail | Uifthenelse(cond, Ustaticfail (nfail, []), ifnot) -> exit_if_true cond nfail (transl ifnot) | Uifthenelse(Uprim(Psequand, _, _) as cond, ifso, ifnot) -> let raise_num = next_raise_count () in make_catch raise_num (exit_if_false cond (transl ifso) raise_num) (transl ifnot) | Uifthenelse(Uprim(Psequor, _, _) as cond, ifso, ifnot) -> let raise_num = next_raise_count () in make_catch raise_num (exit_if_true cond raise_num (transl ifnot)) (transl ifso) | Uifthenelse (Uifthenelse (cond, condso, condnot), ifso, ifnot) -> let num_true = next_raise_count () in make_catch num_true (make_catch2 (fun shared_false -> Cifthenelse (test_bool (transl cond), exit_if_true condso num_true shared_false, exit_if_true condnot num_true shared_false)) (transl ifnot)) (transl ifso) | Uifthenelse(cond, ifso, ifnot) -> Cifthenelse(test_bool(transl cond), transl ifso, transl ifnot) | Usequence(exp1, exp2) -> Csequence(remove_unit(transl exp1), transl exp2) | Uwhile(cond, body) -> let raise_num = next_raise_count () in return_unit (Ccatch (raise_num, [], Cloop(exit_if_false cond (remove_unit(transl body)) raise_num), Ctuple [])) | Ufor(id, low, high, dir, body) -> let tst = match dir with Upto -> Cgt | Downto -> Clt in let inc = match dir with Upto -> Caddi | Downto -> Csubi in let raise_num = next_raise_count () in let id_prev = Ident.rename id in return_unit (Clet (id, transl low, bind_nonvar "bound" (transl high) (fun high -> Ccatch (raise_num, [], Cifthenelse (Cop(Ccmpi tst, [Cvar id; high]), Cexit (raise_num, []), Cloop (Csequence (remove_unit(transl body), Clet(id_prev, Cvar id, Csequence (Cassign(id, Cop(inc, [Cvar id; Cconst_int 2])), Cifthenelse (Cop(Ccmpi Ceq, [Cvar id_prev; high]), Cexit (raise_num,[]), Ctuple [])))))), Ctuple [])))) | Uassign(id, exp) -> return_unit(Cassign(id, transl exp)) and transl_prim_1 p arg dbg = match p with (* Generic operations *) Pidentity -> transl arg | Pignore -> return_unit(remove_unit (transl arg)) (* Heap operations *) | Pfield n -> get_field (transl arg) n | Pfloatfield n -> let ptr = transl arg in box_float( Cop(Cload Double_u, [if n = 0 then ptr else Cop(Cadda, [ptr; Cconst_int(n * size_float)])])) (* Exceptions *) | Praise -> Cop(Craise dbg, [transl arg]) (* Integer operations *) | Pnegint -> Cop(Csubi, [Cconst_int 2; transl arg]) | Poffsetint n -> if no_overflow_lsl n then add_const (transl arg) (n lsl 1) else transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n), None)) Debuginfo.none | Poffsetref n -> return_unit (bind "ref" (transl arg) (fun arg -> Cop(Cstore Word, [arg; add_const (Cop(Cload Word, [arg])) (n lsl 1)]))) (* Floating-point operations *) | Pfloatofint -> box_float(Cop(Cfloatofint, [untag_int(transl arg)])) | Pintoffloat -> tag_int(Cop(Cintoffloat, [transl_unbox_float arg])) | Pnegfloat -> box_float(Cop(Cnegf, [transl_unbox_float arg])) | Pabsfloat -> box_float(Cop(Cabsf, [transl_unbox_float arg])) (* String operations *) | Pstringlength -> tag_int(string_length (transl arg)) (* Array operations *) | Parraylength kind -> begin match kind with Pgenarray -> let len = if wordsize_shift = numfloat_shift then Cop(Clsr, [header(transl arg); Cconst_int wordsize_shift]) else bind "header" (header(transl arg)) (fun hdr -> Cifthenelse(is_addr_array_hdr hdr, Cop(Clsr, [hdr; Cconst_int wordsize_shift]), Cop(Clsr, [hdr; Cconst_int numfloat_shift]))) in Cop(Cor, [len; Cconst_int 1]) | Paddrarray | Pintarray -> Cop(Cor, [addr_array_length(header(transl arg)); Cconst_int 1]) | Pfloatarray -> Cop(Cor, [float_array_length(header(transl arg)); Cconst_int 1]) end (* Boolean operations *) | Pnot -> Cop(Csubi, [Cconst_int 4; transl arg]) (* 1 -> 3, 3 -> 1 *) (* Test integer/block *) | Pisint -> tag_int(Cop(Cand, [transl arg; Cconst_int 1])) (* Boxed integers *) | Pbintofint bi -> box_int bi (untag_int (transl arg)) | Pintofbint bi -> force_tag_int (transl_unbox_int bi arg) | Pcvtbint(bi1, bi2) -> box_int bi2 (transl_unbox_int bi1 arg) | Pnegbint bi -> box_int bi (Cop(Csubi, [Cconst_int 0; transl_unbox_int bi arg])) | _ -> fatal_error "Cmmgen.transl_prim_1" and transl_prim_2 p arg1 arg2 dbg = match p with (* Heap operations *) Psetfield(n, ptr) -> if ptr then return_unit(Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none), [field_address (transl arg1) n; transl arg2])) else return_unit(set_field (transl arg1) n (transl arg2)) | Psetfloatfield n -> let ptr = transl arg1 in return_unit( Cop(Cstore Double_u, [if n = 0 then ptr else Cop(Cadda, [ptr; Cconst_int(n * size_float)]); transl_unbox_float arg2])) (* Boolean operations *) | Psequand -> Cifthenelse(test_bool(transl arg1), transl arg2, Cconst_int 1) (* let id = Ident.create "res1" in Clet(id, transl arg1, Cifthenelse(test_bool(Cvar id), transl arg2, Cvar id)) *) | Psequor -> Cifthenelse(test_bool(transl arg1), Cconst_int 3, transl arg2) (* Integer operations *) | Paddint -> decr_int(add_int (transl arg1) (transl arg2)) | Psubint -> incr_int(sub_int (transl arg1) (transl arg2)) | Pmulint -> incr_int(Cop(Cmuli, [decr_int(transl arg1); untag_int(transl arg2)])) | Pdivint -> tag_int(safe_divmod Cdivi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg) | Pmodint -> tag_int(safe_divmod Cmodi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg) | Pandint -> Cop(Cand, [transl arg1; transl arg2]) | Porint -> Cop(Cor, [transl arg1; transl arg2]) | Pxorint -> Cop(Cor, [Cop(Cxor, [ignore_low_bit_int(transl arg1); ignore_low_bit_int(transl arg2)]); Cconst_int 1]) | Plslint -> incr_int(lsl_int (decr_int(transl arg1)) (untag_int(transl arg2))) | Plsrint -> Cop(Cor, [Cop(Clsr, [transl arg1; untag_int(transl arg2)]); Cconst_int 1]) | Pasrint -> Cop(Cor, [Cop(Casr, [transl arg1; untag_int(transl arg2)]); Cconst_int 1]) | Pintcomp cmp -> tag_int(Cop(Ccmpi(transl_comparison cmp), [transl arg1; transl arg2])) | Pisout -> transl_isout (transl arg1) (transl arg2) (* Float operations *) | Paddfloat -> box_float(Cop(Caddf, [transl_unbox_float arg1; transl_unbox_float arg2])) | Psubfloat -> box_float(Cop(Csubf, [transl_unbox_float arg1; transl_unbox_float arg2])) | Pmulfloat -> box_float(Cop(Cmulf, [transl_unbox_float arg1; transl_unbox_float arg2])) | Pdivfloat -> box_float(Cop(Cdivf, [transl_unbox_float arg1; transl_unbox_float arg2])) | Pfloatcomp cmp -> tag_int(Cop(Ccmpf(transl_comparison cmp), [transl_unbox_float arg1; transl_unbox_float arg2])) (* String operations *) | Pstringrefu -> tag_int(Cop(Cload Byte_unsigned, [add_int (transl arg1) (untag_int(transl arg2))])) | Pstringrefs -> tag_int (bind "str" (transl arg1) (fun str -> bind "index" (untag_int (transl arg2)) (fun idx -> Csequence( make_checkbound dbg [string_length str; idx], Cop(Cload Byte_unsigned, [add_int str idx]))))) (* Array operations *) | Parrayrefu kind -> begin match kind with Pgenarray -> bind "arr" (transl arg1) (fun arr -> bind "index" (transl arg2) (fun idx -> Cifthenelse(is_addr_array_ptr arr, addr_array_ref arr idx, float_array_ref arr idx))) | Paddrarray | Pintarray -> addr_array_ref (transl arg1) (transl arg2) | Pfloatarray -> float_array_ref (transl arg1) (transl arg2) end | Parrayrefs kind -> begin match kind with | Pgenarray -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> bind "header" (header arr) (fun hdr -> if wordsize_shift = numfloat_shift then Csequence(make_checkbound dbg [addr_array_length hdr; idx], Cifthenelse(is_addr_array_hdr hdr, addr_array_ref arr idx, float_array_ref arr idx)) else Cifthenelse(is_addr_array_hdr hdr, Csequence(make_checkbound dbg [addr_array_length hdr; idx], addr_array_ref arr idx), Csequence(make_checkbound dbg [float_array_length hdr; idx], float_array_ref arr idx))))) | Paddrarray | Pintarray -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> Csequence(make_checkbound dbg [addr_array_length(header arr); idx], addr_array_ref arr idx))) | Pfloatarray -> box_float( bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> Csequence(make_checkbound dbg [float_array_length(header arr); idx], unboxed_float_array_ref arr idx)))) end (* Operations on bitvects *) | Pbittest -> bind "index" (untag_int(transl arg2)) (fun idx -> tag_int( Cop(Cand, [Cop(Clsr, [Cop(Cload Byte_unsigned, [add_int (transl arg1) (Cop(Clsr, [idx; Cconst_int 3]))]); Cop(Cand, [idx; Cconst_int 7])]); Cconst_int 1]))) (* Boxed integers *) | Paddbint bi -> box_int bi (Cop(Caddi, [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) | Psubbint bi -> box_int bi (Cop(Csubi, [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) | Pmulbint bi -> box_int bi (Cop(Cmuli, [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) | Pdivbint bi -> box_int bi (safe_div_bi (transl_unbox_int bi arg1) (transl_unbox_int bi arg2) bi dbg) | Pmodbint bi -> box_int bi (safe_mod_bi (transl_unbox_int bi arg1) (transl_unbox_int bi arg2) bi dbg) | Pandbint bi -> box_int bi (Cop(Cand, [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) | Porbint bi -> box_int bi (Cop(Cor, [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) | Pxorbint bi -> box_int bi (Cop(Cxor, [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) | Plslbint bi -> box_int bi (Cop(Clsl, [transl_unbox_int bi arg1; untag_int(transl arg2)])) | Plsrbint bi -> box_int bi (Cop(Clsr, [make_unsigned_int bi (transl_unbox_int bi arg1); untag_int(transl arg2)])) | Pasrbint bi -> box_int bi (Cop(Casr, [transl_unbox_int bi arg1; untag_int(transl arg2)])) | Pbintcomp(bi, cmp) -> tag_int (Cop(Ccmpi(transl_comparison cmp), [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) | _ -> fatal_error "Cmmgen.transl_prim_2" and transl_prim_3 p arg1 arg2 arg3 dbg = match p with (* String operations *) Pstringsetu -> return_unit(Cop(Cstore Byte_unsigned, [add_int (transl arg1) (untag_int(transl arg2)); untag_int(transl arg3)])) | Pstringsets -> return_unit (bind "str" (transl arg1) (fun str -> bind "index" (untag_int (transl arg2)) (fun idx -> Csequence( make_checkbound dbg [string_length str; idx], Cop(Cstore Byte_unsigned, [add_int str idx; untag_int(transl arg3)]))))) (* Array operations *) | Parraysetu kind -> return_unit(begin match kind with Pgenarray -> bind "newval" (transl arg3) (fun newval -> bind "index" (transl arg2) (fun index -> bind "arr" (transl arg1) (fun arr -> Cifthenelse(is_addr_array_ptr arr, addr_array_set arr index newval, float_array_set arr index (unbox_float newval))))) | Paddrarray -> addr_array_set (transl arg1) (transl arg2) (transl arg3) | Pintarray -> int_array_set (transl arg1) (transl arg2) (transl arg3) | Pfloatarray -> float_array_set (transl arg1) (transl arg2) (transl_unbox_float arg3) end) | Parraysets kind -> return_unit(begin match kind with | Pgenarray -> bind "newval" (transl arg3) (fun newval -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> bind "header" (header arr) (fun hdr -> if wordsize_shift = numfloat_shift then Csequence(make_checkbound dbg [addr_array_length hdr; idx], Cifthenelse(is_addr_array_hdr hdr, addr_array_set arr idx newval, float_array_set arr idx (unbox_float newval))) else Cifthenelse(is_addr_array_hdr hdr, Csequence(make_checkbound dbg [addr_array_length hdr; idx], addr_array_set arr idx newval), Csequence(make_checkbound dbg [float_array_length hdr; idx], float_array_set arr idx (unbox_float newval))))))) | Paddrarray -> bind "newval" (transl arg3) (fun newval -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> Csequence(make_checkbound dbg [addr_array_length(header arr); idx], addr_array_set arr idx newval)))) | Pintarray -> bind "newval" (transl arg3) (fun newval -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> Csequence(make_checkbound dbg [addr_array_length(header arr); idx], int_array_set arr idx newval)))) | Pfloatarray -> bind "newval" (transl_unbox_float arg3) (fun newval -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> Csequence(make_checkbound dbg [float_array_length(header arr);idx], float_array_set arr idx newval)))) end) | _ -> fatal_error "Cmmgen.transl_prim_3" and transl_unbox_float = function Uconst(Const_base(Const_float f), _) -> Cconst_float f | exp -> unbox_float(transl exp) and transl_unbox_int bi = function Uconst(Const_base(Const_int32 n), _) -> Cconst_natint (Nativeint.of_int32 n) | Uconst(Const_base(Const_nativeint n), _) -> Cconst_natint n | Uconst(Const_base(Const_int64 n), _) -> assert (size_int = 8); Cconst_natint (Int64.to_nativeint n) | Uprim(Pbintofint bi', [Uconst(Const_base(Const_int i),_)], _) when bi = bi' -> Cconst_int i | exp -> unbox_int bi (transl exp) and transl_unbox_let box_fn unbox_fn transl_unbox_fn id exp body = let unboxed_id = Ident.create (Ident.name id) in let trbody1 = transl body in let (trbody2, need_boxed, is_assigned) = subst_boxed_number unbox_fn id unboxed_id trbody1 in if need_boxed && is_assigned then Clet(id, transl exp, trbody1) else Clet(unboxed_id, transl_unbox_fn exp, if need_boxed then Clet(id, box_fn(Cvar unboxed_id), trbody2) else trbody2) and make_catch ncatch body handler = match body with | Cexit (nexit,[]) when nexit=ncatch -> handler | _ -> Ccatch (ncatch, [], body, handler) and make_catch2 mk_body handler = match handler with | Cexit (_,[])|Ctuple []|Cconst_int _|Cconst_pointer _ -> mk_body handler | _ -> let nfail = next_raise_count () in make_catch nfail (mk_body (Cexit (nfail,[]))) handler and exit_if_true cond nfail otherwise = match cond with | Uconst (Const_pointer 0, _) -> otherwise | Uconst (Const_pointer 1, _) -> Cexit (nfail,[]) | Uprim(Psequor, [arg1; arg2], _) -> exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise) | Uprim(Psequand, _, _) -> begin match otherwise with | Cexit (raise_num,[]) -> exit_if_false cond (Cexit (nfail,[])) raise_num | _ -> let raise_num = next_raise_count () in make_catch raise_num (exit_if_false cond (Cexit (nfail,[])) raise_num) otherwise end | Uprim(Pnot, [arg], _) -> exit_if_false arg otherwise nfail | Uifthenelse (cond, ifso, ifnot) -> make_catch2 (fun shared -> Cifthenelse (test_bool (transl cond), exit_if_true ifso nfail shared, exit_if_true ifnot nfail shared)) otherwise | _ -> Cifthenelse(test_bool(transl cond), Cexit (nfail, []), otherwise) and exit_if_false cond otherwise nfail = match cond with | Uconst (Const_pointer 0, _) -> Cexit (nfail,[]) | Uconst (Const_pointer 1, _) -> otherwise | Uprim(Psequand, [arg1; arg2], _) -> exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail | Uprim(Psequor, _, _) -> begin match otherwise with | Cexit (raise_num,[]) -> exit_if_true cond raise_num (Cexit (nfail,[])) | _ -> let raise_num = next_raise_count () in make_catch raise_num (exit_if_true cond raise_num (Cexit (nfail,[]))) otherwise end | Uprim(Pnot, [arg], _) -> exit_if_true arg nfail otherwise | Uifthenelse (cond, ifso, ifnot) -> make_catch2 (fun shared -> Cifthenelse (test_bool (transl cond), exit_if_false ifso shared nfail, exit_if_false ifnot shared nfail)) otherwise | _ -> Cifthenelse(test_bool(transl cond), otherwise, Cexit (nfail, [])) and transl_switch arg index cases = match Array.length cases with | 0 -> fatal_error "Cmmgen.transl_switch" | 1 -> transl cases.(0) | _ -> let n_index = Array.length index in let actions = Array.map transl cases in let inters = ref [] and this_high = ref (n_index-1) and this_low = ref (n_index-1) and this_act = ref index.(n_index-1) in for i = n_index-2 downto 0 do let act = index.(i) in if act = !this_act then decr this_low else begin inters := (!this_low, !this_high, !this_act) :: !inters ; this_high := i ; this_low := i ; this_act := act end done ; inters := (0, !this_high, !this_act) :: !inters ; bind "switcher" arg (fun a -> SwitcherBlocks.zyva (0,n_index-1) (fun i -> Cconst_int i) a (Array.of_list !inters) actions) and transl_letrec bindings cont = let bsz = List.map (fun (id, exp) -> (id, exp, expr_size exp)) bindings in let op_alloc prim sz = Cop(Cextcall(prim, typ_addr, true, Debuginfo.none), [int_const sz]) in let rec init_blocks = function | [] -> fill_nonrec bsz | (id, exp, RHS_block sz) :: rem -> Clet(id, op_alloc "caml_alloc_dummy" sz, init_blocks rem) | (id, exp, RHS_floatblock sz) :: rem -> Clet(id, op_alloc "caml_alloc_dummy_float" sz, init_blocks rem) | (id, exp, RHS_nonrec) :: rem -> Clet (id, Cconst_int 0, init_blocks rem) and fill_nonrec = function | [] -> fill_blocks bsz | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> fill_nonrec rem | (id, exp, RHS_nonrec) :: rem -> Clet (id, transl exp, fill_nonrec rem) and fill_blocks = function | [] -> cont | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> let op = Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none), [Cvar id; transl exp]) in Csequence(op, fill_blocks rem) | (id, exp, RHS_nonrec) :: rem -> fill_blocks rem in init_blocks bsz (* Translate a function definition *) let transl_function f = Cfunction {fun_name = f.label; fun_args = List.map (fun id -> (id, typ_addr)) f.params; fun_body = transl f.body; fun_fast = !Clflags.optimize_for_speed; fun_dbg = f.dbg; } (* Translate all function definitions *) module StringSet = Set.Make(struct type t = string let compare = compare end) let rec transl_all_functions already_translated cont = try let f = Queue.take functions in if StringSet.mem f.label already_translated then transl_all_functions already_translated cont else begin transl_all_functions (StringSet.add f.label already_translated) (transl_function f :: cont) end with Queue.Empty -> cont (* Emit structured constants *) let immstrings = Hashtbl.create 17 let rec emit_constant symb cst cont = match cst with Const_base(Const_float s) -> Cint(float_header) :: Cdefine_symbol symb :: Cdouble s :: cont | Const_base(Const_string s) | Const_immstring s -> Cint(string_header (String.length s)) :: Cdefine_symbol symb :: emit_string_constant s cont | Const_base(Const_int32 n) -> Cint(boxedint32_header) :: Cdefine_symbol symb :: emit_boxed_int32_constant n cont | Const_base(Const_int64 n) -> Cint(boxedint64_header) :: Cdefine_symbol symb :: emit_boxed_int64_constant n cont | Const_base(Const_nativeint n) -> Cint(boxedintnat_header) :: Cdefine_symbol symb :: emit_boxed_nativeint_constant n cont | Const_block(tag, fields) -> let (emit_fields, cont1) = emit_constant_fields fields cont in Cint(block_header tag (List.length fields)) :: Cdefine_symbol symb :: emit_fields @ cont1 | Const_float_array(fields) -> Cint(floatarray_header (List.length fields)) :: Cdefine_symbol symb :: Misc.map_end (fun f -> Cdouble f) fields cont | _ -> fatal_error "gencmm.emit_constant" and emit_constant_fields fields cont = match fields with [] -> ([], cont) | f1 :: fl -> let (data1, cont1) = emit_constant_field f1 cont in let (datal, contl) = emit_constant_fields fl cont1 in (data1 :: datal, contl) and emit_constant_field field cont = match field with Const_base(Const_int n) -> (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n), cont) | Const_base(Const_char c) -> (Cint(Nativeint.of_int(((Char.code c) lsl 1) + 1)), cont) | Const_base(Const_float s) -> let lbl = Compilenv.new_const_label() in (Clabel_address lbl, Cint(float_header) :: Cdefine_label lbl :: Cdouble s :: cont) | Const_base(Const_string s) -> let lbl = Compilenv.new_const_label() in (Clabel_address lbl, Cint(string_header (String.length s)) :: Cdefine_label lbl :: emit_string_constant s cont) | Const_immstring s -> begin try (Clabel_address (Hashtbl.find immstrings s), cont) with Not_found -> let lbl = Compilenv.new_const_label() in Hashtbl.add immstrings s lbl; (Clabel_address lbl, Cint(string_header (String.length s)) :: Cdefine_label lbl :: emit_string_constant s cont) end | Const_base(Const_int32 n) -> let lbl = Compilenv.new_const_label() in (Clabel_address lbl, Cint(boxedint32_header) :: Cdefine_label lbl :: emit_boxed_int32_constant n cont) | Const_base(Const_int64 n) -> let lbl = Compilenv.new_const_label() in (Clabel_address lbl, Cint(boxedint64_header) :: Cdefine_label lbl :: emit_boxed_int64_constant n cont) | Const_base(Const_nativeint n) -> let lbl = Compilenv.new_const_label() in (Clabel_address lbl, Cint(boxedintnat_header) :: Cdefine_label lbl :: emit_boxed_nativeint_constant n cont) | Const_pointer n -> (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n), cont) | Const_block(tag, fields) -> let lbl = Compilenv.new_const_label() in let (emit_fields, cont1) = emit_constant_fields fields cont in (Clabel_address lbl, Cint(block_header tag (List.length fields)) :: Cdefine_label lbl :: emit_fields @ cont1) | Const_float_array(fields) -> let lbl = Compilenv.new_const_label() in (Clabel_address lbl, Cint(floatarray_header (List.length fields)) :: Cdefine_label lbl :: Misc.map_end (fun f -> Cdouble f) fields cont) and emit_string_constant s cont = let n = size_int - 1 - (String.length s) mod size_int in Cstring s :: Cskip n :: Cint8 n :: cont and emit_boxed_int32_constant n cont = let n = Nativeint.of_int32 n in if size_int = 8 then Csymbol_address("caml_int32_ops") :: Cint32 n :: Cint32 0n :: cont else Csymbol_address("caml_int32_ops") :: Cint n :: cont and emit_boxed_nativeint_constant n cont = Csymbol_address("caml_nativeint_ops") :: Cint n :: cont and emit_boxed_int64_constant n cont = let lo = Int64.to_nativeint n in if size_int = 8 then Csymbol_address("caml_int64_ops") :: Cint lo :: cont else begin let hi = Int64.to_nativeint (Int64.shift_right n 32) in if big_endian then Csymbol_address("caml_int64_ops") :: Cint hi :: Cint lo :: cont else Csymbol_address("caml_int64_ops") :: Cint lo :: Cint hi :: cont end (* Emit constant closures *) let emit_constant_closure symb fundecls cont = match fundecls with [] -> assert false | f1 :: remainder -> let rec emit_others pos = function [] -> cont | f2 :: rem -> if f2.arity = 1 then Cint(infix_header pos) :: Csymbol_address f2.label :: Cint 3n :: emit_others (pos + 3) rem else Cint(infix_header pos) :: Csymbol_address(curry_function f2.arity) :: Cint(Nativeint.of_int (f2.arity lsl 1 + 1)) :: Csymbol_address f2.label :: emit_others (pos + 4) rem in Cint(closure_header (fundecls_size fundecls)) :: Cdefine_symbol symb :: if f1.arity = 1 then Csymbol_address f1.label :: Cint 3n :: emit_others 3 remainder else Csymbol_address(curry_function f1.arity) :: Cint(Nativeint.of_int (f1.arity lsl 1 + 1)) :: Csymbol_address f1.label :: emit_others 4 remainder (* Emit all structured constants *) let emit_all_constants cont = let c = ref cont in List.iter (fun (lbl, global, cst) -> let cst = emit_constant lbl cst [] in let cst = if global then Cglobal_symbol lbl :: cst else cst in c:= Cdata(cst):: !c) (Compilenv.structured_constants()); (* structured_constants := []; done in Compilenv.reset() *) Hashtbl.clear immstrings; (* PR#3979 *) List.iter (fun (symb, fundecls) -> c := Cdata(emit_constant_closure symb fundecls []) :: !c) !constant_closures; constant_closures := []; !c (* Translate a compilation unit *) let compunit size ulam = let glob = Compilenv.make_symbol None in let init_code = transl ulam in let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry"); fun_args = []; fun_body = init_code; fun_fast = false; fun_dbg = Debuginfo.none }] in let c2 = transl_all_functions StringSet.empty c1 in let c3 = emit_all_constants c2 in Cdata [Cint(block_header 0 size); Cglobal_symbol glob; Cdefine_symbol glob; Cskip(size * size_addr)] :: c3 (* CAMLprim value caml_cache_public_method (value meths, value tag, value *cache) { int li = 3, hi = Field(meths,0), mi; while (li < hi) { // no need to check the 1st time mi = ((li+hi) >> 1) | 1; if (tag < Field(meths,mi)) hi = mi-2; else li = mi; } *cache = (li-3)*sizeof(value)+1; return Field (meths, li-1); } *) let cache_public_method meths tag cache = let raise_num = next_raise_count () in let li = Ident.create "li" and hi = Ident.create "hi" and mi = Ident.create "mi" and tagged = Ident.create "tagged" in Clet ( li, Cconst_int 3, Clet ( hi, Cop(Cload Word, [meths]), Csequence( Ccatch (raise_num, [], Cloop (Clet( mi, Cop(Cor, [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi]); Cconst_int 1]); Cconst_int 1]), Csequence( Cifthenelse (Cop (Ccmpi Clt, [tag; Cop(Cload Word, [Cop(Cadda, [meths; lsl_const (Cvar mi) log2_size_addr])])]), Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2])), Cassign(li, Cvar mi)), Cifthenelse (Cop(Ccmpi Cge, [Cvar li; Cvar hi]), Cexit (raise_num, []), Ctuple [])))), Ctuple []), Clet ( tagged, Cop(Cadda, [lsl_const (Cvar li) log2_size_addr; Cconst_int(1 - 3 * size_addr)]), Csequence(Cop (Cstore Word, [cache; Cvar tagged]), Cvar tagged))))) (* Generate an application function: (defun caml_applyN (a1 ... aN clos) (if (= clos.arity N) (app clos.direct a1 ... aN clos) (let (clos1 (app clos.code a1 clos) clos2 (app clos1.code a2 clos) ... closN-1 (app closN-2.code aN-1 closN-2)) (app closN-1.code aN closN-1)))) *) let apply_function_body arity = let arg = Array.create arity (Ident.create "arg") in for i = 1 to arity - 1 do arg.(i) <- Ident.create "arg" done; let clos = Ident.create "clos" in let rec app_fun clos n = if n = arity-1 then Cop(Capply(typ_addr, Debuginfo.none), [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]) else begin let newclos = Ident.create "clos" in Clet(newclos, Cop(Capply(typ_addr, Debuginfo.none), [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]), app_fun newclos (n+1)) end in let args = Array.to_list arg in let all_args = args @ [clos] in (args, clos, if arity = 1 then app_fun clos 0 else Cifthenelse( Cop(Ccmpi Ceq, [get_field (Cvar clos) 1; int_const arity]), Cop(Capply(typ_addr, Debuginfo.none), get_field (Cvar clos) 2 :: List.map (fun s -> Cvar s) all_args), app_fun clos 0)) let send_function arity = let (args, clos', body) = apply_function_body (1+arity) in let cache = Ident.create "cache" and obj = List.hd args and tag = Ident.create "tag" in let clos = let cache = Cvar cache and obj = Cvar obj and tag = Cvar tag in let meths = Ident.create "meths" and cached = Ident.create "cached" in let real = Ident.create "real" in let mask = get_field (Cvar meths) 1 in let cached_pos = Cvar cached in let tag_pos = Cop(Cadda, [Cop (Cadda, [cached_pos; Cvar meths]); Cconst_int(3*size_addr-1)]) in let tag' = Cop(Cload Word, [tag_pos]) in Clet ( meths, Cop(Cload Word, [obj]), Clet ( cached, Cop(Cand, [Cop(Cload Word, [cache]); mask]), Clet ( real, Cifthenelse(Cop(Ccmpa Cne, [tag'; tag]), cache_public_method (Cvar meths) tag cache, cached_pos), Cop(Cload Word, [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths]); Cconst_int(2*size_addr-1)])])))) in let body = Clet(clos', clos, body) in let fun_args = [obj, typ_addr; tag, typ_int; cache, typ_addr] @ List.map (fun id -> (id, typ_addr)) (List.tl args) in Cfunction {fun_name = "caml_send" ^ string_of_int arity; fun_args = fun_args; fun_body = body; fun_fast = true; fun_dbg = Debuginfo.none } let apply_function arity = let (args, clos, body) = apply_function_body arity in let all_args = args @ [clos] in Cfunction {fun_name = "caml_apply" ^ string_of_int arity; fun_args = List.map (fun id -> (id, typ_addr)) all_args; fun_body = body; fun_fast = true; fun_dbg = Debuginfo.none } (* Generate tuplifying functions: (defun caml_tuplifyN (arg clos) (app clos.direct #0(arg) ... #N-1(arg) clos)) *) let tuplify_function arity = let arg = Ident.create "arg" in let clos = Ident.create "clos" in let rec access_components i = if i >= arity then [] else get_field (Cvar arg) i :: access_components(i+1) in Cfunction {fun_name = "caml_tuplify" ^ string_of_int arity; fun_args = [arg, typ_addr; clos, typ_addr]; fun_body = Cop(Capply(typ_addr, Debuginfo.none), get_field (Cvar clos) 2 :: access_components 0 @ [Cvar clos]); fun_fast = true; fun_dbg = Debuginfo.none } (* Generate currying functions: (defun caml_curryN (arg clos) (alloc HDR caml_curryN_1 caml_curry_N_1_app arg clos)) (defun caml_curryN_1 (arg clos) (alloc HDR caml_curryN_2 caml_curry_N_2_app arg clos)) ... (defun caml_curryN_N-1 (arg clos) (let (closN-2 clos.vars[1] closN-3 closN-2.vars[1] ... clos1 clos2.vars[1] clos clos1.vars[1]) (app clos.direct clos1.vars[0] ... closN-2.vars[0] clos.vars[0] arg clos))) Special "shortcut" functions are also generated to handle the case where a partially applied function is applied to all remaining arguments in one go. For instance: (defun caml_curry_N_1_app (arg2 ... argN clos) (let clos' clos.vars[1] (app clos'.direct clos.vars[0] arg2 ... argN clos'))) *) let final_curry_function arity = let last_arg = Ident.create "arg" in let last_clos = Ident.create "clos" in let rec curry_fun args clos n = if n = 0 then Cop(Capply(typ_addr, Debuginfo.none), get_field (Cvar clos) 2 :: args @ [Cvar last_arg; Cvar clos]) else if n = arity - 1 then begin let newclos = Ident.create "clos" in Clet(newclos, get_field (Cvar clos) 3, curry_fun (get_field (Cvar clos) 2 :: args) newclos (n-1)) end else begin let newclos = Ident.create "clos" in Clet(newclos, get_field (Cvar clos) 4, curry_fun (get_field (Cvar clos) 3 :: args) newclos (n-1)) end in Cfunction {fun_name = "caml_curry" ^ string_of_int arity ^ "_" ^ string_of_int (arity-1); fun_args = [last_arg, typ_addr; last_clos, typ_addr]; fun_body = curry_fun [] last_clos (arity-1); fun_fast = true; fun_dbg = Debuginfo.none } let rec intermediate_curry_functions arity num = if num = arity - 1 then [final_curry_function arity] else begin let name1 = "caml_curry" ^ string_of_int arity in let name2 = if num = 0 then name1 else name1 ^ "_" ^ string_of_int num in let arg = Ident.create "arg" and clos = Ident.create "clos" in Cfunction {fun_name = name2; fun_args = [arg, typ_addr; clos, typ_addr]; fun_body = if arity - num > 2 then Cop(Calloc, [alloc_closure_header 5; Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); int_const (arity - num - 1); Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1) ^ "_app"); Cvar arg; Cvar clos]) else Cop(Calloc, [alloc_closure_header 4; Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); int_const 1; Cvar arg; Cvar clos]); fun_fast = true; fun_dbg = Debuginfo.none } :: (if arity - num > 2 then let rec iter i = if i <= arity then let arg = Ident.create (Printf.sprintf "arg%d" i) in (arg, typ_addr) :: iter (i+1) else [] in let direct_args = iter (num+2) in let rec iter i args clos = if i = 0 then Cop(Capply(typ_addr, Debuginfo.none), (get_field (Cvar clos) 2) :: args @ [Cvar clos]) else let newclos = Ident.create "clos" in Clet(newclos, get_field (Cvar clos) 4, iter (i-1) (get_field (Cvar clos) 3 :: args) newclos) in let cf = Cfunction {fun_name = name1 ^ "_" ^ string_of_int (num+1) ^ "_app"; fun_args = direct_args @ [clos, typ_addr]; fun_body = iter (num+1) (List.map (fun (arg,_) -> Cvar arg) direct_args) clos; fun_fast = true; fun_dbg = Debuginfo.none } in cf :: intermediate_curry_functions arity (num+1) else intermediate_curry_functions arity (num+1)) end let curry_function arity = if arity >= 0 then intermediate_curry_functions arity 0 else [tuplify_function (-arity)] module IntSet = Set.Make( struct type t = int let compare = compare end) let default_apply = IntSet.add 2 (IntSet.add 3 IntSet.empty) (* These apply funs are always present in the main program because the run-time system needs them (cf. asmrun/.S) . *) let generic_functions shared units = let (apply,send,curry) = List.fold_left (fun (apply,send,curry) ui -> List.fold_right IntSet.add ui.ui_apply_fun apply, List.fold_right IntSet.add ui.ui_send_fun send, List.fold_right IntSet.add ui.ui_curry_fun curry) (IntSet.empty,IntSet.empty,IntSet.empty) units in let apply = if shared then apply else IntSet.union apply default_apply in let accu = IntSet.fold (fun n accu -> apply_function n :: accu) apply [] in let accu = IntSet.fold (fun n accu -> send_function n :: accu) send accu in IntSet.fold (fun n accu -> curry_function n @ accu) curry accu (* Generate the entry point *) let entry_point namelist = let incr_global_inited = Cop(Cstore Word, [Cconst_symbol "caml_globals_inited"; Cop(Caddi, [Cop(Cload Word, [Cconst_symbol "caml_globals_inited"]); Cconst_int 1])]) in let body = List.fold_right (fun name next -> let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in Csequence(Cop(Capply(typ_void, Debuginfo.none), [Cconst_symbol entry_sym]), Csequence(incr_global_inited, next))) namelist (Cconst_int 1) in Cfunction {fun_name = "caml_program"; fun_args = []; fun_body = body; fun_fast = false; fun_dbg = Debuginfo.none } (* Generate the table of globals *) let cint_zero = Cint 0n let global_table namelist = let mksym name = Csymbol_address (Compilenv.make_symbol ~unitname:name None) in Cdata(Cglobal_symbol "caml_globals" :: Cdefine_symbol "caml_globals" :: List.map mksym namelist @ [cint_zero]) let reference_symbols namelist = let mksym name = Csymbol_address name in Cdata(List.map mksym namelist) let global_data name v = Cdata(Cglobal_symbol name :: emit_constant name (Const_base (Const_string (Marshal.to_string v []))) []) let globals_map v = global_data "caml_globals_map" v (* Generate the master table of frame descriptors *) let frame_table namelist = let mksym name = Csymbol_address (Compilenv.make_symbol ~unitname:name (Some "frametable")) in Cdata(Cglobal_symbol "caml_frametable" :: Cdefine_symbol "caml_frametable" :: List.map mksym namelist @ [cint_zero]) (* Generate the table of module data and code segments *) let segment_table namelist symbol begname endname = let addsyms name lst = Csymbol_address (Compilenv.make_symbol ~unitname:name (Some begname)) :: Csymbol_address (Compilenv.make_symbol ~unitname:name (Some endname)) :: lst in Cdata(Cglobal_symbol symbol :: Cdefine_symbol symbol :: List.fold_right addsyms namelist [cint_zero]) let data_segment_table namelist = segment_table namelist "caml_data_segments" "data_begin" "data_end" let code_segment_table namelist = segment_table namelist "caml_code_segments" "code_begin" "code_end" (* Initialize a predefined exception *) let predef_exception name = let bucketname = "caml_bucket_" ^ name in let symname = "caml_exn_" ^ name in Cdata(Cglobal_symbol symname :: emit_constant symname (Const_block(0,[Const_base(Const_string name)])) [ Cglobal_symbol bucketname; Cint(block_header 0 1); Cdefine_symbol bucketname; Csymbol_address symname ]) (* Header for a plugin *) let mapflat f l = List.flatten (List.map f l) let plugin_header units = let mk (ui,crc) = { dynu_name = ui.ui_name; dynu_crc = crc; dynu_imports_cmi = ui.ui_imports_cmi; dynu_imports_cmx = ui.ui_imports_cmx; dynu_defines = ui.ui_defines } in global_data "caml_plugin_header" { dynu_magic = Config.cmxs_magic_number; dynu_units = List.map mk units } mingw-ocaml/ocaml/asmcomp/mips/0000755000175000017500000000000012124403240016064 5ustar tootstootsmingw-ocaml/ocaml/asmcomp/mips/.gitignore0000644000175000017500000000000012124403240020042 0ustar tootstootsmingw-ocaml/ocaml/asmcomp/split.ml0000644000175000017500000001555212124403240016611 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Renaming of registers at reload points to split live ranges. *) open Reg open Mach (* Substitutions are represented by register maps *) type subst = Reg.t Reg.Map.t let subst_reg r sub = try Reg.Map.find r sub with Not_found -> r let subst_regs rv sub = match sub with None -> rv | Some s -> let n = Array.length rv in let nv = Array.create n Reg.dummy in for i = 0 to n-1 do nv.(i) <- subst_reg rv.(i) s done; nv (* We maintain equivalence classes of registers using a standard union-find algorithm *) let equiv_classes = ref (Reg.Map.empty : Reg.t Reg.Map.t) let rec repres_reg r = try repres_reg(Reg.Map.find r !equiv_classes) with Not_found -> r let repres_regs rv = let n = Array.length rv in for i = 0 to n-1 do rv.(i) <- repres_reg rv.(i) done (* Identify two registers. The second register is chosen as canonical representative. *) let identify r1 r2 = let repres1 = repres_reg r1 in let repres2 = repres_reg r2 in if repres1.stamp = repres2.stamp then () else begin equiv_classes := Reg.Map.add repres1 repres2 !equiv_classes end (* Identify the image of a register by two substitutions. Be careful to use the original register as canonical representative in case it does not belong to the domain of one of the substitutions. *) let identify_sub sub1 sub2 reg = try let r1 = Reg.Map.find reg sub1 in try let r2 = Reg.Map.find reg sub2 in identify r1 r2 with Not_found -> identify r1 reg with Not_found -> try let r2 = Reg.Map.find reg sub2 in identify r2 reg with Not_found -> () (* Identify registers so that the two substitutions agree on the registers live before the given instruction. *) let merge_substs sub1 sub2 i = match (sub1, sub2) with (None, None) -> None | (Some s1, None) -> sub1 | (None, Some s2) -> sub2 | (Some s1, Some s2) -> Reg.Set.iter (identify_sub s1 s2) (Reg.add_set_array i.live i.arg); sub1 (* Same, for N substitutions *) let merge_subst_array subv instr = let rec find_one_subst i = if i >= Array.length subv then None else begin match subv.(i) with None -> find_one_subst (i+1) | Some si as sub -> for j = i+1 to Array.length subv - 1 do match subv.(j) with None -> () | Some sj -> Reg.Set.iter (identify_sub si sj) (Reg.add_set_array instr.live instr.arg) done; sub end in find_one_subst 0 (* First pass: rename registers at reload points *) let exit_subst = ref [] let find_exit_subst k = try List.assoc k !exit_subst with | Not_found -> Misc.fatal_error "Split.find_exit_subst" let rec rename i sub = match i.desc with Iend -> (i, sub) | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> (instr_cons i.desc (subst_regs i.arg sub) [||] i.next, None) | Iop Ireload when i.res.(0).loc = Unknown -> begin match sub with None -> rename i.next sub | Some s -> let oldr = i.res.(0) in let newr = Reg.clone i.res.(0) in let (new_next, sub_next) = rename i.next (Some(Reg.Map.add oldr newr s)) in (instr_cons i.desc i.arg [|newr|] new_next, sub_next) end | Iop _ -> let (new_next, sub_next) = rename i.next sub in (instr_cons_debug i.desc (subst_regs i.arg sub) (subst_regs i.res sub) i.dbg new_next, sub_next) | Iifthenelse(tst, ifso, ifnot) -> let (new_ifso, sub_ifso) = rename ifso sub in let (new_ifnot, sub_ifnot) = rename ifnot sub in let (new_next, sub_next) = rename i.next (merge_substs sub_ifso sub_ifnot i.next) in (instr_cons (Iifthenelse(tst, new_ifso, new_ifnot)) (subst_regs i.arg sub) [||] new_next, sub_next) | Iswitch(index, cases) -> let new_sub_cases = Array.map (fun c -> rename c sub) cases in let sub_merge = merge_subst_array (Array.map (fun (n, s) -> s) new_sub_cases) i.next in let (new_next, sub_next) = rename i.next sub_merge in (instr_cons (Iswitch(index, Array.map (fun (n, s) -> n) new_sub_cases)) (subst_regs i.arg sub) [||] new_next, sub_next) | Iloop(body) -> let (new_body, sub_body) = rename body sub in let (new_next, sub_next) = rename i.next (merge_substs sub sub_body i) in (instr_cons (Iloop(new_body)) [||] [||] new_next, sub_next) | Icatch(nfail, body, handler) -> let new_subst = ref None in exit_subst := (nfail, new_subst) :: !exit_subst ; let (new_body, sub_body) = rename body sub in let sub_entry_handler = !new_subst in exit_subst := List.tl !exit_subst; let (new_handler, sub_handler) = rename handler sub_entry_handler in let (new_next, sub_next) = rename i.next (merge_substs sub_body sub_handler i.next) in (instr_cons (Icatch(nfail, new_body, new_handler)) [||] [||] new_next, sub_next) | Iexit nfail -> let r = find_exit_subst nfail in r := merge_substs !r sub i; (i, None) | Itrywith(body, handler) -> let (new_body, sub_body) = rename body sub in let (new_handler, sub_handler) = rename handler sub in let (new_next, sub_next) = rename i.next (merge_substs sub_body sub_handler i.next) in (instr_cons (Itrywith(new_body, new_handler)) [||] [||] new_next, sub_next) | Iraise -> (instr_cons_debug Iraise (subst_regs i.arg sub) [||] i.dbg i.next, None) (* Second pass: replace registers by their final representatives *) let set_repres i = instr_iter (fun i -> repres_regs i.arg; repres_regs i.res) i (* Entry point *) let fundecl f = equiv_classes := Reg.Map.empty; let new_args = Array.copy f.fun_args in let (new_body, sub_body) = rename f.fun_body (Some Reg.Map.empty) in repres_regs new_args; set_repres new_body; equiv_classes := Reg.Map.empty; { fun_name = f.fun_name; fun_args = new_args; fun_body = new_body; fun_fast = f.fun_fast; fun_dbg = f.fun_dbg } mingw-ocaml/ocaml/asmcomp/selectgen.mli0000644000175000017500000001016112124403240017567 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) type environment = (Ident.t, Reg.t array) Tbl.t val size_expr : environment -> Cmm.expression -> int class virtual selector_generic : object (* The following methods must or can be overridden by the processor description *) method virtual is_immediate : int -> bool (* Must be defined to indicate whether a constant is a suitable immediate operand to arithmetic instructions *) method virtual select_addressing : Cmm.memory_chunk -> Cmm.expression -> Arch.addressing_mode * Cmm.expression (* Must be defined to select addressing modes *) method is_simple_expr: Cmm.expression -> bool (* Can be overridden to reflect special extcalls known to be pure *) method select_operation : Cmm.operation -> Cmm.expression list -> Mach.operation * Cmm.expression list (* Can be overridden to deal with special arithmetic instructions *) method select_condition : Cmm.expression -> Mach.test * Cmm.expression (* Can be overridden to deal with special test instructions *) method select_store : Arch.addressing_mode -> Cmm.expression -> Mach.operation * Cmm.expression (* Can be overridden to deal with special store constant instructions *) method regs_for : Cmm.machtype -> Reg.t array (* Return an array of fresh registers of the given type. Default implementation is like Reg.createv. Can be overridden if float values are stored as pairs of integer registers. *) method insert_op : Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array (* Can be overridden to deal with 2-address instructions or instructions with hardwired input/output registers *) method insert_op_debug : Mach.operation -> Debuginfo.t -> Reg.t array -> Reg.t array -> Reg.t array (* Can be overridden to deal with 2-address instructions or instructions with hardwired input/output registers *) method emit_extcall_args : environment -> Cmm.expression list -> Reg.t array * int (* Can be overridden to deal with stack-based calling conventions *) method emit_stores : environment -> Cmm.expression list -> Reg.t array -> unit (* Fill a freshly allocated block. Can be overridden for architectures that do not provide Arch.offset_addressing. *) (* The following method is the entry point and should not be overridden *) method emit_fundecl : Cmm.fundecl -> Mach.fundecl (* The following methods should not be overridden. They cannot be declared "private" in the current implementation because they are not always applied to "self", but ideally they should be private. *) method extract : Mach.instruction method insert : Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit method insert_debug : Mach.instruction_desc -> Debuginfo.t -> Reg.t array -> Reg.t array -> unit method insert_move : Reg.t -> Reg.t -> unit method insert_move_args : Reg.t array -> Reg.t array -> int -> unit method insert_move_results : Reg.t array -> Reg.t array -> int -> unit method insert_moves : Reg.t array -> Reg.t array -> unit method emit_expr : (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> Reg.t array option method emit_tail : (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> unit end mingw-ocaml/ocaml/asmcomp/closure.mli0000644000175000017500000000166712124403240017305 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Introduction of closures, uncurrying, recognition of direct calls *) val intro: int -> Lambda.lambda -> Clambda.ulambda mingw-ocaml/ocaml/asmcomp/printmach.mli0000644000175000017500000000266112124403240017611 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Pretty-printing of pseudo machine code *) open Format val reg: formatter -> Reg.t -> unit val regs: formatter -> Reg.t array -> unit val regset: formatter -> Reg.Set.t -> unit val regsetaddr: formatter -> Reg.Set.t -> unit val operation: Mach.operation -> Reg.t array -> formatter -> Reg.t array -> unit val test: Mach.test -> formatter -> Reg.t array -> unit val instr: formatter -> Mach.instruction -> unit val fundecl: formatter -> Mach.fundecl -> unit val phase: string -> formatter -> Mach.fundecl -> unit val interferences: formatter -> unit -> unit val preferences: formatter -> unit -> unit val print_live: bool ref mingw-ocaml/ocaml/asmcomp/selectgen.ml0000644000175000017500000007146412124403240017433 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) open Misc open Cmm open Reg open Mach type environment = (Ident.t, Reg.t array) Tbl.t (* Infer the type of the result of an operation *) let oper_result_type = function Capply(ty, _) -> ty | Cextcall(s, ty, alloc, _) -> ty | Cload c -> begin match c with Word -> typ_addr | Single | Double | Double_u -> typ_float | _ -> typ_int end | Calloc -> typ_addr | Cstore c -> typ_void | Caddi | Csubi | Cmuli | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi _ | Ccmpa _ | Ccmpf _ -> typ_int | Cadda | Csuba -> typ_addr | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf -> typ_float | Cfloatofint -> typ_float | Cintoffloat -> typ_int | Craise _ -> typ_void | Ccheckbound _ -> typ_void (* Infer the size in bytes of the result of a simple expression *) let size_expr env exp = let rec size localenv = function Cconst_int _ | Cconst_natint _ -> Arch.size_int | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ -> Arch.size_addr | Cconst_float _ -> Arch.size_float | Cvar id -> begin try Tbl.find id localenv with Not_found -> try let regs = Tbl.find id env in size_machtype (Array.map (fun r -> r.typ) regs) with Not_found -> fatal_error("Selection.size_expr: unbound var " ^ Ident.unique_name id) end | Ctuple el -> List.fold_right (fun e sz -> size localenv e + sz) el 0 | Cop(op, args) -> size_machtype(oper_result_type op) | Clet(id, arg, body) -> size (Tbl.add id (size localenv arg) localenv) body | Csequence(e1, e2) -> size localenv e2 | _ -> fatal_error "Selection.size_expr" in size Tbl.empty exp (* Swap the two arguments of an integer comparison *) let swap_intcomp = function Isigned cmp -> Isigned(swap_comparison cmp) | Iunsigned cmp -> Iunsigned(swap_comparison cmp) (* Naming of registers *) let all_regs_anonymous rv = try for i = 0 to Array.length rv - 1 do if String.length rv.(i).name > 0 then raise Exit done; true with Exit -> false let name_regs id rv = if Array.length rv = 1 then rv.(0).name <- Ident.name id else for i = 0 to Array.length rv - 1 do rv.(i).name <- Ident.name id ^ "#" ^ string_of_int i done (* "Join" two instruction sequences, making sure they return their results in the same registers. *) let join opt_r1 seq1 opt_r2 seq2 = match (opt_r1, opt_r2) with (None, _) -> opt_r2 | (_, None) -> opt_r1 | (Some r1, Some r2) -> let l1 = Array.length r1 in assert (l1 = Array.length r2); let r = Array.create l1 Reg.dummy in for i = 0 to l1-1 do if String.length r1.(i).name = 0 then begin r.(i) <- r1.(i); seq2#insert_move r2.(i) r1.(i) end else if String.length r2.(i).name = 0 then begin r.(i) <- r2.(i); seq1#insert_move r1.(i) r2.(i) end else begin r.(i) <- Reg.create r1.(i).typ; seq1#insert_move r1.(i) r.(i); seq2#insert_move r2.(i) r.(i) end done; Some r (* Same, for N branches *) let join_array rs = let some_res = ref None in for i = 0 to Array.length rs - 1 do let (r, s) = rs.(i) in if r <> None then some_res := r done; match !some_res with None -> None | Some template -> let size_res = Array.length template in let res = Array.create size_res Reg.dummy in for i = 0 to size_res - 1 do res.(i) <- Reg.create template.(i).typ done; for i = 0 to Array.length rs - 1 do let (r, s) = rs.(i) in match r with None -> () | Some r -> s#insert_moves r res done; Some res (* Extract debug info contained in a C-- operation *) let debuginfo_op = function | Capply(_, dbg) -> dbg | Cextcall(_, _, _, dbg) -> dbg | Craise dbg -> dbg | Ccheckbound dbg -> dbg | _ -> Debuginfo.none (* Registers for catch constructs *) let catch_regs = ref [] (* Name of function being compiled *) let current_function_name = ref "" (* The default instruction selection class *) class virtual selector_generic = object (self) (* Says if an expression is "simple". A "simple" expression has no side-effects and its execution can be delayed until its value is really needed. In the case of e.g. an [alloc] instruction, the non-simple arguments are computed in right-to-left order first, then the block is allocated, then the simple arguments are evaluated and stored. *) method is_simple_expr = function Cconst_int _ -> true | Cconst_natint _ -> true | Cconst_float _ -> true | Cconst_symbol _ -> true | Cconst_pointer _ -> true | Cconst_natpointer _ -> true | Cvar _ -> true | Ctuple el -> List.for_all self#is_simple_expr el | Clet(id, arg, body) -> self#is_simple_expr arg && self#is_simple_expr body | Csequence(e1, e2) -> self#is_simple_expr e1 && self#is_simple_expr e2 | Cop(op, args) -> begin match op with (* The following may have side effects *) | Capply _ | Cextcall _ | Calloc | Cstore _ | Craise _ -> false (* The remaining operations are simple if their args are *) | _ -> List.for_all self#is_simple_expr args end | _ -> false (* Says whether an integer constant is a suitable immediate argument *) method virtual is_immediate : int -> bool (* Selection of addressing modes *) method virtual select_addressing : Cmm.memory_chunk -> Cmm.expression -> Arch.addressing_mode * Cmm.expression (* Default instruction selection for stores (of words) *) method select_store addr arg = (Istore(Word, addr), arg) (* Default instruction selection for operators *) method select_operation op args = match (op, args) with (Capply(ty, dbg), Cconst_symbol s :: rem) -> (Icall_imm s, rem) | (Capply(ty, dbg), _) -> (Icall_ind, args) | (Cextcall(s, ty, alloc, dbg), _) -> (Iextcall(s, alloc), args) | (Cload chunk, [arg]) -> let (addr, eloc) = self#select_addressing chunk arg in (Iload(chunk, addr), [eloc]) | (Cstore chunk, [arg1; arg2]) -> let (addr, eloc) = self#select_addressing chunk arg1 in if chunk = Word then begin let (op, newarg2) = self#select_store addr arg2 in (op, [newarg2; eloc]) end else begin (Istore(chunk, addr), [arg2; eloc]) (* Inversion addr/datum in Istore *) end | (Calloc, _) -> (Ialloc 0, args) | (Caddi, _) -> self#select_arith_comm Iadd args | (Csubi, _) -> self#select_arith Isub args | (Cmuli, [arg1; Cconst_int n]) -> let l = Misc.log2 n in if n = 1 lsl l then (Iintop_imm(Ilsl, l), [arg1]) else self#select_arith_comm Imul args | (Cmuli, [Cconst_int n; arg1]) -> let l = Misc.log2 n in if n = 1 lsl l then (Iintop_imm(Ilsl, l), [arg1]) else self#select_arith_comm Imul args | (Cmuli, _) -> self#select_arith_comm Imul args | (Cdivi, _) -> self#select_arith Idiv args | (Cmodi, _) -> self#select_arith_comm Imod args | (Cand, _) -> self#select_arith_comm Iand args | (Cor, _) -> self#select_arith_comm Ior args | (Cxor, _) -> self#select_arith_comm Ixor args | (Clsl, _) -> self#select_shift Ilsl args | (Clsr, _) -> self#select_shift Ilsr args | (Casr, _) -> self#select_shift Iasr args | (Ccmpi comp, _) -> self#select_arith_comp (Isigned comp) args | (Cadda, _) -> self#select_arith_comm Iadd args | (Csuba, _) -> self#select_arith Isub args | (Ccmpa comp, _) -> self#select_arith_comp (Iunsigned comp) args | (Cnegf, _) -> (Inegf, args) | (Cabsf, _) -> (Iabsf, args) | (Caddf, _) -> (Iaddf, args) | (Csubf, _) -> (Isubf, args) | (Cmulf, _) -> (Imulf, args) | (Cdivf, _) -> (Idivf, args) | (Cfloatofint, _) -> (Ifloatofint, args) | (Cintoffloat, _) -> (Iintoffloat, args) | (Ccheckbound _, _) -> self#select_arith Icheckbound args | _ -> fatal_error "Selection.select_oper" method private select_arith_comm op = function [arg; Cconst_int n] when self#is_immediate n -> (Iintop_imm(op, n), [arg]) | [arg; Cconst_pointer n] when self#is_immediate n -> (Iintop_imm(op, n), [arg]) | [Cconst_int n; arg] when self#is_immediate n -> (Iintop_imm(op, n), [arg]) | [Cconst_pointer n; arg] when self#is_immediate n -> (Iintop_imm(op, n), [arg]) | args -> (Iintop op, args) method private select_arith op = function [arg; Cconst_int n] when self#is_immediate n -> (Iintop_imm(op, n), [arg]) | [arg; Cconst_pointer n] when self#is_immediate n -> (Iintop_imm(op, n), [arg]) | args -> (Iintop op, args) method private select_shift op = function [arg; Cconst_int n] when n >= 0 && n < Arch.size_int * 8 -> (Iintop_imm(op, n), [arg]) | args -> (Iintop op, args) method private select_arith_comp cmp = function [arg; Cconst_int n] when self#is_immediate n -> (Iintop_imm(Icomp cmp, n), [arg]) | [arg; Cconst_pointer n] when self#is_immediate n -> (Iintop_imm(Icomp cmp, n), [arg]) | [Cconst_int n; arg] when self#is_immediate n -> (Iintop_imm(Icomp(swap_intcomp cmp), n), [arg]) | [Cconst_pointer n; arg] when self#is_immediate n -> (Iintop_imm(Icomp(swap_intcomp cmp), n), [arg]) | args -> (Iintop(Icomp cmp), args) (* Instruction selection for conditionals *) method select_condition = function Cop(Ccmpi cmp, [arg1; Cconst_int n]) when self#is_immediate n -> (Iinttest_imm(Isigned cmp, n), arg1) | Cop(Ccmpi cmp, [Cconst_int n; arg2]) when self#is_immediate n -> (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2) | Cop(Ccmpi cmp, [arg1; Cconst_pointer n]) when self#is_immediate n -> (Iinttest_imm(Isigned cmp, n), arg1) | Cop(Ccmpi cmp, [Cconst_pointer n; arg2]) when self#is_immediate n -> (Iinttest_imm(Isigned(swap_comparison cmp), n), arg2) | Cop(Ccmpi cmp, args) -> (Iinttest(Isigned cmp), Ctuple args) | Cop(Ccmpa cmp, [arg1; Cconst_pointer n]) when self#is_immediate n -> (Iinttest_imm(Iunsigned cmp, n), arg1) | Cop(Ccmpa cmp, [arg1; Cconst_int n]) when self#is_immediate n -> (Iinttest_imm(Iunsigned cmp, n), arg1) | Cop(Ccmpa cmp, [Cconst_pointer n; arg2]) when self#is_immediate n -> (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2) | Cop(Ccmpa cmp, [Cconst_int n; arg2]) when self#is_immediate n -> (Iinttest_imm(Iunsigned(swap_comparison cmp), n), arg2) | Cop(Ccmpa cmp, args) -> (Iinttest(Iunsigned cmp), Ctuple args) | Cop(Ccmpf cmp, args) -> (Ifloattest(cmp, false), Ctuple args) | Cop(Cand, [arg; Cconst_int 1]) -> (Ioddtest, arg) | arg -> (Itruetest, arg) (* Return an array of fresh registers of the given type. Normally implemented as Reg.createv, but some ports (e.g. Arm) can override this definition to store float values in pairs of integer registers. *) method regs_for tys = Reg.createv tys (* Buffering of instruction sequences *) val mutable instr_seq = dummy_instr method insert_debug desc dbg arg res = instr_seq <- instr_cons_debug desc arg res dbg instr_seq method insert desc arg res = instr_seq <- instr_cons desc arg res instr_seq method extract = let rec extract res i = if i == dummy_instr then res else extract {i with next = res} i.next in extract (end_instr()) instr_seq (* Insert a sequence of moves from one pseudoreg set to another. *) method insert_move src dst = if src.stamp <> dst.stamp then self#insert (Iop Imove) [|src|] [|dst|] method insert_moves src dst = for i = 0 to min (Array.length src) (Array.length dst) - 1 do self#insert_move src.(i) dst.(i) done (* Insert moves and stack offsets for function arguments and results *) method insert_move_args arg loc stacksize = if stacksize <> 0 then self#insert (Iop(Istackoffset stacksize)) [||] [||]; self#insert_moves arg loc method insert_move_results loc res stacksize = if stacksize <> 0 then self#insert(Iop(Istackoffset(-stacksize))) [||] [||]; self#insert_moves loc res (* Add an Iop opcode. Can be overridden by processor description to insert moves before and after the operation, i.e. for two-address instructions, or instructions using dedicated registers. *) method insert_op_debug op dbg rs rd = self#insert_debug (Iop op) dbg rs rd; rd method insert_op op rs rd = self#insert_op_debug op Debuginfo.none rs rd (* Add the instructions for the given expression at the end of the self sequence *) method emit_expr env exp = match exp with Cconst_int n -> let r = self#regs_for typ_int in Some(self#insert_op (Iconst_int(Nativeint.of_int n)) [||] r) | Cconst_natint n -> let r = self#regs_for typ_int in Some(self#insert_op (Iconst_int n) [||] r) | Cconst_float n -> let r = self#regs_for typ_float in Some(self#insert_op (Iconst_float n) [||] r) | Cconst_symbol n -> let r = self#regs_for typ_addr in Some(self#insert_op (Iconst_symbol n) [||] r) | Cconst_pointer n -> let r = self#regs_for typ_addr in Some(self#insert_op (Iconst_int(Nativeint.of_int n)) [||] r) | Cconst_natpointer n -> let r = self#regs_for typ_addr in Some(self#insert_op (Iconst_int n) [||] r) | Cvar v -> begin try Some(Tbl.find v env) with Not_found -> fatal_error("Selection.emit_expr: unbound var " ^ Ident.unique_name v) end | Clet(v, e1, e2) -> begin match self#emit_expr env e1 with None -> None | Some r1 -> self#emit_expr (self#bind_let env v r1) e2 end | Cassign(v, e1) -> let rv = try Tbl.find v env with Not_found -> fatal_error ("Selection.emit_expr: unbound var " ^ Ident.name v) in begin match self#emit_expr env e1 with None -> None | Some r1 -> self#insert_moves r1 rv; Some [||] end | Ctuple [] -> Some [||] | Ctuple exp_list -> begin match self#emit_parts_list env exp_list with None -> None | Some(simple_list, ext_env) -> Some(self#emit_tuple ext_env simple_list) end | Cop(Craise dbg, [arg]) -> begin match self#emit_expr env arg with None -> None | Some r1 -> let rd = [|Proc.loc_exn_bucket|] in self#insert (Iop Imove) r1 rd; self#insert_debug Iraise dbg rd [||]; None end | Cop(Ccmpf comp, args) -> self#emit_expr env (Cifthenelse(exp, Cconst_int 1, Cconst_int 0)) | Cop(op, args) -> begin match self#emit_parts_list env args with None -> None | Some(simple_args, env) -> let ty = oper_result_type op in let (new_op, new_args) = self#select_operation op simple_args in let dbg = debuginfo_op op in match new_op with Icall_ind -> Proc.contains_calls := true; let r1 = self#emit_tuple env new_args in let rarg = Array.sub r1 1 (Array.length r1 - 1) in let rd = self#regs_for ty in let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in let loc_res = Proc.loc_results rd in self#insert_move_args rarg loc_arg stack_ofs; self#insert_debug (Iop Icall_ind) dbg (Array.append [|r1.(0)|] loc_arg) loc_res; self#insert_move_results loc_res rd stack_ofs; Some rd | Icall_imm lbl -> Proc.contains_calls := true; let r1 = self#emit_tuple env new_args in let rd = self#regs_for ty in let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in let loc_res = Proc.loc_results rd in self#insert_move_args r1 loc_arg stack_ofs; self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res; self#insert_move_results loc_res rd stack_ofs; Some rd | Iextcall(lbl, alloc) -> Proc.contains_calls := true; let (loc_arg, stack_ofs) = self#emit_extcall_args env new_args in let rd = self#regs_for ty in let loc_res = self#insert_op_debug (Iextcall(lbl, alloc)) dbg loc_arg (Proc.loc_external_results rd) in self#insert_move_results loc_res rd stack_ofs; Some rd | Ialloc _ -> Proc.contains_calls := true; let rd = self#regs_for typ_addr in let size = size_expr env (Ctuple new_args) in self#insert (Iop(Ialloc size)) [||] rd; self#emit_stores env new_args rd; Some rd | op -> let r1 = self#emit_tuple env new_args in let rd = self#regs_for ty in Some (self#insert_op_debug op dbg r1 rd) end | Csequence(e1, e2) -> begin match self#emit_expr env e1 with None -> None | Some r1 -> self#emit_expr env e2 end | Cifthenelse(econd, eif, eelse) -> let (cond, earg) = self#select_condition econd in begin match self#emit_expr env earg with None -> None | Some rarg -> let (rif, sif) = self#emit_sequence env eif in let (relse, selse) = self#emit_sequence env eelse in let r = join rif sif relse selse in self#insert (Iifthenelse(cond, sif#extract, selse#extract)) rarg [||]; r end | Cswitch(esel, index, ecases) -> begin match self#emit_expr env esel with None -> None | Some rsel -> let rscases = Array.map (self#emit_sequence env) ecases in let r = join_array rscases in self#insert (Iswitch(index, Array.map (fun (r, s) -> s#extract) rscases)) rsel [||]; r end | Cloop(ebody) -> let (rarg, sbody) = self#emit_sequence env ebody in self#insert (Iloop(sbody#extract)) [||] [||]; Some [||] | Ccatch(nfail, ids, e1, e2) -> let rs = List.map (fun id -> let r = self#regs_for typ_addr in name_regs id r; r) ids in catch_regs := (nfail, Array.concat rs) :: !catch_regs ; let (r1, s1) = self#emit_sequence env e1 in catch_regs := List.tl !catch_regs ; let new_env = List.fold_left (fun env (id,r) -> Tbl.add id r env) env (List.combine ids rs) in let (r2, s2) = self#emit_sequence new_env e2 in let r = join r1 s1 r2 s2 in self#insert (Icatch(nfail, s1#extract, s2#extract)) [||] [||]; r | Cexit (nfail,args) -> begin match self#emit_parts_list env args with None -> None | Some (simple_list, ext_env) -> let src = self#emit_tuple ext_env simple_list in let dest = try List.assoc nfail !catch_regs with Not_found -> Misc.fatal_error ("Selectgen.emit_expr, on exit("^string_of_int nfail^")") in self#insert_moves src dest ; self#insert (Iexit nfail) [||] [||]; None end | Ctrywith(e1, v, e2) -> Proc.contains_calls := true; let (r1, s1) = self#emit_sequence env e1 in let rv = self#regs_for typ_addr in let (r2, s2) = self#emit_sequence (Tbl.add v rv env) e2 in let r = join r1 s1 r2 s2 in self#insert (Itrywith(s1#extract, instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv (s2#extract))) [||] [||]; r method private emit_sequence env exp = let s = {< instr_seq = dummy_instr >} in let r = s#emit_expr env exp in (r, s) method private bind_let env v r1 = if all_regs_anonymous r1 then begin name_regs v r1; Tbl.add v r1 env end else begin let rv = Reg.createv_like r1 in name_regs v rv; self#insert_moves r1 rv; Tbl.add v rv env end method private emit_parts env exp = if self#is_simple_expr exp then Some (exp, env) else begin match self#emit_expr env exp with None -> None | Some r -> if Array.length r = 0 then Some (Ctuple [], env) else begin (* The normal case *) let id = Ident.create "bind" in if all_regs_anonymous r then (* r is an anonymous, unshared register; use it directly *) Some (Cvar id, Tbl.add id r env) else begin (* Introduce a fresh temp to hold the result *) let tmp = Reg.createv_like r in self#insert_moves r tmp; Some (Cvar id, Tbl.add id tmp env) end end end method private emit_parts_list env exp_list = match exp_list with [] -> Some ([], env) | exp :: rem -> (* This ensures right-to-left evaluation, consistent with the bytecode compiler *) match self#emit_parts_list env rem with None -> None | Some(new_rem, new_env) -> match self#emit_parts new_env exp with None -> None | Some(new_exp, fin_env) -> Some(new_exp :: new_rem, fin_env) method private emit_tuple env exp_list = let rec emit_list = function [] -> [] | exp :: rem -> (* Again, force right-to-left evaluation *) let loc_rem = emit_list rem in match self#emit_expr env exp with None -> assert false (* should have been caught in emit_parts *) | Some loc_exp -> loc_exp :: loc_rem in Array.concat(emit_list exp_list) method emit_extcall_args env args = let r1 = self#emit_tuple env args in let (loc_arg, stack_ofs as arg_stack) = Proc.loc_external_arguments r1 in self#insert_move_args r1 loc_arg stack_ofs; arg_stack method emit_stores env data regs_addr = let a = ref (Arch.offset_addressing Arch.identity_addressing (-Arch.size_int)) in List.iter (fun e -> let (op, arg) = self#select_store !a e in match self#emit_expr env arg with None -> assert false | Some regs -> match op with Istore(_, _) -> for i = 0 to Array.length regs - 1 do let r = regs.(i) in let kind = if r.typ = Float then Double_u else Word in self#insert (Iop(Istore(kind, !a))) (Array.append [|r|] regs_addr) [||]; a := Arch.offset_addressing !a (size_component r.typ) done | _ -> self#insert (Iop op) (Array.append regs regs_addr) [||]; a := Arch.offset_addressing !a (size_expr env e)) data (* Same, but in tail position *) method private emit_return env exp = match self#emit_expr env exp with None -> () | Some r -> let loc = Proc.loc_results r in self#insert_moves r loc; self#insert Ireturn loc [||] method emit_tail env exp = match exp with Clet(v, e1, e2) -> begin match self#emit_expr env e1 with None -> () | Some r1 -> self#emit_tail (self#bind_let env v r1) e2 end | Cop(Capply(ty, dbg) as op, args) -> begin match self#emit_parts_list env args with None -> () | Some(simple_args, env) -> let (new_op, new_args) = self#select_operation op simple_args in match new_op with Icall_ind -> let r1 = self#emit_tuple env new_args in let rarg = Array.sub r1 1 (Array.length r1 - 1) in let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in if stack_ofs = 0 then begin self#insert_moves rarg loc_arg; self#insert (Iop Itailcall_ind) (Array.append [|r1.(0)|] loc_arg) [||] end else begin Proc.contains_calls := true; let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in self#insert_move_args rarg loc_arg stack_ofs; self#insert_debug (Iop Icall_ind) dbg (Array.append [|r1.(0)|] loc_arg) loc_res; self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; self#insert Ireturn loc_res [||] end | Icall_imm lbl -> let r1 = self#emit_tuple env new_args in let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in if stack_ofs = 0 then begin self#insert_moves r1 loc_arg; self#insert (Iop(Itailcall_imm lbl)) loc_arg [||] end else if lbl = !current_function_name then begin let loc_arg' = Proc.loc_parameters r1 in self#insert_moves r1 loc_arg'; self#insert (Iop(Itailcall_imm lbl)) loc_arg' [||] end else begin Proc.contains_calls := true; let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in self#insert_move_args r1 loc_arg stack_ofs; self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res; self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; self#insert Ireturn loc_res [||] end | _ -> fatal_error "Selection.emit_tail" end | Csequence(e1, e2) -> begin match self#emit_expr env e1 with None -> () | Some r1 -> self#emit_tail env e2 end | Cifthenelse(econd, eif, eelse) -> let (cond, earg) = self#select_condition econd in begin match self#emit_expr env earg with None -> () | Some rarg -> self#insert (Iifthenelse(cond, self#emit_tail_sequence env eif, self#emit_tail_sequence env eelse)) rarg [||] end | Cswitch(esel, index, ecases) -> begin match self#emit_expr env esel with None -> () | Some rsel -> self#insert (Iswitch(index, Array.map (self#emit_tail_sequence env) ecases)) rsel [||] end | Ccatch(nfail, ids, e1, e2) -> let rs = List.map (fun id -> let r = self#regs_for typ_addr in name_regs id r ; r) ids in catch_regs := (nfail, Array.concat rs) :: !catch_regs ; let s1 = self#emit_tail_sequence env e1 in catch_regs := List.tl !catch_regs ; let new_env = List.fold_left (fun env (id,r) -> Tbl.add id r env) env (List.combine ids rs) in let s2 = self#emit_tail_sequence new_env e2 in self#insert (Icatch(nfail, s1, s2)) [||] [||] | Ctrywith(e1, v, e2) -> Proc.contains_calls := true; let (opt_r1, s1) = self#emit_sequence env e1 in let rv = self#regs_for typ_addr in let s2 = self#emit_tail_sequence (Tbl.add v rv env) e2 in self#insert (Itrywith(s1#extract, instr_cons (Iop Imove) [|Proc.loc_exn_bucket|] rv s2)) [||] [||]; begin match opt_r1 with None -> () | Some r1 -> let loc = Proc.loc_results r1 in self#insert_moves r1 loc; self#insert Ireturn loc [||] end | _ -> self#emit_return env exp method private emit_tail_sequence env exp = let s = {< instr_seq = dummy_instr >} in s#emit_tail env exp; s#extract (* Sequentialization of a function definition *) method emit_fundecl f = Proc.contains_calls := false; current_function_name := f.Cmm.fun_name; let rargs = List.map (fun (id, ty) -> let r = self#regs_for ty in name_regs id r; r) f.Cmm.fun_args in let rarg = Array.concat rargs in let loc_arg = Proc.loc_parameters rarg in let env = List.fold_right2 (fun (id, ty) r env -> Tbl.add id r env) f.Cmm.fun_args rargs Tbl.empty in self#insert_moves loc_arg rarg; self#emit_tail env f.Cmm.fun_body; { fun_name = f.Cmm.fun_name; fun_args = loc_arg; fun_body = self#extract; fun_fast = f.Cmm.fun_fast; fun_dbg = f.Cmm.fun_dbg } end (* Tail call criterion (estimated). Assumes: - all arguments are of type "int" (always the case for OCaml function calls) - one extra argument representing the closure environment (conservative). *) let is_tail_call nargs = assert (Reg.dummy.typ = Int); let args = Array.make (nargs + 1) Reg.dummy in let (loc_arg, stack_ofs) = Proc.loc_arguments args in stack_ofs = 0 let _ = Simplif.is_tail_native_heuristic := is_tail_call mingw-ocaml/ocaml/asmcomp/emit.mli0000644000175000017500000000175212124403240016562 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Generation of assembly code *) val fundecl: Linearize.fundecl -> unit val data: Cmm.data_item list -> unit val begin_assembly: unit -> unit val end_assembly: unit -> unit mingw-ocaml/ocaml/asmcomp/asmpackager.mli0000644000175000017500000000243012124403240020074 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* "Package" a set of .cmx/.o files into one .cmx/.o file having the original compilation units as sub-modules. *) val package_files: Format.formatter -> string list -> string -> unit type error = Illegal_renaming of string * string | Forward_reference of string * string | Wrong_for_pack of string * string | Linking_error | Assembler_error of string | File_not_found of string exception Error of error val report_error: Format.formatter -> error -> unit mingw-ocaml/ocaml/asmcomp/schedgen.ml0000644000175000017500000003164212124403240017234 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Instruction scheduling *) open Misc open Reg open Mach open Linearize (* Representation of the code DAG. *) type code_dag_node = { instr: instruction; (* The instruction *) delay: int; (* How many cycles before result is available *) mutable sons: (code_dag_node * int) list; (* Instructions that depend on it *) mutable date: int; (* Start date *) mutable length: int; (* Length of longest path to result *) mutable ancestors: int; (* Number of ancestors *) mutable emitted_ancestors: int } (* Number of emitted ancestors *) let dummy_node = { instr = end_instr; delay = 0; sons = []; date = 0; length = -1; ancestors = 0; emitted_ancestors = 0 } (* The code dag itself is represented by two tables from registers to nodes: - "results" maps registers to the instructions that produced them; - "uses" maps registers to the instructions that use them. In addition: - code_stores contains the latest store nodes emitted so far - code_loads contains all load nodes emitted since the last store - code_checkbounds contains the latest checkbound node not matched by a subsequent load or store. *) let code_results = (Hashtbl.create 31 : (location, code_dag_node) Hashtbl.t) let code_uses = (Hashtbl.create 31 : (location, code_dag_node) Hashtbl.t) let code_stores = ref ([] : code_dag_node list) let code_loads = ref ([] : code_dag_node list) let code_checkbounds = ref ([] : code_dag_node list) let clear_code_dag () = Hashtbl.clear code_results; Hashtbl.clear code_uses; code_stores := []; code_loads := []; code_checkbounds := [] (* Add an edge to the code DAG *) let add_edge ancestor son delay = ancestor.sons <- (son, delay) :: ancestor.sons; son.ancestors <- son.ancestors + 1 let add_edge_after son ancestor = add_edge ancestor son 0 (* Add edges from all instructions that define a pseudoregister [arg] being used as argument to node [node] (RAW dependencies *) let add_RAW_dependencies node arg = try let ancestor = Hashtbl.find code_results arg.loc in add_edge ancestor node ancestor.delay with Not_found -> () (* Add edges from all instructions that use a pseudoregister [res] that is defined by node [node] (WAR dependencies). *) let add_WAR_dependencies node res = let ancestors = Hashtbl.find_all code_uses res.loc in List.iter (add_edge_after node) ancestors (* Add edges from all instructions that have already defined a pseudoregister [res] that is defined by node [node] (WAW dependencies). *) let add_WAW_dependencies node res = try let ancestor = Hashtbl.find code_results res.loc in add_edge ancestor node 0 with Not_found -> () (* Compute length of longest path to a result. For leafs of the DAG, see whether their result is used in the instruction immediately following the basic block (a "critical" output). *) let is_critical critical_outputs results = try for i = 0 to Array.length results - 1 do let r = results.(i).loc in for j = 0 to Array.length critical_outputs - 1 do if critical_outputs.(j).loc = r then raise Exit done done; false with Exit -> true let rec longest_path critical_outputs node = if node.length < 0 then begin match node.sons with [] -> node.length <- if is_critical critical_outputs node.instr.res || node.instr.desc = Lreloadretaddr (* alway critical *) then node.delay else 0 | sons -> node.length <- List.fold_left (fun len (son, delay) -> max len (longest_path critical_outputs son + delay)) 0 sons end; node.length (* Remove an instruction from the ready queue *) let rec remove_instr node = function [] -> [] | instr :: rem -> if instr == node then rem else instr :: remove_instr node rem (* We treat Lreloadretaddr as a word-sized load *) let some_load = (Iload(Cmm.Word, Arch.identity_addressing)) (* The generic scheduler *) class virtual scheduler_generic = object (self) (* Determine whether an operation ends a basic block or not. Can be overridden for some processors to signal specific instructions that terminate a basic block. *) method oper_in_basic_block = function Icall_ind -> false | Icall_imm _ -> false | Itailcall_ind -> false | Itailcall_imm _ -> false | Iextcall _ -> false | Istackoffset _ -> false | Ialloc _ -> false | _ -> true (* Determine whether an instruction ends a basic block or not *) method private instr_in_basic_block instr = match instr.desc with Lop op -> self#oper_in_basic_block op | Lreloadretaddr -> true | _ -> false (* Determine whether an operation is a memory store or a memory load. Can be overridden for some processors to signal specific load or store instructions (e.g. on the I386). *) method is_store = function Istore(_, _) -> true | _ -> false method is_load = function Iload(_, _) -> true | _ -> false method is_checkbound = function Iintop Icheckbound -> true | Iintop_imm(Icheckbound, _) -> true | _ -> false method private instr_is_store instr = match instr.desc with Lop op -> self#is_store op | _ -> false method private instr_is_load instr = match instr.desc with Lop op -> self#is_load op | _ -> false method private instr_is_checkbound instr = match instr.desc with Lop op -> self#is_checkbound op | _ -> false (* Estimate the latency of an operation. *) method virtual oper_latency : Mach.operation -> int (* Estimate the latency of a Lreloadretaddr operation. *) method reload_retaddr_latency = self#oper_latency some_load (* Estimate the delay needed to evaluate an instruction *) method private instr_latency instr = match instr.desc with Lop op -> self#oper_latency op | Lreloadretaddr -> self#reload_retaddr_latency | _ -> assert false (* Estimate the number of cycles consumed by emitting an operation. *) method virtual oper_issue_cycles : Mach.operation -> int (* Estimate the number of cycles consumed by emitting a Lreloadretaddr. *) method reload_retaddr_issue_cycles = self#oper_issue_cycles some_load (* Estimate the number of cycles consumed by emitting an instruction. *) method private instr_issue_cycles instr = match instr.desc with Lop op -> self#oper_issue_cycles op | Lreloadretaddr -> self#reload_retaddr_issue_cycles | _ -> assert false (* Pseudoregisters destroyed by an instruction *) method private destroyed_by_instr instr = match instr.desc with | Lop op -> Proc.destroyed_at_oper (Iop op) | Lreloadretaddr -> [||] | _ -> assert false (* Add an instruction to the code dag *) method private add_instruction ready_queue instr = let delay = self#instr_latency instr in let destroyed = self#destroyed_by_instr instr in let node = { instr = instr; delay = delay; sons = []; date = 0; length = -1; ancestors = 0; emitted_ancestors = 0 } in (* Add edges from all instructions that define one of the registers used (RAW dependencies) *) Array.iter (add_RAW_dependencies node) instr.arg; (* Also add edges from all instructions that use one of the result regs of this instruction, or a reg destroyed by this instruction (WAR dependencies). *) Array.iter (add_WAR_dependencies node) instr.res; Array.iter (add_WAR_dependencies node) destroyed; (* PR#5731 *) (* Also add edges from all instructions that have already defined one of the results of this instruction, or a reg destroyed by this instruction (WAW dependencies). *) Array.iter (add_WAW_dependencies node) instr.res; Array.iter (add_WAW_dependencies node) destroyed; (* PR#5731 *) (* If this is a load, add edges from the most recent store viewed so far (if any) and remember the load. Also add edges from the most recent checkbound and forget that checkbound. *) if self#instr_is_load instr then begin List.iter (add_edge_after node) !code_stores; code_loads := node :: !code_loads; List.iter (add_edge_after node) !code_checkbounds; code_checkbounds := [] end (* If this is a store, add edges from the most recent store, as well as all loads viewed since then, and also the most recent checkbound. Remember the store, discarding the previous stores, loads and checkbounds. *) else if self#instr_is_store instr then begin List.iter (add_edge_after node) !code_stores; List.iter (add_edge_after node) !code_loads; List.iter (add_edge_after node) !code_checkbounds; code_stores := [node]; code_loads := []; code_checkbounds := [] end else if self#instr_is_checkbound instr then begin code_checkbounds := [node] end; (* Remember the registers used and produced by this instruction *) for i = 0 to Array.length instr.res - 1 do Hashtbl.add code_results instr.res.(i).loc node done; for i = 0 to Array.length destroyed - 1 do Hashtbl.add code_results destroyed.(i).loc node (* PR#5731 *) done; for i = 0 to Array.length instr.arg - 1 do Hashtbl.add code_uses instr.arg.(i).loc node done; (* If this is a root instruction (all arguments already computed), add it to the ready queue *) if node.ancestors = 0 then node :: ready_queue else ready_queue (* Given a list of instructions and a date, choose one or several that are ready to be computed (start date <= current date) and that we can emit in one cycle. Favor instructions with maximal distance to result. If we can't find any, return None. This does not take multiple issues into account, though. *) method private ready_instruction date queue = let rec extract best = function [] -> if best == dummy_node then None else Some best | instr :: rem -> let new_best = if instr.date <= date && instr.length > best.length then instr else best in extract new_best rem in extract dummy_node queue (* Schedule a basic block, adding its instructions in front of the given instruction sequence *) method private reschedule ready_queue date cont = if ready_queue = [] then cont else begin match self#ready_instruction date ready_queue with None -> self#reschedule ready_queue (date + 1) cont | Some node -> (* Remove node from queue *) let new_queue = ref (remove_instr node ready_queue) in (* Update the start date and number of ancestors emitted of all descendents of this node. Enter those that become ready in the queue. *) let issue_cycles = self#instr_issue_cycles node.instr in List.iter (fun (son, delay) -> let completion_date = date + issue_cycles + delay - 1 in if son.date < completion_date then son.date <- completion_date; son.emitted_ancestors <- son.emitted_ancestors + 1; if son.emitted_ancestors = son.ancestors then new_queue := son :: !new_queue) node.sons; instr_cons node.instr.desc node.instr.arg node.instr.res (self#reschedule !new_queue (date + issue_cycles) cont) end (* Entry point *) (* Don't bother to schedule for initialization code and the like. *) method schedule_fundecl f = let rec schedule i = match i.desc with Lend -> i | _ -> if self#instr_in_basic_block i then begin clear_code_dag(); schedule_block [] i end else { i with next = schedule i.next } and schedule_block ready_queue i = if self#instr_in_basic_block i then schedule_block (self#add_instruction ready_queue i) i.next else begin let critical_outputs = match i.desc with Lop(Icall_ind | Itailcall_ind) -> [| i.arg.(0) |] | Lop(Icall_imm _ | Itailcall_imm _ | Iextcall _) -> [||] | Lreturn -> [||] | _ -> i.arg in List.iter (fun x -> ignore (longest_path critical_outputs x)) ready_queue; self#reschedule ready_queue 0 (schedule i) end in if f.fun_fast then begin let new_body = schedule f.fun_body in clear_code_dag(); { fun_name = f.fun_name; fun_body = new_body; fun_fast = f.fun_fast; fun_dbg = f.fun_dbg } end else f end mingw-ocaml/ocaml/asmcomp/printmach.ml0000644000175000017500000001632212124403240017437 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Pretty-printing of pseudo machine code *) open Format open Cmm open Reg open Mach let reg ppf r = if String.length r.name > 0 then fprintf ppf "%s" r.name else fprintf ppf "%s" (match r.typ with Addr -> "A" | Int -> "I" | Float -> "F"); fprintf ppf "/%i" r.stamp; begin match r.loc with | Unknown -> () | Reg r -> fprintf ppf "[%s]" (Proc.register_name r) | Stack(Local s) -> fprintf ppf "[s%i]" s | Stack(Incoming s) -> fprintf ppf "[si%i]" s | Stack(Outgoing s) -> fprintf ppf "[so%i]" s end let regs ppf v = match Array.length v with | 0 -> () | 1 -> reg ppf v.(0) | n -> reg ppf v.(0); for i = 1 to n-1 do fprintf ppf " %a" reg v.(i) done let regset ppf s = let first = ref true in Reg.Set.iter (fun r -> if !first then begin first := false; fprintf ppf "%a" reg r end else fprintf ppf "@ %a" reg r) s let regsetaddr ppf s = let first = ref true in Reg.Set.iter (fun r -> if !first then begin first := false; fprintf ppf "%a" reg r end else fprintf ppf "@ %a" reg r; match r.typ with Addr -> fprintf ppf "*" | _ -> ()) s let intcomp = function | Isigned c -> Printf.sprintf " %ss " (Printcmm.comparison c) | Iunsigned c -> Printf.sprintf " %su " (Printcmm.comparison c) let floatcomp c = Printf.sprintf " %sf " (Printcmm.comparison c) let intop = function | Iadd -> " + " | Isub -> " - " | Imul -> " * " | Idiv -> " div " | Imod -> " mod " | Iand -> " & " | Ior -> " | " | Ixor -> " ^ " | Ilsl -> " << " | Ilsr -> " >>u " | Iasr -> " >>s " | Icomp cmp -> intcomp cmp | Icheckbound -> " check > " let test tst ppf arg = match tst with | Itruetest -> reg ppf arg.(0) | Ifalsetest -> fprintf ppf "not %a" reg arg.(0) | Iinttest cmp -> fprintf ppf "%a%s%a" reg arg.(0) (intcomp cmp) reg arg.(1) | Iinttest_imm(cmp, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intcomp cmp) n | Ifloattest(cmp, neg) -> fprintf ppf "%s%a%s%a" (if neg then "not " else "") reg arg.(0) (floatcomp cmp) reg arg.(1) | Ieventest -> fprintf ppf "%a & 1 == 0" reg arg.(0) | Ioddtest -> fprintf ppf "%a & 1 == 1" reg arg.(0) let print_live = ref false let operation op arg ppf res = if Array.length res > 0 then fprintf ppf "%a := " regs res; match op with | Imove -> regs ppf arg | Ispill -> fprintf ppf "%a (spill)" regs arg | Ireload -> fprintf ppf "%a (reload)" regs arg | Iconst_int n -> fprintf ppf "%s" (Nativeint.to_string n) | Iconst_float s -> fprintf ppf "%s" s | Iconst_symbol s -> fprintf ppf "\"%s\"" s | Icall_ind -> fprintf ppf "call %a" regs arg | Icall_imm lbl -> fprintf ppf "call \"%s\" %a" lbl regs arg | Itailcall_ind -> fprintf ppf "tailcall %a" regs arg | Itailcall_imm lbl -> fprintf ppf "tailcall \"%s\" %a" lbl regs arg | Iextcall(lbl, alloc) -> fprintf ppf "extcall \"%s\" %a%s" lbl regs arg (if not alloc then "" else " (noalloc)") | Istackoffset n -> fprintf ppf "offset stack %i" n | Iload(chunk, addr) -> fprintf ppf "%s[%a]" (Printcmm.chunk chunk) (Arch.print_addressing reg addr) arg | Istore(chunk, addr) -> fprintf ppf "%s[%a] := %a" (Printcmm.chunk chunk) (Arch.print_addressing reg addr) (Array.sub arg 1 (Array.length arg - 1)) reg arg.(0) | Ialloc n -> fprintf ppf "alloc %i" n | Iintop(op) -> fprintf ppf "%a%s%a" reg arg.(0) (intop op) reg arg.(1) | Iintop_imm(op, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intop op) n | Inegf -> fprintf ppf "-f %a" reg arg.(0) | Iabsf -> fprintf ppf "absf %a" reg arg.(0) | Iaddf -> fprintf ppf "%a +f %a" reg arg.(0) reg arg.(1) | Isubf -> fprintf ppf "%a -f %a" reg arg.(0) reg arg.(1) | Imulf -> fprintf ppf "%a *f %a" reg arg.(0) reg arg.(1) | Idivf -> fprintf ppf "%a /f %a" reg arg.(0) reg arg.(1) | Ifloatofint -> fprintf ppf "floatofint %a" reg arg.(0) | Iintoffloat -> fprintf ppf "intoffloat %a" reg arg.(0) | Ispecific op -> Arch.print_specific_operation reg op ppf arg let rec instr ppf i = if !print_live then begin fprintf ppf "@[<1>{%a" regsetaddr i.live; if Array.length i.arg > 0 then fprintf ppf "@ +@ %a" regs i.arg; fprintf ppf "}@]@,"; end; begin match i.desc with | Iend -> () | Iop op -> operation op i.arg ppf i.res | Ireturn -> fprintf ppf "return %a" regs i.arg | Iifthenelse(tst, ifso, ifnot) -> fprintf ppf "@[if %a then@,%a" (test tst) i.arg instr ifso; begin match ifnot.desc with | Iend -> () | _ -> fprintf ppf "@;<0 -2>else@,%a" instr ifnot end; fprintf ppf "@;<0 -2>endif@]" | Iswitch(index, cases) -> fprintf ppf "switch %a" reg i.arg.(0); for i = 0 to Array.length cases - 1 do fprintf ppf "@,@[@["; for j = 0 to Array.length index - 1 do if index.(j) = i then fprintf ppf "case %i:@," j done; fprintf ppf "@]@,%a@]" instr cases.(i) done; fprintf ppf "@,endswitch" | Iloop(body) -> fprintf ppf "@[loop@,%a@;<0 -2>endloop@]" instr body | Icatch(i, body, handler) -> fprintf ppf "@[catch@,%a@;<0 -2>with(%d)@,%a@;<0 -2>endcatch@]" instr body i instr handler | Iexit i -> fprintf ppf "exit(%d)" i | Itrywith(body, handler) -> fprintf ppf "@[try@,%a@;<0 -2>with@,%a@;<0 -2>endtry@]" instr body instr handler | Iraise -> fprintf ppf "raise %a" reg i.arg.(0) end; if not (Debuginfo.is_none i.dbg) then fprintf ppf "%s" (Debuginfo.to_string i.dbg); begin match i.next.desc with Iend -> () | _ -> fprintf ppf "@,%a" instr i.next end let fundecl ppf f = let dbg = if Debuginfo.is_none f.fun_dbg then "" else " " ^ Debuginfo.to_string f.fun_dbg in fprintf ppf "@[%s(%a)%s@,%a@]" f.fun_name regs f.fun_args dbg instr f.fun_body let phase msg ppf f = fprintf ppf "*** %s@.%a@." msg fundecl f let interference ppf r = let interf ppf = List.iter (fun r -> fprintf ppf "@ %a" reg r) r.interf in fprintf ppf "@[<2>%a:%t@]@." reg r interf let interferences ppf () = fprintf ppf "*** Interferences@."; List.iter (interference ppf) (Reg.all_registers()) let preference ppf r = let prefs ppf = List.iter (fun (r, w) -> fprintf ppf "@ %a weight %i" reg r w) r.prefer in fprintf ppf "@[<2>%a: %t@]@." reg r prefs let preferences ppf () = fprintf ppf "*** Preferences@."; List.iter (preference ppf) (Reg.all_registers()) mingw-ocaml/ocaml/asmcomp/compilenv.mli0000644000175000017500000000703112124403240017614 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Compilation environments for compilation units *) open Clambda open Cmx_format val reset: ?packname:string -> string -> unit (* Reset the environment and record the name of the unit being compiled (arg). Optional argument is [-for-pack] prefix. *) val current_unit_infos: unit -> unit_infos (* Return the infos for the unit being compiled *) val current_unit_name: unit -> string (* Return the name of the unit being compiled *) val make_symbol: ?unitname:string -> string option -> string (* [make_symbol ~unitname:u None] returns the asm symbol that corresponds to the compilation unit [u] (default: the current unit). [make_symbol ~unitname:u (Some id)] returns the asm symbol that corresponds to symbol [id] in the compilation unit [u] (or the current unit). *) val symbol_for_global: Ident.t -> string (* Return the asm symbol that refers to the given global identifier *) val global_approx: Ident.t -> Clambda.value_approximation (* Return the approximation for the given global identifier *) val set_global_approx: Clambda.value_approximation -> unit (* Record the approximation of the unit being compiled *) val record_global_approx_toplevel: unit -> unit (* Record the current approximation for the current toplevel phrase *) val need_curry_fun: int -> unit val need_apply_fun: int -> unit val need_send_fun: int -> unit (* Record the need of a currying (resp. application, message sending) function with the given arity *) val new_const_symbol : unit -> string val new_const_label : unit -> int val new_structured_constant : Lambda.structured_constant -> bool -> string val structured_constants : unit -> (string * bool * Lambda.structured_constant) list val read_unit_info: string -> unit_infos * Digest.t (* Read infos and MD5 from a [.cmx] file. *) val write_unit_info: unit_infos -> string -> unit (* Save the given infos in the given file *) val save_unit_info: string -> unit (* Save the infos for the current unit in the given file *) val cache_unit_info: unit_infos -> unit (* Enter the given infos in the cache. The infos will be honored by [symbol_for_global] and [global_approx] without looking at the corresponding .cmx file. *) val cmx_not_found_crc: Digest.t (* Special digest used in the [ui_imports_cmx] list to signal that no [.cmx] file was found and used for the imported unit *) val read_library_info: string -> library_infos type error = Not_a_unit_info of string | Corrupted_unit_info of string | Illegal_renaming of string * string exception Error of error val report_error: Format.formatter -> error -> unit mingw-ocaml/ocaml/asmcomp/sparc/0000755000175000017500000000000012124403240016224 5ustar tootstootsmingw-ocaml/ocaml/asmcomp/sparc/scheduling.ml0000644000175000017500000000425712124403240020713 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Cmm open Mach (* Instruction scheduling for the Sparc *) class scheduler = object inherit Schedgen.scheduler_generic (* Latencies (in cycles). *) (* UltraSPARC issues two integer operations, plus a single load or store, per cycle. At most one of the integer instructions may be a shift. Most integer operations have one cycle latency. Unsigned loads take two cycles. Signed loads take three cycles. Conditional moves have two cycle latency and may not issue in the same cycle as any other instruction. Floating point issue rules are complicated, but in general independent add and multiply can dual issue with four cycle latency. *) method oper_latency = function Ireload -> 2 | Iload((Byte_signed|Sixteen_signed|Thirtytwo_signed), _) -> 3 | Iload(_, _) -> 2 | Iconst_float _ -> 2 (* turned into a load *) | Inegf | Iabsf | Iaddf | Isubf | Imulf -> 4 | Idivf -> 15 | _ -> 1 (* Issue cycles. Rough approximations. *) method oper_issue_cycles = function Iconst_float _ -> 2 | Iconst_symbol _ -> 2 | Ialloc _ -> 6 | Iintop(Icomp _) -> 4 | Iintop(Icheckbound) -> 2 | Iintop_imm(Idiv, _) -> 5 | Iintop_imm(Imod, _) -> 5 | Iintop_imm(Icomp _, _) -> 4 | Iintop_imm(Icheckbound, _) -> 2 | Inegf -> 2 | Iabsf -> 2 | Ifloatofint -> 6 | Iintoffloat -> 6 | _ -> 1 end let fundecl f = (new scheduler)#schedule_fundecl f mingw-ocaml/ocaml/asmcomp/sparc/arch.ml0000644000175000017500000000506712124403240017503 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Specific operations for the Sparc processor *) open Misc open Format (* SPARC V8 adds multiply and divide. SPARC V9 adds double precision float operations, conditional move, and more instructions that are only useful in 64 bit mode. Sun calls 32 bit V9 "V8+". *) type arch_version = SPARC_V7 | SPARC_V8 | SPARC_V9 let arch_version = ref SPARC_V7 let command_line_options = [ "-march=v8", Arg.Unit (fun () -> arch_version := SPARC_V8), " Generate code for SPARC V8 processors"; "-march=v9", Arg.Unit (fun () -> arch_version := SPARC_V9), " Generate code for SPARC V9 processors" ] type specific_operation = unit (* None worth mentioning *) (* Addressing modes *) type addressing_mode = Ibased of string * int (* symbol + displ *) | Iindexed of int (* reg + displ *) (* Sizes, endianness *) let big_endian = true let size_addr = 4 let size_int = 4 let size_float = 8 (* Behavior of division *) let division_crashes_on_overflow = false (* Operations on addressing modes *) let identity_addressing = Iindexed 0 let offset_addressing addr delta = match addr with Ibased(s, n) -> Ibased(s, n + delta) | Iindexed n -> Iindexed(n + delta) let num_args_addressing = function Ibased(s, n) -> 0 | Iindexed n -> 1 (* Printing operations and addressing modes *) let print_addressing printreg addr ppf arg = match addr with | Ibased(s, n) -> let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in fprintf ppf "\"%s\"%s" s idx | Iindexed n -> let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in fprintf ppf "%a%s" printreg arg.(0) idx let print_specific_operation printreg op ppf arg = Misc.fatal_error "Arch_sparc.print_specific_operation" mingw-ocaml/ocaml/asmcomp/sparc/proc.ml0000644000175000017500000001520412124403240017523 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Description of the Sparc processor *) open Misc open Cmm open Reg open Arch open Mach (* Instruction selection *) let word_addressed = false (* Registers available for register allocation *) (* Register map: %o0 - %o5 0 - 5 function results, C functions args / res %i0 - %i5 6 - 11 function arguments, preserved by C %l0 - %l4 12 - 16 general purpose, preserved by C %g3 - %g4 17 - 18 general purpose, not preserved by C %l5 exception pointer %l6 allocation pointer %l7 address of allocation limit %g0 always zero %g1 - %g2 temporaries %g5 - %g7 reserved for system libraries %f0 - %f10 100 - 105 function arguments and results %f12 - %f28 106 - 114 general purpose %f30 temporary *) let int_reg_name = [| (* 0-5 *) "%o0"; "%o1"; "%o2"; "%o3"; "%o4"; "%o5"; (* 6-11 *) "%i0"; "%i1"; "%i2"; "%i3"; "%i4"; "%i5"; (* 12-16 *) "%l0"; "%l1"; "%l2"; "%l3"; "%l4"; (* 17-18 *) "%g3"; "%g4" |] let float_reg_name = [| (* 100-105 *) "%f0"; "%f2"; "%f4"; "%f6"; "%f8"; "%f10"; (* 106-109 *) "%f12"; "%f14"; "%f16"; "%f18"; (* 110-114 *) "%f20"; "%f22"; "%f24"; "%f26"; "%f28"; (* 115 *) "%f30"; (* Odd parts of register pairs *) (* 116-121 *) "%f1"; "%f3"; "%f5"; "%f7"; "%f9"; "%f11"; (* 122-125 *) "%f13"; "%f15"; "%f17"; "%f19"; (* 126-130 *) "%f21"; "%f23"; "%f25"; "%f27"; "%f29"; (* 131 *) "%f31" |] let num_register_classes = 2 let register_class r = match r.typ with Int -> 0 | Addr -> 0 | Float -> 1 let num_available_registers = [| 19; 15 |] let first_available_register = [| 0; 100 |] let register_name r = if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) let rotate_registers = true (* Representation of hard registers by pseudo-registers *) let hard_int_reg = let v = Array.create 19 Reg.dummy in for i = 0 to 18 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = let v = Array.create 32 Reg.dummy in for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v let all_phys_regs = Array.append hard_int_reg (Array.sub hard_float_reg 0 15) (* No need to include the odd parts of float register pairs, nor the temporary register %f30 *) let phys_reg n = if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) let stack_slot slot ty = Reg.at_location ty (Stack slot) (* Calling conventions *) let calling_conventions first_int last_int first_float last_float make_stack arg = let loc = Array.create (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in for i = 0 to Array.length arg - 1 do match arg.(i).typ with Int | Addr as ty -> if !int <= last_int then begin loc.(i) <- phys_reg !int; incr int end else begin loc.(i) <- stack_slot (make_stack !ofs) ty; ofs := !ofs + size_int end | Float -> if !float <= last_float then begin loc.(i) <- phys_reg !float; incr float end else begin loc.(i) <- stack_slot (make_stack !ofs) Float; ofs := !ofs + size_float end done; (loc, Misc.align !ofs 8) (* Keep stack 8-aligned *) let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs let not_supported ofs = fatal_error "Proc.loc_results: cannot call" let loc_arguments arg = calling_conventions 6 15 100 105 outgoing arg let loc_parameters arg = let (loc, ofs) = calling_conventions 6 15 100 105 incoming arg in loc let loc_results res = let (loc, ofs) = calling_conventions 0 5 100 105 not_supported res in loc (* On the Sparc, all arguments to C functions, even floating-point arguments, are passed in %o0..%o5, then on the stack *) let loc_external_arguments arg = let loc = ref [] in let reg = ref 0 (* %o0 *) in let ofs = ref (-4) in (* start at sp + 92 = sp + 96 - 4 *) for i = 0 to Array.length arg - 1 do if !reg <= 5 (* %o5 *) then begin match arg.(i).typ with Int | Addr -> loc := phys_reg !reg :: !loc; incr reg | Float -> if !reg = 5 then fatal_error "Proc_sparc: cannot call"; loc := phys_reg (!reg + 1) :: phys_reg !reg :: !loc; reg := !reg + 2 end else begin loc := stack_slot (outgoing !ofs) arg.(i).typ :: !loc; ofs := !ofs + size_component arg.(i).typ end done; (* Keep stack 8-aligned *) (Array.of_list(List.rev !loc), Misc.align (!ofs + 4) 8) let loc_external_results res = let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc let loc_exn_bucket = phys_reg 0 (* $o0 *) (* Registers destroyed by operations *) let destroyed_at_c_call = (* %l0-%l4, %i0-%i5 preserved *) Array.of_list(List.map phys_reg [0; 1; 2; 3; 4; 5; 17; 18; 100; 101; 102; 103; 104; 105; 106; 107; 108; 109; 110; 111; 112; 113; 114]) let destroyed_at_oper = function Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs | Iop(Iextcall(_, false)) -> destroyed_at_c_call | _ -> [||] let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function Iextcall(_, _) -> 0 | _ -> 15 let max_register_pressure = function Iextcall(_, _) -> [| 11; 0 |] | _ -> [| 19; 15 |] (* Layout of the stack *) let num_stack_slots = [| 0; 0 |] let contains_calls = ref false (* Calling the assembler and the archiver *) let assemble_file infile outfile = let asflags = begin match !arch_version with SPARC_V7 -> " -o " | SPARC_V8 -> " -xarch=v8 -o " | SPARC_V9 -> " -xarch=v8plus -o " end in Ccomp.command (Config.asm ^ asflags ^ Filename.quote outfile ^ " " ^ Filename.quote infile) mingw-ocaml/ocaml/asmcomp/sparc/reload.ml0000644000175000017500000000162512124403240020030 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Reloading for the Sparc *) let fundecl f = (new Reloadgen.reload_generic)#fundecl f mingw-ocaml/ocaml/asmcomp/sparc/selection.ml0000644000175000017500000000617512124403240020554 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Instruction selection for the Sparc processor *) open Misc open Cmm open Reg open Arch open Mach class selector = object (self) inherit Selectgen.selector_generic as super method is_immediate n = (n <= 4095) && (n >= -4096) method select_addressing chunk = function Cconst_symbol s -> (Ibased(s, 0), Ctuple []) | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) -> (Ibased(s, n), Ctuple []) | Cop(Cadda, [arg; Cconst_int n]) -> (Iindexed n, arg) | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) -> (Iindexed n, Cop(Cadda, [arg1; arg2])) | arg -> (Iindexed 0, arg) method! select_operation op args = match (op, args) with (* For SPARC V7 multiplication, division and modulus are turned into calls to C library routines, except if the dividend is a power of 2. For SPARC V8 and V9, use hardware multiplication and division, but C library routine for modulus. *) (Cmuli, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> (Iintop_imm(Ilsl, Misc.log2 n), [arg]) | (Cmuli, [Cconst_int n; arg]) when n = 1 lsl (Misc.log2 n) -> (Iintop_imm(Ilsl, Misc.log2 n), [arg]) | (Cmuli, _) when !arch_version = SPARC_V7 -> (Iextcall(".umul", false), args) | (Cdivi, [arg; Cconst_int n]) when self#is_immediate n && n = 1 lsl (Misc.log2 n) -> (Iintop_imm(Idiv, n), [arg]) | (Cdivi, _) when !arch_version = SPARC_V7 -> (Iextcall(".div", false), args) | (Cmodi, [arg; Cconst_int n]) when self#is_immediate n && n = 1 lsl (Misc.log2 n) -> (Iintop_imm(Imod, n), [arg]) | (Cmodi, _) -> (Iextcall(".rem", false), args) | _ -> super#select_operation op args (* Override insert_move_args to deal correctly with floating-point arguments being passed into pairs of integer registers. *) method! insert_move_args arg loc stacksize = if stacksize <> 0 then self#insert (Iop(Istackoffset stacksize)) [||] [||]; let locpos = ref 0 in for i = 0 to Array.length arg - 1 do let src = arg.(i) in let dst = loc.(!locpos) in match (src, dst) with ({typ = Float}, {typ = Int}) -> let dst2 = loc.(!locpos + 1) in self#insert (Iop Imove) [|src|] [|dst; dst2|]; locpos := !locpos + 2 | (_, _) -> self#insert_move src dst; incr locpos done end let fundecl f = (new selector)#emit_fundecl f mingw-ocaml/ocaml/asmcomp/sparc/emit.mlp0000644000175000017500000006443212124403240017705 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Emission of Sparc assembly code *) open Location open Misc open Cmm open Arch open Proc open Reg open Mach open Linearize open Emitaux (* Solaris vs. the other ports *) let solaris = Config.system = "solaris" (* Tradeoff between code size and code speed *) let fastcode_flag = ref true (* Layout of the stack *) (* Always keep the stack 8-aligned. Always leave 96 bytes at the bottom of the stack *) let stack_offset = ref 0 let frame_size () = let size = !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + (if !contains_calls then 4 else 0) in Misc.align size 8 let slot_offset loc cl = match loc with Incoming n -> frame_size() + n + 96 | Local n -> if cl = 0 then !stack_offset + num_stack_slots.(1) * 8 + n * 4 + 96 else !stack_offset + n * 8 + 96 | Outgoing n -> n + 96 (* Return the other register in a register pair *) let next_in_pair = function {loc = Reg r; typ = (Int | Addr)} -> phys_reg (r + 1) | {loc = Reg r; typ = Float} -> phys_reg (r + 16) | _ -> fatal_error "Emit.next_in_pair" (* Symbols are prefixed with _ under SunOS *) let symbol_prefix = if Config.system = "sunos" then "_" else "" let emit_symbol s = if String.length s >= 1 & s.[0] = '.' then emit_string s else begin emit_string symbol_prefix; Emitaux.emit_symbol '$' s end let emit_size lbl = if Config.system = "solaris" then ` .size {emit_symbol lbl},.-{emit_symbol lbl}\n` let rodata () = if Config.system = "solaris" (* || Config.system = "linux" *) (* || Config.system = "gnu" *) then ` .section \".rodata\"\n` else ` .data\n` (* Check if an integer or native integer is an immediate operand *) let is_immediate n = n <= 4095 && n >= -4096 let is_native_immediate n = n <= Nativeint.of_int 4095 && n >= Nativeint.of_int (-4096) (* Output a label *) let label_prefix = if Config.system = "sunos" then "L" else ".L" let emit_label lbl = emit_string label_prefix; emit_int lbl let emit_data_label lbl = emit_string label_prefix; emit_string "d"; emit_int lbl (* Output a pseudo-register *) let emit_reg r = match r.loc with Reg r -> emit_string (register_name r) | _ -> fatal_error "Emit.emit_reg" (* Output a stack reference *) let emit_stack r = match r.loc with Stack s -> let ofs = slot_offset s (register_class r) in `[%sp + {emit_int ofs}]` | _ -> fatal_error "Emit.emit_stack" (* Output a load *) let emit_load instr addr arg dst = match addr with Ibased(s, 0) -> ` sethi %hi({emit_symbol s}), %g1\n`; ` {emit_string instr} [%g1 + %lo({emit_symbol s})], {emit_reg dst}\n` | Ibased(s, ofs) -> ` sethi %hi({emit_symbol s} + {emit_int ofs}), %g1\n`; ` {emit_string instr} [%g1 + %lo({emit_symbol s} + {emit_int ofs})], {emit_reg dst}\n` | Iindexed ofs -> if is_immediate ofs then ` {emit_string instr} [{emit_reg arg.(0)} + {emit_int ofs}], {emit_reg dst}\n` else begin ` sethi %hi({emit_int ofs}), %g1\n`; ` or %g1, %lo({emit_int ofs}), %g1\n`; ` {emit_string instr} [{emit_reg arg.(0)} + %g1], {emit_reg dst}\n` end (* Output a store *) let emit_store instr addr arg src = match addr with Ibased(s, 0) -> ` sethi %hi({emit_symbol s}), %g1\n`; ` {emit_string instr} {emit_reg src}, [%g1 + %lo({emit_symbol s})]\n` | Ibased(s, ofs) -> ` sethi %hi({emit_symbol s} + {emit_int ofs}), %g1\n`; ` {emit_string instr} {emit_reg src}, [%g1 + %lo({emit_symbol s} + {emit_int ofs})]\n` | Iindexed ofs -> if is_immediate ofs then ` {emit_string instr} {emit_reg src}, [{emit_reg arg.(1)} + {emit_int ofs}]\n` else begin ` sethi %hi({emit_int ofs}), %g1\n`; ` or %g1, %lo({emit_int ofs}), %g1\n`; ` {emit_string instr} {emit_reg src}, [{emit_reg arg.(1)} + %g1]\n` end (* Record live pointers at call points *) type frame_descr = { fd_lbl: int; (* Return address *) fd_frame_size: int; (* Size of stack frame *) fd_live_offset: int list } (* Offsets/regs of live addresses *) let frame_descriptors = ref([] : frame_descr list) let record_frame live = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter (function {typ = Addr; loc = Reg r} -> live_offset := ((r lsl 1) + 1) :: !live_offset | {typ = Addr; loc = Stack s} as reg -> live_offset := slot_offset s (register_class reg) :: !live_offset | _ -> ()) live; frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); fd_live_offset = !live_offset } :: !frame_descriptors; `{emit_label lbl}:` let emit_frame fd = ` .word {emit_label fd.fd_lbl}\n`; ` .half {emit_int fd.fd_frame_size}\n`; ` .half {emit_int (List.length fd.fd_live_offset)}\n`; List.iter (fun n -> ` .half {emit_int n}\n`) fd.fd_live_offset; ` .align 4\n` (* Record floating-point constants *) let float_constants = ref ([] : (int * string) list) let emit_float_constant (lbl, cst) = rodata (); ` .align 8\n`; `{emit_label lbl}:`; emit_float64_split_directive ".word" cst (* Emission of the profiling prelude *) let emit_profile () = begin match Config.system with "solaris" -> let lbl = new_label() in ` .section \".bss\"\n`; `{emit_label lbl}: .skip 4\n`; ` .text\n`; ` save %sp,-96,%sp\n`; ` sethi %hi({emit_label lbl}),%o0\n`; ` call _mcount\n`; ` or %o0,%lo({emit_label lbl}),%o0\n`; ` restore\n` | _ -> () end (* Names of various instructions *) let name_for_int_operation = function Iadd -> "add" | Isub -> "sub" | Iand -> "and" | Ior -> "or" | Ixor -> "xor" | Ilsl -> "sll" | Ilsr -> "srl" | Iasr -> "sra" | Imul -> "smul" | _ -> Misc.fatal_error "Emit.name_for_int_operation" let name_for_float_operation = function Inegf -> if !arch_version = SPARC_V9 then "fnegd" else "fnegs" | Iabsf -> if !arch_version = SPARC_V9 then "fabsd" else "fabss" | Iaddf -> "faddd" | Isubf -> "fsubd" | Imulf -> "fmuld" | Idivf -> "fdivd" | _ -> Misc.fatal_error "Emit.name_for_float_operation" let name_for_int_movcc = function Isigned Ceq -> "e" | Isigned Cne -> "ne" | Isigned Cle -> "le" | Isigned Cgt -> "g" | Isigned Clt -> "l" | Isigned Cge -> "ge" | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "leu" | Iunsigned Cgt -> "gu" | Iunsigned Clt -> "lu" | Iunsigned Cge -> "geu" let name_for_int_comparison = function Isigned Ceq -> "be" | Isigned Cne -> "bne" | Isigned Cle -> "ble" | Isigned Cgt -> "bg" | Isigned Clt -> "bl" | Isigned Cge -> "bge" | Iunsigned Ceq -> "be" | Iunsigned Cne -> "bne" | Iunsigned Cle -> "bleu" | Iunsigned Cgt -> "bgu" | Iunsigned Clt -> "blu" | Iunsigned Cge -> "bgeu" let name_for_float_comparison cmp neg = match cmp with Ceq -> if neg then "fbne" else "fbe" | Cne -> if neg then "fbe" else "fbne" | Cle -> if neg then "fbug" else "fble" | Cgt -> if neg then "fbule" else "fbg" | Clt -> if neg then "fbuge" else "fbl" | Cge -> if neg then "fbul" else "fbge" (* Output the assembly code for an instruction *) let function_name = ref "" let tailrec_entry_point = ref 0 let range_check_trap = ref 0 let rec emit_instr i dslot = match i.desc with Lend -> () | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in begin match (src, dst) with {loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} -> ` mov {emit_reg src}, {emit_reg dst}\n` | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> if !arch_version = SPARC_V9 then ` fmovd {emit_reg src}, {emit_reg dst}\n` else begin ` fmovs {emit_reg src}, {emit_reg dst}\n`; ` fmovs {emit_reg(next_in_pair src)}, {emit_reg(next_in_pair dst)}\n` end | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = (Int | Addr)} -> (* This happens when calling C functions and passing a float arg in %o0...%o5 *) ` sub %sp, 8, %sp\n`; ` std {emit_reg src}, [%sp + 96]\n`; ` ld [%sp + 96], {emit_reg dst}\n`; ` ld [%sp + 100], {emit_reg(next_in_pair dst)}\n`; ` add %sp, 8, %sp\n` | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} -> ` st {emit_reg src}, {emit_stack dst}\n` | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> ` std {emit_reg src}, {emit_stack dst}\n` | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} -> ` ld {emit_stack src}, {emit_reg dst}\n` | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> ` ldd {emit_stack src}, {emit_reg dst}\n` | (_, _) -> fatal_error "Emit: Imove" end | Lop(Iconst_int n) -> if is_native_immediate n then ` mov {emit_nativeint n}, {emit_reg i.res.(0)}\n` else begin ` sethi %hi({emit_nativeint n}), %g1\n`; ` or %g1, %lo({emit_nativeint n}), {emit_reg i.res.(0)}\n` end | Lop(Iconst_float s) -> (* On UltraSPARC, the fzero instruction could be used to set a floating point register pair to zero. *) let lbl = new_label() in float_constants := (lbl, s) :: !float_constants; ` sethi %hi({emit_label lbl}), %g1\n`; ` ldd [%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n` | Lop(Iconst_symbol s) -> ` sethi %hi({emit_symbol s}), %g1\n`; ` or %g1, %lo({emit_symbol s}), {emit_reg i.res.(0)}\n` | Lop(Icall_ind) -> `{record_frame i.live} call {emit_reg i.arg.(0)}\n`; fill_delay_slot dslot | Lop(Icall_imm s) -> `{record_frame i.live} call {emit_symbol s}\n`; fill_delay_slot dslot | Lop(Itailcall_ind) -> let n = frame_size() in if !contains_calls then ` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n`; ` jmp {emit_reg i.arg.(0)}\n`; ` add %sp, {emit_int n}, %sp\n` (* in delay slot *) | Lop(Itailcall_imm s) -> let n = frame_size() in if s = !function_name then begin ` b {emit_label !tailrec_entry_point}\n`; fill_delay_slot dslot end else begin if !contains_calls then ` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n`; ` sethi %hi({emit_symbol s}), %g1\n`; ` jmp %g1 + %lo({emit_symbol s})\n`; ` add %sp, {emit_int n}, %sp\n` (* in delay slot *) end | Lop(Iextcall(s, alloc)) -> if alloc then begin ` sethi %hi({emit_symbol s}), %g2\n`; `{record_frame i.live} call {emit_symbol "caml_c_call"}\n`; ` or %g2, %lo({emit_symbol s}), %g2\n` (* in delay slot *) end else begin ` call {emit_symbol s}\n`; fill_delay_slot dslot end | Lop(Istackoffset n) -> ` add %sp, {emit_int (-n)}, %sp\n`; stack_offset := !stack_offset + n | Lop(Iload(chunk, addr)) -> let dest = i.res.(0) in begin match chunk with Double_u -> emit_load "ld" addr i.arg dest; emit_load "ld" (offset_addressing addr 4) i.arg (next_in_pair dest) | Single -> emit_load "ld" addr i.arg dest; ` fstod {emit_reg dest}, {emit_reg dest}\n` | _ -> let loadinstr = match chunk with Byte_unsigned -> "ldub" | Byte_signed -> "ldsb" | Sixteen_unsigned -> "lduh" | Sixteen_signed -> "ldsh" | Double -> "ldd" | _ -> "ld" in emit_load loadinstr addr i.arg dest end | Lop(Istore(chunk, addr)) -> let src = i.arg.(0) in begin match chunk with Double_u -> emit_store "st" addr i.arg src; emit_store "st" (offset_addressing addr 4) i.arg (next_in_pair src) | Single -> ` fdtos {emit_reg src}, %f30\n`; emit_store "st" addr i.arg (phys_reg 115) (* %f30 *) | _ -> let storeinstr = match chunk with | Byte_unsigned | Byte_signed -> "stb" | Sixteen_unsigned | Sixteen_signed -> "sth" | Double -> "std" | _ -> "st" in emit_store storeinstr addr i.arg src end | Lop(Ialloc n) -> if !fastcode_flag then begin let lbl_cont = new_label() in if solaris then begin ` sub %l6, {emit_int n}, %l6\n`; ` cmp %l6, %l7\n` end else begin ` ld [%l7], %g1\n`; ` sub %l6, {emit_int n}, %l6\n`; ` cmp %l6, %g1\n` end; ` bgeu {emit_label lbl_cont}\n`; ` add %l6, 4, {emit_reg i.res.(0)}\n`; (* in delay slot *) `{record_frame i.live} call {emit_symbol "caml_call_gc"}\n`; ` mov {emit_int n}, %g2\n`; (* in delay slot *) ` add %l6, 4, {emit_reg i.res.(0)}\n`; `{emit_label lbl_cont}:\n` end else begin `{record_frame i.live} call {emit_symbol "caml_allocN"}\n`; ` mov {emit_int n}, %g2\n`; (* in delay slot *) ` add %l6, 4, {emit_reg i.res.(0)}\n` end | Lop(Iintop(Icomp cmp)) -> ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; if !arch_version = SPARC_V9 then begin let comp = name_for_int_movcc cmp in ` mov 0, {emit_reg i.res.(0)}\n`; ` mov{emit_string comp} %icc, 1, {emit_reg i.res.(0)}\n` end else begin let comp = name_for_int_comparison cmp and lbl = new_label() in ` {emit_string comp},a {emit_label lbl}\n`; ` mov 1, {emit_reg i.res.(0)}\n`; ` mov 0, {emit_reg i.res.(0)}\n`; `{emit_label lbl}:\n` end | Lop(Iintop Icheckbound) -> ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; if solaris then ` tleu 5\n` (* 5 = ST_RANGE_CHECK *) else begin if !range_check_trap = 0 then range_check_trap := new_label(); ` bleu {emit_label !range_check_trap}\n`; ` nop\n` (* delay slot *) end | Lop(Iintop Idiv) -> ` sra {emit_reg i.arg.(0)}, 31, %g1\n`; ` wr %g1, %y\n`; ` sdiv {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` | Lop(Iintop op) -> let instr = name_for_int_operation op in ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Ilsl, 1)) -> (* UltraSPARC has two add units but only one shifter. *) ` add {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Idiv, n)) -> let l = Misc.log2 n in if n = 1 lsl l then begin let lbl = new_label() in ` cmp {emit_reg i.arg.(0)}, 0\n`; ` bge {emit_label lbl}\n`; ` mov {emit_reg i.arg.(0)}, %g1\n`; (* in delay slot *) ` add %g1, {emit_int (n-1)}, %g1\n`; `{emit_label lbl}:\n`; ` sra %g1, {emit_int l}, {emit_reg i.res.(0)}\n` end else begin ` sra {emit_reg i.arg.(0)}, 31, %g1\n`; ` wr %g1, %y\n`; ` sdiv {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n` end | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *) let lbl = new_label() in ` tst {emit_reg i.arg.(0)}\n`; ` bge {emit_label lbl}\n`; ` andcc {emit_reg i.arg.(0)}, {emit_int (n-1)}, {emit_reg i.res.(0)}\n`; (* in delay slot *) ` be {emit_label lbl}\n`; ` nop\n`; ` sub {emit_reg i.res.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`; `{emit_label lbl}:\n` | Lop(Iintop_imm(Icomp cmp, n)) -> ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; if !arch_version = SPARC_V9 then begin let comp = name_for_int_movcc cmp in ` mov 0, {emit_reg i.res.(0)}\n`; ` mov{emit_string comp} %icc, 1, {emit_reg i.res.(0)}\n` end else begin let comp = name_for_int_comparison cmp and lbl = new_label() in ` {emit_string comp},a {emit_label lbl}\n`; ` mov 1, {emit_reg i.res.(0)}\n`; ` mov 0, {emit_reg i.res.(0)}\n`; `{emit_label lbl}:\n` end | Lop(Iintop_imm(Icheckbound, n)) -> ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; if solaris then ` tleu 5\n` (* 5 = ST_RANGE_CHECK *) else begin if !range_check_trap = 0 then range_check_trap := new_label(); ` bleu {emit_label !range_check_trap}\n`; ` nop\n` (* delay slot *) end | Lop(Iintop_imm(op, n)) -> let instr = name_for_int_operation op in ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n` | Lop(Inegf | Iabsf as op) -> let instr = name_for_float_operation op in ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`; if !arch_version <> SPARC_V9 then ` fmovs {emit_reg(next_in_pair i.arg.(0))}, {emit_reg(next_in_pair i.res.(0))}\n` | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> let instr = name_for_float_operation op in ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` | Lop(Ifloatofint) -> ` sub %sp, 8, %sp\n`; ` st {emit_reg i.arg.(0)}, [%sp + 96]\n`; ` ld [%sp + 96], %f30\n`; ` add %sp, 8, %sp\n`; ` fitod %f30, {emit_reg i.res.(0)}\n` | Lop(Iintoffloat) -> ` fdtoi {emit_reg i.arg.(0)}, %f30\n`; ` sub %sp, 8, %sp\n`; ` st %f30, [%sp + 96]\n`; ` ld [%sp + 96], {emit_reg i.res.(0)}\n`; ` add %sp, 8, %sp\n` | Lop(Ispecific sop) -> assert false | Lreloadretaddr -> let n = frame_size() in ` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n` | Lreturn -> let n = frame_size() in ` retl\n`; if n = 0 then ` nop\n` else ` add %sp, {emit_int n}, %sp\n` | Llabel lbl -> `{emit_label lbl}:\n` | Lbranch lbl -> ` b {emit_label lbl}\n`; fill_delay_slot dslot | Lcondbranch(tst, lbl) -> begin match tst with Itruetest -> ` tst {emit_reg i.arg.(0)}\n`; ` bne {emit_label lbl}\n` | Ifalsetest -> ` tst {emit_reg i.arg.(0)}\n`; ` be {emit_label lbl}\n` | Iinttest cmp -> let comp = name_for_int_comparison cmp in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` {emit_string comp} {emit_label lbl}\n` | Iinttest_imm(cmp, n) -> let comp = name_for_int_comparison cmp in ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; ` {emit_string comp} {emit_label lbl}\n` | Ifloattest(cmp, neg) -> let comp = name_for_float_comparison cmp neg in ` fcmpd {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` nop\n`; ` {emit_string comp} {emit_label lbl}\n` | Ioddtest -> ` andcc {emit_reg i.arg.(0)}, 1, %g0\n`; ` bne {emit_label lbl}\n` | Ieventest -> ` andcc {emit_reg i.arg.(0)}, 1, %g0\n`; ` be {emit_label lbl}\n` end; fill_delay_slot dslot | Lcondbranch3(lbl0, lbl1, lbl2) -> ` cmp {emit_reg i.arg.(0)}, 1\n`; begin match lbl0 with None -> () | Some lbl -> ` bl {emit_label lbl}\n nop\n` end; begin match lbl1 with None -> () | Some lbl -> ` be {emit_label lbl}\n nop\n` end; begin match lbl2 with None -> () | Some lbl -> ` bg {emit_label lbl}\n nop\n` end | Lswitch jumptbl -> let lbl_jumptbl = new_label() in ` sethi %hi({emit_label lbl_jumptbl}), %g1\n`; ` or %g1, %lo({emit_label lbl_jumptbl}), %g1\n`; ` sll {emit_reg i.arg.(0)}, 2, %g2\n`; ` ld [%g1 + %g2], %g1\n`; ` jmp %g1\n`; (* poor scheduling *) ` nop\n`; `{emit_label lbl_jumptbl}:`; for i = 0 to Array.length jumptbl - 1 do ` .word {emit_label jumptbl.(i)}\n` done | Lsetuptrap lbl -> ` call {emit_label lbl}\n`; ` sub %sp, 8, %sp\n` (* in delay slot *) | Lpushtrap -> stack_offset := !stack_offset + 8; ` st %o7, [%sp + 96]\n`; ` st %l5, [%sp + 100]\n`; ` mov %sp, %l5\n` | Lpoptrap -> ` ld [%sp + 100], %l5\n`; ` add %sp, 8, %sp\n`; stack_offset := !stack_offset - 8 | Lraise -> ` ld [%l5 + 96], %g1\n`; ` mov %l5, %sp\n`; ` ld [%sp + 100], %l5\n`; ` jmp %g1 + 8\n`; ` add %sp, 8, %sp\n` and fill_delay_slot = function None -> ` nop\n` | Some i -> emit_instr i None (* Checks if a pseudo-instruction expands to exactly one machine instruction that does not branch. *) let is_one_instr_op = function Idiv | Imod | Icomp _ | Icheckbound -> false | _ -> true let is_one_instr i = match i.desc with Lop op -> begin match op with Imove | Ispill | Ireload -> i.arg.(0).typ <> Float && i.res.(0).typ <> Float | Iconst_int n -> is_native_immediate n | Istackoffset _ -> true | Iload(_, Iindexed n) -> i.res.(0).typ <> Float & is_immediate n | Istore(_, Iindexed n) -> i.arg.(0).typ <> Float & is_immediate n | Iintop(op) -> is_one_instr_op op | Iintop_imm(op, _) -> is_one_instr_op op | Iaddf | Isubf | Imulf | Idivf -> true | Iabsf | Inegf -> !arch_version = SPARC_V9 | _ -> false end | _ -> false let no_interference res arg = try for i = 0 to Array.length arg - 1 do for j = 0 to Array.length res - 1 do if arg.(i).loc = res.(j).loc then raise Exit done done; true with Exit -> false (* Emit a sequence of instructions, trying to fill delay slots for branches *) let rec emit_all i = match i with {desc = Lend} -> () | {next = {desc = Lop(Icall_imm _) | Lop(Iextcall(_, false)) | Lbranch _}} when is_one_instr i -> emit_instr i.next (Some i); emit_all i.next.next | {next = {desc = Lop(Itailcall_imm s)}} when s = !function_name & is_one_instr i -> emit_instr i.next (Some i); emit_all i.next.next | {next = {desc = Lop(Icall_ind)}} when is_one_instr i & no_interference i.res i.next.arg -> emit_instr i.next (Some i); emit_all i.next.next | {next = {desc = Lcondbranch(_, _)}} when is_one_instr i & no_interference i.res i.next.arg -> emit_instr i.next (Some i); emit_all i.next.next | _ -> emit_instr i None; emit_all i.next (* Emission of a function declaration *) let fundecl fundecl = function_name := fundecl.fun_name; fastcode_flag := fundecl.fun_fast; tailrec_entry_point := new_label(); range_check_trap := 0; stack_offset := 0; float_constants := []; ` .text\n`; ` .align 4\n`; ` .global {emit_symbol fundecl.fun_name}\n`; if Config.system = "solaris" then ` .type {emit_symbol fundecl.fun_name},#function\n`; `{emit_symbol fundecl.fun_name}:\n`; if !Clflags.gprofile then emit_profile(); let n = frame_size() in if n > 0 then ` sub %sp, {emit_int n}, %sp\n`; if !contains_calls then ` st %o7, [%sp + {emit_int(n - 4 + 96)}]\n`; `{emit_label !tailrec_entry_point}:\n`; emit_all fundecl.fun_body; if !range_check_trap > 0 then begin `{emit_label !range_check_trap}:\n`; ` call {emit_symbol "caml_ml_array_bound_error"}\n`; ` nop\n` end; emit_size fundecl.fun_name; List.iter emit_float_constant !float_constants (* Emission of data *) let emit_item = function Cglobal_symbol s -> ` .global {emit_symbol s}\n`; | Cdefine_symbol s -> `{emit_symbol s}:\n` | Cdefine_label lbl -> `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> ` .half {emit_int n}\n` | Cint32 n -> ` .word {emit_nativeint n}\n` | Cint n -> ` .word {emit_nativeint n}\n` | Csingle f -> emit_float32_directive ".word" f | Cdouble f -> emit_float64_split_directive ".word" f | Csymbol_address s -> ` .word {emit_symbol s}\n` | Clabel_address lbl -> ` .word {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s | Cskip n -> if n > 0 then ` .skip {emit_int n}\n` | Calign n -> ` .align {emit_int n}\n` let data l = ` .data\n`; List.iter emit_item l (* Beginning / end of an assembly file *) let begin_assembly() = let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ` .data\n`; ` .global {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin}:\n`; let lbl_begin = Compilenv.make_symbol (Some "code_begin") in ` .text\n`; ` .global {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin}:\n` let end_assembly() = ` .text\n`; let lbl_end = Compilenv.make_symbol (Some "code_end") in ` .global {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end}:\n`; ` .data\n`; let lbl_end = Compilenv.make_symbol (Some "data_end") in ` .global {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end}:\n`; ` .word 0\n`; let lbl = Compilenv.make_symbol (Some "frametable") in rodata (); ` .global {emit_symbol lbl}\n`; if Config.system = "solaris" then ` .type {emit_symbol lbl},#object\n`; `{emit_symbol lbl}:\n`; ` .word {emit_int (List.length !frame_descriptors)}\n`; List.iter emit_frame !frame_descriptors; emit_size lbl; frame_descriptors := [] mingw-ocaml/ocaml/asmcomp/compilenv.ml0000644000175000017500000001560012124403240017444 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Compilation environments for compilation units *) open Config open Misc open Clambda open Cmx_format type error = Not_a_unit_info of string | Corrupted_unit_info of string | Illegal_renaming of string * string exception Error of error let global_infos_table = (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t) let structured_constants = ref ([] : (string * bool * Lambda.structured_constant) list) let current_unit = { ui_name = ""; ui_symbol = ""; ui_defines = []; ui_imports_cmi = []; ui_imports_cmx = []; ui_approx = Value_unknown; ui_curry_fun = []; ui_apply_fun = []; ui_send_fun = []; ui_force_link = false } let symbolname_for_pack pack name = match pack with | None -> name | Some p -> let b = Buffer.create 64 in for i = 0 to String.length p - 1 do match p.[i] with | '.' -> Buffer.add_string b "__" | c -> Buffer.add_char b c done; Buffer.add_string b "__"; Buffer.add_string b name; Buffer.contents b let reset ?packname name = Hashtbl.clear global_infos_table; let symbol = symbolname_for_pack packname name in current_unit.ui_name <- name; current_unit.ui_symbol <- symbol; current_unit.ui_defines <- [symbol]; current_unit.ui_imports_cmi <- []; current_unit.ui_imports_cmx <- []; current_unit.ui_curry_fun <- []; current_unit.ui_apply_fun <- []; current_unit.ui_send_fun <- []; current_unit.ui_force_link <- false; structured_constants := [] let current_unit_infos () = current_unit let current_unit_name () = current_unit.ui_name let make_symbol ?(unitname = current_unit.ui_symbol) idopt = let prefix = "caml" ^ unitname in match idopt with | None -> prefix | Some id -> prefix ^ "__" ^ id let read_unit_info filename = let ic = open_in_bin filename in try let buffer = input_bytes ic (String.length cmx_magic_number) in if buffer <> cmx_magic_number then begin close_in ic; raise(Error(Not_a_unit_info filename)) end; let ui = (input_value ic : unit_infos) in let crc = Digest.input ic in close_in ic; (ui, crc) with End_of_file | Failure _ -> close_in ic; raise(Error(Corrupted_unit_info(filename))) let read_library_info filename = let ic = open_in_bin filename in let buffer = input_bytes ic (String.length cmxa_magic_number) in if buffer <> cmxa_magic_number then raise(Error(Not_a_unit_info filename)); let infos = (input_value ic : library_infos) in close_in ic; infos (* Read and cache info on global identifiers *) let cmx_not_found_crc = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" let get_global_info global_ident = let modname = Ident.name global_ident in if modname = current_unit.ui_name then Some current_unit else begin try Hashtbl.find global_infos_table modname with Not_found -> let (infos, crc) = try let filename = find_in_path_uncap !load_path (modname ^ ".cmx") in let (ui, crc) = read_unit_info filename in if ui.ui_name <> modname then raise(Error(Illegal_renaming(ui.ui_name, filename))); (Some ui, crc) with Not_found -> (None, cmx_not_found_crc) in current_unit.ui_imports_cmx <- (modname, crc) :: current_unit.ui_imports_cmx; Hashtbl.add global_infos_table modname infos; infos end let cache_unit_info ui = Hashtbl.add global_infos_table ui.ui_name (Some ui) (* Return the approximation of a global identifier *) let toplevel_approx = Hashtbl.create 16 let record_global_approx_toplevel id = Hashtbl.add toplevel_approx current_unit.ui_name current_unit.ui_approx let global_approx id = if Ident.is_predef_exn id then Value_unknown else try Hashtbl.find toplevel_approx (Ident.name id) with Not_found -> match get_global_info id with | None -> Value_unknown | Some ui -> ui.ui_approx (* Return the symbol used to refer to a global identifier *) let symbol_for_global id = if Ident.is_predef_exn id then "caml_exn_" ^ Ident.name id else begin match get_global_info id with | None -> make_symbol ~unitname:(Ident.name id) None | Some ui -> make_symbol ~unitname:ui.ui_symbol None end (* Register the approximation of the module being compiled *) let set_global_approx approx = current_unit.ui_approx <- approx (* Record that a currying function or application function is needed *) let need_curry_fun n = if not (List.mem n current_unit.ui_curry_fun) then current_unit.ui_curry_fun <- n :: current_unit.ui_curry_fun let need_apply_fun n = if not (List.mem n current_unit.ui_apply_fun) then current_unit.ui_apply_fun <- n :: current_unit.ui_apply_fun let need_send_fun n = if not (List.mem n current_unit.ui_send_fun) then current_unit.ui_send_fun <- n :: current_unit.ui_send_fun (* Write the description of the current unit *) let write_unit_info info filename = let oc = open_out_bin filename in output_string oc cmx_magic_number; output_value oc info; flush oc; let crc = Digest.file filename in Digest.output oc crc; close_out oc let save_unit_info filename = current_unit.ui_imports_cmi <- Env.imported_units(); write_unit_info current_unit filename let const_label = ref 0 let new_const_label () = incr const_label; !const_label let new_const_symbol () = incr const_label; make_symbol (Some (string_of_int !const_label)) let new_structured_constant cst global = let lbl = new_const_symbol() in structured_constants := (lbl, global, cst) :: !structured_constants; lbl let structured_constants () = !structured_constants (* Error report *) open Format let report_error ppf = function | Not_a_unit_info filename -> fprintf ppf "%a@ is not a compilation unit description." Location.print_filename filename | Corrupted_unit_info filename -> fprintf ppf "Corrupted compilation unit description@ %a" Location.print_filename filename | Illegal_renaming(modname, filename) -> fprintf ppf "%a@ contains the description for unit@ %s" Location.print_filename filename modname mingw-ocaml/ocaml/asmcomp/asmgen.ml0000644000175000017500000001125012124403240016717 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* From lambda to assembly code *) open Format open Config open Clflags open Misc open Cmm type error = Assembler_error of string exception Error of error let liveness ppf phrase = Liveness.fundecl ppf phrase; phrase let dump_if ppf flag message phrase = if !flag then Printmach.phase message ppf phrase let pass_dump_if ppf flag message phrase = dump_if ppf flag message phrase; phrase let pass_dump_linear_if ppf flag message phrase = if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase; phrase let rec regalloc ppf round fd = if round > 50 then fatal_error(fd.Mach.fun_name ^ ": function too complex, cannot complete register allocation"); dump_if ppf dump_live "Liveness analysis" fd; Interf.build_graph fd; if !dump_interf then Printmach.interferences ppf (); if !dump_prefer then Printmach.preferences ppf (); Coloring.allocate_registers(); dump_if ppf dump_regalloc "After register allocation" fd; let (newfd, redo_regalloc) = Reload.fundecl fd in dump_if ppf dump_reload "After insertion of reloading code" newfd; if redo_regalloc then begin Reg.reinit(); Liveness.fundecl ppf newfd; regalloc ppf (round + 1) newfd end else newfd let (++) x f = f x let compile_fundecl (ppf : formatter) fd_cmm = Reg.reset(); fd_cmm ++ Selection.fundecl ++ pass_dump_if ppf dump_selection "After instruction selection" ++ Comballoc.fundecl ++ pass_dump_if ppf dump_combine "After allocation combining" ++ liveness ppf ++ pass_dump_if ppf dump_live "Liveness analysis" ++ Spill.fundecl ++ liveness ppf ++ pass_dump_if ppf dump_spill "After spilling" ++ Split.fundecl ++ pass_dump_if ppf dump_split "After live range splitting" ++ liveness ppf ++ regalloc ppf 1 ++ Linearize.fundecl ++ pass_dump_linear_if ppf dump_linear "Linearized code" ++ Scheduling.fundecl ++ pass_dump_linear_if ppf dump_scheduling "After instruction scheduling" ++ Emit.fundecl let compile_phrase ppf p = if !dump_cmm then fprintf ppf "%a@." Printcmm.phrase p; match p with | Cfunction fd -> compile_fundecl ppf fd | Cdata dl -> Emit.data dl (* For the native toplevel: generates generic functions unless they are already available in the process *) let compile_genfuns ppf f = List.iter (function | (Cfunction {fun_name = name}) as ph when f name -> compile_phrase ppf ph | _ -> ()) (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()]) let compile_implementation ?toplevel prefixname ppf (size, lam) = let asmfile = if !keep_asm_file then prefixname ^ ext_asm else Filename.temp_file "camlasm" ext_asm in let oc = open_out asmfile in begin try Emitaux.output_channel := oc; Emit.begin_assembly(); Closure.intro size lam ++ Cmmgen.compunit size ++ List.iter (compile_phrase ppf) ++ (fun () -> ()); (match toplevel with None -> () | Some f -> compile_genfuns ppf f); (* We add explicit references to external primitive symbols. This is to ensure that the object files that define these symbols, when part of a C library, won't be discarded by the linker. This is important if a module that uses such a symbol is later dynlinked. *) compile_phrase ppf (Cmmgen.reference_symbols (List.filter (fun s -> s <> "" && s.[0] <> '%') (List.map Primitive.native_name !Translmod.primitive_declarations)) ); Emit.end_assembly(); close_out oc with x -> close_out oc; if !keep_asm_file then () else remove_file asmfile; raise x end; if Proc.assemble_file asmfile (prefixname ^ ext_obj) <> 0 then raise(Error(Assembler_error asmfile)); if !keep_asm_file then () else remove_file asmfile (* Error report *) let report_error ppf = function | Assembler_error file -> fprintf ppf "Assembler error, input left in file %a" Location.print_filename file mingw-ocaml/ocaml/asmcomp/split.mli0000644000175000017500000000165112124403240016755 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Renaming of registers at reload points to split live ranges. *) val fundecl: Mach.fundecl -> Mach.fundecl mingw-ocaml/ocaml/asmcomp/m68k/0000755000175000017500000000000012124403240015701 5ustar tootstootsmingw-ocaml/ocaml/asmcomp/m68k/.gitignore0000644000175000017500000000000012124403240017657 0ustar tootstootsmingw-ocaml/ocaml/asmcomp/coloring.ml0000644000175000017500000002376312124403240017275 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Register allocation by coloring of the interference graph *) open Reg (* Preallocation of spilled registers in the stack. *) let allocate_spilled reg = if reg.spill then begin let cl = Proc.register_class reg in let nslots = Proc.num_stack_slots.(cl) in let conflict = Array.create nslots false in List.iter (fun r -> match r.loc with Stack(Local n) -> if Proc.register_class r = cl then conflict.(n) <- true | _ -> ()) reg.interf; let slot = ref 0 in while !slot < nslots && conflict.(!slot) do incr slot done; reg.loc <- Stack(Local !slot); if !slot >= nslots then Proc.num_stack_slots.(cl) <- !slot + 1 end (* Compute the degree (= number of neighbours of the same type) of each register, and split them in two sets: unconstrained (degree < number of available registers) and constrained (degree >= number of available registers). Spilled registers are ignored in the process. *) let unconstrained = ref Reg.Set.empty let constrained = ref Reg.Set.empty let find_degree reg = if reg.spill then () else begin let cl = Proc.register_class reg in let avail_regs = Proc.num_available_registers.(cl) in if avail_regs = 0 then (* Don't bother computing the degree if there are no regs in this class *) unconstrained := Reg.Set.add reg !unconstrained else begin let deg = ref 0 in List.iter (fun r -> if not r.spill && Proc.register_class r = cl then incr deg) reg.interf; reg.degree <- !deg; if !deg >= avail_regs then constrained := Reg.Set.add reg !constrained else unconstrained := Reg.Set.add reg !unconstrained end end (* Remove a register from the interference graph *) let remove_reg reg = reg.degree <- 0; (* 0 means r is no longer part of the graph *) let cl = Proc.register_class reg in List.iter (fun r -> if Proc.register_class r = cl && r.degree > 0 then begin let olddeg = r.degree in r.degree <- olddeg - 1; if olddeg = Proc.num_available_registers.(cl) then begin (* r was constrained and becomes unconstrained *) constrained := Reg.Set.remove r !constrained; unconstrained := Reg.Set.add r !unconstrained end end) reg.interf (* Remove all registers one by one, unconstrained if possible, otherwise constrained with lowest spill cost. Return the list of registers removed in reverse order. The spill cost measure is [r.spill_cost / r.degree]. [r.spill_cost] estimates the number of accesses to this register. *) let rec remove_all_regs stack = if not (Reg.Set.is_empty !unconstrained) then begin (* Pick any unconstrained register *) let r = Reg.Set.choose !unconstrained in unconstrained := Reg.Set.remove r !unconstrained; remove_all_regs (r :: stack) end else if not (Reg.Set.is_empty !constrained) then begin (* Find a constrained reg with minimal cost *) let r = ref Reg.dummy in let min_degree = ref 0 and min_spill_cost = ref 1 in (* initially !min_spill_cost / !min_degree is +infty *) Reg.Set.iter (fun r2 -> (* if r2.spill_cost / r2.degree < !min_spill_cost / !min_degree *) if r2.spill_cost * !min_degree < !min_spill_cost * r2.degree then begin r := r2; min_degree := r2.degree; min_spill_cost := r2.spill_cost end) !constrained; constrained := Reg.Set.remove !r !constrained; remove_all_regs (!r :: stack) end else stack (* All regs have been removed *) (* Iterate over all registers preferred by the given register (transitively) *) let iter_preferred f reg = let rec walk r w = if not r.visited then begin f r w; begin match r.prefer with [] -> () | p -> r.visited <- true; List.iter (fun (r1, w1) -> walk r1 (min w w1)) p; r.visited <- false end end in reg.visited <- true; List.iter (fun (r, w) -> walk r w) reg.prefer; reg.visited <- false (* Where to start the search for a suitable register. Used to introduce some "randomness" in the choice between registers with equal scores. This offers more opportunities for scheduling. *) let start_register = Array.create Proc.num_register_classes 0 (* Assign a location to a register, the best we can *) let assign_location reg = let cl = Proc.register_class reg in let first_reg = Proc.first_available_register.(cl) in let num_regs = Proc.num_available_registers.(cl) in let last_reg = first_reg + num_regs in let score = Array.create num_regs 0 in let best_score = ref (-1000000) and best_reg = ref (-1) in let start = start_register.(cl) in if num_regs > 0 then begin (* Favor the registers that have been assigned to pseudoregs for which we have a preference. If these pseudoregs have not been assigned already, avoid the registers with which they conflict. *) iter_preferred (fun r w -> match r.loc with Reg n -> if n >= first_reg && n < last_reg then score.(n - first_reg) <- score.(n - first_reg) + w | Unknown -> List.iter (fun neighbour -> match neighbour.loc with Reg n -> if n >= first_reg && n < last_reg then score.(n - first_reg) <- score.(n - first_reg) - w | _ -> ()) r.interf | _ -> ()) reg; List.iter (fun neighbour -> (* Prohibit the registers that have been assigned to our neighbours *) begin match neighbour.loc with Reg n -> if n >= first_reg && n < last_reg then score.(n - first_reg) <- (-1000000) | _ -> () end; (* Avoid the registers that have been assigned to pseudoregs for which our neighbours have a preference *) iter_preferred (fun r w -> match r.loc with Reg n -> if n >= first_reg && n < last_reg then score.(n - first_reg) <- score.(n - first_reg) - (w - 1) (* w-1 to break the symmetry when two conflicting regs have the same preference for a third reg. *) | _ -> ()) neighbour) reg.interf; (* Pick the register with the best score *) for n = start to num_regs - 1 do if score.(n) > !best_score then begin best_score := score.(n); best_reg := n end done; for n = 0 to start - 1 do if score.(n) > !best_score then begin best_score := score.(n); best_reg := n end done end; (* Found a register? *) if !best_reg >= 0 then begin reg.loc <- Reg(first_reg + !best_reg); if Proc.rotate_registers then start_register.(cl) <- (if start+1 >= num_regs then 0 else start+1) end else begin (* Sorry, we must put the pseudoreg in a stack location *) let nslots = Proc.num_stack_slots.(cl) in let score = Array.create nslots 0 in (* Compute the scores as for registers *) List.iter (fun (r, w) -> match r.loc with Stack(Local n) -> if Proc.register_class r = cl then score.(n) <- score.(n) + w | Unknown -> List.iter (fun neighbour -> match neighbour.loc with Stack(Local n) -> if Proc.register_class neighbour = cl then score.(n) <- score.(n) - w | _ -> ()) r.interf | _ -> ()) reg.prefer; List.iter (fun neighbour -> begin match neighbour.loc with Stack(Local n) -> if Proc.register_class neighbour = cl then score.(n) <- (-1000000) | _ -> () end; List.iter (fun (r, w) -> match r.loc with Stack(Local n) -> if Proc.register_class r = cl then score.(n) <- score.(n) - w | _ -> ()) neighbour.prefer) reg.interf; (* Pick the location with the best score *) let best_score = ref (-1000000) and best_slot = ref (-1) in for n = 0 to nslots - 1 do if score.(n) > !best_score then begin best_score := score.(n); best_slot := n end done; (* Found one? *) if !best_slot >= 0 then reg.loc <- Stack(Local !best_slot) else begin (* Allocate a new stack slot *) reg.loc <- Stack(Local nslots); Proc.num_stack_slots.(cl) <- nslots + 1 end end; (* Cancel the preferences of this register so that they don't influence transitively the allocation of registers that prefer this reg. *) reg.prefer <- [] let allocate_registers() = (* First pass: preallocate spill registers Second pass: compute the degrees Third pass: determine coloring order by successive removals of regs Fourth pass: assign registers in that order *) for i = 0 to Proc.num_register_classes - 1 do Proc.num_stack_slots.(i) <- 0; start_register.(i) <- 0 done; List.iter allocate_spilled (Reg.all_registers()); List.iter find_degree (Reg.all_registers()); List.iter assign_location (remove_all_regs []) mingw-ocaml/ocaml/asmcomp/amd64/0000755000175000017500000000000012124403240016027 5ustar tootstootsmingw-ocaml/ocaml/asmcomp/amd64/emit_nt.mlp0000644000175000017500000006646012124403240020214 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Emission of x86-64 (AMD 64) assembly code, MASM syntax *) module StringSet = Set.Make(struct type t = string let compare = compare end) open Misc open Cmm open Arch open Proc open Reg open Mach open Linearize open Emitaux (* Tradeoff between code size and code speed *) let fastcode_flag = ref true let stack_offset = ref 0 (* Layout of the stack frame *) let frame_required () = !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0 let frame_size () = (* includes return address *) if frame_required() then begin let sz = (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8) in Misc.align sz 16 end else !stack_offset + 8 let slot_offset loc cl = match loc with Incoming n -> frame_size() + n | Local n -> if cl = 0 then !stack_offset + n * 8 else !stack_offset + (num_stack_slots.(0) + n) * 8 | Outgoing n -> n (* Output a 32 bit integer in hex *) let emit_int32 n = emit_printf "0%lxh" n (* Symbols *) let emit_symbol s = Emitaux.emit_symbol '$' s (* Record symbols used and defined - at the end generate extern for those used but not defined *) let symbols_defined = ref StringSet.empty let symbols_used = ref StringSet.empty let add_def_symbol s = symbols_defined := StringSet.add s !symbols_defined let add_used_symbol s = symbols_used := StringSet.add s !symbols_used (* Output a label *) let emit_label lbl = emit_string "L"; emit_int lbl let emit_data_label lbl = emit_string "Ld"; emit_int lbl (* Output a .align directive. *) let emit_align n = ` ALIGN {emit_int n}\n` let emit_Llabel fallthrough lbl = if not fallthrough && !fastcode_flag then emit_align 4; emit_label lbl (* Output a pseudo-register *) let emit_reg = function { loc = Reg r } -> emit_string (register_name r) | { loc = Stack s; typ = Float } as r -> let ofs = slot_offset s (register_class r) in `REAL8 PTR {emit_int ofs}[rsp]` | { loc = Stack s; typ = _ } as r -> let ofs = slot_offset s (register_class r) in `QWORD PTR {emit_int ofs}[rsp]` | { loc = Unknown } -> assert false (* Output a reference to the lower 8, 16 or 32 bits of a register *) let reg_low_8_name = [| "al"; "bl"; "dil"; "sil"; "dl"; "cl"; "r8b"; "r9b"; "r12b"; "r13b"; "bpl"; "r10b"; "r11b" |] let reg_low_16_name = [| "ax"; "bx"; "di"; "si"; "dx"; "cx"; "r8w"; "r9w"; "r12w"; "r13w"; "bp"; "r10w"; "r11w" |] let reg_low_32_name = [| "eax"; "ebx"; "edi"; "esi"; "edx"; "ecx"; "r8d"; "r9d"; "r12d"; "r13d"; "ebp"; "r10d"; "r11d" |] let emit_subreg tbl pref r = match r.loc with Reg r when r < 13 -> emit_string tbl.(r) | Stack s -> let ofs = slot_offset s (register_class r) in `{emit_string pref} PTR {emit_int ofs}[rsp]` | _ -> assert false let emit_reg8 r = emit_subreg reg_low_8_name "BYTE" r let emit_reg16 r = emit_subreg reg_low_16_name "WORD" r let emit_reg32 r = emit_subreg reg_low_32_name "DWORD" r (* Output an addressing mode *) let emit_signed_int d = if d > 0 then emit_char '+'; if d <> 0 then emit_int d let emit_addressing addr r n = match addr with Ibased(s, d) -> add_used_symbol s; `{emit_symbol s}{emit_signed_int d}` | Iindexed d -> `[{emit_reg r.(n)}{emit_signed_int d}]` | Iindexed2 d -> `[{emit_reg r.(n)}+{emit_reg r.(n+1)}{emit_signed_int d}]` | Iscaled(2, d) -> `[{emit_reg r.(n)}+{emit_reg r.(n)}{emit_signed_int d}]` | Iscaled(scale, d) -> `[{emit_reg r.(n)}*{emit_int scale}{emit_signed_int d}]` | Iindexed2scaled(scale, d) -> `[{emit_reg r.(n)}+{emit_reg r.(n+1)}*{emit_int scale}{emit_signed_int d}]` (* Record live pointers at call points *) let record_frame_label live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter (function {typ = Addr; loc = Reg r} -> live_offset := ((r lsl 1) + 1) :: !live_offset | {typ = Addr; loc = Stack s} as reg -> live_offset := slot_offset s (register_class reg) :: !live_offset | _ -> ()) live; frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); fd_live_offset = !live_offset; fd_debuginfo = dbg } :: !frame_descriptors; lbl let record_frame live dbg = let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` (* Record calls to the GC -- we've moved them out of the way *) type gc_call = { gc_lbl: label; (* Entry label *) gc_return_lbl: label; (* Where to branch after GC *) gc_frame: label } (* Label of frame descriptor *) let call_gc_sites = ref ([] : gc_call list) let emit_call_gc gc = `{emit_label gc.gc_lbl}: call {emit_symbol "caml_call_gc"}\n`; `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` (* Record calls to caml_ml_array_bound_error. In -g mode, we maintain one call to caml_ml_array_bound_error per bound check site. Without -g, we can share a single call. *) type bound_error_call = { bd_lbl: label; (* Entry label *) bd_frame: label } (* Label of frame descriptor *) let bound_error_sites = ref ([] : bound_error_call list) let bound_error_call = ref 0 let bound_error_label dbg = if !Clflags.debug then begin let lbl_bound_error = new_label() in let lbl_frame = record_frame_label Reg.Set.empty dbg in bound_error_sites := { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; lbl_bound_error end else begin if !bound_error_call = 0 then bound_error_call := new_label(); !bound_error_call end let emit_call_bound_error bd = `{emit_label bd.bd_lbl}: call caml_ml_array_bound_error\n`; `{emit_label bd.bd_frame}:\n` let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then `{emit_label !bound_error_call}: call caml_ml_array_bound_error\n` (* Names for instructions *) let instr_for_intop = function Iadd -> "add" | Isub -> "sub" | Imul -> "imul" | Iand -> "and" | Ior -> "or" | Ixor -> "xor" | Ilsl -> "sal" | Ilsr -> "shr" | Iasr -> "sar" | _ -> assert false let instr_for_floatop = function Iaddf -> "addsd" | Isubf -> "subsd" | Imulf -> "mulsd" | Idivf -> "divsd" | _ -> assert false let instr_for_floatarithmem = function Ifloatadd -> "addsd" | Ifloatsub -> "subsd" | Ifloatmul -> "mulsd" | Ifloatdiv -> "divsd" let name_for_cond_branch = function Isigned Ceq -> "e" | Isigned Cne -> "ne" | Isigned Cle -> "le" | Isigned Cgt -> "g" | Isigned Clt -> "l" | Isigned Cge -> "ge" | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" (* Output an = 0 or <> 0 test. *) let output_test_zero arg = match arg.loc with Reg r -> ` test {emit_reg arg}, {emit_reg arg}\n` | _ -> ` cmp {emit_reg arg}, 0\n` (* Output a floating-point compare and branch *) let emit_float_test cmp neg arg lbl = (* Effect of comisd on flags and conditional branches: ZF PF CF cond. branches taken unordered 1 1 1 je, jb, jbe, jp > 0 0 0 jne, jae, ja < 0 0 1 jne, jbe, jb = 1 0 0 je, jae, jbe. If FP traps are on (they are off by default), comisd traps on QNaN and SNaN but ucomisd traps on SNaN only. *) match (cmp, neg) with | (Ceq, false) | (Cne, true) -> let next = new_label() in ` ucomisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; ` jp {emit_label next}\n`; (* skip if unordered *) ` je {emit_label lbl}\n`; (* branch taken if x=y *) `{emit_label next}:\n` | (Cne, false) | (Ceq, true) -> ` ucomisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; ` jp {emit_label lbl}\n`; (* branch taken if unordered *) ` jne {emit_label lbl}\n` (* branch taken if xy *) | (Clt, _) -> ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; (* swap compare *) if not neg then ` ja {emit_label lbl}\n` (* branch taken if y>x i.e. x ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; (* swap compare *) if not neg then ` jae {emit_label lbl}\n` (* branch taken if y>=x i.e. x<=y *) else ` jb {emit_label lbl}\n` (* taken if unordered or y ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; if not neg then ` ja {emit_label lbl}\n` (* branch taken if x>y *) else ` jbe {emit_label lbl}\n` (* taken if unordered or x<=y i.e. !(x>y) *) | (Cge, _) -> ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *) if not neg then ` jae {emit_label lbl}\n` (* branch taken if x>=y *) else ` jb {emit_label lbl}\n` (* taken if unordered or x=y) *) (* Deallocate the stack frame before a return or tail call *) let output_epilogue () = if frame_required() then begin let n = frame_size() - 8 in ` add rsp, {emit_int n}\n` end (* Output the assembly code for an instruction *) (* Name of current function *) let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 let float_constants = ref ([] : (int * string) list) let emit_instr fallthrough i = match i.desc with Lend -> () | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin match src.typ, src.loc, dst.loc with Float, Reg _, Reg _ -> ` movapd {emit_reg dst}, {emit_reg src}\n` | Float, _, _ -> ` movsd {emit_reg dst}, {emit_reg src}\n` | _ -> ` mov {emit_reg dst}, {emit_reg src}\n` end | Lop(Iconst_int n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xor {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> ` mov {emit_reg i.res.(0)}, 0\n` end else if n >= -0x80000000n && n <= 0x7FFFFFFFn then ` mov {emit_reg i.res.(0)}, {emit_nativeint n}\n` else if n >= 0x80000000n && n <= 0xFFFFFFFFn then (* work around bug in ml64 *) ` mov {emit_reg32 i.res.(0)}, {emit_nativeint n}\n` else (* force ml64 to use mov reg, imm64 instruction *) ` mov {emit_reg i.res.(0)}, {emit_printf "0%nxH" n}\n` | Lop(Iconst_float s) -> begin match Int64.bits_of_float (float_of_string s) with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> let lbl = new_label() in float_constants := (lbl, s) :: !float_constants; ` movsd {emit_reg i.res.(0)}, {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> add_used_symbol s; if !pic_code then ` lea {emit_reg i.res.(0)}, {emit_symbol s}\n` else ` mov {emit_reg i.res.(0)}, OFFSET {emit_symbol s}\n` | Lop(Icall_ind) -> ` call {emit_reg i.arg.(0)}\n`; record_frame i.live i.dbg | Lop(Icall_imm s) -> add_used_symbol s; ` call {emit_symbol s}\n`; record_frame i.live i.dbg | Lop(Itailcall_ind) -> output_epilogue(); ` jmp {emit_reg i.arg.(0)}\n` | Lop(Itailcall_imm s) -> if s = !function_name then ` jmp {emit_label !tailrec_entry_point}\n` else begin add_used_symbol s; output_epilogue(); ` jmp {emit_symbol s}\n` end | Lop(Iextcall(s, alloc)) -> add_used_symbol s; if alloc then begin ` lea rax, {emit_symbol s}\n`; ` call {emit_symbol "caml_c_call"}\n`; record_frame i.live i.dbg end else begin ` call {emit_symbol s}\n` end | Lop(Istackoffset n) -> if n < 0 then ` add rsp, {emit_int(-n)}\n` else ` sub rsp, {emit_int(n)}\n`; stack_offset := !stack_offset + n | Lop(Iload(chunk, addr)) -> let dest = i.res.(0) in begin match chunk with | Word -> ` mov {emit_reg dest}, QWORD PTR {emit_addressing addr i.arg 0}\n` | Byte_unsigned -> ` movzx {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n` | Byte_signed -> ` movsx {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n` | Sixteen_unsigned -> ` movzx {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n` | Sixteen_signed -> ` movsx {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n` | Thirtytwo_unsigned -> (* load to low 32 bits sets high 32 bits to 0 *) ` mov {emit_reg32 dest}, DWORD PTR {emit_addressing addr i.arg 0}\n` | Thirtytwo_signed -> ` movsxd {emit_reg dest}, DWORD PTR {emit_addressing addr i.arg 0}\n` | Single -> ` cvtss2sd {emit_reg dest}, REAL4 PTR {emit_addressing addr i.arg 0}\n` | Double | Double_u -> ` movsd {emit_reg dest}, REAL8 PTR {emit_addressing addr i.arg 0}\n` end | Lop(Istore(chunk, addr)) -> begin match chunk with | Word -> ` mov QWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` | Byte_unsigned | Byte_signed -> ` mov BYTE PTR {emit_addressing addr i.arg 1}, {emit_reg8 i.arg.(0)}\n` | Sixteen_unsigned | Sixteen_signed -> ` mov WORD PTR {emit_addressing addr i.arg 1}, {emit_reg16 i.arg.(0)}\n` | Thirtytwo_signed | Thirtytwo_unsigned -> ` mov DWORD PTR {emit_addressing addr i.arg 1}, {emit_reg32 i.arg.(0)}\n` | Single -> ` cvtsd2ss xmm15, {emit_reg i.arg.(0)}\n`; ` movss REAL4 PTR {emit_addressing addr i.arg 1}, xmm15\n` | Double | Double_u -> ` movsd REAL8 PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` end | Lop(Ialloc n) -> if !fastcode_flag then begin let lbl_redo = new_label() in `{emit_label lbl_redo}: sub r15, {emit_int n}\n`; ` cmp r15, {emit_symbol "caml_young_limit"}\n`; let lbl_call_gc = new_label() in let lbl_frame = record_frame_label i.live Debuginfo.none in ` jb {emit_label lbl_call_gc}\n`; ` lea {emit_reg i.res.(0)}, [r15+8]\n`; call_gc_sites := { gc_lbl = lbl_call_gc; gc_return_lbl = lbl_redo; gc_frame = lbl_frame } :: !call_gc_sites end else begin begin match n with 16 -> ` call {emit_symbol "caml_alloc1"}\n` | 24 -> ` call {emit_symbol "caml_alloc2"}\n` | 32 -> ` call {emit_symbol "caml_alloc3"}\n` | _ -> ` mov rax, {emit_int n}\n`; ` call {emit_symbol "caml_allocN"}\n` end; `{record_frame i.live Debuginfo.none} lea {emit_reg i.res.(0)}, [r15+8]\n` end | Lop(Iintop(Icomp cmp)) -> ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; let b = name_for_cond_branch cmp in ` set{emit_string b} al\n`; ` movzx {emit_reg i.res.(0)}, al\n` | Lop(Iintop_imm(Icomp cmp, n)) -> ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; let b = name_for_cond_branch cmp in ` set{emit_string b} al\n`; ` movzx {emit_reg i.res.(0)}, al\n` | Lop(Iintop Icheckbound) -> let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` jbe {emit_label lbl}\n` | Lop(Iintop_imm(Icheckbound, n)) -> let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; ` jbe {emit_label lbl}\n` | Lop(Iintop(Idiv | Imod)) -> ` cqo\n`; ` idiv {emit_reg i.arg.(1)}\n` | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, cl\n` | Lop(Iintop op) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> ` lea {emit_reg i.res.(0)}, {emit_int n}[{emit_reg i.arg.(0)}]\n` | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> ` inc {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> ` dec {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Idiv, n)) -> (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) let l = Misc.log2 n in ` mov rax, {emit_reg i.arg.(0)}\n`; ` add {emit_reg i.arg.(0)}, {emit_int(n-1)}\n`; ` test rax, rax\n`; ` cmovns {emit_reg i.arg.(0)}, rax\n`; ` sar {emit_reg i.res.(0)}, {emit_int l}\n` | Lop(Iintop_imm(Imod, n)) -> (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) ` mov rax, {emit_reg i.arg.(0)}\n`; ` test rax, rax\n`; ` lea rax, {emit_int(n-1)}[rax]\n`; ` cmovns rax, {emit_reg i.arg.(0)}\n`; ` and rax, {emit_int (-n)}\n`; ` sub {emit_reg i.res.(0)}, rax\n` | Lop(Iintop_imm(op, n)) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_int n}\n` | Lop(Inegf) -> ` xorpd {emit_reg i.res.(0)}, {emit_symbol "caml_negf_mask"}\n` | Lop(Iabsf) -> ` andpd {emit_reg i.res.(0)}, {emit_symbol "caml_absf_mask"}\n` | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) -> ` {emit_string(instr_for_floatop floatop)} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Ifloatofint) -> ` cvtsi2sd {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` | Lop(Iintoffloat) -> ` cvttsd2si {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` | Lop(Ispecific(Ilea addr)) -> ` lea {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Istore_int(n, addr))) -> ` mov QWORD PTR {emit_addressing addr i.arg 0}, {emit_nativeint n}\n` | Lop(Ispecific(Istore_symbol(s, addr))) -> assert (not !pic_code); add_used_symbol s; ` mov QWORD PTR {emit_addressing addr i.arg 0}, OFFSET {emit_symbol s}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> ` add QWORD PTR {emit_addressing addr i.arg 0}, {emit_int n}\n` | Lop(Ispecific(Ifloatarithmem(op, addr))) -> ` {emit_string(instr_for_floatarithmem op)} {emit_reg i.res.(0)}, REAL8 PTR {emit_addressing addr i.arg 1}\n` | Lreloadretaddr -> () | Lreturn -> output_epilogue(); ` ret\n` | Llabel lbl -> `{emit_Llabel fallthrough lbl}:\n` | Lbranch lbl -> ` jmp {emit_label lbl}\n` | Lcondbranch(tst, lbl) -> begin match tst with Itruetest -> output_test_zero i.arg.(0); ` jne {emit_label lbl}\n` | Ifalsetest -> output_test_zero i.arg.(0); ` je {emit_label lbl}\n` | Iinttest cmp -> ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` | Iinttest_imm((Isigned Ceq | Isigned Cne | Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> output_test_zero i.arg.(0); let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` | Iinttest_imm(cmp, n) -> ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` | Ifloattest(cmp, neg) -> emit_float_test cmp neg i.arg lbl | Ioddtest -> ` test {emit_reg8 i.arg.(0)}, 1\n`; ` jne {emit_label lbl}\n` | Ieventest -> ` test {emit_reg8 i.arg.(0)}, 1\n`; ` je {emit_label lbl}\n` end | Lcondbranch3(lbl0, lbl1, lbl2) -> ` cmp {emit_reg i.arg.(0)}, 1\n`; begin match lbl0 with None -> () | Some lbl -> ` jb {emit_label lbl}\n` end; begin match lbl1 with None -> () | Some lbl -> ` je {emit_label lbl}\n` end; begin match lbl2 with None -> () | Some lbl -> ` jg {emit_label lbl}\n` end | Lswitch jumptbl -> let lbl = new_label() in (* rax and rdx are clobbered by the Lswitch, meaning that no variable that is live across the Lswitch is assigned to rax or rdx. However, the argument to Lswitch can still be assigned to one of these two registers, so we must be careful not to clobber it before use. *) let (tmp1, tmp2) = if i.arg.(0).loc = Reg 0 (* rax *) then (phys_reg 4 (*rdx*), phys_reg 0 (*rax*)) else (phys_reg 0 (*rax*), phys_reg 4 (*rdx*)) in ` lea {emit_reg tmp1}, {emit_label lbl}\n`; ` movsxd {emit_reg tmp2}, DWORD PTR [{emit_reg tmp1}+{emit_reg i.arg.(0)}*4]\n`; ` add {emit_reg tmp1}, {emit_reg tmp2}\n`; ` jmp {emit_reg tmp1}\n`; emit_align 4; `{emit_label lbl} LABEL DWORD\n`; for i = 0 to Array.length jumptbl - 1 do ` DWORD {emit_label jumptbl.(i)} - {emit_label lbl}\n` done | Lsetuptrap lbl -> ` call {emit_label lbl}\n` | Lpushtrap -> ` push r14\n`; ` mov r14, rsp\n`; stack_offset := !stack_offset + 16 | Lpoptrap -> ` pop r14\n`; ` add rsp, 8\n`; stack_offset := !stack_offset - 16 | Lraise -> if !Clflags.debug then begin ` call caml_raise_exn\n`; record_frame Reg.Set.empty i.dbg end else begin ` mov rsp, r14\n`; ` pop r14\n`; ` ret\n` end let rec emit_all fallthrough i = match i.desc with | Lend -> () | _ -> emit_instr fallthrough i; emit_all (Linearize.has_fallthrough i.desc) i.next (* Emission of the floating-point constants *) let emit_float s = (* MASM doesn't like floating-point constants such as 2e9. Turn them into 2.0e9. *) let pos_e = ref (-1) and pos_dot = ref (-1) in for i = 0 to String.length s - 1 do match s.[i] with 'e'|'E' -> pos_e := i | '.' -> pos_dot := i | _ -> () done; if !pos_dot < 0 && !pos_e >= 0 then begin emit_string (String.sub s 0 !pos_e); emit_string ".0"; emit_string (String.sub s !pos_e (String.length s - !pos_e)) end else emit_string s let emit_float_constant (lbl, cst) = `{emit_label lbl} REAL8 {emit_float cst}\n` (* Emission of a function declaration *) let fundecl fundecl = function_name := fundecl.fun_name; fastcode_flag := fundecl.fun_fast; tailrec_entry_point := new_label(); stack_offset := 0; float_constants := []; call_gc_sites := []; bound_error_sites := []; bound_error_call := 0; ` .CODE\n`; emit_align 16; add_def_symbol fundecl.fun_name; ` PUBLIC {emit_symbol fundecl.fun_name}\n`; `{emit_symbol fundecl.fun_name}:\n`; if frame_required() then begin let n = frame_size() - 8 in ` sub rsp, {emit_int n}\n` end; `{emit_label !tailrec_entry_point}:\n`; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors(); if !float_constants <> [] then begin ` .DATA\n`; List.iter emit_float_constant !float_constants end (* Emission of data *) let emit_item = function Cglobal_symbol s -> ` PUBLIC {emit_symbol s}\n`; | Cdefine_symbol s -> add_def_symbol s; `{emit_symbol s} LABEL QWORD\n` | Cdefine_label lbl -> `{emit_data_label lbl} LABEL QWORD\n` | Cint8 n -> ` BYTE {emit_int n}\n` | Cint16 n -> ` WORD {emit_int n}\n` | Cint32 n -> ` DWORD {emit_nativeint n}\n` | Cint n -> ` QWORD {emit_nativeint n}\n` | Csingle f -> ` REAL4 {emit_float f}\n` | Cdouble f -> ` REAL8 {emit_float f}\n` | Csymbol_address s -> add_used_symbol s; ` QWORD {emit_symbol s}\n` | Clabel_address lbl -> ` QWORD {emit_data_label lbl}\n` | Cstring s -> emit_bytes_directive " BYTE " s | Cskip n -> if n > 0 then ` BYTE {emit_int n} DUP (?)\n` | Calign n -> emit_align n let data l = ` .DATA\n`; List.iter emit_item l (* Beginning / end of an assembly file *) let begin_assembly() = ` EXTRN caml_young_ptr: QWORD\n`; ` EXTRN caml_young_limit: QWORD\n`; ` EXTRN caml_exception_pointer: QWORD\n`; ` EXTRN caml_absf_mask: QWORD\n`; ` EXTRN caml_negf_mask: QWORD\n`; ` EXTRN caml_call_gc: NEAR\n`; ` EXTRN caml_c_call: NEAR\n`; ` EXTRN caml_allocN: NEAR\n`; ` EXTRN caml_alloc1: NEAR\n`; ` EXTRN caml_alloc2: NEAR\n`; ` EXTRN caml_alloc3: NEAR\n`; ` EXTRN caml_ml_array_bound_error: NEAR\n`; ` EXTRN caml_raise_exn: NEAR\n`; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in add_def_symbol lbl_begin; ` .DATA\n`; ` PUBLIC {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin} LABEL QWORD\n`; let lbl_begin = Compilenv.make_symbol (Some "code_begin") in add_def_symbol lbl_begin; ` .CODE\n`; ` PUBLIC {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin} LABEL QWORD\n` let end_assembly() = let lbl_end = Compilenv.make_symbol (Some "code_end") in add_def_symbol lbl_end; ` .CODE\n`; ` PUBLIC {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end} LABEL QWORD\n`; ` .DATA\n`; let lbl_end = Compilenv.make_symbol (Some "data_end") in add_def_symbol lbl_end; ` PUBLIC {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end} LABEL QWORD\n`; ` QWORD 0\n`; let lbl = Compilenv.make_symbol (Some "frametable") in add_def_symbol lbl; ` PUBLIC {emit_symbol lbl}\n`; `{emit_symbol lbl} LABEL QWORD\n`; emit_frames { efa_label = (fun l -> ` QWORD {emit_label l}\n`); efa_16 = (fun n -> ` WORD {emit_int n}\n`); efa_32 = (fun n -> ` DWORD {emit_int32 n}\n`); efa_word = (fun n -> ` QWORD {emit_int n}\n`); efa_align = emit_align; efa_label_rel = (fun lbl ofs -> ` DWORD {emit_label lbl} - THIS BYTE + {emit_int32 ofs}\n`); efa_def_label = (fun l -> `{emit_label l} LABEL QWORD\n`); efa_string = (fun s -> emit_bytes_directive " BYTE " (s ^ "\000")) }; `\n;External functions\n\n`; StringSet.iter (fun s -> if not (StringSet.mem s !symbols_defined) then ` EXTRN {emit_symbol s}: NEAR\n`) !symbols_used; symbols_used := StringSet.empty; symbols_defined := StringSet.empty; `END\n` mingw-ocaml/ocaml/asmcomp/amd64/scheduling.ml0000644000175000017500000000175312124403240020514 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2000 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Schedgen (* to create a dependency *) (* Scheduling is turned off because the processor schedules dynamically much better than what we could do. *) let fundecl f = f mingw-ocaml/ocaml/asmcomp/amd64/arch.ml0000644000175000017500000001037512124403240017304 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2000 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Machine-specific command-line options *) let pic_code = ref true let command_line_options = [ "-fPIC", Arg.Set pic_code, " Generate position-independent machine code (default)"; "-fno-PIC", Arg.Clear pic_code, " Generate position-dependent machine code" ] (* Specific operations for the AMD64 processor *) open Format type addressing_mode = Ibased of string * int (* symbol + displ *) | Iindexed of int (* reg + displ *) | Iindexed2 of int (* reg + reg + displ *) | Iscaled of int * int (* reg * scale + displ *) | Iindexed2scaled of int * int (* reg + reg * scale + displ *) type specific_operation = Ilea of addressing_mode (* "lea" gives scaled adds *) | Istore_int of nativeint * addressing_mode (* Store an integer constant *) | Istore_symbol of string * addressing_mode (* Store a symbol *) | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) | Ifloatarithmem of float_operation * addressing_mode (* Float arith operation with memory *) and float_operation = Ifloatadd | Ifloatsub | Ifloatmul | Ifloatdiv (* Sizes, endianness *) let big_endian = false let size_addr = 8 let size_int = 8 let size_float = 8 (* Behavior of division *) let division_crashes_on_overflow = true (* Operations on addressing modes *) let identity_addressing = Iindexed 0 let offset_addressing addr delta = match addr with Ibased(s, n) -> Ibased(s, n + delta) | Iindexed n -> Iindexed(n + delta) | Iindexed2 n -> Iindexed2(n + delta) | Iscaled(scale, n) -> Iscaled(scale, n + delta) | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta) let num_args_addressing = function Ibased(s, n) -> 0 | Iindexed n -> 1 | Iindexed2 n -> 2 | Iscaled(scale, n) -> 1 | Iindexed2scaled(scale, n) -> 2 (* Printing operations and addressing modes *) let print_addressing printreg addr ppf arg = match addr with | Ibased(s, 0) -> fprintf ppf "\"%s\"" s | Ibased(s, n) -> fprintf ppf "\"%s\" + %i" s n | Iindexed n -> let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in fprintf ppf "%a%s" printreg arg.(0) idx | Iindexed2 n -> let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in fprintf ppf "%a + %a%s" printreg arg.(0) printreg arg.(1) idx | Iscaled(scale, n) -> let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in fprintf ppf "%a * %i%s" printreg arg.(0) scale idx | Iindexed2scaled(scale, n) -> let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in fprintf ppf "%a + %a * %i%s" printreg arg.(0) printreg arg.(1) scale idx let print_specific_operation printreg op ppf arg = match op with | Ilea addr -> print_addressing printreg addr ppf arg | Istore_int(n, addr) -> fprintf ppf "[%a] := %nd" (print_addressing printreg addr) arg n | Istore_symbol(lbl, addr) -> fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl | Ioffset_loc(n, addr) -> fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n | Ifloatarithmem(op, addr) -> let op_name = function | Ifloatadd -> "+f" | Ifloatsub -> "-f" | Ifloatmul -> "*f" | Ifloatdiv -> "/f" in fprintf ppf "%a %s float64[%a]" printreg arg.(0) (op_name op) (print_addressing printreg addr) (Array.sub arg 1 (Array.length arg - 1)) mingw-ocaml/ocaml/asmcomp/amd64/proc.ml0000644000175000017500000002143612124403240017332 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2000 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Description of the AMD64 processor *) open Misc open Arch open Cmm open Reg open Mach (* Which ABI to use *) let win64 = match Config.system with | "win64" | "mingw64" -> true | _ -> false (* Which asm conventions to use *) let masm = match Config.ccomp_type with | "msvc" -> true | _ -> false (* Registers available for register allocation *) (* Register map: rax 0 rbx 1 rdi 2 rsi 3 rdx 4 rcx 5 r8 6 r9 7 r12 8 r13 9 rbp 10 r10 11 r11 12 r14 trap pointer r15 allocation pointer xmm0 - xmm15 100 - 115 *) (* Conventions: rax - r13: OCaml function arguments rax: OCaml and C function results xmm0 - xmm9: OCaml function arguments xmm0: OCaml and C function results Under Unix: rdi, rsi, rdx, rcx, r8, r9: C function arguments xmm0 - xmm7: C function arguments rbx, rbp, r12-r15 are preserved by C xmm registers are not preserved by C Under Win64: rcx, rdx, r8, r9: C function arguments xmm0 - xmm3: C function arguments rbx, rbp, rsi, rdi r12-r15 are preserved by C xmm6-xmm15 are preserved by C Note (PR#5707): r11 should not be used for parameter passing, as it can be destroyed by the dynamic loader according to SVR4 ABI. Linux's dynamic loader also destroys r10. *) let int_reg_name = match Config.ccomp_type with | "msvc" -> [| "rax"; "rbx"; "rdi"; "rsi"; "rdx"; "rcx"; "r8"; "r9"; "r12"; "r13"; "rbp"; "r10"; "r11" |] | _ -> [| "%rax"; "%rbx"; "%rdi"; "%rsi"; "%rdx"; "%rcx"; "%r8"; "%r9"; "%r12"; "%r13"; "%rbp"; "%r10"; "%r11" |] let float_reg_name = match Config.ccomp_type with | "msvc" -> [| "xmm0"; "xmm1"; "xmm2"; "xmm3"; "xmm4"; "xmm5"; "xmm6"; "xmm7"; "xmm8"; "xmm9"; "xmm10"; "xmm11"; "xmm12"; "xmm13"; "xmm14"; "xmm15" |] | _ -> [| "%xmm0"; "%xmm1"; "%xmm2"; "%xmm3"; "%xmm4"; "%xmm5"; "%xmm6"; "%xmm7"; "%xmm8"; "%xmm9"; "%xmm10"; "%xmm11"; "%xmm12"; "%xmm13"; "%xmm14"; "%xmm15" |] let num_register_classes = 2 let register_class r = match r.typ with Int -> 0 | Addr -> 0 | Float -> 1 let num_available_registers = [| 13; 16 |] let first_available_register = [| 0; 100 |] let register_name r = if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) (* Pack registers starting at %rax so as to reduce the number of REX prefixes and thus improve code density *) let rotate_registers = false (* Representation of hard registers by pseudo-registers *) let hard_int_reg = let v = Array.create 13 Reg.dummy in for i = 0 to 12 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = let v = Array.create 16 Reg.dummy in for i = 0 to 15 do v.(i) <- Reg.at_location Float (Reg (100 + i)) done; v let all_phys_regs = Array.append hard_int_reg hard_float_reg let phys_reg n = if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) let rax = phys_reg 0 let rcx = phys_reg 5 let rdx = phys_reg 4 let rxmm15 = phys_reg 115 let stack_slot slot ty = Reg.at_location ty (Stack slot) (* Instruction selection *) let word_addressed = false (* Calling conventions *) let calling_conventions first_int last_int first_float last_float make_stack arg = let loc = Array.create (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in for i = 0 to Array.length arg - 1 do match arg.(i).typ with Int | Addr as ty -> if !int <= last_int then begin loc.(i) <- phys_reg !int; incr int end else begin loc.(i) <- stack_slot (make_stack !ofs) ty; ofs := !ofs + size_int end | Float -> if !float <= last_float then begin loc.(i) <- phys_reg !float; incr float end else begin loc.(i) <- stack_slot (make_stack !ofs) Float; ofs := !ofs + size_float end done; (loc, Misc.align !ofs 16) (* keep stack 16-aligned *) let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs let not_supported ofs = fatal_error "Proc.loc_results: cannot call" let loc_arguments arg = calling_conventions 0 9 100 109 outgoing arg let loc_parameters arg = let (loc, ofs) = calling_conventions 0 9 100 109 incoming arg in loc let loc_results res = let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc (* C calling conventions under Unix: first integer args in rdi, rsi, rdx, rcx, r8, r9 first float args in xmm0 ... xmm7 remaining args on stack return value in rax or xmm0. C calling conventions under Win64: first integer args in rcx, rdx, r8, r9 first float args in xmm0 ... xmm3 each integer arg consumes a float reg, and conversely remaining args on stack always 32 bytes reserved at bottom of stack. Return value in rax or xmm0. *) let loc_external_results res = let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc let unix_loc_external_arguments arg = calling_conventions 2 7 100 107 outgoing arg let win64_int_external_arguments = [| 5 (*rcx*); 4 (*rdx*); 6 (*r8*); 7 (*r9*) |] let win64_float_external_arguments = [| 100 (*xmm0*); 101 (*xmm1*); 102 (*xmm2*); 103 (*xmm3*) |] let win64_loc_external_arguments arg = let loc = Array.create (Array.length arg) Reg.dummy in let reg = ref 0 and ofs = ref 32 in for i = 0 to Array.length arg - 1 do match arg.(i).typ with Int | Addr as ty -> if !reg < 4 then begin loc.(i) <- phys_reg win64_int_external_arguments.(!reg); incr reg end else begin loc.(i) <- stack_slot (Outgoing !ofs) ty; ofs := !ofs + size_int end | Float -> if !reg < 4 then begin loc.(i) <- phys_reg win64_float_external_arguments.(!reg); incr reg end else begin loc.(i) <- stack_slot (Outgoing !ofs) Float; ofs := !ofs + size_float end done; (loc, Misc.align !ofs 16) (* keep stack 16-aligned *) let loc_external_arguments = if win64 then win64_loc_external_arguments else unix_loc_external_arguments let loc_exn_bucket = rax (* Registers destroyed by operations *) let destroyed_at_c_call = if win64 then (* Win64: rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 preserved *) Array.of_list(List.map phys_reg [0;4;5;6;7;11;12; 100;101;102;103;104;105]) else (* Unix: rbp, rbx, r12-r15 preserved *) Array.of_list(List.map phys_reg [0;2;3;4;5;6;7;11;12; 100;101;102;103;104;105;106;107; 108;109;110;111;112;113;114;115]) let destroyed_at_oper = function Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs | Iop(Iextcall(_, false)) -> destroyed_at_c_call | Iop(Iintop(Idiv | Imod)) -> [| rax; rdx |] | Iop(Istore(Single, _)) -> [| rxmm15 |] | Iop(Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _)) -> [| rax |] | Iswitch(_, _) -> [| rax; rdx |] | _ -> [||] let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function Iextcall(_,_) -> if win64 then 8 else 0 | _ -> 11 let max_register_pressure = function Iextcall(_, _) -> if win64 then [| 8; 10 |] else [| 4; 0 |] | Iintop(Idiv | Imod) -> [| 11; 16 |] | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _) -> [| 12; 16 |] | Istore(Single, _) -> [| 13; 15 |] | _ -> [| 13; 16 |] (* Layout of the stack frame *) let num_stack_slots = [| 0; 0 |] let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = if masm then Ccomp.command (Config.asm ^ Filename.quote outfile ^ " " ^ Filename.quote infile ^ (if !Clflags.verbose then "" else ">NUL")) else Ccomp.command (Config.asm ^ " -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) mingw-ocaml/ocaml/asmcomp/amd64/reload.ml0000644000175000017500000001146612124403240017637 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2000 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Cmm open Arch open Reg open Mach (* Reloading for the AMD64 *) (* Summary of instruction set constraints: "S" means either stack or register, "R" means register only. Operation Res Arg1 Arg2 Imove R S or S R Iconst_int S if 32-bit signed, R otherwise Iconst_float R Iconst_symbol (not PIC) S Iconst_symbol (PIC) R Icall_ind R Itailcall_ind R Iload R R R Istore R R Iintop(Icomp) R R S or S S R Iintop(Imul|Idiv|mod) R R S Iintop(shift) S S R Iintop(others) R R S or S S R Iintop_imm(Iadd, n)/lea R R Iintop_imm(others) S S Inegf...Idivf R R S Ifloatofint R S Iintoffloat R S Ispecific(Ilea) R R R Ispecific(Ifloatarithmem) R R R Conditional branches: Iinttest S R or R S Ifloattest R S (or S R if swapped test) other tests S *) let stackp r = match r.loc with Stack _ -> true | _ -> false class reload = object (self) inherit Reloadgen.reload_generic as super method! reload_operation op arg res = match op with | Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound) -> (* One of the two arguments can reside in the stack, but not both *) if stackp arg.(0) && stackp arg.(1) then ([|arg.(0); self#makereg arg.(1)|], res) else (arg, res) | Iintop_imm(Iadd, _) when arg.(0).loc <> res.(0).loc -> (* This add will be turned into a lea; args and results must be in registers *) super#reload_operation op arg res | Iintop(Idiv | Imod | Ilsl | Ilsr | Iasr) | Iintop_imm(_, _) -> (* The argument(s) and results can be either in register or on stack *) (* Note: Idiv, Imod: arg(0) and res(0) already forced in regs Ilsl, Ilsr, Iasr: arg(1) already forced in regs *) (arg, res) | Iintop(Imul) | Iaddf | Isubf | Imulf | Idivf -> (* First argument (= result) must be in register, second arg can reside in the stack *) if stackp arg.(0) then (let r = self#makereg arg.(0) in ([|r; arg.(1)|], [|r|])) else (arg, res) | Ifloatofint | Iintoffloat -> (* Result must be in register, but argument can be on stack *) (arg, (if stackp res.(0) then [| self#makereg res.(0) |] else res)) | Iconst_int n -> if n <= 0x7FFFFFFFn && n >= -0x80000000n then (arg, res) else super#reload_operation op arg res | Iconst_symbol _ -> if !pic_code || !Clflags.dlcode then super#reload_operation op arg res else (arg, res) | _ -> (* Other operations: all args and results in registers *) super#reload_operation op arg res method! reload_test tst arg = match tst with Iinttest cmp -> (* One of the two arguments can reside on stack *) if stackp arg.(0) && stackp arg.(1) then [| self#makereg arg.(0); arg.(1) |] else arg | Ifloattest((Clt|Cle), _) -> (* Cf. emit.mlp: we swap arguments in this case *) (* First argument can be on stack, second must be in register *) if stackp arg.(1) then [| arg.(0); self#makereg arg.(1) |] else arg | Ifloattest((Ceq|Cne|Cgt|Cge), _) -> (* Second argument can be on stack, first must be in register *) if stackp arg.(0) then [| self#makereg arg.(0); arg.(1) |] else arg | _ -> (* The argument(s) can be either in register or on stack *) arg end let fundecl f = (new reload)#fundecl f mingw-ocaml/ocaml/asmcomp/amd64/selection.ml0000644000175000017500000002003012124403240020341 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2000 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Instruction selection for the AMD64 *) open Misc open Arch open Proc open Cmm open Reg open Mach (* Auxiliary for recognizing addressing modes *) type addressing_expr = Asymbol of string | Alinear of expression | Aadd of expression * expression | Ascale of expression * int | Ascaledadd of expression * expression * int let rec select_addr exp = match exp with Cconst_symbol s when not !Clflags.dlcode -> (Asymbol s, 0) | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> let (a, n) = select_addr arg in (a, n + m) | Cop((Csubi | Csuba), [arg; Cconst_int m]) -> let (a, n) = select_addr arg in (a, n - m) | Cop((Caddi | Cadda), [Cconst_int m; arg]) -> let (a, n) = select_addr arg in (a, n + m) | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift) | _ -> (Alinear exp, 0) end | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, mult), n * mult) | _ -> (Alinear exp, 0) end | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, mult), n * mult) | _ -> (Alinear exp, 0) end | Cop((Caddi | Cadda), [arg1; arg2]) -> begin match (select_addr arg1, select_addr arg2) with ((Alinear e1, n1), (Alinear e2, n2)) -> (Aadd(e1, e2), n1 + n2) | ((Alinear e1, n1), (Ascale(e2, scale), n2)) -> (Ascaledadd(e1, e2, scale), n1 + n2) | ((Ascale(e1, scale), n1), (Alinear e2, n2)) -> (Ascaledadd(e2, e1, scale), n1 + n2) | (_, (Ascale(e2, scale), n2)) -> (Ascaledadd(arg1, e2, scale), n2) | ((Ascale(e1, scale), n1), _) -> (Ascaledadd(arg2, e1, scale), n1) | _ -> (Aadd(arg1, arg2), 0) end | arg -> (Alinear arg, 0) (* Special constraints on operand and result registers *) exception Use_default let rax = phys_reg 0 let rcx = phys_reg 5 let rdx = phys_reg 4 let pseudoregs_for_operation op arg res = match op with (* Two-address binary operations: arg.(0) and res.(0) must be the same *) Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) | Iaddf|Isubf|Imulf|Idivf -> ([|res.(0); arg.(1)|], res) (* One-address unary operations: arg.(0) and res.(0) must be the same *) | Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) | Iabsf | Inegf -> (res, res) | Ispecific(Ifloatarithmem(_,_)) -> let arg' = Array.copy arg in arg'.(0) <- res.(0); (arg', res) (* For shifts with variable shift count, second arg must be in rcx *) | Iintop(Ilsl|Ilsr|Iasr) -> ([|res.(0); rcx|], res) (* For div and mod, first arg must be in rax, rdx is clobbered, and result is in rax or rdx respectively. Keep it simple, just force second argument in rcx. *) | Iintop(Idiv) -> ([| rax; rcx |], [| rax |]) | Iintop(Imod) -> ([| rax; rcx |], [| rdx |]) (* For div and mod with immediate operand, arg must not be in rax. Keep it simple, force it in rdx. *) | Iintop_imm((Idiv|Imod), _) -> ([| rdx |], [| rdx |]) (* Other instructions are regular *) | _ -> raise Use_default (* The selector class *) class selector = object (self) inherit Selectgen.selector_generic as super method is_immediate n = n <= 0x7FFFFFFF && n >= -0x80000000 method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n method select_addressing chunk exp = let (a, d) = select_addr exp in (* PR#4625: displacement must be a signed 32-bit immediate *) if d < -0x8000_0000 || d > 0x7FFF_FFFF then (Iindexed 0, exp) else match a with | Asymbol s -> (Ibased(s, d), Ctuple []) | Alinear e -> (Iindexed d, e) | Aadd(e1, e2) -> (Iindexed2 d, Ctuple[e1; e2]) | Ascale(e, scale) -> (Iscaled(scale, d), e) | Ascaledadd(e1, e2, scale) -> (Iindexed2scaled(scale, d), Ctuple[e1; e2]) method! select_store addr exp = match exp with Cconst_int n when self#is_immediate n -> (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) | Cconst_natint n when self#is_immediate_natint n -> (Ispecific(Istore_int(n, addr)), Ctuple []) | Cconst_pointer n when self#is_immediate n -> (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) | Cconst_natpointer n when self#is_immediate_natint n -> (Ispecific(Istore_int(n, addr)), Ctuple []) | Cconst_symbol s when not (!pic_code || !Clflags.dlcode) -> (Ispecific(Istore_symbol(s, addr)), Ctuple []) | _ -> super#select_store addr exp method! select_operation op args = match op with (* Recognize the LEA instruction *) Caddi | Cadda | Csubi | Csuba -> begin match self#select_addressing Word (Cop(op, args)) with (Iindexed d, _) -> super#select_operation op args | (Iindexed2 0, _) -> super#select_operation op args | (addr, arg) -> (Ispecific(Ilea addr), [arg]) end (* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *) | Cdivi -> begin match args with [arg1; Cconst_int n] when self#is_immediate n && n = 1 lsl (Misc.log2 n) -> (Iintop_imm(Idiv, n), [arg1]) | _ -> (Iintop Idiv, args) end | Cmodi -> begin match args with [arg1; Cconst_int n] when self#is_immediate n && n = 1 lsl (Misc.log2 n) -> (Iintop_imm(Imod, n), [arg1]) | _ -> (Iintop Imod, args) end (* Recognize float arithmetic with memory. *) | Caddf -> self#select_floatarith true Iaddf Ifloatadd args | Csubf -> self#select_floatarith false Isubf Ifloatsub args | Cmulf -> self#select_floatarith true Imulf Ifloatmul args | Cdivf -> self#select_floatarith false Idivf Ifloatdiv args (* Recognize store instructions *) | Cstore Word -> begin match args with [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])] when loc = loc' && self#is_immediate n -> let (addr, arg) = self#select_addressing Word loc in (Ispecific(Ioffset_loc(n, addr)), [arg]) | _ -> super#select_operation op args end | _ -> super#select_operation op args (* Recognize float arithmetic with mem *) method select_floatarith commutative regular_op mem_op args = match args with [arg1; Cop(Cload (Double|Double_u as chunk), [loc2])] -> let (addr, arg2) = self#select_addressing chunk loc2 in (Ispecific(Ifloatarithmem(mem_op, addr)), [arg1; arg2]) | [Cop(Cload (Double|Double_u as chunk), [loc1]); arg2] when commutative -> let (addr, arg1) = self#select_addressing chunk loc1 in (Ispecific(Ifloatarithmem(mem_op, addr)), [arg2; arg1]) | [arg1; arg2] -> (regular_op, [arg1; arg2]) | _ -> assert false (* Deal with register constraints *) method! insert_op_debug op dbg rs rd = try let (rsrc, rdst) = pseudoregs_for_operation op rs rd in self#insert_moves rs rsrc; self#insert_debug (Iop op) dbg rsrc rdst; self#insert_moves rdst rd; rd with Use_default -> super#insert_op_debug op dbg rs rd end let fundecl f = (new selector)#emit_fundecl f mingw-ocaml/ocaml/asmcomp/amd64/emit.mlp0000644000175000017500000007057012124403240017510 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Emission of x86-64 (AMD 64) assembly code *) open Misc open Cmm open Arch open Proc open Reg open Mach open Linearize open Emitaux let macosx = (Config.system = "macosx") let mingw64 = (Config.system = "mingw64") (* Tradeoff between code size and code speed *) let fastcode_flag = ref true let stack_offset = ref 0 (* Layout of the stack frame *) let frame_required () = !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0 let frame_size () = (* includes return address *) if frame_required() then begin let sz = (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8) in Misc.align sz 16 end else !stack_offset + 8 let slot_offset loc cl = match loc with Incoming n -> frame_size() + n | Local n -> if cl = 0 then !stack_offset + n * 8 else !stack_offset + (num_stack_slots.(0) + n) * 8 | Outgoing n -> n (* Symbols *) let emit_symbol s = if macosx then emit_string "_"; Emitaux.emit_symbol '$' s let emit_call s = if !Clflags.dlcode && not macosx && not mingw64 then `call {emit_symbol s}@PLT` else `call {emit_symbol s}` let emit_jump s = if !Clflags.dlcode && not macosx && not mingw64 then `jmp {emit_symbol s}@PLT` else `jmp {emit_symbol s}` let load_symbol_addr s = if !Clflags.dlcode && not mingw64 then `movq {emit_symbol s}@GOTPCREL(%rip)` else if !pic_code then `leaq {emit_symbol s}(%rip)` else `movq ${emit_symbol s}` (* Output a label *) let emit_label lbl = emit_string ".L"; emit_int lbl let emit_data_label lbl = emit_string ".Ld"; emit_int lbl (* Output a .align directive. *) let emit_align n = let n = if macosx then Misc.log2 n else n in ` .align {emit_int n}\n` let emit_Llabel fallthrough lbl = if not fallthrough && !fastcode_flag then emit_align 4; emit_label lbl (* Output a pseudo-register *) let emit_reg = function { loc = Reg r } -> emit_string (register_name r) | { loc = Stack s } as r -> let ofs = slot_offset s (register_class r) in `{emit_int ofs}(%rsp)` | { loc = Unknown } -> assert false (* Output a reference to the lower 8, 16 or 32 bits of a register *) let reg_low_8_name = [| "%al"; "%bl"; "%dil"; "%sil"; "%dl"; "%cl"; "%r8b"; "%r9b"; "%r12b"; "%r13b"; "%bpl"; "%r10b"; "%r11b" |] let reg_low_16_name = [| "%ax"; "%bx"; "%di"; "%si"; "%dx"; "%cx"; "%r8w"; "%r9w"; "%r12w"; "%r13w"; "%bp"; "%r10w"; "%r11w" |] let reg_low_32_name = [| "%eax"; "%ebx"; "%edi"; "%esi"; "%edx"; "%ecx"; "%r8d"; "%r9d"; "%r12d"; "%r13d"; "%ebp"; "%r10d"; "%r11d" |] let emit_subreg tbl r = match r.loc with Reg r when r < 13 -> emit_string tbl.(r) | Stack s -> let ofs = slot_offset s (register_class r) in `{emit_int ofs}(%rsp)` | _ -> assert false let emit_reg8 r = emit_subreg reg_low_8_name r let emit_reg16 r = emit_subreg reg_low_16_name r let emit_reg32 r = emit_subreg reg_low_32_name r (* Output an addressing mode *) let emit_addressing addr r n = match addr with | Ibased _ when !Clflags.dlcode -> assert false | Ibased(s, d) -> `{emit_symbol s}`; if d <> 0 then ` + {emit_int d}`; `(%rip)` | Iindexed d -> if d <> 0 then emit_int d; `({emit_reg r.(n)})` | Iindexed2 d -> if d <> 0 then emit_int d; `({emit_reg r.(n)}, {emit_reg r.(n+1)})` | Iscaled(2, d) -> if d <> 0 then emit_int d; `({emit_reg r.(n)}, {emit_reg r.(n)})` | Iscaled(scale, d) -> if d <> 0 then emit_int d; `(, {emit_reg r.(n)}, {emit_int scale})` | Iindexed2scaled(scale, d) -> if d <> 0 then emit_int d; `({emit_reg r.(n)}, {emit_reg r.(n+1)}, {emit_int scale})` (* Record live pointers at call points -- see Emitaux *) let record_frame_label live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter (function {typ = Addr; loc = Reg r} -> live_offset := ((r lsl 1) + 1) :: !live_offset | {typ = Addr; loc = Stack s} as reg -> live_offset := slot_offset s (register_class reg) :: !live_offset | _ -> ()) live; frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); fd_live_offset = !live_offset; fd_debuginfo = dbg } :: !frame_descriptors; lbl let record_frame live dbg = let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` (* Record calls to the GC -- we've moved them out of the way *) type gc_call = { gc_lbl: label; (* Entry label *) gc_return_lbl: label; (* Where to branch after GC *) gc_frame: label } (* Label of frame descriptor *) let call_gc_sites = ref ([] : gc_call list) let emit_call_gc gc = `{emit_label gc.gc_lbl}: {emit_call "caml_call_gc"}\n`; `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` (* Record calls to caml_ml_array_bound_error. In -g mode, we maintain one call to caml_ml_array_bound_error per bound check site. Without -g, we can share a single call. *) type bound_error_call = { bd_lbl: label; (* Entry label *) bd_frame: label } (* Label of frame descriptor *) let bound_error_sites = ref ([] : bound_error_call list) let bound_error_call = ref 0 let bound_error_label dbg = if !Clflags.debug then begin let lbl_bound_error = new_label() in let lbl_frame = record_frame_label Reg.Set.empty dbg in bound_error_sites := { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; lbl_bound_error end else begin if !bound_error_call = 0 then bound_error_call := new_label(); !bound_error_call end let emit_call_bound_error bd = `{emit_label bd.bd_lbl}: {emit_call "caml_ml_array_bound_error"}\n`; `{emit_label bd.bd_frame}:\n` let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then `{emit_label !bound_error_call}: {emit_call "caml_ml_array_bound_error"}\n` (* Names for instructions *) let instr_for_intop = function Iadd -> "addq" | Isub -> "subq" | Imul -> "imulq" | Iand -> "andq" | Ior -> "orq" | Ixor -> "xorq" | Ilsl -> "salq" | Ilsr -> "shrq" | Iasr -> "sarq" | _ -> assert false let instr_for_floatop = function Iaddf -> "addsd" | Isubf -> "subsd" | Imulf -> "mulsd" | Idivf -> "divsd" | _ -> assert false let instr_for_floatarithmem = function Ifloatadd -> "addsd" | Ifloatsub -> "subsd" | Ifloatmul -> "mulsd" | Ifloatdiv -> "divsd" let name_for_cond_branch = function Isigned Ceq -> "e" | Isigned Cne -> "ne" | Isigned Cle -> "le" | Isigned Cgt -> "g" | Isigned Clt -> "l" | Isigned Cge -> "ge" | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" (* Output an = 0 or <> 0 test. *) let output_test_zero arg = match arg.loc with Reg r -> ` testq {emit_reg arg}, {emit_reg arg}\n` | _ -> ` cmpq $0, {emit_reg arg}\n` (* Output a floating-point compare and branch *) let emit_float_test cmp neg arg lbl = (* Effect of comisd on flags and conditional branches: ZF PF CF cond. branches taken unordered 1 1 1 je, jb, jbe, jp > 0 0 0 jne, jae, ja < 0 0 1 jne, jbe, jb = 1 0 0 je, jae, jbe. If FP traps are on (they are off by default), comisd traps on QNaN and SNaN but ucomisd traps on SNaN only. *) match (cmp, neg) with | (Ceq, false) | (Cne, true) -> let next = new_label() in ` ucomisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; ` jp {emit_label next}\n`; (* skip if unordered *) ` je {emit_label lbl}\n`; (* branch taken if x=y *) `{emit_label next}:\n` | (Cne, false) | (Ceq, true) -> ` ucomisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; ` jp {emit_label lbl}\n`; (* branch taken if unordered *) ` jne {emit_label lbl}\n` (* branch taken if xy *) | (Clt, _) -> ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *) if not neg then ` ja {emit_label lbl}\n` (* branch taken if y>x i.e. x ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *) if not neg then ` jae {emit_label lbl}\n` (* branch taken if y>=x i.e. x<=y *) else ` jb {emit_label lbl}\n` (* taken if unordered or y ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; if not neg then ` ja {emit_label lbl}\n` (* branch taken if x>y *) else ` jbe {emit_label lbl}\n` (* taken if unordered or x<=y i.e. !(x>y) *) | (Cge, _) -> ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; (* swap compare *) if not neg then ` jae {emit_label lbl}\n` (* branch taken if x>=y *) else ` jb {emit_label lbl}\n` (* taken if unordered or x=y) *) (* Deallocate the stack frame before a return or tail call *) let output_epilogue f = if frame_required() then begin let n = frame_size() - 8 in ` addq ${emit_int n}, %rsp\n`; cfi_adjust_cfa_offset (-n); f (); (* reset CFA back cause function body may continue *) cfi_adjust_cfa_offset n end else f () (* Output the assembly code for an instruction *) (* Name of current function *) let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 let float_constants = ref ([] : (int * string) list) (* Emit an instruction *) let emit_instr fallthrough i = emit_debug_info i.dbg; match i.desc with Lend -> () | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin match src.typ, src.loc, dst.loc with Float, Reg _, Reg _ -> ` movapd {emit_reg src}, {emit_reg dst}\n` | Float, _, _ -> ` movsd {emit_reg src}, {emit_reg dst}\n` | _ -> ` movq {emit_reg src}, {emit_reg dst}\n` end | Lop(Iconst_int n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xorq {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> ` movq $0, {emit_reg i.res.(0)}\n` end else if n <= 0x7FFFFFFFn && n >= -0x80000000n then ` movq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` else ` movabsq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` | Lop(Iconst_float s) -> begin match Int64.bits_of_float (float_of_string s) with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> let lbl = new_label() in float_constants := (lbl, s) :: !float_constants; ` movsd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n` end | Lop(Iconst_symbol s) -> ` {load_symbol_addr s}, {emit_reg i.res.(0)}\n` | Lop(Icall_ind) -> ` call *{emit_reg i.arg.(0)}\n`; record_frame i.live i.dbg | Lop(Icall_imm(s)) -> ` {emit_call s}\n`; record_frame i.live i.dbg | Lop(Itailcall_ind) -> output_epilogue begin fun () -> ` jmp *{emit_reg i.arg.(0)}\n` end | Lop(Itailcall_imm s) -> if s = !function_name then ` jmp {emit_label !tailrec_entry_point}\n` else begin output_epilogue begin fun () -> ` {emit_jump s}\n` end end | Lop(Iextcall(s, alloc)) -> if alloc then begin ` {load_symbol_addr s}, %rax\n`; ` {emit_call "caml_c_call"}\n`; record_frame i.live i.dbg; ` {load_symbol_addr "caml_young_ptr"}, %r11\n`; ` movq (%r11), %r15\n`; end else begin ` {emit_call s}\n` end | Lop(Istackoffset n) -> if n < 0 then ` addq ${emit_int(-n)}, %rsp\n` else ` subq ${emit_int(n)}, %rsp\n`; cfi_adjust_cfa_offset n; stack_offset := !stack_offset + n | Lop(Iload(chunk, addr)) -> let dest = i.res.(0) in begin match chunk with | Word -> ` movq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` | Byte_unsigned -> ` movzbq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` | Byte_signed -> ` movsbq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` | Sixteen_unsigned -> ` movzwq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` | Sixteen_signed -> ` movswq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` | Thirtytwo_unsigned -> ` movl {emit_addressing addr i.arg 0}, {emit_reg32 dest}\n` | Thirtytwo_signed -> ` movslq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` | Single -> ` cvtss2sd {emit_addressing addr i.arg 0}, {emit_reg dest}\n` | Double | Double_u -> ` movsd {emit_addressing addr i.arg 0}, {emit_reg dest}\n` end | Lop(Istore(chunk, addr)) -> begin match chunk with | Word -> ` movq {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` | Byte_unsigned | Byte_signed -> ` movb {emit_reg8 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` | Sixteen_unsigned | Sixteen_signed -> ` movw {emit_reg16 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` | Thirtytwo_signed | Thirtytwo_unsigned -> ` movl {emit_reg32 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` | Single -> ` cvtsd2ss {emit_reg i.arg.(0)}, %xmm15\n`; ` movss %xmm15, {emit_addressing addr i.arg 1}\n` | Double | Double_u -> ` movsd {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` end | Lop(Ialloc n) -> if !fastcode_flag then begin let lbl_redo = new_label() in `{emit_label lbl_redo}: subq ${emit_int n}, %r15\n`; if !Clflags.dlcode then begin ` {load_symbol_addr "caml_young_limit"}, %rax\n`; ` cmpq (%rax), %r15\n`; end else ` cmpq {emit_symbol "caml_young_limit"}(%rip), %r15\n`; let lbl_call_gc = new_label() in let lbl_frame = record_frame_label i.live Debuginfo.none in ` jb {emit_label lbl_call_gc}\n`; ` leaq 8(%r15), {emit_reg i.res.(0)}\n`; call_gc_sites := { gc_lbl = lbl_call_gc; gc_return_lbl = lbl_redo; gc_frame = lbl_frame } :: !call_gc_sites end else begin begin match n with 16 -> ` {emit_call "caml_alloc1"}\n` | 24 -> ` {emit_call "caml_alloc2"}\n` | 32 -> ` {emit_call "caml_alloc3"}\n` | _ -> ` movq ${emit_int n}, %rax\n`; ` {emit_call "caml_allocN"}\n` end; `{record_frame i.live Debuginfo.none} leaq 8(%r15), {emit_reg i.res.(0)}\n` end | Lop(Iintop(Icomp cmp)) -> ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; let b = name_for_cond_branch cmp in ` set{emit_string b} %al\n`; ` movzbq %al, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Icomp cmp, n)) -> ` cmpq ${emit_int n}, {emit_reg i.arg.(0)}\n`; let b = name_for_cond_branch cmp in ` set{emit_string b} %al\n`; ` movzbq %al, {emit_reg i.res.(0)}\n` | Lop(Iintop Icheckbound) -> let lbl = bound_error_label i.dbg in ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; ` jbe {emit_label lbl}\n` | Lop(Iintop_imm(Icheckbound, n)) -> let lbl = bound_error_label i.dbg in ` cmpq ${emit_int n}, {emit_reg i.arg.(0)}\n`; ` jbe {emit_label lbl}\n` | Lop(Iintop(Idiv | Imod)) -> ` cqto\n`; ` idivq {emit_reg i.arg.(1)}\n` | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *) ` {emit_string(instr_for_intop op)} %cl, {emit_reg i.res.(0)}\n` | Lop(Iintop op) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> ` leaq {emit_int n}({emit_reg i.arg.(0)}), {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> ` incq {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> ` decq {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Idiv, n)) -> (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) let l = Misc.log2 n in ` movq {emit_reg i.arg.(0)}, %rax\n`; ` addq ${emit_int(n-1)}, {emit_reg i.arg.(0)}\n`; ` testq %rax, %rax\n`; ` cmovns %rax, {emit_reg i.arg.(0)}\n`; ` sarq ${emit_int l}, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Imod, n)) -> (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) ` movq {emit_reg i.arg.(0)}, %rax\n`; ` testq %rax, %rax\n`; ` leaq {emit_int(n-1)}(%rax), %rax\n`; ` cmovns {emit_reg i.arg.(0)}, %rax\n`; ` andq ${emit_int (-n)}, %rax\n`; ` subq %rax, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(op, n)) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} ${emit_int n}, {emit_reg i.res.(0)}\n` | Lop(Inegf) -> ` xorpd {emit_symbol "caml_negf_mask"}(%rip), {emit_reg i.res.(0)}\n` | Lop(Iabsf) -> ` andpd {emit_symbol "caml_absf_mask"}(%rip), {emit_reg i.res.(0)}\n` | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) -> ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` | Lop(Ifloatofint) -> ` cvtsi2sdq {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` | Lop(Iintoffloat) -> ` cvttsd2siq {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` | Lop(Ispecific(Ilea addr)) -> ` leaq {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` | Lop(Ispecific(Istore_int(n, addr))) -> ` movq ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Istore_symbol(s, addr))) -> assert (not !pic_code && not !Clflags.dlcode); ` movq ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> ` addq ${emit_int n}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Ifloatarithmem(op, addr))) -> ` {emit_string(instr_for_floatarithmem op)} {emit_addressing addr i.arg 1}, {emit_reg i.res.(0)}\n` | Lreloadretaddr -> () | Lreturn -> output_epilogue begin fun () -> ` ret\n` end | Llabel lbl -> `{emit_Llabel fallthrough lbl}:\n` | Lbranch lbl -> ` jmp {emit_label lbl}\n` | Lcondbranch(tst, lbl) -> begin match tst with Itruetest -> output_test_zero i.arg.(0); ` jne {emit_label lbl}\n` | Ifalsetest -> output_test_zero i.arg.(0); ` je {emit_label lbl}\n` | Iinttest cmp -> ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` | Iinttest_imm((Isigned Ceq | Isigned Cne | Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> output_test_zero i.arg.(0); let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` | Iinttest_imm(cmp, n) -> ` cmpq ${emit_int n}, {emit_reg i.arg.(0)}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` | Ifloattest(cmp, neg) -> emit_float_test cmp neg i.arg lbl | Ioddtest -> ` testb $1, {emit_reg8 i.arg.(0)}\n`; ` jne {emit_label lbl}\n` | Ieventest -> ` testb $1, {emit_reg8 i.arg.(0)}\n`; ` je {emit_label lbl}\n` end | Lcondbranch3(lbl0, lbl1, lbl2) -> ` cmpq $1, {emit_reg i.arg.(0)}\n`; begin match lbl0 with None -> () | Some lbl -> ` jb {emit_label lbl}\n` end; begin match lbl1 with None -> () | Some lbl -> ` je {emit_label lbl}\n` end; begin match lbl2 with None -> () | Some lbl -> ` jg {emit_label lbl}\n` end | Lswitch jumptbl -> let lbl = new_label() in (* rax and rdx are clobbered by the Lswitch, meaning that no variable that is live across the Lswitch is assigned to rax or rdx. However, the argument to Lswitch can still be assigned to one of these two registers, so we must be careful not to clobber it before use. *) let (tmp1, tmp2) = if i.arg.(0).loc = Reg 0 (* rax *) then (phys_reg 4 (*rdx*), phys_reg 0 (*rax*)) else (phys_reg 0 (*rax*), phys_reg 4 (*rdx*)) in ` leaq {emit_label lbl}(%rip), {emit_reg tmp1}\n`; ` movslq ({emit_reg tmp1}, {emit_reg i.arg.(0)}, 4), {emit_reg tmp2}\n`; ` addq {emit_reg tmp2}, {emit_reg tmp1}\n`; ` jmp *{emit_reg tmp1}\n`; if macosx then ` .const\n` else if mingw64 then ` .section .rdata,\"dr\"\n` else ` .section .rodata\n`; emit_align 4; `{emit_label lbl}:`; for i = 0 to Array.length jumptbl - 1 do ` .long {emit_label jumptbl.(i)} - {emit_label lbl}\n` done; ` .text\n` | Lsetuptrap lbl -> ` call {emit_label lbl}\n` | Lpushtrap -> cfi_adjust_cfa_offset 8; ` pushq %r14\n`; cfi_adjust_cfa_offset 8; ` movq %rsp, %r14\n`; stack_offset := !stack_offset + 16 | Lpoptrap -> ` popq %r14\n`; cfi_adjust_cfa_offset (-8); ` addq $8, %rsp\n`; cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset - 16 | Lraise -> if !Clflags.debug then begin ` {emit_call "caml_raise_exn"}\n`; record_frame Reg.Set.empty i.dbg end else begin ` movq %r14, %rsp\n`; ` popq %r14\n`; ` ret\n` end let rec emit_all fallthrough i = match i.desc with | Lend -> () | _ -> emit_instr fallthrough i; emit_all (Linearize.has_fallthrough i.desc) i.next (* Emission of the floating-point constants *) let emit_float_constant (lbl, cst) = `{emit_label lbl}:`; emit_float64_directive ".quad" cst (* Emission of the profiling prelude *) let emit_profile () = match Config.system with | "linux" | "gnu" -> (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly and rbx, rbp, r12-r15 like all C functions. This includes all the registers used for argument passing, so we don't need to preserve other regs. We do need to initialize rbp like mcount expects it, though. *) ` pushq %r10\n`; ` movq %rsp, %rbp\n`; ` {emit_call "mcount"}\n`; ` popq %r10\n` | _ -> () (*unsupported yet*) (* Emission of a function declaration *) let fundecl fundecl = function_name := fundecl.fun_name; fastcode_flag := fundecl.fun_fast; tailrec_entry_point := new_label(); stack_offset := 0; float_constants := []; call_gc_sites := []; bound_error_sites := []; bound_error_call := 0; ` .text\n`; emit_align 16; if macosx && not !Clflags.output_c_object && is_generic_function fundecl.fun_name then (* PR#4690 *) ` .private_extern {emit_symbol fundecl.fun_name}\n` else ` .globl {emit_symbol fundecl.fun_name}\n`; `{emit_symbol fundecl.fun_name}:\n`; emit_debug_info fundecl.fun_dbg; cfi_startproc (); if !Clflags.gprofile then emit_profile(); if frame_required() then begin let n = frame_size() - 8 in ` subq ${emit_int n}, %rsp\n`; cfi_adjust_cfa_offset n; end; `{emit_label !tailrec_entry_point}:\n`; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors (); cfi_endproc (); begin match Config.system with "linux" | "gnu" -> ` .type {emit_symbol fundecl.fun_name},@function\n`; ` .size {emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n` | _ -> () end; if !float_constants <> [] then begin if macosx then ` .literal8\n` else if mingw64 then ` .section .rdata,\"dr\"\n` else ` .section .rodata.cst8,\"a\",@progbits\n`; List.iter emit_float_constant !float_constants end (* Emission of data *) let emit_item = function Cglobal_symbol s -> ` .globl {emit_symbol s}\n`; | Cdefine_symbol s -> `{emit_symbol s}:\n` | Cdefine_label lbl -> `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> ` .word {emit_int n}\n` | Cint32 n -> ` .long {emit_nativeint n}\n` | Cint n -> ` .quad {emit_nativeint n}\n` | Csingle f -> emit_float32_directive ".long" f | Cdouble f -> emit_float64_directive ".quad" f | Csymbol_address s -> ` .quad {emit_symbol s}\n` | Clabel_address lbl -> ` .quad {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s | Cskip n -> if n > 0 then ` .space {emit_int n}\n` | Calign n -> emit_align n let data l = ` .data\n`; List.iter emit_item l (* Beginning / end of an assembly file *) let begin_assembly() = reset_debug_info(); (* PR#5603 *) if !Clflags.dlcode then begin (* from amd64.S; could emit these constants on demand *) if macosx then ` .literal16\n` else if mingw64 then ` .section .rdata,\"dr\"\n` else ` .section .rodata.cst8,\"a\",@progbits\n`; emit_align 16; `{emit_symbol "caml_negf_mask"}: .quad 0x8000000000000000, 0\n`; emit_align 16; `{emit_symbol "caml_absf_mask"}: .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF\n` end; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ` .data\n`; ` .globl {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin}:\n`; let lbl_begin = Compilenv.make_symbol (Some "code_begin") in ` .text\n`; ` .globl {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin}:\n`; if macosx then ` nop\n` (* PR#4690 *) let end_assembly() = let lbl_end = Compilenv.make_symbol (Some "code_end") in ` .text\n`; if macosx then ` nop\n`; (* suppress "ld warning: atom sorting error" *) ` .globl {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end}:\n`; ` .data\n`; let lbl_end = Compilenv.make_symbol (Some "data_end") in ` .globl {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end}:\n`; ` .long 0\n`; let lbl = Compilenv.make_symbol (Some "frametable") in ` .globl {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; emit_frames { efa_label = (fun l -> ` .quad {emit_label l}\n`); efa_16 = (fun n -> ` .word {emit_int n}\n`); efa_32 = (fun n -> ` .long {emit_int32 n}\n`); efa_word = (fun n -> ` .quad {emit_int n}\n`); efa_align = emit_align; efa_label_rel = if macosx then begin let setcnt = ref 0 in fun lbl ofs -> incr setcnt; ` .set L$set${emit_int !setcnt}, ({emit_label lbl} - .) + {emit_int32 ofs}\n`; ` .long L$set${emit_int !setcnt}\n` end else begin fun lbl ofs -> ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n` end; efa_def_label = (fun l -> `{emit_label l}:\n`); efa_string = (fun s -> emit_string_directive " .asciz " s) }; if Config.system = "linux" then (* Mark stack as non-executable, PR#4564 *) ` .section .note.GNU-stack,\"\",%progbits\n` mingw-ocaml/ocaml/asmcomp/emitaux.ml0000644000175000017500000001724612124403240017134 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Common functions for emitting assembly code *) open Debuginfo open Cmm open Reg open Linearize let output_channel = ref stdout let emit_string s = output_string !output_channel s let emit_int n = output_string !output_channel (string_of_int n) let emit_char c = output_char !output_channel c let emit_nativeint n = output_string !output_channel (Nativeint.to_string n) let emit_printf fmt = Printf.fprintf !output_channel fmt let emit_int32 n = emit_printf "0x%lx" n let emit_symbol esc s = for i = 0 to String.length s - 1 do let c = s.[i] in match c with 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> output_char !output_channel c | _ -> Printf.fprintf !output_channel "%c%02x" esc (Char.code c) done let emit_string_literal s = let last_was_escape = ref false in emit_string "\""; for i = 0 to String.length s - 1 do let c = s.[i] in if c >= '0' && c <= '9' then if !last_was_escape then Printf.fprintf !output_channel "\\%o" (Char.code c) else output_char !output_channel c else if c >= ' ' && c <= '~' && c <> '"' (* '"' *) && c <> '\\' then begin output_char !output_channel c; last_was_escape := false end else begin Printf.fprintf !output_channel "\\%o" (Char.code c); last_was_escape := true end done; emit_string "\"" let emit_string_directive directive s = let l = String.length s in if l = 0 then () else if l < 80 then begin emit_string directive; emit_string_literal s; emit_char '\n' end else begin let i = ref 0 in while !i < l do let n = min (l - !i) 80 in emit_string directive; emit_string_literal (String.sub s !i n); emit_char '\n'; i := !i + n done end let emit_bytes_directive directive s = let pos = ref 0 in for i = 0 to String.length s - 1 do if !pos = 0 then emit_string directive else emit_char ','; emit_int(Char.code s.[i]); incr pos; if !pos >= 16 then begin emit_char '\n'; pos := 0 end done; if !pos > 0 then emit_char '\n' (* PR#4813: assemblers do strange things with float literals indeed, so we convert to IEEE representation ourselves and emit float literals as 32- or 64-bit integers. *) let emit_float64_directive directive f = let x = Int64.bits_of_float (float_of_string f) in emit_printf "\t%s\t0x%Lx\n" directive x let emit_float64_split_directive directive f = let x = Int64.bits_of_float (float_of_string f) in let lo = Int64.logand x 0xFFFF_FFFFL and hi = Int64.shift_right_logical x 32 in emit_printf "\t%s\t0x%Lx, 0x%Lx\n" directive (if Arch.big_endian then hi else lo) (if Arch.big_endian then lo else hi) let emit_float32_directive directive f = let x = Int32.bits_of_float (float_of_string f) in emit_printf "\t%s\t0x%lx\n" directive x (* Record live pointers at call points *) type frame_descr = { fd_lbl: int; (* Return address *) fd_frame_size: int; (* Size of stack frame *) fd_live_offset: int list; (* Offsets/regs of live addresses *) fd_debuginfo: Debuginfo.t } (* Location, if any *) let frame_descriptors = ref([] : frame_descr list) type emit_frame_actions = { efa_label: int -> unit; efa_16: int -> unit; efa_32: int32 -> unit; efa_word: int -> unit; efa_align: int -> unit; efa_label_rel: int -> int32 -> unit; efa_def_label: int -> unit; efa_string: string -> unit } let emit_frames a = let filenames = Hashtbl.create 7 in let lbl_filenames = ref 200000 in let label_filename name = try Hashtbl.find filenames name with Not_found -> let lbl = !lbl_filenames in Hashtbl.add filenames name lbl; incr lbl_filenames; lbl in let emit_frame fd = a.efa_label fd.fd_lbl; a.efa_16 (if Debuginfo.is_none fd.fd_debuginfo then fd.fd_frame_size else fd.fd_frame_size + 1); a.efa_16 (List.length fd.fd_live_offset); List.iter a.efa_16 fd.fd_live_offset; a.efa_align Arch.size_addr; if not (Debuginfo.is_none fd.fd_debuginfo) then begin let d = fd.fd_debuginfo in let line = min 0xFFFFF d.dinfo_line and char_start = min 0xFF d.dinfo_char_start and char_end = min 0x3FF d.dinfo_char_end and kind = match d.dinfo_kind with Dinfo_call -> 0 | Dinfo_raise -> 1 in let info = Int64.add (Int64.shift_left (Int64.of_int line) 44) ( Int64.add (Int64.shift_left (Int64.of_int char_start) 36) ( Int64.add (Int64.shift_left (Int64.of_int char_end) 26) (Int64.of_int kind))) in a.efa_label_rel (label_filename d.dinfo_file) (Int64.to_int32 info); a.efa_32 (Int64.to_int32 (Int64.shift_right info 32)) end in let emit_filename name lbl = a.efa_def_label lbl; a.efa_string name; a.efa_align Arch.size_addr in a.efa_word (List.length !frame_descriptors); List.iter emit_frame !frame_descriptors; Hashtbl.iter emit_filename filenames; frame_descriptors := [] (* Detection of functions that can be duplicated between a DLL and the main program (PR#4690) *) let isprefix s1 s2 = String.length s1 <= String.length s2 && String.sub s2 0 (String.length s1) = s1 let is_generic_function name = List.exists (fun p -> isprefix p name) ["caml_apply"; "caml_curry"; "caml_send"; "caml_tuplify"] (* CFI directives *) let is_cfi_enabled () = Config.asm_cfi_supported let cfi_startproc () = if is_cfi_enabled () then emit_string "\t.cfi_startproc\n" let cfi_endproc () = if is_cfi_enabled () then emit_string "\t.cfi_endproc\n" let cfi_adjust_cfa_offset n = if is_cfi_enabled () then begin emit_string "\t.cfi_adjust_cfa_offset\t"; emit_int n; emit_string "\n"; end (* Emit debug information *) (* This assoc list is expected to be very short *) let file_pos_nums = (ref [] : (string * int) list ref) (* Number of files *) let file_pos_num_cnt = ref 1 (* Reset debug state at beginning of asm file *) let reset_debug_info () = file_pos_nums := []; file_pos_num_cnt := 1 (* We only diplay .file if the file has not been seen before. We display .loc for every instruction. *) let emit_debug_info dbg = if is_cfi_enabled () && !Clflags.debug && not (Debuginfo.is_none dbg) then begin let line = dbg.Debuginfo.dinfo_line in assert (line <> 0); (* clang errors out on zero line numbers *) let file_name = dbg.Debuginfo.dinfo_file in let file_num = try List.assoc file_name !file_pos_nums with Not_found -> let file_num = !file_pos_num_cnt in incr file_pos_num_cnt; emit_string "\t.file\t"; emit_int file_num; emit_char '\t'; emit_string_literal file_name; emit_char '\n'; file_pos_nums := (file_name,file_num) :: !file_pos_nums; file_num in emit_string "\t.loc\t"; emit_int file_num; emit_char '\t'; emit_int line; emit_char '\n' end mingw-ocaml/ocaml/asmcomp/coloring.mli0000644000175000017500000000164112124403240017435 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Register allocation by coloring of the interference graph *) val allocate_registers: unit -> unit mingw-ocaml/ocaml/asmcomp/codegen.mli0000644000175000017500000000222712124403240017226 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* From C-- to assembly code *) val phrase: Cmm.phrase -> unit val file: string -> unit val dump_cmm: bool ref val dump_selection: bool ref val dump_live: bool ref val dump_spill: bool ref val dump_split: bool ref val dump_interf: bool ref val dump_prefer: bool ref val dump_regalloc: bool ref val dump_reload: bool ref val dump_linear: bool ref mingw-ocaml/ocaml/asmcomp/clambda.mli0000644000175000017500000000527412124403240017212 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* A variant of the "lambda" code with direct / indirect calls explicit and closures explicit too *) open Asttypes open Lambda type function_label = string type ulambda = Uvar of Ident.t | Uconst of structured_constant * string option | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of ufunction list * ulambda list | Uoffset of ulambda * int | Ulet of Ident.t * ulambda * ulambda | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda | Uifthenelse of ulambda * ulambda * ulambda | Usequence of ulambda * ulambda | Uwhile of ulambda * ulambda | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda | Uassign of Ident.t * ulambda | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t and ufunction = { label : function_label; arity : int; params : Ident.t list; body : ulambda; dbg : Debuginfo.t; } and ulambda_switch = { us_index_consts: int array; us_actions_consts: ulambda array; us_index_blocks: int array; us_actions_blocks: ulambda array} (* Description of known functions *) type function_description = { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) mutable fun_inline: (Ident.t list * ulambda) option } (* Approximation of values *) type value_approximation = Value_closure of function_description * value_approximation | Value_tuple of value_approximation array | Value_unknown | Value_integer of int | Value_constptr of int mingw-ocaml/ocaml/asmcomp/cmm.mli0000644000175000017500000000643012124403240016376 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Second intermediate language (machine independent) *) type machtype_component = Addr | Int | Float type machtype = machtype_component array val typ_void: machtype val typ_addr: machtype val typ_int: machtype val typ_float: machtype val size_component: machtype_component -> int val size_machtype: machtype -> int type comparison = Ceq | Cne | Clt | Cle | Cgt | Cge val negate_comparison: comparison -> comparison val swap_comparison: comparison -> comparison type memory_chunk = Byte_unsigned | Byte_signed | Sixteen_unsigned | Sixteen_signed | Thirtytwo_unsigned | Thirtytwo_signed | Word | Single | Double (* 64-bit-aligned 64-bit float *) | Double_u (* word-aligned 64-bit float *) type operation = Capply of machtype * Debuginfo.t | Cextcall of string * machtype * bool * Debuginfo.t | Cload of memory_chunk | Calloc | Cstore of memory_chunk | Caddi | Csubi | Cmuli | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi of comparison | Cadda | Csuba | Ccmpa of comparison | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf of comparison | Craise of Debuginfo.t | Ccheckbound of Debuginfo.t type expression = Cconst_int of int | Cconst_natint of nativeint | Cconst_float of string | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint | Cvar of Ident.t | Clet of Ident.t * expression * expression | Cassign of Ident.t * expression | Ctuple of expression list | Cop of operation * expression list | Csequence of expression * expression | Cifthenelse of expression * expression * expression | Cswitch of expression * int array * expression array | Cloop of expression | Ccatch of int * Ident.t list * expression * expression | Cexit of int * expression list | Ctrywith of expression * Ident.t * expression type fundecl = { fun_name: string; fun_args: (Ident.t * machtype) list; fun_body: expression; fun_fast: bool; fun_dbg : Debuginfo.t; } type data_item = Cdefine_symbol of string | Cdefine_label of int | Cglobal_symbol of string | Cint8 of int | Cint16 of int | Cint32 of nativeint | Cint of nativeint | Csingle of string | Cdouble of string | Csymbol_address of string | Clabel_address of int | Cstring of string | Cskip of int | Calign of int type phrase = Cfunction of fundecl | Cdata of data_item list mingw-ocaml/ocaml/asmcomp/asmgen.mli0000644000175000017500000000222112124403240017066 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* From lambda to assembly code *) val compile_implementation : ?toplevel:(string -> bool) -> string -> Format.formatter -> int * Lambda.lambda -> unit val compile_phrase : Format.formatter -> Cmm.phrase -> unit type error = Assembler_error of string exception Error of error val report_error: Format.formatter -> error -> unit mingw-ocaml/ocaml/asmcomp/spill.mli0000644000175000017500000000171612124403240016747 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Insertion of moves to suggest possible spilling / reloading points before register allocation. *) val fundecl: Mach.fundecl -> Mach.fundecl mingw-ocaml/ocaml/asmcomp/scheduling.mli0000644000175000017500000000161512124403240017747 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Instruction scheduling *) val fundecl: Linearize.fundecl -> Linearize.fundecl mingw-ocaml/ocaml/asmcomp/codegen.ml0000644000175000017500000000632312124403240017056 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* From C-- to assembly code *) open Format open Cmm let dump_cmm = ref false let dump_selection = ref false let dump_live = ref false let dump_spill = ref false let dump_split = ref false let dump_interf = ref false let dump_prefer = ref false let dump_regalloc = ref false let dump_reload = ref false let dump_linear = ref false let rec regalloc fd = if !dump_live then Printmach.phase "Liveness analysis" fd; Interf.build_graph fd; if !dump_interf then Printmach.interferences(); if !dump_prefer then Printmach.preferences(); Coloring.allocate_registers(); if !dump_regalloc then Printmach.phase "After register allocation" fd; let (newfd, redo_regalloc) = Reload.fundecl fd in if !dump_reload then Printmach.phase "After insertion of reloading code" newfd; if redo_regalloc then begin Reg.reinit(); Liveness.fundecl newfd; regalloc newfd end else newfd let fundecl ppf fd_cmm = if !dump_cmm then begin fprintf ppf "*** C-- code@."; fprintf ppf "%a@." Printcmm.fundecl fd_cmm end; Reg.reset(); let fd_sel = Sequence.fundecl fd_cmm in if !dump_selection then Printmach.phase "After instruction selection" fd_sel; Liveness.fundecl fd_sel; if !dump_live then Printmach.phase "Liveness analysis" fd_sel; let fd_spill = Spill.fundecl fd_sel in Liveness.fundecl fd_spill; if !dump_spill then Printmach.phase "After spilling" fd_spill; let fd_split = Split.fundecl fd_spill in Liveness.fundecl fd_split; if !dump_split then Printmach.phase "After live range splitting" fd_split; let fd_reload = regalloc fd_split in let fd_linear = Linearize.fundecl fd_reload in if !dump_linear then begin printf "*** Linearized code@."; Printlinear.fundecl fd_linear; print_newline() end; Emit.fundecl fd_linear let phrase = function Cfunction fd -> fundecl fd | Cdata dl -> Emit.data dl let file filename = let ic = open_in filename in let lb = Lexing.from_channel ic in try while true do phrase(Parsecmm.phrase Lexcmm.token lb) done with End_of_file -> close_in ic | Lexcmm.Error msg -> close_in ic; Lexcmm.report_error lb msg | Parsing.Parse_error -> close_in ic; prerr_string "Syntax error near character "; prerr_int (Lexing.lexeme_start lb); prerr_newline() | Parsecmmaux.Error msg -> close_in ic; Parsecmmaux.report_error msg | x -> close_in ic; raise x mingw-ocaml/ocaml/asmcomp/schedgen.mli0000644000175000017500000000421412124403240017400 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Instruction scheduling *) type code_dag_node = { instr: Linearize.instruction; delay: int; mutable sons: (code_dag_node * int) list; mutable date: int; mutable length: int; mutable ancestors: int; mutable emitted_ancestors: int } class virtual scheduler_generic : object (* Can be overridden by processor description *) method virtual oper_issue_cycles : Mach.operation -> int (* Number of cycles needed to issue the given operation *) method virtual oper_latency : Mach.operation -> int (* Number of cycles needed to complete the given operation *) method reload_retaddr_issue_cycles : int (* Number of cycles needed to issue a Lreloadretaddr operation *) method reload_retaddr_latency : int (* Number of cycles needed to complete a Lreloadretaddr operation *) method oper_in_basic_block : Mach.operation -> bool (* Says whether the given operation terminates a basic block *) method is_store : Mach.operation -> bool (* Says whether the given operation is a memory store *) method is_load : Mach.operation -> bool (* Says whether the given operation is a memory load *) method is_checkbound : Mach.operation -> bool (* Says whether the given operation is a checkbound *) (* Entry point *) method schedule_fundecl : Linearize.fundecl -> Linearize.fundecl end mingw-ocaml/ocaml/asmcomp/liveness.ml0000644000175000017500000001127212124403240017301 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Liveness analysis. Annotate mach code with the set of regs live at each point. *) open Mach let live_at_exit = ref [] let find_live_at_exit k = try List.assoc k !live_at_exit with | Not_found -> Misc.fatal_error "Spill.find_live_at_exit" let live_at_break = ref Reg.Set.empty let live_at_raise = ref Reg.Set.empty let rec live i finally = (* finally is the set of registers live after execution of the instruction sequence. The result of the function is the set of registers live just before the instruction sequence. The instruction i is annotated by the set of registers live across the instruction. *) match i.desc with Iend -> i.live <- finally; finally | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> (* i.live remains empty since no regs are live across *) Reg.set_of_array i.arg | Iifthenelse(test, ifso, ifnot) -> let at_join = live i.next finally in let at_fork = Reg.Set.union (live ifso at_join) (live ifnot at_join) in i.live <- at_fork; Reg.add_set_array at_fork i.arg | Iswitch(index, cases) -> let at_join = live i.next finally in let at_fork = ref Reg.Set.empty in for i = 0 to Array.length cases - 1 do at_fork := Reg.Set.union !at_fork (live cases.(i) at_join) done; i.live <- !at_fork; Reg.add_set_array !at_fork i.arg | Iloop(body) -> let at_top = ref Reg.Set.empty in (* Yes, there are better algorithms, but we'll just iterate till reaching a fixpoint. *) begin try while true do let new_at_top = Reg.Set.union !at_top (live body !at_top) in if Reg.Set.equal !at_top new_at_top then raise Exit; at_top := new_at_top done with Exit -> () end; i.live <- !at_top; !at_top | Icatch(nfail, body, handler) -> let at_join = live i.next finally in let before_handler = live handler at_join in let before_body = live_at_exit := (nfail,before_handler) :: !live_at_exit ; let before_body = live body at_join in live_at_exit := List.tl !live_at_exit ; before_body in i.live <- before_body; before_body | Iexit nfail -> let this_live = find_live_at_exit nfail in i.live <- this_live ; this_live | Itrywith(body, handler) -> let at_join = live i.next finally in let before_handler = live handler at_join in let saved_live_at_raise = !live_at_raise in live_at_raise := Reg.Set.remove Proc.loc_exn_bucket before_handler; let before_body = live body at_join in live_at_raise := saved_live_at_raise; i.live <- before_body; before_body | Iraise -> (* i.live remains empty since no regs are live across *) Reg.add_set_array !live_at_raise i.arg | _ -> let across_after = Reg.diff_set_array (live i.next finally) i.res in let across = match i.desc with Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _) | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> (* The function call may raise an exception, branching to the nearest enclosing try ... with. Similarly for bounds checks. Hence, everything that must be live at the beginning of the exception handler must also be live across this instr. *) Reg.Set.union across_after !live_at_raise | _ -> across_after in i.live <- across; Reg.add_set_array across i.arg let fundecl ppf f = let initially_live = live f.fun_body Reg.Set.empty in (* Sanity check: only function parameters can be live at entrypoint *) let wrong_live = Reg.Set.diff initially_live (Reg.set_of_array f.fun_args) in if not (Reg.Set.is_empty wrong_live) then begin Format.fprintf ppf "%a@." Printmach.regset wrong_live; Misc.fatal_error "Liveness.fundecl" end mingw-ocaml/ocaml/asmcomp/linearize.ml0000644000175000017500000002126212124403240017433 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Transformation of Mach code into a list of pseudo-instructions. *) open Reg open Mach type label = int let label_counter = ref 99 let new_label() = incr label_counter; !label_counter type instruction = { mutable desc: instruction_desc; mutable next: instruction; arg: Reg.t array; res: Reg.t array; dbg: Debuginfo.t; live: Reg.Set.t } and instruction_desc = Lend | Lop of operation | Lreloadretaddr | Lreturn | Llabel of label | Lbranch of label | Lcondbranch of test * label | Lcondbranch3 of label option * label option * label option | Lswitch of label array | Lsetuptrap of label | Lpushtrap | Lpoptrap | Lraise let has_fallthrough = function | Lreturn | Lbranch _ | Lswitch _ | Lraise | Lop Itailcall_ind | Lop (Itailcall_imm _) -> false | _ -> true type fundecl = { fun_name: string; fun_body: instruction; fun_fast: bool; fun_dbg : Debuginfo.t } (* Invert a test *) let invert_integer_test = function Isigned cmp -> Isigned(Cmm.negate_comparison cmp) | Iunsigned cmp -> Iunsigned(Cmm.negate_comparison cmp) let invert_test = function Itruetest -> Ifalsetest | Ifalsetest -> Itruetest | Iinttest(cmp) -> Iinttest(invert_integer_test cmp) | Iinttest_imm(cmp, n) -> Iinttest_imm(invert_integer_test cmp, n) | Ifloattest(cmp, neg) -> Ifloattest(cmp, not neg) | Ieventest -> Ioddtest | Ioddtest -> Ieventest (* The "end" instruction *) let rec end_instr = { desc = Lend; next = end_instr; arg = [||]; res = [||]; dbg = Debuginfo.none; live = Reg.Set.empty } (* Cons an instruction (live, debug empty) *) let instr_cons d a r n = { desc = d; next = n; arg = a; res = r; dbg = Debuginfo.none; live = Reg.Set.empty } (* Cons a simple instruction (arg, res, live empty) *) let cons_instr d n = { desc = d; next = n; arg = [||]; res = [||]; dbg = Debuginfo.none; live = Reg.Set.empty } (* Build an instruction with arg, res, dbg, live taken from the given Mach.instruction *) let copy_instr d i n = { desc = d; next = n; arg = i.Mach.arg; res = i.Mach.res; dbg = i.Mach.dbg; live = i.Mach.live } (* Label the beginning of the given instruction sequence. - If the sequence starts with a branch, jump over it. - If the sequence is the end, (tail call position), just do nothing *) let get_label n = match n.desc with Lbranch lbl -> (lbl, n) | Llabel lbl -> (lbl, n) | Lend -> (-1, n) | _ -> let lbl = new_label() in (lbl, cons_instr (Llabel lbl) n) (* Check the fallthrough label *) let check_label n = match n.desc with | Lbranch lbl -> lbl | Llabel lbl -> lbl | _ -> -1 (* Discard all instructions up to the next label. This function is to be called before adding a non-terminating instruction. *) let rec discard_dead_code n = match n.desc with Lend -> n | Llabel _ -> n (* Do not discard Lpoptrap or Istackoffset instructions, as this may cause a stack imbalance later during assembler generation. *) | Lpoptrap -> n | Lop(Istackoffset _) -> n | _ -> discard_dead_code n.next (* Add a branch in front of a continuation. Discard dead code in the continuation. Does not insert anything if we're just falling through or if we jump to dead code after the end of function (lbl=-1) *) let add_branch lbl n = if lbl >= 0 then let n1 = discard_dead_code n in match n1.desc with | Llabel lbl1 when lbl1 = lbl -> n1 | _ -> cons_instr (Lbranch lbl) n1 else discard_dead_code n (* Current labels for exit handler *) let exit_label = ref [] let find_exit_label k = try List.assoc k !exit_label with | Not_found -> Misc.fatal_error "Linearize.find_exit_label" let is_next_catch n = match !exit_label with | (n0,_)::_ when n0=n -> true | _ -> false (* Linearize an instruction [i]: add it in front of the continuation [n] *) let rec linear i n = match i.Mach.desc with Iend -> n | Iop(Itailcall_ind | Itailcall_imm _ as op) -> copy_instr (Lop op) i (discard_dead_code n) | Iop(Imove | Ireload | Ispill) when i.Mach.arg.(0).loc = i.Mach.res.(0).loc -> linear i.Mach.next n | Iop op -> copy_instr (Lop op) i (linear i.Mach.next n) | Ireturn -> let n1 = copy_instr Lreturn i (discard_dead_code n) in if !Proc.contains_calls then cons_instr Lreloadretaddr n1 else n1 | Iifthenelse(test, ifso, ifnot) -> let n1 = linear i.Mach.next n in begin match (ifso.Mach.desc, ifnot.Mach.desc, n1.desc) with Iend, _, Lbranch lbl -> copy_instr (Lcondbranch(test, lbl)) i (linear ifnot n1) | _, Iend, Lbranch lbl -> copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1) | Iexit nfail1, Iexit nfail2, _ when is_next_catch nfail1 -> let lbl2 = find_exit_label nfail2 in copy_instr (Lcondbranch (invert_test test, lbl2)) i (linear ifso n1) | Iexit nfail, _, _ -> let n2 = linear ifnot n1 and lbl = find_exit_label nfail in copy_instr (Lcondbranch(test, lbl)) i n2 | _, Iexit nfail, _ -> let n2 = linear ifso n1 in let lbl = find_exit_label nfail in copy_instr (Lcondbranch(invert_test test, lbl)) i n2 | Iend, _, _ -> let (lbl_end, n2) = get_label n1 in copy_instr (Lcondbranch(test, lbl_end)) i (linear ifnot n2) | _, Iend, _ -> let (lbl_end, n2) = get_label n1 in copy_instr (Lcondbranch(invert_test test, lbl_end)) i (linear ifso n2) | _, _, _ -> (* Should attempt branch prediction here *) let (lbl_end, n2) = get_label n1 in let (lbl_else, nelse) = get_label (linear ifnot n2) in copy_instr (Lcondbranch(invert_test test, lbl_else)) i (linear ifso (add_branch lbl_end nelse)) end | Iswitch(index, cases) -> let lbl_cases = Array.create (Array.length cases) 0 in let (lbl_end, n1) = get_label(linear i.Mach.next n) in let n2 = ref (discard_dead_code n1) in for i = Array.length cases - 1 downto 0 do let (lbl_case, ncase) = get_label(linear cases.(i) (add_branch lbl_end !n2)) in lbl_cases.(i) <- lbl_case; n2 := discard_dead_code ncase done; (* Switches with 1 and 2 branches have been eliminated earlier. Here, we do something for switches with 3 branches. *) if Array.length index = 3 then begin let fallthrough_lbl = check_label !n2 in let find_label n = let lbl = lbl_cases.(index.(n)) in if lbl = fallthrough_lbl then None else Some lbl in copy_instr (Lcondbranch3(find_label 0, find_label 1, find_label 2)) i !n2 end else copy_instr (Lswitch(Array.map (fun n -> lbl_cases.(n)) index)) i !n2 | Iloop body -> let lbl_head = new_label() in let n1 = linear i.Mach.next n in let n2 = linear body (cons_instr (Lbranch lbl_head) n1) in cons_instr (Llabel lbl_head) n2 | Icatch(io, body, handler) -> let (lbl_end, n1) = get_label(linear i.Mach.next n) in let (lbl_handler, n2) = get_label(linear handler n1) in exit_label := (io, lbl_handler) :: !exit_label ; let n3 = linear body (add_branch lbl_end n2) in exit_label := List.tl !exit_label; n3 | Iexit nfail -> let n1 = linear i.Mach.next n in let lbl = find_exit_label nfail in add_branch lbl n1 | Itrywith(body, handler) -> let (lbl_join, n1) = get_label (linear i.Mach.next n) in let (lbl_body, n2) = get_label (cons_instr Lpushtrap (linear body (cons_instr Lpoptrap n1))) in cons_instr (Lsetuptrap lbl_body) (linear handler (add_branch lbl_join n2)) | Iraise -> copy_instr Lraise i (discard_dead_code n) let fundecl f = { fun_name = f.Mach.fun_name; fun_body = linear f.Mach.fun_body end_instr; fun_fast = f.Mach.fun_fast; fun_dbg = f.Mach.fun_dbg } mingw-ocaml/ocaml/asmcomp/cmmgen.mli0000644000175000017500000000310212124403240017061 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Translation from closed lambda to C-- *) val compunit: int -> Clambda.ulambda -> Cmm.phrase list val apply_function: int -> Cmm.phrase val send_function: int -> Cmm.phrase val curry_function: int -> Cmm.phrase list val generic_functions: bool -> Cmx_format.unit_infos list -> Cmm.phrase list val entry_point: string list -> Cmm.phrase val global_table: string list -> Cmm.phrase val reference_symbols: string list -> Cmm.phrase val globals_map: (string * Digest.t * Digest.t * string list) list -> Cmm.phrase val frame_table: string list -> Cmm.phrase val data_segment_table: string list -> Cmm.phrase val code_segment_table: string list -> Cmm.phrase val predef_exception: string -> Cmm.phrase val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase mingw-ocaml/ocaml/asmcomp/asmlink.ml0000644000175000017500000003353612124403240017116 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Link a set of .cmx/.o files and produce an executable *) open Sys open Misc open Config open Cmx_format open Compilenv type error = File_not_found of string | Not_an_object_file of string | Missing_implementations of (string * string list) list | Inconsistent_interface of string * string * string | Inconsistent_implementation of string * string * string | Assembler_error of string | Linking_error | Multiple_definition of string * string * string | Missing_cmx of string * string exception Error of error (* Consistency check between interfaces and implementations *) let crc_interfaces = Consistbl.create () let crc_implementations = Consistbl.create () let extra_implementations = ref ([] : string list) let implementations_defined = ref ([] : (string * string) list) let cmx_required = ref ([] : string list) let check_consistency file_name unit crc = begin try List.iter (fun (name, crc) -> if name = unit.ui_name then Consistbl.set crc_interfaces name crc file_name else Consistbl.check crc_interfaces name crc file_name) unit.ui_imports_cmi with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_interface(name, user, auth))) end; begin try List.iter (fun (name, crc) -> if crc <> cmx_not_found_crc then Consistbl.check crc_implementations name crc file_name else if List.mem name !cmx_required then raise(Error(Missing_cmx(file_name, name))) else extra_implementations := name :: !extra_implementations) unit.ui_imports_cmx with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_implementation(name, user, auth))) end; begin try let source = List.assoc unit.ui_name !implementations_defined in raise (Error(Multiple_definition(unit.ui_name, file_name, source))) with Not_found -> () end; Consistbl.set crc_implementations unit.ui_name crc file_name; implementations_defined := (unit.ui_name, file_name) :: !implementations_defined; if unit.ui_symbol <> unit.ui_name then cmx_required := unit.ui_name :: !cmx_required let extract_crc_interfaces () = Consistbl.extract crc_interfaces let extract_crc_implementations () = List.fold_left (fun ncl n -> if List.mem_assoc n ncl then ncl else (n, cmx_not_found_crc) :: ncl) (Consistbl.extract crc_implementations) !extra_implementations (* Add C objects and options and "custom" info from a library descriptor. See bytecomp/bytelink.ml for comments on the order of C objects. *) let lib_ccobjs = ref [] let lib_ccopts = ref [] let add_ccobjs l = if not !Clflags.no_auto_link then begin lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs; lib_ccopts := l.lib_ccopts @ !lib_ccopts end let runtime_lib () = let libname = if !Clflags.gprofile then "libasmrunp" ^ ext_lib else "libasmrun" ^ !Clflags.runtime_variant ^ ext_lib in try if !Clflags.nopervasives then [] else [ find_in_path !load_path libname ] with Not_found -> raise(Error(File_not_found libname)) let object_file_name name = let file_name = try find_in_path !load_path name with Not_found -> fatal_error "Asmlink.object_file_name: not found" in if Filename.check_suffix file_name ".cmx" then Filename.chop_suffix file_name ".cmx" ^ ext_obj else if Filename.check_suffix file_name ".cmxa" then Filename.chop_suffix file_name ".cmxa" ^ ext_lib else fatal_error "Asmlink.object_file_name: bad ext" (* First pass: determine which units are needed *) let missing_globals = (Hashtbl.create 17 : (string, string list ref) Hashtbl.t) let is_required name = try ignore (Hashtbl.find missing_globals name); true with Not_found -> false let add_required by (name, crc) = try let rq = Hashtbl.find missing_globals name in rq := by :: !rq with Not_found -> Hashtbl.add missing_globals name (ref [by]) let remove_required name = Hashtbl.remove missing_globals name let extract_missing_globals () = let mg = ref [] in Hashtbl.iter (fun md rq -> mg := (md, !rq) :: !mg) missing_globals; !mg type file = | Unit of string * unit_infos * Digest.t | Library of string * library_infos let read_file obj_name = let file_name = try find_in_path !load_path obj_name with Not_found -> raise(Error(File_not_found obj_name)) in if Filename.check_suffix file_name ".cmx" then begin (* This is a .cmx file. It must be linked in any case. Read the infos to see which modules it requires. *) let (info, crc) = read_unit_info file_name in Unit (file_name,info,crc) end else if Filename.check_suffix file_name ".cmxa" then begin let infos = try read_library_info file_name with Compilenv.Error(Not_a_unit_info _) -> raise(Error(Not_an_object_file file_name)) in Library (file_name,infos) end else raise(Error(Not_an_object_file file_name)) let scan_file obj_name tolink = match read_file obj_name with | Unit (file_name,info,crc) -> (* This is a .cmx file. It must be linked in any case. *) remove_required info.ui_name; List.iter (add_required file_name) info.ui_imports_cmx; (info, file_name, crc) :: tolink | Library (file_name,infos) -> (* This is an archive file. Each unit contained in it will be linked in only if needed. *) add_ccobjs infos; List.fold_right (fun (info, crc) reqd -> if info.ui_force_link || !Clflags.link_everything || is_required info.ui_name then begin remove_required info.ui_name; List.iter (add_required (Printf.sprintf "%s(%s)" file_name info.ui_name)) info.ui_imports_cmx; (info, file_name, crc) :: reqd end else reqd) infos.lib_units tolink (* Second pass: generate the startup file and link it with everything else *) let make_startup_file ppf filename units_list = let compile_phrase p = Asmgen.compile_phrase ppf p in let oc = open_out filename in Emitaux.output_channel := oc; Location.input_name := "caml_startup"; (* set name of "current" input *) Compilenv.reset "_startup"; (* set the name of the "current" compunit *) Emit.begin_assembly(); let name_list = List.flatten (List.map (fun (info,_,_) -> info.ui_defines) units_list) in compile_phrase (Cmmgen.entry_point name_list); let units = List.map (fun (info,_,_) -> info) units_list in List.iter compile_phrase (Cmmgen.generic_functions false units); Array.iter (fun name -> compile_phrase (Cmmgen.predef_exception name)) Runtimedef.builtin_exceptions; compile_phrase (Cmmgen.global_table name_list); compile_phrase (Cmmgen.globals_map (List.map (fun (unit,_,crc) -> try (unit.ui_name, List.assoc unit.ui_name unit.ui_imports_cmi, crc, unit.ui_defines) with Not_found -> assert false) units_list)); compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list)); compile_phrase(Cmmgen.code_segment_table ("_startup" :: name_list)); compile_phrase (Cmmgen.frame_table("_startup" :: "_system" :: name_list)); Emit.end_assembly(); close_out oc let make_shared_startup_file ppf units filename = let compile_phrase p = Asmgen.compile_phrase ppf p in let oc = open_out filename in Emitaux.output_channel := oc; Location.input_name := "caml_startup"; Compilenv.reset "_shared_startup"; Emit.begin_assembly(); List.iter compile_phrase (Cmmgen.generic_functions true (List.map fst units)); compile_phrase (Cmmgen.plugin_header units); compile_phrase (Cmmgen.global_table (List.map (fun (ui,_) -> ui.ui_symbol) units)); (* this is to force a reference to all units, otherwise the linker might drop some of them (in case of libraries) *) Emit.end_assembly(); close_out oc let call_linker_shared file_list output_name = if not (Ccomp.call_linker Ccomp.Dll output_name file_list "") then raise(Error Linking_error) let link_shared ppf objfiles output_name = let units_tolink = List.fold_right scan_file objfiles [] in List.iter (fun (info, file_name, crc) -> check_consistency file_name info crc) units_tolink; Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts; let objfiles = List.rev (List.map object_file_name objfiles) @ (List.rev !Clflags.ccobjs) in let startup = if !Clflags.keep_startup_file then output_name ^ ".startup" ^ ext_asm else Filename.temp_file "camlstartup" ext_asm in make_shared_startup_file ppf (List.map (fun (ui,_,crc) -> (ui,crc)) units_tolink) startup; let startup_obj = output_name ^ ".startup" ^ ext_obj in if Proc.assemble_file startup startup_obj <> 0 then raise(Error(Assembler_error startup)); if not !Clflags.keep_startup_file then remove_file startup; call_linker_shared (startup_obj :: objfiles) output_name; remove_file startup_obj let call_linker file_list startup_file output_name = let main_dll = !Clflags.output_c_object && Filename.check_suffix output_name Config.ext_dll in let files = startup_file :: (List.rev file_list) in let files, c_lib = if (not !Clflags.output_c_object) || main_dll then files @ (List.rev !Clflags.ccobjs) @ runtime_lib (), (if !Clflags.nopervasives then "" else Config.native_c_libraries) else files, "" in let mode = if main_dll then Ccomp.MainDll else if !Clflags.output_c_object then Ccomp.Partial else Ccomp.Exe in if not (Ccomp.call_linker mode output_name files c_lib) then raise(Error Linking_error) (* Main entry point *) let link ppf objfiles output_name = let stdlib = if !Clflags.gprofile then "stdlib.p.cmxa" else "stdlib.cmxa" in let stdexit = if !Clflags.gprofile then "std_exit.p.cmx" else "std_exit.cmx" in let objfiles = if !Clflags.nopervasives then objfiles else if !Clflags.output_c_object then stdlib :: objfiles else stdlib :: (objfiles @ [stdexit]) in let units_tolink = List.fold_right scan_file objfiles [] in Array.iter remove_required Runtimedef.builtin_exceptions; begin match extract_missing_globals() with [] -> () | mg -> raise(Error(Missing_implementations mg)) end; List.iter (fun (info, file_name, crc) -> check_consistency file_name info crc) units_tolink; Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts; (* put user's opts first *) let startup = if !Clflags.keep_startup_file then output_name ^ ".startup" ^ ext_asm else Filename.temp_file "camlstartup" ext_asm in make_startup_file ppf startup units_tolink; let startup_obj = Filename.temp_file "camlstartup" ext_obj in if Proc.assemble_file startup startup_obj <> 0 then raise(Error(Assembler_error startup)); try call_linker (List.map object_file_name objfiles) startup_obj output_name; if not !Clflags.keep_startup_file then remove_file startup; remove_file startup_obj with x -> remove_file startup_obj; raise x (* Error report *) open Format let report_error ppf = function | File_not_found name -> fprintf ppf "Cannot find file %s" name | Not_an_object_file name -> fprintf ppf "The file %a is not a compilation unit description" Location.print_filename name | Missing_implementations l -> let print_references ppf = function | [] -> () | r1 :: rl -> fprintf ppf "%s" r1; List.iter (fun r -> fprintf ppf ",@ %s" r) rl in let print_modules ppf = List.iter (fun (md, rq) -> fprintf ppf "@ @[%s referenced from %a@]" md print_references rq) in fprintf ppf "@[No implementations provided for the following modules:%a@]" print_modules l | Inconsistent_interface(intf, file1, file2) -> fprintf ppf "@[Files %a@ and %a@ make inconsistent assumptions \ over interface %s@]" Location.print_filename file1 Location.print_filename file2 intf | Inconsistent_implementation(intf, file1, file2) -> fprintf ppf "@[Files %a@ and %a@ make inconsistent assumptions \ over implementation %s@]" Location.print_filename file1 Location.print_filename file2 intf | Assembler_error file -> fprintf ppf "Error while assembling %a" Location.print_filename file | Linking_error -> fprintf ppf "Error during linking" | Multiple_definition(modname, file1, file2) -> fprintf ppf "@[Files %a@ and %a@ both define a module named %s@]" Location.print_filename file1 Location.print_filename file2 modname | Missing_cmx(filename, name) -> fprintf ppf "@[File %a@ was compiled without access@ \ to the .cmx file@ for module %s,@ \ which was produced by `ocamlopt -for-pack'.@ \ Please recompile %a@ with the correct `-I' option@ \ so that %s.cmx@ is found.@]" Location.print_filename filename name Location.print_filename filename name mingw-ocaml/ocaml/asmcomp/cmm.ml0000644000175000017500000000667312124403240016236 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) type machtype_component = Addr | Int | Float type machtype = machtype_component array let typ_void = ([||] : machtype_component array) let typ_addr = [|Addr|] let typ_int = [|Int|] let typ_float = [|Float|] let size_component = function Addr -> Arch.size_addr | Int -> Arch.size_int | Float -> Arch.size_float let size_machtype mty = let size = ref 0 in for i = 0 to Array.length mty - 1 do size := !size + size_component mty.(i) done; !size type comparison = Ceq | Cne | Clt | Cle | Cgt | Cge let negate_comparison = function Ceq -> Cne | Cne -> Ceq | Clt -> Cge | Cle -> Cgt | Cgt -> Cle | Cge -> Clt let swap_comparison = function Ceq -> Ceq | Cne -> Cne | Clt -> Cgt | Cle -> Cge | Cgt -> Clt | Cge -> Cle type memory_chunk = Byte_unsigned | Byte_signed | Sixteen_unsigned | Sixteen_signed | Thirtytwo_unsigned | Thirtytwo_signed | Word | Single | Double | Double_u type operation = Capply of machtype * Debuginfo.t | Cextcall of string * machtype * bool * Debuginfo.t | Cload of memory_chunk | Calloc | Cstore of memory_chunk | Caddi | Csubi | Cmuli | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi of comparison | Cadda | Csuba | Ccmpa of comparison | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf of comparison | Craise of Debuginfo.t | Ccheckbound of Debuginfo.t type expression = Cconst_int of int | Cconst_natint of nativeint | Cconst_float of string | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint | Cvar of Ident.t | Clet of Ident.t * expression * expression | Cassign of Ident.t * expression | Ctuple of expression list | Cop of operation * expression list | Csequence of expression * expression | Cifthenelse of expression * expression * expression | Cswitch of expression * int array * expression array | Cloop of expression | Ccatch of int * Ident.t list * expression * expression | Cexit of int * expression list | Ctrywith of expression * Ident.t * expression type fundecl = { fun_name: string; fun_args: (Ident.t * machtype) list; fun_body: expression; fun_fast: bool; fun_dbg : Debuginfo.t; } type data_item = Cdefine_symbol of string | Cdefine_label of int | Cglobal_symbol of string | Cint8 of int | Cint16 of int | Cint32 of nativeint | Cint of nativeint | Csingle of string | Cdouble of string | Csymbol_address of string | Clabel_address of int | Cstring of string | Cskip of int | Calign of int type phrase = Cfunction of fundecl | Cdata of data_item list mingw-ocaml/ocaml/asmcomp/interf.ml0000644000175000017500000001332512124403240016741 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Construction of the interference graph. Annotate pseudoregs with interference lists and preference lists. *) module IntPairSet = Set.Make(struct type t = int * int let compare = compare end) open Misc open Reg open Mach let build_graph fundecl = (* The interference graph is represented in two ways: - by adjacency lists for each register - by a sparse bit matrix (a set of pairs of register stamps) *) let mat = ref IntPairSet.empty in (* Record an interference between two registers *) let add_interf ri rj = let i = ri.stamp and j = rj.stamp in if i <> j then begin let p = if i < j then (i, j) else (j, i) in if not(IntPairSet.mem p !mat) then begin mat := IntPairSet.add p !mat; if ri.loc = Unknown then ri.interf <- rj :: ri.interf; if rj.loc = Unknown then rj.interf <- ri :: rj.interf end end in (* Record interferences between a register array and a set of registers *) let add_interf_set v s = for i = 0 to Array.length v - 1 do let r1 = v.(i) in Reg.Set.iter (add_interf r1) s done in (* Record interferences between elements of an array *) let add_interf_self v = for i = 0 to Array.length v - 2 do let ri = v.(i) in for j = i+1 to Array.length v - 1 do add_interf ri v.(j) done done in (* Record interferences between the destination of a move and a set of live registers. Since the destination is equal to the source, do not add an interference between them if the source is still live afterwards. *) let add_interf_move src dst s = Reg.Set.iter (fun r -> if r.stamp <> src.stamp then add_interf dst r) s in (* Compute interferences *) let rec interf i = let destroyed = Proc.destroyed_at_oper i.desc in if Array.length destroyed > 0 then add_interf_set destroyed i.live; match i.desc with Iend -> () | Ireturn -> () | Iop(Imove | Ispill | Ireload) -> add_interf_move i.arg.(0) i.res.(0) i.live; interf i.next | Iop(Itailcall_ind) -> () | Iop(Itailcall_imm lbl) -> () | Iop op -> add_interf_set i.res i.live; add_interf_self i.res; interf i.next | Iifthenelse(tst, ifso, ifnot) -> interf ifso; interf ifnot; interf i.next | Iswitch(index, cases) -> for i = 0 to Array.length cases - 1 do interf cases.(i) done; interf i.next | Iloop body -> interf body; interf i.next | Icatch(_, body, handler) -> interf body; interf handler; interf i.next | Iexit _ -> () | Itrywith(body, handler) -> add_interf_set Proc.destroyed_at_raise handler.live; interf body; interf handler; interf i.next | Iraise -> () in (* Add a preference from one reg to another. Do not add anything if the two registers conflict, or if the source register already has a location. *) let add_pref weight r1 r2 = if weight > 0 then begin let i = r1.stamp and j = r2.stamp in if i <> j && r1.loc = Unknown && (let p = if i < j then (i, j) else (j, i) in not (IntPairSet.mem p !mat)) then r1.prefer <- (r2, weight) :: r1.prefer end in (* Add a mutual preference between two regs *) let add_mutual_pref weight r1 r2 = add_pref weight r1 r2; add_pref weight r2 r1 in (* Update the spill cost of the registers involved in an operation *) let add_spill_cost cost arg = for i = 0 to Array.length arg - 1 do let r = arg.(i) in r.spill_cost <- r.spill_cost + cost done in (* Compute preferences and spill costs *) let rec prefer weight i = add_spill_cost weight i.arg; add_spill_cost weight i.res; match i.desc with Iend -> () | Ireturn -> () | Iop(Imove) -> add_mutual_pref weight i.arg.(0) i.res.(0); prefer weight i.next | Iop(Ispill) -> add_pref (weight / 4) i.arg.(0) i.res.(0); prefer weight i.next | Iop(Ireload) -> add_pref (weight / 4) i.res.(0) i.arg.(0); prefer weight i.next | Iop(Itailcall_ind) -> () | Iop(Itailcall_imm lbl) -> () | Iop op -> prefer weight i.next | Iifthenelse(tst, ifso, ifnot) -> prefer (weight / 2) ifso; prefer (weight / 2) ifnot; prefer weight i.next | Iswitch(index, cases) -> for i = 0 to Array.length cases - 1 do prefer (weight / 2) cases.(i) done; prefer weight i.next | Iloop body -> (* Avoid overflow of weight and spill_cost *) prefer (if weight < 1000 then 8 * weight else weight) body; prefer weight i.next | Icatch(_, body, handler) -> prefer weight body; prefer weight handler; prefer weight i.next | Iexit _ -> () | Itrywith(body, handler) -> prefer weight body; prefer weight handler; prefer weight i.next | Iraise -> () in interf fundecl.fun_body; prefer 8 fundecl.fun_body mingw-ocaml/ocaml/asmcomp/printcmm.mli0000644000175000017500000000245612124403240017457 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Pretty-printing of C-- code *) open Format val machtype_component : formatter -> Cmm.machtype_component -> unit val machtype : formatter -> Cmm.machtype_component array -> unit val comparison : Cmm.comparison -> string val chunk : Cmm.memory_chunk -> string val operation : Cmm.operation -> string val expression : formatter -> Cmm.expression -> unit val fundecl : formatter -> Cmm.fundecl -> unit val data : formatter -> Cmm.data_item list -> unit val phrase : formatter -> Cmm.phrase -> unit mingw-ocaml/ocaml/asmcomp/liveness.mli0000644000175000017500000000172012124403240017447 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Liveness analysis. Annotate mach code with the set of regs live at each point. *) open Format val fundecl: formatter -> Mach.fundecl -> unit mingw-ocaml/ocaml/asmcomp/clambda.ml0000644000175000017500000000527412124403240017041 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* A variant of the "lambda" code with direct / indirect calls explicit and closures explicit too *) open Asttypes open Lambda type function_label = string type ulambda = Uvar of Ident.t | Uconst of structured_constant * string option | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of ufunction list * ulambda list | Uoffset of ulambda * int | Ulet of Ident.t * ulambda * ulambda | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda | Uifthenelse of ulambda * ulambda * ulambda | Usequence of ulambda * ulambda | Uwhile of ulambda * ulambda | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda | Uassign of Ident.t * ulambda | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t and ufunction = { label : function_label; arity : int; params : Ident.t list; body : ulambda; dbg : Debuginfo.t } and ulambda_switch = { us_index_consts: int array; us_actions_consts : ulambda array; us_index_blocks: int array; us_actions_blocks: ulambda array} (* Description of known functions *) type function_description = { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) mutable fun_inline: (Ident.t list * ulambda) option } (* Approximation of values *) type value_approximation = Value_closure of function_description * value_approximation | Value_tuple of value_approximation array | Value_unknown | Value_integer of int | Value_constptr of int mingw-ocaml/ocaml/asmcomp/interf.mli0000644000175000017500000000172512124403240017113 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Construction of the interference graph. Annotate pseudoregs with interference lists and preference lists. *) val build_graph: Mach.fundecl -> unit mingw-ocaml/ocaml/asmcomp/comballoc.ml0000644000175000017500000000746412124403240017414 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Combine heap allocations occurring in the same basic block *) open Mach type allocation_state = No_alloc (* no allocation is pending *) | Pending_alloc of Reg.t * int (* an allocation is pending *) (* The arguments of Pending_alloc(reg, ofs) are: reg the register holding the result of the last allocation ofs the alloc position in the allocated block *) let allocated_size = function No_alloc -> 0 | Pending_alloc(reg, ofs) -> ofs let rec combine i allocstate = match i.desc with Iend | Ireturn | Iexit _ | Iraise -> (i, allocated_size allocstate) | Iop(Ialloc sz) -> begin match allocstate with No_alloc -> let (newnext, newsz) = combine i.next (Pending_alloc(i.res.(0), sz)) in (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, 0) | Pending_alloc(reg, ofs) -> if ofs + sz < Config.max_young_wosize * Arch.size_addr then begin let (newnext, newsz) = combine i.next (Pending_alloc(reg, ofs + sz)) in (instr_cons (Iop(Iintop_imm(Iadd, ofs))) [| reg |] i.res newnext, newsz) end else begin let (newnext, newsz) = combine i.next (Pending_alloc(i.res.(0), sz)) in (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, ofs) end end | Iop(Icall_ind | Icall_imm _ | Iextcall _ | Itailcall_ind | Itailcall_imm _) -> let newnext = combine_restart i.next in (instr_cons_debug i.desc i.arg i.res i.dbg newnext, allocated_size allocstate) | Iop op -> let (newnext, sz) = combine i.next allocstate in (instr_cons_debug i.desc i.arg i.res i.dbg newnext, sz) | Iifthenelse(test, ifso, ifnot) -> let newifso = combine_restart ifso in let newifnot = combine_restart ifnot in let newnext = combine_restart i.next in (instr_cons (Iifthenelse(test, newifso, newifnot)) i.arg i.res newnext, allocated_size allocstate) | Iswitch(table, cases) -> let newcases = Array.map combine_restart cases in let newnext = combine_restart i.next in (instr_cons (Iswitch(table, newcases)) i.arg i.res newnext, allocated_size allocstate) | Iloop(body) -> let newbody = combine_restart body in (instr_cons (Iloop(newbody)) i.arg i.res i.next, allocated_size allocstate) | Icatch(io, body, handler) -> let (newbody, sz) = combine body allocstate in let newhandler = combine_restart handler in let newnext = combine_restart i.next in (instr_cons (Icatch(io, newbody, newhandler)) i.arg i.res newnext, sz) | Itrywith(body, handler) -> let (newbody, sz) = combine body allocstate in let newhandler = combine_restart handler in let newnext = combine_restart i.next in (instr_cons (Itrywith(newbody, newhandler)) i.arg i.res newnext, sz) and combine_restart i = let (newi, _) = combine i No_alloc in newi let fundecl f = {f with fun_body = combine_restart f.fun_body} mingw-ocaml/ocaml/asmcomp/proc.mli0000644000175000017500000000366012124403240016567 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Processor descriptions *) (* Instruction selection *) val word_addressed: bool (* Registers available for register allocation *) val num_register_classes: int val register_class: Reg.t -> int val num_available_registers: int array val first_available_register: int array val register_name: int -> string val phys_reg: int -> Reg.t val rotate_registers: bool (* Calling conventions *) val loc_arguments: Reg.t array -> Reg.t array * int val loc_results: Reg.t array -> Reg.t array val loc_parameters: Reg.t array -> Reg.t array val loc_external_arguments: Reg.t array -> Reg.t array * int val loc_external_results: Reg.t array -> Reg.t array val loc_exn_bucket: Reg.t (* Maximal register pressures for pre-spilling *) val safe_register_pressure: Mach.operation -> int val max_register_pressure: Mach.operation -> int array (* Registers destroyed by operations *) val destroyed_at_oper: Mach.instruction_desc -> Reg.t array val destroyed_at_raise: Reg.t array (* Info for laying out the stack frame *) val num_stack_slots: int array val contains_calls: bool ref (* Calling the assembler *) val assemble_file: string -> string -> int mingw-ocaml/ocaml/asmcomp/printcmm.ml0000644000175000017500000001560012124403240017301 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Pretty-printing of C-- code *) open Format open Cmm let machtype_component ppf = function | Addr -> fprintf ppf "addr" | Int -> fprintf ppf "int" | Float -> fprintf ppf "float" let machtype ppf mty = match Array.length mty with | 0 -> fprintf ppf "unit" | n -> machtype_component ppf mty.(0); for i = 1 to n-1 do fprintf ppf "*%a" machtype_component mty.(i) done let comparison = function | Ceq -> "==" | Cne -> "!=" | Clt -> "<" | Cle -> "<=" | Cgt -> ">" | Cge -> ">=" let chunk = function | Byte_unsigned -> "unsigned int8" | Byte_signed -> "signed int8" | Sixteen_unsigned -> "unsigned int16" | Sixteen_signed -> "signed int16" | Thirtytwo_unsigned -> "unsigned int32" | Thirtytwo_signed -> "signed int32" | Word -> "" | Single -> "float32" | Double -> "float64" | Double_u -> "float64u" let operation = function | Capply(ty, d) -> "app" ^ Debuginfo.to_string d | Cextcall(lbl, ty, alloc, d) -> Printf.sprintf "extcall \"%s\"%s" lbl (Debuginfo.to_string d) | Cload Word -> "load" | Cload c -> Printf.sprintf "load %s" (chunk c) | Calloc -> "alloc" | Cstore Word -> "store" | Cstore c -> Printf.sprintf "store %s" (chunk c) | Caddi -> "+" | Csubi -> "-" | Cmuli -> "*" | Cdivi -> "/" | Cmodi -> "mod" | Cand -> "and" | Cor -> "or" | Cxor -> "xor" | Clsl -> "<<" | Clsr -> ">>u" | Casr -> ">>s" | Ccmpi c -> comparison c | Cadda -> "+a" | Csuba -> "-a" | Ccmpa c -> Printf.sprintf "%sa" (comparison c) | Cnegf -> "~f" | Cabsf -> "absf" | Caddf -> "+f" | Csubf -> "-f" | Cmulf -> "*f" | Cdivf -> "/f" | Cfloatofint -> "floatofint" | Cintoffloat -> "intoffloat" | Ccmpf c -> Printf.sprintf "%sf" (comparison c) | Craise d -> "raise" ^ Debuginfo.to_string d | Ccheckbound d -> "checkbound" ^ Debuginfo.to_string d let rec expr ppf = function | Cconst_int n -> fprintf ppf "%i" n | Cconst_natint n -> fprintf ppf "%s" (Nativeint.to_string n) | Cconst_float s -> fprintf ppf "%s" s | Cconst_symbol s -> fprintf ppf "\"%s\"" s | Cconst_pointer n -> fprintf ppf "%ia" n | Cconst_natpointer n -> fprintf ppf "%sa" (Nativeint.to_string n) | Cvar id -> Ident.print ppf id | Clet(id, def, (Clet(_, _, _) as body)) -> let print_binding id ppf def = fprintf ppf "@[<2>%a@ %a@]" Ident.print id expr def in let rec in_part ppf = function | Clet(id, def, body) -> fprintf ppf "@ %a" (print_binding id) def; in_part ppf body | exp -> exp in fprintf ppf "@[<2>(let@ @[<1>(%a" (print_binding id) def; let exp = in_part ppf body in fprintf ppf ")@]@ %a)@]" sequence exp | Clet(id, def, body) -> fprintf ppf "@[<2>(let@ @[<2>%a@ %a@]@ %a)@]" Ident.print id expr def sequence body | Cassign(id, exp) -> fprintf ppf "@[<2>(assign @[<2>%a@ %a@])@]" Ident.print id expr exp | Ctuple el -> let tuple ppf el = let first = ref true in List.iter (fun e -> if !first then first := false else fprintf ppf "@ "; expr ppf e) el in fprintf ppf "@[<1>[%a]@]" tuple el | Cop(op, el) -> fprintf ppf "@[<2>(%s" (operation op); List.iter (fun e -> fprintf ppf "@ %a" expr e) el; begin match op with | Capply (mty, _) -> fprintf ppf "@ %a" machtype mty | Cextcall(_, mty, _, _) -> fprintf ppf "@ %a" machtype mty | _ -> () end; fprintf ppf ")@]" | Csequence(e1, e2) -> fprintf ppf "@[<2>(seq@ %a@ %a)@]" sequence e1 sequence e2 | Cifthenelse(e1, e2, e3) -> fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" expr e1 expr e2 expr e3 | Cswitch(e1, index, cases) -> let print_case i ppf = for j = 0 to Array.length index - 1 do if index.(j) = i then fprintf ppf "case %i:" j done in let print_cases ppf = for i = 0 to Array.length cases - 1 do fprintf ppf "@ @[<2>%t@ %a@]" (print_case i) sequence cases.(i) done in fprintf ppf "@[@[<2>(switch@ %a@ @]%t)@]" expr e1 print_cases | Cloop e -> fprintf ppf "@[<2>(loop@ %a)@]" sequence e | Ccatch(i, ids, e1, e2) -> fprintf ppf "@[<2>(catch@ %a@;<1 -2>with(%d%a)@ %a)@]" sequence e1 i (fun ppf ids -> List.iter (fun id -> fprintf ppf " %a" Ident.print id) ids) ids sequence e2 | Cexit (i, el) -> fprintf ppf "@[<2>(exit %d" i ; List.iter (fun e -> fprintf ppf "@ %a" expr e) el; fprintf ppf ")@]" | Ctrywith(e1, id, e2) -> fprintf ppf "@[<2>(try@ %a@;<1 -2>with@ %a@ %a)@]" sequence e1 Ident.print id sequence e2 and sequence ppf = function | Csequence(e1, e2) -> fprintf ppf "%a@ %a" sequence e1 sequence e2 | e -> expression ppf e and expression ppf e = fprintf ppf "%a" expr e let fundecl ppf f = let print_cases ppf cases = let first = ref true in List.iter (fun (id, ty) -> if !first then first := false else fprintf ppf "@ "; fprintf ppf "%a: %a" Ident.print id machtype ty) cases in fprintf ppf "@[<1>(function%s %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@." (Debuginfo.to_string f.fun_dbg) f.fun_name print_cases f.fun_args sequence f.fun_body let data_item ppf = function | Cdefine_symbol s -> fprintf ppf "\"%s\":" s | Cdefine_label l -> fprintf ppf "L%i:" l | Cglobal_symbol s -> fprintf ppf "global \"%s\"" s | Cint8 n -> fprintf ppf "byte %i" n | Cint16 n -> fprintf ppf "int16 %i" n | Cint32 n -> fprintf ppf "int32 %s" (Nativeint.to_string n) | Cint n -> fprintf ppf "int %s" (Nativeint.to_string n) | Csingle f -> fprintf ppf "single %s" f | Cdouble f -> fprintf ppf "double %s" f | Csymbol_address s -> fprintf ppf "addr \"%s\"" s | Clabel_address l -> fprintf ppf "addr L%i" l | Cstring s -> fprintf ppf "string \"%s\"" s | Cskip n -> fprintf ppf "skip %i" n | Calign n -> fprintf ppf "align %i" n let data ppf dl = let items ppf = List.iter (fun d -> fprintf ppf "@ %a" data_item d) dl in fprintf ppf "@[(data%t)@]" items let phrase ppf = function | Cfunction f -> fundecl ppf f | Cdata dl -> data ppf dl mingw-ocaml/ocaml/asmcomp/printlinear.ml0000644000175000017500000000521312124403240017776 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Pretty-printing of linearized machine code *) open Format open Mach open Printmach open Linearize let label ppf l = Format.fprintf ppf "L%i" l let instr ppf i = begin match i.desc with | Lend -> () | Lop op -> begin match op with | Ialloc _ | Icall_ind | Icall_imm _ | Iextcall(_, _) -> fprintf ppf "@[<1>{%a}@]@," regsetaddr i.live | _ -> () end; operation op i.arg ppf i.res | Lreloadretaddr -> fprintf ppf "reload retaddr" | Lreturn -> fprintf ppf "return %a" regs i.arg | Llabel lbl -> fprintf ppf "%a:" label lbl | Lbranch lbl -> fprintf ppf "goto %a" label lbl | Lcondbranch(tst, lbl) -> fprintf ppf "if %a goto %a" (test tst) i.arg label lbl | Lcondbranch3(lbl0, lbl1, lbl2) -> fprintf ppf "switch3 %a" reg i.arg.(0); let case n = function | None -> () | Some lbl -> fprintf ppf "@,case %i: goto %a" n label lbl in case 0 lbl0; case 1 lbl1; case 2 lbl2; fprintf ppf "@,endswitch" | Lswitch lblv -> fprintf ppf "switch %a" reg i.arg.(0); for i = 0 to Array.length lblv - 1 do fprintf ppf "case %i: goto %a" i label lblv.(i) done; fprintf ppf "@,endswitch" | Lsetuptrap lbl -> fprintf ppf "setup trap %a" label lbl | Lpushtrap -> fprintf ppf "push trap" | Lpoptrap -> fprintf ppf "pop trap" | Lraise -> fprintf ppf "raise %a" reg i.arg.(0) end; if not (Debuginfo.is_none i.dbg) then fprintf ppf " %s" (Debuginfo.to_string i.dbg) let rec all_instr ppf i = match i.desc with | Lend -> () | _ -> fprintf ppf "%a@,%a" instr i all_instr i.next let fundecl ppf f = let dbg = if Debuginfo.is_none f.fun_dbg then "" else " " ^ Debuginfo.to_string f.fun_dbg in fprintf ppf "@[%s:%s@,%a@]" f.fun_name dbg all_instr f.fun_body mingw-ocaml/ocaml/asmcomp/asmlink.mli0000644000175000017500000000331612124403240017260 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Link a set of .cmx/.o files and produce an executable or a plugin *) open Format val link: formatter -> string list -> string -> unit val link_shared: formatter -> string list -> string -> unit val call_linker_shared: string list -> string -> unit val check_consistency: string -> Cmx_format.unit_infos -> Digest.t -> unit val extract_crc_interfaces: unit -> (string * Digest.t) list val extract_crc_implementations: unit -> (string * Digest.t) list type error = File_not_found of string | Not_an_object_file of string | Missing_implementations of (string * string list) list | Inconsistent_interface of string * string * string | Inconsistent_implementation of string * string * string | Assembler_error of string | Linking_error | Multiple_definition of string * string * string | Missing_cmx of string * string exception Error of error val report_error: formatter -> error -> unit mingw-ocaml/ocaml/asmcomp/power/0000755000175000017500000000000012124403240016250 5ustar tootstootsmingw-ocaml/ocaml/asmcomp/power/scheduling.ml0000644000175000017500000000405212124403240020730 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Instruction scheduling for the Power PC *) open Arch open Mach class scheduler = object inherit Schedgen.scheduler_generic (* Latencies (in cycles). Based roughly on the "common model". *) method oper_latency = function Ireload -> 2 | Iload(_, _) -> 2 | Iconst_float _ -> 2 (* turned into a load *) | Iconst_symbol _ -> 1 | Iintop Imul -> 9 | Iintop_imm(Imul, _) -> 5 | Iintop(Idiv | Imod) -> 36 | Iaddf | Isubf -> 4 | Imulf -> 5 | Idivf -> 33 | Ispecific(Imultaddf | Imultsubf) -> 5 | _ -> 1 method reload_retaddr_latency = 12 (* If we can have that many cycles between the reloadretaddr and the return, we can expect that the blr branch will be completely folded. *) (* Issue cycles. Rough approximations. *) method oper_issue_cycles = function Iconst_float _ | Iconst_symbol _ -> 2 | Iload(_, Ibased(_, _)) -> 2 | Istore(_, Ibased(_, _)) -> 2 | Ialloc _ -> 4 | Iintop(Imod) -> 40 (* assuming full stall *) | Iintop(Icomp _) -> 4 | Iintop_imm(Idiv, _) -> 2 | Iintop_imm(Imod, _) -> 4 | Iintop_imm(Icomp _, _) -> 4 | Ifloatofint -> 9 | Iintoffloat -> 4 | _ -> 1 method reload_retaddr_issue_cycles = 3 (* load then stalling mtlr *) end let fundecl f = (new scheduler)#schedule_fundecl f mingw-ocaml/ocaml/asmcomp/power/arch.ml0000644000175000017500000000545012124403240017523 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Specific operations for the PowerPC processor *) open Misc open Format (* Machine-specific command-line options *) let command_line_options = [] (* Specific operations *) type specific_operation = Imultaddf (* multiply and add *) | Imultsubf (* multiply and subtract *) | Ialloc_far of int (* allocation in large functions *) (* Addressing modes *) type addressing_mode = Ibased of string * int (* symbol + displ *) | Iindexed of int (* reg + displ *) | Iindexed2 (* reg + reg *) (* Sizes, endianness *) let big_endian = true let ppc64 = match Config.model with "ppc64" -> true | _ -> false let size_addr = if ppc64 then 8 else 4 let size_int = size_addr let size_float = 8 (* Behavior of division *) let division_crashes_on_overflow = true (* Operations on addressing modes *) let identity_addressing = Iindexed 0 let offset_addressing addr delta = match addr with Ibased(s, n) -> Ibased(s, n + delta) | Iindexed n -> Iindexed(n + delta) | Iindexed2 -> assert false let num_args_addressing = function Ibased(s, n) -> 0 | Iindexed n -> 1 | Iindexed2 -> 2 (* Printing operations and addressing modes *) let print_addressing printreg addr ppf arg = match addr with | Ibased(s, n) -> let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in fprintf ppf "\"%s\"%s" s idx | Iindexed n -> let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in fprintf ppf "%a%s" printreg arg.(0) idx | Iindexed2 -> fprintf ppf "%a + %a" printreg arg.(0) printreg arg.(1) let print_specific_operation printreg op ppf arg = match op with | Imultaddf -> fprintf ppf "%a *f %a +f %a" printreg arg.(0) printreg arg.(1) printreg arg.(2) | Imultsubf -> fprintf ppf "%a *f %a -f %a" printreg arg.(0) printreg arg.(1) printreg arg.(2) | Ialloc_far n -> fprintf ppf "alloc_far %d" n mingw-ocaml/ocaml/asmcomp/power/proc.ml0000644000175000017500000001715312124403240017554 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Description of the Power PC *) open Misc open Cmm open Reg open Arch open Mach (* Instruction selection *) let word_addressed = false (* Registers available for register allocation *) (* Integer register map: 0 temporary, null register for some operations 1 stack pointer 2 pointer to table of contents 3 - 10 function arguments and results 11 - 12 temporaries 13 pointer to small data area 14 - 28 general purpose, preserved by C 29 trap pointer 30 allocation limit 31 allocation pointer Floating-point register map: 0 temporary 1 - 13 function arguments and results 14 - 31 general purpose, preserved by C *) let int_reg_name = if Config.system = "rhapsody" then [| "r3"; "r4"; "r5"; "r6"; "r7"; "r8"; "r9"; "r10"; "r14"; "r15"; "r16"; "r17"; "r18"; "r19"; "r20"; "r21"; "r22"; "r23"; "r24"; "r25"; "r26"; "r27"; "r28" |] else [| "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10"; "14"; "15"; "16"; "17"; "18"; "19"; "20"; "21"; "22"; "23"; "24"; "25"; "26"; "27"; "28" |] let float_reg_name = if Config.system = "rhapsody" then [| "f1"; "f2"; "f3"; "f4"; "f5"; "f6"; "f7"; "f8"; "f9"; "f10"; "f11"; "f12"; "f13"; "f14"; "f15"; "f16"; "f17"; "f18"; "f19"; "f20"; "f21"; "f22"; "f23"; "f24"; "f25"; "f26"; "f27"; "f28"; "f29"; "f30"; "f31" |] else [| "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10"; "11"; "12"; "13"; "14"; "15"; "16"; "17"; "18"; "19"; "20"; "21"; "22"; "23"; "24"; "25"; "26"; "27"; "28"; "29"; "30"; "31" |] let num_register_classes = 2 let register_class r = match r.typ with Int -> 0 | Addr -> 0 | Float -> 1 let num_available_registers = [| 23; 31 |] let first_available_register = [| 0; 100 |] let register_name r = if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) let rotate_registers = true (* Representation of hard registers by pseudo-registers *) let hard_int_reg = let v = Array.create 23 Reg.dummy in for i = 0 to 22 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = let v = Array.create 31 Reg.dummy in for i = 0 to 30 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v let all_phys_regs = Array.append hard_int_reg hard_float_reg let phys_reg n = if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) let stack_slot slot ty = Reg.at_location ty (Stack slot) (* Calling conventions *) let calling_conventions first_int last_int first_float last_float make_stack stack_ofs arg = let loc = Array.create (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref stack_ofs in for i = 0 to Array.length arg - 1 do match arg.(i).typ with Int | Addr as ty -> if !int <= last_int then begin loc.(i) <- phys_reg !int; incr int end else begin loc.(i) <- stack_slot (make_stack !ofs) ty; ofs := !ofs + size_int end | Float -> if !float <= last_float then begin loc.(i) <- phys_reg !float; incr float end else begin loc.(i) <- stack_slot (make_stack !ofs) Float; ofs := !ofs + size_float end done; (loc, Misc.align !ofs 16) (* Keep stack 16-aligned. *) let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs let not_supported ofs = fatal_error "Proc.loc_results: cannot call" let loc_arguments arg = calling_conventions 0 7 100 112 outgoing 0 arg let loc_parameters arg = let (loc, ofs) = calling_conventions 0 7 100 112 incoming 0 arg in loc let loc_results res = let (loc, ofs) = calling_conventions 0 7 100 112 not_supported 0 res in loc (* C calling conventions under PowerOpen: use GPR 3-10 and FPR 1-13 just like ML calling conventions, but always reserve stack space for all arguments. Also, using a float register automatically reserves two int registers (in 32-bit mode) or one int register (in 64-bit mode). (If we were to call a non-prototyped C function, each float argument would have to go both in a float reg and in the matching pair of integer regs.) C calling conventions under SVR4: use GPR 3-10 and FPR 1-8 just like ML calling conventions. Using a float register does not affect the int registers. Always reserve 8 bytes at bottom of stack, plus whatever is needed to hold the overflow arguments. *) let poweropen_external_conventions first_int last_int first_float last_float arg = let loc = Array.create (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref (14 * size_addr) in for i = 0 to Array.length arg - 1 do match arg.(i).typ with Int | Addr as ty -> if !int <= last_int then begin loc.(i) <- phys_reg !int; incr int end else begin loc.(i) <- stack_slot (Outgoing !ofs) ty; ofs := !ofs + size_int end | Float -> if !float <= last_float then begin loc.(i) <- phys_reg !float; incr float end else begin loc.(i) <- stack_slot (Outgoing !ofs) Float; ofs := !ofs + size_float end; int := !int + (if ppc64 then 1 else 2) done; (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) let loc_external_arguments = match Config.system with | "rhapsody" -> poweropen_external_conventions 0 7 100 112 | "elf" | "bsd" -> calling_conventions 0 7 100 107 outgoing 8 | _ -> assert false let extcall_use_push = false (* Results are in GPR 3 and FPR 1 *) let loc_external_results res = let (loc, ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc (* Exceptions are in GPR 3 *) let loc_exn_bucket = phys_reg 0 (* Registers destroyed by operations *) let destroyed_at_c_call = Array.of_list(List.map phys_reg [0; 1; 2; 3; 4; 5; 6; 7; 100; 101; 102; 103; 104; 105; 106; 107; 108; 109; 110; 111; 112]) let destroyed_at_oper = function Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs | Iop(Iextcall(_, false)) -> destroyed_at_c_call | _ -> [||] let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function Iextcall(_, _) -> 15 | _ -> 23 let max_register_pressure = function Iextcall(_, _) -> [| 15; 18 |] | _ -> [| 23; 30 |] (* Layout of the stack *) let num_stack_slots = [| 0; 0 |] let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = Ccomp.command (Config.asm ^ " -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; mingw-ocaml/ocaml/asmcomp/power/reload.ml0000644000175000017500000000162712124403240020056 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Reloading for the PowerPC *) let fundecl f = (new Reloadgen.reload_generic)#fundecl f mingw-ocaml/ocaml/asmcomp/power/selection.ml0000644000175000017500000000667612124403240020606 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Instruction selection for the Power PC processor *) open Misc open Cmm open Reg open Arch open Mach (* Recognition of addressing modes *) type addressing_expr = Asymbol of string | Alinear of expression | Aadd of expression * expression let rec select_addr = function Cconst_symbol s -> (Asymbol s, 0) | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> let (a, n) = select_addr arg in (a, n + m) | Cop((Caddi | Cadda), [Cconst_int m; arg]) -> let (a, n) = select_addr arg in (a, n + m) | Cop((Caddi | Cadda), [arg1; arg2]) -> begin match (select_addr arg1, select_addr arg2) with ((Alinear e1, n1), (Alinear e2, n2)) -> (Aadd(e1, e2), n1 + n2) | _ -> (Aadd(arg1, arg2), 0) end | exp -> (Alinear exp, 0) (* Instruction selection *) class selector = object (self) inherit Selectgen.selector_generic as super method is_immediate n = (n <= 32767) && (n >= -32768) method select_addressing chunk exp = match select_addr exp with (Asymbol s, d) -> (Ibased(s, d), Ctuple []) | (Alinear e, d) -> (Iindexed d, e) | (Aadd(e1, e2), d) -> if d = 0 then (Iindexed2, Ctuple[e1; e2]) else (Iindexed d, Cop(Cadda, [e1; e2])) method! select_operation op args = match (op, args) with (* Prevent the recognition of (x / cst) and (x % cst) when cst is not a power of 2, which do not correspond to an instruction. *) (Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> (Iintop_imm(Idiv, n), [arg]) | (Cdivi, _) -> (Iintop Idiv, args) | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> (Iintop_imm(Imod, n), [arg]) | (Cmodi, _) -> (Iintop Imod, args) (* The and, or and xor instructions have a different range of immediate operands than the other instructions *) | (Cand, _) -> self#select_logical Iand args | (Cor, _) -> self#select_logical Ior args | (Cxor, _) -> self#select_logical Ixor args (* Recognize mult-add and mult-sub instructions *) | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> (Ispecific Imultaddf, [arg1; arg2; arg3]) | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) -> (Ispecific Imultaddf, [arg1; arg2; arg3]) | (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> (Ispecific Imultsubf, [arg1; arg2; arg3]) | _ -> super#select_operation op args method select_logical op = function [arg; Cconst_int n] when n >= 0 && n <= 0xFFFF -> (Iintop_imm(op, n), [arg]) | [Cconst_int n; arg] when n >= 0 && n <= 0xFFFF -> (Iintop_imm(op, n), [arg]) | args -> (Iintop op, args) end let fundecl f = (new selector)#emit_fundecl f mingw-ocaml/ocaml/asmcomp/power/emit.mlp0000644000175000017500000010404412124403240017723 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Emission of PowerPC assembly code *) module StringSet = Set.Make(struct type t = string let compare = compare end) open Location open Misc open Cmm open Arch open Proc open Reg open Mach open Linearize open Emitaux (* Layout of the stack. The stack is kept 16-aligned. *) let stack_offset = ref 0 let frame_size () = let size = !stack_offset + (* Trap frame, outgoing parameters *) size_int * num_stack_slots.(0) + (* Local int variables *) size_float * num_stack_slots.(1) + (* Local float variables *) (if !contains_calls then size_int else 0) in (* The return address *) Misc.align size 16 let slot_offset loc cls = match loc with Local n -> if cls = 0 then !stack_offset + num_stack_slots.(1) * size_float + n * size_int else !stack_offset + n * size_float | Incoming n -> frame_size() + n | Outgoing n -> n (* Whether stack backtraces are supported *) let supports_backtraces = match Config.system with | "rhapsody" -> true | _ -> false (* Output a symbol *) let emit_symbol = match Config.system with | "elf" | "bsd" -> (fun s -> Emitaux.emit_symbol '.' s) | "rhapsody" -> (fun s -> emit_char '_'; Emitaux.emit_symbol '$' s) | _ -> assert false (* Output a label *) let label_prefix = match Config.system with | "elf" | "bsd" -> ".L" | "rhapsody" -> "L" | _ -> assert false let emit_label lbl = emit_string label_prefix; emit_int lbl let emit_data_label lbl = emit_string label_prefix; emit_string "d"; emit_int lbl (* Section switching *) let data_space = match Config.system with | "elf" | "bsd" -> " .section \".data\"\n" | "rhapsody" -> " .data\n" | _ -> assert false let code_space = match Config.system with | "elf" | "bsd" -> " .section \".text\"\n" | "rhapsody" -> " .text\n" | _ -> assert false let rodata_space = match Config.system with | "elf" | "bsd" -> " .section \".rodata\"\n" | "rhapsody" -> " .const\n" | _ -> assert false (* Names of instructions that differ in 32 and 64-bit modes *) let lg = if ppc64 then "ld" else "lwz" let stg = if ppc64 then "std" else "stw" let lwa = if ppc64 then "lwa" else "lwz" let cmpg = if ppc64 then "cmpd" else "cmpw" let cmplg = if ppc64 then "cmpld" else "cmplw" let datag = if ppc64 then ".quad" else ".long" let aligng = if ppc64 then 3 else 2 let mullg = if ppc64 then "mulld" else "mullw" let divg = if ppc64 then "divd" else "divw" let tglle = if ppc64 then "tdlle" else "twlle" let sragi = if ppc64 then "sradi" else "srawi" let slgi = if ppc64 then "sldi" else "slwi" let fctigz = if ppc64 then "fctidz" else "fctiwz" (* Output a pseudo-register *) let emit_reg r = match r.loc with Reg r -> emit_string (register_name r) | _ -> fatal_error "Emit.emit_reg" let use_full_regnames = Config.system = "rhapsody" let emit_gpr r = if use_full_regnames then emit_char 'r'; emit_int r let emit_fpr r = if use_full_regnames then emit_char 'f'; emit_int r let emit_ccr r = if use_full_regnames then emit_string "cr"; emit_int r (* Output a stack reference *) let emit_stack r = match r.loc with Stack s -> let ofs = slot_offset s (register_class r) in `{emit_int ofs}({emit_gpr 1})` | _ -> fatal_error "Emit.emit_stack" (* Split a 32-bit integer constants in two 16-bit halves *) let low n = n land 0xFFFF let high n = n asr 16 let nativelow n = Nativeint.to_int n land 0xFFFF let nativehigh n = Nativeint.to_int (Nativeint.shift_right n 16) let is_immediate n = n <= 32767 && n >= -32768 let is_native_immediate n = n <= 32767n && n >= -32768n (* Output a "upper 16 bits" or "lower 16 bits" operator. *) let emit_upper emit_fun arg = match Config.system with | "elf" | "bsd" -> emit_fun arg; emit_string "@ha" | "rhapsody" -> emit_string "ha16("; emit_fun arg; emit_string ")" | _ -> assert false let emit_lower emit_fun arg = match Config.system with | "elf" | "bsd" -> emit_fun arg; emit_string "@l" | "rhapsody" -> emit_string "lo16("; emit_fun arg; emit_string ")" | _ -> assert false (* Output a load or store operation *) let emit_symbol_offset (s, d) = emit_symbol s; if d > 0 then `+`; if d <> 0 then emit_int d let valid_offset instr ofs = ofs land 3 = 0 || (instr <> "ld" && instr <> "std") let emit_load_store instr addressing_mode addr n arg = match addressing_mode with Ibased(s, d) -> ` addis {emit_gpr 11}, 0, {emit_upper emit_symbol_offset (s,d)}\n`; ` {emit_string instr} {emit_reg arg}, {emit_lower emit_symbol_offset (s,d)}({emit_gpr 11})\n` | Iindexed ofs -> if is_immediate ofs && valid_offset instr ofs then ` {emit_string instr} {emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)})\n` else begin ` lis {emit_gpr 0}, {emit_int(high ofs)}\n`; if low ofs <> 0 then ` ori {emit_gpr 0}, {emit_gpr 0}, {emit_int(low ofs)}\n`; ` {emit_string instr}x {emit_reg arg}, {emit_reg addr.(n)}, {emit_gpr 0}\n` end | Iindexed2 -> ` {emit_string instr}x {emit_reg arg}, {emit_reg addr.(n)}, {emit_reg addr.(n+1)}\n` (* After a comparison, extract the result as 0 or 1 *) let emit_set_comp cmp res = ` mfcr {emit_gpr 0}\n`; let bitnum = match cmp with Ceq | Cne -> 2 | Cgt | Cle -> 1 | Clt | Cge -> 0 in ` rlwinm {emit_reg res}, {emit_gpr 0}, {emit_int(bitnum+1)}, 31, 31\n`; begin match cmp with Cne | Cle | Cge -> ` xori {emit_reg res}, {emit_reg res}, 1\n` | _ -> () end (* Record live pointers at call points *) let record_frame live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter (function {typ = Addr; loc = Reg r} -> live_offset := (r lsl 1) + 1 :: !live_offset | {typ = Addr; loc = Stack s} as reg -> live_offset := slot_offset s (register_class reg) :: !live_offset | _ -> ()) live; frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); fd_live_offset = !live_offset; fd_debuginfo = dbg } :: !frame_descriptors; `{emit_label lbl}:\n` (* Record floating-point and large integer literals *) let float_literals = ref ([] : (string * int) list) let int_literals = ref ([] : (nativeint * int) list) (* Record external C functions to be called in a position-independent way (for MacOSX) *) let pic_externals = (Config.system = "rhapsody") let external_functions = ref StringSet.empty let emit_external s = ` .non_lazy_symbol_pointer\n`; `L{emit_symbol s}$non_lazy_ptr:\n`; ` .indirect_symbol {emit_symbol s}\n`; ` {emit_string datag} 0\n` (* Names for conditional branches after comparisons *) let branch_for_comparison = function Ceq -> "beq" | Cne -> "bne" | Cle -> "ble" | Cgt -> "bgt" | Cge -> "bge" | Clt -> "blt" let name_for_int_comparison = function Isigned cmp -> (cmpg, branch_for_comparison cmp) | Iunsigned cmp -> (cmplg, branch_for_comparison cmp) (* Names for various instructions *) let name_for_intop = function Iadd -> "add" | Imul -> if ppc64 then "mulld" else "mullw" | Idiv -> if ppc64 then "divd" else "divw" | Iand -> "and" | Ior -> "or" | Ixor -> "xor" | Ilsl -> if ppc64 then "sld" else "slw" | Ilsr -> if ppc64 then "srd" else "srw" | Iasr -> if ppc64 then "srad" else "sraw" | _ -> Misc.fatal_error "Emit.Intop" let name_for_intop_imm = function Iadd -> "addi" | Imul -> "mulli" | Iand -> "andi." | Ior -> "ori" | Ixor -> "xori" | Ilsl -> if ppc64 then "sldi" else "slwi" | Ilsr -> if ppc64 then "srdi" else "srwi" | Iasr -> if ppc64 then "sradi" else "srawi" | _ -> Misc.fatal_error "Emit.Intop_imm" let name_for_floatop1 = function Inegf -> "fneg" | Iabsf -> "fabs" | _ -> Misc.fatal_error "Emit.Iopf1" let name_for_floatop2 = function Iaddf -> "fadd" | Isubf -> "fsub" | Imulf -> "fmul" | Idivf -> "fdiv" | _ -> Misc.fatal_error "Emit.Iopf2" let name_for_specific = function Imultaddf -> "fmadd" | Imultsubf -> "fmsub" | _ -> Misc.fatal_error "Emit.Ispecific" (* Name of current function *) let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 (* Names of functions defined in the current file *) let defined_functions = ref StringSet.empty (* Label of glue code for calling the GC *) let call_gc_label = ref 0 (* Fixup conditional branches that exceed hardware allowed range *) let load_store_size = function Ibased(s, d) -> 2 | Iindexed ofs -> if is_immediate ofs then 1 else 3 | Iindexed2 -> 1 let instr_size = function Lend -> 0 | Lop(Imove | Ispill | Ireload) -> 1 | Lop(Iconst_int n) -> if is_native_immediate n then 1 else 2 | Lop(Iconst_float s) -> 2 | Lop(Iconst_symbol s) -> 2 | Lop(Icall_ind) -> 2 | Lop(Icall_imm s) -> 1 | Lop(Itailcall_ind) -> 5 | Lop(Itailcall_imm s) -> if s = !function_name then 1 else 4 | Lop(Iextcall(s, true)) -> 3 | Lop(Iextcall(s, false)) -> if pic_externals then 4 else 1 | Lop(Istackoffset n) -> 1 | Lop(Iload(chunk, addr)) -> if chunk = Byte_signed then load_store_size addr + 1 else load_store_size addr | Lop(Istore(chunk, addr)) -> load_store_size addr | Lop(Ialloc n) -> 4 | Lop(Ispecific(Ialloc_far n)) -> 5 | Lop(Iintop Imod) -> 3 | Lop(Iintop(Icomp cmp)) -> 4 | Lop(Iintop op) -> 1 | Lop(Iintop_imm(Idiv, n)) -> 2 | Lop(Iintop_imm(Imod, n)) -> 4 | Lop(Iintop_imm(Icomp cmp, n)) -> 4 | Lop(Iintop_imm(op, n)) -> 1 | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1 | Lop(Ifloatofint) -> 9 | Lop(Iintoffloat) -> 4 | Lop(Ispecific sop) -> 1 | Lreloadretaddr -> 2 | Lreturn -> 2 | Llabel lbl -> 0 | Lbranch lbl -> 1 | Lcondbranch(tst, lbl) -> 2 | Lcondbranch3(lbl0, lbl1, lbl2) -> 1 + (if lbl0 = None then 0 else 1) + (if lbl1 = None then 0 else 1) + (if lbl2 = None then 0 else 1) | Lswitch jumptbl -> 8 | Lsetuptrap lbl -> 1 | Lpushtrap -> 4 | Lpoptrap -> 2 | Lraise -> 6 let label_map code = let map = Hashtbl.create 37 in let rec fill_map pc instr = match instr.desc with Lend -> (pc, map) | Llabel lbl -> Hashtbl.add map lbl pc; fill_map pc instr.next | op -> fill_map (pc + instr_size op) instr.next in fill_map 0 code let max_branch_offset = 8180 (* 14-bit signed offset in words. Remember to cut some slack for multi-word instructions where the branch can be anywhere in the middle. 12 words of slack is plenty. *) let branch_overflows map pc_branch lbl_dest = let pc_dest = Hashtbl.find map lbl_dest in let delta = pc_dest - (pc_branch + 1) in delta <= -max_branch_offset || delta >= max_branch_offset let opt_branch_overflows map pc_branch opt_lbl_dest = match opt_lbl_dest with None -> false | Some lbl_dest -> branch_overflows map pc_branch lbl_dest let fixup_branches codesize map code = let expand_optbranch lbl n arg next = match lbl with None -> next | Some l -> instr_cons (Lcondbranch(Iinttest_imm(Isigned Ceq, n), l)) arg [||] next in let rec fixup did_fix pc instr = match instr.desc with Lend -> did_fix | Lcondbranch(test, lbl) when branch_overflows map pc lbl -> let lbl2 = new_label() in let cont = instr_cons (Lbranch lbl) [||] [||] (instr_cons (Llabel lbl2) [||] [||] instr.next) in instr.desc <- Lcondbranch(invert_test test, lbl2); instr.next <- cont; fixup true (pc + 2) instr.next | Lcondbranch3(lbl0, lbl1, lbl2) when opt_branch_overflows map pc lbl0 || opt_branch_overflows map pc lbl1 || opt_branch_overflows map pc lbl2 -> let cont = expand_optbranch lbl0 0 instr.arg (expand_optbranch lbl1 1 instr.arg (expand_optbranch lbl2 2 instr.arg instr.next)) in instr.desc <- cont.desc; instr.next <- cont.next; fixup true pc instr | Lop(Ialloc n) when codesize - pc >= max_branch_offset -> instr.desc <- Lop(Ispecific(Ialloc_far n)); fixup true (pc + 4) instr.next | op -> fixup did_fix (pc + instr_size op) instr.next in fixup false 0 code (* Iterate branch expansion till all conditional branches are OK *) let rec branch_normalization code = let (codesize, map) = label_map code in if codesize >= max_branch_offset && fixup_branches codesize map code then branch_normalization code else () (* Output the assembly code for an instruction *) let rec emit_instr i dslot = match i.desc with Lend -> () | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin match (src, dst) with {loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} -> ` mr {emit_reg dst}, {emit_reg src}\n` | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> ` fmr {emit_reg dst}, {emit_reg src}\n` | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} -> ` {emit_string stg} {emit_reg src}, {emit_stack dst}\n` | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> ` stfd {emit_reg src}, {emit_stack dst}\n` | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} -> ` {emit_string lg} {emit_reg dst}, {emit_stack src}\n` | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> ` lfd {emit_reg dst}, {emit_stack src}\n` | (_, _) -> fatal_error "Emit: Imove" end | Lop(Iconst_int n) -> if is_native_immediate n then ` li {emit_reg i.res.(0)}, {emit_nativeint n}\n` else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin ` lis {emit_reg i.res.(0)}, {emit_int(nativehigh n)}\n`; if nativelow n <> 0 then ` ori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_int(nativelow n)}\n` end else begin let lbl = new_label() in int_literals := (n, lbl) :: !int_literals; ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` {emit_string lg} {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n` end | Lop(Iconst_float s) -> let lbl = new_label() in float_literals := (s, lbl) :: !float_literals; ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` lfd {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n` | Lop(Iconst_symbol s) -> ` addis {emit_reg i.res.(0)}, 0, {emit_upper emit_symbol s}\n`; ` addi {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_lower emit_symbol s}\n` | Lop(Icall_ind) -> ` mtctr {emit_reg i.arg.(0)}\n`; ` bctrl\n`; record_frame i.live i.dbg | Lop(Icall_imm s) -> ` bl {emit_symbol s}\n`; record_frame i.live i.dbg | Lop(Itailcall_ind) -> let n = frame_size() in ` mtctr {emit_reg i.arg.(0)}\n`; if !contains_calls then begin ` {emit_string lg} {emit_gpr 11}, {emit_int(n - size_addr)}({emit_gpr 1})\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`; ` mtlr {emit_gpr 11}\n` end else begin if n > 0 then ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n` end; ` bctr\n` | Lop(Itailcall_imm s) -> if s = !function_name then ` b {emit_label !tailrec_entry_point}\n` else begin let n = frame_size() in if !contains_calls then begin ` {emit_string lg} {emit_gpr 11}, {emit_int(n - size_addr)}({emit_gpr 1})\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`; ` mtlr {emit_gpr 11}\n` end else begin if n > 0 then ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n` end; ` b {emit_symbol s}\n` end | Lop(Iextcall(s, alloc)) -> if alloc then begin if pic_externals then begin external_functions := StringSet.add s !external_functions; ` addis {emit_gpr 11}, 0, ha16(L{emit_symbol s}$non_lazy_ptr)\n`; ` {emit_string lg} {emit_gpr 11}, lo16(L{emit_symbol s}$non_lazy_ptr)({emit_gpr 11})\n` end else begin ` addis {emit_gpr 11}, 0, {emit_upper emit_symbol s}\n`; ` addi {emit_gpr 11}, {emit_gpr 11}, {emit_lower emit_symbol s}\n` end; ` bl {emit_symbol "caml_c_call"}\n`; record_frame i.live i.dbg end else begin if pic_externals then begin external_functions := StringSet.add s !external_functions; ` addis {emit_gpr 11}, 0, ha16(L{emit_symbol s}$non_lazy_ptr)\n`; ` {emit_string lg} {emit_gpr 11}, lo16(L{emit_symbol s}$non_lazy_ptr)({emit_gpr 11})\n`; ` mtctr {emit_gpr 11}\n`; ` bctrl\n` end else ` bl {emit_symbol s}\n` end | Lop(Istackoffset n) -> ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int (-n)}\n`; stack_offset := !stack_offset + n | Lop(Iload(chunk, addr)) -> let loadinstr = match chunk with Byte_unsigned -> "lbz" | Byte_signed -> "lbz" | Sixteen_unsigned -> "lhz" | Sixteen_signed -> "lha" | Thirtytwo_unsigned -> "lwz" | Thirtytwo_signed -> if ppc64 then "lwa" else "lwz" | Word -> lg | Single -> "lfs" | Double | Double_u -> "lfd" in emit_load_store loadinstr addr i.arg 0 i.res.(0); if chunk = Byte_signed then ` extsb {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | Lop(Istore(chunk, addr)) -> let storeinstr = match chunk with Byte_unsigned | Byte_signed -> "stb" | Sixteen_unsigned | Sixteen_signed -> "sth" | Thirtytwo_unsigned | Thirtytwo_signed -> "stw" | Word -> stg | Single -> "stfs" | Double | Double_u -> "stfd" in emit_load_store storeinstr addr i.arg 1 i.arg.(0) | Lop(Ialloc n) -> if !call_gc_label = 0 then call_gc_label := new_label(); ` addi {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`; ` {emit_string cmplg} {emit_gpr 31}, {emit_gpr 30}\n`; ` addi {emit_reg i.res.(0)}, {emit_gpr 31}, {emit_int size_addr}\n`; ` bltl {emit_label !call_gc_label}\n`; record_frame i.live Debuginfo.none | Lop(Ispecific(Ialloc_far n)) -> if !call_gc_label = 0 then call_gc_label := new_label(); let lbl = new_label() in ` addi {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`; ` {emit_string cmplg} {emit_gpr 31}, {emit_gpr 30}\n`; ` bge {emit_label lbl}\n`; ` bl {emit_label !call_gc_label}\n`; record_frame i.live Debuginfo.none; `{emit_label lbl}: addi {emit_reg i.res.(0)}, {emit_gpr 31}, {emit_int size_addr}\n` | Lop(Iintop Isub) -> (* subfc has swapped arguments *) ` subfc {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` | Lop(Iintop Imod) -> ` {emit_string divg} {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` {emit_string mullg} {emit_gpr 0}, {emit_gpr 0}, {emit_reg i.arg.(1)}\n`; ` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n` | Lop(Iintop(Icomp cmp)) -> begin match cmp with Isigned c -> ` {emit_string cmpg} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; emit_set_comp c i.res.(0) | Iunsigned c -> ` {emit_string cmplg} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; emit_set_comp c i.res.(0) end | Lop(Iintop Icheckbound) -> if !Clflags.debug && supports_backtraces then record_frame Reg.Set.empty i.dbg; ` {emit_string tglle} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> let instr = name_for_intop op in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Iintop_imm(Isub, n)) -> ` addi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int(-n)}\n` | Lop(Iintop_imm(Idiv, n)) -> (* n is guaranteed to be a power of 2 *) let l = Misc.log2 n in ` {emit_string sragi} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int l}\n`; ` addze {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Imod, n)) -> (* n is guaranteed to be a power of 2 *) let l = Misc.log2 n in ` {emit_string sragi} {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int l}\n`; ` addze {emit_gpr 0}, {emit_gpr 0}\n`; ` {emit_string slgi} {emit_gpr 0}, {emit_gpr 0}, {emit_int l}\n`; ` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n` | Lop(Iintop_imm(Icomp cmp, n)) -> begin match cmp with Isigned c -> ` {emit_string cmpg}i {emit_reg i.arg.(0)}, {emit_int n}\n`; emit_set_comp c i.res.(0) | Iunsigned c -> ` {emit_string cmplg}i {emit_reg i.arg.(0)}, {emit_int n}\n`; emit_set_comp c i.res.(0) end | Lop(Iintop_imm(Icheckbound, n)) -> if !Clflags.debug && supports_backtraces then record_frame Reg.Set.empty i.dbg; ` {emit_string tglle}i {emit_reg i.arg.(0)}, {emit_int n}\n` | Lop(Iintop_imm(op, n)) -> let instr = name_for_intop_imm op in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n` | Lop(Inegf | Iabsf as op) -> let instr = name_for_floatop1 op in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> let instr = name_for_floatop2 op in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Ifloatofint) -> if ppc64 then begin ` stdu {emit_reg i.arg.(0)}, -16({emit_gpr 1})\n`; ` lfd {emit_reg i.res.(0)}, 0({emit_gpr 1})\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; ` fcfid {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` end else begin let lbl = new_label() in float_literals := ("4.503601774854144e15", lbl) :: !float_literals; (* That float above represents 0x4330000080000000 *) ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` lfd {emit_fpr 0}, {emit_lower emit_label lbl}({emit_gpr 11})\n`; ` lis {emit_gpr 0}, 0x4330\n`; ` stwu {emit_gpr 0}, -16({emit_gpr 1})\n`; ` xoris {emit_gpr 0}, {emit_reg i.arg.(0)}, 0x8000\n`; ` stw {emit_gpr 0}, 4({emit_gpr 1})\n`; ` lfd {emit_reg i.res.(0)}, 0({emit_gpr 1})\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; ` fsub {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_fpr 0}\n` end | Lop(Iintoffloat) -> let ofs = if ppc64 then 0 else 4 in ` {emit_string fctigz} {emit_fpr 0}, {emit_reg i.arg.(0)}\n`; ` stfdu {emit_fpr 0}, -16({emit_gpr 1})\n`; ` {emit_string lg} {emit_reg i.res.(0)}, {emit_int ofs}({emit_gpr 1})\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n` | Lop(Ispecific sop) -> let instr = name_for_specific sop in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n` | Lreloadretaddr -> let n = frame_size() in ` {emit_string lg} {emit_gpr 11}, {emit_int(n - size_addr)}({emit_gpr 1})\n`; ` mtlr {emit_gpr 11}\n` | Lreturn -> let n = frame_size() in if n > 0 then ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`; ` blr\n` | Llabel lbl -> `{emit_label lbl}:\n` | Lbranch lbl -> ` b {emit_label lbl}\n` | Lcondbranch(tst, lbl) -> begin match tst with Itruetest -> ` {emit_string cmpg}i {emit_reg i.arg.(0)}, 0\n`; emit_delay dslot; ` bne {emit_label lbl}\n` | Ifalsetest -> ` {emit_string cmpg}i {emit_reg i.arg.(0)}, 0\n`; emit_delay dslot; ` beq {emit_label lbl}\n` | Iinttest cmp -> let (comp, branch) = name_for_int_comparison cmp in ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; emit_delay dslot; ` {emit_string branch} {emit_label lbl}\n` | Iinttest_imm(cmp, n) -> let (comp, branch) = name_for_int_comparison cmp in ` {emit_string comp}i {emit_reg i.arg.(0)}, {emit_int n}\n`; emit_delay dslot; ` {emit_string branch} {emit_label lbl}\n` | Ifloattest(cmp, neg) -> ` fcmpu {emit_ccr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; (* bit 0 = lt, bit 1 = gt, bit 2 = eq *) let (bitnum, negtst) = match cmp with Ceq -> (2, neg) | Cne -> (2, not neg) | Cle -> ` cror 3, 0, 2\n`; (* lt or eq *) (3, neg) | Cgt -> (1, neg) | Cge -> ` cror 3, 1, 2\n`; (* gt or eq *) (3, neg) | Clt -> (0, neg) in emit_delay dslot; if negtst then ` bf {emit_int bitnum}, {emit_label lbl}\n` else ` bt {emit_int bitnum}, {emit_label lbl}\n` | Ioddtest -> ` andi. {emit_gpr 0}, {emit_reg i.arg.(0)}, 1\n`; emit_delay dslot; ` bne {emit_label lbl}\n` | Ieventest -> ` andi. {emit_gpr 0}, {emit_reg i.arg.(0)}, 1\n`; emit_delay dslot; ` beq {emit_label lbl}\n` end | Lcondbranch3(lbl0, lbl1, lbl2) -> ` {emit_string cmpg}i {emit_reg i.arg.(0)}, 1\n`; emit_delay dslot; begin match lbl0 with None -> () | Some lbl -> ` blt {emit_label lbl}\n` end; begin match lbl1 with None -> () | Some lbl -> ` beq {emit_label lbl}\n` end; begin match lbl2 with None -> () | Some lbl -> ` bgt {emit_label lbl}\n` end | Lswitch jumptbl -> let lbl = new_label() in ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` addi {emit_gpr 11}, {emit_gpr 11}, {emit_lower emit_label lbl}\n`; ` {emit_string slgi} {emit_gpr 0}, {emit_reg i.arg.(0)}, 2\n`; ` {emit_string lwa}x {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`; ` add {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`; ` mtctr {emit_gpr 0}\n`; ` bctr\n`; emit_string rodata_space; `{emit_label lbl}:`; for i = 0 to Array.length jumptbl - 1 do ` .long {emit_label jumptbl.(i)} - {emit_label lbl}\n` done; emit_string code_space | Lsetuptrap lbl -> ` bl {emit_label lbl}\n` | Lpushtrap -> stack_offset := !stack_offset + 16; ` mflr {emit_gpr 0}\n`; ` {emit_string stg}u {emit_gpr 0}, -16({emit_gpr 1})\n`; ` {emit_string stg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; ` mr {emit_gpr 29}, {emit_gpr 1}\n` | Lpoptrap -> ` {emit_string lg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; stack_offset := !stack_offset - 16 | Lraise -> if !Clflags.debug && supports_backtraces then begin ` bl {emit_symbol "caml_raise_exn"}\n`; record_frame Reg.Set.empty i.dbg end else begin ` {emit_string lg} {emit_gpr 0}, 0({emit_gpr 29})\n`; ` mr {emit_gpr 1}, {emit_gpr 29}\n`; ` mtlr {emit_gpr 0}\n`; ` {emit_string lg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; ` blr\n` end and emit_delay = function None -> () | Some i -> emit_instr i None (* Checks if a pseudo-instruction expands to instructions that do not branch and do not affect CR0 nor R12. *) let is_simple_instr i = match i.desc with Lop op -> begin match op with Icall_imm _ | Icall_ind | Itailcall_imm _ | Itailcall_ind | Iextcall(_, _) -> false | Ialloc(_) -> false | Iintop(Icomp _) -> false | Iintop_imm(Iand, _) -> false | Iintop_imm(Icomp _, _) -> false | _ -> true end | Lreloadretaddr -> true | _ -> false let no_interference res arg = try for i = 0 to Array.length arg - 1 do for j = 0 to Array.length res - 1 do if arg.(i).loc = res.(j).loc then raise Exit done done; true with Exit -> false (* Emit a sequence of instructions, trying to fill delay slots for branches *) let rec emit_all i = match i with {desc = Lend} -> () | {next = {desc = (Lcondbranch(_, _) | Lcondbranch3(_, _, _))}} when is_simple_instr i & no_interference i.res i.next.arg -> emit_instr i.next (Some i); emit_all i.next.next | _ -> emit_instr i None; emit_all i.next (* Emission of a function declaration *) let fundecl fundecl = function_name := fundecl.fun_name; defined_functions := StringSet.add fundecl.fun_name !defined_functions; tailrec_entry_point := new_label(); stack_offset := 0; call_gc_label := 0; float_literals := []; int_literals := []; if Config.system = "rhapsody" && not !Clflags.output_c_object && is_generic_function fundecl.fun_name then (* PR#4690 *) ` .private_extern {emit_symbol fundecl.fun_name}\n` else ` .globl {emit_symbol fundecl.fun_name}\n`; begin match Config.system with | "elf" | "bsd" -> ` .type {emit_symbol fundecl.fun_name}, @function\n` | _ -> () end; emit_string code_space; ` .align 2\n`; `{emit_symbol fundecl.fun_name}:\n`; let n = frame_size() in if !contains_calls then begin ` mflr {emit_gpr 0}\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int(-n)}\n`; ` {emit_string stg} {emit_gpr 0}, {emit_int(n - size_addr)}({emit_gpr 1})\n` end else begin if n > 0 then ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int(-n)}\n` end; `{emit_label !tailrec_entry_point}:\n`; branch_normalization fundecl.fun_body; emit_all fundecl.fun_body; (* Emit the glue code to call the GC *) if !call_gc_label > 0 then begin `{emit_label !call_gc_label}:\n`; ` b {emit_symbol "caml_call_gc"}\n` end; (* Emit the numeric literals *) if !float_literals <> [] || !int_literals <> [] then begin emit_string rodata_space; ` .align 3\n`; List.iter (fun (f, lbl) -> `{emit_label lbl}:`; if ppc64 then emit_float64_directive ".quad" f else emit_float64_split_directive ".long" f) !float_literals; List.iter (fun (n, lbl) -> `{emit_label lbl}: {emit_string datag} {emit_nativeint n}\n`) !int_literals end (* Emission of data *) let declare_global_data s = ` .globl {emit_symbol s}\n`; if Config.system = "elf" || Config.system = "bsd" then ` .type {emit_symbol s}, @object\n` let emit_item = function Cglobal_symbol s -> declare_global_data s | Cdefine_symbol s -> `{emit_symbol s}:\n`; | Cdefine_label lbl -> `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> ` .short {emit_int n}\n` | Cint32 n -> ` .long {emit_nativeint n}\n` | Cint n -> ` {emit_string datag} {emit_nativeint n}\n` | Csingle f -> emit_float32_directive ".long" f | Cdouble f -> if ppc64 then emit_float64_directive ".quad" f else emit_float64_split_directive ".long" f | Csymbol_address s -> ` {emit_string datag} {emit_symbol s}\n` | Clabel_address lbl -> ` {emit_string datag} {emit_data_label lbl}\n` | Cstring s -> emit_bytes_directive " .byte " s | Cskip n -> if n > 0 then ` .space {emit_int n}\n` | Calign n -> ` .align {emit_int (Misc.log2 n)}\n` let data l = emit_string data_space; List.iter emit_item l (* Beginning / end of an assembly file *) let begin_assembly() = defined_functions := StringSet.empty; external_functions := StringSet.empty; (* Emit the beginning of the segments *) let lbl_begin = Compilenv.make_symbol (Some "data_begin") in emit_string data_space; declare_global_data lbl_begin; `{emit_symbol lbl_begin}:\n`; let lbl_begin = Compilenv.make_symbol (Some "code_begin") in emit_string code_space; declare_global_data lbl_begin; `{emit_symbol lbl_begin}:\n` let end_assembly() = if pic_externals then (* Emit the pointers to external functions *) StringSet.iter emit_external !external_functions; (* Emit the end of the segments *) emit_string code_space; let lbl_end = Compilenv.make_symbol (Some "code_end") in declare_global_data lbl_end; `{emit_symbol lbl_end}:\n`; ` .long 0\n`; emit_string data_space; let lbl_end = Compilenv.make_symbol (Some "data_end") in declare_global_data lbl_end; `{emit_symbol lbl_end}:\n`; ` {emit_string datag} 0\n`; (* Emit the frame descriptors *) emit_string rodata_space; let lbl = Compilenv.make_symbol (Some "frametable") in declare_global_data lbl; `{emit_symbol lbl}:\n`; emit_frames { efa_label = (fun l -> ` {emit_string datag} {emit_label l}\n`); efa_16 = (fun n -> ` .short {emit_int n}\n`); efa_32 = (fun n -> ` .long {emit_int32 n}\n`); efa_word = (fun n -> ` {emit_string datag} {emit_int n}\n`); efa_align = (fun n -> ` .align {emit_int (Misc.log2 n)}\n`); efa_label_rel = (fun lbl ofs -> ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n`); efa_def_label = (fun l -> `{emit_label l}:\n`); efa_string = (fun s -> emit_bytes_directive " .byte " (s ^ "\000")) } mingw-ocaml/ocaml/asmcomp/i386/0000755000175000017500000000000012124403240015605 5ustar tootstootsmingw-ocaml/ocaml/asmcomp/i386/emit_nt.mlp0000644000175000017500000007305012124403240017763 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Emission of Intel 386 assembly code, MASM syntax. *) module StringSet = Set.Make(struct type t = string let compare = compare end) open Misc open Cmm open Arch open Proc open Reg open Mach open Linearize open Emitaux (* Tradeoff between code size and code speed *) let fastcode_flag = ref true (* Layout of the stack frame *) let stack_offset = ref 0 let frame_size () = (* includes return address *) !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4 let slot_offset loc cl = match loc with Incoming n -> assert (n >= 0); frame_size() + n | Local n -> if cl = 0 then !stack_offset + n * 4 else !stack_offset + num_stack_slots.(0) * 4 + n * 8 | Outgoing n -> assert (n >= 0); n (* Record symbols used and defined - at the end generate extern for those used but not defined *) let symbols_defined = ref StringSet.empty let symbols_used = ref StringSet.empty let add_def_symbol s = symbols_defined := StringSet.add s !symbols_defined let add_used_symbol s = symbols_used := StringSet.add s !symbols_used let emit_symbol s = emit_string "_"; Emitaux.emit_symbol '$' s let emit_int32 n = emit_printf "0%lxh" n (* Output a label *) let emit_label lbl = emit_string "L"; emit_int lbl let emit_data_label lbl = emit_string "Ld"; emit_int lbl (* Output an align directive. *) let emit_align n = ` ALIGN {emit_int n}\n` (* Output a pseudo-register *) let emit_reg = function { loc = Reg r } -> emit_string (register_name r) | { loc = Stack(Incoming n | Outgoing n) } when n < 0 -> `{emit_symbol "caml_extra_params"} + {emit_int (n + 64)}` | { loc = Stack s; typ = Float } as r -> let ofs = slot_offset s (register_class r) in `REAL8 PTR {emit_int ofs}[esp]` | { loc = Stack s } as r -> let ofs = slot_offset s (register_class r) in `DWORD PTR {emit_int ofs}[esp]` | { loc = Unknown } -> fatal_error "Emit.emit_reg" (* Output a reference to the lower 8 bits or lower 16 bits of a register *) let reg_low_byte_name = [| "al"; "bl"; "cl"; "dl" |] let reg_low_half_name = [| "ax"; "bx"; "cx"; "dx"; "si"; "di"; "bp" |] let emit_reg8 r = match r.loc with Reg r when r < 4 -> emit_string (reg_low_byte_name.(r)) | _ -> fatal_error "Emit.emit_reg8" let emit_reg16 r = match r.loc with Reg r when r < 7 -> emit_string (reg_low_half_name.(r)) | _ -> fatal_error "Emit.emit_reg16" (* Check if the given register overlaps (same location) with the given array of registers *) let register_overlap reg arr = try for i = 0 to Array.length arr - 1 do if reg.loc = arr.(i).loc then raise Exit done; false with Exit -> true (* Output an addressing mode *) let emit_signed_int d = if d > 0 then emit_char '+'; if d <> 0 then emit_int d let emit_addressing addr r n = match addr with Ibased(s, d) -> add_used_symbol s; `{emit_symbol s}{emit_signed_int d}` | Iindexed d -> `[{emit_reg r.(n)}{emit_signed_int d}]` | Iindexed2 d -> `[{emit_reg r.(n)}+{emit_reg r.(n+1)}{emit_signed_int d}]` | Iscaled(2, d) -> `[{emit_reg r.(n)}+{emit_reg r.(n)}{emit_signed_int d}]` | Iscaled(scale, d) -> `[{emit_reg r.(n)}*{emit_int scale}{emit_signed_int d}]` | Iindexed2scaled(scale, d) -> `[{emit_reg r.(n)}+{emit_reg r.(n+1)}*{emit_int scale}{emit_signed_int d}]` (* Record live pointers at call points *) let record_frame_label live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter (function {typ = Addr; loc = Reg r} -> live_offset := ((r lsl 1) + 1) :: !live_offset | {typ = Addr; loc = Stack s} as reg -> live_offset := slot_offset s (register_class reg) :: !live_offset | _ -> ()) live; frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); fd_live_offset = !live_offset; fd_debuginfo = dbg } :: !frame_descriptors; lbl let record_frame live dbg = let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` (* Record calls to the GC -- we've moved them out of the way *) type gc_call = { gc_lbl: label; (* Entry label *) gc_return_lbl: label; (* Where to branch after GC *) gc_frame: label } (* Label of frame descriptor *) let call_gc_sites = ref ([] : gc_call list) let emit_call_gc gc = `{emit_label gc.gc_lbl}: call _caml_call_gc\n`; `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` (* Record calls to caml_ml_array_bound_error. In -g mode, we maintain one call to caml_ml_array_bound_error per bound check site. Without -g, we can share a single call. *) type bound_error_call = { bd_lbl: label; (* Entry label *) bd_frame: label } (* Label of frame descriptor *) let bound_error_sites = ref ([] : bound_error_call list) let bound_error_call = ref 0 let bound_error_label dbg = if !Clflags.debug then begin let lbl_bound_error = new_label() in let lbl_frame = record_frame_label Reg.Set.empty dbg in bound_error_sites := { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; lbl_bound_error end else begin if !bound_error_call = 0 then bound_error_call := new_label(); !bound_error_call end let emit_call_bound_error bd = `{emit_label bd.bd_lbl}: call _caml_ml_array_bound_error\n`; `{emit_label bd.bd_frame}:\n` let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then `{emit_label !bound_error_call}: call _caml_ml_array_bound_error\n` (* Names for instructions *) let instr_for_intop = function Iadd -> "add" | Isub -> "sub" | Imul -> "imul" | Iand -> "and" | Ior -> "or" | Ixor -> "xor" | Ilsl -> "sal" | Ilsr -> "shr" | Iasr -> "sar" | _ -> fatal_error "Emit: instr_for_intop" let instr_for_floatop = function Inegf -> "fchs" | Iabsf -> "fabs" | Iaddf -> "fadd" | Isubf -> "fsub" | Imulf -> "fmul" | Idivf -> "fdiv" | Ispecific Isubfrev -> "fsubr" | Ispecific Idivfrev -> "fdivr" | _ -> fatal_error "Emit: instr_for_floatop" let instr_for_floatop_reversed = function Iaddf -> "fadd" | Isubf -> "fsubr" | Imulf -> "fmul" | Idivf -> "fdivr" | Ispecific Isubfrev -> "fsub" | Ispecific Idivfrev -> "fdiv" | _ -> fatal_error "Emit: instr_for_floatop_reversed" let instr_for_floatarithmem = function Ifloatadd -> "fadd" | Ifloatsub -> "fsub" | Ifloatsubrev -> "fsubr" | Ifloatmul -> "fmul" | Ifloatdiv -> "fdiv" | Ifloatdivrev -> "fdivr" let name_for_cond_branch = function Isigned Ceq -> "e" | Isigned Cne -> "ne" | Isigned Cle -> "le" | Isigned Cgt -> "g" | Isigned Clt -> "l" | Isigned Cge -> "ge" | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" (* Output an = 0 or <> 0 test. *) let output_test_zero arg = match arg.loc with Reg r -> ` test {emit_reg arg}, {emit_reg arg}\n` | _ -> ` cmp {emit_reg arg}, 0\n` (* Deallocate the stack frame before a return or tail call *) let output_epilogue () = let n = frame_size() - 4 in if n > 0 then ` add esp, {emit_int n}\n` (* Determine if the given register is the top of the floating-point stack *) let is_tos = function { loc = Reg _; typ = Float } -> true | _ -> false (* Emit the code for a floating-point comparison *) let emit_float_test cmp neg arg lbl = let actual_cmp = match (is_tos arg.(0), is_tos arg.(1)) with (true, true) -> (* both args on top of FP stack *) ` fcompp\n`; cmp | (true, false) -> (* first arg on top of FP stack *) ` fcomp {emit_reg arg.(1)}\n`; cmp | (false, true) -> (* second arg on top of FP stack *) ` fcomp {emit_reg arg.(0)}\n`; Cmm.swap_comparison cmp | (false, false) -> ` fld {emit_reg arg.(0)}\n`; ` fcomp {emit_reg arg.(1)}\n`; cmp in ` fnstsw ax\n`; begin match actual_cmp with Ceq -> if neg then begin ` and ah, 68\n`; ` xor ah, 64\n`; ` jne ` end else begin ` and ah, 69\n`; ` cmp ah, 64\n`; ` je ` end | Cne -> if neg then begin ` and ah, 69\n`; ` cmp ah, 64\n`; ` je ` end else begin ` and ah, 68\n`; ` xor ah, 64\n`; ` jne ` end | Cle -> ` and ah, 69\n`; ` dec ah\n`; ` cmp ah, 64\n`; if neg then ` jae ` else ` jb ` | Cge -> ` and ah, 5\n`; if neg then ` jne ` else ` je ` | Clt -> ` and ah, 69\n`; ` cmp ah, 1\n`; if neg then ` jne ` else ` je ` | Cgt -> ` and ah, 69\n`; if neg then ` jne ` else ` je ` end; `{emit_label lbl}\n` (* Emit a Ifloatspecial instruction *) let emit_floatspecial = function "atan" -> ` fld1\n\tfpatan\n` | "atan2" -> ` fpatan\n` | "cos" -> ` fcos\n` | "log" -> ` fldln2\n\tfxch\n\tfyl2x\n` | "log10" -> ` fldlg2\n\tfxch\n\tfyl2x\n` | "sin" -> ` fsin\n` | "sqrt" -> ` fsqrt\n` | "tan" -> ` fptan\n\tfstp st(0)\n` | _ -> assert false (* Output the assembly code for an instruction *) (* Name of current function *) let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 (* Label of trap for out-of-range accesses *) let range_check_trap = ref 0 let float_constants = ref ([] : (int * string) list) let emit_instr i = match i.desc with Lend -> () | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin if src.typ = Float then if is_tos src then ` fstp {emit_reg dst}\n` else if is_tos dst then ` fld {emit_reg src}\n` else begin ` fld {emit_reg src}\n`; ` fstp {emit_reg dst}\n` end else ` mov {emit_reg dst}, {emit_reg src}\n` end | Lop(Iconst_int n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xor {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> ` mov {emit_reg i.res.(0)}, 0\n` end else ` mov {emit_reg i.res.(0)}, {emit_nativeint n}\n` | Lop(Iconst_float s) -> begin match Int64.bits_of_float (float_of_string s) with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` fldz\n` | 0x8000_0000_0000_0000L -> (* -0.0 *) ` fldz\n fchs\n` | 0x3FF0_0000_0000_0000L -> (* 1.0 *) ` fld1\n` | 0xBFF0_0000_0000_0000L -> (* -1.0 *) ` fld1\n fchs\n` | _ -> let lbl = new_label() in float_constants := (lbl, s) :: !float_constants; ` fld {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> add_used_symbol s; ` mov {emit_reg i.res.(0)}, OFFSET {emit_symbol s}\n` | Lop(Icall_ind) -> ` call {emit_reg i.arg.(0)}\n`; record_frame i.live i.dbg | Lop(Icall_imm s) -> add_used_symbol s; ` call {emit_symbol s}\n`; record_frame i.live i.dbg | Lop(Itailcall_ind) -> output_epilogue(); ` jmp {emit_reg i.arg.(0)}\n` | Lop(Itailcall_imm s) -> if s = !function_name then ` jmp {emit_label !tailrec_entry_point}\n` else begin output_epilogue(); add_used_symbol s; ` jmp {emit_symbol s}\n` end | Lop(Iextcall(s, alloc)) -> add_used_symbol s ; if alloc then begin ` mov eax, OFFSET {emit_symbol s}\n`; ` call _caml_c_call\n`; record_frame i.live i.dbg end else begin ` call {emit_symbol s}\n` end | Lop(Istackoffset n) -> if n >= 0 then ` sub esp, {emit_int n}\n` else ` add esp, {emit_int(-n)}\n`; stack_offset := !stack_offset + n | Lop(Iload(chunk, addr)) -> let dest = i.res.(0) in begin match chunk with | Word | Thirtytwo_signed | Thirtytwo_unsigned -> ` mov {emit_reg dest}, DWORD PTR {emit_addressing addr i.arg 0}\n` | Byte_unsigned -> ` movzx {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n` | Byte_signed -> ` movsx {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n` | Sixteen_unsigned -> ` movzx {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n` | Sixteen_signed -> ` movsx {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n` | Single -> ` fld REAL4 PTR {emit_addressing addr i.arg 0}\n` | Double | Double_u -> ` fld REAL8 PTR {emit_addressing addr i.arg 0}\n` end | Lop(Istore(chunk, addr)) -> begin match chunk with | Word | Thirtytwo_signed | Thirtytwo_unsigned -> ` mov DWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` | Byte_unsigned | Byte_signed -> ` mov BYTE PTR {emit_addressing addr i.arg 1}, {emit_reg8 i.arg.(0)}\n` | Sixteen_unsigned | Sixteen_signed -> ` mov WORD PTR {emit_addressing addr i.arg 1}, {emit_reg16 i.arg.(0)}\n` | Single -> if is_tos i.arg.(0) then ` fstp REAL4 PTR {emit_addressing addr i.arg 1}\n` else begin ` fld {emit_reg i.arg.(0)}\n`; ` fstp REAL4 PTR {emit_addressing addr i.arg 1}\n` end | Double | Double_u -> if is_tos i.arg.(0) then ` fstp REAL8 PTR {emit_addressing addr i.arg 1}\n` else begin ` fld {emit_reg i.arg.(0)}\n`; ` fstp REAL8 PTR {emit_addressing addr i.arg 1}\n` end end | Lop(Ialloc n) -> if !fastcode_flag then begin let lbl_redo = new_label() in `{emit_label lbl_redo}: mov eax, _caml_young_ptr\n`; ` sub eax, {emit_int n}\n`; ` mov _caml_young_ptr, eax\n`; ` cmp eax, _caml_young_limit\n`; let lbl_call_gc = new_label() in let lbl_frame = record_frame_label i.live Debuginfo.none in ` jb {emit_label lbl_call_gc}\n`; ` lea {emit_reg i.res.(0)}, [eax+4]\n`; call_gc_sites := { gc_lbl = lbl_call_gc; gc_return_lbl = lbl_redo; gc_frame = lbl_frame } :: !call_gc_sites end else begin begin match n with 8 -> ` call _caml_alloc1\n` | 12 -> ` call _caml_alloc2\n` | 16 -> ` call _caml_alloc3\n` | _ -> ` mov eax, {emit_int n}\n`; ` call _caml_allocN\n` end; `{record_frame i.live Debuginfo.none} lea {emit_reg i.res.(0)}, [eax+4]\n` end | Lop(Iintop(Icomp cmp)) -> ` cmp {emit_reg i.arg.(0)},{emit_reg i.arg.(1)}\n`; let b = name_for_cond_branch cmp in ` set{emit_string b} al\n`; ` movzx {emit_reg i.res.(0)}, al\n` | Lop(Iintop_imm(Icomp cmp, n)) -> ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; let b = name_for_cond_branch cmp in ` set{emit_string b} al\n`; ` movzx {emit_reg i.res.(0)}, al\n` | Lop(Iintop Icheckbound) -> let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` jbe {emit_label lbl}\n` | Lop(Iintop_imm(Icheckbound, n)) -> let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; ` jbe {emit_label lbl}\n` | Lop(Iintop(Idiv | Imod)) -> ` cdq\n`; ` idiv {emit_reg i.arg.(1)}\n` | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, cl\n` | Lop(Iintop op) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> ` lea {emit_reg i.res.(0)}, [{emit_reg i.arg.(0)}+{emit_int n}]\n` | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> ` inc {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> ` dec {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Idiv, n)) -> let l = Misc.log2 n in let lbl = new_label() in output_test_zero i.arg.(0); ` jge {emit_label lbl}\n`; ` add {emit_reg i.arg.(0)}, {emit_int(n-1)}\n`; `{emit_label lbl}: sar {emit_reg i.arg.(0)}, {emit_int l}\n` | Lop(Iintop_imm(Imod, n)) -> let lbl = new_label() in ` mov eax, {emit_reg i.arg.(0)}\n`; ` test eax, eax\n`; ` jge {emit_label lbl}\n`; ` add eax, {emit_int(n-1)}\n`; `{emit_label lbl}: and eax, {emit_int(-n)}\n`; ` sub {emit_reg i.arg.(0)}, eax\n` | Lop(Iintop_imm(op, n)) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_int n}\n` | Lop(Inegf | Iabsf as floatop) -> if not (is_tos i.arg.(0)) then ` fld {emit_reg i.arg.(0)}\n`; ` {emit_string(instr_for_floatop floatop)}\n` | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific(Isubfrev | Idivfrev) as floatop) -> begin match (is_tos i.arg.(0), is_tos i.arg.(1)) with (true, true) -> (* both operands on top of FP stack *) ` {emit_string(instr_for_floatop_reversed floatop)}\n` | (true, false) -> (* first operand on stack *) ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` | (false, true) -> (* second operand on stack *) ` {emit_string(instr_for_floatop_reversed floatop)} {emit_reg i.arg.(0)}\n` | (false, false) -> (* both operands in memory *) ` fld {emit_reg i.arg.(0)}\n`; ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` end | Lop(Ifloatofint) -> begin match i.arg.(0).loc with Stack s -> ` fild {emit_reg i.arg.(0)}\n` | _ -> ` push {emit_reg i.arg.(0)}\n`; ` fild DWORD PTR [esp]\n`; ` add esp, 4\n` end | Lop(Iintoffloat) -> if not (is_tos i.arg.(0)) then ` fld {emit_reg i.arg.(0)}\n`; stack_offset := !stack_offset - 8; ` sub esp, 8\n`; ` fnstcw [esp+4]\n`; ` mov ax, [esp+4]\n`; ` mov ah, 12\n`; ` mov [esp], ax\n`; ` fldcw [esp]\n`; begin match i.res.(0).loc with Stack s -> ` fistp {emit_reg i.res.(0)}\n` | _ -> ` fistp DWORD PTR [esp]\n`; ` mov {emit_reg i.res.(0)}, [esp]\n` end; ` fldcw [esp+4]\n`; ` add esp, 8\n`; stack_offset := !stack_offset + 8 | Lop(Ispecific(Ilea addr)) -> ` lea {emit_reg i.res.(0)}, DWORD PTR {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Istore_int(n, addr))) -> ` mov DWORD PTR {emit_addressing addr i.arg 0},{emit_nativeint n}\n` | Lop(Ispecific(Istore_symbol(s, addr))) -> add_used_symbol s ; ` mov DWORD PTR {emit_addressing addr i.arg 0},OFFSET {emit_symbol s}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> ` add DWORD PTR {emit_addressing addr i.arg 0},{emit_int n}\n` | Lop(Ispecific(Ipush)) -> (* Push arguments in reverse order *) for n = Array.length i.arg - 1 downto 0 do let r = i.arg.(n) in match r with {loc = Reg rn; typ = Float} -> ` sub esp, 8\n`; ` fstp REAL8 PTR 0[esp]\n`; stack_offset := !stack_offset + 8 | {loc = Stack sl; typ = Float} -> let ofs = slot_offset sl 1 in ` push DWORD PTR {emit_int (ofs + 4)}[esp]\n`; ` push DWORD PTR {emit_int (ofs + 4)}[esp]\n`; stack_offset := !stack_offset + 8 | _ -> ` push {emit_reg r}\n`; stack_offset := !stack_offset + 4 done | Lop(Ispecific(Ipush_int n)) -> ` push {emit_nativeint n}\n`; stack_offset := !stack_offset + 4 | Lop(Ispecific(Ipush_symbol s)) -> add_used_symbol s; ` push OFFSET {emit_symbol s}\n`; stack_offset := !stack_offset + 4 | Lop(Ispecific(Ipush_load addr)) -> ` push DWORD PTR {emit_addressing addr i.arg 0}\n`; stack_offset := !stack_offset + 4 | Lop(Ispecific(Ipush_load_float addr)) -> ` push DWORD PTR {emit_addressing (offset_addressing addr 4) i.arg 0}\n`; ` push DWORD PTR {emit_addressing addr i.arg 0}\n`; stack_offset := !stack_offset + 8 | Lop(Ispecific(Ifloatarithmem(double, op, addr))) -> if not (is_tos i.arg.(0)) then ` fld {emit_reg i.arg.(0)}\n`; let size = if double then "REAL8" else "REAL4" in ` {emit_string(instr_for_floatarithmem op)} {emit_string size} PTR {emit_addressing addr i.arg 1}\n` | Lop(Ispecific(Ifloatspecial s)) -> (* Push args on float stack if necessary *) for k = 0 to Array.length i.arg - 1 do if not (is_tos i.arg.(k)) then ` fld {emit_reg i.arg.(k)}\n` done; (* Fix-up for binary instrs whose args were swapped *) if Array.length i.arg = 2 && is_tos i.arg.(1) then ` fxch st(1)\n`; emit_floatspecial s | Lreloadretaddr -> () | Lreturn -> output_epilogue(); ` ret\n` | Llabel lbl -> `{emit_label lbl}:\n` | Lbranch lbl -> ` jmp {emit_label lbl}\n` | Lcondbranch(tst, lbl) -> begin match tst with Itruetest -> output_test_zero i.arg.(0); ` jne {emit_label lbl}\n` | Ifalsetest -> output_test_zero i.arg.(0); ` je {emit_label lbl}\n` | Iinttest cmp -> ` cmp {emit_reg i.arg.(0)},{emit_reg i.arg.(1)}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` | Iinttest_imm((Isigned Ceq | Isigned Cne | Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> output_test_zero i.arg.(0); let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` | Iinttest_imm(cmp, n) -> ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` | Ifloattest(cmp, neg) -> emit_float_test cmp neg i.arg lbl | Ioddtest -> ` test {emit_reg i.arg.(0)}, 1\n`; ` jne {emit_label lbl}\n` | Ieventest -> ` test {emit_reg i.arg.(0)}, 1\n`; ` je {emit_label lbl}\n` end | Lcondbranch3(lbl0, lbl1, lbl2) -> ` cmp {emit_reg i.arg.(0)}, 1\n`; begin match lbl0 with None -> () | Some lbl -> ` jb {emit_label lbl}\n` end; begin match lbl1 with None -> () | Some lbl -> ` je {emit_label lbl}\n` end; begin match lbl2 with None -> () | Some lbl -> ` jg {emit_label lbl}\n` end | Lswitch jumptbl -> let lbl = new_label() in ` jmp [{emit_reg i.arg.(0)} * 4 + {emit_label lbl}]\n`; ` .DATA\n`; `{emit_label lbl}`; for i = 0 to Array.length jumptbl - 1 do ` DWORD {emit_label jumptbl.(i)}\n` done; ` .CODE\n` | Lsetuptrap lbl -> ` call {emit_label lbl}\n` | Lpushtrap -> ` push _caml_exception_pointer\n`; ` mov _caml_exception_pointer, esp\n`; stack_offset := !stack_offset + 8 | Lpoptrap -> ` pop _caml_exception_pointer\n`; ` add esp, 4\n`; stack_offset := !stack_offset - 8 | Lraise -> if !Clflags.debug then begin ` call _caml_raise_exn\n`; record_frame Reg.Set.empty i.dbg end else begin ` mov esp, _caml_exception_pointer\n`; ` pop _caml_exception_pointer\n`; ` ret\n` end let rec emit_all i = match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next (* Emission of the floating-point constants *) let emit_float s = (* MASM doesn't like floating-point constants such as 2e9. Turn them into 2.0e9. *) let pos_e = ref (-1) and pos_dot = ref (-1) in for i = 0 to String.length s - 1 do match s.[i] with 'e'|'E' -> pos_e := i | '.' -> pos_dot := i | _ -> () done; if !pos_dot < 0 && !pos_e >= 0 then begin emit_string (String.sub s 0 !pos_e); emit_string ".0"; emit_string (String.sub s !pos_e (String.length s - !pos_e)) end else emit_string s let emit_float_constant (lbl, cst) = `{emit_label lbl} REAL8 {emit_float cst}\n` (* Emission of a function declaration *) let fundecl fundecl = function_name := fundecl.fun_name; fastcode_flag := fundecl.fun_fast; tailrec_entry_point := new_label(); stack_offset := 0; float_constants := []; call_gc_sites := []; bound_error_sites := []; bound_error_call := 0; ` .CODE\n`; add_def_symbol fundecl.fun_name; emit_align 4; ` PUBLIC {emit_symbol fundecl.fun_name}\n`; `{emit_symbol fundecl.fun_name}:\n`; let n = frame_size() - 4 in if n > 0 then ` sub esp, {emit_int n}\n`; `{emit_label !tailrec_entry_point}:\n`; emit_all fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors (); begin match !float_constants with [] -> () | _ -> ` .DATA\n`; List.iter emit_float_constant !float_constants; float_constants := [] end (* Emission of data *) let emit_item = function Cglobal_symbol s -> ` PUBLIC {emit_symbol s}\n`; | Cdefine_symbol s -> add_def_symbol s ; `{emit_symbol s} LABEL DWORD\n` | Cdefine_label lbl -> `{emit_data_label lbl} LABEL DWORD\n` | Cint8 n -> ` BYTE {emit_int n}\n` | Cint16 n -> ` WORD {emit_int n}\n` | Cint n -> ` DWORD {emit_nativeint n}\n` | Cint32 n -> ` DWORD {emit_nativeint n}\n` | Csingle f -> ` REAL4 {emit_float f}\n` | Cdouble f -> ` REAL8 {emit_float f}\n` | Csymbol_address s -> add_used_symbol s ; ` DWORD {emit_symbol s}\n` | Clabel_address lbl -> ` DWORD {emit_data_label lbl}\n` | Cstring s -> emit_bytes_directive " BYTE " s | Cskip n -> if n > 0 then ` BYTE {emit_int n} DUP (?)\n` | Calign n -> emit_align n let data l = ` .DATA\n`; List.iter emit_item l (* Beginning / end of an assembly file *) let begin_assembly() = `.386\n`; ` .MODEL FLAT\n\n`; ` EXTERN _caml_young_ptr: DWORD\n`; ` EXTERN _caml_young_limit: DWORD\n`; ` EXTERN _caml_exception_pointer: DWORD\n`; ` EXTERN _caml_extra_params: DWORD\n`; ` EXTERN _caml_call_gc: PROC\n`; ` EXTERN _caml_c_call: PROC\n`; ` EXTERN _caml_allocN: PROC\n`; ` EXTERN _caml_alloc1: PROC\n`; ` EXTERN _caml_alloc2: PROC\n`; ` EXTERN _caml_alloc3: PROC\n`; ` EXTERN _caml_ml_array_bound_error: PROC\n`; ` EXTERN _caml_raise_exn: PROC\n`; ` .DATA\n`; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in add_def_symbol lbl_begin; ` PUBLIC {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin} LABEL DWORD\n`; ` .CODE\n`; let lbl_begin = Compilenv.make_symbol (Some "code_begin") in add_def_symbol lbl_begin; ` PUBLIC {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin} LABEL DWORD\n` let end_assembly() = ` .CODE\n`; let lbl_end = Compilenv.make_symbol (Some "code_end") in add_def_symbol lbl_end; ` PUBLIC {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end} LABEL DWORD\n`; ` .DATA\n`; let lbl_end = Compilenv.make_symbol (Some "data_end") in add_def_symbol lbl_end; ` PUBLIC {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end} LABEL DWORD\n`; ` DWORD 0\n`; let lbl = Compilenv.make_symbol (Some "frametable") in add_def_symbol lbl; ` PUBLIC {emit_symbol lbl}\n`; `{emit_symbol lbl}`; emit_frames { efa_label = (fun l -> ` DWORD {emit_label l}\n`); efa_16 = (fun n -> ` WORD {emit_int n}\n`); efa_32 = (fun n -> ` DWORD {emit_int32 n}\n`); efa_word = (fun n -> ` DWORD {emit_int n}\n`); efa_align = emit_align; efa_label_rel = (fun lbl ofs -> ` DWORD {emit_label lbl} - THIS BYTE + {emit_int32 ofs}\n`); efa_def_label = (fun l -> `{emit_label l} LABEL DWORD\n`); efa_string = (fun s -> emit_bytes_directive " BYTE " (s ^ "\000")) }; `\n;External functions\n\n`; StringSet.iter (fun s -> if not (StringSet.mem s !symbols_defined) then ` EXTERN {emit_symbol s}: PROC\n`) !symbols_used; symbols_used := StringSet.empty; symbols_defined := StringSet.empty; `END\n` mingw-ocaml/ocaml/asmcomp/i386/scheduling.ml0000644000175000017500000000216412124403240020267 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Schedgen (* to create a dependency *) (* Scheduling is turned off because our model does not fit the 486 nor the Pentium very well. In particular, it messes up with the float reg stack. The Pentiums Pro / II / III / etc schedule at run-time much better than what we could do. *) let fundecl f = f mingw-ocaml/ocaml/asmcomp/i386/arch.ml0000644000175000017500000001344312124403240017061 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Machine-specific command-line options *) let fast_math = ref false let command_line_options = [ "-ffast-math", Arg.Set fast_math, " Inline trigonometric and exponential functions" ] (* Specific operations for the Intel 386 processor *) open Misc open Format type addressing_mode = Ibased of string * int (* symbol + displ *) | Iindexed of int (* reg + displ *) | Iindexed2 of int (* reg + reg + displ *) | Iscaled of int * int (* reg * scale + displ *) | Iindexed2scaled of int * int (* reg + reg * scale + displ *) type specific_operation = Ilea of addressing_mode (* Lea gives scaled adds *) | Istore_int of nativeint * addressing_mode (* Store an integer constant *) | Istore_symbol of string * addressing_mode (* Store a symbol *) | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) | Ipush (* Push regs on stack *) | Ipush_int of nativeint (* Push an integer constant *) | Ipush_symbol of string (* Push a symbol *) | Ipush_load of addressing_mode (* Load a scalar and push *) | Ipush_load_float of addressing_mode (* Load a float and push *) | Isubfrev | Idivfrev (* Reversed float sub and div *) | Ifloatarithmem of bool * float_operation * addressing_mode (* Float arith operation with memory *) (* bool: true=64 bits, false=32 *) | Ifloatspecial of string and float_operation = Ifloatadd | Ifloatsub | Ifloatsubrev | Ifloatmul | Ifloatdiv | Ifloatdivrev (* Sizes, endianness *) let big_endian = false let size_addr = 4 let size_int = 4 let size_float = 8 (* Behavior of division *) let division_crashes_on_overflow = true (* Operations on addressing modes *) let identity_addressing = Iindexed 0 let offset_addressing addr delta = match addr with Ibased(s, n) -> Ibased(s, n + delta) | Iindexed n -> Iindexed(n + delta) | Iindexed2 n -> Iindexed2(n + delta) | Iscaled(scale, n) -> Iscaled(scale, n + delta) | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta) let num_args_addressing = function Ibased(s, n) -> 0 | Iindexed n -> 1 | Iindexed2 n -> 2 | Iscaled(scale, n) -> 1 | Iindexed2scaled(scale, n) -> 2 (* Printing operations and addressing modes *) let print_addressing printreg addr ppf arg = match addr with | Ibased(s, 0) -> fprintf ppf "\"%s\"" s | Ibased(s, n) -> fprintf ppf "\"%s\" + %i" s n | Iindexed n -> let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in fprintf ppf "%a%s" printreg arg.(0) idx | Iindexed2 n -> let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in fprintf ppf "%a + %a%s" printreg arg.(0) printreg arg.(1) idx | Iscaled(scale, n) -> let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in fprintf ppf "%a * %i%s" printreg arg.(0) scale idx | Iindexed2scaled(scale, n) -> let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in fprintf ppf "%a + %a * %i%s" printreg arg.(0) printreg arg.(1) scale idx let print_specific_operation printreg op ppf arg = match op with | Ilea addr -> print_addressing printreg addr ppf arg | Istore_int(n, addr) -> fprintf ppf "[%a] := %s" (print_addressing printreg addr) arg (Nativeint.to_string n) | Istore_symbol(lbl, addr) -> fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl | Ioffset_loc(n, addr) -> fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n | Ipush -> fprintf ppf "push "; for i = 0 to Array.length arg - 1 do if i > 0 then fprintf ppf ", "; printreg ppf arg.(i) done | Ipush_int n -> fprintf ppf "push %s" (Nativeint.to_string n) | Ipush_symbol s -> fprintf ppf "push \"%s\"" s | Ipush_load addr -> fprintf ppf "push [%a]" (print_addressing printreg addr) arg | Ipush_load_float addr -> fprintf ppf "pushfloat [%a]" (print_addressing printreg addr) arg | Isubfrev -> fprintf ppf "%a -f(rev) %a" printreg arg.(0) printreg arg.(1) | Idivfrev -> fprintf ppf "%a /f(rev) %a" printreg arg.(0) printreg arg.(1) | Ifloatarithmem(double, op, addr) -> let op_name = function | Ifloatadd -> "+f" | Ifloatsub -> "-f" | Ifloatsubrev -> "-f(rev)" | Ifloatmul -> "*f" | Ifloatdiv -> "/f" | Ifloatdivrev -> "/f(rev)" in let long = if double then "float64" else "float32" in fprintf ppf "%a %s %s[%a]" printreg arg.(0) (op_name op) long (print_addressing printreg addr) (Array.sub arg 1 (Array.length arg - 1)) | Ifloatspecial name -> fprintf ppf "%s " name; for i = 0 to Array.length arg - 1 do if i > 0 then fprintf ppf ", "; printreg ppf arg.(i) done (* Stack alignment constraints *) let stack_alignment = match Config.system with | "macosx" -> 16 | _ -> 4 mingw-ocaml/ocaml/asmcomp/i386/proc.ml0000644000175000017500000001415412124403240017107 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Description of the Intel 386 processor *) open Misc open Arch open Cmm open Reg open Mach (* Which asm conventions to use *) let masm = match Config.ccomp_type with | "msvc" -> true | _ -> false (* Registers available for register allocation *) (* Register map: eax 0 eax - edi: function arguments and results ebx 1 eax: C function results ecx 2 ebx, esi, edi, ebp: preserved by C edx 3 esi 4 edi 5 ebp 6 tos 100 top of floating-point stack. *) let int_reg_name = if masm then [| "eax"; "ebx"; "ecx"; "edx"; "esi"; "edi"; "ebp" |] else [| "%eax"; "%ebx"; "%ecx"; "%edx"; "%esi"; "%edi"; "%ebp" |] let float_reg_name = if masm then [| "tos" |] else [| "%tos" |] let num_register_classes = 2 let register_class r = match r.typ with Int -> 0 | Addr -> 0 | Float -> 1 let num_available_registers = [| 7; 0 |] let first_available_register = [| 0; 100 |] let register_name r = if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) (* There is little scheduling, and some operations are more compact when their argument is %eax. *) let rotate_registers = false (* Representation of hard registers by pseudo-registers *) let hard_int_reg = let v = Array.create 7 Reg.dummy in for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = [| Reg.at_location Float (Reg 100) |] let all_phys_regs = Array.append hard_int_reg hard_float_reg let phys_reg n = if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) let eax = phys_reg 0 let ecx = phys_reg 2 let edx = phys_reg 3 let tos = phys_reg 100 let stack_slot slot ty = Reg.at_location ty (Stack slot) (* Instruction selection *) let word_addressed = false (* Calling conventions *) (* To supplement the processor's meagre supply of registers, we also use some global memory locations to pass arguments beyond the 6th. These globals are denoted by Incoming and Outgoing stack locations with negative offsets, starting at -64. Unlike arguments passed on stack, arguments passed in globals do not prevent tail-call elimination. The caller stores arguments in these globals immediately before the call, and the first thing the callee does is copy them to registers or stack locations. Neither GC nor thread context switches can occur between these two times. *) let calling_conventions first_int last_int first_float last_float make_stack arg = let loc = Array.create (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref (-64) in for i = 0 to Array.length arg - 1 do match arg.(i).typ with Int | Addr as ty -> if !int <= last_int then begin loc.(i) <- phys_reg !int; incr int end else begin loc.(i) <- stack_slot (make_stack !ofs) ty; ofs := !ofs + size_int end | Float -> if !float <= last_float then begin loc.(i) <- phys_reg !float; incr float end else begin loc.(i) <- stack_slot (make_stack !ofs) Float; ofs := !ofs + size_float end done; (loc, Misc.align (max 0 !ofs) stack_alignment) let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs let not_supported ofs = fatal_error "Proc.loc_results: cannot call" let loc_arguments arg = calling_conventions 0 5 100 99 outgoing arg let loc_parameters arg = let (loc, ofs) = calling_conventions 0 5 100 99 incoming arg in loc let loc_results res = let (loc, ofs) = calling_conventions 0 5 100 100 not_supported res in loc let extcall_use_push = true let loc_external_arguments arg = fatal_error "Proc.loc_external_arguments" let loc_external_results res = let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc let loc_exn_bucket = eax (* Registers destroyed by operations *) let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *) [|eax; ecx; edx|] let destroyed_at_oper = function Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs | Iop(Iextcall(_, false)) -> destroyed_at_c_call | Iop(Iintop(Idiv | Imod)) -> [| eax; edx |] | Iop(Iintop_imm(Imod, _)) -> [| eax |] | Iop(Ialloc _) -> [| eax |] | Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |] | Iop(Iintoffloat) -> [| eax |] | Iifthenelse(Ifloattest(_, _), _, _) -> [| eax |] | _ -> [||] let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure op = 4 let max_register_pressure = function Iextcall(_, _) -> [| 4; max_int |] | Iintop(Idiv | Imod) -> [| 5; max_int |] | Ialloc _ | Iintop(Icomp _) | Iintop_imm(Icomp _, _) | Iintoffloat -> [| 6; max_int |] | _ -> [|7; max_int |] (* Layout of the stack frame *) let num_stack_slots = [| 0; 0 |] let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = if masm then Ccomp.command (Config.asm ^ Filename.quote outfile ^ " " ^ Filename.quote infile ^ (if !Clflags.verbose then "" else ">NUL")) else Ccomp.command (Config.asm ^ " -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; mingw-ocaml/ocaml/asmcomp/i386/reload.ml0000644000175000017500000000546712124403240017421 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Cmm open Arch open Reg open Mach (* Reloading for the Intel x86 *) let stackp r = match r.loc with Stack _ -> true | _ -> false class reload = object (self) inherit Reloadgen.reload_generic as super method! makereg r = match r.typ with Float -> r | _ -> super#makereg r (* By overriding makereg, we make sure that pseudoregs of type float will never be reloaded. Hence there is no need to make special cases for floating-point operations. *) method! reload_operation op arg res = match op with Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound) -> (* One of the two arguments can reside in the stack *) if stackp arg.(0) && stackp arg.(1) then ([|arg.(0); self#makereg arg.(1)|], res) else (arg, res) | Iintop(Imul) -> (* First argument (and destination) must be in register, second arg can reside in stack *) if stackp arg.(0) then let r = self#makereg arg.(0) in ([|r; arg.(1)|], [|r|]) else (arg, res) | Iintop_imm(Iadd, _) when arg.(0).loc <> res.(0).loc -> (* This add will be turned into a lea; args and results must be in registers *) super#reload_operation op arg res | Iintop_imm(Imul, _) -> (* First argument and destination must be in register *) if stackp arg.(0) then let r = self#makereg arg.(0) in ([|r|], [|r|]) else (arg, res) | Iintop(Ilsl|Ilsr|Iasr) | Iintop_imm(_, _) | Ifloatofint | Iintoffloat | Ispecific(Ipush) -> (* The argument(s) can be either in register or on stack *) (arg, res) | _ -> (* Other operations: all args and results in registers *) super#reload_operation op arg res method! reload_test tst arg = match tst with Iinttest cmp -> (* One of the two arguments can reside on stack *) if stackp arg.(0) && stackp arg.(1) then [| self#makereg arg.(0); arg.(1) |] else arg | _ -> (* The argument(s) can be either in register or on stack *) arg end let fundecl f = (new reload)#fundecl f mingw-ocaml/ocaml/asmcomp/i386/selection.ml0000644000175000017500000002624112124403240020131 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Instruction selection for the Intel x86 *) open Misc open Arch open Proc open Cmm open Reg open Mach (* Auxiliary for recognizing addressing modes *) type addressing_expr = Asymbol of string | Alinear of expression | Aadd of expression * expression | Ascale of expression * int | Ascaledadd of expression * expression * int let rec select_addr exp = match exp with Cconst_symbol s -> (Asymbol s, 0) | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> let (a, n) = select_addr arg in (a, n + m) | Cop((Csubi | Csuba), [arg; Cconst_int m]) -> let (a, n) = select_addr arg in (a, n - m) | Cop((Caddi | Cadda), [Cconst_int m; arg]) -> let (a, n) = select_addr arg in (a, n + m) | Cop(Clsl, [arg; Cconst_int(1|2|3 as shift)]) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, 1 lsl shift), n lsl shift) | _ -> (Alinear exp, 0) end | Cop(Cmuli, [arg; Cconst_int(2|4|8 as mult)]) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, mult), n * mult) | _ -> (Alinear exp, 0) end | Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg]) -> begin match select_addr arg with (Alinear e, n) -> (Ascale(e, mult), n * mult) | _ -> (Alinear exp, 0) end | Cop((Caddi | Cadda), [arg1; arg2]) -> begin match (select_addr arg1, select_addr arg2) with ((Alinear e1, n1), (Alinear e2, n2)) -> (Aadd(e1, e2), n1 + n2) | ((Alinear e1, n1), (Ascale(e2, scale), n2)) -> (Ascaledadd(e1, e2, scale), n1 + n2) | ((Ascale(e1, scale), n1), (Alinear e2, n2)) -> (Ascaledadd(e2, e1, scale), n1 + n2) | (_, (Ascale(e2, scale), n2)) -> (Ascaledadd(arg1, e2, scale), n2) | ((Ascale(e1, scale), n1), _) -> (Ascaledadd(arg2, e1, scale), n1) | _ -> (Aadd(arg1, arg2), 0) end | arg -> (Alinear arg, 0) (* C functions to be turned into Ifloatspecial instructions if -ffast-math *) let inline_float_ops = ["atan"; "atan2"; "cos"; "log"; "log10"; "sin"; "sqrt"; "tan"] (* Estimate number of float temporaries needed to evaluate expression (Ershov's algorithm) *) let rec float_needs = function Cop((Cnegf | Cabsf), [arg]) -> float_needs arg | Cop((Caddf | Csubf | Cmulf | Cdivf), [arg1; arg2]) -> let n1 = float_needs arg1 in let n2 = float_needs arg2 in if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2 | Cop(Cextcall(fn, ty_res, alloc, dbg), args) when !fast_math && List.mem fn inline_float_ops -> begin match args with [arg] -> float_needs arg | [arg1; arg2] -> max (float_needs arg2 + 1) (float_needs arg1) | _ -> assert false end | _ -> 1 (* Special constraints on operand and result registers *) exception Use_default let eax = phys_reg 0 let ecx = phys_reg 2 let edx = phys_reg 3 let tos = phys_reg 100 let pseudoregs_for_operation op arg res = match op with (* Two-address binary operations *) Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) -> ([|res.(0); arg.(1)|], res, false) (* Two-address unary operations *) | Iintop_imm((Iadd|Isub|Imul|Idiv|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) -> (res, res, false) (* For shifts with variable shift count, second arg must be in ecx *) | Iintop(Ilsl|Ilsr|Iasr) -> ([|res.(0); ecx|], res, false) (* For div and mod, first arg must be in eax, edx is clobbered, and result is in eax or edx respectively. Keep it simple, just force second argument in ecx. *) | Iintop(Idiv) -> ([| eax; ecx |], [| eax |], true) | Iintop(Imod) -> ([| eax; ecx |], [| edx |], true) (* For mod with immediate operand, arg must not be in eax. Keep it simple, force it in edx. *) | Iintop_imm(Imod, _) -> ([| edx |], [| edx |], true) (* For floating-point operations and floating-point loads, the result is always left at the top of the floating-point stack *) | Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf | Ifloatofint | Iload((Single | Double | Double_u), _) | Ispecific(Isubfrev | Idivfrev | Ifloatarithmem(_, _, _) | Ifloatspecial _) -> (arg, [| tos |], false) (* don't move it immediately *) (* For storing a byte, the argument must be in eax...edx. (But for a short, any reg will do!) Keep it simple, just force the argument to be in edx. *) | Istore((Byte_unsigned | Byte_signed), addr) -> let newarg = Array.copy arg in newarg.(0) <- edx; (newarg, res, false) (* Other instructions are regular *) | _ -> raise Use_default let chunk_double = function Single -> false | Double -> true | Double_u -> true | _ -> assert false (* The selector class *) class selector = object (self) inherit Selectgen.selector_generic as super method is_immediate (n : int) = true method! is_simple_expr e = match e with | Cop(Cextcall(fn, _, alloc, _), args) when !fast_math && List.mem fn inline_float_ops -> (* inlined float ops are simple if their arguments are *) List.for_all self#is_simple_expr args | _ -> super#is_simple_expr e method select_addressing chunk exp = match select_addr exp with (Asymbol s, d) -> (Ibased(s, d), Ctuple []) | (Alinear e, d) -> (Iindexed d, e) | (Aadd(e1, e2), d) -> (Iindexed2 d, Ctuple[e1; e2]) | (Ascale(e, scale), d) -> (Iscaled(scale, d), e) | (Ascaledadd(e1, e2, scale), d) -> (Iindexed2scaled(scale, d), Ctuple[e1; e2]) method! select_store addr exp = match exp with Cconst_int n -> (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) | Cconst_natint n -> (Ispecific(Istore_int(n, addr)), Ctuple []) | Cconst_pointer n -> (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) | Cconst_natpointer n -> (Ispecific(Istore_int(n, addr)), Ctuple []) | Cconst_symbol s -> (Ispecific(Istore_symbol(s, addr)), Ctuple []) | _ -> super#select_store addr exp method! select_operation op args = match op with (* Recognize the LEA instruction *) Caddi | Cadda | Csubi | Csuba -> begin match self#select_addressing Word (Cop(op, args)) with (Iindexed d, _) -> super#select_operation op args | (Iindexed2 0, _) -> super#select_operation op args | (addr, arg) -> (Ispecific(Ilea addr), [arg]) end (* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *) | Cdivi -> begin match args with [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> (Iintop_imm(Idiv, n), [arg1]) | _ -> (Iintop Idiv, args) end | Cmodi -> begin match args with [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> (Iintop_imm(Imod, n), [arg1]) | _ -> (Iintop Imod, args) end (* Recognize float arithmetic with memory. In passing, apply Ershov's algorithm to reduce stack usage *) | Caddf -> self#select_floatarith Iaddf Iaddf Ifloatadd Ifloatadd args | Csubf -> self#select_floatarith Isubf (Ispecific Isubfrev) Ifloatsub Ifloatsubrev args | Cmulf -> self#select_floatarith Imulf Imulf Ifloatmul Ifloatmul args | Cdivf -> self#select_floatarith Idivf (Ispecific Idivfrev) Ifloatdiv Ifloatdivrev args (* Recognize store instructions *) | Cstore Word -> begin match args with [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])] when loc = loc' -> let (addr, arg) = self#select_addressing Word loc in (Ispecific(Ioffset_loc(n, addr)), [arg]) | _ -> super#select_operation op args end (* Recognize inlined floating point operations *) | Cextcall(fn, ty_res, false, dbg) when !fast_math && List.mem fn inline_float_ops -> (Ispecific(Ifloatspecial fn), args) (* Default *) | _ -> super#select_operation op args (* Recognize float arithmetic with mem *) method select_floatarith regular_op reversed_op mem_op mem_rev_op args = match args with [arg1; Cop(Cload chunk, [loc2])] -> let (addr, arg2) = self#select_addressing chunk loc2 in (Ispecific(Ifloatarithmem(chunk_double chunk, mem_op, addr)), [arg1; arg2]) | [Cop(Cload chunk, [loc1]); arg2] -> let (addr, arg1) = self#select_addressing chunk loc1 in (Ispecific(Ifloatarithmem(chunk_double chunk, mem_rev_op, addr)), [arg2; arg1]) | [arg1; arg2] -> (* Evaluate bigger subexpression first to minimize stack usage. Because of right-to-left evaluation, rightmost arg is evaluated first *) if float_needs arg1 <= float_needs arg2 then (regular_op, [arg1; arg2]) else (reversed_op, [arg2; arg1]) | _ -> fatal_error "Proc_i386: select_floatarith" (* Deal with register constraints *) method! insert_op_debug op dbg rs rd = try let (rsrc, rdst, move_res) = pseudoregs_for_operation op rs rd in self#insert_moves rs rsrc; self#insert_debug (Iop op) dbg rsrc rdst; if move_res then begin self#insert_moves rdst rd; rd end else rdst with Use_default -> super#insert_op_debug op dbg rs rd (* Selection of push instructions for external calls *) method select_push exp = match exp with Cconst_int n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple []) | Cconst_natint n -> (Ispecific(Ipush_int n), Ctuple []) | Cconst_pointer n -> (Ispecific(Ipush_int(Nativeint.of_int n)), Ctuple []) | Cconst_natpointer n -> (Ispecific(Ipush_int n), Ctuple []) | Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple []) | Cop(Cload Word, [loc]) -> let (addr, arg) = self#select_addressing Word loc in (Ispecific(Ipush_load addr), arg) | Cop(Cload Double_u, [loc]) -> let (addr, arg) = self#select_addressing Double_u loc in (Ispecific(Ipush_load_float addr), arg) | _ -> (Ispecific(Ipush), exp) method! emit_extcall_args env args = let rec size_pushes = function | [] -> 0 | e :: el -> Selectgen.size_expr env e + size_pushes el in let sz1 = size_pushes args in let sz2 = Misc.align sz1 stack_alignment in let rec emit_pushes = function | [] -> if sz2 > sz1 then self#insert (Iop (Istackoffset (sz2 - sz1))) [||] [||] | e :: el -> emit_pushes el; let (op, arg) = self#select_push e in match self#emit_expr env arg with | None -> () | Some r -> self#insert (Iop op) r [||] in emit_pushes args; ([||], sz2) end let fundecl f = (new selector)#emit_fundecl f mingw-ocaml/ocaml/asmcomp/i386/emit.mlp0000644000175000017500000010263212124403240017261 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Emission of Intel 386 assembly code *) module StringSet = Set.Make(struct type t = string let compare = compare end) open Location open Misc open Cmm open Arch open Proc open Reg open Mach open Linearize open Emitaux (* Tradeoff between code size and code speed *) let fastcode_flag = ref true let stack_offset = ref 0 (* Layout of the stack frame *) let frame_size () = (* includes return address *) let sz = !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4 in Misc.align sz stack_alignment let slot_offset loc cl = match loc with Incoming n -> assert (n >= 0); frame_size() + n | Local n -> if cl = 0 then !stack_offset + n * 4 else !stack_offset + num_stack_slots.(0) * 4 + n * 8 | Outgoing n -> assert (n >= 0); n let trap_frame_size = Misc.align 8 stack_alignment (* Prefixing of symbols with "_" *) let symbol_prefix = match Config.system with "linux_elf" -> "" | "bsd_elf" -> "" | "solaris" -> "" | "beos" -> "" | "gnu" -> "" | _ -> "_" let emit_symbol s = emit_string symbol_prefix; Emitaux.emit_symbol '$' s (* Output a label *) let label_prefix = match Config.system with "linux_elf" -> ".L" | "bsd_elf" -> ".L" | "solaris" -> ".L" | "beos" -> ".L" | "gnu" -> ".L" | _ -> "L" let emit_label lbl = emit_string label_prefix; emit_int lbl let emit_data_label lbl = emit_string label_prefix; emit_string "d"; emit_int lbl (* Some data directives have different names under Solaris *) let word_dir = match Config.system with "solaris" -> ".value" | _ -> ".word" let skip_dir = match Config.system with "solaris" -> ".zero" | _ -> ".space" let use_ascii_dir = match Config.system with "solaris" -> false | _ -> true (* MacOSX has its own way to reference symbols potentially defined in shared objects *) let macosx = match Config.system with | "macosx" -> true | _ -> false (* Output a .align directive. The numerical argument to .align is log2 of alignment size, except under ELF, where it is the alignment size... *) let emit_align = match Config.system with "linux_elf" | "bsd_elf" | "solaris" | "beos" | "cygwin" | "mingw" | "gnu" -> (fun n -> ` .align {emit_int n}\n`) | _ -> (fun n -> ` .align {emit_int(Misc.log2 n)}\n`) let emit_Llabel fallthrough lbl = if not fallthrough && !fastcode_flag then emit_align 16 ; emit_label lbl (* Output a pseudo-register *) let emit_reg = function { loc = Reg r } -> emit_string (register_name r) | { loc = Stack(Incoming n | Outgoing n) } when n < 0 -> `{emit_symbol "caml_extra_params"} + {emit_int (n + 64)}` | { loc = Stack s } as r -> let ofs = slot_offset s (register_class r) in `{emit_int ofs}(%esp)` | { loc = Unknown } -> fatal_error "Emit_i386.emit_reg" (* Output a reference to the lower 8 bits or lower 16 bits of a register *) let reg_low_byte_name = [| "%al"; "%bl"; "%cl"; "%dl" |] let reg_low_half_name = [| "%ax"; "%bx"; "%cx"; "%dx"; "%si"; "%di"; "%bp" |] let emit_reg8 r = match r.loc with Reg r when r < 4 -> emit_string (reg_low_byte_name.(r)) | _ -> fatal_error "Emit_i386.emit_reg8" let emit_reg16 r = match r.loc with Reg r when r < 7 -> emit_string (reg_low_half_name.(r)) | _ -> fatal_error "Emit_i386.emit_reg16" (* Output an addressing mode *) let emit_addressing addr r n = match addr with Ibased(s, d) -> `{emit_symbol s}`; if d <> 0 then ` + {emit_int d}` | Iindexed d -> if d <> 0 then emit_int d; `({emit_reg r.(n)})` | Iindexed2 d -> if d <> 0 then emit_int d; `({emit_reg r.(n)}, {emit_reg r.(n+1)})` | Iscaled(2, d) -> if d <> 0 then emit_int d; `({emit_reg r.(n)}, {emit_reg r.(n)})` | Iscaled(scale, d) -> if d <> 0 then emit_int d; `(, {emit_reg r.(n)}, {emit_int scale})` | Iindexed2scaled(scale, d) -> if d <> 0 then emit_int d; `({emit_reg r.(n)}, {emit_reg r.(n+1)}, {emit_int scale})` (* Record live pointers at call points *) let record_frame_label live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter (function {typ = Addr; loc = Reg r} -> live_offset := ((r lsl 1) + 1) :: !live_offset | {typ = Addr; loc = Stack s} as reg -> live_offset := slot_offset s (register_class reg) :: !live_offset | _ -> ()) live; frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); fd_live_offset = !live_offset; fd_debuginfo = dbg } :: !frame_descriptors; lbl let record_frame live dbg = let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` (* Record calls to the GC -- we've moved them out of the way *) type gc_call = { gc_lbl: label; (* Entry label *) gc_return_lbl: label; (* Where to branch after GC *) gc_frame: label } (* Label of frame descriptor *) let call_gc_sites = ref ([] : gc_call list) let emit_call_gc gc = `{emit_label gc.gc_lbl}: call {emit_symbol "caml_call_gc"}\n`; `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` (* Record calls to caml_ml_array_bound_error. In -g mode, we maintain one call to caml_ml_array_bound_error per bound check site. Without -g, we can share a single call. *) type bound_error_call = { bd_lbl: label; (* Entry label *) bd_frame: label } (* Label of frame descriptor *) let bound_error_sites = ref ([] : bound_error_call list) let bound_error_call = ref 0 let bound_error_label dbg = if !Clflags.debug then begin let lbl_bound_error = new_label() in let lbl_frame = record_frame_label Reg.Set.empty dbg in bound_error_sites := { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; lbl_bound_error end else begin if !bound_error_call = 0 then bound_error_call := new_label(); !bound_error_call end let emit_call_bound_error bd = `{emit_label bd.bd_lbl}: call {emit_symbol "caml_ml_array_bound_error"}\n`; `{emit_label bd.bd_frame}:\n` let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then `{emit_label !bound_error_call}: call {emit_symbol "caml_ml_array_bound_error"}\n` (* Names for instructions *) let instr_for_intop = function Iadd -> "addl" | Isub -> "subl" | Imul -> "imull" | Iand -> "andl" | Ior -> "orl" | Ixor -> "xorl" | Ilsl -> "sall" | Ilsr -> "shrl" | Iasr -> "sarl" | _ -> fatal_error "Emit_i386: instr_for_intop" let instr_for_floatop = function Inegf -> "fchs" | Iabsf -> "fabs" | Iaddf -> "faddl" | Isubf -> "fsubl" | Imulf -> "fmull" | Idivf -> "fdivl" | Ispecific Isubfrev -> "fsubrl" | Ispecific Idivfrev -> "fdivrl" | _ -> fatal_error "Emit_i386: instr_for_floatop" let instr_for_floatop_reversed = function Iaddf -> "faddl" | Isubf -> "fsubrl" | Imulf -> "fmull" | Idivf -> "fdivrl" | Ispecific Isubfrev -> "fsubl" | Ispecific Idivfrev -> "fdivl" | _ -> fatal_error "Emit_i386: instr_for_floatop_reversed" let instr_for_floatop_pop = function Iaddf -> "faddp" | Isubf -> "fsubp" | Imulf -> "fmulp" | Idivf -> "fdivp" | Ispecific Isubfrev -> "fsubrp" | Ispecific Idivfrev -> "fdivrp" | _ -> fatal_error "Emit_i386: instr_for_floatop_pop" let instr_for_floatarithmem double = function Ifloatadd -> if double then "faddl" else "fadds" | Ifloatsub -> if double then "fsubl" else "fsubs" | Ifloatsubrev -> if double then "fsubrl" else "fsubrs" | Ifloatmul -> if double then "fmull" else "fmuls" | Ifloatdiv -> if double then "fdivl" else "fdivs" | Ifloatdivrev -> if double then "fdivrl" else "fdivrs" let name_for_cond_branch = function Isigned Ceq -> "e" | Isigned Cne -> "ne" | Isigned Cle -> "le" | Isigned Cgt -> "g" | Isigned Clt -> "l" | Isigned Cge -> "ge" | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" (* Output an = 0 or <> 0 test. *) let output_test_zero arg = match arg.loc with Reg r -> ` testl {emit_reg arg}, {emit_reg arg}\n` | _ -> ` cmpl $0, {emit_reg arg}\n` (* Deallocate the stack frame before a return or tail call *) let output_epilogue f = let n = frame_size() - 4 in if n > 0 then begin ` addl ${emit_int n}, %esp\n`; cfi_adjust_cfa_offset (-n); f (); (* reset CFA back cause function body may continue *) cfi_adjust_cfa_offset n end else f () (* Determine if the given register is the top of the floating-point stack *) let is_tos = function { loc = Reg _; typ = Float } -> true | _ -> false (* Emit the code for a floating-point comparison *) let emit_float_test cmp neg arg lbl = let actual_cmp = match (is_tos arg.(0), is_tos arg.(1)) with (true, true) -> (* both args on top of FP stack *) ` fcompp\n`; cmp | (true, false) -> (* first arg on top of FP stack *) ` fcompl {emit_reg arg.(1)}\n`; cmp | (false, true) -> (* second arg on top of FP stack *) ` fcompl {emit_reg arg.(0)}\n`; Cmm.swap_comparison cmp | (false, false) -> ` fldl {emit_reg arg.(0)}\n`; ` fcompl {emit_reg arg.(1)}\n`; cmp in ` fnstsw %ax\n`; begin match actual_cmp with Ceq -> if neg then begin ` andb $68, %ah\n`; ` xorb $64, %ah\n`; ` jne ` end else begin ` andb $69, %ah\n`; ` cmpb $64, %ah\n`; ` je ` end | Cne -> if neg then begin ` andb $69, %ah\n`; ` cmpb $64, %ah\n`; ` je ` end else begin ` andb $68, %ah\n`; ` xorb $64, %ah\n`; ` jne ` end | Cle -> ` andb $69, %ah\n`; ` decb %ah\n`; ` cmpb $64, %ah\n`; if neg then ` jae ` else ` jb ` | Cge -> ` andb $5, %ah\n`; if neg then ` jne ` else ` je ` | Clt -> ` andb $69, %ah\n`; ` cmpb $1, %ah\n`; if neg then ` jne ` else ` je ` | Cgt -> ` andb $69, %ah\n`; if neg then ` jne ` else ` je ` end; `{emit_label lbl}\n` (* Emit a Ifloatspecial instruction *) let emit_floatspecial = function "atan" -> ` fld1; fpatan\n` | "atan2" -> ` fpatan\n` | "cos" -> ` fcos\n` | "log" -> ` fldln2; fxch; fyl2x\n` | "log10" -> ` fldlg2; fxch; fyl2x\n` | "sin" -> ` fsin\n` | "sqrt" -> ` fsqrt\n` | "tan" -> ` fptan; fstp %st(0)\n` | _ -> assert false (* Output the assembly code for an instruction *) (* Name of current function *) let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 (* Label of trap for out-of-range accesses *) let range_check_trap = ref 0 (* Record float literals to be emitted later *) let float_constants = ref ([] : (int * string) list) (* Record references to external C functions (for MacOSX) *) let external_symbols_direct = ref StringSet.empty let external_symbols_indirect = ref StringSet.empty let emit_instr fallthrough i = emit_debug_info i.dbg; match i.desc with Lend -> () | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin if src.typ = Float then if is_tos src then ` fstpl {emit_reg dst}\n` else if is_tos dst then ` fldl {emit_reg src}\n` else begin ` fldl {emit_reg src}\n`; ` fstpl {emit_reg dst}\n` end else ` movl {emit_reg src}, {emit_reg dst}\n` end | Lop(Iconst_int n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xorl {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> ` movl $0, {emit_reg i.res.(0)}\n` end else ` movl ${emit_nativeint n}, {emit_reg i.res.(0)}\n` | Lop(Iconst_float s) -> begin match Int64.bits_of_float (float_of_string s) with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` fldz\n` | 0x8000_0000_0000_0000L -> (* -0.0 *) ` fldz\n fchs\n` | 0x3FF0_0000_0000_0000L -> (* 1.0 *) ` fld1\n` | 0xBFF0_0000_0000_0000L -> (* -1.0 *) ` fld1\n fchs\n` | _ -> let lbl = new_label() in float_constants := (lbl, s) :: !float_constants; ` fldl {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> ` movl ${emit_symbol s}, {emit_reg i.res.(0)}\n` | Lop(Icall_ind) -> ` call *{emit_reg i.arg.(0)}\n`; record_frame i.live i.dbg | Lop(Icall_imm s) -> ` call {emit_symbol s}\n`; record_frame i.live i.dbg | Lop(Itailcall_ind) -> output_epilogue begin fun () -> ` jmp *{emit_reg i.arg.(0)}\n` end | Lop(Itailcall_imm s) -> if s = !function_name then ` jmp {emit_label !tailrec_entry_point}\n` else begin output_epilogue begin fun () -> ` jmp {emit_symbol s}\n` end end | Lop(Iextcall(s, alloc)) -> if alloc then begin if not macosx then ` movl ${emit_symbol s}, %eax\n` else begin external_symbols_indirect := StringSet.add s !external_symbols_indirect; ` movl L{emit_symbol s}$non_lazy_ptr, %eax\n` end; ` call {emit_symbol "caml_c_call"}\n`; record_frame i.live i.dbg end else begin if not macosx then ` call {emit_symbol s}\n` else begin external_symbols_direct := StringSet.add s !external_symbols_direct; ` call L{emit_symbol s}$stub\n` end end | Lop(Istackoffset n) -> if n < 0 then ` addl ${emit_int(-n)}, %esp\n` else ` subl ${emit_int(n)}, %esp\n`; cfi_adjust_cfa_offset n; stack_offset := !stack_offset + n | Lop(Iload(chunk, addr)) -> let dest = i.res.(0) in begin match chunk with | Word | Thirtytwo_signed | Thirtytwo_unsigned -> ` movl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` | Byte_unsigned -> ` movzbl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` | Byte_signed -> ` movsbl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` | Sixteen_unsigned -> ` movzwl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` | Sixteen_signed -> ` movswl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` | Single -> ` flds {emit_addressing addr i.arg 0}\n` | Double | Double_u -> ` fldl {emit_addressing addr i.arg 0}\n` end | Lop(Istore(chunk, addr)) -> begin match chunk with | Word | Thirtytwo_signed | Thirtytwo_unsigned -> ` movl {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` | Byte_unsigned | Byte_signed -> ` movb {emit_reg8 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` | Sixteen_unsigned | Sixteen_signed -> ` movw {emit_reg16 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` | Single -> if is_tos i.arg.(0) then ` fstps {emit_addressing addr i.arg 1}\n` else begin ` fldl {emit_reg i.arg.(0)}\n`; ` fstps {emit_addressing addr i.arg 1}\n` end | Double | Double_u -> if is_tos i.arg.(0) then ` fstpl {emit_addressing addr i.arg 1}\n` else begin ` fldl {emit_reg i.arg.(0)}\n`; ` fstpl {emit_addressing addr i.arg 1}\n` end end | Lop(Ialloc n) -> if !fastcode_flag then begin let lbl_redo = new_label() in `{emit_label lbl_redo}: movl {emit_symbol "caml_young_ptr"}, %eax\n`; ` subl ${emit_int n}, %eax\n`; ` movl %eax, {emit_symbol "caml_young_ptr"}\n`; ` cmpl {emit_symbol "caml_young_limit"}, %eax\n`; let lbl_call_gc = new_label() in let lbl_frame = record_frame_label i.live Debuginfo.none in ` jb {emit_label lbl_call_gc}\n`; ` leal 4(%eax), {emit_reg i.res.(0)}\n`; call_gc_sites := { gc_lbl = lbl_call_gc; gc_return_lbl = lbl_redo; gc_frame = lbl_frame } :: !call_gc_sites end else begin begin match n with 8 -> ` call {emit_symbol "caml_alloc1"}\n` | 12 -> ` call {emit_symbol "caml_alloc2"}\n` | 16 -> ` call {emit_symbol "caml_alloc3"}\n` | _ -> ` movl ${emit_int n}, %eax\n`; ` call {emit_symbol "caml_allocN"}\n` end; `{record_frame i.live Debuginfo.none} leal 4(%eax), {emit_reg i.res.(0)}\n` end | Lop(Iintop(Icomp cmp)) -> ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; let b = name_for_cond_branch cmp in ` set{emit_string b} %al\n`; ` movzbl %al, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Icomp cmp, n)) -> ` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`; let b = name_for_cond_branch cmp in ` set{emit_string b} %al\n`; ` movzbl %al, {emit_reg i.res.(0)}\n` | Lop(Iintop Icheckbound) -> let lbl = bound_error_label i.dbg in ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; ` jbe {emit_label lbl}\n` | Lop(Iintop_imm(Icheckbound, n)) -> let lbl = bound_error_label i.dbg in ` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`; ` jbe {emit_label lbl}\n` | Lop(Iintop(Idiv | Imod)) -> ` cltd\n`; ` idivl {emit_reg i.arg.(1)}\n` | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *) ` {emit_string(instr_for_intop op)} %cl, {emit_reg i.res.(0)}\n` | Lop(Iintop op) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> ` leal {emit_int n}({emit_reg i.arg.(0)}), {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> ` incl {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> ` decl {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Idiv, n)) -> let l = Misc.log2 n in let lbl = new_label() in output_test_zero i.arg.(0); ` jge {emit_label lbl}\n`; ` addl ${emit_int(n-1)}, {emit_reg i.arg.(0)}\n`; `{emit_label lbl}: sarl ${emit_int l}, {emit_reg i.arg.(0)}\n` | Lop(Iintop_imm(Imod, n)) -> let lbl = new_label() in ` movl {emit_reg i.arg.(0)}, %eax\n`; ` testl %eax, %eax\n`; ` jge {emit_label lbl}\n`; ` addl ${emit_int(n-1)}, %eax\n`; `{emit_label lbl}: andl ${emit_int(-n)}, %eax\n`; ` subl %eax, {emit_reg i.arg.(0)}\n` | Lop(Iintop_imm(op, n)) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} ${emit_int n}, {emit_reg i.res.(0)}\n` | Lop(Inegf | Iabsf as floatop) -> if not (is_tos i.arg.(0)) then ` fldl {emit_reg i.arg.(0)}\n`; ` {emit_string(instr_for_floatop floatop)}\n` | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific(Isubfrev | Idivfrev) as floatop) -> begin match (is_tos i.arg.(0), is_tos i.arg.(1)) with (true, true) -> (* both operands on top of FP stack *) ` {emit_string(instr_for_floatop_pop floatop)} %st, %st(1)\n` | (true, false) -> (* first operand on stack *) ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` | (false, true) -> (* second operand on stack *) ` {emit_string(instr_for_floatop_reversed floatop)} {emit_reg i.arg.(0)}\n` | (false, false) -> (* both operands in memory *) ` fldl {emit_reg i.arg.(0)}\n`; ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` end | Lop(Ifloatofint) -> begin match i.arg.(0).loc with Stack s -> ` fildl {emit_reg i.arg.(0)}\n` | _ -> ` pushl {emit_reg i.arg.(0)}\n`; ` fildl (%esp)\n`; ` addl $4, %esp\n` end | Lop(Iintoffloat) -> if not (is_tos i.arg.(0)) then ` fldl {emit_reg i.arg.(0)}\n`; stack_offset := !stack_offset - 8; ` subl $8, %esp\n`; cfi_adjust_cfa_offset 8; ` fnstcw 4(%esp)\n`; ` movw 4(%esp), %ax\n`; ` movb $12, %ah\n`; ` movw %ax, 0(%esp)\n`; ` fldcw 0(%esp)\n`; begin match i.res.(0).loc with Stack s -> ` fistpl {emit_reg i.res.(0)}\n` | _ -> ` fistpl (%esp)\n`; ` movl (%esp), {emit_reg i.res.(0)}\n` end; ` fldcw 4(%esp)\n`; ` addl $8, %esp\n`; cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset + 8 | Lop(Ispecific(Ilea addr)) -> ` lea {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` | Lop(Ispecific(Istore_int(n, addr))) -> ` movl ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Istore_symbol(s, addr))) -> ` movl ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> ` addl ${emit_int n}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Ipush)) -> (* Push arguments in reverse order *) for n = Array.length i.arg - 1 downto 0 do let r = i.arg.(n) in match r with {loc = Reg _; typ = Float} -> ` subl $8, %esp\n`; cfi_adjust_cfa_offset 8; ` fstpl 0(%esp)\n`; stack_offset := !stack_offset + 8 | {loc = Stack sl; typ = Float} -> let ofs = slot_offset sl 1 in ` pushl {emit_int(ofs + 4)}(%esp)\n`; ` pushl {emit_int(ofs + 4)}(%esp)\n`; cfi_adjust_cfa_offset 8; stack_offset := !stack_offset + 8 | _ -> ` pushl {emit_reg r}\n`; cfi_adjust_cfa_offset 4; stack_offset := !stack_offset + 4 done | Lop(Ispecific(Ipush_int n)) -> ` pushl ${emit_nativeint n}\n`; cfi_adjust_cfa_offset 4; stack_offset := !stack_offset + 4 | Lop(Ispecific(Ipush_symbol s)) -> ` pushl ${emit_symbol s}\n`; cfi_adjust_cfa_offset 4; stack_offset := !stack_offset + 4 | Lop(Ispecific(Ipush_load addr)) -> ` pushl {emit_addressing addr i.arg 0}\n`; cfi_adjust_cfa_offset 4; stack_offset := !stack_offset + 4 | Lop(Ispecific(Ipush_load_float addr)) -> ` pushl {emit_addressing (offset_addressing addr 4) i.arg 0}\n`; ` pushl {emit_addressing addr i.arg 0}\n`; cfi_adjust_cfa_offset 8; stack_offset := !stack_offset + 8 | Lop(Ispecific(Ifloatarithmem(double, op, addr))) -> if not (is_tos i.arg.(0)) then ` fldl {emit_reg i.arg.(0)}\n`; ` {emit_string(instr_for_floatarithmem double op)} {emit_addressing addr i.arg 1}\n` | Lop(Ispecific(Ifloatspecial s)) -> (* Push args on float stack if necessary *) for k = 0 to Array.length i.arg - 1 do if not (is_tos i.arg.(k)) then ` fldl {emit_reg i.arg.(k)}\n` done; (* Fix-up for binary instrs whose args were swapped *) if Array.length i.arg = 2 && is_tos i.arg.(1) then ` fxch %st(1)\n`; emit_floatspecial s | Lreloadretaddr -> () | Lreturn -> output_epilogue begin fun () -> ` ret\n` end | Llabel lbl -> `{emit_Llabel fallthrough lbl}:\n` | Lbranch lbl -> ` jmp {emit_label lbl}\n` | Lcondbranch(tst, lbl) -> begin match tst with Itruetest -> output_test_zero i.arg.(0); ` jne {emit_label lbl}\n` | Ifalsetest -> output_test_zero i.arg.(0); ` je {emit_label lbl}\n` | Iinttest cmp -> ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` | Iinttest_imm((Isigned Ceq | Isigned Cne | Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> output_test_zero i.arg.(0); let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` | Iinttest_imm(cmp, n) -> ` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` | Ifloattest(cmp, neg) -> emit_float_test cmp neg i.arg lbl | Ioddtest -> ` testl $1, {emit_reg i.arg.(0)}\n`; ` jne {emit_label lbl}\n` | Ieventest -> ` testl $1, {emit_reg i.arg.(0)}\n`; ` je {emit_label lbl}\n` end | Lcondbranch3(lbl0, lbl1, lbl2) -> ` cmpl $1, {emit_reg i.arg.(0)}\n`; begin match lbl0 with None -> () | Some lbl -> ` jb {emit_label lbl}\n` end; begin match lbl1 with None -> () | Some lbl -> ` je {emit_label lbl}\n` end; begin match lbl2 with None -> () | Some lbl -> ` jg {emit_label lbl}\n` end | Lswitch jumptbl -> let lbl = new_label() in ` jmp *{emit_label lbl}(, {emit_reg i.arg.(0)}, 4)\n`; ` .data\n`; `{emit_label lbl}:`; for i = 0 to Array.length jumptbl - 1 do ` .long {emit_label jumptbl.(i)}\n` done; ` .text\n` | Lsetuptrap lbl -> ` call {emit_label lbl}\n` | Lpushtrap -> if trap_frame_size > 8 then ` subl ${emit_int (trap_frame_size - 8)}, %esp\n`; ` pushl {emit_symbol "caml_exception_pointer"}\n`; cfi_adjust_cfa_offset trap_frame_size; ` movl %esp, {emit_symbol "caml_exception_pointer"}\n`; stack_offset := !stack_offset + trap_frame_size | Lpoptrap -> ` popl {emit_symbol "caml_exception_pointer"}\n`; ` addl ${emit_int (trap_frame_size - 4)}, %esp\n`; cfi_adjust_cfa_offset (-trap_frame_size); stack_offset := !stack_offset - trap_frame_size | Lraise -> if !Clflags.debug then begin ` call {emit_symbol "caml_raise_exn"}\n`; record_frame Reg.Set.empty i.dbg end else begin ` movl {emit_symbol "caml_exception_pointer"}, %esp\n`; ` popl {emit_symbol "caml_exception_pointer"}\n`; if trap_frame_size > 8 then ` addl ${emit_int (trap_frame_size - 8)}, %esp\n`; ` ret\n` end let rec emit_all fallthrough i = match i.desc with | Lend -> () | _ -> emit_instr fallthrough i; emit_all (Linearize.has_fallthrough i.desc) i.next (* Emission of the floating-point constants *) let emit_float_constant (lbl, cst) = ` .data\n`; `{emit_label lbl}:`; emit_float64_split_directive ".long" cst (* Emission of external symbol references (for MacOSX) *) let emit_external_symbol_direct s = `L{emit_symbol s}$stub:\n`; ` .indirect_symbol {emit_symbol s}\n`; ` hlt ; hlt ; hlt ; hlt ; hlt\n` let emit_external_symbol_indirect s = `L{emit_symbol s}$non_lazy_ptr:\n`; ` .indirect_symbol {emit_symbol s}\n`; ` .long 0\n` let emit_external_symbols () = ` .section __IMPORT,__pointers,non_lazy_symbol_pointers\n`; StringSet.iter emit_external_symbol_indirect !external_symbols_indirect; external_symbols_indirect := StringSet.empty; ` .section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5\n`; StringSet.iter emit_external_symbol_direct !external_symbols_direct; external_symbols_direct := StringSet.empty; if !Clflags.gprofile then begin `Lmcount$stub:\n`; ` .indirect_symbol mcount\n`; ` hlt ; hlt ; hlt ; hlt ; hlt\n` end (* Emission of the profiling prelude *) let emit_profile () = match Config.system with "linux_elf" | "gnu" -> ` pushl %eax\n`; ` movl %esp, %ebp\n`; ` pushl %ecx\n`; ` pushl %edx\n`; ` call {emit_symbol "mcount"}\n`; ` popl %edx\n`; ` popl %ecx\n`; ` popl %eax\n` | "bsd_elf" -> ` pushl %eax\n`; ` movl %esp, %ebp\n`; ` pushl %ecx\n`; ` pushl %edx\n`; ` call .mcount\n`; ` popl %edx\n`; ` popl %ecx\n`; ` popl %eax\n` | "macosx" -> ` pushl %eax\n`; ` movl %esp, %ebp\n`; ` pushl %ecx\n`; ` pushl %edx\n`; ` call Lmcount$stub\n`; ` popl %edx\n`; ` popl %ecx\n`; ` popl %eax\n` | _ -> () (*unsupported yet*) (* Emission of a function declaration *) let fundecl fundecl = function_name := fundecl.fun_name; fastcode_flag := fundecl.fun_fast; tailrec_entry_point := new_label(); stack_offset := 0; float_constants := []; call_gc_sites := []; bound_error_sites := []; bound_error_call := 0; ` .text\n`; emit_align 16; if macosx && not !Clflags.output_c_object && is_generic_function fundecl.fun_name then (* PR#4690 *) ` .private_extern {emit_symbol fundecl.fun_name}\n` else ` .globl {emit_symbol fundecl.fun_name}\n`; `{emit_symbol fundecl.fun_name}:\n`; emit_debug_info fundecl.fun_dbg; cfi_startproc (); if !Clflags.gprofile then emit_profile(); let n = frame_size() - 4 in if n > 0 then begin ` subl ${emit_int n}, %esp\n`; cfi_adjust_cfa_offset n; end; `{emit_label !tailrec_entry_point}:\n`; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors (); cfi_endproc (); begin match Config.system with "linux_elf" | "bsd_elf" | "gnu" -> ` .type {emit_symbol fundecl.fun_name},@function\n`; ` .size {emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n` | _ -> () end; List.iter emit_float_constant !float_constants (* Emission of data *) let emit_item = function Cglobal_symbol s -> ` .globl {emit_symbol s}\n`; | Cdefine_symbol s -> `{emit_symbol s}:\n` | Cdefine_label lbl -> `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> ` {emit_string word_dir} {emit_int n}\n` | Cint32 n -> ` .long {emit_nativeint n}\n` | Cint n -> ` .long {emit_nativeint n}\n` | Csingle f -> emit_float32_directive ".long" f | Cdouble f -> emit_float64_split_directive ".long" f | Csymbol_address s -> ` .long {emit_symbol s}\n` | Clabel_address lbl -> ` .long {emit_data_label lbl}\n` | Cstring s -> if use_ascii_dir then emit_string_directive " .ascii " s else emit_bytes_directive " .byte " s | Cskip n -> if n > 0 then ` {emit_string skip_dir} {emit_int n}\n` | Calign n -> emit_align n let data l = ` .data\n`; List.iter emit_item l (* Beginning / end of an assembly file *) let begin_assembly() = reset_debug_info(); (* PR#5603 *) let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ` .data\n`; ` .globl {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin}:\n`; let lbl_begin = Compilenv.make_symbol (Some "code_begin") in ` .text\n`; ` .globl {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin}:\n`; if macosx then ` nop\n` (* PR#4690 *) let end_assembly() = let lbl_end = Compilenv.make_symbol (Some "code_end") in ` .text\n`; if macosx then ` nop\n`; (* suppress "ld warning: atom sorting error" *) ` .globl {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end}:\n`; ` .data\n`; let lbl_end = Compilenv.make_symbol (Some "data_end") in ` .globl {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end}:\n`; ` .long 0\n`; let lbl = Compilenv.make_symbol (Some "frametable") in ` .globl {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; emit_frames { efa_label = (fun l -> ` .long {emit_label l}\n`); efa_16 = (fun n -> ` {emit_string word_dir} {emit_int n}\n`); efa_32 = (fun n -> ` .long {emit_int32 n}\n`); efa_word = (fun n -> ` .long {emit_int n}\n`); efa_align = emit_align; efa_label_rel = (fun lbl ofs -> ` .long {emit_label lbl} - . + {emit_int32 ofs}\n`); efa_def_label = (fun l -> `{emit_label l}:\n`); efa_string = (fun s -> let s = s ^ "\000" in if use_ascii_dir then emit_string_directive " .ascii " s else emit_bytes_directive " .byte " s) }; if macosx then emit_external_symbols (); if Config.system = "linux_elf" then (* Mark stack as non-executable, PR#4564 *) `\n .section .note.GNU-stack,\"\",%progbits\n` mingw-ocaml/ocaml/asmcomp/selection.mli0000644000175000017500000000170312124403240017605 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) val fundecl: Cmm.fundecl -> Mach.fundecl mingw-ocaml/ocaml/asmcomp/mach.ml0000644000175000017500000000746412124403240016371 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Representation of machine code by sequences of pseudoinstructions *) type integer_comparison = Isigned of Cmm.comparison | Iunsigned of Cmm.comparison type integer_operation = Iadd | Isub | Imul | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Icomp of integer_comparison | Icheckbound type test = Itruetest | Ifalsetest | Iinttest of integer_comparison | Iinttest_imm of integer_comparison * int | Ifloattest of Cmm.comparison * bool | Ioddtest | Ieventest type operation = Imove | Ispill | Ireload | Iconst_int of nativeint | Iconst_float of string | Iconst_symbol of string | Icall_ind | Icall_imm of string | Itailcall_ind | Itailcall_imm of string | Iextcall of string * bool | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode | Istore of Cmm.memory_chunk * Arch.addressing_mode | Ialloc of int | Iintop of integer_operation | Iintop_imm of integer_operation * int | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf | Ifloatofint | Iintoffloat | Ispecific of Arch.specific_operation type instruction = { desc: instruction_desc; next: instruction; arg: Reg.t array; res: Reg.t array; dbg: Debuginfo.t; mutable live: Reg.Set.t } and instruction_desc = Iend | Iop of operation | Ireturn | Iifthenelse of test * instruction * instruction | Iswitch of int array * instruction array | Iloop of instruction | Icatch of int * instruction * instruction | Iexit of int | Itrywith of instruction * instruction | Iraise type fundecl = { fun_name: string; fun_args: Reg.t array; fun_body: instruction; fun_fast: bool; fun_dbg : Debuginfo.t } let rec dummy_instr = { desc = Iend; next = dummy_instr; arg = [||]; res = [||]; dbg = Debuginfo.none; live = Reg.Set.empty } let end_instr () = { desc = Iend; next = dummy_instr; arg = [||]; res = [||]; dbg = Debuginfo.none; live = Reg.Set.empty } let instr_cons d a r n = { desc = d; next = n; arg = a; res = r; dbg = Debuginfo.none; live = Reg.Set.empty } let instr_cons_debug d a r dbg n = { desc = d; next = n; arg = a; res = r; dbg = dbg; live = Reg.Set.empty } let rec instr_iter f i = match i.desc with Iend -> () | _ -> f i; match i.desc with Iend -> () | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> () | Iifthenelse(tst, ifso, ifnot) -> instr_iter f ifso; instr_iter f ifnot; instr_iter f i.next | Iswitch(index, cases) -> for i = 0 to Array.length cases - 1 do instr_iter f cases.(i) done; instr_iter f i.next | Iloop(body) -> instr_iter f body; instr_iter f i.next | Icatch(_, body, handler) -> instr_iter f body; instr_iter f handler; instr_iter f i.next | Iexit _ -> () | Itrywith(body, handler) -> instr_iter f body; instr_iter f handler; instr_iter f i.next | Iraise -> () | _ -> instr_iter f i.next mingw-ocaml/ocaml/asmcomp/hppa/0000755000175000017500000000000012124403240016044 5ustar tootstootsmingw-ocaml/ocaml/asmcomp/hppa/.gitignore0000644000175000017500000000000012124403240020022 0ustar tootstootsmingw-ocaml/ocaml/asmcomp/debuginfo.ml0000644000175000017500000000363412124403240017416 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) open Lexing open Location type kind = Dinfo_call | Dinfo_raise type t = { dinfo_kind: kind; dinfo_file: string; dinfo_line: int; dinfo_char_start: int; dinfo_char_end: int } let none = { dinfo_kind = Dinfo_call; dinfo_file = ""; dinfo_line = 0; dinfo_char_start = 0; dinfo_char_end = 0 } (* PR#5643: cannot use (==) because Debuginfo values are marshalled *) let is_none t = t = none let to_string d = if d = none then "" else Printf.sprintf "{%s:%d,%d-%d}" d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end let from_location kind loc = if loc == Location.none then none else { dinfo_kind = kind; dinfo_file = loc.loc_start.pos_fname; dinfo_line = loc.loc_start.pos_lnum; dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol; dinfo_char_end = if loc.loc_end.pos_fname = loc.loc_start.pos_fname then loc.loc_end.pos_cnum - loc.loc_start.pos_bol else loc.loc_start.pos_cnum - loc.loc_start.pos_bol } let from_call ev = from_location Dinfo_call ev.Lambda.lev_loc let from_raise ev = from_location Dinfo_raise ev.Lambda.lev_loc mingw-ocaml/ocaml/asmcomp/reload.mli0000644000175000017500000000167312124403240017074 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Insert load/stores for pseudoregs that got assigned to stack locations. *) val fundecl: Mach.fundecl -> Mach.fundecl * bool mingw-ocaml/ocaml/asmcomp/asmlibrarian.ml0000644000175000017500000000507212124403240020116 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Build libraries of .cmx files *) open Misc open Config open Cmx_format type error = File_not_found of string | Archiver_error of string exception Error of error let read_info name = let filename = try find_in_path !load_path name with Not_found -> raise(Error(File_not_found name)) in let (info, crc) = Compilenv.read_unit_info filename in info.ui_force_link <- !Clflags.link_everything; (* There is no need to keep the approximation in the .cmxa file, since the compiler will go looking directly for .cmx files. The linker, which is the only one that reads .cmxa files, does not need the approximation. *) info.ui_approx <- Clambda.Value_unknown; (Filename.chop_suffix filename ".cmx" ^ ext_obj, (info, crc)) let create_archive file_list lib_name = let archive_name = chop_extension_if_any lib_name ^ ext_lib in let outchan = open_out_bin lib_name in try output_string outchan cmxa_magic_number; let (objfile_list, descr_list) = List.split (List.map read_info file_list) in List.iter2 (fun file_name (unit, crc) -> Asmlink.check_consistency file_name unit crc) file_list descr_list; let infos = { lib_units = descr_list; lib_ccobjs = !Clflags.ccobjs; lib_ccopts = !Clflags.ccopts } in output_value outchan infos; if Ccomp.create_archive archive_name objfile_list <> 0 then raise(Error(Archiver_error archive_name)); close_out outchan with x -> close_out outchan; remove_file lib_name; remove_file archive_name; raise x open Format let report_error ppf = function | File_not_found name -> fprintf ppf "Cannot find file %s" name | Archiver_error name -> fprintf ppf "Error while creating the library %s" name mingw-ocaml/ocaml/asmcomp/printclambda.mli0000644000175000017500000000156312124403240020264 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) open Clambda open Format val clambda: formatter -> ulambda -> unit mingw-ocaml/ocaml/asmcomp/closure.ml0000644000175000017500000010035212124403240017123 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Introduction of closures, uncurrying, recognition of direct calls *) open Misc open Asttypes open Primitive open Lambda open Switch open Clambda (* Auxiliaries for compiling functions *) let rec split_list n l = if n <= 0 then ([], l) else begin match l with [] -> fatal_error "Closure.split_list" | a::l -> let (l1, l2) = split_list (n-1) l in (a::l1, l2) end let rec build_closure_env env_param pos = function [] -> Tbl.empty | id :: rem -> Tbl.add id (Uprim(Pfield pos, [Uvar env_param], Debuginfo.none)) (build_closure_env env_param (pos+1) rem) (* Auxiliary for accessing globals. We change the name of the global to the name of the corresponding asm symbol. This is done here and no longer in Cmmgen so that approximations stored in .cmx files contain the right names if the -for-pack option is active. *) let getglobal id = Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)), [], Debuginfo.none) (* Check if a variable occurs in a [clambda] term. *) let occurs_var var u = let rec occurs = function Uvar v -> v = var | Uconst (cst,_) -> false | Udirect_apply(lbl, args, _) -> List.exists occurs args | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args | Uclosure(fundecls, clos) -> List.exists occurs clos | Uoffset(u, ofs) -> occurs u | Ulet(id, def, body) -> occurs def || occurs body | Uletrec(decls, body) -> List.exists (fun (id, u) -> occurs u) decls || occurs body | Uprim(p, args, _) -> List.exists occurs args | Uswitch(arg, s) -> occurs arg || occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks | Ustaticfail (_, args) -> List.exists occurs args | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr | Utrywith(body, exn, hdlr) -> occurs body || occurs hdlr | Uifthenelse(cond, ifso, ifnot) -> occurs cond || occurs ifso || occurs ifnot | Usequence(u1, u2) -> occurs u1 || occurs u2 | Uwhile(cond, body) -> occurs cond || occurs body | Ufor(id, lo, hi, dir, body) -> occurs lo || occurs hi || occurs body | Uassign(id, u) -> id = var || occurs u | Usend(_, met, obj, args, _) -> occurs met || occurs obj || List.exists occurs args and occurs_array a = try for i = 0 to Array.length a - 1 do if occurs a.(i) then raise Exit done; false with Exit -> true in occurs u (* Determine whether the estimated size of a clambda term is below some threshold *) let prim_size prim args = match prim with Pidentity -> 0 | Pgetglobal id -> 1 | Psetglobal id -> 1 | Pmakeblock(tag, mut) -> 5 + List.length args | Pfield f -> 1 | Psetfield(f, isptr) -> if isptr then 4 else 1 | Pfloatfield f -> 1 | Psetfloatfield f -> 1 | Pduprecord _ -> 10 + List.length args | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args | Praise -> 4 | Pstringlength -> 5 | Pstringrefs | Pstringsets -> 6 | Pmakearray kind -> 5 + List.length args | Parraylength kind -> if kind = Pgenarray then 6 else 2 | Parrayrefu kind -> if kind = Pgenarray then 12 else 2 | Parraysetu kind -> if kind = Pgenarray then 16 else 4 | Parrayrefs kind -> if kind = Pgenarray then 18 else 8 | Parraysets kind -> if kind = Pgenarray then 22 else 10 | Pbittest -> 3 | Pbigarrayref(_, ndims, _, _) -> 4 + ndims * 6 | Pbigarrayset(_, ndims, _, _) -> 4 + ndims * 6 | _ -> 2 (* arithmetic and comparisons *) (* Very raw approximation of switch cost *) let lambda_smaller lam threshold = let size = ref 0 in let rec lambda_size lam = if !size > threshold then raise Exit; match lam with Uvar v -> () | Uconst( (Const_base(Const_int _ | Const_char _ | Const_float _ | Const_int32 _ | Const_int64 _ | Const_nativeint _) | Const_pointer _), _) -> incr size (* Structured Constants are now emitted during closure conversion. *) | Uconst (_, Some _) -> incr size | Uconst _ -> raise Exit (* avoid duplication of structured constants *) | Udirect_apply(fn, args, _) -> size := !size + 4; lambda_list_size args | Ugeneric_apply(fn, args, _) -> size := !size + 6; lambda_size fn; lambda_list_size args | Uclosure(defs, vars) -> raise Exit (* inlining would duplicate function definitions *) | Uoffset(lam, ofs) -> incr size; lambda_size lam | Ulet(id, lam, body) -> lambda_size lam; lambda_size body | Uletrec(bindings, body) -> raise Exit (* usually too large *) | Uprim(prim, args, _) -> size := !size + prim_size prim args; lambda_list_size args | Uswitch(lam, cases) -> if Array.length cases.us_actions_consts > 1 then size := !size + 5 ; if Array.length cases.us_actions_blocks > 1 then size := !size + 5 ; lambda_size lam; lambda_array_size cases.us_actions_consts ; lambda_array_size cases.us_actions_blocks | Ustaticfail (_,args) -> lambda_list_size args | Ucatch(_, _, body, handler) -> incr size; lambda_size body; lambda_size handler | Utrywith(body, id, handler) -> size := !size + 8; lambda_size body; lambda_size handler | Uifthenelse(cond, ifso, ifnot) -> size := !size + 2; lambda_size cond; lambda_size ifso; lambda_size ifnot | Usequence(lam1, lam2) -> lambda_size lam1; lambda_size lam2 | Uwhile(cond, body) -> size := !size + 2; lambda_size cond; lambda_size body | Ufor(id, low, high, dir, body) -> size := !size + 4; lambda_size low; lambda_size high; lambda_size body | Uassign(id, lam) -> incr size; lambda_size lam | Usend(_, met, obj, args, _) -> size := !size + 8; lambda_size met; lambda_size obj; lambda_list_size args and lambda_list_size l = List.iter lambda_size l and lambda_array_size a = Array.iter lambda_size a in try lambda_size lam; !size <= threshold with Exit -> false (* Check if a clambda term is ``pure'', that is without side-effects *and* not containing function definitions *) let rec is_pure_clambda = function Uvar v -> true | Uconst _ -> true | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false | Uprim(p, args, _) -> List.for_all is_pure_clambda args | _ -> false (* Simplify primitive operations on integers *) let make_const_int n = (Uconst(Const_base(Const_int n), None), Value_integer n) let make_const_ptr n = (Uconst(Const_pointer n, None), Value_constptr n) let make_const_bool b = make_const_ptr(if b then 1 else 0) let simplif_prim_pure p (args, approxs) dbg = match approxs with [Value_integer x] -> begin match p with Pidentity -> make_const_int x | Pnegint -> make_const_int (-x) | Poffsetint y -> make_const_int (x + y) | _ -> (Uprim(p, args, dbg), Value_unknown) end | [Value_integer x; Value_integer y] -> begin match p with Paddint -> make_const_int(x + y) | Psubint -> make_const_int(x - y) | Pmulint -> make_const_int(x * y) | Pdivint when y <> 0 -> make_const_int(x / y) | Pmodint when y <> 0 -> make_const_int(x mod y) | Pandint -> make_const_int(x land y) | Porint -> make_const_int(x lor y) | Pxorint -> make_const_int(x lxor y) | Plslint -> make_const_int(x lsl y) | Plsrint -> make_const_int(x lsr y) | Pasrint -> make_const_int(x asr y) | Pintcomp cmp -> let result = match cmp with Ceq -> x = y | Cneq -> x <> y | Clt -> x < y | Cgt -> x > y | Cle -> x <= y | Cge -> x >= y in make_const_bool result | _ -> (Uprim(p, args, dbg), Value_unknown) end | [Value_constptr x] -> begin match p with Pidentity -> make_const_ptr x | Pnot -> make_const_bool(x = 0) | Pisint -> make_const_bool true | _ -> (Uprim(p, args, dbg), Value_unknown) end | [Value_constptr x; Value_constptr y] -> begin match p with Psequand -> make_const_bool(x <> 0 && y <> 0) | Psequor -> make_const_bool(x <> 0 || y <> 0) | _ -> (Uprim(p, args, dbg), Value_unknown) end | _ -> (Uprim(p, args, dbg), Value_unknown) let simplif_prim p (args, approxs as args_approxs) dbg = if List.for_all is_pure_clambda args then simplif_prim_pure p args_approxs dbg else (Uprim(p, args, dbg), Value_unknown) (* Substitute variables in a [ulambda] term (a body of an inlined function) and perform some more simplifications on integer primitives. Also perform alpha-conversion on let-bound identifiers to avoid clashes with locally-generated identifiers. The variables must not be assigned in the term. This is used to substitute "trivial" arguments for parameters during inline expansion, and also for the translation of let rec over functions. *) let approx_ulam = function Uconst(Const_base(Const_int n),_) -> Value_integer n | Uconst(Const_base(Const_char c),_) -> Value_integer(Char.code c) | Uconst(Const_pointer n,_) -> Value_constptr n | _ -> Value_unknown let rec substitute sb ulam = match ulam with Uvar v -> begin try Tbl.find v sb with Not_found -> ulam end | Uconst _ -> ulam | Udirect_apply(lbl, args, dbg) -> Udirect_apply(lbl, List.map (substitute sb) args, dbg) | Ugeneric_apply(fn, args, dbg) -> Ugeneric_apply(substitute sb fn, List.map (substitute sb) args, dbg) | Uclosure(defs, env) -> (* Question: should we rename function labels as well? Otherwise, there is a risk that function labels are not globally unique. This should not happen in the current system because: - Inlined function bodies contain no Uclosure nodes (cf. function [lambda_smaller]) - When we substitute offsets for idents bound by let rec in [close], case [Lletrec], we discard the original let rec body and use only the substituted term. *) Uclosure(defs, List.map (substitute sb) env) | Uoffset(u, ofs) -> Uoffset(substitute sb u, ofs) | Ulet(id, u1, u2) -> let id' = Ident.rename id in Ulet(id', substitute sb u1, substitute (Tbl.add id (Uvar id') sb) u2) | Uletrec(bindings, body) -> let bindings1 = List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in let sb' = List.fold_right (fun (id, id', _) s -> Tbl.add id (Uvar id') s) bindings1 sb in Uletrec( List.map (fun (id, id', rhs) -> (id', substitute sb' rhs)) bindings1, substitute sb' body) | Uprim(p, args, dbg) -> let sargs = List.map (substitute sb) args in let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) dbg in res | Uswitch(arg, sw) -> Uswitch(substitute sb arg, { sw with us_actions_consts = Array.map (substitute sb) sw.us_actions_consts; us_actions_blocks = Array.map (substitute sb) sw.us_actions_blocks; }) | Ustaticfail (nfail, args) -> Ustaticfail (nfail, List.map (substitute sb) args) | Ucatch(nfail, ids, u1, u2) -> Ucatch(nfail, ids, substitute sb u1, substitute sb u2) | Utrywith(u1, id, u2) -> let id' = Ident.rename id in Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2) | Uifthenelse(u1, u2, u3) -> begin match substitute sb u1 with Uconst(Const_pointer n, _) -> if n <> 0 then substitute sb u2 else substitute sb u3 | su1 -> Uifthenelse(su1, substitute sb u2, substitute sb u3) end | Usequence(u1, u2) -> Usequence(substitute sb u1, substitute sb u2) | Uwhile(u1, u2) -> Uwhile(substitute sb u1, substitute sb u2) | Ufor(id, u1, u2, dir, u3) -> let id' = Ident.rename id in Ufor(id', substitute sb u1, substitute sb u2, dir, substitute (Tbl.add id (Uvar id') sb) u3) | Uassign(id, u) -> let id' = try match Tbl.find id sb with Uvar i -> i | _ -> assert false with Not_found -> id in Uassign(id', substitute sb u) | Usend(k, u1, u2, ul, dbg) -> Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul, dbg) (* Perform an inline expansion *) let is_simple_argument = function Uvar _ -> true | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ | Const_int32 _ | Const_int64 _ | Const_nativeint _),_) -> true | Uconst(Const_pointer _, _) -> true | _ -> false let no_effects = function Uclosure _ -> true | Uconst(Const_base(Const_string _),_) -> true | u -> is_simple_argument u let rec bind_params_rec subst params args body = match (params, args) with ([], []) -> substitute subst body | (p1 :: pl, a1 :: al) -> if is_simple_argument a1 then bind_params_rec (Tbl.add p1 a1 subst) pl al body else begin let p1' = Ident.rename p1 in let body' = bind_params_rec (Tbl.add p1 (Uvar p1') subst) pl al body in if occurs_var p1 body then Ulet(p1', a1, body') else if no_effects a1 then body' else Usequence(a1, body') end | (_, _) -> assert false let bind_params params args body = (* Reverse parameters and arguments to preserve right-to-left evaluation order (PR#2910). *) bind_params_rec Tbl.empty (List.rev params) (List.rev args) body (* Check if a lambda term is ``pure'', that is without side-effects *and* not containing function definitions *) let rec is_pure = function Lvar v -> true | Lconst cst -> true | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false | Lprim(p, args) -> List.for_all is_pure args | Levent(lam, ev) -> is_pure lam | _ -> false (* Generate a direct application *) let direct_apply fundesc funct ufunct uargs = let app_args = if fundesc.fun_closed then uargs else uargs @ [ufunct] in let app = match fundesc.fun_inline with None -> Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none) | Some(params, body) -> bind_params params app_args body in (* If ufunct can contain side-effects or function definitions, we must make sure that it is evaluated exactly once. If the function is not closed, we evaluate ufunct as part of the arguments. If the function is closed, we force the evaluation of ufunct first. *) if not fundesc.fun_closed || is_pure funct then app else Usequence(ufunct, app) (* Add [Value_integer] or [Value_constptr] info to the approximation of an application *) let strengthen_approx appl approx = match approx_ulam appl with (Value_integer _ | Value_constptr _) as intapprox -> intapprox | _ -> approx (* If a term has approximation Value_integer or Value_constptr and is pure, replace it by an integer constant *) let check_constant_result lam ulam approx = match approx with Value_integer n when is_pure lam -> make_const_int n | Value_constptr n when is_pure lam -> make_const_ptr n | _ -> (ulam, approx) (* Evaluate an expression with known value for its side effects only, or discard it if it's pure *) let sequence_constant_expr lam ulam1 (ulam2, approx2 as res2) = if is_pure lam then res2 else (Usequence(ulam1, ulam2), approx2) (* Maintain the approximation of the global structure being defined *) let global_approx = ref([||] : value_approximation array) (* Maintain the nesting depth for functions *) let function_nesting_depth = ref 0 let excessive_function_nesting_depth = 5 (* Decorate clambda term with debug information *) let rec add_debug_info ev u = match ev.lev_kind with | Lev_after _ -> begin match u with | Udirect_apply(lbl, args, dinfo) -> Udirect_apply(lbl, args, Debuginfo.from_call ev) | Ugeneric_apply(Udirect_apply(lbl, args1, dinfo1), args2, dinfo2) -> Ugeneric_apply(Udirect_apply(lbl, args1, Debuginfo.from_call ev), args2, Debuginfo.from_call ev) | Ugeneric_apply(fn, args, dinfo) -> Ugeneric_apply(fn, args, Debuginfo.from_call ev) | Uprim(Praise, args, dinfo) -> Uprim(Praise, args, Debuginfo.from_call ev) | Uprim(p, args, dinfo) -> Uprim(p, args, Debuginfo.from_call ev) | Usend(kind, u1, u2, args, dinfo) -> Usend(kind, u1, u2, args, Debuginfo.from_call ev) | Usequence(u1, u2) -> Usequence(u1, add_debug_info ev u2) | _ -> u end | _ -> u (* Uncurry an expression and explicitate closures. Also return the approximation of the expression. The approximation environment [fenv] maps idents to approximations. Idents not bound in [fenv] approximate to [Value_unknown]. The closure environment [cenv] maps idents to [ulambda] terms. It is used to substitute environment accesses for free identifiers. *) let close_approx_var fenv cenv id = let approx = try Tbl.find id fenv with Not_found -> Value_unknown in match approx with Value_integer n -> make_const_int n | Value_constptr n -> make_const_ptr n | approx -> let subst = try Tbl.find id cenv with Not_found -> Uvar id in (subst, approx) let close_var fenv cenv id = let (ulam, app) = close_approx_var fenv cenv id in ulam let rec close fenv cenv = function Lvar id -> close_approx_var fenv cenv id | Lconst cst -> begin match cst with Const_base(Const_int n) -> (Uconst (cst,None), Value_integer n) | Const_base(Const_char c) -> (Uconst (cst,None), Value_integer(Char.code c)) | Const_pointer n -> (Uconst (cst, None), Value_constptr n) | _ -> (Uconst (cst, Some (Compilenv.new_structured_constant cst true)), Value_unknown) end | Lfunction(kind, params, body) as funct -> close_one_function fenv cenv (Ident.create "fun") funct (* We convert [f a] to [let a' = a in fun b c -> f a' b c] when fun_arity > nargs *) | Lapply(funct, args, loc) -> let nargs = List.length args in begin match (close fenv cenv funct, close_list fenv cenv args) with ((ufunct, Value_closure(fundesc, approx_res)), [Uprim(Pmakeblock(_, _), uargs, _)]) when List.length uargs = - fundesc.fun_arity -> let app = direct_apply fundesc funct ufunct uargs in (app, strengthen_approx app approx_res) | ((ufunct, Value_closure(fundesc, approx_res)), uargs) when nargs = fundesc.fun_arity -> let app = direct_apply fundesc funct ufunct uargs in (app, strengthen_approx app approx_res) | ((ufunct, Value_closure(fundesc, approx_res)), uargs) when nargs < fundesc.fun_arity -> let first_args = List.map (fun arg -> (Ident.create "arg", arg) ) uargs in let final_args = Array.to_list (Array.init (fundesc.fun_arity - nargs) (fun _ -> Ident.create "arg")) in let rec iter args body = match args with [] -> body | (arg1, arg2) :: args -> iter args (Ulet ( arg1, arg2, body)) in let internal_args = (List.map (fun (arg1, arg2) -> Lvar arg1) first_args) @ (List.map (fun arg -> Lvar arg ) final_args) in let (new_fun, approx) = close fenv cenv (Lfunction( Curried, final_args, Lapply(funct, internal_args, loc))) in let new_fun = iter first_args new_fun in (new_fun, approx) | ((ufunct, Value_closure(fundesc, approx_res)), uargs) when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity -> let (first_args, rem_args) = split_list fundesc.fun_arity uargs in (Ugeneric_apply(direct_apply fundesc funct ufunct first_args, rem_args, Debuginfo.none), Value_unknown) | ((ufunct, _), uargs) -> (Ugeneric_apply(ufunct, uargs, Debuginfo.none), Value_unknown) end | Lsend(kind, met, obj, args, _) -> let (umet, _) = close fenv cenv met in let (uobj, _) = close fenv cenv obj in (Usend(kind, umet, uobj, close_list fenv cenv args, Debuginfo.none), Value_unknown) | Llet(str, id, lam, body) -> let (ulam, alam) = close_named fenv cenv id lam in begin match (str, alam) with (Variable, _) -> let (ubody, abody) = close fenv cenv body in (Ulet(id, ulam, ubody), abody) | (_, (Value_integer _ | Value_constptr _)) when str = Alias || is_pure lam -> close (Tbl.add id alam fenv) cenv body | (_, _) -> let (ubody, abody) = close (Tbl.add id alam fenv) cenv body in (Ulet(id, ulam, ubody), abody) end | Lletrec(defs, body) -> if List.for_all (function (id, Lfunction(_, _, _)) -> true | _ -> false) defs then begin (* Simple case: only function definitions *) let (clos, infos) = close_functions fenv cenv defs in let clos_ident = Ident.create "clos" in let fenv_body = List.fold_right (fun (id, pos, approx) fenv -> Tbl.add id approx fenv) infos fenv in let (ubody, approx) = close fenv_body cenv body in let sb = List.fold_right (fun (id, pos, approx) sb -> Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb) infos Tbl.empty in (Ulet(clos_ident, clos, substitute sb ubody), approx) end else begin (* General case: recursive definition of values *) let rec clos_defs = function [] -> ([], fenv) | (id, lam) :: rem -> let (udefs, fenv_body) = clos_defs rem in let (ulam, approx) = close fenv cenv lam in ((id, ulam) :: udefs, Tbl.add id approx fenv_body) in let (udefs, fenv_body) = clos_defs defs in let (ubody, approx) = close fenv_body cenv body in (Uletrec(udefs, ubody), approx) end | Lprim(Pdirapply loc,[funct;arg]) | Lprim(Prevapply loc,[arg;funct]) -> close fenv cenv (Lapply(funct, [arg], loc)) | Lprim(Pgetglobal id, []) as lam -> check_constant_result lam (getglobal id) (Compilenv.global_approx id) | Lprim(Pmakeblock(tag, mut) as prim, lams) -> let (ulams, approxs) = List.split (List.map (close fenv cenv) lams) in (Uprim(prim, ulams, Debuginfo.none), begin match mut with Immutable -> Value_tuple(Array.of_list approxs) | Mutable -> Value_unknown end) | Lprim(Pfield n, [lam]) -> let (ulam, approx) = close fenv cenv lam in let fieldapprox = match approx with Value_tuple a when n < Array.length a -> a.(n) | _ -> Value_unknown in check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none)) fieldapprox | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) -> let (ulam, approx) = close fenv cenv lam in (!global_approx).(n) <- approx; (Uprim(Psetfield(n, false), [getglobal id; ulam], Debuginfo.none), Value_unknown) | Lprim(Praise, [Levent(arg, ev)]) -> let (ulam, approx) = close fenv cenv arg in (Uprim(Praise, [ulam], Debuginfo.from_raise ev), Value_unknown) | Lprim(p, args) -> simplif_prim p (close_list_approx fenv cenv args) Debuginfo.none | Lswitch(arg, sw) -> (* NB: failaction might get copied, thus it should be some Lstaticraise *) let (uarg, _) = close fenv cenv arg in let const_index, const_actions = close_switch fenv cenv sw.sw_consts sw.sw_numconsts sw.sw_failaction and block_index, block_actions = close_switch fenv cenv sw.sw_blocks sw.sw_numblocks sw.sw_failaction in (Uswitch(uarg, {us_index_consts = const_index; us_actions_consts = const_actions; us_index_blocks = block_index; us_actions_blocks = block_actions}), Value_unknown) | Lstaticraise (i, args) -> (Ustaticfail (i, close_list fenv cenv args), Value_unknown) | Lstaticcatch(body, (i, vars), handler) -> let (ubody, _) = close fenv cenv body in let (uhandler, _) = close fenv cenv handler in (Ucatch(i, vars, ubody, uhandler), Value_unknown) | Ltrywith(body, id, handler) -> let (ubody, _) = close fenv cenv body in let (uhandler, _) = close fenv cenv handler in (Utrywith(ubody, id, uhandler), Value_unknown) | Lifthenelse(arg, ifso, ifnot) -> begin match close fenv cenv arg with (uarg, Value_constptr n) -> sequence_constant_expr arg uarg (close fenv cenv (if n = 0 then ifnot else ifso)) | (uarg, _ ) -> let (uifso, _) = close fenv cenv ifso in let (uifnot, _) = close fenv cenv ifnot in (Uifthenelse(uarg, uifso, uifnot), Value_unknown) end | Lsequence(lam1, lam2) -> let (ulam1, _) = close fenv cenv lam1 in let (ulam2, approx) = close fenv cenv lam2 in (Usequence(ulam1, ulam2), approx) | Lwhile(cond, body) -> let (ucond, _) = close fenv cenv cond in let (ubody, _) = close fenv cenv body in (Uwhile(ucond, ubody), Value_unknown) | Lfor(id, lo, hi, dir, body) -> let (ulo, _) = close fenv cenv lo in let (uhi, _) = close fenv cenv hi in let (ubody, _) = close fenv cenv body in (Ufor(id, ulo, uhi, dir, ubody), Value_unknown) | Lassign(id, lam) -> let (ulam, _) = close fenv cenv lam in (Uassign(id, ulam), Value_unknown) | Levent(lam, ev) -> let (ulam, approx) = close fenv cenv lam in (add_debug_info ev ulam, approx) | Lifused _ -> assert false and close_list fenv cenv = function [] -> [] | lam :: rem -> let (ulam, _) = close fenv cenv lam in ulam :: close_list fenv cenv rem and close_list_approx fenv cenv = function [] -> ([], []) | lam :: rem -> let (ulam, approx) = close fenv cenv lam in let (ulams, approxs) = close_list_approx fenv cenv rem in (ulam :: ulams, approx :: approxs) and close_named fenv cenv id = function Lfunction(kind, params, body) as funct -> close_one_function fenv cenv id funct | lam -> close fenv cenv lam (* Build a shared closure for a set of mutually recursive functions *) and close_functions fenv cenv fun_defs = (* Update and check nesting depth *) incr function_nesting_depth; let initially_closed = !function_nesting_depth < excessive_function_nesting_depth in (* Determine the free variables of the functions *) let fv = IdentSet.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in (* Build the function descriptors for the functions. Initially all functions are assumed not to need their environment parameter. *) let uncurried_defs = List.map (function (id, Lfunction(kind, params, body)) -> let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in let arity = List.length params in let fundesc = {fun_label = label; fun_arity = (if kind = Tupled then -arity else arity); fun_closed = initially_closed; fun_inline = None } in (id, params, body, fundesc) | (_, _) -> fatal_error "Closure.close_functions") fun_defs in (* Build an approximate fenv for compiling the functions *) let fenv_rec = List.fold_right (fun (id, params, body, fundesc) fenv -> Tbl.add id (Value_closure(fundesc, Value_unknown)) fenv) uncurried_defs fenv in (* Determine the offsets of each function's closure in the shared block *) let env_pos = ref (-1) in let clos_offsets = List.map (fun (id, params, body, fundesc) -> let pos = !env_pos + 1 in env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2); pos) uncurried_defs in let fv_pos = !env_pos in (* This reference will be set to false if the hypothesis that a function does not use its environment parameter is invalidated. *) let useless_env = ref initially_closed in (* Translate each function definition *) let clos_fundef (id, params, body, fundesc) env_pos = let dbg = match body with | Levent (_,({lev_kind=Lev_function} as ev)) -> Debuginfo.from_call ev | _ -> Debuginfo.none in let env_param = Ident.create "env" in let cenv_fv = build_closure_env env_param (fv_pos - env_pos) fv in let cenv_body = List.fold_right2 (fun (id, params, arity, body) pos env -> Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env) uncurried_defs clos_offsets cenv_fv in let (ubody, approx) = close fenv_rec cenv_body body in if !useless_env && occurs_var env_param ubody then useless_env := false; let fun_params = if !useless_env then params else params @ [env_param] in ({ label = fundesc.fun_label; arity = fundesc.fun_arity; params = fun_params; body = ubody; dbg }, (id, env_pos, Value_closure(fundesc, approx))) in (* Translate all function definitions. *) let clos_info_list = if initially_closed then begin let cl = List.map2 clos_fundef uncurried_defs clos_offsets in (* If the hypothesis that the environment parameters are useless has been invalidated, then set [fun_closed] to false in all descriptions and recompile *) if !useless_env then cl else begin List.iter (fun (id, params, body, fundesc) -> fundesc.fun_closed <- false) uncurried_defs; List.map2 clos_fundef uncurried_defs clos_offsets end end else (* Excessive closure nesting: assume environment parameter is used *) List.map2 clos_fundef uncurried_defs clos_offsets in (* Update nesting depth *) decr function_nesting_depth; (* Return the Uclosure node and the list of all identifiers defined, with offsets and approximations. *) let (clos, infos) = List.split clos_info_list in (Uclosure(clos, List.map (close_var fenv cenv) fv), infos) (* Same, for one non-recursive function *) and close_one_function fenv cenv id funct = match close_functions fenv cenv [id, funct] with ((Uclosure([f], _) as clos), [_, _, (Value_closure(fundesc, _) as approx)]) -> (* See if the function can be inlined *) if lambda_smaller f.body (!Clflags.inline_threshold + List.length f.params) then fundesc.fun_inline <- Some(f.params, f.body); (clos, approx) | _ -> fatal_error "Closure.close_one_function" (* Close a switch *) and close_switch fenv cenv cases num_keys default = let index = Array.create num_keys 0 and store = mk_store Lambda.same in (* First default case *) begin match default with | Some def when List.length cases < num_keys -> ignore (store.act_store def) | _ -> () end ; (* Then all other cases *) List.iter (fun (key,lam) -> index.(key) <- store.act_store lam) cases ; (* Compile action *) let actions = Array.map (fun lam -> let ulam,_ = close fenv cenv lam in ulam) (store.act_get ()) in match actions with | [| |] -> [| |], [| |] (* May happen when default is None *) | _ -> index, actions (* The entry point *) let intro size lam = function_nesting_depth := 0; global_approx := Array.create size Value_unknown; Compilenv.set_global_approx(Value_tuple !global_approx); let (ulam, approx) = close Tbl.empty Tbl.empty lam in global_approx := [||]; ulam mingw-ocaml/ocaml/asmcomp/alpha/0000755000175000017500000000000012124403240016201 5ustar tootstootsmingw-ocaml/ocaml/asmcomp/alpha/.gitignore0000644000175000017500000000000012124403240020157 0ustar tootstootsmingw-ocaml/ocaml/asmcomp/linearize.mli0000644000175000017500000000341112124403240017600 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Transformation of Mach code into a list of pseudo-instructions. *) type label = int val new_label: unit -> label type instruction = { mutable desc: instruction_desc; mutable next: instruction; arg: Reg.t array; res: Reg.t array; dbg: Debuginfo.t; live: Reg.Set.t } and instruction_desc = Lend | Lop of Mach.operation | Lreloadretaddr | Lreturn | Llabel of label | Lbranch of label | Lcondbranch of Mach.test * label | Lcondbranch3 of label option * label option * label option | Lswitch of label array | Lsetuptrap of label | Lpushtrap | Lpoptrap | Lraise val has_fallthrough : instruction_desc -> bool val end_instr: instruction val instr_cons: instruction_desc -> Reg.t array -> Reg.t array -> instruction -> instruction val invert_test: Mach.test -> Mach.test type fundecl = { fun_name: string; fun_body: instruction; fun_fast: bool; fun_dbg : Debuginfo.t } val fundecl: Mach.fundecl -> fundecl mingw-ocaml/ocaml/asmcomp/mach.mli0000644000175000017500000000551712124403240016537 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Representation of machine code by sequences of pseudoinstructions *) type integer_comparison = Isigned of Cmm.comparison | Iunsigned of Cmm.comparison type integer_operation = Iadd | Isub | Imul | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Icomp of integer_comparison | Icheckbound type test = Itruetest | Ifalsetest | Iinttest of integer_comparison | Iinttest_imm of integer_comparison * int | Ifloattest of Cmm.comparison * bool | Ioddtest | Ieventest type operation = Imove | Ispill | Ireload | Iconst_int of nativeint | Iconst_float of string | Iconst_symbol of string | Icall_ind | Icall_imm of string | Itailcall_ind | Itailcall_imm of string | Iextcall of string * bool | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode | Istore of Cmm.memory_chunk * Arch.addressing_mode | Ialloc of int | Iintop of integer_operation | Iintop_imm of integer_operation * int | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf | Ifloatofint | Iintoffloat | Ispecific of Arch.specific_operation type instruction = { desc: instruction_desc; next: instruction; arg: Reg.t array; res: Reg.t array; dbg: Debuginfo.t; mutable live: Reg.Set.t } and instruction_desc = Iend | Iop of operation | Ireturn | Iifthenelse of test * instruction * instruction | Iswitch of int array * instruction array | Iloop of instruction | Icatch of int * instruction * instruction | Iexit of int | Itrywith of instruction * instruction | Iraise type fundecl = { fun_name: string; fun_args: Reg.t array; fun_body: instruction; fun_fast: bool; fun_dbg : Debuginfo.t } val dummy_instr: instruction val end_instr: unit -> instruction val instr_cons: instruction_desc -> Reg.t array -> Reg.t array -> instruction -> instruction val instr_cons_debug: instruction_desc -> Reg.t array -> Reg.t array -> Debuginfo.t -> instruction -> instruction val instr_iter: (instruction -> unit) -> instruction -> unit mingw-ocaml/ocaml/asmcomp/comballoc.mli0000644000175000017500000000164712124403240017562 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Combine heap allocations occurring in the same basic block *) val fundecl: Mach.fundecl -> Mach.fundecl mingw-ocaml/ocaml/asmcomp/reloadgen.ml0000644000175000017500000001111512124403240017405 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Insert load/stores for pseudoregs that got assigned to stack locations. *) open Misc open Reg open Mach let access_stack r = try for i = 0 to Array.length r - 1 do match r.(i).loc with Stack _ -> raise Exit | _ -> () done; false with Exit -> true let insert_move src dst next = if src.loc = dst.loc then next else instr_cons (Iop Imove) [|src|] [|dst|] next let insert_moves src dst next = let rec insmoves i = if i >= Array.length src then next else insert_move src.(i) dst.(i) (insmoves (i+1)) in insmoves 0 class reload_generic = object (self) val mutable redo_regalloc = false method makereg r = match r.loc with Unknown -> fatal_error "Reload.makereg" | Reg _ -> r | Stack _ -> redo_regalloc <- true; let newr = Reg.clone r in (* Strongly discourage spilling this register *) newr.spill_cost <- 100000; newr method private makeregs rv = let n = Array.length rv in let newv = Array.create n Reg.dummy in for i = 0 to n-1 do newv.(i) <- self#makereg rv.(i) done; newv method private makereg1 rv = let newv = Array.copy rv in newv.(0) <- self#makereg rv.(0); newv method reload_operation op arg res = (* By default, assume that arguments and results must reside in hardware registers. For moves, allow one arg or one res to be stack-allocated, but do something for stack-to-stack moves *) match op with Imove | Ireload | Ispill -> begin match arg.(0), res.(0) with {loc = Stack s1}, {loc = Stack s2} when s1 <> s2 -> ([| self#makereg arg.(0) |], res) | _ -> (arg, res) end | _ -> (self#makeregs arg, self#makeregs res) method reload_test tst args = self#makeregs args method private reload i = match i.desc with (* For function calls, returns, etc: the arguments and results are already at the correct position (e.g. on stack for some arguments). However, something needs to be done for the function pointer in indirect calls. *) Iend | Ireturn | Iop(Itailcall_imm _) | Iraise -> i | Iop(Itailcall_ind) -> let newarg = self#makereg1 i.arg in insert_moves i.arg newarg {i with arg = newarg} | Iop(Icall_imm _ | Iextcall _) -> {i with next = self#reload i.next} | Iop(Icall_ind) -> let newarg = self#makereg1 i.arg in insert_moves i.arg newarg {i with arg = newarg; next = self#reload i.next} | Iop op -> let (newarg, newres) = self#reload_operation op i.arg i.res in insert_moves i.arg newarg {i with arg = newarg; res = newres; next = (insert_moves newres i.res (self#reload i.next))} | Iifthenelse(tst, ifso, ifnot) -> let newarg = self#reload_test tst i.arg in insert_moves i.arg newarg (instr_cons (Iifthenelse(tst, self#reload ifso, self#reload ifnot)) newarg [||] (self#reload i.next)) | Iswitch(index, cases) -> let newarg = self#makeregs i.arg in insert_moves i.arg newarg (instr_cons (Iswitch(index, Array.map (self#reload) cases)) newarg [||] (self#reload i.next)) | Iloop body -> instr_cons (Iloop(self#reload body)) [||] [||] (self#reload i.next) | Icatch(nfail, body, handler) -> instr_cons (Icatch(nfail, self#reload body, self#reload handler)) [||] [||] (self#reload i.next) | Iexit i -> instr_cons (Iexit i) [||] [||] dummy_instr | Itrywith(body, handler) -> instr_cons (Itrywith(self#reload body, self#reload handler)) [||] [||] (self#reload i.next) method fundecl f = redo_regalloc <- false; let new_body = self#reload f.fun_body in ({fun_name = f.fun_name; fun_args = f.fun_args; fun_body = new_body; fun_fast = f.fun_fast; fun_dbg = f.fun_dbg}, redo_regalloc) end mingw-ocaml/ocaml/asmcomp/printlinear.mli0000644000175000017500000000173712124403240020156 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Pretty-printing of linearized machine code *) open Format open Linearize val instr: formatter -> instruction -> unit val fundecl: formatter -> fundecl -> unit mingw-ocaml/ocaml/asmcomp/spill.ml0000644000175000017500000003557712124403240016612 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Insertion of moves to suggest possible spilling / reloading points before register allocation. *) open Reg open Mach (* We say that a register is "destroyed" if it is live across a construct that potentially destroys all physical registers: function calls or try...with constructs. The "destroyed" registers must therefore reside in the stack during these instructions.. We will insert spills (stores) just after they are defined, and reloads just before their first use following a "destroying" construct. Instructions with more live registers than actual registers also "destroy" registers: we mark as "destroyed" the registers live across the instruction that haven't been used for the longest time. These registers will be spilled and reloaded as described above. *) (* Association of spill registers to registers *) let spill_env = ref (Reg.Map.empty : Reg.t Reg.Map.t) let spill_reg r = try Reg.Map.find r !spill_env with Not_found -> let spill_r = Reg.create r.typ in spill_r.spill <- true; if String.length r.name > 0 then spill_r.name <- "spilled-" ^ r.name; spill_env := Reg.Map.add r spill_r !spill_env; spill_r (* Record the position of last use of registers *) let use_date = ref (Reg.Map.empty : int Reg.Map.t) let current_date = ref 0 let record_use regv = for i = 0 to Array.length regv - 1 do let r = regv.(i) in let prev_date = try Reg.Map.find r !use_date with Not_found -> 0 in if !current_date > prev_date then use_date := Reg.Map.add r !current_date !use_date done (* Check if the register pressure overflows the maximum pressure allowed at that point. If so, spill enough registers to lower the pressure. *) let add_superpressure_regs op live_regs res_regs spilled = let max_pressure = Proc.max_register_pressure op in let regs = Reg.add_set_array live_regs res_regs in (* Compute the pressure in each register class *) let pressure = Array.create Proc.num_register_classes 0 in Reg.Set.iter (fun r -> if Reg.Set.mem r spilled then () else begin match r.loc with Stack s -> () | _ -> let c = Proc.register_class r in pressure.(c) <- pressure.(c) + 1 end) regs; (* Check if pressure is exceeded for each class. *) let rec check_pressure cl spilled = if cl >= Proc.num_register_classes then spilled else if pressure.(cl) <= max_pressure.(cl) then check_pressure (cl+1) spilled else begin (* Find the least recently used, unspilled, unallocated, live register in the class *) let lru_date = ref 1000000 and lru_reg = ref Reg.dummy in Reg.Set.iter (fun r -> if Proc.register_class r = cl && not (Reg.Set.mem r spilled) && r.loc = Unknown then begin try let d = Reg.Map.find r !use_date in if d < !lru_date then begin lru_date := d; lru_reg := r end with Not_found -> (* Should not happen *) () end) live_regs; if !lru_reg != Reg.dummy then begin pressure.(cl) <- pressure.(cl) - 1; check_pressure cl (Reg.Set.add !lru_reg spilled) end else (* Couldn't find any spillable register, give up for this class *) check_pressure (cl+1) spilled end in check_pressure 0 spilled (* A-list recording what is destroyed at if-then-else points. *) let destroyed_at_fork = ref ([] : (instruction * Reg.Set.t) list) (* First pass: insert reload instructions based on an approximation of what is destroyed at pressure points. *) let add_reloads regset i = Reg.Set.fold (fun r i -> instr_cons (Iop Ireload) [|spill_reg r|] [|r|] i) regset i let reload_at_exit = ref [] let find_reload_at_exit k = try List.assoc k !reload_at_exit with | Not_found -> Misc.fatal_error "Spill.find_reload_at_exit" let reload_at_break = ref Reg.Set.empty let rec reload i before = incr current_date; record_use i.arg; record_use i.res; match i.desc with Iend -> (i, before) | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> (add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty) | Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> (* All regs live across must be spilled *) let (new_next, finally) = reload i.next i.live in (add_reloads (Reg.inter_set_array before i.arg) (instr_cons_debug i.desc i.arg i.res i.dbg new_next), finally) | Iop op -> let new_before = (* Quick check to see if the register pressure is below the maximum *) if Reg.Set.cardinal i.live + Array.length i.res <= Proc.safe_register_pressure op then before else add_superpressure_regs op i.live i.res before in let after = Reg.diff_set_array (Reg.diff_set_array new_before i.arg) i.res in let (new_next, finally) = reload i.next after in (add_reloads (Reg.inter_set_array new_before i.arg) (instr_cons_debug i.desc i.arg i.res i.dbg new_next), finally) | Iifthenelse(test, ifso, ifnot) -> let at_fork = Reg.diff_set_array before i.arg in let date_fork = !current_date in let (new_ifso, after_ifso) = reload ifso at_fork in let date_ifso = !current_date in current_date := date_fork; let (new_ifnot, after_ifnot) = reload ifnot at_fork in current_date := max date_ifso !current_date; let (new_next, finally) = reload i.next (Reg.Set.union after_ifso after_ifnot) in let new_i = instr_cons (Iifthenelse(test, new_ifso, new_ifnot)) i.arg i.res new_next in destroyed_at_fork := (new_i, at_fork) :: !destroyed_at_fork; (add_reloads (Reg.inter_set_array before i.arg) new_i, finally) | Iswitch(index, cases) -> let at_fork = Reg.diff_set_array before i.arg in let date_fork = !current_date in let date_join = ref 0 in let after_cases = ref Reg.Set.empty in let new_cases = Array.map (fun c -> current_date := date_fork; let (new_c, after_c) = reload c at_fork in after_cases := Reg.Set.union !after_cases after_c; date_join := max !date_join !current_date; new_c) cases in current_date := !date_join; let (new_next, finally) = reload i.next !after_cases in (add_reloads (Reg.inter_set_array before i.arg) (instr_cons (Iswitch(index, new_cases)) i.arg i.res new_next), finally) | Iloop(body) -> let date_start = !current_date in let at_head = ref before in let final_body = ref body in begin try while true do current_date := date_start; let (new_body, new_at_head) = reload body !at_head in let merged_at_head = Reg.Set.union !at_head new_at_head in if Reg.Set.equal merged_at_head !at_head then begin final_body := new_body; raise Exit end; at_head := merged_at_head done with Exit -> () end; let (new_next, finally) = reload i.next Reg.Set.empty in (instr_cons (Iloop(!final_body)) i.arg i.res new_next, finally) | Icatch(nfail, body, handler) -> let new_set = ref Reg.Set.empty in reload_at_exit := (nfail, new_set) :: !reload_at_exit ; let (new_body, after_body) = reload body before in let at_exit = !new_set in reload_at_exit := List.tl !reload_at_exit ; let (new_handler, after_handler) = reload handler at_exit in let (new_next, finally) = reload i.next (Reg.Set.union after_body after_handler) in (instr_cons (Icatch(nfail, new_body, new_handler)) i.arg i.res new_next, finally) | Iexit nfail -> let set = find_reload_at_exit nfail in set := Reg.Set.union !set before; (i, Reg.Set.empty) | Itrywith(body, handler) -> let (new_body, after_body) = reload body before in let (new_handler, after_handler) = reload handler handler.live in let (new_next, finally) = reload i.next (Reg.Set.union after_body after_handler) in (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next, finally) | Iraise -> (add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty) (* Second pass: add spill instructions based on what we've decided to reload. That is, any register that may be reloaded in the future must be spilled just after its definition. *) (* As an optimization, if a register needs to be spilled in one branch of a conditional but not in the other, then we spill it late on entrance in the branch that needs it spilled. NB: This strategy is turned off in loops, as it may prevent a spill from being lifted up all the way out of the loop. NB again: This strategy is also off in switch arms as it generates many useless spills inside switch arms NB ter: is it the same thing for catch bodies ? *) let spill_at_exit = ref [] let find_spill_at_exit k = try List.assoc k !spill_at_exit with | Not_found -> Misc.fatal_error "Spill.find_spill_at_exit" let spill_at_raise = ref Reg.Set.empty let inside_loop = ref false and inside_arm = ref false and inside_catch = ref false let add_spills regset i = Reg.Set.fold (fun r i -> instr_cons (Iop Ispill) [|r|] [|spill_reg r|] i) regset i let rec spill i finally = match i.desc with Iend -> (i, finally) | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> (i, Reg.Set.empty) | Iop Ireload -> let (new_next, after) = spill i.next finally in let before1 = Reg.diff_set_array after i.res in (instr_cons i.desc i.arg i.res new_next, Reg.add_set_array before1 i.res) | Iop _ -> let (new_next, after) = spill i.next finally in let before1 = Reg.diff_set_array after i.res in let before = match i.desc with Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _) | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> Reg.Set.union before1 !spill_at_raise | _ -> before1 in (instr_cons_debug i.desc i.arg i.res i.dbg (add_spills (Reg.inter_set_array after i.res) new_next), before) | Iifthenelse(test, ifso, ifnot) -> let (new_next, at_join) = spill i.next finally in let (new_ifso, before_ifso) = spill ifso at_join in let (new_ifnot, before_ifnot) = spill ifnot at_join in if !inside_loop || !inside_arm then (instr_cons (Iifthenelse(test, new_ifso, new_ifnot)) i.arg i.res new_next, Reg.Set.union before_ifso before_ifnot) else begin let destroyed = List.assq i !destroyed_at_fork in let spill_ifso_branch = Reg.Set.diff (Reg.Set.diff before_ifso before_ifnot) destroyed and spill_ifnot_branch = Reg.Set.diff (Reg.Set.diff before_ifnot before_ifso) destroyed in (instr_cons (Iifthenelse(test, add_spills spill_ifso_branch new_ifso, add_spills spill_ifnot_branch new_ifnot)) i.arg i.res new_next, Reg.Set.diff (Reg.Set.diff (Reg.Set.union before_ifso before_ifnot) spill_ifso_branch) spill_ifnot_branch) end | Iswitch(index, cases) -> let (new_next, at_join) = spill i.next finally in let saved_inside_arm = !inside_arm in inside_arm := true ; let before = ref Reg.Set.empty in let new_cases = Array.map (fun c -> let (new_c, before_c) = spill c at_join in before := Reg.Set.union !before before_c; new_c) cases in inside_arm := saved_inside_arm ; (instr_cons (Iswitch(index, new_cases)) i.arg i.res new_next, !before) | Iloop(body) -> let (new_next, _) = spill i.next finally in let saved_inside_loop = !inside_loop in inside_loop := true; let at_head = ref Reg.Set.empty in let final_body = ref body in begin try while true do let (new_body, before_body) = spill body !at_head in let new_at_head = Reg.Set.union !at_head before_body in if Reg.Set.equal new_at_head !at_head then begin final_body := new_body; raise Exit end; at_head := new_at_head done with Exit -> () end; inside_loop := saved_inside_loop; (instr_cons (Iloop(!final_body)) i.arg i.res new_next, !at_head) | Icatch(nfail, body, handler) -> let (new_next, at_join) = spill i.next finally in let (new_handler, at_exit) = spill handler at_join in let saved_inside_catch = !inside_catch in inside_catch := true ; spill_at_exit := (nfail, at_exit) :: !spill_at_exit ; let (new_body, before) = spill body at_join in spill_at_exit := List.tl !spill_at_exit; inside_catch := saved_inside_catch ; (instr_cons (Icatch(nfail, new_body, new_handler)) i.arg i.res new_next, before) | Iexit nfail -> (i, find_spill_at_exit nfail) | Itrywith(body, handler) -> let (new_next, at_join) = spill i.next finally in let (new_handler, before_handler) = spill handler at_join in let saved_spill_at_raise = !spill_at_raise in spill_at_raise := before_handler; let (new_body, before_body) = spill body at_join in spill_at_raise := saved_spill_at_raise; (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next, before_body) | Iraise -> (i, !spill_at_raise) (* Entry point *) let fundecl f = spill_env := Reg.Map.empty; use_date := Reg.Map.empty; current_date := 0; let (body1, _) = reload f.fun_body Reg.Set.empty in let (body2, tospill_at_entry) = spill body1 Reg.Set.empty in let new_body = add_spills (Reg.inter_set_array tospill_at_entry f.fun_args) body2 in spill_env := Reg.Map.empty; use_date := Reg.Map.empty; { fun_name = f.fun_name; fun_args = f.fun_args; fun_body = new_body; fun_fast = f.fun_fast; fun_dbg = f.fun_dbg } mingw-ocaml/ocaml/asmcomp/reg.ml0000644000175000017500000001027612124403240016231 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Cmm type t = { mutable name: string; stamp: int; typ: Cmm.machtype_component; mutable loc: location; mutable spill: bool; mutable interf: t list; mutable prefer: (t * int) list; mutable degree: int; mutable spill_cost: int; mutable visited: bool } and location = Unknown | Reg of int | Stack of stack_location and stack_location = Local of int | Incoming of int | Outgoing of int type reg = t let dummy = { name = ""; stamp = 0; typ = Int; loc = Unknown; spill = false; interf = []; prefer = []; degree = 0; spill_cost = 0; visited = false } let currstamp = ref 0 let reg_list = ref([] : t list) let create ty = let r = { name = ""; stamp = !currstamp; typ = ty; loc = Unknown; spill = false; interf = []; prefer = []; degree = 0; spill_cost = 0; visited = false } in reg_list := r :: !reg_list; incr currstamp; r let createv tyv = let n = Array.length tyv in let rv = Array.create n dummy in for i = 0 to n-1 do rv.(i) <- create tyv.(i) done; rv let createv_like rv = let n = Array.length rv in let rv' = Array.create n dummy in for i = 0 to n-1 do rv'.(i) <- create rv.(i).typ done; rv' let clone r = let nr = create r.typ in nr.name <- r.name; nr let at_location ty loc = let r = { name = "R"; stamp = !currstamp; typ = ty; loc = loc; spill = false; interf = []; prefer = []; degree = 0; spill_cost = 0; visited = false } in incr currstamp; r let first_virtual_reg_stamp = ref (-1) let reset() = (* When reset() is called for the first time, the current stamp reflects all hard pseudo-registers that have been allocated by Proc, so remember it and use it as the base stamp for allocating soft pseudo-registers *) if !first_virtual_reg_stamp = -1 then first_virtual_reg_stamp := !currstamp; currstamp := !first_virtual_reg_stamp; reg_list := [] let all_registers() = !reg_list let num_registers() = !currstamp let reinit_reg r = r.loc <- Unknown; r.interf <- []; r.prefer <- []; r.degree <- 0; (* Preserve the very high spill costs introduced by the reloading pass *) if r.spill_cost >= 100000 then r.spill_cost <- 100000 else r.spill_cost <- 0 let reinit() = List.iter reinit_reg !reg_list module RegOrder = struct type t = reg let compare r1 r2 = r1.stamp - r2.stamp end module Set = Set.Make(RegOrder) module Map = Map.Make(RegOrder) let add_set_array s v = match Array.length v with 0 -> s | 1 -> Set.add v.(0) s | n -> let rec add_all i = if i >= n then s else Set.add v.(i) (add_all(i+1)) in add_all 0 let diff_set_array s v = match Array.length v with 0 -> s | 1 -> Set.remove v.(0) s | n -> let rec remove_all i = if i >= n then s else Set.remove v.(i) (remove_all(i+1)) in remove_all 0 let inter_set_array s v = match Array.length v with 0 -> Set.empty | 1 -> if Set.mem v.(0) s then Set.add v.(0) Set.empty else Set.empty | n -> let rec inter_all i = if i >= n then Set.empty else if Set.mem v.(i) s then Set.add v.(i) (inter_all(i+1)) else inter_all(i+1) in inter_all 0 let set_of_array v = match Array.length v with 0 -> Set.empty | 1 -> Set.add v.(0) Set.empty | n -> let rec add_all i = if i >= n then Set.empty else Set.add v.(i) (add_all(i+1)) in add_all 0 mingw-ocaml/ocaml/asmcomp/emitaux.mli0000644000175000017500000000444312124403240017300 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Common functions for emitting assembly code *) val output_channel: out_channel ref val emit_string: string -> unit val emit_int: int -> unit val emit_nativeint: nativeint -> unit val emit_int32: int32 -> unit val emit_symbol: char -> string -> unit val emit_printf: ('a, out_channel, unit) format -> 'a val emit_char: char -> unit val emit_string_literal: string -> unit val emit_string_directive: string -> string -> unit val emit_bytes_directive: string -> string -> unit val emit_float64_directive: string -> string -> unit val emit_float64_split_directive: string -> string -> unit val emit_float32_directive: string -> string -> unit val reset_debug_info: unit -> unit val emit_debug_info: Debuginfo.t -> unit type frame_descr = { fd_lbl: int; (* Return address *) fd_frame_size: int; (* Size of stack frame *) fd_live_offset: int list; (* Offsets/regs of live addresses *) fd_debuginfo: Debuginfo.t } (* Location, if any *) val frame_descriptors : frame_descr list ref type emit_frame_actions = { efa_label: int -> unit; efa_16: int -> unit; efa_32: int32 -> unit; efa_word: int -> unit; efa_align: int -> unit; efa_label_rel: int -> int32 -> unit; efa_def_label: int -> unit; efa_string: string -> unit } val emit_frames: emit_frame_actions -> unit val is_generic_function: string -> bool val cfi_startproc : unit -> unit val cfi_endproc : unit -> unit val cfi_adjust_cfa_offset : int -> unit mingw-ocaml/ocaml/asmcomp/reg.mli0000644000175000017500000000433212124403240016376 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Pseudo-registers *) type t = { mutable name: string; (* Name (for printing) *) stamp: int; (* Unique stamp *) typ: Cmm.machtype_component; (* Type of contents *) mutable loc: location; (* Actual location *) mutable spill: bool; (* "true" to force stack allocation *) mutable interf: t list; (* Other regs live simultaneously *) mutable prefer: (t * int) list; (* Preferences for other regs *) mutable degree: int; (* Number of other regs live sim. *) mutable spill_cost: int; (* Estimate of spilling cost *) mutable visited: bool } (* For graph walks *) and location = Unknown | Reg of int | Stack of stack_location and stack_location = Local of int | Incoming of int | Outgoing of int val dummy: t val create: Cmm.machtype_component -> t val createv: Cmm.machtype -> t array val createv_like: t array -> t array val clone: t -> t val at_location: Cmm.machtype_component -> location -> t module Set: Set.S with type elt = t module Map: Map.S with type key = t val add_set_array: Set.t -> t array -> Set.t val diff_set_array: Set.t -> t array -> Set.t val inter_set_array: Set.t -> t array -> Set.t val set_of_array: t array -> Set.t val reset: unit -> unit val all_registers: unit -> t list val num_registers: unit -> int val reinit: unit -> unit mingw-ocaml/ocaml/asmcomp/arm/0000755000175000017500000000000012124403240015673 5ustar tootstootsmingw-ocaml/ocaml/asmcomp/arm/scheduling.ml0000644000175000017500000000474712124403240020366 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Benedikt Meurer, University of Siegen *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique *) (* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) (* reserved. This file is distributed under the terms of the Q *) (* Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Arch open Mach (* Instruction scheduling for the ARM *) class scheduler = object(self) inherit Schedgen.scheduler_generic as super (* Scheduling -- based roughly on the ARM11 (ARMv6) *) method oper_latency = function (* Loads have a latency of two cycles in general *) Iconst_symbol _ | Iconst_float _ | Iload(_, _) | Ireload | Ifloatofint (* mcr/mrc count as memory access *) | Iintoffloat -> 2 (* Multiplys have a latency of two cycles *) | Iintop Imul | Ispecific(Imuladd | Imulsub) -> 2 (* VFP instructions *) | Iaddf | Isubf | Idivf | Imulf | Ispecific Inegmulf | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) | Ispecific Isqrtf | Inegf | Iabsf when !fpu >= VFPv3_D16 -> 2 (* Everything else *) | _ -> 1 method! is_checkbound = function Ispecific(Ishiftcheckbound _) -> true | op -> super#is_checkbound op (* Issue cycles. Rough approximations *) method oper_issue_cycles = function Ialloc _ -> 4 | Iintop(Ilsl | Ilsr | Iasr) -> 2 | Iintop(Icomp _) | Iintop_imm(Icomp _, _) -> 3 | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> 2 | Ispecific(Ishiftcheckbound _) -> 3 | Iintop_imm(Idiv, _) -> 4 | Iintop_imm(Imod, _) -> 6 | Iintop Imul | Ispecific(Imuladd | Imulsub) -> 2 (* VFP instructions *) | Iaddf | Isubf -> 7 | Imulf | Ispecific Inegmulf -> 9 | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) -> 17 | Idivf | Ispecific Isqrtf -> 27 | Inegf | Iabsf | Iconst_float _ when !fpu >= VFPv3_D16 -> 4 (* Everything else *) | _ -> 1 end let fundecl f = (new scheduler)#schedule_fundecl f mingw-ocaml/ocaml/asmcomp/arm/arch.ml0000644000175000017500000001562012124403240017146 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Benedikt Meurer, University of Siegen *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique *) (* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) (* reserved. This file is distributed under the terms of the Q *) (* Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Specific operations for the ARM processor *) open Misc open Format type abi = EABI | EABI_VFP type arch = ARMv4 | ARMv5 | ARMv5TE | ARMv6 | ARMv6T2 | ARMv7 type fpu = Soft | VFPv3_D16 | VFPv3 let abi = match Config.system with "linux_eabi" -> EABI | "linux_eabihf" -> EABI_VFP | _ -> assert false let string_of_arch = function ARMv4 -> "armv4" | ARMv5 -> "armv5" | ARMv5TE -> "armv5te" | ARMv6 -> "armv6" | ARMv6T2 -> "armv6t2" | ARMv7 -> "armv7" let string_of_fpu = function Soft -> "soft" | VFPv3_D16 -> "vfpv3-d16" | VFPv3 -> "vfpv3" (* Machine-specific command-line options *) let (arch, fpu, thumb) = let (def_arch, def_fpu, def_thumb) = begin match abi, Config.model with (* Defaults for architecture, FPU and Thumb *) EABI, "armv5" -> ARMv5, Soft, false | EABI, "armv5te" -> ARMv5TE, Soft, false | EABI, "armv6" -> ARMv6, Soft, false | EABI, "armv6t2" -> ARMv6T2, Soft, false | EABI, "armv7" -> ARMv7, Soft, false | EABI, _ -> ARMv4, Soft, false | EABI_VFP, _ -> ARMv7, VFPv3_D16, true end in (ref def_arch, ref def_fpu, ref def_thumb) let pic_code = ref false let farch spec = arch := (match spec with "armv4" when abi <> EABI_VFP -> ARMv4 | "armv5" when abi <> EABI_VFP -> ARMv5 | "armv5te" when abi <> EABI_VFP -> ARMv5TE | "armv6" when abi <> EABI_VFP -> ARMv6 | "armv6t2" when abi <> EABI_VFP -> ARMv6T2 | "armv7" -> ARMv7 | spec -> raise (Arg.Bad spec)) let ffpu spec = fpu := (match spec with "soft" when abi <> EABI_VFP -> Soft | "vfpv3-d16" when abi = EABI_VFP -> VFPv3_D16 | "vfpv3" when abi = EABI_VFP -> VFPv3 | spec -> raise (Arg.Bad spec)) let command_line_options = [ "-farch", Arg.String farch, " Select the ARM target architecture" ^ " (default: " ^ (string_of_arch !arch) ^ ")"; "-ffpu", Arg.String ffpu, " Select the floating-point hardware" ^ " (default: " ^ (string_of_fpu !fpu) ^ ")"; "-fPIC", Arg.Set pic_code, " Generate position-independent machine code"; "-fno-PIC", Arg.Clear pic_code, " Generate position-dependent machine code"; "-fthumb", Arg.Set thumb, " Enable Thumb/Thumb-2 code generation" ^ (if !thumb then " (default)" else ""); "-fno-thumb", Arg.Clear thumb, " Disable Thumb/Thumb-2 code generation" ^ (if not !thumb then " (default" else "")] (* Addressing modes *) type addressing_mode = Iindexed of int (* reg + displ *) (* We do not support the reg + shifted reg addressing mode, because what we really need is reg + shifted reg + displ, and this is decomposed in two instructions (reg + shifted reg -> tmp, then addressing tmp + displ). *) (* Specific operations *) type specific_operation = Ishiftarith of arith_operation * int | Ishiftcheckbound of int | Irevsubimm of int | Imuladd (* multiply and add *) | Imulsub (* multiply and subtract *) | Inegmulf (* floating-point negate and multiply *) | Imuladdf (* floating-point multiply and add *) | Inegmuladdf (* floating-point negate, multiply and add *) | Imulsubf (* floating-point multiply and subtract *) | Inegmulsubf (* floating-point negate, multiply and subtract *) | Isqrtf (* floating-point square root *) and arith_operation = Ishiftadd | Ishiftsub | Ishiftsubrev (* Sizes, endianness *) let big_endian = false let size_addr = 4 let size_int = 4 let size_float = 8 (* Behavior of division *) let division_crashes_on_overflow = false (* Operations on addressing modes *) let identity_addressing = Iindexed 0 let offset_addressing (Iindexed n) delta = Iindexed(n + delta) let num_args_addressing (Iindexed n) = 1 (* Printing operations and addressing modes *) let print_addressing printreg addr ppf arg = match addr with | Iindexed n -> printreg ppf arg.(0); if n <> 0 then fprintf ppf " + %i" n let print_specific_operation printreg op ppf arg = match op with | Ishiftarith(op, shift) -> let op_name = function | Ishiftadd -> "+" | Ishiftsub -> "-" | Ishiftsubrev -> "-rev" in let shift_mark = if shift >= 0 then sprintf "<< %i" shift else sprintf ">> %i" (-shift) in fprintf ppf "%a %s %a %s" printreg arg.(0) (op_name op) printreg arg.(1) shift_mark | Ishiftcheckbound n -> fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) | Irevsubimm n -> fprintf ppf "%i %s %a" n "-" printreg arg.(0) | Imuladd -> fprintf ppf "(%a * %a) + %a" printreg arg.(0) printreg arg.(1) printreg arg.(2) | Imulsub -> fprintf ppf "-(%a * %a) + %a" printreg arg.(0) printreg arg.(1) printreg arg.(2) | Inegmulf -> fprintf ppf "-f (%a *f %a)" printreg arg.(0) printreg arg.(1) | Imuladdf -> fprintf ppf "%a +f (%a *f %a)" printreg arg.(0) printreg arg.(1) printreg arg.(2) | Inegmuladdf -> fprintf ppf "%a -f (%a *f %a)" printreg arg.(0) printreg arg.(1) printreg arg.(2) | Imulsubf -> fprintf ppf "(-f %a) +f (%a *f %a)" printreg arg.(0) printreg arg.(1) printreg arg.(2) | Inegmulsubf -> fprintf ppf "(-f %a) -f (%a *f %a)" printreg arg.(0) printreg arg.(1) printreg arg.(2) | Isqrtf -> fprintf ppf "sqrtf %a" printreg arg.(0) (* Recognize immediate operands *) (* Immediate operands are 8-bit immediate values, zero-extended, and rotated right by 0 ... 30 bits. In Thumb/Thumb-2 mode we utilize 26 ... 30. *) let is_immediate n = let n = ref n in let s = ref 0 in let m = if !thumb then 24 else 30 in while (!s <= m && Int32.logand !n 0xffl <> !n) do n := Int32.logor (Int32.shift_right_logical !n 2) (Int32.shift_left !n 30); s := !s + 2 done; !s <= m mingw-ocaml/ocaml/asmcomp/arm/proc.ml0000644000175000017500000001624012124403240017173 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Benedikt Meurer, University of Siegen *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique *) (* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) (* reserved. This file is distributed under the terms of the Q *) (* Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Description of the ARM processor *) open Misc open Cmm open Reg open Arch open Mach (* Instruction selection *) let word_addressed = false (* Registers available for register allocation *) (* Integer register map: r0 - r3 general purpose (not preserved) r4 - r7 general purpose (preserved) r8 trap pointer (preserved) r9 platform register, usually reserved r10 allocation pointer (preserved) r11 allocation limit (preserved) r12 intra-procedural scratch register (not preserved) r13 stack pointer r14 return address r15 program counter Floatinng-point register map (VFPv3): d0 - d7 general purpose (not preserved) d8 - d15 general purpose (preserved) d16 - d31 generat purpose (not preserved), VFPv3 only *) let int_reg_name = [| "r0"; "r1"; "r2"; "r3"; "r4"; "r5"; "r6"; "r7"; "r12" |] let float_reg_name = [| "d0"; "d1"; "d2"; "d3"; "d4"; "d5"; "d6"; "d7"; "d8"; "d9"; "d10"; "d11"; "d12"; "d13"; "d14"; "d15"; "d16"; "d17"; "d18"; "d19"; "d20"; "d21"; "d22"; "d23"; "d24"; "d25"; "d26"; "d27"; "d28"; "d29"; "d30"; "d31" |] (* We have three register classes: 0 for integer registers 1 for VFPv3-D16 2 for VFPv3 This way we can choose between VFPv3-D16 and VFPv3 at (ocamlopt) runtime using command line switches. *) let num_register_classes = 3 let register_class r = match (r.typ, !fpu) with (Int | Addr), _ -> 0 | Float, VFPv3_D16 -> 1 | Float, _ -> 2 let num_available_registers = [| 9; 16; 32 |] let first_available_register = [| 0; 100; 100 |] let register_name r = if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) let rotate_registers = true (* Representation of hard registers by pseudo-registers *) let hard_int_reg = let v = Array.create 9 Reg.dummy in for i = 0 to 8 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = let v = Array.create 32 Reg.dummy in for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v let all_phys_regs = Array.append hard_int_reg hard_float_reg let phys_reg n = if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) let stack_slot slot ty = Reg.at_location ty (Stack slot) (* Calling conventions *) let calling_conventions first_int last_int first_float last_float make_stack arg = let loc = Array.create (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in for i = 0 to Array.length arg - 1 do match arg.(i).typ with Int | Addr as ty -> if !int <= last_int then begin loc.(i) <- phys_reg !int; incr int end else begin loc.(i) <- stack_slot (make_stack !ofs) ty; ofs := !ofs + size_int end | Float -> assert (abi = EABI_VFP); assert (!fpu >= VFPv3_D16); if !float <= last_float then begin loc.(i) <- phys_reg !float; incr float end else begin ofs := Misc.align !ofs size_float; loc.(i) <- stack_slot (make_stack !ofs) Float; ofs := !ofs + size_float end done; (loc, Misc.align !ofs 8) (* keep stack 8-aligned *) let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs let not_supported ofs = fatal_error "Proc.loc_results: cannot call" (* OCaml calling convention: first integer args in r0...r7 first float args in d0...d15 (EABI+VFP) remaining args on stack. Return values in r0...r7 or d0...d15. *) let loc_arguments arg = calling_conventions 0 7 100 115 outgoing arg let loc_parameters arg = let (loc, _) = calling_conventions 0 7 100 115 incoming arg in loc let loc_results res = let (loc, _) = calling_conventions 0 7 100 115 not_supported res in loc (* C calling convention: first integer args in r0...r3 first float args in d0...d7 (EABI+VFP) remaining args on stack. Return values in r0...r1 or d0. *) let loc_external_arguments arg = calling_conventions 0 3 100 107 outgoing arg let loc_external_results res = let (loc, _) = calling_conventions 0 1 100 100 not_supported res in loc let loc_exn_bucket = phys_reg 0 (* Registers destroyed by operations *) let destroyed_at_alloc = (* r0-r6, d0-d15 preserved *) Array.of_list (List.map phys_reg [7;8; 116;116;118;119;120;121;122;123; 124;125;126;127;128;129;130;131]) let destroyed_at_c_call = Array.of_list (List.map phys_reg (match abi with EABI -> (* r4-r7 preserved *) [0;1;2;3;8; 100;101;102;103;104;105;106;107; 108;109;110;111;112;113;114;115; 116;116;118;119;120;121;122;123; 124;125;126;127;128;129;130;131] | EABI_VFP -> (* r4-r7, d8-d15 preserved *) [0;1;2;3;8; 100;101;102;103;104;105;106;107; 116;116;118;119;120;121;122;123; 124;125;126;127;128;129;130;131])) let destroyed_at_oper = function Iop(Icall_ind | Icall_imm _ ) | Iop(Iextcall(_, true)) -> all_phys_regs | Iop(Iextcall(_, false)) -> destroyed_at_c_call | Iop(Ialloc n) -> destroyed_at_alloc | Iop(Iconst_symbol _) when !pic_code -> [|phys_reg 3; phys_reg 8|] (* r3 and r12 destroyed *) | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _)) -> [|phys_reg 107|] (* d7 (s14-s15) destroyed *) | _ -> [||] let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function Iextcall(_, _) -> 5 | _ -> 9 let max_register_pressure = function Iextcall(_, _) -> [| 5; 9; 9 |] | _ -> [| 9; 16; 32 |] (* Layout of the stack *) let num_stack_slots = [| 0; 0; 0 |] let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = Ccomp.command (Config.asm ^ " -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) mingw-ocaml/ocaml/asmcomp/arm/reload.ml0000644000175000017500000000162312124403240017475 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Reloading for the ARM *) let fundecl f = (new Reloadgen.reload_generic)#fundecl f mingw-ocaml/ocaml/asmcomp/arm/selection.ml0000644000175000017500000002422312124403240020215 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Benedikt Meurer, University of Siegen *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique *) (* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) (* reserved. This file is distributed under the terms of the Q *) (* Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Instruction selection for the ARM processor *) open Arch open Cmm open Mach open Misc open Proc open Reg let is_offset chunk n = match chunk with (* VFPv3 load/store have -1020 to 1020 *) Single | Double | Double_u when !fpu >= VFPv3_D16 -> n >= -1020 && n <= 1020 (* ARM load/store byte/word have -4095 to 4095 *) | Byte_unsigned | Byte_signed | Thirtytwo_unsigned | Thirtytwo_signed | Word | Single when not !thumb -> n >= -4095 && n <= 4095 (* Thumb-2 load/store have -255 to 4095 *) | _ when !arch > ARMv6 && !thumb -> n >= -255 && n <= 4095 (* Everything else has -255 to 255 *) | _ -> n >= -255 && n <= 255 let is_intconst = function Cconst_int _ -> true | _ -> false (* Special constraints on operand and result registers *) exception Use_default let r1 = phys_reg 1 let pseudoregs_for_operation op arg res = match op with (* For mul rd,rm,rs and mla rd,rm,rs,ra (pre-ARMv6) the registers rm and rd must be different. We deal with this by pretending that rm is also a result of the mul / mla operation. *) Iintop Imul | Ispecific Imuladd when !arch < ARMv6 -> (arg, [| res.(0); arg.(0) |]) (* Soft-float Iabsf and Inegf: arg.(0) and res.(0) must be the same *) | Iabsf | Inegf when !fpu = Soft -> ([|res.(0); arg.(1)|], res) (* VFPv3 Imuladdf...Inegmulsubf: arg.(0) and res.(0) must be the same *) | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) -> let arg' = Array.copy arg in arg'.(0) <- res.(0); (arg', res) (* We use __aeabi_idivmod for Cmodi only, and hence we care only for the remainder in r1, so fix up the destination register. *) | Iextcall("__aeabi_idivmod", false) -> (arg, [|r1|]) (* Other instructions are regular *) | _ -> raise Use_default (* Instruction selection *) class selector = object(self) inherit Selectgen.selector_generic as super method! regs_for tyv = Reg.createv (if !fpu = Soft then begin (* Expand floats into pairs of integer registers *) let rec expand = function [] -> [] | Float :: tyl -> Int :: Int :: expand tyl | ty :: tyl -> ty :: expand tyl in Array.of_list (expand (Array.to_list tyv)) end else begin tyv end) method is_immediate n = is_immediate (Int32.of_int n) method! is_simple_expr = function (* inlined floating-point ops are simple if their arguments are *) | Cop(Cextcall("sqrt", _, _, _), args) when !fpu >= VFPv3_D16 -> List.for_all self#is_simple_expr args | e -> super#is_simple_expr e method select_addressing chunk = function | Cop(Cadda, [arg; Cconst_int n]) when is_offset chunk n -> (Iindexed n, arg) | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) when is_offset chunk n -> (Iindexed n, Cop(Cadda, [arg1; arg2])) | arg -> (Iindexed 0, arg) method select_shift_arith op shiftop shiftrevop args = match args with [arg1; Cop(Clsl, [arg2; Cconst_int n])] when n > 0 && n < 32 && not(is_intconst arg2) -> (Ispecific(Ishiftarith(shiftop, n)), [arg1; arg2]) | [arg1; Cop(Casr, [arg2; Cconst_int n])] when n > 0 && n < 32 && not(is_intconst arg2) -> (Ispecific(Ishiftarith(shiftop, -n)), [arg1; arg2]) | [Cop(Clsl, [arg1; Cconst_int n]); arg2] when n > 0 && n < 32 && not(is_intconst arg1) -> (Ispecific(Ishiftarith(shiftrevop, n)), [arg2; arg1]) | [Cop(Casr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 32 && not(is_intconst arg1) -> (Ispecific(Ishiftarith(shiftrevop, -n)), [arg2; arg1]) | args -> begin match super#select_operation op args with (* Recognize multiply and add *) (Iintop Iadd, [Cop(Cmuli, args); arg3]) | (Iintop Iadd, [arg3; Cop(Cmuli, args)]) as op_args -> begin match self#select_operation Cmuli args with (Iintop Imul, [arg1; arg2]) -> (Ispecific Imuladd, [arg1; arg2; arg3]) | _ -> op_args end (* Recognize multiply and subtract *) | (Iintop Isub, [arg3; Cop(Cmuli, args)]) as op_args when !arch > ARMv6 -> begin match self#select_operation Cmuli args with (Iintop Imul, [arg1; arg2]) -> (Ispecific Imulsub, [arg1; arg2; arg3]) | _ -> op_args end | op_args -> op_args end method! select_operation op args = match (op, args) with (* Recognize special shift arithmetic *) ((Cadda | Caddi), [arg; Cconst_int n]) when n < 0 && self#is_immediate (-n) -> (Iintop_imm(Isub, -n), [arg]) | ((Cadda | Caddi as op), args) -> self#select_shift_arith op Ishiftadd Ishiftadd args | ((Csuba | Csubi), [arg; Cconst_int n]) when n < 0 && self#is_immediate (-n) -> (Iintop_imm(Iadd, -n), [arg]) | ((Csuba | Csubi), [Cconst_int n; arg]) when self#is_immediate n -> (Ispecific(Irevsubimm n), [arg]) | ((Csuba | Csubi as op), args) -> self#select_shift_arith op Ishiftsub Ishiftsubrev args | (Ccheckbound _, [Cop(Clsr, [arg1; Cconst_int n]); arg2]) when n > 0 && n < 32 && not(is_intconst arg2) -> (Ispecific(Ishiftcheckbound n), [arg1; arg2]) (* ARM does not support immediate operands for multiplication *) | (Cmuli, args) -> (Iintop Imul, args) (* Turn integer division/modulus into runtime ABI calls *) | (Cdivi, [arg; Cconst_int n]) when n = 1 lsl Misc.log2 n -> (Iintop_imm(Idiv, n), [arg]) | (Cdivi, args) -> (Iextcall("__aeabi_idiv", false), args) | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl Misc.log2 n -> (Iintop_imm(Imod, n), [arg]) | (Cmodi, args) -> (* See above for fix up of return register *) (Iextcall("__aeabi_idivmod", false), args) (* Turn floating-point operations into runtime ABI calls for softfp *) | (op, args) when !fpu = Soft -> self#select_operation_softfp op args (* Select operations for VFPv3 *) | (op, args) -> self#select_operation_vfpv3 op args method private select_operation_softfp op args = match (op, args) with (* Turn floating-point operations into runtime ABI calls *) | (Caddf, args) -> (Iextcall("__aeabi_dadd", false), args) | (Csubf, args) -> (Iextcall("__aeabi_dsub", false), args) | (Cmulf, args) -> (Iextcall("__aeabi_dmul", false), args) | (Cdivf, args) -> (Iextcall("__aeabi_ddiv", false), args) | (Cfloatofint, args) -> (Iextcall("__aeabi_i2d", false), args) | (Cintoffloat, args) -> (Iextcall("__aeabi_d2iz", false), args) | (Ccmpf comp, args) -> let func = (match comp with Cne (* there's no __aeabi_dcmpne *) | Ceq -> "__aeabi_dcmpeq" | Clt -> "__aeabi_dcmplt" | Cle -> "__aeabi_dcmple" | Cgt -> "__aeabi_dcmpgt" | Cge -> "__aeabi_dcmpge") in let comp = (match comp with Cne -> Ceq (* eq 0 => false *) | _ -> Cne (* ne 0 => true *)) in (Iintop_imm(Icomp(Iunsigned comp), 0), [Cop(Cextcall(func, typ_int, false, Debuginfo.none), args)]) (* Add coercions around loads and stores of 32-bit floats *) | (Cload Single, args) -> (Iextcall("__aeabi_f2d", false), [Cop(Cload Word, args)]) | (Cstore Single, [arg1; arg2]) -> let arg2' = Cop(Cextcall("__aeabi_d2f", typ_int, false, Debuginfo.none), [arg2]) in self#select_operation (Cstore Word) [arg1; arg2'] (* Other operations are regular *) | (op, args) -> super#select_operation op args method private select_operation_vfpv3 op args = match (op, args) with (* Recognize floating-point negate and multiply *) (Cnegf, [Cop(Cmulf, args)]) -> (Ispecific Inegmulf, args) (* Recognize floating-point multiply and add *) | (Caddf, [arg; Cop(Cmulf, args)]) | (Caddf, [Cop(Cmulf, args); arg]) -> (Ispecific Imuladdf, arg :: args) (* Recognize floating-point negate, multiply and subtract *) | (Csubf, [Cop(Cnegf, [arg]); Cop(Cmulf, args)]) | (Csubf, [Cop(Cnegf, [Cop(Cmulf, args)]); arg]) -> (Ispecific Inegmulsubf, arg :: args) (* Recognize floating-point negate, multiply and add *) | (Csubf, [arg; Cop(Cmulf, args)]) -> (Ispecific Inegmuladdf, arg :: args) (* Recognize multiply and subtract *) | (Csubf, [Cop(Cmulf, args); arg]) -> (Ispecific Imulsubf, arg :: args) (* Recognize floating-point square root *) | (Cextcall("sqrt", _, false, _), args) -> (Ispecific Isqrtf, args) (* Other operations are regular *) | (op, args) -> super#select_operation op args method! select_condition = function (* Turn floating-point comparisons into runtime ABI calls *) Cop(Ccmpf _ as op, args) when !fpu = Soft -> begin match self#select_operation_softfp op args with (Iintop_imm(Icomp(Iunsigned Ceq), 0), [arg]) -> (Ifalsetest, arg) | (Iintop_imm(Icomp(Iunsigned Cne), 0), [arg]) -> (Itruetest, arg) | _ -> assert false end | expr -> super#select_condition expr (* Deal with some register constraints *) method! insert_op_debug op dbg rs rd = try let (rsrc, rdst) = pseudoregs_for_operation op rs rd in self#insert_moves rs rsrc; self#insert_debug (Iop op) dbg rsrc rdst; self#insert_moves rdst rd; rd with Use_default -> super#insert_op_debug op dbg rs rd end let fundecl f = (new selector)#emit_fundecl f mingw-ocaml/ocaml/asmcomp/arm/emit.mlp0000644000175000017500000010431012124403240017342 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Benedikt Meurer, University of Siegen *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique *) (* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) (* reserved. This file is distributed under the terms of the Q *) (* Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Emission of ARM assembly code *) open Location open Misc open Cmm open Arch open Proc open Reg open Mach open Linearize open Emitaux (* Tradeoff between code size and code speed *) let fastcode_flag = ref true (* Output a label *) let emit_label lbl = emit_string ".L"; emit_int lbl let emit_data_label lbl = emit_string ".Ld"; emit_int lbl (* Symbols *) let emit_symbol s = Emitaux.emit_symbol '$' s let emit_call s = if !Clflags.dlcode || !pic_code then `bl {emit_symbol s}(PLT)` else `bl {emit_symbol s}` let emit_jump s = if !Clflags.dlcode || !pic_code then `b {emit_symbol s}(PLT)` else `b {emit_symbol s}` (* Output a pseudo-register *) let emit_reg = function {loc = Reg r} -> emit_string (register_name r) | _ -> fatal_error "Emit_arm.emit_reg" (* Layout of the stack frame *) let stack_offset = ref 0 let frame_size () = let sz = !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 8 * num_stack_slots.(2) + (if !contains_calls then 4 else 0) in Misc.align sz 8 let slot_offset loc cl = match loc with Incoming n -> assert (n >= 0); frame_size() + n | Local n -> if cl = 0 then !stack_offset + n * 4 else !stack_offset + num_stack_slots.(0) * 4 + n * 8 | Outgoing n -> assert (n >= 0); n (* Output a stack reference *) let emit_stack r = match r.loc with | Stack s -> let ofs = slot_offset s (register_class r) in `[sp, #{emit_int ofs}]` | _ -> fatal_error "Emit_arm.emit_stack" (* Output an addressing mode *) let emit_addressing addr r n = match addr with Iindexed ofs -> `[{emit_reg r.(n)}, #{emit_int ofs}]` (* Record live pointers at call points *) let record_frame_label live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter (function {typ = Addr; loc = Reg r} -> live_offset := ((r lsl 1) + 1) :: !live_offset | {typ = Addr; loc = Stack s} as reg -> live_offset := slot_offset s (register_class reg) :: !live_offset | _ -> ()) live; frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); fd_live_offset = !live_offset; fd_debuginfo = dbg } :: !frame_descriptors; lbl let record_frame live dbg = let lbl = record_frame_label live dbg in `{emit_label lbl}:` (* Record calls to the GC -- we've moved them out of the way *) type gc_call = { gc_lbl: label; (* Entry label *) gc_return_lbl: label; (* Where to branch after GC *) gc_frame_lbl: label } (* Label of frame descriptor *) let call_gc_sites = ref ([] : gc_call list) let emit_call_gc gc = `{emit_label gc.gc_lbl}: {emit_call "caml_call_gc"}\n`; `{emit_label gc.gc_frame_lbl}: b {emit_label gc.gc_return_lbl}\n` (* Record calls to caml_ml_array_bound_error. In debug mode, we maintain one call to caml_ml_array_bound_error per bound check site. Otherwise, we can share a single call. *) type bound_error_call = { bd_lbl: label; (* Entry label *) bd_frame_lbl: label } (* Label of frame descriptor *) let bound_error_sites = ref ([] : bound_error_call list) let bound_error_label dbg = if !Clflags.debug || !bound_error_sites = [] then begin let lbl_bound_error = new_label() in let lbl_frame = record_frame_label Reg.Set.empty dbg in bound_error_sites := { bd_lbl = lbl_bound_error; bd_frame_lbl = lbl_frame } :: !bound_error_sites; lbl_bound_error end else begin let bd = List.hd !bound_error_sites in bd.bd_lbl end let emit_call_bound_error bd = `{emit_label bd.bd_lbl}: {emit_call "caml_ml_array_bound_error"}\n`; `{emit_label bd.bd_frame_lbl}:\n` (* Negate a comparison *) let negate_integer_comparison = function Isigned cmp -> Isigned(negate_comparison cmp) | Iunsigned cmp -> Iunsigned(negate_comparison cmp) (* Names of various instructions *) let name_for_comparison = function Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le" | Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt" | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls" | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi" let name_for_int_operation = function Iadd -> "add" | Isub -> "sub" | Imul -> "mul" | Iand -> "and" | Ior -> "orr" | Ixor -> "eor" | _ -> assert false let name_for_shift_operation = function Ilsl -> "lsl" | Ilsr -> "lsr" | Iasr -> "asr" | _ -> assert false (* General functional to decompose a non-immediate integer constant into 8-bit chunks shifted left 0 ... 30 bits. *) let decompose_intconst n fn = let i = ref n in let shift = ref 0 in let ninstr = ref 0 in while !i <> 0l do if Int32.logand (Int32.shift_right !i !shift) 3l = 0l then shift := !shift + 2 else begin let bits = Int32.logand !i (Int32.shift_left 0xffl !shift) in i := Int32.sub !i bits; shift := !shift + 8; incr ninstr; fn bits end done; !ninstr (* Load an integer constant into a register *) let emit_intconst dst n = let nr = Int32.lognot n in if is_immediate n then begin (* Use movs here to enable 16-bit T1 encoding *) ` movs {emit_reg dst}, #{emit_int32 n}\n`; 1 end else if is_immediate nr then begin ` mvn {emit_reg dst}, #{emit_int32 nr}\n`; 1 end else if !arch > ARMv6 then begin let nl = Int32.logand 0xffffl n in let nh = Int32.logand 0xffffl (Int32.shift_right_logical n 16) in if nh = 0l then begin ` movw {emit_reg dst}, #{emit_int32 nl}\n`; 1 end else if Int32.logand nl 0xffl = nl then begin ` movs {emit_reg dst}, #{emit_int32 nl}\n`; ` movt {emit_reg dst}, #{emit_int32 nh}\n`; 2 end else begin ` movw {emit_reg dst}, #{emit_int32 nl}\n`; ` movt {emit_reg dst}, #{emit_int32 nh}\n`; 2 end end else begin let first = ref true in decompose_intconst n (fun bits -> if !first then ` mov {emit_reg dst}, #{emit_int32 bits} @ {emit_int32 n}\n` else ` add {emit_reg dst}, {emit_reg dst}, #{emit_int32 bits}\n`; first := false) end (* Adjust sp (up or down) by the given byte amount *) let emit_stack_adjustment n = if n = 0 then 0 else begin let instr = if n < 0 then "sub" else "add" in let ninstr = decompose_intconst (Int32.of_int (abs n)) (fun bits -> ` {emit_string instr} sp, sp, #{emit_int32 bits}\n`) in cfi_adjust_cfa_offset (-n); ninstr end (* Deallocate the stack frame before a return or tail call *) let output_epilogue f = let n = frame_size() in if n > 0 then begin let ninstr = emit_stack_adjustment n in let ninstr = ninstr + f () in (* reset CFA back cause function body may continue *) cfi_adjust_cfa_offset n; ninstr end else f () (* Name of current function *) let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 (* Pending floating-point literals *) let float_literals = ref ([] : (string * label) list) (* Pending relative references to the global offset table *) let gotrel_literals = ref ([] : (label * label) list) (* Pending symbol literals *) let symbol_literals = ref ([] : (string * label) list) (* Total space (in words) occupied by pending literals *) let num_literals = ref 0 (* Label a floating-point literal *) let float_literal f = try List.assoc f !float_literals with Not_found -> let lbl = new_label() in num_literals := !num_literals + 2; float_literals := (f, lbl) :: !float_literals; lbl (* Label a GOTREL literal *) let gotrel_literal l = let lbl = new_label() in num_literals := !num_literals + 1; gotrel_literals := (l, lbl) :: !gotrel_literals; lbl (* Label a symbol literal *) let symbol_literal s = try List.assoc s !symbol_literals with Not_found -> let lbl = new_label() in num_literals := !num_literals + 1; symbol_literals := (s, lbl) :: !symbol_literals; lbl (* Emit all pending literals *) let emit_literals() = if !float_literals <> [] then begin ` .align 3\n`; List.iter (fun (f, lbl) -> `{emit_label lbl}: .double {emit_string f}\n`) !float_literals; float_literals := [] end; if !symbol_literals <> [] then begin let offset = if !thumb then 4 else 8 in let suffix = if !pic_code then "(GOT)" else "" in ` .align 2\n`; List.iter (fun (l, lbl) -> `{emit_label lbl}: .word _GLOBAL_OFFSET_TABLE_-({emit_label l}+{emit_int offset})\n`) !gotrel_literals; List.iter (fun (s, lbl) -> `{emit_label lbl}: .word {emit_symbol s}{emit_string suffix}\n`) !symbol_literals; gotrel_literals := []; symbol_literals := [] end; num_literals := 0 (* Emit code to load the address of a symbol *) let emit_load_symbol_addr dst s = if !pic_code then begin let lbl_pic = new_label() in let lbl_got = gotrel_literal lbl_pic in let lbl_sym = symbol_literal s in (* Both r3 and r12 are marked as clobbered in PIC mode (cf. proc.ml), so use r12 as temporary scratch register unless the destination is r12, then we use r3 instead. *) let tmp = if dst.loc = Reg 8 (*r12*) then phys_reg 3 (*r3*) else phys_reg 8 (*r12*) in ` ldr {emit_reg tmp}, {emit_label lbl_got}\n`; ` ldr {emit_reg dst}, {emit_label lbl_sym}\n`; `{emit_label lbl_pic}: add {emit_reg tmp}, pc, {emit_reg tmp}\n`; ` ldr {emit_reg dst}, [{emit_reg tmp}, {emit_reg dst}] @ {emit_symbol s}\n`; 4 end else if !arch > ARMv6 && not !Clflags.dlcode && !fastcode_flag then begin ` movw {emit_reg dst}, #:lower16:{emit_symbol s}\n`; ` movt {emit_reg dst}, #:upper16:{emit_symbol s}\n`; 2 end else begin let lbl = symbol_literal s in ` ldr {emit_reg dst}, {emit_label lbl} @ {emit_symbol s}\n`; 1 end (* Output the assembly code for an instruction *) let emit_instr i = emit_debug_info i.dbg; match i.desc with Lend -> 0 | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc = dst.loc then 0 else begin begin match (src, dst) with {loc = Reg _; typ = Float}, {loc = Reg _} -> ` fcpyd {emit_reg dst}, {emit_reg src}\n` | {loc = Reg _}, {loc = Reg _} -> ` mov {emit_reg dst}, {emit_reg src}\n` | {loc = Reg _; typ = Float}, _ -> ` fstd {emit_reg src}, {emit_stack dst}\n` | {loc = Reg _}, _ -> ` str {emit_reg src}, {emit_stack dst}\n` | {typ = Float}, _ -> ` fldd {emit_reg dst}, {emit_stack src}\n` | _ -> ` ldr {emit_reg dst}, {emit_stack src}\n` end; 1 end | Lop(Iconst_int n) -> emit_intconst i.res.(0) (Nativeint.to_int32 n) | Lop(Iconst_float f) when !fpu = Soft -> ` @ {emit_string f}\n`; let bits = Int64.bits_of_float (float_of_string f) in let high_bits = Int64.to_int32 (Int64.shift_right_logical bits 32) and low_bits = Int64.to_int32 bits in if is_immediate low_bits || is_immediate high_bits then begin let ninstr_low = emit_intconst i.res.(0) low_bits and ninstr_high = emit_intconst i.res.(1) high_bits in ninstr_low + ninstr_high end else begin let lbl = float_literal f in ` ldr {emit_reg i.res.(0)}, {emit_label lbl}\n`; ` ldr {emit_reg i.res.(1)}, {emit_label lbl} + 4\n`; 2 end | Lop(Iconst_float f) -> let encode imm = let sg = Int64.to_int (Int64.shift_right_logical imm 63) in let ex = Int64.to_int (Int64.shift_right_logical imm 52) in let ex = (ex land 0x7ff) - 1023 in let mn = Int64.logand imm 0xfffffffffffffL in if Int64.logand mn 0xffffffffffffL <> 0L || ex < -3 || ex > 4 then None else begin let mn = Int64.to_int (Int64.shift_right_logical mn 48) in if mn land 0x0f <> mn then None else let ex = ((ex + 3) land 0x07) lxor 0x04 in Some((sg lsl 7) lor (ex lsl 4) lor mn) end in begin match encode (Int64.bits_of_float (float_of_string f)) with None -> let lbl = float_literal f in ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n` | Some imm8 -> ` fconstd {emit_reg i.res.(0)}, #{emit_int imm8} @ {emit_string f}\n` end; 1 | Lop(Iconst_symbol s) -> emit_load_symbol_addr i.res.(0) s | Lop(Icall_ind) -> if !arch >= ARMv5 then begin ` blx {emit_reg i.arg.(0)}\n`; `{record_frame i.live i.dbg}\n`; 1 end else begin ` mov lr, pc\n`; ` bx {emit_reg i.arg.(0)}\n`; `{record_frame i.live i.dbg}\n`; 2 end | Lop(Icall_imm s) -> ` {emit_call s}\n`; `{record_frame i.live i.dbg}\n`; 1 | Lop(Itailcall_ind) -> output_epilogue begin fun () -> if !contains_calls then ` ldr lr, [sp, #{emit_int (-4)}]\n`; ` bx {emit_reg i.arg.(0)}\n`; 2 end | Lop(Itailcall_imm s) -> if s = !function_name then begin ` b {emit_label !tailrec_entry_point}\n`; 1 end else begin output_epilogue begin fun () -> if !contains_calls then ` ldr lr, [sp, #{emit_int (-4)}]\n`; ` {emit_jump s}\n`; 2 end end | Lop(Iextcall(s, false)) -> ` {emit_call s}\n`; 1 | Lop(Iextcall(s, true)) -> let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) s in ` {emit_call "caml_c_call"}\n`; `{record_frame i.live i.dbg}\n`; 1 + ninstr | Lop(Istackoffset n) -> assert (n mod 8 = 0); let ninstr = emit_stack_adjustment (-n) in stack_offset := !stack_offset + n; ninstr | Lop(Iload(Single, addr)) when !fpu >= VFPv3_D16 -> ` flds s14, {emit_addressing addr i.arg 0}\n`; ` fcvtds {emit_reg i.res.(0)}, s14\n`; 2 | Lop(Iload((Double | Double_u), addr)) when !fpu = Soft -> (* Use LDM or LDRD if possible *) begin match i.res.(0), i.res.(1), addr with {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0 when rt < rt2 -> ` ldm {emit_reg i.arg.(0)}, \{{emit_reg i.res.(0)}, {emit_reg i.res.(1)}}\n`; 1 | {loc = Reg rt}, {loc = Reg rt2}, addr when !arch >= ARMv5TE && rt mod 2 == 0 && rt2 = rt + 1 -> ` ldrd {emit_reg i.res.(0)}, {emit_reg i.res.(1)}, {emit_addressing addr i.arg 0}\n`; 1 | _ -> let addr' = offset_addressing addr 4 in if i.res.(0).loc <> i.arg.(0).loc then begin ` ldr {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`; ` ldr {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n` end else begin ` ldr {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n`; ` ldr {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n` end; 2 end | Lop(Iload(size, addr)) -> let r = i.res.(0) in let instr = match size with Byte_unsigned -> "ldrb" | Byte_signed -> "ldrsb" | Sixteen_unsigned -> "ldrh" | Sixteen_signed -> "ldrsh" | Double | Double_u -> "fldd" | _ (* 32-bit quantities *) -> "ldr" in ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`; 1 | Lop(Istore(Single, addr)) when !fpu >= VFPv3_D16 -> ` fcvtsd s14, {emit_reg i.arg.(0)}\n`; ` fsts s14, {emit_addressing addr i.arg 1}\n`; 2 | Lop(Istore((Double | Double_u), addr)) when !fpu = Soft -> (* Use STM or STRD if possible *) begin match i.arg.(0), i.arg.(1), addr with {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0 when rt < rt2 -> ` stm {emit_reg i.arg.(2)}, \{{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}}\n`; 1 | {loc = Reg rt}, {loc = Reg rt2}, addr when !arch >= ARMv5TE && rt mod 2 == 0 && rt2 = rt + 1 -> ` strd {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_addressing addr i.arg 2}\n`; 1 | _ -> let addr' = offset_addressing addr 4 in ` str {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 2}\n`; ` str {emit_reg i.arg.(1)}, {emit_addressing addr' i.arg 2}\n`; 2 end | Lop(Istore(size, addr)) -> let r = i.arg.(0) in let instr = match size with Byte_unsigned | Byte_signed -> "strb" | Sixteen_unsigned | Sixteen_signed -> "strh" | Double | Double_u -> "fstd" | _ (* 32-bit quantities *) -> "str" in ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 1}\n`; 1 | Lop(Ialloc n) -> let lbl_frame = record_frame_label i.live i.dbg in if !fastcode_flag then begin let lbl_redo = new_label() in `{emit_label lbl_redo}:`; let ninstr = decompose_intconst (Int32.of_int n) (fun i -> ` sub alloc_ptr, alloc_ptr, #{emit_int32 i}\n`) in ` cmp alloc_ptr, alloc_limit\n`; ` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; let lbl_call_gc = new_label() in ` bcc {emit_label lbl_call_gc}\n`; call_gc_sites := { gc_lbl = lbl_call_gc; gc_return_lbl = lbl_redo; gc_frame_lbl = lbl_frame } :: !call_gc_sites; 3 + ninstr end else begin let ninstr = begin match n with 8 -> ` {emit_call "caml_alloc1"}\n`; 1 | 12 -> ` {emit_call "caml_alloc2"}\n`; 1 | 16 -> ` {emit_call "caml_alloc3"}\n`; 1 | _ -> let ninstr = emit_intconst (phys_reg 7) (Int32.of_int n) in ` {emit_call "caml_allocN"}\n`; 1 + ninstr end in `{emit_label lbl_frame}: add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; 1 + ninstr end | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> let shift = name_for_shift_operation op in ` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} {emit_reg i.arg.(1)}\n`; 1 | Lop(Iintop(Icomp cmp)) -> let compthen = name_for_comparison cmp in let compelse = name_for_comparison (negate_integer_comparison cmp) in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` ite {emit_string compthen}\n`; ` mov{emit_string compthen} {emit_reg i.res.(0)}, #1\n`; ` mov{emit_string compelse} {emit_reg i.res.(0)}, #0\n`; 4 | Lop(Iintop_imm(Icomp cmp, n)) -> let compthen = name_for_comparison cmp in let compelse = name_for_comparison (negate_integer_comparison cmp) in ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; ` ite {emit_string compthen}\n`; ` mov{emit_string compthen} {emit_reg i.res.(0)}, #1\n`; ` mov{emit_string compelse} {emit_reg i.res.(0)}, #0\n`; 4 | Lop(Iintop Icheckbound) -> let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` bls {emit_label lbl}\n`; 2 | Lop(Iintop_imm(Icheckbound, n)) -> let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; ` bls {emit_label lbl}\n`; 2 | Lop(Ispecific(Ishiftcheckbound shift)) -> let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; ` bcs {emit_label lbl}\n`; 2 | Lop(Iintop op) -> let instr = name_for_int_operation op in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 | Lop(Iintop_imm(Idiv, n)) -> (* n is a power of 2 *) let l = Misc.log2 n in let r = i.res.(0) in ` movs {emit_reg r}, {emit_reg i.arg.(0)}\n`; if n <= 256 then begin ` it lt\n`; ` addlt {emit_reg r}, {emit_reg r}, #{emit_int (n-1)}\n` end else begin ` itt lt\n`; ` addlt {emit_reg r}, {emit_reg r}, #{emit_int n}\n`; ` sublt {emit_reg r}, {emit_reg r}, #1\n` end; ` mov {emit_reg r}, {emit_reg r}, asr #{emit_int l}\n`; 5 | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *) let l = Misc.log2 n in let a = i.arg.(0) in let r = i.res.(0) in let lbl = new_label() in ` cmp {emit_reg a}, #0\n`; ` mov {emit_reg r}, {emit_reg a}, lsl #{emit_int (32-l)}\n`; ` mov {emit_reg r}, {emit_reg r}, lsr #{emit_int (32-l)}\n`; ` bpl {emit_label lbl}\n`; ` cmp {emit_reg r}, #0\n`; ` it ne\n`; ` subne {emit_reg r}, {emit_reg r}, #{emit_int n}\n`; `{emit_label lbl}:\n`; 7 | Lop(Iintop_imm((Ilsl | Ilsr | Iasr as op), n)) -> let shift = name_for_shift_operation op in ` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} #{emit_int n}\n`; 1 | Lop(Iintop_imm(op, n)) -> let instr = name_for_int_operation op in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 | Lop(Iabsf | Inegf as op) when !fpu = Soft -> let instr = (match op with Iabsf -> "bic" | Inegf -> "eor" | _ -> assert false) in ` {emit_string instr} {emit_reg i.res.(1)}, {emit_reg i.arg.(1)}, #0x80000000\n`; 1 | Lop(Iabsf | Inegf | Ispecific Isqrtf as op) -> let instr = (match op with Iabsf -> "fabsd" | Inegf -> "fnegd" | Ispecific Isqrtf -> "fsqrtd" | _ -> assert false) in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`; 1 | Lop(Ifloatofint) -> ` fmsr s14, {emit_reg i.arg.(0)}\n`; ` fsitod {emit_reg i.res.(0)}, s14\n`; 2 | Lop(Iintoffloat) -> ` ftosizd s14, {emit_reg i.arg.(0)}\n`; ` fmrs {emit_reg i.res.(0)}, s14\n`; 2 | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf as op) -> let instr = (match op with Iaddf -> "faddd" | Isubf -> "fsubd" | Imulf -> "fmuld" | Idivf -> "fdivd" | Ispecific Inegmulf -> "fnmuld" | _ -> assert false) in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 | Lop(Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf as op)) -> let instr = (match op with Imuladdf -> "fmacd" | Inegmuladdf -> "fnmacd" | Imulsubf -> "fmscd" | Inegmulsubf -> "fnmscd" | _ -> assert false) in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`; 1 | Lop(Ispecific(Ishiftarith(op, shift))) -> let instr = (match op with Ishiftadd -> "add" | Ishiftsub -> "sub" | Ishiftsubrev -> "rsb") in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`; if shift >= 0 then `, lsl #{emit_int shift}\n` else `, asr #{emit_int (-shift)}\n`; 1 | Lop(Ispecific(Irevsubimm n)) -> ` rsb {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 | Lop(Ispecific(Imuladd | Imulsub as op)) -> let instr = (match op with Imuladd -> "mla" | Imulsub -> "mls" | _ -> assert false) in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`; 1 | Lreloadretaddr -> let n = frame_size() in ` ldr lr, [sp, #{emit_int(n-4)}]\n`; 1 | Lreturn -> output_epilogue begin fun () -> ` bx lr\n`; 1 end | Llabel lbl -> `{emit_label lbl}:\n`; 0 | Lbranch lbl -> ` b {emit_label lbl}\n`; 1 | Lcondbranch(tst, lbl) -> begin match tst with Itruetest -> ` cmp {emit_reg i.arg.(0)}, #0\n`; ` bne {emit_label lbl}\n`; 2 | Ifalsetest -> ` cmp {emit_reg i.arg.(0)}, #0\n`; ` beq {emit_label lbl}\n`; 2 | Iinttest cmp -> ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; let comp = name_for_comparison cmp in ` b{emit_string comp} {emit_label lbl}\n`; 2 | Iinttest_imm(cmp, n) -> ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; let comp = name_for_comparison cmp in ` b{emit_string comp} {emit_label lbl}\n`; 2 | Ifloattest(cmp, neg) -> let comp = (match (cmp, neg) with (Ceq, false) | (Cne, true) -> "eq" | (Cne, false) | (Ceq, true) -> "ne" | (Clt, false) -> "cc" | (Clt, true) -> "cs" | (Cle, false) -> "ls" | (Cle, true) -> "hi" | (Cgt, false) -> "gt" | (Cgt, true) -> "le" | (Cge, false) -> "ge" | (Cge, true) -> "lt") in ` fcmpd {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` fmstat\n`; ` b{emit_string comp} {emit_label lbl}\n`; 3 | Ioddtest -> ` tst {emit_reg i.arg.(0)}, #1\n`; ` bne {emit_label lbl}\n`; 2 | Ieventest -> ` tst {emit_reg i.arg.(0)}, #1\n`; ` beq {emit_label lbl}\n`; 2 end | Lcondbranch3(lbl0, lbl1, lbl2) -> ` cmp {emit_reg i.arg.(0)}, #1\n`; begin match lbl0 with None -> () | Some lbl -> ` blt {emit_label lbl}\n` end; begin match lbl1 with None -> () | Some lbl -> ` beq {emit_label lbl}\n` end; begin match lbl2 with None -> () | Some lbl -> ` bgt {emit_label lbl}\n` end; 4 | Lswitch jumptbl -> if !arch > ARMv6 && !thumb then begin (* The Thumb-2 TBH instruction supports only forward branches, so we need to generate appropriate trampolines for all labels that appear before this switch instruction (PR#5623) *) let tramtbl = Array.copy jumptbl in ` tbh [pc, {emit_reg i.arg.(0)}, lsl #1]\n`; for j = 0 to Array.length tramtbl - 1 do let rec label i = match i.desc with Lend -> new_label() | Llabel lbl when lbl = tramtbl.(j) -> lbl | _ -> label i.next in tramtbl.(j) <- label i.next; ` .short ({emit_label tramtbl.(j)}-.)/2+{emit_int j}\n` done; (* Generate the necessary trampolines *) for j = 0 to Array.length tramtbl - 1 do if tramtbl.(j) <> jumptbl.(j) then `{emit_label tramtbl.(j)}: b {emit_label jumptbl.(j)}\n` done end else if not !pic_code then begin ` ldr pc, [pc, {emit_reg i.arg.(0)}, lsl #2]\n`; ` nop\n`; for j = 0 to Array.length jumptbl - 1 do ` .word {emit_label jumptbl.(j)}\n` done end else begin (* Slightly slower, but position-independent *) ` add pc, pc, {emit_reg i.arg.(0)}, lsl #2\n`; ` nop\n`; for j = 0 to Array.length jumptbl - 1 do ` b {emit_label jumptbl.(j)}\n` done end; 2 + Array.length jumptbl | Lsetuptrap lbl -> ` bl {emit_label lbl}\n`; 1 | Lpushtrap -> stack_offset := !stack_offset + 8; ` push \{trap_ptr, lr}\n`; cfi_adjust_cfa_offset 8; ` mov trap_ptr, sp\n`; 2 | Lpoptrap -> ` pop \{trap_ptr, lr}\n`; cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset - 8; 1 | Lraise -> if !Clflags.debug then begin ` {emit_call "caml_raise_exn"}\n`; `{record_frame Reg.Set.empty i.dbg}\n`; 1 end else begin ` mov sp, trap_ptr\n`; ` pop \{trap_ptr, pc}\n`; 2 end (* Emission of an instruction sequence *) let rec emit_all ninstr i = if i.desc = Lend then () else begin let n = emit_instr i in let ninstr' = ninstr + n in (* fldd can address up to +/-1KB, ldr can address up to +/-4KB *) let limit = (if !fpu >= VFPv3_D16 && !float_literals <> [] then 127 else 511) in let limit = limit - !num_literals in if ninstr' >= limit - 64 && not(has_fallthrough i.desc) then begin emit_literals(); emit_all 0 i.next end else if !num_literals != 0 && ninstr' >= limit then begin let lbl = new_label() in ` b {emit_label lbl}\n`; emit_literals(); `{emit_label lbl}:\n`; emit_all 0 i.next end else emit_all ninstr' i.next end (* Emission of the profiling prelude *) let emit_profile() = match Config.system with "linux_eabi" | "linux_eabihf" -> ` push \{lr}\n`; ` {emit_call "__gnu_mcount_nc"}\n` | _ -> () (* Emission of a function declaration *) let fundecl fundecl = function_name := fundecl.fun_name; fastcode_flag := fundecl.fun_fast; tailrec_entry_point := new_label(); float_literals := []; gotrel_literals := []; symbol_literals := []; stack_offset := 0; call_gc_sites := []; bound_error_sites := []; ` .text\n`; ` .align 2\n`; ` .globl {emit_symbol fundecl.fun_name}\n`; if !arch > ARMv6 && !thumb then ` .thumb\n` else ` .arm\n`; ` .type {emit_symbol fundecl.fun_name}, %function\n`; `{emit_symbol fundecl.fun_name}:\n`; emit_debug_info fundecl.fun_dbg; cfi_startproc(); if !Clflags.gprofile then emit_profile(); let n = frame_size() in if n > 0 then begin ignore(emit_stack_adjustment (-n)); if !contains_calls then ` str lr, [sp, #{emit_int(n - 4)}]\n` end; `{emit_label !tailrec_entry_point}:\n`; emit_all 0 fundecl.fun_body; emit_literals(); List.iter emit_call_gc !call_gc_sites; List.iter emit_call_bound_error !bound_error_sites; cfi_endproc(); ` .type {emit_symbol fundecl.fun_name}, %function\n`; ` .size {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n` (* Emission of data *) let emit_item = function Cglobal_symbol s -> ` .globl {emit_symbol s}\n`; | Cdefine_symbol s -> `{emit_symbol s}:\n` | Cdefine_label lbl -> `{emit_data_label lbl}:\n` | Cint8 n -> ` .byte {emit_int n}\n` | Cint16 n -> ` .short {emit_int n}\n` | Cint32 n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` | Cint n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` | Csingle f -> ` .single {emit_string f}\n` | Cdouble f -> ` .double {emit_string f}\n` | Csymbol_address s -> ` .word {emit_symbol s}\n` | Clabel_address lbl -> ` .word {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s | Cskip n -> if n > 0 then ` .space {emit_int n}\n` | Calign n -> ` .align {emit_int(Misc.log2 n)}\n` let data l = ` .data\n`; List.iter emit_item l (* Beginning / end of an assembly file *) let begin_assembly() = reset_debug_info(); ` .syntax unified\n`; begin match !arch with | ARMv4 -> ` .arch armv4t\n` | ARMv5 -> ` .arch armv5t\n` | ARMv5TE -> ` .arch armv5te\n` | ARMv6 -> ` .arch armv6\n` | ARMv6T2 -> ` .arch armv6t2\n` | ARMv7 -> ` .arch armv7-a\n` end; begin match !fpu with Soft -> ` .fpu softvfp\n` | VFPv3_D16 -> ` .fpu vfpv3-d16\n` | VFPv3 -> ` .fpu vfpv3\n` end; `trap_ptr .req r8\n`; `alloc_ptr .req r10\n`; `alloc_limit .req r11\n`; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ` .data\n`; ` .globl {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin}:\n`; let lbl_begin = Compilenv.make_symbol (Some "code_begin") in ` .text\n`; ` .globl {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin}:\n` let end_assembly () = let lbl_end = Compilenv.make_symbol (Some "code_end") in ` .text\n`; ` .globl {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end}:\n`; let lbl_end = Compilenv.make_symbol (Some "data_end") in ` .data\n`; ` .globl {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end}:\n`; ` .long 0\n`; let lbl = Compilenv.make_symbol (Some "frametable") in ` .globl {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; emit_frames { efa_label = (fun lbl -> ` .type {emit_label lbl}, %function\n`; ` .word {emit_label lbl}\n`); efa_16 = (fun n -> ` .short {emit_int n}\n`); efa_32 = (fun n -> ` .long {emit_int32 n}\n`); efa_word = (fun n -> ` .word {emit_int n}\n`); efa_align = (fun n -> ` .align {emit_int(Misc.log2 n)}\n`); efa_label_rel = (fun lbl ofs -> ` .word {emit_label lbl} - . + {emit_int32 ofs}\n`); efa_def_label = (fun lbl -> `{emit_label lbl}:\n`); efa_string = (fun s -> emit_string_directive " .asciz " s) }; ` .type {emit_symbol lbl}, %object\n`; ` .size {emit_symbol lbl}, .-{emit_symbol lbl}\n`; begin match Config.system with "linux_eabihf" | "linux_eabi" -> (* Mark stack as non-executable *) ` .section .note.GNU-stack,\"\",%progbits\n` | _ -> () end mingw-ocaml/ocaml/asmcomp/reloadgen.mli0000644000175000017500000000256012124403240017562 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) class reload_generic : object method reload_operation : Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array * Reg.t array method reload_test : Mach.test -> Reg.t array -> Reg.t array (* Can be overridden to reflect instructions that can operate directly on stack locations *) method makereg : Reg.t -> Reg.t (* Can be overridden to avoid creating new registers of some class (i.e. if all "registers" of that class are actually on stack) *) method fundecl : Mach.fundecl -> Mach.fundecl * bool (* The entry point *) end mingw-ocaml/ocaml/asmcomp/printclambda.ml0000644000175000017500000001235712124403240020116 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) open Format open Asttypes open Clambda open Debuginfo let rec pr_idents ppf = function | [] -> () | h::t -> fprintf ppf "%a %a" Ident.print h pr_idents t let rec lam ppf = function | Uvar id -> Ident.print ppf id | Uconst (cst,_) -> Printlambda.structured_constant ppf cst | Udirect_apply(f, largs, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(apply*@ %s %a)@]" f lams largs | Ugeneric_apply(lfun, largs, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs | Uclosure(clos, fv) -> let idents ppf = List.iter (fprintf ppf "@ %a" Ident.print)in let one_fun ppf f = fprintf ppf "(fun@ %s@ %d @[<2>%a@] @[<2>%a@])" f.label f.arity idents f.params lam f.body in let funs ppf = List.iter (fprintf ppf "@ %a" one_fun) in let lams ppf = List.iter (fprintf ppf "@ %a" lam) in fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i | Ulet(id, arg, body) -> let rec letbody ul = match ul with | Ulet(id, arg, body) -> fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg; letbody body | _ -> ul in fprintf ppf "@[<2>(let@ @[(@[<2>%a@ %a@]" Ident.print id lam arg; let expr = letbody body in fprintf ppf ")@]@ %a)@]" lam expr | Uletrec(id_arg_list, body) -> let bindings ppf id_arg_list = let spc = ref false in List.iter (fun (id, l) -> if !spc then fprintf ppf "@ " else spc := true; fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l) id_arg_list in fprintf ppf "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body | Uprim(prim, largs, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim lams largs | Uswitch(larg, sw) -> let switch ppf sw = let spc = ref false in for i = 0 to Array.length sw.us_index_consts - 1 do let n = sw.us_index_consts.(i) and l = sw.us_actions_consts.(i) in if !spc then fprintf ppf "@ " else spc := true; fprintf ppf "@[case int %i:@ %a@]" n lam l; done; for i = 0 to Array.length sw.us_index_blocks - 1 do let n = sw.us_index_blocks.(i) and l = sw.us_actions_blocks.(i) in if !spc then fprintf ppf "@ " else spc := true; fprintf ppf "@[case tag %i:@ %a@]" n lam l; done in fprintf ppf "@[<1>(switch %a@ @[%a@])@]" lam larg switch sw | Ustaticfail (i, ls) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls; | Ucatch(i, vars, lbody, lhandler) -> fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" lam lbody i (fun ppf vars -> match vars with | [] -> () | _ -> List.iter (fun x -> fprintf ppf " %a" Ident.print x) vars) vars lam lhandler | Utrywith(lbody, param, lhandler) -> fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" lam lbody Ident.print param lam lhandler | Uifthenelse(lcond, lif, lelse) -> fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse | Usequence(l1, l2) -> fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 | Uwhile(lcond, lbody) -> fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody | Ufor(param, lo, hi, dir, body) -> fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" Ident.print param lam lo (match dir with Upto -> "to" | Downto -> "downto") lam hi lam body | Uassign(id, expr) -> fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr | Usend (k, met, obj, largs, _) -> let args ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in let kind = if k = Lambda.Self then "self" else if k = Lambda.Cached then "cache" else "" in fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs and sequence ppf ulam = match ulam with | Usequence(l1, l2) -> fprintf ppf "%a@ %a" sequence l1 sequence l2 | _ -> lam ppf ulam let clambda = lam mingw-ocaml/ocaml/compilerlibs/0000755000175000017500000000000012124403240016141 5ustar tootstootsmingw-ocaml/ocaml/compilerlibs/.gitignore0000644000175000017500000000000012124403240020117 0ustar tootstootsmingw-ocaml/ocaml/README.win320000644000175000017500000004170012124403240015300 0ustar tootstoots Release notes on the MS Windows ports of OCaml ---------------------------------------------- There are no less than four ports of OCaml for MS Windows available: - a native Win32 port, built with the Microsoft development tools; - a native Win32 port, built with the 32-bit version of the gcc compiler from the mingw-w64 project, packaged in Cygwin (under the name mingw64-i686); - a port consisting of the Unix sources compiled under the Cygwin Unix-like environment for Windows; - a native Win64 port (64-bit Windows), built with the Microsoft development tools. Here is a summary of the main differences between these ports: Native MS Native MinGW Cygwin 64 bits? Win32 or Win64 Win32 only Win32 only Third-party software required - for base bytecode system none none none - for ocamlc -custom MSVC Cygwin Cygwin - for native-code generation MSVC+MASM Cygwin Cygwin Speed of bytecode interpreter 70% 100% 100% Replay debugger yes (**) yes (**) yes The Unix library partial partial full The Threads library yes yes yes The Graphics library yes yes no Restrictions on generated executables? none none yes (*) (*) Cygwin-generated .exe files refer to a DLL that is distributed under the GPL. Thus, these .exe files can only be distributed under a license that is compatible with the GPL. Executables generated by MSVC or by MinGW have no such restrictions. (**) The debugger is supported but the "replay" functions are not enabled. Other functions are available (step, goto, run...). The remainder of this document gives more information on each port. ------------------------------------------------------------------------------ The native Win32 port built with Microsoft Windows SDK ------------------------------------------------------ REQUIREMENTS: This port runs under MS Windows 7 (32 and 64 bits), Vista, XP, and 2000. The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) runs without any additional tools. The native-code compiler (ocamlopt) requires the Microsoft Windows SDK (item [1]) and the flexdll tool (item [2]). Statically linking OCaml bytecode with C code (ocamlc -custom) also requires items [1] and [2]. The LablTk GUI requires Tcl/Tk 8.5 (item [3]). INSTALLATION: The binary distribution is a self-installing executable archive. Just run it and it should install OCaml automatically. To run programs that use the LablTK GUI, the directory where the DLLs tk85.dll and tcl85.dll were installed (by the Tcl/Tk installer) must be added to the PATH environment variable. To compile programs that use the LablTK GUI, the directory where the libraries tk85.lib and tcl85.lib were installed (by the Tcl/Tk installer) must be added to the library search path in the LIB environment variable. E.g. if Tcl/Tk was installed in C:\Tcl, add "C:\Tcl\lib" to the LIB environment variable. THIRD-PARTY SOFTWARE: [1] Microsoft Windows SDK for Windows 7 and .NET Framework 3.5 Service Pack 1. Can be downloaded for free from http://www.microsoft.com/downloads/en/default.aspx under the name "Microsoft Windows 7 SDK". [2] flexdll version 0.29 or later. Can be downloaded from http://alain.frisch.fr/flexdll.html [3] TCL/TK version 8.5. Windows binaries are available as part of the ActiveTCL distribution at http://www.activestate.com/activetcl/downloads RECOMPILATION FROM THE SOURCES: The command-line tools can be recompiled from the Unix source distribution (ocaml-X.YY.Z.tar.gz), which also contains the files modified for Windows. You will need the following software components to perform the recompilation: - Windows NT, 2000, XP, Vista, or 7 (32 or 64 bits). - Items [1], [2] and [3] from the list of recommended software above. Make sure to install the 32-bit version of TCL/TK, even if you are compiling on a 64-bit Windows. - The Cygwin port of GNU tools, available from http://www.cygwin.com/ Install at least the following packages (and their dependencies): diffutils, make, ncurses. First, you need to set up your cygwin environment for using the MS tools. The following assumes that you have installed [1], [2], and [3] in their default directories. If this is not the case, you will need to adjust the paths accordingly. Open a Windows Command Prompt and enter the following command: set PFPATH=C:\Program Files If you are compiling on the 64-bit version of Windows 7, enter the following instead: set PFPATH=C:\Program Files (x86) Then enter the following commands: cd "%PFPATH%\Microsoft Visual Studio 9.0\VC\bin" set FLEXDLLDIR=%PFPATH%\flexdll vcvars32 echo VCPATH="`cygpath -p '%Path%'`" >C:\cygwin\tmp\msenv echo LIB="%LIB%;C:\Tcl\lib" >>C:\cygwin\tmp\msenv echo LIBPATH="%LIBPATH%" >>C:\cygwin\tmp\msenv echo INCLUDE="%INCLUDE%;%FLEXDLLDIR%;C:\Tcl\include" >>C:\cygwin\tmp\msenv echo FLPATH="`cygpath '%FLEXDLLDIR%'`" >>C:\cygwin\tmp\msenv echo PATH="$VCPATH:$FLPATH:$PATH" >>C:\cygwin\tmp\msenv echo export PATH LIB LIBPATH INCLUDE >>C:\cygwin\tmp\msenv echo export OCAMLBUILD_FIND=/usr/bin/find >>C:\cygwin\tmp\msenv Open a Cygwin shell and enter the following commands: tr -d '\r' .msenv32 echo '. $HOME/.msenv32' >>.bashrc Now, close the Command Prompt and the shell and you're set up for using the MS tools under Cygwin. To recompile OCaml, start a new Cygwin shell and change to the top-level directory of the OCaml distribution. Then, do cp config/m-nt.h config/m.h cp config/s-nt.h config/s.h cp config/Makefile.msvc config/Makefile Then, edit config/Makefile as needed, following the comments in this file. Normally, the only variables that need to be changed are PREFIX where to install everything TK_ROOT where TCL/TK was installed Finally, use "make -f Makefile.nt" to build the system, e.g. make -f Makefile.nt world make -f Makefile.nt bootstrap make -f Makefile.nt opt make -f Makefile.nt opt.opt make -f Makefile.nt install NOTES: * The VC++ compiler does not implement "computed gotos", and therefore generates inefficient code for byterun/interp.c. Consequently, the performance of bytecode programs is about 2/3 of that obtained under Unix/GCC or Cygwin or Mingw on similar hardware. * Libraries available in this port: "num", "str", "threads", "graphics", "labltk", and large parts of "unix". * The replay debugger is partially supported (no reverse execution). CREDITS: The initial port of Caml Special Light (the ancestor of OCaml) to Windows NT was done by Kevin Gallo at Microsoft Research, who kindly contributed his changes to the OCaml project. ------------------------------------------------------------------------------ The native Win32 port built with Mingw -------------------------------------- REQUIREMENTS: This port runs under MS Windows Seven, Vista, XP, and 2000. The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) runs without any additional tools. The native-code compiler (ocamlopt), as well as static linking of OCaml bytecode with C code (ocamlc -custom), require the Cygwin development tools, available at http://www.cygwin.com/ and the flexdll tool, available at http://alain.frisch.fr/flexdll.html You will need to install at least the following Cygwin packages (use the Setup tool from Cygwin): mingw64-i686-binutils mingw64-i686-gcc mingw64-i686-gcc-core mingw64-i686-runtime NOTES: - Do not use the Cygwin version of flexdll for this port. - There is another 32-bit gcc compiler, from the MinGW.org project, packaged in Cygwin under the name mingw-gcc. It is not currently supported by flexdll and OCaml. - The standard gcc compiler shipped with Cygwin used to support a "-mno-cygwin" option, which turned the compiler into a mingw compiler. This option was used by previous versions of flexdll and OCaml, but it is no longer available in recent version, hence the switch to another toolchain packaged in Cygwin. - The standalone mingw toolchain from the MinGW-w64 project (http://mingw-w64.sourceforge.net/) is not supported. Please use the version packaged in Cygwin instead. The LablTk GUI requires Tcl/Tk 8.5. Windows binaries are available as part of the ActiveTCL distribution at http://www.activestate.com/activetcl/downloads Note that you will need to install the 32-bit version of ActiveTCL, even if you are on a 64-bit version of Windows. INSTALLATION: The binary distribution is a self-installing executable archive. Just run it and it should install OCaml automatically. To run programs that use the LablTK GUI, the directory where the DLLs tk85.dll and tcl85.dll were installed (by the Tcl/Tk installer) must be added to the PATH environment variable. To compile programs that use the LablTK GUI, the directory where the libraries tk85.lib and tcl85.lib were installed (by the Tcl/Tk installer) must be added to the library search path in the LIB environment variable. E.g. if Tcl/Tk was installed in C:\tcl, add "C:\tcl\lib" to the LIB environment variable. RECOMPILATION FROM THE SOURCES: You will need the following software components to perform the recompilation: - Windows NT, 2000, XP, Vista, or Seven. - Cygwin: http://cygwin.com/ Install at least the following packages (and their dependencies, as computed by Cygwin's setup.exe): mingw64-i686-binutils mingw64-i686-gcc mingw64-i686-gcc-core mingw64-i686-runtime diffutils make ncurses - Tcl/Tk version 8.5 (see above). - The flexdll tool (see above). Do not forget to add the flexdll directory to your PATH The standalone mingw toolchain from the MinGW-w64 project (http://mingw-w64.sourceforge.net/) is not supported. Please use the version packaged in Cygwin instead. Start a new Cygwin shell and unpack the source distribution (ocaml-X.YY.Z.tar.gz) with "tar xzf". Change to the top-level directory of the OCaml distribution. Then, do cp config/m-nt.h config/m.h cp config/s-nt.h config/s.h cp config/Makefile.mingw config/Makefile Then, edit config/Makefile as needed, following the comments in this file. Normally, the only variables that need to be changed are PREFIX where to install everything TK_ROOT where Tcl/Tk was installed Finally, use "make -f Makefile.nt" to build the system, e.g. make -f Makefile.nt world make -f Makefile.nt bootstrap make -f Makefile.nt opt make -f Makefile.nt opt.opt make -f Makefile.nt install NOTES: * Libraries available in this port: "num", "str", "threads", "graphics", "labltk", and large parts of "unix". * The replay debugger is partially supported (no reverse execution). ------------------------------------------------------------------------------ The Cygwin port of OCaml ------------------------ REQUIREMENTS: This port requires the Cygwin environment from Cygnus/RedHat, which is freely available at: http://www.cygwin.com/ It also requires the flexdll tool, available at: http://alain.frisch.fr/flexdll.html This port runs under all versions of MS Windows supported by Cygwin. INSTALLATION: We do not distribute binaries for this port, but they can be found in the Cygwin distribution (use the Setup tool from Cygwin and select the OCaml packages). Alternatively, recompile from the source distribution. RECOMPILATION FROM THE SOURCES: Before starting, make sure that the gcc version installed by cygwin is not 4.5.3 (it has a bug that affects OCaml). If needed, use cygwin's setup.exe to downgrade to 4.3.4. You will need to recompile (and install) flexdll from source with Cygwin's C compiler because the official binary version of flexdll doesn't handle Cygwin's symbolic links and sometimes fails to launch the C compiler. In order to recompile flexdll, you first need to configure, compile, and install OCaml without flexdll support (configure with options -no-shared-libs -no-tk -no-camlp4), then modify the flexdll Makefile to change line 51 from: LINKFLAGS = -ccopt "-link version_res.o" to: LINKFLAGS = -cclib version_res.o Then "make CHAINS=cygwin" and add the flexdll directory to your PATH. Make sure to add it before "/usr/bin" or you will get cygwin's flexlink. Then, in OCaml's source directory, type: make clean make distclean and follow the instructions for Unix machines given in the file INSTALL. NOTES: - There is a problem with cygwin's port of gcc version 4.5.3. You should use cygwin's setup program to downgrade to 4.3.4 before compiling OCaml. - The replay debugger is fully supported. - When upgrading from 3.12.0 to 3.12.1, you will need to remove /usr/local/bin/ocamlmktop.exe before typing "make install". - In order to use the "graph" and "labltk" libraries, you will need to use Cygwin's setup.exe to install the xinit, libX11-devel, tcl, and tcl-tk packages before compiling OCaml. ------------------------------------------------------------------------------ The native Win64 port built with Microsoft Windows SDK ------------------------------------------------------ REQUIREMENTS: This port runs under MS Windows XP 64, Windows Server 64, and Windows 7 64 on Intel64/AMD64 machines. The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) runs without any additional tools. Statically linking OCaml bytecode with C code (ocamlc -custom) requires the Microsoft Platform SDK compiler (item [1] in the section "third-party software" below) and the flexdll tool (item [2]). The native-code compiler (ocamlopt) requires the Microsoft compiler and the Microsoft assembler MASM64 (item [1]) and the flexdll tool (item [2]). The LablTk GUI is not available in this version. INSTALLATION: There is no binary distribution yet. Please compile from sources as described below. THIRD-PARTY SOFTWARE: [1] Microsoft Windows SDK for Windows 7 and .NET Framework 3.5 Service Pack 1. Can be downloaded for free from http://www.microsoft.com/downloads/en/default.aspx under the name "Microsoft Windows 7 SDK". [2] flexdll version 0.29 or later. Can be downloaded from http://alain.frisch.fr/flexdll.html RECOMPILATION FROM THE SOURCES: The command-line tools can be recompiled from the Unix source distribution (ocaml-X.YZ.tar.gz), which also contains the files modified for Windows. You will need the following software components to perform the recompilation: - Windows XP 64, Windows Server 64, or Windows 7 64. - Items [1] and [2] from the list of recommended software above. - The Cygwin port of GNU tools, available from http://www.cygwin.com/ Install at least the following packages: diffutils, make, ncurses. First, you need to set up your cygwin environment for using the MS tools. The following assumes that you have installed [1] and [2] in their default directories. If this is not the case, you will need to adjust the paths accordingly. Open a Windows Command Prompt and enter the following commands: set PFPATH=C:\Program Files (x86) cd "%PFPATH%\Microsoft Visual Studio 9.0\VC\bin" vcvars64 echo VCPATH="`cygpath -p '%Path%'`" >C:\cygwin\tmp\msenv echo LIB="%LIB%;C:\Tcl\lib" >>C:\cygwin\tmp\msenv echo LIBPATH="%LIBPATH%" >>C:\cygwin\tmp\msenv echo INCLUDE="%INCLUDE%;C:\Tcl\include" >>C:\cygwin\tmp\msenv echo FLPATH="`cygpath '%PFPATH%\flexdll'`" >>C:\cygwin\tmp\msenv echo PATH="${VCPATH}:$PATH:${FLPATH}" >>C:\cygwin\tmp\msenv echo export PATH LIB LIBPATH INCLUDE >>C:\cygwin\tmp\msenv echo export OCAMLBUILD_FIND=/usr/bin/find >>C:\cygwin\tmp\msenv Open a Cygwin shell and enter the following commands: tr -d '\r' .msenv64 echo '. $HOME/.msenv64' >>.bashrc Now, close the Command Prompt and the shell and you're set up for using the MS tools under Cygwin. To recompile OCaml, start a new Cygwin shell and change to the top-level directory of the OCaml distribution. Then, do cp config/m-nt.h config/m.h cp config/s-nt.h config/s.h cp config/Makefile.msvc64 config/Makefile Then, edit config/Makefile as needed, following the comments in this file. Normally, the only variable that need to be changed is PREFIX where to install everything Finally, use "make -f Makefile.nt" to build the system, e.g. make -f Makefile.nt world make -f Makefile.nt bootstrap make -f Makefile.nt opt make -f Makefile.nt opt.opt make -f Makefile.nt install NOTES: * Libraries available in this port: "num", "str", "threads", "graphics", and large parts of "unix". * The replay debugger is partially supported (no reverse execution). * The graphical browser ocamlbrowser is not supported. mingw-ocaml/ocaml/boot/0000755000175000017500000000000012124403240014420 5ustar tootstootsmingw-ocaml/ocaml/boot/.ignore0000644000175000017500000000014012124403240015677 0ustar tootstootsSaved ocamlrun ocamlrun.exe ocamlyacc ocamlyacc.exe camlheader myocamlbuild myocamlbuild.native mingw-ocaml/ocaml/boot/ocamlc0000755000175000017500000454364712124403240015633 0ustar tootstoots#!/usr/local/ocaml/4.00/bin/ocamlrun T)*VD C 2" @(()*c( ` 5?[o n2$ ]()* ^()* ^()* ^()* ^(](]()* ^(](](](]U()* ^(](](]()* ^()* ^(](]()* ^(](](c!](cC%c!c%C +I( ] ] h ha()*6 " &c!](c!]Y(]%g ^]("g ^](!&!&&^(g ^]("g ^](!&!&&^(Y]Z(h()*VD C ] oha o2' ()*] V  ]'5?[)] h `c]cVn @ ]'(m] mh `co @2&, ,ch &)*  ]o }V5 % $)*  ]o }V5% `(h6'h6')* _](Y]ZThY]Z(h(]]()*c _()*  ]o }V5% `()*]h `(VD C Y]ZTh2%c(,c] %l6'l6')* _](6^% ~V5&^ 0: T -T(2%] ,c %6^Z(5 ^V5 ^V5%d(c(V5(5(5%()*] ] n] h ha ha(g u((m()* ^V(()* ^V((6@[6@[+ +6? + + + +livgTg>iv 6]6]6 ]6!]6"]6#] +^+H +9+ + :+ + ,c]i]j] + + + + +Z+4 +& + + + + +%+ ,(+ +t ++ +++++++v"+f +V+A+2 !+" + + :,+ +? + + + 6$^.  + + + +} +t +h> +X +L +C +: +. +$ + +),* +213 +79 + + +> + +BD +G +LKM02468:<>@BDFHJL_acegkmoqsuwy{}>QB9%T)*V D 2&(]()*|V  $eq o  n n2  n2  n n$ )*c }UH\ n^ n? T\C^ C_ C~V  C^"c C_ zUc()* "._ {V ^2$ o$ _ {V ^ 2$ o$ )* nn  , ^^$)* + + ,O |V hh$ e q oh^ ^  h   h c h $)* " ^"^ _ 2' _()*Y #Z( CyV D _([)* " ^ _ 2&)*f q zVcT5&6 @[ ^"^ _ 2&h_( _()*Y"Z( CyVD ([)* nn ? {V0^ ^"h}V I^ C^"h}V IC( {V^ ^"( {V(@[)* + ,,, +\,Ok qh {U\ ^  # zUcj {U%\ ^h ^  _h"" zUci{Vd ^h ^i _h _( )*? Oh {U\C ^ " I zUcC()*?hO }U\^ C" I zUcC()*VD C _  2&(VD C h"^ ,i &:()*( ^ @ 2&,c O &)*O :(c ^ h " ^i  }U\^ " _  zUc()*c O }U\^ " zUc()*O :(c ^ ! ^i  }U\^ ! _  zUc()*c O }U\^ ! zUc()* Oo }U   Oo}V5'8%%a()*   Oo }V5(8%% n }U\ _  zUc()*  Oo }V5)8%% _()*O %Oh _( ^(O :(h _()*: ^h  }U\^ Q zUc()*:(c ! ^i  }U\! _  zUc(+ + + +j +I + + + +x +R + + ,+ +~ +N6*? +l  +.   +!$&(>9+TO)*V D 2&()*V D C @ 2&(VD C 2! 8%&c()*VD C ! 2" @(c()*VD C " 2# @(c()*V D C ! 2&c()*VD C "2'c()*VD C "2'()*VD C 2# &()* VVD C DC "  2# @( Uc(5,8%%)* VVD C DC " 2' Uc(5-8%%)* VVD C DC    # 2$U(5.8%%)* VV!D C DC    2   ' U(5/8%%)*VD C !V 2&(d()*VD C !U 2&(c()* VVD C DC "V 2' ( Ud(508%%)* VVD C DC "U 2' ( Uc(518%%)*VD C ^hyU 2&(c()*VD C yU 2&(c()*VD C D C ^(2&5?[)*VD C D C yV(2&5?[)*VD C C ^hyU2&(c()*VD C C yU2&(c()*VD C C ^(2" @(c()*VD C C yV(2" @(c()*VD C !V( 2&5?[VD C D C 2! D C @ @@(52()* VVD C DC 2" @@(Uc(538%%)* V0V)D C DC "  2# @( 2# @(  ( ()*(V D 2&546 @[)* V/V&D C DC "  @ 2'  @2'  & &)* V/V&D C DC "  @ 2'  @2'  & &)* VD VD VwC CC "5 " c @ @ @(  " c @ @ @( c @ @ @(  " c @ @ @(  " c @ @ @( c @ @ @( T-T)V&D VC C " c @ @(c @ @( i x o " 3" 3"h ')* VD V{D VrC CC "3 " c @ @ @(  " c @ @ @( c @ @ @(  " c @ @ @(  " c @ @ @( c @ @ @( T,T(V%D VC C " c @ @(c @ @( i x o " 1" 1"h ')*,, ,<! ( & )*VD C !V  @2' @2'! !@()*,hh ')*VD C !V  @2& 2&%,c %)* VVD C DC "@2' U(558%%)*, h ')* h')*VD C !@2&()*,h &)* h'c &)*VD C ( 2&568%%)*578%%, &VD (588%%VC (598%%h&,+ + + +8% ,+ , ,,+h +W ,,+* , ,,-+ ,U,},,,,,,,X,p,,,,,,,*+ +Z ,5,T,|,&,+    !#%')+-/24379>@C>AHHLNMQSUW>+/9:T)* o(az ((AZ  (('.\&*W&&&&&&&&&&5;(5<(5=(5>(5?(5@(]V d] h S(l]l\h Sgd ql0ni Sg l qrl0nj Sg rl0nk S(5A8%%(+ +v +R +. +# >9BT)* ~V5?[ RyV(  2$)*5?[ RyV(  2')* ^()*] ~V5C8%%Y #cdZ(6 CyVc([)*h ')*]  }V5D8%%Y      cdZ(6 CyVc([)*] ~V5E8%% ')* ] ')*]  }V5F8%% $)*h ] $8B&8B&)*](!h R !h S(8B&8B&)*] (]h  }U\R! S zUc(c?h ] }U?\R  "!\T  T ]VdTgTe Cn I zUc] CyV(C]h Ic ] }U\R  :  8g\CSCSTToTgTc" W#4ETKg\CSgbCST4g\CSgtCST#g\CSgnCSTg\CSgrCSTTF ]VCST7l\CSgd ql0nCSg l qrl0nCSg rl0nCS zUc(]h? T\ C{V C R!Uc? T\C C~V CR!UcC  CyV(C C~VC Co C'5G(  TTTc(d(]Cha]CnI]Cha]CnI(]CnI()*V?D Ch?h? +8: "C]p Cn] ]h ha]?  +8: "(5H()*c ] }U\R " zUc()*c ] }U\R ! zUc()* ]o }U  ]o}V5I8%%a()*  ]o }V5J8%% `()*  ]o }V5K8%%] h a(] ] h ha()*] h `(+ + + + +T +/ + + +b + + +j +^ +S +5 +) + ,+ + ,'+ ++x +k+: +-      #%$(*,.0>9LT!?[V +?&c&)* ^c(c] D Ch] E D C iv lqph? +lllllllllllllllllllll6M? +6N    "$&(*,.0449997?A>!#9OT)*V)D CVDC "V 2# @(2# @((()* ol|Vd nw ^ ^ "V #^ ^ "V #^ ^ "V #^ ??^ "XU ^ "XV5P6@[T8\T\C^ "VcT\ C^ "VcC C{VC C#C C{UcCo Co|V C2" C2& C2"C2&()* ,(Oh "d O }U]\^ ^ "XV@^ _ ? T\C^ C_ C C^ "Vc C_  zUc()* ^ ^ _  _ (V3D C V# D C 2! "V c @@Tc@ @@(ch @@(c(VD VD C C 2! #@((VD V!2%C (c()*,,, ! %,+ +Z + A9QT)* _(]U()*  ]o }V5R8%% ^W n ]o }V5S8%% ^V()* "n()*  ]o }V5T8%% ^W()*  ]o }V5U8%%a(+l + + +q  +c +T>9VT/)* 8V" n 8V"@(c ^()* _()* ^(+ + + +lllllllllll lll   "$>9WT5)* ^k(6X^l(5Y ^c(5Z ^V(][(5[ ^](5\ ^\(5]6^6_ + + +6`6a + + +   >  9bT5)* ^(6c^(5d ^x(5e ^V(]p(5f ^r(5g ^q(5h6i6j + + +6k6l + + +   >  9mT5)* ^(6n^(5o ^(5p ^V(](5q ^(5r ^(5s6t6u + + +8O 6v^6w ^ + + +   >  9xTcc Mc LG h E D C> M c K(G F F D C> M (G (G (G F(G F()* Gn D^()*  D^?(c()* D^()* o ] h Da?(c()* o ] h Da(G Go ] h GDa(d M( :ihhhhh ]6y 8%" +> ()*h 8%>$+% :hhhhhhhl]l] "> ()*] " TdMcD] En}VD] GEon|VGEoh D G D8L TB7OD]jp8%" GEon}V5z8%!]  G Eoh G D8L JG FnLGoMcMGoMEoKG h O }U\ ^ h|V o _ zUcE Dh 8L EnK()* _ h|VG M G GFn E D C>M ()* _ h|VG M G GFn E D C>M (5{ + + +6| + +w +G +& + + + + + + + + + +t +R     $>9}T](c(C%!F(!F(c!F(c!F(G oG oF^(G oG oE^(G F^( G F^(G oE^ G oF^ ^V(2%,G %)* G o D^()* ` W"*2_!G MG M i2&?[c!cj2&c!ck2&YG C^!l@ZT CyVcl@T[ D C 2&5~G !cl2&]V  ]E^y( D^y()* ,bG G GGGGGG M M G M Y ch "Z( GM M MMMMM CyVD ( +vI[c( cGhD8+ cM(Gj ph ^h ^8} ^8}^ hhC8+ I hhD8+ J hhE8+ K hhF8+ LM(5?6?hhhhhh8}8}hhhld8}ld^8}ld^hld^hld^> +c +K +D?  + +++++ + + + + +w +p   +_>9T9! G G# G GG"G GGG G G G G GGGGGGGFGGG>()*V)E D C C" (  2"' 2" ' dh h>()*VE D C 2"'%)*VE D C 2" '%)* VKVBF E D CFEDC}V   2# '}V 2#'   '&&VC V2%D (5?[VE D V2%(5?[VC V E D 2!'E (58%%)*VGE D C C" i A(2" E D C# A( 2" E D C   #A( 5()*VE D C C" hyU T2&(c()*V+E D C C"  &  2"' 2" ' c()* V_VXF E D CFEDC~V  & " E C 2" 2"' & " E C 2"  2"' ( ()* V8V2 E DC " D C  E 2" 2"'E 2" 2"&c(c()* V8V1 E DC " D C  E 2" 2"&E 2" 2"' (c()*VE D C A 2&()* V*V$E D CEDC C" ( ""2& d(Vg(c()* VTVN E D CEDC C"  2"V2&( hh>2"V2&( hh>2"V 2&( c(d()*VE D C 2"!2&c()*VE D C 2# " 2' ()*VE D C !V 2"V2&(d()*VE D C !U 2"U2&(c()*V E D C 2" !2" V' & c()*V:E D C 2" D C!2" D C V"  #@(  # "@( 5(VE C 2! 2!n(c()*VE D C 2" @2&(h&)* "hy()*c "h "&Vc(d()* VV !!' ( ()* VV !!' ( (dh h>()*VF Tc VF Tc  }VDV:E DC ! !~V # ' VE DC  # #'58%% 58%% }VFV<EDC ! !~V    #' VE D C#   #'58%% 58%% ~VT>()*VF Tc VF Tc ~VT>(VF (c(+ + + ,!+ ,O,b ,r,,,  + +~,c +h,9,W , ,,,Z,k +" +,,,, ,=,V,v,,+    "$&(*,.02468:<>@BDF>$(%+ +?9TJ! G G G GG#G G G"G  G G G G GGGGGG EGGGG>()*VAG FEDC C"   >(   2#$ 2#$ dh h>()*V!F E DC C" (T2& 5?[)*VF D C C" hyU T2&(c(VC V2%E D @(5?[VF E D V2% @(5?[VC VF E D 2!$ F (58%%)*V2F E DC C"  &  2"$ 2"$ c()*VF E DC 2" "2&c()*V"G F EDC 2" !2" >( c()*V$G F EDC 2" "2" >( c()*VF E DC 2# #2' ()*VF E DC "V 2"V2&(d()*VF E DC "U 2"U2&(c()*VF EDC   2#$  &)*VF EDC 2# $  &)* VlVbG F E DCGFE D C }V  2  $ }V   2 $$' ' )*VZF E DC C" ? A(2" E D C       A( 2" E D C      A( 5()* V@G F EDC !~V) " E D C  2# ?# 2#$TUc(V-F E D C " E D C  2#? #2#$56 @[)*V%F E DC 2" "2" V $ & c()*VKF E DC 2" D C " 2" D C V"    @(       "@( 5()*VF E D C> 2&(VF C 2! 2!n(c()*VF E DC 2"@@2&(h&)* V4V.F E D CFEDC C"hyV "V ""2&( c(Vc(d()*,c"h" &)* V<V6F E D CFEDC C" (  " (  ""2&d(Vg(c()*,c"h" &)*V C $  &)* VV! D C! $  ( ()* VV! D C! $  ( (Vc(d()*V G TcV G Tc  }VcVYF EDC ! !~V       $V*FEDC          $58%% 58%% }VdVZFEDC !!~V   $V*F E D C          $58%% 58%% ~VT>()*dh h>()*!! ~VT>(VG (c(+ + + +h + ,,M,r,,,  +^  ,, ,&,L,t,,,, , + + ,^ ,,6,],+  +: ,,+    "$&(*,.02468:<>@BDF>$(%+ +?9TV)*C 8: &C8:%Chy(C VC (?[C V D C I(?[)*C @ I(C?(c I(c?(5? + + + +++ + + +     >  9T ]8W yVc ^ (7W zV(% ]8W yVc ^ (7W zV(%c ^ h _ c ! h_ 7W ^([c ^ h _ Yc! h_ 7W^Z( +h_ [?[5? + + + + +a  >9T)* {Vh^ $2 \g\""l 2&\ " 2& 2&\"l 2& # D C !"l 2& l\yV&()*] ,scl &)* ~V5?[ ^ ({ "  o8L#@(  h!   o 8L#@()* ~V(^ _: TeTd0`T[{SS@ W@@@@DDDD@@@@@DD@@DDDD@DDDD@D@@DDD@@@DDDD@@@@@DD@@DDDD@DDDD@D@@DDDT T`( 2&)*,j] &)* ~V5?[ ^yV   2' ^yV(  2'  2')* ,] ' ({56 @[g}(g)()*Dh C 8%/$)*h}U7O }V58%!E Dn}V " DC8%?  Dn J()*Dh C $)*] Dn E }V "DCh 8L  J()*h}U h}U ]o }V58%! Dn E }V "DC  8L  J()*D E ~Vd " C_ J()*E ? T\Cjp ICDn}Uc7O C}V7ODn|V7O IT58%!C] Dhh C8L ICK(c JF IC] K(c J(D()*D ~V58%% C^()* Do }U  ]o}V58%%C8L$ )*   Do }V58%%] hC8L (Dh C8L'dT8O }V7OT ] h >(+ + + +e +F += +4 +! + + +c +7 +&+ + + + +T +n  +O   !>9T ( +&c(! +8 8i$)*! %8! 8!(]jp 8%c( +&(c()* +8 8+h$8%&8%&c( +&c(+(+%()*8%+8%.8%-+h$)* ~V%R %" 2&0 4443 $ )*" 1&)* V h " "T " 4&)*V c !  "T ! 4&)*  ! 4&&)* !D" 4+ $)*] 2, ;sc & )* ! ,cC! " & )* $)* 3+  ')* "  @"$)*R  T;W"T"T2 +  ' 3$ 2$ )* R |W||q%q% &6'6' "8%!T       "  "'  '  "  "E! h"  "$  '  "  "'  '  i8L"' " sT5 8L !8%"68%"yVT      "  "' " c i8L"T5 8B!8%"68%"  "' "      ^Z  "'  "     ^  "'  " 8%! "'  R  T+W!!%%%%%%%%%%%!%%%%!%%%%%!%%%%%!%%!T,"    ln ^Z  "'   TCW!"     ^lTT"     ^TT"     ^   "' "  # { ! "'  "' )* "^()* +           , Jh')* ^ ]H (% ~V 58%&^   TT 7TT2%(] ,c %)*VC (()*V(E%)*R 0:*  l pn2&$58%% F!?&h&)* R  h&,  &)*cl^ h _i _j _k _l _l _& )*cl^ h _i _j _k _l _&)*cl^ h _i _j _k _&)*ck^ h _i _j _&)*cj^ h _i _&ci^ h _& @&)* o_()* ~Vc^ +"& 2+()*!  ,ch &W !(/: & +( +q( +O( +'( +( +()*VD C V "2& &c()*,h &! C()*()*l)zVl}zV "()*aeTd lryVEKV DnJ(CnI(chhA + + + #()*V 58 "Tg%8" &)*8"(] 8! + + #8%)* }V%R : _Ci2& 8 W"-----------TTgi # 2&T  3& 2& 2& {V ^ "2%()* }V%R ~W~~EE #3% #  # ,5 !2& '(gs 'gc 'gi 'gf 'gB ' '  }V gi'^  T+W!!%%%%%%%%%%%!%%%%!%%%%%!%%%%%!%%!T gi' gi #& ' {V^% h4"2%2%()*] ,gc !c(' ~V%^ %2%3% ~V%^   TW TTT TT1% " 1% yV(')*(g)Tg} 2,e %)*] , & )*  F(gg ] _()*  Nn(gu ] _()* |V<R * 8"2&VD C 8%!8 "! 2& 56 @[(R 0 :2%$((R  (, %)*+  ! o 8!l% 8" ,c8:! "8% )*! D C]hl $ )* yV( |V 8L' 8L" V h  8L T  o  8L ()*] ~Vh@(R 1:  ]o8L#]Y@(-i2& 2&,Ydh"Z(6 CyVgsh'[5 G!8%"68%"8%%)* G!')*5 8%"68%" 8%!8%"68%" i8L"8%"68%"8%%]h ')* 8L'%)* n%(8%!68%"8%%+ +i ! + + +  > +n +\ +A + + +t +> + +w +`  +   + +b : + + + +?+(+ + + +a  !+  +& +:+, + + ++ + + + +  + +t % > @ D C G G E C>@   > '9TL)*VD C D C ^V( 2& 5?[ ~V(^ 2%(] ,Y g 8L "!Z(6 CyV([! h8:# !8: &)*D C E6 ^VkW E  E !l ] oo8L" h8L# ]o 8L# 8%" 8%"A( E !l o8L" 8%"68%"A(()*E D C W  ! ]n8%&]8%&)*Y   8Oh Z( CyVD 68"e8%L% CyVD 68"c8%L%[W cjqI9Ch %CC{VBC^ Y 8%!!ZT(6 CyVD6 ^VT5 A@[T[(TCi I(Ch I(CC{VC^ !(TCC{VC^ I(TCC{V@C^ Y ]Y!ZT(6 CyVD6 ^VT5 A@[T[(T^CC{V@C^ Y ]YIZT(6 CyVD6 ^VT5 A@[T[(TCC{V@C^ Y ]!ZT(6 CyVD6 ^VT5 A@[T[(TCC{V@C^ Y ]IZT(6 CyVD6 ^VT5 A@[T[(TtC 28: &D CC{V;C^ 8:"VC^ !( 666 68%" A@[T C T\C^ !C{Uc(?@[ {V  ^T5 W+FZC6 ^V5 ^V 68 TcTcTDE D C  68 T)C  68 TC  68 T#5 ^U5 ^V 8!@[8!@[)*VC T Ol8! C    + ,T\C^ ]ic ^-bY  "ZT6 CyV? !T[ Y  , !ZT% CyV D ?!T CyV D !T[T"Y!ZT CyV D ?!T[C{Udc( )* "68&)*g8! #8%)*6 8#! !8: &Y 6"ccZT6 CyVc6?6A@T[ Y 6"ccZT6 CyVc6?6A@T[ 8%" 8%&5@[)*E D C ]h{V7W   68$ C  666  68$ ()*8%" 8%&)*VDC 8%"+8:#8%&5(5?6?6? ,+ +p +e + + + +h?    +  + ,+S +  +     >9T#^!l ^!vn(Aa g&ga o (GgA o ( Tg0 o(56@[]l zV56@[+ +l]hl }U\jp!8B! _ zUc(g ]hl }U%\ejph ^68"8L  zUc(g]  gh8%? ()*gh 8%/$8%:!l ^ 8%F!()*  ]o }V58%% _(]h _(7L + + + + + +Q +   >9TD&G%c]%?E&E&G%G&G &G &G &G&G%)*! r l?o o}V 2&()*!]gli !s]g^d ^b ^`68b^]^\ ^]^V2&()*!]|l !]|^yl<l!s]|^y ^w ^w ^u68m^r^q ^r^V2& (d !shy()* !^&(5 !]! !]! ^'^$^'()*] "]()*] "]()*5 ^V58%% &)*5 ^V58%% &)*?58%% &g7 Dr JD C^ll ws ul7 Dr C^nl? s DC_(c! "(c]%c! "(gk ^vlj ^vli^vh^nnn()*8%! 8%"8%)*+ + Oc?T Ohl6 }U\ C_ zUc5?h l78%"l6n }U5\g7 r r ^C "Ig?C !  C^us  C_ zUccJ()*g7hChC8+ D J(chl7^@(+ + +P + + + + ,+ ,+,+d8x +MT+:+ + +    >h6]@ +7 ++ + ++++ + + +  +  + GGG G G GGGGF>    > 9T)* ~V(7Oj p}V(j p2&)*VE D C ^(2&5?[)*V E 2&()* `S(6&)*D%C + @! C D E FGGGGG G  G  G  G  G  +     >()*VE D C C"V(2&5?[VE C C"U2%(c()*, " D^ %VE D C C"VA(2! A(5?[)* , " D^ Y ! D_Z(6 CyV"A D_CIdDOvC}V& ([VE D C C"V 2! @(2%c()*, " D^ %)* " D^ VIE D C C"V(V1E DC  C"V( VE DC  C"V(  &5?[5?[5?[V E D C C"V CI(2! A(c()* , " D^ ! D_()* " D^A D_C Id DOv C}V&()*DO ED"s(+ + +,  + + +{ +<   >(h" ^ _()*h" 8%&Dh+8+#h ^ D +8+ " DOC>()*VE D C # 2&()*,D?h O }U\C ^" I zUcC(VE D C "2%c()*,Dh O }U\ ^! zUc(VE C ^hyU2%(c()*, " D^ %VE D C ^A(2! A(5?[)* , " D^ Y ! D_Z(6 CyV"A D_CIdDOvC}V& ([VE D C ^ 2! @(2%c()*, " D^ %)* " D^ VIE D C ^(V1E DC  ^( VE DC  ^(  &5?[5?[5?[V E D C ^ CI(2! A(c()* , " D^ ! D_()* " D^A D_C Id DOv C}V&()*ODO Eldl `Ss(DO ldl _Tr(VE D C 2!" ^ A _(c()*D Oj p8O {V,c ^ J,c }U\^ ! zUc(C( F E D8+! C>(DO OF yV%c Ic F^ J(c IDOh  }U\c D_ zUc()*VC TC l" V" ] CT 8!T8 F!Tc h^h>(c8 D%dI()* ldl `S()*h `S(hldl `S(+ + + Y5]ZT&6 CyVY5]ZT6 CyV5T[T[lR 8L" ? + +? , +4 + + + + + +@ + + ,+e+N++ +_ + , + + B + + !#%'>9T2G! C E D h}V GG G o{XV G!c T#G nM 2%()*h{VP h G'gPh G# 2&(c &+ &%)* +h'( +&%"%g8! + +i'&&c( +&c( +&)*%)* +G%()* +h')*?I! &)*. ~V1-%/^ %&@ 3! 2&. ~V/&&/^ AY^- TW 14' Tc1"2&[ W 14' Tc1"2&  W!!....2......6.C............PZ..k2c1!"2&TTTWc1""2&c1"2&14' 022+ 4 ' c1"2&c1"2&/&&3!2&0 44430/$F$ )*2! 1&)*'V h "0!T- " 4&)*%V c !.!T+ ! 4&)*c)" 4&&)* 4+"&)*&)*&)*&)*&)* #' ~V&^ 0: T.-T( yVcT oC!E# #  '2%)*" ~V#&#^ R% #", %#+n#+_#+P#+A#+2   $#F$   2' ~V!&!^ >!&(2% ~Vl@(^ bxhvl@(i@( ~Vh@(^ ovh@(j@( ~V 6'^ v i8L"68%"' k@(l@()*6')*6')*%)*Vc !Tc +"  @@$)*Vh "T " @@$ )* @@$)*~V oC!E#" '^ %&> 2$  oC!E#" 'oC!E# 2+ 2+h 2+<+%+  F$ )*, V h$)*3! ')* #! &)* ~V c  " 4&^ < c  " 4&444 ,4' )* #! &)* ~V gh # 4&^ < gh # 4&4! D C 44+ 4' )*"! &)* ~V 5 " 4&^ < 5 " 4&44+ 4'C VC #cI(&C VC i8L" #cI(&)*!h? + +        , O[v,`DchC!&)*] 2     +d G&)*      ,()*V @8:!68L&()*g8! ! " &)*c "%8! 8!()*Y]YZT6 CyV "T[ ()* 6#8%%)* 6')* #8%%)*] {V  ^68"T g.68" F! 68$c"8!8!(c(+ 8 !&8%+%+ 8%/!&c(c()* + +  ! M! M()*c!h6l# " i@@ hh    68%iiiihlNlNl lNhhhh>(c(5 8%"68%&5 8%"68%&8%+%)*8%/! M+ M! M! M()*dh6 G')*G G G G>()* # M M()*G G@()* M M()*G()*i|V0! MG G|VGTdj Gq GGo8%"8%" &()*G()* Go &)*i|V! MG Go M%( {V(()*G()* M()*G G y()*G()*i{V M()*G G {V chh# &()*ch ')*G G {V @ G m# i '()*G i{VG G {Vcjh# "G  M ()*G  M G G {Vch???h# &()*ch ')*ci ')*G G {V @ G m# i '()*G G {V clh# &()*G G {V ckh# &()*c "c G%)*d "c G%)*g ')*f ')*e ')*d ')*ch ')*d] h _i ')*8%! &)*8%! &)*8%! &)* ] ')* ')*G G {V '()*T\c "G c M !V!%!!c Jc Kc Lc Mc M c M G M%)*F E DC MMMM()*G G G G>()* " &)*G()*G()* M()* M()*GV clhA "GVF VD C G!L(c()*GV F @ L G!GV c ?hA &()*G i{V"G G {VcihA "d "c "G  M (fh ')*G  M G G {Vc @ G m# h 'G G yVG &()* "Vd "C G @@ I()*C VRC D C CD D G {V% W1111111 11 XV  G nI I(  V  G nI I( c( c( I()*] ')* ?# &)* A()* "%Y!Z( CyVc([)*VD C ^V( 2&5?[)*VD C ^V @( 2" @(c @()*W ,;J]q E VC C ,CGGo " I(c(D VD J(c(E VD K(c(D V C D &%G Go G zV%(G VD C G! "M(c(C Go M "c M (D C D VtC D C W /d& ' ' G}V' & G V& G}V'  GonG }V' & & c(D C G Go E VPC C ,C V"C Y C "ZT6 CyVT[T o  n & G n 'c(D C G Go G }V!Go G}VTgTdD @@J(C E @ K(C G! "G @ M(G! C E G oM GnM(D V!C D CG }V c(&c(%)* Go M &)*h ')*!d M  Gon G8%" M G Go MG &)* G%c G%)*]h G'd M d M G%)*E G n M G &D VC C D JhyVcI(?[D VC C (?[)*c @? C V C I J(IJ(c Ic J(ch@(g]+ + +6? + + +t+al ʚ; +O +D +8 + + + + +   +  ,p+? +/ +! + +h6l#h l@@ + + +a +# + +++ +{ +n +b +V +E +- +  "+  !$++ + +y +i +Y +I+4+&++ ++ + +"$+#%+%+f +Y +L')+(*+#*+ ++-+ + + +p +c +W>+D  + + + + + + + + +j +Zl lP8L" ,^ +( + + + DH\_+  +v +] +Hl8!8% !8%! ! 9+ 1!1!1!1!1!I! I! I! ?! ?! ?!?!>!@!6!5!7!;!=!?!=!:!:!:!9!;!1!1!5! 5!!>!">!#>!$>!%>!&1!'9!(9!)9!*9!+c!,e!-k!.j!/l!0k!1k!8 C8 D + + + + + + p+ >+k +O   giknpry~+ +y +d +P +@ C+1 C+& H+ +I+ }+ 38%M!     cegicrtvxzsusu]_acegi`ccfcrt}>p9 T]()* _()* ^()* ^()* ^()*a()*! ~V( ^VdTc n 2')*d a()* + ^ " h$ CO  ! }V-! 3+ "CIDJEKFLCOGrM(7% Kc L( ~V7Oj kpq8%" |V5 8%!!h ^ h h a  hh 8+  # _ C_ D_E |VE }V"FLc }U\! zUcCOqF}V%( ^V2%  #  _()* C^ D^ !      1, c % )* n()* ^(CO C8+ " +8+"h +8+#  ^jq ^h^ !>()* ~V(^yV6^ V'C C"V^ V C @2&2& 2& 2&)*D! " C^ D^ !  ,ch & )*d()*c + $)*c _()*c + $ ~V(^yV ^ VC C"V&2%2%)*D! " C^ D^ !    ,c % )*5?[)*+ ')* _()*? + ()* + ' ~V&^yV-^ VC C"V^ VC (2%2%2%)*D! " C^ D^ !   ,c % )* _()*D! " ? +$)* ~V3^V 2&^Vd a^ _ 2& 2&(G C^ G D^ ! !hh# |VF,!h "GC_:GD_T ^^E}VE |VFLCOGrM(fj pq(7Oj kpq8%&c Ch!8+')*! ~Vc( ^  D^# 2' 2')* ,Ch !8+ &)*! ~Vc( ^ V C ! 2& 2&)*,Ch !8+ &)*! ~V( ^ VC "2' 2')*, Ch !8+'c CO }U\ C_: D_ zUc Kc L(gT8O }V7OThh :^^>()*CO8% sr(](+h ! +lj + ++l+,+,N+ + + +  ,mr++e + ++ +V +:+ +u   > ()* ! n}V5 6@[ n }U\ _ zUc(O(+ + + +} +o +b +U +G +;> 9 T# Yll@k@i@8%*#@Z(6 CyV [2%[)*VC T5  VC TC ,c %# Yg6_]Z(6 CyV [2%[)*VC TC ,c %C(I()*g ] CT 8!T8 F!s  68  &c8 D%"V58%%^. h8L'2%,] %)*] ]o 58%%h 8L')*]  "V 8%&8%" 8%&! D '! D C # 8%&!V]j 8L#jh 8L#@(6@([ T TAc(d(+ ]j|Vc ^ !Vd ^l:y( yV g"8&^ "\8"2%h3&h3&)* yV g"8"3%^ "\3!1% 2&jp3!g"8"1%d }U\g\8" zUc(] 8!l" 8" ,Uc !8%)*] ]~V] ] ]o 8L# 8L! 8L!^(!VO]j}U 5jh 8L#^V;]j}U 5jh 8L#^V']k}U 5kh 8L#^V]k}U 5kh 8L#^(]i}Uc ^l/zV]i}Uc ^l\zV]j}Ud ^l:z()* ^ l/yU l\yUl:y()*] ]~V ] ] ]o 8L#^(!V']j}U 5jh 8L#^V]k}U 5kh 8L#^(]i}Uc ^l/z()* ^l/y( dh8L'"V2%3%("V3%2% dh8L'"V2%h8L')* ,5^V(] % dh8L'"V2% 3&)* h8L'"V o 8L' 2&)* ,5^V(] %)*] 8!l' 8"c  }U$\^'  8 "T ^ 8" zUcg' 8"8%+ + +"666 + + +m +J Y5]ZT6 CyV5T[6  ! "  "   >  6!6"6# + + +X +* Y5$]ZT6 CyV5%T[ + +6 +  +   +   >  6&6'6( FGGGG G" "   >  8O6) ^Ve5* ^V65+ ^V5,6 @[G G GGGGG F E D C> TMG G GGGG G F E D C> T%G G GGGGGF E D C>  G G G GGGGFE D C + +j+W +&? + ? + + + +^>9-Tj)*V D 2# C !@(()*VC ! D 2" @()*VVC C "V D D 2'(Ud(c()*c( 2" @()*VD C ^V( 2" @(VD C V2! D C @@(h@(5.6 @[)*VVC C "V D D 2'(Ud(c(c(d x2!in(E(D(C(E(D(C(Ch I()*] ~V(^  TT TT  3' 2&)*] ~V o 8L#@(^  TT TT  2' o8L#@1&,ech &)*] ~V(] n~V5?[^ n^yV 2&c 2&)* ,c &8- ! 8- ! Y/g.8L " h8L#8-!V 7-^VT8-"Z(6 CyV([Y 8-!Z(6 CyV([i8%x|Vd8%x |()* o u 8%! uth}()* n8%! u uth}()* m ns(m s()*]  h8%? ( gh8%>  8% h8 c2%g8!l] ,c %c(g8%"h8%>  5?[ h8%/  o2%)*g] , % gh8%>  c( h8%/ c2%)*g] ,c %D C8')*h8" +8: "()*]c ^+]i 8L# 8-&(Y]Z(6 CyVc([V$C 8-" 8-" ]V(]V(D2%5?[)*8L! , %V C8-" ]V(D2%5?[)*8-!U]V(5?[, %)*VC !?()*VC %()*Yc!ZTh ![h !(5/8% !8%#!?[50? + + ,,,,,,,+ + +n +< + + + + +` + + , + + + +q +W + + + + + + + + + +    "$&(*,.02468:<>@BDGG>%%91Tz)*V=F EDC ^ G>(  2#$ 2#$ dh h>()*VD ^ E(CTF 2&5?[)*VD ^ hyUCTF 2&()*V"VFEDCF2"  E D C$(()*V1F E DC ^  &  2"$ 2"$ ()*VC 2"E D "F 2&()*VD G F 2"E " C2">()*V C 2# E D # F 2'()* 628 f$)* +&)* + 638 f$ )*!!  }VZVPF EDC ! !~V       $V&     F ED   C    $546 @[ }V[VQCF ! !~VE D      $ V' F E DF  E D  C    $ 556 @[$ )*!! ~VT>(VG(c(c + + + ,v,,,,!,U,j,+   >  96T)* 678$)* 688$+ +69 "6: "6; "6< "6= "6> "6? "6@ " 6A " 6B " 6C " 6D " 6E "6F "6G "6H "6I "6J "6K "6L "6M "7O6N "6O "6P "8%+%7O 6Q Y5R]ZT%6 CyVY5S]ZT6 CyVT[T[6T6U6V6W6X6Y6Z6[6\6]6^6_6`6a6b6c6d6e6f6g6h6i6jh?6k?llll6l6m6n6oh6p6q6r6s8O6t ^V5u ^V 5v ^V 5wT5xT5yi   ),.02468:<>@+   "$''*,.024*,;=?;=?DFHJLNPRU>+,9zT%CVc(c8z@(CV5{(7z8-! 8%&c?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?6|?6}?h?h?h?i?h?h?h?h?h?h?h?l?h?h?h?h?h?h?i?h?h?h?h?h?hh?h?h?h?h?h?h?h?h?l ?h?:+";+h?i?6~?   !#%')+-/13579;=?ACEGIKMOQSUWY[]_acegikmoqsuwy{}>EF9TN)*! u8-!8z68 Tb`8C8:!68L"8zC6"68"CV7zT5 8-!8#C VCT W 7z T7z T 7z T56 @[68 !hy(]5jh 8L#^V(7z& ]j 8L#8%"68%" Y 8zC81 "Z(6 CyV([)*81!8-!8z6 ^VE7z ]cT56 @[!8z 68 ! 7z ](68%"8z 8%"%! 68#%H8-!68@!8C8:!6"8C8:!68L"8#C VCT7=CV7zT7z68 %VC8-%5(8%&5 ^()* +8:" +8: " %5 ^( +8:" 8-8: " 68L" ]58O^V%(81%68' 56hh8-  D C +8: "8%6!+8%M!68%&!c(7CV58% !8% !c8%$!](+ + + +e +B +! + +d + + > 9ToD C68' +8: "58%!gblz }UE\8B! ! V-DV8%8: "68L" 8B!68#TC 8B!68# zUcc8%L%Ch{V C@hI[(%)*! !h?h ] }U\^l yV zUcc8 c" F E D C +  8 b   68 f c 8 I" 8 b ^VC( W'+/37;?CGKOSW[_cgk3BKTXggk{ 5(5(5(5(5(5(5(5(5(5(5(5(5(5(5(5(5(C6 ^V5 8%"68%&5(C V)D C V6@ @6@68L&5 8%"68%&56 @[C6 ^V 68%&5(5 C8%"68%&C V5D C V5 6@ @6@68L"8%&568%" 8%"68%&56 @[5 C68L"8%"68%&5 C8%"68%&5 C8%&5 C8%&C(5 C8%"68%&CTF E D C68$C E D68$5 C8%"68%&5 C8%"68%&5 C8%"68%&5 C8%"68%&5 C8%"68%&C D5 8%"68%&E5 8%"68%&5 8%"68%&C D5 8%"68%&5 8%"68%&6 8%"68%&)* VT&)*] ~V @(^   @(l0^l pno2&] ~Vc(^ A9a{]^!8: "2%[E^8B!!8: "2%. @%3&+W 3&3&c %)*] ~Vc%^ A3a{Y^! 8: "1%[D^8B!! 8: "1% )! D E8%" }U\! zUcC1%c%h" D C] {V)^."^.h" D {Vc! CA( A(58@[d _d _(c _(d _()*+ ++ +,[ +~   ,wc % !^(!^(c(2! @( 56 @[W"%)-1""""59=""A"EI"MQ"UY], %c(5(5(5(5(5(5(5(5(5(5(5(5(5(5(5(W'*-048<@DHLPTX\`dhlptx|d(e(f(g(g(g (g (g (g(g(g(g(g(g(g(g(g'(g(g(g(g (g (g(g(g(g(g(g(g(g(g(g(g (g!(g"(g#(g$(g%(g&(+;l' +i ^h ^ + + +Q +66 h" i" +ah?  +6? +6 +D  > 9TT\8"8"Uc()*!XVC @I()*c? +8 "C +8: &)* C @@(c +8 ')* 8"D()* @ 8')*Y8" C^V D >[Z(6 CyV@[[)*Y8" C^V D >[Z(6 CyV @ 8'[g h8&+86?6? + +{ +i +Y +I +   >  9T)*C VVEC V>Y 56]^ZT6 CyVcT[ Vc(YC #dZ(8% CyVc([(7%]I 2'C V%Y   C C  dZ(8% CyVc([( &)* @(c8  !()*8 1 ')* 8" CnI()*8!V!+ " 68 f c 8 I"(C! &)* "5 8 f&)*5  CC^V  #Vc( 6 8 f$)*C! E C CFDFon6  ^V#Vc(DFCF6 8 f$ D6  8 f h|V6 8 f$ (E Fo D CA(cI()*!6 8 f'CV%(8- ! 8- ! ^V(7- ^V2%7- ^V 2!8- % 2!8-&8-!V h]8-"T , %)*Fm h}V7%?[ Eohhh }U3\ nD^l yV CF}V DF}V zUc DF CF6 8 f 58 ?"chh }U\ n D^ gyVyV  8 C"TyV CF {V g. 8 C"T 8 C"TyV DF {V  8 C"Tg. 8 C"T}V{V 8 C"TyVyVP5 8 f" CF }U\g  8 C" zUc CF DF }U\g^ 8 C" zUc~V|V5 8 f" DF {V 5 8 ?" zUc( )*c 8 I"Fm h}V7%?[C E }U\D^l yV zUc ~V7%?[7%8%+!]c68%!c Eo }US\V 58%!cCF yU CF yVd]DF yU DF yVc] nD^ 8%!l y zUcc]C]7%8%+% c 8! 8!A(dh8!h8!A(ch8!h8!A()*chi> M (c G G A(ghi >i A(c? +6 ! + + + + +6?h?h?h? + ++ ,#+ + ++6 G F E DC +  + + + + + +u+e +Y  +M"   (*,.03377>#9T)*W  C@(C D@2&581%)*Y!g.8L # 2" o8L#@Z(6 CyVc ]o8L#@([)* @(c " VD C? +8:'5(W C(D(581%h&,b+ + ,v+ A9T~)*WIWiF E DC68C^V 8#V 6 8 f$ 8 6! 8 f  8 6"8 f$ C8 6# 8 f$D C8 6$8 f$ C8 6% 8 f$5&?6'? +y A9(T.V!C D2!i DD DCA h @@?@ &ch86)8"A%V!C D2!i DD DCA h @@?@ &ch86*8"A%)* yV ??% 8B!2" ??!@%)* }V 2& yV ??% "%)* l8 $)* l8 $)* k8 $)* j8 $)* i8 $5+8%%d 8 "(d 8 " 8:%d 8 " ?(d 8 "h !@?(d 8 "(5?[c 8 "h @(d 8 "h 8 " @(c 8 "(d 8 "h 8 " h !@?@(c(c(d 8 "h 8 " h !@?@(d 8 "h 8 " h @?@(d 8 "h 8 " @(d 8 "h 8 " h @?@(d 8 "h 8 " @(c 8 "i "?%d 8 " ?%d 8 "k6,i6-$g 8 "k 8 "h 8 " k"A%f 8 "i 8 " @%f 8 "i 8 "l6.j6/$f 8 "i 8 " @%f 8 "i 8 "l60i61$d 8 "(d 8 "k62i63$d 8 " ?%f 8 "i 8 "h ? !? A!?%g 8 "k 8 "i 8 " ? !? ? !?A!?%f 8 "i 8 " ? !?h A!?%e 8 "l64i65$e 8 "l66i67$d 8 "l68i69$c 8 "(d 8 "h 8 " !@(c(c(d 8 "h 8 " !@(d 8 "h 8 " @(d 8 "h 8 " @(d 8 "h 8 " VC CCVDVT D?%8:! @%g 8 "j 8 "h 8 "h8! Aj"@%c 8 " 8:!?%d 8 "h 8 " j "@%e 8 "h 8 "l8! 8"j "@%d 8 "h 8 " j "@%c 8 " 8:!?%e 8 "h 8 " k "@%c 8 "j "? %c 8 " 8:!? %c 8 " 8:!? %c 8 " ? %c 8 "(e 8 "h 8 " @%g 8 "j 8 "h 8 " j"A%c 8 "h @(e 8 "h 8 " @(g 8 "j 8 "h 8 " i"A(c 8 "i "?%d 8 " 8:!?%d 8 "k6:i6;$g 8 "k 8 "h 8 " k"A%e 8 "h 8 " 8:! @%c 8 " ?%d 8 "(d 8 "k6<i6=$c(d 8 "h 8 " @(e 8 "i 8 " @(e 8 "h 8 "h8!h Aj "@%g 8 "j 8 "h 8 "h8! Aj"@%c 8 " 8:!?%d 8 "h 8 " j "@%d 8 "h 8 " j "@%c 8 " 8:!?%c 8 "hk "@%e 8 "h 8 " ?k "@%c 8 "j "?%c 8 " ?%c 8 " 8:!?%c 8 " 8:!? %c 8 "(g 8 "j 8 "h 8 " j"A%c 8 "h @(e 8 "h 8 " @(e 8 "h 8 " i "@(e 8 "h 8 " @(c 8 "h @(f 8 "j 8 "i 8 "h8 " C8:%!h8! D k"DC@ >(c 8 "(e 8 "h 8 " @%d 8 "h 8 " E DC>%c8!h@(d 8 "h8! 8:!@(e 8 "h 8 " E DC>%d 8 "h 8 " E DC>%c 8 "(c 8 "(d 8 "h 8 " 8:! @%f 8 "j 8 "h 8 " 8:!A%e 8 "h 8 " 8:!l8! 8"@%c 8 "hi "@%d 8 " ?%d 8 "k6>i6?$f 8 "i 8 " @%f 8 "i 8 "l6@i6A$d 8 "(d 8 "k6Bi6C$d 8 "h 8 " 8:! @(d 8 " %f 8 "i 8 " @ %c%c(d 8 "h 8 " @(e 8 "i 8 "h 8 " A%c 8 " ?%c 8 " ?%c 8 " ?%c 8 " ?%c 8 " ?%c 8 " ?%c 8 " ?(c(g 8 "j 8 "h 8 " hyVc!il8!8"A(f 8 "j 8 "h 8 " k"A(g 8 "k 8 "j 8 "h8 " k">(g 8 "l 8 "k 8 "j8 "h8 " D C A!k">(g 8 "j 8 "h 8 " hyVc!hl8!8"A(g 8 "k 8 "j 8 "h8 " hyVc! l8!8"A(f 8 "j 8 "i 8 "h8 "h @!l8!8">(g 8 "l 8 "l 8 "j8 "h8 " ? @!l8!8">(g 8 "l 8 "l 8 "l8 "j8 "h8 " # D? C@!l8!8">(c 8 "(g 8 "j 8 "h 8 " !6D8%"A%f 8 "j 8 "h 8 " !6E8%"A%g 8 "j 8 "h 8 " A%e 8 "h 8 " 6FA%e 8 "h 8 " 8:!l8! 8"@%c 8 "hi "@%d 8 " ?%d 8 "k6Gi6H$d 8 "h 8 "h8! 8:! A(d 8 "(c%c(d 8 "h 8 " @(c 8 " ?%c 8 " ?%c 8 " ?%c 8 " ?%c 8 " ?%f 8 "j 8 "h 8 " h>(f 8 "j 8 "h 8 " i>(e 8 "h 8 " ih>(f 8 "j 8 "h 8 " A(e 8 "h 8 " h A(f 8 "j 8 "h 8 " A(e 8 "h 8 "h8! A(e 8 "h 8 " @(e 8 "h 8 " @(c 8 "h @(g 8 "k 8 "j 8 "h8 " C8:%!h8! D k"DC@ >(e 8 "h 8 " @(c 8 "h @(g 8 "k 8 "j 8 "h8 " C8:%!h8! D k"DC@ >(c 8 "(d 8 " %e 8 "h 8 " @%e 8 "i 8 " D C6I8%"A(c 8 " Dh C6J8%"A(g 8 "j 8 "i 8 " 6K8%"A(d 8 "h 8 " h 6L8%"A(d 8 " Dh CA(c 8 " Dh CA(d 8 "h 8 " h A(c 8 " h6MA(c 8 "i "?%c%c(c 8 " ?(c 8 "(e 8 "h 8 " D@ ! C@(c 8 "i "?! @(c 8 "(e 8 "h 8 " @ %c 8 "(d 8 "h 8 " 8:! @%f 8 "j 8 "h 8 " 8:!A%f 8 "j 8 "h 8 " k"A%e 8 "h 8 " k "@%d 8 "h 8 " 8:!h6NA%d 8 "h 8 "h E@@ D CA%e 8 "h 8 " @%f 8 "i 8 "h 8 " 8:! @%f 8 "i 8 "h 8 " 8:! @%e 8 "h%c 8 " 8:!?%d 8 "h 8 "h ?i"A%d 8 "h 8 " ? @ %g 8 "j 8 "h 8 " ? A%e 8 "h 8 "h A%f 8 "i 8 " @%g 8 "l 8 "l 8 "k8 "i8 " j ">%e 8 "h 8 "h8!h @ @?!&f 8 "i 8 "h8!h @ @?!&e 8 "i 8 "h 8 " 'e 8 "i 8 "h 8 " 'e 8 "i 8 "h 8 " 'e 8 "i 8 "h 8 " 'e 8 "i 8 "h 8 " 'e 8 "h 8 " 6O 'e 8 "h 8 " 6P 'e 8 "h 8 " 6Q 'e 8 "h 8 " 6R 'e 8 "h 8 " 6S 'e 8 "h 8 " 6T 'e 8 "h 8 " 6U 'e 8 "h 8 " 6V 'e 8 "h 8 " 6W 'e 8 "h 8 " 6X 'e 8 "h 8 " 6Y 'e 8 "h 8 " 6Z 'e 8 "h 8 " 6[ 'd 8 "h 8 " &d 8 "h 8 " &g 8 "j 8 "h 8 " k "A %g 8 "k 8 "h 8 "h 6\@@ 6]@@ 6^@@6_6`"?!@%g 8 "k 8 "h 8 "h 6a@@ 6b@@ 6c@@6d6e"?!@%g 8 "k 8 "h 8 " 'e 8 "h 8 " i "@%c 8 " %c 8 " ?%d 8 " ?%d 8 "k6fi6g$c 8 "i "?%c 8 " ?%c 8 "hhi "A%c 8 "h @ %d 8 " %d 8 "k6hi6i$d 8 " %chh8!6j8"A%d 8 "k6ki6l$e 8 "i 8 " D C A%e 8 "h 8 "k " @ %g 8 "i 8 " i "@%g 8 "i 8 "l6mk6n$g 8 "i 8 "h 6o@@ 6p@@6q6r"?!@%g 8 "i 8 "l6sk6t$g 8 "i 8 "h 6u@@ 6v@@6w6x"?!@%g 8 "i 8 "l6yk6z$g 8 "i 8 " &g 8 "i 8 "l6{k6|$d 8 " C D@ %d 8 "k6}i6~$e 8 "i 8 " 8:!? %e 8 "i 8 "l6i6$5%e 8 "i 8 " 8:!!%e 8 "i 8 "l6i6$d 8 "h 8 "h 6@@i "@%c 8 "h 6@@i6"@%c 8 "j "?%e 8 "i 8 " 8:!?%e 8 "i 8 "l6i6$5%e 8 "h 8 " @%d 8 " ?%f 8 "i 8 "h ? !? ?!A%e 8 "l6i6$c 8 "h @(d 8 "h 8 " @(c 8 " 6@(c 8 "(d 8 "h 8 " @(c 8 "(c 8 " D C68%"@(d 8 "h 8 " 68%"@(c 8 "i ?"?! @(c 8 "h @(e 8 "h 8 " @(c 8 "h @(d 8 "h 8 " @(d 8 "h 8 " i "@(g 8 "l 8 "j 8 "h8 " @!i"@ !@(g 8 "l 8 "j 8 "h8 " # C Di"@ !@(e 8 "h 8 " @(c 8 "(e 8 "h 8 " D C A%c 8 "(d 8 "h 8 "h E@@ D CA%e 8 "h 8 " @%d 8 "h 8 "h @@(f 8 "i 8 "h 8 " @@(c 8 "(d 8 "h 8 "h E@@ D CA%e 8 "h 8 " @%c 8 "(e 8 "h 8 " @%e 8 "h 8 " @(e 8 "h 8 "h @ @(e 8 "h 8 " ?@(c 8 " h@(c 8 "h @(e 8 "h 8 " @(d 8 "h @(e 8 "h 8 " i "@(c 8 "i "i "@(e 8 "h 8 "h i"@@(g 8 "j 8 "h 8 " k"@@(c 8 "h @(e 8 "h 8 " @(c 8 "h ?@(e 8 "h 8 " ? ?@(c 8 " ?h@(c%c%c 8 "(e 8 "h 8 "k " @%c 8 " 8:!?%d 8 "h 8 "h ?i"A%d 8 "h 8 " ? @%e 8 "h 8 "h8!h @ @?!&f 8 "i 8 "h8!h @ @?!&e 8 "h 8 " @%c 8 " ? %c 8 "i "?%c%c 8 " ?%e 8 "h 8 " &c 8 "hhi "A%c 8 "h @%c 8 "j "? %d 8 " D C@%d 8 "l6i6$e 8 "i 8 " 8:!!%e 8 "i 8 "l6i6$e 8 "i 8 " 8:!?%5%e 8 "i 8 "l6i6$d 8 " %d 8 "k6i6$f 8 "i 8 " @ %f 8 "i 8 "l6i6$d 8 "k "? %f 8 "i 8 " ? !k "? !@ %f 8 "i 8 "l6i6$e 8 "h 8 " @(e 8 "h 8 "h @ @(c 8 "h @(e 8 "h 8 " @(c 8 "hh @@(d 8 "hh @@(f 8 "h 8 "ih @@(e 8 "h 8 " D C @@(e 8 "h 8 " i "@(c 8 "i "i "@(c 8 "h @(d 8 "h 8 " @(c 8 "h @(e 8 "h 8 " @(f 8 "j 8 "i 8 "h8 " 8:%!h8! DEDC8:!C>j"@(e 8 "h 8 " @(c(5(c 8 " ?ihA(c 8 " ?hhA(c 8 "hi 8:!?A(c 8 "hh 8:!?A(e 8 "h 8 "h 8:!?A(g 8 "j 8 "i 8 "h 8:!?A(g 8 "j 8 "i 8 "h8 " ? 8:!?A(g 8 "l 8 "j 8 "i8 " ? 8:!?A(c(c 8 "h @(d 8 " 8:%e 8 "h 8 " k "?@(d 8 " h@(c 8 "h @(e 8 "h 8 " @(c(c 8 "h @(d 8 " 8:%e 8 "h 8 " k "@(5(5(5(c 8 "h @(e 8 "h 8 " @(c 8 "h @(e 8 "h 8 " @(d 8 "h 8 "h8! D Ci">(c(c 8 " 8:%5(c 8 "h 8:!@(e 8 "h 8 " ? 8:!@(c 8 " ?h@(c 8 "h @(e 8 "h 8 " @(f 8 "j 8 "h 8 "h8! j">(c 8 "h @(e 8 "h 8 " @(?(g 8 "k 8 "j 8 "i8 "h8 "8:%!h8! D?h8:!C +8: ">?k"@(?(f 8 "j 8 "h 8 " 8:%!h8! D ?ihhC +8: ">?k"@(e 8 "h 8 "l "?j "@(e 8 "h 8 "l "?j "@(d(c(c 8 "h @(e 8 "h 8 " @(c 8 " h@%e 8 "h 8 " 8:!@%c 8 "(f 8 "h 8 " @%c 8 "(g 8 "j 8 "h 8 " !68%"A%f 8 "j 8 "h 8 " !68%"A%g 8 "j 8 "h 8 " A%e 8 "h 8 " 6A%c 8 "(d 8 " V DUC(7 ?[c 8 " ?%c%c 8 "hi "@%d 8 "h 8 "h @j "@%e 8 "h 8 " 8:!l "@%d 8 " ?%5%d 8 "h 8 " hj"A%f 8 "i 8 "h 8 " h@k"A%g 8 "i 8 "h 8 " 8:!l"A%d 8 "hih @A%d 8 "hi 8:!A%f 8 "i 8 "hi 8:!@A%e 8 "i 8 "hh 8:!A%5%e 8 "i 8 "6i 8:!A%g 8 "k 8 "i 8 " 8:!?i 8:!A%d 8 " ? %c 8 "hi "@(e 8 "h 8 " i "@(e 8 "h 8 " j "@(c 8 "h @(e 8 "h 8 " @(c 8 "h @(e 8 "h 8 " @(c 8 "(c 8 " ?(f 8 "i 8 "h 8 " 8:! A(c 8 "hi A(d(c(c 8 "h @(e 8 "h 8 " @(d 8 " 8:%c(c 8 "h @(d 8 "h 8 " @(c 8 "(e 8 "h 8 " 8:! @?%c 8 "h @(e 8 "h 8 " @(c 8 "h @(e 8 "h 8 " @(e 8 "h 8 " @(d 8 "h 8 "h @(ch!@(e 8 "h 8 " @%c 8 "(c 8 " ?(c 8 " ?(c 8 " ?(c 8 " ?(c 8 " ?(c 8 " ?(c 8 " ?(c 8 "(c 8 " m?(c 8 " 68%"?(c 8 " ][?(c 8 " ]p?(c 8 " ]?(c 8 " ?(c 8 " ?(c 8 " ?(c 8 " ?(c 8 " ?(c 8 "(c 8 "(c 8 "(d 8 "(c 8 "(c 8 "(c 8 "(c 8 "(c 8 "(c 8 "(5(5(5(5(5(5(5(5(5(5(5(5(5(5(c 8 "(5(5(5(5(c 8 " ?(e 8 "h 8 " @(c 8 "(5(5(5(5(c 8 " ?(e 8 "h 8 " @(c 8 " ?(e 8 "h 8 " @(c 8 " ?(e 8 "h 8 " @(c 8 " ?(e 8 "h 8 " @(f 8 "i 8 " &c 8 " ?(e 8 "h 8 " @(c 8 " ?(e 8 "h 8 " @(c 8 " ?(e 8 "h 8 " @(c 8 " ?(e 8 "h 8 " @(c 8 "(5(5(5(5(c 8 "h @(d 8 "h 8 " ? @(d 8 "h 8 " ? @(d 8 "h 8 " ? @(d 8 "6 @(d 8 "6 @(c 8 "(c(d(c(d(d(c(c(d(d(c(d(c(c(c(c(c(5(5(5(5(c 8 "8 @[c 8 "8 @[c 8 "8 @[c 8 "8 @[c 8 "8 @[)* @%)*c ?A! +8:# " @! @(D! C@(C W -8lwcTC D#?TE2! D2! CATC28: "?TC C WDUC 8:"V?TTT D28: " @ToC38: "?TdE D28: " CATUD D# C2!@T@E D C48: "AT0C D"8: "D2! @TC D2+&8: " C@? T D @(C V D1! C@ D @(WE48: " D CA(C4!?()*, %)* 8:"V  @8(@[()* 8!"?%)* 8!?"?%)*7 CV @(c8!?8(@[)*7 CV5T5 ! VD C VpD C V=DVTc 6@@ C6@@ 6@@ 6@@6@@6"?!@% c 6@@ 6@@ 6@@6@@6"?!@% c6@@ 6@@6@@6"?!@%c6@@ ? !6@@ 6@@66"?!@%)*7 CV5T5 ! VD C V`D C V5DVTnc C6@@ 6@@ 6@@6@@6"?!@% c 6@@ 6@@6@@6"?!@% c 6@@6@@6"?!@%c ? !6@@ 6@@66"?!@%C W %%%%%%%%!%%%%%%%%%%%%%%%%%%%%%%%%C(c @()*7 6@@8&)*8! 8!>8(@[7(?[)*7 CV 68%"T ?@8%Di D CA ?@()*h ?868"A@()*h ?868"A@()*C6 ^V 5 ^UaT0W ,,!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,CWMMMMW ,,!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,CWc 6@@i 68%""@%%)*C6 ^V 5 ^UT`W \\!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\C W  +T,Cm??%C][??%C]p??%C]??%W <<!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<C W T C!??%c 6@@i 68%""@%]c ^- ]i 8L'68%&)*c 6@@ 6@@j "@%C W OOOOOOOOO!OOOOOOOOOOOOOOOOOOOOOOOCC WT"5 C^VTDVTETc%?%c8! @(c8! @(c8! @()*8! "?@()*8! ?8"?@(c8! C@(c8! C@(Dh @68!@@()*8! 8&c8! @(c8! @(c8! @(c8! @(c8! @(c8! @(c8! @(c8! @(c8! @(c8! @(c8! @(c8! @(g]7+ + + + + + + + +} +o +a +S +B ++ + + ++ + + ++S+3 + +<+ + +q  , ,+M +- ,!,#+ + + + &+ '+ +'+)+ + + ,+86]6]6666666 l|56 6 6 6  + + + + + + + + + + + + + +z +s +l +e +^ +W +P +I +B +; +4 +- +! + + + + + + + + + + +{ +e +V +@ +1 + + + +@+ + + + + +q +b +L += +5 +- +% + + + + + + + + + + + + + + + + + +x +p +h +` +X +P +D +8 +, + + + + + + + + + + + + +| +k +Z +E +5 +) + + + + + + + +++ +y +c +M += +' ++ + + + + + + + + +| +k +J +; +/ + + + ++++++`+B+8++++++}+_+U+D+"++++ + +++p+G+ ++ +++ + + + ++k+K+ + + ++c +M += ++ + + + + ++ + + +} +m +e +] +U+; ++ + + + + ++ + + + +n +B + + + + + + + + ++G +1 +! + + + + + + + +n +X +H +/ ++$+$++%++w+h+L)+B*+' +  + +.+$0+0+&2++n3+]4+T*6+>6+-7+'+(+:+0<+<+z2>+] +Q+H+? +- + + + +;+<+ >+>+g +W +A +1 +! + + +P+ +R+C+| +p +Q +8W+ H+ +J+ + +2MP+}LNQ+GP+- + + + +Ze+ + + + +o +c +R +< +,L+\_p+o+p+q+Q+s+ju+ogv+Phw+,V+^l+y+Y+{+[+}+]+l[+U_+8dr+a+ft+c+{+x|+[+@g+++}+j++++++p+{+j+Y+J+-q+z+{++h+R+<+$+ ++++++|+d+L+4+++++++s+M+'++++++c+N+?+++++++b+?+# ++ +++ + + +++z +h +Q +> ++ + + + +++ ++B +2 ++ + + + + +k +T +7 + + ++++++ +u +n+e +Y +:+%++++++t+J +>+++x+A+++++Y +R +C+2+!+++++ + ++ ++q +W+B +6+ +++ +++|+` +T +H+*+ + +++ ++h +X +B+( + +(+ +(+)+*+#,+$-+a%.+J.+5'0+(1+1+*3++4+ + +i +b+M +A:+0;+3=++>+6@+7+ +w +g:B+BB+* +C+ D+E+@G+AH+H+CJ+~DK+WEL+:L+%GN+N+ + +9+| +u +n<+U +I9+3:+;+KN\+LO]+MP^+]+t@+_ +SB+7a+D+c+]e+G+f+`h+ +t +Y +C +(S+ + +V+ + + + + +\+ +s +c +W +L>D 8  > + + + ++ >C9T gl^ M c 3&)* !8}# K  C! 2&WLL\`dhCg8m "&*.26:>BFJNRVZ^bfjnnw chih 1%1%gW(gR(8}! ]i 8L# 8"V8! ? A[? (gD(gE(8}! ]i 8L# 8"V8! ? A[? (8}! Y 8"Z(6 CyV? ([8}!?(Y8}!!?Z(6 CyV 8!6 A[[8}!!?(Y8}!!?Z(6 CyV 8!6 A[[Y8}!!? Z(6 CyV 8!6 A[[Y8}!!? Z(6 CyV 8!6 A[[c!dIG 8!I4!cI M c!?( dhih d 8}"?(d 8}"?(e 8}"!?(e "?(f "?(8}! ]i 8L# 8! ? A[8!h @Ic!3!h!h!E DCA @?(8!CVc 8"c @Ic!3!h!h!E DCA @?(8!i 8"G MG F E D C>M gO(d G ^h G ^ 8} #j G ^kG ^8} #  ci]Y  1%gM(d(c(g(gF(g4(gJ(gO(g(g9(g(g(g (g (g(g(gK(gL(g1(g2(g(g-(g.(g/(g0(gH(g+(g,(g(g(g (g"(g$(gG(g#(g(5(gA(gB(g7(g8(8}!?(8}!?(8}!?(8}!?(8}!?(8}!?(g(8!h 8}"? A[gn 3&)* 8}#  C! 2&W !IC 8!@I !1%C VD V I !1%cI8%56 @[8!Ig" !dIY3!ZT; CyV0DV+C VC8:!8:!hIC ? A[56 @[T[cIg" !1% !1% dhih  !1%C VC8:!8:!hIC ? A[56 @[ chih  !1%gj^ M g 3&)* 8}#   C! 2&W -=IUc(Gh G ^ 8} #  ]hih  1%d 8}"!!1%d "!1%e "!1%c !V1%8!l 8"c 8}"!d 8}"!1%c !XV g 8!8" chih  !1%cI ChA[c 8}"!1%g 3&)* 8}#   C! 2&W chkh$chih$c(! W]oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooor(CC D C@@I2%cIcIcI(C8:%)*W'/7A5 8 f&C8B!6 8 f'C6 8 f'5 8 f&5 8 f&C6 8 f'C6 8 f')*G VCTC F FoVTDn > M ()* ~V ~V(h8L'^ _ _ 2& 2&] ,ch &]h 8L#68%"]](]h 8L#68%"]]p(]h 8L#6 8%"]m][(6!8%"]Ym()* 8}" aT AT  8}" aT AT lpn8B%)* 8}"  8}"l p 8}"ldpnn c!Vgx(8! 8}!?A[8B%n#u(W  g ((g (g (b(g(C(Chz(ChC8L#I(8}!h ] }U\ ^! zUc(C]C~VeC]p] C]hhC8L ICCS(IcI(5"?6#l81"l] ?h? + + +~ +i8?h? +Wh? +Li? ++ +w +f +K +0 + + + +N6$     "$&+-,]l@G`oJQc?  ,t+ + +   > &9%TY8%! V  LT2!TcZ(8% CyVDW c(2%[)*Yc8%!8%"h8!Z(8% CyVDW \\\[5&8C^V![7( CyV5'8C^V![7 CyU 7( CyUT8!6(8C^V!?8(@[[gL8!U g8!Vc(%,%+ +Y8 !8 !8 !8! >9)T)*W C6* 8 f'D C26+8 f$D2 C26,8 f$6-8 f'+8: % &)* DS6.\  C W 9Jdv5/ \'C60\$ 51 \#C `#D 2#E 2'52 \#C2]$ CT63 \ D2]$ 54 \#C4]$ CT65 \  D2] E`]$  D66\ C 2'D8%!67\  C4R] E`]+ ^$ C +68 \ D 2'C CT69  \ D3]$ )* CR6:Z D 1')* DO6;X  C V C6<X D 4'5= X')* DM6>V  C W "7DUx5? V'CC6@V$  DC6AV C 2'CO6BV$ 5C V#C2W$ CN6D V  D2X E \' C6EV D2X$ 5F V#C4@W$ 5G V#C2W$ 5H V#C 2#D 2'5I V#C 2#D 4'5J V#C Y'5K V#C 2'CC6LV$ )* DK6MT  C W !)6Cf9Niz 2?Tf5N T'CL6OT$ CM6PT$ CQ6Q T  D4BU E 2' C6RT  D2V E4@U$ 5S T#C 2#D4HU$ 5T T#C 2#D4@U$ 5U T#C 2#D4@U$ 5V T#C2U$ CL6W T  D2V E Z' C6XT D2V$ 5Y T# C4FU D2V$ 5Z T#C 2#D W'5[ T#C 2#D W#E 2'5\ T#C2U$ 5] T#C 2#D 2#E2V$ 5^ T#C 2#D 2'5_ T#C 2#D 2'FRCC6`  T D 2#E 2#G 2'5a T#C 2# D4V E4V$ 5b T#C 2#D 2' D6cT C 2'CL6dT$  CC6eT D 2'5f T#C4DU$  CC6gT D 4(#E 2'5h T#C 2'5i T#C 2'5j T#C 2#D4V$ 5k T#C 4' C6lT D 2'5m T#C 4('CL6n T D 2')*5o R#C 4#D V S$)*V CC T'5p T')*GE6qN 6r N# C1O 5s N# D40O 5t N#E 3#FM6uN 5v N#G 4 P$)*W 5w L'5x L#C 40 M$5y L#C 42 M$)* 4 K$)* D?6zH  C W,C@6{ H D4I$ 5| H#C 3' C6}H D 4#E 2')*5~ F#C 4#D 3 G$)*D C W;]5D#C4'C ;E?D> C6D F4' C ;DCC6  D E4' C ;DCC6  D E4' C ;6  D C4#D4' )*G96B  C=6B 5 B#D 4*# EC6B 5 B#F 4')*G76@  C;6@ 5 @#D 4(# EC6@ 5 @#F 4')* D56>  C W!/WoC66 > D4?$ 5 >#C 3'5 >#C E# D4@ E 4#F 2'5 >#C 2#D42?$ C;6 >  D4,? E 2'5 >#C 2#D 4')*5 <#C 4#D 3 =$)*D C W-PxC66  : D4#E><$ C 1D4CC6  : E4' C 1E6D4 CC6: F4' C 1D9CC6  : E4' C 1E6D9 CC6: F4' C 16  : C4#D4' 5:#C4')*G/68  C368 5 8#D 4 # EC68 5 8#F 4')* D-66  C W ;SC.66$ 5 6#C 3' CC66 D 2#E 2'5 6#C 2#D47$ 5 6#C 4 ')* 3 5$)* D)62  C W 2H^p CC62 D 4'5 2#C4 3$  CC62 D 4' CC62 D 4'5 2#C43$  CC62 D 3'C*62$ 5 2#C 4'5 2#C43$ 5 2#C43$ )*V5 0#C 4'5 0')*W"35 .#C 4'C&6.$5 .#C 4'C&6.$)* D#6,  C W!=QfC$6,$ 5 ,#C 3' CC6, D 4#E 2'5 ,#C 2#D 2'5 ,#C 2#D 4'5 ,#C 4')* 3 +$)* D6(  C W 7M^t5 (#C 4'C%6 ( D4)$  CC6( D 4'5 (#C3)$  CC6( D 4'D CC6($  CC6( D 4'5 (#C4)$  CC6( D 4'C 6($ 5 (#C4)$ 5 (#C4)$ 5 (#C 4')*CC *#D 4')*CC (#D 4')*CC &#D 4#E 4')* C6 D 4')* E6 C 4#D 4')*FCC6  D4 E 4 $)*FD CC6   E 4')* D6 C  $)* C6 D 4')*5 #C 4#D 4')*5 #C 4#D 4')* CC6 D 4')* C6 D 4')* C6 D 4')*W!D8%!C6 E 4  $5  #C 4')*W5 #C ' C6 D 3')*W !,5 'C6 $C 6 $C6$C8%!6 $)* h')* h$)* h$)*6 $)*8%!6 $)*C6 $)*6 $)*6$)*V5 #C '5 ')*V5 # "8: "5 '5 ')*g jp8L"6 8 f# 8 f&)* 5 8 f&5 8 f&)* 5 8 f&5 8 f&)*W 5 8 f&5 8 f&5 8 f&)* 5 8 f&5 8 f&)* 5 8 f&5 8 f&)* 5 8 f&5 8 f&)*W%/9CC6 8 f'C6 8 f'C6 8 f'C6 8 f'C6 8 f'C6 8 f'C6 8 f')*C6 8 f$)*6 8 f$)*DC68 f EV 5 8 f&()*DF C6 8 f$E Fo E DC68 f$+ + ,B+ + +/ + + + + + + +e +< +  + ++++   ",*!Mex=:Mlo=I'F&AVkE DC CDD^ F?A>(  2#' 2# ' dhhAh>()*VC CCyVD(E 2&5?[)*V/D CD D^ CC CyVD(E C&CTE 2&5?[)*VD CD ^ D(CTE 2&5?[)*VE DC@ C@2'V C D2'(hh')*VFTc VFTc  }VDV:E DC VFTc VFTc~V # ' VE# DC#' 56 @[ }VIV?CE VFTc VFTc~VD #' VED E# D C#' 5 6 @[')*VFTc VFTc ~VT>()*C &!V5 T5  D6 8 f$D6  8 f'D6 8 f' Eshz( Eshz( Et K(E DlA(CCI(CI(C8%"I(C(C()* ^()*D D^(Chy(C8%!68%" D8%&C8%!68%" D8%&C(D(E DCA( hA( CA(c CA(djh? + ++ + + + + + +y +k +^ +U +L +!9T)*W)W::C C8 &W++D D^VC C2&(WC C2"VD D2&(c()*W C 8 &C 2&C 2"UD 2&(W C8%C2%D2! C2!8%&)*VCT W 3C8%D !V5 8%"68%"T68%"C ?2"8%&5 D ?2"8%"68%" C ?2"8%&W C(C2%56 @[W C8%D(D2%c(g ,,#,D+ ,\,,    >9TC(5 F^VF(C(c C@ EU6@T6 F^V F@T GV6@T 8:%)*VD C VsC6 ^V D V5 C^VT=d i>(T/D V(D C V5 C^U d h >(c h >(5  ^V c i>(c6!h>(c6"i>(5#81%+n +5 +! + >9$T )* ^()* y(E()*E Eo(+ + + A + ? 8! 8! DECA>9%T V(CC VC2%(C W  D! F2%C2%(V(C CC2%()*W(CV 8:!??(((F D C V C 8%"2&E 8%"C>()*V D C8%"2&()*D!C W  C C T @2&(] C" I(VC C^VD%D2%D! C W  C&c()* 2,C %D! C W  C2%(D8: &D! WC VC%T D8: &c()*C +8: "D!C W    5&6 @[C 2&G +81 &)*Wc(E !F !G 2&CC 2&VhzV5'6 @[(CC VC2%c??(C W ### ### # ##C VC2%T C2%(5(6 @[!%)*VC W -8Hrc(V(5)(F!E!D!C>(C 8: "?(c?D8: "CA(CDC VC D8: " C@?? !@(c? !@(F !E!D!C>(CC h2'5*6 @[5+6 @[(D +K8: " C!@ (E 8: "DCA (! D~V Do J2&(! D{V Do J2&(WD8: "E2%C%D!E2%)*W$c( C^VD 8"VF?(G 2'CC 2')*W *5,6 @[G D 8"V( 2" FE C>(C C2" I7%?[)*V&D C C !^V8:! D >(@2' 5?[)*V5-6 @[(D Ci I C@2&D C C V5.8%%I(c!h" 8: "c II?h8 'CCIc8 " V C@(c? ?h8 # @()*C @! I()*C @! I()*C @!? I()*C @!? I()*C @! I()*C @!? I()*C E|VD @! J()*!C ? IC W A AAAAAAAAAAAW 1 11111111111C VCVDD{V !?I(!?I(c(C E|V C @%(c8 " Vc? @ CI?h8 '(WD CI(D CJ()* h'!V ]i 8L'(]h{Vc ^l?y()*Y C"IZ(8% CyVc([)*C> IC @I(c I(C +8: "cI()*E%C!D+8%G &D8: "E81 &E%C8: "E WcTC+8: "T C+8: "TG VC%(&! D~VDo J(c I(D CI(C +8: "C +8: "cIcIcI(C V5/6 @[C 8:"XVC @Ic?C @I?? I()*C @@I(!c(d??(D ! WT>C V C!??TT*VFTc?GVTE D8: " C>T C@()*C+8: " G VC D8: " C@? GVFh >()*C W !)AJJO [gc(D !E %C 8: &D 8: &C DC V !CD8: &%E !F %C %C "! %C !D 8: &E 8: &] c(50l 8L#^(!C W  d(F2%c(!C W 33333 333333,C %C! C W  d(c(c(C W     516 @[((FTC 2%! C W   (,C %C !U%(ch ] }U\^ lpn zUcgiv s? giv o((D! Wc(d(! FV C+8:&(! GU#D!C W    526 @[c(d(h&h&C W  d(c(C W  d(c()*?%&)*C A(536 @[7%8!8%8!8% E D@8! +?lh jpl? + + + + +j64 ,, ,,,?+M ,,+9 ,, + + +  +Z + + ,'+- ,X+ ,o+y , ,c? +Wh?h? + + '),^')+ + *,,Z+l +C ,c,c? + + ,+ + + ,+ +{i8 !h? +P +: + + ++++t+a+M  D+ , +I      !#&(+..13579`b=?CIKHNQQTVXZ\^`bgeknnqsuwy{><M95T* )*W D2 C2668 f$D C2678 f$C68 8 f')*V !C "D 2$()*VDC V"!2$ &()*W-------------D C2698 f$D2 C6:8 f$ 3&)*W22222222222222C E2D36;^V 5<8%"T5=6>8 f$  3&)*W  C6?34"6@ 8 f$ 3&)*CVcI5AT5B  6C8 f$ 5D 8 f&)*WC +$C D6E8 f$)*VC V 6F8 f$c()*W*;JTiD CV5GT5HE46I8 f$ C D46J8 f$C D3!6K 8 f$C6L 8 f'D CV5MT5N6O 8 f$F +q44  +B D EV 5PT5QT 5RT5S CV5TT5U6V 8 f$ C6W 8 f#d? E D 4+8:#5X 8 f&46Y 8 f$c()*V=D C D C V2! 46Z 8 f$46[ 8 f V5\8 f"c2' VCV5]T5^6_ 8 f'(V 5` 8 f& 5a 8 f&5b 8 f&)*E D + 6c43" C6d8 f$ )*VDC V2" 6e 8 f$ &()*V"DV6f41"6g 8 f$C46h 8 f$(5i 8 f&)*VCC6j 8 f$()*V6kC"6l 8 f$()*W=+ CD 6m8 f$ C E2D6n^V 5o8%"T5p6q8 f$ + D +~3"C 6r8 f$ )*W:DC CC6s8 f$FC CEV5tT5uDV5vT5w6x8 f$ FC CEV5yT5zDV5{T5|6}8 f$ )*W%c(E2 D2C6~8 f$ C 6 8 f$CC6 8 f$)*VD C V2 C68 f$ C&(68 f')*VC6 8 f#D +8: &()*W2]oFC DECV5T5G5T568 f$ FC DECV5T5G5T568 f$ c D CA46 8 f$D C V 68 f'C 68 f$ DC CEW 5T 5T5T68 f$C D5T53'E 5T5 + D CC6 8 f$ 5 8 f&5 8 f&)*W"9C68 f$c(C +"68 f$C +"68 f$)*c(5 8 f&68 f$)*WCC6 8 f$c(5 8 f&V&DV +"68 f$C68 f$6 8 f'DC CC68 f$)* +8: &)*F EDC +  + +g  +PWTDT +"  43 , G 68 f$)*E D C V*C V6"6 8 f$  68 f$ V6" 68 f$ 68 f')*EC CDV5T568 f$)*V@D C D C V!CCC6 8 f T C6 8 f hzV 268 f$ ()*W'CC DC68 f$C V 68 f$(C D C ')*7O CyV 5 8 f&5 CyV 5 8 f&5 CyV 5 8 f&C6 8 f$58%%58%%58%%5 8 f&)*V +"6 8 f$()*D C6 ^VT68%" DU5T CU5T568 f$)*6 8 f'5 8 f&)*6 8 f'5 8 f&)*WVVVVVVVVVVVVVVAD V)C DV624"  68 f$ C3  68 f$ TD VC3C68 f$ 4&)*Waaaa#1AQaaaaaaaC6 ^D  !6 $C h} 6 $C6 ^ 6 $C6 ^ 6 $C6 ^ 6 $ 3&)*W'1<IS]gq?[C644"6 8 f$C6 8 f'DUC &C!6 8 f'C6 8 f'C6 8 f'C6 8 f'C6 8 f'C644"6 8 f$ C%Ci3!!6 8 f$Y C68 f#Z(6 CyV5 D^U 5 8 f&[C6 8 f'C644"6 8 f$DU C6 8 f'4!6 8 f$)*V+C XV5 8 f"D4!C6 8 f D h2'()*VXV 6 8 f#C "D h2'()* ,i !')*,&' )*Vg( 8 C" 8 f#V g) 8 C&(]H <5(68" ] ^AVT68" ]^AVT68" %5 ^DV5(5( ~V 58%&^ 0: (-(2%] ,c %)*!V 6 8 f'6 8 f'5 8:"U-c ^ aT{T[_TAd(c()*Y"Z( CyV 5 8 f&[5? + ,+ + +o + +   + ? ,,+c +T " +E +6 " ,+hWw? +  +  ,9? +? +? +?   %(, mG III+ ,  + ?%  &>)9T)*W)Y DC86"Z(6 CyV([E D C 2"A(D 2" C 2"@()*W0=Y EC86" W 581!TCTZ(6 CyV([E D C "A(581%)*85 ! C W  C(C 85"FV5!Tch85" ?IW  "Lc? D2!8: " C"ATDC VC D2!8: " C"@?? C2"@TF D CyV75D{V75 ^V2"E >T85 ! 2"?TTHTMC85 ! D85 ! C W YYYYYYYY YYYYCC W  T6C V%D VDVT$C ? I?TTTT TTFU(75 DyU 85!UC W  dTc C W     56 @[CT. 2"T'C85" FVC!TV85!V C85!Th@ @?85!?IX i2!85  G VC ] D C"@? M?T?TE2!8: " D C"A T 2!h85# I(FUE FV!T D85" 85"? I(()*W#E 2" D !8: " C "A(C "?(E 2" D " CA()*VgC W "9CTHC 8!D @ ?#2' C 8!D @ ?#2' C 8!D @ ??#2' 8!D @2' 8:!@()*W;DC W,Y EC86"Z(6 CyV([E D C"A?(581%C 3"?(C 8! E ?#2"D2" A()*h  # C D3!8:')*W*7AND " @(E D "A(D  " @(E D 4"A(D 3" @(E D "A(E D "A()*V C 4"?()*c E E!# D D!#CC!#>()* ! 86')* +86')*FV7TD C !8: "@()*FV7TE D C "A()* "h85!()*F E " D "C!8: ">h85!()*G F VC "? E "D"C!8: "> FXVc85!(E" D CA(D!8: " C"@()*F +8: " E D +8%G"C">(E!81 " D!8: " CA(E" D CA()*FV7TGh GG VC"?FE WcT"D C+8: "@TC+8: "?TDC!8: ">h85!()* "h85!(C85 A(gI()*W)Y CC86"Z(6 CyV([E D C "A(581%d E D C>()*F E 86#DC>()*F ED86#C>()*F EDC86#>(c868686> + + + + ,,P+Sl? +D +3  ,+ + +X  , +  + +++z,   ,1+L +  "%')+->9T8 ! 8!@()*7 @ &)*7hhhihhh>8hhhihhh A@hhA@?hh>8hhhihhh!A@?hh>8hhhi6hh>hh85"8h6hihih@>hh85"8h6hihhh!@@#A@hh"A@?ih@>8h6hihlhhh85"@hh85"@hh85"@hh85"@hh85"@hh85"@>hh85"8h6hihhh@%A@hh$A@?ih@>hh85"8h6hihih@> +   #  #  #  #  # # # #  #  #   #  #   #   #  #hh@@@?85!@ #hh@@@?85!@ #h #h #h@ #h #h #h@ #h@ #h #h #hh@@@?85!@ 'c?h @A85%c?h @A85%c?h @A85%c?h @A85%)* !C @@I(c? +8 !8 !6 !6 !6 !6 !6 !6 !6 !6 !6 !6 !6 !6 !6!6!6!???????????????h?hA85!h?hA85!h?hA85!h?hA85!h?hA85!h?hA85!h?hA85!++ +h?hA85!h?hA85!h?hA85! +6-!6.!6/!60!61!62!63!64!65!66!6 7!6!8! ? ? ?6"=!6#>!6$?!6%@!6&A!6'B!6(C!   !#%'.58IKMOQSUWY[]_ace+%h @ @@@@@@@@@@@ +t8: "l8!GC8:!  -/13579;=?ACEGI.02468:<>@BDFH>#I9)T85 !85 D~VID85!o JC W 4 4444444444C 85F"I(C85 ! 285"85!XVD2%(285&(75C? , !85%!C()*V@C D C V?^V E A(D2$ ?^V E A(D2$ ?[)*hh $)*V,C CDE8!> _D2" @@()* 8:!^ ,h &)*dhlllD@C8:!Ch8)> ()*VxD C E D VCT V2#?@T 2#?@ VC! ?85!! 85G"85G!hzCCCC 8:!  > D C@@(DTEhyV()*c?h?h? +8: " ,Ihh ' ,f+ +ll6*Aih :lh6+> +6,? ,S+   > 9-T)*W!C86. 8 f$D C86/8 f$C860 8 f$)*7z 8%."D C@ 8%2"8%+!8! E C@@ 8%2"F8%2"(8%:! Ya7z]81"8z ^VA8%F!7z] h8z8L# h8L#^V7z ^V51T52  @@[?@[!8%F!Z( CyV 8%F!D@[5 CyU 5 CyU[8%F!?@[8%B! 8%B! 8%B! DC>(53? + +E + + >94T)*W7YC YGG" DZ(6 CyV8!V 8!!E(5?[[ C2"CC" WCG D86" C(5?[C 2"CC" W5?[D CC')*W;jC Y GG"Z(6 CyV C ^V5?[ ! E 8!?@([D C2" DCC" WCG 86" C DCA@(5?[ C2" C D3" C DCC" W5?[C DD C  C# @@()*W<oC Y GG"Z(6 CyV!C ^V5?[! D? 8!?@([D C1" DCC" WCG 86" CC" DCA@(5?[ C1" D2" C C@ DCC" W5?[C D D C E G C8#8" @()*W?(E 8! CA(556 @[)*W(Y C"2"Z(6 CyV([)*V?C W>k C8! A DD W  T   D  2  D C@@(C8 8!A  D 8#  2  D C @@( C8! A D2  D C @@(C 8!A  D 8#  2  D C @@(C8 8!A  D ?8#  2  D C @@( C8! A D2  D C @@(7 C8! A  D2  D C @@(h@()* >D%F8 D@ C8!86#L(E8 D@ C8!86#K(D()*WVPD C  8 "C C @ 8!86#I7CVD Ch@ 8!86#JD W  c( (D C  8 "G8 @ 8!86#M"G8 +o8: "@8!86#M+?8: "" +8: " C    I(D 8 " 8-"E C @C8!86#K (D C  @D!G C @ 8!86#M   C G C @8!86#M  C   I (D C  8"G8 @ 8!86#M  C   I(D 8 "G  C @ C8!86#M  (D 8"G  C @ C8!86#M (D C F" W+7686868686868686868686> ?(C8686868686868686868686>  h E!  D?h? C  444 1 + 8:#?( gh8" ED8"C>?(CXV !8&(dI()*EXV 56 !8!VK8! @ 8"Vc(c? + 8#57 ^Uc ^l_yUc ^l#yXV +C%( E$)* 1+81 "]C@E# I G A M ()*7CV]D@ E# J((D()*C D "@ E')*C D "@ E'GXVCXVEDA8&(C8! A 8"XV0c! ! 8#58^U c^l_yXV +C%(?()*G   +4  "" EXV598!V8!   +s8: "]E +28:# KF +8:# LG +8: "@E# MG@E# M G A M ()*]G@ E# M G A M (GXVCXV D@8&()*D EXV5:8!V65; 8! A 8"XVc !  ! 8#  + C!]E8-""@E# K G A M ()*]G@ E# MG  8 4 @ E# M G A M ()*]G@  E# M G A M ()*]G @  E# M  G A M ()*]G @ E# M  G A M ()*V  C" D2&()*W(C D86<8 f$C E8D86=8 f$ 5> C D6?8 f$)*7 G " ] G M G M(] G M G M G M(G (G (G ( + +'G (G ( + +'G(G( + +'G(G( + +'F(F( + +'E(E( + +'C(C( + +')*V CD? 8!? $()* D C 8!$)* CC" D A $)*V+ C" C DC" W CG +86' 5?[ G +#  +8 ')* D C 8!$)* C D A $)*V)C" C DC" W C! +86' 5?[ !+' )* F" ')* G! +8:')*c! $)*c85*!c8!88!8" 8%)! Yg7CV5@  >  84#8%6! ? 8!?8  F C@@  > ? 8# 8  Z( 8%6!81![8%! Y F8:"Z(6 CyV5A6 @[[)* " D(CXVh8"?8&()*VCT7 VC U$EU 5B8!Vc? +C!" G' ' )*! D 8!?')*W,@UjC D 8 "8 !h  h8 !$ D 8 "C8 !$ D 8 "C8 !$ D 8"C8 !$ D 8"C8 !$ D 8 "C8 !$ D 8"C8 !$)* 8h  D C  + )8:  ]G @ M ()*W!*3< D Ch$ D C' D C' D C' D C' D C' D C'!%)*8!  ?  @()*GV(G V  ] CC@? M # ]i M (5C6 @[)* ? $)* ? $)* ? $)* ? $)* ? $)* ? $)* ? $)* ?$ )*Y G8"Z(6 CyV0 @ E8C8#8"  G F  G8#([)*E WF D Ch?CA85!8-$c(F h?CA85!8-')* + E WC %c(85 !C 85E"XV3C 85F"859"C W  EC Ch85)#281 &c()*Y G 8:"ZT6 CyV5D6 @[[ , %)*Y G 8:"ZT6 CyV5E6 @[[ C85F8:# 859&85 !85F%V7C D C85G"V75C C +85G # IC85E"VC?(D2%()*,G %C W  d(c()*] G 85C? @@ M ()* " D6F Eh8"^V "cTE"E"()* " D6G Eh8"^V "cTE"()* " DD! "()*G W1C! Y"ZT6 CyV5H6 @[[ 8! $ YD6IA8#Z(6 CyVc([)* " DC! "(C W  C(5J6 @[)*Y"ZT6 CyV5K6 @[[ 8!&)* " D 8!"()* " D 8!"(%)*YG@8"ZT6 CyV5L6 @[[ + G @8 'c!c%)*E @ Y8"  +8 #Z(6 CyV  8'[)*YD6MA8#Z(6 CyVc([)*YGA8#Z(6 CyVc([)*YcG@8#Z(6 CyVc([)*YcE@8#Z(6 CyVc([G (G (G (G (G(G(G(G(F(F(E(E(D(D()* + +$C(C(G ()*W 2 ! CG& C" DCC" WC!D86" C(5?[5?[)*W < ! CG&DC" DCC" WC! 86" C DCA@(5?[5?[)*W:aC YGG" DZ(6 CyV8!V8!! D?(5?[[ C"CC" WCG D86" CC&5?[5?[)* " VC(5?[D()* " G VG +81 " C CA(5?[D()* " G V(C F E85!VG +81 " CA(5?[G (G (G (G (G(G(G(G(G(G(D(D(C(C()*W3 ! CG" D( C"CC" WC !D86" C(5?[5?[I()* @((c +8 # 8!8: &5NI8!8!8!8%5O ^V5?[Y 8"?ZT6 CyVcT[ VC VC(5?[Y5P8%"8zC81 "ZT6 CyV c 8#5?[[ &7CXV CC@@[()*84! C D E F ?8!?8C    > C^V  C@@[F "G +8: "?8#(  D C8$)*Y+8: "Z(8 CyV E F DA@[[)*5Q6 @[)*5R6 @[5S6 @[)*5T6 @[)*G G # G G#8%" E E#8%" C C#8%&C%Wd(c( F"!VY F"cZ(6 CyVd([()*G! +8:&]i M(D C8&8%%I()*C I++81&)* 8"i DIC()* 8"i DIC()* 8"C()*C @ 8'??()*C W C(C[YC! ?IZ( ?I[chhA()*W d I(d J(d K(5U6 @[+?lh8"lh8" + +lh8"6V? + +{ @8i?? +[ +K +6 +!+ +   > +hhhhCCCC C C C C CCC> + + +V +M + + ? +? +? +?6W?lh8"h8! +  +" + +}+d+K   ,. + + + " + + " + +" + +" + +" + +" +y +p"+1++ "$&+n%'),,%'+ &(+ + + +" + + +x" +n +f" +[ +R" +F += " +1 +( " + + "5+5+3+4+y9+A9++ + ,+ +u +]  #@+ +++ +e +H +6 + +#,+% + , LNQSUWY[, &8fD  +p MIKI LI +O += ++++++++ +y +l ! !!!!!   + ,!#(+ X+ js+Z+nZ+H^+=%`bn+ +o+u (Pt+$ )Qgtw+ +[ +C ++++++w"$8) # +y+ +k +*  |TVYQ\^`)+**/9;=?ACE<<@BLNPRTVXZ\tv{~xz|R>P9XTC W 0 000000+0C D C@@I(C2!C E D@@I(C2%2&)*C W m 9mmmmmmmmG FED YD C "@ZT6 CyVcT[>(C 2" Y!GF E D E D " A>Z(6 CyV([G FED2!">()* 8:&C(! +8: &C(! +8: &!8:%C%cI+8: "ChI(cI!ChI(F! E D C>()*W  %:P`ky(E D C !A(C 8: "?(G F 8: " EDC>(D VE C !?CA((D C +8: "@(C 8: "?(E D ! C !A(C !? (F%)*W << < (3 C %C 8: &F 8: &D 81 &C +8: &C !D %c(+ +*h? , + + + + + +  ,78     >  9YTi! C W  (C2%F2%WE2%C(W E2%c(E2!in()*VbVODC CDC C ^V  DDA@  2$ ^V    @2$   @ 2$ 8:! 8:"A( 8:" 8:!A()*V/C D 2" D85! W(EV c F855"( @(!85 D~V\D 85!o JC W F FFFFFF+FFF75 zV3?[D85 !hyVE2!F2%C85 ! 285"85!XVD2%(285&()*!85 D~VD85!o JCC W [alC@@I(VoY&CCh8X #85 D!DzV C  @@IZT6 CyVcT[Di2!8: &Ch2&Ei2"Fh2&C85 ! i2!85"85!XVDh2&(i2!85&(h" V C D CA[()*!C D}V;75 DzV375 853"C W  EC 2!85"Tc 2!85&C @ I()*!85 DzVR85!V D}V 853&C D}V$C W  C!XV c EIdTdV75 853" 2!85&(!C D{U 75 DyVc(C W MM "MMMMMM<I75 853"D2!E2%CT/C!U&75 853"c EID28: &75 853"C2%ETc(85 853"28: &)*! D}V78X!V 8X" VC{Vch" @@@[C W ]C "{VBYC"852"  2#Z( CyV""{Vch"@@@[2"85& [TD C VCC"{V c 854"2' T}Ty75 C^Vp E!D}Vfch" @@@[C85 ! G V!CC"{V85:!]h M?ITc 853"2"85&C "{Vch" @@@[ 853"2"85&()*EV''5Z()*!85 DzV| D}Vv75 853"C W ^^ ^^^^^^^^SD#E2'D Y C8X"GZT6 CyV  +8: "T[h EI 2+z8:' E"8: &2"85&()*! Y85G" D8%" JZ(6 CyV @ 85G#h @2"85&[)*W!c(CD 8"VE?(G 2&CC 2&)* 2#! C W  C(75 DzV(75 DyV75T+V!C C!85D!V DVDTCT75T5[6 @[85 zV5\ & C 85"ch"V*C 8X!V 8X" V c @ C 8X#TTTc?IW tttt ^mtttttD CC # C " VC !zV?TTT#CC WTC?T? 8: "ATc? C!@TD85 ! V F!?Th85#TC85!h85#TC85 ! D! C W YYYYYYYY YYYYCC W  T6C V%D VDVT$C ? I?TTTT TTk75 Dz C W (   ( 5]6 @[CT#VC85" !TC85"VTC!h@ @?85!?I  i85 ?T  85# I( )* yVc(V  D2" C@(5^8%%)* @ @(C%hhh ?I()*! ! 85D!V$75 DzV(ch"C +?@I(Y1 8: "85!VcTD " hzV"V5?[CZ(6 CyVch" C W   T  @@@     2 C W HC85 ! D! 85!V75 Dz ! V!85!    85  ?TED8: " +8: " 8%"  +8:#8%"  C2 @ T C h85# I( [)*8:!8:!zVc@[C IY}ch" V@ C C W  T C D #  85+ TT5_6 @[ I  h# Dh?I  C# C C!8:#IZ(  CyVI[[)* " Y2"ZT CyVT[ 8X!V 8X" V  C8X#()* " Y2"Z( CyV([)* "! C W  (DC V#CD VC!85!V c? C@D&((()*! ! yV?[C 8:"XVC @IC W gggg zgggzgggC Y"  2#Z( CyV?7CV/!U&!U Y8X"!ZT6 CyVcT[Vc(2"85& [7CVc(2"85&c()*yV?[C W Y) 8:"U7CV?[ @2#85"Z( CyVaYJ " yU 8:"V?[C W & & 7CXV  @ 2#85"TcZ( CyV7CXV?[([[7CXV 2#85&(c()*! C 8:"XVqC @ IC W MMMM aMMMaMMMC8"V?[Y "   2 Z( CyV7CVc(2#85& [7CVc(2#85&c(C!y()*Y+8:" D?Z(6 CyVc([)*VbC+ C " D " V@C C VVC!yVc( T0T,VC C VT 856" 856& T UD2' c@[c@[)*Wc(D 8"UG 2&(CC 2&)*yVc(!! yVc(C C W 2?22 22222222DU"W ... ........DUC C8"Vc( W  " " ! ! yVc( Y@ G"Z( 6 CyVc @ G#C C W +t)Vc(W  5`6 @[W  C C ^U85-!U%85-!UDD2 EE2$T=W 999 999999999C C3$W  D D CC4 $W C C4$W 4$W C C4$W C'D C U&W  TmDUC 2$W  TH2# DC$W ------------ C C8"VD D^VE E3$c@[[5a81% )*8:!8:!zVc@[1#8:'F D"G E$)*!V!XV5b6 @[!! C C" DD   4 DhzV!ChyUEhzV!ChyVc @[C34+8: & )*85 ! 85 ! VV T UTc @[c(D85! E85! WgC V>C WTC V C $ TCTD   8: &WTiCVTaTZDVTUTNC"WC VD  C 8: &DUT WCUTUCT WCUc(c@[D85! Wd(c()*85 !85 ! C C" + FVD 8:"U FVC 8:"Vc @[E4 +8: & )*!U !VGhy()*  + Y 8X" 8X"  8"V "V4 TE E W[3WUD D^VK4 iCC4 TYW%O4 ACC4 T1  "V  "U !U  !V "V c@[c@[Z(6 CyVc( [)*VVCC4$ VT(c@[)*V3V7C C  EE C C^VD D^VD D2&c@[VT(c@[)* 1,()*V3V7C C  EE C C^VD D^VD D2&c@[VT(c@[)* 4,()* C;#Vc(! ! C;#Vc(C! YNd)ICC W QW   3"V   3#T   C*# C-" 852" D C'#TC W  ( T  3"V   3#TNT{DVTDVTC 8"V(EC 0"UEC 0"U  D C'#  852"TTmTTlW a*aaaaaaaa aa/C ,# D C'# 852"T?W 4 44444444444 C*# C-"852"D C'#T  3#VcIZ( CyVVcID @@@[[)*C"C" C#V C#V @( 2&C D@()* 9&, " D C D D8%" C%# C%# C9#Vc(!!CVYC8X" C8X" V7C V%C }V   C8X#T }V   C8X#T   C8X#TV  C C8X#7CVW5!{U 5!{VGC W  T DVTT C W  T DVTT@T @ D C  C9#U   C9#U   3$Y  3 Z(  CyVD +8: "@[[')*CCzV/" W X XXXX!XXX8XXC&#C)"852& W Y4YYYY YYYYYY4' W BBBBBBBBB BB+C(#852& W " """""""""""C&#C)"852& C 6"TC&#852"Ychh W 6JW  t  TQcT FDCT C W  y T% C ^U7CVR85-!UK85-!UD D D4# E E4# F85 ! F85 ! VVcT C858"T C858"TTTTTrW  TC C 3#TQ C W tttt tttttttt D D C 8"VPC2CV-!U'!U!YC8X"!ZT6 CyVcT[V  3#T 3+6ci#TTTWT" DVTC W nnnn nnnnnnnn C WTU DVTLC1"V;C1"V2CV-C4" C4"^V @T C@ D C5#TTT/ C1"V"CV 0" ?C'# 5#TTwTTW j TGC C 4#!C W TTTTT TTTTTTTD C V4CD V&C!C W   cTdVcT T TT  DC 854"TcTW  T F D CTuW  TC C 4 #TO D C U* W   TtT DU  C 4#T4 W   TKTZ4!DC+C* TTW 7 TC C8"VD D^V E E 3#TTW dddd ddddddddC W@@ DVTFC  C1"V"CV 0" ?C'# 5#TTT DVT T#TC W  Tq DVThC  0" 0"  C2#TTDTF85 ! U-75 ^V%d C857"   4#Th D" 4#Tc@[Tc@[VB C W 8888 88888888C E85,"  C$" D""XV ! !852"TcZ( CyV ID@[[)*8:! 8:!zVc @[ 4!8:')*C W  CU 85:!? I(c()*+ CC W Q QQQQQQQQQQQC V8W ) )))))))))))C V DD|VTTTTV "TTT*W % %%%%%%%%%%%C V V "TTTc V(V( & G F E DC "YCV DC##Z( CyV!Dh!>!h!>!@@@[[)*! D! D CC" E D!D !D hy  hy 8%"1 CC Y:   #4#  #4# C34  +68: "Z( 85:! I 85:! I[)*85 ! 85 ! yVc(V&V hzVT( C857&V C857&5d6 @[D C')* 4+8: &E D C Y    Z( CyVDih@@"ih@@"@@@[[)* V F"T hzV FU85!U V 85!VFXV"dh"h "hyV @T @@@[85!CV CcTCV?85! DC#85!V" yVc(85!V  852& ' ] I?85! DC# 852&)* @()* @(D85!hyU E85!hy(D85!hy( +8:&E D" C85!hyU D85!hz( +8:&C Y85!8"A[6 CyVc([C 85!8')*85 ! 85 ! 85! 85! C+#Vc(CC" E D C hzVhzV!8:!h8" +8: " +8: "85!85! VTVT5eD D8%"" U FU F+; + V  !U FV !UFV  +8:"Vcih!"ih!"@@@[G#FU !V FV + !V  !VGT* GhzV FU !VFXU +i !V !V G h h> 4!+ CC Y'""3!+8: "Z(85:!I85:!I[)*VD C 8:"V 2& 2" @( ')*85!85! yVc( WW c( EU F855& C VXC WTC V C 4'TCTU+F 855" !DC#YD 4"8: "Z( h I[TWTCVT( CDVTzU  F855& TkTgC E DFWg~ DVTMCVTEU F855&T6C V9U1CF 855" !D C#Y D4+8: "Z(h I[TTTU F855&TF yVc(EDCU!U U U CV8:!iyU8:!iyV/8%" V$UVc@[D C 4"8: "ChzUChz V  2$8: " 8: " , "  " 8%"!DC"8: "c? U U > U U > 855" 855&c@[)* " C W T .TTTTTTTTTTD h" h"h  > " 852" @( C ^U7CV5f^V85-!U E D@(c@[)* " C W _ ____7______D h" h"  cTc?? > " 852"( D85 ! C^ViyVc "E(F2$ c@[)* " C W 4 444*4444444ch" ! D#852"$ C$ c@[)*yVc( ! ! yVc(YCC W T TT/TTTTTTTT "V@D # #852"T_DU"W  DUC C8"VcT: " "  !  ! yVcTY@ G"ZT 6 CyVc @ G#C C W .5OVcT"V D# 852"TW  C C ^U7CV/85-!U(85-!U!DD2 EE2 TTdTfW \\\ \\\\\\\\\TCC3 TEW ;;;; ;;;;;;;;C C8"V%)DD3 TW  CC4 TW 4 TW CC4 TW C#TD C U)W  TzDU=C2 T/W  TR2#DC TT:W 000000000000 C C8"VD D^VEE3 Tc @[T[Z( CyVD @@ @[[)*8:!8:!zVc@[1#8:'G F E DC "Y   Z( CyVD>!>!@@@[[)* ! ! D C C " DhzVc@[E !D #D   4 C 34+j8: & )*85 ! 85 ! yVc(VVhzVT(V C857&c@[ $ $D85! E85! yVc(W CVc(C V!WTC VC C$ TWTCVT(C #DUPWLLCVTV  F855&TW..C V#VC F855"D +P8: &TTF D WTrV 855&TcF zVZDCVXVc@[Eh >855"8:!8:!yV#8:' VC +8: & hzVc@[(c@[)*85 !85 ! D! D! yVc( 85!V"UChy CC " D CFVh "  "@T @ D ChzU FV FXUhzVc@[CC W )))))))))) ))W C   #TW  85!VcTVH 85!XV  D#T" ] I  D"85"? D"  852"T=W //// ////////W    4 T c@[c@[E4+y8: &)*!85 D~VD85!o JC W u uuuuuuu uuuC 8:"XVC @ I(C85 ! D! 85!V85!XV"C D" GiFEh> ?D" 852"2!85"85!XV 85!2&( 2!85&(! C W  F2%( Dy( Dy()*yVc( ! ! yVc(Y7CC W pW VuY! C 8: "zVc @[ZT6 CyV% C+8:"Vc @[ C @@ IT[TDU"W  DUC C8"VcT " "  !  ! yVcTxY@ G"ZTh6 CyV]c @ G#C C W sA??d V/cT2W ( (((((((((((VY!C 8: "zVc @[ZT6 CyV"C+8:"Vc @[C@@IT[TW  C C ^U7CV385-!U,85-!U%DD2 EE2 TTwTyW ooo ooooooooogCC3 TVW LLLL LLLLLLLLC C8"V6:DD3 T)W  CC4 TW 4 TW CC4 TW C#TD C U+W  TDUDC2 T4W  TY 2 DC TT<W 222222222222 C C8"VD D^VEE3 Tc @[T[Z( CyVD @@ @[[)*8:!8:!zVc@[  1 8:' G F E DC "Y   Z( CyVD >! >!@@@[[)* ! D ! D yU @G "UV C @8:" Vc(  " C W  C     2$CC "  4 DhzUEhzVc@[C    34+ 8: &)*85 ! 85 ! VV T UTc@[c( $D85! E85! W EVc(C V#WTC VC C$ TWTCVT(CDUWCDVT(D VzWTrCTiD V^D C DC   8:! 8:!yV   8:'    8: " +8: & Tc@[)*85! " C W  C2$85 !85 ! C C" D C FF^UFXV hzUhzU  8%"h"hzVc@[85!XVDD4 E    4+x8: &)*D 8%G" Y EEi Z( CyVc D"@@@[[YGEi Z( CyVc D" C@@@[[)*YWv  E  i2 TC WTT C C!! C!! ! ! C C" C+{8: "D++8%G "TTjTlWPaCC^VUYDDi ZT CyVc D "?@@[[( E E  h2 T E   i2 Tc@[Z( CyVD U @@@[[)*D 8%G" Y EEi Z( CyVc D"@@@[[YGEi Z( CyVc D" C@@@[[)*Y"W4E W"    i2 T E   i2 TTC WXT C C!! C!! ! ! C C" C+U8: "D+8%G "TTpT WTg C C^V[YDDi ZT CyVc D "?@@[[: E E   h2 T(& E    i2 TVcT c  @@@[Z( CyVVD@@@[[VCC W   D2%()*VCT5g W"C8! 8%"?(D 8%" Ch2"@(Dh2" C ?2"@(C(C D85! WYYC V8C  CVc?hh @h>T?? D @@(Vch?hhi>@@(c@(5h6 @[C()*C DVVc @(X$ V$ ehh"@(C()*! C W %SQ;;BBV ch"j @( dIc @(V&Y8: "iId @Z(6 CyVc @( [c @( "Vc @( @ D  X  2  E    2  D D8%"h ^Vh CCC>!@( c@(  "Vc @( @ C      2 8: " !h ^V + 8: "?!@( c@( D Cr "Vk "Vd"U] "! ! YC W  V!U " D CChEiC  ! C W 77777 7777777DC VC C8"V D C@TT TTT5?[ D  !8:"V5?[5i Ich" @@ C!h@2  C 85!VcT5j6 @[d D^U "VcT@? ? @IY  #ZT CyV5k6 @[[e@ T5?[Z( 6 CyV&2  Dh ^V C@(c @(["Vc@( @ Yk 8X"hyV  "V   "V   "XVdI G2+8:# !h ^V +8: " "@Tc @Z( 6 CyVc@( [C "U!Vc @( ! {VcT!@     2  Dh ^Vh? C@!@( c@( E     2  F     2  D D8%"h ^V CChC>!@( c@( C85 ! "U85!Uc @( ! {VcT!@ Ch"     2+k8: " !h ^VcTGh hhh" +E8: ">j ?!@(C     2  Dh ^V D C@ !@( c@( 5l6 @[c @()*V%V D C C ^VD2& ^V2&(d()*V%V$V!D D C C^V  D2#C@( 2'(5m6 @[)*D C DCV5V!Ch@?D"h@?D">@( @@$ V @@$ ()*C >()* $)* ! ! yV(Y@ G" Z(6 CyVc @ G#C C W N] |NNNNTE D C W  b T'T$EDC ^U7CV885-!U185-!U*  @@2   @@2$TTW   C C  3$DUW  DUC C8"V ( C W   TxTuTC !85!V!85!V C  >@(    4$W 8988y8888 888YC C4 Z( 8% CyV C >@( [D C U.W    TTTDU C   2$W    TTTD C V=Y 2+     Z( CyVC  >@([ hh  D2$D W   T:T7TsD CC8"V# "V EE# +i8:#8%&TW  W ---- --------C"V"V "  2$W ,,,, ,,,,,,,,C"V"V "  2$W C W aaaa aaaaaaaaC 8"VLY0 8X" ! D D8:&"G2+C8: Z( 6 CyV C  >@( ["V  "  2$ C >@(  C >@( [)* @@$)*8:! 8:!zV " 1+8:$ )*G E @@$ )*! D! D CC " E D C T71   @@4 T C!D # >@ TChh"!D #  >@C   4+c8:')*D85! E85! W5(C V'WTbC VC C @@$ TFT5C0D V'WT.C VC C @@$ TTW  CU(7%?[)*D85! E85!hh W CV(C V WTC V CCTzTpWTfCVT^(CDURWNNCGDUC(D V9DVT3WT)CT D VDVTCCT T7%?[ @@$ )*85 !85 ! C C " E CD!D! C C W ;W tttt ttttttttC C8"V^  @@ 4$W pppppppppp ppF F^V[WDR  @@4    4+8:'W '' ''''''''FV  4+8:'7%?[! C W //   , 5n6 @[Dh&F2! E D C> D&(C D&!C W  E2!in(c()*C C^(Dhz(c @h@h$)* +8:"V( @(D 85! WTKD VAD V7h C@+8:#zU8:! 8:!{VFE 8:!C>TTTT C@()*! C 85E"XV C 85F" IC W D C VvC D VgD C C ?85! "V c854"TG! C W ( ( c 854"T' 85:!c?A IT zV @ @? 854"T5o81!C!85 D{VcT! D C D#85:!C IT;C85 ! C+8: " +8:" +w8:'"85:!] I?ITc 2"85&()*C W   (C 2'Y 85G"Z(6 CyVWch85" 85G#C W //// ^/////!C 8"V2Y C D" "  2#?ZT* CyU  CyU[5?[Tc? D2"8: " ATDC V$C C  8"VcTD  2"8: " @?? C2#@TC85 ! D! Y85G" 85G#?ZT_6 CyVT 85G#85! Vc85!T i i2"85  G VCC 8"V]h M?T?T[TC8"V5?[C2"h85# I([)*W)3E C 8"V2'2#D"8: " A(C #?(E 2# D #CA(D85! W33D V*D V!C "8: "c?Eh @C>F855&Tc()*! 8:"Vc( @ C W ((((((((( (((C85 ! C+8: " 2"85&  2"85&)*h "8: &)*E 8"UcT5p6 @[F ED#C"8: ">h!()*E 8"UcT5q6 @[G F V C#?ED#C"8: ">h!(E# D CA(D"8: " C@()*F +8: " ED+8%G"C#>(E"81 " D"8: " CA(E# D CA()*YC"8: " Y8 E WcT'D C  +8: "@TC  +8: "?TZT6 CyV VcT[ YG VC  ##?ZT6 CyV VcT[h!V C85!VcT F GhGD >Z(6 CyV c!5?[[)*! ? 85!U !8:"U!V(C D"h? A D" 852"()*Y#h!Z(6 CyV c!5?[[85D!85D%)*85C? ')*! C W FFFF FFFFFFFF? C^U. 8:"U&Y"@2"Z( CyVc( CyVd([(c()* ,h &! C W ; ;;;;;; ;;(C D !@ D&C85 ! D ] C D" J?D&C D&YFE D? Z( CyVD8:!8:! C8:!"A[[8:!+8: &)*D!cIch  @@ D! +()*Y8X" FhyVGhzZ(6 CyVc([)*c 8:! "A[)*cI lihh C C@()* "85%)* 6r"8X" D G V9C !C W ***** *******DC VCC8"V@(T5?[5s6 @[)* 8:"VdId()*D 8%&h +8:'e r((e r (()* 6tA()*Yi Z( CyVc D"?@@[[)* 8:"V( ?@()*DD 8%E"U  6u@ @(()*Y4D8%G"CC ?@TDD ?@TZ(6 CyV  ?@([)*C D85 ! F85 ! V'V( ? @(V  ? @((5v6 @[? (C()*C D85 ! V  ? @TE 8%E"V( 6w@ @()*g5C!h?!! C! C!h @G#!! !! C C"h D+8:# E +8: " +q8: "8%" D Di C + 8:#  D +8%G #  D +8%G #  E E8%G"8%G!+S8:# V(Yn8:!8:! zV c @@ @[  +8:#??h +8:! ""6x Z( CyVD([)* 8:"V( ?@()*DD 8%E"U  6y@ @(()*Y4D8%G"CC ?@TDD ?@TZ(6 CyV  ?@([)*Y FD"Z( CyV  C? @([? (C()*C D85 ! V  ? @T d C857"E 8%E"V( 6z@ @()*VCTdl5C!C85Ih " D !85Ih " D ! ! C! C!h @ G#!! !! C C"h D+a8:# E +R8: " +C8: "8%" D Di C +8:#  D +8%G #  D +~8%G #  E E8%G"8%G!+K8:# V @@T&Y cZT CyVDT[I( )*cI$ )*YcI   h?l C!  dZ( CyVc([D! C!@(CC W  TDC W  TTc(d(C +8:"V C+8: " I()*CiI " I()*c850! !h85*!Y#"ZT CyVcT[ 851!("C 8:"Vc(C @I85%)*c? +8:&c? "85%!C()*C85I h#!85I h# Y l C! dZT CyVcT[ I()*cI$ )*V 75 Dz(75 Dy(! D}VI85!V 75 D~V?[D85!o JC W  C 85!V285&285&()*,Y !85%!ZT CyV 85%!c@[[ " ')*  YC8%G"Z(6 CyV8!@C 8%F#I([)* c()*! " VcI()*c ?$)*I ')*! ! yVc(C W S SSSSSSSSSSS! Y" #D #852"VcIZ( CyVVcID@@" @[[ ?' ')*Y#cI?I+hi#cID!Z(D! CyVD@[cI[)*Y #Z( CyV D C"@[ CyVc@@ C"@[[)* yU&C hzVY"G"dZ(6 CyVc([()*c "G')*E E|V @( @()*! ? C" ? ?"h!  C 8X$ Ic85*%)*Y8X"G VCT5{6 @[Z(6 CyV5|6 @[[!85 D~VC D{VDID85!o J285&(75? , !85%!C()* hlC!$)*Y8X" GhyXV GhyVEhyZ(6 CyVc([!C 85E"Vc(C 85F"IC W O OO%OOOO7OOOC VCT5} D" 852&C!V%C"285&C 85!XV85!2!285&285&)*c@?" !C 8X*#h?h C?A" DI()*c! +85C? ,8 %C VC(5~6 @[!85 D~V yV?[D85!o J285&()*,Y !85%!cZ( CyV 85%!d([)*ch hhh">?85%)*D C " !@@ " !@@()*c +8:'c? @(c? @( 85E& 85E&)*C &)*C 85C+8:#8: "8: " +8:"V @ !  U +8:"V @ !  Vc@[ +x8: " +g8: " @@ @@IY "  IZ(  I[ !85E&)*CUDV%(!C 85E"Vc(C 85F"IC W cccc ccccc>McD V+YC8X" G2+8:#Z(6 CyV28: &[( 85E"V?[(D+o8:"Vc(C2%285&)* "85C? ,_Y  !cZ( CyVd([ C!85E&)*D VC +8:"V &(()*75C(,75C 85F8:# 8:')* C!85F&)*CUDV&( 85E"X()*!85 D~V`85D!V D85!o JdTMY1C85G" +85G"VC 85G"85F#IdZT6 CyVC 85F#IdT[VC W tttt tttttB^tD V/YC8X" G 2+M8:#Z(6 CyV 2!8: &[( 85E"XVchh85" @@@[( D8: "85F8:# C 2& 2!85&()*75C? ,Y85C"85%!Z(85%![)*Y #cZ( CyVd([)*C Y"T\ccI   h  CU"Z( " CyVc@[[)*Vd I()*!ch85"hIc i> IY% hhh ?i85 #cIcIZ(hIcI[)*Yh8X #85 D!DyZ(6 CyVc([)*C W DDDD DDDDDDDDD Y'C8X" h" DChh?i cZ(6 CyVc([56 @[)*c850! Y "Z( CyU  CyU[851!%)*! C W   "%?[7X ()*c850! Y "Z( CyU  CyU[851!%)*Y"Z( CyV%[)*Y !"Z( CyV56 @[[)*! C W   "%?[)*c850! Y "dZ( CyU  CyU[851!c(?8X % +i')* !C W  E D CD # C 85)# V'C85zVY #ZT CyVcT[( Y  #ZT6 CyV?[[ E D C?   ! C W 555555555 555C 85!V]  @? M? ITTTcCVGV+C {Vch"@@@[c @@ 8X#T  8X" V c @ C8X#(56 @[C zV c85*!I(5(5()*Y   hh?i85 Z( CyV?[[)*c@[)* Dhhh  E! C W  CDh T Ehhh h@h85! D CA(] C(8%()*c @ @(C W  VC?%ch&56 @[)*VC 8: " + 8: " +8:#hI h!  C +u8: "cIc85! @(  !8:&)*8: " +85G& Ehhh  D CA(hhh$D+8: " C@(hhh$WCE2! D+8: " CA(C F+8: " E D+8%G"  Chhh >?(E2!  Dhhh  CA(hhh$)*,+8: " !h85! @(hhh$hhh$hhh$E+81 " D+8: " CA( Ehhh  D CA(hhh$G G G G+81 "FE WcTD C+8: "@TC+8: "?TDC+l8: ">h85!(hhh$hhh$)*+8: " +8: " hhh h85! A()* 'hh+')* +8: " hhh h85! @(c@?" ! C W  C VCTTT5C !8X*# DIc?h C?A!  hhh 852&hhh$)* Chhh  E+8: " VC D C +iD 8: "c85! @()*7 hihhh>(YC8%G"ZT6 CyVcT[C 8%F#I 68'hh')*! ! +8: "h85!(hhh h85!()*! V C!@? h h85!(8X!V?()*CC W  D8: " 8:"Vc(Y-C85G" C85E"XVC85F" ID2!8: "Z(6 CyV85G!?C85G#D 2!8: &[Y 85G"CZ(6 CyV75C([)*85!V &(g85C! h #g85C! ,A +85G "+()*!C D}U 75 DyV?? @C8#75 DyU yV C @IC 853"h @2!85&75 D{VD8" D C8%" I(D85 zVS75 853"8"DC28: "C W 444444444 444C85! D85 {UC }V75 zV 75 853&(c()*C85 DzV C 853&()*!lh8"85 ?h? ,nh "75 D{V h !85"C 8: "+8 & %C&C&)*cIY C#Z( CyVD VDVT CD@@@[[7CV(%)*Y8X"G VCCT8!Z(6 CyV8%[)*?[)*cI &)* D|V( @()*c? !8: "c C +8:'h?&)*cI &88 &88&E D85 !hyVY!Z( CyV C E D>@[[(75 C^VE85"%()*C!! ! C 85"8: "D85"! +8: "Y3C!85#!+8: "C!85$!85%8: "85(!cZ( CyVC!85$!85%8: "85(!D?([EVc(D8: &E%YDC85"8: "E WcTC+8: "T C+8: "TG VC!85&!cZ( CyV 85&!D?([)*85"8: "Y!dZT CyVcT[ 85%8: "85%!(C()* " +8: " 85%!()*cIIi"ChIcI(Y !85%!dZ( CyV 85%!c([)*V;V8DU CC8:!"Uc A(DU CC8:!"Uc A(! !hhh$c A()*C C^(!C%D85 ! Vc(d C857&!C W c DIC! C +8: &56 @[!C W  c(c D854&581%)*!C W   @ ?@? D854&56 @[! C W  (F2%56 @[,!C W  C %56 @[! C W  c D" 852&F2%56 @[,!C W  C %56 @[!C W  c(d(!C W    c(d()*CDVVqD D C E D CDC E D C ^V @  >@2$ ^V @A@2$  @   A@2$D8:!8%" 8:! 8:!A(8:! 8:!8%" 8:!A()*,N @hhh$)* E D C>&+8:%)*! C W  F E DCA@2& @()*C C^(,h " D C +8Q"@(!C W  C(56 @[E Vc(d(Y 7X8X"dZ(6 CyVc([Wd(c()*VCTiyCC YIIc !IIZ( II[DEl]p CEn()*C CyVD Dy()*c? A%c? @%)*?C&)*? &)*?C&C&C&)*CU 7CU!V((CXV8X!V dIc85*!d(W C8!T DT56 @[h ^l#y(I(CCI(CI(C8:!C8:!ICIDI(CCC@@ICI(CCC@@I(CCC@@ICI(II(C(gq]5?6?6?6?6?6?6?h?h?i?h? + + + + +t +T +F +6 +, +h? +h? +85 + + + ++y+k+[6!85 +? +. @8!h?h? + + + +++h+ + ,R+( + +++/+ + ,J+ ,N+8Q! ,Y +@ ,ƕ5? , + 6?h?h? ",B + + ,+ +#6?  !#,+ +6 +)*F,˖7+ + +.=K,;+0?M,SP+? +q 5;VZ,+P 6,BR[+ Q+T++:V+;,h=+~ ,c?? AHKMOa,+ + +l +L8%C? + +  JS++ + +e + ,M+Ah? SZ],՛ SZ]+ S+$t+?  \as{,sx+8X? + + &[agk~+ q +c z~++ \|+ +I|,B^~+ _+ `+| +rh " b+D ,Ld+ j+fp,Nf+{6?h? dfhn,x y+ , c? +  + +q,c? !r,Rs+Ct+!8:! v+ x+ y+@h? ,{++h?~+h? +N ;=+ +?  !my|~, _ǡhsУn++ + Ih+Nl C! +. + +   !$&(-/158Gs, )ܭʮ_L #+A !(+ %2n+g NI(+Q +@C+$ ,ɴ ," s,+ +4Av+g + 35;@Q,ZƸ7+ o+`,ڻ+CS+- +,\9X++ ACI, ^ǿ> E+F+6? G, y+ I,2 L+ Wh? + + + ,E+ ,]+`r+O    5Xp}, +lC!U+ + ,Q,z `bt{ , 9`c+?,+,{+s`,Z+l/85C!l85C! +  ,O +f+_ + +8 ,+  +H,/+w %0<C@NPRU_cehmomaa!#&),.79;=?ACFNPRUWVZ\cegikmo>b9T)*W C6 8 f'D C268 f$D2 C268 f$W +C!?(C W C8 "VD?(D 2!@(D2! C2!@()*W 1C &C W C8 "V D6 8 f'D 268 f$D2 C268 f$)*V 5(5(CC VC 8:"V5( @2&5()*V 5(5(C 8:"V5(C @2&)*C W !!!!!!! !!!!!C 8:"U @2&(Wc(G2! D@(CC2%)*h "C 8:"V E6 8 f'C @IC4 D E68 f$ 1&)*D C68 f$G VC D C68 f$ 5 8 f&C VC D C68 f$ 5 8 f&)*W ";G`u5 8 f&C 6 8 f$Fh" E4D4C68 f$ C16 8 f$EC!! D1C68 f$ D 1+u C468 f$F4 E4Dh"C68 f$ C46 8 f$C46 8 f$C 1+6 G6F6D46 C3+!668 f$C 6 8 f$D1 C468 f$E1 C68 f$C V C68 f$5 8 f&)*W %5 8 f&C VC468 f$5 8 f&F 2+ ED4C68 f$ D^(CClan8B!i8L"TgCq8%!lCrlan8B!i8L"8%"C 8:"U C +8:"Vc2%(%D85 !hyVE&()*85 ! 85! 8:"V !V% @ C W )-oc(%D 2"E 2&C 2!8: &DTC 8:"V%8!VC @IDC VCD8:! 2!8: & C8! C2+]8: & F D85 ! E 2" 2& 2& 581%C 2&C 8:"V%C85 ! 85!XVC@IG V!V CD2!8: & 2!85& D+8: "C 2&E 2!8: & )* z(8!68L&C(C(D85! Wd(c(D85!hz()*CV5 ^U85-!VT5 85-!VH85 !C W 8888 88888888D VDVT7) C8"VC"T T TT5T"" A(C W  .9HSZb c!  "@ ( +a E D C 'C  "? (D  " C!@(DC C  '581%C &C85 ! FV C + 8:"TC +8:" 8:! 8:!y G VMC C!VA! D  "FV V @(   "VcT  +8: "?  F!@> ( FVXV  "  !8: " VcT  +]8: "? F ?> ( !h@ (D C V685 8: "  &C 8: "8: "  " @ !I( &D +8: " E  " Ch8"A (c  ')*85 ! 85! C 8:""VC 8:"U 4"  ! @ ( 44432  +'C 8:"VC +h!8:"I!V!V! !h !@(c %)*C D85! W !ch A(C Vc C1"@hA(T(C DUTD V 3"iA(3"hA(ch A()* 4!8: &)*C C^()*D85 ! V( E C@@((8!h C +8:# +8:'" D')*V(C D VC85 ! 3" D1" C! A(581%4+ ! D C@()*V85!V75 Dz()*VC D 4" C@D2# D C @@(C W    581!TcT 5T 1"? h@(V Ch"@(()* h"!@()*U 85 !85!U D C@(5(Ehz(E WGhyUFhyTFhyTFhyU C +8:"T G C +8:# +8:#8!@(WD(5(D8: "E81 &E%)*c !C!  8: " 8: "858: "8: "G VfC 85 ! C W MMMMMMMMM MMMC85 ! G V0CC WT C 8 "V]h M?85!TTTT  !? E WcTC +U8: "TC +98: "T+  +  +t !!E W*V FCh "@T*5T& F C48: "?!@T F C38: "?!@T D CDC>( E D C8! c h " A(ChIh !81 " h " I A(V Ch"?(Eh" Diy C8!A()*E%!C%)*W;E D 8]!C 85!8:"U858:"V  8E!8:"V2&8: &C C85 ! 85!C 8:"V!TC @IC8!8! C+8: "D+t8%G &D!E 2&)* F" EhyDiyC>@()* E DC>@()* D C@@()*W5E 8]!C 85!8:"U 858:"U2'Di"C!@(C C85 ! !V 85!!h@ ? C8!8!h! +8:#hD +n8%G # 8:!  +@8:#C  E  "8:# 8:!@( D CCV5 ^U85-!VT5 85-!VP85 !C W 5555 55555555D VDVT7) C8"VCT T TTc68!?8"T "E2# A(W C!?(C3!?(E2! D2! C8!A(VC W=LesD2! D C"@(D C 8!85!V2%2! E!D "@@(D2! D C"@(D2! E! D1! C8!A@(D2! D C3"@(D V$D VD VD2!EDC#@(T.T*T&D VD VD2! EDC #@(TT(56 @[)*VC4! 8!@()*V5D V.CC XV58 f"Dh2" DC!DC!6 8 f$ c(VID VBD C D CC D CU85!U85!Vc( 2! yV yV( @@ @@( c()*V-D V!CD CD D2" V( #V @?(56 @[()*W%W22C C&W%%D D^VC C2&WC C2"D D2&c(VD VC C C C"D D"D2%c()*c!8: "8: "   i c(i"  6h  i' )*7CXI!YFV?D V2V(D!C@ C@    T !    dITTTcZ(iI[)* i$ D! C@()*c! !+8: "  " VgD V`YYD!C hy"C hy"8CXI8: " +  "6h"DC! D C!68 f dIZ(iI[56 @[)*85 !C 85 !C W $$$$ $$$$$$$$W  C C&c()* 8"V 8 "XV!%()*V C D C$()*C C W & &BV&&&&&&W lll lllllVllCU\T<C V8!D{V 6 8 f$ T;CUW C W  . T_V8!D{V 6 8 f$ TTW ::::::: :::C85 ! C85 ! C F C F V-DUIEVBDUQMCC CC ^V 68 f'T4U 5 8 f&68 f$U 68 f$c( W M1W S W  CToW }}}}}} }}}}}}CT[58 f&85!VT68 f$ 85!V@T@ D C 8X8D#V 6 8 f$5 6 8 f$85 ^V 58 f& W hh C FC V5W 1 1  TYFC VC ^V 6 8 f' T=T9W   T%6 8 f' W  C68 f' c()*C C W kkkkk kk[kkkFC V,W ( (  TtT@FC V CC^(T]W   TITHTW = =======@===W 0 W  W  c(d(C68 f')*VCC6 8 f#D +8: &()*D C 85 !C W   V ! @( @%C D! ! zV! @(85 ! C W CCCCCCCCC CCCC 85 !G)85 !h G F E85!Dh8"C>? D85&()* yV &85! 85!yV8[!T  68 f$ )*!6 8 f$)*8C6 8 f$)* " 8C&)*! 8C&)*! ! 8!A()*d # 8C&)*DhyU(C85 ^U E 8%E"X()*C85 8: "h!8: "D "D8]! 8: "858: "8: "!V85!!D8\! C8!8! C +8:"Uc D +{8%G #!Di#F 8:#8!>()*d # 8C&)*C!h!8: "D "D8]! 8: "858: "8: "!V85!!Fhy!Di #G 8:#8!>(WD(5(i" +8: &)*85 !85!V5T i" WDT5@()*c!h"hh# 8C&)*C85 ^V1D85 ! hz 8%E"XE A! C" D!  >@( (D85 ! E85 ! V#C W  T D C@(c @()*Dh "C!68 f$ )* " 8C&)*8! C! D WC8$!Tc A()* " 8C&)*C!Ch" 8!@()*d # 8C&)*! "@(5(5()*85 ! 8:"V  ?85!@( @(h +8:# 8:%)*8[! 85! 85!zVi" i" @@((c +8:'!i&)*VCTd Vc! hi$)*! hi$)* hi$)* hh$)* " 8C&)*CV5 ^U85-!V 6 8 f'(c!8: &c!%7Ic!c%cIcIcI(8X8V"h&D85! WDFVCVhy(8:!iy(d(GhzV C +8:&(C W   d(c(85! !XV C @I%(C 85!8:&C 8:"XVC @I()*! "68 f$)*V85!V 75 DzV5(5( C8:"X(85 8: "C +8:"I(!c(DC^(Y C8: "Z(6 CyV}C W 3 33333333 33C VCT!TTBC VCTTT/c!T* ?h T\8%! 8%" IC +8:"UC6 ^V C @@I([C W ) ))))))))))C VCTTC VCTc(C 8:"Vc(C @I(cIcIcI()*cI "cI()*V C6 8 f'5 8 f&68 f$ +8: &)*VD +C 68 f$ 5 8 f&W c(d(e()*!6 8 f'Y C8"cZ(6 CyVC 8! 8#I([Y C8"Z(6 CyV8%[,x7? + + +68! , ,+y +U ,,(,N,u+h?   ,z&+ 85;Ih?h?h? + + ,H+ ++ + +th?h?h? +S +C  +$ + +  ,p+  + ,+ +z +ki? +E   #4, k+ + +  + "+ + + +h +6 )1, CP<+ ++ + + + +l +/ /+ #(.,5"-28O, $++q+] ),13<R+ + *-24=S+  + RU,Q+ + + + +q%+= ,,+ 8+ 9+ +m + ,/a+K +3e+ ,;+ ,r FJ+ * + B+  G+d !#%'+ K&&"&(;=?A=?MpPRPU`bfe~>'q9T6 8 f$)* +8: &)*V+ D C6 8 f$ (6  8 f'5  8 f&6  8 f'5 8 f&5 8 f&5 8 f&5 8 f&5 8 f&)*W 7Ja{5 8 f&5 8 f&+ + Ch8$#6 8 f$D8 C868 f$+ + Ch8$#6 8 f$C +l +_Dh8$#68 f$C +A +4Dh8$#68 f$C6 8 f'C6 8 f'C6 8 f'C6 8 f'C6 8 f'D C6 8 f$C6  8 f'C6! 8 f'C6" 8 f')*F F UV5#(DCDC8M$ )*D C DC8M$)* h8K$+ + + + +[ >9$TN)*W(YC8X "2"Z(6 CyV([)* " W( C 3#?(7 CVC ?@ E2# D A(()*VC Wy D 2# @(D C G F E VTAUT:c?C88! AA85!?E]i L MT ] MD2#E A@(D CD8X #2# E8 8! A1# A@(D C VT7 8!A??D8X!#2# @@(()*W(C 3"8: "?()*W #(C ED8 8!A# A(C ED8 8!A1# A()* " Wc(Ch3$)*VC W$>nDD W  TD 2$  D2 8 C8!A@(D C  D   8X #2   8!A1#8%& DDC8X!#2$ D2$ D2$ ()* " Wc(C 3&)*VBC W39393DD W  D 2&c(D 1"VD C8X #2&(D 2&c(d()*G V(Y28X"D DzVT]h? C A85!? MZ(6 CyV([)*W&C 8"V  8X " 2'(C 3#?(D C W dTcTeTE8X #2# 2# A()*VC D 2# W!?[lD E D C8P#AC@@(C E D hy 8Q  A@(D D C8P"8: "@ C@@( E D1#CA@(C YD 3"@@Z(6 CyV5?[h @@([ E D8R#CA@( E D8S#CA@(()*V Cj 4#?()*,h' 88&,+ ,+ +P ,,,E ,  >  9%T )*C @C @i8L$)*VC CVC E D CED 8!8!^V c A@(8:! 8:!zV c?@(V#VPcC@hC@i8L U c?@(U.    +r81#V D D    2$c?@(c?@(c h@@(V cCCi@@()*VuC CVeC C 8! 8!^V c  A@( DD^V c ?@(  CE@ CE@i 8L V D D    2$c ?@( c h@@(V cCCi@@()*C D " Y8%G""ZT6 CyVT[@()*5& +8%G ')*C D @ Y8%G"@ZT6 CyVT[@()*5' +8%G ')* D@ C7)Tch85"@()*c @h @h8L$)*C C +81')*CXUCVDXUD(C8!8X@$)*+8: &)*VCDDzV5(("U5)(EE VcTW7WD CCi   D^VT c iy?@TUWOOC C + F FcTe     V8!h   i T5* (GG VgV F CC CC  VcTa5+T]c? C ?A85!  C Ci 8L VcC@h@h 8L VcT5,T5-T C Ci 8L VcT5. ( E V G VC89"85!TdT FhyVGG +L8:#Vc( 5/( c(#608 f$)* +8: %8 f&)*+W  #(3>I_t51 %52 %53 %54 %c(55 %C8!66 &C8!67 &C8!68 &E8!D8!C!69$ CVTD8!6:$ 5;CVT6<$ 5=(5>(5?(5@ 8%!8%&@@i8L U&hyV Y89"8:"2!Z(8 CyVc([(D85! E85! W ~Wd(C VHWTC VCT%TCT~D VDVTqCTTgC C@@Id(WTOCVTGC DV T:T6d(W//D D 8:! 8:!yVCC^VC 8:&"8%"Id(c(D85! Wc(d(G E@()* 89" 89" C C W ]]]]] ]]]]]]W MMMMM MMMMMMMC 8!D"V{8!  D@  @i 8L V[C8! DC W   cTdV8C C8" EhyV(C +e8: "8:%! D8%" C 8%"i 8L$( TW C 85!"VC85 ! 85 ! D@  @i 8L VrD C W   cTdVVC C8#" FXUFV Ch8$"hyV8D +8:"V,  8:&"? E +8:"VC8:%! D Ci 8L$(     ,i % )*C W 2222 22222222CW!! 89" C W   c(d(c()*F F EhyV GhyUEhz(d()* CCi8G V<D D W$$$$$C WC ^Vc(?[?(W  ?[c(?[5A? + + +? + +v + + ,,  + + + + +=>9BTs )*Y     3 Z( CyVc8"@@@ @[ CyVD8"@@@ @[[)*WW$C #2$ W~~CC4$ WllCD8" D8 ?@ 1  ) E E ?C8#  ?@   8X #1  VVc( @(  8" 3$ ?[)*WW''C C8"Vc(WC # 81$ 5C6 @[)*V7C ! WDDW  TTDCAD86# 2' ()*VDC ! D C WNNNNNNDGUBW>>>>>>C ] l|V5Dl 8L#^Vc ]h 8L#?@TTTd @ YaC86" C W % T* ? 8#T ? 8#T ?? 8#T E DA@2 Z( 6 CyVDV ?@@T    2$[V@[8:! $)*8XC!8X&",86h # 3,  hh  % )*VC C WZ1jD W TD D DC     D W   2$    2  E@@( D W T.DDC    D2$ D W TDDC      D   2 hE@@(D W TC D?D 8%#  ?@ 4    D   2  E@@( D W TDDC   3 D2$ D W TWDDC      D   2 hE@@(D W TDDC    D2$ (5E6 @[)* 8" ?@ Y1 VV'%CC  3 TVC ??  3 Z( CyVD   A@@@[[)* 84  84  VVc(ch@@@[)*VOC W'8D4 C86F8 f$ D3 C86G8 f$ D3 C86H8 f$ D3 C86I8 f$ 5J 8 f&)*VCW16K 8 f$ 1&)*V0C WT#D1 C86L8 f$ D2 C86M8 f$ 16N 8 f$!8: %)*!U 6O 8 f$CV 5P 8 f"cI()*c(81!i? + + DC 6Q 8 f$ 7(C h{V&C]{V]IYc  hC8V cZ(i()*D C8:!6R8 f$Wc(d()*c( +8:"V!86S 8 f$6T 8 f$)*V!C W 5U6 @[Dl C8!A2&(VC WT,D C? &5V6 @[)*W !I5W 8 f&C86X 8 f$E D C 8!8!6Y 8 f E E@&E D CF6Z6[6\8B#GG@8!6]8!6^6_8 f$ E D C 8!8!6` 8 f D D@&D8 C86a8 f$C E 8!D 8!6b8 f$ D C6c 8 f$C F8$E 8 !D8 !6d8 f$ C F8$E 8!D8!6e8 f$ C86f 8 f$)*D 6g#C 6h')*C6i C8:"Vc(8 6j8 f$ )* 8h$ )* 8h$)* 8h$)*Y  8h8X Z( CyVD @h@@@[[)*Y    8%#8h  cZ( CyV5?[[)*VC CyVDhyV D 2&(d(,h "Vc(?(W#1?M[C 8!? @(C 8!? @(C 8!? @(C 8!? @(C 8!? @(C 8!? @(C 8!? @()*Y 8X "Z(6 CyVc? @@@[[)* 8 "  8$# Vc   >@@@[()* 8"  8$# Vc   >@@@[()*8!h8XB# 8 "  8B#Vc(c A@@@[)*8!8X?" 8 "   8!h8B  hzVc   >@@@[()*8!8X>" 8 " Y  8B#Z(8B CyVc A@@@[[5k? + +w +D ++6l?+ +O +9   , TH+ 8XFI+++m+Y +5 + + ,_}+ +] +56m? + + ">"9nT^?(Y 8X"cZ(6 CyV + 5o6 @[[)* 2+ W cTC !TC !D !? A[! A[VD VD2! C@ C@(((CC(DD(D# C@()*D85! 8E"V2C W ! !!!!!!!!!!!75 DyV C? I @(C@DA[(c ?" @(D CV;C 8:"U/W$$C Vc?hh C@h>T c?hhi>T 5p6 @[T D')*7%?[D(WrE D ChI"8: "V!C 8:"U +8: "h?h >T*8:!i{UVhzV ?DA[V CD??T5q D #A(C # D D8! C W  D C@?Tc Y +H8 "IZT8% CyVcIT[D89" C W 7 7777777777V(CC?DA[C 85!V 85 ! CTTT ? DA[  +8: "?( 8:!"XV ? DA[()* @()*85! Yh8" C  ^V  @ DA[  " D " c@h@h8L VcT#Y 8>#ZT8 CyV  @  A[[Z(6 CyV @ 8'[)*chihhh"h@@>?8%D C 8:"VT285! WT"C Vc?hh C@h>T c?hhi>T @(C 8:!"XV ? DA[(D()*Y DD8@#Z(8 CyVD!? CDA[[G V2C8!C W """" """"""" C8X"2%C85!Vc(5?[5?[C VD# C@ D @(D()*Y DD#Z(8 CyVD!? CDA[[D()*D C W 0ch"T 5rDA[ch"  h$ C6s ^Vc ^l_yV6t8%"? DA[Y C8:"h8-#ZTX6 CyVMY C86"C h8-#ZT:6 CyV+ c ?"Tc ?" C D @86# IT[T[  ?$ C D2# E2#h D D>8! A$ C2"8: " +8: "?8!  ?$ D C CD# D C D8:!zV8:! DCA DA[  2"8: " C! G V75 C8!DyV7@T 7>T7@  8:&"  +J8:# +<8: "8" Y 8="ZT8 CyV D?DA[[    A$C2+8: "  h  3 8!  ?$ E D C Y' C8X" D ,g !eD8"d CAZTo6 CyVdYJhzV5?[C WC6u8%"?TD6v8%" C@T 5w81!T 8X"h D CAZT6 CyV C? DA[[T[ D C D8:!zV8:! DCA DA[  2"8: " C! 8:&" +|8:# +n8: " Y8"89"ZT8 CyV D?DA[[ C W (C8!jyV  C D@ ITpC85 ! +8: "C +8: "@?hihhh"> 85! V]h8! JTT]hh" J ?8!T5x6 @[     >$D C YcY  C 8:"ZT6 CyV C86"C h8-#T[  2# Y D8@#ZT8 CyVD! ?DA[[ZT6 CyV7CVc8!ch" C D @86# I2# Y D 8@#ZT8 CyVD! ? DA[[7CV c8 !8)!h8-# 85! C W 1 1111111111CU!85:!?? ITCU85:!?? ITcF E C>T[ D@$ E Dh?+lh8"   += 2, C 8: "h +8 #VC +8: "Ch hhh"8:!> 85! V]h8! JTT]hh" J ?8!  A$Ch8!+8: " C C 8%" ID2# D  Ic8 !8%!h  +8:# 8:! @ 85! hh" 8@#  @$C C D@ Di  Ch ! DC"  !  2+8: "C  DC# +8: " +8: " A 8!   D>? $)*VJC C V3C 8:"V ? DA[ D @  2  DDh>8% ch &ch &c8%D85! W(Fi D C> C@(8!85 D~VR85#!C W @@@@@@@@@ @@@C85 ! 85!85!VGi F EDC +8: ">? I285&285&(5y 8 f&5z 8 f&5{ 8 f&5| 8 f&)*W",:HZdr-:HVdr5} 8 f&C6~ 8 f'C86 8 f$C86 8 f$E D C868 f$C6 8 f'C86 8 f$+~ +qCi8$$+] +PCi8$$C6 8 f'C6 8 f'D Ch @ @8!8 6 8 66 8 f$ C 8!8 68 f$5 D C68 f$C6 8 f'D 85!V5T85!V5T5 C68 f$C86 8 f$5 C6 8 f$C86 8 f$C86 8 f$C86 8 f$C86 8 f$C86 8 f$C86 8 f$C86 8 f$C86 8 f$)*c!c8!h #h8 !D8%!()*cI76Ii # D!c " @()*8! C W  (75 DyV C? I @(()*C 86"V C 86#I()*cI76IcIc8!j #C86I+86"ch#c8 !D8%!Ch +p8:# D!F E D@ 85!h8-#C>()*cI76I VcTd #h #D!(Y ED8>#Z(8 CyV D? CA[[C+8: &)*D Chh"h850! Y 8>#dZT 851!cV`YCC 86" A@IZ(6 CyV=V 8!85!V68%"?A[ch"C A@IC 86#I([()*c?C +f86"76I +J(!85%%)* >()*c "C @I(8!C W  (c @ 8%)*Y C86"Z(6 CyV68%"? A[[)*Y35^Vc^l_yV68%"? A[C86"V?[Z(6 CyVc?"C 86#I([)*c !8&)*c !8&VC6 ^Vc ^!V(l_yU la|Vlz~(C8!DI(Ch8 !@(c8 !76I()*hVcTD?ihhh>h ?CC@@@ @@()*C C C C^V C?A[ ^()*D +8:'" C?@+8:# @(56 @[56 @[?(?(?(?(?(?(?(?()*Y9W,,C WT5 C^VT7X D?"TT "Z(6 CyV     56 @[[5?6?8X8/! ,+ +8X " +y8X " +k8X" +]8X" +O8X" +A8X" +38X" +$8X " +? +? +86?h?h?86? +q+b+R +< + + +  + +u +N  +8 ,A+$  '+-,g,+h! '+ + +c  + + +!#&&)+-&( 68#%!)>,9TV+c(2!@()*C C W "" )>a"  C2&W  QQQQQBQC C"hy(W 9 9999*9C C3&W $$ $$$$EG EG^VF F3&(D C V0W   ( TTD VC ^VC C2& (TW   ! TTvDVc(C ^(TW ``` C C" D C3&C W  ) TwT0C 8:! 8:!yV 3&(TJW UUUUUUF C C2&W ..( W 999999999 9 C2"U D2&(C 2&d(C 2"UD 2&(56 @[d()*VVC C1"VD D2&(Ud(56 @[)*8!C W   C8X&581%)* " E W C 8-&GV!88"2'581%)* " E WC(GV  !88"2&581%FCVc(d()*E VPD CCW1GF DC>268 f$GF DC>268 f$GF DC>268 f$C W ,~ (FVg5 8 f&C 8&D8 C268 f$ C W%/9CC68 f'C68 f'C68 f'C68 f'C68 f'C68 f'C68 f'C64 !68 f$F EG VaDVEGF #6 ^U$V!D VDVTC4C36 8 f$64 ! 6 8 f$ GF # C4 6 8 f$ GF # 68 f' D C VC4 68 f$ 68 f' C +k8:"GF"4 !68 f$C64 !68 f$D4 C468 f$ C468 f$)*C W <<<<< <<<<<F V+D V"DVT  EG"V 168 f$ TT 1&)*C W AAAAA AAAAAF V0D V'DVT% EG "VC2 C168 f$ TT 4&)*C W  FV 468 f$ 4&)*C W  D2 C268 f$  4&)*V D C V 2! 46 8 f$ 4&()*V<D C F E V "2!48!6 8 f$ " 4 8!6 8 f$ ()*C W << 9)92C 2&C(F(D Vc C@(TC !&c C@(c(C W %%%%  %C%F%DV c@(c@(c( E D C>((C W  *BZp~(G Fh'C2%G F C!?'G F G F!EDC>'G F E D+81 "CA'G F D C+8: "@'G F C!?'581%G F? ')*VVD D2" D CC@@(581%h@()*VD V 2" C@(c @(VRC VACC W 11  T,D D C@@2%D D D@@ C@@2%D2! @(D2! "@()*V(D C VG FEDh2" "A>( &?[)* " EW$$8!C W  C(56 @[GV ! 88" 2&?[)*VD C ! V  2" C@( 2&(F(C W PP P1>KCTECTEFTAD E C"Vc(VCT'T C +8: "3%C2!UD2%(C2%d( 2% 3%VC1!VD2%(d(C !XV "8%" D&()*VVC C W OO 77777 7D C@ 2&E C"Vc(D C@2"U D@2&( "D "8%" "2&D " " V hh #V 2+g8:& !2& !2& ( %)*VC D C@ ! V(D 2&()*V.D C D C@ ! VC " V C 8%"?(?(&(C !Vc( "8:!n D# V C "?(()*V~CVx"  " VR 2+ hi #V "U  &!2# V"YC  "@?Z( CyV581% [(!2# V C @?((!?(@()* @(&C !Vc( "8:!n D# VC +8: "?(()*VCV"  " Vf 2+  "  !V  "U(!2# V5Y#  "VCC +g# 8%"?Z( CyV581% [(!2# VC +*8: "?((c !@?(VCD" D2!V(d()*VCV" " V2,hyi#V %!h2&ii# V !T !" ! VDCC CW  T.V#! 85!U !h2"VcTC"TTTc(! 2&d(C W  (C2%C W  C2%D C@(56 @[)*Vd(E VDUC!  DC  &56 @[)*E VC ! C W WW8888 888E C"V&d(CDEVDDEV  !!2& !!2& "D "8%"DCA "2& !V  ! !2& !!2&D Vc!"3 +08:$! !"Vc(d()*c @ D CAh@ DCA 1" "V@T1" V8Vd(c@?(C@?(V c@?(((C Vc @ 8%"?( ( C 8%"?( )*C C W ?? )>a C2&W  C C"hy(W  C C3&W EG EG^VF F3&(D C V0W   TTD VC ^VC C2& (T"W   TTnDUC ^(c(W pp\pppp pppC C" D C3&C W   TDT,C 8:! 8:!yV 3&(W &&&&&&&&& C C2&W  C 2&c@hh@@"X(d()*VVC C1"VD D2&(d()*C C W  ,M? C2&W  C C"(W  C C4" GF ?'E W   B TTuTLEG G^VF F4"GFh D C>' TgT[D C VJW   B TJT%TD V#C ^VC C2"GFE ?A' TTT W   - TTTDVTC ^V(TTW C C4" GFD @'C W  ; TTTZC 8:! 8:!yV 4"GF ?' T|TpC W  TdT?TTPC 2" G F ? ' W  C 2&W  (W   D C3'( D C3' ?[)*Y91" Y G F EDh1" A>ZT CyVT[Z( CyV 1&[)*VhVbD C F EDC F E D CG G{V 2">@( GG{V  2" D C>@(  2"">@( (()*0, &)*VVD D2" C C4"@(c(VD C D!V2%2!h C@@()*VC C D VD!X2" Dh @@@(V?[(VC C VD2! D D@@(c()*VGC C D W  & !  "8%" "2&!2& C@2" V( D@2&VC CVTD?(c()*VC ! V(D 2&()*VC 8"V(D 2" @(c @()*F &)*C W  >LXb(CT_CTSEGWFTFG F" F !V "T28:'D VCT((C 2+8:'D C 2"2&C 2& 28:' 2&C%FC%W CC C&1@CTBCT4FT0D VCT/TC2+8:&CC2!VDC2%(c(d( 2+8:& C2%)* " hzV  !$()*58!V"! " # iyV58!V#(!VC%( &g D8&)*VD C Ch @ Y=!8:""! !" VhzVgD8"T C +8: "ZT& CyU CyU5 CyU  CyU[56 @[D !V2&h@@2&()*g8!V  , Uh &(8:! ?# Vc(h8"?8&)*C &)*h+8:# VVC +8: &(7) 8"U7) 8"U7) 8"U 7) 8"X()* ?$ )* h$)*VC8:!h# VtC VkDVTjC VG! C E DC""T? V@C Y+g8! 8 2! "" V5 8 "8!ZT6 ? 8"c( d( Td(581%Vg 8"c(c @(@(V3C DV#VD C D@2! 2! +8: "8%&T +8: &c(? %?%)* 8Y!@( +8:#i @%c! E C@ 8#?(F%?@%VDV ?!?TC?T56 @[h A%?%C W #_C2%C28: "! +8: &Fh! DD ?@ EC@ 8#28: "! V +8: &chhA!@(D C VC2! +X8: &ch @!@(C 2+<8: "! +8: " +8: &C28: "! +8: &D2! C2!8%&C2! +8: &ch!@(ch8"hh8" , !  A(CCI8%!68%&7 @()*Yi"h@ "Z( CyVc([VkC C VbC C W 99 9999999DDD C@@@2%D DD D@@@ C@@@2%D "V2!DD"8%"@@(2%c()*, %C W!!!!!!!!!!!!!!!!!!!!!!!!!!!!!d(c(c@ @()*+8: " ?"c( &)*VD C +8:"V 2& @2&()*,h "h &c()*V 8: " %D +8: &)* @(c @(VC +8: " D +8:!8:'56 @[)*V#D C @2"h @hC8:"8%"A@(,Dh &)*V(TV(C C8%"?(V((d(8: &C(VvD C E VfC C W == ======= D C@DCA@2%D D@DCA@ C@DCA@2%"V2! D "8%"DCA@(2%56 @[()*,} %E()* +8: " &8: &8: &E VD D C@ CA(56 @[E VD D C C@A(56 @[8: &E V D D CA(56 @[E VC%56 @[+8:&!C W  c(d(8: &hhA(!58%#%58%#!+8: "58%#%D!58% !C!58% !E%!58%#%58%#!+8: "58%#%8 4"58% !c8 5!8% !58% %+8: &8 4"c8 5!8% %V DUC(56 @[)* # V!C !?( +8: "h !@?()*V D 2" C "@(VD2! C"8%&()*,, %)*G FhA'VD C V! &(56 @[C%C W  EG(581%)*V0CC CW  T+ +8: " " !8: &56 @[ 8:"V2%GF !?'CC W  C8:%56 @[)*GFh A')*C 8:"V(D85! W( Chy "@( C "@()*VcT?GF A'CC W  C(56 @[C%C W  EG(581%W  C W TC(56 @[??(W  C W TC(56 @[??(W  C W TC(56 @[??(W !!! !!!!!!!C W TC](56 @[8%!??(5 ^$(W !!! !!!!!!!C W TC](56 @[g* 8L"??(()* }V5?[8B! 8:"V 2&GF ??'VC Y DC"Z(6 CyVD2%[(CC W  C W TC(56 @[W  C W TC(56 @[??(()*VCC C W  ) c (CWTh} +h + + $  +`8: " ,,-cl8B!h8B!@@6@6@6@6@ % +h + + $  +~6 +m +> $  8b6 +' + $  8m6 + + $  8x6 + +r $ E GW/VG F"C8"V(+- +#8: " "& 7X8hh]868!?@ MDC>'E +8: " ! + Ch +e8:# VD C+D8:' d6 &  +8: " ,c %( 8:"V!2%GF !'CC%)* +8: " , %  G8:"V?()*C W FFFFF FFFFFE Y&GG#GF G"8X" +"Z(8- CyV581%[581%)*G F E DhF!6 8Y!6 8!?>>(W 5 6 @[d C_(d C_()*c ^h ^ +8: "ch }U\^XV  ?@ zUcc }U\^XV  ?@ zUc()*V8V4CC C W  TEGWTG F" C 8&c(VKCC C W  T4EGWT'G F"8) 8"U7) 8"U 7) 8"X(c(V(CCC W  TE G Gn 8:!y(d(D85!hyU  C8:&(D85! W Ed( C8:&CC W  C(5 6 @[)*VCC C W '*W' 'T~CW c(8:!ly(d(E GW#V! G 8:!y(G Gn8:!y(c( +{8: " !V85!U C +H8:& FV C +%8:& (c(5 81%VD C !V2%2! @(, %CC W  EG(56 @[F G89" C W  C85 %56 @[)*D85! W(E(c F855"c()*85 ! C G +8:# FXUG zV GiEhh85"h>?85! D8>'()*V,D C C "V D"8%"@ @@(2# @(!hh"8%"@ @@()*VQC VIC C W ;; % DD#2&D D C@@2&DD D@@ C@@2&D2&((C D "8%"@ @()*VWC VLCC W 33  T7D D C@@ 2&DD D@@ C@@2&DD +8: "2&D 2&()*,,%C W   cT ch@@" &VLC VBCC W 11  T-D D C@@2%D D D@@ C@@2%D2! D@(D2%(, %VYC VRC C W -- -------D D C@@2%DD D@@ C@@2%D "V2!D"8%"@(2%c()*, %)* i')* h')*E D CVF hzVdV  >( >()*C W (Iz 581% C" DGF C?#@( F" DGFGCEDC>#@(DVV DC?@T 56 @[h@ DGFECCA#@(C " DGFDC +>8:#@#@( C" DGF C?#@(VD GFC? #@(581% @()*E Y G"Z(6 CyV DC>@([)*VmC VeC C W WW  ! A(D D C@@2&%! C+8:#D GFD@#2&DD D@@ C@@2&D2&(()*,! CW   ( & EG_( 68Y!68!?>(VCEG+8+ " +8: "8+ %581%Y EG"Z(6 CyV([)* +8: &EGy()* +8:" F(C W   581%c(C()*C C W #4NduW C C"hy(W }} d(W ll}}} }}}}}EG EG^(W RRcccc ccccC C^(W <<MMMMM MMMd(W ++<<<<<< <<C8:! C8:!y(W  d(W d(c(8 4"c8 5!8% %)*6 8 f$)*G F #6 ^Vc(d()*W#Y# C8!Z(8- CyV5([Ch8&)*YG8:" CZ(6 CyV5 D^U58%[)*! 89"8! C W  C(581%75 DyV(88&)*VkD C F EVRDC F E GG{V  @  @2$GG}V  @ @2$ @  @2$c@@2$ VDh CF@ @2$8:! 8:!@()*,h hh$)*WWC] C]^G( ^(C W  E C&c()*C 85"hy((+8: &)* h8>(+8X8h #8X868Y!68!@# ,+8X86# + + +T+@ ,s5 ? + +[ , ,#+! ,J+ + ,qA*Q+ ++ + +  +} +9  $,d#%,&(+ ,`&(+J + + + + -+ ,_),t+ +A + + +S +&+'+= +4+ -,5!? ,/,, +=+ 4@BDF+ - +Y:,W"%BDJ, mf]D, + ^,,  $(+CINQ, Q+  !#'+.FLQT,H+'"$+P,/+0+ + + +e +P +E ,+$ + ,*+ + + + + +7+v:@+] + + + + +5 +     1Rlq, #^`,W+]bk,v"m+i +2 ,5"? ,,PV+ RT,+k ,-+Z ,c? +: + > _+ 3+ 1+ , +u q,-+F8 !6 ! 46N}+ +5 , ++ " +  QWgi)&*02yxRTV>9#TW#,6@JCC!?(CE!?(CF!?(CD!?(CG!?(CG!?(CG!?(CG!?()* ^()*7CV 7CXV7?CXVvc8X7! 8%)!V7CV5$  C> 84#?881 "  +8:'"V !T 8zCh]8Oh8%!!> h!"8%6!c!c%I(C(C @I(! C VC(?84@[! D VC(?@[8%9! 81! 8%F!(8%:! Yf!8z ^V !?h@TA7z ^V084! Y !8z ^V  ! ?ZTh ?@T ?84@[8%F!D C@Z( 8%F![)*7z 8%." 8%2&8%B%V5W&(CC!?(CG!?(C8+ "?(C8+ "?((F E! D C>(F E! D C>(E D! CA(E! D CA(F E! D C>(E! D CA(E! D CA(F! E D C>(F! E D C>(C W(D E! D CA@(E+8: " G! F DC>(G! F E DC>(! G G G GG GGD>(((((((((((((((((((((((((((((((((((((((((((((((((((9C! C48: " E D A9G%D4! C4 !@()*18: &EG! G! ] MG*! DCA(CG! G! E D ] MG*!A(F! E! D C>(E! D CA(3G! C W $0?LYfzC4 !?TC D 1" @TE3! D CATC4+8: "?TE4! D CATwF E D C>TjE4 ! D CAT]C4 4+j8: " ?TIE4! D CAT<D C@ T4C4"3+ 8: " ? T C4$3+8: " ? T D C4 !@ T E D A3G1%1D! C4(! F E D >1G%G F! E DC>(F E8: " D C>(E D! C!A(/E! E4&+8: " F WcT%C4&+8: " ?TC4&+8: " ?T G VC4&!? GG G D C>/G%-F! C4$8: " E D A -G%F! E D C>(+G! C W %:Scn|C2! E D ATmC28: "?TbG F28: " E DC>TMD V C2!?T E CAT4D C2+8: "@T$C28: "?TE D2! C2!AT C2!? TC E38: " G F D>+G%C WD C4 !?@((E! D CA(F! E D C>(D V C!?T E CA('G! C W"5CUes~ ,EQbqCTC E2! D 4" ATE Dh4" CATwD2+8: " C2!@TeE Dh4" C2!ATUDh4" C2!@TGC28: "?T<G F28: " E DC>T'D V C2!?T C@ TD C2+8: " V C2!?T @ TF E D C2!> TG2! F E DC2!> TC28: "? TE V C2!?T D2! C2!ATD2! C2!@TD2! C2!@TG2! G F2! E2!DC>TuD2! C2!@TiE281 " D C2!ATXF2! E D C>TID2+M8: " C@T9F2! E4! D C>T'C2!?TC2!?TD C4"!@T C4!?TC E38: " G F D>'G%D C WILIC V*D C V C4!? 4!?@@(h 4!?@@(D V C4!?h@@(((C V C4!??@((D! C@(#G! D4+8: " F E C>#G%!G! C38: " E D A!G %E! D CA(E! D CA(G! C W &3@O[_jvE4! D CATlC4+8: "?T]E4! D CATPE4! D CATCC4+8: "?T4E3! D CAT(CT$D C4!@TC48: "?T C48: "? T E D AG!%G ! VC4!? G"%G! G4 ! ] MG(%G! G4 ! ] MG)%E! D CA(G ! C W #5CT6C4!?T-F2! E2! D C>TD3+8: " C2!@T C4!?T F E D >G#%G ! W  C4!?T T C4!?T G%%G ! C W %3\CT^C4!?TUF2! E4! D C>TCE D2! C2!AT5E D C VF C4!? 2!>T Fh 2!>T D C4!@T F E D >G$%E! D CA(E D81 " CA(E! D CA(G ! C W=PoE48: " D CATC4 !?TG F2! E4+8: " D4!C>TaD4+8: " C2!@TNC F2! E4+r8: " D 4" >T/D C VG FEC3!?2!>TG FEh2!>T F E D >G&%G! C WE48: " D CATC3!?TE2! D4! CAT F E D >G+% G! C4! D38: " F E > G'% G! C W#5GC4!?TLC F3! E D C>?T7C E3! D CA?T%C E3! D CA?TC D3! C3!@?T D @ G,% G! C W }} $3>PZjtE2! D2! CATgC28: "?T\E28: " D CATMC38: "?TBF E28: " D C>T0D C2!@T&E D C48: "ATD2! C@T C4!? TC F E D > G-%G! C V D1! C@ D @G.%G! C4! D48: " F E >G/%WE48: " D CA(C4!?(G! C WRG F E D4!C>TG F E DCWGC4!?>TGC4!?>TTMF E D C WGC4!?>TGC4!?>TTD4! C4!@T C4!?T D @G0%)*V C !?((+ ,'O,M2Nv_84    "$&(*,.02468:>(8%8X:! Y 8"Z(6 CyV  8#([7z] ]  h8%? (+ Y 5%]cZT6 CyVdT[lh8" + + +/ + + + + + + + + + + + +x +q +j +c +\ +U +N +G +@ +9 +2 ++ +$ + + + + + + + + + + + + + + + + + + + + + + + +| +u +n    "$&(*,.02468:<>@BDFHJLNPRTVXZ\^`b>22 +@ D +++{+h+X+G +3 +" + + + G0 G/G.G,G*G)G(G'G%G"G G!G"G$G%G&G'G(G)G*G+G,G-G.G/G 0G 1G 2G 3G 4G5G6G7G8G9F:E;D<C>2 C! ,. +6&? + +  +R +< +$ + h? + + +   +L   > 9'T8C VCF CCF|Vc8!DI2%c(7CV+c! V C8%(!8 /!T7 0h!8 !8:#cI(cI(C8:)"hI()*chW""%HC FDTcC FDTU(C ^V 6( 8 f D!6)8 f#(C ^V 6* 8 f 5+8 f"ED#5,8 f"( ^V 6-8 f 5. 8 f"!8! 8 "5/ 8 f"()*W 60 8 f'C 618 f$C 628 f$W 53(54(55()*V&D C CFCF|VDFDF~V2'  @2'()* &C+8:'" ,8h #I()*C "56 8 f"D &)*7} ^V 57 8 f&F E DC688 f$)*! !&)*DF DF^X (CF CF^X(7CVC @I(7CV!EXVC @I(W CD(C(+h?h? + + + + +` +G +',+ + + + +  >99TOC()* 89" C W ???? ???????? C8X" E WG89"2' C +8: & 5:6 @[5;6 @[)* !C 2!8Y&h86" D EGEDC>#FhyV) G8:!"VE8!C W  cTd VG8:" G " EDC>'h86" D 8>#E'F EG@(C G D E DC>&)*C W  "\C 2&C 2!8: " ?8%F E G hyUDhz VF(2!8: " h80" C 8:&"+8:#D(D 2!81 "hhhhhh8"h?C@@>?8%C 8:!! GF(ch8" +98: " 2+ G 8+ "(E D V"C85 ! G Gh Ehh8"C>?8%C2" 2" G EDC>#(F(VCCC WD2%C?(( Chh$ch8" @(C89" 85!XU75 Dz(Eh8!h86" D C hyVc8 !Y EC ZT8 CyVD!@A[[ Fhh  hzV,c8 !8%!8%8: "+{ 8:"V !?A[DC>(ch8" hh$)* hh$D Chh$D(ch8" @()*VCT VCT $ )*2+DC W ;#[=C hh>% C   hh  C h@>% D   Chh h8! C "h8 !8%!  6<h  C FhA>%C  ! C C h?>% C +8: " + 8: "?8!  C  +8: " C h?>%E D C C W""VC C 8"V 8"TTT C C8# D C8!Ci8XA  VDhzVgA[GV C  VPC C W BBB*BBBBBBBBBF0FhyV g D8"F 81"TCVT FTTTc @ F 8:!zV8:! FCAA[h!@?80" D GV T C C  +8:#Ch     C>>%C D+s81 " Vc CF@hhhhhh8"hh?i hy> @@> ?8!C   Ch]hh8" J? A>%D   +m  CC   # C h@>%ch8"  8)!8.! C C +8: " +8: " C h?>%C   Ch6= C I Dh6> C  C   I Ch h8Y" A>%C C W D CW  TD C  C8" C D  C  C D@IC W UUUUUUUUUUU Uc8! CDh6?85  Dh8 !8%!   hh Ch ?@@  @>%5@6 @[d Vc8!D C8" C D V!c8 !8)!Ch8-# Ch8-#@T @ C  C  D hh CD@IVVC W 7 777777777G h ?@@DDCGF E Dh>A>(G E ?@@DC>((C C  C # D EC  G F EC@@@ DC>( ch8"  8) !8.! C  Chh  C h? >% C   h6A  C hh@@ D@>% )*VV!VC C C #D D D 2$UVT(5B6 @[)*VChy(C W!c(G Wd(C%d(C%EFhyVF%(D%C W!4]emsd(D2+8:"VE2%(D V!CDVTC2!VD8: "48:&(TC28:&F28:&D4%C2+p8:"VD4%(C2%CU^d(D2!VE4%(D2%ED8^!>d(E3!VF2%(Ch? D 2+8:"Vd ED +8%G #VChy(C3%c(F%D%C W . ......*D+8:&c(ETC+8:&CTd( %C W d(CC21+8:&c(C2%C1%VC4%d()*C W 4DC 85-!V ch8"!Tch8"h E2" >8%C 2!8: "?8%D Y.CC8X" DD8:!zV5?[2!8: " C8"Z(6 CyVch8&[D 2&ch8&VC&ch8&)*C W !'fv|E 2&E V7CD C 85-!Vc 2"hh8"! >8%c 2"hh8" >8%ToD VCD 2&T_C 2&C 2!8: "?8%D 2&E +P C2" D ! ! Y  8>#ZT8 CyV D? DA[[((ch8&)* 89" 8:"V c8:!@(C W  E C@@2$ 85!8:!@()*ch8" h3$E8"Vc(c E8#C W (((( ((((((((C WTCyV 852&285&C Y+CC8%G" Fh8-# Dh  C?AZ(6 CyV C?A[[C C^()*C +8:"V C?A[ @(?( h$)*V)V&CE G8:"V CCC? A[D D G@2'c()*VD 8:"V 2& 2" C@(EG(G EGz( +8:"V.h86" h86" E8>#Eh8-#8>#D D8>'(F(F()* h$ch85&)*89" 8:"Vc(C W ;; ;;;;;;;;;;YDhh8"8@#ZT8 CyV5C6 @[[E @2&c(" ChyVDX(?8'!?89!h8-# #()*D 2+C W !3P'v!HGj  Bv  ,gVh8-#hh>%C8CV(Y# C8X" D C8?8" A89!ZThC8# D C C h8-#h D WaaFaC? A[ D6D8%"?8X" C W 5E6 @[ D C@T CAT" E6F8%"?8X" CAT A>% C W !h?> % 89"8!C W 7) C8"V C'"T7)8.!h?> % C ;D V4DVT.C C  0"V  DhE@@D@@  2$TE W D??T ??TcT dDhh4   E."Dh2  Fh C A>% D C VE VDVTC C Dh hh6G8Y!A@@@ 6H8Y!?@ h6I8Y!?@?6J8Y!A@@@  6K8Y!?@@@ h Dh C@@jA@ 6L8Y!?@@@h A@ 2$VCT h8-#@ D C8CU 8X! Vc8!Yh8-#8A#ZTD8 CyV8  89" C W  @ A[ hz@A[T[ D C85-!V3ch8" Y!8>#ZT8 CyV5M6 @[[!TVc8 !8)!8)! Ei@?4  C)+M 85-!V !Vg 8:!CD8"h>85!h8-#hDA>%c8!7CVc8!C1"8CV c8 !F8)!,Fh8-#h8 !h "c8!D  4#h8 !Fhh8" 8@# Dh C@>% c8!C1"h8 !&!V F8%!TF8'"Di F h4  h8-#hDCA>%   C h2  Dh 8) h4  FhC@>% C +8: " ?85!        2+8:# +8: "?8!h ?>%  E D C 4$ D Ch8-# Y  89" 89"VC W  TC W  TC85 ! C 8:"85! CC 8:"85! WNNC V?WT=C V(CCC4 h?@ >!TT TTT5?[TTT5?[Z( 6 CyVA 1!81 " +g81 " hhhhhh8"h? @@>?8!h  @ >%[D C    i3  h ,q h #VQVG7CVc8!ch8"   + CEG 8+ "7CV c8 !8)!  Ch2 ?T5N6 @[ V CEGOT5O6 @[/8:!zV& +J8: "  # ,h " ?  A[hzV8:!yV g  8"   h8-#h @ >%D C1" C8# D h86" E 2# Dh  C > >% D C1" C8# EDC>F  h3  E FhyV C? A[ 8)8.!h FDC > >% ch85" 8)!      C 2+8: "  h8-#h? >% E D  7)C h2  V7   h2    C h2  F  2# Fh ?A>%  7) h2  Fh hA>% C4 "   D h2  Fh@>%  7)C h2  D4 "8)8.!h@>% C  7)D h2   7)E h2    h8)8.!AC +?8X) G D4 " 8)8.!h  F   C>>% E D Ci VCVVc8! 8" CC 8" C D D Y8O#h D!c D!c !ZT8 CyVE D@A[[V8c8 !8)!8)!?? h8-# h8-#4 >T??  4 >T\Vc8!h 8# D V0c8 !8)!c ? h8-# h8-# 4 >Tc ?   4 >TVC 8" D C DVc8! 1"V!c8 !ch8" F D," F 8@#Td C-C8!C W`````````````````````````````EDW=====V5W 1111 11111111C D C C8"VC@ Ic !TTTF?8X"?8X"U>c850!8N" Yc!C F8>#dZT8 CyV 851!cT[VcTY%  F8O#h !c !XV 5P8"ZT^8 CyVE D@A[[TC8N"h !YC F8>#ZT&8 CyVD D 8<" > DA[[?h>T 1"hh F > C D E FE@@@ DC>% 7)C h2    D h2  Fh@>% D C8CVc8!1" YC WSSSSSSSSSSSSSSSSSSSSSSSSSSSSSED D W =T$FCh8F  D 8!85!V  ?8"h C?ATD Y C8:"ZT6 CyV  ? DA[[ 6Q8%"?8X" 6R8%"?8X" D D WFCh8F  Dhh8"6S 8A#C C8>#h8-# D8>#chChD CA>?6TA@ h8hA?A>@ h>!??AT5U6 @[TTFi 8B h ?A E8CV c8 !8)!8! C W e eeeeeeeee+ech8"h @ 8! 8.!8>#TBD C V(D8CV75 zV 5V8" hh85 DT h8-#T5W6 @[ hDC A> !Z( 8 CyV  F@ DA[[C C8# D F V C8.!h CA>% C?A[C Y C?8X" D D W\\\\\CFCh8-# Dh2  D6X8%"?8X"8)8.!h CC>> !TCi@ A[Ch@ A[Z(6 CyV C?A[[Ch +s8:# Y 6Y8X" 6Z8X"@ZT6 CyVcA[[ CD D W.....D   2+ 8: " Ch  DC@> %5[6 @[Chh8"h8!D8!c8! DC" EC8X,# Dh8!8!8!  Eh2 h8 !Y F 8@#ZT8 CyVFC@ A[[ h   C>>% 7)C h2 8)8.!h?> % ch85" 8) !       C h2   h8-#h?>% D C8CVc8!VCh8# ? D8!@T c 8!@ C8CV c8 !8)!hzV  h8-# h8-#    89"C W 3 1" Gh F@ 8! E DC>  2#TD C Vfc8!7CVc8! ih85  D8CV c8 !8)!  h2 h8 !C6\h* Gh8-# E DC>T"  h2  Gh8-# E DC>T5]6 @[ G F E D?@@ DC>% C C# DChEC@> % Chh8"h8!c8a! @?hhihhh> D8! 8X*# Ch8!8!D D1"lh8" ,F88" !c8 !G E ?@@C> %h8-#89" C W : ::::::::::fA[7CV75 89"D{V5^8"E D CAT ?A[ D C E CC  DA 8!h C?>% C DC# D   Dh2  G F E CA@@ DC>( )*FEDh8!7CU8X! V c8!c8!i86" E D CVc8 !8)!8)!Yh8-#8.!8>#ZT8 CyVD!@D A[[8.!V c8 !8)!GhyV  V  ?  A[ !@D A[cTc850!? h8-#3 h8 !Y E 6_hz( ZT $!U{YA85181 "c8!4"h8 !F8'" 0# E6`h( ZT; CyV,EW ''''''''''''''''''''''''''''''''''%''[[T[ G F h8-# E DC>  C>(C W &)&&&)&&&&&&)&&&&&&&&)&&&&&&&&&&!D2%c(d()*89"C W P PPPPPPPPPPc A(E C 85-!ViDDh8-#"?@@2&5a ^U7CV !A(cFhA(D C6bA(G E DihGE Dhh?6cA@ +8: "8%" @>@@6dA>()*8! h88hA?8Y!?A>h88Y!@>@()* ^(" DXVC6e +!8:&()*%+ , 89" C W  5f C^UE D!V7CVc8!4"8CV c8 !F8)!  ,Fh " D C8CV75zU 75 8!DzGFh8-#ED C> h8-#EU !U  .#( G EDC>.#(+ D6g " D C  +tV 5hD8""!V %F6i"G E DD!h C@@hA>%    h4  .#( D C VEh C!? A(Eh A( h iyVch8"! #(W=============================ED W T5j CC^VT(d()*V,C D C89" C W ~ R~~~~~~~~~~ch8"hh8" + DD~VC !V g D8"d?? >8!8># @TC ^U7CV5k^V85-!U E D@TTTmW  T8!T  C 8%"" C W ,, ,,,,,,,,,,7CU"U @DA[dDA[F89"?DA[ C 85-!Vd + DD  ? A@2$ "h8-# 8:! +:8: "@(7h8-#&"" %$$)*CXV 7CV75zV dI 8&()*89"89" C W  E D CDC W  TDF85 ! +85.!85-!Vd V^85-!UWVC C@ DDA[V8C D C  ^V5l ^V  @ DA[ + ?DhAT 5m6 @[YY- 85/" E D hzV5n D" F 8%" C>ZT<6 CyV185/" E D hzUhzV5o D "F 8%" C>T[ D C85-!V +?T5p D " +M? F EAZTV6 CyVK76q8:!"U 6r8:!"V#5sD"C  A@I+?T 5tD"cAT[ E C    A@T  TD  E  A@2$V VC C@ DDA[  8%" $h'5u ^(5v C^(85-!X()*" DU C 8:&()*c DC> E85&)* +8:')*+ #+h? 4, , 7CUIF#" DXV<C +8:"8:! 8:!yV" +l8:"V +Z8:"V gD8"dh?   1 , C WED W T5w CC^VT V| C6x C^VTo DVTf5y F h8-# 8A#  CDh4  F 89"C W # ##########%+!T f D8"TcDhh ?6zA@@( FV h  h8-#hh $c  h8-#hh $)*D C $)*C 8# D C  C8!h8XA VHC C W ::::::::!::::::::::::::::::::::::C VT FTTTc @ F 8:!zV8:! FCAA[7CU8X! V c8!c8!h80" D C h h  >> !V<c8 !8)! h8-# G8.! EDC> *#c8 !8)8: "8)! @ 8/" V C D@T5{6 @[ D G EDC>XV h8-# *#C8:&" 4+8:# G hyV ?A[G F ED>>(i')*Dh8! 4"h8 !7CV7)8.! (#(F 89"hh8" C W ? )?1????????D D}V g 8"T*!+!Tf8"T7) C8"VcTg8" 8@#(8#& D')*D D D"8CVc8!6|8-#h8 !8)!TC"V8+!T  C  G h8-# E DC>C@(F8%%h8-# 'ch8" F8@'C(c %C(F8)%DD8CVc8!??8CV5}V ch8"T  8-#   C  C C E8%" I7CV$c8 ! +"G Fh8-# E DC>T #F D@ @(C()* +8: " $!8:" #8:"@ D C V7CU  %#8+!8+!ATA E D CV(c8!c8a!8!c8! 8! 8X" @T h8a!@ D Ch8!ch8"h?  + 8: " +8: " 8:"V8#"!8: "C +8: " +8: " +n!8: " +R8: "c8 ! +=!8: "8:!iyV  4$"+8:#8CUV  h8-#  &+8: "V   #8##  +g!Vc8 !ch8"h8-#  @(F8%% +&F8'&)*!XV +&()*c @@ D8#"c()*C D "TVD IFC W sssssssssss sc8!7CVc8! CDi6~85  D8CV c8 !8)! h h8 !C F6i G Fh8-# E DC>( F h$ D C8X>&C VC C@@ IdI(81! +8: "dIdI(CXVCVT!E8&(C ?8X" 8!h?6 ^Uc ^l_yUc ^l#yXV +! +q 8XD'Uc @(c?h? 8Y ! +8: "? @(c %F8)% +"G Fh8-# E DC>(!Vc @8#"&()*FC W  TG  CDh685 D EDC>T D" 'ch8&C C DC W NNW !!!!!!!!!!!!!!!!!!!$!!!!!!!!!!!!!(D E VCTVCT((8CVDi D CA @ @((? (? ()*VCT+ VCT+h8!7CVc8!VCDC W !!!!!!%!!!!!!!!!!!!!!!!!!!!!!!!!!T]CC W !%!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!T2CC WT%5 C^VT DVTdTTTTc VT +8: " +8: "    F D C iy V +B8:#+8: "7CVc8 !+8: "TE +8: "VTh?h?6 !8!U5!8!U Vg8!  +`8: "  4 + 8:#hIV CXVg8!Vg8:!CD8" +8:#c8 !+8:#+8: "   8:&"A(5 8 f&5 8 f&6 8 f'5 8 f&5 ^V 68 i&5(@8"! D C8!!68 f$5 8 f&8!68 f'+8: %)*5 ^V 85-!V5T56 8 f$5 8 f&5 8 f&5 8 f&5 8 f&5 8 f&86 8 f$5 8 f&)*W %-CKS[k}.<FUku <Xw5 8 f&5 8 f"5 8 f"5 8 f&5 8 f&5 8 f&5 8 f&5 C868 f$E D C868 f$C +p +_D8%$+K +? C 8%$C6 8 f'C8!6 8 f'+ + C 8%$C8!C W  5 8 f"5 8 f&5 8 f&D + 8!C 8 68 f$ C86 8 f$+r C 68 f$C86 8 f$C6 8 f'C D E68 f$C 8!D 8 68 f$C6 8 f'C86 8 f$C8 6 8 f$D8 C868 f$C6 8 f'D CV 6 8 f'6 8 f'D6 C 8&$C6 8 f'D C ++zE8% FV5668 f$(D 8!CV5 8 f"8 68 f$5 8 f"8 68 f$D + 8!C ! 8 68 f$ D 8! 8 68 f C6 8 f'C86 8 f$C86 8 f$C + +D8%$C8 6 8 f$+ +w C 8%$)*c8!c8! "h8 !!V F8%!TF 8'"C W !$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!( CC8X" G DCEDC>()* chh  D C@(?(?()*c8!c +? +?  D C@()* F D$)*Y9?8X" D C WTE D C8+!A   Ch8X TZ(6 CyV([D(C&)* +8:" +8: "!  +8:'C W <<<<<<<<<<<<<YCC8X" DGV7%?[ZT6 CyVcT[2&2&)*,Y!cZ(8% CyVd([C W 2&7%?[,Y!cZ(8% CyVd([D%)*C W 222)22CT+C 8: &DTC +8: &C !D %c( 81 & %)*C D D DDC?8Y"?@?@ A@()* +8:'C(DD(Dh8# C@()*D C 8 C# +8: " +8: " +8: " A 8! A(8!85 D{Vc( D|V7%?[85#!285&)*,Y !85%!dZ(8% CyV 85%!c([)*D F 89"C W & &&&&&&&&&c(fD8&7) C8"Vc(V g 8&(8! 8%!C W # ###########75 DyV85:!C? Id(c()*V!XVF 8'" 89!8: " 89!8: " +8:" 8:! 8:!yVc( F8!@ 85!8!h @@ @@@ DA[)*hh $ ~VC  @( % ^ %2% 3&)* ~V%^ _ h3' i3')* ~V%^  TWT 3& 2&)* 44')* ~V%^   & 2')* ~V%^ -.#T'*W " D8)" C@( 1' 1')* ~V%^ . 4 & 4 1' ~V(^ @( ~V(^ %( ~V(^ % @((( ~V%^ %]2%( ~V%^ % @ '2% ~V%^ ^%% ~V%^ ]%%   ,x  +   , %)*! DVT" C@()* 1" " " D " C@()* 4"  " D C "@(%%)* ~V%^ |W|| C+  %4! 4!8) 4&" 4& ' %4!8) 4&7) 4&7) 4&7) 4&7) 4&a0T-hh8" ~V  ' ^ '  ~V 7) 4&^  T+W!!%%%%%%%%%%%!%%%%!%%%%%!%%%%%!%%!T 7) 4& TW 7) T T 7) TT7) 4& ~V%+3++8 DD  o 8L# !{  4& 4& )*4  , #ok   &]hh8"hh8"hh8"hh8"h?   2, Dc !h?h @@ C@@ @ D@8)A8% ? A[)* A A[)*c 8.!6>8%)*+ + + ,g %D(C(c %c850!C8:! +8: "c!851%C @I(cI(V? (? ()*G F D C EiAh8X   D>A +?8X   Ci Ah8X A(c %)*68%"8Y!68Y!@!@!hh"ch8"  ?hhhh 81! +8: "7%C?8%C?ChI   A   +>8:# E D C >( 7 @(V? (? ()*G D C + 8!8!  D Fh@ A?8X C E>@@(c %)*ch"ch8"  ?hhhh  !Vc @8#""81! +8: "85-!V ch8"! #h@C+]8:#hh # D C C>( )* "?  hhhh 8:# Chh# D81! C>(? (? ()*d"? ?hh6  C +? +?# D81! C>()*F C GVT h DA8X  ?8X' )*81!81! +8:#@()*c850! Y-dh"  ? ???6 851!?Z( 851!c(C M()*VCVCTc8a! ?IY%h X   +"cIZ( hI[ch8&)*h80" D 8!C W ---- --------E D +8: " CA I8="$ 56 @[E G^V C?? A[d G_()*VkCEGh O^ + 8: "hyV58!VFchO }U\^XV  ^C@ zUchzV8:!68L" ?8& (D8! C W &&&& &&&&&&&&C WTC Ch8!"@(C?()*EG EG^X(C C W;;CVC 8"V  8"TTTVC@ D8#TTT C D8# D D C>()*! +8: " +8:'" 8: & )*h?A>(hDCA>()*C D CD85! WMMC V,Ch?ih@h>@@ h8h>?@@@(h?ihi>@@ h@@@( @(ch8&)* 8# C DC +8: "h? A8!89" C W !!!!!!!!! !!!C 85!VTTT ?A[ 85 !C6+38:# @?hhhhh8"D8:!> ?8!i D CA ]hh8" J?C  +8: " V)D C +8:# G F EC>! A( ? A[)*VtC C VeDC CD 8"V;yV 2& YD D8>#ZT8 CyV D?A[[ 2" @@(8!8!^VT ?A[?A[V CC?A[()*!! ,j & )*C8! C8!^( +8:'&CDA89%C C8!^()*VC VCC+8:"V C?A[C8!C   >@IVCXVeA[C@@IT C+81 "()*cIcIIIcI(CW  7%?[c(Y  +"cZ(8% CyVd([C W D F G89" C W  C EI85 !T56 @[ C85" W{ 56 @[C DUFFUB5 F855&D V2FU*C ??F855"VC D @ G"8: & 56 @[TE85!Uc?hh > F855&Tc(c()* F D$)*C VCT56 @[ Y    8? Z(8 CyV D? A[7 CyVE D@ 8 A[7 CyV D? A[[C VC(56 @[)*Y 8>#Z(8 CyV D? A[7 CyVE D@ 8 A[[)*Y 8>#Z(8 CyV D? A[7 CyVE D@ 8 A[[)* 89" C W //// ////////D VDVT7) C8"VC(T56 @[58X 8X" G DF!hh@D8Y!C>$)*58X 8X"8XhhD8Y!C>$)* h>(c?h @8)A8%W'/77)8.%7)8.%7)8.%7)8.%7) 8.%7) 8.%7) 8.%)* @(C W 7!7777777777777777777777777777777CC WT c C8 'c(gh8" + !8: "c +8 'D%D%D%D%D% !ChhhhW !+=LLV\\btzVtttttEDTD281 "E2+8: &C2!D2+8: &CDTCTDTD281 "C2+v8: &CT~ECTvC2!D2!E281 &DCTZD2!E2!G2%DTBC2+$8: &E2!D3%CD48: &C3%c(2!2+8: & 28: & 281 & 2%2!2%C W "c(C38: &ETC2!D2%CTC1% 2%F%E%D%C W ====#==.=9C4%D4+8: &DTC1+8: &C3+8: &CTc( 1%D%D%C W /?c(CD38: &D481 "F2%C2!D4+8: &D4+8: "E2%C2%C W  D1%CFT C4%c( 4%)*,9%E(D(?8'!?89!(?8'!?89!()*56 @[56 @[56 @[)*56 @[5? +? +? +? +? + + + + +v +, + + +y +Q +# + ,3++_h? +G ++ + ,c+h?h?h?h?h? + $+% + #+ ,ݰ%+X ,ݱ+ +(++     $,29,Ѳ+  +Y ,7+1 + +}  ".+ + + h? + + +i +] +U ,X=+/2,4A,[,:+C+[ + +h? +M +$ + + +N86@ C+:+s   $+-179GIKMRUWY[^`gikmoq, $ .x+ + +a +$8XGIZZ]_b,/!NX[[,;>9>]9Tch8&)*8! C E"Vc(C F"IC W sD C +8: " 8" Y  8="ZT$8 CyV56 @[5 CyV ?  A[[8J#XV @A[   2#8: &  CDhh85  D2$ 2#85&)*C!XV  Di c()*EUE DUD CUCA(Dh')* D C8X')*D] M C@()* +8:# +8:# +8:# +8:!8:# ^V 2$ +d8:#@(g ld rqiyl r  T&WU5(TU5(T U5(5(CD5(5(D5(5(D?85%5 C8!8%&E(5 C8!8%&5 8 f&5 8 f&5 8 f&5 8 f&)*W,4<KU_iHVd5 8 f&58z6 8 f$5 8 f&5 8 f&56668 f$C6 8 f'C6 8 f'C6 8 f'C 8!D6668B# 8 6668 f$ D C 8!8!8 8 668 f$ 5 8 f"+9 +- C 8%$+ + C 8%$E D 8!8!8 8 Ch8"68 f$ D6 8 f"C8! E G W!VC ' (+6 +C $ +6 +uC $ C86 8 f$C86 8 f$C ++ + 5 6 6 8 f$ D !6 E!6 !6666 8 f$ C86 8 f$C6 8 f'5 8 f"D C8! 'D85! W%C VC(TD V DUC(?85%585%5 C8%"68%&E(5 C8%&(5(+6 +h@$)* + 8!C W SSSSS SSS0SSSC8! DyV %+6 + C$ C85 ! DyV %+v6 +; C$  %!8E&)*YG+8:"h?@85!h @  !@8! 8 !8 !68 f Z(6 CyVc([ 8& +8:&)* +$ DC8:!! CC8!@()*+8: &c(2!hh8"@(,c8!7h 681"hih!>h8 !!(E Y'Ch8#Dh8# D D 8># AZ(8 CyV D? A[[)* 8!8X?"c8!c8!!83! D 8:!y V C 8@!8:#D+8: "!X G VC 8# D? ?@T5 Ghh DFV E 8:! > V CG  8Y! V C@ GA[  # ] GG@h  Mh8 !! GGCFh C>()*C 8" DD VB8_! hyV eCDA[ 8$"8=CVDl{V5  F^V fCDA[ ?ATh AED >()*Y 8X"ZT6 CyV ? A[[ D 8!h8XA G W ? A[ E@ C@(D()*c8!c8! !8: "h8 ! +8: " 8%8: " @ A()*i 8# D h8X" V  C@DA[ F E C>()*E] D J D CA(D G G@()*C D D# @()*ED 8Y! V C@ DGA[(C D ? 8:"$)*DG @(D%)*DG $)* D C8X'ED C@()*DIC 'D C8X?&C VC C@@ I(81! +8: "c %Uc @(c? ?8X" 8! + 8XE#?@(CC8%D C G GhFhDC> D6! C8%"8Y"@(D%)*+8:" +8: "8%" +8: "h8!8!c8! 8: h?6"8! +R + 8: " 8:# +8: "hI ! +8:#   +8:#c8 !+8: "  +8:#  +n8: "  "8: " +=8:# !8:# !8:# + 8:# +8: "  8: "  C +8:# D @()*EVRFMG VE!V<C8! C D85" 8E"V#c?C?A D85" 852"] ? M((T(C YC8"C C6#> F8"Z(6 CyV C C8'[C YC8"C C6$> F8"Z(6 CyV C C8'[C DE Wc(C +8: &C +x8: &gh8"lh8" +8: &D C@()*G F D G +8: " EDC> FEDC>E]G M>()*G D G G @@ C DC@@@()*5% +8:# C 8: "  D   C +{8:' 5&(DC +8: &8! ]h{Vc ^l#y(D(Ehy(E Diy@(D C UV A(5'()*EG C +8: &E W 2G Vc Ch@@$ 5(6 @[C +8: "$ C +8:"V +v8: "8:!!$      8: " VC(5)6 @[)*D V+D CCUDV  8%"#V gA[ C@@(5*6 @[h8X&)*EDD V_C8! C W LLLL LLLLLLLLD +8: "  Ch@ +~8: ! ] Ic L   $5+6 @[!]h L$ 8:&)* 89" C W   +8:&d(h@()*D C E DCVXUCVXV @ C C@CA A[FA(EFT C C CA()*E D E D CVCXUCVCXVC C@ C C@hA A[()*D C C 85!XVDIEIFI $ (CUDV(5,(C D i$ 8:"X()*DC85 8: " 8: " ?85!Vh8X" +8:" 8: " 8: " 8%"  +8: " C +8: "  +S8:# +8:#c?  +8:'D?85%E(E W%G VC(5-85%C +8: "?85%C +8: "?85%c?h?h? >(D85! WC VC%T D8: &c()*D C UEVUVVUV$)*8! V C E"VV C E"VV C E"Vc(V C F"IV C F"IV C F"I 2# C W &chcqc Di 2 E %C 8: & D c(YC8X" G   2+;8:#Z(6 CyV iii2#8: & [C %E !F %C85 ! C +8: "D % Eiii2#8: & c(CC E"Vd DIC E"Vd EIC E"Vd FI()*C?C?C? ,       +8: & Wc( C8:!&)*C ED + ?8:"$ )*8!C 8:"XVC @IC W D C 8"V   h8L XV8"AA[!V 8:"XVgYWh8X # C D h81# Y C8>!8:#ZT8 CyV 8" @A[[D @ 2 ZT6 CyVcT[2#8: &  CDh6.85  D2$ 2#85&(C6/81# Dh C$)*Cc(c? ,G +81 & Y C8T Z(8 CyVh8"?A[7 CyV D?A[[)*G+81 &)*D C D EUG VC 8!C W D C Yl 8X" C8:!8:!zV50T;C h8L U51T&$8 8#8 " 8!628B  hzV @ GA[Z( 6 CyV ? GA[[c @GA[c(WC(536 @[)* D$8! CC^(E C Y+8:" E D@ZT6 CyV546 @[[ DD C+8:#VV C CD$ c(WC(556 @[)*VC CC ^VED(D 2&566 @[E C8!"$)*D DC? E W&cT;,E ! ,C  +8: "T,E ! C  +"8: "TG VG VCT576 @[ C D$ (D8%8: "E8%81 &E8%%C8%8: "E WcTC +8: "T C +8: "TG VC8%%(CD DD Y 8>#Z(8 CyV D?EA[[58(E&FD C W  T DVTCT E CA(C Ei8# F DC8!>(CCC E"V ?GA[C F"I(G E D C>(D(F E +8: " CA(F E D C C8! VkCh8!h8!h8"8: " h8# D? 8!C W  C 8"VT 8" @DA[ 8! ? >( hi8"8: ">(Dhz(CCC E"V ?GA[C F"I(E Dh8# Ch8#A()*D Ch8!c8!! D+8: " E Wd59TCC? +8: "7z +z8:"8:!}V dGA[  + 8: " +8: "? +8: "?@TDCC? +W8: "+28: " +8: "  +8:"Vd @ ?@TG V!X C  8# D? ?@T5:Gh +8: " D FD 8:! > +`8: "c8 !!V>Y 6;8!8%"?8X"ZT6 CyV5<6 @[[ C G G VC  8U#V C?GA[GG C FC C>  A( V CCGi8'c6=8&YC+8: "Z(8 CyV c GA[[)* ^()*G V C 89"T5>6 @[ C W >>>>> >>>>>>C8!DT0C85 ! ]i M? I85!Vc85!TDT5?A[ 85!XV5@A[c?CA I(G V/CC W ### TCCW   TdTcV EhyVFhy()* 8;"8! C W  7) C8&c(ch8&)*? 8X" G V4C +8: " YC 8" 8>#Z(8 CyV D? A[[(ch85&5A()*D Gh C +8: " G V ch8"?FhC8:!C +8: "> 8X'5B? + +c +, ++] +P ?8!+!  +` +85  , + +n +V+ ++y + + ++ +L8: ! + + + +s ,+^ +( ++ $')+++ +!+"+ "$)++ ++P + +n +. +)   > +9CT$W(E2%D8%8: &)*E8%%W0D8%8: "E2%C C8%!D +8%G "F +8: &D8%!E2%)*W E 2&(c E 2" DC>8%W(E2%)* @()*C ^V( @(8\! E C8!8! Ch+8:#h D +8%G #A()*WE 2# DCA( A()*E8W!V(W 'D8W8:&C C8W!Vd D +8%G '(D8W!VE2%(D8,!8: &)*E8,&)*W4D 8,!8: "E 2&C C 8,"D +8%G "F +8: &D 8,"E 2&)*FEDCD C Wd C 4" D WT  D C@@T DD8%C h  CDD  "8%G # D   ?"@>(C E D C Fh 8# D    A D      >?"@>(C D C DE      A?"@>(C D C DE   8%F"   A?"@>(C DDC  DC@?"@>( )*7%C? h 8# F E D89" C> Dhh8"6D8!  h 8B 8>#Y  8>#ZT8 CyV ?DA[[h8%C8%Ch> 1#8:# F E D> C>( )*h8# D Y 8>#ZT8 CyV D? DA[[()*D C WwD C CD8# D C E8"V C? DA[D C84" C8:! 8:!zV8:! 8:!CA  DA[ +i8:# D A    A$C  EDC 1  E? ?$ C Dh8# D E2" D A  A$ c8 !c8)8.!6E>8!I h8 h8 ! ?&@&c 6F>85!h8 ! I  h8 h8 !cTd ?C>&i?C>&y?C>&y?C>&>&?()* 8! @@()*DEDCE D C i F C @@ F E D>()*GGGF E D C DC WK'aE D C    4  E W T  D C@@T ED ?  Ch   > D+J8%G # F E D ChE +%8%G # V*@CD +?  F E DAT A  E D +?@EDC>(C D C8CVc8!Eh8# D8CV c8 !8)!    h  Ch E C   +4?@FD>(C E D C C8%E"ViyV!c C@? D8"ThyV C6G@A[7CVc8!Y F 8"ZT.8 CyV"D VDVTCC?A[TT[8CV c8 !F8)!    Fi  Ch E CC8%F"   +@?@FD>(C D C EC      +?@   >(C F E D C C8%E"ViyV c C@?8"ThyV C6H@A[C8F  D Y C W !D C VCh8# D 8>#8!C W V VVVVVVVVV5Vch8" h @ 8!8># 8"8>#T) CDhh85  8" D 8>#T5I6 @[T5J6 @[ZT8 CyVDC6KA A[[#C    + _?C8%F"@>(C  DC   D C     +?@   >(C  #C +?    @   >( 8:&C(D85 !hy(C(ch8" E8>'] C(8%(E8*%)*D C ^V85 ! V(d C857"( E 85! >8%)*D @((D85 !hz(F E DA(D85 !hyVd Y  C8B E8>#Z(6L6 @[89"8!8!C()*C Di D CAhh8"6M8!  h 8B 8>#V ch8"T     8  F E D C F Vc?hh8"@8!T Y  8>#ZT8 CyV ? DA[[+Z V ! + 8: "Dh8%C8%Ch G G >   1 8:#hh8"  8>#G GC +8%G"> ! +8:"V 8!F ED>!hD +y8%G # hzUhzV iA A[c8!+8:# Y c?@8!8>#8>#ZT8 CyV D?A[[7CV  +8: "F8:! +8: "8CV  +8: " C +y8%G"! +a8:" +U8: ! ! ! +?8:" hzV ?8"V T F E D89">   >@()*C ? 8X"h8! Ch8-#h88!?8Y!A>h8 !F8%!Eh@ FA8!8!   Dh8X C DA@@()*W(E C 85-!V 2& @2&)* D CA()*Wjj`D C 85.! 85-!VdVY85-!URVC C? DDA[V7C D C ^V5N ^V ? DA[   8 ? DhAT5O6 @[YY 85/" F E8%" D C>ZT(6 CyV 85/" F E8%" D C>T[ D C85-!U 85-!U   8 ?T 8 "  8  8 !? F EAZT96 CyV.85-!V6P8:!"U  6Q8:!"V 78 "?  AT[ E @@T D C E   A@2$8%" VC C? DDA[E?DA[ +\8:# 8:!@(5R ^(5S C^(Wd(c(C E? 8X" Ch8-#h88!?8Y!A>DA(F8)%)*D Y 8>#Z(8 CyV D? FA[[h8')*C W C CD8# D C E8"V C? DA[D+8: " D C84" D C #8:! 8:!zV8:! 8:! CA DA[ +[8:# D  A> ! ! D EDCh>> %CDh 1  D?D C?> %D C VC Dh hh6T8Y!A@@@ 6U8Y!?@ h6V8Y!?@?6W8Y!A@@@ 6X8Y!?@@@ D DFh E@@jA@6Y8Y!?@h>@    2$7CVc8!E   8  E C8CVc8 ! +A8 "D +8: " ,c8X8h86Z>@@ D8#"h8 ! F F 2 h8 !85-!VE !V g D8" EF8.! AD >> %D  C2  ,7CU4Eh " 8:! 8:!yV  +J8:"V +88:"V g D8"d ,xVhEhh T cEhh  D D C@> % C Yc D  8 ZT.8 CyV"D VDVTCC?DA[TT[ D Ch@ 8Y! +O8:#  ED 2  E D C >> % c8 !c8!  C2  8!c8! D" 8!c8 !E E8]!8!"D D8]!8!"D E8$# V ?DA[D! Dh84"D D EDC? >> % C W 27ch8&C 85-!V8.!Tch8"h F2! >8%E2%C2%C W ch8&C 85-!V8.!Tch8"h E2! >8%)*GFEDC DC8:!   DG    EG  EF !8CV8*!c8%C8%Chh8">?hC hzV? h> V   8X"#Thh> 8X## C  D C DC> @@()*C W=DHDHY%C8X " E8 " Dh8-#  8>#Z(6 CyVc(5[6 @[C 3'FTC 2'C Wc(D')*D 1+8: &5\ 8 f&5] 8 f&5^ 8 f&5_ 8 f&)*WF E DC6`$F E DC6a$)*VT c? @85! 8!8 8  6b8 f$5c 8 f&5d 8 f&6e8 f')* +8: &6f 8 f'5g 8 f&5h ^V 6i8 i&5j(6k 8 f$5l 8 f&5m 8 f&5n 8 f&)*W!8N\ds)9_gq5o 8 f&5p 8 f"+ + C 8%$D C + +E8%$C86q 8 f$5r 8 f&+^ C !6s 8 f'C 8!8 6t6u8 f$C86v 8 f$C86w 8 f$E D Ch @ @ @8!8 8 8 6x 8 f$ C + +D8%$E D +CV5yT5z V V5{T5|T5}8%" 6~ 8 f$ E D C868 f$+j +^ C 8%$E Dh @ @8!8 8 C86 8 f$ C 8$&C6 8 f'+ +h8!D C68 f$ C8 6 8 f$D C8!6 8 f$C8 6 8 f$DC8!68 f +e +Y E 8%$+E +9 C 8%$D5T5 D C68 f$D6 ^V C68 f$56 8 f')*8: " "C(7h@ FD8h A?@ ] L(C()*iC8%!  D C C89" 8!8!8! C +8: " C#A( G G G GGGDF>()* h  D C +8: "@()* i$)* i$)* " D @()* C8%!  E @(EC68%"8! EC8! EC8! EC8!>()* +8: "h8!8!c8 !h@"8:# Dh@ C"8:# Dh8 !C "8: "h 8:# 8C " 8:#  !8:# !8: " @()*G G G VC G G V.V+CCh81# CCh81# C C 8>!8:#D D@T56 @[ D C Y c  8O ZT8 CyVE D@8A[[8!XV ?A[G G G G G G F EDC> ()*V E88 "C8X"#T G88"F8X## G88 "G8X# G88 "G8X')*G G G G G DGCG F F E D C>()* G G EGGG>@( 8 ' 8')*G GGGGGF E D C Y C8`"ZT8 CyVDA GA[[C8%8: "D!F VC8%!C8%8: "G VC8%!C8%8: "G VC8%!!XV  @ GA[D8\! C8Z" V V +>T +/ C @ GA[G G      E D C>  G G G         E>( 5(5(C()*D @((5(Ci8')*D G GGGGG F E D Ch8!c8 !YD D C +8: "ZT8 CyV c DDA[[h? Y+7C ?@@8IF"8C8:!8IZTh8I[ Dh8 !8]! 8!8! 8,!8: " "84" D C  ?8" 8]! 8!8!Y8>!8:#ZT#8 CyV?8" A  GA[[Y 8>#ZT 8 CyV89" A GA[[ 84" C D8]! 8!8!8 Y8>!8:#ZT,8 CyV ?8"?8"A GA[[Y 8>#ZT%8 CyV ?8" AGA[[Yh8-#"8>#ZT8 CyVD EC@  GA[[ +8: " ? ! >  C hzV?? > G JV  8X"#T 8X##CiyV0 8\! !h D +y8%G # hzUhzV iA GA[ 8^! 89"8!8! C +:8: " 84" D C? ! > C hzV  h8-#??>Gh +8: "?ih8:! >8]!h81# D C 8!8!"8 Gh +8: "?ih8:!> )CCC8:!' &'((> @@()5()*ci }U\hh8"@ zUcch8"8! h +8: "?ih  >8X# A(] C(8%()*cI "C8:! +8: "cI()*D Y 8%G" D TZT6 CyVT[E CA8%F'  8Y& @()*+ +Dh68%"!6!?!@!@@h6A@()*h 8# Dh8# D Y  8>#ZT8 CyV D? A[[@(8" D !h@IJ(Y 8>#Z(8 CyVD6AA[[)*   8F  D  +C W 999999999 9CU+&D  h8!h C  +s?@I(  h8# D !( )*   8F h 8# D Y D 8>#ZT8 CyVD6A A[[( )*! W ?A[C Y C 8>#ZTn8 CyVbD VRD VED V8D V+CCC W  T+D C6AA[TTTT TTT56 @[T[ E8%G" D! 8%G"VmCP W5T  Ch8"T 8%D!XV8%G! @? 8"8%D!XV8%G! @? 8"T8%D!V8%D!V 5 A[cE8%G" 8%G" A()*D( 8%F&7%C +8%G ')* h8-" YIC 8%G" E D^V   @A[F!!8>#T  XVC?@ZT'8 CyVD6A A[5 CyVh@T[ C V   C>T @8h C D C> 8%F#I()*i Ah8X)  C  i Ah8X     A 8X  D >( ?8'!?89!(C8W8:"VD%()*C ^V(E 8%E"V( @(C8!8! Ch +8:')* @()* @()* >()* >(+ + + +6?85 68!? ,-,K+ ,,,,,+H ,a+/ + +# + ++wh? ++ +L +  ", _+  !%'),,4]Ech85"8) ! ,,+ !,<!'+!&+K + + +(+   +Qh? ++ + + + ,+8 8I + + + 84  ><9TG )*Wc C8! ?A(E D C 2"A(56 @[)*V&C W (ED D C8X#2&(()*VD 2" 8%!68%"@()*VC C8!85!V D 2# h"@( ')*VC C8!85!V D 2# h"@( ')*C W:@CC D 8# C?(C 3"?(D 2" CC8X,# E D2" CA(C 2&C C" D()*c GGA@ GFA@ ECA@()* D CA()* D C8X 'D" CC8!@()* D CA()*VD C C W  $Ac2&C8C" 2" +' D1" CC8X,# D2"h CA@(C1+8: "  +x8:# 2" +_' D3" CC8X-# D2" C@@( CDh  D2&C 1" D#88" 8X&" 2" 8%& C 8"2"h @ +#8:% ()*V C 4"?()*V*C W C8!8:"VD 2&D 2" @(VC W D2%D2! C@(()* DCDD  D C C@@()*D C W/^C C#  ?@$ C 3"  D? ?$ C D2" D C8X,# CE D2" DDA  >$ C 2" D D# D h@ +`8:# D?8%! C@$ C  C"  D C?$ )*G()*c GGA@ GFA@ ECA@(ECD6$)*G ()*c GGA@ GGA@ GFA@ ECA@(ECD6$)* ED CA(CCD6$)* ED CA(CCD6$?()*c8!8!VD C D C W f)c7C DD8C# D  C +?8X)  C D2" D E !8!8:"VT@@ C    A #@A( C  +e8: "8C" C D2" E D +?# C ? #@A( C DD8C# D C8X+# C D2" E DD@@ C   A #@A( C CD6 D " D C8X,# C D2" E DhA@ C   A #@A( C +8: "D # C D2" E D +b# C ? #@A( C CD6 D " D C8X-# C D2" E D@@ C  C A #@A( C  D h  D2" E D C C@ #@A( C  " D D #88"  D  8: " 8X&" 2" D E  !"8%" C  @ #@A( C  +b8: "8" C D2" Eh D@ +#8:! C  +8:#? #@A( C  +8: "8" C D2" Eh D@ +#8:! C  +z8:#?  #@A( hhA()* C? C? C? 431  ,c8'!8XC! " E D CA ?@8'!( )*VC 4" D? ?@(5(C D" C8!A()*D" D CA()* +8:')* ED C8X ' +8:')* E C8X ' +8:')*+ +4++8: " ! " !  # " !  # @( C W C(7 CV D2! C2!@(?[Wd(C38:&E2%W d(DC8W%D1%V9C W.$$.$.DD VTD2! C@(T D2! C@(D2%(V0C C V$D V8! C^VD2! D @@(TD2%(W H(D CV(Ch 8!@8:!"V!h 8!@8:" E ] ? M A((C ,{E  !D  A()*( # 2+8: " ?(h8X"hz()*C W3WhC CD8# D CV   8%#T D@>% DC   h3  D?D C?>%C D " D C8X,# C  EDhi 2  EDA D  >>% D C   h i2  Y !?ZT CyVcT[  h  Vhz2  E 8%" W E?DA[E C YD E8n#ZT8n CyV D? DA[[V8C8#8"T,Y E 8X #8%#ZT6 CyV ?DA[[ D  A>% Ci2  D "  ?D   F E D C>% VdDA[7CVc8!C8"8CV c8 !F8)!F89" C W ` ``````````f D8A[E +8:"V F?  DA[7CV F858"XV 5 D8"DCD T F?  DA[  D @>% G D CA()*c GGA@ GFA@ ECA@(EC6$EFcTd G G A()*c GGA@ GGA@ GFA@ ECA@(EC6$)* FE CA()*C E"i  E8!  EC>(D C@(CC6$)* ED CA(CC6$?( ?8X" @()* ')*+h8!8!VD C D C W +'``^C8"2" E D C? "@A( C W/VCDCTDED A??TEDCA??TcT  D 8  D C 2" 8Y! +I E D 81#C  @"@A(C D 8C#  DC +?8X)  C D2" E DD@@ C  A"@A( C +8: "8C" C  D   2" E D +# C ?"@A( C D 8C# D C8X+# C D2" E DD@@ C  A"@A( D C C 8C# D C8X+# C D2" E D@@ C   C >"@A(C  C6 D C "i    EC  C8X,# C D2" E DhEA@ C  A"@A( C +8: " +8: "# D C   +18:# " 2" E D + # C ?"@A( C  C6 D" D? C8X-# C D2" E DD?@@ C  A"@A( C   ?  D2" E D CC@  "@A( C +r8: "8" C D2" Eh D@ +'#8:! C +8: "?  "@A( C +8: "8" C D2" Eh D@ +#8:! C +8: "?  "@A( C   hi  E D #88"   8: " 8X&" 2" E D8%" C  !@ "@A( hhA(D89%)*VCC?C?C?     1   ,7CV  +8: "c8'!  " E D CA ?@8'! A()*W c(C 3&E 2&3!8: %)*W c(DC 8V&D 4&W(C3!?(E2! D CA()*VnC W3SD @2$ C8!D E"VT @F"2$ C8!D E"VT @ F"2$ D E D!CA@2$ (-,8:!hCC$V6C W++++++D CVTG VD2! CC8!@@(D2%()*V.C C D 8" 8! 8!D ?8#2"h? A@()*W"*8FTbp5 8 f&5 8 f&5 8 f&C86 8 f$C8n6 8 f$C86 8 f$C86 8 f$C86 8 f$D8n C868 f$D C6 8 f$C8 6 8 f$D C8!6 8 f$C86 8 f$C86 8 f$C86 8 f$C8 6 8 f$C8 6 8 f$C868 f D8 6 8 f$ C8:"X(C(81! 8- !8L!6 8%" 8X3"68-"V 8X8%"XV ? 8A[5 8%" 8X3" @()*+8: "h8!8" 81!8zC 8%" ]VA]XV ? 8!A[8X3" c8Xh  @6 8%"8'  68n$  +E8: "h8X7! +.8:"8?CXV568%"  8X5  ?8Xh @6 8%"8' c( )*???68%"8'$ )*c8'!Yc8!7  # E D C !8CV868 08 f c @T7zC 81!8%" ]ViY58%"8zC81 "ZT6 CyV ? 8A[[ 8X3"   8n h8!c? ?68%"8' @T[C"" 68n h8!7?CXV15 8%"8X4# ?? ?68%"8' @Z( !c?h8'!8+ !? 6 8%"8' [h&)*W 56 @[7 C A(7 D C 2"A()*Ych8"8>#Z(8 CyV  @DA[[c "8&)*c8a!h8!8!c8! "h8!8!8!C W E68X,# D C?@T C@T D C ,L +8: "h8 ! c  c?   @(  D     +28:#  c   @()*C W  "TC CD8# DDC@>!T E ! !XV ? DA[ @()*7 hh6$)* A ?8'!()*Y E8n#ZT8n CyV D? DA[[ D >>()*Y@8X" V"+  88: "8:&"C   T?TcA[Z(6 CyVh8!"? 8 A[[F E C D8"  G  Y 8n#ZT8n CyV D?DA[[DD ? D >>  D>()* D? C8')*EVT  C  D8X 'C G 8! A()*, +8: " +8:# 8 +8:# h2$  +. 8: &)*? 8" 8" 8%')*+ ,7 8:!i$)*V8 CA8%'()*C ED8 8!A8%# 8X')*VC  +8:'()*??()*V 7 CA?()* !8: &D F8W!XV F? DA[()*C W   c(D+8: &E E!XV E? DA[()* A ?8'!()* > ?8'!()* 8# C()*W &c(C8! 6$ C8! 6$ C8! 6$ )*CE"V  @ A[CF" I()* ^( 8X" D8C$)*D ED C?8%# +8: &)*8: " +8:')*V Dj !81# Ci "@((ch85&C X X DXA()*VC WiiiiiV`DU\C D E DC WTF C EV 8!^V8C!V7h G +8: "hhhC8:!C +8: ">68%"8! 8X#  ?? 8C  D     ] C I cT    A@ A@? ?A@( 8!^V: h8C  D       A@ ??A@( 58%" 8!^V ?  2$ WT) 8!^V? Ch8C  D   ? I" ??A@( TVDCD EDCU WH C 8!^V4C8# C D 8%#  8n# A@ @?A@(TF C 8!^V7C8# C D 8%#  8n#? I" @?A@( 8!^V.c # 2  C D?A@ E C"A@( D8X%"2  D @ C@(C?A[)*V CC ^Vc(7%?[C W  C(7%?[)*c? , "Y) C8!  c   D VDVT WT C C VCT56 @[ Y_G VNCC W  T9DC8:! 8:!yV +Z8: " C +88:#CTT TT7%?[ZT8% CyV e GA[[ Y C8X"ZT6 CyV56 @[[8 C8# 8"T5C VCT56 @[CC  8#8 C 8# 8"T C@Z(8n CyV DC@A[[)* A()*@V:C W (EDi D CA@((EDi D CA@((((7 ?@()* 8X# V C8X#TT " 8n$)*56 @[?89!()*C 8# C D#   ?8X'  @()* 8%" W ? A[C()* 8%" W c A[C(C(5? + ,+ + + +y +l? ,+3 ,+ + +  +f +h ,,  ,$+6 + ?8! + + ,,+v +^ +H   #&),.5? ,0,Qg&+ + ,q+ + +o +3,+*,//+/+| +f    &(*03=?AF,q+%hhi#hhh# ,#, 8?+ ,@+ 8I#8 I 8 I9+x8I8I8I C+! + ,C+8 + E#, > E9TX )*W2Pz;c+RyGWZZZZZZZZZZZZZZZZZZC C8 &W;;;;;;;;;;;;;;;;;;C C^(WC C2"V D D281 '(WC C^VD D8 81 #VE E2&(WC C^VD D8 "VE E2"VF F2&(WC C381 #VD D2&(W\\\\\\\\\\\\\\\\\\C C^V D D281 '(W222222222222222222C C2"V D D4&(W                  C CyV D D281 '(WD D C C2"VC CyVD D8 81 #VE E2&(WC C2"VD D8 "VE E2&(WqqqqqqqqqqqqqqqqqqC C2"VD D2"VE E2&(WBBBBBBBBBBBBBBBBBBC C2"VD D2&(WC C2"VD D2&(WC C8 "V"D D2"VE E2"VF F^V G G2&(WC C8 "VD D2&(WC C^VD D2"VE E2"V F F281 '(WNNNNNNNNNNNNNNNNNNC C2"V DC DC^(W&&&&&&&&&&&&&&&&&&C C8 "VD D2&(c()*C C8 "VD D1&()*C C^VD D&()*0+ C CyV;E EyV4D D 81 #V)F F 81 #VG G V VC C4&Ud(c(D%D%D%)*W$-<D<kktC !D 8: &E %E !F %D !C +8: &D 8: &D C !D +8: "F +8: "G VC %(C !E %C !D !E %C !D %D !E !G %D %F E@ D@ 8: &C %c(WMMMMMMMMMMMMMMMHMF2%E WTCTDVT d(C2%c()*Wdddddddddd#dddddYdF 2" E DC>(E WT&CTDVT DCA (D C 2"@(581%W(C 8 !V c ?@(?(c C2!@ E?@(581%)*VD C V ! 2" @ ( %(W d(c(g(g(f(e(W c(d(f(e(g(g()*WC 8 "V( >(W,/@L]ly2<Y C8"Z(6 CyV([(E D28: " C2!A(E2! D CA(F2! E2! D C>(D2! C38: "@(D28: " C@(D G VC2!? F48: " E D48: "C> C2!@(D28: " C@(E2! D C2!A (E2! D C2!A (E2! D2! C2!A (D2! C2!@ (D2! C2!@ (G2! F E2! D2!C>(D2! C@(G F28: " E2! D2!C>(D C2!@(D2! C@(D1! C@(D4! C@()*, %C(W;;;;;;;;;;;;;;;;;;C$D WTc C@(c( +&Wc(c C@( +&C G"I(C CG"I(C G"I(2"C !F8:#IWaaa -aaa: aaaHUaaaD+8: &C DG"I(C+8: &DD+8: &C CG"I(C CF"I(c()*C? ,y !C()* ^()*V:C W+58! D ?@2" h>(D @2&8:!%)*,h &)*W$58! ! h>(C %5 ? ,D+ + ,+[ ?8! +7 + +ch? +6 ,#,s,, + +_ += +     %'&>9T 68 f')* +8: &68 f$)* +8: &)*WWaC W%/9CC6 8 f'C6 8 f'C6 8 f'C6 8 f'C6 8 f'C6 8 f'C6 8 f'C6 8 f'D C V.+ D C26 8 f$ 68 f'C V+H D C68 f$ 5 8 f&C6 8 f'68 f$)* +8: &868 f$)*V  +8: &(68 f$)* +8: &CV 58 f"TdID C68 f$CV 58 f"TdID C68 f$)*c? D +8: "F +8: "G VCV 5 8 f"Td IC6 8 f$(6 8 f$)* +8: &CV 5 8 f"TdID C86 8 f$)*c? +8: &W(ED86 8 f F2%86 8 f$CVcIT5 8 f"8&)*5 8 f"d? +8: "5 8 f& +8: &6 8 f$)* +8: &)*W!4Iq +PaC 8&C &.+ D C26 8 f$ C +| E2D 6 8 f$ 2,E2D86  8 f F ! 26 8 f$.+ D2C 6 8 f$ .+ D C6 8 f$ D2+6 C2G V5 T5 6 8 f$ .+ D C6 8 f$D E2 D +CC26  8 f$ E2 D8C26 8 f$ E2 D2C26 8 f$ D3 C26 8 f$D2 C26 8 f$G2 E2F5 T5 D2C86  8 f$ D2 C86 8 f$C2+ 5 T 5 T5 F D2E26  8 f$ D D V 5! T5" T5#  C2 CDFCCFCEV5$ T5% CCDCCC6&  8 f$ D2 C86' 8 f$)*W 1&D2 C26( 8 f$)*W#'JRZbjrz "*2:BJRZbjr/9C} %[h5) 8 f&5* 8 f&5+ 8 f&5, 8 f&5- 8 f&5. 8 f&5/ 8 f&50 8 f&51 8 f&52 8 f&53 8 f&54 8 f&55 8 f&56 8 f&57 8 f&58 8 f&59 8 f&5: 8 f&5; 8 f&5< 8 f&5= 8 f&5> 8 f&5? 8 f&5@ 8 f&5A 8 f&5B 8 f&5C 8 f&5D 8 f&5E 8 f&5F 8 f&5G 8 f&5H 8 f&5I 8 f&5J 8 f&5K 8 f&5L 8 f&5M 8 f&C86N 8 f$C86O 8 f$C D 6P 8 f'6Q 8 f'C6R 8 f'DV5S T5T C 6U 8 f$C6V 8 f'C6W 8 f'D C6X 8 f$CC6Y 8 f'CW&.5Z 8 f&5[ 8 f&5\ 8 f&5] 8 f&5^ 8 f&5_ 8 f&C6` 8 f'C6a 8 f'CW&.5b 8 f&5c 8 f&5d 8 f&5e 8 f&5f 8 f&5g 8 f&5h 8 f&5i 8 f&5j 8 f&5k 8 f&5l 8 f&5m 8 f&C 6n 'C 6o 'D C 'C 6p 'C 6q 'C 6r 'C 6s 'C 6t 'C 6u 'C 6v 'C 6w 'C 6x 'C 6y 'C 6z 'C 6{ 'C DW ") 6| ' 6} ' 6~ ' 6 ' 6 ' 6 'F EC6 $F EC6 $)* 5 8 f&5 8 f&)*W 5 T 5 T5 T W !%)-159=5 T15 T-5 T)5 T%5 T!5 T5 T5 T5 T5 T 5 T 5 T5 T V 6 8%"T6 8 f$ )* "6 8 f')*W 6 8&6 8&6 8&)*! !6 8 f$)* !6 8 f$W 5 (5 (5 (,+ + + + + + + +w  ,]C  A 9 TF G" W NNNN NNNNNNNND V;D V2D V)DVT+ cC G   cC G @(TT5 ()* " W  (C W(C W(DV(5 C8!^VY  D8:"Z(6 CyV([(G F&G F&)* "hh W  . TcD VDVTVCCT9TFCC W  T/D VDVT"CCTT7) 8"V&c(Dhy()* " W C8) 8"U 7) 8"Ve(7) 8"Vf(7) 8"U)7) 8"U7) 8"U7) 8"U 7) 8"Vd(Y'8X" E WcTC +p8:"VeTdZ(6 CyVc([d(c(Dhz(F G" W ```` ````````C8) 8"XVE7) 8"XV:Y,G8X" E WC V +8:"TdTdZ(6 CyVd([(d()*F G" W   C8&c()*8+! 8;"8!C(+ + +P + + + ++6 6  +*   > 9 T! G4 G3@()*VD C V 26 8$ &()*! Y 8"Z(6 CyVRO 8!Vch@hh@@h@T*C {V4"TC {V4"T3"T5 6 @[ 8#([)*Oj q  "hi@hi@ Dh1" D CEh1" D CD "D ""V "T "@ ?@( )*O h1" DCVc^ ^ E E^Vki # D C Eh4" D CFh4" D CyVcTdi@yVcTdi@D "D ""V "T " @i@@ T @6 @T @6 @ D "VC@( C@()*Ol@i  }Uv\"hi@hi@ Dh4" D CEh4" D CD"D""V"T" @"VV  6 8%8#  @   zUc @ D CUgl@i }Ur\ # D CyVWEh4" D C Fh4" D Chi@hi@D "D ""V "T " @"V    @  zUc ATgl@i }U\ }U\ # D C Eh4" D CFh4" D CyVcTdi@yVcTdi@D "D ""V "T " @"V  @  zUc zUkc A D C@ E "V C? @(D@ 'D@ 'D@ 'D@ ')*D C O cT5 6 @[ h "^%h" C W h"^%  D C# F E D C h" DCh" DCyVX "V*D@2#D@2#CnD $D@2#D @2#CnD $ "V&2+/2+oCn $2+2+oCn $C " E D C h" h"D@D@.Cn&Ch"n2# 2#hD $DC DC"V2# 2#CnD$2# 2#CnD$)*()*ChIC^V8! +8+ "@ h@' )*C C8%!|V  D8%!|IC^V8!@ ! D C # h@' )*^ yV^ E! D CA_T^ ^ #! D CA_h{V  2&()*D C_(5 6 @[C @C8#(^(Y8" CZ(6 CyVC+ @ 8#([)*D C O6 ^lh8"h?O? + +   ,  "+lC^ +X8 "@( G 'Cmo + Cmo DG"G& DG ')*^ _(Y 8"Z(6 CyVC 8#([)*D C ^ C ^h Do^lh8"h? +  }U8\ ^ E! Co Do }U\  _ zUc zUcc ^ C^  +V8 "+!( c(^(CO8% ^h ^ +h }UH\c }U3\  #V ^ !{V_!_ zUc zUc^@()* yVd(C ^ ^ DO   #U"C ~V5 C]! D]!^%^$C^&6 ]!^$^E()* oC {V 8+#h" DDC(()* ojyV2 ^  ^ C^ C CyV yV D yVEE^(Cmn@ ! ! !$)*+ m DG"G&! ! D!$ )* G "G 'Cmn@ ! ! !$)*+ m DG"G&! ! D!$ )* G "G ')*D$ )*C$ )* G$ hG$ )* G$ hG$ )* E$ hF$ )* F$ hE$ )*h!@@G"G ' d(" ^V2%(O  " , %)*VC C^VD(D 2&CC @@IC()*c(^ E D C yV2" #@(2" #@h@()* ^V C "?(C "?(c?h? ,s + ,O^ C O" E D #@()*W 5 8&C6 8'C6 8')*O ^ ^ o8+#h8+#"o8+# DC>()*O O O ^ E D Ch^ E D C ^Vc ^  n^h  }U\^ _ zUc   ^ D {VTT d^ C {VTT A _d  }U\^ n_ zUc(}Vcc ^  n^h  }U\^ _ zUc A  _c  }U\^ n_ zUc( }Vbc ^  n^h  }U\^ _ zUc A _d  }U\^ n_ zUc(   8+&(()* ^ Oo 8+# h8+# CA()*W 5 8&D C6 8$C6 8')*C Cn ID Dn J()*C C "VD D& &)* "V(()*C CyVD Dy()*C C{Vd(C CyV D D{Vd(ch@(+ DO8+" C Oh }U4\^ E^ C ID C{V hzVzVD J zUc()*c O }U\^6  8  zUc()*C D 6 8$)* ^ C()* ^ E(C6 8%8$)*c O }U<\^ E D C yV6  8 T6 8  zUc()*7% yV 5 8&7% yV 5 8&6 8'g?l? + +} +j +\ +M8%8%@ +/ + + + +n +[ += +& + + +$ + + ,gh8" +z+livh?  #%, C+ !+c "+@ #+ $+%+&+&+ (+(+W *+$   '-/, 5 ?k? +.+ +) +1+ +^  !+c +1    "$&(*,.02468:<>@BDFHJLNPRTVXZ\^`bdfh>5(6C8+ %)*V C "V@[D 2" D @ C@(c@ @(,YCh" DICZ( CyVD([c? + + @(5 ? + + + @9 T 9)*Vc(D 2&d()*h@(VD 2" D CC@@(5 6 @[)*V/D C C ^V D@( ^Vh@(2" D @ C@(5 ()*VD C C ^V( 2" @()*VGVAD C C DC C yV 2"D D8%"8#" @@( }V  2" @(2"@(((VD VD2! C C"@(((V DV!2%C(D! C@()* +8: &D6 8"F%W&C6 8%#!C!D+8: &5 8%#!CC2%5 8%#!C%)*W+.DY C8:"Z(6 CyV([(CF E 2"D@@2&C W#'JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJNJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJT!D 2!8: " C?@(D 2!8: " C@(?[VC C VD D D C C W / I 2!@(2!  Ci8 8#@@@(  Di8  C@@@2% C V%8#! GFEDD@>2! @@@( 2!8#@@@( ! C W  2!@@@( @@@2% 5 6 @[()*VCC ," %5 6 @[V.CC V!C CW   (D2%5 6 @[5 6 @[7#()*F &)*C W  $-6D$PP( C8F&C D8F"2&C 28:'F 28:'D VC 2&(C 2+8:'C 2&D(D()*C W [ ,[[[[[[<[ C@ # +8: "!8#@@@( C D@2$C D      2 2$ # +8: "! 8Y"@@@( )*V'C C VC "VD 2" D C@@(h@(h@(WCE(CC2!%CC%)*VC D2" C D!!@@(()*VC C VtD D C"VZ!V   D  D C 2$"V@2$  #V@2$ @2$ @2$ 5 6 @[8:! 8:! 8:!3')*V,hhh1  Ch8! D C @@ E D#$ c $ )*  " 4 , hhh$ )*V0C C V"D C !V "V @2' @2' 5 6 @[8:! 8:! VFD C V6hh @3# Ch8! E D# D C @@  !  A?A@( hh @3'   ! A?A@()*VJC CDU8:"V c @2'V"D C !U "V @2' @2' 5 6 @[8:! 8:! V*Dhh C@1# Ch8! D C @@ E D#$  $ )* ! C V 3$ ! 3   , GV$C C VD C!V hh@'hh@'5 6 @[)*(C V D D@(5 6 @[)*VD VC C WTvV DU 3$  +8: " +" D@C?4  D C V# " D! C@?A # @(    3$T5 6 @[ 3$)* !A?A@(?( +8: "@(C V D D@(5 6 @[VC C VC CW  TDD " "VDT5 6 @[ C +8: "D@@A !8C"8G"8G!h8!8#! +kD2! Dhh@@>@  h C   @( D2! D C@@(5 ()*V<    ,6 !8%"! C8%"A  DA?A@( 4$ )*C W 55555555( C8# "(Y C2#Z( CyV D2'[?[)*C W 22222222( C^V(Y C2#Z( CyV D2'[?[)*h@(VD 2" D CC@@(5 6@[)*V'C D  D2 h C??@@@A (()*V&D C D V 2#hC??@@@A ((5 81%)* |V o@@2$ ()*VD V 2&CC((V D C VG F E Dh2!A>((5 81%)*C W  C D 2"2& @()*C W DD. 5 8#! 8# !8:"V@( @ @@(C 2'C 2# D C D2'?[)*VXW+;>8 48 "c8 5!6 8%"81%F 2" E DC>((D CF D C> C@((&&)*WJJJ2J>JJJJJJJJJJC 8 &c(C(E 2"UF 2&(D 2+8:&D 2+8:&d()*W      9          CE "V  i8 $F 2# Di>(D DC V=DVTFVTC "U!GFEhD  2#C@@C> @(TF V6DVTC "U"Gh D  2# C@@EDC> @(TRTNE DC " "" +#  2#A ( 2#A ( ( i8 $  i8 $)*E VCD "h @@(5 81%)*VdD C C " D C VKY0 D VcT   D" Ch @A 2#Z(  CyV 8h@ A 2' [2'  @()*VE ,Y    h  D C#Z( CyVVDCD2$?[[$ )*V(CC V CC W  C(D(D 2&8%)*C VC CV\D VPC CC " D C EDi@@ CA ? " DC3!  D C  D @(5 6 @[D 8!V& E DDA  h2  D C8""@( "@(&)*W AC  C1  D D C1"$ C CD!2  D" C@(C C! C W 0Hh 3$ C #   1"$8#!C8:!"3$   E    1"$E  C# C !   1"$C V8#!CEG"3$T28 !   # !   1"$8#!!3$5 6 @[)* "  CD  4  D" C@()*C W   # * 5 81% 8#!@( C 2' C@( D 2# C 2'F E D C">()*W!(C E " D +8: " C#A?(5 6 @[C #?(W ?6 8!@(c C@(C?()*8: " +8: "    8:' )*D V  C Ch8 $()*W 6 " ? @( C@(D# C@(d ?@(5 8%Dh C@@(Dh C@@()*c" chh6 @@@ +8: "Al@T0c8!h hh8#@@@@hh6 @@@ +8: "A @ D C YY h"8:! +q8: " +`8: " C  #D  +@8: " h ! !  D C 7!VcT5 6 @[T !   h8 !8:  ZTH CyV> i! h  D C !VcT5 6 @[T !  T[Z(  CyV5 6 @[[)*W&C  C  D D C"$ 5 6 @[C $ )*E " C "A(D C"@()* +8: &)*V DU C'5 81%)*c +8:'C VDU D C"@(5 81%)* +8: &)*C W   ?[8#%C(c ?@(7#()* "h8!h +8: "@h @@ +8: "A Y* 8:!! h   ! CD Z( CyVc& [)*ch@@ !h$ c@k@()*c +h8$)* !$ )*C8 !hhh E??@ D??@ C??@h@?@8)8 !@6 @@k@(Dh C@@(Dh C@@()*" 6chh@@ +8: "A  i!   D!VcT5 6 @[C( c8!h hh8#@@@@hh@@ +8: "A Y# i!      CD Z(  CyV5 6 @[[)*!V(c!h@ A (c 8#!h@@(D8%)* +8:"Vc(()*W 6 " ? @( C@()*W'  8 $ ' 8 $8 48 "c8 5%)*" " CV E' E# C V E C@( ?[)*VD C E D C Y "F  " D C ! W8  !!" "" @A 2#T2C yV! !!" Di8 !8: @T  2#TZ( CyV8@ A 2' [ @()* , 3 ' )*VPD C D D V@Y0CD" D"@2" EE@ D CC C@@AZ( CyV2& [2&c !hA()*,h &)*#C D8%"6 8! 8%h? C  h @ ?@i8 D E" @( )* h @l @A (D85! W CDU(c()*C 85 !h? FV C +8: "T7% I+ C8:!y! U hzVdVhhAT    # C D8%" ! D CUVCT_VDUVDU:6CD CD #T@VU##V C #TT!#T# #  #DE" @(???()*5 8! 8%8%? + h@6 @ i>(???()*8%8% +$ ???()* 8%8%  D D C +D$ ???(???()*C W 5 6 @[ Dh C8 !@h@6 @@6 @A ()*DCGF# C D8%" V C@TV D CD@T5 6 @[ C D+8:#E" @( 8:!GGn y Vh@T  E  C8%" ! D C ! VCT GG EAV>C CT3DVT+V C CT4DVT,D DA TTTXUShh + TA! V$C hh + h@l @A TcGG>@! D" @(V6C D C D2! D C W 5 6 @[ C@@@(C@@ @(5 (, ! D! C!@(???(C W5 6 @[D C@(C W5 6 @[D C@()*# CC D8%"W(HUds +8: " 8%8%   Tj +8: " lh  +l TJHk T=;6 6  T.,6 6  T6 6  T6 6  T DE" @( )* !@@()*D Ch @ C +8:#D!"# @(C( D&)*V5V2D C C +8:" C V DD +8: "@@2' 2' h@+8:' " @()*, !+8: "h ')*hhA(VCD "hh @?A(hhA()* !@@()*E Ch @ !C +8:#DVT "D # @()*VDUC!V"h@? ATh ATh A@A Eh@ C+8:# D C DA(VC 8: " 8#" 8#!8: &5 6 @[)*V C C D'5 6 @[)* h@+8:# C(D VC%5 6 @[)* +8:&)*   D D CCC$ )*! V C T! #@()*C C ^Vg( ^Vd(c( +8:'&)*V+DC C DD! yV  2$ 2 A@(c A@(8 ! ,VC C DD!  D T5 6 @[h C! 8+ !@()*V[DC C DD! yV6 yV  2$  3# A@(2  A@(3#A@( yV c A@(chA@ A@()*V*D C C DD!  2' 1 h A@(ch A@(V8D C C DD!  '{V h A@( $ ()*8 ! , ,D! !hC! 8+ !@( )*V  " CC@( @(???()* A ()*c "@l@()*c @ @l!@()*W#5 8! ? @T C@T D ! Ci8 $)* c @ ? @(()* @(V3C D W""""""""""""""""""DU  CyVD2%D2! @()*C }VII(D%D%W==================DU'C Y 8"ZT6 CyVcT[  8 'c(D C G V @(gh8" +D +8: "F +8: "g?l? +g8 "C'C ,c @? F ! E D! C>@( @(C D8:!yV E F8:!y()*c Oh {U\ ^^ @@ zUcchh O> @(D Co@()* o +8: " m"hh> @()**^ E yV 2&^DC  2&()* "h ^ C O^ ,h|V^?hO " D>()*c O^ Oh {U$\^ E ^ C Don _ zUcc Oh {U\^ ^~V zUc ^(g()*(c @ ? @(8:! 3%V C$ 'j 8:!q" D 1! C1!h 8:!C??@@@A ()* ,! %)*C C8# & +8:'&)* ^()*  +!$  ~V(2!jh ???@@?@@@()*V.DCC ! , !""8#! h!hAA( 5 81%)*C W 0000000,0 8#!8%&C 8:!yV 8%&T?[?[)*C W   C8%&5 6 @[C W  C8:%5 6 @[)*O! !!$ O ~V(^ G G?TG? F eTd 2! h@@@@()*VD CC ,O !" h!hA(5 81%)*C W  8# '?[ ')*C W   5 6 @[h "8%& C "8%&F EG_()*7# ^ +8: "8+ %)* !!!$  ~V(2!ih@ ?@@@()*VD CC ,!"h !hA(5 81%)*C W  8# '?[ ')*C W   5 6 @[ 8#!8%& C8%&)* !$ )*V" Dh8CC"@@hA(5 81%)*5 8! ?] CT 8!T ?hh@A8W@@h@6 @8W@@8W8W8%"hh> @ h@l @A h>()*5 8! ?6 8!] CT 8!T h@ Ah8W???@?@6 @A h@6 @h8W???@?@6 @A h@? @ i>h>(Y8!8X8X(" Y8?8X" C W!5 8%"6 8%"8%"6 8%"81!TETZT*6 CyV5 8%"6 8%"8%"6 8%"81!T[hh?@@ ?@Z(6 CyV5 8%"6 8%"81%[)* +Y?()*C W  8#&?[ &)*C W  5 6 @[8#@( C@()* 8#$)*V " DhA(5 81%)*()* ^()* ^(VC C VC C W  TD CDDD2! YC8:"85!hyZT6 CyVdT[V( 85!V%C@@ ? +   $@ ? +b   $c()*C ED 85 ! ,B % C W ###### ####C DV 85!?(85!?(5 6 @[)*V, !" " 8#!  Dih CC@6 @@@hAA(5 81%)*C W 2222222.28#@(D V C^V C@(T T?[?[)*V !" " 8#!  DhAA(5! 81%)* ^()*  +$)*VIDCC ! G WFii T Fhi 8#!"!" hAA(5" 81%)*C W 8888888 8(FU'EGG^V(Y C2"Z( CyV D2&[?[)*C W :8#@(F VDVTEGG^V C@(TT{Y C2"?ZT CyVcT[ Y D2"?ZT CyVcT[ V3C V+V$C VC G F E8hCA>@(TT(VC(?[5# 6 @[?[)*C W .......*.F8#!8%&EGG^V  F8%&?[?[F  +(,(,(C W  E(5$ 81%)*C W   F8%&5% 6 @[C W  EG(5& 6 @[ }V(2!h@ ?@@@()* , %)* 8# "hy()* 6' ! +$)*V! 6( "!" " 8#! DhAA(5) 81%)*()*C W  C(6* 8%"8%#!8#!5+ 6 @[VC C VD2! D DC"@&DE&)* , !C !A(V0C C V'C D2!DDD"@ !E#$ c()*,C %C&)*Y+8:" D CC @ CIZ(6 CyV !h@ CI @@([)*C @ I()* EDC  D CC@()* D@? C@@()* +8:'C V C8# "X(5, 6 @[)*VC C VD C !V8# "V8C"8D!Vb8C"8D!VT"VL " D#V(+8:"V @ @@@8:"@(  @@@ @(DD#V @2&  @@@ @(@2&@2&   @@@@()*, h &)* 8# "V 8# &(C V'C CW  T"U DD'(d()* +8:&)*8!XV 8# &()* 8# "X(C W  d(c(C W  "& *5- 81%((((((((CW  d(c(CW  d(c(CW   c(d(CW   c(d(CVd(CW  d(c(CW  d(c(CW  d(c()* D8!8G&C8C +8:' 8:"V VCT?[8!8! @()* +8: &)*VC8# "V D@((()*c C+8:# V  D @@(()*c +8:')*V  @@((C( +8: "8# 8#&C W  P i (E D YGF E D   C2!A>Z( CyVGFEDDA>@[[C8#! G FEDD@>(E C2! Y!D2!G F E D  A>Z( CyVGFEDDA>@[[@[,BY!Z( CyVD([D"U C8# "X()*D C +8:&)*YMh"h" W888888888888888888DU"WDUC CyT ^Z( CyVc([)*Yh"h" ^Z( CyVc([VCDh"^VD2%(?(V.D CD V!Yh" , !Z( CyVc([?(Yh"Z( CyV([C6. 8"D%)*!+8: &C%D6/ 8%8#C8#%50 8%#! +8: "51 8%#%8 48#"52 8% !c8 5!8% %C +8: "53 8%#% +8: &V8D C C ^V 2! @( ^V @@( D8%"8#"@@(c@@()*V  , %()*Vc @@(Vc(d(C64 8%8#D%V +8: &(8# &D +8:&)* +8:&)*D V%YDC8#"@C@@Z(8# CyV([55 81%)*c +8:')*D" YDCC8#"8%"@@Z(8# CyV([)* +8:')*!h +8:'VC D VxD D C C W D DDDDDD*D 8#@C@@2% C@C@@2% D@C@@ C@C@@2%2! Y" D C C@@@Z( CyV( [56 81%()*! ,k %)*C W   C@@(@@()*C W /////////8%"@(C 8:!yV  8%"@(?[)* F@()* F@()*C W C8#! +8:#@( +8:#@()*C W """""""""@(DUC^V@(?[)*C W 111111111@@(D VC^V  C@@(T?[)*C W .........8%"@(EGG^V  F8%"@(?[)*C W   C8%"@(8%"@()*C W !!!!!!!!!@(C8# "@(?[8#! C W ggg +ENg^C +(C +(F E +>(D C V C +(+(C +y(C 8:! +(C +(57 81%VBC C VCUDU c D68 @@(D D2! " VCV  @@( 69 @@(()*, %VC VD D C C W " """""""" 8#@@2% C@@2%2! Y "@Z( CyV( CyV/C W """"""""" "h D@@ C@@2!8%& 5: 6 @[[8#!5; 81%()* ,b %VC8:%c(8: &C VD C8#" D@(5< 6 @[)* !8: &)*C " D C8%" D@(8: &C V D C@ D@(5= 6 @[l"V8: &8: "8#&D VD C8#@@(5> 6 @[D V D C C@@(5? 6 @[)*C C8# "V D D8# &(5@ 8% !C8#!5A 8% !D8#!5B 8%#% +8: &8#@( +8: &+ + + + +j , +C +' + ,+ + + + +6C ?6D ? + + +0 +t + + +;+ ,,c + ++,,Q,h,+\ + + ,+6E ? , + + +@ + +6F ? + ,,2+ + + ,a5G ? += ,+ + + + + + +i +P +7   + + + + + +Y ,  +/K,L,#+  !#%')+/L_,C[L+ + +q +T +H,x+ + HK+f +J +* + + +PR+{ PS+ +T,rQT+UW+B SV+ + + + Y+ h+ + ^+\6H +J6I 6J " + +8=CVT d+w   d+] +, h+ g+ $h+ +~ +@ m+ l+ )m+ +b +=qs+ ps+ 0+v +^ ,,,3 +) +6K ,S+B ++ +e +J +6L 6M 6N 6O 6P 6Q +' + + + + +    >  G G G G GGGGG F E D C> 8 ! +> ,+k+l+ +o +* + + ,,5R ? ,+D+}f++ I+v  !+ + +/+++h  ++ ,5S ? + +H +X ,+A ,i+,x,,I+  BHNS^biq{,D+p +W+< + +: +& + +  +{+H ,+1 + + + ,3+u '+ + ,@+ +h`L> 9T TWCW#'JPffDU>T?D VDVT/C2%T&D VD VDVTC2!VC2%(Tc(d()*h8@8@8@6U @ j>()*CVCV %YdI!hIZ(hI[Y2dIIIcI7CI!C +8:#hI7XIZ(hI7XI[C @ICC@()*ch ?@@ ?@I !C @T,hhh!@C!@? @@h?@@h@@@ @ D! C@()* ? i>( +8 #h!(???(???(8!cIcI()*!CV7=CUc @(!U%Y:C8:" YC 8:" @ZT6 CyV! C @ IT[Z(6 CyV!Ch @?@@I([Cc ???@C@ @(85!???(W2222D)Y 8"?Z(6 CyV5V 8! 8#?([?(Y7X6W @8X"C8 !Z(6 CyV5X 8%"6Y 8%"81%[+lh8" +h?8?h?h? +i +L ,  + + + +6Z +}  +h?8X?h?8C? + +}   > 9[ T)*V!CCC W  C(D(D 2&8%)*G F E DhA>()*V,C D C C WhCvE CW"TNDVT]h @@D@2$ DUDE  D  D2 hGFED CA>@@( DU +98:#h @@( k6\ " 8!GFE    G F E D8hFA ?8Y! ?A>A>ih GFE D8Y! @>@@  2$(()*h@(VD 2" D CC@@(5] 8%%C W!!!dTc V3%3iG8[ $)* E C?#@ (D VC(5^ 6 @[(%&D #&Dhz( hD   8=CD$C W# sKj9Sjx!%ED WC6_ C^ U 5` C^V*Vd6a 8!6b 8!Dh ? ?>h @ @hA(5c C^VC5d 8!6e 8!6f 8!6g 8!Dh ?@ ?@??j>h @ @@@hA( D&e DA[5h 81%C8 %C??(E 1! " D C4 'E D 4 +" C D D CA(C C WTTTTTTTTTTTTTTTTTTTTTTTTTTTTTED W T'D C D 8:!~V +8:"V  D"" D  4+_ +O C +98: " 3!6i C^U7=CXV5j C^ U 5k C^VVd 8:!Dh i8:">%5l C^VDV:D V3D V*D V!DVT#Dh C@ C@CCj>%TT5m 6 @[D# VVDUc 8:!C"@k@%VVDU D C8T "%5n 6 @[ @  !V%%D D 1!4#&C C W11111111111111111111111111111E D4! C3!D8T $E D4! 1!hD8T $ D 6o " 4! ?8T " C1!A (C3! Y8: "h@?Z( CyV6p @([F3! EG W 1C??(C Y8: "@?Z( CyV h @@([ C8 !@6q @(D C85! V:C1! Yc!@??@h@?Z( CyVc @ ???@6r @([??(C VCE D G G4$5s 81%F G G?TG?h C1!@ @(G F G G?T 8 ! G@h 1!@C1!@ @(8 ! C3! YH8:!l~V?[8: "8: "??Th@?T?[h @? @Z( CyV  ?@([E D C VC 1! " 1!" 1!A (7 1! " 1!A (D 1! " C1!@ (D 1! " C1!@ (G 1! " G F1!E1!C>(D C8 1! " 1!A &E D VC1%C1! W!C 8[ " D dTeD C>TDh C?h>T &7h8@h C8 !@6t @A(c D8 !@ C8 !@6u @(F D C8 !4'5v 8! ? D 4+8:#8hC8 !@6w 8[ !A h>(F1! EhhC# Ch>(7CV7(!!8 C1!A (C C WFC W 7) 8 "Uy7) 8 "Uo7) 8 "Ue7) 8 "U[7) 8 "UQ7) 8 "UG7) 8 "U=7) 8 "U37) 8 "U)7) 8 "U7) 8 "U7) 8 "U 7) 8 "V1%c 1!@h8W@@(c 1!@h8W@@(1%CW<<<<<<c 1!@h8W@@(EFT1!h6x 8!@hAh @h8z@@(1%C E6y 8!G ?D?>D C'ChhC'48: &D ! " C@(4+8: &D! C@(4+8: &C()* D Ch>(D C6z !81 "@(C(Diy()*W''8!C @@I?(()*VC C VD D C@@2'c? + +8:"Vh@Tc@ C T +8: "" 6{ " D+^8: "6| 8! D D ?@@2# WYYYYYYYYYYYYYYYY$YCBE D @hAT>C WTCTE D@hATT h @hAC +8:' +8: " &E D81 "@()*Wggggggggggggggg!6g D8%" CA(G F8%" E DC>(C WTG F8%" E DC>( A()*+ ,4+n8: "h '5} 8%D C8T "@()*VC C C D C W"TP DVTG8#!V> 6~ " DE h D2   hD @@?h8T  CD @h@@( W  TpCViY58:! +L8: " +<8: " 4!8T   i@@Z( 8T  CyV) 6 "  4!? 8T h @h@@( [6 "  4!? 8T h @h@@()*D ! "XVd DA[@(C C W  C(CCVD(c DA[VC C D2! D! D8T $()* 4, %+8: " 4 +}  8:#@()*c 4!@ 8 !@ @ 8 !VdTe?@()*F E G G?T 8 ! G@h!@?@ @@ (EFiy(F! EG_()*O 8:!jpkn~V7 O^6 8!V<cO }U/\^G ?T?h?@ @ _ zUc 4+8: "8+ ! +{8:"Vd Y/iyV?[ 8: "  8: "??Th@?ZT  CyV6 @T  h@@T[ V C4!h>( ( 5 8! 4,V ? 8:#hC4!@@ @ h>(5 6 @[)*VW 5 8 f&5 8 f&5 8 f&C6 8 f')*V Ch8"T8!h ???@6 @(DC8 !hhh E??@ D??@ C??@h@?@8)8 !@6 @ "@k@(W#'JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJMMJJJJJJJJJJJJMMJJJJJJJJMMJJJJJJJJJJJJJJJJMMc(d()*7 CV!c?? ! G8X9! iD> D@ C@(c %)*7 CVG8X9!h F? D> @(()*W/7 CVG8X9!hh D> @(((WC W TC(5 81%W?[C(D&)*W=X C8:"X(E 4"Vd( 3"V F D4#2&(C 4" 3+8:"VD 2&(C W#'JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJNJJJJJJJJJJJJJJJJJJJJJJJT"ChzVT(C 3"VD 2&(C 2& 3& 8E&D&)*W5Pd(E 4"Vd( 2"V F D3#2&(C 4" 2+8:"VD 2&(CW#'iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiJiiiiiiiiiiJiiiiiiiiiiiiiiiiiiiiiiiD 2!8:&C 2"VD 2&(C 2&8! +&8:"X( 8E&)*8! +8:"V @(()* D C')* 1+8:')*WCE WTtCW#'JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJNJJJJJJJJJJJJJJJJJJJJJJJJJJJJJT"D VDVTC 4"V FD3'(c()*W C^(C WTCW#'JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJNJNJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJTMD VFC WT,D V!DVT C^VC4"VD2' (Tc()*,x]9`n& c(2!6 8!@(?()*YC8" CZT(6 CyVY C"ZT6 CyV? T[T[ V5 8!8 ?8T "h @hA(,D ! +8: " @ hA()*C Y8" G D C V~ C C D VKCC W"T(EGWTDVT VTT TT W66666666666666666666666666666EGW DDVTVT D CC W"TDVTDVT VTTTW11111111111111111111111111111DU DDVTqVTk DDVTb7) 8 "U 7) 8 "VTK7) 8 "VET=7) 8 "VFT/7) 8 "VGT 7) 8 "VGT7) 8 "VGTTZ(6 CyVYc" W#'JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJMJJJJJJJJJrJJJJJJJJJJJJJJJJ)T  V D VDVTC8 ! C@TTTCT V DVT C8 !?TTCT V  C8 !?TTCT V  C8 !?TTCT V  C8 !?TxTuCTm V  C8 !?T^T[ETSFTK V C8 ! D C DC>%T1T.ET&FT V C8 ! D C DC>&TTZ(6 CyV]h{Vc ^l%yV ?A[? ([[)*5 ^V5 ^V8&?(?()*5 6 @[)*5 6 @[5 ? +? +?6 l 81"6 l981"6 6 +  +n + +6 ? + + ,,+ + +R + + ,   "$&, '+^ ++! $ > "9 T\?(5 ( +8: "h@8[ %E C@()*ch@@6 8 " h@@?hD8T  @hA(E C@()*C D # @&7()*E D C C W$HHAD +h? i D" CA(G WT CF#"A(d A( A(c !AD +8:# E D+i8:# CA()*C WGZ 5 8!DC Vch C?@ 8:!?@@h@ 8%"?@! C@@ @@( C 2+v' G D E +8: " F   8%"  2  D+ W  C E D "Th " C@( C     2 8 D D8 # C@(E +98: " F   8%"  2  D DC8 # C@( C2$ E C@()*C Wg5 8!6 8! 7T? VcT?   !h@    D CDT h@" #h@" @(E +8: "F8%"2$C W  (C2%)*V C^Vc(D 2"in(5?[ i$ )* C"" Dj>()*C"n" Dj>( 8%E"X()*F E DCC W9S# !D  GF# F@h h D C>( GVT  F C@@ >(F C WT~C8 !i"8=CV(8:! 6 8%"8!h ? 8:! h>@T F8%G"?@8%">(  C8 !h"?@6 8[ !@!@ >(>()*C WIV:C8 !# V ch @6 @@?@h @6 @@!CCh>D@( 5 6 @[C#hh  > D   2+8:# D E#  FF   C@( F       2  E 8: "  Dji   C@( C2$F       2  E 8: "  Dji   C@( G E F +8:" 8%G!h !@ !@ !@?@C ! C W V C C D 8"VcT5 6 @[8 !6 8! 8:!D   +g8:#C  +?8:# h"Cj>hVdTc??@@ 8%"6 8[ !@!h>D@( 2+ V % h ?@6 8[ !@!@ ! D6 8[ !@!@ C@(!8 '(C W+ F@(D C F2! D + C@(7F(C W ""7C(7C CF +8%G 'FTC 2%WC8"V c(E2%7%?[)*ch@@6 8 " h@@?hD8T  @hA()*C W;ACiyV)YF8X "FhyV7%?[ZT6 CyV7%?[[ @(7%?[G D F2# D +x W  C E D "Th " C@(  C 2#8 D D8 # C@( F 2# D D C8 # C@( C 2# C ,E !D @()*C W# Dh@" C@( F2  D D C8 # C@(W2C8!6 ^Vc ^lA|Vc ^lZ~(CW#'eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeJeeQeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeDUd(D VDVTC2%c()*W,,,,,F,,,,,,,,,,,,E WT C8:"V F D@2&TCW#'JD VC WTxD VmC WTWD VHC WT6DVT.C8 "VC8:"Vc C?@6 @(T TT5?[!V c @6 @(W_______________ __C W#'JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJNJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJTD VFC WTDVT C8 "Vc C??@?@6 @(TTD VdC WTD V?C WTjDVTb C8:"Vc C?@6 @(THTDT@C;E WTFVT C8:"V c D@6 @(5?[)* @! +zWD VD CC V\DVTC !V(!V#!h @ D@8%"6 C8%"6 8%"@( !V!V! D@ @ C6 8%"@( Ts!V! D @ C6 8%"@( TVTRCD VDVTC ,E & 5?[E WT C8:"VF D@2$ TCWD WccccccccccccccccccE WTF V.DVT C8:"VC! DC?@ C6 8%"@( TE WTiFVTa C8:"V c @6 @(TJFUFE ! DD@ C6 8%"@(F V)D V DVTE ! D D@ C6 8%"@( T ! D C6 8%"@()*V5 D C6 8 f$5 8 f&)*d h$)*  hF8[ $ "h@hAh'?h#h?@6 8[ !@!@ "h>&)*c @ ?@i @@( ?i>(h6 @@?@6 8[ !@!h>("h@hAh>(c D8 !@6 @( D8!8:&)*h6 !@ ?@6 8[ !@!j>(T @6 @j>(c D8 !@6 @(?(?(c @8@h@hA@8@6 @( 8E"X( +8:"Vc?@!@6 8[ !@%c8@?@?@h8@?@!@6 @h?@6 8[ !@!@ h?@?@!h>&h@hA! 8! ! h>(c8@ ?@!h?@6 8[ !@!@  h>()*h!@6 8[ !@! h>()* 8:" ^V @DA[()*85! 85!^X()*V(  i 8 " C?Tc"i> ?Tc "i>()*V7(c?@?@ ?@6 @@()*WCD VE D C6 8!T  h  8 " Y( XU7 CV5?[ " h @C Z(6 CyV2c 8!8E"UTh?@?@6 @i>@"@( [5 6 @[)*C" 8')*8! C8G8:#8[ C8!8G"8G"8[ I7[ C8F8:# 8G" 8G!C8%"I?C8 +8:' )*  #8 ^V(5 8!8%"8! 8[ ! DX ! D VcT CC8X"6 8!  ! +Fh?  +rh?6 8!6 8!  +7  +6 8! h   D C 8 "XV cDA[8:! 6 i  D CcT5 6 @[5 8!6 8!8%"8!6 8!6 8! +Q8:'" 858: " 8:&" %+8:#++V!  ! "%'%iy +   (+ +!VV %+!V 7 ! %+5 8!6 8!CC 7T?C7TC +~8: "6 @CTC +a8: " @6 @8:! +;8: " +#+&+8:" +8: " +  /+l +U  %+  $+3c @h"@!THV)c @h"@i"@h @h"@!@Tc @8@h"@8@6 @ !4c !T*Uc !T!c?@?@!@6 8[ !@!!8h"A @ !.%9)*88: " @6 8L"8%#%)*  C6 ^V5 ^V5 ^V5 ^V5 ^V5 ^V5 ^V5 ^V5 ^V5 ^V5 ^V5 ^V5 ^V5 ^Vu5 ^Vk5 ^V`5 ^VU5 ^VJ5 ^V?5 ^V45 ^V)5 ^V5 ^V5 ^V5 6 @[gTTgTPgTLgTHgTDgT@gT<gT8gT4dT1fT.eT+g T'gT#gTgTgTgTg Tg T g Tg Tg D ??@( 8E"X()*W5 555555555555555 C8:"X(d(CE8! +8:&%)*Y5 8!6 8!8h ?@ ?#      D C  8 "XV c DA[h@" ^ V8 !T5 8!6 8!6 8!6 8!6 8!hk"@j"@hh ?@?@!@?@!h @"h?@i"@!h>h@"@hh"@?@!@6 @8 !i>h@"h>Z(8% CyV7([C6 @()*V.D V%DVT$h C@C@ ?@6 8[ !@!&T(h 6 @@ ?@6 8[ !@!&C()*C" Dj>(C()* @@()*c +8%G # 8:!8:! !8%G '  hi$ 5 8! n? 5 Tc +8: "!@6 @  8%" +i8:# Dh +W8: "!@ ?@8%" C8[ !@!h>( )*h !@ ?@6 8[ !@!h>()*5 8! ! E D C8 ^V c?@@ V5 T5 8[ !@! @(U?Tc?@?@@6 8[ !@! @ h?@@6 8[ !@!h> @()* E Dj>()* D +8:# Cjh$)*C Y(h8%G"?@?@6 8[ !@!DA@Z(6 CyV([)*c +8:')* C# D>()*+8:')*c !@ ?@ V5 T5 8[ !@%)*8 !VdTe 8!8!hhh ?@ ?@l@@?@ ?@@ ?@ ?@ ?@h?@h@ h>()*8 !VdTeh8 !@ ?@ ?@ ?@(?8[ %)*c ?@ ?@()*7 ^V( @ (7 D CA()*W A( D8%" CA()*(W&&&&&&&&&&&&&&&&&&CE D 8%"hA( hA(5 ? + + +~ +g +S +F ,+ + + ++\ + +y  ,^,{ +A  ++ ,,+ , @,^,,, + ,+z ,4+H ? +%    "$'*,+ % +F +68 I + &A&9 T7h?"@ ?A"h@hA( !8: "6 @()*W+(C 3+ 8&D C6 8! 2+8&C88 &)*c ?@ C?@ D1&D C W C? @(^ D " C@()*W#:(W077C8+ ! C 2+8: "?(WD D2" C C2"@(V(5 81%W 5 81%h#h@hA(5 8! D# ? C"i>h @hA()*C W7XdC8 ! &C h3$F C " 2+i F8[ $ Dh DhE2#@ Chh2#A !iF8[ $C F"2'C8 ! &)*C 3$D WC88 &C^? &?()*V!C D @ 2#h?@ ?@ i>($C F G ED8  @(CF()* "h'C()*VFDCC W #CPX~PPP 2  C8 !@ (D 8Y!8%"    2  C8 ' ED!2$ 2$ C    @2  E " 8 # h>(C    @2  E8 ! h>(C    @2  E "h4# h>(C +%8: "8:"    2  4+' C +8: "    8:!8%"2  +8: "@(5 8! 2,lDh # Chh4# h>(W 5 81%8:! +;8: "6 @(8:!8+ ! C +8: "6 @(CF(V^D CC W  ( 9 K2%2! D8Y!8%&2! C@(2! C81"8: "8%&2! C +8: "8%&2! D8%&()*C86 8 f$)*VD  2# C "@ (7()*c C^! D"@h?@@h @@()*c !@h?@@h @@()*,W 5 6 @[h+ # 8:!@(C 8+ ! h +# 8:!@(C^! D&)*W 5 6 @[8: "T8+ ! C +8: "Th 6 @@ ?@(V c C?@(7?(c8[ !C8 &!8[ !%)*VD 2"h?@ ?@ C"@ (7(C F G ED8  @(CF%CF()* ??h'C W **/>J^**w*C8 %D 8Y! 8 " C8 '7(C Eh 8 # &E8 ! C&C !E ??h# &C 81"8: " 8 " +|'C +l8: " 8: "+V8 " +18: "@(5 8! ,Dh " Chh# h>()* ! h>( 8!+8G '? &)*7h @ !???@hh?@@?@A(7h !???@hh?@@?@A(Y C8"Z(6 CyV8%[C 8! 8#I()*C8Ic DC@ # I()*dh @ 'VACC W  T*DVT"VcT5 6 @[C8 !C8 &$)*CCh8[ !cI8! !D" E D C  + 8[ $)*VD h@C8# 2$ A()*V?C D WD C@@2$ C^D 81"@8#2$  $ )*,W 5! 81%h8h$8+ ! ,Ch8h$ )*V"C D 2" !@ h?@ ?@ i>(i#&C F G ED8  @(CF()* !"h#8 &)*VWD CC W EPU}PPP# 2" C8 !8 "@ (D 8Y! 4! C8 # h4#2" 8 "@ (ED ! 2& 2&C E  !" 8 #  h4#2" 3! h>@ (C E8 !8 "  h4#2" 3! h>@ (C E  !"h#  i4#2" 3!@ 8 " h>(C 81"8: "  i4#2" 4!@  +' C +8: " 4! +8: "@ h4#2" 8 "@ (D6" 8! 432,Th "Chh#8 " h>(I7(Y)8"? D "h @h?@@h C@@Z(6 CyV8!6# 8%"81%[18 &)*Y8 8" DVhh ?@@ C?@8#TVT5$ 6 @[Z(6 CyV5% 6 @[[)* 1!8:')*h D88 "@h?@@h C@@@ ()* , &iq C" 8:' YC8" WC W#'JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJNJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJTD VC WTC W#'JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJNJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJT-DVT%DVTC C@TTTT TT5?[Z(6 CyV8!6& 8%"81%[)*c8[ !cI8!h  C!Dh 8[ !@ ?@(F C " ! D >()* +8: "!&V.C D V"C D2!8h D@ C@6' !ACh>(D2%3%VC DVD2%D2! E Ch>(3%V.C D V"D2!8hE@C?@ CD@6( !A@ (D2%()* ,o %^ W]k^hyV2d _c }U\^ ^8E"V2! zUc C ^ ^^A@ Ie _(^? ^A[c(F(E(D(C( +8: "8+ ! +8: "8+ ! +8: "8+ ! +8: "8+ ! 88+ "Oh ^h?   , %c }U'\^ W!T 5) 6 @[cT zUcC8:% )* 8%" W5?[c C 3"h@@h@()*VC WESXn|DC 89" C W  5* T7) C8"V5+ T5?[ D 2" @(D D C8X#2&5?[D D C8X #2" 1"@(D D C8X!#2&D 2"6, @(D 2&(,@dYEF"?D!@?Z(6 CyVc([C8 !h E??@ D??@ C??@h@?(Y7X6- @8X"C8 !Z(6 CyV5. 8%"6/ 8%"81%[)*V7 8! CA?()*V ? C@?(??(D WC C@I(c(50 ? ,r,c? + + + + +e +; + + +& +   ,168 I +(8? + + ,+ +1 + +61 8!hi8? + +s +L + + + +# + + + (+Q )+ + ,) #> ,92 TD" C@(D" C@(D" C@()*W#&:Nau*8F_j C8 "V?[((E D 2!8: " C 2"A(8! 8E"V?[(F 2" E 2" DC>(D 2" C 2+8: "@(C W#'))))))))))))))))))))))))))))))))))))))))J)))))))))))))))))))))))))))))))CD V7C WTDVT C8 "V?(TTCD VEC WTvD V DVTi C8 "V C2"@(TRTNTJD VCC WT)DVT! C8 "Vc?@ C? @@(TD 2!8: " @(D G VC 2"? F 2+8: " E D2+8: "C> C 2"@(D 2!8: " C@(E 2" D C 2"A (E 2" D C 2"A (E 2" D 2" C 2"A (D 2" C 2"@ (D 2" C 2"@ (G 2" F E 2"D2"C>(D 2" C@(G F 2!8: " E 2"D2"C>(D C 2"@(D 2" C@(D(D(Dh&V7=CV 8:!C!Vc(d()*+hhW)/:J "39[ac(D h4"!E@89%Ei2&Eh2"F2&C2+8: "D2&C VokWgggCD VDVTUC2& TKD VD VDVT9CCTT)T%D VD VDVTCCTTDh4&DCh2"D +3#F +3' Dh4&C2"E2&Ch2"E2&Ch2"D2"E2&Ch2"D2&Ch2"Dh2&Dh2"Eh2"Gh2&Dh2&FEDh2"h2"h4" @!G@89%C2&D2&h2"2&!&)* 1+8: %4!8: %!!8CVi"(d(D&D&D&)*W ct~td C 'c(C WCD VC WTCW#'JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJNJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJTQDVTID DV8:! 8:!yV E #2& T&T"D DV8:! 8:!yV  E #2& 2"D 2!8: &E862&E D W******************VF "2"! C'F "2"ChyU!h{V 2&(C 2+8: "D 2&D 2!8: &D 3"C 2"D 2+_8: "F 2+N8: &C 2"E 2&C 2"D 2"E 2&C 2"D 2&C862"D862&D 2"E 2"G862&D 2&F E@ D@ 2!8: &C 2&C!h{VD 2&()*G V?C D8:!F8:!C {VE {V 1"1&C {UE {VcT53 6 @[1&(D! C@(D! C@(D! C@(W,/)#3o{Y C8"Z(6 CyV([(C WCD VC WTCW#'JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJNJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJTODVTGD DV8:! 8:!yV E #2%T%T!D DV8:! 8:!yV  E #2%E D28: " 2!A(E2! D CA(C E WTVC?2! D8#F2%W )E WT C W#'JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJNJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJTCTDQD VHDVTV9D C2!F2! Y"k>!Z( CyVh@64 @h>% [T]TYTUF E D ! V2! 8#2%2%2! 2! i>(F D ! 2!E2! i>%2%F2! E2! D >%D2! C2+M8: "@(D28: " C@(D C2! D2+"8: " F2+8: " G VC2!? EC>@(D28: " C@(D E2! D C@ C2!A (E2! D C2!A (E2! D2! C2!A (C WD2! 2!@ (D C! 2! D2!@ (2%D2! C2!@ (G2! F E2! D2!C>(D2! C@(G F28: " E2! D2!C>(D C2!@(C!D2%7(F E D W""""""""""""""""""V C 8 "V( C>()*Y86" Cn IZ(6 CyV Y8" C IZ(6 CyVc([[)*c? 8# 86'Y 8"CZ(6 CyVc([7=CU7 CXlSh8" + + +y ,86 "gSh8"+(  ,H % )* h>()* +8:$D%D%D%W&&$-<Dbo ! C2!D28: &E2%F2!E2%C2+8: "D2%D28: &D 3!C2!D2+8: "F2+8: &C!D28: &D C C DUUE WT9DVT1C 2!! Y8" Cn IZ(6 CyV ? 8' [2!!h{VE2%(C2!E2%C2!D2!E2%C2!D2%D2!E2!G2%D2%F E@ D@28: &C2%c(G V<C D8:! F8:!C {VE {V1!1%C {UE {VcT55 6 @[1%()* i>()* ? 8'D! C@(D! C@(D! C@(W'3DV BUcs(E D28: " C2!A(E2! D CA(F2! E2! D C>(D2! C2+8: "@(C D28: "hhhhhhhh W#'yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyJyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyV,D VC C C Wcccccccccccccccc-cDVTDCTC WTDVTDCTDVTh @A(TVC C Wyyyyyyyyyyyyyyyy8y D VDVTtCDC  TxT]C WT& D VDVT3CD C  T7T D VDVTh C@A( @( h@ 8%" A( h @ 8%"A(D C2! D2+8: " F2+8: " G VC2!? EC>@(D C VU28: " Y=8" C 88: " 7 +f8:  D8 "  +D8: Z(6 CyV @([Y8" DZ(6 CyV([D D C C U5E WTDVT2!h@ 8#2%E W@! #2!@2!A (2!@8#2%2%! @8#2%2%E2! D C2!A (E2! D2! C2!A (D2! C2!@ (D2! C2!@ (G2! F E2! D2!C>(D2! C@(G F28: " E2! D2!C>(D C2!@(D2! C@(Y 8"Z(6 CyV d? 8'[Y 8"CZ(6 CyVc([gh8" + + ,2^ !gh8" , % 56 ? ,+ + + +? ,R_+_ @ 97 58 ]69 ] @9: T)*8%:! Y2]81" ^VdTg h 8L#l h 8L#^V?[ZT CyV5; 81! YDV!7 CV 5< 6= 8 f#8%B!8I8%B!Tc8%C"8I8}! 8" !ZT 8%F![ 8%F!(7C V7C ^V81%(7C V81%(7C V15> 6? h8- # 8-!C6@ 8  8!hzV 81!?[((5A ? + + +6B ? +  >9C T c G((!@ G''!@ G&&!@ G%%!@ G$$!@ G##!@ G""!@ G!!!@ G  !@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G !@ G  !@ G  !@ G  !@ G  !@ G !@ G!@ G!@ G!@ G!@ F!@ E!@ D!@ C!@ ?(c GAC!@ G@B!@ G?A!@ G>@!@ G=?!@ G<>!@ G;=!@ G:<!@ G9;!@ G8:!@ G79!@ G68!@ G57!@ G46!@ G35!@ G24!@ G13!@ G02!@ G/1!@ G.0!@ G-/!@ G,.!@ G+-!@ G*,!@ G)+!@ G(*!@ G')!@ G&(!@ G%'!@ G$&!@ G#%!@ G"$!@ G!#!@ G "!@ G!!@ G !@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G !@ G !@ G  !@ G  !@ E !@ G  !@ G !@ G!@ G!@ G!@ G!@ F!@ E!@ D!@ C!@ ?(c G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G !@ G  !@ G  !@ G  !@ G  !@ G !@ G!@ G!@ G!@ G!@ F!@ E!@ D!@ C!@ ?(c G4;!@ G3:!@ G29!@ G18!@ G07!@ G/6!@ G.5!@ G-4!@ G,3!@ G+2!@ G*1!@ G#0!@ G)/!@ G(.!@ G'-!@ G&,!@ G%+!@ G%*!@ G$)!@ G"(!@ G!'!@ G &!@ G%!@ G$!@ G#!@ G"!@ G!!@ G !@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G!@ G !@ G !@h!@ E !@ G  !@ G  !@ G  !@ G !@ G!@ G!@ G!@ G!@ F!@ E!@ D!@ C!@ ?(5D ?6E A(5F ?6G A(5H ?6I A(5J ?6K A(5L ?6M A(5N ?6O A(5P ?6Q A(5R ?6S A(5T ?6U A(5V ?6W A(5X ?6Y A(5Z ?6[ A(5\ ?6] A(5^ ?6_ A(5` ?6a A(5b ?6c A(5d ?6e A(5f ?6g A(5h ?6i A(5j ?6k A(5l ?6m A(5n ?6o A(5p ?6q A(76r 8" ?6s A(76t 8" ?6u A(5v ?6w A(5x ?6y A(5z ?6{ A(5| ?6} A(5~ ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(c(5 +?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(5 ?6 A(+ + + + + + + + +{ +l +] +N +? +0 + + + + + + + + + + + +u +f +W +H +9 +* + + + + + + + + + + + +v +g +X +I +: ++ + + + + + + + + + + + +w +h +Y +C +- + + + + + + + + + + + +y +j +[ +L += +. + + + + + +  "$&(*,.0247;=?ADGIKOSUWY[]_acegkmoruwy{}+;  $&+/157?ACEJLRX[n+   !#%(*,.03579=?ACFHJLNPSUWY]_adfkmprtwy{}+C     #%*,.249=?ADFNPRTY[afhkw+(b >[9 gl? @9 TS)*V C#  D2'()*ViC W#????????????????????????????C??L????X??????????????????????????T!D2$ D Cn2$  Cn?@(V  C?@(c! ?@ ?@(VJCW#?D??????????????????????????D?????????????D????????????????????D2%(VLCW#GGGGGGGGGGGGGGGGGGGGGGGGGGGG?GG?GGGGDGGGGGGGGGGGGGGGGGGGGGGGGGGD2%d(c()*(VaC W#?????????C?????????????????????F????O??????????????????????????T(D C n2&D C n?@( ?@()* 2"h@8?@(()*W C^(C WTCW#'JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJNJNJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJTDD V=C WT#D VDVT C^VD2&(Tc(WUUU$UUUUUUUUUPU8!8G!in?(CE WToC W#'JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJNJJJJJJJJJJJJJJJJJJJJJJJJJJJJJTD FD"VC?(?(F2%D2%C W#'JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJNJJJJXJJJJJiJJJJJJJJJJJJJJJJJJJJJJJTFD8:!?(CD?(D?(C  D8:!?(D8:!?(5 6 @[C2%c()*E V'C C D?T?TD?T?8FCCh> (DD! C_(DD! C_()*ViC E C W=D#2#h@6 @(D#2#h@6 @ C???@(D#2#h@6 @ C???@(  3$)*V/C EV D2 ?@ D$ D2$   3$)*V3C EV D2$  D2 6 @?@h@ D$ "  $D ! CA()*VDCD W5 6 @[c! ED> 8"D2" @((?(C(DWc(d(?()*C }VIchhW(i*:*mA B C YC8"  o?@Z(6 CyVYY D8" ?@Z( 6 CyV:Y E8" ? @Z( 6 CyV86 8 h#8!6 8%"81% [[[C?@(DC 8:! !V' ! n@@ n 2 h@  3$  ?@ n 2 h@  3$ ! 'D?@n 2 h@  3  C?@( c !8!8G!hhi  E D> 8" 8:!@ @ +8: " 3$ i"  F   D #2 h@E2$ DC 8:! ++8:"Vc7 @8!8G! + 8: "  ,h " "n   #2 8:! @ @  +8: " 3$+]8: "  2 ,Q  'C W#'Jg{KE dD VDVT C2$ TD VDVT! C2$ TqD VDVTd!l @ C2$ TMD VD VDVT;C C V C W#???????????????????????????????????????????????????Cl??????????TE D! DC?@2  C?@  2$ 2  C?@  2$ !  D2  C?@  2$TT}D VD VDVTkC C V C W#???????????????????????????????????????????????????C^??????????TE 2  C?@  2$ D! DC?@2  C?@  2$ !  D2  C?@  2$TTD VDVTVdC W#???????????????????????????????????????????????????CN??????????T D C?@T  D C?@TTl@  C 2$T$D ViD V`C WTC W TC W TDVTC !V ?@ C 2$TTTD VkD VbC WTC W TC W ToDVTgC m!V m?@ C 2$THTDT@D V"D VDVT.CCCTCTTD V"D VDVTCCCTTTD VPD VGC WTDVTC8 !? hC@ @ "@  3$TTD V1DVTC !U l @ ???@h@ C 2$T_T[D C . 8:!?@  3$ h 8:!@@  3$  6 @(  6 @h 8:!@@  3$D "@ 3$ D! C D!88 !hC^hE^G VCD!cD +8: "F +8: "c C!h O^ Oh {U2\  @ ^2 ! C _D! zUcc E^ Eh {U\^^ _ zUcc C^ Ch {U\^^ _ zUc @@C2$D!C! D CVDU "  o" C 2$ "  o"   4$ED D CC 8:! ! D C S"n  #2 !Cn C@@@ID@"n 2 "TYV DUCT5 6 @[ i" #2 h@!C C@ @@ID@ 2 C8:!I(!h ! ;Di"ED #2 h@?@C@l@  C 2  ?@( EDC4 $     D 2 C2$ c !h ! '!?@C2 ?@  D 2 l @ ?@ ?@( Fh !h ! gTd eTf qFj"! ?@ ?@6 @6 @6 @?@h@6 @GC #2 l @?@?@?@6 @h@h@E2 h@  D 2$Y&C C8" o?@D2 Z(6 CyV5 81% [FEDC 8:!T 8:! @@l@TTWEEEEEEEEEEEEEEEEEEC W T%C W T@ C?!@TTT @@l@ D C!V!n@@ @ 3$?@ @ 3$! D?@@3  C?@(DC +` D V1    2 hi" &    2 ih" & !V    2$W dTD8:!?T F8:!?T C?" "   2$D2$ h @ A 2$ )* 8:! 3$)*V*D C V 2 h@ 4$  4$ ()*8:!3$ )*V D2 o?@ C 4$ ()*7?^V!  D 4  C?@Tw " V    4  C?@TU" V    4  C?@T2!  D   4 ! DC@   4  C?@ 4$ 8!cIcI 5 i h! @()*8!cIcII ch 8!c! ?@! ?@(( YT \8!"dUcZT8 CyVcT[()*VD n2# C8'7()*C8:! ,GjGlp # FiGGojp#Cl#A ?@D  ? @E?@i@(E?@()*cI 8zC}V6 @C???@((8 |V7  |()*W#'sssssssJNRVZ^bfjnrvz~ss s+.CYo !)K_g (g (g (g(g(g(g(g(g(g(g(g(5 (5 (5 (5 (5 (5 (5 (5 (5 (g(g(5 (5 (g(g(5 (C? (C?(C 8:!@(C?(C?(C?(C?(5 (C D C@(C?(C?(C? (CW 5 (5 (5 (5 (5 (5 (e(C 5 (f(5 (C 5 (g(5 (C 5 (5 (5 (C 5! (5" (5# (6$ C'6% C'CW!DW5& (5' (DW5( (5) (DW5* (5+ (6, C'6- C'6. C'6/ C'60 C'61 C'62 C'63 C'64 C'65 C'66 C'67 C'DW 58 (59 (5: (5; (5< (5= (D  8%!6> 8%"@(D  8%!6? 8%"@(5@ 81%)*W 5A T 5B T5C T 8:! 8%"@()*W''''''''''''''''''DUC! D yVC?(c(Y C8:"Z(6 CyV5D 8%!8%"6E 8%"81%[)*VSC W#??????????????????????????????????????????????????????????????CT D C "& &)*F V  ?"@(VC VTD VC W#??????????????????????????????????????????????????????????????CTRC G V@G V(d? ? Gi   ?GF  D ?"@h@ ?"@( TT ?"@()*F F V@T!V@TV @T @ D C " " F $ )*G G W((C W T6T5C yV Cc(T#C WTC yV?(TT(5F 81%)*G G V(V(5G 81%)* G G GGEDh> (VGCW#BBBBBBBBBBBBBBBBBBBBBBBBBBBBB?BBB?BBBBBBB?B?BBBBBBBBBBBBBBBBBBB(8?@()*VTC W#????????????????????????????C??????????????????????????????????T C yV( ?@(VaC W#?????????C??????????????????J???????U?????????????U????????????Tl @( h C?$ @( hh$VPC W#????????????????????????????C?????????????????????C????????????T C@(c! ?@ @()*E DC8#A(C(c? +888A + ,+h,+ + ,,i,+, ,$,<, + + +t +$ +X +h? + +h8!6H ?h? +\ + +    !#%'*,.1,HW +b + + *,.+a *-+3 @*9I T)*VaC W#MMMMMMMMMMMMMMMMMMMMMMMMMMMM?MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMD2 C6J 8 f$D2 6K 8 f$ ()*6L 8 f$6M 8 f')* +8+ &6N 8 f')*W#?GOW_gow)3=GQ[er| !+5?ISeo|5O 8 f&5P 8 f&5Q 8 f&5R 8 f&5S 8 f&5T 8 f&5U 8 f&5V 8 f&5W 8 f&5X 8 f&5Y 8 f&5Z 8 f&5[ 8 f&5\ 8 f&5] 8 f&5^ 8 f&5_ 8 f&5` 8 f&5a 8 f&5b 8 f&5c 8 f&5d 8 f&5e 8 f&5f 8 f&5g 8 f&5h 8 f&5i 8 f&5j 8 f&C6k 8 f'C6l 8 f'C6m 8 f'C6n 8 f'C6o 8 f'C6p 8 f'C6q 8 f'D C6r 8 f$C6s 8 f'C6t 8 f'D C6u 8 f$5v 8 f"C +R8: "D6w 8 f'C6x 8 f'C86y 8 f$C86z 8 f$C8 6{ 8 f$D C6| 8 f$C6} 8 f'C6~ 8 f'C6 8 f'C6 8 f'C6 8 f'C6 8 f'C6 8 f'C6 8 f'C6 8 f'C6 8 f'+ D C 6 8 f$ C6 8 f'D C6 8 f$CW&.5 8 f&5 8 f&5 8 f&5 8 f&5 8 f&5 8 f&C6 8 f'C6 8 f'C6 8 f'C EDF ECF ECC6 8 f$+ ,t+ @9 g$]cijkllllll l l l l lllllllllllllllllll l!l"l#l$l%l&l'l(l)l*l+l,l-l.l/l0l1l2l3l4l5l6l7l8l9l:l;l<l=l>l?l@lAlBlClDlElFlGlHlIlJlKlLlMlNlOlPlQlRlSlTlUlVlWlXlYlZl[l\l]l^l_l`lalblcldlelflglhliljlklllmlnlolplqlrlsltlulvlwlxlylzl{l|l}l~lllllllllllllllllll    "$&(*,.02468:<>@BDFHJLNPRTVXZ\^`bdfhjlnprtvxz|~   ">9 T V C W#?D VRC W#?????????????????????????????C????????? ?y??????????????????zTqC ]D VVC W#????????????????????????????????????C??????????????????????????TD C?@2% 8 n!T 7 !!D2%C  8 n!T 7 !!D2%C  e q8 2n!T 7 4!!D2%D C V\C W#??????????????????????????????????????????????C????????????????T7 8!!C!D2%7 6!!2%D C V]C W#????????????????????????C?????????????????????????????????????TD VC W#???????????????????????????????????????????????????C_??????????T!V7 !!C!D2% T!V7 !!C!D2% TTD VC C W#???????????????????????????????????????????????????C^??????????T=!V !!C!D2% T"!V8! !!C!D2% TWPpC W 6TzC !V 8 hn!T7 l!!TTST 7 l!C!TTHC  8 hn!T 7 l!!T(DUC 7 <!T 7 =!!T 7 6!!2%CF VT+D VC W#??????????????????????????????????????C????????????????????TD VZC W#??????????????????????????????????????????????C????????????????TD@ @ @h@2% D@ @h@2%TlThTdD V]C W#??????????????????????????????????????????????C????????????????T7 7!C!C!D2% !D2%()*c!! ChC8%/ Ch!()*c!!!C]Ch hCaC8:!Ch! A()*c!7z 8%."8%4!h 8%1"8%4!! ChC8%/ 7 CV8%4!C8%2"8%4!o @T5 D Ch82 C8$8: "h8X7!C8:!C > h!c85*!8%4! 8%2"8%3"8%1& W#?EKQW]ciou{#.9D^ "-8-8Clw7 %7 )%7 O%7 P%7 Q%7 R%7 S%7 X%7 Z%7 [%7 \%7 m%7 n%7 o%7 p%7 q%7 r%7 s%7 t%7 u%7 v%7 w%7 x%7 %7 %7 %7 %7 %C%C  8 n%7 !%C  8 n%7 !%7 !C%7 !C%7 !C%C  8 !n%7 !%D C 8 %n!%7 $!!%7 (!C%7 *!C%7 +!D!C%C8 ,!8:!!D!C !8: &C  e q8 .n%7 0!%7 5!C %7 9!C %C WEa{{C W 0TgC !V  8 cn%7 g!%TB7 g!C%C  8 cn%7 g!%DUC 7 :%7 ;!%7 5!%D C 7 :%7 ;!%8 ?n!%7 >!!%C 7 :%7 B!%C  8 Cn%7 G!%C  8 In%7 M!%7 H!C%7 N!C%7 T!C%7 U!C%7 V!C%D C8 W!g Ov On!C !8+ " !8+ &7 Y!C%D C 8 ]n! %7 b!! %C %7 !C%7 !C%7 !C!c%C %W $7 %7 %7 %7 %7 %7 %W $7 y%7 z%7 {%7 }%7 |%7 ~%cI5 l^IcIcI(C IC @I(?!c%?!c%?!c%?!c%CC @@I(C&)*CO ~V!C^ W e Cox%C C@@? C_c%CO ~V!C^ W 5 81%C8: "C? C_(Cj DCox C_g x C_g x C_g x C_(CO T\jp ~U5 ^ COhhC8+ I(Y !!Z( CyV5 81%[g xl xl x $Y !!Z( CyVc([8 |V7  |(W!!!C W T C(C(C(?[chh $)*CC] ~VC] jp]  hhC8L I CS CS CS CSI(g]?h? + +6 ? +m +[ +@++ + :? +  + +j +. +!h? +  +  +  +  +h? + ++i+7    "%+ N   !, @!+ !+Y  "+- A 9 TP)*D n(Ch +8:#C8:!lp 8%E!oo()* "8%B%)* " 81&)*VC D C^V o8%C"(D o2&5?[)* ,CC8:!lp 8%E!o &C8:%8%E! 8%C"8%A!8z] 81"8z ^V?[lp o8%C"cId }U$\g81"8%A!C @@I zUc(C8%."D8%1&C8:! +8: "C8:! 8%1"7z 8%."cI()*8%4!CC o@@II(8%4!IcI(c?h? + + +6 ? +&++ + + +   >  9 Tzc! !8%"h!8%"Ic]8+ !IcIdI(VcTc!h!8%"I(g &7O6 ^V5 ^V5 ^V5 6 @[g;Tg: Y 6 ]"Z(6 CyVc([] ~Vc(Y8L # 2! o8L#@Z(6 CyVc ]o 8L#@([)* ,c %c Y>5 8z8-"8%9! YT \ 8%=!@ dUcZT6 CyVcT[8%F!ZT6 CyVcT[8:%)*CV] yVc(5 6 @[()*V)D C ^h yV  @2&hzV 8:" @I(5?[,Ch &](C +8: "cIcI()* !8: &)*7z' 8%" YC81 " 8-!V 8-8-"TZT6 CyVT[C 8:"XV5Y^C@IC @IZ(6 CyVD6 8%" 8%"8%%[(7z' 8-"V 7z' 8-&] 5 jh 8L#^V]j 8L#6 8%&( 8:"X(C +8:"I(C 8%"I(c?h?h? + + + + +++h? + +% + + + +j  +4   > 9 T](!C_ (W;C W C(C](C(D 8:! C^h? 2+8: "(C +8: "8+ %)*W"C6 8 f'C6 8 f'C6 8 f'C6 8 f')*!V C 86#I()*76? D +86"C C@(CC C}V5 81!DCC@I(I(C(C Wc(C 8:"XV!V 8!?@[()*C W( C@(h +8:# + 8: &)* !h]_(!h]^(%Y}c!6 D!I5 C!Ic T\g 8L # o 8L#!] {UcY 5 C!ZT6 CyV5 T[ 8 !Y 5 D!ZT6 CyVcT[hE!Z(8  CyU5 CyU 5 CyU[5 81%8%F% 8:& 8:&c(Yc] + + +AZ(6 CyV7O8%:! 8 !+ 8 ! 8 !A([D! C_(CCh]O }V]c]C +8: "cI(C(C 8%2&D! C_(cCC^C +8: "cI(C W(C! D'C! D'C! D'C! D')* +8: &)* Sg x  Sg x  Sg x  S(Y 7)!8:"ZT6 CyV 5 81!T[ !h ??@h@C @@I(7: +8+ "7C]27C8%9! YT \8%=!!dUcZ(6 CyV8%F%8%F![7C]j5 6 h8- # YW8C6 8#]hzV 7C?@[8%9! YT \8%=!!dUcZT6 CyV 8%F!81!T8%F![Z( 81![7: 8+ &c!h O }U\ ^6 8# zUc5 8"5 8"c O }U\ ^6 8# zUc5 8"5 8"c O }U\ ^6 8# zUc5 8&c! 8%.&c!l8!h O }U\^ 8 "g 8" zUc8%)* _(5 CC^CD +86"(c ^l%zV!c(Y C"Z(6 CyV77 CV&Y 8 !ZT6 CyV?@[[ " 8 "(["c(!C @@I(&Y C"Z(6 CyV 8!?@[[CD 86&CC CD @ I()*CC CD 86# @ I()*D 86&5 ?86h@ + + + ?h? +  + +u +_ ?  +N   + + + + +| + + +  + ,+<+$+ + + ++++  ++S+I++ + + &   '""$ *$'>&9 T )*W+>Sa5 8 f&C86 8 f$C86 8 f$D8  C86 8 f$C E8D86 8 f$ C86 8 f$C86 8 f$)*7CVT7 CV6 @T 5 8%"6 @h 8:#C8C8%"8I7CC8%"8I7CC8%"8I7 CU d $ 7 CU|5 6 h8- #6 6 h8- # Y[ c   8%(!6 8%."8 !5 8%."8%6!  ! "XVc@[7!CV 81!81!T   #Z( 81!81![8-!6 8%"8z$ 8%" ]V?@[c Y  #5  8-"XVb@8!hzVc@[7z$ 8-"XVB@7DC6 8%" %7zh@8C8:!8%"h @8%"j8 XVc@[818: "Z( 818: "[7O6 ^V 5 ^V(g. 8L"V(5 8%&)*h6 8%*# 8%:! 81"8%F!8%6!81!81%)*7DC6 8%"8z6 8%"6 8@!8%"h @8C8:!8%"h@8%"h8$C("]CnI()*8%(! Y5 8%."5 8%."c8 !8!c? + +  #8: "7 6  8#5 8%."ch8 !^"5 8%."ch!6 @@h8 !6 @@h8 !6 @@6  8%."c ^ "5  8%."8 !5  8%."8%6!ZT 8%6!81![7 CV5 8-!8%"%(81!l6 8%*# Y)8 !8 !5 8 "!5 8 "8 !8%6!Z( 8%6!81![)*ch ] }U,\^6 8#l |V 5 8%."c zUc()*c ] TB\^ ^ ^^6 8 Cl|V g 8%-"cI {Uc(8%4!o()*81!l6 8%*# YVKY67C]5 T 7DC6 8%" 8zC81 "8%:! 81"8%F!ZT6 CyU 5 CyU[c8 !7C]h{V7C!8%."g 8%-"5 8 "8%4!h8 !8!7C8 8: " V/7C8 !7zC8 !Y h8 "ZT6 CyV D?@[[8%.! +  #8: " Vc8 !7  8%0"c 8%0"c 8%0"c 8%0"5  8 " V 7%C "5  8 " "5  8 "8 !5  8 "c8 ! 8%2"5  8 "8 !5  8 "c! 8%2"5  8 "7 CV!5  8 "8 !8%6!Z( 8%6!81![8-!V h]8-&(8%."c8%0&)* +8: &C8%1"D8%.&C8:! 8%1"C +8: "cI()*W DC$ DC$ 5 C8%"6 8%"8%" Y Z(8  CyV D @@[[)*8%:! Y     +8: "8%F!Z( 8%F![)*8%:! Y       8%F!Z(8  CyV8%F!D@@[8%F![)* #D8%C"E81"F 8 "7 CVGh{VG8%C"G81"C h!@@I !7 CV G8 8: & (8%D CC ^V  8$ 8$)*YG+8: "ZT8 CyV F E DA@[[Y(CC8:" 8!8! CA8!8 #ZT6 CyVcT[C C@@I()*GU7 CU F8:"VF8: "F8: " @(()*Y 8zC81 "ZT6 CyV?@[[ 8%:! Y7z]81"8z ^V+8%A! 8%C"8%B!8%F!F8: "  @@TD7z ^V58%A! 8%C"8%B!8%F!!c C+B8:#  @@T?@[Z(6 CyV 8%F!?@[8%F![C Wc(C CG"I(C Wc(C CF"I(C Wc(C CE&)* ^(7$CXV=7C]hyV 7C]hyVDVd8 IC E8%"IC F8%"IC G8%"I(5 ?h?h?h? + + ?8! C? +v +Z +=  +kh8!h? + +h? +. + + +S+4 + +  +3h? + ++E  +` + + +  "$&(+  + ">"9 T)*W C6 8 f'C86 8 f$)*8%)! Yn7z8%."8%4!h8%1""8: "8:!C8C8%"C8C8%"C8C8%"8 C>8%4!  8%2" 8%3" 8%1"8%6!Z( 8%6!81![)*Y 8zC81 "ZT6 CyV?@[[ 8%:! Y7z]81"8z ^V.8%A! 8%C"8%B!   8 #  #8%F!c @TH7z ^V98%A! 8%C"8%B! C  8 "8: "!C  "8: "8%F!CT?@[Z(6 CyV 8%F!?@[8%F![7$CXV)DVd8 IEC8%"IFC8%"IGC8%"I()*D 8%C"8%4! J7 C ME 81#Gh{VG 8%C"8%4! MG 81'(5 ? +hh?h?h? +u + + +  A 9 T)*VrD C E VRCC D8! 8!?88!A8#n@2$         2$ ( )*W-;KC8 D8!6 8 f$D8! C86 8 f$C86 8 f$D C86 8 f$C6 8 f'Y 8zC81 "Z(6 CyV?@[[)*+8: " 81!6 8%" 8- !8L! Y 8#    Z(81![ C8:"X(6 8%"8%"8! 8!@(D()*81" +8: " +8: "8%)! Y7z8%."8%4!h8%1"8%4!  8hh   8%4!8 CVChzV C8:! 8%2"8%4!h8 ! +G8:" o }VTcCC8X6!@@C8:!  o >  8%2" 8%3" 8%1" 8%6!Z( 8%6![Dn C@()*E VD?()* +8:# 8! 82 # 8I " 8 "C  +8: "8%"I( )* 8%:! Y|8 #F  8: "CG8%"IGVdID8%C"E81#7 CVGh{VG8%C"8%B!   #8: "8%F!EZ( 8%F![81!8- !8L!6 8-"VZ8%:! YI7z]81"8z ^V?@[8%A! 8%C"8%B! C^V C @@[8%F!?ZT 8%F![ A()*]C n ID6 8%" 8%" JG8" MC @I()*C WeTC Y$8:" 8:"V?T  @@[ZT36 CyV(8!l. 8L"V6 8%"8%"8!?TT[T]C Y"8:" 8:"V  @@[?ZT36 CyV(8!l. 8L"V6 8%"8%"8!?TT[TCDn @@I(5 ?h?h?h?h? + ++b + ,)+    +x  + +  A9 T)*7% CyVE 8 "D 8%&7( CyV D 8(&7C CyV8 !5 8 f&7X< CyV8 !D 8X=&74 CyV8 !D 84&7 CyV8 !E D6 8 f$7 CyVD 8 "E 8&7 CyVD 8 "E 8 &7C CyVD 8 "E 8C &7 CyVD 8 "E 8&7n CyV8 !D 8n&7 CyVD 8 "E 8 &7  CyVD 8 "E 8 &7  CyVD 8 "E 8 &72 CyVD 8 "E 82 &7  CyV8 !D 8 &7  CyV8 !D 8 &7  CyV8 !D 8 &7  CyV8 !D 8 &5 CyV8 !D6 8 f'7 CyV8 !D6 8 f'5 8 f"[)*+" 6 8 f$+ ?9 Td8I8!hzVe8%L%()*8Ic!81!8- !8L! #8X2!8C !h!8CVcYM  8 88) # 7z8) 8C  ""c8!8C !5  8%"?89!Z( 8C !5 8%"?89![5 8%" 8%)! Y8 "8 8- # 8I !8 8+#87 8 8*#82 ! 8 88)# 7z8)8C  """""""""c8!8%6!8C !5  8%"?89!Z( 8%6!81!8C !5  8%"?89![)* %)*CV  6 8 f ()*8Ic!81!8- !8L! #8X2!8C !h! Y7z8)  8C  8)CV86 8 f 8"8CVD8!86 8 08 f c8!7CXV&5  8%" D8X4#  8 8C !Z( 8C ![)*Yc^ lV? 8!8 #7%?[d] }Ua\ ^ A$  T%T7TT+T(0: T'T ?  8!8 #7%?[c zUcZ(8% CyVc([c8!Y7CV7XT 7X6! 8X("Z(6 CyV5" 81%[7CV 7C6# @T7CV 7C6$ @T7C 8z81!8: "h8A! 8:"6% @8zIc8X0%+ + + + + +  + +x >9& TC(Y C8#c8 @8@8&@8@ +8:"8:!i{V7CV5' !T5( !7CV!c8& !7C!8C8:!8 #c8!T7&CV%c8& !7C!8C8:! 8 #c8!Tq7CXV7ChzVb7 CV;7C!8z$ 8-"U7z' 8-"U 5) 8-"VT7z'8z$6* 8#!T7C!h8& !8C8:!8 #c8!c8%L!Z( 8 "e8%L%VC(7z((VC(5+ %8%#!e8%L%8I(8I(8DI(?8I(d8 Id8 I(?8I(d8 Id8!Id8 I(8zI(7C @8I(d8Id8I(c @8%C8%"8%I(7C 81!8%"8I(7C @8I(7C 81!8%"8I(?8#I()*c I()*d I(7%8z*!c8%L%7z8%!c8%!c8%L%7z8%!c8%!c8%L%5, 8%!7z8%!c8%!5- 8%!7z8%!c8%!c8%L%)*5. 8-"U 5/ 8-"V! 8& #7C60 8%"@8I(7zC 8-"V$! 8& #7&CV7C61 8%"@8I(52 8-"U 53 8-"V7C @8I(54 8-"V7&CV7C @8I(7z$ 8-"U 7z& 8-"V7C @8I(7z' 8-"V7C @8I(55 8-"V$8& !7C8z$66 8- !8-"8%"@8I(67 8%"8@[)*! 8& #7C68 8%"@8I()*! 8& '7C V7CV c8ICTT 81%+ + + + +i +S +=69 8 1 ! !  ! + + +8 !8 !8!8!8! + + +8  ! + +8  ! +m +\ +Q8!8 ! +08 !8!8!8$!8! + +8&! +8!8! +8 !8!!8"!8 #! + +h8!i8!88)!8*!8)+!8*,!8+-!8-.!2  <BCE!#%')+-/14479;=?ATVEGIKMO[RTVXZ\^`>5/8 ! + + +   +h !    ">9: c8%P!:9; caml_alloc_dummycaml_alloc_dummy_floatcaml_update_dummycaml_array_get_addrcaml_array_get_floatcaml_array_getcaml_array_set_addrcaml_array_set_floatcaml_array_setcaml_array_unsafe_get_floatcaml_array_unsafe_getcaml_array_unsafe_set_addrcaml_array_unsafe_set_floatcaml_array_unsafe_setcaml_make_vectcaml_make_arraycaml_array_blitcaml_array_subcaml_array_appendcaml_array_concatcaml_comparecaml_equalcaml_notequalcaml_lessthancaml_lessequalcaml_greaterthancaml_greaterequalcaml_output_valuecaml_output_value_to_stringcaml_output_value_to_buffercaml_format_floatcaml_float_of_stringcaml_int_of_floatcaml_float_of_intcaml_neg_floatcaml_abs_floatcaml_add_floatcaml_sub_floatcaml_mul_floatcaml_div_floatcaml_exp_floatcaml_floor_floatcaml_fmod_floatcaml_frexp_floatcaml_ldexp_floatcaml_log_floatcaml_log10_floatcaml_modf_floatcaml_sqrt_floatcaml_power_floatcaml_sin_floatcaml_sinh_floatcaml_cos_floatcaml_cosh_floatcaml_tan_floatcaml_tanh_floatcaml_asin_floatcaml_acos_floatcaml_atan_floatcaml_atan2_floatcaml_ceil_floatcaml_hypot_floatcaml_expm1_floatcaml_log1p_floatcaml_copysign_floatcaml_eq_floatcaml_neq_floatcaml_le_floatcaml_lt_floatcaml_ge_floatcaml_gt_floatcaml_float_comparecaml_classify_floatcaml_gc_statcaml_gc_quick_statcaml_gc_counterscaml_gc_getcaml_gc_setcaml_gc_minorcaml_gc_majorcaml_gc_full_majorcaml_gc_major_slicecaml_gc_compactioncaml_hashcaml_hash_univ_paramcaml_input_valuecaml_input_value_from_stringcaml_marshal_data_sizecaml_int_comparecaml_int_of_stringcaml_format_intcaml_int32_negcaml_int32_addcaml_int32_subcaml_int32_mulcaml_int32_divcaml_int32_modcaml_int32_andcaml_int32_orcaml_int32_xorcaml_int32_shift_leftcaml_int32_shift_rightcaml_int32_shift_right_unsignedcaml_int32_of_intcaml_int32_to_intcaml_int32_of_floatcaml_int32_to_floatcaml_int32_comparecaml_int32_formatcaml_int32_of_stringcaml_int32_bits_of_floatcaml_int32_float_of_bitscaml_int64_negcaml_int64_addcaml_int64_subcaml_int64_mulcaml_int64_divcaml_int64_modcaml_int64_andcaml_int64_orcaml_int64_xorcaml_int64_shift_leftcaml_int64_shift_rightcaml_int64_shift_right_unsignedcaml_int64_of_intcaml_int64_to_intcaml_int64_of_floatcaml_int64_to_floatcaml_int64_of_int32caml_int64_to_int32caml_int64_of_nativeintcaml_int64_to_nativeintcaml_int64_comparecaml_int64_formatcaml_int64_of_stringcaml_int64_bits_of_floatcaml_int64_float_of_bitscaml_nativeint_negcaml_nativeint_addcaml_nativeint_subcaml_nativeint_mulcaml_nativeint_divcaml_nativeint_modcaml_nativeint_andcaml_nativeint_orcaml_nativeint_xorcaml_nativeint_shift_leftcaml_nativeint_shift_rightcaml_nativeint_shift_right_unsignedcaml_nativeint_of_intcaml_nativeint_to_intcaml_nativeint_of_floatcaml_nativeint_to_floatcaml_nativeint_of_int32caml_nativeint_to_int32caml_nativeint_comparecaml_nativeint_formatcaml_nativeint_of_stringcaml_ml_open_descriptor_incaml_ml_open_descriptor_outcaml_ml_out_channels_listcaml_channel_descriptorcaml_ml_close_channelcaml_ml_channel_sizecaml_ml_channel_size_64caml_ml_set_binary_modecaml_ml_flush_partialcaml_ml_flushcaml_ml_output_charcaml_ml_output_intcaml_ml_output_partialcaml_ml_outputcaml_ml_seek_outcaml_ml_seek_out_64caml_ml_pos_outcaml_ml_pos_out_64caml_ml_input_charcaml_ml_input_intcaml_ml_inputcaml_ml_seek_incaml_ml_seek_in_64caml_ml_pos_incaml_ml_pos_in_64caml_ml_input_scan_linecaml_lex_enginecaml_new_lex_enginecaml_md5_stringcaml_md5_chancaml_get_global_datacaml_get_section_tablecaml_reify_bytecodecaml_register_code_fragmentcaml_realloc_globalcaml_get_current_environmentcaml_invoke_traced_functioncaml_static_alloccaml_static_freecaml_static_release_bytecodecaml_static_resizecaml_obj_is_blockcaml_obj_tagcaml_obj_set_tagcaml_obj_blockcaml_obj_dupcaml_obj_truncatecaml_obj_add_offsetcaml_lazy_follow_forwardcaml_lazy_make_forwardcaml_get_public_methodcaml_parse_enginecaml_set_parser_tracecaml_install_signal_handlercaml_ml_string_lengthcaml_create_stringcaml_string_getcaml_string_setcaml_string_equalcaml_string_notequalcaml_string_comparecaml_string_lessthancaml_string_lessequalcaml_string_greaterthancaml_string_greaterequalcaml_blit_stringcaml_fill_stringcaml_is_printablecaml_bitvect_testcaml_sys_exitcaml_sys_opencaml_sys_closecaml_sys_file_existscaml_sys_is_directorycaml_sys_removecaml_sys_renamecaml_sys_chdircaml_sys_getcwdcaml_sys_getenvcaml_sys_get_argvcaml_sys_system_commandcaml_sys_timecaml_sys_random_seedcaml_sys_get_configcaml_sys_read_directorycaml_terminfo_setupcaml_terminfo_backupcaml_terminfo_standoutcaml_terminfo_resumecaml_register_named_valuecaml_weak_createcaml_weak_setcaml_weak_getcaml_weak_get_copycaml_weak_checkcaml_weak_blitcaml_final_registercaml_final_releasecaml_ensure_stack_capacitycaml_dynlink_open_libcaml_dynlink_close_libcaml_dynlink_lookup_symbolcaml_dynlink_add_primitivecaml_dynlink_get_current_libscaml_record_backtracecaml_backtrace_statuscaml_get_exception_backtrace%t4-Out_of_memory)Sys_error'Failure0Invalid_argument+End_of_file0Division_by_zero)Not_found-Match_failure.Stack_overflow.Sys_blocked_io.Assert_failure:Undefined_recursive_module"%,,really_input%input@F@@G@&outputACDF@ACDG@%%.12g!."%d%false$true.bool_of_string$true%false+char_of_int/Pervasives.Exit_j_j_j_j_j_j<5Pervasives.do_at_exit@(array.mlD*Array.blit*Array.fill)Array.sub,Array.Bottom@)List.map2*List.iter2/List.fold_left20List.fold_right2-List.for_all2,List.exists2@@,List.combine'list.mlK-List.rev_map2#nth(List.nth"tl"hd@"\b"\t"\n"\r"\\"\'(Char.chr@5String.rcontains_from4String.contains_from2String.rindex_from1String.index_from +String.blit+String.fill*String.sub@)Sys.Break&4.00.1@*Sort.array@1Marshal.from_size3Marshal.from_string1Marshal.data_size *Marshal.to_buffer: substring out of bounds@@"%d_i_i_i_i_i_i_i_i_i@"%d_j_j_j_j_j_j_j_j_j@"%d_n_n_n_n_n_n_n_n_n@ %Lexing.lex_refill: cannot grow buffer @@ A@@@,syntax error.Parsing.YYexit3Parsing.Parse_error@2Set.remove_min_elt@@@@@'Set.bal'Set.bal'Set.bal'Set.bal@2Map.remove_min_elt@@@&map.mlJ@@'Map.bal'Map.bal'Map.bal'Map.bal@+Stack.Empty@:CamlinternalLazy.Undefined@)buffer.mlsI2Buffer.add_channel4Buffer.add_substring>Buffer.add: cannot grow buffer*Buffer.nth+Buffer.blit*Buffer.sub@ !"!"!'!'!. )printf: bad positional specification (0)."%_)printf.mlH"'' )Printf: premature end of format string ``"''4 in format string ``1, at char number 8Printf: bad conversion % (Sformat.index_of_int: negative argument @ ! "%s"%s.bool_of_string)a boolean-int_of_string*an integer-int_of_string*an integer/float_of_string'a float/float_of_string'a float ! (one of: #(?)&--help%-help9%s: unknown option `%s'. 1%s: wrong argument `%s'; option `%s' expects %s. #%s: option `%s' needs an argument. (%s: %s. %-help&--help"%s#%s %-help= Display this list of options%-help&--help= Display this list of options&--help%-help( %s %s !}!|!{* %s %s%s &'Arg.Bad(Arg.Help(Arg.Stop@/Digest.from_hex/Digest.from_hex$%02x0Digest.substring@_i_j A_j,Random.int64_i,Random.int32*Random.int!xzR+]F4J{lGgP2wAv+^  FKk|HHtcHZš/{Yi2zvn6m[b"|ᵟ.xge=xBLX?}nSO}YE] ~N~aNw"\(sd}@*LY= зd(.OR.2E9!DLJ<AGu<*UO^ohf6o/z@@-OCAMLRUNPARAM,CAMLRUNPARAM @.bad box format/bad box name ho:bad tag name specification:bad tag name specification 9bad integer specification*bad format& (%c)."%c =Format.fprintf: %s ``%s'', giving up at character number %d%s@C!.!>"!> Fatal error: 0Misc.Fatal_error@3@[<2>%a ->@ %a;@]@ 0@[[[%a]]@],utils/tbl.mleKlK@'%s: %B '%s: %s 'version8standard_library_default0standard_library0standard_runtime*ccomp_type3bytecomp_c_compiler4bytecomp_c_libraries1native_c_compiler2native_c_libraries2native_pack_linker&ranlib*cc_profile,architecture%model&system#asm1asm_cfi_supported'ext_obj'ext_asm'ext_lib'ext_dll'os_type7default_executable_name3systhread_supported?/usr/local/ocaml/4.00/lib/ocaml(OCAMLLIB'CAMLLIB "/usr/local/ocaml/4.00/bin/ocamlrun"cc =gcc -fno-defer-pop -Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT 2-lcurses -lpthread 'gcc -D_FILE_OFFSET_BITS=64 -D_REENTRANT 7ld -r -arch x86_64 -o &ranlib"ar#-pg /gcc -bundle -flat_namespace -undefined suppress#gcc /gcc -bundle -flat_namespace -undefined suppress,Caml1999X008,Caml1999I014,Caml1999O007,Caml1999A008,Caml1999Y011,Caml1999Z010,Caml1999M015,Caml1999N014,Caml2007D001,Caml2012T001$.mli%amd64'default&macosx/as -arch x86_64".o".s".a#.so&Cygwin$Unix%Win32(camlprog%a.out,camlprog.exe@ @*%s%s %s %s! "-L .utils/ccomp.mlv[:%s -o %s %s %s %s %s %s %s"-l#lib$msvcLF+%s rc %s %s! unescaped end-of-line in a string constant (non-portable code)0unused rec flag. !. `this pattern-matching is fragile. It will remain exhaustive when constructors are added to type !this pattern-matching is fragile.#: 1the following methods are overridden by the class! / is overridden.+the method 1utils/warnings.mlZ \this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (this pattern-matching is not exhaustive. A Either bind these labels explicitly or add '; _' to the pattern. ;the following labels are not bound in this record pattern: E The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)#: %aThis '%s' might be unmatched k%aSyntax error: applicative paths of the form F(X).t are not supported when the option -no-app-func is set. K%a@[In this scoped type, variable '%s@ is reserved for the local type %s.@].%aSyntax error/Syntaxerr.Error6Syntaxerr.Escape_error@"[]"[]&parser#end&struct!)!(!)!(!)!(!)!(!)!(!)!(#end#sig!)!(#end&object!)!(!)!(!?!? #end&object!?!?!?!? !+"+.!-"-.!*!=!"or"||!&"&&":= #set%Array #set&String#end&object!)!("()#end%begin!)!( #get%Array!)!( #get&String!]![!}!{!}!{"|]"[|@!]![ !!">}"{<@!)!( !?!?!}!{!]![@"|]"[|!)!(!)!(!)!(@A@@@A@@A@@!?!? @@@@@!-!!!+"+.!-"-.!*!=!"or"||!&"&&":="()"::%false$true"[]"()%false$true"[]"()%false$true@A!-"-.!+"+.*unsafe_set#set &Array3 &Array2 &Array1 #set(Genarray*unsafe_get#get &Array3 &Array2 &Array1 #get(Genarray(Bigarray'unsafe_"::"::!+"+. !~!-"-. !~!- %false(*predef*&optionx    @ !"#$%&'()/056789:;<=>@ABCDEFGIJKLNOPRSTUVWXYZ[\]^`abcdefhijklm@L *+,-.1234?HMQ_gn@    ############$$%%'(+++**00,,,,111111115666779999999;;<<==>>???-----HHHHKLLMMNNNNNOOOQPPR@&&ST ........YYVVUUWXX[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[22kkllllmGGnnnnooFFF]]^^^qq__ggrrrssjjhhCCCCC888888888ZZZZZZZZZZZZZZZZZZZZZttxxwwwwyyz}}|||||||||{{{//~~""ppDDII33Afffffffuuuuuuuuuuueeddvv!!JJ44 `aaEEBB))::\\iibbcc    D ;<=> ?#@A B "#C*4YIHLMJ80  , rix$)  !-?TN(9/'(|{ D<F(&%)' X.KPOGBCWV+)&/2  ! =><oswxyjmzJUK_Z.-d@RQUSZ"#$ :y6zuv}CB>=G[g]+:cYX,' !";p2pVch\[*t0lH\amlih%8{`f~tmTekjE}v 83DHOZ4EI5QRS789w:^*;j"#k#'B8^CDCbcd<G H~9;`ab$ L9=b_>?@ABCqzI`;3<4k    $VWWFGH, (!t!00*__.(-301N++&(-.0)(-(-  100^0(-(-R3:B:"j1X'ke{22FVN03/n/l)*ng-/Ls(xnw2|./030x!/n  G (-(-(-(-(-(-(-(-(-(-(-(-(-(-(-(-(-(-(-(-(-(-000(-_ -._G/&eG3(-!*N0)//"/*(-(-g-@7(-(-3(-(-g(-\M!-N &T>O8 36v?(-/'c3c3^32^3SSSS''S^3'2(-(-(-^3eZQ  nUNg(-(-(-e( .!-m3=b$;b/%_/////V*3eewg/JF/1~_1  22t2h(-/(-(-_*-v(-(-`/  (x33(-</GO2Hq(-&e_39_T8v <3GL2G~3r.pf-]pp\O3ydr3(-sg-3(-3(-@(- he(-(-(-2{37y3 rJ7kQJ23.U  Aq(.3r0p3f333d/g-2 23(-3x}33(-(-(-~3d xlG 3-3r~3./0p3 C3(-3-'3,x!S.#by222 [~3r^~3933'/3$(-%6;33?(-5C3  33~33Ar3x(-333I3(-3 eP~3S(-_33ab3cg\3333(- z:/0 477  ?c (~0:%G%)("%GK)+;,,,.&&77E&0 :$\&G:7gj12eqc`& /s&+/H$|a@iEAgC  :G3h4v:m' *::Y'a.`h%-x{`&3$:$%7%Eq9Gh'&XYY#`$$#a = %|! 2%"#0U3u5>(%`Xd$Y>7Q%B%$K#$F5u#SY 4XU fK$`XeY$ 8Ycuk SU"5 uyF])S 2Ln:m]]=L"PD<#6@*! jJP\l2gsftVc?&_d'S:Ef|&88%I SWMN1ay_1N;fy6xL8tIJT/m:uw3U}3{6v~5l98nK%8661ha_&6a_fLQ<cd9yh9a7~Z~a65ym58w,817/'6//-i_0_/f (fXg`9l9~a9`/l71/Eh664 E:& )%e*bE.EE //1:E&%hbe7$% yhT`.a`E9E3~1~~~F8g~4\X4~EsEeqe~bmo121v9~lUq]:dQrs:qa;Qq~3QQQkqqQ:T~|:qb:7*1Q9|37Q|yK!jhiQ Rqja||QQA71~T-:"da|~~TLg/~~~:~AB77F~ |bmbb~ ~AbbShb1b1bb#~:bMbbg/$]&Y(<?b1bJZb~2bM0^_0\q@bIbbb$/$5`:bb]k5p0k^qk{a5k09|~kkk[1 o_kp!Vn~.1191~~~k~~k1ekU~1kkwgkAkAg~~~AaHgYgg~VAAAAg:A~ UMgZgA=gy~A!Vn:A5 ggx=Y A~AAgg/<TAAY>A ?@a0p0<~AU $VW~[i$$21%5A%B$F~PK$X~YF(aU$o~&F$NG$ fVn0X0QRx$$(%\<Y$iW<0n )%1~sY ~+``|n=1``><,`$~J^(-^~~TY``^`,GZZ0Wx<Vn919c:::Ddeh5ik~:5~EFG3RS5o..nRX^^H:`pu{^^r~61`M~^:NOP^^H^HHHQY```x ~R(777*RKT5UVY7:jtv)yz|~5:555::7:^5:^WW75:WA('+WLWW)0UJWKOQPV[\^^]^`ceW:WYl}moW7WW777777OQ47:7>@ELOZ7[777in77rtq:vw:::{::}77U:77L7LLLLL%:L:L^Y:9/1:0:9g23 }uLxxE"DYLLLL">iL~7777O77u.U777Y7,P7jnO`AAAA:AAAFFFFFdFA)+46:AAAAF:A`FFFF2^DDDFDDDpDP7PPPP DP2+DDDD:OPDPO9PO7OO^PPOOONdddkOddOdOdzddddd7dddddddYddrz                                                                                      MMMMMMMMM.MMMMM-......................................------------------------^--^^-^^^------^-----^^^^^^]]]]]]]I]]]]]]IIIIIIIIIIINPYYY@YMF@@@@@@@ @@@@@@@@ @   !"#$%&'()*+NG-./01 2  !"#$%&'()*+G-./01 2  !"#$%&'()*+G-./01 2                                                 ?noqrsuRLM???S?????nnNn?no?nonn?6ono???oooq?q?n7oqnqnqrqqronnorqornnrsrrsooq;srqosoqsssuur3qqRsruqruqRuuu5srrRRRsLursrRLssuLMLLussuRML2RuuMSMMRuuSMLR,RLSSSNLS4MN*LML6NNNM06SNMSM6667S667NSSN77761N6776NN;;667;767;3;;773;75333;53;;5553;;53;325233553222,552,54,*,,242*,20444***022,4*,2000,40*,,4*14,*01440**01411*0010111 111f !%&'-./12 f !%&'-./12 f !%&'-./12 Y  !"#$%&'()*+ , -./012  !"#$%&'()*+q-./0125stuV6?@%A{q- .B1}5stuV6?@%A{q-.1}5stuV6?@%A{q-.#1}5stuV6?@%A{q-.1}5stuV6?@%A {-.1}ef !"#%&')*+ -./12f !"#%&')*+ -./12f !"#%&')*+;;;;;-./12;;;;;;;;;;;;;;;;;;;;;;;;;;<<<<<;;;;;<<<<<<<<<<<<<<<<<<<<<<<<<<=====<<<<<==========================>>>>>=====>>>>>>>>>>>>>>>>>>>>>>>>>>  >>>>>f !"#%&'q)*+-./12rstuV[w\q%CxyzD{-|.1}]rstuVEwq%~xyzD{-|.1}rstuVEwq%xyz{-|.1}rstuV.wq%CxyzD{-|.1}rstuVEwq%xyz{-|.1}rstuV.wq!%xyz{-|.1}rstuVvwq%xyz{-|.1}rstuV.wq%xyz{-|.1}5stuV6w=q%y{-.1}5stuV6wq%y{-.1}5stu7V6w7%y77{-.1}7777777+777+77++77777++++++++++q+++++++stuV. w %y{-.1} V] %&+-.1 V] %&+- . 1V]%&+-].1%&+-.1-<34567YxYYY j s) &f{&u^F  !aL,/20tu}Y+PQR#56N;C=?G#?]E?@rgV8@^@?vw6%,h`K 56gVc?Z\%j?Y< >LNWmVYZ\Y& ?6gYmmgYm3"ZWV>VZ-WZh%gYYLZYW7?Z:WVZTJVW0Z? 6%Zgh@@&,(5Y x\KgYmdg)Y!p^\]V3] @YWWWZ3FYJWLx3rstuvYx)[\YLVEZfiV^ZmFWYg LV`aYkY&gfiV V]@/0)')/m(ZBV Bd\gFVL$AFmfj["WiWS/0fWiiW@WffoB(-Y.EW567W@:@BFD(dWgJF$L^JN i\TYVE4_[^ Y@W$h)jUvnUW$xW)Y>Y/0(FCL>gOBFWL/0@fW( Y6[\Y6?BYfiY@/)R??6GB#>i8j F?@?UL-.1jg@[\[i)?@fi@d Sg%g>Y`F^%gfiL_'e)?d(Ng@0#=[\?=Q?f=i A@@@EFU ?@gFCS?@h)U@@rtuv)fo]?`Yh>g?8F>g?LmF?@%\LJ[[\!g[Y[\fRgi?f??ig8mg >?@j?7?J8W ?@g)gjU$Y?@gg)>gYFdm~gL???>6m8F[\g6L8?#?@f??@\[\?Ygfgfj.68Y!&567?@:g gggUm:FRJgL=@ G_h)X[^gjX Zi]@>Cfg+FexOLroz|;=?}[+,-.Xffg@CDC ?@OPO  ratuv^@()@?G123j?@>n@ZF?@L HZgYY[\ZYfmigm+m?123;=?X?g?([H!g#,-.? AZEFZ67g??CD grStuvgYOP@!g.f^=)K@fm8g?.gU>?@W567Y:JF^?YL^YJY?E[(g[ ^fi?Kgg8:;<g?@Kx)WZ$;E_ UU+\Z@FLghY?$YY?)YY[/0mGG==f=i>(BEF.E@?L567:YVWEYZ[EY^YjJfEf~iRjmEE[=^?ZYE8Y:;<?@YrtuvxUReEV8\:;<o?@(EghjV UA\EFY[?YghYYUS Y$??$?fV??LU()W(E%@AC\A>VWvYZXF LACukIY[\LCfQi>m8:;<?@([].567j:UA\EFyJghS6[^fx3 =CLV) e>@oFL Y[\fi3mEce>korVWYZTE(kVWYZ=ACEFk S efo  )E)>@)F.VWLYZ6YF[\FkL Lfim[fif)i F)KL/[> FfiLEtYO[\)TV/0f\8i:;<m?@6>iB=FMtLSU{\Y[\fghf i eo%()/0>BEFLVWYZ[\acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[\^acfim6     $%()*+,-./012346789<=>?@BCDEFHILMNOPQSVWYZ[\^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[\^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[\^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[\^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[\^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[\^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[^_abcdfgim   $%()*+,-./04<>BCDEFLMNOPSVWYZ[\^abcfim   $%()*+,-./04<>BCDEFLMNOPSVWYZ[\^abcfim   $%()*+,-./0<>BCDEFLNOPVWYZ[^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[\^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[\^acfim   $%()*+,-/0<>BCDEFLNOPVWYZ[\^acfim   $%()*+,-/0<>BCDEFLNOPVWYZ[\^acfim   $%()*+,-/0<>BCDEFLNOPVWYZ[\^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[\^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[\^acfim   $%()*+,/0<>BCDEFLNOPVWYZ[\acfim   $%()*+,/0<>BCDEFLNOPVWYZ[\acfim   $%()*+,/0<>BCDEFLNOPVWYZ[\acfim   $%()*+,/0<>BCDEFLNOPVWYZ[\acfim   $%()*+,/0<>BCDEFLNOPVWYZ[\acfim   $%()*+,-./0<BEFLNVWYZ[\^acfim   $%()*+/0<>BEFLNVWYZ[\acfim   $%()*/0<>BEFLNVWYZ[\acfim   $%()*/0<>BEFLNVWYZ[\acfim   $%()*/0<>BEFLNVWYZ[\acfim   $%()*/0<>BEFLNVWYZ[\acfim   $%()*/0<>BEFL NVWYZ[\acfim   E%()/0VWYZ>BEFkLNVWYZ[\acfi  m %()/0>BEFLNVWYZ[\acfi m %()/0>BEFLVWYZ[\acfi m %()/0>BEFLVWYZ[\acfi m %()/0>BEFLVWYZ[\acfi m %()/0>BEFL VWYZ[\acf i m%()E/0VW>YZBEFLkVWYZ[\acfi m %()/0>BEFLVWYZ[\acfi m %()/0>BEFL VWYZ[\acf i m%()E/0VW>YZBEFLkVWYZ[\acfi m %()/0>BEFLVWYZ[\acfi m %()/0>BEFLVWYZ[\acf i m %())/0>BEFFLLVWYZ[\[acfif mi %()/0>BEFLVWY[\acfim 8:;<$?@)/0MSU>?B\EFLghVWYZ[\^fgi m8:;<$?@)/0MSU>?B\EFLghVWYZ[\^fgi m8:;<$?@)/0MRSU>B\EFdLghVWYZ[\fi m8:;<$?@)/0MSU>B\EFdLghVWYZ[^fi m8:;<$?@)F/0MSU>YB\EFLghVWYZ[\fi m$)/0>BFLVWYZ[\fi m$)/0>BFLVWYZ[\fi m8:;<$?@)F/0MSU>B\FLghVWYZ[\fi m$)/0>B FLVWYZ[\)fi m>F$L)/0Y[\>fBi FmLVWYZ[\)fi m>FL)Y[\>fiFmLY[\fim    !"')12356789>?@ACDFHIJLOPQ[\_defgl    !"')12356789>?@ACDFHIJLOPQ\_defgl    !"')12356789>?@ACDFHIJLOPQ\_defgl   )12345689>?@CEFHLMOSVWYZ[\_bdfghk  ))>@FKL?EF[\LfiY[\^ fgi) ?EF)LY[\>^EFfgiL[\ ^fi) > F)L[\>)FfiL >[\FLfi )Y[\fi>) FL>[\F )Lfi[\> )FfiL>[\)F fLi >[\F)fLi) [\>FfiLF )L[\[fi )FfiL[)F fLi[ F)fLi[() FfiL>[F()Lfi[\> FfL[\ )f > )FL)>[\)FfL>>F [\LFLf[\[\)f f> F )L [\>))FfL>)>[\FFLfL> [\F[\Lff[\)f>FL   [\f !"$'*+,-.12356789<>?@ACDFHIJNOPQY^_degl    !"$'*+,-.12356789<>?@ACDFHIJNOPQY^_degl    !"$'*+,-.12356789<>?@ACDHIJNOPQ^_degl  1234689?@CEHMOSVWYZ\_bdghk8$:;<?@/0MS?UBE\   ghUVZ\^ !"gi')12356789>?@ACDFHIJLOPQ[   _defgl !"')12356789>?@ACDFHIJLOPQ  _defgl$*+,-.1235689<?@CDFHNOPQY \ ^_dfgh$*+,-.1235689<?@CDFHNOPQY \ ^_dgh$*+,-.1235689<?@CDFHNOPQY \ ^_dfgh$*+,-.1235689<?@CDFHNOPQY \ ^_dfgh$*+,-.1235689<?@CDFHNOPQY  \^_dgh !"'12356789>?@ACDHIJOPQ  _degl !"'12356789>?@ACDHIJOPQW   _degl !"'12356789>?@ACDHIJOPQ  _degl !"'12356789>?@ACDHIJOPQY  _degl !"'12356789>?@ACDHIJOPQY  _degl !"'12356789>?@ACDHIJOPQY  _degl !"'12356789>?@ACDHIJOPQY  _degl !"'12356789>?@ACDHIJ OPQ_degl1234689?@CE HMOS\_bdghk1234689?@C HMOS\_bdgh1234689?@C HMOS\_bdgh1234689?@C HMOS\_bdgh1234689?@C HMOS\_bdgh1234689?@C EHMOS\_bdgh1234689?@C HMOS\_bdgh1234689?@C HMOS\_bdgh1235689?@C  HOW\_dgh1235689?@C HO\_dgh1235689?@C HO\_dgh1235689?@C HO\_dgh1235689?@C HO\_dgh123689?@C  HO\_dgh12346789?@  HIMQS\_bdg12346789?@  HIMQS_bd  g1236789?@HIQ1236789_?@dgHI Q_dg$*+,-. <CD$NOP*+,-.Y^< CDNOPZ$^*+,-.< CDNOPQY$^*+,-. <CD$NOP*+,-.^ <CDNOP$V*+,-.^ <CDNOP$V*+,-.^ <CDNOPQ$*+,-.^ <CD$NOP*+,-.^ <CDNOP$*+,-.^ <CD$NOP*+,-.V^< CDNOPY$^$*+,-.*+,-.<<CDCDNOPOP8:;<^?@^JMSU8:;<\?@ghMSU8:;<\?@fghMSU8:;<\?@ghMSU8:;<\?@ghMSU8:;<\?@ghMSU\gh AMPERAMPERAMPERSANDANDASASSERTBACKQUOTEBANGBARBARBARBARRBRACKETBEGINCLASSCOLONCOLONCOLONCOLONEQUALCOLONGREATERCOMMACONSTRAINTDODONEDOTDOTDOTDOWNTOELSEENDEOFEQUALEXCEPTIONEXTERNALFALSEFORFUNFUNCTIONFUNCTORGREATERGREATERRBRACEGREATERRBRACKETIFININCLUDEINHERITINITIALIZERLAZYLBRACELBRACELESSLBRACKETLBRACKETBARLBRACKETLESSLBRACKETGREATERLESSLESSMINUSLETLPARENMATCHMETHODMINUSMINUSDOTMINUSGREATERMODULEMUTABLENEWOBJECTOFOPENORPLUSPLUSDOTPRIVATEQUESTIONQUESTIONQUESTIONQUOTERBRACERBRACKETRECRPARENSEMISEMISEMISHARPSIGSTARSTRUCTTHENTILDETOTRUETRYTYPEUNDERSCOREVALVIRTUALWHENWHILEWITH CHARFLOATINFIXOP0INFIXOP1INFIXOP2INFIXOP3INFIXOP4INTINT32INT64LABELLIDENTNATIVEINTOPTLABELPREFIXOPSTRINGUIDENTCOMMENT@#int%int32%int64)nativeint"!=1parsing/lexer.mllP1parsing/lexer.mllR1parsing/lexer.mllP=String literal not terminated6Illegal character (%s) 4Illegal backslash escape in string or character (%s)6Comment not terminated 4This comment contains an unterminated string literal 2`%s' is a keyword, it cannot be used as label name FInteger literal exceeds the range of representable integers of type %s!-!-!-!-+Lexer.Error#andB"asC&assertD%beginJ%classK*constraintQ"doR$doneS&downtoV$elseW#endX)exception[(external\%false]#for^#fun_(function`'functora"ife"inf'includeg'inherith+initializeri$lazyj#lets%matchu&methodv&modulez'mutable{#new|&object}"of~$open"or@'privateC#recI#sigN&structP$thenQ"toS$trueT#tryU$typeV#valX'virtualY$whenZ%while[$with\#mod#mod$land$land#lor#lor$lxor$lxor#lsl#lsl#lsr#lsr#asr#asr@, H&Il CEHUB{e]/xi_-]p7gzbraNsuvu, - A d g> M K m   . HIFE?=964/.,*&$A! D HGB#-7C>@  H;@SSTSVoz *$&&$%RXqRXQW$ ! f # "dac`]P_^K$?9$9778888888888>DPGJL$66666666xwOOOOOOOOOO8888888888e~ = |R>Q~VUR=Q<UTZZZZZZZmZZZZZZZ:kkkkkkkkkkZklkkkZZkkkjigbhZZZZ|ZZ{Z[ZZZZ\ZZ}YZNM77yZZ1.0.71/-200/.-3420/-3411111111115555555555q0p555555EEEEEEEEEEt1svu0555555  5555555555555555.FFFFFFFFFF5555555r/- '''''''''''''+'8888888888'***************************8''''''''P'''''''''POOOOOOOOOO'(((((((((((((((((((((((((((''********************************HHHHHHHHHHHHHHHHHHHHHH(((((((((((((((((((((((( (((((((( 66666666IIIIIIIIII.IIIIII6/-IIIIII '''''''''''''''((((((((((()'(((((((((((((((((((((((((('('((((((((((((((((((((((((((URQUTOOOOOOOOOO((((((((((((((((((((((((((((((((((((((((((((((((((((((*((((((((**********,*******************************************************************************************************************'''''''''CCC''''''BBBBBBBBBBMMMMMMMMM'MMMMMMCC''CCCMAMMZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkZZZZZZZZZkkZkZZZZZkkZZZ *%QWpSVSV  $;0$0220000000000=CFIK$33333333uvz9999999999 |<SV{T<T{TUUUUU    T U sss77s7777s11111111114444444444n1n444444BBBBBBBBBBn1nnn1444444  55555555555555555EEEEEEEEEE5555555n55 !!!!!!!!!!!!!!!8888888888!!!!!!!!!!!!!!!!!!!!!!!!!!!!8!"!"""""P"""""""""PPPPPPPPPPP""""""""""""""""""""""""""""""!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!AAAAAAAAAAAAAAAAAAAAAA""""""""""""""""""""""""#""""""""###############################################################66666666HHHHHHHHHH6HHHHHH666HHHHHH##############################################################'''''''''''''''(((((((((((('(((((((((((((((((((((((((('('((((((((((((((((((((((((((OOOOOOOOOOOOOOO((((((((((((((((((((((((((((((((((((((((((((((((((((((*((((((((****************************************************************O**************************************************************+++++++++:::++++++::::::::::MMMMMMMMM+MMMMMM::++:::M:YYYYYYYYYMYMYYYYYZZZZZZZZZZYZZZZZ[[[[[[[[[YYZ[[[[[[\\\\\\\\\ZZ:\[\\\\\bbbbbbbbb[[b\bbbbbhhhhhhhhh\\hbhhhhhkkkkkkkkkbbkhkkkkklllllllllhhlklllllmmmmmmmmmyykkymlmmmmmyyyyyyyyyyllmyymmyyyy H $  H '' H J$$$ JTTTUOPOOOOOOOOOOPPPPPPPPPPPT *@,//toplevel//,//toplevel//,//toplevel//@"%s%%a.%s&%a(%a)$ '%s-core_type %a )Ptyp_any ,Ptyp_var %s +Ptyp_arrow +Ptyp_tuple /Ptyp_constr %a ,Ptyp_object .Ptyp_class %a 0Ptyp_alias "%s" 7Ptyp_variant closed=%s ,Ptyp_poly%a 0Ptyp_package %a -with type %a 3core_field_type %a ,Pfield "%s" +Pfield_var +pattern %a )Ppat_any .Ppat_var "%s" 0Ppat_alias "%s" 1Ppat_constant %a +Ppat_tuple 2Ppat_construct %a 2Ppat_variant "%s" ,Ppat_record +Ppat_array (Ppat_or /Ppat_constraint)Ppat_type*Ppat_lazy 1Ppat_unpack "%s" .expression %a 0Pexp_assertfalse.Pexp_ident %a 1Pexp_constant %a ,Pexp_let %a 3Pexp_function "%s" +Pexp_apply +Pexp_match )Pexp_try +Pexp_tuple 2Pexp_construct %a 2Pexp_variant "%s" ,Pexp_record +Pexp_field .Pexp_setfield +Pexp_array 0Pexp_ifthenelse .Pexp_sequence +Pexp_while 1Pexp_for "%s" %a 0Pexp_constraint *Pexp_when /Pexp_send "%s" ,Pexp_new %a 5Pexp_setinstvar "%s" .Pexp_override 4Pexp_letmodule "%s" +Pexp_assert)Pexp_lazy*Pexp_poly +Pexp_object2Pexp_newtype "%s" )Pexp_pack/Pexp_open "%a" 2value_description !_4type_declaration %a /ptype_params = .ptype_cstrs = -ptype_kind = 3ptype_private = %a 1ptype_manifest = /Ptype_abstract .Ptype_variant -Ptype_record .class_type %a /Pcty_constr %a /Pcty_signature .Pcty_fun "%s" 0class_signature +Pctf_inher 7Pctf_val "%s" %a %a %a 5Pctf_virt "%s" %a %a 5Pctf_meth "%s" %a %a -Pctf_cstr %a 5class_description %a .pci_virt = %a -pci_params = 0pci_name = "%s" +pci_expr = :class_type_declaration %a .pci_virt = %a -pci_params = 0pci_name = "%s" +pci_expr = .class_expr %a .Pcl_constr %a .Pcl_structure (Pcl_fun *Pcl_apply +Pcl_let %a /Pcl_constraint 0class_structure -Pcf_inher %a 7Pcf_valvirt "%s" %a %a 6Pcf_val "%s" %a %a %a 4Pcf_virt "%s" %a %a 7Pcf_meth "%s" %a %a %a .Pcf_constr %a )Pcf_init 5class_declaration %a .pci_virt = %a -pci_params = 0pci_name = "%s" +pci_expr = /module_type %a .Pmty_ident %a /Pmty_signature 2Pmty_functor "%s" *Pmty_with ,Pmty_typeof 2signature_item %a 0Psig_value "%s" *Psig_type 4Psig_exception "%s" 1Psig_module "%s" /Psig_recmodule 2Psig_modtype "%s" -Psig_open %a -Psig_include +Psig_class 0Psig_class_type 2Pmodtype_manifest 2Pmodtype_abstract +Pwith_type 0Pwith_module %a 0Pwith_typesubst 2Pwith_modsubst %a /module_expr %a .Pmod_ident %a /Pmod_structure 2Pmod_functor "%s" +Pmod_apply 0Pmod_constraint ,Pmod_unpack 2structure_item %a *Pstr_eval .Pstr_value %a 4Pstr_primitive "%s" *Pstr_type 4Pstr_exception "%s" 8Pstr_exn_rebind "%s" %a 1Pstr_module "%s" /Pstr_recmodule 2Pstr_modtype "%s" -Pstr_open %a +Pstr_class 0Pstr_class_type ,Pstr_include#%a 0 %a ("%s" %a +"%s" %a %a , %a #%a ' & 0 "%s" #%a - Add to the list of include directories"-I9 Print inferred interface"-i 5 Record debugging information for exception backtrace"-g; Save debugging information"-g Y Generate code that can later be `packed' with ocamlopt -pack -o .cmx)-for-pack 2 Ignored (for compatibility with ocamlopt))-for-pack< (deprecated) same as -annot'-dtypes A Add to the run-time search path for shared libraries(-dllpath / Use the dynamically-loaded library &-dllib4 Link in custom mode'-custom $ Print configuration values and exit'-config % Optimize code size rather than speed(-compact 5 Pass option to the C compiler and linker&-ccopt ( Pass option to the C linker&-cclib 5 Use as the C compiler and linker#-cc; Compile only (do not link)"-c ! Save typedtree in .cmt*-bin-annot % Save information in .annot&-annot * Show absolute filenames in error message(-absname0 Build a library"-a@@3bytecomp/bytegen.mlj@0caml_alloc_dummyA6caml_alloc_dummy_floatA1caml_update_dummyB Q$%a@.7Bytegen.comp_expr: var @@/caml_make_arrayAhxAABAB9Bytegen.comp_expr: assignA@:caml_ensure_stack_capacityA1caml_int_of_floatA1caml_float_of_intA.caml_neg_floatA.caml_abs_floatA.caml_add_floatB.caml_sub_floatB.caml_mul_floatB.caml_div_floatB5caml_ml_string_lengthA/caml_string_getB/caml_string_setC1caml_bitvect_testB,caml_obj_dupA-caml_eq_floatB.caml_neq_floatB-caml_lt_floatB-caml_gt_floatB-caml_le_floatB-caml_ge_floatB;caml_array_unsafe_get_floatB5caml_array_unsafe_getB;caml_array_unsafe_set_floatC5caml_array_unsafe_setC4caml_array_get_floatB3caml_array_get_addrB.caml_array_getB4caml_array_set_floatC3caml_array_set_addrC.caml_array_setC&of_int&to_int7caml_nativeint_to_int32A7caml_int64_of_nativeintA7caml_nativeint_of_int32A3caml_int64_of_int32A7caml_int64_to_nativeintA3caml_int64_to_int32A#neg#add#sub#mul#div#mod#and"or#xor*shift_left4shift_right_unsigned+shift_right*caml_equalB-caml_notequalB-caml_lessthanB0caml_greaterthanB.caml_lessequalB1caml_greaterequalB,caml_ba_get_,caml_ba_set_6Bytegen.comp_primitive/caml_nativeint_+caml_int32_+caml_int64_<) outside appropriated catch%exit(2Bytegen.merge_repr3Bytegen.merge_infos @&L%i:%a&%a@ %a+@[%a@]$@ %i# %i% push( restart+ vectlength, getvectitem, setvectitem. getstringchar. setstringchar( boolnot( poptrap& raise. check_signals' negint' addint' subint' mulint' divint' modint' andint& orint' xorint' lslint' lsrint' asrint& isint& isout* getmethod* getdynmet% stop$L%i:' acc %i* envacc %i' pop %i* assign %i1 push_retaddr L%i) apply %i/ appterm %i, %i* return %i( grab %i0 closure L%i, %i+ closurerec$, %i1 offsetclosure %i- getglobal %a- setglobal %a2@[<10> const@ %a@]1 makeblock %i, %i2 makefloatblock %i, getfield %i, setfield %i1 getfloatfield %i1 setfloatfield %i+ branch L%i- branchif L%i0 branchifnot L%i3 strictbranchif L%i6 strictbranchifnot L%i4@[<10> switch%a/%a@]- pushtrap L%i- ccall %s, %i& eqint' neqint& ltint& gtint& leint& geint- offsetint %i- offsetref %i- getpubmet %i1 event "%s" %i-%i@@@@@5Emitcode.define_label@5Emitcode.const_as_int.Emitcode.AsInt@=Bytesections.Bad_magic_number@&Cygwin$Unix%Win32/bytecomp/dll.mlK4CAML_LD_LIBRARY_PATH'ld.confpD": "-l#dll@ "Reference to undefined global `%s' +The external function `%s' is not available ,Cannot find or execute the runtime system %s 0The value of the global `%s' is not yet computed7Symtable.hide_additions$SYMB$PRIM$DLPT $CRCS )Toplevel bytecode executable is corrupted-Symtable.init )camlprims*%s -p > %s3extern value %s(); >typedef value (*primitive)(); #primitive caml_builtin_cprim[] = { & %s, 3 (primitive) 0 }; /const char * caml_names_of_builtin_cprim[] = { ( "%s", 0 (char *) 0 }; .Symtable.Error@ *Error while building custom runtime system3Cannot find file %a )The file %a is not a bytecode object file;Error while linking %a:@ %a J@[Files %a@ and %a@ make inconsistent assumptions over interface %s@] !Cannot overwrite existing file %a 'Error on dynamically loaded library: %a*stdlib.cma,std_exit.cmo@*stdlib.cma (camlcode".c(camlprim #ifdef __cplusplus extern "C" { #endif #ifdef _WIN64 #ifdef __MINGW32__ typedef long long value; #else typedef __int64 value; #endif #else typedef long value; #endif <#ifdef __cplusplus } #endif ".c".c)-lcamlrun&Cygwin%Win32$.exeABF@)-lcamlrun! "-I #ifdef __cplusplus extern "C" { #endif #include CAMLextern void caml_startup_code( code_t code, asize_t code_size, char *data, asize_t data_size, char *section_table, asize_t section_table_size, char **argv); ;static int caml_code[] = { ) 0x%x}; Options are:@@JB@ <@@#ArgA@A@%ArrayAk@@%BtypeA5@AB@&BufferA@@'BytegenA I@@-BytelibrarianA @ABC@(BytelinkA @@,BytepackagerA @A@,BytesectionsA @B@0CamlinternalLazyA@@%CcompA@ACD@$CharAB@@'ClflagsA@A@*Cmi_formatA4@@*Cmt_formatA'@@'CompileA &@ABC@&ConfigAz@@)ConsistblA@A@%CtypeA@@(DatareprA-@ABD@&DigestA@@#DllA @A@(EmitcodeA @B@#EnvAX@@&ErrorsA @A@(FilenameA-@@&FormatA @ABCEF@'HashtblA@@%IdentA@A@,IncludeclassA$@@+IncludecoreAB@AB@*IncludemodAn@@(InstructA @A@%Int32Ab@BC@%Int64Am@@&LambdaA@A@%LexerA%@@&LexingA}@AB@$ListAz@@(LocationA@A@)LongidentA@@$MainA :@A@)Main_argsA @@#MapA@ABCDE@'MarshalAV@@(MatchingA T@A@$MiscA1@B@%MtypeA%@@)NativeintAx@AC@#ObjAW@@'OpcodesA @A@&OprintA@B@(ParmatchA#@@%ParseA)@AC@&ParserA@@'ParsingA@@$PathA@ABDEFG@*PervasivesAe@@&PparseA C@A@&PredefA)@@)PrimitiveA$@AB@(PrintastA@@&PrintfA@@*PrintinstrA @AB@+PrintlambdaA @@(PrinttypA@ACD@&RandomA@@*RuntimedefA :@A@#SetA@@'SimplifA 7@AB@$SortAQ@@%StackA@@(Std_exitA ;@ABC@&StringAL@@&StypesA9@A@%SubstA@B@&SwitchA @@(SymtableA @A@)SyntaxerrA(@@#SysAO@ABCDE@#TblA6@@+TranslclassA @A@*TranslcoreA @@)TranslmodA 2@AB@)TranslobjA [@@)TypeclassA@@(TypecoreA@ABC@(TypedeclAC@@)TypedtreeAY@A@'TypemodA@@'TypeoptA @ABD@%TypesA%@@(TypetexpA@A@(WarningsA@@$WeakA @P-Match_failureCG@ABCEQ-Out_of_memoryC@@R0Invalid_argumentCC@AS'FailureCB@T)Not_foundCF@AU)Sys_errorCA@BCV+End_of_fileCD@W0Division_by_zeroCE@AX.Stack_overflowCH@Y.Sys_blocked_ioCI@AZ.Assert_failureCJ@[:Undefined_recursive_moduleCK@ABCDFGH U(Location0 Ik˘/ &Oprint0H Q9W*Translcore0?QVE\ڈ$Char0&)9_=J(Bm*Cmi_format0%x̣$$Weak0n M?&Lambda0s+ Eꠠ(Matching084Ӻz(Filename0LTjC>+Translclass0',۵Y2+>Kˠ&Predef0ń3l+q."=,Includeclass0=@dIgɵ`'Bytegen0A_Bw-%Array0M^ {OԲwp%Stack0&(Jhl?)Translobj0b%Hr|6+Printlambda0B)ˬ~xuڠ&Pparse02.4`>*Printinstr0q8M)Typedtree0U=Q+)5 #Obj0{B+,;'Hashtbl0q΋q"H>6/x#Env0V[zޱ7+Includecore0M}=\P%/󲠠&Switch0 ';T(Ti#Set0**V $.QCˠ)Consistbl0䞗ْ6nSs#Tbl0MLz %3&Digest0rUATy[;l(Terminfo0y5 &ﺠ&Stypes0]k^J63(Std_exit0Uol'HWà'Typemod0KnW[/8?'Simplif0K%G?* WN)Main_args0k75d)#d (Bytelink0 /Z8Hv'Typeopt0ĤkǠ*Cmo_format0W-/.#p,Bytesections0Te'Wu栠,Bytepackager0rfqgROӠ&String0T&GSq첋*Runtimedef0iS U!K&Random0o7pr)Longident0BLl=1}A}f'Marshal0}55UanRߜ&Buffer0?lG!Wdk:Ѡ(Typedecl0'Z\'_{%ܠ(Printtyp07=@sIp|(X-Bytelibrarian0:yGT}let/ˠ#Sys0Eu%B&̄y&)Nativeint0G$)@p hc$%Btype0a YneP%Lexer0(O\Xt<.CamlinternalOO0]q?bp'Compile0 iCS dMm&Format0nk{uDLsc'Parsing0 RY'Opcodes0U2*N>̝D$Meta0dQTsw[$Misc0TU2*OTɏ(Asttypes0W_Nw;'#&%Mtype0+J3@Ou (Typecore0Ŷ ܳU Ĥ(Instruct09yk)K?aנ(Warnings0"քO]-(Jg\x,ꠠ(Symtable0Π~%&%g6(Emitcode0(AWhLKEańy蠠)Syntaxerr0v9Rw~ N֠0CamlinternalLazy0~OaKtGB(Typetexp0KKt} 3庙Ҡ%Parse0Οj~[h@n)Translmod0[i-ȠX!&Lexing0~0fڛ[LPѪ*$Lazy0G T mONK(Printast0'ykޞ?栠%Annot0[3W[%Ctype08=މC Y\70'Clflags0͗{͇g.ݑ%Types0ΪE -Ӡa +Outcometree0`D'OM jݠ$Main0`rjB+Ex q栠%Ccomp0h[6[gȖ`B8(͠$Path0MW=?z*Includemod0&0-Gsݠ%Int640 ^͍:.B};@CODE{DLPTDLLSPRIMDATA%SYMB^CRCS 4Caml1999X008mingw-ocaml/ocaml/boot/myocamlbuild.boot0000755000175000017500000150113612124403240020000 0ustar tootstoots#!/home/lefessan/.ocaml/roots/ocaml-4.00-binannot/bin/ocamlrun T)*VD C 2" @(()*c( ` 5?[o n2$ ]()* ^()* ^()* ^()* ^(](]()* ^(](](](]U()* ^(](](]()* ^()* ^(](]()* ^(](](c!](cC%c!c%C +I( ] ] h ha()*6 " &c!](c!]Y(]%g ^]("g ^](!&!&&^(g ^]("g ^](!&!&&^(Y]Z(h()*VD C ] oha o2' ()*] V  ]'5?[)] h `c]cVn @ ]'(m] mh `co @2&, ,ch &)*  ]o }V5 % $)*  ]o }V5% `(h6'h6')* _](Y]ZThY]Z(h(]]()*c _()*  ]o }V5% `()*]h `(VD C Y]ZTh2%c(,c] %l6'l6')* _](6^% ~V5&^ 0: T -T(2%] ,c %6^Z(5 ^V5 ^V5%d(c(V5(5(5%()*] ] n] h ha ha(g u((m()* ^V(()* ^V((6@[6@[+ +6? + + + +livgTg>iv 6]6]6 ]6!]6"]6#] +^+H +9+ + :+ + ,c]i]j] + + + + +Z+4 +& + + + + +%+ ,(+ +t ++ +++++++v"+f +V+A+2 !+" + + :,+ +? + + + 6$^.  + + + +} +t +h> +X +L +C +: +. +$ + +),* +213 +79 + + +> + +BD +G +LKM02468:<>@BDFHJL_acegkmoqsuwy{}>QB9%T)*V D 2&(]()* _()*|V  $eq o  n n2  n2  n n$ )*c }UH\ n^ n? T\C^ C_ C~V  C^"c C_ zUc()* "._ {V ^2$ o$ _ {V ^ 2$ o$ )* nn  , ^^$)* + + ,O |V hh$ e q oh^ ^  h   h c h $)* " ^"^ _ 2' _()*Y #Z( CyV D _([)* " ^ _ 2&)*f q zVcT5&6 @[ ^"^ _ 2&h_( _()*Y"Z( CyVD ([)* nn ? {V0^ ^"h}V I^ C^"h}V IC( {V^ ^"( {V(@[)* + ,,, +\,Ok qh {U\ ^  # zUcj {U%\ ^h ^  _h"" zUci{Vd ^h ^i _h _( )*? Oh {U\C ^ " I zUcC()*?hO }U\^ C" I zUcC()*VD C _  2&(VD C h"^ ,i &:()*( ^ @ 2&,c O &)*O :(c ^ h " ^i  }U\^ " _  zUc()*c O }U\^ " zUc()*O :(c ^ ! ^i  }U\^ ! _  zUc()*c O }U\^ ! zUc()* Oo }U   Oo}V5'8%%a()*   Oo }V5(8%% n }U\ _  zUc()*O %Oh _( ^(O :(h _()*: ^h  }U\^ Q zUc()*:(c ! ^i  }U\! _  zUc(+ + + +j +. + + + +s +4 +" ,%+ + +o6)? +l  +O   + + #%'>9*TO)*V D 2&()*V D C @ 2&(VD C 2! 8%&c()*VD C ! 2" @(c()*VD C " 2# @(c()*V D C ! 2&c()*VD C "2'c()*VD C "2'()*VD C 2# &()* VVD C DC "  2# @( Uc(5+8%%)* VVD C DC " 2' Uc(5,8%%)* VVD C DC    # 2$U(5-8%%)* VV!D C DC    2   ' U(5.8%%)*VD C !V 2&(d()*VD C !U 2&(c()* VVD C DC "V 2' ( Ud(5/8%%)* VVD C DC "U 2' ( Uc(508%%)*VD C ^hyU 2&(c()*VD C yU 2&(c()*VD C D C ^(2&5?[)*VD C D C yV(2&5?[)*VD C C ^hyU2&(c()*VD C C yU2&(c()*VD C C ^(2" @(c()*VD C C yV(2" @(c()*VD C !V( 2&5?[VD C D C 2! D C @ @@(51()* VVD C DC 2" @@(Uc(528%%)* V0V)D C DC "  2# @( 2# @(  ( ()*(V D 2&536 @[)* V/V&D C DC "  @ 2'  @2'  & &)* V/V&D C DC "  @ 2'  @2'  & &)* VD VD VwC CC "5 " c @ @ @(  " c @ @ @( c @ @ @(  " c @ @ @(  " c @ @ @( c @ @ @( T-T)V&D VC C " c @ @(c @ @( i x o " 3" 3"h ')* VD V{D VrC CC "3 " c @ @ @(  " c @ @ @( c @ @ @(  " c @ @ @(  " c @ @ @( c @ @ @( T,T(V%D VC C " c @ @(c @ @( i x o " 1" 1"h ')*,, ,<! ( & )*VD C !V  @2' @2'! !@()*,hh ')*VD C !V  @2& 2&%,c %)* VVD C DC "@2' U(548%%)*, h ')* h')*VD C !@2&()*,h &)* h'c &)*VD C ( 2&558%%)*568%%, &VD (578%%VC (588%%h&,+ + + +8% ,+ , ,,+h +W ,,+* , ,,-+ ,U,},,,,,,,X,p,,,,,,,*+ +Z ,5,T,|,&,+    !#%')+-/24379>@C>AHHLNMQSUW>+/99T)* o(az ((AZ  (('.\&*W&&&&&&&&&&5:(5;(5<(5=(5>(5?(]V d] h S(l]l\h Sgd ql0ni Sg l qrl0nj Sg rl0nk S(5@8%%(+ +v +R +. +# >9AT)* ~V5?[ RyV(  2$)*5?[ RyV(  2')* ^()*] ~V5B8%%Y #cdZ(6 CyVc([)*h ')*]  }V5C8%%Y      cdZ(6 CyVc([)*] ~V5D8%% ')* ] ')*]  }V5E8%% $)*h ] $8A&8A&)*](!h R !h S(8A&8A&)*] (]h  }U\R! S zUc(c?h ] }U?\R  "!\T  T ]VdTgTe Cn I zUc] CyV(C]h Ic ] }U\R  :  8g\CSCSTToTgTc" W#4ETKg\CSgbCST4g\CSgtCST#g\CSgnCSTg\CSgrCSTTF ]VCST7l\CSgd ql0nCSg l qrl0nCSg rl0nCS zUc(]h? T\ C{V C R!Uc? T\C C~V CR!UcC  CyV(C C~VC Co C'5F(  TTTc(d(]Cha]CnI]Cha]CnI(]CnI()*V?D Ch?h? +89 "C]p Cn] ]h ha]?  +89 "(5G()*c ] }U\R " zUc()*c ] }U\R ! zUc()* ]o }U  ]o}V5H8%%a()*  ]o }V5I8%% `()*  ]o }V5J8%%] h a(] ] h ha()*] h `(+ + + + +T +/ + + +b + + +j +^ +S +5 +) + ,+ + ,'+ ++x +k+: +-      #%$(*,.0>9KT!?[V +?&c&)* ^c(c] D Ch] E D C iv lqph? +lllllllllllllllllllll6L? +6M    "$&(*,.0449997?A>!#9NT)* _(]U()*  ]o }V5O8%% ^W n ]o }V5P8%% ^V()* "n()*  ]o }V5Q8%% ^W()*  ]o }V5R8%%a(+l + + +q  +c +T>9ST/)* 8S" n 8S"@(c ^()* _()* ^(+ + + +lllllllllll lll   "$>9TT5)* ^k(6U^l(5V ^c(5W ^V(][(5X ^](5Y ^\(5Z6[6\ + + +6]6^ + + +   >  9_T5)* ^(6`^(5a ^x(5b ^V(]p(5c ^r(5d ^q(5e6f6g + + +6h6i + + +   >  9jT5)* ^(6k^(5l ^(5m ^V(](5n ^(5o ^(5p6q6r + + +8N 6s^6t ^ + + +   >  9uTcc Mc LG h E D C> M c K(G F F D C> M (G (G (G F(G F()* Gn D^()*  D^?(c()* D^()* o ] h Da?(c()* o ] h Da(G Go ] h GDa(d M( :ihhhhh ]6v 8%" +> ()*h 8%>$+% :hhhhhhhl]l] "> ()*] " TdMcD] En}VD] GEon|VGEoh D G D8K TB7ND]jp8%" GEon}V5w8%!]  G Eoh G D8K JG FnLGoMcMGoMEoKG h O }U\ ^ h|V o _ zUcE Dh 8K EnK()* _ h|VG M G GFn E D C>M ()* _ h|VG M G GFn E D C>M (5x + + +6y + +w +G +& + + + + + + + + + +t +R     $>9zT7! G G# G GG"G GGG G G G G GGGGGGGFGGG>()*V)E D C C" (  2"' 2" ' dh h>()*VE D C 2"'%)*VE D C 2" '%)* VKVBF E D CFEDC}V   2# '}V 2#'   '&&VC V2%D (5?[VE D V2%(5?[VC V E D 2!'E (5{8%%)*VGE D C C" i A(2" E D C# A( 2" E D C   #A( 5|()*VE D C C" hyU T2&(c()*V+E D C C"  &  2"' 2" ' c()* V_VXF E D CFEDC~V  & " E C 2" 2"' & " E C 2"  2"' ( ()* V8V2 E DC " D C  E 2" 2"'E 2" 2"&c(c()* V8V1 E DC " D C  E 2" 2"&E 2" 2"' (c()*VE D C A 2&()* V*V$E D CEDC C" ( ""2& d(Vg(c()* VTVN E D CEDC C"  2"V2&( hh>2"V2&( hh>2"V 2&( c(d()*VE D C 2"!2&c()*VE D C 2# " 2' ()*VE D C !V 2"V2&(d()*VE D C !U 2"U2&(c()*VE D C 2" 2" !V ' & c()*V9E D C 2" D C2" D C !V"  #@( # "@( 5}(VE C 2! 2!n(c()*VE D C 2" @2&(h&)* "hy()*c "h "&Vc(d()* VV !!' ( ()* VV !!' ( (dh h>()*VF Tc VF Tc  }VDV:E DC ! !~V # ' VE DC  # #'5~8%% 58%% }VFV<EDC ! !~V    #' VE D C#   #'58%% 58%% ~VT>()*VF Tc VF Tc ~VT>(VF (c(+ + + ,#+ ,Q,d ,t,,,  + +~,c +h,;,Y , ,,,\,m +" +,,, ,",?,X,w,,+    "$&(*,.02468:<>@BDF>$(%+ +?9TK! G G G GG#G G G"G  G G G G GGGGGG EGGGG>()*VAG FEDC C"   >(   2#$ 2#$ dh h>()*V!F E DC C" (T2& 5?[)*VF D C C" hyU T2&(c(VC V2%E D @(5?[VF E D V2% @(5?[VC VF E D 2!$ F (58%%)*V2F E DC C"  &  2"$ 2"$ c()*VF E DC 2" "2&c()*V"G F EDC 2" !2" >( c()*V$G F EDC 2" "2" >( c()*VF E DC 2# #2' ()*VF E DC "V 2"V2&(d()*VF E DC "U 2"U2&(c()*VF EDC   2#$  &)*VF EDC 2# $  &)* VlVbG F E DCGFE D C }V  2  $ }V   2 $$' ' )*VZF E DC C" ? A(2" E D C       A( 2" E D C      A( 5()* V@G F EDC !~V) " E D C  2# ?# 2#$TUc(V-F E D C " E D C  2#? #2#$56 @[)*V%F E DC 2"2""V $ & c()*VLF E DC 2" D C2" D C "V"      @(       "@( 5()*VF E D C> 2&(VF C 2! 2!n(c()*VF E DC 2"@@2&(h&)* V4V.F E D CFEDC C"hyV "V ""2&( c(Vc(d()*,c"h" &)* V<V6F E D CFEDC C" (  " (  ""2&d(Vg(c()*,c"h" &)*V C $  &)* VV! D C! $  ( ()* VV! D C! $  ( (Vc(d()*V G TcV G Tc  }VcVYF EDC ! !~V       $V*FEDC          $58%% 58%% }VdVZFEDC !!~V   $V*F E D C          $58%% 58%% ~VT>()*dh h>()*!! ~VT>(VG (c(+ + + +h + ,,L,q,,,  +^  ,, ,%,K,s,,,, , + + ,] ,,5,\,+  +: ,,+    "$&(*,.02468:<>@BDF>$(%+ +?9T ]8T yVc ^ (7T zV(% ]8T yVc ^ (7T zV(%c ^ h _ c ! h_ 7T ^([c ^ h _ Yc! h_ 7T^Z( +h_ [?[5? + + + + +a  >9T)*W0PD C 2" W 56 @[2&D C @ @(C ] CT 8!T 2&C C VC V ChI @(c( D! V C @(5 Ic(C E F~V!Ec(F DR F L @((D W 4Wpc(C ?(D C" W 56 @[c(C "?(C ] CT 8!T "2%C C VC (C D! ? I(C E F~V!Ec "c(F DR?(D W999)D C I &C C V CIc I(TC C IF L(! V2%c()* c DhA(! V!C ! 2" E D C  @ @A(c DhA()*58%!C8%!58%!D 3"58%!c8%%)*W +JQX58%%D C68%! !58%! 2"58%%D C68%! 2"58%! 2"58%%58%%58%%58%%C(c!D(+??h@(ch!@(+??h@(Dh!@()* +??h@(Dh!D@()* +??h@(c @h@()*D @h@()*D D@h@(chl] >?h@(] {V ^?(c(+%)* @(c +89#h@(h@?h@(! VC!!cc2%c()* ,c %! V?[c(! V C !(?[)* " E D C CoI"(D]hDC8%>  Kc L()*i _ (5?6? + + ,C ,,z ,+  + +m+Z +3 + + + + + + + + +g6 +L ,     +(  ,.>9T)* {Vh^ $2 \g\""l 2&\ " 2& 2&\"l 2& # D C !"l 2& l\yV&()*] ,scl &)* ~V5?[ ^ ({ "  o8K#@(  h!   o 8K#@()* ~V(^ _: TeTd0`T[{SS@ W@@@@DDDD@@@@@DD@@DDDD@DDDD@D@@DDD@@@DDDD@@@@@DD@@DDDD@DDDD@D@@DDDT T`( 2&)*,j] &)* ~V5?[ ^yV   2' ^yV(  2'  2')* ,] ' ({56 @[g}(g)()*Dh C 8%/$)*h}U7N }V58%!E Dn}V " DC8%?  Dn J()*Dh C $)*] Dn E }V "DCh 8K  J()*h}U h}U ]o }V58%! Dn E }V "DC  8K  J()*D E ~Vd " C_ J()*E ? T\Cjp ICDn}Uc7N C}V7NDn|V7N IT58%!C] Dhh C8K ICK(c JF IC] K(c J(D()*D ~V58%% C^()* Do }U  ]o}V58%%C8K$ )*   Do }V58%%] hC8K (Dh C8K'dT8N }V7NT ] h >(+ + + +e +F += +4 +! + + +c +7 +&+ + + + +T +n  +O   !>9T ( +&c(! +8 8i$)*! %8! 8!(]jp 8%c( +&(c()* +8 8+h$8%&8%&c( +&c(+(+%()*8%+8%.8%-+h$)* ~V%R %" 2&0 4443 $ )*" 1&)* V h " "T " 4&)*V c !  "T ! 4&)*  ! 4&&)* !D" 4+ $)*] 2, ;sc & )* ! ,cC! " & )* $)* 3+  ')* "  @"$)*R  T;W"T"T2 +  ' 3$ 2$ )* R |W||q%q% &6'6' "8%!T       "  "'  '  "  "E! h"  "$  '  "  "'  '  i8K"' " sT5 8K !8%"68%"yVT      "  "' " c i8K"T5 8A!8%"68%"  "' "      ^Z  "'  "     ^  "'  " 8%! "'  R  T+W!!%%%%%%%%%%%!%%%%!%%%%%!%%%%%!%%!T,"    ln ^Z  "'   TCW!"     ^lTT"     ^TT"     ^   "' "  # { ! "'  "' )* "^()* +           , Jh')* ^ ]H (% ~V 58%&^   TT 7TT2%(] ,c %)*VC (()*V(E%)*R 0:*  l pn2&$58%% F!?&h&)* R  h&,  &)*cl^ h _i _j _k _l _l _& )*cl^ h _i _j _k _l _&)*cl^ h _i _j _k _&)*ck^ h _i _j _&)*cj^ h _i _&ci^ h _& @&)* o_()* ~Vc^ +"& 2+()*!  ,ch &W !(/: & +( +q( +O( +'( +( +()*VD C V "2& &c()*,h &! C()*()*l)zVl}zV "()*aeTd lryVEKV DnJ(CnI(chhA + + + #()*V 58 "Tg%8" &)*8"(] 8! + + #8%)* }V%R : _Ci2& 8 W"-----------TTgi # 2&T  3& 2& 2& {V ^ "2%()* }V%R ~W~~EE #3% #  # ,5 !2& '(gs 'gc 'gi 'gf 'gB ' '  }V gi'^  T+W!!%%%%%%%%%%%!%%%%!%%%%%!%%%%%!%%!T gi' gi #& ' {V^% h4"2%2%()*] ,gc !c(' ~V%^ %2%3% ~V%^   TW TTT TT1% " 1% yV(')*(g)Tg} 2,e %)*] , & )*  F(gg ] _()*  Nn(gu ] _()* |V<R * 8"2&VD C 8%!8 "! 2& 56 @[(R 0 :2%$((R  (, %)*+  ! o 8!l% 8" ,c89! "8% )*! D C]hl $ )* yV( |V 8K' 8K" V h  8K T  o  8K ()*] ~Vh@(R 1:  ]o8K#]Y@(-i2& 2&,Ydh"Z(6 CyVgsh'[5 G!8%"68%"8%%)* G!')*5 8%"68%" 8%!8%"68%" i8K"8%"68%"8%%]h ')* 8K'%)* n%(8%!68%"8%%+ +i ! + + +  > +n +\ +A + + +t +> + +w +`  +   + +b : + + + +?+(+ + + +a  !+  +& +:+, + + ++ + + + +  + +t % > @ D C G G E C>@   > '9TL)*VD C D C ^V( 2& 5?[ ~V(^ 2%(] ,Y g 8K "!Z(6 CyV([! h89# !89 &)*D C E6 ^VkW E  E !l ] oo8K" h8K# ]o 8K# 8%" 8%"A( E !l o8K" 8%"68%"A(()*E D C W  ! ]n8%&]8%&)*Y   8Nh Z( CyVD 68"e8%L% CyVD 68"c8%L%[W cjqI9Ch %CC{VBC^ Y 8%!!ZT(6 CyVD6 ^VT5 A@[T[(TCi I(Ch I(CC{VC^ !(TCC{VC^ I(TCC{V@C^ Y ]Y!ZT(6 CyVD6 ^VT5 A@[T[(T^CC{V@C^ Y ]YIZT(6 CyVD6 ^VT5 A@[T[(TCC{V@C^ Y ]!ZT(6 CyVD6 ^VT5 A@[T[(TCC{V@C^ Y ]IZT(6 CyVD6 ^VT5 A@[T[(TtC 289 &D CC{V;C^ 89"VC^ !( 666 68%" A@[T C T\C^ !C{Uc(?@[ {V  ^T5 W+FZC6 ^V5 ^V 68 TcTcTDE D C  68 T)C  68 TC  68 T#5 ^U5 ^V 8!@[8!@[)*VC T Ol8! C    + ,T\C^ ]ic ^-bY  "ZT6 CyV? !T[ Y  , !ZT% CyV D ?!T CyV D !T[T"Y!ZT CyV D ?!T[C{Udc( )* "68&)*g8! #8%)*6 8#! !89 &Y 6"ccZT6 CyVc6?6A@T[ Y 6"ccZT6 CyVc6?6A@T[ 8%" 8%&5@[)*E D C ]h{V7W   68$ C  666  68$ ()*8%" 8%&)*VDC 8%"+89#8%&5(5?6?6? ,+ +p +e + + + +h?    +  + ,+S +  +     >9T])*O ~V5( 2" "68'](](C @I(c] V?Cl8!h O }U$\5 ^^V^ "68# zUc8%5(c] V3Ch O }U$\5 ^^V ^ "68# zUc(5 8&)*W C TC T V 5T5T 5T5 WGFED 68$68&)*Y!Z(8%8%+!!68"e8%L%)*Y!Z( !68"7%8%+![VD C Y!ZTh VC (2%5CyV5(5CyV5(5CyVD E D C6 8$ 5 CyVD E D C6 8$ 5 CyVD E D C6 8$ hh ^ ^ ! 8%&,ZC %O e "i "68'W 5(5(d "68&)* ^ ]U 68&7T ]yV 68&7T ]yV8%%5(c?6 + , + +v + + +: + + + + +   > 9T#^!l ^!vn(Aa g&ga o (GgA o ( Tg0 o(56@[]l zV5 6@[+ +l]hl }U\jp!8A! _ zUc(g ]hl }U%\ejph ^6 8"8K  zUc(g]  gh8%? ()*gh 8%/$8%:!l ^ 8%F!()*  ]o }V5 8%% _(]h _(7K + + + + + +Q +   >9 TD&G%c]%?E&E&G%G&G &G &G &G&G%)*! r l?o o}V 2&()*!]gli !s]g^d ^b ^`6 8_^]^\ ^]^V2&()*!]|l !]|^yl<l!s]|^y ^w ^w ^u68j^r^q ^r^V2& (d !shy()* !^&(5 !]! !]! ^'^$^'()*] "]()*] "]()*5 ^V58%% &)*5 ^V58%% &)*?58%% &g7 Dr JD C^ll ws ul7 Dr C^nl? s DC_(c! "(c]%c! "(gk ^vlj ^vli^vh^nnn()*8%! 8%"8 %)*+ + Oc?T Ohl6 }U\ C_ zUc5?h l78%"l6n }U5\g7 r r ^C "Ig?C !  C^us  C_ zUccJ()*g7hChC8* D J(chl7^@(+ + +P + + + + ,+ ,+,+d8u +MT+:+ + +    >h6]@ +7 ++ + ++++ + + +  +  + GGG G G GGGGF>    > 9Tl)* ~V(7Nj p}V(j p2&)*VE D C ^(2&5?[)*V E 2&()* `S(6&)*D%C + @! C D E FGGGGG G  G  G  G  +     > ()*VE D C C"V(2&5?[VE C C"U2%(c()*, " D^ %VE D C C"VA(2! A(5?[)* , " D^ Y ! D_Z(6 CyV"A D_CIdDOvC}V& ([VE D C C"V 2! @(2%c()*, " D^ %)* " D^ VIE D C C"V(V1E DC  C"V( VE DC  C"V(  &5?[5?[5?[V E D C C"V CI(2! A(c()* , " D^ ! D_()* " D^A D_C Id DOv C}V&()*DO ED"s( + + +," +  + +} +>   > (h" ^ _()*h" 8%&Dh+8*#h ^ D +8* " DOC>()*VE D C # 2&()*,D?h O }U\C ^" I zUcC(VE D C "2%c()*,Dh O }U\ ^! zUc(VE C ^hyU2%(c()*, " D^ %VE D C ^A(2! A(5?[)* , " D^ Y ! D_Z(6 CyV"A D_CIdDOvC}V& ([VE D C ^ 2! @(2%c()*, " D^ %)* " D^ VIE D C ^(V1E DC  ^( VE DC  ^(  &5?[5?[5?[V E D C ^ CI(2! A(c()* , " D^ ! D_()* " D^A D_C Id DOv C}V&()*ODO Eldl `Ss(DO ldl _Tr(VE D C 2!" ^ A _(c()*D Oj p8N {V,c ^ J,c }U\^ ! zUc(C( E D8*! CA(c DO }U\c D_ zUcc I()*VC TC l" V" ] CT 8!T8 F!Tc h ^hA(c8 D%dI()* ldl `S()*h `S(hldl `S(+ + + Y5]ZT&6 CyVY5]ZT6 CyV5T[T[lR 8K" ? + +? ,B +6 + + + + +f +4 + ,8++t++ + +: ,9+ +n +K +/ !#%>9T2G! C E D h}V GG G o{XV G!c T#G nM 2%()*h{VP h G'gPh G# 2&(c &+ &%)* +h'( +&%"%g8! + +i'&&c( +&c( +&)*%)* +G%()* +h')*?I! &)*. ~V1-%/^ %&@ 3! 2&. ~V/&&/^ AY^- TW 14' Tc1"2&[ W 14' Tc1"2&  W!!....2......6.C............PZ..k2c1!"2&TTTWc1""2&c1"2&14' 022+ 4 ' c1"2&c1"2&/&&3!2&0 44430/$F$ )*2! 1&)*'V h "0!T- " 4&)*%V c !.!T+ ! 4&)*c)" 4&&)* 4+"&)*&)*&)*&)*&)* #' ~V&^ 0: T.-T( yVcT oC!E# #  '2%)*" ~V#&#^ R% #", %#+n#+_#+P#+A#+2   $#F$   2' ~V!&!^ >!&(2% ~Vl@(^ bxhvl@(i@( ~Vh@(^ ovh@(j@( ~V 6'^ v i8K"68%"' k@(l@()*6')*6 ')*%)*Vc !Tc +"  @@$)*Vh "T " @@$ )* @@$)*~V oC!E#" '^ %&> 2$  oC!E#" 'oC!E# 2+ 2+h 2+<+%+  F$ )*, V h$)*3! ')* #! &)* ~V c  " 4&^ < c  " 4&444 ,4' )* #! &)* ~V gh # 4&^ < gh # 4&4! D C 44+ 4' )*"! &)* ~V 5! " 4&^ < 5" " 4&44+ 4'C VC #cI(&C VC i8K" #cI(&)*!h? + +        , O[v,`DchC!&)*] 2     +d G&)*      ,()*V @89!6#8K&()*g8! ! " &)*c "%8! 8!()*Y]YZT6 CyV "T[ ()* 6$#8%%)* 6%')* #8%%)*] {V  ^6&8"T g.6'8" F! 6(8$c"8!8!(c(+ 8 !&8%+%+ 8%/!&c(c()* + +  ! M! M()*c!h6)l# " i@@ hh    6*8%iiiihlNlNl lNhhhh>(c(5+ 8%"6,8%&5- 8%"6.8%&8%+%)*8%/! M+ M! M! M()*dh6/ G')*G G G G>()* # M M()*G G@()* M M()*G()*i|V0! MG G|VGTdj Gq GGo8%"8%" &()*G()* Go &)*i|V! MG Go M%( {V(()*G()* M()*G G y()*G()*i{V M()*G G {V chh# &()*ch ')*G G {V @ G m# i '()*G i{VG G {Vcjh# "G  M ()*G  M G G {Vch???h# &()*ch ')*ci ')*G G {V @ G m# i '()*G G {V clh# &()*G G {V ckh# &()*c "c G%)*d "c G%)*g ')*f ')*e ')*d ')*ch ')*d] h _i ')*8%! &)*8%! &)*8%! &)* ] ')* ')*G G {V '()*T\c "G c M !V!%!!c Jc Kc Lc Mc M c M G M%)*F E DC MMMM()*G G G G>()* " &)*G()*G()* M()* M()*GV clhA "GVF VD C G!L(c()*GV F @ L G!GV c ?hA &()*G i{V"G G {VcihA "d "c "G  M (fh ')*G  M G G {Vc @ G m# h 'G G yVG &()* "Vd "C G @@ I()*C VRC D C CD D G {V% W1111111 11 XV  G nI I(  V  G nI I( c( c( I()*] ')* ?# &)* A()* "%Y!Z( CyVc([)*VD C ^V( 2&5?[)*VD C ^V @( 2" @(c @()*W ,;J]q E VC C ,CGGo " I(c(D VD J(c(E VD K(c(D V C D &%G Go G zV%(G VD C G! "M(c(C Go M "c M (D C D VtC D C W /d& ' ' G}V' & G V& G}V'  GonG }V' & & c(D C G Go E VPC C ,C V"C Y C "ZT6 CyVT[T o  n & G n 'c(D C G Go G }V!Go G}VTgTdD @@J(C E @ K(C G! "G @ M(G! C E G oM GnM(D V!C D CG }V c(&c(%)* Go M &)*h ')*!d M  Gon G8%" M G Go MG &)* G%c G%)*]h G'd M d M G%)*E G n M G &D VC C D JhyVcI(?[D VC C (?[)*c @? C V C I J(IJ(c Ic J(ch@(g]+ + +60? + + +t+al ʚ; +O +D +8 + + + + +   +  ,p+? +/ +! + +h61l#h l@@ + + +a +# + +++ +{ +n +b +V +E +- +  "+  !$++ + +y +i +Y +I+4+&++ ++ + +"$+#%+%+f +Y +L')+(*+#*+ ++-+ + + +p +c +W>+D  + + + + + + + + +j +Zl lP8K" ,^ +( + + + DH\_+  +v +] +Hl8!8% !8%! ! 9+ 1!1!1!1!1!I! I! I! ?! ?! ?!?!>!@!6!5!7!;!=!?!=!:!:!:!9!;!1!1!5! 5!!>!">!#>!$>!%>!&1!'9!(9!)9!*9!+c!,e!-k!.j!/l!0k!1k!8 C8 D + + + + + + p+ >+k +O   giknpry~+ +y +d +P +@ C+1 C+& H+ +I+ }+ 38%M!     cegicrtvxzsusu]_acegi`ccfcrt}>p92T!)*G! yVF%  F!g 2& &)*(G! G!V(:_ G" 2&0 G# 2&(G! G!XV.  TT TTc(F!2%((+6364 8%"658%"'()*+ !'] 8!l" 8"c  }U%\^ l"yVg\8"8" zUcg" 8"8%)* G!&)* 8%"c! "U &%D&G!%G!% &)* ')* " &)*0 }V @(/R %)" 2' 3')(! 2')*. }V @(-^ _  h3$ i3$ }V%^  h@( !4" D C ?@(^ .h@(h3" D C ?@()* }V @(R   @(! l pn 2&)*,+ ,p,}V@( ! D C ! D C   3$)*V'T& !!)^ |"W||mm!I#G!U56%    4'    4' # # #! " 4' # !" " 4'# " #! " 4' )" D C 3! D C  #    #! "4'%}V576 @[#$^!   " 4' 3! D C# # #! " 4'# "   4' #G!   " 4'  #  # " " 4'# # #! " 4'# " #! " 4' * }V# !" " 4')^  T+W!!%%%%%%%%%%%!%%%%!%%%%%!%%%%%!%%!T#!"  " 4' #    T3W#" "4'T#" "4'# " " 4'  )  D  o C!)E##"#!  "U  &{  "4'c"(  D C 4'C(c  ) '# " #! " 4'# " #! " 4'( }V c @('^ @ c @(( }V c @('^ % c @ @(( }V c@('^ % @ c@(c @ @(] 2%$#"!      ,(=(()*(!%)* %c %)*O + + + +   !      ,%,G !Yc+wh DZT" CyU5 CyU 5 CyU[ "" % )* A]')* @]')* ?]' :' @&')* o_()* ~Vc^ +"+( 2+()*C! E ,ch &W  +( +}( +h( +R()*VD C V "2& &c()*,h &)* CyVD T5 CyVD T[ G ! 688#%)* TW G %TG %G %)*( G! G!V( yV G# 2&()*(  G!  G!V( yU yV  G# 2'()*(  G!  G!V( yU  yU yV  G#2$ ()*(G!G!V( zVG# 2&()*(G!G!V( zV zVG# 2'()*(G!G!V( zV zV zVG#2$ ()*(G!G!V( ! G# 2&(d(c()*,x!SWcC ] JW( +"TC h ^ "T8 i ^h^ #T)d ^-j^i^h^ T    ""T`C ] HW& +n"TA h ^"T7 i ^h^#T)d ^-j^i^h^ T    ""T  "( )*Y8"8"Z(6 CyV  " #([)*Y 8"ZT6 CyVfh8" 8#T[ 8' zV zV  zVd(c( zV  zVd(c( zVd(c(d( yU  yU yVd(c( yU yVd(c( yVd(c(c()*WTC ]  i'W "+(c ^ +(c ^i ^ +(c ^i ^j^ -i' +v(C ]  h'W "+X(c ^ +C(c ^i ^ +$(c ^i ^j^ -h' +(&! ')* " +89 "+()* |VY^ -AV>^ }V h2' ^ }U\ # zUch2' ^#i 2'()*!! ] ,ch #(d 8%!s()* &cTg8%! l 8K&)*g sk w ^ &)*g sk w ^ #8%! _()*d ws()*iv8%! s vt( ~V%^ %]8"2%8! @( ~V%^ % @ '8"2% ~V%^ ^! D C ? @( ! D C ? @( ~V%^ ]%8"%)*] 8! ,; + , %)*59%G! ft 6:8"!TgTg 8%"h'  G! "l" &  G"3%  " "\  G#2% G"3% G& "   "1% G"3% G"4% " g  G#4% G"3% " 4% G"2%)*,B_% G! 'l'& G"3% " \  G#3% G""3% " 'l'& G&)*, %E!   % (E!   TT T % ()* " (u:N TnW!!!!!!!!!!!!!!!!!!!!!!!%TOTF+h !h ! "G' 0( +U h !h ! #G' " ' %! G')*%G! G!V%()*! !lpn   6;8#%8%%la ~V(gA ~V(g0 o()*! !l p !ldpnn  6<8 %8%%g0 o(n"u& W  g (Tg (g (bg(()*G! G'(G!G!V(1  TT TT G#2%( 89"V G& G#2%)* , %)* " c%G!G!Vc%  & T&TG# 8%" " o o & c%)* "  @(G!G!V @(.  "@( G# 8%" " o o  "@()* " &)*(G! G!V(Ee( G#&)*(G! G!V( ( G#&)* TIW!!%%%%%%%%%)%.%%%%4%%%%%:%%%%%?%%!T(T & & & & &5=6 @[ &)* " &)*G! 0 & G# (G!G!V(cox"T% G#&Xb  G#& & G#&)* " &)*G!  TW G'T G'(  TT Tc(d( c(d( c(d((G!G!V( !V G# 2%_( G" 2%)* ,5>%G! !V G# %6?8"%)*5@%G!   6A8"%G# &)* "]()* "]m()* "](G !]()* "]Y()* TOW!!%%%%%%%%%)%6%%%%6%%%%%:%%%%%6%%!T5T#G !6B8%"TTG !6C8%"TT5D6 @[G !T G !6E8%" ] c ^+(i 8K'G !6F ^V5G ^V 6H8"%d(c(c G !^()*hzVG!XV.G! 89"VF%i8K!89 "6I8K" 6J8#%()*E! E!^()* "%)* 6K8')* "%)* 6L8'5M%F!6N8"8%%)*F!6O8 8%%VC (7%(VC (7%(6P8"%6Q8"%6R8"%@[G Wc(D 8%F%C 8%F%)*Y C89 "Z(6 CyV ? #C @@I([5S ^V 8%:! @&(5T ^V 8%9! @&(CC{VC^(CV5?[ h8%> IC dI%dIc^()*C ]h?h?h?   + & 5?[8%F!5?[C~V5?[C^(c? ] + h&)*8! hhhhh> ()* G8" &)* &)*!(G(G 8! 8!G M(c K(G8%G(EVF(F(G W 5U(5V(C (5W(Fhy(C(!cC(! CV5?[(EVD(%Y&cG! JdKFLl yV GMZ(6 CyV Jc Kd I([g + + + + + +} +^ +L +C +7 +. + + + + +l + +i !l? +} +t +L !8%8%6X@# + + h?  + ! +Y    #%((!&('&$&%35-8!>#6Y? + + + + + +8 C8 D + + + +{  +k +[ +K+8 ,++G ++ + + + ++, + +T + ! + ! + !&+ +}  -+ +  +,+O-++ 1+  &3+D0+11+ + +{ 3+E +# 5+249+6Z !6[ !  ;?+& />+ 0?+P :=@+Z35++ +c +U +4 + + + + + +C +lh8" + + :N+M+N,MOQ+ + I+i %(*,.3CEGIKNPRUWY_aceginpr+! +w +j +_ W+Q X+C Y+7EJL+ [+ + ++|    fhDiGjGkGlGmGnGoGpGqGrGsGtC> > _9\Tw8 ! V]C | 9! T W  TT T:TA WAAAAAAAAAAEEAEEAAAAAAAAAAAAEAAAAAEIMIIIIaAIIAAIIAIIIIITTT8 !h!4!??(8 !Y 4!ZT8 CyV 5]8@[[8 ! VC 'T 8 !??(5^8@[8 !4%8 !4%TLT}* 8 !!!?(8 !2%8 !h!!3% 8 !h!!4% 8 !h!!4%c(8 ! VOC [   aT,T6T T*0 T T'T8 ! !2%c!!?(8 ! VvC ^   TaTOTUTCA \;TE!/ W $ $$$ $ $ $$$$$$$$$$ $ T TT8 ! !2%c!!?(8 ! V%C  T8 !h!g-!!3%h!g-!1%8 ! VLC : E2e.T:.08 ! !2%T 8 !l.!3%8 !lE!4%c!]Y??(8 ! V;C   T'8 ! !2% 8 !lE!3%c!]??(8 ! VC + -T8 ! !3%3%8 ! VC  T8 ! !2%c!]??(8 ! VNC ">\8 ! !2%8 !Y4!ZT8 CyV 5_8@[[ !2%8 !c%7?[8 ! V.C \ 8 !(8 !Y3!Z(8 CyV 5`8@[[7?[8 ! VC :5 TW8 !g (Tx8 !g (8 !g (0b8 !8 ! VMC  T@8 !8 ! V+C  T8 !l pld pnn8A% 5a8@[5b8@[ 8 !(7?[8 ! VC *T8 ! 3!4%g( !?(8 ! V4C  TW 8 !3%T 8 !4%8 !2%7?[8 ! VC * 8 !1%8 ! 1!1%7?[8 ! V&C )* 8 !4%8 !2%8 !c(7?[%+8%i8K" Y 8"Z(6 CyV6c8%"8@[[Y 8"Z(6 CyV?([? 8'gh8" +89 "+ + ,M6pEt *T+x(ChC8K#I(C]C~VCjp]  ChhC8K ICC_(IcI(g ] ?h? + + + +d ?9dT# Yll@k@i@8%*#@Z(6 CyV [2%[)*VC T5e VC TC ,c %# Yg6f_]Z(6 CyV [2%[)*VC TC ,c %C(I()*g ] CT 8!T8 F!s  6g8  &c8 D%"V5h8%%^. h8K'2%,] %)*] ]o 5i8%%h 8K')*]  "V 8%&8%" 8%&! D '! D C # 8%&!V]j 8K#jh 8K#@(6j@([ T TAc(d(+ ]j|Vc ^ !Vd ^l:y( yV g"8&^ "\8"2%h3&h3&)* yV g"8"3%^ "\3!1% 2&jp3!g"8"1%d }U\g\8" zUc(] 8!l" 8" ,Uc !8%)*] ]~V] ] ]o 8K# 8K! 8K!^(!VO]j}U 5kjh 8K#^V;]j}U 5ljh 8K#^V']k}U 5mkh 8K#^V]k}U 5nkh 8K#^(]i}Uc ^l/zV]i}Uc ^l\zV]j}Ud ^l:z()* ^ l/yU l\yUl:y()*] ]~V ] ] ]o 8K#^(!V']j}U 5ojh 8K#^V]k}U 5pkh 8K#^(]i}Uc ^l/z()* ^l/y( dh8K'"V2%3%("V3%2% dh8K'"V2%h8K')* ,5q^V(] % dh8K'"V2% 3&)* h8K'"V o 8K' 2&)* ,5r^V(] %)*] 8!l' 8"c  }U$\^'  8 "T ^ 8" zUcg' 8"8%+ + +"6s6t6u + + +m +J Y5v]ZT6 CyV5wT[6x ! "  "   >  6y6z6{ + + +X +* Y5|]ZT6 CyV5}T[ + +6 +  +   +   >  6~66 FGGGG G" "   >  8N6 ^Ve5 ^V65 ^V56 @[G G GGGGG F E D C> TMG G GGGG G F E D C> T%G G GGGGGF E D C>  G G G GGGGFE D C + +j+W +&? + ? + + + +^>9T 82082j&+ ?9TY 8"Z(6 CyV! 8#([ggh8" +()* h8 # Y!]Z( ][!](G !8 !%cG !c%Y 8"Z(6 CyV! 8#([8&8%)* %)* %)* C8%" I( ] C(8%(&+6')*8 !!+ 6' h8%>  h{V h8%/ c2%()*8%E!l l wv 8N8%"l@8%" ] ,c %8%E! ]  h8%?  (+ 6')*VC Tc 8 !! V7%)T7%(! Y !8%6!Z( 8%6![)*VC Tc V7%:T7%9! Y !8%F!Z( 8%F![)*Y]Z(6 CyVVC (682i"8%%[VC (58%%8%&)*7 ^U5 ^V(58N^V ] ^\ ] ^/5 ^V( 8%&68%" 8%&5 ^Vc(8!68%" ](5 ^Vc(]( ^V7%?[(8 ! 8 ! ! W+C8 ^Vd(Y+8* "cZ(8% CyVd([c(8&8%](Y 8"Z(6 CyV +E" 8#([)* ^ ^yV2$ (d()*] ] Y9c ^# o{VcT h V?T   2#Z(6 CyVc([ ~Vc(2! R@(] ,c %CS(V C!]h? +G "(5(] ]h  }U\o^ _ zUc( yUo^ o^yV2%()*] ] |V ,c %( yU^ ^yV2%()*] ] |V ,c %( {V ^yV _2%()*] ! ,c !()* # VC n n"8%" "8%"2&()*] ] ,c &)* ]o ')*h ')* ]o ')*h 'c(^!V2%(  c(d(+ ,] ! yV(h')*6 82f')*VD C "V 2& @2&()* h""%)*! V C @(()*c +89')*XV582f""c()*5 82f"i +#6 82f&)*XV582f"D"c()*5 82f"i +#6 82f& 89'!%)* +'!V@[()*Y+"5?[ CyVD ([8! C D E FGGGGG G  G  G  G  G GGGGGGGGGG6?  + +^+H+'    !#%')+-/1357>(( +&c 82I"8!%)*g*8! 822! +82k')*VC 682f$5 82?&)*Y !?Z( ?(WC (C [Wc(C [5?6?6?6?6? + + + A + +r +W + ?69 C D E FGGGGG G  G  G  G  G GGGGGGGGGGGGGGGGGG G !G!"G"#G#$G$%G%&G&'G'(G()G)*G*+` +9,*+    "$&(*,.02468:<>@BDFHJLNPRTVXZ\>/06K C D E FGGGGG G  G  G  G  G GGGGGGGGG +++++++ ,,+v+. + + +i%+F ++    "$&(*,.02468:<>@BDFHJ>&' G G@ C!lgh8"  + + + A E D C +8N6 ^V+T+d +  + + + + +J +< + + + +t +i +^GG+!6  C D E FGGGGlgh8" +- +" +   >  + + + + +      .!#%',-2GG G!G "E#D>5G6G7G8G9G:G;G<G=G>G ?G @G AG BG CGDGEGFGGGHFIEJDKCLG%MG$NG#OG PGQGRG"SG!TGUGVGWGXGYGZG>&7G*8G)9G(:G';G&<G%=G$>G#?G"@G!AG BGCGDGEGFGGGHGIGJGKGLGMGNGOGPGQGRGSGTG UG VG WG XG YGZG[G\G]G^F_E`DaCbG.cG,dG+>.9;=@DACBEABDFHJ>%'9T8!V(Y ! 4!C?[Z(6 CyV?[[?[Y 1!cdZ( CyU  CyU[c(1!Vj@(% h8%>  h{V h8  n2%(,c !8%g ]l8! +E&G%G%G%G%G%E%D%F%G %G %C()*56 @[[+(56 @[c(8%=!8 D! 8#(Y 8"Z(6 CyV+ 8!68"&[68# 8! hzV 68"8%! h8')* +668' 8!V ]VcTdT7%< h8#66 @[@(d + +6?6?6?l h8" +\  ,;n +0 +%8%M + +   i> +? + + ++++++ + + +v     > 9Tr)*VC &()*VC &()* &)* &)*XV582f"82?"c()*5 82f"i +#6 82f& 89')* &5K G?8! C D E FGGGGG G  G  G  G  G GGGGGGGGGG ++ +f+B+5+ + >     "$&(*,.0246>9Tc()*VC Td C }V8%G V)+"F82f&D V C C 82f& 8%F82f&C 682f V5T56 82f$)*VC Tc + D"G VC     % VCj|V 6F82f' (Ci|V 6F82f' (G VC %c(CV cI682f'682f')*d? +8 &)*d M L MG in M V G in M  MG G 8" M %c8! E ^% G ^FVGV!c M%c()*V>D C D C 8"V 8A!_TG 8"V 8A!_Tg-_2&] }U\g- _ zUc(G G ,Gh &D C;W5T56 82f#8%6!cJ()*VC TgM GXV d M + D"G V C ?&c(D %)*+ D"G VC &E %)*VC %c()*cDhE6C C %)*VC TgMh8! CD ^% MA cE6 * G  G 5T5 G  ;W5T56  cD6$ cDhE6$ VC %c(c8! C D ^% K cE6 O ^']<] 8%!r ^ / G  GVT F G ! G G  6 cD6$ )*cT56 @[] |V 8%."5 o6$] o8%." o8%/$ )*] l< rl<l< qrl q 6$ )*VC T7% VC Tg]VC TgKVC T V  C Td V# C l68%*# 82/!6 82f" @?Tcy6cTMcF! 8 F!  nnnnn o8 !hhh8h6h8!8%>?h 82/! >(g- 8 F!8 G&58N^V Y58!8 D!]YZ(6 CyVgP([gP()*5 &)*5 &)*6 '7 + + + + >66lkl666k66666>66i +h  + +d +    + + ++ + + + +P + + +u +H  ++n   >"9T)*C V C 8&c(!8&)* !8'!8%l&)*5 8%K"68%K" &! ?8&CU78 !U Cc8 !Ugy6Tg] cC?hh?h8 ?I(C VC (8 %cC?hhh6h8$d(+ ? Ci?h?h? +? + + +o +X +M+@+. + +     > 9T8!Vc(8 !2!%)*8!8!h @ @6@&c8!h @6@6@&)*5 8"V5 8"V & 8&)*8!h @ @6@6@&8!XV%(8!h @6@&8!V%(()*c8!8 G"68 G"88 !U 58N^V' 7h8 8!  68#8%%c(ch+@@8?h8 ?h8  VC D 8!68#8%%c(c8!](!V(58N^V 68&8% ~Vd(^ [a{T_T;@ T+c(2%] hzV ,c %(+ + + +8 + + + ,1+ +p88 +O +/    > 9T)*W "+d(c(C 2!89&C 2!89&C 2"X(C %)*W c(C TC TC 2&C % 2!89 &)*W %/(C 2!89 "?(C 2!89 "?(C 2"?(C !?(,V,, A95? ?9Tc 3&)* 8z#  C! 2&W ,/259=@DHh63# C ??(l 8!4"??(c(d(e(g(g(f(g(1%g()*g 3$h6# D C @ ,2% ?"')*8z# C!2$ W #1FYxGG8z # ? "1'  1 ,c %h4"?? ? "1' h4"? ? "1' c  ?@ @@ @?  "1' c ? @@h@?  "1' c  ?@@h@?  "1' 58@[ ? " 1'  " 1'  " 1'G8z" 89"V@(6 "8@[)*g+ 3')*  8z#   C! 2'W ,8%g" 8" 1&G G8z # 8 " 1&G 8z" 6"8@[)*g0 3')* 8z#   C! 2'W-(6@(G 8z" G8z" @?@1&G 8z" @?@1&)* V(V( @(7 +6666  ,LR fp?9TF! ?I hG'W C ^(C C W0D C + C~Vc %Y F#Z(E CyVc %[C hG')* +8&?%c! V(WNNN N+2%c4!l! %c %d %C  " W C ?T C  !?T ?% !6 " @[c ! V 4%c4!h @ @?(!()*c ! V,$c @ @?4%c3!h @h@@?@?( !c @ @?(04%4!4%c! ^Vc(! !6#@[C VC ! !6#@[?I(C V ChI(8%)*8z!h? + + + , 6zc !l! &)*V0C6 6 h ? @@h@?h@ ?@h?@???@?(()*V&C WC 8"?(C 6  8"?@?((h?@?( yUn^ ^yV2%(A% |V A!V  o nA!U2%( yVd(n^"V2%(E D C   n|VcT5 6 @[C~V?[W 5GXhhy(C W!!!!!C Vd(,c %?[C iyV ^ &(D C 2,C +G # Y F8"ZT6 CyVCT[ F#F8#([)*VC Tc ] + ,cC & ! E ()* yV( yVTc! ^^@?? "!  2&" h"!h()*W '5Mc(Ch! 2" h "! h"! h"! (Ch! ? "%D Ch! 2" 2" h"! (Ch! 2+8 G "(C ]h! ,Bc &)* E"V( @()*VD C F" ^ +G # 2&(E D C ^ ^ @@ _(D C ^ F" _()*VCC A@I(C @@I(C(c?h?h? + + ,c ! "CC ^C +8 G "C ^ ,Ic }U\c @C" _ zUcc^ C +>8 G "g%h8" ^> A()* ^(D C ^V^()* +8&V,W  $5(5(5(5(5(5(5(5(5(5 C8l + + +82A @8C! G G @8! + + +[ >6?6?6? +M > +! + +   +h +  > 9Tc 3&)* O8z#   C! 2&W!G G 8z # 3! @ 1! @(c(5M@[gj^ M Gi G _g 3&)* K8z#   C! 2&WGh G ^ 8z # 1! @(c(5I@[gj^ M Gi G _g 3&)* G8z#   C! 2&WGh G ^ 8z # 1! @(c(5E@[gj^ M Gi G _g 3&)* C8z#   C! 2&W "%1%c(Gh G ^ 8z # 1! @(c(5 A@[gl^ M Gk G _Gj G _g! 3&)* ?8z#   C! 2&W14d G ^h G ^ 8z #h @(Gh G ^ 8z # 3! @(c(5!=@[gj^ M g) 3&)* ;8z#   C! 2&WGh G ^ 8z # 1! @(c(5"9@[gl^ M Gk G _Gj G _g1 3&)* 78z#   C! 2&W14d G ^h G ^ 8z #h @(Gh G ^ 8z # 3! @(c(5#5@[gk^ M Gi G _g9 3&)* 38z#   C! 2&W03Gh G ^ 8z # 1! @(Gh G ^ 8z # 1! @(c(5$1@[gA 3&)* /8z#   C! 2&W/G G 8z # 3! @(G G 8z # 3! @6%@(c(gE 3&)* +8z#   C! 2&WG G 8z # 1! @(c(5&)@[gI 3&)* '8z#   C! 2&W/G G 8z # 3! @(G G 8z # 3! @6'@(c(gM 3&)* #8z#   C! 2&WG G 8z # 1! @(c(5(!@[)*gl^M GjG _gQ3$ )*8z# C!2$ W l1$ c(1$ c(dG ^hG ^8z # 8"     3      4      1  @@(  6)8#@[)*gk^M GiG _gb3$ )*8z# C!2$ W6GG8z #D @ C@(GhG ^8z # DC @@( 6*8#@[)*gp3$ )*8z# C!2$ W  4 1$ ( 6+8#@[)*gj^ M g| 3')* 8z#   C! 2'W=G G8z # 1" l-9@@(G G8z # 1"h @lǖA@@(c G ^ G8z # GhG ^8z # V#8z!3!8 G !1" h8"@lǖA@@( 6,8#@[ 1"6-@(c(5.@[g 3&)* 8z#   C! 2&W%G 8z" 1! @(G 8z" 1! @(c(gl^ M g 3&)*  8z#   C! 2&5/ @[d G ^h G ^ 8z #k G ^jG ^8z #lG ^lG ^8z #lG ^lG ^8z #l G ^lG ^8z #l G ^l G ^8z #  >( gl^ M Gk G _Gj G _g 3&)* 8z#   C! 2&50@[d G ^h G ^ 8z # (gl^ M g 3&)* 8z#  C! 2&c G ^ G 8z #i G ^jG ^8z # @(51?6263 ,(6s&H `x&bi0=W^Oq  "'*-26> +94TCG & %D C V$C 8"89! hyV  658# +89 &8"V 668&(8z!84 !C F"I()*! 8'C E"Vc(C F"I%C? +()* ^(5K G?8! + ?8!lh8" C? + + ++B +/678! > 98T4W "-<JVtc(C 28 G &Ch! %Ch! %Ch! !%Ch!8 &C !C!2%CV!2%c!8!698'Ch!! %8!8 &CVcI(g 8&)* 2#l8!6:8N^V5; 8 "d? + +    , & !8% )*W "5< 82?&C 28 C'C ! 82?&D C  8 C!6=82f$ )*V D C 2" %c()*W ....."(C 28 G'C C!2&C !?@( @(.,c " VD V?(C (c(! 88"@&)* + 88&)* 8!&)*C @@I()*D C 8"V &(Ch +8 G')* 8 G"V( @()* +8 G#8 G8!&!@((W +(C 2&C +(D C @&c " VD VTC (5> 6?8 G"8%"6@8%"8 C%)* 8 C!@((W" """""C 28 G&C T C T+( %(W +(C 28 G&C %D %)*, , %W C 28 G &C %c(WC 28 G &C %c()*,, %)*c @ # VC D [c(c ! 8! hzVXV  6A8#8@[()*D C V  h@@(Y+8 G "ci@@Z( ? h@@(c !c()*VC Tc VC Tc8 F!!78 !U5B8N^C h}V5C8%!cT?8 8 c(  "8 G"V +8 G !8 G "c( c8!V)6D +=8 G# D C VC 8 G!@?(c( ?h?8$)*V@C W (D 2&D C 2"2&D C #@2&D D C  D"@2&()* ,c@h "8 G%)* "5E( 8%.!8 G &)*+ h8'CizV<C 5Fi8&C]!C]!^'C]!C]!^' CCCC6Gi8$ (h{V C nIi{VC nIC8%"IC8%"I(6H8'5I 82f&XV?8 ()*! E D C   +()* I(C8"I(7?6J? +  i +! 6K C^VTCC A(c(c(h + +$7 ^V% 8"%+ 8!V8 ! 8 G" 8&(8!U5L8N^V 5M 8%"8%(Y 8"ZT6 CyV6N8"8%!T[ Yc!Z(6 CyV 6O8"8%%[)* 8'5P ^V7((5Q]6R8N^V74T74 Y 8z!!ZT84 CyVD 6S8%"84@[[ + 8 G&?( +8 G"?(?( +8 G"?(5T8%%d? + ? + + +r?l h8" +L + + +  ,9+ +R +$ + ,g+8%?h?h?h?h?h?  +   +L @ D C +1 + @ ,X + + +k +V +,7 G + ,0+Th? + + + + + &)  " (,24>$9UT)*  6V8$6W8%&5X6Y 8%"6Z 8%"6[ 8%"6\8%"6]6^6_6`i6a6b6c6d6e 6f8%" 6g8%"6h6i6j6k6l6m6ni6o6p6q + +6r6s6t6u6v6w6x6y6z6{6|6}6~6666i66 8%"68%" 8%"66666666666i6,6666i 6   38&(*,.0246,.:<>@BDFHJOQSUWY[]_begikmoqsuw{}><E97?6 Y5]ZT6 CyV7T[8"? @9T8 !!8 G&)*W.Ac(G F EDC #V2+?>(c(F D C #V(c( (VD C V 2! &(56 @["8 %!"8 %c"'c"'8 !"')* VD C VJC WBTD G F EDC ^V  2+?>@(  2#@(VfV: DC F E D C ^V2+h?>@(2#@( h  2+8?h  +!?! ">@( V DC D ^V (   2# @( hh +?  >@((C V D 2' ()*W 0D5 82f&G FDC 8 !2!8 C!6 82f$F DC  6 82f$ 5 82f&)*W2$2G F DC8 !2!8 G# $ F D C $ (W%%G E 8 ! 8 !28 G &E 8 !c(c(8 !8 G&W&;c(G F E DC2+? #>(F E D C # >(C ?()*, %78 !V%%8 %)* !'c? YT \C8%=!@IdUccZ(6 CyVC([Y5]ZT6 + 8! 68#8"h +8 G# V#D V ?h+?8 ! >(C (c(7 ^Vc(8 !2! 8 !@(, !8 G%)*D C i# V C W( @@( @ @(()*6 3+8*# D C 8%&&)* " ! YV8 !T8 !?ZT ? WC D Y 8"ZT6 CyVcT[Vc(d 8#C W9Hp8 ! WC 1+?h?  >?T C ??TT;c ?  >?T,8! !8!V   h2#Tc?  >?TcTh 8#( C ??(8!U8!V&(c] +lh8" ,6i # VC (5?[7 ,+ +q ,9, + + ,,+ ,  > 9T)*C " C8%"8 G" I(8!V8%682i"8%%)*C8 G!8 G ! C8%" I( !h8N^682i"h?@8N@8*!  Ch8 C8!C6 ^Vc8!T>8!U682i"8%!T*C8" 8 !8!8!7C?Tc 8!CV85 8!"I5 8!"I5 8!"I5 8!"I5 8!" I+"  " ! " " "# "% "$ "& "' "( ") "* ", "- "+ ". "+ + " "+C8 G#8 G"+I(c @C8%"I(8%!7?[7N 8%!7?[c8I(8I(5I(c(7C8%!7?[dI&cI8!V h]8"I(I(?I(+?()* ^V Ch @@ I(c()*8z!84! C @ I(5I5I5I5I5I5I5I5I(c @6@?(C8!VAC8"6 8%" 8U!V?(8U!V?(Y !Z(6 CyV([Y !Z(6 CyV([5 8%" ? ?8U8$! + 8 G!!8U&7N 68%"h?6h]8"?h?h?h?i?6?i?i?i?h?i?i?h?h?i?h?8 +8 G !6 !6?6?6?6?h?6?6?6?h? +h?h?h?h?85?84?86?8?h?h?h?h?h?h?h?h?h?h?h?h?6?h?h?6?hh8@@?6?6 "$')++M +5 + + /;+h6#+? 6A@6#!6A@6$!6A@6&!6A@6'!6A@6'!6A@6(!6A@6)!6A@6*!6A@6+!6A@6 +H?6A@68?6A@68?6A@6 ?6A@68U?6A@6.?6A@6?6A@60?6A@68?6A@6:?6A@69?6A@68?6A@6 +?6A@63?6A@64?6A@6/?6A@61?6A@65?6A@67?6A@66?6A@62?6A@6!?6A@6  !?6 A@6  !?6 A@6  !?6A@6 !?6A@6!?6A@6!?6A@6!?6A@6!?6A@6!?6A@6!?6A@6!?6A@6!?6 A@6!!?6"A@6#!?6$A@6%!?6&A@6'!?6(A@6)!?6*A@6+!?6,A@6-!?6.A@6/!?60A@61!?62A@63!?64A@65!?66A@67!?68A@69!?6:A@6; !?6<A@6= !?6>A@6??6@A@6A ?6BA@6C +?6DA@6E ?6FA@6G?6HA@6I +l?6JA@6K +W?6LA@6M +3P9QTV>C6R ^V/5S ^V!D VC6T ^VTD 2%2! @(5U8%%D 2%c(^(Y 8"Z(6 CyV7QC +8 G" @([)*8 E! 8 E!^()*5V ^VT ! 8 E!8!" 8"8!&!V8%()*! &! Yg.8 G" 8 F"Z(6 CyV5W([Y!Z(6 CyV([! ! Yg.8 G" 8 E"C"Z(6 CyV5X8%%[)*! &Yg.8 G" 8 F"Z(6 CyV5Y([Y!Z(6 CyV([)*!V! &()*] ] yV 8 E" ^( {V8 E" ^V  ^8 G&(c(8"V! D C ! &()* ^V5ZT C8 G')*! ^V @( !@ 2&,c &&8 !8E%Y 8 !ChyZ(6 CyVc([()* ^()* &)*] ]  }V o ^l.yV  8 G&()*6[8%" 8%&()* ^(5 C D G GGG G 8 C8 C!8 +82? +h] + + +z @ +g +_8 8 +< +-6\6]h8"++ +6^^VcT5_6 @[6`^VcT5a6 @[ , ++?  +&+ ++ + +~ +O +@88 8 +%888$8 C!lkh8" , 3+ +&3 - 35/203EBDKMD>'  H,EMO>%59bT=hzV6c8 G"6d8"%()*hzV6e8 G" 6f8#%(5g! 8&Y 8"Z(6 CyV! 8# ([7h! !8 G')*D C "V D88 G# C88 G'()* +8 G'8z!6h8"i84  %)*Y+h8#Z(84 CyVD 6i8%"8%"84@[[8z!6j8"ih84  %C(!C @I8%D C888 G & +8 G &+lkh8"h? + +@ D C + +b8 +1 +  + +++   >9kTC(^(+89%)* @(! 88"@&)* + 88&)* 8!&)*C @@I(8!%)*D C 8"V @((Ch +89#?(c? + 8UI + + + + +o +a+R  > 9lTXD8 !!8 G"8 G ! V C @@I(c(W)))F G +8 G "8 !28 G &c(6m8&8!6n'W---F D C  8"V " 6o ?(c(c(WF D ^(c(WKKKF D C < 8"V1 8" 8%" +8 G"V " 6p ?(c(c(c()*WD C +&C +B&)*hzVC 8"F"I()*c?C? VC 8!V8!Tc + + , !C D!XVwVZC G! 5qT5r6s8 l6t8%*#88b8!6u # +G "5v "8!6w #8%6!T5x8! +jG "5y8!?[C( VD C ! V(2%c()*, %)*VD C ! V C  @2&2&8 G%)*,h &5z? + +88 C G%@8C! + ?9{TYT\8%=!6| 8\#dUcZ(6 CyVc([7QC8!8 !8b!V+8 !h8#8%)* 6}8$ +8 &+8 !h8'5~8b!8QC8b"C&ggh8" 8! 8! +? + +  A9TZ)*D E&)*i@C! E&)*h@C! E&)*D D&i@C! @()*C 8b &WC (C 8 G"&)* +8 G"68 G&D C6 ^V 682f' 682f$)* +8 G &)*VC 682f$5 82?&)*VC WD Ch #2$ D D C VC W 56 @[D C   n8 G # V_C o 8 G# 8"V7Yc @@ ] n2 Z( CyV o2$[ o   2$?[ o8 G# 8"V  @@( ?[ yV(?[)*] ,Y chh  ?Z( CyVc([)* 8 G # VC yV] n(?[?[C -9D ?(D D C @(D C 8z! 84 " +8 G&8b$%!8b%!8b!l8! 8 "8!V 8 E! 8 "8!8 C%! D W d(c(C VW cTcT!XT56 @[ VcTd J ()*! E F" K()*E !G &+%!E(e !I(!C Vc(C ?(! C VW c(c(c(C %D C hh8U#c %c !I(c!+8 G &)*! C V!W c(56 @[+ @? I(c(! ! ! "V 6l8 T  6l8 8b!8! 8b"c Jc I(d !I(c !I(!C(! !XU8b!V ! 8b &()*68%" 8 E! 8b!VY8! ^ZT6 CyVcT[ U 8"c(68%" 8 E! Y8! ^ZT6 CyVcT[ U 8"c( 6l 8 c !J()*ED!XVEG 682f$ ()*5 82f"c +"5 82f&)* 682f$ )*5 82f"c +"5 82f&)* 8 'Y 8"Z(6 CyVc! 8#([)*EG DC682f$ )*VW 5 82?&5 82?&5 82?&C C 8U682f$)*W 5 82?&5 82?&5 82?&CjjA(7b8!7QC8%8%78 !V !8%8 ! 8 E&78 !Vc(c!c()* 8b"C"8 F%c!7 C8Q1C8! +8'7Q1C8!!?8Q1I()* 8b"C"!8QC 8b#"V8b! ]XV8!c(d(7QCU(+8&8b!V(68"8%%8b!!V 8b8b"C&68"8%%)* ^()* ^(5b G D@8C!8b + + + + + +? +#? + + + + + + +P +2lgh8" + + + + +i +- ++ ,q+ + +  +J + + ++++%+&+i    "$&(*,.0246>++ +6? + 8$! += + + + + > + + +x +e+R+CF  GGGG  G!G"G#G$G%G&G'G(G)G*G+G ,G-C>)>9TC)* ! ! 8b!8! E&)* + h??hhh$ )*c ?@ ?@6@??()*c ?@ @6@??(c ?@6@6@??()*c ?@ ?@6@6@??()*c ?@ ?@6@6@??()*c ?@ ?@6@6@??()*c ?@ ?@6@??()*c ?@ ?@6@??()* " 8U !@()*! 8 G"V682i#8%% @()*V Ch !@Tc +8 G')*VC Tc VC TcVC Tc V  C Tgx+ hyV  hyV hyV5@[ V C @ 8 !?@Th@ D C 8 #+3  8  #888 G#>&C()* C^V  @@( @()* C^V @ @( @(C C^()*YC+8 G"68#@[6 CyVNVfX C @I(c @C8%"I(C fDhC +8 G#I(DhC +a8 G#I([cI(FD 8G$8!8b! Y!8 G""8 G"" ^V5?[Z(6 CyV8E%[8G% 8%.&Y} V D6h8U#T&G VCh8!" + h8#TcF +8 G " XV%#! "F  +Q8 G " 6l8 Z(F8 8 G "[ 68 Vu C6 8'5 8&C "+#2<D 8 68$D 8 68$)D D C  C6 8$ D 8 68$8!X(( 8G &W/C FC6l 8 C F"IF +8 G "((! +8 G&)*C? +  6l8  +G" D  "C G6l 8 F +_8 G # VCh l6Z@@ToE8F8 G # VCh l2<@@TM8FG # VCh l"+@@T/ ! V#C# ^V5T c @l)@@T5 D C   +M ! XV  F8 8 G "7QCVXVg !F68  @[f !  + pVc % F  +8 G &c @(8U! V +8 G"!8D8 G &c(+8U %c @()*8U! V +8 G" !8E8 G&c()*Y "?Z(6 CyVc([)*8 G! 82?&)* C68%"8&YC68%"8!?Z(6 CyVc([8!8 &)*g8! C 8 "+6 8 "F 8 G "5 8 "E 8 G "5 8 " G "8!8 C%8!8 G!8 &)*g8! +6 8 "E 8 G "5 8 " G "8!8 C!8 G%)*8!8b! 8!V 8 E! @@((c F +8 G' 8" V C "@[c()*YF+8 G "cZ( CyVD ?([!G%)*8" %)*8!8 G! 8!8 G! +G VC 8"?TcF ! +  E !D 8C68 >()*F 8 C!EC682f$ )*F 8 C!ED8C6 82f$ )*C 82?&)*56 @[G(F(E(C(76?6? + + + + + +8 8 C! + +p + 6? + ++:+ + + + +c +9 +%    !#+ h? + +\ +A E D C +l + + + + + +f +M +1   > +   )+-/>!9T)*D C h{V 82?" @ 2&()*VD C Y?8!"8 G "Y"8"ZT8 CyV ?@[[Z( CyV3D  @?@&WC 8G !Tc @2& [56 @[)*c8! @ 8 6@ 6l8 8 G"VA[8D! VW)8 6l8$ 8 6l8 ? &8b!U8b!V8G!Vc(? &8!V 8G%8 !8 D" V44 ,c & ? & C  8 6l8 8G %)*V+DC Y1#?Z( CyVD  @2$ [?@?(c %)*Vc %()*D C W#C 8G ! VC D C @ @@( (()*h 1#8 G"6 +8 G# D C 8 F!8UCg Tg i{V 6 8#hh8U# i{V5 8"VC D C +d8 G#c68"[ +K8 G "( )* 4#8G%)*hhh  WC 8G!(C CyV D @@[[)*8G!@[5?6? + , ,ch "  +   > 9T)*W%HC  8 682f c(C 2!8 G&D C 8"V8 682f c( 2&D 2&)*WATC 8 682f$C VD VTC 2&5 82f" 2!8 G "5 82f&D C 2 8 682f$ D C 2 682f$ )* "c(5h8" ,-,~+ @9T 8b"C&8b!!V38b! 8b!8b ^Vc @ 8b"h@(8b! +8 G&c @()*VC 682f$5 82?&8b!68%" 68%" 8b!8k!8C"8C&7 C8 C! + + +l A9T|68&D C C E CXV 58!dI5T568# +89 &5l8"c? 8QCV7QC8QC8b"?Tc8{# V +89 "CV?[(c(5?6 + @9Tz)* ^(Y 8"Z(6 CyVY 684   G G F EDC  684   684  +!8 G" Y 28 G"ZT) CyVD WTC @!TT[       > 8# Z(6 CyVc%74 CyV D @%[[G(F()* !?&)* G?&)*6" ?&)* GF&)*! C+8 G#h G! +8 G# +8 G# +8 G# 8 G!?()*6" ?&)* GF&! C+8 G#h G! +8 G# 8 G!?()* W C6 ^VT( @()* G 8 G#&)* 8 G"V( @(+ h +8 G# 8 G%684'88&8!8z8!"8!&)* +8&!8%#!e8%L%W5(D C 68'C 68&D C 68'@[5? + + +6l*h8" + +w   ,e+^ +C8 C G%@8C! + + +E + ! + !  > 9T)*VD C 2 !682f$ c(W+E D C  682f$ E D C  682f$ D C  682f$)*2, +()*ch WED TED TD % ! 2!8 G &)*ch WED TED TD & " 2!8 G'C%8b! Y"8"6 ^VcT c ?@6@?Z(6 CyV%[D C8#E C8'gh8"lh8" +"C +I @()*D C 8 C! 8 C8 C!!682f$ )*5 ^V  682f$()*5 82f" +8 "5  82f&c( G &DF8 G&C +# +()*E DC6 82f$)*W'RE C 3# F E D C 8 G! A @@( E C E" D CA 3# F E 8 G! Ah@(C @h@()*D C ED 8%" CA " D C @ 8%"@()* C8b"C"6  ^VDTD @ E A6  1+8 G# D C  >( ,-5  "D()*5 ^V(68%" 8%&c @()*h A()*h A(+ + + + + ,L7 C8 C! + ,K,7 C G%@8C! + +n? +M + + +    > 9T)*"   @@(()*D C ! ^V  8 E&68"@[Y 8z!84!ZT84 CyVD 68"@[[h +8 G#8QCV8!68"U6@Th +n8 G# Y 8"ZT6 CyVcT[8 E"8#(!6 8b"D" +_ h8'c?@6@?h @@6@8l&)*?! 8l"XV c @ 8U&(VCh @ ?@6@?(()*VC Tc VC TdVC Td+V C T  8b!68%" + @ 8#V/V5 8%"6 @6@ "V$5 8%"6 @6@ "TXVXV5 8%! V C6! +8 G &c( )*! @ 8'Y 8"Z(6 CyVc([c 8b!8b!8 G#?()*7b ^V( ?@6"@(5#6$ 8C"8C"8l! 8U! c(c ?@6%@?(8z!84%+ h8')* 8b"D"8b"C"@ 8b"D"8b"C"@( +8 G&)*8b! 8b! 8 G#! 8b"C" 8 G$! 8b"C"h  +8 G' )*C @8 G"U7Q(C 8 G"V 6&k8 l7(!Vgh4(g()*8b!]hyV5'8%!C @@I(7QCVc(5( 8 G$!8b"D"8 !8b"C" 8b%8b!8b!%8b!8 G#%! 88"@&)* + 88&5)8b!8QC8b"C"h ?@6*@6+@8QC@??h6,8U# 8!8 D%)* @()* 8l"c ? +8U # 8U&7 C G%@8C! + +? +u +T +D +h? + + +x +78b + + +lgh8"lgh8" + + +6-8b!6.?lgh8" +Q  8$!   !#%(>9/T,! F?(8 ! G" VD V 8608 8%%C 2%(8!V051 8"V#! ^V8!V%V%c(c(%(8!V C 8 G"XV7C 8 G"V CA[C @I! 2+G "C @I(Y8 !G"Z(6 CyVC([!G %D+G ')* ^V( F')*! !+ ! ! VC V C & &V C & & ! V D V 8628 8%%C ?(c(8 ! G&"EG &"DG &)* 8b"V  8 G&()* E"V 8 G"U @(()*! ! ^U !U!V( F' 8b!8 G"X(V 53 8"V8b" 8!V(((54 8"V8b&(55 8"V8b&()*F%)*VC T56 VC T57VC TcVC TcV C Tc V58@Tc@@ 88  69 C+E" G6:#+j+/ +C +C" G6;#G " G6<#c  +G # 86=#+  +n? GG!6># +H? ,+. + +  +? GG!6?#+Th?h? , 8 G "C8#86@ C8 G% )* "@ ')*!V +8 G'()* + &)*Y 8"Z(6 CyV-c 8# F" YG"2G #Z(6 CyV([[)*g h8" ,C 8 G')*Y G"Z(6 CyVc([)*8 ! &)* 6A82f$)*5B 82f" +G "5C 82f&)* " F" F')*Y G"Z(6 CyVC([7 G%?8!8 F C + ++8 !G ! +m +N  +*   +   >  +& >(l 8&+6D? +~ + @9ET )*C Wh4c(C8QCXV[(C $ D 8/')* A 8b! 8b!6F8b"6G8b"6H 8b"D"8b!V8/!Tc6I 8b"D"8b!V8/!Tc8 E" hzV8"XV+d8#  +8 G"  !    2+K8 G'( 5J6K !8C"8C&+8Q-C6L8b"D"6M6Nhh8Q,C6O8b"D"@6P@@$5Q !8C&+8Q-C6R8b"D"6S6Thh8Q,C6U8b"D"@6V@@$)*VC Tc !')*6W6X6Y6Z6[8C"8C"8C"8C"8C"8C8 G'5\ !8C&+8Q-C6]6^hh8Q,C@6_@@$8Q-C6`6ahh8Q,C@6b@@$5c6d6e6f8C"8C"8C"8C& +8Q-C6g8b"D"6h6i6jh8Q,C6k8b"D"@6l@6m@@$5n6o6p 8C"8C"8C& +8Q-C6q6r6sh8Q,C@6t@6u@@$5v6w6x6y8C"8C"8C"8C&5z6{6| 8C"8C"8C&5} !8C&5~6668C"8C"8C"8C&)*! 8/! $  ^( 8 G"X( 8 G& 8b"D&ch 8b"@@!8D8 G &WC 8b!8 G"" +8 G "(C [ 8/'C()*  ! 8!!  8" 8b! 8!VT8b! 8b! +8 G"     +8 G"!  +l8 G"   8#C +58 G" ?h6??  8%" +8 G"  +8 G"8%"68b"D" + 8 G" '5 !8C&+'566668C"8C"8C"8C"8C& +'68Q,C68b"D"@8Q-C68b"D"66$'56668C"8C"8C"8C& +'68Q,C@8Q-C66$5 !8C&566668C"8C"8C"8C"8C&56668C"8C"8C"8C& ^( 8 G"X( 8b"D&)*  ! ! 8!!6 8C" 8" 68b"         C+8 G"  @??h??  +8 G"8%" 68b"D" +b 8 G" hyV58%! 8b 86l8  6 8C"')*!! 8!! h@ '  8 & 8 &C @I(c 8b"D"@( 8b"D&)*8b! 8!! 8/ !8 E" 8 6l 8  +8 G" +8 G"  !8D8 G "( )*Y8/8" D C VT @Z(6 CyV([c +8 ')*VC T5 ! 68b" 8b"  6@  68!8!8"8C"8E"' )*! ! " 68!8!8"8C"8E"' )* ! ! " 68!8C"' )*D C  Wh4c(C8QCV 6k8' [c(D6 8/')*8b! 8b! 8/! +8 G"! +8 G' 56668C"8C"8C"8C&%68"V%%)*8b8 G"h8 E"h 8/ 8 G#68b"h?@6@8U!@ ?@?@"@6@8QC@? 8b!V?(c ?@6@6@?6 @6@ @6@ @6@ ?@6@??()*c?@6@ 8U!@ ?@ "@ @8QC@??()*56 8C"8C"h ?@?@6@ 8/!@ 8/!@6 8C"?@ 8 !@6@8QC@??()*c ?@6@ 8U!@ ?@6@8QC@??(56668C"8C"8C"8C&68"V%%)*c ?@6@ 8U!@6 8C"?@8Q C@??()*c 8b!?@6@ 8U!@ ?@8Q C@??()*c?@6@ 8U!@ ?@ @8QC@??()*56 8C"8C"h ?@?@6@ 8/!@ 8/!@6 8C"?@6@8QC@??()*68"V8 %c(+ + +o6 !h ! +; + + + + +P +6 !6 !h !+y  +a +Y +7 + + +{lkh8" ,+ + +l h8"l h8"h? +T8G +D+9 A 8E! C +  +I  5666  +! " "  5666  +$ " +" "+ +} +Q +)  +  ++ ! ! +r .06666  ! +736666  ! 2+46666  ! +46666  ! +66666   ! /+q  ! 1+ !03+13+ ! ! +b %7+D69+ 79+ ! !-  !#!#%'+-0257;=@BEGJTWY\^`npgikmprxz}>5L9T)*VC T5 !!668!8C"8C"8C"  8" 8l!8U! VTh?@6@6@6@?@ @??( 5 8/')*VC T !!! 8/! 8b!8b! +8 G"  !8E8 G"68!8!8"8C"  $)* ! ! 8 " 68!8C"' )* ! ! 8 " 68!8C"' c ?@6@?()*ch?@6@668C"8C"?@ +8 G"?@8QC@??@h8b!?@6@6@??@h?@6@6@??@?(c ?@6@?()*ch?@6@6 6 8C"8C"?@ +8 G"?@8QC@??@h?@6 @6 @??@h?@6 @6@??@?()*5 8C"h ?@ 8/!@6 8C"8/!@6 8C"?@?@6@8QC@??()* !8QC5T7QC 8 "c ?@6@6668!8C"8C"8C"?@h 8/!@8QC@??@6@ @??()* ! !6 8!8C" 8 "c ?@6@ ?@6 8C"?@ 68"V5Tc@6@ 8/!@ 8/!@8QC@??()* !h ?@66 6!8!8C"8C"8C"?@8Q C@??()* !8QC5"T7QCh ?@6#6$6%8!8C"8C"8C"?@ @??()* ! ! 8!h ?@6&@ ?@ !@??()*7QC5'T7QC ! !!  " D Chh@@ !8D8 G " 8 "5(6)6*8C"8C"8C"6+6,6-8C"8C"8C"h8U!@ ?@6.@6/@ ?@h 8/!@ ?@8QC@??@60@ @??()* ! ! " D C6162 8C"8C"8b!h8U!@ ?@63@? '8!8%54 8/')*8! 8/! 8b!8b! +8 G" !8E8 G" +8 G# @()* ! !6566 8!8C"8C" ? ' )*7QC57T7QCh?@68@ @8!?@69@6:@ ?@ @??(5;6< 8C"8C"6=6> 8C"8/!@ ?@8QC@?( 8b"D&+8 G%+ + +x +P + + ++ + +X + + += + +S +! + + +)   >9?Tc 8A!6@82i"?@6A@?h 8A!6B82i"@6C@6D@8l"c 8A!6E82i"?@6F@?h 8A!6G82i"@6H@6I@8l"c 8A!6J82i"?@6K@?h 8A!6L82i"@6M@6N@8l"c 8A!6O82i"?@6P@?h 8A!6Q82i"@6R@6S@8l&D C h @6T@6U@8l& +8 G &?h @6V@6W@8l& +8 G &c ?@6X@?(c ?@6Y@?(c ?@6Z@?(c ?@6[@?(c ?@6\@?(c ?@6]@?(c ?@6^@?(c ?@6_@?(c ?@6`@?(+6a 8l#+6b 8l#+6c 8l'5d 8%"?(5e 8%"?(5f 8%"?(5g 8%"?()* ?@()*5h ! ! 8!6i8"V7QCT7QCh ?@6j@6k6l8!8C"8C"?@ @??8b 8b!^V(c 8b!8C"@ @?(8b"C"%c8b ?@ 8QC8b"C"?@6m@6n@??(c 8b"C"@()*5o ! 8b! 8/! +8 G"!8D8 G "7QCV+ +8 G"?(c(7Q-C8Q,C8Q.C 6p8b"D" 6q8b"D" 6r8b"D"6s8b"D"6t8b"D"6u8b"D" +|h6v6whhhh6x8 5y6z8 "hhh6{6|h6}6~8 568%"hhhh66668 568#"hhh66h668 568#"hh6hh6668 5668#hhh66h668 56h8#hhh66h668 #568/"hhhh6h @6@?668 #568)"hhhh6h@6@?668 %5668#hhhh6h @6@?668 #5hh8#hhhh6h@6@?668 5668#hhhh66668 56h8#hhhh66668 568"hh66hh668 568"hh66hh668 #568"hhh6h @6@?h668 #568"hhh6h@6@?h668 568!"hh66hh668 568"hh66hh668 568"hh66hh668 568"hh66hh668 85 68b"D"6C#hh6hhh68b"D"@68b"D"@?h68 #5681"hh6hhh @6@?668 #568+"hh6hhh@6@?668 ,568"hhhhh @6@?h @6 @?6 6 8 ,5 6 8"hhhhh@6@?h@6@?668 #5683"hh6hhh @6@?668 #568-"hh6hhh @6@?668 .566 8#hhhhh @6!@?h @6"@?6#6$8 .5%6&6'8#hhhhh @6(@?h @6)@?6*6+8 $5,6-h8#hhhhh@6.@?6/60618 -5263h8#hhhhh@64@?h @65@?66678 .58696:8#hhhhh @6;@?h @6<@?6=6>8 5?6@8?"hh6A6Bhhh6C8 5D6E8?"hh6F6Ghhh6H8 5I8?!hh6J6Khh6L6M8 5N6O8? "hhh6P6Qh6R6S8 5T6U8? "hhh6V6Wh6X6Y8 $5Z6[6\8??8? h6]6^6_hhh6`8 $5a6b6c8??8? h6d6e6fhhh6g8 #5h6i6j8??8? hh6k6lhhh6m8 7QCU 5n8k!Vk5o6p6q8?#hhhh6r6sh6t8 5u6v8?"hh6w6xhhh6y8 5z8? !hhhh6{6|h6}8 5~68?"hh66hhh68 T58?!hh6hh6668 +hh6 ?hhh68 568? "hhh66hh68 568'"hh66hhh68  566h8? hh66hhh68 c8Q#C +e8 G#?68l"7Q!C8U!68l"7Q"C8U!68l"7Q%C8U!68l"7Q%C8U!68l"7Q$C8U!68l"568l"7Q&C8U!68l"568l"7QC +8 G"?68l"7QC +8 G"?68l"7QC +8 G"?68l"7QC +|8 G"?68l"7QCV*568l!8!"568l!8!"5 +*8 G "TXY?7Q C88 G" 8!68l"8!68l"8!68l"8 !68l"ZT8 CyV D 8!T[ +668l#+t668l#+[668l#+B668l#+)668l#+668l# +6 !+6 !568l"5hhhh68/ 5hhhh68/ 5hhhh68/ 5hhhh68/ 5hhhh68/ 5hhhh68/ 5hhhh68/ 56hhh68/ 5h6hh68/ 5h6hh68/ 566hh68/ 566hh68/ 566hh68/ 566hh68/ 568l"568l"568l"568l"568l"568l"568l"568l"568l"568l"568l"568l"568l"568l"568l"568l"5 6 8l"5 6 8l"5 68l"568l"568l"568l"7QCU+568l"568l"568l"568l"568l"T 56 8l"5!6"8l"5#6$8l"5%6&8l"+6' 8 G "5(6)8l"5*6+8l"5,6-8l"5.6/8l"50618l"52638l" 54hhhhh8/  55hhhhh8/    > h(WC (C [! 8b"C& +8 G&56 8"V578Q,C^V 8Q,C8b&()*! !! 8/! 8b!8b! + +8 G" ! +8 G"h 8U!@6869 8!8C"8C"?@?@6:@8Q C@??( + ? + ?9;T:!h G %5< ^(Vtc!7b8!7QCXVa7QCVcT7Q C8N8* !8 G!h +8 G"8U!@6=@8Q/C8QC8b"C"8%"?@ @?hh8" 8U !8!8@[(c(!XU!XU! VV VVc(7QCV5>8C8b"C"8!XV c8QI5?8!VVc?@?@?T?Tc8QCV7QC V5@Tc6A6B>T7QC V5CTc6D6E> F E D C8QCU78 !V5FT6G8b"D"?6H6IA E D C 8b"D" 8b"D"8C 8b"C"8!XV 6J82i"8%!8b!!V 8b8b"C"Th8Q/C8%"?@6K@ 8b"C"?@?@@ 8b"C"?@ @@ ?@6L@ @??8QC8!7Q/C8%"8!hh8U'8QC8b"C" 8b!V8b!V 8b "U 8 "c(5M6N 8%"6O 8%"6P 8%" 8!8QCV8!8Q/C8QC8b"C"8%"8! 8! +8!6Q8"8!6R8"   +  +|   > (+l +J ?9Scijklilllll l l l l   >9TTC%I(c(+? + + @9UTc g;WTgM?8"8%L%+ Yc!Z(8QCVY[8 CyV7T %7 CyV 5V8!7T %7 CyVD 6W8"7T%7 CyVD 6X8"7T%7 CyVD % CyVc6Y8"7T8%L%7 CyVDh6Z8"8%L%7 CyVD 886[l8 7T%5 CyVD 6\8"7T%7 CyV"E D 8 8 C!8 6]8 7T%5 CyVD 6^8"7T%7/ CyVD 6_8"7T%74 CyVD 6`8"7T %7 CyVD 6a8"7T% CyVD 6b8"7T %7 CyVD 6c8"7T%Y86d8#gd!Z( 8!6e8"gd%[7QCVc8b ?@ ?@6f@6g@?!c()*D C 8QC8b"C"+6h^V05i^V5j^V"5k^V7QCV6l82h"(8b! !( ! @(8U !8%E D C 8b!8! 8" @(8 ! 8! 8b! A()* 8b"C"8! 6m8"XV 6n8"X()*7 ^VcT? 8b"C"6o^V 8k"c5p8 G"U]h{Vc^l_zVv7QC^V 7QC8 G"XV_7 ^VV8b!VO8! 6q8"U7QC 8 G"V C @Id(6r8"U7QC 8b !8 G"U 8b !8 G&(d(c 6s88"@8k%e8U!c8Q2!7QCVc!f8U!c8S!7QChyV7Q+ChyV7QCXV?[7QC8b8 G"h8 E"6t8k!7Q)C8k!7QCU 5u]U5v]V5w8k!7Q C +y8 G "c]8b]c?88! +8"h8U! +u8"8Q CV8!T8!i8U!C8 G!8b @8QI7QC86xk8 ?8Q1I7Q*C8k8 G "g8U!c8;!g8U!c88!]7QCV c!?[c8!d8N!c!7QC +8 G" Y +8 G"h8U!ch8"7b8!+h +(8 G#8QCVQ8 G! V;D C hzV5yh8"c8Q'C8U!@ ?@?  8b 6zk8 !8@[5{8@[TcZ(8E CyVE D  86|8 @[[D C 8U ! 86}$8 8!6~'l8&c8!h8l! + +8 G " +8 G "5 %8!8 68$7Q+C +8 G &)*d(ch8"7QC8!7QCV78! +8" 8!8!?[5?6? + + +l +U + ?956U6T6S6;6?66E6/6666666666{6l6k6b6Q6666U68646666666666h6>)97 G G G G GGGGG G G G G GG G!G"G#G$8888 G" C D G C D E F888 G C D F GGGG G GGGG8 G8E8F8 G 8 G8 G8 G 8 E8 G8 G8C8"G48G8G8G8'C  !#%' "$(*,*/<>@BEGNPRTVXZ\^`bdfhjN]Qorrubac>;@9T)*  68$68%&56 8%"6 8%"6 8%"68%"6666i66666 68%" 68%"6666666i666 + +66666666666666666i66 8%"68%" 8%"66666666666i66666i 5   2@7%')+-/135+-9;=?ACEGINPRTVXZ\^adfhjlnprtvz|~><D9T)* ?@6@(8z!8 E%)*5h68"68#@6@@()*5?@6@6@6@6@6@6@6@6@6@6@6@6@6@6!?@6@6@6@8GC@??( 68"8& 68"8& 68"8&c 68"@ 68"@ +8G" 68"@8%" +8G" 68"@8%" +8G"8%&)*c682!@6@??@6@?()*c682!@6@??@6@?()*5@6@6@6@??()*6 8"8"@6 8"8"@()*5@6@6@6@??()*6 8"8"@6 8"8"@(8G!X(8&)*5668G !@6@@()*5 !6 !h ?@6@ ?@6@6@6@6@6@6@6@6@6@6@6@?@??()*5  !6  ! F"c ?@6 @6 @6 @6@6@ ?@6@?@??(8 ! VNC W?????5 C^U28 !8 ! VC W T8 !2! C@(58%%8 !2%(c @()*! +8G" !8D8G &8! !%+ h8 ')*5?@??()* 8%" # 8%" &)*c!?@6@8C!@6@?@66688!8"8"8"?@@@6@?@6@@??()*c!?@6@8C!@6@?@66688!8"8"8"?@@@6 @?@6!@@??()*VCTd 6"8"6# 8"6$ 8" Vc?@6%@?6&6'AT5( E D CV/U,cG56)8"8"@6*8"@h6+8"@@T5,h @ 8%" 8%" 6-" 6." hG4@"V5/T*cG5608"8"@618"@h628"@@ ;   +63hh!?CC8%"  @8%"?hh8     +064hh!?D D8%"8%"8%" @ @?hh8$ )*c?@65@8C!@66@?@67686988!8"8"8"?@6:@@??()*6;8"6< 8"h@8%"8%" 6=" +6>hhh@?h @?h 8$ )*8-! 6?@ 8G !@6@@ @6A@()*5Bh +8G#@()*5C?@6D@6E@@??( &)* !G8" !81&)* ! !8/&)*6F8" G6G8"8"V +T +hh ??hhh 6H82i"8$ )*5I()*5J6K8/&)*5L()*GV5MD8%"6N8%"??(V8c6O6P8/"@6Q6R8."@6S82!@hG9?@6T@?6U6V#@?(G6W8%"6X ?@6Y@6Z@ ?@6[@6\@ ?@6]@6^@6_D8%"6`8%"?@6a@6b@G?@G?@G?@??()*7%=6ch8 #h6d6e83"@6f 6g82i"?@6h@6i@??@6j82!@?()*5k()*5l()*Vc6m!?6n!'c6o!?@6p!?@6q@@??()*cG?@6r@6s@?6t!6u!')*cG6v8%"?@G6w8%"?@6x@VcTG?@6y@6z@6{@?6|!6}!')*ch8C!@6~@6@6@6@6@6@6@6@6@6@6@6@@??@6@?()*6 8G$!68"8"@()*c6 !G468" !')*668"G+ 6 "c()*668"G 6 "c()*h 8G$!68"8"@@( +8G&)*c8! +8G# ! 8D8G &58,%)* 682i#8 $)*58,!h 8C!@6@6@6@6@6@6@@??(68"6 @ 8G&D C8G&8F! 8G ! +8G&)* 8"@( +8G&)*c +8G'W#V568G" 682i"8C%( 8G I5 @?8G IV5T58GI5 @?8G I5 @?8GIG48G,IG58G-IdG38F"8G.Id8GIc8GI7GCV 8GI(8GIc8GI8GI(5668"8"66668$"568$"568("568("+h?@ @? !68$"568$"568$"568$"5668G8"8"8" 8F!V ?68$"568)"568)"568)"585!cG?@6@G?@6@?68$"cG468"@G468"@68G"cG568"@68G"568$"c?@6@?68$"c?@6@?68$"c?@6@?68$"c?@6@?68$"c?@6@?68$"c?@6@?68$"c?@6@?68$"c?@6@?68$"+^hhh68D"@hh68D"@hh68D"@68D"@68D"@h68C"@68C"@h68C"@68C" !568G"58G @68G"568G"568G"568G"568G"568G"568G"568G"568G"56 8G"5 6 8G"5 6 8G"5 6 8G"5 6 8G"5 6 8G"5 6 8G"5 6 8G"5 6 8G"5 6 8G"5 6 8G"5 +8G " 5 6 h6 8 G56 8"G56 8"h6 8 G56 8"G56 8"h6 8 5 6 6! 6" 8 5# 6$ 6% 6& 8 5' 6( 6) 6* 8 5+ 6, 6- 6. 8 5/ 60 61 62 8 53 64 65 66 8 57 68 69 6: 8  5; 6< h6= 8  5> 6? h6@ 8  5A 6B h6C 8  +hhh6D 6E hh6F 8 +6G 6H h #5I 6J h #5K 6L h #5M 6N h #5O 6P h #5Q 6R h #5S 6T h #5U 6V h #5W 6X h #5Y 6Z h #5[ 6\ h #5] 6^ h #5_ 6` h #5a 6b 6c # 5d hhhhh8* +J? +# .+h6e hh6f G56g 8"@6h @6i @6j @?hh6k 8 D+h6l hh6m G56n 8"@G46o 8"@6p @G56q 8"@6r @6s @?hh6t 8 5u 6v 6w #5x 6y 6z #5{ 6| 6} #G46~ 8"G46 8"6 #5 6 6 #G56 8"G56 8"6 #5 6 8G"!+6 h6 G46 8"?hhh6 8 5 6 8$"cG ?@?6 8$"5 G ?@?6 8$"5 6 8$"5 6 8$"5 G 6 8%"?@G6 8%"?@?6 8$"5 6 8$"c6 !?@6 @?6 8$"5 !6 8$"c6 !@6 !@6 !@?h ?@6 @?6 8$"6 8$"V 5 6 8$"V 5 6 8$"V5 T5 6 8$"5 6 6 8,! +8G# +`h6 h6 ?hh6 8 c?@6 @?@6 @?6 8$"c?@6 @?@6 @?6 8$"c?@6 @?6 8$"cG?@G:?@6 @?6 8$"5 V5 T5 @8G" + +v6 hh6 !?6 !@?hh6 8 *+*6 hh6 !?6 !@?hh6 8 (+6 h6 !?6 !?hhh6 8 VcG ?@6 !@6 @?6 8$"cG ?@?6 8$"cG?@G?@6 8"?@6 @6 @6 @?6 8$"5 6 8$"5 6 8$"+46 h6 6 hhh6 8 +hh6 6 hhh6 8 +hhh6 6 hh6 8 +hhhh6 6 h6 8  5 6 h6 8 +hh6 6 hhh6 8  5 6 h6 8 +hh6 6 hhh6 8 +yhhh6 6 hh6 8 +#6 6 ^V5 T5 "5 +8G "5 ^V5 T5 G6 8"8"  +hhh6 6  @?hh6 8 5 8C!6 !8C!6 !8C!6 !8C!6 !8C!6 !6 !6 !6 !6 !6  !6  !6  !6  !6  !6 !6 !6 !6 !6 !6 !6 !6 !6 !6 !6 !6 !6 !6 !G56 8"!6 ]Vc@6! +hhh6" ?hh6# 8 *+,  - + + 5$ 6% 6& 6' 8 .+hh6( 6) hhh6* 8 5+ 8d! , +X +, >6, 6- 8G"1+vhh6. 6/ hhh60 8 0+hhh61 62 hh63 8 54 65 8G"ch66 #4c@h@h@@@@@"@!@$@67 68  c@h@h@$@h69  /c@h@h@@@@"@!@$@h6:  ch@h@@#@$@h6;  3ch@h@@@@@#@"@!@$@h6<  3ch@h@@@@!@@@#@$@h6=  3ch@h@@@ @!@@@#@$@h6>  5? 6@ 8G"5A 6B 8G"5C 6D 8G"5E 6F 8G"5G 6H 8G"5I 6J 8G"5K 6L 8G"5M 6N 8G"+Chh6O 6P hhh6Q 8  5R 6S h6T 8  5U 6V h6W 8  5X 6Y h6Z 8 5[ 8G!8* ! +8G" +8G"6\ 6] 6^ h +8G# ( +}hhhh 6_ 8%"? 6` @6a @?h6b 8 5c 6d h +-8G# ( +hhhh 6e 8%"? 6f @6g @?h6h 8  +hhh6i  6j 8%"?hh6k 8  +{hhh6l  6m 8%"?hh6n 8 5o 6p @8%" 6q @8%" 8%" +6r ! 5s 8"G"hhh6t ?hh6u 8 5v ! ,5w 8"G*"hhhh?hG56x 8"@6y @?h6z 8 5 + hhh6{  !?hG56| 8"@6} @6~ @6 @?hh6 8 5 E8" +hhh6 hhh6 8 5 6 8)"5 6 8)"5 6 8)"VDcG46 8"@6 8G"5 6 8$"5 ^V5 ^V5 6 @[5 6 8$"T 5 6 8$"+1VcG ! +8G#?TG ?6 8$"5 6 8$"5 6 8$"5 V5 T5 6 8"h6 8     "$&(*,.02468:<>@BDFHJLNPRTVXZ\^`bdfhj>66h(c(5 6 8F!V5 T5 8F!V5 8F!V5 T5 @?@?(5 8F!V5 (8F8G"V5 (8F8G"V 5 @?((G6 6 8"8&G5 6 8"8&G4 6 8"8&6 8&V 6 8&()*c !%)*VC W 33 D2&C VDV  D 8%"2& D C@2& D2&C D 8G! 8G!8G ^V!?T6 8%" 8%"!?6 h 8G # @8G!8%&  @2& 5 8%%U(,Wch @ "?(V 5 8G"V(5 8" 8F!V((V 5 8G"V(5 8&)*cG?@ @G?@? ')*6 6 88!8"8"8"h ?@@G?@G?@? ')*5 ^V0c G48G"8G!8."@h?@6 @ @??@?(c ?@6 @ ?@6 @ @??(5 ^V 6 8"?(6 8%"?(G+!?()*7G ! ! G/#??()*7G !!G,6 8 ??()*7G !!G-6 8 ??( 8&)*+ 6 8 '56 8N^ V5 87!G86 ^V6 82h" +++y+\+N+- +   +  +p +Q +& + +^6 6 h]8"?6 @?6 8F! +08N6 ^V5 !T5 !6 !6 !6 !6 !6 ! ++++h G46 8"@6 @6 @6 @6 +c 6 8G"!6 8G"+ 6 8G"!6 8G"5 6 6     "%(*,/135:<>+!8:!    "$&(*,.02468:<>@CEG>$%9 c8(C!:9 c8%P!:9 caml_alloc_dummycaml_alloc_dummy_floatcaml_update_dummycaml_array_get_addrcaml_array_get_floatcaml_array_getcaml_array_set_addrcaml_array_set_floatcaml_array_setcaml_array_unsafe_get_floatcaml_array_unsafe_getcaml_array_unsafe_set_addrcaml_array_unsafe_set_floatcaml_array_unsafe_setcaml_make_vectcaml_make_arraycaml_array_blitcaml_array_subcaml_array_appendcaml_array_concatcaml_comparecaml_equalcaml_notequalcaml_lessthancaml_lessequalcaml_greaterthancaml_greaterequalcaml_output_valuecaml_output_value_to_stringcaml_output_value_to_buffercaml_format_floatcaml_float_of_stringcaml_int_of_floatcaml_float_of_intcaml_neg_floatcaml_abs_floatcaml_add_floatcaml_sub_floatcaml_mul_floatcaml_div_floatcaml_exp_floatcaml_floor_floatcaml_fmod_floatcaml_frexp_floatcaml_ldexp_floatcaml_log_floatcaml_log10_floatcaml_modf_floatcaml_sqrt_floatcaml_power_floatcaml_sin_floatcaml_sinh_floatcaml_cos_floatcaml_cosh_floatcaml_tan_floatcaml_tanh_floatcaml_asin_floatcaml_acos_floatcaml_atan_floatcaml_atan2_floatcaml_ceil_floatcaml_hypot_floatcaml_expm1_floatcaml_log1p_floatcaml_copysign_floatcaml_eq_floatcaml_neq_floatcaml_le_floatcaml_lt_floatcaml_ge_floatcaml_gt_floatcaml_float_comparecaml_classify_floatcaml_gc_statcaml_gc_quick_statcaml_gc_counterscaml_gc_getcaml_gc_setcaml_gc_minorcaml_gc_majorcaml_gc_full_majorcaml_gc_major_slicecaml_gc_compactioncaml_hashcaml_hash_univ_paramcaml_input_valuecaml_input_value_from_stringcaml_marshal_data_sizecaml_int_comparecaml_int_of_stringcaml_format_intcaml_int32_negcaml_int32_addcaml_int32_subcaml_int32_mulcaml_int32_divcaml_int32_modcaml_int32_andcaml_int32_orcaml_int32_xorcaml_int32_shift_leftcaml_int32_shift_rightcaml_int32_shift_right_unsignedcaml_int32_of_intcaml_int32_to_intcaml_int32_of_floatcaml_int32_to_floatcaml_int32_comparecaml_int32_formatcaml_int32_of_stringcaml_int32_bits_of_floatcaml_int32_float_of_bitscaml_int64_negcaml_int64_addcaml_int64_subcaml_int64_mulcaml_int64_divcaml_int64_modcaml_int64_andcaml_int64_orcaml_int64_xorcaml_int64_shift_leftcaml_int64_shift_rightcaml_int64_shift_right_unsignedcaml_int64_of_intcaml_int64_to_intcaml_int64_of_floatcaml_int64_to_floatcaml_int64_of_int32caml_int64_to_int32caml_int64_of_nativeintcaml_int64_to_nativeintcaml_int64_comparecaml_int64_formatcaml_int64_of_stringcaml_int64_bits_of_floatcaml_int64_float_of_bitscaml_nativeint_negcaml_nativeint_addcaml_nativeint_subcaml_nativeint_mulcaml_nativeint_divcaml_nativeint_modcaml_nativeint_andcaml_nativeint_orcaml_nativeint_xorcaml_nativeint_shift_leftcaml_nativeint_shift_rightcaml_nativeint_shift_right_unsignedcaml_nativeint_of_intcaml_nativeint_to_intcaml_nativeint_of_floatcaml_nativeint_to_floatcaml_nativeint_of_int32caml_nativeint_to_int32caml_nativeint_comparecaml_nativeint_formatcaml_nativeint_of_stringcaml_ml_open_descriptor_incaml_ml_open_descriptor_outcaml_ml_out_channels_listcaml_channel_descriptorcaml_ml_close_channelcaml_ml_channel_sizecaml_ml_channel_size_64caml_ml_set_binary_modecaml_ml_flush_partialcaml_ml_flushcaml_ml_output_charcaml_ml_output_intcaml_ml_output_partialcaml_ml_outputcaml_ml_seek_outcaml_ml_seek_out_64caml_ml_pos_outcaml_ml_pos_out_64caml_ml_input_charcaml_ml_input_intcaml_ml_inputcaml_ml_seek_incaml_ml_seek_in_64caml_ml_pos_incaml_ml_pos_in_64caml_ml_input_scan_linecaml_lex_enginecaml_new_lex_enginecaml_md5_stringcaml_md5_chancaml_get_global_datacaml_get_section_tablecaml_reify_bytecodecaml_register_code_fragmentcaml_realloc_globalcaml_get_current_environmentcaml_invoke_traced_functioncaml_static_alloccaml_static_freecaml_static_release_bytecodecaml_static_resizecaml_obj_is_blockcaml_obj_tagcaml_obj_set_tagcaml_obj_blockcaml_obj_dupcaml_obj_truncatecaml_obj_add_offsetcaml_lazy_follow_forwardcaml_lazy_make_forwardcaml_get_public_methodcaml_parse_enginecaml_set_parser_tracecaml_install_signal_handlercaml_ml_string_lengthcaml_create_stringcaml_string_getcaml_string_setcaml_string_equalcaml_string_notequalcaml_string_comparecaml_string_lessthancaml_string_lessequalcaml_string_greaterthancaml_string_greaterequalcaml_blit_stringcaml_fill_stringcaml_is_printablecaml_bitvect_testcaml_sys_exitcaml_sys_opencaml_sys_closecaml_sys_file_existscaml_sys_is_directorycaml_sys_removecaml_sys_renamecaml_sys_chdircaml_sys_getcwdcaml_sys_getenvcaml_sys_get_argvcaml_sys_system_commandcaml_sys_timecaml_sys_random_seedcaml_sys_get_configcaml_sys_read_directorycaml_terminfo_setupcaml_terminfo_backupcaml_terminfo_standoutcaml_terminfo_resumecaml_register_named_valuecaml_weak_createcaml_weak_setcaml_weak_getcaml_weak_get_copycaml_weak_checkcaml_weak_blitcaml_final_registercaml_final_releasecaml_ensure_stack_capacitycaml_dynlink_open_libcaml_dynlink_close_libcaml_dynlink_lookup_symbolcaml_dynlink_add_primitivecaml_dynlink_get_current_libscaml_record_backtracecaml_backtrace_statuscaml_get_exception_backtracegkL+-Out_of_memory)Sys_error'Failure0Invalid_argument+End_of_file0Division_by_zero)Not_found-Match_failure.Stack_overflow.Sys_blocked_io.Assert_failure:Undefined_recursive_module"%,,really_input%input@F@@G@&outputACDF@ACDG@%%.12g!."%d%false$true.bool_of_string$true%false+char_of_int/Pervasives.Exit_j_j_j_j_j_j<5Pervasives.do_at_exit@(array.mlD*Array.blit*Array.fill,Array.Bottom@)List.map2*List.iter2/List.fold_left20List.fold_right2-List.for_all2,List.exists2@@,List.combine'list.mlK-List.rev_map2#nth(List.nth"tl"hd@"\b"\t"\n"\r"\\"\'(Char.chr@5String.rcontains_from4String.contains_from2String.rindex_from1String.index_from +String.blit+String.fill*String.sub@)Sys.Break 4.00.0+dev15_2012-04-16+binannot@1Marshal.from_size3Marshal.from_string1Marshal.data_size *Marshal.to_buffer: substring out of bounds@@"%d_i_i_i_i_i_i_i_i_i@"%d_j_j_j_j_j_j_j_j_j@"%d_n_n_n_n_n_n_n_n_n@ %Lexing.lex_refill: cannot grow buffer @@ A@@@2Set.remove_min_elt@@@@@'Set.bal'Set.bal'Set.bal'Set.bal@2Map.remove_min_elt@@@&map.mlJ@@'Map.bal'Map.bal'Map.bal'Map.bal@:CamlinternalLazy.Undefined@)stream.mlwL@TL){count = ); data = !}&Sempty'Scons (", !)&Sapp (", !)%Slazy$Sgen'Sbuffio.Stream.Failure,Stream.Error@@@)buffer.mlsI2Buffer.add_channel4Buffer.add_substring>Buffer.add: cannot grow buffer*Buffer.nth+Buffer.blit*Buffer.sub@ !"!"!'!'!. )printf: bad positional specification (0)."%_)printf.mlH"'' )Printf: premature end of format string ``"''4 in format string ``1, at char number 8Printf: bad conversion % (Sformat.index_of_int: negative argument @ ! "%s"%s.bool_of_string)a boolean-int_of_string*an integer-int_of_string*an integer/float_of_string'a float/float_of_string'a float ! (one of: #(?)&--help%-help9%s: unknown option `%s'. 1%s: wrong argument `%s'; option `%s' expects %s. #%s: option `%s' needs an argument. (%s: %s. %-help&--help"%s#%s %-help= Display this list of options%-help&--help= Display this list of options&--help%-help( %s %s !}!|!{* %s %s%s &'Arg.Bad(Arg.Help(Arg.Stop@ &, %s%sA#%s ;(Program not linked with -g, cannot print stack backtrace) A#%s ;(Program not linked with -g, cannot print stack backtrace) )Raised at,Re-raised at Raised by primitive operation at+Called from '%s file "%s", line %d, characters %d-%d3%s unknown location7Uncaught exception: %s 7Uncaught exception: %s -Out of memory.Stack overflow7Pattern matching failed0Assertion failed:Undefined recursive module&(%s%s) $(%s)"%d"%S!_ (File "%s", line %d, characters %d-%d: %s@/Digest.from_hex/Digest.from_hex$%02x0Digest.substring@_i_j A_j,Random.int64_i,Random.int32*Random.int!xzR+]F4J{lGgP2wAv+^  FKk|HHtcHZš/{Yi2zvn6m[b"|ᵟ.xge=xBLX?}nSO}YE] ~N~aNw"\(sd}@*LY= зd(.OR.2E9!DLJ<AGu<*UO^ohf6o/z@@-OCAMLRUNPARAM,CAMLRUNPARAM @.bad box format/bad box name ho:bad tag name specification:bad tag name specification 9bad integer specification*bad format& (%c)."%c =Format.fprintf: %s ``%s'', giving up at character number %d%s@C!.!>"![@ %@ ]@]#,@ 2@[@[{.@ (@]@ .}@]8My_std.Set.Make(M).Found/@[<2>Some@ %a@]$None.My_std.Exit_OK1My_std.Exit_usage8My_std.Exit_system_error5My_std.Exit_with_code>My_std.Exit_silently_with_code%Win32@5ocamlbuild/my_unix.mlpPn^+readlink %s)%s > '%s'7Error while running: %s#out*ocamlbuildzs2My_unix.Not_a_link4My_unix.No_such_file )My_unix.Link_to_directories_not_supported@#,@ %@[<0>"@]@;# Target: %s, tags: { %a } ) # cached &%s%s@.1[cache hit] %s %!%%s %!"%s$, %s"un =# Compilation %ssuccessful.@.&%a%a%!"%a !s 'Compilation unsuccessful after building)Finished, !%s %d target%s (%d cached) in %a.%%a %!&%a%a%!"%a:%a %-4d (%-4d) %a %s %s %s$%a%!5ocamlbuild/display.mlB #%*s.%02d:%02d:%02dGACD@4### Starting build. $Unix)tput cols! #%[%dA ?%ocamlO&nativeN$byteB'programP"ppR%debugD&interfI$linkL@#...(STARTING(FINISHED ?!-!/!|!\!*! @$@]@.%@[<2>6y@"mv#-Rf"rm".a".a#-pf"cp%mkdir! %Win32 )Error during command `%s'. Exit code %d. ;Error during command %S: %s%Win32$'%s'@@4Glob_ast.Parse_error@~@}l@ IAmbiguous ** pattern not allowed unless surrounded by one or more slashes 'Unexpected character %C in glob pattern !Unexpected character %C in stringmmoooo@, nS0 n   n,,15 F/)&'44(*4.  2%6   - $$!$$$$$$$$$$3$$$$$$$$$$$$$$$$$$$$$$$$$$"$$$$$$$$$$$$$$$$$$$$$$$$$$$#$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ F- !&13')2+,  0"2 +,0$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$4$$$$$$$$$$$$$$$$$$$$$$$$$$+,0 @?Unexpected token %s in atomizer &Unexpected token, expecting %s, got %s +Trying to unput token %s while %s is activeoo@ 2ocamlbuild/glob.mlH# %d'%d %C {% } %!#AND"OR#NOT$LPAR$RPAR$TRUE%FALSE#EOF$ATOM2Glob.Brute.Succeed/Glob.Brute.Fail3Glob.Brute.Too_hard@ 6>268??>=>?>?<Y?YXV>XU>?_^Y_>^X_W^ `_`^t tx yRBxYx`'` tY`Jx yxt\V{\U tG\[O#\V\UzYcc'#w#\+[c}+cccecfxY+xgcg37x3h37ht:g:h:Twxxx]]j]x]ktvrvstttTvwttTcuzr     U ( (   ^(s AC!I!D$%$%&!E&)K),H,!-~$-%L.&M.P)$/%,/g&0-)0|j1,.14-45/56.8608/19940;<5;<168=4=5>96>?;<?@9@Y=Y;<QQ>QQS=?SW@>WZY[Z?[Qa@Qa````t tu uQA vCSv `(W tZ[IwwDvzXXzXXvEKHXXLMP!\\\\tXbb$%v&g\)d\d,jeb|e-bbb.bbbdx\/xeddd0bdeee1ef4fx5d6h8ehx9f;<fffhf=hhh>hf?@iihQxSkyykyWiZl[liiiainkny`kkklikylllnlknnnnpplpp{{{nXpy{p\bdpe{fhiklnp  !&+-123;<@KXYZ^ghiv.:@FR? -< %%%AIIVVccpp}}     DQ^ kx     55LL 5L*2YY2Yffssfs     ~!!$%&$%&)-/,.,.1b1!$%&44!,.$%&1569569<<41=>?=>?4569<QQQQ569=>?SWZSWZ[=[?QXXXX\\\\eeXQ\eSWZeee[eX\e!$%&1456QSWZ[X\e       @ JWarning: tag %S does not expect a parameter, but is used with parameter %S #Warning: tag %S expects a parameter&%s(%s)@,%Win32"''#nop4@[<2>Echo(%a,@ %a)@]!]!;![ .Exit code %d while executing this command:@ %s%Win32(jobs < 0@@ 5# No parallelism done ]# Parallel statistics: { count(total): %d(%d), max: %d, min: %d, average(total): %.3f(%.3f) }"%a"%S %Win32$.exe Zno solver for the virtual command %S (setup one with Command.setup_virtual_command_solver) Hthe solver for the virtual command %S has failed finding a valid command $PATH%Win32'$PATH: .no_tag_handler@9ar rc %s %s %s; ranlib %s"-l //home/lefessan/.ocaml/roots/ocaml-4.00-binannot$/bin*/lib/ocaml)/stublibs$/man!1&ranlib&ranlib"ar%amd64!10-cclib -lpthread! '-lX11 +-I/usr/include/tcl8.5 -I/usr/include/tk8.5 8 -ltk8.5 -ltcl8.5 -ldl #gcc 8-fno-defer-pop -Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT' -Wl,-E= -lm -ldl -lcurses -lpthread+-Wl,-rpath, %-fPIC+-Wl,-rpath,&-Wl,-E%amd64'default%linux#gcc )-Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT )-Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT +-Wl,-rpath,* -lm -ldl"as&gcc -c+-DPROFILING$prof% -ldl =unix str num dynlink bigarray systhreads threads graph labltk-ocamldebugger#-pg%ld -r$ -o ! !o!a"so".o".s".a#.so "cc"cc$cmxs+gcc -shared+gcc -shared*noruntimed&camlp4@*ocamlbuild(OCAMLLIB@3ocamlbuild/slurp.mlhJ'Nothing !@[<2>Dir(%S,@ %S,@ _,@ %a,@ %a)@]=@[<2>File(%S,@ %S,@ _,@ %a)@](Error(_)/OCAMLBUILD_FIND$find%%s %s@@ @ :Included or excluded directories must be implicit (not %S);Usage %s [options] :Bad log file name: the file name must be implicit (not %S)&ocamlc(ocamlopt(ocamldep(ocamldoc*ocamlmktop 'jocamlc)jocamlopt)jocamldep*jocamlyacc)jocamllex+jocamlmklib+jocamlmktop)jocamlrun)OCAMLFIND$.opt$.opt+ocamlbuild &_build+sanitize.sh&ocamlc(ocamlopt(ocamldep(ocamldoc)ocamlyacc&menhir(ocamllex*ocamlmklib*ocamlmktop)ocamlfind@&OCAMLC(OCAMLOPT(OCAMLDEP(OCAMLDOC(OCAMLLEX*OCAMLMKLIB*OCAMLMKTOP%quiet@@$_log$.svn#CVS@@6*invalid-dummy-string* L Stop argument processing, remaining arguments are given to the user program"--? Set the ocamlrun tool)-ocamlrun ! Set the ocamlmktop tool+-ocamlmktop? Set the ocamllex tool)-ocamllex 8 Set the menhir tool (use it after -use-menhir)'-menhir Set the ocamlyacc tool*-ocamlyacc / Set the OCaml documentation generator)-ocamldoc ' Set the OCaml dependency tool)-ocamldep ' Set the OCaml native compiler)-ocamlopt ) Set the OCaml bytecode compiler'-ocamlc & Display the install library directory&-where ' Set the install binary directory0-install-bin-dir ( Set the install library directory0-install-lib-dir - Set build directory (implies no-links)*-build-dir * Allow N jobs at once (0 for unlimited)"-j & Use ocamlfind to call ocaml compilers.-use-ocamlfind + Use jocaml compilers instead of ocaml ones+-use-jocaml Use menhir instead of ocamlyacc+-use-menhir 0 Display executed commands the old-fashioned way0-classic-display & Fail if something needs to be rebuilt:-nothing-should-be-rebuilt $ Do not generate sanitization script,-no-sanitize ; Change the file name for the generated sanitization script4-sanitization-script ' Use the option only when plugin is run.-plugin-option ' Don't use a native plugin but bytecode,-byte-plugin; Just build myocamlbuild.ml,-just-plugin F Don't catch and display exceptions (useful to display the call stack)2-dont-catch-errors< Don't ignore stdlib modules*-no-stdlib< Don't build myocamlbuild.ml*-no-plugin? Don't apply sanity-check rules+-no-hygiene F Don't skip modules that are requested by ocamldep but cannot be built(-no-skip + Don't make links of produced final targets)-no-links - Don't try to build these modules'-ignore . Show tags that applies on that pathname*-show-tags ) Use this line of tags (as in _tags))-tag-line0 (idem)%-tags9 Add to default tags$-tag1 (idem)#-pp ' Add to ocaml preprocessing flags'-ppflag1 (idem))-lexflags< Add to ocamllex flags(-lexflag1 (idem)*-yaccflags= Add to ocamlyacc flags)-yaccflag1 (idem))-docflags< Add to ocamldoc flags(-docflag1 (idem)'-cflags " Add to ocamlc compile flags&-cflag1 (idem)'-lflags? Add to ocamlc link flags&-lflag0 (idem)(-package4 (idem)%-pkgs , Link to this ocaml findlib package$-pkg3 (idem)%-mods " Link to this ocaml module$-mod1 (idem)%-libs ! Link to this ocaml library$-lib1 (idem)#-Xs: Directory to ignore"-X I (same as above, but accepts a (comma or blank)-separated list)#-Is ! Add to include directories"-I 1 Traverse directories by default (true: traverse)"-r 2 Remove build directory and other files, then exit&-clean, No log file'-no-log3 Set log file$-log5 Show rules and flags.-documentation? Set the verbosity level(-verbose: Make as quiet as possible&-quiet; Display the version number%-vnum4 Display the version(-version@!."..".. -Pathname.normalize_list: .. is forbidden here >chop_extensions: no extensions !.o\@/<**/{,.,..}/**>!.6ocamlbuild/pathname.mlIJ"..JJ@", (true: %s", &%S: %s (file: %S": *string: %S@@# %s)rm -f %s ;File %s in %s has suffix %s ,Files %s and %s should not be together in %s !s U@[SANITIZE:@ a@ total@ of@ %d@ file%s@ that@ should@ probably@ not@ be@ in@ your@ source@ tree@ has@ been@ found.@ A@ script@ shell@ file@ %S@ is@ being@ created.@ Check@ this@ script@ and@ run@ it@ to@ remove@ unwanted@ files@ or@ use@ other@ options@ (such@ as@ defining@ hygiene@ exceptions@ or@ using@ the@ -no-hygiene@ option).@]ACDF@ 1#!/bin/sh # File generated by ocamlbuild cd %s ?# Also clean the script itself )rm -f %s Ssanitize: the following are files that should probably not be in your source tree: Remove them manually, don't use the -no-sanitize option, use -no-hygiene, or define hygiene exceptions using the tags or plugin mechanism. ?Hygiene.Exit_hygiene_violations@&%S: %S'%S: %S (_digests@ &%%=%s *%%(%s)=%s (Some(%a)$None6ocamlbuild/resource.mlWf[Z8%a exists and up to date $%a exists in source dir -> import it*Resource: *Resource: 5resource_changed:@ %a3@ @[<2>%a =>@ %a@];0@[@[{:(@]@ :}@]3@ @[<2>%a =>@ %a@];0@[@[{:&@]:}@] Q@[<2>{ @[<2>built =@ %a@];@ @[<2>changed =@ %a@];@ @[<2>dependencies =@ %a@]@ }@]&Bbuilt0Bcannot_be_built.Bnot_built_yet /@[<2>Bsuspension(%a,@ ( : unit -> unit))@]#Yes"No'Unknown0in_build_dir: %S1in_source_dir: %S=Resource.MetaPath.No_solution@#cmp%chmod"-f"rm"-s"ln"-f"ln"-p"cp"cp"mv 2in rule %s, multiple occurences of the resource %s &Can't make a rule that produce nothing #Rule.add_rule: already exists: (%a)A+end rule %a-mid rule %a: Lcache miss: no digest found for %S (the command, a dependency, or a product))cache hit )cache miss: a dependency has changed (%a) 1cache miss: a dynamic dependency has changed (%a) ]cache miss: the digest has changed for %S (the command, a dependency, or a product: %a <> %a) .cache miss: a product is not in build dir (%a)9new dyndep for %S(%a): %S-start rule %a+dyndeps: %anAu@ (Need to rebuild %a through the rule `%a'&Rule: &Rule: &prods:%deps:(dyndeps:%deps:(dyndeps:'%s (%a) -@[rule@ %S@ ~deps:%a@ ~prods:%a@ @] u@[{@ @[<2>name =@ %S@];@ @[<2>tags =@ %a@];@ @[<2>deps =@ %a@];@ @[<2>prods = %a@];@ @[<2>code = @]@]@ }2ocamlbuild/rule.mloR4Rule.Exit_rule_error+Rule.Failed0Rule.Can_produce@4ocamlbuild/solver.mlAP"==(==%a> %a0%a already built1%a already failed<%a was suspended -> resuming@@0>>> PARALLEL: %d,<<< PARALLELW;-Solver.Failed/Solver.Circular@  Ocamlbuild knows of no rules that apply to a target named %a. This can happen if you ask Ocamlbuild to build a target with the wrong extension (e.g. .opt instead of .native) or if the source files live in directories that have not been specified as include directories. Ocamlbuild cannot find or build %a. A file with such a name would usually be a source file. I suspect you have given a wrong target name to Ocamlbuild.6@ - @[<2>Building %a@] '@ - @[Failed to build all of these:"@]:@ - @[Building %a:%a@] *@ - @[<2>Failed to build the target %s%a@] #<*.ml> or <*.mli> or <*.c> or <*.h>@/@[<2>Some@ %a@]$None*extension:%file:@% %s 9IMPORTANT: I cannot work with leftover compiled files. %!%ERROR'Warning(%s: %s: 3Doing sanity checks7Fda.Exit_hygiene_failed Leftover OCaml compilation files$.cmo$.cmi$.cmx$.cma%.cmxa@A $Leftover OCaml type annotation files&.annot@@5Leftover object files".o".a#.so$.obj$.lib$.dll@A "Leftover ocamlyacc-generated files$.mly#.ml$.mly$.mli@A !Leftover ocamllex-generated files$.mll#.ml@A9Leftover dependency files+.ml.depends,.mli.depends@A@@?%s query -l -predicates byte %s (%s query -a-format -predicates native %s8%s query -r -p-format %s"-I"-I 7%s list | cut -d' ' -f15Cannot run Ocamlfind. [Ocamlfind returned "%s" as a dependency for package "%s" but does not know this dependency. Findlib package not found: "%s". 1Cannot parse Ocamlfind query for package "%s": %s5Findlib.Findlib_error)ocamlfind@&@ %a%a2@[dir %S%a%a@]7@[dir_pack %S%a%a@]0@[<2>file %S%a@] )-for-pack A@[<2>@[<2>include_dirs_table:@ %a@];@ @[<2>for_pack_table: %a@]@] 3@ @[<2>%S =>@ %a@];0@[{:@[(@]@ :}@] [@ @[{ @[<2>current_path =@ %S@];@ @[<2>include_dirs =@ %a@];@ @[<2>for_pack =@ %S@] }@] @@ @ !.@ FOcamldep.ocamldep: multiple files in ocamldep output (%s not expected) "Ocamldep.ocamldep: bad output (%s),nopervasives*Pervasives'depends"-I%ocaml"-I$use_$.cma$link$byte@%ocaml%.cmxa$link&native@%ocaml Docaml_lib: ~byte:false or ~native:false only works with ~extern:true'compile#doc/infer_interface@"-I"pp%ocaml#-pp !This module (%s) is ignored by %s&-whereA#cmi:Ocaml_utils.Ocamldep_error@ Athe file %S is included in more than one active open package (%a)$.cmi @ %a3@ @[<2>%S =>@ %a@];0@[{:@[(@]@,:}@] (Ocaml_dependencies.Circular_dependencies@"ml#mli'depends'depends'profile&shared!p&p.cmxa%p.cmx!p%p.cmx'profile!p&p.cmxa%p.cmx!p%p.cmx'library&shared&native$link%ocaml&shared$cmxa#cmx#cmx$cmxa#cmx#cmx'profile&native$pack%ocaml!p&p.cmxa%p.cmx#cmi@@!p#cmi%p.cmx&native$pack%ocaml$cmxa#cmx#cmi@@#cmi#cmx%debug$byte$pack%ocaml$byte$pack%ocaml%debug(toplevel$byte$link%ocamlA-stdlib/stdlib'profile'program'profile&native$link%ocaml#cmi@!p!p&p.cmxa%p.cmx'program&native$link%ocaml#cmi@$cmxa#cmx%debug'program%debug$byte$link%ocaml'program$byte$link%ocaml)link_with#cmi-stdlib/stdlib9Link list cannot be empty.link: %a -o %a.dont_link_with6prepare_libs: %S -> %a#cmx#cmi#cmi@&implem&implem&interf /infer_interface&thread'-thread"-i(ocamllex%lexer%ocaml)OCAMLYACC)ocamlyacc&parser%ocaml!>&MENHIR'compile$byte%ocaml&menhir&parser%ocaml&--base'--infer(--ocamlc/menhir_ocamldep%ocaml&--base#mly@/menhir_ocamldep%ocaml&MENHIR!>*--ocamldep,--raw-depend(ocamldep%ocaml(-modules@&pp:dep@"%c"-w'warn_%c'compile%ocaml"%c+-warn-error-warn_error_%c'compile%ocaml"%c"-w'warn_%c'compile%ocaml"%c+-warn-error-warn_error_%c'compile%ocaml"pp%ocaml"pp%ocaml#-pp#-pp#-pp#-pp'-inline)-for-pack'-syntax+-predicates(-package'package)predicate&syntax$.cmx$.cmo%.cmxa$.cma#%.c&native"-c'compile!c#-sf"ln)%.itarget!%!%!%#%.p#%.p#%.p)%.otarget)%.itarget,target files%%.cmi%%.mli%%.cmi%%.mli-%.mli.depends@%ocaml@1ocaml: mli -> cmi'%.d.cmo(%.mlpack(%.mlpack%%.cmi@'%.d.cmo@%ocaml%debug$byte@ %ocaml: mlpack & d.cmo* -> d.cmo & cmi%%.cmo(%.mlpack%%.cmo%%.mli%%.cmi(%.mlpack@%ocaml$byte@ !ocaml: mlpack & cmo* & cmi -> cmo%%.cmo(%.mlpack(%.mlpack%%.cmo%%.cmi@%ocaml$byte@ !ocaml: mlpack & cmo* -> cmo & cmi'%.d.cmo$%.ml%debug'%.d.cmo%%.mli$%.ml,%.ml.depends%%.cmi@%ocaml$byte@8ocaml: ml & cmi -> d.cmo%%.cmo$%.ml%%.cmo%%.mli$%.ml,%.ml.depends%%.cmi@%ocaml$byte@6ocaml: ml & cmi -> cmo'%.p.cmx(%.mlpack(%.mlpack%%.cmi@'%.p.cmx%ocaml'profile&native@ 2ocaml: mlpack & cmi & p.cmx* & p.o* -> p.cmx & p.o%%.cmx(%.mlpack(%.mlpack%%.cmi@%%.cmx%ocaml&native@ *ocaml: mlpack & cmi & cmx* & o* -> cmx & o$%.ml%p.cmx'profile$%.ml,%.ml.depends%%.cmi@'%.p.cmx%ocaml&native'profile@>ocaml: ml & cmi -> p.cmx & p.o$%.ml$%.ml,%.ml.depends%%.cmi@%%.cmx%ocaml&native@:ocaml: ml & cmi -> cmx & o'%.d.cmo$%.ml%debug$%.ml,%.ml.depends%%.cmi@'%.d.cmo@%ocaml%debug@8ocaml: ml -> d.cmo & cmi%%.cmo$%.ml$%.ml,%.ml.depends@%%.cmo%%.cmi@%ocaml@6ocaml: ml -> cmo & cmi(%.d.byte'%.d.cmo'%.d.cmo(%.d.byte%ocaml$byte%debug'program@7ocaml: d.cmo* -> d.byte&%.byte%%.cmo%%.cmo&%.byte%ocaml$byte'program@3ocaml: cmo* -> byte*%.p.native'%.p.cmx*%.p.native'%.p.cmx%ocaml&native'profile'program@ ocaml: p.cmx* & p.o* -> p.native(%.native%%.cmx(%.native%%.cmx%ocaml&native'program@:ocaml: cmx* & o* -> native'%.d.cma'%.mllib'%.mllib'%.d.cma%ocaml$byte%debug'library@>ocaml: mllib & d.cmo* -> d.cma%%.cma'%.mllib'%.mllib%%.cma%ocaml$byte'library@:ocaml: mllib & cmo* -> cma'%.d.cma'%.d.cmo'%.d.cmo'%.d.cma%ocaml$byte%debug'library@6ocaml: d.cmo* -> d.cma%%.cma%%.cmo%%.cmo%%.cma%ocaml$byte'library@2ocaml: cmo* -> cma1%(path)%(libname)4%(path)lib%(libname)9%(path)lib%(libname).clib9%(path)lib%(libname).clib ,%(path:<**/>)dll%(libname:<*> and not <*.*>) ,%(path:<**/>)lib%(libname:<*> and not <*.*>) 4ocaml C stubs: clib & (o|obj)* -> (a|lib) & (so|dll)(%.p.cmxa'%.mllib'%.mllib(%.p.cmxa%ocaml&native'profile'library@ ,ocaml: mllib & p.cmx* & p.o* -> p.cmxa & p.a&%.cmxa'%.mllib'%.mllib&%.cmxa%ocaml&native'library@ $ocaml: mllib & cmx* & o* -> cmxa & a(%.p.cmxa'%.p.cmx'%.p.cmx(%.p.cmxa%ocaml&native'profile'library@ "ocaml: p.cmx & p.o -> p.cmxa & p.a&%.cmxa%%.cmx%%.cmx&%.cmxa%ocaml&native'library@:ocaml: cmx & o -> cmxa & a(%.p.cmxs)%.mldylib)%.mldylib(%.p.cmxs%ocaml&native'profile&shared'library@ /ocaml: mldylib & p.cmx* & p.o* -> p.cmxs & p.so&%.cmxs)%.mldylib)%.mldylib&%.cmxs%ocaml&native&shared'library@ 'ocaml: mldylib & cmx* & o* -> cmxs & so(%.p.cmxs'%.p.cmx'profile@'%.p.cmx(%.p.cmxs%ocaml&native'profile&shared'library@ #ocaml: p.cmx & p.o -> p.cmxs & p.so(%.p.cmxs(%.p.cmxa'profile'linkall@(%.p.cmxa(%.p.cmxs%ocaml&native'profile&shared'library@ $ocaml: p.cmxa & p.a -> p.cmxs & p.so&%.cmxs%%.cmx%%.cmx&%.cmxs@%ocaml&native&shared'library@6ocaml: cmx & o -> cmxs&%.cmxs%%.cmx%%.cmx&%.cmxs%ocaml&native&shared'library@;ocaml: cmx & o -> cmxs & so&%.cmxs&%.cmxa'linkall@&%.cmxa&%.cmxs%ocaml&native&shared'library@ cmxs & so,%.ml.depends$%.ml$%.ml,%.ml.depends5ocaml dependencies ml-%.mli.depends%%.mli%%.mli-%.mli.depends6ocaml dependencies mli%%.mll%%.mll$%.ml%ocaml@(ocamllex&%.odoc%%.mli&%.odoc%%.mli-%.mli.depends@%ocaml#doc@2ocaml: mli -> odoc&%.odoc$%.ml&%.odoc$%.ml,%.ml.depends@%ocaml#doc@1ocaml: ml -> odoc(%.docdir3%.docdir/index.html'%.odocl3%.docdir/html.stamp'%.odocl3%.docdir/index.html ?ocamldoc: document ocaml project odocl & *odoc -> docdir (html)(%.docdir,%.docdir/man'%.odocl2%.docdir/man.stamp'%.odocl,%.docdir/man >ocamldoc: document ocaml project odocl & *odoc -> docdir (man)-%(dir).docdir5%(dir).docdir/%(file),%(dir).odocl,%(dir).odocl5%(dir).docdir/%(file) Bocamldoc: document ocaml project odocl & *odoc -> man|latex|dot...*use_menhir1%.mlypack.depends)%.mlypack!%)%.mlypack@%%.mli$%.ml@?ocaml: modular menhir (mlypack)1%.mlypack.depends)%.mlypack)%.mlypack1%.mlypack.depends "ocaml: menhir modular dependencies%%.mly%%.mly-%.mly.depends@$%.ml%%.mli@-ocaml: menhir-%.mly.depends%%.mly%%.mly-%.mly.depends:ocaml: menhir dependencies%%.mly%%.mly$%.ml%%.mli@%ocaml@)ocamlyacc#%.c5ocaml C stubs: c -> o.%.inferred.mli$%.ml.%.inferred.mli$%.ml,%.ml.depends@ .ocaml: ml & ml.depends & *cmi -> .inferred.mli%%.top'%.mltop'%.mltop%%.top3ocaml: mltop -> top'%.pp.ml$%.ml%pp.ml$%.ml'%.pp.ml7preprocess: ml -> pp.ml%ocaml"pp@%ocaml'compile@%ocaml$link@%ocaml)ocamlyacc@%ocaml&menhir@%ocaml#doc@)--explain@%ocaml&menhir'explain@%ocaml(ocamllex@#-ml@%ocaml(ocamllex+generate_ml@%ocaml$byte$link@%ocaml&native$link@%ocaml$byte$link@%ocaml&native$link@(-linkpkg%ocaml$link'program@(-linkpkg%ocaml$link(toplevel@%ocaml$byte'compile@%ocaml&native'compile@%ocaml$byte$link@%ocaml&native$link@%ocaml(ocamldep@%ocaml#doc@%ocaml%mktop@%ocaml/infer_interface@@%ocaml$byte'compile@%ocaml&native'compile@%ocaml$byte$link@%ocaml&native$link@(for-pack%ocaml&native'compile@&inline%ocaml&native'compile@"pp%ocaml'compile@"pp%ocaml(ocamldep@"pp%ocaml#doc@"pp%ocaml/infer_interface@'camlp4o'camlp4r(camlp4of(camlp4rf)camlp4orf)camlp4oof@)camlp4orr(camlp4of'-parser(reloaded@)camlp4rrr(camlp4rf'-parser(reloaded@@(-no_quot%ocaml"pp.camlp4:no_quot@'dynlinkA$unixA#strA(bigarrayA$numsA#dbmA(graphicsA+toplevellib,use_toplevelA&labltk'+labltkA(ocamldoc)+ocamldocA-ocamlbuildlib.use_ocamlbuild++ocamlbuildA)camlp4lib*use_camlp4'+camlp4A&camlp4.use_old_camlp4'+camlp4A-camlp4fulllib/use_camlp4_full'+camlp4A"-I5+camlp4/Camlp4Parsers"-I6+camlp4/Camlp4Printers"-I5+camlp4/Camlp4Filters@%ocaml'compile/use_camlp4_full@5+camlp4/Camlp4Bin.cmo%ocaml.use_camlp4_bin$link$byte@5+camlp4/Camlp4Bin.cmx%ocaml.use_camlp4_bin$link&native@"-g%ocaml%debug'compile$byte@"-g%ocaml%debug$link$byte'program@"-g%ocaml%debug$pack$byte@"-g%ocaml%debug'compile&native@"-g%ocaml%debug$link&native'program@"-g%ocaml%debug$pack&native@+-output-obj%ocaml$link&native*output_obj@+-output-obj%ocaml$link$byte*output_obj@'-dtypes%ocaml&dtypes'compile@&-annot%ocaml%annot'compile@)-rectypes%ocaml(rectypes'compile@)-rectypes%ocaml(rectypes/infer_interface@)-rectypes%ocaml(rectypes#doc@(-linkall%ocaml'linkall$link@"-p%ocaml$link'profile&native@'-custom%ocaml$link'program&custom$byte@'-custom%ocaml$link'library&custom$byte@"-p%ocaml'compile'profile&native@'-thread%ocaml'compile&thread@"-I(+threads@%ocaml#doc&thread@,threads.cmxa'-thread@%ocaml$link&thread&native'program@+threads.cma'-thread@%ocaml$link&thread$byte'program@,threads.cmxa'-thread@%ocaml$link&thread&native(toplevel@+threads.cma'-thread@%ocaml$link&thread$byte(toplevel@'-thread%ocaml$link&thread'program@--nopervasives%ocaml'compile,nopervasives@)-nolabels%ocaml'compile(nolabels@"-q%ocaml(ocamllex%quiet@ACDEFLMPRSUVYZX@%-html%ocaml#doc&docdir.extension:html@$-man%ocaml#doc&docdir'manpage@$-dot%ocaml#doc'docfile-extension:dot@&-latex%ocaml#doc'docfile-extension:tex@&-latex%ocaml#doc'docfile-extension:ltx@%-texi%ocaml#doc'docfile.extension:texi@-ocamlbuildlib2ocamlbuildlightlib".o!o*ocamlmklib!c"-o@.-plugin-option*-no-plugin2ocamlbuildlib.cmxa 1Warning: Won't be able to compile a native plugin"-p#cmx$cmxa"-g#cmo#cma2ocamlbuildlightlib/ocamlbuildlight@$unix*ocamlbuild-ocamlbuildlib -Cannot find %S in ocamlbuild -where directory"-o"-I,myocamlbuild#.ml*_config.ml+_config.mli'profile%debug@@@ "Exiting due to hygiene violations.+Usage:@ %s.2System error:@ %s. 9@[@[<2>Solver failed:@ %a@]@ @[Backtrace:%a@]@]@.-Failure:@ %s. 0Circular build detected@ (%a already seen in %a) pINTERNAL ERROR: Invalid argument %s This is likely to be a bug, please report this to the ocamlbuild developers.2Ocamldep error: %s:Lexical analysis error: %s"%s"%s"%s"%a.Exception@ %s.#-sf"ln$byte$html&native#top FWarning: Won't execute %s whose extension is neither .byte nor .native,not_hygienic(precious%_tags&_oasis@'include(traverse'package <<**/*.ml> or <**/*.mli> or <**/*.mlpack> or <**/*.ml.depends>: ocaml <**/*.byte>: ocaml, byte, program <**/*.odoc>: ocaml, doc <**/*.native>: ocaml, native, program <**/*.cma>: ocaml, byte, library <**/*.cmxa>: ocaml, native, library <**/*.cmo>: ocaml, byte <**/*.cmi>: ocaml, byte, native <**/*.cmx>: ocaml, native %_tags/myocamlbuild.ml(traverse@Circular dependencies: %S already seen in@ %a@]@.=@[<2>flag@ {. %a .}@ %S@]@ @ &%a@ @ "@.=@[<2>Tags for %S:@ {. %a .}@]5Main.Exit_build_error2Main.Exit_silently@@@9ar rc %s %s %s; ranlib %s"-l //home/lefessan/.ocaml/roots/ocaml-4.00-binannot$/bin*/lib/ocaml)/stublibs$/man!1&ranlib&ranlib"ar%amd64!10-cclib -lpthread! '-lX11 +-I/usr/include/tcl8.5 -I/usr/include/tk8.5 8 -ltk8.5 -ltcl8.5 -ldl #gcc 8-fno-defer-pop -Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT' -Wl,-E= -lm -ldl -lcurses -lpthread+-Wl,-rpath, %-fPIC+-Wl,-rpath,&-Wl,-E%amd64'default%linux#gcc )-Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT )-Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT +-Wl,-rpath,* -lm -ldl"as&gcc -c+-DPROFILING$prof% -ldl =unix str num dynlink bigarray systhreads threads graph labltk-ocamldebugger#-pg%ld -r$ -o ! !o!a"so".o".s".a#.so "cc"cc$cmxs+gcc -shared+gcc -shared*noruntimed&camlp4@&-cclib;otherlibs/labltk/lib/labltk)labltktop3exec %s -I %s "$@" *#!/bin/sh (unix.cma"-I-otherlibs/str"-I&stdlib'str.cma,topstart.cmo@"-I*labltk.cma4otherlibs/labltk/lib"-I7otherlibs/labltk/camltk"-I7otherlibs/labltk/labltk"-I/toplevellib.cma(toplevel"-I8otherlibs/labltk/support"-I>otherlibs/labltk/lib/labltktop"-o(-linkall(-verbose8otherlibs/labltk/support7otherlibs/labltk/labltk7otherlibs/labltk/camltk>otherlibs/labltk/camltk/camltk>otherlibs/labltk/labltk/labltk;otherlibs/labltk/camltk/cTk:otherlibs/labltk/labltk/tk?otherlibs/labltk/camltk/_cTk.ml !otherlibs/labltk/compiler/pp.byte!>otherlibs/labltk/camltk/cTk.ml@ V(echo '##define CAMLTK'; echo 'include Camltkwrap'; echo 'open Widget'; echo 'open Protocol'; echo 'open Textvariable'; echo ; cat otherlibs/labltk/builtin/report.ml; echo ; cat otherlibs/labltk/builtin/builtin_*.ml; echo ; cat otherlibs/labltk/camltk/_tkgen.ml; echo ; echo ; echo 'module Tkintf = struct'; cat otherlibs/labltk/builtin/builtini_*.ml; cat otherlibs/labltk/camltk/_tkigen.ml; echo 'end (* module Tkintf *)'; echo ; echo ; echo 'open Tkintf' ;echo ; echo ; cat otherlibs/labltk/builtin/builtinf_*.ml; cat otherlibs/labltk/camltk/_tkfgen.ml; echo ; ) > otherlibs/labltk/camltk/_cTk.ml>otherlibs/labltk/labltk/_tk.ml !otherlibs/labltk/compiler/pp.byte!<>otherlibs/labltk/labltk/_tk.ml!>=otherlibs/labltk/labltk/tk.ml@ 9(echo 'open StdLabels'; echo 'open Widget'; echo 'open Protocol'; echo 'open Support'; echo 'open Textvariable'; cat otherlibs/labltk/builtin/report.ml; cat otherlibs/labltk/builtin/builtin_*.ml; cat otherlibs/labltk/labltk/_tkgen.ml; echo ; echo ; echo 'module Tkintf = struct'; cat otherlibs/labltk/builtin/builtini_*.ml; cat otherlibs/labltk/labltk/_tkigen.ml; echo 'end (* module Tkintf *)'; echo ; echo ; echo 'open Tkintf' ;echo ; echo ; cat otherlibs/labltk/builtin/builtinf_*.ml; cat otherlibs/labltk/labltk/_tkfgen.ml; echo ; ) > otherlibs/labltk/labltk/_tk.ml3compiler/tkcompiler'-camltk'-outdir&camltk@"&&0otherlibs/labltk"cd#mli"ml3compiler/tkcompiler'-outdir&labltk@"&&0otherlibs/labltk"cd#mli"ml &otherlibs/labltk/compiler/copyright.ml ";; let write ~w = w copyright;;@ #otherlibs/labltk/compiler/copyright1let copyright = "'%.mlast$%.ml"-o%-impl%trash'-filter$meta'-filter$fold'-filter#map'-filter!r(-printer%%.ml4$%.ml"-o#OPT"-D!o(-printer%-impl'INCLUDE8Camlp4deps parse failure=camlp4/Camlp4/Struct/Lexer.ml(-printer!r"-o4camlp4/boot/Lexer.ml@"-o(-linkall&native$link%ocaml,dynlink.cmxa"-I"-o(-linkall$byte$link%ocaml+dynlink.cma"-I&camlp4$byte&native"-I)unix.cmxa(unix.cma@@@$unix)unix.cmxa(unix.cma@@#cmo@#cmx@@@'dynlink,dynlink.cmxa+dynlink.cma2T3ocaml: cmo* -> byte2T:ocaml: cmx* & o* -> native"-o(-linkall$byte$link%ocaml"-a&camlp4#cma#cmo@2T:ocaml: mllib & cmo* -> cma' end;; * = struct 'module 7camlp4/Camlp4_import.ml!>/asmcomp/emit.ml@!<3tools/cvt_emit.byte'asmcomp'asmcomp8arch specific files %S%%8../build/mkruntimedef.sh!>6bytecomp/runtimedef.ml@3tools/ocamlmklib.ml4tools/ocamlmklib.mlp egrep -v 'REMOVE_ME for ../../debugger/dynlink.ml' < otherlibs/dynlink/dynlink.ml >debugger/dynlink.ml Q/ocamlrun' > stdlib/camlheader && echo '#!' | tr -d '\012' > stdlib/camlheader_ur(echo '#!4stdlib/camlheader_ur1stdlib/camlheader1stdlib/camlheader-tmpheader.exe.camlheader.exe,-I../byterun1stdlib/headernt.c-tmpheader.exe)tmpheader1stdlib/camlheader"&&"cp1stdlib/camlheader4stdlib/camlheader_ur@"mv"&&%strip"&&"-o/stdlib/header.c+/ocamlrun"'1-DRUNTIME_NAME='")../stdlib"-I'VERSION-stdlib/sys.ml"-w!<.stdlib/sys.mlp!>-stdlib/sys.ml@5s,%%%%VERSION%%%%,%s,"-e#sed-stdlib/sys.ml unset LC_ALL || : ; unset LC_CTYPE || : ; unset LC_COLLATE LANG || : ; sed -e '/\/\*/d' -e '/^#/d' -e 's/enum \(.*\) {/let names_of_\1 = [|/' -e 's/};$/ |]/' -e 's/\([A-Z][A-Z_0-9a-z]*\)/"\1"/g' -e 's/,/;/g' byterun/instruct.h > tools/opnames.ml tsed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' byterun/instruct.h | awk -f ../tools/make-opcodes > bytecomp/opcodes.ml*st_stubs_n-libthreadsnat*st_stubs_n-libthreadsnat"rc6-Iotherlibs/systhreads,-I../byterun*st_stubs.c*st_stubs_b&-DSYS_)-DTARGET_--DNATIVE_CODE6-Iotherlibs/systhreads,-I../byterun+-I../asmrun*st_stubs.c*st_stubs_n)-man-mini-OCaml library"-t-otherlibs/num"-I.otherlibs/unix"-I&stdlib"-I3ocamldoc/stdlib_man"-d$-man%mkdir"-p3ocamldoc/stdlib_man@#mli&stdlib#%.c!%2stdlib/stdlib.cmxa3stdlib/stdlib.mllib#cmi@1stdlib/stdlib.cma3stdlib/stdlib.mllib#cmi@&stdlib3stdlib/stdlib.mllib(%s -> %s3stdlib/stdlib.mllib'toploop'topdirs+outcometree%ocaml6toplevel/topstart.byte5toplevel/expunge.byte)otherlibs&stdlib@'asmcomp(bytecomp(debugger&driver#lex(ocamldoc)otherlibs'parsing&stdlib%tools(toplevel&typing%utils@!, "<{%s}/**>: not_hygienic, -traverse-boot/ocamllex@4./boot/ocamlyacc.exe.boot/ocamlyacc5tools/ocamlmklib.byte'-ocamlc)OCAMLCWIN)-ocamlopt+OCAMLOPTWIN@-boot/ocamldep@/camlp4boot.byte$boot&camlp4*camlp4boot'camlp4o"-v%ocaml)ocamlyacc@0-strict-sequence%ocaml'compile/strict_sequence@$Unix?otherlibs/threads/pervasives.ml&String?otherlibs/threads/pervasives.ml%ocaml"pp*camlp4boot@"-D#OPT@%ocaml"pp*camlp4boot&native@"-D#OPT@%ocaml"pp*camlp4boot&pp:dep@(-printer!o@%ocaml"pp*camlp4boot&pp:doc@9Camlp4ExceptionTracer.cmo$boot&camlp4%ocaml"pp*camlp4boot)exntracer@0camlp4/camlp4lib/camlp4/mkcamlp44toplevel/toplevellib1toplevel/topstart9otherlibs/dynlink/dynlink=otherlibs/dynlink/extract_crcThe bootstrap standard library(stdlib/%(asmrun/%-stdlib asmrun(stdlib/%)byterun/%.stdlib byterun9otherlibs/threads/%.mllib.stdlib/%.mllibx ,The thread specific standard library (mllib)7otherlibs/threads/%.cmo,stdlib/%.cmox *The thread specific standard library (cmo)7otherlibs/threads/%.cmi,stdlib/%.cmiXf *The thread specific standard library (cmi)7otherlibs/threads/%.mli,stdlib/%.mlix *The thread specific standard library (mli)7otherlibs/threads/%.mli4otherlibs/unix/%.mlix &The thread specific unix library (mli)6otherlibs/threads/%.ml3otherlibs/unix/%.mlx %The thread specific unix library (ml)9otherlibs/threads/%.mllib6otherlibs/unix/%.mllibx (The thread specific unix library (mllib)$%.ml)%.mlbuild 6Temporary rule, waiting for a full usage of ocamlbuild otherlibs/win32graph/graphics.ml;otherlibs/graph/graphics.ml +graph/graphics.ml -> win32graph/graphics.ml !otherlibs/win32graph/graphics.mli win32graph/graphics.mli%ocaml3stdlib/stdlib.mllib6toplevel/topstart.byte5toplevel/expunge.byte@2the ocaml toplevel&ocamlc0driver/main.byte*ocamlc.opt2driver/main.native(ocamlopt3driver/optmain.byte,ocamlopt.opt5driver/optmain.native,lex/ocamllex-lex/main.byte0lex/ocamllex.opt/lex/main.native3debugger/ocamldebug2debugger/main.byte1ocamldoc/ocamldoc2ocamldoc/odoc.byte5ocamldoc/ocamldoc.opt4ocamldoc/odoc.native0tools/ocamlmklib5tools/ocamlmklib.byte=otherlibs/dynlink/extract_crc "otherlibs/dynlink/extract_crc.byte -ocamlbuild/ocamlbuild_Myocamlbuild_config.mli7myocamlbuild_config.mli ,ocamlbuild/ocamlbuild_Myocamlbuild_config.ml6myocamlbuild_config.ml%%.exe!%x-stdlib/stdlib6byte_stdlib_mixed_mode1stdlib/camlheader4stdlib/camlheader_ur@1stdlib/libcamlrun3stdlib/std_exit.cmo1stdlib/stdlib.cma3stdlib/stdlib.mllib9byte stdlib in mixed mode8native_stdlib_mixed_mode1stdlib/camlheader4stdlib/camlheader_ur@0stdlib/libasmrun/stdlib/std_exit3stdlib/std_exit.cmx-stdlib/stdlib2stdlib/stdlib.cmxa3stdlib/stdlib.mllib;native stdlib in mixed mode otherlibs/dynlink/nat/dynlink.ml?otherlibs/dynlink/natdynlink.mlXf !otherlibs/dynlink/nat/dynlink.mli=otherlibs/dynlink/dynlink.mliXf=otherlibs/dynlink/dynlink.cmx !otherlibs/dynlink/nat/dynlink.cmxXf9otherlibs/dynlink/dynlink=otherlibs/dynlink/nat/dynlinkXf>otherlibs/dynlink/dynlink.cmxa "otherlibs/dynlink/nat/dynlink.cmxaXf9otherlibs/dynlink/dynlink=otherlibs/dynlink/nat/dynlinkXf !otherlibs/dynlink/nat/dynlink.cmi@%ocaml'compile&native &file:otherlibs/dynlink/nat/dynlink.cmx@2T5ocaml C stubs: c -> o#%.c!%'C files"-I5../otherlibs/bigarray@!c'compile2otherlibs_bigarray@*ocamlmklib/otherlibs_graph@4-I../otherlibs/graph@!c'compile/otherlibs_graph@9-I../otherlibs/win32graph!c'compile4otherlibs_win32graph@#-oc;otherlibs/threads/vmthreads@%ocaml*ocamlmklib1otherlibs_threads@"-I0../otherlibs/num@0-DBNG_ASM_LEVEL=+-DBNG_ARCH_!c'compile-otherlibs_num@8-I../otherlibs/win32unix!c'compile3otherlibs_win32unix@&ws2_32&-cclib*ocamlmklib3otherlibs_win32unix@&ws2_32!c$link#dll3otherlibs_win32unix@&user32%gdi32(kernel32&-cclib!c*ocamlmklib4otherlibs_win32graph@!c$link#dll4otherlibs_win32graph@3-DIN_OCAML_BIGARRAY!c'compile2otherlibs_bigarray@'-custom*ocamlmklib@$grep"-v%DEBUG@8../ocamldoc/remove_DEBUG%ocaml"pp0ocamldoc_sources@7./ocamldoc/ocamldoc.opt7otherlibs/unix/unix.mli5otherlibs/str/str.mli?otherlibs/bigarray/bigarray.mli5otherlibs/num/num.mli@3stdlib/stdlib.mllib9ocamldoc/stdlib_man.stamp !ocamldoc/stdlib_man/Pervasives.3o7Standard library manual"-I"-I%ocaml'compile0bootstrap_thread@"-I"-I%ocaml$link0bootstrap_thread@"-I%ocaml'compile0otherlibs_labltk@)-Ibyterun!c'compile0otherlibs_labltk@)threads.h@*st_win32.h*st_posix.hXf*st_stubs_n*st_stubs.c1native systhreadsXf*st_stubs_b*st_stubs.c3bytecode systhreadsXf*st_stubs_n-libthreadsnat/libthreadsnat.a*threadsnat&-cclib%ocaml$link'library4otherlibs_systhreads&native@%ocaml*ocamlmklib4otherlibs_systhreads@".."-I*../byterun"-I!c'compile)otherlibs@"-O!c'compile)otherlibs"cc@"-O!c'compile)otherlibs%mingw@Xf2byterun/instruct.h3bytecomp/opcodes.ml3The numeric opcodes2byterun/instruct.h0tools/opnames.ml0tools/opnames.ml-stdlib/sys.ml.stdlib/sys.mlp'VERSION@-stdlib/sys.ml/stdlib/header.c1stdlib/headernt.c@1stdlib/camlheader4stdlib/camlheader_ur@*camlheader4debugger/dynlink.mli=otherlibs/dynlink/dynlink.mli 5otherlibs/dynlink/dynlink.mli -> debugger/dynlink.mliCamlp4OCamlRevisedParserParser7Camlp4OCamlParserParser3Camlp4GrammarParser7Camlp4ListComprehension1Camlp4MacroParser1Camlp4DebugParser4Camlp4OCamlAstDumper9Camlp4OCamlRevisedPrinter2Camlp4OCamlPrinter1Camlp4AutoPrinter5Camlp4ExceptionTracer-MetaGenerator)Camlp4Bin&Rprint#Top.Camlp4Profiler-camlp4lib.cma.camlp4lib.cmxa)camlp4lib3./boot/Profiler.cmo-utils/misc.ml1utils/terminfo.ml1utils/warnings.ml3parsing/location.ml4parsing/longident.ml4parsing/asttypes.mli5parsing/parsetree.mli6typing/outcometree.mli0typing/oprint.ml6myocamlbuild_config.ml4utils/config.mlbuild@7camlp4/Camlp4_import.ml7camlp4/Camlp4_import.ml !camlp4/Camlp4/Struct/Camlp4Ast.ml8camlp4/boot/Camlp4Ast.mlXf 7camlp4: boot/Camlp4Ast.ml -> Camlp4/Struct/Camlp4Ast.ml=camlp4/Camlp4/Struct/Lexer.ml4camlp4/boot/Lexer.ml /camlp4: Camlp4/Struct/Lexer.ml -> boot/Lexer.ml'INCLUDE!;!=!:@ "camlp4/Camlp4/Camlp4Ast.partial.ml@%ocaml9file:camlp4/Camlp4/Sig.ml@%%.ml4$%.ml1camlp4: ml4 -> ml$%.ml'%.mlast "camlp4/Camlp4/Camlp4Ast.partial.ml@3camlp4: mlast -> ml "camlp4/Camlp4/Camlp4Ast.partial.ml@%ocaml'compile9file:camlp4/Camlp4/Sig.ml@&camlp4@*camlp4boot'camlp4r(camlp4rf'camlp4o(camlp4of)camlp4oof)camlp4orf8otherlibs/labltk/support&stdlib@8otherlibs/labltk/support9otherlibs/labltk/compiler8otherlibs/labltk/support&stdlib@9otherlibs/labltk/compiler7otherlibs/labltk/labltk8otherlibs/labltk/support&stdlib@7otherlibs/labltk/labltk7otherlibs/labltk/camltk8otherlibs/labltk/support&stdlib@7otherlibs/labltk/camltk7otherlibs/labltk/labltk7otherlibs/labltk/camltk8otherlibs/labltk/support&stdlib@4otherlibs/labltk/lib4otherlibs/labltk/jpf7otherlibs/labltk/labltk8otherlibs/labltk/support&stdlib@4otherlibs/labltk/jpf4otherlibs/labltk/frx7otherlibs/labltk/camltk8otherlibs/labltk/support&stdlib@4otherlibs/labltk/frx8otherlibs/labltk/browser7otherlibs/labltk/labltk8otherlibs/labltk/support'parsing%utils&typing&stdlib@8otherlibs/labltk/browser #otherlibs/labltk/compiler/copyright &otherlibs/labltk/compiler/copyright.ml #otherlibs/labltk/compiler/copyright $otherlibs/labltk/compiler/tkcompiler *otherlibs/labltk/compiler/maincompile.byte1labltk tkcompilerotherlibs/labltk/camltk/cTk.ml !otherlibs/labltk/camltk/_tkgen.ml !otherlibs/labltk/compiler/pp.byte@&cTk.ml&labltk&camltk@#cTk"tk#cmo?otherlibs/labltk/lib/labltk.cma?otherlibs/labltk/lib/labltk.cma*labltk.cma#cmx otherlibs/labltk/lib/labltk.cmxa;otherlibs/labltk/lib/labltk otherlibs/labltk/lib/labltk.cmxa+labltk.cmxa>otherlibs/labltk/lib/labltktop "otherlibs/labltk/support/liblabltk?otherlibs/labltk/lib/labltk.cma5toplevel/topstart.cmo8toplevel/toplevellib.cma)labltktop&labltk;otherlibs/labltk/lib/labltk&labltk4toplevel/toplevellib=otherlibs/labltk/browser/main>otherlibs/labltk/browser/jglib=otherlibs/labltk/browser/main;otherlibs/labltk/lib/labltk=otherlibs/labltk/browser/main otherlibs/labltk/browser/winmain%ocaml$link'program,ocamlbrowser@'-custom+threads.cma@%ocaml$link'program,ocamlbrowser@"cc$msvc/myocamlbuild.ml)I&-ccopt8/link /subsystem:windows@%ocaml$link'program,ocamlbrowser@&-ccopt7-Wl,--subsystem,windows@%ocaml$link'program,ocamlbrowser@*ocamlmklib0otherlibs_labltk@"-I8otherlibs/labltk/support@%ocaml$link'program0otherlibs_labltk@:-Iotherlibs/labltk/support!c'compile0otherlibs_labltk@ "otherlibs/labltk/browser/dummy.mli,dummyWin.mli-dummyUnix.mli8otherlibs/labltk/browser9ocamlbrowser dummy module)-nostdlib@2../ocamlcompopt.sh2../ocamlcompopt.sh@,ocamlopt.opt2stdlib/stdlib.cmxa../ocamlopt.opt*./ocamlopt@/../ocamlcomp.sh/../ocamlcomp.sh@,./ocamlc.opt)-nostdlib@(./ocamlc)-nostdlib@4otherlibs/systhreads4otherlibs/systhreads4otherlibs/systhreads4otherlibs/systhreads"..!\(ocamlrun @convert_command_for_windows_shell: invalid atom in head position#exe#exe#exe#exe'compile!c$msvc"-c"-o"-c$msvc)lib%s.lib"-l.%s -o %s %s %s.%s -o %s %s %sA%Win32'windows@"cc/ccomptype: %s@.-boot/ocamlrun-boot/ocamlrun+boot/ocamlc"-I$boot)-nostdlib@;build/ocamlbuild_mixed_mode%Win32.otherlibs/unix3otherlibs/win32unix1otherlibs/threads4otherlibs/systhreads1otherlibs/dynlink-otherlibs/str(toplevel/stdlib/std_exit3stdlib/std_exit.cmx2stdlib/stdlib.cmxa*ocamlc.opt&ocamlc1stdlib/stdlib.cma3stdlib/std_exit.cmo@&OCAMLC)OCAMLCWIN(OCAMLOPT+OCAMLOPTWIN&OCAMLC(OCAMLOPT"ar@@@8 @@#ArgA@A@%ArrayAj@B@&BufferA@@0CamlinternalLazyA@AC@$CharAA@@&DigestA @@(FilenameA@AB@&FormatA2@@&GenlexAd@ACD@'HashtblA@@%Int32A_@A@%Int64Aj@@&LexingAz@AB@$ListAy@@#MapA@A@'MarshalAS@@,MyocamlbuildA @A@3Myocamlbuild_configA@BCD@)NativeintAu@@#ObjAT@@/Ocamlbuild_packA@AB@4Ocamlbuild_pack.BoolA@@7Ocamlbuild_pack.CommandAU@A@=Ocamlbuild_pack.ConfigurationAk@@Ocamlbuild_pack.Discard_printfA@@7Ocamlbuild_pack.DisplayA@@:Ocamlbuild_pack.Exit_codesAT@AB@3Ocamlbuild_pack.FdaA@@7Ocamlbuild_pack.FindlibA@A@5Ocamlbuild_pack.FlagsAl@@4Ocamlbuild_pack.GlobA@ABCDEF@8Ocamlbuild_pack.Glob_astA@@:Ocamlbuild_pack.Glob_lexerA@A@5Ocamlbuild_pack.HooksAU@@7Ocamlbuild_pack.HygieneA{@AB@6Ocamlbuild_pack.LexersA4@@3Ocamlbuild_pack.LogA@@4Ocamlbuild_pack.MainA@AB@6Ocamlbuild_pack.My_stdA@@7Ocamlbuild_pack.My_unixA@ACD@:Ocamlbuild_pack.Ocaml_archA@@>Ocamlbuild_pack.Ocaml_compilerA@A@ "Ocamlbuild_pack.Ocaml_dependenciesAE@@>Ocamlbuild_pack.Ocaml_specificA;@A@;Ocamlbuild_pack.Ocaml_toolsA?@@;Ocamlbuild_pack.Ocaml_utilsA/@ABCE@ .Ocamlbuild_pack.Ocamlbuild_Myocamlbuild_configA@@ Ocamlbuild_pack.Ocamlbuild_whereA@@7Ocamlbuild_pack.OptionsAQ@AB@:Ocamlbuild_pack.Param_tagsA8@@8Ocamlbuild_pack.PathnameAb@A@6Ocamlbuild_pack.PluginAS@@6Ocamlbuild_pack.ReportA@ABC@8Ocamlbuild_pack.ResourceA@@4Ocamlbuild_pack.RuleA@A@5Ocamlbuild_pack.ShellA@@5Ocamlbuild_pack.SlurpA@AB@6Ocamlbuild_pack.SolverA@@4Ocamlbuild_pack.TagsA@A@5Ocamlbuild_pack.ToolsA@@1Ocamlbuild_pluginA@@/OcamlbuildlightA @ABCDEF@*PervasivesAe@@(PrintexcA@A@&PrintfA@@&RandomA@AB@%ScanfA\@@#SetA@@(Std_exitA @ABC@&StreamA@@&StringAK@A@#SysAN@P-Match_failureCG@ABDQ-Out_of_memoryC@@R0Invalid_argumentCC@AS'FailureCB@T)Not_foundCF@AU)Sys_errorCA@BCV+End_of_fileCD@W0Division_by_zeroCE@AX.Stack_overflowCH@Y.Sys_blocked_ioCI@AZ.Assert_failureCJ@[:Undefined_recursive_moduleCK@ABCDEGH%Int320&Y(y cHϚΠ%Int320&Y(y cHϚΠ$Char0&)9_=J(Bm&Printf0L,B=a.4(Filename0LTjC>#Arg0 7}-}\+%Array0M^ {OԲwp&Stream0YvHlQ֎F&Genlex0r@^cST>=+ǂd/Ocamlbuild_pack0Xc YKe3Myocamlbuild_config0 +F85AhӀᠠ#Sys0Eu%B&̄y&#Obj0{B+,;)Nativeint0G$)@p hc$'Hashtbl06`؋ ;)1Ocamlbuild_plugin0NyL175#Set0**V $.QCˠ&Format0nk{uDLsc&Digest0rUATy[;l(Std_exit0Uol'HWà0CamlinternalLazy0~OaKtGB&String0T&GSq첋(Printexc0vIF#ϝg键&Random0o7pr'Marshal0}55UanRߜ&Buffer0?lG!Wiv 6]6]6 ]6!]6"]6#] +^+H +9+ + :+ + ,c]i]j] + + + + +Z+4 +& + + + + +%+ ,(+ +t ++ +++++++v"+f +V+A+2 !+" + + :,+ +? + + + 6$^.  + + + +} +t +h> +X +L +C +: +. +$ + +),* +213 +79 + + +> + +BD +G +LKM02468:<>@BDFHJL_acegkmoqsuwy{}>QB9%T)*V D 2&(]()*|V  $eq o  n n2  n2  n n$ )*c }UH\ n^ n? T\C^ C_ C~V  C^"c C_ zUc()* "._ {V ^2$ o$ _ {V ^ 2$ o$ )* nn  , ^^$)* + + ,O |V hh$ e q oh^ ^  h   h c h $)* " ^"^ _ 2' _()*Y #Z( CyV D _([)* " ^ _ 2&)*f q zVcT5&6 @[ ^"^ _ 2&h_( _()*Y"Z( CyVD ([)* nn ? {V0^ ^"h}V I^ C^"h}V IC( {V^ ^"( {V(@[)* + ,,, +\,Ok qh {U\ ^  # zUcj {U%\ ^h ^  _h"" zUci{Vd ^h ^i _h _( )*? Oh {U\C ^ " I zUcC()*?hO }U\^ C" I zUcC()*VD C _  2&(VD C h"^ ,i &:()*( ^ @ 2&,c O &)*O :(c ^ h " ^i  }U\^ " _  zUc()*c O }U\^ " zUc()*O :(c ^ ! ^i  }U\^ ! _  zUc()*c O }U\^ ! zUc()* Oo }U   Oo}V5'8%%a()*   Oo }V5(8%% n }U\ _  zUc()*  Oo }V5)8%% _()*O %Oh _( ^(O :(h _()*: ^h  }U\^ Q zUc()*:(c ! ^i  }U\! _  zUc(+ + + +j +I + + + +x +R + + ,+ +~ +N6*? +l  +.   +!$&(>9+TO)*V D 2&()*V D C @ 2&(VD C 2! 8%&c()*VD C ! 2" @(c()*VD C " 2# @(c()*V D C ! 2&c()*VD C "2'c()*VD C "2'()*VD C 2# &()* VVD C DC "  2# @( Uc(5,8%%)* VVD C DC " 2' Uc(5-8%%)* VVD C DC    # 2$U(5.8%%)* VV!D C DC    2   ' U(5/8%%)*VD C !V 2&(d()*VD C !U 2&(c()* VVD C DC "V 2' ( Ud(508%%)* VVD C DC "U 2' ( Uc(518%%)*VD C ^hyU 2&(c()*VD C yU 2&(c()*VD C D C ^(2&5?[)*VD C D C yV(2&5?[)*VD C C ^hyU2&(c()*VD C C yU2&(c()*VD C C ^(2" @(c()*VD C C yV(2" @(c()*VD C !V( 2&5?[VD C D C 2! D C @ @@(52()* VVD C DC 2" @@(Uc(538%%)* V0V)D C DC "  2# @( 2# @(  ( ()*(V D 2&546 @[)* V/V&D C DC "  @ 2'  @2'  & &)* V/V&D C DC "  @ 2'  @2'  & &)* VD VD VwC CC "5 " c @ @ @(  " c @ @ @( c @ @ @(  " c @ @ @(  " c @ @ @( c @ @ @( T-T)V&D VC C " c @ @(c @ @( i x o " 3" 3"h ')* VD V{D VrC CC "3 " c @ @ @(  " c @ @ @( c @ @ @(  " c @ @ @(  " c @ @ @( c @ @ @( T,T(V%D VC C " c @ @(c @ @( i x o " 1" 1"h ')*,, ,<! ( & )*VD C !V  @2' @2'! !@()*,hh ')*VD C !V  @2& 2&%,c %)* VVD C DC "@2' U(558%%)*, h ')* h')*VD C !@2&()*,h &)* h'c &)*VD C ( 2&568%%)*578%%, &VD (588%%VC (598%%h&,+ + + +8% ,+ , ,,+h +W ,,+* , ,,-+ ,U,},,,,,,,X,p,,,,,,,*+ +Z ,5,T,|,&,+    !#%')+-/24379>@C>AHHLNMQSUW>+/9:T)* o(az ((AZ  (('.\&*W&&&&&&&&&&5;(5<(5=(5>(5?(5@(]V d] h S(l]l\h Sgd ql0ni Sg l qrl0nj Sg rl0nk S(5A8%%(+ +v +R +. +# >9BT)* ~V5?[ RyV(  2$)*5?[ RyV(  2')* ^()*] ~V5C8%%Y #cdZ(6 CyVc([)*h ')*]  }V5D8%%Y      cdZ(6 CyVc([)*] ~V5E8%% ')* ] ')*]  }V5F8%% $)*h ] $8B&8B&)*](!h R !h S(8B&8B&)*] (]h  }U\R! S zUc(c?h ] }U?\R  "!\T  T ]VdTgTe Cn I zUc] CyV(C]h Ic ] }U\R  :  8g\CSCSTToTgTc" W#4ETKg\CSgbCST4g\CSgtCST#g\CSgnCSTg\CSgrCSTTF ]VCST7l\CSgd ql0nCSg l qrl0nCSg rl0nCS zUc(]h? T\ C{V C R!Uc? T\C C~V CR!UcC  CyV(C C~VC Co C'5G(  TTTc(d(]Cha]CnI]Cha]CnI(]CnI()*V?D Ch?h? +8: "C]p Cn] ]h ha]?  +8: "(5H()*c ] }U\R " zUc()*c ] }U\R ! zUc()* ]o }U  ]o}V5I8%%a()*  ]o }V5J8%% `()*  ]o }V5K8%%] h a(] ] h ha()*] h `(+ + + + +T +/ + + +b + + +j +^ +S +5 +) + ,+ + ,'+ ++x +k+: +-      #%$(*,.0>9LT!?[V +?&c&)* ^c(c] D Ch] E D C iv lqph? +lllllllllllllllllllll6M? +6N    "$&(*,.0449997?A>!#9OT)* _(]U()*  ]o }V5P8%% ^W n ]o }V5Q8%% ^V()* "n()*  ]o }V5R8%% ^W()*  ]o }V5S8%%a(+l + + +q  +c +T>9TT/)* 8T" n 8T"@(c ^()* _()* ^(+ + + +lllllllllll lll   "$>9UT5)* ^k(6V^l(5W ^c(5X ^V(][(5Y ^](5Z ^\(5[6\6] + + +6^6_ + + +   >  9`T5)* ^(6a^(5b ^x(5c ^V(]p(5d ^r(5e ^q(5f6g6h + + +6i6j + + +   >  9kT5)* ^(6l^(5m ^(5n ^V(](5o ^(5p ^(5q6r6s + + +8O 6t^6u ^ + + +   >  9vTcc Mc LG h E D C> M c K(G F F D C> M (G (G (G F(G F()* Gn D^()*  D^?(c()* D^()* o ] h Da?(c()* o ] h Da(G Go ] h GDa(d M( :ihhhhh ]6w 8%" +> ()*h 8%>$+% :hhhhhhhl]l] "> ()*] " TdMcD] En}VD] GEon|VGEoh D G D8L TB7OD]jp8%" GEon}V5x8%!]  G Eoh G D8L JG FnLGoMcMGoMEoKG h O }U\ ^ h|V o _ zUcE Dh 8L EnK()* _ h|VG M G GFn E D C>M ()* _ h|VG M G GFn E D C>M (5y + + +6z + +w +G +& + + + + + + + + + +t +R     $>9{T](c(C%!F(!F(c!F(c!F(G oG oF^(G oG oE^(G F^( G F^(G oE^ G oF^ ^V(2%,G %)* G o D^()* ` W"*2_!G MG M i2&?[c!cj2&c!ck2&YG C^!l@ZT CyVcl@T[ D C 2&5|G !cl2&]V  ]E^y( D^y()* ,bG G GGGGGG M M G M Y ch "Z( GM M MMMMM CyVD ( +vI[c( cGhD8+ cM(Gj ph ^h ^8{ ^8{^ hhC8+ I hhD8+ J hhE8+ K hhF8+ LM(5}?6~?hhhhhh8{8{hhhld8{ld^8{ld^hld^hld^> +c +K +D?  + +++++ + + + + +w +p   +_>9T9! G G# G GG"G GGG G G G G GGGGGGGFGGG>()*V)E D C C" (  2"' 2" ' dh h>()*VE D C 2"'%)*VE D C 2" '%)* VKVBF E D CFEDC}V   2# '}V 2#'   '&&VC V2%D (5?[VE D V2%(5?[VC V E D 2!'E (58%%)*VGE D C C" i A(2" E D C# A( 2" E D C   #A( 5()*VE D C C" hyU T2&(c()*V+E D C C"  &  2"' 2" ' c()* V_VXF E D CFEDC~V  & " E C 2" 2"' & " E C 2"  2"' ( ()* V8V2 E DC " D C  E 2" 2"'E 2" 2"&c(c()* V8V1 E DC " D C  E 2" 2"&E 2" 2"' (c()*VE D C A 2&()* V*V$E D CEDC C" ( ""2& d(Vg(c()* VTVN E D CEDC C"  2"V2&( hh>2"V2&( hh>2"V 2&( c(d()*VE D C 2"!2&c()*VE D C 2# " 2' ()*VE D C !V 2"V2&(d()*VE D C !U 2"U2&(c()*V E D C 2" !2" V' & c()*V:E D C 2" D C!2" D C V"  #@(  # "@( 5(VE C 2! 2!n(c()*VE D C 2" @2&(h&)* "hy()*c "h "&Vc(d()* VV !!' ( ()* VV !!' ( (dh h>()*VF Tc VF Tc  }VDV:E DC ! !~V # ' VE DC  # #'58%% 58%% }VFV<EDC ! !~V    #' VE D C#   #'58%% 58%% ~VT>()*VF Tc VF Tc ~VT>(VF (c(+ + + ,!+ ,O,b ,r,,,  + +~,c +h,9,W , ,,,Z,k +" +,,,, ,=,V,v,,+    "$&(*,.02468:<>@BDF>$(%+ +?9T ]8U yVc ^ (7U zV(% ]8U yVc ^ (7U zV(%c ^ h _ c ! h_ 7U ^([c ^ h _ Yc! h_ 7U^Z( +h_ [?[5? + + + + +a  >9T)* {Vh^ $2 \g\""l 2&\ " 2& 2&\"l 2& # D C !"l 2& l\yV&()*] ,scl &)* ~V5?[ ^ ({ "  o8L#@(  h!   o 8L#@()* ~V(^ _: TeTd0`T[{SS@ W@@@@DDDD@@@@@DD@@DDDD@DDDD@D@@DDD@@@DDDD@@@@@DD@@DDDD@DDDD@D@@DDDT T`( 2&)*,j] &)* ~V5?[ ^yV   2' ^yV(  2'  2')* ,] ' ({56 @[g}(g)()*Dh C 8%/$)*h}U7O }V58%!E Dn}V " DC8%?  Dn J()*Dh C $)*] Dn E }V "DCh 8L  J()*h}U h}U ]o }V58%! Dn E }V "DC  8L  J()*D E ~Vd " C_ J()*E ? T\Cjp ICDn}Uc7O C}V7ODn|V7O IT58%!C] Dhh C8L ICK(c JF IC] K(c J(D()*D ~V58%% C^()* Do }U  ]o}V58%%C8L$ )*   Do }V58%%] hC8L (Dh C8L'dT8O }V7OT ] h >(+ + + +e +F += +4 +! + + +c +7 +&+ + + + +T +n  +O   !>9T ( +&c(! +8 8i$)*! %8! 8!(]jp 8%c( +&(c()* +8 8+h$8%&8%&c( +&c(+(+%()*8%+8%.8%-+h$)* ~V%R %" 2&0 4443 $ )*" 1&)* V h " "T " 4&)*V c !  "T ! 4&)*  ! 4&&)* !D" 4+ $)*] 2, ;sc & )* ! ,cC! " & )* $)* 3+  ')* "  @"$)*R  T;W"T"T2 +  ' 3$ 2$ )* R |W||q%q% &6'6' "8%!T       "  "'  '  "  "E! h"  "$  '  "  "'  '  i8L"' " sT5 8L !8%"68%"yVT      "  "' " c i8L"T5 8B!8%"68%"  "' "      ^Z  "'  "     ^  "'  " 8%! "'  R  T+W!!%%%%%%%%%%%!%%%%!%%%%%!%%%%%!%%!T,"    ln ^Z  "'   TCW!"     ^lTT"     ^TT"     ^   "' "  # { ! "'  "' )* "^()* +           , Jh')* ^ ]H (% ~V 58%&^   TT 7TT2%(] ,c %)*VC (()*V(E%)*R 0:*  l pn2&$58%% F!?&h&)* R  h&,  &)*cl^ h _i _j _k _l _l _& )*cl^ h _i _j _k _l _&)*cl^ h _i _j _k _&)*ck^ h _i _j _&)*cj^ h _i _&ci^ h _& @&)* o_()* ~Vc^ +"& 2+()*!  ,ch &W !(/: & +( +q( +O( +'( +( +()*VD C V "2& &c()*,h &! C()*()*l)zVl}zV "()*aeTd lryVEKV DnJ(CnI(chhA + + + #()*V 58 "Tg%8" &)*8"(] 8! + + #8%)* }V%R : _Ci2& 8 W"-----------TTgi # 2&T  3& 2& 2& {V ^ "2%()* }V%R ~W~~EE #3% #  # ,5 !2& '(gs 'gc 'gi 'gf 'gB ' '  }V gi'^  T+W!!%%%%%%%%%%%!%%%%!%%%%%!%%%%%!%%!T gi' gi #& ' {V^% h4"2%2%()*] ,gc !c(' ~V%^ %2%3% ~V%^   TW TTT TT1% " 1% yV(')*(g)Tg} 2,e %)*] , & )*  F(gg ] _()*  Nn(gu ] _()* |V<R * 8"2&VD C 8%!8 "! 2& 56 @[(R 0 :2%$((R  (, %)*+  ! o 8!l% 8" ,c8:! "8% )*! D C]hl $ )* yV( |V 8L' 8L" V h  8L T  o  8L ()*] ~Vh@(R 1:  ]o8L#]Y@(-i2& 2&,Ydh"Z(6 CyVgsh'[5 G!8%"68%"8%%)* G!')*5 8%"68%" 8%!8%"68%" i8L"8%"68%"8%%]h ')* 8L'%)* n%(8%!68%"8%%+ +i ! + + +  > +n +\ +A + + +t +> + +w +`  +   + +b : + + + +?+(+ + + +a  !+  +& +:+, + + ++ + + + +  + +t % > @ D C G G E C>@   > '9TL)*VD C D C ^V( 2& 5?[ ~V(^ 2%(] ,Y g 8L "!Z(6 CyV([! h8:# !8: &)*D C E6 ^VkW E  E !l ] oo8L" h8L# ]o 8L# 8%" 8%"A( E !l o8L" 8%"68%"A(()*E D C W  ! ]n8%&]8%&)*Y   8Oh Z( CyVD 68"e8%L% CyVD 68"c8%L%[W cjqI9Ch %CC{VBC^ Y 8%!!ZT(6 CyVD6 ^VT5 A@[T[(TCi I(Ch I(CC{VC^ !(TCC{VC^ I(TCC{V@C^ Y ]Y!ZT(6 CyVD6 ^VT5 A@[T[(T^CC{V@C^ Y ]YIZT(6 CyVD6 ^VT5 A@[T[(TCC{V@C^ Y ]!ZT(6 CyVD6 ^VT5 A@[T[(TCC{V@C^ Y ]IZT(6 CyVD6 ^VT5 A@[T[(TtC 28: &D CC{V;C^ 8:"VC^ !( 666 68%" A@[T C T\C^ !C{Uc(?@[ {V  ^T5 W+FZC6 ^V5 ^V 68 TcTcTDE D C  68 T)C  68 TC  68 T#5 ^U5 ^V 8!@[8!@[)*VC T Ol8! C    + ,T\C^ ]ic ^-bY  "ZT6 CyV? !T[ Y  , !ZT% CyV D ?!T CyV D !T[T"Y!ZT CyV D ?!T[C{Udc( )* "68&)*g8! #8%)*6 8#! !8: &Y 6"ccZT6 CyVc6?6A@T[ Y 6"ccZT6 CyVc6?6A@T[ 8%" 8%&5@[)*E D C ]h{V7W   68$ C  666  68$ ()*8%" 8%&)*VDC 8%"+8:#8%&5(5?6?6? ,+ +p +e + + + +h?    +  + ,+S +  +     >9T#^!l ^!vn(Aa g&ga o (GgA o ( Tg0 o(56@[]l zV56@[+ +l]hl }U\jp!8B! _ zUc(g ]hl }U%\ejph ^68"8L  zUc(g]  gh8%? ()*gh 8%/$8%:!l ^ 8%F!()*  ]o }V58%% _(]h _(7L + + + + + +Q +   >9TD&G%c]%?E&E&G%G&G &G &G &G&G%)*! r l?o o}V 2&()*!]gli !s]g^d ^b ^`68`^]^\ ^]^V2&()*!]|l !]|^yl<l!s]|^y ^w ^w ^u68k^r^q ^r^V2& (d !shy()* !^&(5 !]! !]! ^'^$^'()*] "]()*] "]()*5 ^V58%% &)*5 ^V58%% &)*?58%% &g7 Dr JD C^ll ws ul7 Dr C^nl? s DC_(c! "(c]%c! "(gk ^vlj ^vli^vh^nnn()*8%! 8%"8%)*+ + Oc?T Ohl6 }U\ C_ zUc5?h l78%"l6n }U5\g7 r r ^C "Ig?C !  C^us  C_ zUccJ()*g7hChC8+ D J(chl7^@(+ + +P + + + + ,+ ,+,+d8v +MT+:+ + +    >h6]@ +7 ++ + ++++ + + +  +  + GGG G G GGGGF>    > 9T)* ~V(7Oj p}V(j p2&)*VE D C ^(2&5?[)*V E 2&()* `S(6&)*D%C + @! C D E FGGGGG G  G  G  G  G  +     >()*VE D C C"V(2&5?[VE C C"U2%(c()*, " D^ %VE D C C"VA(2! A(5?[)* , " D^ Y ! D_Z(6 CyV"A D_CIdDOvC}V& ([VE D C C"V 2! @(2%c()*, " D^ %)* " D^ VIE D C C"V(V1E DC  C"V( VE DC  C"V(  &5?[5?[5?[V E D C C"V CI(2! A(c()* , " D^ ! D_()* " D^A D_C Id DOv C}V&()*DO ED"s(+ + +,  + + +{ +<   >(h" ^ _()*h" 8%&Dh+8+#h ^ D +8+ " DOC>()*VE D C # 2&()*,D?h O }U\C ^" I zUcC(VE D C "2%c()*,Dh O }U\ ^! zUc(VE C ^hyU2%(c()*, " D^ %VE D C ^A(2! A(5?[)* , " D^ Y ! D_Z(6 CyV"A D_CIdDOvC}V& ([VE D C ^ 2! @(2%c()*, " D^ %)* " D^ VIE D C ^(V1E DC  ^( VE DC  ^(  &5?[5?[5?[V E D C ^ CI(2! A(c()* , " D^ ! D_()* " D^A D_C Id DOv C}V&()*ODO Eldl `Ss(DO ldl _Tr(VE D C 2!" ^ A _(c()*D Oj p8O {V,c ^ J,c }U\^ ! zUc(C( F E D8+! C>(DO OF yV%c Ic F^ J(c IDOh  }U\c D_ zUc()*VC TC l" V" ] CT 8!T8 F!Tc h^h>(c8 D%dI()* ldl `S()*h `S(hldl `S(+ + + Y5]ZT&6 CyVY5]ZT6 CyV5T[T[lR 8L" ? + +? , +4 + + + + + +@ + + ,+e+N++ +_ + , + + B + + !#%'>9T2G! C E D h}V GG G o{XV G!c T#G nM 2%()*h{VP h G'gPh G# 2&(c &+ &%)* +h'( +&%"%g8! + +i'&&c( +&c( +&)*%)* +G%()* +h')*?I! &)*. ~V1-%/^ %&@ 3! 2&. ~V/&&/^ AY^- TW 14' Tc1"2&[ W 14' Tc1"2&  W!!....2......6.C............PZ..k2c1!"2&TTTWc1""2&c1"2&14' 022+ 4 ' c1"2&c1"2&/&&3!2&0 44430/$F$ )*2! 1&)*'V h "0!T- " 4&)*%V c !.!T+ ! 4&)*c)" 4&&)* 4+"&)*&)*&)*&)*&)* #' ~V&^ 0: T.-T( yVcT oC!E# #  '2%)*" ~V#&#^ R% #", %#+n#+_#+P#+A#+2   $#F$   2' ~V!&!^ >!&(2% ~Vl@(^ bxhvl@(i@( ~Vh@(^ ovh@(j@( ~V 6'^ v i8L"68%"' k@(l@()*6')*6')*%)*Vc !Tc +"  @@$)*Vh "T " @@$ )* @@$)*~V oC!E#" '^ %&> 2$  oC!E#" 'oC!E# 2+ 2+h 2+<+%+  F$ )*, V h$)*3! ')* #! &)* ~V c  " 4&^ < c  " 4&444 ,4' )* #! &)* ~V gh # 4&^ < gh # 4&4! D C 44+ 4' )*"! &)* ~V 5 " 4&^ < 5 " 4&44+ 4'C VC #cI(&C VC i8L" #cI(&)*!h? + +        , O[v,`DchC!&)*] 2     +d G&)*      ,()*V @8:!68L&()*g8! ! " &)*c "%8! 8!()*Y]YZT6 CyV "T[ ()* 6#8%%)* 6')* #8%%)*] {V  ^68"T g.68" F! 68$c"8!8!(c(+ 8 !&8%+%+ 8%/!&c(c()* + +  ! M! M()*c!h6l# " i@@ hh    68%iiiihlNlNl lNhhhh>(c(5 8%"68%&5 8%"68%&8%+%)*8%/! M+ M! M! M()*dh6 G')*G G G G>()* # M M()*G G@()* M M()*G()*i|V0! MG G|VGTdj Gq GGo8%"8%" &()*G()* Go &)*i|V! MG Go M%( {V(()*G()* M()*G G y()*G()*i{V M()*G G {V chh# &()*ch ')*G G {V @ G m# i '()*G i{VG G {Vcjh# "G  M ()*G  M G G {Vch???h# &()*ch ')*ci ')*G G {V @ G m# i '()*G G {V clh# &()*G G {V ckh# &()*c "c G%)*d "c G%)*g ')*f ')*e ')*d ')*ch ')*d] h _i ')*8%! &)*8%! &)*8%! &)* ] ')* ')*G G {V '()*T\c "G c M !V!%!!c Jc Kc Lc Mc M c M G M%)*F E DC MMMM()*G G G G>()* " &)*G()*G()* M()* M()*GV clhA "GVF VD C G!L(c()*GV F @ L G!GV c ?hA &()*G i{V"G G {VcihA "d "c "G  M (fh ')*G  M G G {Vc @ G m# h 'G G yVG &()* "Vd "C G @@ I()*C VRC D C CD D G {V% W1111111 11 XV  G nI I(  V  G nI I( c( c( I()*] ')* ?# &)* A()* "%Y!Z( CyVc([)*VD C ^V( 2&5?[)*VD C ^V @( 2" @(c @()*W ,;J]q E VC C ,CGGo " I(c(D VD J(c(E VD K(c(D V C D &%G Go G zV%(G VD C G! "M(c(C Go M "c M (D C D VtC D C W /d& ' ' G}V' & G V& G}V'  GonG }V' & & c(D C G Go E VPC C ,C V"C Y C "ZT6 CyVT[T o  n & G n 'c(D C G Go G }V!Go G}VTgTdD @@J(C E @ K(C G! "G @ M(G! C E G oM GnM(D V!C D CG }V c(&c(%)* Go M &)*h ')*!d M  Gon G8%" M G Go MG &)* G%c G%)*]h G'd M d M G%)*E G n M G &D VC C D JhyVcI(?[D VC C (?[)*c @? C V C I J(IJ(c Ic J(ch@(g]+ + +6? + + +t+al ʚ; +O +D +8 + + + + +   +  ,p+? +/ +! + +h6l#h l@@ + + +a +# + +++ +{ +n +b +V +E +- +  "+  !$++ + +y +i +Y +I+4+&++ ++ + +"$+#%+%+f +Y +L')+(*+#*+ ++-+ + + +p +c +W>+D  + + + + + + + + +j +Zl lP8L" ,^ +( + + + DH\_+  +v +] +Hl8!8% !8%! ! 9+ 1!1!1!1!1!I! I! I! ?! ?! ?!?!>!@!6!5!7!;!=!?!=!:!:!:!9!;!1!1!5! 5!!>!">!#>!$>!%>!&1!'9!(9!)9!*9!+c!,e!-k!.j!/l!0k!1k!8 C8 D + + + + + + p+ >+k +O   giknpry~+ +y +d +P +@ C+1 C+& H+ +I+ }+ 38%M!     cegicrtvxzsusu]_acegi`ccfcrt}>p9T# Yll@k@i@8%*#@Z(6 CyV [2%[)*VC T5 VC TC ,c %# Yg6_]Z(6 CyV [2%[)*VC TC ,c %C(I()*g ] CT 8!T8 F!s  68  &c8 D%"V58%%^. h8L'2%,] %)*] ]o 58%%h 8L')*]  "V 8%&8%" 8%&! D '! D C # 8%&!V]j 8L#jh 8L#@(6@([ T TAc(d(+ ]j|Vc ^ !Vd ^l:y( yV g"8&^ "\8"2%h3&h3&)* yV g"8"3%^ "\3!1% 2&jp3!g"8"1%d }U\g\8" zUc(] 8!l" 8" ,Uc !8%)*] ]~V] ] ]o 8L# 8L! 8L!^(!VO]j}U 5jh 8L#^V;]j}U 5jh 8L#^V']k}U 5kh 8L#^V]k}U 5kh 8L#^(]i}Uc ^l/zV]i}Uc ^l\zV]j}Ud ^l:z()* ^ l/yU l\yUl:y()*] ]~V ] ] ]o 8L#^(!V']j}U 5jh 8L#^V]k}U 5kh 8L#^(]i}Uc ^l/z()* ^l/y( dh8L'"V2%3%("V3%2% dh8L'"V2%h8L')* ,5 ^V(] % dh8L'"V2% 3&)* h8L'"V o 8L' 2&)* ,5 ^V(] %)*] 8!l' 8"c  }U$\^'  8 "T ^ 8" zUcg' 8"8%+ + +"6 6 6  + + +m +J Y5]ZT6 CyV5T[6 ! "  "   >  666 + + +X +* Y5]ZT6 CyV5T[ + +6 +  +   +   >  666 FGGGG G" "   >  8O6 ^Ve5 ^V65 ^V56 @[G G GGGGG F E D C> TMG G GGGG G F E D C> T%G G GGGGGF E D C>  G G G GGGGFE D C + +j+W +&? + ? + + + +^>9Tj)*V D 2# C !@(()*VC ! D 2" @()*VVC C "V D D 2'(Ud(c()*c( 2" @()*VD C ^V( 2" @(VD C V2! D C @@(h@(56 @[)*VVC C "V D D 2'(Ud(c(c(d x2!in(E(D(C(E(D(C(Ch I()*] ~V(^  TT TT  3' 2&)*] ~V o 8L#@(^  TT TT  2' o8L#@1&,ech &)*] ~V(] n~V5?[^ n^yV 2&c 2&)* ,c &8 ! 8 ! Y/g.8L " h8L#8!V 7^VT8"Z(6 CyV([Y 8!Z(6 CyV([i8%x|Vd8%x |()* o u 8%! uth}()* n8%! u uth}()* m ns(m s()*]  h8%? ( gh8%>  8% h8 c2%g8!l] ,c %c(g8%"h8%>  5?[ h8%/  o2%)*g] , % gh8%>  c( h8%/ c2%)*g] ,c %D C8')*h8" +8: "()*]c ^+]i 8L# 8&(Y]Z(6 CyVc([V$C 8" 8" ]V(]V(D2%5?[)*8L! , %V C8" ]V(D2%5?[)*8!U]V(5?[, %)*VC !?()*VC %()*Yc!ZTh ![h !(58% !8%#!?[5 ? + + ,,,,,,,+ + +n +< + + + + +` + + , + + + +q +W + + + + + + + + + +    "$&(*,.02468:<>@BDGG>%%9!T)* 6"8$)* 6#8$+ +6$ "6% "6& "6' "6( "6) "6* "6+ " 6, " 6- " 6. " 6/ " 60 "61 "62 "63 "64 "65 "66 "67 "68 "7O69 "6: "6; "8%+%7O 6< Y5=]ZT%6 CyVY5>]ZT6 CyVT[T[6?6@6A6B6C6D6E6F6G6H6I6J6K6L6M6N6O6P6Q6R6S6T6Uh?6V?llll6W6X6Y6Zh6[6\6]6^8O6_ ^V5` ^V 5a ^V 5bT5cT5di   ),.02468:<>@+   "$''*,.024*,;=?;=?DFHJLNPRU>+,9eT%CVc(c8e@(CV5f(7e8! 8%&c?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?h?6g?6h?h?h?h?i?h?h?h?h?h?h?h?l?h?h?h?h?h?h?i?h?h?h?h?h?hh?h?h?h?h?h?h?h?h?l ?h?:+";+h?i?6i?   !#%')+-/13579;=?ACEGIKMOQSUWY[]_acegikmoqsuwy{}>EF9j:9kToD C6l8' +8: "5m8%!gblz }UE\8B! ! V-DV8%8: "6n8L" 8B!6o8#TC 8B!6p8# zUcc8%L%Ch{V C@hI[(%)*! !h?h ] }U\^l yV zUcc8c" F E D C +  8b   6q8f c 8I" 8b ^VC( W'+/37;?CGKOSW[_cgk3BKTXggk{ 5r(5s(5t(5u(5v(5w(5x(5y(5z(5{(5|(5}(5~(5(5(5(5(C6 ^V5 8%"68%&5(C V)D C V6@ @6@68L&5 8%"68%&56 @[C6 ^V 68%&5(5 C8%"68%&C V5D C V5 6@ @6@68L"8%&568%" 8%"68%&56 @[5 C68L"8%"68%&5 C8%"68%&5 C8%&5 C8%&C(5 C8%"68%&CTF E D C68$C E D68$5 C8%"68%&5 C8%"68%&5 C8%"68%&5 C8%"68%&5 C8%"68%&C D5 8%"68%&E5 8%"68%&5 8%"68%&C D5 8%"68%&5 8%"68%&6 8%"68%&)* VT&)*] ~V @(^   @(l0^l pno2&] ~Vc(^ A9a{]^!8: "2%[E^8B!!8: "2%. @%3&+W 3&3&c %)*] ~Vc%^ A3a{Y^! 8: "1%[D^8B!! 8: "1% )! D E8%" }U\! zUcC1%c%h" D C] {V)^."^.h" D {Vc! CA( A(58@[d _d _(c _(d _()*+ ++ +,[ +~   ,wc % !^(!^(c(2! @( 56 @[W"%)-1""""59=""A"EI"MQ"UY], %c(5(5(5(5(5(5(5(5(5(5(5(5(5(5(5(W'*-048<@DHLPTX\`dhlptx|d(e(f(g(g(g (g (g (g(g(g(g(g(g(g(g(g'(g(g(g(g (g (g(g(g(g(g(g(g(g(g(g(g (g!(g"(g#(g$(g%(g&(+;l' +i ^h ^ + + +Q +66 h" i" +ah?  +6? +6 +D  > 9T)*C VVEC V>Y 56]^ZT6 CyVcT[ Vc(YC #dZ(8% CyVc([(7%]I 2'C V%Y   C C  dZ(8% CyVc([( &)* @(c8 !()*81 ')* 8" CnI()*8!V!+ " 68f c 8I"(C! &)* "5 8f&)*5 CC^V  #Vc( 68f$)*C! E C CFDFon6 ^V#Vc(DFCF68f$ D6 8f h|V6 8f$ (E Fo D CA(cI()*!6 8f'CV%(8 ! 8 ! ^V(7 ^V2%7 ^V 2!8 % 2!8&8!V h]8"T , %)*Fm h}V7%?[ Eohhh }U3\ nD^l yV CF}V DF}V zUc DF CF6 8f 58?"chh }U\ n D^ gyVyV  8C"TyV CF {V g. 8C"T 8C"TyV DF {V  8C"Tg. 8C"T}V{V 8C"TyVyVP5 8f" CF }U\g  8C" zUc CF DF }U\g^ 8C" zUc~V|V5 8f" DF {V 5 8?" zUc( )*c 8I"Fm h}V7%?[C E }U\D^l yV zUc ~V7%?[7%8%+!]c68%!c Eo }US\V 58%!cCF yU CF yVd]DF yU DF yVc] nD^ 8%!l y zUcc]C]7%8%+% c 8! 8!A(dh8!h8!A(ch8!h8!A()*chi> M (c G G A(ghi >i A(c? +6 ! + + + + +6?h?h?h? + ++ ,#+ + ++6 G F E DC +  + + + + + +u+e +Y  +M"   (*,.03377>#9T)*W  C@(C D@2&58!%)*Y!g.8L # 2" o8L#@Z(6 CyVc ]o8L#@([)* @(c " VD C? +8:'5(W C(D(58!%h&,b+ + ,v+ A9T~)*WIWiF E DC68C^V 8#V 68f$ 8 6 8f  8 68f$ C8 6 8f$D C8 68f$ C8 6 8f$5?6? +y A9T.V!C D2!i DD DCA h @@?@ &ch868"A%V!C D2!i DD DCA h @@?@ &ch868"A%)* yV ??% 8B!2" ??!@%)* }V 2& yV ??% "%)* l8 $)* l8 $)* k8 $)* j8 $)* i8 $58%%d 8 "(d 8 " 8:%d 8 " ?(d 8 "h !@?(d 8 "(5?[c 8 "h @(d 8 "h 8 " @(c 8 "(d 8 "h 8 " h !@?@(c(c(d 8 "h 8 " h !@?@(d 8 "h 8 " h @?@(d 8 "h 8 " @(d 8 "h 8 " h @?@(d 8 "h 8 " @(c 8 "i "?%d 8 " ?%d 8 "k6i6$g 8 "k 8 "h 8 " k"A%f 8 "i 8 " @%f 8 "i 8 "l6j6$f 8 "i 8 " @%f 8 "i 8 "l6i6$d 8 "(d 8 "k6i6$d 8 " ?%f 8 "i 8 "h ? !? A!?%g 8 "k 8 "i 8 " ? !? ? !?A!?%f 8 "i 8 " ? !?h A!?%e 8 "l6i6$e 8 "l6i6$d 8 "l6i6$c 8 "(d 8 "h 8 " !@(c(c(d 8 "h 8 " !@(d 8 "h 8 " @(d 8 "h 8 " @(d 8 "h 8 " VC CCVDVT D?%8:! @%g 8 "j 8 "h 8 "h8! Aj"@%c 8 " 8:!?%d 8 "h 8 " j "@%e 8 "h 8 "l8! 8"j "@%d 8 "h 8 " j "@%c 8 " 8:!?%e 8 "h 8 " k "@%c 8 "j "? %c 8 " 8:!? %c 8 " 8:!? %c 8 " ? %c 8 "(e 8 "h 8 " @%g 8 "j 8 "h 8 " j"A%c 8 "h @(e 8 "h 8 " @(g 8 "j 8 "h 8 " i"A(c 8 "i "?%d 8 " 8:!?%d 8 "k6i6$g 8 "k 8 "h 8 " k"A%e 8 "h 8 " 8:! @%c 8 " ?%d 8 "(d 8 "k6i6 $c(d 8 "h 8 " @(e 8 "i 8 " @(e 8 "h 8 "h8!h Aj "@%g 8 "j 8 "h 8 "h8! Aj"@%c 8 " 8:!?%d 8 "h 8 " j "@%d 8 "h 8 " j "@%c 8 " 8:!?%c 8 "hk "@%e 8 "h 8 " ?k "@%c 8 "j "?%c 8 " ?%c 8 " 8:!?%c 8 " 8:!? %c 8 "(g 8 "j 8 "h 8 " j"A%c 8 "h @(e 8 "h 8 " @(e 8 "h 8 " i "@(e 8 "h 8 " @(c 8 "h @(f 8 "j 8 "i 8 "h8 " C8:%!h8! D k"DC@ >(c 8 "(e 8 "h 8 " @%d 8 "h 8 " E DC>%c8!h@(d 8 "h8! 8:!@(e 8 "h 8 " E DC>%d 8 "h 8 " E DC>%c 8 "(c 8 "(d 8 "h 8 " 8:! @%f 8 "j 8 "h 8 " 8:!A%e 8 "h 8 " 8:!l8! 8"@%c 8 "hi "@%d 8 " ?%d 8 "k6 i6 $f 8 "i 8 " @%f 8 "i 8 "l6 i6 $d 8 "(d 8 "k6i6$d 8 "h 8 " 8:! @(d 8 " %f 8 "i 8 " @ %c%c(d 8 "h 8 " @(e 8 "i 8 "h 8 " A%c 8 " ?%c 8 " ?%c 8 " ?%c 8 " ?%c 8 " ?%c 8 " ?%c 8 " ?(c(g 8 "j 8 "h 8 " hyVc!il8!8"A(f 8 "j 8 "h 8 " k"A(g 8 "k 8 "j 8 "h8 " k">(g 8 "l 8 "k 8 "j8 "h8 " D C A!k">(g 8 "j 8 "h 8 " hyVc!hl8!8"A(g 8 "k 8 "j 8 "h8 " hyVc! l8!8"A(f 8 "j 8 "i 8 "h8 "h @!l8!8">(g 8 "l 8 "l 8 "j8 "h8 " ? @!l8!8">(g 8 "l 8 "l 8 "l8 "j8 "h8 " # D? C@!l8!8">(c 8 "(g 8 "j 8 "h 8 " !68%"A%f 8 "j 8 "h 8 " !68%"A%g 8 "j 8 "h 8 " A%e 8 "h 8 " 6A%e 8 "h 8 " 8:!l8! 8"@%c 8 "hi "@%d 8 " ?%d 8 "k6i6$d 8 "h 8 "h8! 8:! A(d 8 "(c%c(d 8 "h 8 " @(c 8 " ?%c 8 " ?%c 8 " ?%c 8 " ?%c 8 " ?%f 8 "j 8 "h 8 " h>(f 8 "j 8 "h 8 " i>(e 8 "h 8 " ih>(f 8 "j 8 "h 8 " A(e 8 "h 8 " h A(f 8 "j 8 "h 8 " A(e 8 "h 8 "h8! A(e 8 "h 8 " @(e 8 "h 8 " @(c 8 "h @(g 8 "k 8 "j 8 "h8 " C8:%!h8! D k"DC@ >(e 8 "h 8 " @(c 8 "h @(g 8 "k 8 "j 8 "h8 " C8:%!h8! D k"DC@ >(c 8 "(d 8 " %e 8 "h 8 " @%e 8 "i 8 " D C68%"A(c 8 " Dh C68%"A(g 8 "j 8 "i 8 " 68%"A(d 8 "h 8 " h 68%"A(d 8 " Dh CA(c 8 " Dh CA(d 8 "h 8 " h A(c 8 " h6A(c 8 "i "?%c%c(c 8 " ?(c 8 "(e 8 "h 8 " D@ ! C@(c 8 "i "?! @(c 8 "(e 8 "h 8 " @ %c 8 "(d 8 "h 8 " 8:! @%f 8 "j 8 "h 8 " 8:!A%f 8 "j 8 "h 8 " k"A%e 8 "h 8 " k "@%d 8 "h 8 " 8:!h6A%d 8 "h 8 "h E@@ D CA%e 8 "h 8 " @%f 8 "i 8 "h 8 " 8:! @%f 8 "i 8 "h 8 " 8:! @%e 8 "h%c 8 " 8:!?%d 8 "h 8 "h ?i"A%d 8 "h 8 " ? @ %g 8 "j 8 "h 8 " ? A%e 8 "h 8 "h A%f 8 "i 8 " @%g 8 "l 8 "l 8 "k8 "i8 " j ">%e 8 "h 8 "h8!h @ @?!&f 8 "i 8 "h8!h @ @?!&e 8 "i 8 "h 8 " 'e 8 "i 8 "h 8 " 'e 8 "i 8 "h 8 " 'e 8 "i 8 "h 8 " 'e 8 "i 8 "h 8 " 'e 8 "h 8 " 6 'e 8 "h 8 " 6 'e 8 "h 8 " 6 'e 8 "h 8 " 6 'e 8 "h 8 " 6 'e 8 "h 8 " 6  'e 8 "h 8 " 6! 'e 8 "h 8 " 6" 'e 8 "h 8 " 6# 'e 8 "h 8 " 6$ 'e 8 "h 8 " 6% 'e 8 "h 8 " 6& 'e 8 "h 8 " 6' 'd 8 "h 8 " &d 8 "h 8 " &g 8 "j 8 "h 8 " k "A %g 8 "k 8 "h 8 "h 6(@@ 6)@@ 6*@@6+6,"?!@%g 8 "k 8 "h 8 "h 6-@@ 6.@@ 6/@@6061"?!@%g 8 "k 8 "h 8 " 'e 8 "h 8 " i "@%c 8 " %c 8 " ?%d 8 " ?%d 8 "k62i63$c 8 "i "?%c 8 " ?%c 8 "hhi "A%c 8 "h @ %d 8 " %d 8 "k64i65$d 8 " %chh8!668"A%d 8 "k67i68$e 8 "i 8 " D C A%e 8 "h 8 "k " @ %g 8 "i 8 " i "@%g 8 "i 8 "l69k6:$g 8 "i 8 "h 6;@@ 6<@@6=6>"?!@%g 8 "i 8 "l6?k6@$g 8 "i 8 "h 6A@@ 6B@@6C6D"?!@%g 8 "i 8 "l6Ek6F$g 8 "i 8 " &g 8 "i 8 "l6Gk6H$d 8 " C D@ %d 8 "k6Ii6J$e 8 "i 8 " 8:!? %e 8 "i 8 "l6Ki6L$5M%e 8 "i 8 " 8:!!%e 8 "i 8 "l6Ni6O$d 8 "h 8 "h 6P@@i "@%c 8 "h 6Q@@i6R"@%c 8 "j "?%e 8 "i 8 " 8:!?%e 8 "i 8 "l6Si6T$5U%e 8 "h 8 " @%d 8 " ?%f 8 "i 8 "h ? !? ?!A%e 8 "l6Vi6W$c 8 "h @(d 8 "h 8 " @(c 8 " 6X@(c 8 "(d 8 "h 8 " @(c 8 "(c 8 " D C6Y8%"@(d 8 "h 8 " 6Z8%"@(c 8 "i ?"?! @(c 8 "h @(e 8 "h 8 " @(c 8 "h @(d 8 "h 8 " @(d 8 "h 8 " i "@(g 8 "l 8 "j 8 "h8 " @!i"@ !@(g 8 "l 8 "j 8 "h8 " # C Di"@ !@(e 8 "h 8 " @(c 8 "(e 8 "h 8 " D C A%c 8 "(d 8 "h 8 "h E@@ D CA%e 8 "h 8 " @%d 8 "h 8 "h @@(f 8 "i 8 "h 8 " @@(c 8 "(d 8 "h 8 "h E@@ D CA%e 8 "h 8 " @%c 8 "(e 8 "h 8 " @%e 8 "h 8 " @(e 8 "h 8 "h @ @(e 8 "h 8 " ?@(c 8 " h@(c 8 "h @(e 8 "h 8 " @(d 8 "h @(e 8 "h 8 " i "@(c 8 "i "i "@(e 8 "h 8 "h i"@@(g 8 "j 8 "h 8 " k"@@(c 8 "h @(e 8 "h 8 " @(c 8 "h ?@(e 8 "h 8 " ? ?@(c 8 " ?h@(c%c%c 8 "(e 8 "h 8 "k " @%c 8 " 8:!?%d 8 "h 8 "h ?i"A%d 8 "h 8 " ? @%e 8 "h 8 "h8!h @ @?!&f 8 "i 8 "h8!h @ @?!&e 8 "h 8 " @%c 8 " ? %c 8 "i "?%c%c 8 " ?%e 8 "h 8 " &c 8 "hhi "A%c 8 "h @%c 8 "j "? %d 8 " D C@%d 8 "l6[i6\$e 8 "i 8 " 8:!!%e 8 "i 8 "l6]i6^$e 8 "i 8 " 8:!?%5_%e 8 "i 8 "l6`i6a$d 8 " %d 8 "k6bi6c$f 8 "i 8 " @ %f 8 "i 8 "l6di6e$d 8 "k "? %f 8 "i 8 " ? !k "? !@ %f 8 "i 8 "l6fi6g$e 8 "h 8 " @(e 8 "h 8 "h @ @(c 8 "h @(e 8 "h 8 " @(c 8 "hh @@(d 8 "hh @@(f 8 "h 8 "ih @@(e 8 "h 8 " D C @@(e 8 "h 8 " i "@(c 8 "i "i "@(c 8 "h @(d 8 "h 8 " @(c 8 "h @(e 8 "h 8 " @(f 8 "j 8 "i 8 "h8 " 8:%!h8! DEDC8:!C>j"@(e 8 "h 8 " @(c(5h(c 8 " ?ihA(c 8 " ?hhA(c 8 "hi 8:!?A(c 8 "hh 8:!?A(e 8 "h 8 "h 8:!?A(g 8 "j 8 "i 8 "h 8:!?A(g 8 "j 8 "i 8 "h8 " ? 8:!?A(g 8 "l 8 "j 8 "i8 " ? 8:!?A(c(c 8 "h @(d 8 " 8:%e 8 "h 8 " k "?@(d 8 " h@(c 8 "h @(e 8 "h 8 " @(c(c 8 "h @(d 8 " 8:%e 8 "h 8 " k "@(5i(5j(5k(c 8 "h @(e 8 "h 8 " @(c 8 "h @(e 8 "h 8 " @(d 8 "h 8 "h8! D Ci">(c(c 8 " 8:%5l(c 8 "h 8:!@(e 8 "h 8 " ? 8:!@(c 8 " ?h@(c 8 "h @(e 8 "h 8 " @(f 8 "j 8 "h 8 "h8! j">(c 8 "h @(e 8 "h 8 " @(?(g 8 "k 8 "j 8 "i8 "h8 "8:%!h8! D?h8:!C +8: ">?k"@(?(f 8 "j 8 "h 8 " 8:%!h8! D ?ihhC +8: ">?k"@(e 8 "h 8 "l "?j "@(e 8 "h 8 "l "?j "@(d(c(c 8 "h @(e 8 "h 8 " @(c 8 " h@%e 8 "h 8 " 8:!@%c 8 "(f 8 "h 8 " @%c 8 "(g 8 "j 8 "h 8 " !6m8%"A%f 8 "j 8 "h 8 " !6n8%"A%g 8 "j 8 "h 8 " A%e 8 "h 8 " 6oA%c 8 "(d 8 " V DUC(7 ?[c 8 " ?%c%c 8 "hi "@%d 8 "h 8 "h @j "@%e 8 "h 8 " 8:!l "@%d 8 " ?%5p%d 8 "h 8 " hj"A%f 8 "i 8 "h 8 " h@k"A%g 8 "i 8 "h 8 " 8:!l"A%d 8 "hih @A%d 8 "hi 8:!A%f 8 "i 8 "hi 8:!@A%e 8 "i 8 "hh 8:!A%5q%e 8 "i 8 "6ri 8:!A%g 8 "k 8 "i 8 " 8:!?i 8:!A%d 8 " ? %c 8 "hi "@(e 8 "h 8 " i "@(e 8 "h 8 " j "@(c 8 "h @(e 8 "h 8 " @(c 8 "h @(e 8 "h 8 " @(c 8 "(c 8 " ?(f 8 "i 8 "h 8 " 8:! A(c 8 "hi A(d(c(c 8 "h @(e 8 "h 8 " @(d 8 " 8:%c(c 8 "h @(d 8 "h 8 " @(c 8 "(e 8 "h 8 " 8:! @?%c 8 "h @(e 8 "h 8 " @(c 8 "h @(e 8 "h 8 " @(e 8 "h 8 " @(d 8 "h 8 "h @(ch!@(e 8 "h 8 " @%c 8 "(c 8 " ?(c 8 " ?(c 8 " ?(c 8 " ?(c 8 " ?(c 8 " ?(c 8 " ?(c 8 "(c 8 " m?(c 8 " 6s8%"?(c 8 " ][?(c 8 " ]p?(c 8 " ]?(c 8 " ?(c 8 " ?(c 8 " ?(c 8 " ?(c 8 " ?(c 8 "(c 8 "(c 8 "(d 8 "(c 8 "(c 8 "(c 8 "(c 8 "(c 8 "(c 8 "(5t(5u(5v(5w(5x(5y(5z(5{(5|(5}(5~(5(5(5(c 8 "(5(5(5(5(c 8 " ?(e 8 "h 8 " @(c 8 "(5(5(5(5(c 8 " ?(e 8 "h 8 " @(c 8 " ?(e 8 "h 8 " @(c 8 " ?(e 8 "h 8 " @(c 8 " ?(e 8 "h 8 " @(f 8 "i 8 " &c 8 " ?(e 8 "h 8 " @(c 8 " ?(e 8 "h 8 " @(c 8 " ?(e 8 "h 8 " @(c 8 " ?(e 8 "h 8 " @(c 8 "(5(5(5(5(c 8 "h @(d 8 "h 8 " ? @(d 8 "h 8 " ? @(d 8 "h 8 " ? @(d 8 "6 @(d 8 "6 @(c 8 "(c(d(c(d(d(c(c(d(d(c(d(c(c(c(c(c(5(5(5(5(c 8 "8 @[c 8 "8 @[c 8 "8 @[c 8 "8 @[c 8 "8 @[)* @%)*c ?A! +8:# " @! @(D! C@(C W -8lwcTC D#?TE2! D2! CATC28: "?TC C WDUC 8:"V?TTT D28: " @ToC38: "?TdE D28: " CATUD D# C2!@T@E D C48: "AT0C D"8: "D2! @TC D2+&8: " C@? T D @(C V D1! C@ D @(WE48: " D CA(C4!?()*, %)* 8:"V  @8@[()* 8!"?%)* 8!?"?%)*7j CV @(c8!?8@[)*7j CV5T5 ! VD C VpD C V=DVTc 6@@ C6@@ 6@@ 6@@6@@6"?!@% c 6@@ 6@@ 6@@6@@6"?!@% c6@@ 6@@6@@6"?!@%c6@@ ? !6@@ 6@@66"?!@%)*7j CV5T5 ! VD C V`D C V5DVTnc C6@@ 6@@ 6@@6@@6"?!@% c 6@@ 6@@6@@6"?!@% c 6@@6@@6"?!@%c ? !6@@ 6@@66"?!@%C W %%%%%%%%!%%%%%%%%%%%%%%%%%%%%%%%%C(c @()*7 6@@8&)*8! 8!>8@[7?[)*7j CV 68%"T ?@8%Di D CA ?@()*h ?868"A@()*h ?868"A@()*C6 ^V 5 ^UaT0W ,,!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,CWMMMMW ,,!,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,CWc 6@@i 68%""@%%)*C6 ^V 5 ^UT`W \\!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\C W  +T,Cm??%C][??%C]p??%C]??%W <<!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<C W T C!??%c 6@@i 68%""@%]c ^- ]i 8L'68%&)*c 6@@ 6@@j "@%C W OOOOOOOOO!OOOOOOOOOOOOOOOOOOOOOOOCC WT"5 C^VTDVTETc%?%c8! @(c8! @(c8! @()*8! "?@()*8! ?8"?@(c8! C@(c8! C@(Dh @68!@@()*8! 8&c8! @(c8! @(c8! @(c8! @(c8! @(c8! @(c8! @(c8! @(c8! @(c8! @(c8! @(c8! @(g]7+ + + + + + + + +} +o +a +S +B ++ + + ++ + + ++S+3 + +<+ + +q  , ,+M +- ,!,#+ + + + &+ '+ +'+)+ + + ,+86]6]6666666l|56666 + + + + + + + + + + + + + +z +s +l +e +^ +W +P +I +B +; +4 +- +! + + + + + + + + + + +{ +e +V +@ +1 + + + +@+ + + + + +q +b +L += +5 +- +% + + + + + + + + + + + + + + + + + +x +p +h +` +X +P +D +8 +, + + + + + + + + + + + + +| +k +Z +E +5 +) + + + + + + + +++ +y +c +M += +' ++ + + + + + + + + +| +k +J +; +/ + + + ++++++`+B+8++++++}+_+U+D+"++++ + +++p+G+ ++ +++ + + + ++k+K+ + + ++c +M += ++ + + + + ++ + + +} +m +e +] +U+; ++ + + + + ++ + + + +n +B + + + + + + + + ++G +1 +! + + + + + + + +n +X +H +/ ++$+$++%++w+h+L)+B*+' +  + +.+$0+0+&2++n3+]4+T*6+>6+-7+'+(+:+0<+<+z2>+] +Q+H+? +- + + + +;+<+ >+>+g +W +A +1 +! + + +P+ +R+C+| +p +Q +8W+ H+ +J+ + +2MP+}LNQ+GP+- + + + +Ze+ + + + +o +c +R +< +,L+\_p+o+p+q+Q+s+ju+ogv+Phw+,V+^l+y+Y+{+[+}+]+l[+U_+8dr+a+ft+c+{+x|+[+@g+++}+j++++++p+{+j+Y+J+-q+z+{++h+R+<+$+ ++++++|+d+L+4+++++++s+M+'++++++c+N+?+++++++b+?+# ++ +++ + + +++z +h +Q +> ++ + + + +++ ++B +2 ++ + + + + +k +T +7 + + ++++++ +u +n+e +Y +:+%++++++t+J +>+++x+A+++++Y +R +C+2+!+++++ + ++ ++q +W+B +6+ +++ +++|+` +T +H+*+ + +++ ++h +X +B+( + +(+ +(+)+*+#,+$-+a%.+J.+5'0+(1+1+*3++4+ + +i +b+M +A:+0;+3=++>+6@+7+ +w +g:B+BB+* +C+ D+E+@G+AH+H+CJ+~DK+WEL+:L+%GN+N+ + +9+| +u +n<+U +I9+3:+;+KN\+LO]+MP^+]+t@+_ +SB+7a+D+c+]e+G+f+`h+ +t +Y +C +(S+ + +V+ + + + + +\+ +s +c +W +L>D 8  > + + + ++ >C9T gl^ M c 3&)* !8{# K  C! 2&WLL\`dhCg8m "&*.26:>BFJNRVZ^bfjnnw chih 1%1%gW(gR(8{! ]i 8L# 8"V8! ? A[? (gD(gE(8{! ]i 8L# 8"V8! ? A[? (8{! Y 8"Z(6 CyV? ([8{!?(Y8{!!?Z(6 CyV 8!6 A[[8{!!?(Y8{!!?Z(6 CyV 8!6 A[[Y8{!!? Z(6 CyV 8!6 A[[Y8{!!? Z(6 CyV 8!6 A[[c!dIG 8!I4!cI M c!?( dhih d 8{"?(d 8{"?(e 8{"!?(e "?(f "?(8{! ]i 8L# 8! ? A[8!h @Ic!3!h!h!E DCA @?(8!CVc 8"c @Ic!3!h!h!E DCA @?(8!i 8"G MG F E D C>M gO(d G ^h G ^ 8{ #j G ^kG ^8{ #  ci]Y  1%gM(d(c(g(gF(g4(gJ(gO(g(g9(g(g(g (g (g(g(gK(gL(g1(g2(g(g-(g.(g/(g0(gH(g+(g,(g(g(g (g"(g$(gG(g#(g(5(gA(gB(g7(g8(8{!?(8{!?(8{!?(8{!?(8{!?(8{!?(g(8!h 8{"? A[gn 3&)* 8{#  C! 2&W !IC 8!@I !1%C VD V I !1%cI8%56 @[8!Ig" !dIY3!ZT; CyV0DV+C VC8:!8:!hIC ? A[56 @[T[cIg" !1% !1% dhih  !1%C VC8:!8:!hIC ? A[56 @[ chih  !1%gj^ M g 3&)* 8{#   C! 2&W -=IUc(Gh G ^ 8{ #  ]hih  1%d 8{"!!1%d "!1%e "!1%c !V1%8!l 8"c 8{"!d 8{"!1%c !XV g 8!8" chih  !1%cI ChA[c 8{"!1%g 3&)* 8{#   C! 2&W chkh$chih$c(! W]oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooor(CC D C@@I2%cIcIcI(C8:%)*W'/7A5 8f&C8B!6 8f'C6 8f'5 8f&5 8f&C6 8f'C6 8f')*G VCTC F FoVTDn > M ()* ~V ~V(h8L'^ _ _ 2& 2&] ,ch &]h 8L#68%"]](]h 8L#68%"]]p(]h 8L#68%"]m][(68%"]Ym()* 8{" aT AT  8{" aT AT lpn8B%)* 8{"  8{"l p 8{"ldpnn c!Vgx(8! 8{!?A[8B%n#u(W  g ((g (g (b(g(C(Chz(ChC8L#I(8{!h ] }U\ ^! zUc(C]C~VeC]p] C]hhC8L ICCS(IcI(5?6l8!"l] ?h? + + +~ +i8?h? +Wh? +Li? ++ +w +f +K +0 + + + +N6     "$&+-,]l@G`oJQc?  ,t+ + +   > &9TY8! V  LT2!TcZ(8 CyVDW c(2%[)*Yc8!8"h8!Z(8 CyVDW \\\[58C^V![7 CyV58C^V![7 CyU 7 CyUT8!68C^V!?8@[[gL8!U g8!Vc(%,%+ +Y8 !8 !8 !8! >9TT)*WC E"XV C F"I(C 2&C 2"D 2&W E!8: &C&)*C W #3#>DPVc(D 2"E 2&C 2!8: &C "D 2!8: &C 4!8: &C 2&C 2+8: &D 2&C 3&D()*C "D +8: " 1!8: &)*C VD 4&()*C W%C "D !8: &C C "D 3!8: &D "E 2&)*C W C 1&CF &CE &C C "D &C"D&)*C W !.6CNY_c(C 2&C 2!8: &C "D 2'D 2'C 2+8: &C 2"D 2&C 2"D &C &C CCF"I(D&C"D&D&)*C W !$!+9FWWblzb$#1DKc(C &D C4# E 2&D 2#E 3&C 2"D 2+8: &C 2"D 3&C 2!8: &C "D 2'D 2'C 2+]8: "D 2'C 2"D &C 2"D "E 2&C 2"D 2"E 2'C 2"D 2&D 2"E 2"G 2&C 2"D #E 'C 2&D 2&C 2+8: &D 4 "E CCF"2&C 2"D 'C C #" D 4!8: &C 4 &C "D 2&C" D &)* 1!+8: &D&)*C &)* +8:# T 4+8: "(D W  C&C&)*C W $8C &C 3&D 2"E CCF"2&C 2"D +8: &C 4&)*V D C 3"2&(D&CC(D&)*C W #0?`nwDC "(C +8: "(D !8: "(D 4" CCF&C +8: "F8:# 4+8: "(D VC 4"(C "(C 4"(C !8: "()*C W (3?C &C 3"c(D 4"E CCF"2&C 2"D 2&C 2"D 4&C 4&)* 38:'D"E&CC(D&)*C W )8EN]C 4"(D C4'DC "(C +8: "(D !8: "(D  "(D 4" CC F&C +8: " F8:# 44+j8: "(D 4"(C  "(C 4 !8: "(C !8: "(C 4"()* 38:#c()*W C 4&(D&)*C W)=O]C "D !8: &C C  " D 3!8: &D 4 #E  " F 2&C 2"D 4+8: &D C4# E 2&C 2"D  &)*C W  )D 1&CETCF 4&C C "D &C 4& &)*F 4&)*I "C()*F &E&D!8: "E!8! &Wc(C+8: &C+8: &C"D&)*D +8: "G #,E %)*VC &()*C &)*C Wc(C &C()* ^(+ ?8! + C? ,+ + ,3M+ +y,N+  C?   , +   , 'J-N 0 !>9T]VYC!Z(6 CyVD2%[5?[?I(7O 68g"c8%L%7O 68g"c8%L%D5T5 C6818f$)*C 6818f#DC +8: "5818f"68&8"VC @I(8" D Ch I +8: "CdIC68"8&C@I(#d @8"Vd &c @8"Vc &(d @8"Vd "c @8"Vc &()*C @@I(F D C +E +8G "hyVd @8"Vd &(D C 8 !8!h ^8B!h _ @h? @ 8#C @IE>(gh8"h? +8: " +~8: "d? T\ChIc I +8: "CVCChzV5818f" +y8 "58!c(C 8!8:"Vh&C 8!8:"Vi&()*8IY]V !T!Z( &8#CVC iA@I(CV &8!6 i!8G # Ch68%"@&8%"](8  #CVC8ChA@I(CV &8!h6 8%"@CVc6 8%"@6 8%"@T c6 8%"@CVc@68%"C+8:"Vc @ @@@TCVc @ @@ D Ch!8G # C 8%""D 8%"& 8%F!%)*7C8IY4! 8%:! + Y ! 8C"c!7CZTh ![Z( "7C()*dI7 CyVD8 E8 6 818f$7 CyVD86 818f$5 CyV D6 818f' CyV 6 818f'[7e "V 8%B! 8%B%c 8%C"8{!8C 8"8%7e "V8%B!h 8%B!?@(c 8%C"8{!8C 8"8%)*Y2]8!" ^VdTg h8L#l h 8L#^V5 8%!Z(6 CyVc([C V8!%(C V27%8%+!56h8 #  C68  ]hzV 8!!?[((]h{Vc ^ cTdV g 8%!8%%()*!8%! +8G "g 8%%)*V=D CCU ] nMhzV58%!! ]n2&8%!! ]2&58%%)*,h@8%" 8%"h &)*] ~V(^  2& 2&)*] ~Vc(^ g\ _g _ 2&^ _ 2&CV!Tl 8L"U8%%,ch " ]n] ,ch "8%%8%"]()*D C YoC8%!8: " ! 8!6 8%"C +8:"CV c @T&V c68%"@ @TV c68%"@Tc @ 8%" @@Z(6 CyVYC 8%!8: " ! 8!CV c6 8%"@Tc6 8%"@TcCV5T5 8%"@CV' c6 8%"@T c6 8%"@6 8%"@T c6 8%"@ 8%" 8%"@Z(6 CyV @([[)*O ~Vc( ^ ^U ^V?( 2&V%C Ch D" VC6 ^V( 8&D2%5?[8L! ,,C %)*]c ^. C @ I(6818f#dI(Y 8e8!" ]h @@C8%"IZ(6 CyVD6 818f#dI([5!8O^V(8L!h ] }U\ ^l\yVg/ _ zUc(c?6"?6#?h?h?h?h?h?h?h?h? + +^+3 + ,j+6$ D C+> + +Ph?6%? + + + +U +$+ +n   !&+  !+1 + !#+ +s6& + +h8jI7!h6'?6(A@6)?6*A@6+$?6,A@6-'?6.A@6/+?60A@61"?62A@63(?64A@65%?66A@67)!?68A@69*!?6:A@6;i !?6<A@6=h !?6>A@6??6@A@6A#?6BA@8# CVC!"CVeTc8%L!    "$&))-/13579;=?ACEGIKM>'(9Cc8%P!:9Dcaml_alloc_dummycaml_alloc_dummy_floatcaml_update_dummycaml_array_get_addrcaml_array_get_floatcaml_array_getcaml_array_set_addrcaml_array_set_floatcaml_array_setcaml_array_unsafe_get_floatcaml_array_unsafe_getcaml_array_unsafe_set_addrcaml_array_unsafe_set_floatcaml_array_unsafe_setcaml_make_vectcaml_make_arraycaml_array_blitcaml_array_subcaml_array_appendcaml_array_concatcaml_comparecaml_equalcaml_notequalcaml_lessthancaml_lessequalcaml_greaterthancaml_greaterequalcaml_output_valuecaml_output_value_to_stringcaml_output_value_to_buffercaml_format_floatcaml_float_of_stringcaml_int_of_floatcaml_float_of_intcaml_neg_floatcaml_abs_floatcaml_add_floatcaml_sub_floatcaml_mul_floatcaml_div_floatcaml_exp_floatcaml_floor_floatcaml_fmod_floatcaml_frexp_floatcaml_ldexp_floatcaml_log_floatcaml_log10_floatcaml_modf_floatcaml_sqrt_floatcaml_power_floatcaml_sin_floatcaml_sinh_floatcaml_cos_floatcaml_cosh_floatcaml_tan_floatcaml_tanh_floatcaml_asin_floatcaml_acos_floatcaml_atan_floatcaml_atan2_floatcaml_ceil_floatcaml_hypot_floatcaml_expm1_floatcaml_log1p_floatcaml_copysign_floatcaml_eq_floatcaml_neq_floatcaml_le_floatcaml_lt_floatcaml_ge_floatcaml_gt_floatcaml_float_comparecaml_classify_floatcaml_gc_statcaml_gc_quick_statcaml_gc_counterscaml_gc_getcaml_gc_setcaml_gc_minorcaml_gc_majorcaml_gc_full_majorcaml_gc_major_slicecaml_gc_compactioncaml_hashcaml_hash_univ_paramcaml_input_valuecaml_input_value_from_stringcaml_marshal_data_sizecaml_int_comparecaml_int_of_stringcaml_format_intcaml_int32_negcaml_int32_addcaml_int32_subcaml_int32_mulcaml_int32_divcaml_int32_modcaml_int32_andcaml_int32_orcaml_int32_xorcaml_int32_shift_leftcaml_int32_shift_rightcaml_int32_shift_right_unsignedcaml_int32_of_intcaml_int32_to_intcaml_int32_of_floatcaml_int32_to_floatcaml_int32_comparecaml_int32_formatcaml_int32_of_stringcaml_int32_bits_of_floatcaml_int32_float_of_bitscaml_int64_negcaml_int64_addcaml_int64_subcaml_int64_mulcaml_int64_divcaml_int64_modcaml_int64_andcaml_int64_orcaml_int64_xorcaml_int64_shift_leftcaml_int64_shift_rightcaml_int64_shift_right_unsignedcaml_int64_of_intcaml_int64_to_intcaml_int64_of_floatcaml_int64_to_floatcaml_int64_of_int32caml_int64_to_int32caml_int64_of_nativeintcaml_int64_to_nativeintcaml_int64_comparecaml_int64_formatcaml_int64_of_stringcaml_int64_bits_of_floatcaml_int64_float_of_bitscaml_nativeint_negcaml_nativeint_addcaml_nativeint_subcaml_nativeint_mulcaml_nativeint_divcaml_nativeint_modcaml_nativeint_andcaml_nativeint_orcaml_nativeint_xorcaml_nativeint_shift_leftcaml_nativeint_shift_rightcaml_nativeint_shift_right_unsignedcaml_nativeint_of_intcaml_nativeint_to_intcaml_nativeint_of_floatcaml_nativeint_to_floatcaml_nativeint_of_int32caml_nativeint_to_int32caml_nativeint_comparecaml_nativeint_formatcaml_nativeint_of_stringcaml_ml_open_descriptor_incaml_ml_open_descriptor_outcaml_ml_out_channels_listcaml_channel_descriptorcaml_ml_close_channelcaml_ml_channel_sizecaml_ml_channel_size_64caml_ml_set_binary_modecaml_ml_flush_partialcaml_ml_flushcaml_ml_output_charcaml_ml_output_intcaml_ml_output_partialcaml_ml_outputcaml_ml_seek_outcaml_ml_seek_out_64caml_ml_pos_outcaml_ml_pos_out_64caml_ml_input_charcaml_ml_input_intcaml_ml_inputcaml_ml_seek_incaml_ml_seek_in_64caml_ml_pos_incaml_ml_pos_in_64caml_ml_input_scan_linecaml_lex_enginecaml_new_lex_enginecaml_md5_stringcaml_md5_chancaml_get_global_datacaml_get_section_tablecaml_reify_bytecodecaml_register_code_fragmentcaml_realloc_globalcaml_get_current_environmentcaml_invoke_traced_functioncaml_static_alloccaml_static_freecaml_static_release_bytecodecaml_static_resizecaml_obj_is_blockcaml_obj_tagcaml_obj_set_tagcaml_obj_blockcaml_obj_dupcaml_obj_truncatecaml_obj_add_offsetcaml_lazy_follow_forwardcaml_lazy_make_forwardcaml_get_public_methodcaml_parse_enginecaml_set_parser_tracecaml_install_signal_handlercaml_ml_string_lengthcaml_create_stringcaml_string_getcaml_string_setcaml_string_equalcaml_string_notequalcaml_string_comparecaml_string_lessthancaml_string_lessequalcaml_string_greaterthancaml_string_greaterequalcaml_blit_stringcaml_fill_stringcaml_is_printablecaml_bitvect_testcaml_sys_exitcaml_sys_opencaml_sys_closecaml_sys_file_existscaml_sys_is_directorycaml_sys_removecaml_sys_renamecaml_sys_chdircaml_sys_getcwdcaml_sys_getenvcaml_sys_get_argvcaml_sys_system_commandcaml_sys_timecaml_sys_random_seedcaml_sys_get_configcaml_sys_read_directorycaml_terminfo_setupcaml_terminfo_backupcaml_terminfo_standoutcaml_terminfo_resumecaml_register_named_valuecaml_weak_createcaml_weak_setcaml_weak_getcaml_weak_get_copycaml_weak_checkcaml_weak_blitcaml_final_registercaml_final_releasecaml_ensure_stack_capacitycaml_dynlink_open_libcaml_dynlink_close_libcaml_dynlink_lookup_symbolcaml_dynlink_add_primitivecaml_dynlink_get_current_libscaml_record_backtracecaml_backtrace_statuscaml_get_exception_backtracemNfP9 -Out_of_memory)Sys_error'Failure0Invalid_argument+End_of_file0Division_by_zero)Not_found-Match_failure.Stack_overflow.Sys_blocked_io.Assert_failure:Undefined_recursive_module"%,,really_input%input@F@@G@&outputACDF@ACDG@%%.12g!."%d%false$true.bool_of_string$true%false+char_of_int/Pervasives.Exit_j_j_j_j_j_j<5Pervasives.do_at_exit@(array.mlD*Array.blit*Array.fill)Array.sub,Array.Bottom@)List.map2*List.iter2/List.fold_left20List.fold_right2-List.for_all2,List.exists2@@,List.combine'list.mlK-List.rev_map2#nth(List.nth"tl"hd@"\b"\t"\n"\r"\\"\'(Char.chr@5String.rcontains_from4String.contains_from2String.rindex_from1String.index_from +String.blit+String.fill*String.sub@)Sys.Break&4.00.1@1Marshal.from_size3Marshal.from_string1Marshal.data_size *Marshal.to_buffer: substring out of bounds@@"%d_i_i_i_i_i_i_i_i_i@"%d_j_j_j_j_j_j_j_j_j@"%d_n_n_n_n_n_n_n_n_n@ %Lexing.lex_refill: cannot grow buffer @@ A@@@,syntax error.Parsing.YYexit3Parsing.Parse_error@2Set.remove_min_elt@@@@@'Set.bal'Set.bal'Set.bal'Set.bal@:CamlinternalLazy.Undefined@)buffer.mlsI2Buffer.add_channel4Buffer.add_substring>Buffer.add: cannot grow buffer*Buffer.nth+Buffer.blit*Buffer.sub@ !"!"!'!'!. )printf: bad positional specification (0)."%_)printf.mlH"'' )Printf: premature end of format string ``"''4 in format string ``1, at char number 8Printf: bad conversion % (Sformat.index_of_int: negative argument @ ! "%s"%s.bool_of_string)a boolean-int_of_string*an integer-int_of_string*an integer/float_of_string'a float/float_of_string'a float ! (one of: #(?)&--help%-help9%s: unknown option `%s'. 1%s: wrong argument `%s'; option `%s' expects %s. #%s: option `%s' needs an argument. (%s: %s. %-help&--help"%s#%s %-help= Display this list of options%-help&--help= Display this list of options&--help%-help( %s %s !}!|!{* %s %s%s &'Arg.Bad(Arg.Help(Arg.Stop@/Digest.from_hex/Digest.from_hex$%02x0Digest.substring@_i_j A_j,Random.int64_i,Random.int32*Random.int!xzR+]F4J{lGgP2wAv+^  FKk|HHtcHZš/{Yi2zvn6m[b"|ᵟ.xge=xBLX?}nSO}YE] ~N~aNw"\(sd}@*LY= зd(.OR.2E9!DLJ<AGu<*UO^ohf6o/z@@-OCAMLRUNPARAM,CAMLRUNPARAM @.bad box format/bad box name ho:bad tag name specification:bad tag name specification 9bad integer specification*bad format& (%c)."%c =Format.fprintf: %s ``%s'', giving up at character number %d%s@C!.!>"!> Fatal error: 0Misc.Fatal_error@'%s: %B '%s: %s 'version8standard_library_default0standard_library0standard_runtime*ccomp_type3bytecomp_c_compiler4bytecomp_c_libraries1native_c_compiler2native_c_libraries2native_pack_linker&ranlib*cc_profile,architecture%model&system#asm1asm_cfi_supported'ext_obj'ext_asm'ext_lib'ext_dll'os_type7default_executable_name3systhread_supported?/usr/local/ocaml/4.00/lib/ocaml(OCAMLLIB'CAMLLIB "/usr/local/ocaml/4.00/bin/ocamlrun"cc =gcc -fno-defer-pop -Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT 2-lcurses -lpthread 'gcc -D_FILE_OFFSET_BITS=64 -D_REENTRANT 7ld -r -arch x86_64 -o &ranlib"ar#-pg /gcc -bundle -flat_namespace -undefined suppress#gcc /gcc -bundle -flat_namespace -undefined suppress,Caml1999X008,Caml1999I014,Caml1999O007,Caml1999A008,Caml1999Y011,Caml1999Z010,Caml1999M015,Caml1999N014,Caml2007D001,Caml2012T001$.mli%amd64'default&macosx/as -arch x86_64".o".s".a#.so&Cygwin$Unix%Win32(camlprog%a.out,camlprog.exe@ @@'%3i %s 1 A All warnings.", 9 %c Set of warnings %s. = %c Synonym for warning %i. &%d: %s?this is the start of a comment. !this is not the end of a comment.:this syntax is deprecated. Gthis function application is partial, maybe some arguments are missing. 8labels were omitted in the application of this function. &this expression should have type unit.:this match case is unused.;this sub-pattern is unused. #illegal backslash escape in string. (this optional argument cannot be erased. /this argument will not be used by the function. 6this statement never returns (or has an unsound type.) Rall the fields are explicitly listed in this record: the 'with' clause is useless. unescaped end-of-line in a string constant (non-portable code)0unused rec flag. !. `this pattern-matching is fragile. It will remain exhaustive when constructors are added to type !this pattern-matching is fragile.#: 1the following methods are overridden by the class! / is overridden.+the method 1utils/warnings.mlZ \this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (this pattern-matching is not exhaustive. A Either bind these labels explicitly or add '; _' to the pattern. ;the following labels are not bound in this record pattern: E The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)#: %aThis '%s' might be unmatched k%aSyntax error: applicative paths of the form F(X).t are not supported when the option -no-app-func is set. K%a@[In this scoped type, variable '%s@ is reserved for the local type %s.@].%aSyntax error/Syntaxerr.Error6Syntaxerr.Escape_error@"[]"[]&parser#end&struct!)!(!)!(!)!(!)!(!)!(!)!(#end#sig!)!(#end&object!)!(!)!(!?!? #end&object!?!?!?!? !+"+.!-"-.!*!=!"or"||!&"&&":= #set%Array #set&String#end&object!)!("()#end%begin!)!( #get%Array!)!( #get&String!]![!}!{!}!{"|]"[|@!]![ !!">}"{<@!)!( !?!?!}!{!]![@"|]"[|!)!(!)!(!)!(@A@@@A@@A@@!?!? @@@@@!-!!!+"+.!-"-.!*!=!"or"||!&"&&":="()"::%false$true"[]"()%false$true"[]"()%false$true@A!-"-.!+"+.*unsafe_set#set &Array3 &Array2 &Array1 #set(Genarray*unsafe_get#get &Array3 &Array2 &Array1 #get(Genarray(Bigarray'unsafe_"::"::!+"+. !~!-"-. !~!- %false(*predef*&optionx    @ !"#$%&'()/056789:;<=>@ABCDEFGIJKLNOPRSTUVWXYZ[\]^`abcdefhijklm@L *+,-.1234?HMQ_gn@    ############$$%%'(+++**00,,,,111111115666779999999;;<<==>>???-----HHHHKLLMMNNNNNOOOQPPR@&&ST ........YYVVUUWXX[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[22kkllllmGGnnnnooFFF]]^^^qq__ggrrrssjjhhCCCCC888888888ZZZZZZZZZZZZZZZZZZZZZttxxwwwwyyz}}|||||||||{{{//~~""ppDDII33Afffffffuuuuuuuuuuueeddvv!!JJ44 `aaEEBB))::\\iibbcc    D ;<=> ?#@A B "#C*4YIHLMJ80  , rix$)  !-?TN(9/'(|{ D<F(&%)' X.KPOGBCWV+)&/2  ! =><oswxyjmzJUK_Z.-d@RQUSZ"#$ :y6zuv}CB>=G[g]+:cYX,' !";p2pVch\[*t0lH\amlih%8{`f~tmTekjE}v 83DHOZ4EI5QRS789w:^*;j"#k#'B8^CDCbcd<G H~9;`ab$ L9=b_>?@ABCqzI`;3<4k    $VWWFGH, (!t!00*__.(-301N++&(-.0)(-(-  100^0(-(-R3:B:"j1X'ke{22FVN03/n/l)*ng-/Ls(xnw2|./030x!/n  G (-(-(-(-(-(-(-(-(-(-(-(-(-(-(-(-(-(-(-(-(-(-000(-_ -._G/&eG3(-!*N0)//"/*(-(-g-@7(-(-3(-(-g(-\M!-N &T>O8 36v?(-/'c3c3^32^3SSSS''S^3'2(-(-(-^3eZQ  nUNg(-(-(-e( .!-m3=b$;b/%_/////V*3eewg/JF/1~_1  22t2h(-/(-(-_*-v(-(-`/  (x33(-</GO2Hq(-&e_39_T8v <3GL2G~3r.pf-]pp\O3ydr3(-sg-3(-3(-@(- he(-(-(-2{37y3 rJ7kQJ23.U  Aq(.3r0p3f333d/g-2 23(-3x}33(-(-(-~3d xlG 3-3r~3./0p3 C3(-3-'3,x!S.#by222 [~3r^~3933'/3$(-%6;33?(-5C3  33~33Ar3x(-333I3(-3 eP~3S(-_33ab3cg\3333(- z:/0 477  ?c (~0:%G%)("%GK)+;,,,.&&77E&0 :$\&G:7gj12eqc`& /s&+/H$|a@iEAgC  :G3h4v:m' *::Y'a.`h%-x{`&3$:$%7%Eq9Gh'&XYY#`$$#a = %|! 2%"#0U3u5>(%`Xd$Y>7Q%B%$K#$F5u#SY 4XU fK$`XeY$ 8Ycuk SU"5 uyF])S 2Ln:m]]=L"PD<#6@*! jJP\l2gsftVc?&_d'S:Ef|&88%I SWMN1ay_1N;fy6xL8tIJT/m:uw3U}3{6v~5l98nK%8661ha_&6a_fLQ<cd9yh9a7~Z~a65ym58w,817/'6//-i_0_/f (fXg`9l9~a9`/l71/Eh664 E:& )%e*bE.EE //1:E&%hbe7$% yhT`.a`E9E3~1~~~F8g~4\X4~EsEeqe~bmo121v9~lUq]:dQrs:qa;Qq~3QQQkqqQ:T~|:qb:7*1Q9|37Q|yK!jhiQ Rqja||QQA71~T-:"da|~~TLg/~~~:~AB77F~ |bmbb~ ~AbbShb1b1bb#~:bMbbg/$]&Y(<?b1bJZb~2bM0^_0\q@bIbbb$/$5`:bb]k5p0k^qk{a5k09|~kkk[1 o_kp!Vn~.1191~~~k~~k1ekU~1kkwgkAkAg~~~AaHgYgg~VAAAAg:A~ UMgZgA=gy~A!Vn:A5 ggx=Y A~AAgg/<TAAY>A ?@a0p0<~AU $VW~[i$$21%5A%B$F~PK$X~YF(aU$o~&F$NG$ fVn0X0QRx$$(%\<Y$iW<0n )%1~sY ~+``|n=1``><,`$~J^(-^~~TY``^`,GZZ0Wx<Vn919c:::Ddeh5ik~:5~EFG3RS5o..nRX^^H:`pu{^^r~61`M~^:NOP^^H^HHHQY```x ~R(777*RKT5UVY7:jtv)yz|~5:555::7:^5:^WW75:WA('+WLWW)0UJWKOQPV[\^^]^`ceW:WYl}moW7WW777777OQ47:7>@ELOZ7[777in77rtq:vw:::{::}77U:77L7LLLLL%:L:L^Y:9/1:0:9g23 }uLxxE"DYLLLL">iL~7777O77u.U777Y7,P7jnO`AAAA:AAAFFFFFdFA)+46:AAAAF:A`FFFF2^DDDFDDDpDP7PPPP DP2+DDDD:OPDPO9PO7OO^PPOOONdddkOddOdOdzddddd7dddddddYddrz                                                                                      MMMMMMMMM.MMMMM-......................................------------------------^--^^-^^^------^-----^^^^^^]]]]]]]I]]]]]]IIIIIIIIIIINPYYY@YMF@@@@@@@ @@@@@@@@ @   !"#$%&'()*+NG-./01 2  !"#$%&'()*+G-./01 2  !"#$%&'()*+G-./01 2                                                 ?noqrsuRLM???S?????nnNn?no?nonn?6ono???oooq?q?n7oqnqnqrqqronnorqornnrsrrsooq;srqosoqsssuur3qqRsruqruqRuuu5srrRRRsLursrRLssuLMLLussuRML2RuuMSMMRuuSMLR,RLSSSNLS4MN*LML6NNNM06SNMSM6667S667NSSN77761N6776NN;;667;767;3;;773;75333;53;;5553;;53;325233553222,552,54,*,,242*,20444***022,4*,2000,40*,,4*14,*01440**01411*0010111 111f !%&'-./12 f !%&'-./12 f !%&'-./12 Y  !"#$%&'()*+ , -./012  !"#$%&'()*+q-./0125stuV6?@%A{q- .B1}5stuV6?@%A{q-.1}5stuV6?@%A{q-.#1}5stuV6?@%A{q-.1}5stuV6?@%A {-.1}ef !"#%&')*+ -./12f !"#%&')*+ -./12f !"#%&')*+;;;;;-./12;;;;;;;;;;;;;;;;;;;;;;;;;;<<<<<;;;;;<<<<<<<<<<<<<<<<<<<<<<<<<<=====<<<<<==========================>>>>>=====>>>>>>>>>>>>>>>>>>>>>>>>>>  >>>>>f !"#%&'q)*+-./12rstuV[w\q%CxyzD{-|.1}]rstuVEwq%~xyzD{-|.1}rstuVEwq%xyz{-|.1}rstuV.wq%CxyzD{-|.1}rstuVEwq%xyz{-|.1}rstuV.wq!%xyz{-|.1}rstuVvwq%xyz{-|.1}rstuV.wq%xyz{-|.1}5stuV6w=q%y{-.1}5stuV6wq%y{-.1}5stu7V6w7%y77{-.1}7777777+777+77++77777++++++++++q+++++++stuV. w %y{-.1} V] %&+-.1 V] %&+- . 1V]%&+-].1%&+-.1-<34567YxYYY j s) &f{&u^F  !aL,/20tu}Y+PQR#56N;C=?G#?]E?@rgV8@^@?vw6%,h`K 56gVc?Z\%j?Y< >LNWmVYZ\Y& ?6gYmmgYm3"ZWV>VZ-WZh%gYYLZYW7?Z:WVZTJVW0Z? 6%Zgh@@&,(5Y x\KgYmdg)Y!p^\]V3] @YWWWZ3FYJWLx3rstuvYx)[\YLVEZfiV^ZmFWYg LV`aYkY&gfiV V]@/0)')/m(ZBV Bd\gFVL$AFmfj["WiWS/0fWiiW@WffoB(-Y.EW567W@:@BFD(dWgJF$L^JN i\TYVE4_[^ Y@W$h)jUvnUW$xW)Y>Y/0(FCL>gOBFWL/0@fW( Y6[\Y6?BYfiY@/)R??6GB#>i8j F?@?UL-.1jg@[\[i)?@fi@d Sg%g>Y`F^%gfiL_'e)?d(Ng@0#=[\?=Q?f=i A@@@EFU ?@gFCS?@h)U@@rtuv)fo]?`Yh>g?8F>g?LmF?@%\LJ[[\!g[Y[\fRgi?f??ig8mg >?@j?7?J8W ?@g)gjU$Y?@gg)>gYFdm~gL???>6m8F[\g6L8?#?@f??@\[\?Ygfgfj.68Y!&567?@:g gggUm:FRJgL=@ G_h)X[^gjX Zi]@>Cfg+FexOLroz|;=?}[+,-.Xffg@CDC ?@OPO  ratuv^@()@?G123j?@>n@ZF?@L HZgYY[\ZYfmigm+m?123;=?X?g?([H!g#,-.? AZEFZ67g??CD grStuvgYOP@!g.f^=)K@fm8g?.gU>?@W567Y:JF^?YL^YJY?E[(g[ ^fi?Kgg8:;<g?@Kx)WZ$;E_ UU+\Z@FLghY?$YY?)YY[/0mGG==f=i>(BEF.E@?L567:YVWEYZ[EY^YjJfEf~iRjmEE[=^?ZYE8Y:;<?@YrtuvxUReEV8\:;<o?@(EghjV UA\EFY[?YghYYUS Y$??$?fV??LU()W(E%@AC\A>VWvYZXF LACukIY[\LCfQi>m8:;<?@([].567j:UA\EFyJghS6[^fx3 =CLV) e>@oFL Y[\fi3mEce>korVWYZTE(kVWYZ=ACEFk S efo  )E)>@)F.VWLYZ6YF[\FkL Lfim[fif)i F)KL/[> FfiLEtYO[\)TV/0f\8i:;<m?@6>iB=FMtLSU{\Y[\fghf i eo%()/0>BEFLVWYZ[\acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[\^acfim6     $%()*+,-./012346789<=>?@BCDEFHILMNOPQSVWYZ[\^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[\^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[\^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[\^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[\^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[\^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[^_abcdfgim     $%()*+,-./012346789<>?@BCDEFHILMNOPQSVWYZ[^_abcdfgim   $%()*+,-./04<>BCDEFLMNOPSVWYZ[\^abcfim   $%()*+,-./04<>BCDEFLMNOPSVWYZ[\^abcfim   $%()*+,-./0<>BCDEFLNOPVWYZ[^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[\^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[\^acfim   $%()*+,-/0<>BCDEFLNOPVWYZ[\^acfim   $%()*+,-/0<>BCDEFLNOPVWYZ[\^acfim   $%()*+,-/0<>BCDEFLNOPVWYZ[\^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[\^acfim   $%()*+,-./0<>BCDEFLNOPVWYZ[\^acfim   $%()*+,/0<>BCDEFLNOPVWYZ[\acfim   $%()*+,/0<>BCDEFLNOPVWYZ[\acfim   $%()*+,/0<>BCDEFLNOPVWYZ[\acfim   $%()*+,/0<>BCDEFLNOPVWYZ[\acfim   $%()*+,/0<>BCDEFLNOPVWYZ[\acfim   $%()*+,-./0<BEFLNVWYZ[\^acfim   $%()*+/0<>BEFLNVWYZ[\acfim   $%()*/0<>BEFLNVWYZ[\acfim   $%()*/0<>BEFLNVWYZ[\acfim   $%()*/0<>BEFLNVWYZ[\acfim   $%()*/0<>BEFLNVWYZ[\acfim   $%()*/0<>BEFL NVWYZ[\acfim   E%()/0VWYZ>BEFkLNVWYZ[\acfi  m %()/0>BEFLNVWYZ[\acfi m %()/0>BEFLVWYZ[\acfi m %()/0>BEFLVWYZ[\acfi m %()/0>BEFLVWYZ[\acfi m %()/0>BEFL VWYZ[\acf i m%()E/0VW>YZBEFLkVWYZ[\acfi m %()/0>BEFLVWYZ[\acfi m %()/0>BEFL VWYZ[\acf i m%()E/0VW>YZBEFLkVWYZ[\acfi m %()/0>BEFLVWYZ[\acfi m %()/0>BEFLVWYZ[\acf i m %())/0>BEFFLLVWYZ[\[acfif mi %()/0>BEFLVWY[\acfim 8:;<$?@)/0MSU>?B\EFLghVWYZ[\^fgi m8:;<$?@)/0MSU>?B\EFLghVWYZ[\^fgi m8:;<$?@)/0MRSU>B\EFdLghVWYZ[\fi m8:;<$?@)/0MSU>B\EFdLghVWYZ[^fi m8:;<$?@)F/0MSU>YB\EFLghVWYZ[\fi m$)/0>BFLVWYZ[\fi m$)/0>BFLVWYZ[\fi m8:;<$?@)F/0MSU>B\FLghVWYZ[\fi m$)/0>B FLVWYZ[\)fi m>F$L)/0Y[\>fBi FmLVWYZ[\)fi m>FL)Y[\>fiFmLY[\fim    !"')12356789>?@ACDFHIJLOPQ[\_defgl    !"')12356789>?@ACDFHIJLOPQ\_defgl    !"')12356789>?@ACDFHIJLOPQ\_defgl   )12345689>?@CEFHLMOSVWYZ[\_bdfghk  ))>@FKL?EF[\LfiY[\^ fgi) ?EF)LY[\>^EFfgiL[\ ^fi) > F)L[\>)FfiL >[\FLfi )Y[\fi>) FL>[\F )Lfi[\> )FfiL>[\)F fLi >[\F)fLi) [\>FfiLF )L[\[fi )FfiL[)F fLi[ F)fLi[() FfiL>[F()Lfi[\> FfL[\ )f > )FL)>[\)FfL>>F [\LFLf[\[\)f f> F )L [\>))FfL>)>[\FFLfL> [\F[\Lff[\)f>FL   [\f !"$'*+,-.12356789<>?@ACDFHIJNOPQY^_degl    !"$'*+,-.12356789<>?@ACDFHIJNOPQY^_degl    !"$'*+,-.12356789<>?@ACDHIJNOPQ^_degl  1234689?@CEHMOSVWYZ\_bdghk8$:;<?@/0MS?UBE\   ghUVZ\^ !"gi')12356789>?@ACDFHIJLOPQ[   _defgl !"')12356789>?@ACDFHIJLOPQ  _defgl$*+,-.1235689<?@CDFHNOPQY \ ^_dfgh$*+,-.1235689<?@CDFHNOPQY \ ^_dgh$*+,-.1235689<?@CDFHNOPQY \ ^_dfgh$*+,-.1235689<?@CDFHNOPQY \ ^_dfgh$*+,-.1235689<?@CDFHNOPQY  \^_dgh !"'12356789>?@ACDHIJOPQ  _degl !"'12356789>?@ACDHIJOPQW   _degl !"'12356789>?@ACDHIJOPQ  _degl !"'12356789>?@ACDHIJOPQY  _degl !"'12356789>?@ACDHIJOPQY  _degl !"'12356789>?@ACDHIJOPQY  _degl !"'12356789>?@ACDHIJOPQY  _degl !"'12356789>?@ACDHIJ OPQ_degl1234689?@CE HMOS\_bdghk1234689?@C HMOS\_bdgh1234689?@C HMOS\_bdgh1234689?@C HMOS\_bdgh1234689?@C HMOS\_bdgh1234689?@C EHMOS\_bdgh1234689?@C HMOS\_bdgh1234689?@C HMOS\_bdgh1235689?@C  HOW\_dgh1235689?@C HO\_dgh1235689?@C HO\_dgh1235689?@C HO\_dgh1235689?@C HO\_dgh123689?@C  HO\_dgh12346789?@  HIMQS\_bdg12346789?@  HIMQS_bd  g1236789?@HIQ1236789_?@dgHI Q_dg$*+,-. <CD$NOP*+,-.Y^< CDNOPZ$^*+,-.< CDNOPQY$^*+,-. <CD$NOP*+,-.^ <CDNOP$V*+,-.^ <CDNOP$V*+,-.^ <CDNOPQ$*+,-.^ <CD$NOP*+,-.^ <CDNOP$*+,-.^ <CD$NOP*+,-.V^< CDNOPY$^$*+,-.*+,-.<<CDCDNOPOP8:;<^?@^JMSU8:;<\?@ghMSU8:;<\?@fghMSU8:;<\?@ghMSU8:;<\?@ghMSU8:;<\?@ghMSU\gh AMPERAMPERAMPERSANDANDASASSERTBACKQUOTEBANGBARBARBARBARRBRACKETBEGINCLASSCOLONCOLONCOLONCOLONEQUALCOLONGREATERCOMMACONSTRAINTDODONEDOTDOTDOTDOWNTOELSEENDEOFEQUALEXCEPTIONEXTERNALFALSEFORFUNFUNCTIONFUNCTORGREATERGREATERRBRACEGREATERRBRACKETIFININCLUDEINHERITINITIALIZERLAZYLBRACELBRACELESSLBRACKETLBRACKETBARLBRACKETLESSLBRACKETGREATERLESSLESSMINUSLETLPARENMATCHMETHODMINUSMINUSDOTMINUSGREATERMODULEMUTABLENEWOBJECTOFOPENORPLUSPLUSDOTPRIVATEQUESTIONQUESTIONQUESTIONQUOTERBRACERBRACKETRECRPARENSEMISEMISEMISHARPSIGSTARSTRUCTTHENTILDETOTRUETRYTYPEUNDERSCOREVALVIRTUALWHENWHILEWITH CHARFLOATINFIXOP0INFIXOP1INFIXOP2INFIXOP3INFIXOP4INTINT32INT64LABELLIDENTNATIVEINTOPTLABELPREFIXOPSTRINGUIDENTCOMMENT@#int%int32%int64)nativeint"!=1parsing/lexer.mllP1parsing/lexer.mllR1parsing/lexer.mllP=String literal not terminated6Illegal character (%s) 4Illegal backslash escape in string or character (%s)6Comment not terminated 4This comment contains an unterminated string literal 2`%s' is a keyword, it cannot be used as label name FInteger literal exceeds the range of representable integers of type %s!-!-!-!-+Lexer.Error#andB"asC&assertD%beginJ%classK*constraintQ"doR$doneS&downtoV$elseW#endX)exception[(external\%false]#for^#fun_(function`'functora"ife"inf'includeg'inherith+initializeri$lazyj#lets%matchu&methodv&modulez'mutable{#new|&object}"of~$open"or@'privateC#recI#sigN&structP$thenQ"toS$trueT#tryU$typeV#valX'virtualY$whenZ%while[$with\#mod#mod$land$land#lor#lor$lxor$lxor#lsl#lsl#lsr#lsr#asr#asr@, H&Il CEHUB{e]/xi_-]p7gzbraNsuvu, - A d g> M K m   . HIFE?=964/.,*&$A! D HGB#-7C>@  H;@SSTSVoz *$&&$%RXqRXQW$ ! f # "dac`]P_^K$?9$9778888888888>DPGJL$66666666xwOOOOOOOOOO8888888888e~ = |R>Q~VUR=Q<UTZZZZZZZmZZZZZZZ:kkkkkkkkkkZklkkkZZkkkjigbhZZZZ|ZZ{Z[ZZZZ\ZZ}YZNM77yZZ1.0.71/-200/.-3420/-3411111111115555555555q0p555555EEEEEEEEEEt1svu0555555  5555555555555555.FFFFFFFFFF5555555r/- '''''''''''''+'8888888888'***************************8''''''''P'''''''''POOOOOOOOOO'(((((((((((((((((((((((((((''********************************HHHHHHHHHHHHHHHHHHHHHH(((((((((((((((((((((((( (((((((( 66666666IIIIIIIIII.IIIIII6/-IIIIII '''''''''''''''((((((((((()'(((((((((((((((((((((((((('('((((((((((((((((((((((((((URQUTOOOOOOOOOO((((((((((((((((((((((((((((((((((((((((((((((((((((((*((((((((**********,*******************************************************************************************************************'''''''''CCC''''''BBBBBBBBBBMMMMMMMMM'MMMMMMCC''CCCMAMMZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkZZZZZZZZZkkZkZZZZZkkZZZ *%QWpSVSV  $;0$0220000000000=CFIK$33333333uvz9999999999 |<SV{T<T{TUUUUU    T U sss77s7777s11111111114444444444n1n444444BBBBBBBBBBn1nnn1444444  55555555555555555EEEEEEEEEE5555555n55 !!!!!!!!!!!!!!!8888888888!!!!!!!!!!!!!!!!!!!!!!!!!!!!8!"!"""""P"""""""""PPPPPPPPPPP""""""""""""""""""""""""""""""!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!AAAAAAAAAAAAAAAAAAAAAA""""""""""""""""""""""""#""""""""###############################################################66666666HHHHHHHHHH6HHHHHH666HHHHHH##############################################################'''''''''''''''(((((((((((('(((((((((((((((((((((((((('('((((((((((((((((((((((((((OOOOOOOOOOOOOOO((((((((((((((((((((((((((((((((((((((((((((((((((((((*((((((((****************************************************************O**************************************************************+++++++++:::++++++::::::::::MMMMMMMMM+MMMMMM::++:::M:YYYYYYYYYMYMYYYYYZZZZZZZZZZYZZZZZ[[[[[[[[[YYZ[[[[[[\\\\\\\\\ZZ:\[\\\\\bbbbbbbbb[[b\bbbbbhhhhhhhhh\\hbhhhhhkkkkkkkkkbbkhkkkkklllllllllhhlklllllmmmmmmmmmyykkymlmmmmmyyyyyyyyyyllmyymmyyyy H $  H '' H J$$$ JTTTUOPOOOOOOOOOOPPPPPPPPPPPT *@,//toplevel//,//toplevel//,//toplevel//@@$%s@.6ocamldep, version %s@."ml#mli&%s.%s ' @[%s: $@]@.#%s #%s @@[Warning: cycle in dependencies. End of list is not sorted.@]@.# %!@@$.cmi$.cmo".o$.cmx$.cmx$.cmi*@[%a%a@]@.(@[%a@]@.4@[I/O error:@ %s@]@. $@[Preprocessing error on file %s@]@. 1OCaml and preprocessor have incompatible versions +ocamldep_pp*%s %s > %s! ! $.cmi$.cmx$.cmx$.cmi$.cmi$.cmx$.cmo$.cmi$.cmx$.cmi$.cmx!.6@[Bad suffix: '%s'@]@.7@[Bad -I option: %s@]@.$Unix#.ml@$.mli@!:' \ Options are:> Print version number and exit%-vnum7 Print version and exit(-version + Sort files according to their dependencies%-sort C (Windows) Use forward slash / instead of backslash \ in file paths&-slash . Pipe sources through preprocessor #-pp 3 Output one line per file, regardless of the length)-one-line ; Generate dependencies for native-code only (no .cmo files)'-native > Print module dependencies in raw form (not suitable for make)(-modules 4 Consider as a synonym of the .mli extension,-mli-synonym 3 Consider as a synonym of the .ml extension+-ml-synonym? Process as a .mli file%-intf> Process as a .ml file%-impl 3 Add to the list of include directories"-I # Generate dependencies on all files$-all@@WjE@@#ArgA@A@%ArrayAk@B@&BufferA@@0CamlinternalLazyA@AC@$CharAB@@'ClflagsAj@A@&ConfigAe@@&DependA@AB@&DigestA@@(FilenameA@@&FormatA@ABC@'HashtblA@@%Int32A`@A@%Int64Ak@@%LexerA@A@&LexingA{@BCDE@$ListAz@@(LocationA@@)LongidentA@AB@'MarshalAT@@$MiscA!@AC@)NativeintAv@@#ObjAU@A@(OcamldepAC@@%ParseA@AB@&ParserA@@'ParsingA@ACD@*PervasivesAe@@&PrintfA@@&RandomA@AB@#SetA@@(Std_exitAD@A@&StringAL@@)SyntaxerrA@AB@#SysAO@@(TerminfoAk@A@(WarningsA@P-Match_failureCG@ABCDEQ-Out_of_memoryC@@R0Invalid_argumentCC@AS'FailureCB@T)Not_foundCF@AU)Sys_errorCA@BCV+End_of_fileCD@W0Division_by_zeroCE@AX.Stack_overflowCH@Y.Sys_blocked_ioCI@AZ.Assert_failureCJ@[:Undefined_recursive_moduleCK@ABCDFG=r%Int320&Y(y cHϚΠ%Int320&Y(y cHϚΠ&Config0"j{YS$ܮ(Location0 Ik˘/ $Char0&)9_=J(Bm&Printf0L,B=a.4(Ocamldep0- 764P7(Filename0LTjC>#Arg0 7}-}\+%Array0M^ {OԲwp&Depend07?[#K F#Sys0Eu%B&̄y&#Obj0{B+,;)Nativeint0G$)@p hc$'Hashtbl0q΋q"H>6/x%Lexer0(O\Xt<#Set0**V $.QCˠ&Format0nk{uDLsc'Parsing0 RY&Digest0rUATy[;l$Misc0TU2*OTɏ(Terminfo0y5 &ﺠ(Asttypes0W_Nw;'#&(Warnings0"քO]-(Jg\x,ꠠ(Std_exit0Uol'HWà)Syntaxerr0v9Rw~ N֠0CamlinternalLazy0~OaKtGB&String0T&GSq첋&Random0o7pr)Longident0BLl=1}A}f%Parse0Οj~[h@n'Marshal0}55UanRߜ&Buffer0?lG!Wiv 6]6]6 ]6!]6"]6#] +^+H +9+ + :+ + ,c]i]j] + + + + +Z+4 +& + + + + +%+ ,(+ +t ++ +++++++v"+f +V+A+2 !+" + + :,+ +? + + + 6$^.  + + + +} +t +h> +X +L +C +: +. +$ + +),* +213 +79 + + +> + +BD +G +LKM02468:<>@BDFHJL_acegkmoqsuwy{}>QB9%T)*V D 2&(]()*|V  $eq o  n n2  n2  n n$ )*c }UH\ n^ n? T\C^ C_ C~V  C^"c C_ zUc()* "._ {V ^2$ o$ _ {V ^ 2$ o$ )* nn  , ^^$)* + + ,O |V hh$ e q oh^ ^  h   h c h $)* " ^"^ _ 2' _()*Y #Z( CyV D _([)* " ^ _ 2&)*f q zVcT5&6 @[ ^"^ _ 2&h_( _()*Y"Z( CyVD ([)* nn ? {V0^ ^"h}V I^ C^"h}V IC( {V^ ^"( {V(@[)* + ,,, +\,Ok qh {U\ ^  # zUcj {U%\ ^h ^  _h"" zUci{Vd ^h ^i _h _( )*? Oh {U\C ^ " I zUcC()*?hO }U\^ C" I zUcC()*VD C _  2&(VD C h"^ ,i &:()*( ^ @ 2&,c O &)*O :(c ^ h " ^i  }U\^ " _  zUc()*c O }U\^ " zUc()*O :(c ^ ! ^i  }U\^ ! _  zUc()*c O }U\^ ! zUc()* Oo }U   Oo}V5'8%%a()*   Oo }V5(8%% n }U\ _  zUc()*  Oo }V5)8%% _()*O %Oh _( ^(O :(h _()*: ^h  }U\^ Q zUc()*:(c ! ^i  }U\! _  zUc(+ + + +j +I + + + +x +R + + ,+ +~ +N6*? +l  +.   +!$&(>9+TO)*V D 2&()*V D C @ 2&(VD C 2! 8%&c()*VD C ! 2" @(c()*VD C " 2# @(c()*V D C ! 2&c()*VD C "2'c()*VD C "2'()*VD C 2# &()* VVD C DC "  2# @( Uc(5,8%%)* VVD C DC " 2' Uc(5-8%%)* VVD C DC    # 2$U(5.8%%)* VV!D C DC    2   ' U(5/8%%)*VD C !V 2&(d()*VD C !U 2&(c()* VVD C DC "V 2' ( Ud(508%%)* VVD C DC "U 2' ( Uc(518%%)*VD C ^hyU 2&(c()*VD C yU 2&(c()*VD C D C ^(2&5?[)*VD C D C yV(2&5?[)*VD C C ^hyU2&(c()*VD C C yU2&(c()*VD C C ^(2" @(c()*VD C C yV(2" @(c()*VD C !V( 2&5?[VD C D C 2! D C @ @@(52()* VVD C DC 2" @@(Uc(538%%)* V0V)D C DC "  2# @( 2# @(  ( ()*(V D 2&546 @[)* V/V&D C DC "  @ 2'  @2'  & &)* V/V&D C DC "  @ 2'  @2'  & &)* VD VD VwC CC "5 " c @ @ @(  " c @ @ @( c @ @ @(  " c @ @ @(  " c @ @ @( c @ @ @( T-T)V&D VC C " c @ @(c @ @( i x o " 3" 3"h ')* VD V{D VrC CC "3 " c @ @ @(  " c @ @ @( c @ @ @(  " c @ @ @(  " c @ @ @( c @ @ @( T,T(V%D VC C " c @ @(c @ @( i x o " 1" 1"h ')*,, ,<! ( & )*VD C !V  @2' @2'! !@()*,hh ')*VD C !V  @2& 2&%,c %)* VVD C DC "@2' U(558%%)*, h ')* h')*VD C !@2&()*,h &)* h'c &)*VD C ( 2&568%%)*578%%, &VD (588%%VC (598%%h&,+ + + +8% ,+ , ,,+h +W ,,+* , ,,-+ ,U,},,,,,,,X,p,,,,,,,*+ +Z ,5,T,|,&,+    !#%')+-/24379>@C>AHHLNMQSUW>+/9:T)* o(az ((AZ  (('.\&*W&&&&&&&&&&5;(5<(5=(5>(5?(5@(]V d] h S(l]l\h Sgd ql0ni Sg l qrl0nj Sg rl0nk S(5A8%%(+ +v +R +. +# >9BT)* ~V5?[ RyV(  2$)*5?[ RyV(  2')* ^()*] ~V5C8%%Y #cdZ(6 CyVc([)*h ')*]  }V5D8%%Y      cdZ(6 CyVc([)*] ~V5E8%% ')* ] ')*]  }V5F8%% $)*h ] $8B&8B&)*](!h R !h S(8B&8B&)*] (]h  }U\R! S zUc(c?h ] }U?\R  "!\T  T ]VdTgTe Cn I zUc] CyV(C]h Ic ] }U\R  :  8g\CSCSTToTgTc" W#4ETKg\CSgbCST4g\CSgtCST#g\CSgnCSTg\CSgrCSTTF ]VCST7l\CSgd ql0nCSg l qrl0nCSg rl0nCS zUc(]h? T\ C{V C R!Uc? T\C C~V CR!UcC  CyV(C C~VC Co C'5G(  TTTc(d(]Cha]CnI]Cha]CnI(]CnI()*V?D Ch?h? +8: "C]p Cn] ]h ha]?  +8: "(5H()*c ] }U\R " zUc()*c ] }U\R ! zUc()* ]o }U  ]o}V5I8%%a()*  ]o }V5J8%% `()*  ]o }V5K8%%] h a(] ] h ha()*] h `(+ + + + +T +/ + + +b + + +j +^ +S +5 +) + ,+ + ,'+ ++x +k+: +-      #%$(*,.0>9LT!?[V +?&c&)* ^c(c] D Ch] E D C iv lqph? +lllllllllllllllllllll6M? +6N    "$&(*,.0449997?A>!#9OT)* _(]U()*  ]o }V5P8%% ^W n ]o }V5Q8%% ^V()* "n()*  ]o }V5R8%% ^W()*  ]o }V5S8%%a(+l + + +q  +c +T>9TT/)* 8T" n 8T"@(c ^()* _()* ^(+ + + +lllllllllll lll   "$>9UT5)* ^k(6V^l(5W ^c(5X ^V(][(5Y ^](5Z ^\(5[6\6] + + +6^6_ + + +   >  9`T5)* ^(6a^(5b ^x(5c ^V(]p(5d ^r(5e ^q(5f6g6h + + +6i6j + + +   >  9kT5)* ^(6l^(5m ^(5n ^V(](5o ^(5p ^(5q6r6s + + +8O 6t^6u ^ + + +   >  9vTcc Mc LG h E D C> M c K(G F F D C> M (G (G (G F(G F()* Gn D^()*  D^?(c()* D^()* o ] h Da?(c()* o ] h Da(G Go ] h GDa(d M( :ihhhhh ]6w 8%" +> ()*h 8%>$+% :hhhhhhhl]l] "> ()*] " TdMcD] En}VD] GEon|VGEoh D G D8L TB7OD]jp8%" GEon}V5x8%!]  G Eoh G D8L JG FnLGoMcMGoMEoKG h O }U\ ^ h|V o _ zUcE Dh 8L EnK()* _ h|VG M G GFn E D C>M ()* _ h|VG M G GFn E D C>M (5y + + +6z + +w +G +& + + + + + + + + + +t +R     $>9{T](c(C%!F(!F(c!F(c!F(G oG oF^(G oG oE^(G F^( G F^(G oE^ G oF^ ^V(2%,G %)* G o D^()* ` W"*2_!G MG M i2&?[c!cj2&c!ck2&YG C^!l@ZT CyVcl@T[ D C 2&5|G !cl2&]V  ]E^y( D^y()* ,bG G GGGGGG M M G M Y ch "Z( GM M MMMMM CyVD ( +vI[c( cGhD8+ cM(Gj ph ^h ^8{ ^8{^ hhC8+ I hhD8+ J hhE8+ K hhF8+ LM(5}?6~?hhhhhh8{8{hhhld8{ld^8{ld^hld^hld^> +c +K +D?  + +++++ + + + + +w +p   +_>9T9! G G# G GG"G GGG G G G G GGGGGGGFGGG>()*V)E D C C" (  2"' 2" ' dh h>()*VE D C 2"'%)*VE D C 2" '%)* VKVBF E D CFEDC}V   2# '}V 2#'   '&&VC V2%D (5?[VE D V2%(5?[VC V E D 2!'E (58%%)*VGE D C C" i A(2" E D C# A( 2" E D C   #A( 5()*VE D C C" hyU T2&(c()*V+E D C C"  &  2"' 2" ' c()* V_VXF E D CFEDC~V  & " E C 2" 2"' & " E C 2"  2"' ( ()* V8V2 E DC " D C  E 2" 2"'E 2" 2"&c(c()* V8V1 E DC " D C  E 2" 2"&E 2" 2"' (c()*VE D C A 2&()* V*V$E D CEDC C" ( ""2& d(Vg(c()* VTVN E D CEDC C"  2"V2&( hh>2"V2&( hh>2"V 2&( c(d()*VE D C 2"!2&c()*VE D C 2# " 2' ()*VE D C !V 2"V2&(d()*VE D C !U 2"U2&(c()*V E D C 2" !2" V' & c()*V:E D C 2" D C!2" D C V"  #@(  # "@( 5(VE C 2! 2!n(c()*VE D C 2" @2&(h&)* "hy()*c "h "&Vc(d()* VV !!' ( ()* VV !!' ( (dh h>()*VF Tc VF Tc  }VDV:E DC ! !~V # ' VE DC  # #'58%% 58%% }VFV<EDC ! !~V    #' VE D C#   #'58%% 58%% ~VT>()*VF Tc VF Tc ~VT>(VF (c(+ + + ,!+ ,O,b ,r,,,  + +~,c +h,9,W , ,,,Z,k +" +,,,, ,=,V,v,,+    "$&(*,.02468:<>@BDF>$(%+ +?9TJ! G G G GG#G G G"G  G G G G GGGGGG EGGGG>()*VAG FEDC C"   >(   2#$ 2#$ dh h>()*V!F E DC C" (T2& 5?[)*VF D C C" hyU T2&(c(VC V2%E D @(5?[VF E D V2% @(5?[VC VF E D 2!$ F (58%%)*V2F E DC C"  &  2"$ 2"$ c()*VF E DC 2" "2&c()*V"G F EDC 2" !2" >( c()*V$G F EDC 2" "2" >( c()*VF E DC 2# #2' ()*VF E DC "V 2"V2&(d()*VF E DC "U 2"U2&(c()*VF EDC   2#$  &)*VF EDC 2# $  &)* VlVbG F E DCGFE D C }V  2  $ }V   2 $$' ' )*VZF E DC C" ? A(2" E D C       A( 2" E D C      A( 5()* V@G F EDC !~V) " E D C  2# ?# 2#$TUc(V-F E D C " E D C  2#? #2#$56 @[)*V%F E DC 2" "2" V $ & c()*VKF E DC 2" D C " 2" D C V"    @(       "@( 5()*VF E D C> 2&(VF C 2! 2!n(c()*VF E DC 2"@@2&(h&)* V4V.F E D CFEDC C"hyV "V ""2&( c(Vc(d()*,c"h" &)* V<V6F E D CFEDC C" (  " (  ""2&d(Vg(c()*,c"h" &)*V C $  &)* VV! D C! $  ( ()* VV! D C! $  ( (Vc(d()*V G TcV G Tc  }VcVYF EDC ! !~V       $V*FEDC          $58%% 58%% }VdVZFEDC !!~V   $V*F E D C          $58%% 58%% ~VT>()*dh h>()*!! ~VT>(VG (c(+ + + +h + ,,M,r,,,  +^  ,, ,&,L,t,,,, , + + ,^ ,,6,],+  +: ,,+    "$&(*,.02468:<>@BDF>$(%+ +?9TV)*C 8: &C8:%Chy(C VC (?[C V D C I(?[)*C @ I(C?(c I(c?(5? + + + +++ + + +     >  9T ]8U yVc ^ (7U zV(% ]8U yVc ^ (7U zV(%c ^ h _ c ! h_ 7U ^([c ^ h _ Yc! h_ 7U^Z( +h_ [?[5? + + + + +a  >9T)* {Vh^ $2 \g\""l 2&\ " 2& 2&\"l 2& # D C !"l 2& l\yV&()*] ,scl &)* ~V5?[ ^ ({ "  o8L#@(  h!   o 8L#@()* ~V(^ _: TeTd0`T[{SS@ W@@@@DDDD@@@@@DD@@DDDD@DDDD@D@@DDD@@@DDDD@@@@@DD@@DDDD@DDDD@D@@DDDT T`( 2&)*,j] &)* ~V5?[ ^yV   2' ^yV(  2'  2')* ,] ' ({56 @[g}(g)()*Dh C 8%/$)*h}U7O }V58%!E Dn}V " DC8%?  Dn J()*Dh C $)*] Dn E }V "DCh 8L  J()*h}U h}U ]o }V58%! Dn E }V "DC  8L  J()*D E ~Vd " C_ J()*E ? T\Cjp ICDn}Uc7O C}V7ODn|V7O IT58%!C] Dhh C8L ICK(c JF IC] K(c J(D()*D ~V58%% C^()* Do }U  ]o}V58%%C8L$ )*   Do }V58%%] hC8L (Dh C8L'dT8O }V7OT ] h >(+ + + +e +F += +4 +! + + +c +7 +&+ + + + +T +n  +O   !>9T ( +&c(! +8 8i$)*! %8! 8!(]jp 8%c( +&(c()* +8 8+h$8%&8%&c( +&c(+(+%()*8%+8%.8%-+h$)* ~V%R %" 2&0 4443 $ )*" 1&)* V h " "T " 4&)*V c !  "T ! 4&)*  ! 4&&)* !D" 4+ $)*] 2, ;sc & )* ! ,cC! " & )* $)* 3+  ')* "  @"$)*R  T;W"T"T2 +  ' 3$ 2$ )* R |W||q%q% &6'6' "8%!T       "  "'  '  "  "E! h"  "$  '  "  "'  '  i8L"' " sT5 8L !8%"68%"yVT      "  "' " c i8L"T5 8B!8%"68%"  "' "      ^Z  "'  "     ^  "'  " 8%! "'  R  T+W!!%%%%%%%%%%%!%%%%!%%%%%!%%%%%!%%!T,"    ln ^Z  "'   TCW!"     ^lTT"     ^TT"     ^   "' "  # { ! "'  "' )* "^()* +           , Jh')* ^ ]H (% ~V 58%&^   TT 7TT2%(] ,c %)*VC (()*V(E%)*R 0:*  l pn2&$58%% F!?&h&)* R  h&,  &)*cl^ h _i _j _k _l _l _& )*cl^ h _i _j _k _l _&)*cl^ h _i _j _k _&)*ck^ h _i _j _&)*cj^ h _i _&ci^ h _& @&)* o_()* ~Vc^ +"& 2+()*!  ,ch &W !(/: & +( +q( +O( +'( +( +()*VD C V "2& &c()*,h &! C()*()*l)zVl}zV "()*aeTd lryVEKV DnJ(CnI(chhA + + + #()*V 58 "Tg%8" &)*8"(] 8! + + #8%)* }V%R : _Ci2& 8 W"-----------TTgi # 2&T  3& 2& 2& {V ^ "2%()* }V%R ~W~~EE #3% #  # ,5 !2& '(gs 'gc 'gi 'gf 'gB ' '  }V gi'^  T+W!!%%%%%%%%%%%!%%%%!%%%%%!%%%%%!%%!T gi' gi #& ' {V^% h4"2%2%()*] ,gc !c(' ~V%^ %2%3% ~V%^   TW TTT TT1% " 1% yV(')*(g)Tg} 2,e %)*] , & )*  F(gg ] _()*  Nn(gu ] _()* |V<R * 8"2&VD C 8%!8 "! 2& 56 @[(R 0 :2%$((R  (, %)*+  ! o 8!l% 8" ,c8:! "8% )*! D C]hl $ )* yV( |V 8L' 8L" V h  8L T  o  8L ()*] ~Vh@(R 1:  ]o8L#]Y@(-i2& 2&,Ydh"Z(6 CyVgsh'[5 G!8%"68%"8%%)* G!')*5 8%"68%" 8%!8%"68%" i8L"8%"68%"8%%]h ')* 8L'%)* n%(8%!68%"8%%+ +i ! + + +  > +n +\ +A + + +t +> + +w +`  +   + +b : + + + +?+(+ + + +a  !+  +& +:+, + + ++ + + + +  + +t % > @ D C G G E C>@   > '9TL)*VD C D C ^V( 2& 5?[ ~V(^ 2%(] ,Y g 8L "!Z(6 CyV([! h8:# !8: &)*D C E6 ^VkW E  E !l ] oo8L" h8L# ]o 8L# 8%" 8%"A( E !l o8L" 8%"68%"A(()*E D C W  ! ]n8%&]8%&)*Y   8Oh Z( CyVD 68"e8%L% CyVD 68"c8%L%[W cjqI9Ch %CC{VBC^ Y 8%!!ZT(6 CyVD6 ^VT5 A@[T[(TCi I(Ch I(CC{VC^ !(TCC{VC^ I(TCC{V@C^ Y ]Y!ZT(6 CyVD6 ^VT5 A@[T[(T^CC{V@C^ Y ]YIZT(6 CyVD6 ^VT5 A@[T[(TCC{V@C^ Y ]!ZT(6 CyVD6 ^VT5 A@[T[(TCC{V@C^ Y ]IZT(6 CyVD6 ^VT5 A@[T[(TtC 28: &D CC{V;C^ 8:"VC^ !( 666 68%" A@[T C T\C^ !C{Uc(?@[ {V  ^T5 W+FZC6 ^V5 ^V 68 TcTcTDE D C  68 T)C  68 TC  68 T#5 ^U5 ^V 8!@[8!@[)*VC T Ol8! C    + ,T\C^ ]ic ^-bY  "ZT6 CyV? !T[ Y  , !ZT% CyV D ?!T CyV D !T[T"Y!ZT CyV D ?!T[C{Udc( )* "68&)*g8! #8%)*6 8#! !8: &Y 6"ccZT6 CyVc6?6A@T[ Y 6"ccZT6 CyVc6?6A@T[ 8%" 8%&5@[)*E D C ]h{V7W   68$ C  666  68$ ()*8%" 8%&)*VDC 8%"+8:#8%&5(5?6?6? ,+ +p +e + + + +h?    +  + ,+S +  +     >9T#^!l ^!vn(Aa g&ga o (GgA o ( Tg0 o(56@[]l zV56@[+ +l]hl }U\jp!8B! _ zUc(g ]hl }U%\ejph ^68"8L  zUc(g]  gh8%? ()*gh 8%/$8%:!l ^ 8%F!()*  ]o }V58%% _(]h _(7L + + + + + +Q +   >9TD&G%c]%?E&E&G%G&G &G &G &G&G%)*! r l?o o}V 2&()*!]gli !s]g^d ^b ^`68`^]^\ ^]^V2&()*!]|l !]|^yl<l!s]|^y ^w ^w ^u68k^r^q ^r^V2& (d !shy()* !^&(5 !]! !]! ^'^$^'()*] "]()*] "]()*5 ^V58%% &)*5 ^V58%% &)*?58%% &g7 Dr JD C^ll ws ul7 Dr C^nl? s DC_(c! "(c]%c! "(gk ^vlj ^vli^vh^nnn()*8%! 8%"8%)*+ + Oc?T Ohl6 }U\ C_ zUc5?h l78%"l6n }U5\g7 r r ^C "Ig?C !  C^us  C_ zUccJ()*g7hChC8+ D J(chl7^@(+ + +P + + + + ,+ ,+,+d8v +MT+:+ + +    >h6]@ +7 ++ + ++++ + + +  +  + GGG G G GGGGF>    > 9T)* ~V(7Oj p}V(j p2&)*VE D C ^(2&5?[)*V E 2&()* `S(6&)*D%C + @! C D E FGGGGG G  G  G  G  G  +     >()*VE D C C"V(2&5?[VE C C"U2%(c()*, " D^ %VE D C C"VA(2! A(5?[)* , " D^ Y ! D_Z(6 CyV"A D_CIdDOvC}V& ([VE D C C"V 2! @(2%c()*, " D^ %)* " D^ VIE D C C"V(V1E DC  C"V( VE DC  C"V(  &5?[5?[5?[V E D C C"V CI(2! A(c()* , " D^ ! D_()* " D^A D_C Id DOv C}V&()*DO ED"s(+ + +,  + + +{ +<   >(h" ^ _()*h" 8%&Dh+8+#h ^ D +8+ " DOC>()*VE D C # 2&()*,D?h O }U\C ^" I zUcC(VE D C "2%c()*,Dh O }U\ ^! zUc(VE C ^hyU2%(c()*, " D^ %VE D C ^A(2! A(5?[)* , " D^ Y ! D_Z(6 CyV"A D_CIdDOvC}V& ([VE D C ^ 2! @(2%c()*, " D^ %)* " D^ VIE D C ^(V1E DC  ^( VE DC  ^(  &5?[5?[5?[V E D C ^ CI(2! A(c()* , " D^ ! D_()* " D^A D_C Id DOv C}V&()*ODO Eldl `Ss(DO ldl _Tr(VE D C 2!" ^ A _(c()*D Oj p8O {V,c ^ J,c }U\^ ! zUc(C( F E D8+! C>(DO OF yV%c Ic F^ J(c IDOh  }U\c D_ zUc()*VC TC l" V" ] CT 8!T8 F!Tc h^h>(c8 D%dI()* ldl `S()*h `S(hldl `S(+ + + Y5]ZT&6 CyVY5]ZT6 CyV5T[T[lR 8L" ? + +? , +4 + + + + + +@ + + ,+e+N++ +_ + , + + B + + !#%'>9T# Yll@k@i@8%*#@Z(6 CyV [2%[)*VC T5 VC TC ,c %# Yg6_]Z(6 CyV [2%[)*VC TC ,c %C(I()*g ] CT 8!T8 F!s  68  &c8 D%"V58%%^. h8L'2%,] %)*] ]o 58%%h 8L')*]  "V 8%&8%" 8%&! D '! D C # 8%&!V]j 8L#jh 8L#@(6@([ T TAc(d(+ ]j|Vc ^ !Vd ^l:y( yV g"8&^ "\8"2%h3&h3&)* yV g"8"3%^ "\3!1% 2&jp3!g"8"1%d }U\g\8" zUc(] 8!l" 8" ,Uc !8%)*] ]~V] ] ]o 8L# 8L! 8L!^(!VO]j}U 5jh 8L#^V;]j}U 5jh 8L#^V']k}U 5kh 8L#^V]k}U 5kh 8L#^(]i}Uc ^l/zV]i}Uc ^l\zV]j}Ud ^l:z()* ^ l/yU l\yUl:y()*] ]~V ] ] ]o 8L#^(!V']j}U 5jh 8L#^V]k}U 5kh 8L#^(]i}Uc ^l/z()* ^l/y( dh8L'"V2%3%("V3%2% dh8L'"V2%h8L')* ,5^V(] % dh8L'"V2% 3&)* h8L'"V o 8L' 2&)* ,5^V(] %)*] 8!l' 8"c  }U$\^'  8 "T ^ 8" zUcg' 8"8%+ + +"666 + + +m +J Y5]ZT6 CyV5T[6 ! "  "   >  666 + + +X +* Y5 ]ZT6 CyV5 T[ + +6 +  +   +   >  6 6 6  FGGGG G" "   >  8O6 ^Ve5 ^V65 ^V56 @[G G GGGGG F E D C> TMG G GGGG G F E D C> T%G G GGGGGF E D C>  G G G GGGGFE D C + +j+W +&? + ? + + + +^>9T)*VKVED C D CDC D C }V 2&  {V  2" @(  {V  @@2&  2& (()*VVVSD C D CDC D C ^V 2& ^V 2&  ^V 2"  8%"@@(  2" 8%"@@()*V^VYD C D CDC D C {V 2" @@( {V 2& {V  @@T {V 2" @@(  2& ((C D }U\ _ zUc(D C +8: &VCDl^ D +8: "(56 @[&)* ^V c @@(c @@(c @@(Vc(d(5?h + + + ,\,,g!lh"lh" + +|       >  9:9TW "*(D2! C2!@(D2! C2!@(C2!?(C2%)* i8 $58%%g 8 "l 8 "k 8 "j8 "i8 " 8:!@A(c 8 "(5(g 8 "j 8 "h 8 " 8'c(e 8 "h 8 " @(c(g 8 "k 8 "h 8 " h>(g 8 "k 8 "h 8 " i>(d 8 "h 8 " @(c(d 8 "h 8 " 8:! @(d 8 "h 8 " 8:! @(e 8 "h 8 " @(c(d 8 "h 8 " @(7?(d(c 8 " 8!?(c 8 " %d 8 " ?(d 8 " ?(d 8 " h@(d 8 " !?@(e 8 "h 8 " ! ! 8 "?(e 8 "h 8 " @(d 8 "h 8 " @(d 8 "(c 8 " Y 8"Z(6 CyV c8! EFoDC68 e8%L%[e 8 "h 8 "k8!k8! E Fo D FF> @@(c 8 "(c 8 " 8 %c 8 "(e 8 "h 8 " 8&c 8 " 8%d 8 "h 8 " 8&c 8 "8 @[W  C(7?[] ~Vc(] yV ^8!?(2! ^8!?@(,c %7g h8" + ,+6]6]66666 6!6"l6#6$6%6& +l +U +E +. +" + + ++ + +t +^+=+( + + +!+ + + + + + + +y +_ +X +B +" + + + +2+ + + +x +m>& 8  > +9 ?9'Tgl^ M c 3&)*  8{#   C! 2&W(Vdh<Rtx|1%c "1%d G ^h G ^ 8{ #j G ^kG ^8{ # ]Y #1%dI4"1%g(8{!6( ^VB5) ^V75* ^V,5+ ^V!5, ^V5- ^V5. ^V?(e(d(g(g(g(f(c!3"c!?(d 8{"?(e 8{"!?(G 8{" G 8{" G8{" #  6/8 & ?(G 8{" G 8{" "?(G 8{" 608" &8{ ! F D EiI4 " o >?(g(g(g (g (g (g (g (g(g(g(g(g(g(8{!8L !618%" &gj^ M g- 3&)* 8{#   C! 2&W %:c(Gh G ^ 8{ # ] "1%G 8{" !!1%G 8{" G 8{" G8{" #h!Vl{V 628 "8B!!1%G 8{" G 8{" "!1%G 8{"h!V 638" "g\!!1%ch6465>[g !c "1%G 8{" !1%g= 3&)* 8{#   C! 2&W 08DM 1%  Cc(1%c !4!c !1%4!1%ch6667 >[c "1%1%gG 3&)* 8{#   C! 2&W$6=IU^1%C8{%1%c !4"c !1%3!1%dI4!1%ch6869>[c "1%1%gQ 3&)* 8{# k|VT (d & C! 2&)*G VCTC F F > M ()*G F Fo D C> M ()* aT AT aT AT lpn8B%)* l p ldpnn()*8{! EFoDC6:8 7%8%+%7OO8O^()*8{! D E Fo C Y   !Z( CyV5; E^UFG  D>[[)*8{! E Fo D C>[n#u(W  g ((g (g (b(g(8%8&8%ChyVChy(c?h? +6<?l8! + + + ++p+) + + + + +x +W6=    ,   @9>TC()*C Dh  }U\ ^! zUc(Ch D8+# !()*C {V D^(?[)*DO C~Vjp " C D_C I()*c D^ ^ DOhhD8+  J(c I(^h@(g + + + +6?? ++l +E +<  > 9@T)*W &/(D 2" C 2"@(D 2" C 2"@(C 2"?(D C E"V 2& F"2"@(ch W DCTC2%C2! DF&C(2! 2!G&Wddd#ISC2! D2! D DG" C CG"@(C2! D D2! D G" " CCG"G"@(C! @(C2! D DF" C@(CC@(Wwww/KUC2! D D2! D G" CCG" G"G"@(C2! D2! D DG" C CG"@(C! @(D C2! D C F" E"VF"T@(CC@()*W=ekCCA(i"CCA(C 2" D E2" E D DG" CCG"A(C 2" E D 2" E ^V DDG" CCG"A(Ch2&D C6A2" E D C VCi" F"A(" F" A()*W 1CU`c(CC8@Id @(CCC@Ic @(C 2# D 2# @(C 2# D 2# @(C 2# ?(D CC2# E"V iA?@(h A? @iA?@(W$''$!C2!VD2%(C2!UD2%(d(d(c(W;;;,C CF&D2! C2!G&C !V2%D2%C !V2%C(C(WSS#ANCC C?@F&CC C?@F&C !V! D2!" 2!G&2%D2! C2!G&C2%C()*VDC D C  8 " 8!V     2 @(  8 " 8!VT2      8 " 8!V  @@( @@ @@ (C D_(C F ! E!D! ! ! C     E " IF CVCTCDC>(! D C O"h!c?      + 8: " C6BC^ +p8: "c!c! @( )*D CC W Eh  Di$  Di$ CC D +8:# _(C 8:!^ +8: "()*C C V(D( CAF' 5C8!c O }U\6D8" ^! zUc5E8%#%C WD C6F8$D C6G8$+G &6H8$)* +G &)*C DD CDC^V  # @(V yV D#h@( # @(D# yVcT  # @@()*D C E"UDV?@ F"@( @()*# D @@C F"@()*cC@ +G # D C@ ^+G # D()*Y ^G"Z(6 CyV5I6 @[[D! C@()*c!   +8: " 8 %)* ^ D ^$ )*c8@@+G ')*$)*+G ')*C WaD C Y:DG" C ^V#  # DG"  @F# C@T Z(6 CyV #D  @F#C@( [C C C {U yVDC^V D#D  @@@( ( )* G"  " F')* +G '!V5J(! D C?@()* Y T\8! C! D @@dUcZT8 CyVcT[(! YCG" 8@"D# @Z(6 CyV.C! C 8@"C F#I @8"D @([)*YBG! "G" "G" zV!V  ?@T  @@TZ(6 CyV5K6 @[[)*C D +G ')*c +G # % !yV  !@(( !E&)* !F&)*V]C+8:# +8:" D C V  8%"2&V*C WTCh! +8: "2" @@( 5L6 @[(,h &6M8$)* +8: "g 8%-"8%+%)*! !6N 8$WD(g(C()*WD CG" D(C DD()*D C W2C YDG"6O6 @[6 CyVD"h@ F#C@([CC C {VD"h@ @@((c! +G ')* " F')*C +G ')*Y DG"Z(6 CyVC ID F#J([Cl@()* ?@()*D D# DC CC@F#@()* D&D C DDC " +G #C # DC@ +G #h D +G # C Ch@C@@@()*D !V" F" @T @ DC CF#@()*C@ +G ')*!V F&()* +G 'h}(h|()*Y 8"ZT6 CyVCT[ YG"G!Z(6 CyV#cIC l|V?[ F"8 #([dIC(I8!cICI(8!cI8@!h()*C CG " (D DG &)* ?F&D C C yVCT C DD ?# G # yVCT C ?F"+G # ! @()* D ?')*Y3G" C^VcT5P6 @[G" DF"@ F#Z(6 CyVCF" @F'[)* +G ')* @F&)*D C Y G" G"  F"F#Z(6 CyV CF" F' [C +G #C +G ')*C C^ (D DG & CCyVC D^(6Q8&5R8% %D + +'5S8%#%6T8&5U8% %C C zV6V8"DD + +#5W8%#!D ++')*8%"5X8!!c%)* +G &)*6Y8"!c%)* +G &)*DV5ZT5[ C6\ 8$)* ^()* ^()*WOOO5@ C_(D C !V! " !G"T!2" 2&C 2"D 2&C !G"2&c(CDC&)*C ^ , +8: "()* DG" C@F&)*C +G ')*C C^ (D DG &F! D E D8:! FCC>A(cIcI+8: "C8:!8+ !hI @()*E C! ! # ! !  C D F E8%" D DC A@ ?D@ C@>( 6]+8:')*WAA+>D6?(5^6 @[C 2" VD C2&(C 2" D 2" ^V(c(?()*W 'Ry? @(DVT? @(5_6 @[C C"V ? @(h@? D C@8#?h@(D C 2" D C V C2" D C "@(c "@(C " D " ^V@(c @()*WAA+>D6?(5`6 @[D 2" VC C2&(C 2" D 2" ^V(c(?()*W 'Ry? @(DVT? @(5a6 @[C C"V ? @(i@? D C@8#?h@(C D 2" D C V C2" D C"@(c "@(C " D " ^V@(c @()*W $\s @(DVTd " @(5b6 @[C C"V @(VC D C@8#h@(D C@! ?@(C 2" D D2" D C C"@(h" V C " @(c @(c @()*C E"Vd @! E"@Tc @!i @!E"A @@(Y 8"Z(6 CyVCc ?@? 8#c ?@?([)*gh8" , ,a, ,;V h" Ch " CT h? +  ,h "h +3G #C C A(C^()* +G&)*VCC Dn C@??()*V(V( @(VC?(VC?(6c" D CG&)*V V C Cn?(c()*VC n?(%! C()* G" G"G&C&)* ^()*C C8L&)* ^(5d? + ?8! + + ?8! ?8! ?8!?8! ,# + +,f ,+o ,+` +O +6  ,f +h?h? ,+ +i + ++ +#  +,   ++w ?8! ,G,m +M $, +8% + ?8! + ?8! +[ +I '+# +C)C8%@@@+G ?8! +W ?8!  /+*  /+ +i ++ ?8! C?h8!h?h?h?lh8"8@! +   ++CE+# + + @E+ BG+ H+GB+ C+ EG+ $-+"+ + + + + R+ #%.R+  !$+ + &+ QS+ .+ 7+ ,,2+ +xV+H X]+ 69+u4[+` ?+D +\+ ^+ (*.02GIP+ e@e9eTWOh ^l ^h ^h^h^h^h }Uj\ ^ WCm  _D! _T?C VC _D!_D" D C C_D _C _D _T zUc8@! O=EhD8+#EhC8+#EhD8+#EhC8+# > T+: : : : : :EhD8+#EhC8+# > !!( )*cl^hl^hl }U)\^ C VCTg_D!_ zUc # # @(VCCnD^D2%%(T\!CO }U2, %C D nC_ nD_()*! " ,c ! +8: "E }VK @(C D Oh jp^IEhCh 8+ g jp^JEhDh8+$ cl^ Igl^ Jc K(cll^hl^A(O ~Vc(^ ^V2%2! @@()* ,c %gh8"hh ^hO }UJ\^ Y  8"ZT6 CyVd?  8#T[  C}VC zUc(c 8:#%c 8:#%Y 8"Z(6 CyV! 8#([8@! 8: "g!()*W  D@ C@(l@ C@()*W  D@ C@(l@ C@(8@&c8@! + + + +leh8" +ih !+W +H + + + +|h !h ! +> +  +_ +G ?9fT8%."g 8%-&)* +8: &DC6g8#cCD W6EDCV5hT5i6j8 TDCV5kT5l6m8 T5nI()*CDC CDC^X()*5o?V! +8:'" +t8: "5p8& ()*C D C  6q8$ &)*V 5r 8&5s 8&C &WD C6t8$C6u8$WD C6v8$C6w8')*V05x 8%."8:!6y 8# +8: "5z 8%." +8: &()*6{ 8')*DC{UVyE6|8 V)dF }U\g 8%-" zUcg( 8%-"TdF }U\g 8%-" zUcC 8%C" DC Vg) 8%-"%()* }U\8%<! l zV8%-" zUc()*o T'\g8%"h8%>   h 8%/  oc(5} D8"D8%+!c Y4T+\E8%<!  dFLTU FLTcdUcZ(6 CyVC F6~D8$[E8%G%)*d 8%:! >(+ + +l] +D +8O6 ^V5 ^VTT +m +] +" + + +l +h?   >9T&58%."$)*7CXV-+GO FO EO DO COnnnnjp FO CO68 G OG OGOGO GO GOnnnnjpn h{V7CXV68"7%8%+!FOl{V?[c     8 "V-58%." C D+68: "58%."c 8$58"C68# D8 dE8 58&)*h{V 6 8'()*F -C D8 CD68!E +D8C68 D8 C6 8 E5T568#58"G+N8: "D8C68$ )*5 8%." C68  D68  E68  F68  G68  G68  G68  G68  G68  G 68  G 68 5 8%.&)*5 8%."c O }U&\g ^s "g slyV5 8%." zUc5 8%.&)*5 8%."c O }U3\g ^s "gl ^xs "g slyV5 8%." zUc5 8%.&)*g\ 8%-"gd ql0n8B! 8%-"g l qrl0n8B! 8%-"g rl0n8B! 8%-&+ +l +$ +w +6? + @9T358%."$)*c8  "V)5 8%." C D+8: "5 8%."c8$58"C68# D8 dE8 58&)*F  CD68! E D8C68 G+8: "58&)*!O  c^h6 d  }U\^6  zUcg 8%-&)* 68 WD 6#C6 8'C VD 6#5 8"C68#5 8"D &WD8 C868$C868$WD C68$C68')*5 8%." +8: "5 8%." +8: &)*C ^V C D8:!$()*D8:!C }V ICII()*C Y 8"ZT6 CyVcD@T[ D @ C@ 8 ')*gh8" +hl }U\^ " zUcc?h?h? +y8 " +T8 "C C' )*5 8" ')*5 8" !8: "5 8" 68  ')* 5 8&8B!8B!6 8')* 68#V C6 8'5 8"5 8&68')* +8: &5 8"5 8%.&+ + + + +V +B + +Z +  +y +8 + ? 9TC VCT 8"e8%L!C VCT 5 8"V56 8"8%"T5 8%" 8%:! 8%(! 8" 8{!hhi> M Yd8>8'" D8e! D CCV5E C8 T8f! E C8  8%F! 8%6! 8!Z(8%F!8%6!8!]7 CyV 8{! EFoDC68%8 Tq7 CyV 8{! EFoDC68%8 TJ7> CyV@DGFE68%8 T+7e CyV 68%8#T7 CyV 68%8#T[f8%L% ?I(?I(7O 8%!c8%L%58%!7O 8%!c8%!c8%L%c?h?h?6 + +h6 ?6A@6 ?6A@6 ?6A@68?6A@6+?6A@6?6A@ +n 8# +h !c8%L!   >9c8%P!:9caml_alloc_dummycaml_alloc_dummy_floatcaml_update_dummycaml_array_get_addrcaml_array_get_floatcaml_array_getcaml_array_set_addrcaml_array_set_floatcaml_array_setcaml_array_unsafe_get_floatcaml_array_unsafe_getcaml_array_unsafe_set_addrcaml_array_unsafe_set_floatcaml_array_unsafe_setcaml_make_vectcaml_make_arraycaml_array_blitcaml_array_subcaml_array_appendcaml_array_concatcaml_comparecaml_equalcaml_notequalcaml_lessthancaml_lessequalcaml_greaterthancaml_greaterequalcaml_output_valuecaml_output_value_to_stringcaml_output_value_to_buffercaml_format_floatcaml_float_of_stringcaml_int_of_floatcaml_float_of_intcaml_neg_floatcaml_abs_floatcaml_add_floatcaml_sub_floatcaml_mul_floatcaml_div_floatcaml_exp_floatcaml_floor_floatcaml_fmod_floatcaml_frexp_floatcaml_ldexp_floatcaml_log_floatcaml_log10_floatcaml_modf_floatcaml_sqrt_floatcaml_power_floatcaml_sin_floatcaml_sinh_floatcaml_cos_floatcaml_cosh_floatcaml_tan_floatcaml_tanh_floatcaml_asin_floatcaml_acos_floatcaml_atan_floatcaml_atan2_floatcaml_ceil_floatcaml_hypot_floatcaml_expm1_floatcaml_log1p_floatcaml_copysign_floatcaml_eq_floatcaml_neq_floatcaml_le_floatcaml_lt_floatcaml_ge_floatcaml_gt_floatcaml_float_comparecaml_classify_floatcaml_gc_statcaml_gc_quick_statcaml_gc_counterscaml_gc_getcaml_gc_setcaml_gc_minorcaml_gc_majorcaml_gc_full_majorcaml_gc_major_slicecaml_gc_compactioncaml_hashcaml_hash_univ_paramcaml_input_valuecaml_input_value_from_stringcaml_marshal_data_sizecaml_int_comparecaml_int_of_stringcaml_format_intcaml_int32_negcaml_int32_addcaml_int32_subcaml_int32_mulcaml_int32_divcaml_int32_modcaml_int32_andcaml_int32_orcaml_int32_xorcaml_int32_shift_leftcaml_int32_shift_rightcaml_int32_shift_right_unsignedcaml_int32_of_intcaml_int32_to_intcaml_int32_of_floatcaml_int32_to_floatcaml_int32_comparecaml_int32_formatcaml_int32_of_stringcaml_int32_bits_of_floatcaml_int32_float_of_bitscaml_int64_negcaml_int64_addcaml_int64_subcaml_int64_mulcaml_int64_divcaml_int64_modcaml_int64_andcaml_int64_orcaml_int64_xorcaml_int64_shift_leftcaml_int64_shift_rightcaml_int64_shift_right_unsignedcaml_int64_of_intcaml_int64_to_intcaml_int64_of_floatcaml_int64_to_floatcaml_int64_of_int32caml_int64_to_int32caml_int64_of_nativeintcaml_int64_to_nativeintcaml_int64_comparecaml_int64_formatcaml_int64_of_stringcaml_int64_bits_of_floatcaml_int64_float_of_bitscaml_nativeint_negcaml_nativeint_addcaml_nativeint_subcaml_nativeint_mulcaml_nativeint_divcaml_nativeint_modcaml_nativeint_andcaml_nativeint_orcaml_nativeint_xorcaml_nativeint_shift_leftcaml_nativeint_shift_rightcaml_nativeint_shift_right_unsignedcaml_nativeint_of_intcaml_nativeint_to_intcaml_nativeint_of_floatcaml_nativeint_to_floatcaml_nativeint_of_int32caml_nativeint_to_int32caml_nativeint_comparecaml_nativeint_formatcaml_nativeint_of_stringcaml_ml_open_descriptor_incaml_ml_open_descriptor_outcaml_ml_out_channels_listcaml_channel_descriptorcaml_ml_close_channelcaml_ml_channel_sizecaml_ml_channel_size_64caml_ml_set_binary_modecaml_ml_flush_partialcaml_ml_flushcaml_ml_output_charcaml_ml_output_intcaml_ml_output_partialcaml_ml_outputcaml_ml_seek_outcaml_ml_seek_out_64caml_ml_pos_outcaml_ml_pos_out_64caml_ml_input_charcaml_ml_input_intcaml_ml_inputcaml_ml_seek_incaml_ml_seek_in_64caml_ml_pos_incaml_ml_pos_in_64caml_ml_input_scan_linecaml_lex_enginecaml_new_lex_enginecaml_md5_stringcaml_md5_chancaml_get_global_datacaml_get_section_tablecaml_reify_bytecodecaml_register_code_fragmentcaml_realloc_globalcaml_get_current_environmentcaml_invoke_traced_functioncaml_static_alloccaml_static_freecaml_static_release_bytecodecaml_static_resizecaml_obj_is_blockcaml_obj_tagcaml_obj_set_tagcaml_obj_blockcaml_obj_dupcaml_obj_truncatecaml_obj_add_offsetcaml_lazy_follow_forwardcaml_lazy_make_forwardcaml_get_public_methodcaml_parse_enginecaml_set_parser_tracecaml_install_signal_handlercaml_ml_string_lengthcaml_create_stringcaml_string_getcaml_string_setcaml_string_equalcaml_string_notequalcaml_string_comparecaml_string_lessthancaml_string_lessequalcaml_string_greaterthancaml_string_greaterequalcaml_blit_stringcaml_fill_stringcaml_is_printablecaml_bitvect_testcaml_sys_exitcaml_sys_opencaml_sys_closecaml_sys_file_existscaml_sys_is_directorycaml_sys_removecaml_sys_renamecaml_sys_chdircaml_sys_getcwdcaml_sys_getenvcaml_sys_get_argvcaml_sys_system_commandcaml_sys_timecaml_sys_random_seedcaml_sys_get_configcaml_sys_read_directorycaml_terminfo_setupcaml_terminfo_backupcaml_terminfo_standoutcaml_terminfo_resumecaml_register_named_valuecaml_weak_createcaml_weak_setcaml_weak_getcaml_weak_get_copycaml_weak_checkcaml_weak_blitcaml_final_registercaml_final_releasecaml_ensure_stack_capacitycaml_dynlink_open_libcaml_dynlink_close_libcaml_dynlink_lookup_symbolcaml_dynlink_add_primitivecaml_dynlink_get_current_libscaml_record_backtracecaml_backtrace_statuscaml_get_exception_backtrace< -Out_of_memory)Sys_error'Failure0Invalid_argument+End_of_file0Division_by_zero)Not_found-Match_failure.Stack_overflow.Sys_blocked_io.Assert_failure:Undefined_recursive_module"%,,really_input%input@F@@G@&outputACDF@ACDG@%%.12g!."%d%false$true.bool_of_string$true%false+char_of_int/Pervasives.Exit_j_j_j_j_j_j<5Pervasives.do_at_exit@(array.mlD*Array.blit*Array.fill)Array.sub,Array.Bottom@)List.map2*List.iter2/List.fold_left20List.fold_right2-List.for_all2,List.exists2@@,List.combine'list.mlK-List.rev_map2#nth(List.nth"tl"hd@"\b"\t"\n"\r"\\"\'(Char.chr@5String.rcontains_from4String.contains_from2String.rindex_from1String.index_from +String.blit+String.fill*String.sub@)Sys.Break&4.00.1@1Marshal.from_size3Marshal.from_string1Marshal.data_size *Marshal.to_buffer: substring out of bounds@@"%d_i_i_i_i_i_i_i_i_i@"%d_j_j_j_j_j_j_j_j_j@"%d_n_n_n_n_n_n_n_n_n@ %Lexing.lex_refill: cannot grow buffer @@ A@@@,syntax error.Parsing.YYexit3Parsing.Parse_error@2Set.remove_min_elt@@@@@'Set.bal'Set.bal'Set.bal'Set.bal@2Map.remove_min_elt@@@&map.mlJ@@'Map.bal'Map.bal'Map.bal'Map.bal@+Stack.Empty@:CamlinternalLazy.Undefined@)buffer.mlsI2Buffer.add_channel4Buffer.add_substring>Buffer.add: cannot grow buffer*Buffer.nth+Buffer.blit*Buffer.sub@ !"!"!'!'!. )printf: bad positional specification (0)."%_)printf.mlH"'' )Printf: premature end of format string ``"''4 in format string ``1, at char number 8Printf: bad conversion % (Sformat.index_of_int: negative argument @ ! "%s"%s.bool_of_string)a boolean-int_of_string*an integer-int_of_string*an integer/float_of_string'a float/float_of_string'a float ! (one of: #(?)&--help%-help9%s: unknown option `%s'. 1%s: wrong argument `%s'; option `%s' expects %s. #%s: option `%s' needs an argument. (%s: %s. %-help&--help"%s#%s %-help= Display this list of options%-help&--help= Display this list of options&--help%-help( %s %s !}!|!{* %s %s%s &'Arg.Bad(Arg.Help(Arg.Stop@/Digest.from_hex/Digest.from_hex$%02x0Digest.substring@_i_j A_j,Random.int64_i,Random.int32*Random.int!xzR+]F4J{lGgP2wAv+^  FKk|HHtcHZš/{Yi2zvn6m[b"|ᵟ.xge=xBLX?}nSO}YE] ~N~aNw"\(sd}@*LY= зd(.OR.2E9!DLJ<AGu<*UO^ohf6o/z@@-OCAMLRUNPARAM,CAMLRUNPARAM @G@ACE@(%s%06x%s7Filename.chop_extension4Filename.chop_suffix "./".\#../#..\"./#../ !."..!/&TMPDIR$/tmp$'\''!."..!\$TEMP!.!."..!/&Cygwin$Unix%Win32+filename.mlI@'cset.mlUP(Cset.Bad@@&parser@@A@ IFile "%s", line %d, character %d: Reference to unbound regexp name `%s'. X     @@ L  L %  "< + ./<"84 *#*,-C~~ 6+68V0E66V@@ DDB(KNQpZr<S[dZ>1 @# :$--# 6!9@- %&'(5 )*-;1 73%&'(=)*#? %2&'(!)* $&'(* 0>  ,   @ ,%*?,    ?           !    :         TruleTparseTparse_shortestTandTequalTendTorTunderscoreTeofTlbracketTrbracketTstarTmaybeTplusTlparenTrparenTcaretTdashTletTasTsharp=TidentTcharTstringTaction@#and"as#eof#let%parse$rule(shortest?illegal escape sequence \%c%c%c;illegal escape sequence \%c2illegal character -illegal backslash escape in string: `\%c%c%c' )illegal backslash escape in string: `\%c' 3unterminated string 4unterminated comment 3unterminated action 8ocamllex warning: File "%s", line %d, character %d: %s. 3Lexer.Lexical_error, t~Ouv)3  {Y <<  \}    ".3>HRU *8888!&),8FEP[Y[Y[[   /21''''''''''((((((((((09999999999****************::::::::::?\\\\\\\\\\******BADC%%IS%$$$$$$$$$$[MLKZZZZZZZZZZ++++++++++%%++++++%%8%7T#++++++666ON5555555555@;;;;;;;;;;66;;;;;;66X64<<<<<<<<<<;;;;;;<<<<<<WWWWWWWWWW<<<<<<J[]]]]]]]]]]]]]]]]^^^^^^^^^^V^^^^^^]]]]]]^^^^^^ *8778 %(+7CDKRSUX\^---$$$$$$$$$$''''''''''-5555555555################9999999999=ZZZZZZZZZZ######====GQWGGGQWWWWWWWWWW****************11Q******111GG1111111111=44444444441144444411T11;;;;;;;;;;444444;;;;;;TTTTTTTTTT;;;;;;GVQVVVVVVVVVVVVVVVV]]]]]]]]]]T]]]]]]VVVVVV1]]]]]]T $  ''  J$$$ J171 *@+Table.Error@@@@(follow=[#%d:!]+ (-> %d,%a)* ([%d],%a)# %a)lexgen.ml,Q@@[Q#%a (%d <- %daqH"%d" , "%d" ,)final=%d $ -> &%d -> !s!e&%s<%s>@@@@]RwRRRR@6Lexgen.Memory_overflow@@#%s $_opt "= Lexing.sub_lexeme%s lexbuf %a %a$_opt $= Lexing.sub_lexeme_char%s lexbuf %a$ and#let$ in )(%a + %d):lexbuf.Lexing.lex_curr_pos;lexbuf.Lexing.lex_start_pos-%s%a <- %a ; %%s%a <- lexbuf.Lexing.lex_curr_pos ; .[%d] <- [%d] ;,[%d] <- p ; #(* %L=%d $ *) :lexbuf.Lexing.lex_mem.(%d)*# %d "%s" ! *# %d "%s" &Cygwin%Win32@$and /%d states, %d transitions, table size %d bytes &%d additional bytes used for bindings (let rec $;; $ | &%d -> ! 0lexbuf.Lexing.lex_mem <- Array.create %d (-1) ; " 5%s %alexbuf = %a%a __ocaml_lex_%s_rec %alexbuf %d 4and __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state = $new_7 match Lexing.%sengine 6 __ocaml_lex_tables __ocaml_lex_state lexbuf with j | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_%s_rec %alexbuf __ocaml_lex_state ;let __ocaml_lex_tables = { 9 Lexing.lex_base = %a; < Lexing.lex_backtrk = %a; < Lexing.lex_default = %a; : Lexing.lex_trans = %a; : Lexing.lex_check = %a; > Lexing.lex_base_code = %a; ! Lexing.lex_backtrk_code = %a; ! Lexing.lex_default_code = %a; ? Lexing.lex_trans_code = %a; ? Lexing.lex_check_code = %a; 9 Lexing.lex_code = %a; #} $ "&\ !"$ "&\ !"5Output.Table_overflow@$and (let rec $;; $ | &%d -> ! " T%s %alexbuf = __ocaml_lex_init_lexbuf lexbuf %d; %a let __ocaml_lex_result = __ocaml_lex_state%d lexbuf in lexbuf.Lexing.lex_start_p <- lexbuf.Lexing.lex_curr_p; lexbuf.Lexing.lex_curr_p <- {lexbuf.Lexing.lex_curr_p with Lexing.pos_cnum = lexbuf.Lexing.lex_abs_pos + lexbuf.Lexing.lex_curr_pos}; match __ocaml_lex_result with 1 | _ -> raise (Failure "lexing: empty token") 'let rec$ and %s __ocaml_lex_state%d lexbuf = " % %d " = lexbuf.Lexing.lex_last_pos <- lexbuf.Lexing.lex_curr_pos ; ( lexbuf.Lexing.lex_last_action <- %d ; * match __ocaml_lex_next_char lexbuf with -%s%a <- %a ; -%s%a <- -1 ; . t%d <- [%d] ;, t%d <- -1 ;"(*$ *) ) | _ -> #(* $ *) ( %a -> $|eof%|'%s'$ ? __ocaml_lex_state%d lexbuf ? lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_last_pos ; " lexbuf.Lexing.lex_last_action #|%d let __ocaml_lex_init_lexbuf lexbuf mem_size = let pos = lexbuf.Lexing.lex_curr_pos in lexbuf.Lexing.lex_mem <- Array.create mem_size (-1) ; lexbuf.Lexing.lex_start_pos <- pos ; lexbuf.Lexing.lex_last_pos <- pos ; lexbuf.Lexing.lex_last_action <- -1 let rec __ocaml_lex_next_char lexbuf = if lexbuf.Lexing.lex_curr_pos >= lexbuf.Lexing.lex_buffer_len then begin if lexbuf.Lexing.lex_eof_reached then 256 else begin lexbuf.Lexing.refill_buff lexbuf ; __ocaml_lex_next_char lexbuf end end else begin let i = lexbuf.Lexing.lex_curr_pos in let c = lexbuf.Lexing.lex_buffer.[i] in lexbuf.Lexing.lex_curr_pos <- i+1 ; Char.code c end @$.mll#.ml$.mll#.ml :File "%s", line %d, character %d: character set expected. 0File "%s", line %d, character %d: syntax error. &File "%s", line %d, character %d: %s. 8File "%s": Position memory overflow, too many bindings ;File "%s": transition table overflow, automaton is too big #The OCaml lexer generator, version #usage: ocamlex [options] sourcefile> Print version number and exit%-vnum7 Print version and exit(-version7 Print version and exit"-v & Do not display informational messages"-q ' Set output file name to "-o N Output code that does not use the Lexing module built-in automata interpreter#-ml@@6Y@@#ArgA@A@%ArrayAk@B@&BufferA@@0CamlinternalLazyA@AC@$CharAB@@&CommonA@A@'CompactAf@@$CsetA@AB@&DigestA@@(FilenameA@ACD@'HashtblA@@%Int32A`@A@%Int64Ak@@%LexerA>@A@&LexgenAe@@&LexingA{@ABC@$ListAz@@$MainA@A@#MapA@@'MarshalAT@AB@)NativeintAv@@#ObjAU@A@&OutputA@@)OutputbisA@AB@&ParserA'@@'ParsingA@ACDEF@*PervasivesAe@@&PrintfA@A@&RandomA@@#SetA@AB@%StackA@@(Std_exitA@A@&StringAL@@&SyntaxA@AB@#SysAO@@%TableA@@AP-Match_failureCG@BCDQ-Out_of_memoryC@@R0Invalid_argumentCC@AS'FailureCB@T)Not_foundCF@AU)Sys_errorCA@BCV+End_of_fileCD@W0Division_by_zeroCE@AX.Stack_overflowCH@Y.Sys_blocked_ioCI@AZ.Assert_failureCJ@[:Undefined_recursive_moduleCK@ABCDEG=Ϡ%Int320&Y(y cHϚΠ%Int320&Y(y cHϚΠ%Table0% itT[$Char0&)9_=J(Bm&Printf0L,B=a.4(Filename0LTjC>)Outputbis0u ZIT'#Arg0 7}-}\+%Array0M^ {OԲwp%Stack0&(Jhl?$Cset0]y`%l=h&Syntax0` Ak, #Sys0Eu%B&̄y&#Obj0{B+,;)Nativeint0G$)@p hc$'Hashtbl0q΋q"H>6/x%Lexer0Ȅ^qق^.>$l #Set0**V $.QCˠ&Lexgen0qK~/K; 2'Parsing0 RY&Digest0rUATy[;l&Output08;x)jͻs(Std_exit0Uol'HWà0CamlinternalLazy0~OaKtGB&String0T&GSq첋&Random0o7pr'Marshal0}55UanRߜ&Buffer0?lG!W fprintf f "%s" s; | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s; | Longident.Lapply (y, z) -> fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; ;; let fmt_longident_noloc f x = fprintf f "\"%a\"" fmt_longident_aux x;; let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;; let fmt_constant f x = match x with | Const_int (i) -> fprintf f "Const_int %d" i; | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c); | Const_string (s) -> fprintf f "Const_string %S" s; | Const_float (s) -> fprintf f "Const_float %s" s; | Const_int32 (i) -> fprintf f "Const_int32 %ld" i; | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i; | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i; ;; let fmt_mutable_flag f x = match x with | Immutable -> fprintf f "Immutable"; | Mutable -> fprintf f "Mutable"; ;; let fmt_virtual_flag f x = match x with | Virtual -> fprintf f "Virtual"; | Concrete -> fprintf f "Concrete"; ;; let fmt_override_flag f x = match x with | Override -> fprintf f "Override"; | Fresh -> fprintf f "Fresh"; ;; let fmt_rec_flag f x = match x with | Nonrecursive -> fprintf f "Nonrec"; | Recursive -> fprintf f "Rec"; | Default -> fprintf f "Default"; ;; let fmt_direction_flag f x = match x with | Upto -> fprintf f "Up"; | Downto -> fprintf f "Down"; ;; let fmt_private_flag f x = match x with | Public -> fprintf f "Public"; | Private -> fprintf f "Private"; ;; let line i f s (*...*) = fprintf f "%s" (String.make (2*i) ' '); fprintf f s (*...*) ;; let list i f ppf l = match l with | [] -> line i ppf "[]\n"; | _ :: _ -> line i ppf "[\n"; List.iter (f (i+1) ppf) l; line i ppf "]\n"; ;; let option i f ppf x = match x with | None -> line i ppf "None\n"; | Some x -> line i ppf "Some\n"; f (i+1) ppf x; ;; let longident i ppf li = line i ppf "%a\n" fmt_longident li;; let string i ppf s = line i ppf "\"%s\"\n" s;; let string_loc i ppf s = line i ppf "\"%s\"\n" s.txt;; let bool i ppf x = line i ppf "%s\n" (string_of_bool x);; let label i ppf x = line i ppf "label=\"%s\"\n" x;; let rec core_type i ppf x = line i ppf "core_type %a\n" fmt_location x.ptyp_loc; let i = i+1 in match x.ptyp_desc with | Ptyp_any -> line i ppf "Ptyp_any\n"; | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s; | Ptyp_arrow (l, ct1, ct2) -> line i ppf "Ptyp_arrow\n"; string i ppf l; core_type i ppf ct1; core_type i ppf ct2; | Ptyp_tuple l -> line i ppf "Ptyp_tuple\n"; list i core_type ppf l; | Ptyp_constr (li, l) -> line i ppf "Ptyp_constr %a\n" fmt_longident li; list i core_type ppf l; | Ptyp_variant (l, closed, low) -> line i ppf "Ptyp_variant closed=%s\n" (string_of_bool closed); list i label_x_bool_x_core_type_list ppf l; option i (fun i -> list i string) ppf low | Ptyp_object (l) -> line i ppf "Ptyp_object\n"; list i core_field_type ppf l; | Ptyp_class (li, l, low) -> line i ppf "Ptyp_class %a\n" fmt_longident li; list i core_type ppf l; list i string ppf low | Ptyp_alias (ct, s) -> line i ppf "Ptyp_alias \"%s\"\n" s; core_type i ppf ct; | Ptyp_poly (sl, ct) -> line i ppf "Ptyp_poly%a\n" (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl; core_type i ppf ct; | Ptyp_package (s, l) -> line i ppf "Ptyp_package %a\n" fmt_longident s; list i package_with ppf l; and package_with i ppf (s, t) = line i ppf "with type %a\n" fmt_longident s; core_type i ppf t and core_field_type i ppf x = line i ppf "core_field_type %a\n" fmt_location x.pfield_loc; let i = i+1 in match x.pfield_desc with | Pfield (s, ct) -> line i ppf "Pfield \"%s\"\n" s; core_type i ppf ct; | Pfield_var -> line i ppf "Pfield_var\n"; and pattern i ppf x = line i ppf "pattern %a\n" fmt_location x.ppat_loc; let i = i+1 in match x.ppat_desc with | Ppat_any -> line i ppf "Ppat_any\n"; | Ppat_var (s) -> line i ppf "Ppat_var \"%s\"\n" s.txt; | Ppat_alias (p, s) -> line i ppf "Ppat_alias \"%s\"\n" s.txt; pattern i ppf p; | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; | Ppat_tuple (l) -> line i ppf "Ppat_tuple\n"; list i pattern ppf l; | Ppat_construct (li, po, b) -> line i ppf "Ppat_construct %a\n" fmt_longident li; option i pattern ppf po; bool i ppf b; | Ppat_variant (l, po) -> line i ppf "Ppat_variant \"%s\"\n" l; option i pattern ppf po; | Ppat_record (l, c) -> line i ppf "Ppat_record\n"; list i longident_x_pattern ppf l; | Ppat_array (l) -> line i ppf "Ppat_array\n"; list i pattern ppf l; | Ppat_or (p1, p2) -> line i ppf "Ppat_or\n"; pattern i ppf p1; pattern i ppf p2; | Ppat_lazy p -> line i ppf "Ppat_lazy\n"; pattern i ppf p; | Ppat_constraint (p, ct) -> line i ppf "Ppat_constraint"; pattern i ppf p; core_type i ppf ct; | Ppat_type (li) -> line i ppf "Ppat_type"; longident i ppf li | Ppat_unpack s -> line i ppf "Ppat_unpack \"%s\"\n" s.txt; and expression i ppf x = line i ppf "expression %a\n" fmt_location x.pexp_loc; let i = i+1 in match x.pexp_desc with | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident li; | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; | Pexp_let (rf, l, e) -> line i ppf "Pexp_let %a\n" fmt_rec_flag rf; list i pattern_x_expression_def ppf l; expression i ppf e; | Pexp_function (p, eo, l) -> line i ppf "Pexp_function \"%s\"\n" p; option i expression ppf eo; list i pattern_x_expression_case ppf l; | Pexp_apply (e, l) -> line i ppf "Pexp_apply\n"; expression i ppf e; list i label_x_expression ppf l; | Pexp_match (e, l) -> line i ppf "Pexp_match\n"; expression i ppf e; list i pattern_x_expression_case ppf l; | Pexp_try (e, l) -> line i ppf "Pexp_try\n"; expression i ppf e; list i pattern_x_expression_case ppf l; | Pexp_tuple (l) -> line i ppf "Pexp_tuple\n"; list i expression ppf l; | Pexp_construct (li, eo, b) -> line i ppf "Pexp_construct %a\n" fmt_longident li; option i expression ppf eo; bool i ppf b; | Pexp_variant (l, eo) -> line i ppf "Pexp_variant \"%s\"\n" l; option i expression ppf eo; | Pexp_record (l, eo) -> line i ppf "Pexp_record\n"; list i longident_x_expression ppf l; option i expression ppf eo; | Pexp_field (e, li) -> line i ppf "Pexp_field\n"; expression i ppf e; longident i ppf li; | Pexp_setfield (e1, li, e2) -> line i ppf "Pexp_setfield\n"; expression i ppf e1; longident i ppf li; expression i ppf e2; | Pexp_array (l) -> line i ppf "Pexp_array\n"; list i expression ppf l; | Pexp_ifthenelse (e1, e2, eo) -> line i ppf "Pexp_ifthenelse\n"; expression i ppf e1; expression i ppf e2; option i expression ppf eo; | Pexp_sequence (e1, e2) -> line i ppf "Pexp_sequence\n"; expression i ppf e1; expression i ppf e2; | Pexp_while (e1, e2) -> line i ppf "Pexp_while\n"; expression i ppf e1; expression i ppf e2; | Pexp_for (s, e1, e2, df, e3) -> line i ppf "Pexp_for \"%s\" %a\n" s.txt fmt_direction_flag df; expression i ppf e1; expression i ppf e2; expression i ppf e3; | Pexp_constraint (e, cto1, cto2) -> line i ppf "Pexp_constraint\n"; expression i ppf e; option i core_type ppf cto1; option i core_type ppf cto2; | Pexp_when (e1, e2) -> line i ppf "Pexp_when\n"; expression i ppf e1; expression i ppf e2; | Pexp_send (e, s) -> line i ppf "Pexp_send \"%s\"\n" s; expression i ppf e; | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident li; | Pexp_setinstvar (s, e) -> line i ppf "Pexp_setinstvar \"%s\"\n" s.txt; expression i ppf e; | Pexp_override (l) -> line i ppf "Pexp_override\n"; list i string_x_expression ppf l; | Pexp_letmodule (s, me, e) -> line i ppf "Pexp_letmodule \"%s\"\n" s.txt; module_expr i ppf me; expression i ppf e; | Pexp_assert (e) -> line i ppf "Pexp_assert"; expression i ppf e; | Pexp_assertfalse -> line i ppf "Pexp_assertfalse"; | Pexp_lazy (e) -> line i ppf "Pexp_lazy"; expression i ppf e; | Pexp_poly (e, cto) -> line i ppf "Pexp_poly\n"; expression i ppf e; option i core_type ppf cto; | Pexp_object s -> line i ppf "Pexp_object"; class_structure i ppf s | Pexp_newtype (s, e) -> line i ppf "Pexp_newtype \"%s\"\n" s; expression i ppf e | Pexp_pack me -> line i ppf "Pexp_pack"; module_expr i ppf me | Pexp_open (m, e) -> line i ppf "Pexp_open \"%a\"\n" fmt_longident m; expression i ppf e and value_description i ppf x = line i ppf "value_description\n"; core_type (i+1) ppf x.pval_type; list (i+1) string ppf x.pval_prim; and string_option_underscore i ppf = function | Some x -> string i ppf x.txt | None -> string i ppf "_" and type_declaration i ppf x = line i ppf "type_declaration %a\n" fmt_location x.ptype_loc; let i = i+1 in line i ppf "ptype_params =\n"; list (i+1) string_option_underscore ppf x.ptype_params; line i ppf "ptype_cstrs =\n"; list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs; line i ppf "ptype_kind =\n"; type_kind (i+1) ppf x.ptype_kind; line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; line i ppf "ptype_manifest =\n"; option (i+1) core_type ppf x.ptype_manifest; and type_kind i ppf x = match x with | Ptype_abstract -> line i ppf "Ptype_abstract\n" | Ptype_variant l -> line i ppf "Ptype_variant\n"; list (i+1) string_x_core_type_list_x_location ppf l; | Ptype_record l -> line i ppf "Ptype_record\n"; list (i+1) string_x_mutable_flag_x_core_type_x_location ppf l; and exception_declaration i ppf x = list i core_type ppf x and class_type i ppf x = line i ppf "class_type %a\n" fmt_location x.pcty_loc; let i = i+1 in match x.pcty_desc with | Pcty_constr (li, l) -> line i ppf "Pcty_constr %a\n" fmt_longident li; list i core_type ppf l; | Pcty_signature (cs) -> line i ppf "Pcty_signature\n"; class_signature i ppf cs; | Pcty_fun (l, co, cl) -> line i ppf "Pcty_fun \"%s\"\n" l; core_type i ppf co; class_type i ppf cl; and class_signature i ppf { pcsig_self = ct; pcsig_fields = l } = line i ppf "class_signature\n"; core_type (i+1) ppf ct; list (i+1) class_type_field ppf l; and class_type_field i ppf x = let loc = x.pctf_loc in match x.pctf_desc with | Pctf_inher (ct) -> line i ppf "Pctf_inher\n"; class_type i ppf ct; | Pctf_val (s, mf, vf, ct) -> line i ppf "Pctf_val \"%s\" %a %a %a\n" s fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc; core_type (i+1) ppf ct; | Pctf_virt (s, pf, ct) -> line i ppf "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; core_type (i+1) ppf ct; | Pctf_meth (s, pf, ct) -> line i ppf "Pctf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; core_type (i+1) ppf ct; | Pctf_cstr (ct1, ct2) -> line i ppf "Pctf_cstr %a\n" fmt_location loc; core_type i ppf ct1; core_type i ppf ct2; and class_description i ppf x = line i ppf "class_description %a\n" fmt_location x.pci_loc; let i = i+1 in line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; line i ppf "pci_params =\n"; string_list_x_location (i+1) ppf x.pci_params; line i ppf "pci_name = \"%s\"\n" x.pci_name.txt; line i ppf "pci_expr =\n"; class_type (i+1) ppf x.pci_expr; and class_type_declaration i ppf x = line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc; let i = i+1 in line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; line i ppf "pci_params =\n"; string_list_x_location (i+1) ppf x.pci_params; line i ppf "pci_name = \"%s\"\n" x.pci_name.txt; line i ppf "pci_expr =\n"; class_type (i+1) ppf x.pci_expr; and class_expr i ppf x = line i ppf "class_expr %a\n" fmt_location x.pcl_loc; let i = i+1 in match x.pcl_desc with | Pcl_constr (li, l) -> line i ppf "Pcl_constr %a\n" fmt_longident li; list i core_type ppf l; | Pcl_structure (cs) -> line i ppf "Pcl_structure\n"; class_structure i ppf cs; | Pcl_fun (l, eo, p, e) -> line i ppf "Pcl_fun\n"; label i ppf l; option i expression ppf eo; pattern i ppf p; class_expr i ppf e; | Pcl_apply (ce, l) -> line i ppf "Pcl_apply\n"; class_expr i ppf ce; list i label_x_expression ppf l; | Pcl_let (rf, l, ce) -> line i ppf "Pcl_let %a\n" fmt_rec_flag rf; list i pattern_x_expression_def ppf l; class_expr i ppf ce; | Pcl_constraint (ce, ct) -> line i ppf "Pcl_constraint\n"; class_expr i ppf ce; class_type i ppf ct; and class_structure i ppf { pcstr_pat = p; pcstr_fields = l } = line i ppf "class_structure\n"; pattern (i+1) ppf p; list (i+1) class_field ppf l; and class_field i ppf x = let loc = x.pcf_loc in match x.pcf_desc with | Pcf_inher (ovf, ce, so) -> line i ppf "Pcf_inher %a\n" fmt_override_flag ovf; class_expr (i+1) ppf ce; option (i+1) string ppf so; | Pcf_valvirt (s, mf, ct) -> line i ppf "Pcf_valvirt \"%s\" %a %a\n" s.txt fmt_mutable_flag mf fmt_location loc; core_type (i+1) ppf ct; | Pcf_val (s, mf, ovf, e) -> line i ppf "Pcf_val \"%s\" %a %a %a\n" s.txt fmt_mutable_flag mf fmt_override_flag ovf fmt_location loc; expression (i+1) ppf e; | Pcf_virt (s, pf, ct) -> line i ppf "Pcf_virt \"%s\" %a %a\n" s.txt fmt_private_flag pf fmt_location loc; core_type (i+1) ppf ct; | Pcf_meth (s, pf, ovf, e) -> line i ppf "Pcf_meth \"%s\" %a %a %a\n" s.txt fmt_private_flag pf fmt_override_flag ovf fmt_location loc; expression (i+1) ppf e; | Pcf_constr (ct1, ct2) -> line i ppf "Pcf_constr %a\n" fmt_location loc; core_type (i+1) ppf ct1; core_type (i+1) ppf ct2; | Pcf_init (e) -> line i ppf "Pcf_init\n"; expression (i+1) ppf e; and class_declaration i ppf x = line i ppf "class_declaration %a\n" fmt_location x.pci_loc; let i = i+1 in line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; line i ppf "pci_params =\n"; string_list_x_location (i+1) ppf x.pci_params; line i ppf "pci_name = \"%s\"\n" x.pci_name.txt; line i ppf "pci_expr =\n"; class_expr (i+1) ppf x.pci_expr; and module_type i ppf x = line i ppf "module_type %a\n" fmt_location x.pmty_loc; let i = i+1 in match x.pmty_desc with | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident li; | Pmty_signature (s) -> line i ppf "Pmty_signature\n"; signature i ppf s; | Pmty_functor (s, mt1, mt2) -> line i ppf "Pmty_functor \"%s\"\n" s.txt; module_type i ppf mt1; module_type i ppf mt2; | Pmty_with (mt, l) -> line i ppf "Pmty_with\n"; module_type i ppf mt; list i longident_x_with_constraint ppf l; | Pmty_typeof m -> line i ppf "Pmty_typeof\n"; module_expr i ppf m; and signature i ppf x = list i signature_item ppf x and signature_item i ppf x = line i ppf "signature_item %a\n" fmt_location x.psig_loc; let i = i+1 in match x.psig_desc with | Psig_value (s, vd) -> line i ppf "Psig_value \"%s\"\n" s.txt; value_description i ppf vd; | Psig_type (l) -> line i ppf "Psig_type\n"; list i string_x_type_declaration ppf l; | Psig_exception (s, ed) -> line i ppf "Psig_exception \"%s\"\n" s.txt; exception_declaration i ppf ed; | Psig_module (s, mt) -> line i ppf "Psig_module \"%s\"\n" s.txt; module_type i ppf mt; | Psig_recmodule decls -> line i ppf "Psig_recmodule\n"; list i string_x_module_type ppf decls; | Psig_modtype (s, md) -> line i ppf "Psig_modtype \"%s\"\n" s.txt; modtype_declaration i ppf md; | Psig_open li -> line i ppf "Psig_open %a\n" fmt_longident li; | Psig_include (mt) -> line i ppf "Psig_include\n"; module_type i ppf mt; | Psig_class (l) -> line i ppf "Psig_class\n"; list i class_description ppf l; | Psig_class_type (l) -> line i ppf "Psig_class_type\n"; list i class_type_declaration ppf l; and modtype_declaration i ppf x = match x with | Pmodtype_abstract -> line i ppf "Pmodtype_abstract\n"; | Pmodtype_manifest (mt) -> line i ppf "Pmodtype_manifest\n"; module_type (i+1) ppf mt; and with_constraint i ppf x = match x with | Pwith_type (td) -> line i ppf "Pwith_type\n"; type_declaration (i+1) ppf td; | Pwith_typesubst (td) -> line i ppf "Pwith_typesubst\n"; type_declaration (i+1) ppf td; | Pwith_module li -> line i ppf "Pwith_module %a\n" fmt_longident li; | Pwith_modsubst li -> line i ppf "Pwith_modsubst %a\n" fmt_longident li; and module_expr i ppf x = line i ppf "module_expr %a\n" fmt_location x.pmod_loc; let i = i+1 in match x.pmod_desc with | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident li; | Pmod_structure (s) -> line i ppf "Pmod_structure\n"; structure i ppf s; | Pmod_functor (s, mt, me) -> line i ppf "Pmod_functor \"%s\"\n" s.txt; module_type i ppf mt; module_expr i ppf me; | Pmod_apply (me1, me2) -> line i ppf "Pmod_apply\n"; module_expr i ppf me1; module_expr i ppf me2; | Pmod_constraint (me, mt) -> line i ppf "Pmod_constraint\n"; module_expr i ppf me; module_type i ppf mt; | Pmod_unpack (e) -> line i ppf "Pmod_unpack\n"; expression i ppf e; and structure i ppf x = list i structure_item ppf x and structure_item i ppf x = line i ppf "structure_item %a\n" fmt_location x.pstr_loc; let i = i+1 in match x.pstr_desc with | Pstr_eval (e) -> line i ppf "Pstr_eval\n"; expression i ppf e; | Pstr_value (rf, l) -> line i ppf "Pstr_value %a\n" fmt_rec_flag rf; list i pattern_x_expression_def ppf l; | Pstr_primitive (s, vd) -> line i ppf "Pstr_primitive \"%s\"\n" s.txt; value_description i ppf vd; | Pstr_type l -> line i ppf "Pstr_type\n"; list i string_x_type_declaration ppf l; | Pstr_exception (s, ed) -> line i ppf "Pstr_exception \"%s\"\n" s.txt; exception_declaration i ppf ed; | Pstr_exn_rebind (s, li) -> line i ppf "Pstr_exn_rebind \"%s\" %a\n" s.txt fmt_longident li; | Pstr_module (s, me) -> line i ppf "Pstr_module \"%s\"\n" s.txt; module_expr i ppf me; | Pstr_recmodule bindings -> line i ppf "Pstr_recmodule\n"; list i string_x_modtype_x_module ppf bindings; | Pstr_modtype (s, mt) -> line i ppf "Pstr_modtype \"%s\"\n" s.txt; module_type i ppf mt; | Pstr_open li -> line i ppf "Pstr_open %a\n" fmt_longident li; | Pstr_class (l) -> line i ppf "Pstr_class\n"; list i class_declaration ppf l; | Pstr_class_type (l) -> line i ppf "Pstr_class_type\n"; list i class_type_declaration ppf l; | Pstr_include me -> line i ppf "Pstr_include"; module_expr i ppf me and string_x_type_declaration i ppf (s, td) = string i ppf s.txt; type_declaration (i+1) ppf td; and string_x_module_type i ppf (s, mty) = string i ppf s.txt; module_type (i+1) ppf mty; and string_x_modtype_x_module i ppf (s, mty, modl) = string i ppf s.txt; module_type (i+1) ppf mty; module_expr (i+1) ppf modl; and longident_x_with_constraint i ppf (li, wc) = line i ppf "%a\n" fmt_longident li; with_constraint (i+1) ppf wc; and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = line i ppf " %a\n" fmt_location l; core_type (i+1) ppf ct1; core_type (i+1) ppf ct2; and string_x_core_type_list_x_location i ppf (s, l, r_opt, loc) = line i ppf "\"%s\" %a\n" s.txt fmt_location loc; list (i+1) core_type ppf l; option (i+1) core_type ppf r_opt; and string_x_mutable_flag_x_core_type_x_location i ppf (s, mf, ct, loc) = line i ppf "\"%s\" %a %a\n" s.txt fmt_mutable_flag mf fmt_location loc; core_type (i+1) ppf ct; and string_list_x_location i ppf (l, loc) = line i ppf " %a\n" fmt_location loc; list (i+1) string_loc ppf l; and longident_x_pattern i ppf (li, p) = line i ppf "%a\n" fmt_longident li; pattern (i+1) ppf p; and pattern_x_expression_case i ppf (p, e) = line i ppf "\n"; pattern (i+1) ppf p; expression (i+1) ppf e; and pattern_x_expression_def i ppf (p, e) = line i ppf "\n"; pattern (i+1) ppf p; expression (i+1) ppf e; and string_x_expression i ppf (s, e) = line i ppf " \"%s\"\n" s.txt; expression (i+1) ppf e; and longident_x_expression i ppf (li, e) = line i ppf "%a\n" fmt_longident li; expression (i+1) ppf e; and label_x_expression i ppf (l,e) = line i ppf " Add to the run-time search path for shared libraries" ;; let mk_dtypes f = "-dtypes", Arg.Unit f, " (deprecated) same as -annot" ;; let mk_for_pack_byt () = "-for-pack", Arg.String ignore, " Ignored (for compatibility with ocamlopt)" ;; let mk_for_pack_opt f = "-for-pack", Arg.String f, " Generate code that can later be `packed' with\n\ \ ocamlopt -pack -o .cmx" ;; let mk_g_byt f = "-g", Arg.Unit f, " Save debugging information" ;; let mk_g_opt f = "-g", Arg.Unit f, " Record debugging information for exception backtrace" ;; let mk_i f = "-i", Arg.Unit f, " Print inferred interface" ;; let mk_I f = "-I", Arg.String f, " Add to the list of include directories" ;; let mk_impl f = "-impl", Arg.String f, " Compile as a .ml file" ;; let mk_init f = "-init", Arg.String f, " Load instead of default init file" ;; let mk_inline f = "-inline", Arg.Int f, " Set aggressiveness of inlining to " ;; let mk_intf f = "-intf", Arg.String f, " Compile as a .mli file" ;; let mk_intf_suffix f = "-intf-suffix", Arg.String f, " Suffix for interface files (default: .mli)" ;; let mk_intf_suffix_2 f = "-intf_suffix", Arg.String f, " (deprecated) same as -intf-suffix" ;; let mk_labels f = "-labels", Arg.Unit f, " Use commuting label mode" ;; let mk_linkall f = "-linkall", Arg.Unit f, " Link all modules, even unused ones" ;; let mk_make_runtime f = "-make-runtime", Arg.Unit f, " Build a runtime system with given C objects and libraries" ;; let mk_make_runtime_2 f = "-make_runtime", Arg.Unit f, " (deprecated) same as -make-runtime" ;; let mk_modern f = "-modern", Arg.Unit f, " (deprecated) same as -labels" ;; let mk_no_app_funct f = "-no-app-funct", Arg.Unit f, " Deactivate applicative functors" ;; let mk_noassert f = "-noassert", Arg.Unit f, " Do not compile assertion checks" ;; let mk_noautolink_byt f = "-noautolink", Arg.Unit f, " Do not automatically link C libraries specified in .cma files" ;; let mk_noautolink_opt f = "-noautolink", Arg.Unit f, " Do not automatically link C libraries specified in .cmxa files" ;; let mk_nodynlink f = "-nodynlink", Arg.Unit f, " Enable optimizations for code that will not be dynlinked" ;; let mk_nolabels f = "-nolabels", Arg.Unit f, " Ignore non-optional labels in types" ;; let mk_noprompt f = "-noprompt", Arg.Unit f, " Suppress all prompts" ;; let mk_nopromptcont f = "-nopromptcont", Arg.Unit f, " Suppress prompts for continuation lines of multi-line inputs" ;; let mk_nostdlib f = "-nostdlib", Arg.Unit f, " Do not add default directory to the list of include directories" ;; let mk_o f = "-o", Arg.String f, " Set output file name to " ;; let mk_output_obj f = "-output-obj", Arg.Unit f, " Output a C object file instead of an executable" ;; let mk_p f = "-p", Arg.Unit f, " Compile and link with profiling support for \"gprof\"\n\ \ (not supported on all platforms)" ;; let mk_pack_byt f = "-pack", Arg.Unit f, " Package the given .cmo files into one .cmo" ;; let mk_pack_opt f = "-pack", Arg.Unit f, " Package the given .cmx files into one .cmx" ;; let mk_pp f = "-pp", Arg.String f, " Pipe sources through preprocessor " ;; let mk_principal f = "-principal", Arg.Unit f, " Check principality of type inference" ;; let mk_rectypes f = "-rectypes", Arg.Unit f, " Allow arbitrary recursive types" ;; let mk_runtime_variant f = "-runtime-variant", Arg.String f, " Use the variant of the run-time system" ;; let mk_S f = "-S", Arg.Unit f, " Keep intermediate assembly file" ;; let mk_stdin f = "-stdin", Arg.Unit f, " Read script from standard input" ;; let mk_strict_sequence f = "-strict-sequence", Arg.Unit f, " Left-hand part of a sequence must have type unit" ;; let mk_shared f = "-shared", Arg.Unit f, " Produce a dynlinkable plugin" ;; let mk_thread f = "-thread", Arg.Unit f, " Generate code that supports the system threads library" ;; let mk_unsafe f = "-unsafe", Arg.Unit f, " Do not compile bounds checking on array and string access" ;; let mk_use_runtime f = "-use-runtime", Arg.String f, " Generate bytecode for the given runtime system" ;; let mk_use_runtime_2 f = "-use_runtime", Arg.String f, " (deprecated) same as -use-runtime" ;; let mk_v f = "-v", Arg.Unit f, " Print compiler version and location of standard library and exit" ;; let mk_version f = "-version", Arg.Unit f, " Print version and exit" ;; let mk_vnum f = "-vnum", Arg.Unit f, " Print version number and exit" ;; let mk_verbose f = "-verbose", Arg.Unit f, " Print calls to external commands" ;; let mk_vmthread f = "-vmthread", Arg.Unit f, " Generate code that supports the threads library with VM-level\n\ \ scheduling" ;; let mk_w f = "-w", Arg.String f, Printf.sprintf " Enable or disable warnings according to :\n\ \ + enable warnings in \n\ \ - disable warnings in \n\ \ @ enable warnings in and treat them as errors\n\ \ can be:\n\ \ a single warning number\n\ \ .. a range of consecutive warning numbers\n\ \ a predefined set\n\ \ default setting is %S" Warnings.defaults_w ;; let mk_warn_error f = "-warn-error", Arg.String f, Printf.sprintf " Enable or disable error status for warnings according\n\ \ to . See option -w for the syntax of .\n\ \ Default setting is %S" Warnings.defaults_warn_error ;; let mk_warn_help f = "-warn-help", Arg.Unit f, " Show description of warning numbers" ;; let mk_where f = "-where", Arg.Unit f, " Print location of standard library and exit" ;; let mk_nopervasives f = "-nopervasives", Arg.Unit f, " (undocumented)" ;; let mk_use_prims f = "-use-prims", Arg.String f, " (undocumented)" ;; let mk_dparsetree f = "-dparsetree", Arg.Unit f, " (undocumented)" ;; let mk_drawlambda f = "-drawlambda", Arg.Unit f, " (undocumented)" ;; let mk_dlambda f = "-dlambda", Arg.Unit f, " (undocumented)" ;; let mk_dclambda f = "-dclambda", Arg.Unit f, " (undocumented)" ;; let mk_dinstr f = "-dinstr", Arg.Unit f, " (undocumented)" ;; let mk_dcmm f = "-dcmm", Arg.Unit f, " (undocumented)" ;; let mk_dsel f = "-dsel", Arg.Unit f, " (undocumented)" ;; let mk_dcombine f = "-dcombine", Arg.Unit f, " (undocumented)" ;; let mk_dlive f = "-dlive", Arg.Unit f, " (undocumented)" ;; let mk_dspill f = "-dspill", Arg.Unit f, " (undocumented)" ;; let mk_dsplit f = "-dsplit", Arg.Unit f, " (undocumented)" ;; let mk_dinterf f = "-dinterf", Arg.Unit f, " (undocumented)" ;; let mk_dprefer f = "-dprefer", Arg.Unit f, " (undocumented)" ;; let mk_dalloc f = "-dalloc", Arg.Unit f, " (undocumented)" ;; let mk_dreload f = "-dreload", Arg.Unit f, " (undocumented)" ;; let mk_dscheduling f = "-dscheduling", Arg.Unit f, " (undocumented)" ;; let mk_dlinear f = "-dlinear", Arg.Unit f, " (undocumented)" ;; let mk_dstartup f = "-dstartup", Arg.Unit f, " (undocumented)" ;; let mk__ f = "-", Arg.String f, " Treat as a file name (even if it starts with `-')" ;; module type Bytecomp_options = sig val _a : unit -> unit val _absname : unit -> unit val _annot : unit -> unit val _binannot : unit -> unit val _c : unit -> unit val _cc : string -> unit val _cclib : string -> unit val _ccopt : string -> unit val _config : unit -> unit val _custom : unit -> unit val _dllib : string -> unit val _dllpath : string -> unit val _g : unit -> unit val _i : unit -> unit val _I : string -> unit val _impl : string -> unit val _intf : string -> unit val _intf_suffix : string -> unit val _labels : unit -> unit val _linkall : unit -> unit val _make_runtime : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _noautolink : unit -> unit val _nolabels : unit -> unit val _nostdlib : unit -> unit val _o : string -> unit val _output_obj : unit -> unit val _pack : unit -> unit val _pp : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit val _strict_sequence : unit -> unit val _thread : unit -> unit val _vmthread : unit -> unit val _unsafe : unit -> unit val _use_runtime : string -> unit val _v : unit -> unit val _version : unit -> unit val _vnum : unit -> unit val _verbose : unit -> unit val _w : string -> unit val _warn_error : string -> unit val _warn_help : unit -> unit val _where : unit -> unit val _nopervasives : unit -> unit val _use_prims : string -> unit val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dinstr : unit -> unit val anonymous : string -> unit end;; module type Bytetop_options = sig val _absname : unit -> unit val _I : string -> unit val _init : string -> unit val _labels : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _nolabels : unit -> unit val _noprompt : unit -> unit val _nopromptcont : unit -> unit val _nostdlib : unit -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _stdin: unit -> unit val _strict_sequence : unit -> unit val _unsafe : unit -> unit val _version : unit -> unit val _vnum : unit -> unit val _w : string -> unit val _warn_error : string -> unit val _warn_help : unit -> unit val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dinstr : unit -> unit val anonymous : string -> unit end;; module type Optcomp_options = sig val _a : unit -> unit val _absname : unit -> unit val _annot : unit -> unit val _binannot : unit -> unit val _c : unit -> unit val _cc : string -> unit val _cclib : string -> unit val _ccopt : string -> unit val _compact : unit -> unit val _config : unit -> unit val _for_pack : string -> unit val _g : unit -> unit val _i : unit -> unit val _I : string -> unit val _impl : string -> unit val _inline : int -> unit val _intf : string -> unit val _intf_suffix : string -> unit val _labels : unit -> unit val _linkall : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _noautolink : unit -> unit val _nodynlink : unit -> unit val _nolabels : unit -> unit val _nostdlib : unit -> unit val _o : string -> unit val _output_obj : unit -> unit val _p : unit -> unit val _pack : unit -> unit val _pp : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit val _S : unit -> unit val _strict_sequence : unit -> unit val _shared : unit -> unit val _thread : unit -> unit val _unsafe : unit -> unit val _v : unit -> unit val _version : unit -> unit val _vnum : unit -> unit val _verbose : unit -> unit val _w : string -> unit val _warn_error : string -> unit val _warn_help : unit -> unit val _where : unit -> unit val _nopervasives : unit -> unit val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit val _dlive : unit -> unit val _dspill : unit -> unit val _dsplit : unit -> unit val _dinterf : unit -> unit val _dprefer : unit -> unit val _dalloc : unit -> unit val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit end;; module type Opttop_options = sig val _absname : unit -> unit val _compact : unit -> unit val _I : string -> unit val _init : string -> unit val _inline : int -> unit val _labels : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _nolabels : unit -> unit val _noprompt : unit -> unit val _nopromptcont : unit -> unit val _nostdlib : unit -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _S : unit -> unit val _stdin : unit -> unit val _strict_sequence : unit -> unit val _unsafe : unit -> unit val _version : unit -> unit val _vnum : unit -> unit val _w : string -> unit val _warn_error : string -> unit val _warn_help : unit -> unit val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit val _dlive : unit -> unit val _dspill : unit -> unit val _dsplit : unit -> unit val _dinterf : unit -> unit val _dprefer : unit -> unit val _dalloc : unit -> unit val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit end;; module type Arg_list = sig val list : (string * Arg.spec * string) list end;; module Make_bytecomp_options (F : Bytecomp_options) = struct let list = [ mk_a F._a; mk_absname F._absname; mk_annot F._annot; mk_binannot F._binannot; mk_c F._c; mk_cc F._cc; mk_cclib F._cclib; mk_ccopt F._ccopt; mk_config F._config; mk_custom F._custom; mk_dllib F._dllib; mk_dllpath F._dllpath; mk_dtypes F._annot; mk_for_pack_byt (); mk_g_byt F._g; mk_i F._i; mk_I F._I; mk_impl F._impl; mk_intf F._intf; mk_intf_suffix F._intf_suffix; mk_intf_suffix_2 F._intf_suffix; mk_labels F._labels; mk_linkall F._linkall; mk_make_runtime F._make_runtime; mk_make_runtime_2 F._make_runtime; mk_modern F._labels; mk_no_app_funct F._no_app_funct; mk_noassert F._noassert; mk_noautolink_byt F._noautolink; mk_nolabels F._nolabels; mk_nostdlib F._nostdlib; mk_o F._o; mk_output_obj F._output_obj; mk_pack_byt F._pack; mk_pp F._pp; mk_principal F._principal; mk_rectypes F._rectypes; mk_runtime_variant F._runtime_variant; mk_strict_sequence F._strict_sequence; mk_thread F._thread; mk_unsafe F._unsafe; mk_use_runtime F._use_runtime; mk_use_runtime_2 F._use_runtime; mk_v F._v; mk_version F._version; mk_vnum F._vnum; mk_verbose F._verbose; mk_vmthread F._vmthread; mk_w F._w; mk_warn_error F._warn_error; mk_warn_help F._warn_help; mk_where F._where; mk_nopervasives F._nopervasives; mk_use_prims F._use_prims; mk_dparsetree F._dparsetree; mk_drawlambda F._drawlambda; mk_dlambda F._dlambda; mk_dinstr F._dinstr; mk__ F.anonymous; ] end;; module Make_bytetop_options (F : Bytetop_options) = struct let list = [ mk_absname F._absname; mk_I F._I; mk_init F._init; mk_labels F._labels; mk_no_app_funct F._no_app_funct; mk_noassert F._noassert; mk_nolabels F._nolabels; mk_noprompt F._noprompt; mk_nopromptcont F._nopromptcont; mk_nostdlib F._nostdlib; mk_principal F._principal; mk_rectypes F._rectypes; mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; mk_unsafe F._unsafe; mk_version F._version; mk_vnum F._vnum; mk_w F._w; mk_warn_error F._warn_error; mk_warn_help F._warn_help; mk_dparsetree F._dparsetree; mk_drawlambda F._drawlambda; mk_dlambda F._dlambda; mk_dinstr F._dinstr; mk__ F.anonymous; ] end;; module Make_optcomp_options (F : Optcomp_options) = struct let list = [ mk_a F._a; mk_absname F._absname; mk_annot F._annot; mk_binannot F._binannot; mk_c F._c; mk_cc F._cc; mk_cclib F._cclib; mk_ccopt F._ccopt; mk_compact F._compact; mk_config F._config; mk_dtypes F._annot; mk_for_pack_opt F._for_pack; mk_g_opt F._g; mk_i F._i; mk_I F._I; mk_impl F._impl; mk_inline F._inline; mk_intf F._intf; mk_intf_suffix F._intf_suffix; mk_labels F._labels; mk_linkall F._linkall; mk_no_app_funct F._no_app_funct; mk_noassert F._noassert; mk_noautolink_opt F._noautolink; mk_nodynlink F._nodynlink; mk_nolabels F._nolabels; mk_nostdlib F._nostdlib; mk_o F._o; mk_output_obj F._output_obj; mk_p F._p; mk_pack_opt F._pack; mk_pp F._pp; mk_principal F._principal; mk_rectypes F._rectypes; mk_runtime_variant F._runtime_variant; mk_S F._S; mk_strict_sequence F._strict_sequence; mk_shared F._shared; mk_thread F._thread; mk_unsafe F._unsafe; mk_v F._v; mk_version F._version; mk_vnum F._vnum; mk_verbose F._verbose; mk_w F._w; mk_warn_error F._warn_error; mk_warn_help F._warn_help; mk_where F._where; mk_nopervasives F._nopervasives; mk_dparsetree F._dparsetree; mk_drawlambda F._drawlambda; mk_dlambda F._dlambda; mk_dclambda F._dclambda; mk_dcmm F._dcmm; mk_dsel F._dsel; mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; mk_dsplit F._dsplit; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; mk_dreload F._dreload; mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; mk_dstartup F._dstartup; mk__ F.anonymous; ] end;; module Make_opttop_options (F : Opttop_options) = struct let list = [ mk_absname F._absname; mk_compact F._compact; mk_I F._I; mk_init F._init; mk_inline F._inline; mk_labels F._labels; mk_no_app_funct F._no_app_funct; mk_noassert F._noassert; mk_nolabels F._nolabels; mk_noprompt F._noprompt; mk_nopromptcont F._nopromptcont; mk_nostdlib F._nostdlib; mk_principal F._principal; mk_rectypes F._rectypes; mk_S F._S; mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; mk_unsafe F._unsafe; mk_version F._version; mk_vnum F._vnum; mk_w F._w; mk_warn_error F._warn_error; mk_warn_help F._warn_help; mk_dparsetree F._dparsetree; mk_drawlambda F._drawlambda; mk_dclambda F._dclambda; mk_dcmm F._dcmm; mk_dsel F._dsel; mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; mk_dsplit F._dsplit; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; mk_dreload F._dreload; mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; mk_dstartup F._dstartup; mk__ F.anonymous; ] end;; mingw-ocaml/ocaml/driver/pparse.mli0000644000175000017500000000203412124403241016745 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Format exception Error val preprocess : string -> string val remove_preprocessed : string -> unit val remove_preprocessed_if_ast : string -> unit val file : formatter -> string -> (Lexing.lexbuf -> 'a) -> string -> 'a mingw-ocaml/ocaml/driver/optmain.mli0000644000175000017500000000161412124403241017125 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocquencourt *) (* *) (* Copyright 2000 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* this "empty" file is here to speed up garbage collection in ocamlopt.opt *) mingw-ocaml/ocaml/driver/compile.mli0000644000175000017500000000206012124403241017102 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Compile a .ml or .mli file *) open Format val interface: formatter -> string -> string -> unit val implementation: formatter -> string -> string -> unit val c_file: string -> unit val initial_env: unit -> Env.t val init_path: unit -> unit mingw-ocaml/ocaml/driver/optcompile.mli0000644000175000017500000000206012124403241017625 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Compile a .ml or .mli file *) open Format val interface: formatter -> string -> string -> unit val implementation: formatter -> string -> string -> unit val c_file: string -> unit val initial_env: unit -> Env.t val init_path: unit -> unit mingw-ocaml/ocaml/driver/ocamlcomp.sh.in0000644000175000017500000000160012124403241017661 0ustar tootstoots#!/bin/sh ######################################################################### # # # OCaml # # # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 2002 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### topdir=`dirname $0` exec @compiler@ -nostdlib -I $topdir/stdlib "$@" mingw-ocaml/ocaml/driver/main_args.mli0000644000175000017500000001557612124403241017432 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1998 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) module type Bytecomp_options = sig val _a : unit -> unit val _absname : unit -> unit val _annot : unit -> unit val _binannot : unit -> unit val _c : unit -> unit val _cc : string -> unit val _cclib : string -> unit val _ccopt : string -> unit val _config : unit -> unit val _custom : unit -> unit val _dllib : string -> unit val _dllpath : string -> unit val _g : unit -> unit val _i : unit -> unit val _I : string -> unit val _impl : string -> unit val _intf : string -> unit val _intf_suffix : string -> unit val _labels : unit -> unit val _linkall : unit -> unit val _make_runtime : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _noautolink : unit -> unit val _nolabels : unit -> unit val _nostdlib : unit -> unit val _o : string -> unit val _output_obj : unit -> unit val _pack : unit -> unit val _pp : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit val _strict_sequence : unit -> unit val _thread : unit -> unit val _vmthread : unit -> unit val _unsafe : unit -> unit val _use_runtime : string -> unit val _v : unit -> unit val _version : unit -> unit val _vnum : unit -> unit val _verbose : unit -> unit val _w : string -> unit val _warn_error : string -> unit val _warn_help : unit -> unit val _where : unit -> unit val _nopervasives : unit -> unit val _use_prims : string -> unit val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dinstr : unit -> unit val anonymous : string -> unit end ;; module type Bytetop_options = sig val _absname : unit -> unit val _I : string -> unit val _init : string -> unit val _labels : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _nolabels : unit -> unit val _noprompt : unit -> unit val _nopromptcont : unit -> unit val _nostdlib : unit -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _stdin : unit -> unit val _strict_sequence : unit -> unit val _unsafe : unit -> unit val _version : unit -> unit val _vnum : unit -> unit val _w : string -> unit val _warn_error : string -> unit val _warn_help : unit -> unit val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dinstr : unit -> unit val anonymous : string -> unit end;; module type Optcomp_options = sig val _a : unit -> unit val _absname : unit -> unit val _annot : unit -> unit val _binannot : unit -> unit val _c : unit -> unit val _cc : string -> unit val _cclib : string -> unit val _ccopt : string -> unit val _compact : unit -> unit val _config : unit -> unit val _for_pack : string -> unit val _g : unit -> unit val _i : unit -> unit val _I : string -> unit val _impl : string -> unit val _inline : int -> unit val _intf : string -> unit val _intf_suffix : string -> unit val _labels : unit -> unit val _linkall : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _noautolink : unit -> unit val _nodynlink : unit -> unit val _nolabels : unit -> unit val _nostdlib : unit -> unit val _o : string -> unit val _output_obj : unit -> unit val _p : unit -> unit val _pack : unit -> unit val _pp : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit val _S : unit -> unit val _strict_sequence : unit -> unit val _shared : unit -> unit val _thread : unit -> unit val _unsafe : unit -> unit val _v : unit -> unit val _version : unit -> unit val _vnum : unit -> unit val _verbose : unit -> unit val _w : string -> unit val _warn_error : string -> unit val _warn_help : unit -> unit val _where : unit -> unit val _nopervasives : unit -> unit val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit val _dlive : unit -> unit val _dspill : unit -> unit val _dsplit : unit -> unit val _dinterf : unit -> unit val _dprefer : unit -> unit val _dalloc : unit -> unit val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit end;; module type Opttop_options = sig val _absname : unit -> unit val _compact : unit -> unit val _I : string -> unit val _init : string -> unit val _inline : int -> unit val _labels : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit val _nolabels : unit -> unit val _noprompt : unit -> unit val _nopromptcont : unit -> unit val _nostdlib : unit -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _S : unit -> unit val _stdin : unit -> unit val _strict_sequence : unit -> unit val _unsafe : unit -> unit val _version : unit -> unit val _vnum : unit -> unit val _w : string -> unit val _warn_error : string -> unit val _warn_help : unit -> unit val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit val _dlive : unit -> unit val _dspill : unit -> unit val _dsplit : unit -> unit val _dinterf : unit -> unit val _dprefer : unit -> unit val _dalloc : unit -> unit val _dreload : unit -> unit val _dscheduling : unit -> unit val _dlinear : unit -> unit val _dstartup : unit -> unit val anonymous : string -> unit end;; module type Arg_list = sig val list : (string * Arg.spec * string) list end;; module Make_bytecomp_options (F : Bytecomp_options) : Arg_list;; module Make_bytetop_options (F : Bytetop_options) : Arg_list;; module Make_optcomp_options (F : Optcomp_options) : Arg_list;; module Make_opttop_options (F : Opttop_options) : Arg_list;; mingw-ocaml/ocaml/driver/errors.ml0000644000175000017500000000651212124403241016623 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* WARNING: if you change something in this file, you must look at opterrors.ml and ocamldoc/odoc_analyse.ml to see if you need to make the same changes there. *) open Format (* Report an error *) let report_error ppf exn = let report ppf = function | Lexer.Error(err, loc) -> Location.print_error ppf loc; Lexer.report_error ppf err | Syntaxerr.Error err -> Syntaxerr.report_error ppf err | Pparse.Error -> Location.print_error_cur_file ppf; fprintf ppf "Preprocessor error" | Env.Error err -> Location.print_error_cur_file ppf; Env.report_error ppf err | Cmi_format.Error err -> Location.print_error_cur_file ppf; Cmi_format.report_error ppf err | Ctype.Tags(l, l') -> Location.print_error_cur_file ppf; fprintf ppf "In this program,@ variant constructors@ `%s and `%s@ \ have the same hash value.@ Change one of them." l l' | Typecore.Error(loc, err) -> Location.print_error ppf loc; Typecore.report_error ppf err | Typetexp.Error(loc, err) -> Location.print_error ppf loc; Typetexp.report_error ppf err | Typedecl.Error(loc, err) -> Location.print_error ppf loc; Typedecl.report_error ppf err | Typeclass.Error(loc, err) -> Location.print_error ppf loc; Typeclass.report_error ppf err | Includemod.Error err -> Location.print_error_cur_file ppf; Includemod.report_error ppf err | Typemod.Error(loc, err) -> Location.print_error ppf loc; Typemod.report_error ppf err | Translcore.Error(loc, err) -> Location.print_error ppf loc; Translcore.report_error ppf err | Translclass.Error(loc, err) -> Location.print_error ppf loc; Translclass.report_error ppf err | Translmod.Error(loc, err) -> Location.print_error ppf loc; Translmod.report_error ppf err | Symtable.Error code -> Location.print_error_cur_file ppf; Symtable.report_error ppf code | Bytelink.Error code -> Location.print_error_cur_file ppf; Bytelink.report_error ppf code | Bytelibrarian.Error code -> Location.print_error_cur_file ppf; Bytelibrarian.report_error ppf code | Bytepackager.Error code -> Location.print_error_cur_file ppf; Bytepackager.report_error ppf code | Sys_error msg -> Location.print_error_cur_file ppf; fprintf ppf "I/O error: %s" msg | Warnings.Errors (n) -> Location.print_error_cur_file ppf; fprintf ppf "Error-enabled warnings (%d occurrences)" n | x -> fprintf ppf "@]"; raise x in fprintf ppf "@[%a@]@." report exn mingw-ocaml/ocaml/driver/pparse.ml0000644000175000017500000000522112124403241016575 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Format exception Error (* Optionally preprocess a source file *) let preprocess sourcefile = match !Clflags.preprocessor with None -> sourcefile | Some pp -> let tmpfile = Filename.temp_file "ocamlpp" "" in let comm = Printf.sprintf "%s %s > %s" pp (Filename.quote sourcefile) tmpfile in if Ccomp.command comm <> 0 then begin Misc.remove_file tmpfile; raise Error; end; tmpfile let remove_preprocessed inputfile = match !Clflags.preprocessor with None -> () | Some _ -> Misc.remove_file inputfile let remove_preprocessed_if_ast inputfile = match !Clflags.preprocessor with None -> () | Some _ -> if inputfile <> !Location.input_name then Misc.remove_file inputfile (* Parse a file or get a dumped syntax tree in it *) exception Outdated_version let file ppf inputfile parse_fun ast_magic = let ic = open_in_bin inputfile in let is_ast_file = try let buffer = Misc.input_bytes ic (String.length ast_magic) in if buffer = ast_magic then true else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then raise Outdated_version else false with Outdated_version -> Misc.fatal_error "OCaml and preprocessor have incompatible versions" | _ -> false in let ast = try if is_ast_file then begin if !Clflags.fast then fprintf ppf "@[Warning: %s@]@." "option -unsafe used with a preprocessor returning a syntax tree"; Location.input_name := input_value ic; input_value ic end else begin seek_in ic 0; Location.input_name := inputfile; let lexbuf = Lexing.from_channel ic in Location.init lexbuf inputfile; parse_fun lexbuf end with x -> close_in ic; raise x in close_in ic; ast mingw-ocaml/ocaml/Changes0000644000175000017500000041635112124403241014763 0ustar tootstootsOCaml 4.00.1: ------------- Bug fixes: - PR#4019: better documentation of Str.matched_string - PR#5111: ocamldoc, heading tags inside spans tags is illegal in html - PR#5278: better error message when typing "make" - PR#5468: ocamlbuild should preserve order of parametric tags - PR#5563: harden Unix.select against file descriptors above FD_SETSIZE - PR#5690: "ocamldoc ... -text README" raises exception - PR#5700: crash with native-code stack backtraces under MacOS 10.8 x86-64 - PR#5707: AMD64 code generator: do not use r10 and r11 for parameter passing, as these registers can be destroyed by the dynamic loader - PR#5712: some documentation problems - PR#5715: configuring with -no-shared-libs breaks under cygwin - PR#5718: false positive on 'unused constructor' warning - PR#5719: ocamlyacc generates code that is not warning 33-compliant - PR#5725: ocamldoc output of preformatted code - PR#5727: emacs caml-mode indents shebang line in toplevel scripts - PR#5729: tools/untypeast.ml creates unary Pexp_tuple - PR#5731: instruction scheduling forgot to account for destroyed registers - PR#5735: %apply and %revapply not first class citizens - PR#5738: first class module patterns not handled by ocamldep - PR#5742: missing bound checks in Array.sub - PR#5744: ocamldoc error on "val virtual" - PR#5757: GC compaction bug (crash) - PR#5758: Compiler bug when matching on floats - PR#5761: Incorrect bigarray custom block size OCaml 4.00.0: ------------- (Changes that can break existing programs are marked with a "*") - The official name of the language is now OCaml. Language features: - Added Generalized Algebraic Data Types (GADTs) to the language. See chapter "Language extensions" of the reference manual for documentation. - It is now possible to omit type annotations when packing and unpacking first-class modules. The type-checker attempts to infer it from the context. Using the -principal option guarantees forward compatibility. - New (module M) and (module M : S) syntax in patterns, for immediate unpacking of a first-class module. Compilers: - Revised simplification of let-alias (PR#5205, PR#5288) - Better reporting of compiler version mismatch in .cmi files * Warning 28 is now enabled by default. - New option -absname to use absolute paths in error messages - Optimize away compile-time beta-redexes, e.g. (fun x y -> e) a b. - Added option -bin-annot to dump the AST with type annotations. - Added lots of new warnings about unused variables, opens, fields, constructors, etc. * New meaning for warning 7: it is now triggered when a method is overridden with the "method" keyword. Use "method!" to avoid the warning. Native-code compiler: - Optimized handling of partially-applied functions (PR#5287) - Small improvements in code generated for array bounds checks (PR#5345, PR#5360). * New ARM backend (PR#5433): . Supports both Linux/EABI (armel) and Linux/EABI+VFPv3 (armhf). . Added support for the Thumb-2 instruction set with average code size savings of 28%. . Added support for position-independent code, natdynlink, profiling and exception backtraces. - Generation of CFI information, and filename/line number debugging (with -g) annotations, enabling in particular precise stack backtraces with the gdb debugger. Currently supported for x86 32-bits and 64-bits only. (PR#5487) - New tool: ocamloptp, the equivalent of ocamlcp for the native-code compiler. OCamldoc: - PR#5645: ocamldoc doesn't handle module/type substitution in signatures - PR#5544: improve HTML output (less formatting in html code) - PR#5522: allow refering to record fields and variant constructors - fix PR#5419 (error message in french) - fix PR#5535 (no cross ref to class after dump+load) * Use first class modules for custom generators, to be able to load various plugins incrementally adding features to the current generator * PR#5507: Use Location.t structures for locations. - fix: do not keep code when not told to keep code. Standard library: - Added float functions "hypot" and "copysign" (PR#3806, PR#4752, PR#5246) * Arg: options with empty doc strings are no longer included in the usage string (PR#5437) - Array: faster implementations of "blit", "copy", "sub", "append" and "concat" (PR#2395, PR#2787, PR#4591) * Hashtbl: . Statistically-better generic hash function based on Murmur 3 (PR#5225) . Fixed behavior of generic hash function w.r.t. -0.0 and NaN (PR#5222) . Added optional "random" parameter to Hashtbl.create to randomize collision patterns and improve security (PR#5572, CVE-2012-0839) . Added "randomize" function and "R" parameter to OCAMLRUNPARAM to turn randomization on by default (PR#5572, CVE-2012-0839) . Added new functorial interface "MakeSeeded" to support randomization with user-provided seeded hash functions. . Install new header for C code. - Filename: on-demand (lazy) initialization of the PRNG used by "temp_file". - Marshal: marshalling of function values (flag Marshal.Closures) now also works for functions that come from dynamically-loaded modules (PR#5215) - Random: . More random initialization (Random.self_init()), using /dev/urandom when available (e.g. Linux, FreeBSD, MacOS X, Solaris) * Faster implementation of Random.float (changes the generated sequences) - Scanf: new function "unescaped" (PR#3888) - Set and Map: more efficient implementation of "filter" and "partition" - String: new function "map" (PR#3888) Installation procedure: - Compiler internals are now installed in `ocamlc -where`/compiler-libs. The files available there include the .cmi interfaces for all compiler modules, plus the following libraries: ocamlcommon.cma/.cmxa modules common to ocamlc, ocamlopt, ocaml ocamlbytecomp.cma/.cmxa modules for ocamlc and ocaml ocamloptcomp.cma/.cmxa modules specific to ocamlopt ocamltoplevel.cma modules specific to ocaml (PR#1804, PR#4653, frequently-asked feature). * Some .cmi for toplevel internals that used to be installed in `ocamlc -where` are now to be found in `ocamlc -where`/compiler-libs. Add "-I +compiler-libs" where needed. * toplevellib.cma is no longer installed because subsumed by ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma - Added a configuration option (-with-debug-runtime) to compile and install a debug version of the runtime system, and a compiler option (-runtime-variant) to select the debug runtime. Bug Fixes: - PR#1643: functions of the Lazy module whose named started with 'lazy_' have been deprecated, and new ones without the prefix added - PR#3571: in Bigarrays, call msync() before unmapping to commit changes - PR#4292: various documentation problems - PR#4511, PR#4838: local modules remove polymorphism * PR#4549: Filename.dirname is not handling multiple / on Unix - PR#4688: (Windows) special floating-point values aren't converted to strings correctly - PR#4697: Unix.putenv leaks memory on failure - PR#4705: camlp4 does not allow to define types with `True or `False - PR#4746: wrong detection of stack overflows in native code under Linux - PR#4869: rare collisions between assembly labels for code and data - PR#4880: "assert" constructs now show up in the exception stack backtrace - PR#4892: Array.set could raise "out of bounds" before evaluating 3rd arg - PR#4937: camlp4 incorrectly handles optional arguments if 'option' is redefined - PR#5024: camlp4r now handles underscores in irrefutable pattern matching of records - PR#5064, PR#5485: try to ensure that 4K words of stack are available before calling into C functions, raising a Stack_overflow exception otherwise. This reduces (but does not eliminate) the risk of segmentation faults due to stack overflow in C code - PR#5073: wrong location for 'Unbound record field label' error - PR#5084: sub-sub-module building fails for native code compilation - PR#5120: fix the output function of Camlp4.Debug.formatter - PR#5131: compilation of custom runtime with g++ generates lots of warnings - PR#5137: caml-types-explore does not work - PR#5159: better documentation of type Lexing.position - PR#5171: Map.join does more comparisons than needed - PR#5176: emacs mode: stack overflow in regexp matcher - PR#5179: port OCaml to mingw-w64 - PR#5211: updated Genlex documentation to state that camlp4 is mandatory for 'parser' keyword and associated notation - PR#5214: ocamlfind plugin invokes 'cut' utility - PR#5218: use $(MAKE) instead of "make" in Makefiles - PR#5224: confusing error message in non-regular type definition - PR#5231: camlp4: fix parsing of <:str_item< type t = $x$ >> - PR#5233: finaliser on weak array gives dangling pointers (crash) - PR#5238, PR#5277: Sys_error when getting error location - PR#5261, PR#5497: Ocaml source-code examples are not "copy-paste-able" * PR#5279: executable name is not initialized properly in caml_startup_code - PR#5290: added hash functions for channels, nats, mutexes, conditions - PR#5291: undetected loop in class initialization - PR#5295: OS threads: problem with caml_c_thread_unregister() - PR#5301: camlp4r and exception equal to another one with parameters - PR#5305: prevent ocamlbuild from complaining about links to _build/ - PR#5306: comparing to Thread.self() raises exception at runtime - PR#5309: Queue.add is not thread/signal safe - PR#5310: Ratio.create_ratio/create_normalized_ratio have misleading names - PR#5311: better message for warning 23 * PR#5312: command-line arguments @reponsefile auto-expansion feature removed from the Windows OCaml runtime, to avoid conflicts with "-w @..." - PR#5313: ocamlopt -g misses optimizations - PR#5316: objinfo now shows ccopts/ccobjs/force_link when applicable - PR#5318: segfault on stack overflow when reading marshaled data - PR#5319: %r11 clobbered by Lswitch in Windows AMD64 native-code compilation - PR#5322: type abbreviations expanding to a universal type variable - PR#5325: (Windows) blocked Unix.recv in one thread blocks Unix.send in another thread - PR#5328: under Windows, Unix.select leaves sockets in non-blocking mode - PR#5330: thread tag with '.top' and '.inferred.mli' targets - PR#5331: ocamlmktop is not always a shell script - PR#5335: Unix.environment segfaults after a call to clearenv - PR#5338: sanitize.sh has windows style end-of-lines (mingw) - PR#5343: ocaml -rectypes is unsound wrt module subtyping - PR#5344: some predefined exceptions need special printing - PR#5349: Hashtbl.replace uses new key instead of reusing old key - PR#5356: ocamlbuild handling of 'predicates' for ocamlfind - PR#5364: wrong compilation of "((val m : SIG1) : SIG2)" - PR#5370: ocamldep omits filename in syntax error message - PR#5374: camlp4 creates wrong location for type definitions - PR#5380: strange sscanf input segfault - PR#5382: EOPNOTSUPP and ENOTSUPP different on exotic platforms - PR#5383: build failure in Win32/MSVC - PR#5387: camlp4: str_item and other syntactic elements with Nils are not very usable - PR#5389: compaction sometimes leaves a very large heap - PR#5393: fails to build from source on GNU/kFreeBSD because of -R link option - PR#5394: documentation for -dtypes is missing in manpage - PR#5397: Filename.temp_dir_name should be mutable - PR#5410: fix printing of class application with Camlp4 - PR#5416: (Windows) Unix.(set|clear)_close_on_exec now preserves blocking mode - PR#5435: ocamlbuild does not find .opt executables on Windows - PR#5436: update object ids on unmarshaling - PR#5442: camlp4: quotation issue with strings - PR#5453: configure doesn't find X11 under Ubuntu/MultiarchSpec - PR#5461: Double linking of bytecode modules - PR#5463: Bigarray.*.map_file fail if empty array is requested - PR#5465: increase stack size of ocamlopt.opt for windows - PR#5469: private record type generated by functor loses abbreviation - PR#5475: Wrapper script for interpreted LablTk wrongly handles command line parameters - PR#5476: bug in native code compilation of let rec on float arrays - PR#5477: use pkg-config to configure graphics on linux - PR#5481: update camlp4 magic numbers - PR#5482: remove bashism in test suite scripts - PR#5495: camlp4o dies on infix definition (or) - PR#5498: Unification with an empty object only checks the absence of the first method - PR#5503: error when ocamlbuild is passed an absolute path as build directory - PR#5509: misclassification of statically-allocated empty array that falls exactly at beginning of an otherwise unused data page. - PR#5510: ocamldep has duplicate -ml{,i}-synonym options - PR#5511: in Bigarray.reshape, unwarranted limitation on new array dimensions. - PR#5513: Int64.div causes floating point exception (ocamlopt, x86) - PR#5516: in Bigarray C stubs, use C99 flexible array types if possible - PR#5518: segfault with lazy empty array - PR#5531: Allow ocamlbuild to add ocamldoc flags through -docflag and -docflags switches - PR#5538: combining -i and -annot in ocamlc - PR#5543: in Bigarray.map_file, try to avoid using lseek() when growing file - PR#5648: (probably fixed) test failures in tests/lib-threads - PR#5551: repeated calls to find_in_path degrade performance - PR#5552: Mac OS X: unrecognized gcc option "-no-cpp-precomp" - PR#5555: add Hashtbl.reset to resize the bucket table to its initial size - PR#5560: incompatible type for tuple pattern with -principal - PR#5575: Random states are not marshallable across architectures - PR#5579: camlp4: when a plugin is loaded in the toplevel, Token.Filter.define_filter has no effect before the first syntax error - PR#5585: typo: "explicitely" - PR#5587: documentation: "allows to" is not correct English - PR#5593: remove C file when -output-obj fails - PR#5597: register names for instrtrace primitives in embedded bytecode - PR#5598: add backslash-space support in strings in ocamllex - PR#5603: wrong .file debug info generated by ocamlopt -g - PR#5604: fix permissions of files created by ocamlbuild itself - PR#5610: new unmarshaler (from PR#5318) fails to freshen object identifiers - PR#5614: add missing -linkall flag when compiling ocamldoc.opt - PR#5616: move ocamlbuild documentation to the reference manual - PR#5619: Uncaught CType.Unify exception in the compiler - PR#5620: invalid printing of type manifest (camlp4 revised syntax) - PR#5637: invalid printing of anonymous type parameters (camlp4 revised syntax) - PR#5643: issues with .cfi and .loc directives generated by ocamlopt -g - PR#5644: Stream.count broken when used with Sapp or Slazy nodes - PR#5647: Cannot use install_printer in debugger - PR#5651: printer for abstract data type (camlp4 revised syntax) - PR#5654: self pattern variable location tweak - PR#5655: ocamlbuild doesn't pass cflags when building C stubs - PR#5657: wrong error location for abbreviated record fields - PR#5659: ocamlmklib -L option breaks with MSVC - PR#5661: fixes for the test suite - PR#5668: Camlp4 produces invalid syntax for "let _ = ..." - PR#5671: initialization of compare_ext field in caml_final_custom_operations() - PR#5677: do not use "value" as identifier (genprintval.ml) - PR#5687: dynlink broken when used from "output-obj" main program (bytecode) - problem with printing of string literals in camlp4 (reported on caml-list) - emacs mode: colorization of comments and strings now works correctly - problem with forall and method (reported on caml-list on 2011-07-26) - crash when using OCAMLRUNPARAM=a=X with invalid X (reported in private) Feature wishes: - PR#352: new option "-stdin" to make ocaml read stdin as a script - PR#1164: better error message when mixing -a and .cmxa - PR#1284: documentation: remove restriction on mixed streams - PR#1496: allow configuring LIBDIR, BINDIR, and MANDIR relative to $(PREFIX) - PR#1835: add Digest.from_hex - PR#1898: toplevel: add option to suppress continuation prompts - PR#4278: configure: option to disable "graph" library - PR#4444: new String.trim function, removing leading and trailing whistespace - PR#4549: make Filename.dirname/basename POSIX compliant - PR#4830: add option -v to expunge.ml - PR#4898: new Sys.big_endian boolean for machine endianness - PR#4963, PR#5467: no extern "C" into ocaml C-stub headers - PR#5199: tests are run only for bytecode if either native support is missing, or a non-empty value is set to "BYTECODE_ONLY" Makefile variable - PR#5215: marshalling of dynlinked closure - PR#5236: new '%revapply' primitive with the semantics 'revapply x f = f x', and '%apply' with semantics 'apply f x = f x'. - PR#5255: natdynlink detection on powerpc, hurd, sparc - PR#5295: OS threads: problem with caml_c_thread_unregister() - PR#5297: compiler now checks existence of builtin primitives - PR#5329: (Windows) more efficient Unix.select if all fd's are sockets - PR#5357: warning for useless open statements - PR#5358: first class modules don't allow "with type" declarations for types in sub-modules - PR#5385: configure: emit a warning when MACOSX_DEPLOYMENT_TARGET is set - PR#5396: ocamldep: add options -sort, -all, and -one-line - PR#5397: Filename.temp_dir_name should be mutable - PR#5403: give better error message when emacs is not found in PATH - PR#5411: new directive for the toplevel: #load_rec - PR#5420: Unix.openfile share mode (Windows) - PR#5421: Unix: do not leak fds in various open_proc* functions - PR#5434: implement Unix.times in win32unix (partially) - PR#5438: new warnings for unused declarations - PR#5439: upgrade config.guess and config.sub - PR#5445 and others: better printing of types with user-provided names - PR#5454: Digest.compare is missing and md5 doc update - PR#5455: .emacs instructions, add lines to recognize ocaml scripts - PR#5456: pa_macro: replace __LOCATION__ after macro expansion; add LOCATION_OF - PR#5461: bytecode: emit warning when linking two modules with the same name - PR#5478: ocamlopt assumes ar command exists - PR#5479: Num.num_of_string may raise an exception, not reflected in the documentation. - PR#5501: increase IO_BUFFER_SIZE to 64KiB - PR#5532: improve error message when bytecode file is wrong - PR#5555: add function Hashtbl.reset to resize the bucket table to its initial size. - PR#5586: increase UNIX_BUFFER_SIZE to 64KiB - PR#5597: register names for instrtrace primitives in embedded bytecode - PR#5599: Add warn() tag in ocamlbuild to control -w compiler switch - PR#5628: add #remove_directory and Topdirs.remove_directory to remove a directory from the load path - PR#5636: in system threads library, issue with linking of pthread_atfork - PR#5666: C includes don't provide a revision number - ocamldebug: ability to inspect values that contain code pointers - ocamldebug: new 'environment' directive to set environment variables for debuggee - configure: add -no-camlp4 option Shedding weight: * Removed the obsolete native-code generators for Alpha, HPPA, IA64 and MIPS. * The "DBM" library (interface with Unix DBM key-value stores) is no longer part of this distribution. It now lives its own life at https://forge.ocamlcore.org/projects/camldbm/ * The "OCamlWin" toplevel user interface for MS Windows is no longer part of this distribution. It now lives its own life at https://forge.ocamlcore.org/projects/ocamltopwin/ Other changes: - Copy VERSION file to library directory when installing. OCaml 3.12.1: ------------- Bug fixes: - PR#4345, PR#4767: problems with camlp4 printing of float values - PR#4380: ocamlbuild should not use tput on windows - PR#4487, PR#5164: multiple 'module type of' are incompatible - PR#4552: ocamlbuild does not create symlinks when using '.itarget' file - PR#4673, PR#5144: camlp4 fails on object copy syntax - PR#4702: system threads: cleanup tick thread at exit - PR#4732: camlp4 rejects polymorphic variants using keywords from macros - PR#4778: Win32/MSVC port: rare syntax error in generated MASM assembly file - PR#4794, PR#4959: call annotations not generated by ocamlopt - PR#4820: revised syntax pretty printer crashes with 'Stack_overflow' - PR#4928: wrong printing of classes and class types by camlp4 - PR#4939: camlp4 rejects patterns of the '?x:_' form - PR#4967: ocamlbuild passes wrong switches to ocamldep through menhir - PR#4972: mkcamlp4 does not include 'dynlink.cma' - PR#5039: ocamlbuild should use '-linkpkg' only when linking programs - PR#5066: ocamldoc: add -charset option used in html generator - PR#5069: fcntl() in caml_sys_open may block, do it within blocking section - PR#5071, PR#5129, PR#5134: inconsistencies between camlp4 and camlp4* binaries - PR#5080, PR#5104: regression in type constructor handling by camlp4 - PR#5090: bad interaction between toplevel and camlp4 - PR#5095: ocamlbuild ignores some tags when building bytecode objects - PR#5100: ocamlbuild always rebuilds a 'cmxs' file - PR#5103: build and install objinfo when building with ocamlbuild - PR#5109: crash when a parser calls a lexer that calls another parser - PR#5110: invalid module name when using optional argument - PR#5115: bytecode executables produced by msvc64 port crash on 32-bit versions - PR#5117: bigarray: wrong function name without HAS_MMAP; missing include - PR#5118: Camlp4o and integer literals - PR#5122: camlp4 rejects lowercase identifiers for module types - PR#5123: shift_right_big_int returns a wrong zero - PR#5124: substitution inside a signature leads to odd printing - PR#5128: typo in 'Camlp4ListComprehension' syntax extension - PR#5136: obsolete function used in emacs mode - PR#5145: ocamldoc: missing html escapes - PR#5146: problem with spaces in multi-line string constants - PR#5149: (partial) various documentation problems - PR#5156: rare compiler crash with objects - PR#5165: ocamlbuild does not pass '-thread' option to ocamlfind - PR#5167: camlp4r loops when printing package type - PR#5172: camlp4 support for 'module type of' construct - PR#5175: in bigarray accesses, make sure bigarray expr is evaluated only once - PR#5177: Gc.compact implies Gc.full_major - PR#5182: use bytecode version of ocamldoc to generate man pages - PR#5184: under Windows, alignment issue with bigarrays mapped from files - PR#5188: double-free corruption in bytecode system threads - PR#5192: mismatch between words and bytes in interpreting max_young_wosize - PR#5202: error in documentation of atan2 - PR#5209: natdynlink incorrectly detected on BSD systems - PR#5213: ocamlbuild should pass '-rectypes' to ocamldoc when needed - PR#5217: ocamlfind plugin should add '-linkpkg' for toplevel - PR#5228: document the exceptions raised by functions in 'Filename' - PR#5229: typo in build script ('TAG_LINE' vs 'TAGLINE') - PR#5230: error in documentation of Scanf.Scanning.open_in - PR#5234: option -shared reverses order of -cclib options - PR#5237: incorrect .size directives generated for x86-32 and x86-64 - PR#5244: String.compare uses polymorphic compare_val (regression of PR#4194) - PR#5248: regression introduced while fixing PR#5118 - PR#5252: typo in docs - PR#5258: win32unix: unix fd leak under windows - PR#5269: (tentative fix) Wrong ext_ref entries in .annot files - PR#5272: caml.el doesn't recognize downto as a keyword - PR#5276: issue with ocamlc -pack and recursively-packed modules - PR#5280: alignment constraints incorrectly autodetected on MIPS 32 - PR#5281: typo in error message - PR#5308: unused variables not detected in "include (struct .. end)" - camlp4 revised syntax printing bug in the toplevel (reported on caml-list) - configure: do not define _WIN32 under cygwin - Hardened generic comparison in the case where two custom blocks are compared and have different sets of custom operations. - Hardened comparison between bigarrays in the case where the two bigarrays have different kinds. - Fixed wrong autodetection of expm1() and log1p(). - don't add .exe suffix when installing the ocamlmktop shell script - ocamldoc: minor fixes related to the display of ocamldoc options - fixed bug with huge values in OCAMLRUNPARAM - mismatch between declaration and definition of caml_major_collection_slice Feature wishes: - PR#4992: added '-ml-synonym' and '-mli-synonym' options to ocamldep - PR#5065: added '-ocamldoc' option to ocamlbuild - PR#5139: added possibility to add options to ocamlbuild - PR#5158: added access to current camlp4 parsers and printers - PR#5180: improved instruction selection for float operations on amd64 - stdlib: added a 'usage_string' function to Arg - allow with constraints to add a type equation to a datatype definition - ocamldoc: allow to merge '@before' tags like other ones - ocamlbuild: allow dependency on file "_oasis" Other changes: - Changed default minor heap size from 32k to 256k words. - Added new operation 'compare_ext' to custom blocks, called when comparing a custom block value with an unboxed integer. Objective Caml 3.12.0: ---------------------- (Changes that can break existing programs are marked with a "*" ) Language features: - Shorthand notation for records: in expressions and patterns, { lbl } stands for { lbl = lbl } and { M.lbl } for { M.lbl = lbl } - Record patterns of the form { lbl = pat; _ } to mark that not all labels are listed, purposefully. (See new warning below.) - Explicit naming of a generic type; in an expression "fun ... (type t) ... -> e", the type t is considered abstract in its scope (the arguments that follow it and the body of the function), and then replaced by a fresh type variable. In particular, the type t can be used in contexts where a type variable is not allowed (e.g. for defining an exception in a local module). - Explicit polymorphic types and polymorphic recursion. In let definitions, one can write an explicit polymorphic type just immediately the function name; the polymorphism will be enforced, and recursive calls may use the polymorphism. The syntax is the same as for polymorphic methods: "let [rec] : 'a1 ... 'an. = ..." - First-class packages modules. New kind of type expression, for packaged modules: (module PT). New kind of expression, to pack a module as a first-class value: (module MODEXPR : PT). New kind of module expression, to unpack a first-class value as a module: (val EXPR : PT). PT is a package type of the form "S" or "S with type t1 = ... and ... and type tn = ..." (S refers to a module type). - Local opening of modules in a subexpression. Syntax: "let open M in e", or "M.(e)" - In class definitions, method and instance variable override can now be made explicit, by writing "method!", "val!" or "inherit!" in place of "method", "val" and "inherit". It is an error to override an undefined member (or to use overriding inheritance when nothing get overridden). Additionally, these constructs disactivate respectively warnings 7 (method override, code 'M') and 13 (instance variable override, code 'V'). Note that, by default, warning 7 is inactive and warning 13 is active. - "Destructive" substitution in signatures. By writing " with type t := " and " with module M := " one replaces "t" and "M" inside the signature, removing their respective fields. Among other uses, this allows to merge two signatures containing identically named fields. * While fixing PR#4824, also corrected a gaping hole in the type checker, which allowed instantiating separately object parameters and instance variables in an interface. This hole was here since the beginning of ocaml, and as a result many programs using object inheritance in a non trivial way will need to be corrected. You can look at lablgtk2 for an example. Compilers and toplevel: - Warnings are now numbered and can be switched on and off individually. The old system with letters referring to sets of warnings is still supported. - New warnings: + 9 (code 'R') to signal record patterns without "; _" where some labels of the record type are not listed in the pattern. + 28 when giving a wildcard argument to a constant constructor in a pattern-matching. + 29 when an end-of-line appears unescaped in a string constant. + 30 when the same constructor or record field is defined twice in mutually-recursive type definitions. * The semantics of warning 7 (code 'M', method override) have changed (it now detects all overrides, not just repeated definitions inside the same class body), and it is now inactive by default. - Better error report in case of unbound qualified identifier: if the module is unbound this error is reported in the first place. - Added option '-strict-sequence' to force left hand part of sequence to have type unit. - Added option '-no-app-funct' to turn applicative functors off. This option can help working around mysterious type incompatibilities caused by the incomplete comparison of applicative paths F(X).t. Native-code compiler: - AMD64: shorter and slightly more efficient code generated for float comparisons. Standard library: - Format: new function ikfprintf analoguous to ifprintf with a continuation argument. * PR#4210, #4245: stricter range checking in string->integer conversion functions (int_of_string, Int32.of_string, Int64.of_string, Nativeint.of_string). The decimal string corresponding to max_int + 1 is no longer accepted. - Scanf: to prevent confusion when mixing Scanf scanning functions and direct low level input, value Scanf.stdin has been added. * Random: changed the algorithm to produce better randomness. Now passes the DieHard tests. - Map: implement functions from Set that make sense for Map. Other libraries: * Str: letters that constitute a word now include digits 0-9 and underscore _. This changes the interpretation of '\b' (word boundary) in regexps, but is more consistent with other regexp libraries. (PR#4874). Ocamlbuild: - Add support for native dynlink. New tool: - ocamlobjinfo: displays various information, esp. dependencies, for compiled OCaml files (.cmi, .cmo, .cma, .cmx, .cmxa, .cmxs, and bytecode executables). Extends and makes more official the old objinfo tool that was installed by some OCaml packages. All tools: - PR#4857: add a -vnum option to display the version number and nothing else Bug Fixes: - PR#4012: Map.map and Map.mapi do not conform to specification - PR#4478: better error messages for type definition mismatches - PR#4683: labltk script uses fixed path on windows - PR#4742: finalisation function raising an exception blocks other finalisations - PR#4775: compiler crash on crazy types (temporary fix) - PR#4824: narrowing the type of class parameters with a module specification - PR#4862: relaxed value restriction and records - PR#4884: optional arguments do not work when Some is redefined - PR#4964: parenthesized names for infix functions in annot files - PR#4970: better error message for instance variables - PR#4975: spelling mistakes - PR#4988: contravariance lost with ocamlc -i - PR#5004: problem in Buffer.add_channel with very large lengths. - PR#5008: on AMD64/MSVC port, rare float corruption during GC. - PR#5018: wrong exception raised by Dynlink.loadfile. - PR#5057: fatal typing error with local module + functor + polymorphic variant - Wrong type for Obj.add_offset. - Small problem with the representation of Int32, Int64, and Nativeint constants. - Use RTLD_LOCAL for native dynlink in private mode. Objective Caml 3.11.2: ---------------------- Bug fixes: - PR#4151: better documentation for min and max w.r.t. NaN - PR#4421: ocamlbuild uses wrong compiler for C files - PR#4710, PR#4720: ocamlbuild does not use properly configuration information - PR#4750: under some Windows installations, high start-up times for Unix lib - PR#4777: problem with scanf and CRLF - PR#4783: ocamlmklib problem under Windows - PR#4810: BSD problem with socket addresses, e.g. in Unix.getnameinfo - PR#4813: issue with parsing of float literals by the GNU assembler - PR#4816: problem with modules and private types - PR#4818: missed opportunity for type-based optimization of bigarray accesses - PR#4821: check for duplicate method names in classes - PR#4823: build problem on Mac OS X - PR#4836: spurious errors raised by Unix.single_write under Windows - PR#4841, PR#4860, PR#4930: problem with ocamlopt -output-obj under Mac OS X - PR#4847: C compiler error with ocamlc -output-obj under Win64 - PR#4856: ocamlbuild uses ocamlrun to execute a native plugin - PR#4867, PR#4760: ocamlopt -shared fails on Mac OS X 64bit - PR#4873: ocamlbuild ignores "thread" tag when building a custom toplevel - PR#4890: ocamlbuild tries to use native plugin on bytecode-only arch - PR#4896: ocamlbuild should always pass -I to tools for external libraries - PR#4900: small bug triggering automatic compaction even if max_overhead = 1M - PR#4902: bug in %.0F printf format - PR#4910: problem with format concatenation - PR#4922: ocamlbuild recompiles too many files - PR#4923: missing \xff for scanf %S - PR#4933: functors not handling private types correctly - PR#4940: problem with end-of-line in DOS text mode, tentative fix - PR#4953: problem compiling bytecode interpreter on ARM in Thumb mode. - PR#4955: compiler crash when typing recursive type expression with constraint - Module Printf: the simple conversion %F (without width indication) was not treated properly. - Makefile: problem with cygwin, flexdll, and symbolic links - Various build problems with ocamlbuild under Windows with msvc Feature wishes: - PR#9: (tentative implementation) make ocamldebug use #linenum annotations - PR#123, PR#4477: custom exception printers - PR#3456: Obj.double_field and Obj.set_double_field functions - PR#4003: destination directory can be given to Filename.[open_]temp_file - PR#4647: Buffer.blit function - PR#4685: access to Filename.dir_sep - PR#4703: support for debugging embedded applications - PR#4723: "clear_rules" function to empty the set of ocamlbuild rules - PR#4921: configure option to help cross-compilers Objective Caml 3.11.1: ---------------------- Bug fixes: - PR#4095: ocamldebug: strange behaviour of control-C - PR#4403: ocamldebug: improved handling of packed modules - PR#4650: Str.regexp_case_fold mis-handling complemented character sets [^a] - PR#4660: Scanf.format_from_string: handling of double quote - PR#4666: Unix.exec* failure in multithread programs under MacOS X and FreeBSD - PR#4667: debugger out of sync with dynlink changes - PR#4678: random "out of memory" error with systhreads - PR#4690: issue with dynamic loading under MacOS 10.5 - PR#4692: wrong error message with options -i and -pack passed to ocamlc - PR#4699: in otherlibs/dbm, fixed construction of dlldbm.so. - PR#4704: error in caml_modify_generational_global_root() - PR#4708: (ocamldoc) improved printing of infix identifiers such as "lor". - PR#4722: typo in configure script - PR#4729: documented the fact that PF_INET6 is not available on all platforms - PR#4730: incorrect typing involving abbreviation "type 'a t = 'a" - PR#4731: incorrect quoting of arguments passed to the assembler on x86-64 - PR#4735: Unix.LargeFile.fstat cannot report size over 32bits on Win32 - PR#4740: guard against possible processor error in {Int32,Int64,Nativeint}.{div,rem} - PR#4745: type inference wrongly produced non-generalizable type variables. - PR#4749: better pipe size for win32unix - PR#4756: printf: no error reported for wrong format '%_s' - PR#4758: scanf: handling of \ by format '%S' - PR#4766: incorrect simplification of some type abbreviations. - PR#4768: printf: %F does not respect width and precision specifications - PR#4769: Format.bprintf fails to flush - PR#4775: fatal error Ctype.Unify during module type-checking (temporary fix) - PR#4776: bad interaction between exceptions and classes - PR#4780: labltk build problem under Windows. - PR#4790: under Windows, map ERROR_NO_DATA Win32 error to EPIPE Unix error. - PR#4792: bug in Big_int.big_int_of_int64 on 32-bit platforms. - PR#4796: ocamlyacc: missing NUL termination of string - PR#4804: bug in Big_int.int64_of_big_int on 32-bit platforms. - PR#4805: improving compatibility with the clang C compiler - PR#4809: issue with Unix.create_process under Win32 - PR#4814: ocamlbrowser: crash when editing comments - PR#4816: module abbreviations remove 'private' type restrictions - PR#4817: Object type gives error "Unbound type parameter .." - Module Parsing: improved computation of locations when an ocamlyacc rule starts with an empty nonterminal - Type-checker: fixed wrong variance computation for private types - x86-32 code generator, MSVC port: wrong "fld" instruction generated. - ocamlbuild: incorrectly using the compile-time value of $OCAMLLIB - Makefile problem when configured with -no-shared-libs - ocamldoc: use dynamic loading in native code Other changes: - Improved wording of various error messages (contributed by Jonathan Davies, Citrix). - Support for 64-bit mode in Solaris/x86 (PR#4670). Objective Caml 3.11.0: ---------------------- (Changes that can break existing programs are marked with a "*" ) Language features: - Addition of lazy patterns: "lazy " matches suspensions whose values, after forcing, match the pattern . - Introduction of private abbreviation types "type t = private ", for abstracting the actual manifest type in type abbreviations. - Subtyping is now allowed between a private abbreviation and its definition, and between a polymorphic method and its monomorphic instance. Compilers: - The file name for a compilation unit should correspond to a valid identifier (Otherwise dynamic linking and other things can fail, and a warning is emitted.) * Revised -output-obj: the output name must now be provided; its extension must be one of .o/.obj, .so/.dll, or .c for the bytecode compiler. The compilers can now produce a shared library (with all the needed -ccopts/-ccobjs options) directly. - -dtypes renamed to -annot, records (in .annot files) which function calls are tail calls. - All compiler error messages now include a file name and location, for better interaction with Emacs' compilation mode. - Optimized compilation of "lazy e" when the argument "e" is already evaluated. - Optimized compilation of equality tests with a variant constant constructor. - The -dllib options recorded in libraries are no longer ignored when -use_runtime or -use_prims is used (unless -no_auto_link is explicitly used). - Check that at most one of -pack, -a, -shared, -c, -output-obj is given on the command line. - Optimized compilation of private types as regular manifest types (e.g. abbreviation to float, float array or record types with only float fields). Native-code compiler: - New port: Mac OS X / Intel in 64-bit mode (configure with -cc "gcc -m64"). - A new option "-shared" to produce a plugin that can be dynamically loaded with the native version of Dynlink. - A new option "-nodynlink" to enable optimizations valid only for code that is never dynlinked (no-op except for AMD64). - More aggressive unboxing of floats and boxed integers. - Can select which assembler and asm options to use at configuration time. Run-time system: - New implementation of the page table describing the heap (two-level array in 32 bits, sparse hashtable in 64 bits), fixes issues with address space randomization on 64-bit OS (PR#4448). - New "generational" API for registering global memory roots with the GC, enables faster scanning of global roots. (The functions are caml_*_generational_global_root in .) - New function "caml_raise_with_args" to raise an exception with several arguments from C. - Changes in implementation of dynamic linking of C code: under Win32, use Alain Frisch's flexdll implementation of the dlopen API; under MacOSX, use dlopen API instead of MacOSX bundle API. - Programs may now choose a first-fit allocation policy instead of the default next-fit. First-fit reduces fragmentation but is slightly slower in some cases. Standard library: - Parsing library: new function "set_trace" to programmatically turn on or off the printing of a trace during parsing. - Printexc library: new functions "print_backtrace" and "get_backtrace" to obtain a stack backtrace of the most recently raised exception. New function "record_backtrace" to turn the exception backtrace mechanism on or off from within a program. - Scanf library: fine-tuning of meta format implementation; fscanf behaviour revisited: only one input buffer is allocated for any given input channel; the %n conversion does not count a lookahead character as read. Other libraries: - Dynlink: on some platforms, the Dynlink library is now available in native code. The boolean Dynlink.is_native allows the program to know whether it has been compiled in bytecode or in native code. - Bigarrays: added "unsafe_get" and "unsafe_set" (non-bound-checking versions of "get" and "set"). - Bigarrays: removed limitation "array dimension < 2^31". - Labltk: added support for TK 8.5. - Num: added conversions between big_int and int32, nativeint, int64. More efficient implementation of Num.quo_num and Num.mod_num. - Threads: improved efficiency of mutex and condition variable operations; improved interaction with Unix.fork (PR#4577). - Unix: added getsockopt_error returning type Unix.error. Added support for TCP_NODELAY and IPV6_ONLY socket options. - Win32 Unix: "select" now supports all kinds of file descriptors. Improved emulation of "lockf" (PR#4609). Tools: - ocamldebug now supported under Windows (MSVC and Mingw ports), but without the replay feature. (Contributed by Dmitry Bely and Sylvain Le Gall at OCamlCore with support from Lexifi.) - ocamldoc: new option -no-module-constraint-filter to include functions hidden by signature constraint in documentation. - ocamlmklib and ocamldep.opt now available under Windows ports. - ocamlmklib no longer supports the -implib option. - ocamlnat: an experimental native toplevel (not built by default). Camlp4: * programs linked with camlp4lib.cma now also need dynlink.cma. Bug fixes: - Major GC and heap compaction: fixed bug involving lazy values and out-of-heap pointers. - PR#3915: updated most man pages. - PR#4261: type-checking of recursive modules - PR#4308: better stack backtraces for "spontaneous" exceptions such as Stack_overflow, Out_of_memory, etc. - PR#4338: Str.global_substitute, Str.global_replace and the Str.*split* functions are now tail-recursive. - PR#4503: fixed bug in classify_float on ARM. - PR#4512: type-checking of recursive modules - PR#4517: crash in ocamllex-generated lexers. - PR#4542: problem with return value of Unix.nice. - PR#4557: type-checking of recursive modules. - PR#4562: strange %n semantics in scanf. - PR#4564: add note "stack is not executable" to object files generated by ocamlopt (Linux/x86, Linux/AMD64). - PR#4566: bug in Ratio.approx_ratio_fix and Num.approx_num_fix. - PR#4582: clarified the documentation of functions in the String module. - PR#4583: stack overflow in "ocamlopt -g" during closure conversion pass. - PR#4585: ocamldoc and "val virtual" declarations. - PR#4587: ocamldoc and escaped @ characters. - PR#4605: Buffer.add_substitute was sometime wrong when target string had backslashes. - PR#4614: Inconsistent declaration of CamlCBCmd in LablTk library. Objective Caml 3.10.2: ---------------------- Bug fixes: - PR#1217 (partial) Typo in ocamldep man page - PR#3952 (partial) ocamlopt: allocation problems on ARM - PR#4339 (continued) ocamlopt: problems on HPPA - PR#4455 str.mli not installed under Windows - PR#4473 crash when accessing float array with polymorphic method - PR#4480 runtime would not compile without gcc extensions - PR#4481 wrong typing of exceptions with object arguments - PR#4490 typo in error message - Random crash on 32-bit when major_heap_increment >= 2^22 - Big performance bug in Weak hashtables - Small bugs in the make-package-macosx script - Bug in typing of polymorphic variants (reported on caml-list) Objective Caml 3.10.1: ---------------------- Bug fixes: - PR#3830 small bugs in docs - PR#4053 compilers: improved compilation time for large variant types - PR#4174 ocamlopt: fixed ocamlopt -nopervasives - PR#4199 otherlibs: documented a small problem in Unix.utimes - PR#4280 camlp4: parsing of identifier (^) - PR#4281 camlp4: parsing of type constraint - PR#4285 runtime: cannot compile under AIX - PR#4286 ocamlbuild: cannot compile under AIX and SunOS - PR#4288 compilers: including a functor application with side effects - PR#4295 camlp4 toplevel: synchronization after an error - PR#4300 ocamlopt: crash with backtrace and illegal array access - PR#4302 camlp4: list comprehension parsing problem - PR#4304 ocamlbuild: handle -I correctly - PR#4305 stdlib: alignment of Arg.Symbol - PR#4307 camlp4: assertion failure - PR#4312 camlp4: accept "let _ : int = 1" - PR#4313 ocamlbuild: -log and missing directories - PR#4315 camlp4: constraints in classes - PR#4316 compilers: crash with recursive modules and Lazy - PR#4318 ocamldoc: installation problem with Cygwin (tentative fix) - PR#4322 ocamlopt: stack overflow under Windows - PR#4325 compilers: wrong error message for unused var - PR#4326 otherlibs: marshal Big_int on win64 - PR#4327 ocamlbuild: make emacs look for .annot in _build directory - PR#4328 camlp4: stack overflow with nil nodes - PR#4331 camlp4: guards on fun expressions - PR#4332 camlp4: parsing of negative 32/64 bit numbers - PR#4336 compilers: unsafe recursive modules - PR#4337 (note) camlp4: invalid character escapes - PR#4339 ocamlopt: problems on HP-UX (tentative fix) - PR#4340 camlp4: wrong pretty-printing of optional arguments - PR#4348 ocamlopt: crash on Mac Intel - PR#4349 camlp4: bug in private type definitions - PR#4350 compilers: type errors with records and polymorphic variants - PR#4352 compilers: terminal recursion under Windows (tentative fix) - PR#4354 ocamlcp: mismatch with ocaml on polymorphic let - PR#4358 ocamlopt: float constants wrong on ARM - PR#4360 ocamldoc: string inside comment - PR#4365 toplevel: wrong pretty-printing of polymorphic variants - PR#4373 otherlibs: leaks in win32unix - PR#4374 otherlibs: threads module not initialized - PR#4375 configure: fails to build on bytecode-only architectures - PR#4377 runtime: finalisation of infix pointers - PR#4378 ocamlbuild: typo in plugin.ml - PR#4379 ocamlbuild: problem with plugins under Windows - PR#4382 compilers: typing of polymorphic record fields - PR#4383 compilers: including module with private type - PR#4385 stdlib: Int32/Int64.format are unsafe - PR#4386 otherlibs: wrong signal numbers with Unix.sigprocmask etc. - PR#4387 ocamlbuild: build directory not used properly - PR#4392 ocamldep: optional argument of class - PR#4394 otherlibs: infinite loops in Str - PR#4397 otherlibs: wrong size for flag arrays in win32unix - PR#4402 ocamldebug: doesn't work with -rectypes - PR#4410 ocamlbuild: problem with plugin and -build - PR#4411 otherlibs: crash with Unix.access under Windows - PR#4412 stdlib: marshalling broken on 64 bit architectures - PR#4413 ocamlopt: crash on AMD64 with out-of-bound access and reraise - PR#4417 camlp4: pretty-printing of unary minus - PR#4419 camlp4: problem with constraint in type class - PR#4426 compilers: problem with optional labels - PR#4427 camlp4: wrong pretty-printing of lists of functions - PR#4433 ocamlopt: fails to build on MacOSX 10.5 - PR#4435 compilers: crash with objects - PR#4439 fails to build on MacOSX 10.5 - PR#4441 crash when build on sparc64 linux - PR#4442 stdlib: crash with weak pointers - PR#4446 configure: fails to detect X11 on MacOSX 10.5 - PR#4448 runtime: huge page table on 64-bit architectures - PR#4450 compilers: stack overflow with recursive modules - PR#4470 compilers: type-checking of recursive modules too restrictive - PR#4472 configure: autodetection of libX11.so on Fedora x86_64 - printf: removed (partially implemented) positional specifications - polymorphic < and <= comparisons: some C compiler optimizations were causing incorrect results when arguments are incomparable New features: - made configure script work on PlayStation 3 - ARM port: brought up-to-date for Debian 4.0 (Etch) - many other small changes and bugfixes in camlp4, ocamlbuild, labltk, emacs files Objective Caml 3.10.0: ---------------------- (Changes that can break existing programs are marked with a "*" ) Language features: - Added virtual instance variables in classes "val virtual v : t" * Changed the behaviour of instance variable overriding; the new definition replaces the old one, rather than creating a new variable. New tools: - ocamlbuild: compilation manager for OCaml applications and libraries. See draft documentation at http://gallium.inria.fr/~pouillar/ * Camlp4: heavily revised implementation, new API. New ports: - MacOS X PowerPC 64 bits. - MS Windows 64 bits (x64) using the Microsoft PSDK toolchain. - MS Windows 32 bits using the Visual Studio 2005 toolchain. Compilers: - Faster type-checking of functor applications. - Referencing an interface compiled with -rectypes from a module not compiled with -rectypes is now an error. - Revised the "fragile matching" warning. Native-code compiler: - Print a stack backtrace on an uncaught exception. (Compile and link with ocamlopt -g; execute with OCAMLRUNPARAM=b.) Supported on Intel/AMD in 32 and 64 bits, PPC in 32 and 64 bits. - Stack overflow detection on MS Windows 32 bits (courtesy O. Andrieu). - Stack overflow detection on MacOS X PPC and Intel. - Intel/AMD 64 bits: generate position-independent code by default. - Fixed bug involving -for-pack and missing .cmx files (PR#4124). - Fixed bug causing duplication of literals (PR#4152). Run-time system: - C/Caml interface functions take "char const *" arguments instead of "char *" when appropriate. - Faster string comparisons (fast case if strings are ==). Standard library: - Refined typing of format strings (type format6). - Printf, Format: new function ifprintf that consumes its arguments and prints nothing (useful to print conditionally). - Scanf: new function format_from_string to convert a string to a format string; new %r conversion to accomodate user defined scanners. - Filename: improved Win32 implementation of Filename.quote. - List: List.nth now tail-recursive. - Sys: added Sys.is_directory. Some functions (e.g. Sys.command) that could incorrectly raise Sys_io_blocked now raise Sys_error as intended. - String and Char: the function ``escaped'' now escapes all the characters especially handled by the compiler's lexer (PR#4220). Other libraries: - Bigarray: mmap_file takes an optional argument specifying the start position of the data in the mapped file. - Dynlink: now defines only two modules, Dynlink and Dynlinkaux (internal), reducing risks of name conflicts with user modules. - Labltk under Win32: now uses Tcl/Tk 8.4 instead of 8.3 by default. - VM threads: improved performance of I/O operations (less polling). - Unix: new function Unix.isatty. - Unix emulation under Win32: fixed incorrect error reporting in several functions (PR#4097); better handling of channels opened on sockets (PR#4098); fixed GC bug in Unix.system (PR#4112). Documentation generator (OCamldoc): - correctly handle '?' in value names (PR#4215) - new option -hide-warnings not to print ocamldoc warnings Lexer generator (ocamllex): improved error reporting. License: fixed a typo in the "special exception" to the LGPL. Objective Caml 3.09.3: ---------------------- Bug fixes: - ocamldoc: -using modtype constraint to filter module elements displayed in doc PR#4016 - ocamldoc: error in merging of top dependencies of modules PR#4007 - ocamldoc: -dot-colors has no effect PR#3981 - ocamdloc: missing crossref in text from intro files PR#4066 - compilers: segfault with recursive modules PR#4008 - compilers: infinite loop when compiling objects PR#4018 - compilers: bad error message when signature mismatch PR#4001 - compilers: infinite loop with -rectypes PR#3999 - compilers: contravariance bug in private rows - compilers: unsafe cast with polymorphic exception PR#4002 - native compiler: bad assembly code generated for AMD64 PR#4067 - native compiler: stack alignment problems on MacOSX/i386 PR#4036 - stdlib: crash in marshalling PR#4030 - stdlib: crash when closing a channel twice PR#4039 - stdlib: memory leak in Sys.readdir PR#4093 - C interface: better definition of CAMLreturn PR#4068 - otherlibs/unix: crash in gethostbyname PR#3043 - tools: subtle problem with unset in makefile PR#4048 - camlp4: install pa_o_fast.o PR#3812 - camlp4: install more modules PR#3689 New features: - ocamldoc: name resolution in cross-referencing {!name}: if name is not found, then it is searched in the parent module/class, and in the parent of the parent, and so on until it is found. - ocamldoc: new option -short-functors to use a short form to display functors in html generator PR#4017 - ocamlprof: added "-version" option Objective Caml 3.09.2: ---------------------- Bug fixes: - Makefile: problem with "make world.opt" PR#3954 - compilers: problem compiling several modules with one command line PR#3979 - compilers,ocamldoc: error message that Emacs cannot parse - compilers: crash when printing type error PR#3968 - compilers: -dtypes wrong for monomorphic type variables PR#3894 - compilers: wrong warning on optional arguments PR#3980 - compilers: crash when wrong use of type constructor in let rec PR#3976 - compilers: better wording of "statement never returns" warning PR#3889 - runtime: inefficiency of signal handling PR#3990 - runtime: crashes with I/O in multithread programs PR#3906 - camlp4: empty file name in error messages PR#3886 - camlp4: stack overflow PR#3948 - otherlibs/labltk: ocamlbrowser ignores its command line options PR#3961 - otherlibs/unix: Unix.times wrong under Mac OS X PR#3960 - otherlibs/unix: wrong doc for execvp and execvpe PR#3973 - otherlibs/win32unix: random crash in Unix.stat PR#3998 - stdlib: update_mod not found under Windows PR#3847 - stdlib: Filename.dirname/basename wrong on Win32 PR#3933 - stdlib: incomplete documentation of Pervasives.abs PR#3967 - stdlib: Printf bugs PR#3902, PR#3955 - tools/checkstack.c: missing include - yacc: crash when given argument "-" PR#3956 New features: - ported to MacOS X on Intel PR#3985 - configure: added support for GNU Hurd PR#3991 Objective Caml 3.09.1: ---------------------- Bug fixes: - compilers: raise not_found with -principal PR#3855 - compilers: assert failure in typeclass.cml PR#3856 - compilers: assert failure in typing/ctype.ml PR#3909 - compilers: fatal error exception Ctype.Unify PR#3918 - compilers: spurious warning Y in objects PR#3868 - compilers: spurious warning Z on loop index PR#3907 - compilers: error message that emacs cannot parse - ocamlopt: problems with -for-pack/-pack PR#3825, PR#3826, PR#3919 - ocamlopt: can't produce shared libraries on x86_64 PR#3869, PR#3924 - ocamlopt: float alignment problem on SPARC PR#3944 - ocamlopt: can't compile on MIPS PR#3936 - runtime: missing dependence for ld.conf - runtime: missing dependence for .depend.nt PR#3880 - runtime: memory leak in caml_register_named_value PR#3940 - runtime: crash in Marshal.to_buffer PR#3879 - stdlib: Sys.time giving wrong results on Mac OS X PR#3850 - stdlib: Weak.get_copy causing random crashes in rare cases - stdlib, debugger, labltk: use TMPDIR if set PR#3895 - stdlib: scanf bug on int32 and nativeint PR#3932 - camlp4: mkcamlp4 option parsing problem PR#3941 - camlp4: bug in pretty-printing of lazy/assert/new - camlp4: update the unmaintained makefile for _loc name - ocamldoc: several fixes see ocamldoc/Changes.txt - otherlibs/str: bug in long sequences of alternatives PR#3783 - otherlibs/systhreads: deadlock in Windows PR#3910 - tools: update dumpobj to handle new event format PR#3873 - toplevel: activate warning Y in toplevel PR#3832 New features: - otherlibs/labltk: browser uses menu bars instead of menu buttons Objective Caml 3.09.0: ---------------------- (Changes that can break existing programs are marked with a "*" ) Language features: - Introduction of private row types, for abstracting the row in object and variant types. Type checking: - Polymorphic variants with at most one constructor [< `A of t] are no longer systematically promoted to the exact type [`A of t]. This was more confusing than useful, and created problems with private row types. Both compilers: - Added warnings 'Y' and 'Z' for local variables that are bound but never used. - Added warning for some uses non-returning functions (e.g. raise), when they are passed extra arguments, or followed by extra statements. - Pattern matching: more prudent compilation in case of guards; fixed PR#3780. - Compilation of classes: reduction in size of generated code. - Compilation of "module rec" definitions: fixed a bad interaction with structure coercion (to a more restrictive signature). Native-code compiler (ocamlopt): * Revised implementation of the -pack option (packing of several compilation units into one). The .cmx files that are to be packed with "ocamlopt -pack -o P.cmx" must be compiled with "ocamlopt -for-pack P". In exchange for this additional constraint, ocamlopt -pack is now available on all platforms (no need for binutils). * Fixed wrong evaluation order for arguments to certain inlined functions. - Modified code generation for "let rec ... and ..." to reduce compilation time (which was quadratic in the number of mutually-recursive functions). - x86 port: support tail-calls for functions with up to 21 arguments. - AMD64 port, Linux: recover from system stack overflow. - Sparc port: more portable handling of out-of-bound conditions on systems other than Solaris. Standard library: - Pervasives: faster implementation of close_in, close_out. set_binary_mode_{out,in} now working correctly under Cygwin. - Printf: better handling of partial applications of the printf functions. - Scanf: new function sscanf_format to read a format from a string. The type of the resulting format is dynamically checked and should be the type of the template format which is the second argument. - Scanf: no more spurious lookahead attempt when the end of file condition is set and a correct token has already been read and could be returned. Other libraries: - System threads library: added Thread.sigmask; fixed race condition in signal handling. - Bigarray library: fixed bug in Array3.of_array. - Unix library: use canonical signal numbers in results of Unix.wait*; hardened Unix.establish_server against EINTR errors. Run-time system: - Support platforms where sizeof(void *) = 8 and sizeof(long) = 4. - Improved and cleaned up implementation of signal handling. Replay debugger: - Improved handling of locations in source code. OCamldoc: - extensible {foo } syntax - user can give .txt files on the command line, containing ocamldoc formatted text, to be able to include bigger texts out of source files - -o option is now used by the html generator to indicate the prefix of generated index files (to avoid conflict when a Index module exists on case-insensitive file systems). Miscellaneous: - Configuration information is installed in `ocamlc -where`/Makefile.config and can be used by client Makefiles or shell scripts. Objective Caml 3.08.4: ---------------------- New features: - configure: find X11 config in some 64-bit Linux distribs - ocamldoc: (**/**) can be canceled with another (**/**) PR#3665 - graphics: added resize_window - graphics: check for invalid arguments to drawing primitives PR#3595 - ocamlbrowser: use windows subsystem on mingw Bug fixes: - ocamlopt: code generation problem on AMD64 PR#3640 - wrong code generated for some classes PR#3576 - fatal error when compiling some OO code PR#3745 - problem with comparison on constant constructors PR#3608 - camlp4: cryptic error message PR#3592 - camlp4: line numbers in multi-line antiquotations PR#3549 - camlp4: problem with make depend - camlp4: parse error with :> PR#3561 - camlp4: ident conversion problem with val/contents/contents__ - camlp4: several small parsing problems PR#3688 - ocamldebug: handling of spaces in executable file name PR#3736 - emacs-mode: problem when caml-types-buffer is deleted by user PR#3704 - ocamldoc: extra backslash in ocamldoc man page PR#3687 - ocamldoc: improvements to HTML display PR#3698 - ocamldoc: escaping of @ in info files - ocamldoc: escaping of . and \ in man pages PR#3686 - ocamldoc: better error reporting of misplaced comments - graphics: fixed .depend file PR#3558 - graphics: segfault with threads and graphics PR#3651 - nums: several bugs: PR#3718, PR#3719, others - nums: inline asm problems with gcc 4.0 PR#3604, PR#3637 - threads: problem with backtrace - unix: problem with getaddrinfo PR#3565 - stdlib: documentation of Int32.rem and Int64.rem PR#3573 - stdlib: documentation of List.rev_map2 PR#3685 - stdlib: wrong order in Map.fold PR#3607 - stdlib: documentation of maximum float array length PR#3714 - better detection of cycles when using -rectypes - missing case of module equality PR#3738 - better error messages for unbound type variables - stack overflow while printing type error message PR#3705 - assert failure when typing some classes PR#3638 - bug in type_approx - better error messages related to type variance checking - yacc: avoid name capture for idents of the Parsing module Objective Caml 3.08.3: ---------------------- New features: - support for ocamlopt -pack under Mac OS X (PR#2634, PR#3320) - ignore unknown warning options for forward and backward compatibility - runtime: export caml_compare_unordered (PR#3479) - camlp4: install argl.* files (PR#3439) - ocamldoc: add -man-section option - labltk: add the "solid" relief option (PR#3343) Bug fixes: - typing: fix unsoundness in type declaration variance inference. Type parameters which are constrained must now have an explicit variant annotation, otherwise they are invariant. This is not backward compatible, so this might break code which either uses subtyping or uses the relaxed value restriction (i.e. was not typable before 3.07) - typing: erroneous partial match warning for polymorphic variants (PR#3424) - runtime: handle the case of an empty command line (PR#3409, PR#3444) - stdlib: make Sys.executable_name an absolute path in native code (PR#3303) - runtime: fix memory leak in finalise.c - runtime: auto-trigger compaction even if gc is called manually (PR#3392) - stdlib: fix segfault in Obj.dup on zero-sized values (PR#3406) - camlp4: correct parsing of the $ identifier (PR#3310, PR#3469) - windows (MS tools): use link /lib instead of lib (PR#3333) - windows (MS tools): change default install destination - autoconf: better checking of SSE2 instructions (PR#3329, PR#3330) - graphics: make close_graph close the X display as well as the window (PR#3312) - num: fix big_int_of_string (empty string) (PR#3483) - num: fix big bug on 64-bit architecture (PR#3299) - str: better documentation of string_match and string_partial_match (PR#3395) - unix: fix file descriptor leak in Unix.accept (PR#3423) - unix: miscellaneous clean-ups - unix: fix documentation of Unix.tm (PR#3341) - graphics: fix problem when allocating lots of images under Windows (PR#3433) - compiler: fix error message with -pack when .cmi is missing (PR#3028) - cygwin: fix problem with compilation of camlheader (PR#3485) - stdlib: Filename.basename doesn't return an empty string any more (PR#3451) - stdlib: better documentation of Open_excl flag (PR#3450) - ocamlcp: accept -thread option (PR#3511) - ocamldep: handle spaces in file names (PR#3370) - compiler: remove spurious warning in pattern-matching on variants (PR#3424) - windows: better handling of InterpreterPath registry entry (PR#3334, PR#3432) Objective Caml 3.08.2: ---------------------- Bug fixes: - runtime: memory leak when unmarshalling big data structures (PR#3247) - camlp4: incorrect line numbers in errors (PR#3188) - emacs: xemacs-specific code, wrong call to "sit-for" - ocamldoc: "Lexing: empty token" (PR#3173) - unix: problem with close_process_* (PR#3191) - unix: possible coredumps (PR#3252) - stdlib: wrong order in Set.fold (PR#3161) - ocamlcp: array out of bounds in profiled programs (PR#3267) - yacc: problem with polymorphic variant types for grammar entries (PR#3033) Misc: - export for caml_format_exception (PR#3080) - clean up caml_search_exe_in_path (maybe PR#3079) - camlp4: new function "make_lexer" for new-style locations - unix: added missing #includes (PR#3088) Objective Caml 3.08.1: ---------------------- Licence: - The emacs files are now under GPL - Slightly relaxed some conditions of the QPL Bug fixes: - ld.conf now generated at compile-time instead of install-time - fixed -pack on Windows XP (PR#2935) - fixed Obj.tag (PR#2946) - added support for multiple dlopen in Darwin - run ranlib when installing camlp4 libraries (PR#2944) - link camlp4opt with -linkall (PR#2949) - camlp4 parsing of patterns now conforms to normal parsing (PR#3015) - install camlp4 *.cmx files (PR#2955) - fixed handling of linefeed in string constants in camlp4 (PR#3074) - ocamldoc: fixed display of class parameters in HTML and LaTeX (PR#2994) - ocamldoc: fixed display of link to class page in html (PR#2994) - Windows toplevel GUI: assorted fixes (including PR#2932) Misc: - added -v option to ocamllex - ocamldoc: new -intf and -impl options supported (PR#3036) Objective Caml 3.08.0: ---------------------- (Changes that can break existing programs are marked with a "*" ) Language features: - Support for immediate objects, i.e. objects defined without going through a class. (Syntax is "object end".) Type-checking: - When typing record construction and record patterns, can omit the module qualification on all labels except one. I.e. { M.l1 = ...; l2 = ... } is interpreted as { M.l1 = ...; M.l2 = ... } Both compilers: - More compact compilation of classes. - Much more efficient handling of class definitions inside functors or local modules. - Simpler representation for method tables. Objects can now be marshaled between identical programs with the flag Marshal.Closures. - Improved error messages for objects and variants. - Improved printing of inferred module signatures (toplevel and ocamlc -i). Recursion between type, class, class type and module definitions is now correctly printed. - The -pack option now accepts compiled interfaces (.cmi files) in addition to compiled implementations (.cmo or .cmx). * A compile-time error is signaled if an integer literal exceeds the range of representable integers. - Fixed code generation error for "module rec" definitions. - The combination of options -c -o sets the name of the generated .cmi / .cmo / .cmx files. Bytecode compiler: - Option -output-obj is now compatible with Dynlink and with embedded toplevels. Native-code compiler: - Division and modulus by zero correctly raise exception Division_by_zero (instead of causing a hardware trap). - Improved compilation time for the register allocation phase. - The float constant -0.0 was incorrectly treated as +0.0 on some processors. - AMD64: fixed bugs in asm glue code for GC invocation and exception raising from C. - IA64: fixed incorrect code generated for "expr mod 1". - PowerPC: minor performance tweaks for the G4 and G5 processors. Standard library: * Revised handling of NaN floats in polymorphic comparisons. The polymorphic boolean-valued comparisons (=, <, >, etc) now treat NaN as uncomparable, as specified by the IEEE standard. The 3-valued comparison (compare) treats NaN as equal to itself and smaller than all other floats. As a consequence, x == y no longer implies x = y but still implies compare x y = 0. * String-to-integer conversions now fail if the result overflows the range of integers representable in the result type. * All array and string access functions now raise Invalid_argument("index out of bounds") when a bounds check fails. In earlier releases, different exceptions were raised in bytecode and native-code. - Module Buffer: new functions Buffer.sub, Buffer.nth - Module Int32: new functions Int32.bits_of_float, Int32.float_of_bits. - Module Map: new functions is_empty, compare, equal. - Module Set: new function split. * Module Gc: in-order finalisation, new function finalise_release. Other libraries: - The Num library: complete reimplementation of the C/asm lowest layer to work around potential licensing problems. Improved speed on the PowerPC and AMD64 architectures. - The Graphics library: improved event handling under MS Windows. - The Str library: fixed bug in "split" functions with nullable regexps. - The Unix library: . Added Unix.single_write. . Added support for IPv6. . Bug fixes in Unix.closedir. . Allow thread switching on Unix.lockf. Runtime System: * Name space depollution: all global C identifiers are now prefixed with "caml" to avoid name clashes with other libraries. This includes the "external" primitives of the standard runtime. Ports: - Windows ports: many improvements in the OCamlWin toplevel application (history, save inputs to file, etc). Contributed by Christopher A. Watford. - Native-code compilation supported for HPPA/Linux. Contributed by Guy Martin. - Removed support for MacOS9. Mac OS 9 is obsolete and the port was not updated since 3.05. - Removed ocamlopt support for HPPA/Nextstep and Power/AIX. Ocamllex: - #line directives in the input file are now accepted. - Added character set concatenation operator "cset1 # cset2". Ocamlyacc: - #line directives in the input file are now accepted. Camlp4: * Support for new-style locations (line numbers, not just character numbers). - See camlp4/CHANGES and camlp4/ICHANGES for more info. Objective Caml 3.07: -------------------- Language features: - Experimental support for recursive module definitions module rec A : SIGA = StructA and B : SIGB = StructB and ... - Support for "private types", or more exactly concrete data types with private constructors or labels. These data types can be de-structured normally in pattern matchings, but values of these types cannot be constructed directly outside of their defining module. - Added integer literals of types int32, nativeint, int64 (written with an 'l', 'n' or 'L' suffix respectively). Type-checking: - Allow polymorphic generalization of covariant parts of expansive expressions. For instance, if f: unit -> 'a list, "let x = f ()" gives "x" the generalized type forall 'a. 'a list, instead of '_a list as before. - The typing of polymorphic variants in pattern matching has changed. It is intended to be more regular, sticking to the principle of "closing only the variants which would be otherwise incomplete". Two potential consequences: (1) some types may be left open which were closed before, and the resulting type might not match the interface anymore (expected to be rare); (2) in some cases an incomplete match may be generated. - Lots of bug fixes in the handling of polymorphism and recursion inside types. - Added a new "-dtypes" option to ocamlc/ocamlopt, and an emacs extension "emacs/caml-types.el". The compiler option saves inferred type information to file *.annot, and the emacs extension allows the user to look at the type of any subexpression in the source file. Works even in the case of a type error (all the types computed up to the error are available). This new feature is also supported by ocamlbrowser. - Disable "method is overridden" warning when the method was explicitly redefined as virtual beforehand (i.e. not through inheritance). Typing and semantics are unchanged. Both compilers: - Added option "-dtypes" to dump detailed type information to a file. - The "-i" option no longer generates compiled files, it only prints the inferred types. - The sources for the module named "Mod" can be placed either in Mod.ml or in mod.ml. - Compilation of "let rec" on non-functional values: tightened some checks, relaxed some other checks. - Fixed wrong code that was generated for "for i = a to max_int" or "for i = a downto min_int". - An explicit interface Mod.mli can now be provided for the module obtained by ocamlc -pack -o Mod.cmo ... or ocamlopt -pack -o Mod.cmx ... - Revised internal handling of source code locations, now handles preprocessed code better. - Pattern-matching bug on float literals fixed. - Minor improvements on pattern-matching over variants. - More efficient compilation of string comparisons and the "compare" function. - More compact code generated for arrays of constants. - Fixed GC bug with mutable record fields of type "exn". - Added warning "E" for "fragile patterns": pattern matchings that would not be flagged as partial if new constructors were added to the data type. Bytecode compiler: - Added option -vmthread to select the threads library with VM-level scheduling. The -thread option now selects the system threads library. Native-code compiler: - New port: AMD64 (Opteron). - Fixed instruction selection bug on expressions of the kind (raise Exn)(arg). - Several bug fixes in ocamlopt -pack (tracking of imported modules, command line too long). - Signal handling bug fixed. - x86 port: Added -ffast-math option to use inline trigo and log functions. Small performance tweaks for the Pentium 4. Fixed illegal "imul" instruction generated by reloading phase. - Sparc port: Enhanced code generation for Sparc V8 (option -march=v8) and Sparc V9 (option -march=v9). Profiling support added for Solaris. - PowerPC port: Keep stack 16-aligned for compatibility with C calling conventions. Toplevel interactive system: - Tightened interface consistency checks between .cmi files, .cm[oa] files loaded by #load, and the running toplevel. - #trace on mutually-recursive functions was broken, works again. - Look for .ocamlinit file in home directory in addition to the current dir. Standard library: - Match_failure and Assert_failure exceptions now report (file, line, column), instead of (file, starting char, ending char). - float_of_string, int_of_string: some ill-formed input strings were not rejected. - Added format concatenation, string_of_format, format_of_string. - Module Arg: added new option handlers Set_string, Set_int, Set_float, Symbol, Tuple. - Module Format: tag handling is now turned off by default, use [Format.set_tags true] to activate. - Modules Lexing and Parsing: added better handling of positions in source file. Added function Lexing.flush_input. - Module Scanf: %n and %N formats to count characters / items read so far; assorted bug fixes, %! to match end of input. New ``_'' special flag to skip reresulting value. - Module Format: tags are not activated by default. - Modules Set and Map: fixed bugs causing trees to become unbalanced. - Module Printf: less restrictive typing of kprintf. - Module Random: better seeding; functions to generate random int32, int64, nativeint; added support for explicit state management. - Module Sys: added Sys.readdir for reading the contents of a directory. Runtime system: - output_value/input_value: fixed bug with large blocks (>= 4 Mwords) produced on a 64-bit platform and incorrectly read back on a 32-bit platform. - Fixed memory compaction bug involving input_value. - Added MacOS X support for dynamic linking of C libraries. - Improved stack backtraces on uncaught exceptions. - Fixed float alignment problem on Sparc V9 with gcc 3.2. Other libraries: - Dynlink: By default, dynamically-loaded code now has access to all modules defined by the program; new functions Dynlink.allow_only and Dynlink.prohibit implement access control. Fixed Dynlink problem with files generated with ocamlc -pack. Protect against references to modules not yet fully initialized. - LablTK/CamlTK: added support for TCL/TK 8.4. - Str: reimplemented regexp matching engine, now less buggy, faster, and LGPL instead of GPL. - Graphics: fixed draw_rect and fill_rect bug under X11. - System threads and bytecode threads libraries can be both installed. - System threads: better implementation of Thread.exit. - Bytecode threads: fixed two library initialization bugs. - Unix: make Unix.openfile blocking to account for named pipes; GC bug in Unix.*stat fixed; fixed problem with Unix.dup2 on Windows. Ocamllex: - Can name parts of the matched input text, e.g. "0" (['0'-'7']+ as s) { ... s ... } Ocamldebug: - Handle programs that run for more than 2^30 steps. Emacs mode: - Added file caml-types.el to interactively display the type information saved by option -dtypes. Win32 ports: - Cygwin port: recognize \ as directory separator in addition to / - MSVC port: ocamlopt -pack works provided GNU binutils are installed. - Graphics library: fixed bug in Graphics.blit_image; improved event handling. OCamldoc: - new ty_code field for types, to keep code of a type (with option -keep-code) - new ex_code field for types, to keep code of an exception (with option -keep-code) - some fixes in html generation - don't overwrite existing style.css file when generating HTML - create the ocamldoc.sty file when generating LaTeX (if nonexistent) - man pages are now installed in man/man3 rather than man/mano - fix: empty [] in generated HTML indexes Objective Caml 3.06: -------------------- Type-checking: - Apply value restriction to polymorphic record fields. Run-time system: - Fixed GC bug affecting lazy values. Both compilers: - Added option "-version" to print just the version number. - Fixed wrong dependencies in .cmi generated with the -pack option. Native-code compiler: - Fixed wrong return value for inline bigarray assignments. Libraries: - Unix.getsockopt: make sure result is a valid boolean. Tools: - ocamlbrowser: improved error reporting; small Win32 fixes. Windows ports: - Fixed two problems with the Mingw port under Cygwin 1.3. Objective Caml 3.05: -------------------- Language features: - Support for polymorphic methods and record fields. - Allows _ separators in integer and float literals, e.g. 1_000_000. Type-checker: - New flag -principal to enforce principality of type inference. - Fixed subtle typing bug with higher-order functors. - Fixed several complexity problems; changed (again) the behaviour of simple coercions. - Fixed various bugs with objects and polymorphic variants. - Improved some error messages. Both compilers: - Added option "-pack" to assemble several compilation units as one unit having the given units as sub-modules. - More precise detection of unused sub-patterns in "or" patterns. - Warnings for ill-formed \ escapes in string and character literals. - Protect against spaces and other special characters in directory names. - Added interface consistency check when building a .cma or .cmxa library. - Minor reduction in code size for class initialization code. - Added option "-nostdlib" to ignore standard library entirely. Bytecode compiler: - Fixed issue with ocamlc.opt and dynamic linking. Native-code compiler: - Added link-time check for multiply-defined module names. - Fixed GC bug related to constant constructors of polymorphic variant types. - Fixed compilation bug for top-level "include" statements. - PowerPC port: work around limited range for relative branches, thus removing assembler failures on large functions. - IA64 port: fixed code generation bug for 3-way constructor matching. Toplevel interactive system: - Can load object files given on command line before starting up. - ocamlmktop: minimized possibility of name clashes with user-provided modules. Run-time system: - Minor garbage collector no longer recursive. - Better support for lazy data in the garbage collector. - Fixed issues with the heap compactor. - Fixed issues with finalized Caml values. - The type "int64" is now supported on all platforms: we use software emulation if the C compiler doesn't support 64-bit integers. - Support for float formats that are neither big-endian nor little-endian (one known example: the ARM). - Fixed bug in callback*_exn functions in the exception-catching case. - Work around gcc 2.96 bug on RedHat 7.2 and Mandrake 8.0, 8.1 among others. - Stub DLLs now installed in subdir stublibs/ of standard library dir. Standard library: - Protect against integer overflow in sub-string and sub-array bound checks. - New module Complex implementing arithmetic over complex numbers. - New module Scanf implementing format-based scanning a la scanf() in C. - Module Arg: added alternate entry point Arg.parse_argv. - Modules Char, Int32, Int64, Nativeint, String: added type "t" and function "compare" so that these modules can be used directly with e.g. Set.Make. - Module Digest: fixed issue with Digest.file on large files (>= 1Gb); added Digest.to_hex. - Module Filename: added Filename.open_temp_file to atomically create and open the temp file; improved security of Filename.temp_file. - Module Genlex: allow _ as first character of an identifier. - Module Lazy: more efficient implementation. - Module Lexing: improved performances for very large tokens. - Module List: faster implementation of sorting functions. - Module Printf: added %S and %C formats (quoted, escaped strings and characters); added kprintf (calls user-specified continuation on formatted string). - Module Queue: faster implementation (courtesy of Franois Pottier). - Module Random: added Random.bool. - Module Stack: added Stack.is_empty. - Module Pervasives: added sub-module LargeFile to support files larger than 1Gb (file offsets are int64 rather than int); opening in "append" mode automatically sets "write" mode; files are now opened in close-on-exec mode; string_of_float distinguishes its output from a plain integer; faster implementation of input_line for long lines. - Module Sys: added Sys.ocaml_version containing the OCaml version number; added Sys.executable_name containing the (exact) path of the file being executable; Sys.argv.(0) is now unchanged w.r.t. what was provided as 0-th argument by the shell. - Module Weak: added weak hash tables. Other libraries: - Bigarray: support for bigarrays of complex numbers; added functions Genarray.dims, {Genarray,Array1,Array2,Array3}.{kind,layout}. - Dynlink: fixed bug with loading of mixed-mode Caml/C libraries. - LablTK: now supports also the CamlTK API (no labels); support for Activate and Deactivate events; support for virtual events; added UTF conversion; export the tcl interpreter as caml value, to avoid DLL dependencies. - Unix: added sub-module LargeFile to support files larger than 1Gb (file offsets are int64 rather than int); added POSIX opening flags (O_NOCTTY, O_*SYNC); use reentrant functions for gethostbyname and gethostbyaddr when available; fixed bug in Unix.close_process and Unix.close_process_full; removed some overhead in Unix.select. Tools: - ocamldoc (the documentation generator) is now part of the distribution. - Debugger: now supports the option -I +dir. - ocamllex: supports the same identifiers as ocamlc; warns for bad \ escapes in strings and characters. - ocamlbrowser: recenter the module boxes when showing a cross-reference; include the current directory in the ocaml path. Windows port: - Can now compile with Mingw (the GNU compilers without the Cygwin runtime library) in addition to MSVC. - Toplevel GUI: wrong filenames were given to #use and #load commands; read_line() was buggy for short lines (2 characters or less). - OCamlBrowser: now fully functional. - Graphics library: fixed several bugs in event handling. - Threads library: fixed preemption bug. - Unix library: better handling of the underlying differences between sockets and regular file descriptors; added Unix.lockf and a better Unix.rename (thanks to Tracy Camp). - LablTk library: fixed a bug in Fileinput Objective Caml 3.04: -------------------- Type-checker: - Allowed coercing self to the type of the current class, avoiding an obscure error message about "Self type cannot be unified..." Both compilers: - Use OCAMLLIB environment variable to find standard library, falls back on CAMLLIB if not defined. - Report out-of-range ASCII escapes in character or string literals such as "\256". Byte-code compiler: - The -use-runtime and -make-runtime flags are back by popular demand (same behavior as in 3.02). - Dynamic loading (of the C part of mixed Caml/C libraries): arrange that linking in -custom mode uses the static libraries for the C parts, not the shared libraries, for maximal robustness and compatibility with 3.02. Native-code compiler: - Fixed bug in link-time consistency checking. Tools: - ocamlyacc: added parser debugging support (set OCAMLRUNPARAM=p to get a trace of the pushdown automaton actions). - ocamlcp: was broken in 3.03 (Sys_error), fixed. Run-time system: - More work on dynamic loading of the C part of mixed Caml/C libraries. - On uncaught exception, flush output channels before printing exception message and backtrace. - Corrected several errors in exception backtraces. Standard library: - Pervasives: integer division and modulus are now fully specified on negative arguments (with round-towards-zero semantics). - Pervasives.float_of_string: now raises Failure on ill-formed input. - Pervasives: added useful float constants max_float, min_float, epsilon_float. - printf functions in Printf and Format: added % formats for int32, nativeint, int64; "*" in width and precision specifications now supported (contributed by Thorsten Ohl). - Added Hashtbl.copy, Stack.copy. - Hashtbl: revised resizing strategy to avoid quadratic behavior on Hashtbl.add. - New module MoreLabels providing labelized versions of modules Hashtbl, Map and Set. - Pervasives.output_value and Marshal.to_* : improved hashing strategy for internal data structures, avoid excessive slowness on quasi-linearly-allocated inputs. Other libraries: - Num: fixed bug in big integer exponentiation (Big_int.power_*). Windows port: - New GUI for interactive toplevel (Jacob Navia). - The Graphics library is now available for stand-alone executables (Jacob Navia). - Unix library: improved reporting of system error codes. - Fixed error in "globbing" of * and ? patterns on command line. Emacs mode: small fixes; special color highlighting for ocamldoc comments. License: added special exception to the LGPL'ed code (libraries and runtime system) allowing unrestricted linking, whether static or dynamic. Objective Caml 3.03 ALPHA: -------------------------- Language: - Removed built-in syntactic sugar for streams and stream patterns [< ... >], now supported via CamlP4, which is now included in the distribution. - Switched the default behaviour to labels mode (labels are compulsory), but allows omitting labels when a function application is complete. -nolabels mode is available but deprecated for programming. (See also scrapelabels and addlabels tools below.) - Removed all labels in the standard libraries, except labltk. Labelized versions are kept for ArrayLabels, ListLabels, StringLabels and UnixLabels. "open StdLabels" gives access to the first three. - Extended polymorphic variant type syntax, allowing union types and row abbreviations for both sub- and super-types. #t deprecated in types. - See the Upgrading file for how to adapt to all the changes above. Type-checker: - Fixed obscure bug in module typing causing the type-checker to loop on signatures of the form module type M module A: sig module type T = sig module T: M end end module B: A.T - Improved efficiency of module type-checking via lazy computation of certain signature summary information. - An empty polymorphic variant type is now an error. Both compilers: - Fixed wrong code generated for "struct include M ... end" when M contains one or several "external" declarations. Byte-code compiler: - Protect against VM stack overflow caused by module initialization code with many local variables. - Support for dynamic loading of the C part of mixed Caml/C libraries. - Removed the -use-runtime and -make-runtime flags, obsoleted by dynamic loading of C libraries. Native-code compiler: - Attempt to recover gracefully from system stack overflow. Currently works on x86 under Linux and BSD. - Alpha: work around "as" bug in Tru64 5.1. Toplevel environment: - Revised printing of inferred types and evaluation results so that an external printer (e.g. Camlp4's) can be hooked in. Tools: - The CamlP4 pre-processor-pretty-printer is now included in the standard distribution. - New tool ocamlmklib to help build mixed Caml/C libraries. - New tool scrapelabels and addlabels, to either remove (non-optional) labels in interfaces, or automatically add them in the definitions. They provide easy transition from classic mode ocaml 3.02 sources, depending on whether you want to keep labels or not. - ocamldep: added -pp option to handle preprocessed source files. Run-time system: - Support for dynamic loading of the C part of mixed Caml/C libraries. Currently works under Linux, FreeBSD, Windows, Tru64, Solaris and Irix. - Implemented registration of global C roots with a skip list, runs much faster when there are many global C roots. - Autoconfiguration script: fixed wrong detection of Mac OS X; problem with the Sparc, gcc 3.0, and float alignment fixed. Standard library: - Added Pervasives.flush_all to flush all opened output channels. Other libraries: - All libraries revised to allow dynamic loading of the C part. - Graphics under X Windows: revised event handling, should no longer lose mouse events between two calls to wait_next_event(); wait_next_event() now interruptible by signals. - Bigarrays: fixed bug in marshaling of big arrays. Windows port: - Fixed broken Unix.{get,set}sockopt* Objective Caml 3.02: -------------------- Both compilers: - Fixed embarrassing bug in pattern-matching compilation (affected or-patterns containing variable bindings). - More optimizations in pattern-matching compilation. Byte-code compiler: - Protect against VM stack overflow caused by functions with many local variables. Native-code compiler: - Removed re-sharing of string literals, causes too many surprises with in-place string modifications. - Corrected wrong compilation of toplevel "include" statements. - Fixed bug in runtime function "callbackN_exn". - Signal handlers receive the conventional signal number as argument instead of the system signal number (same behavior as with the bytecode compiler). - ARM port: fixed issue with immediate operand overflow in large functions. Toplevel environment: - User-definer printers (for #install_printer) now receive as first argument the pretty-printer formatter where to print their second argument. Old printers (with only one argument) still supported for backward compatibility. Standard library: - Module Hashtbl: added Hashtbl.fold. Other libraries: - Dynlink: better error reporting in add_interfaces for missing .cmi files. - Graphics: added more drawing functions (multiple points, polygons, multiple lines, splines). - Bytecode threads: the module Unix is now thread-safe, ThreadUnix is deprecated. Unix.exec* now resets standard descriptors to blocking mode. - Native threads: fixed a context-switch-during-GC problem causing certain C runtime functions to fail, most notably input_value. - Unix.inet_addr_of_string: call inet_aton() when available so as to handle correctly the address 255.255.255.255. - Unix: added more getsockopt and setsockopt functions to get/set options that have values other than booleans. - Num: added documentation for the Big_int module. Tools: - ocamldep: fixed wrong dependency issue with nested modules. Run-time system: - Removed floating-point error at start-up on some non-IEEE platforms (e.g. FreeBSD prior to 4.0R). - Stack backtrace mechanism now works for threads that terminate on an uncaught exception. Auto-configuration: - Updated config.guess and config.sub scripts, should recognize a greater number of recent platform. Windows port: - Fixed broken Unix.waitpid. Unix.file_descr can now be compared or hashed. - Toplevel application: issue with spaces in name of stdlib directory fixed. MacOS 9 port: - Removed the last traces of support for 68k Objective Caml 3.01: -------------------- New language features: - Variables are allowed in "or" patterns, e.g. match l with [t] | [_;t] -> ... t ... - "include " to re-export all components of a structure inside another structure. - Variance annotation on parameters of type declarations, e.g. type (+'a,-'b,'c) t (covariant in 'a, contravariant in 'b, invariant in 'c) New ports: - Intel IA64/Itanium under Linux (including the native-code compiler). - Cygwin under MS Windows. This port is an alternative to the earlier Windows port of OCaml, which relied on MS compilers; the Cygwin Windows port does not need MS Visual C++ nor MASM, runs faster in bytecode, and has a better implementation of the Unix library, but currently lacks threads and COM component support. Type-checking: - Relaxed "monomorphic restriction" on type constructors in a mutually-recursive type definition, e.g. the following is again allowed type u = C of int t | D of string t and 'a t = ... - Fixed name-capture bug in "include SIG" and "SIG with ..." constructs. - Improved implicit subtypes built by (... :> ty), closer to intuition. - Several bug fixes in type-checking of variants. - Typing of polymorphic variants is more restrictive: do not allow conjunctive types inside the same pattern matching. a type has either an upper bound, or all its tags are in the lower bound. This may break some programs (this breaks lablgl-0.94). Both compilers: - Revised compilation of pattern matching. - Option -I + to search a subdirectory of the standard library directory (i.e. write "ocamlc -I +labltk" instead of "ocamlc -I /usr/local/lib/ocaml/labltk"). - Option -warn-error to turn warnings into errors. - Option -where to print the location of the standard library directory. - Assertions are now type-checked even if the -noassert option is given, thus -noassert can no longe change the types of modules. Bytecode compiler and bytecode interpreter: - Print stack backtrace when a program aborts due to an uncaught exception (requires compilation with -g and running with ocamlrun -b or OCAMLRUNPARAM="b=1"). Native-code compiler: - Better unboxing optimizations on the int32, int64, and nativeint types. - Tail recursion preserved for functions having more parameters than available registers (but tail calls to other functions are still turned off if parameters do not fit entirely in registers). - Fixed name-capture bug in function inlining. - Improved spilling/reloading strategy for conditionals. - IA32, Alpha: better alignment of branch targets. - Removed spurious dependency on the -lcurses library. Toplevel environment: - Revised handling of top-level value definitions, allows reclaimation of definitions that are shadowed by later definitions with the same names. (E.g. "let x = ;; let x = 1;;" allows to be reclaimed.) - Revised the tracing facility so that for standard library functions, only calls from user code are traced, not calls from the system. - Added a "*" prompt when within a comment. Runtime system: - Fixed portability issue on bcopy() vs memmove(), affecting Linux RedHat 7.0 in particular. - Structural comparisons (=, <>, <, <=, >, >=, compare) reimplemented so as to avoid overflowing the C stack. - Input/output functions: arrange so that reads and writes on closed in_channel or out_channel raise Sys_error immediately. Standard library: - Module Gc: changed some counters to float in order to avoid overflow; added alarms - Module Hashtbl: added Hashtbl.replace. - Module Int64: added bits_of_float, float_of_bits (access to IEEE 754 representation of floats). - Module List: List.partition now tail-rec; improved memory behavior of List.stable_sort. - Module Nativeint: added Nativeint.size (number of bits in a nativeint). - Module Obj: fixed incorrect resizing of float arrays in Obj.resize. - Module Pervasives: added float constants "infinity", "neg_infinity", "nan"; added a "classify_float" function to test a float for NaN, infinity, etc. - Pervasives.input_value: fixed bug affecting shared custom objects. - Pervasives.output_value: fixed size bug affecting "int64" values. - Pervasives.int_of_string, {Int32,Int64,Nativeint}.of_string: fixed bug causing bad digits to be accepted without error. - Module Random: added get_state and set_state to checkpoint the generator. - Module Sys: signal handling functions are passed the system-independent signal number rather than the raw system signal number whenever possible. - Module Weak: added Weak.get_copy. Other libraries: - Bigarray: added Bigarray.reshape to take a view of the elements of a bigarray with different dimensions or number of dimensions; fixed bug causing "get" operations to be unavailable in custom toplevels including Bigarray. - Dynlink: raise an error instead of crashing when the loaded module refers to the not-yet-initialized module performing a dynlink operation. - Bytecode threads: added a thread-safe version of the Marshal module; fixed a rare GC bug in the thread scheduler. - POSIX threads: fixed compilation problem with threads.cmxa. - Both thread libraries: better tail-recursion in Event.sync. - Num library: fixed bug in square roots (Nat.sqrt_nat, Big_int.sqrt_big_int). Tools: - ocamldep: fixed missing dependencies on labels of record patterns and record construction operations Win32 port: - Unix.waitpid now implements the WNOHANG option. Mac OS ports: - Mac OS X public beta is supported. - Int64.format works on Mac OS 8/9. Objective Caml 3.00: -------------------- Language: - OCaml/OLabl merger: * Support for labeled and optional arguments for functions and classes. * Support for variant types (sum types compared by structure). See tutorial (chapter 2 of the OCaml manual) for more information. - Syntactic change: "?" in stream error handlers changed to "??". - Added exception renaming in structures (exception E = F). - (OCaml 2.99/OLabl users only) Label syntax changed to preserve backward compatibility with 2.0x (labeled function application is f ~lbl:arg instead of f lbl:arg). A tool is provided to help convert labelized programs to OCaml 3.00. Both compilers: - Option -labels to select commuting label mode (labels are mandatory, but labeled arguments can be passed in a different order than in the definition of the function; in default mode, labels may be omitted, but argument reordering is only allowed for optional arguments). - Libraries (.cma and .cmxa files) now "remember" C libraries given at library construction time, and add them back at link time. Allows linking with e.g. just unix.cma instead of unix.cma -custom -cclib -lunix - Revised printing of error messages, now use Format.fprintf; no visible difference for users, but could facilitate internationalization later. - Fixed bug in unboxing of records containing only floats. - Fixed typing bug involving applicative functors as components of modules. - Better error message for inconsistencies between compiled interfaces. Bytecode compiler: - New "modular" format for bytecode executables; no visible differences for users, but will facilitate further extensions later. - Fixed problems in signal handling. Native-code compiler: - Profiling support on x86 under FreeBSD - Open-coding and unboxing optimizations for the new integer types int32, int64, nativeint, and for bigarrays. - Fixed instruction selection bug with "raise" appearing in arguments of strict operators, e.g. "1 + raise E". - Better error message when linking incomplete/incorrectly ordered set of .cmx files. - Optimized scanning of global roots during GC, can reduce total running time by up to 8% on GC-intensive programs. Interactive toplevel: - Better printing of exceptions, including arguments, when possible. - Fixed rare GC bug occurring during interpretation of scripts. - Added consistency checks between interfaces and implementations during #load. Run-time system: - Added support for "custom" heap blocks (heap blocks carrying C functions for finalization, comparison, hashing, serialization and deserialization). - Support for finalisation functions written in Caml. Standard library: - New modules Int32, Int64, Nativeint for 32-bit, 64-bit and platform-native integers - Module Array: added Array.sort, Array.stable_sort. - Module Gc: added Gc.finalise to attach Caml finalisation functions to arbitrary heap-allocated data. - Module Hashtbl: do not bomb when resizing very large table. - Module Lazy: raise Lazy.Undefined when a lazy evaluation needs itself. - Module List: added List.sort, List.stable_sort; fixed bug in List.rev_map2. - Module Map: added mapi (iteration with key and data). - Module Set: added iterators for_all, exists, filter, partition. - Module Sort: still here but deprecated in favor of new sorting functions in Array and List. - Module Stack: added Stack.top - Module String: fixed boundary condition on String.rindex_from - Added labels on function arguments where appropriate. New libraries and tools: - ocamlbrowser: graphical browser for OCaml sources and compiled interfaces, supports cross-referencing, editing, running the toplevel. - LablTK: GUI toolkit based on TK, using labeled and optional arguments, easier to use than CamlTK. - Bigarray: large, multi-dimensional numerical arrays, facilitate interfacing with C/Fortran numerical code, efficient support for advanced array operations such as slicing and memory-mapping of files. Other libraries: - Bytecode threads: timer-based preemption was broken, works back again; fixed bug in Pervasives.input_line; exported Thread.yield. - System threads: several GC / reentrancy bugs fixed in buffered I/O and Unix I/O; revised Thread.join implementation for strict POSIX conformance; exported Thread.yield. - Graphics: added support for double buffering; added, current_x, current_y, rmoveto, rlineto, and draw_rect. - Num: fixed bug in Num.float_of_num. - Str: worked around potential symbol conflicts with C standard library. - Dbm: fixed bug with Dbm.iter on empty database. New or updated ports: - Alpha/Digital Unix: lifted 256M limitation on total memory space induced by -taso - Port to AIX 4.3 on PowerPC - Port to HPUX 10 on HPPA - Deprecated 680x0 / SunOS port Macintosh port: - Implemented the Unix and Thread libraries. - The toplevel application does not work on 68k Macintoshes; maybe later if there's a demand. - Added a new tool, ocamlmkappli, to build an application from a program written in O'Caml. Objective Caml 2.04: -------------------- - C interface: corrected inconsistent change in the CAMLparam* macros. - Fixed internal error in ocamlc -g. - Fixed type-checking of "S with ...", where S is a module type name abbreviating another module type name. - ocamldep: fixed stdout/stderr mismatch after failing on one file. - Random.self_init more random. - Windows port: - Toplevel application: fixed spurious crash on exit. - Native-code compiler: fixed bug in assembling certain floating-point constants (masm doesn't grok 2e5, wants 2.0e5). Objective Caml 2.03: -------------------- New ports: - Ported to BeOS / Intel x86 (bytecode and native-code). - BSD / Intel x86 port now supports both a.out and ELF binary formats. - Added support for {Net,Open}BSD / Alpha. - Revamped Rhapsody port, now works on MacOS X server. Syntax: - Warning for "(*)" and "*)" outside comment. - Removed "#line LINENO", too ambiguous with a method invocation; the equivalent "# LINENO" is still supported. Typing: - When an incomplete pattern-matching is detected, report also a value or value template that is not covered by the cases of the pattern-matching. - Several bugs in class type matching and in type error reporting fixed. - Added an option -rectypes to support general recursive types, not just those involving object types. Bytecode compiler: - Minor cleanups in the bytecode emitter. - Do not remove "let x = y" bindings in -g mode; makes it easier to debug the code. Native-code compiler: - Fixed bug in grouping of allocations performed in the same basic block. - Fixed bug in constant propagation involving expressions containing side-effects. - Fixed incorrect code generation for "for" loops whose upper bound is a reference assigned inside the loop. - MIPS code generator: work around a bug in the IRIX 6 assembler. Toplevel: - Fixed incorrect redirection of standard formatter to stderr while executing toplevel scripts. Standard library: - Added List.rev_map, List.rev_map2. - Documentation of List functions now says which functions are tail-rec, and how much stack space is needed for non-tailrec functions. - Wrong type for Printf.bprintf fixed. - Fixed weird behavior of Printf.sprintf and Printf.bprintf in case of partial applications. - Added Random.self_init, which initializes the PRNG from the system date. - Sort.array: serious bugs fixed. - Stream.count: fixed incorrect behavior with ocamlopt. Run-time system and external interface: - Fixed weird behavior of signal handlers w.r.t. signal masks and exceptions raised from the signal handler. - Fixed bug in the callback*_exn() functions. Debugger: - Fixed wrong printing of float record fields and elements of float arrays. - Supports identifiers starting with '_'. Profiler: - Handles .mli files, so ocamlcp can be used to replace ocamlc (e.g. in a makefile). - Now works on programs that use stream expressions and stream parsers. Other libraries: - Graphics: under X11, treat all mouse buttons equally; fixed problem with current font reverting to the default font when the graphics window is resized. - Str: fixed reentrancy bugs in Str.replace and Str.full_split. - Bytecode threads: set standard I/O descriptors to non-blocking mode. - OS threads: revised implementation of Thread.wait_signal. - All threads: added Event.wrap_abort, Event.choose []. - Unix.localtime, Unix.gmtime: check for errors. - Unix.create_process: now supports arbitrary redirections of std descriptors. - Added Unix.open_process_full. - Implemented Unix.chmod under Windows. - Big_int.square_big_int now gives the proper sign to its result. Others: - ocamldep: don't stop at first error, skip to next file. - Emacs mode: updated with Garrigue and Zimmerman's snapshot of 1999/10/18. - configure script: added -prefix option. - Windows toplevel application: fixed problem with graphics library not loading properly. Objective Caml 2.02: -------------------- * Type system: - Check that all components of a signature have unique names. - Fixed bug in signature matching involving a type component and a module component, both sharing an abstract type. - Bug involving recursive classes constrained by a class type fixed. - Fixed bugs in printing class types and in printing unification errors. * Compilation: - Changed compilation scheme for "{r with lbl = e}" when r has many fields so as to avoid code size explosion. * Native-code compiler: - Better constant propagation in boolean expressions and in conditionals. - Removal of unused arguments during function inlining. - Eliminated redundant tagging/untagging in bit shifts. - Static allocation of closures for functions without free variables, reduces the size of initialization code. - Revised compilation scheme for definitions at top level of compilation units, so that top level functions have no free variables. - Coalesced multiple allocations of heap blocks inside one expression (e.g. x :: y :: z allocates the two conses in one step). - Ix86: better handling of large integer constants in instruction selection. - MIPS: fixed wrong asm generated for String.length "literal". * Standard library: - Added the "ignore" primitive function, which just throws away its argument and returns "()". It allows to write "ignore(f x); y" if "f x" doesn't have type unit and you don't want the warning caused by "f x; y". - Added the "Buffer" module (extensible string buffers). - Module Format: added formatting to buffers and to strings. - Added "mem" functions (membership test) to Hashtbl and Map. - Module List: added find, filter, partition. Renamed remove and removeq to remove_assoc and remove_assq. - Module Marshal: fixed bug in marshaling functions when passed functional values defined by mutual recursion with other functions. - Module Printf: added Printf.bprintf (print to extensible buffer); added %i format as synonymous for %d (as per the docs). - Module Sort: added Sort.array (Quicksort). * Runtime system: - New callback functions for callbacks with arbitrary many arguments and for catching Caml exceptions escaping from a callback. * The ocamldep dependency generator: now performs full parsing of the sources, taking into account the scope of module bindings. * The ocamlyacc parser generator: fixed sentinel error causing wrong tables to be generated in some cases. * The str library: - Added split_delim, full_split as variants of split that control more precisely what happens to delimiters. - Added replace_matched for separate matching and replacement operations. * The graphics library: - Bypass color lookup for 16 bpp and 32 bpp direct-color displays. - Larger color cache. * The thread library: - Bytecode threads: more clever use of non-blocking I/O, makes I/O operations faster. - POSIX threads: gcc-ism removed, should now compile on any ANSI C compiler. - Both: avoid memory leak in the Event module when a communication offer is never selected. * The Unix library: - Fixed inversion of ctime and mtime in Unix.stat, Unix.fstat, Unix.lstat. - Unix.establish_connection: properly reclaim socket if connect fails. * The DBM library: no longer crashes when calling Dbm.close twice. * Emacs mode: - Updated with Garrigue and Zimmerman's latest version. - Now include an "ocamltags" script for using etags on OCaml sources. * Win32 port: - Fixed end-of-line bug in ocamlcp causing problems with generated sources. Objective Caml 2.01: -------------------- * Typing: - Added warning for expressions of the form "a; b" where a does not have type "unit"; catches silly mistake such as "record.lbl = newval; ..." instead of "record.lbl <- newval; ...". - Typing bug in "let module" fixed. * Compilation: - Fixed bug in compilation of recursive and mutually recursive classes. - Option -w to turn specific warnings on/off. - Option -cc to choose the C compiler used with ocamlc -custom and ocamlopt. * Bytecode compiler and bytecode interpreter: - Intel x86: removed asm declaration causing "fixed or forbidden register spilled" error with egcs and gcc 2.8 (but not with gcc 2.7, go figure). - Revised handling of debugging information, allows faster linking with -g. * Native-code compiler: - Fixed bugs in integer constant propagation. - Out-of-bound accesses in array and strings now raise an Invalid_argument exception (like the bytecode system) instead of stopping the program. - Corrected scheduling of bound checks. - Port to the StrongARM under Linux (e.g. Corel Netwinder). - I386: fixed bug in profiled code (ocamlopt -p). - Mips: switched to -n32 model under IRIX; dropped the Ultrix port. - Sparc: simplified the addressing modes, allows for better scheduling. - Fixed calling convention bug for Pervasives.modf. * Toplevel: - #trace works again. - ocamlmktop: use matching ocamlc, not any ocamlc from the search path. * Memory management: - Fixed bug in heap expansion that could cause the GC to loop. * C interface: - New macros CAMLparam... and CAMLlocal... to simplify the handling of local roots in C code. - Simplified procedure for allocating and filling Caml blocks from C. - Declaration of string_length in . * Standard library: - Module Format: added {get,set}_all_formatter_output_functions, formatter_of_out_channel, and the control sequence @ in printf. - Module List: added mem_assoc, mem_assq, remove, removeq. - Module Pervasives: added float_of_int (synonymous for float), int_of_float (truncate), int_of_char (Char.code), char_of_int (Char.chr), bool_of_string. - Module String: added contains, contains_from, rcontains_from. * Unix library: - Unix.lockf: added F_RLOCK, F_TRLOCK; use POSIX locks whenever available. - Unix.tc{get,set}attr: added non-standard speeds 57600, 115200, 230400. - Unix.chroot: added. * Threads: - Bytecode threads: improved speed of I/O scheduling. - Native threads: fixed a bug involving signals and exceptions generated from C. * The "str" library: - Added Str.string_partial_match. - Bumped size of internal stack. * ocamlyacc: emit correct '# lineno' directive for prelude part of .mly file. * Emacs editing mode: updated with Jacques Garrigue's newest code. * Windows port: - Added support for the "-cclib -lfoo" option (instead of -cclib /full/path/libfoo.lib as before). - Threads: fixed a bug at initialization time. * Macintosh port: source code for Macintosh application merged in. Objective Caml 2.00: -------------------- * Language: - New class language. See http://caml.inria.fr/ocaml/refman/ for a tutorial (chapter 2) and for the reference manual (section 4.9). - Local module definitions "let module X = in ". - Record copying with update "{r with lbl1 = expr1; ...}". - Array patterns "[|pat1; ...;patN|]" in pattern-matchings. - New reserved keywords: "object", "initializer". - No longer reserved: "closed", "protected". * Bytecode compiler: - Use the same compact memory representations for float arrays, float records and recursive closures as the native-code compiler. - More type-dependent optimizations. - Added the -use_runtime and -make_runtime flags to build separately and reuse afterwards custom runtime systems (inspired by Fabrice Le Fessant's patch). * Native-code compiler: - Cross-module constant propagation of integer constants. - More type-dependent optimizations. - More compact code generated for "let rec" over data structures. - Better code generated for "for" loops (test at bottom of code). - More aggressive scheduling of stores. - Added -p option for time profiling with gprof (fully supported on Intel x86/Linux and Alpha/Digital Unix only) (inspired by Aleksey Nogin's patch). - A case of bad spilling with high register pressure fixed. - Fixed GC bug when GC called from C without active Caml code. - Alpha: $gp handling revised to follow Alpha's standard conventions, allow running "atom" and "pixie" on ocamlopt-generated binaries. - Intel x86: use movzbl and movsbl systematically to load 8-bit and 16-bit quantities, no more hacks with partial registers (better for the Pentium Pro, worse for the Pentium). - PowerPC: more aggressive scheduling of return address reloading. - Sparc: scheduling bug related to register pairs fixed. * Runtime system: - Better printing of uncaught exceptions (print a fully qualified name whenever possible). * New ports: - Cray T3E (bytecode only) (in collaboration with CEA). - PowerMac under Rhapsody. - SparcStations under Linux. * Standard library: - Added set_binary_mode_in and set_binary_mode_out in Pervasives to toggle open channels between text and binary modes. - output_value and input_value check that the given channel is in binary mode. - input_value no longer fails on very large marshalled data (> 16 Mbytes). - Module Arg: added option Rest. - Module Filename: temp_file no longer loops if temp dir doesn't exist. - Module List: added rev_append (tail-rec alternative to @). - Module Set: tell the truth about "elements" returning a sorted list; added min_elt, max_elt, singleton. - Module Sys: added Sys.time for simple measuring of CPU time. * ocamllex: - Check for overflow when generating the tables for the automaton. - Error messages in generated .ml file now point to .mll source. - Added "let = " to name regular expressions (inspired by Christian Lindig's patch). * ocamlyacc: - Better error recovery in presence of EOF tokens. - Error messages in generated .ml file now point to .mly source. - Generated .ml file now type-safe even without the generated .mli file. * The Unix library: - Use float instead of int to represent Unix times (number of seconds from the epoch). This fixes a year 2005 problem on 32-bit platforms. Functions affected: stat, lstat, fstat, time, gmtime, localtime, mktime, utimes. - Added putenv. - Better handling of "unknown" error codes (EUNKNOWNERR). - Fixed endianness bug in getservbyport. - win32unix (the Win32 implementation of the Unix library) now has the same interface as the unix implementation, this allows exchange of compiled .cmo and .cmi files between Unix and Win32. * The thread libraries: - Bytecode threads: bug with escaping exceptions fixed. - System threads (POSIX, Win32): malloc/free bug fixed; signal bug fixed. - Both: added Thread.wait_signal to wait synchronously for signals. * The graph library: bigger color cache. * The str library: added Str.quote, Str.regexp_string, Str.regexp_string_case_fold. * Emacs mode: - Fixed bug with paragraph fill. - Fixed bug with next-error under Emacs 20. Objective Caml 1.07: -------------------- * Native-code compiler: - Revised interface between generated code and GC, fixes serious GC problems with signals and native threads. - Added "-thread" option for compatibility with ocamlc. * Debugger: correctly print instance variables of objects. * Run-time system: ported to OpenBSD. * Standard library: fixed wrong interface for Marshal.to_buffer and Obj.unmarshal. * Num library: added Intel x86 optimized asm code (courtesy of Bernard Serpette). * Thread libraries: - Native threads: fixed GC bugs and installation procedure. - Bytecode threads: fixed problem with "Marshal" module. - Both: added Event.always. * MS Windows port: better handling of long command lines in Sys.command Objective Caml 1.06: -------------------- * Language: - Added two new keywords: "assert" (check assertion) and "lazy" (delay evaluation). - Allow identifiers to start with "_" (such identifiers are treated as lowercase idents). * Objects: - Added "protected" methods (visible only from subclasses, can be hidden in class type declared in module signature). - Objects can be compared using generic comparison functions. - Fixed compilation of partial application of object constructors. * Type system: - Occur-check now more strict (all recursions must traverse an object). - A few bugs fixed. * Run-time system: - A heap compactor was implemented, so long-running programs can now fight fragmentation. - The meaning of the "space_overhead" parameter has changed. - The macros Push_roots and Pop_roots are superseded by Begin_roots* and End_roots. - Bytecode executable includes list of primitives used, avoids crashes on version mismatch. - Reduced startup overhead for marshalling, much faster marshalling of small objects. - New exception Stack_overflow distinct from Out_of_memory. - Maximum stack size configurable. - I/O revised for compatibility with compactor and with native threads. - All C code ANSIfied (new-style function declarations, etc). - Threaded code work on all 64-bit processors, not just Alpha/Digital Unix. - Better printing of uncaught exceptions. * Both compilers: - Parsing: more detailed reporting of syntax errors (e.g. shows unmatched opening parenthesis on missing closing parenthesis). - Check consistency between interfaces (.cmi). - Revised rules for determining dependencies between modules. - Options "-verbose" for printing calls to C compiler, "-noassert" for turning assertion checks off. * Native-code compiler: - Machine-dependent parts rewritten using inheritance instead of parameterized modules. - GC bug in value let rec fixed. - Port to Linux/Alpha. - Sparc: cleaned up use of %g registers, now compatible with Solaris threads. * Top-level interactive system: - Can execute Caml script files given on command line. - Reads commands from ./.ocamlinit on startup. - Now thread-compatible. * Standard library: - New library module: Lazy (delayed computations). - New library module: Marshal. Allows marshalling to strings and transmission of closures between identical programs (SPMD parallelism). - Filename: "is_absolute" is superseded by "is_implicit" and "is_relative". To adapt old programs, change "is_absolute x" to "not (is_implicit x)" (but the new "is_relative" is NOT the opposite of the old "is_absolute"). - Array, Hashtbl, List, Map, Queue, Set, Stack, Stream: the "iter" functions now take as argument a unit-returning function. - Format: added "printf" interface to the formatter (see the documentation). Revised behaviour of simple boxes: no more than one new line is output when consecutive break hints should lead to multiple line breaks. - Stream: revised implementation, renamed Parse_failure to Failure and Parse_error to Error (don't you love gratuitous changes?). - String: added index, rindex, index_from, rindex_from. - Array: added mapi, iteri, fold_left, fold_right, init. - Added Map.map, Set.subset, Printexc.to_string. * ocamllex: lexers generated by ocamllex can now handle all characters, including '\000'. * ocamlyacc: fixed bug with function closures returned by parser rules. * Debugger: - Revised generation of events. - Break on function entrance. - New commands start/previous. - The command loadprinter now try to recursively load required modules. - Numerous small fixes. * External libraries: - systhreads: can now use POSIX threads; POSIX and Win32 threads are now supported by the native-code compiler. - dbm and graph: work in native code. - num: fixed bug in Nat.nat_of_string. - str: fixed deallocation bug with case folding. - win32unix: use Win32 handles instead of (buggy) VC++ emulation of Unix file handles; added gettimeofday. * Emacs editing mode and debugger interface updated to July '97 version. Objective Caml 1.05: -------------------- * Typing: fixed several bugs causing spurious type errors. * Native-code compiler: fixed instruction selection bug causing GC to see ill-formed pointers; fixed callbacks to support invocation from a main program in C. * Standard library: fixed String.lowercase; Weak now resists integers. * Toplevel: multiple phrases without intermediate ";;" now really supported; fixed value printing problems where the wrong printer was selected. * Debugger: fixed printing problem with local references; revised handling of checkpoints; various other small fixes. * Macintosh port: fixed signed division problem in bytecomp/emitcode.ml Objective Caml 1.04: -------------------- * Replay debugger ported from Caml Light; added debugger support in compiler (option -g) and runtime system. Debugger is alpha-quality and needs testing. * Parsing: - Support for "# linenum" directives. - At toplevel, allow several phrases without intermediate ";;". * Typing: - Allow constraints on datatype parameters, e.g. type 'a foo = ... constraint 'a = 'b * 'c. - Fixed bug in signature matching in presence of free type variables '_a. - Extensive cleanup of internals of type inference. * Native-code compilation: - Inlining of small functions at point of call (fairly conservative). - MIPS code generator ported to SGI IRIX 6. - Better code generated for large integer constants. - Check for urgent GC when allocating large objects in major heap. - PowerPC port: better scheduling, reduced TOC consumption. - HPPA port: handle long conditional branches gracefully, several span-dependent bugs fixed. * Standard library: - More floating-point functions (all ANSI C float functions now available). - Hashtbl: added functorial interface (allow providing own equality and hash functions); rehash when resizing, avoid memory leak on Hashtbl.remove. - Added Char.uppercase, Char.lowercase, String.uppercase, String.lowercase, String.capitalize, String.uncapitalize. - New module Weak for manipulating weak pointers. - New module Callback for registering closures and exceptions to be used from C. * Foreign interface: - Better support for callbacks (C calling Caml), exception raising from C, and main() in C. Added function to remove a global root. - Option -output-obj to package Caml code as a C library. * Thread library: fixed bug in timed_read and timed_write operations; Lexing.from_function and Lexing.from_channel now reentrant. * Unix interface: renamed EACCESS to EACCES (the POSIX name); added setsid; fixed bug in inet_addr_of_string for 64-bit platforms. * Ocamlyacc: default error function no longer prevents error recovery. * Ocamllex: fixed reentrancy problem w.r.t. exceptions during refill; fixed output problem (\r\r\n) under Win32. * Macintosh port: - The makefiles are provided for compiling and installing O'Caml on a Macintosh with MPW 3.4.1. - An application with the toplevel in a window is forthcoming. * Windows NT/95 port: updated toplevel GUI to that of Caml Light 0.73. * Emacs editing mode and debugger interface included in distribution. Objective Caml 1.03: -------------------- * Typing: - bug with type names escaping their scope via unification with non-generalized type variables '_a completely fixed; - fixed bug in occur check : it was too restrictive; - fixed bug of coercion operators; - check that no two types of the same name are generated in a module (there was no check for classes); - "#install_printer" works again; - fixed bug in printing of subtyping errors; - in class interfaces, construct "method m" (without type) change the status of method m from abstract to concrete; - in a recursive definition of class interfaces, a class can now inherit from a previous class; - typing of a method make use of an eventual previously given type of this method, yielding clearer type errors. * Compilation (ocamlc and ocamlopt): - fixed bug in compilation of classes. * Native-code compilation: - optimization of functions taking tuples of arguments; - code emitter for the Motorola 680x0 processors (retrocomputing week); - Alpha/OSF1: generate frame descriptors, avoids crashes when e.g. exp() or log() cause a domain error; fixed bug with String.length "literal"; - Sparc, Mips, HPPA: removed marking of scanned stack frames (benefits do not outweight cost). * Standard library: - Arg.parse now prints documentation for command-line options; - I/O buffers (types in_channel and out_channel) now heap-allocated, avoids crashing when closing a channel several times; - Overflow bug in compare() fixed; - GC bug in raising Sys_error from I/O functions fixed; - Parsing.symbol_start works even for epsilon productions. * Foreign interface: main() in C now working, fixed bug in library order at link time. * Thread library: guard against calling thread functions before Thread.create. * Unix library: fixed getsockopt, setsockopt, open_process_{in,out}. * Perl-free, cpp-free, cholesterol-free installation procedure. Objective Caml 1.02: -------------------- * Typing: - fixed bug with type names escaping their scope via unification with non-generalized type variables '_a; - keep #class abbreviations longer; - faster checking of well-formed abbreviation definitions; - stricter checking of "with" constraints over signatures (arity mismatch, overriding of an already manifest type). * Compilation (ocamlc and ocamlopt): - fixed bug in compilation of recursive classes; - [|...|] and let...rec... allowed inside definitions of recursive data structures; * Bytecode compilation: fixed overflow in linker for programs with more than 65535 globals and constants. * Native-code compilation: - ocamlopt ported to HPPA under HP/UX, Intel x86 under Solaris 2, PowerMacintosh under MkLinux; - fixed two bugs related to floating-point arrays (one with "t array" where t is an abstract type implemented as float, one with comparison between two float arrays on 32 bit platforms); - fixed reloading/spilling problem causing non-termination of register allocation; - fixed bugs in handling of () causing loss of tail recursion; - fixed reloading bug in indirect calls. * Windows NT/95 port: - complete port of the threads library (Pascal Cuoq); - partial port of the Unix library (Pascal Cuoq); - expansion of *, ? and @ on the command line. * Standard library: - bug in in List.exists2 fixed; - bug in "Random.int n" for very large n on 64-bit machines fixed; - module Format: added a "general purpose" type of box (open_box); can output on several formatters at the same time. * The "threads" library: - implementation on top of native threads available for Win32 and POSIX 1003.1c; - added -thread option to select a thread-safe version of the standard library, the ThreadIO module is no longer needed. * The "graph" library: avoid invalid pixmaps when doing open_graph/close_graph several times. * The "dynlink" library: support for "private" (no re-export) dynamic loading. * ocamlyacc: skip '...' character literals correctly. * C interface: C code linked with O'Caml code can provide its own main() and call caml_main() later. Objective Caml 1.01: -------------------- * Typing: better report of type incompatibilities; non-generalizable type variables in a struct...end no longer flagged immediately as an error; name clashes during "open" avoided. * Fixed bug in output_value where identical data structures could have different external representations; this bug caused wrong "inconsistent assumptions" errors when checking compatibility of interfaces at link-time. * Standard library: fixed bug in Array.blit on overlapping array sections * Unmarshaling from strings now working. * ocamlc, ocamlopt: new flags -intf and -impl to force compilation as an implementation/an interface, regardless of file extension; overflow bug on wide-range integer pattern-matchings fixed. * ocamlc: fixed bytecode generation bug causing problems with compilation units defining more than 256 values * ocamlopt, all platforms: fixed GC bug in "let rec" over data structures; link startup file first, fixes "undefined symbol" errors with some libraries. * ocamlopt, Intel x86: more efficient calling sequence for calling C functions; floating-point wars, chapter 5: don't use float stack for holding float pseudo-registers, stack-allocating them is just as efficient. * ocamlopt, Alpha and Intel x86: more compact calling sequence for garbage collection. * ocamllex: generated automata no longer use callbacks for refilling the input buffer (works better with threads); character literals correctly skipped inside actions. * ocamldep: "-I" directories now searched in the right order * Thread library: incompatibilities with callbacks, signals, and dynamic linking removed; scheduling bug with Thread.wait fixed. * New "dbm" library, interfaces with NDBM. * Object-oriented extensions: instance variables can now be omitted in class types; some error messages have been made clearer; several bugs fixes. Objective Caml 1.00: -------------------- * Merge of Jerome Vouillon and Didier Remy's object-oriented extensions. * All libraries: all "new" functions renamed to "create" because "new" is now a reserved keyword. * Compilation of "or" patterns (pat1 | pat2) completely revised to avoid code size explosion. * Compiler support for preprocessing source files (-pp flag). * Library construction: flag -linkall to force linking of all units in a library. * Native-code compiler: port to the Sparc under NetBSD. * Toplevel: fixed bug when tracing several times the same function under different names. * New format for marshaling arbitrary data structures, allows marshaling to/from strings. * Standard library: new module Genlex (configurable lexer for streams) * Thread library: much better support for I/O and blocking system calls. * Graphics library: faster reclaimation of unused pixmaps. * Unix library: new functions {set,clear}_nonblock, {set,clear}_close_on_exec, {set,get}itimer, inet_addr_any, {get,set}sockopt. * Dynlink library: added support for linking libraries (.cma files). Caml Special Light 1.15: ------------------------ * Caml Special Light now runs under Windows NT and 95. Many thanks to Kevin Gallo (Microsoft Research) who contributed his initial port. * csllex now generates tables for a table-driven automaton. The resulting lexers are smaller and run faster. * Completely automatic configuration script. * Typing: more stringent checking of module type definitions against manifest module type specifications. * Toplevel: recursive definitions of values now working. * Native-code compiler, all platforms: toplevel "let"s with refutable patterns now working; fixed bug in assignment to float record fields; direct support for floating-point negation and absolute value. * Native-code compiler, x86: fixed bug with tail calls (with more than 4 arguments) from a function with a one-word stack frame. * Native-code compiler, Sparc: problem with -compact fixed. * Thread library: support for non-blocking writes; scheduler revised. * Unix library: bug in gethostbyaddr fixed; bounds checking for read, write, etc. Caml Special Light 1.14: ------------------------ * cslopt ported to the PowerPC/RS6000 architecture. Better support for AIX in the bytecode system as well. * cslopt, all platforms: fixed bug in live range splitting around catch/exit. * cslopt for the Intel (floating-point wars, chapter 4): implemented Ershov's algorithm to minimize floating-point stack usage; out-of-order pops fixed. * Several bug fixes in callbacks and signals. Caml Special Light 1.13: ------------------------ * Pattern-matching compilation revised to factor out accesses inside matched structures. * Callbacks and signals now supported in cslopt. Signals are only detected at allocation points, though. Added callback functions with 2 and 3 arguments. * More explicit error messages when a native-code program aborts due to array or string bound violations. * In patterns, "C _" allowed even if the constructor C has several arguments. * && and || allowed as alternate syntax for & and or. * cslopt for the Intel: code generation for floating-point operations entirely redone for the third time (a pox on whomever at Intel decided to organize the floating-point registers as a stack). * cslopt for the Sparc: don't use Sparc V8 smul and sdiv instructions, emulation on V7 processors is abysmal. Caml Special Light 1.12: ------------------------ * Fixed an embarrassing bug with references to floats. Caml Special Light 1.11: ------------------------ * Streams and stream parsers a la Caml Light are back (thanks to Daniel de Rauglaudre). * User-level concurrent threads, with low-level shared memory primitives (locks and conditions) as well as channel-based communication primitives with first-class synchronous events, in the style of Reppy's CML. * The native-code compiler has been ported to the HP PA-RISC processor running under NextStep (sorry, no HPUX, its linker keeps dumping core on me). * References not captured in a function are optimized into variables. * Fixed several bugs related to exceptions. * Floats behave a little more as specified in the IEEE standard (believe it or not, but x < y is not the negation of x >= y). * Lower memory consumption for the native-code compiler. Caml Special Light 1.10: ------------------------ * Many bug fixes (too many to list here). * Module language: introduction of a "with module" notation over signatures for concise sharing of all type components of a signature; better support for concrete types in signatures. * Native-code compiler: the Intel 386 version has been ported to NextStep and FreeBSD, and generates better code (especially for floats) * Tools and libraries: the Caml Light profiler and library for arbitrary-precision arithmetic have been ported (thanks to John Malecki and Victor Manuel Gulias Fernandez); better docs for the Unix and regexp libraries. Caml Special Light 1.07: ------------------------ * Syntax: optional ;; allowed in compilation units and structures (back by popular demand) * cslopt: generic handling of float arrays fixed direct function application when the function expr is not a path fixed compilation of "let rec" over values fixed multiple definitions of a value name in a module correctly handled no calls to ranlib in Solaris * csltop: #trace now working * Standard library: added List.memq; documentation of Array fixed. Caml Special Light 1.06: ------------------------ * First public release. mingw-ocaml/ocaml/otherlibs/0000755000175000017500000000000012124403241015451 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/join/0000755000175000017500000000000012124403241016410 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/join/.gitignore0000644000175000017500000000000012124403241020366 0ustar tootstootsmingw-ocaml/ocaml/otherlibs/str/0000755000175000017500000000000012124403241016261 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/str/libstr.clib0000644000175000017500000000001312124403241020405 0ustar tootstootsstrstubs.o mingw-ocaml/ocaml/otherlibs/str/Makefile0000644000175000017500000000224012124403241017717 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ # Makefile for the str library LIBNAME=str COBJS=strstubs.$(O) CLIBNAME=camlstr CAMLOBJS=str.cmo include ../Makefile depend: str.cmo: str.cmi str.cmx: str.cmi depend: gcc -MM $(CFLAGS) *.c > .depend ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend include .depend mingw-ocaml/ocaml/otherlibs/str/str.mli0000644000175000017500000002723212124403241017602 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Regular expressions and high-level string processing *) (** {6 Regular expressions} *) type regexp (** The type of compiled regular expressions. *) val regexp : string -> regexp (** Compile a regular expression. The following constructs are recognized: - [. ] Matches any character except newline. - [* ] (postfix) Matches the preceding expression zero, one or several times - [+ ] (postfix) Matches the preceding expression one or several times - [? ] (postfix) Matches the preceding expression once or not at all - [[..] ] Character set. Ranges are denoted with [-], as in [[a-z]]. An initial [^], as in [[^0-9]], complements the set. To include a [\]] character in a set, make it the first character of the set. To include a [-] character in a set, make it the first or the last character of the set. - [^ ] Matches at beginning of line (either at the beginning of the matched string, or just after a newline character). - [$ ] Matches at end of line (either at the end of the matched string, or just before a newline character). - [\| ] (infix) Alternative between two expressions. - [\(..\)] Grouping and naming of the enclosed expression. - [\1 ] The text matched by the first [\(...\)] expression ([\2] for the second expression, and so on up to [\9]). - [\b ] Matches word boundaries. - [\ ] Quotes special characters. The special characters are [$^\.*+?[]]. *) val regexp_case_fold : string -> regexp (** Same as [regexp], but the compiled expression will match text in a case-insensitive way: uppercase and lowercase letters will be considered equivalent. *) val quote : string -> string (** [Str.quote s] returns a regexp string that matches exactly [s] and nothing else. *) val regexp_string : string -> regexp (** [Str.regexp_string s] returns a regular expression that matches exactly [s] and nothing else.*) val regexp_string_case_fold : string -> regexp (** [Str.regexp_string_case_fold] is similar to {!Str.regexp_string}, but the regexp matches in a case-insensitive way. *) (** {6 String matching and searching} *) val string_match : regexp -> string -> int -> bool (** [string_match r s start] tests whether a substring of [s] that starts at position [start] matches the regular expression [r]. The first character of a string has position [0], as usual. *) val search_forward : regexp -> string -> int -> int (** [search_forward r s start] searches the string [s] for a substring matching the regular expression [r]. The search starts at position [start] and proceeds towards the end of the string. Return the position of the first character of the matched substring. @raise Not_found if no substring matches. *) val search_backward : regexp -> string -> int -> int (** [search_backward r s last] searches the string [s] for a substring matching the regular expression [r]. The search first considers substrings that start at position [last] and proceeds towards the beginning of string. Return the position of the first character of the matched substring. @raise Not_found if no substring matches. *) val string_partial_match : regexp -> string -> int -> bool (** Similar to {!Str.string_match}, but also returns true if the argument string is a prefix of a string that matches. This includes the case of a true complete match. *) val matched_string : string -> string (** [matched_string s] returns the substring of [s] that was matched by the last call to one of the following matching or searching functions: - {!Str.string_match} - {!Str.search_forward} - {!Str.search_backward} - {!Str.string_partial_match} - {!Str.global_substitute} - {!Str.substitute_first} provided that none of the following functions was called inbetween: - {!Str.global_replace} - {!Str.replace_first} - {!Str.split} - {!Str.bounded_split} - {!Str.split_delim} - {!Str.bounded_split_delim} - {!Str.full_split} - {!Str.bounded_full_split} Note: in the case of [global_substitute] and [substitute_first], a call to [matched_string] is only valid within the [subst] argument, not after [global_substitute] or [substitute_first] returns. The user must make sure that the parameter [s] is the same string that was passed to the matching or searching function. *) val match_beginning : unit -> int (** [match_beginning()] returns the position of the first character of the substring that was matched by the last call to a matching or searching function (see {!Str.matched_string} for details). *) val match_end : unit -> int (** [match_end()] returns the position of the character following the last character of the substring that was matched by the last call to a matching or searching function (see {!Str.matched_string} for details). *) val matched_group : int -> string -> string (** [matched_group n s] returns the substring of [s] that was matched by the [n]th group [\(...\)] of the regular expression that was matched by the last call to a matching or searching function (see {!Str.matched_string} for details). The user must make sure that the parameter [s] is the same string that was passed to the matching or searching function. @raise Not_found if the [n]th group of the regular expression was not matched. This can happen with groups inside alternatives [\|], options [?] or repetitions [*]. For instance, the empty string will match [\(a\)*], but [matched_group 1 ""] will raise [Not_found] because the first group itself was not matched. *) val group_beginning : int -> int (** [group_beginning n] returns the position of the first character of the substring that was matched by the [n]th group of the regular expression that was matched by the last call to a matching or searching function (see {!Str.matched_string} for details). @raise Not_found if the [n]th group of the regular expression was not matched. @raise Invalid_argument if there are fewer than [n] groups in the regular expression. *) val group_end : int -> int (** [group_end n] returns the position of the character following the last character of substring that was matched by the [n]th group of the regular expression that was matched by the last call to a matching or searching function (see {!Str.matched_string} for details). @raise Not_found if the [n]th group of the regular expression was not matched. @raise Invalid_argument if there are fewer than [n] groups in the regular expression. *) (** {6 Replacement} *) val global_replace : regexp -> string -> string -> string (** [global_replace regexp templ s] returns a string identical to [s], except that all substrings of [s] that match [regexp] have been replaced by [templ]. The replacement template [templ] can contain [\1], [\2], etc; these sequences will be replaced by the text matched by the corresponding group in the regular expression. [\0] stands for the text matched by the whole regular expression. *) val replace_first : regexp -> string -> string -> string (** Same as {!Str.global_replace}, except that only the first substring matching the regular expression is replaced. *) val global_substitute : regexp -> (string -> string) -> string -> string (** [global_substitute regexp subst s] returns a string identical to [s], except that all substrings of [s] that match [regexp] have been replaced by the result of function [subst]. The function [subst] is called once for each matching substring, and receives [s] (the whole text) as argument. *) val substitute_first : regexp -> (string -> string) -> string -> string (** Same as {!Str.global_substitute}, except that only the first substring matching the regular expression is replaced. *) val replace_matched : string -> string -> string (** [replace_matched repl s] returns the replacement text [repl] in which [\1], [\2], etc. have been replaced by the text matched by the corresponding groups in the regular expression that was matched by the last call to a matching or searching function (see {!Str.matched_string} for details). [s] must be the same string that was passed to the matching or searching function. *) (** {6 Splitting} *) val split : regexp -> string -> string list (** [split r s] splits [s] into substrings, taking as delimiters the substrings that match [r], and returns the list of substrings. For instance, [split (regexp "[ \t]+") s] splits [s] into blank-separated words. An occurrence of the delimiter at the beginning or at the end of the string is ignored. *) val bounded_split : regexp -> string -> int -> string list (** Same as {!Str.split}, but splits into at most [n] substrings, where [n] is the extra integer parameter. *) val split_delim : regexp -> string -> string list (** Same as {!Str.split} but occurrences of the delimiter at the beginning and at the end of the string are recognized and returned as empty strings in the result. For instance, [split_delim (regexp " ") " abc "] returns [[""; "abc"; ""]], while [split] with the same arguments returns [["abc"]]. *) val bounded_split_delim : regexp -> string -> int -> string list (** Same as {!Str.bounded_split}, but occurrences of the delimiter at the beginning and at the end of the string are recognized and returned as empty strings in the result. *) type split_result = Text of string | Delim of string val full_split : regexp -> string -> split_result list (** Same as {!Str.split_delim}, but returns the delimiters as well as the substrings contained between delimiters. The former are tagged [Delim] in the result list; the latter are tagged [Text]. For instance, [full_split (regexp "[{}]") "{ab}"] returns [[Delim "{"; Text "ab"; Delim "}"]]. *) val bounded_full_split : regexp -> string -> int -> split_result list (** Same as {!Str.bounded_split_delim}, but returns the delimiters as well as the substrings contained between delimiters. The former are tagged [Delim] in the result list; the latter are tagged [Text]. *) (** {6 Extracting substrings} *) val string_before : string -> int -> string (** [string_before s n] returns the substring of all characters of [s] that precede position [n] (excluding the character at position [n]). *) val string_after : string -> int -> string (** [string_after s n] returns the substring of all characters of [s] that follow position [n] (including the character at position [n]). *) val first_chars : string -> int -> string (** [first_chars s n] returns the first [n] characters of [s]. This is the same function as {!Str.string_before}. *) val last_chars : string -> int -> string (** [last_chars s n] returns the last [n] characters of [s]. *) mingw-ocaml/ocaml/otherlibs/str/Makefile.nt0000644000175000017500000000204712124403241020344 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ # Makefile for the str library LIBNAME=str COBJS=strstubs.$(O) CLIBNAME=camlstr CAMLOBJS=str.cmo include ../Makefile.nt depend: str.cmo: str.cmi str.cmx: str.cmi mingw-ocaml/ocaml/otherlibs/str/strstubs.c0000644000175000017500000003735612124403241020334 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include /* The backtracking NFA interpreter */ union backtrack_point { struct { value * pc; /* with low bit set */ unsigned char * txt; } pos; struct { unsigned char ** loc; /* with low bit clear */ unsigned char * val; } undo; }; #define Set_tag(p) ((value *) ((intnat)(p) | 1)) #define Clear_tag(p) ((value *) ((intnat)(p) & ~1)) #define Tag_is_set(p) ((intnat)(p) & 1) #define BACKTRACK_STACK_BLOCK_SIZE 500 struct backtrack_stack { struct backtrack_stack * previous; union backtrack_point point[BACKTRACK_STACK_BLOCK_SIZE]; }; #define Opcode(x) ((x) & 0xFF) #define Arg(x) ((uintnat)(x) >> 8) #define SignedArg(x) ((intnat)(x) >> 8) enum { CHAR, /* match a single character */ CHARNORM, /* match a single character, after normalization */ STRING, /* match a character string */ STRINGNORM, /* match a character string, after normalization */ CHARCLASS, /* match a character class */ BOL, /* match at beginning of line */ EOL, /* match at end of line */ WORDBOUNDARY, /* match on a word boundary */ BEGGROUP, /* record the beginning of a group */ ENDGROUP, /* record the end of a group */ REFGROUP, /* match a previously matched group */ ACCEPT, /* report success */ SIMPLEOPT, /* match a character class 0 or 1 times */ SIMPLESTAR, /* match a character class 0, 1 or several times */ SIMPLEPLUS, /* match a character class 1 or several times */ GOTO, /* unconditional branch */ PUSHBACK, /* record a backtrack point -- where to jump in case of failure */ SETMARK, /* remember current position in given register # */ CHECKPROGRESS /* backtrack if no progress was made w.r.t. reg # */ }; /* Accessors in a compiled regexp */ #define Prog(re) Field(re, 0) #define Cpool(re) Field(re, 1) #define Normtable(re) Field(re, 2) #define Numgroups(re) Int_val(Field(re, 3)) #define Numregisters(re) Int_val(Field(re, 4)) #define Startchars(re) Int_val(Field(re, 5)) /* Record positions of matched groups */ #define NUM_GROUPS 32 struct re_group { unsigned char * start; unsigned char * end; }; static struct re_group re_group[NUM_GROUPS]; /* Record positions reached during matching; used to check progress in repeated matching of a regexp. */ #define NUM_REGISTERS 64 static unsigned char * re_register[NUM_REGISTERS]; /* The initial backtracking stack */ static struct backtrack_stack initial_stack = { NULL, }; /* Free a chained list of backtracking stacks */ static void free_backtrack_stack(struct backtrack_stack * stack) { struct backtrack_stack * prevstack; while ((prevstack = stack->previous) != NULL) { stat_free(stack); stack = prevstack; } } /* Membership in a bit vector representing a set of booleans */ #define In_bitset(s,i,tmp) (tmp = (i), ((s)[tmp >> 3] >> (tmp & 7)) & 1) /* Determine if a character is a word constituent */ /* PR#4874: word constituent = letter, digit, underscore. */ static unsigned char re_word_letters[32] = { 0x00, 0x00, 0x00, 0x00, /* 0x00-0x1F: none */ 0x00, 0x00, 0xFF, 0x03, /* 0x20-0x3F: digits 0-9 */ 0xFE, 0xFF, 0xFF, 0x87, /* 0x40-0x5F: A to Z, _ */ 0xFE, 0xFF, 0xFF, 0x07, /* 0x60-0x7F: a to z */ 0x00, 0x00, 0x00, 0x00, /* 0x80-0x9F: none */ 0x00, 0x00, 0x00, 0x00, /* 0xA0-0xBF: none */ 0xFF, 0xFF, 0x7F, 0xFF, /* 0xC0-0xDF: Latin-1 accented uppercase */ 0xFF, 0xFF, 0x7F, 0xFF /* 0xE0-0xFF: Latin-1 accented lowercase */ }; #define Is_word_letter(c) ((re_word_letters[(c) >> 3] >> ((c) & 7)) & 1) /* The bytecode interpreter for the NFA */ static int re_match(value re, unsigned char * starttxt, register unsigned char * txt, register unsigned char * endtxt, int accept_partial_match) { register value * pc; intnat instr; struct backtrack_stack * stack; union backtrack_point * sp; value cpool; value normtable; unsigned char c; union backtrack_point back; { int i; struct re_group * p; unsigned char ** q; for (p = &re_group[1], i = Numgroups(re); i > 1; i--, p++) p->start = p->end = NULL; for (q = &re_register[0], i = Numregisters(re); i > 0; i--, q++) *q = NULL; } pc = &Field(Prog(re), 0); stack = &initial_stack; sp = stack->point; cpool = Cpool(re); normtable = Normtable(re); re_group[0].start = txt; while (1) { instr = Long_val(*pc++); switch (Opcode(instr)) { case CHAR: if (txt == endtxt) goto prefix_match; if (*txt != Arg(instr)) goto backtrack; txt++; break; case CHARNORM: if (txt == endtxt) goto prefix_match; if (Byte_u(normtable, *txt) != Arg(instr)) goto backtrack; txt++; break; case STRING: { unsigned char * s = (unsigned char *) String_val(Field(cpool, Arg(instr))); while ((c = *s++) != 0) { if (txt == endtxt) goto prefix_match; if (c != *txt) goto backtrack; txt++; } break; } case STRINGNORM: { unsigned char * s = (unsigned char *) String_val(Field(cpool, Arg(instr))); while ((c = *s++) != 0) { if (txt == endtxt) goto prefix_match; if (c != Byte_u(normtable, *txt)) goto backtrack; txt++; } break; } case CHARCLASS: if (txt == endtxt) goto prefix_match; if (! In_bitset(String_val(Field(cpool, Arg(instr))), *txt, c)) goto backtrack; txt++; break; case BOL: if (txt > starttxt && txt[-1] != '\n') goto backtrack; break; case EOL: if (txt < endtxt && *txt != '\n') goto backtrack; break; case WORDBOUNDARY: /* At beginning and end of text: no At beginning of text: OK if current char is a letter At end of text: OK if previous char is a letter Otherwise: OK if previous char is a letter and current char not a letter or previous char is not a letter and current char is a letter */ if (txt == starttxt) { if (txt == endtxt) goto prefix_match; if (Is_word_letter(txt[0])) break; goto backtrack; } else if (txt == endtxt) { if (Is_word_letter(txt[-1])) break; goto backtrack; } else { if (Is_word_letter(txt[-1]) != Is_word_letter(txt[0])) break; goto backtrack; } case BEGGROUP: { int group_no = Arg(instr); struct re_group * group = &(re_group[group_no]); back.undo.loc = &(group->start); back.undo.val = group->start; group->start = txt; goto push; } case ENDGROUP: { int group_no = Arg(instr); struct re_group * group = &(re_group[group_no]); back.undo.loc = &(group->end); back.undo.val = group->end; group->end = txt; goto push; } case REFGROUP: { int group_no = Arg(instr); struct re_group * group = &(re_group[group_no]); unsigned char * s; if (group->start == NULL || group->end == NULL) goto backtrack; for (s = group->start; s < group->end; s++) { if (txt == endtxt) goto prefix_match; if (*s != *txt) goto backtrack; txt++; } break; } case ACCEPT: goto accept; case SIMPLEOPT: { char * set = String_val(Field(cpool, Arg(instr))); if (txt < endtxt && In_bitset(set, *txt, c)) txt++; break; } case SIMPLESTAR: { char * set = String_val(Field(cpool, Arg(instr))); while (txt < endtxt && In_bitset(set, *txt, c)) txt++; break; } case SIMPLEPLUS: { char * set = String_val(Field(cpool, Arg(instr))); if (txt == endtxt) goto prefix_match; if (! In_bitset(set, *txt, c)) goto backtrack; txt++; while (txt < endtxt && In_bitset(set, *txt, c)) txt++; break; } case GOTO: pc = pc + SignedArg(instr); break; case PUSHBACK: back.pos.pc = Set_tag(pc + SignedArg(instr)); back.pos.txt = txt; goto push; case SETMARK: { int reg_no = Arg(instr); unsigned char ** reg = &(re_register[reg_no]); back.undo.loc = reg; back.undo.val = *reg; *reg = txt; goto push; } case CHECKPROGRESS: { int reg_no = Arg(instr); if (re_register[reg_no] == txt) goto backtrack; break; } default: caml_fatal_error ("impossible case in re_match"); } /* Continue with next instruction */ continue; push: /* Push an item on the backtrack stack and continue with next instr */ if (sp == stack->point + BACKTRACK_STACK_BLOCK_SIZE) { struct backtrack_stack * newstack = stat_alloc(sizeof(struct backtrack_stack)); newstack->previous = stack; stack = newstack; sp = stack->point; } *sp = back; sp++; continue; prefix_match: /* We get here when matching failed because the end of text was encountered. */ if (accept_partial_match) goto accept; backtrack: /* We get here when matching fails. Backtrack to most recent saved program point, undoing variable assignments on the way. */ while (1) { if (sp == stack->point) { struct backtrack_stack * prevstack = stack->previous; if (prevstack == NULL) return 0; stat_free(stack); stack = prevstack; sp = stack->point + BACKTRACK_STACK_BLOCK_SIZE; } sp--; if (Tag_is_set(sp->pos.pc)) { pc = Clear_tag(sp->pos.pc); txt = sp->pos.txt; break; } else { *(sp->undo.loc) = sp->undo.val; } } continue; } accept: /* We get here when the regexp was successfully matched */ free_backtrack_stack(stack); re_group[0].end = txt; return 1; } /* Allocate an integer array containing the positions of the matched groups. Beginning of group #N is at 2N, end is at 2N+1. Take position = -1 when group wasn't matched. */ static value re_alloc_groups(value re, value str) { CAMLparam1(str); CAMLlocal1(res); unsigned char * starttxt = (unsigned char *) String_val(str); int n = Numgroups(re); int i; struct re_group * group; res = alloc(n * 2, 0); for (i = 0; i < n; i++) { group = &(re_group[i]); if (group->start == NULL || group->end == NULL) { Field(res, i * 2) = Val_int(-1); Field(res, i * 2 + 1) = Val_int(-1); } else { Field(res, i * 2) = Val_long(group->start - starttxt); Field(res, i * 2 + 1) = Val_long(group->end - starttxt); } } CAMLreturn(res); } /* String matching and searching. All functions return the empty array on failure, and an array of positions on success. */ CAMLprim value re_string_match(value re, value str, value pos) { unsigned char * starttxt = &Byte_u(str, 0); unsigned char * txt = &Byte_u(str, Long_val(pos)); unsigned char * endtxt = &Byte_u(str, string_length(str)); if (txt < starttxt || txt > endtxt) invalid_argument("Str.string_match"); if (re_match(re, starttxt, txt, endtxt, 0)) { return re_alloc_groups(re, str); } else { return Atom(0); } } CAMLprim value re_partial_match(value re, value str, value pos) { unsigned char * starttxt = &Byte_u(str, 0); unsigned char * txt = &Byte_u(str, Long_val(pos)); unsigned char * endtxt = &Byte_u(str, string_length(str)); if (txt < starttxt || txt > endtxt) invalid_argument("Str.string_partial_match"); if (re_match(re, starttxt, txt, endtxt, 1)) { return re_alloc_groups(re, str); } else { return Atom(0); } } CAMLprim value re_search_forward(value re, value str, value startpos) { unsigned char * starttxt = &Byte_u(str, 0); unsigned char * txt = &Byte_u(str, Long_val(startpos)); unsigned char * endtxt = &Byte_u(str, string_length(str)); unsigned char * startchars; if (txt < starttxt || txt > endtxt) invalid_argument("Str.search_forward"); if (Startchars(re) == -1) { do { if (re_match(re, starttxt, txt, endtxt, 0)) return re_alloc_groups(re, str); txt++; } while (txt <= endtxt); return Atom(0); } else { startchars = (unsigned char *) String_val(Field(Cpool(re), Startchars(re))); do { while (txt < endtxt && startchars[*txt] == 0) txt++; if (re_match(re, starttxt, txt, endtxt, 0)) return re_alloc_groups(re, str); txt++; } while (txt <= endtxt); return Atom(0); } } CAMLprim value re_search_backward(value re, value str, value startpos) { unsigned char * starttxt = &Byte_u(str, 0); unsigned char * txt = &Byte_u(str, Long_val(startpos)); unsigned char * endtxt = &Byte_u(str, string_length(str)); unsigned char * startchars; if (txt < starttxt || txt > endtxt) invalid_argument("Str.search_backward"); if (Startchars(re) == -1) { do { if (re_match(re, starttxt, txt, endtxt, 0)) return re_alloc_groups(re, str); txt--; } while (txt >= starttxt); return Atom(0); } else { startchars = (unsigned char *) String_val(Field(Cpool(re), Startchars(re))); do { while (txt > starttxt && startchars[*txt] == 0) txt--; if (re_match(re, starttxt, txt, endtxt, 0)) return re_alloc_groups(re, str); txt--; } while (txt >= starttxt); return Atom(0); } } /* Replacement */ CAMLprim value re_replacement_text(value repl, value groups, value orig) { CAMLparam3(repl, groups, orig); CAMLlocal1(res); mlsize_t start, end, len, n; char * p, * q; int c; len = 0; p = String_val(repl); n = string_length(repl); while (n > 0) { c = *p++; n--; if(c != '\\') len++; else { if (n == 0) failwith("Str.replace: illegal backslash sequence"); c = *p++; n--; switch (c) { case '\\': len++; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': c -= '0'; if (c*2 >= Wosize_val(groups)) failwith("Str.replace: reference to unmatched group"); start = Long_val(Field(groups, c*2)); end = Long_val(Field(groups, c*2 + 1)); if (start == (mlsize_t) -1) failwith("Str.replace: reference to unmatched group"); len += end - start; break; default: len += 2; break; } } } res = alloc_string(len); p = String_val(repl); q = String_val(res); n = string_length(repl); while (n > 0) { c = *p++; n--; if(c != '\\') *q++ = c; else { c = *p++; n--; switch (c) { case '\\': *q++ = '\\'; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': c -= '0'; start = Long_val(Field(groups, c*2)); end = Long_val(Field(groups, c*2 + 1)); len = end - start; memmove (q, &Byte(orig, start), len); q += len; break; default: *q++ = '\\'; *q++ = c; break; } } } CAMLreturn(res); } mingw-ocaml/ocaml/otherlibs/str/str.ml0000644000175000017500000005445212124403241017435 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** String utilities *) let string_before s n = String.sub s 0 n let string_after s n = String.sub s n (String.length s - n) let first_chars s n = String.sub s 0 n let last_chars s n = String.sub s (String.length s - n) n (** Representation of character sets **) module Charset = struct type t = string (* of length 32 *) (*let empty = String.make 32 '\000'*) let full = String.make 32 '\255' let make_empty () = String.make 32 '\000' let add s c = let i = Char.code c in s.[i lsr 3] <- Char.chr(Char.code s.[i lsr 3] lor (1 lsl (i land 7))) let add_range s c1 c2 = for i = Char.code c1 to Char.code c2 do add s (Char.chr i) done let singleton c = let s = make_empty () in add s c; s (*let range c1 c2 = let s = make_empty () in add_range s c1 c2; s *) let complement s = let r = String.create 32 in for i = 0 to 31 do r.[i] <- Char.chr(Char.code s.[i] lxor 0xFF) done; r let union s1 s2 = let r = String.create 32 in for i = 0 to 31 do r.[i] <- Char.chr(Char.code s1.[i] lor Char.code s2.[i]) done; r let disjoint s1 s2 = try for i = 0 to 31 do if Char.code s1.[i] land Char.code s2.[i] <> 0 then raise Exit done; true with Exit -> false let iter fn s = for i = 0 to 31 do let c = Char.code s.[i] in if c <> 0 then for j = 0 to 7 do if c land (1 lsl j) <> 0 then fn (Char.chr ((i lsl 3) + j)) done done let expand s = let r = String.make 256 '\000' in iter (fun c -> r.[Char.code c] <- '\001') s; r let fold_case s = let r = make_empty() in iter (fun c -> add r (Char.lowercase c); add r (Char.uppercase c)) s; r end (** Abstract syntax tree for regular expressions *) type re_syntax = Char of char | String of string | CharClass of Charset.t * bool (* true = complemented, false = normal *) | Seq of re_syntax list | Alt of re_syntax * re_syntax | Star of re_syntax | Plus of re_syntax | Option of re_syntax | Group of int * re_syntax | Refgroup of int | Bol | Eol | Wordboundary (** Representation of compiled regular expressions *) type regexp = { prog: int array; (* bytecode instructions *) cpool: string array; (* constant pool (string literals) *) normtable: string; (* case folding table (if any) *) numgroups: int; (* number of \(...\) groups *) numregisters: int; (* number of nullable Star or Plus *) startchars: int (* index of set of starting chars, or -1 if none *) } (** Opcodes for bytecode instructions; see strstubs.c for description *) let op_CHAR = 0 let op_CHARNORM = 1 let op_STRING = 2 let op_STRINGNORM = 3 let op_CHARCLASS = 4 let op_BOL = 5 let op_EOL = 6 let op_WORDBOUNDARY = 7 let op_BEGGROUP = 8 let op_ENDGROUP = 9 let op_REFGROUP = 10 let op_ACCEPT = 11 let op_SIMPLEOPT = 12 let op_SIMPLESTAR = 13 let op_SIMPLEPLUS = 14 let op_GOTO = 15 let op_PUSHBACK = 16 let op_SETMARK = 17 let op_CHECKPROGRESS = 18 (* Encoding of bytecode instructions *) let instr opc arg = opc lor (arg lsl 8) (* Computing relative displacements for GOTO and PUSHBACK instructions *) let displ dest from = dest - from - 1 (** Compilation of a regular expression *) (* Determine if a regexp can match the empty string *) let rec is_nullable = function Char c -> false | String s -> s = "" | CharClass(cl, cmpl) -> false | Seq rl -> List.for_all is_nullable rl | Alt (r1, r2) -> is_nullable r1 || is_nullable r2 | Star r -> true | Plus r -> is_nullable r | Option r -> true | Group(n, r) -> is_nullable r | Refgroup n -> true | Bol -> true | Eol -> true | Wordboundary -> true (* first r returns a set of characters C such that: for all string s, s matches r => the first character of s is in C. For convenience, return Charset.full if r is nullable. *) let rec first = function Char c -> Charset.singleton c | String s -> if s = "" then Charset.full else Charset.singleton s.[0] | CharClass(cl, cmpl) -> if cmpl then Charset.complement cl else cl | Seq rl -> first_seq rl | Alt (r1, r2) -> Charset.union (first r1) (first r2) | Star r -> Charset.full | Plus r -> first r | Option r -> Charset.full | Group(n, r) -> first r | Refgroup n -> Charset.full | Bol -> Charset.full | Eol -> Charset.full | Wordboundary -> Charset.full and first_seq = function [] -> Charset.full | (Bol | Eol | Wordboundary) :: rl -> first_seq rl | Star r :: rl -> Charset.union (first r) (first_seq rl) | Option r :: rl -> Charset.union (first r) (first_seq rl) | r :: rl -> first r (* Transform a Char or CharClass regexp into a character class *) let charclass_of_regexp fold_case re = let (cl1, compl) = match re with | Char c -> (Charset.singleton c, false) | CharClass(cl, compl) -> (cl, compl) | _ -> assert false in let cl2 = if fold_case then Charset.fold_case cl1 else cl1 in if compl then Charset.complement cl2 else cl2 (* The case fold table: maps characters to their lowercase equivalent *) let fold_case_table = let t = String.create 256 in for i = 0 to 255 do t.[i] <- Char.lowercase(Char.chr i) done; t module StringMap = Map.Make(struct type t = string let compare = compare end) (* Compilation of a regular expression *) let compile fold_case re = (* Instruction buffering *) let prog = ref (Array.make 32 0) and progpos = ref 0 and cpool = ref StringMap.empty and cpoolpos = ref 0 and numgroups = ref 1 and numregs = ref 0 in (* Add a new instruction *) let emit_instr opc arg = if !progpos >= Array.length !prog then begin let newlen = ref (Array.length !prog) in while !progpos >= !newlen do newlen := !newlen * 2 done; let nprog = Array.make !newlen 0 in Array.blit !prog 0 nprog 0 (Array.length !prog); prog := nprog end; (!prog).(!progpos) <- (instr opc arg); incr progpos in (* Reserve an instruction slot and return its position *) let emit_hole () = let p = !progpos in incr progpos; p in (* Fill a reserved instruction slot with a GOTO or PUSHBACK instruction *) let patch_instr pos opc dest = (!prog).(pos) <- (instr opc (displ dest pos)) in (* Return the cpool index for the given string, adding it if not already there *) let cpool_index s = try StringMap.find s !cpool with Not_found -> let p = !cpoolpos in cpool := StringMap.add s p !cpool; incr cpoolpos; p in (* Allocate fresh register if regexp is nullable *) let allocate_register_if_nullable r = if is_nullable r then begin let n = !numregs in if n >= 64 then failwith "too many r* or r+ where r is nullable"; incr numregs; n end else -1 in (* Main recursive compilation function *) let rec emit_code = function Char c -> if fold_case then emit_instr op_CHARNORM (Char.code (Char.lowercase c)) else emit_instr op_CHAR (Char.code c) | String s -> begin match String.length s with 0 -> () | 1 -> if fold_case then emit_instr op_CHARNORM (Char.code (Char.lowercase s.[0])) else emit_instr op_CHAR (Char.code s.[0]) | _ -> try (* null characters are not accepted by the STRING* instructions; if one is found, split string at null character *) let i = String.index s '\000' in emit_code (String (string_before s i)); emit_instr op_CHAR 0; emit_code (String (string_after s (i+1))) with Not_found -> if fold_case then emit_instr op_STRINGNORM (cpool_index (String.lowercase s)) else emit_instr op_STRING (cpool_index s) end | CharClass(cl, compl) -> let cl1 = if fold_case then Charset.fold_case cl else cl in let cl2 = if compl then Charset.complement cl1 else cl1 in emit_instr op_CHARCLASS (cpool_index cl2) | Seq rl -> emit_seq_code rl | Alt(r1, r2) -> (* PUSHBACK lbl1 GOTO lbl2 lbl1: lbl2: ... *) let pos_pushback = emit_hole() in emit_code r1; let pos_goto_end = emit_hole() in let lbl1 = !progpos in emit_code r2; let lbl2 = !progpos in patch_instr pos_pushback op_PUSHBACK lbl1; patch_instr pos_goto_end op_GOTO lbl2 | Star r -> (* Implement longest match semantics for compatibility with old Str *) (* General translation: lbl1: PUSHBACK lbl2 SETMARK regno CHECKPROGRESS regno GOTO lbl1 lbl2: If r cannot match the empty string, code can be simplified: lbl1: PUSHBACK lbl2 GOTO lbl1 lbl2: *) let regno = allocate_register_if_nullable r in let lbl1 = emit_hole() in if regno >= 0 then emit_instr op_SETMARK regno; emit_code r; if regno >= 0 then emit_instr op_CHECKPROGRESS regno; emit_instr op_GOTO (displ lbl1 !progpos); let lbl2 = !progpos in patch_instr lbl1 op_PUSHBACK lbl2 | Plus r -> (* Implement longest match semantics for compatibility with old Str *) (* General translation: lbl1: CHECKPROGRESS regno PUSHBACK lbl2 SETMARK regno GOTO lbl1 lbl2: If r cannot match the empty string, code can be simplified: lbl1: PUSHBACK lbl2 GOTO_PLUS lbl1 lbl2: *) let regno = allocate_register_if_nullable r in let lbl1 = !progpos in emit_code r; if regno >= 0 then emit_instr op_CHECKPROGRESS regno; let pos_pushback = emit_hole() in if regno >= 0 then emit_instr op_SETMARK regno; emit_instr op_GOTO (displ lbl1 !progpos); let lbl2 = !progpos in patch_instr pos_pushback op_PUSHBACK lbl2 | Option r -> (* Implement longest match semantics for compatibility with old Str *) (* PUSHBACK lbl lbl: *) let pos_pushback = emit_hole() in emit_code r; let lbl = !progpos in patch_instr pos_pushback op_PUSHBACK lbl | Group(n, r) -> if n >= 32 then failwith "too many \\(...\\) groups"; emit_instr op_BEGGROUP n; emit_code r; emit_instr op_ENDGROUP n; numgroups := max !numgroups (n+1) | Refgroup n -> emit_instr op_REFGROUP n | Bol -> emit_instr op_BOL 0 | Eol -> emit_instr op_EOL 0 | Wordboundary -> emit_instr op_WORDBOUNDARY 0 and emit_seq_code = function [] -> () | Star(Char _ | CharClass _ as r) :: rl when disjoint_modulo_case (first r) (first_seq rl) -> emit_instr op_SIMPLESTAR (cpool_index (charclass_of_regexp fold_case r)); emit_seq_code rl | Plus(Char _ | CharClass _ as r) :: rl when disjoint_modulo_case (first r) (first_seq rl) -> emit_instr op_SIMPLEPLUS (cpool_index (charclass_of_regexp fold_case r)); emit_seq_code rl | Option(Char _ | CharClass _ as r) :: rl when disjoint_modulo_case (first r) (first_seq rl) -> emit_instr op_SIMPLEOPT (cpool_index (charclass_of_regexp fold_case r)); emit_seq_code rl | r :: rl -> emit_code r; emit_seq_code rl and disjoint_modulo_case c1 c2 = if fold_case then Charset.disjoint (Charset.fold_case c1) (Charset.fold_case c2) else Charset.disjoint c1 c2 in emit_code re; emit_instr op_ACCEPT 0; let start = first re in let start' = if fold_case then Charset.fold_case start else start in let start_pos = if start = Charset.full then -1 else cpool_index (Charset.expand start') in let constantpool = Array.make !cpoolpos "" in StringMap.iter (fun str idx -> constantpool.(idx) <- str) !cpool; { prog = Array.sub !prog 0 !progpos; cpool = constantpool; normtable = if fold_case then fold_case_table else ""; numgroups = !numgroups; numregisters = !numregs; startchars = start_pos } (** Parsing of a regular expression *) (* Efficient buffering of sequences *) module SeqBuffer = struct type t = { sb_chars: Buffer.t; mutable sb_next: re_syntax list } let create() = { sb_chars = Buffer.create 16; sb_next = [] } let flush buf = let s = Buffer.contents buf.sb_chars in Buffer.clear buf.sb_chars; match String.length s with 0 -> () | 1 -> buf.sb_next <- Char s.[0] :: buf.sb_next | _ -> buf.sb_next <- String s :: buf.sb_next let add buf re = match re with Char c -> Buffer.add_char buf.sb_chars c | _ -> flush buf; buf.sb_next <- re :: buf.sb_next let extract buf = flush buf; Seq(List.rev buf.sb_next) end (* The character class corresponding to `.' *) let dotclass = Charset.complement (Charset.singleton '\n') (* Parse a regular expression *) let parse s = let len = String.length s in let group_counter = ref 1 in let rec regexp0 i = let (r, j) = regexp1 i in regexp0cont r j and regexp0cont r1 i = if i + 2 <= len && s.[i] = '\\' && s.[i+1] = '|' then let (r2, j) = regexp1 (i+2) in regexp0cont (Alt(r1, r2)) j else (r1, i) and regexp1 i = regexp1cont (SeqBuffer.create()) i and regexp1cont sb i = if i >= len || i + 2 <= len && s.[i] = '\\' && (let c = s.[i+1] in c = '|' || c = ')') then (SeqBuffer.extract sb, i) else let (r, j) = regexp2 i in SeqBuffer.add sb r; regexp1cont sb j and regexp2 i = let (r, j) = regexp3 i in regexp2cont r j and regexp2cont r i = if i >= len then (r, i) else match s.[i] with '?' -> regexp2cont (Option r) (i+1) | '*' -> regexp2cont (Star r) (i+1) | '+' -> regexp2cont (Plus r) (i+1) | _ -> (r, i) and regexp3 i = match s.[i] with '\\' -> regexpbackslash (i+1) | '[' -> let (c, compl, j) = regexpclass0 (i+1) in (CharClass(c, compl), j) | '^' -> (Bol, i+1) | '$' -> (Eol, i+1) | '.' -> (CharClass(dotclass, false), i+1) | c -> (Char c, i+1) and regexpbackslash i = if i >= len then (Char '\\', i) else match s.[i] with '|' | ')' -> assert false | '(' -> let group_no = !group_counter in if group_no < 32 then incr group_counter; let (r, j) = regexp0 (i+1) in if j + 1 < len && s.[j] = '\\' && s.[j+1] = ')' then if group_no < 32 then (Group(group_no, r), j + 2) else (r, j + 2) else failwith "\\( group not closed by \\)" | '1' .. '9' as c -> (Refgroup(Char.code c - 48), i + 1) | 'b' -> (Wordboundary, i + 1) | c -> (Char c, i + 1) and regexpclass0 i = if i < len && s.[i] = '^' then let (c, j) = regexpclass1 (i+1) in (c, true, j) else let (c, j) = regexpclass1 i in (c, false, j) and regexpclass1 i = let c = Charset.make_empty() in let j = regexpclass2 c i i in (c, j) and regexpclass2 c start i = if i >= len then failwith "[ class not closed by ]"; if s.[i] = ']' && i > start then i+1 else begin let c1 = s.[i] in if i+2 < len && s.[i+1] = '-' && s.[i+2] <> ']' then begin let c2 = s.[i+2] in Charset.add_range c c1 c2; regexpclass2 c start (i+3) end else begin Charset.add c c1; regexpclass2 c start (i+1) end end in let (r, j) = regexp0 0 in if j = len then r else failwith "spurious \\) in regular expression" (** Parsing and compilation *) let regexp e = compile false (parse e) let regexp_case_fold e = compile true (parse e) let quote s = let len = String.length s in let buf = String.create (2 * len) in let pos = ref 0 in for i = 0 to len - 1 do match s.[i] with '[' | ']' | '*' | '.' | '\\' | '?' | '+' | '^' | '$' as c -> buf.[!pos] <- '\\'; buf.[!pos + 1] <- c; pos := !pos + 2 | c -> buf.[!pos] <- c; pos := !pos + 1 done; String.sub buf 0 !pos let regexp_string s = compile false (String s) let regexp_string_case_fold s = compile true (String s) (** Matching functions **) external re_string_match: regexp -> string -> int -> int array = "re_string_match" external re_partial_match: regexp -> string -> int -> int array = "re_partial_match" external re_search_forward: regexp -> string -> int -> int array = "re_search_forward" external re_search_backward: regexp -> string -> int -> int array = "re_search_backward" let last_search_result = ref [||] let string_match re s pos = let res = re_string_match re s pos in last_search_result := res; Array.length res > 0 let string_partial_match re s pos = let res = re_partial_match re s pos in last_search_result := res; Array.length res > 0 let search_forward re s pos = let res = re_search_forward re s pos in last_search_result := res; if Array.length res = 0 then raise Not_found else res.(0) let search_backward re s pos = let res = re_search_backward re s pos in last_search_result := res; if Array.length res = 0 then raise Not_found else res.(0) let group_beginning n = let n2 = n + n in if n < 0 || n2 >= Array.length !last_search_result then invalid_arg "Str.group_beginning" else let pos = !last_search_result.(n2) in if pos = -1 then raise Not_found else pos let group_end n = let n2 = n + n in if n < 0 || n2 >= Array.length !last_search_result then invalid_arg "Str.group_end" else let pos = !last_search_result.(n2 + 1) in if pos = -1 then raise Not_found else pos let matched_group n txt = let n2 = n + n in if n < 0 || n2 >= Array.length !last_search_result then invalid_arg "Str.matched_group" else let b = !last_search_result.(n2) and e = !last_search_result.(n2 + 1) in if b = -1 then raise Not_found else String.sub txt b (e - b) let match_beginning () = group_beginning 0 and match_end () = group_end 0 and matched_string txt = matched_group 0 txt (** Replacement **) external re_replacement_text: string -> int array -> string -> string = "re_replacement_text" let replace_matched repl matched = re_replacement_text repl !last_search_result matched let substitute_first expr repl_fun text = try let pos = search_forward expr text 0 in String.concat "" [string_before text pos; repl_fun text; string_after text (match_end())] with Not_found -> text let opt_search_forward re s pos = try Some(search_forward re s pos) with Not_found -> None let global_substitute expr repl_fun text = let rec replace accu start last_was_empty = let startpos = if last_was_empty then start + 1 else start in if startpos > String.length text then string_after text start :: accu else match opt_search_forward expr text startpos with | None -> string_after text start :: accu | Some pos -> let end_pos = match_end() in let repl_text = repl_fun text in replace (repl_text :: String.sub text start (pos-start) :: accu) end_pos (end_pos = pos) in String.concat "" (List.rev (replace [] 0 false)) let global_replace expr repl text = global_substitute expr (replace_matched repl) text and replace_first expr repl text = substitute_first expr (replace_matched repl) text (** Splitting *) let opt_search_forward_progress expr text start = match opt_search_forward expr text start with | None -> None | Some pos -> if match_end() > start then Some pos else if start < String.length text then opt_search_forward expr text (start + 1) else None let bounded_split expr text num = let start = if string_match expr text 0 then match_end() else 0 in let rec split accu start n = if start >= String.length text then accu else if n = 1 then string_after text start :: accu else match opt_search_forward_progress expr text start with | None -> string_after text start :: accu | Some pos -> split (String.sub text start (pos-start) :: accu) (match_end()) (n-1) in List.rev (split [] start num) let split expr text = bounded_split expr text 0 let bounded_split_delim expr text num = let rec split accu start n = if start > String.length text then accu else if n = 1 then string_after text start :: accu else match opt_search_forward_progress expr text start with | None -> string_after text start :: accu | Some pos -> split (String.sub text start (pos-start) :: accu) (match_end()) (n-1) in if text = "" then [] else List.rev (split [] 0 num) let split_delim expr text = bounded_split_delim expr text 0 type split_result = Text of string | Delim of string let bounded_full_split expr text num = let rec split accu start n = if start >= String.length text then accu else if n = 1 then Text(string_after text start) :: accu else match opt_search_forward_progress expr text start with | None -> Text(string_after text start) :: accu | Some pos -> let s = matched_string text in if pos > start then split (Delim(s) :: Text(String.sub text start (pos-start)) :: accu) (match_end()) (n-1) else split (Delim(s) :: accu) (match_end()) (n-1) in List.rev (split [] 0 num) let full_split expr text = bounded_full_split expr text 0 mingw-ocaml/ocaml/otherlibs/str/.depend0000644000175000017500000000065512124403241017527 0ustar tootstootsstrstubs.o: strstubs.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h str.cmi : str.cmo : str.cmi str.cmx : str.cmi mingw-ocaml/ocaml/otherlibs/unix/0000755000175000017500000000000012124403241016434 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/unix/errmsg.c0000644000175000017500000000224712124403241020104 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include extern int error_table[]; CAMLprim value unix_error_message(value err) { int errnum; errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)]; return copy_string(strerror(errnum)); } mingw-ocaml/ocaml/otherlibs/unix/chmod.c0000644000175000017500000000221612124403241017673 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" CAMLprim value unix_chmod(value path, value perm) { int ret; ret = chmod(String_val(path), Int_val(perm)); if (ret == -1) uerror("chmod", path); return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/lockf.c0000644000175000017500000000556612124403241017712 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include "unixsupport.h" #if defined(F_GETLK) && defined(F_SETLK) && defined(F_SETLKW) CAMLprim value unix_lockf(value fd, value cmd, value span) { struct flock l; int ret; int fildes; long size; fildes = Int_val(fd); size = Long_val(span); l.l_whence = 1; if (size < 0) { l.l_start = size; l.l_len = -size; } else { l.l_start = 0L; l.l_len = size; } switch (Int_val(cmd)) { case 0: /* F_ULOCK */ l.l_type = F_UNLCK; ret = fcntl(fildes, F_SETLK, &l); break; case 1: /* F_LOCK */ l.l_type = F_WRLCK; enter_blocking_section(); ret = fcntl(fildes, F_SETLKW, &l); leave_blocking_section(); break; case 2: /* F_TLOCK */ l.l_type = F_WRLCK; ret = fcntl(fildes, F_SETLK, &l); break; case 3: /* F_TEST */ l.l_type = F_WRLCK; ret = fcntl(fildes, F_GETLK, &l); if (ret != -1) { if (l.l_type == F_UNLCK) ret = 0; else { errno = EACCES; ret = -1; } } break; case 4: /* F_RLOCK */ l.l_type = F_RDLCK; enter_blocking_section(); ret = fcntl(fildes, F_SETLKW, &l); leave_blocking_section(); break; case 5: /* F_TRLOCK */ l.l_type = F_RDLCK; ret = fcntl(fildes, F_SETLK, &l); break; default: errno = EINVAL; ret = -1; } if (ret == -1) uerror("lockf", Nothing); return Val_unit; } #else #ifdef HAS_LOCKF #ifdef HAS_UNISTD #include #else #define F_ULOCK 0 #define F_LOCK 1 #define F_TLOCK 2 #define F_TEST 3 #endif static int lock_command_table[] = { F_ULOCK, F_LOCK, F_TLOCK, F_TEST, F_LOCK, F_TLOCK }; CAMLprim value unix_lockf(value fd, value cmd, value span) { if (lockf(Int_val(fd), lock_command_table[Int_val(cmd)], Long_val(span)) == -1) uerror("lockf", Nothing); return Val_unit; } #else CAMLprim value unix_lockf(value fd, value cmd, value span) { invalid_argument("lockf not implemented"); } #endif #endif mingw-ocaml/ocaml/otherlibs/unix/close.c0000644000175000017500000000205212124403241017704 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_close(value fd) { if (close(Int_val(fd)) == -1) uerror("close", Nothing); return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/execve.c0000644000175000017500000000261412124403241020062 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" extern char ** cstringvect(); CAMLprim value unix_execve(value path, value args, value env) { char ** argv; char ** envp; argv = cstringvect(args); envp = cstringvect(env); (void) execve(String_val(path), argv, envp); stat_free((char *) argv); stat_free((char *) envp); uerror("execve", path); return Val_unit; /* never reached, but suppress warnings */ /* from smart compilers */ } mingw-ocaml/ocaml/otherlibs/unix/truncate.c0000644000175000017500000000313312124403241020425 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #ifdef HAS_UNISTD #include #endif #ifdef HAS_TRUNCATE CAMLprim value unix_truncate(value path, value len) { if (truncate(String_val(path), Long_val(len)) == -1) uerror("truncate", path); return Val_unit; } CAMLprim value unix_truncate_64(value path, value len) { if (truncate(String_val(path), File_offset_val(len)) == -1) uerror("truncate", path); return Val_unit; } #else CAMLprim value unix_truncate(value path, value len) { invalid_argument("truncate not implemented"); } CAMLprim value unix_truncate_64(value path, value len) { invalid_argument("truncate not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/unixLabels.ml0000644000175000017500000000170312124403241021075 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [UnixLabels]: labelled Unix module *) include Unix mingw-ocaml/ocaml/otherlibs/unix/cst2constr.c0000644000175000017500000000215312124403241020705 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "cst2constr.h" value cst_to_constr(int n, int *tbl, int size, int deflt) { int i; for (i = 0; i < size; i++) if (n == tbl[i]) return Val_int(i); return Val_int(deflt); } mingw-ocaml/ocaml/otherlibs/unix/mkdir.c0000644000175000017500000000216612124403241017713 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" CAMLprim value unix_mkdir(value path, value perm) { if (mkdir(String_val(path), Int_val(perm)) == -1) uerror("mkdir", path); return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/envir.c0000644000175000017500000000217712124403241017732 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #ifndef _WIN32 extern char ** environ; #endif CAMLprim value unix_environment(value unit) { if (environ != NULL) { return copy_string_array((const char**)environ); } else { return Atom(0); } } mingw-ocaml/ocaml/otherlibs/unix/fcntl.c0000644000175000017500000000447512124403241017720 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #ifdef HAS_UNISTD #include #endif #include #ifndef O_NONBLOCK #define O_NONBLOCK O_NDELAY #endif CAMLprim value unix_set_nonblock(value fd) { int retcode; retcode = fcntl(Int_val(fd), F_GETFL, 0); if (retcode == -1 || fcntl(Int_val(fd), F_SETFL, retcode | O_NONBLOCK) == -1) uerror("set_nonblock", Nothing); return Val_unit; } CAMLprim value unix_clear_nonblock(value fd) { int retcode; retcode = fcntl(Int_val(fd), F_GETFL, 0); if (retcode == -1 || fcntl(Int_val(fd), F_SETFL, retcode & ~O_NONBLOCK) == -1) uerror("clear_nonblock", Nothing); return Val_unit; } #ifdef FD_CLOEXEC CAMLprim value unix_set_close_on_exec(value fd) { int retcode; retcode = fcntl(Int_val(fd), F_GETFD, 0); if (retcode == -1 || fcntl(Int_val(fd), F_SETFD, retcode | FD_CLOEXEC) == -1) uerror("set_close_on_exec", Nothing); return Val_unit; } CAMLprim value unix_clear_close_on_exec(value fd) { int retcode; retcode = fcntl(Int_val(fd), F_GETFD, 0); if (retcode == -1 || fcntl(Int_val(fd), F_SETFD, retcode & ~FD_CLOEXEC) == -1) uerror("clear_close_on_exec", Nothing); return Val_unit; } #else CAMLprim value unix_set_close_on_exec(value fd) { invalid_argument("set_close_on_exec not implemented"); } CAMLprim value unix_clear_close_on_exec(value fd) { invalid_argument("clear_close_on_exec not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/rewinddir.c0000644000175000017500000000254312124403241020573 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #include #include #ifdef HAS_DIRENT #include #else #include #endif #ifdef HAS_REWINDDIR CAMLprim value unix_rewinddir(value vd) { DIR * d = DIR_Val(vd); if (d == (DIR *) NULL) unix_error(EBADF, "rewinddir", Nothing); rewinddir(d); return Val_unit; } #else CAMLprim value unix_rewinddir(value d) { invalid_argument("rewinddir not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/shutdown.c0000644000175000017500000000252712124403241020461 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include static int shutdown_command_table[] = { 0, 1, 2 }; CAMLprim value unix_shutdown(value sock, value cmd) { if (shutdown(Int_val(sock), shutdown_command_table[Int_val(cmd)]) == -1) uerror("shutdown", Nothing); return Val_unit; } #else CAMLprim value unix_shutdown(value sock, value cmd) { invalid_argument("shutdown not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/nice.c0000644000175000017500000000224212124403241017516 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" #include #ifdef HAS_UNISTD #include #endif CAMLprim value unix_nice(value incr) { int ret; errno = 0; ret = nice(Int_val(incr)); if (ret == -1 && errno != 0) uerror("nice", Nothing); return Val_int(ret); } mingw-ocaml/ocaml/otherlibs/unix/time.c0000644000175000017500000000207112124403241017536 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" CAMLprim value unix_time(value unit) { return copy_double((double) time((time_t *) NULL)); } mingw-ocaml/ocaml/otherlibs/unix/unlink.c0000644000175000017500000000206112124403241020077 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_unlink(value path) { if (unlink(String_val(path)) == -1) uerror("unlink", path); return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/setgid.c0000644000175000017500000000205712124403241020063 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_setgid(value gid) { if (setgid(Int_val(gid)) == -1) uerror("setgid", Nothing); return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/getpeername.c0000644000175000017500000000264012124403241021076 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include "socketaddr.h" CAMLprim value unix_getpeername(value sock) { int retcode; union sock_addr_union addr; socklen_param_type addr_len; addr_len = sizeof(addr); retcode = getpeername(Int_val(sock), &addr.s_gen, &addr_len); if (retcode == -1) uerror("getpeername", Nothing); return alloc_sockaddr(&addr, addr_len, -1); } #else CAMLprim value unix_getpeername(value sock) { invalid_argument("getpeername not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/getpw.c0000644000175000017500000000421312124403241017726 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #include static value alloc_passwd_entry(struct passwd *entry) { value res; value name = Val_unit, passwd = Val_unit, gecos = Val_unit; value dir = Val_unit, shell = Val_unit; Begin_roots5 (name, passwd, gecos, dir, shell); name = copy_string(entry->pw_name); passwd = copy_string(entry->pw_passwd); #ifndef __BEOS__ gecos = copy_string(entry->pw_gecos); #else gecos = copy_string(""); #endif dir = copy_string(entry->pw_dir); shell = copy_string(entry->pw_shell); res = alloc_small(7, 0); Field(res,0) = name; Field(res,1) = passwd; Field(res,2) = Val_int(entry->pw_uid); Field(res,3) = Val_int(entry->pw_gid); Field(res,4) = gecos; Field(res,5) = dir; Field(res,6) = shell; End_roots(); return res; } CAMLprim value unix_getpwnam(value name) { struct passwd * entry; entry = getpwnam(String_val(name)); if (entry == (struct passwd *) NULL) raise_not_found(); return alloc_passwd_entry(entry); } CAMLprim value unix_getpwuid(value uid) { struct passwd * entry; entry = getpwuid(Int_val(uid)); if (entry == (struct passwd *) NULL) raise_not_found(); return alloc_passwd_entry(entry); } mingw-ocaml/ocaml/otherlibs/unix/geteuid.c0000644000175000017500000000177612124403241020241 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_geteuid(value unit) { return Val_int(geteuid()); } mingw-ocaml/ocaml/otherlibs/unix/setuid.c0000644000175000017500000000205712124403241020101 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_setuid(value uid) { if (setuid(Int_val(uid)) == -1) uerror("setuid", Nothing); return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/unix.mli0000644000175000017500000014753512124403241020141 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Interface to the Unix system *) (** {6 Error report} *) type error = E2BIG (** Argument list too long *) | EACCES (** Permission denied *) | EAGAIN (** Resource temporarily unavailable; try again *) | EBADF (** Bad file descriptor *) | EBUSY (** Resource unavailable *) | ECHILD (** No child process *) | EDEADLK (** Resource deadlock would occur *) | EDOM (** Domain error for math functions, etc. *) | EEXIST (** File exists *) | EFAULT (** Bad address *) | EFBIG (** File too large *) | EINTR (** Function interrupted by signal *) | EINVAL (** Invalid argument *) | EIO (** Hardware I/O error *) | EISDIR (** Is a directory *) | EMFILE (** Too many open files by the process *) | EMLINK (** Too many links *) | ENAMETOOLONG (** Filename too long *) | ENFILE (** Too many open files in the system *) | ENODEV (** No such device *) | ENOENT (** No such file or directory *) | ENOEXEC (** Not an executable file *) | ENOLCK (** No locks available *) | ENOMEM (** Not enough memory *) | ENOSPC (** No space left on device *) | ENOSYS (** Function not supported *) | ENOTDIR (** Not a directory *) | ENOTEMPTY (** Directory not empty *) | ENOTTY (** Inappropriate I/O control operation *) | ENXIO (** No such device or address *) | EPERM (** Operation not permitted *) | EPIPE (** Broken pipe *) | ERANGE (** Result too large *) | EROFS (** Read-only file system *) | ESPIPE (** Invalid seek e.g. on a pipe *) | ESRCH (** No such process *) | EXDEV (** Invalid link *) | EWOULDBLOCK (** Operation would block *) | EINPROGRESS (** Operation now in progress *) | EALREADY (** Operation already in progress *) | ENOTSOCK (** Socket operation on non-socket *) | EDESTADDRREQ (** Destination address required *) | EMSGSIZE (** Message too long *) | EPROTOTYPE (** Protocol wrong type for socket *) | ENOPROTOOPT (** Protocol not available *) | EPROTONOSUPPORT (** Protocol not supported *) | ESOCKTNOSUPPORT (** Socket type not supported *) | EOPNOTSUPP (** Operation not supported on socket *) | EPFNOSUPPORT (** Protocol family not supported *) | EAFNOSUPPORT (** Address family not supported by protocol family *) | EADDRINUSE (** Address already in use *) | EADDRNOTAVAIL (** Can't assign requested address *) | ENETDOWN (** Network is down *) | ENETUNREACH (** Network is unreachable *) | ENETRESET (** Network dropped connection on reset *) | ECONNABORTED (** Software caused connection abort *) | ECONNRESET (** Connection reset by peer *) | ENOBUFS (** No buffer space available *) | EISCONN (** Socket is already connected *) | ENOTCONN (** Socket is not connected *) | ESHUTDOWN (** Can't send after socket shutdown *) | ETOOMANYREFS (** Too many references: can't splice *) | ETIMEDOUT (** Connection timed out *) | ECONNREFUSED (** Connection refused *) | EHOSTDOWN (** Host is down *) | EHOSTUNREACH (** No route to host *) | ELOOP (** Too many levels of symbolic links *) | EOVERFLOW (** File size or position not representable *) | EUNKNOWNERR of int (** Unknown error *) (** The type of error codes. Errors defined in the POSIX standard and additional errors from UNIX98 and BSD. All other errors are mapped to EUNKNOWNERR. *) exception Unix_error of error * string * string (** Raised by the system calls below when an error is encountered. The first component is the error code; the second component is the function name; the third component is the string parameter to the function, if it has one, or the empty string otherwise. *) val error_message : error -> string (** Return a string describing the given error code. *) val handle_unix_error : ('a -> 'b) -> 'a -> 'b (** [handle_unix_error f x] applies [f] to [x] and returns the result. If the exception [Unix_error] is raised, it prints a message describing the error and exits with code 2. *) (** {6 Access to the process environment} *) val environment : unit -> string array (** Return the process environment, as an array of strings with the format ``variable=value''. *) val getenv : string -> string (** Return the value associated to a variable in the process environment. Raise [Not_found] if the variable is unbound. (This function is identical to {!Sys.getenv}.) *) val putenv : string -> string -> unit (** [Unix.putenv name value] sets the value associated to a variable in the process environment. [name] is the name of the environment variable, and [value] its new associated value. *) (** {6 Process handling} *) type process_status = WEXITED of int (** The process terminated normally by [exit]; the argument is the return code. *) | WSIGNALED of int (** The process was killed by a signal; the argument is the signal number. *) | WSTOPPED of int (** The process was stopped by a signal; the argument is the signal number. *) (** The termination status of a process. See module {!Sys} for the definitions of the standard signal numbers. Note that they are not the numbers used by the OS. *) type wait_flag = WNOHANG (** do not block if no child has died yet, but immediately return with a pid equal to 0.*) | WUNTRACED (** report also the children that receive stop signals. *) (** Flags for {!Unix.waitpid}. *) val execv : string -> string array -> 'a (** [execv prog args] execute the program in file [prog], with the arguments [args], and the current process environment. These [execv*] functions never return: on success, the current program is replaced by the new one; on failure, a {!Unix.Unix_error} exception is raised. *) val execve : string -> string array -> string array -> 'a (** Same as {!Unix.execv}, except that the third argument provides the environment to the program executed. *) val execvp : string -> string array -> 'a (** Same as {!Unix.execv}, except that the program is searched in the path. *) val execvpe : string -> string array -> string array -> 'a (** Same as {!Unix.execve}, except that the program is searched in the path. *) val fork : unit -> int (** Fork a new process. The returned integer is 0 for the child process, the pid of the child process for the parent process. *) val wait : unit -> int * process_status (** Wait until one of the children processes die, and return its pid and termination status. *) val waitpid : wait_flag list -> int -> int * process_status (** Same as {!Unix.wait}, but waits for the child process whose pid is given. A pid of [-1] means wait for any child. A pid of [0] means wait for any child in the same process group as the current process. Negative pid arguments represent process groups. The list of options indicates whether [waitpid] should return immediately without waiting, or also report stopped children. *) val system : string -> process_status (** Execute the given command, wait until it terminates, and return its termination status. The string is interpreted by the shell [/bin/sh] and therefore can contain redirections, quotes, variables, etc. The result [WEXITED 127] indicates that the shell couldn't be executed. *) val getpid : unit -> int (** Return the pid of the process. *) val getppid : unit -> int (** Return the pid of the parent process. *) val nice : int -> int (** Change the process priority. The integer argument is added to the ``nice'' value. (Higher values of the ``nice'' value mean lower priorities.) Return the new nice value. *) (** {6 Basic file input/output} *) type file_descr (** The abstract type of file descriptors. *) val stdin : file_descr (** File descriptor for standard input.*) val stdout : file_descr (** File descriptor for standard output.*) val stderr : file_descr (** File descriptor for standard error. *) type open_flag = O_RDONLY (** Open for reading *) | O_WRONLY (** Open for writing *) | O_RDWR (** Open for reading and writing *) | O_NONBLOCK (** Open in non-blocking mode *) | O_APPEND (** Open for append *) | O_CREAT (** Create if nonexistent *) | O_TRUNC (** Truncate to 0 length if existing *) | O_EXCL (** Fail if existing *) | O_NOCTTY (** Don't make this dev a controlling tty *) | O_DSYNC (** Writes complete as `Synchronised I/O data integrity completion' *) | O_SYNC (** Writes complete as `Synchronised I/O file integrity completion' *) | O_RSYNC (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *) | O_SHARE_DELETE (** Windows only: allow the file to be deleted while still open *) (** The flags to {!Unix.openfile}. *) type file_perm = int (** The type of file access rights, e.g. [0o640] is read and write for user, read for group, none for others *) val openfile : string -> open_flag list -> file_perm -> file_descr (** Open the named file with the given flags. Third argument is the permissions to give to the file if it is created. Return a file descriptor on the named file. *) val close : file_descr -> unit (** Close a file descriptor. *) val read : file_descr -> string -> int -> int -> int (** [read fd buff ofs len] reads [len] characters from descriptor [fd], storing them in string [buff], starting at position [ofs] in string [buff]. Return the number of characters actually read. *) val write : file_descr -> string -> int -> int -> int (** [write fd buff ofs len] writes [len] characters to descriptor [fd], taking them from string [buff], starting at position [ofs] in string [buff]. Return the number of characters actually written. [write] repeats the writing operation until all characters have been written or an error occurs. *) val single_write : file_descr -> string -> int -> int -> int (** Same as [write], but attempts to write only once. Thus, if an error occurs, [single_write] guarantees that no data has been written. *) (** {6 Interfacing with the standard input/output library} *) val in_channel_of_descr : file_descr -> in_channel (** Create an input channel reading from the given descriptor. The channel is initially in binary mode; use [set_binary_mode_in ic false] if text mode is desired. *) val out_channel_of_descr : file_descr -> out_channel (** Create an output channel writing on the given descriptor. The channel is initially in binary mode; use [set_binary_mode_out oc false] if text mode is desired. *) val descr_of_in_channel : in_channel -> file_descr (** Return the descriptor corresponding to an input channel. *) val descr_of_out_channel : out_channel -> file_descr (** Return the descriptor corresponding to an output channel. *) (** {6 Seeking and truncating} *) type seek_command = SEEK_SET (** indicates positions relative to the beginning of the file *) | SEEK_CUR (** indicates positions relative to the current position *) | SEEK_END (** indicates positions relative to the end of the file *) (** Positioning modes for {!Unix.lseek}. *) val lseek : file_descr -> int -> seek_command -> int (** Set the current position for a file descriptor *) val truncate : string -> int -> unit (** Truncates the named file to the given size. *) val ftruncate : file_descr -> int -> unit (** Truncates the file corresponding to the given descriptor to the given size. *) (** {6 File status} *) type file_kind = S_REG (** Regular file *) | S_DIR (** Directory *) | S_CHR (** Character device *) | S_BLK (** Block device *) | S_LNK (** Symbolic link *) | S_FIFO (** Named pipe *) | S_SOCK (** Socket *) type stats = { st_dev : int; (** Device number *) st_ino : int; (** Inode number *) st_kind : file_kind; (** Kind of the file *) st_perm : file_perm; (** Access rights *) st_nlink : int; (** Number of links *) st_uid : int; (** User id of the owner *) st_gid : int; (** Group ID of the file's group *) st_rdev : int; (** Device minor number *) st_size : int; (** Size in bytes *) st_atime : float; (** Last access time *) st_mtime : float; (** Last modification time *) st_ctime : float; (** Last status change time *) } (** The information returned by the {!Unix.stat} calls. *) val stat : string -> stats (** Return the information for the named file. *) val lstat : string -> stats (** Same as {!Unix.stat}, but in case the file is a symbolic link, return the information for the link itself. *) val fstat : file_descr -> stats (** Return the information for the file associated with the given descriptor. *) val isatty : file_descr -> bool (** Return [true] if the given file descriptor refers to a terminal or console window, [false] otherwise. *) (** {6 File operations on large files} *) module LargeFile : sig val lseek : file_descr -> int64 -> seek_command -> int64 val truncate : string -> int64 -> unit val ftruncate : file_descr -> int64 -> unit type stats = { st_dev : int; (** Device number *) st_ino : int; (** Inode number *) st_kind : file_kind; (** Kind of the file *) st_perm : file_perm; (** Access rights *) st_nlink : int; (** Number of links *) st_uid : int; (** User id of the owner *) st_gid : int; (** Group ID of the file's group *) st_rdev : int; (** Device minor number *) st_size : int64; (** Size in bytes *) st_atime : float; (** Last access time *) st_mtime : float; (** Last modification time *) st_ctime : float; (** Last status change time *) } val stat : string -> stats val lstat : string -> stats val fstat : file_descr -> stats end (** File operations on large files. This sub-module provides 64-bit variants of the functions {!Unix.lseek} (for positioning a file descriptor), {!Unix.truncate} and {!Unix.ftruncate} (for changing the size of a file), and {!Unix.stat}, {!Unix.lstat} and {!Unix.fstat} (for obtaining information on files). These alternate functions represent positions and sizes by 64-bit integers (type [int64]) instead of regular integers (type [int]), thus allowing operating on files whose sizes are greater than [max_int]. *) (** {6 Operations on file names} *) val unlink : string -> unit (** Removes the named file *) val rename : string -> string -> unit (** [rename old new] changes the name of a file from [old] to [new]. *) val link : string -> string -> unit (** [link source dest] creates a hard link named [dest] to the file named [source]. *) (** {6 File permissions and ownership} *) type access_permission = R_OK (** Read permission *) | W_OK (** Write permission *) | X_OK (** Execution permission *) | F_OK (** File exists *) (** Flags for the {!Unix.access} call. *) val chmod : string -> file_perm -> unit (** Change the permissions of the named file. *) val fchmod : file_descr -> file_perm -> unit (** Change the permissions of an opened file. *) val chown : string -> int -> int -> unit (** Change the owner uid and owner gid of the named file. *) val fchown : file_descr -> int -> int -> unit (** Change the owner uid and owner gid of an opened file. *) val umask : int -> int (** Set the process's file mode creation mask, and return the previous mask. *) val access : string -> access_permission list -> unit (** Check that the process has the given permissions over the named file. Raise [Unix_error] otherwise. *) (** {6 Operations on file descriptors} *) val dup : file_descr -> file_descr (** Return a new file descriptor referencing the same file as the given descriptor. *) val dup2 : file_descr -> file_descr -> unit (** [dup2 fd1 fd2] duplicates [fd1] to [fd2], closing [fd2] if already opened. *) val set_nonblock : file_descr -> unit (** Set the ``non-blocking'' flag on the given descriptor. When the non-blocking flag is set, reading on a descriptor on which there is temporarily no data available raises the [EAGAIN] or [EWOULDBLOCK] error instead of blocking; writing on a descriptor on which there is temporarily no room for writing also raises [EAGAIN] or [EWOULDBLOCK]. *) val clear_nonblock : file_descr -> unit (** Clear the ``non-blocking'' flag on the given descriptor. See {!Unix.set_nonblock}.*) val set_close_on_exec : file_descr -> unit (** Set the ``close-on-exec'' flag on the given descriptor. A descriptor with the close-on-exec flag is automatically closed when the current process starts another program with one of the [exec] functions. *) val clear_close_on_exec : file_descr -> unit (** Clear the ``close-on-exec'' flag on the given descriptor. See {!Unix.set_close_on_exec}.*) (** {6 Directories} *) val mkdir : string -> file_perm -> unit (** Create a directory with the given permissions. *) val rmdir : string -> unit (** Remove an empty directory. *) val chdir : string -> unit (** Change the process working directory. *) val getcwd : unit -> string (** Return the name of the current working directory. *) val chroot : string -> unit (** Change the process root directory. *) type dir_handle (** The type of descriptors over opened directories. *) val opendir : string -> dir_handle (** Open a descriptor on a directory *) val readdir : dir_handle -> string (** Return the next entry in a directory. @raise End_of_file when the end of the directory has been reached. *) val rewinddir : dir_handle -> unit (** Reposition the descriptor to the beginning of the directory *) val closedir : dir_handle -> unit (** Close a directory descriptor. *) (** {6 Pipes and redirections} *) val pipe : unit -> file_descr * file_descr (** Create a pipe. The first component of the result is opened for reading, that's the exit to the pipe. The second component is opened for writing, that's the entrance to the pipe. *) val mkfifo : string -> file_perm -> unit (** Create a named pipe with the given permissions. *) (** {6 High-level process and redirection management} *) val create_process : string -> string array -> file_descr -> file_descr -> file_descr -> int (** [create_process prog args new_stdin new_stdout new_stderr] forks a new process that executes the program in file [prog], with arguments [args]. The pid of the new process is returned immediately; the new process executes concurrently with the current process. The standard input and outputs of the new process are connected to the descriptors [new_stdin], [new_stdout] and [new_stderr]. Passing e.g. [stdout] for [new_stdout] prevents the redirection and causes the new process to have the same standard output as the current process. The executable file [prog] is searched in the path. The new process has the same environment as the current process. *) val create_process_env : string -> string array -> string array -> file_descr -> file_descr -> file_descr -> int (** [create_process_env prog args env new_stdin new_stdout new_stderr] works as {!Unix.create_process}, except that the extra argument [env] specifies the environment passed to the program. *) val open_process_in : string -> in_channel (** High-level pipe and process management. This function runs the given command in parallel with the program. The standard output of the command is redirected to a pipe, which can be read via the returned input channel. The command is interpreted by the shell [/bin/sh] (cf. [system]). *) val open_process_out : string -> out_channel (** Same as {!Unix.open_process_in}, but redirect the standard input of the command to a pipe. Data written to the returned output channel is sent to the standard input of the command. Warning: writes on output channels are buffered, hence be careful to call {!Pervasives.flush} at the right times to ensure correct synchronization. *) val open_process : string -> in_channel * out_channel (** Same as {!Unix.open_process_out}, but redirects both the standard input and standard output of the command to pipes connected to the two returned channels. The input channel is connected to the output of the command, and the output channel to the input of the command. *) val open_process_full : string -> string array -> in_channel * out_channel * in_channel (** Similar to {!Unix.open_process}, but the second argument specifies the environment passed to the command. The result is a triple of channels connected respectively to the standard output, standard input, and standard error of the command. *) val close_process_in : in_channel -> process_status (** Close channels opened by {!Unix.open_process_in}, wait for the associated command to terminate, and return its termination status. *) val close_process_out : out_channel -> process_status (** Close channels opened by {!Unix.open_process_out}, wait for the associated command to terminate, and return its termination status. *) val close_process : in_channel * out_channel -> process_status (** Close channels opened by {!Unix.open_process}, wait for the associated command to terminate, and return its termination status. *) val close_process_full : in_channel * out_channel * in_channel -> process_status (** Close channels opened by {!Unix.open_process_full}, wait for the associated command to terminate, and return its termination status. *) (** {6 Symbolic links} *) val symlink : string -> string -> unit (** [symlink source dest] creates the file [dest] as a symbolic link to the file [source]. *) val readlink : string -> string (** Read the contents of a link. *) (** {6 Polling} *) val select : file_descr list -> file_descr list -> file_descr list -> float -> file_descr list * file_descr list * file_descr list (** Wait until some input/output operations become possible on some channels. The three list arguments are, respectively, a set of descriptors to check for reading (first argument), for writing (second argument), or for exceptional conditions (third argument). The fourth argument is the maximal timeout, in seconds; a negative fourth argument means no timeout (unbounded wait). The result is composed of three sets of descriptors: those ready for reading (first component), ready for writing (second component), and over which an exceptional condition is pending (third component). *) (** {6 Locking} *) type lock_command = F_ULOCK (** Unlock a region *) | F_LOCK (** Lock a region for writing, and block if already locked *) | F_TLOCK (** Lock a region for writing, or fail if already locked *) | F_TEST (** Test a region for other process locks *) | F_RLOCK (** Lock a region for reading, and block if already locked *) | F_TRLOCK (** Lock a region for reading, or fail if already locked *) (** Commands for {!Unix.lockf}. *) val lockf : file_descr -> lock_command -> int -> unit (** [lockf fd cmd size] puts a lock on a region of the file opened as [fd]. The region starts at the current read/write position for [fd] (as set by {!Unix.lseek}), and extends [size] bytes forward if [size] is positive, [size] bytes backwards if [size] is negative, or to the end of the file if [size] is zero. A write lock prevents any other process from acquiring a read or write lock on the region. A read lock prevents any other process from acquiring a write lock on the region, but lets other processes acquire read locks on it. The [F_LOCK] and [F_TLOCK] commands attempts to put a write lock on the specified region. The [F_RLOCK] and [F_TRLOCK] commands attempts to put a read lock on the specified region. If one or several locks put by another process prevent the current process from acquiring the lock, [F_LOCK] and [F_RLOCK] block until these locks are removed, while [F_TLOCK] and [F_TRLOCK] fail immediately with an exception. The [F_ULOCK] removes whatever locks the current process has on the specified region. Finally, the [F_TEST] command tests whether a write lock can be acquired on the specified region, without actually putting a lock. It returns immediately if successful, or fails otherwise. *) (** {6 Signals} Note: installation of signal handlers is performed via the functions {!Sys.signal} and {!Sys.set_signal}. *) val kill : int -> int -> unit (** [kill pid sig] sends signal number [sig] to the process with id [pid]. *) type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK val sigprocmask : sigprocmask_command -> int list -> int list (** [sigprocmask cmd sigs] changes the set of blocked signals. If [cmd] is [SIG_SETMASK], blocked signals are set to those in the list [sigs]. If [cmd] is [SIG_BLOCK], the signals in [sigs] are added to the set of blocked signals. If [cmd] is [SIG_UNBLOCK], the signals in [sigs] are removed from the set of blocked signals. [sigprocmask] returns the set of previously blocked signals. *) val sigpending : unit -> int list (** Return the set of blocked signals that are currently pending. *) val sigsuspend : int list -> unit (** [sigsuspend sigs] atomically sets the blocked signals to [sigs] and waits for a non-ignored, non-blocked signal to be delivered. On return, the blocked signals are reset to their initial value. *) val pause : unit -> unit (** Wait until a non-ignored, non-blocked signal is delivered. *) (** {6 Time functions} *) type process_times = { tms_utime : float; (** User time for the process *) tms_stime : float; (** System time for the process *) tms_cutime : float; (** User time for the children processes *) tms_cstime : float; (** System time for the children processes *) } (** The execution times (CPU times) of a process. *) type tm = { tm_sec : int; (** Seconds 0..60 *) tm_min : int; (** Minutes 0..59 *) tm_hour : int; (** Hours 0..23 *) tm_mday : int; (** Day of month 1..31 *) tm_mon : int; (** Month of year 0..11 *) tm_year : int; (** Year - 1900 *) tm_wday : int; (** Day of week (Sunday is 0) *) tm_yday : int; (** Day of year 0..365 *) tm_isdst : bool; (** Daylight time savings in effect *) } (** The type representing wallclock time and calendar date. *) val time : unit -> float (** Return the current time since 00:00:00 GMT, Jan. 1, 1970, in seconds. *) val gettimeofday : unit -> float (** Same as {!Unix.time}, but with resolution better than 1 second. *) val gmtime : float -> tm (** Convert a time in seconds, as returned by {!Unix.time}, into a date and a time. Assumes UTC (Coordinated Universal Time), also known as GMT. *) val localtime : float -> tm (** Convert a time in seconds, as returned by {!Unix.time}, into a date and a time. Assumes the local time zone. *) val mktime : tm -> float * tm (** Convert a date and time, specified by the [tm] argument, into a time in seconds, as returned by {!Unix.time}. The [tm_isdst], [tm_wday] and [tm_yday] fields of [tm] are ignored. Also return a normalized copy of the given [tm] record, with the [tm_wday], [tm_yday], and [tm_isdst] fields recomputed from the other fields, and the other fields normalized (so that, e.g., 40 October is changed into 9 November). The [tm] argument is interpreted in the local time zone. *) val alarm : int -> int (** Schedule a [SIGALRM] signal after the given number of seconds. *) val sleep : int -> unit (** Stop execution for the given number of seconds. *) val times : unit -> process_times (** Return the execution times of the process. *) val utimes : string -> float -> float -> unit (** Set the last access time (second arg) and last modification time (third arg) for a file. Times are expressed in seconds from 00:00:00 GMT, Jan. 1, 1970. A time of [0.0] is interpreted as the current time. *) type interval_timer = ITIMER_REAL (** decrements in real time, and sends the signal [SIGALRM] when expired.*) | ITIMER_VIRTUAL (** decrements in process virtual time, and sends [SIGVTALRM] when expired. *) | ITIMER_PROF (** (for profiling) decrements both when the process is running and when the system is running on behalf of the process; it sends [SIGPROF] when expired. *) (** The three kinds of interval timers. *) type interval_timer_status = { it_interval : float; (** Period *) it_value : float; (** Current value of the timer *) } (** The type describing the status of an interval timer *) val getitimer : interval_timer -> interval_timer_status (** Return the current status of the given interval timer. *) val setitimer : interval_timer -> interval_timer_status -> interval_timer_status (** [setitimer t s] sets the interval timer [t] and returns its previous status. The [s] argument is interpreted as follows: [s.it_value], if nonzero, is the time to the next timer expiration; [s.it_interval], if nonzero, specifies a value to be used in reloading it_value when the timer expires. Setting [s.it_value] to zero disable the timer. Setting [s.it_interval] to zero causes the timer to be disabled after its next expiration. *) (** {6 User id, group id} *) val getuid : unit -> int (** Return the user id of the user executing the process. *) val geteuid : unit -> int (** Return the effective user id under which the process runs. *) val setuid : int -> unit (** Set the real user id and effective user id for the process. *) val getgid : unit -> int (** Return the group id of the user executing the process. *) val getegid : unit -> int (** Return the effective group id under which the process runs. *) val setgid : int -> unit (** Set the real group id and effective group id for the process. *) val getgroups : unit -> int array (** Return the list of groups to which the user executing the process belongs. *) val setgroups : int array -> unit (** [setgroups groups] sets the supplementary group IDs for the calling process. Appropriate privileges are required. *) val initgroups : string -> int -> unit (** [initgroups user group] initializes the group access list by reading the group database /etc/group and using all groups of which [user] is a member. The additional group [group] is also added to the list. *) type passwd_entry = { pw_name : string; pw_passwd : string; pw_uid : int; pw_gid : int; pw_gecos : string; pw_dir : string; pw_shell : string } (** Structure of entries in the [passwd] database. *) type group_entry = { gr_name : string; gr_passwd : string; gr_gid : int; gr_mem : string array } (** Structure of entries in the [groups] database. *) val getlogin : unit -> string (** Return the login name of the user executing the process. *) val getpwnam : string -> passwd_entry (** Find an entry in [passwd] with the given name, or raise [Not_found]. *) val getgrnam : string -> group_entry (** Find an entry in [group] with the given name, or raise [Not_found]. *) val getpwuid : int -> passwd_entry (** Find an entry in [passwd] with the given user id, or raise [Not_found]. *) val getgrgid : int -> group_entry (** Find an entry in [group] with the given group id, or raise [Not_found]. *) (** {6 Internet addresses} *) type inet_addr (** The abstract type of Internet addresses. *) val inet_addr_of_string : string -> inet_addr (** Conversion from the printable representation of an Internet address to its internal representation. The argument string consists of 4 numbers separated by periods ([XXX.YYY.ZZZ.TTT]) for IPv4 addresses, and up to 8 numbers separated by colons for IPv6 addresses. Raise [Failure] when given a string that does not match these formats. *) val string_of_inet_addr : inet_addr -> string (** Return the printable representation of the given Internet address. See {!Unix.inet_addr_of_string} for a description of the printable representation. *) val inet_addr_any : inet_addr (** A special IPv4 address, for use only with [bind], representing all the Internet addresses that the host machine possesses. *) val inet_addr_loopback : inet_addr (** A special IPv4 address representing the host machine ([127.0.0.1]). *) val inet6_addr_any : inet_addr (** A special IPv6 address, for use only with [bind], representing all the Internet addresses that the host machine possesses. *) val inet6_addr_loopback : inet_addr (** A special IPv6 address representing the host machine ([::1]). *) (** {6 Sockets} *) type socket_domain = PF_UNIX (** Unix domain *) | PF_INET (** Internet domain (IPv4) *) | PF_INET6 (** Internet domain (IPv6) *) (** The type of socket domains. Not all platforms support IPv6 sockets (type [PF_INET6]). *) type socket_type = SOCK_STREAM (** Stream socket *) | SOCK_DGRAM (** Datagram socket *) | SOCK_RAW (** Raw socket *) | SOCK_SEQPACKET (** Sequenced packets socket *) (** The type of socket kinds, specifying the semantics of communications. *) type sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int (** The type of socket addresses. [ADDR_UNIX name] is a socket address in the Unix domain; [name] is a file name in the file system. [ADDR_INET(addr,port)] is a socket address in the Internet domain; [addr] is the Internet address of the machine, and [port] is the port number. *) val socket : socket_domain -> socket_type -> int -> file_descr (** Create a new socket in the given domain, and with the given kind. The third argument is the protocol type; 0 selects the default protocol for that kind of sockets. *) val domain_of_sockaddr: sockaddr -> socket_domain (** Return the socket domain adequate for the given socket address. *) val socketpair : socket_domain -> socket_type -> int -> file_descr * file_descr (** Create a pair of unnamed sockets, connected together. *) val accept : file_descr -> file_descr * sockaddr (** Accept connections on the given socket. The returned descriptor is a socket connected to the client; the returned address is the address of the connecting client. *) val bind : file_descr -> sockaddr -> unit (** Bind a socket to an address. *) val connect : file_descr -> sockaddr -> unit (** Connect a socket to an address. *) val listen : file_descr -> int -> unit (** Set up a socket for receiving connection requests. The integer argument is the maximal number of pending requests. *) type shutdown_command = SHUTDOWN_RECEIVE (** Close for receiving *) | SHUTDOWN_SEND (** Close for sending *) | SHUTDOWN_ALL (** Close both *) (** The type of commands for [shutdown]. *) val shutdown : file_descr -> shutdown_command -> unit (** Shutdown a socket connection. [SHUTDOWN_SEND] as second argument causes reads on the other end of the connection to return an end-of-file condition. [SHUTDOWN_RECEIVE] causes writes on the other end of the connection to return a closed pipe condition ([SIGPIPE] signal). *) val getsockname : file_descr -> sockaddr (** Return the address of the given socket. *) val getpeername : file_descr -> sockaddr (** Return the address of the host connected to the given socket. *) type msg_flag = MSG_OOB | MSG_DONTROUTE | MSG_PEEK (** The flags for {!Unix.recv}, {!Unix.recvfrom}, {!Unix.send} and {!Unix.sendto}. *) val recv : file_descr -> string -> int -> int -> msg_flag list -> int (** Receive data from a connected socket. *) val recvfrom : file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr (** Receive data from an unconnected socket. *) val send : file_descr -> string -> int -> int -> msg_flag list -> int (** Send data over a connected socket. *) val sendto : file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int (** Send data over an unconnected socket. *) (** {6 Socket options} *) type socket_bool_option = SO_DEBUG (** Record debugging information *) | SO_BROADCAST (** Permit sending of broadcast messages *) | SO_REUSEADDR (** Allow reuse of local addresses for bind *) | SO_KEEPALIVE (** Keep connection active *) | SO_DONTROUTE (** Bypass the standard routing algorithms *) | SO_OOBINLINE (** Leave out-of-band data in line *) | SO_ACCEPTCONN (** Report whether socket listening is enabled *) | TCP_NODELAY (** Control the Nagle algorithm for TCP sockets *) | IPV6_ONLY (** Forbid binding an IPv6 socket to an IPv4 address *) (** The socket options that can be consulted with {!Unix.getsockopt} and modified with {!Unix.setsockopt}. These options have a boolean ([true]/[false]) value. *) type socket_int_option = SO_SNDBUF (** Size of send buffer *) | SO_RCVBUF (** Size of received buffer *) | SO_ERROR (** Deprecated. Use {!Unix.getsockopt_error} instead. *) | SO_TYPE (** Report the socket type *) | SO_RCVLOWAT (** Minimum number of bytes to process for input operations*) | SO_SNDLOWAT (** Minimum number of bytes to process for output operations *) (** The socket options that can be consulted with {!Unix.getsockopt_int} and modified with {!Unix.setsockopt_int}. These options have an integer value. *) type socket_optint_option = SO_LINGER (** Whether to linger on closed connections that have data present, and for how long (in seconds) *) (** The socket options that can be consulted with {!Unix.getsockopt_optint} and modified with {!Unix.setsockopt_optint}. These options have a value of type [int option], with [None] meaning ``disabled''. *) type socket_float_option = SO_RCVTIMEO (** Timeout for input operations *) | SO_SNDTIMEO (** Timeout for output operations *) (** The socket options that can be consulted with {!Unix.getsockopt_float} and modified with {!Unix.setsockopt_float}. These options have a floating-point value representing a time in seconds. The value 0 means infinite timeout. *) val getsockopt : file_descr -> socket_bool_option -> bool (** Return the current status of a boolean-valued option in the given socket. *) val setsockopt : file_descr -> socket_bool_option -> bool -> unit (** Set or clear a boolean-valued option in the given socket. *) val getsockopt_int : file_descr -> socket_int_option -> int (** Same as {!Unix.getsockopt} for an integer-valued socket option. *) val setsockopt_int : file_descr -> socket_int_option -> int -> unit (** Same as {!Unix.setsockopt} for an integer-valued socket option. *) val getsockopt_optint : file_descr -> socket_optint_option -> int option (** Same as {!Unix.getsockopt} for a socket option whose value is an [int option]. *) val setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit (** Same as {!Unix.setsockopt} for a socket option whose value is an [int option]. *) val getsockopt_float : file_descr -> socket_float_option -> float (** Same as {!Unix.getsockopt} for a socket option whose value is a floating-point number. *) val setsockopt_float : file_descr -> socket_float_option -> float -> unit (** Same as {!Unix.setsockopt} for a socket option whose value is a floating-point number. *) val getsockopt_error : file_descr -> error option (** Return the error condition associated with the given socket, and clear it. *) (** {6 High-level network connection functions} *) val open_connection : sockaddr -> in_channel * out_channel (** Connect to a server at the given address. Return a pair of buffered channels connected to the server. Remember to call {!Pervasives.flush} on the output channel at the right times to ensure correct synchronization. *) val shutdown_connection : in_channel -> unit (** ``Shut down'' a connection established with {!Unix.open_connection}; that is, transmit an end-of-file condition to the server reading on the other side of the connection. *) val establish_server : (in_channel -> out_channel -> unit) -> sockaddr -> unit (** Establish a server on the given address. The function given as first argument is called for each connection with two buffered channels connected to the client. A new process is created for each connection. The function {!Unix.establish_server} never returns normally. *) (** {6 Host and protocol databases} *) type host_entry = { h_name : string; h_aliases : string array; h_addrtype : socket_domain; h_addr_list : inet_addr array } (** Structure of entries in the [hosts] database. *) type protocol_entry = { p_name : string; p_aliases : string array; p_proto : int } (** Structure of entries in the [protocols] database. *) type service_entry = { s_name : string; s_aliases : string array; s_port : int; s_proto : string } (** Structure of entries in the [services] database. *) val gethostname : unit -> string (** Return the name of the local host. *) val gethostbyname : string -> host_entry (** Find an entry in [hosts] with the given name, or raise [Not_found]. *) val gethostbyaddr : inet_addr -> host_entry (** Find an entry in [hosts] with the given address, or raise [Not_found]. *) val getprotobyname : string -> protocol_entry (** Find an entry in [protocols] with the given name, or raise [Not_found]. *) val getprotobynumber : int -> protocol_entry (** Find an entry in [protocols] with the given protocol number, or raise [Not_found]. *) val getservbyname : string -> string -> service_entry (** Find an entry in [services] with the given name, or raise [Not_found]. *) val getservbyport : int -> string -> service_entry (** Find an entry in [services] with the given service number, or raise [Not_found]. *) type addr_info = { ai_family : socket_domain; (** Socket domain *) ai_socktype : socket_type; (** Socket type *) ai_protocol : int; (** Socket protocol number *) ai_addr : sockaddr; (** Address *) ai_canonname : string (** Canonical host name *) } (** Address information returned by {!Unix.getaddrinfo}. *) type getaddrinfo_option = AI_FAMILY of socket_domain (** Impose the given socket domain *) | AI_SOCKTYPE of socket_type (** Impose the given socket type *) | AI_PROTOCOL of int (** Impose the given protocol *) | AI_NUMERICHOST (** Do not call name resolver, expect numeric IP address *) | AI_CANONNAME (** Fill the [ai_canonname] field of the result *) | AI_PASSIVE (** Set address to ``any'' address for use with {!Unix.bind} *) (** Options to {!Unix.getaddrinfo}. *) val getaddrinfo: string -> string -> getaddrinfo_option list -> addr_info list (** [getaddrinfo host service opts] returns a list of {!Unix.addr_info} records describing socket parameters and addresses suitable for communicating with the given host and service. The empty list is returned if the host or service names are unknown, or the constraints expressed in [opts] cannot be satisfied. [host] is either a host name or the string representation of an IP address. [host] can be given as the empty string; in this case, the ``any'' address or the ``loopback'' address are used, depending whether [opts] contains [AI_PASSIVE]. [service] is either a service name or the string representation of a port number. [service] can be given as the empty string; in this case, the port field of the returned addresses is set to 0. [opts] is a possibly empty list of options that allows the caller to force a particular socket domain (e.g. IPv6 only or IPv4 only) or a particular socket type (e.g. TCP only or UDP only). *) type name_info = { ni_hostname : string; (** Name or IP address of host *) ni_service : string } (** Name of service or port number *) (** Host and service information returned by {!Unix.getnameinfo}. *) type getnameinfo_option = NI_NOFQDN (** Do not qualify local host names *) | NI_NUMERICHOST (** Always return host as IP address *) | NI_NAMEREQD (** Fail if host name cannot be determined *) | NI_NUMERICSERV (** Always return service as port number *) | NI_DGRAM (** Consider the service as UDP-based instead of the default TCP *) (** Options to {!Unix.getnameinfo}. *) val getnameinfo : sockaddr -> getnameinfo_option list -> name_info (** [getnameinfo addr opts] returns the host name and service name corresponding to the socket address [addr]. [opts] is a possibly empty list of options that governs how these names are obtained. Raise [Not_found] if an error occurs. *) (** {6 Terminal interface} *) (** The following functions implement the POSIX standard terminal interface. They provide control over asynchronous communication ports and pseudo-terminals. Refer to the [termios] man page for a complete description. *) type terminal_io = { (* input modes *) mutable c_ignbrk : bool; (** Ignore the break condition. *) mutable c_brkint : bool; (** Signal interrupt on break condition. *) mutable c_ignpar : bool; (** Ignore characters with parity errors. *) mutable c_parmrk : bool; (** Mark parity errors. *) mutable c_inpck : bool; (** Enable parity check on input. *) mutable c_istrip : bool; (** Strip 8th bit on input characters. *) mutable c_inlcr : bool; (** Map NL to CR on input. *) mutable c_igncr : bool; (** Ignore CR on input. *) mutable c_icrnl : bool; (** Map CR to NL on input. *) mutable c_ixon : bool; (** Recognize XON/XOFF characters on input. *) mutable c_ixoff : bool; (** Emit XON/XOFF chars to control input flow. *) (* Output modes: *) mutable c_opost : bool; (** Enable output processing. *) (* Control modes: *) mutable c_obaud : int; (** Output baud rate (0 means close connection).*) mutable c_ibaud : int; (** Input baud rate. *) mutable c_csize : int; (** Number of bits per character (5-8). *) mutable c_cstopb : int; (** Number of stop bits (1-2). *) mutable c_cread : bool; (** Reception is enabled. *) mutable c_parenb : bool; (** Enable parity generation and detection. *) mutable c_parodd : bool; (** Specify odd parity instead of even. *) mutable c_hupcl : bool; (** Hang up on last close. *) mutable c_clocal : bool; (** Ignore modem status lines. *) (* Local modes: *) mutable c_isig : bool; (** Generate signal on INTR, QUIT, SUSP. *) mutable c_icanon : bool; (** Enable canonical processing (line buffering and editing) *) mutable c_noflsh : bool; (** Disable flush after INTR, QUIT, SUSP. *) mutable c_echo : bool; (** Echo input characters. *) mutable c_echoe : bool; (** Echo ERASE (to erase previous character). *) mutable c_echok : bool; (** Echo KILL (to erase the current line). *) mutable c_echonl : bool; (** Echo NL even if c_echo is not set. *) (* Control characters: *) mutable c_vintr : char; (** Interrupt character (usually ctrl-C). *) mutable c_vquit : char; (** Quit character (usually ctrl-\). *) mutable c_verase : char; (** Erase character (usually DEL or ctrl-H). *) mutable c_vkill : char; (** Kill line character (usually ctrl-U). *) mutable c_veof : char; (** End-of-file character (usually ctrl-D). *) mutable c_veol : char; (** Alternate end-of-line char. (usually none). *) mutable c_vmin : int; (** Minimum number of characters to read before the read request is satisfied. *) mutable c_vtime : int; (** Maximum read wait (in 0.1s units). *) mutable c_vstart : char; (** Start character (usually ctrl-Q). *) mutable c_vstop : char; (** Stop character (usually ctrl-S). *) } val tcgetattr : file_descr -> terminal_io (** Return the status of the terminal referred to by the given file descriptor. *) type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH val tcsetattr : file_descr -> setattr_when -> terminal_io -> unit (** Set the status of the terminal referred to by the given file descriptor. The second argument indicates when the status change takes place: immediately ([TCSANOW]), when all pending output has been transmitted ([TCSADRAIN]), or after flushing all input that has been received but not read ([TCSAFLUSH]). [TCSADRAIN] is recommended when changing the output parameters; [TCSAFLUSH], when changing the input parameters. *) val tcsendbreak : file_descr -> int -> unit (** Send a break condition on the given file descriptor. The second argument is the duration of the break, in 0.1s units; 0 means standard duration (0.25s). *) val tcdrain : file_descr -> unit (** Waits until all output written on the given file descriptor has been transmitted. *) type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH val tcflush : file_descr -> flush_queue -> unit (** Discard data written on the given file descriptor but not yet transmitted, or data received but not yet read, depending on the second argument: [TCIFLUSH] flushes data received but not read, [TCOFLUSH] flushes data written but not transmitted, and [TCIOFLUSH] flushes both. *) type flow_action = TCOOFF | TCOON | TCIOFF | TCION val tcflow : file_descr -> flow_action -> unit (** Suspend or restart reception or transmission of data on the given file descriptor, depending on the second argument: [TCOOFF] suspends output, [TCOON] restarts output, [TCIOFF] transmits a STOP character to suspend input, and [TCION] transmits a START character to restart input. *) val setsid : unit -> int (** Put the calling process in a new session and detach it from its controlling terminal. *) mingw-ocaml/ocaml/otherlibs/unix/termios.c0000644000175000017500000001724412124403241020272 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" #ifdef HAS_TERMIOS #include #include static struct termios terminal_status; enum { Bool, Enum, Speed, Char, End }; enum { Input, Output }; #define iflags ((long)(&terminal_status.c_iflag)) #define oflags ((long)(&terminal_status.c_oflag)) #define cflags ((long)(&terminal_status.c_cflag)) #define lflags ((long)(&terminal_status.c_lflag)) /* Number of fields in the terminal_io record field. Cf. unix.mli */ #define NFIELDS 38 /* Structure of the terminal_io record. Cf. unix.mli */ static long terminal_io_descr[] = { /* Input modes */ Bool, iflags, IGNBRK, Bool, iflags, BRKINT, Bool, iflags, IGNPAR, Bool, iflags, PARMRK, Bool, iflags, INPCK, Bool, iflags, ISTRIP, Bool, iflags, INLCR, Bool, iflags, IGNCR, Bool, iflags, ICRNL, Bool, iflags, IXON, Bool, iflags, IXOFF, /* Output modes */ Bool, oflags, OPOST, /* Control modes */ Speed, Output, Speed, Input, Enum, cflags, 5, 4, CSIZE, CS5, CS6, CS7, CS8, Enum, cflags, 1, 2, CSTOPB, 0, CSTOPB, Bool, cflags, CREAD, Bool, cflags, PARENB, Bool, cflags, PARODD, Bool, cflags, HUPCL, Bool, cflags, CLOCAL, /* Local modes */ Bool, lflags, ISIG, Bool, lflags, ICANON, Bool, lflags, NOFLSH, Bool, lflags, ECHO, Bool, lflags, ECHOE, Bool, lflags, ECHOK, Bool, lflags, ECHONL, /* Control characters */ Char, VINTR, Char, VQUIT, Char, VERASE, Char, VKILL, Char, VEOF, Char, VEOL, Char, VMIN, Char, VTIME, Char, VSTART, Char, VSTOP, End }; #undef iflags #undef oflags #undef cflags #undef lflags struct speedtable_entry ; static struct { speed_t speed; int baud; } speedtable[] = { {B50, 50}, {B75, 75}, {B110, 110}, {B134, 134}, {B150, 150}, {B300, 300}, {B600, 600}, {B1200, 1200}, {B1800, 1800}, {B2400, 2400}, {B4800, 4800}, {B9600, 9600}, {B19200, 19200}, {B38400, 38400}, #ifdef B57600 {B57600, 57600}, #endif #ifdef B115200 {B115200, 115200}, #endif #ifdef B230400 {B230400, 230400}, #endif {B0, 0} }; #define NSPEEDS (sizeof(speedtable) / sizeof(speedtable[0])) static void encode_terminal_status(value *dst) { long * pc; int i; for(pc = terminal_io_descr; *pc != End; dst++) { switch(*pc++) { case Bool: { int * src = (int *) (*pc++); int msk = *pc++; *dst = Val_bool(*src & msk); break; } case Enum: { int * src = (int *) (*pc++); int ofs = *pc++; int num = *pc++; int msk = *pc++; for (i = 0; i < num; i++) { if ((*src & msk) == pc[i]) { *dst = Val_int(i + ofs); break; } } pc += num; break; } case Speed: { int which = *pc++; speed_t speed = 0; *dst = Val_int(9600); /* in case no speed in speedtable matches */ switch (which) { case Output: speed = cfgetospeed(&terminal_status); break; case Input: speed = cfgetispeed(&terminal_status); break; } for (i = 0; i < NSPEEDS; i++) { if (speed == speedtable[i].speed) { *dst = Val_int(speedtable[i].baud); break; } } break; } case Char: { int which = *pc++; *dst = Val_int(terminal_status.c_cc[which]); break; } } } } static void decode_terminal_status(value *src) { long * pc; int i; for (pc = terminal_io_descr; *pc != End; src++) { switch(*pc++) { case Bool: { int * dst = (int *) (*pc++); int msk = *pc++; if (Bool_val(*src)) *dst |= msk; else *dst &= ~msk; break; } case Enum: { int * dst = (int *) (*pc++); int ofs = *pc++; int num = *pc++; int msk = *pc++; i = Int_val(*src) - ofs; if (i >= 0 && i < num) { *dst = (*dst & ~msk) | pc[i]; } else { unix_error(EINVAL, "tcsetattr", Nothing); } pc += num; break; } case Speed: { int which = *pc++; int baud = Int_val(*src); int res = 0; for (i = 0; i < NSPEEDS; i++) { if (baud == speedtable[i].baud) { switch (which) { case Output: res = cfsetospeed(&terminal_status, speedtable[i].speed); break; case Input: res = cfsetispeed(&terminal_status, speedtable[i].speed); break; } if (res == -1) uerror("tcsetattr", Nothing); goto ok; } } unix_error(EINVAL, "tcsetattr", Nothing); ok: break; } case Char: { int which = *pc++; terminal_status.c_cc[which] = Int_val(*src); break; } } } } CAMLprim value unix_tcgetattr(value fd) { value res; if (tcgetattr(Int_val(fd), &terminal_status) == -1) uerror("tcgetattr", Nothing); res = alloc_tuple(NFIELDS); encode_terminal_status(&Field(res, 0)); return res; } static int when_flag_table[] = { TCSANOW, TCSADRAIN, TCSAFLUSH }; CAMLprim value unix_tcsetattr(value fd, value when, value arg) { if (tcgetattr(Int_val(fd), &terminal_status) == -1) uerror("tcsetattr", Nothing); decode_terminal_status(&Field(arg, 0)); if (tcsetattr(Int_val(fd), when_flag_table[Int_val(when)], &terminal_status) == -1) uerror("tcsetattr", Nothing); return Val_unit; } CAMLprim value unix_tcsendbreak(value fd, value delay) { if (tcsendbreak(Int_val(fd), Int_val(delay)) == -1) uerror("tcsendbreak", Nothing); return Val_unit; } CAMLprim value unix_tcdrain(value fd) { if (tcdrain(Int_val(fd)) == -1) uerror("tcdrain", Nothing); return Val_unit; } static int queue_flag_table[] = { TCIFLUSH, TCOFLUSH, TCIOFLUSH }; CAMLprim value unix_tcflush(value fd, value queue) { if (tcflush(Int_val(fd), queue_flag_table[Int_val(queue)]) == -1) uerror("tcflush", Nothing); return Val_unit; } static int action_flag_table[] = { TCOOFF, TCOON, TCIOFF, TCION }; CAMLprim value unix_tcflow(value fd, value action) { if (tcflow(Int_val(fd), action_flag_table[Int_val(action)]) == -1) uerror("tcflow", Nothing); return Val_unit; } #else CAMLprim value unix_tcgetattr(value fd) { invalid_argument("tcgetattr not implemented"); } CAMLprim value unix_tcsetattr(value fd, value when, value arg) { invalid_argument("tcsetattr not implemented"); } CAMLprim value unix_tcsendbreak(value fd, value delay) { invalid_argument("tcsendbreak not implemented"); } CAMLprim value unix_tcdrain(value fd) { invalid_argument("tcdrain not implemented"); } CAMLprim value unix_tcflush(value fd, value queue) { invalid_argument("tcflush not implemented"); } CAMLprim value unix_tcflow(value fd, value action) { invalid_argument("tcflow not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/Makefile0000644000175000017500000000416612124403241020103 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ # Makefile for the Unix interface library LIBNAME=unix EXTRACAMLFLAGS=-nolabels COBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \ chown.o chroot.o close.o closedir.o connect.o cst2constr.o cstringv.o \ dup.o dup2.o envir.o errmsg.o execv.o execve.o execvp.o exit.o \ fchmod.o fchown.o fcntl.o fork.o ftruncate.o \ getaddrinfo.o getcwd.o getegid.o geteuid.o getgid.o \ getgr.o getgroups.o gethost.o gethostname.o getlogin.o \ getnameinfo.o getpeername.o getpid.o getppid.o getproto.o getpw.o \ gettimeofday.o getserv.o getsockname.o getuid.o gmtime.o \ initgroups.o isatty.o itimer.o kill.o link.o listen.o lockf.o lseek.o \ mkdir.o mkfifo.o nice.o open.o opendir.o pipe.o putenv.o read.o \ readdir.o readlink.o rename.o rewinddir.o rmdir.o select.o sendrecv.o \ setgid.o setgroups.o setsid.o setuid.o shutdown.o signals.o \ sleep.o socket.o socketaddr.o \ socketpair.o sockopt.o stat.o strofaddr.o symlink.o termios.o \ time.o times.o truncate.o umask.o unixsupport.o unlink.o \ utimes.o wait.o write.o CAMLOBJS=unix.cmo unixLabels.cmo HEADERS=unixsupport.h socketaddr.h include ../Makefile depend: gcc -MM $(CFLAGS) *.c > .depend ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend include .depend mingw-ocaml/ocaml/otherlibs/unix/socketaddr.h0000644000175000017500000000351612124403241020735 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include union sock_addr_union { struct sockaddr s_gen; struct sockaddr_un s_unix; struct sockaddr_in s_inet; #ifdef HAS_IPV6 struct sockaddr_in6 s_inet6; #endif }; #ifdef HAS_SOCKLEN_T typedef socklen_t socklen_param_type; #else typedef int socklen_param_type; #endif extern void get_sockaddr (value mladdr, union sock_addr_union * addr /*out*/, socklen_param_type * addr_len /*out*/); CAMLexport value alloc_sockaddr (union sock_addr_union * addr /*in*/, socklen_param_type addr_len, int close_on_error); CAMLexport value alloc_inet_addr (struct in_addr * inaddr); #define GET_INET_ADDR(v) (*((struct in_addr *) (v))) #ifdef HAS_IPV6 CAMLexport value alloc_inet6_addr (struct in6_addr * inaddr); #define GET_INET6_ADDR(v) (*((struct in6_addr *) (v))) #endif mingw-ocaml/ocaml/otherlibs/unix/write.c0000644000175000017500000000552712124403241017743 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include "unixsupport.h" #ifndef EAGAIN #define EAGAIN (-1) #endif #ifndef EWOULDBLOCK #define EWOULDBLOCK (-1) #endif CAMLprim value unix_write(value fd, value buf, value vofs, value vlen) { long ofs, len, written; int numbytes, ret; char iobuf[UNIX_BUFFER_SIZE]; Begin_root (buf); ofs = Long_val(vofs); len = Long_val(vlen); written = 0; while (len > 0) { numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; memmove (iobuf, &Byte(buf, ofs), numbytes); enter_blocking_section(); ret = write(Int_val(fd), iobuf, numbytes); leave_blocking_section(); if (ret == -1) { if ((errno == EAGAIN || errno == EWOULDBLOCK) && written > 0) break; uerror("write", Nothing); } written += ret; ofs += ret; len -= ret; } End_roots(); return Val_long(written); } /* When an error occurs after the first loop, unix_write reports the error and discards the number of already written characters. In this case, it would be better to discard the error and return the number of bytes written, since most likely, unix_write will be call again, and the error will be reproduced and this time will be reported. This problem is avoided in unix_single_write, which is faithful to the Unix system call. */ CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen) { long ofs, len; int numbytes, ret; char iobuf[UNIX_BUFFER_SIZE]; Begin_root (buf); ofs = Long_val(vofs); len = Long_val(vlen); ret = 0; if (len > 0) { numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; memmove (iobuf, &Byte(buf, ofs), numbytes); enter_blocking_section(); ret = write(Int_val(fd), iobuf, numbytes); leave_blocking_section(); if (ret == -1) uerror("single_write", Nothing); } End_roots(); return Val_int(ret); } mingw-ocaml/ocaml/otherlibs/unix/sendrecv.c0000644000175000017500000001154312124403241020415 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include "socketaddr.h" static int msg_flag_table[] = { MSG_OOB, MSG_DONTROUTE, MSG_PEEK }; CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value flags) { int ret, cv_flags; long numbytes; char iobuf[UNIX_BUFFER_SIZE]; cv_flags = convert_flag_list(flags, msg_flag_table); Begin_root (buff); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; enter_blocking_section(); ret = recv(Int_val(sock), iobuf, (int) numbytes, cv_flags); leave_blocking_section(); if (ret == -1) uerror("recv", Nothing); memmove (&Byte(buff, Long_val(ofs)), iobuf, ret); End_roots(); return Val_int(ret); } CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags) { int ret, cv_flags; long numbytes; char iobuf[UNIX_BUFFER_SIZE]; value res; value adr = Val_unit; union sock_addr_union addr; socklen_param_type addr_len; cv_flags = convert_flag_list(flags, msg_flag_table); Begin_roots2 (buff, adr); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; addr_len = sizeof(addr); enter_blocking_section(); ret = recvfrom(Int_val(sock), iobuf, (int) numbytes, cv_flags, &addr.s_gen, &addr_len); leave_blocking_section(); if (ret == -1) uerror("recvfrom", Nothing); memmove (&Byte(buff, Long_val(ofs)), iobuf, ret); adr = alloc_sockaddr(&addr, addr_len, -1); res = alloc_small(2, 0); Field(res, 0) = Val_int(ret); Field(res, 1) = adr; End_roots(); return res; } CAMLprim value unix_send(value sock, value buff, value ofs, value len, value flags) { int ret, cv_flags; long numbytes; char iobuf[UNIX_BUFFER_SIZE]; cv_flags = convert_flag_list(flags, msg_flag_table); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes); enter_blocking_section(); ret = send(Int_val(sock), iobuf, (int) numbytes, cv_flags); leave_blocking_section(); if (ret == -1) uerror("send", Nothing); return Val_int(ret); } CAMLprim value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest) { int ret, cv_flags; long numbytes; char iobuf[UNIX_BUFFER_SIZE]; union sock_addr_union addr; socklen_param_type addr_len; cv_flags = convert_flag_list(flags, msg_flag_table); get_sockaddr(dest, &addr, &addr_len); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes); enter_blocking_section(); ret = sendto(Int_val(sock), iobuf, (int) numbytes, cv_flags, &addr.s_gen, addr_len); leave_blocking_section(); if (ret == -1) uerror("sendto", Nothing); return Val_int(ret); } CAMLprim value unix_sendto(value *argv, int argc) { return unix_sendto_native (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } #else CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value flags) { invalid_argument("recv not implemented"); } CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags) { invalid_argument("recvfrom not implemented"); } CAMLprim value unix_send(value sock, value buff, value ofs, value len, value flags) { invalid_argument("send not implemented"); } CAMLprim value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest) { invalid_argument("sendto not implemented"); } CAMLprim value unix_sendto(value *argv, int argc) { invalid_argument("sendto not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/getnameinfo.c0000644000175000017500000000421112124403241021072 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2004 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include #include "unixsupport.h" #if defined(HAS_SOCKETS) && defined(HAS_IPV6) #include "socketaddr.h" #ifndef _WIN32 #include #include #endif static int getnameinfo_flag_table[] = { NI_NOFQDN, NI_NUMERICHOST, NI_NAMEREQD, NI_NUMERICSERV, NI_DGRAM }; CAMLprim value unix_getnameinfo(value vaddr, value vopts) { CAMLparam0(); CAMLlocal3(vhost, vserv, vres); union sock_addr_union addr; socklen_param_type addr_len; char host[4096]; char serv[1024]; int opts, retcode; get_sockaddr(vaddr, &addr, &addr_len); opts = convert_flag_list(vopts, getnameinfo_flag_table); enter_blocking_section(); retcode = getnameinfo((const struct sockaddr *) &addr.s_gen, addr_len, host, sizeof(host), serv, sizeof(serv), opts); leave_blocking_section(); if (retcode != 0) raise_not_found(); /* TODO: detailed error reporting? */ vhost = copy_string(host); vserv = copy_string(serv); vres = alloc_small(2, 0); Field(vres, 0) = vhost; Field(vres, 1) = vserv; CAMLreturn(vres); } #else CAMLprim value unix_getnameinfo(value vaddr, value vopts) { invalid_argument("getnameinfo not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/dup.c0000644000175000017500000000210012124403241017361 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_dup(value fd) { int ret; ret = dup(Int_val(fd)); if (ret == -1) uerror("dup", Nothing); return Val_int(ret); } mingw-ocaml/ocaml/otherlibs/unix/getgroups.c0000644000175000017500000000273412124403241020625 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #ifdef HAS_GETGROUPS #include #ifdef HAS_UNISTD #include #endif #include #include "unixsupport.h" CAMLprim value unix_getgroups(value unit) { gid_t gidset[NGROUPS_MAX]; int n; value res; int i; n = getgroups(NGROUPS_MAX, gidset); if (n == -1) uerror("getgroups", Nothing); res = alloc_tuple(n); for (i = 0; i < n; i++) Field(res, i) = Val_int(gidset[i]); return res; } #else CAMLprim value unix_getgroups(value unit) { invalid_argument("getgroups not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/setgroups.c0000644000175000017500000000311312124403241020631 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Contributed by Stephane Glondu */ /* */ /* Copyright 2009 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #ifdef HAS_SETGROUPS #include #ifdef HAS_UNISTD #include #endif #include #include #include "unixsupport.h" CAMLprim value unix_setgroups(value groups) { gid_t * gidset; mlsize_t size, i; int n; size = Wosize_val(groups); gidset = (gid_t *) stat_alloc(size * sizeof(gid_t)); for (i = 0; i < size; i++) gidset[i] = Int_val(Field(groups, i)); n = setgroups(size, gidset); stat_free(gidset); if (n == -1) uerror("setgroups", Nothing); return Val_unit; } #else CAMLprim value unix_setgroups(value groups) { invalid_argument("setgroups not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/chdir.c0000644000175000017500000000210612124403241017670 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_chdir(value path) { int ret; ret = chdir(String_val(path)); if (ret == -1) uerror("chdir", path); return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/fchmod.c0000644000175000017500000000241312124403241020040 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #ifdef HAS_FCHMOD CAMLprim value unix_fchmod(value fd, value perm) { if (fchmod(Int_val(fd), Int_val(perm)) == -1) uerror("fchmod", Nothing); return Val_unit; } #else CAMLprim value unix_fchmod(value fd, value perm) { invalid_argument("fchmod not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/kill.c0000644000175000017500000000226612124403241017541 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #include #include CAMLprim value unix_kill(value pid, value signal) { int sig; sig = convert_signal_number(Int_val(signal)); if (kill(Int_val(pid), sig) == -1) uerror("kill", Nothing); return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/utimes.c0000644000175000017500000000410112124403241020102 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #ifdef HAS_UTIME #include #ifndef _WIN32 #include #else #include #endif CAMLprim value unix_utimes(value path, value atime, value mtime) { struct utimbuf times, * t; times.actime = Double_val(atime); times.modtime = Double_val(mtime); if (times.actime || times.modtime) t = × else t = (struct utimbuf *) NULL; if (utime(String_val(path), t) == -1) uerror("utimes", path); return Val_unit; } #else #ifdef HAS_UTIMES #include #include CAMLprim value unix_utimes(value path, value atime, value mtime) { struct timeval tv[2], * t; double at = Double_val(atime); double mt = Double_val(mtime); tv[0].tv_sec = at; tv[0].tv_usec = (at - tv[0].tv_sec) * 1000000; tv[1].tv_sec = mt; tv[1].tv_usec = (mt - tv[1].tv_sec) * 1000000; if (tv[0].tv_sec || tv[1].tv_sec) t = tv; else t = (struct timeval *) NULL; if (utimes(String_val(path), t) == -1) uerror("utimes", path); return Val_unit; } #else CAMLprim value unix_utimes(value path, value atime, value mtime) { invalid_argument("utimes not implemented"); } #endif #endif mingw-ocaml/ocaml/otherlibs/unix/execvp.c0000644000175000017500000000350712124403241020077 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" extern char ** cstringvect(); #ifndef _WIN32 extern char ** environ; #endif CAMLprim value unix_execvp(value path, value args) { char ** argv; argv = cstringvect(args); (void) execvp(String_val(path), argv); stat_free((char *) argv); uerror("execvp", path); return Val_unit; /* never reached, but suppress warnings */ /* from smart compilers */ } CAMLprim value unix_execvpe(value path, value args, value env) { char ** argv; char ** saved_environ; argv = cstringvect(args); saved_environ = environ; environ = cstringvect(env); (void) execvp(String_val(path), argv); stat_free((char *) argv); stat_free((char *) environ); environ = saved_environ; uerror("execvp", path); return Val_unit; /* never reached, but suppress warnings */ /* from smart compilers */ } mingw-ocaml/ocaml/otherlibs/unix/readlink.c0000644000175000017500000000271212124403241020373 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #ifdef HAS_SYMLINK #include #include "unixsupport.h" #ifndef PATH_MAX #ifdef MAXPATHLEN #define PATH_MAX MAXPATHLEN #else #define PATH_MAX 512 #endif #endif CAMLprim value unix_readlink(value path) { char buffer[PATH_MAX]; int len; len = readlink(String_val(path), buffer, sizeof(buffer) - 1); if (len == -1) uerror("readlink", path); buffer[len] = '\0'; return copy_string(buffer); } #else CAMLprim value unix_readlink(value path) { invalid_argument("readlink not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/fork.c0000644000175000017500000000236112124403241017543 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" CAMLprim value unix_fork(value unit) { int ret; ret = fork(); if (ret == -1) uerror("fork", Nothing); if (caml_debugger_in_use) if ((caml_debugger_fork_mode && ret == 0) || (!caml_debugger_fork_mode && ret != 0)) caml_debugger_cleanup_fork(); return Val_int(ret); } mingw-ocaml/ocaml/otherlibs/unix/open.c0000644000175000017500000000352112124403241017542 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #include #include #ifndef O_NONBLOCK #define O_NONBLOCK O_NDELAY #endif #ifndef O_DSYNC #define O_DSYNC 0 #endif #ifndef O_SYNC #define O_SYNC 0 #endif #ifndef O_RSYNC #define O_RSYNC 0 #endif static int open_flag_table[] = { O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC, 0 }; CAMLprim value unix_open(value path, value flags, value perm) { CAMLparam3(path, flags, perm); int ret, cv_flags; char * p; cv_flags = convert_flag_list(flags, open_flag_table); p = stat_alloc(string_length(path) + 1); strcpy(p, String_val(path)); /* open on a named FIFO can block (PR#1533) */ enter_blocking_section(); ret = open(p, cv_flags, Int_val(perm)); leave_blocking_section(); stat_free(p); if (ret == -1) uerror("open", path); CAMLreturn (Val_int(ret)); } mingw-ocaml/ocaml/otherlibs/unix/bind.c0000644000175000017500000000261112124403241017514 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include "socketaddr.h" CAMLprim value unix_bind(value socket, value address) { int ret; union sock_addr_union addr; socklen_param_type addr_len; get_sockaddr(address, &addr, &addr_len); ret = bind(Int_val(socket), &addr.s_gen, addr_len); if (ret == -1) uerror("bind", Nothing); return Val_unit; } #else CAMLprim value unix_bind(value socket, value address) { invalid_argument("bind not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/select.c0000644000175000017500000000661112124403241020063 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include "unixsupport.h" #ifdef HAS_SELECT #include #include #ifdef HAS_SYS_SELECT_H #include #endif #include #include #include static int fdlist_to_fdset(value fdlist, fd_set *fdset, int *maxfd) { value l; FD_ZERO(fdset); for (l = fdlist; l != Val_int(0); l = Field(l, 1)) { long fd = Long_val(Field(l, 0)); /* PR#5563: harden against bad fds */ if (fd < 0 || fd >= FD_SETSIZE) return -1; FD_SET((int) fd, fdset); if (fd > *maxfd) *maxfd = fd; } return 0; } static value fdset_to_fdlist(value fdlist, fd_set *fdset) { value l; value res = Val_int(0); Begin_roots2(l, res); for (l = fdlist; l != Val_int(0); l = Field(l, 1)) { int fd = Int_val(Field(l, 0)); if (FD_ISSET(fd, fdset)) { value newres = alloc_small(2, 0); Field(newres, 0) = Val_int(fd); Field(newres, 1) = res; res = newres; } } End_roots(); return res; } CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value timeout) { fd_set read, write, except; int maxfd; double tm; struct timeval tv; struct timeval * tvp; int retcode; value res; Begin_roots3 (readfds, writefds, exceptfds); maxfd = -1; retcode = fdlist_to_fdset(readfds, &read, &maxfd); retcode += fdlist_to_fdset(writefds, &write, &maxfd); retcode += fdlist_to_fdset(exceptfds, &except, &maxfd); /* PR#5563: if a bad fd was encountered, report EINVAL error */ if (retcode != 0) unix_error(EINVAL, "select", Nothing); tm = Double_val(timeout); if (tm < 0.0) tvp = (struct timeval *) NULL; else { tv.tv_sec = (int) tm; tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec)); tvp = &tv; } enter_blocking_section(); retcode = select(maxfd + 1, &read, &write, &except, tvp); leave_blocking_section(); if (retcode == -1) uerror("select", Nothing); readfds = fdset_to_fdlist(readfds, &read); writefds = fdset_to_fdlist(writefds, &write); exceptfds = fdset_to_fdlist(exceptfds, &except); res = alloc_small(3, 0); Field(res, 0) = readfds; Field(res, 1) = writefds; Field(res, 2) = exceptfds; End_roots(); return res; } #else CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value timeout) { invalid_argument("select not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/getpid.c0000644000175000017500000000177412124403241020065 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_getpid(value unit) { return Val_int(getpid()); } mingw-ocaml/ocaml/otherlibs/unix/getegid.c0000644000175000017500000000177612124403241020223 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_getegid(value unit) { return Val_int(getegid()); } mingw-ocaml/ocaml/otherlibs/unix/umask.c0000644000175000017500000000206412124403241017722 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" CAMLprim value unix_umask(value perm) { return Val_int(umask(Int_val(perm))); } mingw-ocaml/ocaml/otherlibs/unix/gmtime.c0000644000175000017500000000546312124403241020072 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #include #include static value alloc_tm(struct tm *tm) { value res; res = alloc_small(9, 0); Field(res,0) = Val_int(tm->tm_sec); Field(res,1) = Val_int(tm->tm_min); Field(res,2) = Val_int(tm->tm_hour); Field(res,3) = Val_int(tm->tm_mday); Field(res,4) = Val_int(tm->tm_mon); Field(res,5) = Val_int(tm->tm_year); Field(res,6) = Val_int(tm->tm_wday); Field(res,7) = Val_int(tm->tm_yday); Field(res,8) = tm->tm_isdst ? Val_true : Val_false; return res; } CAMLprim value unix_gmtime(value t) { time_t clock; struct tm * tm; clock = (time_t) Double_val(t); tm = gmtime(&clock); if (tm == NULL) unix_error(EINVAL, "gmtime", Nothing); return alloc_tm(tm); } CAMLprim value unix_localtime(value t) { time_t clock; struct tm * tm; clock = (time_t) Double_val(t); tm = localtime(&clock); if (tm == NULL) unix_error(EINVAL, "localtime", Nothing); return alloc_tm(tm); } #ifdef HAS_MKTIME CAMLprim value unix_mktime(value t) { struct tm tm; time_t clock; value res; value tmval = Val_unit, clkval = Val_unit; Begin_roots2(tmval, clkval); tm.tm_sec = Int_val(Field(t, 0)); tm.tm_min = Int_val(Field(t, 1)); tm.tm_hour = Int_val(Field(t, 2)); tm.tm_mday = Int_val(Field(t, 3)); tm.tm_mon = Int_val(Field(t, 4)); tm.tm_year = Int_val(Field(t, 5)); tm.tm_wday = Int_val(Field(t, 6)); tm.tm_yday = Int_val(Field(t, 7)); tm.tm_isdst = -1; /* tm.tm_isdst = Bool_val(Field(t, 8)); */ clock = mktime(&tm); if (clock == (time_t) -1) unix_error(ERANGE, "mktime", Nothing); tmval = alloc_tm(&tm); clkval = copy_double((double) clock); res = alloc_small(2, 0); Field(res, 0) = clkval; Field(res, 1) = tmval; End_roots (); return res; } #else CAMLprim value unix_mktime(value t) { invalid_argument("mktime not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/readdir.c0000644000175000017500000000265612124403241020223 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" #include #include #ifdef HAS_DIRENT #include typedef struct dirent directory_entry; #else #include typedef struct direct directory_entry; #endif CAMLprim value unix_readdir(value vd) { DIR * d; directory_entry * e; d = DIR_Val(vd); if (d == (DIR *) NULL) unix_error(EBADF, "readdir", Nothing); e = readdir((DIR *) d); if (e == (directory_entry *) NULL) raise_end_of_file(); return copy_string(e->d_name); } mingw-ocaml/ocaml/otherlibs/unix/mkfifo.c0000644000175000017500000000302512124403241020053 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #ifdef HAS_MKFIFO CAMLprim value unix_mkfifo(value path, value mode) { if (mkfifo(String_val(path), Int_val(mode)) == -1) uerror("mkfifo", path); return Val_unit; } #else #include #include #ifdef S_IFIFO CAMLprim value unix_mkfifo(value path, value mode) { if (mknod(String_val(path), (Int_val(mode) & 07777) | S_IFIFO, 0) == -1) uerror("mkfifo", path); return Val_unit; } #else CAMLprim value unix_mkfifo(value path, value mode) { invalid_argument("mkfifo not implemented"); } #endif #endif mingw-ocaml/ocaml/otherlibs/unix/sleep.c0000644000175000017500000000212112124403241017704 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" CAMLprim value unix_sleep(value t) { enter_blocking_section(); sleep(Int_val(t)); leave_blocking_section(); return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/getcwd.c0000644000175000017500000000313312124403241020055 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" #if !defined (_WIN32) && !macintosh #include #endif #ifndef PATH_MAX #ifdef MAXPATHLEN #define PATH_MAX MAXPATHLEN #else #define PATH_MAX 512 #endif #endif #ifdef HAS_GETCWD CAMLprim value unix_getcwd(value unit) { char buff[PATH_MAX]; if (getcwd(buff, sizeof(buff)) == 0) uerror("getcwd", Nothing); return copy_string(buff); } #else #ifdef HAS_GETWD CAMLprim value unix_getcwd(value unit) { char buff[PATH_MAX]; if (getwd(buff) == 0) uerror("getcwd", copy_string(buff)); return copy_string(buff); } #else CAMLprim value unix_getcwd(value unit) { invalid_argument("getcwd not implemented"); } #endif #endif mingw-ocaml/ocaml/otherlibs/unix/gettimeofday.c0000644000175000017500000000254612124403241021270 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" #ifdef HAS_GETTIMEOFDAY #include #include CAMLprim value unix_gettimeofday(value unit) { struct timeval tp; if (gettimeofday(&tp, NULL) == -1) uerror("gettimeofday", Nothing); return copy_double((double) tp.tv_sec + (double) tp.tv_usec / 1e6); } #else CAMLprim value unix_gettimeofday(value unit) { invalid_argument("gettimeofday not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/read.c0000644000175000017500000000274212124403241017520 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" CAMLprim value unix_read(value fd, value buf, value ofs, value len) { long numbytes; int ret; char iobuf[UNIX_BUFFER_SIZE]; Begin_root (buf); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; enter_blocking_section(); ret = read(Int_val(fd), iobuf, (int) numbytes); leave_blocking_section(); if (ret == -1) uerror("read", Nothing); memmove (&Byte(buf, Long_val(ofs)), iobuf, ret); End_roots(); return Val_int(ret); } mingw-ocaml/ocaml/otherlibs/unix/pipe.c0000644000175000017500000000224712124403241017542 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" CAMLprim value unix_pipe(value unit) { int fd[2]; value res; if (pipe(fd) == -1) uerror("pipe", Nothing); res = alloc_small(2, 0); Field(res, 0) = Val_int(fd[0]); Field(res, 1) = Val_int(fd[1]); return res; } mingw-ocaml/ocaml/otherlibs/unix/chroot.c0000644000175000017500000000211112124403241020071 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_chroot(value path) { int ret; ret = chroot(String_val(path)); if (ret == -1) uerror("chroot", path); return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/unix.ml0000644000175000017500000007162712124403241017766 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) type error = E2BIG | EACCES | EAGAIN | EBADF | EBUSY | ECHILD | EDEADLK | EDOM | EEXIST | EFAULT | EFBIG | EINTR | EINVAL | EIO | EISDIR | EMFILE | EMLINK | ENAMETOOLONG | ENFILE | ENODEV | ENOENT | ENOEXEC | ENOLCK | ENOMEM | ENOSPC | ENOSYS | ENOTDIR | ENOTEMPTY | ENOTTY | ENXIO | EPERM | EPIPE | ERANGE | EROFS | ESPIPE | ESRCH | EXDEV | EWOULDBLOCK | EINPROGRESS | EALREADY | ENOTSOCK | EDESTADDRREQ | EMSGSIZE | EPROTOTYPE | ENOPROTOOPT | EPROTONOSUPPORT | ESOCKTNOSUPPORT | EOPNOTSUPP | EPFNOSUPPORT | EAFNOSUPPORT | EADDRINUSE | EADDRNOTAVAIL | ENETDOWN | ENETUNREACH | ENETRESET | ECONNABORTED | ECONNRESET | ENOBUFS | EISCONN | ENOTCONN | ESHUTDOWN | ETOOMANYREFS | ETIMEDOUT | ECONNREFUSED | EHOSTDOWN | EHOSTUNREACH | ELOOP | EOVERFLOW | EUNKNOWNERR of int exception Unix_error of error * string * string let _ = Callback.register_exception "Unix.Unix_error" (Unix_error(E2BIG, "", "")) external error_message : error -> string = "unix_error_message" let handle_unix_error f arg = try f arg with Unix_error(err, fun_name, arg) -> prerr_string Sys.argv.(0); prerr_string ": \""; prerr_string fun_name; prerr_string "\" failed"; if String.length arg > 0 then begin prerr_string " on \""; prerr_string arg; prerr_string "\"" end; prerr_string ": "; prerr_endline (error_message err); exit 2 external environment : unit -> string array = "unix_environment" external getenv: string -> string = "caml_sys_getenv" external putenv: string -> string -> unit = "unix_putenv" type process_status = WEXITED of int | WSIGNALED of int | WSTOPPED of int type wait_flag = WNOHANG | WUNTRACED external execv : string -> string array -> 'a = "unix_execv" external execve : string -> string array -> string array -> 'a = "unix_execve" external execvp : string -> string array -> 'a = "unix_execvp" external execvpe : string -> string array -> string array -> 'a = "unix_execvpe" external fork : unit -> int = "unix_fork" external wait : unit -> int * process_status = "unix_wait" external waitpid : wait_flag list -> int -> int * process_status = "unix_waitpid" external getpid : unit -> int = "unix_getpid" external getppid : unit -> int = "unix_getppid" external nice : int -> int = "unix_nice" type file_descr = int let stdin = 0 let stdout = 1 let stderr = 2 type open_flag = O_RDONLY | O_WRONLY | O_RDWR | O_NONBLOCK | O_APPEND | O_CREAT | O_TRUNC | O_EXCL | O_NOCTTY | O_DSYNC | O_SYNC | O_RSYNC | O_SHARE_DELETE type file_perm = int external openfile : string -> open_flag list -> file_perm -> file_descr = "unix_open" external close : file_descr -> unit = "unix_close" external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read" external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write" external unsafe_single_write : file_descr -> string -> int -> int -> int = "unix_single_write" let read fd buf ofs len = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.read" else unsafe_read fd buf ofs len let write fd buf ofs len = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.write" else unsafe_write fd buf ofs len (* write misbehaves because it attempts to write all data by making repeated calls to the Unix write function (see comment in write.c and unix.mli). partial_write fixes this by never calling write twice. *) let single_write fd buf ofs len = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.single_write" else unsafe_single_write fd buf ofs len external in_channel_of_descr : file_descr -> in_channel = "caml_ml_open_descriptor_in" external out_channel_of_descr : file_descr -> out_channel = "caml_ml_open_descriptor_out" external descr_of_in_channel : in_channel -> file_descr = "caml_channel_descriptor" external descr_of_out_channel : out_channel -> file_descr = "caml_channel_descriptor" type seek_command = SEEK_SET | SEEK_CUR | SEEK_END external lseek : file_descr -> int -> seek_command -> int = "unix_lseek" external truncate : string -> int -> unit = "unix_truncate" external ftruncate : file_descr -> int -> unit = "unix_ftruncate" type file_kind = S_REG | S_DIR | S_CHR | S_BLK | S_LNK | S_FIFO | S_SOCK type stats = { st_dev : int; st_ino : int; st_kind : file_kind; st_perm : file_perm; st_nlink : int; st_uid : int; st_gid : int; st_rdev : int; st_size : int; st_atime : float; st_mtime : float; st_ctime : float } external stat : string -> stats = "unix_stat" external lstat : string -> stats = "unix_lstat" external fstat : file_descr -> stats = "unix_fstat" external isatty : file_descr -> bool = "unix_isatty" external unlink : string -> unit = "unix_unlink" external rename : string -> string -> unit = "unix_rename" external link : string -> string -> unit = "unix_link" module LargeFile = struct external lseek : file_descr -> int64 -> seek_command -> int64 = "unix_lseek_64" external truncate : string -> int64 -> unit = "unix_truncate_64" external ftruncate : file_descr -> int64 -> unit = "unix_ftruncate_64" type stats = { st_dev : int; st_ino : int; st_kind : file_kind; st_perm : file_perm; st_nlink : int; st_uid : int; st_gid : int; st_rdev : int; st_size : int64; st_atime : float; st_mtime : float; st_ctime : float; } external stat : string -> stats = "unix_stat_64" external lstat : string -> stats = "unix_lstat_64" external fstat : file_descr -> stats = "unix_fstat_64" end type access_permission = R_OK | W_OK | X_OK | F_OK external chmod : string -> file_perm -> unit = "unix_chmod" external fchmod : file_descr -> file_perm -> unit = "unix_fchmod" external chown : string -> int -> int -> unit = "unix_chown" external fchown : file_descr -> int -> int -> unit = "unix_fchown" external umask : int -> int = "unix_umask" external access : string -> access_permission list -> unit = "unix_access" external dup : file_descr -> file_descr = "unix_dup" external dup2 : file_descr -> file_descr -> unit = "unix_dup2" external set_nonblock : file_descr -> unit = "unix_set_nonblock" external clear_nonblock : file_descr -> unit = "unix_clear_nonblock" external set_close_on_exec : file_descr -> unit = "unix_set_close_on_exec" external clear_close_on_exec : file_descr -> unit = "unix_clear_close_on_exec" (* FD_CLOEXEC should be supported on all Unix systems these days, but just in case... *) let try_set_close_on_exec fd = try set_close_on_exec fd; true with Invalid_argument _ -> false external mkdir : string -> file_perm -> unit = "unix_mkdir" external rmdir : string -> unit = "unix_rmdir" external chdir : string -> unit = "unix_chdir" external getcwd : unit -> string = "unix_getcwd" external chroot : string -> unit = "unix_chroot" type dir_handle external opendir : string -> dir_handle = "unix_opendir" external readdir : dir_handle -> string = "unix_readdir" external rewinddir : dir_handle -> unit = "unix_rewinddir" external closedir : dir_handle -> unit = "unix_closedir" external pipe : unit -> file_descr * file_descr = "unix_pipe" external symlink : string -> string -> unit = "unix_symlink" external readlink : string -> string = "unix_readlink" external mkfifo : string -> file_perm -> unit = "unix_mkfifo" external select : file_descr list -> file_descr list -> file_descr list -> float -> file_descr list * file_descr list * file_descr list = "unix_select" type lock_command = F_ULOCK | F_LOCK | F_TLOCK | F_TEST | F_RLOCK | F_TRLOCK external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf" external kill : int -> int -> unit = "unix_kill" type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK external sigprocmask: sigprocmask_command -> int list -> int list = "unix_sigprocmask" external sigpending: unit -> int list = "unix_sigpending" external sigsuspend: int list -> unit = "unix_sigsuspend" let pause() = let sigs = sigprocmask SIG_BLOCK [] in sigsuspend sigs type process_times = { tms_utime : float; tms_stime : float; tms_cutime : float; tms_cstime : float } type tm = { tm_sec : int; tm_min : int; tm_hour : int; tm_mday : int; tm_mon : int; tm_year : int; tm_wday : int; tm_yday : int; tm_isdst : bool } external time : unit -> float = "unix_time" external gettimeofday : unit -> float = "unix_gettimeofday" external gmtime : float -> tm = "unix_gmtime" external localtime : float -> tm = "unix_localtime" external mktime : tm -> float * tm = "unix_mktime" external alarm : int -> int = "unix_alarm" external sleep : int -> unit = "unix_sleep" external times : unit -> process_times = "unix_times" external utimes : string -> float -> float -> unit = "unix_utimes" type interval_timer = ITIMER_REAL | ITIMER_VIRTUAL | ITIMER_PROF type interval_timer_status = { it_interval: float; (* Period *) it_value: float } (* Current value of the timer *) external getitimer: interval_timer -> interval_timer_status = "unix_getitimer" external setitimer: interval_timer -> interval_timer_status -> interval_timer_status = "unix_setitimer" external getuid : unit -> int = "unix_getuid" external geteuid : unit -> int = "unix_geteuid" external setuid : int -> unit = "unix_setuid" external getgid : unit -> int = "unix_getgid" external getegid : unit -> int = "unix_getegid" external setgid : int -> unit = "unix_setgid" external getgroups : unit -> int array = "unix_getgroups" external setgroups : int array -> unit = "unix_setgroups" external initgroups : string -> int -> unit = "unix_initgroups" type passwd_entry = { pw_name : string; pw_passwd : string; pw_uid : int; pw_gid : int; pw_gecos : string; pw_dir : string; pw_shell : string } type group_entry = { gr_name : string; gr_passwd : string; gr_gid : int; gr_mem : string array } external getlogin : unit -> string = "unix_getlogin" external getpwnam : string -> passwd_entry = "unix_getpwnam" external getgrnam : string -> group_entry = "unix_getgrnam" external getpwuid : int -> passwd_entry = "unix_getpwuid" external getgrgid : int -> group_entry = "unix_getgrgid" type inet_addr = string let is_inet6_addr s = String.length s = 16 external inet_addr_of_string : string -> inet_addr = "unix_inet_addr_of_string" external string_of_inet_addr : inet_addr -> string = "unix_string_of_inet_addr" let inet_addr_any = inet_addr_of_string "0.0.0.0" let inet_addr_loopback = inet_addr_of_string "127.0.0.1" let inet6_addr_any = try inet_addr_of_string "::" with Failure _ -> inet_addr_any let inet6_addr_loopback = try inet_addr_of_string "::1" with Failure _ -> inet_addr_loopback type socket_domain = PF_UNIX | PF_INET | PF_INET6 type socket_type = SOCK_STREAM | SOCK_DGRAM | SOCK_RAW | SOCK_SEQPACKET type sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int let domain_of_sockaddr = function ADDR_UNIX _ -> PF_UNIX | ADDR_INET(a, _) -> if is_inet6_addr a then PF_INET6 else PF_INET type shutdown_command = SHUTDOWN_RECEIVE | SHUTDOWN_SEND | SHUTDOWN_ALL type msg_flag = MSG_OOB | MSG_DONTROUTE | MSG_PEEK external socket : socket_domain -> socket_type -> int -> file_descr = "unix_socket" external socketpair : socket_domain -> socket_type -> int -> file_descr * file_descr = "unix_socketpair" external accept : file_descr -> file_descr * sockaddr = "unix_accept" external bind : file_descr -> sockaddr -> unit = "unix_bind" external connect : file_descr -> sockaddr -> unit = "unix_connect" external listen : file_descr -> int -> unit = "unix_listen" external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" external getsockname : file_descr -> sockaddr = "unix_getsockname" external getpeername : file_descr -> sockaddr = "unix_getpeername" external unsafe_recv : file_descr -> string -> int -> int -> msg_flag list -> int = "unix_recv" external unsafe_recvfrom : file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr = "unix_recvfrom" external unsafe_send : file_descr -> string -> int -> int -> msg_flag list -> int = "unix_send" external unsafe_sendto : file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int = "unix_sendto" "unix_sendto_native" let recv fd buf ofs len flags = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.recv" else unsafe_recv fd buf ofs len flags let recvfrom fd buf ofs len flags = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.recvfrom" else unsafe_recvfrom fd buf ofs len flags let send fd buf ofs len flags = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.send" else unsafe_send fd buf ofs len flags let sendto fd buf ofs len flags addr = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.sendto" else unsafe_sendto fd buf ofs len flags addr type socket_bool_option = SO_DEBUG | SO_BROADCAST | SO_REUSEADDR | SO_KEEPALIVE | SO_DONTROUTE | SO_OOBINLINE | SO_ACCEPTCONN | TCP_NODELAY | IPV6_ONLY type socket_int_option = SO_SNDBUF | SO_RCVBUF | SO_ERROR | SO_TYPE | SO_RCVLOWAT | SO_SNDLOWAT type socket_optint_option = SO_LINGER type socket_float_option = SO_RCVTIMEO | SO_SNDTIMEO type socket_error_option = SO_ERROR module SO: sig type ('opt, 'v) t val bool: (socket_bool_option, bool) t val int: (socket_int_option, int) t val optint: (socket_optint_option, int option) t val float: (socket_float_option, float) t val error: (socket_error_option, error option) t val get: ('opt, 'v) t -> file_descr -> 'opt -> 'v val set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit end = struct type ('opt, 'v) t = int let bool = 0 let int = 1 let optint = 2 let float = 3 let error = 4 external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v = "unix_getsockopt" external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit = "unix_setsockopt" end let getsockopt fd opt = SO.get SO.bool fd opt let setsockopt fd opt v = SO.set SO.bool fd opt v let getsockopt_int fd opt = SO.get SO.int fd opt let setsockopt_int fd opt v = SO.set SO.int fd opt v let getsockopt_optint fd opt = SO.get SO.optint fd opt let setsockopt_optint fd opt v = SO.set SO.optint fd opt v let getsockopt_float fd opt = SO.get SO.float fd opt let setsockopt_float fd opt v = SO.set SO.float fd opt v let getsockopt_error fd = SO.get SO.error fd SO_ERROR type host_entry = { h_name : string; h_aliases : string array; h_addrtype : socket_domain; h_addr_list : inet_addr array } type protocol_entry = { p_name : string; p_aliases : string array; p_proto : int } type service_entry = { s_name : string; s_aliases : string array; s_port : int; s_proto : string } external gethostname : unit -> string = "unix_gethostname" external gethostbyname : string -> host_entry = "unix_gethostbyname" external gethostbyaddr : inet_addr -> host_entry = "unix_gethostbyaddr" external getprotobyname : string -> protocol_entry = "unix_getprotobyname" external getprotobynumber : int -> protocol_entry = "unix_getprotobynumber" external getservbyname : string -> string -> service_entry = "unix_getservbyname" external getservbyport : int -> string -> service_entry = "unix_getservbyport" type addr_info = { ai_family : socket_domain; ai_socktype : socket_type; ai_protocol : int; ai_addr : sockaddr; ai_canonname : string } type getaddrinfo_option = AI_FAMILY of socket_domain | AI_SOCKTYPE of socket_type | AI_PROTOCOL of int | AI_NUMERICHOST | AI_CANONNAME | AI_PASSIVE external getaddrinfo_system : string -> string -> getaddrinfo_option list -> addr_info list = "unix_getaddrinfo" let getaddrinfo_emulation node service opts = (* Parse options *) let opt_socktype = ref None and opt_protocol = ref 0 and opt_passive = ref false in List.iter (function AI_SOCKTYPE s -> opt_socktype := Some s | AI_PROTOCOL p -> opt_protocol := p | AI_PASSIVE -> opt_passive := true | _ -> ()) opts; (* Determine socket types and port numbers *) let get_port ty kind = if service = "" then [ty, 0] else try [ty, int_of_string service] with Failure _ -> try [ty, (getservbyname service kind).s_port] with Not_found -> [] in let ports = match !opt_socktype with | None -> get_port SOCK_STREAM "tcp" @ get_port SOCK_DGRAM "udp" | Some SOCK_STREAM -> get_port SOCK_STREAM "tcp" | Some SOCK_DGRAM -> get_port SOCK_DGRAM "udp" | Some ty -> if service = "" then [ty, 0] else [] in (* Determine IP addresses *) let addresses = if node = "" then if List.mem AI_PASSIVE opts then [inet_addr_any, "0.0.0.0"] else [inet_addr_loopback, "127.0.0.1"] else try [inet_addr_of_string node, node] with Failure _ -> try let he = gethostbyname node in List.map (fun a -> (a, he.h_name)) (Array.to_list he.h_addr_list) with Not_found -> [] in (* Cross-product of addresses and ports *) List.flatten (List.map (fun (ty, port) -> List.map (fun (addr, name) -> { ai_family = PF_INET; ai_socktype = ty; ai_protocol = !opt_protocol; ai_addr = ADDR_INET(addr, port); ai_canonname = name }) addresses) ports) let getaddrinfo node service opts = try List.rev(getaddrinfo_system node service opts) with Invalid_argument _ -> getaddrinfo_emulation node service opts type name_info = { ni_hostname : string; ni_service : string } type getnameinfo_option = NI_NOFQDN | NI_NUMERICHOST | NI_NAMEREQD | NI_NUMERICSERV | NI_DGRAM external getnameinfo_system : sockaddr -> getnameinfo_option list -> name_info = "unix_getnameinfo" let getnameinfo_emulation addr opts = match addr with | ADDR_UNIX f -> { ni_hostname = ""; ni_service = f } (* why not? *) | ADDR_INET(a, p) -> let hostname = try if List.mem NI_NUMERICHOST opts then raise Not_found; (gethostbyaddr a).h_name with Not_found -> if List.mem NI_NAMEREQD opts then raise Not_found; string_of_inet_addr a in let service = try if List.mem NI_NUMERICSERV opts then raise Not_found; let kind = if List.mem NI_DGRAM opts then "udp" else "tcp" in (getservbyport p kind).s_name with Not_found -> string_of_int p in { ni_hostname = hostname; ni_service = service } let getnameinfo addr opts = try getnameinfo_system addr opts with Invalid_argument _ -> getnameinfo_emulation addr opts type terminal_io = { mutable c_ignbrk: bool; mutable c_brkint: bool; mutable c_ignpar: bool; mutable c_parmrk: bool; mutable c_inpck: bool; mutable c_istrip: bool; mutable c_inlcr: bool; mutable c_igncr: bool; mutable c_icrnl: bool; mutable c_ixon: bool; mutable c_ixoff: bool; mutable c_opost: bool; mutable c_obaud: int; mutable c_ibaud: int; mutable c_csize: int; mutable c_cstopb: int; mutable c_cread: bool; mutable c_parenb: bool; mutable c_parodd: bool; mutable c_hupcl: bool; mutable c_clocal: bool; mutable c_isig: bool; mutable c_icanon: bool; mutable c_noflsh: bool; mutable c_echo: bool; mutable c_echoe: bool; mutable c_echok: bool; mutable c_echonl: bool; mutable c_vintr: char; mutable c_vquit: char; mutable c_verase: char; mutable c_vkill: char; mutable c_veof: char; mutable c_veol: char; mutable c_vmin: int; mutable c_vtime: int; mutable c_vstart: char; mutable c_vstop: char } external tcgetattr: file_descr -> terminal_io = "unix_tcgetattr" type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH external tcsetattr: file_descr -> setattr_when -> terminal_io -> unit = "unix_tcsetattr" external tcsendbreak: file_descr -> int -> unit = "unix_tcsendbreak" external tcdrain: file_descr -> unit = "unix_tcdrain" type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH external tcflush: file_descr -> flush_queue -> unit = "unix_tcflush" type flow_action = TCOOFF | TCOON | TCIOFF | TCION external tcflow: file_descr -> flow_action -> unit = "unix_tcflow" external setsid : unit -> int = "unix_setsid" (* High-level process management (system, popen) *) let system cmd = match fork() with 0 -> begin try execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] with _ -> exit 127 end | id -> snd(waitpid [] id) let rec safe_dup fd = let new_fd = dup fd in if new_fd >= 3 then new_fd else begin let res = safe_dup fd in close new_fd; res end let safe_close fd = try close fd with Unix_error(_,_,_) -> () let perform_redirections new_stdin new_stdout new_stderr = let newnewstdin = safe_dup new_stdin in let newnewstdout = safe_dup new_stdout in let newnewstderr = safe_dup new_stderr in safe_close new_stdin; safe_close new_stdout; safe_close new_stderr; dup2 newnewstdin stdin; close newnewstdin; dup2 newnewstdout stdout; close newnewstdout; dup2 newnewstderr stderr; close newnewstderr let create_process cmd args new_stdin new_stdout new_stderr = match fork() with 0 -> begin try perform_redirections new_stdin new_stdout new_stderr; execvp cmd args with _ -> exit 127 end | id -> id let create_process_env cmd args env new_stdin new_stdout new_stderr = match fork() with 0 -> begin try perform_redirections new_stdin new_stdout new_stderr; execvpe cmd args env with _ -> exit 127 end | id -> id type popen_process = Process of in_channel * out_channel | Process_in of in_channel | Process_out of out_channel | Process_full of in_channel * out_channel * in_channel let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t) let open_proc cmd proc input output toclose = let cloexec = List.for_all try_set_close_on_exec toclose in match fork() with 0 -> if input <> stdin then begin dup2 input stdin; close input end; if output <> stdout then begin dup2 output stdout; close output end; if not cloexec then List.iter close toclose; begin try execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] with _ -> exit 127 end | id -> Hashtbl.add popen_processes proc id let open_process_in cmd = let (in_read, in_write) = pipe() in let inchan = in_channel_of_descr in_read in begin try open_proc cmd (Process_in inchan) stdin in_write [in_read]; with e -> close_in inchan; close in_write; raise e end; close in_write; inchan let open_process_out cmd = let (out_read, out_write) = pipe() in let outchan = out_channel_of_descr out_write in begin try open_proc cmd (Process_out outchan) out_read stdout [out_write]; with e -> close_out outchan; close out_read; raise e end; close out_read; outchan let open_process cmd = let (in_read, in_write) = pipe() in let fds_to_close = ref [in_read;in_write] in try let (out_read, out_write) = pipe() in fds_to_close := [in_read;in_write;out_read;out_write]; let inchan = in_channel_of_descr in_read in let outchan = out_channel_of_descr out_write in open_proc cmd (Process(inchan, outchan)) out_read in_write [in_read; out_write]; close out_read; close in_write; (inchan, outchan) with e -> List.iter close !fds_to_close; raise e let open_proc_full cmd env proc input output error toclose = let cloexec = List.for_all try_set_close_on_exec toclose in match fork() with 0 -> dup2 input stdin; close input; dup2 output stdout; close output; dup2 error stderr; close error; if not cloexec then List.iter close toclose; begin try execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env with _ -> exit 127 end | id -> Hashtbl.add popen_processes proc id let open_process_full cmd env = let (in_read, in_write) = pipe() in let fds_to_close = ref [in_read;in_write] in try let (out_read, out_write) = pipe() in fds_to_close := out_read::out_write:: !fds_to_close; let (err_read, err_write) = pipe() in fds_to_close := err_read::err_write:: !fds_to_close; let inchan = in_channel_of_descr in_read in let outchan = out_channel_of_descr out_write in let errchan = in_channel_of_descr err_read in open_proc_full cmd env (Process_full(inchan, outchan, errchan)) out_read in_write err_write [in_read; out_write; err_read]; close out_read; close in_write; close err_write; (inchan, outchan, errchan) with e -> List.iter close !fds_to_close; raise e let find_proc_id fun_name proc = try let pid = Hashtbl.find popen_processes proc in Hashtbl.remove popen_processes proc; pid with Not_found -> raise(Unix_error(EBADF, fun_name, "")) let rec waitpid_non_intr pid = try waitpid [] pid with Unix_error (EINTR, _, _) -> waitpid_non_intr pid let close_process_in inchan = let pid = find_proc_id "close_process_in" (Process_in inchan) in close_in inchan; snd(waitpid_non_intr pid) let close_process_out outchan = let pid = find_proc_id "close_process_out" (Process_out outchan) in close_out outchan; snd(waitpid_non_intr pid) let close_process (inchan, outchan) = let pid = find_proc_id "close_process" (Process(inchan, outchan)) in close_in inchan; begin try close_out outchan with Sys_error _ -> () end; snd(waitpid_non_intr pid) let close_process_full (inchan, outchan, errchan) = let pid = find_proc_id "close_process_full" (Process_full(inchan, outchan, errchan)) in close_in inchan; begin try close_out outchan with Sys_error _ -> () end; close_in errchan; snd(waitpid_non_intr pid) (* High-level network functions *) let open_connection sockaddr = let sock = socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in try connect sock sockaddr; ignore(try_set_close_on_exec sock); (in_channel_of_descr sock, out_channel_of_descr sock) with exn -> close sock; raise exn let shutdown_connection inchan = shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND let rec accept_non_intr s = try accept s with Unix_error (EINTR, _, _) -> accept_non_intr s let establish_server server_fun sockaddr = let sock = socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in setsockopt sock SO_REUSEADDR true; bind sock sockaddr; listen sock 5; while true do let (s, caller) = accept_non_intr sock in (* The "double fork" trick, the process which calls server_fun will not leave a zombie process *) match fork() with 0 -> if fork() <> 0 then exit 0; (* The son exits, the grandson works *) close sock; ignore(try_set_close_on_exec s); let inchan = in_channel_of_descr s in let outchan = out_channel_of_descr s in server_fun inchan outchan; (* Do not close inchan nor outchan, as the server_fun could have done it already, and we are about to exit anyway (PR#3794) *) exit 0 | id -> close s; ignore(waitpid_non_intr id) (* Reclaim the son *) done mingw-ocaml/ocaml/otherlibs/unix/access.c0000644000175000017500000000351612124403241020046 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #ifdef HAS_UNISTD # include #else # ifndef _WIN32 # include # ifndef R_OK # define R_OK 4/* test for read permission */ # define W_OK 2/* test for write permission */ # define X_OK 1/* test for execute (search) permission */ # define F_OK 0/* test for presence of file */ # endif # else # define R_OK 4/* test for read permission */ # define W_OK 2/* test for write permission */ # define X_OK 4/* test for execute permission - not implemented in Win32 */ # define F_OK 0/* test for presence of file */ # endif #endif static int access_permission_table[] = { R_OK, W_OK, X_OK, F_OK }; CAMLprim value unix_access(value path, value perms) { int ret, cv_flags; cv_flags = convert_flag_list(perms, access_permission_table); ret = access(String_val(path), cv_flags); if (ret == -1) uerror("access", path); return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/fchown.c0000644000175000017500000000240312124403241020063 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #ifdef HAS_FCHMOD CAMLprim value unix_fchown(value fd, value uid, value gid) { if (fchown(Int_val(fd), Int_val(uid), Int_val(gid)) == -1) uerror("fchown", Nothing); return Val_unit; } #else CAMLprim value unix_fchown(value fd, value uid, value gid) { invalid_argument("fchown not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/cstringv.c0000644000175000017500000000231012124403241020433 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" char ** cstringvect(value arg) { char ** res; mlsize_t size, i; size = Wosize_val(arg); res = (char **) stat_alloc((size + 1) * sizeof(char *)); for (i = 0; i < size; i++) res[i] = String_val(Field(arg, i)); res[size] = NULL; return res; } mingw-ocaml/ocaml/otherlibs/unix/getserv.c0000644000175000017500000000456412124403241020270 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include #ifndef _WIN32 #include #include #include #else #include #endif static value alloc_service_entry(struct servent *entry) { value res; value name = Val_unit, aliases = Val_unit, proto = Val_unit; Begin_roots3 (name, aliases, proto); name = copy_string(entry->s_name); aliases = copy_string_array((const char**)entry->s_aliases); proto = copy_string(entry->s_proto); res = alloc_small(4, 0); Field(res,0) = name; Field(res,1) = aliases; Field(res,2) = Val_int(ntohs(entry->s_port)); Field(res,3) = proto; End_roots(); return res; } CAMLprim value unix_getservbyname(value name, value proto) { struct servent * entry; entry = getservbyname(String_val(name), String_val(proto)); if (entry == (struct servent *) NULL) raise_not_found(); return alloc_service_entry(entry); } CAMLprim value unix_getservbyport(value port, value proto) { struct servent * entry; entry = getservbyport(htons(Int_val(port)), String_val(proto)); if (entry == (struct servent *) NULL) raise_not_found(); return alloc_service_entry(entry); } #else CAMLprim value unix_getservbyport(value port, value proto) { invalid_argument("getservbyport not implemented"); } CAMLprim value unix_getservbyname(value name, value proto) { invalid_argument("getservbyname not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/opendir.c0000644000175000017500000000240612124403241020242 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #include #ifdef HAS_DIRENT #include #else #include #endif CAMLprim value unix_opendir(value path) { DIR * d; value res; d = opendir(String_val(path)); if (d == (DIR *) NULL) uerror("opendir", path); res = alloc_small(1, Abstract_tag); DIR_Val(res) = d; return res; } mingw-ocaml/ocaml/otherlibs/unix/unixsupport.c0000644000175000017500000001420512124403241021222 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include "unixsupport.h" #include "cst2constr.h" #include #ifndef E2BIG #define E2BIG (-1) #endif #ifndef EACCES #define EACCES (-1) #endif #ifndef EAGAIN #define EAGAIN (-1) #endif #ifndef EBADF #define EBADF (-1) #endif #ifndef EBUSY #define EBUSY (-1) #endif #ifndef ECHILD #define ECHILD (-1) #endif #ifndef EDEADLK #define EDEADLK (-1) #endif #ifndef EDOM #define EDOM (-1) #endif #ifndef EEXIST #define EEXIST (-1) #endif #ifndef EFAULT #define EFAULT (-1) #endif #ifndef EFBIG #define EFBIG (-1) #endif #ifndef EINTR #define EINTR (-1) #endif #ifndef EINVAL #define EINVAL (-1) #endif #ifndef EIO #define EIO (-1) #endif #ifndef EISDIR #define EISDIR (-1) #endif #ifndef EMFILE #define EMFILE (-1) #endif #ifndef EMLINK #define EMLINK (-1) #endif #ifndef ENAMETOOLONG #define ENAMETOOLONG (-1) #endif #ifndef ENFILE #define ENFILE (-1) #endif #ifndef ENODEV #define ENODEV (-1) #endif #ifndef ENOENT #define ENOENT (-1) #endif #ifndef ENOEXEC #define ENOEXEC (-1) #endif #ifndef ENOLCK #define ENOLCK (-1) #endif #ifndef ENOMEM #define ENOMEM (-1) #endif #ifndef ENOSPC #define ENOSPC (-1) #endif #ifndef ENOSYS #define ENOSYS (-1) #endif #ifndef ENOTDIR #define ENOTDIR (-1) #endif #ifndef ENOTEMPTY #define ENOTEMPTY (-1) #endif #ifndef ENOTTY #define ENOTTY (-1) #endif #ifndef ENXIO #define ENXIO (-1) #endif #ifndef EPERM #define EPERM (-1) #endif #ifndef EPIPE #define EPIPE (-1) #endif #ifndef ERANGE #define ERANGE (-1) #endif #ifndef EROFS #define EROFS (-1) #endif #ifndef ESPIPE #define ESPIPE (-1) #endif #ifndef ESRCH #define ESRCH (-1) #endif #ifndef EXDEV #define EXDEV (-1) #endif #ifndef EWOULDBLOCK #define EWOULDBLOCK (-1) #endif #ifndef EINPROGRESS #define EINPROGRESS (-1) #endif #ifndef EALREADY #define EALREADY (-1) #endif #ifndef ENOTSOCK #define ENOTSOCK (-1) #endif #ifndef EDESTADDRREQ #define EDESTADDRREQ (-1) #endif #ifndef EMSGSIZE #define EMSGSIZE (-1) #endif #ifndef EPROTOTYPE #define EPROTOTYPE (-1) #endif #ifndef ENOPROTOOPT #define ENOPROTOOPT (-1) #endif #ifndef EPROTONOSUPPORT #define EPROTONOSUPPORT (-1) #endif #ifndef ESOCKTNOSUPPORT #define ESOCKTNOSUPPORT (-1) #endif #ifndef EOPNOTSUPP # ifdef ENOTSUP # define EOPNOTSUPP ENOTSUP # else # define EOPNOTSUPP (-1) # endif #endif #ifndef EPFNOSUPPORT #define EPFNOSUPPORT (-1) #endif #ifndef EAFNOSUPPORT #define EAFNOSUPPORT (-1) #endif #ifndef EADDRINUSE #define EADDRINUSE (-1) #endif #ifndef EADDRNOTAVAIL #define EADDRNOTAVAIL (-1) #endif #ifndef ENETDOWN #define ENETDOWN (-1) #endif #ifndef ENETUNREACH #define ENETUNREACH (-1) #endif #ifndef ENETRESET #define ENETRESET (-1) #endif #ifndef ECONNABORTED #define ECONNABORTED (-1) #endif #ifndef ECONNRESET #define ECONNRESET (-1) #endif #ifndef ENOBUFS #define ENOBUFS (-1) #endif #ifndef EISCONN #define EISCONN (-1) #endif #ifndef ENOTCONN #define ENOTCONN (-1) #endif #ifndef ESHUTDOWN #define ESHUTDOWN (-1) #endif #ifndef ETOOMANYREFS #define ETOOMANYREFS (-1) #endif #ifndef ETIMEDOUT #define ETIMEDOUT (-1) #endif #ifndef ECONNREFUSED #define ECONNREFUSED (-1) #endif #ifndef EHOSTDOWN #define EHOSTDOWN (-1) #endif #ifndef EHOSTUNREACH #define EHOSTUNREACH (-1) #endif #ifndef ENOTEMPTY #define ENOTEMPTY (-1) #endif #ifndef ELOOP #define ELOOP (-1) #endif #ifndef EOVERFLOW #define EOVERFLOW (-1) #endif int error_table[] = { E2BIG, EACCES, EAGAIN, EBADF, EBUSY, ECHILD, EDEADLK, EDOM, EEXIST, EFAULT, EFBIG, EINTR, EINVAL, EIO, EISDIR, EMFILE, EMLINK, ENAMETOOLONG, ENFILE, ENODEV, ENOENT, ENOEXEC, ENOLCK, ENOMEM, ENOSPC, ENOSYS, ENOTDIR, ENOTEMPTY, ENOTTY, ENXIO, EPERM, EPIPE, ERANGE, EROFS, ESPIPE, ESRCH, EXDEV, EWOULDBLOCK, EINPROGRESS, EALREADY, ENOTSOCK, EDESTADDRREQ, EMSGSIZE, EPROTOTYPE, ENOPROTOOPT, EPROTONOSUPPORT, ESOCKTNOSUPPORT, EOPNOTSUPP, EPFNOSUPPORT, EAFNOSUPPORT, EADDRINUSE, EADDRNOTAVAIL, ENETDOWN, ENETUNREACH, ENETRESET, ECONNABORTED, ECONNRESET, ENOBUFS, EISCONN, ENOTCONN, ESHUTDOWN, ETOOMANYREFS, ETIMEDOUT, ECONNREFUSED, EHOSTDOWN, EHOSTUNREACH, ELOOP, EOVERFLOW /*, EUNKNOWNERR */ }; static value * unix_error_exn = NULL; value unix_error_of_code (int errcode) { int errconstr; value err; #if defined(ENOTSUP) && (EOPNOTSUPP != ENOTSUP) if (errcode == ENOTSUP) errcode = EOPNOTSUPP; #endif errconstr = cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1); if (errconstr == Val_int(-1)) { err = alloc_small(1, 0); Field(err, 0) = Val_int(errcode); } else { err = errconstr; } return err; } void unix_error(int errcode, char *cmdname, value cmdarg) { value res; value name = Val_unit, err = Val_unit, arg = Val_unit; Begin_roots3 (name, err, arg); arg = cmdarg == Nothing ? copy_string("") : cmdarg; name = copy_string(cmdname); err = unix_error_of_code (errcode); if (unix_error_exn == NULL) { unix_error_exn = caml_named_value("Unix.Unix_error"); if (unix_error_exn == NULL) invalid_argument("Exception Unix.Unix_error not initialized, please link unix.cma"); } res = alloc_small(4, 0); Field(res, 0) = *unix_error_exn; Field(res, 1) = err; Field(res, 2) = name; Field(res, 3) = arg; End_roots(); mlraise(res); } void uerror(char *cmdname, value cmdarg) { unix_error(errno, cmdname, cmdarg); } mingw-ocaml/ocaml/otherlibs/unix/socketaddr.c0000644000175000017500000001015512124403241020725 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include "socketaddr.h" #ifdef _WIN32 #define EAFNOSUPPORT WSAEAFNOSUPPORT #endif CAMLexport value alloc_inet_addr(struct in_addr * a) { value res; /* Use a string rather than an abstract block so that it can be marshaled safely. Remember that a is in network byte order, hence is marshaled in an endian-independent manner. */ res = alloc_string(4); memcpy(String_val(res), a, 4); return res; } #ifdef HAS_IPV6 CAMLexport value alloc_inet6_addr(struct in6_addr * a) { value res; res = alloc_string(16); memcpy(String_val(res), a, 16); return res; } #endif void get_sockaddr(value mladr, union sock_addr_union * adr /*out*/, socklen_param_type * adr_len /*out*/) { switch(Tag_val(mladr)) { #ifndef _WIN32 case 0: /* ADDR_UNIX */ { value path; mlsize_t len; path = Field(mladr, 0); len = string_length(path); adr->s_unix.sun_family = AF_UNIX; if (len >= sizeof(adr->s_unix.sun_path)) { unix_error(ENAMETOOLONG, "", path); } memmove (adr->s_unix.sun_path, String_val(path), len + 1); *adr_len = ((char *)&(adr->s_unix.sun_path) - (char *)&(adr->s_unix)) + len; break; } #endif case 1: /* ADDR_INET */ #ifdef HAS_IPV6 if (string_length(Field(mladr, 0)) == 16) { memset(&adr->s_inet6, 0, sizeof(struct sockaddr_in6)); adr->s_inet6.sin6_family = AF_INET6; adr->s_inet6.sin6_addr = GET_INET6_ADDR(Field(mladr, 0)); adr->s_inet6.sin6_port = htons(Int_val(Field(mladr, 1))); #ifdef SIN6_LEN adr->s_inet6.sin6_len = sizeof(struct sockaddr_in6); #endif *adr_len = sizeof(struct sockaddr_in6); break; } #endif memset(&adr->s_inet, 0, sizeof(struct sockaddr_in)); adr->s_inet.sin_family = AF_INET; adr->s_inet.sin_addr = GET_INET_ADDR(Field(mladr, 0)); adr->s_inet.sin_port = htons(Int_val(Field(mladr, 1))); #ifdef SIN6_LEN adr->s_inet.sin_len = sizeof(struct sockaddr_in); #endif *adr_len = sizeof(struct sockaddr_in); break; } } value alloc_sockaddr(union sock_addr_union * adr /*in*/, socklen_param_type adr_len, int close_on_error) { value res; switch(adr->s_gen.sa_family) { #ifndef _WIN32 case AF_UNIX: { value n = copy_string(adr->s_unix.sun_path); Begin_root (n); res = alloc_small(1, 0); Field(res,0) = n; End_roots(); break; } #endif case AF_INET: { value a = alloc_inet_addr(&adr->s_inet.sin_addr); Begin_root (a); res = alloc_small(2, 1); Field(res,0) = a; Field(res,1) = Val_int(ntohs(adr->s_inet.sin_port)); End_roots(); break; } #ifdef HAS_IPV6 case AF_INET6: { value a = alloc_inet6_addr(&adr->s_inet6.sin6_addr); Begin_root (a); res = alloc_small(2, 1); Field(res,0) = a; Field(res,1) = Val_int(ntohs(adr->s_inet6.sin6_port)); End_roots(); break; } #endif default: if (close_on_error != -1) close (close_on_error); unix_error(EAFNOSUPPORT, "", Nothing); } return res; } #endif mingw-ocaml/ocaml/otherlibs/unix/sockopt.c0000644000175000017500000001615012124403241020265 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include #include #include #include #include #include "socketaddr.h" #ifndef SO_DEBUG #define SO_DEBUG (-1) #endif #ifndef SO_BROADCAST #define SO_BROADCAST (-1) #endif #ifndef SO_REUSEADDR #define SO_REUSEADDR (-1) #endif #ifndef SO_KEEPALIVE #define SO_KEEPALIVE (-1) #endif #ifndef SO_DONTROUTE #define SO_DONTROUTE (-1) #endif #ifndef SO_OOBINLINE #define SO_OOBINLINE (-1) #endif #ifndef SO_ACCEPTCONN #define SO_ACCEPTCONN (-1) #endif #ifndef SO_SNDBUF #define SO_SNDBUF (-1) #endif #ifndef SO_RCVBUF #define SO_RCVBUF (-1) #endif #ifndef SO_ERROR #define SO_ERROR (-1) #endif #ifndef SO_TYPE #define SO_TYPE (-1) #endif #ifndef SO_RCVLOWAT #define SO_RCVLOWAT (-1) #endif #ifndef SO_SNDLOWAT #define SO_SNDLOWAT (-1) #endif #ifndef SO_LINGER #define SO_LINGER (-1) #endif #ifndef SO_RCVTIMEO #define SO_RCVTIMEO (-1) #endif #ifndef SO_SNDTIMEO #define SO_SNDTIMEO (-1) #endif #ifndef TCP_NODELAY #define TCP_NODELAY (-1) #endif #ifndef SO_ERROR #define SO_ERROR (-1) #endif #ifndef IPPROTO_IPV6 #define IPPROTO_IPV6 (-1) #endif #ifndef IPV6_V6ONLY #define IPV6_V6ONLY (-1) #endif enum option_type { TYPE_BOOL = 0, TYPE_INT = 1, TYPE_LINGER = 2, TYPE_TIMEVAL = 3, TYPE_UNIX_ERROR = 4 }; struct socket_option { int level; int option; }; /* Table of options, indexed by type */ static struct socket_option sockopt_bool[] = { { SOL_SOCKET, SO_DEBUG }, { SOL_SOCKET, SO_BROADCAST }, { SOL_SOCKET, SO_REUSEADDR }, { SOL_SOCKET, SO_KEEPALIVE }, { SOL_SOCKET, SO_DONTROUTE }, { SOL_SOCKET, SO_OOBINLINE }, { SOL_SOCKET, SO_ACCEPTCONN }, { IPPROTO_TCP, TCP_NODELAY }, { IPPROTO_IPV6, IPV6_V6ONLY} }; static struct socket_option sockopt_int[] = { { SOL_SOCKET, SO_SNDBUF }, { SOL_SOCKET, SO_RCVBUF }, { SOL_SOCKET, SO_ERROR }, { SOL_SOCKET, SO_TYPE }, { SOL_SOCKET, SO_RCVLOWAT }, { SOL_SOCKET, SO_SNDLOWAT } }; static struct socket_option sockopt_linger[] = { { SOL_SOCKET, SO_LINGER } }; static struct socket_option sockopt_timeval[] = { { SOL_SOCKET, SO_RCVTIMEO }, { SOL_SOCKET, SO_SNDTIMEO } }; static struct socket_option sockopt_unix_error[] = { { SOL_SOCKET, SO_ERROR } }; static struct socket_option * sockopt_table[] = { sockopt_bool, sockopt_int, sockopt_linger, sockopt_timeval, sockopt_unix_error }; static char * getsockopt_fun_name[] = { "getsockopt", "getsockopt_int", "getsockopt_optint", "getsockopt_float", "getsockopt_error" }; static char * setsockopt_fun_name[] = { "setsockopt", "setsockopt_int", "setsockopt_optint", "setsockopt_float", "setsockopt_error" }; union option_value { int i; struct linger lg; struct timeval tv; }; CAMLexport value unix_getsockopt_aux(char * name, enum option_type ty, int level, int option, value socket) { union option_value optval; socklen_param_type optsize; switch (ty) { case TYPE_BOOL: case TYPE_INT: case TYPE_UNIX_ERROR: optsize = sizeof(optval.i); break; case TYPE_LINGER: optsize = sizeof(optval.lg); break; case TYPE_TIMEVAL: optsize = sizeof(optval.tv); break; default: unix_error(EINVAL, name, Nothing); } if (getsockopt(Int_val(socket), level, option, (void *) &optval, &optsize) == -1) uerror(name, Nothing); switch (ty) { case TYPE_BOOL: case TYPE_INT: return Val_int(optval.i); case TYPE_LINGER: if (optval.lg.l_onoff == 0) { return Val_int(0); /* None */ } else { value res = alloc_small(1, 0); /* Some */ Field(res, 0) = Val_int(optval.lg.l_linger); return res; } case TYPE_TIMEVAL: return copy_double((double) optval.tv.tv_sec + (double) optval.tv.tv_usec / 1e6); case TYPE_UNIX_ERROR: if (optval.i == 0) { return Val_int(0); /* None */ } else { value err, res; err = unix_error_of_code(optval.i); Begin_root(err); res = alloc_small(1, 0); /* Some */ Field(res, 0) = err; End_roots(); return res; } default: unix_error(EINVAL, name, Nothing); } } CAMLexport value unix_setsockopt_aux(char * name, enum option_type ty, int level, int option, value socket, value val) { union option_value optval; socklen_param_type optsize; double f; switch (ty) { case TYPE_BOOL: case TYPE_INT: optsize = sizeof(optval.i); optval.i = Int_val(val); break; case TYPE_LINGER: optsize = sizeof(optval.lg); optval.lg.l_onoff = Is_block (val); if (optval.lg.l_onoff) optval.lg.l_linger = Int_val (Field (val, 0)); break; case TYPE_TIMEVAL: f = Double_val(val); optsize = sizeof(optval.tv); optval.tv.tv_sec = (int) f; optval.tv.tv_usec = (int) (1e6 * (f - optval.tv.tv_sec)); break; case TYPE_UNIX_ERROR: default: unix_error(EINVAL, name, Nothing); } if (setsockopt(Int_val(socket), level, option, (void *) &optval, optsize) == -1) uerror(name, Nothing); return Val_unit; } CAMLprim value unix_getsockopt(value vty, value vsocket, value voption) { enum option_type ty = Int_val(vty); struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]); return unix_getsockopt_aux(getsockopt_fun_name[ty], ty, opt->level, opt->option, vsocket); } CAMLprim value unix_setsockopt(value vty, value vsocket, value voption, value val) { enum option_type ty = Int_val(vty); struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]); return unix_setsockopt_aux(setsockopt_fun_name[ty], ty, opt->level, opt->option, vsocket, val); } #else CAMLprim value unix_getsockopt(value vty, value socket, value option) { invalid_argument("getsockopt not implemented"); } CAMLprim value unix_setsockopt(value vty, value socket, value option, value val) { invalid_argument("setsockopt not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/addrofstr.c0000644000175000017500000000351712124403241020576 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include "socketaddr.h" CAMLprim value unix_inet_addr_of_string(value s) { #if defined(HAS_IPV6) struct in_addr address; struct in6_addr address6; if (inet_pton(AF_INET, String_val(s), &address) > 0) return alloc_inet_addr(&address); else if (inet_pton(AF_INET6, String_val(s), &address6) > 0) return alloc_inet6_addr(&address6); else failwith("inet_addr_of_string"); #elif defined(HAS_INET_ATON) struct in_addr address; if (inet_aton(String_val(s), &address) == 0) failwith("inet_addr_of_string"); return alloc_inet_addr(&address); #else struct in_addr address; address.s_addr = inet_addr(String_val(s)); if (address.s_addr == (uint32) -1) failwith("inet_addr_of_string"); return alloc_inet_addr(&address); #endif } #else CAMLprim value unix_inet_addr_of_string(value s) { invalid_argument("inet_addr_of_string not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/connect.c0000644000175000017500000000276112124403241020237 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include "socketaddr.h" CAMLprim value unix_connect(value socket, value address) { int retcode; union sock_addr_union addr; socklen_param_type addr_len; get_sockaddr(address, &addr, &addr_len); enter_blocking_section(); retcode = connect(Int_val(socket), &addr.s_gen, addr_len); leave_blocking_section(); if (retcode == -1) uerror("connect", Nothing); return Val_unit; } #else CAMLprim value unix_connect(value socket, value address) { invalid_argument("connect not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/socket.c0000644000175000017500000000323712124403241020075 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include #include int socket_domain_table[] = { PF_UNIX, PF_INET, #if defined(HAS_IPV6) PF_INET6 #elif defined(PF_UNDEF) PF_UNDEF #else 0 #endif }; int socket_type_table[] = { SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET }; CAMLprim value unix_socket(value domain, value type, value proto) { int retcode; retcode = socket(socket_domain_table[Int_val(domain)], socket_type_table[Int_val(type)], Int_val(proto)); if (retcode == -1) uerror("socket", Nothing); return Val_int(retcode); } #else CAMLprim value unix_socket(value domain, value type, value proto) { invalid_argument("socket not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/strofaddr.c0000644000175000017500000000321012124403241020564 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include "socketaddr.h" CAMLprim value unix_string_of_inet_addr(value a) { char * res; #ifdef HAS_IPV6 char buffer[64]; if (string_length(a) == 16) res = (char *) inet_ntop(AF_INET6, (const void *) &GET_INET6_ADDR(a), buffer, sizeof(buffer)); else res = (char *) inet_ntop(AF_INET, (const void *) &GET_INET_ADDR(a), buffer, sizeof(buffer)); #else res = inet_ntoa(GET_INET_ADDR(a)); #endif if (res == NULL) uerror("string_of_inet_addr", Nothing); return copy_string(res); } #else CAMLprim value unix_string_of_inet_addr(value a) { invalid_argument("string_of_inet_addr not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/alarm.c0000644000175000017500000000202112124403241017667 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_alarm(value t) { return Val_int(alarm((unsigned int) Long_val(t))); } mingw-ocaml/ocaml/otherlibs/unix/unix.mllib0000644000175000017500000000002012124403241020430 0ustar tootstootsUnix UnixLabels mingw-ocaml/ocaml/otherlibs/unix/putenv.c0000644000175000017500000000311212124403241020116 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1998 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include "unixsupport.h" #ifdef HAS_PUTENV CAMLprim value unix_putenv(value name, value val) { mlsize_t namelen = string_length(name); mlsize_t vallen = string_length(val); char * s = (char *) caml_stat_alloc(namelen + 1 + vallen + 1); memmove (s, String_val(name), namelen); s[namelen] = '='; memmove (s + namelen + 1, String_val(val), vallen); s[namelen + 1 + vallen] = 0; if (putenv(s) == -1) { caml_stat_free(s); uerror("putenv", name); } return Val_unit; } #else CAMLprim value unix_putenv(value name, value val) { invalid_argument("putenv not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/closedir.c0000644000175000017500000000235412124403241020410 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" #include #include #ifdef HAS_DIRENT #include #else #include #endif CAMLprim value unix_closedir(value vd) { DIR * d = DIR_Val(vd); if (d == (DIR *) NULL) unix_error(EBADF, "closedir", Nothing); closedir(d); DIR_Val(vd) = (DIR *) NULL; return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/getlogin.c0000644000175000017500000000224412124403241020412 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #include extern char * getlogin(void); CAMLprim value unix_getlogin(value unit) { char * name; name = getlogin(); if (name == NULL) unix_error(ENOENT, "getlogin", Nothing); return copy_string(name); } mingw-ocaml/ocaml/otherlibs/unix/getgr.c0000644000175000017500000000353012124403241017711 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #include #include static value alloc_group_entry(struct group *entry) { value res; value name = Val_unit, pass = Val_unit, mem = Val_unit; Begin_roots3 (name, pass, mem); name = copy_string(entry->gr_name); pass = copy_string(entry->gr_passwd); mem = copy_string_array((const char**)entry->gr_mem); res = alloc_small(4, 0); Field(res,0) = name; Field(res,1) = pass; Field(res,2) = Val_int(entry->gr_gid); Field(res,3) = mem; End_roots(); return res; } CAMLprim value unix_getgrnam(value name) { struct group * entry; entry = getgrnam(String_val(name)); if (entry == NULL) raise_not_found(); return alloc_group_entry(entry); } CAMLprim value unix_getgrgid(value gid) { struct group * entry; entry = getgrgid(Int_val(gid)); if (entry == NULL) raise_not_found(); return alloc_group_entry(entry); } mingw-ocaml/ocaml/otherlibs/unix/getgid.c0000644000175000017500000000177412124403241020054 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_getgid(value unit) { return Val_int(getgid()); } mingw-ocaml/ocaml/otherlibs/unix/listen.c0000644000175000017500000000240712124403241020101 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include CAMLprim value unix_listen(value sock, value backlog) { if (listen(Int_val(sock), Int_val(backlog)) == -1) uerror("listen", Nothing); return Val_unit; } #else CAMLprim value unix_listen(value sock, value backlog) { invalid_argument("listen not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/getppid.c0000644000175000017500000000177612124403241020247 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_getppid(value unit) { return Val_int(getppid()); } mingw-ocaml/ocaml/otherlibs/unix/link.c0000644000175000017500000000211612124403241017535 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_link(value path1, value path2) { if (link(String_val(path1), String_val(path2)) == -1) uerror("link", path2); return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/times.c0000644000175000017500000000420312124403241017720 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" #include #include #include #ifdef HAS_GETRUSAGE #include #include #endif #ifndef CLK_TCK #ifdef HZ #define CLK_TCK HZ #else #define CLK_TCK 60 #endif #endif CAMLprim value unix_times(value unit) { #ifdef HAS_GETRUSAGE value res; struct rusage ru; res = alloc_small(4 * Double_wosize, Double_array_tag); getrusage (RUSAGE_SELF, &ru); Store_double_field (res, 0, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6); Store_double_field (res, 1, ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6); getrusage (RUSAGE_CHILDREN, &ru); Store_double_field (res, 2, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6); Store_double_field (res, 3, ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6); return res; #else value res; struct tms buffer; times(&buffer); res = alloc_small(4 * Double_wosize, Double_array_tag); Store_double_field(res, 0, (double) buffer.tms_utime / CLK_TCK); Store_double_field(res, 1, (double) buffer.tms_stime / CLK_TCK); Store_double_field(res, 2, (double) buffer.tms_cutime / CLK_TCK); Store_double_field(res, 3, (double) buffer.tms_cstime / CLK_TCK); return res; #endif } mingw-ocaml/ocaml/otherlibs/unix/getuid.c0000644000175000017500000000177412124403241020072 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_getuid(value unit) { return Val_int(getuid()); } mingw-ocaml/ocaml/otherlibs/unix/getaddrinfo.c0000644000175000017500000001023412124403241021066 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2004 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include #include "unixsupport.h" #include "cst2constr.h" #if defined(HAS_SOCKETS) && defined(HAS_IPV6) #include "socketaddr.h" #ifndef _WIN32 #include #include #endif extern int socket_domain_table[]; /* from socket.c */ extern int socket_type_table[]; /* from socket.c */ static value convert_addrinfo(struct addrinfo * a) { CAMLparam0(); CAMLlocal3(vres,vaddr,vcanonname); union sock_addr_union sa; socklen_param_type len; len = a->ai_addrlen; if (len > sizeof(sa)) len = sizeof(sa); memcpy(&sa.s_gen, a->ai_addr, len); vaddr = alloc_sockaddr(&sa, len, -1); vcanonname = copy_string(a->ai_canonname == NULL ? "" : a->ai_canonname); vres = alloc_small(5, 0); Field(vres, 0) = cst_to_constr(a->ai_family, socket_domain_table, 3, 0); Field(vres, 1) = cst_to_constr(a->ai_socktype, socket_type_table, 4, 0); Field(vres, 2) = Val_int(a->ai_protocol); Field(vres, 3) = vaddr; Field(vres, 4) = vcanonname; CAMLreturn(vres); } CAMLprim value unix_getaddrinfo(value vnode, value vserv, value vopts) { CAMLparam3(vnode, vserv, vopts); CAMLlocal3(vres, v, e); mlsize_t len; char * node, * serv; struct addrinfo hints; struct addrinfo * res, * r; int retcode; /* Extract "node" parameter */ len = string_length(vnode); if (len == 0) { node = NULL; } else { node = stat_alloc(len + 1); strcpy(node, String_val(vnode)); } /* Extract "service" parameter */ len = string_length(vserv); if (len == 0) { serv = NULL; } else { serv = stat_alloc(len + 1); strcpy(serv, String_val(vserv)); } /* Parse options, set hints */ memset(&hints, 0, sizeof(hints)); hints.ai_family = PF_UNSPEC; for (/*nothing*/; Is_block(vopts); vopts = Field(vopts, 1)) { v = Field(vopts, 0); if (Is_block(v)) switch (Tag_val(v)) { case 0: /* AI_FAMILY of socket_domain */ hints.ai_family = socket_domain_table[Int_val(Field(v, 0))]; break; case 1: /* AI_SOCKTYPE of socket_type */ hints.ai_socktype = socket_type_table[Int_val(Field(v, 0))]; break; case 2: /* AI_PROTOCOL of int */ hints.ai_protocol = Int_val(Field(v, 0)); break; } else switch (Int_val(v)) { case 0: /* AI_NUMERICHOST */ hints.ai_flags |= AI_NUMERICHOST; break; case 1: /* AI_CANONNAME */ hints.ai_flags |= AI_CANONNAME; break; case 2: /* AI_PASSIVE */ hints.ai_flags |= AI_PASSIVE; break; } } /* Do the call */ enter_blocking_section(); retcode = getaddrinfo(node, serv, &hints, &res); leave_blocking_section(); if (node != NULL) stat_free(node); if (serv != NULL) stat_free(serv); /* Convert result */ vres = Val_int(0); if (retcode == 0) { for (r = res; r != NULL; r = r->ai_next) { e = convert_addrinfo(r); v = alloc_small(2, 0); Field(v, 0) = e; Field(v, 1) = vres; vres = v; } freeaddrinfo(res); } CAMLreturn(vres); } #else CAMLprim value unix_getaddrinfo(value vnode, value vserv, value vopts) { invalid_argument("getaddrinfo not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/unixLabels.mli0000644000175000017500000015223712124403241021257 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Interface to the Unix system. To use as replacement to default {!Unix} module, add [module Unix = UnixLabels] in your implementation. *) (** {6 Error report} *) type error = Unix.error = E2BIG (** Argument list too long *) | EACCES (** Permission denied *) | EAGAIN (** Resource temporarily unavailable; try again *) | EBADF (** Bad file descriptor *) | EBUSY (** Resource unavailable *) | ECHILD (** No child process *) | EDEADLK (** Resource deadlock would occur *) | EDOM (** Domain error for math functions, etc. *) | EEXIST (** File exists *) | EFAULT (** Bad address *) | EFBIG (** File too large *) | EINTR (** Function interrupted by signal *) | EINVAL (** Invalid argument *) | EIO (** Hardware I/O error *) | EISDIR (** Is a directory *) | EMFILE (** Too many open files by the process *) | EMLINK (** Too many links *) | ENAMETOOLONG (** Filename too long *) | ENFILE (** Too many open files in the system *) | ENODEV (** No such device *) | ENOENT (** No such file or directory *) | ENOEXEC (** Not an executable file *) | ENOLCK (** No locks available *) | ENOMEM (** Not enough memory *) | ENOSPC (** No space left on device *) | ENOSYS (** Function not supported *) | ENOTDIR (** Not a directory *) | ENOTEMPTY (** Directory not empty *) | ENOTTY (** Inappropriate I/O control operation *) | ENXIO (** No such device or address *) | EPERM (** Operation not permitted *) | EPIPE (** Broken pipe *) | ERANGE (** Result too large *) | EROFS (** Read-only file system *) | ESPIPE (** Invalid seek e.g. on a pipe *) | ESRCH (** No such process *) | EXDEV (** Invalid link *) | EWOULDBLOCK (** Operation would block *) | EINPROGRESS (** Operation now in progress *) | EALREADY (** Operation already in progress *) | ENOTSOCK (** Socket operation on non-socket *) | EDESTADDRREQ (** Destination address required *) | EMSGSIZE (** Message too long *) | EPROTOTYPE (** Protocol wrong type for socket *) | ENOPROTOOPT (** Protocol not available *) | EPROTONOSUPPORT (** Protocol not supported *) | ESOCKTNOSUPPORT (** Socket type not supported *) | EOPNOTSUPP (** Operation not supported on socket *) | EPFNOSUPPORT (** Protocol family not supported *) | EAFNOSUPPORT (** Address family not supported by protocol family *) | EADDRINUSE (** Address already in use *) | EADDRNOTAVAIL (** Can't assign requested address *) | ENETDOWN (** Network is down *) | ENETUNREACH (** Network is unreachable *) | ENETRESET (** Network dropped connection on reset *) | ECONNABORTED (** Software caused connection abort *) | ECONNRESET (** Connection reset by peer *) | ENOBUFS (** No buffer space available *) | EISCONN (** Socket is already connected *) | ENOTCONN (** Socket is not connected *) | ESHUTDOWN (** Can't send after socket shutdown *) | ETOOMANYREFS (** Too many references: can't splice *) | ETIMEDOUT (** Connection timed out *) | ECONNREFUSED (** Connection refused *) | EHOSTDOWN (** Host is down *) | EHOSTUNREACH (** No route to host *) | ELOOP (** Too many levels of symbolic links *) | EOVERFLOW (** File size or position not representable *) | EUNKNOWNERR of int (** Unknown error *) (** The type of error codes. Errors defined in the POSIX standard and additional errors from UNIX98 and BSD. All other errors are mapped to EUNKNOWNERR. *) exception Unix_error of error * string * string (** Raised by the system calls below when an error is encountered. The first component is the error code; the second component is the function name; the third component is the string parameter to the function, if it has one, or the empty string otherwise. *) val error_message : error -> string (** Return a string describing the given error code. *) val handle_unix_error : ('a -> 'b) -> 'a -> 'b (** [handle_unix_error f x] applies [f] to [x] and returns the result. If the exception [Unix_error] is raised, it prints a message describing the error and exits with code 2. *) (** {6 Access to the process environment} *) val environment : unit -> string array (** Return the process environment, as an array of strings with the format ``variable=value''. *) val getenv : string -> string (** Return the value associated to a variable in the process environment. Raise [Not_found] if the variable is unbound. (This function is identical to [Sys.getenv].) *) val putenv : string -> string -> unit (** [Unix.putenv name value] sets the value associated to a variable in the process environment. [name] is the name of the environment variable, and [value] its new associated value. *) (** {6 Process handling} *) type process_status = Unix.process_status = WEXITED of int (** The process terminated normally by [exit]; the argument is the return code. *) | WSIGNALED of int (** The process was killed by a signal; the argument is the signal number. *) | WSTOPPED of int (** The process was stopped by a signal; the argument is the signal number. *) (** The termination status of a process. See module {!Sys} for the definitions of the standard signal numbers. Note that they are not the numbers used by the OS. *) type wait_flag = Unix.wait_flag = WNOHANG (** do not block if no child has died yet, but immediately return with a pid equal to 0.*) | WUNTRACED (** report also the children that receive stop signals. *) (** Flags for {!UnixLabels.waitpid}. *) val execv : prog:string -> args:string array -> 'a (** [execv prog args] execute the program in file [prog], with the arguments [args], and the current process environment. These [execv*] functions never return: on success, the current program is replaced by the new one; on failure, a {!UnixLabels.Unix_error} exception is raised. *) val execve : prog:string -> args:string array -> env:string array -> 'a (** Same as {!UnixLabels.execv}, except that the third argument provides the environment to the program executed. *) val execvp : prog:string -> args:string array -> 'a (** Same as {!UnixLabels.execv}, except that the program is searched in the path. *) val execvpe : prog:string -> args:string array -> env:string array -> 'a (** Same as {!UnixLabels.execve}, except that the program is searched in the path. *) val fork : unit -> int (** Fork a new process. The returned integer is 0 for the child process, the pid of the child process for the parent process. *) val wait : unit -> int * process_status (** Wait until one of the children processes die, and return its pid and termination status. *) val waitpid : mode:wait_flag list -> int -> int * process_status (** Same as {!UnixLabels.wait}, but waits for the child process whose pid is given. A pid of [-1] means wait for any child. A pid of [0] means wait for any child in the same process group as the current process. Negative pid arguments represent process groups. The list of options indicates whether [waitpid] should return immediately without waiting, or also report stopped children. *) val system : string -> process_status (** Execute the given command, wait until it terminates, and return its termination status. The string is interpreted by the shell [/bin/sh] and therefore can contain redirections, quotes, variables, etc. The result [WEXITED 127] indicates that the shell couldn't be executed. *) val getpid : unit -> int (** Return the pid of the process. *) val getppid : unit -> int (** Return the pid of the parent process. *) val nice : int -> int (** Change the process priority. The integer argument is added to the ``nice'' value. (Higher values of the ``nice'' value mean lower priorities.) Return the new nice value. *) (** {6 Basic file input/output} *) type file_descr = Unix.file_descr (** The abstract type of file descriptors. *) val stdin : file_descr (** File descriptor for standard input.*) val stdout : file_descr (** File descriptor for standard output.*) val stderr : file_descr (** File descriptor for standard error. *) type open_flag = Unix.open_flag = O_RDONLY (** Open for reading *) | O_WRONLY (** Open for writing *) | O_RDWR (** Open for reading and writing *) | O_NONBLOCK (** Open in non-blocking mode *) | O_APPEND (** Open for append *) | O_CREAT (** Create if nonexistent *) | O_TRUNC (** Truncate to 0 length if existing *) | O_EXCL (** Fail if existing *) | O_NOCTTY (** Don't make this dev a controlling tty *) | O_DSYNC (** Writes complete as `Synchronised I/O data integrity completion' *) | O_SYNC (** Writes complete as `Synchronised I/O file integrity completion' *) | O_RSYNC (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *) | O_SHARE_DELETE (** Windows only: allow the file to be deleted while still open *) (** The flags to {!UnixLabels.openfile}. *) type file_perm = int (** The type of file access rights, e.g. [0o640] is read and write for user, read for group, none for others *) val openfile : string -> mode:open_flag list -> perm:file_perm -> file_descr (** Open the named file with the given flags. Third argument is the permissions to give to the file if it is created. Return a file descriptor on the named file. *) val close : file_descr -> unit (** Close a file descriptor. *) val read : file_descr -> buf:string -> pos:int -> len:int -> int (** [read fd buff ofs len] reads [len] characters from descriptor [fd], storing them in string [buff], starting at position [ofs] in string [buff]. Return the number of characters actually read. *) val write : file_descr -> buf:string -> pos:int -> len:int -> int (** [write fd buff ofs len] writes [len] characters to descriptor [fd], taking them from string [buff], starting at position [ofs] in string [buff]. Return the number of characters actually written. [write] repeats the writing operation until all characters have been written or an error occurs. *) val single_write : file_descr -> buf:string -> pos:int -> len:int -> int (** Same as [write], but attempts to write only once. Thus, if an error occurs, [single_write] guarantees that no data has been written. *) (** {6 Interfacing with the standard input/output library} *) val in_channel_of_descr : file_descr -> in_channel (** Create an input channel reading from the given descriptor. The channel is initially in binary mode; use [set_binary_mode_in ic false] if text mode is desired. *) val out_channel_of_descr : file_descr -> out_channel (** Create an output channel writing on the given descriptor. The channel is initially in binary mode; use [set_binary_mode_out oc false] if text mode is desired. *) val descr_of_in_channel : in_channel -> file_descr (** Return the descriptor corresponding to an input channel. *) val descr_of_out_channel : out_channel -> file_descr (** Return the descriptor corresponding to an output channel. *) (** {6 Seeking and truncating} *) type seek_command = Unix.seek_command = SEEK_SET (** indicates positions relative to the beginning of the file *) | SEEK_CUR (** indicates positions relative to the current position *) | SEEK_END (** indicates positions relative to the end of the file *) (** Positioning modes for {!UnixLabels.lseek}. *) val lseek : file_descr -> int -> mode:seek_command -> int (** Set the current position for a file descriptor *) val truncate : string -> len:int -> unit (** Truncates the named file to the given size. *) val ftruncate : file_descr -> len:int -> unit (** Truncates the file corresponding to the given descriptor to the given size. *) (** {6 File status} *) type file_kind = Unix.file_kind = S_REG (** Regular file *) | S_DIR (** Directory *) | S_CHR (** Character device *) | S_BLK (** Block device *) | S_LNK (** Symbolic link *) | S_FIFO (** Named pipe *) | S_SOCK (** Socket *) type stats = Unix.stats = { st_dev : int; (** Device number *) st_ino : int; (** Inode number *) st_kind : file_kind; (** Kind of the file *) st_perm : file_perm; (** Access rights *) st_nlink : int; (** Number of links *) st_uid : int; (** User id of the owner *) st_gid : int; (** Group ID of the file's group *) st_rdev : int; (** Device minor number *) st_size : int; (** Size in bytes *) st_atime : float; (** Last access time *) st_mtime : float; (** Last modification time *) st_ctime : float; (** Last status change time *) } (** The information returned by the {!UnixLabels.stat} calls. *) val stat : string -> stats (** Return the information for the named file. *) val lstat : string -> stats (** Same as {!UnixLabels.stat}, but in case the file is a symbolic link, return the information for the link itself. *) val fstat : file_descr -> stats (** Return the information for the file associated with the given descriptor. *) val isatty : file_descr -> bool (** Return [true] if the given file descriptor refers to a terminal or console window, [false] otherwise. *) (** {6 File operations on large files} *) module LargeFile : sig val lseek : file_descr -> int64 -> mode:seek_command -> int64 val truncate : string -> len:int64 -> unit val ftruncate : file_descr -> len:int64 -> unit type stats = Unix.LargeFile.stats = { st_dev : int; (** Device number *) st_ino : int; (** Inode number *) st_kind : file_kind; (** Kind of the file *) st_perm : file_perm; (** Access rights *) st_nlink : int; (** Number of links *) st_uid : int; (** User id of the owner *) st_gid : int; (** Group ID of the file's group *) st_rdev : int; (** Device minor number *) st_size : int64; (** Size in bytes *) st_atime : float; (** Last access time *) st_mtime : float; (** Last modification time *) st_ctime : float; (** Last status change time *) } val stat : string -> stats val lstat : string -> stats val fstat : file_descr -> stats end (** File operations on large files. This sub-module provides 64-bit variants of the functions {!UnixLabels.lseek} (for positioning a file descriptor), {!UnixLabels.truncate} and {!UnixLabels.ftruncate} (for changing the size of a file), and {!UnixLabels.stat}, {!UnixLabels.lstat} and {!UnixLabels.fstat} (for obtaining information on files). These alternate functions represent positions and sizes by 64-bit integers (type [int64]) instead of regular integers (type [int]), thus allowing operating on files whose sizes are greater than [max_int]. *) (** {6 Operations on file names} *) val unlink : string -> unit (** Removes the named file *) val rename : src:string -> dst:string -> unit (** [rename old new] changes the name of a file from [old] to [new]. *) val link : src:string -> dst:string -> unit (** [link source dest] creates a hard link named [dest] to the file named [source]. *) (** {6 File permissions and ownership} *) type access_permission = Unix.access_permission = R_OK (** Read permission *) | W_OK (** Write permission *) | X_OK (** Execution permission *) | F_OK (** File exists *) (** Flags for the {!UnixLabels.access} call. *) val chmod : string -> perm:file_perm -> unit (** Change the permissions of the named file. *) val fchmod : file_descr -> perm:file_perm -> unit (** Change the permissions of an opened file. *) val chown : string -> uid:int -> gid:int -> unit (** Change the owner uid and owner gid of the named file. *) val fchown : file_descr -> uid:int -> gid:int -> unit (** Change the owner uid and owner gid of an opened file. *) val umask : int -> int (** Set the process's file mode creation mask, and return the previous mask. *) val access : string -> perm:access_permission list -> unit (** Check that the process has the given permissions over the named file. Raise [Unix_error] otherwise. *) (** {6 Operations on file descriptors} *) val dup : file_descr -> file_descr (** Return a new file descriptor referencing the same file as the given descriptor. *) val dup2 : src:file_descr -> dst:file_descr -> unit (** [dup2 fd1 fd2] duplicates [fd1] to [fd2], closing [fd2] if already opened. *) val set_nonblock : file_descr -> unit (** Set the ``non-blocking'' flag on the given descriptor. When the non-blocking flag is set, reading on a descriptor on which there is temporarily no data available raises the [EAGAIN] or [EWOULDBLOCK] error instead of blocking; writing on a descriptor on which there is temporarily no room for writing also raises [EAGAIN] or [EWOULDBLOCK]. *) val clear_nonblock : file_descr -> unit (** Clear the ``non-blocking'' flag on the given descriptor. See {!UnixLabels.set_nonblock}.*) val set_close_on_exec : file_descr -> unit (** Set the ``close-on-exec'' flag on the given descriptor. A descriptor with the close-on-exec flag is automatically closed when the current process starts another program with one of the [exec] functions. *) val clear_close_on_exec : file_descr -> unit (** Clear the ``close-on-exec'' flag on the given descriptor. See {!UnixLabels.set_close_on_exec}.*) (** {6 Directories} *) val mkdir : string -> perm:file_perm -> unit (** Create a directory with the given permissions. *) val rmdir : string -> unit (** Remove an empty directory. *) val chdir : string -> unit (** Change the process working directory. *) val getcwd : unit -> string (** Return the name of the current working directory. *) val chroot : string -> unit (** Change the process root directory. *) type dir_handle = Unix.dir_handle (** The type of descriptors over opened directories. *) val opendir : string -> dir_handle (** Open a descriptor on a directory *) val readdir : dir_handle -> string (** Return the next entry in a directory. @raise End_of_file when the end of the directory has been reached. *) val rewinddir : dir_handle -> unit (** Reposition the descriptor to the beginning of the directory *) val closedir : dir_handle -> unit (** Close a directory descriptor. *) (** {6 Pipes and redirections} *) val pipe : unit -> file_descr * file_descr (** Create a pipe. The first component of the result is opened for reading, that's the exit to the pipe. The second component is opened for writing, that's the entrance to the pipe. *) val mkfifo : string -> perm:file_perm -> unit (** Create a named pipe with the given permissions. *) (** {6 High-level process and redirection management} *) val create_process : prog:string -> args:string array -> stdin:file_descr -> stdout:file_descr -> stderr:file_descr -> int (** [create_process prog args new_stdin new_stdout new_stderr] forks a new process that executes the program in file [prog], with arguments [args]. The pid of the new process is returned immediately; the new process executes concurrently with the current process. The standard input and outputs of the new process are connected to the descriptors [new_stdin], [new_stdout] and [new_stderr]. Passing e.g. [stdout] for [new_stdout] prevents the redirection and causes the new process to have the same standard output as the current process. The executable file [prog] is searched in the path. The new process has the same environment as the current process. *) val create_process_env : prog:string -> args:string array -> env:string array -> stdin:file_descr -> stdout:file_descr -> stderr:file_descr -> int (** [create_process_env prog args env new_stdin new_stdout new_stderr] works as {!UnixLabels.create_process}, except that the extra argument [env] specifies the environment passed to the program. *) val open_process_in : string -> in_channel (** High-level pipe and process management. This function runs the given command in parallel with the program. The standard output of the command is redirected to a pipe, which can be read via the returned input channel. The command is interpreted by the shell [/bin/sh] (cf. [system]). *) val open_process_out : string -> out_channel (** Same as {!UnixLabels.open_process_in}, but redirect the standard input of the command to a pipe. Data written to the returned output channel is sent to the standard input of the command. Warning: writes on output channels are buffered, hence be careful to call {!Pervasives.flush} at the right times to ensure correct synchronization. *) val open_process : string -> in_channel * out_channel (** Same as {!UnixLabels.open_process_out}, but redirects both the standard input and standard output of the command to pipes connected to the two returned channels. The input channel is connected to the output of the command, and the output channel to the input of the command. *) val open_process_full : string -> env:string array -> in_channel * out_channel * in_channel (** Similar to {!UnixLabels.open_process}, but the second argument specifies the environment passed to the command. The result is a triple of channels connected respectively to the standard output, standard input, and standard error of the command. *) val close_process_in : in_channel -> process_status (** Close channels opened by {!UnixLabels.open_process_in}, wait for the associated command to terminate, and return its termination status. *) val close_process_out : out_channel -> process_status (** Close channels opened by {!UnixLabels.open_process_out}, wait for the associated command to terminate, and return its termination status. *) val close_process : in_channel * out_channel -> process_status (** Close channels opened by {!UnixLabels.open_process}, wait for the associated command to terminate, and return its termination status. *) val close_process_full : in_channel * out_channel * in_channel -> process_status (** Close channels opened by {!UnixLabels.open_process_full}, wait for the associated command to terminate, and return its termination status. *) (** {6 Symbolic links} *) val symlink : src:string -> dst:string -> unit (** [symlink source dest] creates the file [dest] as a symbolic link to the file [source]. *) val readlink : string -> string (** Read the contents of a link. *) (** {6 Polling} *) val select : read:file_descr list -> write:file_descr list -> except:file_descr list -> timeout:float -> file_descr list * file_descr list * file_descr list (** Wait until some input/output operations become possible on some channels. The three list arguments are, respectively, a set of descriptors to check for reading (first argument), for writing (second argument), or for exceptional conditions (third argument). The fourth argument is the maximal timeout, in seconds; a negative fourth argument means no timeout (unbounded wait). The result is composed of three sets of descriptors: those ready for reading (first component), ready for writing (second component), and over which an exceptional condition is pending (third component). *) (** {6 Locking} *) type lock_command = Unix.lock_command = F_ULOCK (** Unlock a region *) | F_LOCK (** Lock a region for writing, and block if already locked *) | F_TLOCK (** Lock a region for writing, or fail if already locked *) | F_TEST (** Test a region for other process locks *) | F_RLOCK (** Lock a region for reading, and block if already locked *) | F_TRLOCK (** Lock a region for reading, or fail if already locked *) (** Commands for {!UnixLabels.lockf}. *) val lockf : file_descr -> mode:lock_command -> len:int -> unit (** [lockf fd cmd size] puts a lock on a region of the file opened as [fd]. The region starts at the current read/write position for [fd] (as set by {!UnixLabels.lseek}), and extends [size] bytes forward if [size] is positive, [size] bytes backwards if [size] is negative, or to the end of the file if [size] is zero. A write lock prevents any other process from acquiring a read or write lock on the region. A read lock prevents any other process from acquiring a write lock on the region, but lets other processes acquire read locks on it. The [F_LOCK] and [F_TLOCK] commands attempts to put a write lock on the specified region. The [F_RLOCK] and [F_TRLOCK] commands attempts to put a read lock on the specified region. If one or several locks put by another process prevent the current process from acquiring the lock, [F_LOCK] and [F_RLOCK] block until these locks are removed, while [F_TLOCK] and [F_TRLOCK] fail immediately with an exception. The [F_ULOCK] removes whatever locks the current process has on the specified region. Finally, the [F_TEST] command tests whether a write lock can be acquired on the specified region, without actually putting a lock. It returns immediately if successful, or fails otherwise. *) (** {6 Signals} Note: installation of signal handlers is performed via the functions {!Sys.signal} and {!Sys.set_signal}. *) val kill : pid:int -> signal:int -> unit (** [kill pid sig] sends signal number [sig] to the process with id [pid]. *) type sigprocmask_command = Unix.sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK val sigprocmask : mode:sigprocmask_command -> int list -> int list (** [sigprocmask cmd sigs] changes the set of blocked signals. If [cmd] is [SIG_SETMASK], blocked signals are set to those in the list [sigs]. If [cmd] is [SIG_BLOCK], the signals in [sigs] are added to the set of blocked signals. If [cmd] is [SIG_UNBLOCK], the signals in [sigs] are removed from the set of blocked signals. [sigprocmask] returns the set of previously blocked signals. *) val sigpending : unit -> int list (** Return the set of blocked signals that are currently pending. *) val sigsuspend : int list -> unit (** [sigsuspend sigs] atomically sets the blocked signals to [sigs] and waits for a non-ignored, non-blocked signal to be delivered. On return, the blocked signals are reset to their initial value. *) val pause : unit -> unit (** Wait until a non-ignored, non-blocked signal is delivered. *) (** {6 Time functions} *) type process_times = Unix.process_times = { tms_utime : float; (** User time for the process *) tms_stime : float; (** System time for the process *) tms_cutime : float; (** User time for the children processes *) tms_cstime : float; (** System time for the children processes *) } (** The execution times (CPU times) of a process. *) type tm = Unix.tm = { tm_sec : int; (** Seconds 0..60 *) tm_min : int; (** Minutes 0..59 *) tm_hour : int; (** Hours 0..23 *) tm_mday : int; (** Day of month 1..31 *) tm_mon : int; (** Month of year 0..11 *) tm_year : int; (** Year - 1900 *) tm_wday : int; (** Day of week (Sunday is 0) *) tm_yday : int; (** Day of year 0..365 *) tm_isdst : bool; (** Daylight time savings in effect *) } (** The type representing wallclock time and calendar date. *) val time : unit -> float (** Return the current time since 00:00:00 GMT, Jan. 1, 1970, in seconds. *) val gettimeofday : unit -> float (** Same as {!UnixLabels.time}, but with resolution better than 1 second. *) val gmtime : float -> tm (** Convert a time in seconds, as returned by {!UnixLabels.time}, into a date and a time. Assumes UTC (Coordinated Universal Time), also known as GMT. *) val localtime : float -> tm (** Convert a time in seconds, as returned by {!UnixLabels.time}, into a date and a time. Assumes the local time zone. *) val mktime : tm -> float * tm (** Convert a date and time, specified by the [tm] argument, into a time in seconds, as returned by {!UnixLabels.time}. The [tm_isdst], [tm_wday] and [tm_yday] fields of [tm] are ignored. Also return a normalized copy of the given [tm] record, with the [tm_wday], [tm_yday], and [tm_isdst] fields recomputed from the other fields, and the other fields normalized (so that, e.g., 40 October is changed into 9 November). The [tm] argument is interpreted in the local time zone. *) val alarm : int -> int (** Schedule a [SIGALRM] signal after the given number of seconds. *) val sleep : int -> unit (** Stop execution for the given number of seconds. *) val times : unit -> process_times (** Return the execution times of the process. *) val utimes : string -> access:float -> modif:float -> unit (** Set the last access time (second arg) and last modification time (third arg) for a file. Times are expressed in seconds from 00:00:00 GMT, Jan. 1, 1970. A time of [0.0] is interpreted as the current time. *) type interval_timer = Unix.interval_timer = ITIMER_REAL (** decrements in real time, and sends the signal [SIGALRM] when expired.*) | ITIMER_VIRTUAL (** decrements in process virtual time, and sends [SIGVTALRM] when expired. *) | ITIMER_PROF (** (for profiling) decrements both when the process is running and when the system is running on behalf of the process; it sends [SIGPROF] when expired. *) (** The three kinds of interval timers. *) type interval_timer_status = Unix.interval_timer_status = { it_interval : float; (** Period *) it_value : float; (** Current value of the timer *) } (** The type describing the status of an interval timer *) val getitimer : interval_timer -> interval_timer_status (** Return the current status of the given interval timer. *) val setitimer : interval_timer -> interval_timer_status -> interval_timer_status (** [setitimer t s] sets the interval timer [t] and returns its previous status. The [s] argument is interpreted as follows: [s.it_value], if nonzero, is the time to the next timer expiration; [s.it_interval], if nonzero, specifies a value to be used in reloading it_value when the timer expires. Setting [s.it_value] to zero disable the timer. Setting [s.it_interval] to zero causes the timer to be disabled after its next expiration. *) (** {6 User id, group id} *) val getuid : unit -> int (** Return the user id of the user executing the process. *) val geteuid : unit -> int (** Return the effective user id under which the process runs. *) val setuid : int -> unit (** Set the real user id and effective user id for the process. *) val getgid : unit -> int (** Return the group id of the user executing the process. *) val getegid : unit -> int (** Return the effective group id under which the process runs. *) val setgid : int -> unit (** Set the real group id and effective group id for the process. *) val getgroups : unit -> int array (** Return the list of groups to which the user executing the process belongs. *) val setgroups : int array -> unit (** [setgroups groups] sets the supplementary group IDs for the calling process. Appropriate privileges are required. *) val initgroups : string -> int -> unit (** [initgroups user group] initializes the group access list by reading the group database /etc/group and using all groups of which [user] is a member. The additional group [group] is also added to the list. *) type passwd_entry = Unix.passwd_entry = { pw_name : string; pw_passwd : string; pw_uid : int; pw_gid : int; pw_gecos : string; pw_dir : string; pw_shell : string } (** Structure of entries in the [passwd] database. *) type group_entry = Unix.group_entry = { gr_name : string; gr_passwd : string; gr_gid : int; gr_mem : string array } (** Structure of entries in the [groups] database. *) val getlogin : unit -> string (** Return the login name of the user executing the process. *) val getpwnam : string -> passwd_entry (** Find an entry in [passwd] with the given name, or raise [Not_found]. *) val getgrnam : string -> group_entry (** Find an entry in [group] with the given name, or raise [Not_found]. *) val getpwuid : int -> passwd_entry (** Find an entry in [passwd] with the given user id, or raise [Not_found]. *) val getgrgid : int -> group_entry (** Find an entry in [group] with the given group id, or raise [Not_found]. *) (** {6 Internet addresses} *) type inet_addr = Unix.inet_addr (** The abstract type of Internet addresses. *) val inet_addr_of_string : string -> inet_addr (** Conversion from the printable representation of an Internet address to its internal representation. The argument string consists of 4 numbers separated by periods ([XXX.YYY.ZZZ.TTT]) for IPv4 addresses, and up to 8 numbers separated by colons for IPv6 addresses. Raise [Failure] when given a string that does not match these formats. *) val string_of_inet_addr : inet_addr -> string (** Return the printable representation of the given Internet address. See {!Unix.inet_addr_of_string} for a description of the printable representation. *) val inet_addr_any : inet_addr (** A special IPv4 address, for use only with [bind], representing all the Internet addresses that the host machine possesses. *) val inet_addr_loopback : inet_addr (** A special IPv4 address representing the host machine ([127.0.0.1]). *) val inet6_addr_any : inet_addr (** A special IPv6 address, for use only with [bind], representing all the Internet addresses that the host machine possesses. *) val inet6_addr_loopback : inet_addr (** A special IPv6 address representing the host machine ([::1]). *) (** {6 Sockets} *) type socket_domain = Unix.socket_domain = PF_UNIX (** Unix domain *) | PF_INET (** Internet domain (IPv4) *) | PF_INET6 (** Internet domain (IPv6) *) (** The type of socket domains. Not all platforms support IPv6 sockets (type [PF_INET6]). *) type socket_type = Unix.socket_type = SOCK_STREAM (** Stream socket *) | SOCK_DGRAM (** Datagram socket *) | SOCK_RAW (** Raw socket *) | SOCK_SEQPACKET (** Sequenced packets socket *) (** The type of socket kinds, specifying the semantics of communications. *) type sockaddr = Unix.sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int (** The type of socket addresses. [ADDR_UNIX name] is a socket address in the Unix domain; [name] is a file name in the file system. [ADDR_INET(addr,port)] is a socket address in the Internet domain; [addr] is the Internet address of the machine, and [port] is the port number. *) val socket : domain:socket_domain -> kind:socket_type -> protocol:int -> file_descr (** Create a new socket in the given domain, and with the given kind. The third argument is the protocol type; 0 selects the default protocol for that kind of sockets. *) val domain_of_sockaddr: sockaddr -> socket_domain (** Return the socket domain adequate for the given socket address. *) val socketpair : domain:socket_domain -> kind:socket_type -> protocol:int -> file_descr * file_descr (** Create a pair of unnamed sockets, connected together. *) val accept : file_descr -> file_descr * sockaddr (** Accept connections on the given socket. The returned descriptor is a socket connected to the client; the returned address is the address of the connecting client. *) val bind : file_descr -> addr:sockaddr -> unit (** Bind a socket to an address. *) val connect : file_descr -> addr:sockaddr -> unit (** Connect a socket to an address. *) val listen : file_descr -> max:int -> unit (** Set up a socket for receiving connection requests. The integer argument is the maximal number of pending requests. *) type shutdown_command = Unix.shutdown_command = SHUTDOWN_RECEIVE (** Close for receiving *) | SHUTDOWN_SEND (** Close for sending *) | SHUTDOWN_ALL (** Close both *) (** The type of commands for [shutdown]. *) val shutdown : file_descr -> mode:shutdown_command -> unit (** Shutdown a socket connection. [SHUTDOWN_SEND] as second argument causes reads on the other end of the connection to return an end-of-file condition. [SHUTDOWN_RECEIVE] causes writes on the other end of the connection to return a closed pipe condition ([SIGPIPE] signal). *) val getsockname : file_descr -> sockaddr (** Return the address of the given socket. *) val getpeername : file_descr -> sockaddr (** Return the address of the host connected to the given socket. *) type msg_flag = Unix.msg_flag = MSG_OOB | MSG_DONTROUTE | MSG_PEEK (** The flags for {!UnixLabels.recv}, {!UnixLabels.recvfrom}, {!UnixLabels.send} and {!UnixLabels.sendto}. *) val recv : file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> int (** Receive data from a connected socket. *) val recvfrom : file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> int * sockaddr (** Receive data from an unconnected socket. *) val send : file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> int (** Send data over a connected socket. *) val sendto : file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> addr:sockaddr -> int (** Send data over an unconnected socket. *) (** {6 Socket options} *) type socket_bool_option = SO_DEBUG (** Record debugging information *) | SO_BROADCAST (** Permit sending of broadcast messages *) | SO_REUSEADDR (** Allow reuse of local addresses for bind *) | SO_KEEPALIVE (** Keep connection active *) | SO_DONTROUTE (** Bypass the standard routing algorithms *) | SO_OOBINLINE (** Leave out-of-band data in line *) | SO_ACCEPTCONN (** Report whether socket listening is enabled *) | TCP_NODELAY (** Control the Nagle algorithm for TCP sockets *) | IPV6_ONLY (** Forbid binding an IPv6 socket to an IPv4 address *) (** The socket options that can be consulted with {!UnixLabels.getsockopt} and modified with {!UnixLabels.setsockopt}. These options have a boolean ([true]/[false]) value. *) type socket_int_option = SO_SNDBUF (** Size of send buffer *) | SO_RCVBUF (** Size of received buffer *) | SO_ERROR (** Deprecated. Use {!Unix.getsockopt_error} instead. *) | SO_TYPE (** Report the socket type *) | SO_RCVLOWAT (** Minimum number of bytes to process for input operations *) | SO_SNDLOWAT (** Minimum number of bytes to process for output operations *) (** The socket options that can be consulted with {!UnixLabels.getsockopt_int} and modified with {!UnixLabels.setsockopt_int}. These options have an integer value. *) type socket_optint_option = SO_LINGER (** Whether to linger on closed connections that have data present, and for how long (in seconds) *) (** The socket options that can be consulted with {!Unix.getsockopt_optint} and modified with {!Unix.setsockopt_optint}. These options have a value of type [int option], with [None] meaning ``disabled''. *) type socket_float_option = SO_RCVTIMEO (** Timeout for input operations *) | SO_SNDTIMEO (** Timeout for output operations *) (** The socket options that can be consulted with {!UnixLabels.getsockopt_float} and modified with {!UnixLabels.setsockopt_float}. These options have a floating-point value representing a time in seconds. The value 0 means infinite timeout. *) val getsockopt : file_descr -> socket_bool_option -> bool (** Return the current status of a boolean-valued option in the given socket. *) val setsockopt : file_descr -> socket_bool_option -> bool -> unit (** Set or clear a boolean-valued option in the given socket. *) val getsockopt_int : file_descr -> socket_int_option -> int (** Same as {!Unix.getsockopt} for an integer-valued socket option. *) val setsockopt_int : file_descr -> socket_int_option -> int -> unit (** Same as {!Unix.setsockopt} for an integer-valued socket option. *) val getsockopt_optint : file_descr -> socket_optint_option -> int option (** Same as {!Unix.getsockopt} for a socket option whose value is an [int option]. *) val setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit (** Same as {!Unix.setsockopt} for a socket option whose value is an [int option]. *) val getsockopt_float : file_descr -> socket_float_option -> float (** Same as {!Unix.getsockopt} for a socket option whose value is a floating-point number. *) val setsockopt_float : file_descr -> socket_float_option -> float -> unit (** Same as {!Unix.setsockopt} for a socket option whose value is a floating-point number. *) val getsockopt_error : file_descr -> error option (** Return the error condition associated with the given socket, and clear it. *) (** {6 High-level network connection functions} *) val open_connection : sockaddr -> in_channel * out_channel (** Connect to a server at the given address. Return a pair of buffered channels connected to the server. Remember to call {!Pervasives.flush} on the output channel at the right times to ensure correct synchronization. *) val shutdown_connection : in_channel -> unit (** ``Shut down'' a connection established with {!UnixLabels.open_connection}; that is, transmit an end-of-file condition to the server reading on the other side of the connection. *) val establish_server : (in_channel -> out_channel -> unit) -> addr:sockaddr -> unit (** Establish a server on the given address. The function given as first argument is called for each connection with two buffered channels connected to the client. A new process is created for each connection. The function {!UnixLabels.establish_server} never returns normally. *) (** {6 Host and protocol databases} *) type host_entry = Unix.host_entry = { h_name : string; h_aliases : string array; h_addrtype : socket_domain; h_addr_list : inet_addr array } (** Structure of entries in the [hosts] database. *) type protocol_entry = Unix.protocol_entry = { p_name : string; p_aliases : string array; p_proto : int } (** Structure of entries in the [protocols] database. *) type service_entry = Unix.service_entry = { s_name : string; s_aliases : string array; s_port : int; s_proto : string } (** Structure of entries in the [services] database. *) val gethostname : unit -> string (** Return the name of the local host. *) val gethostbyname : string -> host_entry (** Find an entry in [hosts] with the given name, or raise [Not_found]. *) val gethostbyaddr : inet_addr -> host_entry (** Find an entry in [hosts] with the given address, or raise [Not_found]. *) val getprotobyname : string -> protocol_entry (** Find an entry in [protocols] with the given name, or raise [Not_found]. *) val getprotobynumber : int -> protocol_entry (** Find an entry in [protocols] with the given protocol number, or raise [Not_found]. *) val getservbyname : string -> protocol:string -> service_entry (** Find an entry in [services] with the given name, or raise [Not_found]. *) val getservbyport : int -> protocol:string -> service_entry (** Find an entry in [services] with the given service number, or raise [Not_found]. *) type addr_info = { ai_family : socket_domain; (** Socket domain *) ai_socktype : socket_type; (** Socket type *) ai_protocol : int; (** Socket protocol number *) ai_addr : sockaddr; (** Address *) ai_canonname : string (** Canonical host name *) } (** Address information returned by {!Unix.getaddrinfo}. *) type getaddrinfo_option = AI_FAMILY of socket_domain (** Impose the given socket domain *) | AI_SOCKTYPE of socket_type (** Impose the given socket type *) | AI_PROTOCOL of int (** Impose the given protocol *) | AI_NUMERICHOST (** Do not call name resolver, expect numeric IP address *) | AI_CANONNAME (** Fill the [ai_canonname] field of the result *) | AI_PASSIVE (** Set address to ``any'' address for use with {!Unix.bind} *) (** Options to {!Unix.getaddrinfo}. *) val getaddrinfo: string -> string -> getaddrinfo_option list -> addr_info list (** [getaddrinfo host service opts] returns a list of {!Unix.addr_info} records describing socket parameters and addresses suitable for communicating with the given host and service. The empty list is returned if the host or service names are unknown, or the constraints expressed in [opts] cannot be satisfied. [host] is either a host name or the string representation of an IP address. [host] can be given as the empty string; in this case, the ``any'' address or the ``loopback'' address are used, depending whether [opts] contains [AI_PASSIVE]. [service] is either a service name or the string representation of a port number. [service] can be given as the empty string; in this case, the port field of the returned addresses is set to 0. [opts] is a possibly empty list of options that allows the caller to force a particular socket domain (e.g. IPv6 only or IPv4 only) or a particular socket type (e.g. TCP only or UDP only). *) type name_info = { ni_hostname : string; (** Name or IP address of host *) ni_service : string } (** Name of service or port number *) (** Host and service information returned by {!Unix.getnameinfo}. *) type getnameinfo_option = NI_NOFQDN (** Do not qualify local host names *) | NI_NUMERICHOST (** Always return host as IP address *) | NI_NAMEREQD (** Fail if host name cannot be determined *) | NI_NUMERICSERV (** Always return service as port number *) | NI_DGRAM (** Consider the service as UDP-based instead of the default TCP *) (** Options to {!Unix.getnameinfo}. *) val getnameinfo : sockaddr -> getnameinfo_option list -> name_info (** [getnameinfo addr opts] returns the host name and service name corresponding to the socket address [addr]. [opts] is a possibly empty list of options that governs how these names are obtained. Raise [Not_found] if an error occurs. *) (** {6 Terminal interface} *) (** The following functions implement the POSIX standard terminal interface. They provide control over asynchronous communication ports and pseudo-terminals. Refer to the [termios] man page for a complete description. *) type terminal_io = Unix.terminal_io = { (* input modes *) mutable c_ignbrk : bool; (** Ignore the break condition. *) mutable c_brkint : bool; (** Signal interrupt on break condition. *) mutable c_ignpar : bool; (** Ignore characters with parity errors. *) mutable c_parmrk : bool; (** Mark parity errors. *) mutable c_inpck : bool; (** Enable parity check on input. *) mutable c_istrip : bool; (** Strip 8th bit on input characters. *) mutable c_inlcr : bool; (** Map NL to CR on input. *) mutable c_igncr : bool; (** Ignore CR on input. *) mutable c_icrnl : bool; (** Map CR to NL on input. *) mutable c_ixon : bool; (** Recognize XON/XOFF characters on input. *) mutable c_ixoff : bool; (** Emit XON/XOFF chars to control input flow. *) (* Output modes: *) mutable c_opost : bool; (** Enable output processing. *) (* Control modes: *) mutable c_obaud : int; (** Output baud rate (0 means close connection).*) mutable c_ibaud : int; (** Input baud rate. *) mutable c_csize : int; (** Number of bits per character (5-8). *) mutable c_cstopb : int; (** Number of stop bits (1-2). *) mutable c_cread : bool; (** Reception is enabled. *) mutable c_parenb : bool; (** Enable parity generation and detection. *) mutable c_parodd : bool; (** Specify odd parity instead of even. *) mutable c_hupcl : bool; (** Hang up on last close. *) mutable c_clocal : bool; (** Ignore modem status lines. *) (* Local modes: *) mutable c_isig : bool; (** Generate signal on INTR, QUIT, SUSP. *) mutable c_icanon : bool; (** Enable canonical processing (line buffering and editing) *) mutable c_noflsh : bool; (** Disable flush after INTR, QUIT, SUSP. *) mutable c_echo : bool; (** Echo input characters. *) mutable c_echoe : bool; (** Echo ERASE (to erase previous character). *) mutable c_echok : bool; (** Echo KILL (to erase the current line). *) mutable c_echonl : bool; (** Echo NL even if c_echo is not set. *) (* Control characters: *) mutable c_vintr : char; (** Interrupt character (usually ctrl-C). *) mutable c_vquit : char; (** Quit character (usually ctrl-\). *) mutable c_verase : char; (** Erase character (usually DEL or ctrl-H). *) mutable c_vkill : char; (** Kill line character (usually ctrl-U). *) mutable c_veof : char; (** End-of-file character (usually ctrl-D). *) mutable c_veol : char; (** Alternate end-of-line char. (usually none). *) mutable c_vmin : int; (** Minimum number of characters to read before the read request is satisfied. *) mutable c_vtime : int; (** Maximum read wait (in 0.1s units). *) mutable c_vstart : char; (** Start character (usually ctrl-Q). *) mutable c_vstop : char; (** Stop character (usually ctrl-S). *) } val tcgetattr : file_descr -> terminal_io (** Return the status of the terminal referred to by the given file descriptor. *) type setattr_when = Unix.setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH val tcsetattr : file_descr -> mode:setattr_when -> terminal_io -> unit (** Set the status of the terminal referred to by the given file descriptor. The second argument indicates when the status change takes place: immediately ([TCSANOW]), when all pending output has been transmitted ([TCSADRAIN]), or after flushing all input that has been received but not read ([TCSAFLUSH]). [TCSADRAIN] is recommended when changing the output parameters; [TCSAFLUSH], when changing the input parameters. *) val tcsendbreak : file_descr -> duration:int -> unit (** Send a break condition on the given file descriptor. The second argument is the duration of the break, in 0.1s units; 0 means standard duration (0.25s). *) val tcdrain : file_descr -> unit (** Waits until all output written on the given file descriptor has been transmitted. *) type flush_queue = Unix.flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH val tcflush : file_descr -> mode:flush_queue -> unit (** Discard data written on the given file descriptor but not yet transmitted, or data received but not yet read, depending on the second argument: [TCIFLUSH] flushes data received but not read, [TCOFLUSH] flushes data written but not transmitted, and [TCIOFLUSH] flushes both. *) type flow_action = Unix.flow_action = TCOOFF | TCOON | TCIOFF | TCION val tcflow : file_descr -> mode:flow_action -> unit (** Suspend or restart reception or transmission of data on the given file descriptor, depending on the second argument: [TCOOFF] suspends output, [TCOON] restarts output, [TCIOFF] transmits a STOP character to suspend input, and [TCION] transmits a START character to restart input. *) val setsid : unit -> int (** Put the calling process in a new session and detach it from its controlling terminal. *) mingw-ocaml/ocaml/otherlibs/unix/itimer.c0000644000175000017500000000501312124403241020070 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #ifdef HAS_SETITIMER #include #include static void unix_set_timeval(struct timeval * tv, double d) { double integr, frac; frac = modf(d, &integr); /* Round time up so that if d is small but not 0, we end up with a non-0 timeval. */ tv->tv_sec = integr; tv->tv_usec = ceil(1e6 * frac); if (tv->tv_usec >= 1000000) { tv->tv_sec++; tv->tv_usec = 0; } } static value unix_convert_itimer(struct itimerval *tp) { #define Get_timeval(tv) (double) tv.tv_sec + (double) tv.tv_usec / 1e6 value res = alloc_small(Double_wosize * 2, Double_array_tag); Store_double_field(res, 0, Get_timeval(tp->it_interval)); Store_double_field(res, 1, Get_timeval(tp->it_value)); return res; #undef Get_timeval } static int itimers[3] = { ITIMER_REAL, ITIMER_VIRTUAL, ITIMER_PROF }; CAMLprim value unix_setitimer(value which, value newval) { struct itimerval new, old; unix_set_timeval(&new.it_interval, Double_field(newval, 0)); unix_set_timeval(&new.it_value, Double_field(newval, 1)); if (setitimer(itimers[Int_val(which)], &new, &old) == -1) uerror("setitimer", Nothing); return unix_convert_itimer(&old); } CAMLprim value unix_getitimer(value which) { struct itimerval val; if (getitimer(itimers[Int_val(which)], &val) == -1) uerror("getitimer", Nothing); return unix_convert_itimer(&val); } #else CAMLprim value unix_setitimer(value which, value newval) { invalid_argument("setitimer not implemented"); } CAMLprim value unix_getitimer(value which) { invalid_argument("getitimer not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/ftruncate.c0000644000175000017500000000313112124403241020571 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #ifdef HAS_UNISTD #include #endif #ifdef HAS_TRUNCATE CAMLprim value unix_ftruncate(value fd, value len) { if (ftruncate(Int_val(fd), Long_val(len)) == -1) uerror("ftruncate", Nothing); return Val_unit; } CAMLprim value unix_ftruncate_64(value fd, value len) { if (ftruncate(Int_val(fd), File_offset_val(len)) == -1) uerror("ftruncate", Nothing); return Val_unit; } #else CAMLprim value unix_ftruncate(value fd, value len) { invalid_argument("ftruncate not implemented"); } CAMLprim value unix_ftruncate_64(value fd, value len) { invalid_argument("ftruncate not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/setsid.c0000644000175000017500000000223312124403241020073 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1997 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #ifdef HAS_UNISTD #include #endif CAMLprim value unix_setsid(value unit) { #ifdef HAS_SETSID return Val_int(setsid()); #else invalid_argument("setsid not implemented"); return Val_unit; #endif } mingw-ocaml/ocaml/otherlibs/unix/stat.c0000644000175000017500000000743712124403241017566 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #include "cst2constr.h" #include #include #include #ifndef S_IFLNK #define S_IFLNK 0 #endif #ifndef S_IFIFO #define S_IFIFO 0 #endif #ifndef S_IFSOCK #define S_IFSOCK 0 #endif #ifndef S_IFBLK #define S_IFBLK 0 #endif #ifndef EOVERFLOW #define EOVERFLOW ERANGE #endif static int file_kind_table[] = { S_IFREG, S_IFDIR, S_IFCHR, S_IFBLK, S_IFLNK, S_IFIFO, S_IFSOCK }; static value stat_aux(int use_64, struct stat *buf) { CAMLparam0(); CAMLlocal5(atime, mtime, ctime, offset, v); atime = copy_double((double) buf->st_atime); mtime = copy_double((double) buf->st_mtime); ctime = copy_double((double) buf->st_ctime); offset = use_64 ? Val_file_offset(buf->st_size) : Val_int (buf->st_size); v = alloc_small(12, 0); Field (v, 0) = Val_int (buf->st_dev); Field (v, 1) = Val_int (buf->st_ino); Field (v, 2) = cst_to_constr(buf->st_mode & S_IFMT, file_kind_table, sizeof(file_kind_table) / sizeof(int), 0); Field (v, 3) = Val_int (buf->st_mode & 07777); Field (v, 4) = Val_int (buf->st_nlink); Field (v, 5) = Val_int (buf->st_uid); Field (v, 6) = Val_int (buf->st_gid); Field (v, 7) = Val_int (buf->st_rdev); Field (v, 8) = offset; Field (v, 9) = atime; Field (v, 10) = mtime; Field (v, 11) = ctime; CAMLreturn(v); } CAMLprim value unix_stat(value path) { int ret; struct stat buf; ret = stat(String_val(path), &buf); if (ret == -1) uerror("stat", path); if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG) unix_error(EOVERFLOW, "stat", path); return stat_aux(0, &buf); } CAMLprim value unix_lstat(value path) { int ret; struct stat buf; #ifdef HAS_SYMLINK ret = lstat(String_val(path), &buf); #else ret = stat(String_val(path), &buf); #endif if (ret == -1) uerror("lstat", path); if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG) unix_error(EOVERFLOW, "lstat", path); return stat_aux(0, &buf); } CAMLprim value unix_fstat(value fd) { int ret; struct stat buf; ret = fstat(Int_val(fd), &buf); if (ret == -1) uerror("fstat", Nothing); if (buf.st_size > Max_long && (buf.st_mode & S_IFMT) == S_IFREG) unix_error(EOVERFLOW, "fstat", Nothing); return stat_aux(0, &buf); } CAMLprim value unix_stat_64(value path) { int ret; struct stat buf; ret = stat(String_val(path), &buf); if (ret == -1) uerror("stat", path); return stat_aux(1, &buf); } CAMLprim value unix_lstat_64(value path) { int ret; struct stat buf; #ifdef HAS_SYMLINK ret = lstat(String_val(path), &buf); #else ret = stat(String_val(path), &buf); #endif if (ret == -1) uerror("lstat", path); return stat_aux(1, &buf); } CAMLprim value unix_fstat_64(value fd) { int ret; struct stat buf; ret = fstat(Int_val(fd), &buf); if (ret == -1) uerror("fstat", Nothing); return stat_aux(1, &buf); } mingw-ocaml/ocaml/otherlibs/unix/rmdir.c0000644000175000017500000000205612124403241017720 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_rmdir(value path) { if (rmdir(String_val(path)) == -1) uerror("rmdir", path); return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/libunix.clib0000644000175000017500000000161212124403241020741 0ustar tootstootsaccept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o chown.o chroot.o close.o closedir.o connect.o cst2constr.o cstringv.o dup.o dup2.o envir.o errmsg.o execv.o execve.o execvp.o exit.o fchmod.o fchown.o fcntl.o fork.o ftruncate.o getaddrinfo.o getcwd.o getegid.o geteuid.o getgid.o getgr.o getgroups.o gethost.o gethostname.o getlogin.o getnameinfo.o getpeername.o getpid.o getppid.o getproto.o getpw.o gettimeofday.o getserv.o getsockname.o getuid.o gmtime.o initgroups.o isatty.o itimer.o kill.o link.o listen.o lockf.o lseek.o mkdir.o mkfifo.o nice.o open.o opendir.o pipe.o putenv.o read.o readdir.o readlink.o rename.o rewinddir.o rmdir.o select.o sendrecv.o setgid.o setgroups.o setsid.o setuid.o shutdown.o signals.o sleep.o socket.o socketaddr.o socketpair.o sockopt.o stat.o strofaddr.o symlink.o termios.o time.o times.o truncate.o umask.o unixsupport.o unlink.o utimes.o wait.o write.o mingw-ocaml/ocaml/otherlibs/unix/exit.c0000644000175000017500000000217612124403241017557 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_exit(value n) { _exit(Int_val(n)); return Val_unit; /* never reached, but suppress warnings */ /* from smart compilers */ } mingw-ocaml/ocaml/otherlibs/unix/symlink.c0000644000175000017500000000237012124403241020270 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #ifdef HAS_SYMLINK CAMLprim value unix_symlink(value path1, value path2) { if (symlink(String_val(path1), String_val(path2)) == -1) uerror("symlink", path2); return Val_unit; } #else CAMLprim value unix_symlink(value path1, value path2) { invalid_argument("symlink not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/gethostname.c0000644000175000017500000000310712124403241021117 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #if defined (_WIN32) #include #else #include #endif #include "unixsupport.h" #ifdef HAS_GETHOSTNAME #ifndef MAXHOSTNAMELEN #define MAXHOSTNAMELEN 256 #endif CAMLprim value unix_gethostname(value unit) { char name[MAXHOSTNAMELEN]; gethostname(name, MAXHOSTNAMELEN); name[MAXHOSTNAMELEN-1] = 0; return copy_string(name); } #else #ifdef HAS_UNAME #include CAMLprim value unix_gethostname(value unit) { struct utsname un; uname(&un); return copy_string(un.nodename); } #else CAMLprim value unix_gethostname(value unit) { invalid_argument("gethostname not implemented"); } #endif #endif mingw-ocaml/ocaml/otherlibs/unix/accept.c0000644000175000017500000000323612124403241020043 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include "socketaddr.h" CAMLprim value unix_accept(value sock) { int retcode; value res; value a; union sock_addr_union addr; socklen_param_type addr_len; addr_len = sizeof(addr); enter_blocking_section(); retcode = accept(Int_val(sock), &addr.s_gen, &addr_len); leave_blocking_section(); if (retcode == -1) uerror("accept", Nothing); a = alloc_sockaddr(&addr, addr_len, retcode); Begin_root (a); res = alloc_small(2, 0); Field(res, 0) = Val_int(retcode); Field(res, 1) = a; End_roots(); return res; } #else CAMLprim value unix_accept(value sock) { invalid_argument("accept not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/rename.c0000644000175000017500000000215312124403241020050 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" CAMLprim value unix_rename(value path1, value path2) { if (rename(String_val(path1), String_val(path2)) == -1) uerror("rename", path1); return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/signals.c0000644000175000017500000000562312124403241020246 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1998 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include #include #include "unixsupport.h" #ifndef NSIG #define NSIG 64 #endif #ifdef POSIX_SIGNALS static void decode_sigset(value vset, sigset_t * set) { sigemptyset(set); while (vset != Val_int(0)) { int sig = caml_convert_signal_number(Int_val(Field(vset, 0))); sigaddset(set, sig); vset = Field(vset, 1); } } static value encode_sigset(sigset_t * set) { value res = Val_int(0); int i; Begin_root(res) for (i = 1; i < NSIG; i++) if (sigismember(set, i) > 0) { value newcons = alloc_small(2, 0); Field(newcons, 0) = Val_int(caml_rev_convert_signal_number(i)); Field(newcons, 1) = res; res = newcons; } End_roots(); return res; } static int sigprocmask_cmd[3] = { SIG_SETMASK, SIG_BLOCK, SIG_UNBLOCK }; CAMLprim value unix_sigprocmask(value vaction, value vset) { int how; sigset_t set, oldset; int retcode; how = sigprocmask_cmd[Int_val(vaction)]; decode_sigset(vset, &set); enter_blocking_section(); retcode = sigprocmask(how, &set, &oldset); leave_blocking_section(); if (retcode == -1) uerror("sigprocmask", Nothing); return encode_sigset(&oldset); } CAMLprim value unix_sigpending(value unit) { sigset_t pending; if (sigpending(&pending) == -1) uerror("sigpending", Nothing); return encode_sigset(&pending); } CAMLprim value unix_sigsuspend(value vset) { sigset_t set; int retcode; decode_sigset(vset, &set); enter_blocking_section(); retcode = sigsuspend(&set); leave_blocking_section(); if (retcode == -1 && errno != EINTR) uerror("sigsuspend", Nothing); return Val_unit; } #else CAMLprim value unix_sigprocmask(value vaction, value vset) { invalid_argument("Unix.sigprocmask not available"); } CAMLprim value unix_sigpending(value unit) { invalid_argument("Unix.sigpending not available"); } CAMLprim value unix_sigsuspend(value vset) { invalid_argument("Unix.sigsuspend not available"); } #endif mingw-ocaml/ocaml/otherlibs/unix/initgroups.c0000644000175000017500000000261112124403241021003 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Contributed by Stephane Glondu */ /* */ /* Copyright 2009 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #ifdef HAS_INITGROUPS #include #ifdef HAS_UNISTD #include #endif #include #include #include "unixsupport.h" CAMLprim value unix_initgroups(value user, value group) { if (initgroups(String_val(user), Int_val(group)) == -1) { uerror("initgroups", Nothing); } return Val_unit; } #else CAMLprim value unix_initgroups(value user, value group) { invalid_argument("initgroups not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/.depend0000644000175000017500000006540312124403241017704 0ustar tootstootsaccept.o: accept.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ socketaddr.h ../../byterun/misc.h access.o: access.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h unixsupport.h addrofstr.o: addrofstr.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/fail.h ../../byterun/mlvalues.h \ unixsupport.h socketaddr.h ../../byterun/misc.h alarm.o: alarm.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h bind.o: bind.c ../../byterun/fail.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h socketaddr.h \ ../../byterun/misc.h chdir.o: chdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h chmod.o: chmod.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h chown.o: chown.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h chroot.o: chroot.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h close.o: close.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h closedir.o: closedir.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h unixsupport.h connect.o: connect.c ../../byterun/fail.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h ../../byterun/signals.h unixsupport.h \ socketaddr.h ../../byterun/misc.h cst2constr.o: cst2constr.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/fail.h ../../byterun/mlvalues.h \ cst2constr.h cstringv.o: cstringv.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/mlvalues.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h dup.o: dup.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h dup2.o: dup2.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h envir.o: envir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h errmsg.o: errmsg.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h execv.o: execv.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h execve.o: execve.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h execvp.o: execvp.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h exit.o: exit.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h fchmod.o: fchmod.c ../../byterun/fail.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h fchown.o: fchown.c ../../byterun/fail.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h fcntl.o: fcntl.c ../../byterun/fail.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h fork.o: fork.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h \ ../../byterun/debugger.h ../../byterun/mlvalues.h unixsupport.h ftruncate.o: ftruncate.c ../../byterun/fail.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h ../../byterun/io.h unixsupport.h getaddrinfo.o: getaddrinfo.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ cst2constr.h socketaddr.h ../../byterun/misc.h getcwd.o: getcwd.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/fail.h unixsupport.h getegid.o: getegid.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h unixsupport.h geteuid.o: geteuid.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h unixsupport.h getgid.o: getgid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h getgr.o: getgr.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/fail.h \ ../../byterun/mlvalues.h ../../byterun/alloc.h ../../byterun/memory.h \ ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h unixsupport.h getgroups.o: getgroups.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h unixsupport.h gethost.o: gethost.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ socketaddr.h ../../byterun/misc.h gethostname.o: gethostname.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h unixsupport.h getlogin.o: getlogin.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ unixsupport.h getnameinfo.o: getnameinfo.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ socketaddr.h ../../byterun/misc.h getpeername.o: getpeername.c ../../byterun/fail.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h socketaddr.h \ ../../byterun/misc.h getpid.o: getpid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h getppid.o: getppid.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h unixsupport.h getproto.o: getproto.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h unixsupport.h getpw.o: getpw.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h getserv.o: getserv.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h unixsupport.h getsockname.o: getsockname.c ../../byterun/fail.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h socketaddr.h \ ../../byterun/misc.h gettimeofday.o: gettimeofday.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h unixsupport.h getuid.o: getuid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h gmtime.o: gmtime.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h unixsupport.h initgroups.o: initgroups.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h unixsupport.h isatty.o: isatty.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h itimer.o: itimer.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h unixsupport.h kill.o: kill.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/fail.h \ ../../byterun/mlvalues.h unixsupport.h ../../byterun/signals.h link.o: link.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h listen.o: listen.c ../../byterun/fail.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h lockf.o: lockf.c ../../byterun/fail.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h ../../byterun/signals.h unixsupport.h lseek.o: lseek.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/io.h ../../byterun/signals.h \ unixsupport.h mkdir.o: mkdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h mkfifo.o: mkfifo.c ../../byterun/fail.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h nice.o: nice.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h open.o: open.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h opendir.o: opendir.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ unixsupport.h pipe.o: pipe.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h unixsupport.h putenv.o: putenv.c ../../byterun/fail.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h \ ../../byterun/mlvalues.h unixsupport.h read.o: read.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h \ ../../byterun/signals.h unixsupport.h readdir.o: readdir.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/fail.h ../../byterun/mlvalues.h \ ../../byterun/alloc.h unixsupport.h readlink.o: readlink.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h unixsupport.h rename.o: rename.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h rewinddir.o: rewinddir.c ../../byterun/fail.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h rmdir.o: rmdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h select.o: select.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h sendrecv.o: sendrecv.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ socketaddr.h ../../byterun/misc.h setgid.o: setgid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h setgroups.o: setgroups.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h unixsupport.h setsid.o: setsid.c ../../byterun/fail.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h setuid.o: setuid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h shutdown.o: shutdown.c ../../byterun/fail.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h signals.o: signals.c ../../byterun/alloc.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h ../../byterun/mlvalues.h \ ../../byterun/signals.h unixsupport.h sleep.o: sleep.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h \ ../../byterun/signals.h ../../byterun/mlvalues.h unixsupport.h socket.o: socket.c ../../byterun/fail.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h socketaddr.o: socketaddr.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h \ socketaddr.h ../../byterun/misc.h socketpair.o: socketpair.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h unixsupport.h sockopt.o: sockopt.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/mlvalues.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/alloc.h \ ../../byterun/fail.h unixsupport.h socketaddr.h ../../byterun/misc.h stat.o: stat.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/alloc.h \ unixsupport.h cst2constr.h ../../byterun/io.h strofaddr.o: strofaddr.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h unixsupport.h socketaddr.h ../../byterun/misc.h symlink.o: symlink.c ../../byterun/fail.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h termios.o: termios.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h unixsupport.h time.o: time.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h unixsupport.h times.o: times.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h unixsupport.h truncate.o: truncate.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/fail.h ../../byterun/mlvalues.h \ ../../byterun/io.h unixsupport.h umask.o: umask.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h unixsupport.o: unixsupport.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/callback.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h \ cst2constr.h unlink.o: unlink.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h utimes.o: utimes.c ../../byterun/fail.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h wait.o: wait.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h write.o: write.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h \ ../../byterun/signals.h unixsupport.h unix.cmi : unixLabels.cmi : unix.cmi unix.cmo : unix.cmi unix.cmx : unix.cmi unixLabels.cmo : unix.cmi unixLabels.cmi unixLabels.cmx : unix.cmx unixLabels.cmi mingw-ocaml/ocaml/otherlibs/unix/unixsupport.h0000644000175000017500000000231712124403241021230 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifdef HAS_UNISTD #include #endif #define Nothing ((value) 0) extern value unix_error_of_code (int errcode); extern void unix_error (int errcode, char * cmdname, value arg) Noreturn; extern void uerror (char * cmdname, value arg) Noreturn; #define UNIX_BUFFER_SIZE 65536 #define DIR_Val(v) *((DIR **) &Field(v, 0)) mingw-ocaml/ocaml/otherlibs/unix/execv.c0000644000175000017500000000246112124403241017715 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" extern char ** cstringvect(); CAMLprim value unix_execv(value path, value args) { char ** argv; argv = cstringvect(args); (void) execv(String_val(path), argv); stat_free((char *) argv); uerror("execv", path); return Val_unit; /* never reached, but suppress warnings */ /* from smart compilers */ } mingw-ocaml/ocaml/otherlibs/unix/isatty.c0000644000175000017500000000201012124403241020106 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ /* */ /* Copyright 2006 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_isatty(value fd) { return (Val_bool(isatty(Int_val(fd)))); } mingw-ocaml/ocaml/otherlibs/unix/socketpair.c0000644000175000017500000000312112124403241020741 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include extern int socket_domain_table[], socket_type_table[]; CAMLprim value unix_socketpair(value domain, value type, value proto) { int sv[2]; value res; if (socketpair(socket_domain_table[Int_val(domain)], socket_type_table[Int_val(type)], Int_val(proto), sv) == -1) uerror("socketpair", Nothing); res = alloc_small(2, 0); Field(res,0) = Val_int(sv[0]); Field(res,1) = Val_int(sv[1]); return res; } #else CAMLprim value unix_socketpair(value domain, value type, value proto) { invalid_argument("socketpair not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/lseek.c0000644000175000017500000000416012124403241017704 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include #include "unixsupport.h" #ifdef HAS_UNISTD #include #else #define SEEK_SET 0 #define SEEK_CUR 1 #define SEEK_END 2 #endif #ifndef EOVERFLOW #define EOVERFLOW ERANGE #endif static int seek_command_table[] = { SEEK_SET, SEEK_CUR, SEEK_END }; CAMLprim value unix_lseek(value fd, value ofs, value cmd) { file_offset ret; caml_enter_blocking_section(); ret = lseek(Int_val(fd), Long_val(ofs), seek_command_table[Int_val(cmd)]); caml_leave_blocking_section(); if (ret == -1) uerror("lseek", Nothing); if (ret > Max_long) unix_error(EOVERFLOW, "lseek", Nothing); return Val_long(ret); } CAMLprim value unix_lseek_64(value fd, value ofs, value cmd) { file_offset ret; /* [ofs] is an Int64, which is stored as a custom block; we must therefore extract its contents before dropping the runtime lock, or it might be moved. */ file_offset ofs_c = File_offset_val(ofs); caml_enter_blocking_section(); ret = lseek(Int_val(fd), ofs_c, seek_command_table[Int_val(cmd)]); caml_leave_blocking_section(); if (ret == -1) uerror("lseek", Nothing); return Val_file_offset(ret); } mingw-ocaml/ocaml/otherlibs/unix/gethost.c0000644000175000017500000001177012124403241020263 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include "socketaddr.h" #ifndef _WIN32 #include #include #endif #define NETDB_BUFFER_SIZE 10000 #ifdef _WIN32 #define GETHOSTBYADDR_IS_REENTRANT 1 #define GETHOSTBYNAME_IS_REENTRANT 1 #endif static int entry_h_length; extern int socket_domain_table[]; static value alloc_one_addr(char const *a) { struct in_addr addr; #ifdef HAS_IPV6 struct in6_addr addr6; if (entry_h_length == 16) { memmove(&addr6, a, 16); return alloc_inet6_addr(&addr6); } #endif memmove (&addr, a, 4); return alloc_inet_addr(&addr); } static value alloc_host_entry(struct hostent *entry) { value res; value name = Val_unit, aliases = Val_unit; value addr_list = Val_unit, adr = Val_unit; Begin_roots4 (name, aliases, addr_list, adr); name = copy_string((char *)(entry->h_name)); /* PR#4043: protect against buggy implementations of gethostbyname() that return a NULL pointer in h_aliases */ if (entry->h_aliases) aliases = copy_string_array((const char**)entry->h_aliases); else aliases = Atom(0); entry_h_length = entry->h_length; #ifdef h_addr addr_list = alloc_array(alloc_one_addr, (const char**)entry->h_addr_list); #else adr = alloc_one_addr(entry->h_addr); addr_list = alloc_small(1, 0); Field(addr_list, 0) = adr; #endif res = alloc_small(4, 0); Field(res, 0) = name; Field(res, 1) = aliases; switch (entry->h_addrtype) { case PF_UNIX: Field(res, 2) = Val_int(0); break; case PF_INET: Field(res, 2) = Val_int(1); break; default: /*PF_INET6 */ Field(res, 2) = Val_int(2); break; } Field(res, 3) = addr_list; End_roots(); return res; } CAMLprim value unix_gethostbyaddr(value a) { struct in_addr adr = GET_INET_ADDR(a); struct hostent * hp; #if HAS_GETHOSTBYADDR_R == 7 struct hostent h; char buffer[NETDB_BUFFER_SIZE]; int h_errnop; enter_blocking_section(); hp = gethostbyaddr_r((char *) &adr, 4, AF_INET, &h, buffer, sizeof(buffer), &h_errnop); leave_blocking_section(); #elif HAS_GETHOSTBYADDR_R == 8 struct hostent h; char buffer[NETDB_BUFFER_SIZE]; int h_errnop, rc; enter_blocking_section(); rc = gethostbyaddr_r((char *) &adr, 4, AF_INET, &h, buffer, sizeof(buffer), &hp, &h_errnop); leave_blocking_section(); if (rc != 0) hp = NULL; #else #ifdef GETHOSTBYADDR_IS_REENTRANT enter_blocking_section(); #endif hp = gethostbyaddr((char *) &adr, 4, AF_INET); #ifdef GETHOSTBYADDR_IS_REENTRANT leave_blocking_section(); #endif #endif if (hp == (struct hostent *) NULL) raise_not_found(); return alloc_host_entry(hp); } CAMLprim value unix_gethostbyname(value name) { struct hostent * hp; char * hostname; #if HAS_GETHOSTBYNAME_R || GETHOSTBYNAME_IS_REENTRANT hostname = stat_alloc(string_length(name) + 1); strcpy(hostname, String_val(name)); #else hostname = String_val(name); #endif #if HAS_GETHOSTBYNAME_R == 5 { struct hostent h; char buffer[NETDB_BUFFER_SIZE]; int h_errno; enter_blocking_section(); hp = gethostbyname_r(hostname, &h, buffer, sizeof(buffer), &h_errno); leave_blocking_section(); } #elif HAS_GETHOSTBYNAME_R == 6 { struct hostent h; char buffer[NETDB_BUFFER_SIZE]; int h_errno, rc; enter_blocking_section(); rc = gethostbyname_r(hostname, &h, buffer, sizeof(buffer), &hp, &h_errno); leave_blocking_section(); if (rc != 0) hp = NULL; } #else #ifdef GETHOSTBYNAME_IS_REENTRANT enter_blocking_section(); #endif hp = gethostbyname(hostname); #ifdef GETHOSTBYNAME_IS_REENTRANT leave_blocking_section(); #endif #endif #if HAS_GETHOSTBYNAME_R || GETHOSTBYNAME_IS_REENTRANT stat_free(hostname); #endif if (hp == (struct hostent *) NULL) raise_not_found(); return alloc_host_entry(hp); } #else CAMLprim value unix_gethostbyaddr(value name) { invalid_argument("gethostbyaddr not implemented"); } CAMLprim value unix_gethostbyname(value name) { invalid_argument("gethostbyname not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/cst2constr.h0000644000175000017500000000171012124403241020710 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ extern value cst_to_constr(int n, int * tbl, int size, int deflt); mingw-ocaml/ocaml/otherlibs/unix/dup2.c0000644000175000017500000000270712124403241017460 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" #ifdef HAS_DUP2 CAMLprim value unix_dup2(value fd1, value fd2) { if (dup2(Int_val(fd1), Int_val(fd2)) == -1) uerror("dup2", Nothing); return Val_unit; } #else static int do_dup2(int fd1, int fd2) { int fd; int res; fd = dup(fd1); if (fd == -1) return -1; if (fd == fd2) return 0; res = do_dup2(fd1, fd2); close(fd); return res; } CAMLprim value unix_dup2(value fd1, value fd2) { close(Int_val(fd2)); if (do_dup2(Int_val(fd1), Int_val(fd2)) == -1) uerror("dup2", Nothing); return Val_unit; } #endif mingw-ocaml/ocaml/otherlibs/unix/getproto.c0000644000175000017500000000417312124403241020450 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #ifndef _WIN32 #include #else #include #endif static value alloc_proto_entry(struct protoent *entry) { value res; value name = Val_unit, aliases = Val_unit; Begin_roots2 (name, aliases); name = copy_string(entry->p_name); aliases = copy_string_array((const char**)entry->p_aliases); res = alloc_small(3, 0); Field(res,0) = name; Field(res,1) = aliases; Field(res,2) = Val_int(entry->p_proto); End_roots(); return res; } CAMLprim value unix_getprotobyname(value name) { struct protoent * entry; entry = getprotobyname(String_val(name)); if (entry == (struct protoent *) NULL) raise_not_found(); return alloc_proto_entry(entry); } CAMLprim value unix_getprotobynumber(value proto) { struct protoent * entry; entry = getprotobynumber(Int_val(proto)); if (entry == (struct protoent *) NULL) raise_not_found(); return alloc_proto_entry(entry); } #else CAMLprim value unix_getprotobynumber(value proto) { invalid_argument("getprotobynumber not implemented"); } CAMLprim value unix_getprotobyname(value name) { invalid_argument("getprotobyname not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/getsockname.c0000644000175000017500000000264012124403241021102 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS #include "socketaddr.h" CAMLprim value unix_getsockname(value sock) { int retcode; union sock_addr_union addr; socklen_param_type addr_len; addr_len = sizeof(addr); retcode = getsockname(Int_val(sock), &addr.s_gen, &addr_len); if (retcode == -1) uerror("getsockname", Nothing); return alloc_sockaddr(&addr, addr_len, -1); } #else CAMLprim value unix_getsockname(value sock) { invalid_argument("getsockname not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/unix/chown.c0000644000175000017500000000217012124403241017716 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_chown(value path, value uid, value gid) { int ret; ret = chown(String_val(path), Int_val(uid), Int_val(gid)); if (ret == -1) uerror("chown", path); return Val_unit; } mingw-ocaml/ocaml/otherlibs/unix/wait.c0000644000175000017500000000577412124403241017561 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include "unixsupport.h" #include #include #if !(defined(WIFEXITED) && defined(WEXITSTATUS) && defined(WIFSTOPPED) && \ defined(WSTOPSIG) && defined(WTERMSIG)) /* Assume old-style V7 status word */ #define WIFEXITED(status) (((status) & 0xFF) == 0) #define WEXITSTATUS(status) (((status) >> 8) & 0xFF) #define WIFSTOPPED(status) (((status) & 0xFF) == 0xFF) #define WSTOPSIG(status) (((status) >> 8) & 0xFF) #define WTERMSIG(status) ((status) & 0x3F) #endif #define TAG_WEXITED 0 #define TAG_WSIGNALED 1 #define TAG_WSTOPPED 2 static value alloc_process_status(int pid, int status) { value st, res; if (WIFEXITED(status)) { st = alloc_small(1, TAG_WEXITED); Field(st, 0) = Val_int(WEXITSTATUS(status)); } else if (WIFSTOPPED(status)) { st = alloc_small(1, TAG_WSTOPPED); Field(st, 0) = Val_int(caml_rev_convert_signal_number(WSTOPSIG(status))); } else { st = alloc_small(1, TAG_WSIGNALED); Field(st, 0) = Val_int(caml_rev_convert_signal_number(WTERMSIG(status))); } Begin_root (st); res = alloc_small(2, 0); Field(res, 0) = Val_int(pid); Field(res, 1) = st; End_roots(); return res; } CAMLprim value unix_wait(value unit) { int pid, status; enter_blocking_section(); pid = wait(&status); leave_blocking_section(); if (pid == -1) uerror("wait", Nothing); return alloc_process_status(pid, status); } #if defined(HAS_WAITPID) || defined(HAS_WAIT4) #ifndef HAS_WAITPID #define waitpid(pid,status,opts) wait4(pid,status,opts,NULL) #endif static int wait_flag_table[] = { WNOHANG, WUNTRACED }; CAMLprim value unix_waitpid(value flags, value pid_req) { int pid, status, cv_flags; cv_flags = convert_flag_list(flags, wait_flag_table); enter_blocking_section(); pid = waitpid(Int_val(pid_req), &status, cv_flags); leave_blocking_section(); if (pid == -1) uerror("waitpid", Nothing); return alloc_process_status(pid, status); } #else CAMLprim value unix_waitpid(value flags, value pid_req) { invalid_argument("waitpid not implemented"); } #endif mingw-ocaml/ocaml/otherlibs/win32graph/0000755000175000017500000000000012124403241017435 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/win32graph/.ignore0000644000175000017500000000003112124403241020713 0ustar tootstootsgraphics.ml graphics.mli mingw-ocaml/ocaml/otherlibs/win32graph/dib.c0000644000175000017500000003750712124403241020353 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Developed by Jacob Navia */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ //----------------------------------------------------------------------------- // DIB.C // // This is a collection of useful DIB manipulation/information gathering // functions. Many functions are supplied simply to take the burden // of taking into account whether a DIB is a Win30 style or OS/2 style // DIB away from the application. // // The functions in this module assume that the DIB pointers or handles // passed to them point to a block of memory in one of two formats: // // a) BITMAPINFOHEADER + color table + DIB bits (3.0 style DIB) // b) BITMAPCOREHEADER + color table + DIB bits (OS/2 PM style) // // The SDK Reference, Volume 2 describes these data structures. // // A number of functions in this module were lifted from SHOWDIB, // and modified to handle OS/2 DIBs. // // The functions in this module could be streamlined (made faster and // smaller) by removing the OS/2 DIB specific code, and assuming all // DIBs passed to it are Win30 style DIBs. The DIB file reading code // would need to be modified to always convert DIBs to Win30 style // DIBs. The only reason this isn't done in DIBView is because DIBView // was written to test display and printer drivers (which are supposed // to support OS/2 DIBs wherever they support Win30 style DIBs). SHOWDIB // is a great example of how to go about doing this. //----------------------------------------------------------------------------- #include #include #include #include #include // Size of window extra bytes (we store a handle to a PALINFO structure). #define PAL_CBWNDEXTRA (1 * sizeof (WORD)) typedef struct { HPALETTE hPal; // Handle to palette being displayed. WORD wEntries; // # of entries in the palette. int nSquareSize; // Size of palette square (see PAL_SIZE) HWND hInfoWnd; // Handle to the info bar window. int nRows, nCols; // # of Rows/Columns in window. int cxSquare, cySquare; // Pixel width/height of palette square. WORD wEntry; // Currently selected palette square. } PALINFO, FAR *LPPALINFO; // Window Words. #define WW_PAL_HPALINFO 0 // Handle to PALINFO structure. // The following define is for CopyPaletteChangingFlags(). #define DONT_CHANGE_FLAGS -1 // The following is the palette version that goes in a // LOGPALETTE's palVersion field. #define PALVERSION 0x300 // This is an enumeration for the various ways we can display // a palette in PaletteWndProc(). enum PAL_SIZE { PALSIZE_TINY = 0, PALSIZE_SMALL, PALSIZE_MEDIUM, PALSIZE_LARGE }; #define CopyPalette(hPal) CopyPaletteChangingFlags (hPal, DONT_CHANGE_FLAGS) #define CopyPalForAnimation(hPal) CopyPaletteChangingFlags (hPal, PC_RESERVED) // WIDTHBYTES takes # of bits in a scan line and rounds up to nearest // word. #define WIDTHBYTES(bits) (((bits) + 31) / 32 * 4) // Given a pointer to a DIB header, return TRUE if is a Windows 3.0 style // DIB, false if otherwise (PM style DIB). #define IS_WIN30_DIB(lpbi) ((*(LPDWORD) (lpbi)) == sizeof (BITMAPINFOHEADER)) static WORD PaletteSize (LPSTR lpbi); extern void ShowDbgMsg(char *); static BOOL MyRead (int, LPSTR, DWORD); /*-------------- DIB header Marker Define -------------------------*/ #define DIB_HEADER_MARKER ((WORD) ('M' << 8) | 'B') /*-------------- MyRead Function Define ---------------------------*/ // When we read in a DIB, we read it in in chunks. We read half a segment // at a time. This way we insure that we don't cross any segment // boundries in _lread() during a read. We don't read in a full segment // at a time, since _lread takes some "int" type parms instead of // WORD type params (it'd work, but the compiler would give you warnings)... #define BYTES_PER_READ 32767 /*-------------- Define for PM DIB -------------------------------*/ // The constants for RGB, RLE4, RLE8 are already defined inside // of Windows.h #define BI_PM 3L /*-------------- Magic numbers -------------------------------------*/ // Maximum length of a filename for DOS is 128 characters. #define MAX_FILENAME 129 /*-------------- TypeDef Structures -------------------------------*/ typedef struct InfoStruct { char szName[13]; char szType[15]; DWORD cbWidth; DWORD cbHeight; DWORD cbColors; char szCompress[5]; } INFOSTRUCT; // Some macros. #define RECTWIDTH(lpRect) ((lpRect)->right - (lpRect)->left) #define RECTHEIGHT(lpRect) ((lpRect)->bottom - (lpRect)->top) //--------------------------------------------------------------------- // // Function: FindDIBBits // // Purpose: Given a pointer to a DIB, returns a pointer to the // DIB's bitmap bits. // // Parms: lpbi == pointer to DIB header (either BITMAPINFOHEADER // or BITMAPCOREHEADER) // // History: Date Reason // 6/01/91 Created // //--------------------------------------------------------------------- static LPSTR FindDIBBits (LPSTR lpbi) { return (lpbi + *(LPDWORD)lpbi + PaletteSize (lpbi)); } //--------------------------------------------------------------------- // // Function: DIBNumColors // // Purpose: Given a pointer to a DIB, returns a number of colors in // the DIB's color table. // // Parms: lpbi == pointer to DIB header (either BITMAPINFOHEADER // or BITMAPCOREHEADER) // // History: Date Reason // 6/01/91 Created // //--------------------------------------------------------------------- static WORD DIBNumColors (LPSTR lpbi) { WORD wBitCount; // If this is a Windows style DIB, the number of colors in the // color table can be less than the number of bits per pixel // allows for (i.e. lpbi->biClrUsed can be set to some value). // If this is the case, return the appropriate value. if (IS_WIN30_DIB (lpbi)) { DWORD dwClrUsed; dwClrUsed = ((LPBITMAPINFOHEADER) lpbi)->biClrUsed; if (dwClrUsed) return (WORD) dwClrUsed; } // Calculate the number of colors in the color table based on // the number of bits per pixel for the DIB. if (IS_WIN30_DIB (lpbi)) wBitCount = ((LPBITMAPINFOHEADER) lpbi)->biBitCount; else wBitCount = ((LPBITMAPCOREHEADER) lpbi)->bcBitCount; switch (wBitCount) { case 1: return 2; case 4: return 16; case 8: return 256; default: return 0; } } //--------------------------------------------------------------------- // // Function: PaletteSize // // Purpose: Given a pointer to a DIB, returns number of bytes // in the DIB's color table. // // Parms: lpbi == pointer to DIB header (either BITMAPINFOHEADER // or BITMAPCOREHEADER) // // History: Date Reason // 6/01/91 Created // //--------------------------------------------------------------------- static WORD PaletteSize (LPSTR lpbi) { if (IS_WIN30_DIB (lpbi)) return (DIBNumColors (lpbi) * sizeof (RGBQUAD)); else return (DIBNumColors (lpbi) * sizeof (RGBTRIPLE)); } //--------------------------------------------------------------------- // // Function: DIBHeight // // Purpose: Given a pointer to a DIB, returns its height. Note // that it returns a DWORD (since a Win30 DIB can have // a DWORD in its height field), but under Win30, the // high order word isn't used! // // Parms: lpDIB == pointer to DIB header (either BITMAPINFOHEADER // or BITMAPCOREHEADER) // // History: Date Reason // 6/01/91 Created // //--------------------------------------------------------------------- static DWORD DIBHeight (LPSTR lpDIB) { LPBITMAPINFOHEADER lpbmi; LPBITMAPCOREHEADER lpbmc; lpbmi = (LPBITMAPINFOHEADER) lpDIB; lpbmc = (LPBITMAPCOREHEADER) lpDIB; if (lpbmi->biSize == sizeof (BITMAPINFOHEADER)) return lpbmi->biHeight; else return (DWORD) lpbmc->bcHeight; } /************************************************************************* Function: ReadDIBFile (int) Purpose: Reads in the specified DIB file into a global chunk of memory. Returns: A handle to a dib (hDIB) if successful. NULL if an error occurs. Comments: BITMAPFILEHEADER is stripped off of the DIB. Everything from the end of the BITMAPFILEHEADER structure on is returned in the global memory handle. History: Date Author Reason 6/1/91 Created 6/27/91 Removed PM bitmap conversion routines. 6/31/91 Removed logic which overallocated memory (to account for bad display drivers). 11/08/91 Again removed logic which overallocated memory (it had creeped back in!) *************************************************************************/ static HANDLE ReadDIBFile (int hFile,int dwBitsSize) { BITMAPFILEHEADER bmfHeader; HANDLE hDIB; LPSTR pDIB; // Go read the DIB file header and check if it's valid. if ((_lread (hFile, (LPSTR) &bmfHeader, sizeof (bmfHeader)) != sizeof (bmfHeader)) || (bmfHeader.bfType != DIB_HEADER_MARKER)) { // ShowDbgMsg("Not a DIB file!"); return NULL; } // Allocate memory for DIB hDIB = GlobalAlloc (GMEM_SHARE|GMEM_MOVEABLE | GMEM_ZEROINIT, dwBitsSize - sizeof(BITMAPFILEHEADER)); if (hDIB == 0) { // ShowDbgMsg("Couldn't allocate memory!"); return NULL; } pDIB = GlobalLock (hDIB); // Go read the bits. if (!MyRead (hFile, pDIB, dwBitsSize - sizeof(BITMAPFILEHEADER))) { GlobalUnlock (hDIB); GlobalFree (hDIB); // ShowDbgMsg("Error reading file!"); return NULL; } GlobalUnlock (hDIB); return hDIB; } /************************************************************************* Function: MyRead (int, LPSTR, DWORD) Purpose: Routine to read files greater than 64K in size. Returns: TRUE if successful. FALSE if an error occurs. Comments: History: Date Reason 6/1/91 Created *************************************************************************/ static BOOL MyRead (int hFile, LPSTR lpBuffer, DWORD dwSize) { char *lpInBuf = (char *) lpBuffer; int nBytes; while (dwSize) { nBytes = (int) (dwSize > (DWORD) BYTES_PER_READ ? BYTES_PER_READ : LOWORD (dwSize)); if (_lread (hFile, (LPSTR) lpInBuf, nBytes) != (WORD) nBytes) return FALSE; dwSize -= nBytes; lpInBuf += nBytes; } return TRUE; } //--------------------------------------------------------------------- // // Function: DIBPaint // // Purpose: Painting routine for a DIB. Calls StretchDIBits() or // SetDIBitsToDevice() to paint the DIB. The DIB is // output to the specified DC, at the coordinates given // in lpDCRect. The area of the DIB to be output is // given by lpDIBRect. The specified palette is used. // // Parms: hDC == DC to do output to. // lpDCRect == Rectangle on DC to do output to. // hDIB == Handle to global memory with a DIB spec // in it (either a BITMAPINFO or BITMAPCOREINFO // followed by the DIB bits). // lpDIBRect == Rect of DIB to output into lpDCRect. // hPal == Palette to be used. // // History: Date Reason // 6/01/91 Created // //--------------------------------------------------------------------- static void DIBPaint (HDC hDC,LPRECT lpDCRect,HANDLE hDIB) { LPSTR lpDIBHdr, lpDIBBits; if (!hDIB) return; // Lock down the DIB, and get a pointer to the beginning of the bit // buffer. lpDIBHdr = GlobalLock (hDIB); lpDIBBits = FindDIBBits (lpDIBHdr); // Make sure to use the stretching mode best for color pictures. SetStretchBltMode (hDC, COLORONCOLOR); SetDIBitsToDevice (hDC, // hDC lpDCRect->left, // DestX lpDCRect->top, // DestY RECTWIDTH (lpDCRect), // nDestWidth RECTHEIGHT (lpDCRect), // nDestHeight 0, // SrcX 0, // (int) DIBHeight (lpDIBHdr), // SrcY 0, // nStartScan (WORD) DIBHeight (lpDIBHdr), // nNumScans lpDIBBits, // lpBits (LPBITMAPINFO) lpDIBHdr, // lpBitsInfo DIB_RGB_COLORS); // wUsage GlobalUnlock (hDIB); } static unsigned int Getfilesize(char *name) { FILE *f; unsigned int size; f = fopen(name,"rb"); if (f == NULL) return 0; fseek(f,0,SEEK_END); size = ftell(f); fclose(f); return size; } HANDLE ChargerBitmap(char *FileName,POINT *lppt) { HFILE hFile; OFSTRUCT ofstruct; HANDLE result; LPSTR lpDIBHdr; unsigned int size; size = Getfilesize(FileName); hFile=OpenFile((LPSTR) FileName, &ofstruct, OF_READ | OF_SHARE_DENY_WRITE); result = ReadDIBFile(hFile,size); if (hFile) _lclose(hFile); if (result) { LPBITMAPINFOHEADER lpbmi; LPBITMAPCOREHEADER lpbmc; lpDIBHdr = GlobalLock (result); lpbmi = (LPBITMAPINFOHEADER) lpDIBHdr; lpbmc = (LPBITMAPCOREHEADER) lpDIBHdr; if (lpbmi->biSize == sizeof (BITMAPINFOHEADER)) { lppt->y = lpbmi->biHeight; lppt->x = lpbmi->biWidth; } else { lppt->y = lpbmc->bcHeight; lppt->x = lpbmc->bcWidth; } GlobalUnlock(result); } return(result); } void DessinerBitmap(HANDLE hDIB,HDC hDC,LPRECT lpDCRect) { DIBPaint (hDC, lpDCRect, hDIB); } void AfficheBitmap(char *filename,HDC hDC,int x,int y) { RECT rc; HANDLE hdib; POINT pt; char titi[60]; hdib = ChargerBitmap(filename,&pt); if (hdib == NULL) { return; } rc.top = y; rc.left = x; rc.right = pt.x+x; rc.bottom = pt.y+y; pt.y += GetSystemMetrics(SM_CYCAPTION); DessinerBitmap(hdib,hDC,&rc); GlobalFree(hdib); } mingw-ocaml/ocaml/otherlibs/win32graph/events.c0000755000175000017500000001414212124403241021112 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2004 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "mlvalues.h" #include "alloc.h" #include "libgraph.h" #include enum { EVENT_BUTTON_DOWN = 1, EVENT_BUTTON_UP = 2, EVENT_KEY_PRESSED = 4, EVENT_MOUSE_MOTION = 8 }; struct event_data { short mouse_x, mouse_y; unsigned char kind; unsigned char button; unsigned char key; }; static struct event_data caml_gr_queue[SIZE_QUEUE]; static unsigned int caml_gr_head = 0; /* position of next read */ static unsigned int caml_gr_tail = 0; /* position of next write */ static int caml_gr_event_mask = EVENT_KEY_PRESSED; static int last_button = 0; static LPARAM last_pos = 0; HANDLE caml_gr_queue_semaphore = NULL; CRITICAL_SECTION caml_gr_queue_mutex; void caml_gr_init_event_queue(void) { if (caml_gr_queue_semaphore == NULL) { caml_gr_queue_semaphore = CreateSemaphore(NULL, 0, SIZE_QUEUE, NULL); InitializeCriticalSection(&caml_gr_queue_mutex); } } #define QueueIsEmpty (caml_gr_tail == caml_gr_head) static void caml_gr_enqueue_event(int kind, LPARAM mouse_xy, int button, int key) { struct event_data * ev; if ((caml_gr_event_mask & kind) == 0) return; EnterCriticalSection(&caml_gr_queue_mutex); ev = &(caml_gr_queue[caml_gr_tail]); ev->kind = kind; ev->mouse_x = GET_X_LPARAM(mouse_xy); ev->mouse_y = GET_Y_LPARAM(mouse_xy); ev->button = (button != 0); ev->key = key; caml_gr_tail = (caml_gr_tail + 1) % SIZE_QUEUE; /* If queue was full, it now appears empty; drop oldest entry from queue. */ if (QueueIsEmpty) { caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE; } else { /* One more event in queue */ ReleaseSemaphore(caml_gr_queue_semaphore, 1, NULL); } LeaveCriticalSection(&caml_gr_queue_mutex); } void caml_gr_handle_event(UINT msg, WPARAM wParam, LPARAM lParam) { switch (msg) { case WM_LBUTTONDOWN: case WM_RBUTTONDOWN: case WM_MBUTTONDOWN: last_button = 1; last_pos = lParam; caml_gr_enqueue_event(EVENT_BUTTON_DOWN, lParam, 1, 0); break; case WM_LBUTTONUP: case WM_RBUTTONUP: case WM_MBUTTONUP: last_button = 0; last_pos = lParam; caml_gr_enqueue_event(EVENT_BUTTON_UP, lParam, 0, 0); break; case WM_CHAR: caml_gr_enqueue_event(EVENT_KEY_PRESSED, last_pos, last_button, wParam); break; case WM_MOUSEMOVE: last_pos = lParam; caml_gr_enqueue_event(EVENT_MOUSE_MOTION, lParam, last_button, 0); break; } } static value caml_gr_wait_allocate_result(int mouse_x, int mouse_y, int button, int keypressed, int key) { value res = alloc_small(5, 0); Field(res, 0) = Val_int(mouse_x); Field(res, 1) = Val_int(grwindow.height - 1 - mouse_y); Field(res, 2) = Val_bool(button); Field(res, 3) = Val_bool(keypressed); Field(res, 4) = Val_int(key & 0xFF); return res; } static value caml_gr_wait_event_poll(void) { int key, keypressed, i; /* Look inside event queue for pending KeyPress events */ EnterCriticalSection(&caml_gr_queue_mutex); key = 0; keypressed = 0; for (i = caml_gr_head; i != caml_gr_tail; i = (i + 1) % SIZE_QUEUE) { if (caml_gr_queue[i].kind == EVENT_KEY_PRESSED) { keypressed = 1; key = caml_gr_queue[i].key; break; } } LeaveCriticalSection(&caml_gr_queue_mutex); /* Use global vars for mouse position and buttons */ return caml_gr_wait_allocate_result(GET_X_LPARAM(last_pos), GET_Y_LPARAM(last_pos), last_button, keypressed, key); } static value caml_gr_wait_event_blocking(int mask) { struct event_data ev; /* Increase the selected events if needed */ caml_gr_event_mask |= mask; /* Pop events from queue until one matches */ do { /* Wait for event queue to be non-empty */ WaitForSingleObject(caml_gr_queue_semaphore, INFINITE); /* Pop oldest event in queue */ EnterCriticalSection(&caml_gr_queue_mutex); ev = caml_gr_queue[caml_gr_head]; /* Queue should never be empty at this point, but just in case... */ if (QueueIsEmpty) { ev.kind = 0; } else { caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE; } LeaveCriticalSection(&caml_gr_queue_mutex); /* Check if it matches */ } while ((ev.kind & mask) == 0); return caml_gr_wait_allocate_result(ev.mouse_x, ev.mouse_y, ev.button, ev.kind == EVENT_KEY_PRESSED, ev.key); } CAMLprim value caml_gr_wait_event(value eventlist) /* ML */ { int mask, poll; gr_check_open(); mask = 0; poll = 0; while (eventlist != Val_int(0)) { switch (Int_val(Field(eventlist, 0))) { case 0: /* Button_down */ mask |= EVENT_BUTTON_DOWN; break; case 1: /* Button_up */ mask |= EVENT_BUTTON_UP; break; case 2: /* Key_pressed */ mask |= EVENT_KEY_PRESSED; break; case 3: /* Mouse_motion */ mask |= EVENT_MOUSE_MOTION; break; case 4: /* Poll */ poll = 1; break; } eventlist = Field(eventlist, 1); } if (poll) return caml_gr_wait_event_poll(); else return caml_gr_wait_event_blocking(mask); } mingw-ocaml/ocaml/otherlibs/win32graph/Makefile.nt0000644000175000017500000000257312124403241021524 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 2001 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ LIBNAME=graphics COBJS=open.$(O) draw.$(O) events.$(O) dib.$(O) CAMLOBJS=graphics.cmo WIN32LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,gdi32) $(call SYSLIB,user32) LINKOPTS=-cclib "\"$(WIN32LIBS)\"" LDOPTS=-ldopt "$(WIN32LIBS)" include ../Makefile.nt graphics.ml: ../graph/graphics.ml cp ../graph/graphics.ml graphics.ml graphics.mli: ../graph/graphics.mli cp ../graph/graphics.mli graphics.mli depend: graphics.cmo: graphics.cmi graphics.cmx: graphics.cmi draw.$(O): libgraph.h open.$(O): libgraph.h mingw-ocaml/ocaml/otherlibs/win32graph/open.c0000644000175000017500000002475612124403241020560 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Developed by Jacob Navia, based on code by J-M Geffroy and X Leroy */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "mlvalues.h" #include "fail.h" #include "libgraph.h" #include "callback.h" #include static value gr_reset(void); static long tid; static HANDLE threadHandle; HWND grdisplay = NULL; int grscreen; COLORREF grwhite, grblack; COLORREF grbackground; int grCurrentColor; struct canvas grbstore; BOOL grdisplay_mode; BOOL grremember_mode; int grx, gry; int grcolor; extern HFONT * grfont; MSG msg; static char *szOcamlWindowClass = "OcamlWindowClass"; static BOOL gr_initialized = 0; CAMLprim value caml_gr_clear_graph(void); HANDLE hInst; HFONT CreationFont(char *name) { LOGFONT CurrentFont; memset(&CurrentFont, 0, sizeof(LOGFONT)); CurrentFont.lfCharSet = ANSI_CHARSET; CurrentFont.lfWeight = FW_NORMAL; CurrentFont.lfHeight = grwindow.CurrentFontSize; CurrentFont.lfPitchAndFamily = (BYTE) (FIXED_PITCH | FF_MODERN); strcpy(CurrentFont.lfFaceName, name); /* Courier */ return (CreateFontIndirect(&CurrentFont)); } void SetCoordinates(HWND hwnd) { RECT rc; GetClientRect(hwnd,&rc); grwindow.width = rc.right; grwindow.height = rc.bottom; gr_reset(); } void ResetForClose(HWND hwnd) { DeleteDC(grwindow.tempDC); DeleteDC(grwindow.gcBitmap); DeleteObject(grwindow.hBitmap); memset(&grwindow,0,sizeof(grwindow)); gr_initialized = 0; } static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam) { PAINTSTRUCT ps; HDC hdc; switch (msg) { // Create the MDI client invisible window case WM_CREATE: break; case WM_PAINT: hdc = BeginPaint(hwnd,&ps); BitBlt(hdc,0,0,grwindow.width,grwindow.height, grwindow.gcBitmap,0,0,SRCCOPY); EndPaint(hwnd,&ps); break; // Move the child windows case WM_SIZE: // Position the MDI client window between the tool and status bars if (wParam != SIZE_MINIMIZED) { SetCoordinates(hwnd); } return 0; // End application case WM_DESTROY: ResetForClose(hwnd); break; } caml_gr_handle_event(msg, wParam, lParam); return DefWindowProc(hwnd, msg, wParam, lParam); } int DoRegisterClass(void) { WNDCLASS wc; memset(&wc,0,sizeof(WNDCLASS)); wc.style = CS_HREDRAW|CS_VREDRAW |CS_DBLCLKS|CS_OWNDC ; wc.lpfnWndProc = (WNDPROC)GraphicsWndProc; wc.hInstance = hInst; wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1); wc.lpszClassName = szOcamlWindowClass; wc.lpszMenuName = 0; wc.hCursor = LoadCursor(NULL,IDC_ARROW); wc.hIcon = 0; return RegisterClass(&wc); } static value gr_reset(void) { RECT rc; int screenx,screeny; screenx = GetSystemMetrics(SM_CXSCREEN); screeny = GetSystemMetrics(SM_CYSCREEN); GetClientRect(grwindow.hwnd,&rc); grwindow.gc = GetDC(grwindow.hwnd); grwindow.width = rc.right; grwindow.height = rc.bottom; if (grwindow.gcBitmap == (HDC)0) { grwindow.hBitmap = CreateCompatibleBitmap(grwindow.gc,screenx,screeny); grwindow.gcBitmap = CreateCompatibleDC(grwindow.gc); grwindow.tempDC = CreateCompatibleDC(grwindow.gc); SelectObject(grwindow.gcBitmap,grwindow.hBitmap); SetMapMode(grwindow.gcBitmap,MM_TEXT); MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0); BitBlt(grwindow.gcBitmap,0,0,screenx,screeny, grwindow.gcBitmap,0,0,WHITENESS); grwindow.CurrentFontSize = 15; grwindow.CurrentFont = CreationFont("Courier"); } grwindow.CurrentColor = GetSysColor(COLOR_WINDOWTEXT); grwindow.grx = 0; grwindow.gry = 0; grwindow.CurrentPen = SelectObject(grwindow.gc,GetStockObject(WHITE_PEN)); SelectObject(grwindow.gc,grwindow.CurrentPen); SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); grwindow.CurrentBrush = SelectObject(grwindow.gc,GetStockObject(WHITE_BRUSH)); SelectObject(grwindow.gc,grwindow.CurrentBrush); SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); caml_gr_set_color(Val_long(0)); SelectObject(grwindow.gc,grwindow.CurrentFont); SelectObject(grwindow.gcBitmap,grwindow.CurrentFont); grdisplay_mode = grremember_mode = 1; MoveToEx(grwindow.gc,0,grwindow.height-1,0); MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0); SetTextAlign(grwindow.gcBitmap,TA_BOTTOM); SetTextAlign(grwindow.gc,TA_BOTTOM); return Val_unit; } void SuspendGraphicThread(void) { SuspendThread(threadHandle); } void ResumeGraphicThread(void) { ResumeThread(threadHandle); } /* For handshake between the event handling thread and the main thread */ static char * open_graph_errmsg; static HANDLE open_graph_event; static DWORD WINAPI gr_open_graph_internal(value arg) { RECT rc; int ret; int event; int x, y, w, h; int screenx,screeny; int attributes; static int registered; MSG msg; gr_initialized = TRUE; hInst = GetModuleHandle(NULL); x = y = w = h = CW_USEDEFAULT; sscanf(String_val(arg), "%dx%d+%d+%d", &w, &h, &x, &y); /* Open the display */ if (grwindow.hwnd == NULL || !IsWindow(grwindow.hwnd)) { if (!registered) { registered = DoRegisterClass(); if (!registered) { open_graph_errmsg = "Cannot register the window class"; SetEvent(open_graph_event); return 1; } } grwindow.hwnd = CreateWindow(szOcamlWindowClass, WINDOW_NAME, WS_OVERLAPPEDWINDOW, x,y, w,h, NULL,0,hInst,NULL); if (grwindow.hwnd == NULL) { open_graph_errmsg = "Cannot create window"; SetEvent(open_graph_event); return 1; } #if 0 if (x != CW_USEDEFAULT) { rc.left = 0; rc.top = 0; rc.right = w; rc.bottom = h; AdjustWindowRect(&rc,GetWindowLong(grwindow.hwnd,GWL_STYLE),0); MoveWindow(grwindow.hwnd,x,y,rc.right-rc.left,rc.bottom-rc.top,1); } #endif } gr_reset(); ShowWindow(grwindow.hwnd,SW_SHOWNORMAL); /* Position the current point at origin */ grwindow.grx = 0; grwindow.gry = 0; caml_gr_init_event_queue(); /* The global data structures are now correctly initialized. Restart the OCaml main thread. */ open_graph_errmsg = NULL; SetEvent(open_graph_event); /* Enter the message handling loop */ while (GetMessage(&msg,NULL,0,0)) { TranslateMessage(&msg); // Translates virtual key codes DispatchMessage(&msg); // Dispatches message to window if (!IsWindow(grwindow.hwnd)) break; } return 0; } CAMLprim value caml_gr_open_graph(value arg) { long tid; if (gr_initialized) return Val_unit; open_graph_event = CreateEvent(NULL, FALSE, FALSE, NULL); threadHandle = CreateThread(NULL,0, (LPTHREAD_START_ROUTINE)gr_open_graph_internal,(void **)arg, 0, &tid); WaitForSingleObject(open_graph_event, INFINITE); CloseHandle(open_graph_event); if (open_graph_errmsg != NULL) gr_fail("%s", open_graph_errmsg); return Val_unit; } CAMLprim value caml_gr_close_graph(void) { if (gr_initialized) { PostMessage(grwindow.hwnd, WM_CLOSE, 0, 0); WaitForSingleObject(threadHandle, INFINITE); } return Val_unit; } CAMLprim value caml_gr_clear_graph(void) { gr_check_open(); if(grremember_mode) { BitBlt(grwindow.gcBitmap,0,0,grwindow.width,grwindow.height, grwindow.gcBitmap,0,0,WHITENESS); } if(grdisplay_mode) { BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height, grwindow.gc,0,0,WHITENESS); } return Val_unit; } CAMLprim value caml_gr_size_x(void) { gr_check_open(); return Val_int(grwindow.width); } CAMLprim value caml_gr_size_y(void) { gr_check_open(); return Val_int(grwindow.height); } CAMLprim value caml_gr_resize_window (value vx, value vy) { gr_check_open (); /* FIXME TODO implement this function... */ return Val_unit; } CAMLprim value caml_gr_synchronize(void) { gr_check_open(); BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height, grwindow.gcBitmap,0,0,SRCCOPY); return Val_unit ; } CAMLprim value caml_gr_display_mode(value flag) { grdisplay_mode = (Int_val(flag)) ? 1 : 0; return Val_unit ; } CAMLprim value caml_gr_remember_mode(value flag) { grremember_mode = (Int_val(flag)) ? 1 : 0; return Val_unit ; } CAMLprim value caml_gr_sigio_signal(value unit) { return Val_unit; } CAMLprim value caml_gr_sigio_handler(void) { return Val_unit; } /* Processing of graphic errors */ static value * graphic_failure_exn = NULL; void gr_fail(char *fmt, char *arg) { char buffer[1024]; if (graphic_failure_exn == NULL) { graphic_failure_exn = caml_named_value("Graphics.Graphic_failure"); if (graphic_failure_exn == NULL) invalid_argument("Exception Graphics.Graphic_failure not initialized, must link graphics.cma"); } sprintf(buffer, fmt, arg); raise_with_string(*graphic_failure_exn, buffer); } void gr_check_open(void) { if (!gr_initialized) gr_fail("graphic screen not opened", NULL); } mingw-ocaml/ocaml/otherlibs/win32graph/libgraph.h0000644000175000017500000000531012124403241021375 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Jacob Navia, after Xavier Leroy */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include struct canvas { int w, h; /* Dimensions of the drawable */ HWND win; /* The drawable itself */ HDC gc; /* The associated graphics context */ }; extern HWND grdisplay; /* The display connection */ extern COLORREF grbackground; extern BOOL grdisplay_mode; /* Display-mode flag */ extern BOOL grremember_mode; /* Remember-mode flag */ extern int grx, gry; /* Coordinates of the current point */ extern int grcolor; /* Current *CAML* drawing color (can be -1) */ extern HFONT * grfont; /* Current font */ extern BOOL direct_rgb; extern int byte_order; extern int bitmap_unit; extern int bits_per_pixel; #define Wcvt(y) (grwindow.height - 1 - (y)) #define Bcvt(y) (grwindow.height - 1 - (y)) #define WtoB(y) ((y) + WindowRect.bottom - grwindow.h) #define DEFAULT_SCREEN_WIDTH 1024 #define DEFAULT_SCREEN_HEIGHT 768 #define BORDER_WIDTH 2 #define WINDOW_NAME "OCaml graphics" #define ICON_NAME "OCaml graphics" #define SIZE_QUEUE 256 void gr_fail(char *fmt, char *arg); void gr_check_open(void); CAMLprim value caml_gr_set_color(value vcolor); // Windows specific definitions extern RECT WindowRect; extern int grCurrentColor; typedef struct tagWindow { HDC gc; HDC gcBitmap; HWND hwnd; HBRUSH CurrentBrush; HPEN CurrentPen; DWORD CurrentColor; int width; int height; int grx; int gry; HBITMAP hBitmap; HFONT CurrentFont; int CurrentFontSize; HDC tempDC; // For image operations; } GR_WINDOW; extern GR_WINDOW grwindow; HFONT CreationFont(char *name); extern void caml_gr_init_event_queue(void); extern void caml_gr_handle_event(UINT msg, WPARAM wParam, LPARAM lParam); mingw-ocaml/ocaml/otherlibs/win32graph/libgraphics.clib0000644000175000017500000000003512124403241022555 0ustar tootstootsopen.o draw.o events.o dib.o mingw-ocaml/ocaml/otherlibs/win32graph/draw.c0000644000175000017500000005025212124403241020542 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Developed by Jacob Navia, based on code by J-M Geffroy and X Leroy */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "mlvalues.h" #include "alloc.h" #include "fail.h" #include "libgraph.h" #include "custom.h" #include "memory.h" HDC gcMetaFile; int grdisplay_mode; int grremember_mode; GR_WINDOW grwindow; static void GetCurrentPosition(HDC hDC,POINT *pt) { MoveToEx(hDC,0,0,pt); MoveToEx(hDC,pt->x,pt->y,0); } static value gr_draw_or_fill_arc(value vx, value vy, value vrx, value vry, value vstart, value vend, BOOL fill); CAMLprim value caml_gr_plot(value vx, value vy) { int x = Int_val(vx); int y = Int_val(vy); gr_check_open(); if(grremember_mode) SetPixel(grwindow.gcBitmap, x, Wcvt(y),grwindow.CurrentColor); if(grdisplay_mode) { SetPixel(grwindow.gc, x, Wcvt(y),grwindow.CurrentColor); } return Val_unit; } CAMLprim value caml_gr_moveto(value vx, value vy) { grwindow.grx = Int_val(vx); grwindow.gry = Int_val(vy); if(grremember_mode) MoveToEx(grwindow.gcBitmap,grwindow.grx,Wcvt(grwindow.gry),0); if (grdisplay_mode) MoveToEx(grwindow.gc,grwindow.grx,Wcvt(grwindow.gry),0); return Val_unit; } CAMLprim value caml_gr_current_x(void) { return Val_int(grwindow.grx); } CAMLprim value caml_gr_current_y(void) { return Val_int(grwindow.gry); } CAMLprim value caml_gr_lineto(value vx, value vy) { int x = Int_val(vx); int y = Int_val(vy); gr_check_open(); SelectObject(grwindow.gc,grwindow.CurrentPen); SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); if (grremember_mode) LineTo(grwindow.gcBitmap,x,Wcvt(y)); if (grdisplay_mode) LineTo(grwindow.gc, x, Wcvt(y)); grwindow.grx = x; grwindow.gry = y; return Val_unit; } CAMLprim value caml_gr_draw_rect(value vx, value vy, value vw, value vh) { int x, y, w, h; POINT pt[5]; x=Int_val(vx); y=Wcvt(Int_val(vy)); w=Int_val(vw); h=Int_val(vh); pt[0].x = x; pt[0].y = y - h; pt[1].x = x + w; pt[1].y = y - h; pt[2].x = x + w; pt[2].y = y; pt[3].x = x; pt[3].y = y; pt[4].x = x; pt[4].y = y - h; if (grremember_mode) { Polyline(grwindow.gcBitmap,pt, 5); } if (grdisplay_mode) { Polyline(grwindow.gc,pt, 5); } return Val_unit; } CAMLprim value caml_gr_draw_text(value text,value x) { POINT pt; int oldmode = SetBkMode(grwindow.gc,TRANSPARENT); SetBkMode(grwindow.gcBitmap,TRANSPARENT); SetTextAlign(grwindow.gcBitmap, TA_UPDATECP|TA_BOTTOM); SetTextAlign(grwindow.gc, TA_UPDATECP|TA_BOTTOM); if (grremember_mode) { TextOut(grwindow.gcBitmap,0,0,(char *)text,x); } if(grdisplay_mode) { TextOut(grwindow.gc,0,0,(char *)text,x); } GetCurrentPosition(grwindow.gc,&pt); grwindow.grx = pt.x; grwindow.gry = grwindow.height - pt.y; SetBkMode(grwindow.gc,oldmode); SetBkMode(grwindow.gcBitmap,oldmode); return Val_unit; } CAMLprim value caml_gr_fill_rect(value vx, value vy, value vw, value vh) { int x = Int_val(vx); int y = Int_val(vy); int w = Int_val(vw); int h = Int_val(vh); RECT rc; gr_check_open(); rc.left = x; rc.top = Wcvt(y); rc.right = x+w; rc.bottom = Wcvt(y)-h; if (grdisplay_mode) FillRect(grwindow.gc,&rc,grwindow.CurrentBrush); if (grremember_mode) FillRect(grwindow.gcBitmap,&rc,grwindow.CurrentBrush); return Val_unit; } CAMLprim value caml_gr_sound(value freq, value vdur) { Beep(freq,vdur); return Val_unit; } CAMLprim value caml_gr_point_color(value vx, value vy) { int x = Int_val(vx); int y = Int_val(vy); COLORREF rgb; unsigned long b,g,r; gr_check_open(); rgb = GetPixel(grwindow.gcBitmap,x,Wcvt(y)); b = (unsigned long)((rgb & 0xFF0000) >> 16); g = (unsigned long)((rgb & 0x00FF00) >> 8); r = (unsigned long)(rgb & 0x0000FF); return Val_long((r<<16) + (g<<8) + b); } CAMLprim value caml_gr_circle(value x,value y,value radius) { int left,top,right,bottom; gr_check_open(); left = x - radius/2; top = Wcvt(y) - radius/2; right = left+radius; bottom = top+radius; Ellipse(grwindow.gcBitmap,left,top,right,bottom); return Val_unit; } CAMLprim value caml_gr_set_window_title(value text) { SetWindowText(grwindow.hwnd,(char *)text); return Val_unit; } CAMLprim value caml_gr_draw_arc(value *argv, int argc) { return gr_draw_or_fill_arc(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], FALSE); } CAMLprim value caml_gr_draw_arc_nat(vx, vy, vrx, vry, vstart, vend) { return gr_draw_or_fill_arc(vx, vy, vrx, vry, vstart, vend, FALSE); } CAMLprim value caml_gr_set_line_width(value vwidth) { int width = Int_val(vwidth); HPEN oldPen,newPen; gr_check_open(); oldPen = grwindow.CurrentPen; newPen = CreatePen(PS_SOLID,width,grwindow.CurrentColor); SelectObject(grwindow.gcBitmap,newPen); SelectObject(grwindow.gc,newPen); DeleteObject(oldPen); grwindow.CurrentPen = newPen; return Val_unit; } CAMLprim value caml_gr_set_color(value vcolor) { HBRUSH oldBrush, newBrush; LOGBRUSH lb; LOGPEN pen; HPEN newPen; int color = Long_val(vcolor); int r = (color & 0xFF0000) >> 16, g = (color & 0x00FF00) >> 8 , b = color & 0x0000FF; COLORREF c = RGB(r,g,b); memset(&lb,0,sizeof(lb)); memset(&pen,0,sizeof(LOGPEN)); gr_check_open(); GetObject(grwindow.CurrentPen,sizeof(LOGPEN),&pen); pen.lopnColor = c; newPen = CreatePenIndirect(&pen); SelectObject(grwindow.gcBitmap,newPen); SelectObject(grwindow.gc,newPen); DeleteObject(grwindow.CurrentPen); grwindow.CurrentPen = newPen; SetTextColor(grwindow.gc,c); SetTextColor(grwindow.gcBitmap,c); oldBrush = grwindow.CurrentBrush; lb.lbStyle = BS_SOLID; lb.lbColor = c; newBrush = CreateBrushIndirect(&lb); SelectObject(grwindow.gc,newBrush); SelectObject(grwindow.gcBitmap,newBrush); DeleteObject(oldBrush); grwindow.CurrentBrush = newBrush; grwindow.CurrentColor = c; return Val_unit; } static value gr_draw_or_fill_arc(value vx, value vy, value vrx, value vry, value vstart, value vend, BOOL fill) { int x, y, r_x, r_y, start, end; int x1, y1, x2, y2, x3, y3, x4, y4; double cvt = 3.141592653/180.0; r_x = Int_val(vrx); r_y = Int_val(vry); if ((r_x < 0) || (r_y < 0)) invalid_argument("draw_arc: radius must be positive"); x = Int_val(vx); y = Int_val(vy); start = Int_val(vstart); end = Int_val(vend); // Upper-left corner of bounding rect. x1= x - r_x; y1= y + r_y; // Lower-right corner of bounding rect. x2= x + r_x; y2= y - r_y; // Starting point x3=x + (int)(100.0*cos(cvt*start)); y3=y + (int)(100.0*sin(cvt*start)); // Ending point x4=x + (int)(100.0*cos(cvt*end)); y4=y + (int)(100.0*sin(cvt*end)); if (grremember_mode) { SelectObject(grwindow.gcBitmap,grwindow.CurrentPen); SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); if( fill ) Pie(grwindow.gcBitmap,x1, Wcvt(y1), x2, Wcvt(y2), x3, Wcvt(y3), x4, Wcvt(y4)); else Arc(grwindow.gcBitmap,x1, Wcvt(y1), x2, Wcvt(y2), x3, Wcvt(y3), x4, Wcvt(y4)); } if( grdisplay_mode ) { SelectObject(grwindow.gc,grwindow.CurrentPen); SelectObject(grwindow.gc,grwindow.CurrentBrush); if (fill) Pie(grwindow.gc,x1, Wcvt(y1), x2, Wcvt(y2), x3, Wcvt(y3), x4, Wcvt(y4)); else Arc(grwindow.gc,x1, Wcvt(y1), x2, Wcvt(y2), x3, Wcvt(y3), x4, Wcvt(y4)); } return Val_unit; } CAMLprim value caml_gr_show_bitmap(value filename,int x,int y) { AfficheBitmap(filename,grwindow.gcBitmap,x,Wcvt(y)); AfficheBitmap(filename,grwindow.gc,x,Wcvt(y)); return Val_unit; } CAMLprim value caml_gr_get_mousex(void) { POINT pt; GetCursorPos(&pt); MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); return pt.x; } CAMLprim value caml_gr_get_mousey(void) { POINT pt; GetCursorPos(&pt); MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); return grwindow.height - pt.y - 1; } static void gr_font(char *fontname) { HFONT hf = CreationFont(fontname); if (hf && hf != INVALID_HANDLE_VALUE) { HFONT oldFont = SelectObject(grwindow.gc,hf); SelectObject(grwindow.gcBitmap,hf); DeleteObject(grwindow.CurrentFont); grwindow.CurrentFont = hf; } } CAMLprim value caml_gr_set_font(value fontname) { gr_check_open(); gr_font(String_val(fontname)); return Val_unit; } CAMLprim value caml_gr_set_text_size (value sz) { return Val_unit; } CAMLprim value caml_gr_draw_char(value chr) { char str[1]; gr_check_open(); str[0] = Int_val(chr); caml_gr_draw_text((value)str, 1); return Val_unit; } CAMLprim value caml_gr_draw_string(value str) { gr_check_open(); caml_gr_draw_text(str, string_length(str)); return Val_unit; } CAMLprim value caml_gr_text_size(value str) { SIZE extent; value res; mlsize_t len = string_length(str); if (len > 32767) len = 32767; GetTextExtentPoint(grwindow.gc,String_val(str), len,&extent); res = alloc_tuple(2); Field(res, 0) = Val_long(extent.cx); Field(res, 1) = Val_long(extent.cy); return res; } CAMLprim value caml_gr_fill_poly(value vect) { int n_points, i; POINT *p,*poly; n_points = Wosize_val(vect); if (n_points < 3) gr_fail("fill_poly: not enough points",0); poly = (POINT *)malloc(n_points*sizeof(POINT)); p = poly; for( i = 0; i < n_points; i++ ){ p->x = Int_val(Field(Field(vect,i),0)); p->y = Wcvt(Int_val(Field(Field(vect,i),1))); p++; } if (grremember_mode) { SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); Polygon(grwindow.gcBitmap,poly,n_points); } if (grdisplay_mode) { SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush); Polygon(grwindow.gc,poly,n_points); } free(poly); return Val_unit; } CAMLprim value caml_gr_fill_arc(value *argv, int argc) { return gr_draw_or_fill_arc(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], TRUE); } CAMLprim value caml_gr_fill_arc_nat(vx, vy, vrx, vry, vstart, vend) { return gr_draw_or_fill_arc(vx, vy, vrx, vry, vstart, vend, TRUE); } // Image primitives struct image { int w; int h; HBITMAP data; HBITMAP mask; }; #define Width(i) (((struct image *)Data_custom_val(i))->w) #define Height(i) (((struct image *)Data_custom_val(i))->h) #define Data(i) (((struct image *)Data_custom_val(i))->data) #define Mask(i) (((struct image *)Data_custom_val(i))->mask) #define Max_image_mem 500000 static void finalize_image (value i) { DeleteObject (Data(i)); if (Mask(i) != NULL) DeleteObject(Mask(i)); } static struct custom_operations image_ops = { "_image", finalize_image, custom_compare_default, custom_hash_default, custom_serialize_default, custom_deserialize_default, custom_compare_ext_default }; CAMLprim value caml_gr_create_image(value vw, value vh) { HBITMAP cbm; value res; int w = Int_val(vw); int h = Int_val(vh); if (w < 0 || h < 0) gr_fail("create_image: width and height must be positive",0); cbm = CreateCompatibleBitmap(grwindow.gc, w, h); if (cbm == NULL) gr_fail("create_image: cannot create bitmap", 0); res = alloc_custom(&image_ops, sizeof(struct image), w * h, Max_image_mem); if (res) { Width (res) = w; Height (res) = h; Data (res) = cbm; Mask (res) = NULL; } return res; } CAMLprim value caml_gr_blit_image (value i, value x, value y) { HBITMAP oldBmp = SelectObject(grwindow.tempDC,Data(i)); int xsrc = Int_val(x); int ysrc = Wcvt(Int_val(y) + Height(i) - 1); BitBlt(grwindow.tempDC,0, 0, Width(i), Height(i), grwindow.gcBitmap, xsrc, ysrc, SRCCOPY); SelectObject(grwindow.tempDC,oldBmp); return Val_unit; } CAMLprim value caml_gr_draw_image(value i, value x, value y) { HBITMAP oldBmp; int xdst = Int_val(x); int ydst = Wcvt(Int_val(y)+Height(i)-1); if (Mask(i) == NULL) { if (grremember_mode) { oldBmp = SelectObject(grwindow.tempDC,Data(i)); BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), Height(i), grwindow.tempDC, 0, 0, SRCCOPY); SelectObject(grwindow.tempDC,oldBmp); } if (grdisplay_mode) { oldBmp = SelectObject(grwindow.tempDC,Data(i)); BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), grwindow.tempDC, 0, 0, SRCCOPY); SelectObject(grwindow.tempDC,oldBmp); } } else { if (grremember_mode) { oldBmp = SelectObject(grwindow.tempDC,Mask(i)); BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), Height(i), grwindow.tempDC, 0, 0, SRCAND); SelectObject(grwindow.tempDC,Data(i)); BitBlt(grwindow.gcBitmap,xdst, ydst, Width(i), Height(i), grwindow.tempDC, 0, 0, SRCPAINT); SelectObject(grwindow.tempDC,oldBmp); } if (grdisplay_mode) { oldBmp = SelectObject(grwindow.tempDC,Mask(i)); BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), grwindow.tempDC, 0, 0, SRCAND); SelectObject(grwindow.tempDC,Data(i)); BitBlt(grwindow.gc,xdst, ydst, Width(i), Height(i), grwindow.tempDC, 0, 0, SRCPAINT); SelectObject(grwindow.tempDC,oldBmp); } } return Val_unit; } CAMLprim value caml_gr_make_image(value matrix) { int width, height,has_transp,i,j; value img; HBITMAP oldBmp; height = Wosize_val(matrix); if (height == 0) { width = 0; } else { width = Wosize_val(Field(matrix, 0)); for (i = 1; i < height; i++) { if (width != (int) Wosize_val(Field(matrix, i))) gr_fail("make_image: non-rectangular matrix",0); } } Begin_roots1(matrix) img = caml_gr_create_image(Val_int(width), Val_int(height)); End_roots(); has_transp = 0; oldBmp = SelectObject(grwindow.tempDC,Data(img)); for (i = 0; i < height; i++) { for (j = 0; j < width; j++) { int col = Long_val (Field (Field (matrix, i), j)); if (col == -1){ has_transp = 1; SetPixel(grwindow.tempDC,j, i, 0); } else { int red = (col >> 16) & 0xFF; int green = (col >> 8) & 0xFF; int blue = col & 0xFF; SetPixel(grwindow.tempDC,j, i, RGB(red, green, blue)); } } } SelectObject(grwindow.tempDC,oldBmp); if (has_transp) { HBITMAP cbm; cbm = CreateCompatibleBitmap(grwindow.gc, width, height); Mask(img) = cbm; oldBmp = SelectObject(grwindow.tempDC,Mask(img)); for (i = 0; i < height; i++) { for (j = 0; j < width; j++) { int col = Long_val (Field (Field (matrix, i), j)); SetPixel(grwindow.tempDC,j, i, col == -1 ? 0xFFFFFF : 0); } } SelectObject(grwindow.tempDC,oldBmp); } return img; } static value alloc_int_vect(mlsize_t size) { value res; mlsize_t i; if (size == 0) return Atom(0); if (size <= Max_young_wosize) { res = alloc(size, 0); } else { res = alloc_shr(size, 0); } for (i = 0; i < size; i++) { Field(res, i) = Val_long(0); } return res; } CAMLprim value caml_gr_dump_image (value img) { int height = Height(img); int width = Width(img); value matrix = Val_unit; int i, j; HBITMAP oldBmp; Begin_roots2(img, matrix) matrix = alloc_int_vect (height); for (i = 0; i < height; i++) { modify (&Field (matrix, i), alloc_int_vect (width)); } End_roots(); oldBmp = SelectObject(grwindow.tempDC,Data(img)); for (i = 0; i < height; i++) { for (j = 0; j < width; j++) { int col = GetPixel(grwindow.tempDC,j, i); int blue = (col >> 16) & 0xFF; int green = (col >> 8) & 0xFF; int red = col & 0xFF; Field(Field(matrix, i), j) = Val_long((red << 16) + (green << 8) + blue); } } SelectObject(grwindow.tempDC,oldBmp); if (Mask(img) != NULL) { oldBmp = SelectObject(grwindow.tempDC,Mask(img)); for (i = 0; i < height; i++) { for (j = 0; j < width; j++) { if (GetPixel(grwindow.tempDC,j, i) != 0) Field(Field(matrix, i), j) = Val_long(-1); } } SelectObject(grwindow.tempDC,oldBmp); } return matrix; } mingw-ocaml/ocaml/otherlibs/dynlink/0000755000175000017500000000000012124403241017121 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/dynlink/.ignore0000644000175000017500000000001412124403241020400 0ustar tootstootsextract_crc mingw-ocaml/ocaml/otherlibs/dynlink/natdynlink.ml0000644000175000017500000001762512124403241021641 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Dynamic loading of .cmx files *) type handle external ndl_open: string -> bool -> handle * string = "caml_natdynlink_open" external ndl_run: handle -> string -> unit = "caml_natdynlink_run" external ndl_getmap: unit -> string = "caml_natdynlink_getmap" external ndl_globals_inited: unit -> int = "caml_natdynlink_globals_inited" type linking_error = Undefined_global of string | Unavailable_primitive of string | Uninitialized_global of string type error = Not_a_bytecode_file of string | Inconsistent_import of string | Unavailable_unit of string | Unsafe_file | Linking_error of string * linking_error | Corrupted_interface of string | File_not_found of string | Cannot_open_dll of string | Inconsistent_implementation of string exception Error of error open Cmx_format (* Copied from config.ml to avoid dependencies *) let cmxs_magic_number = "Caml2007D001" (* Copied from compilenv.ml to avoid dependencies *) let cmx_not_found_crc = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" let dll_filename fname = if Filename.is_implicit fname then Filename.concat (Sys.getcwd ()) fname else fname let read_file filename priv = let dll = dll_filename filename in if not (Sys.file_exists dll) then raise (Error (File_not_found dll)); let (handle,data) as res = ndl_open dll (not priv) in if Obj.tag (Obj.repr res) = Obj.string_tag then raise (Error (Cannot_open_dll (Obj.magic res))); let header : dynheader = Marshal.from_string data 0 in if header.dynu_magic <> cmxs_magic_number then raise(Error(Not_a_bytecode_file dll)); (dll, handle, header.dynu_units) (* Management of interface and implementation CRCs *) module StrMap = Map.Make(String) type implem_state = | Loaded | Check_inited of int type state = { ifaces: (string*string) StrMap.t; implems: (string*string*implem_state) StrMap.t; } let empty_state = { ifaces = StrMap.empty; implems = StrMap.empty; } let global_state = ref empty_state let allow_extension = ref true let inited = ref false let default_available_units () = let map : (string*Digest.t*Digest.t*string list) list = Marshal.from_string (ndl_getmap ()) 0 in let exe = Sys.executable_name in let rank = ref 0 in global_state := List.fold_left (fun st (name,crc_intf,crc_impl,syms) -> rank := !rank + List.length syms; { ifaces = StrMap.add name (crc_intf,exe) st.ifaces; implems = StrMap.add name (crc_impl,exe,Check_inited !rank) st.implems; } ) empty_state map; allow_extension := true; inited := true let init () = if not !inited then default_available_units () let add_check_ifaces allow_ext filename ui ifaces = List.fold_left (fun ifaces (name, crc) -> if name = ui.dynu_name then StrMap.add name (crc,filename) ifaces else try let (old_crc,old_src) = StrMap.find name ifaces in if old_crc <> crc then raise(Error(Inconsistent_import(name))) else ifaces with Not_found -> if allow_ext then StrMap.add name (crc,filename) ifaces else raise (Error(Unavailable_unit name)) ) ifaces ui.dynu_imports_cmi let check_implems filename ui implems = List.iter (fun (name, crc) -> match name with |"Out_of_memory" |"Sys_error" |"Failure" |"Invalid_argument" |"End_of_file" |"Division_by_zero" |"Not_found" |"Match_failure" |"Stack_overflow" |"Sys_blocked_io" |"Assert_failure" |"Undefined_recursive_module" -> () | _ -> try let (old_crc,old_src,state) = StrMap.find name implems in if crc <> cmx_not_found_crc && old_crc <> crc then raise(Error(Inconsistent_implementation(name))) else match state with | Check_inited i -> if ndl_globals_inited() < i then raise(Error(Unavailable_unit name)) | Loaded -> () with Not_found -> raise (Error(Unavailable_unit name)) ) ui.dynu_imports_cmx let loadunits filename handle units state = let new_ifaces = List.fold_left (fun accu ui -> add_check_ifaces !allow_extension filename ui accu) state.ifaces units in let new_implems = List.fold_left (fun accu ui -> check_implems filename ui accu; StrMap.add ui.dynu_name (ui.dynu_crc,filename,Loaded) accu) state.implems units in let defines = List.flatten (List.map (fun ui -> ui.dynu_defines) units) in ndl_run handle "_shared_startup"; List.iter (ndl_run handle) defines; { implems = new_implems; ifaces = new_ifaces } let load priv filename = init(); let (filename,handle,units) = read_file filename priv in let nstate = loadunits filename handle units !global_state in if not priv then global_state := nstate let loadfile filename = load false filename let loadfile_private filename = load true filename let allow_only names = init(); let old = !global_state.ifaces in let ifaces = List.fold_left (fun ifaces name -> try StrMap.add name (StrMap.find name old) ifaces with Not_found -> ifaces) StrMap.empty names in global_state := { !global_state with ifaces = ifaces }; allow_extension := false let prohibit names = init(); let ifaces = List.fold_right StrMap.remove names !global_state.ifaces in global_state := { !global_state with ifaces = ifaces }; allow_extension := false let digest_interface _ _ = failwith "Dynlink.digest_interface: not implemented in native code" let add_interfaces _ _ = failwith "Dynlink.add_interfaces: not implemented in native code" let add_available_units _ = failwith "Dynlink.add_available_units: not implemented in native code" let clear_available_units _ = failwith "Dynlink.clear_available_units: not implemented in native code" let allow_unsafe_modules _ = () (* Error report *) let error_message = function Not_a_bytecode_file name -> name ^ " is not an object file" | Inconsistent_import name -> "interface mismatch on " ^ name | Unavailable_unit name -> "no implementation available for " ^ name | Unsafe_file -> "this object file uses unsafe features" | Linking_error (name, Undefined_global s) -> "error while linking " ^ name ^ ".\n" ^ "Reference to undefined global `" ^ s ^ "'" | Linking_error (name, Unavailable_primitive s) -> "error while linking " ^ name ^ ".\n" ^ "The external function `" ^ s ^ "' is not available" | Linking_error (name, Uninitialized_global s) -> "error while linking " ^ name ^ ".\n" ^ "The module `" ^ s ^ "' is not yet initialized" | Corrupted_interface name -> "corrupted interface file " ^ name | File_not_found name -> "cannot find file " ^ name ^ " in search path" | Cannot_open_dll reason -> "error loading shared library: " ^ reason | Inconsistent_implementation name -> "implementation mismatch on " ^ name let is_native = true let adapt_filename f = Filename.chop_extension f ^ ".cmxs" mingw-ocaml/ocaml/otherlibs/dynlink/Makefile0000644000175000017500000000627712124403241020575 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ # Makefile for the dynamic link library include ../../config/Makefile CAMLC=../../boot/ocamlrun ../../ocamlc CAMLOPT=../../ocamlcompopt.sh INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp -I ../../asmcomp COMPFLAGS=-warn-error A -I ../../stdlib $(INCLUDES) OBJS=dynlinkaux.cmo dynlink.cmo COMPILEROBJS=\ ../../utils/misc.cmo ../../utils/config.cmo ../../utils/clflags.cmo \ ../../utils/tbl.cmo ../../utils/consistbl.cmo \ ../../utils/terminfo.cmo ../../utils/warnings.cmo \ ../../parsing/asttypes.cmi \ ../../parsing/location.cmo ../../parsing/longident.cmo \ ../../typing/ident.cmo ../../typing/path.cmo \ ../../typing/primitive.cmo ../../typing/types.cmo \ ../../typing/btype.cmo ../../typing/subst.cmo ../../typing/predef.cmo \ ../../typing/datarepr.cmo ../../typing/cmi_format.cmo ../../typing/env.cmo \ ../../bytecomp/lambda.cmo ../../bytecomp/instruct.cmo \ ../../bytecomp/cmo_format.cmi ../../bytecomp/opcodes.cmo \ ../../bytecomp/runtimedef.cmo ../../bytecomp/bytesections.cmo \ ../../bytecomp/dll.cmo ../../bytecomp/meta.cmo \ ../../bytecomp/symtable.cmo NATOBJS=dynlink.cmx all: dynlink.cma extract_crc allopt: dynlink.cmxa dynlink.cma: $(OBJS) $(CAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cma $(OBJS) dynlink.cmxa: $(NATOBJS) $(CAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cmxa $(NATOBJS) dynlinkaux.cmo: $(COMPILEROBJS) $(CAMLC) $(COMPFLAGS) -pack -o dynlinkaux.cmo $(COMPILEROBJS) dynlinkaux.cmi: dynlinkaux.cmo dynlink.cmx: dynlink.cmi natdynlink.ml cp natdynlink.ml dynlink.mlopt $(CAMLOPT) -c $(COMPFLAGS) -impl dynlink.mlopt rm -f dynlink.mlopt extract_crc: dynlink.cma extract_crc.cmo $(CAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo install: cp dynlink.cmi dynlink.cma dynlink.mli $(LIBDIR) cp extract_crc $(LIBDIR)/extract_crc$(EXE) installopt: if $(NATDYNLINK); then \ cp $(NATOBJS) dynlink.cmxa dynlink.$(A) $(LIBDIR) && \ cd $(LIBDIR) && $(RANLIB) dynlink.$(A); \ fi partialclean: rm -f extract_crc *.cm[ioax] *.cmxa clean: partialclean rm -f *.$(A) *.$(O) *.so *.dll dynlink.mlopt .SUFFIXES: .ml .mli .cmo .cmi .cmx .mli.cmi: $(CAMLC) -c $(COMPFLAGS) $< .ml.cmo: $(CAMLC) -c $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< depend: dynlink.cmo: dynlinkaux.cmi dynlink.cmi extract_crc.cmo: dynlink.cmi mingw-ocaml/ocaml/otherlibs/dynlink/dynlink.ml0000644000175000017500000002320312124403241021123 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Dynamic loading of .cmo files *) open Dynlinkaux (* REMOVE_ME for ../../debugger/dynlink.ml *) open Cmo_format type linking_error = Undefined_global of string | Unavailable_primitive of string | Uninitialized_global of string type error = Not_a_bytecode_file of string | Inconsistent_import of string | Unavailable_unit of string | Unsafe_file | Linking_error of string * linking_error | Corrupted_interface of string | File_not_found of string | Cannot_open_dll of string | Inconsistent_implementation of string exception Error of error (* Management of interface CRCs *) let crc_interfaces = ref (Consistbl.create ()) let allow_extension = ref true (* Check that the object file being loaded has been compiled against the same interfaces as the program itself. In addition, check that only authorized compilation units are referenced. *) let check_consistency file_name cu = try List.iter (fun (name, crc) -> if name = cu.cu_name then Consistbl.set !crc_interfaces name crc file_name else if !allow_extension then Consistbl.check !crc_interfaces name crc file_name else Consistbl.check_noadd !crc_interfaces name crc file_name) cu.cu_imports with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_import name)) | Consistbl.Not_available(name) -> raise(Error(Unavailable_unit name)) (* Empty the crc_interfaces table *) let clear_available_units () = Consistbl.clear !crc_interfaces; allow_extension := false (* Allow only access to the units with the given names *) let allow_only names = Consistbl.filter (fun name -> List.mem name names) !crc_interfaces; allow_extension := false (* Prohibit access to the units with the given names *) let prohibit names = Consistbl.filter (fun name -> not (List.mem name names)) !crc_interfaces; allow_extension := false (* Initialize the crc_interfaces table with a list of units with fixed CRCs *) let add_available_units units = List.iter (fun (unit, crc) -> Consistbl.set !crc_interfaces unit crc "") units (* Default interface CRCs: those found in the current executable *) let default_crcs = ref [] let default_available_units () = clear_available_units(); add_available_units !default_crcs; allow_extension := true (* Initialize the linker tables and everything *) let inited = ref false let init () = if not !inited then begin default_crcs := Symtable.init_toplevel(); default_available_units (); inited := true; end let clear_available_units () = init(); clear_available_units () let allow_only l = init(); allow_only l let prohibit l = init(); prohibit l let add_available_units l = init(); add_available_units l let default_available_units () = init(); default_available_units () (* Read the CRC of an interface from its .cmi file *) let digest_interface unit loadpath = let filename = let shortname = unit ^ ".cmi" in try Misc.find_in_path_uncap loadpath shortname with Not_found -> raise (Error(File_not_found shortname)) in let ic = open_in_bin filename in try let buffer = Misc.input_bytes ic (String.length Config.cmi_magic_number) in if buffer <> Config.cmi_magic_number then begin close_in ic; raise(Error(Corrupted_interface filename)) end; let cmi = Cmi_format.input_cmi ic in close_in ic; let crc = match cmi.Cmi_format.cmi_crcs with (_, crc) :: _ -> crc | _ -> raise(Error(Corrupted_interface filename)) in crc with End_of_file | Failure _ -> close_in ic; raise(Error(Corrupted_interface filename)) (* Initialize the crc_interfaces table with a list of units. Their CRCs are read from their interfaces. *) let add_interfaces units loadpath = add_available_units (List.map (fun unit -> (unit, digest_interface unit loadpath)) units) (* Check whether the object file being loaded was compiled in unsafe mode *) let unsafe_allowed = ref false let allow_unsafe_modules b = unsafe_allowed := b let check_unsafe_module cu = if (not !unsafe_allowed) && cu.cu_primitives <> [] then raise(Error(Unsafe_file)) (* Load in-core and execute a bytecode object file *) external register_code_fragment: string -> int -> string -> unit = "caml_register_code_fragment" let load_compunit ic file_name file_digest compunit = check_consistency file_name compunit; check_unsafe_module compunit; seek_in ic compunit.cu_pos; let code_size = compunit.cu_codesize + 8 in let code = Meta.static_alloc code_size in unsafe_really_input ic code 0 compunit.cu_codesize; String.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); String.unsafe_set code (compunit.cu_codesize + 1) '\000'; String.unsafe_set code (compunit.cu_codesize + 2) '\000'; String.unsafe_set code (compunit.cu_codesize + 3) '\000'; String.unsafe_set code (compunit.cu_codesize + 4) '\001'; String.unsafe_set code (compunit.cu_codesize + 5) '\000'; String.unsafe_set code (compunit.cu_codesize + 6) '\000'; String.unsafe_set code (compunit.cu_codesize + 7) '\000'; let initial_symtable = Symtable.current_state() in begin try Symtable.patch_object code compunit.cu_reloc; Symtable.check_global_initialized compunit.cu_reloc; Symtable.update_global_table() with Symtable.Error error -> let new_error = match error with Symtable.Undefined_global s -> Undefined_global s | Symtable.Unavailable_primitive s -> Unavailable_primitive s | Symtable.Uninitialized_global s -> Uninitialized_global s | _ -> assert false in raise(Error(Linking_error (file_name, new_error))) end; (* PR#5215: identify this code fragment by digest of file contents + unit name. Unit name is needed for .cma files, which produce several code fragments.*) let digest = Digest.string (file_digest ^ compunit.cu_name) in register_code_fragment code code_size digest; begin try ignore((Meta.reify_bytecode code code_size) ()) with exn -> Symtable.restore_state initial_symtable; raise exn end let loadfile file_name = init(); if not (Sys.file_exists file_name) then raise(Error (File_not_found file_name)); let ic = open_in_bin file_name in let file_digest = Digest.channel ic (-1) in seek_in ic 0; try let buffer = try Misc.input_bytes ic (String.length Config.cmo_magic_number) with End_of_file -> raise (Error (Not_a_bytecode_file file_name)) in if buffer = Config.cmo_magic_number then begin let compunit_pos = input_binary_int ic in (* Go to descriptor *) seek_in ic compunit_pos; let cu = (input_value ic : compilation_unit) in load_compunit ic file_name file_digest cu end else if buffer = Config.cma_magic_number then begin let toc_pos = input_binary_int ic in (* Go to table of contents *) seek_in ic toc_pos; let lib = (input_value ic : library) in begin try Dll.open_dlls Dll.For_execution (List.map Dll.extract_dll_name lib.lib_dllibs) with Failure reason -> raise(Error(Cannot_open_dll reason)) end; List.iter (load_compunit ic file_name file_digest) lib.lib_units end else raise(Error(Not_a_bytecode_file file_name)); close_in ic with exc -> close_in ic; raise exc let loadfile_private file_name = init(); let initial_symtable = Symtable.current_state() and initial_crc = !crc_interfaces in try loadfile file_name; Symtable.hide_additions initial_symtable; crc_interfaces := initial_crc with exn -> Symtable.hide_additions initial_symtable; crc_interfaces := initial_crc; raise exn (* Error report *) let error_message = function Not_a_bytecode_file name -> name ^ " is not a bytecode object file" | Inconsistent_import name -> "interface mismatch on " ^ name | Unavailable_unit name -> "no implementation available for " ^ name | Unsafe_file -> "this object file uses unsafe features" | Linking_error (name, Undefined_global s) -> "error while linking " ^ name ^ ".\n" ^ "Reference to undefined global `" ^ s ^ "'" | Linking_error (name, Unavailable_primitive s) -> "error while linking " ^ name ^ ".\n" ^ "The external function `" ^ s ^ "' is not available" | Linking_error (name, Uninitialized_global s) -> "error while linking " ^ name ^ ".\n" ^ "The module `" ^ s ^ "' is not yet initialized" | Corrupted_interface name -> "corrupted interface file " ^ name | File_not_found name -> "cannot find file " ^ name ^ " in search path" | Cannot_open_dll reason -> "error loading shared library: " ^ reason | Inconsistent_implementation name -> "implementation mismatch on " ^ name let is_native = false let adapt_filename f = f mingw-ocaml/ocaml/otherlibs/dynlink/Makefile.nt0000644000175000017500000000167312124403241021210 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ # Makefile for the dynamic link library include Makefile mingw-ocaml/ocaml/otherlibs/dynlink/dynlink.mli0000644000175000017500000001365612124403241021307 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Dynamic loading of object files. *) val is_native: bool (** [true] if the program is native, [false] if the program is bytecode. *) (** {6 Dynamic loading of compiled files} *) val loadfile : string -> unit (** In bytecode: load the given bytecode object file ([.cmo] file) or bytecode library file ([.cma] file), and link it with the running program. In native code: load the given OCaml plugin file (usually [.cmxs]), and link it with the running program. All toplevel expressions in the loaded compilation units are evaluated. No facilities are provided to access value names defined by the unit. Therefore, the unit must register itself its entry points with the main program, e.g. by modifying tables of functions. *) val loadfile_private : string -> unit (** Same as [loadfile], except that the compilation units just loaded are hidden (cannot be referenced) from other modules dynamically loaded afterwards. *) val adapt_filename : string -> string (** In bytecode, the identity function. In native code, replace the last extension with [.cmxs]. *) (** {6 Access control} *) val allow_only: string list -> unit (** [allow_only units] restricts the compilation units that dynamically-linked units can reference: it only allows references to the units named in list [units]. References to any other compilation unit will cause a [Unavailable_unit] error during [loadfile] or [loadfile_private]. Initially (just after calling [init]), all compilation units composing the program currently running are available for reference from dynamically-linked units. [allow_only] can be used to grant access to some of them only, e.g. to the units that compose the API for dynamically-linked code, and prevent access to all other units, e.g. private, internal modules of the running program. *) val prohibit: string list -> unit (** [prohibit units] prohibits dynamically-linked units from referencing the units named in list [units]. This can be used to prevent access to selected units, e.g. private, internal modules of the running program. *) val default_available_units: unit -> unit (** Reset the set of units that can be referenced from dynamically-linked code to its default value, that is, all units composing the currently running program. *) val allow_unsafe_modules : bool -> unit (** Govern whether unsafe object files are allowed to be dynamically linked. A compilation unit is ``unsafe'' if it contains declarations of external functions, which can break type safety. By default, dynamic linking of unsafe object files is not allowed. In native code, this function does nothing; object files with external functions are always allowed to be dynamically linked. *) (** {6 Deprecated, low-level API for access control} *) (** @deprecated The functions [add_interfaces], [add_available_units] and [clear_available_units] should not be used in new programs, since the default initialization of allowed units, along with the [allow_only] and [prohibit] function, provides a better, safer mechanism to control access to program units. The three functions below are provided for backward compatibility only and are not available in native code. *) val add_interfaces : string list -> string list -> unit (** [add_interfaces units path] grants dynamically-linked object files access to the compilation units named in list [units]. The interfaces ([.cmi] files) for these units are searched in [path] (a list of directory names). *) val add_available_units : (string * Digest.t) list -> unit (** Same as {!Dynlink.add_interfaces}, but instead of searching [.cmi] files to find the unit interfaces, uses the interface digests given for each unit. This way, the [.cmi] interface files need not be available at run-time. The digests can be extracted from [.cmi] files using the [extract_crc] program installed in the OCaml standard library directory. *) val clear_available_units : unit -> unit (** Empty the list of compilation units accessible to dynamically-linked programs. *) (** {6 Deprecated, initialization} *) val init : unit -> unit (** @deprecated Initialize the [Dynlink] library. This function is called automatically when needed. *) (** {6 Error reporting} *) type linking_error = Undefined_global of string | Unavailable_primitive of string | Uninitialized_global of string type error = Not_a_bytecode_file of string | Inconsistent_import of string | Unavailable_unit of string | Unsafe_file | Linking_error of string * linking_error | Corrupted_interface of string | File_not_found of string | Cannot_open_dll of string | Inconsistent_implementation of string exception Error of error (** Errors in dynamic linking are reported by raising the [Error] exception with a description of the error. *) val error_message : error -> string (** Convert an error description to a printable message. *) (**/**) (** {6 Internal functions} *) val digest_interface : string -> string list -> Digest.t mingw-ocaml/ocaml/otherlibs/dynlink/extract_crc.ml0000644000175000017500000000402112124403241021751 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Print the digests of unit interfaces *) let load_path = ref [] let first = ref true let print_crc unit = try let crc = Dynlink.digest_interface unit (!load_path @ ["."]) in if !first then first := false else print_string ";\n"; print_string " \""; print_string (String.capitalize unit); print_string "\",\n \""; for i = 0 to String.length crc - 1 do Printf.printf "\\%03d" (Char.code crc.[i]) done; print_string "\"" with exn -> prerr_string "Error while reading the interface for "; prerr_endline unit; begin match exn with Sys_error msg -> prerr_endline msg | Dynlink.Error(Dynlink.File_not_found name) -> prerr_string "Cannot find file "; prerr_endline name | Dynlink.Error _ -> prerr_endline "Ill-formed .cmi file" | _ -> raise exn end; exit 2 let usage = "Usage: extract_crc [-I ] " let main () = print_string "let crc_unit_list = [\n"; Arg.parse ["-I", Arg.String(fun dir -> load_path := !load_path @ [dir]), " Add to the list of include directories"] print_crc usage; print_string "\n]\n" let _ = main(); exit 0 mingw-ocaml/ocaml/otherlibs/dynlink/dynlinkaux.mlpack0000644000175000017500000000034312124403241022500 0ustar tootstootsMisc Config Clflags Tbl Consistbl Terminfo Warnings Asttypes Location Longident Ident Path Primitive Types Btype Subst Predef Datarepr Cmi_format Env Lambda Instruct Cmo_format Opcodes Runtimedef Bytesections Dll Meta Symtable mingw-ocaml/ocaml/otherlibs/dbm/0000755000175000017500000000000012124403241016213 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/dbm/.gitignore0000644000175000017500000000000012124403241020171 0ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/0000755000175000017500000000000012124403241016722 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/.ignore0000644000175000017500000000006312124403241020205 0ustar tootstootslabltklink labltkopt Makefile.config config.status mingw-ocaml/ocaml/otherlibs/labltk/camltk/0000755000175000017500000000000012124403241020175 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/camltk/.ignore0000644000175000017500000000003412124403241021456 0ustar tootstoots*.ml *.mli labltktop labltk mingw-ocaml/ocaml/otherlibs/labltk/camltk/Makefile0000644000175000017500000000360412124403241021640 0ustar tootstoots####################################################################### # # # MLTk, Tcl/Tk interface of OCaml # # # # Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # # projet Cristal, INRIA Rocquencourt # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 2002 Institut National de Recherche en Informatique et # # en Automatique and Kyoto University. All rights reserved. # # This file is distributed under the terms of the GNU Library # # General Public License, with the special exception on linking # # described in file LICENSE found in the OCaml source tree. # # # ####################################################################### include ../support/Makefile.common COMPFLAGS= -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/unix all: camltkobjs opt: camltkobjsx include ./modules CAMLTKOBJS= $(CWIDGETOBJS) cTk.cmo camltk.cmo CAMLTKOBJSX = $(CAMLTKOBJS:.cmo=.cmx) camltkobjs: $(CAMLTKOBJS) camltkobjsx: $(CAMLTKOBJSX) clean: $(MAKE) -f Makefile.gen clean install: if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi cp $(CAMLTKOBJS:.cmo=.cmi) $(CWIDGETOBJS:.cmo=.mli) $(INSTALLDIR) chmod 644 $(INSTALLDIR)/*.cmi installopt: @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi cp $(CAMLTKOBJSX) $(INSTALLDIR) chmod 644 $(INSTALLDIR)/*.cmx .SUFFIXES : .SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp .mli.cmi: $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmo: $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< include .depend mingw-ocaml/ocaml/otherlibs/labltk/camltk/Makefile.gen.nt0000644000175000017500000000002512124403241023022 0ustar tootstootsinclude Makefile.gen mingw-ocaml/ocaml/otherlibs/labltk/camltk/Makefile.nt0000644000175000017500000000002112124403241022246 0ustar tootstootsinclude Makefile mingw-ocaml/ocaml/otherlibs/labltk/camltk/Makefile.gen0000644000175000017500000000450112124403241022405 0ustar tootstoots####################################################################### # # # MLTk, Tcl/Tk interface of OCaml # # # # Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # # projet Cristal, INRIA Rocquencourt # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 2002 Institut National de Recherche en Informatique et # # en Automatique and Kyoto University. All rights reserved. # # This file is distributed under the terms of the GNU Library # # General Public License, with the special exception on linking # # described in file LICENSE found in the OCaml source tree. # # # ####################################################################### include ../support/Makefile.common all: cTk.ml camltk.ml .depend _tkgen.ml: ../Widgets.src ../compiler/tkcompiler$(EXE) cd ..; $(CAMLRUNGEN) compiler/tkcompiler$(EXE) -camltk -outdir camltk #cTk.ml camltk.ml .depend: generate cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp$(EXE) #../builtin/builtin_*.ml (echo '##define CAMLTK'; \ echo 'include Camltkwrap'; \ echo 'open Widget'; \ echo 'open Protocol'; \ echo 'open Textvariable'; \ echo ; \ cat ../builtin/report.ml; \ echo ; \ cat ../builtin/builtin_*.ml; \ echo ; \ cat _tkgen.ml; \ echo ; \ echo ; \ echo 'module Tkintf = struct'; \ cat ../builtin/builtini_*.ml; \ cat _tkigen.ml; \ echo 'end (* module Tkintf *)'; \ echo ; \ echo ; \ echo 'open Tkintf' ;\ echo ; \ echo ; \ cat ../builtin/builtinf_*.ml; \ cat _tkfgen.ml; \ echo ; \ ) > _cTk.ml $(CAMLRUN) ../compiler/pp < _cTk.ml > cTk.ml rm -f _cTk.ml $(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend ../compiler/pp$(EXE): cd ../compiler; $(MAKE) pp($EXE) ../compiler/tkcompiler$(EXE): cd ../compiler; $(MAKE) tkcompiler($EXE) # All .{ml,mli} files are generated in this directory clean: rm -f *.cm* *.ml *.mli *.$(O) *.$(A) .depend # rm -f modules .PHONY: all generate clean mingw-ocaml/ocaml/otherlibs/labltk/camltk/byte.itarget0000644000175000017500000000075712124403241022532 0ustar tootstootscPlace.cmo cResource.cmo cWm.cmo cImagephoto.cmo cCanvas.cmo cButton.cmo cText.cmo cLabel.cmo cScrollbar.cmo cImage.cmo cEncoding.cmo cPixmap.cmo cPalette.cmo cFont.cmo cMessage.cmo cMenu.cmo cEntry.cmo cListbox.cmo cFocus.cmo cMenubutton.cmo cPack.cmo cOption.cmo cToplevel.cmo cFrame.cmo cDialog.cmo cImagebitmap.cmo cClipboard.cmo cRadiobutton.cmo cTkwait.cmo cGrab.cmo cSelection.cmo cScale.cmo cOptionmenu.cmo cWinfo.cmo cGrid.cmo cCheckbutton.cmo cBell.cmo cTkvars.cmo cTk.cmo camltk.cmo mingw-ocaml/ocaml/otherlibs/labltk/camltk/native.itarget0000644000175000017500000000073312124403241023047 0ustar tootstootscPlace.cmx cResource.cmx cWm.cmx cImagephoto.cmx cCanvas.cmx cButton.cmx cText.cmx cLabel.cmx cScrollbar.cmx cImage.cmx cEncoding.cmx cPixmap.cmx cPalette.cmx cFont.cmx cMessage.cmx cMenu.cmx cEntry.cmx cListbox.cmx cFocus.cmx cMenubutton.cmx cPack.cmx cOption.cmx cToplevel.cmx cFrame.cmx cDialog.cmx cImagebitmap.cmx cClipboard.cmx cRadiobutton.cmx cTkwait.cmx cGrab.cmx cSelection.cmx cScale.cmx cOptionmenu.cmx cWinfo.cmx cGrid.cmx cCheckbutton.cmx cBell.cmx cTkvars.cmx mingw-ocaml/ocaml/otherlibs/labltk/camltk/modules0000644000175000017500000000657112124403241021601 0ustar tootstootsCWIDGETOBJS=cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo cBell.ml cScale.ml cWinfo.ml cScrollbar.ml cEntry.ml cListbox.ml cWm.ml cTkwait.ml cGrab.ml cFont.ml cCanvas.ml cImage.ml cClipboard.ml cLabel.ml cResource.ml cMessage.ml cText.ml cImagephoto.ml cOption.ml cFrame.ml cSelection.ml cDialog.ml cPlace.ml cPixmap.ml cMenubutton.ml cRadiobutton.ml cFocus.ml cPack.ml cImagebitmap.ml cEncoding.ml cOptionmenu.ml cCheckbutton.ml cTkvars.ml cPalette.ml cMenu.ml cButton.ml cToplevel.ml cGrid.ml : _tkgen.ml cBell.cmo : cBell.ml cBell.cmi : cBell.mli cScale.cmo : cScale.ml cScale.cmi : cScale.mli cWinfo.cmo : cWinfo.ml cWinfo.cmi : cWinfo.mli cScrollbar.cmo : cScrollbar.ml cScrollbar.cmi : cScrollbar.mli cEntry.cmo : cEntry.ml cEntry.cmi : cEntry.mli cListbox.cmo : cListbox.ml cListbox.cmi : cListbox.mli cWm.cmo : cWm.ml cWm.cmi : cWm.mli cTkwait.cmo : cTkwait.ml cTkwait.cmi : cTkwait.mli cGrab.cmo : cGrab.ml cGrab.cmi : cGrab.mli cFont.cmo : cFont.ml cFont.cmi : cFont.mli cCanvas.cmo : cCanvas.ml cCanvas.cmi : cCanvas.mli cImage.cmo : cImage.ml cImage.cmi : cImage.mli cClipboard.cmo : cClipboard.ml cClipboard.cmi : cClipboard.mli cLabel.cmo : cLabel.ml cLabel.cmi : cLabel.mli cResource.cmo : cResource.ml cResource.cmi : cResource.mli cMessage.cmo : cMessage.ml cMessage.cmi : cMessage.mli cText.cmo : cText.ml cText.cmi : cText.mli cImagephoto.cmo : cImagephoto.ml cImagephoto.cmi : cImagephoto.mli cOption.cmo : cOption.ml cOption.cmi : cOption.mli cFrame.cmo : cFrame.ml cFrame.cmi : cFrame.mli cSelection.cmo : cSelection.ml cSelection.cmi : cSelection.mli cDialog.cmo : cDialog.ml cDialog.cmi : cDialog.mli cPlace.cmo : cPlace.ml cPlace.cmi : cPlace.mli cPixmap.cmo : cPixmap.ml cPixmap.cmi : cPixmap.mli cMenubutton.cmo : cMenubutton.ml cMenubutton.cmi : cMenubutton.mli cRadiobutton.cmo : cRadiobutton.ml cRadiobutton.cmi : cRadiobutton.mli cFocus.cmo : cFocus.ml cFocus.cmi : cFocus.mli cPack.cmo : cPack.ml cPack.cmi : cPack.mli cImagebitmap.cmo : cImagebitmap.ml cImagebitmap.cmi : cImagebitmap.mli cEncoding.cmo : cEncoding.ml cEncoding.cmi : cEncoding.mli cOptionmenu.cmo : cOptionmenu.ml cOptionmenu.cmi : cOptionmenu.mli cCheckbutton.cmo : cCheckbutton.ml cCheckbutton.cmi : cCheckbutton.mli cTkvars.cmo : cTkvars.ml cTkvars.cmi : cTkvars.mli cPalette.cmo : cPalette.ml cPalette.cmi : cPalette.mli cMenu.cmo : cMenu.ml cMenu.cmi : cMenu.mli cButton.cmo : cButton.ml cButton.cmi : cButton.mli cToplevel.cmo : cToplevel.ml cToplevel.cmi : cToplevel.mli cGrid.cmo : cGrid.ml cGrid.cmi : cGrid.mli camltk.cmo : cTk.cmo cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo mingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/0000755000175000017500000000000012124403241022073 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/addition.ml0000644000175000017500000000441612124403241024225 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk let main () = let top = opentk () in (* The widgets. They all have "top" as parent widget. *) let en1 = Entry.create top [TextWidth 6; Relief Sunken] in let lab1 = Label.create top [Text "plus"] in let en2 = Entry.create top [TextWidth 6 ; Relief Sunken] in let lab2 = Label.create top [Text "="] in let result_display = Label.create top [] in (* References holding values of entry widgets *) let n1 = ref 0 and n2 = ref 0 in (* Refresh result *) let refresh () = Label.configure result_display [Text (string_of_int (!n1 + !n2))] in (* Electric *) let get_and_refresh (w,r) = fun _ _ -> try r := int_of_string (Entry.get w); refresh () with Failure "int_of_string" -> Label.configure result_display [Text "error"] in (* Set the callbacks *) Entry.configure en1 [XScrollCommand (get_and_refresh (en1,n1)) ]; Entry.configure en2 [XScrollCommand (get_and_refresh (en2,n2)) ]; (* Map the widgets *) pack [en1;lab1;en2;lab2;result_display] []; (* Make the window resizable *) Wm.minsize_set top 1 1; (* Start interaction (event-driven program) *) mainLoop () ;; let _ = Printexc.catch main () ;; mingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/.ignore0000644000175000017500000000010212124403241023350 0ustar tootstootsaddition eyes fileinput fileopen helloworld tetris winskel mytext mingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/fileinput.ml0000644000175000017500000000362212124403241024427 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk ;; let top_w = opentk () ;; let buffer = String.create 256 ;; let (fd_in, fd_out) = Unix.pipe () ;; let text0_w = Text.create top_w [] ;; let entry0_w = Entry.create top_w [] ;; let button0_w = Button.create top_w [Text "Quit"; Command (fun _ -> exit 0)] ;; Fileevent.add_fileinput fd_in (fun _ -> let n = Unix.read fd_in buffer 0 (String.length buffer) in let txt = String.sub buffer 0 n in Text.insert text0_w (TextIndex (End, [])) txt []) ;; let send _ = let txt = Entry.get entry0_w ^ "\n" in Entry.delete_range entry0_w (At 0) End ; ignore (Unix.write fd_out txt 0 (String.length txt));; bind entry0_w [([], KeyPressDetail "Return")] (BindSet ([], send)) ; pack [text0_w; entry0_w; button0_w][Side Side_Top; Fill Fill_X; Expand true] ;; mainLoop () ;; mingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/Makefile0000644000175000017500000000270112124403241023533 0ustar tootstootsinclude ../support/Makefile.common # We are using the non-installed library ! COMPFLAGS=-I ../lib -I ../camltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support all: addition$(EXE) helloworld$(EXE) winskel$(EXE) fileinput$(EXE) \ eyes$(EXE) tetris$(EXE) mytext$(EXE) fileopen$(EXE) addition$(EXE): addition.cmo $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma addition.cmo helloworld$(EXE): helloworld.cmo $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma helloworld.cmo winskel$(EXE): winskel.cmo $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma winskel.cmo fileinput$(EXE): fileinput.cmo $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma fileinput.cmo socketinput$(EXE): socketinput.cmo $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma socketinput.cmo eyes$(EXE): eyes.cmo $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma eyes.cmo tetris$(EXE): tetris.cmo $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma tetris.cmo mytext$(EXE): mytext.cmo $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma mytext.cmo # graph$(EXE): graphics.cmo graphics_test.cmo # $(CAMLC) -o $@ graphics.cmo graphics_test.cmo # # graphics_test.cmo: graphics.cmo fileopen$(EXE): fileopen.cmo $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma fileopen.cmo clean : rm -f *.cm? $(EXECS) addition eyes fileinput fileopen helloworld jptest mytext tetris winskel .SUFFIXES : .SUFFIXES : .mli .ml .cmi .cmo .mli.cmi: $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmo: $(CAMLCOMP) $(COMPFLAGS) $< mingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/mytext.ml0000644000175000017500000000422712124403241023764 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk let top = opentk () let scroll_link sb tx = Text.configure tx [YScrollCommand (Scrollbar.set sb)]; Scrollbar.configure sb [ScrollCommand (Text.yview tx)] let f = Frame.create top [] let text = Text.create f [] let scrollbar = Scrollbar.create f [] (* kill buffer *) let buffer = ref "" (* Note: for the text widgets, the insertion cursor is not TextIndex(Insert, []), but TextIndex(Mark "insert", []) *) let insertMark = TextIndex(Mark "insert", []) let eol_insertMark = TextIndex(Mark "insert", [LineEnd]) let kill () = buffer := Text.get text insertMark eol_insertMark; prerr_endline ("Killed: " ^ !buffer); Text.delete text insertMark eol_insertMark ;; let yank () = Text.insert text insertMark !buffer []; prerr_endline ("Yanked: " ^ !buffer) ;; let _ = scroll_link scrollbar text; pack [text; scrollbar][Side Side_Left; Fill Fill_Y]; pack [f][]; bind text [[Control], KeyPressDetail "y"] (BindSet ([], fun _ -> yank () )); bind text [[Control], KeyPressDetail "k"] (BindSet ([], fun _ -> kill () )); mainLoop () ;; mingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/Makefile.nt0000644000175000017500000000153112124403241024153 0ustar tootstootsinclude ../support/Makefile.common # We are using the non-installed library ! COMPFLAGS= -I ../lib -I ../camltk -I ../support LINKFLAGS= -I ../lib -I ../camltk -I ../support # Use pieces of Makefile.config TKLINKOPT=$(LIBNAME).cma $(TKLIBS) all: addition.exe helloworld.exe winskel.exe socketinput.exe addition.exe: addition.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ -o $@ addition.cmo helloworld.exe: helloworld.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ -o $@ helloworld.cmo winskel.exe: winskel.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ -o $@ winskel.cmo socketinput.exe: socketinput.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) unix.cma \ -o $@ socketinput.cmo clean : rm -f *.cm? *.exe .SUFFIXES : .SUFFIXES : .mli .ml .cmi .cmo .mli.cmi: $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmo: $(CAMLCOMP) $(COMPFLAGS) $< mingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/tetris.ml0000644000175000017500000004222712124403241023746 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* A Tetris game for CamlTk *) (* written by Jun P. Furuse *) open Camltk exception Done type cell = {mutable color : int; tag : tagOrId * tagOrId * tagOrId} type falling_block = { mutable pattern: int array list; mutable bcolor: int; mutable x: int; mutable y: int; mutable d: int; mutable alive: bool } let stop_a_bit = 300 let colors = [| NamedColor "red"; NamedColor "yellow"; NamedColor "blue"; NamedColor "orange"; NamedColor "magenta"; NamedColor "green"; NamedColor "cyan" |] let baseurl = "images/" let backgrounds = List.map (fun s -> baseurl ^ s) [ "dojoji.back.gif"; "Lambda2back.gif"; "CamlBook.gif"; ] (* blocks *) let block_size = 16 let cell_border = 2 let blocks = [ [ [|"0000"; "0000"; "1111"; "0000" |]; [|"0010"; "0010"; "0010"; "0010" |]; [|"0000"; "0000"; "1111"; "0000" |]; [|"0010"; "0010"; "0010"; "0010" |] ]; [ [|"0000"; "0110"; "0110"; "0000" |]; [|"0000"; "0110"; "0110"; "0000" |]; [|"0000"; "0110"; "0110"; "0000" |]; [|"0000"; "0110"; "0110"; "0000" |] ]; [ [|"0000"; "0111"; "0100"; "0000" |]; [|"0000"; "0110"; "0010"; "0010" |]; [|"0000"; "0010"; "1110"; "0000" |]; [|"0100"; "0100"; "0110"; "0000" |] ]; [ [|"0000"; "0100"; "0111"; "0000" |]; [|"0000"; "0110"; "0100"; "0100" |]; [|"0000"; "1110"; "0010"; "0000" |]; [|"0010"; "0010"; "0110"; "0000" |] ]; [ [|"0000"; "1100"; "0110"; "0000" |]; [|"0010"; "0110"; "0100"; "0000" |]; [|"0000"; "1100"; "0110"; "0000" |]; [|"0010"; "0110"; "0100"; "0000" |] ]; [ [|"0000"; "0011"; "0110"; "0000" |]; [|"0100"; "0110"; "0010"; "0000" |]; [|"0000"; "0011"; "0110"; "0000" |]; [|"0000"; "0100"; "0110"; "0010" |] ]; [ [|"0000"; "0000"; "1110"; "0100" |]; [|"0000"; "0100"; "1100"; "0100" |]; [|"0000"; "0100"; "1110"; "0000" |]; [|"0000"; "0100"; "0110"; "0100" |] ] ] let line_empty = int_of_string "0b1110000000000111" let line_full = int_of_string "0b1111111111111111" let decode_block dvec = let btoi d = int_of_string ("0b"^d) in Array.map btoi dvec let init fw = let scorev = Textvariable.create () and linev = Textvariable.create () and levv = Textvariable.create () in let f = Frame.create fw [BorderWidth (Pixels 2)] in let c = Canvas.create f [Width (Pixels (block_size * 10)); Height (Pixels (block_size * 20)); BorderWidth (Pixels cell_border); Relief Sunken; Background Black] and r = Frame.create f [] and r' = Frame.create f [] in let nl = Label.create r [Text "Next"; Font "variable"] in let nc = Canvas.create r [Width (Pixels (block_size * 4)); Height (Pixels (block_size * 4)); BorderWidth (Pixels cell_border); Relief Sunken; Background Black] in let scl = Label.create r [Text "Score"; Font "variable"] in let sc = Label.create r [TextVariable scorev; Font "variable"] in let lnl = Label.create r [Text "Lines"; Font "variable"] in let ln = Label.create r [TextVariable linev; Font "variable"] in let levl = Label.create r [Text "Level"; Font "variable"] in let lev = Label.create r [TextVariable levv; Font "Variable"] in let newg = Button.create r [Text "New Game"; Font "variable"] in let exitg = Button.create r [Text "Quit"; Font "variable"] in pack [f] []; pack [c; r; r'] [Side Side_Left; Fill Fill_Y]; pack [nl; nc] [Side Side_Top]; pack [scl; sc; lnl; ln; levl; lev; newg; exitg] [Side Side_Top]; let cells_src = Array.create 20 (Array.create 10 ()) in let cells = Array.map (Array.map (fun () -> {tag= (let t1, t2, t3 = Canvas.create_rectangle c (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) (Pixels (-9)) (Pixels (-9)) [], Canvas.create_rectangle c (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) (Pixels (-11)) (Pixels (-11)) [], Canvas.create_rectangle c (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) (Pixels (-13)) (Pixels (-13)) [] in Canvas.raise_top c t1; Canvas.raise_top c t2; Canvas.lower_bot c t3; t1,t2,t3); color= 0})) cells_src in let nexts_src = Array.create 4 (Array.create 4 ()) in let nexts = Array.map (Array.map (fun () -> {tag= (let t1, t2, t3 = Canvas.create_rectangle nc (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) (Pixels (-9)) (Pixels (-9)) [], Canvas.create_rectangle nc (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) (Pixels (-11)) (Pixels (-11)) [], Canvas.create_rectangle nc (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) (Pixels (-13)) (Pixels (-13)) [] in Canvas.raise_top nc t1; Canvas.raise_top nc t2; Canvas.lower_bot nc t3; t1, t2, t3); color= 0})) nexts_src in let game_over () = () in [f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg, (c, cells), (nc, nexts), scorev, linev, levv, game_over let cell_get (c, cf) x y = (Array.get (Array.get cf y) x).color let cell_set (c, cf) x y col = let cur = Array.get (Array.get cf y) x in let t1,t2,t3 = cur.tag in if cur.color = col then () else if cur.color <> 0 && col = 0 then begin Canvas.move c t1 (Pixels (- block_size * (x + 1) -10 - cell_border * 2)) (Pixels (- block_size * (y + 1) -10 - cell_border * 2)); Canvas.move c t2 (Pixels (- block_size * (x + 1) -10 - cell_border * 2)) (Pixels (- block_size * (y + 1) -10 - cell_border * 2)); Canvas.move c t3 (Pixels (- block_size * (x + 1) -10 - cell_border * 2)) (Pixels (- block_size * (y + 1) -10 - cell_border * 2)) end else begin Canvas.configure_rectangle c t2 [FillColor (Array.get colors (col - 1)); Outline (Array.get colors (col - 1))]; Canvas.configure_rectangle c t1 [FillColor Black; Outline Black]; Canvas.configure_rectangle c t3 [FillColor (NamedColor "light gray"); Outline (NamedColor "light gray")]; if cur.color = 0 && col <> 0 then begin Canvas.move c t1 (Pixels (block_size * (x+1)+10+ cell_border*2)) (Pixels (block_size * (y+1)+10+ cell_border*2)); Canvas.move c t2 (Pixels (block_size * (x+1)+10+ cell_border*2)) (Pixels (block_size * (y+1)+10+ cell_border*2)); Canvas.move c t3 (Pixels (block_size * (x+1)+10+ cell_border*2)) (Pixels (block_size * (y+1)+10+ cell_border*2)) end end; cur.color <- col let draw_block field col d x y = for iy = 0 to 3 do let base = ref 1 in let xd = Array.get d iy in for ix = 0 to 3 do if xd land !base <> 0 then begin try cell_set field (ix + x) (iy + y) col with _ -> () end else begin (* cell_set field (ix + x) (iy + y) 0 *) () end; base := !base lsl 1 done done let timer_ref = (ref None : Timer.t option ref) (* I know, this should be timer ref, but I'm not sure what should be the initial value ... *) let remove_timer () = match !timer_ref with | None -> () | Some t -> Timer.remove t (* ; prerr_endline "removed!" *) let do_after milli f = timer_ref := Some (Timer.add milli f) let copy_block c = { pattern= !c.pattern; bcolor= !c.bcolor; x= !c.x; y= !c.y; d= !c.d; alive= !c.alive } let _ = let top = opentk () in let lb = Label.create top [] and fw = Frame.create top [] in let set_message s = Label.configure lb [Text s] in pack [lb; fw] [Side Side_Top]; let score = ref 0 in let line = ref 0 in let level = ref 0 in let time = ref 1000 in let blocks = List.map (List.map decode_block) blocks in let field = Array.create 26 0 in let widgets, newg, exitg, cell_field, next_field, scorev, linev, levv, game_over = init fw in let canvas = fst cell_field in let init_field () = for i = 0 to 25 do field.(i) <- line_empty done; field.(23) <- line_full; for i = 0 to 19 do for j = 0 to 9 do cell_set cell_field j i 0 done done; for i = 0 to 3 do for j = 0 to 3 do cell_set next_field j i 0 done done in let draw_falling_block fb = draw_block cell_field fb.bcolor (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) and erase_falling_block fb = draw_block cell_field 0 (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) in let stone fb = for i=0 to 3 do let cur = field.(i + fb.y) in field.(i + fb.y) <- cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x) done; for i=0 to 2 do field.(i) <- line_empty done and clear fb = let l = ref 0 in for i = 0 to 3 do if i + fb.y >= 3 && i + fb.y <= 22 then if field.(i + fb.y) = line_full then begin incr l; field.(i + fb.y) <- line_empty; for j = 0 to 9 do cell_set cell_field j (i + fb.y - 3) 0 done end done; !l and fall_lines () = let eye = ref 22 (* bottom *) and cur = ref 22 (* bottom *) in try while !eye >= 3 do while field.(!eye) = line_empty do decr eye; if !eye = 2 then raise Done done; field.(!cur) <- field.(!eye); for j = 0 to 9 do cell_set cell_field j (!cur-3) (cell_get cell_field j (!eye-3)) done; decr eye; decr cur done with Done -> (); for i = 3 to !cur do field.(i) <- line_empty; for j = 0 to 9 do cell_set cell_field j (i-3) 0 done done in let next = ref 42 (* THE ANSWER *) and current = ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false} in let draw_next () = draw_block next_field (!next+1) (List.hd (List.nth blocks !next)) 0 0 and erase_next () = draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0 in let set_nextblock () = current := { pattern= (List.nth blocks !next); bcolor= !next+1; x=6; y= 1; d= 0; alive= true}; erase_next (); next := Random.int 7; draw_next () in let death_check fb = try for i=0 to 3 do let cur = field.(i + fb.y) in if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0 then raise Done done; false with Done -> true in let try_to_move m = if !current.alive then let sub m = if death_check m then false else begin erase_falling_block !current; draw_falling_block m; current := m; true end in if sub m then () else begin m.x <- m.x + 1; if sub m then () else begin m.x <- m.x - 2; ignore (sub m) end end else () in let image_load = let i = Canvas.create_image canvas (Pixels (block_size * 5 + block_size / 2)) (Pixels (block_size * 10 + block_size / 2)) [Anchor Center] in Canvas.lower_bot canvas i; let img = Imagephoto.create [] in fun file -> try Imagephoto.configure img [File file]; Canvas.configure_image canvas i [ImagePhoto img] with _ -> begin Printf.eprintf "%s : No such image...\n" file; flush stderr end in let add_score l = let pline = !line in if l <> 0 then begin line := !line + l; score := !score + l * l; set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2))) end; Textvariable.set linev (string_of_int !line); Textvariable.set scorev (string_of_int !score); if !line /10 <> pline /10 then (* update the background every 10 lines. *) begin let num_image = List.length backgrounds - 1 in let n = !line/10 in let n = if n > num_image then num_image else n in let file = List.nth backgrounds n in image_load file; (* Future work: We should gain level after an image is put... *) incr level; Textvariable.set levv (string_of_int !level) end in let rec newblock () = set_message "TETRIS"; set_nextblock (); draw_falling_block !current; if death_check !current then begin !current.alive <- false; set_message "GAME OVER"; game_over () end else begin time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200); if !time < 60 - !level * 3 then time := 60 - !level * 3; do_after stop_a_bit loop end and loop () = let m = copy_block current in m.y <- m.y + 1; if death_check m then begin !current.alive <- false; stone !current; do_after stop_a_bit (fun () -> let l = clear !current in if l > 0 then do_after stop_a_bit (fun () -> fall_lines (); add_score l; do_after stop_a_bit newblock) else newblock ()) end else begin erase_falling_block !current; draw_falling_block m; current := m; do_after !time loop end in let bind_game w = bind w [([], KeyPress)] (BindSet ([Ev_KeySymString], fun e -> match e.ev_KeySymString with | "h" -> let m = copy_block current in m.x <- m.x - 1; try_to_move m | "j" -> let m = copy_block current in m.d <- m.d + 1; if m.d = List.length m.pattern then m.d <- 0; try_to_move m | "k" -> let m = copy_block current in m.d <- m.d - 1; if m.d < 0 then m.d <- List.length m.pattern - 1; try_to_move m | "l" -> let m = copy_block current in m.x <- m.x + 1; try_to_move m | "m" -> remove_timer (); loop () | "space" -> if !current.alive then begin let m = copy_block current and n = copy_block current in while m.y <- m.y + 1; if death_check m then false else begin n.y <- m.y; true end do () done; erase_falling_block !current; draw_falling_block n; current := n; remove_timer (); loop () end | _ -> () )) in let game_init () = (* Game Initialization *) set_message "Initializing ..."; remove_timer (); image_load (List.hd backgrounds); time := 1000; score := 0; line := 0; level := 1; add_score 0; init_field (); next := Random.int 7; set_message "Welcome to TETRIS"; set_nextblock (); draw_falling_block !current; do_after !time loop in bind_game top; Button.configure newg [Command game_init]; Button.configure exitg [Command (fun () -> closeTk (); exit 0)]; game_init () let _ = Printexc.print mainLoop () mingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/fileopen.ml0000644000175000017500000000376612124403241024242 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk;; let win = opentk();; let cvs = Canvas.create win [];; let t = Label.create cvs [Text "File name"];; let b = Button.create cvs [Text "Save"; Command (function _ -> let s = getSaveFile [Title "SAVE FILE TEST"; DefaultExtension ".foo"; FileTypes [ { typename= "just test"; extensions= [".foo"; ".test"]; mactypes= ["FOOO"; "BARR"] } ]; InitialDir Filename.temp_dir_name; InitialFile "hogehoge" ] in Label.configure t [Text s])];; let bb = Button.create cvs [Text "Open"; Command (function _ -> let s = getOpenFile [] in Label.configure t [Text s])];; let q = Button.create cvs [Text "Quit"; Command (function _ -> closeTk (); exit 0)];; pack [cvs; q; bb; b; t] [];; mainLoop ();; mingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/socketinput.ml0000644000175000017500000000422512124403241025000 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk let _ = let top_w = opentk () in let text0_w = Text.create top_w [] in let entry0_w = Entry.create top_w [] in let button0_w = Button.create top_w [Text "Quit"; Command (fun _ -> exit 0)] in let buffer = String.create 256 in let master_socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in Unix.bind master_socket (Unix.ADDR_INET(Unix.inet_addr_any, 6789)); Unix.listen master_socket 3; print_string "Please connect to port 6789..."; print_newline(); let (sock, _) = Unix.accept master_socket in Fileevent.add_fileinput sock (fun _ -> let n = Unix.recv sock buffer 0 (String.length buffer) [] in let txt = String.sub buffer 0 n in Text.insert text0_w (TextIndex (End, [])) txt []); let send _ = let txt = Entry.get entry0_w ^ "\n" in Entry.delete_range entry0_w (At 0) End ; Unix.send sock txt 0 (String.length txt) []; () in bind entry0_w [([], KeyPressDetail "Return")] (BindSet ([], send)); pack [text0_w; entry0_w; button0_w][Side Side_Top; Fill Fill_X; Expand true]; mainLoop () mingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/eyes.ml0000644000175000017500000000510012124403241023366 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* The eyes of OCaml (CamlTk) *) open Camltk;; let _ = let top = opentk () in let fw = Frame.create top [] in pack [fw] []; let c = Canvas.create fw [Width (Pixels 200); Height (Pixels 200)] in let create_eye cx cy wx wy ewx ewy bnd = let _o2 = Canvas.create_oval c (Pixels (cx - wx)) (Pixels (cy - wy)) (Pixels (cx + wx)) (Pixels (cy + wy)) [Outline (NamedColor "black"); Width (Pixels 7); FillColor (NamedColor "white")] and o = Canvas.create_oval c (Pixels (cx - ewx)) (Pixels (cy - ewy)) (Pixels (cx + ewx)) (Pixels (cy + ewy)) [FillColor (NamedColor "black")] in let curx = ref cx and cury = ref cy in bind c [[], Motion] (BindExtend ([Ev_MouseX; Ev_MouseY], (fun e -> let nx, ny = let xdiff = e.ev_MouseX - cx and ydiff = e.ev_MouseY - cy in let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. (float ydiff /. (float wy *. bnd)) ** 2.0) in if diff > 1.0 then truncate ((float xdiff) *. (1.0 /. diff)) + cx, truncate ((float ydiff) *. (1.0 /. diff)) + cy else e.ev_MouseX, e.ev_MouseY in Canvas.move c o (Pixels (nx - !curx)) (Pixels (ny - !cury)); curx := nx; cury := ny))) in create_eye 60 100 30 40 5 6 0.6; create_eye 140 100 30 40 5 6 0.6; pack [c] [] let _ = Printexc.print mainLoop () mingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/images/0000755000175000017500000000000012124403241023340 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/images/dojoji.back.gif0000644000175000017500000014141712124403241026214 0ustar tootstootsGIF87a@yqe(]0 UUUq ǂ} 0QaAÂU$0aQy8߲yy(8((ImUQeq]UE(me}},((A (Q AAYA$ߚמ]˪},YI }a}yCAZI[h8HȔ#c1'M*LSB9HAE˜1WMJjL/iy5^)c.YRb%V&ZX# v"[.Q#LM1"gC&4aJ)XV4 ')QP)t ќCU5Mz7c<ټTK+#"Ӝ /dC [ה^#pDA8ni3)T ]5Ŋ㞡AEN-E. u TJWpIp\XPTH\%D"55ZjR\!ZeTBj)u'P)XBVra5$@BBw"PEV^CuP#d$V{DY/|《mI8%ETWQqeM84@IG@UiDu1CJ"HɤZRv(SAyQ(G$#A&;6/1|]81lc|LhQ$0s,ShhPt@V ^U[Հڤѥ֩nTD2ŽΫy$s"BO$IvażҦelde*pt 'FEx`SzEd.,mU(Ԟly.hEY43( BjBHA AE6%GMNON{2H|<"tZcXA^c2(HL_aJgM\g DsZ(8]b' SZ!9CcTKPPo9jE-x13%" Dł} 2(uevYCES#1`Eـf@X;Jgts =u}y PZoVPd!vU"ɋm~'x'jfȌ(x~Gj !Rh #Ђ( `D'%mYhS pR%@F!@q30;y;].6!` uIhqBL|vch@JXOeh=$1(`jג~ג~xGqW~gx=j( 0S.N ey(f}4;P$tLk'_1!(0J0-#d@;D5gW!#5gD{`H(xYZnqUXx('-~njhbq1pш`qyw{A ]Ix30a<k2}@B@,@3@!p{Z*CSe`Ivu+ԗhZd%5qD";!x, wYh~6i G7@i(=ɡkerQ:91X 2ga Pdf'pw0bA ޡ";o$@BDP#ߧUPHfW0P{&j80f ɨ, qZWZx֟.Ԩ]qojj=Arz mtXk,;K/Z X%MZ֯xX'/4Vp,!0@ ` GƎqJ Uru;h%":p){V){ٚw @iي=yjwiY"Z@. LH-h@u2e3QkuOGTitɤ n|Z$'1iW)ۋfx'z~Yx{{'~h(ܺϺjj fxq3^I^ {`hYmt#vShHEP4:G$k3v{pmUS5f0<ŗ)|)ƪ  ZUp[(;qIxw91?px9xyjY&6q(T5PT "숎'a@'ZL2% 1g:XF9zYBB+Y'oMGQh1X(R#(GͱIл=`̨q!=? j, =.c=ʎ3"05=(4 @kZJɢF;iL`@dͧ"ʕTY±ΜvYW ϝ Ŏ#) [6ˑAX!=wNޥǒ,W'ic4=b>N,3Pj_z:בS+4G3tIm: $QF4/0P'6zq$;!"Qtuׁ{j @9)Oؽ'업p \6j.٤mj-3?ڠ> N3c>y ɮo`SyҔ 3 PYm8,Pw1PgT6yAW0>nM3X {P x1^Ǭ;-m!}cP6]N?AzPf5vTAX61؁v4F%5Ex5ص2VٱRօ61"B0Tʘ(JABQbB\@a" D%S^uaю!1_o_Ooh'/G"L84 /&pÌ;j8<8!F@)4fĔ10hP#Q$*3ϞDe҄p@W/ `i4R mƲ P Y#n1V:XPp >Cwpwc>| &LQG͐!z=ReY|%(+ztReLBThʔi).](HB!L=dh@13[=k"1'жTn%(Y8 X?fXb8@:X:=vA U&<ԃg@Zf" &֙W2"S屢ԈQtiEu".9LnEv@H3XLȍ]DW 280XlLYۘIA5P14XgJ`:擠>s4Ѓ ̰h!C0 S8P4&>+Ll*T8 畲(@q,,(Dhe:&3[m{̙) Y>\p@ S@Hca@ٿobZfdL6C"xDH*Feܑ=h^E'@/hQBZ@apDv/8\"V4gl4iqA DAE,̰Udǘ^s L29o9# $\(L (A, i)~:"Ƣ( <qc3YJE)#P3ϥAr YE8v(`* JP&`ImWŮ8 ƼB,nOb.=` =Тafhnx>4D⨈c(0A(8JU Y1]#$)bg`V<>)@ Yɫ>!؈<@Ո 3ǃ !#az _ 12g*8"'*QфqbOU&`LaP` .l Ph(R iN&zCa5:h)!8yD)*L/.`F4PlP)@_o ;(DCrml*H7Ȥr>NW#+Xa1@'( !9PH4"8/A:Q2@I"\Gy# 4LCr@|0FXP<aL,` `h>Q$tT]LpyhZ*qHP`(IB1M% 8K*a&WE#0 ׌nG)"@p1"ׄ`$HK`pe!u4ơ @ȗ= g0%FHP)IE p^QhTʥ82P ʹ@K&W`oZ$(]('$B1WZ#u)_V^6p43`P98϶;C3II%V $fE Jp 2 CW1 zvFdG9 ob'|t r]Ѣ V "CWd93ؚjM%MJVVypVbбIErp63hV?`[pw?^$qEy5!28 aB`Q}Ѐcw1>D5Ȯ/`FY ~1@$Bw!ɶkP*(C5"#20#!t`4ua )33#FAg=JuXNJX@5#T|7OCs50q "}m%7ؗ^(>cA6f ~3! rRRJQ Wz1^Tgb3%o5ԑ `.zcq5CC @!`V7#9]C#U)/ZEbWnu }3!K)GW!PB8lpJV"PIrp^8u10rUW`d- e 3M GDb>R3p<7'`0Q-S`3XU Ob1  `A!5^] C0>7%)W qPV]f}-R213 )lA@#g19҆D0W2!N*Z 20z2:zL 6AsoC^@T!0  [\.j7S!3/'8dx0c`> g>s^BSD!z`3;h!`Rq![ HWN4 8V+\(GqmSG:0@Irm`hY2E \@w}8PC5\smRC\ @(}"(k}w66VDq~`8:E*0И~qd (U:A54 8R$3q 8*QD 1Nq1 *25H5Z @|?U@Gv(ߵdyD?)<O8G\>ih řEce9b2<0Xbe@5)` %S+&%FBp2d 01 A' 0Ӂ#I*ҹCWw~QwޙP67w91ZzsV)CDtjwud %)0^"e)Jf!Ѧ[) Lkt58P6 +1&5s 8S@Rap, 3J|p_\mUXE A!("V d')_w#wiz_} o8)fA70 _9rX@ ASc0 Δ 8٘)5 %x[Pi.*Z Yp b0Iae琰wy">}7!mrHK:re%)"Kbfl}Q^<6&(/p@LQxm2qȡuLn2LQ&6[c_A.h0aDM7(q"+"5x!OLP8R;Q)0* _Z]r]ȶ+)pAH2R`0YURZBJHJhT[+U3 5i4'X0il|a )Jt k77!f kA!"% *)Xg[X $w rpeD!ij~ (H3x#&ôr3Qh n5ÏS[ J`*ګ͗;ghʥCr2'ѕ! }jy^IưJ f"3P{;1SQ+R]Wl~x7/S m3GS!G_v(A19:&H  FY vmm_ᒖ PPyVZ:A^zЖVvok11_6'P$ee2_pY<_h, <OuG L9S[iBv[JA` PG]ՠi58dq#WLT(~bJ?^0ӫl)[e q)lZ\XSZI0 e0AѸL׊Ipп> _k)+&׶ RGQVI4Z 0g+C)t|a}~0s_P(3P);G~_vee7juFp~J]SZܑ2\(Z3U('&1sV`Za`_Tuk\ij.)W )!3W3zq w8 +pe~VTKepXJ^3EiUy`:)cb&pA6@uNq PH:- /ppFIP=p bkSdRV!7[Q^ 5<}u՞]JYrTpO}7|nE) q~ '*[!*2ST0.uP y7BX Їͧ&h.. (xԟ/׶7 5k=!u-}}04/bP70Z KPIT*3LNL+!ZN 4'i'Q/bEFnu m*׾/LPC?rJ_d u `,<@]p?7iґ4N3*s G;/N&QU+#@>S"T6 pM!;0r("! V@?r ͭk(G@0PG@,hijA!p*Xpᩈrt+1<]GzS`&``YqAN%R4aJ2*ah , d(K(tթFym uAd_ DD` Bh7<)Qc]]Q3$97( *<[#SBS3WBcQS/GGS]hGhVQ)!!NQ,JGQPc+)) BB)-,B9F9F999p<9L07n#h߇.;# J %""ZX)@@JB0𒀂QD)3FA@ 1t@jSV9bHR&if ByQkmХht(7!cIP@ϟJXihܩG2 0 IРy0 bFZVeޘ@ CM ialDSrwDaiD,bTE<4cEPaEBVtLc%B 9BpZ;QrTljO?!=IQ(lT@,E,BdDMtS%Pbjvh1 @^TE*pHA ЀHx!"Qx@lP 8Wp9ƤPMaa|i@ 8H}L$!63RAQHvoTD"] ]QͲ(@&AQ7]UehnX0[!Hhro* }6ÿ\̗aѕLVH(`1~%u&LA8~tͦ*tg͜Qins?S-:W B)p'Vc;$`OMTttNtmɵ.ݓ7pp=@Y  5A5q9`ťpE.\1 'E5.hD@~x)8JDin^ $յPhs4;6@3BF|$(@:!ZY TUD"AP#|@Q-eɓ X>D&'3*A!ÐV!8Q7^p Tt?YcA T8J lh#iYAb p@ ֪g`YJ<-# Cq`!¥tMc׺@O(']T0M\P.93?b hqnDS2!<s60@lfA>p"  8ҕuJ Oa )!eaf9d J~)(]шfp z)voO IAH+>t>K]\ C':d尜7W$€M#}jG.KMU}@b h <L%!@R%Y`AA,s>ᔨvB̠[ais,O NNE=llPL`v5I#@SH  H p SQ% Nr,C"9At&UE骴N$IbxHDWH0$? N(A .7A"OFb$'A4@ !Vw8x ЁӠ1$ag8 -g%+gPL\Ζ0yk4б <%OhA EK< #e TPG|*]@jij=]wĬٹMH]GN͑:$ { Cdig$khXAlp- ]o"+/0{3N0 f~q ! ]u )a S0R' !!f++6"0NAI5lI ;4i\FW,L;GxQBJW5+@F5wm4vA`}7t"bԐ6sܓaAM(>s 1"&p =U"h^GN3&A!b k"F 7I)XcV)3d# Fkg[\wm7mdr£I#t SO6GEb@t>C(u sC*{o.0#q"oMeO!6,R1*BPJcJ1W 4AP1GS<fR<6g.=y4#:@(aq A X G0!V "b N@B'[P=xl+p*POI13bP@5DPa`*WC5:у34CC-Vhyge@y D8Y+WAƖ_6$Y1I B@!"F Q` tb) u $p !9qQ&w#,u7EBd0iIP0,0X w "H'PJ+`<"%3%`Y`(rP=`=nS cP>)@Ey>a! :Ն9Z1 쓚a/JWUWU1!a-I@"w&:`Jৡn`6<1IpByyiy"yK)Pd;"%U'0zs b @5101X!"c5p4|67Y#q3rs 32x^{k#xXpU2 UY (B ϙA$K‹? D5D&qMK?25 1 K' =ōsucL ?"1/[PuB2"J4@gUplӊO.)1B$t8fPy i]Ekf`H X1ڮ ?@X^\5x_  QbEaiRVYZ KeiBr-a%x' W /c T7 fsPU{D@^"7?S%-w#32-0X$B0@I0P,84sD̓[Z3$=As#ZJH5aep  {2aFoq c1z [!"V(SN\sPP@#O%2͈ Mru TN@E;XQG》'-5Up! [ !,Ba05#;0tb/Z7` j1'"NEKAH0D>( 3b{ V=9&,Cg>Ygn+]sGOr-:#5h 3ja S1G'!>LoGjD *p 0H! 30=^pZg1 ZNN;0)SK2<(׶rB gW/5о;e6*۳-L]i0669A{'(|2B1332ġ5a1119x8q23ApqCs4"0C1U2qR\VA}=]]ֱ==m NBaKpSz?\?cy%G(XŁ eDyeה-(RHqdKRPp)Fp`1E |T`[PI>EiSC*9 }!'UTݘA!k Us`EKQl*WoծAl[g۞i %*O*%$ 'BƼ堃.-FrƬ OvZ` Q- > :iRM E3TZAG B^%c<`UUt"\Z. ,L|DW6pc@[X`d RU*84P PECGdFPQ E0@Y2&EPBY-$k )=MA8"&M@&D%=u KڳJXو<Z V=0aN65FXP06GLB{AB `BH*^l1,@eY ̀BL/DqA)EjbHUF.-ZlYEmQ(B]$DT  9)Qr uP1XbVFD4]y=pDM^}M4$oXE\܈j A+!EB 2@f `a2u $JAS<iQPQMYۮ*ml(0)PaQ'!NaK0 $B#Lb 9DJ,!̀ !(i`хe$E q.-'AI&(aD Z86\*^3~Ђ$!eKhn5GACaY@54ʛk"6XJ+{W)&1XCBF`fQ9Iж+%(qX#9wT M$NSēoAX~UQHBPXk5οMpJȓ1t!f@hL⒂DiL!#Cd fIAB"B,D c 0BR.\q'!?=Ax$!HӁu\T D /ph2fJ`A]PG;ugu827N~0pGkЌ%R@X9$`#p:bnapVQ δ7a ,撤 Iރ0&^f#KJ}zHmg#W3DbQ33+?WVh/ 9R=6a PX(jНc,ʬg \G h89.uVG[Ь'Ɛ*0t7+SP/f5C4$7͒CYfX,h  % MyI(a# U%VeG`! >VΐBݦ!] ɟ\ La렮F5%:bc6ӧoAeY&El=H.E Mvpbx @i5h" 7In_lR5cyF)gl qfО=3㳢]([K}e@n  ~i8z-nqR/-`n$]W$M~G0+~4TxE ,x !@z:tl# 6B4!AV2aCm mtA.7K-B E3ab6=0gD(N@@}@X&:`Psopa`v+ QPV&9 HJІqt(XdI&af!ATH_?f;$Ar.7G ?Fg*s'jdv|z3[BΆ]O<d IcIk 11XNahH)(J&I 5pDŽK?F+ouoyThPpFjyM Ui隢p+ P0 dfq({35AH!RhPKӠed;:X/ U;?94 "J q:Ζ"bfOZ`A p Ip& DSQn8N va&qD,: vHb3/iqcNc(!+p=A:.H.\my1sA8g5(#d"zTOdJBXhބih'尢Z;{b][W p/pG,ĢeC6>oIL҅<#(e4-: ,yЕ"_(ǚJ#$>Q5WV]]IjGۈIl3dĒJN+VVspUlb&TIGBZ ba}Bڪ{&B(I$*@<2jI8SCQHx7ӫRd\e౧V'~;/P&`4ƗTd7epFEJ;dGlG@ b'q*]z W;t3lxƇ}3']q3,3:VWyQHȃWu⎕/Ԇm?df (I _]PNTLNPpەp *;w O 7%*6WJu3c5h.^` (TPc[ ef3q38~}O]]J]e4>lɇ{PGtvY%miȳ`78 8toU*~</x/<]pϗJ?0*-tB~}xl8"lZdĪGB-P7ZHrsewodBul"]+op1E[]Ji%0#WEeP4oEV7cD*]ԀBCI>J!pJ $ckC($z\#aBJ"Oaw*Ds׸tm dPcGsxo}⩻쏽:۴8$ą\y*qpMuF4*VXMAsD*ʹS'=l@OQ_y4 IBc)hEƍqaG}&4Suv8+8\Cav/K4<3f7yܙ@ߩ>#MIB<@&:04:# U^S,0e3,a6q/qGx~W= 7X0ҎeUVwbhZ[Z} M8 GB3MԬI7{Йyѫ?SQ'~$8@5:)r,*DB5PŌU[uK%q !MF0J5X}x?7 jp16c- lm@kQ8 lcf;,K^ UiBꃗPcI(񙺙X*TZVc0c EѵP*' BfHp_)@Bi߮?xi[9&YowK5wK cy,oq;Dhce[DXS0WkL@AQ##GGT#VSSQGSQQVVST)[]]QSV+G)BNW* WWBNSZePee+PZZ+e+Z+[XSGcQeVǑ]uyQFUcAI0a#eh9Xaؘ(NB̈pC1 uI(I!W$M\5qZ^4>_QR/`tpVppGiU[͙ud㦍/ǐu1dQ(3[4pǰ08c\Qq.fcE*@@Ɉ)]]DWa1[Ԥ%BD˥<Ţi՘=-UZСIح[WP%4ru#lo3sYrݔ), @!5g`>IhH&t1]HGhZ1R46 %qa ˰ApI-"LDA^'DDCEth҉+S2C:%X]HT)u` a+9fMÖyհw{s'2,@`A` |3 1BPۊeh 1k-(bI x` WLBt %QcǹBSeȦKc SeTJIBR'e"Qaw@ ĘGM{XfA:zh|C`W8qL8g}dZ]I u1}xЅePaLdJ0@` 5P1m#0ɚֈ|䍸P*YAYpPJ)@)p]XFwca9n X L<|Ijpx! 1ҡhЊàNX21A") StY+F3*I+*I6Z~'T ɑX*"V4@M.^ t7i^MWS8b\oqŕ { H*r4h40tk UZd]N`1!pDI jkqZQVTF)]+]:Tp_!R֏NB P9YvR  DZY9k5Nq zP I\h4T{aHp , H#VhjЁm y z( B|Y)DěO[Ȁ{:lǁvJ&؟.,ICȢF]9`،cha,(t5sHCD Qp؊@)#xdh! "@ ,+X*Dc!9&BD` Mo,wн9cDeN4  b0 JQ%t.sbBz^Kv$ yK"!D7ZdN$b"Hx$ J@P1$cpF$f),7HoD0HAJ\V P4]]n!7IթE<V7;d/f/QN*YVB rӘm Kb:fY&+(#D4(X9Bt#SZ UP uc3;ȴ6Ugl$˻Ҵ7I#?zَ `JfJݸ}BQ[+O|$D dqm=Gȉ 8ѩׄKiM"**'(p% y,paPa)|3u,耏Y:%@m&|GCViĢ!H 0CT1'YLu!UBX`XK+oNBd QERR@XY0NrZGgN9͉LМH G.RPp1;tdx_X/$˖BZ'(uqvѡ.RER@ǝ+UB9IX;^J*n\@7+|s%Օs!BvHUxA#ÉU<&(8 C #(Nq}ĭ-lR h:@ KV|s,&FSGVD.ȣJ U`FCx<79YML4aw $ p DЀp̽(@QG( $8tv|cލM(Ϡq(R dW)qiA$#.Ybp*o|! 2,ʱgcG15vL@ǜ1E h .px$Cɮx$l *ยl. ,LqH=5<݄d-x9t$(`̊U0HTA&& ?\njݪsJ$pM4P.`>Gy1 &_tY"@!QQP&A v"$XB?!_? @p `:Z;q%00L33.B@$x1 2mע;c4cJLss4pJ'pS6дt T)bV+DQcHQ^ 5$pJG >qq3 Qq##e4pw̒:NqUwсG~S&"X h0vH;WBX? zPI HhX(WAg: su1!ǀ>H2\KG 0""8#6akK$4eL4VNՐW 0q{w:X3x-o)0&AUA̘J5?@Xz 5s$B/:2@2EpDр M_ d\q9*!ׄTpД  Ggl 6%~БU YQ`Y`13*_A|U'Or,I 2 :׆ І ;P'>0}2 ړ$TiA x6¨)đFل$9R_sJN)S3`tN甗u= ~=ZqGSf} !%BGMИ)"@9/aWF72>\8q*P]W* y KeL$ b *i 'wi6TĐRN)"=&Z LXZR:V~NALqUwO7aqX?Hz. ;=89pe* mikIvc@WoI|3!@.B C$\*f p$_`DG NّG 0 PTYj&@Y*ʞ=Xp B`qQ#倬H XpX`@P;~ZzϸڮP 0 ,P+,0Z$+pt F HUXtYD*}(Q9c3 / ,*jn~NyzZZ> ȊKPHq3TqJ'Av0zJІ:s5IE@?@D0vJ0uR+8B) 0 1 F)Q FNhoSKJ+l4, 9%:Ǣ*3ǪiXW51r}w`?7NNI`$pM@P>Y!@X/ 0A$@N-QOp#_Ms \ȡp W,pT GMN)> ;Tj8;2B bhDxE;~S p'0z}:zMP?Lmx;@E\0 Rw#KW?h`5-J774B7"P2@/?*_χ2f@vl ` 5;jWz"XK)pRB,aD.ʂlʦJPX.' s,y`xh#9xMu =y @‚f P"ME+2Cqqt,Yv\~lLL 0ɓPU9#W[)=4= 5`$v2:\ǯPơG—Y*/bo^=.D$.2ia JM^|-+M@w,nv ԗ}< i `b@PbiƐPP Y{;cWq4:p7. X @j~>YZkVG ;/KQK pYGe8 ##Mt)3* 4PlfQ~t,!Pz ) $ i)-hh ~P8VBw $zw4 hGi50zǛ>R20A8 }_B?+P].%e0g}`D2JJQqt1 [4 ܐɂ{Y^V*ςLb Pbr-i&|T  HP3X`=?y*İL0ds&&7 :)92R2H Mt'9f[6[5w$dq!BؤxfP,L3Pl=8mbBـ909.ɞ H#G,KX>$p1*YRv o5Lb!&($0$y")MkjT {ͻL *^^K$ꖮ0* pLB0¢ >'V``=PM vꓡ'g*3A#X0Na`H]+Z4nKӏO#( /e>.00M?R?p  VWqDa/Z 7Yi s` ԝl_X0=)Y~1@9@5`. ` z0tA<9 K) a dĿ▰*>KN?TZo[Ypdd xv`0;Ϟ/T7ko?!X`wW1r:$`?s>E@0BTRUePq%q16&Q6AA!hH12庪2$!++$5<`BcaQ"-c"bR.=AQP"ԢѲ"A$f 81*zW]t8 D@lpB $Ha 6$ ,TѡE 3/x Q҅!f0TH1Q+S:l)!.SVX2%!rp#D#lіXn -5j4®,`@`tfX@~A 3@N CA9f!U0LDFJ!d :0p(0@pD!cPMA L NT@ND1t&``D'XJB)S慤- #31Q S+.VBb61Qʘ"h Xig 4A6 1C  Y&1S QHFA*6@k5)u"rcֹC P48B .N(@% Jr\  M2`zRAN13 h`1Rpыhp\6)%la@` pδTpǪ݀sߐN ` ?*vs. ^s.tx,BT,4PP7v-B!`-<@ud 5.@+ &d X19:j=$נּ+|< ;oy $\H"3`aE(@F2H dZuLIslPE*: Ru`D\auBЧV; OȠ ICP_Qġ R /@q";aygr|Au$`znCs3VBL\`6X{TA,s!@^b^@7xd0Fjۤ^:Ql1q&0ggxd~}bwf ] T!nY`1IJw3 WNn317dRg^A&7WM.M`:A"K7LR>47^`\dOAׂi@lh^!@!" D;x"mև,AWH Zp,*PF1D8Dy!q3A&h"p12Bp z/  /~8/? ^qyx%.M%$aS1sPr>F.J`0PId 4P1;%"8>զ70(rT,@YW2u+H XDX֑&q& X41IA 2c #`0BA;_b pBhyV^hpVuWwȑ]IH9z>GSАP0<\ӥ{{h !;;ltB%DW+ONvOJp( cj;a0'!pXp7XgRwh dx)@O9QA9bQ1.|ba5^Xw 'L#Q`ٖ"1pT^N*pT6X,h0HFI3.@;@skBH&ДeHgH3pY)YDٓ58(1Dr7VϑrehT()(xpYP[/m8@wgqop%19E=z0` Y\=0s#q,+B^"@6TDw[ReЄ`|Ux P ~'k=9w;&/gB&y?\`DV 9' QX2!!eu7!Q[_qy0zp<>P^Wt)E3p P AE0s  L .;p 07G$ ,W 0BP: J0PBX0Zb&fB~ W1`9R)`@4 p7B*ٹWh&̱L0P=mmtR4W̱ B@$X!j*HzP^if|t'+ Z,Iyj3'f0kf``&#Б/qX'GP1AS3!rXQg^eBB+0L"=*0IPaPDs@{ņ B6 ;zS{VvCJ ] }DjE/ y/!.$A֢9YP( .ܑNJzKzm dRj8w)kiB30^!X00`\ \{Qz!/*w )\$jE1wuTD(epk{@7`@*( P?P{81?c)p(]2Ed:_Iz8Qz]+ۦ˲@y zOd^0/"6UE֗AZR)'!!t8MV ch< Es!s: p.(3Hy7zOoQL@0M S@GAG(& U##3#$( 5 |Zʫm6kE@0IR0]h ˠ@0J* 66+3`fP+pKvJ3`rv <$V 85[h.okf84L#礊8pN 1b %!:.4؆)̀Aڀuf yŀ\?X&Ds?0wSxzrzBFBĔ1Ĭq+ #HA\W "H!Ba& ,@Z[r447  xxh`TU2NP`*% PN-@ b bh@K5FaH0^" G('ޕ',JQ+@ R <*sW@}h@ dB~u G[%!DBڠ5-%X`䆿s]{&@ $5}X@-͔8aR0T_=S$M fGi ":gn(:R[0O'8(*Z/%#8ҟŒdWj}^Ԥ&^rL  dA%%A^VE8- z.bns+BI oh "0F^fpǁUP"W:a:C4A94^ 0*#^8*aI*P` >QPo,7Pp@HQcD t4e6e; @!w$ pm,P2\~эk܁A2GW5+Y5Qʠ™Q>@'t3<ϡ"4xF " ^άGG;jE|v2{I04X . >]1lXo_2$# 5dy &EXDp1*pF4cHA"=3T`TB>`alYQ֑fm1(!o#wWvkC2= ^؄Y4$`a Sp50> +X! @ZE+@ #4F@$ $p&NlB@LRa((7#CavvKb9eFj1*S+ui6*AU;`H;A@` jJ,' ,!ekR  AFVSP 2 `Hcj345PgYm'0 GD 0T1gі?^$13=)02a9ao,nWb =4$|S |Ʈ QV?@ |JV@BA}40ɰr^sd ʷuzC1s:@h+F2h]5Q+c Na:!)g(x)7)# 2R^.PO-X 7LsUpuI2%ks{sC2@'+ld`%!SHhwFPJK@(z+ !pXp10aFT:? cW^MD>_Y TU(Q090>fZu%CG@ sx@Y jWh ɐ=0[PpJ ʡnIvA FV1DZ=aAcAosw=A$E+' TO1=۬$xc + D'=%ub\,kA D((\6?6Qvj5<< !H|>'apO dFTe8*⶷̿x_VUN>1uB ځOFXXjf .z >W*H3;8x .V=$+l[3=\̗,PRSBg*P= HE`J(GGI[ԫ6pԒjʏ57 Wib~,2A~_hP~#@w)Mؿ9 EF> ͞ u*JFk! x0`J<0$a;P>e"  -y Nc"7-E3Uw@"ȗ^la3?M+gez1LA<&-B EF誦UpO(A Om_ipYEGl`QYdIVcy0D<`$OJ,ֽ4%[[1 `!cl1شK(0LZV+tg҉0b@RQSS!RSCYPt@2r52urt40rv46beEA06p+4D|P|AɸyYXQq2`"""#s/c?!2hЌ Y `"m񢍈p0chPBx?|_=&@#h?5ځIE!&00 StE2VWSreeESZ!*`R\8mțSp ( )o<ɹ^ (&gH¥HG5Ʀ" !gp2d1C^N&t'N*F I.(q bZ¤2eP.Smw%W[+rSM5.cDpKW<4( S^''Չ6l 'h:WIFY'41  t@-xOpD ЂP@B DlᶑEEX ACwA& N 褏 @!pBU &4!r !4ae䇊tQ.GhY10D)Е68"6 vaЈs84v4QŖ1O̤*,WBF 0iёEƖ۱?  \<W`̃ٶA WAddBTn)MFU3Wp\q(1tTU.l{nPI0bŗ>2hL qz@L(C9gT"+D@#b @!B"[,GRlDQI3a N&sfO|-# L Sp{S:LQQ_ͧ߂ W,0B. ЍQMW 5H5z}b N!\sMf6obLHАH@CP@dC>E0`C ^I3Lטf xѠ͚lVIv 0B8 LO_*0 "p TS. ؛"QQ9.0kN2 @ ;B't$7 *@ܐAU@CF%` _t"2:TgKlpy 6b5J` UXa _4(X" ry-2.(rr!.JY*B'd`bd ?@k) :IA C ", ɂX , C$q! C < p.D"L.}aر/ 뜨jQQBG_Pp@П (xAxP@+Ѕ. „C"QKiBYA E9N0AlKVD&L{\ *$;k;e )HćB|RƗwHgEDK]cQg` KAA,m ~ |2bεb6E1&H{цh0h@I||&ۚT2r6 B x(˒ )Dr "9 p'4{Iu^赛L3tmBbؤ5"oWHsR GlA漅LT@1D eB'A2th@sؑ9&273`i`%hay(}in 0(uI2tР i-{Јۏi<"SB>2> FYvAaijATBe#TF5' a :Tf-|>sLzD xa P@D@ i@4F'HS`!l"V T. 8ki Sy$ay"y(h?҇Hc|/q0hT!*CH'!2Sx@~U\P4sp@":el9`r'HEhkBZQ e 9E33& Bo19oQ r|1Ԓ8 $}X:!׃Cc\7d 0 R)-]%1y d(V';luh4/ DqFYHs<``a'"[%'i`&@v#I buI`ptD\/F hQG@q_\kq 7PF!/lG2y1PpAk@FlGЄs7%"dh,@mB+-p6 4KH,?PY[@RPYn٠ Q!:, A=8x1 ME pƌ V.O(O\zY Ln( qe1 [IW-[*$s5l-B xXP@be%KPaUR?Yp<Q&E7Q5`Fa:  'P*GE2 |'Z8VxY7z4TUGoV(\1@*-&s3 ) sHz iqB&W (>I3"=B@3_@7P #D@R%4X @_oYJ@ f0C 2!4 "Ÿat ?60'UWZA8(/D B4 dԠ }PW!:$0yWz$:WXĶ%_b J#dfm_f'oIC{Ff"ZZQ Q 5rrF[$3pe` @(Z\ccVUe@XE o)(/>d`:2iEP' j.?Ha#S<@'1"#htI,(pbYe+0KjvI_Q =QCϖH4  'kMP5 * e/ZG76U@ kz(@!Bk7vh:8"u2 .;5"pF7H0+0PP@Je O3K7r##" {Y{!MbFa!U?OG" x[~8'\ R1' vLx:ZL339"Z PpT_Уge7;$_u;\KJE7}ty_{A  p!qX !j/ G 0vN'Hp! 0yb Bhv WrK:A AҀ2v1% @GWh Kj/B QsA_X,w; N:>s hWAPaP6Jc~/6 VU7Yp!@ #ⴌRepFu>Ae:.}9ܰ1d7PBl;HUW[63s Ai@ ;R-[` ]ɤ"{ұ.AptøvW5 I&Ae u oqh /ͮ(\\Z4X $w)Py>! d ><tA %(`b#Z [[`"V{2 l| 2+"@ L;; Z)гq *X |s[=b'"D#)J Ie:s2" X~,pJ}dƝi82;b3pz)-ƴdA$@!g Z1FEr HYrAG}g0m8 :(g(Q-* Bvx)wPQdT隭e/zU%Dc`0UX^ 8P@bgYƬL x:`!Z.@EP:Z5M g;?r!HЭ@ R Te|1A91@ߏ$A롨**(e"*tr;; J,;<@&Q3<,_ HwH dP&@7,:Mw,>UףUȠ>Mٶ8/I0uG#] e50' "bNFz!o \ տhp IkpkV, 'mЩX;ű4<6tandC ;& 5e N8ŕURR d!]WpwyN :@pA1 {ŲLF#:5&1eYD>:'bI ݿ`'#C?6%-5YlK>v2$1A4Mt)bUw@+8GO 38bOV .5'L M5$ .$M  & "== `-B[Q++PBPiihXPiRP,B,P-B`PBXXi 4!4^ !J! 4!!:!!*p! @ DB.HtH+S8 #8)P IA-5s.߇KZ2UdCF2`#<pF LCE+Y=&Vˆk*"|F pKӢEX~ ʗIE ܻ@  W埁58uĥM 2bX)#LF"JSt&ʒ "v!#@jB+h B](S!LA̺2{V#@ABZkW_ 5MP77`\B 7+DP@^0'zH0XCv1c@QB-&`8u Í0S|DQG<'cdnUIHMqDL1EAA0ByP1rB!CRYxIxpIRYm$,П3B0EA.~#.]ՂW䕋^t.qM+l RhpOf T!\$5lK SLƍ`MLbb%E8[H"t19@O $1&CFuB{BD)BC)$@yc&B[ArR@K&2a{\# 6T0xE>|Mϔ3 g|F:P}:i=uL0FpieUZ!Jmw+tRtDpo)T!xәL8̉c|(G sC *8 Eт,&1@9[˘FP\+2"m@ QҀ,c^0@4Ј41BF+Djx !]%0GL%q)2PQ15aA,05a

q4xcH H)Br":p\P\ 0a$]#8J'^2l'!IbAH|j"zk i_=(q]a~M:V(ta:'q1= bx4I:'q'5a1#UK3n!2VV7!4GH^ǕhcY03LC(uܑ4^ ^4Ld0#`:QH -C@IDQIrb ~R1DG9gH 1,7"pTZ0rWYsFbFstα"V)["J f(gah4IM&iQ虞.p  '`vhnjfWd[z9iR%,Gz3 MG;H#|p89e@.`%aenUV- !dFm)Gn#'#kTkQS (:`0 {Wdwz'PA; (PhQg6a\5xHji,H,D4L)"#cA"GF _Y P/uȖ!(tȖl9^(6"qZ@ +2A H.05kd941\u E9'P@2ZMVq UFJzba.ٌ UI"Hr|I`,QY %ܕT`a6ѡ]T7|%4fS*i&ЃF sfC` IGƞ8' CapTj1'>@0٫b'e?%4H4yуG$RI Afԡ"AGVu`Nɭa4GVo,pv"+8˂1DSs/0$ LAa-EQ V ( vI IZ+ 7c{ 9 %P+ddhj5)" Ȑ';=MXN~BtT1V$t$q!K̩DMC?1`Qs1b `4AYZ *gMs Cz 諾3bQyRkE"RH(B74@nRqz!V"1(`hy5{D15O%d#dE@HK:@w+h4EPPI QQS@I\l%x=P9Ҹ s*+ggz/(BҔ OEX5>@'ceQU|k44`uCFΣau14PE{ Eɐ Fh.QC#vJ Щ6ZxV"_ӢVjVV[*LHf6~*&)۰M +I k-:s]AOeZ@*tgFÚ-5_*CiPT6v,jhvd߶kYlcἳ;+Zi eԳ;i^8wwvjуVGWnYjv~#a9f(}jY^V&}>m&pz+ŸdH y%L*'ZVd|1kmoZ',qI_䶕_~k>4z-EW_ϲ@TQ;K]Wl$&g |zwgs9Wniۉ o%j2y(~e;R {,-;Է?F+L37υNC*aNr>V-7ք%0oix-J6N3m9,}e(չ,8܌-9Yy7١hoݪgC>ٱڹf]+kfx٦z[W=nz'w0ԣy7È,Yƍ.{ʗO!<)|V+'ެ}u˟V[{"g,G5Fi NlmCR~3T+RS /k\0e,9Q.^ fIqE%ϋ~bMʙ2@ͣ,cYćԢ[g:R쌤94hTbժb8ʌrTpC\U8enY7֏yriMS:ΘSHǹᣤ0,e4s!ںQSeE©iVYqV-*JbLTJuVj"K-0G5Fuhڿ!ӃD5,rZ#]< Pv6[s>,#ӑ03)T.k:^Ku]jecAjUݟs;V֯ع=kRl\tl^gKlmM0=nzSr&uo Y\*_kc/gvHR ״Ugњ`6VݽrL[hj6V+1dTCrŭ:S283X\L9nPGIc4$'@ɚȋ䰎g 9 o W*N4twF4wo##`Y]-ga=2'Vְޑ9$ue/L+sӝNTAո3oB+N6/ zUdg@6˻pG,j+KNk`I6Jd.mn[K~r)IW$y:Na7Wf9:'+V_fbWVӂZ־6 :!D_17pO.t8m6} q_I~`|Wy+:暞dyL;-r3fUX p,t^ӧӷ rS*-:Xbڹ_(i>{g;LmDNy]yy[\߯9 OX)om|!'>]Wկsߥ=R~_=nG`}3]w ,߷·꒺,is&^F/bɊjI2OaxmRg|g5U~gĥQyZ}nWma?L̴緁~w'kdOLe\Lj\ Vgv&ljā vc`iy `ٌtYMI~Ɋy$`wRs{ʧLHzhiֆpHxΘp!P&  !{Y0yz,p1ʌzٞH0CJiل/jyڢJƊ"ꬥJꪉךMڬ͸抮 y஺7}9AָX)|!@}Uj& , ) 0F+鞠xj Z Pf{~v `Oz9J9ɨ+I:YڸYFxȉ(Qh 2lψ8Y8 Dk ,/E+<ۍuK)̘T{y Jx3kEQ=u[v Z) 8 0*;D2@I10 IN9 [H.@i.*\ 0{T'CvW˓j9ȐɊF۞iDE31@ 1c IͨJ٥E{j-*sÆ ̈́0SiF۹yꍊzGظܫ0]0܋1мڼɪyۓJU\0\()jhÇvvȎlGYɗJɄȽ~Jʦ̼  \\<}98̺̑6.Q)8Zy iӏٞH 8 I0&64-6;ū e=.ꞟ,:ɞh!ˮmHU W- 8.˿m} 췍;4#" Zp!0bcɿMٔwYȨuy۝ J94 pٴzշt{,!û˼ȝ\PJX p'@Y+Vۭܫ3zX밤xi9ԕ;pPا^]{)nL αʨ]xۘwukuvdۿ♚;I;e:쯡h$ 8 r; nD+c\;ȊɊ]yh.Ƶ)ɉ9)QWG>/b.#3b6ݍߝ\sM5;h<=p8 >֨\Ni詭 ojجγ}[KGQʐI;"|`a׾}n` @ؐD !F`F "xWc]3!*hf"VF \ jaQJmhB(XP5mEB .VJє=lπuV .3ڮF{'"jI]pƩv6X@~ZȄ rd.*|>z!A Gz׸Bsjb\Ne>,@HԨ ^C( 1걈OG= _GTb`@􏭵&۷7v^zU $*Eb0cJF:af}ƙrEPiZvgEEmf:5#i`"ɉ6>=GtTWv}!2R,9 7H{W_Ye^~ :ԶXR <(H+PZǂ "` fnpH$E%T6?~u3*iX^{HA~wd:HhAd B=- _eA%H2K{L@ βB/%--5yM88⛋mS +c& ;: 0svBy #R }`Bm"5hh`P/:!0.&, *TE( r?X,U!&u1-> 3݂$ 4?= t44ݴ 83!\wr-Vr"ytxrPNBҡيIA=&h& !Af1׭BM[i-Dd')cD7NTuZ鄜(aK)Ob &8॥x4\Ҹ<9 '2h!A 'U v(N@=FwLsT/%5`p7$8Z>%(h $#+*؅߾ժQ؃)ШUFVИr O0)VH?2dV ?%qTą +cLǏCDx kE A} )hlf !*G,3Atꖹ%SKЄFÌ_YdnD i394ٴSCMpgk ɜb~kg*JOͳ $?O֗l36J,TU(C 9⎤&uMtĤ x:vZ2mS 6Gx!E ZthBzA NuPS.9 @gJ9 z`8.C49Gⵐ$zo  l4SP_yQ @f5 pL'i/H :DoGLƾ)rf=N &39!4|.s4QW0Ǧ sM.U)@!ZP(OXD}#l YC0$ !.qP_Q^gs.F`=Hl RaY޸"^IB R3e~C X@PQTHL@Cp&uWz+8ռQ>@b|<2)LOdwLLyj .BwFxg0΄# f$㔀gt*BC#9})s!Tfx@R x `7k4!s=l'8E;$БVeA's5pzL> d`R]ØmSj>Vz7_ v@tCЁ y?Dvub;0: b~l!UmFj?Ey\[(A (WLDn 8ͧxR_ 1 `'. סhD@ъxǔL[Hnloj_+;y $M^'F]) 8!G q+11`A,&:t`cp ~t pNt`b`-ށe 0dt%88l'G| `|.W#| ɥ g}}56p5P~$w;mGbw rwk-x6)Q"p| X9SFHr[%:x $ၽ Y9(H *XY 6c<˓dl9ddn4]49 8BaX6 ^ .c>nx>,=em `a!oh)U=oJhp^EO GN/@4p63 31.VTQD٣p ߱q}Ffao.0a 0 pze+tP`Vls7Ԋvbs"Pebqc%(cd @gvusE *3"o_3) "rLa03w7Q[2ud1*?F 9OSQ$*5+`Ty y XaPŠWY(yUOȳd2CglKDICW=y }"'uTGC y@>SgKyjs1!uJ?}ضR6fy((>4 2"zG}Đdo7ϑ8!2z_#r2 13:3}!3Z:(Ρz QGiyE2U2IJ#‚6dl@s>3tH1x{SW'VGPN`|j!y&yvQ6U4/ L,BcWSs?r`hwW1$va4%ULhJv2 mT?P*G2  O>q:01x55R*PH*Т0:7:s35 eTց ˚1Ԕi ڊZl"홖cT0oSٍ~Я4 QaC K9 U y_TV-+*v9\rQ,H<-i6<  ;Y&>ڙmS25`Xy.dT2"Pj dB!Ч,7QQh\=~#g5}5$o FdߪXV?>/'+I*`* !KA(U12u2:h'!ށ+b79RaPZE)͓{5:h +Y^9N imy e4.W5rr0L®Uc`eYEX*5L#mq?~FupF^R78U@5[^Q5streɘG2a ;*0x@;l2&Ȃv-]c!su 3}XыEI .K;uF -s+t.$Z'$1& QEl8pp(q q&/"{=怮:56(A0=D#9F3 I"bIU!=9SrЍYw/  c=du*"AIR5 Z}t>K!<*ׇV5J;/ga9Pʭhוg\QŌa*PTOwҋgwA$v=Z&if $#]ڂNգz h3} ;Sx*Pu˫ԧ*du$L-ep7j 7 \Nד>  -\!׋cOZFy8 ܪ,R?i93d%!X@l'foKV?cL? `'j( T @I;na "uWQQfڲA S_a';fa47E(? Fm@뺸a2BQZu˚'@`|z".+.G*G\w2nfJyU"7hz Q8/U3v inf)1u Q {%,c-&2"*M WI5f IP,7R|f<5Wϩ ޔ2$2> N y2 z5` Zw#ℶ*zyaƭ+NF/l*AK|Q ^< ㎳l)ՕQMsB+hQ.'SV3e|Qɉ*Qg\W Ѡ|]TD|Q2A8'Zøm+MC n'hدC>IuE5v̰n`7g+7"($my:\xߘs(p5vx}߯@eLcHq+5LJt:!;Dn M榪 G YDCi.p[b@RJ腕*1 ">uSPT@..y!QuVF8f "("^$ա[A\n0ѣGQOo|b~F 8nt &$5(B;$EI@ e(VV$;BlKK{ D"XJ B|B|rİcJÐB 5l@P#4h|B8\ np `gg03zƌ(aIFa4M*@ $X+*ܙ/SPbE8u="1IBJ+ :!ZXJE ùPGK2R 94Q'€Qz`?u`1k03yF'd, :I m EpG*#3yA!l1G?*yd5rU$- bKSj&$(T` +y"b Un'!o1}Gk"zRF.RShU0n]hXe$1+5C6CGE1cAkY aSHd`Qb ip Lv:಄U|2r`ȫ]D 2 ]9V!llȉ.x)@#;wX-B=R} `-S ,a.6aQgXVYrM{5MDk :Bߓ $QyP* EG!Uq.4NT+P2@bX]CV`815 nPeЀ0F=Wq9j@L1w]Jq$| *NAȳR84 tFcc1Da+l@1<.2sgPs&tX!}HI w @PC)/GT%>K>r+u Ac0W{'% 4`U+E2$0T2E@<`  2]R 7T$!ezgx>mnE 8-Rf uPL2)PP/HZt!4 15/sr1G**L7)r +V$wdp,iFxIp>PtPbGF7U>FVP77ؕ 3ThGI<%PHy(+m?B+#(a+A/DX!pTB1KZP1-WQ0J/0&P:O1!tyv!ld d5)UyF4=5P' mT_"M7P34qCct s yR"-0F]ICu$@T1y-UdIE!!_!`=Л?;]w !h悡AZ'rb~1$ݑEt-+u/+n0@]DZV>,dh-  /915Yx#ɐ*=W~2)X < Iep4`RjPw$yGBTE@8Q":tH\t_jDPrJ52x86E#Atg!P\̓}Z*|e)b#rpE}Kkդ5FFlSUj̀.BYt@7`ln*tdru:,§R!zzxq鐨I])j". zUzъAZ, ʪϒЮ5 WS#p* V( ^)4 [Tɠ_RAku@9F8m}t WU m!u)ޅ5 &QP>Е顣G?"`Q=5DhNW3iR,9_ EaWy3AEp_zr[TWJpw h*$suu% ~ ? S@wk ιzOEzQ!p*/pkمZ:= HF 472E"4-HZnfw1.+p`"w\Ww x>vA k9*EIgRUXX f,QkVhDQyV[ G`f<"<a}z^ /J ܡ {@dHu5O?G"1<2`RW#Q&AHd-XBk_ )}N!Nvq 1\hǷ70 x@ '*(qH!W]9-:8.K5q~Qt[D) c)*1GĒ<P 2ȉcrPG]@rdx )\xoaJRTYD0pmitiG>?wKy+!& xI703PZp-phôƎU.|U$˫pMq$7R a>a,IGc<2^}5`& f P7;PHhŴl Qt!_@ 3С+P9 NNGtKry|L}4@;#5efq^ZQ(sZr@  9TyO1)#wu!-6Yf(Z׌;%|׈|E$BɴP4*2 9#>18m 5)U y0*%*+!Pt*I-򴷕_̶@>OuH*x4Z>/#‹QoP-zq 7@?DFgK'[avBS2B޼Z [M3kW @P6p#*"!27mҏf_D֢]9wTZQ FS!P "~PJ1Y(qJ}*@ `⁆}*ΚB/I2^l*:?lQ^4F~SINM R*TVykc! ^21e=;dLlp~N2Y/)xz|>w~޶a'A$V.k( rY)F*lQDgfV]P_6H&G|* 7̀><Е\< t!NAS7 <_0$ s7$`!< N(Mpҟ8tCם "42P2ws%t,2Y.x7Z@/u(>fWdQ-!_V:vRk4_ ?XA܂ZTaQF|<;YP,0푵iw򑪻>!%++ɛd}>ہ104A,_,eE2~mQl 6ޗݙ}-:H E"!!!!h(IXؒ"RcX(Yb*#RQb!XA[S+"B*L( "()r*S"QM#1+R!rC/a"@pAG|!ބ%2ntP Z/8JԀY Ai,X!URwb pQg KC9Z$d  E`Å(U$ 6@xj]0xzKsI"".K*u0)*o"T5C 4<`MwT T0Pc0A_@B]Mc[;"\AnRE5xAdBƒ"~-R$8EqQ\3bڦ%a*]sNQQ~٦ >'0(a<HQp@FI 1Fl#5ֈ"E"- -_o f A!EP ҂s!C2MXAi0#i22R,' )w5#\{AF 5d_a#% mFB#$֜5*Q!,7/ȠK,ӜJoI S|٘Ù(40!ujjy }`hD*OhfW饙Biqyq3ȤLYF骭&vZ뭹ګ5)ð" )2 N8GXUrW:".梫.q.9&Gܛﾂ˿\0n) SC0qe*jֈ` /tN20~b̉JYzs/i6 ɯ+8BPנ#@Ci2)$tzWl'e75,& *:65sBM*_$H1[&eJ_GIГ%(*i״*%O1L3!e,tBHLR-MpS ]+H4vT= !aiTGoȕEPFN`:ԧ\}Oz9q"? ц" # "p*K 4lf F5'; Z}W 6|ՌGF[6Э#!ݴy:=o"ԻDmc)OxW ~C| Où(ZrPFHrF)ǀW 4f!>$=i6!6CY* K5, e<&`SU @tSW40" t1RpQ r s%34b%fVV 35qB=2e&) -YrUPPR!P!zA 8x 7}r&InSq&+&BlG 6N1K@baC=2= UqM>e3ِQ DF (2!N)$Q1␀Ag~J=7"=M2|3aW5FSb/e΢C*)@A Q7)T%ELIIscG+ȰKp 3,p%R,1OV[BPgC;b8 O; րP %3HyB h0(Q,4@#pr * \>!Z1>\ DDjr&( 1C!p(=D 6Au" PV+΅!0`h(( 4|`tzx fl c ӊi&:lj)pcիz"ǚnʚZ+4H1 F 8z%s 5ߚ ,P 뺷&KQLGЯ"$b0_5а/q9Dp騴DM E:6pFPb!E>q Z:2 %E)FHYwe{&^&#q΁ +f` ,"*]Gg"b2yDH-pQTwL )0h3p ¡E,&Faor[vV<#fVXW?TPa Z@ pE*ii< P ZCDp3U#EQU׻:W,,)V0 fAS|@#I c:D_v(+4A1+ò- H )ACP b`<˩>›Rl,J05s^?#A,%0\#% <.!JȥHPC'aI0]h(q^W pQ&aJ) T2_URq =`Φ)P gydдq4@Uvd)YoA<Cg-x" H\S `qp!I0"Pu>#ȉ)@R-% Td#|"` & td0AI0lfU1c$`UV\ @\ :!3fY)E ,EA gEsƲU,ҵ3I%3|XpMc}M5C'20Q< s,UhXA DpTa  ۂR9BKvp { Y-h!wnADiUT)2C=iLl7E\spX7@0@Lg{* \4fYFgPE%$`A P G%>#nkG$/Co+.$ .L@1ed2ΩP˰dRR  3I}AjPtB<]~("x*ư**)RT^*Vzxe? 2GC1)VZNl B*`=XLYV~N ta|,Lp k鳹#ꤞW-Aೱ8Cf59!^ ,c7`쀖 ~z$A.DRnt#:i@cѱB$$Ù@+q"-1@ >Z "Q{fK syGG@^{'"PV;b r^ǁ< <X"^glFR<sa}7sS-XaAU}d1-<#W=`t2/0HyH jIa>---**5/I2DII>!>AA2>5>-A00D7F*>CCE5C*>>"5 -Ez`2H5*AI$>@Fy@DIƩhAV"BH(R+AA,Xp"hC xaD! D !B 4p& "U/<ʐQiY\9 Hx"dDP# JE萠 MjtPZɸJfH1D5BI?>+A*>>X D-֨P1Dd]f4;YnG?B'Ye>.7:0`nV1 %E-?1E|Ã)ɍNM8\ QA TX !c!!XAtrϔ6 "(+B(+1^USՎ bʨLYX _YJƤBp5$`AmSsi\<+Aa*t,|*a"+A2 Q7̎Mz fOJ`+Ao*|@T! k6S )'6 CуWX--"|4TtD GOd+R?a4=AWxv9 t 6"x V  8(%m#p-d $qUʠr;?DBD1>+R\^QHu1kl mGXudPB\P#FرƠ|3 >nfF|zDs4DZ&șN|=hFI>m56"  >{8D4QB YlX6F6uc1=fX>@9eC,`z簄ylAC6HD˛zIezx.XHh D@`GJ 1Axq""Nq8o+&|Wsj&w:EL`4AqINMRU,K&‹(z#:YNG,`ElQ5ih Nȇ[`I( %#T0SӚ P22) @堊jpbǩر,m1r[!z0HMP$DKX-jp=4VL/>ƴ SK̠qBLF lScĤ- A Ӂ&(9J&Aj>!n@LR׍mQ^f~ց!bǾDjcC8e?2* ]!VF5) P!2:$Fk &lq@FGi%R< FLia6eǙ (DiA^0PH:h6{܍@$1u20LExH-ǒXDHHVxׇRu0rĘT_f\󌳖7$:Vr<&e>j8T "G38="+ġ ơv@cр=uQOF4!~ bE@R $I :u W6Ig^'%2'Mgp7{[Q`oG2BRAbAP#!U+09`(%EVx!"#<5 +R` *VS5gfQ,E`E2pMA%&Y0P#" P!PI kR|@Q3s(%"s0`cq# B 87'B -.,FL:LqL2WR'# ,PSD:PG#A1ZQ wr D+S $H_uR2Y 2+4Ubx%1 yT"Ug U[ +XKSS! H%2P '…,Q\n?RakgE:VmB0pMpL 8FnGJ6sK1+R1#TK0%? }!OREi %8 !@Hpƈq<8 8!鰉hA u(4-EЊ(G43\Xы$Q76{Fq!dRRHv#,XMvؕ\% Y2 (D7`˂? ΑB8BGi+@װL!!}DA,"2 YLy3+!I[df d C0C}arQXp P #'0;: PiU@H7+A1B#=LG1A) "pP?6?U]tVx$p r5or%E8.PJ@P+ $l,t3ٰ5Z" -eddT#0C<+$C i} q 2GaVw`VatAw8& YbwwIP {r5Q#8tK0p-bA*w* iEPx_Q2%} 磠c'yb1vuoaIx`2%*'?ϐ*+GDkrWWR//b! `CnsS!!; 20|A ԉ#gJRF*, pu^+>_oU.p&1?RI0aE*1"wpGU `>r0&!qCsd-C-70.Ӧ~!,E%Œ|+yGTFHW#Bd7AAeBXq?+!0.7 [XG #v#0h g&|%"RKfZE4Xdq:8WH aK9,GcD; -i4 ) D&CB o=GOW1g+67bAq'b:I[wdQu O& ,x UrD?K ! aveM2XRac! #u#2@ ]SP0c `%)/@/`="H2s[2Ql o@34i}2F$ưG ^+weUI&2{P&u Sc d ~(Q {vLvS(`_ /7\(? HKP9F,q*PV\!#S=5!uP-}\aA(EBwE|rX+@B R mG\Jl`*> !Ş@U\gWY4]],`,bl dlƝp!B*nLU6 sL;`\%|E 37ȷPȇ,l,S|3 VAɒ `tqpphS2]a&if("^s1-΄$W!67g].TE<>^PA4ѵG4YWA@ ʀ ҋ&^(3x72>qY%) 1FP7Y"sB08@8m,M`~09 YNK1XBGsH0"O Z'mD2@tK} ! /1La( u.!ˈJ& ${}>qQh: ?c :deB!XDmJ+aT+wPa4xޜЂS,p -0n6Եo{ ,́$7GRfOU]#p@TmRM @)Gly#bGt"Fd/*K/v pf4P@tq/\NJ?W7rkQT?*0Ӌ32Ft$݊C²ei!0n2@_òK1jFyE@j) 3nq}-z2^U3BG'g@-f(p.X27W 1WPT!"!!#q!qTQRR!"!BSSr*ر8##ss(Q8irc,]M]SC$S1T. 3 <`Ѓ#JAȐ\ &5d4taF+hTq$&C|hQN#>* MHY"HEzm*x8UccHԔ'OxX5Ga1m!Y3BQ &*k>* 9pk[rqvb35I$ jԨ"Di$)'C c0bEH@2eA9kZiײm-\Υ[xBԻZ?4†F"F58z9oH %9J-L5ݔN=tDPCuTRKVQMmWV]}BXcPg?n\t`W xŗ_'&X"b5-X(rEdTYV"g@""ZkɶݦBnx)Co &%#%$ yUcL-5֖6 ,'MQ; dW>'!BF`L䨠AE|pHAHhqC~Z@#HRECrXMtCVBAQ%tPMT(AtS)NDVupý%"XM eHwAɧ@%C&P%#Z4Afm%=|k%$2O0AM].@ CF2q"7Ѝ Ih/UУt+xeypkK,~J[P!-`B}U*>LO!+n$W|dm 7C"f!Vp-fJ b%bNa壯y"㨕 `*NOD`#`"I @*W%TU?"0;IP(u+\*Bql$3%c?I137Fi8xIo>*0*}i˞wr'#!825-I0]AKʿ! h!ײ3br<^z2&,?)JVhx*TUfZ-PbE?ZlCcⷛTXA`B9ř3Jr&R7T%AlC|?``MTD%22=(R#M-X"Qa (~< |T߰M2Jn=!AA.frC(w:F8 A)#P%+t *p9B^~5 ŭK uF#]LP.)Tm pg:TؠyGH)'ti]c2D%(DAB稍D4i/ I\ūSPEx ,;s)<0끏mD>,쮉1wa. i„r8dOa?0em ;% 03wrr%>r ,XQ 6zeaFhxE,A !$,얋.gZfP^pL"/{盔$o8e)N ~6dJ(AU3 SiTkS&>q}U*$fh3Lfh6VfoYqE\<#A:Ah)F,yVl^ W 8kէe/NT, B'Wޣu HnBCb+#@_jdC1De c=22 N36] =Ȉȕ+u$_NitZS=2ذ lq&(<6F^uoK` MAc,Xc!^ED! =;6 "x&C+7|Q:KvA4fjS&WQKfMFP^:#Luz>AtCN6i3R!Psl\]"k- 02?> GPa5' 6SR zB DB+oj!\; 0?7pC99[!!D0FO+cс%836E[E1aRQ,8LHH Ǔ Sd4GJo!E gE'_+(7T]W^7{ KGI4@ɰ^> s=*U|3f3 8`b!"~w["WJEGB /0bG)2Q%3a!pNCP@ 00J?6u&QYU*-r/Θ~S!++=$f#,$SQ~ LN+4+s5@oS?'>t>e'F0'`0?jfE4wQ7?aICd'r=$^*CAC7,0~BPv #gPHp  Gu } 'q7 ]!lGQ d;r0]%/%w S̠;6#BBP LL0@t"=~[/b5X ceюKDB0J@P P9%S5&GP3UH_IS,I@!s x OW5'K1KA9I*`8^URȈ}Gr4d"IDj 2 }b 0!1` 1 `BS^Bf_P @6M`=WM`oxP1#W -p: "/iF$ P?0^B=0$$3 I~RX+@[W 4YMpg+0N1p4= @ (%3Y*♥G ,> 5КU F C~(S7WEp2i.y iA Rp3v *9 p3QCp}&ED`֕ŸђZ,#.j:e@!:%yp)j>,6/D1t: <BJwVGjJ>5u<rh ,'S6~̇>ƠSQ(OW&"]6?:'"+)= 'A rQEd@C7Д :Jo^r,@XN Pij!J7dZWE? ;=&YQC3^$'=R%bC2d@ R&E/#8eq@I\8N:*@{#4˔nātRgS{ %|,Kd@6 0^Jզp(B *`0CVERQdZ/Yuqa%aIS1d*i3 YFԓ@Mؠ5vy414~"v O0dD7q"8pR,3@*iQ,,\$X'w7g<Es%;Bz1!8

w2,2M|AjJ<ƴ_QO}$@ 4V`4?40K0Q#'!XźM3qx_P !zh[{dy>1[РqA#2 5'l+4q1}"]6o[&,-Dx:%Bwe$2"$@,Eq"=ʷeäg=Pq*x@q#?D>P3·P&zecqRVȶ[Bdԡ*l4̷7l /R7YpPD03]" &ELjAp ?ZOrӐPT =0#$ !2J0 [ = j-N8yQ'6Y/]2PL`?Sr䪷'kH>UScsXJ {683g8da(G3XtavqUr33&Η~l2rΐqSr U v&1 w-'F}~bWq GZe]Ǔm0E|62E C;-p$sZ O7ܔ0ܔ$7V'܄g?xgm,:Q2$ŝq)Oobwm5@s۽rֆ aޭj'^LdKM3ߊ'}Z4[ YR > p3L5lUp>~r_>"Nl;U(-.iaZ DG۰8Y&f<} q 6a9lJL\@RƂʩ|4׭kx^0?+gq_ h =?Dq3GU1,HIp|0\!aWFmB#! l(YC*=+]U7>S! ± @ 60ets zD ?:5!z-@41>]WnG1B|2XOyW"vh1AcT./L@E'>=J|_?s vu:i4 jOW4 ~ KYV3Xj1't2Y 'r+ :]P~Siה}a4\  @'~х-dk412@ )(@ݎWF{Fzn8TPT|B cgK9i JS\(i 227I5>>A5A25"*"AAH++5H">7A>!5ID! HH5"/DI2A>!"ŗE+A?**?B*#H"6Dӻ *,*0200!>"CH7CtAčFMzA|hdƍC6@hd`(R$ՐaE#J- ğK*a}9$IC !AȐK`R#?lRLj>$hC<12" k01#5dcXXZX$y݂˜AHXơ5Hl$#|b#{JQg ~P!m$ ӞRqh "H9Xc7 Ũƍw:프7^:pDu/Zg% <# z%+&I`E2 >5:CeE8MRxRDo;}B!xD&uNLT>AS $Ё K2``h2td#_uD|&uxgȐFT6Ow rH0sYh{Vv" Xs5b$^0'.5 /̕\WE@i‰|Hb@ Eb QМ-!ITWC@dr&adD'"$"biv jH`uQ2P8)]ER PA $AGz/<#c<׊,UMDuT<4Q%Kotd5DCkg;0F̘sȼ& cI<!`Hi *s6& &+v1voD*#-7H|PB\VICD F:$B Ed 3`ˈ@ / _%A@ n) FZhsɈc7˶PJ_$O#p7evxTM?C|%#= d? $Eպ 47P+Q%YJ?5BL 1 ; qp]#]"!8Ɋ\v+w>{N56&EiLsԤF5Y"kE;&lf^6P7o*7ep!S=l8r-(g9i9DҙNR[ Zw׵#lgn]q xAH혧zң=K 7‚0; Bv l ChCC|P j1rctЦe, z#'=>cf\2X`S㙡#Hą hS2d)0mZ `2$(#,!3A`Fb~&Ԡl6@fZlP,LU"jT nb;Ћ g>2̫Hгh(!v'?L"bHq00M!L% DIXhˆ% -Rr2 Uʨ 8dԟxA_W<0A%HxЭ‹XLn17%J1Mڕ ,- ZA{n rR)I 3 "4E)ԈzF;;$`( "ܕL AԦxIˆf" Tg̀TRxa`EYR!cLnX3ĸJkI`daų9&`B1Ń6`]O%@ElZM#EN EoIFI@y{aQ!t$)b]pKឥaSb24|LSĩ3rJi(.g%ğ?r;OL>p 6E4g9<`x""o+z|brd?hС;,ދiZHfC%<%$~"\+(A &YWDs{~8Xr<=dyF2HT]łߞ@T J#N} ^zVD{,Eb!$$NQ1za4TRػkLF "bC[S9ŖRX^;LX裺nF;-i&ȭ $]L"-3ljD1_} G@]%k♉uSFa1 &G[kzB[ɮ7iP<'**Вj%0)á+Ϩ]OD02y;!5|_=ң3€霉,]^]p3:C&;%|'HBtnlOsWwbyG |wp8w] 0 x$qe[xaCy+`yNyxyx.e 'pczMzd>$R5_G# `21t aJ6 f%/v vQ% lpR&2h> i%q+1 b 0`Hp~,pO ́C fIi ;Botueq #Mf"yrfP(F`KM=pe0\]F_K_!/ CT1;f-W& 0o `p Q8v v'H2>+%|_c%hj,%P8fShSX1)a!M5 ~#*L4qP!WvƐm" V pfU0p0# L# 7GO!):EW]zu v,A*QDB pE-å20#(uo-0Ɠ!0\PL"zBfJpa$9>F yVFZ{Dh1)9!p4h>8X.v{6)Tja>*6Mmw%Ù@Pp9O^l>Cuf'BPTQ8Q+QR}@L! p()IDGlSģq154W"/N)p/kB ~ hZ os@A"+ c>?4dn4!v5-P4+E@q CW$5s$sM-$R-B= )NYOiç"aV`q `"'`8$BsD*GWq -+Y6?s8ױrSr -Z0W_3@*A8 N]"ASi?Y~ayщq43!.=(d7ngpEU3'Q% Hq*`k\( r-.PI\l%#22Xu*g*`j BB 27&F *tN ЩưSMd AB;+J3.{r=iPVY@ !pZWR++t&&Q15D3?3 kA Xl:NƷ*;6'W4ICH<CY.È~#*rFG;0X-xA#b"!k$N?ಇBIZ7+: }H'*hZ}GJJpZ@J|WᰵеQ|Df g{)iжZ3s[{!k2+M4'󙍠:C4+ӹM50Z˺j -K,%/$QТ9& `1 `th &dJǀ`gi0Z8S@(T- 4kl3Pz3 * s;q 2t7c27- c|316 ?`+QAvzQV`ŀaeAL% @6BiI,ThZ.L- Q.YkeQ DKS I=§OXD9rNXO7KpTG!7 %P6Gx) %`&iBn'9t _ %ٱb5L''xtCtR0$D, wz23wKA֨O95-lPlqN$ܹfܒQr5 5؃_ȝPy&q4iC*=L0!b"# 3AsH}Bt@`vWK Y+( z0*V|0b&7 mM`~IR.3:4 ;'lBY)3bhv?s47 % y"*T콂A;0.YW($m]- 2":M^7P&!/ZE;ܭ><8rC *́Y.(0ŪmI$$}&7ҽpN,~6&1I k3 `v`0ukc{'0=@:Dg OXqq`#s-cO"Eq"b-`vrE/k4Osx` IsuA0 ~ |?P2R^PMY9_a/yR ~3sP$&ʯ1uxPSCXRrx("BrCITs#(#S"Xy!IDy㪨rt!A)c2)zQ$CBRTP}!1-stTbdQQTq14TsAI#d(DG L$")K4Qu#$AX$Q B($D$2Q #$=R Ş(Y씤F5Dd$HO sPO ƍ+*!hқ< C $0`$$Df@"H`Nnhqy"c\nxAħ%$8F;2 qN[C7Ŵ- a-ABŪczw\=GH0)",|LF;I@QɵR"35v,#I$K(w(4D &1&$S)HEZ2QEQ&7dQ&KyMPTOq GTX!Fd&hr IH` l,IЊxy@ !%HWdV"6ҢBPXb!/bUiŠ'͗ 4#pS;0\;J !TQ&! @ đA^d> 12ӂ\ϩ1<N'hRDwxaogШwL!C7&Y<"CDZDc@D.%4G?VNנ5VP%eH*ҁ't8)Zt V* aqB^݇]b viK %y9e@H2`">a"xH%SumdʂD-"x.l-<#▕)GfPxc 4ң#oXEA2 0TIsaTiEaVLvDQLp9B4sFc,Co0$`6P vQC= A0[a!9fV(.hF[ad9"b!n0ePnU32 S!pr8 3"=`g5_qt* K?k hJP6p*T6*ڔ(=0KAHHmOCedKPc-& ph9`E6re!{EHaHX =q:(Q"@4BxZsD%2!wFF I h,wgu "&ss @ dh0@JLD@2 D@M!1Q$ԡ rhDD>r%Wt@Uh,֥50GEph  H!0<0IvE"נFhPV%0% *!vvhH`}؍h)V`Fю!EC$hmH4!2!?v)CgY"#?Ґ> tp- #)%Y'+ْf0"PrE;=!tdA)`hbJcN P)@,uYѕ8ay0X,plp)tM%Q^m{1[hy)`hhbtG"n;''QIi#]vd63 E}L?>\2 hqHNrFW}{  q2x27hp7'o2<'0}7IC}0Ru2#1/(U" P070`$ `L@@ *PNmG%G0N^֦s,>ʍ"`"'Vc%F J&XR"}DF;3w/P]p+@GS`R.ӓY t< ]pkI}'YאBP PpX03i_0Q&oE?GGG J4w~JBjs]56EVY> R7SaNr$Mp 1Q$߲\jZ)`R.JaoSm@(7A?h^b!I$;arsw[`l1s"s[2\ Mp]O$O w{װLY*1Kv J.Vw h"$EH@qXyzh>" g]i(G4 `B?D)?yd6m bA2s#LoȀ=#$"a:QQ/w[S9X" J0 n(001t-s4"qG!YNGF !BYJnl"s/eiri&ʽ?d{x RE0à5C"@(Ws\]9I <# UڄXDqDP}PŅG@*W68),ˍh5T6 :f`(ROTm9:2 @$HgH".`O.Ȓ^hɁ$hV5(h ^Z,[ Tcld欬T`Ja0n~wDc]f^Ui/dj$ fy =XJaAG]rZ1Nȼ@  ? %Q/@@p Qp 4Ɏڨ 2_O0Vq/J^Sbo Dmy a  M-pOO]afհ\Ok[( 5VUE98 PSVA `BBɾ-ͅNITij9diН0|T `S'171eQ)]A>5>>A5!2F$ 9 &&#+AK7>** #?E$<%EJJ-?*KCC*A*767A>!B766 ,,7D//0FF>HH2D5""*H-EE6-*EBI2*<ᑡH E2Rd-H$#%L-[pBL0Tx" *`0^Ie̘(dlrL&Z lx T@h 7pȃ ySEaDG)0`fdCݐ⠌xCHI "$ajB (3CS(QBL7f2z$$I*HҙL)TC@F8` $x #"%HJ#>d$I"Xg=m bD "DޠAH#AɠaC!l =T^  >4:2 0KZe0!+>!cUT,&QFGd!%x=@zBu eCB1 0 X`P=ZvO H5g522h3#!% HB,IL-ZG3NA * @PhiT7Tx2Z$Q2[mրpgr[-sѭCuiwxxazͨǞ{w"3_} Eh Bx:Z2p胇 HE,vb3x9 YF"dP SRi%"h^Cd` h&Zm6 C$&Aw.?>JzhTBL ̌ixP7DX Un$T"H 2 1l ; _ !f A35CTTq3z0C *2!,DV^|_g VbC-HERF(r2MhҊ!TBeTAsca0 AELcaLh>D A4kC8eCADjD|y5-   ЁxbI@uд%2a!".h P h`F( V(1$x`AŵR%!@h@ 0)XHLbxB%,87 N?3΀>{AC# rHS+@DY<0EPy$I@ #| k(Gt1x! RhъВ1/ !"B.RR\a8( H<P&A 3h@i=X x `T5LU6A *܃'bTcun U@HzpC 5&&i݀ژ(`XbPUb' (1Zq 0|>D!r'>L.E'<G`x8C@_#A%_"(Y.AHB#5! 80`wi\*a ' KNruLXt M`&@a3 c/ iO| _ ;QA6>I1 :AD1F9=6D3 Jt 2 (-(ϩD4 M/UAt$[dyd$=#2E+NHaE H78v=?n `M>= g+T($A h;2 'pڲR&.Ѕ.<.~M`W0Y5[~= **<(Edʵ@\B5Y`ȋ@2!!0(4 %,=QmaBP A$(p\ D>CH`EǛcpS0 -n AGKKP0 (g<%P#U"jp D-?fo ڣ )g SLT" *=1#F1>` xp@G.  7=D33@DR`m" VE< I5c'~ FC+4A@ɓDcPTCH%Jd"*Blg^@1a&`56ɄIX#!Qd xt k&%!21spt9 7JIY<sGJU7HG|!f.sq =8^"`)ȋ c ._9,\<6")j":ѢPv-tWoRꮮճ[b7dgv=ojU%a!qGsWwdpw^U"zw(wGxm[xxGyryՐy z~SLd$P|ΤAzCz:0{'wY<&%|rG|Ʒ|`(T,``!@D prEE7ǕL LP!7B9 P9w -{SZ 2$mu<AV@`a{a-t? C5B` aXa*AU P9?ʂn.s Zh1Lqp `IqOO 1@ Hw,n4P%P@P#P$@ V$AD }5J`g pP!h$t7,ÂbwEeuWUr'?9v(-]7Q ]'͔(>  P9% D9CB@o@;jE `&E) Q@~V׈f*Iۣ³x0beu[)j=Ev{ ERu:w$V&Q#Xi$6ww= mFb&j-&\@/֪!Sw .-b; ,G &dpFGpr 2P=4¨A}d"P:KQ 0e%0 `3˜ڧņ1N4SD 7ʝ KQ"  V=6v0yiM˔pU.$=P0_VPq4&wcP2U(QXXU#/eՊ)==LVWps9i{G@;0`勺CFAQADXiVI0!ꢇ&5pPp 1-WW0,!8p &YL{`諾|+[4'6kBۿ$ <<H=̭ v~t ,$lEWOa¶ÿC[`î`U;\#]E?Rx@F_.AKJP<]0U|Yů1x` ƶe|iSl^oq̓<@]``}\1L;wSjȍ;%s9@A E ) QG[Qꆖ ,@o%2 oL\Tb(11)l0qL:VΣDuS`\[Ru=&J?=mWf<Xb (F\4Bh-a!JN u W3ppC#1`@0i1%F@C1 ELJ0UukeT\cPp}bb '@  }Dg GdQbܰ@ I:%!v.1W^(#+KH4qS4R[ ^Pfwmd<2a<#Q'l##^0MTE0J`u^ň^HeЊ"xm<!xWXmVsiv[f"d?2$SV+x#&sb۪R ͕GC #V[WPu4#Z±A0yrG Y -@gsJ ]%#MЧ  u } G Pv'"(UaVmde(ahuLvUx[w,O-p<%  |֞FFF8PjHvk=qam~0.#d *Ȥبm]<0Wj>" p{xEP*HTtÛK IZ5O@s%_3wK JZU0Q`Z-Q0dhBWvpeU㗧Ԋ"UܬD:Yu,a&v&i5׌)Rq=CuWA-z jo(#MrGbo)TtPPX8PĔXpsـy zIzrbdZ21T*;K[kZZptuud EE5FEF66VDFmvLE]= F֒,TսT$Ľ<䥲օU6 32)#Sl۱tqIF+Ķ pܺ)LoОl)M .]rFjT9e gۮhТ)]J]XZ,) M<):J:.db"*D9$ r%0u j[rzek†L Et1)q-y1/c}DI<5'H`D2I%` @,)taExdv)bDrEJ\Z0)Wq4TTUPm:AW`lKTtED u^9YRG`(^8#XTX!(ELM"aMPjbDFQr !ψM578dUĶG]!H[p]*V45EVdp!V<50XeB? f1  +L SRlcQx,%Oe,k"36RDd =PBH \ "€f,Qe?pl9!K.+jS #@g:i!Kӝ9*IO{sgπԛ}BP:i6(\acQjKHDRJs,TֲBMsSg=O %T*G%CRMih/Z[WM'e*Zu['k++jVyE _Z>jO(ai6INN(f Hs6++셙UaJW8 7]_?BJRdlƨP,"d(yU{  B(x 6WO:0ЃS$%0!u꠰cpǛQa zʓ.*XcX fx*H2~3PL 2aM@04 H4j  H,YN(_A9L2qNLg8+(  >W?yhS `@ jaI쀓/@gDhaab*LD h}x@ !a APۂn:%lϨT9d!C2U 4Izb$qϕ4bH kC6&&P ITZ䉲ABPa]U 3v(WL <(aX d`@'x(:\^6B[ \QnY_1%b:ɤ7M oj<&1&T58[@_-ˠ1. kyA#KX>ƛ Pe8܈Xօ(t:|]4hR0-h yԲÃJNmStjj3.D:$ Sϊ=;"E:MwPdA(cI rgW)`L a V{msd'Ts ٠*a`QP H ek2"(h P "3ya(ޚhmkKƙ!:2>)q#*Y)B볘 8S8# Gl˒{oHwH0{ƞ`eV]lj~h^gͰjagk&3LϘjl!(&989Brp7*Z?̣zt޺e 4a7QFn;@apE~sb"Gt# oP C4 whOGХ 4mR 5@kY " aFCXG8Rp?0V 2j,p^ uF,@䵩C!Q;sĞa2 M 9! r 9hC'-2p~4oDDVK| };AhBKQq kNXA PgeXIFp4X jx27(cG< "o~|V0]UJ(UiC#U`J [-HR ~U><1M7&'z)Lꉴ%q_T +TǫMP: p o%[ޖH\*MtK&d HE 8x@^y+!|׼5|wE~K_t75/z_p|?0d6xbstEք E#֙6{|R$i3'\ [S\vE\d헭)G]Pq[Rp'"x u[BfL)+Z~}p*6AOs1d<-^dS-oO1+P %,)s_,LW@ )z榥'kO}qr+4Pr*Öj|۪A H7rVGC/)+tY!'n*?v Uu<$bЏ8G IN# x;Bz{h~:|dkcyvWcO~Ј'|sT?VVOuhEC9'C#cdQ(SC# ?4yw7w2ss%kz`n 8uKRr*,w{m24s`sf|=wn7rCaFrl0Hh0~!mpZWwuB }wAV;6G?' 'C7 V|!YUMxtz&Bvw+'? '?22 Gs2M7gmh64t+r' .BF%*h@? ]T0 /|m ;0 #q@$&W)OЂFp +C;fu%tRt0ơ;qVM&@ BXqģ'Z~U`xq">rW(<~v"Th2Swb,352DsX#$h'K1gWY-;c32",#RpSe,T%]s- %sTs%5]+2ve8>bW!⎁v;'Y13%36B#vT&(ֲ7Y)E!pBO1H7we$F"E6b8d4651u4,YtS0:s3_R-"AbJC@6j!6Yf9Ƃ;[1 v#wIW]+HSReur"3GWu0L<ɔb$7~.H9@NH2.cRr(B)d,"R0Ib(i0S0rJRcq'R.(O+Wғ$%%E<#Vyj 6:y8YOs;ac-;iE="ES7sgO/3/Zm3b ZɜAmY;#6.܉*Z:4&UF2| 19(9b22EF2*8NczZJS)Qhr)2M)c2I:*w1Zb3<u~ٚy,2U,m/Vi5,v7RbH&8u35ɞo.h.Sh[/jja^J~I3"J7(X%"..70c'b@*"*Tj;+/`bSb)C:gY:`g:8;%㐝6Iӓٖi4k27$p2j}L/&8&-$Y=If@L3h$+Rec mx06   -H @ o0HK Po뱲 Ud@0Pa@ :J8 OiC@ ~rb q @ 0P` `  ӠP p`+P  հ {Hs4g~ R zT `۸&`%@ , 3bV&bus>hF`pa%p Z  _[w ˰ Πȫhod4a% :` " s"QyߐhJS 8`[d[s@ ` {q pO{`n+GZp`+; !"UWf4rhpv:$,pU%пҠ~,h x@{7bgSir{1,?Y;N,: ŐЈG|԰O,c;{R<5!aLR 0k*ץu|{z;3;; ,&i|sopI:qK ǶgT@ŵwnl3|F9N :;|ˇ\:KȦR#r+ ?n3``+[¶ ʠ ɐ0a`~Mto& p k lˈ\b| ehj"@sz6|t>ɐ`S@@`\uK, V3o` [P d :`v"{*d(gAul k <_  d #L:HIY0= l؆=vF'l"@ s@M`KՌD<0؀ ( `np3 Y $SP P ۮ``k-ۃP@4s9Pˎ8:-=stӆzP\<C6`C ]ў ؐ ` 7w@ = XOPͼۮ  ] _p @ƕ Y8(ѭO m~p6ޗ  >l̋ 3P9и|i@23*{`Z #t[F"" _P؜ D@ o  3No̒@֌P=-p C^Di  c%{ݨ003dL9l M׋8 P unwҋ}-΀`np * ?r@R} z  r?4"%  {`4=pD>h׍7]43Z%KT4B r 0k>}@m[M< ^ n8 щ-0 #mqΐBb%p BA Z@@ o ̼%w0,?g \p Ț8!gp~Ԡ t <ڰc 60CMPVPK 'p@ݺ@b?p ^0!2IOpne`; w@Ҁ>՞@ ` j Z u> -=P@=9P Onp; H0O+oYBp ,cS"a@ t0OjxP(`Ö-D }t^A6pUJWVBڶys޶y;{4Cona¥/6M+ ]EN}M0dC1D!BF/GgHJJ]5xK+sl86;sZΙgIDl雦 D"Fp7R<0"=&ھF~3#bƕ+1!jG~c.-T4R4DisvPxP7]5tKlOyىޞT5_mYwaafx#6l bGd<㡈$l=,^[]~VUmXA>CPb j'Cck45kHZ?.!aH&"% @V8\׭$^wG'QQba!+@4\sJ -JPmu`|2g|m'mzID{g,<䡵ky\3kUZ H{DLa`c.EL7>(@P@* x4y]Sc9 Jn2m$h`J=1OLшؐr38VK YȄgC2Z.@F5d2IZݻ MTAQ++x"HU& aV+c$phC88Zb_8VKO c!/crGdlU%J-1yc'F(O+bBlcx fC`@*NqVnr~'v4#,1kS"؜Lb:WlR=,Z%0@ ]7"ɂ 86W@,Ca) hNWMP#n6H̐CyIEy, a(Z"'(axܟ9QbDcOjP h!pͱHF2O 5tI-@E?3Hp} l@ PR`&8:yhVy+ԣ(l 2PB4(E_zjVg@r ;P8ͫM )+? O*,c9 Çv0\`Wԣ/˨M8#Z@qxDm A%45AV0f5 bCrT>˿Y^^,¼H?Ć4PC쁄tlmA,VM9woD.B7`QEk\Zk&rY> ԃ\@ I"@I`{-:aը;xa@,P$ W9hlK4 %P3eFs]@ $BvU|h"2Dn1`] c!/g9r2K;4ш20tR"+z=yז@(.,Yek5\~?9QnXx\隡G4wĤʜ^.nr/\Bm(@>CVDHl_v؃ =ePsLe:2bJ13]QG4"Ze˩0»VX? w86PgHC)agF {L[4^ 3jX]X 8QWMbhQ}d,VivװZO7Yb{W< IhPMn]?7H $zK80ěцU:ifATj]mCBCΤnzaMS((`C^ďONm҅:B*E Ȃ0Ѫ)CІe򃔕.l~unV$`]f8,yhBohBIQ\c ".tl:ډLkBIHk0 \@5 ruD⛐Nl_.]Yx9̲@.쳝kȅ+0]{_XRxTxQͶs8_mO&$/2D\ G9i(܉ R˅C%eAti8І)VOhp E5~"&IhISoȂ]0{Jt l?<>B 2ǑX<`O%+:6WWZXE+H׏(枌Rőa&ȏ@@79b6۔4M L)>\W( ]=YlF ].m(ab\#,S7")S1wނV{R &Q. UQn䛀9>b [  Fҵ$oUF}X8i%J2^(WElb8}}_`Dž[vY0CHEO^ 7Ԍ8)qu]O-O4`qO8@" J'zo8Xf2 Ϧ H,9ܟ\R@J9ݦyzx-s23-'g<_<2 /yH*X1Ѓ_k2|,*+l,08Q,Ѭ);s%QإH i^F}Y .3t@F ~MDP۶ͫ8y0Na9&Jd܊>JD ?$fμ_mrB8?2_̠ehP7 ao3sON 08s ]rEz(ِEqbҌ/f#E$Ϭxڔ>|k}x&e"T72>hAgF<8C b@-'ÚͰ [i{ȪC-|U.x[iܾ{ōeqܽ{:0 MR꬯ ) ğ9PJy6N- 6' ,u 3á*H A9]gQw`?Ac^S`5-ĸ6HASR8?؀ f7D*82 6(dÃ9 A>Pcr*^Tw![qaub] 4QO)\CF|f?SJ:jF@ ژ7 LCR/"6C Jral9ޜqtEޱg1# *E4($l0CXL$ZjA`lT+rbZ[#\c/4{/~C NP#:[!+²~vQ`aO=m/Ȥ!#$1p !F{g۸ n.,berRtCM>q(oy %aDž r2k`-R6* 1Գ@ȘA4O>t٬rrC89`0z}5W,Fdsm9A7iP2>SbM) cqAQP] `5[c;9,Rj4r '"Q-@B%6@tFSzr˱@sIk'>it#EtAm|`)KGC#-lb&~8Q_!6Mlק\a<5q.A*r Ia 3Ydbڃ0A/\/xfbzԳG C$AXp1j-fr6c֨l0N#R@--v75}Ω8P9`4 Oډ?nД0LC(' 'p`F=8mQAMЩdC= D#&Dm>H)`)H!kM@ޖ|(+bx )G300&b\`kb+}ш4NZ"  e,#T@4TAh#f ޠ C` !2=g3Jf"x}l!%X@ B1Jf( ,H>za2B [x c0 _X*J͐9$]@` 2qƉ0D<`} 8 |b G..JVnqZ@ h!3*caMn 4i5FVǒ%o F F:E/TEp$$(C;RJ2'4#v;shC_ hq،K!7O-$R k%&r Qd}=[vs"Ђ98am"8:Ɔ !`'@qTCֈz]*Ty6o Ss8==zaXZf}Wxp]n P!CbHy\RkNĩ8ĂԈE>Xܚ`%D\ ; T fHaP{G8I$dP }CqztiuS:KAn$ha)5!8X0YW[䭗>qAr1}%aOO@@YP836Τfn['9:-1ţ}nz \KpIve?:ٲ)noz?⭽F,HɵQ\Ljay2-](>3hݴN!lۻ"!zr,Hltc'K^t[fEy\rD =q)WQ~w>B8Esk!m-GNmp;Z(L^v!&.xRidz7>7 ﬍KA~uCɳ<]~aOx%t=?z‘ml_~8Ƕ-3ӻ;5'R5yD%SQ$ͽ9 `K6P#(0DBS|98#&>ֽCߝ9Eݑ7? H$>!8l"J!qɅ92ڛ:6SUџ%CS,C54lC*$\22e:R/z}͋"h |:X ¥ŌAB*dҥ ]rql:4Ăd3CH\%_Π W>:4b84G6>PCS=ű߶MfF߶ ؍=:>fr:M$'P B(7M: JH`˹6$?@;<0$P0|zc?T b9~[%aE4 >D40HC5Ă;4HC,h5DCDC>44A>Cfx'fn|i<4;O#@3HL2|;8>E?4#9ā

yank () )) ;; let _ = bind text [[Control], KeyPressDetail "k"] (BindSet ([], fun _ -> kill () )) ;; let _ = scroll_link scrollbar text; pack [text;f][]; pack [f][]; mainLoop () ;; mingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/winskel.ml0000644000175000017500000000607712124403241024113 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* This examples is based on Ousterhout's book (fig 16.15) *) open Camltk let main () = let top = opentk() in let mbar = Frame.create top [Relief Raised; BorderWidth (Pixels 2)] and dummy = Frame.create top [Width (Centimeters 10.); Height (Centimeters 5.)] in pack [mbar; dummy] [Side Side_Top; Fill Fill_X]; let file = Menubutton.create mbar [Text "File"; UnderlinedChar 0] and edit = Menubutton.create mbar [Text "Edit"; UnderlinedChar 0] and graphics = Menubutton.create mbar [Text "Graphics"; UnderlinedChar 0] and text = Menubutton.create mbar [Text "Text"; UnderlinedChar 0] and view = Menubutton.create mbar [Text "View"; UnderlinedChar 0] and help = Menubutton.create mbar [Text "Help"; UnderlinedChar 0] in pack [file;edit;graphics;text;view] [Side Side_Left]; pack [help] [Side Side_Right]; (* same code as chap16-14 *) let m = Menu.create text [] in let bold = Textvariable.create() and italic = Textvariable.create() and underline = Textvariable.create() in Menu.add_checkbutton m [Label "Bold"; Variable bold]; Menu.add_checkbutton m [Label "Italic"; Variable italic]; Menu.add_checkbutton m [Label "Underline"; Variable underline]; Menu.add_separator m; let font = Textvariable.create() in Menu.add_radiobutton m [Label "Times"; Variable font; Value "times"]; Menu.add_radiobutton m [Label "Helvetica"; Variable font; Value "helvetica"] ; Menu.add_radiobutton m [Label "Courier"; Variable font; Value "courier"]; Menu.add_separator m; Menu.add_command m [Label "Insert Bullet"; Command (function () -> print_string "Insert Bullet\n"; flush stdout)]; Menu.add_command m [Label "Margins and Tags..."; Command (function () -> print_string "margins\n"; flush stdout)]; Menubutton.configure text [Menu m]; mainLoop() let _ = Printexc.catch main () mingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/helloworld.ml0000644000175000017500000000344312124403241024604 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk;; (* Make interface functions available *) let top = opentk ();; (* Initialisation of the interface *) (* top is now the toplevel widget *) (* Widget initialisation *) let b = Button.create top [Text "foobar"; Command (function () -> print_string "foobar"; print_newline(); flush stdout)];; (* b exists but is not yet visible *) let q = Button.create top [Text "quit"; Command closeTk];; (* q exists but is not yet visible *) pack [b; q][] ;; (* Make b visible *) mainLoop() ;; (* User interaction*) (* You can quit this program by deleting its main window *) mingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/jptest.ml0000644000175000017500000000231112124403241023733 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Tk let win = opentk();; let b = Button.create win [ Text "" ];; let _ = pack [b] [];; mainLoop();; mingw-ocaml/ocaml/otherlibs/labltk/examples_camltk/taddition.ml0000644000175000017500000000442312124403241024407 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Tk let main () = let top = opentk () in (* The widgets. They all have "top" as parent widget. *) let en1 = Entry.create top [TextWidth 6; Relief Sunken] in let lab1 = Label.create top [Text "plus"] in let en2 = Entry.create top [TextWidth 6 ; Relief Sunken] in let lab2 = Label.create top [Text "="] in let result_display = Label.create top [] in (* References holding values of entry widgets *) let n1 = ref 0 and n2 = ref 0 in (* Refresh result *) let refresh () = Label.configure result_display [Text (string_of_int (!n1 + !n2))] in (* Electric *) let get_and_refresh (w,r) = fun _ _ -> try r := int_of_string (Entry.get w); refresh () with Failure "int_of_string" -> Label.configure result_display [Text "error"] in (* Set the callbacks *) Entry.configure en1 [XScrollCommand (get_and_refresh (en1,n1)) ]; Entry.configure en2 [XScrollCommand (get_and_refresh (en2,n2)) ]; (* Map the widgets *) pack [en1;lab1;en2;lab2;result_display] []; (* Make the window resizable *) Wm.minsize_set top 1 1; (* Start interaction (event-driven program) *) Threadtk.mainLoop () ;; let _ = Printexc.catch main () ;; mingw-ocaml/ocaml/otherlibs/labltk/labltk/0000755000175000017500000000000012124403241020173 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/labltk/.ignore0000644000175000017500000000003412124403241021454 0ustar tootstoots*.ml *.mli labltktop labltk mingw-ocaml/ocaml/otherlibs/labltk/labltk/Makefile0000644000175000017500000000360212124403241021634 0ustar tootstoots####################################################################### # # # MLTk, Tcl/Tk interface of OCaml # # # # Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # # projet Cristal, INRIA Rocquencourt # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 2002 Institut National de Recherche en Informatique et # # en Automatique and Kyoto University. All rights reserved. # # This file is distributed under the terms of the GNU Library # # General Public License, with the special exception on linking # # described in file LICENSE found in the OCaml source tree. # # # ####################################################################### include ../support/Makefile.common COMPFLAGS= -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/unix all: labltkobjs opt: labltkobjsx include ./modules LABLTKOBJS = $(WIDGETOBJS) tk.cmo labltk.cmo LABLTKOBJSX = $(LABLTKOBJS:.cmo=.cmx) labltkobjs: $(LABLTKOBJS) labltkobjsx: $(LABLTKOBJSX) install: if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi cp $(LABLTKOBJS:.cmo=.cmi) $(WIDGETOBJS:.cmo=.mli) $(INSTALLDIR) chmod 644 $(INSTALLDIR)/*.cmi installopt: @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi cp $(LABLTKOBJSX) $(INSTALLDIR) chmod 644 $(INSTALLDIR)/*.cmx clean: $(MAKE) -f Makefile.gen clean .SUFFIXES : .SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp .mli.cmi: $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmo: $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< include .depend mingw-ocaml/ocaml/otherlibs/labltk/labltk/Makefile.gen.nt0000644000175000017500000000002512124403241023020 0ustar tootstootsinclude Makefile.gen mingw-ocaml/ocaml/otherlibs/labltk/labltk/Makefile.nt0000644000175000017500000000002112124403241022244 0ustar tootstootsinclude Makefile mingw-ocaml/ocaml/otherlibs/labltk/labltk/Makefile.gen0000644000175000017500000000450512124403241022407 0ustar tootstoots####################################################################### # # # MLTk, Tcl/Tk interface of OCaml # # # # Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # # projet Cristal, INRIA Rocquencourt # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 2002 Institut National de Recherche en Informatique et # # en Automatique and Kyoto University. All rights reserved. # # This file is distributed under the terms of the GNU Library # # General Public License, with the special exception on linking # # described in file LICENSE found in the OCaml source tree. # # # ####################################################################### include ../support/Makefile.common all: tk.ml labltk.ml .depend _tkgen.ml: ../Widgets.src ../compiler/tkcompiler$(EXE) cd ..; $(CAMLRUNGEN) compiler/tkcompiler$(EXE) -outdir labltk # dependencies are broken: wouldn't work with gmake 3.77 #tk.ml labltk.ml .depend: generate tk.ml labltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp$(EXE) #../builtin/builtin_*.ml (echo 'open StdLabels'; \ echo 'open Widget'; \ echo 'open Protocol'; \ echo 'open Support'; \ echo 'open Textvariable'; \ cat ../builtin/report.ml; \ cat ../builtin/builtin_*.ml; \ cat _tkgen.ml; \ echo ; \ echo ; \ echo 'module Tkintf = struct'; \ cat ../builtin/builtini_*.ml; \ cat _tkigen.ml; \ echo 'end (* module Tkintf *)'; \ echo ; \ echo ; \ echo 'open Tkintf' ;\ echo ; \ echo ; \ cat ../builtin/builtinf_*.ml; \ cat _tkfgen.ml; \ echo ; \ ) > _tk.ml $(CAMLRUN) ../compiler/pp < _tk.ml > tk.ml rm -f _tk.ml $(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend ../compiler/pp$(EXE): cd ../compiler; $(MAKE) pp$(EXE) ../compiler/tkcompiler$(EXE): cd ../compiler; $(MAKE) tkcompiler$(EXE) # All .{ml,mli} files are generated in this directory clean: rm -f *.cm* *.ml *.mli *.$(O) *.$(A) .depend # rm -f modules .PHONY: all generate clean mingw-ocaml/ocaml/otherlibs/labltk/labltk/byte.itarget0000644000175000017500000000067312124403241022525 0ustar tootstootsplace.cmo wm.cmo imagephoto.cmo canvas.cmo button.cmo text.cmo label.cmo scrollbar.cmo image.cmo encoding.cmo pixmap.cmo palette.cmo font.cmo message.cmo menu.cmo entry.cmo listbox.cmo focus.cmo menubutton.cmo pack.cmo option.cmo toplevel.cmo frame.cmo dialog.cmo imagebitmap.cmo clipboard.cmo radiobutton.cmo tkwait.cmo grab.cmo selection.cmo scale.cmo optionmenu.cmo winfo.cmo grid.cmo checkbutton.cmo bell.cmo tkvars.cmo tk.cmo labltk.cmo mingw-ocaml/ocaml/otherlibs/labltk/labltk/native.itarget0000644000175000017500000000065012124403241023043 0ustar tootstootsplace.cmx wm.cmx imagephoto.cmx canvas.cmx button.cmx text.cmx label.cmx scrollbar.cmx image.cmx encoding.cmx pixmap.cmx palette.cmx font.cmx message.cmx menu.cmx entry.cmx listbox.cmx focus.cmx menubutton.cmx pack.cmx option.cmx toplevel.cmx frame.cmx dialog.cmx imagebitmap.cmx clipboard.cmx radiobutton.cmx tkwait.cmx grab.cmx selection.cmx scale.cmx optionmenu.cmx winfo.cmx grid.cmx checkbutton.cmx bell.cmx tkvars.cmx mingw-ocaml/ocaml/otherlibs/labltk/labltk/modules0000644000175000017500000000512312124403241021567 0ustar tootstootsWIDGETOBJS=bell.cmo scale.cmo winfo.cmo scrollbar.cmo entry.cmo listbox.cmo wm.cmo tkwait.cmo grab.cmo font.cmo canvas.cmo image.cmo clipboard.cmo label.cmo message.cmo text.cmo imagephoto.cmo option.cmo frame.cmo selection.cmo dialog.cmo place.cmo pixmap.cmo menubutton.cmo radiobutton.cmo focus.cmo pack.cmo imagebitmap.cmo encoding.cmo optionmenu.cmo checkbutton.cmo tkvars.cmo palette.cmo menu.cmo button.cmo toplevel.cmo grid.cmo bell.ml scale.ml winfo.ml scrollbar.ml entry.ml listbox.ml wm.ml tkwait.ml grab.ml font.ml canvas.ml image.ml clipboard.ml label.ml message.ml text.ml imagephoto.ml option.ml frame.ml selection.ml dialog.ml place.ml pixmap.ml menubutton.ml radiobutton.ml focus.ml pack.ml imagebitmap.ml encoding.ml optionmenu.ml checkbutton.ml tkvars.ml palette.ml menu.ml button.ml toplevel.ml grid.ml : _tkgen.ml bell.cmo : bell.ml bell.cmi : bell.mli scale.cmo : scale.ml scale.cmi : scale.mli winfo.cmo : winfo.ml winfo.cmi : winfo.mli scrollbar.cmo : scrollbar.ml scrollbar.cmi : scrollbar.mli entry.cmo : entry.ml entry.cmi : entry.mli listbox.cmo : listbox.ml listbox.cmi : listbox.mli wm.cmo : wm.ml wm.cmi : wm.mli tkwait.cmo : tkwait.ml tkwait.cmi : tkwait.mli grab.cmo : grab.ml grab.cmi : grab.mli font.cmo : font.ml font.cmi : font.mli canvas.cmo : canvas.ml canvas.cmi : canvas.mli image.cmo : image.ml image.cmi : image.mli clipboard.cmo : clipboard.ml clipboard.cmi : clipboard.mli label.cmo : label.ml label.cmi : label.mli message.cmo : message.ml message.cmi : message.mli text.cmo : text.ml text.cmi : text.mli imagephoto.cmo : imagephoto.ml imagephoto.cmi : imagephoto.mli option.cmo : option.ml option.cmi : option.mli frame.cmo : frame.ml frame.cmi : frame.mli selection.cmo : selection.ml selection.cmi : selection.mli dialog.cmo : dialog.ml dialog.cmi : dialog.mli place.cmo : place.ml place.cmi : place.mli pixmap.cmo : pixmap.ml pixmap.cmi : pixmap.mli menubutton.cmo : menubutton.ml menubutton.cmi : menubutton.mli radiobutton.cmo : radiobutton.ml radiobutton.cmi : radiobutton.mli focus.cmo : focus.ml focus.cmi : focus.mli pack.cmo : pack.ml pack.cmi : pack.mli imagebitmap.cmo : imagebitmap.ml imagebitmap.cmi : imagebitmap.mli encoding.cmo : encoding.ml encoding.cmi : encoding.mli optionmenu.cmo : optionmenu.ml optionmenu.cmi : optionmenu.mli checkbutton.cmo : checkbutton.ml checkbutton.cmi : checkbutton.mli tkvars.cmo : tkvars.ml tkvars.cmi : tkvars.mli palette.cmo : palette.ml palette.cmi : palette.mli menu.cmo : menu.ml menu.cmi : menu.mli button.cmo : button.ml button.cmi : button.mli toplevel.cmo : toplevel.ml toplevel.cmi : toplevel.mli grid.cmo : grid.ml grid.cmi : grid.mli mingw-ocaml/ocaml/otherlibs/labltk/frx/0000755000175000017500000000000012124403241017521 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/frx/frx_req.mli0000644000175000017500000000425212124403241021675 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* Various dialog boxes *) val open_simple : string -> (string -> unit) -> (unit -> 'a) -> Textvariable.textVariable -> unit (* [open_simple title action cancelled memory] A dialog with a message and an entry field (with memory between invocations). Either [action] or [cancelled] is called when the user answers to the dialog (with Ok or Cancel) *) val open_simple_synchronous : string -> Textvariable.textVariable -> bool (* [open_simple_synchronous title memory] A synchronous dialog with a message and an entry field (with memory between invocations). Returns true if the user clicks Ok or false if the user clicks Cancel. *) val open_list : string -> string list -> (string -> unit) -> (unit -> unit) -> unit (* [open_list title elements action cancelled] A dialog for selecting from a list of elements. [action] is called on each selected element, or [cancelled] is called if the user clicks Cancel. *) val open_passwd : string -> string * string (* [open_passwd title] pops up a username/password dialog and returns (username, password). *) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_toplevel.mli0000644000175000017500000000220412124403241022733 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Widget val make_visible : Widget -> unit mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_fillbox.ml0000644000175000017500000000607412124403241022400 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk (* * Progress indicators *) let okcolor = NamedColor "#3cb371" and kocolor = NamedColor "#dc5c5c" let new_vertical parent w h = let c = Canvas.create_named parent "fillbox" [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1); Relief Sunken] in let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels w) (Pixels 0) [FillColor okcolor; Outline okcolor] in c, (function 0 -> Canvas.configure_rectangle c i [FillColor okcolor; Outline okcolor]; Canvas.coords_set c i [Pixels 0; Pixels 0; Pixels w; Pixels 0] | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; Outline kocolor] | n -> let percent = if n > 100 then 100 else n in let hf = percent*h/100 in Canvas.coords_set c i [Pixels 0; Pixels 0; Pixels w; Pixels hf]) let new_horizontal parent w h = let c = Canvas.create_named parent "fillbox" [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1); Relief Sunken] in let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels 0) (Pixels h) [FillColor okcolor; Outline okcolor] in c, (function 0 -> Canvas.configure_rectangle c i [FillColor okcolor; Outline okcolor]; Canvas.coords_set c i [Pixels 0; Pixels 0; Pixels 0; Pixels h] | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; Outline kocolor] | n -> let percent = if n > 100 then 100 else n in let wf = percent*w/100 in Canvas.coords_set c i [Pixels 0; Pixels 0; Pixels wf; Pixels h]) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_selection.ml0000644000175000017500000000377412124403241022732 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* A selection handler *) open Widget open Protocol open Camltk let frame = ref None let selection = ref "" let read ofs n = let res = if ofs < 0 then "" else if ofs + n > String.length !selection then String.sub !selection ofs (String.length !selection - ofs) else String.sub !selection ofs n in tkreturn res (* As long as we don't loose the selection, we keep the widget *) (* Calling this function means that we own the selection *) (* When we loose the selection, both cb are destroyed *) let own () = match !frame with None -> let f = Frame.create_named Widget.default_toplevel "frx_selection" [] in let lost () = selection := ""; destroy f; frame := None in Selection.own_set [Selection "PRIMARY"; LostCommand lost] f; Selection.handle_set [Selection "PRIMARY"; ICCCMType "STRING"] f read; frame := Some f | Some f -> () let set s = own(); selection := s mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_mem.mli0000644000175000017500000000247712124403241021673 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* A Garbage Collector Gauge for OCaml *) val init : unit -> unit (* [init ()] creates the gauge and its updater, but keeps it iconified *) val f : unit -> unit (* [f ()] makes the gauge visible if it has not been destroyed *) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_lbutton.mli0000644000175000017500000000234312124403241022574 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Widget open Camltk val version : string val create : Widget -> option list -> Widget and configure : Widget -> option list -> unit mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_synth.ml0000644000175000017500000000635512124403241022110 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* Some notion of synthetic events *) open Camltk open Widget open Protocol (* To each event is associated a table of (widget, callback) *) let events = Hashtbl.create 37 (* Notes: * "cascading" events (on the same event) are not supported * Only one binding active at a time for each event on each widget. *) (* Get the callback table associated with . Initializes if required *) let get_event name = try Hashtbl.find events name with Not_found -> let h = Hashtbl.create 37 in Hashtbl.add events name h; (* Initialize the callback invocation mechanism, based on variable trace *) let var = "camltk_events(" ^ name ^")" in let tkvar = Textvariable.coerce var in let rec set () = Textvariable.handle tkvar (fun () -> begin match Textvariable.get tkvar with "all" -> (* Invoke all callbacks *) Hashtbl.iter (fun p f -> try f (cTKtoCAMLwidget p) with _ -> ()) h | p -> (* Invoke callback for p *) try let w = cTKtoCAMLwidget p and f = Hashtbl.find h p in f w with _ -> () end; set ()(* reactivate the callback *) ) in set(); h (* Remove binding for event on widget *) let remove w name = Hashtbl.remove (get_event name) (Widget.name w) (* Adds as callback for widget on event *) let bind w name f = remove w name; Hashtbl.add (get_event name) (Widget.name w) f (* Sends event to all widgets *) let broadcast name = Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) "all" (* Sends event to widget *) let send name w = Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) (Widget.name w) (* Remove all callbacks associated to widget *) let remove_callbacks w = Hashtbl.iter (fun _ h -> Hashtbl.remove h (Widget.name w)) events let _ = add_destroy_hook remove_callbacks mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_misc.mli0000644000175000017500000000253212124403241022040 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk val autodef : (unit -> 'a) -> (unit -> 'a) (* [autodef make] is a pleasant wrapper around 'a option ref *) val create_photo : Camltk.options list -> Camltk.imagePhoto (* [create_photo options] allows Data in options (by saving to tmp file) *) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_after.ml0000644000175000017500000000262012124403241022033 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Protocol let idle f = let id = new_function_id () in let wrapped _ = clear_callback id; (* do it first in case f raises exception *) f() in Hashtbl.add callback_naming_table id wrapped; tkCommand [| TkToken "after"; TkToken "idle"; TkToken ("camlcb "^ string_of_cbid id) |] mingw-ocaml/ocaml/otherlibs/labltk/frx/Makefile0000644000175000017500000000402712124403241021164 0ustar tootstoots####################################################################### # # # MLTk, Tcl/Tk interface of OCaml # # # # Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # # projet Cristal, INRIA Rocquencourt # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 2002 Institut National de Recherche en Informatique et # # en Automatique and Kyoto University. All rights reserved. # # This file is distributed under the terms of the GNU Library # # General Public License, with the special exception on linking # # described in file LICENSE found in the OCaml source tree. # # # ####################################################################### include ../support/Makefile.common COMPFLAGS=-I ../camltk -I ../support OBJS= frx_misc.cmo frx_widget.cmo frx_font.cmo frx_entry.cmo frx_text.cmo \ frx_listbox.cmo frx_req.cmo frx_fillbox.cmo frx_focus.cmo \ frx_dialog.cmo frx_mem.cmo frx_rpc.cmo frx_synth.cmo frx_selection.cmo \ frx_after.cmo frx_fit.cmo frx_ctext.cmo frx_color.cmo OBJSX = $(OBJS:.cmo=.cmx) all: frxlib.cma opt: frxlib.cmxa frxlib.cma: $(OBJS) $(CAMLLIBR) -o frxlib.cma $(OBJS) frxlib.cmxa: $(OBJSX) $(CAMLOPTLIBR) -o frxlib.cmxa $(OBJSX) install: cp *.cmi *.mli frxlib.cma $(INSTALLDIR) installopt: cp frxlib.cmxa frxlib.$(A) $(INSTALLDIR) clean: rm -f *.cm* *.$(O) *.$(A) $(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma $(OBJSX): ../lib/$(LIBNAME).cmxa .SUFFIXES : .SUFFIXES : .mli .ml .cmi .cmo .cmx .mli.cmi: $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmo: $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< depend: $(CAMLDEP) *.mli *.ml > .depend include .depend mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_fillbox.mli0000644000175000017500000000326312124403241022546 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk val new_vertical : Widget.widget -> int -> int -> Widget.widget * (int -> unit) (* [new_vertical parent width height] creates a vertical fillbox of [width] and [height]. Returns a frame widget and a function to set the current value of the fillbox. The value can be n < 0 : the fillbox changes color (reddish) 0 <= n <= 100: the fillbox fills up to n percent 100 <= n : the fillbox fills up to 95% *) val new_horizontal : Widget.widget -> int -> int -> Widget.widget * (int -> unit) (* save as above, except the widget is horizontal *) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_entry.ml0000644000175000017500000000345312124403241022100 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk let version = "$Id$" (* * Tk 4.0 has emacs bindings for entry widgets *) let new_label_entry parent txt action = let f = Frame.create parent [] in let m = Label.create f [Text txt] and e = Entry.create f [Relief Sunken; TextWidth 0] in Camltk.bind e [[], KeyPressDetail "Return"] (BindSet ([], fun _ -> action(Entry.get e))); pack [m][Side Side_Left]; pack [e][Side Side_Right; Fill Fill_X; Expand true]; f,e let new_labelm_entry parent txt memo = let f = Frame.create parent [] in let m = Label.create f [Text txt] and e = Entry.create f [Relief Sunken; TextVariable memo; TextWidth 0] in pack [m][Side Side_Left]; pack [e][Side Side_Right; Fill Fill_X; Expand true]; f,e mingw-ocaml/ocaml/otherlibs/labltk/frx/Makefile.nt0000644000175000017500000000002112124403241021572 0ustar tootstootsinclude Makefile mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_listbox.ml0000644000175000017500000000700112124403241022414 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk let version = "$Id$" (* * Link a scrollbar and a listbox *) let scroll_link sb lb = Listbox.configure lb [YScrollCommand (Scrollbar.set sb)]; Scrollbar.configure sb [ScrollCommand (Listbox.yview lb)] (* * Completion for listboxes, Macintosh style. * As long as you type fast enough, the listbox is repositioned to the * first entry "greater" than the typed prefix. * assumes: * sorted list (otherwise it's stupid) * fixed size, because we don't recompute size at each callback invocation *) let add_completion lb action = let prefx = ref "" (* current match prefix *) and maxi = Listbox.size lb - 1 (* maximum index (doesn't matter actually) *) and current = ref 0 (* current position *) and lastevent = ref 0 in let rec move_forward () = if Listbox.get lb (Number !current) < !prefx then if !current < maxi then begin incr current; move_forward() end and recenter () = let element = Number !current in (* Clean the selection *) Listbox.selection_clear lb (Number 0) End; (* Set it to our unique element *) Listbox.selection_set lb element element; (* Activate it, to keep consistent with Up/Down. You have to be in Extended or Browse mode *) Listbox.activate lb element; Listbox.selection_anchor lb element; Listbox.see lb element in let complete time s = if time - !lastevent < 500 then (* sorry, hard coded limit *) prefx := !prefx ^ s else begin (* reset *) current := 0; prefx := s end; lastevent := time; move_forward(); recenter() in bind lb [[], KeyPress] (BindSet([Ev_Char; Ev_Time], (function ev -> (* consider only keys producing characters. The callback is called * even if you press Shift. *) if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char))); (* Key specific bindings override KeyPress *) bind lb [[], KeyPressDetail "Return"] (BindSet([], action)); (* Finally, we have to set focus, otherwise events dont get through *) Focus.set lb; recenter() (* so that first item is selected *) let new_scrollable_listbox top options = let f = Frame.create top [] in let lb = Listbox.create f options and sb = Scrollbar.create f [] in scroll_link sb lb; pack [lb] [Side Side_Left; Fill Fill_Both; Expand true]; pack [sb] [Side Side_Left; Fill Fill_Y]; f, lb mingw-ocaml/ocaml/otherlibs/labltk/frx/README0000644000175000017500000000010712124403241020377 0ustar tootstootsThis is Francois Rouaix's widget set library, Frx. It uses CamlTk API. mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_group.ml0000644000175000017500000000231312124403241022065 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk let vgroup top l = let f = Frame.create top [] in Pack.forget l; Pack.configure l [In f]; f mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_fit.mli0000644000175000017500000000313312124403241021665 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk open Widget val debug: bool ref val vert: widget -> (float -> float -> unit) * (unit -> unit) (* [vert widget] can be applied to a text widget so that it expands to show its full contents. Returns [scroll] and [check]. [scroll] must be used as the YScrollCommand of the widget. [check] can be called when some modification occurs in the content of the widget (such as a size change in some embedded windows. This feature is a terrible hack and should be used with extreme caution. *) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_color.mli0000644000175000017500000000216112124403241022221 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) val check : string -> bool mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_color.ml0000644000175000017500000000313512124403241022052 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk open Protocol module StringSet = Set.Make(struct type t = string let compare = compare end) (* should we keep a negative cache ? *) let available_colors = ref (StringSet.empty) let check s = if StringSet.mem s !available_colors then true else begin try let f = Frame.create_named Widget.default_toplevel "frxcolorcheck" [Background (NamedColor s)] in available_colors := StringSet.add s !available_colors; destroy f; true with TkError _ -> false end mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_widget.mli0000644000175000017500000000221612124403241022367 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk open Widget val resizeable : widget -> unit mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_fit.ml0000644000175000017500000000626712124403241021527 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk let debug = ref false let vert wid = let newsize = ref 0 and pending_resize = ref false and last_last = ref 0.0 in let rec resize () = pending_resize := false; if !debug then (Printf.eprintf "%s Resize %d\n" (Widget.name wid) !newsize; flush stderr); Text.configure wid [TextHeight !newsize]; () and check () = let first, last = Text.yview_get wid in check1 first last and check1 first last = let curheight = int_of_string (cget wid CHeight) in if !debug then begin Printf.eprintf "%s C %d %f %f\n" (Widget.name wid) curheight first last; flush stderr end; if first = 0.0 && last = 1.0 then () (* Don't attempt anything if widget is not visible *) else if not (Winfo.viewable wid) then begin if !debug then (Printf.eprintf "%s C notviewable\n" (Widget.name wid); flush stderr); (* Try again later *) bind wid [[], Expose] (BindSet ([], fun _ -> bind wid [[], Expose] BindRemove; check())) end else begin let delta = if last = 0.0 then 1 else if last = !last_last then (* it didn't change since our last resize ! *) 1 else begin last_last := last; (* never to more than double *) let visible = max 0.5 (last -. first) in max 1 (truncate (float curheight *. (1. -. visible))) end in newsize := max (curheight + delta) !newsize; if !debug then (Printf.eprintf "%s newsize: %d\n" (Widget.name wid) !newsize; flush stderr); if !pending_resize then () else begin pending_resize := true; Timer.set 300 (fun () -> Frx_after.idle resize) end end and scroll first last = if !debug then (Printf.eprintf "%s V %f %f\n" (Widget.name wid) first last; flush stderr); if first = 0.0 && last = 1.0 then () else check1 first last in scroll, check mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_ctext.ml0000644000175000017500000000623612124403241022070 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* A trick by Steve Ball to do pixel scrolling on text widgets *) (* USES frx_fit *) open Camltk let create top opts navigation = let f = Frame.create top [BorderWidth (Pixels 2); Relief Raised] in let lf = Frame.create f [] in let rf = Frame.create f [] in let c = Canvas.create lf [BorderWidth (Pixels 0)] and xscroll = Scrollbar.create lf [Orient Horizontal] and yscroll = Scrollbar.create rf [Orient Vertical] and secret = Frame.create_named rf "secret" [] in let t = Text.create c (BorderWidth(Pixels 0) :: opts) in if navigation then Frx_text.navigation_keys t; (* Make the text widget an embedded canvas object *) ignore (Canvas.create_window c (Pixels 0) (Pixels 0) [Anchor NW; Window t; Tags [Tag "main"]]); Canvas.focus c (Tag "main"); (* Canvas.configure c [Width (Pixels (Winfo.reqwidth t)); Height(Pixels (Winfo.reqheight t))]; *) Canvas.configure c [YScrollCommand (Scrollbar.set yscroll)]; (* The horizontal scrollbar is directly attached to the * text widget, because h scrolling works properly *) Scrollbar.configure xscroll [ScrollCommand (Text.xview t)]; (* But vertical scroll is attached to the canvas *) Scrollbar.configure yscroll [ScrollCommand (Canvas.yview c)]; let scroll, check = Frx_fit.vert t in Text.configure t [ XScrollCommand (Scrollbar.set xscroll); YScrollCommand (fun first last -> scroll first last; let x,y,w,h = Canvas.bbox c [Tag "main"] in Canvas.configure c [ScrollRegion (Pixels x, Pixels y, Pixels w, Pixels h)]) ]; bind c [[],Configure] (BindSet ([Ev_Width], (fun ei -> Canvas.configure_window c (Tag "main") [Width (Pixels ei.ev_Width)]))); pack [rf] [Side Side_Right; Fill Fill_Y]; pack [lf] [Side Side_Left; Fill Fill_Both; Expand true]; pack [secret] [Side Side_Bottom]; pack [yscroll] [Side Side_Top; Fill Fill_Y; Expand true]; pack [xscroll] [Side Side_Bottom; Fill Fill_X]; pack [c] [Side Side_Left; Fill Fill_Both; Expand true]; f, t mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_widget.ml0000644000175000017500000000246612124403241022225 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk open Widget let version = "$Id$" (* Make a window (toplevel widget) resizeable *) let resizeable t = update_idletasks(); (* wait until layout is computed *) Wm.minsize_set t (Winfo.width t) (Winfo.height t) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_synth.mli0000644000175000017500000000266112124403241022255 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* Synthetic events *) open Camltk open Widget val send : string -> widget -> unit (* [send event_name widget] *) val broadcast : string -> unit (* [broadcase event_name] *) val bind : widget -> string -> (widget -> unit) -> unit (* [bind event_name callback] *) val remove : widget -> string -> unit (* [remove widget event_name] *) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_rpc.mli0000644000175000017500000000270012124403241021666 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* Some notion of RPC *) val register : string -> (string list -> unit) -> unit (* [register external_name f] *) val invoke : string -> string -> string list -> string (* [invoke interp name args] *) val async_invoke : string -> string -> string list -> unit (* [async_invoke interp name args] *) val rpc_info : string -> string (* [rpc_info interp] *) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_text.mli0000644000175000017500000000413112124403241022066 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk val abs_index : int -> textIndex (* [abs_index offs] returns the corresponding TextIndex *) val insertMark : textIndex val currentMark : textIndex val textEnd : textIndex val textBegin : textIndex (* shortcuts for various positions in a text widget *) val scroll_link : Widget.widget -> Widget.widget -> unit (* [scroll_link scrollbar text] links a scrollbar and a text widget as expected *) val new_scrollable_text : Widget.widget -> options list -> bool -> Widget.widget * Widget.widget (* [new_scrollable_text parent opts nav_keys] makes a scrollable text widget with optional navigation keys. Returns frame and text widget. *) val addsearch : Widget.widget -> unit (* [addsearch textw] adds a search dialog bound on [Control-s] on the text widget *) val navigation_keys : Widget.widget -> unit (* [navigation_keys textw] adds common navigations functions to [textw] *) val init : unit -> unit (* [init ()] must be called before any of the above features is used *) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_misc.ml0000644000175000017500000000500012124403241021660 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* Delayed global, a.k.a cache&carry *) let autodef f = let v = ref None in (function () -> match !v with None -> let x = f() in v := Some x; x | Some x -> x) open Camltk (* allows Data in options *) let create_photo options = let hasopt = ref None in (* Check options *) List.iter (function Data s -> begin match !hasopt with None -> hasopt := Some (Data s) | Some _ -> raise (Protocol.TkError "two data sources in options") end | File f -> begin match !hasopt with None -> hasopt := Some (File f) | Some _ -> raise (Protocol.TkError "two data sources in options") end | o -> ()) options; match !hasopt with None -> raise (Protocol.TkError "no data source in options") | Some (Data s) -> begin let tmpfile = Filename.temp_file "img" "" in let oc = open_out_bin tmpfile in output_string oc s; close_out oc; let newopts = List.map (function | Data s -> File tmpfile | o -> o) options in try let i = Imagephoto.create newopts in (try Sys.remove tmpfile with Sys_error _ -> ()); i with e -> (try Sys.remove tmpfile with Sys_error _ -> ()); raise e end | Some (File s) -> Imagephoto.create options | _ -> assert false mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_listbox.mli0000644000175000017500000000327512124403241022576 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk val scroll_link : Widget.widget -> Widget.widget -> unit (* [scroll_link scrollbar listbox] links [scrollbar] and [listbox] as expected. *) val add_completion : Widget.widget -> (eventInfo -> unit) -> unit (* [add_completion listbox action] adds Macintosh like electric navigation in the listbox when characters are typed in. [action] is invoked if Return is pressed *) val new_scrollable_listbox : Widget.widget -> options list -> Widget.widget * Widget.widget (* [new_scrollable_listbox parent options] makes a scrollable listbox and returns (frame, listbox) *) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_mem.ml0000644000175000017500000001001112124403241021501 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* Memory gauge *) open Camltk open Gc let inited = ref None let w = ref 300 let delay = ref 5 (* in seconds *) let wordsize = (* officially approved *) if 1 lsl 31 = 0 then 4 else 8 let init () = let top = Toplevel.create Widget.default_toplevel [Class "CamlGC"] in let name = Camltk.appname_get () in Wm.title_set top (name ^ " Memory Gauge"); Wm.withdraw top; inited := Some top; (* this should be executed before the internal "all" binding *) bind top [[], Destroy] (BindSet ([], (fun _ -> inited := None))); let fminors = Frame.create top [] in let lminors = Label.create fminors [Text "Minor collections"] and vminors = Label.create fminors [] in pack [lminors][Side Side_Left]; pack [vminors][Side Side_Right; Fill Fill_X; Expand true]; let fmajors = Frame.create top [] in let lmajors = Label.create fmajors [Text "Major collections"] and vmajors = Label.create fmajors [] in pack [lmajors][Side Side_Left]; pack [vmajors][Side Side_Right; Fill Fill_X; Expand true]; let fcompacts = Frame.create top [] in let lcompacts = Label.create fcompacts [Text "Compactions"] and vcompacts = Label.create fcompacts [] in pack [lcompacts][Side Side_Left]; pack [vcompacts][Side Side_Right; Fill Fill_X; Expand true]; let fsize = Frame.create top [] in let lsize = Label.create fsize [Text "Heap size (bytes)"] and vsize = Label.create fsize [] in pack [lsize][Side Side_Left]; pack [vsize][Side Side_Right; Fill Fill_X; Expand true]; let fheap = Frame.create top [Width (Pixels !w); Height (Pixels 10)] in let flive = Frame.create fheap [Background Red] and ffree = Frame.create fheap [Background Green] and fdead = Frame.create fheap [Background Black] in pack [fminors; fmajors; fcompacts; fsize; fheap][Fill Fill_X]; let display () = let st = Gc.stat() in Label.configure vminors [Text (string_of_int st.minor_collections)]; Label.configure vmajors [Text (string_of_int st.major_collections)]; Label.configure vcompacts [Text (string_of_int st.compactions)]; Label.configure vsize [Text (string_of_int (wordsize * st.heap_words))]; let liver = (float st.live_words) /. (float st.heap_words) and freer = (float st.free_words) /. (float st.heap_words) in Place.configure flive [X (Pixels 0); Y (Pixels 0); RelWidth liver; RelHeight 1.0]; Place.configure ffree [RelX liver; Y (Pixels 0); RelWidth freer; RelHeight 1.0]; Place.configure fdead [RelX (liver +. freer); Y (Pixels 0); RelWidth (1.0 -. freer -. liver); RelHeight 1.0] in let rec tim () = if Winfo.exists top then begin display(); Timer.set (!delay * 1000) tim end in tim() let rec f () = match !inited with Some w -> Wm.deiconify w | None -> init (); f() mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_entry.mli0000644000175000017500000000326612124403241022253 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk val new_label_entry : Widget.widget -> string -> (string -> unit) -> Widget.widget * Widget.widget (* [new_label_entry parent label action] creates a "labelled" entry widget where [action] will be invoked when the user types Return in the widget. Returns (frame widget, entry widget) *) val new_labelm_entry : Widget.widget -> string -> Textvariable.textVariable -> Widget.widget * Widget.widget (* [new_labelm_entry parent label variable] creates a "labelled" entry widget whose contents is [variable]. Returns (frame widget, entry widget) *) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_font.ml0000644000175000017500000000414312124403241021702 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk open Widget let version = "$Id$" (* * Finding fonts. Inspired by code in Ical by Sanjay Ghemawat. * Possibly bogus because some families use "i" for italic where others * use "o". * wght: bold, medium * slant: i, o, r * pxlsz: 8, 10, ... *) module StringSet = Set.Make(struct type t = string let compare = compare end) let available_fonts = ref (StringSet.empty) let get_canvas = Frx_misc.autodef (fun () -> Canvas.create Widget.default_toplevel []) let find fmly wght slant pxlsz = let fontspec = "-*-"^fmly^"-"^wght^"-"^slant^"-normal-*-"^string_of_int pxlsz^"-*-*-*-*-*-iso8859-1" in if StringSet.mem fontspec !available_fonts then fontspec else let c = get_canvas() in try let tag = Canvas.create_text c (Pixels 0) (Pixels 0) [Text "foo"; Font fontspec] in Canvas.delete c [tag]; available_fonts := StringSet.add fontspec !available_fonts; fontspec with _ -> raise (Invalid_argument fontspec) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_selection.mli0000644000175000017500000000224312124403241023071 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) val set : string -> unit (* [set s] sets the X PRIMARY selection to [s] *) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_after.mli0000644000175000017500000000226512124403241022211 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) val idle : (unit -> unit) -> unit (* [idle f] is equivalent to Tk "after idle {camlcb f}" *) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_req.ml0000644000175000017500000001633512124403241021531 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk (* * Some standard requesters (in Amiga techspeak) or dialog boxes (in Apple * jargon). *) let version = "$Id$" (* * Simple requester * an entry field, unrestricted, with emacs-like bindings * Note: grabs focus, thus always unique at one given moment, and we * shouldn't have to worry about toplevel widget name. * We add a title widget in case the window manager does not decorate * toplevel windows. *) let open_simple title action notaction memory = let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in Focus.set t; Wm.title_set t title; let tit = Label.create t [Text title] in let len = max 40 (String.length (Textvariable.get memory)) in let e = Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in let activate _ = let v = Entry.get e in Grab.release t; (* because of wm *) destroy t; (* so action can call open_simple *) action v in bind e [[], KeyPressDetail "Return"] (BindSet ([], activate)); let f = Frame.create t [] in let bok = Button.create f [Text "Ok"; Command activate] in let bcancel = Button.create f [Text "Cancel"; Command (fun () -> notaction(); Grab.release t; destroy t)] in bind e [[], KeyPressDetail "Escape"] (BindSet ([], (fun _ -> Button.invoke bcancel))); pack [bok] [Side Side_Left; Expand true]; pack [bcancel] [Side Side_Right; Expand true]; pack [tit;e] [Fill Fill_X]; pack [f] [Side Side_Bottom; Fill Fill_X]; Frx_widget.resizeable t; Focus.set e; Tkwait.visibility t; Grab.set t (* A synchronous version *) let open_simple_synchronous title memory = let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in Focus.set t; Wm.title_set t title; let tit = Label.create t [Text title] in let len = max 40 (String.length (Textvariable.get memory)) in let e = Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in let waiting = Textvariable.create_temporary t in let activate _ = Grab.release t; (* because of wm *) destroy t; (* so action can call open_simple *) Textvariable.set waiting "1" in bind e [[], KeyPressDetail "Return"] (BindSet ([], activate)); let f = Frame.create t [] in let bok = Button.create f [Text "Ok"; Command activate] in let bcancel = Button.create f [Text "Cancel"; Command (fun () -> Grab.release t; destroy t; Textvariable.set waiting "0")] in bind e [[], KeyPressDetail "Escape"] (BindSet ([], (fun _ -> Button.invoke bcancel))); pack [bok] [Side Side_Left; Expand true]; pack [bcancel] [Side Side_Right; Expand true]; pack [tit;e] [Fill Fill_X]; pack [f] [Side Side_Bottom; Fill Fill_X]; Frx_widget.resizeable t; Focus.set e; Tkwait.visibility t; Grab.set t; Tkwait.variable waiting; begin match Textvariable.get waiting with "1" -> true | _ -> false end (* * Simple list requester * Same remarks as in open_simple. * focus seems to be in the listbox automatically *) let open_list title elements action notaction = let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in Wm.title_set t title; let tit = Label.create t [Text title] in let fls = Frame.create t [Relief Sunken; BorderWidth (Pixels 2)] in let lb = Listbox.create fls [SelectMode Extended] in let sb = Scrollbar.create fls [] in Frx_listbox.scroll_link sb lb; Listbox.insert lb End elements; (* activation: we have to break() because we destroy the requester *) let activate _ = let l = List.map (Listbox.get lb) (Listbox.curselection lb) in Grab.release t; destroy t; List.iter action l; break() in bind lb [[Double], ButtonPressDetail 1] (BindSetBreakable ([], activate)); Frx_listbox.add_completion lb activate; let f = Frame.create t [] in let bok = Button.create f [Text "Ok"; Command activate] in let bcancel = Button.create f [Text "Cancel"; Command (fun () -> notaction(); Grab.release t; destroy t)] in pack [bok; bcancel] [Side Side_Left; Fill Fill_X; Expand true]; pack [lb] [Side Side_Left; Fill Fill_Both; Expand true]; pack [sb] [Side Side_Right; Fill Fill_Y]; pack [tit] [Fill Fill_X]; pack [fls] [Fill Fill_Both; Expand true]; pack [f] [Side Side_Bottom; Fill Fill_X]; Frx_widget.resizeable t; Tkwait.visibility t; Grab.set t (* Synchronous *) let open_passwd title = let username = ref "" and password = ref "" and cancelled = ref false in let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in Focus.set t; Wm.title_set t title; let tit = Label.create t [Text title] and fu,eu = Frx_entry.new_label_entry t "Username" (fun s -> ()) and fp,ep = Frx_entry.new_label_entry t "Password" (fun s -> ()) in let fb = Frame.create t [] in let bok = Button.create fb [Text "Ok"; Command (fun _ -> username := Entry.get eu; password := Entry.get ep; Grab.release t; (* because of wm *) destroy t)] (* will return from tkwait *) and bcancel = Button.create fb [Text "Cancel"; Command (fun _ -> cancelled := true; Grab.release t; (* because of wm *) destroy t)] (* will return from tkwait *) in Entry.configure ep [Show '*']; bind eu [[], KeyPressDetail "Return"] (BindSetBreakable ([], (fun _ -> Focus.set ep; break()))); bind ep [[], KeyPressDetail "Return"] (BindSetBreakable ([], (fun _ -> Button.flash bok; Button.invoke bok; break()))); pack [bok] [Side Side_Left; Expand true]; pack [bcancel] [Side Side_Right; Expand true]; pack [tit;fu;fp;fb] [Fill Fill_X]; Tkwait.visibility t; Focus.set eu; Grab.set t; Tkwait.window t; if !cancelled then failwith "cancelled" else (!username, !password) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_rpc.ml0000644000175000017500000000404412124403241021520 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* Some notion of RPC *) open Camltk open Protocol (* A RPC is just a callback with a particular name, plus a Tcl procedure *) let register name f = let id = new_function_id() in Hashtbl.add callback_naming_table id f; (* For rpc_info *) Textvariable.set (Textvariable.coerce ("camltkrpc("^name^")")) (string_of_cbid id); tkCommand [| TkToken "proc"; TkToken name; TkToken "args"; TkToken ("camlcb "^(string_of_cbid id)^" $args") |] (* RPC *) let invoke interp f args = tkEval [| TkToken "send"; TkToken interp; TkToken f; TkTokenList (List.map (fun s -> TkToken s) args) |] let async_invoke interp f args = tkCommand [| TkToken "send"; TkToken "-async"; TkToken interp; TkToken f; TkTokenList (List.map (fun s -> TkToken s) args) |] let rpc_info interp = tkEval [| TkToken "send"; TkToken interp; TkToken "array"; TkToken "names"; TkToken "camltkrpc" |] mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_lbutton.ml0000644000175000017500000000402312124403241022420 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk open Widget let version = "$Id$" (* * Simulate a button with a bitmap AND a label *) let rec sort_options but lab com = function [] -> but,lab,com |(Command f as o)::l -> sort_options (o::but) lab com l |(Bitmap b as o)::l -> sort_options (o::but) lab com l |(Text t as o)::l -> sort_options but (o::lab) com l |o::l -> sort_options but lab (o::com) l let create parent options = let but,lab,com = sort_options [] [] [] options in let f = Frame.create parent com in let b = Button.create f (but@com) and l = Label.create f (lab@com) in pack [b;l][]; bind l [[],ButtonPressDetail 1] (BindSet ([],(function _ -> Button.invoke b))); f let configure f options = let but,lab,com = sort_options [] [] [] options in match Pack.slaves f with [b;l] -> Frame.configure f com; Button.configure b (but@com); Label.configure l (lab@com) | _ -> raise (Invalid_argument "lbutton configure") mingw-ocaml/ocaml/otherlibs/labltk/frx/frxlib.mllib0000644000175000017500000000026312124403241022031 0ustar tootstootsFrx_misc Frx_widget Frx_font Frx_entry Frx_text Frx_listbox Frx_req Frx_fillbox Frx_focus Frx_dialog Frx_mem Frx_rpc Frx_synth Frx_selection Frx_after Frx_fit Frx_ctext Frx_color mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_text.ml0000644000175000017500000002041112124403241021714 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk let version = "$Id$" (* * convert an integer to an absolute index *) let abs_index n = TextIndex (LineChar(0,0), [CharOffset n]) let insertMark = TextIndex(Mark "insert", []) let currentMark = TextIndex(Mark "current", []) let textEnd = TextIndex(End, []) let textBegin = TextIndex (LineChar(0,0), []) (* * Link a scrollbar and a text widget *) let scroll_link sb tx = Text.configure tx [YScrollCommand (Scrollbar.set sb)]; Scrollbar.configure sb [ScrollCommand (Text.yview tx)] (* * Tk 4.0 has navigation in Text widgets, sometimes using scrolling * sometimes using the insertion mark. It is a pain to add more * compatible bindings. We do our own. *) let page_up tx = Text.yview tx (ScrollPage (-1)) and page_down tx = Text.yview tx (ScrollPage 1) and line_up tx = Text.yview tx (ScrollUnit (-1)) and line_down tx = Text.yview tx (ScrollUnit 1) and top tx = Text.yview_index tx textBegin and bottom tx = Text.yview_index tx textEnd let navigation_keys tx = let tags = bindtags_get tx in match tags with (WidgetBindings t)::l when t = tx -> bindtags tx ((WidgetBindings tx) :: (TagBindings "TEXT_RO") :: l) | _ -> () let new_scrollable_text top options navigation = let f = Frame.create top [] in let tx = Text.create f options and sb = Scrollbar.create f [] in scroll_link sb tx; (* IN THIS ORDER -- RESIZING *) pack [sb] [Side Side_Right; Fill Fill_Y]; pack [tx] [Side Side_Left; Fill Fill_Both; Expand true]; if navigation then navigation_keys tx; f, tx (* * Searching *) let patternv = Frx_misc.autodef Textvariable.create and casev = Frx_misc.autodef Textvariable.create let topsearch t = (* The user interface *) let top = Toplevel.create t [Class "TextSearch"] in Wm.title_set top "Text search"; let f = Frame.create_named top "fpattern" [] in let m = Label.create_named f "search" [Text "Search pattern"] and e = Entry.create_named f "pattern" [Relief Sunken; TextVariable (patternv()) ] in let hgroup = Frame.create top [] and bgroup = Frame.create top [] in let fdir = Frame.create hgroup [] and fmisc = Frame.create hgroup [] in let direction = Textvariable.create_temporary fdir and exactv = Textvariable.create_temporary fdir in let forw = Radiobutton.create_named fdir "forward" [Text "Forward"; Variable direction; Value "f"] and backw = Radiobutton.create_named fdir "backward" [Text "Backward"; Variable direction; Value "b"] and exact = Checkbutton.create_named fmisc "exact" [Text "Exact match"; Variable exactv] and case = Checkbutton.create_named fmisc "case" [Text "Fold Case"; Variable (casev())] and searchb = Button.create_named bgroup "search" [Text "Search"] and contb = Button.create_named bgroup "continue" [Text "Continue"] and dismissb = Button.create_named bgroup "dismiss" [Text "Dismiss"; Command (fun () -> Text.tag_delete t ["search"]; destroy top)] in Radiobutton.invoke forw; pack [m][Side Side_Left]; pack [e][Side Side_Right; Fill Fill_X; Expand true]; pack [forw; backw] [Anchor W]; pack [exact; case] [Anchor W]; pack [fdir; fmisc] [Side Side_Left; Anchor Center]; pack [searchb; contb; dismissb] [Side Side_Left; Fill Fill_X]; pack [f;hgroup;bgroup] [Fill Fill_X; Expand true]; let current_index = ref textBegin in let search cont = fun () -> let opts = ref [] in if Textvariable.get direction = "f" then opts := Forwards :: !opts else opts := Backwards :: !opts ; if Textvariable.get exactv = "1" then opts := Exact :: !opts; if Textvariable.get (casev()) = "1" then opts := Nocase :: !opts; try let forward = Textvariable.get direction = "f" in let i = Text.search t !opts (Entry.get e) (if cont then !current_index else if forward then textBegin else TextIndex(End, [CharOffset (-1)])) (* does not work with end *) (if forward then textEnd else textBegin) in let found = TextIndex (i, []) in current_index := TextIndex(i, [CharOffset (if forward then 1 else (-1))]); Text.tag_delete t ["search"]; Text.tag_add t "search" found (TextIndex (i, [WordEnd])); Text.tag_configure t "search" [Relief Raised; BorderWidth (Pixels 1); Background Red]; Text.see t found with Invalid_argument _ -> Bell.ring() in bind e [[], KeyPressDetail "Return"] (BindSet ([], fun _ -> search false ())); Button.configure searchb [Command (search false)]; Button.configure contb [Command (search true)]; Tkwait.visibility top; Focus.set e let addsearch tx = let tags = bindtags_get tx in match tags with (WidgetBindings t)::l when t = tx -> bindtags tx ((WidgetBindings tx) :: (TagBindings "SEARCH") :: l) | _ -> () (* We use Mod1 instead of Meta or Alt *) let init () = List.iter (function ev -> tag_bind "TEXT_RO" ev (BindSetBreakable ([Ev_Widget], (fun ei -> page_up ei.ev_Widget; break())))) [ [[], KeyPressDetail "BackSpace"]; [[], KeyPressDetail "Delete"]; [[], KeyPressDetail "Prior"]; [[], KeyPressDetail "b"]; [[Mod1], KeyPressDetail "v"] ]; List.iter (function ev -> tag_bind "TEXT_RO" ev (BindSetBreakable ([Ev_Widget], (fun ei -> page_down ei.ev_Widget; break())))) [ [[], KeyPressDetail "space"]; [[], KeyPressDetail "Next"]; [[Control], KeyPressDetail "v"] ]; List.iter (function ev -> tag_bind "TEXT_RO" ev (BindSetBreakable ([Ev_Widget], (fun ei -> line_up ei.ev_Widget; break())))) [ [[], KeyPressDetail "Up"]; [[Mod1], KeyPressDetail "z"] ]; List.iter (function ev -> tag_bind "TEXT_RO" ev (BindSetBreakable ([Ev_Widget], (fun ei -> line_down ei.ev_Widget; break())))) [ [[], KeyPressDetail "Down"]; [[Control], KeyPressDetail "z"] ]; List.iter (function ev -> tag_bind "TEXT_RO" ev (BindSetBreakable ([Ev_Widget], (fun ei -> top ei.ev_Widget; break())))) [ [[], KeyPressDetail "Home"]; [[Mod1], KeyPressDetail "less"] ]; List.iter (function ev -> tag_bind "TEXT_RO" ev (BindSetBreakable ([Ev_Widget], (fun ei -> bottom ei.ev_Widget; break())))) [ [[], KeyPressDetail "End"]; [[Mod1], KeyPressDetail "greater"] ]; List.iter (function ev -> tag_bind "SEARCH" ev (BindSetBreakable ([Ev_Widget], (fun ei -> topsearch ei.ev_Widget; break())))) [ [[Control], KeyPressDetail "s"] ] mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_focus.ml0000644000175000017500000000257612124403241022063 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk (* Temporary focus *) (* ? use bind tag ? how about the global reference then *) let auto w = let old_focus = ref w in bind w [[],Enter] (BindSet([], fun _ -> old_focus := Focus.get (); Focus.set w)); bind w [[],Leave] (BindSet([], fun _ -> Focus.set !old_focus)) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_font.mli0000644000175000017500000000245612124403241022060 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) val find : string -> string -> string -> int -> string (* [find family weight slant pxlsz] returns the X11 full name of the font required font, if available. Raises Invalid_argument fullname otherwise. *) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_ctext.mli0000644000175000017500000000256012124403241022235 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk val create : Widget.widget -> Camltk.options list -> bool -> Widget.widget * Widget.widget (* [create parent opts nav_keys] creates a text widget with "pixel scrolling". Based on a trick learned from Steve Ball. Returns (frame widget, text widget). *) mingw-ocaml/ocaml/otherlibs/labltk/frx/.depend0000644000175000017500000000245612124403241020770 0ustar tootstootsfrx_after.cmo: frx_after.cmi frx_after.cmx: frx_after.cmi frx_color.cmo: frx_color.cmi frx_color.cmx: frx_color.cmi frx_ctext.cmo: frx_fit.cmi frx_text.cmi frx_ctext.cmi frx_ctext.cmx: frx_fit.cmx frx_text.cmx frx_ctext.cmi frx_dialog.cmo: frx_dialog.cmi frx_dialog.cmx: frx_dialog.cmi frx_entry.cmo: frx_entry.cmi frx_entry.cmx: frx_entry.cmi frx_fillbox.cmo: frx_fillbox.cmi frx_fillbox.cmx: frx_fillbox.cmi frx_fit.cmo: frx_after.cmi frx_fit.cmi frx_fit.cmx: frx_after.cmx frx_fit.cmi frx_focus.cmo: frx_focus.cmi frx_focus.cmx: frx_focus.cmi frx_font.cmo: frx_misc.cmi frx_font.cmi frx_font.cmx: frx_misc.cmx frx_font.cmi frx_lbutton.cmo: frx_lbutton.cmi frx_lbutton.cmx: frx_lbutton.cmi frx_listbox.cmo: frx_listbox.cmi frx_listbox.cmx: frx_listbox.cmi frx_mem.cmo: frx_mem.cmi frx_mem.cmx: frx_mem.cmi frx_misc.cmo: frx_misc.cmi frx_misc.cmx: frx_misc.cmi frx_req.cmo: frx_entry.cmi frx_listbox.cmi frx_widget.cmi frx_req.cmi frx_req.cmx: frx_entry.cmx frx_listbox.cmx frx_widget.cmx frx_req.cmi frx_rpc.cmo: frx_rpc.cmi frx_rpc.cmx: frx_rpc.cmi frx_selection.cmo: frx_selection.cmi frx_selection.cmx: frx_selection.cmi frx_synth.cmo: frx_synth.cmi frx_synth.cmx: frx_synth.cmi frx_text.cmo: frx_misc.cmi frx_text.cmi frx_text.cmx: frx_misc.cmx frx_text.cmi frx_widget.cmo: frx_widget.cmi frx_widget.cmx: frx_widget.cmi mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_dialog.mli0000644000175000017500000000253712124403241022351 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk val f : Widget.widget -> string -> string -> string -> Camltk.bitmap -> int -> string list -> int (* same as Dialog.create_named, but with a local variable for synchronisation. Makes it possible to have several dialogs simultaneously *) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_dialog.ml0000644000175000017500000001035512124403241022175 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk open Protocol let rec mapi f n l = match l with [] -> [] | x::l -> let v = f n x in v::(mapi f (succ n) l) (* Same as tk_dialog, but not sharing the tkwait variable *) (* w IS the parent widget *) let f w name title mesg bitmap def buttons = let t = Toplevel.create_named w name [Class "Dialog"] in Wm.title_set t title; Wm.iconname_set t "Dialog"; Wm.protocol_set t "WM_DELETE_WINDOW" (function () -> ()); (* Wm.transient_set t (Winfo.toplevel w); *) let ftop = Frame.create_named t "top" [Relief Raised; BorderWidth (Pixels 1)] and fbot = Frame.create_named t "bot" [Relief Raised; BorderWidth (Pixels 1)] in pack [ftop][Side Side_Top; Fill Fill_Both]; pack [fbot][Side Side_Bottom; Fill Fill_Both]; let l = Label.create_named ftop "msg" [Justify Justify_Left; Text mesg; WrapLength (Pixels 600)] in pack [l][Side Side_Right; Expand true; Fill Fill_Both; PadX (Millimeters 3.0); PadY (Millimeters 3.0)]; begin match bitmap with Predefined "" -> () | _ -> let b = Label.create_named ftop "bitmap" [Bitmap bitmap] in pack [b][Side Side_Left; PadX (Millimeters 3.0); PadY (Millimeters 3.0)] end; let waitv = Textvariable.create_temporary t in let buttons = mapi (fun i bname -> let b = Button.create t [Text bname; Command (fun () -> Textvariable.set waitv (string_of_int i))] in if i = def then begin let f = Frame.create_named fbot "default" [Relief Sunken; BorderWidth (Pixels 1)] in raise_window_above b f; pack [f][Side Side_Left; Expand true; PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; pack [b][In f; PadX (Millimeters 2.0); PadY (Millimeters 2.0)]; bind t [[], KeyPressDetail "Return"] (BindSet ([], (fun _ -> Button.flash b; Button.invoke b))) end else pack [b][In fbot; Side Side_Left; Expand true; PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; b ) 0 buttons in Wm.withdraw t; update_idletasks(); let x = (Winfo.screenwidth t)/2 - (Winfo.reqwidth t)/2 - (Winfo.vrootx (Winfo.parent t)) and y = (Winfo.screenheight t)/2 - (Winfo.reqheight t)/2 - (Winfo.vrooty (Winfo.parent t)) in Wm.geometry_set t (Printf.sprintf "+%d+%d" x y); Wm.deiconify t; let oldfocus = try Some (Focus.get()) with _ -> None and oldgrab = Grab.current ~displayof: t () and grabstatus = ref None in begin match oldgrab with [] -> () | x::l -> grabstatus := Some(Grab.status x) end; (* avoid errors here because it makes the entire app useless *) (try Grab.set t with TkError _ -> ()); Tkwait.visibility t; Focus.set (if def >= 0 then List.nth buttons def else t); Tkwait.variable waitv; begin match oldfocus with None -> () | Some w -> try Focus.set w with _ -> () end; destroy t; begin match oldgrab with [] -> () | x::l -> try match !grabstatus with Some(GrabGlobal) -> Grab.set_global x | _ -> Grab.set x with TkError _ -> () end; int_of_string (Textvariable.get waitv) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_focus.mli0000644000175000017500000000221212124403241022217 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk val auto : Widget.widget -> unit (* *) mingw-ocaml/ocaml/otherlibs/labltk/frx/frx_fileinput.ml0000644000175000017500000000271312124403241022734 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Camltk let version = "$Id$" (* * Simple spooling for fileinput callbacks *) let waiting_list = Queue. new() and waiting = ref 0 and max_open = ref 10 and cur_open = ref 0 let add fd f = if !cur_open < !max_open then begin incr cur_open; add_fileinput fd f end else begin incr waiting; Queue.add (fd,f) waiting_list end let remove fd = mingw-ocaml/ocaml/otherlibs/labltk/Makefile0000644000175000017500000000532412124403241020366 0ustar tootstoots####################################################################### # # # MLTk, Tcl/Tk interface of OCaml # # # # Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # # projet Cristal, INRIA Rocquencourt # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique and Kyoto University. All rights reserved. # # This file is distributed under the terms of the GNU Library # # General Public License, with the special exception on linking # # described in file LICENSE found in the OCaml source tree. # # # ####################################################################### # Top Makefile for mlTk SUBDIRS=compiler support lib jpf frx examples_labltk \ examples_camltk browser SUBDIRS_GENERATED=camltk labltk all: cd support; $(MAKE) cd compiler; $(MAKE) cd labltk; $(MAKE) -f Makefile.gen cd labltk; $(MAKE) cd camltk; $(MAKE) -f Makefile.gen cd camltk; $(MAKE) cd lib; $(MAKE) cd jpf; $(MAKE) cd frx; $(MAKE) cd browser; $(MAKE) allopt: cd support; $(MAKE) opt cd labltk; $(MAKE) -f Makefile.gen cd labltk; $(MAKE) opt cd camltk; $(MAKE) -f Makefile.gen cd camltk; $(MAKE) opt cd lib; $(MAKE) opt cd jpf; $(MAKE) opt cd frx; $(MAKE) opt byte: all opt: allopt .PHONY: all allopt byte opt .PHONY: labltk camltk examples examples_labltk examples_camltk .PHONY: install installopt partialclean clean depend labltk: Widgets.src compiler/tkcompiler -outdir labltk cd labltk; $(MAKE) camltk: Widgets.src compiler/tkcompiler -camltk -outdir camltk cd camltk; $(MAKE) examples: examples_labltk examples_camltk examples_labltk: cd examples_labltk; $(MAKE) all examples_camltk: cd examples_camltk; $(MAKE) all install: cd support; $(MAKE) install cd lib; $(MAKE) install cd labltk; $(MAKE) install cd camltk; $(MAKE) install cd compiler; $(MAKE) install cd jpf; $(MAKE) install cd frx; $(MAKE) install cd browser; $(MAKE) install installopt: cd support; $(MAKE) installopt cd lib; $(MAKE) installopt cd labltk; $(MAKE) installopt cd camltk; $(MAKE) installopt cd jpf; $(MAKE) installopt cd frx; $(MAKE) installopt partialclean clean: for d in $(SUBDIRS); do \ cd $$d; $(MAKE) -f Makefile clean; cd ..; \ done for d in $(SUBDIRS_GENERATED); do \ cd $$d; $(MAKE) -f Makefile.gen clean; cd ..; \ done depend: mingw-ocaml/ocaml/otherlibs/labltk/builtin/0000755000175000017500000000000012124403241020370 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/builtin/selection_handle_set.ml0000644000175000017500000000203312124403241025073 0ustar tootstoots##ifdef CAMLTK (* The function *must* use tkreturn *) let handle_set opts w cmd = tkCommand [| TkToken"selection"; TkToken"handle"; TkTokenList (List.map (function x -> cCAMLtoTKicccm w icccm_selection_handle_table x) opts); cCAMLtoTKwidget widget_any_table w; let id = register_callback w (function args -> let (a1,args) = int_of_string (List.hd args), List.tl args in let (a2,args) = int_of_string (List.hd args), List.tl args in cmd a1 a2) in TkToken ("camlcb "^id) |] ;; ##else (* The function *must* use tkreturn *) let handle_set ~command = selection_handle_icccm_optionals (fun opts w -> tkCommand [| TkToken"selection"; TkToken"handle"; TkTokenList opts; cCAMLtoTKwidget w; let id = register_callback w ~callback: begin fun args -> let pos = int_of_string (List.hd args) in let len = int_of_string (List.nth args 1) in tkreturn (command ~pos ~len) end in TkToken ("camlcb " ^ id) |]) ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtina_empty.ml0000644000175000017500000000000012124403241023735 0ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/builtin/builtini_grab.ml0000644000175000017500000000011612124403241023532 0ustar tootstootslet cCAMLtoTKgrabGlobal x = if x then TkToken "-global" else TkTokenList [] mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtini_font.ml0000644000175000017500000000011212124403241023561 0ustar tootstootslet cCAMLtoTKfont (s : font) = TkToken s let cTKtoCAMLfont (s : font) = s mingw-ocaml/ocaml/otherlibs/labltk/builtin/LICENSE0000644000175000017500000000231412124403241021375 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) All the files in this directory are subject to the above copyright notice. mingw-ocaml/ocaml/otherlibs/labltk/builtin/canvas_bind.ml0000644000175000017500000000321712124403241023174 0ustar tootstoots##ifdef CAMLTK let bind widget tag eventsequence action = tkCommand [| cCAMLtoTKwidget widget_canvas_table widget; TkToken "bind"; cCAMLtoTKtagOrId tag; cCAMLtoTKeventSequence eventsequence; begin match action with | BindRemove -> TkToken "" | BindSet (what, f) -> let cbId = register_callback widget (wrapeventInfo f what) in TkToken ("camlcb " ^ cbId ^ (writeeventField what)) | BindSetBreakable (what, f) -> let cbId = register_callback widget (wrapeventInfo f what) in TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \ set BreakBindingsSequence 0") | BindExtend (what, f) -> let cbId = register_callback widget (wrapeventInfo f what) in TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) end |] ;; ##else let bind ~events ?(extend = false) ?(breakable = false) ?(fields = []) ?action widget tag = tkCommand [| cCAMLtoTKwidget widget; TkToken "bind"; cCAMLtoTKtagOrId tag; cCAMLtoTKeventSequence events; begin match action with None -> TkToken "" | Some f -> let cbId = register_callback widget ~callback: (wrapeventInfo f fields) in let cb = if extend then "+camlcb " else "camlcb " in let cb = cb ^ cbId ^ writeeventField fields in let cb = if breakable then cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" ^ " ; set BreakBindingsSequence 0" else cb in TkToken cb end |] ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/image.ml0000644000175000017500000000144312124403241022006 0ustar tootstoots##ifdef CAMLTK let cTKtoCAMLimage s = let res = tkEval [|TkToken "image"; TkToken "type"; TkToken s|] in match res with | "bitmap" -> ImageBitmap (BitmapImage s) | "photo" -> ImagePhoto (PhotoImage s) | _ -> raise (TkError ("unknown image type \"" ^ res ^ "\"")) ;; let names () = let res = tkEval [|TkToken "image"; TkToken "names"|] in let names = splitlist res in List.map cTKtoCAMLimage names ;; ##else let cTKtoCAMLimage s = let res = tkEval [|TkToken "image"; TkToken "type"; TkToken s|] in match res with | "bitmap" -> `Bitmap s | "photo" -> `Photo s | _ -> raise (TkError ("unknown image type \"" ^ res ^ "\"")) ;; let names () = let res = tkEval [|TkToken "image"; TkToken "names"|] in let names = splitlist res in List.map cTKtoCAMLimage names ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtin_text.ml0000644000175000017500000000222312124403241023433 0ustar tootstoots(* Not a string as such, more like a symbol *) (* type *) type textMark = string;; (* /type *) (* type *) type textTag = string;; (* /type *) ##ifdef CAMLTK (* type *) type textModifier = | CharOffset of int (* tk keyword: +/- Xchars *) | LineOffset of int (* tk keyword: +/- Xlines *) | LineStart (* tk keyword: linestart *) | LineEnd (* tk keyword: lineend *) | WordStart (* tk keyword: wordstart *) | WordEnd (* tk keyword: wordend *) ;; (* /type *) (* type *) type textIndex = | TextIndex of index * textModifier list | TextIndexNone ;; (* /type *) ##else (* type *) type textModifier = [ | `Char of int (* tk keyword: +/- Xchars *) | `Line of int (* tk keyword: +/- Xlines *) | `Linestart (* tk keyword: linestart *) | `Lineend (* tk keyword: lineend *) | `Wordstart (* tk keyword: wordstart *) | `Wordend (* tk keyword: wordend *) ] ;; (* /type *) (* type *) type textIndex = text_index * textModifier list ;; (* /type *) ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/text_tag_bind.mli0000644000175000017500000000045412124403241023711 0ustar tootstoots##ifdef CAMLTK val tag_bind: widget -> textTag -> (modifier list * xEvent) list -> bindAction -> unit ##else val tag_bind : tag: string -> events: event list -> ?extend: bool -> ?breakable: bool -> ?fields: eventField list -> ?action: (eventInfo -> unit) -> text widget -> unit ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/winfo_contained.ml0000644000175000017500000000022112124403241024063 0ustar tootstoots##ifdef CAMLTK let contained x y w = w = containing x y ;; ##else let contained ~x ~y w = forget_type w = containing ~x ~y () ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/dialog.mli0000644000175000017500000000123612124403241022334 0ustar tootstoots##ifdef CAMLTK val create : ?name: string -> widget -> string -> string -> bitmap -> int -> string list -> int (* [create ~name parent title message bitmap default button_names] cf. tk_dialog *) val create_named : widget -> string -> string -> string -> bitmap -> int -> string list -> int (* [create_named parent name title message bitmap default button_names] cf. tk_dialog *) ##else val create : parent: 'a widget -> title: string -> message: string -> buttons: string list -> ?name: string -> ?bitmap: bitmap -> ?default: int -> unit ->int (* [create title message bitmap default button_names parent] cf. tk_dialog *) ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtini_text.ml0000644000175000017500000000325412124403241023611 0ustar tootstootslet cCAMLtoTKtextMark x = TkToken x;; let cTKtoCAMLtextMark x = x;; let cCAMLtoTKtextTag x = TkToken x;; let cTKtoCAMLtextTag x = x;; ##ifdef CAMLTK (* TextModifiers are never returned by Tk *) let ppTextModifier = function CharOffset n -> if n > 0 then "+" ^ (string_of_int n) ^ "chars" else if n = 0 then "" else (string_of_int n) ^ "chars" | LineOffset n -> if n > 0 then "+" ^ (string_of_int n) ^ "lines" else if n = 0 then "" else (string_of_int n) ^ "lines" | LineStart -> " linestart" | LineEnd -> " lineend" | WordStart -> " wordstart" | WordEnd -> " wordend" ;; let ppTextIndex = function | TextIndexNone -> "" | TextIndex (base, ml) -> match cCAMLtoTKindex index_text_table base with | TkToken ppbase -> List.fold_left (^) ppbase (List.map ppTextModifier ml) | _ -> assert false ;; let cCAMLtoTKtextIndex i = TkToken (ppTextIndex i) ;; ##else (* TextModifiers are never returned by Tk *) let cCAMLtoTKtextIndex (i : textIndex) = let ppTextModifier = function | `Char n -> if n > 0 then "+" ^ (string_of_int n) ^ "chars" else if n = 0 then "" else (string_of_int n) ^ "chars" | `Line n -> if n > 0 then "+" ^ (string_of_int n) ^ "lines" else if n = 0 then "" else (string_of_int n) ^ "lines" | `Linestart -> " linestart" | `Lineend -> " lineend" | `Wordstart -> " wordstart" | `Wordend -> " wordend" in let ppTextIndex (base, ml : textIndex) = match cCAMLtoTKtext_index base with TkToken ppbase -> String.concat ~sep:"" (ppbase :: List.map ~f:ppTextModifier ml) | _ -> assert false in TkToken (ppTextIndex i) ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtin_ScrollValue.ml0000644000175000017500000000077212124403241024711 0ustar tootstoots##ifdef CAMLTK (* type *) type scrollValue = | ScrollPage of int (* tk option: scroll page *) | ScrollUnit of int (* tk option: scroll unit *) | MoveTo of float (* tk option: moveto *) ;; (* /type *) ##else (* type *) type scrollValue = [ | `Page of int (* tk option: scroll page *) | `Unit of int (* tk option: scroll unit *) | `Moveto of float (* tk option: moveto *) ] ;; (* /type *) ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtin_index.ml0000644000175000017500000000332512124403241023562 0ustar tootstoots(* Various indexes canvas entry listbox *) ##ifdef CAMLTK (* A large type for all indices in all widgets *) (* a bit overkill though *) (* type *) type index = | Number of int (* no keyword *) | ActiveElement (* tk keyword: active *) | End (* tk keyword: end *) | Last (* tk keyword: last *) | NoIndex (* tk keyword: none *) | Insert (* tk keyword: insert *) | SelFirst (* tk keyword: sel.first *) | SelLast (* tk keyword: sel.last *) | At of int (* tk keyword: @n *) | AtXY of int * int (* tk keyword: @x,y *) | AnchorPoint (* tk keyword: anchor *) | Pattern of string (* no keyword *) | LineChar of int * int (* tk keyword: l.c *) | Mark of string (* no keyword *) | TagFirst of string (* tk keyword: tag.first *) | TagLast of string (* tk keyword: tag.last *) | Embedded of widget (* no keyword *) ;; (* /type *) ##else type canvas_index = [ | `Num of int | `End | `Insert | `Selfirst | `Sellast | `Atxy of int * int ] ;; type entry_index = [ | `Num of int | `End | `Insert | `Selfirst | `Sellast | `At of int | `Anchor ] ;; type listbox_index = [ | `Num of int | `Active | `Anchor | `End | `Atxy of int * int ] ;; type menu_index = [ | `Num of int | `Active | `End | `Last | `None | `At of int | `Pattern of string ] ;; type text_index = [ | `Linechar of int * int | `Atxy of int * int | `End | `Mark of string | `Tagfirst of string | `Taglast of string | `Window of any widget | `Image of string ] ;; type linechar_index = int * int;; type num_index = int;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtini_GetCursor.ml0000644000175000017500000000307712124403241024545 0ustar tootstoots##ifdef CAMLTK let cCAMLtoTKcolor = function NamedColor x -> TkToken x | Black -> TkToken "black" | White -> TkToken "white" | Red -> TkToken "red" | Green -> TkToken "green" | Blue -> TkToken "blue" | Yellow -> TkToken "yellow" ;; let cTKtoCAMLcolor = function s -> NamedColor s ;; let cCAMLtoTKcursor = function XCursor s -> TkToken s | XCursorFg (s,fg) -> TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg]) | XCursortFgBg (s,fg,bg) -> TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) | CursorFileFg (s,fg) -> TkQuote(TkTokenList [TkToken ("@"^s); cCAMLtoTKcolor fg]) | CursorMaskFile (s,m,fg,bg) -> TkQuote(TkTokenList [TkToken ("@"^s); TkToken m; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) ;; ##else let cCAMLtoTKcolor : color -> tkArgs = function | `Color x -> TkToken x | `Black -> TkToken "black" | `White -> TkToken "white" | `Red -> TkToken "red" | `Green -> TkToken "green" | `Blue -> TkToken "blue" | `Yellow -> TkToken "yellow" ;; let cTKtoCAMLcolor = function s -> `Color s ;; let cCAMLtoTKcursor : cursor -> tkArgs = function | `Xcursor s -> TkToken s | `Xcursorfg (s,fg) -> TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg]) | `Xcursorfgbg (s,fg,bg) -> TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) | `Cursorfilefg (s,fg) -> TkQuote(TkTokenList [TkToken ("@"^s); cCAMLtoTKcolor fg]) | `Cursormaskfile (s,m,fg,bg) -> TkQuote(TkTokenList [TkToken ("@"^s); TkToken m; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtin_FilePattern.ml0000644000175000017500000000105012124403241024661 0ustar tootstoots(* File patterns *) (* type *) type filePattern = { typename : string; extensions : string list; mactypes : string list } (* /type *) let cCAMLtoTKfilePattern fp = let typename = TkQuote (TkToken fp.typename) in let extensions = TkQuote (TkTokenList (List.map (fun x -> TkToken x) fp.extensions)) in let mactypes = match fp.mactypes with | [] -> [] | [s] -> [TkToken s] | _ -> [TkQuote (TkTokenList (List.map (fun x -> TkToken x) fp.mactypes))] in TkQuote (TkTokenList (typename :: extensions :: mactypes)) mingw-ocaml/ocaml/otherlibs/labltk/builtin/dialog.ml0000644000175000017500000000277112124403241022170 0ustar tootstoots##ifdef CAMLTK let create ?name parent title mesg bitmap def buttons = let w = Widget.new_atom "toplevel" ~parent ?name in let res = tkEval [|TkToken"tk_dialog"; cCAMLtoTKwidget widget_any_table w; TkToken title; TkToken mesg; cCAMLtoTKbitmap bitmap; TkToken (string_of_int def); TkTokenList (List.map (function x -> TkToken x) buttons)|] in int_of_string res ;; let create_named parent name title mesg bitmap def buttons = let w = Widget.new_atom "toplevel" ~parent ~name in let res = tkEval [|TkToken"tk_dialog"; cCAMLtoTKwidget widget_any_table w; TkToken title; TkToken mesg; cCAMLtoTKbitmap bitmap; TkToken (string_of_int def); TkTokenList (List.map (function x -> TkToken x) buttons)|] in int_of_string res ;; ##else let create ~parent ~title ~message ~buttons ?name ?(bitmap = `Predefined "") ?(default = -1) () = let w = Widget.new_atom "toplevel" ?name ~parent in let res = tkEval [|TkToken"tk_dialog"; cCAMLtoTKwidget w; TkToken title; TkToken message; cCAMLtoTKbitmap bitmap; TkToken (string_of_int default); TkTokenList (List.map ~f:(fun x -> TkToken x) buttons)|] in int_of_string res ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/selection_own_set.ml0000644000175000017500000000111712124403241024445 0ustar tootstoots##ifdef CAMLTK (* builtin to handle callback association to widget *) let own_set v1 v2 = tkCommand [| TkToken"selection"; TkToken"own"; TkTokenList (List.map (function x -> cCAMLtoTKicccm v2 icccm_selection_ownset_table x) v1); cCAMLtoTKwidget widget_any_table v2 |] ;; ##else (* builtin to handle callback association to widget *) let own_set ?command = selection_ownset_icccm_optionals ?command (fun opts w -> tkCommand [| TkToken"selection"; TkToken"own"; TkTokenList opts; cCAMLtoTKwidget w |]) ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/selection_own_set.mli0000644000175000017500000000042312124403241024615 0ustar tootstoots##ifdef CAMLTK val own_set : icccm list -> widget -> unit (** tk invocation: selection own *) ##else val own_set : ?command:(unit->unit) -> ?selection:string -> 'a widget -> unit (** tk invocation: selection own *) ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/image.mli0000644000175000017500000000014212124403241022152 0ustar tootstoots##ifdef CAMLTK val names : unit -> options list ##else val names : unit -> image list ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtinf_GetPixel.ml0000644000175000017500000000064112124403241024340 0ustar tootstoots##ifdef CAMLTK let pixels units = let res = tkEval [|TkToken"winfo"; TkToken"pixels"; cCAMLtoTKwidget widget_any_table default_toplevel; cCAMLtoTKunits units|] in int_of_string res ##else let pixels units = let res = tkEval [|TkToken"winfo"; TkToken"pixels"; cCAMLtoTKwidget default_toplevel; cCAMLtoTKunits units|] in int_of_string res ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtin_bind.ml0000644000175000017500000003011412124403241023363 0ustar tootstoots##ifdef CAMLTK open Widget;; (* Events and bindings *) (* Builtin types *) (* type *) type xEvent = | Activate | ButtonPress (* also Button, but we omit it *) | ButtonPressDetail of int | ButtonRelease | ButtonReleaseDetail of int | Circulate | ColorMap (* not Colormap, avoiding confusion between the Colormap option *) | Configure | Deactivate | Destroy | Enter | Expose | FocusIn | FocusOut | Gravity | KeyPress (* also Key, but we omit it *) | KeyPressDetail of string (* /usr/include/X11/keysymdef.h *) | KeyRelease | KeyReleaseDetail of string | Leave | Map | Motion | Property | Reparent | Unmap | Visibility | Virtual of string (* Virtual event. Must be without modifiers *) ;; (* /type *) (* type *) type modifier = | Control | Shift | Lock | Button1 | Button2 | Button3 | Button4 | Button5 | Double | Triple | Mod1 | Mod2 | Mod3 | Mod4 | Mod5 | Meta | Alt ;; (* /type *) (* Event structure, passed to bounded functions *) (* type *) type eventInfo = { (* %# : event serial number is unsupported *) mutable ev_Above : int; (* tk: %a *) mutable ev_ButtonNumber : int; (* tk: %b *) mutable ev_Count : int; (* tk: %c *) mutable ev_Detail : string; (* tk: %d *) mutable ev_Focus : bool; (* tk: %f *) mutable ev_Height : int; (* tk: %h *) mutable ev_KeyCode : int; (* tk: %k *) mutable ev_Mode : string; (* tk: %m *) mutable ev_OverrideRedirect : bool; (* tk: %o *) mutable ev_Place : string; (* tk: %p *) mutable ev_State : string; (* tk: %s *) mutable ev_Time : int; (* tk: %t *) mutable ev_Width : int; (* tk: %w *) mutable ev_MouseX : int; (* tk: %x *) mutable ev_MouseY : int; (* tk: %y *) mutable ev_Char : string; (* tk: %A *) mutable ev_BorderWidth : int; (* tk: %B *) mutable ev_SendEvent : bool; (* tk: %E *) mutable ev_KeySymString : string; (* tk: %K *) mutable ev_KeySymInt : int; (* tk: %N *) mutable ev_RootWindow : int; (* tk: %R *) mutable ev_SubWindow : int; (* tk: %S *) mutable ev_Type : int; (* tk: %T *) mutable ev_Widget : widget; (* tk: %W *) mutable ev_RootX : int; (* tk: %X *) mutable ev_RootY : int (* tk: %Y *) } ;; (* /type *) (* To avoid collision with other constructors (Width, State), use Ev_ prefix *) (* type *) type eventField = | Ev_Above | Ev_ButtonNumber | Ev_Count | Ev_Detail | Ev_Focus | Ev_Height | Ev_KeyCode | Ev_Mode | Ev_OverrideRedirect | Ev_Place | Ev_State | Ev_Time | Ev_Width | Ev_MouseX | Ev_MouseY | Ev_Char | Ev_BorderWidth | Ev_SendEvent | Ev_KeySymString | Ev_KeySymInt | Ev_RootWindow | Ev_SubWindow | Ev_Type | Ev_Widget | Ev_RootX | Ev_RootY ;; (* /type *) let filleventInfo ev v = function | Ev_Above -> ev.ev_Above <- int_of_string v | Ev_ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v | Ev_Count -> ev.ev_Count <- int_of_string v | Ev_Detail -> ev.ev_Detail <- v | Ev_Focus -> ev.ev_Focus <- v = "1" | Ev_Height -> ev.ev_Height <- int_of_string v | Ev_KeyCode -> ev.ev_KeyCode <- int_of_string v | Ev_Mode -> ev.ev_Mode <- v | Ev_OverrideRedirect -> ev.ev_OverrideRedirect <- v = "1" | Ev_Place -> ev.ev_Place <- v | Ev_State -> ev.ev_State <- v | Ev_Time -> ev.ev_Time <- int_of_string v | Ev_Width -> ev.ev_Width <- int_of_string v | Ev_MouseX -> ev.ev_MouseX <- int_of_string v | Ev_MouseY -> ev.ev_MouseY <- int_of_string v | Ev_Char -> ev.ev_Char <- v | Ev_BorderWidth -> ev.ev_BorderWidth <- int_of_string v | Ev_SendEvent -> ev.ev_SendEvent <- v = "1" | Ev_KeySymString -> ev.ev_KeySymString <- v | Ev_KeySymInt -> ev.ev_KeySymInt <- int_of_string v | Ev_RootWindow -> ev.ev_RootWindow <- int_of_string v | Ev_SubWindow -> ev.ev_SubWindow <- int_of_string v | Ev_Type -> ev.ev_Type <- int_of_string v | Ev_Widget -> ev.ev_Widget <- cTKtoCAMLwidget v | Ev_RootX -> ev.ev_RootX <- int_of_string v | Ev_RootY -> ev.ev_RootY <- int_of_string v ;; let wrapeventInfo f what = let ev = { ev_Above = 0; ev_ButtonNumber = 0; ev_Count = 0; ev_Detail = ""; ev_Focus = false; ev_Height = 0; ev_KeyCode = 0; ev_Mode = ""; ev_OverrideRedirect = false; ev_Place = ""; ev_State = ""; ev_Time = 0; ev_Width = 0; ev_MouseX = 0; ev_MouseY = 0; ev_Char = ""; ev_BorderWidth = 0; ev_SendEvent = false; ev_KeySymString = ""; ev_KeySymInt = 0; ev_RootWindow = 0; ev_SubWindow = 0; ev_Type = 0; ev_Widget = Widget.default_toplevel; ev_RootX = 0; ev_RootY = 0 } in function args -> let l = ref args in List.iter (function field -> match !l with [] -> () | v::rest -> filleventInfo ev v field; l:=rest) what; f ev ;; let rec writeeventField = function | [] -> "" | field::rest -> begin match field with | Ev_Above -> " %a" | Ev_ButtonNumber ->" %b" | Ev_Count -> " %c" | Ev_Detail -> " %d" | Ev_Focus -> " %f" | Ev_Height -> " %h" | Ev_KeyCode -> " %k" | Ev_Mode -> " %m" | Ev_OverrideRedirect -> " %o" | Ev_Place -> " %p" | Ev_State -> " %s" | Ev_Time -> " %t" | Ev_Width -> " %w" | Ev_MouseX -> " %x" | Ev_MouseY -> " %y" (* Quoting is done by Tk *) | Ev_Char -> " %A" | Ev_BorderWidth -> " %B" | Ev_SendEvent -> " %E" | Ev_KeySymString -> " %K" | Ev_KeySymInt -> " %N" | Ev_RootWindow ->" %R" | Ev_SubWindow -> " %S" | Ev_Type -> " %T" | Ev_Widget ->" %W" | Ev_RootX -> " %X" | Ev_RootY -> " %Y" end ^ writeeventField rest ;; ##else open Widget;; (* Events and bindings *) (* Builtin types *) (* type *) type event = [ | `Activate | `ButtonPress (* also Button, but we omit it *) | `ButtonPressDetail of int | `ButtonRelease | `ButtonReleaseDetail of int | `Circulate | `Colormap | `Configure | `Deactivate | `Destroy | `Enter | `Expose | `FocusIn | `FocusOut | `Gravity | `KeyPress (* also Key, but we omit it *) | `KeyPressDetail of string (* /usr/include/X11/keysymdef.h *) | `KeyRelease | `KeyReleaseDetail of string | `Leave | `Map | `Motion | `Property | `Reparent | `Unmap | `Visibility | `Virtual of string (* Virtual event. Must be without modifiers *) | `Modified of modifier list * event ] and modifier = [ | `Control | `Shift | `Lock | `Button1 | `Button2 | `Button3 | `Button4 | `Button5 | `Double | `Triple | `Mod1 | `Mod2 | `Mod3 | `Mod4 | `Mod5 | `Meta | `Alt ] ;; (* /type *) (* Event structure, passed to bounded functions *) (* type *) type eventInfo = { (* %# : event serial number is unsupported *) mutable ev_Above : int; (* tk: %a *) mutable ev_ButtonNumber : int; (* tk: %b *) mutable ev_Count : int; (* tk: %c *) mutable ev_Detail : string; (* tk: %d *) mutable ev_Focus : bool; (* tk: %f *) mutable ev_Height : int; (* tk: %h *) mutable ev_KeyCode : int; (* tk: %k *) mutable ev_Mode : string; (* tk: %m *) mutable ev_OverrideRedirect : bool; (* tk: %o *) mutable ev_Place : string; (* tk: %p *) mutable ev_State : string; (* tk: %s *) mutable ev_Time : int; (* tk: %t *) mutable ev_Width : int; (* tk: %w *) mutable ev_MouseX : int; (* tk: %x *) mutable ev_MouseY : int; (* tk: %y *) mutable ev_Char : string; (* tk: %A *) mutable ev_BorderWidth : int; (* tk: %B *) mutable ev_SendEvent : bool; (* tk: %E *) mutable ev_KeySymString : string; (* tk: %K *) mutable ev_KeySymInt : int; (* tk: %N *) mutable ev_RootWindow : int; (* tk: %R *) mutable ev_SubWindow : int; (* tk: %S *) mutable ev_Type : int; (* tk: %T *) mutable ev_Widget : any widget; (* tk: %W *) mutable ev_RootX : int; (* tk: %X *) mutable ev_RootY : int (* tk: %Y *) } ;; (* /type *) (* To avoid collision with other constructors (Width, State), use Ev_ prefix *) (* type *) type eventField = [ | `Above | `ButtonNumber | `Count | `Detail | `Focus | `Height | `KeyCode | `Mode | `OverrideRedirect | `Place | `State | `Time | `Width | `MouseX | `MouseY | `Char | `BorderWidth | `SendEvent | `KeySymString | `KeySymInt | `RootWindow | `SubWindow | `Type | `Widget | `RootX | `RootY ] ;; (* /type *) let filleventInfo ev v : eventField -> unit = function | `Above -> ev.ev_Above <- int_of_string v | `ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v | `Count -> ev.ev_Count <- int_of_string v | `Detail -> ev.ev_Detail <- v | `Focus -> ev.ev_Focus <- v = "1" | `Height -> ev.ev_Height <- int_of_string v | `KeyCode -> ev.ev_KeyCode <- int_of_string v | `Mode -> ev.ev_Mode <- v | `OverrideRedirect -> ev.ev_OverrideRedirect <- v = "1" | `Place -> ev.ev_Place <- v | `State -> ev.ev_State <- v | `Time -> ev.ev_Time <- int_of_string v | `Width -> ev.ev_Width <- int_of_string v | `MouseX -> ev.ev_MouseX <- int_of_string v | `MouseY -> ev.ev_MouseY <- int_of_string v | `Char -> ev.ev_Char <- v | `BorderWidth -> ev.ev_BorderWidth <- int_of_string v | `SendEvent -> ev.ev_SendEvent <- v = "1" | `KeySymString -> ev.ev_KeySymString <- v | `KeySymInt -> ev.ev_KeySymInt <- int_of_string v | `RootWindow -> ev.ev_RootWindow <- int_of_string v | `SubWindow -> ev.ev_SubWindow <- int_of_string v | `Type -> ev.ev_Type <- int_of_string v | `Widget -> ev.ev_Widget <- cTKtoCAMLwidget v | `RootX -> ev.ev_RootX <- int_of_string v | `RootY -> ev.ev_RootY <- int_of_string v ;; let wrapeventInfo f (what : eventField list) = let ev = { ev_Above = 0; ev_ButtonNumber = 0; ev_Count = 0; ev_Detail = ""; ev_Focus = false; ev_Height = 0; ev_KeyCode = 0; ev_Mode = ""; ev_OverrideRedirect = false; ev_Place = ""; ev_State = ""; ev_Time = 0; ev_Width = 0; ev_MouseX = 0; ev_MouseY = 0; ev_Char = ""; ev_BorderWidth = 0; ev_SendEvent = false; ev_KeySymString = ""; ev_KeySymInt = 0; ev_RootWindow = 0; ev_SubWindow = 0; ev_Type = 0; ev_Widget = forget_type default_toplevel; ev_RootX = 0; ev_RootY = 0 } in function args -> let l = ref args in List.iter what ~f: begin fun field -> match !l with | [] -> () | v :: rest -> filleventInfo ev v field; l := rest end; f ev ;; let rec writeeventField : eventField list -> string = function | [] -> "" | field :: rest -> begin match field with | `Above -> " %a" | `ButtonNumber ->" %b" | `Count -> " %c" | `Detail -> " %d" | `Focus -> " %f" | `Height -> " %h" | `KeyCode -> " %k" | `Mode -> " %m" | `OverrideRedirect -> " %o" | `Place -> " %p" | `State -> " %s" | `Time -> " %t" | `Width -> " %w" | `MouseX -> " %x" | `MouseY -> " %y" (* Quoting is done by Tk *) | `Char -> " %A" | `BorderWidth -> " %B" | `SendEvent -> " %E" | `KeySymString -> " %K" | `KeySymInt -> " %N" | `RootWindow ->" %R" | `SubWindow -> " %S" | `Type -> " %T" | `Widget -> " %W" | `RootX -> " %X" | `RootY -> " %Y" end ^ writeeventField rest ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtini_GetBitmap.ml0000644000175000017500000000104212124403241024472 0ustar tootstoots##ifdef CAMLTK let cCAMLtoTKbitmap = function BitmapFile s -> TkToken ("@" ^ s) | Predefined s -> TkToken s ;; let cTKtoCAMLbitmap s = if s = "" then Predefined "" else if String.get s 0 = '@' then BitmapFile (String.sub s 1 (String.length s - 1)) else Predefined s ;; ##else let cCAMLtoTKbitmap : bitmap -> tkArgs = function | `File s -> TkToken ("@" ^ s) | `Predefined s -> TkToken s ;; let cTKtoCAMLbitmap s = if String.get s 0 = '@' then `File (String.sub s ~pos:1 ~len:(String.length s - 1)) else `Predefined s ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtini_ScrollValue.ml0000644000175000017500000000256212124403241025061 0ustar tootstoots##ifdef CAMLTK let cCAMLtoTKscrollValue = function ScrollPage v1 -> TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"pages"] | ScrollUnit v1 -> TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"units"] | MoveTo v1 -> TkTokenList [TkToken"moveto"; TkToken (Printf.sprintf "%g" v1)] ;; (* str l -> scrllv -> str l *) let cTKtoCAMLscrollValue = function "scroll"::n::("pages"|"page")::l -> ScrollPage (int_of_string n), l | "scroll"::n::"units"::l -> ScrollUnit (int_of_string n), l | "moveto"::f::l -> MoveTo (float_of_string f), l | l -> raise (Invalid_argument (String.concat " " ("TKtoCAMLscrollValue"::l))) ;; ##else let cCAMLtoTKscrollValue : scrollValue -> tkArgs = function | `Page v1 -> TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"pages"] | `Unit v1 -> TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"units"] | `Moveto v1 -> TkTokenList [TkToken"moveto"; TkToken (Printf.sprintf "%g" v1)] ;; (* str l -> scrllv -> str l *) let cTKtoCAMLscrollValue = function | "scroll" :: n :: ("pages"|"page") :: l -> `Page (int_of_string n), l | "scroll" :: n :: "units" :: l -> `Unit (int_of_string n), l | "moveto" :: f :: l -> `Moveto (float_of_string f), l | l -> raise (Invalid_argument (String.concat " " ("TKtoCAMLscrollValue"::l))) ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtini_GetPixel.ml0000644000175000017500000000264612124403241024352 0ustar tootstoots##ifdef CAMLTK let cCAMLtoTKunits = function Pixels (foo) -> TkToken (string_of_int foo) | Millimeters (foo) -> TkToken(Printf.sprintf "%gm" foo) | Inches (foo) -> TkToken(Printf.sprintf "%gi" foo) | PrinterPoint (foo) -> TkToken(Printf.sprintf "%gp" foo) | Centimeters (foo) -> TkToken(Printf.sprintf "%gc" foo) ;; let cTKtoCAMLunits str = let len = String.length str in let num_part str = String.sub str 0 (len - 1) in match String.get str (pred len) with 'c' -> Centimeters (float_of_string (num_part str)) | 'i' -> Inches (float_of_string (num_part str)) | 'm' -> Millimeters (float_of_string (num_part str)) | 'p' -> PrinterPoint (float_of_string (num_part str)) | _ -> Pixels(int_of_string str) ;; ##else let cCAMLtoTKunits : units -> tkArgs = function | `Pix (foo) -> TkToken (string_of_int foo) | `Mm (foo) -> TkToken(Printf.sprintf "%gm" foo) | `In (foo) -> TkToken(Printf.sprintf "%gi" foo) | `Pt (foo) -> TkToken(Printf.sprintf "%gp" foo) | `Cm (foo) -> TkToken(Printf.sprintf "%gc" foo) ;; let cTKtoCAMLunits str = let len = String.length str in let num_part str = String.sub str ~pos:0 ~len:(len - 1) in match String.get str (pred len) with | 'c' -> `Cm (float_of_string (num_part str)) | 'i' -> `In (float_of_string (num_part str)) | 'm' -> `Mm (float_of_string (num_part str)) | 'p' -> `Pt (float_of_string (num_part str)) | _ -> `Pix(int_of_string str) ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/text_tag_bind.ml0000644000175000017500000000326512124403241023543 0ustar tootstoots##ifdef CAMLTK let tag_bind widget tag eventsequence action = check_class widget widget_text_table; tkCommand [| cCAMLtoTKwidget widget_text_table widget; TkToken "tag"; TkToken "bind"; cCAMLtoTKtextTag tag; cCAMLtoTKeventSequence eventsequence; begin match action with | BindRemove -> TkToken "" | BindSet (what, f) -> let cbId = register_callback widget (wrapeventInfo f what) in TkToken ("camlcb " ^ cbId ^ (writeeventField what)) | BindSetBreakable (what, f) -> let cbId = register_callback widget (wrapeventInfo f what) in TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^ " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \ set BreakBindingsSequence 0") | BindExtend (what, f) -> let cbId = register_callback widget (wrapeventInfo f what) in TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) end |] ;; ##else let tag_bind ~tag ~events ?(extend = false) ?(breakable = false) ?(fields = []) ?action widget = tkCommand [| cCAMLtoTKwidget widget; TkToken "tag"; TkToken "bind"; cCAMLtoTKtextTag tag; cCAMLtoTKeventSequence events; begin match action with | None -> TkToken "" | Some f -> let cbId = register_callback widget ~callback: (wrapeventInfo f fields) in let cb = if extend then "+camlcb " else "camlcb " in let cb = cb ^ cbId ^ writeeventField fields in let cb = if breakable then cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" ^ " ; set BreakBindingsSequence 0" else cb in TkToken cb end |] ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/optionmenu.mli0000644000175000017500000000131412124403241023267 0ustar tootstoots##ifdef CAMLTK (* Support for tk_optionMenu *) val create: ?name: string -> widget -> textVariable -> string list -> widget * widget (** [create ?name parent var options] creates a multi-option menubutton and its associated menu. The option is also stored in the variable. Both widgets (menubutton and menu) are returned. *) ##else (* Support for tk_optionMenu *) val create: parent:'a widget -> variable:textVariable -> ?name: string -> string list -> menubutton widget * menu widget (** [create ~parent ~var ~name options] creates a multi-option menubutton and its associated menu. The option is also stored in the variable. Both widgets (menubutton and menu) are returned *) ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtini_bind.ml0000644000175000017500000000676112124403241023547 0ustar tootstoots##ifdef CAMLTK let cCAMLtoTKxEvent = function | Activate -> "Activate" | ButtonPress -> "ButtonPress" | ButtonPressDetail n -> "ButtonPress-"^string_of_int n | ButtonRelease -> "ButtonRelease" | ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n | Circulate -> "Circulate" | ColorMap -> "Colormap" | Configure -> "Configure" | Deactivate -> "Deactivate" | Destroy -> "Destroy" | Enter -> "Enter" | Expose -> "Expose" | FocusIn -> "FocusIn" | FocusOut -> "FocusOut" | Gravity -> "Gravity" | KeyPress -> "KeyPress" | KeyPressDetail s -> "KeyPress-"^s | KeyRelease -> "KeyRelease" | KeyReleaseDetail s -> "KeyRelease-"^s | Leave -> "Leave" | Map -> "Map" | Motion -> "Motion" | Property -> "Property" | Reparent -> "Reparent" | Unmap -> "Unmap" | Visibility -> "Visibility" | Virtual s -> "<"^s^">" ;; let cCAMLtoTKmodifier = function | Control -> "Control-" | Shift -> "Shift-" | Lock -> "Lock-" | Button1 -> "Button1-" | Button2 -> "Button2-" | Button3 -> "Button3-" | Button4 -> "Button4-" | Button5 -> "Button5-" | Double -> "Double-" | Triple -> "Triple-" | Mod1 -> "Mod1-" | Mod2 -> "Mod2-" | Mod3 -> "Mod3-" | Mod4 -> "Mod4-" | Mod5 -> "Mod5-" | Meta -> "Meta-" | Alt -> "Alt-" ;; exception IllegalVirtualEvent (* type event = modifier list * xEvent *) let cCAMLtoTKevent (ml, xe) = match xe with | Virtual s -> if ml = [] then "<<"^s^">>" else raise IllegalVirtualEvent | _ -> "<" ^ (String.concat " " (List.map cCAMLtoTKmodifier ml)) ^ (cCAMLtoTKxEvent xe) ^ ">" ;; (* type eventSequence == (modifier list * xEvent) list *) let cCAMLtoTKeventSequence l = TkToken(List.fold_left (^) "" (List.map cCAMLtoTKevent l)) ##else let cCAMLtoTKmodifier : modifier -> string = function | `Control -> "Control-" | `Shift -> "Shift-" | `Lock -> "Lock-" | `Button1 -> "Button1-" | `Button2 -> "Button2-" | `Button3 -> "Button3-" | `Button4 -> "Button4-" | `Button5 -> "Button5-" | `Double -> "Double-" | `Triple -> "Triple-" | `Mod1 -> "Mod1-" | `Mod2 -> "Mod2-" | `Mod3 -> "Mod3-" | `Mod4 -> "Mod4-" | `Mod5 -> "Mod5-" | `Meta -> "Meta-" | `Alt -> "Alt-" ;; exception IllegalVirtualEvent let cCAMLtoTKevent (ev : event) = let modified = ref false in let rec convert = function | `Activate -> "Activate" | `ButtonPress -> "ButtonPress" | `ButtonPressDetail n -> "ButtonPress-"^string_of_int n | `ButtonRelease -> "ButtonRelease" | `ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n | `Circulate -> "Circulate" | `Colormap -> "Colormap" | `Configure -> "Configure" | `Deactivate -> "Deactivate" | `Destroy -> "Destroy" | `Enter -> "Enter" | `Expose -> "Expose" | `FocusIn -> "FocusIn" | `FocusOut -> "FocusOut" | `Gravity -> "Gravity" | `KeyPress -> "KeyPress" | `KeyPressDetail s -> "KeyPress-"^s | `KeyRelease -> "KeyRelease" | `KeyReleaseDetail s -> "KeyRelease-"^s | `Leave -> "Leave" | `Map -> "Map" | `Motion -> "Motion" | `Property -> "Property" | `Reparent -> "Reparent" | `Unmap -> "Unmap" | `Visibility -> "Visibility" | `Virtual s -> if !modified then raise IllegalVirtualEvent else "<"^s^">" | `Modified(ml, ev) -> modified := true; String.concat ~sep:"" (List.map ~f:cCAMLtoTKmodifier ml) ^ convert ev in "<" ^ convert ev ^ ">" ;; let cCAMLtoTKeventSequence (l : event list) = TkToken(String.concat ~sep:"" (List.map ~f:cCAMLtoTKevent l)) ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/optionmenu.ml0000644000175000017500000000311312124403241023115 0ustar tootstoots##ifdef CAMLTK open Protocol;; (* Implementation of the tk_optionMenu *) let create ?name parent variable values = let w = Widget.new_atom "menubutton" ~parent ?name in let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in let res = tkEval [|TkToken "tk_optionMenu"; TkToken (Widget.name w); cCAMLtoTKtextVariable variable; TkTokenList (List.map (function x -> TkToken x) values)|] in if res <> Widget.name mw then raise (TkError "internal error in Optionmenu.create") else w,mw ;; let create_named parent name variable values = let w = Widget.new_atom "menubutton" ~parent ~name in let mw = Widget.new_atom "menu" ~parent:w ~name: "menu" in let res = tkEval [|TkToken "tk_optionMenu"; TkToken (Widget.name w); cCAMLtoTKtextVariable variable; TkTokenList (List.map (function x -> TkToken x) values)|] in if res <> Widget.name mw then raise (TkError "internal error in Optionmenu.create") else w,mw ;; ##else open Protocol;; (* Implementation of the tk_optionMenu *) let create ~parent ~variable ?name values = let w = Widget.new_atom "menubutton" ~parent ?name in let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in (* assumes .menu naming *) let res = tkEval [|TkToken "tk_optionMenu"; TkToken (Widget.name w); cCAMLtoTKtextVariable variable; TkTokenList (List.map ~f:(fun x -> TkToken x) values)|] in if res <> Widget.name mw then raise (TkError "internal error in Optionmenu.create") else w, mw ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/report.ml0000644000175000017500000000073412124403241022241 0ustar tootstoots(* Report globals from protocol *) let opentk = Protocol.opentk let keywords = Protocol.keywords let opentk_with_args = Protocol.opentk_with_args let openTk = Protocol.openTk let openTkClass = Protocol.openTkClass let openTkDisplayClass = Protocol.openTkDisplayClass let closeTk = Protocol.closeTk let mainLoop = Protocol.mainLoop let register = Protocol.register (* From support *) let may = Support.may let maycons = Support.maycons (* From widget *) let coe = Widget.coe mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtin_font.ml0000644000175000017500000000005212124403241023413 0ustar tootstoots(* type *) type font = string (* /type *) mingw-ocaml/ocaml/otherlibs/labltk/builtin/rawimg.ml0000644000175000017500000000752312124403241022217 0ustar tootstootsexternal rawget : string -> string = "camltk_getimgdata" external rawset : string -> string -> int -> int -> int -> int -> unit = "camltk_setimgdata_bytecode" (* all int parameters MUST be positive *) "camltk_setimgdata_native" type t = { pixmap_width : int; pixmap_height: int; pixmap_data: string } type pixel = string (* 3 chars *) (* pixmap will be an abstract type *) let width pix = pix.pixmap_width let height pix = pix.pixmap_height (* note: invalid size would have been caught by String.create, but we put * it here for documentation purpose *) let create w h = if w < 0 || h < 0 then invalid_arg "invalid size" else { pixmap_width = w; pixmap_height = h; pixmap_data = String.create (w * h * 3); } (* * operations on pixmaps *) let unsafe_copy pix_from pix_to = String.unsafe_blit pix_from.pixmap_data 0 pix_to.pixmap_data 0 (String.length pix_from.pixmap_data) (* We check only the length. w,h might be different... *) let copy pix_from pix_to = let l = String.length pix_from.pixmap_data in if l <> String.length pix_to.pixmap_data then raise (Invalid_argument "copy: incompatible length") else unsafe_copy pix_from pix_to (* Pixel operations *) let unsafe_get_pixel pixmap x y = let pos = (y * pixmap.pixmap_width + x) * 3 in let r = String.create 3 in String.unsafe_blit pixmap.pixmap_data pos r 0 3; r let unsafe_set_pixel pixmap x y pixel = let pos = (y * pixmap.pixmap_width + x) * 3 in String.unsafe_blit pixel 0 pixmap.pixmap_data pos 3 (* To get safe operations, we can either check x,y wrt [0,w[ and [0,h[ or rely on blit checking. We choose the first for clarity. *) let get_pixel pix x y = if x < 0 || y < 0 || x >= pix.pixmap_width || y >= pix.pixmap_height then invalid_arg "invalid pixel" else unsafe_get_pixel pix x y (* same check (pixel being abstract, it must be of good size *) let set_pixel pix x y pixel = if x < 0 || y < 0 || x >= pix.pixmap_width || y >= pix.pixmap_height then invalid_arg "invalid pixel" else unsafe_set_pixel pix x y pixel (* black as default_color, if at all needed *) let default_color = "\000\000\000" (* Char.chr does range checking *) let pixel r g b = let s = String.create 3 in s.[0] <- Char.chr r; s.[1] <- Char.chr g; s.[2] <- Char.chr b; s ##ifdef CAMLTK (* create pixmap from an existing image *) let get photo = match photo with | PhotoImage s -> { pixmap_width = CImagephoto.width photo; pixmap_height = CImagephoto.height photo; pixmap_data = rawget s; } (* copy a full pixmap into an image *) let set photo pix = match photo with | PhotoImage s -> rawset s pix.pixmap_data 0 0 pix.pixmap_width pix.pixmap_height (* general blit of pixmap into image *) let blit photo pix x y w h = if x < 0 || y < 0 || w < 0 || h < 0 then invalid_arg "negative argument" else match photo with | PhotoImage s -> rawset s pix.pixmap_data x y w h (* get from a file *) let from_file filename = let img = CImagephoto.create [File filename] in let pix = get img in CImagephoto.delete img; pix ##else (* create pixmap from an existing image *) let get photo = match photo with | `Photo s -> { pixmap_width = Imagephoto.width photo; pixmap_height = Imagephoto.height photo; pixmap_data = rawget s; } (* copy a full pixmap into an image *) let set photo pix = match photo with | `Photo s -> rawset s pix.pixmap_data 0 0 pix.pixmap_width pix.pixmap_height (* general blit of pixmap into image *) let blit photo pix x y w h = if x < 0 || y < 0 || w < 0 || h < 0 then invalid_arg "negative argument" else match photo with | `Photo s -> rawset s pix.pixmap_data x y w h (* get from a file *) let from_file filename = let img = Imagephoto.create ~file: filename () in let pix = get img in Imagephoto.delete img; pix ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtini_bindtags.ml0000644000175000017500000000111712124403241024414 0ustar tootstoots##ifdef CAMLTK let cCAMLtoTKbindings = function | WidgetBindings v1 -> cCAMLtoTKwidget widget_any_table v1 | TagBindings v1 -> TkToken v1 ;; (* this doesn't really belong here *) let cTKtoCAMLbindings s = if String.length s > 0 && s.[0] = '.' then WidgetBindings (cTKtoCAMLwidget s) else TagBindings s ;; ##else let cCAMLtoTKbindings = function | `Widget v1 -> cCAMLtoTKwidget v1 | `Tag v1 -> TkToken v1 ;; (* this doesn't really belong here *) let cTKtoCAMLbindings s = if String.length s > 0 && s.[0] = '.' then `Widget (cTKtoCAMLwidget s) else `Tag s ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtin_GetBitmap.ml0000644000175000017500000000057212124403241024330 0ustar tootstoots(* Tk_GetBitmap emulation *) ##ifdef CAMLTK (* type *) type bitmap = | BitmapFile of string (* path of file *) | Predefined of string (* bitmap name *) ;; (* /type *) ##else (* type *) type bitmap = [ | `File of string (* path of file *) | `Predefined of string (* bitmap name *) ] ;; (* /type *) ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtin_bindtags.ml0000644000175000017500000000054612124403241024250 0ustar tootstoots##ifdef CAMLTK (* type *) type bindings = | TagBindings of string (* tk option: *) | WidgetBindings of widget (* tk option: *) ;; (* /type *) ##else (* type *) type bindings = [ | `Tag of string (* tk option: *) | `Widget of any widget (* tk option: *) ] ;; (* /type *) ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/rawimg.mli0000644000175000017500000000201712124403241022361 0ustar tootstoots(* * Minimal pixmap support *) type t type pixel val width : t -> int (* [width pixmap] *) val height : t -> int (* [height pixmap] *) val create : int -> int -> t (* [create width height] *) val get : imagePhoto -> t (* [get img] *) val set : imagePhoto -> t -> unit (* [set img pixmap] *) val blit : imagePhoto -> t -> int -> int -> int -> int -> unit (* [blit img pixmap x y w h] (all ints must be non-negative) *) val from_file : string -> t (* [from_file filename] *) val copy : t -> t -> unit (* [copy src dst] *) (* * Pixel operations *) val get_pixel : t -> int -> int -> pixel (* [get_pixel pixmap x y] *) val set_pixel : t -> int -> int -> pixel -> unit (* [set_pixel pixmap x y pixel] *) val default_color : pixel val pixel : int -> int -> int -> pixel (* [pixel r g b] (r,g,b must be in [0..255]) *) (*-*) (* unsafe *) val unsafe_copy : t -> t -> unit val unsafe_get_pixel : t -> int -> int -> pixel val unsafe_set_pixel : t -> int -> int -> pixel -> unit (* /unsafe *) mingw-ocaml/ocaml/otherlibs/labltk/builtin/selection_handle_set.mli0000644000175000017500000000060412124403241025246 0ustar tootstoots##ifdef CAMLTK val handle_set : icccm list -> widget -> (int -> int -> unit) -> unit (** tk invocation: selection handle *) ##else val handle_set : command: (pos:int -> len:int -> string) -> ?format: string -> ?selection:string -> ?typ: string -> 'a widget -> unit (** tk invocation: selection handle *) ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtini_palette.ml0000644000175000017500000000104412124403241024256 0ustar tootstoots##ifdef CAMLTK let cCAMLtoTKpaletteType = function GrayShades (foo) -> TkToken (string_of_int foo) | RGBShades (r,v,b) -> TkToken (string_of_int r^"/"^ string_of_int v^"/"^ string_of_int b) ;; ##else let cCAMLtoTKpaletteType : paletteType -> tkArgs = function | `Gray (foo) -> TkToken (string_of_int foo) | `Rgb (r,v,b) -> TkToken (string_of_int r ^ "/" ^ string_of_int v ^ "/" ^ string_of_int b) ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtin_GetCursor.ml0000644000175000017500000000251612124403241024371 0ustar tootstoots(* Color *) ##ifdef CAMLTK (* type *) type color = | NamedColor of string | Black (* tk keyword: black *) | White (* tk keyword: white *) | Red (* tk keyword: red *) | Green (* tk keyword: green *) | Blue (* tk keyword: blue *) | Yellow (* tk keyword: yellow *) ;; (* /type *) ##else (* type *) type color = [ | `Color of string | `Black (* tk keyword: black *) | `White (* tk keyword: white *) | `Red (* tk keyword: red *) | `Green (* tk keyword: green *) | `Blue (* tk keyword: blue *) | `Yellow (* tk keyword: yellow *) ] ;; (* /type *) ##endif ##ifdef CAMLTK (* type *) type cursor = | XCursor of string | XCursorFg of string * color | XCursortFgBg of string * color * color | CursorFileFg of string * color | CursorMaskFile of string * string * color * color ;; (* /type *) ##else (* Tk_GetCursor emulation *) (* type *) type cursor = [ | `Xcursor of string | `Xcursorfg of string * color | `Xcursorfgbg of string * color * color | `Cursorfilefg of string * color | `Cursormaskfile of string * string * color * color ] ;; (* /type *) ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtin_GetPixel.ml0000644000175000017500000000062212124403241024171 0ustar tootstoots(* Tk_GetPixels emulation *) ##ifdef CAMLTK (* type *) type units = | Pixels of int (* specified as floating-point, but inconvenient *) | Centimeters of float | Inches of float | Millimeters of float | PrinterPoint of float ;; (* /type *) ##else (* type *) type units = [ | `Pix of int | `Cm of float | `In of float | `Mm of float | `Pt of float ] ;; (* /type *) ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtin_grab.ml0000644000175000017500000000005612124403241023364 0ustar tootstoots(* type *) type grabGlobal = bool (* /type *) mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtin_palette.ml0000644000175000017500000000034412124403241024107 0ustar tootstoots##ifdef CAMLTK (* type *) type paletteType = | GrayShades of int | RGBShades of int * int * int ;; (* /type *) ##else (* type *) type paletteType = [ | `Gray of int | `Rgb of int * int * int ] ;; (* /type *) ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/canvas_bind.mli0000644000175000017500000000047112124403241023344 0ustar tootstoots##ifdef CAMLTK val bind : widget -> tagOrId -> (modifier list * xEvent) list -> bindAction -> unit ##else val bind : events: event list -> ?extend: bool -> ?breakable: bool -> ?fields: eventField list -> ?action: (eventInfo -> unit) -> canvas widget -> tagOrId -> unit ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtinf_bind.ml0000644000175000017500000001011112124403241023524 0ustar tootstoots##ifdef CAMLTK (* type *) type bindAction = | BindSet of eventField list * (eventInfo -> unit) | BindSetBreakable of eventField list * (eventInfo -> unit) | BindRemove | BindExtend of eventField list * (eventInfo -> unit) (* /type *) (* FUNCTION val bind: widget -> (modifier list * xEvent) list -> bindAction -> unit /FUNCTION *) let bind widget eventsequence action = tkCommand [| TkToken "bind"; TkToken (Widget.name widget); cCAMLtoTKeventSequence eventsequence; begin match action with BindRemove -> TkToken "" | BindSet (what, f) -> let cbId = register_callback widget (wrapeventInfo f what) in TkToken ("camlcb " ^ cbId ^ (writeeventField what)) | BindSetBreakable (what, f) -> let cbId = register_callback widget (wrapeventInfo f what) in TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^ " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0") | BindExtend (what, f) -> let cbId = register_callback widget (wrapeventInfo f what) in TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) end |] ;; (* FUNCTION (* unsafe *) val bind_class : string -> (modifier list * xEvent) list -> bindAction -> unit (* /unsafe *) /FUNCTION class arg is not constrained *) let bind_class clas eventsequence action = tkCommand [| TkToken "bind"; TkToken clas; cCAMLtoTKeventSequence eventsequence; begin match action with BindRemove -> TkToken "" | BindSet (what, f) -> let cbId = register_callback Widget.dummy (wrapeventInfo f what) in TkToken ("camlcb " ^ cbId ^ (writeeventField what)) | BindSetBreakable (what, f) -> let cbId = register_callback Widget.dummy (wrapeventInfo f what) in TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" ) | BindExtend (what, f) -> let cbId = register_callback Widget.dummy (wrapeventInfo f what) in TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) end |] ;; (* FUNCTION (* unsafe *) val bind_tag : string -> (modifier list * xEvent) list -> bindAction -> unit (* /unsafe *) /FUNCTION *) let bind_tag = bind_class ;; (* FUNCTION val break : unit -> unit /FUNCTION *) let break = function () -> Textvariable.set (Textvariable.coerce "BreakBindingsSequence") "1" ;; (* Legacy functions *) let tag_bind = bind_tag;; let class_bind = bind_class;; ##else let bind_class ~events ?(extend = false) ?(breakable = false) ?(fields = []) ?action ?on:widget name = let widget = match widget with None -> Widget.dummy | Some w -> coe w in tkCommand [| TkToken "bind"; TkToken name; cCAMLtoTKeventSequence events; begin match action with None -> TkToken "" | Some f -> let cbId = register_callback widget ~callback: (wrapeventInfo f fields) in let cb = if extend then "+camlcb " else "camlcb " in let cb = cb ^ cbId ^ writeeventField fields in let cb = if breakable then cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" ^ " ; set BreakBindingsSequence 0" else cb in TkToken cb end |] ;; let bind ~events ?extend ?breakable ?fields ?action widget = bind_class ~events ?extend ?breakable ?fields ?action ~on:widget (Widget.name widget) ;; let bind_tag = bind_class ;; (* FUNCTION val break : unit -> unit /FUNCTION *) let break = function () -> tkCommand [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |] ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/builtini_index.ml0000644000175000017500000001075212124403241023735 0ustar tootstoots##ifdef CAMLTK (* sp to avoid being picked up by doc scripts *) type index_constrs = CNumber | CActiveElement | CEnd | CLast | CNoIndex | CInsert | CSelFirst | CSelLast | CAt | CAtXY | CAnchorPoint | CPattern | CLineChar | CMark | CTagFirst | CTagLast | CEmbedded ;; let index_any_table = [CNumber; CActiveElement; CEnd; CLast; CNoIndex; CInsert; CSelFirst; CSelLast; CAt; CAtXY; CAnchorPoint; CPattern; CLineChar; CMark; CTagFirst; CTagLast; CEmbedded] ;; let index_canvas_table = [CNumber; CEnd; CInsert; CSelFirst; CSelLast; CAtXY] ;; let index_entry_table = [CNumber; CAnchorPoint; CEnd; CInsert; CSelFirst; CSelLast; CAt] ;; let index_listbox_table = [CNumber; CActiveElement; CAnchorPoint; CEnd; CAtXY] ;; let index_menu_table = [CNumber; CActiveElement; CEnd; CLast; CNoIndex; CAt; CPattern] ;; let index_text_table = [CLineChar; CAtXY; CEnd; CMark; CTagFirst; CTagLast; CEmbedded] ;; let cCAMLtoTKindex table = function Number x -> chk_sub "Number" table CNumber; TkToken (string_of_int x) | ActiveElement -> chk_sub "ActiveElement" table CActiveElement; TkToken "active" | End -> chk_sub "End" table CEnd; TkToken "end" | Last -> chk_sub "Last" table CLast; TkToken "last" | NoIndex -> chk_sub "NoIndex" table CNoIndex; TkToken "none" | Insert -> chk_sub "Insert" table CInsert; TkToken "insert" | SelFirst -> chk_sub "SelFirst" table CSelFirst; TkToken "sel.first" | SelLast -> chk_sub "SelLast" table CSelLast; TkToken "sel.last" | At n -> chk_sub "At" table CAt; TkToken ("@"^string_of_int n) | AtXY (x,y) -> chk_sub "AtXY" table CAtXY; TkToken ("@"^string_of_int x^","^string_of_int y) | AnchorPoint -> chk_sub "AnchorPoint" table CAnchorPoint; TkToken "anchor" | Pattern s -> chk_sub "Pattern" table CPattern; TkToken s | LineChar (l,c) -> chk_sub "LineChar" table CLineChar; TkToken (string_of_int l^"."^string_of_int c) | Mark s -> chk_sub "Mark" table CMark; TkToken s | TagFirst t -> chk_sub "TagFirst" table CTagFirst; TkToken (t^".first") | TagLast t -> chk_sub "TagLast" table CTagLast; TkToken (t^".last") | Embedded w -> chk_sub "Embedded" table CEmbedded; cCAMLtoTKwidget widget_any_table w ;; let char_index c s = let rec find i = if i >= String.length s then raise Not_found else if String.get s i = c then i else find (i+1) in find 0 ;; (* Assume returned values are only numerical and l.c *) (* .menu index returns none if arg is none, but blast it *) let cTKtoCAMLindex s = try let p = char_index '.' s in LineChar(int_of_string (String.sub s 0 p), int_of_string (String.sub s (p+1) (String.length s - p - 1))) with Not_found -> try Number (int_of_string s) with _ -> raise (Invalid_argument ("TKtoCAMLindex: "^s)) ;; ##else let cCAMLtoTKindex (* Don't put explicit typing *) = function | `Num x -> TkToken (string_of_int x) | `Active -> TkToken "active" | `End -> TkToken "end" | `Last -> TkToken "last" | `None -> TkToken "none" | `Insert -> TkToken "insert" | `Selfirst -> TkToken "sel.first" | `Sellast -> TkToken "sel.last" | `At n -> TkToken ("@" ^ string_of_int n) | `Atxy (x,y) -> TkToken ("@" ^ string_of_int x ^ "," ^ string_of_int y) | `Anchor -> TkToken "anchor" | `Pattern s -> TkToken s | `Linechar (l,c) -> TkToken (string_of_int l ^ "." ^ string_of_int c) | `Mark s -> TkToken s | `Tagfirst t -> TkToken (t ^ ".first") | `Taglast t -> TkToken (t ^ ".last") | `Window (w : any widget) -> cCAMLtoTKwidget w | `Image s -> TkToken s ;; let cCAMLtoTKcanvas_index = (cCAMLtoTKindex : canvas_index -> tkArgs);; let cCAMLtoTKentry_index = (cCAMLtoTKindex : entry_index -> tkArgs);; let cCAMLtoTKlistbox_index = (cCAMLtoTKindex : listbox_index -> tkArgs);; let cCAMLtoTKmenu_index = (cCAMLtoTKindex : menu_index -> tkArgs);; let cCAMLtoTKtext_index = (cCAMLtoTKindex : text_index -> tkArgs);; (* Assume returned values are only numerical and l.c *) let cTKtoCAMLtext_index s = try let p = String.index s '.' in `Linechar (int_of_string (String.sub s ~pos:0 ~len:p), int_of_string (String.sub s ~pos:(p + 1) ~len:(String.length s - p - 1))) with Not_found -> raise (Invalid_argument ("TKtoCAMLtext_index: " ^ s)) ;; let cTKtoCAMLlistbox_index s = try `Num (int_of_string s) with _ -> raise (Invalid_argument ("TKtoCAMLlistbox_index: " ^ s)) ;; ##endif mingw-ocaml/ocaml/otherlibs/labltk/builtin/winfo_contained.mli0000644000175000017500000000036112124403241024241 0ustar tootstoots##ifdef CAMLTK val contained : int -> int -> widget -> bool (** [contained x y w] returns true if (x,y) is in w *) ##else val contained : x:int -> y:int -> 'a widget -> bool (** [contained x y w] returns true if (x,y) is in w *) ##endif mingw-ocaml/ocaml/otherlibs/labltk/jpf/0000755000175000017500000000000012124403241017501 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/jpf/jpf_font.mli0000644000175000017500000000403712124403241022015 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) val debug : bool ref type ('a, 'b) xlfd = { mutable foundry: 'a; mutable family: 'a; mutable weight: 'a; mutable slant: 'a; mutable setWidth: 'a; mutable addStyle: 'a; mutable pixelSize: 'b; mutable pointSize: 'b; mutable resolutionX: 'b; mutable resolutionY: 'b; mutable spacing: 'a; mutable averageWidth: 'b; mutable registry: 'a; mutable encoding: 'a } exception Parse_Xlfd_Failure of string type valid_xlfd = (string, int) xlfd type pattern = (string option, int option) xlfd val empty_pattern : pattern val copy : ('a, 'b) xlfd -> ('a, 'b) xlfd val string_of_valid_xlfd : valid_xlfd -> string val string_of_pattern : pattern -> string val is_vector_font : valid_xlfd -> bool val list_fonts : string option -> pattern -> valid_xlfd list val available_pixel_size : string option -> pattern -> (int * valid_xlfd list) list val nearest_pixel_size : string option -> bool -> pattern -> valid_xlfd mingw-ocaml/ocaml/otherlibs/labltk/jpf/Makefile0000644000175000017500000000532312124403241021144 0ustar tootstoots####################################################################### # # # MLTk, Tcl/Tk interface of OCaml # # # # Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # # projet Cristal, INRIA Rocquencourt # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique and Kyoto University. All rights reserved. # # This file is distributed under the terms of the GNU Library # # General Public License, with the special exception on linking # # described in file LICENSE found in the OCaml source tree. # # # ####################################################################### include ../support/Makefile.common COMPFLAGS=-I ../labltk -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/unix -I $(OTHERS)/str OBJS= fileselect.cmo balloon.cmo shell.cmo jpf_font.cmo OBJSX = $(OBJS:.cmo=.cmx) all: jpflib.cma opt: jpflib.cmxa test: balloontest testopt: balloontest.opt jpflib.cma: $(OBJS) $(CAMLLIBR) -o jpflib.cma $(OBJS) jpflib.cmxa: $(OBJSX) $(CAMLOPTLIBR) -o jpflib.cmxa $(OBJSX) install: cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) jpflib.cma $(INSTALLDIR) installopt: cp jpflib.cmxa jpflib.$(A) $(OBJS:.cmo=.cmx) $(INSTALLDIR) clean: rm -f *.cm* *.$(O) *.$(A) *~ *test $(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma $(OBJSX): ../lib/$(LIBNAME).cmxa ### Tests balloontest: balloontest.cmo $(CAMLC) -o balloontest -I ../support -I ../lib \ -custom $(LIBNAME).cma jpflib.cma balloontest.cmo balloontest.opt: balloontest.cmx $(CAMLOPT) -o balloontest.opt -I ../support -I ../lib \ $(LIBNAME).cmxa jpflib.cmxa balloontest.cmx balloontest.cmo : balloon.cmo jpflib.cma balloontest.cmx : balloon.cmx jpflib.cmxa .SUFFIXES : .SUFFIXES : .mli .ml .cmi .cmx .cmo .mli.cmi: $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmo: $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< depend: mv Makefile Makefile.bak (sed -n -e '1,/^### DO NOT DELETE THIS LINE/p' Makefile.bak; \ $(CAMLDEP) *.mli *.ml) > Makefile ### EVERYTHING THAT GOES BEYOND THIS COMMENT IS GENERATED ### DO NOT DELETE THIS LINE balloon.cmo: balloon.cmi balloon.cmx: balloon.cmi fileselect.cmo: fileselect.cmi fileselect.cmx: fileselect.cmi jpf_font.cmo: shell.cmi jpf_font.cmi jpf_font.cmx: shell.cmx jpf_font.cmi shell.cmo: shell.cmi shell.cmx: shell.cmi mingw-ocaml/ocaml/otherlibs/labltk/jpf/Makefile.nt0000644000175000017500000000002112124403241021552 0ustar tootstootsinclude Makefile mingw-ocaml/ocaml/otherlibs/labltk/jpf/README0000644000175000017500000000010212124403241020352 0ustar tootstootsThis is Jun Furuse's widget set library, Jpf. It uses LablTk API. mingw-ocaml/ocaml/otherlibs/labltk/jpf/jpflib.mllib0000644000175000017500000000004212124403241021764 0ustar tootstootsFileselect Balloon Shell Jpf_font mingw-ocaml/ocaml/otherlibs/labltk/jpf/fileselect.ml0000644000175000017500000003135512124403241022161 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* file selection box *) (* This file selecter works only under the OS with the full unix support. For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *) open StdLabels open UnixLabels open Str open Filename open Tk open Widget exception Not_selected (********************************************************** Search directory *) (* Default is curdir *) let global_dir = ref (getcwd ()) (***************************************************** Some widgets creation *) (* from frx_listbox.ml *) let scroll_link sb lb = Listbox.configure lb ~yscrollcommand: (Scrollbar.set sb); Scrollbar.configure sb ~command: (Listbox.yview lb) (* focus when enter binding *) let bind_enter_focus w = bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w);; let myentry_create p ~variable = let w = Entry.create p ~relief: `Sunken ~textvariable: variable in bind_enter_focus w; w (************************************************************* Subshell call *) let subshell cmd = let r,w = pipe () in match fork () with 0 -> close r; dup2 ~src:w ~dst:stdout; execv ~prog:"/bin/sh" ~args:[| "/bin/sh"; "-c"; cmd |] | id -> close w; let rc = in_channel_of_descr r in let rec it l = match try Some(input_line rc) with _ -> None with Some x -> it (x::l) | None -> List.rev l in let answer = it [] in close_in rc; (* because of finalize_channel *) let _ = waitpid ~mode:[] id in answer (***************************************************************** Path name *) (* find directory name which doesn't contain "?*[" *) let dirget = regexp "^\\([^\\*?[]*/\\)\\(.*\\)" let parse_filter src = (* replace // by / *) let s = global_replace (regexp "/+") "/" src in (* replace /./ by / *) let s = global_replace (regexp "/\\./") "/" s in (* replace ????/../ by "" *) let s = global_replace (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./") "" s in (* replace ????/..$ by "" *) let s = global_replace (regexp "\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$") "" s in (* replace ^/../../ by / *) let s = global_replace (regexp "^\\(/\\.\\.\\)+/") "/" s in if string_match dirget s 0 then let dirs = matched_group 1 s and ptrn = matched_group 2 s in dirs, ptrn else "", s let ls dir pattern = subshell ("cd " ^ dir ^ ";/bin/ls -ad " ^ pattern ^" 2>/dev/null") (*************************************************************** File System *) let get_files_in_directory dir = let dirh = opendir dir in let rec get_them l = match try Some(Unix.readdir dirh) with _ -> None with | None -> Unix.closedir dirh; l | Some x -> get_them (x::l) in List.sort ~cmp:compare (get_them []) let rec get_directories_in_files path = List.filter ~f:(fun x -> try (stat (path ^ x)).st_kind = S_DIR with _ -> false) let remove_directories path = List.filter ~f:(fun x -> try (stat (path ^ x)).st_kind <> S_DIR with _ -> false) (************************* a nice interface to listbox - from frx_listbox.ml *) let add_completion lb action = let prefx = ref "" (* current match prefix *) and maxi = ref 0 (* maximum index (doesn'y matter actually) *) and current = ref 0 (* current position *) and lastevent = ref 0 in let rec move_forward () = if Listbox.get lb ~index:(`Num !current) < !prefx then if !current < !maxi then begin incr current; move_forward() end and recenter () = let element = `Num !current in (* Clean the selection *) Listbox.selection_clear lb ~first:(`Num 0) ~last:`End; (* Set it to our unique element *) Listbox.selection_set lb ~first:element ~last:element; (* Activate it, to keep consistent with Up/Down. You have to be in Extended or Browse mode *) Listbox.activate lb ~index:element; Listbox.selection_anchor lb ~index:element; Listbox.see lb ~index:element in let complete time s = if time - !lastevent < 500 then (* sorry, hard coded limit *) prefx := !prefx ^ s else begin (* reset *) current := 0; prefx := s end; lastevent := time; move_forward(); recenter() in bind lb ~events:[`KeyPress] ~fields:[`Char; `Time] (* consider only keys producing characters. The callback is called if you press Shift. *) ~action:(fun ev -> if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char); (* Key specific bindings override KeyPress *) bind lb ~events:[`KeyPressDetail "Return"] ~action; (* Finally, we have to set focus, otherwise events dont get through *) Focus.set lb; recenter() (* so that first item is selected *); (* returns init_completion function *) (fun lb -> prefx := ""; maxi := Listbox.size lb - 1; current := 0) (****************************************************************** Creation *) let f ~title ~action:proc ~filter:deffilter ~file:deffile ~multi ~sync = (* Ah ! Now I regret about the names of the widgets... *) let current_pattern = ref "" and current_dir = ref "" in (* init_completions *) let filter_init_completion = ref (fun _ -> ()) and directory_init_completion = ref (fun _ -> ()) in let tl = Toplevel.create default_toplevel in Focus.set tl; Wm.title_set tl title; let filter_var = Textvariable.create ~on:tl () (* new_temporary *) and selection_var = Textvariable.create ~on:tl () and sync_var = Textvariable.create ~on:tl () in let frm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in let frm = Frame.create frm' ~borderwidth: 8 in let fl = Label.create frm ~text: "Filter" in let df = Frame.create frm in let dfl = Frame.create df in let dfll = Label.create dfl ~text: "Directories" in let dflf = Frame.create dfl in let directory_listbox = Listbox.create dflf ~relief: `Sunken and directory_scrollbar = Scrollbar.create dflf in scroll_link directory_scrollbar directory_listbox; let dfr = Frame.create df in let dfrl = Label.create dfr ~text: "Files" in let dfrf = Frame.create dfr in let filter_listbox = Listbox.create dfrf ~relief: `Sunken in let filter_scrollbar = Scrollbar.create dfrf in scroll_link filter_scrollbar filter_listbox; let sl = Label.create frm ~text: "Selection" in let filter_entry = myentry_create frm ~variable: filter_var in let selection_entry = myentry_create frm ~variable: selection_var in let cfrm' = Frame.create tl ~borderwidth: 1 ~relief: `Raised in let cfrm = Frame.create cfrm' ~borderwidth: 8 in let dumf = Frame.create cfrm in let dumf2 = Frame.create cfrm in let configure filter = (* OLDER let curdir = getcwd () in *) (* Printf.eprintf "CURDIR %s\n" curdir; *) let filter = if string_match (regexp "^/.*") filter 0 then filter else if filter = "" then !global_dir ^ "/*" else !global_dir ^ "/" ^ filter in (* Printf.eprintf "FILTER %s\n" filter; *) let dirname, patternname = parse_filter filter in (* Printf.eprintf "DIRNAME %s PATTERNNAME %s\n" dirname patternname; *) current_dir := dirname; global_dir := dirname; let patternname = if patternname = "" then "*" else patternname in current_pattern := patternname; let filter = dirname ^ patternname in (* Printf.eprintf "FILTER : %s\n\n" filter; *) (* flush Pervasives.stderr; *) try let directories = get_directories_in_files dirname (get_files_in_directory dirname) in (* get matched file by subshell call. *) let matched_files = remove_directories dirname (ls dirname patternname) in Textvariable.set filter_var filter; Textvariable.set selection_var (dirname ^ deffile); Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End; Listbox.insert directory_listbox ~index:`End ~texts:directories; Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End; Listbox.insert filter_listbox ~index:`End ~texts:matched_files; !directory_init_completion directory_listbox; !filter_init_completion filter_listbox with Unix_error (ENOENT,_,_) -> (* Directory is not found (maybe) *) Bell.ring () in let selected_files = ref [] in (* used for synchronous mode *) let activate l () = Grab.release tl; destroy tl; if sync then begin selected_files := l; Textvariable.set sync_var "1" end else begin proc l; break () end in (* and buttons *) let okb = Button.create cfrm ~text: "OK" ~command: begin fun () -> let files = List.map (Listbox.curselection filter_listbox) ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x)) in let files = if files = [] then [Textvariable.get selection_var] else files in activate files () end in let flb = Button.create cfrm ~text: "Filter" ~command: (fun () -> configure (Textvariable.get filter_var)) in let ccb = Button.create cfrm ~text: "Cancel" ~command: (fun () -> activate [] ()) in (* binding *) bind selection_entry ~events:[`KeyPressDetail "Return"] ~breakable:true ~action:(fun _ -> activate [Textvariable.get selection_var] ()); bind filter_entry ~events:[`KeyPressDetail "Return"] ~action:(fun _ -> configure (Textvariable.get filter_var)); let action _ = let files = List.map (Listbox.curselection filter_listbox) ~f:(fun x -> !current_dir ^ (Listbox.get filter_listbox ~index:x)) in activate files () in bind filter_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)] ~breakable:true ~action; if multi then Listbox.configure filter_listbox ~selectmode: `Multiple; filter_init_completion := add_completion filter_listbox action; let action _ = try configure (!current_dir ^ ((function [x] -> Listbox.get directory_listbox ~index:x | _ -> (* you must choose at least one directory. *) Bell.ring (); raise Not_selected) (Listbox.curselection directory_listbox)) ^ "/" ^ !current_pattern) with _ -> () in bind directory_listbox ~events:[`Modified([`Double], `ButtonPressDetail 1)] ~breakable:true ~action; Listbox.configure directory_listbox ~selectmode: `Browse; directory_init_completion := add_completion directory_listbox action; pack [frm'; frm] ~fill: `X; (* filter *) pack [fl] ~side: `Top ~anchor: `W; pack [filter_entry] ~side: `Top ~fill: `X; (* directory + files *) pack [df] ~side: `Top ~fill: `X ~ipadx: 8; (* directory *) pack [dfl] ~side: `Left; pack [dfll] ~side: `Top ~anchor: `W; pack [dflf] ~side: `Top; pack [coe directory_listbox; coe directory_scrollbar] ~side: `Left ~fill: `Y; (* files *) pack [dfr] ~side: `Right; pack [dfrl] ~side: `Top ~anchor: `W; pack [dfrf] ~side: `Top; pack [coe filter_listbox; coe filter_scrollbar] ~side: `Left ~fill: `Y; (* selection *) pack [sl] ~side: `Top ~anchor: `W; pack [selection_entry] ~side: `Top ~fill: `X; (* create OK, Filter and Cancel buttons *) pack [cfrm'] ~fill: `X; pack [cfrm] ~fill: `X; pack [okb] ~side: `Left; pack [dumf] ~side: `Left ~expand: true; pack [flb] ~side: `Left; pack [dumf2] ~side: `Left ~expand: true; pack [ccb] ~side: `Left; configure deffilter; Tkwait.visibility tl; Grab.set tl; if sync then begin Tkwait.variable sync_var; proc !selected_files end; () mingw-ocaml/ocaml/otherlibs/labltk/jpf/balloon.mli0000644000175000017500000000236212124403241021635 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* easy balloon help facility *) open Widget val flag : bool ref val init : unit -> unit val put : on: 'a widget -> ms: int -> string -> unit mingw-ocaml/ocaml/otherlibs/labltk/jpf/jpf_font.ml0000644000175000017500000001541312124403241021644 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* find font information *) let debug = ref false let log s = if !debug then try prerr_endline s with _ -> () type ('s, 'i) xlfd = { (* some of them are currently not interesting for me *) mutable foundry: 's; mutable family: 's; mutable weight: 's; mutable slant: 's; mutable setWidth: 's; mutable addStyle: 's; mutable pixelSize: 'i; mutable pointSize: 'i; mutable resolutionX: 'i; mutable resolutionY: 'i; mutable spacing: 's; mutable averageWidth: 'i; mutable registry: 's; mutable encoding: 's } let copy xlfd = {xlfd with foundry= xlfd.foundry} let string_of_xlfd s i xlfd = let foundry= s xlfd.foundry and family= s xlfd.family and weight= s xlfd.weight and slant= s xlfd.slant and setWidth = s xlfd.setWidth and addStyle = s xlfd.addStyle and pixelSize= i xlfd.pixelSize and pointSize = i xlfd.pointSize and resolutionX = i xlfd.resolutionX and resolutionY = i xlfd.resolutionY and spacing= s xlfd.spacing and averageWidth = i xlfd.averageWidth and registry= s xlfd.registry and encoding = s xlfd.encoding in "-"^foundry^ "-"^family^ "-"^weight^ "-"^slant^ "-"^setWidth ^ "-"^addStyle ^ "-"^pixelSize^ "-"^pointSize ^ "-"^resolutionX ^ "-"^resolutionY ^ "-"^spacing^ "-"^averageWidth ^ "-"^registry^ "-"^encoding exception Parse_Xlfd_Failure of string let parse_xlfd xlfd_string = (* this must not be a pattern *) let split_str char_sep str = let len = String.length str in let rec split beg cur = if cur >= len then [String.sub str beg (len - beg)] else if char_sep (String.get str cur) then let nextw = succ cur in (String.sub str beg (cur - beg)) ::(split nextw nextw) else split beg (succ cur) in split 0 0 in match split_str (function '-' -> true | _ -> false) xlfd_string with | [ _; foundry; family; weight; slant; setWidth; addStyle; pixelSize; pointSize; resolutionX; resolutionY; spacing; averageWidth; registry; encoding ] -> { foundry= foundry; family= family; weight= weight; slant= slant; setWidth= setWidth; addStyle= addStyle; pixelSize= int_of_string pixelSize; pointSize= int_of_string pointSize; resolutionX= int_of_string resolutionX; resolutionY= int_of_string resolutionY; spacing= spacing; averageWidth= int_of_string averageWidth; registry= registry; encoding= encoding; } | _ -> raise (Parse_Xlfd_Failure xlfd_string) type valid_xlfd = (string, int) xlfd let string_of_valid_xlfd = string_of_xlfd (fun x -> x) string_of_int type pattern = (string option, int option) xlfd let empty_pattern = { foundry= None; family= None; weight= None; slant= None; setWidth= None; addStyle= None; pixelSize= None; pointSize= None; resolutionX= None; resolutionY= None; spacing= None; averageWidth= None; registry= None; encoding= None; } let string_of_pattern = let pat f = function Some x -> f x | None -> "*" in let pat_string = pat (fun x -> x) in let pat_int = pat string_of_int in string_of_xlfd pat_string pat_int let is_vector_font xlfd = (xlfd.pixelSize = 0 && xlfd.resolutionX = 0 && xlfd.resolutionY = 0) || xlfd.spacing <> "c" let list_fonts dispname pattern = let dispopt = match dispname with None -> "" | Some x -> "-display " ^ x in let result = List.map parse_xlfd (Shell.subshell ("xlsfonts "^dispopt^" -fn "^string_of_pattern pattern)) in if result = [] then raise Not_found else result let available_pixel_size_aux dispname pattern = (* return available pixel size without font resizing *) (* to obtain good result, *) (* the pattern should contain as many information as possible *) let pattern = copy pattern in pattern.pixelSize <- None; let xlfds = list_fonts dispname pattern in let pxszs = Hashtbl.create 107 in List.iter (fun xlfd -> Hashtbl.add pxszs xlfd.pixelSize xlfd) xlfds; pxszs let extract_size_font_hash tbl = let keys = ref [] in Hashtbl.iter (fun k _ -> if not (List.mem k !keys) then keys := k :: !keys) tbl; Sort.list (fun (k1,_) (k2,_) -> k1 < k2) (List.map (fun k -> k, Hashtbl.find_all tbl k) !keys) let available_pixel_size dispname pattern = let pxszs = available_pixel_size_aux dispname pattern in extract_size_font_hash pxszs let nearest_pixel_size dispname vector_ok pattern = (* find the font with the nearest pixel size *) log ("\n*** "^string_of_pattern pattern); let pxlsz = match pattern.pixelSize with None -> raise (Failure "invalid pixelSize pattern") | Some x -> x in let tbl = available_pixel_size_aux dispname pattern in let newtbl = Hashtbl.create 107 in Hashtbl.iter (fun s xlfd -> if vector_ok then if s = 0 then begin if is_vector_font xlfd then begin log (Printf.sprintf "%s is vector" (string_of_valid_xlfd xlfd)); xlfd.pixelSize <- pxlsz; Hashtbl.add newtbl pxlsz xlfd end end else Hashtbl.add newtbl s xlfd else if not (is_vector_font xlfd) && s <> 0 then Hashtbl.add newtbl s xlfd) tbl; let size_font_table = extract_size_font_hash newtbl in let diff = ref 10000 in let min = ref None in List.iter (fun (s,xlfds) -> let d = abs(s - pxlsz) in if d < !diff then begin min := Some (s,xlfds); diff := d end) size_font_table; (* if it contains more than one font, just return the first *) match !min with | None -> raise Not_found | Some(s, xlfds) -> log (Printf.sprintf "Size %d is selected" s); List.iter (fun xlfd -> log (string_of_valid_xlfd xlfd)) xlfds; List.hd xlfds mingw-ocaml/ocaml/otherlibs/labltk/jpf/shell.ml0000644000175000017500000000323412124403241021144 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Unix (************************************************************* Subshell call *) let subshell cmd = let r,w = pipe () in match fork () with 0 -> close r; dup2 w stdout; close stderr; execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] | id -> close w; let rc = in_channel_of_descr r in let rec it () = try let x = input_line rc in x:: it () with _ -> [] in let answer = it() in close_in rc; (* because of finalize_channel *) let _ = waitpid [] id in answer mingw-ocaml/ocaml/otherlibs/labltk/jpf/shell.mli0000644000175000017500000000217312124403241021316 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) val subshell : string -> string list mingw-ocaml/ocaml/otherlibs/labltk/jpf/balloon.ml0000644000175000017500000000723512124403241021470 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) open StdLabels (* easy balloon help facility *) open Tk open Widget open Protocol open Support (* switch -- if you do not want balloons, set false *) let flag = ref true let debug = ref false (* We assume we have at most one popup label at a time *) let topw = ref default_toplevel and popupw = ref (Obj.magic dummy : message widget) let configure_cursor w cursor = (* DDDDDDDDDIIIIIIIRRRRRRRRTTTTTTTTYYYYYYY *) Protocol.tkCommand [| TkToken (name w); TkToken "configure"; TkToken "-cursor"; TkToken cursor |] let put ~on: w ~ms: millisec mesg = let t = ref None in let cursor = ref "" in let reset () = begin match !t with Some t -> Timer.remove t | _ -> () end; (* if there is a popup label, unmap it *) if Winfo.exists !topw && Wm.state !topw <> "withdrawn" then begin Wm.withdraw !topw; if Winfo.exists w then configure_cursor w !cursor end and set ev = if !flag then t := Some (Timer.add ~ms: millisec ~callback: (fun () -> t := None; if !debug then prerr_endline ("Balloon: " ^ Widget.name w); update_idletasks(); Message.configure !popupw ~text: mesg; raise_window !topw; Wm.geometry_set !topw (* 9 & 8 are some kind of magic... *) ("+"^(string_of_int (ev.ev_RootX + 9))^ "+"^(string_of_int (ev.ev_RootY + 8))); Wm.deiconify !topw; cursor := cget w `Cursor; configure_cursor w "hand2")) in List.iter [[`Leave]; [`ButtonPress]; [`ButtonRelease]; [`Destroy]; [`KeyPress]; [`KeyRelease]] ~f:(fun events -> bind w ~events ~extend:true ~action:(fun _ -> reset ())); List.iter [[`Enter]; [`Motion]] ~f: begin fun events -> bind w ~events ~extend:true ~fields:[`RootX; `RootY] ~action:(fun ev -> reset (); set ev) end let init () = let t = Hashtbl.create 101 in Protocol.add_destroy_hook (fun w -> Hashtbl.remove t w); topw := Toplevel.create default_toplevel; Wm.overrideredirect_set !topw true; Wm.withdraw !topw; popupw := Message.create !topw ~name: "balloon" ~background: (`Color "yellow") ~aspect: 300; pack [!popupw]; bind_class "all" ~events: [`Enter] ~extend:true ~fields:[`Widget] ~action: begin fun w -> try Hashtbl.find t w.ev_Widget with Not_found -> Hashtbl.add t w.ev_Widget (); let x = Option.get w.ev_Widget ~name: "balloon" ~clas: "Balloon" in if x <> "" then put ~on: w.ev_Widget ~ms: 1000 x end mingw-ocaml/ocaml/otherlibs/labltk/jpf/balloontest.ml0000644000175000017500000000257212124403241022367 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) open Tk open Widget open Balloon open Protocol let _ = let t = openTk () in Balloon.init (); let b = Button.create t ~text: "hello" in Button.configure b ~command: (fun () -> destroy b); pack [b]; Balloon.put ~on: b ~ms: 1000 "Balloon"; Printexc.catch mainLoop () mingw-ocaml/ocaml/otherlibs/labltk/jpf/fileselect.mli0000644000175000017500000000316312124403241022326 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* This file selecter works only under the OS with the full unix support. For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *) open Support val f : title:string -> action:(string list -> unit) -> filter:string -> file:string -> multi:bool -> sync:bool -> unit (* action [] means canceled if multi select is false, then the list is null or a singleton *) (* multi select if true then more than one file are selectable *) (* sync it if true then in synchronous mode *) mingw-ocaml/ocaml/otherlibs/labltk/Makefile.nt0000644000175000017500000000471012124403241021004 0ustar tootstoots####################################################################### # # # MLTk, Tcl/Tk interface of OCaml # # # # Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # # projet Cristal, INRIA Rocquencourt # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 2000 Institut National de Recherche en Informatique et # # en Automatique and Kyoto University. All rights reserved. # # This file is distributed under the terms of the GNU Library # # General Public License, with the special exception on linking # # described in file LICENSE found in the OCaml source tree. # # # ####################################################################### # Top Makefile for LablTk include ../../config/Makefile SUBDIRS=compiler support lib labltk camltk jpf frx examples_labltk examples_camltk browser all: cd support ; $(MAKEREC) cd compiler ; $(MAKEREC) cd labltk ; $(MAKECMD) -f Makefile.gen.nt cd labltk ; $(MAKEREC) cd camltk ; $(MAKECMD) -f Makefile.gen.nt cd camltk ; $(MAKEREC) cd lib ; $(MAKEREC) cd jpf ; $(MAKEREC) cd frx ; $(MAKEREC) cd browser ; $(MAKEREC) allopt: cd support ; $(MAKEREC) opt cd labltk ; $(MAKECMD) -f Makefile.gen.nt cd labltk ; $(MAKEREC) opt cd camltk ; $(MAKECMD) -f Makefile.gen.nt cd camltk ; $(MAKEREC) opt cd lib ; $(MAKEREC) opt cd jpf ; $(MAKEREC) opt cd frx ; $(MAKEREC) opt .PHONY: examples_labltk examples_camltk examples: examples_labltk examples_camltk examples_labltk: cd examples_labltk; $(MAKE) all examples_camltk: cd examples_camltk; $(MAKE) all install: cd labltk ; $(MAKEREC) install cd camltk ; $(MAKEREC) install cd lib ; $(MAKEREC) install cd support ; $(MAKEREC) install cd compiler ; $(MAKEREC) install cd jpf ; $(MAKEREC) install cd frx ; $(MAKEREC) install cd browser ; $(MAKEREC) install installopt: cd support ; $(MAKEREC) installopt cd labltk ; $(MAKEREC) installopt cd camltk ; $(MAKEREC) installopt cd lib ; $(MAKEREC) installopt cd jpf ; $(MAKEREC) installopt cd frx ; $(MAKEREC) installopt partialclean clean: for d in $(SUBDIRS); do $(MAKEREC) -C $$d clean; done mingw-ocaml/ocaml/otherlibs/labltk/browser/0000755000175000017500000000000012124403241020405 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/browser/jg_toplevel.ml0000644000175000017500000000237312124403241023256 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Tk let titled ?iconname title = let iconname = match iconname with None -> title | Some s -> s in let tl = Toplevel.create Widget.default_toplevel in Wm.title_set tl title; Wm.iconname_set tl iconname; Wm.group_set tl ~leader: Widget.default_toplevel; tl mingw-ocaml/ocaml/otherlibs/labltk/browser/.ignore0000644000175000017500000000003712124403241021671 0ustar tootstootsocamlbrowser dummy.mli help.ml mingw-ocaml/ocaml/otherlibs/labltk/browser/lexical.mli0000644000175000017500000000214512124403241022533 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Widget val init_tags : text widget -> unit val tag : ?start:Tk.textIndex -> ?stop:Tk.textIndex -> text widget -> unit mingw-ocaml/ocaml/otherlibs/labltk/browser/searchid.mli0000644000175000017500000000330312124403241022671 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) val start_env : Env.t ref val module_list : string list ref val longident_of_path : Path.t ->Longident.t type pkind = Pvalue | Ptype | Plabel | Pconstructor | Pmodule | Pmodtype | Pclass | Pcltype val string_of_kind : pkind -> string exception Error of int * int val search_string_type : string -> mode:[`Exact|`Included] -> (Longident.t * pkind) list val search_pattern_symbol : string -> (Longident.t * pkind) list val search_string_symbol : string -> (Longident.t * pkind) list val search_structure : Parsetree.structure -> name:string -> kind:pkind -> prefix:string list -> int val search_signature : Parsetree.signature -> name:string -> kind:pkind -> prefix:string list -> int mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_memo.mli0000644000175000017500000000220312124403241022522 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) val fast : f:('a -> 'b) -> 'a -> 'b (* "fast" memoizer: uses a List.assq like function *) (* Good for a smallish number of keys, phisically equal *) mingw-ocaml/ocaml/otherlibs/labltk/browser/setpath.ml0000644000175000017500000001347312124403241022417 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open StdLabels open Tk (* Listboxes *) let update_hooks = ref [] let add_update_hook f = update_hooks := f :: !update_hooks let exec_update_hooks () = update_hooks := List.filter !update_hooks ~f: begin fun f -> try f (); true with Protocol.TkError _ -> false end let set_load_path l = Config.load_path := l; exec_update_hooks () let get_load_path () = !Config.load_path let renew_dirs box ~var ~dir = Textvariable.set var dir; Listbox.delete box ~first:(`Num 0) ~last:`End; Listbox.insert box ~index:`End ~texts:(Useunix.get_directories_in_files ~path:dir (Useunix.get_files_in_directory dir)); Jg_box.recenter box ~index:(`Num 0) let renew_path box = Listbox.delete box ~first:(`Num 0) ~last:`End; Listbox.insert box ~index:`End ~texts:!Config.load_path; Jg_box.recenter box ~index:(`Num 0) let add_to_path ~dirs ?(base="") box = let dirs = if base = "" then dirs else if dirs = [] then [base] else List.map dirs ~f: begin function "." -> base | ".." -> Filename.dirname base | x -> Filename.concat base x end in set_load_path (dirs @ List.fold_left dirs ~init:(get_load_path ()) ~f:(fun acc x -> List2.exclude x acc)) let remove_path box ~dirs = set_load_path (List.fold_left dirs ~init:(get_load_path ()) ~f:(fun acc x -> List2.exclude x acc)) (* main function *) let f ~dir = let current_dir = ref dir in let tl = Jg_toplevel.titled "Edit Load Path" in Jg_bind.escape_destroy tl; let var_dir = Textvariable.create ~on:tl () in let caplab = Label.create tl ~text:"Path" and dir_name = Entry.create tl ~textvariable:var_dir and browse = Frame.create tl in let dirs = Frame.create browse and path = Frame.create browse in let dirframe, dirbox, dirsb = Jg_box.create_with_scrollbar dirs and pathframe, pathbox, pathsb = Jg_box.create_with_scrollbar path in add_update_hook (fun () -> renew_path pathbox); Listbox.configure pathbox ~width:40 ~selectmode:`Multiple; Listbox.configure dirbox ~selectmode:`Multiple; Jg_box.add_completion dirbox ~action: begin fun index -> begin match Listbox.get dirbox ~index with "." -> () | ".." -> current_dir := Filename.dirname !current_dir | x -> current_dir := !current_dir ^ "/" ^ x end; renew_dirs dirbox ~var:var_dir ~dir:!current_dir; Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End end; Jg_box.add_completion pathbox ~action: begin fun index -> current_dir := Listbox.get pathbox ~index; renew_dirs dirbox ~var:var_dir ~dir:!current_dir end; bind dir_name ~events:[`KeyPressDetail"Return"] ~action:(fun _ -> let dir = Textvariable.get var_dir in if Useunix.is_directory dir then begin current_dir := dir; renew_dirs dirbox ~var:var_dir ~dir end); (* Avoid space being used by the completion mechanism *) let bind_space_toggle lb = bind lb ~events:[`KeyPressDetail "space"] ~extend:true ~action:ignore in bind_space_toggle dirbox; bind_space_toggle pathbox; let add_paths _ = add_to_path pathbox ~base:!current_dir ~dirs:(List.map (Listbox.curselection dirbox) ~f:(fun x -> Listbox.get dirbox ~index:x)); Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End and remove_paths _ = remove_path pathbox ~dirs:(List.map (Listbox.curselection pathbox) ~f:(fun x -> Listbox.get pathbox ~index:x)) in bind dirbox ~events:[`KeyPressDetail "Insert"] ~action:add_paths; bind pathbox ~events:[`KeyPressDetail "Delete"] ~action:remove_paths; let dirlab = Label.create dirs ~text:"Directories" and pathlab = Label.create path ~text:"Load path" and addbutton = Button.create dirs ~text:"Add to path" ~command:add_paths and pathbuttons = Frame.create path in let removebutton = Button.create pathbuttons ~text:"Remove from path" ~command:remove_paths and ok = Jg_button.create_destroyer tl ~parent:pathbuttons in renew_dirs dirbox ~var:var_dir ~dir:!current_dir; renew_path pathbox; pack [dirsb] ~side:`Right ~fill:`Y; pack [dirbox] ~side:`Left ~fill:`Y ~expand:true; pack [pathsb] ~side:`Right ~fill:`Y; pack [pathbox] ~side:`Left ~fill:`Both ~expand:true; pack [dirlab] ~side:`Top ~anchor:`W ~padx:10; pack [addbutton] ~side:`Bottom ~fill:`X; pack [dirframe] ~fill:`Y ~expand:true; pack [pathlab] ~side:`Top ~anchor:`W ~padx:10; pack [removebutton; ok] ~side:`Left ~fill:`X ~expand:true; pack [pathbuttons] ~fill:`X ~side:`Bottom; pack [pathframe] ~fill:`Both ~expand:true; pack [dirs] ~side:`Left ~fill:`Y; pack [path] ~side:`Right ~fill:`Both ~expand:true; pack [caplab] ~side:`Top ~anchor:`W ~padx:10; pack [dir_name] ~side:`Top ~anchor:`W ~fill:`X; pack [browse] ~side:`Bottom ~expand:true ~fill:`Both; tl let set ~dir = ignore (f ~dir);; mingw-ocaml/ocaml/otherlibs/labltk/browser/winmain.c0000644000175000017500000000311012124403241022206 0ustar tootstoots/*************************************************************************/ /* */ /* OCaml LablTk library */ /* */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file ../../../LICENSE. */ /* */ /*************************************************************************/ /* $Id$ */ #include #include #include #include /*CAMLextern int __argc; */ /* CAMLextern char **__argv; */ /* CAMLextern void caml_expand_command_line(int * argcp, char *** argvp); */ /* extern void caml_main (char **); */ int WINAPI WinMain(HINSTANCE h, HINSTANCE HPrevInstance, LPSTR lpCmdLine, int nCmdShow) { char exe_name[1024]; char * argv[2]; GetModuleFileName(NULL, exe_name, sizeof(exe_name) - 1); exe_name[sizeof(exe_name) - 1] = '0'; argv[0] = exe_name; argv[1] = NULL; caml_main(argv); sys_exit(Val_int(0)); return 0; } mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_button.ml0000644000175000017500000000233512124403241022735 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Tk let create_destroyer ~parent ?(text="Ok") tl = Button.create parent ~text ~command:(fun () -> destroy tl) let add_destroyer ?text tl = let b = create_destroyer tl ~parent:tl ?text in pack [b] ~side:`Bottom ~fill:`X; b mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_text.ml0000644000175000017500000001005112124403241022400 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open StdLabels open Tk open Jg_tk let get_all tw = Text.get tw ~start:tstart ~stop:(tposend 1) let tag_and_see tw ~tag ~start ~stop = Text.tag_remove tw ~start:(tpos 0) ~stop:tend ~tag; Text.tag_add tw ~start ~stop ~tag; try Text.see tw ~index:(`Tagfirst tag, []); Text.mark_set tw ~mark:"insert" ~index:(`Tagfirst tag, []) with Protocol.TkError _ -> () let output tw ~buf ~pos ~len = Text.insert tw ~index:tend ~text:(String.sub buf ~pos ~len) let add_scrollbar tw = let sb = Scrollbar.create (Winfo.parent tw) ~command:(Text.yview tw) in Text.configure tw ~yscrollcommand:(Scrollbar.set sb); sb let create_with_scrollbar parent = let frame = Frame.create parent in let tw = Text.create frame in frame, tw, add_scrollbar tw let goto_tag tw ~tag = let index = (`Tagfirst tag, []) in try Text.see tw ~index; Text.mark_set tw ~index ~mark:"insert" with Protocol.TkError _ -> () let search_string tw = let tl = Jg_toplevel.titled "Search" in Wm.transient_set tl ~master:(Winfo.toplevel tw); let fi = Frame.create tl and fd = Frame.create tl and fm = Frame.create tl and buttons = Frame.create tl and direction = Textvariable.create ~on:tl () and mode = Textvariable.create ~on:tl () and count = Textvariable.create ~on:tl () in let label = Label.create fi ~text:"Pattern:" and text = Entry.create fi ~width:20 and back = Radiobutton.create fd ~variable:direction ~text:"Backwards" ~value:"backward" and forw = Radiobutton.create fd ~variable:direction ~text:"Forwards" ~value:"forward" and exact = Radiobutton.create fm ~variable:mode ~text:"Exact" ~value:"exact" and nocase = Radiobutton.create fm ~variable:mode ~text:"No case" ~value:"nocase" and regexp = Radiobutton.create fm ~variable:mode ~text:"Regexp" ~value:"regexp" in let search = Button.create buttons ~text:"Search" ~command: begin fun () -> try let pattern = Entry.get text in let dir, ofs = match Textvariable.get direction with "forward" -> `Forwards, 1 | "backward" -> `Backwards, -1 | _ -> assert false and mode = match Textvariable.get mode with "exact" -> [`Exact] | "nocase" -> [`Nocase] | "regexp" -> [`Regexp] | _ -> [] in let ndx = Text.search tw ~pattern ~switches:([dir;`Count count] @ mode) ~start:(`Mark "insert", [`Char ofs]) in tag_and_see tw ~tag:"sel" ~start:(ndx,[]) ~stop:(ndx,[`Char(int_of_string (Textvariable.get count))]) with Invalid_argument _ -> () end and ok = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in Focus.set text; Jg_bind.return_invoke text ~button:search; Jg_bind.escape_destroy tl; Textvariable.set direction "forward"; Textvariable.set mode "nocase"; pack [label] ~side:`Left; pack [text] ~side:`Right ~fill:`X ~expand:true; pack [back; forw] ~side:`Left; pack [exact; nocase; regexp] ~side:`Left; pack [search; ok] ~side:`Left ~fill:`X ~expand:true; pack [fi; fd; fm; buttons] ~side:`Top ~fill:`X mingw-ocaml/ocaml/otherlibs/labltk/browser/editor.ml0000644000175000017500000006146112124403241022235 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open StdLabels open Tk open Parsetree open Location open Jg_tk open Mytypes let lex_on_load = ref true and type_on_load = ref false let compiler_preferences master = let tl = Jg_toplevel.titled "Compiler" in Wm.transient_set tl ~master; let mk_chkbutton ~text ~ref ~invert = let variable = Textvariable.create ~on:tl () in if (if invert then not !ref else !ref) then Textvariable.set variable "1"; Checkbutton.create tl ~text ~variable, (fun () -> ref := Textvariable.get variable = (if invert then "0" else "1")) in let use_pp = ref (!Clflags.preprocessor <> None) in let chkbuttons, setflags = List.split (List.map ~f:(fun (text, ref, invert) -> mk_chkbutton ~text ~ref ~invert) [ "No pervasives", Clflags.nopervasives, false; "No warnings", Typecheck.nowarnings, false; "No labels", Clflags.classic, false; "Recursive types", Clflags.recursive_types, false; "Lex on load", lex_on_load, false; "Type on load", type_on_load, false; "Preprocessor", use_pp, false ]) in let pp_command = Entry.create tl (* ~state:(if !use_pp then `Normal else`Disabled) *) in begin match !Clflags.preprocessor with None -> () | Some pp -> Entry.insert pp_command ~index:(`Num 0) ~text:pp end; let buttons = Frame.create tl in let ok = Button.create buttons ~text:"Ok" ~padx:20 ~command: begin fun () -> List.iter ~f:(fun f -> f ()) setflags; Clflags.preprocessor := if !use_pp then Some (Entry.get pp_command) else None; destroy tl end and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in pack chkbuttons ~side:`Top ~anchor:`W; pack [pp_command] ~side:`Top ~anchor:`E; pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true; pack [buttons] ~side:`Bottom ~fill:`X let rec exclude txt = function [] -> [] | x :: l -> if txt.number = x.number then l else x :: exclude txt l let goto_line tw = let tl = Jg_toplevel.titled "Go to" in Wm.transient_set tl ~master:(Winfo.toplevel tw); Jg_bind.escape_destroy tl; let ef = Frame.create tl in let fl = Frame.create ef and fi = Frame.create ef in let ll = Label.create fl ~text:"Line ~number:" and il = Entry.create fi ~width:10 and lc = Label.create fl ~text:"Col ~number:" and ic = Entry.create fi ~width:10 and get_int ew = try int_of_string (Entry.get ew) with Failure "int_of_string" -> 0 in let buttons = Frame.create tl in let ok = Button.create buttons ~text:"Ok" ~command: begin fun () -> let l = get_int il and c = get_int ic in Text.mark_set tw ~mark:"insert" ~index:(`Linechar (l,0), [`Char c]); Text.see tw ~index:(`Mark "insert", []); destroy tl end and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in Focus.set il; List.iter [il; ic] ~f: begin fun w -> Jg_bind.enter_focus w; Jg_bind.return_invoke w ~button:ok end; pack [ll; lc] ~side:`Top ~anchor:`W; pack [il; ic] ~side:`Top ~fill:`X ~expand:true; pack [fl; fi] ~side:`Left ~fill:`X ~expand:true; pack [ok; cancel] ~side:`Left ~fill:`X ~expand:true; pack [ef; buttons] ~side:`Top ~fill:`X ~expand:true let select_shell txt = let shells = Shell.get_all () in let shells = List.sort shells ~cmp:compare in let tl = Jg_toplevel.titled "Select Shell" in Jg_bind.escape_destroy tl; Wm.transient_set tl ~master:(Winfo.toplevel txt.tw); let label = Label.create tl ~text:"Send to:" and box = Listbox.create tl and frame = Frame.create tl in Jg_bind.enter_focus box; let cancel = Jg_button.create_destroyer tl ~parent:frame ~text:"Cancel" and ok = Button.create frame ~text:"Ok" ~command: begin fun () -> try let name = Listbox.get box ~index:`Active in txt.shell <- Some (name, List.assoc name shells); destroy tl with Not_found -> txt.shell <- None; destroy tl end in Listbox.insert box ~index:`End ~texts:(List.map ~f:fst shells); Listbox.configure box ~height:(List.length shells); bind box ~events:[`KeyPressDetail"Return"] ~breakable:true ~action:(fun _ -> Button.invoke ok; break ()); bind box ~events:[`Modified([`Double],`ButtonPressDetail 1)] ~breakable:true ~fields:[`MouseX;`MouseY] ~action:(fun ev -> Listbox.activate box ~index:(`Atxy (ev.ev_MouseX, ev.ev_MouseY)); Button.invoke ok; break ()); pack [label] ~side:`Top ~anchor:`W; pack [box] ~side:`Top ~fill:`Both; pack [frame] ~side:`Bottom ~fill:`X ~expand:true; pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true open Parser let send_phrase txt = if txt.shell = None then begin match Shell.get_all () with [] -> () | [sh] -> txt.shell <- Some sh | l -> select_shell txt end; match txt.shell with None -> () | Some (_,sh) -> try let i1,i2 = Text.tag_nextrange txt.tw ~tag:"sel" ~start:tstart in let phrase = Text.get txt.tw ~start:(i1,[]) ~stop:(i2,[]) in sh#send phrase; if Str.string_match (Str.regexp ";;") phrase 0 then sh#send "\n" else sh#send ";;\n" with Not_found | Protocol.TkError _ -> let text = Text.get txt.tw ~start:tstart ~stop:tend in let buffer = Lexing.from_string text in let start = ref 0 and block_start = ref [] and pend = ref (-1) and after = ref false in while !pend = -1 do let token = Lexer.token buffer in let pos = if token = SEMISEMI then Lexing.lexeme_end buffer else Lexing.lexeme_start buffer in let bol = (pos = 0) || text.[pos-1] = '\n' in if not !after && Text.compare txt.tw ~index:(tpos pos) ~op:(if bol then `Gt else `Ge) ~index:(`Mark"insert",[]) then begin after := true; let anon, real = List.partition !block_start ~f:(fun x -> x = -1) in block_start := anon; if real <> [] then start := List.hd real; end; match token with CLASS | EXTERNAL | EXCEPTION | FUNCTOR | LET | MODULE | OPEN | TYPE | VAL | SHARP when bol -> if !block_start = [] then if !after then pend := pos else start := pos else block_start := pos :: List.tl !block_start | SEMISEMI -> if !block_start = [] then if !after then pend := Lexing.lexeme_start buffer else start := pos else block_start := pos :: List.tl !block_start | BEGIN | OBJECT -> block_start := -1 :: !block_start | STRUCT | SIG -> block_start := Lexing.lexeme_end buffer :: !block_start | END -> if !block_start = [] then if !after then pend := pos else () else block_start := List.tl !block_start | EOF -> pend := pos | _ -> () done; let phrase = String.sub text ~pos:!start ~len:(!pend - !start) in sh#send phrase; sh#send ";;\n" let search_pos_window txt ~x ~y = if txt.type_info = [] && txt.psignature = [] then () else let `Linechar (l, c) = Text.index txt.tw ~index:(`Atxy(x,y), []) in let text = Jg_text.get_all txt.tw in let pos = Searchpos.lines_to_chars l ~text + c in try if txt.type_info <> [] then begin match Searchpos.search_pos_info txt.type_info ~pos with [] -> () | (kind, env, loc) :: _ -> Searchpos.view_type kind ~env end else begin match Searchpos.search_pos_signature txt.psignature ~pos ~env:!Searchid.start_env with [] -> () | ((kind, lid), env, loc) :: _ -> Searchpos.view_decl lid ~kind ~env end with Not_found -> () let search_pos_menu txt ~x ~y = if txt.type_info = [] && txt.psignature = [] then () else let `Linechar (l, c) = Text.index txt.tw ~index:(`Atxy(x,y), []) in let text = Jg_text.get_all txt.tw in let pos = Searchpos.lines_to_chars l ~text + c in try if txt.type_info <> [] then begin match Searchpos.search_pos_info txt.type_info ~pos with [] -> () | (kind, env, loc) :: _ -> let menu = Searchpos.view_type_menu kind ~env ~parent:txt.tw in let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in Menu.popup menu ~x ~y end else begin match Searchpos.search_pos_signature txt.psignature ~pos ~env:!Searchid.start_env with [] -> () | ((kind, lid), env, loc) :: _ -> let menu = Searchpos.view_decl_menu lid ~kind ~env ~parent:txt.tw in let x = x + Winfo.rootx txt.tw and y = y + Winfo.rooty txt.tw - 10 in Menu.popup menu ~x ~y end with Not_found -> () let string_width s = let width = ref 0 in for i = 0 to String.length s - 1 do if s.[i] = '\t' then width := (!width / 8 + 1) * 8 else incr width done; !width let indent_line = let ins = `Mark"insert" and reg = Str.regexp "[ \t]*" in fun tw -> let `Linechar(l,c) = Text.index tw ~index:(ins,[]) and line = Text.get tw ~start:(ins,[`Linestart]) ~stop:(ins,[`Lineend]) in ignore (Str.string_match reg line 0); let len = Str.match_end () in if len < c then Text.insert tw ~index:(ins,[]) ~text:"\t" else let width = string_width (Str.matched_string line) in Text.mark_set tw ~mark:"insert" ~index:(ins,[`Linestart;`Char len]); let indent = if l <= 1 then 2 else let previous = Text.get tw ~start:(ins,[`Line(-1);`Linestart]) ~stop:(ins,[`Line(-1);`Lineend]) in ignore (Str.string_match reg previous 0); let previous = Str.matched_string previous in let width_previous = string_width previous in if width_previous <= width then 2 else width_previous - width in Text.insert tw ~index:(ins,[]) ~text:(String.make indent ' ') (* The editor class *) class editor ~top ~menus = object (self) val file_menu = new Jg_menu.c "File" ~parent:menus val edit_menu = new Jg_menu.c "Edit" ~parent:menus val compiler_menu = new Jg_menu.c "Compiler" ~parent:menus val module_menu = new Jg_menu.c "Modules" ~parent:menus val window_menu = new Jg_menu.c "Windows" ~parent:menus initializer Menu.add_checkbutton menus ~state:`Disabled ~onvalue:"modified" ~offvalue:"unchanged" val mutable current_dir = Unix.getcwd () val mutable error_messages = [] val mutable windows = [] val mutable current_tw = Text.create top val vwindow = Textvariable.create ~on:top () val mutable window_counter = 0 method has_window name = List.exists windows ~f:(fun x -> x.name = name) method reset_window_menu = Menu.delete window_menu#menu ~first:(`Num 0) ~last:`End; List.iter (List.sort windows ~cmp: (fun w1 w2 -> compare (Filename.basename w1.name) (Filename.basename w2.name))) ~f: begin fun txt -> Menu.add_radiobutton window_menu#menu ~label:(Filename.basename txt.name) ~variable:vwindow ~value:txt.number ~command:(fun () -> self#set_edit txt) end method set_file_name txt = Menu.configure_checkbutton menus `Last ~label:(Filename.basename txt.name) ~variable:txt.modified method set_edit txt = if windows <> [] then Pack.forget [(List.hd windows).frame]; windows <- txt :: exclude txt windows; self#reset_window_menu; current_tw <- txt.tw; self#set_file_name txt; Textvariable.set vwindow txt.number; Text.yview txt.tw ~scroll:(`Page 0); pack [txt.frame] ~fill:`Both ~expand:true ~side:`Bottom method new_window name = let tl, tw, sb = Jg_text.create_with_scrollbar top in Text.configure tw ~background:`White; Jg_bind.enter_focus tw; window_counter <- window_counter + 1; let txt = { name = name; tw = tw; frame = tl; number = string_of_int window_counter; modified = Textvariable.create ~on:tw (); shell = None; structure = []; type_info = []; signature = []; psignature = [] } in let control c = Char.chr (Char.code c - 96) in bind tw ~events:[`Modified([`Alt], `KeyPress)] ~action:ignore; bind tw ~events:[`KeyPress] ~fields:[`Char] ~action:(fun ev -> if ev.ev_Char <> "" && (ev.ev_Char.[0] >= ' ' || List.mem ev.ev_Char.[0] (List.map ~f:control ['d'; 'h'; 'i'; 'k'; 'o'; 't'; 'w'; 'y'])) then Textvariable.set txt.modified "modified"); bind tw ~events:[`KeyPressDetail"Tab"] ~breakable:true ~action:(fun _ -> indent_line tw; Textvariable.set txt.modified "modified"; break ()); bind tw ~events:[`Modified([`Control],`KeyPressDetail"k")] ~action:(fun _ -> let text = Text.get tw ~start:(`Mark"insert",[]) ~stop:(`Mark"insert",[`Lineend]) in ignore (Str.string_match (Str.regexp "[ \t]*") text 0); if Str.match_end () <> String.length text then begin Clipboard.clear (); Clipboard.append ~data:text () end); bind tw ~events:[`KeyRelease] ~fields:[`Char] ~action:(fun ev -> if ev.ev_Char <> "" then Lexical.tag tw ~start:(`Mark"insert", [`Linestart]) ~stop:(`Mark"insert", [`Lineend])); bind tw ~events:[`Motion] ~action:(fun _ -> Focus.set tw); bind tw ~events:[`ButtonPressDetail 2] ~action:(fun _ -> Textvariable.set txt.modified "modified"; Lexical.tag txt.tw ~start:(`Mark"insert", [`Linestart]) ~stop:(`Mark"insert", [`Lineend])); bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)] ~fields:[`MouseX;`MouseY] ~action:(fun ev -> search_pos_window txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY); bind tw ~events:[`ButtonPressDetail 3] ~fields:[`MouseX;`MouseY] ~action:(fun ev -> search_pos_menu txt ~x:ev.ev_MouseX ~y:ev.ev_MouseY); pack [sb] ~fill:`Y ~side:`Right; pack [tw] ~fill:`Both ~expand:true ~side:`Left; self#set_edit txt; Textvariable.set txt.modified "unchanged"; Lexical.init_tags txt.tw method clear_errors () = Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend; List.iter error_messages ~f:(fun tl -> try destroy tl with Protocol.TkError _ -> ()); error_messages <- [] method typecheck () = self#clear_errors (); error_messages <- Typecheck.f (List.hd windows) method lex () = List.iter [ Widget.default_toplevel; top ] ~f:(Toplevel.configure ~cursor:(`Xcursor "watch")); Text.configure current_tw ~cursor:(`Xcursor "watch"); ignore (Timer.add ~ms:1 ~callback: begin fun () -> Text.tag_remove current_tw ~tag:"error" ~start:tstart ~stop:tend; Lexical.tag current_tw; Text.configure current_tw ~cursor:(`Xcursor "xterm"); List.iter [ Widget.default_toplevel; top ] ~f:(Toplevel.configure ~cursor:(`Xcursor "")) end) method save_text ?name:l txt = let l = match l with None -> [txt.name] | Some l -> l in if l = [] then () else let name = List.hd l in if txt.name <> name then current_dir <- Filename.dirname name; try if Sys.file_exists name then if txt.name = name then begin let backup = name ^ "~" in if Sys.file_exists backup then Sys.remove backup; try Sys.rename name backup with Sys_error _ -> () end else begin match Jg_message.ask ~master:top ~title:"Save" ("File `" ^ name ^ "' exists. Overwrite it?") with `Yes -> Sys.remove name | `No -> raise (Sys_error "") | `Cancel -> raise Exit end; let file = open_out name in let text = Text.get txt.tw ~start:tstart ~stop:(tposend 1) in output_string file text; close_out file; txt.name <- name; self#set_file_name txt with Sys_error _ -> Jg_message.info ~master:top ~title:"Error" ("Could not save `" ^ name ^ "'.") | Exit -> () method load_text l = if l = [] then () else let name = List.hd l in try let index = try self#set_edit (List.find windows ~f:(fun x -> x.name = name)); let txt = List.hd windows in if Textvariable.get txt.modified = "modified" then begin match Jg_message.ask ~master:top ~title:"Open" ("`" ^ Filename.basename txt.name ^ "' modified. Save it?") with `Yes -> self#save_text txt | `No -> () | `Cancel -> raise Exit end; Textvariable.set txt.modified "unchanged"; (Text.index current_tw ~index:(`Mark"insert", []), []) with Not_found -> self#new_window name; tstart in current_dir <- Filename.dirname name; let file = open_in name and tw = current_tw and len = ref 0 and buf = String.create 4096 in Text.delete tw ~start:tstart ~stop:tend; while len := input file buf 0 4096; !len > 0 do Jg_text.output tw ~buf ~pos:0 ~len:!len done; close_in file; Text.mark_set tw ~mark:"insert" ~index; Text.see tw ~index; if Filename.check_suffix name ".ml" || Filename.check_suffix name ".mli" then begin if !lex_on_load then self#lex (); if !type_on_load then self#typecheck () end with Sys_error _ | Exit -> () method close_window txt = try if Textvariable.get txt.modified = "modified" then begin match Jg_message.ask ~master:top ~title:"Close" ("`" ^ Filename.basename txt.name ^ "' modified. Save it?") with `Yes -> self#save_text txt | `No -> () | `Cancel -> raise Exit end; windows <- exclude txt windows; if windows = [] then self#new_window (current_dir ^ "/untitled") else self#set_edit (List.hd windows); destroy txt.frame with Exit -> () method open_file () = Fileselect.f ~title:"Open File" ~action:self#load_text ~dir:current_dir ~filter:("*.{ml,mli}") ~sync:true () method save_file () = self#save_text (List.hd windows) method close_file () = self#close_window (List.hd windows) method quit ?(cancel=true) () = try List.iter windows ~f: begin fun txt -> if Textvariable.get txt.modified = "modified" then match Jg_message.ask ~master:top ~title:"Quit" ~cancel ("`" ^ Filename.basename txt.name ^ "' modified. Save it?") with `Yes -> self#save_text txt | `No -> () | `Cancel -> raise Exit end; bind top ~events:[`Destroy]; destroy top with Exit -> () method reopen ~file ~pos = if not (Winfo.ismapped top) then Wm.deiconify top; match file with None -> () | Some file -> self#load_text [file]; Text.mark_set current_tw ~mark:"insert" ~index:(tpos pos); try let index = Text.search current_tw ~switches:[`Backwards] ~pattern:"*)" ~start:(tpos pos) ~stop:(tpos pos ~modi:[`Line(-1)]) in let index = Text.search current_tw ~switches:[`Backwards] ~pattern:"(*" ~start:(index,[]) ~stop:(tpos pos ~modi:[`Line(-20)]) in let s = Text.get current_tw ~start:(index,[`Line(-1);`Linestart]) ~stop:(index,[`Line(-1);`Lineend]) in for i = 0 to String.length s - 1 do match s.[i] with '\t'|' ' -> () | _ -> raise Not_found done; Text.yview_index current_tw ~index:(index,[`Line(-1)]) with _ -> Text.yview_index current_tw ~index:(tpos pos ~modi:[`Line(-2)]) initializer (* Create a first window *) self#new_window (current_dir ^ "/untitled"); (* Bindings for the main window *) List.iter [ [`Control], "s", (fun () -> Jg_text.search_string current_tw); [`Control], "g", (fun () -> goto_line current_tw); [`Alt], "s", self#save_file; [`Alt], "x", (fun () -> send_phrase (List.hd windows)); [`Alt], "l", self#lex; [`Alt], "t", self#typecheck ] ~f:begin fun (modi,key,act) -> bind top ~events:[`Modified(modi, `KeyPressDetail key)] ~breakable:true ~action:(fun _ -> act (); break ()) end; bind top ~events:[`Destroy] ~fields:[`Widget] ~action: begin fun ev -> if Widget.name ev.ev_Widget = Widget.name top then self#quit ~cancel:false () end; (* File menu *) file_menu#add_command "Open File..." ~command:self#open_file; file_menu#add_command "Reopen" ~command:(fun () -> self#load_text [(List.hd windows).name]); file_menu#add_command "Save File" ~command:self#save_file ~accelerator:"M-s"; file_menu#add_command "Save As..." ~underline:5 ~command: begin fun () -> let txt = List.hd windows in Fileselect.f ~title:"Save as File" ~action:(fun name -> self#save_text txt ~name) ~dir:(Filename.dirname txt.name) ~filter:"*.{ml,mli}" ~file:(Filename.basename txt.name) ~sync:true ~usepath:false () end; file_menu#add_command "Close File" ~command:self#close_file; file_menu#add_command "Close Window" ~command:self#quit ~underline:6; (* Edit menu *) edit_menu#add_command "Paste selection" ~command: begin fun () -> Text.insert current_tw ~index:(`Mark"insert",[]) ~text:(Selection.get ~displayof:top ()) end; edit_menu#add_command "Goto..." ~accelerator:"C-g" ~command:(fun () -> goto_line current_tw); edit_menu#add_command "Search..." ~accelerator:"C-s" ~command:(fun () -> Jg_text.search_string current_tw); edit_menu#add_command "To shell" ~accelerator:"M-x" ~command:(fun () -> send_phrase (List.hd windows)); edit_menu#add_command "Select shell..." ~command:(fun () -> select_shell (List.hd windows)); (* Compiler menu *) compiler_menu#add_command "Preferences..." ~command:(fun () -> compiler_preferences top); compiler_menu#add_command "Lex" ~accelerator:"M-l" ~command:self#lex; compiler_menu#add_command "Typecheck" ~accelerator:"M-t" ~command:self#typecheck; compiler_menu#add_command "Clear errors" ~command:self#clear_errors; compiler_menu#add_command "Signature..." ~command: begin fun () -> let txt = List.hd windows in if txt.signature <> [] then let basename = Filename.basename txt.name in let modname = String.capitalize (try Filename.chop_extension basename with _ -> basename) in let env = Env.add_module (Ident.create modname) (Types.Mty_signature txt.signature) Env.initial in Viewer.view_defined (Longident.Lident modname) ~env ~show_all:true end; (* Modules *) module_menu#add_command "Path editor..." ~command:(fun () -> Setpath.set ~dir:current_dir); module_menu#add_command "Reset cache" ~command:(fun () -> Setpath.exec_update_hooks (); Env.reset_cache ()); module_menu#add_command "Search symbol..." ~command:Viewer.search_symbol; module_menu#add_command "Close all" ~command:Viewer.close_all_views; end (* The main function starts here ! *) let already_open : editor list ref = ref [] let editor ?file ?(pos=0) ?(reuse=false) () = if !already_open <> [] && let ed = List.hd !already_open (* try let name = match file with Some f -> f | None -> raise Not_found in List.find !already_open ~f:(fun ed -> ed#has_window name) with Not_found -> List.hd !already_open *) in try ed#reopen ~file ~pos; true with Protocol.TkError _ -> already_open := [] (* List.filter !already_open ~f:((<>) ed) *); false then () else let top = Jg_toplevel.titled "OCamlBrowser Editor" in let menus = Jg_menu.menubar top in let ed = new editor ~top ~menus in already_open := !already_open @ [ed]; if file <> None then ed#reopen ~file ~pos let f ?file ?pos ?(opendialog=false) () = if opendialog then Fileselect.f ~title:"Open File" ~action:(function [file] -> editor ~file () | _ -> ()) ~filter:("*.{ml,mli}") ~sync:true () else editor ?file ?pos ~reuse:(file <> None) () mingw-ocaml/ocaml/otherlibs/labltk/browser/Makefile0000644000175000017500000000207112124403241022045 0ustar tootstoots######################################################################### # # # OCaml LablTk library # # # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique and Kyoto University. All rights reserved. # # This file is distributed under the terms of the GNU Library # # General Public License, with the special exception on linking # # described in file ../../../LICENSE. # # # ######################################################################### # $Id$ OTHERSLIB=-I $(OTHERS)/unix -I $(OTHERS)/str include Makefile.shared dummy.mli: cp dummyUnix.mli dummy.mli mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_memo.ml0000644000175000017500000000253112124403241022355 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) type ('a, 'b) assoc_list = Nil | Cons of 'a * 'b * ('a, 'b) assoc_list let rec assq key = function Nil -> raise Not_found | Cons (a, b, l) -> if key == a then b else assq key l let fast ~f = let memo = ref Nil in fun key -> try assq key !memo with Not_found -> let data = f key in memo := Cons(key, data, !memo); data mingw-ocaml/ocaml/otherlibs/labltk/browser/searchpos.ml0000644000175000017500000007657412124403241022751 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Asttypes open StdLabels open Support open Tk open Jg_tk open Parsetree open Types open Typedtree open Location open Longident open Path open Env open Searchid (* auxiliary functions *) let (~!) = Jg_memo.fast ~f:Str.regexp let lines_to_chars n ~text:s = let l = String.length s in let rec ltc n ~pos = if n = 1 || pos >= l then pos else if s.[pos] = '\n' then ltc (n-1) ~pos:(pos+1) else ltc n ~pos:(pos+1) in ltc n ~pos:0 let in_loc loc ~pos = loc.loc_ghost || pos >= loc.loc_start.Lexing.pos_cnum && pos < loc.loc_end.Lexing.pos_cnum let le_loc loc1 loc2 = loc1.loc_start.Lexing.pos_cnum <= loc2.loc_start.Lexing.pos_cnum && loc1.loc_end.Lexing.pos_cnum >= loc2.loc_end.Lexing.pos_cnum let add_found ~found sol ~env ~loc = if loc.loc_ghost then () else if List.exists !found ~f:(fun (_,_,loc') -> le_loc loc loc') then () else found := (sol, env, loc) :: List.filter !found ~f:(fun (_,_,loc') -> not (le_loc loc' loc)) let observe ~ref ?init f x = let old = !ref in begin match init with None -> () | Some x -> ref := x end; try (f x : unit); let v = !ref in ref := old; v with exn -> ref := old; raise exn let rec string_of_longident = function Lident s -> s | Ldot (id,s) -> string_of_longident id ^ "." ^ s | Lapply (id1, id2) -> string_of_longident id1 ^ "(" ^ string_of_longident id2 ^ ")" let string_of_path p = string_of_longident (Searchid.longident_of_path p) let parent_path = function Pdot (path, _, _) -> Some path | Pident _ | Papply _ -> None let ident_of_path ~default = function Pident i -> i | Pdot (_, s, _) -> Ident.create s | Papply _ -> Ident.create default let rec head_id = function Pident id -> id | Pdot (path,_,_) -> head_id path | Papply (path,_) -> head_id path (* wrong, but ... *) let rec list_of_path = function Pident id -> [Ident.name id] | Pdot (path, s, _) -> list_of_path path @ [s] | Papply (path, _) -> list_of_path path (* wrong, but ... *) (* a simple wrapper *) class buffer ~size = object val buffer = Buffer.create size method out buf = Buffer.add_substring buffer buf method get = Buffer.contents buffer end (* Search in a signature *) type skind = [`Type|`Class|`Module|`Modtype] let found_sig = ref ([] : ((skind * Longident.t) * Env.t * Location.t) list) let add_found_sig = add_found ~found:found_sig let rec search_pos_type t ~pos ~env = if in_loc ~pos t.ptyp_loc then begin match t.ptyp_desc with Ptyp_any | Ptyp_var _ -> () | Ptyp_variant(tl, _, _) -> List.iter tl ~f: begin function Rtag (_,_,tl) -> List.iter tl ~f:(search_pos_type ~pos ~env) | Rinherit st -> search_pos_type ~pos ~env st end | Ptyp_arrow (_, t1, t2) -> search_pos_type t1 ~pos ~env; search_pos_type t2 ~pos ~env | Ptyp_tuple tl -> List.iter tl ~f:(search_pos_type ~pos ~env) | Ptyp_constr (lid, tl) -> List.iter tl ~f:(search_pos_type ~pos ~env); add_found_sig (`Type, lid.txt) ~env ~loc:t.ptyp_loc | Ptyp_object fl -> List.iter fl ~f: begin function | {pfield_desc = Pfield (_, ty)} -> search_pos_type ty ~pos ~env | _ -> () end | Ptyp_class (lid, tl, _) -> List.iter tl ~f:(search_pos_type ~pos ~env); add_found_sig (`Type, lid.txt) ~env ~loc:t.ptyp_loc | Ptyp_alias (t, _) | Ptyp_poly (_, t) -> search_pos_type ~pos ~env t | Ptyp_package (_, stl) -> List.iter stl ~f:(fun (_, ty) -> search_pos_type ty ~pos ~env) end let rec search_pos_class_type cl ~pos ~env = if in_loc cl.pcty_loc ~pos then begin match cl.pcty_desc with Pcty_constr (lid, _) -> add_found_sig (`Class, lid.txt) ~env ~loc:cl.pcty_loc | Pcty_signature cl -> List.iter cl.pcsig_fields ~f: (fun fl -> begin match fl.pctf_desc with Pctf_inher cty -> search_pos_class_type cty ~pos ~env | Pctf_val (_, _, _, ty) -> if in_loc fl.pctf_loc ~pos then search_pos_type ty ~pos ~env | Pctf_virt (_, _, ty) -> if in_loc fl.pctf_loc ~pos then search_pos_type ty ~pos ~env | Pctf_meth (_, _, ty) -> if in_loc fl.pctf_loc ~pos then search_pos_type ty ~pos ~env | Pctf_cstr (ty1, ty2) -> if in_loc fl.pctf_loc ~pos then begin search_pos_type ty1 ~pos ~env; search_pos_type ty2 ~pos ~env end end) | Pcty_fun (_, ty, cty) -> search_pos_type ty ~pos ~env; search_pos_class_type cty ~pos ~env end let search_pos_type_decl td ~pos ~env = if in_loc ~pos td.ptype_loc then begin begin match td.ptype_manifest with Some t -> search_pos_type t ~pos ~env | None -> () end; let rec search_tkind = function Ptype_abstract -> () | Ptype_variant dl -> List.iter dl ~f:(fun (_, tl, _, _) -> List.iter tl ~f:(search_pos_type ~pos ~env)) | Ptype_record dl -> List.iter dl ~f:(fun (_, _, t, _) -> search_pos_type t ~pos ~env) in search_tkind td.ptype_kind; List.iter td.ptype_cstrs ~f: begin fun (t1, t2, _) -> search_pos_type t1 ~pos ~env; search_pos_type t2 ~pos ~env end end let rec search_pos_signature l ~pos ~env = ignore ( List.fold_left l ~init:env ~f: begin fun env pt -> let env = match pt.psig_desc with Psig_open id -> let path, mt = lookup_module id.txt env in begin match mt with Mty_signature sign -> open_signature path sign env | _ -> env end | sign_item -> try add_signature (Typemod.transl_signature env [pt]).sig_type env with Typemod.Error _ | Typeclass.Error _ | Typetexp.Error _ | Typedecl.Error _ -> env in if in_loc ~pos pt.psig_loc then begin match pt.psig_desc with Psig_value (_, desc) -> search_pos_type desc.pval_type ~pos ~env | Psig_type l -> List.iter l ~f:(fun (_,desc) -> search_pos_type_decl ~pos desc ~env) | Psig_exception (_, l) -> List.iter l ~f:(search_pos_type ~pos ~env); add_found_sig (`Type, Lident "exn") ~env ~loc:pt.psig_loc | Psig_module (_, t) -> search_pos_module t ~pos ~env | Psig_recmodule decls -> List.iter decls ~f:(fun (_, t) -> search_pos_module t ~pos ~env) | Psig_modtype (_, Pmodtype_manifest t) -> search_pos_module t ~pos ~env | Psig_modtype _ -> () | Psig_class l -> List.iter l ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env) | Psig_class_type l -> List.iter l ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env) (* The last cases should not happen in generated interfaces *) | Psig_open lid -> add_found_sig (`Module, lid.txt) ~env ~loc:pt.psig_loc | Psig_include t -> search_pos_module t ~pos ~env end; env end) and search_pos_module m ~pos ~env = if in_loc m.pmty_loc ~pos then begin begin match m.pmty_desc with Pmty_ident lid -> add_found_sig (`Modtype, lid.txt) ~env ~loc:m.pmty_loc | Pmty_signature sg -> search_pos_signature sg ~pos ~env | Pmty_functor (_ , m1, m2) -> search_pos_module m1 ~pos ~env; search_pos_module m2 ~pos ~env | Pmty_with (m, l) -> search_pos_module m ~pos ~env; List.iter l ~f: begin function _, Pwith_type t -> search_pos_type_decl t ~pos ~env | _ -> () end | Pmty_typeof md -> () (* TODO? *) end end let search_pos_signature l ~pos ~env = observe ~ref:found_sig (search_pos_signature ~pos ~env) l (* the module display machinery *) type module_widgets = { mw_frame: Widget.frame Widget.widget; mw_title: Widget.label Widget.widget option; mw_detach: Widget.button Widget.widget; mw_edit: Widget.button Widget.widget; mw_intf: Widget.button Widget.widget } let shown_modules = Hashtbl.create 17 let default_frame = ref None let set_path = ref (fun _ ~sign -> assert false) let filter_modules () = Hashtbl.iter (fun key data -> if not (Winfo.exists data.mw_frame) then Hashtbl.remove shown_modules key) shown_modules let add_shown_module path ~widgets = Hashtbl.add shown_modules path widgets let find_shown_module path = try filter_modules (); Hashtbl.find shown_modules path with Not_found -> match !default_frame with None -> raise Not_found | Some mw -> mw let is_shown_module path = !default_frame <> None || (filter_modules (); Hashtbl.mem shown_modules path) (* Viewing a signature *) (* Forward definitions of Viewer.view_defined and Editor.editor *) let view_defined_ref = ref (fun lid ~env -> ()) let editor_ref = ref (fun ?file ?pos ?opendialog () -> ()) let edit_source ~file ~path ~sign = match sign with [item] -> let id, kind = match item with Sig_value (id, _) -> id, Pvalue | Sig_type (id, _, _) -> id, Ptype | Sig_exception (id, _) -> id, Pconstructor | Sig_module (id, _, _) -> id, Pmodule | Sig_modtype (id, _) -> id, Pmodtype | Sig_class (id, _, _) -> id, Pclass | Sig_class_type (id, _, _) -> id, Pcltype in let prefix = List.tl (list_of_path path) and name = Ident.name id in let pos = try let chan = open_in file in if Filename.check_suffix file ".ml" then let parsed = Parse.implementation (Lexing.from_channel chan) in close_in chan; Searchid.search_structure parsed ~name ~kind ~prefix else let parsed = Parse.interface (Lexing.from_channel chan) in close_in chan; Searchid.search_signature parsed ~name ~kind ~prefix with _ -> 0 in !editor_ref ~file ~pos () | _ -> !editor_ref ~file () (* List of windows to destroy by Close All *) let top_widgets = ref [] let dummy_item = Sig_modtype (Ident.create "dummy", Modtype_abstract) let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign = let env = match path with None -> env | Some path -> Env.open_signature path sign env in let title = match title, path with Some title, _ -> title | None, Some path -> string_of_path path | None, None -> "Signature" in let tl, tw, finish = try match path, !default_frame with None, Some ({mw_title=Some label} as mw) when not detach -> Button.configure mw.mw_detach ~command:(fun () -> view_signature sign ~title ~env ~detach:true); pack [mw.mw_detach] ~side:`Left; Pack.forget [mw.mw_edit; mw.mw_intf]; List.iter ~f:destroy (Winfo.children mw.mw_frame); Label.configure label ~text:title; pack [label] ~fill:`X ~side:`Bottom; Jg_message.formatted ~title ~on:mw.mw_frame ~maxheight:15 () | None, _ -> raise Not_found | Some path, _ -> let mw = try find_shown_module path with Not_found -> view_module path ~env; find_shown_module path in (try !set_path path ~sign with _ -> ()); begin match mw.mw_title with None -> () | Some label -> Label.configure label ~text:title; pack [label] ~fill:`X ~side:`Bottom end; Button.configure mw.mw_detach ~command:(fun () -> view_signature sign ~title ~env ~detach:true); pack [mw.mw_detach] ~side:`Left; let repack = ref false in List.iter2 [mw.mw_edit; mw.mw_intf] [".ml"; ".mli"] ~f: begin fun button ext -> try let id = head_id path in let file = Misc.find_in_path_uncap !Config.load_path ((Ident.name id) ^ ext) in Button.configure button ~command:(fun () -> edit_source ~file ~path ~sign); if !repack then Pack.forget [button] else if not (Winfo.viewable button) then repack := true; pack [button] ~side:`Left with Not_found -> Pack.forget [button] end; let top = Winfo.toplevel mw.mw_frame in if not (Winfo.ismapped top) then Wm.deiconify top; List.iter ~f:destroy (Winfo.children mw.mw_frame); Jg_message.formatted ~title ~on:mw.mw_frame ~maxheight:15 () with Not_found -> let tl, tw, finish = Jg_message.formatted ~title ~maxheight:15 () in top_widgets := tl :: !top_widgets; tl, tw, finish in Format.set_max_boxes 100; Printtyp.signature Format.std_formatter sign; finish (); Lexical.init_tags tw; Lexical.tag tw; Text.configure tw ~state:`Disabled; let text = Jg_text.get_all tw in let pt = try Parse.interface (Lexing.from_string text) with Syntaxerr.Error e -> let l = match e with Syntaxerr.Unclosed(l,_,_,_) -> l | Syntaxerr.Applicative_path l -> l | Syntaxerr.Variable_in_scope(l,_) -> l | Syntaxerr.Other l -> l in Jg_text.tag_and_see tw ~start:(tpos l.loc_start.Lexing.pos_cnum) ~stop:(tpos l.loc_end.Lexing.pos_cnum) ~tag:"error"; [] | Lexer.Error (_, l) -> let s = l.loc_start.Lexing.pos_cnum in let e = l.loc_end.Lexing.pos_cnum in Jg_text.tag_and_see tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error"; [] in Jg_bind.enter_focus tw; bind tw ~events:[`Modified([`Control], `KeyPressDetail"s")] ~action:(fun _ -> Jg_text.search_string tw); bind tw ~events:[`Modified([`Double], `ButtonPressDetail 1)] ~fields:[`MouseX;`MouseY] ~breakable:true ~action:(fun ev -> let `Linechar (l, c) = Text.index tw ~index:(`Atxy(ev.ev_MouseX,ev.ev_MouseY), []) in try match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env with [] -> break () | ((kind, lid), env, loc) :: _ -> view_decl lid ~kind ~env with Not_found | Env.Error _ -> ()); bind tw ~events:[`ButtonPressDetail 3] ~breakable:true ~fields:[`MouseX;`MouseY] ~action:(fun ev -> let x = ev.ev_MouseX and y = ev.ev_MouseY in let `Linechar (l, c) = Text.index tw ~index:(`Atxy(x,y), []) in try match search_pos_signature pt ~pos:(lines_to_chars l ~text + c) ~env with [] -> break () | ((kind, lid), env, loc) :: _ -> let menu = view_decl_menu lid ~kind ~env ~parent:tw in let x = x + Winfo.rootx tw and y = y + Winfo.rooty tw - 10 in Menu.popup menu ~x ~y with Not_found -> ()) and view_signature_item sign ~path ~env = view_signature sign ~title:(string_of_path path) ?path:(parent_path path) ~env and view_module path ~env = match find_module path env with Mty_signature sign -> !view_defined_ref (Searchid.longident_of_path path) ~env | modtype -> let id = ident_of_path path ~default:"M" in view_signature_item [Sig_module (id, modtype, Trec_not)] ~path ~env and view_module_id id ~env = let path, _ = lookup_module id env in view_module path ~env and view_type_decl path ~env = let td = find_type path env in try match td.type_manifest with None -> raise Not_found | Some ty -> match Ctype.repr ty with {desc = Tobject _} -> let clt = find_cltype path env in view_signature_item ~path ~env [Sig_class_type(ident_of_path path ~default:"ct", clt, Trec_first); dummy_item; dummy_item] | _ -> raise Not_found with Not_found -> view_signature_item ~path ~env [Sig_type(ident_of_path path ~default:"t", td, Trec_first)] and view_type_id li ~env = let path, decl = lookup_type li env in view_type_decl path ~env and view_class_id li ~env = let path, cl = lookup_class li env in view_signature_item ~path ~env [Sig_class(ident_of_path path ~default:"c", cl, Trec_first); dummy_item; dummy_item; dummy_item] and view_cltype_id li ~env = let path, clt = lookup_cltype li env in view_signature_item ~path ~env [Sig_class_type(ident_of_path path ~default:"ct", clt, Trec_first); dummy_item; dummy_item] and view_modtype_id li ~env = let path, td = lookup_modtype li env in view_signature_item ~path ~env [Sig_modtype(ident_of_path path ~default:"S", td)] and view_expr_type ?title ?path ?env ?(name="noname") t = let title = match title, path with Some title, _ -> title | None, Some path -> string_of_path path | None, None -> "Expression type" and path, id = match path with None -> None, Ident.create name | Some path -> parent_path path, ident_of_path path ~default:name in view_signature ~title ?path ?env [Sig_value (id, {val_type = t; val_kind = Val_reg; Types.val_loc = Location.none})] and view_decl lid ~kind ~env = match kind with `Type -> view_type_id lid ~env | `Class -> view_class_id lid ~env | `Module -> view_module_id lid ~env | `Modtype -> view_modtype_id lid ~env and view_decl_menu lid ~kind ~env ~parent = let path, kname = try match kind with `Type -> fst (lookup_type lid env), "Type" | `Class -> fst (lookup_class lid env), "Class" | `Module -> fst (lookup_module lid env), "Module" | `Modtype -> fst (lookup_modtype lid env), "Module type" with Env.Error _ -> raise Not_found in let menu = Menu.create parent ~tearoff:false in let label = kname ^ " " ^ string_of_path path in begin match path with Pident _ -> Menu.add_command menu ~label ~state:`Disabled | _ -> Menu.add_command menu ~label ~command:(fun () -> view_decl lid ~kind ~env); end; if kind = `Type || kind = `Modtype then begin let buf = new buffer ~size:60 in let (fo,ff) = Format.get_formatter_output_functions () and margin = Format.get_margin () in Format.set_formatter_output_functions buf#out (fun () -> ()); Format.set_margin 60; Format.open_hbox (); if kind = `Type then Printtyp.type_declaration (ident_of_path path ~default:"t") Format.std_formatter (find_type path env) else Printtyp.modtype_declaration (ident_of_path path ~default:"S") Format.std_formatter (find_modtype path env); Format.close_box (); Format.print_flush (); Format.set_formatter_output_functions fo ff; Format.set_margin margin; let l = Str.split ~!"\n" buf#get in let font = let font = Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in if font = "" then "7x14" else font in (* Menu.add_separator menu; *) List.iter l ~f:(fun label -> Menu.add_command menu ~label ~font ~state:`Disabled) end; menu (* search and view in a structure *) type fkind = [ `Exp of [`Expr|`Pat|`Const|`Val of Path.t|`Var of Path.t|`New of Path.t] * Types.type_expr | `Class of Path.t * Types.class_type | `Module of Path.t * Types.module_type ] let view_type kind ~env = match kind with `Exp (k, ty) -> begin match k with `Expr -> view_expr_type ty ~title:"Expression type" ~env | `Pat -> view_expr_type ty ~title:"Pattern type" ~env | `Const -> view_expr_type ty ~title:"Constant type" ~env | `Val path -> begin try let vd = find_value path env in view_signature_item ~path ~env [Sig_value(ident_of_path path ~default:"v", vd)] with Not_found -> view_expr_type ty ~path ~env end | `Var path -> let vd = find_value path env in view_expr_type vd.val_type ~env ~path ~title:"Variable type" | `New path -> let cl = find_class path env in view_signature_item ~path ~env [Sig_class(ident_of_path path ~default:"c", cl, Trec_first)] end | `Class (path, cty) -> let cld = { cty_params = []; cty_variance = []; cty_type = cty; cty_path = path; cty_new = None } in view_signature_item ~path ~env [Sig_class(ident_of_path path ~default:"c", cld, Trec_first)] | `Module (path, mty) -> match mty with Mty_signature sign -> view_signature sign ~path ~env | modtype -> view_signature_item ~path ~env [Sig_module(ident_of_path path ~default:"M", mty, Trec_not)] let view_type_menu kind ~env ~parent = let title = match kind with `Exp (`Expr,_) -> "Expression :" | `Exp (`Pat, _) -> "Pattern :" | `Exp (`Const, _) -> "Constant :" | `Exp (`Val path, _) -> "Value " ^ string_of_path path ^ " :" | `Exp (`Var path, _) -> "Variable " ^ Ident.name (ident_of_path path ~default:"noname") ^ " :" | `Exp (`New path, _) -> "Class " ^ string_of_path path ^ " :" | `Class (path, _) -> "Class " ^ string_of_path path ^ " :" | `Module (path,_) -> "Module " ^ string_of_path path in let menu = Menu.create parent ~tearoff:false in begin match kind with `Exp((`Expr | `Pat | `Const | `Val (Pident _)),_) -> Menu.add_command menu ~label:title ~state:`Disabled | `Exp _ | `Class _ | `Module _ -> Menu.add_command menu ~label:title ~command:(fun () -> view_type kind ~env) end; begin match kind with `Module _ | `Class _ -> () | `Exp(_, ty) -> let buf = new buffer ~size:60 in let (fo,ff) = Format.get_formatter_output_functions () and margin = Format.get_margin () in Format.set_formatter_output_functions buf#out ignore; Format.set_margin 60; Format.open_hbox (); Printtyp.reset (); Printtyp.mark_loops ty; Printtyp.type_expr Format.std_formatter ty; Format.close_box (); Format.print_flush (); Format.set_formatter_output_functions fo ff; Format.set_margin margin; let l = Str.split ~!"\n" buf#get in let font = let font = Option.get Widget.default_toplevel ~name:"font" ~clas:"Font" in if font = "" then "7x14" else font in (* Menu.add_separator menu; *) List.iter l ~f: begin fun label -> match (Ctype.repr ty).desc with Tconstr (path,_,_) -> Menu.add_command menu ~label ~font ~command:(fun () -> view_type_decl path ~env) | Tvariant {row_name = Some (path, _)} -> Menu.add_command menu ~label ~font ~command:(fun () -> view_type_decl path ~env) | _ -> Menu.add_command menu ~label ~font ~state:`Disabled end end; menu let found_str = ref ([] : (fkind * Env.t * Location.t) list) let add_found_str = add_found ~found:found_str let rec search_pos_structure ~pos str = List.iter str ~f: begin function str -> match str.str_desc with Tstr_eval exp -> search_pos_expr exp ~pos | Tstr_value (rec_flag, l) -> List.iter l ~f: begin fun (pat, exp) -> let env = if rec_flag = Asttypes.Recursive then exp.exp_env else Env.empty in search_pos_pat pat ~pos ~env; search_pos_expr exp ~pos end | Tstr_primitive (_, _, vd) ->() | Tstr_type _ -> () | Tstr_exception _ -> () | Tstr_exn_rebind(_, _, _, _) -> () | Tstr_module (_, _, m) -> search_pos_module_expr m ~pos | Tstr_recmodule bindings -> List.iter bindings ~f:(fun (_, _, _, m) -> search_pos_module_expr m ~pos) | Tstr_modtype _ -> () | Tstr_open _ -> () | Tstr_class l -> List.iter l ~f:(fun (cl, _, _) -> search_pos_class_expr cl.ci_expr ~pos) | Tstr_class_type _ -> () | Tstr_include (m, _) -> search_pos_module_expr m ~pos end and search_pos_class_structure ~pos cls = List.iter cls.cstr_fields ~f: begin function cf -> match cf.cf_desc with Tcf_inher (_, cl, _, _, _) -> search_pos_class_expr cl ~pos | Tcf_val (_, _, _, _, Tcfk_concrete exp, _) -> search_pos_expr exp ~pos | Tcf_val _ -> () | Tcf_meth (_, _, _, Tcfk_concrete exp, _) -> search_pos_expr exp ~pos | Tcf_init exp -> search_pos_expr exp ~pos | Tcf_constr _ | Tcf_meth _ -> assert false (* TODO !!!!!!!!!!!!!!!!! *) end and search_pos_class_expr ~pos cl = if in_loc cl.cl_loc ~pos then begin begin match cl.cl_desc with Tcl_ident (path, _, _) -> add_found_str (`Class (path, cl.cl_type)) ~env:!start_env ~loc:cl.cl_loc | Tcl_structure cls -> search_pos_class_structure ~pos cls | Tcl_fun (_, pat, iel, cl, _) -> search_pos_pat pat ~pos ~env:pat.pat_env; List.iter iel ~f:(fun (_,_, exp) -> search_pos_expr exp ~pos); search_pos_class_expr cl ~pos | Tcl_apply (cl, el) -> search_pos_class_expr cl ~pos; List.iter el ~f:(fun (_, x,_) -> Misc.may (search_pos_expr ~pos) x) | Tcl_let (_, pel, iel, cl) -> List.iter pel ~f: begin fun (pat, exp) -> search_pos_pat pat ~pos ~env:exp.exp_env; search_pos_expr exp ~pos end; List.iter iel ~f:(fun (_,_, exp) -> search_pos_expr exp ~pos); search_pos_class_expr cl ~pos | Tcl_constraint (cl, _, _, _, _) -> search_pos_class_expr cl ~pos end; add_found_str (`Class (Pident (Ident.create "c"), cl.cl_type)) ~env:!start_env ~loc:cl.cl_loc end and search_pos_expr ~pos exp = if in_loc exp.exp_loc ~pos then begin begin match exp.exp_desc with Texp_ident (path, _, _) -> add_found_str (`Exp(`Val path, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc | Texp_constant v -> add_found_str (`Exp(`Const, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc | Texp_let (_, expl, exp) -> List.iter expl ~f: begin fun (pat, exp') -> search_pos_pat pat ~pos ~env:exp.exp_env; search_pos_expr exp' ~pos end; search_pos_expr exp ~pos | Texp_function (_, l, _) -> List.iter l ~f: begin fun (pat, exp) -> search_pos_pat pat ~pos ~env:exp.exp_env; search_pos_expr exp ~pos end | Texp_apply (exp, l) -> List.iter l ~f:(fun (_, x,_) -> Misc.may (search_pos_expr ~pos) x); search_pos_expr exp ~pos | Texp_match (exp, l, _) -> search_pos_expr exp ~pos; List.iter l ~f: begin fun (pat, exp) -> search_pos_pat pat ~pos ~env:exp.exp_env; search_pos_expr exp ~pos end | Texp_try (exp, l) -> search_pos_expr exp ~pos; List.iter l ~f: begin fun (pat, exp) -> search_pos_pat pat ~pos ~env:exp.exp_env; search_pos_expr exp ~pos end | Texp_tuple l -> List.iter l ~f:(search_pos_expr ~pos) | Texp_construct (_, _, _, l,_) -> List.iter l ~f:(search_pos_expr ~pos) | Texp_variant (_, None) -> () | Texp_variant (_, Some exp) -> search_pos_expr exp ~pos | Texp_record (l, opt) -> List.iter l ~f:(fun (_, _, _, exp) -> search_pos_expr exp ~pos); (match opt with None -> () | Some exp -> search_pos_expr exp ~pos) | Texp_field (exp, _, _, _) -> search_pos_expr exp ~pos | Texp_setfield (a, _, _, _, b) -> search_pos_expr a ~pos; search_pos_expr b ~pos | Texp_array l -> List.iter l ~f:(search_pos_expr ~pos) | Texp_ifthenelse (a, b, c) -> search_pos_expr a ~pos; search_pos_expr b ~pos; begin match c with None -> () | Some exp -> search_pos_expr exp ~pos end | Texp_sequence (a,b) -> search_pos_expr a ~pos; search_pos_expr b ~pos | Texp_while (a,b) -> search_pos_expr a ~pos; search_pos_expr b ~pos | Texp_for (_, _, a, b, _, c) -> List.iter [a;b;c] ~f:(search_pos_expr ~pos) | Texp_when (a, b) -> search_pos_expr a ~pos; search_pos_expr b ~pos | Texp_send (exp, _, _) -> search_pos_expr exp ~pos | Texp_new (path, _, _) -> add_found_str (`Exp(`New path, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc | Texp_instvar (_, path, _) -> add_found_str (`Exp(`Var path, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc | Texp_setinstvar (_, path, _, exp) -> search_pos_expr exp ~pos; add_found_str (`Exp(`Var path, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc | Texp_override (_, l) -> List.iter l ~f:(fun (_, _, exp) -> search_pos_expr exp ~pos) | Texp_letmodule (id, _, modexp, exp) -> search_pos_module_expr modexp ~pos; search_pos_expr exp ~pos | Texp_assertfalse -> () | Texp_assert exp -> search_pos_expr exp ~pos | Texp_lazy exp -> search_pos_expr exp ~pos | Texp_object (cls, _) -> search_pos_class_structure ~pos cls | Texp_pack modexp -> search_pos_module_expr modexp ~pos end; add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc end and search_pos_pat ~pos ~env pat = if in_loc pat.pat_loc ~pos then begin begin match pat.pat_desc with Tpat_any -> () | Tpat_var (id, _) -> add_found_str (`Exp(`Val (Pident id), pat.pat_type)) ~env ~loc:pat.pat_loc | Tpat_alias (pat, _, _) -> search_pos_pat pat ~pos ~env | Tpat_lazy pat -> search_pos_pat pat ~pos ~env | Tpat_constant _ -> add_found_str (`Exp(`Const, pat.pat_type)) ~env ~loc:pat.pat_loc | Tpat_tuple l -> List.iter l ~f:(search_pos_pat ~pos ~env) | Tpat_construct (_, _, _, l, _) -> List.iter l ~f:(search_pos_pat ~pos ~env) | Tpat_variant (_, None, _) -> () | Tpat_variant (_, Some pat, _) -> search_pos_pat pat ~pos ~env | Tpat_record (l, _) -> List.iter l ~f:(fun (_, _, _, pat) -> search_pos_pat pat ~pos ~env) | Tpat_array l -> List.iter l ~f:(search_pos_pat ~pos ~env) | Tpat_or (a, b, None) -> search_pos_pat a ~pos ~env; search_pos_pat b ~pos ~env | Tpat_or (_, _, Some _) -> () end; add_found_str (`Exp(`Pat, pat.pat_type)) ~env ~loc:pat.pat_loc end and search_pos_module_expr ~pos (m :module_expr) = if in_loc m.mod_loc ~pos then begin begin match m.mod_desc with Tmod_ident (path, _) -> add_found_str (`Module (path, m.mod_type)) ~env:m.mod_env ~loc:m.mod_loc | Tmod_structure str -> search_pos_structure str.str_items ~pos | Tmod_functor (_, _, _, m) -> search_pos_module_expr m ~pos | Tmod_apply (a, b, _) -> search_pos_module_expr a ~pos; search_pos_module_expr b ~pos | Tmod_constraint (m, _, _, _) -> search_pos_module_expr m ~pos | Tmod_unpack (e, _) -> search_pos_expr e ~pos end; add_found_str (`Module (Pident (Ident.create "M"), m.mod_type)) ~env:m.mod_env ~loc:m.mod_loc end let search_pos_structure ~pos str = observe ~ref:found_str (search_pos_structure ~pos) str open Stypes let search_pos_ti ~pos = function Ti_pat p -> search_pos_pat ~pos ~env:p.pat_env p | Ti_expr e -> search_pos_expr ~pos e | Ti_class c -> search_pos_class_expr ~pos c | Ti_mod m -> search_pos_module_expr ~pos m | _ -> () let rec search_pos_info ~pos = function [] -> [] | ti :: l -> if in_loc ~pos (get_location ti) then observe ~ref:found_str (search_pos_ti ~pos) ti else search_pos_info ~pos l mingw-ocaml/ocaml/otherlibs/labltk/browser/viewer.mli0000644000175000017500000000271212124403241022413 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) (* Module viewer *) open Widget val search_symbol : unit -> unit (* search a symbol in all modules in the path *) val f : ?dir:string -> ?on:toplevel widget -> unit -> unit (* open then module viewer *) val st_viewer : ?dir:string -> ?on:toplevel widget -> unit -> unit (* one-box viewer *) val view_defined : env:Env.t -> ?show_all:bool -> Longident.t -> unit (* displays a signature, found in environment *) val close_all_views : unit -> unit mingw-ocaml/ocaml/otherlibs/labltk/browser/main.ml0000644000175000017500000001103712124403241021665 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open StdLabels module Unix = UnixLabels open Tk let fatal_error text = let top = openTk ~clas:"OCamlBrowser" () in let mw = Message.create top ~text ~padx:20 ~pady:10 ~width:400 ~justify:`Left ~aspect:400 ~anchor:`W and b = Button.create top ~text:"OK" ~command:(fun () -> destroy top) in pack [mw] ~side:`Top ~fill:`Both; pack [b] ~side:`Bottom; mainLoop (); exit 0 let rec get_incr key = function [] -> raise Not_found | (k, c, d) :: rem -> if k = key then match c with Arg.Set _ | Arg.Clear _ | Arg.Unit _ -> false | _ -> true else get_incr key rem let check ~spec argv = let i = ref 1 in while !i < Array.length argv do try let a = get_incr argv.(!i) spec in incr i; if a then incr i with Not_found -> i := Array.length argv + 1 done; !i = Array.length argv open Printf let print_version () = printf "The OCaml browser, version %s\n" Sys.ocaml_version; exit 0; ;; let print_version_num () = printf "%s\n" Sys.ocaml_version; exit 0; ;; let usage ~spec errmsg = let b = Buffer.create 1024 in bprintf b "%s\n" errmsg; List.iter (function (key, _, doc) -> bprintf b " %s %s\n" key doc) spec; Buffer.contents b let _ = let is_win32 = Sys.os_type = "Win32" in if is_win32 then Format.pp_set_formatter_output_functions Format.err_formatter (fun _ _ _ -> ()) (fun _ -> ()); let path = ref [] in let st = ref true in let spec = [ "-I", Arg.String (fun s -> path := s :: !path), "

Add to the list of include directories"; "-labels", Arg.Clear Clflags.classic, " "; "-nolabels", Arg.Set Clflags.classic, " Ignore non-optional labels in types"; "-oldui", Arg.Clear st, " Revert back to old UI"; "-pp", Arg.String (fun s -> Clflags.preprocessor := Some s), " Pipe sources through preprocessor "; "-rectypes", Arg.Set Clflags.recursive_types, " Allow arbitrary recursive types"; "-version", Arg.Unit print_version, " Print version and exit"; "-vnum", Arg.Unit print_version_num, " Print version number and exit"; "-w", Arg.String (fun s -> Shell.warnings := s), " Enable or disable warnings according to "; ] and errmsg = "Command line: ocamlbrowser " in if not (check ~spec Sys.argv) then fatal_error (usage ~spec errmsg); Arg.parse spec (fun name -> raise(Arg.Bad("don't know what to do with " ^ name))) errmsg; Config.load_path := Sys.getcwd () :: List.rev_map ~f:(Misc.expand_directory Config.standard_library) !path @ [Config.standard_library]; Warnings.parse_options false !Shell.warnings; Unix.putenv "TERM" "noterminal"; begin try Searchid.start_env := Env.open_pers_signature "Pervasives" Env.initial with _ -> fatal_error (Printf.sprintf "%s\nPlease check that %s %s\nCurrent value is `%s'" "Couldn't initialize environment." (if is_win32 then "%OCAMLLIB%" else "$OCAMLLIB") "points to the OCaml library." Config.standard_library) end; Searchpos.view_defined_ref := (fun s ~env -> Viewer.view_defined s ~env); Searchpos.editor_ref := Editor.f; let top = openTk ~clas:"OCamlBrowser" () in Jg_config.init (); (* bind top ~events:[`Destroy] ~action:(fun _ -> exit 0); *) at_exit Shell.kill_all; if !st then Viewer.st_viewer ~on:top () else Viewer.f ~on:top (); while true do try if is_win32 then mainLoop () else Printexc.print mainLoop () with Protocol.TkError _ -> if not is_win32 then flush stderr done mingw-ocaml/ocaml/otherlibs/labltk/browser/Makefile.nt0000644000175000017500000000254612124403241022474 0ustar tootstoots######################################################################### # # # OCaml LablTk library # # # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 2000 Institut National de Recherche en Informatique et # # en Automatique and Kyoto University. All rights reserved. # # This file is distributed under the terms of the GNU Library # # General Public License, with the special exception on linking # # described in file ../../../LICENSE. # # # ######################################################################### # $Id$ OTHERSLIB=-I $(OTHERS)/win32unix -I $(OTHERS)/str -I $(OTHERS)/systhreads CCFLAGS=-I../../../byterun $(TK_DEFS) include ../support/Makefile.common ifeq ($(CCOMPTYPE),cc) WINDOWS_APP=-ccopt "-link -Wl,--subsystem,windows" else WINDOWS_APP=-ccopt "-link /subsystem:windows" endif XTRAOBJ=winmain.$(O) XTRALIBS=threads.cma -custom $(WINDOWS_APP) include Makefile.shared dummy.mli: cp dummyWin.mli dummy.mli mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_entry.ml0000644000175000017500000000243212124403241022561 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Tk let create ?command ?width ?textvariable parent = let ew = Entry.create parent ?width ?textvariable in Jg_bind.enter_focus ew; begin match command with Some command -> bind ew ~events:[`KeyPressDetail "Return"] ~action:(fun _ -> command (Entry.get ew)) | None -> () end; ew mingw-ocaml/ocaml/otherlibs/labltk/browser/README0000644000175000017500000001475212124403241021276 0ustar tootstoots Installing and Using OCamlBrowser INSTALLATION If you installed it with LablTk, nothing to do. Otherwise, the source is in labltk/browser. After installing LablTk, simply do "make" and "make install". The name of the command is `ocamlbrowser'. USE OCamlBrowser is composed of three tools, the Viewer, to walk around compiled modules, the Editor, which allows one to edit/typecheck/analyse .mli and .ml files, and the Shell, to run an OCaml subshell. You may only have one instance of Editor and Viewer, but you may use several subshells. As with the compiler, you may specify a different path for the standard library by setting CAMLLIB. You may also extend the initial load path (only standard library by default) by using the -I command line option, or set various other options (see -help). If you prefered the old GUI, it is still available with the option -oldui, otherwise you get a new Smalltalkish user interface. 1) Viewer Menus File - Open and File - Editor give access to the editor. File - Shell opens an OCaml shell. View - Show all defs displays all the interface of the currently selected module View - Search entry shows/hides the search entry at the top of the window Modules - Path editor changes the load path. Pressing [Add to path] or Insert key adds selected directories to the load path. Pressing [Remove from path] or Delete key removes selected paths from the load path. Modules - Reset cache rescans the load path and resets the module cache. Do it if you recompile some interface, or change the load path in a conflictual way. Modules - Search symbol allows to search a symbol either by its name, like the bottom line of the viewer, or, more interestingly, by its type. Exact type searches for a type with exactly the same information as the pattern (variables match only variables), included type allows to give only partial information: the actual type may take more arguments and return more results, and variables in the pattern match anything. In both cases, argument and tuple order is irrelevant (*), and unlabeled arguments in the pattern match any label. (*) To avoid combinatorial explosion of the search space, optional arguments in the actual type are ignored if (1) there are to many of them, and (2) they do not appear explicitly in the pattern. Search entry The entry line at the top allows one to search for an identifier in all modules, either by its name (? and * patterns allowed) or by its type. When search by type is used, it is done in inclusion mode (cf. Modules - search symbol) The Close all button at the bottom is there to dismiss the windows created by the Detach button. By double-clicking on it you will quit the browser. Module browsing You select a module in the leftmost box by either cliking on it or pressing return when it is selected. Fast access is available in all boxes pressing the first few letter of the desired name. Double-clicking / double-return displays the whole signature for the module. Defined identifiers inside the module are displayed in a box to the right of the previous one. If you click on one, this will either display its contents in another box (if this is a sub-module) or display the signature for this identifier below. Signatures are clickable. Double clicking with the left mouse button on an identifier in a signature brings you to its signature. A single click on the right button pops up a menu displaying the type declaration for the selected identifier. Its title, when selectable, also brings you to its signature. At the bottom, a series of buttons, depending on the context. * Detach copies the currently displayed signature in a new window, to keep it. You can discard these windows with Close all. * Impl and Intf bring you to the implementation or interface of the currently displayed signature, if it is available. C-s opens a text search dialog for the displayed signature. 2) Editor You can edit files with it, but there is no auto-save nor undo at the moment. Otherwise you can use it as a browser, making occasional corrections. The Edit menu contains commands for jump (C-g), search (C-s), and sending the current selection to a sub-shell (M-x). For this last option, you may choose the shell via a dialog. Essential function are in the Compiler menu. Preferences opens a dialog to set internals of the editor and type checker. Lex (M-l) adds colors according to lexical categories. Typecheck (M-t) verifies typing, and memorizes it to let one see an expression's type by double-clicking on it. This is also valid for interfaces. If an error occurs, the part of the interface preceding the error is computed. After typechecking, pressing the right button pops up a menu giving the type of the pointed expression, and eventually allowing to follow some links. Clear errors dismisses type checker error messages and warnings. Signature shows the signature of the current file. 3) Shell When you create a shell, a dialog is presented to you, letting you choose which command you want to run, and the title of the shell (to choose it in the Editor). You may change the default command by setting the OLABL environment variable. The executed subshell is given the current load path. File: use a source file or load a bytecode file. You may also import the browser's path into the subprocess. History: M-p and M-n browse up and down. Signal: C-c interrupts and you can kill the subprocess. BUGS * This not really a bug, but OCamlBrowser is a huge memory consumer. Go and buy some. * When you quit the editor and some file was modified, a dialogue is displayed asking wether you want to really quit or not. But 1) if you quit directly from the viewer, there is no dialogue at all, and 2) if you close from the window manager, the dialogue is displayed, but you cannot cancel the destruction... Beware. * When you run it through xon, the shell hangs at the first error. But its ok if you start ocamlbrowser from a remote shell... TODO * Complete cross-references. * Power up editor. * Add support for the debugger. * Make this a real programming environment, both for beginners an experimented users. Bug reports and comments to mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_multibox.mli0000644000175000017500000000321212124403241023431 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) class c : cols:int -> texts:string list -> ?maxheight:int -> ?width:int -> 'a Widget.widget -> object method cols : int method texts : string list method parent : Widget.any Widget.widget method boxes : Widget.listbox Widget.widget list method current : int method init : unit method recenter : ?aligntop:bool -> int -> unit method bind_mouse : events:Tk.event list -> action:(Tk.eventInfo -> index:int -> unit) -> unit method bind_kbd : events:Tk.event list -> action:(Tk.eventInfo -> index:int -> unit) -> unit end val add_scrollbar : c -> Widget.scrollbar Widget.widget val add_completion : ?action:(int -> unit) -> ?wait:int -> c -> unit mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_message.ml0000644000175000017500000001061112124403241023042 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open StdLabels open Tk open Jg_tk (* class formatted ~parent ~width ~maxheight ~minheight = val parent = (parent : Widget.any Widget.widget) val width = width val maxheight = maxheight val minheight = minheight val tw = Text.create ~parent ~width ~wrap:`Word val fof = Format.get_formatter_output_functions () method parent = parent method init = pack [tw] ~side:`Left ~fill:`Both ~expand:true; Format.print_flush (); Format.set_margin (width - 2); Format.set_formatter_output_functions ~out:(Jg_text.output tw) ~flush:(fun () -> ()) method finish = Format.print_flush (); Format.set_formatter_output_functions ~out:(fst fof) ~flush:(snd fof); let `Linechar (l, _) = Text.index tw ~index:(tposend 1) in Text.configure tw ~height:(max minheight (min l maxheight)); if l > 5 then pack [Jg_text.add_scrollbar tw] ~before:tw ~side:`Right ~fill:`Y end *) let formatted ~title ?on ?(ppf = Format.std_formatter) ?(width=60) ?(maxheight=10) ?(minheight=0) () = let tl, frame = match on with Some frame -> (* let label = Label.create frame ~anchor:`W ~padx:10 ~text:title in pack [label] ~side:`Top ~fill:`X; let frame2 = Frame.create frame in pack [frame2] ~side:`Bottom ~fill:`Both ~expand:true; *) coe frame, frame | None -> let tl = Jg_toplevel.titled title in Jg_bind.escape_destroy tl; let frame = Frame.create tl in pack [frame] ~side:`Top ~fill:`Both ~expand:true; coe tl, frame in let tw = Text.create frame ~width ~wrap:`Word in pack [tw] ~side:`Left ~fill:`Both ~expand:true; Format.pp_print_flush ppf (); Format.pp_set_margin ppf (width - 2); let fof,fff = Format.pp_get_formatter_output_functions ppf () in Format.pp_set_formatter_output_functions ppf (fun buf pos len -> Jg_text.output tw ~buf ~pos ~len) ignore; tl, tw, begin fun () -> Format.pp_print_flush ppf (); Format.pp_set_formatter_output_functions ppf fof fff; let `Linechar (l, _) = Text.index tw ~index:(tposend 1) in Text.configure tw ~height:(max minheight (min l maxheight)); if l > 5 then pack [Jg_text.add_scrollbar tw] ~before:tw ~side:`Right ~fill:`Y end let ask ~title ?master ?(no=true) ?(cancel=true) text = let tl = Jg_toplevel.titled title in begin match master with None -> () | Some master -> Wm.transient_set tl ~master end; let mw = Message.create tl ~text ~padx:20 ~pady:10 ~width:250 ~justify:`Left ~aspect:400 ~anchor:`W and fw = Frame.create tl and sync = Textvariable.create ~on:tl () and r = ref (`Cancel : [`Yes|`No|`Cancel]) in let accept = Button.create fw ~text:(if no || cancel then "Yes" else "Dismiss") ~command:(fun () -> r := `Yes; destroy tl) and refuse = Button.create fw ~text:"No" ~command:(fun () -> r := `No; destroy tl) and cancelB = Button.create fw ~text:"Cancel" ~command:(fun () -> r := `Cancel; destroy tl) in bind tl ~events:[`Destroy] ~extend:true ~action:(fun _ -> Textvariable.set sync "1"); pack [accept] ~side:`Left ~fill:`X ~expand:true; if no then pack [refuse] ~side:`Left ~fill:`X ~expand:true; if cancel then pack [cancelB] ~side:`Left ~fill:`X ~expand:true; pack [mw] ~side:`Top ~fill:`Both; pack [fw] ~side:`Bottom ~fill:`X ~expand:true; Grab.set tl; Tkwait.variable sync; !r let info ~title ?master text = ignore (ask ~title ?master ~no:false ~cancel:false text) mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_tk.ml0000644000175000017500000000240212124403241022033 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Tk let tpos ?(modi=[]) x : textIndex = `Linechar (1,0), `Char x :: modi and tposend ?(modi=[]) x : textIndex = `End, `Char (-x) :: modi let tstart : textIndex = `Linechar (1,0), [] and tend : textIndex = `End, [] let wingui = Sys.os_type = "Win32" || Sys.os_type = "Cygwin" mingw-ocaml/ocaml/otherlibs/labltk/browser/list2.ml0000644000175000017500000000216412124403241021777 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open StdLabels let exclude x l = List.filter l ~f:((<>) x) let rec flat_map ~f = function [] -> [] | x :: l -> f x @ flat_map ~f l mingw-ocaml/ocaml/otherlibs/labltk/browser/mytypes.mli0000644000175000017500000000257312124403241022631 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Widget type edit_window = { mutable name: string; tw: text widget; frame: frame widget; modified: Textvariable.textVariable; mutable shell: (string * Shell.shell) option; mutable structure: Typedtree.structure_item list; mutable type_info: Stypes.annotation list; mutable signature: Types.signature; mutable psignature: Parsetree.signature; number: string } mingw-ocaml/ocaml/otherlibs/labltk/browser/searchpos.mli0000644000175000017500000000621412124403241023102 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Widget val top_widgets : any widget list ref type module_widgets = { mw_frame: frame widget; mw_title: label widget option; mw_detach: button widget; mw_edit: button widget; mw_intf: button widget } val add_shown_module : Path.t -> widgets:module_widgets -> unit val find_shown_module : Path.t -> module_widgets val is_shown_module : Path.t -> bool val default_frame : module_widgets option ref val set_path : (Path.t -> sign:Types.signature -> unit) ref val view_defined_ref : (Longident.t -> env:Env.t -> unit) ref val editor_ref : (?file:string -> ?pos:int -> ?opendialog:bool -> unit -> unit) ref val view_signature : ?title:string -> ?path:Path.t -> ?env:Env.t -> ?detach:bool -> Types.signature -> unit val view_signature_item : Types.signature -> path:Path.t -> env:Env.t -> unit val view_module_id : Longident.t -> env:Env.t -> unit val view_type_id : Longident.t -> env:Env.t -> unit val view_class_id : Longident.t -> env:Env.t -> unit val view_cltype_id : Longident.t -> env:Env.t -> unit val view_modtype_id : Longident.t -> env:Env.t -> unit val view_type_decl : Path.t -> env:Env.t -> unit type skind = [`Type|`Class|`Module|`Modtype] val search_pos_signature : Parsetree.signature -> pos:int -> env:Env.t -> ((skind * Longident.t) * Env.t * Location.t) list val view_decl : Longident.t -> kind:skind -> env:Env.t -> unit val view_decl_menu : Longident.t -> kind:skind -> env:Env.t -> parent:text widget -> menu widget type fkind = [ `Exp of [`Expr|`Pat|`Const|`Val of Path.t|`Var of Path.t|`New of Path.t] * Types.type_expr | `Class of Path.t * Types.class_type | `Module of Path.t * Types.module_type ] val search_pos_structure : pos:int -> Typedtree.structure_item list -> (fkind * Env.t * Location.t) list val search_pos_info : pos:int -> Stypes.annotation list -> (fkind * Env.t * Location.t) list val view_type : fkind -> env:Env.t -> unit val view_type_menu : fkind -> env:Env.t -> parent:'a widget -> menu widget val parent_path : Path.t -> Path.t option val string_of_path : Path.t -> string val string_of_longident : Longident.t -> string val lines_to_chars : int -> text:string -> int mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_box.ml0000644000175000017500000000576612124403241022225 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Tk let add_scrollbar lb = let sb = Scrollbar.create (Winfo.parent lb) ~command:(Listbox.yview lb) in Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb); sb let create_with_scrollbar ?selectmode parent = let frame = Frame.create parent in let lb = Listbox.create frame ?selectmode in frame, lb, add_scrollbar lb (* from frx_listbox,adapted *) let recenter lb ~index = Listbox.selection_clear lb ~first:(`Num 0) ~last:`End; (* Activate it, to keep consistent with Up/Down. You have to be in Extended or Browse mode *) Listbox.activate lb ~index; Listbox.selection_anchor lb ~index; Listbox.yview_index lb ~index class timed ?wait ?nocase get_texts = object val get_texts = get_texts inherit Jg_completion.timed [] ?wait ?nocase as super method! reset = texts <- get_texts (); super#reset end let add_completion ?action ?wait ?nocase ?(double=true) lb = let comp = new timed ?wait ?nocase (fun () -> Listbox.get_range lb ~first:(`Num 0) ~last:`End) in Jg_bind.enter_focus lb; bind lb ~events:[`KeyPress] ~fields:[`Char] ~action: begin fun ev -> (* consider only keys producing characters. The callback is called even if you press Shift. *) if ev.ev_Char <> "" then recenter lb ~index:(`Num (comp#add ev.ev_Char)) end; begin match action with Some action -> bind lb ~events:[`KeyPressDetail "Return"] ~action:(fun _ -> action `Active); let bmod = if double then [`Double] else [] in bind lb ~events:[`Modified(bmod, `ButtonPressDetail 1)] ~breakable:true ~fields:[`MouseY] ~action: begin fun ev -> let index = Listbox.nearest lb ~y:ev.ev_MouseY in if not double then begin Listbox.selection_clear lb ~first:(`Num 0) ~last:`End; Listbox.selection_set lb ~first:index ~last:index; end; action index; break () end | None -> () end; recenter lb ~index:(`Num 0) (* so that first item is active *) mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_completion.ml0000644000175000017500000000373412124403241023577 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) let lt_string ?(nocase=false) s1 s2 = if nocase then String.lowercase s1 < String.lowercase s2 else s1 < s2 class completion ?nocase texts = object val mutable texts = texts val nocase = nocase val mutable prefix = "" val mutable current = 0 method add c = prefix <- prefix ^ c; while current < List.length texts - 1 && lt_string (List.nth texts current) prefix ?nocase do current <- current + 1 done; current method current = current method get_current = List.nth texts current method reset = prefix <- ""; current <- 0 end class timed ?nocase ?wait texts = object (self) inherit completion texts ?nocase as super val wait = match wait with None -> 500 | Some n -> n val mutable timer = None method! add c = begin match timer with None -> self#reset | Some t -> Timer.remove t end; timer <- Some (Timer.add ~ms:wait ~callback:(fun () -> self#reset)); super#add c method! reset = timer <- None; super#reset end mingw-ocaml/ocaml/otherlibs/labltk/browser/jglib.mllib0000644000175000017500000000017312124403241022516 0ustar tootstootsJg_tk Jg_config Jg_bind Jg_completion Jg_box Jg_button Jg_toplevel Jg_text Jg_message Jg_menu Jg_entry Jg_multibox Jg_memo mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_multibox.ml0000644000175000017500000001421612124403241023266 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open StdLabels let rec gen_list ~f:f ~len = if len = 0 then [] else f () :: gen_list ~f:f ~len:(len - 1) let rec make_list ~len ~fill = if len = 0 then [] else fill :: make_list ~len:(len - 1) ~fill (* By column version let rec firsts ~len l = if len = 0 then ([],l) else match l with a::l -> let (f,l) = firsts l len:(len - 1) in (a::f,l) | [] -> (l,[]) let rec split ~len = function [] -> [] | l -> let (f,r) = firsts l ~len in let ret = split ~len r in f :: ret let extend l ~len ~fill = if List.length l >= len then l else l @ make_list ~fill len:(len - List.length l) *) (* By row version *) let rec first l ~len = if len = 0 then [], l else match l with [] -> make_list ~len ~fill:"", [] | a::l -> let (l',r) = first ~len:(len - 1) l in a::l',r let rec split l ~len = if l = [] then make_list ~len ~fill:[] else let (cars,r) = first l ~len in let cdrs = split r ~len in List.map2 cars cdrs ~f:(fun a l -> a::l) open Tk class c ~cols ~texts ?maxheight ?width parent = object (self) val parent' = coe parent val length = List.length texts val boxes = let height = (List.length texts - 1) / cols + 1 in let height = match maxheight with None -> height | Some max -> min max height in gen_list ~len:cols ~f: begin fun () -> Listbox.create parent ~height ?width ~highlightthickness:0 ~borderwidth:1 end val mutable current = 0 method cols = cols method texts = texts method parent = parent' method boxes = boxes method current = current method recenter ?(aligntop=false) n = current <- if n < 0 then 0 else if n < length then n else length - 1; (* Activate it, to keep consistent with Up/Down. You have to be in Extended or Browse mode *) let box = List.nth boxes (current mod cols) and index = `Num (current / cols) in List.iter boxes ~f: begin fun box -> Listbox.selection_clear box ~first:(`Num 0) ~last:`End; Listbox.selection_anchor box ~index; Listbox.activate box ~index end; Focus.set box; if aligntop then Listbox.yview_index box ~index else Listbox.see box ~index; let (first,last) = Listbox.yview_get box in List.iter boxes ~f:(Listbox.yview ~scroll:(`Moveto first)) method init = let textl = split ~len:cols texts in List.iter2 boxes textl ~f: begin fun box texts -> Jg_bind.enter_focus box; Listbox.insert box ~texts ~index:`End end; pack boxes ~side:`Left ~expand:true ~fill:`Both; self#bind_mouse ~events:[`ButtonPressDetail 1] ~action:(fun _ ~index:n -> self#recenter n; break ()); let current_height () = let (top,bottom) = Listbox.yview_get (List.hd boxes) in truncate ((bottom -. top) *. float (Listbox.size (List.hd boxes)) +. 0.99) in List.iter [ "Right", (fun n -> n+1); "Left", (fun n -> n-1); "Up", (fun n -> n-cols); "Down", (fun n -> n+cols); "Prior", (fun n -> n - current_height () * cols); "Next", (fun n -> n + current_height () * cols); "Home", (fun _ -> 0); "End", (fun _ -> List.length texts) ] ~f:begin fun (key,f) -> self#bind_kbd ~events:[`KeyPressDetail key] ~action:(fun _ ~index:n -> self#recenter (f n); break ()) end; self#recenter 0 method bind_mouse ~events ~action = let i = ref 0 in List.iter boxes ~f: begin fun box -> let b = !i in bind box ~events ~breakable:true ~fields:[`MouseX;`MouseY] ~action:(fun ev -> let `Num n = Listbox.nearest box ~y:ev.ev_MouseY in action ev ~index:(n * cols + b)); incr i end method bind_kbd ~events ~action = let i = ref 0 in List.iter boxes ~f: begin fun box -> let b = !i in bind box ~events ~breakable:true ~fields:[`Char] ~action:(fun ev -> let `Num n = Listbox.index box ~index:`Active in action ev ~index:(n * cols + b)); incr i end end let add_scrollbar (box : c) = let boxes = box#boxes in let sb = Scrollbar.create (box#parent) ~command:(fun ~scroll -> List.iter boxes ~f:(Listbox.yview ~scroll)) in List.iter boxes ~f:(fun lb -> Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb)); pack [sb] ~before:(List.hd boxes) ~side:`Right ~fill:`Y; sb let add_completion ?action ?wait (box : c) = let comp = new Jg_completion.timed (box#texts) ?wait in box#bind_kbd ~events:[`KeyPress] ~action:(fun ev ~index -> (* consider only keys producing characters. The callback is called * even if you press Shift. *) if ev.ev_Char <> "" then box#recenter (comp#add ev.ev_Char) ~aligntop:true); match action with Some action -> box#bind_kbd ~events:[`KeyPressDetail "space"] ~action:(fun ev ~index -> action (box#current)); box#bind_kbd ~events:[`KeyPressDetail "Return"] ~action:(fun ev ~index -> action (box#current)); box#bind_mouse ~events:[`ButtonPressDetail 1] ~action:(fun ev ~index -> box#recenter index; action (box#current); break ()) | None -> () mingw-ocaml/ocaml/otherlibs/labltk/browser/fileselect.ml0000644000175000017500000002414212124403241023061 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) (* file selection box *) open StdLabels open Str open Filename open Tk open Useunix (**** Memoized rexgexp *) let (~!) = Jg_memo.fast ~f:Str.regexp (************************************************************ Path name *) (* Convert Windows-style directory separator '\' to caml-style '/' *) let caml_dir path = if Sys.os_type = "Win32" then global_replace ~!"\\\\" "/" path else path let parse_filter s = let s = caml_dir s in (* replace // by / *) let s = global_replace ~!"/+" "/" s in (* replace /./ by / *) let s = global_replace ~!"/\\./" "/" s in (* replace hoge/../ by "" *) let s = global_replace ~!"\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\./" "" s in (* replace hoge/..$ by *) let s = global_replace ~!"\\([^/]\\|[^\\./][^/]\\|[^/][^\\./]\\|[^/][^/]+\\)/\\.\\.$" "" s in (* replace ^/hoge/../ by / *) let s = global_replace ~!"^\\(/\\.\\.\\)+/" "/" s in if string_match ~!"^\\([^\\*?[]*[/:]\\)\\(.*\\)" s 0 then let dirs = matched_group 1 s and ptrn = matched_group 2 s in dirs, ptrn else "", s let rec fixpoint ~f v = let v' = f v in if v = v' then v else fixpoint ~f v' let unix_regexp s = let s = Str.global_replace ~!"[$^.+]" "\\\\\\0" s in let s = Str.global_replace ~!"\\*" ".*" s in let s = Str.global_replace ~!"\\?" ".?" s in let s = fixpoint s ~f:(Str.replace_first ~!"\\({.*\\),\\(.*}\\)" "\\1\\|\\2") in let s = Str.global_replace ~!"{\\(.*\\)}" "\\(\\1\\)" s in Str.regexp s let exact_match ~pat s = Str.string_match pat s 0 && Str.match_end () = String.length s let ls ~dir ~pattern = let files = get_files_in_directory dir in let regexp = unix_regexp pattern in List.filter files ~f:(exact_match ~pat:regexp) (********************************************* Creation *) let load_in_path = ref false let search_in_path ~name = Misc.find_in_path !Config.load_path name let f ~title ~action:proc ?(dir = Unix.getcwd ()) ?filter:(deffilter ="*") ?file:(deffile ="") ?(multi=false) ?(sync=false) ?(usepath=true) () = let current_pattern = ref "" and current_dir = ref (caml_dir dir) in let may_prefix name = if Filename.is_relative name then concat !current_dir name else name in let tl = Jg_toplevel.titled title in Focus.set tl; let new_var () = Textvariable.create ~on:tl () in let filter_var = new_var () and selection_var = new_var () and sync_var = new_var () in Textvariable.set filter_var deffilter; let frm = Frame.create tl ~borderwidth:1 ~relief:`Raised in let df = Frame.create frm in let dfl = Frame.create df in let dfll = Label.create dfl ~text:"Directories" in let dflf, directory_listbox, directory_scrollbar = Jg_box.create_with_scrollbar dfl in let dfr = Frame.create df in let dfrl = Label.create dfr ~text:"Files" in let dfrf, filter_listbox, filter_scrollbar = Jg_box.create_with_scrollbar dfr in let cfrm = Frame.create tl ~borderwidth:1 ~relief:`Raised in let configure ~filter = let filter = may_prefix filter in let dir, pattern = parse_filter filter in let dir = if !load_in_path && usepath then "" else (current_dir := Filename.dirname dir; dir) and pattern = if pattern = "" then "*" else pattern in current_pattern := pattern; let filter = if !load_in_path && usepath then pattern else dir ^ pattern in let directories = get_directories_in_files ~path:dir (get_files_in_directory dir) in let matched_files = (* get matched file by subshell call. *) if !load_in_path && usepath then List.fold_left !Config.load_path ~init:[] ~f: begin fun acc dir -> let files = ls ~dir ~pattern in Sort.merge (<) files (List.fold_left files ~init:acc ~f:(fun acc name -> List2.exclude name acc)) end else List.fold_left directories ~init:(ls ~dir ~pattern) ~f:(fun acc dir -> List2.exclude dir acc) in Textvariable.set filter_var filter; Textvariable.set selection_var (dir ^ deffile); Listbox.delete filter_listbox ~first:(`Num 0) ~last:`End; Listbox.insert filter_listbox ~index:`End ~texts:matched_files; Jg_box.recenter filter_listbox ~index:(`Num 0); if !load_in_path && usepath then Listbox.configure directory_listbox ~takefocus:false else begin Listbox.configure directory_listbox ~takefocus:true; Listbox.delete directory_listbox ~first:(`Num 0) ~last:`End; Listbox.insert directory_listbox ~index:`End ~texts:directories; Jg_box.recenter directory_listbox ~index:(`Num 0) end in let selected_files = ref [] in (* used for synchronous mode *) let activate l = Grab.release tl; destroy tl; let l = if !load_in_path && usepath then List.fold_right l ~init:[] ~f: begin fun name acc -> if not (Filename.is_implicit name) then may_prefix name :: acc else try search_in_path ~name :: acc with Not_found -> acc end else List.map l ~f:may_prefix in if sync then begin selected_files := l; Textvariable.set sync_var "1" end else proc l in (* entries *) let fl = Label.create frm ~text:"Filter" in let sl = Label.create frm ~text:"Selection" in let filter_entry = Jg_entry.create frm ~textvariable:filter_var ~command:(fun filter -> configure ~filter) in let selection_entry = Jg_entry.create frm ~textvariable:selection_var ~command:(fun file -> activate [file]) in (* and buttons *) let set_path = Button.create dfl ~text:"Path editor" ~command: begin fun () -> Setpath.add_update_hook (fun () -> configure ~filter:!current_pattern); let w = Setpath.f ~dir:!current_dir in Grab.set w; bind w ~events:[`Destroy] ~extend:true ~action:(fun _ -> Grab.set tl) end in let toggle_in_path = Checkbutton.create dfl ~text:"Use load path" ~command: begin fun () -> load_in_path := not !load_in_path; if !load_in_path then pack [set_path] ~side:`Bottom ~fill:`X ~expand:true else Pack.forget [set_path]; configure ~filter:(Textvariable.get filter_var) end and okb = Button.create cfrm ~text:"Ok" ~command: begin fun () -> let files = List.map (Listbox.curselection filter_listbox) ~f: begin fun x -> !current_dir ^ Listbox.get filter_listbox ~index:x end in let files = if files = [] then [Textvariable.get selection_var] else files in activate files end and flb = Button.create cfrm ~text:"Filter" ~command:(fun () -> configure ~filter:(Textvariable.get filter_var)) and ccb = Button.create cfrm ~text:"Cancel" ~command:(fun () -> activate []) in (* binding *) bind tl ~events:[`KeyPressDetail "Escape"] ~action:(fun _ -> activate []); Jg_box.add_completion filter_listbox ~action:(fun index -> activate [Listbox.get filter_listbox ~index]); if multi then Listbox.configure filter_listbox ~selectmode:`Multiple else bind filter_listbox ~events:[`ButtonPressDetail 1] ~fields:[`MouseY] ~action:(fun ev -> let name = Listbox.get filter_listbox ~index:(Listbox.nearest filter_listbox ~y:ev.ev_MouseY) in if !load_in_path && usepath then try Textvariable.set selection_var (search_in_path ~name) with Not_found -> () else Textvariable.set selection_var (may_prefix name)); Jg_box.add_completion directory_listbox ~action: begin fun index -> let filter = may_prefix (Listbox.get directory_listbox ~index) ^ "/" ^ !current_pattern in configure ~filter end; pack [frm] ~fill:`Both ~expand:true; (* filter *) pack [fl] ~side:`Top ~anchor:`W; pack [filter_entry] ~side:`Top ~fill:`X; (* directory + files *) pack [df] ~side:`Top ~fill:`Both ~expand:true; (* directory *) pack [dfl] ~side:`Left ~fill:`Both ~expand:true; pack [dfll] ~side:`Top ~anchor:`W; if usepath then pack [toggle_in_path] ~side:`Bottom ~anchor:`W; pack [dflf] ~side:`Top ~fill:`Both ~expand:true; pack [directory_scrollbar] ~side:`Right ~fill:`Y; pack [directory_listbox] ~side:`Left ~fill:`Both ~expand:true; (* files *) pack [dfr] ~side:`Right ~fill:`Both ~expand:true; pack [dfrl] ~side:`Top ~anchor:`W; pack [dfrf] ~side:`Top ~fill:`Both ~expand:true; pack [filter_scrollbar] ~side:`Right ~fill:`Y; pack [filter_listbox] ~side:`Left ~fill:`Both ~expand:true; (* selection *) pack [sl] ~before:df ~side:`Bottom ~anchor:`W; pack [selection_entry] ~before:sl ~side:`Bottom ~fill:`X; (* create OK, Filter and Cancel buttons *) pack [okb; flb; ccb] ~side:`Left ~fill:`X ~expand:true; pack [cfrm] ~before:frm ~side:`Bottom ~fill:`X; if !load_in_path && usepath then begin load_in_path := false; Checkbutton.invoke toggle_in_path; Checkbutton.select toggle_in_path end else configure ~filter:deffilter; Tkwait.visibility tl; Grab.set tl; if sync then begin Tkwait.variable sync_var; proc !selected_files end; () mingw-ocaml/ocaml/otherlibs/labltk/browser/dummyWin.mli0000644000175000017500000000175012124403241022724 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2000 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) mingw-ocaml/ocaml/otherlibs/labltk/browser/Makefile.shared0000644000175000017500000000527612124403241023324 0ustar tootstootsinclude ../support/Makefile.common ######################################################################### # # # OCaml LablTk library # # # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique and Kyoto University. All rights reserved. # # This file is distributed under the terms of the GNU Library # # General Public License, with the special exception on linking # # described in file ../../../LICENSE. # # # ######################################################################### LABLTKLIB=-I ../labltk -I ../lib -I ../support OCAMLTOPLIB=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils -I $(TOPDIR)/typing INCLUDES=$(OTHERSLIB) $(LABLTKLIB) $(OCAMLTOPLIB) OBJ = list2.cmo useunix.cmo setpath.cmo lexical.cmo \ fileselect.cmo searchid.cmo searchpos.cmo shell.cmo \ help.cmo \ viewer.cmo typecheck.cmo editor.cmo main.cmo JG = jg_tk.cmo jg_config.cmo jg_bind.cmo jg_completion.cmo \ jg_box.cmo \ jg_button.cmo jg_toplevel.cmo jg_text.cmo jg_message.cmo \ jg_menu.cmo jg_entry.cmo jg_multibox.cmo jg_memo.cmo # Default rules .SUFFIXES: .ml .mli .cmo .cmi .cmx .c .$(O) .ml.cmo: $(CAMLCOMP) $(INCLUDES) $< .mli.cmi: $(CAMLCOMP) $(INCLUDES) $< .c.$(O): $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< all: ocamlbrowser$(EXE) ocamlbrowser$(EXE): $(TOPDIR)/compilerlibs/ocamlcommon.cma jglib.cma $(OBJ) \ ../support/lib$(LIBNAME).$(A) $(XTRAOBJ) $(CAMLC) -o ocamlbrowser$(EXE) $(INCLUDES) \ $(TOPDIR)/compilerlibs/ocamlcommon.cma \ unix.cma str.cma $(XTRALIBS) $(LIBNAME).cma jglib.cma \ $(OBJ) $(XTRAOBJ) ocamlbrowser.cma: jglib.cma $(OBJ) $(CAMLC) -a -o $@ -linkall jglib.cma $(OBJ) jglib.cma: $(JG) $(CAMLC) -a -o $@ $(JG) help.ml: echo 'let text = "\\' > $@ sed -e 's/^ /\\032/' -e 's/$$/\\n\\/' help.txt >> $@ echo '";;' >> $@ install: if test -f ocamlbrowser$(EXE); then : ; \ cp ocamlbrowser$(EXE) $(BINDIR); fi clean: rm -f *.cm? ocamlbrowser$(EXE) dummy.mli *~ *.orig *.$(O) help.ml depend: help.ml $(CAMLDEP) $(LABLTKLIB) $(OCAMLTOPLIB) *.ml *.mli > .depend shell.cmo: dummy.cmi setpath.cmo fileselect.cmo lexical.cmi searchid.cmi typecheck.cmi: $(TOPDIR)/compilerlibs/ocamlcommon.cma mytypes.cmi searchpos.cmi searchpos.cmo typecheck.cmo: $(TOPDIR)/typing/stypes.cmi include .depend mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_config.ml0000644000175000017500000000364312124403241022672 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open StdLabels open Jg_tk let fixed = if wingui then "{Courier New} 8" else "fixed" let variable = if wingui then "Arial 9" else "variable" let init () = if wingui then Option.add ~path:"*font" fixed; let font = let font = Option.get Widget.default_toplevel ~name:"variableFont" ~clas:"Font" in if font = "" then variable else font in List.iter ["Button"; "Label"; "Menu"; "Menubutton"; "Radiobutton"] ~f:(fun cl -> Option.add ~path:("*" ^ cl ^ ".font") font); Option.add ~path:"*Menu.tearOff" "0" ~priority:`StartupFile; Option.add ~path:"*Button.padY" "0" ~priority:`StartupFile; Option.add ~path:"*Text.highlightThickness" "0" ~priority:`StartupFile; Option.add ~path:"*interface.background" "gray85" ~priority:`StartupFile; let foreground = Option.get Widget.default_toplevel ~name:"disabledForeground" ~clas:"Foreground" in if foreground = "" then Option.add ~path:"*disabledForeground" "black" mingw-ocaml/ocaml/otherlibs/labltk/browser/useunix.ml0000644000175000017500000000432312124403241022441 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open StdLabels open UnixLabels let get_files_in_directory dir = let len = String.length dir in let dir = if len > 0 && Sys.os_type = "Win32" && (dir.[len-1] = '/' || dir.[len-1] = '\\') then String.sub dir ~pos:0 ~len:(len-1) else dir in match try Some(opendir dir) with Unix_error _ -> None with None -> [] | Some dirh -> let rec get_them l = match try Some(readdir dirh) with _ -> None with | Some x -> get_them (x::l) | None -> closedir dirh; l in List.sort ~cmp:compare (get_them []) let is_directory name = try (stat name).st_kind = S_DIR with _ -> false let concat dir name = let len = String.length dir in if len = 0 then name else if dir.[len-1] = '/' then dir ^ name else dir ^ "/" ^ name let get_directories_in_files ~path = List.filter ~f:(fun x -> is_directory (concat path x)) (************************************************** Subshell call *) let subshell ~cmd = let rc = open_process_in cmd in let rec it l = match try Some(input_line rc) with _ -> None with Some x -> it (x::l) | None -> List.rev l in let answer = it [] in ignore (close_process_in rc); answer mingw-ocaml/ocaml/otherlibs/labltk/browser/shell.ml0000644000175000017500000003171212124403241022052 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open StdLabels module Unix = UnixLabels open Tk open Jg_tk open Dummy (* Here again, memoize regexps *) let (~!) = Jg_memo.fast ~f:Str.regexp (* Nice history class. May reuse *) class ['a] history () = object val mutable history = ([] : 'a list) val mutable count = 0 method empty = history = [] method add s = count <- 0; history <- s :: history method previous = let s = List.nth history count in count <- (count + 1) mod List.length history; s method next = let l = List.length history in count <- (l + count - 1) mod l; List.nth history ((l + count - 1) mod l) end let dump_handle (h : Unix.file_descr) = let obj = Obj.repr h in if Obj.is_int obj || Obj.tag obj <> Obj.custom_tag then invalid_arg "Shell.dump_handle"; Nativeint.format "%x" (Obj.obj obj) (* The shell class. Now encapsulated *) let protect f x = try f x with _ -> () let is_win32 = Sys.os_type = "Win32" let use_threads = is_win32 let use_sigpipe = is_win32 class shell ~textw ~prog ~args ~env ~history = let (in2,out1) = Unix.pipe () and (in1,out2) = Unix.pipe () and (err1,err2) = Unix.pipe () and (sig2,sig1) = Unix.pipe () in object (self) val pid = let env = if use_sigpipe then let sigdef = "CAMLSIGPIPE=" ^ dump_handle sig2 in Array.append env [|sigdef|] else env in Unix.create_process_env ~prog ~args ~env ~stdin:in2 ~stdout:out2 ~stderr:err2 val out = Unix.out_channel_of_descr out1 val h : _ history = history val mutable alive = true val mutable reading = false val ibuffer = Buffer.create 1024 val imutex = Mutex.create () val mutable ithreads = [] method alive = alive method kill = if Winfo.exists textw then Text.configure textw ~state:`Disabled; if alive then begin alive <- false; protect close_out out; try if use_sigpipe then ignore (Unix.write sig1 ~buf:"T" ~pos:0 ~len:1); List.iter ~f:(protect Unix.close) [in1; err1; sig1; sig2]; if not use_threads then begin Fileevent.remove_fileinput ~fd:in1; Fileevent.remove_fileinput ~fd:err1; end; if not use_sigpipe then begin Unix.kill ~pid ~signal:Sys.sigkill; ignore (Unix.waitpid ~mode:[] pid) end with _ -> () end method interrupt = if alive then try reading <- false; if use_sigpipe then begin ignore (Unix.write sig1 ~buf:"C" ~pos:0 ~len:1); self#send " " end else Unix.kill ~pid ~signal:Sys.sigint with Unix.Unix_error _ -> () method send s = if alive then try output_string out s; flush out with Sys_error _ -> () method private read ~fd ~len = begin try let buf = String.create len in let len = Unix.read fd ~buf ~pos:0 ~len in if len > 0 then begin self#insert (String.sub buf ~pos:0 ~len); Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)]) end; len with Unix.Unix_error _ -> 0 end; method history (dir : [`Next|`Previous]) = if not h#empty then begin if reading then begin Text.delete textw ~start:(`Mark"input",[`Char 1]) ~stop:(`Mark"insert",[]) end else begin reading <- true; Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)]) end; self#insert (if dir = `Previous then h#previous else h#next) end method private lex ?(start = `Mark"insert",[`Linestart]) ?(stop = `Mark"insert",[`Lineend]) () = Lexical.tag textw ~start ~stop method insert text = let idx = Text.index textw ~index:(`Mark"insert",[`Char(-1);`Linestart]) in Text.insert textw ~text ~index:(`Mark"insert",[]); self#lex ~start:(idx,[`Linestart]) (); Text.see textw ~index:(`Mark"insert",[]) method private keypress c = if not reading && c > " " then begin reading <- true; Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)]) end method private keyrelease c = if c <> "" then self#lex () method private return = if reading then reading <- false else Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Linestart;`Char 1]); Text.mark_set textw ~mark:"insert" ~index:(`Mark"insert",[`Lineend]); self#lex ~start:(`Mark"input",[`Linestart]) (); let s = (* input is one character before real input *) Text.get textw ~start:(`Mark"input",[`Char 1]) ~stop:(`Mark"insert",[]) in h#add s; Text.insert textw ~index:(`Mark"insert",[]) ~text:"\n"; Text.yview_index textw ~index:(`Mark"insert",[]); self#send s; self#send "\n" method private paste ev = if not reading then begin reading <- true; Text.mark_set textw ~mark:"input" ~index:(`Atxy(ev.ev_MouseX, ev.ev_MouseY),[`Char(-1)]) end initializer Lexical.init_tags textw; let rec bindings = [ ([], `KeyPress, [`Char], fun ev -> self#keypress ev.ev_Char); ([], `KeyRelease, [`Char], fun ev -> self#keyrelease ev.ev_Char); (* [], `KeyPressDetail"Return", [], fun _ -> self#return; *) ([], `ButtonPressDetail 2, [`MouseX; `MouseY], self#paste); ([`Alt], `KeyPressDetail"p", [], fun _ -> self#history `Previous); ([`Alt], `KeyPressDetail"n", [], fun _ -> self#history `Next); ([`Meta], `KeyPressDetail"p", [], fun _ -> self#history `Previous); ([`Meta], `KeyPressDetail"n", [], fun _ -> self#history `Next); ([`Control], `KeyPressDetail"c", [], fun _ -> self#interrupt); ([], `Destroy, [], fun _ -> self#kill) ] in List.iter bindings ~f: begin fun (modif,event,fields,action) -> bind textw ~events:[`Modified(modif,event)] ~fields ~action end; bind textw ~events:[`KeyPressDetail"Return"] ~breakable:true ~action:(fun _ -> self#return; break()); List.iter ~f:Unix.close [in2;out2;err2]; if use_threads then begin let fileinput_thread fd = let buf = String.create 1024 in let len = ref 0 in try while len := Unix.read fd ~buf ~pos:0 ~len:1024; !len > 0 do Mutex.lock imutex; Buffer.add_substring ibuffer buf 0 !len; Mutex.unlock imutex done with Unix.Unix_error _ -> () in ithreads <- List.map [in1; err1] ~f:(Thread.create fileinput_thread); let rec read_buffer () = Mutex.lock imutex; if Buffer.length ibuffer > 0 then begin self#insert (Str.global_replace ~!"\r\n" "\n" (Buffer.contents ibuffer)); Buffer.reset ibuffer; Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Char(-1)]) end; Mutex.unlock imutex; Timer.set ~ms:100 ~callback:read_buffer in read_buffer () end else begin try List.iter [in1;err1] ~f: begin fun fd -> Fileevent.add_fileinput ~fd ~callback:(fun () -> ignore (self#read ~fd ~len:1024)) end with _ -> () end end (* Specific use of shell, for OCamlBrowser *) let shells : (string * shell) list ref = ref [] (* Called before exiting *) let kill_all () = List.iter !shells ~f:(fun (_,sh) -> if sh#alive then sh#kill); shells := [] let get_all () = let all = List.filter !shells ~f:(fun (_,sh) -> sh#alive) in shells := all; all let may_exec_unix prog = try Unix.access prog ~perm:[Unix.X_OK]; prog with Unix.Unix_error _ -> "" let may_exec_win prog = let has_ext = List.exists ~f:(Filename.check_suffix prog) ["exe"; "com"; "bat"] in if has_ext then may_exec_unix prog else List.fold_left [prog^".bat"; prog^".exe"; prog^".com"] ~init:"" ~f:(fun res prog -> if res = "" then may_exec_unix prog else res) let may_exec = if is_win32 then may_exec_win else may_exec_unix let path_sep = if is_win32 then ";" else ":" let warnings = ref Warnings.defaults_w let program_not_found prog = Jg_message.info ~title:"Error" ("Program \"" ^ prog ^ "\"\nwas not found in path") let protect_arg s = if String.contains s ' ' then "\"" ^ s ^ "\"" else s let f ~prog ~title = let progargs = List.filter ~f:((<>) "") (Str.split ~!" " prog) in if progargs = [] then () else let prog = List.hd progargs in let path = try Sys.getenv "PATH" with Not_found -> "/bin" ^ path_sep ^ "/usr/bin" in let exec_path = Str.split ~!path_sep path in let exec_path = if is_win32 then "."::exec_path else exec_path in let progpath = if not (Filename.is_implicit prog) then may_exec prog else List.fold_left exec_path ~init:"" ~f: (fun res dir -> if res = "" then may_exec (Filename.concat dir prog) else res) in if progpath = "" then program_not_found prog else let tl = Jg_toplevel.titled title in let menus = Menu.create tl ~name:"menubar" ~typ:`Menubar in Toplevel.configure tl ~menu:menus; let file_menu = new Jg_menu.c "File" ~parent:menus and history_menu = new Jg_menu.c "History" ~parent:menus and signal_menu = new Jg_menu.c "Signal" ~parent:menus in let frame, tw, sb = Jg_text.create_with_scrollbar tl in Text.configure tw ~background:`White; pack [sb] ~fill:`Y ~side:`Right; pack [tw] ~fill:`Both ~expand:true ~side:`Left; pack [frame] ~fill:`Both ~expand:true; let env = Array.map (Unix.environment ()) ~f: begin fun s -> if Str.string_match ~!"TERM=" s 0 then "TERM=dumb" else s end in let load_path = List2.flat_map !Config.load_path ~f:(fun dir -> ["-I"; dir]) in let load_path = if is_win32 then List.map ~f:protect_arg load_path else load_path in let labels = if !Clflags.classic then ["-nolabels"] else [] in let rectypes = if !Clflags.recursive_types then ["-rectypes"] else [] in let warnings = if List.mem "-w" progargs || !warnings = "Al" then [] else ["-w"; !warnings] in let args = Array.of_list (progargs @ labels @ warnings @ rectypes @ load_path) in let history = new history () in let start_shell () = let sh = new shell ~textw:tw ~prog:progpath ~env ~args ~history in shells := (title, sh) :: !shells; sh in let sh = ref (start_shell ()) in let current_dir = ref (Unix.getcwd ()) in file_menu#add_command "Restart" ~command: begin fun () -> (!sh)#kill; Text.configure tw ~state:`Normal; Text.insert tw ~index:(`End,[]) ~text:"\n"; Text.see tw ~index:(`End,[]); Text.mark_set tw ~mark:"insert" ~index:(`End,[]); sh := start_shell (); end; file_menu#add_command "Use..." ~command: begin fun () -> Fileselect.f ~title:"Use File" ~filter:"*.ml" ~sync:true ~dir:!current_dir () ~action:(fun l -> if l = [] then () else let name = Fileselect.caml_dir (List.hd l) in current_dir := Filename.dirname name; if Filename.check_suffix name ".ml" then let cmd = "#use \"" ^ String.escaped name ^ "\";;\n" in (!sh)#insert cmd; (!sh)#send cmd) end; file_menu#add_command "Load..." ~command: begin fun () -> Fileselect.f ~title:"Load File" ~filter:"*.cm[oa]" ~sync:true () ~dir:!current_dir ~action:(fun l -> if l = [] then () else let name = Fileselect.caml_dir (List.hd l) in current_dir := Filename.dirname name; if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma" then let cmd = "#load \"" ^ String.escaped name ^ "\";;\n" in (!sh)#insert cmd; (!sh)#send cmd) end; file_menu#add_command "Import path" ~command: begin fun () -> List.iter (List.rev !Config.load_path) ~f: (fun dir -> (!sh)#send ("#directory \"" ^ String.escaped dir ^ "\";;\n")) end; file_menu#add_command "Close" ~command:(fun () -> destroy tl); history_menu#add_command "Previous " ~accelerator:"M-p" ~command:(fun () -> (!sh)#history `Previous); history_menu#add_command "Next" ~accelerator:"M-n" ~command:(fun () -> (!sh)#history `Next); signal_menu#add_command "Interrupt " ~accelerator:"C-c" ~command:(fun () -> (!sh)#interrupt); signal_menu#add_command "Kill" ~command:(fun () -> (!sh)#kill) mingw-ocaml/ocaml/otherlibs/labltk/browser/editor.mli0000644000175000017500000000213612124403241022400 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Widget val f : ?file:string -> ?pos:int -> ?opendialog:bool -> unit -> unit (* open the file editor *) mingw-ocaml/ocaml/otherlibs/labltk/browser/searchid.ml0000644000175000017500000004523512124403241022532 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Asttypes open StdLabels open Location open Longident open Path open Types open Typedtree open Env open Btype open Ctype (* only initial here, but replaced by Pervasives later *) let start_env = ref initial let module_list = ref [] type pkind = Pvalue | Ptype | Plabel | Pconstructor | Pmodule | Pmodtype | Pclass | Pcltype let string_of_kind = function Pvalue -> "v" | Ptype -> "t" | Plabel -> "l" | Pconstructor -> "cn" | Pmodule -> "m" | Pmodtype -> "s" | Pclass -> "c" | Pcltype -> "ct" let rec longident_of_path = function Pident id -> Lident (Ident.name id) | Pdot (path, s, _) -> Ldot (longident_of_path path, s) | Papply (p1, p2) -> Lapply (longident_of_path p1, longident_of_path p2) let rec remove_prefix lid ~prefix = let rec remove_hd lid ~name = match lid with Ldot (Lident s1, s2) when s1 = name -> Lident s2 | Ldot (l, s) -> Ldot (remove_hd ~name l, s) | _ -> raise Not_found in match prefix with [] -> lid | name :: prefix -> try remove_prefix ~prefix (remove_hd ~name lid) with Not_found -> lid let rec permutations l = match l with [] | [_] -> [l] | [a;b] -> [l; [b;a]] | _ -> let _, perms = List.fold_left l ~init:(l,[]) ~f: begin fun (l, perms) a -> let l = List.tl l in l @ [a], List.map (permutations l) ~f:(fun l -> a :: l) @ perms end in perms let rec choose n ~card:l = let len = List.length l in if n = len then [l] else if n = 1 then List.map l ~f:(fun x -> [x]) else if n = 0 then [[]] else if n > len then [] else match l with [] -> [] | a :: l -> List.map (choose (n-1) ~card:l) ~f:(fun l -> a :: l) @ choose n ~card:l let rec arr p ~card:n = if p = 0 then 1 else n * arr (p-1) ~card:(n-1) let rec all_args ty = let ty = repr ty in match ty.desc with Tarrow(l, ty1, ty2, _) -> let (tl,ty) = all_args ty2 in ((l,ty1)::tl, ty) | _ -> ([], ty) let rec equal ~prefix t1 t2 = match (repr t1).desc, (repr t2).desc with Tvar _, Tvar _ -> true | Tvariant row1, Tvariant row2 -> let row1 = row_repr row1 and row2 = row_repr row2 in let fields1 = filter_row_fields false row1.row_fields and fields2 = filter_row_fields false row1.row_fields in let r1, r2, pairs = merge_row_fields fields1 fields2 in row1.row_closed = row2.row_closed && r1 = [] && r2 = [] && List.for_all pairs ~f: begin fun (_,f1,f2) -> match row_field_repr f1, row_field_repr f2 with Rpresent None, Rpresent None -> true | Rpresent(Some t1), Rpresent (Some t2) -> equal t1 t2 ~prefix | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) -> c1 = c2 && List.length tl1 = List.length tl2 && List.for_all2 tl1 tl2 ~f:(equal ~prefix) | _ -> false end | Tarrow _, Tarrow _ -> let l1, t1 = all_args t1 and l2, t2 = all_args t2 in equal t1 t2 ~prefix && List.length l1 = List.length l2 && List.exists (permutations l1) ~f: begin fun l1 -> List.for_all2 l1 l2 ~f: begin fun (p1,t1) (p2,t2) -> (p1 = "" || p1 = p2) && equal t1 t2 ~prefix end end | Ttuple l1, Ttuple l2 -> List.length l1 = List.length l2 && List.for_all2 l1 l2 ~f:(equal ~prefix) | Tconstr (p1, l1, _), Tconstr (p2, l2, _) -> remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2) && List.length l1 = List.length l2 && List.for_all2 l1 l2 ~f:(equal ~prefix) | _ -> false let is_opt s = s <> "" && s.[0] = '?' let get_options = List.filter ~f:is_opt let rec included ~prefix t1 t2 = match (repr t1).desc, (repr t2).desc with Tvar _, _ -> true | Tvariant row1, Tvariant row2 -> let row1 = row_repr row1 and row2 = row_repr row2 in let fields1 = filter_row_fields false row1.row_fields and fields2 = filter_row_fields false row2.row_fields in let r1, r2, pairs = merge_row_fields fields1 fields2 in r1 = [] && List.for_all pairs ~f: begin fun (_,f1,f2) -> match row_field_repr f1, row_field_repr f2 with Rpresent None, Rpresent None -> true | Rpresent(Some t1), Rpresent (Some t2) -> included t1 t2 ~prefix | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) -> c1 = c2 && List.length tl1 = List.length tl2 && List.for_all2 tl1 tl2 ~f:(included ~prefix) | _ -> false end | Tarrow _, Tarrow _ -> let l1, t1 = all_args t1 and l2, t2 = all_args t2 in included t1 t2 ~prefix && let len1 = List.length l1 and len2 = List.length l2 in let l2 = if arr len1 ~card:len2 < 100 then l2 else let ll1 = get_options (fst (List.split l1)) in List.filter l2 ~f:(fun (l,_) -> not (is_opt l) || List.mem l ll1) in len1 <= len2 && List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f: begin fun l2 -> List.for_all2 l1 l2 ~f: begin fun (p1,t1) (p2,t2) -> (p1 = "" || p1 = p2) && included t1 t2 ~prefix end end | Ttuple l1, Ttuple l2 -> let len1 = List.length l1 in len1 <= List.length l2 && List.exists (List2.flat_map ~f:permutations (choose len1 ~card:l2)) ~f: begin fun l2 -> List.for_all2 l1 l2 ~f:(included ~prefix) end | _, Ttuple _ -> included (newty (Ttuple [t1])) t2 ~prefix | Tconstr (p1, l1, _), Tconstr (p2, l2, _) -> remove_prefix ~prefix (longident_of_path p1) = (longident_of_path p2) && List.length l1 = List.length l2 && List.for_all2 l1 l2 ~f:(included ~prefix) | _ -> false let mklid = function [] -> raise (Invalid_argument "Searchid.mklid") | x :: l -> List.fold_left l ~init:(Lident x) ~f:(fun acc x -> Ldot (acc, x)) let mkpath = function [] -> raise (Invalid_argument "Searchid.mklid") | x :: l -> List.fold_left l ~init:(Pident (Ident.create x)) ~f:(fun acc x -> Pdot (acc, x, 0)) let get_fields ~prefix ~sign self = let env = open_signature (mkpath prefix) sign initial in match (expand_head env self).desc with Tobject (ty_obj, _) -> let l,_ = flatten_fields ty_obj in l | _ -> [] let rec search_type_in_signature t ~sign ~prefix ~mode = let matches = match mode with `Included -> included t ~prefix | `Exact -> equal t ~prefix and lid_of_id id = mklid (prefix @ [Ident.name id]) in List2.flat_map sign ~f: begin fun item -> match item with Sig_value (id, vd) -> if matches vd.val_type then [lid_of_id id, Pvalue] else [] | Sig_type (id, td, _) -> if matches (newconstr (Pident id) td.type_params) || begin match td.type_manifest with None -> false | Some t -> matches t end || begin match td.type_kind with Type_abstract -> false | Type_variant l -> List.exists l ~f: begin fun (_, l, r) -> List.exists l ~f:matches || match r with None -> false | Some x -> matches x end | Type_record(l, rep) -> List.exists l ~f:(fun (_, _, t) -> matches t) end then [lid_of_id id, Ptype] else [] | Sig_exception (id, l) -> if List.exists l.exn_args ~f:matches then [lid_of_id id, Pconstructor] else [] | Sig_module (id, Mty_signature sign, _) -> search_type_in_signature t ~sign ~mode ~prefix:(prefix @ [Ident.name id]) | Sig_module _ -> [] | Sig_modtype _ -> [] | Sig_class (id, cl, _) -> let self = self_type cl.cty_type in if matches self || (match cl.cty_new with None -> false | Some ty -> matches ty) (* || List.exists (get_fields ~prefix ~sign self) ~f:(fun (_,_,ty_field) -> matches ty_field) *) then [lid_of_id id, Pclass] else [] | Sig_class_type (id, cl, _) -> let self = self_type cl.clty_type in if matches self (* || List.exists (get_fields ~prefix ~sign self) ~f:(fun (_,_,ty_field) -> matches ty_field) *) then [lid_of_id id, Pclass] else [] end let search_all_types t ~mode = let tl = match mode, t.desc with `Exact, _ -> [t] | `Included, Tarrow _ -> [t] | `Included, _ -> [t; newty(Tarrow("",t,newvar(),Cok)); newty(Tarrow("",newvar(),t,Cok))] in List2.flat_map !module_list ~f: begin fun modname -> let mlid = Lident modname in try match lookup_module mlid initial with _, Mty_signature sign -> List2.flat_map tl ~f:(search_type_in_signature ~sign ~prefix:[modname] ~mode) | _ -> [] with Not_found | Env.Error _ -> [] end exception Error of int * int let search_string_type text ~mode = try let sexp = Parse.interface (Lexing.from_string ("val z : " ^ text)) in let sign = try (Typemod.transl_signature !start_env sexp).sig_type with _ -> let env = List.fold_left !module_list ~init:initial ~f: begin fun acc m -> try open_pers_signature m acc with Env.Error _ -> acc end in try (Typemod.transl_signature env sexp).sig_type with Env.Error err -> [] | Typemod.Error (l,_) -> let start_c = l.loc_start.Lexing.pos_cnum in let end_c = l.loc_end.Lexing.pos_cnum in raise (Error (start_c - 8, end_c - 8)) | Typetexp.Error (l,_) -> let start_c = l.loc_start.Lexing.pos_cnum in let end_c = l.loc_end.Lexing.pos_cnum in raise (Error (start_c - 8, end_c - 8)) in match sign with [ Sig_value (_, vd) ] -> search_all_types vd.val_type ~mode | _ -> [] with Syntaxerr.Error(Syntaxerr.Unclosed(l,_,_,_)) -> let start_c = l.loc_start.Lexing.pos_cnum in let end_c = l.loc_end.Lexing.pos_cnum in raise (Error (start_c - 8, end_c - 8)) | Syntaxerr.Error(Syntaxerr.Other l) -> let start_c = l.loc_start.Lexing.pos_cnum in let end_c = l.loc_end.Lexing.pos_cnum in raise (Error (start_c - 8, end_c - 8)) | Lexer.Error (_, l) -> let start_c = l.loc_start.Lexing.pos_cnum in let end_c = l.loc_end.Lexing.pos_cnum in raise (Error (start_c - 8, end_c - 8)) let longident_of_string text = let exploded = ref [] and l = ref 0 in for i = 0 to String.length text - 2 do if text.[i] ='.' then (exploded := String.sub text ~pos:!l ~len:(i - !l) :: !exploded; l := i+1) done; let sym = String.sub text ~pos:!l ~len:(String.length text - !l) in let rec mklid = function [s] -> Lident s | s :: l -> Ldot (mklid l, s) | [] -> assert false in sym, fun l -> mklid (sym :: !exploded @ l) let explode s = let l = ref [] in for i = String.length s - 1 downto 0 do l := s.[i] :: !l done; !l let rec check_match ~pattern s = match pattern, s with [], [] -> true | '*'::l, l' -> check_match ~pattern:l l' || check_match ~pattern:('?'::'*'::l) l' | '?'::l, _::l' -> check_match ~pattern:l l' | x::l, y::l' when x == y -> check_match ~pattern:l l' | _ -> false let search_pattern_symbol text = if text = "" then [] else let pattern = explode text in let check i = check_match ~pattern (explode (Ident.name i)) in let l = List.map !module_list ~f: begin fun modname -> Lident modname, try match lookup_module (Lident modname) initial with _, Mty_signature sign -> List2.flat_map sign ~f: begin function Sig_value (i, _) when check i -> [i, Pvalue] | Sig_type (i, _, _) when check i -> [i, Ptype] | Sig_exception (i, _) when check i -> [i, Pconstructor] | Sig_module (i, _, _) when check i -> [i, Pmodule] | Sig_modtype (i, _) when check i -> [i, Pmodtype] | Sig_class (i, cl, _) when check i || List.exists (get_fields ~prefix:[modname] ~sign (self_type cl.cty_type)) ~f:(fun (name,_,_) -> check_match ~pattern (explode name)) -> [i, Pclass] | Sig_class_type (i, cl, _) when check i || List.exists (get_fields ~prefix:[modname] ~sign (self_type cl.clty_type)) ~f:(fun (name,_,_) -> check_match ~pattern (explode name)) -> [i, Pcltype] | _ -> [] end | _ -> [] with Env.Error _ -> [] end in List2.flat_map l ~f: begin fun (m, l) -> List.map l ~f:(fun (i, p) -> Ldot (m, Ident.name i), p) end (* let is_pattern s = try for i = 0 to String.length s -1 do if s.[i] = '?' || s.[i] = '*' then raise Exit done; false with Exit -> true *) let search_string_symbol text = if text = "" then [] else let lid = snd (longident_of_string text) [] in let try_lookup f k = try let _ = f lid Env.initial in [lid, k] with Not_found | Env.Error _ -> [] in try_lookup lookup_constructor Pconstructor @ try_lookup lookup_module Pmodule @ try_lookup lookup_modtype Pmodtype @ try_lookup lookup_value Pvalue @ try_lookup lookup_type Ptype @ try_lookup lookup_label Plabel @ try_lookup lookup_class Pclass open Parsetree let rec bound_variables pat = match pat.ppat_desc with Ppat_any | Ppat_constant _ | Ppat_type _ | Ppat_unpack _ -> [] | Ppat_var s -> [s.txt] | Ppat_alias (pat,s) -> s.txt :: bound_variables pat | Ppat_tuple l -> List2.flat_map l ~f:bound_variables | Ppat_construct (_,None,_) -> [] | Ppat_construct (_,Some pat,_) -> bound_variables pat | Ppat_variant (_,None) -> [] | Ppat_variant (_,Some pat) -> bound_variables pat | Ppat_record (l, _) -> List2.flat_map l ~f:(fun (_,pat) -> bound_variables pat) | Ppat_array l -> List2.flat_map l ~f:bound_variables | Ppat_or (pat1,pat2) -> bound_variables pat1 @ bound_variables pat2 | Ppat_constraint (pat,_) -> bound_variables pat | Ppat_lazy pat -> bound_variables pat let search_structure str ~name ~kind ~prefix = let loc = ref 0 in let rec search_module str ~prefix = match prefix with [] -> str | modu::prefix -> let str = List.fold_left ~init:[] str ~f: begin fun acc item -> match item.pstr_desc with Pstr_module (s, mexp) when s.txt = modu -> loc := mexp.pmod_loc.loc_start.Lexing.pos_cnum; begin match mexp.pmod_desc with Pmod_structure str -> str | _ -> [] end | _ -> acc end in search_module str ~prefix in List.iter (search_module str ~prefix) ~f: begin fun item -> if match item.pstr_desc with Pstr_value (_, l) when kind = Pvalue -> List.iter l ~f: begin fun (pat,_) -> if List.mem name (bound_variables pat) then loc := pat.ppat_loc.loc_start.Lexing.pos_cnum end; false | Pstr_primitive (s, _) when kind = Pvalue -> name = s.txt | Pstr_type l when kind = Ptype -> List.iter l ~f: begin fun (s, td) -> if s.txt = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum end; false | Pstr_exception (s, _) when kind = Pconstructor -> name = s.txt | Pstr_module (s, _) when kind = Pmodule -> name = s.txt | Pstr_modtype (s, _) when kind = Pmodtype -> name = s.txt | Pstr_class l when kind = Pclass || kind = Ptype || kind = Pcltype -> List.iter l ~f: begin fun c -> if c.pci_name.txt = name then loc := c.pci_loc.loc_start.Lexing.pos_cnum end; false | Pstr_class_type l when kind = Pcltype || kind = Ptype -> List.iter l ~f: begin fun c -> if c.pci_name.txt = name then loc := c.pci_loc.loc_start.Lexing.pos_cnum end; false | _ -> false then loc := item.pstr_loc.loc_start.Lexing.pos_cnum end; !loc let search_signature sign ~name ~kind ~prefix = ignore (name = ""); ignore (prefix = [""]); let loc = ref 0 in let rec search_module_type sign ~prefix = match prefix with [] -> sign | modu::prefix -> let sign = List.fold_left ~init:[] sign ~f: begin fun acc item -> match item.psig_desc with Psig_module (s, mtyp) when s.txt = modu -> loc := mtyp.pmty_loc.loc_start.Lexing.pos_cnum; begin match mtyp.pmty_desc with Pmty_signature sign -> sign | _ -> [] end | _ -> acc end in search_module_type sign ~prefix in List.iter (search_module_type sign ~prefix) ~f: begin fun item -> if match item.psig_desc with Psig_value (s, _) when kind = Pvalue -> name = s.txt | Psig_type l when kind = Ptype -> List.iter l ~f: begin fun (s, td) -> if s.txt = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum end; false | Psig_exception (s, _) when kind = Pconstructor -> name = s.txt | Psig_module (s, _) when kind = Pmodule -> name = s.txt | Psig_modtype (s, _) when kind = Pmodtype -> name = s.txt | Psig_class l when kind = Pclass || kind = Ptype || kind = Pcltype -> List.iter l ~f: begin fun c -> if c.pci_name.txt = name then loc := c.pci_loc.loc_start.Lexing.pos_cnum end; false | Psig_class_type l when kind = Ptype || kind = Pcltype -> List.iter l ~f: begin fun c -> if c.pci_name.txt = name then loc := c.pci_loc.loc_start.Lexing.pos_cnum end; false | _ -> false then loc := item.psig_loc.loc_start.Lexing.pos_cnum end; !loc mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_text.mli0000644000175000017500000000265412124403241022563 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Widget val get_all : text widget -> string val tag_and_see : text widget -> tag:Tk.textTag -> start:Tk.textIndex -> stop:Tk.textIndex -> unit val output : text widget -> buf:string -> pos:int -> len:int -> unit val add_scrollbar : text widget -> scrollbar widget val create_with_scrollbar : 'a widget -> frame widget * text widget * scrollbar widget val goto_tag : text widget -> tag:string -> unit val search_string : text widget -> unit mingw-ocaml/ocaml/otherlibs/labltk/browser/useunix.mli0000644000175000017500000000235612124403241022616 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) (* Unix utilities *) val get_files_in_directory : string -> string list val is_directory : string -> bool val concat : string -> string -> string val get_directories_in_files : path:string -> string list -> string list val subshell : cmd:string -> string list mingw-ocaml/ocaml/otherlibs/labltk/browser/shell.mli0000644000175000017500000000326212124403241022222 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) class ['a] history : unit -> object val mutable count : int val mutable history : 'a list method add : 'a -> unit method empty : bool method next : 'a method previous : 'a end (* toplevel shell *) class shell : textw:Widget.text Widget.widget -> prog:string -> args:string array -> env:string array -> history:string history -> object method alive : bool method kill : unit method interrupt : unit method insert : string -> unit method send : string -> unit method history : [`Next|`Previous] -> unit end val kill_all : unit -> unit val get_all : unit -> (string * shell) list val warnings : string ref val f : prog:string -> title:string -> unit mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_bind.mli0000644000175000017500000000222412124403241022504 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Widget val enter_focus : 'a widget -> unit val escape_destroy : ?destroy:'a widget -> 'a widget ->unit val return_invoke : 'a widget -> button:button widget -> unit mingw-ocaml/ocaml/otherlibs/labltk/browser/typecheck.ml0000644000175000017500000001534112124403241022722 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open StdLabels open Tk open Parsetree open Typedtree open Location open Jg_tk open Mytypes (* Optionally preprocess a source file *) let preprocess ~pp ~ext text = let sourcefile = Filename.temp_file "caml" ext in begin try let oc = open_out_bin sourcefile in output_string oc text; flush oc; close_out oc with _ -> failwith "Preprocessing error" end; let tmpfile = Filename.temp_file "camlpp" ext in let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in if Ccomp.command comm <> 0 then begin Sys.remove sourcefile; Sys.remove tmpfile; failwith "Preprocessing error" end; Sys.remove sourcefile; tmpfile exception Outdated_version let parse_pp ~parse ~wrap ~ext text = Location.input_name := ""; match !Clflags.preprocessor with None -> let buffer = Lexing.from_string text in Location.init buffer ""; parse buffer | Some pp -> let tmpfile = preprocess ~pp ~ext text in let ast_magic = if ext = ".ml" then Config.ast_impl_magic_number else Config.ast_intf_magic_number in let ic = open_in_bin tmpfile in let ast = try let buffer = Misc.input_bytes ic (String.length ast_magic) in if buffer = ast_magic then begin ignore (input_value ic); wrap (input_value ic) end else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then raise Outdated_version else raise Exit with Outdated_version -> close_in ic; Sys.remove tmpfile; failwith "OCaml and preprocessor have incompatible versions" | _ -> seek_in ic 0; let buffer = Lexing.from_channel ic in Location.init buffer ""; parse buffer in close_in ic; Sys.remove tmpfile; ast let nowarnings = ref false let f txt = let error_messages = ref [] in let text = Jg_text.get_all txt.tw and env = ref (Env.open_pers_signature "Pervasives" Env.initial) in let tl, ew, end_message = Jg_message.formatted ~title:"Warnings" ~ppf:Format.err_formatter () in Text.tag_remove txt.tw ~tag:"error" ~start:tstart ~stop:tend; txt.structure <- []; txt.type_info <- []; txt.signature <- []; txt.psignature <- []; ignore (Stypes.get_info ()); Clflags.annotations := true; begin try if Filename.check_suffix txt.name ".mli" then let psign = parse_pp text ~ext:".mli" ~parse:Parse.interface ~wrap:(fun x -> x) in txt.psignature <- psign; txt.signature <- (Typemod.transl_signature !env psign).sig_type; else (* others are interpreted as .ml *) let psl = parse_pp text ~ext:".ml" ~parse:Parse.use_file ~wrap:(fun x -> [Parsetree.Ptop_def x]) in List.iter psl ~f: begin function Ptop_def pstr -> let str, sign, env' = Typemod.type_structure !env pstr Location.none in txt.structure <- txt.structure @ str.str_items; txt.signature <- txt.signature @ sign; env := env' | Ptop_dir _ -> () end; txt.type_info <- Stypes.get_info (); with Lexer.Error _ | Syntaxerr.Error _ | Typecore.Error _ | Typemod.Error _ | Typeclass.Error _ | Typedecl.Error _ | Typetexp.Error _ | Includemod.Error _ | Env.Error _ | Ctype.Tags _ | Failure _ as exn -> txt.type_info <- Stypes.get_info (); let et, ew, end_message = Jg_message.formatted ~title:"Error !" () in error_messages := et :: !error_messages; let range = match exn with Lexer.Error (err, l) -> Lexer.report_error Format.std_formatter err; l | Syntaxerr.Error err -> Syntaxerr.report_error Format.std_formatter err; begin match err with Syntaxerr.Unclosed(l,_,_,_) -> l | Syntaxerr.Applicative_path l -> l | Syntaxerr.Variable_in_scope(l,_) -> l | Syntaxerr.Other l -> l end | Typecore.Error (l,err) -> Typecore.report_error Format.std_formatter err; l | Typeclass.Error (l,err) -> Typeclass.report_error Format.std_formatter err; l | Typedecl.Error (l, err) -> Typedecl.report_error Format.std_formatter err; l | Typemod.Error (l,err) -> Typemod.report_error Format.std_formatter err; l | Typetexp.Error (l,err) -> Typetexp.report_error Format.std_formatter err; l | Includemod.Error errl -> Includemod.report_error Format.std_formatter errl; Location.none | Env.Error err -> Env.report_error Format.std_formatter err; Location.none | Cmi_format.Error err -> Cmi_format.report_error Format.std_formatter err; Location.none | Ctype.Tags(l, l') -> Format.printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value.@." l l'; Location.none | Failure s -> Format.printf "%s.@." s; Location.none | _ -> assert false in end_message (); let s = range.loc_start.Lexing.pos_cnum in let e = range.loc_end.Lexing.pos_cnum in if s < e then Jg_text.tag_and_see txt.tw ~start:(tpos s) ~stop:(tpos e) ~tag:"error" end; end_message (); if !nowarnings || Text.index ew ~index:tend = `Linechar (2,0) then destroy tl else begin error_messages := tl :: !error_messages; Text.configure ew ~state:`Disabled; bind ew ~events:[`Modified([`Double], `ButtonReleaseDetail 1)] ~action:(fun _ -> try let start, ende = Text.tag_nextrange ew ~tag:"sel" ~start:(tpos 0) in let s = Text.get ew ~start:(start,[]) ~stop:(ende,[]) in let n = int_of_string s in Text.mark_set txt.tw ~index:(tpos n) ~mark:"insert"; Text.see txt.tw ~index:(`Mark "insert", []) with _ -> ()) end; !error_messages mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_menu.ml0000644000175000017500000000372312124403241022370 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Tk class c ~parent ?(underline=0) label = object (self) val menu = let menu = Menu.create parent in Menu.add_cascade parent ~menu ~label ~underline; menu method menu = menu method virtual add_command : ?underline:int -> ?accelerator:string -> ?activebackground:color -> ?activeforeground:color -> ?background:color -> ?bitmap:bitmap -> ?command:(unit -> unit) -> ?font:string -> ?foreground:color -> ?image:image -> ?state:state -> string -> unit method add_command ?(underline=0) ?accelerator ?activebackground ?activeforeground ?background ?bitmap ?command ?font ?foreground ?image ?state label = Menu.add_command menu ~label ~underline ?accelerator ?activebackground ?activeforeground ?background ?bitmap ?command ?font ?foreground ?image ?state end let menubar tl = let menu = Menu.create tl ~name:"menubar" ~typ:`Menubar in Toplevel.configure tl ~menu; menu mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_config.mli0000644000175000017500000000200012124403241023025 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) val init: unit -> unit mingw-ocaml/ocaml/otherlibs/labltk/browser/help.txt0000644000175000017500000001447112124403241022105 0ustar tootstoots OCamlBrowser Help USE OCamlBrowser is composed of three tools, the Editor, which allows one to edit/typecheck/analyse .mli and .ml files, the Viewer, to walk around compiled modules, and the Shell, to run an OCaml subshell. You may only have one instance of Editor and Viewer, but you may use several subshells. As with the compiler, you may specify a different path for the standard library by setting OCAMLLIB. You may also extend the initial load path (only standard library by default) by using the -I command line option. The -nolabels, -rectypes and -w options are also accepted, and inherited by subshells. The -oldui options selects the old multi-window interface. The default is now more like Smalltalk's class browser. 1) Viewer This is the first window you get when you start OCamlBrowser. It displays a search window, and the list of modules in the load path. At the top a row of menus. File - Open and File - Editor give access to the editor. File - Shell opens an OCaml shell. View - Show all defs displays the signature of the currently selected module. View - Search entry shows/hides the search entry just below the menu bar. Modules - Path editor changes the load path. Pressing [Add to path] or Insert key adds selected directories to the load path. Pressing [Remove from path] or Delete key removes selected paths from the load path. Modules - Reset cache rescans the load path and resets the module cache. Do it if you recompile some interface, or change the load path in a conflictual way. Modules - Search symbol allows to search a symbol either by its name, like the bottom line of the viewer, or, more interestingly, by its type. Exact type searches for a type with exactly the same information as the pattern (variables match only variables), included type allows to give only partial information: the actual type may take more arguments and return more results, and variables in the pattern match anything. In both cases, argument and tuple order is irrelevant (*), and unlabeled arguments in the pattern match any label. (*) To avoid combinatorial explosion of the search space, optional arguments in the actual type are ignored if (1) there are to many of them, and (2) they do not appear explicitly in the pattern. The Search entry just below the menu bar allows one to search for an identifier in all modules, either by its name (? and * patterns allowed) or by its type (if there is an arrow in the input). When search by type is used, it is done in inclusion mode (cf. Modules - search symbol) The Close all button is there to dismiss the windows created by the Detach button. By double-clicking on it you will quit the browser. 2) Module browsing You select a module in the leftmost box by either cliking on it or pressing return when it is selected. Fast access is available in all boxes pressing the first few letter of the desired name. Double-clicking / double-return displays the whole signature for the module. Defined identifiers inside the module are displayed in a box to the right of the previous one. If you click on one, this will either display its contents in another box (if this is a sub-module) or display the signature for this identifier below. Signatures are clickable. Double clicking with the left mouse button on an identifier in a signature brings you to its signature, inside its module box. A single click on the right button pops up a menu displaying the type declaration for the selected identifier. Its title, when selectable, also brings you to its signature. At the bottom, a series of buttons, depending on the context. * Detach copies the currently displayed signature in a new window, to keep it. * Impl and Intf bring you to the implementation or interface of the currently displayed signature, if it is available. C-s opens a text search dialog for the displayed signature. 3) File editor You can edit files with it, but there is no auto-save nor undo at the moment. Otherwise you can use it as a browser, making occasional corrections. The Edit menu contains commands for jump (C-g), search (C-s), and sending the current selection to a sub-shell (M-x). For this last option, you may choose the shell via a dialog. Essential function are in the Compiler menu. Preferences opens a dialog to set internals of the editor and type checker. Lex (M-l) adds colors according to lexical categories. Typecheck (M-t) verifies typing, and memorizes it to let one see an expression's type by double-clicking on it. This is also valid for interfaces. If an error occurs, the part of the interface preceding the error is computed. After typechecking, pressing the right button pops up a menu giving the type of the pointed expression, and eventually allowing to follow some links. Clear errors dismisses type checker error messages and warnings. Signature shows the signature of the current file. 4) Shell When you create a shell, a dialog is presented to you, letting you choose which command you want to run, and the title of the shell (to choose it in the Editor). You may change the default command by setting the OLABL environment variable. The executed subshell is given the current load path. File: use a source file or load a bytecode file. You may also import the browser's path into the subprocess. History: M-p and M-n browse up and down. Signal: C-c interrupts and you can kill the subprocess. BUGS * When you quit the editor and some file was modified, a dialogue is displayed asking wether you want to really quit or not. But 1) if you quit directly from the viewer, there is no dialogue at all, and 2) if you close from the window manager, the dialogue is displayed, but you cannot cancel the destruction... Beware. * When you run it through xon, the shell hangs at the first error. But its ok if you start ocamlbrowser from a remote shell... TODO * Complete cross-references. * Power up editor. * Add support for the debugger. * Make this a real programming environment, both for beginners and experimented users. Bug reports and comments to mingw-ocaml/ocaml/otherlibs/labltk/browser/setpath.mli0000644000175000017500000000233612124403241022564 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Widget val add_update_hook : (unit -> unit) -> unit val exec_update_hooks : unit -> unit (* things to do when Config.load_path changes *) val set : dir:string -> unit val f : dir:string -> toplevel widget (* edit the load path *) mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_message.mli0000644000175000017500000000256612124403241023225 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Widget val formatted : title:string -> ?on:frame widget -> ?ppf:Format.formatter -> ?width:int -> ?maxheight:int -> ?minheight:int -> unit -> any widget * text widget * (unit -> unit) val ask : title:string -> ?master:toplevel widget -> ?no:bool -> ?cancel:bool -> string -> [`Cancel|`No|`Yes] val info : title:string -> ?master:toplevel widget -> string -> unit mingw-ocaml/ocaml/otherlibs/labltk/browser/viewer.ml0000644000175000017500000005413412124403241022247 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open StdLabels open Tk open Jg_tk open Mytypes open Longident open Types open Typedtree open Env open Searchpos open Searchid (* Managing the module list *) let list_modules ~path = List.fold_left path ~init:[] ~f: begin fun modules dir -> let l = List.filter (Useunix.get_files_in_directory dir) ~f:(fun x -> Filename.check_suffix x ".cmi") in let l = List.map l ~f: begin fun x -> String.capitalize (Filename.chop_suffix x ".cmi") end in List.fold_left l ~init:modules ~f:(fun modules item -> if List.mem item modules then modules else item :: modules) end let reset_modules box = Listbox.delete box ~first:(`Num 0) ~last:`End; module_list := Sort.list (Jg_completion.lt_string ~nocase:true) (list_modules ~path:!Config.load_path); Listbox.insert box ~index:`End ~texts:!module_list; Jg_box.recenter box ~index:(`Num 0) (* How to display a symbol *) let view_symbol ~kind ~env ?path id = let name = match id with Lident x -> x | Ldot (_, x) -> x | _ -> match kind with Pvalue | Ptype | Plabel -> "z" | _ -> "Z" in match kind with Pvalue -> let path, vd = lookup_value id env in view_signature_item ~path ~env [Sig_value (Ident.create name, vd)] | Ptype -> view_type_id id ~env | Plabel -> let _,ld = lookup_label id env in begin match ld.lbl_res.desc with Tconstr (path, _, _) -> view_type_decl path ~env | _ -> () end | Pconstructor -> let _,cd = lookup_constructor id env in begin match cd.cstr_res.desc with Tconstr (cpath, _, _) -> if Path.same cpath Predef.path_exn then view_signature ~title:(string_of_longident id) ~env ?path [Sig_exception (Ident.create name, {Types.exn_loc = Location.none; exn_args = cd.cstr_args})] else view_type_decl cpath ~env | _ -> () end | Pmodule -> view_module_id id ~env | Pmodtype -> view_modtype_id id ~env | Pclass -> view_class_id id ~env | Pcltype -> view_cltype_id id ~env (* Create a list of symbols you can choose from *) let choose_symbol ~title ~env ?signature ?path l = if match path with None -> false | Some path -> is_shown_module path then () else let tl = Jg_toplevel.titled title in Jg_bind.escape_destroy tl; top_widgets := coe tl :: !top_widgets; let buttons = Frame.create tl in let all = Button.create buttons ~text:"Show all" ~padx:20 and ok = Jg_button.create_destroyer tl ~parent:buttons and detach = Button.create buttons ~text:"Detach" and edit = Button.create buttons ~text:"Impl" and intf = Button.create buttons ~text:"Intf" in let l = List.sort l ~cmp:(fun (li1, _) (li2,_) -> compare li1 li2) in let nl = List.map l ~f: begin fun (li, k) -> string_of_longident li ^ " (" ^ string_of_kind k ^ ")" end in let fb = Frame.create tl in let box = new Jg_multibox.c fb ~cols:3 ~texts:nl ~maxheight:3 ~width:21 in box#init; box#bind_kbd ~events:[`KeyPressDetail"Escape"] ~action:(fun _ ~index -> destroy tl; break ()); if List.length nl > 9 then ignore (Jg_multibox.add_scrollbar box); Jg_multibox.add_completion box ~action: begin fun pos -> let li, k = List.nth l pos in let path = match path, li with None, Ldot (lip, _) -> begin try Some (fst (lookup_module lip env)) with Not_found -> None end | _ -> path in view_symbol li ~kind:k ~env ?path end; pack [buttons] ~side:`Bottom ~fill:`X; pack [fb] ~side:`Top ~fill:`Both ~expand:true; begin match signature with None -> pack [ok] ~fill:`X ~expand:true | Some signature -> Button.configure all ~command: begin fun () -> view_signature signature ~title ~env ?path end; pack [ok; all] ~side:`Right ~fill:`X ~expand:true end; begin match path with None -> () | Some path -> let frame = Frame.create tl in pack [frame] ~side:`Bottom ~fill:`X; add_shown_module path ~widgets:{ mw_frame = frame; mw_title = None; mw_detach = detach; mw_edit = edit; mw_intf = intf } end let choose_symbol_ref = ref choose_symbol (* Search, both by type and name *) let guess_search_mode s : [`Type | `Long | `Pattern] = let is_type = ref false and is_long = ref false in for i = 0 to String.length s - 2 do if s.[i] = '-' && s.[i+1] = '>' then is_type := true; if s.[i] = '.' then is_long := true done; if !is_type then `Type else if !is_long then `Long else `Pattern let search_string ?(mode="symbol") ew = let text = Entry.get ew in try if text = "" then () else let l = match mode with "Name" -> begin match guess_search_mode text with `Long -> search_string_symbol text | `Pattern -> search_pattern_symbol text | `Type -> search_string_type text ~mode:`Included end | "Type" -> search_string_type text ~mode:`Included | "Exact" -> search_string_type text ~mode:`Exact | _ -> assert false in match l with [] -> () | [lid,kind] -> view_symbol lid ~kind ~env:!start_env | l -> choose_symbol ~title:"Choose symbol" ~env:!start_env l with Searchid.Error (s,e) -> Entry.icursor ew ~index:(`Num s) let search_which = ref "Name" let search_symbol () = if !module_list = [] then module_list := List.sort ~cmp:compare (list_modules ~path:!Config.load_path); let tl = Jg_toplevel.titled "Search symbol" in Jg_bind.escape_destroy tl; let ew = Entry.create tl ~width:30 in let choice = Frame.create tl and which = Textvariable.create ~on:tl () in let itself = Radiobutton.create choice ~text:"Itself" ~variable:which ~value:"Name" and extype = Radiobutton.create choice ~text:"Exact type" ~variable:which ~value:"Exact" and iotype = Radiobutton.create choice ~text:"Included type" ~variable:which ~value:"Type" and buttons = Frame.create tl in let search = Button.create buttons ~text:"Search" ~command: begin fun () -> search_which := Textvariable.get which; search_string ew ~mode:!search_which end and ok = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" in Focus.set ew; Jg_bind.return_invoke ew ~button:search; Textvariable.set which !search_which; pack [itself; extype; iotype] ~side:`Left ~anchor:`W; pack [search; ok] ~side:`Left ~fill:`X ~expand:true; pack [coe ew; coe choice; coe buttons] ~side:`Top ~fill:`X ~expand:true (* Display the contents of a module *) let ident_of_decl ~modlid = function Sig_value (id, _) -> Lident (Ident.name id), Pvalue | Sig_type (id, _, _) -> Lident (Ident.name id), Ptype | Sig_exception (id, _) -> Ldot (modlid, Ident.name id), Pconstructor | Sig_module (id, _, _) -> Lident (Ident.name id), Pmodule | Sig_modtype (id, _) -> Lident (Ident.name id), Pmodtype | Sig_class (id, _, _) -> Lident (Ident.name id), Pclass | Sig_class_type (id, _, _) -> Lident (Ident.name id), Pcltype let view_defined ~env ?(show_all=false) modlid = try match lookup_module modlid env with path, Mty_signature sign -> let rec iter_sign sign idents = match sign with [] -> List.rev idents | decl :: rem -> let rem = match decl, rem with Sig_class _, cty :: ty1 :: ty2 :: rem -> rem | Sig_class_type _, ty1 :: ty2 :: rem -> rem | _, rem -> rem in iter_sign rem (ident_of_decl ~modlid decl :: idents) in let l = iter_sign sign [] in let title = string_of_path path in let env = open_signature path sign env in !choose_symbol_ref l ~title ~signature:sign ~env ~path; if show_all then view_signature sign ~title ~env ~path | _ -> () with Not_found -> () | Env.Error err -> let tl, tw, finish = Jg_message.formatted ~title:"Error!" () in Env.report_error Format.std_formatter err; finish () | Cmi_format.Error err -> let tl, tw, finish = Jg_message.formatted ~title:"Error!" () in Cmi_format.report_error Format.std_formatter err; finish () (* Manage toplevel windows *) let close_all_views () = List.iter !top_widgets ~f:(fun tl -> try destroy tl with Protocol.TkError _ -> ()); top_widgets := [] (* Launch a shell *) let shell_counter = ref 1 let default_shell = ref "ocaml" let start_shell master = let tl = Jg_toplevel.titled "Start New Shell" in Wm.transient_set tl ~master; let input = Frame.create tl and buttons = Frame.create tl in let ok = Button.create buttons ~text:"Ok" and cancel = Jg_button.create_destroyer tl ~parent:buttons ~text:"Cancel" and labels = Frame.create input and entries = Frame.create input in let l1 = Label.create labels ~text:"Command:" and l2 = Label.create labels ~text:"Title:" and e1 = Jg_entry.create entries ~command:(fun _ -> Button.invoke ok) and e2 = Jg_entry.create entries ~command:(fun _ -> Button.invoke ok) and names = List.map ~f:fst (Shell.get_all ()) in Entry.insert e1 ~index:`End ~text:!default_shell; let shell_name () = "Shell #" ^ string_of_int !shell_counter in while List.mem (shell_name ()) names do incr shell_counter done; Entry.insert e2 ~index:`End ~text:(shell_name ()); Button.configure ok ~command:(fun () -> if not (List.mem (Entry.get e2) names) then begin default_shell := Entry.get e1; Shell.f ~prog:!default_shell ~title:(Entry.get e2); destroy tl end); pack [l1;l2] ~side:`Top ~anchor:`W; pack [e1;e2] ~side:`Top ~fill:`X ~expand:true; pack [labels;entries] ~side:`Left ~fill:`X ~expand:true; pack [ok;cancel] ~side:`Left ~fill:`X ~expand:true; pack [input;buttons] ~side:`Top ~fill:`X ~expand:true (* Help window *) let show_help () = let tl = Jg_toplevel.titled "OCamlBrowser Help" in Jg_bind.escape_destroy tl; let fw, tw, sb = Jg_text.create_with_scrollbar tl in let ok = Jg_button.create_destroyer ~parent:tl ~text:"Ok" tl in Text.insert tw ~index:tend ~text:Help.text; Text.configure tw ~state:`Disabled; Jg_bind.enter_focus tw; pack [tw] ~side:`Left ~fill:`Both ~expand:true; pack [sb] ~side:`Right ~fill:`Y; pack [fw] ~side:`Top ~expand:true ~fill:`Both; pack [ok] ~side:`Bottom ~fill:`X (* Launch the classical viewer *) let f ?(dir=Unix.getcwd()) ?on () = let (top, tl) = match on with None -> let tl = Jg_toplevel.titled "Module viewer" in ignore (Jg_bind.escape_destroy tl); (tl, coe tl) | Some top -> Wm.title_set top "OCamlBrowser"; Wm.iconname_set top "OCamlBrowser"; let tl = Frame.create top in bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0); pack [tl] ~expand:true ~fill:`Both; (top, coe tl) in let menus = Jg_menu.menubar top in let filemenu = new Jg_menu.c "File" ~parent:menus and modmenu = new Jg_menu.c "Modules" ~parent:menus in let fmbox, mbox, msb = Jg_box.create_with_scrollbar tl in Jg_box.add_completion mbox ~nocase:true ~action: begin fun index -> view_defined (Lident (Listbox.get mbox ~index)) ~env:!start_env end; Setpath.add_update_hook (fun () -> reset_modules mbox); let ew = Entry.create tl in let buttons = Frame.create tl in let search = Button.create buttons ~text:"Search" ~pady:1 ~command:(fun () -> search_string ew) and close = Button.create buttons ~text:"Close all" ~pady:1 ~command:close_all_views in (* bindings *) Jg_bind.enter_focus ew; Jg_bind.return_invoke ew ~button:search; bind close ~events:[`Modified([`Double], `ButtonPressDetail 1)] ~action:(fun _ -> destroy tl); (* File menu *) filemenu#add_command "Open..." ~command:(fun () -> !editor_ref ~opendialog:true ()); filemenu#add_command "Editor..." ~command:(fun () -> !editor_ref ()); filemenu#add_command "Shell..." ~command:(fun () -> start_shell tl); filemenu#add_command "Quit" ~command:(fun () -> destroy tl); (* modules menu *) modmenu#add_command "Path editor..." ~command:(fun () -> Setpath.set ~dir); modmenu#add_command "Reset cache" ~command:(fun () -> reset_modules mbox; Env.reset_cache ()); modmenu#add_command "Search symbol..." ~command:search_symbol; pack [close; search] ~fill:`X ~side:`Right ~expand:true; pack [coe buttons; coe ew] ~fill:`X ~side:`Bottom; pack [msb] ~side:`Right ~fill:`Y; pack [mbox] ~side:`Left ~fill:`Both ~expand:true; pack [fmbox] ~fill:`Both ~expand:true ~side:`Top; reset_modules mbox (* Smalltalk-like version *) class st_viewer ?(dir=Unix.getcwd()) ?on () = let (top, tl) = match on with None -> let tl = Jg_toplevel.titled "Module viewer" in ignore (Jg_bind.escape_destroy tl); (tl, coe tl) | Some top -> Wm.title_set top "OCamlBrowser"; Wm.iconname_set top "OCamlBrowser"; let tl = Frame.create top in bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0); pack [tl] ~side:`Bottom ~expand:true ~fill:`Both; (top, coe tl) in let menus = Menu.create top ~name:"menubar" ~typ:`Menubar in let () = Toplevel.configure top ~menu:menus in let filemenu = new Jg_menu.c "File" ~parent:menus and modmenu = new Jg_menu.c "Modules" ~parent:menus and viewmenu = new Jg_menu.c "View" ~parent:menus and helpmenu = new Jg_menu.c "Help" ~parent:menus in let search_frame = Frame.create tl in let boxes_frame = Frame.create tl ~name:"boxes" in let label = Label.create tl ~anchor:`W ~padx:5 in let view = Frame.create tl in let buttons = Frame.create tl in let _all = Button.create buttons ~text:"Show all" ~padx:20 and close = Button.create buttons ~text:"Close all" ~command:close_all_views and detach = Button.create buttons ~text:"Detach" and edit = Button.create buttons ~text:"Impl" and intf = Button.create buttons ~text:"Intf" in object (self) val mutable boxes = [] val mutable show_all = fun () -> () method create_box = let fmbox, mbox, sb = Jg_box.create_with_scrollbar boxes_frame in bind mbox ~events:[`Modified([`Double], `ButtonPressDetail 1)] ~action:(fun _ -> show_all ()); bind mbox ~events:[`Modified([`Double], `KeyPressDetail "Return")] ~action:(fun _ -> show_all ()); boxes <- boxes @ [fmbox, mbox]; pack [sb] ~side:`Right ~fill:`Y; pack [mbox] ~side:`Left ~fill:`Both ~expand:true; pack [fmbox] ~side:`Left ~fill:`Both ~expand:true; fmbox, mbox initializer (* Search *) let ew = Entry.create search_frame and searchtype = Textvariable.create ~on:tl () in bind ew ~events:[`KeyPressDetail "Return"] ~action: (fun _ -> search_string ew ~mode:(Textvariable.get searchtype)); Jg_bind.enter_focus ew; let search_button ?value text = Radiobutton.create search_frame ~text ~variable:searchtype ~value:text in let symbol = search_button "Name" and atype = search_button "Type" in Radiobutton.select symbol; pack [Label.create search_frame ~text:"Search"] ~side:`Left ~ipadx:5; pack [ew] ~fill:`X ~expand:true ~side:`Left; pack [Label.create search_frame ~text:"by"] ~side:`Left ~ipadx:5; pack [symbol; atype] ~side:`Left; pack [Label.create search_frame] ~side:`Right initializer (* Boxes *) let fmbox, mbox = self#create_box in Jg_box.add_completion mbox ~nocase:true ~double:false ~action: begin fun index -> view_defined (Lident (Listbox.get mbox ~index)) ~env:!start_env end; Setpath.add_update_hook (fun () -> reset_modules mbox; self#hide_after 1); List.iter [1;2] ~f:(fun _ -> ignore self#create_box); Searchpos.default_frame := Some { mw_frame = view; mw_title = Some label; mw_detach = detach; mw_edit = edit; mw_intf = intf }; Searchpos.set_path := self#set_path; (* Buttons *) pack [close] ~side:`Right ~fill:`X ~expand:true; bind close ~events:[`Modified([`Double], `ButtonPressDetail 1)] ~action:(fun _ -> destroy tl); (* File menu *) filemenu#add_command "Open..." ~command:(fun () -> !editor_ref ~opendialog:true ()); filemenu#add_command "Editor..." ~command:(fun () -> !editor_ref ()); filemenu#add_command "Shell..." ~command:(fun () -> start_shell tl); filemenu#add_command "Quit" ~command:(fun () -> destroy tl); (* View menu *) viewmenu#add_command "Show all defs" ~command:(fun () -> show_all ()); let show_search = Textvariable.create ~on:tl () in Textvariable.set show_search "1"; Menu.add_checkbutton viewmenu#menu ~label:"Search Entry" ~variable:show_search ~indicatoron:true ~state:`Active ~command: begin fun () -> let v = Textvariable.get show_search in if v = "1" then begin pack [search_frame] ~after:menus ~fill:`X end else Pack.forget [search_frame] end; (* modules menu *) modmenu#add_command "Path editor..." ~command:(fun () -> Setpath.set ~dir); modmenu#add_command "Reset cache" ~command:(fun () -> reset_modules mbox; Env.reset_cache ()); modmenu#add_command "Search symbol..." ~command:search_symbol; (* Help menu *) helpmenu#add_command "Manual..." ~command:show_help; pack [search_frame] ~fill:`X; pack [boxes_frame] ~fill:`Both ~expand:true; pack [buttons] ~fill:`X ~side:`Bottom; pack [view] ~fill:`Both ~side:`Bottom ~expand:true; reset_modules mbox val mutable shown_paths = [] method hide_after n = for i = n to List.length boxes - 1 do let fm, box = List.nth boxes i in if i < 3 then Listbox.delete box ~first:(`Num 0) ~last:`End else destroy fm done; let rec firsts n = function [] -> [] | a :: l -> if n > 0 then a :: firsts (pred n) l else [] in shown_paths <- firsts (n-1) shown_paths; boxes <- firsts (max 3 n) boxes method get_box ~path = let rec path_index p = function [] -> raise Not_found | a :: l -> if Path.same p a then 1 else path_index p l + 1 in try let n = path_index path shown_paths in self#hide_after (n+1); n with Not_found -> match path with Path.Pdot (path', _, _) -> let n = self#get_box ~path:path' in shown_paths <- shown_paths @ [path]; if n + 1 >= List.length boxes then ignore self#create_box; n+1 | _ -> self#hide_after 2; shown_paths <- [path]; 1 method set_path path ~sign = let rec path_elems l path = match path with Path.Pdot (path, _, _) -> path_elems (path::l) path | _ -> [] in let path_elems path = match path with | Path.Pident _ -> [path] | _ -> path_elems [] path in let see_path ~box:n ?(sign=[]) path = let (_, box) = List.nth boxes n in let texts = Listbox.get_range box ~first:(`Num 0) ~last:`End in let rec index s = function [] -> raise Not_found | a :: l -> if a = s then 0 else 1 + index s l in try let modlid, s = match path with Path.Pdot (p, s, _) -> longident_of_path p, s | Path.Pident i -> Longident.Lident "M", Ident.name i | _ -> assert false in let li, k = if sign = [] then Longident.Lident s, Pmodule else ident_of_decl ~modlid (List.hd sign) in let s = if n = 0 then string_of_longident li else string_of_longident li ^ " (" ^ string_of_kind k ^ ")" in let n = index s texts in Listbox.see box (`Num n); Listbox.activate box (`Num n) with Not_found -> () in let l = path_elems path in if l <> [] then begin List.iter l ~f: begin fun path -> if not (List.mem path shown_paths) then view_symbol (longident_of_path path) ~kind:Pmodule ~env:Env.initial ~path; let n = self#get_box path - 1 in see_path path ~box:n end; see_path path ~box:(self#get_box path) ~sign end method choose_symbol ~title ~env ?signature ?path l = let n = match path with None -> 1 | Some path -> self#get_box ~path in let l = List.sort l ~cmp:(fun (li1, _) (li2,_) -> compare li1 li2) in let nl = List.map l ~f: begin fun (li, k) -> string_of_longident li ^ " (" ^ string_of_kind k ^ ")" end in let _, box = List.nth boxes n in Listbox.delete box ~first:(`Num 0) ~last:`End; Listbox.insert box ~index:`End ~texts:nl; let current = ref None in let display index = let `Num pos = Listbox.index box ~index in try let li, k = List.nth l pos in self#hide_after (n+1); if !current = Some (li,k) then () else let path = match path, li with None, Ldot (lip, _) -> begin try Some (fst (lookup_module lip env)) with Not_found -> None end | _ -> path in current := Some (li,k); view_symbol li ~kind:k ~env ?path with Failure "nth" -> () in Jg_box.add_completion box ~double:false ~action:display; bind box ~events:[`KeyRelease] ~fields:[`Char] ~action:(fun ev -> display `Active); begin match signature with None -> () | Some signature -> show_all <- begin fun () -> current := None; view_signature signature ~title ~env ?path end end end let st_viewer ?dir ?on () = let viewer = new st_viewer ?dir ?on () in choose_symbol_ref := viewer#choose_symbol mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_bind.ml0000644000175000017500000000253012124403241022333 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Tk let enter_focus w = bind w ~events:[`Enter] ~action:(fun _ -> Focus.set w) let escape_destroy ?destroy:tl w = let tl = match tl with Some w -> w | None -> w in bind w ~events:[`KeyPressDetail "Escape"] ~action:(fun _ -> destroy tl) let return_invoke w ~button = bind w ~events:[`KeyPressDetail "Return"] ~action:(fun _ -> Button.invoke button) mingw-ocaml/ocaml/otherlibs/labltk/browser/.depend0000644000175000017500000003735712124403241021664 0ustar tootstootseditor.cmo : ../labltk/wm.cmi ../labltk/winfo.cmi ../support/widget.cmi \ viewer.cmi ../../../typing/types.cmi typecheck.cmi ../labltk/toplevel.cmi \ ../labltk/tk.cmo ../support/timer.cmi ../support/textvariable.cmi \ ../labltk/text.cmi shell.cmi setpath.cmi ../labltk/selection.cmi \ searchpos.cmi searchid.cmi ../support/protocol.cmi \ ../../../parsing/parsetree.cmi ../../../parsing/parser.cmi \ ../labltk/pack.cmi mytypes.cmi ../labltk/menu.cmi \ ../../../parsing/longident.cmi ../../../parsing/location.cmi \ ../labltk/listbox.cmi lexical.cmi ../../../parsing/lexer.cmi \ ../labltk/label.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_message.cmi \ jg_menu.cmo jg_button.cmo jg_bind.cmi ../../../typing/ident.cmi \ ../labltk/frame.cmi ../labltk/focus.cmi fileselect.cmi \ ../../../typing/env.cmi ../labltk/entry.cmi ../labltk/clipboard.cmi \ ../../../utils/clflags.cmi ../labltk/checkbutton.cmi ../labltk/button.cmi \ editor.cmi editor.cmx : ../labltk/wm.cmx ../labltk/winfo.cmx ../support/widget.cmx \ viewer.cmx ../../../typing/types.cmx typecheck.cmx ../labltk/toplevel.cmx \ ../labltk/tk.cmx ../support/timer.cmx ../support/textvariable.cmx \ ../labltk/text.cmx shell.cmx setpath.cmx ../labltk/selection.cmx \ searchpos.cmx searchid.cmx ../support/protocol.cmx \ ../../../parsing/parsetree.cmi ../../../parsing/parser.cmx \ ../labltk/pack.cmx mytypes.cmi ../labltk/menu.cmx \ ../../../parsing/longident.cmx ../../../parsing/location.cmx \ ../labltk/listbox.cmx lexical.cmx ../../../parsing/lexer.cmx \ ../labltk/label.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_message.cmx \ jg_menu.cmx jg_button.cmx jg_bind.cmx ../../../typing/ident.cmx \ ../labltk/frame.cmx ../labltk/focus.cmx fileselect.cmx \ ../../../typing/env.cmx ../labltk/entry.cmx ../labltk/clipboard.cmx \ ../../../utils/clflags.cmx ../labltk/checkbutton.cmx ../labltk/button.cmx \ editor.cmi fileselect.cmo : useunix.cmi ../labltk/tkwait.cmi ../labltk/tk.cmo \ ../support/textvariable.cmi setpath.cmi ../labltk/pack.cmi \ ../../../utils/misc.cmi ../labltk/listbox.cmi list2.cmo \ ../labltk/label.cmi jg_toplevel.cmo jg_memo.cmi jg_entry.cmo jg_box.cmo \ ../labltk/grab.cmi ../labltk/frame.cmi ../labltk/focus.cmi \ ../../../utils/config.cmi ../labltk/checkbutton.cmi ../labltk/button.cmi \ fileselect.cmi fileselect.cmx : useunix.cmx ../labltk/tkwait.cmx ../labltk/tk.cmx \ ../support/textvariable.cmx setpath.cmx ../labltk/pack.cmx \ ../../../utils/misc.cmx ../labltk/listbox.cmx list2.cmx \ ../labltk/label.cmx jg_toplevel.cmx jg_memo.cmx jg_entry.cmx jg_box.cmx \ ../labltk/grab.cmx ../labltk/frame.cmx ../labltk/focus.cmx \ ../../../utils/config.cmx ../labltk/checkbutton.cmx ../labltk/button.cmx \ fileselect.cmi help.cmo : help.cmx : jg_bind.cmo : ../labltk/tk.cmo ../labltk/focus.cmi ../labltk/button.cmi \ jg_bind.cmi jg_bind.cmx : ../labltk/tk.cmx ../labltk/focus.cmx ../labltk/button.cmx \ jg_bind.cmi jg_box.cmo : ../labltk/winfo.cmi ../labltk/tk.cmo ../labltk/scrollbar.cmi \ ../labltk/listbox.cmi jg_completion.cmi jg_bind.cmi ../labltk/frame.cmi jg_box.cmx : ../labltk/winfo.cmx ../labltk/tk.cmx ../labltk/scrollbar.cmx \ ../labltk/listbox.cmx jg_completion.cmx jg_bind.cmx ../labltk/frame.cmx jg_button.cmo : ../labltk/tk.cmo ../labltk/button.cmi jg_button.cmx : ../labltk/tk.cmx ../labltk/button.cmx jg_completion.cmo : ../support/timer.cmi jg_completion.cmi jg_completion.cmx : ../support/timer.cmx jg_completion.cmi jg_config.cmo : ../support/widget.cmi ../labltk/option.cmi jg_tk.cmo \ jg_config.cmi jg_config.cmx : ../support/widget.cmx ../labltk/option.cmx jg_tk.cmx \ jg_config.cmi jg_entry.cmo : ../labltk/tk.cmo jg_bind.cmi ../labltk/entry.cmi jg_entry.cmx : ../labltk/tk.cmx jg_bind.cmx ../labltk/entry.cmx jg_memo.cmo : jg_memo.cmi jg_memo.cmx : jg_memo.cmi jg_menu.cmo : ../labltk/toplevel.cmi ../labltk/tk.cmo ../labltk/menu.cmi jg_menu.cmx : ../labltk/toplevel.cmx ../labltk/tk.cmx ../labltk/menu.cmx jg_message.cmo : ../labltk/wm.cmi ../labltk/tkwait.cmi ../labltk/tk.cmo \ ../support/textvariable.cmi ../labltk/text.cmi ../labltk/message.cmi \ jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi ../labltk/grab.cmi \ ../labltk/frame.cmi ../labltk/button.cmi jg_message.cmi jg_message.cmx : ../labltk/wm.cmx ../labltk/tkwait.cmx ../labltk/tk.cmx \ ../support/textvariable.cmx ../labltk/text.cmx ../labltk/message.cmx \ jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx ../labltk/grab.cmx \ ../labltk/frame.cmx ../labltk/button.cmx jg_message.cmi jg_multibox.cmo : ../labltk/tk.cmo ../labltk/scrollbar.cmi \ ../labltk/listbox.cmi jg_completion.cmi jg_bind.cmi ../labltk/focus.cmi \ jg_multibox.cmi jg_multibox.cmx : ../labltk/tk.cmx ../labltk/scrollbar.cmx \ ../labltk/listbox.cmx jg_completion.cmx jg_bind.cmx ../labltk/focus.cmx \ jg_multibox.cmi jg_text.cmo : ../labltk/wm.cmi ../labltk/winfo.cmi ../labltk/tk.cmo \ ../support/textvariable.cmi ../labltk/text.cmi ../labltk/scrollbar.cmi \ ../labltk/radiobutton.cmi ../support/protocol.cmi ../labltk/label.cmi \ jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi ../labltk/frame.cmi \ ../labltk/focus.cmi ../labltk/entry.cmi ../labltk/button.cmi jg_text.cmi jg_text.cmx : ../labltk/wm.cmx ../labltk/winfo.cmx ../labltk/tk.cmx \ ../support/textvariable.cmx ../labltk/text.cmx ../labltk/scrollbar.cmx \ ../labltk/radiobutton.cmx ../support/protocol.cmx ../labltk/label.cmx \ jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx ../labltk/frame.cmx \ ../labltk/focus.cmx ../labltk/entry.cmx ../labltk/button.cmx jg_text.cmi jg_tk.cmo : ../labltk/tk.cmo jg_tk.cmx : ../labltk/tk.cmx jg_toplevel.cmo : ../labltk/wm.cmi ../support/widget.cmi \ ../labltk/toplevel.cmi ../labltk/tk.cmo jg_toplevel.cmx : ../labltk/wm.cmx ../support/widget.cmx \ ../labltk/toplevel.cmx ../labltk/tk.cmx lexical.cmo : ../labltk/tk.cmo ../labltk/text.cmi \ ../../../parsing/parser.cmi ../../../parsing/location.cmi \ ../../../parsing/lexer.cmi jg_tk.cmo lexical.cmi lexical.cmx : ../labltk/tk.cmx ../labltk/text.cmx \ ../../../parsing/parser.cmx ../../../parsing/location.cmx \ ../../../parsing/lexer.cmx jg_tk.cmx lexical.cmi list2.cmo : list2.cmx : main.cmo : ../../../utils/warnings.cmi viewer.cmi ../labltk/tk.cmo shell.cmi \ searchpos.cmi searchid.cmi ../support/protocol.cmi \ ../../../utils/misc.cmi ../labltk/message.cmi jg_config.cmi \ ../../../typing/env.cmi editor.cmi ../../../utils/config.cmi \ ../../../utils/clflags.cmi ../labltk/button.cmi main.cmx : ../../../utils/warnings.cmx viewer.cmx ../labltk/tk.cmx shell.cmx \ searchpos.cmx searchid.cmx ../support/protocol.cmx \ ../../../utils/misc.cmx ../labltk/message.cmx jg_config.cmx \ ../../../typing/env.cmx editor.cmx ../../../utils/config.cmx \ ../../../utils/clflags.cmx ../labltk/button.cmx searchid.cmo : ../../../typing/typetexp.cmi ../../../typing/types.cmi \ ../../../typing/typemod.cmi ../../../typing/typedtree.cmi \ ../../../parsing/syntaxerr.cmi ../../../typing/path.cmi \ ../../../parsing/parsetree.cmi ../../../parsing/parse.cmi \ ../../../parsing/longident.cmi ../../../parsing/location.cmi list2.cmo \ ../../../parsing/lexer.cmi ../../../typing/ident.cmi \ ../../../typing/env.cmi ../../../typing/ctype.cmi \ ../../../typing/btype.cmi ../../../parsing/asttypes.cmi searchid.cmi searchid.cmx : ../../../typing/typetexp.cmx ../../../typing/types.cmx \ ../../../typing/typemod.cmx ../../../typing/typedtree.cmx \ ../../../parsing/syntaxerr.cmx ../../../typing/path.cmx \ ../../../parsing/parsetree.cmi ../../../parsing/parse.cmx \ ../../../parsing/longident.cmx ../../../parsing/location.cmx list2.cmx \ ../../../parsing/lexer.cmx ../../../typing/ident.cmx \ ../../../typing/env.cmx ../../../typing/ctype.cmx \ ../../../typing/btype.cmx ../../../parsing/asttypes.cmi searchid.cmi searchpos.cmo : ../labltk/wm.cmi ../labltk/winfo.cmi ../support/widget.cmi \ ../../../typing/typetexp.cmi ../../../typing/types.cmi \ ../../../typing/typemod.cmi ../../../typing/typedtree.cmi \ ../../../typing/typedecl.cmi ../../../typing/typeclass.cmi \ ../labltk/tk.cmo ../labltk/text.cmi ../../../parsing/syntaxerr.cmi \ ../support/support.cmi ../../../typing/stypes.cmi searchid.cmi \ ../../../typing/printtyp.cmi ../../../typing/path.cmi \ ../../../parsing/parsetree.cmi ../../../parsing/parse.cmi \ ../labltk/pack.cmi ../labltk/option.cmi ../../../utils/misc.cmi \ ../labltk/menu.cmi ../../../parsing/longident.cmi \ ../../../parsing/location.cmi lexical.cmi ../../../parsing/lexer.cmi \ ../labltk/label.cmi jg_tk.cmo jg_text.cmi jg_message.cmi jg_memo.cmi \ jg_bind.cmi ../../../typing/ident.cmi ../../../typing/env.cmi \ ../../../typing/ctype.cmi ../../../utils/config.cmi ../labltk/button.cmi \ ../../../parsing/asttypes.cmi searchpos.cmi searchpos.cmx : ../labltk/wm.cmx ../labltk/winfo.cmx ../support/widget.cmx \ ../../../typing/typetexp.cmx ../../../typing/types.cmx \ ../../../typing/typemod.cmx ../../../typing/typedtree.cmx \ ../../../typing/typedecl.cmx ../../../typing/typeclass.cmx \ ../labltk/tk.cmx ../labltk/text.cmx ../../../parsing/syntaxerr.cmx \ ../support/support.cmx ../../../typing/stypes.cmx searchid.cmx \ ../../../typing/printtyp.cmx ../../../typing/path.cmx \ ../../../parsing/parsetree.cmi ../../../parsing/parse.cmx \ ../labltk/pack.cmx ../labltk/option.cmx ../../../utils/misc.cmx \ ../labltk/menu.cmx ../../../parsing/longident.cmx \ ../../../parsing/location.cmx lexical.cmx ../../../parsing/lexer.cmx \ ../labltk/label.cmx jg_tk.cmx jg_text.cmx jg_message.cmx jg_memo.cmx \ jg_bind.cmx ../../../typing/ident.cmx ../../../typing/env.cmx \ ../../../typing/ctype.cmx ../../../utils/config.cmx ../labltk/button.cmx \ ../../../parsing/asttypes.cmi searchpos.cmi setpath.cmo : useunix.cmi ../labltk/tk.cmo ../support/textvariable.cmi \ ../support/protocol.cmi ../labltk/listbox.cmi list2.cmo \ ../labltk/label.cmi jg_toplevel.cmo jg_button.cmo jg_box.cmo jg_bind.cmi \ ../labltk/frame.cmi ../labltk/entry.cmi ../../../utils/config.cmi \ ../labltk/button.cmi setpath.cmi setpath.cmx : useunix.cmx ../labltk/tk.cmx ../support/textvariable.cmx \ ../support/protocol.cmx ../labltk/listbox.cmx list2.cmx \ ../labltk/label.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx jg_bind.cmx \ ../labltk/frame.cmx ../labltk/entry.cmx ../../../utils/config.cmx \ ../labltk/button.cmx setpath.cmi shell.cmo : ../labltk/winfo.cmi ../../../utils/warnings.cmi \ ../labltk/toplevel.cmi ../labltk/tk.cmo ../support/timer.cmi \ ../labltk/text.cmi ../labltk/menu.cmi list2.cmo lexical.cmi \ jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_message.cmi jg_menu.cmo \ jg_memo.cmi fileselect.cmi ../support/fileevent.cmi dummy.cmi \ ../../../utils/config.cmi ../../../utils/clflags.cmi shell.cmi shell.cmx : ../labltk/winfo.cmx ../../../utils/warnings.cmx \ ../labltk/toplevel.cmx ../labltk/tk.cmx ../support/timer.cmx \ ../labltk/text.cmx ../labltk/menu.cmx list2.cmx lexical.cmx \ jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_message.cmx jg_menu.cmx \ jg_memo.cmx fileselect.cmx ../support/fileevent.cmx dummy.cmi \ ../../../utils/config.cmx ../../../utils/clflags.cmx shell.cmi typecheck.cmo : ../../../typing/typetexp.cmi ../../../typing/typemod.cmi \ ../../../typing/typedtree.cmi ../../../typing/typedecl.cmi \ ../../../typing/typecore.cmi ../../../typing/typeclass.cmi \ ../labltk/tk.cmo ../labltk/text.cmi ../../../parsing/syntaxerr.cmi \ ../../../typing/stypes.cmi ../../../parsing/parsetree.cmi \ ../../../parsing/parse.cmi mytypes.cmi ../../../utils/misc.cmi \ ../../../parsing/location.cmi ../../../parsing/lexer.cmi jg_tk.cmo \ jg_text.cmi jg_message.cmi ../../../typing/includemod.cmi \ ../../../typing/env.cmi ../../../typing/ctype.cmi \ ../../../utils/config.cmi ../../../typing/cmi_format.cmi \ ../../../utils/clflags.cmi ../../../utils/ccomp.cmi typecheck.cmi typecheck.cmx : ../../../typing/typetexp.cmx ../../../typing/typemod.cmx \ ../../../typing/typedtree.cmx ../../../typing/typedecl.cmx \ ../../../typing/typecore.cmx ../../../typing/typeclass.cmx \ ../labltk/tk.cmx ../labltk/text.cmx ../../../parsing/syntaxerr.cmx \ ../../../typing/stypes.cmx ../../../parsing/parsetree.cmi \ ../../../parsing/parse.cmx mytypes.cmi ../../../utils/misc.cmx \ ../../../parsing/location.cmx ../../../parsing/lexer.cmx jg_tk.cmx \ jg_text.cmx jg_message.cmx ../../../typing/includemod.cmx \ ../../../typing/env.cmx ../../../typing/ctype.cmx \ ../../../utils/config.cmx ../../../typing/cmi_format.cmx \ ../../../utils/clflags.cmx ../../../utils/ccomp.cmx typecheck.cmi useunix.cmo : useunix.cmi useunix.cmx : useunix.cmi viewer.cmo : ../labltk/wm.cmi useunix.cmi ../../../typing/types.cmi \ ../../../typing/typedtree.cmi ../labltk/toplevel.cmi ../labltk/tk.cmo \ ../support/textvariable.cmi ../labltk/text.cmi shell.cmi setpath.cmi \ searchpos.cmi searchid.cmi ../labltk/radiobutton.cmi \ ../support/protocol.cmi ../../../typing/predef.cmi \ ../../../typing/path.cmi ../labltk/pack.cmi mytypes.cmi \ ../labltk/menu.cmi ../../../parsing/longident.cmi \ ../../../parsing/location.cmi ../labltk/listbox.cmi ../labltk/label.cmi \ jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_multibox.cmi jg_message.cmi \ jg_menu.cmo jg_entry.cmo jg_completion.cmi jg_button.cmo jg_box.cmo \ jg_bind.cmi ../../../typing/ident.cmi help.cmo ../labltk/frame.cmi \ ../labltk/focus.cmi ../../../typing/env.cmi ../labltk/entry.cmi \ ../../../utils/config.cmi ../../../typing/cmi_format.cmi \ ../labltk/button.cmi viewer.cmi viewer.cmx : ../labltk/wm.cmx useunix.cmx ../../../typing/types.cmx \ ../../../typing/typedtree.cmx ../labltk/toplevel.cmx ../labltk/tk.cmx \ ../support/textvariable.cmx ../labltk/text.cmx shell.cmx setpath.cmx \ searchpos.cmx searchid.cmx ../labltk/radiobutton.cmx \ ../support/protocol.cmx ../../../typing/predef.cmx \ ../../../typing/path.cmx ../labltk/pack.cmx mytypes.cmi \ ../labltk/menu.cmx ../../../parsing/longident.cmx \ ../../../parsing/location.cmx ../labltk/listbox.cmx ../labltk/label.cmx \ jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_multibox.cmx jg_message.cmx \ jg_menu.cmx jg_entry.cmx jg_completion.cmx jg_button.cmx jg_box.cmx \ jg_bind.cmx ../../../typing/ident.cmx help.cmx ../labltk/frame.cmx \ ../labltk/focus.cmx ../../../typing/env.cmx ../labltk/entry.cmx \ ../../../utils/config.cmx ../../../typing/cmi_format.cmx \ ../labltk/button.cmx viewer.cmi dummy.cmi : dummyUnix.cmi : dummyWin.cmi : editor.cmi : ../support/widget.cmi fileselect.cmi : jg_bind.cmi : ../support/widget.cmi jg_completion.cmi : jg_config.cmi : jg_memo.cmi : jg_message.cmi : ../support/widget.cmi jg_multibox.cmi : ../support/widget.cmi ../labltk/tk.cmo jg_text.cmi : ../support/widget.cmi ../labltk/tk.cmo lexical.cmi : ../support/widget.cmi ../labltk/tk.cmo mytypes.cmi : ../support/widget.cmi ../../../typing/types.cmi \ ../../../typing/typedtree.cmi ../support/textvariable.cmi \ ../../../typing/stypes.cmi shell.cmi ../../../parsing/parsetree.cmi searchid.cmi : ../../../typing/path.cmi ../../../parsing/parsetree.cmi \ ../../../parsing/longident.cmi ../../../typing/env.cmi searchpos.cmi : ../support/widget.cmi ../../../typing/types.cmi \ ../../../typing/typedtree.cmi ../../../typing/stypes.cmi \ ../../../typing/path.cmi ../../../parsing/parsetree.cmi \ ../../../parsing/longident.cmi ../../../parsing/location.cmi \ ../../../typing/env.cmi setpath.cmi : ../support/widget.cmi shell.cmi : ../support/widget.cmi typecheck.cmi : ../support/widget.cmi mytypes.cmi useunix.cmi : viewer.cmi : ../support/widget.cmi ../../../parsing/longident.cmi \ ../../../typing/env.cmi mingw-ocaml/ocaml/otherlibs/labltk/browser/dummyUnix.mli0000644000175000017500000000234312124403241023111 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2000 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) module Mutex : sig type t external create : unit -> t = "%ignore" external lock : t -> unit = "%ignore" external unlock : t -> unit = "%ignore" end module Thread : sig type t external create : ('a -> 'b) -> 'a -> t = "caml_ml_input" end mingw-ocaml/ocaml/otherlibs/labltk/browser/typecheck.mli0000644000175000017500000000217512124403241023074 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open Widget open Mytypes val nowarnings : bool ref val f : edit_window -> any widget list (* Typechecks the window as much as possible *) mingw-ocaml/ocaml/otherlibs/labltk/browser/lexical.ml0000644000175000017500000000730112124403241022361 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) open StdLabels open Tk open Jg_tk open Parser let tags = ["control"; "define"; "structure"; "char"; "infix"; "label"; "uident"] and colors = ["blue"; "forestgreen"; "purple"; "gray40"; "indianred4"; "saddlebrown"; "midnightblue"] let init_tags tw = List.iter2 tags colors ~f: begin fun tag col -> Text.tag_configure tw ~tag ~foreground:(`Color col) end; Text.tag_configure tw ~tag:"error" ~foreground:`Red; Text.tag_configure tw ~tag:"error" ~relief:`Raised; Text.tag_raise tw ~tag:"error" let tag ?(start=tstart) ?(stop=tend) tw = let tpos c = (Text.index tw ~index:start, [`Char c]) in let text = Text.get tw ~start ~stop in let buffer = Lexing.from_string text in Location.init buffer ""; Location.input_name := ""; List.iter tags ~f:(fun tag -> Text.tag_remove tw ~start ~stop ~tag); let last = ref (EOF, 0, 0) in try while true do let token = Lexer.token buffer and start = Lexing.lexeme_start buffer and stop = Lexing.lexeme_end buffer in let tag = match token with AMPERAMPER | AMPERSAND | BARBAR | DO | DONE | DOWNTO | ELSE | FOR | IF | LAZY | MATCH | OR | THEN | TO | TRY | WHEN | WHILE | WITH -> "control" | AND | AS | BAR | CLASS | CONSTRAINT | EXCEPTION | EXTERNAL | FUN | FUNCTION | FUNCTOR | IN | INHERIT | INITIALIZER | LET | METHOD | MODULE | MUTABLE | NEW | OF | PRIVATE | REC | TYPE | VAL | VIRTUAL -> "define" | BEGIN | END | INCLUDE | OBJECT | OPEN | SIG | STRUCT -> "structure" | CHAR _ | STRING _ -> "char" | BACKQUOTE | INFIXOP1 _ | INFIXOP2 _ | INFIXOP3 _ | INFIXOP4 _ | PREFIXOP _ | SHARP -> "infix" | LABEL _ | OPTLABEL _ | QUESTION | TILDE -> "label" | UIDENT _ -> "uident" | LIDENT _ -> begin match !last with (QUESTION | TILDE), _, _ -> "label" | _ -> "" end | COLON -> begin match !last with LIDENT _, lstart, lstop -> if lstop = start then Text.tag_add tw ~tag:"label" ~start:(tpos lstart) ~stop:(tpos stop); "" | _ -> "" end | EOF -> raise End_of_file | _ -> "" in if tag <> "" then Text.tag_add tw ~tag ~start:(tpos start) ~stop:(tpos stop); last := (token, start, stop) done with End_of_file -> () | Lexer.Error (err, loc) -> () mingw-ocaml/ocaml/otherlibs/labltk/browser/jg_completion.mli0000644000175000017500000000236312124403241023745 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) val lt_string : ?nocase:bool -> string -> string -> bool class timed : ?nocase:bool -> ?wait:int -> string list -> object val mutable texts : string list method add : string -> int method current : int method get_current : string method reset : unit end mingw-ocaml/ocaml/otherlibs/labltk/browser/fileselect.mli0000644000175000017500000000304712124403241023233 0ustar tootstoots(*************************************************************************) (* *) (* OCaml LablTk library *) (* *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (*************************************************************************) (* $Id$ *) val f : title:string -> action:(string list -> unit) -> ?dir:string -> ?filter:string -> ?file:string -> ?multi:bool -> ?sync:bool -> ?usepath:bool -> unit -> unit (* action [] means canceled if multi select is false, then the list is null or a singleton *) (* multi If true then more than one file are selectable *) (* sync If true then synchronous mode *) (* usepath Enables/disables load path search. Defaults to true *) val caml_dir : string -> string (* Convert Windows-style directory separator '\' to caml-style '/' *) mingw-ocaml/ocaml/otherlibs/labltk/README0000644000175000017500000001344212124403241017606 0ustar tootstootsINTRODUCTION ============ mlTk is a library for interfacing OCaml with the scripting language Tcl/Tk (all versions since 8.0.3, but no betas). In addition to the basic interface with Tcl/Tk, this package contains * the OCamlBrowser code editor / library browser written by Jacques Garrigue. * the "jpf" library, written by Jun P. Furuse; it contains a "file selector" and "balloon help" support * the "frx" library, written by Francois Rouaix * the "tkanim" library, which supports animated gif loading/display mlTk = CamlTk + LablTk ====================== There existed two parallel Tcl/Tk interfaces for OCaml, CamlTk and LablTk. CamlTk uses classical features only, therefore it is easy to understand for the beginners of ML. It makes many conservative OCaml gurus also happy. LablTk, on the other hand, uses rather newer features of OCaml, the labeled optional arguments and polymorphic variants. Its syntax has much more Tcl/Tk script flavor, but provides more powerful typing than CamlTk at the same time (i.e. less run time type checking of widgets). Until now, these two interfaces have been distributed and maintained independently. mlTk unifies these libraries into one. Since mlTk provides the both API's, both CamlTk and LablTk users can compile their applications with mlTk, just with little fixes. REQUIREMENTS ============ You must have already installed * OCaml source, version 3.04+8 or later * Tcl/Tk 8.0.3 or later http://www.scriptics.com/ or various mirrors PLATFORMS: Essentially any Unix/X Window System platform. We have tested releases on Linux (ELF x86), FreeBSD (x86), SunOS4.1.x (sparc), DEC OSF/1 V4.0 (alpha), DGUX SVR4 (m88k) and Windows (VC++ and Cygwin). INSTALLATION ============ 0. Check-out the OCaml CVS source code tree. 1. Compile OCaml (= make world). If you want, also make opt. 2. Untar this mlTk distribution in the otherlibs directory, just like the labltk source tree. 3. change directory to otherlibs/mltk, and make (and make opt) 4. To install the library, make install (and make installopt) To compile mlTk, you need the OCaml source tree, since mltk/camlbrowser requires some modules of OCaml. If you are not interested in camlbrowser, you can compile mlTk without the OCaml source tree, but you have to modify support/Makefile.common. Compile your CamlTk/LablTk applications with mlTk ================================================= * General The names of the additional libraries libjpf and libfrx are changed to jpflib and frxlib respectively, to avoid the library name space confusion. * LablTk users Just change the occurrences of labltk in your Makefiles to mltk (i.e. -I +labltk => -I +mltk, labltk.cma => mltk.cma, and so on) Since the API functions are 100% compatible, you need not to change your .ml files. * CamlTk users - Makefiles : apply the same modification explained above for LablTk users. - open Camltk : The API modules and functions are stored in the modules Camltk. Therefore you need to replace the module name Tk to Camltk. For example, open Tk => open Camltk. open Camltk (* instead of open Tk *) let t = openTk ();; let b = Button.create t [];; - You may also need to open the Camltk module explicitly, when your original module source contain no open Tk phrase. Widget and the other Tcl/Tk related types are now under Camltk. (e.g. Widget.widget is now Camltk.Widget.widget) Add open Camltk at the beginning of .mli files, if these types are used: open Camltk (* added for compiling under mlTk *) val create_progress_bar : Widget.widget -> Widget.widget - Eta expansion to flush optional arguments at registering callbacks. Functions with the _displayof suffix are unified with their non-displayof versions, using optional labeled arguments. For example, Bell.ring had/have the following types: before: Bell.ring : unit -> unit now: Bell.ring : ?displayof:Camltk.widget -> unit -> unit If you use these functions as callbacks directly like Command Bell.ring, you need eta-expansions to flush these new optional arguments: Button.create w [Command Bell.ring] => Button.create w [Command (fun () -> Bell.ring ())] Use the both API's at the same time =================================== It is possible to use the both API's in one program. If you want to use a widget library written in the different API from you use, you need to do it. (It will be confusing, but easier than porting the library itself from one to the other API.) For the users who mainly use LablTk API, CamlTk API is available in the modules start with 'C'. For example, the source file of the CamlTk button widget functions is CButton (and exported also as Camltk.Button). For the users who mainly use CamlTk API, LablTk API modules are exported inside Labltk module. For example, LablTk's Button module can be also accessible as Labltk.Button. In CamlTk, we have only one widget type, [widget]. This type is equivalent to the LablTk's type [any widget]. Therefore, if you want to apply CamlTk functions to LablTk widget, you can use [coe] function to coerce it to [any widget]. To do the converse, the "widget-typers" are available inside the module Labltk. For example, to recover the type of a button widget, use Labltk.button. These widget-typers checks the types of widgets at run-time. If the widget type is different from the context type, a run-time exception is raised. open Tk (* open LablTk API *) let t = openTk ();; (* t is LablTk widget, toplevel widget *) (* CButton.create takes [any widget]; [t] must be coerced to the type. *) let caml_b = CButton.create (coe t) [];; (* caml_b is [any widget], must be explicitly typed as [button widget], when it is used with LablTk API functions *) let b = Labltk.button caml_b in (* recover the type [button widget] *) ... mingw-ocaml/ocaml/otherlibs/labltk/compiler/0000755000175000017500000000000012124403241020534 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/compiler/.ignore0000644000175000017500000000016012124403241022015 0ustar tootstootslexer.ml parser.output parser.ml parser.mli tkcompiler pp copyright.ml pplex.ml ppyac.ml ppyac.output ppyac.mli mingw-ocaml/ocaml/otherlibs/labltk/compiler/ppyac.mly0000644000175000017500000000335012124403241022374 0ustar tootstoots/***********************************************************************/ /* */ /* MLTk, Tcl/Tk interface of OCaml */ /* */ /* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file ../../../LICENSE. */ /* */ /***********************************************************************/ %{ open Code %} %token IFDEF %token IFNDEF %token ELSE %token ENDIF %token DEFINE %token UNDEF %token OTHER %token EOF /* entry */ %start code_list %type code_list %% code_list: /* empty */ { [] } | code code_list { $1 :: $2 } ; code: | DEFINE { Define $1 } | UNDEF { Undef $1 } | IFDEF code_list ELSE code_list ENDIF { Ifdef (true, $1, $2, Some ($4)) } | IFNDEF code_list ELSE code_list ENDIF { Ifdef (false, $1, $2, Some ($4)) } | IFDEF code_list ENDIF { Ifdef (true, $1, $2, None) } | IFNDEF code_list ENDIF { Ifdef (false, $1, $2, None) } | OTHER { Line $1 } ; %% mingw-ocaml/ocaml/otherlibs/labltk/compiler/Makefile0000644000175000017500000000500712124403241022176 0ustar tootstoots####################################################################### # # # MLTk, Tcl/Tk interface of OCaml # # # # Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # # projet Cristal, INRIA Rocquencourt # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique and Kyoto University. All rights reserved. # # This file is distributed under the terms of the GNU Library # # General Public License, with the special exception on linking # # described in file LICENSE found in the OCaml source tree. # # # ####################################################################### include ../support/Makefile.common OBJS= ../support/support.cmo flags.cmo copyright.cmo \ tsort.cmo tables.cmo printer.cmo lexer.cmo \ pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo \ parser.cmo compile.cmo intf.cmo maincompile.cmo PPOBJS= pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo pp.cmo all: tkcompiler$(EXE) pp$(EXE) tkcompiler$(EXE) : $(OBJS) $(CAMLC) -g $(LINKFLAGS) -o tkcompiler$(EXE) $(OBJS) pp$(EXE): $(PPOBJS) $(CAMLC) -g $(LINKFLAGS) -o pp$(EXE) $(PPOBJS) lexer.ml: lexer.mll $(CAMLLEX) lexer.mll parser.ml parser.mli: parser.mly $(CAMLYACC) -v parser.mly pplex.ml: pplex.mll $(CAMLLEX) pplex.mll pplex.mli: ppyac.cmi ppyac.ml ppyac.mli: ppyac.mly $(CAMLYACC) -v ppyac.mly copyright.ml: copyright (echo "let copyright=\"\\"; \ sed -e 's/$$/\\n\\/' copyright; \ echo "\""; \ echo "let write ~w = w copyright;;") > copyright.ml clean : rm -f *.cm* parser.ml parser.mli lexer.ml copyright.ml rm -f pplex.ml ppyac.ml ppyac.mli ppyac.output rm -f tkcompiler$(EXE) pp$(EXE) parser.output scratch : rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler$(EXE) rm -f *.cm* pplex.ml ppyac.ml ppyac.mli pp$(EXE) install: cp tkcompiler$(EXE) $(INSTALLDIR) cp pp$(EXE) $(INSTALLDIR) .SUFFIXES : .SUFFIXES : .mli .ml .cmi .cmo .mlp .mli.cmi: $(CAMLCOMP) $(COMPFLAGS) -I ../support $< .ml.cmo: $(CAMLCOMP) $(COMPFLAGS) -I ../support $< depend: parser.ml parser.mli lexer.ml pplex.ml ppyac.ml ppyac.mli $(CAMLDEP) *.mli *.ml > .depend include .depend mingw-ocaml/ocaml/otherlibs/labltk/compiler/tables.ml0000644000175000017500000003256612124403241022354 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) open StdLabels open Support (* Internal compiler errors *) exception Compiler_Error of string let fatal_error s = raise (Compiler_Error s) (* Types of the description language *) type mltype = Unit | Int | Float | Bool | Char | String | List of mltype | Product of mltype list | Record of (string * mltype) list | UserDefined of string | Subtype of string * string | Function of mltype (* arg type only *) | As of mltype * string type template = StringArg of string | TypeArg of string * mltype | ListArg of template list | OptionalArgs of string * template list * template list (* Sorts of components *) type component_type = Constructor | Command | External (* Full definition of a component *) type fullcomponent = { component : component_type; ml_name : string; (* used for camltk *) var_name : string; (* used just for labltk *) template : template; result : mltype; safe : bool } let sort_components = List.sort ~cmp:(fun c1 c2 -> compare c1.ml_name c2.ml_name) (* components are given either in full or abbreviated *) type component = Full of fullcomponent | Abbrev of string (* A type definition *) (* requires_widget_context: the converter of the type MUST be passed an additional argument of type Widget. *) type parser_arity = OneToken | MultipleToken type type_def = { parser_arity : parser_arity; mutable constructors : fullcomponent list; mutable subtypes : (string * fullcomponent list) list; mutable requires_widget_context : bool; mutable variant : bool } type module_type = Widget | Family type module_def = { module_type : module_type; commands : fullcomponent list; externals : fullcomponent list } (******************** The tables ********************) (* the table of all explicitly defined types *) let types_table = (Hashtbl.create 37 : (string, type_def) Hashtbl.t) (* "builtin" types *) let types_external = ref ([] : (string * parser_arity) list) (* dependancy order *) let types_order = (Tsort.create () : string Tsort.porder) (* Types of atomic values returned by Tk functions *) let types_returned = ref ([] : string list) (* Function table *) let function_table = ref ([] : fullcomponent list) (* Widget/Module table *) let module_table = (Hashtbl.create 37 : (string, module_def) Hashtbl.t) (* variant name *) let rec getvarname ml_name temp = let offhypben s = let s = String.copy s in if (try String.sub s ~pos:0 ~len:1 with _ -> "") = "-" then String.sub s ~pos:1 ~len:(String.length s - 1) else s and makecapital s = begin try let cd = s.[0] in if cd >= 'a' && cd <= 'z' then s.[0] <- Char.chr (Char.code cd + (Char.code 'A' - Char.code 'a')) with _ -> () end; s in let head = makecapital (offhypben begin match temp with StringArg s -> s | TypeArg (s,t) -> s | ListArg (h::_) -> getvarname ml_name h | OptionalArgs (s,_,_) -> s | ListArg [] -> "" end) in let varname = if head = "" then ml_name else if head.[0] >= 'A' && head.[0] <= 'Z' then head else ml_name in varname (***** Some utilities on the various tables *****) (* Enter a new empty type *) let new_type typname arity = Tsort.add_element types_order typname; let typdef = {parser_arity = arity; constructors = []; subtypes = []; requires_widget_context = false; variant = false} in Hashtbl.add types_table typname typdef; typdef (* Assume that types not yet defined are not subtyped *) (* Widget is builtin and implicitly subtyped *) let is_subtyped s = s = "widget" || try let typdef = Hashtbl.find types_table s in typdef.subtypes <> [] with Not_found -> false let requires_widget_context s = try (Hashtbl.find types_table s).requires_widget_context with Not_found -> false let declared_type_parser_arity s = try (Hashtbl.find types_table s).parser_arity with Not_found -> try List.assoc s !types_external with Not_found -> prerr_string "Type "; prerr_string s; prerr_string " is undeclared external or undefined\n"; prerr_string ("Assuming cTKtoCAML"^s^" : string -> "^s^"\n"); OneToken let rec type_parser_arity = function Unit -> OneToken | Int -> OneToken | Float -> OneToken | Bool -> OneToken | Char -> OneToken | String -> OneToken | List _ -> MultipleToken | Product _ -> MultipleToken | Record _ -> MultipleToken | UserDefined s -> declared_type_parser_arity s | Subtype (s,_) -> declared_type_parser_arity s | Function _ -> OneToken | As (ty, _) -> type_parser_arity ty let enter_external_type s v = types_external := (s,v)::!types_external (*** Stuff for topological Sort.list of types ***) (* Make sure all types used in commands and functions are in *) (* the table *) let rec enter_argtype = function Unit | Int | Float | Bool | Char | String -> () | List ty -> enter_argtype ty | Product tyl -> List.iter ~f:enter_argtype tyl | Record tyl -> List.iter tyl ~f:(fun (l,t) -> enter_argtype t) | UserDefined s -> Tsort.add_element types_order s | Subtype (s,_) -> Tsort.add_element types_order s | Function ty -> enter_argtype ty | As (ty, _) -> enter_argtype ty let rec enter_template_types = function StringArg _ -> () | TypeArg (l,t) -> enter_argtype t | ListArg l -> List.iter ~f:enter_template_types l | OptionalArgs (_,tl,_) -> List.iter ~f:enter_template_types tl (* Find type dependancies on s *) let rec add_dependancies s = function List ty -> add_dependancies s ty | Product tyl -> List.iter ~f:(add_dependancies s) tyl | Subtype(s',_) -> if s <> s' then Tsort.add_relation types_order (s', s) | UserDefined s' -> if s <> s' then Tsort.add_relation types_order (s', s) | Function ty -> add_dependancies s ty | As (ty, _) -> add_dependancies s ty | _ -> () let rec add_template_dependancies s = function StringArg _ -> () | TypeArg (l,t) -> add_dependancies s t | ListArg l -> List.iter ~f:(add_template_dependancies s) l | OptionalArgs (_,tl,_) -> List.iter ~f:(add_template_dependancies s) tl (* Assumes functions are not nested in products, which is reasonable due to syntax*) let rec has_callback = function StringArg _ -> false | TypeArg (l,Function _ ) -> true | TypeArg _ -> false | ListArg l -> List.exists ~f:has_callback l | OptionalArgs (_,tl,_) -> List.exists ~f:has_callback tl (*** Returned types ***) let really_add ty = if List.mem ty !types_returned then () else types_returned := ty :: !types_returned let rec add_return_type = function Unit -> () | Int -> () | Float -> () | Bool -> () | Char -> () | String -> () | List ty -> add_return_type ty | Product tyl -> List.iter ~f:add_return_type tyl | Record tyl -> List.iter tyl ~f:(fun (l,t) -> add_return_type t) | UserDefined s -> really_add s | Subtype (s,_) -> really_add s | Function _ -> fatal_error "unexpected return type (function)" (* whoah *) | As (ty, _) -> add_return_type ty (*** Update tables for a component ***) let enter_component_types {template = t; result = r} = add_return_type r; enter_argtype r; enter_template_types t (******************** Types and subtypes ********************) exception Duplicate_Definition of string * string exception Invalid_implicit_constructor of string (* Checking duplicate definition of constructor in subtypes *) let rec check_duplicate_constr allowed c = function [] -> false (* not defined *) | c'::rest -> if c.ml_name = c'.ml_name then (* defined *) if allowed then if c.template = c'.template then true (* same arg *) else raise (Duplicate_Definition ("constructor",c.ml_name)) else raise (Duplicate_Definition ("constructor", c.ml_name)) else check_duplicate_constr allowed c rest (* Retrieve constructor *) let rec find_constructor cname = function [] -> raise (Invalid_implicit_constructor cname) | c::l -> if c.ml_name = cname then c else find_constructor cname l (* Enter a type, must not be previously defined *) let enter_type typname ?(variant = false) arity constructors = if Hashtbl.mem types_table typname then raise (Duplicate_Definition ("type", typname)) else let typdef = new_type typname arity in if variant then typdef.variant <- true; List.iter constructors ~f: begin fun c -> if not (check_duplicate_constr false c typdef.constructors) then begin typdef.constructors <- c :: typdef.constructors; add_template_dependancies typname c.template end; (* Callbacks require widget context *) typdef.requires_widget_context <- typdef.requires_widget_context || has_callback c.template end (* Enter a subtype *) let enter_subtype typ arity subtyp constructors = (* Retrieve the type if already defined, else add a new one *) let typdef = try Hashtbl.find types_table typ with Not_found -> new_type typ arity in if List.mem_assoc subtyp typdef.subtypes then raise (Duplicate_Definition ("subtype", typ ^" "^subtyp)) else begin let real_constructors = List.map constructors ~f: begin function Full c -> if not (check_duplicate_constr true c typdef.constructors) then begin add_template_dependancies typ c.template; typdef.constructors <- c :: typdef.constructors end; typdef.requires_widget_context <- typdef.requires_widget_context || has_callback c.template; c | Abbrev name -> find_constructor name typdef.constructors end in (* TODO: duplicate def in subtype are not checked *) typdef.subtypes <- (subtyp , List.sort real_constructors ~cmp:(fun c1 c2 -> compare c1.var_name c2.var_name)) :: typdef.subtypes end (******************** Widgets ********************) (* used by the parser; when enter_widget is called, all components are assumed to be in Full form *) let retrieve_option optname = let optiontyp = try Hashtbl.find types_table "options" with Not_found -> raise (Invalid_implicit_constructor optname) in find_constructor optname optiontyp.constructors (* Sort components by type *) let rec add_sort l obj = match l with [] -> [obj.component ,[obj]] | (s',l)::rest -> if obj.component = s' then (s',obj::l)::rest else (s',l)::(add_sort rest obj) let separate_components = List.fold_left ~f:add_sort ~init:[] let enter_widget name components = if Hashtbl.mem module_table name then raise (Duplicate_Definition ("widget/module", name)) else let sorted_components = separate_components components in List.iter sorted_components ~f: begin function Constructor, l -> enter_subtype "options" MultipleToken name (List.map ~f:(fun c -> Full c) l) | Command, l -> List.iter ~f:enter_component_types l | External, _ -> () end; let commands = try List.assoc Command sorted_components with Not_found -> [] and externals = try List.assoc External sorted_components with Not_found -> [] in Hashtbl.add module_table name {module_type = Widget; commands = commands; externals = externals} (******************** Functions ********************) let enter_function comp = enter_component_types comp; function_table := comp :: !function_table (******************** Modules ********************) let enter_module name components = if Hashtbl.mem module_table name then raise (Duplicate_Definition ("widget/module", name)) else let sorted_components = separate_components components in List.iter sorted_components ~f: begin function Constructor, l -> fatal_error "unexpected Constructor" | Command, l -> List.iter ~f:enter_component_types l | External, _ -> () end; let commands = try List.assoc Command sorted_components with Not_found -> [] and externals = try List.assoc External sorted_components with Not_found -> [] in Hashtbl.add module_table name {module_type = Family; commands = commands; externals = externals} mingw-ocaml/ocaml/otherlibs/labltk/compiler/Makefile.nt0000644000175000017500000000002112124403241022605 0ustar tootstootsinclude Makefile mingw-ocaml/ocaml/otherlibs/labltk/compiler/copyright0000644000175000017500000000212612124403241022470 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) mingw-ocaml/ocaml/otherlibs/labltk/compiler/compile.ml0000644000175000017500000010672312124403241022527 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) open StdLabels open Tables (* CONFIGURE *) (* if you set it true, ImagePhoto and ImageBitmap will annoy you... *) let safetype = true let labeloff ~at l = match l with "", t -> t | l, t -> raise (Failure ("labeloff: " ^ l ^ " at " ^ at)) let labltk_labelstring l = if l = "" then l else if l.[0] = '?' then l ^ ":" else "~" ^ l ^ ":" let camltk_labelstring l = if l = "" then l else if l.[0] = '?' then l ^ ":" else "" let labelstring l = if !Flags.camltk then camltk_labelstring l else labltk_labelstring l let labltk_typelabel l = if l = "" then l else l ^ ":" let camltk_typelabel l = if l = "" then l else if l.[0] = '?' then l ^ ":" else "" let typelabel l = if !Flags.camltk then camltk_typelabel l else labltk_typelabel l let forbidden = [ "class"; "type"; "in"; "from"; "to" ] let nicknames = [ "class", "clas"; "type", "typ" ] let small = String.lowercase let gettklabel fc = match fc.template with ListArg( StringArg s :: _ ) -> let s = small s in if s = "" then s else let s = if s.[0] = '-' then String.sub s ~pos:1 ~len:(String.length s - 1) else s in begin if List.mem s forbidden then try List.assoc s nicknames with Not_found -> small fc.var_name else s end | _ -> raise (Failure "gettklabel") let count ~item:x l = let count = ref 0 in List.iter ~f:(fun y -> if x = y then incr count) l; !count (* Extract all types from a template *) let rec types_of_template = function StringArg _ -> [] | TypeArg (l, t) -> [l, t] | ListArg l -> List.flatten (List.map ~f:types_of_template l) | OptionalArgs (l, tl, _) -> begin match List.flatten (List.map ~f:types_of_template tl) with ["", t] -> ["?" ^ l, t] | [_, _] -> raise (Failure "0 label required") | _ -> raise (Failure "0 or more than 1 args in for optionals") end (* * Pretty print a type * used to write ML type definitions *) let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) = let rec ppMLtype = function Unit -> "unit" | Int -> "int" | Float -> "float" | Bool -> "bool" | Char -> "char" | String -> "string" (* new *) | List (Subtype (sup, sub)) -> if !Flags.camltk then "(* " ^ sub ^ " *) " ^ sup ^ " list" else begin if return then sub ^ "_" ^ sup ^ " list" else begin try let typdef = Hashtbl.find types_table sup in let fcl = List.assoc sub typdef.subtypes in let tklabels = List.map ~f:gettklabel fcl in let l = List.map fcl ~f: begin fun fc -> "?" ^ begin let p = gettklabel fc in if count ~item:p tklabels > 1 then small fc.var_name else p end ^ ":" ^ let l = types_of_template fc.template in match l with [] -> "unit" | [lt] -> ppMLtype (labeloff lt ~at:"ppMLtype") | l -> "(" ^ String.concat ~sep:"*" (List.map l ~f:(fun lt -> ppMLtype (labeloff lt ~at:"ppMLtype"))) ^ ")" end in String.concat ~sep:" ->\n" l with Not_found -> Printf.eprintf "ppMLtype %s/%s\n" sup sub; exit (-1) end end | List ty -> (ppMLtype ty) ^ " list" | Product tyl -> "(" ^ String.concat ~sep:" * " (List.map ~f:ppMLtype tyl) ^ ")" | Record tyl -> String.concat ~sep:" * " (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t)) | Subtype ("widget", sub) -> if !Flags.camltk then "(* " ^ sub ^" *) widget" else sub ^ " widget" | UserDefined "widget" -> if !Flags.camltk then "widget" else begin if any then "any widget" else let c = String.make 1 (Char.chr(Char.code 'a' + !counter)) in incr counter; "'" ^ c ^ " widget" end | UserDefined s -> if !Flags.camltk then s else begin (* a bit dirty hack for ImageBitmap and ImagePhoto *) try let typdef = Hashtbl.find types_table s in if typdef.variant then if return then try "[>" ^ String.concat ~sep:"|" (List.map typdef.constructors ~f: begin fun c -> "`" ^ c.var_name ^ (match types_of_template c.template with [] -> "" | l -> " of " ^ ppMLtype (Product (List.map l ~f:(labeloff ~at:"ppMLtype UserDefined")))) end) ^ "]" with Not_found -> prerr_endline ("ppMLtype " ^ s ^ " ?"); s else if not def && List.length typdef.constructors > 1 then "[< " ^ s ^ "]" else s else s with Not_found -> s end | Subtype (s, s') -> if !Flags.camltk then "(* " ^ s' ^ " *) " ^ s else s' ^ "_" ^ s | Function (Product tyl) -> raise (Failure "Function (Product tyl) ? ppMLtype") | Function (Record tyl) -> "(" ^ String.concat ~sep:" -> " (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t)) ^ " -> unit)" | Function ty -> "(" ^ (ppMLtype ty) ^ " -> unit)" | As (t, s) -> if !Flags.camltk then ppMLtype t else s in ppMLtype (* Produce a documentation version of a template *) let rec ppTemplate = function StringArg s -> s | TypeArg (l, t) -> "<" ^ ppMLtype t ^ ">" | ListArg l -> "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate l) ^ "}" | OptionalArgs (l, tl, d) -> "?" ^ l ^ "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate tl) ^ "}[<" ^ String.concat ~sep:" " (List.map ~f:ppTemplate d) ^ ">]" let doc_of_template = function ListArg l -> String.concat ~sep:" " (List.map ~f:ppTemplate l) | t -> ppTemplate t (* * Type definitions *) (* Write an ML constructor *) let write_constructor ~w {ml_name = mlconstr; template = t} = w mlconstr; begin match types_of_template t with [] -> () | l -> w " of "; w (ppMLtype ~any:true (Product (List.map l ~f:(labeloff ~at:"write_constructor")))) end; w " (* tk option: "; w (doc_of_template t); w " *)" (* Write a rhs type decl *) let write_constructors ~w = function [] -> fatal_error "empty type" | x :: l -> write_constructor ~w x; List.iter l ~f: begin fun x -> w "\n | "; write_constructor ~w x end (* Write an ML variant *) let write_variant ~w {var_name = varname; template = t} = w "`"; w varname; begin match types_of_template t with [] -> () | l -> w " of "; w (ppMLtype ~any:true ~def:true (Product (List.map l ~f:(labeloff ~at:"write_variant")))) end; w " (* tk option: "; w (doc_of_template t); w " *)" let write_variants ~w = function [] -> fatal_error "empty variants" | l -> List.iter l ~f: begin fun x -> w "\n | "; write_variant ~w x end (* Definition of a type *) let labltk_write_type ~intf:w ~impl:w' name ~def:typdef = (* Only needed if no subtypes, otherwise use optionals *) if typdef.subtypes = [] then begin w "(* Variant type *)\n"; w ("type " ^ name ^ " = ["); write_variants ~w (sort_components typdef.constructors); w "\n]\n\n" end (* CamlTk: List of constructors, for runtime subtyping *) let write_constructor_set ~w ~sep = function | [] -> fatal_error "empty type" | x::l -> w ("C" ^ x.ml_name); List.iter l ~f: (function x -> w sep; w ("C" ^ x.ml_name)) (* CamlTk: Definition of a type *) let camltk_write_type ~intf:w ~impl:w' name ~def:typdef = (* Put markers for extraction *) w "(* type *)\n"; w ("type " ^ name ^ " =\n"); w " | "; write_constructors ~w (sort_components typdef.constructors); w "\n(* /type *)\n\n"; (* Dynamic Subtyping *) if typdef.subtypes <> [] then begin (* The set of its constructors *) if name = "options" then begin w "(* type *)\n"; w ("type "^name^"_constrs =\n\t") end else begin (* added some prefix to avoid being picked up in documentation *) w ("(* no doc *) type "^name^"_constrs =\n") end; w " | "; write_constructor_set ~w:w ~sep: "\n | " (sort_components typdef.constructors); w "\n\n"; (* The set of all constructors *) w' ("let "^name^"_any_table = ["); write_constructor_set ~w:w' ~sep:"; " (sort_components typdef.constructors); w' ("]\n\n"); (* The subset of constructors for each subtype *) List.iter ~f:(function (s,l) -> w' ("let "^name^"_"^s^"_table = ["); write_constructor_set ~w:w' ~sep:"; " (sort_components l); w' ("]\n\n")) typdef.subtypes end let write_type ~intf:w ~impl:w' name ~def:typdef = (if !Flags.camltk then camltk_write_type else labltk_write_type) ~intf:w ~impl:w' name ~def:typdef (************************************************************) (* Converters *) (************************************************************) let rec converterTKtoCAML ~arg = function | Int -> "int_of_string " ^ arg | Float -> "float_of_string " ^ arg | Bool -> "(match " ^ arg ^ " with\n\ | \"1\" -> true\n\ | \"0\" -> false\n\ | s -> Pervasives.raise (Invalid_argument (\"cTKtoCAMLbool\" ^ s)))" | Char -> "String.get " ^ arg ^ " 0" | String -> arg | UserDefined s -> "cTKtoCAML" ^ s ^ " " ^ arg | Subtype ("widget", s') when not !Flags.camltk -> String.concat ~sep:" " ["(Obj.magic (cTKtoCAMLwidget "; arg; ") :"; s'; "widget)"] | Subtype (s, s') -> if !Flags.camltk then "cTKtoCAML" ^ s ^ " " ^ arg else "cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg | List ty -> begin match type_parser_arity ty with OneToken -> String.concat ~sep:" " ["(List.map (function x ->"; converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"] | MultipleToken -> String.concat ~sep:" " ["iterate_converter (function x ->"; converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"] end | As (ty, _) -> converterTKtoCAML ~arg ty | t -> prerr_endline ("ERROR with " ^ arg ^ " " ^ ppMLtype t); fatal_error "converterTKtoCAML" (*******************************) (* Wrappers *) (*******************************) let varnames ~prefix n = let rec var i = if i > n then [] else (prefix ^ string_of_int i) :: var (succ i) in var 1 (* * generate wrapper source for callbacks * transform a function ... -> unit in a function : unit -> unit * using primitives arg_ ... from the protocol * Warning: sequentiality is important in generated code * TODO: remove arg_ stuff and process lists directly ? *) let rec wrapper_code ~name ty = match ty with Unit -> "(fun _ -> " ^ name ^ " ())" | As (ty, _) -> wrapper_code ~name ty | ty -> "(fun args ->\n " ^ begin match ty with Product tyl -> raise (Failure "Product -> record was done. ???") | Record tyl -> (* variables for each component of the product *) let vnames = varnames ~prefix:"a" (List.length tyl) in (* getting the arguments *) let readarg = List.map2 vnames tyl ~f: begin fun v (l, ty) -> match type_parser_arity ty with OneToken -> "let (" ^ v ^ ", args) = " ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ", List.tl args in\n " | MultipleToken -> "let (" ^ v ^ ", args) = " ^ converterTKtoCAML ~arg:"args" ty ^ " in\n " end in String.concat ~sep:"" readarg ^ name ^ " " ^ String.concat ~sep:" " (List.map2 ~f:(fun v (l, _) -> if !Flags.camltk then v else labelstring l ^ v) vnames tyl) (* all other types are read in one operation *) | List ty -> name ^ "(" ^ converterTKtoCAML ~arg:"args" ty ^ ")" | String -> name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")" | ty -> begin match type_parser_arity ty with OneToken -> name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")" | MultipleToken -> "let (v, _) = " ^ converterTKtoCAML ~arg:"args" ty ^ " in\n " ^ name ^ " v" end end ^ ")" (*************************************************************) (* Parsers *) (* are required only for values returned by commands and *) (* functions (table is computed by the parser) *) (* Tuples/Lists are Ok if they don't contain strings *) (* they will be returned as list of strings *) (* Can we generate a "parser" ? -> all constructors are unit and at most one int and one string, with null constr *) type parser_pieces = { mutable zeroary : (string * string) list ; (* kw string, ml name *) mutable intpar : string list; (* one at most, mlname *) mutable stringpar : string list (* idem *) } type mini_parser = NoParser | ParserPieces of parser_pieces let can_generate_parser constructors = let pp = {zeroary = []; intpar = []; stringpar = []} in if List.for_all constructors ~f: begin fun c -> let vname = if !Flags.camltk then c.ml_name else c.var_name in match c.template with ListArg [StringArg s] -> pp.zeroary <- (s, vname) :: pp.zeroary; true | ListArg [TypeArg(_, Int)] | ListArg[TypeArg(_, Float)] -> if pp.intpar <> [] then false else (pp.intpar <- [vname]; true) | ListArg [TypeArg(_, String)] -> if pp.stringpar <> [] then false else (pp.stringpar <- [vname]; true) | _ -> false end then ParserPieces pp else NoParser (* We can generate parsers only for simple types *) (* we should avoid multiple walks *) let labltk_write_TKtoCAML ~w name ~def:typdef = if typdef.parser_arity = MultipleToken then prerr_string ("You must write cTKtoCAML" ^ name ^ " : string list ->" ^ name ^ " * string list\n") else let write ~consts ~name = match can_generate_parser consts with NoParser -> prerr_string ("You must write cTKtoCAML" ^ name ^ " : string ->" ^ name ^ "\n") | ParserPieces pp -> w ("let cTKtoCAML" ^ name ^ " n =\n"); (* First check integer *) if pp.intpar <> [] then begin w (" try `" ^ List.hd pp.intpar ^ " (int_of_string n)\n"); w (" with _ ->\n") end; w (" match n with\n"); List.iter pp.zeroary ~f: begin fun (tk, ml) -> w " | \""; w tk; w "\" -> `"; w ml; w "\n" end; let final = if pp.stringpar <> [] then "n -> `" ^ List.hd pp.stringpar ^ " n" else "s -> Pervasives.raise (Invalid_argument (\"cTKtoCAML" ^ name ^ ": \" ^ s))" in w " | "; w final; w "\n\n" in begin write ~name ~consts:typdef.constructors; List.iter typdef.subtypes ~f: begin fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts end end let camltk_write_TKtoCAML ~w name ~def:typdef = if typdef.parser_arity = MultipleToken then prerr_string ("You must write cTKtoCAML" ^ name ^ " : string list ->" ^ name ^ " * string list\n") else let write ~consts ~name = match can_generate_parser consts with NoParser -> prerr_string ("You must write cTKtoCAML" ^ name ^ " : string ->" ^ name ^ "\n") | ParserPieces pp -> w ("let cTKtoCAML" ^ name ^ " n =\n"); (* First check integer *) if pp.intpar <> [] then begin w (" try " ^ List.hd pp.intpar ^ " (int_of_string n)\n"); w (" with _ ->\n") end; w (" match n with\n"); List.iter pp.zeroary ~f: begin fun (tk, ml) -> w " | \""; w tk; w "\" -> "; w ml; w "\n" end; let final = if pp.stringpar <> [] then "n -> " ^ List.hd pp.stringpar ^ " n" else "s -> Pervasives.raise (Invalid_argument (\"cTKtoCAML" ^ name ^ ": \" ^ s))" in w " | "; w final; w "\n\n" in begin write ~name ~consts:typdef.constructors; List.iter typdef.subtypes ~f: begin fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts end end let write_TKtoCAML ~w name ~def:typdef = (if !Flags.camltk then camltk_write_TKtoCAML else labltk_write_TKtoCAML) ~w name ~def: typdef (******************************) (* Converters *) (******************************) (* Produce an in-lined converter OCaml -> Tk for simple types *) (* the converter is a function of type: -> string *) let rec converterCAMLtoTK ~context_widget argname ty = match ty with Int -> "TkToken (string_of_int " ^ argname ^ ")" | Float -> "TkToken (Printf.sprintf \"%g\" " ^ argname ^ ")" | Bool -> "if " ^ argname ^ " then TkToken \"1\" else TkToken \"0\"" | Char -> "TkToken (Char.escaped " ^ argname ^ ")" | String -> "TkToken " ^ argname | As (ty, _) -> converterCAMLtoTK ~context_widget argname ty | UserDefined s -> let name = "cCAMLtoTK" ^ s ^ " " in let args = argname in let args = if !Flags.camltk then begin if is_subtyped s then (* unconstraint subtype *) s ^ "_any_table " ^ args else args end else args in let args = if requires_widget_context s then context_widget ^ " " ^ args else args in name ^ args | Subtype ("widget", s') -> if !Flags.camltk then let name = "cCAMLtoTKwidget " in let args = "widget_"^s'^"_table "^argname in let args = if requires_widget_context "widget" then context_widget^" "^args else args in name^args else begin let name = "cCAMLtoTKwidget " in let args = "(" ^ argname ^ " : " ^ s' ^ " widget)" in name ^ args end | Subtype (s, s') -> let name = if !Flags.camltk then "cCAMLtoTK" ^ s ^ " " else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " " in let args = if !Flags.camltk then begin s^"_"^s'^"_table "^argname end else begin if safetype then "(" ^ argname ^ " : [< " ^ s' ^ "_" ^ s ^ "])" else argname end in let args = if requires_widget_context s then context_widget ^ " " ^ args else args in name ^ args | Product tyl -> let vars = varnames ~prefix:"z" (List.length tyl) in String.concat ~sep:" " ("let" :: String.concat ~sep:"," vars :: "=" :: argname :: "in TkTokenList [" :: String.concat ~sep:"; " (List.map2 vars tyl ~f:(converterCAMLtoTK ~context_widget)) :: ["]"]) | List ty -> (* Just added for Imagephoto.put *) String.concat ~sep:" " [(if !Flags.camltk then "TkQuote (TkTokenList (List.map (fun y -> " else "TkQuote (TkTokenList (List.map ~f:(fun y -> "); converterCAMLtoTK ~context_widget "y" ty; ")"; argname; "))"] | Function _ -> fatal_error "unexpected function type in converterCAMLtoTK" | Unit -> fatal_error "unexpected unit type in converterCAMLtoTK" | Record _ -> fatal_error "unexpected product type in converterCAMLtoTK" (* * Produce a list of arguments from a template * The idea here is to avoid allocation as much as possible * *) let code_of_template ~context_widget ?func:(funtemplate=false) template = let catch_opts = ref ("", "") in (* class name and first option *) let variables = ref [] in let variables2 = ref [] in let varcnter = ref 0 in let optionvar = ref None in let newvar1 l = match !optionvar with Some v -> optionvar := None; v | None -> incr varcnter; let v = "v" ^ (string_of_int !varcnter) in variables := (l, v) :: !variables; v in let newvar2 l = match !optionvar with Some v -> optionvar := None; v | None -> incr varcnter; let v = "v" ^ (string_of_int !varcnter) in variables2 := (l, v) :: !variables2; v in let newvar = ref newvar1 in let rec coderec = function StringArg s -> "TkToken \"" ^ s ^ "\"" | TypeArg (_, List (Subtype (sup, sub))) when not !Flags.camltk -> begin try let typdef = Hashtbl.find types_table sup in let classdef = List.assoc sub typdef.subtypes in let lbl = gettklabel (List.hd classdef) in catch_opts := (sub ^ "_" ^ sup, lbl); newvar := newvar2; "TkTokenList opts" with Not_found -> raise (Failure (Printf.sprintf "type %s(%s) not found" sup sub)); end | TypeArg (l, List ty) -> (if !Flags.camltk then "TkTokenList (List.map (function x -> " else "TkTokenList (List.map ~f:(function x -> ") ^ converterCAMLtoTK ~context_widget "x" ty ^ ") " ^ !newvar l ^ ")" | TypeArg (l, Function tyarg) -> "let id = register_callback " ^ context_widget ^ " ~callback: " ^ wrapper_code ~name:(!newvar l) tyarg ^ " in TkToken (\"camlcb \" ^ id)" | TypeArg (l, ty) -> converterCAMLtoTK ~context_widget (!newvar l) ty | ListArg l -> "TkQuote (TkTokenList [" ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "])" | OptionalArgs (l, tl, d) -> let nv = !newvar ("?" ^ l) in optionvar := Some nv; (* Store *) let argstr = String.concat ~sep:"; " (List.map ~f:coderec tl) in let defstr = String.concat ~sep:"; " (List.map ~f:coderec d) in "TkTokenList (match " ^ nv ^ " with\n" ^ " | Some " ^ nv ^ " -> [" ^ argstr ^ "]\n" ^ " | None -> [" ^ defstr ^ "])" in let code = if funtemplate then match template with ListArg l -> "[|" ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "|]" | _ -> "[|" ^ coderec template ^ "|]" else match template with ListArg [x] -> coderec x | ListArg l -> "TkTokenList [" ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "]" | _ -> coderec template in code, List.rev !variables, List.rev !variables2, !catch_opts (* * Converters for user defined types *) (* For each case of a concrete type *) let labltk_write_clause ~w ~context_widget comp = let warrow () = w " -> " in w "`"; w comp.var_name; let code, variables, variables2, (co, _) = code_of_template ~context_widget comp.template in (* no subtype I think ... *) if co <> "" then raise (Failure "write_clause subtype ?"); begin match variables with | [] -> warrow() | [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow() | l -> w " ( "; w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l)); w ")"; warrow() end; w code let camltk_write_clause ~w ~context_widget ~subtype comp = let warrow () = w " -> "; if subtype then w ("chk_sub \""^comp.ml_name^"\" table C" ^ comp.ml_name ^ "; ") in w comp.ml_name; (* we use ml_name, not var_name, specialized for labltk *) let code, variables, variables2, (co, _) = code_of_template ~context_widget comp.template in (* no subtype I think ... *) if co <> "" then raise (Failure "write_clause subtype ?"); begin match variables with | [] -> warrow() | [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow() | l -> w " ( "; w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l)); w ")"; warrow() end; w code let write_clause ~w ~context_widget ~subtype comp = if !Flags.camltk then camltk_write_clause ~w ~context_widget ~subtype comp else labltk_write_clause ~w ~context_widget comp (* The full converter *) let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name = let write_one name constrs = let subtype = typdef.subtypes <> [] in w ("let cCAMLtoTK" ^ name); let context_widget = if typdef.requires_widget_context then begin w " w"; "w" end else "dummy" in if !Flags.camltk && subtype then w " table"; if st then begin w " : "; if typdef.variant then w ("[< " ^ name ^ "]") else w name; w " -> tkArgs " end; w (" = function"); List.iter constrs ~f:(fun c -> w "\n | "; write_clause ~w ~context_widget ~subtype c); w "\n\n\n" in let constrs = typdef.constructors in if !Flags.camltk then write_one name constrs else begin (* Only needed if no subtypes, otherwise use optionals *) if typdef.subtypes == [] then write_one name constrs else List.iter constrs ~f: begin fun fc -> let code, vars, _, (co, _) = code_of_template ~context_widget:"dummy" fc.template in if co <> "" then fatal_error "optionals in optionals"; let vars = List.map ~f:snd vars in w "let ccCAMLtoTK"; w name; w "_"; w (small fc.ml_name); w " ("; w (String.concat ~sep:", " vars); w ") =\n "; w code; w "\n\n" end end (* Tcl does not really return "lists". It returns sp separated tokens *) let rec write_result_parsing ~w = function List String -> w "(splitlist res)" | List ty -> if !Flags.camltk then w (" List.map " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) else w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) | Product tyl -> raise (Failure "Product -> record was done. ???") | Record tyl -> (* of course all the labels are "" *) let rnames = varnames ~prefix:"r" (List.length tyl) in w " let l = splitlist res in"; w ("\n if List.length l <> " ^ string_of_int (List.length tyl)); w ("\n then Pervasives.raise (TkError (\"unexpected result: \" ^ res))"); w ("\n else "); List.iter2 rnames tyl ~f: begin fun r (l, ty) -> if l <> "" then raise (Failure "lables in return type!!!"); w (" let " ^ r ^ ", l = "); begin match type_parser_arity ty with OneToken -> w (converterTKtoCAML ~arg:"(List.hd l)" ty); w (", List.tl l") | MultipleToken -> w (converterTKtoCAML ~arg:"l" ty) end; w (" in\n") end; w (String.concat ~sep:", " rnames) | String -> w (converterTKtoCAML ~arg:"res" String) | As (ty, _) -> write_result_parsing ~w ty | ty -> match type_parser_arity ty with OneToken -> w (converterTKtoCAML ~arg:"res" ty) | MultipleToken -> w (converterTKtoCAML ~arg:"(splitlist res)" ty) let labltk_write_function ~w def = w ("let " ^ def.ml_name); (* a bit approximative *) let context_widget = match def.template with ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1" | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1" | _ -> "dummy" in let code, variables, variables2, (co, lbl) = code_of_template ~func:true ~context_widget def.template in (* Arguments *) let uv, lv, ov = let rec replace_args ~u ~l ~o = function [] -> u, l, o | ("", x) :: ls -> replace_args ~u:(x :: u) ~l ~o ls | (p, _ as x) :: ls when p.[0] = '?' -> replace_args ~u ~l ~o:(x :: o) ls | x :: ls -> replace_args ~u ~l:(x :: l) ~o ls in replace_args ~u:[] ~l:[] ~o:[] (List.rev (variables @ variables2)) in let has_opts = (ov <> [] || co <> "") in if not has_opts then List.iter uv ~f:(fun x -> w " "; w x); List.iter (lv@ov) ~f:(fun (l, v) -> w " "; w (labelstring l); w v); if co <> "" then begin if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta"); w " =\n"; w (co ^ "_optionals"); if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta"); w " (fun opts"; if uv = [] then w " ()" else if has_opts then List.iter uv ~f:(fun x -> w " "; w x); w " ->\n" end else begin if (ov <> [] || lv = []) && uv = [] then w " ()" else if has_opts then List.iter uv ~f:(fun x -> w " "; w x); w " =\n" end; begin match def.result with | Unit | As (Unit, _) -> w "tkCommand "; w code | ty -> w "let res = tkEval "; w code ; w " in \n"; write_result_parsing ~w ty end; if co <> "" then w ")"; w "\n\n" let camltk_write_function ~w def = w ("let " ^ def.ml_name); (* a bit approximative *) let context_widget = match def.template with ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1" | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1" | _ -> "dummy" in let code, variables, variables2, (co, lbl) = code_of_template ~func:true ~context_widget def.template in (* Arguments *) let uv, ov = let rec replace_args ~u ~o = function [] -> u, o | ("", x) :: ls -> replace_args ~u:(x :: u) ~o ls | (p, _ as x) :: ls when p.[0] = '?' -> replace_args ~u ~o:(x :: o) ls | (_,x) :: ls -> replace_args ~u:(x::u) ~o ls in replace_args ~u:[] ~o:[] (List.rev (variables @ variables2)) in let has_opts = ov <> [] (* (ov <> [] || co <> "") *) in if not has_opts then List.iter uv ~f:(fun x -> w " "; w x); List.iter ov ~f:(fun (l, v) -> w " "; w (labelstring l); w v); begin if uv = [] then w " ()" else if has_opts then List.iter uv ~f:(fun x -> w " "; w x); w " =\n" end; begin match def.result with | Unit | As (Unit, _) -> w "tkCommand "; w code | ty -> w "let res = tkEval "; w code ; w " in \n"; write_result_parsing ~w ty end; w "\n\n" (* w ("let " ^ def.ml_name); (* a bit approximative *) let context_widget = match def.template with ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1" | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1" | _ -> "dummy" in let code, variables, variables2, (co, lbl) = code_of_template ~func:true ~context_widget def.template in let variables = variables @ variables2 in (* Arguments *) begin match variables with [] -> w " () =\n" | l -> let has_normal_argument = ref false in List.iter (fun (l,x) -> w " "; if l <> "" then if l.[0] = '?' then w (l ^ ":") else has_normal_argument := true else has_normal_argument := true; w x) l; if not !has_normal_argument then w " ()"; w " =\n" end; begin match def.result with | Unit | As (Unit, _) -> w "tkCommand "; w code | ty -> w "let res = tkEval "; w code ; w " in \n"; write_result_parsing ~w ty end; w "\n\n" *) let write_function ~w def = if !Flags.camltk then camltk_write_function ~w def else labltk_write_function ~w def ;; let labltk_write_create ~w clas = w ("let create ?name =\n"); w (" " ^ clas ^ "_options_optionals (fun opts parent ->\n"); w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n"); w " tkCommand [|"; w ("TkToken \"" ^ clas ^ "\";\n"); w (" TkToken (Widget.name w);\n"); w (" TkTokenList opts |];\n"); w (" w)\n\n\n") let camltk_write_create ~w clas = w ("let create ?name parent options =\n"); w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n"); w " tkCommand [|"; w ("TkToken \"" ^ clas ^ "\";\n"); w (" TkToken (Widget.name w);\n"); w (" TkTokenList (List.map (function x -> "^ converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n"); w (" |];\n"); w (" w\n\n") let camltk_write_named_create ~w clas = w ("let create_named parent name options =\n"); w (" let w = new_atom \"" ^ clas ^ "\" ~parent ~name in\n"); w " tkCommand [|"; w ("TkToken \"" ^ clas ^ "\";\n"); w (" TkToken (Widget.name w);\n"); w (" TkTokenList (List.map (function x -> "^ converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n"); w (" |];\n"); w (" w\n\n") (* Search Path. *) let search_path = ref ["."] (* taken from utils/misc.ml *) let find_in_path path name = if not (Filename.is_implicit name) then if Sys.file_exists name then name else raise Not_found else begin let rec try_dir = function [] -> raise Not_found | dir :: rem -> let fullname = Filename.concat dir name in if Sys.file_exists fullname then fullname else try_dir rem in try_dir path end (* builtin-code: the file (without suffix) is in .template... *) (* not efficient, but hell *) let write_external ~w def = match def.template with | StringArg fname -> begin try let realname = find_in_path !search_path (fname ^ ".ml") in let ic = open_in_bin realname in try let code_list = Ppparse.parse_channel ic in close_in ic; List.iter (Ppexec.exec (fun _ -> ()) w) (if !Flags.camltk then Code.Define "CAMLTK" :: code_list else code_list ); with | Ppparse.Error s -> close_in ic; raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) with | Not_found -> raise (Compiler_Error ("can't find external file: " ^ fname)) end | _ -> raise (Compiler_Error "invalid external definition") let write_catch_optionals ~w clas ~def:typdef = if typdef.subtypes = [] then () else List.iter typdef.subtypes ~f: begin fun (subclass, classdefs) -> w ("let " ^ subclass ^ "_" ^ clas ^ "_optionals f = fun\n"); let tklabels = List.map ~f:gettklabel classdefs in let l = List.map classdefs ~f: begin fun fc -> (* let code, vars, _, (co, _) = code_of_template ~context_widget:"dummy" fc.template in if co <> "" then fatal_error "optionals in optionals"; *) let p = gettklabel fc in (if count ~item:p tklabels > 1 then small fc.var_name else p), small fc.ml_name end in let p = List.map l ~f:(fun (si, _) -> " ?" ^ si) in let v = List.map l ~f: begin fun (si, s) -> "(maycons ccCAMLtoTK" ^ clas ^ "_" ^ s ^ " " ^ si end in w (String.concat ~sep:"\n" p); w " ->\n"; w " f "; w (String.concat ~sep:"\n " v); w "\n []"; w (String.make (List.length v) ')'); w "\n\n" end mingw-ocaml/ocaml/otherlibs/labltk/compiler/code.mli0000644000175000017500000000233412124403241022153 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) type code = | Line of string | Ifdef of bool * string * code list * code list option | Define of string | Undef of string ;; mingw-ocaml/ocaml/otherlibs/labltk/compiler/maincompile.ml0000644000175000017500000003375212124403241023375 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) open StdLabels open Support open Tables open Printer open Compile open Intf let flag_verbose = ref false let verbose_string s = if !flag_verbose then prerr_string s let verbose_endline s = if !flag_verbose then prerr_endline s let input_name = ref "Widgets.src" let output_dir = ref "" let destfile f = Filename.concat !output_dir f let usage () = prerr_string "Usage: tkcompiler input.src\n"; flush stderr; exit 1 let prerr_error_header () = prerr_string "File \""; prerr_string !input_name; prerr_string "\", line "; prerr_string (string_of_int !Lexer.current_line); prerr_string ": " (* parse Widget.src config file *) let parse_file filename = let ic = open_in_bin filename in let lexbuf = try let code_list = Ppparse.parse_channel ic in close_in ic; let buf = Buffer.create 50000 in List.iter (Ppexec.exec (fun l -> Buffer.add_string buf (Printf.sprintf "##line %d\n" l)) (Buffer.add_string buf)) (if !Flags.camltk then Code.Define "CAMLTK" :: code_list else code_list); Lexing.from_string (Buffer.contents buf) with | Ppparse.Error s -> close_in ic; raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) in try while true do Parser.entry Lexer.main lexbuf done with | Parsing.Parse_error -> prerr_error_header(); prerr_string "Syntax error \n"; exit 1 | Lexer.Lexical_error s -> prerr_error_header(); prerr_string "Lexical error ("; prerr_string s; prerr_string ")\n"; exit 1 | Duplicate_Definition (s,s') -> prerr_error_header(); prerr_string s; prerr_string " "; prerr_string s'; prerr_string " is defined twice.\n"; exit 1 | Compiler_Error s -> prerr_error_header(); prerr_string "Internal error: "; prerr_string s; prerr_string "\n"; prerr_string "Please report bug\n"; exit 1 | End_of_file -> () (* The hack to provoke the production of cCAMLtoTKoptions_constrs *) (* Auxiliary function: the list of all the elements associated to keys in an hash table. *) let elements t = let elems = ref [] in Hashtbl.iter (fun _ d -> elems := d :: !elems) t; !elems;; (* Verifies that duplicated clauses are semantically equivalent and returns a unique set of clauses. *) let uniq_clauses = function | [] -> [] | l -> let check_constr constr1 constr2 = if constr1.template <> constr2.template then begin let code1, vars11, vars12, opts1 = code_of_template ~context_widget:"dummy" constr1.template in let code2, vars12, vars22, opts2 = code_of_template ~context_widget:"dummy" constr2.template in let err = Printf.sprintf "uncompatible redondant clauses for variant %s:\n %s\n and\n %s" constr1.var_name code1 code2 in Format.print_newline(); print_fullcomponent constr1; Format.print_newline(); print_fullcomponent constr2; Format.print_newline(); prerr_endline err; fatal_error err end in let t = Hashtbl.create 11 in List.iter l ~f:(fun constr -> let c = constr.var_name in if Hashtbl.mem t c then (check_constr constr (Hashtbl.find t c)) else Hashtbl.add t c constr); elements t;; let option_hack oc = if Hashtbl.mem types_table "options" then let typdef = Hashtbl.find types_table "options" in let hack = { parser_arity = OneToken; constructors = begin let constrs = List.map typdef.constructors ~f: begin fun c -> { component = Constructor; ml_name = (if !Flags.camltk then "C" ^ c.ml_name else c.ml_name); var_name = c.var_name; (* as variants *) template = begin match c.template with ListArg (x :: _) -> x | _ -> fatal_error "bogus hack" end; result = UserDefined "options_constrs"; safe = true } end in if !Flags.camltk then constrs else uniq_clauses constrs (* JPF ?? *) end; subtypes = []; requires_widget_context = false; variant = false } in write_CAMLtoTK ~w:(output_string oc) ~def:hack ~safetype:false "options_constrs" let realname name = (* module name fix for camltk *) if !Flags.camltk then "c" ^ String.capitalize name else name ;; (* analize the parsed Widget.src and output source files *) let compile () = verbose_endline "Creating _tkgen.ml ..."; let oc = open_out_bin (destfile "_tkgen.ml") in let oc' = open_out_bin (destfile "_tkigen.ml") in let oc'' = open_out_bin (destfile "_tkfgen.ml") in let sorted_types = Tsort.sort types_order in verbose_endline " writing types ..."; List.iter sorted_types ~f: begin fun typname -> verbose_string (" " ^ typname ^ " "); try let typdef = Hashtbl.find types_table typname in verbose_string "type "; write_type ~intf:(output_string oc) ~impl:(output_string oc') typname ~def:typdef; verbose_string "C2T "; write_CAMLtoTK ~w:(output_string oc') typname ~def:typdef; verbose_string "T2C "; if List.mem typname !types_returned then write_TKtoCAML ~w:(output_string oc') typname ~def:typdef; verbose_string "CO "; if not !Flags.camltk then (* only for LablTk *) write_catch_optionals ~w:(output_string oc') typname ~def:typdef; verbose_endline "." with Not_found -> if not (List.mem_assoc typname !types_external) then begin verbose_string "Type "; verbose_string typname; verbose_string " is undeclared external or undefined\n" end else verbose_endline "." end; verbose_endline " option hacking ..."; option_hack oc'; verbose_endline " writing functions ..."; List.iter ~f:(write_function ~w:(output_string oc'')) !function_table; close_out oc; close_out oc'; close_out oc''; (* Write the interface for public functions *) (* this interface is used only for documentation *) verbose_endline "Creating _tkgen.mli ..."; let oc = open_out_bin (destfile "_tkgen.mli") in List.iter (sort_components !function_table) ~f:(write_function_type ~w:(output_string oc)); close_out oc; verbose_endline "Creating other ml, mli ..."; let write_module wname wdef = verbose_endline (" "^wname); let modname = realname wname in let oc = open_out_bin (destfile (modname ^ ".ml")) and oc' = open_out_bin (destfile (modname ^ ".mli")) in Copyright.write ~w:(output_string oc); Copyright.write ~w:(output_string oc'); begin match wdef.module_type with Widget -> output_string oc' ("(* The "^wname^" widget *)\n") | Family -> output_string oc' ("(* The "^wname^" commands *)\n") end; List.iter ~f:(fun s -> output_string oc s; output_string oc' s) begin if !Flags.camltk then [ "open CTk\n"; "open Tkintf\n"; "open Widget\n"; "open Textvariable\n\n" ] else [ "open StdLabels\n"; "open Tk\n"; "open Tkintf\n"; "open Widget\n"; "open Textvariable\n\n" ] end; output_string oc "open Protocol\n"; begin match wdef.module_type with Widget -> if !Flags.camltk then begin camltk_write_create ~w:(output_string oc) wname; camltk_write_named_create ~w:(output_string oc) wname; camltk_write_create_p ~w:(output_string oc') wname; camltk_write_named_create_p ~w:(output_string oc') wname; end else begin labltk_write_create ~w:(output_string oc) wname; labltk_write_create_p ~w:(output_string oc') wname end | Family -> () end; List.iter ~f:(write_function ~w:(output_string oc)) (sort_components wdef.commands); List.iter ~f:(write_function_type ~w:(output_string oc')) (sort_components wdef.commands); List.iter ~f:(write_external ~w:(output_string oc)) (sort_components wdef.externals); List.iter ~f:(write_external_type ~w:(output_string oc')) (sort_components wdef.externals); close_out oc; close_out oc' in Hashtbl.iter write_module module_table; (* wrapper code camltk.ml and labltk.ml *) if !Flags.camltk then begin let oc = open_out_bin (destfile "camltk.ml") in Copyright.write ~w:(output_string oc); output_string oc "(** This module Camltk provides the module name spaces of the CamlTk API.\n\ \n\ The users of the CamlTk API should open this module first to access\n\ the types, functions and modules of the CamlTk API easier.\n\ For the documentation of each sub modules such as [Button] and [Toplevel],\n\ refer to its defintion file, [cButton.mli], [cToplevel.mli], etc.\n\ *)\n\ \n\ "; output_string oc "include CTk\n"; output_string oc "module Tk = CTk\n"; Hashtbl.iter (fun name _ -> let cname = realname name in output_string oc (Printf.sprintf "module %s = %s;;\n" (String.capitalize name) (String.capitalize cname))) module_table; close_out oc end else begin let oc = open_out_bin (destfile "labltk.ml") in Copyright.write ~w:(output_string oc); output_string oc "(** This module Labltk provides the module name spaces of the LablTk API,\n\ useful to call LablTk functions inside CamlTk programs. 100% LablTk users\n\ do not need to use this. *)\n\ \n\ "; output_string oc "module Widget = Widget;;\n\ module Protocol = Protocol;;\n\ module Textvariable = Textvariable;;\n\ module Fileevent = Fileevent;;\n\ module Timer = Timer;;\n\ "; Hashtbl.iter (fun name _ -> let cname = realname name in output_string oc (Printf.sprintf "module %s = %s;;\n" (String.capitalize name) (String.capitalize cname))) module_table; (* widget typer *) output_string oc "\n(** Widget typers *)\n\nopen Widget\n\n"; Hashtbl.iter (fun name def -> match def.module_type with | Widget -> output_string oc (Printf.sprintf "let %s (w : any widget) =\n" name); output_string oc (Printf.sprintf " Rawwidget.check_class w widget_%s_table;\n" name); output_string oc (Printf.sprintf " (Obj.magic w : %s widget);;\n\n" name); | _ -> () ) module_table; close_out oc end; (* write the module list for the Makefile *) (* and hack to death until it works *) let oc = open_out_bin (destfile "modules") in if !Flags.camltk then output_string oc "CWIDGETOBJS=" else output_string oc "WIDGETOBJS="; Hashtbl.iter (fun name _ -> let name = realname name in output_string oc name; output_string oc ".cmo ") module_table; output_string oc "\n"; Hashtbl.iter (fun name _ -> let name = realname name in output_string oc name; output_string oc ".ml ") module_table; output_string oc ": _tkgen.ml\n\n"; Hashtbl.iter (fun name _ -> let name = realname name in output_string oc name; output_string oc ".cmo : "; output_string oc name; output_string oc ".ml\n"; output_string oc name; output_string oc ".cmi : "; output_string oc name; output_string oc ".mli\n") module_table; (* for camltk.ml wrapper *) if !Flags.camltk then begin output_string oc "camltk.cmo : cTk.cmo "; Hashtbl.iter (fun name _ -> let name = realname name in output_string oc name; output_string oc ".cmo ") module_table; output_string oc "\n" end; close_out oc let main () = Arg.parse [ "-verbose", Arg.Unit (fun () -> flag_verbose := true), "Make output verbose"; "-camltk", Arg.Unit (fun () -> Flags.camltk := true), "Make CamlTk interface"; "-outdir", Arg.String (fun s -> output_dir := s), "output directory"; "-debugpp", Arg.Unit (fun () -> Ppexec.debug := true), "debug preprocessor" ] (fun filename -> input_name := filename) "Usage: tkcompiler " ; if !output_dir = "" then begin prerr_endline "specify -outdir option"; exit 1 end; try verbose_endline "Parsing..."; parse_file !input_name; verbose_endline "Compiling..."; compile (); verbose_endline "Finished"; exit 0 with | Lexer.Lexical_error s -> prerr_string "Invalid lexical character: "; prerr_endline s; exit 1 | Duplicate_Definition (s, s') -> prerr_string s; prerr_string " "; prerr_string s'; prerr_endline " is redefined illegally"; exit 1 | Invalid_implicit_constructor c -> prerr_string "Constructor "; prerr_string c; prerr_endline " is used implicitly before defined"; exit 1 | Tsort.Cyclic -> prerr_endline "Cyclic dependency of types"; exit 1 let () = Printexc.catch main () mingw-ocaml/ocaml/otherlibs/labltk/compiler/lexer.mll0000644000175000017500000001166612124403241022373 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) { open StdLabels open Lexing open Parser open Support exception Lexical_error of string let current_line = ref 1 (* The table of keywords *) let keyword_table = (Hashtbl.create 149 : (string, token) Hashtbl.t) let _ = List.iter ~f:(fun (str,tok) -> Hashtbl.add keyword_table str tok) [ "int", TYINT; "float", TYFLOAT; "bool", TYBOOL; "char", TYCHAR; "string", TYSTRING; "list", LIST; "as", AS; "variant", VARIANT; "widget", WIDGET; "option", OPTION; "type", TYPE; "subtype", SUBTYPE; "function", FUNCTION; "module", MODULE; "external", EXTERNAL; "sequence", SEQUENCE; "unsafe", UNSAFE ] (* To buffer string literals *) let initial_string_buffer = String.create 256 let string_buff = ref initial_string_buffer let string_index = ref 0 let reset_string_buffer () = string_buff := initial_string_buffer; string_index := 0; () let store_string_char c = if !string_index >= String.length (!string_buff) then begin let new_buff = String.create (String.length (!string_buff) * 2) in String.blit ~src:(!string_buff) ~src_pos:0 ~dst:new_buff ~dst_pos:0 ~len:(String.length (!string_buff)); string_buff := new_buff end; String.set (!string_buff) (!string_index) c; incr string_index let get_stored_string () = let s = String.sub (!string_buff) ~pos:0 ~len:(!string_index) in string_buff := initial_string_buffer; s (* To translate escape sequences *) let char_for_backslash = function 'n' -> '\010' | 'r' -> '\013' | 'b' -> '\008' | 't' -> '\009' | c -> c let char_for_decimal_code lexbuf i = Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48)) let saved_string_start = ref 0 } rule main = parse '\010' { incr current_line; main lexbuf } | [' ' '\013' '\009' '\026' '\012'] + { main lexbuf } | ['A'-'Z' 'a'-'z' '\192'-'\214' '\216'-'\246' '\248'-'\255' ] ( '_' ? ['A'-'Z' 'a'-'z' '\192'-'\214' '\216'-'\246' '\248'-'\255' (*'*) '0'-'9' ] ) * { let s = Lexing.lexeme lexbuf in try Hashtbl.find keyword_table s with Not_found -> IDENT s } | "\"" { reset_string_buffer(); (* Start of token is start of string. *) saved_string_start := lexbuf.lex_start_pos; string lexbuf; lexbuf.lex_start_pos <- !saved_string_start; STRING (get_stored_string()) } | "(" { LPAREN } | ")" { RPAREN } | "[" { LBRACKET } | "]" { RBRACKET } | "{" { LBRACE } | "}" { RBRACE } | "," { COMMA } | ";" { SEMICOLON } | ":" {COLON} | "?" {QUESTION} | "/" {SLASH} | "%" { comment lexbuf; main lexbuf } | "##line" { line lexbuf; main lexbuf } | eof { EOF } | _ { raise (Lexical_error("illegal character")) } and string = parse '"' { () } | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] + { string lexbuf } | '\\' ['\\' '"' 'n' 't' 'b' 'r'] { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); string lexbuf } | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_string_char(char_for_decimal_code lexbuf 1); string lexbuf } | eof { raise (Lexical_error("string not terminated")) } | '\010' { incr current_line; store_string_char(Lexing.lexeme_char lexbuf 0); string lexbuf } | _ { store_string_char(Lexing.lexeme_char lexbuf 0); string lexbuf } and comment = parse '\010' { incr current_line } | eof { () } | _ { comment lexbuf } and linenum = parse | ['0'-'9']+ { let next_line = int_of_string (Lexing.lexeme lexbuf) in current_line := next_line - 1 } | _ { raise (Lexical_error("illegal ##line directive: no line number"))} and line = parse | [' ' '\t']* { linenum lexbuf } mingw-ocaml/ocaml/otherlibs/labltk/compiler/intf.ml0000644000175000017500000001532012124403241022027 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) open StdLabels (* Write .mli for widgets *) open Tables open Compile let labltk_write_create_p ~w wname = w "val create :\n ?name:string ->\n"; begin try let option = Hashtbl.find types_table "options" in let classdefs = List.assoc wname option.subtypes in let tklabels = List.map ~f:gettklabel classdefs in let l = List.map classdefs ~f: begin fun fc -> begin let p = gettklabel fc in if count ~item:p tklabels > 1 then small fc.var_name else p end, fc.template end in w (String.concat ~sep:" ->\n" (List.map l ~f: begin fun (s, t) -> " ?" ^ s ^ ":" ^(ppMLtype (match types_of_template t with | [t] -> labeloff t ~at:"write_create_p" | [] -> fatal_error "multiple" | l -> Product (List.map ~f:(labeloff ~at:"write_create_p") l))) end)) with Not_found -> fatal_error "in write_create_p" end; w (" ->\n 'a widget -> " ^ wname ^ " widget\n"); w "(** [create ?name parent options...] creates a new widget with\n"; w " parent [parent] and new patch component [name], if specified. *)\n\n" ;; let camltk_write_create_p ~w wname = w "val create : ?name: string -> widget -> options list -> widget \n"; w "(** [create ?name parent options] creates a new widget with\n"; w " parent [parent] and new patch component [name] if specified.\n"; w " Options are restricted to the widget class subset, and checked\n"; w " dynamically. *)\n\n" ;; let camltk_write_named_create_p ~w wname = w "val create_named : widget -> string -> options list -> widget \n"; w "(** [create_named parent name options] creates a new widget with\n"; w " parent [parent] and new patch component [name].\n"; w " This function is now obsolete and unified with [create]. *)\n\n"; ;; (* Unsafe: write special comment *) let labltk_write_function_type ~w def = if not def.safe then w "(* unsafe *)\n"; w "val "; w def.ml_name; w " : "; let us, ls, os = let tys = types_of_template def.template in let rec replace_args ~u ~l ~o = function [] -> u, l, o | (_, List(Subtype _) as x)::ls -> replace_args ~u ~l ~o:(x::o) ls | ("", _ as x)::ls -> replace_args ~u:(x::u) ~l ~o ls | (p, _ as x)::ls when p.[0] = '?' -> replace_args ~u ~l ~o:(x::o) ls | x::ls -> replace_args ~u ~l:(x::l) ~o ls in replace_args ~u:[] ~l:[] ~o:[] (List.rev tys) in let counter = ref 0 in let params = if os = [] then us @ ls else ls @ os @ us in List.iter params ~f: begin fun (l, t) -> if l <> "" then w (l ^ ":"); w (ppMLtype t ~counter); w " -> " end; if (os <> [] || ls = []) && us = [] then w "unit -> "; w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *) w " \n"; (* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *) if def.safe then w "\n" else w "\n(* /unsafe *)\n" let camltk_write_function_type ~w def = if not def.safe then w "(* unsafe *)\n"; w "val "; w def.ml_name; w " : "; let us, os = let tys = types_of_template def.template in let rec replace_args ~u ~o = function [] -> u, o | ("", _ as x)::ls -> replace_args ~u:(x::u) ~o ls | (p, _ as x)::ls when p.[0] = '?' -> replace_args ~u ~o:(x::o) ls | x::ls -> replace_args ~u:(x::u) ~o ls in replace_args ~u:[] ~o:[] (List.rev tys) in let counter = ref 0 in let params = if os = [] then us else os @ us in List.iter params ~f: begin fun (l, t) -> if l <> "" then if l.[0] = '?' then w (l ^ ":"); w (ppMLtype t ~counter); w " -> " end; if us = [] then w "unit -> "; w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *) w " \n"; (* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *) if def.safe then w "\n" else w "\n(* /unsafe *)\n" (* if not def.safe then w "(* unsafe *)\n"; w "val "; w def.ml_name; w " : "; let tys = types_of_template def.template in let counter = ref 0 in let have_normal_arg = ref false in List.iter tys ~f: begin fun (l, t) -> if l <> "" then if l.[0] = '?' then w (l^":") else begin have_normal_arg := true; w (" (* " ^ l ^ ":*)") end else have_normal_arg := true; w (ppMLtype t ~counter); w " -> " end; if not !have_normal_arg then w "unit -> "; w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *) w " \n"; if def.safe then w "\n" else w "\n(* /unsafe *)\n" *) let write_function_type ~w def = if !Flags.camltk then camltk_write_function_type ~w def else labltk_write_function_type ~w def let write_external_type ~w def = match def.template with | StringArg fname -> begin try let realname = find_in_path !search_path (fname ^ ".mli") in let ic = open_in_bin realname in try let code_list = Ppparse.parse_channel ic in close_in ic; if not def.safe then w "(* unsafe *)\n"; List.iter (Ppexec.exec (fun _ -> ()) w) (if !Flags.camltk then Code.Define "CAMLTK" :: code_list else code_list ); if def.safe then w "\n\n" else w "\n(* /unsafe *)\n\n" with | Ppparse.Error s -> close_in ic; raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) with | Not_found -> raise (Compiler_Error ("can't find external file: " ^ fname)) end | _ -> raise (Compiler_Error "invalid external definition") mingw-ocaml/ocaml/otherlibs/labltk/compiler/pp.ml0000644000175000017500000000242212124403241021505 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) let _ = try let code_list = Ppparse.parse_channel stdin in List.iter (Ppexec.exec (fun _ -> ()) print_string) code_list with | Ppparse.Error s -> prerr_endline s; exit 2 ;; mingw-ocaml/ocaml/otherlibs/labltk/compiler/ppparse.ml0000644000175000017500000000326612124403241022547 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) exception Error of string let parse_channel ic = let lexbuf = Lexing.from_channel ic in try Ppyac.code_list Pplex.token lexbuf with | Pplex.Error s -> let loc_start = Lexing.lexeme_start lexbuf and loc_end = Lexing.lexeme_end lexbuf in raise (Error (Printf.sprintf "parse error at char %d, %d: %s" loc_start loc_end s)) | Parsing.Parse_error -> let loc_start = Lexing.lexeme_start lexbuf and loc_end = Lexing.lexeme_end lexbuf in raise (Error (Printf.sprintf "parse error at char %d, %d" loc_start loc_end)) ;; mingw-ocaml/ocaml/otherlibs/labltk/compiler/tsort.ml0000644000175000017500000000552212124403241022245 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) open StdLabels (* Topological Sort.list *) (* d'apres More Programming Pearls *) (* node * pred count * successors *) type 'a entry = {node : 'a; mutable pred_count : int; mutable successors : 'a entry list } type 'a porder = 'a entry list ref exception Cyclic let find_entry order node = let rec search_entry = function [] -> raise Not_found | x::l -> if x.node = node then x else search_entry l in try search_entry !order with Not_found -> let entry = {node = node; pred_count = 0; successors = []} in order := entry::!order; entry let create () = ref [] (* Inverted args because Sort.list builds list in reverse order *) let add_relation order (succ,pred) = let pred_entry = find_entry order pred and succ_entry = find_entry order succ in succ_entry.pred_count <- succ_entry.pred_count + 1; pred_entry.successors <- succ_entry::pred_entry.successors (* Just add it *) let add_element order e = ignore (find_entry order e) let sort order = let q = Queue.create () and result = ref [] in List.iter !order ~f:(function {pred_count = n} as node -> if n = 0 then Queue.add node q); begin try while true do let t = Queue.take q in result := t.node :: !result; List.iter t.successors ~f: begin fun s -> let n = s.pred_count - 1 in s.pred_count <- n; if n = 0 then Queue.add s q end done with Queue.Empty -> List.iter !order ~f:(fun node -> if node.pred_count <> 0 then raise Cyclic) end; !result mingw-ocaml/ocaml/otherlibs/labltk/compiler/parser.mly0000644000175000017500000001632012124403241022555 0ustar tootstoots/***********************************************************************/ /* */ /* MLTk, Tcl/Tk interface of OCaml */ /* */ /* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file ../../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ %{ open Tables %} /* Tokens */ %token IDENT %token STRING %token EOF %token LPAREN /* "(" */ %token RPAREN /* ")" */ %token COMMA /* "," */ %token SEMICOLON /* ";" */ %token COLON /* ":" */ %token QUESTION /* "?" */ %token LBRACKET /* "[" */ %token RBRACKET /* "]" */ %token LBRACE /* "{" */ %token RBRACE /* "}" */ %token SLASH /* "/" */ %token TYINT /* "int" */ %token TYFLOAT /* "float" */ %token TYBOOL /* "bool" */ %token TYCHAR /* "char" */ %token TYSTRING /* "string" */ %token LIST /* "list" */ %token AS /* "as" */ %token VARIANT /* "variant" */ %token WIDGET /* "widget" */ %token OPTION /* "option" */ %token TYPE /* "type" */ %token SEQUENCE /* "sequence" */ %token SUBTYPE /* "subtype" */ %token FUNCTION /* "function" */ %token MODULE /* "module" */ %token EXTERNAL /* "external" */ %token UNSAFE /* "unsafe" */ /* Entry points */ %start entry %type entry %% TypeName: IDENT { String.uncapitalize $1 } | WIDGET { "widget" } ; /* Atomic types */ Type0 : TYINT { Int } | TYFLOAT { Float } | TYBOOL { Bool } | TYCHAR { Char } | TYSTRING { String } | TypeName { UserDefined $1 } ; /* Camltk/Labltk types */ Type0_5: | Type0 SLASH Type0 { if !Flags.camltk then $1 else $3 } | Type0 { $1 } ; /* with subtypes */ Type1 : Type0_5 { $1 } | TypeName LPAREN IDENT RPAREN { Subtype ($1, $3) } | WIDGET LPAREN IDENT RPAREN { Subtype ("widget", $3) } | OPTION LPAREN IDENT RPAREN { Subtype ("options", $3) } | Type1 AS STRING { As ($1, $3) } | LBRACE Type_list RBRACE { Product $2 } ; /* with list constructors */ Type2 : Type1 { $1 } | Type2 LIST { List $1 } ; Labeled_type2 : Type2 { "", $1 } | IDENT COLON Type2 { $1, $3 } ; /* products */ Type_list : Type2 COMMA Type_list { $1 :: $3 } | Type2 { [$1] } ; /* records */ Type_record : Labeled_type2 COMMA Type_record { $1 :: $3 } | Labeled_type2 { [$1] } ; /* callback arguments or function results*/ FType : LPAREN RPAREN { Unit } | LPAREN Type2 RPAREN { $2 } | LPAREN Type_record RPAREN { Record $2 } ; Type : Type2 { $1 } | FUNCTION FType { Function $2 } ; SimpleArg: STRING {StringArg $1} | Type {TypeArg ("", $1) } ; Arg: STRING {StringArg $1} | Type {TypeArg ("", $1) } | IDENT COLON Type {TypeArg ($1, $3)} | QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET DefaultList {OptionalArgs ( $2, $5, $7 )} | QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET DefaultList {OptionalArgs ( "widget", $5, $7 )} | QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET {OptionalArgs ( $2, $5, [] )} | QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET {OptionalArgs ( "widget", $5, [] )} | WIDGET COLON Type {TypeArg ("widget", $3)} | Template { $1 } ; SimpleArgList: SimpleArg SEMICOLON SimpleArgList { $1 :: $3} | SimpleArg { [$1] } ; ArgList: Arg SEMICOLON ArgList { $1 :: $3} | Arg { [$1] } ; /* DefaultList Only one TypeArg in ArgList and it must be unlabeled */ DefaultList : LBRACKET LBRACE ArgList RBRACE RBRACKET {$3} /* Template */ Template : LBRACKET ArgList RBRACKET { ListArg $2 } ; /* Constructors for type declarations */ Constructor : IDENT Template {{ component = Constructor; ml_name = $1; var_name = getvarname $1 $2; template = $2; result = Unit; safe = true }} | IDENT LPAREN IDENT RPAREN Template {{ component = Constructor; ml_name = $1; var_name = $3; template = $5; result = Unit; safe = true }} ; AbbrevConstructor : Constructor { Full $1 } | IDENT { Abbrev $1 } ; Constructors : Constructor Constructors { $1 :: $2 } | Constructor { [$1] } ; AbbrevConstructors : AbbrevConstructor AbbrevConstructors { $1 :: $2 } | AbbrevConstructor { [$1] } ; Safe: /* */ { true } | UNSAFE { false } Command : Safe FUNCTION FType IDENT Template {{component = Command; ml_name = $4; var_name = ""; template = $5; result = $3; safe = $1 }} ; External : Safe EXTERNAL IDENT STRING {{component = External; ml_name = $3; var_name = ""; template = StringArg $4; result = Unit; safe = $1}} ; Option : OPTION IDENT Template {{component = Constructor; ml_name = $2; var_name = getvarname $2 $3; template = $3; result = Unit; safe = true }} /* Abbreviated */ | OPTION IDENT LPAREN IDENT RPAREN Template {{component = Constructor; ml_name = $2; var_name = $4; template = $6; result = Unit; safe = true }} /* Abbreviated */ | OPTION IDENT { retrieve_option $2 } ; WidgetComponents : /* */ { [] } | Command WidgetComponents { $1 :: $2 } | Option WidgetComponents { $1 :: $2 } | External WidgetComponents { $1 :: $2 } ; ModuleComponents : /* */ { [] } | Command ModuleComponents { $1 :: $2 } | External ModuleComponents { $1 :: $2 } ; ParserArity : /* */ { OneToken } | SEQUENCE { MultipleToken } ; entry : TYPE ParserArity TypeName LBRACE Constructors RBRACE { enter_type $3 $2 $5 } | VARIANT TYPE ParserArity TypeName LBRACE Constructors RBRACE { enter_type $4 $3 $6 ~variant: true } | TYPE ParserArity TypeName EXTERNAL { enter_external_type $3 $2 } | SUBTYPE ParserArity OPTION LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE { enter_subtype "options" $2 $5 $8 } | SUBTYPE ParserArity TypeName LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE { enter_subtype $3 $2 $5 $8 } | Command { enter_function $1 } | WIDGET IDENT LBRACE WidgetComponents RBRACE { enter_widget $2 $4 } | MODULE IDENT LBRACE ModuleComponents RBRACE { enter_module (String.uncapitalize $2) $4 } | EOF { raise End_of_file } ; mingw-ocaml/ocaml/otherlibs/labltk/compiler/printer.ml0000644000175000017500000001523412124403241022556 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Tables;; open Format;; let escape_string s = let more = ref 0 in for i = 0 to String.length s - 1 do match s.[i] with | '\\' | '"' -> incr more | _ -> () done; if !more = 0 then s else let res = String.create (String.length s + !more) in let j = ref 0 in for i = 0 to String.length s - 1 do let c = s.[i] in match c with | '\\' | '"' -> res.[!j] <- '\\'; incr j; res.[!j] <- c; incr j | _ -> res.[!j] <- c; incr j done; res;; let escape_char c = if c = '\'' then "\\'" else String.make 1 c;; let print_quoted_string s = printf "\"%s\"" (escape_string s);; let print_quoted_char c = printf "'%s'" (escape_char c);; let print_quoted_int i = if i < 0 then printf "(%d)" i else printf "%d" i;; let print_quoted_float f = if f <= 0.0 then printf "(%f)" f else printf "%f" f;; (* Iterators *) let print_list f l = printf "@[<1>["; let rec pl = function | [] -> printf "@;<0 -1>]@]" | [x] -> f x; pl [] | x :: xs -> f x; printf ";@ "; pl xs in pl l;; let print_array f v = printf "@[<2>[|"; let l = Array.length v in if l >= 1 then f v.(0); if l >= 2 then for i = 1 to l - 1 do printf ";@ "; f v.(i) done; printf "@;<0 -1>|]@]";; let print_option f = function | None -> print_string "None" | Some x -> printf "@[<1>Some@ "; f x; printf "@]";; let print_bool = function | true -> print_string "true" | _ -> print_string "false";; let print_poly x = print_string "";; (* Types of the description language *) let rec print_mltype = function | Unit -> printf "Unit" | Int -> printf "Int" | Float -> printf "Float" | Bool -> printf "Bool" | Char -> printf "Char" | String -> printf "String" | List m -> printf "@[<1>(%s@ " "List"; print_mltype m; printf ")@]" | Product l_m -> printf "@[<1>(%s@ " "Product"; print_list print_mltype l_m; printf ")@]" | Record l_t_s_m -> printf "@[<1>(%s@ " "Record"; print_list (function (s, m) -> printf "@[<1>("; print_quoted_string s; printf ",@ "; print_mltype m; printf ")@]") l_t_s_m; printf ")@]" | UserDefined s -> printf "@[<1>(%s@ " "UserDefined"; print_quoted_string s; printf ")@]" | Subtype (s, s0) -> printf "@[<1>(%s@ " "Subtype"; printf "@[<1>("; print_quoted_string s; printf ",@ "; print_quoted_string s0; printf ")@]"; printf ")@]" | Function m -> printf "@[<1>(%s@ " "Function"; print_mltype m; printf ")@]" | As (m, s) -> printf "@[<1>(%s@ " "As"; printf "@[<1>("; print_mltype m; printf ",@ "; print_quoted_string s; printf ")@]"; printf ")@]";; let rec print_template = function | StringArg s -> printf "@[<1>(%s@ " "StringArg"; print_quoted_string s; printf ")@]" | TypeArg (s, m) -> printf "@[<1>(%s@ " "TypeArg"; printf "@[<1>("; print_quoted_string s; printf ",@ "; print_mltype m; printf ")@]"; printf ")@]" | ListArg l_t -> printf "@[<1>(%s@ " "ListArg"; print_list print_template l_t; printf ")@]" | OptionalArgs (s, l_t, l_t0) -> printf "@[<1>(%s@ " "OptionalArgs"; printf "@[<1>("; print_quoted_string s; printf ",@ "; print_list print_template l_t; printf ",@ "; print_list print_template l_t0; printf ")@]"; printf ")@]";; (* Sorts of components *) let rec print_component_type = function | Constructor -> printf "Constructor" | Command -> printf "Command" | External -> printf "External";; (* Full definition of a component *) let rec print_fullcomponent = function {component = c; ml_name = s; var_name = s0; template = t; result = m; safe = b; } -> printf "@[<1>{"; printf "@[<1>component =@ "; print_component_type c; printf ";@]@ "; printf "@[<1>ml_name =@ "; print_quoted_string s; printf ";@]@ "; printf "@[<1>var_name =@ "; print_quoted_string s0; printf ";@]@ "; printf "@[<1>template =@ "; print_template t; printf ";@]@ "; printf "@[<1>result =@ "; print_mltype m; printf ";@]@ "; printf "@[<1>safe =@ "; print_bool b; printf ";@]@ "; printf "@,}@]";; (* components are given either in full or abbreviated *) let rec print_component = function | Full f -> printf "@[<1>(%s@ " "Full"; print_fullcomponent f; printf ")@]" | Abbrev s -> printf "@[<1>(%s@ " "Abbrev"; print_quoted_string s; printf ")@]";; (* A type definition *) (* requires_widget_context: the converter of the type MUST be passed an additional argument of type Widget. *) let rec print_parser_arity = function | OneToken -> printf "OneToken" | MultipleToken -> printf "MultipleToken";; let rec print_type_def = function {parser_arity = p; constructors = l_f; subtypes = l_t_s_l_f; requires_widget_context = b; variant = b0; } -> printf "@[<1>{"; printf "@[<1>parser_arity =@ "; print_parser_arity p; printf ";@]@ "; printf "@[<1>constructors =@ "; print_list print_fullcomponent l_f; printf ";@]@ "; printf "@[<1>subtypes =@ "; print_list (function (s, l_f0) -> printf "@[<1>("; print_quoted_string s; printf ",@ "; print_list print_fullcomponent l_f0; printf ")@]") l_t_s_l_f; printf ";@]@ "; printf "@[<1>requires_widget_context =@ "; print_bool b; printf ";@]@ "; printf "@[<1>variant =@ "; print_bool b0; printf ";@]@ "; printf "@,}@]";; let rec print_module_type = function | Widget -> printf "Widget" | Family -> printf "Family";; let rec print_module_def = function {module_type = m; commands = l_f; externals = l_f0; } -> printf "@[<1>{"; printf "@[<1>module_type =@ "; print_module_type m; printf ";@]@ "; printf "@[<1>commands =@ "; print_list print_fullcomponent l_f; printf ";@]@ "; printf "@[<1>externals =@ "; print_list print_fullcomponent l_f0; printf ";@]@ "; printf "@,}@]";; mingw-ocaml/ocaml/otherlibs/labltk/compiler/pplex.mll0000644000175000017500000000435512124403241022401 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file ../../../LICENSE. *) (* *) (***********************************************************************) { open Ppyac exception Error of string let linenum = ref 1 } let blank = [' ' '\013' '\009' '\012'] let identchar = ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] rule token = parse blank + { token lexbuf } | "##" [' ' '\t']* { directive lexbuf } | ("#")? [^ '#' '\n']* '\n'? { begin let str = Lexing.lexeme lexbuf in if String.length str <> 0 && str.[String.length str - 1] = '\n' then begin incr linenum end; OTHER (str) end } | eof { EOF } and directive = parse | "ifdef" [' ' '\t']+ { IFDEF (ident lexbuf)} | "ifndef" [' ' '\t']+ { IFNDEF (ident lexbuf)} | "else" { ELSE } | "endif" { ENDIF } | "define" [' ' '\t']+* { DEFINE (ident lexbuf)} | "undef" [' ' '\t']+ { UNDEF (ident lexbuf)} | _ { raise (Error (Printf.sprintf "unknown directive at line %d" !linenum))} and ident = parse | lowercase identchar* | uppercase identchar* { Lexing.lexeme lexbuf } | _ { raise (Error (Printf.sprintf "illegal identifier at line %d" !linenum)) } mingw-ocaml/ocaml/otherlibs/labltk/compiler/.depend0000644000175000017500000000213712124403241021777 0ustar tootstootspplex.cmi: ppyac.cmi ppyac.cmi: code.cmi compile.cmo: code.cmi flags.cmo ppexec.cmo ppparse.cmo tables.cmo compile.cmx: code.cmi flags.cmx ppexec.cmx ppparse.cmx tables.cmx intf.cmo: code.cmi compile.cmo flags.cmo ppexec.cmo ppparse.cmo tables.cmo intf.cmx: code.cmi compile.cmx flags.cmx ppexec.cmx ppparse.cmx tables.cmx lexer.cmo: parser.cmi lexer.cmx: parser.cmx maincompile.cmo: code.cmi compile.cmo flags.cmo intf.cmo lexer.cmo parser.cmi \ ppexec.cmo ppparse.cmo printer.cmo tables.cmo tsort.cmo maincompile.cmx: code.cmi compile.cmx flags.cmx intf.cmx lexer.cmx parser.cmx \ ppexec.cmx ppparse.cmx printer.cmx tables.cmx tsort.cmx parser.cmo: flags.cmo tables.cmo parser.cmi parser.cmx: flags.cmx tables.cmx parser.cmi pp.cmo: ppexec.cmo ppparse.cmo pp.cmx: ppexec.cmx ppparse.cmx ppexec.cmo: code.cmi ppexec.cmx: code.cmi pplex.cmo: ppyac.cmi pplex.cmi pplex.cmx: ppyac.cmx pplex.cmi ppparse.cmo: pplex.cmi ppyac.cmi ppparse.cmx: pplex.cmx ppyac.cmx ppyac.cmo: code.cmi ppyac.cmi ppyac.cmx: code.cmi ppyac.cmi printer.cmo: tables.cmo printer.cmx: tables.cmx tables.cmo: tsort.cmo tables.cmx: tsort.cmx mingw-ocaml/ocaml/otherlibs/labltk/compiler/pplex.mli0000644000175000017500000000223212124403241022366 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) exception Error of string val token : Lexing.lexbuf -> Ppyac.token mingw-ocaml/ocaml/otherlibs/labltk/compiler/flags.ml0000644000175000017500000000216012124403241022161 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) let camltk = ref false;; mingw-ocaml/ocaml/otherlibs/labltk/compiler/ppexec.ml0000644000175000017500000000422112124403241022351 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) open Code let debug = ref false let defined = ref [] let linenum = ref 1 let rec nop = function | Line _ -> incr linenum | Ifdef (_, _, c1, c2o) -> List.iter nop c1; begin match c2o with | Some c2 -> List.iter nop c2 | None -> () end | _ -> () ;; let rec exec lp f = function | Line line -> if !debug then prerr_endline (Printf.sprintf "%03d: %s" !linenum (String.sub line 0 ((String.length line) - 1))); f line; incr linenum | Ifdef (sw, k, c1, c2o) -> if List.mem k !defined = sw then begin List.iter (exec lp f) c1; begin match c2o with | Some c2 -> List.iter nop c2 | None -> () end; lp !linenum end else begin List.iter nop c1; match c2o with | Some c2 -> lp !linenum; List.iter (exec lp f) c2 | None -> () end | Define k -> defined := k :: !defined | Undef k -> defined := List.fold_right (fun k' s -> if k = k' then s else k' :: s) [] !defined ;; mingw-ocaml/ocaml/otherlibs/labltk/examples_labltk/0000755000175000017500000000000012124403241022071 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/examples_labltk/.ignore0000644000175000017500000000005612124403241023356 0ustar tootstootscalc clock demo eyes hello tetris lang taquin mingw-ocaml/ocaml/otherlibs/labltk/examples_labltk/Makefile0000644000175000017500000000233612124403241023535 0ustar tootstootsinclude ../support/Makefile.common COMPFLAGS=-I ../lib -I ../labltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support all: hello demo eyes calc clock tetris lang opt: hello.opt demo.opt eyes.opt calc.opt clock.opt tetris.opt hello: hello.cmo $(CAMLC) $(COMPFLAGS) -o hello $(LIBNAME).cma hello.cmo demo: demo.cmo $(CAMLC) $(COMPFLAGS) -o demo $(LIBNAME).cma demo.cmo eyes: eyes.cmo $(CAMLC) $(COMPFLAGS) -o eyes $(LIBNAME).cma eyes.cmo calc: calc.cmo $(CAMLC) $(COMPFLAGS) -o calc $(LIBNAME).cma calc.cmo clock: clock.cmo $(CAMLC) $(COMPFLAGS) -o clock $(LIBNAME).cma unix.cma clock.cmo clock.opt: clock.cmx $(CAMLOPT) $(COMPFLAGS) -o clock.opt \ $(LIBNAME).cmxa unix.cmxa clock.cmx tetris: tetris.cmo $(CAMLC) $(COMPFLAGS) -o tetris $(LIBNAME).cma tetris.cmo taquin: taquin.cmo $(CAMLC) $(COMPFLAGS) -o taquin $(LIBNAME).cma taquin.cmo lang: lang.cmo $(CAMLC) $(COMPFLAGS) -o lang $(LIBNAME).cma lang.cmo clean: rm -f hello demo eyes calc clock tetris lang *.opt *.o *.cm* .SUFFIXES : .SUFFIXES : .mli .ml .cmi .cmx .cmo .opt .mli.cmi: $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmo: $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< .cmx.opt: $(CAMLOPT) $(COMPFLAGS) -o $@ $(LIBNAME).cmxa $< mingw-ocaml/ocaml/otherlibs/labltk/examples_labltk/Makefile.nt0000644000175000017500000000205512124403241024153 0ustar tootstootsinclude ../support/Makefile.common # We are using the non-installed library ! COMPFLAGS= -I ../lib -I ../labltk -I ../support LINKFLAGS= -I ../lib -I ../labltk -I ../support # Use pieces of Makefile.config TKLINKOPT=$(LIBNAME).cma $(TKLIBS) all: hello.exe demo.exe eyes.exe calc.exe clock.exe tetris.exe lang.exe hello.exe: hello.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ -o $@ hello.cmo demo.exe: demo.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ -o $@ demo.cmo eyes.exe: eyes.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ -o $@ eyes.cmo calc.exe: calc.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ -o $@ calc.cmo clock.exe: clock.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) unix.cma \ -o $@ clock.cmo tetris.exe: tetris.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ -o $@ tetris.cmo lang.exe: lang.cmo $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ -o $@ lang.cmo clean : rm -f *.cm? *.exe .SUFFIXES : .SUFFIXES : .mli .ml .cmi .cmo .mli.cmi: $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmo: $(CAMLCOMP) $(COMPFLAGS) $< mingw-ocaml/ocaml/otherlibs/labltk/examples_labltk/README0000644000175000017500000000102312124403241022745 0ustar tootstoots$Id$ Some examples for LablTk. They are written in classic mode, except testris.ml which uses label commutation. You may either compile them here, or just run them as scripts with labltk example.ml hello.ml A very simple example of CamlTk hello.tcl The same programme in Tcl/Tk demo.ml A demonstration using many widget classes eyes.ml A "bind" test calc.ml A little calculator clock.ml An analog clock (uses unix.cma) tetris.ml You NEED a game also (uses -labels) mingw-ocaml/ocaml/otherlibs/labltk/examples_labltk/tetris.ml0000644000175000017500000004300012124403241023732 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* A Tetris game for LablTk *) (* written by Jun P. Furuse *) open StdLabels open Tk exception Done type falling_block = { mutable pattern: int array list; mutable bcolor: int; mutable x: int; mutable y: int; mutable d: int; mutable alive: bool } let stop_a_bit = 300 let field_width = 10 let field_height = 20 let colors = [| `Color "red"; `Color "yellow"; `Color "blue"; `Color "orange"; `Color "magenta"; `Color "green"; `Color "cyan" |] (* Put here your favorite image files *) let backgrounds = [ "Lambda2.back.gif" ] (* blocks *) let block_size = 16 let cell_border = 2 let blocks = [ [ [|"0000"; "0000"; "1111"; "0000" |]; [|"0010"; "0010"; "0010"; "0010" |]; [|"0000"; "0000"; "1111"; "0000" |]; [|"0010"; "0010"; "0010"; "0010" |] ]; [ [|"0000"; "0110"; "0110"; "0000" |]; [|"0000"; "0110"; "0110"; "0000" |]; [|"0000"; "0110"; "0110"; "0000" |]; [|"0000"; "0110"; "0110"; "0000" |] ]; [ [|"0000"; "0111"; "0100"; "0000" |]; [|"0000"; "0110"; "0010"; "0010" |]; [|"0000"; "0010"; "1110"; "0000" |]; [|"0100"; "0100"; "0110"; "0000" |] ]; [ [|"0000"; "0100"; "0111"; "0000" |]; [|"0000"; "0110"; "0100"; "0100" |]; [|"0000"; "1110"; "0010"; "0000" |]; [|"0010"; "0010"; "0110"; "0000" |] ]; [ [|"0000"; "1100"; "0110"; "0000" |]; [|"0010"; "0110"; "0100"; "0000" |]; [|"0000"; "1100"; "0110"; "0000" |]; [|"0010"; "0110"; "0100"; "0000" |] ]; [ [|"0000"; "0011"; "0110"; "0000" |]; [|"0100"; "0110"; "0010"; "0000" |]; [|"0000"; "0011"; "0110"; "0000" |]; [|"0000"; "0100"; "0110"; "0010" |] ]; [ [|"0000"; "0000"; "1110"; "0100" |]; [|"0000"; "0100"; "1100"; "0100" |]; [|"0000"; "0100"; "1110"; "0000" |]; [|"0000"; "0100"; "0110"; "0100" |] ] ] let line_empty = int_of_string "0b1110000000000111" let line_full = int_of_string "0b1111111111111111" let decode_block dvec = let btoi d = int_of_string ("0b"^d) in Array.map ~f:btoi dvec class cell t1 t2 t3 ~canvas ~x ~y = object val mutable color = 0 method get = color method set ~color:col = if color = col then () else if color <> 0 && col = 0 then begin Canvas.move canvas t1 ~x:(- block_size * (x + 1) -10 - cell_border * 2) ~y:(- block_size * (y + 1) -10 - cell_border * 2); Canvas.move canvas t2 ~x:(- block_size * (x + 1) -10 - cell_border * 2) ~y:(- block_size * (y + 1) -10 - cell_border * 2); Canvas.move canvas t3 ~x:(- block_size * (x + 1) -10 - cell_border * 2) ~y:(- block_size * (y + 1) -10 - cell_border * 2) end else begin Canvas.configure_rectangle canvas t2 ~fill: colors.(col - 1) ~outline: colors.(col - 1); Canvas.configure_rectangle canvas t1 ~fill: `Black ~outline: `Black; Canvas.configure_rectangle canvas t3 ~fill: (`Color "light gray") ~outline: (`Color "light gray"); if color = 0 && col <> 0 then begin Canvas.move canvas t1 ~x: (block_size * (x+1)+10+ cell_border*2) ~y: (block_size * (y+1)+10+ cell_border*2); Canvas.move canvas t2 ~x: (block_size * (x+1)+10+ cell_border*2) ~y: (block_size * (y+1)+10+ cell_border*2); Canvas.move canvas t3 ~x: (block_size * (x+1)+10+ cell_border*2) ~y: (block_size * (y+1)+10+ cell_border*2) end end; color <- col end let cell_get (c, cf) x y = cf.(y).(x) #get let cell_set (c, cf) ~x ~y ~color = if x >= 0 && y >= 0 && Array.length cf > y && Array.length cf.(y) > x then let cur = cf.(y).(x) in if cur#get = color then () else cur#set ~color let create_base_matrix ~cols ~rows = let m = Array.create_matrix ~dimx:rows ~dimy:cols (0,0) in for x = 0 to cols - 1 do for y = 0 to rows - 1 do m.(y).(x) <- (x,y) done done; m let init fw = let scorev = Textvariable.create () and linev = Textvariable.create () and levv = Textvariable.create () and namev = Textvariable.create () in let f = Frame.create fw ~borderwidth: 2 in let c = Canvas.create f ~width: (block_size * 10) ~height: (block_size * 20) ~borderwidth: cell_border ~relief: `Sunken ~background: `Black and r = Frame.create f and r' = Frame.create f in let nl = Label.create r ~text: "Next" ~font: "variable" in let nc = Canvas.create r ~width: (block_size * 4) ~height: (block_size * 4) ~borderwidth: cell_border ~relief: `Sunken ~background: `Black in let scl = Label.create r ~text: "Score" ~font: "variable" in let sc = Label.create r ~textvariable: scorev ~font: "variable" in let lnl = Label.create r ~text: "Lines" ~font: "variable" in let ln = Label.create r ~textvariable: linev ~font: "variable" in let levl = Label.create r ~text: "Level" ~font: "variable" in let lev = Label.create r ~textvariable: levv ~font: "variable" in let newg = Button.create r ~text: "New Game" ~font: "variable" in pack [f]; pack [coe c; coe r; coe r'] ~side: `Left ~fill: `Y; pack [coe nl; coe nc] ~side: `Top; pack [coe scl; coe sc; coe lnl; coe ln; coe levl; coe lev; coe newg] ~side: `Top; let cells_src = create_base_matrix ~cols:field_width ~rows:field_height in let cells = Array.map cells_src ~f: (Array.map ~f: begin fun (x,y) -> let t1 = Canvas.create_rectangle c ~x1:(-block_size - 8) ~y1:(-block_size - 8) ~x2:(-9) ~y2:(-9) and t2 = Canvas.create_rectangle c ~x1:(-block_size - 10) ~y1:(-block_size - 10) ~x2:(-11) ~y2:(-11) and t3 = Canvas.create_rectangle c ~x1:(-block_size - 12) ~y1:(-block_size - 12) ~x2:(-13) ~y2:(-13) in Canvas.raise c t1; Canvas.raise c t2; Canvas.lower c t3; new cell ~canvas:c ~x ~y t1 t2 t3 end) in let nexts_src = create_base_matrix ~cols:4 ~rows:4 in let nexts = Array.map nexts_src ~f: (Array.map ~f: begin fun (x,y) -> let t1 = Canvas.create_rectangle nc ~x1:(-block_size - 8) ~y1:(-block_size - 8) ~x2:(-9) ~y2:(-9) and t2 = Canvas.create_rectangle nc ~x1:(-block_size - 10) ~y1:(-block_size - 10) ~x2:(-11) ~y2:(-11) and t3 = Canvas.create_rectangle nc ~x1:(-block_size - 12) ~y1:(-block_size - 12) ~x2:(-13) ~y2:(-13) in Canvas.raise nc t1; Canvas.raise nc t2; Canvas.lower nc t3; new cell ~canvas:nc ~x ~y t1 t2 t3 end) in let game_over () = () in (* What a mess ! *) [ coe f; coe c; coe r; coe nl; coe nc; coe scl; coe sc; coe levl; coe lev; coe lnl; coe ln ], newg, (c, cells), (nc, nexts), scorev, linev, levv, game_over let draw_block field ~color ~block ~x ~y = for iy = 0 to 3 do let base = ref 1 in let xd = block.(iy) in for ix = 0 to 3 do if xd land !base <> 0 then cell_set field ~x:(ix + x) ~y:(iy + y) ~color; base := !base lsl 1 done done let timer_ref = (ref None : Timer.t option ref) (* I know, this should be timer ref, but I'm not sure what should be the initial value ... *) let remove_timer () = match !timer_ref with None -> () | Some t -> Timer.remove t (* ; prerr_endline "removed!" *) let do_after ~ms ~callback = timer_ref := Some (Timer.add ~ms ~callback) let copy_block c = { pattern= !c.pattern; bcolor= !c.bcolor; x= !c.x; y= !c.y; d= !c.d; alive= !c.alive } let _ = let top = openTk () in let lb = Label.create top and fw = Frame.create top in let set_message s = Label.configure lb ~text:s in pack [coe lb; coe fw] ~side: `Top; let score = ref 0 in let line = ref 0 in let level = ref 0 in let time = ref 1000 in let blocks = List.map ~f:(List.map ~f:decode_block) blocks in let field = Array.create 26 0 in let widgets, button, cell_field, next_field, scorev, linev, levv, game_over = init fw in let canvas = fst cell_field in let init_field () = for i = 0 to 25 do field.(i) <- line_empty done; field.(23) <- line_full; for i = 0 to 19 do for j = 0 to 9 do cell_set cell_field ~x:j ~y:i ~color:0 done done; for i = 0 to 3 do for j = 0 to 3 do cell_set next_field ~x:j ~y:i ~color:0 done done in let draw_falling_block fb = draw_block cell_field ~color: fb.bcolor ~block: (List.nth fb.pattern fb.d) ~x: (fb.x - 3) ~y: (fb.y - 3) and erase_falling_block fb = draw_block cell_field ~color: 0 ~block: (List.nth fb.pattern fb.d) ~x: (fb.x - 3) ~y: (fb.y - 3) in let stone fb = for i=0 to 3 do let cur = field.(i + fb.y) in field.(i + fb.y) <- cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x) done; for i=0 to 2 do field.(i) <- line_empty done and clear fb = let l = ref 0 in for i = 0 to 3 do if i + fb.y >= 3 && i + fb.y <= 22 then if field.(i + fb.y) = line_full then begin incr l; field.(i + fb.y) <- line_empty; for j = 0 to 9 do cell_set cell_field ~x:j ~y:(i + fb.y - 3) ~color:0 done end done; !l and fall_lines () = let eye = ref 22 (* bottom *) and cur = ref 22 (* bottom *) in try while !eye >= 3 do while field.(!eye) = line_empty do decr eye; if !eye = 2 then raise Done done; field.(!cur) <- field.(!eye); for j = 0 to 9 do cell_set cell_field ~x:j ~y:(!cur-3) ~color:(cell_get cell_field j (!eye-3)) done; decr eye; decr cur done with Done -> (); for i = 3 to !cur do field.(i) <- line_empty; for j = 0 to 9 do cell_set cell_field ~x:j ~y:(i-3) ~color:0 done done in let next = ref 42 (* THE ANSWER *) and current = ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false} in let draw_next () = draw_block next_field ~color: (!next+1) ~block: (List.hd (List.nth blocks !next)) ~x: 0 ~y: 0 and erase_next () = draw_block next_field ~color: 0 ~block: (List.hd (List.nth blocks !next)) ~x: 0 ~y: 0 in let set_nextblock () = current := { pattern= (List.nth blocks !next); bcolor= !next+1; x=6; y= 1; d= 0; alive= true}; erase_next (); next := Random.int 7; draw_next () in let death_check fb = try for i=0 to 3 do let cur = field.(i + fb.y) in if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0 then raise Done done; false with Done -> true in let try_to_move m = if !current.alive then let sub m = if death_check m then false else begin erase_falling_block !current; draw_falling_block m; current := m; true end in if sub m then true else begin m.x <- m.x + 1; if sub m then true else begin m.x <- m.x - 2; sub m end end else false in let image_load = let i = Canvas.create_image canvas ~x: (block_size * 5 + block_size / 2) ~y: (block_size * 10 + block_size / 2) ~anchor: `Center in Canvas.lower canvas i; let img = Imagephoto.create () in fun file -> try Imagephoto.configure img ~file: file; Canvas.configure_image canvas i ~image: img with _ -> begin Printf.eprintf "%s : No such image...\n" file; flush stderr end in let add_score l = let pline = !line in if l <> 0 then begin line := !line + l; score := !score + l * l; set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2))) end; Textvariable.set linev (string_of_int !line); Textvariable.set scorev (string_of_int !score); if !line /10 <> pline /10 then (* update the background every 10 lines. *) begin let num_image = List.length backgrounds - 1 in let n = !line/10 in let n = if n > num_image then num_image else n in let file = List.nth backgrounds n in image_load file; incr level; Textvariable.set levv (string_of_int !level) end in let rec newblock () = set_message "TETRIS"; set_nextblock (); draw_falling_block !current; if death_check !current then begin !current.alive <- false; set_message "GAME OVER"; game_over () end else begin time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200); if !time < 60 - !level * 3 then time := 60 - !level * 3; do_after ~ms:stop_a_bit ~callback:loop end and loop () = let m = copy_block current in m.y <- m.y + 1; if death_check m then begin !current.alive <- false; stone !current; do_after ~ms:stop_a_bit ~callback: begin fun () -> let l = clear !current in if l > 0 then do_after ~ms:stop_a_bit ~callback: begin fun () -> fall_lines (); add_score l; do_after ~ms:stop_a_bit ~callback:newblock end else newblock () end end else begin erase_falling_block !current; draw_falling_block m; current := m; do_after ~ms:!time ~callback:loop end in let bind_game w = bind w ~events:[`KeyPress] ~fields:[`KeySymString] ~action: begin fun e -> match e.ev_KeySymString with | "h"|"Left" -> let m = copy_block current in m.x <- m.x - 1; ignore (try_to_move m) | "j"|"Up" -> let m = copy_block current in m.d <- m.d + 1; if m.d = List.length m.pattern then m.d <- 0; ignore (try_to_move m) | "k"|"Down" -> let m = copy_block current in m.d <- m.d - 1; if m.d < 0 then m.d <- List.length m.pattern - 1; ignore (try_to_move m) | "l"|"Right" -> let m = copy_block current in m.x <- m.x + 1; ignore (try_to_move m) | "m" -> remove_timer (); loop () | "space" -> if !current.alive then begin let m = copy_block current and n = copy_block current in while m.y <- m.y + 1; if death_check m then false else begin n.y <- m.y; true end do () done; erase_falling_block !current; draw_falling_block n; current := n; remove_timer (); loop () end | _ -> () end in let game_init () = (* Game Initialization *) set_message "Initializing ..."; remove_timer (); image_load (List.hd backgrounds); time := 1000; score := 0; line := 0; level := 1; add_score 0; init_field (); next := Random.int 7; set_message "Welcome to TETRIS"; set_nextblock (); draw_falling_block !current; do_after ~ms:!time ~callback:loop in (* As an applet, it was required... *) (* List.iter f: bind_game widgets; *) bind_game top; Button.configure button ~command: game_init; game_init () let _ = Printexc.print mainLoop () mingw-ocaml/ocaml/otherlibs/labltk/examples_labltk/hello.ml0000644000175000017500000000335212124403241023531 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* LablTk4 Demonstration by JPF *) (* First, open this modules for convenience *) open Tk (* initialization of Tk --- the result is a toplevel widget *) let top = openTk () (* create a button on top *) (* Button.create : use of create function defined in button.ml *) (* But you shouldn't open Button module for other widget class modules use *) let b = Button.create ~text: "Hello, LablTk!" top (* Lack of toplevel expressions in lsl, you must use dummy let exp. *) let _ = pack [coe b] (* Last, you must call mainLoop *) (* You can write just let _ = mainLoop () *) (* But Printexc.print will help you *) let _ = Printexc.print mainLoop () mingw-ocaml/ocaml/otherlibs/labltk/examples_labltk/calc.ml0000644000175000017500000000762012124403241023332 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* A simple calculator demonstrating OO programming with O'Labl and LablTk. LablTk itself is not OO, but it is good to wrap complex structures in objects. Even if the absence of initializers makes things a little bit awkward. *) open StdLabels open Tk let mem_string ~elt:c s = try for i = 0 to String.length s -1 do if s.[i] = c then raise Exit done; false with Exit -> true let ops = ['+',(+.); '-',(-.); '*',( *.); '/',(/.)] (* The abstract calculator class. Does not use Tk (only Textvariable) *) class calc () = object (calc) val variable = Textvariable.create () val mutable x = 0.0 val mutable op = None val mutable displaying = true method set = Textvariable.set variable method get = Textvariable.get variable method insert s = calc#set (calc#get ^ s) method get_float = float_of_string (calc#get) method command s = if s <> "" then match s.[0] with '0'..'9' -> if displaying then (calc#set ""; displaying <- false); calc#insert s | '.' -> if displaying then (calc#set "0."; displaying <- false) else if not (mem_string ~elt:'.' calc#get) then calc#insert s | '+'|'-'|'*'|'/' as c -> displaying <- true; begin match op with None -> x <- calc#get_float; op <- Some (List.assoc c ops) | Some f -> x <- f x (calc#get_float); op <- Some (List.assoc c ops); calc#set (Printf.sprintf "%g" x) end | '='|'\n'|'\r' -> displaying <- true; begin match op with None -> () | Some f -> x <- f x (calc#get_float); op <- None; calc#set (Printf.sprintf "%g" x) end | 'q' -> closeTk (); exit 0 | _ -> () end (* Buttons for the calculator *) let m = [|["7";"8";"9";"+"]; ["4";"5";"6";"-"]; ["1";"2";"3";"*"]; ["0";".";"=";"/"]|] (* The physical calculator. Inherits from the abstract one *) class calculator ~parent = object inherit calc () as calc val label = Label.create ~anchor:`E ~relief:`Sunken ~padx:10 parent val frame = Frame.create parent initializer let buttons = Array.map ~f: (List.map ~f: (fun text -> Button.create ~text ~command:(fun () -> calc#command text) frame)) m in Label.configure ~textvariable:variable label; calc#set "0"; bind ~events:[`KeyPress] ~fields:[`Char] ~action:(fun ev -> calc#command ev.ev_Char) parent; for i = 0 to Array.length m - 1 do Grid.configure ~row:i buttons.(i) done; pack ~side:`Top ~fill:`X [label]; pack ~side:`Bottom ~fill:`Both ~expand:true [frame]; end (* Finally start everything *) let top = openTk () let applet = new calculator ~parent:top let _ = mainLoop () mingw-ocaml/ocaml/otherlibs/labltk/examples_labltk/clock.ml0000644000175000017500000001146212124403241023522 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* Clock/V, a simple clock. Reverts every time you push the right button. Adapted from ASCII/V May 1997 Uses Tk and Unix, so you must link with labltklink unix.cma clock.ml -o clock -cclib -lunix *) open Tk (* pi is not a constant! *) let pi = acos (-1.) (* The main class: * create it with a parent: [new clock parent:top] * initialize with [#init] *) class clock ~parent = object (self) (* Instance variables *) val canvas = Canvas.create ~width:100 ~height:100 parent val mutable height = 100 val mutable width = 100 val mutable rflag = -1 (* Convert from -1.0 .. 1.0 to actual positions on the canvas *) method x x0 = truncate (float width *. (x0 +. 1.) /. 2.) method y y0 = truncate (float height *. (y0 +. 1.) /. 2.) initializer (* Create the oval border *) Canvas.create_oval canvas ~tags:["cadran"] ~x1:1 ~y1:1 ~x2:(width - 2) ~y2:(height - 2) ~width:3 ~outline:`Yellow ~fill:`White; (* Draw the figures *) self#draw_figures; (* Create the arrows with dummy position *) Canvas.create_line canvas ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] ~tags:["hours"] ~fill:`Red; Canvas.create_line canvas ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] ~tags:["minutes"] ~fill:`Blue; Canvas.create_line canvas ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] ~tags:["seconds"] ~fill:`Black; (* Setup a timer every second *) let rec timer () = self#draw_arrows (Unix.localtime (Unix.time ())); Timer.add ~ms:1000 ~callback:timer; () in timer (); (* Redraw when configured (changes size) *) bind canvas ~events:[`Configure] ~action: begin fun _ -> width <- Winfo.width canvas; height <- Winfo.height canvas; self#redraw end; (* Change direction with right button *) bind canvas ~events:[`ButtonPressDetail 3] ~action:(fun _ -> rflag <- -rflag; self#redraw); (* Pack, expanding in both directions *) pack ~fill:`Both ~expand:true [canvas] (* Redraw everything *) method redraw = Canvas.coords_set canvas (`Tag "cadran") ~xys:[ 1, 1; width - 2, height - 2 ]; self#draw_figures; self#draw_arrows (Unix.localtime (Unix.time ())) (* Delete and redraw the figures *) method draw_figures = Canvas.delete canvas [`Tag "figures"]; for i = 1 to 12 do let angle = float (rflag * i - 3) *. pi /. 6. in Canvas.create_text canvas ~x:(self#x (0.8 *. cos angle)) ~y:(self#y (0.8 *. sin angle)) ~tags:["figures"] ~text:(string_of_int i) ~font:"variable" ~anchor:`Center done (* Resize and reposition the arrows *) method draw_arrows tm = Canvas.configure_line ~width:(min width height / 40) canvas (`Tag "hours"); let hangle = float (rflag * (tm.Unix.tm_hour * 60 + tm.Unix.tm_min) - 180) *. pi /. 360. in Canvas.coords_set canvas (`Tag "hours") ~xys:[ self#x 0., self#y 0.; self#x (cos hangle /. 2.), self#y (sin hangle /. 2.) ]; Canvas.configure_line ~width:(min width height / 50) canvas (`Tag "minutes"); let mangle = float (rflag * tm.Unix.tm_min - 15) *. pi /. 30. in Canvas.coords_set canvas (`Tag "minutes") ~xys:[ self#x 0., self#y 0.; self#x (cos mangle /. 1.5), self#y (sin mangle /. 1.5) ]; let sangle = float (rflag * tm.Unix.tm_sec - 15) *. pi /. 30. in Canvas.coords_set canvas (`Tag "seconds") ~xys:[ self#x 0., self#y 0.; self#x (cos sangle /. 1.25), self#y (sin sangle /. 1.25) ] end (* Initialize the Tcl interpreter *) let top = openTk () (* Create a clock on the main window *) let clock = new clock ~parent:top (* Wait for events *) let _ = mainLoop () mingw-ocaml/ocaml/otherlibs/labltk/examples_labltk/Lambda2.back.gif0000644000175000017500000015030212124403241024722 0ustar tootstootsGIF87ao@ϪϚòߊuuϺueuequuUueeuϺϺߊ}}}UeUeEUuEeuEEUeu<<}0QaUuu0EeEUeߪ<}}߲Ϛeu}}euuuuuuuEeeUueϚuuUee]]]Ϻϊ}IAIuuuEUEE0EueeeUUӶeEEeuuUuuEueEUu00E 0 UUUuee 0,o@ͯ˱όۖΥν `%Dبq#T*DZa|ٓϞ4(S<_uƤT ]łYDq%^ |z.G}*%XRR6t>ZxV"_ӢVjVV[*LHf6~*&)۰M +I k-:s]AOeZ@*tgFÚ-5_*CiPT6v,jhvd߶kYlcἳ;+Zi eԳ;i^8wwvjуVGWnYjv~#a9f(}jY^V&}>m&pz+ŸdH y%L*'ZVd|1kmoZ',qI_䶕_~k>4z-EW_ϲ@TQ;K]Wl$&g |zwgs9Wniۉ o%j2y(~e;R {,-;Է?F+L37υNC*aNr>V-7ք%0oix-J6N3m9,}e(չ,8܌-9Yy7١hoݪgC>ٱڹf]+kfx٦z[W=nz'w0ԣy7È,Yƍ.{ʗO!<)|V+'ެ}u˟V[{"g,G5Fi NlmCR~3T+RS /k\0e,9Q.^ fIqE%ϋ~bMʙ2@ͣ,cYćԢ[g:R쌤94hTbժb8ʌrTpC\U8enY7֏yriMS:ΘSHǹᣤ0,e4s!ںQSeE©iVYqV-*JbLTJuVj"K-0G5Fuhڿ!ӃD5,rZ#]< Pv6[s>,#ӑ03)T.k:^Ku]jecAjUݟs;V֯ع=kRl\tl^gKlmM0=nzSr&uo Y\*_kc/gvHR ״Ugњ`6VݽrL[hj6V+1dTCrŭ:S283X\L9nPGIc4$'@ɚȋ䰎g 9 o W*N4twF4wo##`Y]-ga=2'Vְޑ9$ue/L+sӝNTAո3oB+N6/ zUdg@6˻pG,j+KNk`I6Jd.mn[K~r)IW$y:Na7Wf9:'+V_fbWVӂZ־6 :!D_17pO.t8m6} q_I~`|Wy+:暞dyL;-r3fUX p,t^ӧӷ rS*-:Xbڹ_(i>{g;LmDNy]yy[\߯9 OX)om|!'>]Wկsߥ=R~_=nG`}3]w ,߷·꒺,is&^F/bɊjI2OaxmRg|g5U~gĥQyZ}nWma?L̴緁~w'kdOLe\Lj\ Vgv&ljā vc`iy `ٌtYMI~Ɋy$`wRs{ʧLHzhiֆpHxΘp!P&  !{Y0yz,p1ʌzٞH0CJiل/jyڢJƊ"ꬥJꪉךMڬ͸抮 y஺7}9AָX)|!@}Uj& , ) 0F+鞠xj Z Pf{~v `Oz9J9ɨ+I:YڸYFxȉ(Qh 2lψ8Y8 Dk ,/E+<ۍuK)̘T{y Jx3kEQ=u[v Z) 8 0*;D2@I10 IN9 [H.@i.*\ 0{T'CvW˓j9ȐɊF۞iDE31@ 1c IͨJ٥E{j-*sÆ ̈́0SiF۹yꍊzGظܫ0]0܋1мڼɪyۓJU\0\()jhÇvvȎlGYɗJɄȽ~Jʦ̼  \\<}98̺̑6.Q)8Zy iӏٞH 8 I0&64-6;ū e=.ꞟ,:ɞh!ˮmHU W- 8.˿m} 췍;4#" Zp!0bcɿMٔwYȨuy۝ J94 pٴzշt{,!û˼ȝ\PJX p'@Y+Vۭܫ3zX밤xi9ԕ;pPا^]{)nL αʨ]xۘwukuvdۿ♚;I;e:쯡h$ 8 r; nD+c\;ȊɊ]yh.Ƶ)ɉ9)QWG>/b.#3b6ݍߝ\sM5;h<=p8 >֨\Ni詭 ojجγ}[KGQʐI;"|`a׾}n` @ؐD !F`F "xWc]3!*hf"VF \ jaQJmhB(XP5mEB .VJє=lπuV .3ڮF{'"jI]pƩv6X@~ZȄ rd.*|>z!A Gz׸Bsjb\Ne>,@HԨ ^C( 1걈OG= _GTb`@􏭵&۷7v^zU $*Eb0cJF:af}ƙrEPiZvgEEmf:5#i`"ɉ6>=GtTWv}!2R,9 7H{W_Ye^~ :ԶXR <(H+PZǂ "` fnpH$E%T6?~u3*iX^{HA~wd:HhAd B=- _eA%H2K{L@ βB/%--5yM88⛋mS +c& ;: 0svBy #R }`Bm"5hh`P/:!0.&, *TE( r?X,U!&u1-> 3݂$ 4?= t44ݴ 83!\wr-Vr"ytxrPNBҡيIA=&h& !Af1׭BM[i-Dd')cD7NTuZ鄜(aK)Ob &8॥x4\Ҹ<9 '2h!A 'U v(N@=FwLsT/%5`p7$8Z>%(h $#+*؅߾ժQ؃)ШUFVИr O0)VH?2dV ?%qTą +cLǏCDx kE A} )hlf !*G,3Atꖹ%SKЄFÌ_YdnD i394ٴSCMpgk ɜb~kg*JOͳ $?O֗l36J,TU(C 9⎤&uMtĤ x:vZ2mS 6Gx!E ZthBzA NuPS.9 @gJ9 z`8.C49Gⵐ$zo  l4SP_yQ @f5 pL'i/H :DoGLƾ)rf=N &39!4|.s4QW0Ǧ sM.U)@!ZP(OXD}#l YC0$ !.qP_Q^gs.F`=Hl RaY޸"^IB R3e~C X@PQTHL@Cp&uWz+8ռQ>@b|<2)LOdwLLyj .BwFxg0΄# f$㔀gt*BC#9})s!Tfx@R x `7k4!s=l'8E;$БVeA's5pzL> d`R]ØmSj>Vz7_ v@tCЁ y?Dvub;0: b~l!UmFj?Ey\[(A (WLDn 8ͧxR_ 1 `'. סhD@ъxǔL[Hnloj_+;y $M^'F]) 8!G q+11`A,&:t`cp ~t pNt`b`-ށe 0dt%88l'G| `|.W#| ɥ g}}56p5P~$w;mGbw rwk-x6)Q"p| X9SFHr[%:x $ၽ Y9(H *XY 6c<˓dl9ddn4]49 8BaX6 ^ .c>nx>,=em `a!oh)U=oJhp^EO GN/@4p63 31.VTQD٣p ߱q}Ffao.0a 0 pze+tP`Vls7Ԋvbs"Pebqc%(cd @gvusE *3"o_3) "rLa03w7Q[2ud1*?F 9OSQ$*5+`Ty y XaPŠWY(yUOȳd2CglKDICW=y }"'uTGC y@>SgKyjs1!uJ?}ضR6fy((>4 2"zG}Đdo7ϑ8!2z_#r2 13:3}!3Z:(Ρz QGiyE2U2IJ#‚6dl@s>3tH1x{SW'VGPN`|j!y&yvQ6U4/ L,BcWSs?r`hwW1$va4%ULhJv2 mT?P*G2  O>q:01x55R*PH*Т0:7:s35 eTց ˚1Ԕi ڊZl"홖cT0oSٍ~Я4 QaC K9 U y_TV-+*v9\rQ,H<-i6<  ;Y&>ڙmS25`Xy.dT2"Pj dB!Ч,7QQh\=~#g5}5$o FdߪXV?>/'+I*`* !KA(U12u2:h'!ށ+b79RaPZE)͓{5:h +Y^9N imy e4.W5rr0L®Uc`eYEX*5L#mq?~FupF^R78U@5[^Q5streɘG2a ;*0x@;l2&Ȃv-]c!su 3}XыEI .K;uF -s+t.$Z'$1& QEl8pp(q q&/"{=怮:56(A0=D#9F3 I"bIU!=9SrЍYw/  c=du*"AIR5 Z}t>K!<*ׇV5J;/ga9Pʭhוg\QŌa*PTOwҋgwA$v=Z&if $#]ڂNգz h3} ;Sx*Pu˫ԧ*du$L-ep7j 7 \Nד>  -\!׋cOZFy8 ܪ,R?i93d%!X@l'foKV?cL? `'j( T @I;na "uWQQfڲA S_a';fa47E(? Fm@뺸a2BQZu˚'@`|z".+.G*G\w2nfJyU"7hz Q8/U3v inf)1u Q {%,c-&2"*M WI5f IP,7R|f<5Wϩ ޔ2$2> N y2 z5` Zw#ℶ*zyaƭ+NF/l*AK|Q ^< ㎳l)ՕQMsB+hQ.'SV3e|Qɉ*Qg\W Ѡ|]TD|Q2A8'Zøm+MC n'hدC>IuE5v̰n`7g+7"($my:\xߘs(p5vx}߯@eLcHq+5LJt:!;Dn M榪 G YDCi.p[b@RJ腕*1 ">uSPT@..y!QuVF8f "("^$ա[A\n0ѣGQOo|b~F 8nt &$5(B;$EI@ e(VV$;BlKK{ D"XJ B|B|rİcJÐB 5l@P#4h|B8\ np `gg03zƌ(aIFa4M*@ $X+*ܙ/SPbE8u="1IBJ+ :!ZXJE ùPGK2R 94Q'€Qz`?u`1k03yF'd, :I m EpG*#3yA!l1G?*yd5rU$- bKSj&$(T` +y"b Un'!o1}Gk"zRF.RShU0n]hXe$1+5C6CGE1cAkY aSHd`Qb ip Lv:಄U|2r`ȫ]D 2 ]9V!llȉ.x)@#;wX-B=R} `-S ,a.6aQgXVYrM{5MDk :Bߓ $QyP* EG!Uq.4NT+P2@bX]CV`815 nPeЀ0F=Wq9j@L1w]Jq$| *NAȳR84 tFcc1Da+l@1<.2sgPs&tX!}HI w @PC)/GT%>K>r+u Ac0W{'% 4`U+E2$0T2E@<`  2]R 7T$!ezgx>mnE 8-Rf uPL2)PP/HZt!4 15/sr1G**L7)r +V$wdp,iFxIp>PtPbGF7U>FVP77ؕ 3ThGI<%PHy(+m?B+#(a+A/DX!pTB1KZP1-WQ0J/0&P:O1!tyv!ld d5)UyF4=5P' mT_"M7P34qCct s yR"-0F]ICu$@T1y-UdIE!!_!`=Л?;]w !h悡AZ'rb~1$ݑEt-+u/+n0@]DZV>,dh-  /915Yx#ɐ*=W~2)X < Iep4`RjPw$yGBTE@8Q":tH\t_jDPrJ52x86E#Atg!P\̓}Z*|e)b#rpE}Kkդ5FFlSUj̀.BYt@7`ln*tdru:,§R!zzxq鐨I])j". zUzъAZ, ʪϒЮ5 WS#p* V( ^)4 [Tɠ_RAku@9F8m}t WU m!u)ޅ5 &QP>Е顣G?"`Q=5DhNW3iR,9_ EaWy3AEp_zr[TWJpw h*$suu% ~ ? S@wk ιzOEzQ!p*/pkمZ:= HF 472E"4-HZnfw1.+p`"w\Ww x>vA k9*EIgRUXX f,QkVhDQyV[ G`f<"<a}z^ /J ܡ {@dHu5O?G"1<2`RW#Q&AHd-XBk_ )}N!Nvq 1\hǷ70 x@ '*(qH!W]9-:8.K5q~Qt[D) c)*1GĒ<P 2ȉcrPG]@rdx )\xoaJRTYD0pmitiG>?wKy+!& xI703PZp-phôƎU.|U$˫pMq$7R a>a,IGc<2^}5`& f P7;PHhŴl Qt!_@ 3С+P9 NNGtKry|L}4@;#5efq^ZQ(sZr@  9TyO1)#wu!-6Yf(Z׌;%|׈|E$BɴP4*2 9#>18m 5)U y0*%*+!Pt*I-򴷕_̶@>OuH*x4Z>/#‹QoP-zq 7@?DFgK'[avBS2B޼Z [M3kW @P6p#*"!27mҏf_D֢]9wTZQ FS!P "~PJ1Y(qJ}*@ `⁆}*ΚB/I2^l*:?lQ^4F~SINM R*TVykc! ^21e=;dLlp~N2Y/)xz|>w~޶a'A$V.k( rY)F*lQDgfV]P_6H&G|* 7̀><Е\< t!NAS7 <_0$ s7$`!< N(Mpҟ8tCם "42P2ws%t,2Y.x7Z@/u(>fWdQ-!_V:vRk4_ ?XA܂ZTaQF|<;YP,0푵iw򑪻>!%++ɛd}>ہ104A,_,eE2~mQl 6ޗݙ}-:H E"!!!!h(IXؒ"RcX(Yb*#RQb!XA[S+"B*L( "()r*S"QM#1+R!rC/a"@pAG|!ބ%2ntP Z/8JԀY Ai,X!URwb pQg KC9Z$d  E`Å(U$ 6@xj]0xzKsI"".K*u0)*o"T5C 4<`MwT T0Pc0A_@B]Mc[;"\AnRE5xAdBƒ"~-R$8EqQ\3bڦ%a*]sNQQ~٦ >'0(a<HQp@FI 1Fl#5ֈ"E"- -_o f A!EP ҂s!C2MXAi0#i22R,' )w5#\{AF 5d_a#% mFB#$֜5*Q!,7/ȠK,ӜJoI S|٘Ù(40!ujjy }`hD*OhfW饙Biqyq3ȤLYF骭&vZ뭹ګ5)ð" )2 N8GXUrW:".梫.q.9&Gܛﾂ˿\0n) SC0qe*jֈ` /tN20~b̉JYzs/i6 ɯ+8BPנ#@Ci2)$tzWl'e75,& *:65sBM*_$H1[&eJ_GIГ%(*i״*%O1L3!e,tBHLR-MpS ]+H4vT= !aiTGoȕEPFN`:ԧ\}Oz9q"? ц" # "p*K 4lf F5'; Z}W 6|ՌGF[6Э#!ݴy:=o"ԻDmc)OxW ~C| Où(ZrPFHrF)ǀW 4f!>$=i6!6CY* K5, e<&`SU @tSW40" t1RpQ r s%34b%fVV 35qB=2e&) -YrUPPR!P!zA 8x 7}r&InSq&+&BlG 6N1K@baC=2= UqM>e3ِQ DF (2!N)$Q1␀Ag~J=7"=M2|3aW5FSb/e΢C*)@A Q7)T%ELIIscG+ȰKp 3,p%R,1OV[BPgC;b8 O; րP %3HyB h0(Q,4@#pr * \>!Z1>\ DDjr&( 1C!p(=D 6Au" PV+΅!0`h(( 4|`tzx fl c ӊi&:lj)pcիz"ǚnʚZ+4H1 F 8z%s 5ߚ ,P 뺷&KQLGЯ"$b0_5а/q9Dp騴DM E:6pFPb!E>q Z:2 %E)FHYwe{&^&#q΁ +f` ,"*]Gg"b2yDH-pQTwL )0h3p ¡E,&Faor[vV<#fVXW?TPa Z@ pE*ii< P ZCDp3U#EQU׻:W,,)V0 fAS|@#I c:D_v(+4A1+ò- H )ACP b`<˩>›Rl,J05s^?#A,%0\#% <.!JȥHPC'aI0]h(q^W pQ&aJ) T2_URq =`Φ)P gydдq4@Uvd)YoA<Cg-x" H\S `qp!I0"Pu>#ȉ)@R-% Td#|"` & td0AI0lfU1c$`UV\ @\ :!3fY)E ,EA gEsƲU,ҵ3I%3|XpMc}M5C'20Q< s,UhXA DpTa  ۂR9BKvp { Y-h!wnADiUT)2C=iLl7E\spX7@0@Lg{* \4fYFgPE%$`A P G%>#nkG$/Co+.$ .L@1ed2ΩP˰dRR  3I}AjPtB<]~("x*ư**)RT^*Vzxe? 2GC1)VZNl B*`=XLYV~N ta|,Lp k鳹#ꤞW-Aೱ8Cf59!^ ,c7`쀖 ~z$A.DRnt#:i@cѱB$$Ù@+q"-1@ >Z "Q{fK syGG@^{'"PV;b r^ǁ< <X"^glFR<sa}7sS-XaAU}d1-<#W=`t2/0HyH jIa>---**5/I2DII>!>AA2>5>-A00D7F*>CCE5C*>>"5 -Ez`2H5*AI$>@Fy@DIƩhAV"BH(R+AA,Xp"hC xaD! D !B 4p& "U/<ʐQiY\9 Hx"dDP# JE萠 MjtPZɸJfH1D5BI?>+A*>>X D-֨P1Dd]f4;YnG?B'Ye>.7:0`nV1 %E-?1E|Ã)ɍNM8\ QA TX !c!!XAtrϔ6 "(+B(+1^USՎ bʨLYX _YJƤBp5$`AmSsi\<+Aa*t,|*a"+A2 Q7̎Mz fOJ`+Ao*|@T! k6S )'6 CуWX--"|4TtD GOd+R?a4=AWxv9 t 6"x V  8(%m#p-d $qUʠr;?DBD1>+R\^QHu1kl mGXudPB\P#FرƠ|3 >nfF|zDs4DZ&șN|=hFI>m56"  >{8D4QB YlX6F6uc1=fX>@9eC,`z簄ylAC6HD˛zIezx.XHh D@`GJ 1Axq""Nq8o+&|Wsj&w:EL`4AqINMRU,K&‹(z#:YNG,`ElQ5ih Nȇ[`I( %#T0SӚ P22) @堊jpbǩر,m1r[!z0HMP$DKX-jp=4VL/>ƴ SK̠qBLF lScĤ- A Ӂ&(9J&Aj>!n@LR׍mQ^f~ց!bǾDjcC8e?2* ]!VF5) P!2:$Fk &lq@FGi%R< FLia6eǙ (DiA^0PH:h6{܍@$1u20LExH-ǒXDHHVxׇRu0rĘT_f\󌳖7$:Vr<&e>j8T "G38="+ġ ơv@cр=uQOF4!~ bE@R $I :u W6Ig^'%2'Mgp7{[Q`oG2BRAbAP#!U+09`(%EVx!"#<5 +R` *VS5gfQ,E`E2pMA%&Y0P#" P!PI kR|@Q3s(%"s0`cq# B 87'B -.,FL:LqL2WR'# ,PSD:PG#A1ZQ wr D+S $H_uR2Y 2+4Ubx%1 yT"Ug U[ +XKSS! H%2P '…,Q\n?RakgE:VmB0pMpL 8FnGJ6sK1+R1#TK0%? }!OREi %8 !@Hpƈq<8 8!鰉hA u(4-EЊ(G43\Xы$Q76{Fq!dRRHv#,XMvؕ\% Y2 (D7`˂? ΑB8BGi+@װL!!}DA,"2 YLy3+!I[df d C0C}arQXp P #'0;: PiU@H7+A1B#=LG1A) "pP?6?U]tVx$p r5or%E8.PJ@P+ $l,t3ٰ5Z" -eddT#0C<+$C i} q 2GaVw`VatAw8& YbwwIP {r5Q#8tK0p-bA*w* iEPx_Q2%} 磠c'yb1vuoaIx`2%*'?ϐ*+GDkrWWR//b! `CnsS!!; 20|A ԉ#gJRF*, pu^+>_oU.p&1?RI0aE*1"wpGU `>r0&!qCsd-C-70.Ӧ~!,E%Œ|+yGTFHW#Bd7AAeBXq?+!0.7 [XG #v#0h g&|%"RKfZE4Xdq:8WH aK9,GcD; -i4 ) D&CB o=GOW1g+67bAq'b:I[wdQu O& ,x UrD?K ! aveM2XRac! #u#2@ ]SP0c `%)/@/`="H2s[2Ql o@34i}2F$ưG ^+weUI&2{P&u Sc d ~(Q {vLvS(`_ /7\(? HKP9F,q*PV\!#S=5!uP-}\aA(EBwE|rX+@B R mG\Jl`*> !Ş@U\gWY4]],`,bl dlƝp!B*nLU6 sL;`\%|E 37ȷPȇ,l,S|3 VAɒ `tqpphS2]a&if("^s1-΄$W!67g].TE<>^PA4ѵG4YWA@ ʀ ҋ&^(3x72>qY%) 1FP7Y"sB08@8m,M`~09 YNK1XBGsH0"O Z'mD2@tK} ! /1La( u.!ˈJ& ${}>qQh: ?c :deB!XDmJ+aT+wPa4xޜЂS,p -0n6Եo{ ,́$7GRfOU]#p@TmRM @)Gly#bGt"Fd/*K/v pf4P@tq/\NJ?W7rkQT?*0Ӌ32Ft$݊C²ei!0n2@_òK1jFyE@j) 3nq}-z2^U3BG'g@-f(p.X27W 1WPT!"!!#q!qTQRR!"!BSSr*ر8##ss(Q8irc,]M]SC$S1T. 3 <`Ѓ#JAȐ\ &5d4taF+hTq$&C|hQN#>* MHY"HEzm*x8UccHԔ'OxX5Ga1m!Y3BQ &*k>* 9pk[rqvb35I$ jԨ"Di$)'C c0bEH@2eA9kZiײm-\Υ[xBԻZ?4†F"F58z9oH %9J-L5ݔN=tDPCuTRKVQMmWV]}BXcPg?n\t`W xŗ_'&X"b5-X(rEdTYV"g@""ZkɶݦBnx)Co &%#%$ yUcL-5֖6 ,'MQ; dW>'!BF`L䨠AE|pHAHhqC~Z@#HRECrXMtCVBAQ%tPMT(AtS)NDVupý%"XM eHwAɧ@%C&P%#Z4Afm%=|k%$2O0AM].@ CF2q"7Ѝ Ih/UУt+xeypkK,~J[P!-`B}U*>LO!+n$W|dm 7C"f!Vp-fJ b%bNa壯y"㨕 `*NOD`#`"I @*W%TU?"0;IP(u+\*Bql$3%c?I137Fi8xIo>*0*}i˞wr'#!825-I0]AKʿ! h!ײ3br<^z2&,?)JVhx*TUfZ-PbE?ZlCcⷛTXA`B9ř3Jr&R7T%AlC|?``MTD%22=(R#M-X"Qa (~< |T߰M2Jn=!AA.frC(w:F8 A)#P%+t *p9B^~5 ŭK uF#]LP.)Tm pg:TؠyGH)'ti]c2D%(DAB稍D4i/ I\ūSPEx ,;s)<0끏mD>,쮉1wa. i„r8dOa?0em ;% 03wrr%>r ,XQ 6zeaFhxE,A !$,얋.gZfP^pL"/{盔$o8e)N ~6dJ(AU3 SiTkS&>q}U*$fh3Lfh6VfoYqE\<#A:Ah)F,yVl^ W 8kէe/NT, B'Wޣu HnBCb+#@_jdC1De c=22 N36] =Ȉȕ+u$_NitZS=2ذ lq&(<6F^uoK` MAc,Xc!^ED! =;6 "x&C+7|Q:KvA4fjS&WQKfMFP^:#Luz>AtCN6i3R!Psl\]"k- 02?> GPa5' 6SR zB DB+oj!\; 0?7pC99[!!D0FO+cс%836E[E1aRQ,8LHH Ǔ Sd4GJo!E gE'_+(7T]W^7{ KGI4@ɰ^> s=*U|3f3 8`b!"~w["WJEGB /0bG)2Q%3a!pNCP@ 00J?6u&QYU*-r/Θ~S!++=$f#,$SQ~ LN+4+s5@oS?'>t>e'F0'`0?jfE4wQ7?aICd'r=$^*CAC7,0~BPv #gPHp  Gu } 'q7 ]!lGQ d;r0]%/%w S̠;6#BBP LL0@t"=~[/b5X ceюKDB0J@P P9%S5&GP3UH_IS,I@!s x OW5'K1KA9I*`8^URȈ}Gr4d"IDj 2 }b 0!1` 1 `BS^Bf_P @6M`=WM`oxP1#W -p: "/iF$ P?0^B=0$$3 I~RX+@[W 4YMpg+0N1p4= @ (%3Y*♥G ,> 5КU F C~(S7WEp2i.y iA Rp3v *9 p3QCp}&ED`֕ŸђZ,#.j:e@!:%yp)j>,6/D1t: <BJwVGjJ>5u<rh ,'S6~̇>ƠSQ(OW&"]6?:'"+)= 'A rQEd@C7Д :Jo^r,@XN Pij!J7dZWE? ;=&YQC3^$'=R%bC2d@ R&E/#8eq@I\8N:*@{#4˔nātRgS{ %|,Kd@6 0^Jզp(B *`0CVERQdZ/Yuqa%aIS1d*i3 YFԓ@Mؠ5vy414~"v O0dD7q"8pR,3@*iQ,,\$X'w7g<Es%;Bz1!8

w2,2M|AjJ<ƴ_QO}$@ 4V`4?40K0Q#'!XźM3qx_P !zh[{dy>1[РqA#2 5'l+4q1}"]6o[&,-Dx:%Bwe$2"$@,Eq"=ʷeäg=Pq*x@q#?D>P3·P&zecqRVȶ[Bdԡ*l4̷7l /R7YpPD03]" &ELjAp ?ZOrӐPT =0#$ !2J0 [ = j-N8yQ'6Y/]2PL`?Sr䪷'kH>UScsXJ {683g8da(G3XtavqUr33&Η~l2rΐqSr U v&1 w-'F}~bWq GZe]Ǔm0E|62E C;-p$sZ O7ܔ0ܔ$7V'܄g?xgm,:Q2$ŝq)Oobwm5@s۽rֆ aޭj'^LdKM3ߊ'}Z4[ YR > p3L5lUp>~r_>"Nl;U(-.iaZ DG۰8Y&f<} q 6a9lJL\@RƂʩ|4׭kx^0?+gq_ h =?Dq3GU1,HIp|0\!aWFmB#! l(YC*=+]U7>S! ± @ 60ets zD ?:5!z-@41>]WnG1B|2XOyW"vh1AcT./L@E'>=J|_?s vu:i4 jOW4 ~ KYV3Xj1't2Y 'r+ :]P~Siה}a4\  @'~х-dk412@ )(@ݎWF{Fzn8TPT|B cgK9i JS\(i 227I5>>A5A25"*"AAH++5H">7A>!5ID! HH5"/DI2A>!"ŗE+A?**?B*#H"6Dӻ *,*0200!>"CH7CtAčFMzA|hdƍC6@hd`(R$ՐaE#J- ğK*a}9$IC !AȐK`R#?lRLj>$hC<12" k01#5dcXXZX$y݂˜AHXơ5Hl$#|b#{JQg ~P!m$ ӞRqh "H9Xc7 Ũƍw:프7^:pDu/Zg% <# z%+&I`E2 >5:CeE8MRxRDo;}B!xD&uNLT>AS $Ё K2``h2td#_uD|&uxgȐFT6Ow rH0sYh{Vv" Xs5b$^0'.5 /̕\WE@i‰|Hb@ Eb QМ-!ITWC@dr&adD'"$"biv jH`uQ2P8)]ER PA $AGz/<#c<׊,UMDuT<4Q%Kotd5DCkg;0F̘sȼ& cI<!`Hi *s6& &+v1voD*#-7H|PB\VICD F:$B Ed 3`ˈ@ / _%A@ n) FZhsɈc7˶PJ_$O#p7evxTM?C|%#= d? $Eպ 47P+Q%YJ?5BL 1 ; qp]#]"!8Ɋ\v+w>{N56&EiLsԤF5Y"kE;&lf^6P7o*7ep!S=l8r-(g9i9DҙNR[ Zw׵#lgn]q xAH혧zң=K 7‚0; Bv l ChCC|P j1rctЦe, z#'=>cf\2X`S㙡#Hą hS2d)0mZ `2$(#,!3A`Fb~&Ԡl6@fZlP,LU"jT nb;Ћ g>2̫Hгh(!v'?L"bHq00M!L% DIXhˆ% -Rr2 Uʨ 8dԟxA_W<0A%HxЭ‹XLn17%J1Mڕ ,- ZA{n rR)I 3 "4E)ԈzF;;$`( "ܕL AԦxIˆf" Tg̀TRxa`EYR!cLnX3ĸJkI`daų9&`B1Ń6`]O%@ElZM#EN EoIFI@y{aQ!t$)b]pKឥaSb24|LSĩ3rJi(.g%ğ?r;OL>p 6E4g9<`x""o+z|brd?hС;,ދiZHfC%<%$~"\+(A &YWDs{~8Xr<=dyF2HT]łߞ@T J#N} ^zVD{,Eb!$$NQ1za4TRػkLF "bC[S9ŖRX^;LX裺nF;-i&ȭ $]L"-3ljD1_} G@]%k♉uSFa1 &G[kzB[ɮ7iP<'**Вj%0)á+Ϩ]OD02y;!5|_=ң3€霉,]^]p3:C&;%|'HBtnlOsWwbyG |wp8w] 0 x$qe[xaCy+`yNyxyx.e 'pczMzd>$R5_G# `21t aJ6 f%/v vQ% lpR&2h> i%q+1 b 0`Hp~,pO ́C fIi ;Botueq #Mf"yrfP(F`KM=pe0\]F_K_!/ CT1;f-W& 0o `p Q8v v'H2>+%|_c%hj,%P8fShSX1)a!M5 ~#*L4qP!WvƐm" V pfU0p0# L# 7GO!):EW]zu v,A*QDB pE-å20#(uo-0Ɠ!0\PL"zBfJpa$9>F yVFZ{Dh1)9!p4h>8X.v{6)Tja>*6Mmw%Ù@Pp9O^l>Cuf'BPTQ8Q+QR}@L! p()IDGlSģq154W"/N)p/kB ~ hZ os@A"+ c>?4dn4!v5-P4+E@q CW$5s$sM-$R-B= )NYOiç"aV`q `"'`8$BsD*GWq -+Y6?s8ױrSr -Z0W_3@*A8 N]"ASi?Y~ayщq43!.=(d7ngpEU3'Q% Hq*`k\( r-.PI\l%#22Xu*g*`j BB 27&F *tN ЩưSMd AB;+J3.{r=iPVY@ !pZWR++t&&Q15D3?3 kA Xl:NƷ*;6'W4ICH<CY.È~#*rFG;0X-xA#b"!k$N?ಇBIZ7+: }H'*hZ}GJJpZ@J|WᰵеQ|Df g{)iжZ3s[{!k2+M4'󙍠:C4+ӹM50Z˺j -K,%/$QТ9& `1 `th &dJǀ`gi0Z8S@(T- 4kl3Pz3 * s;q 2t7c27- c|316 ?`+QAvzQV`ŀaeAL% @6BiI,ThZ.L- Q.YkeQ DKS I=§OXD9rNXO7KpTG!7 %P6Gx) %`&iBn'9t _ %ٱb5L''xtCtR0$D, wz23wKA֨O95-lPlqN$ܹfܒQr5 5؃_ȝPy&q4iC*=L0!b"# 3AsH}Bt@`vWK Y+( z0*V|0b&7 mM`~IR.3:4 ;'lBY)3bhv?s47 % y"*T콂A;0.YW($m]- 2":M^7P&!/ZE;ܭ><8rC *́Y.(0ŪmI$$}&7ҽpN,~6&1I k3 `v`0ukc{'0=@:Dg OXqq`#s-cO"Eq"b-`vrE/k4Osx` IsuA0 ~ |?P2R^PMY9_a/yR ~3sP$&ʯ1uxPSCXRrx("BrCITs#(#S"Xy!IDy㪨rt!A)c2)zQ$CBRTP}!1-stTbdQQTq14TsAI#d(DG L$")K4Qu#$AX$Q B($D$2Q #$=R Ş(Y씤F5Dd$HO sPO ƍ+*!hқ< C $0`$$Df@"H`Nnhqy"c\nxAħ%$8F;2 qN[C7Ŵ- a-ABŪczw\=GH0)",|LF;I@QɵR"35v,#I$K(w(4D &1&$S)HEZ2QEQ&7dQ&KyMPTOq GTX!Fd&hr IH` l,IЊxy@ !%HWdV"6ҢBPXb!/bUiŠ'͗ 4#pS;0\;J !TQ&! @ đA^d> 12ӂ\ϩ1<N'hRDwxaogШwL!C7&Y<"CDZDc@D.%4G?VNנ5VP%eH*ҁ't8)Zt V* aqB^݇]b viK %y9e@H2`">a"xH%SumdʂD-"x.l-<#▕)GfPxc 4ң#oXEA2 0TIsaTiEaVLvDQLp9B4sFc,Co0$`6P vQC= A0[a!9fV(.hF[ad9"b!n0ePnU32 S!pr8 3"=`g5_qt* K?k hJP6p*T6*ڔ(=0KAHHmOCedKPc-& ph9`E6re!{EHaHX =q:(Q"@4BxZsD%2!wFF I h,wgu "&ss @ dh0@JLD@2 D@M!1Q$ԡ rhDD>r%Wt@Uh,֥50GEph  H!0<0IvE"נFhPV%0% *!vvhH`}؍h)V`Fю!EC$hmH4!2!?v)CgY"#?Ґ> tp- #)%Y'+ْf0"PrE;=!tdA)`hbJcN P)@,uYѕ8ay0X,plp)tM%Q^m{1[hy)`hhbtG"n;''QIi#]vd63 E}L?>\2 hqHNrFW}{  q2x27hp7'o2<'0}7IC}0Ru2#1/(U" P070`$ `L@@ *PNmG%G0N^֦s,>ʍ"`"'Vc%F J&XR"}DF;3w/P]p+@GS`R.ӓY t< ]pkI}'YאBP PpX03i_0Q&oE?GGG J4w~JBjs]56EVY> R7SaNr$Mp 1Q$߲\jZ)`R.JaoSm@(7A?h^b!I$;arsw[`l1s"s[2\ Mp]O$O w{װLY*1Kv J.Vw h"$EH@qXyzh>" g]i(G4 `B?D)?yd6m bA2s#LoȀ=#$"a:QQ/w[S9X" J0 n(001t-s4"qG!YNGF !BYJnl"s/eiri&ʽ?d{x RE0à5C"@(Ws\]9I <# UڄXDqDP}PŅG@*W68),ˍh5T6 :f`(ROTm9:2 @$HgH".`O.Ȓ^hɁ$hV5(h ^Z,[ Tcld欬T`Ja0n~wDc]f^Ui/dj$ fy =XJaAG]rZ1Nȼ@  ? %Q/@@p Qp 4Ɏڨ 2_O0Vq/J^Sbo Dmy a  M-pOO]afհ\Ok[( 5VUE98 PSVA `BBɾ-ͅNITij9diН0|T `S'171eQ)]A>5>>A5!2F$ 9 &&#+AK7>** #?E$<%EJJ-?*KCC*A*767A>!B766 ,,7D//0FF>HH2D5""*H-EE6-*EBI2*<ᑡH E2Rd-H$#%L-[pBL0Tx" *`0^Ie̘(dlrL&Z lx T@h 7pȃ ySEaDG)0`fdCݐ⠌xCHI "$ajB (3CS(QBL7f2z$$I*HҙL)TC@F8` $x #"%HJ#>d$I"Xg=m bD "DޠAH#AɠaC!l =T^  >4:2 0KZe0!+>!cUT,&QFGd!%x=@zBu eCB1 0 X`P=ZvO H5g522h3#!% HB,IL-ZG3NA * @PhiT7Tx2Z$Q2[mրpgr[-sѭCuiwxxazͨǞ{w"3_} Eh Bx:Z2p胇 HE,vb3x9 YF"dP SRi%"h^Cd` h&Zm6 C$&Aw.?>JzhTBL ̌ixP7DX Un$T"H 2 1l ; _ !f A35CTTq3z0C *2!,DV^|_g VbC-HERF(r2MhҊ!TBeTAsca0 AELcaLh>D A4kC8eCADjD|y5-   ЁxbI@uд%2a!".h P h`F( V(1$x`AŵR%!@h@ 0)XHLbxB%,87 N?3΀>{AC# rHS+@DY<0EPy$I@ #| k(Gt1x! RhъВ1/ !"B.RR\a8( H<P&A 3h@i=X x `T5LU6A *܃'bTcun U@HzpC 5&&i݀ژ(`XbPUb' (1Zq 0|>D!r'>L.E'<G`x8C@_#A%_"(Y.AHB#5! 80`wi\*a ' KNruLXt M`&@a3 c/ iO| _ ;QA6>I1 :AD1F9=6D3 Jt 2 (-(ϩD4 M/UAt$[dyd$=#2E+NHaE H78v=?n `M>= g+T($A h;2 'pڲR&.Ѕ.<.~M`W0Y5[~= **<(Edʵ@\B5Y`ȋ@2!!0(4 %,=QmaBP A$(p\ D>CH`EǛcpS0 -n AGKKP0 (g<%P#U"jp D-?fo ڣ )g SLT" *=1#F1>` xp@G.  7=D33@DR`m" VE< I5c'~ FC+4A@ɓDcPTCH%Jd"*Blg^@1a&`56ɄIX#!Qd xt k&%!21spt9 7JIY<sGJU7HG|!f.sq =8^"`)ȋ c ._9,\<6")j":ѢPv-tWoRꮮճ[b7dgv=ojU%a!qGsWwdpw^U"zw(wGxm[xxGyryՐy z~SLd$P|ΤAzCz:0{'wY<&%|rG|Ʒ|`(T,``!@D prEE7ǕL LP!7B9 P9w -{SZ 2$mu<AV@`a{a-t? C5B` aXa*AU P9?ʂn.s Zh1Lqp `IqOO 1@ Hw,n4P%P@P#P$@ V$AD }5J`g pP!h$t7,ÂbwEeuWUr'?9v(-]7Q ]'͔(>  P9% D9CB@o@;jE `&E) Q@~V׈f*Iۣ³x0beu[)j=Ev{ ERu:w$V&Q#Xi$6ww= mFb&j-&\@/֪!Sw .-b; ,G &dpFGpr 2P=4¨A}d"P:KQ 0e%0 `3˜ڧņ1N4SD 7ʝ KQ"  V=6v0yiM˔pU.$=P0_VPq4&wcP2U(QXXU#/eՊ)==LVWps9i{G@;0`勺CFAQADXiVI0!ꢇ&5pPp 1-WW0,!8p &YL{`諾|+[4'6kBۿ$ <<H=̭ v~t ,$lEWOa¶ÿC[`î`U;\#]E?Rx@F_.AKJP<]0U|Yů1x` ƶe|iSl^oq̓<@]``}\1L;wSjȍ;%s9@A E ) QG[Qꆖ ,@o%2 oL\Tb(11)l0qL:VΣDuS`\[Ru=&J?=mWf<Xb (F\4Bh-a!JN u W3ppC#1`@0i1%F@C1 ELJ0UukeT\cPp}bb '@  }Dg GdQbܰ@ I:%!v.1W^(#+KH4qS4R[ ^Pfwmd<2a<#Q'l##^0MTE0J`u^ň^HeЊ"xm<!xWXmVsiv[f"d?2$SV+x#&sb۪R ͕GC #V[WPu4#Z±A0yrG Y -@gsJ ]%#MЧ  u } G Pv'"(UaVmde(ahuLvUx[w,O-p<%  |֞FFF8PjHvk=qam~0.#d *Ȥبm]<0Wj>" p{xEP*HTtÛK IZ5O@s%_3wK JZU0Q`Z-Q0dhBWvpeU㗧Ԋ"UܬD:Yu,a&v&i5׌)Rq=CuWA-z jo(#MrGbo)TtPPX8PĔXpsـy zIzrbdZ21T*;K[kZZptuud EE5FEF66VDFmvLE]= F֒,TսT$Ľ<䥲օU6 32)#Sl۱tqIF+Ķ pܺ)LoОl)M .]rFjT9e gۮhТ)]J]XZ,) M<):J:.db"*D9$ r%0u j[rzek†L Et1)q-y1/c}DI<5'H`D2I%` @,)taExdv)bDrEJ\Z0)Wq4TTUPm:AW`lKTtED u^9YRG`(^8#XTX!(ELM"aMPjbDFQr !ψM578dUĶG]!H[p]*V45EVdp!V<50XeB? f1  +L SRlcQx,%Oe,k"36RDd =PBH \ "€f,Qe?pl9!K.+jS #@g:i!Kӝ9*IO{sgπԛ}BP:i6(\acQjKHDRJs,TֲBMsSg=O %T*G%CRMih/Z[WM'e*Zu['k++jVyE _Z>jO(ai6INN(f Hs6++셙UaJW8 7]_?BJRdlƨP,"d(yU{  B(x 6WO:0ЃS$%0!u꠰cpǛQa zʓ.*XcX fx*H2~3PL 2aM@04 H4j  H,YN(_A9L2qNLg8+(  >W?yhS `@ jaI쀓/@gDhaab*LD h}x@ !a APۂn:%lϨT9d!C2U 4Izb$qϕ4bH kC6&&P ITZ䉲ABPa]U 3v(WL <(aX d`@'x(:\^6B[ \QnY_1%b:ɤ7M oj<&1&T58[@_-ˠ1. kyA#KX>ƛ Pe8܈Xօ(t:|]4hR0-h yԲÃJNmStjj3.D:$ Sϊ=;"E:MwPdA(cI rgW)`L a V{msd'Ts ٠*a`QP H ek2"(h P "3ya () | pice :: reste -> taquin.(x).(y) <- Canvas.create_image ~x:(x * tx) ~y:(y * ty) ~image:pice ~anchor:`Nw ~tags:["pice"] c; p := reste done done; let dplacer x y = let pice = taquin.(x).(y) in Canvas.coords_set c pice ~xys:[!trou_x * tx, !trou_y * ty]; Canvas.coords_set c trou ~xys:[x * tx, y * ty; tx, ty]; taquin.(!trou_x).(!trou_y) <- pice; taquin.(x).(y) <- trou; trou_x := x; trou_y := y in let jouer ei = let x = ei.ev_MouseX / tx and y = ei.ev_MouseY / ty in if x = !trou_x && (y = !trou_y - 1 || y = !trou_y + 1) || y = !trou_y && (x = !trou_x - 1 || x = !trou_x + 1) then dplacer x y in Canvas.bind ~events:[`ButtonPress] ~fields:[`MouseX; `MouseY] ~action:jouer c (`Tag "pice");; let rec permutation = function | [] -> [] | l -> let n = Random.int (List.length l) in let (lment, reste) = partage l n in lment :: permutation reste and partage l n = match l with | [] -> failwith "partage" | tte :: reste -> if n = 0 then (tte, reste) else let (lment, reste') = partage reste (n - 1) in (lment, tte :: reste');; let create_filled_text parent lines = let lnum = List.length lines and lwidth = List.fold_right (fun line max -> let l = String.length line in if l > max then l else max) lines 1 in let txtw = Text.create ~width:lwidth ~height:lnum parent in List.iter (fun line -> Text.insert ~index:(`End, []) ~text:line txtw; Text.insert ~index:(`End, []) ~text:"\n" txtw) lines; txtw;; let give_help parent lines () = let help_window = Toplevel.create parent in Wm.title_set help_window "Help"; let help_frame = Frame.create help_window in let help_txtw = create_filled_text help_frame lines in let quit_help () = destroy help_window in let ok_button = Button.create ~text:"Ok" ~command:quit_help help_frame in pack ~side:`Bottom [help_txtw]; pack ~side:`Bottom [ok_button ]; pack [help_frame];; let taquin nom_fichier nx ny = let fp = openTk () in Wm.title_set fp "Taquin"; let img = Imagephoto.create ~file:nom_fichier () in let c = Canvas.create ~background:`Black ~width:(Imagephoto.width img) ~height:(Imagephoto.height img) fp in let (tx, ty, pices) = dcoupe_image img nx ny in remplir_taquin c nx ny tx ty (permutation pices); pack [c]; let quit = Button.create ~text:"Quit" ~command:closeTk fp in let help_lines = ["Pour jouer, cliquer sur une des pices"; "entourant le trou"; ""; "To play, click on a part around the hole"] in let help = Button.create ~text:"Help" ~command:(give_help fp help_lines) fp in pack ~side:`Left ~fill:`X [quit] ; pack ~side:`Left ~fill:`X [help] ; mainLoop ();; if !Sys.interactive then () else begin taquin "Lambda2.back.gif" 4 4; exit 0 end;; mingw-ocaml/ocaml/otherlibs/labltk/examples_labltk/demo.ml0000644000175000017500000001335312124403241023354 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* Some CamlTk4 Demonstration by JPF *) (* First, open these modules for convenience *) open StdLabels open Tk (* Dummy let *) let _ = (* Initialize Tk *) let top = openTk () in (* Title setting *) Wm.title_set top "LablTk demo"; (* Base frame *) let base = Frame.create top in pack [base]; (* Menu bar *) let bar = Frame.create ~borderwidth:2 ~relief:`Raised base in pack ~fill:`X [bar]; (* Menu and Menubutton *) let meb = Menubutton.create ~text:"Menu" bar in let men = Menu.create meb in Menu.add_command ~label:"Quit" ~command:(fun () -> closeTk (); exit 0) men; Menubutton.configure ~menu:men meb; (* Frames *) let base2 = Frame.create base in let left = Frame.create base2 in let right = Frame.create base2 in pack [base2]; pack ~side:`Left [left; right]; (* Widgets on left and right *) (* Button *) let but = Button.create ~text:"Welcome to LablTk" left in (* Canvas *) let can = Canvas.create ~width:100 ~height:100 ~borderwidth:1 ~relief:`Sunken left in let oval = Canvas.create_oval ~x1: 10 ~y1: 10 ~x2: 90 ~y2: 90 ~fill: `Red can in ignore oval; (* Check button *) let che = Checkbutton.create ~text:"Check" left in (* Entry *) let ent = Entry.create ~width:10 left in (* Label *) let lab = Label.create ~text:"Welcome to LablTk" left in (* Listbox *) let lis = Listbox.create left in Listbox.insert lis ~index:`End ~texts:["This"; "is"; "Listbox"]; (* Message *) let mes = Message.create ~text: "Hello this is a message widget with very long text, but ..." left in (* Radio buttons *) let tv = Textvariable.create () in Textvariable.set tv "One"; let radf = Frame.create right in let rads = List.map ~f:(fun t -> Radiobutton.create ~text:t ~value:t ~variable:tv radf) ["One"; "Two"; "Three"] in (* Scale *) let sca = Scale.create ~label:"Scale" ~length:100 ~showvalue:true right in (* Text and scrollbar *) let texf = Frame.create right in (* Text *) let tex = Text.create ~width:20 ~height:8 texf in Text.insert ~index:(`End,[]) ~text:"This is a text widget." tex; (* Scrollbar *) let scr = Scrollbar.create texf in (* Text and Scrollbar widget link *) let scroll_link sb tx = Text.configure ~yscrollcommand:(Scrollbar.set sb) tx; Scrollbar.configure ~command:(Text.yview tx) sb in scroll_link scr tex; pack ~side:`Right ~fill:`Y [scr]; pack ~side:`Left ~fill:`Both ~expand:true [tex]; (* Pack them *) pack ~side:`Left [meb]; pack [coe but; coe can; coe che; coe ent; coe lab; coe lis; coe mes]; pack [coe radf; coe sca; coe texf]; pack rads; (* Toplevel *) let top2 = Toplevel.create top in Wm.title_set top2 "LablTk demo control"; let defcol = `Color "#dfdfdf" in let selcol = `Color "#ffdfdf" in let buttons = List.map ~f:(fun (w, t, c, a) -> let b = Button.create ~text:t ~command:c top2 in bind ~events:[`Enter] ~action:(fun _ -> a selcol) b; bind ~events:[`Leave] ~action:(fun _ -> a defcol) b; b) [coe bar, "Frame", (fun () -> ()), (fun background -> Frame.configure ~background bar); coe meb, "Menubutton", (fun () -> ()), (fun background -> Menubutton.configure ~background meb); coe but, "Button", (fun () -> ()), (fun background -> Button.configure ~background but); coe can, "Canvas", (fun () -> ()), (fun background -> Canvas.configure ~background can); coe che, "CheckButton", (fun () -> ()), (fun background -> Checkbutton.configure ~background che); coe ent, "Entry", (fun () -> ()), (fun background -> Entry.configure ~background ent); coe lab, "Label", (fun () -> ()), (fun background -> Label.configure ~background lab); coe lis, "Listbox", (fun () -> ()), (fun background -> Listbox.configure ~background lis); coe mes, "Message", (fun () -> ()), (fun background -> Message.configure ~background mes); coe radf, "Radiobox", (fun () -> ()), (fun background -> List.iter ~f:(fun b -> Radiobutton.configure ~background b) rads); coe sca, "Scale", (fun () -> ()), (fun background -> Scale.configure ~background sca); coe tex, "Text", (fun () -> ()), (fun background -> Text.configure ~background tex); coe scr, "Scrollbar", (fun () -> ()), (fun background -> Scrollbar.configure ~background scr) ] in pack ~fill:`X buttons; (* Main Loop *) Printexc.print mainLoop () mingw-ocaml/ocaml/otherlibs/labltk/examples_labltk/eyes.ml0000644000175000017500000000461712124403241023400 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) open Tk let _ = let top = openTk () in let fw = Frame.create top in pack [fw]; let c = Canvas.create ~width: 200 ~height: 200 fw in let create_eye cx cy wx wy ewx ewy bnd = let o2 = Canvas.create_oval ~x1:(cx - wx) ~y1:(cy - wy) ~x2:(cx + wx) ~y2:(cy + wy) ~outline: `Black ~width: 7 ~fill: `White c and o = Canvas.create_oval ~x1:(cx - ewx) ~y1:(cy - ewy) ~x2:(cx + ewx) ~y2:(cy + ewy) ~fill:`Black c in let curx = ref cx and cury = ref cy in bind ~events:[`Motion] ~extend:true ~fields:[`MouseX; `MouseY] ~action:(fun e -> let nx, ny = let xdiff = e.ev_MouseX - cx and ydiff = e.ev_MouseY - cy in let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. (float ydiff /. (float wy *. bnd)) ** 2.0) in if diff > 1.0 then truncate ((float xdiff) *. (1.0 /. diff)) + cx, truncate ((float ydiff) *. (1.0 /. diff)) + cy else e.ev_MouseX, e.ev_MouseY in Canvas.move c o ~x: (nx - !curx) ~y: (ny - !cury); curx := nx; cury := ny) c in create_eye 60 100 30 40 5 6 0.6; create_eye 140 100 30 40 5 6 0.6; pack [c] let _ = Printexc.print mainLoop () mingw-ocaml/ocaml/otherlibs/labltk/examples_labltk/lang.ml0000644000175000017500000000623012124403241023345 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* language encoding using UTF-8 *) open Tk let top = opentk () (* declare Tk that we use utf-8 to communicate *) (* problem: Text display is highly dependent on your font installation and configulation. The fonts with no-scale setting are selected only if the point sizes are exactly same??? *) let _ = Encoding.system_set "utf-8"; let l = Label.create top ~text: "???" in pack [l]; let t = Text.create top in pack [t]; let create_hello lang hello = let b = Button.create t ~text: lang ~command: (fun () -> Label.configure l ~text: hello) in Text.window_create t ~index: (`End,[]) ~window: b in List.iter (fun (lang, hello) -> create_hello lang hello) ["Amharic(አማርኛ)", "ሠላም"; "Arabic", "�����������"; "Croatian (Hrvatski)", "Bog (Bok), Dobar dan"; "Czech (česky)", "Dobrý den"; "Danish (Dansk)", "Hej, Goddag"; "English", "Hello"; "Esperanto", "Saluton"; "Estonian", "Tere, Tervist"; "FORTRAN", "PROGRAM"; "Finnish (Suomi)", "Hei"; "French (Français)", "Bonjour, Salut"; "German (Deutsch Nord)", "Guten Tag"; "German (Deutsch Süd)", "Grüß Gott"; "Greek (Ελληνικά)", "Γειά σας"; "Hebrew", "שלום"; "Italiano", "Ciao, Buon giorno"; "Maltese", "Ciao"; "Nederlands, Vlaams", "Hallo, Hoi, Goedendag"; "Norwegian (Norsk)", "Hei, God dag"; "Polish", "Cześć!"; "Russian (Русский)", "Здравствуйте!"; "Slovak", "Dobrý deň"; "Spanish (Español)", "¡Hola!"; "Swedish (Svenska)", "Hej, Goddag"; "Thai (�������)", "�������, ������"; "Tigrigna (ትግርኛ)", "ሰላማት"; "Turkish (Türkçe)", "Merhaba"; "Vietnamese (Tiếng Việt)", "Chào bạn"; "Japanese (日本語)", "こんにちは"; "Chinese (中文,普通话,汉语)", "你好"; "Cantonese (粵語,廣東話)", "早晨, 你好"; "Hangul (한글)", "안녕하세요, 안녕하십니까" ] ;; let _ = Printexc.print mainLoop () mingw-ocaml/ocaml/otherlibs/labltk/examples_labltk/hello.tcl0000755000175000017500000000010212124403241023674 0ustar tootstoots#!/usr/bin/wish button .hello -text "Hello, TclTk!" pack .hello mingw-ocaml/ocaml/otherlibs/labltk/support/0000755000175000017500000000000012124403241020436 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/support/cltkCaml.c0000644000175000017500000000550412124403241022340 0ustar tootstoots/***********************************************************************/ /* */ /* MLTk, Tcl/Tk interface of OCaml */ /* */ /* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file LICENSE found in the OCaml source tree. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include #include "camltk.h" value * tkerror_exn = NULL; value * handler_code = NULL; /* The Tcl command for evaluating callback in OCaml */ int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, int argc, CONST84 char **argv) { CheckInit(); /* Assumes no result */ Tcl_SetResult(interp, NULL, NULL); if (argc >= 2) { int id; if (Tcl_GetInt(interp, argv[1], &id) != TCL_OK) return TCL_ERROR; callback2(*handler_code,Val_int(id), copy_string_list(argc - 2,(char **)&argv[2])); /* Never fails (OCaml would have raised an exception) */ /* but result may have been set by callback */ return TCL_OK; } else return TCL_ERROR; } /* Callbacks are always of type _ -> unit, to simplify storage * But a callback can nevertheless return something (to Tcl) by * using the following. TCL_VOLATILE ensures that Tcl will make * a copy of the string */ CAMLprim value camltk_return (value v) { CheckInit(); Tcl_SetResult(cltclinterp, String_val(v), TCL_VOLATILE); return Val_unit; } /* Note: raise_with_string WILL copy the error message */ CAMLprim void tk_error(char *errmsg) { raise_with_string(*tkerror_exn, errmsg); } /* The initialisation of the C global variables pointing to OCaml values must be made accessible from OCaml, so that we are sure that it *always* takes place during loading of the protocol module */ CAMLprim value camltk_init(value v) { /* Initialize the OCaml pointers */ if (tkerror_exn == NULL) tkerror_exn = caml_named_value("tkerror"); if (handler_code == NULL) handler_code = caml_named_value("camlcb"); return Val_unit; } mingw-ocaml/ocaml/otherlibs/labltk/support/cltkEvent.c0000644000175000017500000000351412124403241022544 0ustar tootstoots/***********************************************************************/ /* */ /* MLTk, Tcl/Tk interface of OCaml */ /* */ /* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file LICENSE found in the OCaml source tree. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "camltk.h" CAMLprim value camltk_tk_mainloop(void) { CheckInit(); if (cltk_slave_mode) return Val_unit; if (!signal_events) { /* Initialise signal handling */ signal_events = 1; Tk_CreateTimerHandler(100, invoke_pending_caml_signals, NULL); } Tk_MainLoop(); return Val_unit; } /* Note: this HAS to be reported "as-is" in ML source */ static int event_flag_table[] = { TK_DONT_WAIT, TK_X_EVENTS, TK_FILE_EVENTS, TK_TIMER_EVENTS, TK_IDLE_EVENTS, TK_ALL_EVENTS }; CAMLprim value camltk_dooneevent(value flags) { int ret; CheckInit(); ret = Tk_DoOneEvent(convert_flag_list(flags, event_flag_table)); return Val_int(ret); } mingw-ocaml/ocaml/otherlibs/labltk/support/liblabltk.clib0000644000175000017500000000017012124403241023227 0ustar tootstootscltkCaml.o cltkUtf.o cltkEval.o cltkEvent.o cltkFile.o cltkMain.o cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o cltkImg.o mingw-ocaml/ocaml/otherlibs/labltk/support/cltkMain.c0000644000175000017500000001263012124403241022346 0ustar tootstoots/***********************************************************************/ /* */ /* MLTk, Tcl/Tk interface of OCaml */ /* */ /* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file LICENSE found in the OCaml source tree. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include #include #include #include #ifdef HAS_UNISTD #include /* for R_OK */ #endif #include "camltk.h" #ifndef R_OK #define R_OK 4 #endif /* * Dealing with signals: when a signal handler is defined in OCaml, * the actual execution of the signal handler upon reception of the * signal is delayed until we are sure we are out of the GC. * If a signal occurs during the MainLoop, we would have to wait * the next event for the handler to be invoked. * The following function will invoke a pending signal handler if any, * and we put in on a regular timer. */ #define SIGNAL_INTERVAL 300 int signal_events = 0; /* do we have a pending timer */ void invoke_pending_caml_signals (ClientData clientdata) { signal_events = 0; enter_blocking_section(); /* triggers signal handling */ /* Rearm timer */ Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL); signal_events = 1; leave_blocking_section(); } /* Now the real Tk stuff */ Tk_Window cltk_mainWindow; /* In slave mode, the interpreter *already* exists */ int cltk_slave_mode = 0; /* Initialisation, based on tkMain.c */ CAMLprim value camltk_opentk(value argv) { CAMLparam1(argv); CAMLlocal1(tmp); char *argv0; /* argv must contain argv[0], the application command name */ tmp = Val_unit; if ( argv == Val_int(0) ){ failwith("camltk_opentk: argv is empty"); } argv0 = String_val( Field( argv, 0 ) ); if (!cltk_slave_mode) { /* Create an interpreter, dies if error */ #if TCL_MAJOR_VERSION >= 8 Tcl_FindExecutable(String_val(argv0)); #endif cltclinterp = Tcl_CreateInterp(); { /* Register cltclinterp for use in other related extensions */ value *interp = caml_named_value("cltclinterp"); if (interp != NULL) Store_field(*interp,0,copy_nativeint((intnat)cltclinterp)); } if (Tcl_Init(cltclinterp) != TCL_OK) tk_error(Tcl_GetStringResult(cltclinterp)); Tcl_SetVar(cltclinterp, "argv0", String_val (argv0), TCL_GLOBAL_ONLY); { /* Sets argv */ int argc = 0; tmp = Field(argv, 1); /* starts from argv[1] */ while ( tmp != Val_int(0) ) { argc++; tmp = Field(tmp, 1); } if( argc != 0 ){ int i; char *args; char **tkargv; char argcstr[256]; /* string of argc */ tkargv = (char**)stat_alloc(sizeof( char* ) * argc ); tmp = Field(argv, 1); /* starts from argv[1] */ i = 0; while ( tmp != Val_int(0) ) { tkargv[i] = String_val(Field(tmp, 0)); tmp = Field(tmp, 1); i++; } sprintf( argcstr, "%d", argc ); Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY); args = Tcl_Merge(argc, (const char *const*)tkargv); /* args must be freed by Tcl_Free */ Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY); Tcl_Free(args); stat_free( tkargv ); } } if (Tk_Init(cltclinterp) != TCL_OK) tk_error(Tcl_GetStringResult(cltclinterp)); /* Retrieve the main window */ cltk_mainWindow = Tk_MainWindow(cltclinterp); if (NULL == cltk_mainWindow) tk_error(Tcl_GetStringResult(cltclinterp)); Tk_GeometryRequest(cltk_mainWindow,200,200); } /* Create the camlcallback command */ Tcl_CreateCommand(cltclinterp, CAMLCB, CamlCBCmd, (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL); /* This is required by "unknown" and thus autoload */ Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); /* Our hack for implementing break in callbacks */ Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY); /* Load the traditional rc file */ { char *home = getenv("HOME"); if (home != NULL) { char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2); f[0]='\0'; strcat(f, home); strcat(f, "/"); strcat(f, RCNAME); if (0 == access(f,R_OK)) if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) { stat_free(f); tk_error(Tcl_GetStringResult(cltclinterp)); }; stat_free(f); } } CAMLreturn(Val_unit); } CAMLprim value camltk_finalize(value unit) /* ML */ { Tcl_Finalize(); return Val_unit; } mingw-ocaml/ocaml/otherlibs/labltk/support/cltkDMain.c0000644000175000017500000001641112124403241022453 0ustar tootstoots/*************************************************************************/ /* */ /* OCaml LablTk library */ /* */ /* Francois Rouaix, Francois Pessaux and Jun Furuse */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file ../../../LICENSE. */ /* */ /*************************************************************************/ /* $Id$ */ #include #include #include #include #include "gc.h" #include "exec.h" #include "sys.h" #include "fail.h" #include "io.h" #include "mlvalues.h" #include "memory.h" #include "camltk.h" #ifndef O_BINARY #define O_BINARY 0 #endif /* * Dealing with signals: when a signal handler is defined in OCaml, * the actual execution of the signal handler upon reception of the * signal is delayed until we are sure we are out of the GC. * If a signal occurs during the MainLoop, we would have to wait * the next event for the handler to be invoked. * The following function will invoke a pending signal handler if any, * and we put in on a regular timer. */ #define SIGNAL_INTERVAL 300 int signal_events = 0; /* do we have a pending timer */ void invoke_pending_caml_signals (clientdata) ClientData clientdata; { signal_events = 0; enter_blocking_section(); /* triggers signal handling */ /* Rearm timer */ Tk_CreateTimerHandler(SIGNAL_INTERVAL, invoke_pending_caml_signals, NULL); signal_events = 1; leave_blocking_section(); } /* The following is taken from byterun/startup.c */ header_t atom_table[256]; code_t start_code; asize_t code_size; static void init_atoms() { int i; for(i = 0; i < 256; i++) atom_table[i] = Make_header(0, i, White); } static unsigned long read_size(p) unsigned char * p; { return ((unsigned long) p[0] << 24) + ((unsigned long) p[1] << 16) + ((unsigned long) p[2] << 8) + p[3]; } #define FILE_NOT_FOUND (-1) #define TRUNCATED_FILE (-2) #define BAD_MAGIC_NUM (-3) static int read_trailer(fd, trail) int fd; struct exec_trailer * trail; { char buffer[TRAILER_SIZE]; lseek(fd, (long) -TRAILER_SIZE, 2); if (read(fd, buffer, TRAILER_SIZE) < TRAILER_SIZE) return TRUNCATED_FILE; trail->code_size = read_size(buffer); trail->data_size = read_size(buffer+4); trail->symbol_size = read_size(buffer+8); trail->debug_size = read_size(buffer+12); if (strncmp(buffer + 16, EXEC_MAGIC, 12) == 0) return 0; else return BAD_MAGIC_NUM; } int attempt_open(name, trail, do_open_script) char ** name; struct exec_trailer * trail; int do_open_script; { char * truename; int fd; int err; char buf [2]; truename = searchpath(*name); if (truename == 0) truename = *name; else *name = truename; fd = open(truename, O_RDONLY | O_BINARY); if (fd == -1) return FILE_NOT_FOUND; if (!do_open_script){ err = read (fd, buf, 2); if (err < 2) { close(fd); return TRUNCATED_FILE; } if (buf [0] == '#' && buf [1] == '!') { close(fd); return BAD_MAGIC_NUM; } } err = read_trailer(fd, trail); if (err != 0) { close(fd); return err; } return fd; } /* Command for loading the bytecode file */ int CamlRunCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int fd; struct exec_trailer trail; struct longjmp_buffer raise_buf; struct channel * chan; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " foo.cmo args\"", (char *) NULL); return TCL_ERROR; } fd = attempt_open(&argv[1], &trail, 1); switch(fd) { case FILE_NOT_FOUND: fatal_error_arg("Fatal error: cannot find file %s\n", argv[1]); break; case TRUNCATED_FILE: case BAD_MAGIC_NUM: fatal_error_arg( "Fatal error: the file %s is not a bytecode executable file\n", argv[1]); break; } if (sigsetjmp(raise_buf.buf, 1) == 0) { external_raise = &raise_buf; lseek(fd, - (long) (TRAILER_SIZE + trail.code_size + trail.data_size + trail.symbol_size + trail.debug_size), 2); code_size = trail.code_size; start_code = (code_t) stat_alloc(code_size); if (read(fd, (char *) start_code, code_size) != code_size) fatal_error("Fatal error: truncated bytecode file.\n"); #ifdef ARCH_BIG_ENDIAN fixup_endianness(start_code, code_size); #endif chan = open_descr(fd); global_data = input_value(chan); close_channel(chan); /* Ensure that the globals are in the major heap. */ oldify(global_data, &global_data); sys_init(argv + 1); interprete(start_code, code_size); return TCL_OK; } else { Tcl_AppendResult(interp, "Caml program", argv[1], " raised exception \"", String_val(Field(Field(exn_bucket, 0), 0))); return TCL_ERROR; } } int CamlInvokeCmd(dummy /* Now the real Tk stuff */ Tk_Window cltk_mainWindow; #define RCNAME ".camltkrc" #define CAMLCB "camlcb" /* Initialisation of the dynamically loaded module */ int Caml_Init(interp) Tcl_Interp *interp; { cltclinterp = interp; /* Create the camlcallback command */ Tcl_CreateCommand(cltclinterp, CAMLCB, CamlCBCmd, (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL); /* This is required by "unknown" and thus autoload */ Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); /* Our hack for implementing break in callbacks */ Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY); /* Load the traditional rc file */ { char *home = getenv("HOME"); if (home != NULL) { char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2); f[0]='\0'; strcat(f, home); strcat(f, "/"); strcat(f, RCNAME); if (0 == access(f,R_OK)) if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) { stat_free(f); tk_error(Tcl_GetStringResult(cltclinterp)); }; stat_free(f); } } /* Initialisations from caml_main */ { int verbose_init = 0, percent_free_init = Percent_free_def; long minor_heap_init = Minor_heap_def, heap_chunk_init = Heap_chunk_def; /* Machine-dependent initialization of the floating-point hardware so that it behaves as much as possible as specified in IEEE */ init_ieee_floats(); init_gc (minor_heap_init, heap_chunk_init, percent_free_init, verbose_init); init_stack(); init_atoms(); } } mingw-ocaml/ocaml/otherlibs/labltk/support/fileevent.ml0000644000175000017500000000545512124403241022762 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) open Unix open Support open Protocol external add_file_input : file_descr -> cbid -> unit = "camltk_add_file_input" external rem_file_input : file_descr -> cbid -> unit = "camltk_rem_file_input" external add_file_output : file_descr -> cbid -> unit = "camltk_add_file_output" external rem_file_output : file_descr -> cbid -> unit = "camltk_rem_file_output" (* File input handlers *) let fd_table = Hashtbl.create 37 (* Avoid space leak in callback table *) let add_fileinput ~fd ~callback:f = let id = new_function_id () in Hashtbl.add callback_naming_table id (fun _ -> f()); Hashtbl.add fd_table (fd, 'r') id; if !Protocol.debug then begin Protocol.prerr_cbid id; prerr_endline " for fileinput" end; add_file_input fd id let remove_fileinput ~fd = try let id = Hashtbl.find fd_table (fd, 'r') in clear_callback id; Hashtbl.remove fd_table (fd, 'r'); if !Protocol.debug then begin prerr_string "clear "; Protocol.prerr_cbid id; prerr_endline " for fileinput" end; rem_file_input fd id with Not_found -> () let add_fileoutput ~fd ~callback:f = let id = new_function_id () in Hashtbl.add callback_naming_table id (fun _ -> f()); Hashtbl.add fd_table (fd, 'w') id; if !Protocol.debug then begin Protocol.prerr_cbid id; prerr_endline " for fileoutput" end; add_file_output fd id let remove_fileoutput ~fd = try let id = Hashtbl.find fd_table (fd, 'w') in clear_callback id; Hashtbl.remove fd_table (fd, 'w'); if !Protocol.debug then begin prerr_string "clear "; Protocol.prerr_cbid id; prerr_endline " for fileoutput" end; rem_file_output fd id with Not_found -> () mingw-ocaml/ocaml/otherlibs/labltk/support/tkwait.ml0000644000175000017500000000244012124403241022273 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) external internal_tracevis : string -> Protocol.cbid -> unit = "camltk_wait_vis" ;; external internal_tracedestroy : string -> Protocol.cbid -> unit = "camltk_wait_des" ;; mingw-ocaml/ocaml/otherlibs/labltk/support/slave.ml0000644000175000017500000000402012124403241022076 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* The code run on initialisation, in addition to normal Tk code * NOTE: camltk has not fully been initialised yet *) external tcl_eval : string -> string = "camltk_tcl_eval" let tcl_command s = ignore (tcl_eval s);; open Printf let dynload args = List.iter Dynlink.loadfile args (* Default modules include everything from let default_modules = [] *) (* [caml::run foo.cmo .. bar.cmo] is now available from Tcl *) let init () = Dynlink.init(); (* Make it unsafe by default, with everything available *) Dynlink.allow_unsafe_modules true; Dynlink.add_interfaces [] []; let s = register_callback Widget.dummy dynload in tcl_command (sprintf "proc caml::run {l} {camlcb %s l}" s) let _ = Printexc.print init () (* A typical master program would then * caml::run foo.cmo * # during initialisation, "foo" was registered as a tcl procedure * foo x y z * # proceed with some Tcl code calling foo *) mingw-ocaml/ocaml/otherlibs/labltk/support/rawwidget.mli0000644000175000017500000000741712124403241023147 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* Support for widget manipulations *) type 'a raw_widget (* widget is an abstract type *) type raw_any and button and canvas and checkbutton and entry and frame and label and listbox and menu and menubutton and message and radiobutton and scale and scrollbar and text and toplevel val forget_type : 'a raw_widget -> raw_any raw_widget val coe : 'a raw_widget -> raw_any raw_widget val default_toplevel : toplevel raw_widget (* [default_toplevel] is "." in Tk, the toplevel widget that is always existing during a Tk session. Destroying [default_toplevel] ends the main loop *) val atom : parent: 'a raw_widget -> name: string -> raw_any raw_widget (* [atom parent name] returns the widget [parent.name]. The widget is not created. Only its name is returned. In a given parent, there may only exist one children for a given name. This function should only be used to check the existence of a widget with a known name. It doesn't add the widget to the internal tables of CamlTk. *) val name : 'a raw_widget -> string (* [name w] returns the name (tk "path") of a widget *) (*--*) (* The following functions are used internally. There is normally no need for them in users programs *) val known_class : 'a raw_widget -> string (* [known_class w] returns the class of a widget (e.g. toplevel, frame), as known by the CamlTk interface. Not equivalent to "winfo w" in Tk. *) val dummy : raw_any raw_widget (* [dummy] is a widget used as context when we don't have any. It is *not* a real widget. *) val new_atom : parent:'a raw_widget -> ?name: string -> string -> 'b raw_widget val get_atom : string -> raw_any raw_widget (* [get_atom path] returns the widget with Tk path [path] *) val remove : 'a raw_widget -> unit (* [remove w] removes widget from the internal tables *) (* Subtypes tables *) val widget_any_table : string list val widget_button_table : string list val widget_canvas_table : string list val widget_checkbutton_table : string list val widget_entry_table : string list val widget_frame_table : string list val widget_label_table : string list val widget_listbox_table : string list val widget_menu_table : string list val widget_menubutton_table : string list val widget_message_table : string list val widget_radiobutton_table : string list val widget_scale_table : string list val widget_scrollbar_table : string list val widget_text_table : string list val widget_toplevel_table : string list val chk_sub : string -> 'a list -> 'a -> unit val check_class : 'a raw_widget -> string list -> unit (* Widget subtyping *) exception IllegalWidgetType of string (* Raised when widget command applied illegally*) mingw-ocaml/ocaml/otherlibs/labltk/support/Makefile0000644000175000017500000000633612124403241022106 0ustar tootstoots####################################################################### # # # MLTk, Tcl/Tk interface of OCaml # # # # Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # # projet Cristal, INRIA Rocquencourt # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique and Kyoto University. All rights reserved. # # This file is distributed under the terms of the GNU Library # # General Public License, with the special exception on linking # # described in file LICENSE found in the OCaml source tree. # # # ####################################################################### include Makefile.common all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \ textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo \ tkthread.cmo lib$(LIBNAME).$(A) opt: support.cmx rawwidget.cmx widget.cmx protocol.cmx \ textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx \ tkthread.cmx lib$(LIBNAME).$(A) COBJS=cltkCaml.$(O) cltkUtf.$(O) cltkEval.$(O) cltkEvent.$(O) \ cltkFile.$(O) cltkMain.$(O) cltkMisc.$(O) cltkTimer.$(O) \ cltkVar.$(O) cltkWait.$(O) cltkImg.$(O) CCFLAGS=-I../../../byterun $(TK_DEFS) $(SHAREDCCCOMPOPTS) COMPFLAGS=-I $(OTHERS)/win32unix -I $(OTHERS)/unix THFLAGS=-I $(OTHERS)/systhreads -I $(OTHERS)/threads TKLDOPTS=$(TK_LINK:%=-ldopt "%") lib$(LIBNAME).$(A): $(COBJS) $(MKLIB) -o $(LIBNAME) $(COBJS) $(TKLDOPTS) PUBMLI=fileevent.mli protocol.mli textvariable.mli timer.mli \ rawwidget.mli widget.mli PUB= $(PUBMLI) $(PUBMLI:.mli=.cmi) tkthread.mli tkthread.cmi tkthread.cmo install: if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi cp $(PUB) lib$(LIBNAME).$(A) $(INSTALLDIR) cd $(INSTALLDIR); $(RANLIB) lib$(LIBNAME).$(A) cd $(INSTALLDIR); chmod 644 $(PUB) lib$(LIBNAME).$(A) if test -f dll$(LIBNAME)$(EXT_DLL); then \ cp dll$(LIBNAME)$(EXT_DLL) $(STUBLIBDIR)/; fi installopt: @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi cp $(PUBMLI:.mli=.cmx) $(INSTALLDIR) if test -f tkthread.$(O); then \ cp tkthread.cmx tkthread.$(O) $(INSTALLDIR); \ chmod 644 $(INSTALLDIR)/tkthread.cmx $(INSTALLDIR)/tkthread.$(O); \ fi clean: rm -f *.cm* *.o *.a *.so *.obj *.lib *.dll *.exp .SUFFIXES: .SUFFIXES: .mli .ml .cmi .cmo .cmx .mlp .c .$(O) .mli.cmi: $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmo: $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< .c.$(O): $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< tkthread.cmi: tkthread.mli $(CAMLCOMP) $(COMPFLAGS) $(THFLAGS) $< tkthread.cmo: tkthread.ml $(CAMLCOMP) $(COMPFLAGS) $(THFLAGS) $< tkthread.cmx: tkthread.ml if test -f $(OTHERS)/systhreads/threads.cmxa; then \ $(CAMLOPT) -c $(COMPFLAGS) $(THFLAGS) $< ; \ fi depend: $(CAMLDEP) *.mli *.ml > .depend $(COBJS): $(TOPDIR)/config/Makefile camltk.h include .depend mingw-ocaml/ocaml/otherlibs/labltk/support/fileevent.mli0000644000175000017500000000256612124403241023133 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) open Unix val add_fileinput : fd:file_descr -> callback:(unit -> unit) -> unit val remove_fileinput: fd:file_descr -> unit val add_fileoutput : fd:file_descr -> callback:(unit -> unit) -> unit val remove_fileoutput: fd:file_descr -> unit (* see [tk] module *) mingw-ocaml/ocaml/otherlibs/labltk/support/cltkTimer.c0000644000175000017500000000334212124403241022542 0ustar tootstoots/***********************************************************************/ /* */ /* MLTk, Tcl/Tk interface of OCaml */ /* */ /* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file LICENSE found in the OCaml source tree. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "camltk.h" /* Basically the same thing as FileProc */ void TimerProc (ClientData clientdata) { callback2(*handler_code,Val_long(clientdata),Val_int(0)); } CAMLprim value camltk_add_timer(value milli, value cbid) { CheckInit(); /* look at tkEvent.c , Tk_Token is an int */ return (Val_int(Tcl_CreateTimerHandler(Int_val(milli), TimerProc, (ClientData) (Long_val(cbid))))); } CAMLprim value camltk_rem_timer(value token) { Tcl_DeleteTimerHandler((Tcl_TimerToken) Long_val(token)); return Val_unit; } mingw-ocaml/ocaml/otherlibs/labltk/support/timer.ml0000644000175000017500000000425112124403241022112 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* Timers *) open Support open Protocol type tkTimer = int external internal_add_timer : int -> cbid -> tkTimer = "camltk_add_timer" external internal_rem_timer : tkTimer -> unit = "camltk_rem_timer" type t = tkTimer * cbid (* the token and the cb id *) (* A timer is used only once, so we must clean the callback table *) let add ~ms ~callback = if !Protocol.debug then begin prerr_string "Timer.add "; flush stderr; end; let id = new_function_id () in if !Protocol.debug then begin prerr_string "id="; prerr_cbid id; flush stderr; end; let wrapped _ = clear_callback id; (* do it first in case f raises exception *) callback() in Hashtbl.add callback_naming_table id wrapped; let t = internal_add_timer ms id in if !Protocol.debug then begin prerr_endline " done" end; t,id let set ~ms ~callback = ignore (add ~ms ~callback);; (* If the timer has never been used, there is a small space leak in the C heap, where a copy of id has been stored *) let remove (tkTimer, id) = internal_rem_timer tkTimer; clear_callback id mingw-ocaml/ocaml/otherlibs/labltk/support/camltk.h0000644000175000017500000000474612124403241022075 0ustar tootstoots/*************************************************************************/ /* */ /* OCaml LablTk library */ /* */ /* Francois Rouaix, Francois Pessaux and Jun Furuse */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file ../../../LICENSE. */ /* */ /*************************************************************************/ /* $Id$ */ #if defined(_WIN32) && defined(CAML_DLL) && defined(IN_CAMLTKSUPPORT) #define CAMLTKextern CAMLexport #else #define CAMLTKextern CAMLextern #endif /* compatibility with earlier versions of Tcl/Tk */ #ifndef CONST84 #define CONST84 #endif /* if Tcl_GetStringResult is not defined, we use interp->result */ #ifndef Tcl_GetStringResult # define Tcl_GetStringResult(interp) (interp->result) #endif /* cltkMisc.c */ /* copy an OCaml string to the C heap. Must be deallocated with stat_free */ extern char *string_to_c(value s); /* cltkUtf.c */ extern value tcl_string_to_caml( char * ); extern char * caml_string_to_tcl( value ); /* cltkEval.c */ CAMLTKextern Tcl_Interp *cltclinterp; /* The Tcl interpretor */ extern value copy_string_list(int argc, char **argv); /* cltkCaml.c */ /* pointers to OCaml values */ extern value *tkerror_exn; extern value *handler_code; extern int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, int argc, CONST84 char *argv[]); CAMLTKextern void tk_error(char * errmsg) Noreturn; /* cltkMain.c */ extern int signal_events; extern void invoke_pending_caml_signals(ClientData clientdata); extern Tk_Window cltk_mainWindow; extern int cltk_slave_mode; /* check that initialisations took place */ #define CheckInit() if (!cltclinterp) tk_error("Tcl/Tk not initialised") #define RCNAME ".camltkrc" #define CAMLCB "camlcb" mingw-ocaml/ocaml/otherlibs/labltk/support/camltkwrap.mli0000644000175000017500000002132512124403241023311 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) module Widget : sig type widget = Widget.any Widget.widget (* widget is an abstract type *) val default_toplevel : widget (* [default_toplevel] is "." in Tk, the toplevel widget that is always existing during a Tk session. Destroying [default_toplevel] ends the main loop *) val atom : parent: widget -> name: string -> widget (* [atom parent name] returns the widget [parent.name]. The widget is not created. Only its name is returned. In a given parent, there may only exist one children for a given name. This function should only be used to check the existence of a widget with a known name. It doesn't add the widget to the internal tables of CamlTk. *) val name : widget -> string (* [name w] returns the name (tk "path") of a widget *) (*--*) (* The following functions are used internally. There is normally no need for them in users programs *) val known_class : widget -> string (* [known_class w] returns the class of a widget (e.g. toplevel, frame), as known by the CamlTk interface. Not equivalent to "winfo w" in Tk. *) val dummy : widget (* [dummy] is a widget used as context when we don't have any. It is *not* a real widget. *) val new_atom : parent: widget -> ?name: string -> string -> widget (* incompatible with the classic camltk *) val get_atom : string -> widget (* [get_atom path] returns the widget with Tk path [path] *) val remove : widget -> unit (* [remove w] removes widget from the internal tables *) (* Subtypes tables *) val widget_any_table : string list val widget_button_table : string list val widget_canvas_table : string list val widget_checkbutton_table : string list val widget_entry_table : string list val widget_frame_table : string list val widget_label_table : string list val widget_listbox_table : string list val widget_menu_table : string list val widget_menubutton_table : string list val widget_message_table : string list val widget_radiobutton_table : string list val widget_scale_table : string list val widget_scrollbar_table : string list val widget_text_table : string list val widget_toplevel_table : string list val chk_sub : string -> 'a list -> 'a -> unit val check_class : widget -> string list -> unit (* Widget subtyping *) exception IllegalWidgetType of string (* Raised when widget command applied illegally*) (* this function is not used, but introduced for the compatibility with labltk. useless for camltk users *) val coe : 'a Widget.widget -> Widget.any Widget.widget end module Protocol : sig open Widget (* Lower level interface *) exception TkError of string (* Raised by the communication functions *) val debug : bool ref (* When set to true, displays approximation of intermediate Tcl code *) type tkArgs = TkToken of string | TkTokenList of tkArgs list (* to be expanded *) | TkQuote of tkArgs (* mapped to Tcl list *) (* Misc *) external splitlist : string -> string list = "camltk_splitlist" val add_destroy_hook : (widget -> unit) -> unit (* Opening, closing, and mainloop *) val default_display : unit -> string val opentk : unit -> widget (* The basic initialization function. [opentk ()] parses automatically the command line options and use the tk related options in them such as "-display localhost:0" to initialize Tk applications. Consult wish manpage about the supported options. *) val keywords : (string * Arg.spec * string) list (* Command line parsing specification for Arg.parse, which contains the standard Tcl/Tk command line options such as "-display" and "-name". These Tk command line options are used by opentk *) val opentk_with_args : string list -> widget (* [opentk_with_args argv] invokes [opentk] with the tk related command line options given by [argv] to the executable program. *) val openTk : ?display:string -> ?clas:string -> unit -> widget (* [openTk ~display:display ~clas:clas ()] is equivalent to [opentk ["-display"; display; "-name"; clas]] *) (* Legacy opentk functions *) val openTkClass: string -> widget (* [openTkClass class] is equivalent to [opentk ["-name"; class]] *) val openTkDisplayClass: string -> string -> widget (* [openTkDisplayClass disp class] is equivalent to [opentk ["-display"; disp; "-name"; class]] *) val closeTk : unit -> unit val finalizeTk : unit -> unit (* Finalize tcl/tk before exiting. This function will be automatically called when you call [Pervasives.exit ()] *) val mainLoop : unit -> unit (* Direct evaluation of tcl code *) val tkEval : tkArgs array -> string val tkCommand : tkArgs array -> unit (* Returning a value from a Tcl callback *) val tkreturn: string -> unit (* Callbacks: this is private *) type cbid = Protocol.cbid type callback_buffer = string list (* Buffer for reading callback arguments *) val callback_naming_table : (cbid, callback_buffer -> unit) Hashtbl.t (* CAMLTK val callback_memo_table : (widget, cbid) Hashtbl.t *) val callback_memo_table : (widget, cbid) Hashtbl.t (* Exported for debug purposes only. Don't use them unless you know what you are doing *) val new_function_id : unit -> cbid val string_of_cbid : cbid -> string val register_callback : widget -> callback:(callback_buffer -> unit) -> string (* Callback support *) val clear_callback : cbid -> unit (* Remove a given callback from the table *) val remove_callbacks : widget -> unit (* Clean up callbacks associated to widget. Must be used only when the Destroy event is bind by the user and masks the default Destroy event binding *) val cTKtoCAMLwidget : string -> widget val cCAMLtoTKwidget : string list -> widget -> tkArgs val register : string -> callback:(callback_buffer -> unit) -> unit (*-*) val prerr_cbid : cbid -> unit end module Textvariable : sig open Widget open Protocol type textVariable = Textvariable.textVariable (* TextVariable is an abstract type *) val create : ?on: widget -> unit -> textVariable (* Allocation of a textVariable with lifetime associated to widget if a widget is specified *) val create_temporary : widget -> textVariable (* for backward compatibility [create_temporary w] is equivalent to [create ~on:w ()] *) val set : textVariable -> string -> unit (* Setting the val of a textVariable *) val get : textVariable -> string (* Reading the val of a textVariable *) val name : textVariable -> string (* Its tcl name *) val cCAMLtoTKtextVariable : textVariable -> tkArgs (* Internal conversion function *) val handle : textVariable -> (unit -> unit) -> unit (* Callbacks on variable modifications *) val coerce : string -> textVariable (*-*) val free : textVariable -> unit end module Fileevent : sig open Unix val add_fileinput : file_descr -> (unit -> unit) -> unit val remove_fileinput: file_descr -> unit val add_fileoutput : file_descr -> (unit -> unit) -> unit val remove_fileoutput: file_descr -> unit (* see [tk] module *) end module Timer : sig type t = Timer.t val add : int -> (unit -> unit) -> t val set : int -> (unit -> unit) -> unit val remove : t -> unit end (* Tkwait exists, but is not used in support module Tkwait : sig val internal_tracevis : string -> Protocol.cbid -> unit val internal_tracedestroy : string -> Protocol.cbid -> unit end *) mingw-ocaml/ocaml/otherlibs/labltk/support/Makefile.nt0000644000175000017500000000002112124403241022507 0ustar tootstootsinclude Makefile mingw-ocaml/ocaml/otherlibs/labltk/support/camltkwrap.ml0000644000175000017500000000510312124403241023134 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) module Widget = struct include Rawwidget type widget = raw_any raw_widget let default_toplevel = coe default_toplevel end module Protocol = struct open Widget include Protocol let opentk () = coe (opentk ()) let opentk_with_args args = coe (opentk_with_args args) let openTk ?display ?clas () = coe (openTk ?display ?clas ()) let cCAMLtoTKwidget table w = Widget.check_class w table; (* we need run time type check of widgets *) TkToken (Widget.name w) (* backward compatibility *) let openTkClass s = coe (openTkClass s) let openTkDisplayClass disp c = coe (openTkDisplayClass disp c) end module Textvariable = struct open Textvariable type textVariable = Textvariable.textVariable let create = create let set = set let get = get let name = name let cCAMLtoTKtextVariable = cCAMLtoTKtextVariable let handle tv cbk = handle tv ~callback:cbk let coerce = coerce (*-*) let free = free (* backward compatibility *) let create_temporary w = create ~on: w () end module Fileevent = struct open Fileevent let add_fileinput fd callback = add_fileinput ~fd ~callback let remove_fileinput fd = remove_fileinput ~fd let add_fileoutput fd callback = add_fileoutput ~fd ~callback let remove_fileoutput fd = remove_fileoutput ~fd end module Timer = struct open Timer type t = Timer.t let add ms callback = add ~ms ~callback let set ms callback = set ~ms ~callback let remove = remove end (* Not compiled in support module Tkwait = Tkwait *) mingw-ocaml/ocaml/otherlibs/labltk/support/Makefile.common0000644000175000017500000000344312124403241023371 0ustar tootstoots####################################################################### # # # MLTk, Tcl/Tk interface of OCaml # # # # Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # # projet Cristal, INRIA Rocquencourt # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique and Kyoto University. All rights reserved. # # This file is distributed under the terms of the GNU Library # # General Public License, with the special exception on linking # # described in file LICENSE found in the OCaml source tree. # # # ####################################################################### ## Paths are relative to subdirectories ## Where you compiled OCaml TOPDIR=../../.. ## Path to the otherlibs subdirectory OTHERS=$(TOPDIR)/otherlibs LIBNAME=labltk include $(TOPDIR)/config/Makefile INSTALLDIR=$(LIBDIR)/$(LIBNAME) ## Tools from the OCaml distribution CAMLRUN=$(TOPDIR)/boot/ocamlrun CAMLC=$(TOPDIR)/ocamlcomp.sh CAMLOPT=$(TOPDIR)/ocamlcompopt.sh CAMLCB=$(CAMLRUN) $(TOPDIR)/ocamlc CAMLOPTB=$(CAMLRUN) $(TOPDIR)/ocamlopt CAMLCOMP=$(CAMLC) -c -warn-error A CAMLYACC=$(TOPDIR)/boot/ocamlyacc -v CAMLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex CAMLLIBR=$(CAMLC) -a CAMLDEP=$(CAMLRUN) $(TOPDIR)/tools/ocamldep COMPFLAGS=-g LINKFLAGS= CAMLOPTLIBR=$(CAMLOPT) -a MKLIB=$(CAMLRUN) $(TOPDIR)/tools/ocamlmklib CAMLRUNGEN=../../boot/ocamlrun mingw-ocaml/ocaml/otherlibs/labltk/support/timer.mli0000644000175000017500000000234712124403241022267 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) type t val add : ms:int -> callback:(unit -> unit) -> t val set : ms:int -> callback:(unit -> unit) -> unit val remove : t -> unit mingw-ocaml/ocaml/otherlibs/labltk/support/cltkVar.c0000644000175000017500000001032112124403241022205 0ustar tootstoots/***********************************************************************/ /* */ /* MLTk, Tcl/Tk interface of OCaml */ /* */ /* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file LICENSE found in the OCaml source tree. */ /* */ /***********************************************************************/ /* $Id$ */ /* Alternative to tkwait variable */ #include #include #include #include #include #include #include #include "camltk.h" CAMLprim value camltk_getvar(value var) { char *s; char *stable_var = NULL; CheckInit(); stable_var = string_to_c(var); s = (char *)Tcl_GetVar(cltclinterp,stable_var, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); stat_free(stable_var); if (s == NULL) tk_error(Tcl_GetStringResult(cltclinterp)); else return(tcl_string_to_caml(s)); } CAMLprim value camltk_setvar(value var, value contents) { char *s; char *stable_var = NULL; char *utf_contents; CheckInit(); /* SetVar makes a copy of the contents. */ /* In case we have write traces in OCaml, it's better to make sure that var doesn't move... */ stable_var = string_to_c(var); utf_contents = caml_string_to_tcl(contents); s = (char *)Tcl_SetVar(cltclinterp,stable_var, utf_contents, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); stat_free(stable_var); if( s == utf_contents ){ tk_error("camltk_setvar: Tcl_SetVar returned strange result. Call the author of mlTk!"); } stat_free(utf_contents); if (s == NULL) tk_error(Tcl_GetStringResult(cltclinterp)); else return(Val_unit); } /* The appropriate type is typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *part1, char *part2, int flags)); */ static char * tracevar(clientdata, interp, name1, name2, flags) ClientData clientdata; Tcl_Interp *interp; /* Interpreter containing variable. */ char *name1; /* Name of variable. */ char *name2; /* Second part of variable name. */ int flags; /* Information about what happened. */ { Tcl_UntraceVar2(interp, name1, name2, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, tracevar, clientdata); callback2(*handler_code,Val_int(clientdata),Val_unit); return (char *)NULL; } /* Sets up a callback upon modification of a variable */ CAMLprim value camltk_trace_var(value var, value cbid) { char *cvar = NULL; CheckInit(); /* Make a copy of var, since Tcl will modify it in place, and we * don't trust that much what it will do here */ cvar = string_to_c(var); if (Tcl_TraceVar(cltclinterp, cvar, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, tracevar, (ClientData) (Long_val(cbid))) != TCL_OK) { stat_free(cvar); tk_error(Tcl_GetStringResult(cltclinterp)); }; stat_free(cvar); return Val_unit; } CAMLprim value camltk_untrace_var(value var, value cbid) { char *cvar = NULL; CheckInit(); /* Make a copy of var, since Tcl will modify it in place, and we * don't trust that much what it will do here */ cvar = string_to_c(var); Tcl_UntraceVar(cltclinterp, cvar, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, tracevar, (ClientData) (Long_val(cbid))); stat_free(cvar); return Val_unit; } mingw-ocaml/ocaml/otherlibs/labltk/support/protocol.mli0000644000175000017500000001116712124403241023010 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) open Widget (* Lower level interface *) exception TkError of string (* Raised by the communication functions *) val debug : bool ref (* When set to true, displays approximation of intermediate Tcl code *) type tkArgs = TkToken of string | TkTokenList of tkArgs list (* to be expanded *) | TkQuote of tkArgs (* mapped to Tcl list *) (* Misc *) external splitlist : string -> string list = "camltk_splitlist" val add_destroy_hook : (any widget -> unit) -> unit (* Opening, closing, and mainloop *) val default_display : unit -> string val opentk : unit -> toplevel widget (* The basic initialization function. *) val keywords : (string * Arg.spec * string) list (* Command line parsing specification for Arg.parse, which contains the standard Tcl/Tk command line options such as "-display" and "-name". Add [keywords] to a [Arg.parse] call, then call [opentk]. Then [opentk] can make use of these command line options to initiate applications. *) val opentk_with_args : string list -> toplevel widget (* [opentk_with_args] is a lower level interface to initiate Tcl/Tk applications. [opentk_with_args argv] initializes Tcl/Tk with the command line options given by [argv] *) val openTk : ?display:string -> ?clas:string -> unit -> toplevel widget (* [openTk ~display:display ~clas:clas ()] is equivalent to [opentk_with_args ["-display"; display; "-name"; clas]] *) (* Legacy opentk functions *) val openTkClass: string -> toplevel widget (* [openTkClass class] is equivalent to [opentk ["-name"; class]] *) val openTkDisplayClass: string -> string -> toplevel widget (* [openTkDisplayClass disp class] is equivalent to [opentk ["-display"; disp; "-name"; class]] *) val closeTk : unit -> unit val finalizeTk : unit -> unit (* Finalize tcl/tk before exiting. This function will be automatically called when you call [Pervasives.exit ()] *) val mainLoop : unit -> unit (* Start the event loop *) type event_flag = DONT_WAIT | X_EVENTS | FILE_EVENTS | TIMER_EVENTS | IDLE_EVENTS | ALL_EVENTS val do_one_event : event_flag list -> bool (* Process a single event *) val do_pending : unit -> unit (* Process all pending events, without waiting. This lets you use Tk from the toplevel, for instance. *) (* Direct evaluation of tcl code *) val tkEval : tkArgs array -> string val tkCommand : tkArgs array -> unit (* Returning a value from a Tcl callback *) val tkreturn: string -> unit (* Callbacks: this is private *) type cbid type callback_buffer = string list (* Buffer for reading callback arguments *) val callback_naming_table : (cbid, callback_buffer -> unit) Hashtbl.t val callback_memo_table : (any widget, cbid) Hashtbl.t (* Exported for debug purposes only. Don't use them unless you know what you are doing *) val new_function_id : unit -> cbid val string_of_cbid : cbid -> string val register_callback : 'a widget -> callback:(callback_buffer -> unit) -> string (* Callback support *) val clear_callback : cbid -> unit (* Remove a given callback from the table *) val remove_callbacks : 'a widget -> unit (* Clean up callbacks associated to widget. Must be used only when the Destroy event is bind by the user and masks the default Destroy event binding *) val cTKtoCAMLwidget : string -> any widget val cCAMLtoTKwidget : 'a widget -> tkArgs val register : string -> callback:(callback_buffer -> unit) -> unit (*-*) val prerr_cbid : cbid -> unit mingw-ocaml/ocaml/otherlibs/labltk/support/byte.itarget0000644000175000017500000000016712124403241022766 0ustar tootstootssupport.cmo rawwidget.cmo widget.cmo protocol.cmo textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo tkthread.cmo mingw-ocaml/ocaml/otherlibs/labltk/support/cltkImg.c0000644000175000017500000001016312124403241022175 0ustar tootstoots/***********************************************************************/ /* */ /* MLTk, Tcl/Tk interface of OCaml */ /* */ /* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file LICENSE found in the OCaml source tree. */ /* */ /***********************************************************************/ #include #include #include #include #include #include #include "camltk.h" /* * Pixmap manipulation from OCaml : get the pixmap from an arbitrary photo * image, and put it back in some (possibly other) image. * TODO: other blits * We use the same format of "internal" pixmap data as in Tk, that is * 24 bits per pixel */ CAMLprim value camltk_getimgdata (value imgname) /* ML */ { CAMLparam1(imgname); CAMLlocal1(res); Tk_PhotoHandle ph; Tk_PhotoImageBlock pib; int code,size; #if (TK_MAJOR_VERSION < 8) if (NULL == (ph = Tk_FindPhoto(String_val(imgname)))) tk_error("no such image"); #else if (NULL == (ph = Tk_FindPhoto(cltclinterp, String_val(imgname)))) tk_error("no such image"); #endif code = Tk_PhotoGetImage(ph,&pib); /* never fails ? */ size = pib.width * pib.height * pib.pixelSize; res = alloc_string(size); /* no holes, default format ? */ if ((pib.pixelSize == 3) && (pib.pitch == (pib.width * pib.pixelSize)) && (pib.offset[0] == 0) && (pib.offset[1] == 1) && (pib.offset[2] == 2)) { memcpy(pib.pixelPtr, String_val(res),size); CAMLreturn(res); } else { int y; /* varies from 0 to height - 1 */ int yoffs = 0; /* byte offset of line in src */ int yidx = 0; /* byte offset of line in dst */ for (y=0; y= 5 || TK_MAJOR_VERSION > 8) NULL, #endif ph,&pib,Int_val(x),Int_val(y),Int_val(w),Int_val(h) #if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 4 || TK_MAJOR_VERSION > 8) , TK_PHOTO_COMPOSITE_SET #endif ); } CAMLprim void camltk_setimgdata_bytecode(argv,argn) value *argv; int argn; { camltk_setimgdata_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } mingw-ocaml/ocaml/otherlibs/labltk/support/widget.ml0000644000175000017500000000242112124403241022252 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* Hack to permit having the different data type with the same name [widget] for CamlTk and LablTk. *) include Rawwidget type 'a widget = 'a raw_widget type any = raw_any mingw-ocaml/ocaml/otherlibs/labltk/support/cltkEval.c0000644000175000017500000001577312124403241022364 0ustar tootstoots/***********************************************************************/ /* */ /* MLTk, Tcl/Tk interface of OCaml */ /* */ /* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file LICENSE found in the OCaml source tree. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include #include #ifdef HAS_UNISTD #include #endif #include "camltk.h" /* The Tcl interpretor */ Tcl_Interp *cltclinterp = NULL; /* Copy a list of strings from the C heap to OCaml */ value copy_string_list(int argc, char **argv) { CAMLparam0(); CAMLlocal3( res, oldres, str ); int i; oldres = Val_unit; str = Val_unit; res = Val_int(0); /* [] */ for (i = argc-1; i >= 0; i--) { oldres = res; str = tcl_string_to_caml(argv[i]); res = alloc(2, 0); Field(res, 0) = str; Field(res, 1) = oldres; } CAMLreturn(res); } /* * Calling Tcl from OCaml * this version works on an arbitrary Tcl command, * and does parsing and substitution */ CAMLprim value camltk_tcl_eval(value str) { int code; char *cmd = NULL; CheckInit(); /* Tcl_Eval may write to its argument, so we take a copy * If the evaluation raises an OCaml exception, we have a space * leak */ Tcl_ResetResult(cltclinterp); cmd = caml_string_to_tcl(str); code = Tcl_Eval(cltclinterp, cmd); stat_free(cmd); switch (code) { case TCL_OK: return tcl_string_to_caml(Tcl_GetStringResult(cltclinterp)); case TCL_ERROR: tk_error(Tcl_GetStringResult(cltclinterp)); default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ tk_error("bad tcl result"); } } /* * Calling Tcl from OCaml * direct call, argument is TkArgs vect type TkArgs = TkToken of string | TkTokenList of TkArgs list (* to be expanded *) | TkQuote of TkArgs (* mapped to Tcl list *) * NO PARSING, NO SUBSTITUTION */ /* * Compute the size of the argument (of type TkArgs). * TkTokenList must be expanded, * TkQuote count for one. */ int argv_size(value v) { switch (Tag_val(v)) { case 0: /* TkToken */ return 1; case 1: /* TkTokenList */ { int n = 0; value l; for (l=Field(v,0), n=0; Is_block(l); l=Field(l,1)) n+=argv_size(Field(l,0)); return n; } case 2: /* TkQuote */ return 1; default: tk_error("argv_size: illegal tag"); } } /* Fill a preallocated vector arguments, doing expansion and all. * Assumes Tcl will * not tamper with our strings * make copies if strings are "persistent" */ int fill_args (char **argv, int where, value v) { value l; switch (Tag_val(v)) { case 0: argv[where] = caml_string_to_tcl(Field(v,0)); /* must free by stat_free */ return (where + 1); case 1: for (l=Field(v,0); Is_block(l); l=Field(l,1)) where = fill_args(argv,where,Field(l,0)); return where; case 2: { char **tmpargv; char *merged; int i; int size = argv_size(Field(v,0)); tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *)); fill_args(tmpargv,0,Field(v,0)); tmpargv[size] = NULL; merged = Tcl_Merge(size,(const char *const*)tmpargv); for(i = 0; i= 8) /* info.proc might be a NULL pointer * We should probably attempt an Obj invocation, but the following quick * hack is easier. */ if (info.proc == NULL) { Tcl_DString buf; Tcl_DStringInit(&buf); Tcl_DStringAppend(&buf, argv[0], -1); for (i=1; i= 0; i--) argv[i+1] = argv[i]; argv[0] = "unknown"; result = (*info.proc)(info.clientData,cltclinterp,size+1,(const char**)argv); } else { /* ah, it isn't there at all */ result = TCL_ERROR; Tcl_AppendResult(cltclinterp, "Unknown command \"", argv[0], "\"", NULL); } } /* Free the various things we allocated */ for(i=0; i< size; i ++){ stat_free((char *) allocated[i]); } stat_free((char *)argv); stat_free((char *)allocated); switch (result) { case TCL_OK: return tcl_string_to_caml (Tcl_GetStringResult(cltclinterp)); case TCL_ERROR: tk_error(Tcl_GetStringResult(cltclinterp)); default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ tk_error("bad tcl result"); } } mingw-ocaml/ocaml/otherlibs/labltk/support/cltkWait.c0000644000175000017500000000723512124403241022373 0ustar tootstoots/***********************************************************************/ /* */ /* MLTk, Tcl/Tk interface of OCaml */ /* */ /* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file LICENSE found in the OCaml source tree. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include "camltk.h" /* The following are replacements for tkwait visibility tkwait window in the case where we use threads (tkwait internally calls an event loop, and thus prevents thread scheduling from taking place). Instead, one should set up a callback, wait for a signal, and signal from inside the callback */ static void WaitVisibilityProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); static void WaitWindowProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); /* For the other handlers, we need a bit more data */ struct WinCBData { int cbid; Tk_Window win; }; static void WaitVisibilityProc(clientData, eventPtr) ClientData clientData; XEvent *eventPtr; /* Information about event (not used). */ { struct WinCBData *vis = clientData; value cbid = Val_int(vis->cbid); Tk_DeleteEventHandler(vis->win, VisibilityChangeMask, WaitVisibilityProc, clientData); stat_free((char *)vis); callback2(*handler_code,cbid,Val_int(0)); } /* Sets up a callback upon Visibility of a window */ CAMLprim value camltk_wait_vis(value win, value cbid) { struct WinCBData *vis = (struct WinCBData *)stat_alloc(sizeof(struct WinCBData)); vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow); if (vis -> win == NULL) { stat_free((char *)vis); tk_error(Tcl_GetStringResult(cltclinterp)); }; vis->cbid = Int_val(cbid); Tk_CreateEventHandler(vis->win, VisibilityChangeMask, WaitVisibilityProc, (ClientData) vis); return Val_unit; } static void WaitWindowProc(ClientData clientData, XEvent *eventPtr) { if (eventPtr->type == DestroyNotify) { struct WinCBData *vis = clientData; value cbid = Val_int(vis->cbid); stat_free((char *)clientData); /* The handler is destroyed by Tk itself */ callback2(*handler_code,cbid,Val_int(0)); } } /* Sets up a callback upon window destruction */ CAMLprim value camltk_wait_des(value win, value cbid) { struct WinCBData *vis = (struct WinCBData *)stat_alloc(sizeof(struct WinCBData)); vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow); if (vis -> win == NULL) { stat_free((char *)vis); tk_error(Tcl_GetStringResult(cltclinterp)); }; vis->cbid = Int_val(cbid); Tk_CreateEventHandler(vis->win, StructureNotifyMask, WaitWindowProc, (ClientData) vis); return Val_unit; } mingw-ocaml/ocaml/otherlibs/labltk/support/cltkMisc.c0000644000175000017500000000413412124403241022355 0ustar tootstoots/***********************************************************************/ /* */ /* MLTk, Tcl/Tk interface of OCaml */ /* */ /* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file LICENSE found in the OCaml source tree. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include "camltk.h" /* Parsing results */ CAMLprim value camltk_splitlist (value v) { int argc; char **argv; int result; char *utf; CheckInit(); utf = caml_string_to_tcl(v); /* argv is allocated by Tcl, to be freed by us */ result = Tcl_SplitList(cltclinterp,utf,&argc,(const char ***)&argv); switch(result) { case TCL_OK: { value res = copy_string_list(argc,argv); Tcl_Free((char *)argv); /* only one large block was allocated */ /* argv points into utf: utf must be freed after argv are freed */ stat_free( utf ); return res; } case TCL_ERROR: default: stat_free( utf ); tk_error(Tcl_GetStringResult(cltclinterp)); } } /* Copy an OCaml string to the C heap. Should deallocate with stat_free */ char *string_to_c(value s) { int l = string_length(s); char *res = stat_alloc(l + 1); memmove (res, String_val (s), l); res[l] = '\0'; return res; } mingw-ocaml/ocaml/otherlibs/labltk/support/textvariable.mli0000644000175000017500000000360212124403241023634 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* Support for Tk -textvariable option *) open Widget open Protocol type textVariable (* TextVariable is an abstract type *) val create : ?on: 'a widget -> unit -> textVariable (* Allocation of a textVariable with lifetime associated to widget if a widget is specified *) val set : textVariable -> string -> unit (* Setting the val of a textVariable *) val get : textVariable -> string (* Reading the val of a textVariable *) val name : textVariable -> string (* Its tcl name *) val cCAMLtoTKtextVariable : textVariable -> tkArgs (* Internal conversion function *) val handle : textVariable -> callback:(unit -> unit) -> unit (* Callbacks on variable modifications *) val coerce : string -> textVariable (*-*) val free : textVariable -> unit mingw-ocaml/ocaml/otherlibs/labltk/support/native.itarget0000644000175000017500000000016712124403241023311 0ustar tootstootssupport.cmx rawwidget.cmx widget.cmx protocol.cmx textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx tkthread.cmx mingw-ocaml/ocaml/otherlibs/labltk/support/textvariable.ml0000644000175000017500000000774712124403241023501 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) open Support open Protocol external internal_tracevar : string -> cbid -> unit = "camltk_trace_var" external internal_untracevar : string -> cbid -> unit = "camltk_untrace_var" external set : string -> string -> unit = "camltk_setvar" external get : string -> string = "camltk_getvar" type textVariable = string (* List of handles *) let handles = Hashtbl.create 401 let add_handle var cbid = try let r = Hashtbl.find handles var in r := cbid :: !r with Not_found -> Hashtbl.add handles var (ref [cbid]) let exceptq x = let rec ex acc = function [] -> acc | y::l when y == x -> ex acc l | y::l -> ex (y::acc) l in ex [] let rem_handle var cbid = try let r = Hashtbl.find handles var in match exceptq cbid !r with [] -> Hashtbl.remove handles var | remaining -> r := remaining with Not_found -> () (* Used when we "free" the variable (otherwise, old handlers would apply to * new usage of the variable) *) let rem_all_handles var = try let r = Hashtbl.find handles var in List.iter (internal_untracevar var) !r; Hashtbl.remove handles var with Not_found -> () (* Variable trace *) let handle vname ~callback:f = let id = new_function_id() in let wrapped _ = clear_callback id; rem_handle vname id; f() in Hashtbl.add callback_naming_table id wrapped; add_handle vname id; if !Protocol.debug then begin prerr_cbid id; prerr_string " for variable "; prerr_endline vname end; internal_tracevar vname id (* Avoid space leak (all variables are global in Tcl) *) module StringSet = Set.Make(struct type t = string let compare = compare end) let freelist = ref (StringSet.empty) let memo = Hashtbl.create 101 (* Added a variable v referenced by widget w *) let add w v = let w = Widget.forget_type w in let r = try Hashtbl.find memo w with Not_found -> let r = ref StringSet.empty in Hashtbl.add memo w r; r in r := StringSet.add v !r (* to be used with care ! *) let free v = rem_all_handles v; freelist := StringSet.add v !freelist (* Free variables associated with a widget *) let freew w = try let r = Hashtbl.find memo w in StringSet.iter free !r; Hashtbl.remove memo w with Not_found -> () let _ = add_destroy_hook freew (* Allocate a new variable *) let counter = ref 0 let getv () = let v = if StringSet.is_empty !freelist then begin incr counter; "camlv("^ string_of_int !counter ^")" end else let v = StringSet.choose !freelist in freelist := StringSet.remove v !freelist; v in set v ""; v let create ?on: w () = let v = getv() in begin match w with Some w -> add w v | None -> () end; v (* to be used with care ! *) let free v = freelist := StringSet.add v !freelist let cCAMLtoTKtextVariable s = TkToken s let name s = s let coerce s = s mingw-ocaml/ocaml/otherlibs/labltk/support/cltkUtf.c0000644000175000017500000000467512124403241022232 0ustar tootstoots/***********************************************************************/ /* */ /* MLTk, Tcl/Tk interface of OCaml */ /* */ /* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file LICENSE found in the OCaml source tree. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include #include #ifdef HAS_UNISTD #include #endif #include "camltk.h" #if (TCL_MAJOR_VERSION > 8 || \ (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)) /* 8.1 */ # define UTFCONVERSION #endif #ifdef UTFCONVERSION char *external_to_utf( char *str ){ char *res; Tcl_DString dstr; int length; Tcl_ExternalToUtfDString(NULL, str, strlen(str), &dstr); length = Tcl_DStringLength(&dstr); res = stat_alloc(length + 1); memmove( res, Tcl_DStringValue(&dstr), length+1); Tcl_DStringFree(&dstr); return res; } char *utf_to_external( char *str ){ char *res; Tcl_DString dstr; int length; Tcl_UtfToExternalDString(NULL, str, strlen(str), &dstr); length = Tcl_DStringLength(&dstr); res = stat_alloc(length + 1); memmove( res, Tcl_DStringValue(&dstr), length+1); Tcl_DStringFree(&dstr); return res; } char *caml_string_to_tcl( value s ) { return external_to_utf( String_val(s) ); } value tcl_string_to_caml( char *s ) { CAMLparam0(); CAMLlocal1(res); char *str; str = utf_to_external( s ); res = copy_string(str); stat_free(str); CAMLreturn(res); } #else char *caml_string_to_tcl(value s){ return string_to_c(s); } value tcl_string_to_caml(char *s){ return copy_string(s); } #endif mingw-ocaml/ocaml/otherlibs/labltk/support/tkthread.ml0000644000175000017500000000440512124403241022601 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Jacques Garrigue, Nagoya University Mathematics Dept. *) (* *) (* Copyright 2004 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) let jobs : (unit -> unit) Queue.t = Queue.create () let m = Mutex.create () let with_jobs f = Mutex.lock m; let y = f jobs in Mutex.unlock m; y let loop_id = ref None let gui_safe () = !loop_id = Some(Thread.id (Thread.self ())) let running () = !loop_id <> None let has_jobs () = not (with_jobs Queue.is_empty) let n_jobs () = with_jobs Queue.length let do_next_job () = with_jobs Queue.take () let async j x = with_jobs (Queue.add (fun () -> j x)) let sync f x = if !loop_id = None then failwith "Tkthread.sync"; if gui_safe () then f x else let m = Mutex.create () in let res = ref None in Mutex.lock m; let c = Condition.create () in let j x = let y = f x in Mutex.lock m; res := Some y; Mutex.unlock m; Condition.signal c in async j x; Condition.wait c m; match !res with Some y -> y | None -> assert false let rec job_timer () = Timer.set ~ms:10 ~callback: (fun () -> for i = 1 to n_jobs () do do_next_job () done; job_timer()) let thread_main () = try loop_id := Some (Thread.id (Thread.self ())); ignore (Protocol.openTk()); job_timer(); Protocol.mainLoop(); loop_id := None; with exn -> loop_id := None; raise exn let start () = let th = Thread.create thread_main () in loop_id := Some (Thread.id th); th let top = Widget.default_toplevel mingw-ocaml/ocaml/otherlibs/labltk/support/support.ml0000644000175000017500000000363312124403241022511 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* Parsing results of Tcl *) (* List.split a string according to char_sep predicate *) let split_str ~pred:char_sep str = let len = String.length str in let rec skip_sep cur = if cur >= len then cur else if char_sep str.[cur] then skip_sep (succ cur) else cur in let rec split beg cur = if cur >= len then if beg = cur then [] else [String.sub str beg (len - beg)] else if char_sep str.[cur] then let nextw = skip_sep cur in (String.sub str beg (cur - beg)) ::(split nextw nextw) else split beg (succ cur) in let wstart = skip_sep 0 in split wstart wstart (* Very easy hack for option type *) let may f = function Some x -> Some (f x) | None -> None let maycons f x l = match x with Some x -> f x :: l | None -> l mingw-ocaml/ocaml/otherlibs/labltk/support/support.mli0000644000175000017500000000241312124403241022655 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) val split_str : pred:(char -> bool) -> string -> string list val may : ('a -> 'b) -> 'a option -> 'b option val maycons : ('a -> 'b) -> 'a option -> 'b list -> 'b list mingw-ocaml/ocaml/otherlibs/labltk/support/cltkFile.c0000644000175000017500000001100712124403241022336 0ustar tootstoots/***********************************************************************/ /* */ /* MLTk, Tcl/Tk interface of OCaml */ /* */ /* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ /* projet Cristal, INRIA Rocquencourt */ /* Jacques Garrigue, Kyoto University RIMS */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique and Kyoto University. All rights reserved. */ /* This file is distributed under the terms of the GNU Library */ /* General Public License, with the special exception on linking */ /* described in file LICENSE found in the OCaml source tree. */ /* */ /***********************************************************************/ /* $Id$ */ #ifdef _WIN32 #include #include #include #endif #include #include #include #include #include "camltk.h" /* * File descriptor callbacks */ void FileProc(ClientData clientdata, int mask) { callback2(*handler_code,Val_int(clientdata),Val_int(0)); } /* Map Unix.file_descr values to Tcl file handles */ #ifndef _WIN32 /* Under Unix, we use file handlers */ /* Map Unix.file_descr values to Tcl file handles (for tcl 7) or Unix file descriptors (for tcl 8). */ #if (TCL_MAJOR_VERSION < 8) static Tcl_File tcl_filehandle(value fd) { return Tcl_GetFile((ClientData)Long_val(fd), TCL_UNIX_FD); } #else #define tcl_filehandle(fd) Int_val(fd) #define Tcl_File int #endif CAMLprim value camltk_add_file_input(value fd, value cbid) { CheckInit(); Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_READABLE, FileProc, (ClientData)(Long_val(cbid))); return Val_unit; } /* We have to free the Tcl handle when we are finished using it (Tcl * asks us to, and moreover it is probably dangerous to keep the same * handle over two allocations of the same fd by the kernel). * But we don't know when we are finished with the fd, so we free it * in rem_file (it doesn't close the fd anyway). For fds for which we * repeatedly add/rem, this will cause some overhead. */ CAMLprim value camltk_rem_file_input(value fd, value cbid) { Tcl_File fh = tcl_filehandle(fd); Tcl_DeleteFileHandler(fh); #if (TCL_MAJOR_VERSION < 8) Tcl_FreeFile(fh); #endif return Val_unit; } CAMLprim value camltk_add_file_output(value fd, value cbid) { CheckInit(); Tcl_CreateFileHandler(tcl_filehandle(fd), TCL_WRITABLE, FileProc, (ClientData) (Long_val(cbid))); return Val_unit; } CAMLprim value camltk_rem_file_output(value fd, value cbid) { Tcl_File fh = tcl_filehandle(fd); Tcl_DeleteFileHandler(fh); #if (TCL_MAJOR_VERSION < 8) Tcl_FreeFile(fh); #endif return Val_unit; } #else /* Under Win32, we go through the generic channel abstraction */ #define Handle_val(v) (*((HANDLE *) Data_custom_val(v))) /* Map Unix.file_descr values to Tcl channels */ static Tcl_Channel tcl_channel(value fd, int flags) { HANDLE h = Handle_val(fd); int optval, optsize; optsize = sizeof(optval); if (getsockopt((SOCKET) h, SOL_SOCKET, SO_TYPE, (char *)&optval, &optsize) == 0) return Tcl_MakeTcpClientChannel((ClientData) h); else return Tcl_MakeFileChannel((ClientData) h, flags); } CAMLprim value camltk_add_file_input(value fd, value cbid) { CheckInit(); Tcl_CreateChannelHandler(tcl_channel(fd, TCL_READABLE), TCL_READABLE, FileProc, (ClientData) (Int_val(cbid))); return Val_unit; } CAMLprim value camltk_rem_file_input(value fd, value cbid) { Tcl_DeleteChannelHandler(tcl_channel(fd, TCL_READABLE), FileProc, (ClientData) (Int_val(cbid))); return Val_unit; } CAMLprim value camltk_add_file_output(value fd, value cbid) { CheckInit(); Tcl_CreateChannelHandler(tcl_channel(fd, TCL_WRITABLE), TCL_WRITABLE, FileProc, (ClientData) (Int_val(cbid))); return Val_unit; } CAMLprim value camltk_rem_file_output(value fd, value cbid) { Tcl_DeleteChannelHandler(tcl_channel(fd, TCL_WRITABLE), FileProc, (ClientData) (Int_val(cbid))); return Val_unit; } #endif mingw-ocaml/ocaml/otherlibs/labltk/support/widget.mli0000644000175000017500000000734512124403241022435 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* Support for widget manipulations *) type 'a widget = 'a Rawwidget.raw_widget (* widget is an abstract type *) type any = Rawwidget.raw_any and button and canvas and checkbutton and entry and frame and label and listbox and menu and menubutton and message and radiobutton and scale and scrollbar and text and toplevel val forget_type : 'a widget -> any widget val coe : 'a widget -> any widget val default_toplevel : toplevel widget (* [default_toplevel] is "." in Tk, the toplevel widget that is always existing during a Tk session. Destroying [default_toplevel] ends the main loop *) val atom : parent: 'a widget -> name: string -> any widget (* [atom parent name] returns the widget [parent.name]. The widget is not created. Only its name is returned. In a given parent, there may only exist one children for a given name. This function should only be used to check the existence of a widget with a known name. It doesn't add the widget to the internal tables of CamlTk. *) val name : 'a widget -> string (* [name w] returns the name (tk "path") of a widget *) (*--*) (* The following functions are used internally. There is normally no need for them in users programs *) val known_class : 'a widget -> string (* [known_class w] returns the class of a widget (e.g. toplevel, frame), as known by the CamlTk interface. Not equivalent to "winfo w" in Tk. *) val dummy : any widget (* [dummy] is a widget used as context when we don't have any. It is *not* a real widget. *) val new_atom : parent:'a widget -> ?name: string -> string -> 'b widget val get_atom : string -> any widget (* [get_atom path] returns the widget with Tk path [path] *) val remove : 'a widget -> unit (* [remove w] removes widget from the internal tables *) (* Subtypes tables *) val widget_any_table : string list val widget_button_table : string list val widget_canvas_table : string list val widget_checkbutton_table : string list val widget_entry_table : string list val widget_frame_table : string list val widget_label_table : string list val widget_listbox_table : string list val widget_menu_table : string list val widget_menubutton_table : string list val widget_message_table : string list val widget_radiobutton_table : string list val widget_scale_table : string list val widget_scrollbar_table : string list val widget_text_table : string list val widget_toplevel_table : string list val chk_sub : string -> 'a list -> 'a -> unit val check_class : 'a widget -> string list -> unit (* Widget subtyping *) exception IllegalWidgetType of string (* Raised when widget command applied illegally*) mingw-ocaml/ocaml/otherlibs/labltk/support/tkthread.mli0000644000175000017500000000440312124403241022750 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Jacques Garrigue, Nagoya University Mathematics Dept. *) (* *) (* Copyright 2004 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) (* Helper functions for using LablTk with threads. To use, add tkthread.cmo or tkthread.cmx to your command line *) (** Start the main loop in a new GUI thread. Do not use recursively. *) val start : unit -> Thread.t (** The actual function executed in the GUI thread *) val thread_main : unit -> unit (** The toplevel widget (an alias of [Widget.default_toplevel]) *) val top : Widget.toplevel Widget.widget (* Jobs are needed for Windows, as you cannot do GUI work from another thread. This is apparently true on OSX/Aqua too. And even using X11 some calls need to come from the main thread. The basic idea is to either use async (if you don't need a result) or sync whenever you call a Tk related function from another thread (for instance with the threaded toplevel). With sync, beware of deadlocks! *) (** Add an asynchronous job (to do in the GUI thread) *) val async : ('a -> unit) -> 'a -> unit (** Add a synchronous job (to do in the GUI thread). Raise [Failure "Tkthread.sync"] if there is no such thread. *) val sync : ('a -> 'b) -> 'a -> 'b (** Whether the current thread is the GUI thread. Note that when using X11 it is generally safe to call most Tk functions from other threads too. *) val gui_safe : unit -> bool (** Whether a GUI thread is running *) val running : unit -> bool mingw-ocaml/ocaml/otherlibs/labltk/support/.depend0000644000175000017500000000227112124403241021700 0ustar tootstootscamltkwrap.cmi: widget.cmi timer.cmi textvariable.cmi protocol.cmi protocol.cmi: widget.cmi textvariable.cmi: widget.cmi protocol.cmi tkthread.cmi: widget.cmi widget.cmi: rawwidget.cmi camltkwrap.cmo: timer.cmi textvariable.cmi rawwidget.cmi protocol.cmi \ fileevent.cmi camltkwrap.cmi camltkwrap.cmx: timer.cmx textvariable.cmx rawwidget.cmx protocol.cmx \ fileevent.cmx camltkwrap.cmi fileevent.cmo: support.cmi protocol.cmi fileevent.cmi fileevent.cmx: support.cmx protocol.cmx fileevent.cmi protocol.cmo: widget.cmi support.cmi protocol.cmi protocol.cmx: widget.cmx support.cmx protocol.cmi rawwidget.cmo: support.cmi rawwidget.cmi rawwidget.cmx: support.cmx rawwidget.cmi slave.cmo: widget.cmi slave.cmx: widget.cmx support.cmo: support.cmi support.cmx: support.cmi textvariable.cmo: widget.cmi support.cmi protocol.cmi textvariable.cmi textvariable.cmx: widget.cmx support.cmx protocol.cmx textvariable.cmi timer.cmo: support.cmi protocol.cmi timer.cmi timer.cmx: support.cmx protocol.cmx timer.cmi tkthread.cmo: widget.cmi timer.cmi protocol.cmi tkthread.cmi tkthread.cmx: widget.cmx timer.cmx protocol.cmx tkthread.cmi widget.cmo: rawwidget.cmi widget.cmi widget.cmx: rawwidget.cmx widget.cmi mingw-ocaml/ocaml/otherlibs/labltk/support/rawwidget.ml0000644000175000017500000001205312124403241022766 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) open Support (* * Widgets *) exception IllegalWidgetType of string (* Raised when widget command applied illegally*) (***************************************************) (* Widgets *) (* This 'a raw_widget will be 'a Widget.widget *) (***************************************************) type 'a raw_widget = Untyped of string | Typed of string * string type raw_any (* will be Widget.any *) and button and canvas and checkbutton and entry and frame and label and listbox and menu and menubutton and message and radiobutton and scale and scrollbar and text and toplevel let forget_type w = (Obj.magic (w : 'a raw_widget) : raw_any raw_widget) let coe = forget_type (* table of widgets *) let table = (Hashtbl.create 401 : (string, raw_any raw_widget) Hashtbl.t) let name = function Untyped s -> s | Typed (s,_) -> s (* Normally all widgets are known *) (* this is a provision for send commands to external tk processes *) let known_class = function Untyped _ -> "unknown" | Typed (_,c) -> c (* This one is always created by opentk *) let default_toplevel = let wname = "." in let w = Typed (wname, "toplevel") in Hashtbl.add table wname w; w (* Dummy widget to which global callbacks are associated *) (* also passed around by camltotkoption when no widget in context *) let dummy = Untyped "dummy" let remove w = Hashtbl.remove table (name w) (* Retype widgets returned from Tk *) (* JPF report: sometime s is "", see Protocol.cTKtoCAMLwidget *) let get_atom s = try Hashtbl.find table s with Not_found -> Untyped s let naming_scheme = [ "button", "b"; "canvas", "ca"; "checkbutton", "cb"; "entry", "en"; "frame", "f"; "label", "l"; "listbox", "li"; "menu", "me"; "menubutton", "mb"; "message", "ms"; "radiobutton", "rb"; "scale", "sc"; "scrollbar", "sb"; "text", "t"; "toplevel", "top" ] let widget_any_table = List.map fst naming_scheme (* subtypes *) let widget_button_table = [ "button" ] and widget_canvas_table = [ "canvas" ] and widget_checkbutton_table = [ "checkbutton" ] and widget_entry_table = [ "entry" ] and widget_frame_table = [ "frame" ] and widget_label_table = [ "label" ] and widget_listbox_table = [ "listbox" ] and widget_menu_table = [ "menu" ] and widget_menubutton_table = [ "menubutton" ] and widget_message_table = [ "message" ] and widget_radiobutton_table = [ "radiobutton" ] and widget_scale_table = [ "scale" ] and widget_scrollbar_table = [ "scrollbar" ] and widget_text_table = [ "text" ] and widget_toplevel_table = [ "toplevel" ] let new_suffix clas n = try (List.assoc clas naming_scheme) ^ (string_of_int n) with Not_found -> "w" ^ (string_of_int n) (* The function called by generic creation *) let counter = ref 0 let new_atom ~parent ?name:nom clas = let parentpath = name parent in let path = match nom with None -> incr counter; if parentpath = "." then "." ^ (new_suffix clas !counter) else parentpath ^ "." ^ (new_suffix clas !counter) | Some name -> if parentpath = "." then "." ^ name else parentpath ^ "." ^ name in let w = Typed(path,clas) in Hashtbl.add table path w; w (* Just create a path. Only to check existence of widgets *) (* Use with care *) let atom ~parent ~name:pathcomp = let parentpath = name parent in let path = if parentpath = "." then "." ^ pathcomp else parentpath ^ "." ^ pathcomp in Untyped path (* LablTk: Redundant with subtyping of Widget, backward compatibility *) let check_class w clas = match w with Untyped _ -> () (* assume run-time check by tk*) | Typed(_,c) -> if List.mem c clas then () else raise (IllegalWidgetType c) (* Checking membership of constructor in subtype table *) let chk_sub errname table c = if List.mem c table then () else raise (Invalid_argument errname) mingw-ocaml/ocaml/otherlibs/labltk/support/protocol.ml0000644000175000017500000002146112124403241022635 0ustar tootstoots(***********************************************************************) (* *) (* MLTk, Tcl/Tk interface of OCaml *) (* *) (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) (* projet Cristal, INRIA Rocquencourt *) (* Jacques Garrigue, Kyoto University RIMS *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique and Kyoto University. All rights reserved. *) (* This file is distributed under the terms of the GNU Library *) (* General Public License, with the special exception on linking *) (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) (* $Id$ *) open Support open Widget type callback_buffer = string list (* Buffer for reading callback arguments *) type tkArgs = TkToken of string | TkTokenList of tkArgs list (* to be expanded *) | TkQuote of tkArgs (* mapped to Tcl list *) type cbid = int external opentk_low : string list -> unit = "camltk_opentk" external tcl_eval : string -> string = "camltk_tcl_eval" external tk_mainloop : unit -> unit = "camltk_tk_mainloop" external tcl_direct_eval : tkArgs array -> string = "camltk_tcl_direct_eval" external splitlist : string -> string list = "camltk_splitlist" external tkreturn : string -> unit = "camltk_return" external callback_init : unit -> unit = "camltk_init" external finalizeTk : unit -> unit = "camltk_finalize" (* Finalize tcl/tk before exiting. This function will be automatically called when you call [Pervasives.exit ()] (This is installed at [install_cleanup ()] *) let tcl_command s = ignore (tcl_eval s);; type event_flag = DONT_WAIT | X_EVENTS | FILE_EVENTS | TIMER_EVENTS | IDLE_EVENTS | ALL_EVENTS external do_one_event : event_flag list -> bool = "camltk_dooneevent" let do_pending () = while do_one_event [DONT_WAIT] do () done exception TkError of string (* Raised by the communication functions *) let () = Callback.register_exception "tkerror" (TkError "") let cltclinterp = ref Nativeint.zero (* For use in other extensions *) let () = Callback.register "cltclinterp" cltclinterp (* Debugging support *) let debug = ref (try ignore (Sys.getenv "CAMLTKDEBUG"); true with Not_found -> false) (* This is approximative, since we don't quote what needs to be quoted *) let dump_args args = let rec print_arg = function TkToken s -> prerr_string s; prerr_string " " | TkTokenList l -> List.iter print_arg l | TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} " in Array.iter print_arg args; prerr_newline() (* * Evaluating Tcl code * debugging support should not affect performances... *) let tkEval args = if !debug then dump_args args; let res = tcl_direct_eval args in if !debug then begin prerr_string "->>"; prerr_endline res end; res let tkCommand args = ignore (tkEval args) (* * Callbacks *) (* LablTk only *) let cCAMLtoTKwidget w = (* Widget.check_class w table; (* with subtyping, it is redundant *) *) TkToken (Widget.name w) let cTKtoCAMLwidget = function "" -> raise (Invalid_argument "cTKtoCAMLwidget") | s -> Widget.get_atom s let callback_naming_table = (Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t) let callback_memo_table = (Hashtbl.create 401 : (any widget, int) Hashtbl.t) let new_function_id = let counter = ref 0 in function () -> incr counter; !counter let string_of_cbid = string_of_int (* Add a new callback, associated to widget w *) (* The callback should be cleared when w is destroyed *) let register_callback w ~callback:f = let id = new_function_id () in Hashtbl.add callback_naming_table id f; if (forget_type w) <> (forget_type Widget.dummy) then Hashtbl.add callback_memo_table (forget_type w) id; (string_of_cbid id) let clear_callback id = Hashtbl.remove callback_naming_table id (* Clear callbacks associated to a given widget *) let remove_callbacks w = let w = forget_type w in let cb_ids = Hashtbl.find_all callback_memo_table w in List.iter clear_callback cb_ids; for i = 1 to List.length cb_ids do Hashtbl.remove callback_memo_table w done (* Hand-coded callback for destroyed widgets * This may be extended by the application, or by other layers of Camltk. * Could use bind + of Tk, but I'd rather give an alternate mechanism so * that hooks can be set up at load time (i.e. before openTk) *) let destroy_hooks = ref [] let add_destroy_hook f = destroy_hooks := f :: !destroy_hooks let _ = add_destroy_hook (fun w -> remove_callbacks w; Widget.remove w) let install_cleanup () = let call_destroy_hooks = function [wname] -> let w = cTKtoCAMLwidget wname in List.iter (fun f -> f w) !destroy_hooks | _ -> raise (TkError "bad cleanup callback") in let fid = new_function_id () in Hashtbl.add callback_naming_table fid call_destroy_hooks; (* setup general destroy callback *) tcl_command ("bind all {camlcb " ^ (string_of_cbid fid) ^" %W}"); at_exit finalizeTk let prerr_cbid id = prerr_string "camlcb "; prerr_int id (* The callback dispatch function *) let dispatch_callback id args = if !debug then begin prerr_cbid id; List.iter (fun x -> prerr_string " "; prerr_string x) args; prerr_newline() end; (Hashtbl.find callback_naming_table id) args; if !debug then prerr_endline "<<-" let protected_dispatch id args = try dispatch_callback id args with e -> Printf.eprintf "Uncaught exception: %s\n" (Printexc.to_string e); flush stderr let _ = Callback.register "camlcb" protected_dispatch (* Make sure the C variables are initialised *) let _ = callback_init () (* Different version of initialisation functions *) let default_display_name = ref "" let default_display () = !default_display_name let camltk_argv = ref [] (* options for Arg.parse *) let keywords = [ "-display", Arg.String (fun s -> camltk_argv := "-display" :: s :: !camltk_argv), " : X server to contact (CamlTk)"; "-colormap", Arg.String (fun s -> camltk_argv := "-colormap" :: s :: !camltk_argv), " : colormap to use (CamlTk)"; "-geometry", Arg.String (fun s -> camltk_argv := "-geometry" :: s :: !camltk_argv), " : size and position (CamlTk)"; "-name", Arg.String (fun s -> camltk_argv := "-name" :: s :: !camltk_argv), " : application class (CamlTk)"; "-sync", Arg.Unit (fun () -> camltk_argv := "-sync" :: !camltk_argv), ": sync mode (CamlTk)"; "-use", Arg.String (fun s -> camltk_argv := "-use" :: s :: !camltk_argv), " : parent window id (CamlTk)"; "-window", Arg.String (fun s -> camltk_argv := "-use" :: s :: !camltk_argv), " : parent window id (CamlTk)"; "-visual", Arg.String (fun s -> camltk_argv := "-visual" :: s :: !camltk_argv), " : visual to use (CamlTk)" ] let opentk_with_args argv (* = [argv1;..;argvn] *) = (* argv must be command line for wish *) let argv0 = Sys.argv.(0) in let rec find_display = function | "-display" :: s :: xs -> s | "-colormap" :: s :: xs -> find_display xs | "-geometry" :: s :: xs -> find_display xs | "-name" :: s :: xs -> find_display xs | "-sync" :: xs -> find_display xs | "-use" :: s :: xs -> find_display xs | "-window" :: s :: xs -> find_display xs | "-visual" :: s :: xs -> find_display xs | "--" :: _ -> "" | _ :: xs -> find_display xs | [] -> "" in default_display_name := find_display argv; opentk_low (argv0 :: argv); install_cleanup(); Widget.default_toplevel let opentk () = opentk_with_args !camltk_argv;; let openTkClass s = opentk_with_args ["-name"; s] let openTkDisplayClass disp cl = opentk_with_args ["-display"; disp; "-name"; cl] (*JPF CAMLTK/LABLTK? *) let openTk ?(display = "") ?(clas = "LablTk") () = let dispopt = match display with | "" -> [] | _ -> ["-display"; display] in opentk_with_args (dispopt @ ["-name"; clas]) (* Destroy all widgets, thus cleaning up table and exiting the loop *) let closeTk () = tcl_command "destroy ." let mainLoop = tk_mainloop (* [register tclname f] makes [f] available from Tcl with name [tclname] *) let register tclname ~callback = let s = register_callback Widget.default_toplevel ~callback in tcl_command (Printf.sprintf "proc %s {args} {eval {camlcb %s} $args}" tclname s) mingw-ocaml/ocaml/otherlibs/labltk/lib/0000755000175000017500000000000012124403241017470 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/lib/.ignore0000644000175000017500000000006112124403241020751 0ustar tootstootslabltktop labltk mltktop mltk .depend *.ml *.mli mingw-ocaml/ocaml/otherlibs/labltk/lib/labltk.bat0000755000175000017500000000007012124403241021431 0ustar tootstoots@ocaml -I +labltk labltk.cma %1 %2 %3 %4 %5 %6 %7 %8 %9 mingw-ocaml/ocaml/otherlibs/labltk/lib/Makefile0000644000175000017500000000736112124403241021137 0ustar tootstoots####################################################################### # # # MLTk, Tcl/Tk interface of OCaml # # # # Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis # # projet Cristal, INRIA Rocquencourt # # Jacques Garrigue, Kyoto University RIMS # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique and Kyoto University. All rights reserved. # # This file is distributed under the terms of the GNU Library # # General Public License, with the special exception on linking # # described in file LICENSE found in the OCaml source tree. # # # ####################################################################### include ../support/Makefile.common all: $(LIBNAME).cma $(LIBNAME)top$(EXE) $(LIBNAME) opt: $(LIBNAME).cmxa clean: rm -f $(LIBNAME)top$(EXE) $(LIBNAME) *.cm* *.$(A) *$(EXT_DLL) superclean: - if test -f tk.cmo; then \ echo We have changes... Now lib directory has no .cmo files; \ rm -f *.cm* *.$(O); \ fi include ../labltk/modules LABLTKOBJS=tk.cmo $(WIDGETOBJS) include ../camltk/modules CAMLTKOBJS=cTk.cmo $(CWIDGETOBJS) labltk.cmo camltk.cmo SUPPORT=../support/support.cmo ../support/rawwidget.cmo \ ../support/widget.cmo ../support/protocol.cmo \ ../support/textvariable.cmo ../support/timer.cmo \ ../support/fileevent.cmo ../support/camltkwrap.cmo TKOBJS=$(SUPPORT) $(LABLTKOBJS) $(CAMLTKOBJS) TOPLEVELLIBS=$(TOPDIR)/compilerlibs/ocamlcommon.cma \ $(TOPDIR)/compilerlibs/ocamlbytecomp.cma \ $(TOPDIR)/compilerlibs/ocamltoplevel.cma TOPLEVELSTART=$(TOPDIR)/toplevel/topstart.cmo TOPDEPS = $(TOPLEVELLIBS) $(TOPLEVELSTART) $(LIBNAME).cma: $(SUPPORT) ../Widgets.src $(MAKE) superclean cd ../labltk; $(MAKE) cd ../camltk; $(MAKE) $(MKLIB) -ocamlc '$(CAMLCB)' -o $(LIBNAME) \ -I ../labltk -I ../camltk $(TKOBJS) \ -cclib "\"$(TK_LINK)\"" $(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) ../Widgets.src $(MAKE) superclean cd ../labltk; $(MAKE) opt cd ../camltk; $(MAKE) opt $(MKLIB) -ocamlopt '$(CAMLOPTB)' -o $(LIBNAME) -oc $(LIBNAME) \ -I ../labltk -I ../camltk $(TKOBJS:.cmo=.cmx) \ -cclib "\"$(TK_LINK)\"" $(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).$(A) $(CAMLC) -verbose -linkall -o $(LIBNAME)top$(EXE) -I ../support \ $(TOPLEVELLIBS) \ -I $(OTHERS)/unix -I $(OTHERS)/win32unix unix.cma \ -I ../labltk -I ../camltk $(LIBNAME).cma \ -I $(OTHERS)/str str.cma \ $(TOPLEVELSTART) $(LIBNAME): Makefile $(TOPDIR)/config/Makefile @echo Generate $@ @echo "#!/bin/sh" > $@ @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) "$$@"' >> $@ install-script: $(LIBNAME) cp $(LIBNAME) $(BINDIR) chmod 755 $(BINDIR)/$(LIBNAME) install-batch: cp labltk.bat $(BINDIR) install: if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi cp $(LIBNAME).cma $(LIBNAME)top$(EXE) $(INSTALLDIR) chmod 644 $(INSTALLDIR)/$(LIBNAME).cma chmod 755 $(INSTALLDIR)/$(LIBNAME)top$(EXE) @if test -d $(BINDIR); then : ; else mkdir $(BINDIR); fi @case x$(TOOLCHAIN) in \ xmingw|xmsvc) $(MAKE) install-batch ;; \ *) $(MAKE) install-script ;; \ esac installopt: @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi cp $(LIBNAME).cmxa $(LIBNAME).$(A) $(INSTALLDIR) cd $(INSTALLDIR); $(RANLIB) $(LIBNAME).$(A) chmod 644 $(INSTALLDIR)/$(LIBNAME).cmxa chmod 644 $(INSTALLDIR)/$(LIBNAME).$(A) mingw-ocaml/ocaml/otherlibs/labltk/lib/Makefile.nt0000644000175000017500000000002112124403241021541 0ustar tootstootsinclude Makefile mingw-ocaml/ocaml/otherlibs/labltk/Widgets.src0000644000175000017500000022570612124403241021055 0ustar tootstoots%(***********************************************************************) %(* *) %(* MLTk, Tcl/Tk interface of OCaml *) %(* *) %(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) %(* projet Cristal, INRIA Rocquencourt *) %(* Jacques Garrigue, Kyoto University RIMS *) %(* *) %(* Copyright 2002 Institut National de Recherche en Informatique et *) %(* en Automatique and Kyoto University. All rights reserved. *) %(* This file is distributed under the terms of the GNU Library *) %(* General Public License, with the special exception on linking *) %(* described in file LICENSE found in the OCaml source tree. *) %(* *) %(***********************************************************************) %%%%%%%%%%%%%% Standard Tk8.0.3 Widgets and functions %%%%%%%%%%%%%% type Widget external % cget will probably never be implemented with verifications function (string) cgets [widget; "cget"; string] % another version with some hack is type options_constrs external function (string) cget [widget; "cget"; options_constrs] % constructors of type options_constrs are of the form C % where is an option constructor (e.g. CBackground) %%%%% Some types for standard options of widgets type Anchor { NW ["nw"] N ["n"] NE ["ne"] W ["w"] Center ["center"] E ["e"] SW ["sw"] S ["s"] SE ["se"] } type Bitmap external % builtin_GetBitmap.ml type Cursor external % builtin_GetCursor.ml type Color external % builtin_GetCursor.ml ##ifdef CAMLTK type ImageBitmap { BitmapImage [string] } type ImagePhoto { PhotoImage [string] } ##else variant type ImageBitmap { Bitmap [string] } variant type ImagePhoto { Photo [string] } variant type Image { Bitmap [string] Photo [string] } ##endif type Justification { Justify_Left ["left"] Justify_Center ["center"] Justify_Right ["right"] } type Orientation { Vertical ["vertical"] Horizontal ["horizontal"] } type Relief { Raised ["raised"] Sunken ["sunken"] Flat ["flat"] Ridge ["ridge"] Solid ["solid"] Groove ["groove"] } type TextVariable external % textvariable.ml type Units external % builtin_GetPixel.ml %%%%% The standard options, as defined in man page options(n) %%%%% The subtype is never used subtype option(standard) { ActiveBackground ["-activebackground"; Color] ActiveBorderWidth ["-activeborderwidth"; Units/int] ActiveForeground ["-activeforeground"; Color] Anchor ["-anchor"; Anchor] Background ["-background"; Color] Bitmap ["-bitmap"; Bitmap] BorderWidth ["-borderwidth"; Units/int] Cursor ["-cursor"; Cursor] DisabledForeground ["-disabledforeground"; Color] ExportSelection ["-exportselection"; bool] Font ["-font"; string] Foreground ["-foreground"; Color] % Geometry is not one of standard options... Geometry ["-geometry"; string] % Too variable to encode HighlightBackground ["-highlightbackground"; Color] HighlightColor ["-highlightcolor"; Color] HighlightThickness ["-highlightthickness"; Units/int] ##ifdef CAMLTK % images are split, to do additionnal static typing ImageBitmap (ImageBitmap) ["-image"; ImageBitmap] ImagePhoto (ImagePhoto) ["-image"; ImagePhoto] ##else Image ["-image"; Image] ##endif InsertBackground ["-insertbackground"; Color] InsertBorderWidth ["-insertborderwidth"; Units/int] InsertOffTime ["-insertofftime"; int] % Positive only InsertOnTime ["-insertontime"; int] % Idem InsertWidth ["-insertwidth"; Units/int] Jump ["-jump"; bool] Justify ["-justify"; Justification] Orient ["-orient"; Orientation] PadX ["-padx"; Units/int] PadY ["-pady"; Units/int] Relief ["-relief"; Relief] RepeatDelay ["-repeatdelay"; int] RepeatInterval ["-repeatinterval"; int] SelectBackground ["-selectbackground"; Color] SelectBorderWidth ["-selectborderwidth"; Units/int] SelectForeground ["-selectforeground"; Color] SetGrid ["-setgrid"; bool] % incomplete description of TakeFocus TakeFocus ["-takefocus"; bool] Text ["-text"; string] TextVariable ["-textvariable"; TextVariable] TroughColor ["-troughcolor"; Color] UnderlinedChar ["-underline"; int] WrapLength ["-wraplength"; Units/int] XScrollCommand ["-xscrollcommand"; function(first:float, last:float)] YScrollCommand ["-yscrollcommand"; function(first:float, last:float)] } %%%% Some other common types type Index external % builtin_index.ml type sequence ScrollValue external % builtin_ScrollValue.ml % type sequence ScrollValue { % MoveTo ["moveto"; float] % ScrollUnit ["scroll"; int; "unit"] % ScrollPage ["scroll"; int; "page"] % } %%%%% bell(n) module Bell { ##ifdef CAMLTK function () ring ["bell"; ?displayof:["-displayof"; widget]] function () ring_displayof ["bell"; "-displayof" ; displayof: widget] ##else function () ring ["bell"; ?displayof:["-displayof"; widget]] ##endif } %%%%% bind(n) % builtin_bind.ml %%%%% bindtags(n) %type Bindings { % TagBindings [string] % WidgetBindings [widget] % } type Bindings external function () bindtags ["bindtags"; widget; [bindings: Bindings list]] function (Bindings list) bindtags_get ["bindtags"; widget] %%%%% bitmap(n) subtype option(bitmapimage) { Background Data ["-data"; string] File ["-file"; string] Foreground Maskdata ["-maskdata"; string] Maskfile ["-maskfile"; string] } module Imagebitmap { function (ImageBitmap) create ["image"; "create"; "bitmap"; ?name:[ImageBitmap]; option(bitmapimage) list] ##ifdef CAMLTK function (ImageBitmap) create_named ["image"; "create"; "bitmap"; ImageBitmap; option(bitmapimage) list] ##endif function () delete ["image"; "delete"; ImageBitmap] function (int) height ["image"; "height"; ImageBitmap] function (int) width ["image"; "width"; ImageBitmap] function () configure [ImageBitmap; "configure"; option(bitmapimage) list] function (string) configure_get [ImageBitmap; "configure"] % Functions inherited from the "image" TK class } %%%%% button(n) type State { Normal ["normal"] Active ["active"] Disabled ["disabled"] Hidden ["hidden"] % introduced in tk8.3, requested for Syndex } widget button { % Standard options option ActiveBackground option ActiveForeground option Anchor option Background option Bitmap option BorderWidth option Cursor option DisabledForeground option Font option Foreground option HighlightBackground option HighlightColor option HighlightThickness ##ifdef CAMLTK option ImageBitmap option ImagePhoto ##else option Image ##endif option Justify option PadX option PadY option Relief option TakeFocus option Text option TextVariable option UnderlinedChar option WrapLength % Widget specific options option Command ["-command"; function ()] option Default ["-default"; State] option Height ["-height"; Units/int] option State ["-state"; State] option Width ["-width"; Units/int] function () configure [widget(button); "configure"; option(button) list] function (string) configure_get [widget(button); "configure"] function () flash [widget(button); "flash"] function () invoke [widget(button); "invoke"] } %%%%%% canvas(n) % Item ids and tags type TagOrId { Tag [string] Id [int] } % Indices: defined internally % subtype Index(canvas) { % Number End Insert SelFirst SelLast AtXY % } type SearchSpec { Above ["above"; TagOrId] All ["all"] Below ["below"; TagOrId] Closest ["closest"; Units/int; Units/int] ClosestHalo (Closesthalo) ["closest"; Units/int; Units/int; Units/int] ClosestHaloStart (Closesthalostart) ["closest"; Units/int; Units/int; Units/int; TagOrId] Enclosed ["enclosed"; Units/int;Units/int;Units/int;Units/int] Overlapping ["overlapping"; int;int;int;int] Withtag ["withtag"; TagOrId] } type ColorMode { Color ["color"] Gray ["gray"] Mono ["mono"] } subtype option(postscript) { % Cannot support this without array variables % Colormap ["-colormap"; TextVariable] Colormode ["-colormode"; ColorMode] File ["-file"; string] % Fontmap ["-fontmap"; TextVariable] Height PageAnchor ["-pageanchor"; Anchor] PageHeight ["-pageheight"; Units/int] PageWidth ["-pagewidth"; Units/int] PageX ["-pagex"; Units/int] PageY ["-pagey"; Units/int] Rotate ["-rotate"; bool] Width X ["-x"; Units/int] Y ["-y"; Units/int] } % Arc item configuration type ArcStyle { Arc ["arc"] Chord ["chord"] PieSlice ["pieslice"] } subtype option(arc) { Extent ["-extent"; float] Dash ["-dash"; string] % Fill is used by packer FillColor ["-fill"; Color] Outline ["-outline"; Color] OutlineStipple ["-outlinestipple"; Bitmap] Start ["-start"; float] Stipple ["-stipple"; Bitmap] ArcStyle ["-style"; ArcStyle] Tags ["-tags"; [TagOrId/string list]] Width } % Bitmap item configuration subtype option(bitmap) { Anchor Background Bitmap Foreground Tags } % Image item configuration subtype option(image) { Anchor ##ifdef CAMLTK ImagePhoto ImageBitmap ##else Image ##endif Tags } % Line item configuration type ArrowStyle { Arrow_None ["none"] Arrow_First ["first"] Arrow_Last ["last"] Arrow_Both ["both"] } type CapStyle { Cap_Butt ["butt"] Cap_Projecting ["projecting"] Cap_Round ["round"] } type JoinStyle { Join_Bevel ["bevel"] Join_Miter ["miter"] Join_Round ["round"] } subtype option(line) { ArrowStyle ["-arrow"; ArrowStyle] ArrowShape ["-arrowshape"; [Units/int; Units/int; Units/int]] CapStyle ["-capstyle"; CapStyle] Dash FillColor JoinStyle ["-joinstyle"; JoinStyle] Smooth ["-smooth"; bool] SplineSteps ["-splinesteps"; int] Stipple Tags Width } % Oval item configuration subtype option(oval) { Dash FillColor Outline Stipple Tags Width } % Polygon item configuration subtype option(polygon) { Dash FillColor Outline Smooth SplineSteps Stipple Tags Width } % Rectangle item configuration subtype option(rectangle) { Dash FillColor Outline Stipple Tags Width } % Text item configuration ##ifndef CAMLTK % Only for Labltk. CanvasTextState is unified as State in Camltk type CanvasTextState { Normal ["normal"] Disabled ["disabled"] Hidden ["hidden"] } ##endif subtype option(canvastext) { Anchor FillColor Font Justify Stipple Tags Text Width ##ifdef CAMLTK State % introduced in tk8.3, requested for Syndex ##else CanvasTextState ["-state"; CanvasTextState] % introduced in tk8.3, requested for Syndex ##endif } % Window item configuration subtype option(window) { Anchor Height Tags Width Window ["-window"; widget] Dash } % Types of items type CanvasItem { Arc_item ["arc"] Bitmap_item ["bitmap"] Image_item ["image"] Line_item ["line"] Oval_item ["oval"] Polygon_item ["polygon"] Rectangle_item ["rectangle"] Text_item ["text"] Window_item ["window"] User_item [string] } widget canvas { % Standard options option Background option BorderWidth option Cursor option HighlightBackground option HighlightColor option HighlightThickness option InsertBackground option InsertBorderWidth option InsertOffTime option InsertOnTime option InsertWidth option Relief option SelectBackground option SelectBorderWidth option SelectForeground option TakeFocus option XScrollCommand option YScrollCommand % Widget specific options option CloseEnough ["-closeenough"; float] option Confine ["-confine"; bool] option Height ["-height"; Units/int] option ScrollRegion ["-scrollregion"; [Units/int;Units/int;Units/int;Units/int]] option Width ["-width"; Units/int] option XScrollIncrement ["-xscrollincrement"; Units/int] option YScrollIncrement ["-yscrollincrement"; Units/int] function () addtag [widget(canvas); "addtag"; tag: TagOrId/string; specs: SearchSpec list] % Tag only % bbox not fully supported. should be builtin because of ambiguous result % will raise Protocol.TkError if no items match TagOrId function (int,int,int,int) bbox [widget(canvas); "bbox"; TagOrId list] external bind "builtin/canvas_bind" ##ifdef CAMLTK function (float) canvasx [widget(canvas); "canvasx"; ?spacing:[Units]; Units] function (float) canvasy [widget(canvas); "canvasy"; ?spacing:[Units]; Units] function (float) canvasx_grid [widget(canvas); "canvasx"; Units; Units] function (float) canvasy_grid [widget(canvas); "canvasy"; Units; Units] ##else function (float) canvasx [widget(canvas); "canvasx"; x:int; ?spacing:[int]] function (float) canvasy [widget(canvas); "canvasy"; y:int; ?spacing:[int]] ##endif function () configure [widget(canvas); "configure"; option(canvas) list] function (string) configure_get [widget(canvas); "configure"] % TODO: check result function (float list) coords_get [widget(canvas); "coords"; TagOrId] ##ifdef CAMLTK function () coords_set [widget(canvas); "coords"; TagOrId; xys: Units list] ##else function () coords_set [widget(canvas); "coords"; TagOrId; xys: {int, int} list] ##endif % create variations (see below) function () dchars [widget(canvas); "dchars"; TagOrId; first: Index(canvas); last: Index(canvas)] function () delete [widget(canvas); "delete"; TagOrId list] function () dtag [widget(canvas); "dtag"; TagOrId; tag: TagOrId/string] function (TagOrId list) find [widget(canvas); "find"; specs: SearchSpec list] % focus variations function () focus_reset [widget(canvas); "focus"; ""] function (TagOrId) focus_get [widget(canvas); "focus"] function () focus [widget(canvas); "focus"; TagOrId] function (TagOrId/string list) gettags [widget(canvas); "gettags"; TagOrId] function () icursor [widget(canvas); "icursor"; TagOrId; index: Index(canvas)] function (int) index [widget(canvas); "index"; TagOrId; index: Index(canvas)] function () insert [widget(canvas); "insert"; TagOrId; before: Index(canvas); text: string] % itemcget, itemconfigure are defined later function () lower [widget(canvas); "lower"; TagOrId; ?below: [TagOrId]] ##ifdef CAMLTK function () lower_below [widget(canvas); "lower"; TagOrId; TagOrId] function () lower_bot [widget(canvas); "lower"; TagOrId] ##endif function () move [widget(canvas); "move"; TagOrId; x: Units/int; y: Units/int] unsafe function (string) postscript [widget(canvas); "postscript"; option(postscript) list] % We use raise with Module name function () raise [widget(canvas); "raise"; TagOrId; ?above:[TagOrId]] ##ifdef CAMLTK function () raise_above [widget(canvas); "raise"; TagOrId; TagOrId] function () raise_top [widget(canvas); "raise"; TagOrId] ##endif function () scale [widget(canvas); "scale"; TagOrId; xorigin: Units/int; yorigin: Units/int; xscale: float; yscale: float] % For scan, use x:int and y:int since common usage is with mouse coordinates function () scan_mark [widget(canvas); "scan"; "mark"; x: int; y: int] function () scan_dragto [widget(canvas); "scan"; "dragto"; x: int; y: int] % select variations function () select_adjust [widget(canvas); "select"; "adjust"; TagOrId; index: Index(canvas)] function () select_clear [widget(canvas); "select"; "clear"] function () select_from [widget(canvas); "select"; "from"; TagOrId; index: Index(canvas)] function (TagOrId) select_item [widget(canvas); "select"; "item"] function () select_to [widget(canvas); "select"; "to"; TagOrId; index: Index(canvas)] function (CanvasItem) typeof [widget(canvas); "type"; TagOrId] function (float,float) xview_get [widget(canvas); "xview"] function (float,float) yview_get [widget(canvas); "yview"] function () xview [widget(canvas); "xview"; scroll: ScrollValue] function () yview [widget(canvas); "yview"; scroll: ScrollValue] % create and configure variations function (TagOrId) create_arc [widget(canvas); "create"; "arc"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(arc) list] function (TagOrId) create_bitmap [widget(canvas); "create"; "bitmap"; x: Units/int; y: Units/int; option(bitmap) list] function (TagOrId) create_image [widget(canvas); "create"; "image"; x: Units/int; y: Units/int; option(image) list] ##ifdef CAMLTK function (TagOrId) create_line [widget(canvas); "create"; "line"; Units list; option(line) list] function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; Units list; option(polygon) list] ##else function (TagOrId) create_line [widget(canvas); "create"; "line"; xys: {int, int} list; option(line) list] function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; xys: {int, int} list; option(polygon) list] ##endif function (TagOrId) create_oval [widget(canvas); "create"; "oval"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(oval) list] function (TagOrId) create_rectangle [widget(canvas); "create"; "rectangle"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(rectangle) list] function (TagOrId) create_text [widget(canvas); "create"; "text"; x: Units/int; y: Units/int; option(canvastext) list] function (TagOrId) create_window [widget(canvas); "create"; "window"; x: Units/int; y: Units/int; option(window) list] function (string) itemconfigure_get [widget(canvas); "itemconfigure"; TagOrId] function () configure_arc [widget(canvas); "itemconfigure"; TagOrId; option(arc) list] function () configure_bitmap [widget(canvas); "itemconfigure"; TagOrId; option(bitmap) list] function () configure_image [widget(canvas); "itemconfigure"; TagOrId; option(image) list] function () configure_line [widget(canvas); "itemconfigure"; TagOrId; option(line) list] function () configure_oval [widget(canvas); "itemconfigure"; TagOrId; option(oval) list] function () configure_polygon [widget(canvas); "itemconfigure"; TagOrId; option(polygon) list] function () configure_rectangle [widget(canvas); "itemconfigure"; TagOrId; option(rectangle) list] function () configure_text [widget(canvas); "itemconfigure"; TagOrId; option(canvastext) list] function () configure_window [widget(canvas); "itemconfigure"; TagOrId; option(window) list] } %%%%% checkbutton(n) widget checkbutton { % Standard options option ActiveBackground option ActiveForeground option Anchor option Background option Bitmap option BorderWidth option Cursor option DisabledForeground option Font option Foreground option HighlightBackground option HighlightColor option HighlightThickness ##ifdef CAMLTK option ImageBitmap option ImagePhoto ##else option Image ##endif option Justify option PadX option PadY option Relief option TakeFocus option Text option TextVariable option UnderlinedChar option WrapLength % Widget specific options option Command option Height option IndicatorOn ["-indicatoron"; bool] option OffValue ["-offvalue"; string] option OnValue ["-onvalue"; string] option SelectColor ["-selectcolor"; Color] ##ifdef CAMLTK option SelectImageBitmap (SelectImageBitmap) ["-selectimage"; ImageBitmap] option SelectImagePhoto (SelectImagePhoto) ["-selectimage"; ImagePhoto] ##else option SelectImage ["-selectimage"; Image] ##endif option State option Variable ["-variable"; TextVariable] option Width function () configure [widget(checkbutton); "configure"; option(checkbutton) list] function (string) configure_get [widget(checkbutton); "configure"] function () deselect [widget(checkbutton); "deselect"] function () flash [widget(checkbutton); "flash"] function () invoke [widget(checkbutton); "invoke"] function () select [widget(checkbutton); "select"] function () toggle [widget(checkbutton); "toggle"] } %%%%% clipboard(n) subtype icccm(clipboard_append) { ICCCMFormat ["-format"; string] ICCCMType ["-type"; string] } module Clipboard { function () clear ["clipboard"; "clear"; ?displayof:["-displayof"; widget]] function () append ["clipboard"; "append"; ?displayof:["-displayof"; widget]; icccm(clipboard_append) list; "--"; data: string] } %%%%% destroy(n) function () destroy ["destroy"; widget] %%%%% tk_dialog(n) module Dialog { external create "builtin/dialog" } %%%%% entry(n) % Defined internally % subtype Index(entry) { % Number End Insert SelFirst SelLast At AnchorPoint % } ##ifndef CAMLTK % Only for Labltk. InputState is unified as State in Camltk type InputState { Normal ["normal"] Disabled ["disabled"] } ##endif widget entry { % Standard options option Background option BorderWidth option Cursor option ExportSelection option Font option Foreground option HighlightBackground option HighlightColor option HighlightThickness option InsertBackground option InsertBorderWidth option InsertOffTime option InsertOnTime option InsertWidth option Justify option Relief option SelectBackground option SelectBorderWidth option SelectForeground option TakeFocus option TextVariable option XScrollCommand % Widget specific options option Show ["-show"; char] ##ifdef CAMLTK option State ##else option EntryState ["-state"; InputState] ##endif option TextWidth (Textwidth) ["-width"; int] function (int,int,int,int) bbox [widget(entry); "bbox"; Index(entry)] function () configure [widget(entry); "configure"; option(entry) list] function (string) configure_get [widget(entry); "configure"] function () delete_single [widget(entry); "delete"; index: Index(entry)] function () delete_range [widget(entry); "delete"; start: Index(entry); stop: Index(entry)] function (string) get [widget(entry); "get"] function () icursor [widget(entry); "icursor"; index: Index(entry)] function (int) index [widget(entry); "index"; index: Index(entry)] function () insert [widget(entry); "insert"; index: Index(entry); text: string] function () scan_mark [widget(entry); "scan"; "mark"; x: int] function () scan_dragto [widget(entry); "scan"; "dragto"; x: int] % selection variation function () selection_adjust [widget(entry); "selection"; "adjust"; index: Index(entry)] function () selection_clear [widget(entry); "selection"; "clear"] function () selection_from [widget(entry); "selection"; "from"; index: Index(entry)] function (bool) selection_present [widget(entry); "selection"; "present"] function () selection_range [widget(entry); "selection"; "range"; start: Index(entry) ; stop: Index(entry)] function () selection_to [widget(entry); "selection"; "to"; index: Index(entry)] function (float,float) xview_get [widget(entry); "xview"] function () xview [widget(entry); "xview"; scroll: ScrollValue] function () xview_index [widget(entry); "xview"; index: Index(entry)] function (float, float) xview_get [widget(entry); "xview"] } %%%%% focus(n) %%%%% tk_focusNext(n) module Focus { unsafe function (widget) get ["focus"; ?displayof:["-displayof"; widget]] unsafe function (widget) displayof ["focus"; "-displayof"; widget] function () set ["focus"; widget] function () force ["focus"; "-force"; widget] unsafe function (widget) lastfor ["focus"; "-lastfor"; widget] unsafe function (widget) next ["tk_focusNext"; widget] unsafe function (widget) prev ["tk_focusPrev"; widget] function () follows_mouse ["tk_focusFollowsMouse"] } type font external % builtin/builtin_font.ml type weight { Weight_Normal(Normal) ["normal"] Weight_Bold(Bold) ["bold"] } type slant { Slant_Roman(Roman) ["roman"] Slant_Italic(Italic) ["italic"] } type fontMetrics { Ascent ["-ascent"] Descent ["-descent"] Linespace ["-linespace"] Fixed ["-fixed"] } subtype options(font) { Font_Family ["-family"; string] Font_Size ["-size"; int] Font_Weight ["-weight"; weight] Font_Slant ["-slant"; slant] Font_Underline ["-underline"; bool] Font_Overstrike ["-overstrike"; bool] % later, JP only % Charset ["-charset"; string] %% Beware of the order of Compound ! Put it as the first option % Compound ["-compound"; [font list]] % Copy ["-copy"; string] } module Font { function (string) actual_family ["font"; "actual"; font; ?displayof:["-displayof"; widget]; "-family"] function (int) actual_size ["font"; "actual"; font; ?displayof:["-displayof"; widget]; "-size"] function (string) actual_weight ["font"; "actual"; font; ?displayof:["-displayof"; widget]; "-weight"] function (string) actual_slant ["font"; "actual"; font; ?displayof:["-displayof"; widget]; "-slant"] function (bool) actual_underline ["font"; "actual"; font; ?displayof:["-displayof"; widget]; "-underline"] function (bool) actual_overstrike ["font"; "actual"; font; ?displayof:["-displayof"; widget]; "-overstrike"] function () configure ["font"; "configure"; font; options(font) list] function (font) create ["font"; "create"; ?name:[string]; options(font) list] ##ifdef CAMLTK function (font) create_named ["font"; "create"; string; options(font) list] ##endif function () delete ["font"; "delete"; font] function (string list) families ["font"; "families"; ?displayof:["-displayof"; widget]] ##ifdef CAMLTK function (string list) families_displayof ["font"; "families"; "-displayof"; widget] ##endif function (int) measure ["font"; "measure"; font; string; ?displayof:["-displayof"; widget]] ##ifdef CAMLTK function (int) measure_displayof ["font"; "measure"; font; "-displayof"; widget; string ] ##endif function (int) metrics ["font"; "metrics"; font; ?displayof:["-displayof"; widget]; fontMetrics ] ##ifdef CAMLTK function (int) metrics_displayof ["font"; "metrics"; font; "-displayof"; widget; fontMetrics ] ##endif function (string list) names ["font"; "names"] % JP % function () failsafe ["font"; "failsafe"; string] } %%%%% frame(n) type Colormap { NewColormap (New) ["new"] WidgetColormap (Widget) [widget] } % Visual classes are: directcolor, grayscale, greyscale, pseudocolor, % staticcolor, staticgray, staticgrey, truecolor type Visual { ClassVisual (Clas) [[string; int]] DefaultVisual ["default"] WidgetVisual (Widget) [widget] BestDepth (Bestdepth) [["best"; int]] Best ["best"] } widget frame { % Standard options option BorderWidth option Cursor option HighlightBackground option HighlightColor option HighlightThickness option Relief option TakeFocus % Widget specific options option Background ##ifdef CAMLTK option Class ["-class"; string] ##else option Clas ["-class"; string] ##endif option Colormap ["-colormap"; Colormap] option Container ["-container"; bool] option Height option Visual ["-visual"; Visual] option Width % Class and Colormap and Visual cannot be changed function () configure [widget(frame); "configure"; option(frame) list] function (string) configure_get [widget(frame); "configure"] } %%%%% grab(n) type GrabStatus { GrabNone ["none"] GrabLocal ["local"] GrabGlobal ["global"] } type GrabGlobal external module Grab { function () set ["grab"; "set"; ?global:[GrabGlobal]; widget] ##ifdef CAMLTK function () set_global ["grab"; "set"; "-global"; widget] ##endif unsafe function (widget list) current ["grab"; "current"; ?displayof:[widget]] ##ifdef CAMLTK % all_current is now current. % The old current is now current_of unsafe function (widget list) current_of ["grab"; "current"; widget] ##endif function () release ["grab"; "release"; widget] function (GrabStatus) status ["grab"; "status"; widget] } subtype option(rowcolumnconfigure) { Minsize ["-minsize"; Units/int] Weight ["-weight"; int] Pad ["-pad"; Units/int] } subtype option(grid) { Column ["-column"; int] ColumnSpan ["-columnspan"; int] In(Inside) ["-in"; widget] IPadX ["-ipadx"; Units/int] IPadY ["-ipady"; Units/int] PadX PadY Row ["-row"; int] RowSpan ["-rowspan"; int] Sticky ["-sticky"; string] } % Same as pack function () grid ["grid"; widget list; option(grid) list] module Grid { function (int,int,int,int) bbox ["grid"; "bbox"; widget] function (int,int,int,int) bbox_cell ["grid"; "bbox"; widget; column: int; row: int] function (int,int,int,int) bbox_span ["grid"; "bbox"; widget; column1: int; row1: int; column2: int; row2: int] function () column_configure ["grid"; "columnconfigure"; widget; int; option(rowcolumnconfigure) list] function () configure ["grid"; "configure"; widget list; option(grid) list] function (string) column_configure_get ["grid"; "columnconfigure"; widget; int] function () forget ["grid"; "forget"; widget list] %% info returns only a string function (string) info ["grid"; "info"; widget] %% TODO: check result values function (int,int) location ["grid"; "location"; widget; x:Units/int; y:Units/int] function (bool) propagate_get ["grid"; "propagate"; widget] function () propagate_set ["grid"; "propagate"; widget; bool] function () row_configure ["grid"; "rowconfigure"; widget; int; option(rowcolumnconfigure) list] function (string) row_configure_get ["grid"; "rowconfigure"; widget; int] function (int,int) size ["grid"; "size"; widget] ##ifdef CAMLTK function (widget list) slaves ["grid"; "slaves"; widget; ?column:["-column"; int]; ?row:["-row"; int]] function (widget list) row_slaves ["grid"; "slaves"; widget; "-row"; int] function (widget list) column_slaves ["grid"; "slaves"; widget; "-column"; int] ##else function (widget list) slaves ["grid"; "slaves"; widget; ?column:["-column"; int]; ?row:["-row"; int]] ##endif } %%%%% image(n) %%%%% cf Imagephoto and Imagebitmap % Some functions on images are implemented in Imagephoto or Imagebitmap. module Image { external names "builtin/image" } %%%%% label(n) widget label { % Standard options option Anchor option Background option Bitmap option BorderWidth option Cursor option Font option Foreground option HighlightBackground option HighlightColor option HighlightThickness ##ifdef CAMLTK option ImageBitmap option ImagePhoto ##else option Image ##endif option Justify option PadX option PadY option Relief option TakeFocus option Text option TextVariable option UnderlinedChar option WrapLength % Widget specific options option Height % use according to label contents option Width option TextWidth function () configure [widget(label); "configure"; option(label) list] function (string) configure_get [widget(label); "configure"] } %%%%% listbox(n) % Defined internally % subtype Index(listbox) { % Number Active AnchorPoint End AtXY %} type SelectModeType { Single ["single"] Browse ["browse"] Multiple ["multiple"] Extended ["extended"] } widget listbox { % Standard options option Background option BorderWidth option Cursor option ExportSelection option Font option Foreground % Height is TextHeight option HighlightBackground option HighlightColor option HighlightThickness option Relief option SelectBackground option SelectBorderWidth option SelectForeground option SetGrid option TakeFocus % Width is TextWidth option XScrollCommand option YScrollCommand % Widget specific options option TextHeight ["-height"; int] option TextWidth option SelectMode ["-selectmode"; SelectModeType] function () activate [widget(listbox); "activate"; index: Index(listbox)] function (int,int,int,int) bbox [widget(listbox); "bbox"; index: Index(listbox)] function () configure [widget(listbox); "configure"; option(listbox) list] function (string) configure_get [widget(listbox); "configure"] function (Index(listbox) as "[>`Num of int]" list) curselection [widget(listbox); "curselection"] function () delete [widget(listbox); "delete"; first: Index(listbox); last: Index(listbox)] function (string) get [widget(listbox); "get"; index: Index(listbox)] function (string list) get_range [widget(listbox); "get"; first: Index(listbox); last: Index(listbox)] function (Index(listbox) as "[>`Num of int]") index [widget(listbox); "index"; index: Index(listbox)] function () insert [widget(listbox); "insert"; index: Index(listbox); texts: string list] function (Index(listbox) as "[>`Num of int]") nearest [widget(listbox); "nearest"; y: int] function () scan_mark [widget(listbox); "scan"; "mark"; x: int; y: int] function () scan_dragto [widget(listbox); "scan"; "dragto"; x: int; y: int] function () see [widget(listbox); "see"; index: Index(listbox)] function () selection_anchor [widget(listbox); "selection"; "anchor"; index: Index(listbox)] function () selection_clear [widget(listbox); "selection"; "clear"; first: Index(listbox); last: Index(listbox)] function (bool) selection_includes [widget(listbox); "selection"; "includes"; index: Index(listbox)] function () selection_set [widget(listbox); "selection"; "set"; first: Index(listbox); last: Index(listbox)] function (int) size [widget(listbox); "size"] function (float,float) xview_get [widget(listbox); "xview"] function (float,float) yview_get [widget(listbox); "yview"] function () xview_index [widget(listbox); "xview"; index: Index(listbox)] function () yview_index [widget(listbox); "yview"; index: Index(listbox)] function () xview [widget(listbox); "xview"; scroll: ScrollValue] function () yview [widget(listbox); "yview"; scroll: ScrollValue] } %%%%% lower(n) function () lower_window ["lower"; widget; ?below:[widget]] ##ifdef CAMLTK function () lower_window_below ["lower"; widget; below: widget] ##endif %%%%% menu(n) %%%%% tk_popup(n) % defined internally % subtype Index(menu) { % Number Active End Last None At Pattern % } type MenuItem { Cascade_Item ["cascade"] Checkbutton_Item ["checkbutton"] Command_Item ["command"] Radiobutton_Item ["radiobutton"] Separator_Item ["separator"] TearOff_Item ["tearoff"] } % notused as a subtype. just for cleaning up the rest. subtype option(menuentry) { ActiveBackground ActiveForeground Accelerator ["-accelerator"; string] Background Bitmap ColumnBreak ["-columnbreak"; bool] Command Font Foreground HideMargin ["-hidemargin"; bool] ##ifdef CAMLTK ImageBitmap ImagePhoto ##else Image ##endif IndicatorOn Label ["-label"; string] Menu ["-menu"; widget(menu)] OffValue OnValue SelectColor ##ifdef CAMLTK SelectImageBitmap SelectImagePhoto ##else SelectImage ##endif State UnderlinedChar Value ["-value"; string] Variable } % Options for cascade entry subtype option(menucascade) { ActiveBackground ActiveForeground Accelerator Background Bitmap ColumnBreak Command Font Foreground HideMargin ##ifdef CAMLTK ImageBitmap ImagePhoto ##else Image ##endif IndicatorOn Label Menu State UnderlinedChar } % Options for radiobutton entry subtype option(menuradio) { ActiveBackground ActiveForeground Accelerator Background Bitmap ColumnBreak Command Font Foreground ##ifdef CAMLTK ImageBitmap ImagePhoto SelectImageBitmap SelectImagePhoto ##else Image SelectImage ##endif IndicatorOn Label SelectColor State UnderlinedChar Value Variable } % Options for checkbutton entry subtype option(menucheck) { ActiveBackground ActiveForeground Accelerator Background Bitmap ColumnBreak Command Font Foreground ##ifdef CAMLTK ImageBitmap SelectImageBitmap ImagePhoto SelectImagePhoto ##else Image SelectImage ##endif IndicatorOn Label OffValue OnValue SelectColor State UnderlinedChar Variable } % Options for command entry subtype option(menucommand) { ActiveBackground ActiveForeground Accelerator Background Bitmap ColumnBreak Command Font Foreground ##ifdef CAMLTK ImageBitmap ImagePhoto ##else Image ##endif Label State UnderlinedChar } type menuType { Menu_Menubar ["menubar"] Menu_Tearoff ["tearoff"] Menu_Normal ["normal"] } % Separators and tearoffs don't have options widget menu { % Standard options option ActiveBackground option ActiveBorderWidth option ActiveForeground option Background option BorderWidth option Cursor option DisabledForeground option Font option Foreground option Relief option TakeFocus % Widget specific options option PostCommand ["-postcommand"; function()] option SelectColor option TearOff ["-tearoff"; bool] option TearOffCommand ["-tearoffcommand"; function(menu: widget(any), tornoff: widget(any)) ] option MenuTitle ["-title"; string] option MenuType ["-type"; menuType] function () activate [widget(menu); "activate"; index: Index(menu)] % add variations function () add_cascade [widget(menu); "add"; "cascade"; option(menucascade) list] function () add_checkbutton [widget(menu); "add"; "checkbutton"; option(menucheck) list] function () add_command [widget(menu); "add"; "command"; option(menucommand) list] function () add_radiobutton [widget(menu); "add"; "radiobutton"; option(menuradio) list] function () add_separator [widget(menu); "add"; "separator"] % not for user: function clone [widget(menu); "clone"; ???; menuType] function () configure [widget(menu); "configure"; option(menu) list] function (string) configure_get [widget(menu); "configure"] % beware of possible callback leak when deleting menu entries function () delete [widget(menu); "delete"; first: Index(menu); last: Index(menu)] function () configure_cascade [widget(menu); "entryconfigure"; Index(menu); option(menucascade) list] function () configure_checkbutton [widget(menu); "entryconfigure"; Index(menu); option(menucheck) list] function () configure_command [widget(menu); "entryconfigure"; Index(menu); option(menucommand) list] function () configure_radiobutton [widget(menu); "entryconfigure"; Index(menu); option(menuradio) list] function (string) entryconfigure_get [widget(menu); "entryconfigure"; Index(menu)] function (int) index [widget(menu); "index"; Index(menu)] function () insert_cascade [widget(menu); "insert"; index: Index(menu); "cascade"; option(menucascade) list] function () insert_checkbutton [widget(menu); "insert"; index: Index(menu); "checkbutton"; option(menucheck) list] function () insert_command [widget(menu); "insert"; index: Index(menu); "command"; option(menucommand) list] function () insert_radiobutton [widget(menu); "insert"; index: Index(menu); "radiobutton"; option(menuradio) list] function () insert_separator [widget(menu); "insert"; index: Index(menu); "separator"] function (string) invoke [widget(menu); "invoke"; index: Index(menu)] function () post [widget(menu); "post"; x: int; y: int] function () postcascade [widget(menu); "postcascade"; index: Index(menu)] % can't use type of course function (MenuItem) typeof [widget(menu); "type"; index: Index(menu)] function () unpost [widget(menu); "unpost"] function (int) yposition [widget(menu); "yposition"; index: Index(menu)] function () popup ["tk_popup"; widget(menu); x: int; y: int; ?entry:[Index(menu)]] ##ifdef CAMLTK function () popup_entry ["tk_popup"; widget(menu); x: int; y: int; index: Index(menu)] ##endif } %%%%% menubutton(n) type menubuttonDirection { Dir_Above ["above"] Dir_Below ["below"] Dir_Left ["left"] Dir_Right ["right"] } widget menubutton { % Standard options option ActiveBackground option ActiveForeground option Anchor option Background option Bitmap option BorderWidth option Cursor option DisabledForeground option Font option Foreground option HighlightBackground option HighlightColor option HighlightThickness ##ifdef CAMLTK option ImageBitmap option ImagePhoto ##else option Image ##endif option Justify option PadX option PadY option Relief option TakeFocus option Text option TextVariable option UnderlinedChar option WrapLength % Widget specific options option Direction ["-direction"; menubuttonDirection ] option Height option IndicatorOn option Menu ["-menu"; widget(menu)] option State option Width option TextWidth function () configure [widget(menubutton); "configure"; option(menubutton) list] function (string) configure_get [widget(menubutton); "configure"] } %%%%% message(n) widget message { % Standard options option Anchor option Background option BorderWidth option Cursor option Font option Foreground option HighlightBackground option HighlightColor option HighlightThickness option PadX option PadY option Relief option TakeFocus option Text option TextVariable % Widget specific options option Aspect ["-aspect"; int] option Justify option Width function () configure [widget(message); "configure"; option(message) list] function (string) configure_get [widget(message); "configure"] } %%%%% option(n) type OptionPriority { WidgetDefault ["widgetDefault"] StartupFile ["startupFile"] UserDefault ["userDefault"] Interactive ["interactive"] Priority [int] } ##ifdef CAMLTK module Option { unsafe function () add ["option"; "add"; string; string; OptionPriority] function () clear ["option"; "clear"] function (string) get ["option"; "get"; widget; string; string] unsafe function () readfile ["option"; "readfile"; string; OptionPriority] } %% Resource is now superseded by Option module Resource { unsafe function () add ["option"; "add"; string; string; OptionPriority] function () clear ["option"; "clear"] function (string) get ["option"; "get"; widget; string; string] unsafe function () readfile ["option"; "readfile"; string; OptionPriority] } ##else module Option { unsafe function () add ["option"; "add"; path: string; string; ?priority:[OptionPriority]] function () clear ["option"; "clear"] function (string) get ["option"; "get"; widget; name: string; clas: string] unsafe function () readfile ["option"; "readfile"; string; ?priority:[OptionPriority]] } ##endif %%%%% tk_optionMenu(n) module Optionmenu { external create "builtin/optionmenu" } %%%%% pack(n) type Side { Side_Left ["left"] Side_Right ["right"] Side_Top ["top"] Side_Bottom ["bottom"] } type FillMode { Fill_None ["none"] Fill_X ["x"] Fill_Y ["y"] Fill_Both ["both"] } subtype option(pack) { After ["-after"; widget] Anchor Before ["-before"; widget] Expand ["-expand"; bool] Fill ["-fill"; FillMode] In(Inside) ["-in"; widget] IPadX ["-ipadx"; Units/int] IPadY ["-ipady"; Units/int] PadX PadY Side ["-side"; Side] } function () pack ["pack"; widget list; option(pack) list] module Pack { function () configure ["pack"; "configure"; widget list; option(pack) list] function () forget ["pack"; "forget"; widget list] function (string) info ["pack"; "info"; widget] function (bool) propagate_get ["pack"; "propagate"; widget] function () propagate_set ["pack"; "propagate"; widget; bool] function (widget list) slaves ["pack"; "slaves"; widget] } subtype TkPalette(any) { % Not sophisticated... PaletteActiveBackground ["activeBackground"; Color] PaletteActiveForeground ["activeForeground"; Color] PaletteBackground ["background"; Color] PaletteDisabledForeground ["disabledForeground"; Color] PaletteForeground ["foreground"; Color] PaletteHighlightBackground ["hilightBackground"; Color] PaletteHighlightColor ["highlightColor"; Color] PaletteInsertBackground ["insertBackground"; Color] PaletteSelectColor ["selectColor"; Color] PaletteSelectBackground ["selectBackground"; Color] PaletteForegroundselectColor ["selectForeground"; Color] PaletteTroughColor ["troughColor"; Color] } %%%%% tk_setPalette(n) %%%% can't simply encode general form of tk_setPalette module Palette { function () set_background ["tk_setPalette"; Color] function () set ["tk_setPalette"; TkPalette(any) list] function () bisque ["tk_bisque"] } %%%%% photo(n) type PaletteType external % builtin_palette.ml subtype option(photoimage) { % Channel ["-channel"; file_descr] % removed in 8.3 ? Data Format ["-format"; string] File Gamma ["-gamma"; float] Height Palette ["-palette"; PaletteType] Width } subtype photo(copy) { ImgFrom(Src_area) ["-from"; int; int; int; int] ImgTo(Dst_area) ["-to"; int; int; int; int] Shrink ["-shrink"] Zoom ["-zoom"; int; int] Subsample ["-subsample"; int; int] } subtype photo(put) { ImgTo } subtype photo(read) { ImgFormat ["-format"; string] ImgFrom Shrink TopLeft(Dst_pos) ["-to"; int; int] } subtype photo(write) { ImgFormat ImgFrom } module Imagephoto { function (ImagePhoto) create ["image"; "create"; "photo"; ?name:[ImagePhoto]; option(photoimage) list] ##ifdef CAMLTK function (ImagePhoto) create_named ["image"; "create"; "photo"; ImagePhoto; option(photoimage) list] ##endif function () delete ["image"; "delete"; ImagePhoto] function (int) height ["image"; "height"; ImagePhoto] function (int) width ["image"; "width"; ImagePhoto] %name %type function () blank [ImagePhoto; "blank"] function () configure [ImagePhoto; "configure"; option(photoimage) list] function (string) configure_get [ImagePhoto; "configure"] function () copy [ImagePhoto; "copy"; src: ImagePhoto; photo(copy) list] function (int, int, int) get [ImagePhoto; "get"; x: int; y: int] % it is buggy ? can't express nested lists ? function () put [ImagePhoto; "put"; [Color list list]; photo(put) list] % external put "builtin/imagephoto_put" function () read [ImagePhoto; "read"; file: string; photo(read) list] function () redither [ImagePhoto; "redither"] function () write [ImagePhoto; "write"; file: string; photo(write) list] % Functions inherited from the "image" TK class } %%%%% place(n) type BorderMode { Inside ["inside"] Outside ["outside"] Ignore ["ignore"] } subtype option(place) { In X RelX ["-relx"; float] Y RelY ["-rely"; float] Anchor Width RelWidth ["-relwidth"; float] Height RelHeight ["-relheight"; float] BorderMode ["-bordermode"; BorderMode] } function () place ["place"; widget; option(place) list] module Place { function () configure ["place"; "configure"; widget; option(place) list] function () forget ["place"; "forget"; widget] function (string) info ["place"; "info"; widget] function (widget list) slaves ["place"; "slaves"; widget] } %%%%% radiobutton(n) widget radiobutton { % Standard options option ActiveBackground option ActiveForeground option Anchor option Background option Bitmap option BorderWidth option Cursor option DisabledForeground option Font option Foreground option HighlightBackground option HighlightColor option HighlightThickness ##ifdef CAMLTK option ImageBitmap option ImagePhoto ##else option Image ##endif option Justify option PadX option PadY option Relief option TakeFocus option Text option TextVariable option UnderlinedChar option WrapLength % Widget specific options option Command option Height option IndicatorOn option SelectColor ##ifdef CAMLTK option SelectImageBitmap option SelectImagePhoto ##else option SelectImage ##endif option State option Value option Variable option Width function () configure [widget(radiobutton); "configure"; option(radiobutton) list] function (string) configure_get [widget(radiobutton); "configure"] function () deselect [widget(radiobutton); "deselect"] function () flash [widget(radiobutton); "flash"] function () invoke [widget(radiobutton); "invoke"] function () select [widget(radiobutton); "select"] } %%%%% raise(n) % We cannot use raise !! function () raise_window ["raise"; widget; ?above:[widget]] ##ifdef CAMLTK function () raise_window_above ["raise"; widget; widget] ##endif %%%%% scale(n) %% shared with scrollbars ##ifdef CAMLTK subtype WidgetElement(scale) { Slider ["slider"] Trough1 ["trough1"] Trough2 ["trough2"] Beyond [""] } ##else type ScaleElement { Slider ["slider"] Trough1 ["trough1"] Trough2 ["trough2"] Beyond [""] } ##endif widget scale { % Standard options option ActiveBackground option Background option BorderWidth option Cursor option Font option Foreground option HighlightBackground option HighlightColor option HighlightThickness option Orient option Relief option RepeatDelay option RepeatInterval option TakeFocus option TroughColor % Widget specific options option BigIncrement ["-bigincrement"; float] option ScaleCommand ["-command"; function (float)] option Digits ["-digits"; int] option From(Min) ["-from"; float] option Label ["-label"; string] option Length ["-length"; Units/int] option Resolution ["-resolution"; float] option ShowValue ["-showvalue"; bool] option SliderLength ["-sliderlength"; Units/int] option State option TickInterval ["-tickinterval"; float] option To(Max) ["-to"; float] option Variable option Width ##ifdef CAMLTK function (int,int) coords [widget(scale); "coords"] function (int,int) coords_at [widget(scale); "coords"; at: float] ##else function (int,int) coords [widget(scale); "coords"; ?at: [float]] ##endif function () configure [widget(scale); "configure"; option(scale) list] function (string) configure_get [widget(scale); "configure"] function (float) get [widget(scale); "get"] function (float) get_xy [widget(scale); "get"; x: int; y: int] function (WidgetElement/ScaleElement) identify [widget(scale); x: int; y: int] function () set [widget(scale); "set"; float] } %%%%% scrollbar(n) ##ifdef CAMLTK subtype WidgetElement(scrollbar) { Arrow1 ["arrow1"] Trough1 Trough2 Slider Arrow2 ["arrow2"] Beyond } ##else type ScrollbarElement { Arrow1 ["arrow1"] Trough1 ["through1"] Trough2 ["through2"] Slider ["slider"] Arrow2 ["arrow2"] Beyond [""] } ##endif widget scrollbar { % Standard options option ActiveBackground option Background option BorderWidth option Cursor option HighlightBackground option HighlightColor option HighlightThickness option Jump option Orient option Relief option RepeatDelay option RepeatInterval option TakeFocus option TroughColor % Widget specific options option ActiveRelief ["-activerelief"; Relief] option ScrollCommand ["-command"; function(scroll: ScrollValue)] option ElementBorderWidth ["-elementborderwidth"; Units/int] option Width ##ifdef CAMLTK function () activate [widget(scrollbar); "activate"; element: WidgetElement(scrollbar)] ##else function () activate [widget(scrollbar); "activate"; element: ScrollbarElement] ##endif function (WidgetElement/ScrollbarElement) activate_get [widget(scrollbar); "activate"] function () configure [widget(scrollbar); "configure"; option(scrollbar) list] function (string) configure_get [widget(scrollbar); "configure"] function (float) delta [widget(scrollbar); "delta"; x: int; y: int] function (float) fraction [widget(scrollbar); "fraction"; x: int; y: int] function (float, float) get [widget(scrollbar); "get"] function (int,int,int,int) old_get [widget(scrollbar); "get"] function (WidgetElement/ScrollbarElement) identify [widget(scale); "identify"; int; int] function () set [widget(scrollbar); "set"; first: float; last: float] function () old_set [widget(scrollbar); "set"; total:int; window:int; first:int; last:int] } %%%%% selection(n) subtype icccm(selection_clear) { DisplayOf ["-displayof"; widget] Selection ["-selection"; string] } subtype icccm(selection_get) { DisplayOf Selection ICCCMType } subtype icccm(selection_ownset) { LostCommand ["-command"; function()] Selection } subtype icccm(selection_handle) { Selection ICCCMType ICCCMFormat ["-format"; string] } module Selection { function () clear ["selection"; "clear"; icccm(selection_clear) list] function (string) get ["selection"; "get"; icccm(selection_get) list] % function () handle_set ["selection"; "handle"; icccm(selection_handle) list; widget; function(int,int)] external handle_set "builtin/selection_handle_set" unsafe function (widget) own_get ["selection"; "own"; icccm(selection_clear) list] % builtin % function () own_set ["selection"; "own"; widget; icccm(selection_ownset) list] external own_set "builtin/selection_own_set" } %%%%% send(n) type SendOption { SendDisplayOf ["-displayof"; widget] % DisplayOf is used for icccm ! SendAsync ["-async"] } unsafe function () send ["send"; SendOption list; "--"; app: string; command: string list] %%%%% text(n) type TextIndex external type TextTag external type TextMark external type TabType { TabLeft [Units/int; "left"] TabRight [Units/int; "right"] TabCenter [Units/int; "center"] TabNumeric [Units/int; "numeric"] } type WrapMode { WrapNone ["none"] WrapChar ["char"] WrapWord ["word"] } type Comparison { LT (Lt) ["<"] LE (Le) ["<="] EQ (Eq) ["=="] GE (Ge) [">="] GT (Gt) [">"] NEQ (Neq) ["!="] } type MarkDirection { Mark_Left ["left"] Mark_Right ["right"] } type AlignType { Align_Top ["top"] Align_Bottom ["bottom"] Align_Center ["center"] Align_Baseline ["baseline"] } subtype option(embeddedi) { Align ["-align"; AlignType] ##ifdef CAMLTK ImageBitmap ImagePhoto ##else Image ##endif Name ["-name"; string] PadX PadY } subtype option(embeddedw) { Align ["-align"; AlignType] PadX PadY Stretch ["-stretch"; bool] Window } type TextSearch { Forwards ["-forwards"] Backwards ["-backwards"] Exact ["-exact"] Regexp ["-regexp"] Nocase ["-nocase"] Count ["-count"; TextVariable] } type text_dump { DumpAll ["-all"] DumpCommand ["-command"; function (key: string, value: string, index: string)] DumpMark ["-mark"] DumpTag ["-tag"] DumpText ["-text"] DumpWindow ["-window"] } widget text { % Standard options option Background option BorderWidth option Cursor option ExportSelection option Font option Foreground option HighlightBackground option HighlightColor option HighlightThickness option InsertBackground option InsertBorderWidth option InsertOffTime option InsertOnTime option InsertWidth option PadX option PadY option Relief option SelectBackground option SelectBorderWidth option SelectForeground option SetGrid option TakeFocus option XScrollCommand option YScrollCommand % Widget specific options option TextHeight option Spacing1 ["-spacing1"; Units/int] option Spacing2 ["-spacing2"; Units/int] option Spacing3 ["-spacing3"; Units/int] ##ifdef CAMLTK option State ##else option EntryState ##endif option Tabs ["-tabs"; [TabType list]] option TextWidth option Wrap ["-wrap"; WrapMode] function (int,int,int,int) bbox [widget(text); "bbox"; index: TextIndex] function (bool) compare [widget(text); "compare"; index: TextIndex; op: Comparison; index: TextIndex] function () configure [widget(text); "configure"; option(text) list] function (string) configure_get [widget(text); "configure"] function () debug [widget(text); "debug"; bool] function () delete [widget(text); "delete"; start: TextIndex; stop: TextIndex] function () delete_char [widget(text); "delete"; index: TextIndex] function (int, int, int, int, int) dlineinfo [widget(text); "dlineinfo"; index: TextIndex] % require result parser function (string list) dump [widget(text); "dump"; text_dump list; start: TextIndex; stop: TextIndex] function (string list) dump_char [widget(text); "dump"; text_dump list; index: TextIndex] function (string) get [widget(text); "get"; start: TextIndex; stop: TextIndex] function (string) get_char [widget(text); "get"; index: TextIndex] function () image_configure [widget(text); "image"; "configure"; name: string; option(embeddedi) list] function (string) image_configure_get [widget(text); "image"; "cgets"; name: string] function (string) image_create [widget(text); "image"; "create"; index: TextIndex; option(embeddedi) list] function (string list) image_names [widget(text); "image"; "names"] function (Index(text) as "[>`Linechar of int * int]") index [widget(text); "index"; index: TextIndex] ##ifdef CAMLTK function () insert [widget(text); "insert"; index: TextIndex; text: string; [TextTag list]] ##else function () insert [widget(text); "insert"; index: TextIndex; text: string; ?tags: [TextTag list]] ##endif % Mark function () mark_gravity_set [widget(text); "mark"; "gravity"; mark: TextMark; direction: MarkDirection] function (MarkDirection) mark_gravity_get [widget(text); "mark"; "gravity"; mark: TextMark] function (TextMark list) mark_names [widget(text); "mark"; "names"] function (TextMark) mark_next [widget(text); "mark"; "next"; index: TextIndex] function (TextMark) mark_previous [widget(text); "mark"; "previous"; index: TextIndex] function () mark_set [widget(text); "mark"; "set"; mark: TextMark; index: TextIndex] function () mark_unset [widget(text); "mark"; "unset"; marks: TextMark list] % Scan function () scan_mark [widget(text); "scan"; "mark"; x: int; y: int] function () scan_dragto [widget(text); "scan"; "dragto"; x: int; y: int] ##ifdef CAMLTK function (Index) search [widget(text); "search"; TextSearch list; "--"; string; TextIndex; TextIndex] ##else function (Index(text) as "[>`Linechar of int * int]") search [widget(text); "search"; switches: TextSearch list; "--"; pattern: string; start: TextIndex; ?stop: [TextIndex]] ##endif function () see [widget(text); "see"; index: TextIndex] % Tags function () tag_add [widget(text); "tag"; "add"; tag: TextTag; start: TextIndex; stop: TextIndex] function () tag_add_char [widget(text); "tag"; "add"; tag: TextTag; index: TextIndex] external tag_bind "builtin/text_tag_bind" function () tag_configure [widget(text); "tag"; "configure"; tag: TextTag; option(texttag) list] function () tag_delete [widget(text); "tag"; "delete"; TextTag list] function () tag_lower [widget(text); "tag"; "lower"; tag: TextTag; ?below: [TextTag]] ##ifdef CAMLTK function () tag_lower_below [widget(text); "tag"; "lower"; TextTag; TextTag] function () tag_lower_bot [widget(text); "tag"; "lower"; TextTag] ##endif function (TextTag list) tag_names [widget(text); "tag"; "names"; ?index: [TextIndex]] ##ifdef CAMLTK function (TextTag list) tag_allnames [widget(text); "tag"; "names"] function (TextTag list) tag_indexnames [widget(text); "tag"; "names"; TextIndex] ##endif ##ifdef CAMLTK function (Index, Index) tag_nextrange [widget(text); "tag"; "nextrange"; TextTag; start: TextIndex; stop: TextIndex] function (Index, Index) tag_prevrange [widget(text); "tag"; "prevrange"; TextTag; start: TextIndex; stop: TextIndex] ##else function (Index(text) as "[>`Linechar of int * int]", Index(text) as "[>`Linechar of int * int]") tag_nextrange [widget(text); "tag"; "nextrange"; tag: TextTag; start: TextIndex; ?stop: [TextIndex]] function (Index(text) as "[>`Linechar of int * int]", Index(text) as "[>`Linechar of int * int]") tag_prevrange [widget(text); "tag"; "prevrange"; tag: TextTag; start: TextIndex; ?stop: [TextIndex]] ##endif function () tag_raise [widget(text); "tag"; "raise"; tag: TextTag; ?above: [TextTag]] ##ifdef CAMLTK function () tag_raise_above [widget(text); "tag"; "raise"; TextTag; TextTag] function () tag_raise_top [widget(text); "tag"; "raise"; TextTag] ##endif ##ifdef CAMLTK function (Index list) tag_ranges [widget(text); "tag"; "ranges"; TextTag] ##else function (Index(text) as "[>`Linechar of int * int]" list) tag_ranges [widget(text); "tag"; "ranges"; tag: TextTag] ##endif function () tag_remove [widget(text); "tag"; "remove"; tag: TextTag; start: TextIndex; stop: TextIndex] function () tag_remove_char [widget(text); "tag"; "remove"; tag: TextTag; index: TextIndex] function () window_configure [widget(text); "window"; "configure"; tag: TextTag; option(embeddedw) list] function () window_create [widget(text); "window"; "create"; index: TextIndex; option(embeddedw) list] function (widget list) window_names [widget(text); "window"; "names"] % scrolling function (float,float) xview_get [widget(text); "xview"] function (float,float) yview_get [widget(text); "yview"] function () xview [widget(text); "xview"; scroll: ScrollValue] function () yview [widget(text); "yview"; scroll: ScrollValue] function () yview_index [widget(text); "yview"; index: TextIndex] function () yview_index_pickplace [widget(text); "yview"; "-pickplace"; index: TextIndex] function () yview_line [widget(text); "yview"; line: int] % obsolete } subtype option(texttag) { Background BgStipple ["-bgstipple"; Bitmap] BorderWidth FgStipple ["-fgstipple"; Bitmap] Font Foreground Justify LMargin1 ["-lmargin1"; Units/int] LMargin2 ["-lmargin2"; Units/int] Offset ["-offset"; Units/int] OverStrike ["-overstrike"; bool] Relief RMargin ["-rmargin"; Units/int] Spacing1 Spacing2 Spacing3 Tabs Underline ["-underline"; bool] Wrap ["-wrap"; WrapMode] } %%%%% tk(n) unsafe function () appname_set ["tk"; "appname"; string] unsafe function (string) appname_get ["tk"; "appname"] function (float) scaling_get ["tk"; "scaling"; ?displayof:["-displayof"; widget]] unsafe function () scaling_set ["tk"; "scaling"; ?displayof:["-displayof"; widget]; float] %%%%% tk_chooseColor(n) subtype option(chooseColor){ InitialColor ["-initialcolor"; Color] Parent ["-parent"; widget] Title ["-title"; string] } function (Color) chooseColor ["tk_chooseColor"; option(chooseColor) list] %%%%% tkwait(n) module Tkwait { function () variable ["tkwait"; "variable"; TextVariable] function () visibility ["tkwait"; "visibility"; widget] function () window ["tkwait"; "window"; widget] } %%%%% toplevel(n) % This module will be renamed "toplevelw" to avoid collision with % Caml Light standard toplevel module. widget toplevel { % Standard options option BorderWidth option Cursor option HighlightBackground option HighlightColor option HighlightThickness option Relief option TakeFocus % Widget specific options option Background ##ifdef CAMLTK option Class ##else option Clas ##endif option Colormap option Container ["-container"; bool] option Height option Menu option Screen ["-screen"; string] option Use ["-use"; string] % must be hexadecimal "0x????" option Visual option Width function () configure [widget(toplevel); "configure"; option(toplevel) list] function (string) configure_get [widget(toplevel); "configure"] } %%%%% update(n) function () update ["update"] function () update_idletasks ["update"; "idletasks"] %%%%% winfo(n) type AtomId { AtomId [int] } module Winfo { unsafe function (AtomId) atom ["winfo"; "atom"; ?displayof:["-displayof"; widget]; string] unsafe function (string) atomname ["winfo"; "atomname"; ?displayof:["-displayof"; widget]; AtomId] ##ifdef CAMLTK unsafe function (AtomId) atom_displayof ["winfo"; "atom"; "-displayof"; widget; string] unsafe function (string) atomname_displayof ["winfo"; "atomname"; "-displayof"; widget; AtomId] ##endif function (int) cells ["winfo"; "cells"; widget] function (widget list) children ["winfo"; "children"; widget] function (string) class_name ["winfo"; "class"; widget] function (bool) colormapfull ["winfo"; "colormapfull"; widget] unsafe function (widget) containing ["winfo"; "containing"; ?displayof:["-displayof"; widget]; x: int; y: int] ##ifdef CAMLTK unsafe function (widget) containing_displayof ["winfo"; "containing"; "-displayof"; widget; int; int] ##endif % addition for applets external contained "builtin/winfo_contained" function (int) depth ["winfo"; "depth"; widget] function (bool) exists ["winfo"; "exists"; widget] function (float) fpixels ["winfo"; "fpixels"; widget; length: Units] function (string) geometry ["winfo"; "geometry"; widget] function (int) height ["winfo"; "height"; widget] unsafe function (string) id ["winfo"; "id"; widget] unsafe function (string list) interps ["winfo"; "interps"; ?displayof:["-displayof"; widget]] ##ifdef CAMLTK unsafe function (string list) interps_displayof ["winfo"; "interps"; "-displayof"; widget] ##endif function (bool) ismapped ["winfo"; "ismapped"; widget] function (string) manager ["winfo"; "manager"; widget] function (string) name ["winfo"; "name"; widget] unsafe function (widget) parent ["winfo"; "parent"; widget] % bogus for top unsafe function (widget) pathname ["winfo"; "pathname"; ?displayof:["-displayof"; widget]; string] ##ifdef CAMLTK unsafe function (widget) pathname_displayof ["winfo"; "pathname"; "-displayof"; widget; string] ##endif function (int) pixels ["winfo"; "pixels"; widget; length: Units] function (int) pointerx ["winfo"; "pointerx"; widget] function (int) pointery ["winfo"; "pointery"; widget] function (int, int) pointerxy ["winfo"; "pointerxy"; widget] function (int) reqheight ["winfo"; "reqheight"; widget] function (int) reqwidth ["winfo"; "reqwidth"; widget] function (int,int,int) rgb ["winfo"; "rgb"; widget; color: Color] function (int) rootx ["winfo"; "rootx"; widget] function (int) rooty ["winfo"; "rooty"; widget] unsafe function (string) screen ["winfo"; "screen"; widget] function (int) screencells ["winfo"; "screencells"; widget] function (int) screendepth ["winfo"; "screendepth"; widget] function (int) screenheight ["winfo"; "screenheight"; widget] function (int) screenmmheight ["winfo"; "screenmmheight"; widget] function (int) screenmmwidth ["winfo"; "screenmmwidth"; widget] function (string) screenvisual ["winfo"; "screenvisual"; widget] function (int) screenwidth ["winfo"; "screenwidth"; widget] unsafe function (string) server ["winfo"; "server"; widget] unsafe function (widget(toplevel)) toplevel ["winfo"; "toplevel"; widget] function (bool) viewable ["winfo"; "viewable"; widget] function (string) visual ["winfo"; "visual"; widget] function (int) visualid ["winfo"; "visualid"; widget] % need special parser function (string) visualsavailable ["winfo"; "visualsavailable"; widget; ?includeids: [int list]] function (int) vrootheight ["winfo"; "vrootheight"; widget] function (int) vrootwidth ["winfo"; "vrootwidth"; widget] function (int) vrootx ["winfo"; "vrootx"; widget] function (int) vrooty ["winfo"; "vrooty"; widget] function (int) width ["winfo"; "width"; widget] function (int) x ["winfo"; "x"; widget] function (int) y ["winfo"; "y"; widget] } %%%%% wm(n) type FocusModel { FocusActive ["active"] FocusPassive ["passive"] } type WmFrom { User ["user"] Program ["program"] } module Wm { %%% Aspect function () aspect_set ["wm"; "aspect"; widget(toplevel); minnum:int; mindenom:int; maxnum:int; maxdenom:int] % aspect: problem with empty return function (int,int,int,int) aspect_get ["wm"; "aspect"; widget(toplevel)] %%% WM_CLIENT_MACHINE function () client_set ["wm"; "client"; widget(toplevel); name: string] function (string) client_get ["wm"; "client"; widget(toplevel)] %%% WM_COLORMAP_WINDOWS function () colormapwindows_set ["wm"; "colormapwindows"; widget(toplevel); [windows: widget list]] unsafe function (widget list) colormapwindows_get ["wm"; "colormapwindows"; widget(toplevel)] %%% WM_COMMAND function () command_clear ["wm"; "command"; widget(toplevel); ""] function () command_set ["wm"; "command"; widget(toplevel); [string list]] function (string list) command_get ["wm"; "command"; widget(toplevel)] function () deiconify ["wm"; "deiconify"; widget(toplevel)] %%% Focus model function () focusmodel_set ["wm"; "focusmodel"; widget(toplevel); FocusModel] function (FocusModel) focusmodel_get ["wm"; "focusmodel"; widget(toplevel)] function (string) frame ["wm"; "frame"; widget(toplevel)] %%% Geometry function () geometry_set ["wm"; "geometry"; widget(toplevel); string] function (string) geometry_get ["wm"; "geometry"; widget(toplevel)] %%% Grid function () grid_clear ["wm"; "grid"; widget(toplevel); ""; ""; ""; ""] function () grid_set ["wm"; "grid"; widget(toplevel); basewidth: int; baseheight: int; widthinc: int; heightinc: int] function (int,int,int,int) grid_get ["wm"; "grid"; widget(toplevel)] %%% Groups function () group_clear ["wm"; "group"; widget(toplevel); ""] function () group_set ["wm"; "group"; widget(toplevel); leader: widget] unsafe function (widget) group_get ["wm"; "group"; widget(toplevel)] %%% Icon bitmap function () iconbitmap_clear ["wm"; "iconbitmap"; widget(toplevel); ""] function () iconbitmap_set ["wm"; "iconbitmap"; widget(toplevel); Bitmap] function (Bitmap) iconbitmap_get ["wm"; "iconbitmap"; widget(toplevel)] function () iconify ["wm"; "iconify"; widget(toplevel)] %%% Icon mask function () iconmask_clear ["wm"; "iconmask"; widget(toplevel); ""] function () iconmask_set ["wm"; "iconmask"; widget(toplevel); Bitmap] function (Bitmap) iconmask_get ["wm"; "iconmask"; widget(toplevel)] %%% Icon name function () iconname_set ["wm"; "iconname"; widget(toplevel); string] function (string) iconname_get ["wm"; "iconname"; widget(toplevel)] %%% Icon position function () iconposition_clear ["wm"; "iconposition"; widget(toplevel); ""; ""] function () iconposition_set ["wm"; "iconposition"; widget(toplevel); x: int; y: int] function (int,int) iconposition_get ["wm"; "iconposition"; widget(toplevel)] %%% Icon window function () iconwindow_clear ["wm"; "iconwindow"; widget(toplevel); ""] function () iconwindow_set ["wm"; "iconwindow"; widget(toplevel); icon: widget(toplevel)] unsafe function (widget(toplevel)) iconwindow_get ["wm"; "iconwindow"; widget(toplevel)] %%% Sizes function () maxsize_set ["wm"; "maxsize"; widget(toplevel); width: int; height: int] function (int,int) maxsize_get ["wm"; "maxsize"; widget(toplevel)] function () minsize_set ["wm"; "minsize"; widget(toplevel); width: int; height: int] function (int,int) minsize_get ["wm"; "minsize"; widget(toplevel)] %%% Override unsafe function () overrideredirect_set ["wm"; "overrideredirect"; widget(toplevel); bool] function (bool) overrideredirect_get ["wm"; "overrideredirect"; widget(toplevel)] %%% Position function () positionfrom_clear ["wm"; "positionfrom"; widget(toplevel); ""] function () positionfrom_set ["wm"; "positionfrom"; widget(toplevel); WmFrom] function (WmFrom) positionfrom_get ["wm"; "positionfrom"; widget(toplevel)] %%% Protocols function () protocol_set ["wm"; "protocol"; widget(toplevel); name: string; command: function()] function () protocol_clear ["wm"; "protocol"; widget(toplevel); name: string; ""] function (string list) protocols ["wm"; "protocol"; widget(toplevel)] %%% Resize function () resizable_set ["wm"; "resizable"; widget(toplevel); width: bool; height: bool] function (bool, bool) resizable_get ["wm"; "resizable"; widget(toplevel)] %%% Sizefrom function () sizefrom_clear ["wm"; "sizefrom"; widget(toplevel); ""] function () sizefrom_set ["wm"; "sizefrom"; widget(toplevel); WmFrom] function (WmFrom) sizefrom_get ["wm"; "sizefrom"; widget(toplevel)] function (string) state ["wm"; "state"; widget(toplevel)] %%% Title function (string) title_get ["wm"; "title"; widget(toplevel)] function () title_set ["wm"; "title"; widget(toplevel); string] %%% Transient function () transient_clear ["wm"; "transient"; widget(toplevel); ""] function () transient_set ["wm"; "transient"; widget(toplevel); master: widget] unsafe function (widget) transient_get ["wm"; "transient"; widget(toplevel)] function () withdraw ["wm"; "withdraw"; widget(toplevel)] } %%%%% tk_getOpenFile(n) (since version 8.0) type FilePattern external subtype option(getFile) { DefaultExtension ["-defaultextension"; string] FileTypes ["-filetypes"; [FilePattern list]] InitialDir ["-initialdir"; string] InitialFile ["-initialfile"; string] Parent ["-parent"; widget] Title ["-title"; string] } function (string) getOpenFile ["tk_getOpenFile"; option(getFile) list] function (string) getSaveFile ["tk_getSaveFile"; option(getFile) list] %%%%% tk_messageBox type MessageIcon { Error ["error"] Info ["info"] Question ["question"] Warning ["warning"] } type MessageType { AbortRetryIgnore ["abortretryignore"] Ok ["ok"] OkCancel ["okcancel"] RetryCancel ["retrycancel"] YesNo ["yesno"] YesNoCancel ["yesnocancel"] } subtype option(messageBox) { MessageDefault ["-default"; string] MessageIcon ["-icon"; MessageIcon] Message ["-message"; string] Parent Title MessageType ["-type"; MessageType] } function (string) messageBox ["tk_messageBox"; option(messageBox) list] module Tkvars { function (string) library ["$tk_library"] function (string) patchLevel ["$tk_patchLevel"] function (bool) strictMotif ["$tk_strictMotif"] function () set_strictMotif ["set"; "tk_strictMotif"; bool] function (string) version ["$tk_version"] } % Direct API calls, non Tcl-based modules module Pixmap { external create "builtin/rawimg" } %%% encodings : require if you want write your application international module Encoding { function (string) convertfrom ["encoding"; "convertfrom"; ?encoding: [string]; string] function (string) convertto ["encoding"; "convertto"; ?encoding: [string]; string] function (string list) names ["encoding"; "names"] function () system_set ["encoding"; "system"; string] function (string) system_get ["encoding"; "system"] } mingw-ocaml/ocaml/otherlibs/labltk/Changes0000644000175000017500000000106512124403241020217 0ustar tootstoots2005-12-20: ----------- * Add Protocol.do_one_event and Protocol.do_pending. 2002-05-03: ----------- General Changes * Merging CamlTk and LablTk API interfaces * Activate and Deactivate Events are added * Virtual events support * Added UTF conversion Incompatibilities between the previous camltk/labltk versions * CamlTk's bind_tag and bind_class superseded tag_bind and class_bind. * added optional arguments to some functions of CamlTk. * The library name libfrx and libjpf are changed to frxlib and jpflib respectively, to avoid the library name confusion. mingw-ocaml/ocaml/otherlibs/labltk/example/0000755000175000017500000000000012124403241020355 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/example/.gitignore0000644000175000017500000000000012124403241022333 0ustar tootstootsmingw-ocaml/ocaml/otherlibs/labltk/labl.gif0000644000175000017500000000277512124403241020336 0ustar tootstootsGIF89a9.Ǿuuuuqm}yu}}]Q 1Db= Ξ ePD~PԢ1)<",IG.}^ 9A3AZ@stDApӝyKeZ<8T g$k8P5ڱ\ʀBLJ}%"/t]J;mingw-ocaml/ocaml/otherlibs/threads/0000755000175000017500000000000012124403241017103 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/threads/.ignore0000644000175000017500000000004412124403241020365 0ustar tootstootsmarshal.mli pervasives.mli unix.mli mingw-ocaml/ocaml/otherlibs/threads/condition.ml0000644000175000017500000000265612124403241021434 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) type t = { mutable waiting: Thread.t list } let create () = { waiting = [] } let wait cond mut = Thread.critical_section := true; Mutex.unlock mut; cond.waiting <- Thread.self() :: cond.waiting; Thread.sleep(); Mutex.lock mut let signal cond = match cond.waiting with (* atomic *) [] -> () | th :: rem -> cond.waiting <- rem (* atomic *); Thread.wakeup th let broadcast cond = let w = cond.waiting in (* atomic *) cond.waiting <- []; (* atomic *) List.iter Thread.wakeup w mingw-ocaml/ocaml/otherlibs/threads/Tests/0000755000175000017500000000000012124403241020205 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/threads/Tests/.gitignore0000644000175000017500000000000012124403241022163 0ustar tootstootsmingw-ocaml/ocaml/otherlibs/threads/mutex.mli0000644000175000017500000000365212124403241020756 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Locks for mutual exclusion. Mutexes (mutual-exclusion locks) are used to implement critical sections and protect shared mutable data structures against concurrent accesses. The typical use is (if [m] is the mutex associated with the data structure [D]): {[ Mutex.lock m; (* Critical section that operates over D *); Mutex.unlock m ]} *) type t (** The type of mutexes. *) val create : unit -> t (** Return a new mutex. *) val lock : t -> unit (** Lock the given mutex. Only one thread can have the mutex locked at any time. A thread that attempts to lock a mutex already locked by another thread will suspend until the other thread unlocks the mutex. *) val try_lock : t -> bool (** Same as {!Mutex.lock}, but does not suspend the calling thread if the mutex is already locked: just return [false] immediately in that case. If the mutex is unlocked, lock it and return [true]. *) val unlock : t -> unit (** Unlock the given mutex. Other threads suspended trying to lock the mutex will restart. *) mingw-ocaml/ocaml/otherlibs/threads/event.mli0000644000175000017500000000676512124403241020745 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** First-class synchronous communication. This module implements synchronous inter-thread communications over channels. As in John Reppy's Concurrent ML system, the communication events are first-class values: they can be built and combined independently before being offered for communication. *) type 'a channel (** The type of communication channels carrying values of type ['a]. *) val new_channel : unit -> 'a channel (** Return a new channel. *) type +'a event (** The type of communication events returning a result of type ['a]. *) (** [send ch v] returns the event consisting in sending the value [v] over the channel [ch]. The result value of this event is [()]. *) val send : 'a channel -> 'a -> unit event (** [receive ch] returns the event consisting in receiving a value from the channel [ch]. The result value of this event is the value received. *) val receive : 'a channel -> 'a event val always : 'a -> 'a event (** [always v] returns an event that is always ready for synchronization. The result value of this event is [v]. *) val choose : 'a event list -> 'a event (** [choose evl] returns the event that is the alternative of all the events in the list [evl]. *) val wrap : 'a event -> ('a -> 'b) -> 'b event (** [wrap ev fn] returns the event that performs the same communications as [ev], then applies the post-processing function [fn] on the return value. *) val wrap_abort : 'a event -> (unit -> unit) -> 'a event (** [wrap_abort ev fn] returns the event that performs the same communications as [ev], but if it is not selected the function [fn] is called after the synchronization. *) val guard : (unit -> 'a event) -> 'a event (** [guard fn] returns the event that, when synchronized, computes [fn()] and behaves as the resulting event. This allows events with side-effects to be computed at the time of the synchronization operation. *) val sync : 'a event -> 'a (** ``Synchronize'' on an event: offer all the communication possibilities specified in the event to the outside world, and block until one of the communications succeed. The result value of that communication is returned. *) val select : 'a event list -> 'a (** ``Synchronize'' on an alternative of events. [select evl] is shorthand for [sync(choose evl)]. *) val poll : 'a event -> 'a option (** Non-blocking version of {!Event.sync}: offer all the communication possibilities specified in the event to the outside world, and if one can take place immediately, perform it and return [Some r] where [r] is the result value of that communication. Otherwise, return [None] without blocking. *) mingw-ocaml/ocaml/otherlibs/threads/threadUnix.mli0000644000175000017500000000713612124403241021730 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Thread-compatible system calls. @deprecated The functionality of this module has been merged back into the {!Unix} module. Threaded programs can now call the functions from module {!Unix} directly, and still get the correct behavior (block the calling thread, if required, but do not block all threads in the process). *) (** {6 Process handling} *) val execv : string -> string array -> unit val execve : string -> string array -> string array -> unit val execvp : string -> string array -> unit val wait : unit -> int * Unix.process_status val waitpid : Unix.wait_flag list -> int -> int * Unix.process_status val system : string -> Unix.process_status (** {6 Basic input/output} *) val read : Unix.file_descr -> string -> int -> int -> int val write : Unix.file_descr -> string -> int -> int -> int val single_write : Unix.file_descr -> string -> int -> int -> int (** {6 Input/output with timeout} *) val timed_read : Unix.file_descr -> string -> int -> int -> float -> int (** See {!ThreadUnix.timed_write}. *) val timed_write : Unix.file_descr -> string -> int -> int -> float -> int (** Behave as {!ThreadUnix.read} and {!ThreadUnix.write}, except that [Unix_error(ETIMEDOUT,_,_)] is raised if no data is available for reading or ready for writing after [d] seconds. The delay [d] is given in the fifth argument, in seconds. *) (** {6 Polling} *) val select : Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list * Unix.file_descr list (** {6 Pipes and redirections} *) val pipe : unit -> Unix.file_descr * Unix.file_descr val open_process_in : string -> in_channel val open_process_out : string -> out_channel val open_process : string -> in_channel * out_channel val open_process_full : string -> string array -> in_channel * out_channel * in_channel (** {6 Time} *) val sleep : int -> unit (** {6 Sockets} *) val socket : Unix.socket_domain -> Unix.socket_type -> int -> Unix.file_descr val socketpair : Unix.socket_domain -> Unix.socket_type -> int -> Unix.file_descr * Unix.file_descr val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr val connect : Unix.file_descr -> Unix.sockaddr -> unit val recv : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int val recvfrom : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr val send : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int val sendto : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int val open_connection : Unix.sockaddr -> in_channel * out_channel val establish_server : (in_channel -> out_channel -> unit) -> Unix.sockaddr -> unit mingw-ocaml/ocaml/otherlibs/threads/event.ml0000644000175000017500000002125012124403241020556 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Events *) type 'a basic_event = { poll: unit -> bool; (* If communication can take place immediately, return true. *) suspend: unit -> unit; (* Offer the communication on the channel and get ready to suspend current process. *) result: unit -> 'a } (* Return the result of the communication *) type 'a behavior = int ref -> Condition.t -> int -> 'a basic_event type 'a event = Communication of 'a behavior | Choose of 'a event list | WrapAbort of 'a event * (unit -> unit) | Guard of (unit -> 'a event) (* Communication channels *) type 'a channel = { mutable writes_pending: 'a communication Queue.t; (* All offers to write on it *) mutable reads_pending: 'a communication Queue.t } (* All offers to read from it *) (* Communication offered *) and 'a communication = { performed: int ref; (* -1 if not performed yet, set to the number *) (* of the matching communication after rendez-vous. *) condition: Condition.t; (* To restart the blocked thread. *) mutable data: 'a option; (* The data sent or received. *) event_number: int } (* Event number in select *) (* Create a channel *) let new_channel () = { writes_pending = Queue.create(); reads_pending = Queue.create() } (* Basic synchronization function *) let masterlock = Mutex.create() let do_aborts abort_env genev performed = if abort_env <> [] then begin if performed >= 0 then begin let ids_done = snd genev.(performed) in List.iter (fun (id,f) -> if not (List.mem id ids_done) then f ()) abort_env end else begin List.iter (fun (_,f) -> f ()) abort_env end end let basic_sync abort_env genev = let performed = ref (-1) in let condition = Condition.create() in let bev = Array.create (Array.length genev) (fst (genev.(0)) performed condition 0) in for i = 1 to Array.length genev - 1 do bev.(i) <- (fst genev.(i)) performed condition i done; (* See if any of the events is already activable *) let rec poll_events i = if i >= Array.length bev then false else bev.(i).poll() || poll_events (i+1) in Mutex.lock masterlock; if not (poll_events 0) then begin (* Suspend on all events *) for i = 0 to Array.length bev - 1 do bev.(i).suspend() done; (* Wait until the condition is signalled *) Condition.wait condition masterlock end; Mutex.unlock masterlock; (* Extract the result *) if abort_env = [] then (* Preserve tail recursion *) bev.(!performed).result() else begin let num = !performed in let result = bev.(num).result() in (* Handle the aborts and return the result *) do_aborts abort_env genev num; result end (* Apply a random permutation on an array *) let scramble_array a = let len = Array.length a in if len = 0 then invalid_arg "Event.choose"; for i = len - 1 downto 1 do let j = Random.int (i + 1) in let temp = a.(i) in a.(i) <- a.(j); a.(j) <- temp done; a (* Main synchronization function *) let gensym = let count = ref 0 in fun () -> incr count; !count let rec flatten_event (abort_list : int list) (accu : ('a behavior * int list) list) (accu_abort : (int * (unit -> unit)) list) ev = match ev with Communication bev -> ((bev,abort_list) :: accu) , accu_abort | WrapAbort (ev,fn) -> let id = gensym () in flatten_event (id :: abort_list) accu ((id,fn)::accu_abort) ev | Choose evl -> let rec flatten_list accu' accu_abort'= function ev :: l -> let (accu'',accu_abort'') = flatten_event abort_list accu' accu_abort' ev in flatten_list accu'' accu_abort'' l | [] -> (accu',accu_abort') in flatten_list accu accu_abort evl | Guard fn -> flatten_event abort_list accu accu_abort (fn ()) let sync ev = let (evl,abort_env) = flatten_event [] [] [] ev in basic_sync abort_env (scramble_array(Array.of_list evl)) (* Event polling -- like sync, but non-blocking *) let basic_poll abort_env genev = let performed = ref (-1) in let condition = Condition.create() in let bev = Array.create(Array.length genev) (fst genev.(0) performed condition 0) in for i = 1 to Array.length genev - 1 do bev.(i) <- fst genev.(i) performed condition i done; (* See if any of the events is already activable *) let rec poll_events i = if i >= Array.length bev then false else bev.(i).poll() || poll_events (i+1) in Mutex.lock masterlock; let ready = poll_events 0 in if ready then begin (* Extract the result *) Mutex.unlock masterlock; let result = Some(bev.(!performed).result()) in do_aborts abort_env genev !performed; result end else begin (* Cancel the communication offers *) performed := 0; Mutex.unlock masterlock; do_aborts abort_env genev (-1); None end let poll ev = let (evl,abort_env) = flatten_event [] [] [] ev in basic_poll abort_env (scramble_array(Array.of_list evl)) (* Remove all communication opportunities already synchronized *) let cleanup_queue q = let q' = Queue.create() in Queue.iter (fun c -> if !(c.performed) = -1 then Queue.add c q') q; q' (* Event construction *) let always data = Communication(fun performed condition evnum -> { poll = (fun () -> performed := evnum; true); suspend = (fun () -> ()); result = (fun () -> data) }) let send channel data = Communication(fun performed condition evnum -> let wcomm = { performed = performed; condition = condition; data = Some data; event_number = evnum } in { poll = (fun () -> let rec poll () = let rcomm = Queue.take channel.reads_pending in if !(rcomm.performed) >= 0 then poll () else begin rcomm.data <- wcomm.data; performed := evnum; rcomm.performed := rcomm.event_number; Condition.signal rcomm.condition end in try poll(); true with Queue.Empty -> false); suspend = (fun () -> channel.writes_pending <- cleanup_queue channel.writes_pending; Queue.add wcomm channel.writes_pending); result = (fun () -> ()) }) let receive channel = Communication(fun performed condition evnum -> let rcomm = { performed = performed; condition = condition; data = None; event_number = evnum } in { poll = (fun () -> let rec poll () = let wcomm = Queue.take channel.writes_pending in if !(wcomm.performed) >= 0 then poll () else begin rcomm.data <- wcomm.data; performed := evnum; wcomm.performed := wcomm.event_number; Condition.signal wcomm.condition end in try poll(); true with Queue.Empty -> false); suspend = (fun () -> channel.reads_pending <- cleanup_queue channel.reads_pending; Queue.add rcomm channel.reads_pending); result = (fun () -> match rcomm.data with None -> invalid_arg "Event.receive" | Some res -> res) }) let choose evl = Choose evl let wrap_abort ev fn = WrapAbort(ev,fn) let guard fn = Guard fn let rec wrap ev fn = match ev with Communication genev -> Communication(fun performed condition evnum -> let bev = genev performed condition evnum in { poll = bev.poll; suspend = bev.suspend; result = (fun () -> fn(bev.result())) }) | Choose evl -> Choose(List.map (fun ev -> wrap ev fn) evl) | WrapAbort (ev, f') -> WrapAbort (wrap ev fn, f') | Guard gu -> Guard(fun () -> wrap (gu()) fn) (* Convenience functions *) let select evl = sync(Choose evl) mingw-ocaml/ocaml/otherlibs/threads/Makefile0000644000175000017500000001030212124403241020537 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ include ../../config/Makefile CC=$(BYTECC) CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -g CAMLC=../../ocamlcomp.sh -I ../unix MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib COMPFLAGS=-warn-error A C_OBJS=scheduler.o CAML_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo LIB=../../stdlib LIB_OBJS=pervasives.cmo \ $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/string.cmo \ $(LIB)/sys.cmo $(LIB)/sort.cmo marshal.cmo $(LIB)/obj.cmo \ $(LIB)/int32.cmo $(LIB)/int64.cmo $(LIB)/nativeint.cmo \ $(LIB)/lexing.cmo $(LIB)/parsing.cmo $(LIB)/set.cmo $(LIB)/map.cmo \ $(LIB)/stack.cmo $(LIB)/queue.cmo $(LIB)/camlinternalLazy.cmo \ $(LIB)/lazy.cmo $(LIB)/stream.cmo $(LIB)/buffer.cmo \ $(LIB)/printf.cmo $(LIB)/arg.cmo $(LIB)/printexc.cmo $(LIB)/gc.cmo \ $(LIB)/digest.cmo $(LIB)/random.cmo $(LIB)/hashtbl.cmo \ $(LIB)/format.cmo $(LIB)/scanf.cmo $(LIB)/callback.cmo \ $(LIB)/camlinternalOO.cmo \ $(LIB)/oo.cmo $(LIB)/camlinternalMod.cmo $(LIB)/genlex.cmo \ $(LIB)/weak.cmo $(LIB)/filename.cmo \ $(LIB)/complex.cmo $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo \ $(LIB)/stringLabels.cmo $(LIB)/stdLabels.cmo $(LIB)/moreLabels.cmo UNIXLIB=../unix UNIXLIB_OBJS=unix.cmo $(UNIXLIB)/unixLabels.cmo all: libvmthreads.a threads.cma stdlib.cma unix.cma allopt: libvmthreads.a: $(C_OBJS) $(MKLIB) -o threads -oc vmthreads $(C_OBJS) threads.cma: $(CAML_OBJS) $(MKLIB) -ocamlc '$(CAMLC)' -o threads -oc vmthreads $(CAML_OBJS) stdlib.cma: $(LIB_OBJS) $(CAMLC) -a -o stdlib.cma $(LIB_OBJS) unix.cma: $(UNIXLIB_OBJS) $(MKLIB) -ocamlc '$(CAMLC)' -o unix -linkall $(UNIXLIB_OBJS) pervasives.cmo: pervasives.mli pervasives.cmi pervasives.ml $(CAMLC) ${COMPFLAGS} -nopervasives -c pervasives.ml pervasives.mli: $(LIB)/pervasives.mli ln -s $(LIB)/pervasives.mli pervasives.mli pervasives.cmi: $(LIB)/pervasives.cmi ln -s $(LIB)/pervasives.cmi pervasives.cmi marshal.cmo: marshal.mli marshal.cmi marshal.ml $(CAMLC) ${COMPFLAGS} -c marshal.ml marshal.mli: $(LIB)/marshal.mli ln -s $(LIB)/marshal.mli marshal.mli marshal.cmi: $(LIB)/marshal.cmi ln -s $(LIB)/marshal.cmi marshal.cmi unix.mli: $(UNIXLIB)/unix.mli ln -s -f $(UNIXLIB)/unix.mli unix.mli unix.cmi: $(UNIXLIB)/unix.cmi ln -s -f $(UNIXLIB)/unix.cmi unix.cmi unix.cmo: unix.mli unix.cmi $(UNIXLIB)/unixLabels.cmo $(CAMLC) ${COMPFLAGS} -c unix.ml partialclean: rm -f *.cm* clean: partialclean rm -f libvmthreads.a dllvmthreads.so *.o rm -f pervasives.mli marshal.mli unix.mli install: if test -f dllvmthreads.so; then cp dllvmthreads.so $(STUBLIBDIR)/.; fi mkdir -p $(LIBDIR)/vmthreads cp libvmthreads.a $(LIBDIR)/vmthreads/libvmthreads.a cd $(LIBDIR)/vmthreads; $(RANLIB) libvmthreads.a cp thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi threads.cma stdlib.cma unix.cma $(LIBDIR)/vmthreads cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli $(LIBDIR)/vmthreads installopt: .SUFFIXES: .ml .mli .cmo .cmi .cmx .mli.cmi: $(CAMLC) -c $(COMPFLAGS) $< .ml.cmo: $(CAMLC) -c $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< depend: gcc -MM $(CFLAGS) *.c > .depend ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend include .depend mingw-ocaml/ocaml/otherlibs/threads/mutex.ml0000644000175000017500000000326312124403241020603 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) type t = { mutable locked: bool; mutable waiting: Thread.t list } let create () = { locked = false; waiting = [] } let rec lock m = if m.locked then begin (* test and set atomic *) Thread.critical_section := true; m.waiting <- Thread.self() :: m.waiting; Thread.sleep(); lock m end else begin m.locked <- true (* test and set atomic *) end let try_lock m = (* test and set atomic *) if m.locked then false else begin m.locked <- true; true end let unlock m = (* Don't play with Thread.critical_section here because of Condition.wait *) let w = m.waiting in (* atomic *) m.waiting <- []; (* atomic *) m.locked <- false; (* atomic *) List.iter Thread.wakeup w mingw-ocaml/ocaml/otherlibs/threads/thread.ml0000644000175000017500000001242312124403241020706 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* User-level threads *) type t let critical_section = ref false type resumption_status = Resumed_wakeup | Resumed_delay | Resumed_join | Resumed_io | Resumed_select of Unix.file_descr list * Unix.file_descr list * Unix.file_descr list | Resumed_wait of int * Unix.process_status (* It is mucho important that the primitives that reschedule are called through an ML function call, not directly. That's because when such a primitive returns, the bytecode interpreter is only semi-obedient: it takes sp from the new thread, but keeps pc from the old thread. But that's OK if all calls to rescheduling primitives are immediately followed by a RETURN operation, which will restore the correct pc from the stack. Furthermore, the RETURNs must all have the same frame size, which means that both the primitives and their ML wrappers must take exactly one argument. *) external thread_initialize : unit -> unit = "thread_initialize" external thread_initialize_preemption : unit -> unit = "thread_initialize_preemption" external thread_new : (unit -> unit) -> t = "thread_new" external thread_yield : unit -> unit = "thread_yield" external thread_request_reschedule : unit -> unit = "thread_request_reschedule" external thread_sleep : unit -> unit = "thread_sleep" external thread_wait_read : Unix.file_descr -> unit = "thread_wait_read" external thread_wait_write : Unix.file_descr -> unit = "thread_wait_write" external thread_wait_timed_read : Unix.file_descr * float -> resumption_status (* remember: 1 arg *) = "thread_wait_timed_read" external thread_wait_timed_write : Unix.file_descr * float -> resumption_status (* remember: 1 arg *) = "thread_wait_timed_write" external thread_select : Unix.file_descr list * Unix.file_descr list * (* remember: 1 arg *) Unix.file_descr list * float -> resumption_status = "thread_select" external thread_join : t -> unit = "thread_join" external thread_delay : float -> unit = "thread_delay" external thread_wait_pid : int -> resumption_status = "thread_wait_pid" external thread_wakeup : t -> unit = "thread_wakeup" external thread_self : unit -> t = "thread_self" external thread_kill : t -> unit = "thread_kill" external thread_uncaught_exception : exn -> unit = "thread_uncaught_exception" external id : t -> int = "thread_id" (* In sleep() below, we rely on the fact that signals are detected only at function applications and beginning of loops, making all other operations atomic. *) let yield () = thread_yield() let sleep () = critical_section := false; thread_sleep() let delay duration = thread_delay duration let join th = thread_join th let wakeup pid = thread_wakeup pid let self () = thread_self() let kill pid = thread_kill pid let exit () = thread_kill(thread_self()) let select_aux arg = thread_select arg let select readfds writefds exceptfds delay = match select_aux (readfds, writefds, exceptfds, delay) with Resumed_select(r, w, e) -> (r, w, e) | _ -> ([], [], []) let wait_read fd = thread_wait_read fd let wait_write fd = thread_wait_write fd let wait_timed_read_aux arg = thread_wait_timed_read arg let wait_timed_write_aux arg = thread_wait_timed_write arg let wait_timed_read fd delay = match wait_timed_read_aux (fd, delay) with Resumed_io -> true | _ -> false let wait_timed_write fd delay = match wait_timed_write_aux (fd, delay) with Resumed_io -> true | _ -> false let wait_pid_aux pid = thread_wait_pid pid let wait_pid pid = match wait_pid_aux pid with Resumed_wait(pid, status) -> (pid, status) | _ -> invalid_arg "Thread.wait_pid" let wait_signal sigs = let gotsig = ref 0 in let self = thread_self() in let sighandler s = gotsig := s; wakeup self in let oldhdlrs = List.map (fun s -> Sys.signal s (Sys.Signal_handle sighandler)) sigs in if !gotsig = 0 then sleep(); List.iter2 Sys.set_signal sigs oldhdlrs; !gotsig (* For Thread.create, make sure the function passed to thread_new always terminates by calling Thread.exit. *) let create fn arg = thread_new (fun () -> try fn arg; exit() with x -> flush stdout; flush stderr; thread_uncaught_exception x; exit()) (* Preemption *) let preempt signal = if !critical_section then () else thread_request_reschedule() (* Initialization of the scheduler *) let _ = thread_initialize(); Sys.set_signal Sys.sigvtalrm (Sys.Signal_handle preempt); thread_initialize_preemption() mingw-ocaml/ocaml/otherlibs/threads/threadUnix.ml0000644000175000017500000000447012124403241021555 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [ThreadUnix]: thread-compatible system calls *) let execv = Unix.execv let execve = Unix.execve let execvp = Unix.execvp let wait = Unix.wait let waitpid = Unix.waitpid let system = Unix.system let read = Unix.read let write = Unix.write let single_write = Unix.single_write let select = Unix.select let pipe = Unix.pipe let open_process_in = Unix.open_process_in let open_process_out = Unix.open_process_out let open_process = Unix.open_process let open_process_full = Unix.open_process_full let sleep = Unix.sleep let socket = Unix.socket let socketpair = Unix.socketpair let accept = Unix.accept let connect = Unix.connect let recv = Unix.recv let recvfrom = Unix.recvfrom let send = Unix.send let sendto = Unix.sendto let open_connection = Unix.open_connection let establish_server = Unix.establish_server open Unix let rec timed_read fd buff ofs len timeout = if Thread.wait_timed_read fd timeout then begin try Unix.read fd buff ofs len with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> timed_read fd buff ofs len timeout end else raise (Unix_error(ETIMEDOUT, "timed_read", "")) let rec timed_write fd buff ofs len timeout = if Thread.wait_timed_write fd timeout then begin try Unix.write fd buff ofs len with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> timed_write fd buff ofs len timeout end else raise (Unix_error(ETIMEDOUT, "timed_write", "")) mingw-ocaml/ocaml/otherlibs/threads/pervasives.ml0000644000175000017500000004271312124403241021633 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Same as ../../stdlib/pervasives.ml, except that I/O functions have been redefined to not block the whole process, but only the calling thread. *) (* type 'a option = None | Some of 'a *) (* Exceptions *) external raise : exn -> 'a = "%raise" let failwith s = raise(Failure s) let invalid_arg s = raise(Invalid_argument s) exception Exit (* Comparisons *) external (=) : 'a -> 'a -> bool = "%equal" external (<>) : 'a -> 'a -> bool = "%notequal" external (<) : 'a -> 'a -> bool = "%lessthan" external (>) : 'a -> 'a -> bool = "%greaterthan" external (<=) : 'a -> 'a -> bool = "%lessequal" external (>=) : 'a -> 'a -> bool = "%greaterequal" external compare: 'a -> 'a -> int = "%compare" let min x y = if x <= y then x else y let max x y = if x >= y then x else y external (==) : 'a -> 'a -> bool = "%eq" external (!=) : 'a -> 'a -> bool = "%noteq" (* Boolean operations *) external not : bool -> bool = "%boolnot" external (&) : bool -> bool -> bool = "%sequand" external (&&) : bool -> bool -> bool = "%sequand" external (or) : bool -> bool -> bool = "%sequor" external (||) : bool -> bool -> bool = "%sequor" (* Integer operations *) external (~-) : int -> int = "%negint" external (~+) : int -> int = "%identity" external succ : int -> int = "%succint" external pred : int -> int = "%predint" external (+) : int -> int -> int = "%addint" external (-) : int -> int -> int = "%subint" external ( * ) : int -> int -> int = "%mulint" external (/) : int -> int -> int = "%divint" external (mod) : int -> int -> int = "%modint" let abs x = if x >= 0 then x else -x external (land) : int -> int -> int = "%andint" external (lor) : int -> int -> int = "%orint" external (lxor) : int -> int -> int = "%xorint" let lnot x = x lxor (-1) external (lsl) : int -> int -> int = "%lslint" external (lsr) : int -> int -> int = "%lsrint" external (asr) : int -> int -> int = "%asrint" let min_int = 1 lsl (if 1 lsl 31 = 0 then 30 else 62) let max_int = min_int - 1 (* Floating-point operations *) external (~-.) : float -> float = "%negfloat" external (~+.) : float -> float = "%identity" external (+.) : float -> float -> float = "%addfloat" external (-.) : float -> float -> float = "%subfloat" external ( *. ) : float -> float -> float = "%mulfloat" external (/.) : float -> float -> float = "%divfloat" external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float" external exp : float -> float = "caml_exp_float" "exp" "float" external expm1 : float -> float = "caml_expm1_float" "caml_expm1" "float" external acos : float -> float = "caml_acos_float" "acos" "float" external asin : float -> float = "caml_asin_float" "asin" "float" external atan : float -> float = "caml_atan_float" "atan" "float" external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float" external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot" "float" external cos : float -> float = "caml_cos_float" "cos" "float" external cosh : float -> float = "caml_cosh_float" "cosh" "float" external log : float -> float = "caml_log_float" "log" "float" external log10 : float -> float = "caml_log10_float" "log10" "float" external log1p : float -> float = "caml_log1p_float" "caml_log1p" "float" external sin : float -> float = "caml_sin_float" "sin" "float" external sinh : float -> float = "caml_sinh_float" "sinh" "float" external sqrt : float -> float = "caml_sqrt_float" "sqrt" "float" external tan : float -> float = "caml_tan_float" "tan" "float" external tanh : float -> float = "caml_tanh_float" "tanh" "float" external ceil : float -> float = "caml_ceil_float" "ceil" "float" external floor : float -> float = "caml_floor_float" "floor" "float" external abs_float : float -> float = "%absfloat" external copysign : float -> float -> float = "caml_copysign_float" "caml_copysign" "float" external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float" external frexp : float -> float * int = "caml_frexp_float" external ldexp : float -> int -> float = "caml_ldexp_float" external modf : float -> float * float = "caml_modf_float" external float : int -> float = "%floatofint" external float_of_int : int -> float = "%floatofint" external truncate : float -> int = "%intoffloat" external int_of_float : float -> int = "%intoffloat" external float_of_bits : int64 -> float = "caml_int64_float_of_bits" let infinity = float_of_bits 0x7F_F0_00_00_00_00_00_00L let neg_infinity = float_of_bits 0xFF_F0_00_00_00_00_00_00L let nan = float_of_bits 0x7F_F0_00_00_00_00_00_01L let max_float = float_of_bits 0x7F_EF_FF_FF_FF_FF_FF_FFL let min_float = float_of_bits 0x00_10_00_00_00_00_00_00L let epsilon_float = float_of_bits 0x3C_B0_00_00_00_00_00_00L type fpclass = FP_normal | FP_subnormal | FP_zero | FP_infinite | FP_nan external classify_float: float -> fpclass = "caml_classify_float" (* String operations -- more in module String *) external string_length : string -> int = "%string_length" external string_create: int -> string = "caml_create_string" external string_blit : string -> int -> string -> int -> int -> unit = "caml_blit_string" "noalloc" let (^) s1 s2 = let l1 = string_length s1 and l2 = string_length s2 in let s = string_create (l1 + l2) in string_blit s1 0 s 0 l1; string_blit s2 0 s l1 l2; s (* Character operations -- more in module Char *) external int_of_char : char -> int = "%identity" external unsafe_char_of_int : int -> char = "%identity" let char_of_int n = if n < 0 || n > 255 then invalid_arg "char_of_int" else unsafe_char_of_int n (* Unit operations *) external ignore : 'a -> unit = "%ignore" (* Pair operations *) external fst : 'a * 'b -> 'a = "%field0" external snd : 'a * 'b -> 'b = "%field1" (* References *) type 'a ref = { mutable contents: 'a } external ref: 'a -> 'a ref = "%makemutable" external (!): 'a ref -> 'a = "%field0" external (:=): 'a ref -> 'a -> unit = "%setfield0" external incr: int ref -> unit = "%incr" external decr: int ref -> unit = "%decr" (* String conversion functions *) external format_int: string -> int -> string = "caml_format_int" external format_float: string -> float -> string = "caml_format_float" let string_of_bool b = if b then "true" else "false" let bool_of_string = function | "true" -> true | "false" -> false | _ -> invalid_arg "bool_of_string" let string_of_int n = format_int "%d" n external int_of_string : string -> int = "caml_int_of_string" let valid_float_lexem s = let l = string_length s in let rec loop i = if i >= l then s ^ "." else match s.[i] with | '0' .. '9' | '-' -> loop (i+1) | _ -> s in loop 0 ;; let string_of_float f = valid_float_lexem (format_float "%.12g" f);; external float_of_string : string -> float = "caml_float_of_string" (* List operations -- more in module List *) let rec (@) l1 l2 = match l1 with [] -> l2 | hd :: tl -> hd :: (tl @ l2) (* I/O operations *) type in_channel type out_channel external open_descriptor_out: int -> out_channel = "caml_ml_open_descriptor_out" external open_descriptor_in: int -> in_channel = "caml_ml_open_descriptor_in" let stdin = open_descriptor_in 0 let stdout = open_descriptor_out 1 let stderr = open_descriptor_out 2 (* Non-blocking stuff *) external thread_wait_read_prim : Unix.file_descr -> unit = "thread_wait_read" external thread_wait_write_prim : Unix.file_descr -> unit = "thread_wait_write" let thread_wait_read fd = thread_wait_read_prim fd let thread_wait_write fd = thread_wait_write_prim fd external descr_inchan : in_channel -> Unix.file_descr = "caml_channel_descriptor" external descr_outchan : out_channel -> Unix.file_descr = "caml_channel_descriptor" let wait_inchan ic = thread_wait_read (descr_inchan ic) let wait_outchan oc len = thread_wait_write (descr_outchan oc) (* General output functions *) type open_flag = Open_rdonly | Open_wronly | Open_append | Open_creat | Open_trunc | Open_excl | Open_binary | Open_text | Open_nonblock external open_desc: string -> open_flag list -> int -> int = "caml_sys_open" let open_out_gen mode perm name = open_descriptor_out(open_desc name mode perm) let open_out name = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name let open_out_bin name = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name external flush_partial : out_channel -> bool = "caml_ml_flush_partial" let rec flush oc = let success = try flush_partial oc with Sys_blocked_io -> wait_outchan oc (-1); false in if success then () else flush oc external out_channels_list : unit -> out_channel list = "caml_ml_out_channels_list" let flush_all () = let rec iter = function [] -> () | a::l -> begin try flush a with Sys_error _ -> () (* ignore channels closed during a preceding flush. *) end; iter l in iter (out_channels_list ()) external unsafe_output_partial : out_channel -> string -> int -> int -> int = "caml_ml_output_partial" let rec unsafe_output oc buf pos len = if len > 0 then begin let written = try unsafe_output_partial oc buf pos len with Sys_blocked_io -> wait_outchan oc len; 0 in unsafe_output oc buf (pos + written) (len - written) end external output_char_blocking : out_channel -> char -> unit = "caml_ml_output_char" external output_byte_blocking : out_channel -> int -> unit = "caml_ml_output_char" let rec output_char oc c = try output_char_blocking oc c with Sys_blocked_io -> wait_outchan oc 1; output_char oc c let output_string oc s = unsafe_output oc s 0 (string_length s) let output oc s ofs len = if ofs < 0 || len < 0 || ofs > string_length s - len then invalid_arg "output" else unsafe_output oc s ofs len let output' oc ~buf ~pos ~len = output oc buf pos len let rec output_byte oc b = try output_byte_blocking oc b with Sys_blocked_io -> wait_outchan oc 1; output_byte oc b let output_binary_int oc n = output_byte oc (n asr 24); output_byte oc (n asr 16); output_byte oc (n asr 8); output_byte oc n external marshal_to_string : 'a -> unit list -> string = "caml_output_value_to_string" let output_value oc v = output_string oc (marshal_to_string v []) external seek_out_blocking : out_channel -> int -> unit = "caml_ml_seek_out" let seek_out oc pos = flush oc; seek_out_blocking oc pos external pos_out : out_channel -> int = "caml_ml_pos_out" external out_channel_length : out_channel -> int = "caml_ml_channel_size" external close_out_channel : out_channel -> unit = "caml_ml_close_channel" let close_out oc = (try flush oc with _ -> ()); close_out_channel oc let close_out_noerr oc = (try flush oc with _ -> ()); (try close_out_channel oc with _ -> ()) external set_binary_mode_out : out_channel -> bool -> unit = "caml_ml_set_binary_mode" (* General input functions *) let open_in_gen mode perm name = open_descriptor_in(open_desc name mode perm) let open_in name = open_in_gen [Open_rdonly; Open_text] 0 name let open_in_bin name = open_in_gen [Open_rdonly; Open_binary] 0 name external input_char_blocking : in_channel -> char = "caml_ml_input_char" external input_byte_blocking : in_channel -> int = "caml_ml_input_char" let rec input_char ic = try input_char_blocking ic with Sys_blocked_io -> wait_inchan ic; input_char ic external unsafe_input_blocking : in_channel -> string -> int -> int -> int = "caml_ml_input" let rec unsafe_input ic s ofs len = try unsafe_input_blocking ic s ofs len with Sys_blocked_io -> wait_inchan ic; unsafe_input ic s ofs len let input ic s ofs len = if ofs < 0 || len < 0 || ofs > string_length s - len then invalid_arg "input" else unsafe_input ic s ofs len let rec unsafe_really_input ic s ofs len = if len <= 0 then () else begin let r = unsafe_input ic s ofs len in if r = 0 then raise End_of_file else unsafe_really_input ic s (ofs+r) (len-r) end let really_input ic s ofs len = if ofs < 0 || len < 0 || ofs > string_length s - len then invalid_arg "really_input" else unsafe_really_input ic s ofs len let input_line ic = let buf = ref (string_create 128) in let pos = ref 0 in begin try while true do if !pos = string_length !buf then begin let newbuf = string_create (2 * !pos) in string_blit !buf 0 newbuf 0 !pos; buf := newbuf end; let c = input_char ic in if c = '\n' then raise Exit; !buf.[!pos] <- c; incr pos done with Exit -> () | End_of_file -> if !pos = 0 then raise End_of_file end; let res = string_create !pos in string_blit !buf 0 res 0 !pos; res let rec input_byte ic = try input_byte_blocking ic with Sys_blocked_io -> wait_inchan ic; input_byte ic let input_binary_int ic = let b1 = input_byte ic in let n1 = if b1 >= 128 then b1 - 256 else b1 in let b2 = input_byte ic in let b3 = input_byte ic in let b4 = input_byte ic in (n1 lsl 24) + (b2 lsl 16) + (b3 lsl 8) + b4 external unmarshal : string -> int -> 'a = "caml_input_value_from_string" external marshal_data_size : string -> int -> int = "caml_marshal_data_size" let input_value ic = let header = string_create 20 in really_input ic header 0 20; let bsize = marshal_data_size header 0 in let buffer = string_create (20 + bsize) in string_blit header 0 buffer 0 20; really_input ic buffer 20 bsize; unmarshal buffer 0 external seek_in : in_channel -> int -> unit = "caml_ml_seek_in" external pos_in : in_channel -> int = "caml_ml_pos_in" external in_channel_length : in_channel -> int = "caml_ml_channel_size" external close_in : in_channel -> unit = "caml_ml_close_channel" let close_in_noerr ic = (try close_in ic with _ -> ());; external set_binary_mode_in : in_channel -> bool -> unit = "caml_ml_set_binary_mode" (* Output functions on standard output *) let print_char c = output_char stdout c let print_string s = output_string stdout s let print_int i = output_string stdout (string_of_int i) let print_float f = output_string stdout (string_of_float f) let print_endline s = output_string stdout s; output_char stdout '\n'; flush stdout let print_newline () = output_char stdout '\n'; flush stdout (* Output functions on standard error *) let prerr_char c = output_char stderr c let prerr_string s = output_string stderr s let prerr_int i = output_string stderr (string_of_int i) let prerr_float f = output_string stderr (string_of_float f) let prerr_endline s = output_string stderr s; output_char stderr '\n'; flush stderr let prerr_newline () = output_char stderr '\n'; flush stderr (* Input functions on standard input *) let read_line () = flush stdout; input_line stdin let read_int () = int_of_string(read_line()) let read_float () = float_of_string(read_line()) (* Operations on large files *) module LargeFile = struct external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64" external pos_out : out_channel -> int64 = "caml_ml_pos_out_64" external out_channel_length : out_channel -> int64 = "caml_ml_channel_size_64" external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64" external pos_in : in_channel -> int64 = "caml_ml_pos_in_64" external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64" end (* Formats *) type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 external format_of_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" external format_to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity" external string_to_format : string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" let (( ^^ ) : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('f, 'b, 'c, 'e, 'g, 'h) format6 -> ('a, 'b, 'c, 'd, 'g, 'h) format6) = fun fmt1 fmt2 -> string_to_format (format_to_string fmt1 ^ "%," ^ format_to_string fmt2) ;; let string_of_format fmt = let s = format_to_string fmt in let l = string_length s in let r = string_create l in string_blit s 0 r 0 l; r (* Miscellaneous *) external sys_exit : int -> 'a = "caml_sys_exit" let exit_function = ref flush_all let at_exit f = let g = !exit_function in exit_function := (fun () -> f(); g()) let do_at_exit () = (!exit_function) () let exit retcode = do_at_exit (); sys_exit retcode external register_named_value : string -> 'a -> unit = "caml_register_named_value" let _ = register_named_value "Pervasives.do_at_exit" do_at_exit mingw-ocaml/ocaml/otherlibs/threads/libvmthreads.clib0000644000175000017500000000001412124403241022415 0ustar tootstootsscheduler.o mingw-ocaml/ocaml/otherlibs/threads/unix.ml0000644000175000017500000007706312124403241020435 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* An alternate implementation of the Unix module from ../unix which is safe in conjunction with bytecode threads. *) (* Type definitions that matter for thread operations *) type file_descr = int type process_status = WEXITED of int | WSIGNALED of int | WSTOPPED of int (* We can't call functions from Thread because of type circularities, so we redefine here the functions that we need *) type resumption_status = Resumed_wakeup | Resumed_delay | Resumed_join | Resumed_io | Resumed_select of file_descr list * file_descr list * file_descr list | Resumed_wait of int * process_status external thread_initialize : unit -> unit = "thread_initialize" external thread_wait_read : file_descr -> unit = "thread_wait_read" external thread_wait_write : file_descr -> unit = "thread_wait_write" external thread_select : file_descr list * file_descr list * file_descr list * float -> resumption_status = "thread_select" external thread_wait_pid : int -> resumption_status = "thread_wait_pid" external thread_delay : float -> unit = "thread_delay" let wait_read fd = thread_wait_read fd let wait_write fd = thread_wait_write fd let select_aux arg = thread_select arg let wait_pid_aux pid = thread_wait_pid pid let delay duration = thread_delay duration (* Make sure that threads are initialized (PR#1516). *) let _ = thread_initialize() (* Back to the Unix module *) type error = E2BIG | EACCES | EAGAIN | EBADF | EBUSY | ECHILD | EDEADLK | EDOM | EEXIST | EFAULT | EFBIG | EINTR | EINVAL | EIO | EISDIR | EMFILE | EMLINK | ENAMETOOLONG | ENFILE | ENODEV | ENOENT | ENOEXEC | ENOLCK | ENOMEM | ENOSPC | ENOSYS | ENOTDIR | ENOTEMPTY | ENOTTY | ENXIO | EPERM | EPIPE | ERANGE | EROFS | ESPIPE | ESRCH | EXDEV | EWOULDBLOCK | EINPROGRESS | EALREADY | ENOTSOCK | EDESTADDRREQ | EMSGSIZE | EPROTOTYPE | ENOPROTOOPT | EPROTONOSUPPORT | ESOCKTNOSUPPORT | EOPNOTSUPP | EPFNOSUPPORT | EAFNOSUPPORT | EADDRINUSE | EADDRNOTAVAIL | ENETDOWN | ENETUNREACH | ENETRESET | ECONNABORTED | ECONNRESET | ENOBUFS | EISCONN | ENOTCONN | ESHUTDOWN | ETOOMANYREFS | ETIMEDOUT | ECONNREFUSED | EHOSTDOWN | EHOSTUNREACH | ELOOP | EOVERFLOW | EUNKNOWNERR of int exception Unix_error of error * string * string let _ = Callback.register_exception "Unix.Unix_error" (Unix_error(E2BIG, "", "")) external error_message : error -> string = "unix_error_message" let handle_unix_error f arg = try f arg with Unix_error(err, fun_name, arg) -> prerr_string Sys.argv.(0); prerr_string ": \""; prerr_string fun_name; prerr_string "\" failed"; if String.length arg > 0 then begin prerr_string " on \""; prerr_string arg; prerr_string "\"" end; prerr_string ": "; prerr_endline (error_message err); exit 2 external environment : unit -> string array = "unix_environment" external getenv: string -> string = "caml_sys_getenv" external putenv: string -> string -> unit = "unix_putenv" type interval_timer = ITIMER_REAL | ITIMER_VIRTUAL | ITIMER_PROF type interval_timer_status = { it_interval: float; (* Period *) it_value: float } (* Current value of the timer *) external getitimer: interval_timer -> interval_timer_status = "unix_getitimer" external setitimer: interval_timer -> interval_timer_status -> interval_timer_status = "unix_setitimer" type wait_flag = WNOHANG | WUNTRACED let stdin = 0 let stdout = 1 let stderr = 2 type open_flag = O_RDONLY | O_WRONLY | O_RDWR | O_NONBLOCK | O_APPEND | O_CREAT | O_TRUNC | O_EXCL | O_NOCTTY | O_DSYNC | O_SYNC | O_RSYNC | O_SHARE_DELETE type file_perm = int external openfile : string -> open_flag list -> file_perm -> file_descr = "unix_open" external close : file_descr -> unit = "unix_close" external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read" external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write" external unsafe_single_write : file_descr -> string -> int -> int -> int = "unix_single_write" let rec read fd buf ofs len = try if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.read" else unsafe_read fd buf ofs len with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> wait_read fd; read fd buf ofs len let rec write fd buf ofs len = try if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.write" else unsafe_write fd buf ofs len with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> wait_write fd; write fd buf ofs len let rec single_write fd buf ofs len = try if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.partial_write" else unsafe_single_write fd buf ofs len with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> wait_write fd; single_write fd buf ofs len external in_channel_of_descr : file_descr -> in_channel = "caml_ml_open_descriptor_in" external out_channel_of_descr : file_descr -> out_channel = "caml_ml_open_descriptor_out" external descr_of_in_channel : in_channel -> file_descr = "caml_channel_descriptor" external descr_of_out_channel : out_channel -> file_descr = "caml_channel_descriptor" type seek_command = SEEK_SET | SEEK_CUR | SEEK_END external lseek : file_descr -> int -> seek_command -> int = "unix_lseek" external truncate : string -> int -> unit = "unix_truncate" external ftruncate : file_descr -> int -> unit = "unix_ftruncate" type file_kind = S_REG | S_DIR | S_CHR | S_BLK | S_LNK | S_FIFO | S_SOCK type stats = { st_dev : int; st_ino : int; st_kind : file_kind; st_perm : file_perm; st_nlink : int; st_uid : int; st_gid : int; st_rdev : int; st_size : int; st_atime : float; st_mtime : float; st_ctime : float } external stat : string -> stats = "unix_stat" external lstat : string -> stats = "unix_lstat" external fstat : file_descr -> stats = "unix_fstat" external isatty : file_descr -> bool = "unix_isatty" external unlink : string -> unit = "unix_unlink" external rename : string -> string -> unit = "unix_rename" external link : string -> string -> unit = "unix_link" module LargeFile = struct external lseek : file_descr -> int64 -> seek_command -> int64 = "unix_lseek_64" external truncate : string -> int64 -> unit = "unix_truncate_64" external ftruncate : file_descr -> int64 -> unit = "unix_ftruncate_64" type stats = { st_dev : int; st_ino : int; st_kind : file_kind; st_perm : file_perm; st_nlink : int; st_uid : int; st_gid : int; st_rdev : int; st_size : int64; st_atime : float; st_mtime : float; st_ctime : float; } external stat : string -> stats = "unix_stat_64" external lstat : string -> stats = "unix_lstat_64" external fstat : file_descr -> stats = "unix_fstat_64" end type access_permission = R_OK | W_OK | X_OK | F_OK external chmod : string -> file_perm -> unit = "unix_chmod" external fchmod : file_descr -> file_perm -> unit = "unix_fchmod" external chown : string -> int -> int -> unit = "unix_chown" external fchown : file_descr -> int -> int -> unit = "unix_fchown" external umask : int -> int = "unix_umask" external access : string -> access_permission list -> unit = "unix_access" external dup : file_descr -> file_descr = "unix_dup" external dup2 : file_descr -> file_descr -> unit = "unix_dup2" external set_nonblock : file_descr -> unit = "unix_set_nonblock" external clear_nonblock : file_descr -> unit = "unix_clear_nonblock" external set_close_on_exec : file_descr -> unit = "unix_set_close_on_exec" external clear_close_on_exec : file_descr -> unit = "unix_clear_close_on_exec" external mkdir : string -> file_perm -> unit = "unix_mkdir" external rmdir : string -> unit = "unix_rmdir" external chdir : string -> unit = "unix_chdir" external getcwd : unit -> string = "unix_getcwd" external chroot : string -> unit = "unix_chroot" type dir_handle external opendir : string -> dir_handle = "unix_opendir" external readdir : dir_handle -> string = "unix_readdir" external rewinddir : dir_handle -> unit = "unix_rewinddir" external closedir : dir_handle -> unit = "unix_closedir" external _pipe : unit -> file_descr * file_descr = "unix_pipe" let pipe() = let (out_fd, in_fd as fd_pair) = _pipe() in set_nonblock in_fd; set_nonblock out_fd; fd_pair external symlink : string -> string -> unit = "unix_symlink" external readlink : string -> string = "unix_readlink" external mkfifo : string -> file_perm -> unit = "unix_mkfifo" let select readfds writefds exceptfds delay = match select_aux (readfds, writefds, exceptfds, delay) with Resumed_select(r, w, e) -> (r, w, e) | _ -> ([], [], []) type lock_command = F_ULOCK | F_LOCK | F_TLOCK | F_TEST | F_RLOCK | F_TRLOCK external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf" external _execv : string -> string array -> 'a = "unix_execv" external _execve : string -> string array -> string array -> 'a = "unix_execve" external _execvp : string -> string array -> 'a = "unix_execvp" external _execvpe : string -> string array -> string array -> 'a = "unix_execvpe" (* Disable the timer interrupt before doing exec, because some OS keep sending timer interrupts to the exec'ed code. Also restore blocking mode on stdin, stdout and stderr, since this is what most programs expect! *) let safe_clear_nonblock fd = try clear_nonblock fd with Unix_error(_,_,_) -> () let safe_set_nonblock fd = try set_nonblock fd with Unix_error(_,_,_) -> () let do_exec fn = let oldtimer = setitimer ITIMER_VIRTUAL {it_interval = 0.0; it_value = 0.0} in safe_clear_nonblock stdin; safe_clear_nonblock stdout; safe_clear_nonblock stderr; try fn () with Unix_error(_,_,_) as exn -> ignore(setitimer ITIMER_VIRTUAL oldtimer); safe_set_nonblock stdin; safe_set_nonblock stdout; safe_set_nonblock stderr; raise exn let execv proc args = do_exec (fun () -> _execv proc args) let execve proc args env = do_exec (fun () -> _execve proc args env) let execvp proc args = do_exec (fun () -> _execvp proc args) let execvpe proc args = do_exec (fun () -> _execvpe proc args) external fork : unit -> int = "unix_fork" external _waitpid : wait_flag list -> int -> int * process_status = "unix_waitpid" let wait_pid pid = match wait_pid_aux pid with Resumed_wait(pid, status) -> (pid, status) | _ -> invalid_arg "Thread.wait_pid" let wait () = wait_pid (-1) let waitpid flags pid = if List.mem WNOHANG flags then _waitpid flags pid else wait_pid pid external getpid : unit -> int = "unix_getpid" external getppid : unit -> int = "unix_getppid" external nice : int -> int = "unix_nice" external kill : int -> int -> unit = "unix_kill" type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK external sigprocmask: sigprocmask_command -> int list -> int list = "unix_sigprocmask" external sigpending: unit -> int list = "unix_sigpending" external sigsuspend: int list -> unit = "unix_sigsuspend" let pause() = let sigs = sigprocmask SIG_BLOCK [] in sigsuspend sigs type process_times = { tms_utime : float; tms_stime : float; tms_cutime : float; tms_cstime : float } type tm = { tm_sec : int; tm_min : int; tm_hour : int; tm_mday : int; tm_mon : int; tm_year : int; tm_wday : int; tm_yday : int; tm_isdst : bool } external time : unit -> float = "unix_time" external gettimeofday : unit -> float = "unix_gettimeofday" external gmtime : float -> tm = "unix_gmtime" external localtime : float -> tm = "unix_localtime" external mktime : tm -> float * tm = "unix_mktime" external alarm : int -> int = "unix_alarm" let sleep secs = delay (float secs) external times : unit -> process_times = "unix_times" external utimes : string -> float -> float -> unit = "unix_utimes" external getuid : unit -> int = "unix_getuid" external geteuid : unit -> int = "unix_geteuid" external setuid : int -> unit = "unix_setuid" external getgid : unit -> int = "unix_getgid" external getegid : unit -> int = "unix_getegid" external setgid : int -> unit = "unix_setgid" external getgroups : unit -> int array = "unix_getgroups" external setgroups : int array -> unit = "unix_setgroups" external initgroups : string -> int -> unit = "unix_initgroups" type passwd_entry = { pw_name : string; pw_passwd : string; pw_uid : int; pw_gid : int; pw_gecos : string; pw_dir : string; pw_shell : string } type group_entry = { gr_name : string; gr_passwd : string; gr_gid : int; gr_mem : string array } external getlogin : unit -> string = "unix_getlogin" external getpwnam : string -> passwd_entry = "unix_getpwnam" external getgrnam : string -> group_entry = "unix_getgrnam" external getpwuid : int -> passwd_entry = "unix_getpwuid" external getgrgid : int -> group_entry = "unix_getgrgid" type inet_addr = string external inet_addr_of_string : string -> inet_addr = "unix_inet_addr_of_string" external string_of_inet_addr : inet_addr -> string = "unix_string_of_inet_addr" let inet_addr_any = inet_addr_of_string "0.0.0.0" let inet_addr_loopback = inet_addr_of_string "127.0.0.1" let inet6_addr_any = try inet_addr_of_string "::" with Failure _ -> inet_addr_any let inet6_addr_loopback = try inet_addr_of_string "::1" with Failure _ -> inet_addr_loopback let is_inet6_addr s = String.length s = 16 type socket_domain = PF_UNIX | PF_INET | PF_INET6 type socket_type = SOCK_STREAM | SOCK_DGRAM | SOCK_RAW | SOCK_SEQPACKET type sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int let domain_of_sockaddr = function ADDR_UNIX _ -> PF_UNIX | ADDR_INET(a, _) -> if is_inet6_addr a then PF_INET6 else PF_INET type shutdown_command = SHUTDOWN_RECEIVE | SHUTDOWN_SEND | SHUTDOWN_ALL type msg_flag = MSG_OOB | MSG_DONTROUTE | MSG_PEEK external _socket : socket_domain -> socket_type -> int -> file_descr = "unix_socket" external _socketpair : socket_domain -> socket_type -> int -> file_descr * file_descr = "unix_socketpair" let socket dom typ proto = let s = _socket dom typ proto in set_nonblock s; s let socketpair dom typ proto = let (s1, s2 as spair) = _socketpair dom typ proto in set_nonblock s1; set_nonblock s2; spair external _accept : file_descr -> file_descr * sockaddr = "unix_accept" let rec accept req = wait_read req; try let (s, caller as result) = _accept req in set_nonblock s; result with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> accept req external bind : file_descr -> sockaddr -> unit = "unix_bind" external listen : file_descr -> int -> unit = "unix_listen" external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" external getsockname : file_descr -> sockaddr = "unix_getsockname" external getpeername : file_descr -> sockaddr = "unix_getpeername" external _connect : file_descr -> sockaddr -> unit = "unix_connect" let connect s addr = try _connect s addr with Unix_error((EINPROGRESS | EWOULDBLOCK | EAGAIN), _, _) -> wait_write s; (* Check if it really worked *) ignore(getpeername s) external unsafe_recv : file_descr -> string -> int -> int -> msg_flag list -> int = "unix_recv" external unsafe_recvfrom : file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr = "unix_recvfrom" external unsafe_send : file_descr -> string -> int -> int -> msg_flag list -> int = "unix_send" external unsafe_sendto : file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int = "unix_sendto" "unix_sendto_native" let rec recv fd buf ofs len flags = try if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.recv" else unsafe_recv fd buf ofs len flags with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> wait_read fd; recv fd buf ofs len flags let rec recvfrom fd buf ofs len flags = try if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.recvfrom" else unsafe_recvfrom fd buf ofs len flags with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> wait_read fd; recvfrom fd buf ofs len flags let rec send fd buf ofs len flags = try if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.send" else unsafe_send fd buf ofs len flags with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> wait_write fd; send fd buf ofs len flags let rec sendto fd buf ofs len flags addr = try if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.sendto" else unsafe_sendto fd buf ofs len flags addr with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> wait_write fd; sendto fd buf ofs len flags addr type socket_bool_option = SO_DEBUG | SO_BROADCAST | SO_REUSEADDR | SO_KEEPALIVE | SO_DONTROUTE | SO_OOBINLINE | SO_ACCEPTCONN | TCP_NODELAY | IPV6_ONLY type socket_int_option = SO_SNDBUF | SO_RCVBUF | SO_ERROR | SO_TYPE | SO_RCVLOWAT | SO_SNDLOWAT type socket_optint_option = SO_LINGER type socket_float_option = SO_RCVTIMEO | SO_SNDTIMEO type socket_error_option = SO_ERROR module SO: sig type ('opt, 'v) t val bool: (socket_bool_option, bool) t val int: (socket_int_option, int) t val optint: (socket_optint_option, int option) t val float: (socket_float_option, float) t val error: (socket_error_option, error option) t val get: ('opt, 'v) t -> file_descr -> 'opt -> 'v val set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit end = struct type ('opt, 'v) t = int let bool = 0 let int = 1 let optint = 2 let float = 3 let error = 4 external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v = "unix_getsockopt" external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit = "unix_setsockopt" end let getsockopt fd opt = SO.get SO.bool fd opt let setsockopt fd opt v = SO.set SO.bool fd opt v let getsockopt_int fd opt = SO.get SO.int fd opt let setsockopt_int fd opt v = SO.set SO.int fd opt v let getsockopt_optint fd opt = SO.get SO.optint fd opt let setsockopt_optint fd opt v = SO.set SO.optint fd opt v let getsockopt_float fd opt = SO.get SO.float fd opt let setsockopt_float fd opt v = SO.set SO.float fd opt v let getsockopt_error fd = SO.get SO.error fd SO_ERROR type host_entry = { h_name : string; h_aliases : string array; h_addrtype : socket_domain; h_addr_list : inet_addr array } type protocol_entry = { p_name : string; p_aliases : string array; p_proto : int } type service_entry = { s_name : string; s_aliases : string array; s_port : int; s_proto : string } external gethostname : unit -> string = "unix_gethostname" external gethostbyname : string -> host_entry = "unix_gethostbyname" external gethostbyaddr : inet_addr -> host_entry = "unix_gethostbyaddr" external getprotobyname : string -> protocol_entry = "unix_getprotobyname" external getprotobynumber : int -> protocol_entry = "unix_getprotobynumber" external getservbyname : string -> string -> service_entry = "unix_getservbyname" external getservbyport : int -> string -> service_entry = "unix_getservbyport" type addr_info = { ai_family : socket_domain; ai_socktype : socket_type; ai_protocol : int; ai_addr : sockaddr; ai_canonname : string } type getaddrinfo_option = AI_FAMILY of socket_domain | AI_SOCKTYPE of socket_type | AI_PROTOCOL of int | AI_NUMERICHOST | AI_CANONNAME | AI_PASSIVE external getaddrinfo_system : string -> string -> getaddrinfo_option list -> addr_info list = "unix_getaddrinfo" let getaddrinfo_emulation node service opts = (* Parse options *) let opt_socktype = ref None and opt_protocol = ref 0 and opt_passive = ref false in List.iter (function AI_SOCKTYPE s -> opt_socktype := Some s | AI_PROTOCOL p -> opt_protocol := p | AI_PASSIVE -> opt_passive := true | _ -> ()) opts; (* Determine socket types and port numbers *) let get_port ty kind = if service = "" then [ty, 0] else try [ty, int_of_string service] with Failure _ -> try [ty, (getservbyname service kind).s_port] with Not_found -> [] in let ports = match !opt_socktype with | None -> get_port SOCK_STREAM "tcp" @ get_port SOCK_DGRAM "udp" | Some SOCK_STREAM -> get_port SOCK_STREAM "tcp" | Some SOCK_DGRAM -> get_port SOCK_DGRAM "udp" | Some ty -> if service = "" then [ty, 0] else [] in (* Determine IP addresses *) let addresses = if node = "" then if List.mem AI_PASSIVE opts then [inet_addr_any, "0.0.0.0"] else [inet_addr_loopback, "127.0.0.1"] else try [inet_addr_of_string node, node] with Failure _ -> try let he = gethostbyname node in List.map (fun a -> (a, he.h_name)) (Array.to_list he.h_addr_list) with Not_found -> [] in (* Cross-product of addresses and ports *) List.flatten (List.map (fun (ty, port) -> List.map (fun (addr, name) -> { ai_family = PF_INET; ai_socktype = ty; ai_protocol = !opt_protocol; ai_addr = ADDR_INET(addr, port); ai_canonname = name }) addresses) ports) let getaddrinfo node service opts = try List.rev(getaddrinfo_system node service opts) with Invalid_argument _ -> getaddrinfo_emulation node service opts type name_info = { ni_hostname : string; ni_service : string } type getnameinfo_option = NI_NOFQDN | NI_NUMERICHOST | NI_NAMEREQD | NI_NUMERICSERV | NI_DGRAM external getnameinfo_system : sockaddr -> getnameinfo_option list -> name_info = "unix_getnameinfo" let getnameinfo_emulation addr opts = match addr with | ADDR_UNIX f -> { ni_hostname = ""; ni_service = f } (* why not? *) | ADDR_INET(a, p) -> let hostname = try if List.mem NI_NUMERICHOST opts then raise Not_found; (gethostbyaddr a).h_name with Not_found -> if List.mem NI_NAMEREQD opts then raise Not_found; string_of_inet_addr a in let service = try if List.mem NI_NUMERICSERV opts then raise Not_found; let kind = if List.mem NI_DGRAM opts then "udp" else "tcp" in (getservbyport p kind).s_name with Not_found -> string_of_int p in { ni_hostname = hostname; ni_service = service } let getnameinfo addr opts = try getnameinfo_system addr opts with Invalid_argument _ -> getnameinfo_emulation addr opts type terminal_io = { mutable c_ignbrk: bool; mutable c_brkint: bool; mutable c_ignpar: bool; mutable c_parmrk: bool; mutable c_inpck: bool; mutable c_istrip: bool; mutable c_inlcr: bool; mutable c_igncr: bool; mutable c_icrnl: bool; mutable c_ixon: bool; mutable c_ixoff: bool; mutable c_opost: bool; mutable c_obaud: int; mutable c_ibaud: int; mutable c_csize: int; mutable c_cstopb: int; mutable c_cread: bool; mutable c_parenb: bool; mutable c_parodd: bool; mutable c_hupcl: bool; mutable c_clocal: bool; mutable c_isig: bool; mutable c_icanon: bool; mutable c_noflsh: bool; mutable c_echo: bool; mutable c_echoe: bool; mutable c_echok: bool; mutable c_echonl: bool; mutable c_vintr: char; mutable c_vquit: char; mutable c_verase: char; mutable c_vkill: char; mutable c_veof: char; mutable c_veol: char; mutable c_vmin: int; mutable c_vtime: int; mutable c_vstart: char; mutable c_vstop: char } external tcgetattr: file_descr -> terminal_io = "unix_tcgetattr" type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH external tcsetattr: file_descr -> setattr_when -> terminal_io -> unit = "unix_tcsetattr" external tcsendbreak: file_descr -> int -> unit = "unix_tcsendbreak" external tcdrain: file_descr -> unit = "unix_tcdrain" type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH external tcflush: file_descr -> flush_queue -> unit = "unix_tcflush" type flow_action = TCOOFF | TCOON | TCIOFF | TCION external tcflow: file_descr -> flow_action -> unit = "unix_tcflow" external setsid : unit -> int = "unix_setsid" (* High-level process management (system, popen) *) let system cmd = match fork() with 0 -> begin try execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] with _ -> exit 127 end | id -> snd(waitpid [] id) let rec safe_dup fd = let new_fd = dup fd in if new_fd >= 3 then new_fd else begin let res = safe_dup fd in close new_fd; res end let safe_close fd = try close fd with Unix_error(_,_,_) -> () let perform_redirections new_stdin new_stdout new_stderr = let newnewstdin = safe_dup new_stdin in let newnewstdout = safe_dup new_stdout in let newnewstderr = safe_dup new_stderr in safe_close new_stdin; safe_close new_stdout; safe_close new_stderr; dup2 newnewstdin stdin; close newnewstdin; dup2 newnewstdout stdout; close newnewstdout; dup2 newnewstderr stderr; close newnewstderr let create_process cmd args new_stdin new_stdout new_stderr = match fork() with 0 -> begin try perform_redirections new_stdin new_stdout new_stderr; execvp cmd args with _ -> exit 127 end | id -> id let create_process_env cmd args env new_stdin new_stdout new_stderr = match fork() with 0 -> begin try perform_redirections new_stdin new_stdout new_stderr; execvpe cmd args env with _ -> exit 127 end | id -> id type popen_process = Process of in_channel * out_channel | Process_in of in_channel | Process_out of out_channel | Process_full of in_channel * out_channel * in_channel let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t) let open_proc cmd proc input output toclose = match fork() with 0 -> if input <> stdin then begin dup2 input stdin; close input end; if output <> stdout then begin dup2 output stdout; close output end; List.iter close toclose; begin try execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] with _ -> exit 127 end | id -> Hashtbl.add popen_processes proc id let open_process_in cmd = let (in_read, in_write) = pipe() in let inchan = in_channel_of_descr in_read in open_proc cmd (Process_in inchan) stdin in_write [in_read]; close in_write; inchan let open_process_out cmd = let (out_read, out_write) = pipe() in let outchan = out_channel_of_descr out_write in open_proc cmd (Process_out outchan) out_read stdout [out_write]; close out_read; outchan let open_process cmd = let (in_read, in_write) = pipe() in let (out_read, out_write) = pipe() in let inchan = in_channel_of_descr in_read in let outchan = out_channel_of_descr out_write in open_proc cmd (Process(inchan, outchan)) out_read in_write [in_read; out_write]; close out_read; close in_write; (inchan, outchan) let open_proc_full cmd env proc input output error toclose = match fork() with 0 -> dup2 input stdin; close input; dup2 output stdout; close output; dup2 error stderr; close error; List.iter close toclose; begin try execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env with _ -> exit 127 end | id -> Hashtbl.add popen_processes proc id let open_process_full cmd env = let (in_read, in_write) = pipe() in let (out_read, out_write) = pipe() in let (err_read, err_write) = pipe() in let inchan = in_channel_of_descr in_read in let outchan = out_channel_of_descr out_write in let errchan = in_channel_of_descr err_read in open_proc_full cmd env (Process_full(inchan, outchan, errchan)) out_read in_write err_write [in_read; out_write; err_read]; close out_read; close in_write; close err_write; (inchan, outchan, errchan) let find_proc_id fun_name proc = try let pid = Hashtbl.find popen_processes proc in Hashtbl.remove popen_processes proc; pid with Not_found -> raise(Unix_error(EBADF, fun_name, "")) let rec waitpid_non_intr pid = try waitpid [] pid with Unix_error (EINTR, _, _) -> waitpid_non_intr pid let close_process_in inchan = let pid = find_proc_id "close_process_in" (Process_in inchan) in close_in inchan; snd(waitpid_non_intr pid) let close_process_out outchan = let pid = find_proc_id "close_process_out" (Process_out outchan) in close_out outchan; snd(waitpid_non_intr pid) let close_process (inchan, outchan) = let pid = find_proc_id "close_process" (Process(inchan, outchan)) in close_in inchan; begin try close_out outchan with Sys_error _ -> () end; snd(waitpid_non_intr pid) let close_process_full (inchan, outchan, errchan) = let pid = find_proc_id "close_process_full" (Process_full(inchan, outchan, errchan)) in close_in inchan; begin try close_out outchan with Sys_error _ -> () end; close_in errchan; snd(waitpid_non_intr pid) (* High-level network functions *) let open_connection sockaddr = let sock = socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in try connect sock sockaddr; (in_channel_of_descr sock, out_channel_of_descr sock) with exn -> close sock; raise exn let shutdown_connection inchan = shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND let establish_server server_fun sockaddr = let sock = socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in setsockopt sock SO_REUSEADDR true; bind sock sockaddr; listen sock 5; while true do let (s, caller) = accept sock in (* The "double fork" trick, the process which calls server_fun will not leave a zombie process *) match fork() with 0 -> if fork() <> 0 then exit 0; (* The son exits, the grandson works *) let inchan = in_channel_of_descr s in let outchan = out_channel_of_descr s in server_fun inchan outchan; close_out outchan; (* The file descriptor was already closed by close_out. close_in inchan; *) exit 0 | id -> close s; ignore(waitpid [] id) (* Reclaim the son *) done mingw-ocaml/ocaml/otherlibs/threads/thread.mli0000644000175000017500000001354712124403241021067 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Lightweight threads. *) type t (** The type of thread handles. *) (** {6 Thread creation and termination} *) val create : ('a -> 'b) -> 'a -> t (** [Thread.create funct arg] creates a new thread of control, in which the function application [funct arg] is executed concurrently with the other threads of the program. The application of [Thread.create] returns the handle of the newly created thread. The new thread terminates when the application [funct arg] returns, either normally or by raising an uncaught exception. In the latter case, the exception is printed on standard error, but not propagated back to the parent thread. Similarly, the result of the application [funct arg] is discarded and not directly accessible to the parent thread. *) val self : unit -> t (** Return the thread currently executing. *) external id : t -> int = "thread_id" (** Return the identifier of the given thread. A thread identifier is an integer that identifies uniquely the thread. It can be used to build data structures indexed by threads. *) val exit : unit -> unit (** Terminate prematurely the currently executing thread. *) val kill : t -> unit (** Terminate prematurely the thread whose handle is given. This functionality is available only with bytecode-level threads. *) (** {6 Suspending threads} *) val delay : float -> unit (** [delay d] suspends the execution of the calling thread for [d] seconds. The other program threads continue to run during this time. *) val join : t -> unit (** [join th] suspends the execution of the calling thread until the thread [th] has terminated. *) val wait_read : Unix.file_descr -> unit (** See {!Thread.wait_write}.*) val wait_write : Unix.file_descr -> unit (** Suspend the execution of the calling thread until at least one character is available for reading ({!Thread.wait_read}) or one character can be written without blocking ([wait_write]) on the given Unix file descriptor. *) val wait_timed_read : Unix.file_descr -> float -> bool (** See {!Thread.wait_timed_write}.*) val wait_timed_write : Unix.file_descr -> float -> bool (** Same as {!Thread.wait_read} and {!Thread.wait_write}, but wait for at most the amount of time given as second argument (in seconds). Return [true] if the file descriptor is ready for input/output and [false] if the timeout expired. *) val select : Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list * Unix.file_descr list (** Suspend the execution of the calling thead until input/output becomes possible on the given Unix file descriptors. The arguments and results have the same meaning as for {!Unix.select}. *) val wait_pid : int -> int * Unix.process_status (** [wait_pid p] suspends the execution of the calling thread until the Unix process specified by the process identifier [p] terminates. A pid [p] of [-1] means wait for any child. A pid of [0] means wait for any child in the same process group as the current process. Negative pid arguments represent process groups. Returns the pid of the child caught and its termination status, as per {!Unix.wait}. *) val wait_signal : int list -> int (** [wait_signal sigs] suspends the execution of the calling thread until the process receives one of the signals specified in the list [sigs]. It then returns the number of the signal received. Signal handlers attached to the signals in [sigs] will not be invoked. Do not call [wait_signal] concurrently from several threads on the same signals. *) val yield : unit -> unit (** Re-schedule the calling thread without suspending it. This function can be used to give scheduling hints, telling the scheduler that now is a good time to switch to other threads. *) (**/**) (** {6 Synchronization primitives} The following primitives provide the basis for implementing synchronization functions between threads. Their direct use is discouraged, as they are very low-level and prone to race conditions and deadlocks. The modules {!Mutex}, {!Condition} and {!Event} provide higher-level synchronization primitives. *) val critical_section : bool ref (** Setting this reference to [true] deactivate thread preemption (the timer interrupt that transfers control from thread to thread), causing the current thread to run uninterrupted until [critical_section] is reset to [false] or the current thread explicitely relinquishes control using [sleep], [delay], [wait_inchan] or [wait_descr]. *) val sleep : unit -> unit (** Suspend the calling thread until another thread reactivates it using {!Thread.wakeup}. Just before suspending the thread, {!Thread.critical_section} is reset to [false]. Resetting {!Thread.critical_section} and suspending the calling thread is an atomic operation. *) val wakeup : t -> unit (** Reactivate the given thread. After the call to [wakeup], the suspended thread will resume execution at some future time. *) mingw-ocaml/ocaml/otherlibs/threads/marshal.ml0000644000175000017500000000434112124403241021066 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) type extern_flags = No_sharing | Closures external to_string: 'a -> extern_flags list -> string = "caml_output_value_to_string" let to_channel chan v flags = output_string chan (to_string v flags) external to_buffer_unsafe: string -> int -> int -> 'a -> extern_flags list -> int = "caml_output_value_to_buffer" let to_buffer buff ofs len v flags = if ofs < 0 || len < 0 || ofs + len > String.length buff then invalid_arg "Marshal.to_buffer: substring out of bounds" else to_buffer_unsafe buff ofs len v flags let to_buffer' ~buf ~pos ~len v ~mode = to_buffer buf pos len v mode external from_string_unsafe: string -> int -> 'a = "caml_input_value_from_string" external data_size_unsafe: string -> int -> int = "caml_marshal_data_size" let header_size = 20 let data_size buff ofs = if ofs < 0 || ofs > String.length buff - header_size then invalid_arg "Marshal.data_size" else data_size_unsafe buff ofs let total_size buff ofs = header_size + data_size buff ofs let from_string buff ofs = if ofs < 0 || ofs > String.length buff - header_size then invalid_arg "Marshal.from_size" else begin let len = data_size_unsafe buff ofs in if ofs > String.length buff - (header_size + len) then invalid_arg "Marshal.from_string" else from_string_unsafe buff ofs end let from_channel = Pervasives.input_value mingw-ocaml/ocaml/otherlibs/threads/scheduler.c0000644000175000017500000006413412124403241021235 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* The thread scheduler */ #include #include #include #include "alloc.h" #include "backtrace.h" #include "callback.h" #include "config.h" #include "fail.h" #include "io.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" #include "printexc.h" #include "roots.h" #include "signals.h" #include "stacks.h" #include "sys.h" #if ! (defined(HAS_SELECT) && \ defined(HAS_SETITIMER) && \ defined(HAS_GETTIMEOFDAY) && \ (defined(HAS_WAITPID) || defined(HAS_WAIT4))) #include "Cannot compile libthreads, system calls missing" #endif #include #include #include #include #include #include #ifdef HAS_UNISTD #include #endif #ifdef HAS_SYS_SELECT_H #include #endif #ifndef HAS_WAITPID #define waitpid(pid,status,opts) wait4(pid,status,opts,NULL) #endif #ifndef O_NONBLOCK #define O_NONBLOCK O_NDELAY #endif /* Configuration */ /* Initial size of stack when a thread is created (4kB) */ #define Thread_stack_size (Stack_size / 4) /* Max computation time before rescheduling, in microseconds (50ms) */ #define Thread_timeout 50000 /* The thread descriptors */ struct caml_thread_struct { value ident; /* Unique id (for equality comparisons) */ struct caml_thread_struct * next; /* Double linking of threads */ struct caml_thread_struct * prev; value * stack_low; /* The execution stack for this thread */ value * stack_high; value * stack_threshold; value * sp; value * trapsp; value backtrace_pos; /* The backtrace info for this thread */ code_t * backtrace_buffer; value backtrace_last_exn; value status; /* RUNNABLE, KILLED. etc (see below) */ value fd; /* File descriptor on which we're doing read or write */ value readfds, writefds, exceptfds; /* Lists of file descriptors on which we're doing select() */ value delay; /* Time until which this thread is blocked */ value joining; /* Thread we're trying to join */ value waitpid; /* PID of process we're waiting for */ value retval; /* Value to return when thread resumes */ }; typedef struct caml_thread_struct * caml_thread_t; #define RUNNABLE Val_int(0) #define KILLED Val_int(1) #define SUSPENDED Val_int(2) #define BLOCKED_READ Val_int(4) #define BLOCKED_WRITE Val_int(8) #define BLOCKED_SELECT Val_int(16) #define BLOCKED_DELAY Val_int(32) #define BLOCKED_JOIN Val_int(64) #define BLOCKED_WAIT Val_int(128) #define RESUMED_WAKEUP Val_int(0) #define RESUMED_DELAY Val_int(1) #define RESUMED_JOIN Val_int(2) #define RESUMED_IO Val_int(3) #define TAG_RESUMED_SELECT 0 #define TAG_RESUMED_WAIT 1 #define NO_FDS Val_unit #define NO_DELAY Val_unit #define NO_JOINING Val_unit #define NO_WAITPID Val_int(0) #define DELAY_INFTY 1E30 /* +infty, for this purpose */ /* The thread currently active */ static caml_thread_t curr_thread = NULL; /* Identifier for next thread creation */ static value next_ident = Val_int(0); #define Assign(dst,src) modify((value *)&(dst), (value)(src)) /* Scan the stacks of the other threads */ static void (*prev_scan_roots_hook) (scanning_action); static void thread_scan_roots(scanning_action action) { caml_thread_t th, start; /* Scan all active descriptors */ start = curr_thread; (*action)((value) curr_thread, (value *) &curr_thread); /* Don't scan curr_thread->sp, this has already been done. Don't scan local roots either, for the same reason. */ for (th = start->next; th != start; th = th->next) { do_local_roots(action, th->sp, th->stack_high, NULL); } /* Hook */ if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action); } /* Forward declarations for async I/O handling */ static int stdin_initial_status, stdout_initial_status, stderr_initial_status; static void thread_restore_std_descr(void); /* Initialize the thread machinery */ value thread_initialize(value unit) /* ML */ { /* Protect against repeated initialization (PR#1325) */ if (curr_thread != NULL) return Val_unit; /* Create a descriptor for the current thread */ curr_thread = (caml_thread_t) alloc_shr(sizeof(struct caml_thread_struct) / sizeof(value), 0); curr_thread->ident = next_ident; next_ident = Val_int(Int_val(next_ident) + 1); curr_thread->next = curr_thread; curr_thread->prev = curr_thread; curr_thread->stack_low = stack_low; curr_thread->stack_high = stack_high; curr_thread->stack_threshold = stack_threshold; curr_thread->sp = extern_sp; curr_thread->trapsp = trapsp; curr_thread->backtrace_pos = Val_int(backtrace_pos); curr_thread->backtrace_buffer = backtrace_buffer; caml_initialize (&curr_thread->backtrace_last_exn, backtrace_last_exn); curr_thread->status = RUNNABLE; curr_thread->fd = Val_int(0); curr_thread->readfds = NO_FDS; curr_thread->writefds = NO_FDS; curr_thread->exceptfds = NO_FDS; curr_thread->delay = NO_DELAY; curr_thread->joining = NO_JOINING; curr_thread->waitpid = NO_WAITPID; curr_thread->retval = Val_unit; /* Initialize GC */ prev_scan_roots_hook = scan_roots_hook; scan_roots_hook = thread_scan_roots; /* Set standard file descriptors to non-blocking mode */ stdin_initial_status = fcntl(0, F_GETFL); stdout_initial_status = fcntl(1, F_GETFL); stderr_initial_status = fcntl(2, F_GETFL); if (stdin_initial_status != -1) fcntl(0, F_SETFL, stdin_initial_status | O_NONBLOCK); if (stdout_initial_status != -1) fcntl(1, F_SETFL, stdout_initial_status | O_NONBLOCK); if (stderr_initial_status != -1) fcntl(2, F_SETFL, stderr_initial_status | O_NONBLOCK); /* Register an at-exit function to restore the standard file descriptors */ atexit(thread_restore_std_descr); return Val_unit; } /* Initialize the interval timer used for preemption */ value thread_initialize_preemption(value unit) /* ML */ { struct itimerval timer; timer.it_interval.tv_sec = 0; timer.it_interval.tv_usec = Thread_timeout; timer.it_value = timer.it_interval; setitimer(ITIMER_VIRTUAL, &timer, NULL); return Val_unit; } /* Create a thread */ value thread_new(value clos) /* ML */ { caml_thread_t th; /* Allocate the thread and its stack */ Begin_root(clos); th = (caml_thread_t) alloc_shr(sizeof(struct caml_thread_struct) / sizeof(value), 0); End_roots(); th->ident = next_ident; next_ident = Val_int(Int_val(next_ident) + 1); th->stack_low = (value *) stat_alloc(Thread_stack_size); th->stack_high = th->stack_low + Thread_stack_size / sizeof(value); th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value); th->sp = th->stack_high; th->trapsp = th->stack_high; /* Set up a return frame that pretends we're applying the function to (). This way, the next RETURN instruction will run the function. */ th->sp -= 5; th->sp[0] = Val_unit; /* dummy local to be popped by RETURN 1 */ th->sp[1] = (value) Code_val(clos); th->sp[2] = clos; th->sp[3] = Val_long(0); /* no extra args */ th->sp[4] = Val_unit; /* the () argument */ /* Fake a C call frame */ th->sp--; th->sp[0] = Val_unit; /* a dummy environment */ /* Finish initialization of th */ th->backtrace_pos = Val_int(0); th->backtrace_buffer = NULL; th->backtrace_last_exn = Val_unit; /* The thread is initially runnable */ th->status = RUNNABLE; th->fd = Val_int(0); th->readfds = NO_FDS; th->writefds = NO_FDS; th->exceptfds = NO_FDS; th->delay = NO_DELAY; th->joining = NO_JOINING; th->waitpid = NO_WAITPID; th->retval = Val_unit; /* Insert thread in doubly linked list of threads */ th->prev = curr_thread->prev; th->next = curr_thread; Assign(curr_thread->prev->next, th); Assign(curr_thread->prev, th); /* Return thread */ return (value) th; } /* Return the thread identifier */ value thread_id(value th) /* ML */ { return ((caml_thread_t)th)->ident; } /* Return the current time as a floating-point number */ static double timeofday(void) { struct timeval tv; gettimeofday(&tv, NULL); return (double) tv.tv_sec + (double) tv.tv_usec * 1e-6; } /* Find a runnable thread and activate it */ #define FOREACH_THREAD(x) x = curr_thread; do { x = x->next; #define END_FOREACH(x) } while (x != curr_thread) static value alloc_process_status(int pid, int status); static void add_fdlist_to_set(value fdl, fd_set *set); static value inter_fdlist_set(value fdl, fd_set *set, int *count); static void find_bad_fd(int fd, fd_set *set); static void find_bad_fds(value fdl, fd_set *set); static value schedule_thread(void) { caml_thread_t run_thread, th; fd_set readfds, writefds, exceptfds; double delay, now; int need_select, need_wait; /* Don't allow preemption during a callback */ if (callback_depth > 1) return curr_thread->retval; /* Save the status of the current thread */ curr_thread->stack_low = stack_low; curr_thread->stack_high = stack_high; curr_thread->stack_threshold = stack_threshold; curr_thread->sp = extern_sp; curr_thread->trapsp = trapsp; curr_thread->backtrace_pos = Val_int(backtrace_pos); curr_thread->backtrace_buffer = backtrace_buffer; caml_modify (&curr_thread->backtrace_last_exn, backtrace_last_exn); try_again: /* Find if a thread is runnable. Build fdsets and delay for select. See if some join or wait operations succeeded. */ run_thread = NULL; FD_ZERO(&readfds); FD_ZERO(&writefds); FD_ZERO(&exceptfds); delay = DELAY_INFTY; now = -1.0; need_select = 0; need_wait = 0; FOREACH_THREAD(th) if (th->status <= SUSPENDED) continue; if (th->status & (BLOCKED_READ - 1)) { FD_SET(Int_val(th->fd), &readfds); need_select = 1; } if (th->status & (BLOCKED_WRITE - 1)) { FD_SET(Int_val(th->fd), &writefds); need_select = 1; } if (th->status & (BLOCKED_SELECT - 1)) { add_fdlist_to_set(th->readfds, &readfds); add_fdlist_to_set(th->writefds, &writefds); add_fdlist_to_set(th->exceptfds, &exceptfds); need_select = 1; } if (th->status & (BLOCKED_DELAY - 1)) { double th_delay; if (now < 0.0) now = timeofday(); th_delay = Double_val(th->delay) - now; if (th_delay <= 0) { th->status = RUNNABLE; Assign(th->retval,RESUMED_DELAY); } else { if (th_delay < delay) delay = th_delay; } } if (th->status & (BLOCKED_JOIN - 1)) { if (((caml_thread_t)(th->joining))->status == KILLED) { th->status = RUNNABLE; Assign(th->retval, RESUMED_JOIN); } } if (th->status & (BLOCKED_WAIT - 1)) { int status, pid; pid = waitpid(Int_val(th->waitpid), &status, WNOHANG); if (pid > 0) { th->status = RUNNABLE; Assign(th->retval, alloc_process_status(pid, status)); } else { need_wait = 1; } } END_FOREACH(th); /* Find if a thread is runnable. */ run_thread = NULL; FOREACH_THREAD(th) if (th->status == RUNNABLE) { run_thread = th; break; } END_FOREACH(th); /* Do the select if needed */ if (need_select || run_thread == NULL) { struct timeval delay_tv, * delay_ptr; int retcode; /* If a thread is blocked on wait, don't block forever */ if (need_wait && delay > Thread_timeout * 1e-6) { delay = Thread_timeout * 1e-6; } /* Convert delay to a timeval */ /* If a thread is runnable, just poll */ if (run_thread != NULL) { delay_tv.tv_sec = 0; delay_tv.tv_usec = 0; delay_ptr = &delay_tv; } else if (delay != DELAY_INFTY) { delay_tv.tv_sec = (unsigned int) delay; delay_tv.tv_usec = (delay - (double) delay_tv.tv_sec) * 1E6; delay_ptr = &delay_tv; } else { delay_ptr = NULL; } enter_blocking_section(); retcode = select(FD_SETSIZE, &readfds, &writefds, &exceptfds, delay_ptr); leave_blocking_section(); if (retcode == -1) switch (errno) { case EINTR: break; case EBADF: /* One of the descriptors in the sets was closed or is bad. Find it using fstat() and wake up the threads waiting on it so that they'll get an error when operating on it. */ FOREACH_THREAD(th) if (th->status & (BLOCKED_READ - 1)) { find_bad_fd(Int_val(th->fd), &readfds); } if (th->status & (BLOCKED_WRITE - 1)) { find_bad_fd(Int_val(th->fd), &writefds); } if (th->status & (BLOCKED_SELECT - 1)) { find_bad_fds(th->readfds, &readfds); find_bad_fds(th->writefds, &writefds); find_bad_fds(th->exceptfds, &exceptfds); } END_FOREACH(th); retcode = FD_SETSIZE; break; default: sys_error(NO_ARG); } if (retcode > 0) { /* Some descriptors are ready. Mark the corresponding threads runnable. */ FOREACH_THREAD(th) if (retcode <= 0) break; if ((th->status & (BLOCKED_READ - 1)) && FD_ISSET(Int_val(th->fd), &readfds)) { Assign(th->retval, RESUMED_IO); th->status = RUNNABLE; if (run_thread == NULL) run_thread = th; /* Found one. */ /* Wake up only one thread per fd */ FD_CLR(Int_val(th->fd), &readfds); retcode--; } if ((th->status & (BLOCKED_WRITE - 1)) && FD_ISSET(Int_val(th->fd), &writefds)) { Assign(th->retval, RESUMED_IO); th->status = RUNNABLE; if (run_thread == NULL) run_thread = th; /* Found one. */ /* Wake up only one thread per fd */ FD_CLR(Int_val(th->fd), &readfds); retcode--; } if (th->status & (BLOCKED_SELECT - 1)) { value r = Val_unit, w = Val_unit, e = Val_unit; Begin_roots3(r,w,e) r = inter_fdlist_set(th->readfds, &readfds, &retcode); w = inter_fdlist_set(th->writefds, &writefds, &retcode); e = inter_fdlist_set(th->exceptfds, &exceptfds, &retcode); if (r != NO_FDS || w != NO_FDS || e != NO_FDS) { value retval = alloc_small(3, TAG_RESUMED_SELECT); Field(retval, 0) = r; Field(retval, 1) = w; Field(retval, 2) = e; Assign(th->retval, retval); th->status = RUNNABLE; if (run_thread == NULL) run_thread = th; /* Found one. */ } End_roots(); } END_FOREACH(th); } /* If we get here with run_thread still NULL, one of the following may have happened: - a delay has expired - a wait() needs to be polled again - the select() failed (e.g. was interrupted) In these cases, we go through the loop once more to make the corresponding threads runnable. */ if (run_thread == NULL && (delay != DELAY_INFTY || need_wait || retcode == -1)) goto try_again; } /* If we haven't something to run at that point, we're in big trouble. */ if (run_thread == NULL) invalid_argument("Thread: deadlock"); /* Free everything the thread was waiting on */ Assign(run_thread->readfds, NO_FDS); Assign(run_thread->writefds, NO_FDS); Assign(run_thread->exceptfds, NO_FDS); Assign(run_thread->delay, NO_DELAY); Assign(run_thread->joining, NO_JOINING); run_thread->waitpid = NO_WAITPID; /* Activate the thread */ curr_thread = run_thread; stack_low = curr_thread->stack_low; stack_high = curr_thread->stack_high; stack_threshold = curr_thread->stack_threshold; extern_sp = curr_thread->sp; trapsp = curr_thread->trapsp; backtrace_pos = Int_val(curr_thread->backtrace_pos); backtrace_buffer = curr_thread->backtrace_buffer; backtrace_last_exn = curr_thread->backtrace_last_exn; return curr_thread->retval; } /* Since context switching is not allowed in callbacks, a thread that blocks during a callback is a deadlock. */ static void check_callback(void) { if (callback_depth > 1) caml_fatal_error("Thread: deadlock during callback"); } /* Reschedule without suspending the current thread */ value thread_yield(value unit) /* ML */ { Assert(curr_thread != NULL); Assign(curr_thread->retval, Val_unit); return schedule_thread(); } /* Honor an asynchronous request for re-scheduling */ static void thread_reschedule(void) { value accu; Assert(curr_thread != NULL); /* Pop accu from event frame, making it look like a C_CALL frame followed by a RETURN frame */ accu = *extern_sp++; /* Reschedule */ Assign(curr_thread->retval, accu); accu = schedule_thread(); /* Push accu below C_CALL frame so that it looks like an event frame */ *--extern_sp = accu; } /* Request a re-scheduling as soon as possible */ value thread_request_reschedule(value unit) /* ML */ { async_action_hook = thread_reschedule; something_to_do = 1; return Val_unit; } /* Suspend the current thread */ value thread_sleep(value unit) /* ML */ { Assert(curr_thread != NULL); check_callback(); curr_thread->status = SUSPENDED; return schedule_thread(); } /* Suspend the current thread on a read() or write() request */ static value thread_wait_rw(int kind, value fd) { /* Don't do an error if we're not initialized yet (we can be called from thread-safe Pervasives before initialization), just return immediately. */ if (curr_thread == NULL) return RESUMED_WAKEUP; /* As a special case, if we're in a callback, don't fail but block the whole process till I/O is possible */ if (callback_depth > 1) { fd_set fds; FD_ZERO(&fds); FD_SET(Int_val(fd), &fds); switch(kind) { case BLOCKED_READ: select(FD_SETSIZE, &fds, NULL, NULL, NULL); break; case BLOCKED_WRITE: select(FD_SETSIZE, NULL, &fds, NULL, NULL); break; } return RESUMED_IO; } else { curr_thread->fd = fd; curr_thread->status = kind; return schedule_thread(); } } value thread_wait_read(value fd) { return thread_wait_rw(BLOCKED_READ, fd); } value thread_wait_write(value fd) { return thread_wait_rw(BLOCKED_WRITE, fd); } /* Suspend the current thread on a read() or write() request with timeout */ static value thread_wait_timed_rw(int kind, value arg) { double date; check_callback(); curr_thread->fd = Field(arg, 0); date = timeofday() + Double_val(Field(arg, 1)); Assign(curr_thread->delay, copy_double(date)); curr_thread->status = kind | BLOCKED_DELAY; return schedule_thread(); } value thread_wait_timed_read(value arg) { return thread_wait_timed_rw(BLOCKED_READ, arg); } value thread_wait_timed_write(value arg) { return thread_wait_timed_rw(BLOCKED_WRITE, arg); } /* Suspend the current thread on a select() request */ value thread_select(value arg) /* ML */ { double date; check_callback(); Assign(curr_thread->readfds, Field(arg, 0)); Assign(curr_thread->writefds, Field(arg, 1)); Assign(curr_thread->exceptfds, Field(arg, 2)); date = Double_val(Field(arg, 3)); if (date >= 0.0) { date += timeofday(); Assign(curr_thread->delay, copy_double(date)); curr_thread->status = BLOCKED_SELECT | BLOCKED_DELAY; } else { curr_thread->status = BLOCKED_SELECT; } return schedule_thread(); } /* Primitives to implement suspension on buffered channels */ value thread_inchan_ready(value vchan) /* ML */ { struct channel * chan = Channel(vchan); return Val_bool(chan->curr < chan->max); } value thread_outchan_ready(value vchan, value vsize) /* ML */ { struct channel * chan = Channel(vchan); intnat size = Long_val(vsize); /* Negative size means we want to flush the buffer entirely */ if (size < 0) { return Val_bool(chan->curr == chan->buff); } else { int free = chan->end - chan->curr; if (chan->curr == chan->buff) return Val_bool(size < free); else return Val_bool(size <= free); } } /* Suspend the current thread for some time */ value thread_delay(value time) /* ML */ { double date = timeofday() + Double_val(time); Assert(curr_thread != NULL); check_callback(); curr_thread->status = BLOCKED_DELAY; Assign(curr_thread->delay, copy_double(date)); return schedule_thread(); } /* Suspend the current thread until another thread terminates */ value thread_join(value th) /* ML */ { check_callback(); Assert(curr_thread != NULL); if (((caml_thread_t)th)->status == KILLED) return Val_unit; curr_thread->status = BLOCKED_JOIN; Assign(curr_thread->joining, th); return schedule_thread(); } /* Suspend the current thread until a Unix process exits */ value thread_wait_pid(value pid) /* ML */ { Assert(curr_thread != NULL); check_callback(); curr_thread->status = BLOCKED_WAIT; curr_thread->waitpid = pid; return schedule_thread(); } /* Reactivate another thread */ value thread_wakeup(value thread) /* ML */ { caml_thread_t th = (caml_thread_t) thread; switch (th->status) { case SUSPENDED: th->status = RUNNABLE; Assign(th->retval, RESUMED_WAKEUP); break; case KILLED: failwith("Thread.wakeup: killed thread"); default: failwith("Thread.wakeup: thread not suspended"); } return Val_unit; } /* Return the current thread */ value thread_self(value unit) /* ML */ { Assert(curr_thread != NULL); return (value) curr_thread; } /* Kill a thread */ value thread_kill(value thread) /* ML */ { value retval = Val_unit; caml_thread_t th = (caml_thread_t) thread; if (th->status == KILLED) failwith("Thread.kill: killed thread"); /* Don't paint ourselves in a corner */ if (th == th->next) failwith("Thread.kill: cannot kill the last thread"); /* This thread is no longer waiting on anything */ th->status = KILLED; /* If this is the current thread, activate another one */ if (th == curr_thread) { Begin_root(thread); retval = schedule_thread(); th = (caml_thread_t) thread; End_roots(); } /* Remove thread from the doubly-linked list */ Assign(th->prev->next, th->next); Assign(th->next->prev, th->prev); /* Free its resources */ stat_free((char *) th->stack_low); th->stack_low = NULL; th->stack_high = NULL; th->stack_threshold = NULL; th->sp = NULL; th->trapsp = NULL; if (th->backtrace_buffer != NULL) { free(th->backtrace_buffer); th->backtrace_buffer = NULL; } return retval; } /* Print uncaught exception and backtrace */ value thread_uncaught_exception(value exn) /* ML */ { char * msg = format_caml_exception(exn); fprintf(stderr, "Thread %d killed on uncaught exception %s\n", Int_val(curr_thread->ident), msg); free(msg); if (backtrace_active) print_exception_backtrace(); fflush(stderr); return Val_unit; } /* Set a list of file descriptors in a fdset */ static void add_fdlist_to_set(value fdl, fd_set *set) { for (/*nothing*/; fdl != NO_FDS; fdl = Field(fdl, 1)) { int fd = Int_val(Field(fdl, 0)); /* Ignore funky file descriptors, which can cause crashes */ if (fd >= 0 && fd < FD_SETSIZE) FD_SET(fd, set); } } /* Build the intersection of a list and a fdset (the list of file descriptors which are both in the list and in the fdset). */ static value inter_fdlist_set(value fdl, fd_set *set, int *count) { value res = Val_unit; value cons; Begin_roots2(fdl, res); for (res = NO_FDS; fdl != NO_FDS; fdl = Field(fdl, 1)) { int fd = Int_val(Field(fdl, 0)); if (FD_ISSET(fd, set)) { cons = alloc_small(2, 0); Field(cons, 0) = Val_int(fd); Field(cons, 1) = res; res = cons; FD_CLR(fd, set); /* wake up only one thread per fd ready */ (*count)--; } } End_roots(); return res; } /* Find closed file descriptors in a waiting list and set them to 1 in the given fdset */ static void find_bad_fd(int fd, fd_set *set) { struct stat s; if (fd >= 0 && fd < FD_SETSIZE && fstat(fd, &s) == -1 && errno == EBADF) FD_SET(fd, set); } static void find_bad_fds(value fdl, fd_set *set) { for (/*nothing*/; fdl != NO_FDS; fdl = Field(fdl, 1)) find_bad_fd(Int_val(Field(fdl, 0)), set); } /* Auxiliary function for allocating the result of a waitpid() call */ #if !(defined(WIFEXITED) && defined(WEXITSTATUS) && defined(WIFSTOPPED) && \ defined(WSTOPSIG) && defined(WTERMSIG)) /* Assume old-style V7 status word */ #define WIFEXITED(status) (((status) & 0xFF) == 0) #define WEXITSTATUS(status) (((status) >> 8) & 0xFF) #define WIFSTOPPED(status) (((status) & 0xFF) == 0xFF) #define WSTOPSIG(status) (((status) >> 8) & 0xFF) #define WTERMSIG(status) ((status) & 0x3F) #endif #define TAG_WEXITED 0 #define TAG_WSIGNALED 1 #define TAG_WSTOPPED 2 static value alloc_process_status(int pid, int status) { value st, res; if (WIFEXITED(status)) { st = alloc_small(1, TAG_WEXITED); Field(st, 0) = Val_int(WEXITSTATUS(status)); } else if (WIFSTOPPED(status)) { st = alloc_small(1, TAG_WSTOPPED); Field(st, 0) = Val_int(WSTOPSIG(status)); } else { st = alloc_small(1, TAG_WSIGNALED); Field(st, 0) = Val_int(WTERMSIG(status)); } Begin_root(st); res = alloc_small(2, TAG_RESUMED_WAIT); Field(res, 0) = Val_int(pid); Field(res, 1) = st; End_roots(); return res; } /* Restore the standard file descriptors to their initial state */ static void thread_restore_std_descr(void) { if (stdin_initial_status != -1) fcntl(0, F_SETFL, stdin_initial_status); if (stdout_initial_status != -1) fcntl(1, F_SETFL, stdout_initial_status); if (stderr_initial_status != -1) fcntl(2, F_SETFL, stderr_initial_status); } mingw-ocaml/ocaml/otherlibs/threads/unix.mllib0000644000175000017500000000002012124403241021077 0ustar tootstootsUnix UnixLabels mingw-ocaml/ocaml/otherlibs/threads/threads.mllib0000644000175000017500000000005012124403241021551 0ustar tootstootsThread Mutex Condition Event ThreadUnix mingw-ocaml/ocaml/otherlibs/threads/condition.mli0000644000175000017500000000430212124403241021573 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Condition variables to synchronize between threads. Condition variables are used when one thread wants to wait until another thread has finished doing something: the former thread ``waits'' on the condition variable, the latter thread ``signals'' the condition when it is done. Condition variables should always be protected by a mutex. The typical use is (if [D] is a shared data structure, [m] its mutex, and [c] is a condition variable): {[ Mutex.lock m; while (* some predicate P over D is not satisfied *) do Condition.wait c m done; (* Modify D *) if (* the predicate P over D is now satified *) then Condition.signal c; Mutex.unlock m ]} *) type t (** The type of condition variables. *) val create : unit -> t (** Return a new condition variable. *) val wait : t -> Mutex.t -> unit (** [wait c m] atomically unlocks the mutex [m] and suspends the calling process on the condition variable [c]. The process will restart after the condition variable [c] has been signalled. The mutex [m] is locked again before [wait] returns. *) val signal : t -> unit (** [signal c] restarts one of the processes waiting on the condition variable [c]. *) val broadcast : t -> unit (** [broadcast c] restarts all processes waiting on the condition variable [c]. *) mingw-ocaml/ocaml/otherlibs/threads/.depend0000644000175000017500000000262612124403241020351 0ustar tootstootsscheduler.o: scheduler.c ../../byterun/alloc.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/backtrace.h ../../byterun/callback.h \ ../../byterun/config.h ../../byterun/fail.h ../../byterun/io.h \ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/misc.h \ ../../byterun/mlvalues.h ../../byterun/printexc.h ../../byterun/roots.h \ ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \ ../../byterun/sys.h condition.cmi : mutex.cmi event.cmi : marshal.cmi : mutex.cmi : pervasives.cmi : thread.cmi : unix.cmi threadUnix.cmi : unix.cmi unix.cmi : condition.cmo : thread.cmi mutex.cmi condition.cmi condition.cmx : thread.cmx mutex.cmx condition.cmi event.cmo : mutex.cmi condition.cmi event.cmi event.cmx : mutex.cmx condition.cmx event.cmi marshal.cmo : pervasives.cmi marshal.cmi marshal.cmx : pervasives.cmx marshal.cmi mutex.cmo : thread.cmi mutex.cmi mutex.cmx : thread.cmx mutex.cmi pervasives.cmo : unix.cmi pervasives.cmi pervasives.cmx : unix.cmx pervasives.cmi thread.cmo : unix.cmi thread.cmi thread.cmx : unix.cmx thread.cmi threadUnix.cmo : unix.cmi thread.cmi threadUnix.cmi threadUnix.cmx : unix.cmx thread.cmx threadUnix.cmi unix.cmo : unix.cmi unix.cmx : unix.cmi mingw-ocaml/ocaml/otherlibs/Makefile0000644000175000017500000000225012124403241017110 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ # Common Makefile for otherlibs on the Unix ports CAMLC=$(ROOTDIR)/ocamlcomp.sh CAMLOPT=$(ROOTDIR)/ocamlcompopt.sh CFLAGS=-I$(ROOTDIR)/byterun -O $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS) include ../Makefile.shared # Note .. is the current directory (this makefile is included from # a subdirectory) mingw-ocaml/ocaml/otherlibs/Makefile.nt0000644000175000017500000000237512124403241017540 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ # Common Makefile for otherlibs on the Win32/MinGW ports CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib -w s CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib -w s CFLAGS=-I$(ROOTDIR)/byterun $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS) include ../Makefile.shared # Note .. is the current directory (this makefile is included from # a subdirectory) mingw-ocaml/ocaml/otherlibs/win32unix/0000755000175000017500000000000012124403241017317 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/win32unix/errmsg.c0000644000175000017500000000314312124403241020763 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include "unixsupport.h" extern int error_table[]; CAMLprim value unix_error_message(value err) { int errnum; char buffer[512]; errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)]; if (errnum > 0) return copy_string(strerror(errnum)); if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, NULL, -errnum, 0, buffer, sizeof(buffer), NULL)) return copy_string(buffer); sprintf(buffer, "unknown error #%d", errnum); return copy_string(buffer); } mingw-ocaml/ocaml/otherlibs/win32unix/lockf.c0000644000175000017500000001252412124403241020565 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Contributed by Tracy Camp, PolyServe Inc., */ /* Further improvements by Reed Wilson */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* under the terms of the GNU Library General Public License. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include "unixsupport.h" #include #include #ifndef INVALID_SET_FILE_POINTER #define INVALID_SET_FILE_POINTER (-1) #endif /* Sets handle h to a position based on gohere */ /* output, if set, is changed to the new location */ static void set_file_pointer(HANDLE h, LARGE_INTEGER gohere, PLARGE_INTEGER output, DWORD method) { LONG high = gohere.HighPart; DWORD ret = SetFilePointer(h, gohere.LowPart, &high, method); if(ret == INVALID_SET_FILE_POINTER) { DWORD err = GetLastError(); if(err != NO_ERROR) { win32_maperr(err); uerror("lockf", Nothing); } } if(output != NULL) { output->LowPart = ret; output->HighPart = high; } } CAMLprim value unix_lockf(value fd, value cmd, value span) { CAMLparam3(fd, cmd, span); OVERLAPPED overlap; intnat l_len; HANDLE h; OSVERSIONINFO version; LARGE_INTEGER cur_position; LARGE_INTEGER beg_position; LARGE_INTEGER lock_len; LARGE_INTEGER zero; DWORD err = NO_ERROR; version.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); if(GetVersionEx(&version) == 0) { invalid_argument("lockf only supported on WIN32_NT platforms: could not determine current platform."); } if(version.dwPlatformId != VER_PLATFORM_WIN32_NT) { invalid_argument("lockf only supported on WIN32_NT platforms"); } h = Handle_val(fd); l_len = Long_val(span); /* No matter what, we need the current position in the file */ zero.HighPart = zero.LowPart = 0; set_file_pointer(h, zero, &cur_position, FILE_CURRENT); /* All unused fields must be set to zero */ memset(&overlap, 0, sizeof(overlap)); if(l_len == 0) { /* Lock from cur to infinity */ lock_len.QuadPart = -1; overlap.OffsetHigh = cur_position.HighPart; overlap.Offset = cur_position.LowPart ; } else if(l_len > 0) { /* Positive file offset */ lock_len.QuadPart = l_len; overlap.OffsetHigh = cur_position.HighPart; overlap.Offset = cur_position.LowPart ; } else { /* Negative file offset */ lock_len.QuadPart = - l_len; if (lock_len.QuadPart > cur_position.QuadPart) { errno = EINVAL; uerror("lockf", Nothing); } beg_position.QuadPart = cur_position.QuadPart - lock_len.QuadPart; overlap.OffsetHigh = beg_position.HighPart; overlap.Offset = beg_position.LowPart ; } switch(Int_val(cmd)) { case 0: /* F_ULOCK - unlock */ if (! UnlockFileEx(h, 0, lock_len.LowPart, lock_len.HighPart, &overlap)) err = GetLastError(); break; case 1: /* F_LOCK - blocking write lock */ enter_blocking_section(); if (! LockFileEx(h, LOCKFILE_EXCLUSIVE_LOCK, 0, lock_len.LowPart, lock_len.HighPart, &overlap)) err = GetLastError(); leave_blocking_section(); break; case 2: /* F_TLOCK - non-blocking write lock */ if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0, lock_len.LowPart, lock_len.HighPart, &overlap)) err = GetLastError(); break; case 3: /* F_TEST - check whether a write lock can be obtained */ /* I'm doing this by aquiring an immediate write * lock and then releasing it. It is not clear that * this behavior matches anything in particular, but * it is not clear the nature of the lock test performed * by ocaml (unix) currently. */ if (LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0, lock_len.LowPart, lock_len.HighPart, &overlap)) { UnlockFileEx(h, 0, lock_len.LowPart, lock_len.HighPart, &overlap); } else { err = GetLastError(); } break; case 4: /* F_RLOCK - blocking read lock */ enter_blocking_section(); if (! LockFileEx(h, 0, 0, lock_len.LowPart, lock_len.HighPart, &overlap)) err = GetLastError(); leave_blocking_section(); break; case 5: /* F_TRLOCK - non-blocking read lock */ if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY, 0, lock_len.LowPart, lock_len.HighPart, &overlap)) err = GetLastError(); break; default: errno = EINVAL; uerror("lockf", Nothing); } if (err != NO_ERROR) { win32_maperr(err); uerror("lockf", Nothing); } CAMLreturn(Val_unit); } mingw-ocaml/ocaml/otherlibs/win32unix/close.c0000644000175000017500000000314712124403241020575 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" #include extern int _close(int); CAMLprim value unix_close(value fd) { if (Descr_kind_val(fd) == KIND_SOCKET) { if (closesocket(Socket_val(fd)) != 0) { win32_maperr(WSAGetLastError()); uerror("close", Nothing); } } else { /* If we have an fd then closing it also closes * the underlying handle. Also, closing only * the handle and not the fd leads to fd leaks. */ if (CRT_fd_val(fd) != NO_CRT_FD) { if (_close(CRT_fd_val(fd)) != 0) uerror("close", Nothing); } else { if (! CloseHandle(Handle_val(fd))) { win32_maperr(GetLastError()); uerror("close", Nothing); } } } return Val_unit; } mingw-ocaml/ocaml/otherlibs/win32unix/.ignore0000644000175000017500000000041112124403241020577 0ustar tootstootsunixLabels.ml* unix.mli unix.lib access.c addrofstr.c chdir.c chmod.c cst2constr.c cstringv.c envir.c execv.c execve.c execvp.c exit.c getcwd.c gethost.c gethostname.c getproto.c getserv.c gmtime.c putenv.c rmdir.c socketaddr.c strofaddr.c time.c unlink.c utimes.c mingw-ocaml/ocaml/otherlibs/win32unix/mkdir.c0000644000175000017500000000210612124403241020570 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_mkdir(path, perm) value path, perm; { if (_mkdir(String_val(path)) == -1) uerror("mkdir", path); return Val_unit; } mingw-ocaml/ocaml/otherlibs/win32unix/channels.c0000644000175000017500000000553312124403241021264 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #include extern intptr_t _get_osfhandle(int); extern int _open_osfhandle(intptr_t, int); int win_CRT_fd_of_filedescr(value handle) { if (CRT_fd_val(handle) != NO_CRT_FD) { return CRT_fd_val(handle); } else { int fd = _open_osfhandle((intptr_t) Handle_val(handle), O_BINARY); if (fd == -1) uerror("channel_of_descr", Nothing); CRT_fd_val(handle) = fd; return fd; } } CAMLprim value win_inchannel_of_filedescr(value handle) { CAMLparam1(handle); CAMLlocal1(vchan); struct channel * chan; chan = caml_open_descriptor_in(win_CRT_fd_of_filedescr(handle)); if (Descr_kind_val(handle) == KIND_SOCKET) chan->flags |= CHANNEL_FLAG_FROM_SOCKET; vchan = caml_alloc_channel(chan); CAMLreturn(vchan); } CAMLprim value win_outchannel_of_filedescr(value handle) { CAMLparam1(handle); CAMLlocal1(vchan); int fd; struct channel * chan; chan = caml_open_descriptor_out(win_CRT_fd_of_filedescr(handle)); if (Descr_kind_val(handle) == KIND_SOCKET) chan->flags |= CHANNEL_FLAG_FROM_SOCKET; vchan = caml_alloc_channel(chan); CAMLreturn(vchan); } CAMLprim value win_filedescr_of_channel(value vchan) { CAMLparam1(vchan); CAMLlocal1(fd); struct channel * chan; HANDLE h; chan = Channel(vchan); if (chan->fd == -1) uerror("descr_of_channel", Nothing); h = (HANDLE) _get_osfhandle(chan->fd); if (chan->flags & CHANNEL_FLAG_FROM_SOCKET) fd = win_alloc_socket((SOCKET) h); else fd = win_alloc_handle(h); CRT_fd_val(fd) = chan->fd; CAMLreturn(fd); } CAMLprim value win_handle_fd(value vfd) { int crt_fd = Int_val(vfd); /* PR#4750: do not use the _or_socket variant as it can cause performance degradation and this function is only used with the standard handles 0, 1, 2, which are not sockets. */ value res = win_alloc_handle((HANDLE) _get_osfhandle(crt_fd)); CRT_fd_val(res) = crt_fd; return res; } mingw-ocaml/ocaml/otherlibs/win32unix/shutdown.c0000644000175000017500000000235112124403241021337 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" static int shutdown_command_table[] = { 0, 1, 2 }; CAMLprim value unix_shutdown(sock, cmd) value sock, cmd; { if (shutdown(Socket_val(sock), shutdown_command_table[Int_val(cmd)]) == -1) { win32_maperr(WSAGetLastError()); uerror("shutdown", Nothing); } return Val_unit; } mingw-ocaml/ocaml/otherlibs/win32unix/getpeername.c0000644000175000017500000000254212124403241021762 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" #include "socketaddr.h" CAMLprim value unix_getpeername(sock) value sock; { int retcode; union sock_addr_union addr; socklen_param_type addr_len; addr_len = sizeof(sock_addr); retcode = getpeername(Socket_val(sock), &addr.s_gen, &addr_len); if (retcode == -1) { win32_maperr(WSAGetLastError()); uerror("getpeername", Nothing); } return alloc_sockaddr(&addr, addr_len, -1); } mingw-ocaml/ocaml/otherlibs/win32unix/winworker.h0000644000175000017500000000453712124403241021530 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Contributed by Sylvain Le Gall for Lexifi */ /* */ /* Copyright 2008 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef _WINWORKER_H #define _WINWORKER_H #define _WIN32_WINNT 0x0400 #include /* Pool of worker threads. * * These functions help to manage a pool of worker thread and submit task to * the pool. It helps to reduce the number of thread creation. * * Each worker are started in alertable wait state and jobs are submitted as * APC (asynchronous procedure call). */ /* Data associated with submitted job */ typedef struct _WORKER WORKER; typedef WORKER *LPWORKER; /* Function type of submitted job: * void worker_call (HANDLE hStop, void *data) * * This function will be called using the data following: * - hStop must be watched for change, since it represents an external command * to stop the call. This event is shared through the WORKER structure, which * can be access throuhg worker_job_event_done. * - data is user provided data for the function. */ typedef void (*WORKERFUNC) (HANDLE, void *); /* Initialize global data structure for worker */ void worker_init (void); /* Free global data structure for worker */ void worker_cleanup (void); /* Submit a job to worker. Use returned data to synchronize with the procedure * submitted. */ LPWORKER worker_job_submit (WORKERFUNC f, void *data); /* Get event to know when a job is done. */ HANDLE worker_job_event_done (LPWORKER); /* Ask a job to stop processing. */ void worker_job_stop (LPWORKER); /* End a job submitted to worker. */ void worker_job_finish (LPWORKER); #endif /* _WINWORKER_H */ mingw-ocaml/ocaml/otherlibs/win32unix/socketaddr.h0000644000175000017500000000304112124403241021611 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include union sock_addr_union { struct sockaddr s_gen; struct sockaddr_in s_inet; }; extern union sock_addr_union sock_addr; #ifdef HAS_SOCKLEN_T typedef socklen_t socklen_param_type; #else typedef int socklen_param_type; #endif extern void get_sockaddr (value mladdr, union sock_addr_union * addr /*out*/, socklen_param_type * addr_len /*out*/); CAMLprim value alloc_sockaddr (union sock_addr_union * addr /*in*/, socklen_param_type addr_len, int close_on_error); CAMLprim value alloc_inet_addr (struct in_addr * inaddr); #define GET_INET_ADDR(v) (*((struct in_addr *) (v))) mingw-ocaml/ocaml/otherlibs/win32unix/write.c0000644000175000017500000000630612124403241020622 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include "unixsupport.h" CAMLprim value unix_write(value fd, value buf, value vofs, value vlen) { intnat ofs, len, written; DWORD numbytes, numwritten; char iobuf[UNIX_BUFFER_SIZE]; DWORD err = 0; Begin_root (buf); ofs = Long_val(vofs); len = Long_val(vlen); written = 0; while (len > 0) { numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; memmove (iobuf, &Byte(buf, ofs), numbytes); if (Descr_kind_val(fd) == KIND_SOCKET) { int ret; SOCKET s = Socket_val(fd); enter_blocking_section(); ret = send(s, iobuf, numbytes, 0); if (ret == SOCKET_ERROR) err = WSAGetLastError(); leave_blocking_section(); numwritten = ret; } else { HANDLE h = Handle_val(fd); enter_blocking_section(); if (! WriteFile(h, iobuf, numbytes, &numwritten, NULL)) err = GetLastError(); leave_blocking_section(); } if (err) { win32_maperr(err); uerror("write", Nothing); } written += numwritten; ofs += numwritten; len -= numwritten; } End_roots(); return Val_long(written); } CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen) { intnat ofs, len, written; DWORD numbytes, numwritten; char iobuf[UNIX_BUFFER_SIZE]; DWORD err = 0; Begin_root (buf); ofs = Long_val(vofs); len = Long_val(vlen); written = 0; if (len > 0) { numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; memmove (iobuf, &Byte(buf, ofs), numbytes); if (Descr_kind_val(fd) == KIND_SOCKET) { int ret; SOCKET s = Socket_val(fd); enter_blocking_section(); ret = send(s, iobuf, numbytes, 0); if (ret == SOCKET_ERROR) err = WSAGetLastError(); leave_blocking_section(); numwritten = ret; } else { HANDLE h = Handle_val(fd); enter_blocking_section(); if (! WriteFile(h, iobuf, numbytes, &numwritten, NULL)) err = GetLastError(); leave_blocking_section(); } if (err) { win32_maperr(err); uerror("single_write", Nothing); } written = numwritten; } End_roots(); return Val_long(written); } mingw-ocaml/ocaml/otherlibs/win32unix/sendrecv.c0000644000175000017500000001043112124403241021273 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #include "socketaddr.h" static int msg_flag_table[] = { MSG_OOB, MSG_DONTROUTE, MSG_PEEK }; CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value flags) { SOCKET s = Socket_val(sock); int flg = convert_flag_list(flags, msg_flag_table); int ret; intnat numbytes; char iobuf[UNIX_BUFFER_SIZE]; DWORD err = 0; Begin_root (buff); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; enter_blocking_section(); ret = recv(s, iobuf, (int) numbytes, flg); if (ret == -1) err = WSAGetLastError(); leave_blocking_section(); if (ret == -1) { win32_maperr(err); uerror("recv", Nothing); } memmove (&Byte(buff, Long_val(ofs)), iobuf, ret); End_roots(); return Val_int(ret); } CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags) { SOCKET s = Socket_val(sock); int flg = convert_flag_list(flags, msg_flag_table); int ret; intnat numbytes; char iobuf[UNIX_BUFFER_SIZE]; value res; value adr = Val_unit; union sock_addr_union addr; socklen_param_type addr_len; DWORD err = 0; Begin_roots2 (buff, adr); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; addr_len = sizeof(sock_addr); enter_blocking_section(); ret = recvfrom(s, iobuf, (int) numbytes, flg, &addr.s_gen, &addr_len); if (ret == -1) err = WSAGetLastError(); leave_blocking_section(); if (ret == -1) { win32_maperr(err); uerror("recvfrom", Nothing); } memmove (&Byte(buff, Long_val(ofs)), iobuf, ret); adr = alloc_sockaddr(&addr, addr_len, -1); res = alloc_small(2, 0); Field(res, 0) = Val_int(ret); Field(res, 1) = adr; End_roots(); return res; } CAMLprim value unix_send(value sock, value buff, value ofs, value len, value flags) { SOCKET s = Socket_val(sock); int flg = convert_flag_list(flags, msg_flag_table); int ret; intnat numbytes; char iobuf[UNIX_BUFFER_SIZE]; DWORD err = 0; numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes); enter_blocking_section(); ret = send(s, iobuf, (int) numbytes, flg); if (ret == -1) err = WSAGetLastError(); leave_blocking_section(); if (ret == -1) { win32_maperr(err); uerror("send", Nothing); } return Val_int(ret); } value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest) { SOCKET s = Socket_val(sock); int flg = convert_flag_list(flags, msg_flag_table); int ret; intnat numbytes; char iobuf[UNIX_BUFFER_SIZE]; union sock_addr_union addr; socklen_param_type addr_len; DWORD err = 0; get_sockaddr(dest, &addr, &addr_len); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes); enter_blocking_section(); ret = sendto(s, iobuf, (int) numbytes, flg, &addr.s_gen, addr_len); if (ret == -1) err = WSAGetLastError(); leave_blocking_section(); if (ret == -1) { win32_maperr(err); uerror("sendto", Nothing); } return Val_int(ret); } CAMLprim value unix_sendto(value * argv, int argc) { return unix_sendto_native (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } mingw-ocaml/ocaml/otherlibs/win32unix/nonblock.c0000755000175000017500000000314012124403241021271 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" CAMLprim value unix_set_nonblock(socket) value socket; { u_long non_block = 1; if (ioctlsocket(Socket_val(socket), FIONBIO, &non_block) != 0) { win32_maperr(WSAGetLastError()); uerror("unix_set_nonblock", Nothing); } Flags_fd_val(socket) = Flags_fd_val(socket) & ~FLAGS_FD_IS_BLOCKING; return Val_unit; } CAMLprim value unix_clear_nonblock(socket) value socket; { u_long non_block = 0; if (ioctlsocket(Socket_val(socket), FIONBIO, &non_block) != 0) { win32_maperr(WSAGetLastError()); uerror("unix_clear_nonblock", Nothing); } Flags_fd_val(socket) = Flags_fd_val(socket) | FLAGS_FD_IS_BLOCKING; return Val_unit; } mingw-ocaml/ocaml/otherlibs/win32unix/dup.c0000644000175000017500000000251612124403241020257 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_dup(value fd) { HANDLE newh; value newfd; int kind = Descr_kind_val(fd); if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd), GetCurrentProcess(), &newh, 0L, TRUE, DUPLICATE_SAME_ACCESS)) { win32_maperr(GetLastError()); return -1; } newfd = win_alloc_handle(newh); Descr_kind_val(newfd) = kind; return newfd; } mingw-ocaml/ocaml/otherlibs/win32unix/winwait.c0000644000175000017500000000430012124403241021142 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Pascal Cuoq and Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #include #include static value alloc_process_status(HANDLE pid, int status) { value res, st; st = alloc(1, 0); Field(st, 0) = Val_int(status); Begin_root (st); res = alloc_small(2, 0); Field(res, 0) = Val_long((intnat) pid); Field(res, 1) = st; End_roots(); return res; } enum { CAML_WNOHANG = 1, CAML_WUNTRACED = 2 }; static int wait_flag_table[] = { CAML_WNOHANG, CAML_WUNTRACED }; CAMLprim value win_waitpid(value vflags, value vpid_req) { int flags; DWORD status, retcode; HANDLE pid_req = (HANDLE) Long_val(vpid_req); DWORD err = 0; flags = convert_flag_list(vflags, wait_flag_table); if ((flags & CAML_WNOHANG) == 0) { enter_blocking_section(); retcode = WaitForSingleObject(pid_req, INFINITE); if (retcode == WAIT_FAILED) err = GetLastError(); leave_blocking_section(); if (err) { win32_maperr(err); uerror("waitpid", Nothing); } } if (! GetExitCodeProcess(pid_req, &status)) { win32_maperr(GetLastError()); uerror("waitpid", Nothing); } if (status == STILL_ACTIVE) return alloc_process_status((HANDLE) 0, 0); else { CloseHandle(pid_req); return alloc_process_status(pid_req, status); } } mingw-ocaml/ocaml/otherlibs/win32unix/system.c0000644000175000017500000000275112124403241021014 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #include #include CAMLprim value win_system(cmd) value cmd; { int ret; value st; char *buf; intnat len; len = caml_string_length (cmd); buf = caml_stat_alloc (len + 1); memmove (buf, String_val (cmd), len + 1); enter_blocking_section(); _flushall(); ret = system(buf); leave_blocking_section(); caml_stat_free(buf); if (ret == -1) uerror("system", Nothing); st = alloc_small(1, 0); /* Tag 0: Exited */ Field(st, 0) = Val_int(ret); return st; } mingw-ocaml/ocaml/otherlibs/win32unix/Makefile.nt0000644000175000017500000000421012124403241021374 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ # Files in this directory WIN_FILES = accept.c bind.c channels.c close.c \ close_on.c connect.c createprocess.c dup.c dup2.c errmsg.c \ getpeername.c getpid.c getsockname.c gettimeofday.c \ link.c listen.c lockf.c lseek.c nonblock.c \ mkdir.c open.c pipe.c read.c rename.c \ select.c sendrecv.c \ shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \ system.c times.c unixsupport.c windir.c winwait.c write.c \ winlist.c winworker.c windbug.c # Files from the ../unix directory UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \ cstringv.c envir.c execv.c execve.c execvp.c \ exit.c getcwd.c gethost.c gethostname.c getproto.c \ getserv.c gmtime.c putenv.c rmdir.c \ socketaddr.c strofaddr.c time.c unlink.c utimes.c UNIX_CAML_FILES = unix.mli unixLabels.mli unixLabels.ml ALL_FILES=$(WIN_FILES) $(UNIX_FILES) WSOCKLIB=$(call SYSLIB,ws2_32) LIBNAME=unix COBJS=$(ALL_FILES:.c=.$(O)) CAMLOBJS=unix.cmo unixLabels.cmo LINKOPTS=-cclib $(WSOCKLIB) LDOPTS=-ldopt $(WSOCKLIB) EXTRACAMLFLAGS=-nolabels EXTRACFLAGS=-I../unix HEADERS=unixsupport.h socketaddr.h include ../Makefile.nt clean:: rm -f $(UNIX_FILES) $(UNIX_CAML_FILES) $(UNIX_FILES) $(UNIX_CAML_FILES): %: ../unix/% cp ../unix/$* $* depend: $(COBJS): unixsupport.h include .depend mingw-ocaml/ocaml/otherlibs/win32unix/close_on.c0000644000175000017500000000320412124403241021263 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" int win_set_inherit(value fd, BOOL inherit) { /* According to the MSDN, SetHandleInformation may not work for console handles on WinNT4 and earlier versions. */ if (! SetHandleInformation(Handle_val(fd), HANDLE_FLAG_INHERIT, inherit ? HANDLE_FLAG_INHERIT : 0)) { win32_maperr(GetLastError()); return -1; } return 0; } CAMLprim value win_set_close_on_exec(value fd) { if (win_set_inherit(fd, FALSE) == -1) uerror("set_close_on_exec", Nothing); return Val_unit; } CAMLprim value win_clear_close_on_exec(value fd) { if (win_set_inherit(fd, TRUE) == -1) uerror("clear_close_on_exec", Nothing); return Val_unit; } mingw-ocaml/ocaml/otherlibs/win32unix/open.c0000644000175000017500000000502512124403241020426 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #include static int open_access_flags[13] = { GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }; static int open_create_flags[13] = { 0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0, 0 }; static int open_share_flags[13] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, FILE_SHARE_DELETE }; CAMLprim value unix_open(value path, value flags, value perm) { int fileaccess, createflags, fileattrib, filecreate, sharemode; SECURITY_ATTRIBUTES attr; HANDLE h; fileaccess = convert_flag_list(flags, open_access_flags); sharemode = FILE_SHARE_READ | FILE_SHARE_WRITE | convert_flag_list(flags, open_share_flags); createflags = convert_flag_list(flags, open_create_flags); if ((createflags & (O_CREAT | O_EXCL)) == (O_CREAT | O_EXCL)) filecreate = CREATE_NEW; else if ((createflags & (O_CREAT | O_TRUNC)) == (O_CREAT | O_TRUNC)) filecreate = CREATE_ALWAYS; else if (createflags & O_TRUNC) filecreate = TRUNCATE_EXISTING; else if (createflags & O_CREAT) filecreate = OPEN_ALWAYS; else filecreate = OPEN_EXISTING; if ((createflags & O_CREAT) && (Int_val(perm) & 0200) == 0) fileattrib = FILE_ATTRIBUTE_READONLY; else fileattrib = FILE_ATTRIBUTE_NORMAL; attr.nLength = sizeof(attr); attr.lpSecurityDescriptor = NULL; attr.bInheritHandle = TRUE; h = CreateFile(String_val(path), fileaccess, sharemode, &attr, filecreate, fileattrib, NULL); if (h == INVALID_HANDLE_VALUE) { win32_maperr(GetLastError()); uerror("open", path); } return win_alloc_handle(h); } mingw-ocaml/ocaml/otherlibs/win32unix/bind.c0000644000175000017500000000246012124403241020401 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" #include "socketaddr.h" CAMLprim value unix_bind(socket, address) value socket, address; { int ret; union sock_addr_union addr; socklen_param_type addr_len; get_sockaddr(address, &addr, &addr_len); ret = bind(Socket_val(socket), &addr.s_gen, addr_len); if (ret == -1) { win32_maperr(WSAGetLastError()); uerror("bind", Nothing); } return Val_unit; } mingw-ocaml/ocaml/otherlibs/win32unix/select.c0000644000175000017500000010654112124403241020751 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Contributed by Sylvain Le Gall for Lexifi */ /* */ /* Copyright 2008 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include #include #include #include "unixsupport.h" #include "windbug.h" #include "winworker.h" #include "winlist.h" /* This constant define the maximum number of objects that * can be handle by a SELECTDATA. * It takes the following parameters into account: * - limitation on number of objects is mostly due to limitation * a WaitForMultipleObjects * - there is always an event "hStop" to watch * * This lead to pick the following value as the biggest possible * value */ #define MAXIMUM_SELECT_OBJECTS (MAXIMUM_WAIT_OBJECTS - 1) /* Manage set of handle */ typedef struct _SELECTHANDLESET { LPHANDLE lpHdl; DWORD nMax; DWORD nLast; } SELECTHANDLESET; typedef SELECTHANDLESET *LPSELECTHANDLESET; void handle_set_init (LPSELECTHANDLESET hds, LPHANDLE lpHdl, DWORD max) { DWORD i; hds->lpHdl = lpHdl; hds->nMax = max; hds->nLast = 0; /* Set to invalid value every entry of the handle */ for (i = 0; i < hds->nMax; i++) { hds->lpHdl[i] = INVALID_HANDLE_VALUE; }; } void handle_set_add (LPSELECTHANDLESET hds, HANDLE hdl) { LPSELECTHANDLESET res; if (hds->nLast < hds->nMax) { hds->lpHdl[hds->nLast] = hdl; hds->nLast++; } DEBUG_PRINT("Adding handle %x to set %x", hdl, hds); } BOOL handle_set_mem (LPSELECTHANDLESET hds, HANDLE hdl) { BOOL res; DWORD i; res = FALSE; for (i = 0; !res && i < hds->nLast; i++) { res = (hds->lpHdl[i] == hdl); } return res; } void handle_set_reset (LPSELECTHANDLESET hds) { DWORD i; for (i = 0; i < hds->nMax; i++) { hds->lpHdl[i] = INVALID_HANDLE_VALUE; } hds->nMax = 0; hds->nLast = 0; hds->lpHdl = NULL; } /* Data structure for handling select */ typedef enum _SELECTHANDLETYPE { SELECT_HANDLE_NONE = 0, SELECT_HANDLE_DISK, SELECT_HANDLE_CONSOLE, SELECT_HANDLE_PIPE, SELECT_HANDLE_SOCKET, } SELECTHANDLETYPE; typedef enum _SELECTMODE { SELECT_MODE_NONE = 0, SELECT_MODE_READ = 1, SELECT_MODE_WRITE = 2, SELECT_MODE_EXCEPT = 4, } SELECTMODE; typedef enum _SELECTSTATE { SELECT_STATE_NONE = 0, SELECT_STATE_INITFAILED, SELECT_STATE_ERROR, SELECT_STATE_SIGNALED } SELECTSTATE; typedef enum _SELECTTYPE { SELECT_TYPE_NONE = 0, SELECT_TYPE_STATIC, /* Result is known without running anything */ SELECT_TYPE_CONSOLE_READ, /* Reading data on console */ SELECT_TYPE_PIPE_READ, /* Reading data on pipe */ SELECT_TYPE_SOCKET /* Classic select */ } SELECTTYPE; /* Data structure for results */ typedef struct _SELECTRESULT { LIST lst; SELECTMODE EMode; int lpOrigIdx; } SELECTRESULT; typedef SELECTRESULT *LPSELECTRESULT; /* Data structure for query */ typedef struct _SELECTQUERY { LIST lst; SELECTMODE EMode; HANDLE hFileDescr; int lpOrigIdx; unsigned int uFlagsFd; /* Copy of filedescr->flags_fd */ } SELECTQUERY; typedef SELECTQUERY *LPSELECTQUERY; typedef struct _SELECTDATA { LIST lst; SELECTTYPE EType; /* Sockets may generate a result for all three lists from one single query object */ SELECTRESULT aResults[MAXIMUM_SELECT_OBJECTS * 3]; DWORD nResultsCount; /* Data following are dedicated to APC like call, they will be initialized if required. */ WORKERFUNC funcWorker; SELECTQUERY aQueries[MAXIMUM_SELECT_OBJECTS]; DWORD nQueriesCount; SELECTSTATE EState; DWORD nError; LPWORKER lpWorker; } SELECTDATA; typedef SELECTDATA *LPSELECTDATA; /* Get error status if associated condition is false */ static BOOL check_error(LPSELECTDATA lpSelectData, BOOL bFailed) { if (bFailed && lpSelectData->nError == 0) { lpSelectData->EState = SELECT_STATE_ERROR; lpSelectData->nError = GetLastError(); } return bFailed; } /* Create data associated with a select operation */ LPSELECTDATA select_data_new (LPSELECTDATA lpSelectData, SELECTTYPE EType) { /* Allocate the data structure */ LPSELECTDATA res; DWORD i; res = (LPSELECTDATA)caml_stat_alloc(sizeof(SELECTDATA)); /* Init common data */ list_init((LPLIST)res); list_next_set((LPLIST)res, (LPLIST)lpSelectData); res->EType = EType; res->nResultsCount = 0; /* Data following are dedicated to APC like call, they will be initialized if required. For now they are set to invalid values. */ res->funcWorker = NULL; res->nQueriesCount = 0; res->EState = SELECT_STATE_NONE; res->nError = 0; res->lpWorker = NULL; return res; } /* Free select data */ void select_data_free (LPSELECTDATA lpSelectData) { DWORD i; DEBUG_PRINT("Freeing data of %x", lpSelectData); /* Free APC related data, if they exists */ if (lpSelectData->lpWorker != NULL) { worker_job_finish(lpSelectData->lpWorker); lpSelectData->lpWorker = NULL; }; /* Make sure results/queries cannot be accessed */ lpSelectData->nResultsCount = 0; lpSelectData->nQueriesCount = 0; caml_stat_free(lpSelectData); } /* Add a result to select data, return zero if something goes wrong. */ DWORD select_data_result_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, int lpOrigIdx) { DWORD res; DWORD i; res = 0; if (lpSelectData->nResultsCount < MAXIMUM_SELECT_OBJECTS * 3) { i = lpSelectData->nResultsCount; lpSelectData->aResults[i].EMode = EMode; lpSelectData->aResults[i].lpOrigIdx = lpOrigIdx; lpSelectData->nResultsCount++; res = 1; } return res; } /* Add a query to select data, return zero if something goes wrong */ DWORD select_data_query_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDLE hFileDescr, int lpOrigIdx, unsigned int uFlagsFd) { DWORD res; DWORD i; res = 0; if (lpSelectData->nQueriesCount < MAXIMUM_SELECT_OBJECTS) { i = lpSelectData->nQueriesCount; lpSelectData->aQueries[i].EMode = EMode; lpSelectData->aQueries[i].hFileDescr = hFileDescr; lpSelectData->aQueries[i].lpOrigIdx = lpOrigIdx; lpSelectData->aQueries[i].uFlagsFd = uFlagsFd; lpSelectData->nQueriesCount++; res = 1; } return res; } /* Search for a job that has available query slots and that match provided type. * If none is found, create a new one. Return the corresponding SELECTDATA, and * update provided SELECTDATA head, if required. */ LPSELECTDATA select_data_job_search (LPSELECTDATA *lppSelectData, SELECTTYPE EType) { LPSELECTDATA res; res = NULL; /* Search for job */ DEBUG_PRINT("Searching an available job for type %d", EType); res = *lppSelectData; while ( res != NULL && !( res->EType == EType && res->nQueriesCount < MAXIMUM_SELECT_OBJECTS ) ) { res = LIST_NEXT(LPSELECTDATA, res); } /* No matching job found, create one */ if (res == NULL) { DEBUG_PRINT("No job for type %d found, create one", EType); res = select_data_new(*lppSelectData, EType); *lppSelectData = res; } return res; } /***********************/ /* Console */ /***********************/ void read_console_poll(HANDLE hStop, void *_data) { HANDLE events[2]; INPUT_RECORD record; DWORD waitRes; DWORD n; LPSELECTDATA lpSelectData; LPSELECTQUERY lpQuery; DEBUG_PRINT("Waiting for data on console"); record; waitRes = 0; n = 0; lpSelectData = (LPSELECTDATA)_data; lpQuery = &(lpSelectData->aQueries[0]); events[0] = hStop; events[1] = lpQuery->hFileDescr; while (lpSelectData->EState == SELECT_STATE_NONE) { waitRes = WaitForMultipleObjects(2, events, FALSE, INFINITE); if (waitRes == WAIT_OBJECT_0 || check_error(lpSelectData, waitRes == WAIT_FAILED)) { /* stop worker event or error */ break; } /* console event */ if (check_error(lpSelectData, PeekConsoleInput(lpQuery->hFileDescr, &record, 1, &n) == 0)) { break; } /* check for ASCII keypress only */ if (record.EventType == KEY_EVENT && record.Event.KeyEvent.bKeyDown && record.Event.KeyEvent.uChar.AsciiChar != 0) { select_data_result_add(lpSelectData, lpQuery->EMode, lpQuery->lpOrigIdx); lpSelectData->EState = SELECT_STATE_SIGNALED; break; } else { /* discard everything else and try again */ if (check_error(lpSelectData, ReadConsoleInput(lpQuery->hFileDescr, &record, 1, &n) == 0)) { break; } } }; } /* Add a function to monitor console input */ LPSELECTDATA read_console_poll_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDLE hFileDescr, int lpOrigIdx, unsigned int uFlagsFd) { LPSELECTDATA res; res = select_data_new(lpSelectData, SELECT_TYPE_CONSOLE_READ); res->funcWorker = read_console_poll; select_data_query_add(res, SELECT_MODE_READ, hFileDescr, lpOrigIdx, uFlagsFd); return res; } /***********************/ /* Pipe */ /***********************/ /* Monitor a pipe for input */ void read_pipe_poll (HANDLE hStop, void *_data) { DWORD res; DWORD event; DWORD n; LPSELECTQUERY iterQuery; LPSELECTDATA lpSelectData; DWORD i; DWORD wait; /* Poll pipe */ event = 0; n = 0; lpSelectData = (LPSELECTDATA)_data; wait = 1; DEBUG_PRINT("Checking data pipe"); while (lpSelectData->EState == SELECT_STATE_NONE) { for (i = 0; i < lpSelectData->nQueriesCount; i++) { iterQuery = &(lpSelectData->aQueries[i]); res = PeekNamedPipe( iterQuery->hFileDescr, NULL, 0, NULL, &n, NULL); if (check_error(lpSelectData, (res == 0) && (GetLastError() != ERROR_BROKEN_PIPE))) { break; }; if ((n > 0) || (res == 0)) { lpSelectData->EState = SELECT_STATE_SIGNALED; select_data_result_add(lpSelectData, iterQuery->EMode, iterQuery->lpOrigIdx); }; }; /* Alas, nothing except polling seems to work for pipes. Check the state & stop_worker_event every 10 ms */ if (lpSelectData->EState == SELECT_STATE_NONE) { event = WaitForSingleObject(hStop, wait); /* Fast start: begin to wait 1, 2, 4, 8 and then 10 ms. * If we are working with the output of a program there is * a chance that one of the 4 first calls succeed. */ wait = 2 * wait; if (wait > 10) { wait = 10; }; if (event == WAIT_OBJECT_0 || check_error(lpSelectData, event == WAIT_FAILED)) { break; } } } DEBUG_PRINT("Finish checking data on pipe"); } /* Add a function to monitor pipe input */ LPSELECTDATA read_pipe_poll_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDLE hFileDescr, int lpOrigIdx, unsigned int uFlagsFd) { LPSELECTDATA res; LPSELECTDATA hd; hd = lpSelectData; /* Polling pipe is a non blocking operation by default. This means that each worker can handle many pipe. We begin to try to find a worker that is polling pipe, but for which there is under the limit of pipe per worker. */ DEBUG_PRINT("Searching an available worker handling pipe"); res = select_data_job_search(&hd, SELECT_TYPE_PIPE_READ); /* Add a new pipe to poll */ res->funcWorker = read_pipe_poll; select_data_query_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); return hd; } /***********************/ /* Socket */ /***********************/ /* Monitor socket */ void socket_poll (HANDLE hStop, void *_data) { LPSELECTDATA lpSelectData; LPSELECTQUERY iterQuery; HANDLE aEvents[MAXIMUM_SELECT_OBJECTS]; DWORD nEvents; long maskEvents; DWORD i; u_long iMode; SELECTMODE mode; WSANETWORKEVENTS events; lpSelectData = (LPSELECTDATA)_data; DEBUG_PRINT("Worker has %d queries to service", lpSelectData->nQueriesCount); for (nEvents = 0; nEvents < lpSelectData->nQueriesCount; nEvents++) { iterQuery = &(lpSelectData->aQueries[nEvents]); aEvents[nEvents] = CreateEvent(NULL, TRUE, FALSE, NULL); maskEvents = 0; mode = iterQuery->EMode; if ((mode & SELECT_MODE_READ) != 0) { DEBUG_PRINT("Polling read for %d", iterQuery->hFileDescr); maskEvents |= FD_READ | FD_ACCEPT | FD_CLOSE; } if ((mode & SELECT_MODE_WRITE) != 0) { DEBUG_PRINT("Polling write for %d", iterQuery->hFileDescr); maskEvents |= FD_WRITE | FD_CONNECT | FD_CLOSE; } if ((mode & SELECT_MODE_EXCEPT) != 0) { DEBUG_PRINT("Polling exceptions for %d", iterQuery->hFileDescr); maskEvents |= FD_OOB; } check_error(lpSelectData, WSAEventSelect( (SOCKET)(iterQuery->hFileDescr), aEvents[nEvents], maskEvents) == SOCKET_ERROR); } /* Add stop event */ aEvents[nEvents] = hStop; nEvents++; if (lpSelectData->nError == 0) { check_error(lpSelectData, WaitForMultipleObjects( nEvents, aEvents, FALSE, INFINITE) == WAIT_FAILED); }; if (lpSelectData->nError == 0) { for (i = 0; i < lpSelectData->nQueriesCount; i++) { iterQuery = &(lpSelectData->aQueries[i]); if (WaitForSingleObject(aEvents[i], 0) == WAIT_OBJECT_0) { DEBUG_PRINT("Socket %d has pending events", (i - 1)); if (iterQuery != NULL) { /* Find out what kind of events were raised */ if (WSAEnumNetworkEvents((SOCKET)(iterQuery->hFileDescr), aEvents[i], &events) == 0) { if ((iterQuery->EMode & SELECT_MODE_READ) != 0 && (events.lNetworkEvents & (FD_READ | FD_ACCEPT | FD_CLOSE)) != 0) { select_data_result_add(lpSelectData, SELECT_MODE_READ, iterQuery->lpOrigIdx); } if ((iterQuery->EMode & SELECT_MODE_WRITE) != 0 && (events.lNetworkEvents & (FD_WRITE | FD_CONNECT | FD_CLOSE)) != 0) { select_data_result_add(lpSelectData, SELECT_MODE_WRITE, iterQuery->lpOrigIdx); } if ((iterQuery->EMode & SELECT_MODE_EXCEPT) != 0 && (events.lNetworkEvents & FD_OOB) != 0) { select_data_result_add(lpSelectData, SELECT_MODE_EXCEPT, iterQuery->lpOrigIdx); } } } } /* WSAEventSelect() automatically sets socket to nonblocking mode. Restore the blocking one. */ if (iterQuery->uFlagsFd & FLAGS_FD_IS_BLOCKING) { DEBUG_PRINT("Restore a blocking socket"); iMode = 0; check_error(lpSelectData, WSAEventSelect((SOCKET)(iterQuery->hFileDescr), aEvents[i], 0) != 0 || ioctlsocket((SOCKET)(iterQuery->hFileDescr), FIONBIO, &iMode) != 0); } else { check_error(lpSelectData, WSAEventSelect((SOCKET)(iterQuery->hFileDescr), aEvents[i], 0) != 0); }; CloseHandle(aEvents[i]); aEvents[i] = INVALID_HANDLE_VALUE; } } } /* Add a function to monitor socket */ LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDLE hFileDescr, int lpOrigIdx, unsigned int uFlagsFd) { LPSELECTDATA res; LPSELECTDATA candidate; DWORD i; LPSELECTQUERY aQueries; res = lpSelectData; candidate = NULL; aQueries = NULL; /* Polling socket can be done mulitple handle at the same time. You just need one worker to use it. Try to find if there is already a worker handling this kind of request. Only one event can be associated with a given socket which means that if a socket is in more than one of the fd_sets then we have to find that particular query and update EMode with the additional flag. */ DEBUG_PRINT("Scanning list of worker to find one that already handle socket"); /* Search for job */ DEBUG_PRINT("Searching for an available job for type %d for descriptor %d", SELECT_TYPE_SOCKET, hFileDescr); while (res != NULL) { if (res->EType == SELECT_TYPE_SOCKET) { i = res->nQueriesCount - 1; aQueries = res->aQueries; while (i >= 0 && aQueries[i].hFileDescr != hFileDescr) { i--; } /* If we didn't find the socket but this worker has available slots, store it */ if (i < 0) { if ( res->nQueriesCount < MAXIMUM_SELECT_OBJECTS) { candidate = res; } res = LIST_NEXT(LPSELECTDATA, res); } else { /* Previous socket query located -- we're finished */ aQueries = &aQueries[i]; break; } } else { res = LIST_NEXT(LPSELECTDATA, res); } } if (res == NULL) { res = candidate; /* No matching job found, create one */ if (res == NULL) { DEBUG_PRINT("No job for type %d found, create one", SELECT_TYPE_SOCKET); res = select_data_new(lpSelectData, SELECT_TYPE_SOCKET); res->funcWorker = socket_poll; res->nQueriesCount = 1; aQueries = &res->aQueries[0]; } else { aQueries = &(res->aQueries[res->nQueriesCount++]); } aQueries->EMode = EMode; aQueries->hFileDescr = hFileDescr; aQueries->lpOrigIdx = lpOrigIdx; aQueries->uFlagsFd = uFlagsFd; DEBUG_PRINT("Socket %x added", hFileDescr); } else { aQueries->EMode |= EMode; DEBUG_PRINT("Socket %x updated to %d", hFileDescr, aQueries->EMode); } return res; } /***********************/ /* Static */ /***********************/ /* Add a static result */ LPSELECTDATA static_poll_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDLE hFileDescr, int lpOrigIdx, unsigned int uFlagsFd) { LPSELECTDATA res; LPSELECTDATA hd; /* Look for an already initialized static element */ hd = lpSelectData; res = select_data_job_search(&hd, SELECT_TYPE_STATIC); /* Add a new query/result */ select_data_query_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); select_data_result_add(res, EMode, lpOrigIdx); return hd; } /********************************/ /* Generic select data handling */ /********************************/ /* Guess handle type */ static SELECTHANDLETYPE get_handle_type(value fd) { DWORD mode; SELECTHANDLETYPE res; CAMLparam1(fd); mode = 0; res = SELECT_HANDLE_NONE; if (Descr_kind_val(fd) == KIND_SOCKET) { res = SELECT_HANDLE_SOCKET; } else { switch(GetFileType(Handle_val(fd))) { case FILE_TYPE_DISK: res = SELECT_HANDLE_DISK; break; case FILE_TYPE_CHAR: /* character file or a console */ if (GetConsoleMode(Handle_val(fd), &mode) != 0) { res = SELECT_HANDLE_CONSOLE; } else { res = SELECT_HANDLE_NONE; }; break; case FILE_TYPE_PIPE: /* a named or an anonymous pipe (socket already handled) */ res = SELECT_HANDLE_PIPE; break; }; }; CAMLreturnT(SELECTHANDLETYPE, res); } /* Choose what to do with given data */ LPSELECTDATA select_data_dispatch (LPSELECTDATA lpSelectData, SELECTMODE EMode, value fd, int lpOrigIdx) { LPSELECTDATA res; HANDLE hFileDescr; struct sockaddr sa; int sa_len; BOOL alreadyAdded; unsigned int uFlagsFd; CAMLparam1(fd); res = lpSelectData; hFileDescr = Handle_val(fd); sa_len = sizeof(sa); alreadyAdded = FALSE; uFlagsFd = Flags_fd_val(fd); DEBUG_PRINT("Begin dispatching handle %x", hFileDescr); DEBUG_PRINT("Waiting for %d on handle %x", EMode, hFileDescr); /* There is only 2 way to have except mode: transmission of OOB data through a socket TCP/IP and through a strange interaction with a TTY. With windows, we only consider the TCP/IP except condition */ switch(get_handle_type(fd)) { case SELECT_HANDLE_DISK: DEBUG_PRINT("Handle %x is a disk handle", hFileDescr); /* Disk is always ready in read/write operation */ if (EMode == SELECT_MODE_READ || EMode == SELECT_MODE_WRITE) { res = static_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); }; break; case SELECT_HANDLE_CONSOLE: DEBUG_PRINT("Handle %x is a console handle", hFileDescr); /* Console is always ready in write operation, need to check for read. */ if (EMode == SELECT_MODE_READ) { res = read_console_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); } else if (EMode == SELECT_MODE_WRITE) { res = static_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); }; break; case SELECT_HANDLE_PIPE: DEBUG_PRINT("Handle %x is a pipe handle", hFileDescr); /* Console is always ready in write operation, need to check for read. */ if (EMode == SELECT_MODE_READ) { DEBUG_PRINT("Need to check availability of data on pipe"); res = read_pipe_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); } else if (EMode == SELECT_MODE_WRITE) { DEBUG_PRINT("No need to check availability of data on pipe, write operation always possible"); res = static_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); }; break; case SELECT_HANDLE_SOCKET: DEBUG_PRINT("Handle %x is a socket handle", hFileDescr); if (getsockname((SOCKET)hFileDescr, &sa, &sa_len) == SOCKET_ERROR) { if (WSAGetLastError() == WSAEINVAL) { /* Socket is not bound */ DEBUG_PRINT("Socket is not connected"); if (EMode == SELECT_MODE_WRITE || EMode == SELECT_MODE_READ) { res = static_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); alreadyAdded = TRUE; } } } if (!alreadyAdded) { res = socket_poll_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); } break; default: DEBUG_PRINT("Handle %x is unknown", hFileDescr); win32_maperr(ERROR_INVALID_HANDLE); uerror("select", Nothing); break; }; DEBUG_PRINT("Finish dispatching handle %x", hFileDescr); CAMLreturnT(LPSELECTDATA, res); } static DWORD caml_list_length (value lst) { DWORD res; CAMLparam1 (lst); CAMLlocal1 (l); for (res = 0, l = lst; l != Val_int(0); l = Field(l, 1), res++) { } CAMLreturnT(DWORD, res); } static value find_handle(LPSELECTRESULT iterResult, value readfds, value writefds, value exceptfds) { CAMLparam3(readfds, writefds, exceptfds); CAMLlocal2(result, list); int i; switch( iterResult->EMode ) { case SELECT_MODE_READ: list = readfds; break; case SELECT_MODE_WRITE: list = writefds; break; case SELECT_MODE_EXCEPT: list = exceptfds; break; }; for(i=0; list != Val_unit && i < iterResult->lpOrigIdx; ++i ) { list = Field(list, 1); } if (list == Val_unit) failwith ("select.c: original file handle not found"); result = Field(list, 0); CAMLreturn( result ); } #define MAX(a, b) ((a) > (b) ? (a) : (b)) /* Convert fdlist to an fd_set if all the handles in fdlist are sockets and return 0. * Returns 1 if a non-socket value is encountered. */ static int fdlist_to_fdset(value fdlist, fd_set *fdset) { value l, c; FD_ZERO(fdset); for (l = fdlist; l != Val_int(0); l = Field(l, 1)) { c = Field(l, 0); if (Descr_kind_val(c) == KIND_SOCKET) { FD_SET(Socket_val(c), fdset); } else { DEBUG_PRINT("Non socket value encountered"); return 0; } } return 1; } static value fdset_to_fdlist(value fdlist, fd_set *fdset) { value res = Val_int(0); Begin_roots2(fdlist, res) for (/*nothing*/; fdlist != Val_int(0); fdlist = Field(fdlist, 1)) { value s = Field(fdlist, 0); if (FD_ISSET(Socket_val(s), fdset)) { value newres = alloc_small(2, 0); Field(newres, 0) = s; Field(newres, 1) = res; res = newres; } } End_roots(); return res; } CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value timeout) { /* Event associated to handle */ DWORD nEventsCount; DWORD nEventsMax; HANDLE *lpEventsDone; /* Data for all handles */ LPSELECTDATA lpSelectData; LPSELECTDATA iterSelectData; /* Iterator for results */ LPSELECTRESULT iterResult; /* Iterator */ DWORD i; /* Error status */ DWORD err; /* Time to wait */ DWORD milliseconds; /* Is there static select data */ BOOL hasStaticData = FALSE; /* Wait return */ DWORD waitRet; /* Set of handle */ SELECTHANDLESET hds; DWORD hdsMax; LPHANDLE hdsData; /* Length of each list */ DWORD readfds_len; DWORD writefds_len; DWORD exceptfds_len; CAMLparam4 (readfds, writefds, exceptfds, timeout); CAMLlocal5 (read_list, write_list, except_list, res, l); CAMLlocal1 (fd); fd_set read, write, except; double tm; struct timeval tv; struct timeval * tvp; DEBUG_PRINT("in select"); err = 0; tm = Double_val(timeout); if (readfds == Val_int(0) && writefds == Val_int(0) && exceptfds == Val_int(0)) { DEBUG_PRINT("nothing to do"); if ( tm > 0.0 ) { enter_blocking_section(); Sleep( (int)(tm * 1000)); leave_blocking_section(); } read_list = write_list = except_list = Val_int(0); } else { if (fdlist_to_fdset(readfds, &read) && fdlist_to_fdset(writefds, &write) && fdlist_to_fdset(exceptfds, &except)) { DEBUG_PRINT("only sockets to select on, using classic select"); if (tm < 0.0) { tvp = (struct timeval *) NULL; } else { tv.tv_sec = (int) tm; tv.tv_usec = (int) (1e6 * (tm - (int) tm)); tvp = &tv; } enter_blocking_section(); if (select(FD_SETSIZE, &read, &write, &except, tvp) == -1) { err = WSAGetLastError(); DEBUG_PRINT("Error %ld occurred", err); } leave_blocking_section(); if (err) { DEBUG_PRINT("Error %ld occurred", err); win32_maperr(err); uerror("select", Nothing); } read_list = fdset_to_fdlist(readfds, &read); write_list = fdset_to_fdlist(writefds, &write); except_list = fdset_to_fdlist(exceptfds, &except); } else { nEventsCount = 0; nEventsMax = 0; lpEventsDone = NULL; lpSelectData = NULL; iterSelectData = NULL; iterResult = NULL; hasStaticData = 0; waitRet = 0; readfds_len = caml_list_length(readfds); writefds_len = caml_list_length(writefds); exceptfds_len = caml_list_length(exceptfds); hdsMax = MAX(readfds_len, MAX(writefds_len, exceptfds_len)); hdsData = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * hdsMax); if (tm >= 0.0) { milliseconds = 1000 * tm; DEBUG_PRINT("Will wait %d ms", milliseconds); } else { milliseconds = INFINITE; } /* Create list of select data, based on the different list of fd to watch */ DEBUG_PRINT("Dispatch read fd"); handle_set_init(&hds, hdsData, hdsMax); i=0; for (l = readfds; l != Val_int(0); l = Field(l, 1)) { fd = Field(l, 0); if (!handle_set_mem(&hds, Handle_val(fd))) { handle_set_add(&hds, Handle_val(fd)); lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_READ, fd, i++); } else { DEBUG_PRINT("Discarding handle %x which is already monitor for read", Handle_val(fd)); } } handle_set_reset(&hds); DEBUG_PRINT("Dispatch write fd"); handle_set_init(&hds, hdsData, hdsMax); i=0; for (l = writefds; l != Val_int(0); l = Field(l, 1)) { fd = Field(l, 0); if (!handle_set_mem(&hds, Handle_val(fd))) { handle_set_add(&hds, Handle_val(fd)); lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_WRITE, fd, i++); } else { DEBUG_PRINT("Discarding handle %x which is already monitor for write", Handle_val(fd)); } } handle_set_reset(&hds); DEBUG_PRINT("Dispatch exceptional fd"); handle_set_init(&hds, hdsData, hdsMax); i=0; for (l = exceptfds; l != Val_int(0); l = Field(l, 1)) { fd = Field(l, 0); if (!handle_set_mem(&hds, Handle_val(fd))) { handle_set_add(&hds, Handle_val(fd)); lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_EXCEPT, fd, i++); } else { DEBUG_PRINT("Discarding handle %x which is already monitor for exceptional", Handle_val(fd)); } } handle_set_reset(&hds); /* Building the list of handle to wait for */ DEBUG_PRINT("Building events done array"); nEventsMax = list_length((LPLIST)lpSelectData); nEventsCount = 0; lpEventsDone = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * nEventsMax); iterSelectData = lpSelectData; while (iterSelectData != NULL) { /* Check if it is static data. If this is the case, launch everything * but don't wait for events. It helps to test if there are events on * any other fd (which are not static), knowing that there is at least * one result (the static data). */ if (iterSelectData->EType == SELECT_TYPE_STATIC) { hasStaticData = TRUE; }; /* Execute APC */ if (iterSelectData->funcWorker != NULL) { iterSelectData->lpWorker = worker_job_submit( iterSelectData->funcWorker, (void *)iterSelectData); DEBUG_PRINT("Job submitted to worker %x", iterSelectData->lpWorker); lpEventsDone[nEventsCount] = worker_job_event_done(iterSelectData->lpWorker); nEventsCount++; }; iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); }; DEBUG_PRINT("Need to watch %d workers", nEventsCount); /* Processing select itself */ enter_blocking_section(); /* There are worker started, waiting to be monitored */ if (nEventsCount > 0) { /* Waiting for event */ if (err == 0 && !hasStaticData) { DEBUG_PRINT("Waiting for one select worker to be done"); switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, FALSE, milliseconds)) { case WAIT_FAILED: err = GetLastError(); break; case WAIT_TIMEOUT: DEBUG_PRINT("Select timeout"); break; default: DEBUG_PRINT("One worker is done"); break; }; } /* Ordering stop to every worker */ DEBUG_PRINT("Sending stop signal to every select workers"); iterSelectData = lpSelectData; while (iterSelectData != NULL) { if (iterSelectData->lpWorker != NULL) { worker_job_stop(iterSelectData->lpWorker); }; iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); }; DEBUG_PRINT("Waiting for every select worker to be done"); switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, TRUE, INFINITE)) { case WAIT_FAILED: err = GetLastError(); break; default: DEBUG_PRINT("Every worker is done"); break; } } /* Nothing to monitor but some time to wait. */ else if (!hasStaticData) { Sleep(milliseconds); } leave_blocking_section(); DEBUG_PRINT("Error status: %d (0 is ok)", err); /* Build results */ if (err == 0) { DEBUG_PRINT("Building result"); read_list = Val_unit; write_list = Val_unit; except_list = Val_unit; iterSelectData = lpSelectData; while (iterSelectData != NULL) { for (i = 0; i < iterSelectData->nResultsCount; i++) { iterResult = &(iterSelectData->aResults[i]); l = alloc_small(2, 0); Store_field(l, 0, find_handle(iterResult, readfds, writefds, exceptfds)); switch (iterResult->EMode) { case SELECT_MODE_READ: Store_field(l, 1, read_list); read_list = l; break; case SELECT_MODE_WRITE: Store_field(l, 1, write_list); write_list = l; break; case SELECT_MODE_EXCEPT: Store_field(l, 1, except_list); except_list = l; break; } } /* We try to only process the first error, bypass other errors */ if (err == 0 && iterSelectData->EState == SELECT_STATE_ERROR) { err = iterSelectData->nError; } iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); } } /* Free resources */ DEBUG_PRINT("Free selectdata resources"); iterSelectData = lpSelectData; while (iterSelectData != NULL) { lpSelectData = iterSelectData; iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); select_data_free(lpSelectData); } lpSelectData = NULL; /* Free allocated events/handle set array */ DEBUG_PRINT("Free local allocated resources"); caml_stat_free(lpEventsDone); caml_stat_free(hdsData); DEBUG_PRINT("Raise error if required"); if (err != 0) { win32_maperr(err); uerror("select", Nothing); } } } DEBUG_PRINT("Build final result"); res = alloc_small(3, 0); Store_field(res, 0, read_list); Store_field(res, 1, write_list); Store_field(res, 2, except_list); DEBUG_PRINT("out select"); CAMLreturn(res); } mingw-ocaml/ocaml/otherlibs/win32unix/getpid.c0000644000175000017500000000202712124403241020740 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" extern value val_process_id; CAMLprim value unix_getpid(value unit) { return val_process_id; } mingw-ocaml/ocaml/otherlibs/win32unix/winlist.c0000644000175000017500000000336412124403241021162 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Contributed by Sylvain Le Gall for Lexifi */ /* */ /* Copyright 2008 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Basic list function in C. */ #include "winlist.h" #include void list_init (LPLIST lst) { lst->lpNext = NULL; } void list_cleanup (LPLIST lst) { lst->lpNext = NULL; } void list_next_set (LPLIST lst, LPLIST next) { lst->lpNext = next; } LPLIST list_next (LPLIST lst) { return lst->lpNext; } int list_length (LPLIST lst) { int length = 0; LPLIST iter = lst; while (iter != NULL) { length++; iter = list_next(iter); }; return length; } LPLIST list_concat (LPLIST lsta, LPLIST lstb) { LPLIST res = NULL; LPLIST iter = NULL; LPLIST iterPrev = NULL; if (lsta == NULL) { res = lstb; } else if (lstb == NULL) { res = lsta; } else { res = lsta; iter = lsta; while (iter != NULL) { iterPrev = iter; iter = list_next(iter); }; iterPrev->lpNext = lstb; }; return res; } mingw-ocaml/ocaml/otherlibs/win32unix/windir.c0000644000175000017500000000431712124403241020764 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Pascal Cuoq and Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include "unixsupport.h" CAMLprim value win_findfirst(name) value name; { HANDLE h; value v; WIN32_FIND_DATA fileinfo; value valname = Val_unit; value valh = Val_unit; Begin_roots2 (valname,valh); h = FindFirstFile(String_val(name),&fileinfo); if (h == INVALID_HANDLE_VALUE) { DWORD err = GetLastError(); if (err == ERROR_NO_MORE_FILES) raise_end_of_file(); else { win32_maperr(err); uerror("opendir", Nothing); } } valname = copy_string(fileinfo.cFileName); valh = win_alloc_handle(h); v = alloc_small(2, 0); Field(v,0) = valname; Field(v,1) = valh; End_roots(); return v; } CAMLprim value win_findnext(valh) value valh; { WIN32_FIND_DATA fileinfo; BOOL retcode; retcode = FindNextFile(Handle_val(valh), &fileinfo); if (!retcode) { DWORD err = GetLastError(); if (err == ERROR_NO_MORE_FILES) raise_end_of_file(); else { win32_maperr(err); uerror("readdir", Nothing); } } return copy_string(fileinfo.cFileName); } CAMLprim value win_findclose(valh) value valh; { if (! FindClose(Handle_val(valh))) { win32_maperr(GetLastError()); uerror("closedir", Nothing); } return Val_unit; } mingw-ocaml/ocaml/otherlibs/win32unix/sleep.c0000644000175000017500000000214012124403241020570 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" CAMLprim value unix_sleep(t) value t; { enter_blocking_section(); Sleep(Int_val(t) * 1000); leave_blocking_section(); return Val_unit; } mingw-ocaml/ocaml/otherlibs/win32unix/windbug.h0000644000175000017500000000266112124403241021134 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Contributed by Sylvain Le Gall for Lexifi */ /* */ /* Copyright 2008 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifdef DEBUG #include #include /* According to MSDN, MSVC supports the gcc ## operator (to deal with empty argument lists) */ #define DEBUG_PRINT(fmt, ...) \ do \ { \ if (debug_test()) \ { \ fprintf(stderr, "DBUG (pid:%ld, tid: %ld): ", GetCurrentProcessId(), GetCurrentThreadId()); \ fprintf(stderr, fmt, ##__VA_ARGS__); \ fprintf(stderr, "\n"); \ fflush(stderr); \ }; \ } while(0) /* Test if we are in dbug mode */ int debug_test (void); #else #define DEBUG_PRINT(fmt, ...) #endif mingw-ocaml/ocaml/otherlibs/win32unix/gettimeofday.c0000644000175000017500000000270112124403241022144 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" static time_t initial_time = 0; /* 0 means uninitialized */ static DWORD initial_tickcount; CAMLprim value unix_gettimeofday(value unit) { DWORD tickcount = GetTickCount(); if (initial_time == 0 || tickcount < initial_tickcount) { initial_tickcount = tickcount; initial_time = time(NULL); return copy_double((double) initial_time); } else { return copy_double((double) initial_time + (double) (tickcount - initial_tickcount) * 1e-3); } } mingw-ocaml/ocaml/otherlibs/win32unix/read.c0000644000175000017500000000362312124403241020402 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" CAMLprim value unix_read(value fd, value buf, value ofs, value vlen) { intnat len; DWORD numbytes, numread; char iobuf[UNIX_BUFFER_SIZE]; DWORD err = 0; Begin_root (buf); len = Long_val(vlen); numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; if (Descr_kind_val(fd) == KIND_SOCKET) { int ret; SOCKET s = Socket_val(fd); enter_blocking_section(); ret = recv(s, iobuf, numbytes, 0); if (ret == SOCKET_ERROR) err = WSAGetLastError(); leave_blocking_section(); numread = ret; } else { HANDLE h = Handle_val(fd); enter_blocking_section(); if (! ReadFile(h, iobuf, numbytes, &numread, NULL)) err = GetLastError(); leave_blocking_section(); } if (err) { win32_maperr(err); uerror("read", Nothing); } memmove (&Byte(buf, Long_val(ofs)), iobuf, numread); End_roots(); return Val_int(numread); } mingw-ocaml/ocaml/otherlibs/win32unix/pipe.c0000644000175000017500000000321712124403241020423 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" #include /* PR#4749: pick a size that matches that of I/O buffers */ #define SIZEBUF 4096 CAMLprim value unix_pipe(value unit) { SECURITY_ATTRIBUTES attr; HANDLE readh, writeh; value readfd = Val_unit, writefd = Val_unit, res; attr.nLength = sizeof(attr); attr.lpSecurityDescriptor = NULL; attr.bInheritHandle = TRUE; if (! CreatePipe(&readh, &writeh, &attr, SIZEBUF)) { win32_maperr(GetLastError()); uerror("pipe", Nothing); } Begin_roots2(readfd, writefd) readfd = win_alloc_handle(readh); writefd = win_alloc_handle(writeh); res = alloc_small(2, 0); Field(res, 0) = readfd; Field(res, 1) = writefd; End_roots(); return res; } mingw-ocaml/ocaml/otherlibs/win32unix/unix.ml0000644000175000017500000007243412124403241020646 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Initialization *) external startup: unit -> unit = "win_startup" external cleanup: unit -> unit = "win_cleanup" let _ = startup(); at_exit cleanup (* Errors *) type error = (* Errors defined in the POSIX standard *) E2BIG (* Argument list too long *) | EACCES (* Permission denied *) | EAGAIN (* Resource temporarily unavailable; try again *) | EBADF (* Bad file descriptor *) | EBUSY (* Resource unavailable *) | ECHILD (* No child process *) | EDEADLK (* Resource deadlock would occur *) | EDOM (* Domain error for math functions, etc. *) | EEXIST (* File exists *) | EFAULT (* Bad address *) | EFBIG (* File too large *) | EINTR (* Function interrupted by signal *) | EINVAL (* Invalid argument *) | EIO (* Hardware I/O error *) | EISDIR (* Is a directory *) | EMFILE (* Too many open files by the process *) | EMLINK (* Too many links *) | ENAMETOOLONG (* Filename too long *) | ENFILE (* Too many open files in the system *) | ENODEV (* No such device *) | ENOENT (* No such file or directory *) | ENOEXEC (* Not an executable file *) | ENOLCK (* No locks available *) | ENOMEM (* Not enough memory *) | ENOSPC (* No space left on device *) | ENOSYS (* Function not supported *) | ENOTDIR (* Not a directory *) | ENOTEMPTY (* Directory not empty *) | ENOTTY (* Inappropriate I/O control operation *) | ENXIO (* No such device or address *) | EPERM (* Operation not permitted *) | EPIPE (* Broken pipe *) | ERANGE (* Result too large *) | EROFS (* Read-only file system *) | ESPIPE (* Invalid seek e.g. on a pipe *) | ESRCH (* No such process *) | EXDEV (* Invalid link *) (* Additional errors, mostly BSD *) | EWOULDBLOCK (* Operation would block *) | EINPROGRESS (* Operation now in progress *) | EALREADY (* Operation already in progress *) | ENOTSOCK (* Socket operation on non-socket *) | EDESTADDRREQ (* Destination address required *) | EMSGSIZE (* Message too long *) | EPROTOTYPE (* Protocol wrong type for socket *) | ENOPROTOOPT (* Protocol not available *) | EPROTONOSUPPORT (* Protocol not supported *) | ESOCKTNOSUPPORT (* Socket type not supported *) | EOPNOTSUPP (* Operation not supported on socket *) | EPFNOSUPPORT (* Protocol family not supported *) | EAFNOSUPPORT (* Address family not supported by protocol family *) | EADDRINUSE (* Address already in use *) | EADDRNOTAVAIL (* Can't assign requested address *) | ENETDOWN (* Network is down *) | ENETUNREACH (* Network is unreachable *) | ENETRESET (* Network dropped connection on reset *) | ECONNABORTED (* Software caused connection abort *) | ECONNRESET (* Connection reset by peer *) | ENOBUFS (* No buffer space available *) | EISCONN (* Socket is already connected *) | ENOTCONN (* Socket is not connected *) | ESHUTDOWN (* Can't send after socket shutdown *) | ETOOMANYREFS (* Too many references: can't splice *) | ETIMEDOUT (* Connection timed out *) | ECONNREFUSED (* Connection refused *) | EHOSTDOWN (* Host is down *) | EHOSTUNREACH (* No route to host *) | ELOOP (* Too many levels of symbolic links *) | EOVERFLOW (* All other errors are mapped to EUNKNOWNERR *) | EUNKNOWNERR of int (* Unknown error *) exception Unix_error of error * string * string let _ = Callback.register_exception "Unix.Unix_error" (Unix_error(E2BIG, "", "")) external error_message : error -> string = "unix_error_message" let handle_unix_error f arg = try f arg with Unix_error(err, fun_name, arg) -> prerr_string Sys.argv.(0); prerr_string ": \""; prerr_string fun_name; prerr_string "\" failed"; if String.length arg > 0 then begin prerr_string " on \""; prerr_string arg; prerr_string "\"" end; prerr_string ": "; prerr_endline (error_message err); exit 2 external environment : unit -> string array = "unix_environment" external getenv: string -> string = "caml_sys_getenv" external putenv: string -> string -> unit = "unix_putenv" type process_status = WEXITED of int | WSIGNALED of int | WSTOPPED of int type wait_flag = WNOHANG | WUNTRACED type file_descr external execv : string -> string array -> 'a = "unix_execv" external execve : string -> string array -> string array -> 'a = "unix_execve" external execvp : string -> string array -> 'a = "unix_execvp" external execvpe : string -> string array -> string array -> 'a = "unix_execvpe" external waitpid : wait_flag list -> int -> int * process_status = "win_waitpid" external getpid : unit -> int = "unix_getpid" let fork () = invalid_arg "Unix.fork not implemented" let wait () = invalid_arg "Unix.wait not implemented" let getppid () = invalid_arg "Unix.getppid not implemented" let nice prio = invalid_arg "Unix.nice not implemented" (* Basic file input/output *) external filedescr_of_fd : int -> file_descr = "win_handle_fd" let stdin = filedescr_of_fd 0 let stdout = filedescr_of_fd 1 let stderr = filedescr_of_fd 2 type open_flag = O_RDONLY | O_WRONLY | O_RDWR | O_NONBLOCK | O_APPEND | O_CREAT | O_TRUNC | O_EXCL | O_NOCTTY | O_DSYNC | O_SYNC | O_RSYNC | O_SHARE_DELETE type file_perm = int external openfile : string -> open_flag list -> file_perm -> file_descr = "unix_open" external close : file_descr -> unit = "unix_close" external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read" external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write" external unsafe_single_write : file_descr -> string -> int -> int -> int = "unix_single_write" let read fd buf ofs len = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.read" else unsafe_read fd buf ofs len let write fd buf ofs len = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.write" else unsafe_write fd buf ofs len let single_write fd buf ofs len = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.single_write" else unsafe_single_write fd buf ofs len (* Interfacing with the standard input/output library *) external in_channel_of_descr: file_descr -> in_channel = "win_inchannel_of_filedescr" external out_channel_of_descr: file_descr -> out_channel = "win_outchannel_of_filedescr" external descr_of_in_channel : in_channel -> file_descr = "win_filedescr_of_channel" external descr_of_out_channel : out_channel -> file_descr = "win_filedescr_of_channel" (* Seeking and truncating *) type seek_command = SEEK_SET | SEEK_CUR | SEEK_END external lseek : file_descr -> int -> seek_command -> int = "unix_lseek" let truncate name len = invalid_arg "Unix.truncate not implemented" let ftruncate fd len = invalid_arg "Unix.ftruncate not implemented" (* File statistics *) type file_kind = S_REG | S_DIR | S_CHR | S_BLK | S_LNK | S_FIFO | S_SOCK type stats = { st_dev : int; st_ino : int; st_kind : file_kind; st_perm : file_perm; st_nlink : int; st_uid : int; st_gid : int; st_rdev : int; st_size : int; st_atime : float; st_mtime : float; st_ctime : float } external stat : string -> stats = "unix_stat" let lstat = stat external fstat : file_descr -> stats = "unix_fstat" let isatty fd = match (fstat fd).st_kind with S_CHR -> true | _ -> false (* Operations on file names *) external unlink : string -> unit = "unix_unlink" external rename : string -> string -> unit = "unix_rename" external link : string -> string -> unit = "unix_link" (* Operations on large files *) module LargeFile = struct external lseek : file_descr -> int64 -> seek_command -> int64 = "unix_lseek_64" let truncate name len = invalid_arg "Unix.LargeFile.truncate not implemented" let ftruncate name len = invalid_arg "Unix.LargeFile.ftruncate not implemented" type stats = { st_dev : int; st_ino : int; st_kind : file_kind; st_perm : file_perm; st_nlink : int; st_uid : int; st_gid : int; st_rdev : int; st_size : int64; st_atime : float; st_mtime : float; st_ctime : float; } external stat : string -> stats = "unix_stat_64" let lstat = stat external fstat : file_descr -> stats = "unix_fstat_64" end (* File permissions and ownership *) type access_permission = R_OK | W_OK | X_OK | F_OK external chmod : string -> file_perm -> unit = "unix_chmod" let fchmod fd perm = invalid_arg "Unix.fchmod not implemented" let chown file perm = invalid_arg "Unix.chown not implemented" let fchown fd perm = invalid_arg "Unix.fchown not implemented" let umask msk = invalid_arg "Unix.umask not implemented" external access : string -> access_permission list -> unit = "unix_access" (* Operations on file descriptors *) external dup : file_descr -> file_descr = "unix_dup" external dup2 : file_descr -> file_descr -> unit = "unix_dup2" external set_nonblock : file_descr -> unit = "unix_set_nonblock" external clear_nonblock : file_descr -> unit = "unix_clear_nonblock" external set_close_on_exec : file_descr -> unit = "win_set_close_on_exec" external clear_close_on_exec : file_descr -> unit = "win_clear_close_on_exec" (* Directories *) external mkdir : string -> file_perm -> unit = "unix_mkdir" external rmdir : string -> unit = "unix_rmdir" external chdir : string -> unit = "unix_chdir" external getcwd : unit -> string = "unix_getcwd" let chroot _ = invalid_arg "Unix.chroot not implemented" type dir_entry = Dir_empty | Dir_read of string | Dir_toread type dir_handle = { dirname: string; mutable handle: int; mutable entry_read: dir_entry } external findfirst : string -> string * int = "win_findfirst" external findnext : int -> string= "win_findnext" let opendir dirname = try let (first_entry, handle) = findfirst (Filename.concat dirname "*.*") in { dirname = dirname; handle = handle; entry_read = Dir_read first_entry } with End_of_file -> { dirname = dirname; handle = 0; entry_read = Dir_empty } let readdir d = match d.entry_read with Dir_empty -> raise End_of_file | Dir_read name -> d.entry_read <- Dir_toread; name | Dir_toread -> findnext d.handle external win_findclose : int -> unit = "win_findclose" let closedir d = match d.entry_read with Dir_empty -> () | _ -> win_findclose d.handle let rewinddir d = closedir d; try let (first_entry, handle) = findfirst (d.dirname ^ "\\*.*") in d.handle <- handle; d.entry_read <- Dir_read first_entry with End_of_file -> d.handle <- 0; d.entry_read <- Dir_empty (* Pipes *) external pipe : unit -> file_descr * file_descr = "unix_pipe" let mkfifo name perm = invalid_arg "Unix.mkfifo not implemented" (* Symbolic links *) let readlink path = invalid_arg "Unix.readlink not implemented" let symlink path1 path2 = invalid_arg "Unix.symlink not implemented" (* Locking *) type lock_command = F_ULOCK | F_LOCK | F_TLOCK | F_TEST | F_RLOCK | F_TRLOCK external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf" let kill pid signo = invalid_arg "Unix.kill not implemented" type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK let sigprocmask cmd sigs = invalid_arg "Unix.sigprocmask not implemented" let sigpending () = invalid_arg "Unix.sigpending not implemented" let sigsuspend sigs = invalid_arg "Unix.sigsuspend not implemented" let pause () = invalid_arg "Unix.pause not implemented" (* Time functions *) type process_times = { tms_utime : float; tms_stime : float; tms_cutime : float; tms_cstime : float } type tm = { tm_sec : int; tm_min : int; tm_hour : int; tm_mday : int; tm_mon : int; tm_year : int; tm_wday : int; tm_yday : int; tm_isdst : bool } external time : unit -> float = "unix_time" external gettimeofday : unit -> float = "unix_gettimeofday" external gmtime : float -> tm = "unix_gmtime" external localtime : float -> tm = "unix_localtime" external mktime : tm -> float * tm = "unix_mktime" let alarm n = invalid_arg "Unix.alarm not implemented" external sleep : int -> unit = "unix_sleep" external times: unit -> process_times = "unix_times" external utimes : string -> float -> float -> unit = "unix_utimes" type interval_timer = ITIMER_REAL | ITIMER_VIRTUAL | ITIMER_PROF type interval_timer_status = { it_interval: float; it_value: float } let getitimer it = invalid_arg "Unix.getitimer not implemented" let setitimer it tm = invalid_arg "Unix.setitimer not implemented" (* User id, group id *) let getuid () = 1 let geteuid = getuid let setuid id = invalid_arg "Unix.setuid not implemented" let getgid () = 1 let getegid = getgid let setgid id = invalid_arg "Unix.setgid not implemented" let getgroups () = [|1|] let setgroups _ = invalid_arg "Unix.setgroups not implemented" let initgroups _ _ = invalid_arg "Unix.initgroups not implemented" type passwd_entry = { pw_name : string; pw_passwd : string; pw_uid : int; pw_gid : int; pw_gecos : string; pw_dir : string; pw_shell : string } type group_entry = { gr_name : string; gr_passwd : string; gr_gid : int; gr_mem : string array } let getlogin () = try Sys.getenv "USERNAME" with Not_found -> "" let getpwnam x = raise Not_found let getgrnam = getpwnam let getpwuid = getpwnam let getgrgid = getpwnam (* Internet addresses *) type inet_addr = string let is_inet6_addr s = String.length s = 16 external inet_addr_of_string : string -> inet_addr = "unix_inet_addr_of_string" external string_of_inet_addr : inet_addr -> string = "unix_string_of_inet_addr" let inet_addr_any = inet_addr_of_string "0.0.0.0" let inet_addr_loopback = inet_addr_of_string "127.0.0.1" let inet6_addr_any = try inet_addr_of_string "::" with Failure _ -> inet_addr_any let inet6_addr_loopback = try inet_addr_of_string "::1" with Failure _ -> inet_addr_loopback (* Sockets *) type socket_domain = PF_UNIX | PF_INET | PF_INET6 type socket_type = SOCK_STREAM | SOCK_DGRAM | SOCK_RAW | SOCK_SEQPACKET type sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int let domain_of_sockaddr = function ADDR_UNIX _ -> PF_UNIX | ADDR_INET(a, _) -> if is_inet6_addr a then PF_INET6 else PF_INET type shutdown_command = SHUTDOWN_RECEIVE | SHUTDOWN_SEND | SHUTDOWN_ALL type msg_flag = MSG_OOB | MSG_DONTROUTE | MSG_PEEK external socket : socket_domain -> socket_type -> int -> file_descr = "unix_socket" let socketpair dom ty proto = invalid_arg "Unix.socketpair not implemented" external accept : file_descr -> file_descr * sockaddr = "unix_accept" external bind : file_descr -> sockaddr -> unit = "unix_bind" external connect : file_descr -> sockaddr -> unit = "unix_connect" external listen : file_descr -> int -> unit = "unix_listen" external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" external getsockname : file_descr -> sockaddr = "unix_getsockname" external getpeername : file_descr -> sockaddr = "unix_getpeername" external unsafe_recv : file_descr -> string -> int -> int -> msg_flag list -> int = "unix_recv" external unsafe_recvfrom : file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr = "unix_recvfrom" external unsafe_send : file_descr -> string -> int -> int -> msg_flag list -> int = "unix_send" external unsafe_sendto : file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int = "unix_sendto" "unix_sendto_native" let recv fd buf ofs len flags = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.recv" else unsafe_recv fd buf ofs len flags let recvfrom fd buf ofs len flags = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.recvfrom" else unsafe_recvfrom fd buf ofs len flags let send fd buf ofs len flags = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.send" else unsafe_send fd buf ofs len flags let sendto fd buf ofs len flags addr = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.sendto" else unsafe_sendto fd buf ofs len flags addr type socket_bool_option = SO_DEBUG | SO_BROADCAST | SO_REUSEADDR | SO_KEEPALIVE | SO_DONTROUTE | SO_OOBINLINE | SO_ACCEPTCONN | TCP_NODELAY | IPV6_ONLY type socket_int_option = SO_SNDBUF | SO_RCVBUF | SO_ERROR | SO_TYPE | SO_RCVLOWAT | SO_SNDLOWAT type socket_optint_option = SO_LINGER type socket_float_option = SO_RCVTIMEO | SO_SNDTIMEO type socket_error_option = SO_ERROR module SO: sig type ('opt, 'v) t val bool: (socket_bool_option, bool) t val int: (socket_int_option, int) t val optint: (socket_optint_option, int option) t val float: (socket_float_option, float) t val error: (socket_error_option, error option) t val get: ('opt, 'v) t -> file_descr -> 'opt -> 'v val set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit end = struct type ('opt, 'v) t = int let bool = 0 let int = 1 let optint = 2 let float = 3 let error = 4 external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v = "unix_getsockopt" external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit = "unix_setsockopt" end let getsockopt fd opt = SO.get SO.bool fd opt let setsockopt fd opt v = SO.set SO.bool fd opt v let getsockopt_int fd opt = SO.get SO.int fd opt let setsockopt_int fd opt v = SO.set SO.int fd opt v let getsockopt_optint fd opt = SO.get SO.optint fd opt let setsockopt_optint fd opt v = SO.set SO.optint fd opt v let getsockopt_float fd opt = SO.get SO.float fd opt let setsockopt_float fd opt v = SO.set SO.float fd opt v let getsockopt_error fd = SO.get SO.error fd SO_ERROR (* Host and protocol databases *) type host_entry = { h_name : string; h_aliases : string array; h_addrtype : socket_domain; h_addr_list : inet_addr array } type protocol_entry = { p_name : string; p_aliases : string array; p_proto : int } type service_entry = { s_name : string; s_aliases : string array; s_port : int; s_proto : string } external gethostname : unit -> string = "unix_gethostname" external gethostbyname : string -> host_entry = "unix_gethostbyname" external gethostbyaddr : inet_addr -> host_entry = "unix_gethostbyaddr" external getprotobyname : string -> protocol_entry = "unix_getprotobyname" external getprotobynumber : int -> protocol_entry = "unix_getprotobynumber" external getservbyname : string -> string -> service_entry = "unix_getservbyname" external getservbyport : int -> string -> service_entry = "unix_getservbyport" type addr_info = { ai_family : socket_domain; ai_socktype : socket_type; ai_protocol : int; ai_addr : sockaddr; ai_canonname : string } type getaddrinfo_option = AI_FAMILY of socket_domain | AI_SOCKTYPE of socket_type | AI_PROTOCOL of int | AI_NUMERICHOST | AI_CANONNAME | AI_PASSIVE let getaddrinfo node service opts = (* Parse options *) let opt_socktype = ref None and opt_protocol = ref 0 and opt_passive = ref false in List.iter (function AI_SOCKTYPE s -> opt_socktype := Some s | AI_PROTOCOL p -> opt_protocol := p | AI_PASSIVE -> opt_passive := true | _ -> ()) opts; (* Determine socket types and port numbers *) let get_port ty kind = if service = "" then [ty, 0] else try [ty, int_of_string service] with Failure _ -> try [ty, (getservbyname service kind).s_port] with Not_found -> [] in let ports = match !opt_socktype with | None -> get_port SOCK_STREAM "tcp" @ get_port SOCK_DGRAM "udp" | Some SOCK_STREAM -> get_port SOCK_STREAM "tcp" | Some SOCK_DGRAM -> get_port SOCK_DGRAM "udp" | Some ty -> if service = "" then [ty, 0] else [] in (* Determine IP addresses *) let addresses = if node = "" then if List.mem AI_PASSIVE opts then [inet_addr_any, "0.0.0.0"] else [inet_addr_loopback, "127.0.0.1"] else try [inet_addr_of_string node, node] with Failure _ -> try let he = gethostbyname node in List.map (fun a -> (a, he.h_name)) (Array.to_list he.h_addr_list) with Not_found -> [] in (* Cross-product of addresses and ports *) List.flatten (List.map (fun (ty, port) -> List.map (fun (addr, name) -> { ai_family = PF_INET; ai_socktype = ty; ai_protocol = !opt_protocol; ai_addr = ADDR_INET(addr, port); ai_canonname = name }) addresses) ports) type name_info = { ni_hostname : string; ni_service : string } type getnameinfo_option = NI_NOFQDN | NI_NUMERICHOST | NI_NAMEREQD | NI_NUMERICSERV | NI_DGRAM let getnameinfo addr opts = match addr with | ADDR_UNIX f -> { ni_hostname = ""; ni_service = f } (* why not? *) | ADDR_INET(a, p) -> let hostname = try if List.mem NI_NUMERICHOST opts then raise Not_found; (gethostbyaddr a).h_name with Not_found -> if List.mem NI_NAMEREQD opts then raise Not_found; string_of_inet_addr a in let service = try if List.mem NI_NUMERICSERV opts then raise Not_found; let kind = if List.mem NI_DGRAM opts then "udp" else "tcp" in (getservbyport p kind).s_name with Not_found -> string_of_int p in { ni_hostname = hostname; ni_service = service } (* High-level process management (system, popen) *) external win_create_process : string -> string -> string option -> file_descr -> file_descr -> file_descr -> int = "win_create_process" "win_create_process_native" let make_cmdline args = let maybe_quote f = if String.contains f ' ' || String.contains f '\"' then Filename.quote f else f in String.concat " " (List.map maybe_quote (Array.to_list args)) let create_process prog args fd1 fd2 fd3 = win_create_process prog (make_cmdline args) None fd1 fd2 fd3 let create_process_env prog args env fd1 fd2 fd3 = win_create_process prog (make_cmdline args) (Some(String.concat "\000" (Array.to_list env) ^ "\000")) fd1 fd2 fd3 external system: string -> process_status = "win_system" type popen_process = Process of in_channel * out_channel | Process_in of in_channel | Process_out of out_channel | Process_full of in_channel * out_channel * in_channel let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t) let open_proc cmd optenv proc input output error = let shell = try Sys.getenv "COMSPEC" with Not_found -> raise(Unix_error(ENOEXEC, "open_proc", cmd)) in let pid = win_create_process shell (shell ^ " /c " ^ cmd) optenv input output error in Hashtbl.add popen_processes proc pid let open_process_in cmd = let (in_read, in_write) = pipe() in set_close_on_exec in_read; let inchan = in_channel_of_descr in_read in open_proc cmd None (Process_in inchan) stdin in_write stderr; close in_write; inchan let open_process_out cmd = let (out_read, out_write) = pipe() in set_close_on_exec out_write; let outchan = out_channel_of_descr out_write in open_proc cmd None (Process_out outchan) out_read stdout stderr; close out_read; outchan let open_process cmd = let (in_read, in_write) = pipe() in let (out_read, out_write) = pipe() in set_close_on_exec in_read; set_close_on_exec out_write; let inchan = in_channel_of_descr in_read in let outchan = out_channel_of_descr out_write in open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr; close out_read; close in_write; (inchan, outchan) let open_process_full cmd env = let (in_read, in_write) = pipe() in let (out_read, out_write) = pipe() in let (err_read, err_write) = pipe() in set_close_on_exec in_read; set_close_on_exec out_write; set_close_on_exec err_read; let inchan = in_channel_of_descr in_read in let outchan = out_channel_of_descr out_write in let errchan = in_channel_of_descr err_read in open_proc cmd (Some(String.concat "\000" (Array.to_list env) ^ "\000")) (Process_full(inchan, outchan, errchan)) out_read in_write err_write; close out_read; close in_write; close err_write; (inchan, outchan, errchan) let find_proc_id fun_name proc = try let pid = Hashtbl.find popen_processes proc in Hashtbl.remove popen_processes proc; pid with Not_found -> raise(Unix_error(EBADF, fun_name, "")) let close_process_in inchan = let pid = find_proc_id "close_process_in" (Process_in inchan) in close_in inchan; snd(waitpid [] pid) let close_process_out outchan = let pid = find_proc_id "close_process_out" (Process_out outchan) in close_out outchan; snd(waitpid [] pid) let close_process (inchan, outchan) = let pid = find_proc_id "close_process" (Process(inchan, outchan)) in close_in inchan; close_out outchan; snd(waitpid [] pid) let close_process_full (inchan, outchan, errchan) = let pid = find_proc_id "close_process_full" (Process_full(inchan, outchan, errchan)) in close_in inchan; close_out outchan; close_in errchan; snd(waitpid [] pid) (* Polling *) external select : file_descr list -> file_descr list -> file_descr list -> float -> file_descr list * file_descr list * file_descr list = "unix_select" (* High-level network functions *) let open_connection sockaddr = let domain = match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in let sock = socket domain SOCK_STREAM 0 in connect sock sockaddr; (in_channel_of_descr sock, out_channel_of_descr sock) let shutdown_connection inchan = shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND let establish_server server_fun sockaddr = invalid_arg "Unix.establish_server not implemented" (* Terminal interface *) type terminal_io = { mutable c_ignbrk: bool; mutable c_brkint: bool; mutable c_ignpar: bool; mutable c_parmrk: bool; mutable c_inpck: bool; mutable c_istrip: bool; mutable c_inlcr: bool; mutable c_igncr: bool; mutable c_icrnl: bool; mutable c_ixon: bool; mutable c_ixoff: bool; mutable c_opost: bool; mutable c_obaud: int; mutable c_ibaud: int; mutable c_csize: int; mutable c_cstopb: int; mutable c_cread: bool; mutable c_parenb: bool; mutable c_parodd: bool; mutable c_hupcl: bool; mutable c_clocal: bool; mutable c_isig: bool; mutable c_icanon: bool; mutable c_noflsh: bool; mutable c_echo: bool; mutable c_echoe: bool; mutable c_echok: bool; mutable c_echonl: bool; mutable c_vintr: char; mutable c_vquit: char; mutable c_verase: char; mutable c_vkill: char; mutable c_veof: char; mutable c_veol: char; mutable c_vmin: int; mutable c_vtime: int; mutable c_vstart: char; mutable c_vstop: char } type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH let tcgetattr fd = invalid_arg "Unix.tcgetattr not implemented" let tcsetattr fd wh = invalid_arg "Unix.tcsetattr not implemented" let tcsendbreak fd n = invalid_arg "Unix.tcsendbreak not implemented" let tcdrain fd = invalid_arg "Unix.tcdrain not implemented" type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH let tcflush fd q = invalid_arg "Unix.tcflush not implemented" type flow_action = TCOOFF | TCOON | TCIOFF | TCION let tcflow fd fl = invalid_arg "Unix.tcflow not implemented" let setsid () = invalid_arg "Unix.setsid not implemented" mingw-ocaml/ocaml/otherlibs/win32unix/unixsupport.c0000644000175000017500000002151312124403241022105 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include #include #include "unixsupport.h" #include "cst2constr.h" #include /* Heap-allocation of Windows file handles */ static int win_handle_compare(value v1, value v2) { HANDLE h1 = Handle_val(v1); HANDLE h2 = Handle_val(v2); return h1 == h2 ? 0 : h1 < h2 ? -1 : 1; } static intnat win_handle_hash(value v) { return (intnat) Handle_val(v); } static struct custom_operations win_handle_ops = { "_handle", custom_finalize_default, win_handle_compare, win_handle_hash, custom_serialize_default, custom_deserialize_default, custom_compare_ext_default }; value win_alloc_handle(HANDLE h) { value res = alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1); Handle_val(res) = h; Descr_kind_val(res) = KIND_HANDLE; CRT_fd_val(res) = NO_CRT_FD; Flags_fd_val(res) = FLAGS_FD_IS_BLOCKING; return res; } value win_alloc_socket(SOCKET s) { value res = alloc_custom(&win_handle_ops, sizeof(struct filedescr), 0, 1); Socket_val(res) = s; Descr_kind_val(res) = KIND_SOCKET; CRT_fd_val(res) = NO_CRT_FD; Flags_fd_val(res) = FLAGS_FD_IS_BLOCKING; return res; } #if 0 /* PR#4750: this function is no longer used */ value win_alloc_handle_or_socket(HANDLE h) { value res = win_alloc_handle(h); int opt; int optlen = sizeof(opt); if (getsockopt((SOCKET) h, SOL_SOCKET, SO_TYPE, (char *)&opt, &optlen) == 0) Descr_kind_val(res) = KIND_SOCKET; return res; } #endif /* Mapping of Windows error codes to POSIX error codes */ struct error_entry { DWORD win_code; int range; int posix_code; }; static struct error_entry win_error_table[] = { { ERROR_INVALID_FUNCTION, 0, EINVAL}, { ERROR_FILE_NOT_FOUND, 0, ENOENT}, { ERROR_PATH_NOT_FOUND, 0, ENOENT}, { ERROR_TOO_MANY_OPEN_FILES, 0, EMFILE}, { ERROR_ACCESS_DENIED, 0, EACCES}, { ERROR_INVALID_HANDLE, 0, EBADF}, { ERROR_ARENA_TRASHED, 0, ENOMEM}, { ERROR_NOT_ENOUGH_MEMORY, 0, ENOMEM}, { ERROR_INVALID_BLOCK, 0, ENOMEM}, { ERROR_BAD_ENVIRONMENT, 0, E2BIG}, { ERROR_BAD_FORMAT, 0, ENOEXEC}, { ERROR_INVALID_ACCESS, 0, EINVAL}, { ERROR_INVALID_DATA, 0, EINVAL}, { ERROR_INVALID_DRIVE, 0, ENOENT}, { ERROR_CURRENT_DIRECTORY, 0, EACCES}, { ERROR_NOT_SAME_DEVICE, 0, EXDEV}, { ERROR_NO_MORE_FILES, 0, ENOENT}, { ERROR_LOCK_VIOLATION, 0, EACCES}, { ERROR_BAD_NETPATH, 0, ENOENT}, { ERROR_NETWORK_ACCESS_DENIED, 0, EACCES}, { ERROR_BAD_NET_NAME, 0, ENOENT}, { ERROR_FILE_EXISTS, 0, EEXIST}, { ERROR_CANNOT_MAKE, 0, EACCES}, { ERROR_FAIL_I24, 0, EACCES}, { ERROR_INVALID_PARAMETER, 0, EINVAL}, { ERROR_NO_PROC_SLOTS, 0, EAGAIN}, { ERROR_DRIVE_LOCKED, 0, EACCES}, { ERROR_BROKEN_PIPE, 0, EPIPE}, { ERROR_NO_DATA, 0, EPIPE}, { ERROR_DISK_FULL, 0, ENOSPC}, { ERROR_INVALID_TARGET_HANDLE, 0, EBADF}, { ERROR_INVALID_HANDLE, 0, EINVAL}, { ERROR_WAIT_NO_CHILDREN, 0, ECHILD}, { ERROR_CHILD_NOT_COMPLETE, 0, ECHILD}, { ERROR_DIRECT_ACCESS_HANDLE, 0, EBADF}, { ERROR_NEGATIVE_SEEK, 0, EINVAL}, { ERROR_SEEK_ON_DEVICE, 0, EACCES}, { ERROR_DIR_NOT_EMPTY, 0, ENOTEMPTY}, { ERROR_NOT_LOCKED, 0, EACCES}, { ERROR_BAD_PATHNAME, 0, ENOENT}, { ERROR_MAX_THRDS_REACHED, 0, EAGAIN}, { ERROR_LOCK_FAILED, 0, EACCES}, { ERROR_ALREADY_EXISTS, 0, EEXIST}, { ERROR_FILENAME_EXCED_RANGE, 0, ENOENT}, { ERROR_NESTING_NOT_ALLOWED, 0, EAGAIN}, { ERROR_NOT_ENOUGH_QUOTA, 0, ENOMEM}, { ERROR_INVALID_STARTING_CODESEG, ERROR_INFLOOP_IN_RELOC_CHAIN - ERROR_INVALID_STARTING_CODESEG, ENOEXEC }, { ERROR_WRITE_PROTECT, ERROR_SHARING_BUFFER_EXCEEDED - ERROR_WRITE_PROTECT, EACCES }, { WSAEINVAL, 0, EINVAL }, { WSAEACCES, 0, EACCES }, { WSAEBADF, 0, EBADF }, { WSAEFAULT, 0, EFAULT }, { WSAEINTR, 0, EINTR }, { WSAEINVAL, 0, EINVAL }, { WSAEMFILE, 0, EMFILE }, #ifdef WSANAMETOOLONG { WSANAMETOOLONG, 0, ENAMETOOLONG }, #endif #ifdef WSAENFILE { WSAENFILE, 0, ENFILE }, #endif { WSAENOTEMPTY, 0, ENOTEMPTY }, { 0, -1, 0 } }; void win32_maperr(DWORD errcode) { int i; for (i = 0; win_error_table[i].range >= 0; i++) { if (errcode >= win_error_table[i].win_code && errcode <= win_error_table[i].win_code + win_error_table[i].range) { errno = win_error_table[i].posix_code; return; } } /* Not found: save original error code, negated so that we can recognize it in unix_error_message */ errno = -errcode; } /* Windows socket errors */ #define EWOULDBLOCK -WSAEWOULDBLOCK #define EINPROGRESS -WSAEINPROGRESS #define EALREADY -WSAEALREADY #define ENOTSOCK -WSAENOTSOCK #define EDESTADDRREQ -WSAEDESTADDRREQ #define EMSGSIZE -WSAEMSGSIZE #define EPROTOTYPE -WSAEPROTOTYPE #define ENOPROTOOPT -WSAENOPROTOOPT #define EPROTONOSUPPORT -WSAEPROTONOSUPPORT #define ESOCKTNOSUPPORT -WSAESOCKTNOSUPPORT #define EOPNOTSUPP -WSAEOPNOTSUPP #define EPFNOSUPPORT -WSAEPFNOSUPPORT #define EAFNOSUPPORT -WSAEAFNOSUPPORT #define EADDRINUSE -WSAEADDRINUSE #define EADDRNOTAVAIL -WSAEADDRNOTAVAIL #define ENETDOWN -WSAENETDOWN #define ENETUNREACH -WSAENETUNREACH #define ENETRESET -WSAENETRESET #define ECONNABORTED -WSAECONNABORTED #define ECONNRESET -WSAECONNRESET #define ENOBUFS -WSAENOBUFS #define EISCONN -WSAEISCONN #define ENOTCONN -WSAENOTCONN #define ESHUTDOWN -WSAESHUTDOWN #define ETOOMANYREFS -WSAETOOMANYREFS #define ETIMEDOUT -WSAETIMEDOUT #define ECONNREFUSED -WSAECONNREFUSED #define ELOOP -WSAELOOP #define EHOSTDOWN -WSAEHOSTDOWN #define EHOSTUNREACH -WSAEHOSTUNREACH #define EPROCLIM -WSAEPROCLIM #define EUSERS -WSAEUSERS #define EDQUOT -WSAEDQUOT #define ESTALE -WSAESTALE #define EREMOTE -WSAEREMOTE #define EOVERFLOW -ERROR_ARITHMETIC_OVERFLOW #define EACCESS EACCES int error_table[] = { E2BIG, EACCESS, EAGAIN, EBADF, EBUSY, ECHILD, EDEADLK, EDOM, EEXIST, EFAULT, EFBIG, EINTR, EINVAL, EIO, EISDIR, EMFILE, EMLINK, ENAMETOOLONG, ENFILE, ENODEV, ENOENT, ENOEXEC, ENOLCK, ENOMEM, ENOSPC, ENOSYS, ENOTDIR, ENOTEMPTY, ENOTTY, ENXIO, EPERM, EPIPE, ERANGE, EROFS, ESPIPE, ESRCH, EXDEV, EWOULDBLOCK, EINPROGRESS, EALREADY, ENOTSOCK, EDESTADDRREQ, EMSGSIZE, EPROTOTYPE, ENOPROTOOPT, EPROTONOSUPPORT, ESOCKTNOSUPPORT, EOPNOTSUPP, EPFNOSUPPORT, EAFNOSUPPORT, EADDRINUSE, EADDRNOTAVAIL, ENETDOWN, ENETUNREACH, ENETRESET, ECONNABORTED, ECONNRESET, ENOBUFS, EISCONN, ENOTCONN, ESHUTDOWN, ETOOMANYREFS, ETIMEDOUT, ECONNREFUSED, EHOSTDOWN, EHOSTUNREACH, ELOOP, EOVERFLOW /*, EUNKNOWNERR */ }; static value * unix_error_exn = NULL; value unix_error_of_code (int errcode) { int errconstr; value err; errconstr = cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1); if (errconstr == Val_int(-1)) { err = alloc_small(1, 0); Field(err, 0) = Val_int(errcode); } else { err = errconstr; } return err; } void unix_error(int errcode, char *cmdname, value cmdarg) { value res; value name = Val_unit, err = Val_unit, arg = Val_unit; int errconstr; Begin_roots3 (name, err, arg); arg = cmdarg == Nothing ? copy_string("") : cmdarg; name = copy_string(cmdname); err = unix_error_of_code (errcode); if (unix_error_exn == NULL) { unix_error_exn = caml_named_value("Unix.Unix_error"); if (unix_error_exn == NULL) invalid_argument("Exception Unix.Unix_error not initialized, please link unix.cma"); } res = alloc_small(4, 0); Field(res, 0) = *unix_error_exn; Field(res, 1) = err; Field(res, 2) = name; Field(res, 3) = arg; End_roots(); mlraise(res); } void uerror(cmdname, cmdarg) char * cmdname; value cmdarg; { unix_error(errno, cmdname, cmdarg); } mingw-ocaml/ocaml/otherlibs/win32unix/sockopt.c0000644000175000017500000001360512124403241021152 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include #include "unixsupport.h" #include "socketaddr.h" #ifndef IPPROTO_IPV6 #define IPPROTO_IPV6 (-1) #endif #ifndef IPV6_V6ONLY #define IPV6_V6ONLY (-1) #endif enum option_type { TYPE_BOOL = 0, TYPE_INT = 1, TYPE_LINGER = 2, TYPE_TIMEVAL = 3, TYPE_UNIX_ERROR = 4 }; struct socket_option { int level; int option; }; /* Table of options, indexed by type */ static struct socket_option sockopt_bool[] = { { SOL_SOCKET, SO_DEBUG }, { SOL_SOCKET, SO_BROADCAST }, { SOL_SOCKET, SO_REUSEADDR }, { SOL_SOCKET, SO_KEEPALIVE }, { SOL_SOCKET, SO_DONTROUTE }, { SOL_SOCKET, SO_OOBINLINE }, { SOL_SOCKET, SO_ACCEPTCONN }, { IPPROTO_TCP, TCP_NODELAY }, { IPPROTO_IPV6, IPV6_V6ONLY} }; static struct socket_option sockopt_int[] = { { SOL_SOCKET, SO_SNDBUF }, { SOL_SOCKET, SO_RCVBUF }, { SOL_SOCKET, SO_ERROR }, { SOL_SOCKET, SO_TYPE }, { SOL_SOCKET, SO_RCVLOWAT }, { SOL_SOCKET, SO_SNDLOWAT } }; static struct socket_option sockopt_linger[] = { { SOL_SOCKET, SO_LINGER } }; static struct socket_option sockopt_timeval[] = { { SOL_SOCKET, SO_RCVTIMEO }, { SOL_SOCKET, SO_SNDTIMEO } }; static struct socket_option sockopt_unix_error[] = { { SOL_SOCKET, SO_ERROR } }; static struct socket_option * sockopt_table[] = { sockopt_bool, sockopt_int, sockopt_linger, sockopt_timeval, sockopt_unix_error }; static char * getsockopt_fun_name[] = { "getsockopt", "getsockopt_int", "getsockopt_optint", "getsockopt_float", "getsockopt_error" }; static char * setsockopt_fun_name[] = { "setsockopt", "setsockopt_int", "setsockopt_optint", "setsockopt_float", "setsockopt_error" }; union option_value { int i; struct linger lg; struct timeval tv; }; CAMLexport value unix_getsockopt_aux(char * name, enum option_type ty, int level, int option, value socket) { union option_value optval; socklen_param_type optsize; switch (ty) { case TYPE_BOOL: case TYPE_INT: case TYPE_UNIX_ERROR: optsize = sizeof(optval.i); break; case TYPE_LINGER: optsize = sizeof(optval.lg); break; case TYPE_TIMEVAL: optsize = sizeof(optval.tv); break; default: unix_error(EINVAL, name, Nothing); } if (getsockopt(Socket_val(socket), level, option, (void *) &optval, &optsize) == -1) uerror(name, Nothing); switch (ty) { case TYPE_BOOL: case TYPE_INT: return Val_int(optval.i); case TYPE_LINGER: if (optval.lg.l_onoff == 0) { return Val_int(0); /* None */ } else { value res = alloc_small(1, 0); /* Some */ Field(res, 0) = Val_int(optval.lg.l_linger); return res; } case TYPE_TIMEVAL: return copy_double((double) optval.tv.tv_sec + (double) optval.tv.tv_usec / 1e6); case TYPE_UNIX_ERROR: if (optval.i == 0) { return Val_int(0); /* None */ } else { value err, res; err = unix_error_of_code(optval.i); Begin_root(err); res = alloc_small(1, 0); /* Some */ Field(res, 0) = err; End_roots(); return res; } default: unix_error(EINVAL, name, Nothing); return Val_unit; /* Avoid warning */ } } CAMLexport value unix_setsockopt_aux(char * name, enum option_type ty, int level, int option, value socket, value val) { union option_value optval; socklen_param_type optsize; double f; switch (ty) { case TYPE_BOOL: case TYPE_INT: optsize = sizeof(optval.i); optval.i = Int_val(val); break; case TYPE_LINGER: optsize = sizeof(optval.lg); optval.lg.l_onoff = Is_block (val); if (optval.lg.l_onoff) optval.lg.l_linger = Int_val (Field (val, 0)); break; case TYPE_TIMEVAL: f = Double_val(val); optsize = sizeof(optval.tv); optval.tv.tv_sec = (int) f; optval.tv.tv_usec = (int) (1e6 * (f - optval.tv.tv_sec)); break; case TYPE_UNIX_ERROR: default: unix_error(EINVAL, name, Nothing); } if (setsockopt(Socket_val(socket), level, option, (void *) &optval, optsize) == -1) uerror(name, Nothing); return Val_unit; } CAMLprim value unix_getsockopt(value vty, value vsocket, value voption) { enum option_type ty = Int_val(vty); struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]); return unix_getsockopt_aux(getsockopt_fun_name[ty], ty, opt->level, opt->option, vsocket); } CAMLprim value unix_setsockopt(value vty, value vsocket, value voption, value val) { enum option_type ty = Int_val(vty); struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]); return unix_setsockopt_aux(setsockopt_fun_name[ty], ty, opt->level, opt->option, vsocket, val); } mingw-ocaml/ocaml/otherlibs/win32unix/connect.c0000644000175000017500000000265112124403241021120 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #include "socketaddr.h" CAMLprim value unix_connect(socket, address) value socket, address; { SOCKET s = Socket_val(socket); union sock_addr_union addr; socklen_param_type addr_len; DWORD err = 0; get_sockaddr(address, &addr, &addr_len); enter_blocking_section(); if (connect(s, &addr.s_gen, addr_len) == -1) err = WSAGetLastError(); leave_blocking_section(); if (err) { win32_maperr(err); uerror("connect", Nothing); } return Val_unit; } mingw-ocaml/ocaml/otherlibs/win32unix/winworker.c0000644000175000017500000002163212124403241021516 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Contributed by Sylvain Le Gall for Lexifi */ /* */ /* Copyright 2008 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "winworker.h" #include "winlist.h" #include "windbug.h" #include #include #include "unixsupport.h" typedef enum { WORKER_CMD_NONE = 0, WORKER_CMD_EXEC, WORKER_CMD_STOP } WORKERCMD; struct _WORKER { LIST lst; /* This structure is used as a list. */ HANDLE hJobStarted; /* Event representing that the function has begun. */ HANDLE hJobStop; /* Event that can be used to notify the function that it should stop processing. */ HANDLE hJobDone; /* Event representing that the function has finished. */ void *lpJobUserData; /* User data for the job. */ WORKERFUNC hJobFunc; /* Function to be called during APC */ HANDLE hWorkerReady; /* Worker is ready. */ HANDLE hCommandReady; /* Worker should execute command. */ WORKERCMD ECommand; /* Command to execute */ HANDLE hThread; /* Thread handle of the worker. */ }; #define THREAD_WORKERS_MAX 16 #define THREAD_WORKERS_MEM 4000 LPWORKER lpWorkers = NULL; DWORD nWorkersCurrent = 0; DWORD nWorkersMax = 0; HANDLE hWorkersMutex = INVALID_HANDLE_VALUE; DWORD WINAPI worker_wait (LPVOID _data) { BOOL bExit; LPWORKER lpWorker; lpWorker = (LPWORKER )_data; bExit = FALSE; DEBUG_PRINT("Worker %x starting", lpWorker); while ( !bExit && SignalObjectAndWait( lpWorker->hWorkerReady, lpWorker->hCommandReady, INFINITE, TRUE) == WAIT_OBJECT_0) { DEBUG_PRINT("Worker %x running", lpWorker); switch (lpWorker->ECommand) { case WORKER_CMD_NONE: break; case WORKER_CMD_EXEC: if (lpWorker->hJobFunc != NULL) { SetEvent(lpWorker->hJobStarted); lpWorker->hJobFunc(lpWorker->hJobStop, lpWorker->lpJobUserData); SetEvent(lpWorker->hJobDone); }; break; case WORKER_CMD_STOP: bExit = TRUE; break; } }; DEBUG_PRINT("Worker %x exiting", lpWorker); return 0; } LPWORKER worker_new (void) { LPWORKER lpWorker = NULL; lpWorker = (LPWORKER)caml_stat_alloc(sizeof(WORKER)); list_init((LPLIST)lpWorker); lpWorker->hJobStarted = CreateEvent(NULL, TRUE, FALSE, NULL); lpWorker->hJobStop = CreateEvent(NULL, TRUE, FALSE, NULL); lpWorker->hJobDone = CreateEvent(NULL, TRUE, FALSE, NULL); lpWorker->lpJobUserData = NULL; lpWorker->hWorkerReady = CreateEvent(NULL, FALSE, FALSE, NULL); lpWorker->hCommandReady = CreateEvent(NULL, FALSE, FALSE, NULL); lpWorker->ECommand = WORKER_CMD_NONE; lpWorker->hThread = CreateThread( NULL, THREAD_WORKERS_MEM, worker_wait, (LPVOID)lpWorker, 0, NULL); return lpWorker; }; void worker_free (LPWORKER lpWorker) { /* Wait for termination of the worker */ DEBUG_PRINT("Shutting down worker %x", lpWorker); WaitForSingleObject(lpWorker->hWorkerReady, INFINITE); lpWorker->ECommand = WORKER_CMD_STOP; SetEvent(lpWorker->hCommandReady); WaitForSingleObject(lpWorker->hThread, INFINITE); /* Free resources */ DEBUG_PRINT("Freeing resources of worker %x", lpWorker); if (lpWorker->hThread != INVALID_HANDLE_VALUE) { CloseHandle(lpWorker->hThread); lpWorker->hThread = INVALID_HANDLE_VALUE; } if (lpWorker->hJobStarted != INVALID_HANDLE_VALUE) { CloseHandle(lpWorker->hJobStarted); lpWorker->hJobStarted = INVALID_HANDLE_VALUE; } if (lpWorker->hJobStop != INVALID_HANDLE_VALUE) { CloseHandle(lpWorker->hJobStop); lpWorker->hJobStop = INVALID_HANDLE_VALUE; } if (lpWorker->hJobDone != INVALID_HANDLE_VALUE) { CloseHandle(lpWorker->hJobDone); lpWorker->hJobDone = INVALID_HANDLE_VALUE; } lpWorker->lpJobUserData = NULL; lpWorker->hJobFunc = NULL; if (lpWorker->hWorkerReady != INVALID_HANDLE_VALUE) { CloseHandle(lpWorker->hWorkerReady); lpWorker->hWorkerReady = INVALID_HANDLE_VALUE; } if (lpWorker->hCommandReady != INVALID_HANDLE_VALUE) { CloseHandle(lpWorker->hCommandReady); lpWorker->hCommandReady = INVALID_HANDLE_VALUE; } caml_stat_free(lpWorker); }; LPWORKER worker_pop (void) { LPWORKER lpWorkerFree = NULL; WaitForSingleObject(hWorkersMutex, INFINITE); /* Get the first worker of the list */ if (lpWorkers != NULL) { lpWorkerFree = lpWorkers; lpWorkers = LIST_NEXT(LPWORKER, lpWorkers); } nWorkersCurrent++; nWorkersMax = (nWorkersCurrent > nWorkersMax ? nWorkersCurrent : nWorkersMax); DEBUG_PRINT("Workers running current/runnning max/waiting: %d/%d/%d", nWorkersCurrent, nWorkersMax, list_length((LPLIST)lpWorkers)); ReleaseMutex(hWorkersMutex); if (lpWorkerFree == NULL) { /* We cannot find a free worker, create one. */ lpWorkerFree = worker_new(); } /* Ensure that we don't get dangling pointer to old data. */ list_init((LPLIST)lpWorkerFree); lpWorkerFree->lpJobUserData = NULL; /* Reset events */ ResetEvent(lpWorkerFree->hJobStarted); ResetEvent(lpWorkerFree->hJobStop); ResetEvent(lpWorkerFree->hJobDone); return lpWorkerFree; } void worker_push(LPWORKER lpWorker) { BOOL bFreeWorker; bFreeWorker = TRUE; WaitForSingleObject(hWorkersMutex, INFINITE); DEBUG_PRINT("Testing if we are under the maximum number of running workers"); if (list_length((LPLIST)lpWorkers) < THREAD_WORKERS_MAX) { DEBUG_PRINT("Saving this worker for future use"); DEBUG_PRINT("Next: %x", ((LPLIST)lpWorker)->lpNext); lpWorkers = (LPWORKER)list_concat((LPLIST)lpWorker, (LPLIST)lpWorkers); bFreeWorker = FALSE; }; nWorkersCurrent--; DEBUG_PRINT("Workers running current/runnning max/waiting: %d/%d/%d", nWorkersCurrent, nWorkersMax, list_length((LPLIST)lpWorkers)); ReleaseMutex(hWorkersMutex); if (bFreeWorker) { DEBUG_PRINT("Freeing worker %x", lpWorker); worker_free(lpWorker); } } void worker_init (void) { int i = 0; /* Init a shared variable. The only way to ensure that no other worker will be at the same point is to use a critical section. */ DEBUG_PRINT("Allocating mutex for workers"); if (hWorkersMutex == INVALID_HANDLE_VALUE) { hWorkersMutex = CreateMutex(NULL, FALSE, NULL); } } void worker_cleanup(void) { LPWORKER lpWorker = NULL; /* WARNING: we can have a race condition here, if while this code is executed another worker is waiting to access hWorkersMutex, he will never be able to get it... */ if (hWorkersMutex != INVALID_HANDLE_VALUE) { WaitForSingleObject(hWorkersMutex, INFINITE); DEBUG_PRINT("Freeing global resource of workers"); /* Empty the queue of worker worker */ while (lpWorkers != NULL) { ReleaseMutex(hWorkersMutex); lpWorker = worker_pop(); DEBUG_PRINT("Freeing worker %x", lpWorker); WaitForSingleObject(hWorkersMutex, INFINITE); worker_free(lpWorker); }; ReleaseMutex(hWorkersMutex); /* Destroy associated mutex */ CloseHandle(hWorkersMutex); hWorkersMutex = INVALID_HANDLE_VALUE; }; } LPWORKER worker_job_submit (WORKERFUNC f, void *user_data) { LPWORKER lpWorker = worker_pop(); DEBUG_PRINT("Waiting for worker to be ready"); enter_blocking_section(); WaitForSingleObject(lpWorker->hWorkerReady, INFINITE); ResetEvent(lpWorker->hWorkerReady); leave_blocking_section(); DEBUG_PRINT("Worker is ready"); lpWorker->hJobFunc = f; lpWorker->lpJobUserData = user_data; lpWorker->ECommand = WORKER_CMD_EXEC; DEBUG_PRINT("Call worker (func: %x, worker: %x)", f, lpWorker); SetEvent(lpWorker->hCommandReady); return (LPWORKER)lpWorker; } HANDLE worker_job_event_done (LPWORKER lpWorker) { return lpWorker->hJobDone; } void worker_job_stop (LPWORKER lpWorker) { DEBUG_PRINT("Sending stop signal to worker %x", lpWorker); SetEvent(lpWorker->hJobStop); DEBUG_PRINT("Signal sent to worker %x", lpWorker); } void worker_job_finish (LPWORKER lpWorker) { DEBUG_PRINT("Finishing call of worker %x", lpWorker); enter_blocking_section(); WaitForSingleObject(lpWorker->hJobDone, INFINITE); leave_blocking_section(); worker_push(lpWorker); } mingw-ocaml/ocaml/otherlibs/win32unix/socket.c0000644000175000017500000000432312124403241020755 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" int socket_domain_table[] = { PF_UNIX, PF_INET /*, PF_INET6 */ }; int socket_type_table[] = { SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET }; CAMLprim value unix_socket(domain, type, proto) value domain, type, proto; { SOCKET s; int oldvalue, oldvaluelen, newvalue, retcode; /* IPv6 requires WinSock2, we must raise an error on PF_INET6 */ if (Int_val(domain) >= sizeof(socket_domain_table)/sizeof(int)) { win32_maperr(WSAEPFNOSUPPORT); uerror("socket", Nothing); } oldvaluelen = sizeof(oldvalue); retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &oldvalue, &oldvaluelen); if (retcode == 0) { /* Set sockets to synchronous mode */ newvalue = SO_SYNCHRONOUS_NONALERT; setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &newvalue, sizeof(newvalue)); } s = socket(socket_domain_table[Int_val(domain)], socket_type_table[Int_val(type)], Int_val(proto)); if (retcode == 0) { /* Restore initial mode */ setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &oldvalue, oldvaluelen); } if (s == INVALID_SOCKET) { win32_maperr(WSAGetLastError()); uerror("socket", Nothing); } return win_alloc_socket(s); } mingw-ocaml/ocaml/otherlibs/win32unix/listen.c0000644000175000017500000000222212124403241020757 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" CAMLprim value unix_listen(sock, backlog) value sock, backlog; { if (listen(Socket_val(sock), Int_val(backlog)) == -1) { win32_maperr(WSAGetLastError()); uerror("listen", Nothing); } return Val_unit; } mingw-ocaml/ocaml/otherlibs/win32unix/winlist.h0000644000175000017500000000333012124403241021160 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Contributed by Sylvain Le Gall for Lexifi */ /* */ /* Copyright 2008 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef _WINLIST_H #define _WINLIST_H /* Basic list function in C. */ /* Singly-linked list data structure. * To transform a C struct into a list structure, you must include * at first position of your C struct a "LIST lst" and call list_init * on this data structure. * * See winworker.c for example. */ typedef struct _LIST LIST; typedef LIST *LPLIST; struct _LIST { LPLIST lpNext; }; /* Initialize list data structure */ void list_init (LPLIST lst); /* Cleanup list data structure */ void list_cleanup (LPLIST lst); /* Set next element */ void list_next_set (LPLIST lst, LPLIST next); /* Return next element */ LPLIST list_next (LPLIST); #define LIST_NEXT(T, e) ((T)(list_next((LPLIST)(e)))) /* Get number of element */ int list_length (LPLIST); /* Concat two list. */ LPLIST list_concat (LPLIST, LPLIST); #endif /* _WINLIST_H */ mingw-ocaml/ocaml/otherlibs/win32unix/link.c0000644000175000017500000000312512124403241020421 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* File contributed by Lionel Fourquaux */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" typedef BOOL (WINAPI *tCreateHardLink)( LPCTSTR lpFileName, LPCTSTR lpExistingFileName, LPSECURITY_ATTRIBUTES lpSecurityAttributes ); CAMLprim value unix_link(value path1, value path2) { HMODULE hModKernel32; tCreateHardLink pCreateHardLink; hModKernel32 = GetModuleHandle("KERNEL32.DLL"); pCreateHardLink = (tCreateHardLink) GetProcAddress(hModKernel32, "CreateHardLinkA"); if (pCreateHardLink == NULL) invalid_argument("Unix.link not implemented"); if (! pCreateHardLink(String_val(path2), String_val(path1), NULL)) { win32_maperr(GetLastError()); uerror("link", path2); } return Val_unit; } mingw-ocaml/ocaml/otherlibs/win32unix/times.c0000644000175000017500000000143012124403241020602 0ustar tootstoots#include #include #include "unixsupport.h" double to_sec(FILETIME ft) { ULARGE_INTEGER tmp; tmp.u.LowPart = ft.dwLowDateTime; tmp.u.HighPart = ft.dwHighDateTime; /* convert to seconds: GetProcessTimes returns number of 100-nanosecond intervals */ return tmp.QuadPart / 1e7; } value unix_times(value unit) { value res; FILETIME creation, exit, stime, utime; if (!(GetProcessTimes(GetCurrentProcess(), &creation, &exit, &stime, &utime))) { win32_maperr(GetLastError()); uerror("times", Nothing); } res = alloc_small(4 * Double_wosize, Double_array_tag); Store_double_field(res, 0, to_sec(utime)); Store_double_field(res, 1, to_sec(stime)); Store_double_field(res, 2, 0); Store_double_field(res, 3, 0); return res; } mingw-ocaml/ocaml/otherlibs/win32unix/startup.c0000644000175000017500000000301212124403241021161 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ #include #include #include #include #include "unixsupport.h" #include "winworker.h" #include "windbug.h" value val_process_id; CAMLprim value win_startup(unit) value unit; { WSADATA wsaData; int i; HANDLE h; (void) WSAStartup(MAKEWORD(2, 0), &wsaData); DuplicateHandle(GetCurrentProcess(), GetCurrentProcess(), GetCurrentProcess(), &h, 0, TRUE, DUPLICATE_SAME_ACCESS); val_process_id = Val_int(h); worker_init(); return Val_unit; } CAMLprim value win_cleanup(unit) value unit; { worker_cleanup(); (void) WSACleanup(); return Val_unit; } mingw-ocaml/ocaml/otherlibs/win32unix/stat.c0000644000175000017500000000632612124403241020445 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #include "cst2constr.h" #define _INTEGRAL_MAX_BITS 64 #include #include #ifndef S_IFLNK #define S_IFLNK 0 #endif #ifndef S_IFIFO #define S_IFIFO 0 #endif #ifndef S_IFSOCK #define S_IFSOCK 0 #endif #ifndef S_IFBLK #define S_IFBLK 0 #endif static int file_kind_table[] = { S_IFREG, S_IFDIR, S_IFCHR, S_IFBLK, S_IFLNK, S_IFIFO, S_IFSOCK }; static value stat_aux(int use_64, struct _stati64 *buf) { CAMLparam0 (); CAMLlocal1 (v); v = caml_alloc (12, 0); Store_field (v, 0, Val_int (buf->st_dev)); Store_field (v, 1, Val_int (buf->st_ino)); Store_field (v, 2, cst_to_constr (buf->st_mode & S_IFMT, file_kind_table, sizeof(file_kind_table) / sizeof(int), 0)); Store_field (v, 3, Val_int(buf->st_mode & 07777)); Store_field (v, 4, Val_int (buf->st_nlink)); Store_field (v, 5, Val_int (buf->st_uid)); Store_field (v, 6, Val_int (buf->st_gid)); Store_field (v, 7, Val_int (buf->st_rdev)); Store_field (v, 8, use_64 ? copy_int64(buf->st_size) : Val_int (buf->st_size)); Store_field (v, 9, copy_double((double) buf->st_atime)); Store_field (v, 10, copy_double((double) buf->st_mtime)); Store_field (v, 11, copy_double((double) buf->st_ctime)); CAMLreturn (v); } CAMLprim value unix_stat(value path) { int ret; struct _stati64 buf; ret = _stati64(String_val(path), &buf); if (ret == -1) uerror("stat", path); if (buf.st_size > Max_long) { win32_maperr(ERROR_ARITHMETIC_OVERFLOW); uerror("stat", path); } return stat_aux(0, &buf); } CAMLprim value unix_stat_64(value path) { int ret; struct _stati64 buf; ret = _stati64(String_val(path), &buf); if (ret == -1) uerror("stat", path); return stat_aux(1, &buf); } CAMLprim value unix_fstat(value handle) { int ret; struct _stati64 buf; ret = _fstati64(win_CRT_fd_of_filedescr(handle), &buf); if (ret == -1) uerror("fstat", Nothing); if (buf.st_size > Max_long) { win32_maperr(ERROR_ARITHMETIC_OVERFLOW); uerror("fstat", Nothing); } return stat_aux(0, &buf); } CAMLprim value unix_fstat_64(value handle) { int ret; struct _stati64 buf; ret = _fstati64(win_CRT_fd_of_filedescr(handle), &buf); if (ret == -1) uerror("fstat", Nothing); return stat_aux(1, &buf); } mingw-ocaml/ocaml/otherlibs/win32unix/libunix.clib0000644000175000017500000000124612124403241021627 0ustar tootstoots# Files in this directory accept.o bind.o channels.o close.o close_on.o connect.o createprocess.o dup.o dup2.o errmsg.o getpeername.o getpid.o getsockname.o gettimeofday.o link.o listen.o lockf.o lseek.o nonblock.o mkdir.o open.o pipe.o read.o rename.o select.o sendrecv.o shutdown.o sleep.o socket.o sockopt.o startup.o stat.o system.o unixsupport.o windir.o winwait.o write.o winlist.o winworker.o windbug.o # Files from the ../unix directory access.o addrofstr.o chdir.o chmod.o cst2constr.o cstringv.o envir.o execv.o execve.o execvp.o exit.o getcwd.o gethost.o gethostname.o getproto.o getserv.o gmtime.o putenv.o rmdir.o socketaddr.o strofaddr.o time.o unlink.o utimes.o mingw-ocaml/ocaml/otherlibs/win32unix/createprocess.c0000644000175000017500000000557412124403241022340 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "unixsupport.h" static int win_has_console(void); value win_create_process_native(value cmd, value cmdline, value env, value fd1, value fd2, value fd3) { PROCESS_INFORMATION pi; STARTUPINFO si; char * exefile, * envp; int flags; exefile = search_exe_in_path(String_val(cmd)); if (env != Val_int(0)) { envp = String_val(Field(env, 0)); } else { envp = NULL; } /* Prepare stdin/stdout/stderr redirection */ ZeroMemory(&si, sizeof(STARTUPINFO)); si.cb = sizeof(STARTUPINFO); si.dwFlags = STARTF_USESTDHANDLES; si.hStdInput = Handle_val(fd1); si.hStdOutput = Handle_val(fd2); si.hStdError = Handle_val(fd3); /* If we do not have a console window, then we must create one before running the process (keep it hidden for apparence). If we are starting a GUI application, the newly created console should not matter. */ if (win_has_console()) flags = 0; else { flags = CREATE_NEW_CONSOLE; si.dwFlags = (STARTF_USESHOWWINDOW | STARTF_USESTDHANDLES); si.wShowWindow = SW_HIDE; } /* Create the process */ if (! CreateProcess(exefile, String_val(cmdline), NULL, NULL, TRUE, flags, envp, NULL, &si, &pi)) { win32_maperr(GetLastError()); uerror("create_process", cmd); } CloseHandle(pi.hThread); /* Return the process handle as pseudo-PID (this is consistent with the wait() emulation in the MSVC C library */ return Val_long(pi.hProcess); } CAMLprim value win_create_process(value * argv, int argn) { return win_create_process_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } static int win_has_console(void) { HANDLE h, log; int i; h = CreateFile("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (h == INVALID_HANDLE_VALUE) { return 0; } else { CloseHandle(h); return 1; } } mingw-ocaml/ocaml/otherlibs/win32unix/accept.c0000644000175000017500000000444412124403241020730 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include "unixsupport.h" #include "socketaddr.h" CAMLprim value unix_accept(sock) value sock; { SOCKET sconn = Socket_val(sock); SOCKET snew; value fd = Val_unit, adr = Val_unit, res; int oldvalue, oldvaluelen, newvalue, retcode; union sock_addr_union addr; socklen_param_type addr_len; DWORD err = 0; oldvaluelen = sizeof(oldvalue); retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &oldvalue, &oldvaluelen); if (retcode == 0) { /* Set sockets to synchronous mode */ newvalue = SO_SYNCHRONOUS_NONALERT; setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &newvalue, sizeof(newvalue)); } addr_len = sizeof(sock_addr); enter_blocking_section(); snew = accept(sconn, &addr.s_gen, &addr_len); if (snew == INVALID_SOCKET) err = WSAGetLastError (); leave_blocking_section(); if (retcode == 0) { /* Restore initial mode */ setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &oldvalue, oldvaluelen); } if (snew == INVALID_SOCKET) { win32_maperr(err); uerror("accept", Nothing); } Begin_roots2 (fd, adr) fd = win_alloc_socket(snew); adr = alloc_sockaddr(&addr, addr_len, snew); res = alloc_small(2, 0); Field(res, 0) = fd; Field(res, 1) = adr; End_roots(); return res; } mingw-ocaml/ocaml/otherlibs/win32unix/rename.c0000644000175000017500000000327412124403241020740 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Contributed by Tracy Camp, PolyServe Inc., */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" CAMLprim value unix_rename(value path1, value path2) { static int supports_MoveFileEx = -1; /* don't know yet */ BOOL ok; if (supports_MoveFileEx < 0) { OSVERSIONINFO VersionInfo; VersionInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); supports_MoveFileEx = (GetVersionEx(&VersionInfo) != 0) && (VersionInfo.dwPlatformId == VER_PLATFORM_WIN32_NT); } if (supports_MoveFileEx > 0) ok = MoveFileEx(String_val(path1), String_val(path2), MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH | MOVEFILE_COPY_ALLOWED); else ok = MoveFile(String_val(path1), String_val(path2)); if (! ok) { win32_maperr(GetLastError()); uerror("rename", path1); } return Val_unit; } mingw-ocaml/ocaml/otherlibs/win32unix/.depend0000644000175000017500000000021712124403241020557 0ustar tootstootsunix.cmo: unix.cmi unix.cmx: unix.cmi unixLabels.cmo: unix.cmi unixLabels.cmi unixLabels.cmx: unix.cmx unixLabels.cmi unixLabels.cmi: unix.cmi mingw-ocaml/ocaml/otherlibs/win32unix/unixsupport.h0000644000175000017500000000466312124403241022121 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #define WIN32_LEAN_AND_MEAN #include #include #include #include #include #include #include struct filedescr { union { HANDLE handle; SOCKET socket; } fd; /* Real windows handle */ enum { KIND_HANDLE, KIND_SOCKET } kind; int crt_fd; /* C runtime descriptor */ unsigned int flags_fd; /* See FLAGS_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) #define CRT_fd_val(v) (((struct filedescr *) Data_custom_val(v))->crt_fd) #define Flags_fd_val(v) (((struct filedescr *) Data_custom_val(v))->flags_fd) /* extern value win_alloc_handle_or_socket(HANDLE); */ extern value win_alloc_handle(HANDLE); extern value win_alloc_socket(SOCKET); extern int win_CRT_fd_of_filedescr(value handle); #define NO_CRT_FD (-1) #define Nothing ((value) 0) extern void win32_maperr(DWORD errcode); extern value unix_error_of_code (int errcode); extern void unix_error (int errcode, char * cmdname, value arg); extern void uerror (char * cmdname, value arg); extern value unix_freeze_buffer (value); /* Information stored in flags_fd, describing more precisely the socket * and its status. The whole flags_fd is initialized to 0. */ /* Blocking or nonblocking. By default a filedescr is in blocking state */ #define FLAGS_FD_IS_BLOCKING (1<<0) #define UNIX_BUFFER_SIZE 65536 mingw-ocaml/ocaml/otherlibs/win32unix/lseek.c0000644000175000017500000000417012124403241020570 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include "unixsupport.h" #ifdef HAS_UNISTD #include #else #define SEEK_SET 0 #define SEEK_CUR 1 #define SEEK_END 2 #endif static DWORD seek_command_table[] = { FILE_BEGIN, FILE_CURRENT, FILE_END }; #ifndef INVALID_SET_FILE_POINTER #define INVALID_SET_FILE_POINTER (-1) #endif static __int64 caml_set_file_pointer(HANDLE h, __int64 dist, DWORD mode) { LARGE_INTEGER i; DWORD err; i.QuadPart = dist; i.LowPart = SetFilePointer(h, i.LowPart, &i.HighPart, mode); if (i.LowPart == INVALID_SET_FILE_POINTER) { err = GetLastError(); if (err != NO_ERROR) { win32_maperr(err); uerror("lseek", Nothing); } } return i.QuadPart; } CAMLprim value unix_lseek(value fd, value ofs, value cmd) { __int64 ret; ret = caml_set_file_pointer(Handle_val(fd), Long_val(ofs), seek_command_table[Int_val(cmd)]); if (ret > Max_long) { win32_maperr(ERROR_ARITHMETIC_OVERFLOW); uerror("lseek", Nothing); } return Val_long(ret); } CAMLprim value unix_lseek_64(value fd, value ofs, value cmd) { __int64 ret; ret = caml_set_file_pointer(Handle_val(fd), Int64_val(ofs), seek_command_table[Int_val(cmd)]); return copy_int64(ret); } mingw-ocaml/ocaml/otherlibs/win32unix/dup2.c0000644000175000017500000000322512124403241020337 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" extern int _dup2(int, int); CAMLprim value unix_dup2(value fd1, value fd2) { HANDLE oldh, newh; oldh = Handle_val(fd2); if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd1), GetCurrentProcess(), &newh, 0L, TRUE, DUPLICATE_SAME_ACCESS)) { win32_maperr(GetLastError()); return -1; } Handle_val(fd2) = newh; if (Descr_kind_val(fd2) == KIND_SOCKET) closesocket((SOCKET) oldh); else CloseHandle(oldh); Descr_kind_val(fd2) = Descr_kind_val(fd1); /* Reflect the dup2 on the CRT fds, if any */ if (CRT_fd_val(fd1) != NO_CRT_FD || CRT_fd_val(fd2) != NO_CRT_FD) _dup2(win_CRT_fd_of_filedescr(fd1), win_CRT_fd_of_filedescr(fd2)); return Val_unit; } mingw-ocaml/ocaml/otherlibs/win32unix/getsockname.c0000644000175000017500000000246312124403241021770 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "unixsupport.h" #include "socketaddr.h" CAMLprim value unix_getsockname(sock) value sock; { int retcode; union sock_addr_union addr; socklen_param_type addr_len; addr_len = sizeof(sock_addr); retcode = getsockname(Socket_val(sock), &addr.s_gen, &addr_len); if (retcode == -1) uerror("getsockname", Nothing); return alloc_sockaddr(&addr, addr_len, -1); } mingw-ocaml/ocaml/otherlibs/win32unix/windbug.c0000644000175000017500000000215412124403241021124 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Contributed by Sylvain Le Gall for Lexifi */ /* */ /* Copyright 2008 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "windbug.h" int debug_test (void) { static int debug_init = 0; static int debug = 0; #ifdef DEBUG if (!debug_init) { debug = (getenv("OCAMLDEBUG") != NULL); debug_init = 1; }; #endif return debug; } mingw-ocaml/ocaml/otherlibs/db/0000755000175000017500000000000012124403241016036 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/db/.gitignore0000644000175000017500000000000012124403241020014 0ustar tootstootsmingw-ocaml/ocaml/otherlibs/Makefile.shared0000644000175000017500000000532612124403241020364 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ # Common Makefile for otherlibs ROOTDIR=../.. include $(ROOTDIR)/config/Makefile # Compilation options CC=$(BYTECC) CAMLRUN=$(ROOTDIR)/boot/ocamlrun COMPFLAGS=-warn-error A -g $(EXTRACAMLFLAGS) MKLIB=$(CAMLRUN) $(ROOTDIR)/tools/ocamlmklib # Variables to be defined by individual libraries: #LIBNAME= #CLIBNAME= #CMIFILES= #CAMLOBJS= #COBJS= #EXTRACFLAGS= #EXTRACAMLFLAGS= #LINKOPTS= #LDOPTS= #HEADERS= CMIFILES ?= $(CAMLOBJS:.cmo=.cmi) CAMLOBJS_NAT ?= $(CAMLOBJS:.cmo=.cmx) CLIBNAME ?= $(LIBNAME) all: lib$(CLIBNAME).$(A) $(LIBNAME).cma $(CMIFILES) allopt: lib$(CLIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).$(CMXS) $(CMIFILES) $(LIBNAME).cma: $(CAMLOBJS) $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlc '$(CAMLC)' -linkall $(CAMLOBJS) $(LINKOPTS) $(LIBNAME).cmxa: $(CAMLOBJS_NAT) $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlopt '$(CAMLOPT)' -linkall $(CAMLOBJS_NAT) $(LINKOPTS) $(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(CLIBNAME).$(A) $(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa lib$(CLIBNAME).$(A): $(COBJS) $(MKLIB) -oc $(CLIBNAME) $(COBJS) $(LDOPTS) install:: if test -f dll$(CLIBNAME)$(EXT_DLL); then \ cp dll$(CLIBNAME)$(EXT_DLL) $(STUBLIBDIR)/; fi cp lib$(CLIBNAME).$(A) $(LIBDIR)/ cd $(LIBDIR); $(RANLIB) lib$(CLIBNAME).$(A) cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) $(LIBDIR)/ if test -n "$(HEADERS)"; then cp $(HEADERS) $(LIBDIR)/caml/; fi installopt: cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) $(LIBDIR)/ cd $(LIBDIR); $(RANLIB) $(LIBNAME).a if test -f $(LIBNAME).cmxs; then cp $(LIBNAME).cmxs $(LIBDIR)/; fi partialclean: rm -f *.cm* clean:: partialclean rm -f *.dll *.so *.a *.lib *.o *.obj .SUFFIXES: .ml .mli .cmi .cmo .cmx .$(O) .mli.cmi: $(CAMLC) -c $(COMPFLAGS) $< .ml.cmo: $(CAMLC) -c $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< .c.$(O): $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $< mingw-ocaml/ocaml/otherlibs/bigarray/0000755000175000017500000000000012124403241017251 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/bigarray/libbigarraywin32.clib0000644000175000017500000000003612124403241023255 0ustar tootstootsbigarray_stubs.o mmap_win32.o mingw-ocaml/ocaml/otherlibs/bigarray/bigarray.mli0000644000175000017500000010650312124403241021561 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt *) (* *) (* Copyright 2000 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Large, multi-dimensional, numerical arrays. This module implements multi-dimensional arrays of integers and floating-point numbers, thereafter referred to as ``big arrays''. The implementation allows efficient sharing of large numerical arrays between OCaml code and C or Fortran numerical libraries. Concerning the naming conventions, users of this module are encouraged to do [open Bigarray] in their source, then refer to array types and operations via short dot notation, e.g. [Array1.t] or [Array2.sub]. Big arrays support all the OCaml ad-hoc polymorphic operations: - comparisons ([=], [<>], [<=], etc, as well as {!Pervasives.compare}); - hashing (module [Hash]); - and structured input-output (the functions from the {!Marshal} module, as well as {!Pervasives.output_value} and {!Pervasives.input_value}). *) (** {6 Element kinds} *) (** Big arrays can contain elements of the following kinds: - IEEE single precision (32 bits) floating-point numbers ({!Bigarray.float32_elt}), - IEEE double precision (64 bits) floating-point numbers ({!Bigarray.float64_elt}), - IEEE single precision (2 * 32 bits) floating-point complex numbers ({!Bigarray.complex32_elt}), - IEEE double precision (2 * 64 bits) floating-point complex numbers ({!Bigarray.complex64_elt}), - 8-bit integers (signed or unsigned) ({!Bigarray.int8_signed_elt} or {!Bigarray.int8_unsigned_elt}), - 16-bit integers (signed or unsigned) ({!Bigarray.int16_signed_elt} or {!Bigarray.int16_unsigned_elt}), - OCaml integers (signed, 31 bits on 32-bit architectures, 63 bits on 64-bit architectures) ({!Bigarray.int_elt}), - 32-bit signed integer ({!Bigarray.int32_elt}), - 64-bit signed integers ({!Bigarray.int64_elt}), - platform-native signed integers (32 bits on 32-bit architectures, 64 bits on 64-bit architectures) ({!Bigarray.nativeint_elt}). Each element kind is represented at the type level by one of the abstract types defined below. *) type float32_elt type float64_elt type complex32_elt type complex64_elt type int8_signed_elt type int8_unsigned_elt type int16_signed_elt type int16_unsigned_elt type int_elt type int32_elt type int64_elt type nativeint_elt type ('a, 'b) kind (** To each element kind is associated an OCaml type, which is the type of OCaml values that can be stored in the big array or read back from it. This type is not necessarily the same as the type of the array elements proper: for instance, a big array whose elements are of kind [float32_elt] contains 32-bit single precision floats, but reading or writing one of its elements from OCaml uses the OCaml type [float], which is 64-bit double precision floats. The abstract type [('a, 'b) kind] captures this association of an OCaml type ['a] for values read or written in the big array, and of an element kind ['b] which represents the actual contents of the big array. The following predefined values of type [kind] list all possible associations of OCaml types with element kinds: *) val float32 : (float, float32_elt) kind (** See {!Bigarray.char}. *) val float64 : (float, float64_elt) kind (** See {!Bigarray.char}. *) val complex32 : (Complex.t, complex32_elt) kind (** See {!Bigarray.char}. *) val complex64 : (Complex.t, complex64_elt) kind (** See {!Bigarray.char}. *) val int8_signed : (int, int8_signed_elt) kind (** See {!Bigarray.char}. *) val int8_unsigned : (int, int8_unsigned_elt) kind (** See {!Bigarray.char}. *) val int16_signed : (int, int16_signed_elt) kind (** See {!Bigarray.char}. *) val int16_unsigned : (int, int16_unsigned_elt) kind (** See {!Bigarray.char}. *) val int : (int, int_elt) kind (** See {!Bigarray.char}. *) val int32 : (int32, int32_elt) kind (** See {!Bigarray.char}. *) val int64 : (int64, int64_elt) kind (** See {!Bigarray.char}. *) val nativeint : (nativeint, nativeint_elt) kind (** See {!Bigarray.char}. *) val char : (char, int8_unsigned_elt) kind (** As shown by the types of the values above, big arrays of kind [float32_elt] and [float64_elt] are accessed using the OCaml type [float]. Big arrays of complex kinds [complex32_elt], [complex64_elt] are accessed with the OCaml type {!Complex.t}. Big arrays of integer kinds are accessed using the smallest OCaml integer type large enough to represent the array elements: [int] for 8- and 16-bit integer bigarrays, as well as OCaml-integer bigarrays; [int32] for 32-bit integer bigarrays; [int64] for 64-bit integer bigarrays; and [nativeint] for platform-native integer bigarrays. Finally, big arrays of kind [int8_unsigned_elt] can also be accessed as arrays of characters instead of arrays of small integers, by using the kind value [char] instead of [int8_unsigned]. *) (** {6 Array layouts} *) type c_layout (** See {!Bigarray.fortran_layout}.*) type fortran_layout (** To facilitate interoperability with existing C and Fortran code, this library supports two different memory layouts for big arrays, one compatible with the C conventions, the other compatible with the Fortran conventions. In the C-style layout, array indices start at 0, and multi-dimensional arrays are laid out in row-major format. That is, for a two-dimensional array, all elements of row 0 are contiguous in memory, followed by all elements of row 1, etc. In other terms, the array elements at [(x,y)] and [(x, y+1)] are adjacent in memory. In the Fortran-style layout, array indices start at 1, and multi-dimensional arrays are laid out in column-major format. That is, for a two-dimensional array, all elements of column 0 are contiguous in memory, followed by all elements of column 1, etc. In other terms, the array elements at [(x,y)] and [(x+1, y)] are adjacent in memory. Each layout style is identified at the type level by the abstract types {!Bigarray.c_layout} and [fortran_layout] respectively. *) type 'a layout (** The type ['a layout] represents one of the two supported memory layouts: C-style if ['a] is {!Bigarray.c_layout}, Fortran-style if ['a] is {!Bigarray.fortran_layout}. *) (** {7 Supported layouts} The abstract values [c_layout] and [fortran_layout] represent the two supported layouts at the level of values. *) val c_layout : c_layout layout val fortran_layout : fortran_layout layout (** {6 Generic arrays (of arbitrarily many dimensions)} *) module Genarray : sig type ('a, 'b, 'c) t (** The type [Genarray.t] is the type of big arrays with variable numbers of dimensions. Any number of dimensions between 1 and 16 is supported. The three type parameters to [Genarray.t] identify the array element kind and layout, as follows: - the first parameter, ['a], is the OCaml type for accessing array elements ([float], [int], [int32], [int64], [nativeint]); - the second parameter, ['b], is the actual kind of array elements ([float32_elt], [float64_elt], [int8_signed_elt], [int8_unsigned_elt], etc); - the third parameter, ['c], identifies the array layout ([c_layout] or [fortran_layout]). For instance, [(float, float32_elt, fortran_layout) Genarray.t] is the type of generic big arrays containing 32-bit floats in Fortran layout; reads and writes in this array use the OCaml type [float]. *) external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t = "caml_ba_create" (** [Genarray.create kind layout dimensions] returns a new big array whose element kind is determined by the parameter [kind] (one of [float32], [float64], [int8_signed], etc) and whose layout is determined by the parameter [layout] (one of [c_layout] or [fortran_layout]). The [dimensions] parameter is an array of integers that indicate the size of the big array in each dimension. The length of [dimensions] determines the number of dimensions of the bigarray. For instance, [Genarray.create int32 c_layout [|4;6;8|]] returns a fresh big array of 32-bit integers, in C layout, having three dimensions, the three dimensions being 4, 6 and 8 respectively. Big arrays returned by [Genarray.create] are not initialized: the initial values of array elements is unspecified. [Genarray.create] raises [Invalid_argument] if the number of dimensions is not in the range 1 to 16 inclusive, or if one of the dimensions is negative. *) external num_dims: ('a, 'b, 'c) t -> int = "caml_ba_num_dims" (** Return the number of dimensions of the given big array. *) val dims : ('a, 'b, 'c) t -> int array (** [Genarray.dims a] returns all dimensions of the big array [a], as an array of integers of length [Genarray.num_dims a]. *) external nth_dim: ('a, 'b, 'c) t -> int -> int = "caml_ba_dim" (** [Genarray.nth_dim a n] returns the [n]-th dimension of the big array [a]. The first dimension corresponds to [n = 0]; the second dimension corresponds to [n = 1]; the last dimension, to [n = Genarray.num_dims a - 1]. Raise [Invalid_argument] if [n] is less than 0 or greater or equal than [Genarray.num_dims a]. *) external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" (** Return the kind of the given big array. *) external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) external get: ('a, 'b, 'c) t -> int array -> 'a = "caml_ba_get_generic" (** Read an element of a generic big array. [Genarray.get a [|i1; ...; iN|]] returns the element of [a] whose coordinates are [i1] in the first dimension, [i2] in the second dimension, ..., [iN] in the [N]-th dimension. If [a] has C layout, the coordinates must be greater or equal than 0 and strictly less than the corresponding dimensions of [a]. If [a] has Fortran layout, the coordinates must be greater or equal than 1 and less or equal than the corresponding dimensions of [a]. Raise [Invalid_argument] if the array [a] does not have exactly [N] dimensions, or if the coordinates are outside the array bounds. If [N > 3], alternate syntax is provided: you can write [a.{i1, i2, ..., iN}] instead of [Genarray.get a [|i1; ...; iN|]]. (The syntax [a.{...}] with one, two or three coordinates is reserved for accessing one-, two- and three-dimensional arrays as described below.) *) external set: ('a, 'b, 'c) t -> int array -> 'a -> unit = "caml_ba_set_generic" (** Assign an element of a generic big array. [Genarray.set a [|i1; ...; iN|] v] stores the value [v] in the element of [a] whose coordinates are [i1] in the first dimension, [i2] in the second dimension, ..., [iN] in the [N]-th dimension. The array [a] must have exactly [N] dimensions, and all coordinates must lie inside the array bounds, as described for [Genarray.get]; otherwise, [Invalid_argument] is raised. If [N > 3], alternate syntax is provided: you can write [a.{i1, i2, ..., iN} <- v] instead of [Genarray.set a [|i1; ...; iN|] v]. (The syntax [a.{...} <- v] with one, two or three coordinates is reserved for updating one-, two- and three-dimensional arrays as described below.) *) external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" (** Extract a sub-array of the given big array by restricting the first (left-most) dimension. [Genarray.sub_left a ofs len] returns a big array with the same number of dimensions as [a], and the same dimensions as [a], except the first dimension, which corresponds to the interval [[ofs ... ofs + len - 1]] of the first dimension of [a]. No copying of elements is involved: the sub-array and the original array share the same storage space. In other terms, the element at coordinates [[|i1; ...; iN|]] of the sub-array is identical to the element at coordinates [[|i1+ofs; ...; iN|]] of the original array [a]. [Genarray.sub_left] applies only to big arrays in C layout. Raise [Invalid_argument] if [ofs] and [len] do not designate a valid sub-array of [a], that is, if [ofs < 0], or [len < 0], or [ofs + len > Genarray.nth_dim a 0]. *) external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "caml_ba_sub" (** Extract a sub-array of the given big array by restricting the last (right-most) dimension. [Genarray.sub_right a ofs len] returns a big array with the same number of dimensions as [a], and the same dimensions as [a], except the last dimension, which corresponds to the interval [[ofs ... ofs + len - 1]] of the last dimension of [a]. No copying of elements is involved: the sub-array and the original array share the same storage space. In other terms, the element at coordinates [[|i1; ...; iN|]] of the sub-array is identical to the element at coordinates [[|i1; ...; iN+ofs|]] of the original array [a]. [Genarray.sub_right] applies only to big arrays in Fortran layout. Raise [Invalid_argument] if [ofs] and [len] do not designate a valid sub-array of [a], that is, if [ofs < 1], or [len < 0], or [ofs + len > Genarray.nth_dim a (Genarray.num_dims a - 1)]. *) external slice_left: ('a, 'b, c_layout) t -> int array -> ('a, 'b, c_layout) t = "caml_ba_slice" (** Extract a sub-array of lower dimension from the given big array by fixing one or several of the first (left-most) coordinates. [Genarray.slice_left a [|i1; ... ; iM|]] returns the ``slice'' of [a] obtained by setting the first [M] coordinates to [i1], ..., [iM]. If [a] has [N] dimensions, the slice has dimension [N - M], and the element at coordinates [[|j1; ...; j(N-M)|]] in the slice is identical to the element at coordinates [[|i1; ...; iM; j1; ...; j(N-M)|]] in the original array [a]. No copying of elements is involved: the slice and the original array share the same storage space. [Genarray.slice_left] applies only to big arrays in C layout. Raise [Invalid_argument] if [M >= N], or if [[|i1; ... ; iM|]] is outside the bounds of [a]. *) external slice_right: ('a, 'b, fortran_layout) t -> int array -> ('a, 'b, fortran_layout) t = "caml_ba_slice" (** Extract a sub-array of lower dimension from the given big array by fixing one or several of the last (right-most) coordinates. [Genarray.slice_right a [|i1; ... ; iM|]] returns the ``slice'' of [a] obtained by setting the last [M] coordinates to [i1], ..., [iM]. If [a] has [N] dimensions, the slice has dimension [N - M], and the element at coordinates [[|j1; ...; j(N-M)|]] in the slice is identical to the element at coordinates [[|j1; ...; j(N-M); i1; ...; iM|]] in the original array [a]. No copying of elements is involved: the slice and the original array share the same storage space. [Genarray.slice_right] applies only to big arrays in Fortran layout. Raise [Invalid_argument] if [M >= N], or if [[|i1; ... ; iM|]] is outside the bounds of [a]. *) external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" (** Copy all elements of a big array in another big array. [Genarray.blit src dst] copies all elements of [src] into [dst]. Both arrays [src] and [dst] must have the same number of dimensions and equal dimensions. Copying a sub-array of [src] to a sub-array of [dst] can be achieved by applying [Genarray.blit] to sub-array or slices of [src] and [dst]. *) external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" (** Set all elements of a big array to a given value. [Genarray.fill a v] stores the value [v] in all elements of the big array [a]. Setting only some elements of [a] to [v] can be achieved by applying [Genarray.fill] to a sub-array or a slice of [a]. *) val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout -> bool -> int array -> ('a, 'b, 'c) t (** Memory mapping of a file as a big array. [Genarray.map_file fd kind layout shared dims] returns a big array of kind [kind], layout [layout], and dimensions as specified in [dims]. The data contained in this big array are the contents of the file referred to by the file descriptor [fd] (as opened previously with [Unix.openfile], for example). The optional [pos] parameter is the byte offset in the file of the data being mapped; it defaults to 0 (map from the beginning of the file). If [shared] is [true], all modifications performed on the array are reflected in the file. This requires that [fd] be opened with write permissions. If [shared] is [false], modifications performed on the array are done in memory only, using copy-on-write of the modified pages; the underlying file is not affected. [Genarray.map_file] is much more efficient than reading the whole file in a big array, modifying that big array, and writing it afterwards. To adjust automatically the dimensions of the big array to the actual size of the file, the major dimension (that is, the first dimension for an array with C layout, and the last dimension for an array with Fortran layout) can be given as [-1]. [Genarray.map_file] then determines the major dimension from the size of the file. The file must contain an integral number of sub-arrays as determined by the non-major dimensions, otherwise [Failure] is raised. If all dimensions of the big array are given, the file size is matched against the size of the big array. If the file is larger than the big array, only the initial portion of the file is mapped to the big array. If the file is smaller than the big array, the file is automatically grown to the size of the big array. This requires write permissions on [fd]. Array accesses are bounds-checked, but the bounds are determined by the initial call to [map_file]. Therefore, you should make sure no other process modifies the mapped file while you're accessing it, or a SIGBUS signal may be raised. This happens, for instance, if the file is shrinked. *) end (** {6 One-dimensional arrays} *) (** One-dimensional arrays. The [Array1] structure provides operations similar to those of {!Bigarray.Genarray}, but specialized to the case of one-dimensional arrays. (The [Array2] and [Array3] structures below provide operations specialized for two- and three-dimensional arrays.) Statically knowing the number of dimensions of the array allows faster operations, and more precise static type-checking. *) module Array1 : sig type ('a, 'b, 'c) t (** The type of one-dimensional big arrays whose elements have OCaml type ['a], representation kind ['b], and memory layout ['c]. *) val create: ('a, 'b) kind -> 'c layout -> int -> ('a, 'b, 'c) t (** [Array1.create kind layout dim] returns a new bigarray of one dimension, whose size is [dim]. [kind] and [layout] determine the array element kind and the array layout as described for [Genarray.create]. *) val dim: ('a, 'b, 'c) t -> int (** Return the size (dimension) of the given one-dimensional big array. *) external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" (** Return the kind of the given big array. *) external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1" (** [Array1.get a x], or alternatively [a.{x}], returns the element of [a] at index [x]. [x] must be greater or equal than [0] and strictly less than [Array1.dim a] if [a] has C layout. If [a] has Fortran layout, [x] must be greater or equal than [1] and less or equal than [Array1.dim a]. Otherwise, [Invalid_argument] is raised. *) external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1" (** [Array1.set a x v], also written [a.{x} <- v], stores the value [v] at index [x] in [a]. [x] must be inside the bounds of [a] as described in {!Bigarray.Array1.get}; otherwise, [Invalid_argument] is raised. *) external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "caml_ba_sub" (** Extract a sub-array of the given one-dimensional big array. See [Genarray.sub_left] for more details. *) external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" (** Copy the first big array to the second big array. See [Genarray.blit] for more details. *) external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" (** Fill the given big array with the given value. See [Genarray.fill] for more details. *) val of_array: ('a, 'b) kind -> 'c layout -> 'a array -> ('a, 'b, 'c) t (** Build a one-dimensional big array initialized from the given array. *) val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout -> bool -> int -> ('a, 'b, 'c) t (** Memory mapping of a file as a one-dimensional big array. See {!Bigarray.Genarray.map_file} for more details. *) external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1" (** Like {!Bigarray.Array1.get}, but bounds checking is not always performed. Use with caution and only when the program logic guarantees that the access is within bounds. *) external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_unsafe_set_1" (** Like {!Bigarray.Array1.set}, but bounds checking is not always performed. Use with caution and only when the program logic guarantees that the access is within bounds. *) end (** {6 Two-dimensional arrays} *) (** Two-dimensional arrays. The [Array2] structure provides operations similar to those of {!Bigarray.Genarray}, but specialized to the case of two-dimensional arrays. *) module Array2 : sig type ('a, 'b, 'c) t (** The type of two-dimensional big arrays whose elements have OCaml type ['a], representation kind ['b], and memory layout ['c]. *) val create: ('a, 'b) kind -> 'c layout -> int -> int -> ('a, 'b, 'c) t (** [Array2.create kind layout dim1 dim2] returns a new bigarray of two dimension, whose size is [dim1] in the first dimension and [dim2] in the second dimension. [kind] and [layout] determine the array element kind and the array layout as described for {!Bigarray.Genarray.create}. *) val dim1: ('a, 'b, 'c) t -> int (** Return the first dimension of the given two-dimensional big array. *) val dim2: ('a, 'b, 'c) t -> int (** Return the second dimension of the given two-dimensional big array. *) external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" (** Return the kind of the given big array. *) external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2" (** [Array2.get a x y], also written [a.{x,y}], returns the element of [a] at coordinates ([x], [y]). [x] and [y] must be within the bounds of [a], as described for {!Bigarray.Genarray.get}; otherwise, [Invalid_argument] is raised. *) external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_set_2" (** [Array2.set a x y v], or alternatively [a.{x,y} <- v], stores the value [v] at coordinates ([x], [y]) in [a]. [x] and [y] must be within the bounds of [a], as described for {!Bigarray.Genarray.set}; otherwise, [Invalid_argument] is raised. *) external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" (** Extract a two-dimensional sub-array of the given two-dimensional big array by restricting the first dimension. See {!Bigarray.Genarray.sub_left} for more details. [Array2.sub_left] applies only to arrays with C layout. *) external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "caml_ba_sub" (** Extract a two-dimensional sub-array of the given two-dimensional big array by restricting the second dimension. See {!Bigarray.Genarray.sub_right} for more details. [Array2.sub_right] applies only to arrays with Fortran layout. *) val slice_left: ('a, 'b, c_layout) t -> int -> ('a, 'b, c_layout) Array1.t (** Extract a row (one-dimensional slice) of the given two-dimensional big array. The integer parameter is the index of the row to extract. See {!Bigarray.Genarray.slice_left} for more details. [Array2.slice_left] applies only to arrays with C layout. *) val slice_right: ('a, 'b, fortran_layout) t -> int -> ('a, 'b, fortran_layout) Array1.t (** Extract a column (one-dimensional slice) of the given two-dimensional big array. The integer parameter is the index of the column to extract. See {!Bigarray.Genarray.slice_right} for more details. [Array2.slice_right] applies only to arrays with Fortran layout. *) external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" (** Copy the first big array to the second big array. See {!Bigarray.Genarray.blit} for more details. *) external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" (** Fill the given big array with the given value. See {!Bigarray.Genarray.fill} for more details. *) val of_array: ('a, 'b) kind -> 'c layout -> 'a array array -> ('a, 'b, 'c) t (** Build a two-dimensional big array initialized from the given array of arrays. *) val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout -> bool -> int -> int -> ('a, 'b, 'c) t (** Memory mapping of a file as a two-dimensional big array. See {!Bigarray.Genarray.map_file} for more details. *) external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_unsafe_ref_2" (** Like {!Bigarray.Array2.get}, but bounds checking is not always performed. *) external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_unsafe_set_2" (** Like {!Bigarray.Array2.set}, but bounds checking is not always performed. *) end (** {6 Three-dimensional arrays} *) (** Three-dimensional arrays. The [Array3] structure provides operations similar to those of {!Bigarray.Genarray}, but specialized to the case of three-dimensional arrays. *) module Array3 : sig type ('a, 'b, 'c) t (** The type of three-dimensional big arrays whose elements have OCaml type ['a], representation kind ['b], and memory layout ['c]. *) val create: ('a, 'b) kind -> 'c layout -> int -> int -> int -> ('a, 'b, 'c) t (** [Array3.create kind layout dim1 dim2 dim3] returns a new bigarray of three dimension, whose size is [dim1] in the first dimension, [dim2] in the second dimension, and [dim3] in the third. [kind] and [layout] determine the array element kind and the array layout as described for {!Bigarray.Genarray.create}. *) val dim1: ('a, 'b, 'c) t -> int (** Return the first dimension of the given three-dimensional big array. *) val dim2: ('a, 'b, 'c) t -> int (** Return the second dimension of the given three-dimensional big array. *) val dim3: ('a, 'b, 'c) t -> int (** Return the third dimension of the given three-dimensional big array. *) external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" (** Return the kind of the given big array. *) external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3" (** [Array3.get a x y z], also written [a.{x,y,z}], returns the element of [a] at coordinates ([x], [y], [z]). [x], [y] and [z] must be within the bounds of [a], as described for {!Bigarray.Genarray.get}; otherwise, [Invalid_argument] is raised. *) external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%caml_ba_set_3" (** [Array3.set a x y v], or alternatively [a.{x,y,z} <- v], stores the value [v] at coordinates ([x], [y], [z]) in [a]. [x], [y] and [z] must be within the bounds of [a], as described for {!Bigarray.Genarray.set}; otherwise, [Invalid_argument] is raised. *) external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" (** Extract a three-dimensional sub-array of the given three-dimensional big array by restricting the first dimension. See {!Bigarray.Genarray.sub_left} for more details. [Array3.sub_left] applies only to arrays with C layout. *) external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "caml_ba_sub" (** Extract a three-dimensional sub-array of the given three-dimensional big array by restricting the second dimension. See {!Bigarray.Genarray.sub_right} for more details. [Array3.sub_right] applies only to arrays with Fortran layout. *) val slice_left_1: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) Array1.t (** Extract a one-dimensional slice of the given three-dimensional big array by fixing the first two coordinates. The integer parameters are the coordinates of the slice to extract. See {!Bigarray.Genarray.slice_left} for more details. [Array3.slice_left_1] applies only to arrays with C layout. *) val slice_right_1: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) Array1.t (** Extract a one-dimensional slice of the given three-dimensional big array by fixing the last two coordinates. The integer parameters are the coordinates of the slice to extract. See {!Bigarray.Genarray.slice_right} for more details. [Array3.slice_right_1] applies only to arrays with Fortran layout. *) val slice_left_2: ('a, 'b, c_layout) t -> int -> ('a, 'b, c_layout) Array2.t (** Extract a two-dimensional slice of the given three-dimensional big array by fixing the first coordinate. The integer parameter is the first coordinate of the slice to extract. See {!Bigarray.Genarray.slice_left} for more details. [Array3.slice_left_2] applies only to arrays with C layout. *) val slice_right_2: ('a, 'b, fortran_layout) t -> int -> ('a, 'b, fortran_layout) Array2.t (** Extract a two-dimensional slice of the given three-dimensional big array by fixing the last coordinate. The integer parameter is the coordinate of the slice to extract. See {!Bigarray.Genarray.slice_right} for more details. [Array3.slice_right_2] applies only to arrays with Fortran layout. *) external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" (** Copy the first big array to the second big array. See {!Bigarray.Genarray.blit} for more details. *) external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" (** Fill the given big array with the given value. See {!Bigarray.Genarray.fill} for more details. *) val of_array: ('a, 'b) kind -> 'c layout -> 'a array array array -> ('a, 'b, 'c) t (** Build a three-dimensional big array initialized from the given array of arrays of arrays. *) val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout -> bool -> int -> int -> int -> ('a, 'b, 'c) t (** Memory mapping of a file as a three-dimensional big array. See {!Bigarray.Genarray.map_file} for more details. *) external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_unsafe_ref_3" (** Like {!Bigarray.Array3.get}, but bounds checking is not always performed. *) external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%caml_ba_unsafe_set_3" (** Like {!Bigarray.Array3.set}, but bounds checking is not always performed. *) end (** {6 Coercions between generic big arrays and fixed-dimension big arrays} *) external genarray_of_array1 : ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t = "%identity" (** Return the generic big array corresponding to the given one-dimensional big array. *) external genarray_of_array2 : ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t = "%identity" (** Return the generic big array corresponding to the given two-dimensional big array. *) external genarray_of_array3 : ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t = "%identity" (** Return the generic big array corresponding to the given three-dimensional big array. *) val array1_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array1.t (** Return the one-dimensional big array corresponding to the given generic big array. Raise [Invalid_argument] if the generic big array does not have exactly one dimension. *) val array2_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array2.t (** Return the two-dimensional big array corresponding to the given generic big array. Raise [Invalid_argument] if the generic big array does not have exactly two dimensions. *) val array3_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array3.t (** Return the three-dimensional big array corresponding to the given generic big array. Raise [Invalid_argument] if the generic big array does not have exactly three dimensions. *) (** {6 Re-shaping big arrays} *) val reshape : ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t (** [reshape b [|d1;...;dN|]] converts the big array [b] to a [N]-dimensional array of dimensions [d1]...[dN]. The returned array and the original array [b] share their data and have the same layout. For instance, assuming that [b] is a one-dimensional array of dimension 12, [reshape b [|3;4|]] returns a two-dimensional array [b'] of dimensions 3 and 4. If [b] has C layout, the element [(x,y)] of [b'] corresponds to the element [x * 3 + y] of [b]. If [b] has Fortran layout, the element [(x,y)] of [b'] corresponds to the element [x + (y - 1) * 4] of [b]. The returned big array must have exactly the same number of elements as the original big array [b]. That is, the product of the dimensions of [b] must be equal to [i1 * ... * iN]. Otherwise, [Invalid_argument] is raised. *) val reshape_1 : ('a, 'b, 'c) Genarray.t -> int -> ('a, 'b, 'c) Array1.t (** Specialized version of {!Bigarray.reshape} for reshaping to one-dimensional arrays. *) val reshape_2 : ('a, 'b, 'c) Genarray.t -> int -> int -> ('a, 'b, 'c) Array2.t (** Specialized version of {!Bigarray.reshape} for reshaping to two-dimensional arrays. *) val reshape_3 : ('a, 'b, 'c) Genarray.t -> int -> int -> int -> ('a, 'b, 'c) Array3.t (** Specialized version of {!Bigarray.reshape} for reshaping to three-dimensional arrays. *) mingw-ocaml/ocaml/otherlibs/bigarray/Makefile0000644000175000017500000000231212124403241020707 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ LIBNAME=bigarray EXTRACFLAGS=-I../unix -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE EXTRACAMLFLAGS=-I ../unix COBJS=bigarray_stubs.$(O) mmap_unix.$(O) CAMLOBJS=bigarray.cmo HEADERS=bigarray.h include ../Makefile depend: gcc -MM $(CFLAGS) *.c > .depend ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend include .depend mingw-ocaml/ocaml/otherlibs/bigarray/bigarray.ml0000644000175000017500000002350012124403241021403 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Manuel Serrano et Xavier Leroy, INRIA Rocquencourt *) (* *) (* Copyright 2000 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [Bigarray]: large, multi-dimensional, numerical arrays *) external init : unit -> unit = "caml_ba_init" let _ = init() type ('a, 'b) kind = int type int8_signed_elt type int8_unsigned_elt type int16_signed_elt type int16_unsigned_elt type int_elt type int32_elt type int64_elt type nativeint_elt type float32_elt type float64_elt type complex32_elt type complex64_elt (* Keep those constants in sync with the caml_ba_kind enumeration in bigarray.h *) let float32 = 0 let float64 = 1 let int8_signed = 2 let int8_unsigned = 3 let int16_signed = 4 let int16_unsigned = 5 let int32 = 6 let int64 = 7 let int = 8 let nativeint = 9 let char = int8_unsigned let complex32 = 10 let complex64 = 11 type 'a layout = int type c_layout type fortran_layout (* Keep those constants in sync with the caml_ba_layout enumeration in bigarray.h *) let c_layout = 0 let fortran_layout = 0x100 module Genarray = struct type ('a, 'b, 'c) t external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t = "caml_ba_create" external get: ('a, 'b, 'c) t -> int array -> 'a = "caml_ba_get_generic" external set: ('a, 'b, 'c) t -> int array -> 'a -> unit = "caml_ba_set_generic" external num_dims: ('a, 'b, 'c) t -> int = "caml_ba_num_dims" external nth_dim: ('a, 'b, 'c) t -> int -> int = "caml_ba_dim" let dims a = let n = num_dims a in let d = Array.make n 0 in for i = 0 to n-1 do d.(i) <- nth_dim a i done; d external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "caml_ba_sub" external slice_left: ('a, 'b, c_layout) t -> int array -> ('a, 'b, c_layout) t = "caml_ba_slice" external slice_right: ('a, 'b, fortran_layout) t -> int array -> ('a, 'b, fortran_layout) t = "caml_ba_slice" external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" external map_internal: Unix.file_descr -> ('a, 'b) kind -> 'c layout -> bool -> int array -> int64 -> ('a, 'b, 'c) t = "caml_ba_map_file_bytecode" "caml_ba_map_file" let map_file fd ?(pos = 0L) kind layout shared dims = map_internal fd kind layout shared dims pos end module Array1 = struct type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t let create kind layout dim = Genarray.create kind layout [|dim|] external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1" external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1" external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1" external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_unsafe_set_1" let dim a = Genarray.nth_dim a 0 external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "caml_ba_sub" external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" let of_array kind layout data = let ba = create kind layout (Array.length data) in let ofs = if layout = c_layout then 0 else 1 in for i = 0 to Array.length data - 1 do unsafe_set ba (i + ofs) data.(i) done; ba let map_file fd ?pos kind layout shared dim = Genarray.map_file fd ?pos kind layout shared [|dim|] end module Array2 = struct type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t let create kind layout dim1 dim2 = Genarray.create kind layout [|dim1; dim2|] external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2" external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_set_2" external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_unsafe_ref_2" external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_unsafe_set_2" let dim1 a = Genarray.nth_dim a 0 let dim2 a = Genarray.nth_dim a 1 external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "caml_ba_sub" let slice_left a n = Genarray.slice_left a [|n|] let slice_right a n = Genarray.slice_right a [|n|] external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" let of_array kind layout data = let dim1 = Array.length data in let dim2 = if dim1 = 0 then 0 else Array.length data.(0) in let ba = create kind layout dim1 dim2 in let ofs = if layout = c_layout then 0 else 1 in for i = 0 to dim1 - 1 do let row = data.(i) in if Array.length row <> dim2 then invalid_arg("Bigarray.Array2.of_array: non-rectangular data"); for j = 0 to dim2 - 1 do unsafe_set ba (i + ofs) (j + ofs) row.(j) done done; ba let map_file fd ?pos kind layout shared dim1 dim2 = Genarray.map_file fd ?pos kind layout shared [|dim1;dim2|] end module Array3 = struct type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t let create kind layout dim1 dim2 dim3 = Genarray.create kind layout [|dim1; dim2; dim3|] external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3" external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%caml_ba_set_3" external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_unsafe_ref_3" external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%caml_ba_unsafe_set_3" let dim1 a = Genarray.nth_dim a 0 let dim2 a = Genarray.nth_dim a 1 let dim3 a = Genarray.nth_dim a 2 external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "caml_ba_sub" let slice_left_1 a n m = Genarray.slice_left a [|n; m|] let slice_right_1 a n m = Genarray.slice_right a [|n; m|] let slice_left_2 a n = Genarray.slice_left a [|n|] let slice_right_2 a n = Genarray.slice_right a [|n|] external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" let of_array kind layout data = let dim1 = Array.length data in let dim2 = if dim1 = 0 then 0 else Array.length data.(0) in let dim3 = if dim2 = 0 then 0 else Array.length data.(0).(0) in let ba = create kind layout dim1 dim2 dim3 in let ofs = if layout = c_layout then 0 else 1 in for i = 0 to dim1 - 1 do let row = data.(i) in if Array.length row <> dim2 then invalid_arg("Bigarray.Array3.of_array: non-cubic data"); for j = 0 to dim2 - 1 do let col = row.(j) in if Array.length col <> dim3 then invalid_arg("Bigarray.Array3.of_array: non-cubic data"); for k = 0 to dim3 - 1 do unsafe_set ba (i + ofs) (j + ofs) (k + ofs) col.(k) done done done; ba let map_file fd ?pos kind layout shared dim1 dim2 dim3 = Genarray.map_file fd ?pos kind layout shared [|dim1;dim2;dim3|] end external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t = "%identity" external genarray_of_array2: ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t = "%identity" external genarray_of_array3: ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t = "%identity" let array1_of_genarray a = if Genarray.num_dims a = 1 then a else invalid_arg "Bigarray.array1_of_genarray" let array2_of_genarray a = if Genarray.num_dims a = 2 then a else invalid_arg "Bigarray.array2_of_genarray" let array3_of_genarray a = if Genarray.num_dims a = 3 then a else invalid_arg "Bigarray.array3_of_genarray" external reshape: ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t = "caml_ba_reshape" let reshape_1 a dim1 = reshape a [|dim1|] let reshape_2 a dim1 dim2 = reshape a [|dim1;dim2|] let reshape_3 a dim1 dim2 dim3 = reshape a [|dim1;dim2;dim3|] (* Force caml_ba_get_{1,2,3,N} to be linked in, since we don't refer to those primitives directly in this file *) let _ = let _ = Genarray.get in let _ = Array1.get in let _ = Array2.get in let _ = Array3.get in () external get1: unit -> unit = "caml_ba_get_1" external get2: unit -> unit = "caml_ba_get_2" external get3: unit -> unit = "caml_ba_get_3" external set1: unit -> unit = "caml_ba_set_1" external set2: unit -> unit = "caml_ba_set_2" external set3: unit -> unit = "caml_ba_set_3" mingw-ocaml/ocaml/otherlibs/bigarray/Makefile.nt0000644000175000017500000000233012124403241021327 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ LIBNAME=bigarray EXTRACFLAGS=-I../win32unix -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE EXTRACAMLFLAGS=-I ../win32unix COBJS=bigarray_stubs.$(O) mmap_win32.$(O) CAMLOBJS=bigarray.cmo HEADERS=bigarray.h include ../Makefile.nt depend: gcc -MM $(CFLAGS) *.c > .depend ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend include .depend mingw-ocaml/ocaml/otherlibs/bigarray/mmap_win32.c0000644000175000017500000001256712124403241021404 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ /* */ /* Copyright 2000 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "bigarray.h" #include "alloc.h" #include "custom.h" #include "fail.h" #include "mlvalues.h" #include "sys.h" #include "unixsupport.h" extern int caml_ba_element_size[]; /* from bigarray_stubs.c */ static void caml_ba_sys_error(void); #ifndef INVALID_SET_FILE_POINTER #define INVALID_SET_FILE_POINTER (-1) #endif static __int64 caml_ba_set_file_pointer(HANDLE h, __int64 dist, DWORD mode) { LARGE_INTEGER i; DWORD err; i.QuadPart = dist; i.LowPart = SetFilePointer(h, i.LowPart, &i.HighPart, mode); if (i.LowPart == INVALID_SET_FILE_POINTER) return -1; return i.QuadPart; } CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, value vshared, value vdim, value vstart) { HANDLE fd, fmap; int flags, major_dim, mode, perm; intnat num_dims, i; intnat dim[CAML_BA_MAX_NUM_DIMS]; __int64 currpos, startpos, file_size, data_size; uintnat array_size, page, delta; char c; void * addr; LARGE_INTEGER li; SYSTEM_INFO sysinfo; fd = Handle_val(vfd); flags = Int_val(vkind) | Int_val(vlayout); startpos = Int64_val(vstart); num_dims = Wosize_val(vdim); major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0; /* Extract dimensions from OCaml array */ num_dims = Wosize_val(vdim); if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS) caml_invalid_argument("Bigarray.mmap: bad number of dimensions"); for (i = 0; i < num_dims; i++) { dim[i] = Long_val(Field(vdim, i)); if (dim[i] == -1 && i == major_dim) continue; if (dim[i] < 0) caml_invalid_argument("Bigarray.create: negative dimension"); } /* Determine file size */ currpos = caml_ba_set_file_pointer(fd, 0, FILE_CURRENT); if (currpos == -1) caml_ba_sys_error(); file_size = caml_ba_set_file_pointer(fd, 0, FILE_END); if (file_size == -1) caml_ba_sys_error(); /* Determine array size in bytes (or size of array without the major dimension if that dimension wasn't specified) */ array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK]; for (i = 0; i < num_dims; i++) if (dim[i] != -1) array_size *= dim[i]; /* Check if the first/last dimension is unknown */ if (dim[major_dim] == -1) { /* Determine first/last dimension from file size */ if (file_size < startpos) caml_failwith("Bigarray.mmap: file position exceeds file size"); data_size = file_size - startpos; dim[major_dim] = (uintnat) (data_size / array_size); array_size = dim[major_dim] * array_size; if (array_size != data_size) caml_failwith("Bigarray.mmap: file size doesn't match array dimensions"); } /* Restore original file position */ caml_ba_set_file_pointer(fd, currpos, FILE_BEGIN); /* Create the file mapping */ if (Bool_val(vshared)) { perm = PAGE_READWRITE; mode = FILE_MAP_WRITE; } else { perm = PAGE_READONLY; /* doesn't work under Win98 */ mode = FILE_MAP_COPY; } li.QuadPart = startpos + array_size; fmap = CreateFileMapping(fd, NULL, perm, li.HighPart, li.LowPart, NULL); if (fmap == NULL) caml_ba_sys_error(); /* Determine offset so that the mapping starts at the given file pos */ GetSystemInfo(&sysinfo); delta = (uintnat) (startpos % sysinfo.dwAllocationGranularity); /* Map the mapping in memory */ li.QuadPart = startpos - delta; addr = MapViewOfFile(fmap, mode, li.HighPart, li.LowPart, array_size + delta); if (addr == NULL) caml_ba_sys_error(); addr = (void *) ((uintnat) addr + delta); /* Close the file mapping */ CloseHandle(fmap); /* Build and return the OCaml bigarray */ return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim); } CAMLprim value caml_ba_map_file_bytecode(value * argv, int argn) { return caml_ba_map_file(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } void caml_ba_unmap_file(void * addr, uintnat len) { SYSTEM_INFO sysinfo; uintnat delta; GetSystemInfo(&sysinfo); delta = (uintnat) addr % sysinfo.dwAllocationGranularity; UnmapViewOfFile((void *)((uintnat)addr - delta)); } static void caml_ba_sys_error(void) { char buffer[512]; DWORD errnum; errnum = GetLastError(); if (!FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS, NULL, errnum, 0, buffer, sizeof(buffer), NULL)) sprintf(buffer, "Unknown error %ld\n", errnum); caml_raise_sys_error(caml_copy_string(buffer)); } mingw-ocaml/ocaml/otherlibs/bigarray/bigarray_stubs.c0000644000175000017500000010227512124403241022444 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ /* */ /* Copyright 2000 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "alloc.h" #include "bigarray.h" #include "custom.h" #include "fail.h" #include "intext.h" #include "hash.h" #include "memory.h" #include "mlvalues.h" #define int8 caml_ba_int8 #define uint8 caml_ba_uint8 #define int16 caml_ba_int16 #define uint16 caml_ba_uint16 extern void caml_ba_unmap_file(void * addr, uintnat len); /* from mmap_xxx.c */ /* Compute the number of elements of a big array */ static uintnat caml_ba_num_elts(struct caml_ba_array * b) { uintnat num_elts; int i; num_elts = 1; for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i]; return num_elts; } /* Size in bytes of a bigarray element, indexed by bigarray kind */ int caml_ba_element_size[] = { 4 /*FLOAT32*/, 8 /*FLOAT64*/, 1 /*SINT8*/, 1 /*UINT8*/, 2 /*SINT16*/, 2 /*UINT16*/, 4 /*INT32*/, 8 /*INT64*/, sizeof(value) /*CAML_INT*/, sizeof(value) /*NATIVE_INT*/, 8 /*COMPLEX32*/, 16 /*COMPLEX64*/ }; /* Compute the number of bytes for the elements of a big array */ CAMLexport uintnat caml_ba_byte_size(struct caml_ba_array * b) { return caml_ba_num_elts(b) * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK]; } /* Operation table for bigarrays */ static void caml_ba_finalize(value v); static int caml_ba_compare(value v1, value v2); static intnat caml_ba_hash(value v); static void caml_ba_serialize(value, uintnat *, uintnat *); uintnat caml_ba_deserialize(void * dst); static struct custom_operations caml_ba_ops = { "_bigarray", caml_ba_finalize, caml_ba_compare, caml_ba_hash, caml_ba_serialize, caml_ba_deserialize, custom_compare_ext_default }; /* Multiplication of unsigned longs with overflow detection */ static uintnat caml_ba_multov(uintnat a, uintnat b, int * overflow) { #define HALF_SIZE (sizeof(uintnat) * 4) #define HALF_MASK (((uintnat)1 << HALF_SIZE) - 1) #define LOW_HALF(x) ((x) & HALF_MASK) #define HIGH_HALF(x) ((x) >> HALF_SIZE) /* Cut in half words */ uintnat al = LOW_HALF(a); uintnat ah = HIGH_HALF(a); uintnat bl = LOW_HALF(b); uintnat bh = HIGH_HALF(b); /* Exact product is: al * bl + ah * bl << HALF_SIZE + al * bh << HALF_SIZE + ah * bh << 2*HALF_SIZE Overflow occurs if: ah * bh is not 0, i.e. ah != 0 and bh != 0 OR ah * bl has high half != 0 OR ah * bl has high half != 0 OR the sum al * bl + LOW_HALF(ah * bl) << HALF_SIZE + LOW_HALF(al * bh) << HALF_SIZE overflows. This sum is equal to p = (a * b) modulo word size. */ uintnat p1 = al * bh; uintnat p2 = ah * bl; uintnat p = a * b; if (ah != 0 && bh != 0) *overflow = 1; if (HIGH_HALF(p1) != 0 || HIGH_HALF(p2) != 0) *overflow = 1; p1 <<= HALF_SIZE; p2 <<= HALF_SIZE; p1 += p2; if (p < p1 || p1 < p2) *overflow = 1; /* overflow in sums */ return p; #undef HALF_SIZE #undef LOW_HALF #undef HIGH_HALF } /* Allocation of a big array */ #define CAML_BA_MAX_MEMORY 1024*1024*1024 /* 1 Gb -- after allocating that much, it's probably worth speeding up the major GC */ /* [caml_ba_alloc] will allocate a new bigarray object in the heap. If [data] is NULL, the memory for the contents is also allocated (with [malloc]) by [caml_ba_alloc]. [data] cannot point into the OCaml heap. [dim] may point into an object in the OCaml heap. */ CAMLexport value caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim) { uintnat num_elts, asize, size; int overflow, i; value res; struct caml_ba_array * b; intnat dimcopy[CAML_BA_MAX_NUM_DIMS]; Assert(num_dims >= 1 && num_dims <= CAML_BA_MAX_NUM_DIMS); Assert((flags & CAML_BA_KIND_MASK) <= CAML_BA_COMPLEX64); for (i = 0; i < num_dims; i++) dimcopy[i] = dim[i]; size = 0; if (data == NULL) { overflow = 0; num_elts = 1; for (i = 0; i < num_dims; i++) { num_elts = caml_ba_multov(num_elts, dimcopy[i], &overflow); } size = caml_ba_multov(num_elts, caml_ba_element_size[flags & CAML_BA_KIND_MASK], &overflow); if (overflow) caml_raise_out_of_memory(); data = malloc(size); if (data == NULL && size != 0) caml_raise_out_of_memory(); flags |= CAML_BA_MANAGED; } /* PR#5516: use C99's flexible array types if possible */ #if (__STDC_VERSION__ >= 199901L) asize = sizeof(struct caml_ba_array) + num_dims * sizeof(intnat); #else asize = sizeof(struct caml_ba_array) + (num_dims - 1) * sizeof(intnat); #endif res = caml_alloc_custom(&caml_ba_ops, asize, size, CAML_BA_MAX_MEMORY); b = Caml_ba_array_val(res); b->data = data; b->num_dims = num_dims; b->flags = flags; b->proxy = NULL; for (i = 0; i < num_dims; i++) b->dim[i] = dimcopy[i]; return res; } /* Same as caml_ba_alloc, but dimensions are passed as a list of arguments */ CAMLexport value caml_ba_alloc_dims(int flags, int num_dims, void * data, ...) { va_list ap; intnat dim[CAML_BA_MAX_NUM_DIMS]; int i; value res; Assert(num_dims <= CAML_BA_MAX_NUM_DIMS); va_start(ap, data); for (i = 0; i < num_dims; i++) dim[i] = va_arg(ap, intnat); va_end(ap); res = caml_ba_alloc(flags, num_dims, data, dim); return res; } /* Allocate a bigarray from OCaml */ CAMLprim value caml_ba_create(value vkind, value vlayout, value vdim) { intnat dim[CAML_BA_MAX_NUM_DIMS]; mlsize_t num_dims; int i, flags; num_dims = Wosize_val(vdim); if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS) caml_invalid_argument("Bigarray.create: bad number of dimensions"); for (i = 0; i < num_dims; i++) { dim[i] = Long_val(Field(vdim, i)); if (dim[i] < 0) caml_invalid_argument("Bigarray.create: negative dimension"); } flags = Int_val(vkind) | Int_val(vlayout); return caml_ba_alloc(flags, num_dims, NULL, dim); } /* Given a big array and a vector of indices, check that the indices are within the bounds and return the offset of the corresponding array element in the data part of the array. */ static long caml_ba_offset(struct caml_ba_array * b, intnat * index) { intnat offset; int i; offset = 0; if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) { /* C-style layout: row major, indices start at 0 */ for (i = 0; i < b->num_dims; i++) { if ((uintnat) index[i] >= (uintnat) b->dim[i]) caml_array_bound_error(); offset = offset * b->dim[i] + index[i]; } } else { /* Fortran-style layout: column major, indices start at 1 */ for (i = b->num_dims - 1; i >= 0; i--) { if ((uintnat) (index[i] - 1) >= (uintnat) b->dim[i]) caml_array_bound_error(); offset = offset * b->dim[i] + (index[i] - 1); } } return offset; } /* Helper function to allocate a record of two double floats */ static value copy_two_doubles(double d0, double d1) { value res = caml_alloc_small(2 * Double_wosize, Double_array_tag); Store_double_field(res, 0, d0); Store_double_field(res, 1, d1); return res; } /* Generic code to read from a big array */ value caml_ba_get_N(value vb, value * vind, int nind) { struct caml_ba_array * b = Caml_ba_array_val(vb); intnat index[CAML_BA_MAX_NUM_DIMS]; int i; intnat offset; /* Check number of indices = number of dimensions of array (maybe not necessary if ML typing guarantees this) */ if (nind != b->num_dims) caml_invalid_argument("Bigarray.get: wrong number of indices"); /* Compute offset and check bounds */ for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]); offset = caml_ba_offset(b, index); /* Perform read */ switch ((b->flags) & CAML_BA_KIND_MASK) { default: Assert(0); case CAML_BA_FLOAT32: return caml_copy_double(((float *) b->data)[offset]); case CAML_BA_FLOAT64: return caml_copy_double(((double *) b->data)[offset]); case CAML_BA_SINT8: return Val_int(((int8 *) b->data)[offset]); case CAML_BA_UINT8: return Val_int(((uint8 *) b->data)[offset]); case CAML_BA_SINT16: return Val_int(((int16 *) b->data)[offset]); case CAML_BA_UINT16: return Val_int(((uint16 *) b->data)[offset]); case CAML_BA_INT32: return caml_copy_int32(((int32 *) b->data)[offset]); case CAML_BA_INT64: return caml_copy_int64(((int64 *) b->data)[offset]); case CAML_BA_NATIVE_INT: return caml_copy_nativeint(((intnat *) b->data)[offset]); case CAML_BA_CAML_INT: return Val_long(((intnat *) b->data)[offset]); case CAML_BA_COMPLEX32: { float * p = ((float *) b->data) + offset * 2; return copy_two_doubles(p[0], p[1]); } case CAML_BA_COMPLEX64: { double * p = ((double *) b->data) + offset * 2; return copy_two_doubles(p[0], p[1]); } } } CAMLprim value caml_ba_get_1(value vb, value vind1) { return caml_ba_get_N(vb, &vind1, 1); } CAMLprim value caml_ba_get_2(value vb, value vind1, value vind2) { value vind[2]; vind[0] = vind1; vind[1] = vind2; return caml_ba_get_N(vb, vind, 2); } CAMLprim value caml_ba_get_3(value vb, value vind1, value vind2, value vind3) { value vind[3]; vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; return caml_ba_get_N(vb, vind, 3); } #if 0 CAMLprim value caml_ba_get_4(value vb, value vind1, value vind2, value vind3, value vind4) { value vind[4]; vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4; return caml_ba_get_N(vb, vind, 4); } CAMLprim value caml_ba_get_5(value vb, value vind1, value vind2, value vind3, value vind4, value vind5) { value vind[5]; vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4; vind[4] = vind5; return caml_ba_get_N(vb, vind, 5); } CAMLprim value caml_ba_get_6(value vb, value vind1, value vind2, value vind3, value vind4, value vind5, value vind6) { value vind[6]; vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4; vind[4] = vind5; vind[5] = vind6; return caml_ba_get_N(vb, vind, 6); } #endif CAMLprim value caml_ba_get_generic(value vb, value vind) { return caml_ba_get_N(vb, &Field(vind, 0), Wosize_val(vind)); } /* Generic write to a big array */ static value caml_ba_set_aux(value vb, value * vind, intnat nind, value newval) { struct caml_ba_array * b = Caml_ba_array_val(vb); intnat index[CAML_BA_MAX_NUM_DIMS]; int i; intnat offset; /* Check number of indices = number of dimensions of array (maybe not necessary if ML typing guarantees this) */ if (nind != b->num_dims) caml_invalid_argument("Bigarray.set: wrong number of indices"); /* Compute offset and check bounds */ for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]); offset = caml_ba_offset(b, index); /* Perform write */ switch (b->flags & CAML_BA_KIND_MASK) { default: Assert(0); case CAML_BA_FLOAT32: ((float *) b->data)[offset] = Double_val(newval); break; case CAML_BA_FLOAT64: ((double *) b->data)[offset] = Double_val(newval); break; case CAML_BA_SINT8: case CAML_BA_UINT8: ((int8 *) b->data)[offset] = Int_val(newval); break; case CAML_BA_SINT16: case CAML_BA_UINT16: ((int16 *) b->data)[offset] = Int_val(newval); break; case CAML_BA_INT32: ((int32 *) b->data)[offset] = Int32_val(newval); break; case CAML_BA_INT64: ((int64 *) b->data)[offset] = Int64_val(newval); break; case CAML_BA_NATIVE_INT: ((intnat *) b->data)[offset] = Nativeint_val(newval); break; case CAML_BA_CAML_INT: ((intnat *) b->data)[offset] = Long_val(newval); break; case CAML_BA_COMPLEX32: { float * p = ((float *) b->data) + offset * 2; p[0] = Double_field(newval, 0); p[1] = Double_field(newval, 1); break; } case CAML_BA_COMPLEX64: { double * p = ((double *) b->data) + offset * 2; p[0] = Double_field(newval, 0); p[1] = Double_field(newval, 1); break; } } return Val_unit; } CAMLprim value caml_ba_set_1(value vb, value vind1, value newval) { return caml_ba_set_aux(vb, &vind1, 1, newval); } CAMLprim value caml_ba_set_2(value vb, value vind1, value vind2, value newval) { value vind[2]; vind[0] = vind1; vind[1] = vind2; return caml_ba_set_aux(vb, vind, 2, newval); } CAMLprim value caml_ba_set_3(value vb, value vind1, value vind2, value vind3, value newval) { value vind[3]; vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; return caml_ba_set_aux(vb, vind, 3, newval); } #if 0 CAMLprim value caml_ba_set_4(value vb, value vind1, value vind2, value vind3, value vind4, value newval) { value vind[4]; vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4; return caml_ba_set_aux(vb, vind, 4, newval); } CAMLprim value caml_ba_set_5(value vb, value vind1, value vind2, value vind3, value vind4, value vind5, value newval) { value vind[5]; vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4; vind[4] = vind5; return caml_ba_set_aux(vb, vind, 5, newval); } CAMLprim value caml_ba_set_6(value vb, value vind1, value vind2, value vind3, value vind4, value vind5, value vind6, value newval) { value vind[6]; vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4; vind[4] = vind5; vind[5] = vind6; return caml_ba_set_aux(vb, vind, 6, newval); } value caml_ba_set_N(value vb, value * vind, int nargs) { return caml_ba_set_aux(vb, vind, nargs - 1, vind[nargs - 1]); } #endif CAMLprim value caml_ba_set_generic(value vb, value vind, value newval) { return caml_ba_set_aux(vb, &Field(vind, 0), Wosize_val(vind), newval); } /* Return the number of dimensions of a big array */ CAMLprim value caml_ba_num_dims(value vb) { struct caml_ba_array * b = Caml_ba_array_val(vb); return Val_long(b->num_dims); } /* Return the n-th dimension of a big array */ CAMLprim value caml_ba_dim(value vb, value vn) { struct caml_ba_array * b = Caml_ba_array_val(vb); intnat n = Long_val(vn); if (n >= b->num_dims) caml_invalid_argument("Bigarray.dim"); return Val_long(b->dim[n]); } /* Return the kind of a big array */ CAMLprim value caml_ba_kind(value vb) { return Val_int(Caml_ba_array_val(vb)->flags & CAML_BA_KIND_MASK); } /* Return the layout of a big array */ CAMLprim value caml_ba_layout(value vb) { return Val_int(Caml_ba_array_val(vb)->flags & CAML_BA_LAYOUT_MASK); } /* Finalization of a big array */ static void caml_ba_finalize(value v) { struct caml_ba_array * b = Caml_ba_array_val(v); switch (b->flags & CAML_BA_MANAGED_MASK) { case CAML_BA_EXTERNAL: break; case CAML_BA_MANAGED: if (b->proxy == NULL) { free(b->data); } else { if (-- b->proxy->refcount == 0) { free(b->proxy->data); caml_stat_free(b->proxy); } } break; case CAML_BA_MAPPED_FILE: if (b->proxy == NULL) { caml_ba_unmap_file(b->data, caml_ba_byte_size(b)); } else { if (-- b->proxy->refcount == 0) { caml_ba_unmap_file(b->proxy->data, b->proxy->size); caml_stat_free(b->proxy); } } break; } } /* Comparison of two big arrays */ static int caml_ba_compare(value v1, value v2) { struct caml_ba_array * b1 = Caml_ba_array_val(v1); struct caml_ba_array * b2 = Caml_ba_array_val(v2); uintnat n, num_elts; intnat flags1, flags2; int i; /* Compare kind & layout in case the arguments are of different types */ flags1 = b1->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK); flags2 = b2->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK); if (flags1 != flags2) return flags2 - flags1; /* Compare number of dimensions */ if (b1->num_dims != b2->num_dims) return b2->num_dims - b1->num_dims; /* Same number of dimensions: compare dimensions lexicographically */ for (i = 0; i < b1->num_dims; i++) { intnat d1 = b1->dim[i]; intnat d2 = b2->dim[i]; if (d1 != d2) return d1 < d2 ? -1 : 1; } /* Same dimensions: compare contents lexicographically */ num_elts = caml_ba_num_elts(b1); #define DO_INTEGER_COMPARISON(type) \ { type * p1 = b1->data; type * p2 = b2->data; \ for (n = 0; n < num_elts; n++) { \ type e1 = *p1++; type e2 = *p2++; \ if (e1 < e2) return -1; \ if (e1 > e2) return 1; \ } \ return 0; \ } #define DO_FLOAT_COMPARISON(type) \ { type * p1 = b1->data; type * p2 = b2->data; \ for (n = 0; n < num_elts; n++) { \ type e1 = *p1++; type e2 = *p2++; \ if (e1 < e2) return -1; \ if (e1 > e2) return 1; \ if (e1 != e2) { \ caml_compare_unordered = 1; \ if (e1 == e1) return 1; \ if (e2 == e2) return -1; \ } \ } \ return 0; \ } switch (b1->flags & CAML_BA_KIND_MASK) { case CAML_BA_COMPLEX32: num_elts *= 2; /*fallthrough*/ case CAML_BA_FLOAT32: DO_FLOAT_COMPARISON(float); case CAML_BA_COMPLEX64: num_elts *= 2; /*fallthrough*/ case CAML_BA_FLOAT64: DO_FLOAT_COMPARISON(double); case CAML_BA_SINT8: DO_INTEGER_COMPARISON(int8); case CAML_BA_UINT8: DO_INTEGER_COMPARISON(uint8); case CAML_BA_SINT16: DO_INTEGER_COMPARISON(int16); case CAML_BA_UINT16: DO_INTEGER_COMPARISON(uint16); case CAML_BA_INT32: DO_INTEGER_COMPARISON(int32); case CAML_BA_INT64: #ifdef ARCH_INT64_TYPE DO_INTEGER_COMPARISON(int64); #else { int64 * p1 = b1->data; int64 * p2 = b2->data; for (n = 0; n < num_elts; n++) { int64 e1 = *p1++; int64 e2 = *p2++; if ((int32)e1.h > (int32)e2.h) return 1; if ((int32)e1.h < (int32)e2.h) return -1; if (e1.l > e2.l) return 1; if (e1.l < e2.l) return -1; } return 0; } #endif case CAML_BA_CAML_INT: case CAML_BA_NATIVE_INT: DO_INTEGER_COMPARISON(intnat); default: Assert(0); return 0; /* should not happen */ } #undef DO_INTEGER_COMPARISON #undef DO_FLOAT_COMPARISON } /* Hashing of a bigarray */ static intnat caml_ba_hash(value v) { struct caml_ba_array * b = Caml_ba_array_val(v); intnat num_elts, n; uint32 h, w; int i; num_elts = 1; for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i]; h = 0; switch (b->flags & CAML_BA_KIND_MASK) { case CAML_BA_SINT8: case CAML_BA_UINT8: { uint8 * p = b->data; if (num_elts > 256) num_elts = 256; for (n = 0; n + 4 <= num_elts; n += 4, p += 4) { w = p[0] | (p[1] << 8) | (p[2] << 16) | (p[3] << 24); h = caml_hash_mix_uint32(h, w); } w = 0; switch (num_elts & 3) { case 3: w = p[2] << 16; /* fallthrough */ case 2: w |= p[1] << 8; /* fallthrough */ case 1: w |= p[0]; h = caml_hash_mix_uint32(h, w); } break; } case CAML_BA_SINT16: case CAML_BA_UINT16: { uint16 * p = b->data; if (num_elts > 128) num_elts = 128; for (n = 0; n + 2 <= num_elts; n += 2, p += 2) { w = p[0] | (p[1] << 16); h = caml_hash_mix_uint32(h, w); } if ((num_elts & 1) != 0) h = caml_hash_mix_uint32(h, p[0]); break; } case CAML_BA_INT32: { uint32 * p = b->data; if (num_elts > 64) num_elts = 64; for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_uint32(h, *p); break; } case CAML_BA_CAML_INT: case CAML_BA_NATIVE_INT: { intnat * p = b->data; if (num_elts > 64) num_elts = 64; for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_intnat(h, *p); break; } case CAML_BA_INT64: { int64 * p = b->data; if (num_elts > 32) num_elts = 32; for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_int64(h, *p); break; } case CAML_BA_COMPLEX32: num_elts *= 2; /* fallthrough */ case CAML_BA_FLOAT32: { float * p = b->data; if (num_elts > 64) num_elts = 64; for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_float(h, *p); break; } case CAML_BA_COMPLEX64: num_elts *= 2; /* fallthrough */ case CAML_BA_FLOAT64: { double * p = b->data; if (num_elts > 32) num_elts = 32; for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_double(h, *p); break; } } return h; } static void caml_ba_serialize_longarray(void * data, intnat num_elts, intnat min_val, intnat max_val) { #ifdef ARCH_SIXTYFOUR int overflow_32 = 0; intnat * p, n; for (n = 0, p = data; n < num_elts; n++, p++) { if (*p < min_val || *p > max_val) { overflow_32 = 1; break; } } if (overflow_32) { caml_serialize_int_1(1); caml_serialize_block_8(data, num_elts); } else { caml_serialize_int_1(0); for (n = 0, p = data; n < num_elts; n++, p++) caml_serialize_int_4((int32) *p); } #else caml_serialize_int_1(0); caml_serialize_block_4(data, num_elts); #endif } static void caml_ba_serialize(value v, uintnat * wsize_32, uintnat * wsize_64) { struct caml_ba_array * b = Caml_ba_array_val(v); intnat num_elts; int i; /* Serialize header information */ caml_serialize_int_4(b->num_dims); caml_serialize_int_4(b->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK)); /* On a 64-bit machine, if any of the dimensions is >= 2^32, the size of the marshaled data will be >= 2^32 and extern_value() will fail. So, it is safe to write the dimensions as 32-bit unsigned integers. */ for (i = 0; i < b->num_dims; i++) caml_serialize_int_4(b->dim[i]); /* Compute total number of elements */ num_elts = 1; for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i]; /* Serialize elements */ switch (b->flags & CAML_BA_KIND_MASK) { case CAML_BA_SINT8: case CAML_BA_UINT8: caml_serialize_block_1(b->data, num_elts); break; case CAML_BA_SINT16: case CAML_BA_UINT16: caml_serialize_block_2(b->data, num_elts); break; case CAML_BA_FLOAT32: case CAML_BA_INT32: caml_serialize_block_4(b->data, num_elts); break; case CAML_BA_COMPLEX32: caml_serialize_block_4(b->data, num_elts * 2); break; case CAML_BA_FLOAT64: case CAML_BA_INT64: caml_serialize_block_8(b->data, num_elts); break; case CAML_BA_COMPLEX64: caml_serialize_block_8(b->data, num_elts * 2); break; case CAML_BA_CAML_INT: caml_ba_serialize_longarray(b->data, num_elts, -0x40000000, 0x3FFFFFFF); break; case CAML_BA_NATIVE_INT: caml_ba_serialize_longarray(b->data, num_elts, -0x80000000, 0x7FFFFFFF); break; } /* Compute required size in OCaml heap. Assumes struct caml_ba_array is exactly 4 + num_dims words */ /* PR#5516: use C99's flexible array types if possible */ #if (__STDC_VERSION__ >= 199901L) Assert(sizeof(struct caml_ba_array) == 4 * sizeof(value)); #else Assert(sizeof(struct caml_ba_array) == 5 * sizeof(value)); #endif *wsize_32 = (4 + b->num_dims) * 4; *wsize_64 = (4 + b->num_dims) * 8; } static void caml_ba_deserialize_longarray(void * dest, intnat num_elts) { int sixty = caml_deserialize_uint_1(); #ifdef ARCH_SIXTYFOUR if (sixty) { caml_deserialize_block_8(dest, num_elts); } else { intnat * p, n; for (n = 0, p = dest; n < num_elts; n++, p++) *p = caml_deserialize_sint_4(); } #else if (sixty) caml_deserialize_error("input_value: cannot read bigarray " "with 64-bit OCaml ints"); caml_deserialize_block_4(dest, num_elts); #endif } uintnat caml_ba_deserialize(void * dst) { struct caml_ba_array * b = dst; int i, elt_size; uintnat num_elts; /* Read back header information */ b->num_dims = caml_deserialize_uint_4(); b->flags = caml_deserialize_uint_4() | CAML_BA_MANAGED; b->proxy = NULL; for (i = 0; i < b->num_dims; i++) b->dim[i] = caml_deserialize_uint_4(); /* Compute total number of elements */ num_elts = caml_ba_num_elts(b); /* Determine element size in bytes */ if ((b->flags & CAML_BA_KIND_MASK) > CAML_BA_COMPLEX64) caml_deserialize_error("input_value: bad bigarray kind"); elt_size = caml_ba_element_size[b->flags & CAML_BA_KIND_MASK]; /* Allocate room for data */ b->data = malloc(elt_size * num_elts); if (b->data == NULL) caml_deserialize_error("input_value: out of memory for bigarray"); /* Read data */ switch (b->flags & CAML_BA_KIND_MASK) { case CAML_BA_SINT8: case CAML_BA_UINT8: caml_deserialize_block_1(b->data, num_elts); break; case CAML_BA_SINT16: case CAML_BA_UINT16: caml_deserialize_block_2(b->data, num_elts); break; case CAML_BA_FLOAT32: case CAML_BA_INT32: caml_deserialize_block_4(b->data, num_elts); break; case CAML_BA_COMPLEX32: caml_deserialize_block_4(b->data, num_elts * 2); break; case CAML_BA_FLOAT64: case CAML_BA_INT64: caml_deserialize_block_8(b->data, num_elts); break; case CAML_BA_COMPLEX64: caml_deserialize_block_8(b->data, num_elts * 2); break; case CAML_BA_CAML_INT: case CAML_BA_NATIVE_INT: caml_ba_deserialize_longarray(b->data, num_elts); break; } /* PR#5516: use C99's flexible array types if possible */ #if (__STDC_VERSION__ >= 199901L) return sizeof(struct caml_ba_array) + b->num_dims * sizeof(intnat); #else return sizeof(struct caml_ba_array) + (b->num_dims - 1) * sizeof(intnat); #endif } /* Create / update proxy to indicate that b2 is a sub-array of b1 */ static void caml_ba_update_proxy(struct caml_ba_array * b1, struct caml_ba_array * b2) { struct caml_ba_proxy * proxy; /* Nothing to do for un-managed arrays */ if ((b1->flags & CAML_BA_MANAGED_MASK) == CAML_BA_EXTERNAL) return; if (b1->proxy != NULL) { /* If b1 is already a proxy for a larger array, increment refcount of proxy */ b2->proxy = b1->proxy; ++ b1->proxy->refcount; } else { /* Otherwise, create proxy and attach it to both b1 and b2 */ proxy = caml_stat_alloc(sizeof(struct caml_ba_proxy)); proxy->refcount = 2; /* original array + sub array */ proxy->data = b1->data; proxy->size = b1->flags & CAML_BA_MAPPED_FILE ? caml_ba_byte_size(b1) : 0; b1->proxy = proxy; b2->proxy = proxy; } } /* Slicing */ CAMLprim value caml_ba_slice(value vb, value vind) { CAMLparam2 (vb, vind); #define b ((struct caml_ba_array *) Caml_ba_array_val(vb)) CAMLlocal1 (res); intnat index[CAML_BA_MAX_NUM_DIMS]; int num_inds, i; intnat offset; intnat * sub_dims; char * sub_data; /* Check number of indices < number of dimensions of array */ num_inds = Wosize_val(vind); if (num_inds >= b->num_dims) caml_invalid_argument("Bigarray.slice: too many indices"); /* Compute offset and check bounds */ if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) { /* We slice from the left */ for (i = 0; i < num_inds; i++) index[i] = Long_val(Field(vind, i)); for (/*nothing*/; i < b->num_dims; i++) index[i] = 0; offset = caml_ba_offset(b, index); sub_dims = b->dim + num_inds; } else { /* We slice from the right */ for (i = 0; i < num_inds; i++) index[b->num_dims - num_inds + i] = Long_val(Field(vind, i)); for (i = 0; i < b->num_dims - num_inds; i++) index[i] = 1; offset = caml_ba_offset(b, index); sub_dims = b->dim; } sub_data = (char *) b->data + offset * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK]; /* Allocate an OCaml bigarray to hold the result */ res = caml_ba_alloc(b->flags, b->num_dims - num_inds, sub_data, sub_dims); /* Create or update proxy in case of managed bigarray */ caml_ba_update_proxy(b, Caml_ba_array_val(res)); /* Return result */ CAMLreturn (res); #undef b } /* Extracting a sub-array of same number of dimensions */ CAMLprim value caml_ba_sub(value vb, value vofs, value vlen) { CAMLparam3 (vb, vofs, vlen); CAMLlocal1 (res); #define b ((struct caml_ba_array *) Caml_ba_array_val(vb)) intnat ofs = Long_val(vofs); intnat len = Long_val(vlen); int i, changed_dim; intnat mul; char * sub_data; /* Compute offset and check bounds */ if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) { /* We reduce the first dimension */ mul = 1; for (i = 1; i < b->num_dims; i++) mul *= b->dim[i]; changed_dim = 0; } else { /* We reduce the last dimension */ mul = 1; for (i = 0; i < b->num_dims - 1; i++) mul *= b->dim[i]; changed_dim = b->num_dims - 1; ofs--; /* Fortran arrays start at 1 */ } if (ofs < 0 || len < 0 || ofs + len > b->dim[changed_dim]) caml_invalid_argument("Bigarray.sub: bad sub-array"); sub_data = (char *) b->data + ofs * mul * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK]; /* Allocate an OCaml bigarray to hold the result */ res = caml_ba_alloc(b->flags, b->num_dims, sub_data, b->dim); /* Doctor the changed dimension */ Caml_ba_array_val(res)->dim[changed_dim] = len; /* Create or update proxy in case of managed bigarray */ caml_ba_update_proxy(b, Caml_ba_array_val(res)); /* Return result */ CAMLreturn (res); #undef b } /* Copying a big array into another one */ CAMLprim value caml_ba_blit(value vsrc, value vdst) { struct caml_ba_array * src = Caml_ba_array_val(vsrc); struct caml_ba_array * dst = Caml_ba_array_val(vdst); int i; intnat num_bytes; /* Check same numbers of dimensions and same dimensions */ if (src->num_dims != dst->num_dims) goto blit_error; for (i = 0; i < src->num_dims; i++) if (src->dim[i] != dst->dim[i]) goto blit_error; /* Compute number of bytes in array data */ num_bytes = caml_ba_num_elts(src) * caml_ba_element_size[src->flags & CAML_BA_KIND_MASK]; /* Do the copying */ memmove (dst->data, src->data, num_bytes); return Val_unit; blit_error: caml_invalid_argument("Bigarray.blit: dimension mismatch"); return Val_unit; /* not reached */ } /* Filling a big array with a given value */ CAMLprim value caml_ba_fill(value vb, value vinit) { struct caml_ba_array * b = Caml_ba_array_val(vb); intnat num_elts = caml_ba_num_elts(b); switch (b->flags & CAML_BA_KIND_MASK) { default: Assert(0); case CAML_BA_FLOAT32: { float init = Double_val(vinit); float * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_FLOAT64: { double init = Double_val(vinit); double * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_SINT8: case CAML_BA_UINT8: { int init = Int_val(vinit); char * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_SINT16: case CAML_BA_UINT16: { int init = Int_val(vinit); int16 * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_INT32: { int32 init = Int32_val(vinit); int32 * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_INT64: { int64 init = Int64_val(vinit); int64 * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_NATIVE_INT: { intnat init = Nativeint_val(vinit); intnat * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_CAML_INT: { intnat init = Long_val(vinit); intnat * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_COMPLEX32: { float init0 = Double_field(vinit, 0); float init1 = Double_field(vinit, 1); float * p; for (p = b->data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; } break; } case CAML_BA_COMPLEX64: { double init0 = Double_field(vinit, 0); double init1 = Double_field(vinit, 1); double * p; for (p = b->data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; } break; } } return Val_unit; } /* Reshape an array: change dimensions and number of dimensions, preserving array contents */ CAMLprim value caml_ba_reshape(value vb, value vdim) { CAMLparam2 (vb, vdim); CAMLlocal1 (res); #define b ((struct caml_ba_array *) Caml_ba_array_val(vb)) intnat dim[CAML_BA_MAX_NUM_DIMS]; mlsize_t num_dims; uintnat num_elts; int i; num_dims = Wosize_val(vdim); if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS) caml_invalid_argument("Bigarray.reshape: bad number of dimensions"); num_elts = 1; for (i = 0; i < num_dims; i++) { dim[i] = Long_val(Field(vdim, i)); if (dim[i] < 0) caml_invalid_argument("Bigarray.reshape: negative dimension"); num_elts *= dim[i]; } /* Check that sizes agree */ if (num_elts != caml_ba_num_elts(b)) caml_invalid_argument("Bigarray.reshape: size mismatch"); /* Create bigarray with same data and new dimensions */ res = caml_ba_alloc(b->flags, num_dims, b->data, dim); /* Create or update proxy in case of managed bigarray */ caml_ba_update_proxy(b, Caml_ba_array_val(res)); /* Return result */ CAMLreturn (res); #undef b } /* Initialization */ CAMLprim value caml_ba_init(value unit) { caml_register_custom_operations(&caml_ba_ops); return Val_unit; } mingw-ocaml/ocaml/otherlibs/bigarray/bigarray.h0000644000175000017500000000764312124403241021234 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ /* */ /* Copyright 2000 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_BIGARRAY_H #define CAML_BIGARRAY_H #ifndef CAML_NAME_SPACE #include "compatibility.h" #endif #include "config.h" #include "mlvalues.h" typedef signed char caml_ba_int8; typedef unsigned char caml_ba_uint8; #if SIZEOF_SHORT == 2 typedef short caml_ba_int16; typedef unsigned short caml_ba_uint16; #else #error "No 16-bit integer type available" #endif #define CAML_BA_MAX_NUM_DIMS 16 enum caml_ba_kind { CAML_BA_FLOAT32, /* Single-precision floats */ CAML_BA_FLOAT64, /* Double-precision floats */ CAML_BA_SINT8, /* Signed 8-bit integers */ CAML_BA_UINT8, /* Unsigned 8-bit integers */ CAML_BA_SINT16, /* Signed 16-bit integers */ CAML_BA_UINT16, /* Unsigned 16-bit integers */ CAML_BA_INT32, /* Signed 32-bit integers */ CAML_BA_INT64, /* Signed 64-bit integers */ CAML_BA_CAML_INT, /* OCaml-style integers (signed 31 or 63 bits) */ CAML_BA_NATIVE_INT, /* Platform-native long integers (32 or 64 bits) */ CAML_BA_COMPLEX32, /* Single-precision complex */ CAML_BA_COMPLEX64, /* Double-precision complex */ CAML_BA_KIND_MASK = 0xFF /* Mask for kind in flags field */ }; enum caml_ba_layout { CAML_BA_C_LAYOUT = 0, /* Row major, indices start at 0 */ CAML_BA_FORTRAN_LAYOUT = 0x100, /* Column major, indices start at 1 */ CAML_BA_LAYOUT_MASK = 0x100 /* Mask for layout in flags field */ }; enum caml_ba_managed { CAML_BA_EXTERNAL = 0, /* Data is not allocated by OCaml */ CAML_BA_MANAGED = 0x200, /* Data is allocated by OCaml */ CAML_BA_MAPPED_FILE = 0x400, /* Data is a memory mapped file */ CAML_BA_MANAGED_MASK = 0x600 /* Mask for "managed" bits in flags field */ }; struct caml_ba_proxy { intnat refcount; /* Reference count */ void * data; /* Pointer to base of actual data */ uintnat size; /* Size of data in bytes (if mapped file) */ }; struct caml_ba_array { void * data; /* Pointer to raw data */ intnat num_dims; /* Number of dimensions */ intnat flags; /* Kind of element array + memory layout + allocation status */ struct caml_ba_proxy * proxy; /* The proxy for sub-arrays, or NULL */ /* PR#5516: use C99's flexible array types if possible */ #if (__STDC_VERSION__ >= 199901L) intnat dim[] /*[num_dims]*/; /* Size in each dimension */ #else intnat dim[1] /*[num_dims]*/; /* Size in each dimension */ #endif }; #define Caml_ba_array_val(v) ((struct caml_ba_array *) Data_custom_val(v)) #define Caml_ba_data_val(v) (Caml_ba_array_val(v)->data) #if defined(IN_OCAML_BIGARRAY) #define CAMLBAextern CAMLexport #else #define CAMLBAextern CAMLextern #endif CAMLBAextern value caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim); CAMLBAextern value caml_ba_alloc_dims(int flags, int num_dims, void * data, ... /*dimensions, with type intnat */); CAMLBAextern uintnat caml_ba_byte_size(struct caml_ba_array * b); #endif mingw-ocaml/ocaml/otherlibs/bigarray/.depend0000644000175000017500000000231712124403241020514 0ustar tootstootsbigarray_stubs.o: bigarray_stubs.c ../../byterun/alloc.h \ ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h bigarray.h \ ../../byterun/config.h ../../byterun/mlvalues.h ../../byterun/custom.h \ ../../byterun/fail.h ../../byterun/intext.h ../../byterun/io.h \ ../../byterun/hash.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \ ../../byterun/custom.h ../../byterun/mlvalues.h ../../byterun/fail.h \ ../../byterun/io.h ../../byterun/sys.h ../../byterun/signals.h mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \ ../../byterun/alloc.h ../../byterun/mlvalues.h ../../byterun/custom.h \ ../../byterun/fail.h ../../byterun/sys.h ../unix/unixsupport.h bigarray.cmi : bigarray.cmo : bigarray.cmi bigarray.cmx : bigarray.cmi mingw-ocaml/ocaml/otherlibs/bigarray/libbigarray.clib0000644000175000017500000000003512124403241022371 0ustar tootstootsbigarray_stubs.o mmap_unix.o mingw-ocaml/ocaml/otherlibs/bigarray/mmap_unix.c0000644000175000017500000001462112124403241021416 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ /* */ /* Copyright 2000 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Needed (under Linux at least) to get pwrite's prototype in unistd.h. Must be defined before the first system .h is included. */ #define _XOPEN_SOURCE 500 #include #include #include "bigarray.h" #include "custom.h" #include "fail.h" #include "io.h" #include "mlvalues.h" #include "sys.h" #include "signals.h" extern int caml_ba_element_size[]; /* from bigarray_stubs.c */ #include #ifdef HAS_UNISTD #include #endif #ifdef HAS_MMAP #include #include #include #endif #if defined(HAS_MMAP) #ifndef MAP_FAILED #define MAP_FAILED ((void *) -1) #endif /* [caml_grow_file] function contributed by Gerd Stolpmann (PR#5543). */ static int caml_grow_file(int fd, file_offset size) { char c; int p; /* First use pwrite for growing - it is a conservative method, as it can never happen that we shrink by accident */ #ifdef HAS_PWRITE c = 0; p = pwrite(fd, &c, 1, size - 1); #else /* Emulate pwrite with lseek. This should only be necessary on ancient systems nowadays */ file_offset currpos; currpos = lseek(fd, 0, SEEK_CUR); if (currpos != -1) { p = lseek(fd, size - 1, SEEK_SET); if (p != -1) { c = 0; p = write(fd, &c, 1); if (p != -1) p = lseek(fd, currpos, SEEK_SET); } } else p=-1; #endif #ifdef HAS_TRUNCATE if (p == -1 && errno == ESPIPE) { /* Plan B. Check if at least ftruncate is possible. There are some non-seekable descriptor types that do not support pwrite but ftruncate, like shared memory. We never get into this case for real files, so there is no danger of truncating persistent data by accident */ p = ftruncate(fd, size); } #endif return p; } CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, value vshared, value vdim, value vstart) { int fd, flags, major_dim, shared; intnat num_dims, i; intnat dim[CAML_BA_MAX_NUM_DIMS]; file_offset startpos, file_size, data_size; struct stat st; uintnat array_size, page, delta; void * addr; fd = Int_val(vfd); flags = Int_val(vkind) | Int_val(vlayout); startpos = File_offset_val(vstart); num_dims = Wosize_val(vdim); major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0; /* Extract dimensions from OCaml array */ num_dims = Wosize_val(vdim); if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS) caml_invalid_argument("Bigarray.mmap: bad number of dimensions"); for (i = 0; i < num_dims; i++) { dim[i] = Long_val(Field(vdim, i)); if (dim[i] == -1 && i == major_dim) continue; if (dim[i] < 0) caml_invalid_argument("Bigarray.create: negative dimension"); } /* Determine file size. We avoid lseek here because it is fragile, and because some mappable file types do not support it */ caml_enter_blocking_section(); if (fstat(fd, &st) == -1) { caml_leave_blocking_section(); caml_sys_error(NO_ARG); } file_size = st.st_size; /* Determine array size in bytes (or size of array without the major dimension if that dimension wasn't specified) */ array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK]; for (i = 0; i < num_dims; i++) if (dim[i] != -1) array_size *= dim[i]; /* Check if the major dimension is unknown */ if (dim[major_dim] == -1) { /* Determine major dimension from file size */ if (file_size < startpos) { caml_leave_blocking_section(); caml_failwith("Bigarray.mmap: file position exceeds file size"); } data_size = file_size - startpos; dim[major_dim] = (uintnat) (data_size / array_size); array_size = dim[major_dim] * array_size; if (array_size != data_size) { caml_leave_blocking_section(); caml_failwith("Bigarray.mmap: file size doesn't match array dimensions"); } } else { /* Check that file is large enough, and grow it otherwise */ if (file_size < startpos + array_size) { if (caml_grow_file(fd, startpos + array_size) == -1) { /* PR#5543 */ caml_leave_blocking_section(); caml_sys_error(NO_ARG); } } } /* Determine offset so that the mapping starts at the given file pos */ page = getpagesize(); delta = (uintnat) startpos % page; /* Do the mmap */ shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE; if (array_size > 0) addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE, shared, fd, startpos - delta); else addr = NULL; /* PR#5463 - mmap fails on empty region */ caml_leave_blocking_section(); if (addr == (void *) MAP_FAILED) caml_sys_error(NO_ARG); addr = (void *) ((uintnat) addr + delta); /* Build and return the OCaml bigarray */ return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim); } #else CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, value vshared, value vdim, value vpos) { caml_invalid_argument("Bigarray.map_file: not supported"); return Val_unit; } #endif CAMLprim value caml_ba_map_file_bytecode(value * argv, int argn) { return caml_ba_map_file(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } void caml_ba_unmap_file(void * addr, uintnat len) { #if defined(HAS_MMAP) uintnat page = getpagesize(); uintnat delta = (uintnat) addr % page; if (len == 0) return; /* PR#5463 */ addr = (void *)((uintnat)addr - delta); len = len + delta; #if defined(_POSIX_SYNCHRONIZED_IO) msync(addr, len, MS_ASYNC); /* PR#3571 */ #endif munmap(addr, len); #endif } mingw-ocaml/ocaml/otherlibs/num/0000755000175000017500000000000012124403241016250 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/num/bng.h0000644000175000017500000001313212124403241017167 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2003 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "config.h" typedef uintnat bngdigit; typedef bngdigit * bng; typedef unsigned int bngcarry; typedef uintnat bngsize; #define BNG_BITS_PER_DIGIT (sizeof(bngdigit) * 8) #define BNG_BITS_PER_HALF_DIGIT (sizeof(bngdigit) * 4) struct bng_operations { /* {a,alen} := {a, alen} + carry. Return carry out. */ bngcarry (*add_carry) (bng a/*[alen]*/, bngsize alen, bngcarry carry); #define bng_add_carry bng_ops.add_carry /* {a,alen} := {a,alen} + {b,blen} + carry. Return carry out. Require alen >= blen. */ bngcarry (*add) (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngcarry carry); #define bng_add bng_ops.add /* {a,alen} := {a, alen} - carry. Return carry out. */ bngcarry (*sub_carry) (bng a/*[alen]*/, bngsize alen, bngcarry carry); #define bng_sub_carry bng_ops.sub_carry /* {a,alen} := {a,alen} - {b,blen} - carry. Return carry out. Require alen >= blen. */ bngcarry (*sub) (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngcarry carry); #define bng_sub bng_ops.sub /* {a,alen} := {a,alen} << shift. Return the bits shifted out of the most significant digit of a. Require 0 <= shift < BITS_PER_BNGDIGIT. */ bngdigit (*shift_left) (bng a/*[alen]*/, bngsize alen, int shift); #define bng_shift_left bng_ops.shift_left /* {a,alen} := {a,alen} >> shift. Return the bits shifted out of the least significant digit of a. Require 0 <= shift < BITS_PER_BNGDIGIT. */ bngdigit (*shift_right) (bng a/*[alen]*/, bngsize alen, int shift); #define bng_shift_right bng_ops.shift_right /* {a,alen} := {a,alen} + d * {b,blen}. Return carry out. Require alen >= blen. If alen > blen, the carry out returned is 0 or 1. If alen == blen, the carry out returned is a full digit. */ bngdigit (*mult_add_digit) (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngdigit d); #define bng_mult_add_digit bng_ops.mult_add_digit /* {a,alen} := {a,alen} - d * {b,blen}. Return carry out. Require alen >= blen. If alen > blen, the carry out returned is 0 or 1. If alen == blen, the carry out returned is a full digit. */ bngdigit (*mult_sub_digit) (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngdigit d); #define bng_mult_sub_digit bng_ops.mult_sub_digit /* {a,alen} := {a,alen} + {b,blen} * {c,clen}. Return carry out. Require alen >= blen + clen. */ bngcarry (*mult_add) (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bng c/*[clen]*/, bngsize clen); #define bng_mult_add bng_ops.mult_add /* {a,alen} := 2 * {a,alen} + {b,blen}^2. Return carry out. Require alen >= 2 * blen. */ bngcarry (*square_add) (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen); #define bng_square_add bng_ops.square_add /* {a,len-1} := {b,len} / d. Return {b,len} modulo d. Require d is normalized and MSD of b < d. See div_rem_digit for a function that does not require d to be normalized */ bngdigit (*div_rem_norm_digit) (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d); #define bng_div_rem_norm_digit bng_ops.div_rem_norm_digit /* {a,len-1} := {b,len} / d. Return {b,len} modulo d. Require MSD of b < d. */ bngdigit (*div_rem_digit) (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d); #define bng_div_rem_digit bng_ops.div_rem_digit /* {n+dlen, nlen-dlen} := {n,nlen} / {d, dlen}. {n, dlen} := {n,nlen} modulo {d, dlen}. Require nlen > dlen and MSD of n < MSD of d (which implies d != 0). */ void (*div_rem) (bng n/*[nlen]*/, bngsize nlen, bng d/*[nlen]*/, bngsize dlen); #define bng_div_rem bng_ops.div_rem }; extern struct bng_operations bng_ops; /* Initialize the BNG library */ extern void bng_init(void); /* {a,alen} := 0 */ #define bng_zero(a,alen) memset((a), 0, (alen) * sizeof(bngdigit)) /* {a,len} := {b,len} */ #define bng_assign(a,b,len) memmove((a), (b), (len) * sizeof(bngdigit)) /* Complement the digits of {a,len} */ extern void bng_complement(bng a/*[alen]*/, bngsize alen); /* Return number of significant digits in {a,alen}. */ extern bngsize bng_num_digits(bng a/*[alen]*/, bngsize alen); /* Return 1 if {a,alen} is 0, 0 otherwise. */ #define bng_is_zero(a,alen) (bng_num_digits(a,alen) == 0) /* Return 0 if {a,alen} = {b,blen} <0 if {a,alen} < {b,blen} >0 if {a,alen} > {b,blen}. */ extern int bng_compare(bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen); /* Return the number of leading zero bits in digit d. */ extern int bng_leading_zero_bits(bngdigit d); mingw-ocaml/ocaml/otherlibs/num/ratio.ml0000644000175000017500000004735512124403241017736 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) open Int_misc open Nat open Big_int open Arith_flags (* Definition of the type ratio : Conventions : - the denominator is always a positive number - the sign of n/0 is the sign of n These convention is automatically respected when a ratio is created with the create_ratio primitive *) type ratio = { mutable numerator : big_int; mutable denominator : big_int; mutable normalized : bool} let failwith_zero name = let s = "infinite or undefined rational number" in failwith (if String.length name = 0 then s else name ^ " " ^ s) let numerator_ratio r = r.numerator and denominator_ratio r = r.denominator let null_denominator r = sign_big_int r.denominator = 0 let verify_null_denominator r = if sign_big_int r.denominator = 0 then (if !error_when_null_denominator_flag then (failwith_zero "") else true) else false let sign_ratio r = sign_big_int r.numerator (* Physical normalization of rational numbers *) (* 1/0, 0/0 and -1/0 are the normalized forms for n/0 numbers *) let normalize_ratio r = if r.normalized then r else if verify_null_denominator r then begin r.numerator <- big_int_of_int (sign_big_int r.numerator); r.normalized <- true; r end else begin let p = gcd_big_int r.numerator r.denominator in if eq_big_int p unit_big_int then begin r.normalized <- true; r end else begin r.numerator <- div_big_int (r.numerator) p; r.denominator <- div_big_int (r.denominator) p; r.normalized <- true; r end end let cautious_normalize_ratio r = if (!normalize_ratio_flag) then (normalize_ratio r) else r let cautious_normalize_ratio_when_printing r = if (!normalize_ratio_when_printing_flag) then (normalize_ratio r) else r let create_ratio bi1 bi2 = match sign_big_int bi2 with -1 -> cautious_normalize_ratio { numerator = minus_big_int bi1; denominator = minus_big_int bi2; normalized = false } | 0 -> if !error_when_null_denominator_flag then (failwith_zero "create_ratio") else cautious_normalize_ratio { numerator = bi1; denominator = bi2; normalized = false } | _ -> cautious_normalize_ratio { numerator = bi1; denominator = bi2; normalized = false } let create_normalized_ratio bi1 bi2 = match sign_big_int bi2 with -1 -> { numerator = minus_big_int bi1; denominator = minus_big_int bi2; normalized = true } | 0 -> if !error_when_null_denominator_flag then failwith_zero "create_normalized_ratio" else { numerator = bi1; denominator = bi2; normalized = true } | _ -> { numerator = bi1; denominator = bi2; normalized = true } let is_normalized_ratio r = r.normalized let report_sign_ratio r bi = if sign_ratio r = -1 then minus_big_int bi else bi let abs_ratio r = { numerator = abs_big_int r.numerator; denominator = r.denominator; normalized = r.normalized } let is_integer_ratio r = eq_big_int ((normalize_ratio r).denominator) unit_big_int (* Operations on rational numbers *) let add_ratio r1 r2 = if !normalize_ratio_flag then begin let p = gcd_big_int ((normalize_ratio r1).denominator) ((normalize_ratio r2).denominator) in if eq_big_int p unit_big_int then {numerator = add_big_int (mult_big_int (r1.numerator) r2.denominator) (mult_big_int (r2.numerator) r1.denominator); denominator = mult_big_int (r1.denominator) r2.denominator; normalized = true} else begin let d1 = div_big_int (r1.denominator) p and d2 = div_big_int (r2.denominator) p in let n = add_big_int (mult_big_int (r1.numerator) d2) (mult_big_int d1 r2.numerator) in let p' = gcd_big_int n p in { numerator = div_big_int n p'; denominator = mult_big_int d1 (div_big_int (r2.denominator) p'); normalized = true } end end else { numerator = add_big_int (mult_big_int (r1.numerator) r2.denominator) (mult_big_int (r1.denominator) r2.numerator); denominator = mult_big_int (r1.denominator) r2.denominator; normalized = false } let minus_ratio r = { numerator = minus_big_int (r.numerator); denominator = r.denominator; normalized = r.normalized } let add_int_ratio i r = ignore (cautious_normalize_ratio r); { numerator = add_big_int (mult_int_big_int i r.denominator) r.numerator; denominator = r.denominator; normalized = r.normalized } let add_big_int_ratio bi r = ignore (cautious_normalize_ratio r); { numerator = add_big_int (mult_big_int bi r.denominator) r.numerator ; denominator = r.denominator; normalized = r.normalized } let sub_ratio r1 r2 = add_ratio r1 (minus_ratio r2) let mult_ratio r1 r2 = if !normalize_ratio_flag then begin let p1 = gcd_big_int ((normalize_ratio r1).numerator) ((normalize_ratio r2).denominator) and p2 = gcd_big_int (r2.numerator) r1.denominator in let (n1, d2) = if eq_big_int p1 unit_big_int then (r1.numerator, r2.denominator) else (div_big_int (r1.numerator) p1, div_big_int (r2.denominator) p1) and (n2, d1) = if eq_big_int p2 unit_big_int then (r2.numerator, r1.denominator) else (div_big_int r2.numerator p2, div_big_int r1.denominator p2) in { numerator = mult_big_int n1 n2; denominator = mult_big_int d1 d2; normalized = true } end else { numerator = mult_big_int (r1.numerator) r2.numerator; denominator = mult_big_int (r1.denominator) r2.denominator; normalized = false } let mult_int_ratio i r = if !normalize_ratio_flag then begin let p = gcd_big_int ((normalize_ratio r).denominator) (big_int_of_int i) in if eq_big_int p unit_big_int then { numerator = mult_big_int (big_int_of_int i) r.numerator; denominator = r.denominator; normalized = true } else { numerator = mult_big_int (div_big_int (big_int_of_int i) p) r.numerator; denominator = div_big_int (r.denominator) p; normalized = true } end else { numerator = mult_int_big_int i r.numerator; denominator = r.denominator; normalized = false } let mult_big_int_ratio bi r = if !normalize_ratio_flag then begin let p = gcd_big_int ((normalize_ratio r).denominator) bi in if eq_big_int p unit_big_int then { numerator = mult_big_int bi r.numerator; denominator = r.denominator; normalized = true } else { numerator = mult_big_int (div_big_int bi p) r.numerator; denominator = div_big_int (r.denominator) p; normalized = true } end else { numerator = mult_big_int bi r.numerator; denominator = r.denominator; normalized = false } let square_ratio r = ignore (cautious_normalize_ratio r); { numerator = square_big_int r.numerator; denominator = square_big_int r.denominator; normalized = r.normalized } let inverse_ratio r = if !error_when_null_denominator_flag && (sign_big_int r.numerator) = 0 then failwith_zero "inverse_ratio" else {numerator = report_sign_ratio r r.denominator; denominator = abs_big_int r.numerator; normalized = r.normalized} let div_ratio r1 r2 = mult_ratio r1 (inverse_ratio r2) (* Integer part of a rational number *) (* Odd function *) let integer_ratio r = if null_denominator r then failwith_zero "integer_ratio" else if sign_ratio r = 0 then zero_big_int else report_sign_ratio r (div_big_int (abs_big_int r.numerator) (abs_big_int r.denominator)) (* Floor of a rational number *) (* Always less or equal to r *) let floor_ratio r = ignore (verify_null_denominator r); div_big_int (r.numerator) r.denominator (* Round of a rational number *) (* Odd function, 1/2 -> 1 *) let round_ratio r = ignore (verify_null_denominator r); let abs_num = abs_big_int r.numerator in let bi = div_big_int abs_num r.denominator in report_sign_ratio r (if sign_big_int (sub_big_int (mult_int_big_int 2 (sub_big_int abs_num (mult_big_int (r.denominator) bi))) r.denominator) = -1 then bi else succ_big_int bi) let ceiling_ratio r = if (is_integer_ratio r) then r.numerator else succ_big_int (floor_ratio r) (* Comparison operators on rational numbers *) let eq_ratio r1 r2 = ignore (normalize_ratio r1); ignore (normalize_ratio r2); eq_big_int (r1.numerator) r2.numerator && eq_big_int (r1.denominator) r2.denominator let compare_ratio r1 r2 = if verify_null_denominator r1 then let sign_num_r1 = sign_big_int r1.numerator in if (verify_null_denominator r2) then let sign_num_r2 = sign_big_int r2.numerator in if sign_num_r1 = 1 && sign_num_r2 = -1 then 1 else if sign_num_r1 = -1 && sign_num_r2 = 1 then -1 else 0 else sign_num_r1 else if verify_null_denominator r2 then -(sign_big_int r2.numerator) else match compare_int (sign_big_int r1.numerator) (sign_big_int r2.numerator) with 1 -> 1 | -1 -> -1 | _ -> if eq_big_int (r1.denominator) r2.denominator then compare_big_int (r1.numerator) r2.numerator else compare_big_int (mult_big_int (r1.numerator) r2.denominator) (mult_big_int (r1.denominator) r2.numerator) let lt_ratio r1 r2 = compare_ratio r1 r2 < 0 and le_ratio r1 r2 = compare_ratio r1 r2 <= 0 and gt_ratio r1 r2 = compare_ratio r1 r2 > 0 and ge_ratio r1 r2 = compare_ratio r1 r2 >= 0 let max_ratio r1 r2 = if lt_ratio r1 r2 then r2 else r1 and min_ratio r1 r2 = if gt_ratio r1 r2 then r2 else r1 let eq_big_int_ratio bi r = (is_integer_ratio r) && eq_big_int bi r.numerator let compare_big_int_ratio bi r = ignore (normalize_ratio r); if (verify_null_denominator r) then -(sign_big_int r.numerator) else compare_big_int (mult_big_int bi r.denominator) r.numerator let lt_big_int_ratio bi r = compare_big_int_ratio bi r < 0 and le_big_int_ratio bi r = compare_big_int_ratio bi r <= 0 and gt_big_int_ratio bi r = compare_big_int_ratio bi r > 0 and ge_big_int_ratio bi r = compare_big_int_ratio bi r >= 0 (* Coercions *) (* Coercions with type int *) let int_of_ratio r = if ((is_integer_ratio r) && (is_int_big_int r.numerator)) then (int_of_big_int r.numerator) else failwith "integer argument required" and ratio_of_int i = { numerator = big_int_of_int i; denominator = unit_big_int; normalized = true } (* Coercions with type nat *) let ratio_of_nat nat = { numerator = big_int_of_nat nat; denominator = unit_big_int; normalized = true } and nat_of_ratio r = ignore (normalize_ratio r); if not (is_integer_ratio r) then failwith "nat_of_ratio" else if sign_big_int r.numerator > -1 then nat_of_big_int (r.numerator) else failwith "nat_of_ratio" (* Coercions with type big_int *) let ratio_of_big_int bi = { numerator = bi; denominator = unit_big_int; normalized = true } and big_int_of_ratio r = ignore (normalize_ratio r); if is_integer_ratio r then r.numerator else failwith "big_int_of_ratio" let div_int_ratio i r = ignore (verify_null_denominator r); mult_int_ratio i (inverse_ratio r) let div_ratio_int r i = div_ratio r (ratio_of_int i) let div_big_int_ratio bi r = ignore (verify_null_denominator r); mult_big_int_ratio bi (inverse_ratio r) let div_ratio_big_int r bi = div_ratio r (ratio_of_big_int bi) (* Functions on type string *) (* giving floating point approximations of rational numbers *) (* Compares strings that contains only digits, have the same length, from index i to index i + l *) let rec compare_num_string s1 s2 i len = if i >= len then 0 else let c1 = int_of_char s1.[i] and c2 = int_of_char s2.[i] in match compare_int c1 c2 with | 0 -> compare_num_string s1 s2 (succ i) len | c -> c;; (* Position of the leading digit of the decimal expansion *) (* of a strictly positive rational number *) (* if the decimal expansion of a non null rational r is equal to *) (* sigma for k=-P to N of r_k*10^k then msd_ratio r = N *) (* Nota : for a big_int we have msd_ratio = nums_digits_big_int -1 *) (* Tests if s has only zeros characters from index i to index lim *) let rec only_zeros s i lim = i >= lim || s.[i] == '0' && only_zeros s (succ i) lim;; (* Nota : for a big_int we have msd_ratio = nums_digits_big_int -1 *) let msd_ratio r = ignore (cautious_normalize_ratio r); if null_denominator r then failwith_zero "msd_ratio" else if sign_big_int r.numerator == 0 then 0 else begin let str_num = string_of_big_int r.numerator and str_den = string_of_big_int r.denominator in let size_num = String.length str_num and size_den = String.length str_den in let size_min = min size_num size_den in let m = size_num - size_den in let cmp = compare_num_string str_num str_den 0 size_min in match cmp with | 1 -> m | -1 -> pred m | _ -> if m >= 0 then m else if only_zeros str_den size_min size_den then m else pred m end ;; (* Decimal approximations of rational numbers *) (* Approximation with fix decimal point *) (* This is an odd function and the last digit is round off *) (* Format integer_part . decimal_part_with_n_digits *) let approx_ratio_fix n r = (* Don't need to normalize *) if (null_denominator r) then failwith_zero "approx_ratio_fix" else let sign_r = sign_ratio r in if sign_r = 0 then "+0" (* r = 0 *) else (* r.numerator and r.denominator are not null numbers s1 contains one more digit than desired for the round off operation *) if n >= 0 then begin let s1 = string_of_nat (nat_of_big_int (div_big_int (base_power_big_int 10 (succ n) (abs_big_int r.numerator)) r.denominator)) in (* Round up and add 1 in front if needed *) let s2 = if round_futur_last_digit s1 0 (String.length s1) then "1" ^ s1 else s1 in let l2 = String.length s2 - 1 in (* if s2 without last digit is xxxxyyy with n 'yyy' digits: xxxx . yyy if s2 without last digit is yy with <= n digits: 0 . 0yy *) if l2 > n then begin let s = String.make (l2 + 2) '0' in String.set s 0 (if sign_r = -1 then '-' else '+'); String.blit s2 0 s 1 (l2 - n); String.set s (l2 - n + 1) '.'; String.blit s2 (l2 - n) s (l2 - n + 2) n; s end else begin let s = String.make (n + 3) '0' in String.set s 0 (if sign_r = -1 then '-' else '+'); String.set s 2 '.'; String.blit s2 0 s (n + 3 - l2) l2; s end end else begin (* Dubious; what is this code supposed to do? *) let s = string_of_big_int (div_big_int (abs_big_int r.numerator) (base_power_big_int 10 (-n) r.denominator)) in let len = succ (String.length s) in let s' = String.make len '0' in String.set s' 0 (if sign_r = -1 then '-' else '+'); String.blit s 0 s' 1 (pred len); s' end (* Number of digits of the decimal representation of an int *) let num_decimal_digits_int n = String.length (string_of_int n) (* Approximation with floating decimal point *) (* This is an odd function and the last digit is round off *) (* Format (+/-)(0. n_first_digits e msd)/(1. n_zeros e (msd+1) *) let approx_ratio_exp n r = (* Don't need to normalize *) if (null_denominator r) then failwith_zero "approx_ratio_exp" else if n <= 0 then invalid_arg "approx_ratio_exp" else let sign_r = sign_ratio r and i = ref (n + 3) in if sign_r = 0 then let s = String.make (n + 5) '0' in (String.blit "+0." 0 s 0 3); (String.blit "e0" 0 s !i 2); s else let msd = msd_ratio (abs_ratio r) in let k = n - msd in let s = (let nat = nat_of_big_int (if k < 0 then div_big_int (abs_big_int r.numerator) (base_power_big_int 10 (- k) r.denominator) else div_big_int (base_power_big_int 10 k (abs_big_int r.numerator)) r.denominator) in string_of_nat nat) in if (round_futur_last_digit s 0 (String.length s)) then let m = num_decimal_digits_int (succ msd) in let str = String.make (n + m + 4) '0' in (String.blit (if sign_r = -1 then "-1." else "+1.") 0 str 0 3); String.set str !i ('e'); incr i; (if m = 0 then String.set str !i '0' else String.blit (string_of_int (succ msd)) 0 str !i m); str else let m = num_decimal_digits_int (succ msd) and p = n + 3 in let str = String.make (succ (m + p)) '0' in (String.blit (if sign_r = -1 then "-0." else "+0.") 0 str 0 3); (String.blit s 0 str 3 n); String.set str p 'e'; (if m = 0 then String.set str (succ p) '0' else (String.blit (string_of_int (succ msd)) 0 str (succ p) m)); str (* String approximation of a rational with a fixed number of significant *) (* digits printed *) let float_of_rational_string r = let s = approx_ratio_exp !floating_precision r in if String.get s 0 = '+' then (String.sub s 1 (pred (String.length s))) else s (* Coercions with type string *) let string_of_ratio r = ignore (cautious_normalize_ratio_when_printing r); if !approx_printing_flag then float_of_rational_string r else string_of_big_int r.numerator ^ "/" ^ string_of_big_int r.denominator (* XL: j'ai puissamment simplifie "ratio_of_string" en virant la notation scientifique. *) let ratio_of_string s = try let n = String.index s '/' in create_ratio (sys_big_int_of_string s 0 n) (sys_big_int_of_string s (n+1) (String.length s - n - 1)) with Not_found -> { numerator = big_int_of_string s; denominator = unit_big_int; normalized = true } (* Coercion with type float *) let float_of_ratio r = float_of_string (float_of_rational_string r) (* XL: suppression de ratio_of_float *) let power_ratio_positive_int r n = create_ratio (power_big_int_positive_int (r.numerator) n) (power_big_int_positive_int (r.denominator) n) let power_ratio_positive_big_int r bi = create_ratio (power_big_int_positive_big_int (r.numerator) bi) (power_big_int_positive_big_int (r.denominator) bi) mingw-ocaml/ocaml/otherlibs/num/Makefile0000644000175000017500000000270512124403241017714 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ # Makefile for the "num" (exact rational arithmetic) library LIBNAME=nums EXTRACFLAGS=-DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL) CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \ ratio.cmo num.cmo arith_status.cmo CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi COBJS=bng.$(O) nat_stubs.$(O) include ../Makefile clean:: rm -f *~ bng.$(O): bng.h bng_digit.c \ bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c depend: gcc -MM $(CFLAGS) *.c > .depend ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend include .depend mingw-ocaml/ocaml/otherlibs/num/bng_amd64.c0000644000175000017500000001454212124403241020163 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2003 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Code specific to the AMD x86_64 architecture. */ #define BngAdd2(res,carryout,arg1,arg2) \ asm("xorl %1, %1 \n\t" \ "addq %3, %0 \n\t" \ "setc %b1" \ : "=r" (res), "=&q" (carryout) \ : "0" (arg1), "rm" (arg2)) #define BngSub2(res,carryout,arg1,arg2) \ asm("xorl %1, %1 \n\t" \ "subq %3, %0 \n\t" \ "setc %b1" \ : "=r" (res), "=&q" (carryout) \ : "0" (arg1), "rm" (arg2)) #define BngMult(resh,resl,arg1,arg2) \ asm("mulq %3" \ : "=a" (resl), "=d" (resh) \ : "a" (arg1), "r" (arg2)) #define BngDiv(quo,rem,nh,nl,d) \ asm("divq %4" \ : "=a" (quo), "=d" (rem) \ : "a" (nl), "d" (nh), "r" (d)) /* Reimplementation in asm of some of the bng operations. */ static bngcarry bng_amd64_add (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngcarry carry) { bngdigit tmp; alen -= blen; if (blen > 0) { asm("negb %b3 \n\t" "1: \n\t" "movq (%0), %4 \n\t" "adcq (%1), %4 \n\t" "movq %4, (%0) \n\t" "leaq 8(%0), %0 \n\t" "leaq 8(%1), %1 \n\t" "decq %2 \n\t" "jnz 1b \n\t" "setc %b3" : "=r" (a), "=r" (b), "=r" (blen), "=q" (carry), "=r" (tmp) : "0" (a), "1" (b), "2" (blen), "3" (carry)); } if (carry == 0 || alen == 0) return carry; do { if (++(*a) != 0) return 0; a++; } while (--alen); return 1; } static bngcarry bng_amd64_sub (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngcarry carry) { bngdigit tmp; alen -= blen; if (blen > 0) { asm("negb %b3 \n\t" "1: \n\t" "movq (%0), %4 \n\t" "sbbq (%1), %4 \n\t" "movq %4, (%0) \n\t" "leaq 8(%0), %0 \n\t" "leaq 8(%1), %1 \n\t" "decq %2 \n\t" "jnz 1b \n\t" "setc %b3" : "=r" (a), "=r" (b), "=r" (blen), "=q" (carry), "=r" (tmp) : "0" (a), "1" (b), "2" (blen), "3" (carry)); } if (carry == 0 || alen == 0) return carry; do { if ((*a)-- != 0) return 0; a++; } while (--alen); return 1; } static bngdigit bng_amd64_mult_add_digit (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngdigit d) { bngdigit out; bngcarry carry; alen -= blen; out = 0; if (blen > 0) { asm("1: \n\t" "movq (%1), %%rax \n\t" "mulq %7\n\t" /* rdx:rax = d * next digit of b */ "addq (%0), %%rax \n\t" /* add next digit of a to rax */ "adcq $0, %%rdx \n\t" /* accumulate carry in rdx */ "addq %3, %%rax \n\t" /* add out to rax */ "adcq $0, %%rdx \n\t" /* accumulate carry in rdx */ "movq %%rax, (%0) \n\t" /* rax is next digit of result */ "movq %%rdx, %3 \n\t" /* rdx is next out */ "leaq 8(%0), %0 \n\t" "leaq 8(%1), %1 \n\t" "decq %2 \n\t" "jnz 1b" : "=&r" (a), "=&r" (b), "=&r" (blen), "=&r" (out) : "0" (a), "1" (b), "2" (blen), "rm" (d), "3" (out) : "rax", "rdx"); } if (alen == 0) return out; /* current digit of a += out */ BngAdd2(*a, carry, *a, out); a++; alen--; /* Propagate carry */ if (carry == 0 || alen == 0) return carry; do { if (++(*a) != 0) return 0; a++; } while (--alen); return 1; } static bngdigit bng_amd64_mult_sub_digit (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngdigit d) { bngdigit out, tmp; bngcarry carry; alen -= blen; out = 0; if (blen > 0) { asm("1: \n\t" "movq (%1), %%rax \n\t" "movq (%0), %4 \n\t" "mulq %8\n\t" /* rdx:rax = d * next digit of b */ "subq %%rax, %4 \n\t" /* subtract rax from next digit of a */ "adcq $0, %%rdx \n\t" /* accumulate carry in rdx */ "subq %3, %4 \n\t" /* subtract out */ "adcq $0, %%rdx \n\t" /* accumulate carry in rdx */ "movq %4, (%0) \n\t" /* store next digit of result */ "movq %%rdx, %3 \n\t" /* rdx is next out */ "leaq 8(%0), %0 \n\t" "leaq 8(%1), %1 \n\t" "decq %2 \n\t" "jnz 1b" : "=&r" (a), "=&r" (b), "=&rm" (blen), "=&r" (out), "=&r" (tmp) : "0" (a), "1" (b), "2" (blen), "rm" (d), "3" (out) : "rax", "rdx"); } if (alen == 0) return out; /* current digit of a -= out */ BngSub2(*a, carry, *a, out); a++; alen--; /* Propagate carry */ if (carry == 0 || alen == 0) return carry; do { if ((*a)-- != 0) return 0; a++; } while (--alen); return 1; } static void bng_amd64_setup_ops(void) { bng_ops.add = bng_amd64_add; bng_ops.sub = bng_amd64_sub; bng_ops.mult_add_digit = bng_amd64_mult_add_digit; bng_ops.mult_sub_digit = bng_amd64_mult_sub_digit; } #define BNG_SETUP_OPS bng_amd64_setup_ops() mingw-ocaml/ocaml/otherlibs/num/arith_flags.ml0000644000175000017500000000213712124403241021070 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) let error_when_null_denominator_flag = ref true;; let normalize_ratio_flag = ref false;; let normalize_ratio_when_printing_flag = ref true;; let floating_precision = ref 12;; let approx_printing_flag = ref false;; mingw-ocaml/ocaml/otherlibs/num/bignum/0000755000175000017500000000000012124403241017531 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/num/bignum/.gitignore0000644000175000017500000000000012124403241021507 0ustar tootstootsmingw-ocaml/ocaml/otherlibs/num/libnums.clib0000644000175000017500000000002212124403241020546 0ustar tootstootsbng.o nat_stubs.o mingw-ocaml/ocaml/otherlibs/num/big_int.ml0000644000175000017500000007241012124403241020221 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) open Int_misc open Nat type big_int = { sign : int; abs_value : nat } let create_big_int sign nat = if sign = 1 || sign = -1 || (sign = 0 && is_zero_nat nat 0 (num_digits_nat nat 0 (length_nat nat))) then { sign = sign; abs_value = nat } else invalid_arg "create_big_int" (* Sign of a big_int *) let sign_big_int bi = bi.sign let zero_big_int = { sign = 0; abs_value = make_nat 1 } let unit_big_int = { sign = 1; abs_value = nat_of_int 1 } (* Number of digits in a big_int *) let num_digits_big_int bi = num_digits_nat (bi.abs_value) 0 (length_nat bi.abs_value) (* Opposite of a big_int *) let minus_big_int bi = { sign = - bi.sign; abs_value = copy_nat (bi.abs_value) 0 (num_digits_big_int bi)} (* Absolute value of a big_int *) let abs_big_int bi = { sign = if bi.sign = 0 then 0 else 1; abs_value = copy_nat (bi.abs_value) 0 (num_digits_big_int bi)} (* Comparison operators on big_int *) (* compare_big_int (bi, bi2) = sign of (bi-bi2) i.e. 1 if bi > bi2 0 if bi = bi2 -1 if bi < bi2 *) let compare_big_int bi1 bi2 = if bi1.sign = 0 && bi2.sign = 0 then 0 else if bi1.sign < bi2.sign then -1 else if bi1.sign > bi2.sign then 1 else if bi1.sign = 1 then compare_nat (bi1.abs_value) 0 (num_digits_big_int bi1) (bi2.abs_value) 0 (num_digits_big_int bi2) else compare_nat (bi2.abs_value) 0 (num_digits_big_int bi2) (bi1.abs_value) 0 (num_digits_big_int bi1) let eq_big_int bi1 bi2 = compare_big_int bi1 bi2 = 0 and le_big_int bi1 bi2 = compare_big_int bi1 bi2 <= 0 and ge_big_int bi1 bi2 = compare_big_int bi1 bi2 >= 0 and lt_big_int bi1 bi2 = compare_big_int bi1 bi2 < 0 and gt_big_int bi1 bi2 = compare_big_int bi1 bi2 > 0 let max_big_int bi1 bi2 = if lt_big_int bi1 bi2 then bi2 else bi1 and min_big_int bi1 bi2 = if gt_big_int bi1 bi2 then bi2 else bi1 (* Operations on big_int *) let pred_big_int bi = match bi.sign with 0 -> { sign = -1; abs_value = nat_of_int 1} | 1 -> let size_bi = num_digits_big_int bi in let copy_bi = copy_nat (bi.abs_value) 0 size_bi in ignore (decr_nat copy_bi 0 size_bi 0); { sign = if is_zero_nat copy_bi 0 size_bi then 0 else 1; abs_value = copy_bi } | _ -> let size_bi = num_digits_big_int bi in let size_res = succ (size_bi) in let copy_bi = create_nat (size_res) in blit_nat copy_bi 0 (bi.abs_value) 0 size_bi; set_digit_nat copy_bi size_bi 0; ignore (incr_nat copy_bi 0 size_res 1); { sign = -1; abs_value = copy_bi } let succ_big_int bi = match bi.sign with 0 -> {sign = 1; abs_value = nat_of_int 1} | -1 -> let size_bi = num_digits_big_int bi in let copy_bi = copy_nat (bi.abs_value) 0 size_bi in ignore (decr_nat copy_bi 0 size_bi 0); { sign = if is_zero_nat copy_bi 0 size_bi then 0 else -1; abs_value = copy_bi } | _ -> let size_bi = num_digits_big_int bi in let size_res = succ (size_bi) in let copy_bi = create_nat (size_res) in blit_nat copy_bi 0 (bi.abs_value) 0 size_bi; set_digit_nat copy_bi size_bi 0; ignore (incr_nat copy_bi 0 size_res 1); { sign = 1; abs_value = copy_bi } let add_big_int bi1 bi2 = let size_bi1 = num_digits_big_int bi1 and size_bi2 = num_digits_big_int bi2 in if bi1.sign = bi2.sign then (* Add absolute values if signs are the same *) { sign = bi1.sign; abs_value = match compare_nat (bi1.abs_value) 0 size_bi1 (bi2.abs_value) 0 size_bi2 with -1 -> let res = create_nat (succ size_bi2) in (blit_nat res 0 (bi2.abs_value) 0 size_bi2; set_digit_nat res size_bi2 0; ignore (add_nat res 0 (succ size_bi2) (bi1.abs_value) 0 size_bi1 0); res) |_ -> let res = create_nat (succ size_bi1) in (blit_nat res 0 (bi1.abs_value) 0 size_bi1; set_digit_nat res size_bi1 0; ignore (add_nat res 0 (succ size_bi1) (bi2.abs_value) 0 size_bi2 0); res)} else (* Subtract absolute values if signs are different *) match compare_nat (bi1.abs_value) 0 size_bi1 (bi2.abs_value) 0 size_bi2 with 0 -> zero_big_int | 1 -> { sign = bi1.sign; abs_value = let res = copy_nat (bi1.abs_value) 0 size_bi1 in (ignore (sub_nat res 0 size_bi1 (bi2.abs_value) 0 size_bi2 1); res) } | _ -> { sign = bi2.sign; abs_value = let res = copy_nat (bi2.abs_value) 0 size_bi2 in (ignore (sub_nat res 0 size_bi2 (bi1.abs_value) 0 size_bi1 1); res) } (* Coercion with int type *) let big_int_of_int i = { sign = sign_int i; abs_value = let res = (create_nat 1) in (if i = monster_int then (set_digit_nat res 0 biggest_int; ignore (incr_nat res 0 1 1)) else set_digit_nat res 0 (abs i)); res } let add_int_big_int i bi = add_big_int (big_int_of_int i) bi let sub_big_int bi1 bi2 = add_big_int bi1 (minus_big_int bi2) (* Returns i * bi *) let mult_int_big_int i bi = let size_bi = num_digits_big_int bi in let size_res = succ size_bi in if i = monster_int then let res = create_nat size_res in blit_nat res 0 (bi.abs_value) 0 size_bi; set_digit_nat res size_bi 0; ignore (mult_digit_nat res 0 size_res (bi.abs_value) 0 size_bi (nat_of_int biggest_int) 0); { sign = - (sign_big_int bi); abs_value = res } else let res = make_nat (size_res) in ignore (mult_digit_nat res 0 size_res (bi.abs_value) 0 size_bi (nat_of_int (abs i)) 0); { sign = (sign_int i) * (sign_big_int bi); abs_value = res } let mult_big_int bi1 bi2 = let size_bi1 = num_digits_big_int bi1 and size_bi2 = num_digits_big_int bi2 in let size_res = size_bi1 + size_bi2 in let res = make_nat (size_res) in { sign = bi1.sign * bi2.sign; abs_value = if size_bi2 > size_bi1 then (ignore (mult_nat res 0 size_res (bi2.abs_value) 0 size_bi2 (bi1.abs_value) 0 size_bi1);res) else (ignore (mult_nat res 0 size_res (bi1.abs_value) 0 size_bi1 (bi2.abs_value) 0 size_bi2);res) } (* (quotient, rest) of the euclidian division of 2 big_int *) let quomod_big_int bi1 bi2 = if bi2.sign = 0 then raise Division_by_zero else let size_bi1 = num_digits_big_int bi1 and size_bi2 = num_digits_big_int bi2 in match compare_nat (bi1.abs_value) 0 size_bi1 (bi2.abs_value) 0 size_bi2 with -1 -> (* 1/2 -> 0, reste 1, -1/2 -> -1, reste 1 *) (* 1/-2 -> 0, reste 1, -1/-2 -> 1, reste 1 *) if bi1.sign >= 0 then (big_int_of_int 0, bi1) else if bi2.sign >= 0 then (big_int_of_int(-1), add_big_int bi2 bi1) else (big_int_of_int 1, sub_big_int bi1 bi2) | 0 -> (big_int_of_int (bi1.sign * bi2.sign), zero_big_int) | _ -> let bi1_negatif = bi1.sign = -1 in let size_q = if bi1_negatif then succ (max (succ (size_bi1 - size_bi2)) 1) else max (succ (size_bi1 - size_bi2)) 1 and size_r = succ (max size_bi1 size_bi2) (* r is long enough to contain both quotient and remainder *) (* of the euclidian division *) in (* set up quotient, remainder *) let q = create_nat size_q and r = create_nat size_r in blit_nat r 0 (bi1.abs_value) 0 size_bi1; set_to_zero_nat r size_bi1 (size_r - size_bi1); (* do the division of |bi1| by |bi2| - at the beginning, r contains |bi1| - at the end, r contains * in the size_bi2 least significant digits, the remainder * in the size_r-size_bi2 most significant digits, the quotient note the conditions for application of div_nat are verified here *) div_nat r 0 size_r (bi2.abs_value) 0 size_bi2; (* separate quotient and remainder *) blit_nat q 0 r size_bi2 (size_r - size_bi2); let not_null_mod = not (is_zero_nat r 0 size_bi2) in (* correct the signs, adjusting the quotient and remainder *) if bi1_negatif && not_null_mod then (* bi1<0, r>0, noting r for (r, size_bi2) the remainder, *) (* we have |bi1|=q * |bi2| + r with 0 < r < |bi2|, *) (* thus -bi1 = q * |bi2| + r *) (* and bi1 = (-q) * |bi2| + (-r) with -|bi2| < (-r) < 0 *) (* thus bi1 = -(q+1) * |bi2| + (|bi2|-r) *) (* with 0 < (|bi2|-r) < |bi2| *) (* so the quotient has for sign the opposite of the bi2'one *) (* and for value q+1 *) (* and the remainder is strictly positive *) (* has for value |bi2|-r *) (let new_r = copy_nat (bi2.abs_value) 0 size_bi2 in (* new_r contains (r, size_bi2) the remainder *) { sign = - bi2.sign; abs_value = (set_digit_nat q (pred size_q) 0; ignore (incr_nat q 0 size_q 1); q) }, { sign = 1; abs_value = (ignore (sub_nat new_r 0 size_bi2 r 0 size_bi2 1); new_r) }) else (if bi1_negatif then set_digit_nat q (pred size_q) 0; { sign = if is_zero_nat q 0 size_q then 0 else bi1.sign * bi2.sign; abs_value = q }, { sign = if not_null_mod then 1 else 0; abs_value = copy_nat r 0 size_bi2 }) let div_big_int bi1 bi2 = fst (quomod_big_int bi1 bi2) and mod_big_int bi1 bi2 = snd (quomod_big_int bi1 bi2) let gcd_big_int bi1 bi2 = let size_bi1 = num_digits_big_int bi1 and size_bi2 = num_digits_big_int bi2 in if is_zero_nat (bi1.abs_value) 0 size_bi1 then abs_big_int bi2 else if is_zero_nat (bi2.abs_value) 0 size_bi2 then { sign = 1; abs_value = bi1.abs_value } else { sign = 1; abs_value = match compare_nat (bi1.abs_value) 0 size_bi1 (bi2.abs_value) 0 size_bi2 with 0 -> bi1.abs_value | 1 -> let res = copy_nat (bi1.abs_value) 0 size_bi1 in let len = gcd_nat res 0 size_bi1 (bi2.abs_value) 0 size_bi2 in copy_nat res 0 len | _ -> let res = copy_nat (bi2.abs_value) 0 size_bi2 in let len = gcd_nat res 0 size_bi2 (bi1.abs_value) 0 size_bi1 in copy_nat res 0 len } (* Coercion operators *) let monster_big_int = big_int_of_int monster_int;; let monster_nat = monster_big_int.abs_value;; let is_int_big_int bi = num_digits_big_int bi == 1 && match compare_nat bi.abs_value 0 1 monster_nat 0 1 with | 0 -> bi.sign == -1 | -1 -> true | _ -> false;; let int_of_big_int bi = try let n = int_of_nat bi.abs_value in if bi.sign = -1 then - n else n with Failure _ -> if eq_big_int bi monster_big_int then monster_int else failwith "int_of_big_int";; let big_int_of_nativeint i = if i = 0n then zero_big_int else if i > 0n then begin let res = create_nat 1 in set_digit_nat_native res 0 i; { sign = 1; abs_value = res } end else begin let res = create_nat 1 in set_digit_nat_native res 0 (Nativeint.neg i); { sign = -1; abs_value = res } end let nativeint_of_big_int bi = if num_digits_big_int bi > 1 then failwith "nativeint_of_big_int"; let i = nth_digit_nat_native bi.abs_value 0 in if bi.sign >= 0 then if i >= 0n then i else failwith "nativeint_of_big_int" else if i >= 0n || i = Nativeint.min_int then Nativeint.neg i else failwith "nativeint_of_big_int" let big_int_of_int32 i = big_int_of_nativeint (Nativeint.of_int32 i) let int32_of_big_int bi = let i = nativeint_of_big_int bi in if i <= 0x7FFF_FFFFn && i >= -0x8000_0000n then Nativeint.to_int32 i else failwith "int32_of_big_int" let big_int_of_int64 i = if Sys.word_size = 64 then big_int_of_nativeint (Int64.to_nativeint i) else begin let (sg, absi) = if i = 0L then (0, 0L) else if i > 0L then (1, i) else (-1, Int64.neg i) in let res = create_nat 2 in set_digit_nat_native res 0 (Int64.to_nativeint absi); set_digit_nat_native res 1 (Int64.to_nativeint (Int64.shift_right absi 32)); { sign = sg; abs_value = res } end let int64_of_big_int bi = if Sys.word_size = 64 then Int64.of_nativeint (nativeint_of_big_int bi) else begin let i = match num_digits_big_int bi with | 1 -> Int64.logand (Int64.of_nativeint (nth_digit_nat_native bi.abs_value 0)) 0xFFFFFFFFL | 2 -> Int64.logor (Int64.logand (Int64.of_nativeint (nth_digit_nat_native bi.abs_value 0)) 0xFFFFFFFFL) (Int64.shift_left (Int64.of_nativeint (nth_digit_nat_native bi.abs_value 1)) 32) | _ -> failwith "int64_of_big_int" in if bi.sign >= 0 then if i >= 0L then i else failwith "int64_of_big_int" else if i >= 0L || i = Int64.min_int then Int64.neg i else failwith "int64_of_big_int" end (* Coercion with nat type *) let nat_of_big_int bi = if bi.sign = -1 then failwith "nat_of_big_int" else copy_nat (bi.abs_value) 0 (num_digits_big_int bi) let sys_big_int_of_nat nat off len = let length = num_digits_nat nat off len in { sign = if is_zero_nat nat off length then 0 else 1; abs_value = copy_nat nat off length } let big_int_of_nat nat = sys_big_int_of_nat nat 0 (length_nat nat) (* Coercion with string type *) let string_of_big_int bi = if bi.sign = -1 then "-" ^ string_of_nat bi.abs_value else string_of_nat bi.abs_value let sys_big_int_of_string_aux s ofs len sgn = if len < 1 then failwith "sys_big_int_of_string"; let n = sys_nat_of_string 10 s ofs len in if is_zero_nat n 0 (length_nat n) then zero_big_int else {sign = sgn; abs_value = n} ;; let sys_big_int_of_string s ofs len = if len < 1 then failwith "sys_big_int_of_string"; match s.[ofs] with | '-' -> sys_big_int_of_string_aux s (ofs+1) (len-1) (-1) | '+' -> sys_big_int_of_string_aux s (ofs+1) (len-1) 1 | _ -> sys_big_int_of_string_aux s ofs len 1 ;; let big_int_of_string s = sys_big_int_of_string s 0 (String.length s) let power_base_nat base nat off len = if base = 0 then nat_of_int 0 else if is_zero_nat nat off len || base = 1 then nat_of_int 1 else let power_base = make_nat (succ length_of_digit) in let (pmax, pint) = make_power_base base power_base in let (n, rem) = let (x, y) = quomod_big_int (sys_big_int_of_nat nat off len) (big_int_of_int (succ pmax)) in (int_of_big_int x, int_of_big_int y) in if n = 0 then copy_nat power_base (pred rem) 1 else begin let res = make_nat n and res2 = make_nat (succ n) and l = num_bits_int n - 2 in let p = ref (1 lsl l) in blit_nat res 0 power_base pmax 1; for i = l downto 0 do let len = num_digits_nat res 0 n in let len2 = min n (2 * len) in let succ_len2 = succ len2 in ignore (square_nat res2 0 len2 res 0 len); begin if n land !p > 0 then (set_to_zero_nat res 0 len; ignore (mult_digit_nat res 0 succ_len2 res2 0 len2 power_base pmax)) else blit_nat res 0 res2 0 len2 end; set_to_zero_nat res2 0 len2; p := !p lsr 1 done; if rem > 0 then (ignore (mult_digit_nat res2 0 (succ n) res 0 n power_base (pred rem)); res2) else res end let power_int_positive_int i n = match sign_int n with 0 -> unit_big_int | -1 -> invalid_arg "power_int_positive_int" | _ -> let nat = power_base_int (abs i) n in { sign = if i >= 0 then sign_int i else if n land 1 = 0 then 1 else -1; abs_value = nat} let power_big_int_positive_int bi n = match sign_int n with 0 -> unit_big_int | -1 -> invalid_arg "power_big_int_positive_int" | _ -> let bi_len = num_digits_big_int bi in let res_len = bi_len * n in let res = make_nat res_len and res2 = make_nat res_len and l = num_bits_int n - 2 in let p = ref (1 lsl l) in blit_nat res 0 bi.abs_value 0 bi_len; for i = l downto 0 do let len = num_digits_nat res 0 res_len in let len2 = min res_len (2 * len) in set_to_zero_nat res2 0 len2; ignore (square_nat res2 0 len2 res 0 len); if n land !p > 0 then begin let lenp = min res_len (len2 + bi_len) in set_to_zero_nat res 0 lenp; ignore(mult_nat res 0 lenp res2 0 len2 (bi.abs_value) 0 bi_len) end else begin blit_nat res 0 res2 0 len2 end; p := !p lsr 1 done; {sign = if bi.sign >= 0 then bi.sign else if n land 1 = 0 then 1 else -1; abs_value = res} let power_int_positive_big_int i bi = match sign_big_int bi with 0 -> unit_big_int | -1 -> invalid_arg "power_int_positive_big_int" | _ -> let nat = power_base_nat (abs i) (bi.abs_value) 0 (num_digits_big_int bi) in { sign = if i >= 0 then sign_int i else if is_digit_odd (bi.abs_value) 0 then -1 else 1; abs_value = nat } let power_big_int_positive_big_int bi1 bi2 = match sign_big_int bi2 with 0 -> unit_big_int | -1 -> invalid_arg "power_big_int_positive_big_int" | _ -> try power_big_int_positive_int bi1 (int_of_big_int bi2) with Failure _ -> try power_int_positive_big_int (int_of_big_int bi1) bi2 with Failure _ -> raise Out_of_memory (* If neither bi1 nor bi2 is a small integer, bi1^bi2 is not representable. Indeed, on a 32-bit platform, |bi1| >= 2 and |bi2| >= 2^30, hence bi1^bi2 has at least 2^30 bits = 2^27 bytes, greater than the max size of allocated blocks. On a 64-bit platform, |bi1| >= 2 and |bi2| >= 2^62, hence bi1^bi2 has at least 2^62 bits = 2^59 bytes, greater than the max size of allocated blocks. *) (* base_power_big_int compute bi*base^n *) let base_power_big_int base n bi = match sign_int n with 0 -> bi | -1 -> let nat = power_base_int base (-n) in let len_nat = num_digits_nat nat 0 (length_nat nat) and len_bi = num_digits_big_int bi in if len_bi < len_nat then invalid_arg "base_power_big_int" else if len_bi = len_nat && compare_digits_nat (bi.abs_value) len_bi nat len_nat = -1 then invalid_arg "base_power_big_int" else let copy = create_nat (succ len_bi) in blit_nat copy 0 (bi.abs_value) 0 len_bi; set_digit_nat copy len_bi 0; div_nat copy 0 (succ len_bi) nat 0 len_nat; if not (is_zero_nat copy 0 len_nat) then invalid_arg "base_power_big_int" else { sign = bi.sign; abs_value = copy_nat copy len_nat 1 } | _ -> let nat = power_base_int base n in let len_nat = num_digits_nat nat 0 (length_nat nat) and len_bi = num_digits_big_int bi in let new_len = len_bi + len_nat in let res = make_nat new_len in ignore (if len_bi > len_nat then mult_nat res 0 new_len (bi.abs_value) 0 len_bi nat 0 len_nat else mult_nat res 0 new_len nat 0 len_nat (bi.abs_value) 0 len_bi) ; if is_zero_nat res 0 new_len then zero_big_int else create_big_int (bi.sign) res (* Coercion with float type *) let float_of_big_int bi = float_of_string (string_of_big_int bi) (* XL: suppression de big_int_of_float et nat_of_float. *) (* Other functions needed *) (* Integer part of the square root of a big_int *) let sqrt_big_int bi = match bi.sign with | 0 -> zero_big_int | -1 -> invalid_arg "sqrt_big_int" | _ -> {sign = 1; abs_value = sqrt_nat (bi.abs_value) 0 (num_digits_big_int bi)} let square_big_int bi = if bi.sign == 0 then zero_big_int else let len_bi = num_digits_big_int bi in let len_res = 2 * len_bi in let res = make_nat len_res in ignore (square_nat res 0 len_res (bi.abs_value) 0 len_bi); {sign = 1; abs_value = res} (* round off of the futur last digit (of the integer represented by the string argument of the function) that is now the previous one. if s contains an integer of the form (10^n)-1 then s <- only 0 digits and the result_int is true else s <- the round number and the result_int is false *) let round_futur_last_digit s off_set length = let l = pred (length + off_set) in if Char.code(String.get s l) >= Char.code '5' then let rec round_rec l = if l < off_set then true else begin let current_char = String.get s l in if current_char = '9' then (String.set s l '0'; round_rec (pred l)) else (String.set s l (Char.chr (succ (Char.code current_char))); false) end in round_rec (pred l) else false (* Approximation with floating decimal point a` la approx_ratio_exp *) let approx_big_int prec bi = let len_bi = num_digits_big_int bi in let n = max 0 (int_of_big_int ( add_int_big_int (-prec) (div_big_int (mult_big_int (big_int_of_int (pred len_bi)) (big_int_of_string "963295986")) (big_int_of_string "100000000")))) in let s = string_of_big_int (div_big_int bi (power_int_positive_int 10 n)) in let (sign, off, len) = if String.get s 0 = '-' then ("-", 1, succ prec) else ("", 0, prec) in if (round_futur_last_digit s off (succ prec)) then (sign^"1."^(String.make prec '0')^"e"^ (string_of_int (n + 1 - off + String.length s))) else (sign^(String.sub s off 1)^"."^ (String.sub s (succ off) (pred prec)) ^"e"^(string_of_int (n - succ off + String.length s))) (* Logical operations *) (* Shift left by N bits *) let shift_left_big_int bi n = if n < 0 then invalid_arg "shift_left_big_int" else if n = 0 then bi else if bi.sign = 0 then bi else begin let size_bi = num_digits_big_int bi in let size_res = size_bi + ((n + length_of_digit - 1) / length_of_digit) in let res = create_nat size_res in let ndigits = n / length_of_digit in set_to_zero_nat res 0 ndigits; blit_nat res ndigits bi.abs_value 0 size_bi; let nbits = n mod length_of_digit in if nbits > 0 then shift_left_nat res ndigits size_bi res (ndigits + size_bi) nbits; { sign = bi.sign; abs_value = res } end (* Shift right by N bits (rounds toward zero) *) let shift_right_towards_zero_big_int bi n = if n < 0 then invalid_arg "shift_right_towards_zero_big_int" else if n = 0 then bi else if bi.sign = 0 then bi else begin let size_bi = num_digits_big_int bi in let ndigits = n / length_of_digit in let nbits = n mod length_of_digit in if ndigits >= size_bi then zero_big_int else begin let size_res = size_bi - ndigits in let res = create_nat size_res in blit_nat res 0 bi.abs_value ndigits size_res; if nbits > 0 then begin let tmp = create_nat 1 in shift_right_nat res 0 size_res tmp 0 nbits end; if is_zero_nat res 0 size_res then zero_big_int else { sign = bi.sign; abs_value = res } end end (* Compute 2^n - 1 *) let two_power_m1_big_int n = if n < 0 then invalid_arg "two_power_m1_big_int" else if n = 0 then zero_big_int else begin let size_res = (n + length_of_digit - 1) / length_of_digit in let res = make_nat size_res in set_digit_nat_native res (n / length_of_digit) (Nativeint.shift_left 1n (n mod length_of_digit)); ignore (decr_nat res 0 size_res 0); { sign = 1; abs_value = res } end (* Shift right by N bits (rounds toward minus infinity) *) let shift_right_big_int bi n = if n < 0 then invalid_arg "shift_right_big_int" else if bi.sign >= 0 then shift_right_towards_zero_big_int bi n else shift_right_towards_zero_big_int (sub_big_int bi (two_power_m1_big_int n)) n (* Extract N bits starting at ofs. Treats bi in two's complement. Result is always positive. *) let extract_big_int bi ofs n = if ofs < 0 || n < 0 then invalid_arg "extract_big_int" else if bi.sign = 0 then bi else begin let size_bi = num_digits_big_int bi in let size_res = (n + length_of_digit - 1) / length_of_digit in let ndigits = ofs / length_of_digit in let nbits = ofs mod length_of_digit in let res = make_nat size_res in if ndigits < size_bi then blit_nat res 0 bi.abs_value ndigits (min size_res (size_bi - ndigits)); if bi.sign < 0 then begin (* Two's complement *) complement_nat res 0 size_res; ignore (incr_nat res 0 size_res 1) end; if nbits > 0 then begin let tmp = create_nat 1 in shift_right_nat res 0 size_res tmp 0 nbits end; let n' = n mod length_of_digit in if n' > 0 then begin let tmp = create_nat 1 in set_digit_nat_native tmp 0 (Nativeint.shift_right_logical (-1n) (length_of_digit - n')); land_digit_nat res (size_res - 1) tmp 0 end; if is_zero_nat res 0 size_res then zero_big_int else { sign = 1; abs_value = res } end (* Bitwise logical operations. Arguments must be >= 0. *) let and_big_int a b = if a.sign < 0 || b.sign < 0 then invalid_arg "and_big_int" else if a.sign = 0 || b.sign = 0 then zero_big_int else begin let size_a = num_digits_big_int a and size_b = num_digits_big_int b in let size_res = min size_a size_b in let res = create_nat size_res in blit_nat res 0 a.abs_value 0 size_res; for i = 0 to size_res - 1 do land_digit_nat res i b.abs_value i done; if is_zero_nat res 0 size_res then zero_big_int else { sign = 1; abs_value = res } end let or_big_int a b = if a.sign < 0 || b.sign < 0 then invalid_arg "or_big_int" else if a.sign = 0 then b else if b.sign = 0 then a else begin let size_a = num_digits_big_int a and size_b = num_digits_big_int b in let size_res = max size_a size_b in let res = create_nat size_res in let or_aux a' b' size_b' = blit_nat res 0 a'.abs_value 0 size_res; for i = 0 to size_b' - 1 do lor_digit_nat res i b'.abs_value i done in if size_a >= size_b then or_aux a b size_b else or_aux b a size_a; if is_zero_nat res 0 size_res then zero_big_int else { sign = 1; abs_value = res } end let xor_big_int a b = if a.sign < 0 || b.sign < 0 then invalid_arg "xor_big_int" else if a.sign = 0 then b else if b.sign = 0 then a else begin let size_a = num_digits_big_int a and size_b = num_digits_big_int b in let size_res = max size_a size_b in let res = create_nat size_res in let xor_aux a' b' size_b' = blit_nat res 0 a'.abs_value 0 size_res; for i = 0 to size_b' - 1 do lxor_digit_nat res i b'.abs_value i done in if size_a >= size_b then xor_aux a b size_b else xor_aux b a size_a; if is_zero_nat res 0 size_res then zero_big_int else { sign = 1; abs_value = res } end mingw-ocaml/ocaml/otherlibs/num/Makefile.nt0000644000175000017500000000262712124403241020337 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ # Makefile for the "num" (exact rational arithmetic) library LIBNAME=nums EXTRACFLAGS=-DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL) CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \ ratio.cmo num.cmo arith_status.cmo CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi COBJS=bng.$(O) nat_stubs.$(O) include ../Makefile.nt clean:: rm -f *~ bng.$(O): bng.h bng_digit.c \ bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c depend: sed -e 's/\.o/.$(O)/g' .depend > .depend.nt include .depend.nt mingw-ocaml/ocaml/otherlibs/num/README0000644000175000017500000000372612124403241017140 0ustar tootstootsThe "libnum" library implements exact-precision arithmetic on big integers and on rationals. This library is derived from Valerie Menissie-Morain's implementation of rational arithmetic for Caml V3.1 (INRIA). Xavier Leroy (INRIA) did the Caml Light port. Victor Manuel Gulias Fernandez did the initial Caml Special Light port. Pierre Weis did most of the maintenance and bug fixing. Initially, the low-level big integer operations were provided by the BigNum package developed by Bernard Serpette, Jean Vuillemin and Jean-Claude Herve (INRIA and Digital PRL). License issues forced us to replace the BigNum package. The current implementation of low-level big integer operations is due to Xavier Leroy. This library is documented in "The CAML Numbers Reference Manual" by Valerie Menissier-Morain, technical report 141, INRIA, july 1992, available at ftp://ftp.inria.fr/INRIA/publication/RT/RT-0141.ps.gz USAGE: To use the bignum library from your programs, just do ocamlc nums.cma <.cmo and .ml files> or ocamlopt nums.cmxa <.cmx and .ml files> for the linking phase. If you'd like to have the bignum functions available at toplevel, do ocamlmktop -o ocamltopnum nums.cma <.cmo and .ml files> ./ocamltopnum As an example, try: open Num;; let rec fact n = if n = 0 then Int 1 else mult_num (num_of_int n) (fact(n-1));; string_of_num(fact 1000);; PROCESSOR-SPECIFIC OPTIMIZATIONS: When compiled with GCC, the low-level primitives use "inline extended asm" to exploit useful features of the target processor (additions and subtractions with carry; double-width multiplication, division). Here are the processors for which such optimizations are available: IA32 (x86) (carry, dwmult, dwdiv, 64-bit ops with SSE2 if available) AMD64 (Opteron) (carry, dwmult, dwdiv) PowerPC (carry, dwmult) Alpha (dwmult) SPARC (carry, dwmult, dwdiv) MIPS (dwmult) mingw-ocaml/ocaml/otherlibs/num/arith_status.mli0000644000175000017500000000556512124403241021500 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Flags that control rational arithmetic. *) val arith_status: unit -> unit (** Print the current status of the arithmetic flags. *) val get_error_when_null_denominator : unit -> bool (** See {!Arith_status.set_error_when_null_denominator}.*) val set_error_when_null_denominator : bool -> unit (** Get or set the flag [null_denominator]. When on, attempting to create a rational with a null denominator raises an exception. When off, rationals with null denominators are accepted. Initially: on. *) val get_normalize_ratio : unit -> bool (** See {!Arith_status.set_normalize_ratio}.*) val set_normalize_ratio : bool -> unit (** Get or set the flag [normalize_ratio]. When on, rational numbers are normalized after each operation. When off, rational numbers are not normalized until printed. Initially: off. *) val get_normalize_ratio_when_printing : unit -> bool (** See {!Arith_status.set_normalize_ratio_when_printing}.*) val set_normalize_ratio_when_printing : bool -> unit (** Get or set the flag [normalize_ratio_when_printing]. When on, rational numbers are normalized before being printed. When off, rational numbers are printed as is, without normalization. Initially: on. *) val get_approx_printing : unit -> bool (** See {!Arith_status.set_approx_printing}.*) val set_approx_printing : bool -> unit (** Get or set the flag [approx_printing]. When on, rational numbers are printed as a decimal approximation. When off, rational numbers are printed as a fraction. Initially: off. *) val get_floating_precision : unit -> int (** See {!Arith_status.set_floating_precision}.*) val set_floating_precision : int -> unit (** Get or set the parameter [floating_precision]. This parameter is the number of digits displayed when [approx_printing] is on. Initially: 12. *) mingw-ocaml/ocaml/otherlibs/num/bng_ia32.c0000644000175000017500000003177312124403241020013 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2003 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Code specific to the Intel IA32 (x86) architecture. */ #define BngAdd2(res,carryout,arg1,arg2) \ asm("xorl %1, %1 \n\t" \ "addl %3, %0 \n\t" \ "setc %b1" \ : "=r" (res), "=&q" (carryout) \ : "0" (arg1), "rm" (arg2)) #define BngSub2(res,carryout,arg1,arg2) \ asm("xorl %1, %1 \n\t" \ "subl %3, %0 \n\t" \ "setc %b1" \ : "=r" (res), "=&q" (carryout) \ : "0" (arg1), "rm" (arg2)) #define BngMult(resh,resl,arg1,arg2) \ asm("mull %3" \ : "=a" (resl), "=d" (resh) \ : "a" (arg1), "r" (arg2)) #define BngDiv(quo,rem,nh,nl,d) \ asm("divl %4" \ : "=a" (quo), "=d" (rem) \ : "a" (nl), "d" (nh), "r" (d)) /* Reimplementation in asm of some of the bng operations. */ static bngcarry bng_ia32_add (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngcarry carry) { bngdigit tmp; alen -= blen; if (blen > 0) { asm("negb %b3 \n\t" "1: \n\t" "movl (%0), %4 \n\t" "adcl (%1), %4 \n\t" "movl %4, (%0) \n\t" "leal 4(%0), %0 \n\t" "leal 4(%1), %1 \n\t" "decl %2 \n\t" "jnz 1b \n\t" "setc %b3" : "+&r" (a), "+&r" (b), "+&r" (blen), "+&q" (carry), "=&r" (tmp)); } if (carry == 0 || alen == 0) return carry; do { if (++(*a) != 0) return 0; a++; } while (--alen); return 1; } static bngcarry bng_ia32_sub (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngcarry carry) { bngdigit tmp; alen -= blen; if (blen > 0) { asm("negb %b3 \n\t" "1: \n\t" "movl (%0), %4 \n\t" "sbbl (%1), %4 \n\t" "movl %4, (%0) \n\t" "leal 4(%0), %0 \n\t" "leal 4(%1), %1 \n\t" "decl %2 \n\t" "jnz 1b \n\t" "setc %b3" : "+&r" (a), "+&r" (b), "+&r" (blen), "+&q" (carry), "=&r" (tmp)); } if (carry == 0 || alen == 0) return carry; do { if ((*a)-- != 0) return 0; a++; } while (--alen); return 1; } static bngdigit bng_ia32_mult_add_digit (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngdigit d) { bngdigit out; bngcarry carry; alen -= blen; out = 0; if (blen > 0) { asm("1: \n\t" "movl (%1), %%eax \n\t" "mull %4\n\t" /* edx:eax = d * next digit of b */ "addl (%0), %%eax \n\t" /* add next digit of a to eax */ "adcl $0, %%edx \n\t" /* accumulate carry in edx */ "addl %3, %%eax \n\t" /* add out to eax */ "adcl $0, %%edx \n\t" /* accumulate carry in edx */ "movl %%eax, (%0) \n\t" /* eax is next digit of result */ "movl %%edx, %3 \n\t" /* edx is next out */ "leal 4(%0), %0 \n\t" "leal 4(%1), %1 \n\t" "decl %2 \n\t" "jnz 1b" : "+&r" (a), "+&r" (b), "+&r" (blen), "=m" (out) : "m" (d) : "eax", "edx"); } if (alen == 0) return out; /* current digit of a += out */ BngAdd2(*a, carry, *a, out); a++; alen--; /* Propagate carry */ if (carry == 0 || alen == 0) return carry; do { if (++(*a) != 0) return 0; a++; } while (--alen); return 1; } static bngdigit bng_ia32_mult_sub_digit (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngdigit d) { bngdigit out, tmp; bngcarry carry; alen -= blen; out = 0; if (blen > 0) { asm("1: \n\t" "movl (%1), %%eax \n\t" "movl (%0), %4 \n\t" "mull %5\n\t" /* edx:eax = d * next digit of b */ "subl %%eax, %4 \n\t" /* subtract eax from next digit of a */ "adcl $0, %%edx \n\t" /* accumulate carry in edx */ "subl %3, %4 \n\t" /* subtract out */ "adcl $0, %%edx \n\t" /* accumulate carry in edx */ "movl %4, (%0) \n\t" /* store next digit of result */ "movl %%edx, %3 \n\t" /* edx is next out */ "leal 4(%0), %0 \n\t" "leal 4(%1), %1 \n\t" "decl %2 \n\t" "jnz 1b" : "+&r" (a), "+&r" (b), "=m" (blen), "=m" (out), "=&r" (tmp) : "m" (d) : "eax", "edx"); } if (alen == 0) return out; /* current digit of a -= out */ BngSub2(*a, carry, *a, out); a++; alen--; /* Propagate carry */ if (carry == 0 || alen == 0) return carry; do { if ((*a)-- != 0) return 0; a++; } while (--alen); return 1; } /* This is another asm implementation of some of the bng operations, using SSE2 operations to provide 64-bit arithmetic. This is faster than the plain IA32 code above on the Pentium 4. (Arithmetic operations with carry are slow on the Pentium 4). */ #if BNG_ASM_LEVEL >= 2 static bngcarry bng_ia32sse2_add (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngcarry carry) { alen -= blen; if (blen > 0) { asm("movd %3, %%mm0 \n\t" /* MM0 is carry */ "1: \n\t" "movd (%0), %%mm1 \n\t" /* MM1 is next digit of a */ "movd (%1), %%mm2 \n\t" /* MM2 is next digit of b */ "paddq %%mm1, %%mm0 \n\t" /* Add carry (64 bits) */ "paddq %%mm2, %%mm0 \n\t" /* Add digits (64 bits) */ "movd %%mm0, (%0) \n\t" /* Store low 32 bits of result */ "psrlq $32, %%mm0 \n\t" /* Next carry is top 32 bits of results */ "addl $4, %0\n\t" "addl $4, %1\n\t" "subl $1, %2\n\t" "jne 1b \n\t" "movd %%mm0, %3 \n\t" "emms" : "+&r" (a), "+&r" (b), "+&r" (blen), "+&rm" (carry)); } if (carry == 0 || alen == 0) return carry; do { if (++(*a) != 0) return 0; a++; } while (--alen); return 1; } static bngcarry bng_ia32sse2_sub (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngcarry carry) { alen -= blen; if (blen > 0) { asm("movd %3, %%mm0 \n\t" /* MM0 is carry */ "1: \n\t" "movd (%0), %%mm1 \n\t" /* MM1 is next digit of a */ "movd (%1), %%mm2 \n\t" /* MM2 is next digit of b */ "psubq %%mm0, %%mm1 \n\t" /* Subtract carry (64 bits) */ "psubq %%mm2, %%mm1 \n\t" /* Subtract digits (64 bits) */ "movd %%mm1, (%0) \n\t" /* Store low 32 bits of result */ "psrlq $63, %%mm1 \n\t" /* Next carry is sign bit of result */ "movq %%mm1, %%mm0 \n\t" "addl $4, %0\n\t" "addl $4, %1\n\t" "subl $1, %2\n\t" "jne 1b \n\t" "movd %%mm0, %3 \n\t" "emms" : "+&r" (a), "+&r" (b), "+&r" (blen), "+&rm" (carry)); } if (carry == 0 || alen == 0) return carry; do { if ((*a)-- != 0) return 0; a++; } while (--alen); return 1; } static bngdigit bng_ia32sse2_mult_add_digit (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngdigit d) { bngdigit out; bngcarry carry; alen -= blen; out = 0; if (blen > 0) { asm("pxor %%mm0, %%mm0 \n\t" /* MM0 is carry */ "movd %4, %%mm7 \n\t" /* MM7 is digit d */ "1: \n\t" "movd (%0), %%mm1 \n\t" /* MM1 is next digit of a */ "movd (%1), %%mm2 \n\t" /* MM2 is next digit of b */ "pmuludq %%mm7, %%mm2 \n\t" /* MM2 = d * digit of b */ "paddq %%mm1, %%mm0 \n\t" /* Add product and carry ... */ "paddq %%mm2, %%mm0 \n\t" /* ... and digit of a */ "movd %%mm0, (%0) \n\t" /* Store low 32 bits of result */ "psrlq $32, %%mm0 \n\t" /* Next carry is high 32 bits result */ "addl $4, %0\n\t" "addl $4, %1\n\t" "subl $1, %2\n\t" "jne 1b \n\t" "movd %%mm0, %3 \n\t" "emms" : "+&r" (a), "+&r" (b), "+&r" (blen), "=&rm" (out) : "m" (d)); } if (alen == 0) return out; /* current digit of a += out */ BngAdd2(*a, carry, *a, out); a++; alen--; /* Propagate carry */ if (carry == 0 || alen == 0) return carry; do { if (++(*a) != 0) return 0; a++; } while (--alen); return 1; } static bngdigit bng_ia32sse2_mult_sub_digit (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngdigit d) { static unsigned long long bias1 = 0xFFFFFFFF00000000ULL - 0xFFFFFFFFULL; static unsigned long bias2 = 0xFFFFFFFFUL; bngdigit out; bngcarry carry; alen -= blen; out = 0; if (blen > 0) { /* Carry C is represented by ENC(C) = 0xFFFFFFFF - C (one's complement) */ asm("movd %6, %%mm0 \n\t" /* MM0 is carry (initially 0xFFFFFFFF) */ "movq %5, %%mm6 \n\t" /* MM6 is magic constant bias1 */ "movd %4, %%mm7 \n\t" /* MM7 is digit d */ "1: \n\t" "movd (%0), %%mm1 \n\t" /* MM1 is next digit of a */ "movd (%1), %%mm2 \n\t" /* MM2 is next digit of b */ "paddq %%mm6, %%mm1 \n\t" /* bias digit of a */ "pmuludq %%mm7, %%mm2 \n\t" /* MM2 = d * digit of b */ /* Compute digit of a + ENC(carry) + 0xFFFFFFFF00000000 - 0xFFFFFFFF - product = digit of a - carry + 0xFFFFFFFF00000000 - product = digit of a - carry - productlow + (ENC(nextcarry) << 32) */ "psubq %%mm2, %%mm1 \n\t" "paddq %%mm1, %%mm0 \n\t" "movd %%mm0, (%0) \n\t" /* Store low 32 bits of result */ "psrlq $32, %%mm0 \n\t" /* Next carry is 32 high bits of result */ "addl $4, %0\n\t" "addl $4, %1\n\t" "subl $1, %2\n\t" "jne 1b \n\t" "movd %%mm0, %3 \n\t" "emms" : "+&r" (a), "+&r" (b), "+&r" (blen), "=&rm" (out) : "m" (d), "m" (bias1), "m" (bias2)); out = ~out; /* Undo encoding on out digit */ } if (alen == 0) return out; /* current digit of a -= out */ BngSub2(*a, carry, *a, out); a++; alen--; /* Propagate carry */ if (carry == 0 || alen == 0) return carry; do { if ((*a)-- != 0) return 0; a++; } while (--alen); return 1; } /* Detect whether SSE2 instructions are supported */ static int bng_ia32_sse2_supported(void) { unsigned int flags, newflags, max_id, capabilities; #define EFLAG_CPUID 0x00200000 #define CPUID_IDENTIFY 0 #define CPUID_CAPABILITIES 1 #define SSE2_CAPABILITY 26 /* Check if processor has CPUID instruction */ asm("pushfl \n\t" "popl %0" : "=r" (flags) : ); newflags = flags ^ EFLAG_CPUID; /* CPUID detection flag */ asm("pushfl \n\t" "pushl %1 \n\t" "popfl \n\t" "pushfl \n\t" "popl %0 \n\t" "popfl" : "=r" (flags) : "r" (newflags)); /* If CPUID detection flag cannot be changed, CPUID instruction is not available */ if ((flags & EFLAG_CPUID) != (newflags & EFLAG_CPUID)) return 0; /* See if SSE2 extensions are supported */ asm("pushl %%ebx \n\t" /* need to preserve %ebx for PIC */ "cpuid \n\t" "popl %%ebx" : "=a" (max_id) : "a" (CPUID_IDENTIFY): "ecx", "edx"); if (max_id < 1) return 0; asm("pushl %%ebx \n\t" "cpuid \n\t" "popl %%ebx" : "=d" (capabilities) : "a" (CPUID_CAPABILITIES) : "ecx"); return capabilities & (1 << SSE2_CAPABILITY); } #endif static void bng_ia32_setup_ops(void) { #if BNG_ASM_LEVEL >= 2 if (bng_ia32_sse2_supported()) { bng_ops.add = bng_ia32sse2_add; bng_ops.sub = bng_ia32sse2_sub; bng_ops.mult_add_digit = bng_ia32sse2_mult_add_digit; bng_ops.mult_sub_digit = bng_ia32sse2_mult_sub_digit; return; } #endif bng_ops.add = bng_ia32_add; bng_ops.sub = bng_ia32_sub; bng_ops.mult_add_digit = bng_ia32_mult_add_digit; bng_ops.mult_sub_digit = bng_ia32_mult_sub_digit; } #define BNG_SETUP_OPS bng_ia32_setup_ops() mingw-ocaml/ocaml/otherlibs/num/ratio.mli0000644000175000017500000000756212124403241020103 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Operation on rational numbers. This module is used to support the implementation of {!Num} and should not be called directly. *) open Nat open Big_int (* Rationals (type [ratio]) are arbitrary-precision rational numbers, plus the special elements [1/0] (infinity) and [0/0] (undefined). In constrast with numbers (type [num]), the special cases of small integers and big integers are not optimized specially. *) type ratio (**/**) val null_denominator : ratio -> bool val numerator_ratio : ratio -> big_int val denominator_ratio : ratio -> big_int val sign_ratio : ratio -> int val normalize_ratio : ratio -> ratio val cautious_normalize_ratio : ratio -> ratio val cautious_normalize_ratio_when_printing : ratio -> ratio val create_ratio : big_int -> big_int -> ratio (* assumes nothing *) val create_normalized_ratio : big_int -> big_int -> ratio (* assumes normalized argument *) val is_normalized_ratio : ratio -> bool val report_sign_ratio : ratio -> big_int -> big_int val abs_ratio : ratio -> ratio val is_integer_ratio : ratio -> bool val add_ratio : ratio -> ratio -> ratio val minus_ratio : ratio -> ratio val add_int_ratio : int -> ratio -> ratio val add_big_int_ratio : big_int -> ratio -> ratio val sub_ratio : ratio -> ratio -> ratio val mult_ratio : ratio -> ratio -> ratio val mult_int_ratio : int -> ratio -> ratio val mult_big_int_ratio : big_int -> ratio -> ratio val square_ratio : ratio -> ratio val inverse_ratio : ratio -> ratio val div_ratio : ratio -> ratio -> ratio val integer_ratio : ratio -> big_int val floor_ratio : ratio -> big_int val round_ratio : ratio -> big_int val ceiling_ratio : ratio -> big_int val eq_ratio : ratio -> ratio -> bool val compare_ratio : ratio -> ratio -> int val lt_ratio : ratio -> ratio -> bool val le_ratio : ratio -> ratio -> bool val gt_ratio : ratio -> ratio -> bool val ge_ratio : ratio -> ratio -> bool val max_ratio : ratio -> ratio -> ratio val min_ratio : ratio -> ratio -> ratio val eq_big_int_ratio : big_int -> ratio -> bool val compare_big_int_ratio : big_int -> ratio -> int val lt_big_int_ratio : big_int -> ratio -> bool val le_big_int_ratio : big_int -> ratio -> bool val gt_big_int_ratio : big_int -> ratio -> bool val ge_big_int_ratio : big_int -> ratio -> bool val int_of_ratio : ratio -> int val ratio_of_int : int -> ratio val ratio_of_nat : nat -> ratio val nat_of_ratio : ratio -> nat val ratio_of_big_int : big_int -> ratio val big_int_of_ratio : ratio -> big_int val div_int_ratio : int -> ratio -> ratio val div_ratio_int : ratio -> int -> ratio val div_big_int_ratio : big_int -> ratio -> ratio val div_ratio_big_int : ratio -> big_int -> ratio val approx_ratio_fix : int -> ratio -> string val approx_ratio_exp : int -> ratio -> string val float_of_rational_string : ratio -> string val string_of_ratio : ratio -> string val ratio_of_string : string -> ratio val float_of_ratio : ratio -> float val power_ratio_positive_int : ratio -> int -> ratio val power_ratio_positive_big_int : ratio -> big_int -> ratio mingw-ocaml/ocaml/otherlibs/num/arith_flags.mli0000644000175000017500000000212012124403241021231 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) val error_when_null_denominator_flag : bool ref val normalize_ratio_flag : bool ref val normalize_ratio_when_printing_flag : bool ref val floating_precision : int ref val approx_printing_flag : bool ref mingw-ocaml/ocaml/otherlibs/num/bng_ppc.c0000644000175000017500000001257112124403241020032 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2003 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Code specific to the PowerPC architecture. */ #define BngAdd2(res,carryout,arg1,arg2) \ asm("addc %0, %2, %3 \n\t" \ "li %1, 0 \n\t" \ "addze %1, %1" \ : "=r" (res), "=r" (carryout) \ : "r" (arg1), "r" (arg2)) #define BngAdd2Carry(res,carryout,arg1,arg2,carryin) \ asm("addic %1, %4, -1 \n\t" \ "adde %0, %2, %3 \n\t" \ "li %1, 0 \n\t" \ "addze %1, %1" \ : "=r" (res), "=&r" (carryout) \ : "r" (arg1), "r" (arg2), "1" (carryin)) #define BngAdd3(res,carryaccu,arg1,arg2,arg3) \ asm("addc %0, %2, %3 \n\t" \ "addze %1, %1 \n\t" \ "addc %0, %0, %4 \n\t" \ "addze %1, %1" \ : "=&r" (res), "=&r" (carryaccu) \ : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu)) /* The "subtract" instructions interpret carry differently than what we need: the processor carry bit CA is 1 if no carry occured, 0 if a carry occured. In other terms, CA = !carry. Thus, subfe rd,ra,rb computes rd = ra - rb - !CA subfe rd,rd,rd sets rd = - !CA subfe rd,rd,rd; neg rd, rd sets rd = !CA and recovers "our" carry. */ #define BngSub2(res,carryout,arg1,arg2) \ asm("subfc %0, %3, %2 \n\t" \ "subfe %1, %1, %1\n\t" \ "neg %1, %1" \ : "=r" (res), "=r" (carryout) \ : "r" (arg1), "r" (arg2)) #define BngSub2Carry(res,carryout,arg1,arg2,carryin) \ asm("subfic %1, %4, 0 \n\t" \ "subfe %0, %3, %2 \n\t" \ "subfe %1, %1, %1 \n\t" \ "neg %1, %1" \ : "=r" (res), "=&r" (carryout) \ : "r" (arg1), "r" (arg2), "1" (carryin)) /* Here is what happens with carryaccu: neg %1, %1 carryaccu = -carryaccu addze %1, %1 carryaccu += !carry1 addze %1, %1 carryaccu += !carry2 subifc %1, %1, 2 carryaccu = 2 - carryaccu Thus, carryaccu_final = carryaccu_initial + 2 - (1 - carry1) - (1 - carry2) = carryaccu_initial + carry1 + carry2 */ #define BngSub3(res,carryaccu,arg1,arg2,arg3) \ asm("neg %1, %1 \n\t" \ "subfc %0, %3, %2 \n\t" \ "addze %1, %1 \n\t" \ "subfc %0, %4, %0 \n\t" \ "addze %1, %1 \n\t" \ "subfic %1, %1, 2 \n\t" \ : "=&r" (res), "=&r" (carryaccu) \ : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu)) #ifdef __ppc64__ #define BngMult(resh,resl,arg1,arg2) \ asm("mulld %0, %2, %3 \n\t" \ "mulhdu %1, %2, %3" \ : "=&r" (resl), "=r" (resh) \ : "r" (arg1), "r" (arg2)) #else #define BngMult(resh,resl,arg1,arg2) \ asm("mullw %0, %2, %3 \n\t" \ "mulhwu %1, %2, %3" \ : "=&r" (resl), "=r" (resh) \ : "r" (arg1), "r" (arg2)) #endif mingw-ocaml/ocaml/otherlibs/num/nums.mllib0000644000175000017500000000007012124403241020250 0ustar tootstootsInt_misc Nat Big_int Arith_flags Ratio Num Arith_status mingw-ocaml/ocaml/otherlibs/num/nat.ml0000644000175000017500000005321512124403241017372 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) open Int_misc type nat;; external create_nat: int -> nat = "create_nat" external set_to_zero_nat: nat -> int -> int -> unit = "set_to_zero_nat" external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat" external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat" external nth_digit_nat: nat -> int -> int = "nth_digit_nat" external set_digit_nat_native: nat -> int -> nativeint -> unit = "set_digit_nat_native" external nth_digit_nat_native: nat -> int -> nativeint = "nth_digit_nat_native" external num_digits_nat: nat -> int -> int -> int = "num_digits_nat" external num_leading_zero_bits_in_digit: nat -> int -> int = "num_leading_zero_bits_in_digit" external is_digit_int: nat -> int -> bool = "is_digit_int" external is_digit_zero: nat -> int -> bool = "is_digit_zero" external is_digit_normalized: nat -> int -> bool = "is_digit_normalized" external is_digit_odd: nat -> int -> bool = "is_digit_odd" external incr_nat: nat -> int -> int -> int -> int = "incr_nat" external add_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "add_nat" "add_nat_native" external complement_nat: nat -> int -> int -> unit = "complement_nat" external decr_nat: nat -> int -> int -> int -> int = "decr_nat" external sub_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "sub_nat" "sub_nat_native" external mult_digit_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int = "mult_digit_nat" "mult_digit_nat_native" external mult_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int -> int = "mult_nat" "mult_nat_native" external square_nat: nat -> int -> int -> nat -> int -> int -> int = "square_nat" "square_nat_native" external shift_left_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_left_nat" "shift_left_nat_native" external div_digit_nat: nat -> int -> nat -> int -> nat -> int -> int -> nat -> int -> unit = "div_digit_nat" "div_digit_nat_native" external div_nat: nat -> int -> int -> nat -> int -> int -> unit = "div_nat" "div_nat_native" external shift_right_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_right_nat" "shift_right_nat_native" external compare_digits_nat: nat -> int -> nat -> int -> int = "compare_digits_nat" external compare_nat: nat -> int -> int -> nat -> int -> int -> int = "compare_nat" "compare_nat_native" external land_digit_nat: nat -> int -> nat -> int -> unit = "land_digit_nat" external lor_digit_nat: nat -> int -> nat -> int -> unit = "lor_digit_nat" external lxor_digit_nat: nat -> int -> nat -> int -> unit = "lxor_digit_nat" external initialize_nat: unit -> unit = "initialize_nat" let _ = initialize_nat() let length_nat (n : nat) = Obj.size (Obj.repr n) - 1 let length_of_digit = Sys.word_size;; let make_nat len = if len < 0 then invalid_arg "make_nat" else let res = create_nat len in set_to_zero_nat res 0 len; res (* Nat temporaries *) let a_2 = make_nat 2 and a_1 = make_nat 1 and b_2 = make_nat 2 let copy_nat nat off_set length = let res = create_nat (length) in blit_nat res 0 nat off_set length; res let is_zero_nat n off len = compare_nat (make_nat 1) 0 1 n off (num_digits_nat n off len) = 0 let is_nat_int nat off len = num_digits_nat nat off len = 1 && is_digit_int nat off let sys_int_of_nat nat off len = if is_nat_int nat off len then nth_digit_nat nat off else failwith "int_of_nat" let int_of_nat nat = sys_int_of_nat nat 0 (length_nat nat) let nat_of_int i = if i < 0 then invalid_arg "nat_of_int" else let res = make_nat 1 in if i = 0 then res else begin set_digit_nat res 0 i; res end let eq_nat nat1 off1 len1 nat2 off2 len2 = compare_nat nat1 off1 (num_digits_nat nat1 off1 len1) nat2 off2 (num_digits_nat nat2 off2 len2) = 0 and le_nat nat1 off1 len1 nat2 off2 len2 = compare_nat nat1 off1 (num_digits_nat nat1 off1 len1) nat2 off2 (num_digits_nat nat2 off2 len2) <= 0 and lt_nat nat1 off1 len1 nat2 off2 len2 = compare_nat nat1 off1 (num_digits_nat nat1 off1 len1) nat2 off2 (num_digits_nat nat2 off2 len2) < 0 and ge_nat nat1 off1 len1 nat2 off2 len2 = compare_nat nat1 off1 (num_digits_nat nat1 off1 len1) nat2 off2 (num_digits_nat nat2 off2 len2) >= 0 and gt_nat nat1 off1 len1 nat2 off2 len2 = compare_nat nat1 off1 (num_digits_nat nat1 off1 len1) nat2 off2 (num_digits_nat nat2 off2 len2) > 0 (* XL: now implemented in C for better performance. The code below doesn't handle carries correctly. Fortunately, the carry is never used. *) (*** let square_nat nat1 off1 len1 nat2 off2 len2 = let c = ref 0 and trash = make_nat 1 in (* Double product *) for i = 0 to len2 - 2 do c := !c + mult_digit_nat nat1 (succ (off1 + 2 * i)) (2 * (pred (len2 - i))) nat2 (succ (off2 + i)) (pred (len2 - i)) nat2 (off2 + i) done; shift_left_nat nat1 0 len1 trash 0 1; (* Square of digit *) for i = 0 to len2 - 1 do c := !c + mult_digit_nat nat1 (off1 + 2 * i) (len1 - 2 * i) nat2 (off2 + i) 1 nat2 (off2 + i) done; !c ***) let gcd_int_nat i nat off len = if i = 0 then 1 else if is_nat_int nat off len then begin set_digit_nat nat off (gcd_int (nth_digit_nat nat off) i); 0 end else begin let len_copy = succ len in let copy = create_nat len_copy and quotient = create_nat 1 and remainder = create_nat 1 in blit_nat copy 0 nat off len; set_digit_nat copy len 0; div_digit_nat quotient 0 remainder 0 copy 0 len_copy (nat_of_int i) 0; set_digit_nat nat off (gcd_int (nth_digit_nat remainder 0) i); 0 end let exchange r1 r2 = let old1 = !r1 in r1 := !r2; r2 := old1 let gcd_nat nat1 off1 len1 nat2 off2 len2 = if is_zero_nat nat1 off1 len1 then begin blit_nat nat1 off1 nat2 off2 len2; len2 end else begin let copy1 = ref (create_nat (succ len1)) and copy2 = ref (create_nat (succ len2)) in blit_nat !copy1 0 nat1 off1 len1; blit_nat !copy2 0 nat2 off2 len2; set_digit_nat !copy1 len1 0; set_digit_nat !copy2 len2 0; if lt_nat !copy1 0 len1 !copy2 0 len2 then exchange copy1 copy2; let real_len1 = ref (num_digits_nat !copy1 0 (length_nat !copy1)) and real_len2 = ref (num_digits_nat !copy2 0 (length_nat !copy2)) in while not (is_zero_nat !copy2 0 !real_len2) do set_digit_nat !copy1 !real_len1 0; div_nat !copy1 0 (succ !real_len1) !copy2 0 !real_len2; exchange copy1 copy2; real_len1 := !real_len2; real_len2 := num_digits_nat !copy2 0 !real_len2 done; blit_nat nat1 off1 !copy1 0 !real_len1; !real_len1 end (* Racine carre entire par la mthode de Newton (entire par dfaut). *) (* Thorme: la suite xn+1 = (xn + a/xn) / 2 converge vers la racine *) (* carre entire de a par dfaut, si on part d'une valeur x0 *) (* strictement plus grande que la racine de a, sauf quand a est un *) (* carr - 1, cas auquel la suite alterne entre la racine par dfaut *) (* et par excs. Dans tous les cas, le dernier terme de la partie *) (* strictement dcroissante de la suite est le rsultat cherch. *) let sqrt_nat rad off len = let len = num_digits_nat rad off len in (* Copie de travail du radicande *) let len_parity = len mod 2 in let rad_len = len + 1 + len_parity in let rad = let res = create_nat rad_len in blit_nat res 0 rad off len; set_digit_nat res len 0; set_digit_nat res (rad_len - 1) 0; res in let cand_len = (len + 1) / 2 in (* ceiling len / 2 *) let cand_rest = rad_len - cand_len in (* Racine carre suppose cand = "|FFFF .... |" *) let cand = make_nat cand_len in (* Amlioration de la racine de dpart: on calcule nbb le nombre de bits significatifs du premier digit du candidat (la moiti du nombre de bits significatifs dans les deux premiers digits du radicande tendu une longueur paire). shift_cand est word_size - nbb *) let shift_cand = ((num_leading_zero_bits_in_digit rad (len-1)) + Sys.word_size * len_parity) / 2 in (* Tous les bits du radicande sont 0, on rend 0. *) if shift_cand = Sys.word_size then cand else begin complement_nat cand 0 cand_len; shift_right_nat cand 0 1 a_1 0 shift_cand; let next_cand = create_nat rad_len in (* Repeat until *) let rec loop () = (* next_cand := rad *) blit_nat next_cand 0 rad 0 rad_len; (* next_cand <- next_cand / cand *) div_nat next_cand 0 rad_len cand 0 cand_len; (* next_cand (poids fort) <- next_cand (poids fort) + cand, i.e. next_cand <- cand + rad / cand *) ignore (add_nat next_cand cand_len cand_rest cand 0 cand_len 0); (* next_cand <- next_cand / 2 *) shift_right_nat next_cand cand_len cand_rest a_1 0 1; if lt_nat next_cand cand_len cand_rest cand 0 cand_len then begin (* cand <- next_cand *) blit_nat cand 0 next_cand cand_len cand_len; loop () end else cand in loop () end;; let power_base_max = make_nat 2;; match length_of_digit with | 64 -> set_digit_nat power_base_max 0 (Int64.to_int 1000000000000000000L); ignore (mult_digit_nat power_base_max 0 2 power_base_max 0 1 (nat_of_int 9) 0) | 32 -> set_digit_nat power_base_max 0 1000000000 | _ -> assert false ;; let pmax = match length_of_digit with | 64 -> 19 | 32 -> 9 | _ -> assert false ;; let max_superscript_10_power_in_int = match length_of_digit with | 64 -> 18 | 32 -> 9 | _ -> assert false ;; let max_power_10_power_in_int = match length_of_digit with | 64 -> nat_of_int (Int64.to_int 1000000000000000000L) | 32 -> nat_of_int 1000000000 | _ -> assert false ;; let raw_string_of_digit nat off = if is_nat_int nat off 1 then begin string_of_int (nth_digit_nat nat off) end else begin blit_nat b_2 0 nat off 1; div_digit_nat a_2 0 a_1 0 b_2 0 2 max_power_10_power_in_int 0; let leading_digits = nth_digit_nat a_2 0 and s1 = string_of_int (nth_digit_nat a_1 0) in let len = String.length s1 in if leading_digits < 10 then begin let result = String.make (max_superscript_10_power_in_int+1) '0' in String.set result 0 (Char.chr (48 + leading_digits)); String.blit s1 0 result (String.length result - len) len; result end else begin let result = String.make (max_superscript_10_power_in_int+2) '0' in String.blit (string_of_int leading_digits) 0 result 0 2; String.blit s1 0 result (String.length result - len) len; result end end (* XL: suppression de string_of_digit et de sys_string_of_digit. La copie est de toute facon faite dans string_of_nat, qui est le seul point d entree public dans ce code. *) (****** let sys_string_of_digit nat off = let s = raw_string_of_digit nat off in let result = String.create (String.length s) in String.blit s 0 result 0 (String.length s); s let string_of_digit nat = sys_string_of_digit nat 0 *******) let digits = "0123456789ABCDEF" (* make_power_base affecte power_base des puissances successives de base a partir de la puissance 1-ieme. A la fin de la boucle i-1 est la plus grande puissance de la base qui tient sur un seul digit et j est la plus grande puissance de la base qui tient sur un int. *) let make_power_base base power_base = let i = ref 0 and j = ref 0 in set_digit_nat power_base 0 base; while incr i; is_digit_zero power_base !i do ignore (mult_digit_nat power_base !i 2 power_base (pred !i) 1 power_base 0) done; while !j <= !i && is_digit_int power_base !j do incr j done; (!i - 2, !j) (* int_to_string place la representation de l entier int en base base dans la chaine s en le rangeant de la fin indiquee par pos vers le debut, sur times places et affecte a pos sa nouvelle valeur. *) let int_to_string int s pos_ref base times = let i = ref int and j = ref times in while ((!i != 0) || (!j != 0)) && (!pos_ref != -1) do String.set s !pos_ref (String.get digits (!i mod base)); decr pos_ref; decr j; i := !i / base done (* XL: suppression de adjust_string *) let power_base_int base i = if i = 0 then nat_of_int 1 else if i < 0 then invalid_arg "power_base_int" else begin let power_base = make_nat (succ length_of_digit) in let (pmax, pint) = make_power_base base power_base in let n = i / (succ pmax) and rem = i mod (succ pmax) in if n > 0 then begin let newn = if i = biggest_int then n else (succ n) in let res = make_nat newn and res2 = make_nat newn and l = num_bits_int n - 2 in let p = ref (1 lsl l) in blit_nat res 0 power_base pmax 1; for i = l downto 0 do let len = num_digits_nat res 0 newn in let len2 = min n (2 * len) in let succ_len2 = succ len2 in ignore (square_nat res2 0 len2 res 0 len); if n land !p > 0 then begin set_to_zero_nat res 0 len; ignore (mult_digit_nat res 0 succ_len2 res2 0 len2 power_base pmax) end else blit_nat res 0 res2 0 len2; set_to_zero_nat res2 0 len2; p := !p lsr 1 done; if rem > 0 then begin ignore (mult_digit_nat res2 0 newn res 0 n power_base (pred rem)); res2 end else res end else copy_nat power_base (pred rem) 1 end (* the ith element (i >= 2) of num_digits_max_vector is : | | | biggest_string_length * log (i) | | ------------------------------- | + 1 | length_of_digit * log (2) | -- -- *) (* XL: ai specialise le code d origine a length_of_digit = 32. *) (* Puis suppression (inutile?) *) (****** let num_digits_max_vector = [|0; 0; 1024; 1623; 2048; 2378; 2647; 2875; 3072; 3246; 3402; 3543; 3671; 3789; 3899; 4001; 4096|] let num_digits_max_vector = match length_of_digit with 16 -> [|0; 0; 2048; 3246; 4096; 4755; 5294; 5749; 6144; 6492; 6803; 7085; 7342; 7578; 7797; 8001; 8192|] (* If really exotic machines !!!! | 17 -> [|0; 0; 1928; 3055; 3855; 4476; 4983; 5411; 5783; 6110; 6403; 6668; 6910; 7133; 7339; 7530; 7710|] | 18 -> [|0; 0; 1821; 2886; 3641; 4227; 4706; 5111; 5461; 5771; 6047; 6298; 6526; 6736; 6931; 7112; 7282|] | 19 -> [|0; 0; 1725; 2734; 3449; 4005; 4458; 4842; 5174; 5467; 5729; 5966; 6183; 6382; 6566; 6738; 6898|] | 20 -> [|0; 0; 1639; 2597; 3277; 3804; 4235; 4600; 4915; 5194; 5443; 5668; 5874; 6063; 6238; 6401; 6553|] | 21 -> [|0; 0; 1561; 2473; 3121; 3623; 4034; 4381; 4681; 4946; 5183; 5398; 5594; 5774; 5941; 6096; 6241|] | 22 -> [|0; 0; 1490; 2361; 2979; 3459; 3850; 4182; 4468; 4722; 4948; 5153; 5340; 5512; 5671; 5819; 5958|] | 23 -> [|0; 0; 1425; 2258; 2850; 3308; 3683; 4000; 4274; 4516; 4733; 4929; 5108; 5272; 5424; 5566; 5699|] | 24 -> [|0; 0; 1366; 2164; 2731; 3170; 3530; 3833; 4096; 4328; 4536; 4723; 4895; 5052; 5198; 5334; 5461|] | 25 -> [|0; 0; 1311; 2078; 2622; 3044; 3388; 3680; 3932; 4155; 4354; 4534; 4699; 4850; 4990; 5121; 5243|] | 26 -> [|0; 0; 1261; 1998; 2521; 2927; 3258; 3538; 3781; 3995; 4187; 4360; 4518; 4664; 4798; 4924; 5041|] | 27 -> [|0; 0; 1214; 1924; 2428; 2818; 3137; 3407; 3641; 3847; 4032; 4199; 4351; 4491; 4621; 4742; 4855|] | 28 -> [|0; 0; 1171; 1855; 2341; 2718; 3025; 3286; 3511; 3710; 3888; 4049; 4196; 4331; 4456; 4572; 4681|] | 29 -> [|0; 0; 1130; 1791; 2260; 2624; 2921; 3172; 3390; 3582; 3754; 3909; 4051; 4181; 4302; 4415; 4520|] | 30 -> [|0; 0; 1093; 1732; 2185; 2536; 2824; 3067; 3277; 3463; 3629; 3779; 3916; 4042; 4159; 4267; 4369|] | 31 -> [|0; 0; 1057; 1676; 2114; 2455; 2733; 2968; 3171; 3351; 3512; 3657; 3790; 3912; 4025; 4130; 4228|] *) | 32 -> [|0; 0; 1024; 1623; 2048; 2378; 2647; 2875; 3072; 3246; 3402; 3543; 3671; 3789; 3899; 4001; 4096|] | n -> failwith "num_digits_max_vector" ******) (* XL: suppression de string_list_of_nat *) let unadjusted_string_of_nat nat off len_nat = let len = num_digits_nat nat off len_nat in if len = 1 then raw_string_of_digit nat off else let len_copy = ref (succ len) in let copy1 = create_nat !len_copy and copy2 = make_nat !len_copy and rest_digit = make_nat 2 in if len > biggest_int / (succ pmax) then failwith "number too long" else let len_s = (succ pmax) * len in let s = String.make len_s '0' and pos_ref = ref len_s in len_copy := pred !len_copy; blit_nat copy1 0 nat off len; set_digit_nat copy1 len 0; while not (is_zero_nat copy1 0 !len_copy) do div_digit_nat copy2 0 rest_digit 0 copy1 0 (succ !len_copy) power_base_max 0; let str = raw_string_of_digit rest_digit 0 in String.blit str 0 s (!pos_ref - String.length str) (String.length str); (* XL: il y avait pmax a la place de String.length str mais ca ne marche pas avec le blit de Caml Light, qui ne verifie pas les debordements *) pos_ref := !pos_ref - pmax; len_copy := num_digits_nat copy2 0 !len_copy; blit_nat copy1 0 copy2 0 !len_copy; set_digit_nat copy1 !len_copy 0 done; s let string_of_nat nat = let s = unadjusted_string_of_nat nat 0 (length_nat nat) and index = ref 0 in begin try for i = 0 to String.length s - 2 do if String.get s i <> '0' then (index:= i; raise Exit) done with Exit -> () end; String.sub s !index (String.length s - !index) (* XL: suppression de sys_string_of_nat *) (* XL: suppression de debug_string_nat *) let base_digit_of_char c base = let n = Char.code c in if n >= 48 && n <= 47 + min base 10 then n - 48 else if n >= 65 && n <= 65 + base - 11 then n - 55 else failwith "invalid digit" (* La sous-chaine (s, off, len) represente un nat en base base que on determine ici *) let sys_nat_of_string base s off len = let power_base = make_nat (succ length_of_digit) in let (pmax, pint) = make_power_base base power_base in let new_len = ref (1 + len / (pmax + 1)) and current_len = ref 1 in let possible_len = ref (min 2 !new_len) in let nat1 = make_nat !new_len and nat2 = make_nat !new_len and digits_read = ref 0 and bound = off + len - 1 and int = ref 0 in for i = off to bound do (* on lit pint (au maximum) chiffres, on en fait un int et on l integre au nombre *) let c = String.get s i in begin match c with ' ' | '\t' | '\n' | '\r' | '\\' -> () | _ -> int := !int * base + base_digit_of_char c base; incr digits_read end; if (!digits_read = pint || i = bound) && not (!digits_read = 0) then begin set_digit_nat nat1 0 !int; let erase_len = if !new_len = !current_len then !current_len - 1 else !current_len in for j = 1 to erase_len do set_digit_nat nat1 j 0 done; ignore (mult_digit_nat nat1 0 !possible_len nat2 0 !current_len power_base (pred !digits_read)); blit_nat nat2 0 nat1 0 !possible_len; current_len := num_digits_nat nat1 0 !possible_len; possible_len := min !new_len (succ !current_len); int := 0; digits_read := 0 end done; (* On recadre le nat *) let nat = create_nat !current_len in blit_nat nat 0 nat1 0 !current_len; nat let nat_of_string s = sys_nat_of_string 10 s 0 (String.length s) let float_of_nat nat = float_of_string(string_of_nat nat) mingw-ocaml/ocaml/otherlibs/num/.depend.nt0000644000175000017500000000575612124403241020145 0ustar tootstootsbng.dobj: bng.c bng.h ../../byterun/config.h ../../config/m.h \ ../../config/s.h ../../byterun/compatibility.h bng_ppc.c bng_digit.c bng_alpha.dobj: bng_alpha.c bng_amd64.dobj: bng_amd64.c bng_digit.dobj: bng_digit.c bng_ia32.dobj: bng_ia32.c bng_mips.dobj: bng_mips.c bng_ppc.dobj: bng_ppc.c bng_sparc.dobj: bng_sparc.c nat_stubs.dobj: nat_stubs.c ../../byterun/alloc.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/mlvalues.h ../../byterun/custom.h ../../byterun/intext.h \ ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/fail.h \ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h bng.h nat.h big_int.cmi: nat.cmi num.cmi: ratio.cmi nat.cmi big_int.cmi ratio.cmi: nat.cmi big_int.cmi arith_flags.cmo: arith_flags.cmi arith_flags.cmx: arith_flags.cmi arith_status.cmo: arith_flags.cmi arith_status.cmi arith_status.cmx: arith_flags.cmx arith_status.cmi big_int.cmo: nat.cmi int_misc.cmi big_int.cmi big_int.cmx: nat.cmx int_misc.cmx big_int.cmi int_misc.cmo: int_misc.cmi int_misc.cmx: int_misc.cmi nat.cmo: int_misc.cmi nat.cmi nat.cmx: int_misc.cmx nat.cmi num.cmo: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi bng.sobj: bng.c bng.h ../../byterun/config.h ../../config/m.h \ ../../config/s.h ../../byterun/compatibility.h bng_ppc.c bng_digit.c bng_alpha.sobj: bng_alpha.c bng_amd64.sobj: bng_amd64.c bng_digit.sobj: bng_digit.c bng_ia32.sobj: bng_ia32.c bng_mips.sobj: bng_mips.c bng_ppc.sobj: bng_ppc.c bng_sparc.sobj: bng_sparc.c nat_stubs.sobj: nat_stubs.c ../../byterun/alloc.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/mlvalues.h ../../byterun/custom.h ../../byterun/intext.h \ ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/fail.h \ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h bng.h nat.h big_int.cmi: nat.cmi num.cmi: ratio.cmi nat.cmi big_int.cmi ratio.cmi: nat.cmi big_int.cmi arith_flags.cmo: arith_flags.cmi arith_flags.cmx: arith_flags.cmi arith_status.cmo: arith_flags.cmi arith_status.cmi arith_status.cmx: arith_flags.cmx arith_status.cmi big_int.cmo: nat.cmi int_misc.cmi big_int.cmi big_int.cmx: nat.cmx int_misc.cmx big_int.cmi int_misc.cmo: int_misc.cmi int_misc.cmx: int_misc.cmi nat.cmo: int_misc.cmi nat.cmi nat.cmx: int_misc.cmx nat.cmi num.cmo: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi mingw-ocaml/ocaml/otherlibs/num/nat.h0000644000175000017500000000201412124403241017200 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1999 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Nats are represented as unstructured blocks with tag Custom_tag. */ #define Digit_val(nat,pos) (((bng) Data_custom_val(nat))[pos]) mingw-ocaml/ocaml/otherlibs/num/nat_stubs.c0000644000175000017500000003057212124403241020425 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "alloc.h" #include "config.h" #include "custom.h" #include "intext.h" #include "fail.h" #include "hash.h" #include "memory.h" #include "mlvalues.h" #include "bng.h" #include "nat.h" /* Stub code for the Nat module. */ static intnat hash_nat(value); static void serialize_nat(value, uintnat *, uintnat *); static uintnat deserialize_nat(void * dst); static struct custom_operations nat_operations = { "_nat", custom_finalize_default, custom_compare_default, hash_nat, serialize_nat, deserialize_nat, custom_compare_ext_default }; CAMLprim value initialize_nat(value unit) { bng_init(); register_custom_operations(&nat_operations); return Val_unit; } CAMLprim value create_nat(value size) { mlsize_t sz = Long_val(size); return alloc_custom(&nat_operations, sz * sizeof(value), 0, 1); } CAMLprim value length_nat(value nat) { return Val_long(Wosize_val(nat) - 1); } CAMLprim value set_to_zero_nat(value nat, value ofs, value len) { bng_zero(&Digit_val(nat, Long_val(ofs)), Long_val(len)); return Val_unit; } CAMLprim value blit_nat(value nat1, value ofs1, value nat2, value ofs2, value len) { bng_assign(&Digit_val(nat1, Long_val(ofs1)), &Digit_val(nat2, Long_val(ofs2)), Long_val(len)); return Val_unit; } CAMLprim value set_digit_nat(value nat, value ofs, value digit) { Digit_val(nat, Long_val(ofs)) = Long_val(digit); return Val_unit; } CAMLprim value nth_digit_nat(value nat, value ofs) { return Val_long(Digit_val(nat, Long_val(ofs))); } CAMLprim value set_digit_nat_native(value nat, value ofs, value digit) { Digit_val(nat, Long_val(ofs)) = Nativeint_val(digit); return Val_unit; } CAMLprim value nth_digit_nat_native(value nat, value ofs) { return caml_copy_nativeint(Digit_val(nat, Long_val(ofs))); } CAMLprim value num_digits_nat(value nat, value ofs, value len) { return Val_long(bng_num_digits(&Digit_val(nat, Long_val(ofs)), Long_val(len))); } CAMLprim value num_leading_zero_bits_in_digit(value nat, value ofs) { return Val_long(bng_leading_zero_bits(Digit_val(nat, Long_val(ofs)))); } CAMLprim value is_digit_int(value nat, value ofs) { return Val_bool(Digit_val(nat, Long_val(ofs)) <= Max_long); } CAMLprim value is_digit_zero(value nat, value ofs) { return Val_bool(Digit_val(nat, Long_val(ofs)) == 0); } CAMLprim value is_digit_normalized(value nat, value ofs) { return Val_bool(Digit_val(nat, Long_val(ofs)) & ((bngdigit)1 << (BNG_BITS_PER_DIGIT-1))); } CAMLprim value is_digit_odd(value nat, value ofs) { return Val_bool(Digit_val(nat, Long_val(ofs)) & 1); } CAMLprim value incr_nat(value nat, value ofs, value len, value carry_in) { return Val_long(bng_add_carry(&Digit_val(nat, Long_val(ofs)), Long_val(len), Long_val(carry_in))); } value add_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value len2, value carry_in) { return Val_long(bng_add(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), &Digit_val(nat2, Long_val(ofs2)), Long_val(len2), Long_val(carry_in))); } CAMLprim value add_nat(value *argv, int argn) { return add_nat_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); } CAMLprim value complement_nat(value nat, value ofs, value len) { bng_complement(&Digit_val(nat, Long_val(ofs)), Long_val(len)); return Val_unit; } CAMLprim value decr_nat(value nat, value ofs, value len, value carry_in) { return Val_long(1 ^ bng_sub_carry(&Digit_val(nat, Long_val(ofs)), Long_val(len), 1 ^ Long_val(carry_in))); } value sub_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value len2, value carry_in) { return Val_long(1 ^ bng_sub(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), &Digit_val(nat2, Long_val(ofs2)), Long_val(len2), 1 ^ Long_val(carry_in))); } CAMLprim value sub_nat(value *argv, int argn) { return sub_nat_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); } value mult_digit_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value len2, value nat3, value ofs3) { return Val_long(bng_mult_add_digit( &Digit_val(nat1, Long_val(ofs1)), Long_val(len1), &Digit_val(nat2, Long_val(ofs2)), Long_val(len2), Digit_val(nat3, Long_val(ofs3)))); } CAMLprim value mult_digit_nat(value *argv, int argn) { return mult_digit_nat_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7]); } value mult_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value len2, value nat3, value ofs3, value len3) { return Val_long(bng_mult_add(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), &Digit_val(nat2, Long_val(ofs2)), Long_val(len2), &Digit_val(nat3, Long_val(ofs3)), Long_val(len3))); } CAMLprim value mult_nat(value *argv, int argn) { return mult_nat_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8]); } value square_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value len2) { return Val_long(bng_square_add(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), &Digit_val(nat2, Long_val(ofs2)), Long_val(len2))); } CAMLprim value square_nat(value *argv, int argn) { return square_nat_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } value shift_left_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value nbits) { Digit_val(nat2, Long_val(ofs2)) = bng_shift_left(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), Long_val(nbits)); return Val_unit; } CAMLprim value shift_left_nat(value *argv, int argn) { return shift_left_nat_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } value div_digit_nat_native(value natq, value ofsq, value natr, value ofsr, value nat1, value ofs1, value len1, value nat2, value ofs2) { Digit_val(natr, Long_val(ofsr)) = bng_div_rem_digit(&Digit_val(natq, Long_val(ofsq)), &Digit_val(nat1, Long_val(ofs1)), Long_val(len1), Digit_val(nat2, Long_val(ofs2))); return Val_unit; } CAMLprim value div_digit_nat(value *argv, int argn) { return div_digit_nat_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8]); } value div_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value len2) { bng_div_rem(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), &Digit_val(nat2, Long_val(ofs2)), Long_val(len2)); return Val_unit; } CAMLprim value div_nat(value *argv, int argn) { return div_nat_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } value shift_right_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value nbits) { Digit_val(nat2, Long_val(ofs2)) = bng_shift_right(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), Long_val(nbits)); return Val_unit; } CAMLprim value shift_right_nat(value *argv, int argn) { return shift_right_nat_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } CAMLprim value compare_digits_nat(value nat1, value ofs1, value nat2, value ofs2) { bngdigit d1 = Digit_val(nat1, Long_val(ofs1)); bngdigit d2 = Digit_val(nat2, Long_val(ofs2)); if (d1 > d2) return Val_int(1); if (d1 < d2) return Val_int(-1); return Val_int(0); } value compare_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value len2) { return Val_int(bng_compare(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1), &Digit_val(nat2, Long_val(ofs2)), Long_val(len2))); } CAMLprim value compare_nat(value *argv, int argn) { return compare_nat_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } CAMLprim value land_digit_nat(value nat1, value ofs1, value nat2, value ofs2) { Digit_val(nat1, Long_val(ofs1)) &= Digit_val(nat2, Long_val(ofs2)); return Val_unit; } CAMLprim value lor_digit_nat(value nat1, value ofs1, value nat2, value ofs2) { Digit_val(nat1, Long_val(ofs1)) |= Digit_val(nat2, Long_val(ofs2)); return Val_unit; } CAMLprim value lxor_digit_nat(value nat1, value ofs1, value nat2, value ofs2) { Digit_val(nat1, Long_val(ofs1)) ^= Digit_val(nat2, Long_val(ofs2)); return Val_unit; } /* The wire format for a nat is: - 32-bit word: number of 32-bit words in nat - N 32-bit words (big-endian format) For little-endian platforms, the memory layout between 32-bit and 64-bit machines is identical, so we can write the nat using serialize_block_4. For big-endian 64-bit platforms, we need to swap the two 32-bit halves of 64-bit words to obtain the correct behavior. */ static void serialize_nat(value nat, uintnat * wsize_32, uintnat * wsize_64) { mlsize_t len = Wosize_val(nat) - 1; #ifdef ARCH_SIXTYFOUR len = len * 2; /* two 32-bit words per 64-bit digit */ if (len >= ((mlsize_t)1 << 32)) failwith("output_value: nat too big"); #endif serialize_int_4((int32) len); #if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN) { int32 * p; mlsize_t i; for (i = len, p = Data_custom_val(nat); i > 0; i -= 2, p += 2) { serialize_int_4(p[1]); /* low 32 bits of 64-bit digit */ serialize_int_4(p[0]); /* high 32 bits of 64-bit digit */ } } #else serialize_block_4(Data_custom_val(nat), len); #endif *wsize_32 = len * 4; *wsize_64 = len * 4; } static uintnat deserialize_nat(void * dst) { mlsize_t len; len = deserialize_uint_4(); #if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN) { uint32 * p; mlsize_t i; for (i = len, p = dst; i > 1; i -= 2, p += 2) { p[1] = deserialize_uint_4(); /* low 32 bits of 64-bit digit */ p[0] = deserialize_uint_4(); /* high 32 bits of 64-bit digit */ } if (i > 0){ p[1] = deserialize_uint_4(); /* low 32 bits of 64-bit digit */ p[0] = 0; /* high 32 bits of 64-bit digit */ ++ len; } } #else deserialize_block_4(dst, len); #if defined(ARCH_SIXTYFOUR) if (len & 1){ ((uint32 *) dst)[len] = 0; ++ len; } #endif #endif return len * 4; } static intnat hash_nat(value v) { bngsize len, i; uint32 h; len = bng_num_digits(&Digit_val(v,0), Wosize_val(v) - 1); h = 0; for (i = 0; i < len; i++) { bngdigit d = Digit_val(v, i); #ifdef ARCH_SIXTYFOUR /* Mix the two 32-bit halves as if we were on a 32-bit platform, namely low 32 bits first, then high 32 bits. Also, ignore final 32 bits if they are zero. */ h = caml_hash_mix_uint32(h, (uint32) d); d = d >> 32; if (d == 0 && i + 1 == len) break; h = caml_hash_mix_uint32(h, (uint32) d); #else h = caml_hash_mix_uint32(h, d); #endif } return h; } mingw-ocaml/ocaml/otherlibs/num/bng.c0000644000175000017500000002716412124403241017174 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2003 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "bng.h" #include "config.h" #if defined(__GNUC__) && BNG_ASM_LEVEL > 0 #if defined(BNG_ARCH_ia32) #include "bng_ia32.c" #elif defined(BNG_ARCH_amd64) #include "bng_amd64.c" #elif defined(BNG_ARCH_ppc) #include "bng_ppc.c" #elif defined (BNG_ARCH_alpha) #include "bng_alpha.c" #elif defined (BNG_ARCH_sparc) #include "bng_sparc.c" #elif defined (BNG_ARCH_mips) #include "bng_mips.c" #endif #endif #include "bng_digit.c" /**** Operations that cannot be overridden ****/ /* Return number of leading zero bits in d */ int bng_leading_zero_bits(bngdigit d) { int n = BNG_BITS_PER_DIGIT; #ifdef ARCH_SIXTYFOUR if ((d & 0xFFFFFFFF00000000L) != 0) { n -= 32; d = d >> 32; } #endif if ((d & 0xFFFF0000) != 0) { n -= 16; d = d >> 16; } if ((d & 0xFF00) != 0) { n -= 8; d = d >> 8; } if ((d & 0xF0) != 0) { n -= 4; d = d >> 4; } if ((d & 0xC) != 0) { n -= 2; d = d >> 2; } if ((d & 2) != 0) { n -= 1; d = d >> 1; } return n - d; } /* Complement the digits of {a,len} */ void bng_complement(bng a/*[alen]*/, bngsize alen) { for (/**/; alen > 0; alen--, a++) *a = ~*a; } /* Return number of significant digits in {a,alen}. */ bngsize bng_num_digits(bng a/*[alen]*/, bngsize alen) { while (1) { if (alen == 0) return 1; if (a[alen - 1] != 0) return alen; alen--; } } /* Return 0 if {a,alen} = {b,blen} -1 if {a,alen} < {b,blen} 1 if {a,alen} > {b,blen}. */ int bng_compare(bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen) { bngdigit da, db; while (alen > 0 && a[alen-1] == 0) alen--; while (blen > 0 && b[blen-1] == 0) blen--; if (alen > blen) return 1; if (alen < blen) return -1; while (alen > 0) { alen--; da = a[alen]; db = b[alen]; if (da > db) return 1; if (da < db) return -1; } return 0; } /**** Generic definitions of the overridable operations ****/ /* {a,alen} := {a, alen} + carry. Return carry out. */ static bngcarry bng_generic_add_carry (bng a/*[alen]*/, bngsize alen, bngcarry carry) { if (carry == 0 || alen == 0) return carry; do { if (++(*a) != 0) return 0; a++; } while (--alen); return 1; } /* {a,alen} := {a,alen} + {b,blen} + carry. Return carry out. Require alen >= blen. */ static bngcarry bng_generic_add (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngcarry carry) { alen -= blen; for (/**/; blen > 0; blen--, a++, b++) { BngAdd2Carry(*a, carry, *a, *b, carry); } if (carry == 0 || alen == 0) return carry; do { if (++(*a) != 0) return 0; a++; } while (--alen); return 1; } /* {a,alen} := {a, alen} - carry. Return carry out. */ static bngcarry bng_generic_sub_carry (bng a/*[alen]*/, bngsize alen, bngcarry carry) { if (carry == 0 || alen == 0) return carry; do { if ((*a)-- != 0) return 0; a++; } while (--alen); return 1; } /* {a,alen} := {a,alen} - {b,blen} - carry. Return carry out. Require alen >= blen. */ static bngcarry bng_generic_sub (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngcarry carry) { alen -= blen; for (/**/; blen > 0; blen--, a++, b++) { BngSub2Carry(*a, carry, *a, *b, carry); } if (carry == 0 || alen == 0) return carry; do { if ((*a)-- != 0) return 0; a++; } while (--alen); return 1; } /* {a,alen} := {a,alen} << shift. Return the bits shifted out of the most significant digit of a. Require 0 <= shift < BITS_PER_BNGDIGIT. */ static bngdigit bng_generic_shift_left (bng a/*[alen]*/, bngsize alen, int shift) { int shift2 = BNG_BITS_PER_DIGIT - shift; bngdigit carry = 0; if (shift > 0) { for (/**/; alen > 0; alen--, a++) { bngdigit d = *a; *a = (d << shift) | carry; carry = d >> shift2; } } return carry; } /* {a,alen} := {a,alen} >> shift. Return the bits shifted out of the least significant digit of a. Require 0 <= shift < BITS_PER_BNGDIGIT. */ static bngdigit bng_generic_shift_right (bng a/*[alen]*/, bngsize alen, int shift) { int shift2 = BNG_BITS_PER_DIGIT - shift; bngdigit carry = 0; if (shift > 0) { for (a = a + alen - 1; alen > 0; alen--, a--) { bngdigit d = *a; *a = (d >> shift) | carry; carry = d << shift2; } } return carry; } /* {a,alen} := {a,alen} + d * {b,blen}. Return carry out. Require alen >= blen. */ static bngdigit bng_generic_mult_add_digit (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngdigit d) { bngdigit out, ph, pl; bngcarry carry; alen -= blen; for (out = 0; blen > 0; blen--, a++, b++) { bngdigit bd = *b; /* ph:pl = double-digit product of b's current digit and d */ BngMult(ph, pl, bd, d); /* current digit of a += pl + out. Accumulate carries in ph. */ BngAdd3(*a, ph, *a, pl, out); /* prepare out for next iteration */ out = ph; } if (alen == 0) return out; /* current digit of a += out */ BngAdd2(*a, carry, *a, out); a++; alen--; /* Propagate carry */ if (carry == 0 || alen == 0) return carry; do { if (++(*a) != 0) return 0; a++; } while (--alen); return 1; } /* {a,alen} := {a,alen} - d * {b,blen}. Return carry out. Require alen >= blen. */ static bngdigit bng_generic_mult_sub_digit (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bngdigit d) { bngdigit out, ph, pl; bngcarry carry; alen -= blen; for (out = 0; blen > 0; blen--, a++, b++) { bngdigit bd = *b; /* ph:pl = double-digit product of b's current digit and d */ BngMult(ph, pl, bd, d); /* current digit of a -= pl + out. Accumulate carrys in ph. */ BngSub3(*a, ph, *a, pl, out); /* prepare out for next iteration */ out = ph; } if (alen == 0) return out; /* current digit of a -= out */ BngSub2(*a, carry, *a, out); a++; alen--; /* Propagate carry */ if (carry == 0 || alen == 0) return carry; do { if ((*a)-- != 0) return 0; a++; } while (--alen); return 1; } /* {a,alen} := {a,alen} + {b,blen} * {c,clen}. Return carry out. Require alen >= blen + clen. */ static bngcarry bng_generic_mult_add (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen, bng c/*[clen]*/, bngsize clen) { bngcarry carry; for (carry = 0; clen > 0; clen--, c++, alen--, a++) carry += bng_mult_add_digit(a, alen, b, blen, *c); return carry; } /* {a,alen} := 2 * {a,alen} + {b,blen}^2. Return carry out. Require alen >= 2 * blen. */ static bngcarry bng_generic_square_add (bng a/*[alen]*/, bngsize alen, bng b/*[blen]*/, bngsize blen) { bngcarry carry1, carry2; bngsize i, aofs; bngdigit ph, pl, d; /* Double products */ for (carry1 = 0, i = 1; i < blen; i++) { aofs = 2 * i - 1; carry1 += bng_mult_add_digit(a + aofs, alen - aofs, b + i, blen - i, b[i - 1]); } /* Multiply by two */ carry1 = (carry1 << 1) | bng_shift_left(a, alen, 1); /* Add square of digits */ carry2 = 0; for (i = 0; i < blen; i++) { d = b[i]; BngMult(ph, pl, d, d); BngAdd2Carry(*a, carry2, *a, pl, carry2); a++; BngAdd2Carry(*a, carry2, *a, ph, carry2); a++; } alen -= 2 * blen; if (alen > 0 && carry2 != 0) { do { if (++(*a) != 0) { carry2 = 0; break; } a++; } while (--alen); } return carry1 + carry2; } /* {a,len-1} := {b,len} / d. Return {b,len} modulo d. Require MSD of b < d. If BngDivNeedsNormalization is defined, require d normalized. */ static bngdigit bng_generic_div_rem_norm_digit (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d) { bngdigit topdigit, quo, rem; intnat i; topdigit = b[len - 1]; for (i = len - 2; i >= 0; i--) { /* Divide topdigit:current digit of numerator by d */ BngDiv(quo, rem, topdigit, b[i], d); /* Quotient is current digit of result */ a[i] = quo; /* Iterate with topdigit = remainder */ topdigit = rem; } return topdigit; } #ifdef BngDivNeedsNormalization /* {a,len-1} := {b,len} / d. Return {b,len} modulo d. Require MSD of b < d. */ static bngdigit bng_generic_div_rem_digit (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d) { bngdigit rem; int shift; /* Normalize d and b */ shift = bng_leading_zero_bits(d); d <<= shift; bng_shift_left(b, len, shift); /* Do the division */ rem = bng_div_rem_norm_digit(a, b, len, d); /* Undo normalization on b and remainder */ bng_shift_right(b, len, shift); return rem >> shift; } #endif /* {n+dlen, nlen-dlen} := {n,nlen} / {d, dlen}. {n, dlen} := {n,nlen} modulo {d, dlen}. Require nlen > dlen and MSD of n < MSD of d. (This implies MSD of d > 0). */ static void bng_generic_div_rem (bng n/*[nlen]*/, bngsize nlen, bng d/*[dlen]*/, bngsize dlen) { bngdigit topden, quo, rem; int shift; bngsize i, j; /* Normalize d */ shift = bng_leading_zero_bits(d[dlen - 1]); /* Note that no bits of n are lost by the following shift, since n[nlen-1] < d[dlen-1] */ bng_shift_left(n, nlen, shift); bng_shift_left(d, dlen, shift); /* Special case if d is just one digit */ if (dlen == 1) { *n = bng_div_rem_norm_digit(n + 1, n, nlen, *d); } else { topden = d[dlen - 1]; /* Long division */ for (j = nlen - 1; j >= dlen; j--) { i = j - dlen; /* At this point: - the current numerator is n[j] : ...................... : n[0] - to be subtracted quo times: d[dlen-1] : ... : d[0] : 0... : 0 (there are i zeroes at the end) */ /* Under-estimate the next digit of the quotient (quo) */ if (topden + 1 == 0) quo = n[j]; else BngDiv(quo, rem, n[j], n[j - 1], topden + 1); /* Subtract d * quo (shifted i places) from numerator */ n[j] -= bng_mult_sub_digit(n + i, dlen, d, dlen, quo); /* Adjust if necessary */ while (n[j] != 0 || bng_compare(n + i, dlen, d, dlen) >= 0) { /* Numerator is still bigger than shifted divisor. Increment quotient and subtract shifted divisor. */ quo++; n[j] -= bng_sub(n + i, dlen, d, dlen, 0); } /* Store quotient digit */ n[j] = quo; } } /* Undo normalization on remainder and divisor */ bng_shift_right(n, dlen, shift); bng_shift_right(d, dlen, shift); } /**** Construction of the table of operations ****/ struct bng_operations bng_ops = { bng_generic_add_carry, bng_generic_add, bng_generic_sub_carry, bng_generic_sub, bng_generic_shift_left, bng_generic_shift_right, bng_generic_mult_add_digit, bng_generic_mult_sub_digit, bng_generic_mult_add, bng_generic_square_add, bng_generic_div_rem_norm_digit, #ifdef BngDivNeedsNormalization bng_generic_div_rem_digit, #else bng_generic_div_rem_norm_digit, #endif bng_generic_div_rem }; void bng_init(void) { #ifdef BNG_SETUP_OPS BNG_SETUP_OPS; #endif } mingw-ocaml/ocaml/otherlibs/num/big_int.mli0000644000175000017500000002146512124403241020376 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Operations on arbitrary-precision integers. Big integers (type [big_int]) are signed integers of arbitrary size. *) open Nat type big_int (** The type of big integers. *) val zero_big_int : big_int (** The big integer [0]. *) val unit_big_int : big_int (** The big integer [1]. *) (** {6 Arithmetic operations} *) val minus_big_int : big_int -> big_int (** Unary negation. *) val abs_big_int : big_int -> big_int (** Absolute value. *) val add_big_int : big_int -> big_int -> big_int (** Addition. *) val succ_big_int : big_int -> big_int (** Successor (add 1). *) val add_int_big_int : int -> big_int -> big_int (** Addition of a small integer to a big integer. *) val sub_big_int : big_int -> big_int -> big_int (** Subtraction. *) val pred_big_int : big_int -> big_int (** Predecessor (subtract 1). *) val mult_big_int : big_int -> big_int -> big_int (** Multiplication of two big integers. *) val mult_int_big_int : int -> big_int -> big_int (** Multiplication of a big integer by a small integer *) val square_big_int: big_int -> big_int (** Return the square of the given big integer *) val sqrt_big_int: big_int -> big_int (** [sqrt_big_int a] returns the integer square root of [a], that is, the largest big integer [r] such that [r * r <= a]. Raise [Invalid_argument] if [a] is negative. *) val quomod_big_int : big_int -> big_int -> big_int * big_int (** Euclidean division of two big integers. The first part of the result is the quotient, the second part is the remainder. Writing [(q,r) = quomod_big_int a b], we have [a = q * b + r] and [0 <= r < |b|]. Raise [Division_by_zero] if the divisor is zero. *) val div_big_int : big_int -> big_int -> big_int (** Euclidean quotient of two big integers. This is the first result [q] of [quomod_big_int] (see above). *) val mod_big_int : big_int -> big_int -> big_int (** Euclidean modulus of two big integers. This is the second result [r] of [quomod_big_int] (see above). *) val gcd_big_int : big_int -> big_int -> big_int (** Greatest common divisor of two big integers. *) val power_int_positive_int: int -> int -> big_int val power_big_int_positive_int: big_int -> int -> big_int val power_int_positive_big_int: int -> big_int -> big_int val power_big_int_positive_big_int: big_int -> big_int -> big_int (** Exponentiation functions. Return the big integer representing the first argument [a] raised to the power [b] (the second argument). Depending on the function, [a] and [b] can be either small integers or big integers. Raise [Invalid_argument] if [b] is negative. *) (** {6 Comparisons and tests} *) val sign_big_int : big_int -> int (** Return [0] if the given big integer is zero, [1] if it is positive, and [-1] if it is negative. *) val compare_big_int : big_int -> big_int -> int (** [compare_big_int a b] returns [0] if [a] and [b] are equal, [1] if [a] is greater than [b], and [-1] if [a] is smaller than [b]. *) val eq_big_int : big_int -> big_int -> bool val le_big_int : big_int -> big_int -> bool val ge_big_int : big_int -> big_int -> bool val lt_big_int : big_int -> big_int -> bool val gt_big_int : big_int -> big_int -> bool (** Usual boolean comparisons between two big integers. *) val max_big_int : big_int -> big_int -> big_int (** Return the greater of its two arguments. *) val min_big_int : big_int -> big_int -> big_int (** Return the smaller of its two arguments. *) val num_digits_big_int : big_int -> int (** Return the number of machine words used to store the given big integer. *) (** {6 Conversions to and from strings} *) val string_of_big_int : big_int -> string (** Return the string representation of the given big integer, in decimal (base 10). *) val big_int_of_string : string -> big_int (** Convert a string to a big integer, in decimal. The string consists of an optional [-] or [+] sign, followed by one or several decimal digits. *) (** {6 Conversions to and from other numerical types} *) val big_int_of_int : int -> big_int (** Convert a small integer to a big integer. *) val is_int_big_int : big_int -> bool (** Test whether the given big integer is small enough to be representable as a small integer (type [int]) without loss of precision. On a 32-bit platform, [is_int_big_int a] returns [true] if and only if [a] is between 2{^30} and 2{^30}-1. On a 64-bit platform, [is_int_big_int a] returns [true] if and only if [a] is between -2{^62} and 2{^62}-1. *) val int_of_big_int : big_int -> int (** Convert a big integer to a small integer (type [int]). Raises [Failure "int_of_big_int"] if the big integer is not representable as a small integer. *) val big_int_of_int32 : int32 -> big_int (** Convert a 32-bit integer to a big integer. *) val big_int_of_nativeint : nativeint -> big_int (** Convert a native integer to a big integer. *) val big_int_of_int64 : int64 -> big_int (** Convert a 64-bit integer to a big integer. *) val int32_of_big_int : big_int -> int32 (** Convert a big integer to a 32-bit integer. Raises [Failure] if the big integer is outside the range [[-2{^31}, 2{^31}-1]]. *) val nativeint_of_big_int : big_int -> nativeint (** Convert a big integer to a native integer. Raises [Failure] if the big integer is outside the range [[Nativeint.min_int, Nativeint.max_int]]. *) val int64_of_big_int : big_int -> int64 (** Convert a big integer to a 64-bit integer. Raises [Failure] if the big integer is outside the range [[-2{^63}, 2{^63}-1]]. *) val float_of_big_int : big_int -> float (** Returns a floating-point number approximating the given big integer. *) (** {6 Bit-oriented operations} *) val and_big_int : big_int -> big_int -> big_int (** Bitwise logical ``and''. The arguments must be positive or zero. *) val or_big_int : big_int -> big_int -> big_int (** Bitwise logical ``or''. The arguments must be positive or zero. *) val xor_big_int : big_int -> big_int -> big_int (** Bitwise logical ``exclusive or''. The arguments must be positive or zero. *) val shift_left_big_int : big_int -> int -> big_int (** [shift_left_big_int b n] returns [b] shifted left by [n] bits. Equivalent to multiplication by [2^n]. *) val shift_right_big_int : big_int -> int -> big_int (** [shift_right_big_int b n] returns [b] shifted right by [n] bits. Equivalent to division by [2^n] with the result being rounded towards minus infinity. *) val shift_right_towards_zero_big_int : big_int -> int -> big_int (** [shift_right_towards_zero_big_int b n] returns [b] shifted right by [n] bits. The shift is performed on the absolute value of [b], and the result has the same sign as [b]. Equivalent to division by [2^n] with the result being rounded towards zero. *) val extract_big_int : big_int -> int -> int -> big_int (** [extract_big_int bi ofs n] returns a nonnegative number corresponding to bits [ofs] to [ofs + n - 1] of the binary representation of [bi]. If [bi] is negative, a two's complement representation is used. *) (**/**) (** {6 For internal use} *) val nat_of_big_int : big_int -> nat val big_int_of_nat : nat -> big_int val base_power_big_int: int -> int -> big_int -> big_int val sys_big_int_of_string: string -> int -> int -> big_int val round_futur_last_digit : string -> int -> int -> bool val approx_big_int: int -> big_int -> string mingw-ocaml/ocaml/otherlibs/num/int_misc.mli0000644000175000017500000000217212124403241020562 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Some extra operations on integers *) val gcd_int: int -> int -> int val num_bits_int: int -> int val compare_int: int -> int -> int val sign_int: int -> int val length_of_int: int val biggest_int: int val least_int: int val monster_int: int mingw-ocaml/ocaml/otherlibs/num/test/0000755000175000017500000000000012124403241017227 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/num/test/.gitignore0000644000175000017500000000000012124403241021205 0ustar tootstootsmingw-ocaml/ocaml/otherlibs/num/num.ml0000644000175000017500000003277612124403241017420 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) open Int_misc open Nat open Big_int open Arith_flags open Ratio type num = Int of int | Big_int of big_int | Ratio of ratio (* The type of numbers. *) let biggest_INT = big_int_of_int biggest_int and least_INT = big_int_of_int least_int (* Coercion big_int -> num *) let num_of_big_int bi = if le_big_int bi biggest_INT && ge_big_int bi least_INT then Int (int_of_big_int bi) else Big_int bi let numerator_num = function Ratio r -> ignore (normalize_ratio r); num_of_big_int (numerator_ratio r) | n -> n let denominator_num = function Ratio r -> ignore (normalize_ratio r); num_of_big_int (denominator_ratio r) | n -> Int 1 let normalize_num = function Int i -> Int i | Big_int bi -> num_of_big_int bi | Ratio r -> if is_integer_ratio r then num_of_big_int (numerator_ratio r) else Ratio r let cautious_normalize_num_when_printing n = if (!normalize_ratio_when_printing_flag) then (normalize_num n) else n let num_of_ratio r = ignore (normalize_ratio r); if not (is_integer_ratio r) then Ratio r else if is_int_big_int (numerator_ratio r) then Int (int_of_big_int (numerator_ratio r)) else Big_int (numerator_ratio r) (* Operations on num *) let add_num a b = match (a,b) with ((Int int1), (Int int2)) -> let r = int1 + int2 in if (int1 lxor int2) lor (int1 lxor (r lxor (-1))) < 0 then Int r (* No overflow *) else Big_int(add_big_int (big_int_of_int int1) (big_int_of_int int2)) | ((Int i), (Big_int bi)) -> num_of_big_int (add_int_big_int i bi) | ((Big_int bi), (Int i)) -> num_of_big_int (add_int_big_int i bi) | ((Int i), (Ratio r)) -> Ratio (add_int_ratio i r) | ((Ratio r), (Int i)) -> Ratio (add_int_ratio i r) | ((Big_int bi1), (Big_int bi2)) -> num_of_big_int (add_big_int bi1 bi2) | ((Big_int bi), (Ratio r)) -> Ratio (add_big_int_ratio bi r) | ((Ratio r), (Big_int bi)) -> Ratio (add_big_int_ratio bi r) | ((Ratio r1), (Ratio r2)) -> num_of_ratio (add_ratio r1 r2) let ( +/ ) = add_num let minus_num = function Int i -> if i = monster_int then Big_int (minus_big_int (big_int_of_int i)) else Int (-i) | Big_int bi -> Big_int (minus_big_int bi) | Ratio r -> Ratio (minus_ratio r) let sub_num n1 n2 = add_num n1 (minus_num n2) let ( -/ ) = sub_num let mult_num a b = match (a,b) with ((Int int1), (Int int2)) -> if num_bits_int int1 + num_bits_int int2 < length_of_int then Int (int1 * int2) else num_of_big_int (mult_big_int (big_int_of_int int1) (big_int_of_int int2)) | ((Int i), (Big_int bi)) -> num_of_big_int (mult_int_big_int i bi) | ((Big_int bi), (Int i)) -> num_of_big_int (mult_int_big_int i bi) | ((Int i), (Ratio r)) -> num_of_ratio (mult_int_ratio i r) | ((Ratio r), (Int i)) -> num_of_ratio (mult_int_ratio i r) | ((Big_int bi1), (Big_int bi2)) -> num_of_big_int (mult_big_int bi1 bi2) | ((Big_int bi), (Ratio r)) -> num_of_ratio (mult_big_int_ratio bi r) | ((Ratio r), (Big_int bi)) -> num_of_ratio (mult_big_int_ratio bi r) | ((Ratio r1), (Ratio r2)) -> num_of_ratio (mult_ratio r1 r2) let ( */ ) = mult_num let square_num = function Int i -> if 2 * num_bits_int i < length_of_int then Int (i * i) else num_of_big_int (square_big_int (big_int_of_int i)) | Big_int bi -> Big_int (square_big_int bi) | Ratio r -> Ratio (square_ratio r) let div_num n1 n2 = match n1 with | Int i1 -> begin match n2 with | Int i2 -> num_of_ratio (create_ratio (big_int_of_int i1) (big_int_of_int i2)) | Big_int bi2 -> num_of_ratio (create_ratio (big_int_of_int i1) bi2) | Ratio r2 -> num_of_ratio (div_int_ratio i1 r2) end | Big_int bi1 -> begin match n2 with | Int i2 -> num_of_ratio (create_ratio bi1 (big_int_of_int i2)) | Big_int bi2 -> num_of_ratio (create_ratio bi1 bi2) | Ratio r2 -> num_of_ratio (div_big_int_ratio bi1 r2) end | Ratio r1 -> begin match n2 with | Int i2 -> num_of_ratio (div_ratio_int r1 i2) | Big_int bi2 -> num_of_ratio (div_ratio_big_int r1 bi2) | Ratio r2 -> num_of_ratio (div_ratio r1 r2) end ;; let ( // ) = div_num let floor_num = function Int i as n -> n | Big_int bi as n -> n | Ratio r -> num_of_big_int (floor_ratio r) (* The function [quo_num] is equivalent to let quo_num x y = floor_num (div_num x y);; However, this definition is vastly inefficient (cf PR #3473): we define here a better way of computing the same thing. *) let quo_num n1 n2 = match n1 with | Int i1 -> begin match n2 with | Int i2 -> Int (i1 / i2) | Big_int bi2 -> num_of_big_int (div_big_int (big_int_of_int i1) bi2) | Ratio r2 -> num_of_big_int (floor_ratio (div_int_ratio i1 r2)) end | Big_int bi1 -> begin match n2 with | Int i2 -> num_of_big_int (div_big_int bi1 (big_int_of_int i2)) | Big_int bi2 -> num_of_big_int (div_big_int bi1 bi2) | Ratio r2 -> num_of_big_int (floor_ratio (div_big_int_ratio bi1 r2)) end | Ratio r1 -> begin match n2 with | Int i2 -> num_of_big_int (floor_ratio (div_ratio_int r1 i2)) | Big_int bi2 -> num_of_big_int (floor_ratio (div_ratio_big_int r1 bi2)) | Ratio r2 -> num_of_big_int (floor_ratio (div_ratio r1 r2)) end ;; (* The function [mod_num] is equivalent to: let mod_num x y = sub_num x (mult_num y (quo_num x y));; However, as for [quo_num] above, this definition is inefficient: we define here a better way of computing the same thing. *) let mod_num n1 n2 = match n1 with | Int i1 -> begin match n2 with | Int i2 -> Int (i1 mod i2) | Big_int bi2 -> num_of_big_int (mod_big_int (big_int_of_int i1) bi2) | Ratio _r2 -> sub_num n1 (mult_num n2 (quo_num n1 n2)) end | Big_int bi1 -> begin match n2 with | Int i2 -> num_of_big_int (mod_big_int bi1 (big_int_of_int i2)) | Big_int bi2 -> num_of_big_int (mod_big_int bi1 bi2) | Ratio _r2 -> sub_num n1 (mult_num n2 (quo_num n1 n2)) end | Ratio _r1 -> sub_num n1 (mult_num n2 (quo_num n1 n2)) ;; let power_num_int a b = match (a,b) with ((Int i), n) -> (match sign_int n with 0 -> Int 1 | 1 -> num_of_big_int (power_int_positive_int i n) | _ -> Ratio (create_normalized_ratio unit_big_int (power_int_positive_int i (-n)))) | ((Big_int bi), n) -> (match sign_int n with 0 -> Int 1 | 1 -> num_of_big_int (power_big_int_positive_int bi n) | _ -> Ratio (create_normalized_ratio unit_big_int (power_big_int_positive_int bi (-n)))) | ((Ratio r), n) -> (match sign_int n with 0 -> Int 1 | 1 -> Ratio (power_ratio_positive_int r n) | _ -> Ratio (power_ratio_positive_int (inverse_ratio r) (-n))) let power_num_big_int a b = match (a,b) with ((Int i), n) -> (match sign_big_int n with 0 -> Int 1 | 1 -> num_of_big_int (power_int_positive_big_int i n) | _ -> Ratio (create_normalized_ratio unit_big_int (power_int_positive_big_int i (minus_big_int n)))) | ((Big_int bi), n) -> (match sign_big_int n with 0 -> Int 1 | 1 -> num_of_big_int (power_big_int_positive_big_int bi n) | _ -> Ratio (create_normalized_ratio unit_big_int (power_big_int_positive_big_int bi (minus_big_int n)))) | ((Ratio r), n) -> (match sign_big_int n with 0 -> Int 1 | 1 -> Ratio (power_ratio_positive_big_int r n) | _ -> Ratio (power_ratio_positive_big_int (inverse_ratio r) (minus_big_int n))) let power_num a b = match (a,b) with (n, (Int i)) -> power_num_int n i | (n, (Big_int bi)) -> power_num_big_int n bi | _ -> invalid_arg "power_num" let ( **/ ) = power_num let is_integer_num = function Int _ -> true | Big_int _ -> true | Ratio r -> is_integer_ratio r (* integer_num, floor_num, round_num, ceiling_num rendent des nums *) let integer_num = function Int i as n -> n | Big_int bi as n -> n | Ratio r -> num_of_big_int (integer_ratio r) and round_num = function Int i as n -> n | Big_int bi as n -> n | Ratio r -> num_of_big_int (round_ratio r) and ceiling_num = function Int i as n -> n | Big_int bi as n -> n | Ratio r -> num_of_big_int (ceiling_ratio r) (* Comparisons on nums *) let sign_num = function Int i -> sign_int i | Big_int bi -> sign_big_int bi | Ratio r -> sign_ratio r let eq_num a b = match (a,b) with ((Int int1), (Int int2)) -> int1 = int2 | ((Int i), (Big_int bi)) -> eq_big_int (big_int_of_int i) bi | ((Big_int bi), (Int i)) -> eq_big_int (big_int_of_int i) bi | ((Int i), (Ratio r)) -> eq_big_int_ratio (big_int_of_int i) r | ((Ratio r), (Int i)) -> eq_big_int_ratio (big_int_of_int i) r | ((Big_int bi1), (Big_int bi2)) -> eq_big_int bi1 bi2 | ((Big_int bi), (Ratio r)) -> eq_big_int_ratio bi r | ((Ratio r), (Big_int bi)) -> eq_big_int_ratio bi r | ((Ratio r1), (Ratio r2)) -> eq_ratio r1 r2 let ( =/ ) = eq_num let ( <>/ ) a b = not(eq_num a b) let compare_num a b = match (a,b) with ((Int int1), (Int int2)) -> compare_int int1 int2 | ((Int i), (Big_int bi)) -> compare_big_int (big_int_of_int i) bi | ((Big_int bi), (Int i)) -> compare_big_int bi (big_int_of_int i) | ((Int i), (Ratio r)) -> compare_big_int_ratio (big_int_of_int i) r | ((Ratio r), (Int i)) -> -(compare_big_int_ratio (big_int_of_int i) r) | ((Big_int bi1), (Big_int bi2)) -> compare_big_int bi1 bi2 | ((Big_int bi), (Ratio r)) -> compare_big_int_ratio bi r | ((Ratio r), (Big_int bi)) -> -(compare_big_int_ratio bi r) | ((Ratio r1), (Ratio r2)) -> compare_ratio r1 r2 let lt_num num1 num2 = compare_num num1 num2 < 0 and le_num num1 num2 = compare_num num1 num2 <= 0 and gt_num num1 num2 = compare_num num1 num2 > 0 and ge_num num1 num2 = compare_num num1 num2 >= 0 let ( / ) = gt_num and ( >=/ ) = ge_num let max_num num1 num2 = if lt_num num1 num2 then num2 else num1 and min_num num1 num2 = if gt_num num1 num2 then num2 else num1 (* Coercions with basic types *) (* Coercion with int type *) let int_of_num = function Int i -> i | Big_int bi -> int_of_big_int bi | Ratio r -> int_of_ratio r and num_of_int i = if i = monster_int then Big_int (big_int_of_int i) else Int i (* Coercion with nat type *) let nat_of_num = function Int i -> nat_of_int i | Big_int bi -> nat_of_big_int bi | Ratio r -> nat_of_ratio r and num_of_nat nat = if (is_nat_int nat 0 (length_nat nat)) then Int (nth_digit_nat nat 0) else Big_int (big_int_of_nat nat) (* Coercion with big_int type *) let big_int_of_num = function Int i -> big_int_of_int i | Big_int bi -> bi | Ratio r -> big_int_of_ratio r (* Coercion with ratio type *) let ratio_of_num = function Int i -> ratio_of_int i | Big_int bi -> ratio_of_big_int bi | Ratio r -> r ;; let string_of_big_int_for_num bi = if !approx_printing_flag then approx_big_int !floating_precision bi else string_of_big_int bi (* Coercion with string type *) (* XL: suppression de sys_string_of_num *) let string_of_normalized_num = function Int i -> string_of_int i | Big_int bi -> string_of_big_int_for_num bi | Ratio r -> string_of_ratio r let string_of_num n = string_of_normalized_num (cautious_normalize_num_when_printing n) let num_of_string s = try let flag = !normalize_ratio_flag in normalize_ratio_flag := true; let r = ratio_of_string s in normalize_ratio_flag := flag; if eq_big_int (denominator_ratio r) unit_big_int then num_of_big_int (numerator_ratio r) else Ratio r with Failure _ -> failwith "num_of_string" (* Coercion with float type *) let float_of_num = function Int i -> float i | Big_int bi -> float_of_big_int bi | Ratio r -> float_of_ratio r (* XL: suppression de num_of_float, float_num *) let succ_num = function Int i -> if i = biggest_int then Big_int (succ_big_int (big_int_of_int i)) else Int (succ i) | Big_int bi -> num_of_big_int (succ_big_int bi) | Ratio r -> Ratio (add_int_ratio 1 r) and pred_num = function Int i -> if i = monster_int then Big_int (pred_big_int (big_int_of_int i)) else Int (pred i) | Big_int bi -> num_of_big_int (pred_big_int bi) | Ratio r -> Ratio (add_int_ratio (-1) r) let abs_num = function Int i -> if i = monster_int then Big_int (minus_big_int (big_int_of_int i)) else Int (abs i) | Big_int bi -> Big_int (abs_big_int bi) | Ratio r -> Ratio (abs_ratio r) let approx_num_fix n num = approx_ratio_fix n (ratio_of_num num) and approx_num_exp n num = approx_ratio_exp n (ratio_of_num num) let incr_num r = r := succ_num !r and decr_num r = r := pred_num !r mingw-ocaml/ocaml/otherlibs/num/nat.mli0000644000175000017500000001064412124403241017542 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [Nat]: operations on natural numbers *) type nat (* Natural numbers (type [nat]) are positive integers of arbitrary size. All operations on [nat] are performed in-place. *) external create_nat: int -> nat = "create_nat" val make_nat: int -> nat external set_to_zero_nat: nat -> int -> int -> unit = "set_to_zero_nat" external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat" val copy_nat: nat -> int -> int -> nat external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat" external nth_digit_nat: nat -> int -> int = "nth_digit_nat" external set_digit_nat_native: nat -> int -> nativeint -> unit = "set_digit_nat_native" external nth_digit_nat_native: nat -> int -> nativeint = "nth_digit_nat_native" val length_nat : nat -> int external num_digits_nat: nat -> int -> int -> int = "num_digits_nat" external num_leading_zero_bits_in_digit: nat -> int -> int = "num_leading_zero_bits_in_digit" external is_digit_int: nat -> int -> bool = "is_digit_int" external is_digit_zero: nat -> int -> bool = "is_digit_zero" external is_digit_normalized: nat -> int -> bool = "is_digit_normalized" external is_digit_odd: nat -> int -> bool = "is_digit_odd" val is_zero_nat: nat -> int -> int -> bool val is_nat_int: nat -> int -> int -> bool val int_of_nat: nat -> int val nat_of_int: int -> nat external incr_nat: nat -> int -> int -> int -> int = "incr_nat" external add_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "add_nat" "add_nat_native" external complement_nat: nat -> int -> int -> unit = "complement_nat" external decr_nat: nat -> int -> int -> int -> int = "decr_nat" external sub_nat: nat -> int -> int -> nat -> int -> int -> int -> int = "sub_nat" "sub_nat_native" external mult_digit_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int = "mult_digit_nat" "mult_digit_nat_native" external mult_nat: nat -> int -> int -> nat -> int -> int -> nat -> int -> int -> int = "mult_nat" "mult_nat_native" external square_nat: nat -> int -> int -> nat -> int -> int -> int = "square_nat" "square_nat_native" external shift_left_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_left_nat" "shift_left_nat_native" external div_digit_nat: nat -> int -> nat -> int -> nat -> int -> int -> nat -> int -> unit = "div_digit_nat" "div_digit_nat_native" external div_nat: nat -> int -> int -> nat -> int -> int -> unit = "div_nat" "div_nat_native" external shift_right_nat: nat -> int -> int -> nat -> int -> int -> unit = "shift_right_nat" "shift_right_nat_native" external compare_digits_nat: nat -> int -> nat -> int -> int = "compare_digits_nat" external compare_nat: nat -> int -> int -> nat -> int -> int -> int = "compare_nat" "compare_nat_native" val eq_nat : nat -> int -> int -> nat -> int -> int -> bool val le_nat : nat -> int -> int -> nat -> int -> int -> bool val lt_nat : nat -> int -> int -> nat -> int -> int -> bool val ge_nat : nat -> int -> int -> nat -> int -> int -> bool val gt_nat : nat -> int -> int -> nat -> int -> int -> bool external land_digit_nat: nat -> int -> nat -> int -> unit = "land_digit_nat" external lor_digit_nat: nat -> int -> nat -> int -> unit = "lor_digit_nat" external lxor_digit_nat: nat -> int -> nat -> int -> unit = "lxor_digit_nat" val gcd_nat : nat -> int -> int -> nat -> int -> int -> int val sqrt_nat : nat -> int -> int -> nat val string_of_nat : nat -> string val nat_of_string : string -> nat val sys_nat_of_string : int -> string -> int -> int -> nat val float_of_nat : nat -> float val make_power_base : int -> nat -> int * int val power_base_int : int -> int -> nat val length_of_digit: int mingw-ocaml/ocaml/otherlibs/num/bng_digit.c0000644000175000017500000001720712124403241020351 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2003 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /**** Generic operations on digits ****/ /* These macros can be defined in the machine-specific include file. Below are the default definitions (in plain C). Except for BngMult, all macros are guaranteed to evaluate their arguments exactly once. */ #ifndef BngAdd2 /* res = arg1 + arg2. carryout = carry out. */ #define BngAdd2(res,carryout,arg1,arg2) { \ bngdigit tmp1, tmp2; \ tmp1 = arg1; \ tmp2 = tmp1 + (arg2); \ carryout = (tmp2 < tmp1); \ res = tmp2; \ } #endif #ifndef BngAdd2Carry /* res = arg1 + arg2 + carryin. carryout = carry out. */ #define BngAdd2Carry(res,carryout,arg1,arg2,carryin) { \ bngdigit tmp1, tmp2, tmp3; \ tmp1 = arg1; \ tmp2 = tmp1 + (arg2); \ tmp3 = tmp2 + (carryin); \ carryout = (tmp2 < tmp1) + (tmp3 < tmp2); \ res = tmp3; \ } #endif #ifndef BngAdd3 /* res = arg1 + arg2 + arg3. Each carry increments carryaccu. */ #define BngAdd3(res,carryaccu,arg1,arg2,arg3) { \ bngdigit tmp1, tmp2, tmp3; \ tmp1 = arg1; \ tmp2 = tmp1 + (arg2); \ carryaccu += (tmp2 < tmp1); \ tmp3 = tmp2 + (arg3); \ carryaccu += (tmp3 < tmp2); \ res = tmp3; \ } #endif #ifndef BngSub2 /* res = arg1 - arg2. carryout = carry out. */ #define BngSub2(res,carryout,arg1,arg2) { \ bngdigit tmp1, tmp2; \ tmp1 = arg1; \ tmp2 = arg2; \ res = tmp1 - tmp2; \ carryout = (tmp1 < tmp2); \ } #endif #ifndef BngSub2Carry /* res = arg1 - arg2 - carryin. carryout = carry out. */ #define BngSub2Carry(res,carryout,arg1,arg2,carryin) { \ bngdigit tmp1, tmp2, tmp3; \ tmp1 = arg1; \ tmp2 = arg2; \ tmp3 = tmp1 - tmp2; \ res = tmp3 - (carryin); \ carryout = (tmp1 < tmp2) + (tmp3 < carryin); \ } #endif #ifndef BngSub3 /* res = arg1 - arg2 - arg3. Each carry increments carryaccu. */ #define BngSub3(res,carryaccu,arg1,arg2,arg3) { \ bngdigit tmp1, tmp2, tmp3, tmp4; \ tmp1 = arg1; \ tmp2 = arg2; \ tmp3 = arg3; \ tmp4 = tmp1 - tmp2; \ res = tmp4 - tmp3; \ carryaccu += (tmp1 < tmp2) + (tmp4 < tmp3); \ } #endif #define BngLowHalf(d) ((d) & (((bngdigit)1 << BNG_BITS_PER_HALF_DIGIT) - 1)) #define BngHighHalf(d) ((d) >> BNG_BITS_PER_HALF_DIGIT) #ifndef BngMult /* resl = low digit of product arg1 * arg2 resh = high digit of product arg1 * arg2. */ #define BngMult(resh,resl,arg1,arg2) { \ bngdigit p11 = BngLowHalf(arg1) * BngLowHalf(arg2); \ bngdigit p12 = BngLowHalf(arg1) * BngHighHalf(arg2); \ bngdigit p21 = BngHighHalf(arg1) * BngLowHalf(arg2); \ bngdigit p22 = BngHighHalf(arg1) * BngHighHalf(arg2); \ resh = p22 + (p12 >> BNG_BITS_PER_HALF_DIGIT) \ + (p21 >> BNG_BITS_PER_HALF_DIGIT); \ BngAdd3(resl, resh, \ p11, p12 << BNG_BITS_PER_HALF_DIGIT, p21 << BNG_BITS_PER_HALF_DIGIT); \ } #endif #ifndef BngDiv /* Divide the double-width number nh:nl by d. Require d != 0 and nh < d. Store quotient in quo, remainder in rem. Can be slow if d is not normalized. */ #define BngDiv(quo,rem,nh,nl,d) bng_div_aux(&(quo),&(rem),nh,nl,d) #define BngDivNeedsNormalization static void bng_div_aux(bngdigit * quo, bngdigit * rem, bngdigit nh, bngdigit nl, bngdigit d) { bngdigit dl, dh, ql, qh, pl, ph, nsaved; dl = BngLowHalf(d); dh = BngHighHalf(d); /* Under-estimate the top half of the quotient (qh) */ qh = nh / (dh + 1); /* Shift nh:nl right by BNG_BITS_PER_HALF_DIGIT bits, so that we focus on the top 1.5 digits of the numerator. Then, subtract (qh * d) from nh:nl. */ nsaved = BngLowHalf(nl); ph = qh * dh; pl = qh * dl; nh -= ph; /* Subtract before shifting so that carry propagates for free */ nl = (nl >> BNG_BITS_PER_HALF_DIGIT) | (nh << BNG_BITS_PER_HALF_DIGIT); nh = (nh >> BNG_BITS_PER_HALF_DIGIT); nh -= (nl < pl); /* Borrow */ nl -= pl; /* Adjust estimate qh until nh:nl < 0:d */ while (nh != 0 || nl >= d) { nh -= (nl < d); /* Borrow */ nl -= d; qh++; } /* Under-estimate the bottom half of the quotient (ql) */ ql = nl / (dh + 1); /* Shift nh:nl left by BNG_BITS_PER_HALF_DIGIT bits, restoring the low bits we saved earlier, so that we focus on the bottom 1.5 digit of the numerator. Then, subtract (ql * d) from nh:nl. */ ph = ql * dh; pl = ql * dl; nl -= ph; /* Subtract before shifting so that carry propagates for free */ nh = (nl >> BNG_BITS_PER_HALF_DIGIT); nl = (nl << BNG_BITS_PER_HALF_DIGIT) | nsaved; nh -= (nl < pl); /* Borrow */ nl -= pl; /* Adjust estimate ql until nh:nl < 0:d */ while (nh != 0 || nl >= d) { nh -= (nl < d); /* Borrow */ nl -= d; ql++; } /* We're done */ *quo = (qh << BNG_BITS_PER_HALF_DIGIT) | ql; *rem = nl; } #endif mingw-ocaml/ocaml/otherlibs/num/arith_status.ml0000644000175000017500000000704412124403241021321 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) open Arith_flags;; let get_error_when_null_denominator () = !error_when_null_denominator_flag and set_error_when_null_denominator choice = error_when_null_denominator_flag := choice;; let get_normalize_ratio () = !normalize_ratio_flag and set_normalize_ratio choice = normalize_ratio_flag := choice;; let get_normalize_ratio_when_printing () = !normalize_ratio_when_printing_flag and set_normalize_ratio_when_printing choice = normalize_ratio_when_printing_flag := choice;; let get_floating_precision () = !floating_precision and set_floating_precision i = floating_precision := i;; let get_approx_printing () = !approx_printing_flag and set_approx_printing b = approx_printing_flag := b;; let arith_print_string s = print_string s; print_string " --> ";; let arith_print_bool = function true -> print_string "ON" | _ -> print_string "OFF" ;; let arith_status () = print_newline (); arith_print_string "Normalization during computation"; arith_print_bool (get_normalize_ratio ()); print_newline (); print_string " (returned by get_normalize_ratio ())"; print_newline (); print_string " (modifiable with set_normalize_ratio )"; print_newline (); print_newline (); arith_print_string "Normalization when printing"; arith_print_bool (get_normalize_ratio_when_printing ()); print_newline (); print_string " (returned by get_normalize_ratio_when_printing ())"; print_newline (); print_string " (modifiable with set_normalize_ratio_when_printing )"; print_newline (); print_newline (); arith_print_string "Floating point approximation when printing rational numbers"; arith_print_bool (get_approx_printing ()); print_newline (); print_string " (returned by get_approx_printing ())"; print_newline (); print_string " (modifiable with set_approx_printing )"; print_newline (); (if (get_approx_printing ()) then (print_string " Default precision = "; print_int (get_floating_precision ()); print_newline (); print_string " (returned by get_floating_precision ())"; print_newline (); print_string " (modifiable with set_floating_precision )"; print_newline (); print_newline ()) else print_newline()); arith_print_string "Error when a rational denominator is null"; arith_print_bool (get_error_when_null_denominator ()); print_newline (); print_string " (returned by get_error_when_null_denominator ())"; print_newline (); print_string " (modifiable with set_error_when_null_denominator )"; print_newline () ;; mingw-ocaml/ocaml/otherlibs/num/num.mli0000644000175000017500000001155712124403241017563 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Operation on arbitrary-precision numbers. Numbers (type [num]) are arbitrary-precision rational numbers, plus the special elements [1/0] (infinity) and [0/0] (undefined). *) open Nat open Big_int open Ratio (** The type of numbers. *) type num = Int of int | Big_int of big_int | Ratio of ratio (** {6 Arithmetic operations} *) val ( +/ ) : num -> num -> num (** Same as {!Num.add_num}.*) val add_num : num -> num -> num (** Addition *) val minus_num : num -> num (** Unary negation. *) val ( -/ ) : num -> num -> num (** Same as {!Num.sub_num}.*) val sub_num : num -> num -> num (** Subtraction *) val ( */ ) : num -> num -> num (** Same as {!Num.mult_num}.*) val mult_num : num -> num -> num (** Multiplication *) val square_num : num -> num (** Squaring *) val ( // ) : num -> num -> num (** Same as {!Num.div_num}.*) val div_num : num -> num -> num (** Division *) val quo_num : num -> num -> num (** Euclidean division: quotient. *) val mod_num : num -> num -> num (** Euclidean division: remainder. *) val ( **/ ) : num -> num -> num (** Same as {!Num.power_num}. *) val power_num : num -> num -> num (** Exponentiation *) val abs_num : num -> num (** Absolute value. *) val succ_num : num -> num (** [succ n] is [n+1] *) val pred_num : num -> num (** [pred n] is [n-1] *) val incr_num : num ref -> unit (** [incr r] is [r:=!r+1], where [r] is a reference to a number. *) val decr_num : num ref -> unit (** [decr r] is [r:=!r-1], where [r] is a reference to a number. *) val is_integer_num : num -> bool (** Test if a number is an integer *) (** The four following functions approximate a number by an integer : *) val integer_num : num -> num (** [integer_num n] returns the integer closest to [n]. In case of ties, rounds towards zero. *) val floor_num : num -> num (** [floor_num n] returns the largest integer smaller or equal to [n]. *) val round_num : num -> num (** [round_num n] returns the integer closest to [n]. In case of ties, rounds off zero. *) val ceiling_num : num -> num (** [ceiling_num n] returns the smallest integer bigger or equal to [n]. *) val sign_num : num -> int (** Return [-1], [0] or [1] according to the sign of the argument. *) (** {7 Comparisons between numbers} *) val ( =/ ) : num -> num -> bool val ( num -> bool val ( >/ ) : num -> num -> bool val ( <=/ ) : num -> num -> bool val ( >=/ ) : num -> num -> bool val ( <>/ ) : num -> num -> bool val eq_num : num -> num -> bool val lt_num : num -> num -> bool val le_num : num -> num -> bool val gt_num : num -> num -> bool val ge_num : num -> num -> bool val compare_num : num -> num -> int (** Return [-1], [0] or [1] if the first argument is less than, equal to, or greater than the second argument. *) val max_num : num -> num -> num (** Return the greater of the two arguments. *) val min_num : num -> num -> num (** Return the smaller of the two arguments. *) (** {6 Coercions with strings} *) val string_of_num : num -> string (** Convert a number to a string, using fractional notation. *) val approx_num_fix : int -> num -> string (** See {!Num.approx_num_exp}.*) val approx_num_exp : int -> num -> string (** Approximate a number by a decimal. The first argument is the required precision. The second argument is the number to approximate. {!Num.approx_num_fix} uses decimal notation; the first argument is the number of digits after the decimal point. [approx_num_exp] uses scientific (exponential) notation; the first argument is the number of digits in the mantissa. *) val num_of_string : string -> num (** Convert a string to a number. Raise [Failure "num_of_string"] if the given string is not a valid representation of an integer *) (** {6 Coercions between numerical types} *) val int_of_num : num -> int val num_of_int : int -> num val nat_of_num : num -> nat val num_of_nat : nat -> num val num_of_big_int : big_int -> num val big_int_of_num : num -> big_int val ratio_of_num : num -> ratio val num_of_ratio : ratio -> num val float_of_num : num -> float mingw-ocaml/ocaml/otherlibs/num/.depend0000644000175000017500000000314112124403241017507 0ustar tootstootsbng.o: bng.c bng.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/compatibility.h bng_amd64.c \ bng_digit.c bng_amd64.o: bng_amd64.c bng_digit.o: bng_digit.c bng_ia32.o: bng_ia32.c bng_ppc.o: bng_ppc.c bng_sparc.o: bng_sparc.c nat_stubs.o: nat_stubs.c ../../byterun/alloc.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/config.h ../../byterun/custom.h ../../byterun/intext.h \ ../../byterun/io.h ../../byterun/fail.h ../../byterun/hash.h \ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h \ ../../byterun/mlvalues.h bng.h nat.h arith_flags.cmi : arith_status.cmi : big_int.cmi : nat.cmi int_misc.cmi : nat.cmi : num.cmi : ratio.cmi nat.cmi big_int.cmi ratio.cmi : nat.cmi big_int.cmi arith_flags.cmo : arith_flags.cmi arith_flags.cmx : arith_flags.cmi arith_status.cmo : arith_flags.cmi arith_status.cmi arith_status.cmx : arith_flags.cmx arith_status.cmi big_int.cmo : nat.cmi int_misc.cmi big_int.cmi big_int.cmx : nat.cmx int_misc.cmx big_int.cmi int_misc.cmo : int_misc.cmi int_misc.cmx : int_misc.cmi nat.cmo : int_misc.cmi nat.cmi nat.cmx : int_misc.cmx nat.cmi num.cmo : ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi num.cmx : ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi ratio.cmo : nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi ratio.cmx : nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi mingw-ocaml/ocaml/otherlibs/num/bng_sparc.c0000644000175000017500000001101212124403241020345 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2003 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Code specific to the SPARC (V8 and above) architecture. */ #define BngAdd2(res,carryout,arg1,arg2) \ asm("addcc %2, %3, %0 \n\t" \ "addx %%g0, 0, %1" \ : "=r" (res), "=r" (carryout) \ : "r" (arg1), "r" (arg2) \ : "cc") #define BngAdd2Carry(res,carryout,arg1,arg2,carryin) \ asm("subcc %%g0, %4, %%g0 \n\t" \ "addxcc %2, %3, %0 \n\t" \ "addx %%g0, 0, %1" \ : "=r" (res), "=r" (carryout) \ : "r" (arg1), "r" (arg2), "r" (carryin) \ : "cc") #define BngAdd3(res,carryaccu,arg1,arg2,arg3) \ asm("addcc %2, %3, %0 \n\t" \ "addx %1, 0, %1 \n\t" \ "addcc %0, %4, %0 \n\t" \ "addx %1, 0, %1" \ : "=r" (res), "=r" (carryaccu) \ : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu) \ : "cc") #define BngSub2(res,carryout,arg1,arg2) \ asm("subcc %2, %3, %0 \n\t" \ "addx %%g0, 0, %1" \ : "=r" (res), "=r" (carryout) \ : "r" (arg1), "r" (arg2) \ : "cc") #define BngSub2Carry(res,carryout,arg1,arg2,carryin) \ asm("subcc %%g0, %4, %%g0 \n\t" \ "subxcc %2, %3, %0 \n\t" \ "addx %%g0, 0, %1" \ : "=r" (res), "=r" (carryout) \ : "r" (arg1), "r" (arg2), "r" (carryin) \ : "cc") #define BngSub3(res,carryaccu,arg1,arg2,arg3) \ asm("subcc %2, %3, %0 \n\t" \ "addx %1, 0, %1 \n\t" \ "subcc %0, %4, %0 \n\t" \ "addx %1, 0, %1" \ : "=r" (res), "=r" (carryaccu) \ : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu) \ : "cc") #define BngMult(resh,resl,arg1,arg2) \ asm("umul %2, %3, %0 \n\t" \ "rd %%y, %1" \ : "=r" (resl), "=r" (resh) \ : "r" (arg1), "r" (arg2)) #define BngDiv(quo,rem,nh,nl,d) \ asm("wr %1, %%y \n\t" \ "udiv %2, %3, %0" \ : "=r" (quo) \ : "r" (nh), "r" (nl), "r" (d)); \ rem = nl - d * quo mingw-ocaml/ocaml/otherlibs/num/int_misc.ml0000644000175000017500000000265412124403241020416 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Some extra operations on integers *) let rec gcd_int i1 i2 = if i2 = 0 then abs i1 else gcd_int i2 (i1 mod i2) ;; let rec num_bits_int_aux n = if n = 0 then 0 else succ(num_bits_int_aux (n lsr 1));; let num_bits_int n = num_bits_int_aux (abs n);; let sign_int i = if i = 0 then 0 else if i > 0 then 1 else -1;; let length_of_int = Sys.word_size - 2;; let monster_int = 1 lsl length_of_int;; let biggest_int = monster_int - 1;; let least_int = - biggest_int;; let compare_int n1 n2 = if n1 == n2 then 0 else if n1 > n2 then 1 else -1;; mingw-ocaml/ocaml/otherlibs/graph/0000755000175000017500000000000012124403241016552 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/graph/graphicsX11.ml0000644000175000017500000000315012124403241021175 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis and Jun Furuse, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [GraphicsX11]: additional graphics primitives for the X Windows system *) type window_id = string external window_id : unit -> window_id = "caml_gr_window_id" let subwindows = Hashtbl.create 13 external open_subwindow : int -> int -> int -> int -> window_id = "caml_gr_open_subwindow" external close_subwindow : window_id -> unit = "caml_gr_close_subwindow" let open_subwindow ~x ~y ~width ~height = let wid = open_subwindow x y width height in Hashtbl.add subwindows wid (); wid ;; let close_subwindow wid = if Hashtbl.mem subwindows wid then begin close_subwindow wid; Hashtbl.remove subwindows wid end else raise (Graphics.Graphic_failure ("close_subwindow: no such subwindow: " ^ wid)) ;; mingw-ocaml/ocaml/otherlibs/graph/image.c0000644000175000017500000000673412124403241020012 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "libgraph.h" #include "image.h" #include #include static void caml_gr_free_image(value im) { XFreePixmap(caml_gr_display, Data_im(im)); if (Mask_im(im) != None) XFreePixmap(caml_gr_display, Mask_im(im)); } static struct custom_operations image_ops = { "_image", caml_gr_free_image, custom_compare_default, custom_hash_default, custom_serialize_default, custom_deserialize_default, custom_compare_ext_default }; #define Max_image_mem 2000000 value caml_gr_new_image(int w, int h) { value res = alloc_custom(&image_ops, sizeof(struct grimage), w * h, Max_image_mem); Width_im(res) = w; Height_im(res) = h; Data_im(res) = XCreatePixmap(caml_gr_display, caml_gr_window.win, w, h, XDefaultDepth(caml_gr_display, caml_gr_screen)); Mask_im(res) = None; return res; } value caml_gr_create_image(value vw, value vh) { caml_gr_check_open(); return caml_gr_new_image(Int_val(vw), Int_val(vh)); } value caml_gr_blit_image(value im, value vx, value vy) { int x = Int_val(vx); int y = Int_val(vy); caml_gr_check_open(); XCopyArea(caml_gr_display, caml_gr_bstore.win, Data_im(im), caml_gr_bstore.gc, x, Bcvt(y) + 1 - Height_im(im), Width_im(im), Height_im(im), 0, 0); return Val_unit; } value caml_gr_draw_image(value im, value vx, value vy) { int x = Int_val(vx); int y = Int_val(vy); int wy = Wcvt(y) + 1 - Height_im(im); int by = Bcvt(y) + 1 - Height_im(im); caml_gr_check_open(); if (Mask_im(im) != None) { if(caml_gr_remember_modeflag) { XSetClipOrigin(caml_gr_display, caml_gr_bstore.gc, x, by); XSetClipMask(caml_gr_display, caml_gr_bstore.gc, Mask_im(im)); } if(caml_gr_display_modeflag) { XSetClipOrigin(caml_gr_display, caml_gr_window.gc, x, wy); XSetClipMask(caml_gr_display, caml_gr_window.gc, Mask_im(im)); } } if(caml_gr_remember_modeflag) XCopyArea(caml_gr_display, Data_im(im), caml_gr_bstore.win, caml_gr_bstore.gc, 0, 0, Width_im(im), Height_im(im), x, by); if(caml_gr_display_modeflag) XCopyArea(caml_gr_display, Data_im(im), caml_gr_window.win, caml_gr_window.gc, 0, 0, Width_im(im), Height_im(im), x, wy); if (Mask_im(im) != None) { if(caml_gr_remember_modeflag) XSetClipMask(caml_gr_display, caml_gr_bstore.gc, None); if(caml_gr_display_modeflag) XSetClipMask(caml_gr_display, caml_gr_window.gc, None); } if(caml_gr_display_modeflag) XFlush(caml_gr_display); return Val_unit; } /* eof $Id$ */ mingw-ocaml/ocaml/otherlibs/graph/point_col.c0000644000175000017500000000234312124403241020706 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "libgraph.h" value caml_gr_point_color(value vx, value vy) { int x = Int_val(vx); int y = Int_val(vy); XImage * im; int rgb; caml_gr_check_open(); im = XGetImage(caml_gr_display, caml_gr_bstore.win, x, Bcvt(y), 1, 1, (-1), ZPixmap); rgb = caml_gr_rgb_pixel(XGetPixel(im, 0, 0)); XDestroyImage(im); return Val_int(rgb); } mingw-ocaml/ocaml/otherlibs/graph/text.c0000644000175000017500000000540612124403241017707 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "libgraph.h" #include XFontStruct * caml_gr_font = NULL; static void caml_gr_get_font(char *fontname) { XFontStruct * font = XLoadQueryFont(caml_gr_display, fontname); if (font == NULL) caml_gr_fail("cannot find font %s", fontname); if (caml_gr_font != NULL) XFreeFont(caml_gr_display, caml_gr_font); caml_gr_font = font; XSetFont(caml_gr_display, caml_gr_window.gc, caml_gr_font->fid); XSetFont(caml_gr_display, caml_gr_bstore.gc, caml_gr_font->fid); } value caml_gr_set_font(value fontname) { caml_gr_check_open(); caml_gr_get_font(String_val(fontname)); return Val_unit; } value caml_gr_set_text_size (value sz) { return Val_unit; } static void caml_gr_draw_text(char *txt, int len) { if (caml_gr_font == NULL) caml_gr_get_font(DEFAULT_FONT); if (caml_gr_remember_modeflag) XDrawString(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, caml_gr_x, Bcvt(caml_gr_y) - caml_gr_font->descent + 1, txt, len); if (caml_gr_display_modeflag) { XDrawString(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, caml_gr_x, Wcvt(caml_gr_y) - caml_gr_font->descent + 1, txt, len); XFlush(caml_gr_display); } caml_gr_x += XTextWidth(caml_gr_font, txt, len); } value caml_gr_draw_char(value chr) { char str[1]; caml_gr_check_open(); str[0] = Int_val(chr); caml_gr_draw_text(str, 1); return Val_unit; } value caml_gr_draw_string(value str) { caml_gr_check_open(); caml_gr_draw_text(String_val(str), string_length(str)); return Val_unit; } value caml_gr_text_size(value str) { int width; value res; caml_gr_check_open(); if (caml_gr_font == NULL) caml_gr_get_font(DEFAULT_FONT); width = XTextWidth(caml_gr_font, String_val(str), string_length(str)); res = alloc_small(2, 0); Field(res, 0) = Val_int(width); Field(res, 1) = Val_int(caml_gr_font->ascent + caml_gr_font->descent); return res; } mingw-ocaml/ocaml/otherlibs/graph/graphicsX11.mli0000644000175000017500000000263212124403241021352 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis and Jun Furuse, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Additional graphics primitives for the X Windows system. *) type window_id = string val window_id : unit -> window_id (** Return the unique identifier of the OCaml graphics window. The returned string is an unsigned 32 bits integer in decimal form. *) val open_subwindow : x:int -> y:int -> width:int -> height:int -> window_id (** Create a sub-window of the current OCaml graphics window and return its identifier. *) val close_subwindow : window_id -> unit (** Close the sub-window having the given identifier. *) mingw-ocaml/ocaml/otherlibs/graph/events.c0000644000175000017500000002206512124403241020227 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include "libgraph.h" #include #include #include #include #ifdef HAS_SYS_SELECT_H #include #endif #include #include struct event_data { short kind; short mouse_x, mouse_y; unsigned char button; unsigned char key; }; static struct event_data caml_gr_queue[SIZE_QUEUE]; static unsigned int caml_gr_head = 0; /* position of next read */ static unsigned int caml_gr_tail = 0; /* position of next write */ #define QueueIsEmpty (caml_gr_tail == caml_gr_head) static void caml_gr_enqueue_event(int kind, int mouse_x, int mouse_y, int button, int key) { struct event_data * ev; ev = &(caml_gr_queue[caml_gr_tail]); ev->kind = kind; ev->mouse_x = mouse_x; ev->mouse_y = mouse_y; ev->button = (button != 0); ev->key = key; caml_gr_tail = (caml_gr_tail + 1) % SIZE_QUEUE; /* If queue was full, it now appears empty; drop oldest entry from queue. */ if (QueueIsEmpty) caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE; } #define BUTTON_STATE(state) \ ((state) & (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask)) void caml_gr_handle_event(XEvent * event) { switch (event->type) { case Expose: XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win, caml_gr_window.gc, event->xexpose.x, event->xexpose.y + caml_gr_bstore.h - caml_gr_window.h, event->xexpose.width, event->xexpose.height, event->xexpose.x, event->xexpose.y); XFlush(caml_gr_display); break; case ConfigureNotify: caml_gr_window.w = event->xconfigure.width; caml_gr_window.h = event->xconfigure.height; if (caml_gr_window.w > caml_gr_bstore.w || caml_gr_window.h > caml_gr_bstore.h) { /* Allocate a new backing store large enough to accomodate both the old backing store and the current window. */ struct canvas newbstore; newbstore.w = max(caml_gr_window.w, caml_gr_bstore.w); newbstore.h = max(caml_gr_window.h, caml_gr_bstore.h); newbstore.win = XCreatePixmap(caml_gr_display, caml_gr_window.win, newbstore.w, newbstore.h, XDefaultDepth(caml_gr_display, caml_gr_screen)); newbstore.gc = XCreateGC(caml_gr_display, newbstore.win, 0, NULL); XSetBackground(caml_gr_display, newbstore.gc, caml_gr_white); XSetForeground(caml_gr_display, newbstore.gc, caml_gr_white); XFillRectangle(caml_gr_display, newbstore.win, newbstore.gc, 0, 0, newbstore.w, newbstore.h); XSetForeground(caml_gr_display, newbstore.gc, caml_gr_color); if (caml_gr_font != NULL) XSetFont(caml_gr_display, newbstore.gc, caml_gr_font->fid); /* Copy the old backing store into the new one */ XCopyArea(caml_gr_display, caml_gr_bstore.win, newbstore.win, newbstore.gc, 0, 0, caml_gr_bstore.w, caml_gr_bstore.h, 0, newbstore.h - caml_gr_bstore.h); /* Free the old backing store */ XFreeGC(caml_gr_display, caml_gr_bstore.gc); XFreePixmap(caml_gr_display, caml_gr_bstore.win); /* Use the new backing store */ caml_gr_bstore = newbstore; XFlush(caml_gr_display); } break; case MappingNotify: XRefreshKeyboardMapping(&(event->xmapping)); break; case KeyPress: { KeySym thekey; char keytxt[256]; int nchars; char * p; nchars = XLookupString(&(event->xkey), keytxt, sizeof(keytxt), &thekey, 0); for (p = keytxt; nchars > 0; p++, nchars--) caml_gr_enqueue_event(event->type, event->xkey.x, event->xkey.y, BUTTON_STATE(event->xkey.state), *p); break; } case ButtonPress: case ButtonRelease: caml_gr_enqueue_event(event->type, event->xbutton.x, event->xbutton.y, event->type == ButtonPress, 0); break; case MotionNotify: caml_gr_enqueue_event(event->type, event->xmotion.x, event->xmotion.y, BUTTON_STATE(event->xmotion.state), 0); break; } } static value caml_gr_wait_allocate_result(int mouse_x, int mouse_y, int button, int keypressed, int key) { value res = alloc_small(5, 0); Field(res, 0) = Val_int(mouse_x); Field(res, 1) = Val_int(mouse_y == -1 ? -1 : Wcvt(mouse_y)); Field(res, 2) = Val_bool(button); Field(res, 3) = Val_bool(keypressed); Field(res, 4) = Val_int(key & 0xFF); return res; } static value caml_gr_wait_event_poll(void) { int mouse_x, mouse_y, button, key, keypressed; Window rootwin, childwin; int root_x, root_y, win_x, win_y; unsigned int modifiers; unsigned int i; if (XQueryPointer(caml_gr_display, caml_gr_window.win, &rootwin, &childwin, &root_x, &root_y, &win_x, &win_y, &modifiers)) { mouse_x = win_x; mouse_y = win_y; } else { mouse_x = -1; mouse_y = -1; } button = modifiers & (Button1Mask | Button2Mask | Button3Mask | Button4Mask | Button5Mask); /* Look inside event queue for pending KeyPress events */ key = 0; keypressed = False; for (i = caml_gr_head; i != caml_gr_tail; i = (i + 1) % SIZE_QUEUE) { if (caml_gr_queue[i].kind == KeyPress) { keypressed = True; key = caml_gr_queue[i].key; break; } } return caml_gr_wait_allocate_result(mouse_x, mouse_y, button, keypressed, key); } static value caml_gr_wait_event_in_queue(long mask) { struct event_data * ev; /* Pop events in queue until one matches mask. */ while (caml_gr_head != caml_gr_tail) { ev = &(caml_gr_queue[caml_gr_head]); caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE; if ((ev->kind == KeyPress && (mask & KeyPressMask)) || (ev->kind == ButtonPress && (mask & ButtonPressMask)) || (ev->kind == ButtonRelease && (mask & ButtonReleaseMask)) || (ev->kind == MotionNotify && (mask & PointerMotionMask))) return caml_gr_wait_allocate_result(ev->mouse_x, ev->mouse_y, ev->button, ev->kind == KeyPress, ev->key); } return Val_false; } static value caml_gr_wait_event_blocking(long mask) { XEvent event; fd_set readfds; value res; /* First see if we have a matching event in the queue */ res = caml_gr_wait_event_in_queue(mask); if (res != Val_false) return res; /* Increase the selected events if required */ if ((mask & ~caml_gr_selected_events) != 0) { caml_gr_selected_events |= mask; XSelectInput(caml_gr_display, caml_gr_window.win, caml_gr_selected_events); } /* Replenish our event queue from that of X11 */ caml_gr_ignore_sigio = True; while (1) { if (XCheckMaskEvent(caml_gr_display, -1 /*all events*/, &event)) { /* One event available: add it to our queue */ caml_gr_handle_event(&event); /* See if we now have a matching event */ res = caml_gr_wait_event_in_queue(mask); if (res != Val_false) break; } else { /* No event available: block on input socket until one is */ FD_ZERO(&readfds); FD_SET(ConnectionNumber(caml_gr_display), &readfds); enter_blocking_section(); select(FD_SETSIZE, &readfds, NULL, NULL, NULL); leave_blocking_section(); caml_gr_check_open(); /* in case another thread closed the display */ } } caml_gr_ignore_sigio = False; /* Return result */ return res; } value caml_gr_wait_event(value eventlist) /* ML */ { int mask; Bool poll; caml_gr_check_open(); mask = 0; poll = False; while (eventlist != Val_int(0)) { switch (Int_val(Field(eventlist, 0))) { case 0: /* Button_down */ mask |= ButtonPressMask | OwnerGrabButtonMask; break; case 1: /* Button_up */ mask |= ButtonReleaseMask | OwnerGrabButtonMask; break; case 2: /* Key_pressed */ mask |= KeyPressMask; break; case 3: /* Mouse_motion */ mask |= PointerMotionMask; break; case 4: /* Poll */ poll = True; break; } eventlist = Field(eventlist, 1); } if (poll) return caml_gr_wait_event_poll(); else return caml_gr_wait_event_blocking(mask); } mingw-ocaml/ocaml/otherlibs/graph/Makefile0000644000175000017500000000255012124403241020214 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ # Makefile for the portable graphics library LIBNAME=graphics COBJS=open.o draw.o fill.o color.o text.o \ image.o make_img.o dump_img.o point_col.o sound.o events.o \ subwindow.o CAMLOBJS=graphics.cmo graphicsX11.cmo LINKOPTS=-cclib "\"$(X11_LINK)\"" LDOPTS=-ldopt "$(X11_LINK)" EXTRACFLAGS=$(X11_INCLUDES) include ../Makefile depend: gcc -MM $(CFLAGS) *.c | sed -e 's, /usr[^ ]*\.h,,g' > .depend ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend include .depend mingw-ocaml/ocaml/otherlibs/graph/open.c0000644000175000017500000003102012124403241017653 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include "libgraph.h" #include #include #include #include #ifdef HAS_UNISTD #include #endif #ifdef HAS_SETITIMER #include #endif Display * caml_gr_display = NULL; int caml_gr_screen; Colormap caml_gr_colormap; int caml_gr_white, caml_gr_black, caml_gr_background; struct canvas caml_gr_window; struct canvas caml_gr_bstore; Bool caml_gr_display_modeflag; Bool caml_gr_remember_modeflag; int caml_gr_x, caml_gr_y; int caml_gr_color; extern XFontStruct * caml_gr_font; long caml_gr_selected_events; Bool caml_gr_ignore_sigio = False; static Bool caml_gr_initialized = False; static char * window_name = NULL; static int caml_gr_error_handler(Display *display, XErrorEvent *error); static int caml_gr_ioerror_handler(Display *display); value caml_gr_clear_graph(void); value caml_gr_open_graph(value arg) { char display_name[256], geometry_spec[64]; char * p, * q; XSizeHints hints; int ret; XEvent event; int x, y, w, h; XWindowAttributes attributes; if (caml_gr_initialized) { caml_gr_clear_graph(); } else { /* Parse the argument */ for (p = String_val(arg), q = display_name; *p != 0 && *p != ' '; p++) if (q < display_name + sizeof(display_name) - 1) *q++ = *p; *q = 0; while (*p == ' ') p++; for (q = geometry_spec; *p != 0; p++) if (q < geometry_spec + sizeof(geometry_spec) - 1) *q++ = *p; *q = 0; /* Open the display */ if (caml_gr_display == NULL) { caml_gr_display = XOpenDisplay(display_name); if (caml_gr_display == NULL) caml_gr_fail("Cannot open display %s", XDisplayName(display_name)); caml_gr_screen = DefaultScreen(caml_gr_display); caml_gr_black = BlackPixel(caml_gr_display, caml_gr_screen); caml_gr_white = WhitePixel(caml_gr_display, caml_gr_screen); caml_gr_background = caml_gr_white; caml_gr_colormap = DefaultColormap(caml_gr_display, caml_gr_screen); } /* Set up the error handlers */ XSetErrorHandler(caml_gr_error_handler); XSetIOErrorHandler(caml_gr_ioerror_handler); /* Parse the geometry specification */ hints.x = 0; hints.y = 0; hints.width = DEFAULT_SCREEN_WIDTH; hints.height = DEFAULT_SCREEN_HEIGHT; hints.flags = PPosition | PSize; hints.win_gravity = 0; ret = XWMGeometry(caml_gr_display, caml_gr_screen, geometry_spec, "", BORDER_WIDTH, &hints, &x, &y, &w, &h, &hints.win_gravity); if (ret & (XValue | YValue)) { hints.x = x; hints.y = y; hints.flags |= USPosition; } if (ret & (WidthValue | HeightValue)) { hints.width = w; hints.height = h; hints.flags |= USSize; } /* Initial drawing color is black */ caml_gr_color = 0; /* CAML COLOR */ /* Create the on-screen window */ caml_gr_window.w = hints.width; caml_gr_window.h = hints.height; caml_gr_window.win = XCreateSimpleWindow(caml_gr_display, DefaultRootWindow(caml_gr_display), hints.x, hints.y, hints.width, hints.height, BORDER_WIDTH, caml_gr_black, caml_gr_background); p = window_name; if (p == NULL) p = DEFAULT_WINDOW_NAME; /* What not use XSetWMProperties? */ XSetStandardProperties(caml_gr_display, caml_gr_window.win, p, p, None, NULL, 0, &hints); caml_gr_window.gc = XCreateGC(caml_gr_display, caml_gr_window.win, 0, NULL); XSetBackground(caml_gr_display, caml_gr_window.gc, caml_gr_background); XSetForeground(caml_gr_display, caml_gr_window.gc, caml_gr_black); /* Require exposure, resize and keyboard events */ caml_gr_selected_events = DEFAULT_SELECTED_EVENTS; XSelectInput(caml_gr_display, caml_gr_window.win, caml_gr_selected_events); /* Map the window on the screen and wait for the first Expose event */ XMapWindow(caml_gr_display, caml_gr_window.win); do { XNextEvent(caml_gr_display, &event); } while (event.type != Expose); /* Get the actual window dimensions */ XGetWindowAttributes(caml_gr_display, caml_gr_window.win, &attributes); caml_gr_window.w = attributes.width; caml_gr_window.h = attributes.height; /* Create the pixmap used for backing store */ caml_gr_bstore.w = caml_gr_window.w; caml_gr_bstore.h = caml_gr_window.h; caml_gr_bstore.win = XCreatePixmap(caml_gr_display, caml_gr_window.win, caml_gr_bstore.w, caml_gr_bstore.h, XDefaultDepth(caml_gr_display, caml_gr_screen)); caml_gr_bstore.gc = XCreateGC(caml_gr_display, caml_gr_bstore.win, 0, NULL); XSetBackground(caml_gr_display, caml_gr_bstore.gc, caml_gr_background); /* Clear the pixmap */ XSetForeground(caml_gr_display, caml_gr_bstore.gc, caml_gr_background); XFillRectangle(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, 0, 0, caml_gr_bstore.w, caml_gr_bstore.h); XSetForeground(caml_gr_display, caml_gr_bstore.gc, caml_gr_black); /* Set the display and remember modes on */ caml_gr_display_modeflag = True ; caml_gr_remember_modeflag = True ; /* The global data structures are now correctly initialized. In particular, caml_gr_sigio_handler can now handle events safely. */ caml_gr_initialized = True; /* If possible, request that system calls be restarted after the EVENT_SIGNAL signal. */ #ifdef POSIX_SIGNALS #ifdef SA_RESTART { struct sigaction action; sigaction(EVENT_SIGNAL, NULL, &action); action.sa_flags |= SA_RESTART; sigaction(EVENT_SIGNAL, &action, NULL); } #endif #endif #ifdef USE_ASYNC_IO /* If BSD-style asynchronous I/O are supported: arrange for I/O on the connection to trigger the SIGIO signal */ ret = fcntl(ConnectionNumber(caml_gr_display), F_GETFL, 0); fcntl(ConnectionNumber(caml_gr_display), F_SETFL, ret | FASYNC); fcntl(ConnectionNumber(caml_gr_display), F_SETOWN, getpid()); #endif } #ifdef USE_INTERVAL_TIMER /* If BSD-style interval timers are provided, use the real-time timer to poll events. */ { struct itimerval it; it.it_interval.tv_sec = 0; it.it_interval.tv_usec = 250000; it.it_value.tv_sec = 0; it.it_value.tv_usec = 250000; setitimer(ITIMER_REAL, &it, NULL); } #endif #ifdef USE_ALARM /* The poor man's solution: use alarm to poll events. */ alarm(1); #endif /* Position the current point at origin */ caml_gr_x = 0; caml_gr_y = 0; /* Reset the color cache */ caml_gr_init_color_cache(); caml_gr_init_direct_rgb_to_pixel(); return Val_unit; } value caml_gr_close_graph(void) { if (caml_gr_initialized) { #ifdef USE_INTERVAL_TIMER struct itimerval it; it.it_value.tv_sec = 0; it.it_value.tv_usec = 0; setitimer(ITIMER_REAL, &it, NULL); #endif caml_gr_initialized = False; if (caml_gr_font != NULL) { XFreeFont(caml_gr_display, caml_gr_font); caml_gr_font = NULL; } XFreeGC(caml_gr_display, caml_gr_window.gc); XDestroyWindow(caml_gr_display, caml_gr_window.win); XFreeGC(caml_gr_display, caml_gr_bstore.gc); XFreePixmap(caml_gr_display, caml_gr_bstore.win); XFlush(caml_gr_display); XCloseDisplay (caml_gr_display); caml_gr_display = NULL; } return Val_unit; } value caml_gr_id_of_window(Window win) { char tmp[256]; sprintf(tmp, "%lu", (unsigned long)win); return copy_string( tmp ); } value caml_gr_window_id(void) { caml_gr_check_open(); return caml_gr_id_of_window(caml_gr_window.win); } value caml_gr_set_window_title(value n) { if (window_name != NULL) stat_free(window_name); window_name = stat_alloc(strlen(String_val(n))+1); strcpy(window_name, String_val(n)); if (caml_gr_initialized) { XStoreName(caml_gr_display, caml_gr_window.win, window_name); XSetIconName(caml_gr_display, caml_gr_window.win, window_name); XFlush(caml_gr_display); } return Val_unit; } value caml_gr_resize_window (value vx, value vy) { caml_gr_check_open (); caml_gr_window.w = Int_val (vx); caml_gr_window.h = Int_val (vy); XResizeWindow (caml_gr_display, caml_gr_window.win, caml_gr_window.w, caml_gr_window.h); XFreeGC(caml_gr_display, caml_gr_bstore.gc); XFreePixmap(caml_gr_display, caml_gr_bstore.win); caml_gr_bstore.w = caml_gr_window.w; caml_gr_bstore.h = caml_gr_window.h; caml_gr_bstore.win = XCreatePixmap(caml_gr_display, caml_gr_window.win, caml_gr_bstore.w, caml_gr_bstore.h, XDefaultDepth(caml_gr_display, caml_gr_screen)); caml_gr_bstore.gc = XCreateGC(caml_gr_display, caml_gr_bstore.win, 0, NULL); XSetBackground(caml_gr_display, caml_gr_bstore.gc, caml_gr_background); caml_gr_clear_graph (); return Val_unit; } value caml_gr_clear_graph(void) { caml_gr_check_open(); if(caml_gr_remember_modeflag) { XSetForeground(caml_gr_display, caml_gr_bstore.gc, caml_gr_white); XFillRectangle(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, 0, 0, caml_gr_bstore.w, caml_gr_bstore.h); XSetForeground(caml_gr_display, caml_gr_bstore.gc, caml_gr_color); } if(caml_gr_display_modeflag) { XSetForeground(caml_gr_display, caml_gr_window.gc, caml_gr_white); XFillRectangle(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, 0, 0, caml_gr_window.w, caml_gr_window.h); XSetForeground(caml_gr_display, caml_gr_window.gc, caml_gr_color); XFlush(caml_gr_display); } caml_gr_init_color_cache(); caml_gr_init_direct_rgb_to_pixel(); return Val_unit; } value caml_gr_size_x(void) { caml_gr_check_open(); return Val_int(caml_gr_window.w); } value caml_gr_size_y(void) { caml_gr_check_open(); return Val_int(caml_gr_window.h); } value caml_gr_synchronize(void) { caml_gr_check_open(); XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win, caml_gr_window.gc, 0, caml_gr_bstore.h - caml_gr_window.h, caml_gr_window.w, caml_gr_window.h, 0, 0); XFlush(caml_gr_display); return Val_unit ; } value caml_gr_display_mode(value flag) { caml_gr_display_modeflag = Bool_val (flag); return Val_unit ; } value caml_gr_remember_mode(value flag) { caml_gr_remember_modeflag = Bool_val(flag); return Val_unit ; } /* The caml_gr_sigio_handler is called via the signal machinery in the bytecode interpreter. The signal system ensures that this function will be called either between two bytecode instructions, or during a blocking primitive. In either case, not in the middle of an Xlib call. */ value caml_gr_sigio_signal(value unit) { return Val_int(EVENT_SIGNAL); } value caml_gr_sigio_handler(void) { XEvent grevent; if (caml_gr_initialized && !caml_gr_ignore_sigio) { while (XCheckMaskEvent(caml_gr_display, -1 /*all events*/, &grevent)) { caml_gr_handle_event(&grevent); } } #ifdef USE_ALARM alarm(1); #endif return Val_unit; } /* Processing of graphic errors */ static value * graphic_failure_exn = NULL; void caml_gr_fail(char *fmt, char *arg) { char buffer[1024]; if (graphic_failure_exn == NULL) { graphic_failure_exn = caml_named_value("Graphics.Graphic_failure"); if (graphic_failure_exn == NULL) invalid_argument("Exception Graphics.Graphic_failure not initialized, must link graphics.cma"); } sprintf(buffer, fmt, arg); raise_with_string(*graphic_failure_exn, buffer); } void caml_gr_check_open(void) { if (!caml_gr_initialized) caml_gr_fail("graphic screen not opened", NULL); } static int caml_gr_error_handler(Display *display, XErrorEvent *error) { char errmsg[512]; XGetErrorText(error->display, error->error_code, errmsg, sizeof(errmsg)); caml_gr_fail("Xlib error: %s", errmsg); return 0; } static int caml_gr_ioerror_handler(Display *display) { caml_gr_fail("fatal I/O error", NULL); return 0; } mingw-ocaml/ocaml/otherlibs/graph/libgraph.h0000644000175000017500000000701112124403241020512 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include struct canvas { int w, h; /* Dimensions of the drawable */ Drawable win; /* The drawable itself */ GC gc; /* The associated graphics context */ }; extern Display * caml_gr_display; /* The display connection */ extern int caml_gr_screen; /* The screen number */ extern Colormap caml_gr_colormap; /* The color map */ extern struct canvas caml_gr_window; /* The graphics window */ extern struct canvas caml_gr_bstore; /* The pixmap used for backing store */ extern int caml_gr_white, caml_gr_black; /* Black and white pixels for X */ extern int caml_gr_background; /* Background color for X (used for CAML color -1) */ extern Bool caml_gr_display_modeflag; /* Display-mode flag */ extern Bool caml_gr_remember_modeflag; /* Remember-mode flag */ extern int caml_gr_x, caml_gr_y; /* Coordinates of the current point */ extern int caml_gr_color; /* Current *CAML* drawing color (can be -1) */ extern XFontStruct * caml_gr_font; /* Current font */ extern long caml_gr_selected_events; /* Events we are interested in */ extern Bool caml_gr_ignore_sigio; /* Whether to consume events on sigio */ extern Bool caml_gr_direct_rgb; extern int caml_gr_byte_order; extern int caml_gr_bitmap_unit; extern int caml_gr_bits_per_pixel; #define Wcvt(y) (caml_gr_window.h - 1 - (y)) #define Bcvt(y) (caml_gr_bstore.h - 1 - (y)) #define WtoB(y) ((y) + caml_gr_bstore.h - caml_gr_window.h) #define BtoW(y) ((y) + caml_gr_window.h - caml_gr_bstore.h) #define min(a,b) ((a) < (b) ? (a) : (b)) #define max(a,b) ((a) > (b) ? (a) : (b)) #define DEFAULT_SCREEN_WIDTH 600 #define DEFAULT_SCREEN_HEIGHT 450 #define BORDER_WIDTH 2 #define DEFAULT_WINDOW_NAME "OCaml graphics" #define DEFAULT_SELECTED_EVENTS \ (ExposureMask | KeyPressMask | StructureNotifyMask) #define DEFAULT_FONT "fixed" #define SIZE_QUEUE 256 /* To handle events asynchronously */ #ifdef HAS_ASYNC_IO #define USE_ASYNC_IO #define EVENT_SIGNAL SIGIO #else #ifdef HAS_SETITIMER #define USE_INTERVAL_TIMER #define EVENT_SIGNAL SIGALRM #else #define USE_ALARM #define EVENT_SIGNAL SIGALRM #endif #endif extern void caml_gr_fail(char *fmt, char *arg); extern void caml_gr_check_open(void); extern unsigned long caml_gr_pixel_rgb(int rgb); extern int caml_gr_rgb_pixel(long unsigned int pixel); extern void caml_gr_handle_event(XEvent *e); extern void caml_gr_init_color_cache(void); extern void caml_gr_init_direct_rgb_to_pixel(void); extern value caml_gr_id_of_window( Window w ); mingw-ocaml/ocaml/otherlibs/graph/graphics.mli0000644000175000017500000003524312124403241021064 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Machine-independent graphics primitives. *) exception Graphic_failure of string (** Raised by the functions below when they encounter an error. *) (** {6 Initializations} *) val open_graph : string -> unit (** Show the graphics window or switch the screen to graphic mode. The graphics window is cleared and the current point is set to (0, 0). The string argument is used to pass optional information on the desired graphics mode, the graphics window size, and so on. Its interpretation is implementation-dependent. If the empty string is given, a sensible default is selected. *) val close_graph : unit -> unit (** Delete the graphics window or switch the screen back to text mode. *) val set_window_title : string -> unit (** Set the title of the graphics window. *) val resize_window : int -> int -> unit (** Resize and erase the graphics window. *) external clear_graph : unit -> unit = "caml_gr_clear_graph" (** Erase the graphics window. *) external size_x : unit -> int = "caml_gr_size_x" (** See {!Graphics.size_y}. *) external size_y : unit -> int = "caml_gr_size_y" (** Return the size of the graphics window. Coordinates of the screen pixels range over [0 .. size_x()-1] and [0 .. size_y()-1]. Drawings outside of this rectangle are clipped, without causing an error. The origin (0,0) is at the lower left corner. *) (** {6 Colors} *) type color = int (** A color is specified by its R, G, B components. Each component is in the range [0..255]. The three components are packed in an [int]: [0xRRGGBB], where [RR] are the two hexadecimal digits for the red component, [GG] for the green component, [BB] for the blue component. *) val rgb : int -> int -> int -> color (** [rgb r g b] returns the integer encoding the color with red component [r], green component [g], and blue component [b]. [r], [g] and [b] are in the range [0..255]. *) external set_color : color -> unit = "caml_gr_set_color" (** Set the current drawing color. *) val background : color (** See {!Graphics.foreground}.*) val foreground : color (** Default background and foreground colors (usually, either black foreground on a white background or white foreground on a black background). {!Graphics.clear_graph} fills the screen with the [background] color. The initial drawing color is [foreground]. *) (** {7 Some predefined colors} *) val black : color val white : color val red : color val green : color val blue : color val yellow : color val cyan : color val magenta : color (** {6 Point and line drawing} *) external plot : int -> int -> unit = "caml_gr_plot" (** Plot the given point with the current drawing color. *) val plots : (int * int) array -> unit (** Plot the given points with the current drawing color. *) external point_color : int -> int -> color = "caml_gr_point_color" (** Return the color of the given point in the backing store (see "Double buffering" below). *) external moveto : int -> int -> unit = "caml_gr_moveto" (** Position the current point. *) val rmoveto : int -> int -> unit (** [rmoveto dx dy] translates the current point by the given vector. *) external current_x : unit -> int = "caml_gr_current_x" (** Return the abscissa of the current point. *) external current_y : unit -> int = "caml_gr_current_y" (** Return the ordinate of the current point. *) val current_point : unit -> int * int (** Return the position of the current point. *) external lineto : int -> int -> unit = "caml_gr_lineto" (** Draw a line with endpoints the current point and the given point, and move the current point to the given point. *) val rlineto : int -> int -> unit (** Draw a line with endpoints the current point and the current point translated of the given vector, and move the current point to this point. *) val curveto : int * int -> int * int -> int * int -> unit (** [curveto b c d] draws a cubic Bezier curve starting from the current point to point [d], with control points [b] and [c], and moves the current point to [d]. *) val draw_rect : int -> int -> int -> int -> unit (** [draw_rect x y w h] draws the rectangle with lower left corner at [x,y], width [w] and height [h]. The current point is unchanged. Raise [Invalid_argument] if [w] or [h] is negative. *) val draw_poly_line : (int * int) array -> unit (** [draw_poly_line points] draws the line that joins the points given by the array argument. The array contains the coordinates of the vertices of the polygonal line, which need not be closed. The current point is unchanged. *) val draw_poly : (int * int) array -> unit (** [draw_poly polygon] draws the given polygon. The array contains the coordinates of the vertices of the polygon. The current point is unchanged. *) val draw_segments : (int * int * int * int) array -> unit (** [draw_segments segments] draws the segments given in the array argument. Each segment is specified as a quadruple [(x0, y0, x1, y1)] where [(x0, y0)] and [(x1, y1)] are the coordinates of the end points of the segment. The current point is unchanged. *) val draw_arc : int -> int -> int -> int -> int -> int -> unit (** [draw_arc x y rx ry a1 a2] draws an elliptical arc with center [x,y], horizontal radius [rx], vertical radius [ry], from angle [a1] to angle [a2] (in degrees). The current point is unchanged. Raise [Invalid_argument] if [rx] or [ry] is negative. *) val draw_ellipse : int -> int -> int -> int -> unit (** [draw_ellipse x y rx ry] draws an ellipse with center [x,y], horizontal radius [rx] and vertical radius [ry]. The current point is unchanged. Raise [Invalid_argument] if [rx] or [ry] is negative. *) val draw_circle : int -> int -> int -> unit (** [draw_circle x y r] draws a circle with center [x,y] and radius [r]. The current point is unchanged. Raise [Invalid_argument] if [r] is negative. *) val set_line_width : int -> unit (** Set the width of points and lines drawn with the functions above. Under X Windows, [set_line_width 0] selects a width of 1 pixel and a faster, but less precise drawing algorithm than the one used when [set_line_width 1] is specified. Raise [Invalid_argument] if the argument is negative. *) (** {6 Text drawing} *) external draw_char : char -> unit = "caml_gr_draw_char" (** See {!Graphics.draw_string}.*) external draw_string : string -> unit = "caml_gr_draw_string" (** Draw a character or a character string with lower left corner at current position. After drawing, the current position is set to the lower right corner of the text drawn. *) external set_font : string -> unit = "caml_gr_set_font" (** Set the font used for drawing text. The interpretation of the argument to [set_font] is implementation-dependent. *) val set_text_size : int -> unit (** Set the character size used for drawing text. The interpretation of the argument to [set_text_size] is implementation-dependent. *) external text_size : string -> int * int = "caml_gr_text_size" (** Return the dimensions of the given text, if it were drawn with the current font and size. *) (** {6 Filling} *) val fill_rect : int -> int -> int -> int -> unit (** [fill_rect x y w h] fills the rectangle with lower left corner at [x,y], width [w] and height [h], with the current color. Raise [Invalid_argument] if [w] or [h] is negative. *) external fill_poly : (int * int) array -> unit = "caml_gr_fill_poly" (** Fill the given polygon with the current color. The array contains the coordinates of the vertices of the polygon. *) val fill_arc : int -> int -> int -> int -> int -> int -> unit (** Fill an elliptical pie slice with the current color. The parameters are the same as for {!Graphics.draw_arc}. *) val fill_ellipse : int -> int -> int -> int -> unit (** Fill an ellipse with the current color. The parameters are the same as for {!Graphics.draw_ellipse}. *) val fill_circle : int -> int -> int -> unit (** Fill a circle with the current color. The parameters are the same as for {!Graphics.draw_circle}. *) (** {6 Images} *) type image (** The abstract type for images, in internal representation. Externally, images are represented as matrices of colors. *) val transp : color (** In matrices of colors, this color represent a ``transparent'' point: when drawing the corresponding image, all pixels on the screen corresponding to a transparent pixel in the image will not be modified, while other points will be set to the color of the corresponding point in the image. This allows superimposing an image over an existing background. *) external make_image : color array array -> image = "caml_gr_make_image" (** Convert the given color matrix to an image. Each sub-array represents one horizontal line. All sub-arrays must have the same length; otherwise, exception [Graphic_failure] is raised. *) external dump_image : image -> color array array = "caml_gr_dump_image" (** Convert an image to a color matrix. *) external draw_image : image -> int -> int -> unit = "caml_gr_draw_image" (** Draw the given image with lower left corner at the given point. *) val get_image : int -> int -> int -> int -> image (** Capture the contents of a rectangle on the screen as an image. The parameters are the same as for {!Graphics.fill_rect}. *) external create_image : int -> int -> image = "caml_gr_create_image" (** [create_image w h] returns a new image [w] pixels wide and [h] pixels tall, to be used in conjunction with [blit_image]. The initial image contents are random, except that no point is transparent. *) external blit_image : image -> int -> int -> unit = "caml_gr_blit_image" (** [blit_image img x y] copies screen pixels into the image [img], modifying [img] in-place. The pixels copied are those inside the rectangle with lower left corner at [x,y], and width and height equal to those of the image. Pixels that were transparent in [img] are left unchanged. *) (** {6 Mouse and keyboard events} *) type status = { mouse_x : int; (** X coordinate of the mouse *) mouse_y : int; (** Y coordinate of the mouse *) button : bool; (** true if a mouse button is pressed *) keypressed : bool; (** true if a key has been pressed *) key : char; (** the character for the key pressed *) } (** To report events. *) type event = Button_down (** A mouse button is pressed *) | Button_up (** A mouse button is released *) | Key_pressed (** A key is pressed *) | Mouse_motion (** The mouse is moved *) | Poll (** Don't wait; return immediately *) (** To specify events to wait for. *) external wait_next_event : event list -> status = "caml_gr_wait_event" (** Wait until one of the events specified in the given event list occurs, and return the status of the mouse and keyboard at that time. If [Poll] is given in the event list, return immediately with the current status. If the mouse cursor is outside of the graphics window, the [mouse_x] and [mouse_y] fields of the event are outside the range [0..size_x()-1, 0..size_y()-1]. Keypresses are queued, and dequeued one by one when the [Key_pressed] event is specified. *) (** {6 Mouse and keyboard polling} *) val mouse_pos : unit -> int * int (** Return the position of the mouse cursor, relative to the graphics window. If the mouse cursor is outside of the graphics window, [mouse_pos()] returns a point outside of the range [0..size_x()-1, 0..size_y()-1]. *) val button_down : unit -> bool (** Return [true] if the mouse button is pressed, [false] otherwise. *) val read_key : unit -> char (** Wait for a key to be pressed, and return the corresponding character. Keypresses are queued. *) val key_pressed : unit -> bool (** Return [true] if a keypress is available; that is, if [read_key] would not block. *) (** {6 Sound} *) external sound : int -> int -> unit = "caml_gr_sound" (** [sound freq dur] plays a sound at frequency [freq] (in hertz) for a duration [dur] (in milliseconds). *) (** {6 Double buffering} *) val auto_synchronize : bool -> unit (** By default, drawing takes place both on the window displayed on screen, and in a memory area (the ``backing store''). The backing store image is used to re-paint the on-screen window when necessary. To avoid flicker during animations, it is possible to turn off on-screen drawing, perform a number of drawing operations in the backing store only, then refresh the on-screen window explicitly. [auto_synchronize false] turns on-screen drawing off. All subsequent drawing commands are performed on the backing store only. [auto_synchronize true] refreshes the on-screen window from the backing store (as per [synchronize]), then turns on-screen drawing back on. All subsequent drawing commands are performed both on screen and in the backing store. The default drawing mode corresponds to [auto_synchronize true]. *) external synchronize : unit -> unit = "caml_gr_synchronize" (** Synchronize the backing store and the on-screen window, by copying the contents of the backing store onto the graphics window. *) external display_mode : bool -> unit = "caml_gr_display_mode" (** Set display mode on or off. When turned on, drawings are done in the graphics window; when turned off, drawings do not affect the graphics window. This occurs independently of drawing into the backing store (see the function {!Graphics.remember_mode} below). Default display mode is on. *) external remember_mode : bool -> unit = "caml_gr_remember_mode" (** Set remember mode on or off. When turned on, drawings are done in the backing store; when turned off, the backing store is unaffected by drawings. This occurs independently of drawing onto the graphics window (see the function {!Graphics.display_mode} above). Default remember mode is on. *) mingw-ocaml/ocaml/otherlibs/graph/subwindow.c0000644000175000017500000000317312124403241020743 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Jun Furuse, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2001 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "libgraph.h" value caml_gr_open_subwindow(value vx, value vy, value width, value height) { Window win; int h = Int_val(height); int w = Int_val(width); int x = Int_val(vx); int y = Int_val(vy); caml_gr_check_open(); win = XCreateSimpleWindow(caml_gr_display, caml_gr_window.win, x, Wcvt(y + h), w, h, 0, caml_gr_black, caml_gr_background); XMapWindow(caml_gr_display, win); XFlush(caml_gr_display); return (caml_gr_id_of_window (win)); } value caml_gr_close_subwindow(value wid) { Window win; caml_gr_check_open(); sscanf( String_val(wid), "%lu", (unsigned long *)(&win) ); XDestroyWindow(caml_gr_display, win); XFlush(caml_gr_display); return Val_unit; } mingw-ocaml/ocaml/otherlibs/graph/make_img.c0000644000175000017500000000651712124403241020500 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "libgraph.h" #include "image.h" #include value caml_gr_make_image(value m) { int width, height; value im; Bool has_transp; XImage * idata, * imask; char * bdata, * bmask; int i, j, rgb; value line; GC gc; caml_gr_check_open(); height = Wosize_val(m); if (height == 0) return caml_gr_new_image(0, 0); width = Wosize_val(Field(m, 0)); for (i = 1; i < height; i++) if (Wosize_val(Field(m, i)) != width) caml_gr_fail("make_image: lines of different lengths", NULL); /* Build an XImage for the data part of the image */ idata = XCreateImage(caml_gr_display, DefaultVisual(caml_gr_display, caml_gr_screen), XDefaultDepth(caml_gr_display, caml_gr_screen), ZPixmap, 0, NULL, width, height, BitmapPad(caml_gr_display), 0); bdata = (char *) stat_alloc(height * idata->bytes_per_line); idata->data = bdata; has_transp = False; for (i = 0; i < height; i++) { line = Field(m, i); for (j = 0; j < width; j++) { rgb = Int_val(Field(line, j)); if (rgb == Transparent) { has_transp = True; rgb = 0; } XPutPixel(idata, j, i, caml_gr_pixel_rgb(rgb)); } } /* If the matrix contains transparent points, build an XImage for the mask part of the image */ if (has_transp) { imask = XCreateImage(caml_gr_display, DefaultVisual(caml_gr_display, caml_gr_screen), 1, ZPixmap, 0, NULL, width, height, BitmapPad(caml_gr_display), 0); bmask = (char *) stat_alloc(height * imask->bytes_per_line); imask->data = bmask; for (i = 0; i < height; i++) { line = Field(m, i); for (j = 0; j < width; j++) { rgb = Int_val(Field(line, j)); XPutPixel(imask, j, i, rgb != Transparent); } } } else { imask = NULL; } /* Allocate the image and store the XImages into the Pixmaps */ im = caml_gr_new_image(width, height); gc = XCreateGC(caml_gr_display, Data_im(im), 0, NULL); XPutImage(caml_gr_display, Data_im(im), gc, idata, 0, 0, 0, 0, width, height); XDestroyImage(idata); XFreeGC(caml_gr_display, gc); if (has_transp) { Mask_im(im) = XCreatePixmap(caml_gr_display, caml_gr_window.win, width, height, 1); gc = XCreateGC(caml_gr_display, Mask_im(im), 0, NULL); XPutImage(caml_gr_display, Mask_im(im), gc, imask, 0, 0, 0, 0, width, height); XDestroyImage(imask); XFreeGC(caml_gr_display, gc); } XFlush(caml_gr_display); return im; } mingw-ocaml/ocaml/otherlibs/graph/graphics.ml0000644000175000017500000001763012124403241020713 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) exception Graphic_failure of string (* Initializations *) let _ = Callback.register_exception "Graphics.Graphic_failure" (Graphic_failure "") external raw_open_graph: string -> unit = "caml_gr_open_graph" external raw_close_graph: unit -> unit = "caml_gr_close_graph" external sigio_signal: unit -> int = "caml_gr_sigio_signal" external sigio_handler: int -> unit = "caml_gr_sigio_handler" let unix_open_graph arg = Sys.set_signal (sigio_signal()) (Sys.Signal_handle sigio_handler); raw_open_graph arg let unix_close_graph () = Sys.set_signal (sigio_signal()) Sys.Signal_ignore; raw_close_graph () let (open_graph, close_graph) = match Sys.os_type with | "Unix" | "Cygwin" -> (unix_open_graph, unix_close_graph) | "Win32" -> (raw_open_graph, raw_close_graph) | "MacOS" -> (raw_open_graph, raw_close_graph) | _ -> invalid_arg ("Graphics: unknown OS type: " ^ Sys.os_type) external set_window_title : string -> unit = "caml_gr_set_window_title" external resize_window : int -> int -> unit = "caml_gr_resize_window" external clear_graph : unit -> unit = "caml_gr_clear_graph" external size_x : unit -> int = "caml_gr_size_x" external size_y : unit -> int = "caml_gr_size_y" (* Double-buffering *) external display_mode : bool -> unit = "caml_gr_display_mode" external remember_mode : bool -> unit = "caml_gr_remember_mode" external synchronize : unit -> unit = "caml_gr_synchronize" let auto_synchronize = function | true -> display_mode true; remember_mode true; synchronize () | false -> display_mode false; remember_mode true ;; (* Colors *) type color = int let rgb r g b = (r lsl 16) + (g lsl 8) + b external set_color : color -> unit = "caml_gr_set_color" let black = 0x000000 and white = 0xFFFFFF and red = 0xFF0000 and green = 0x00FF00 and blue = 0x0000FF and yellow = 0xFFFF00 and cyan = 0x00FFFF and magenta = 0xFF00FF let background = white and foreground = black (* Drawing *) external plot : int -> int -> unit = "caml_gr_plot" let plots points = for i = 0 to Array.length points - 1 do let (x, y) = points.(i) in plot x y; done ;; external point_color : int -> int -> color = "caml_gr_point_color" external moveto : int -> int -> unit = "caml_gr_moveto" external current_x : unit -> int = "caml_gr_current_x" external current_y : unit -> int = "caml_gr_current_y" let current_point () = current_x (), current_y () external lineto : int -> int -> unit = "caml_gr_lineto" let rlineto x y = lineto (current_x () + x) (current_y () + y) let rmoveto x y = moveto (current_x () + x) (current_y () + y) external raw_draw_rect : int -> int -> int -> int -> unit = "caml_gr_draw_rect" let draw_rect x y w h = if w < 0 || h < 0 then raise (Invalid_argument "draw_rect") else raw_draw_rect x y w h ;; let draw_poly, draw_poly_line = let dodraw close_flag points = if Array.length points > 0 then begin let (savex, savey) = current_point () in moveto (fst points.(0)) (snd points.(0)); for i = 1 to Array.length points - 1 do let (x, y) = points.(i) in lineto x y; done; if close_flag then lineto (fst points.(0)) (snd points.(0)); moveto savex savey; end; in dodraw true, dodraw false ;; let draw_segments segs = let (savex, savey) = current_point () in for i = 0 to Array.length segs - 1 do let (x1, y1, x2, y2) = segs.(i) in moveto x1 y1; lineto x2 y2; done; moveto savex savey; ;; external raw_draw_arc : int -> int -> int -> int -> int -> int -> unit = "caml_gr_draw_arc" "caml_gr_draw_arc_nat" let draw_arc x y rx ry a1 a2 = if rx < 0 || ry < 0 then raise (Invalid_argument "draw_arc/ellipse/circle") else raw_draw_arc x y rx ry a1 a2 ;; let draw_ellipse x y rx ry = draw_arc x y rx ry 0 360 let draw_circle x y r = draw_arc x y r r 0 360 external raw_set_line_width : int -> unit = "caml_gr_set_line_width" let set_line_width w = if w < 0 then raise (Invalid_argument "set_line_width") else raw_set_line_width w ;; external raw_fill_rect : int -> int -> int -> int -> unit = "caml_gr_fill_rect" let fill_rect x y w h = if w < 0 || h < 0 then raise (Invalid_argument "fill_rect") else raw_fill_rect x y w h ;; external fill_poly : (int * int) array -> unit = "caml_gr_fill_poly" external raw_fill_arc : int -> int -> int -> int -> int -> int -> unit = "caml_gr_fill_arc" "caml_gr_fill_arc_nat" let fill_arc x y rx ry a1 a2 = if rx < 0 || ry < 0 then raise (Invalid_argument "fill_arc/ellipse/circle") else raw_fill_arc x y rx ry a1 a2 ;; let fill_ellipse x y rx ry = fill_arc x y rx ry 0 360 let fill_circle x y r = fill_arc x y r r 0 360 (* Text *) external draw_char : char -> unit = "caml_gr_draw_char" external draw_string : string -> unit = "caml_gr_draw_string" external set_font : string -> unit = "caml_gr_set_font" external set_text_size : int -> unit = "caml_gr_set_text_size" external text_size : string -> int * int = "caml_gr_text_size" (* Images *) type image let transp = -1 external make_image : color array array -> image = "caml_gr_make_image" external dump_image : image -> color array array = "caml_gr_dump_image" external draw_image : image -> int -> int -> unit = "caml_gr_draw_image" external create_image : int -> int -> image = "caml_gr_create_image" external blit_image : image -> int -> int -> unit = "caml_gr_blit_image" let get_image x y w h = let image = create_image w h in blit_image image x y; image (* Events *) type status = { mouse_x : int; mouse_y : int; button : bool; keypressed : bool; key : char } type event = Button_down | Button_up | Key_pressed | Mouse_motion | Poll external wait_next_event : event list -> status = "caml_gr_wait_event" let mouse_pos () = let e = wait_next_event [Poll] in (e.mouse_x, e.mouse_y) let button_down () = let e = wait_next_event [Poll] in e.button let read_key () = let e = wait_next_event [Key_pressed] in e.key let key_pressed () = let e = wait_next_event [Poll] in e.keypressed (*** Sound *) external sound : int -> int -> unit = "caml_gr_sound" (* Splines *) let add (x1, y1) (x2, y2) = (x1 +. x2, y1 +. y2) and sub (x1, y1) (x2, y2) = (x1 -. x2, y1 -. y2) and middle (x1, y1) (x2, y2) = ((x1 +. x2) /. 2.0, (y1 +. y2) /. 2.0) and area (x1, y1) (x2, y2) = abs_float (x1 *. y2 -. x2 *. y1) and norm (x1, y1) = sqrt (x1 *. x1 +. y1 *. y1);; let test a b c d = let v = sub d a in let s = norm v in area v (sub a b) <= s && area v (sub a c) <= s;; let spline a b c d = let rec spl accu a b c d = if test a b c d then d :: accu else let a' = middle a b and o = middle b c in let b' = middle a' o and d' = middle c d in let c' = middle o d' in let i = middle b' c' in spl (spl accu a a' b' i) i c' d' d in spl [a] a b c d;; let curveto b c (x, y as d) = let float_point (x, y) = (float_of_int x, float_of_int y) in let round f = int_of_float (f +. 0.5) in let int_point (x, y) = (round x, round y) in let points = spline (float_point (current_point ())) (float_point b) (float_point c) (float_point d) in draw_poly_line (Array.of_list (List.map int_point points)); moveto x y;; mingw-ocaml/ocaml/otherlibs/graph/sound.c0000644000175000017500000000277512124403241020061 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "libgraph.h" value caml_gr_sound(value vfreq, value vdur) { XKeyboardControl kbdcontrol; caml_gr_check_open(); kbdcontrol.bell_pitch = Int_val(vfreq); kbdcontrol.bell_duration = Int_val(vdur); XChangeKeyboardControl(caml_gr_display, KBBellPitch | KBBellDuration, &kbdcontrol); XBell(caml_gr_display, 0); kbdcontrol.bell_pitch = -1; /* restore default value */ kbdcontrol.bell_duration = -1; /* restore default value */ XChangeKeyboardControl(caml_gr_display, KBBellPitch | KBBellDuration, &kbdcontrol); XFlush(caml_gr_display); return Val_unit; } mingw-ocaml/ocaml/otherlibs/graph/libgraphics.clib0000644000175000017500000000015312124403241021673 0ustar tootstootsopen.o draw.o fill.o color.o text.o image.o make_img.o dump_img.o point_col.o sound.o events.o subwindow.o mingw-ocaml/ocaml/otherlibs/graph/fill.c0000644000175000017500000000606312124403241017651 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "libgraph.h" #include value caml_gr_fill_rect(value vx, value vy, value vw, value vh) { int x = Int_val(vx); int y = Int_val(vy); int w = Int_val(vw); int h = Int_val(vh); caml_gr_check_open(); if(caml_gr_remember_modeflag) XFillRectangle(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, x, Bcvt(y) - h, w + 1, h + 1); if(caml_gr_display_modeflag) { XFillRectangle(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, x, Wcvt(y) - h, w + 1, h + 1); XFlush(caml_gr_display); } return Val_unit; } value caml_gr_fill_poly(value array) { XPoint * points; int npoints, i; caml_gr_check_open(); npoints = Wosize_val(array); points = (XPoint *) stat_alloc(npoints * sizeof(XPoint)); for (i = 0; i < npoints; i++) { points[i].x = Int_val(Field(Field(array, i), 0)); points[i].y = Bcvt(Int_val(Field(Field(array, i), 1))); } if(caml_gr_remember_modeflag) XFillPolygon(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, points, npoints, Complex, CoordModeOrigin); if(caml_gr_display_modeflag) { for (i = 0; i < npoints; i++) points[i].y = BtoW(points[i].y); XFillPolygon(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, points, npoints, Complex, CoordModeOrigin); XFlush(caml_gr_display); } stat_free((char *) points); return Val_unit; } value caml_gr_fill_arc_nat(value vx, value vy, value vrx, value vry, value va1, value va2) { int x = Int_val(vx); int y = Int_val(vy); int rx = Int_val(vrx); int ry = Int_val(vry); int a1 = Int_val(va1); int a2 = Int_val(va2); caml_gr_check_open(); if(caml_gr_remember_modeflag) XFillArc(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, x - rx, Bcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64); if(caml_gr_display_modeflag) { XFillArc(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, x - rx, Wcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64); XFlush(caml_gr_display); } return Val_unit; } value caml_gr_fill_arc(value *argv, int argc) { return caml_gr_fill_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } mingw-ocaml/ocaml/otherlibs/graph/dump_img.c0000644000175000017500000000370312124403241020522 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "libgraph.h" #include "image.h" #include #include value caml_gr_dump_image(value image) { int width, height, i, j; XImage * idata, * imask; value m = Val_unit; Begin_roots2(image, m); caml_gr_check_open(); width = Width_im(image); height = Height_im(image); m = alloc(height, 0); for (i = 0; i < height; i++) { value v = alloc(width, 0); modify(&Field(m, i), v); } idata = XGetImage(caml_gr_display, Data_im(image), 0, 0, width, height, (-1), ZPixmap); for (i = 0; i < height; i++) for (j = 0; j < width; j++) Field(Field(m, i), j) = Val_int(caml_gr_rgb_pixel(XGetPixel(idata, j, i))); XDestroyImage(idata); if (Mask_im(image) != None) { imask = XGetImage(caml_gr_display, Mask_im(image), 0, 0, width, height, 1, ZPixmap); for (i = 0; i < height; i++) for (j = 0; j < width; j++) if (XGetPixel(imask, j, i) == 0) Field(Field(m, i), j) = Val_int(Transparent); XDestroyImage(imask); } End_roots(); return m; } mingw-ocaml/ocaml/otherlibs/graph/graphics.mllib0000644000175000017500000000002512124403241021370 0ustar tootstootsGraphics GraphicsX11 mingw-ocaml/ocaml/otherlibs/graph/draw.c0000644000175000017500000000733512124403241017663 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "libgraph.h" #include value caml_gr_plot(value vx, value vy) { int x = Int_val(vx); int y = Int_val(vy); caml_gr_check_open(); if(caml_gr_remember_modeflag) XDrawPoint(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, x, Bcvt(y)); if(caml_gr_display_modeflag) { XDrawPoint(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, x, Wcvt(y)); XFlush(caml_gr_display); } return Val_unit; } value caml_gr_moveto(value vx, value vy) { caml_gr_x = Int_val(vx); caml_gr_y = Int_val(vy); return Val_unit; } value caml_gr_current_x(void) { return Val_int(caml_gr_x); } value caml_gr_current_y(void) { return Val_int(caml_gr_y); } value caml_gr_lineto(value vx, value vy) { int x = Int_val(vx); int y = Int_val(vy); caml_gr_check_open(); if(caml_gr_remember_modeflag) XDrawLine(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, caml_gr_x, Bcvt(caml_gr_y), x, Bcvt(y)); if(caml_gr_display_modeflag) { XDrawLine(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, caml_gr_x, Wcvt(caml_gr_y), x, Wcvt(y)); XFlush(caml_gr_display); } caml_gr_x = x; caml_gr_y = y; return Val_unit; } value caml_gr_draw_rect(value vx, value vy, value vw, value vh) { int x = Int_val(vx); int y = Int_val(vy); int w = Int_val(vw); int h = Int_val(vh); caml_gr_check_open(); if(caml_gr_remember_modeflag) XDrawRectangle(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, x, Bcvt(y) - h, w, h); if(caml_gr_display_modeflag) { XDrawRectangle(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, x, Wcvt(y) - h, w, h); XFlush(caml_gr_display); } return Val_unit; } value caml_gr_draw_arc_nat(value vx, value vy, value vrx, value vry, value va1, value va2) { int x = Int_val(vx); int y = Int_val(vy); int rx = Int_val(vrx); int ry = Int_val(vry); int a1 = Int_val(va1); int a2 = Int_val(va2); caml_gr_check_open(); if(caml_gr_remember_modeflag) XDrawArc(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, x - rx, Bcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64); if(caml_gr_display_modeflag) { XDrawArc(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, x - rx, Wcvt(y) - ry, rx * 2, ry * 2, a1 * 64, (a2 - a1) * 64); XFlush(caml_gr_display); } return Val_unit; } value caml_gr_draw_arc(value *argv, int argc) { return caml_gr_draw_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } value caml_gr_set_line_width(value vwidth) { int width = Int_val(vwidth); caml_gr_check_open(); XSetLineAttributes(caml_gr_display, caml_gr_window.gc, width, LineSolid, CapRound, JoinRound); XSetLineAttributes(caml_gr_display, caml_gr_bstore.gc, width, LineSolid, CapRound, JoinRound); return Val_unit; } mingw-ocaml/ocaml/otherlibs/graph/.depend0000644000175000017500000000712512124403241020017 0ustar tootstootscolor.o: color.c libgraph.h \ \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h \ draw.o: draw.c libgraph.h \ \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h dump_img.o: dump_img.c libgraph.h \ \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h image.h \ ../../byterun/alloc.h ../../byterun/mlvalues.h ../../byterun/memory.h \ ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h events.o: events.c libgraph.h \ \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/signals.h fill.o: fill.c libgraph.h \ \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h image.o: image.c libgraph.h \ \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h image.h \ ../../byterun/alloc.h ../../byterun/mlvalues.h ../../byterun/custom.h make_img.o: make_img.c libgraph.h \ \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h image.h \ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/mlvalues.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h open.o: open.c libgraph.h \ \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/callback.h ../../byterun/fail.h \ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h point_col.o: point_col.c libgraph.h \ \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h sound.o: sound.c libgraph.h \ \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h subwindow.o: subwindow.c libgraph.h \ \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h text.o: text.c libgraph.h \ \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h graphics.cmi : graphicsX11.cmi : graphics.cmo : graphics.cmi graphics.cmx : graphics.cmi graphicsX11.cmo : graphics.cmi graphicsX11.cmi graphicsX11.cmx : graphics.cmx graphicsX11.cmi mingw-ocaml/ocaml/otherlibs/graph/color.c0000644000175000017500000001553112124403241020041 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "libgraph.h" #include /* Cache to speed up the translation rgb -> pixel value. */ struct color_cache_entry { int rgb; /* RGB value with format 0xRRGGBB */ unsigned long pixel; /* Pixel value */ }; #define Color_cache_size 512 static struct color_cache_entry color_cache[Color_cache_size]; #define Empty (-1) #define Hash_rgb(r,g,b) \ ((((r) & 0xE0) << 1) + (((g) & 0xE0) >> 2) + (((b) & 0xE0) >> 5)) #define Color_cache_slack 16 static int num_overflows = 0; /* rgb -> pixel conversion *without* display connection */ Bool caml_gr_direct_rgb = False; int caml_gr_red_l, caml_gr_red_r; int caml_gr_green_l, caml_gr_green_r; int caml_gr_blue_l, caml_gr_blue_r; unsigned long caml_gr_red_mask, caml_gr_green_mask, caml_gr_blue_mask; /* rgb -> pixel table */ unsigned long caml_gr_red_vals[256]; unsigned long caml_gr_green_vals[256]; unsigned long caml_gr_blue_vals[256]; void caml_gr_get_shifts( unsigned long mask, int *lsl, int *lsr ) { int l = 0; int r = 0; int bit = 1; if ( mask == 0 ){ *lsl = -1; *lsr = -1; return; } for( l = 0; l < 32; l++ ){ if( bit & mask ){ break; } bit = bit << 1; } for( r = l; r < 32; r++ ){ if( ! (bit & mask) ){ break; } bit = bit << 1; } /* fix r */ if ( r == 32 ) { r = 31; } *lsl = l; *lsr = 16 - (r - l); } void caml_gr_init_direct_rgb_to_pixel(void) { Visual *visual; int i; visual = DefaultVisual(caml_gr_display,caml_gr_screen); if ( visual->class == TrueColor || visual->class == DirectColor ){ caml_gr_red_mask = visual->red_mask; caml_gr_green_mask = visual->green_mask; caml_gr_blue_mask = visual->blue_mask; #ifdef QUICKCOLORDEBUG fprintf(stderr, "visual %lx %lx %lx\n", caml_gr_red_mask, caml_gr_green_mask, caml_gr_blue_mask); #endif caml_gr_get_shifts(caml_gr_red_mask, &caml_gr_red_l, &caml_gr_red_r); #ifdef QUICKCOLORDEBUG fprintf(stderr, "red %d %d\n", caml_gr_red_l, caml_gr_red_r); #endif for(i=0; i<256; i++){ caml_gr_red_vals[i] = (((i << 8) + i) >> caml_gr_red_r) << caml_gr_red_l; } caml_gr_get_shifts(caml_gr_green_mask, &caml_gr_green_l, &caml_gr_green_r); #ifdef QUICKCOLORDEBUG fprintf(stderr, "green %d %d\n", caml_gr_green_l, caml_gr_green_r); #endif for(i=0; i<256; i++){ caml_gr_green_vals[i] = (((i << 8) + i) >> caml_gr_green_r) << caml_gr_green_l; } caml_gr_get_shifts(caml_gr_blue_mask, &caml_gr_blue_l, &caml_gr_blue_r); #ifdef QUICKCOLORDEBUG fprintf(stderr, "blue %d %d\n", caml_gr_blue_l, caml_gr_blue_r); #endif for(i=0; i<256; i++){ caml_gr_blue_vals[i] = (((i << 8) + i) >> caml_gr_blue_r) << caml_gr_blue_l; } if( caml_gr_red_l < 0 || caml_gr_red_r < 0 || caml_gr_green_l < 0 || caml_gr_green_r < 0 || caml_gr_blue_l < 0 || caml_gr_blue_r < 0 ){ #ifdef QUICKCOLORDEBUG fprintf(stderr, "Damn, boost failed\n"); #endif caml_gr_direct_rgb = False; } else { #ifdef QUICKCOLORDEBUG fprintf(stderr, "Boost ok\n"); #endif caml_gr_direct_rgb = True; } } else { /* we cannot use direct_rgb_to_pixel */ #ifdef QUICKCOLORDEBUG fprintf(stderr, "No boost!\n"); #endif caml_gr_direct_rgb = False; } } void caml_gr_init_color_cache(void) { int i; for (i = 0; i < Color_cache_size; i++) color_cache[i].rgb = Empty; i = Hash_rgb(0, 0, 0); color_cache[i].rgb = 0; color_cache[i].pixel = caml_gr_black; i = Hash_rgb(0xFF, 0xFF, 0xFF); color_cache[i].rgb = 0xFFFFFF; color_cache[i].pixel = caml_gr_white; } unsigned long caml_gr_pixel_rgb(int rgb) { unsigned int r, g, b; int h, i; XColor color; r = (rgb >> 16) & 0xFF; g = (rgb >> 8) & 0xFF; b = rgb & 0xFF; if (caml_gr_direct_rgb){ return caml_gr_red_vals[r] | caml_gr_green_vals[g] | caml_gr_blue_vals[b]; } h = Hash_rgb(r, g, b); i = h; while(1) { if (color_cache[i].rgb == Empty) break; if (color_cache[i].rgb == rgb) return color_cache[i].pixel; i = (i + 1) & (Color_cache_size - 1); if (i == h) { /* Cache is full. Instead of inserting at slot h, which causes thrashing if many colors hash to the same value, insert at h + n where n is pseudo-random and smaller than Color_cache_slack */ int slack = num_overflows++ & (Color_cache_slack - 1); i = (i + slack) & (Color_cache_size - 1); break; } } color.red = r * 0x101; color.green = g * 0x101; color.blue = b * 0x101; XAllocColor(caml_gr_display, caml_gr_colormap, &color); color_cache[i].rgb = rgb; color_cache[i].pixel = color.pixel; return color.pixel; } int caml_gr_rgb_pixel(long unsigned int pixel) { register int r,g,b; XColor color; int i; if (caml_gr_direct_rgb) { r = (((pixel & caml_gr_red_mask) >> caml_gr_red_l) << 8) >> (16 - caml_gr_red_r); g = (((pixel & caml_gr_green_mask) >> caml_gr_green_l) << 8) >> (16 - caml_gr_green_r); b = (((pixel & caml_gr_blue_mask) >> caml_gr_blue_l) << 8) >> (16 - caml_gr_blue_r); return (r << 16) + (g << 8) + b; } if (pixel == caml_gr_black) return 0; if (pixel == caml_gr_white) return 0xFFFFFF; /* Probably faster to do a linear search than to query the X server. */ for (i = 0; i < Color_cache_size; i++) { if (color_cache[i].rgb != Empty && color_cache[i].pixel == pixel) return color_cache[i].rgb; } color.pixel = pixel; XQueryColor(caml_gr_display, caml_gr_colormap, &color); return ((color.red >> 8) << 16) + ((color.green >> 8) << 8) + (color.blue >> 8); } value caml_gr_set_color(value vrgb) { int xcolor; caml_gr_check_open(); caml_gr_color = Int_val(vrgb); if (caml_gr_color >= 0 ){ xcolor = caml_gr_pixel_rgb(Int_val(vrgb)); XSetForeground(caml_gr_display, caml_gr_window.gc, xcolor); XSetForeground(caml_gr_display, caml_gr_bstore.gc, xcolor); } else { XSetForeground(caml_gr_display, caml_gr_window.gc, caml_gr_background); XSetForeground(caml_gr_display, caml_gr_bstore.gc, caml_gr_background); } return Val_unit; } mingw-ocaml/ocaml/otherlibs/graph/image.h0000644000175000017500000000264012124403241020007 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ struct grimage { int width, height; /* Dimensions of the image */ Pixmap data; /* Pixels */ Pixmap mask; /* Mask for transparent points, or None */ }; #define Width_im(i) (((struct grimage *)Data_custom_val(i))->width) #define Height_im(i) (((struct grimage *)Data_custom_val(i))->height) #define Data_im(i) (((struct grimage *)Data_custom_val(i))->data) #define Mask_im(i) (((struct grimage *)Data_custom_val(i))->mask) #define Transparent (-1) value caml_gr_new_image(int w, int h); mingw-ocaml/ocaml/otherlibs/systhreads/0000755000175000017500000000000012124403241017642 5ustar tootstootsmingw-ocaml/ocaml/otherlibs/systhreads/libthreads.clib0000644000175000017500000000001512124403241022612 0ustar tootstootsst_stubs_b.o mingw-ocaml/ocaml/otherlibs/systhreads/.ignore0000644000175000017500000000001212124403241021117 0ustar tootstootsthread.ml mingw-ocaml/ocaml/otherlibs/systhreads/condition.ml0000644000175000017500000000215212124403241022162 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1995 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) type t external create: unit -> t = "caml_condition_new" external wait: t -> Mutex.t -> unit = "caml_condition_wait" external signal: t -> unit = "caml_condition_signal" external broadcast: t -> unit = "caml_condition_broadcast" mingw-ocaml/ocaml/otherlibs/systhreads/threads.h0000644000175000017500000000561012124403241021447 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1995 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #ifndef CAML_THREADS_H #define CAML_THREADS_H CAMLextern void caml_enter_blocking_section (void); CAMLextern void caml_leave_blocking_section (void); #define caml_acquire_runtime_system caml_leave_blocking_section #define caml_release_runtime_system caml_enter_blocking_section /* Manage the master lock around the OCaml run-time system. Only one thread at a time can execute OCaml compiled code or OCaml run-time system functions. When OCaml calls a C function, the current thread holds the master lock. The C function can release it by calling [caml_release_runtime_system]. Then, another thread can execute OCaml code. However, the calling thread must not access any OCaml data, nor call any runtime system function, nor call back into OCaml. Before returning to its OCaml caller, or accessing OCaml data, or call runtime system functions, the current thread must re-acquire the master lock by calling [caml_acquire_runtime_system]. Symmetrically, if a C function (not called from OCaml) wishes to call back into OCaml code, it should invoke [caml_acquire_runtime_system] first, then do the callback, then invoke [caml_release_runtime_system]. For historical reasons, alternate names can be used: [caml_enter_blocking_section] instead of [caml_release_runtime_system] [caml_leave_blocking_section] instead of [caml_acquire_runtime_system] Intuition: a ``blocking section'' is a piece of C code that does not use the runtime system (typically, a blocking I/O operation). */ CAMLextern int caml_c_thread_register(void); CAMLextern int caml_c_thread_unregister(void); /* If a thread is created by C code (instead of by OCaml itself), it must be registered with the OCaml runtime system before being able to call back into OCaml code or use other runtime system functions. Just call [caml_c_thread_register] once. Before the thread finishes, it must call [caml_c_thread_unregister]. Both functions return 1 on success, 0 on error. */ #endif /* CAML_THREADS_H */ mingw-ocaml/ocaml/otherlibs/systhreads/mutex.mli0000644000175000017500000000365212124403241021515 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Locks for mutual exclusion. Mutexes (mutual-exclusion locks) are used to implement critical sections and protect shared mutable data structures against concurrent accesses. The typical use is (if [m] is the mutex associated with the data structure [D]): {[ Mutex.lock m; (* Critical section that operates over D *); Mutex.unlock m ]} *) type t (** The type of mutexes. *) val create : unit -> t (** Return a new mutex. *) val lock : t -> unit (** Lock the given mutex. Only one thread can have the mutex locked at any time. A thread that attempts to lock a mutex already locked by another thread will suspend until the other thread unlocks the mutex. *) val try_lock : t -> bool (** Same as {!Mutex.lock}, but does not suspend the calling thread if the mutex is already locked: just return [false] immediately in that case. If the mutex is unlocked, lock it and return [true]. *) val unlock : t -> unit (** Unlock the given mutex. Other threads suspended trying to lock the mutex will restart. *) mingw-ocaml/ocaml/otherlibs/systhreads/event.mli0000644000175000017500000000676112124403241021500 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** First-class synchronous communication. This module implements synchronous inter-thread communications over channels. As in John Reppy's Concurrent ML system, the communication events are first-class values: they can be built and combined independently before being offered for communication. *) type 'a channel (** The type of communication channels carrying values of type ['a]. *) val new_channel : unit -> 'a channel (** Return a new channel. *) type +'a event (** The type of communication events returning a result of type ['a]. *) (** [send ch v] returns the event consisting in sending the value [v] over the channel [ch]. The result value of this event is [()]. *) val send : 'a channel -> 'a -> unit event (** [receive ch] returns the event consisting in receiving a value from the channel [ch]. The result value of this event is the value received. *) val receive : 'a channel -> 'a event val always : 'a -> 'a event (** [always v] returns an event that is always ready for synchronization. The result value of this event is [v]. *) val choose : 'a event list -> 'a event (** [choose evl] returns the event that is the alternative of all the events in the list [evl]. *) val wrap : 'a event -> ('a -> 'b) -> 'b event (** [wrap ev fn] returns the event that performs the same communications as [ev], then applies the post-processing function [fn] on the return value. *) val wrap_abort : 'a event -> (unit -> unit) -> 'a event (** [wrap_abort ev fn] returns the event that performs the same communications as [ev], but if it is not selected the function [fn] is called after the synchronization. *) val guard : (unit -> 'a event) -> 'a event (** [guard fn] returns the event that, when synchronized, computes [fn()] and behaves as the resulting event. This allows to compute events with side-effects at the time of the synchronization operation. *) val sync : 'a event -> 'a (** ``Synchronize'' on an event: offer all the communication possibilities specified in the event to the outside world, and block until one of the communications succeed. The result value of that communication is returned. *) val select : 'a event list -> 'a (** ``Synchronize'' on an alternative of events. [select evl] is shorthand for [sync(choose evl)]. *) val poll : 'a event -> 'a option (** Non-blocking version of {!Event.sync}: offer all the communication possibilities specified in the event to the outside world, and if one can take place immediately, perform it and return [Some r] where [r] is the result value of that communication. Otherwise, return [None] without blocking. *) mingw-ocaml/ocaml/otherlibs/systhreads/st_stubs.c0000644000175000017500000006561312124403241021667 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 1995 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ #include "alloc.h" #include "backtrace.h" #include "callback.h" #include "custom.h" #include "fail.h" #include "io.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" #include "printexc.h" #include "roots.h" #include "signals.h" #ifdef NATIVE_CODE #include "stack.h" #else #include "stacks.h" #endif #include "sys.h" #include "threads.h" /* Initial size of bytecode stack when a thread is created (4 Ko) */ #define Thread_stack_size (Stack_size / 4) /* Max computation time before rescheduling, in milliseconds */ #define Thread_timeout 50 /* OS-specific code */ #ifdef _WIN32 #include "st_win32.h" #else #include "st_posix.h" #endif /* The ML value describing a thread (heap-allocated) */ struct caml_thread_descr { value ident; /* Unique integer ID */ value start_closure; /* The closure to start this thread */ value terminated; /* Triggered event for thread termination */ }; #define Ident(v) (((struct caml_thread_descr *)(v))->ident) #define Start_closure(v) (((struct caml_thread_descr *)(v))->start_closure) #define Terminated(v) (((struct caml_thread_descr *)(v))->terminated) /* The infos on threads (allocated via malloc()) */ struct caml_thread_struct { value descr; /* The heap-allocated descriptor (root) */ struct caml_thread_struct * next; /* Double linking of running threads */ struct caml_thread_struct * prev; #ifdef NATIVE_CODE char * top_of_stack; /* Top of stack for this thread (approx.) */ char * bottom_of_stack; /* Saved value of caml_bottom_of_stack */ uintnat last_retaddr; /* Saved value of caml_last_return_address */ value * gc_regs; /* Saved value of caml_gc_regs */ char * exception_pointer; /* Saved value of caml_exception_pointer */ struct caml__roots_block * local_roots; /* Saved value of local_roots */ struct longjmp_buffer * exit_buf; /* For thread exit */ #else value * stack_low; /* The execution stack for this thread */ value * stack_high; value * stack_threshold; value * sp; /* Saved value of extern_sp for this thread */ value * trapsp; /* Saved value of trapsp for this thread */ struct caml__roots_block * local_roots; /* Saved value of local_roots */ struct longjmp_buffer * external_raise; /* Saved external_raise */ #endif int backtrace_pos; /* Saved backtrace_pos */ code_t * backtrace_buffer; /* Saved backtrace_buffer */ value backtrace_last_exn; /* Saved backtrace_last_exn (root) */ }; typedef struct caml_thread_struct * caml_thread_t; /* The "head" of the circular list of thread descriptors */ static caml_thread_t all_threads = NULL; /* The descriptor for the currently executing thread */ static caml_thread_t curr_thread = NULL; /* The master lock protecting the OCaml runtime system */ static st_masterlock caml_master_lock; /* Whether the ``tick'' thread is already running */ static int caml_tick_thread_running = 0; /* The thread identifier of the ``tick'' thread */ static st_thread_id caml_tick_thread_id; /* The key used for storing the thread descriptor in the specific data of the corresponding system thread. */ static st_tlskey thread_descriptor_key; /* The key used for unlocking I/O channels on exceptions */ static st_tlskey last_channel_locked_key; /* Identifier for next thread creation */ static intnat thread_next_ident = 0; /* Forward declarations */ static value caml_threadstatus_new (void); static void caml_threadstatus_terminate (value); static st_retcode caml_threadstatus_wait (value); /* Imports from the native-code runtime system */ #ifdef NATIVE_CODE extern struct longjmp_buffer caml_termination_jmpbuf; extern void (*caml_termination_hook)(void); #endif /* Hook for scanning the stacks of the other threads */ static void (*prev_scan_roots_hook) (scanning_action); static void caml_thread_scan_roots(scanning_action action) { caml_thread_t th; th = curr_thread; do { (*action)(th->descr, &th->descr); (*action)(th->backtrace_last_exn, &th->backtrace_last_exn); /* Don't rescan the stack of the current thread, it was done already */ if (th != curr_thread) { #ifdef NATIVE_CODE if (th->bottom_of_stack != NULL) do_local_roots(action, th->bottom_of_stack, th->last_retaddr, th->gc_regs, th->local_roots); #else do_local_roots(action, th->sp, th->stack_high, th->local_roots); #endif } th = th->next; } while (th != curr_thread); /* Hook */ if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action); } /* Hooks for enter_blocking_section and leave_blocking_section */ static void caml_thread_enter_blocking_section(void) { /* Save the stack-related global variables in the thread descriptor of the current thread */ #ifdef NATIVE_CODE curr_thread->bottom_of_stack = caml_bottom_of_stack; curr_thread->last_retaddr = caml_last_return_address; curr_thread->gc_regs = caml_gc_regs; curr_thread->exception_pointer = caml_exception_pointer; curr_thread->local_roots = local_roots; #else curr_thread->stack_low = stack_low; curr_thread->stack_high = stack_high; curr_thread->stack_threshold = stack_threshold; curr_thread->sp = extern_sp; curr_thread->trapsp = trapsp; curr_thread->local_roots = local_roots; curr_thread->external_raise = external_raise; #endif curr_thread->backtrace_pos = backtrace_pos; curr_thread->backtrace_buffer = backtrace_buffer; curr_thread->backtrace_last_exn = backtrace_last_exn; /* Tell other threads that the runtime is free */ st_masterlock_release(&caml_master_lock); } static void caml_thread_leave_blocking_section(void) { /* Wait until the runtime is free */ st_masterlock_acquire(&caml_master_lock); /* Update curr_thread to point to the thread descriptor corresponding to the thread currently executing */ curr_thread = st_tls_get(thread_descriptor_key); /* Restore the stack-related global variables */ #ifdef NATIVE_CODE caml_bottom_of_stack= curr_thread->bottom_of_stack; caml_last_return_address = curr_thread->last_retaddr; caml_gc_regs = curr_thread->gc_regs; caml_exception_pointer = curr_thread->exception_pointer; local_roots = curr_thread->local_roots; #else stack_low = curr_thread->stack_low; stack_high = curr_thread->stack_high; stack_threshold = curr_thread->stack_threshold; extern_sp = curr_thread->sp; trapsp = curr_thread->trapsp; local_roots = curr_thread->local_roots; external_raise = curr_thread->external_raise; #endif backtrace_pos = curr_thread->backtrace_pos; backtrace_buffer = curr_thread->backtrace_buffer; backtrace_last_exn = curr_thread->backtrace_last_exn; } static int caml_thread_try_leave_blocking_section(void) { /* Disable immediate processing of signals (PR#3659). try_leave_blocking_section always fails, forcing the signal to be recorded and processed at the next leave_blocking_section or polling. */ return 0; } /* Hooks for I/O locking */ static void caml_io_mutex_free(struct channel *chan) { st_mutex mutex = chan->mutex; if (mutex != NULL) st_mutex_destroy(mutex); } static void caml_io_mutex_lock(struct channel *chan) { st_mutex mutex = chan->mutex; if (mutex == NULL) { st_mutex_create(&mutex); chan->mutex = mutex; } /* PR#4351: first try to acquire mutex without releasing the master lock */ if (st_mutex_trylock(mutex) == PREVIOUSLY_UNLOCKED) { st_tls_set(last_channel_locked_key, (void *) chan); return; } /* If unsuccessful, block on mutex */ enter_blocking_section(); st_mutex_lock(mutex); /* Problem: if a signal occurs at this point, and the signal handler raises an exception, we will not unlock the mutex. The alternative (doing the setspecific before locking the mutex is also incorrect, since we could then unlock a mutex that is unlocked or locked by someone else. */ st_tls_set(last_channel_locked_key, (void *) chan); leave_blocking_section(); } static void caml_io_mutex_unlock(struct channel *chan) { st_mutex_unlock(chan->mutex); st_tls_set(last_channel_locked_key, NULL); } static void caml_io_mutex_unlock_exn(void) { struct channel * chan = st_tls_get(last_channel_locked_key); if (chan != NULL) caml_io_mutex_unlock(chan); } /* Hook for estimating stack usage */ static uintnat (*prev_stack_usage_hook)(void); static uintnat caml_thread_stack_usage(void) { uintnat sz; caml_thread_t th; /* Don't add stack for current thread, this is done elsewhere */ for (sz = 0, th = curr_thread->next; th != curr_thread; th = th->next) { #ifdef NATIVE_CODE sz += (value *) th->top_of_stack - (value *) th->bottom_of_stack; #else sz += th->stack_high - th->sp; #endif } if (prev_stack_usage_hook != NULL) sz += prev_stack_usage_hook(); return sz; } /* Create and setup a new thread info block. This block has no associated thread descriptor and is not inserted in the list of threads. */ static caml_thread_t caml_thread_new_info(void) { caml_thread_t th; th = (caml_thread_t) malloc(sizeof(struct caml_thread_struct)); if (th == NULL) return NULL; th->descr = Val_unit; /* filled later */ #ifdef NATIVE_CODE th->bottom_of_stack = NULL; th->top_of_stack = NULL; th->last_retaddr = 1; th->exception_pointer = NULL; th->local_roots = NULL; th->exit_buf = NULL; #else /* Allocate the stacks */ th->stack_low = (value *) stat_alloc(Thread_stack_size); th->stack_high = th->stack_low + Thread_stack_size / sizeof(value); th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value); th->sp = th->stack_high; th->trapsp = th->stack_high; th->local_roots = NULL; th->external_raise = NULL; #endif th->backtrace_pos = 0; th->backtrace_buffer = NULL; th->backtrace_last_exn = Val_unit; return th; } /* Allocate a thread descriptor block. */ static value caml_thread_new_descriptor(value clos) { value mu = Val_unit; value descr; Begin_roots2 (clos, mu) /* Create and initialize the termination semaphore */ mu = caml_threadstatus_new(); /* Create a descriptor for the new thread */ descr = alloc_small(3, 0); Ident(descr) = Val_long(thread_next_ident); Start_closure(descr) = clos; Terminated(descr) = mu; thread_next_ident++; End_roots(); return descr; } /* Remove a thread info block from the list of threads. Free it and its stack resources. */ static void caml_thread_remove_info(caml_thread_t th) { if (th->next == th) all_threads = NULL; /* last OCaml thread exiting */ else if (all_threads == th) all_threads = th->next; /* PR#5295 */ th->next->prev = th->prev; th->prev->next = th->next; #ifndef NATIVE_CODE stat_free(th->stack_low); #endif if (th->backtrace_buffer != NULL) free(th->backtrace_buffer); stat_free(th); } /* Reinitialize the thread machinery after a fork() (PR#4577) */ static void caml_thread_reinitialize(void) { caml_thread_t thr, next; struct channel * chan; /* Remove all other threads (now nonexistent) from the doubly-linked list of threads */ thr = curr_thread->next; while (thr != curr_thread) { next = thr->next; stat_free(thr); thr = next; } curr_thread->next = curr_thread; curr_thread->prev = curr_thread; all_threads = curr_thread; /* Reinitialize the master lock machinery, just in case the fork happened while other threads were doing leave_blocking_section */ st_masterlock_init(&caml_master_lock); /* Tick thread is not currently running in child process, will be re-created at next Thread.create */ caml_tick_thread_running = 0; /* Destroy all IO mutexes; will be reinitialized on demand */ for (chan = caml_all_opened_channels; chan != NULL; chan = chan->next) { if (chan->mutex != NULL) { st_mutex_destroy(chan->mutex); chan->mutex = NULL; } } } /* Initialize the thread machinery */ CAMLprim value caml_thread_initialize(value unit) /* ML */ { /* Protect against repeated initialization (PR#1325) */ if (curr_thread != NULL) return Val_unit; /* OS-specific initialization */ st_initialize(); /* Initialize and acquire the master lock */ st_masterlock_init(&caml_master_lock); /* Initialize the keys */ st_tls_newkey(&thread_descriptor_key); st_tls_newkey(&last_channel_locked_key); /* Set up a thread info block for the current thread */ curr_thread = (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct)); curr_thread->descr = caml_thread_new_descriptor(Val_unit); curr_thread->next = curr_thread; curr_thread->prev = curr_thread; all_threads = curr_thread; curr_thread->backtrace_last_exn = Val_unit; #ifdef NATIVE_CODE curr_thread->exit_buf = &caml_termination_jmpbuf; #endif /* The stack-related fields will be filled in at the next enter_blocking_section */ /* Associate the thread descriptor with the thread */ st_tls_set(thread_descriptor_key, (void *) curr_thread); /* Set up the hooks */ prev_scan_roots_hook = scan_roots_hook; scan_roots_hook = caml_thread_scan_roots; enter_blocking_section_hook = caml_thread_enter_blocking_section; leave_blocking_section_hook = caml_thread_leave_blocking_section; try_leave_blocking_section_hook = caml_thread_try_leave_blocking_section; #ifdef NATIVE_CODE caml_termination_hook = st_thread_exit; #endif caml_channel_mutex_free = caml_io_mutex_free; caml_channel_mutex_lock = caml_io_mutex_lock; caml_channel_mutex_unlock = caml_io_mutex_unlock; caml_channel_mutex_unlock_exn = caml_io_mutex_unlock_exn; prev_stack_usage_hook = caml_stack_usage_hook; caml_stack_usage_hook = caml_thread_stack_usage; /* Set up fork() to reinitialize the thread machinery in the child (PR#4577) */ st_atfork(caml_thread_reinitialize); return Val_unit; } /* Cleanup the thread machinery on program exit or DLL unload. */ CAMLprim value caml_thread_cleanup(value unit) /* ML */ { if (caml_tick_thread_running) st_thread_kill(caml_tick_thread_id); return Val_unit; } /* Thread cleanup at termination */ static void caml_thread_stop(void) { #ifndef NATIVE_CODE /* PR#5188: update curr_thread->stack_low because the stack may have been reallocated since the last time we entered a blocking section */ curr_thread->stack_low = stack_low; #endif /* Signal that the thread has terminated */ caml_threadstatus_terminate(Terminated(curr_thread->descr)); /* Remove th from the doubly-linked list of threads and free its info block */ caml_thread_remove_info(curr_thread); /* OS-specific cleanups */ st_thread_cleanup(); /* Release the runtime system */ st_masterlock_release(&caml_master_lock); } /* Create a thread */ static ST_THREAD_FUNCTION caml_thread_start(void * arg) { caml_thread_t th = (caml_thread_t) arg; value clos; #ifdef NATIVE_CODE struct longjmp_buffer termination_buf; char tos; #endif /* Associate the thread descriptor with the thread */ st_tls_set(thread_descriptor_key, (void *) th); /* Acquire the global mutex */ leave_blocking_section(); #ifdef NATIVE_CODE /* Record top of stack (approximative) */ th->top_of_stack = &tos; /* Setup termination handler (for caml_thread_exit) */ if (sigsetjmp(termination_buf.buf, 0) == 0) { th->exit_buf = &termination_buf; #endif /* Callback the closure */ clos = Start_closure(th->descr); modify(&(Start_closure(th->descr)), Val_unit); callback_exn(clos, Val_unit); caml_thread_stop(); #ifdef NATIVE_CODE } #endif /* The thread now stops running */ return 0; } CAMLprim value caml_thread_new(value clos) /* ML */ { caml_thread_t th; st_retcode err; /* Create a thread info block */ th = caml_thread_new_info(); if (th == NULL) caml_raise_out_of_memory(); /* Equip it with a thread descriptor */ th->descr = caml_thread_new_descriptor(clos); /* Add thread info block to the list of threads */ th->next = curr_thread->next; th->prev = curr_thread; curr_thread->next->prev = th; curr_thread->next = th; /* Create the new thread */ err = st_thread_create(NULL, caml_thread_start, (void *) th); if (err != 0) { /* Creation failed, remove thread info block from list of threads */ caml_thread_remove_info(th); st_check_error(err, "Thread.create"); } /* Create the tick thread if not already done. Because of PR#4666, we start the tick thread late, only when we create the first additional thread in the current process*/ if (! caml_tick_thread_running) { err = st_thread_create(&caml_tick_thread_id, caml_thread_tick, NULL); st_check_error(err, "Thread.create"); caml_tick_thread_running = 1; } return th->descr; } /* Register a thread already created from C */ CAMLexport int caml_c_thread_register(void) { caml_thread_t th; st_retcode err; /* Already registered? */ if (st_tls_get(thread_descriptor_key) != NULL) return 0; /* Create a thread info block */ th = caml_thread_new_info(); if (th == NULL) return 0; #ifdef NATIVE_CODE th->top_of_stack = (char *) &err; #endif /* Take master lock to protect access to the chaining of threads */ st_masterlock_acquire(&caml_master_lock); /* Add thread info block to the list of threads */ if (all_threads == NULL) { th->next = th; th->prev = th; all_threads = th; } else { th->next = all_threads->next; th->prev = all_threads; all_threads->next->prev = th; all_threads->next = th; } /* Associate the thread descriptor with the thread */ st_tls_set(thread_descriptor_key, (void *) th); /* Release the master lock */ st_masterlock_release(&caml_master_lock); /* Now we can re-enter the run-time system and heap-allocate the descriptor */ leave_blocking_section(); th->descr = caml_thread_new_descriptor(Val_unit); /* no closure */ /* Create the tick thread if not already done. */ if (! caml_tick_thread_running) { err = st_thread_create(&caml_tick_thread_id, caml_thread_tick, NULL); if (err == 0) caml_tick_thread_running = 1; } /* Exit the run-time system */ enter_blocking_section(); return 1; } /* Unregister a thread that was created from C and registered with the function above */ CAMLexport int caml_c_thread_unregister(void) { caml_thread_t th = st_tls_get(thread_descriptor_key); /* Not registered? */ if (th == NULL) return 0; /* Wait until the runtime is available */ st_masterlock_acquire(&caml_master_lock); /* Forget the thread descriptor */ st_tls_set(thread_descriptor_key, NULL); /* Remove thread info block from list of threads, and free it */ caml_thread_remove_info(th); /* Release the runtime */ st_masterlock_release(&caml_master_lock); return 1; } /* Return the current thread */ CAMLprim value caml_thread_self(value unit) /* ML */ { if (curr_thread == NULL) invalid_argument("Thread.self: not initialized"); return curr_thread->descr; } /* Return the identifier of a thread */ CAMLprim value caml_thread_id(value th) /* ML */ { return Ident(th); } /* Print uncaught exception and backtrace */ CAMLprim value caml_thread_uncaught_exception(value exn) /* ML */ { char * msg = format_caml_exception(exn); fprintf(stderr, "Thread %d killed on uncaught exception %s\n", Int_val(Ident(curr_thread->descr)), msg); free(msg); if (caml_backtrace_active) print_exception_backtrace(); fflush(stderr); return Val_unit; } /* Terminate current thread */ CAMLprim value caml_thread_exit(value unit) /* ML */ { struct longjmp_buffer * exit_buf = NULL; if (curr_thread == NULL) invalid_argument("Thread.exit: not initialized"); /* In native code, we cannot call pthread_exit here because on some systems this raises a C++ exception, and ocamlopt-generated stack frames cannot be unwound. Instead, we longjmp to the thread creation point (in caml_thread_start) or to the point in caml_main where caml_termination_hook will be called. Note that threads created in C then registered do not have a creation point (exit_buf == NULL). */ #ifdef NATIVE_CODE exit_buf = curr_thread->exit_buf; #endif caml_thread_stop(); if (exit_buf != NULL) { /* Native-code and (main thread or thread created by OCaml) */ siglongjmp(exit_buf->buf, 1); } else { /* Bytecode, or thread created from C */ st_thread_exit(); } return Val_unit; /* not reached */ } /* Allow re-scheduling */ CAMLprim value caml_thread_yield(value unit) /* ML */ { if (st_masterlock_waiters(&caml_master_lock) == 0) return Val_unit; enter_blocking_section(); st_thread_yield(); leave_blocking_section(); return Val_unit; } /* Suspend the current thread until another thread terminates */ CAMLprim value caml_thread_join(value th) /* ML */ { st_retcode rc = caml_threadstatus_wait(Terminated(th)); st_check_error(rc, "Thread.join"); return Val_unit; } /* Mutex operations */ #define Mutex_val(v) (* ((st_mutex *) Data_custom_val(v))) #define Max_mutex_number 5000 static void caml_mutex_finalize(value wrapper) { st_mutex_destroy(Mutex_val(wrapper)); } static int caml_mutex_compare(value wrapper1, value wrapper2) { st_mutex mut1 = Mutex_val(wrapper1); st_mutex mut2 = Mutex_val(wrapper2); return mut1 == mut2 ? 0 : mut1 < mut2 ? -1 : 1; } static intnat caml_mutex_hash(value wrapper) { return (intnat) (Mutex_val(wrapper)); } static struct custom_operations caml_mutex_ops = { "_mutex", caml_mutex_finalize, caml_mutex_compare, caml_mutex_hash, custom_serialize_default, custom_deserialize_default }; CAMLprim value caml_mutex_new(value unit) /* ML */ { st_mutex mut = NULL; /* suppress warning */ value wrapper; st_check_error(st_mutex_create(&mut), "Mutex.create"); wrapper = alloc_custom(&caml_mutex_ops, sizeof(st_mutex *), 1, Max_mutex_number); Mutex_val(wrapper) = mut; return wrapper; } CAMLprim value caml_mutex_lock(value wrapper) /* ML */ { st_mutex mut = Mutex_val(wrapper); st_retcode retcode; /* PR#4351: first try to acquire mutex without releasing the master lock */ if (st_mutex_trylock(mut) == PREVIOUSLY_UNLOCKED) return Val_unit; /* If unsuccessful, block on mutex */ Begin_root(wrapper) /* prevent the deallocation of mutex */ enter_blocking_section(); retcode = st_mutex_lock(mut); leave_blocking_section(); End_roots(); st_check_error(retcode, "Mutex.lock"); return Val_unit; } CAMLprim value caml_mutex_unlock(value wrapper) /* ML */ { st_mutex mut = Mutex_val(wrapper); st_retcode retcode; /* PR#4351: no need to release and reacquire master lock */ retcode = st_mutex_unlock(mut); st_check_error(retcode, "Mutex.unlock"); return Val_unit; } CAMLprim value caml_mutex_try_lock(value wrapper) /* ML */ { st_mutex mut = Mutex_val(wrapper); st_retcode retcode; retcode = st_mutex_trylock(mut); if (retcode == ALREADY_LOCKED) return Val_false; st_check_error(retcode, "Mutex.try_lock"); return Val_true; } /* Conditions operations */ #define Condition_val(v) (* (st_condvar *) Data_custom_val(v)) #define Max_condition_number 5000 static void caml_condition_finalize(value wrapper) { st_condvar_destroy(Condition_val(wrapper)); } static int caml_condition_compare(value wrapper1, value wrapper2) { st_condvar cond1 = Condition_val(wrapper1); st_condvar cond2 = Condition_val(wrapper2); return cond1 == cond2 ? 0 : cond1 < cond2 ? -1 : 1; } static intnat caml_condition_hash(value wrapper) { return (intnat) (Condition_val(wrapper)); } static struct custom_operations caml_condition_ops = { "_condition", caml_condition_finalize, caml_condition_compare, caml_condition_hash, custom_serialize_default, custom_deserialize_default, custom_compare_ext_default }; CAMLprim value caml_condition_new(value unit) /* ML */ { st_condvar cond = NULL; /* suppress warning */ value wrapper; st_check_error(st_condvar_create(&cond), "Condition.create"); wrapper = alloc_custom(&caml_condition_ops, sizeof(st_condvar *), 1, Max_condition_number); Condition_val(wrapper) = cond; return wrapper; } CAMLprim value caml_condition_wait(value wcond, value wmut) /* ML */ { st_condvar cond = Condition_val(wcond); st_mutex mut = Mutex_val(wmut); st_retcode retcode; Begin_roots2(wcond, wmut) /* prevent deallocation of cond and mutex */ enter_blocking_section(); retcode = st_condvar_wait(cond, mut); leave_blocking_section(); End_roots(); st_check_error(retcode, "Condition.wait"); return Val_unit; } CAMLprim value caml_condition_signal(value wrapper) /* ML */ { st_check_error(st_condvar_signal(Condition_val(wrapper)), "Condition.signal"); return Val_unit; } CAMLprim value caml_condition_broadcast(value wrapper) /* ML */ { st_check_error(st_condvar_broadcast(Condition_val(wrapper)), "Condition.signal"); return Val_unit; } /* Thread status blocks */ #define Threadstatus_val(v) (* ((st_event *) Data_custom_val(v))) #define Max_threadstatus_number 500 static void caml_threadstatus_finalize(value wrapper) { st_event_destroy(Threadstatus_val(wrapper)); } static int caml_threadstatus_compare(value wrapper1, value wrapper2) { st_event ts1 = Threadstatus_val(wrapper1); st_event ts2 = Threadstatus_val(wrapper2); return ts1 == ts2 ? 0 : ts1 < ts2 ? -1 : 1; } static struct custom_operations caml_threadstatus_ops = { "_threadstatus", caml_threadstatus_finalize, caml_threadstatus_compare, custom_hash_default, custom_serialize_default, custom_deserialize_default, custom_compare_ext_default }; static value caml_threadstatus_new (void) { st_event ts = NULL; /* suppress warning */ value wrapper; st_check_error(st_event_create(&ts), "Thread.create"); wrapper = alloc_custom(&caml_threadstatus_ops, sizeof(st_event *), 1, Max_threadstatus_number); Threadstatus_val(wrapper) = ts; return wrapper; } static void caml_threadstatus_terminate (value wrapper) { st_event_trigger(Threadstatus_val(wrapper)); } static st_retcode caml_threadstatus_wait (value wrapper) { st_event ts = Threadstatus_val(wrapper); st_retcode retcode; Begin_roots1(wrapper) /* prevent deallocation of ts */ enter_blocking_section(); retcode = st_event_wait(ts); leave_blocking_section(); End_roots(); return retcode; } mingw-ocaml/ocaml/otherlibs/systhreads/threadUnix.mli0000644000175000017500000000651012124403241022462 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Thread-compatible system calls. @deprecated The functionality of this module has been merged back into the {!Unix} module. Threaded programs can now call the functions from module {!Unix} directly, and still get the correct behavior (block the calling thread, if required, but do not block all threads in the process). *) (** {6 Process handling} *) val execv : string -> string array -> unit val execve : string -> string array -> string array -> unit val execvp : string -> string array -> unit val wait : unit -> int * Unix.process_status val waitpid : Unix.wait_flag list -> int -> int * Unix.process_status val system : string -> Unix.process_status (** {6 Basic input/output} *) val read : Unix.file_descr -> string -> int -> int -> int val write : Unix.file_descr -> string -> int -> int -> int (** {6 Input/output with timeout} *) val timed_read : Unix.file_descr -> string -> int -> int -> float -> int (** See {!ThreadUnix.timed_write}. *) val timed_write : Unix.file_descr -> string -> int -> int -> float -> int (** Behave as {!ThreadUnix.read} and {!ThreadUnix.write}, except that [Unix_error(ETIMEDOUT,_,_)] is raised if no data is available for reading or ready for writing after [d] seconds. The delay [d] is given in the fifth argument, in seconds. *) (** {6 Polling} *) val select : Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list * Unix.file_descr list (** {6 Pipes and redirections} *) val pipe : unit -> Unix.file_descr * Unix.file_descr val open_process_in: string -> in_channel val open_process_out: string -> out_channel val open_process: string -> in_channel * out_channel (** {6 Time} *) val sleep : int -> unit (** {6 Sockets} *) val socket : Unix.socket_domain -> Unix.socket_type -> int -> Unix.file_descr val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr val connect : Unix.file_descr -> Unix.sockaddr -> unit val recv : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int val recvfrom : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr val send : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int val sendto : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int val open_connection : Unix.sockaddr -> in_channel * out_channel mingw-ocaml/ocaml/otherlibs/systhreads/event.ml0000644000175000017500000002125012124403241021315 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Events *) type 'a basic_event = { poll: unit -> bool; (* If communication can take place immediately, return true. *) suspend: unit -> unit; (* Offer the communication on the channel and get ready to suspend current process. *) result: unit -> 'a } (* Return the result of the communication *) type 'a behavior = int ref -> Condition.t -> int -> 'a basic_event type 'a event = Communication of 'a behavior | Choose of 'a event list | WrapAbort of 'a event * (unit -> unit) | Guard of (unit -> 'a event) (* Communication channels *) type 'a channel = { mutable writes_pending: 'a communication Queue.t; (* All offers to write on it *) mutable reads_pending: 'a communication Queue.t } (* All offers to read from it *) (* Communication offered *) and 'a communication = { performed: int ref; (* -1 if not performed yet, set to the number *) (* of the matching communication after rendez-vous. *) condition: Condition.t; (* To restart the blocked thread. *) mutable data: 'a option; (* The data sent or received. *) event_number: int } (* Event number in select *) (* Create a channel *) let new_channel () = { writes_pending = Queue.create(); reads_pending = Queue.create() } (* Basic synchronization function *) let masterlock = Mutex.create() let do_aborts abort_env genev performed = if abort_env <> [] then begin if performed >= 0 then begin let ids_done = snd genev.(performed) in List.iter (fun (id,f) -> if not (List.mem id ids_done) then f ()) abort_env end else begin List.iter (fun (_,f) -> f ()) abort_env end end let basic_sync abort_env genev = let performed = ref (-1) in let condition = Condition.create() in let bev = Array.create (Array.length genev) (fst (genev.(0)) performed condition 0) in for i = 1 to Array.length genev - 1 do bev.(i) <- (fst genev.(i)) performed condition i done; (* See if any of the events is already activable *) let rec poll_events i = if i >= Array.length bev then false else bev.(i).poll() || poll_events (i+1) in Mutex.lock masterlock; if not (poll_events 0) then begin (* Suspend on all events *) for i = 0 to Array.length bev - 1 do bev.(i).suspend() done; (* Wait until the condition is signalled *) Condition.wait condition masterlock end; Mutex.unlock masterlock; (* Extract the result *) if abort_env = [] then (* Preserve tail recursion *) bev.(!performed).result() else begin let num = !performed in let result = bev.(num).result() in (* Handle the aborts and return the result *) do_aborts abort_env genev num; result end (* Apply a random permutation on an array *) let scramble_array a = let len = Array.length a in if len = 0 then invalid_arg "Event.choose"; for i = len - 1 downto 1 do let j = Random.int (i + 1) in let temp = a.(i) in a.(i) <- a.(j); a.(j) <- temp done; a (* Main synchronization function *) let gensym = let count = ref 0 in fun () -> incr count; !count let rec flatten_event (abort_list : int list) (accu : ('a behavior * int list) list) (accu_abort : (int * (unit -> unit)) list) ev = match ev with Communication bev -> ((bev,abort_list) :: accu) , accu_abort | WrapAbort (ev,fn) -> let id = gensym () in flatten_event (id :: abort_list) accu ((id,fn)::accu_abort) ev | Choose evl -> let rec flatten_list accu' accu_abort'= function ev :: l -> let (accu'',accu_abort'') = flatten_event abort_list accu' accu_abort' ev in flatten_list accu'' accu_abort'' l | [] -> (accu',accu_abort') in flatten_list accu accu_abort evl | Guard fn -> flatten_event abort_list accu accu_abort (fn ()) let sync ev = let (evl,abort_env) = flatten_event [] [] [] ev in basic_sync abort_env (scramble_array(Array.of_list evl)) (* Event polling -- like sync, but non-blocking *) let basic_poll abort_env genev = let performed = ref (-1) in let condition = Condition.create() in let bev = Array.create(Array.length genev) (fst genev.(0) performed condition 0) in for i = 1 to Array.length genev - 1 do bev.(i) <- fst genev.(i) performed condition i done; (* See if any of the events is already activable *) let rec poll_events i = if i >= Array.length bev then false else bev.(i).poll() || poll_events (i+1) in Mutex.lock masterlock; let ready = poll_events 0 in if ready then begin (* Extract the result *) Mutex.unlock masterlock; let result = Some(bev.(!performed).result()) in do_aborts abort_env genev !performed; result end else begin (* Cancel the communication offers *) performed := 0; Mutex.unlock masterlock; do_aborts abort_env genev (-1); None end let poll ev = let (evl,abort_env) = flatten_event [] [] [] ev in basic_poll abort_env (scramble_array(Array.of_list evl)) (* Remove all communication opportunities already synchronized *) let cleanup_queue q = let q' = Queue.create() in Queue.iter (fun c -> if !(c.performed) = -1 then Queue.add c q') q; q' (* Event construction *) let always data = Communication(fun performed condition evnum -> { poll = (fun () -> performed := evnum; true); suspend = (fun () -> ()); result = (fun () -> data) }) let send channel data = Communication(fun performed condition evnum -> let wcomm = { performed = performed; condition = condition; data = Some data; event_number = evnum } in { poll = (fun () -> let rec poll () = let rcomm = Queue.take channel.reads_pending in if !(rcomm.performed) >= 0 then poll () else begin rcomm.data <- wcomm.data; performed := evnum; rcomm.performed := rcomm.event_number; Condition.signal rcomm.condition end in try poll(); true with Queue.Empty -> false); suspend = (fun () -> channel.writes_pending <- cleanup_queue channel.writes_pending; Queue.add wcomm channel.writes_pending); result = (fun () -> ()) }) let receive channel = Communication(fun performed condition evnum -> let rcomm = { performed = performed; condition = condition; data = None; event_number = evnum } in { poll = (fun () -> let rec poll () = let wcomm = Queue.take channel.writes_pending in if !(wcomm.performed) >= 0 then poll () else begin rcomm.data <- wcomm.data; performed := evnum; wcomm.performed := wcomm.event_number; Condition.signal wcomm.condition end in try poll(); true with Queue.Empty -> false); suspend = (fun () -> channel.reads_pending <- cleanup_queue channel.reads_pending; Queue.add rcomm channel.reads_pending); result = (fun () -> match rcomm.data with None -> invalid_arg "Event.receive" | Some res -> res) }) let choose evl = Choose evl let wrap_abort ev fn = WrapAbort(ev,fn) let guard fn = Guard fn let rec wrap ev fn = match ev with Communication genev -> Communication(fun performed condition evnum -> let bev = genev performed condition evnum in { poll = bev.poll; suspend = bev.suspend; result = (fun () -> fn(bev.result())) }) | Choose evl -> Choose(List.map (fun ev -> wrap ev fn) evl) | WrapAbort (ev, f') -> WrapAbort (wrap ev fn, f') | Guard gu -> Guard(fun () -> wrap (gu()) fn) (* Convenience functions *) let select evl = sync(Choose evl) mingw-ocaml/ocaml/otherlibs/systhreads/Makefile0000644000175000017500000000673412124403241021314 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ include ../../config/Makefile CAMLC=../../ocamlcomp.sh -I ../unix CAMLOPT=../../ocamlcompopt.sh -I ../unix MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib COMPFLAGS=-warn-error A -g BYTECODE_C_OBJS=st_stubs_b.o NATIVECODE_C_OBJS=st_stubs_n.o THREAD_OBJS= thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo all: libthreads.a threads.cma allopt: libthreadsnat.a threads.cmxa libthreads.a: $(BYTECODE_C_OBJS) $(MKLIB) -o threads $(BYTECODE_C_OBJS) -lpthread st_stubs_b.o: st_stubs.c st_posix.h $(BYTECC) -O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \ -c st_stubs.c mv st_stubs.o st_stubs_b.o # Dynamic linking with -lpthread is risky on many platforms, so # do not create a shared object for libthreadsnat. libthreadsnat.a: $(NATIVECODE_C_OBJS) $(AR) rc libthreadsnat.a $(NATIVECODE_C_OBJS) st_stubs_n.o: st_stubs.c st_posix.h $(NATIVECC) -O -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) -c st_stubs.c mv st_stubs.o st_stubs_n.o threads.cma: $(THREAD_OBJS) $(MKLIB) -ocamlc '$(CAMLC)' -o threads $(THREAD_OBJS) \ -cclib -lunix $(PTHREAD_LINK) # See remark above: force static linking of libthreadsnat.a threads.cmxa: $(THREAD_OBJS:.cmo=.cmx) $(CAMLOPT) -a -o threads.cmxa $(THREAD_OBJS:.cmo=.cmx) \ -cclib -lthreadsnat $(PTHREAD_LINK) # Note: I removed "-cclib -lunix" from the line above. # Indeed, if we link threads.cmxa, then we must also link unix.cmxa, # which itself will pass -lunix to the C linker. It seems more # modular to me this way. -- Alain $(THREAD_OBJS:.cmo=.cmx): ../../ocamlopt partialclean: rm -f *.cm* clean: partialclean rm -f *.o *.a *.so install: if test -f dllthreads.so; then cp dllthreads.so $(STUBLIBDIR)/dllthreads.so; fi cp libthreads.a $(LIBDIR)/libthreads.a cd $(LIBDIR); $(RANLIB) libthreads.a if test -d $(LIBDIR)/threads; then :; else mkdir $(LIBDIR)/threads; fi cp $(THREAD_OBJS:.cmo=.cmi) threads.cma $(LIBDIR)/threads rm -f $(LIBDIR)/threads/stdlib.cma cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli $(LIBDIR) cp threads.h $(LIBDIR)/caml/threads.h installopt: cp libthreadsnat.a $(LIBDIR)/libthreadsnat.a cd $(LIBDIR); $(RANLIB) libthreadsnat.a cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.a $(LIBDIR)/threads cd $(LIBDIR)/threads; $(RANLIB) threads.a .SUFFIXES: .ml .mli .cmo .cmi .cmx .mli.cmi: $(CAMLC) -c $(COMPFLAGS) $< .ml.cmo: $(CAMLC) -c $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< depend: $(GENFILES) -gcc -MM -I../../byterun *.c > .depend ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend include .depend mingw-ocaml/ocaml/otherlibs/systhreads/mutex.ml0000644000175000017500000000211512124403241021335 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Pascal Cuoq, INRIA Rocquencourt *) (* *) (* Copyright 1995 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) type t external create: unit -> t = "caml_mutex_new" external lock: t -> unit = "caml_mutex_lock" external try_lock: t -> bool = "caml_mutex_try_lock" external unlock: t -> unit = "caml_mutex_unlock" mingw-ocaml/ocaml/otherlibs/systhreads/thread.ml0000644000175000017500000000601612124403241021446 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* User-level threads *) type t external thread_initialize : unit -> unit = "caml_thread_initialize" external thread_cleanup : unit -> unit = "caml_thread_cleanup" external thread_new : (unit -> unit) -> t = "caml_thread_new" external thread_uncaught_exception : exn -> unit = "caml_thread_uncaught_exception" external yield : unit -> unit = "caml_thread_yield" external self : unit -> t = "caml_thread_self" external id : t -> int = "caml_thread_id" external join : t -> unit = "caml_thread_join" external exit : unit -> unit = "caml_thread_exit" (* For new, make sure the function passed to thread_new never raises an exception. *) let create fn arg = thread_new (fun () -> try fn arg; () with exn -> flush stdout; flush stderr; thread_uncaught_exception exn) (* Thread.kill is currently not implemented due to problems with cleanup handlers on several platforms *) let kill th = invalid_arg "Thread.kill: not implemented" (* Preemption *) let preempt signal = yield() (* Initialization of the scheduler *) let preempt_signal = match Sys.os_type with | "Win32" -> Sys.sigterm | _ -> Sys.sigvtalrm let _ = Sys.set_signal preempt_signal (Sys.Signal_handle preempt); thread_initialize(); at_exit (fun () -> thread_cleanup(); (* In case of DLL-embedded OCaml the preempt_signal handler will point to nowhere after DLL unloading and an accidental preempt_signal will crash the main program. So restore the default handler. *) Sys.set_signal preempt_signal Sys.Signal_default ) (* Wait functions *) let delay time = ignore(Unix.select [] [] [] time) let wait_read fd = () let wait_write fd = () let wait_timed_read fd d = match Unix.select [fd] [] [] d with ([], _, _) -> false | (_, _, _) -> true let wait_timed_write fd d = match Unix.select [] [fd] [] d with (_, [], _) -> false | (_, _, _) -> true let select = Unix.select let wait_pid p = Unix.waitpid [] p external sigmask : Unix.sigprocmask_command -> int list -> int list = "caml_thread_sigmask" external wait_signal : int list -> int = "caml_wait_signal" mingw-ocaml/ocaml/otherlibs/systhreads/Makefile.nt0000644000175000017500000000615412124403241021730 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the GNU Library General Public License, with # # the special exception on linking described in file ../../LICENSE. # # # ######################################################################### # $Id$ include ../../config/Makefile # Compilation options CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../win32unix CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../win32unix COMPFLAGS=-warn-error A -g MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib CFLAGS=-I../../byterun $(EXTRACFLAGS) CAMLOBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo CMIFILES=$(CAMLOBJS:.cmo=.cmi) COBJS=st_stubs_b.$(O) COBJS_NAT=st_stubs_n.$(O) LIBNAME=threads all: lib$(LIBNAME).$(A) $(LIBNAME).cma $(CMIFILES) allopt: lib$(LIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).cmxs $(CMIFILES) $(LIBNAME).cma: $(CAMLOBJS) $(MKLIB) -o $(LIBNAME) -ocamlc "..\\..\\boot\\ocamlrun ..\\..\\ocamlc" -linkall $(CAMLOBJS) $(LINKOPTS) lib$(LIBNAME).$(A): $(COBJS) $(MKLIB) -o $(LIBNAME) $(COBJS) $(LDOPTS) st_stubs_b.$(O): st_stubs.c st_win32.h $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c st_stubs.c mv st_stubs.$(O) st_stubs_b.$(O) $(LIBNAME).cmxa: $(CAMLOBJS:.cmo=.cmx) $(MKLIB) -o $(LIBNAME)nat -ocamlopt "..\\..\\boot\\ocamlrun ..\\..\\ocamlopt" -linkall $(CAMLOBJS:.cmo=.cmx) $(LINKOPTS) mv $(LIBNAME)nat.cmxa $(LIBNAME).cmxa mv $(LIBNAME)nat.$(A) $(LIBNAME).$(A) $(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(LIBNAME)nat.$(A) $(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa -linkall lib$(LIBNAME)nat.$(A): $(COBJS_NAT) $(MKLIB) -o $(LIBNAME)nat $(COBJS_NAT) $(LDOPTS) st_stubs_n.$(O): st_stubs.c st_win32.h $(NATIVECC) -DNATIVE_CODE -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) -c st_stubs.c mv st_stubs.$(O) st_stubs_n.$(O) $(CAMLOBJS:.cmo=.cmx): ../../ocamlopt partialclean: rm -f *.cm* clean: partialclean rm -f *.dll *.$(A) *.$(O) install: cp dllthreads.dll $(STUBLIBDIR)/dllthreads.dll cp libthreads.$(A) $(LIBDIR)/libthreads.$(A) mkdir -p $(LIBDIR)/threads cp $(CMIFILES) threads.cma $(LIBDIR)/threads rm -f $(LIBDIR)/threads/stdlib.cma cp threads.h $(LIBDIR)/caml/threads.h installopt: cp libthreadsnat.$(A) $(LIBDIR)/libthreadsnat.$(A) cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.$(A) $(LIBDIR)/threads cp threads.cmxs $(LIBDIR)/threads .SUFFIXES: .ml .mli .cmo .cmi .cmx .mli.cmi: $(CAMLC) -c $(COMPFLAGS) $< .ml.cmo: $(CAMLC) -c -g $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< depend: include .depend mingw-ocaml/ocaml/otherlibs/systhreads/threadUnix.ml0000644000175000017500000000415012124403241022307 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [ThreadUnix]: thread-compatible system calls *) open Unix (*** Process handling *) external execv : string -> string array -> unit = "unix_execv" external execve : string -> string array -> string array -> unit = "unix_execve" external execvp : string -> string array -> unit = "unix_execvp" let wait = Unix.wait let waitpid = Unix.waitpid let system = Unix.system let read = Unix.read let write = Unix.write let select = Unix.select let timed_read fd buff ofs len timeout = if Thread.wait_timed_read fd timeout then Unix.read fd buff ofs len else raise (Unix_error(ETIMEDOUT, "timed_read", "")) let timed_write fd buff ofs len timeout = if Thread.wait_timed_write fd timeout then Unix.write fd buff ofs len else raise (Unix_error(ETIMEDOUT, "timed_write", "")) let pipe = Unix.pipe let open_process_in = Unix.open_process_in let open_process_out = Unix.open_process_out let open_process = Unix.open_process external sleep : int -> unit = "unix_sleep" let socket = Unix.socket let accept = Unix.accept external connect : file_descr -> sockaddr -> unit = "unix_connect" let recv = Unix.recv let recvfrom = Unix.recvfrom let send = Unix.send let sendto = Unix.sendto let open_connection = Unix.open_connection mingw-ocaml/ocaml/otherlibs/systhreads/st_posix.h0000644000175000017500000002267212124403241021674 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 2009 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* POSIX thread implementation of the "st" interface */ #include #include #include #include #include #ifdef __sun #define _POSIX_PTHREAD_SEMANTICS #endif #include #include #ifdef __linux__ #include #endif #ifdef __GNUC__ #define INLINE inline #else #define INLINE #endif typedef int st_retcode; #define SIGPREEMPTION SIGVTALRM /* OS-specific initialization */ static int st_initialize(void) { return 0; } /* Thread creation. Created in detached mode if [res] is NULL. */ typedef pthread_t st_thread_id; static int st_thread_create(st_thread_id * res, void * (*fn)(void *), void * arg) { pthread_t thr; pthread_attr_t attr; int rc; pthread_attr_init(&attr); if (res == NULL) pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); rc = pthread_create(&thr, &attr, fn, arg); if (res != NULL) *res = thr; return rc; } #define ST_THREAD_FUNCTION void * /* Cleanup at thread exit */ static INLINE void st_thread_cleanup(void) { return; } /* Thread termination */ static void st_thread_exit(void) { pthread_exit(NULL); } static void st_thread_kill(st_thread_id thr) { pthread_cancel(thr); } /* Scheduling hints */ static void INLINE st_thread_yield(void) { #ifndef __linux__ /* sched_yield() doesn't do what we want in Linux 2.6 and up (PR#2663) */ sched_yield(); #endif } /* Thread-specific state */ typedef pthread_key_t st_tlskey; static int st_tls_newkey(st_tlskey * res) { return pthread_key_create(res, NULL); } static INLINE void * st_tls_get(st_tlskey k) { return pthread_getspecific(k); } static INLINE void st_tls_set(st_tlskey k, void * v) { pthread_setspecific(k, v); } /* The master lock. This is a mutex that is held most of the time, so we implement it in a slightly consoluted way to avoid all risks of busy-waiting. Also, we count the number of waiting threads. */ typedef struct { pthread_mutex_t lock; /* to protect contents */ int busy; /* 0 = free, 1 = taken */ volatile int waiters; /* number of threads waiting on master lock */ pthread_cond_t is_free; /* signaled when free */ } st_masterlock; static void st_masterlock_init(st_masterlock * m) { pthread_mutex_init(&m->lock, NULL); pthread_cond_init(&m->is_free, NULL); m->busy = 1; m->waiters = 0; } static void st_masterlock_acquire(st_masterlock * m) { pthread_mutex_lock(&m->lock); while (m->busy) { m->waiters ++; pthread_cond_wait(&m->is_free, &m->lock); m->waiters --; } m->busy = 1; pthread_mutex_unlock(&m->lock); } static void st_masterlock_release(st_masterlock * m) { pthread_mutex_lock(&m->lock); m->busy = 0; pthread_mutex_unlock(&m->lock); pthread_cond_signal(&m->is_free); } static INLINE int st_masterlock_waiters(st_masterlock * m) { return m->waiters; } /* Mutexes */ typedef pthread_mutex_t * st_mutex; static int st_mutex_create(st_mutex * res) { int rc; st_mutex m = malloc(sizeof(pthread_mutex_t)); if (m == NULL) return ENOMEM; rc = pthread_mutex_init(m, NULL); if (rc != 0) { free(m); return rc; } *res = m; return 0; } static int st_mutex_destroy(st_mutex m) { int rc; rc = pthread_mutex_destroy(m); free(m); return rc; } static INLINE int st_mutex_lock(st_mutex m) { return pthread_mutex_lock(m); } #define PREVIOUSLY_UNLOCKED 0 #define ALREADY_LOCKED EBUSY static INLINE int st_mutex_trylock(st_mutex m) { return pthread_mutex_trylock(m); } static INLINE int st_mutex_unlock(st_mutex m) { return pthread_mutex_unlock(m); } /* Condition variables */ typedef pthread_cond_t * st_condvar; static int st_condvar_create(st_condvar * res) { int rc; st_condvar c = malloc(sizeof(pthread_cond_t)); if (c == NULL) return ENOMEM; rc = pthread_cond_init(c, NULL); if (rc != 0) { free(c); return rc; } *res = c; return 0; } static int st_condvar_destroy(st_condvar c) { int rc; rc = pthread_cond_destroy(c); free(c); return rc; } static INLINE int st_condvar_signal(st_condvar c) { return pthread_cond_signal(c); } static INLINE int st_condvar_broadcast(st_condvar c) { return pthread_cond_broadcast(c); } static INLINE int st_condvar_wait(st_condvar c, st_mutex m) { return pthread_cond_wait(c, m); } /* Triggered events */ typedef struct st_event_struct { pthread_mutex_t lock; /* to protect contents */ int status; /* 0 = not triggered, 1 = triggered */ pthread_cond_t triggered; /* signaled when triggered */ } * st_event; static int st_event_create(st_event * res) { int rc; st_event e = malloc(sizeof(struct st_event_struct)); if (e == NULL) return ENOMEM; rc = pthread_mutex_init(&e->lock, NULL); if (rc != 0) { free(e); return rc; } rc = pthread_cond_init(&e->triggered, NULL); if (rc != 0) { pthread_mutex_destroy(&e->lock); free(e); return rc; } e->status = 0; *res = e; return 0; } static int st_event_destroy(st_event e) { int rc1, rc2; rc1 = pthread_mutex_destroy(&e->lock); rc2 = pthread_cond_destroy(&e->triggered); free(e); return rc1 != 0 ? rc1 : rc2; } static int st_event_trigger(st_event e) { int rc; rc = pthread_mutex_lock(&e->lock); if (rc != 0) return rc; e->status = 1; rc = pthread_mutex_unlock(&e->lock); if (rc != 0) return rc; rc = pthread_cond_broadcast(&e->triggered); return rc; } static int st_event_wait(st_event e) { int rc; rc = pthread_mutex_lock(&e->lock); if (rc != 0) return rc; while(e->status == 0) { rc = pthread_cond_wait(&e->triggered, &e->lock); if (rc != 0) return rc; } rc = pthread_mutex_unlock(&e->lock); return rc; } /* Reporting errors */ static void st_check_error(int retcode, char * msg) { char * err; int errlen, msglen; value str; if (retcode == 0) return; if (retcode == ENOMEM) raise_out_of_memory(); err = strerror(retcode); msglen = strlen(msg); errlen = strlen(err); str = alloc_string(msglen + 2 + errlen); memmove (&Byte(str, 0), msg, msglen); memmove (&Byte(str, msglen), ": ", 2); memmove (&Byte(str, msglen + 2), err, errlen); raise_sys_error(str); } /* The tick thread: posts a SIGPREEMPTION signal periodically */ static void * caml_thread_tick(void * arg) { struct timeval timeout; sigset_t mask; /* Block all signals so that we don't try to execute an OCaml signal handler*/ sigfillset(&mask); pthread_sigmask(SIG_BLOCK, &mask, NULL); /* Allow async cancellation */ pthread_setcanceltype(PTHREAD_CANCEL_ASYNCHRONOUS, NULL); while(1) { /* select() seems to be the most efficient way to suspend the thread for sub-second intervals */ timeout.tv_sec = 0; timeout.tv_usec = Thread_timeout * 1000; select(0, NULL, NULL, NULL, &timeout); /* The preemption signal should never cause a callback, so don't go through caml_handle_signal(), just record signal delivery via caml_record_signal(). */ caml_record_signal(SIGPREEMPTION); } return NULL; /* prevents compiler warning */ } /* "At fork" processing */ static int st_atfork(void (*fn)(void)) { return pthread_atfork(NULL, NULL, fn); } /* Signal handling */ static void st_decode_sigset(value vset, sigset_t * set) { sigemptyset(set); while (vset != Val_int(0)) { int sig = caml_convert_signal_number(Int_val(Field(vset, 0))); sigaddset(set, sig); vset = Field(vset, 1); } } #ifndef NSIG #define NSIG 64 #endif static value st_encode_sigset(sigset_t * set) { value res = Val_int(0); int i; Begin_root(res) for (i = 1; i < NSIG; i++) if (sigismember(set, i) > 0) { value newcons = alloc_small(2, 0); Field(newcons, 0) = Val_int(caml_rev_convert_signal_number(i)); Field(newcons, 1) = res; res = newcons; } End_roots(); return res; } static int sigmask_cmd[3] = { SIG_SETMASK, SIG_BLOCK, SIG_UNBLOCK }; value caml_thread_sigmask(value cmd, value sigs) /* ML */ { int how; sigset_t set, oldset; int retcode; how = sigmask_cmd[Int_val(cmd)]; st_decode_sigset(sigs, &set); enter_blocking_section(); retcode = pthread_sigmask(how, &set, &oldset); leave_blocking_section(); st_check_error(retcode, "Thread.sigmask"); return st_encode_sigset(&oldset); } value caml_wait_signal(value sigs) /* ML */ { #ifdef HAS_SIGWAIT sigset_t set; int retcode, signo; st_decode_sigset(sigs, &set); enter_blocking_section(); retcode = sigwait(&set, &signo); leave_blocking_section(); st_check_error(retcode, "Thread.wait_signal"); return Val_int(signo); #else invalid_argument("Thread.wait_signal not implemented"); return Val_int(0); /* not reached */ #endif } mingw-ocaml/ocaml/otherlibs/systhreads/thread.mli0000644000175000017500000001311312124403241021613 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1995 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Lightweight threads for Posix [1003.1c] and Win32. *) type t (** The type of thread handles. *) (** {6 Thread creation and termination} *) val create : ('a -> 'b) -> 'a -> t (** [Thread.create funct arg] creates a new thread of control, in which the function application [funct arg] is executed concurrently with the other threads of the program. The application of [Thread.create] returns the handle of the newly created thread. The new thread terminates when the application [funct arg] returns, either normally or by raising an uncaught exception. In the latter case, the exception is printed on standard error, but not propagated back to the parent thread. Similarly, the result of the application [funct arg] is discarded and not directly accessible to the parent thread. *) val self : unit -> t (** Return the thread currently executing. *) val id : t -> int (** Return the identifier of the given thread. A thread identifier is an integer that identifies uniquely the thread. It can be used to build data structures indexed by threads. *) val exit : unit -> unit (** Terminate prematurely the currently executing thread. *) val kill : t -> unit (** Terminate prematurely the thread whose handle is given. *) (** {6 Suspending threads} *) val delay: float -> unit (** [delay d] suspends the execution of the calling thread for [d] seconds. The other program threads continue to run during this time. *) val join : t -> unit (** [join th] suspends the execution of the calling thread until the thread [th] has terminated. *) val wait_read : Unix.file_descr -> unit (** See {!Thread.wait_write}.*) val wait_write : Unix.file_descr -> unit (** This function does nothing in this implementation. *) val wait_timed_read : Unix.file_descr -> float -> bool (** See {!Thread.wait_timed_read}.*) val wait_timed_write : Unix.file_descr -> float -> bool (** Suspend the execution of the calling thread until at least one character is available for reading ([wait_read]) or one character can be written without blocking ([wait_write]) on the given Unix file descriptor. Wait for at most the amount of time given as second argument (in seconds). Return [true] if the file descriptor is ready for input/output and [false] if the timeout expired. These functions return immediately [true] in the Win32 implementation. *) val select : Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list * Unix.file_descr list (** Suspend the execution of the calling thead until input/output becomes possible on the given Unix file descriptors. The arguments and results have the same meaning as for [Unix.select]. This function is not implemented yet under Win32. *) val wait_pid : int -> int * Unix.process_status (** [wait_pid p] suspends the execution of the calling thread until the process specified by the process identifier [p] terminates. Returns the pid of the child caught and its termination status, as per [Unix.wait]. This function is not implemented under MacOS. *) val yield : unit -> unit (** Re-schedule the calling thread without suspending it. This function can be used to give scheduling hints, telling the scheduler that now is a good time to switch to other threads. *) (** {6 Management of signals} *) (** Signal handling follows the POSIX thread model: signals generated by a thread are delivered to that thread; signals generated externally are delivered to one of the threads that does not block it. Each thread possesses a set of blocked signals, which can be modified using {!Thread.sigmask}. This set is inherited at thread creation time. Per-thread signal masks are supported only by the system thread library under Unix, but not under Win32, nor by the VM thread library. *) val sigmask : Unix.sigprocmask_command -> int list -> int list (** [sigmask cmd sigs] changes the set of blocked signals for the calling thread. If [cmd] is [SIG_SETMASK], blocked signals are set to those in the list [sigs]. If [cmd] is [SIG_BLOCK], the signals in [sigs] are added to the set of blocked signals. If [cmd] is [SIG_UNBLOCK], the signals in [sigs] are removed from the set of blocked signals. [sigmask] returns the set of previously blocked signals for the thread. *) val wait_signal : int list -> int (** [wait_signal sigs] suspends the execution of the calling thread until the process receives one of the signals specified in the list [sigs]. It then returns the number of the signal received. Signal handlers attached to the signals in [sigs] will not be invoked. The signals [sigs] are expected to be blocked before calling [wait_signal]. *) mingw-ocaml/ocaml/otherlibs/systhreads/st_win32.h0000644000175000017500000002406112124403241021466 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ /* */ /* Copyright 2009 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Win32 implementation of the "st" interface */ #define _WIN32_WINNT 0x0400 #include #include #include #include #define INLINE __inline #if 1 #define TRACE(x) #define TRACE1(x,y) #else #include #define TRACE(x) printf("%d: %s\n", GetCurrentThreadId(), x); fflush(stdout) #define TRACE1(x,y) printf("%d: %s %p\n", GetCurrentThreadId(), x, (void *)y); fflush(stdout) #endif typedef DWORD st_retcode; #define SIGPREEMPTION SIGTERM /* Thread-local storage assocaiting a Win32 event to every thread. */ static DWORD st_thread_sem_key; /* OS-specific initialization */ static DWORD st_initialize(void) { st_thread_sem_key = TlsAlloc(); if (st_thread_sem_key == TLS_OUT_OF_INDEXES) return GetLastError(); else return 0; } /* Thread creation. Created in detached mode if [res] is NULL. */ typedef HANDLE st_thread_id; static DWORD st_thread_create(st_thread_id * res, LPTHREAD_START_ROUTINE fn, void * arg) { HANDLE h = CreateThread(NULL, 0, fn, arg, 0, NULL); TRACE1("st_thread_create", h); if (h == NULL) return GetLastError(); if (res == NULL) CloseHandle(h); else *res = h; return 0; } #define ST_THREAD_FUNCTION DWORD WINAPI /* Cleanup at thread exit */ static void st_thread_cleanup(void) { HANDLE ev = (HANDLE) TlsGetValue(st_thread_sem_key); if (ev != NULL) CloseHandle(ev); } /* Thread termination */ static void st_thread_exit(void) { TRACE("st_thread_exit"); ExitThread(0); } static void st_thread_kill(st_thread_id thr) { TRACE1("st_thread_kill", thr); TerminateThread(thr, 0); CloseHandle(thr); } /* Scheduling hints */ static INLINE void st_thread_yield(void) { Sleep(0); } /* Thread-specific state */ typedef DWORD st_tlskey; static DWORD st_tls_newkey(st_tlskey * res) { *res = TlsAlloc(); if (*res == TLS_OUT_OF_INDEXES) return GetLastError(); else return 0; } static INLINE void * st_tls_get(st_tlskey k) { return TlsGetValue(k); } static INLINE void st_tls_set(st_tlskey k, void * v) { TlsSetValue(k, v); } /* The master lock. */ typedef CRITICAL_SECTION st_masterlock; static void st_masterlock_init(st_masterlock * m) { TRACE("st_masterlock_init"); InitializeCriticalSection(m); EnterCriticalSection(m); } static INLINE void st_masterlock_acquire(st_masterlock * m) { TRACE("st_masterlock_acquire"); EnterCriticalSection(m); TRACE("st_masterlock_acquire (done)"); } static INLINE void st_masterlock_release(st_masterlock * m) { LeaveCriticalSection(m); TRACE("st_masterlock_released"); } static INLINE int st_masterlock_waiters(st_masterlock * m) { return 1; /* info not maintained */ } /* Mutexes */ typedef CRITICAL_SECTION * st_mutex; static DWORD st_mutex_create(st_mutex * res) { st_mutex m = malloc(sizeof(CRITICAL_SECTION)); if (m == NULL) return ERROR_NOT_ENOUGH_MEMORY; InitializeCriticalSection(m); *res = m; return 0; } static DWORD st_mutex_destroy(st_mutex m) { DeleteCriticalSection(m); free(m); return 0; } static INLINE DWORD st_mutex_lock(st_mutex m) { TRACE1("st_mutex_lock", m); EnterCriticalSection(m); TRACE1("st_mutex_lock (done)", m); return 0; } /* Error codes with the 29th bit set are reserved for the application */ #define PREVIOUSLY_UNLOCKED 0 #define ALREADY_LOCKED (1<<29) static INLINE DWORD st_mutex_trylock(st_mutex m) { TRACE1("st_mutex_trylock", m); if (TryEnterCriticalSection(m)) { TRACE1("st_mutex_trylock (success)", m); return PREVIOUSLY_UNLOCKED; } else { TRACE1("st_mutex_trylock (failure)", m); return ALREADY_LOCKED; } } static INLINE DWORD st_mutex_unlock(st_mutex m) { TRACE1("st_mutex_unlock", m); LeaveCriticalSection(m); return 0; } /* Condition variables */ /* A condition variable is just a list of threads currently waiting on this c.v. Each thread is represented by its associated event. */ struct st_wait_list { HANDLE event; /* event of the first waiting thread */ struct st_wait_list * next; }; typedef struct st_condvar_struct { CRITICAL_SECTION lock; /* protect the data structure */ struct st_wait_list * waiters; /* list of threads waiting */ } * st_condvar; static DWORD st_condvar_create(st_condvar * res) { st_condvar c = malloc(sizeof(struct st_condvar_struct)); if (c == NULL) return ERROR_NOT_ENOUGH_MEMORY; InitializeCriticalSection(&c->lock); c->waiters = NULL; *res = c; return 0; } static DWORD st_condvar_destroy(st_condvar c) { TRACE1("st_condvar_destroy", c); DeleteCriticalSection(&c->lock); free(c); return 0; } static DWORD st_condvar_signal(st_condvar c) { DWORD rc = 0; struct st_wait_list * curr, * next; TRACE1("st_condvar_signal", c); EnterCriticalSection(&c->lock); curr = c->waiters; if (curr != NULL) { next = curr->next; /* Wake up the first waiting thread */ TRACE1("st_condvar_signal: waking up", curr->event); if (! SetEvent(curr->event)) rc = GetLastError(); /* Remove it from the waiting list */ c->waiters = next; } LeaveCriticalSection(&c->lock); return rc; } static DWORD st_condvar_broadcast(st_condvar c) { DWORD rc = 0; struct st_wait_list * curr, * next; TRACE1("st_condvar_broadcast", c); EnterCriticalSection(&c->lock); /* Wake up all waiting threads */ curr = c->waiters; while (curr != NULL) { next = curr->next; TRACE1("st_condvar_signal: waking up", curr->event); if (! SetEvent(curr->event)) rc = GetLastError(); curr = next; } /* Remove them all from the waiting list */ c->waiters = NULL; LeaveCriticalSection(&c->lock); return rc; } static DWORD st_condvar_wait(st_condvar c, st_mutex m) { HANDLE ev; struct st_wait_list wait; TRACE1("st_condvar_wait", c); /* Recover (or create) the event associated with the calling thread */ ev = (HANDLE) TlsGetValue(st_thread_sem_key); if (ev == 0) { ev = CreateEvent(NULL, FALSE /*auto reset*/, FALSE /*initially unset*/, NULL); if (ev == NULL) return GetLastError(); TlsSetValue(st_thread_sem_key, (void *) ev); } EnterCriticalSection(&c->lock); /* Insert the current thread in the waiting list (atomically) */ wait.event = ev; wait.next = c->waiters; c->waiters = &wait; LeaveCriticalSection(&c->lock); /* Release the mutex m */ LeaveCriticalSection(m); /* Wait for our event to be signaled. There is no risk of lost wakeup, since we inserted ourselves on the waiting list of c before releasing m */ TRACE1("st_condvar_wait: blocking on event", ev); if (WaitForSingleObject(ev, INFINITE) == WAIT_FAILED) return GetLastError(); /* Reacquire the mutex m */ TRACE1("st_condvar_wait: restarted, acquiring mutex", m); EnterCriticalSection(m); TRACE1("st_condvar_wait: acquired mutex", m); return 0; } /* Triggered events */ typedef HANDLE st_event; static DWORD st_event_create(st_event * res) { st_event m = CreateEvent(NULL, TRUE/*manual reset*/, FALSE/*initially unset*/, NULL); TRACE1("st_event_create", m); if (m == NULL) return GetLastError(); *res = m; return 0; } static DWORD st_event_destroy(st_event e) { TRACE1("st_event_destroy", e); if (CloseHandle(e)) return 0; else return GetLastError(); } static DWORD st_event_trigger(st_event e) { TRACE1("st_event_trigger", e); if (SetEvent(e)) return 0; else return GetLastError(); } static DWORD st_event_wait(st_event e) { TRACE1("st_event_wait", e); if (WaitForSingleObject(e, INFINITE) == WAIT_FAILED) return GetLastError(); else return 0; } /* Reporting errors */ static void st_check_error(DWORD retcode, char * msg) { char err[1024]; int errlen, msglen; value str; if (retcode == 0) return; if (retcode == ERROR_NOT_ENOUGH_MEMORY) raise_out_of_memory(); if (! FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS, NULL, retcode, 0, err, sizeof(err), NULL)) { sprintf(err, "error code %lx", retcode); } msglen = strlen(msg); errlen = strlen(err); str = alloc_string(msglen + 2 + errlen); memmove (&Byte(str, 0), msg, msglen); memmove (&Byte(str, msglen), ": ", 2); memmove (&Byte(str, msglen + 2), err, errlen); raise_sys_error(str); } /* The tick thread: posts a SIGPREEMPTION signal periodically */ static DWORD WINAPI caml_thread_tick(void * arg) { while(1) { Sleep(Thread_timeout); /* The preemption signal should never cause a callback, so don't go through caml_handle_signal(), just record signal delivery via caml_record_signal(). */ caml_record_signal(SIGPREEMPTION); } return 0; /* prevents compiler warning */ } /* "At fork" processing -- none under Win32 */ static DWORD st_atfork(void (*fn)(void)) { return 0; } /* Signal handling -- none under Win32 */ value caml_thread_sigmask(value cmd, value sigs) /* ML */ { invalid_argument("Thread.sigmask not implemented"); return Val_int(0); /* not reached */ } value caml_wait_signal(value sigs) /* ML */ { invalid_argument("Thread.wait_signal not implemented"); return Val_int(0); /* not reached */ } mingw-ocaml/ocaml/otherlibs/systhreads/threads.mllib0000644000175000017500000000005012124403241022310 0ustar tootstootsThread Mutex Condition Event ThreadUnix mingw-ocaml/ocaml/otherlibs/systhreads/condition.mli0000644000175000017500000000430212124403241022332 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (* $Id$ *) (** Condition variables to synchronize between threads. Condition variables are used when one thread wants to wait until another thread has finished doing something: the former thread ``waits'' on the condition variable, the latter thread ``signals'' the condition when it is done. Condition variables should always be protected by a mutex. The typical use is (if [D] is a shared data structure, [m] its mutex, and [c] is a condition variable): {[ Mutex.lock m; while (* some predicate P over D is not satisfied *) do Condition.wait c m done; (* Modify D *) if (* the predicate P over D is now satified *) then Condition.signal c; Mutex.unlock m ]} *) type t (** The type of condition variables. *) val create : unit -> t (** Return a new condition variable. *) val wait : t -> Mutex.t -> unit (** [wait c m] atomically unlocks the mutex [m] and suspends the calling process on the condition variable [c]. The process will restart after the condition variable [c] has been signalled. The mutex [m] is locked again before [wait] returns. *) val signal : t -> unit (** [signal c] restarts one of the processes waiting on the condition variable [c]. *) val broadcast : t -> unit (** [broadcast c] restarts all processes waiting on the condition variable [c]. *) mingw-ocaml/ocaml/otherlibs/systhreads/.depend0000644000175000017500000000212112124403241021076 0ustar tootstootsst_stubs.o: st_stubs.c ../../byterun/alloc.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/backtrace.h ../../byterun/callback.h \ ../../byterun/custom.h ../../byterun/fail.h ../../byterun/io.h \ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/misc.h \ ../../byterun/mlvalues.h ../../byterun/printexc.h ../../byterun/roots.h \ ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \ ../../byterun/sys.h threads.h st_posix.h condition.cmi : mutex.cmi event.cmi : mutex.cmi : thread.cmi : threadUnix.cmi : condition.cmo : mutex.cmi condition.cmi condition.cmx : mutex.cmx condition.cmi event.cmo : mutex.cmi condition.cmi event.cmi event.cmx : mutex.cmx condition.cmx event.cmi mutex.cmo : mutex.cmi mutex.cmx : mutex.cmi thread.cmo : thread.cmi thread.cmx : thread.cmi threadUnix.cmo : thread.cmi threadUnix.cmi threadUnix.cmx : thread.cmx threadUnix.cmi mingw-ocaml/ocaml/INSTALL0000644000175000017500000003324712124403241014520 0ustar tootstoots Installing OCaml on a Unix machine ---------------------------------- PREREQUISITES * The GNU C compiler gcc is recommended, as the bytecode interpreter takes advantage of gcc-specific features to enhance performance. gcc is the standard compiler under Linux, MacOS X, and many other systems. * Under MacOS X 10.5, you need version 3.1 or later of the XCode development tools. The version of XCode found on MacOS X 10.5 installation media causes linking problems. XCode updates are available free of charge at http://developer.apple.com/tools/xcode/ * Under MacOS X up to version 10.2.8, you must raise the limit on the stack size with one of the following commands: limit stacksize 64M # if your shell is zsh or tcsh ulimit -s 65536 # if your shell is bash * If you do not have write access to /tmp, you should set the environment variable TMPDIR to the name of some other temporary directory. * Under HP/UX, the GNU C compiler gcc, the GNU assembler gas, and GNU make are all *required*. The vendor-provided compiler, assembler and make have major problems. * GNU make is needed to build ocamlbuild and camlp4. If your system's default make is not GNU make, you need to define the GNUMAKE environment variable to the name of GNU make, typically with this command: export GNUMAKE=gnumake INSTALLATION INSTRUCTIONS 1- Configure the system. From the top directory, do: ./configure This generates the three configuration files "Makefile", "m.h" and "s.h" in the config/ subdirectory. The "configure" script accepts the following options: -prefix

(default: /usr/local) Set the PREFIX variable used to define the defaults of the following three options. Must be an absolute path name. -bindir (default: $(PREFIX)/bin) Directory where the binaries will be installed. Must be an absolute path name, or start with "$(PREFIX)" -libdir (default: $(PREFIX)/lib/ocaml) Directory where the OCaml library will be installed Must be an absolute path name, or start with "$(PREFIX)" -mandir (default: $(PREFIX)/man/man1) Directory where the manual pages will be installed Must be an absolute path name, or start with "$(PREFIX)" -cc (default: gcc if available, cc otherwise) C compiler to use for building the system -libs (default: none) Extra libraries to link with the system -no-curses Do not use the curses library. -host (default: determined automatically) The type of the host machine, in GNU's "configuration name" format (CPU-COMPANY-SYSTEM or CPU-COMPANY-KERNEL-SYSTEM). This info is generally determined automatically by the "configure" script, and rarely ever needs to be provided by hand. The installation instructions for gcc or emacs contain a complete list of configuration names. -x11include (default: determined automatically) -x11lib (default: determined automatically) Location of the X11 include directory (e.g. /usr/X11R6/include) and the X11 library directory (e.g. /usr/X11R6/lib). -tkdefs (default: none) -tklibs (default: determined automatically) These options specify where to find the Tcl/Tk libraries for LablTk. "-tkdefs" helps to find the headers, and "-tklibs" the C libraries. "-tklibs" may contain either only -L/path and -Wl,... flags, in which case the library names are determined automatically, or the actual libraries, which are used as given. Example: for a Japanese tcl/tk whose headers are in specific directories and libraries in /usr/local/lib, you can use ./configure -tklibs "-L/usr/local/lib -ltk8.0jp -ltcl8.0jp" -tkdefs "-I/usr/local/include/tcl8.0jp -I/usr/local/include/tk8.0jp" -tk-no-x11 Build LablTk without using X11. This option is needed on Cygwin. -no-tk Do not attempt to build LablTk. -no-pthread Do not attempt to use POSIX threads. -with-pthread Attempt to use POSIX threads (this is the default). -no-shared-libs Do not configure support for shared libraries -dldefs -dllibs These options specify where to find the libraries for dynamic linking (i.e. use of shared libraries). "-dldefs" specifies options for finding the header files, and "-dllibs" for finding the C libraries. -as (default: determined automatically) The assembler to use for assembling ocamlopt-generated code. -aspp (default: determined automatically) The assembler to use for assembling the parts of the run-time system manually written in assembly language. This assembler must preprocess its input with the C preprocessor. -with-debug-runtime Compile and install the debug version of the runtimes, useful for debugging C stubs and other low-level code. -verbose Verbose output of the configuration tests. Use it if the outcome of configure is not what you were expecting. -no-camlp4 Do not compile Camlp4. -no-graph Do not compile the Graphics library. -partialld (default: determined automatically) The linker and options to use for producing an object file (rather than an executable) from several other object files. Examples: Standard installation in /usr/{bin,lib,man} instead of /usr/local: ./configure -prefix /usr Installation in /usr, man pages in section "l": ./configure -bindir /usr/bin -libdir /usr/lib/ocaml -mandir /usr/man/manl or: ./configure -prefix /usr -mandir '$(PREFIX)/man/manl' On a MacOSX 10.5/Intel Core 2 or MacOSX 10.5/PowerPC host, to build a 64-bit version of OCaml: ./configure -cc "gcc -m64" On a MacOSX 10.6/Intel Core 2, to build a 32-bit version of OCaml: ./configure -cc "gcc -m32" -as "as -arch i386" -aspp "gcc -m32 -c" On a Linux x86/64 bits host, to build a 32-bit version of OCaml: ./configure -cc "gcc -m32" -as "as --32" -aspp "gcc -m32 -c" On a Linux x86/64 bits host, to build the run-time system in PIC mode (enables putting the runtime in a shared library, at a small performance cost): ./configure -cc "gcc -fPIC" -aspp "gcc -c -fPIC" For Sun Solaris with the "acc" compiler: ./configure -cc "acc -fast" -libs "-lucb" For Sun Solaris on Sparc 64bit, to compile natively (32bit only) ./configure -cc "gcc -m32" -as "as -32" -aspp "gcc -m32 -c" For AIX 4.3 with the IBM compiler xlc: ./configure -cc "xlc_r -D_AIX43 -Wl,-bexpall,-brtl -qmaxmem=8192" If something goes wrong during the automatic configuration, or if the generated files cause errors later on, then look at the template files config/Makefile-templ config/m-templ.h config/s-templ.h for guidance on how to edit the generated files by hand. 2- From the top directory, do: make world This builds the OCaml bytecode compiler for the first time. This phase is fairly verbose; consider redirecting the output to a file: make world > log.world 2>&1 # in sh make world >& log.world # in csh 3- (Optional) To be sure everything works well, you can try to bootstrap the system --- that is, to recompile all OCaml sources with the newly created compiler. From the top directory, do: make bootstrap or, better: make bootstrap > log.bootstrap 2>&1 # in sh make bootstrap >& log.bootstrap # in csh The "make bootstrap" checks that the bytecode programs compiled with the new compiler are identical to the bytecode programs compiled with the old compiler. If this is the case, you can be pretty sure the system has been correctly compiled. Otherwise, this does not necessarily mean something went wrong. The best thing to do is to try a second bootstrapping phase: just do "make bootstrap" again. It will either crash almost immediately, or re-re-compile everything correctly and reach the fixpoint. 4- If your platform is supported by the native-code compiler (as reported during the autoconfiguration), you can now build the native-code compiler. From the top directory, do: make opt or: make opt > log.opt 2>&1 # in sh make opt >& log.opt # in csh 5- Compile fast versions of the OCaml compilers, by compiling them with the native-code compiler (you have only compiled them to bytecode so far). Just do: make opt.opt Later, you can compile your programs to bytecode using ocamlc.opt instead of ocamlc, and to native-code using ocamlopt.opt instead of ocamlopt. The ".opt" compilers should run faster than the normal compilers, especially on large input files, but they may take longer to start due to increased code size. If compilation times are an issue on your programs, try the ".opt" compilers to see if they make a significant difference. An alternative, and faster approach to steps 2 to 5 is make world.opt # to build using native-code compilers The result is equivalent to "make world opt opt.opt", but this may fail if anything goes wrong in native-code generation. 6- You can now install the OCaml system. This will create the following commands (in the binary directory selected during autoconfiguration): ocamlc the batch bytecode compiler ocamlopt the batch native-code compiler (if supported) ocamlrun the runtime system for the bytecode compiler ocamlyacc the parser generator ocamllex the lexer generator ocaml the interactive, toplevel-based system ocamlmktop a tool to make toplevel systems that integrate user-defined C primitives and OCaml code ocamldebug the source-level replay debugger ocamldep generator of "make" dependencies for OCaml sources ocamldoc documentation generator ocamlprof execution count profiler ocamlcp the bytecode compiler in profiling mode and also, if you built them during step 5, ocamlc.opt the batch bytecode compiler compiled with ocamlopt ocamlopt.opt the batch native-code compiler compiled with ocamlopt ocamllex.opt the lexer generator compiled with ocamlopt From the top directory, become superuser and do: umask 022 # make sure to give read & execute permission to all make install 7- Installation is complete. Time to clean up. From the toplevel directory, do "make clean". 8- (Optional) The emacs/ subdirectory contains Emacs-Lisp files for an OCaml editing mode and an interface for the debugger. To install these files, change to the emacs/ subdirectory and do make EMACSDIR= install or make install In the latter case, the destination directory defaults to the "site-lisp" directory of your Emacs installation. 9- After installation, do *not* strip the ocamldebug and ocamlbrowser executables. (These are mixed-mode executables, containing both compiled C code and OCaml bytecode; stripping erases the bytecode!) Other executables such as ocamlrun can safely be stripped. IF SOMETHING GOES WRONG: Read the "common problems" and "machine-specific hints" section at the end of this file. Check the files m.h and s.h in config/. Wrong endianness or alignment constraints in m.h will immediately crash the bytecode interpreter. If you get a "segmentation violation" signal, check the limits on the stack size and data segment size (type "limit" under csh or "ulimit -a" under bash). Make sure the limit on the stack size is at least 4M. Try recompiling the runtime system with optimizations turned off (change CFLAGS in byterun/Makefile and asmrun/Makefile). The runtime system contains some complex, atypical pieces of C code that can uncover bugs in optimizing compilers. Alternatively, try another C compiler (e.g. gcc instead of the vendor-supplied cc). You can also build a debug version of the runtime system. Go to the byterun/ directory and do "make ocamlrund". Then, copy ocamlrund to ../boot/ocamlrun, and try again. This version of the runtime system contains lots of assertions and sanity checks that could help you pinpoint the problem. COMMON PROBLEMS: * The Makefiles do not support parallel make (e.g. make -j2). Fix: do not pass the -j option to make, and be patient. * The Makefiles use the "include" directive, which is not supported by all versions of make. Use GNU make if this is a problem. * The Makefiles assume that make executes commands by calling /bin/sh. They won't work if /bin/csh is called instead. You may have to unset the SHELL environment variable, or set it to /bin/sh. * On some systems, localization causes build problems. You should try to set the C locale (export LC_ALL=C) before compiling if you have strange errors while compiling OCaml. * gcc 2.7.2.1 generates incorrect code for the runtime system in -O mode on some Intel x86 platforms (e.g. Linux RedHat 4.1 and 4.2). If this causes a problem, the solution is to upgrade to 2.7.2.3 or above. * Some versions of gcc 2.96 for the Intel x86 (as found in RedHat 7.2, Mandrake 8.0 and Mandrake 8.1) generates incorrect code for the runtime system. The "configure" script tries to work around this problem. * On HP 9000/700 machines under HP/UX 9. Some versions of cc are unable to compile correctly the runtime system (wrong code is generated for (x - y) where x is a pointer and y an integer). Fix: use gcc. mingw-ocaml/ocaml/jocparsing/0000755000175000017500000000000012124403241015615 5ustar tootstootsmingw-ocaml/ocaml/jocparsing/.gitignore0000644000175000017500000000000012124403241017573 0ustar tootstootsmingw-ocaml/ocaml/testsuite/0000755000175000017500000000000012124403241015507 5ustar tootstootsmingw-ocaml/ocaml/testsuite/.ignore0000644000175000017500000000000512124403241016766 0ustar tootstoots_log mingw-ocaml/ocaml/testsuite/Makefile0000644000175000017500000000463612124403241017160 0ustar tootstoots# $Id$ BASEDIR=${PWD} NO_PRINT=`($(MAKE) empty --no-print-directory > /dev/null 2>&1) && echo '--no-print-directory' || echo ''` default: @echo "Available targets:" @echo " all launches all tests" @echo " list FILE=f launches the tests referenced in file f (one path per line)" @echo " one DIR=p launches the tests located in path p" @echo " promote DIR=p promotes the reference files for the tests located in path p" @echo " lib builds library modules" @echo " clean deletes generated files" @echo " report prints the report for the last execution, if any" all: lib @for dir in tests/*; do \ $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \ done 2>&1 | tee _log @$(MAKE) report list: lib @if [ -z $(FILE) ]; then echo "No value set for variable 'FILE'."; exit 1; fi @if [ ! -f $(FILE) ]; then echo "File '$(FILE)' does not exist."; exit 1; fi @while read LINE; do \ $(MAKE) $(NO_PRINT) exec-one DIR=$$LINE; \ done < $(FILE) 2>&1 | tee _log @$(MAKE) report one: lib @if [ -z $(DIR) ]; then echo "No value set for variable 'DIR'."; exit 1; fi @if [ ! -d $(DIR) ]; then echo "Directory '$(DIR)' does not exist."; exit 1; fi @$(MAKE) $(NO_PRINT) exec-one DIR=$(DIR) exec-one: @if [ ! -f $(DIR)/Makefile ]; then \ for dir in $(DIR)/*; do \ if [ -d $$dir ]; then \ $(MAKE) exec-one DIR=$$dir; \ fi; \ done; \ else \ echo "Running tests from '$$DIR' ..."; \ (cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR)); \ fi promote: FORCE @if [ -z $(DIR) ]; then echo "No value set for variable 'DIR'."; exit 1; fi @if [ ! -d $(DIR) ]; then echo "Directory '$(DIR)' does not exist."; exit 1; fi @(cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) promote) lib: FORCE @(cd lib && $(MAKE) -s BASEDIR=$(BASEDIR)) clean: FORCE @(cd lib && $(MAKE) BASEDIR=$(BASEDIR) clean) @for file in `find interactive tests -name Makefile`; do \ (cd `dirname $$file` && $(MAKE) BASEDIR=$(BASEDIR) clean); \ done report: FORCE @if [ ! -f _log ]; then echo "No '_log' file."; exit 1; fi @echo '' @echo 'Summary:' @echo ' ' `grep 'passed$$' _log | wc -l` 'test(s) passed' @echo ' ' `grep 'failed$$' _log | wc -l` 'test(s) failed' @echo ' ' `grep '^Error' _log | wc -l` 'compilation error(s)' @echo ' ' `grep '^Warning' _log | wc -l` 'compilation warning(s)' @echo ' ' `grep '^make\[2\]: ' _log | wc -l` 'makefile error(s)' empty: FORCE FORCE: mingw-ocaml/ocaml/testsuite/external/0000755000175000017500000000000012124403241017331 5ustar tootstootsmingw-ocaml/ocaml/testsuite/external/.gitignore0000644000175000017500000000000012124403241021307 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/0000755000175000017500000000000012124403241016651 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-gadts/0000755000175000017500000000000012124403241021263 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-gadts/term-conv.ml0000644000175000017500000001064512124403241023535 0ustar tootstoots(* HOAS to de Bruijn, by chak *) (* http://www.cse.unsw.edu.au/~chak/haskell/term-conv/ *) module Typeable = struct type 'a ty = | Int: int ty | String: string ty | List: 'a ty -> 'a list ty | Pair: ('a ty * 'b ty) -> ('a * 'b) ty | Fun: ('a ty * 'b ty) -> ('a -> 'b) ty type (_,_) eq = Eq : ('a,'a) eq exception CastFailure let rec check_eq : type t t'. t ty -> t' ty -> (t,t') eq = fun t t' -> match t, t' with | Int, Int -> Eq | String, String -> Eq | List t, List t' -> (match check_eq t t' with Eq -> Eq) | Pair (t1,t2), Pair (t1',t2') -> (match check_eq t1 t1', check_eq t2 t2' with Eq, Eq -> Eq) | Fun (t1,t2), Fun (t1',t2') -> (match check_eq t1 t1', check_eq t2 t2' with Eq, Eq -> Eq) | _ -> raise CastFailure let gcast : type t t'. t ty -> t' ty -> t -> t' = fun t t' x -> match check_eq t t' with Eq -> x end;; module HOAS = struct open Typeable type _ term = | Tag : 't ty * int -> 't term | Con : 't -> 't term | Lam : 's ty * ('s term -> 't term) -> ('s -> 't) term | App : ('s -> 't) term * 's term -> 't term let rec intp : type t. t term -> t = function | Tag (_, ix) -> failwith "HOAS.intp" | Con v -> v | Lam (_, f) -> fun x -> intp (f (Con x)) | App (f, a) -> intp f (intp a) end;; module DeBruijn = struct type ('env,'t) ix = | ZeroIx : ('env * 't, 't) ix | SuccIx : ('env,'t) ix -> ('env * 's, 't) ix let rec to_int : type env t. (env,t) ix -> int = function | ZeroIx -> 0 | SuccIx n -> to_int n + 1 type ('env,'t) term = | Var : ('env,'t) ix -> ('env,'t) term | Con : 't -> ('env,'t) term | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term type _ stack = | Empty : unit stack | Push : 'env stack * 't -> ('env * 't) stack let rec prj : type env t. (env,t) ix -> env stack -> t = fun i s -> match i, s with | ZeroIx, Push (s,v) -> v | SuccIx i, Push (s,_) -> prj i s let rec intp : type env t. (env,t) term -> env stack -> t = fun t s -> match t with | Var ix -> prj ix s | Con v -> v | Lam b -> fun x -> intp b (Push (s, x)) | App(f,a) -> intp f s (intp a s) end;; module Convert = struct type (_,_) layout = | EmptyLayout : ('env, unit) layout | PushLayout : 't Typeable.ty * ('env,'env') layout * ('env,'t) DeBruijn.ix -> ('env,'env' * 't) layout let rec size : type env env'. (env,env') layout -> int = function | EmptyLayout -> 0 | PushLayout (_, lyt, _) -> size lyt + 1 let rec inc : type env env'. (env,env') layout -> (env * 't, env') layout = function | EmptyLayout -> EmptyLayout | PushLayout (t, lyt, ix) -> PushLayout (t, inc lyt, DeBruijn.SuccIx ix) let rec prj : type env env' t. t Typeable.ty -> int -> (env,env') layout -> (env,t) DeBruijn.ix = fun t n -> function | EmptyLayout -> failwith "Convert.prj: internal error" | PushLayout (t', l, ix) -> if n = 0 then match Typeable.check_eq t t' with Typeable.Eq -> ix else prj t (n-1) l let rec cvt : type env t. (env,env) layout -> t HOAS.term -> (env,t) DeBruijn.term = fun lyt -> function | HOAS.Tag (t, sz) -> DeBruijn.Var (prj t (size lyt - sz -1) lyt) | HOAS.Con v -> DeBruijn.Con v | HOAS.Lam (t, f) -> let lyt' = PushLayout (t, inc lyt, DeBruijn.ZeroIx) in DeBruijn.Lam (cvt lyt' (f (HOAS.Tag (t, size lyt)))) | HOAS.App (f, a) -> DeBruijn.App (cvt lyt f, cvt lyt a) let convert t = cvt EmptyLayout t end;; module Main = struct open HOAS let i t = Lam (t, fun x -> x) let zero t = Lam (Typeable.Fun(t,t), fun f -> Lam(t, fun x -> x)) let one t = Lam (Typeable.Fun(t,t), fun f -> Lam(t, fun x -> App (f, x))) let two t = Lam (Typeable.Fun(t,t), fun f -> Lam(t, fun x -> App (f, App (f, x)))) let three t = Lam (Typeable.Fun(t,t), fun f -> Lam(t, fun x -> App (f, App (f, App (f, x))))) let plus t = let t1 = Typeable.Fun(t,t) in let t2 = Typeable.Fun(t1,t1) in Lam (t2, fun m -> Lam (t2, fun n -> Lam (t1, fun f -> Lam(t, fun x -> App(App(m,f), App(App(n,f),x)))))) let plus_2_3 t = App (App (plus t, two t), three t) open Convert let i' = convert (i Typeable.Int) let plus_2_3' = convert (plus_2_3 Typeable.Int) let eval_plus_2_3' = DeBruijn.intp plus_2_3' DeBruijn.Empty succ 0 end;; mingw-ocaml/ocaml/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference0000644000175000017500000001650012124403241030516 0ustar tootstoots # type 'a ty = Int : int ty | String : string ty | List : 'a ty -> 'a list ty | Pair : ('a ty * 'b ty) -> ('a * 'b) ty # type variant = VInt of int | VString of string | VList of variant list | VPair of variant * variant val variantize : 't ty -> 't -> variant = exception VariantMismatch val devariantize : 't ty -> variant -> 't = # type 'a ty = Int : int ty | String : string ty | List : 'a ty -> 'a list ty | Pair : ('a ty * 'b ty) -> ('a * 'b) ty | Record : 'a record -> 'a ty and 'a record = { path : string; fields : 'a field_ list; } and 'a field_ = Field : ('a, 'b) field -> 'a field_ and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; } # type variant = VInt of int | VString of string | VList of variant list | VPair of variant * variant | VRecord of (string * variant) list val variantize : 't ty -> 't -> variant = # type 'a ty = Int : int ty | String : string ty | List : 'a ty -> 'a list ty | Pair : ('a ty * 'b ty) -> ('a * 'b) ty | Record : ('a, 'builder) record -> 'a ty and ('a, 'builder) record = { path : string; fields : ('a, 'builder) field list; create_builder : unit -> 'builder; of_builder : 'builder -> 'a; } and ('a, 'builder) field = Field : ('a, 'builder, 'b) field_ -> ('a, 'builder) field and ('a, 'builder, 'b) field_ = { label : string; field_type : 'b ty; get : 'a -> 'b; set : 'builder -> 'b -> unit; } val devariantize : 't ty -> variant -> 't = # type my_record = { a : int; b : string list; } val my_record : my_record ty = Record {path = "My_module.my_record"; fields = [Field {label = "a"; field_type = Int; get = ; set = }; Field {label = "b"; field_type = List String; get = ; set = }]; create_builder = ; of_builder = } # type noarg = Noarg type (_, _) ty = Int : (int, 'c) ty | String : (string, 'd) ty | List : ('a, 'e) ty -> ('a list, 'e) ty | Option : ('a, 'e) ty -> ('a option, 'e) ty | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty | Var : ('a, 'a -> 'e) ty | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty | Sum : ('a, 'e, 'b) ty_sum -> ('a, 'e) ty and ('a, 'e, 'b) ty_sum = { sum_proj : 'a -> string * 'e ty_dyn option; sum_cases : (string * ('e, 'b) ty_case) list; sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a; } and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn and (_, _) ty_sel = Thd : ('a -> 'b, 'a) ty_sel | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel and (_, _) ty_case = TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case # type _ ty_env = Enil : unit ty_env | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env # type (_, _) eq = Eq : ('a, 'a) eq val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = val get_case : ('b, 'a) ty_sel -> (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = # type variant = VInt of int | VString of string | VList of variant list | VOption of variant option | VPair of variant * variant | VConv of string * variant | VSum of string * variant option val may_map : ('a -> 'b) -> 'a option -> 'b option = val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = # val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = # val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = # val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty = # val v : ([ `A of (int * 'a) option ] as 'a) -> variant = # val x : variant = VConv ("`A", VOption (Some (VPair (VInt 1, VConv ("`A", VOption (Some (VPair (VInt 2, VConv ("`A", VOption None))))))))) # val triple : ('a, 'b) ty -> ('c, 'b) ty -> ('d, 'b) ty -> ('a * 'c * 'd, 'b) ty = val v : variant = VConv ("Triple", VPair (VString "A", VPair (VInt 2, VInt 3))) # val ty_abc : ([ `A of int | `B of string | `C ], 'a) ty = Sum {sum_proj = ; sum_cases = [("A", TCarg (Thd, Int)); ("B", TCarg (Ttl Thd, String)); ("C", TCnoarg (Ttl (Ttl Thd)))]; sum_inj = } # val a : [ `A of int | `B of string | `C ] = `A 3 type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ] val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = val v : variant = VSum ("Cons", Some (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None))))))) # type (_, _) ty = Int : (int, 'c) ty | String : (string, 'd) ty | List : ('a, 'e) ty -> ('a list, 'e) ty | Option : ('a, 'e) ty -> ('a option, 'e) ty | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty | Var : ('a, 'a -> 'e) ty | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty | Sum : ('a -> string * 'e ty_dyn option) * (string * 'e ty_dyn option -> 'a) -> ('a, 'e) ty and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (, ) # Characters 327-344: | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p))) ^^^^^^^^^^^^^^^^^ Error: This pattern matches values of type a * a vlist but a pattern was expected which matches values of type ex#46 = ex#47 * ex#48 # type (_, _) ty = Int : (int, 'd) ty | String : (string, 'f) ty | List : ('a, 'e) ty -> ('a list, 'e) ty | Option : ('a, 'e) ty -> ('a option, 'e) ty | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty | Var : ('a, 'a -> 'e) ty | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty | Sum : < cases : (string * ('e, 'b) ty_case) list; inj : 'c. ('b, 'c) ty_sel * 'c -> 'a; proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn and (_, _) ty_sel = Thd : ('a -> 'b, 'a) ty_sel | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel and (_, _) ty_case = TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case # val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ] val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = # * * * * * * * * * mingw-ocaml/ocaml/testsuite/tests/typing-gadts/test.ml.principal.reference0000644000175000017500000003103612124403241026514 0ustar tootstoots # module Exp : sig type _ t = IntLit : int -> int t | BoolLit : bool -> bool t | Pair : 'a t * 'b t -> ('a * 'b) t | App : ('a -> 'b) t * 'a t -> 'b t | Abs : ('a -> 'b) -> ('a -> 'b) t val eval : 's t -> 's val discern : 'a t -> int end # module List : sig type zero type _ t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t val head : ('a * 'b) t -> 'a val tail : ('a * 'b) t -> 'b t val length : 'a t -> int end # Characters 196-224: ......function | C2 x -> x Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: C1 _ Characters 458-529: ......function | Foo _ , Foo _ -> true | Bar _, Bar _ -> true Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (Bar _, Foo _) module Nonexhaustive : sig type 'a u = C1 : int -> int u | C2 : bool -> bool u type 'a v = C1 : int -> int v val unexhaustive : 's u -> 's module M : sig type t type u end type 'a t = Foo : M.t -> M.t t | Bar : M.u -> M.u t val same_type : 's t * 's t -> bool end # module Exhaustive : sig type t = int type u = bool type 'a v = Foo : t -> t v | Bar : u -> u v val same_type : 's v * 's v -> bool end # Characters 118-119: let eval (D x) = x ^ Error: This expression has type ex#16 t but an expression was expected of type ex#16 t The type constructor ex#16 would escape its scope # Characters 174-175: C -> ^ Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t # Characters 178-186: | (IntLit _ | BoolLit _) -> () ^^^^^^^^ Error: This pattern matches values of type int t but a pattern was expected which matches values of type s t # Characters 224-237: | `A, BoolLit _ -> () ^^^^^^^^^^^^^ Error: This pattern matches values of type ([? `A ] as 'a) * bool t but a pattern was expected which matches values of type 'a * int t # Characters 299-300: | BoolLit b -> b ^ Error: This expression has type bool but an expression was expected of type s # Characters 87-88: let f = function A -> 1 | B -> 2 ^ Error: This pattern matches values of type b but a pattern was expected which matches values of type a # type _ t = Int : int t # val ky : 'a -> 'a -> 'a = # val test : 'a t -> 'a = # val test : 'a t -> int = # Characters 49-61: function Int -> ky (1 : a) 1 (* fails *) ^^^^^^^^^^^^ Error: This expression has type a = int but an expression was expected of type a = int This instance of int is ambiguous: it would escape the scope of its equation # Characters 70-82: let r = match x with Int -> ky (1 : a) 1 (* fails *) ^^^^^^^^^^^^ Error: This expression has type a = int but an expression was expected of type a = int This instance of int is ambiguous: it would escape the scope of its equation # Characters 69-81: let r = match x with Int -> ky 1 (1 : a) (* fails *) ^^^^^^^^^^^^ Error: This expression has type a = int but an expression was expected of type a = int This instance of int is ambiguous: it would escape the scope of its equation # val test : 'a t -> int = # val test : 'a t -> 'a = # val test : 'a t -> int = # val test : 'a t -> 'a = # val test2 : 'a t -> 'a option = # val test2 : 'a t -> 'a option = # val test2 : 'a t -> 'a option = # Characters 152-154: begin match x with Int -> u := Some 1; r := !u end; ^^ Error: This expression has type int option but an expression was expected of type a option Type int is not compatible with type a = int This instance of int is ambiguous: it would escape the scope of its equation # val test2 : 'a t -> 'a option = # val test2 : 'a t -> 'a option = # Characters 100-101: match v with Int -> let y = either 1 x in y ^ Error: This expression has type a = int but an expression was expected of type a = int This instance of int is ambiguous: it would escape the scope of its equation # val f : 'a t -> 'a -> 'a = # val f : 'a t -> 'a -> 'a = # val f : 'a t -> 'a -> 'a = # val f : 'a t -> 'a -> 'a = # val f : 'a t -> 'a -> 'a = # Characters 136-137: let module M = struct type b = a let z = (y : b) end ^ Error: This expression has type a = int but an expression was expected of type b = int This instance of int is ambiguous: it would escape the scope of its equation # val f : 'a t -> int -> int = # type _ h = Has_m : < m : int > h | Has_b : < b : bool > h val f : 'a h -> 'a = # type _ j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j val f : 'a j -> 'a = # type (_, _) eq = Eq : ('a, 'a) eq # Characters 5-91: ....f : type a b. (a,b) eq -> ( as 'c) -> ( as 'c) = fun Eq o -> o Error: The universal type variable 'b cannot be generalized: it is already bound to another variable. # Characters 74-75: fun Eq o -> o ^ Error: This expression has type < m : a; .. > but an expression was expected of type < m : b; .. > Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation # Characters 97-98: match eq with Eq -> o ;; (* should fail *) ^ Error: This expression has type < m : a; .. > but an expression was expected of type < m : b; .. > Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation # val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = # val int_of_bool : (bool, int) eq = Eq # val x : < m : bool > = # val y : < m : bool > * < m : int > = (, ) # val f : ('a, int) eq -> < m : 'a > -> bool = # Characters 146-147: let r : < m : b > = match eq with Eq -> o in (* fail with principal *) ^ Error: This expression has type < m : a > but an expression was expected of type < m : b > Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation # Characters 118-119: let r : < m : b > = match eq with Eq -> o in (* fail *) ^ Error: This expression has type < m : a; .. > but an expression was expected of type < m : b > Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation # Characters 74-75: fun Eq o -> o ;; (* fail *) ^ Error: This expression has type [> `A of a ] but an expression was expected of type [> `A of b ] Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation # Characters 97-98: match eq with Eq -> v ;; (* should fail *) ^ Error: This expression has type [> `A of a ] but an expression was expected of type [> `A of b ] Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation # Characters 5-85: ....f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] = fun Eq o -> o.............. Error: This definition has type ('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c # val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = # val f : ('a, int) eq -> [ `A of 'a ] -> bool = # Characters 166-167: let r : [`A of b | `B] = match eq with Eq -> o in (* fail with principal *) ^ Error: This expression has type [ `A of a | `B ] but an expression was expected of type [ `A of b | `B ] Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation # Characters 131-132: let r : [`A of b | `B] = match eq with Eq -> o in (* fail *) ^ Error: This expression has type [> `A of a | `B ] but an expression was expected of type [ `A of b | `B ] Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation # type 'a t = A of int | B of bool | C of float | D of 'a type _ ty = TE : 'a ty -> 'a array ty | TA : int ty | TB : bool ty | TC : float ty | TD : string -> bool ty val f : 'a ty -> 'a t -> int = # Characters 51-202: ..match x, y with | _, A z -> z | _, B z -> if z then 1 else 2 | _, C z -> truncate z | TE TC, D [|1.0|] -> 14 | TA, D 0 -> -1 | TA, D z -> z Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (TE TC, D [| |]) val f : 'a ty -> 'a t -> int = # Characters 147-154: | D [|1.0|], TE TC -> 14 ^^^^^^^ Error: This pattern matches values of type 'a array but a pattern was expected which matches values of type a # Characters 259-266: | {left=TE TC; right=D [|1.0|]} -> 14 ^^^^^^^ Error: This pattern matches values of type 'a array but a pattern was expected which matches values of type a # Characters 92-334: ..match {left=x; right=y} with | {left=_; right=A z} -> z | {left=_; right=B z} -> if z then 1 else 2 | {left=_; right=C z} -> truncate z | {left=TE TC; right=D [|1.0|]} -> 14 | {left=TA; right=D 0} -> -1 | {left=TA; right=D z} -> z Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: {left=TE TC; right=D [| |]} type ('a, 'b) pair = { left : 'a; right : 'b; } val f : 'a ty -> 'a t -> int = # module M : sig type 'a t val eq : ('a t, 'b t) eq end # Characters 69-71: function Eq -> Eq (* fail *) ^^ Error: This expression has type (a, a) eq but an expression was expected of type (a, b) eq # val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = # val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = # type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t val f : 'a t -> 'a = # - : [ `A | `B ] = `A # type _ int_foo = IF_constr : < foo : int; .. > int_foo type _ int_bar = IB_constr : < bar : int; .. > int_bar # Characters 98-99: (x:) ^ Error: This expression has type t = < foo : int; .. > but an expression was expected of type < foo : int > Type ex#20 = < bar : int; .. > is not compatible with type < > The second object type has no method bar # Characters 98-99: (x:) ^ Error: This expression has type t = < foo : int; .. > but an expression was expected of type < bar : int; foo : int > Type ex#22 = < bar : int; .. > is not compatible with type < bar : int > # Characters 98-99: (x:) ^ Error: This expression has type < bar : int; foo : int; .. > as 'a but an expression was expected of type 'a The type constructor ex#25 would escape its scope # val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = # val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = # type 'a ty = Int : int -> int ty # val f : 'a ty -> 'a = # val g : 'a ty -> 'a = # mingw-ocaml/ocaml/testsuite/tests/typing-gadts/pr5332.ml0000644000175000017500000000063712124403241022561 0ustar tootstootstype ('env, 'a) var = | Zero : ('a * 'env, 'a) var | Succ : ('env, 'a) var -> ('b * 'env, 'a) var ;; type ('env, 'a) typ = | Tint : ('env, int) typ | Tbool : ('env, bool) typ | Tvar : ('env, 'a) var -> ('env, 'a) typ ;; let f : type env a. (env, a) typ -> (env, a) typ -> int = fun ta tb -> match ta, tb with | Tint, Tint -> 0 | Tbool, Tbool -> 1 | Tvar var, tb -> 2 ;; let x = f Tint (Tvar Zero) ;; mingw-ocaml/ocaml/testsuite/tests/typing-gadts/term-conv.ml.reference0000644000175000017500000000541112124403241025465 0ustar tootstoots # module Typeable : sig type 'a ty = Int : int ty | String : string ty | List : 'a ty -> 'a list ty | Pair : ('a ty * 'b ty) -> ('a * 'b) ty | Fun : ('a ty * 'b ty) -> ('a -> 'b) ty type (_, _) eq = Eq : ('a, 'a) eq exception CastFailure val check_eq : 't ty -> 't' ty -> ('t, 't') eq val gcast : 't ty -> 't' ty -> 't -> 't' end # module HOAS : sig type _ term = Tag : 't Typeable.ty * int -> 't term | Con : 't -> 't term | Lam : 's Typeable.ty * ('s term -> 't term) -> ('s -> 't) term | App : ('s -> 't) term * 's term -> 't term val intp : 't term -> 't end # module DeBruijn : sig type ('env, 't) ix = ZeroIx : ('env * 't, 't) ix | SuccIx : ('env, 't) ix -> ('env * 's, 't) ix val to_int : ('env, 't) ix -> int type ('env, 't) term = Var : ('env, 't) ix -> ('env, 't) term | Con : 't -> ('env, 't) term | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term type _ stack = Empty : unit stack | Push : 'env stack * 't -> ('env * 't) stack val prj : ('env, 't) ix -> 'env stack -> 't val intp : ('env, 't) term -> 'env stack -> 't end # module Convert : sig type (_, _) layout = EmptyLayout : ('env, unit) layout | PushLayout : 't Typeable.ty * ('env, 'env') layout * ('env, 't) DeBruijn.ix -> ('env, 'env' * 't) layout val size : ('env, 'env') layout -> int val inc : ('env, 'env') layout -> ('env * 't, 'env') layout val prj : 't Typeable.ty -> int -> ('env, 'env') layout -> ('env, 't) DeBruijn.ix val cvt : ('env, 'env) layout -> 't HOAS.term -> ('env, 't) DeBruijn.term val convert : 'a HOAS.term -> (unit, 'a) DeBruijn.term end # module Main : sig val i : 'a Typeable.ty -> ('a -> 'a) HOAS.term val zero : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term val one : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term val two : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term val three : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term val plus : 'a Typeable.ty -> ((('a -> 'a) -> 'a -> 'a) -> (('a -> 'a) -> 'a -> 'a) -> ('a -> 'a) -> 'a -> 'a) HOAS.term val plus_2_3 : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term val i' : (unit, int -> int) DeBruijn.term val plus_2_3' : (unit, (int -> int) -> int -> int) DeBruijn.term val eval_plus_2_3' : int end # mingw-ocaml/ocaml/testsuite/tests/typing-gadts/Makefile0000644000175000017500000000015212124403241022721 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-gadts/pr5689.ml.principal.reference0000644000175000017500000000241612124403241026512 0ustar tootstoots # type inkind = [ `Link | `Nonlink ] type _ inline_t = Text : string -> [< inkind > `Nonlink ] inline_t | Bold : 'a inline_t list -> 'a inline_t | Link : string -> [< inkind > `Link ] inline_t | Mref : string * [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t # val uppercase : 'a inline_t list -> 'a inline_t list = # type ast_t = Ast_Text of string | Ast_Bold of ast_t list | Ast_Link of string | Ast_Mref of string * ast_t list # val inlineseq_from_astseq : ast_t list -> inkind inline_t list = # type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp # val inlineseq_from_astseq : ast_t list -> inkind inline_t list = # type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2 # Characters 272-279: | (Kind Maylink, Ast_Link lnk) -> Link lnk ^^^^^^^ Error: This pattern matches values of type inkind linkp but a pattern was expected which matches values of type ([< inkind ] as 'a) linkp Type inkind = [ `Link | `Nonlink ] is not compatible with type 'a = [< `Link | `Nonlink ] Types for tag `Nonlink are incompatible # mingw-ocaml/ocaml/testsuite/tests/typing-gadts/pr5689.ml.reference0000644000175000017500000000241612124403241024532 0ustar tootstoots # type inkind = [ `Link | `Nonlink ] type _ inline_t = Text : string -> [< inkind > `Nonlink ] inline_t | Bold : 'a inline_t list -> 'a inline_t | Link : string -> [< inkind > `Link ] inline_t | Mref : string * [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t # val uppercase : 'a inline_t list -> 'a inline_t list = # type ast_t = Ast_Text of string | Ast_Bold of ast_t list | Ast_Link of string | Ast_Mref of string * ast_t list # val inlineseq_from_astseq : ast_t list -> inkind inline_t list = # type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp # val inlineseq_from_astseq : ast_t list -> inkind inline_t list = # type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2 # Characters 272-279: | (Kind Maylink, Ast_Link lnk) -> Link lnk ^^^^^^^ Error: This pattern matches values of type inkind linkp but a pattern was expected which matches values of type ([< inkind ] as 'a) linkp Type inkind = [ `Link | `Nonlink ] is not compatible with type 'a = [< `Link | `Nonlink ] Types for tag `Nonlink are incompatible # mingw-ocaml/ocaml/testsuite/tests/typing-gadts/yallop_bugs.ml.reference0000644000175000017500000000216512124403241026076 0ustar tootstoots # Characters 240-248: let f (Refl : (a T.t, b T.t) eq) = (x :> b) ^^^^^^^^ Error: Type a is not a subtype of b # Characters 36-67: type (_, +_) eq = Refl : ('a, 'a) eq ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In this GADT definition, the variance of some parameter cannot be checked # Characters 115-175: .......................................function | BoolLit, false -> false | IntLit , 6 -> false Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (IntLit, 0) type _ t = IntLit : int t | BoolLit : bool t val check : 's t * 's -> bool = # Characters 91-180: .............................................function | {fst = BoolLit; snd = false} -> false | {fst = IntLit ; snd = 6} -> false Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: {fst=IntLit; snd=0} type ('a, 'b) pair = { fst : 'a; snd : 'b; } val check : ('s t, 's) pair -> bool = # mingw-ocaml/ocaml/testsuite/tests/typing-gadts/test.ml.reference0000644000175000017500000002756612124403241024551 0ustar tootstoots # module Exp : sig type _ t = IntLit : int -> int t | BoolLit : bool -> bool t | Pair : 'a t * 'b t -> ('a * 'b) t | App : ('a -> 'b) t * 'a t -> 'b t | Abs : ('a -> 'b) -> ('a -> 'b) t val eval : 's t -> 's val discern : 'a t -> int end # module List : sig type zero type _ t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t val head : ('a * 'b) t -> 'a val tail : ('a * 'b) t -> 'b t val length : 'a t -> int end # Characters 196-224: ......function | C2 x -> x Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: C1 _ Characters 458-529: ......function | Foo _ , Foo _ -> true | Bar _, Bar _ -> true Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (Bar _, Foo _) module Nonexhaustive : sig type 'a u = C1 : int -> int u | C2 : bool -> bool u type 'a v = C1 : int -> int v val unexhaustive : 's u -> 's module M : sig type t type u end type 'a t = Foo : M.t -> M.t t | Bar : M.u -> M.u t val same_type : 's t * 's t -> bool end # module Exhaustive : sig type t = int type u = bool type 'a v = Foo : t -> t v | Bar : u -> u v val same_type : 's v * 's v -> bool end # Characters 118-119: let eval (D x) = x ^ Error: This expression has type ex#16 t but an expression was expected of type ex#16 t The type constructor ex#16 would escape its scope # Characters 174-175: C -> ^ Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t # Characters 178-186: | (IntLit _ | BoolLit _) -> () ^^^^^^^^ Error: This pattern matches values of type int t but a pattern was expected which matches values of type s t # Characters 224-237: | `A, BoolLit _ -> () ^^^^^^^^^^^^^ Error: This pattern matches values of type ([? `A ] as 'a) * bool t but a pattern was expected which matches values of type 'a * int t # module Propagation : sig type _ t = IntLit : int -> int t | BoolLit : bool -> bool t val check : 's t -> 's end # Characters 87-88: let f = function A -> 1 | B -> 2 ^ Error: This pattern matches values of type b but a pattern was expected which matches values of type a # type _ t = Int : int t # val ky : 'a -> 'a -> 'a = # val test : 'a t -> 'a = # val test : 'a t -> int = # Characters 49-61: function Int -> ky (1 : a) 1 (* fails *) ^^^^^^^^^^^^ Error: This expression has type a = int but an expression was expected of type a = int This instance of int is ambiguous: it would escape the scope of its equation # Characters 70-82: let r = match x with Int -> ky (1 : a) 1 (* fails *) ^^^^^^^^^^^^ Error: This expression has type a = int but an expression was expected of type a = int This instance of int is ambiguous: it would escape the scope of its equation # Characters 69-81: let r = match x with Int -> ky 1 (1 : a) (* fails *) ^^^^^^^^^^^^ Error: This expression has type a = int but an expression was expected of type a = int This instance of int is ambiguous: it would escape the scope of its equation # val test : 'a t -> int = # val test : 'a t -> 'a = # val test : 'a t -> int = # val test : 'a t -> 'a = # val test2 : 'a t -> 'a option = # val test2 : 'a t -> 'a option = # val test2 : 'a t -> 'a option = # Characters 152-154: begin match x with Int -> u := Some 1; r := !u end; ^^ Error: This expression has type int option but an expression was expected of type a option Type int is not compatible with type a = int This instance of int is ambiguous: it would escape the scope of its equation # val test2 : 'a t -> 'a option = # val test2 : 'a t -> 'a option = # Characters 100-101: match v with Int -> let y = either 1 x in y ^ Error: This expression has type a = int but an expression was expected of type a = int This instance of int is ambiguous: it would escape the scope of its equation # val f : 'a t -> 'a -> 'a = # val f : 'a t -> 'a -> 'a = # val f : 'a t -> 'a -> 'a = # val f : 'a t -> 'a -> 'a = # val f : 'a t -> 'a -> 'a = # Characters 136-137: let module M = struct type b = a let z = (y : b) end ^ Error: This expression has type a = int but an expression was expected of type b = int This instance of int is ambiguous: it would escape the scope of its equation # val f : 'a t -> int -> int = # type _ h = Has_m : < m : int > h | Has_b : < b : bool > h val f : 'a h -> 'a = # type _ j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j val f : 'a j -> 'a = # type (_, _) eq = Eq : ('a, 'a) eq # Characters 5-91: ....f : type a b. (a,b) eq -> ( as 'c) -> ( as 'c) = fun Eq o -> o Error: The universal type variable 'b cannot be generalized: it is already bound to another variable. # Characters 74-75: fun Eq o -> o ^ Error: This expression has type < m : a; .. > but an expression was expected of type < m : b; .. > Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation # Characters 97-98: match eq with Eq -> o ;; (* should fail *) ^ Error: This expression has type < m : a; .. > but an expression was expected of type < m : b; .. > Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation # val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = # val int_of_bool : (bool, int) eq = Eq # val x : < m : bool > = # val y : < m : bool > * < m : int > = (, ) # val f : ('a, int) eq -> < m : 'a > -> bool = # val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = # Characters 118-119: let r : < m : b > = match eq with Eq -> o in (* fail *) ^ Error: This expression has type < m : a; .. > but an expression was expected of type < m : b > Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation # Characters 74-75: fun Eq o -> o ;; (* fail *) ^ Error: This expression has type [> `A of a ] but an expression was expected of type [> `A of b ] Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation # Characters 97-98: match eq with Eq -> v ;; (* should fail *) ^ Error: This expression has type [> `A of a ] but an expression was expected of type [> `A of b ] Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation # Characters 5-85: ....f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] = fun Eq o -> o.............. Error: This definition has type ('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c # val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = # val f : ('a, int) eq -> [ `A of 'a ] -> bool = # val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = # Characters 131-132: let r : [`A of b | `B] = match eq with Eq -> o in (* fail *) ^ Error: This expression has type [> `A of a | `B ] but an expression was expected of type [ `A of b | `B ] Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation # type 'a t = A of int | B of bool | C of float | D of 'a type _ ty = TE : 'a ty -> 'a array ty | TA : int ty | TB : bool ty | TC : float ty | TD : string -> bool ty val f : 'a ty -> 'a t -> int = # Characters 51-202: ..match x, y with | _, A z -> z | _, B z -> if z then 1 else 2 | _, C z -> truncate z | TE TC, D [|1.0|] -> 14 | TA, D 0 -> -1 | TA, D z -> z Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (TE TC, D [| |]) val f : 'a ty -> 'a t -> int = # Characters 147-154: | D [|1.0|], TE TC -> 14 ^^^^^^^ Error: This pattern matches values of type 'a array but a pattern was expected which matches values of type a # Characters 259-266: | {left=TE TC; right=D [|1.0|]} -> 14 ^^^^^^^ Error: This pattern matches values of type 'a array but a pattern was expected which matches values of type a # Characters 92-334: ..match {left=x; right=y} with | {left=_; right=A z} -> z | {left=_; right=B z} -> if z then 1 else 2 | {left=_; right=C z} -> truncate z | {left=TE TC; right=D [|1.0|]} -> 14 | {left=TA; right=D 0} -> -1 | {left=TA; right=D z} -> z Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: {left=TE TC; right=D [| |]} type ('a, 'b) pair = { left : 'a; right : 'b; } val f : 'a ty -> 'a t -> int = # module M : sig type 'a t val eq : ('a t, 'b t) eq end # Characters 69-71: function Eq -> Eq (* fail *) ^^ Error: This expression has type (a, a) eq but an expression was expected of type (a, b) eq # val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = # val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = # type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t val f : 'a t -> 'a = # - : [ `A | `B ] = `A # type _ int_foo = IF_constr : < foo : int; .. > int_foo type _ int_bar = IB_constr : < bar : int; .. > int_bar # Characters 98-99: (x:) ^ Error: This expression has type t = < foo : int; .. > but an expression was expected of type < foo : int > Type ex#20 = < bar : int; .. > is not compatible with type < > The second object type has no method bar # Characters 98-99: (x:) ^ Error: This expression has type t = < foo : int; .. > but an expression was expected of type < bar : int; foo : int > Type ex#22 = < bar : int; .. > is not compatible with type < bar : int > # Characters 98-99: (x:) ^ Error: This expression has type < bar : int; foo : int; .. > as 'a but an expression was expected of type 'a The type constructor ex#25 would escape its scope # val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = # val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = # type 'a ty = Int : int -> int ty # val f : 'a ty -> 'a = # val g : 'a ty -> 'a = # mingw-ocaml/ocaml/testsuite/tests/typing-gadts/omega07.ml.reference0000644000175000017500000003115512124403241025016 0ustar tootstoots # * * * * * type ('a, 'b) sum = Inl of 'a | Inr of 'b type zero = Zero type _ succ type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat # type (_, _) seq = Snil : ('a, zero) seq | Scons : 'a * ('a, 'n) seq -> ('a, 'n succ) seq # val l1 : (int, zero succ succ) seq = Scons (3, Scons (5, Snil)) # * type (_, _, _) plus = PlusZ : 'a nat -> (zero, 'a, 'a) plus | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus # val length : ('a, 'n) seq -> 'n nat = # * type (_, _, _) app = App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = # * type tp type nd type (_, _) fk type _ shape = Tp : tp shape | Nd : nd shape | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape # type tt type ff type _ boolean = BT : tt boolean | BF : ff boolean # type (_, _) path = Pnone : 'a -> (tp, 'a) path | Phere : (nd, 'a) path | Pleft : ('x, 'a) path -> (('x, 'y) fk, 'a) path | Pright : ('y, 'a) path -> (('x, 'y) fk, 'a) path # type (_, _) tree = Ttip : (tp, 'a) tree | Tnode : 'a -> (nd, 'a) tree | Tfork : ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree # val tree1 : (((tp, nd) fk, (nd, nd) fk) fk, int) tree = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3)) # val find : ('a -> 'a -> bool) -> 'a -> ('sh, 'a) tree -> ('sh, 'a) path list = # val extract : ('sh, 'a) path -> ('sh, 'a) tree -> 'a = # type (_, _) le = LeZ : 'a nat -> (zero, 'a) le | LeS : ('n, 'm) le -> ('n succ, 'm succ) le # type _ even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even # type one = zero succ type two = one succ type three = two succ type four = three succ # val even0 : zero even = EvenZ val even2 : two even = EvenSS EvenZ val even4 : four even = EvenSS (EvenSS EvenZ) # val p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ))) # val summandLessThanSum : ('a, 'b, 'c) plus -> ('a, 'c) le = # type (_, _) equal = Eq : ('a, 'a) equal val convert : ('a, 'b) equal -> 'a -> 'b = val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = # val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = # type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff # * * * * * * * * * val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = # Characters 87-243: ..match a, b,le with (* warning *) | NZ, m, LeZ _ -> Diff (m, PlusZ m) | NS x, NS y, LeS q -> match diff q x y with Diff (m, p) -> Diff (m, PlusS p) Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (NS _, NZ, _) val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = # val diff : ('a, 'b) le -> 'b nat -> ('a, 'b) diff = # type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter val leS' : ('m, 'n) le -> ('m, 'n succ) le = # val filter : ('a -> bool) -> ('a, 'n) seq -> ('a, 'n) filter = # type (_, _, _) balance = Less : ('h, 'h succ, 'h succ) balance | Same : ('h, 'h, 'h) balance | More : ('h succ, 'h, 'h succ) balance type _ avl = Leaf : zero avl | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int * 'hR avl -> 'hMax succ avl type avl' = Avl : 'h avl -> avl' # val empty : avl' = Avl Leaf val elem : int -> 'h avl -> bool = # val rotr : 'n succ succ avl -> int -> 'n avl -> ('n succ succ avl, 'n succ succ succ avl) sum = # val rotl : 'n avl -> int -> 'n succ succ avl -> ('n succ succ avl, 'n succ succ succ avl) sum = # val ins : int -> 'n avl -> ('n avl, 'n succ avl) sum = # val insert : int -> avl' -> avl' = # val del_min : 'n succ avl -> int * ('n avl, 'n succ avl) sum = type _ avl_del = Dsame : 'n avl -> 'n avl_del | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del val del : int -> 'n avl -> 'n avl_del = # val delete : int -> avl' -> avl' = # type red type black type (_, _) sub_tree = Bleaf : (black, zero) sub_tree | Rnode : (black, 'n) sub_tree * int * (black, 'n) sub_tree -> (red, 'n) sub_tree | Bnode : ('cL, 'n) sub_tree * int * ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree type rb_tree = Root : (black, 'n) sub_tree -> rb_tree # type dir = LeftD | RightD type (_, _) ctxt = CNil : (black, 'n) ctxt | CRed : int * dir * (black, 'n) sub_tree * (red, 'n) ctxt -> (black, 'n) ctxt | CBlk : int * dir * ('c1, 'n) sub_tree * (black, 'n succ) ctxt -> ('c, 'n) ctxt # val blacken : (red, 'a) sub_tree -> (black, 'a succ) sub_tree = type _ crep = Red : red crep | Black : black crep val color : ('c, 'n) sub_tree -> 'c crep = # val fill : ('c, 'n) ctxt -> ('c, 'n) sub_tree -> rb_tree = # val recolor : dir -> int -> ('a, 'b) sub_tree -> dir -> int -> (black, 'b succ) sub_tree -> ('c, 'b) sub_tree -> (red, 'b succ) sub_tree = # val rotate : dir -> int -> (black, 'a) sub_tree -> dir -> int -> (black, 'a) sub_tree -> (red, 'a) sub_tree -> (black, 'a succ) sub_tree = # val repair : (red, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = # val ins : int -> ('c, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = # val insert : int -> rb_tree -> rb_tree = # type _ term = Const : int -> int term | Add : (int * int -> int) term | LT : (int * int -> bool) term | Ap : ('a -> 'b) term * 'a term -> 'b term | Pair : 'a term * 'b term -> ('a * 'b) term val ex1 : int term = Ap (Add, Pair (Const 3, Const 5)) val ex2 : (int * int) term = Pair (Ap (Add, Pair (Const 3, Const 5)), Const 1) val eval_term : 'a term -> 'a = type _ rep = Rint : int rep | Rbool : bool rep | Rpair : 'a rep * 'b rep -> ('a * 'b) rep | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep type (_, _) equal = Eq : ('a, 'a) equal val rep_equal : 'a rep -> 'b rep -> ('a, 'b) equal option = # type assoc = Assoc : string * 'a rep * 'a -> assoc val assoc : string -> 'a rep -> assoc list -> 'a = type _ term = Var : string * 'a rep -> 'a term | Abs : string * 'a rep * 'b term -> ('a -> 'b) term | Const : int -> int term | Add : (int * int -> int) term | LT : (int * int -> bool) term | Ap : ('a -> 'b) term * 'a term -> 'b term | Pair : 'a term * 'b term -> ('a * 'b) term val eval_term : assoc list -> 'a term -> 'a = # val ex3 : (int -> int) term = Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))) val ex4 : int term = Ap (Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))), Const 3) val v4 : int = 6 # type rnil type (_, _, _) rcons type _ is_row = Rnil : rnil is_row | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row type (_, _) lam = Const : int -> ('e, int) lam | Var : 'a -> (('a, 't, 'e) rcons, 't) lam | Shift : ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam | Abs : 'a * (('a, 's, 'e) rcons, 't) lam -> ('e, 's -> 't) lam | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam type x = X type y = Y val ex1 : ((x, 'a -> 'b, (y, 'a, 'c) rcons) rcons, 'b) lam = App (Var X, Shift (Var Y)) val ex2 : ('a, ('b -> 'c) -> 'b -> 'c) lam = Abs (, Abs (, App (Shift (Var ), Var ))) # type _ env = Enil : rnil env | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env val eval_lam : 'e env -> ('e, 't) lam -> 't = # type add = Add type suc = Suc val env0 : (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons) rcons env = Econs (Zero, 0, Econs (Suc, , Econs (Add, , Enil))) val _0 : ((zero, int, 'a) rcons, int) lam = Var Zero val suc : (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam -> (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = val _1 : ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons) rcons, int) lam = App (Shift (Var Suc), Var Zero) val _2 : ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons) rcons, int) lam = App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)) val _3 : ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons) rcons, int) lam = App (Shift (Var Suc), App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))) val add : (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons, int -> int -> int) lam = Shift (Shift (Var Add)) val double : (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons, int -> int) lam = Abs (, App (App (Shift (Shift (Shift (Var Add))), Var ), Var )) val ex3 : ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons) rcons, int) lam = App (Abs (, App (App (Shift (Shift (Shift (Var Add))), Var ), Var )), App (Shift (Var Suc), App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))) # val v3 : int = 6 # * type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep val compare : 'a rep -> 'b rep -> (string, ('a, 'b) equal) sum = # type term = C of int | Ab : string * 'a rep * term -> term | Ap of term * term | V of string type _ ctx = Cnil : rnil ctx | Ccons : 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx # type _ checked = Cerror of string | Cok : ('e, 't) lam * 't rep -> 'e checked val lookup : string -> 'e ctx -> 'e checked = # val tc : 'n nat -> 'e ctx -> term -> 'e checked = # val ctx0 : (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons) rcons ctx = Ccons (Zero, "0", I, Ccons (Suc, "S", Ar (I, I), Ccons (Add, "+", Ar (I, Ar (I, I)), Cnil))) val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")) # val c1 : (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons) rcons checked = Cok (Abs (, App (App (Shift (Shift (Shift (Var Add))), Var ), Var )), Ar (I, I)) # val ex2 : term = Ap (Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")), C 3) # val c2 : (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons) rcons checked = Cok (App (Abs (, App (App (Shift (Shift (Shift (Var Add))), Var ), Var )), Const 3), I) # val eval_checked : 'a env -> 'a checked -> int = # val v2 : int = 6 # type pexp type pval type _ mode = Pexp : pexp mode | Pval : pval mode type (_, _) tarr type tint type (_, _) rel = IntR : (tint, int) rel | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel type (_, _, _) lam = Const : ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam | Var : 'a -> (pval, ('a, 't, 'e) rcons, 't) lam | Shift : ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam | Lam : 'a * ('m, ('a, 's, 'e) rcons, 't) lam -> (pval, 'e, ('s, 't) tarr) lam | App : ('m1, 'e, ('s, 't) tarr) lam * ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam # val ex1 : (pexp, 'a, tint) lam = App (Lam (, Var ), Const (IntR, )) val mode : ('m, 'e, 't) lam -> 'm mode = # type (_, _) sub = Id : ('r, 'r) sub | Bind : 't * ('m, 'r2, 'x) lam * ('r, 'r2) sub -> (('t, 'x, 'r) rcons, 'r2) sub | Push : ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam' # val subst : ('m1, 'r, 't) lam -> ('r, 's) sub -> ('s, 't) lam' = # type closed = rnil type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum # val rule : (pval, closed, ('a, 'b) tarr) lam -> (pval, closed, 'a) lam -> 'b rlam = # val onestep : ('m, closed, 't) lam -> 't rlam = # mingw-ocaml/ocaml/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference0000644000175000017500000001650012124403241026536 0ustar tootstoots # type 'a ty = Int : int ty | String : string ty | List : 'a ty -> 'a list ty | Pair : ('a ty * 'b ty) -> ('a * 'b) ty # type variant = VInt of int | VString of string | VList of variant list | VPair of variant * variant val variantize : 't ty -> 't -> variant = exception VariantMismatch val devariantize : 't ty -> variant -> 't = # type 'a ty = Int : int ty | String : string ty | List : 'a ty -> 'a list ty | Pair : ('a ty * 'b ty) -> ('a * 'b) ty | Record : 'a record -> 'a ty and 'a record = { path : string; fields : 'a field_ list; } and 'a field_ = Field : ('a, 'b) field -> 'a field_ and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; } # type variant = VInt of int | VString of string | VList of variant list | VPair of variant * variant | VRecord of (string * variant) list val variantize : 't ty -> 't -> variant = # type 'a ty = Int : int ty | String : string ty | List : 'a ty -> 'a list ty | Pair : ('a ty * 'b ty) -> ('a * 'b) ty | Record : ('a, 'builder) record -> 'a ty and ('a, 'builder) record = { path : string; fields : ('a, 'builder) field list; create_builder : unit -> 'builder; of_builder : 'builder -> 'a; } and ('a, 'builder) field = Field : ('a, 'builder, 'b) field_ -> ('a, 'builder) field and ('a, 'builder, 'b) field_ = { label : string; field_type : 'b ty; get : 'a -> 'b; set : 'builder -> 'b -> unit; } val devariantize : 't ty -> variant -> 't = # type my_record = { a : int; b : string list; } val my_record : my_record ty = Record {path = "My_module.my_record"; fields = [Field {label = "a"; field_type = Int; get = ; set = }; Field {label = "b"; field_type = List String; get = ; set = }]; create_builder = ; of_builder = } # type noarg = Noarg type (_, _) ty = Int : (int, 'c) ty | String : (string, 'd) ty | List : ('a, 'e) ty -> ('a list, 'e) ty | Option : ('a, 'e) ty -> ('a option, 'e) ty | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty | Var : ('a, 'a -> 'e) ty | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty | Sum : ('a, 'e, 'b) ty_sum -> ('a, 'e) ty and ('a, 'e, 'b) ty_sum = { sum_proj : 'a -> string * 'e ty_dyn option; sum_cases : (string * ('e, 'b) ty_case) list; sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a; } and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn and (_, _) ty_sel = Thd : ('a -> 'b, 'a) ty_sel | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel and (_, _) ty_case = TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case # type _ ty_env = Enil : unit ty_env | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env # type (_, _) eq = Eq : ('a, 'a) eq val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = val get_case : ('b, 'a) ty_sel -> (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = # type variant = VInt of int | VString of string | VList of variant list | VOption of variant option | VPair of variant * variant | VConv of string * variant | VSum of string * variant option val may_map : ('a -> 'b) -> 'a option -> 'b option = val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = # val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = # val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = # val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty = # val v : ([ `A of (int * 'a) option ] as 'a) -> variant = # val x : variant = VConv ("`A", VOption (Some (VPair (VInt 1, VConv ("`A", VOption (Some (VPair (VInt 2, VConv ("`A", VOption None))))))))) # val triple : ('a, 'b) ty -> ('c, 'b) ty -> ('d, 'b) ty -> ('a * 'c * 'd, 'b) ty = val v : variant = VConv ("Triple", VPair (VString "A", VPair (VInt 2, VInt 3))) # val ty_abc : ([ `A of int | `B of string | `C ], 'a) ty = Sum {sum_proj = ; sum_cases = [("A", TCarg (Thd, Int)); ("B", TCarg (Ttl Thd, String)); ("C", TCnoarg (Ttl (Ttl Thd)))]; sum_inj = } # val a : [ `A of int | `B of string | `C ] = `A 3 type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ] val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = val v : variant = VSum ("Cons", Some (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None))))))) # type (_, _) ty = Int : (int, 'c) ty | String : (string, 'd) ty | List : ('a, 'e) ty -> ('a list, 'e) ty | Option : ('a, 'e) ty -> ('a option, 'e) ty | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty | Var : ('a, 'a -> 'e) ty | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty | Sum : ('a -> string * 'e ty_dyn option) * (string * 'e ty_dyn option -> 'a) -> ('a, 'e) ty and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (, ) # Characters 327-344: | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p))) ^^^^^^^^^^^^^^^^^ Error: This pattern matches values of type a * a vlist but a pattern was expected which matches values of type ex#46 = ex#47 * ex#48 # type (_, _) ty = Int : (int, 'd) ty | String : (string, 'f) ty | List : ('a, 'e) ty -> ('a list, 'e) ty | Option : ('a, 'e) ty -> ('a option, 'e) ty | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty | Var : ('a, 'a -> 'e) ty | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty | Sum : < cases : (string * ('e, 'b) ty_case) list; inj : 'c. ('b, 'c) ty_sel * 'c -> 'a; proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn and (_, _) ty_sel = Thd : ('a -> 'b, 'a) ty_sel | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel and (_, _) ty_case = TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case # val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ] val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = # * * * * * * * * * mingw-ocaml/ocaml/testsuite/tests/typing-gadts/dynamic_frisch.ml0000644000175000017500000003416612124403241024611 0ustar tootstoots(* Encoding generics using GADTs *) (* (c) Alain Frisch / Lexifi *) (* cf. http://www.lexifi.com/blog/dynamic-types *) (* Basic tag *) type 'a ty = | Int: int ty | String: string ty | List: 'a ty -> 'a list ty | Pair: ('a ty * 'b ty) -> ('a * 'b) ty ;; (* Tagging data *) type variant = | VInt of int | VString of string | VList of variant list | VPair of variant * variant let rec variantize: type t. t ty -> t -> variant = fun ty x -> (* type t is abstract here *) match ty with | Int -> VInt x (* in this branch: t = int *) | String -> VString x (* t = string *) | List ty1 -> VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) | Pair (ty1, ty2) -> VPair (variantize ty1 (fst x), variantize ty2 (snd x)) (* t = ('a, 'b) for some 'a and 'b *) exception VariantMismatch let rec devariantize: type t. t ty -> variant -> t = fun ty v -> match ty, v with | Int, VInt x -> x | String, VString x -> x | List ty1, VList vl -> List.map (devariantize ty1) vl | Pair (ty1, ty2), VPair (x1, x2) -> (devariantize ty1 x1, devariantize ty2 x2) | _ -> raise VariantMismatch ;; (* Handling records *) type 'a ty = | Int: int ty | String: string ty | List: 'a ty -> 'a list ty | Pair: ('a ty * 'b ty) -> ('a * 'b) ty | Record: 'a record -> 'a ty and 'a record = { path: string; fields: 'a field_ list; } and 'a field_ = | Field: ('a, 'b) field -> 'a field_ and ('a, 'b) field = { label: string; field_type: 'b ty; get: ('a -> 'b); } ;; (* Again *) type variant = | VInt of int | VString of string | VList of variant list | VPair of variant * variant | VRecord of (string * variant) list let rec variantize: type t. t ty -> t -> variant = fun ty x -> (* type t is abstract here *) match ty with | Int -> VInt x (* in this branch: t = int *) | String -> VString x (* t = string *) | List ty1 -> VList (List.map (variantize ty1) x) (* t = 'a list for some 'a *) | Pair (ty1, ty2) -> VPair (variantize ty1 (fst x), variantize ty2 (snd x)) (* t = ('a, 'b) for some 'a and 'b *) | Record {fields} -> VRecord (List.map (fun (Field{field_type; label; get}) -> (label, variantize field_type (get x))) fields) ;; (* Extraction *) type 'a ty = | Int: int ty | String: string ty | List: 'a ty -> 'a list ty | Pair: ('a ty * 'b ty) -> ('a * 'b) ty | Record: ('a, 'builder) record -> 'a ty and ('a, 'builder) record = { path: string; fields: ('a, 'builder) field list; create_builder: (unit -> 'builder); of_builder: ('builder -> 'a); } and ('a, 'builder) field = | Field: ('a, 'builder, 'b) field_ -> ('a, 'builder) field and ('a, 'builder, 'b) field_ = { label: string; field_type: 'b ty; get: ('a -> 'b); set: ('builder -> 'b -> unit); } let rec devariantize: type t. t ty -> variant -> t = fun ty v -> match ty, v with | Int, VInt x -> x | String, VString x -> x | List ty1, VList vl -> List.map (devariantize ty1) vl | Pair (ty1, ty2), VPair (x1, x2) -> (devariantize ty1 x1, devariantize ty2 x2) | Record {fields; create_builder; of_builder}, VRecord fl -> if List.length fields <> List.length fl then raise VariantMismatch; let builder = create_builder () in List.iter2 (fun (Field {label; field_type; set}) (lab, v) -> if label <> lab then raise VariantMismatch; set builder (devariantize field_type v) ) fields fl; of_builder builder | _ -> raise VariantMismatch ;; type my_record = { a: int; b: string list; } let my_record = let fields = [ Field {label = "a"; field_type = Int; get = (fun {a} -> a); set = (fun (r, _) x -> r := Some x)}; Field {label = "b"; field_type = List String; get = (fun {b} -> b); set = (fun (_, r) x -> r := Some x)}; ] in let create_builder () = (ref None, ref None) in let of_builder (a, b) = match !a, !b with | Some a, Some b -> {a; b} | _ -> failwith "Some fields are missing in record of type my_record" in Record {path = "My_module.my_record"; fields; create_builder; of_builder} ;; (* Extension to recursive types and polymorphic variants *) (* by Jacques Garrigue *) type noarg = Noarg type (_,_) ty = | Int: (int,_) ty | String: (string,_) ty | List: ('a,'e) ty -> ('a list, 'e) ty | Option: ('a,'e) ty -> ('a option, 'e) ty | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty (* Support for type variables and recursive types *) | Var: ('a, 'a -> 'e) ty | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty (* Change the representation of a type *) | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty (* Sum types (both normal sums and polymorphic variants) *) | Sum: ('a, 'e, 'b) ty_sum -> ('a, 'e) ty and ('a, 'e, 'b) ty_sum = { sum_proj: 'a -> string * 'e ty_dyn option; sum_cases: (string * ('e,'b) ty_case) list; sum_inj: 'c. ('b,'c) ty_sel * 'c -> 'a; } and 'e ty_dyn = (* dynamic type *) | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn and (_,_) ty_sel = (* selector from a list of types *) | Thd : ('a -> 'b, 'a) ty_sel | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel and (_,_) ty_case = (* type a sum case *) | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case ;; type _ ty_env = (* type variable substitution *) | Enil : unit ty_env | Econs : ('a,'e) ty * 'e ty_env -> ('a -> 'e) ty_env ;; (* Comparing selectors *) type (_,_) eq = Eq: ('a,'a) eq let rec eq_sel : type a b c. (a,b) ty_sel -> (a,c) ty_sel -> (b,c) eq option = fun s1 s2 -> match s1, s2 with | Thd, Thd -> Some Eq | Ttl s1, Ttl s2 -> (match eq_sel s1 s2 with None -> None | Some Eq -> Some Eq) | _ -> None (* Auxiliary function to get the type of a case from its selector *) let rec get_case : type a b e. (b, a) ty_sel -> (string * (e,b) ty_case) list -> string * (a, e) ty option = fun sel cases -> match cases with | (name, TCnoarg sel') :: rem -> begin match eq_sel sel sel' with | None -> get_case sel rem | Some Eq -> name, None end | (name, TCarg (sel', ty)) :: rem -> begin match eq_sel sel sel' with | None -> get_case sel rem | Some Eq -> name, Some ty end | [] -> raise Not_found ;; (* Untyped representation of values *) type variant = | VInt of int | VString of string | VList of variant list | VOption of variant option | VPair of variant * variant | VConv of string * variant | VSum of string * variant option let may_map f = function Some x -> Some (f x) | None -> None let rec variantize : type a e. e ty_env -> (a,e) ty -> a -> variant = fun e ty v -> match ty with | Int -> VInt v | String -> VString v | List t -> VList (List.map (variantize e t) v) | Option t -> VOption (may_map (variantize e t) v) | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v)) | Rec t -> variantize (Econs (ty, e)) t v | Pop t -> (match e with Econs (_, e') -> variantize e' t v) | Var -> (match e with Econs (t, e') -> variantize e' t v) | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v)) | Sum ops -> let tag, arg = ops.sum_proj v in VSum (tag, may_map (function Tdyn (ty,arg) -> variantize e ty arg) arg) ;; let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t = fun e ty v -> match ty, v with | Int, VInt x -> x | String, VString x -> x | List ty1, VList vl -> List.map (devariantize e ty1) vl | Pair (ty1, ty2), VPair (x1, x2) -> (devariantize e ty1 x1, devariantize e ty2 x2) | Rec t, _ -> devariantize (Econs (ty, e)) t v | Pop t, _ -> (match e with Econs (_, e') -> devariantize e' t v) | Var, _ -> (match e with Econs (t, e') -> devariantize e' t v) | Conv (s, proj, inj, t), VConv (s', v) when s = s' -> inj (devariantize e t v) | Sum ops, VSum (tag, a) -> begin try match List.assoc tag ops.sum_cases, a with | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a) | TCnoarg sel, None -> ops.sum_inj (sel, Noarg) | _ -> raise VariantMismatch with Not_found -> raise VariantMismatch end | _ -> raise VariantMismatch ;; (* First attempt: represent 1-constructor variants using Conv *) let wrap_A t = Conv ("`A", (fun (`A x) -> x), (fun x -> `A x), t);; let ty a = Rec (wrap_A (Option (Pair (a, Var)))) ;; let v = variantize Enil (ty Int);; let x = v (`A (Some (1, `A (Some (2, `A None))))) ;; (* Can also use it to decompose a tuple *) let triple t1 t2 t3 = Conv ("Triple", (fun (a,b,c) -> (a,(b,c))), (fun (a,(b,c)) -> (a,b,c)), Pair (t1, Pair (t2, t3))) let v = variantize Enil (triple String Int Int) ("A", 2, 3) ;; (* Second attempt: introduce a real sum construct *) let ty_abc = (* Could also use [get_case] for proj, but direct definition is shorter *) let proj = function `A n -> "A", Some (Tdyn (Int, n)) | `B s -> "B", Some (Tdyn (String, s)) | `C -> "C", None (* Define inj in advance to be able to write the type annotation easily *) and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c -> [`A of int | `B of string | `C] = function Thd, v -> `A v | Ttl Thd, v -> `B v | Ttl (Ttl Thd), Noarg -> `C in (* Coherence of sum_inj and sum_cases is checked by the typing *) Sum { sum_proj = proj; sum_inj = inj; sum_cases = [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String); "C", TCnoarg (Ttl (Ttl Thd)) ] } ;; let v = variantize Enil ty_abc (`A 3) let a = devariantize Enil ty_abc v (* And an example with recursion... *) type 'a vlist = [`Nil | `Cons of 'a * 'a vlist] let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> let tcons = Pair (Pop t, Var) in Rec (Sum { sum_proj = (function `Nil -> "Nil", None | `Cons p -> "Cons", Some (Tdyn (tcons, p))); sum_cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)]; sum_inj = fun (type c) -> (function | Thd, Noarg -> `Nil | Ttl Thd, v -> `Cons v : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist) (* One can also write the type annotation directly *) }) let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) ;; (* Simpler but weaker approach *) type (_,_) ty = | Int: (int,_) ty | String: (string,_) ty | List: ('a,'e) ty -> ('a list, 'e) ty | Option: ('a,'e) ty -> ('a option, 'e) ty | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty | Var: ('a, 'a -> 'e) ty | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty | Sum: ('a -> string * 'e ty_dyn option) * (string * 'e ty_dyn option -> 'a) -> ('a, 'e) ty and 'e ty_dyn = | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn let ty_abc : ([`A of int | `B of string | `C],'e) ty = (* Could also use [get_case] for proj, but direct definition is shorter *) Sum ( (function `A n -> "A", Some (Tdyn (Int, n)) | `B s -> "B", Some (Tdyn (String, s)) | `C -> "C", None), (function "A", Some (Tdyn (Int, n)) -> `A n | "B", Some (Tdyn (String, s)) -> `B s | "C", None -> `C | _ -> invalid_arg "ty_abc")) ;; (* Breaks: no way to pattern-match on a full recursive type *) let ty_list : type a e. (a,e) ty -> (a vlist,e) ty = fun t -> let targ = Pair (Pop t, Var) in Rec (Sum ( (function `Nil -> "Nil", None | `Cons p -> "Cons", Some (Tdyn (targ, p))), (function "Nil", None -> `Nil | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p))) ;; (* Define Sum using object instead of record for first-class polymorphism *) type (_,_) ty = | Int: (int,_) ty | String: (string,_) ty | List: ('a,'e) ty -> ('a list, 'e) ty | Option: ('a,'e) ty -> ('a option, 'e) ty | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty | Var: ('a, 'a -> 'e) ty | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty | Sum: < proj: 'a -> string * 'e ty_dyn option; cases: (string * ('e,'b) ty_case) list; inj: 'c. ('b,'c) ty_sel * 'c -> 'a > -> ('a, 'e) ty and 'e ty_dyn = | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn and (_,_) ty_sel = | Thd : ('a -> 'b, 'a) ty_sel | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel and (_,_) ty_case = | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case ;; let ty_abc : ([`A of int | `B of string | `C] as 'a, 'e) ty = Sum (object method proj = function `A n -> "A", Some (Tdyn (Int, n)) | `B s -> "B", Some (Tdyn (String, s)) | `C -> "C", None method cases = [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String); "C", TCnoarg (Ttl (Ttl Thd)) ]; method inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c -> [`A of int | `B of string | `C] = function Thd, v -> `A v | Ttl Thd, v -> `B v | Ttl (Ttl Thd), Noarg -> `C | _ -> assert false end) type 'a vlist = [`Nil | `Cons of 'a * 'a vlist] let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t -> let tcons = Pair (Pop t, Var) in Rec (Sum (object method proj = function `Nil -> "Nil", None | `Cons p -> "Cons", Some (Tdyn (tcons, p)) method cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)] method inj : type c.(noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist = function | Thd, Noarg -> `Nil | Ttl Thd, v -> `Cons v end)) ;; (* type (_,_) ty_assoc = | Anil : (unit,'e) ty_assoc | Acons : string * ('a,'e) ty * ('b,'e) ty_assoc -> ('a -> 'b, 'e) ty_assoc and (_,_) ty_pvar = | Pnil : ('a,'e) ty_pvar | Pconst : 't * ('b,'e) ty_pvar -> ('t -> 'b, 'e) ty_pvar | Parg : 't * ('a,'e) ty * ('b,'e) ty_pvar -> ('t * 'a -> 'b, 'e) ty_pvar *) mingw-ocaml/ocaml/testsuite/tests/typing-gadts/omega07.ml.principal.reference0000644000175000017500000003115512124403241026776 0ustar tootstoots # * * * * * type ('a, 'b) sum = Inl of 'a | Inr of 'b type zero = Zero type _ succ type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat # type (_, _) seq = Snil : ('a, zero) seq | Scons : 'a * ('a, 'n) seq -> ('a, 'n succ) seq # val l1 : (int, zero succ succ) seq = Scons (3, Scons (5, Snil)) # * type (_, _, _) plus = PlusZ : 'a nat -> (zero, 'a, 'a) plus | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus # val length : ('a, 'n) seq -> 'n nat = # * type (_, _, _) app = App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = # * type tp type nd type (_, _) fk type _ shape = Tp : tp shape | Nd : nd shape | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape # type tt type ff type _ boolean = BT : tt boolean | BF : ff boolean # type (_, _) path = Pnone : 'a -> (tp, 'a) path | Phere : (nd, 'a) path | Pleft : ('x, 'a) path -> (('x, 'y) fk, 'a) path | Pright : ('y, 'a) path -> (('x, 'y) fk, 'a) path # type (_, _) tree = Ttip : (tp, 'a) tree | Tnode : 'a -> (nd, 'a) tree | Tfork : ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree # val tree1 : (((tp, nd) fk, (nd, nd) fk) fk, int) tree = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3)) # val find : ('a -> 'a -> bool) -> 'a -> ('sh, 'a) tree -> ('sh, 'a) path list = # val extract : ('sh, 'a) path -> ('sh, 'a) tree -> 'a = # type (_, _) le = LeZ : 'a nat -> (zero, 'a) le | LeS : ('n, 'm) le -> ('n succ, 'm succ) le # type _ even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even # type one = zero succ type two = one succ type three = two succ type four = three succ # val even0 : zero even = EvenZ val even2 : two even = EvenSS EvenZ val even4 : four even = EvenSS (EvenSS EvenZ) # val p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ))) # val summandLessThanSum : ('a, 'b, 'c) plus -> ('a, 'c) le = # type (_, _) equal = Eq : ('a, 'a) equal val convert : ('a, 'b) equal -> 'a -> 'b = val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = # val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = # type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff # * * * * * * * * * val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = # Characters 87-243: ..match a, b,le with (* warning *) | NZ, m, LeZ _ -> Diff (m, PlusZ m) | NS x, NS y, LeS q -> match diff q x y with Diff (m, p) -> Diff (m, PlusS p) Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (NS _, NZ, _) val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = # val diff : ('a, 'b) le -> 'b nat -> ('a, 'b) diff = # type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter val leS' : ('m, 'n) le -> ('m, 'n succ) le = # val filter : ('a -> bool) -> ('a, 'n) seq -> ('a, 'n) filter = # type (_, _, _) balance = Less : ('h, 'h succ, 'h succ) balance | Same : ('h, 'h, 'h) balance | More : ('h succ, 'h, 'h succ) balance type _ avl = Leaf : zero avl | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int * 'hR avl -> 'hMax succ avl type avl' = Avl : 'h avl -> avl' # val empty : avl' = Avl Leaf val elem : int -> 'h avl -> bool = # val rotr : 'n succ succ avl -> int -> 'n avl -> ('n succ succ avl, 'n succ succ succ avl) sum = # val rotl : 'n avl -> int -> 'n succ succ avl -> ('n succ succ avl, 'n succ succ succ avl) sum = # val ins : int -> 'n avl -> ('n avl, 'n succ avl) sum = # val insert : int -> avl' -> avl' = # val del_min : 'n succ avl -> int * ('n avl, 'n succ avl) sum = type _ avl_del = Dsame : 'n avl -> 'n avl_del | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del val del : int -> 'n avl -> 'n avl_del = # val delete : int -> avl' -> avl' = # type red type black type (_, _) sub_tree = Bleaf : (black, zero) sub_tree | Rnode : (black, 'n) sub_tree * int * (black, 'n) sub_tree -> (red, 'n) sub_tree | Bnode : ('cL, 'n) sub_tree * int * ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree type rb_tree = Root : (black, 'n) sub_tree -> rb_tree # type dir = LeftD | RightD type (_, _) ctxt = CNil : (black, 'n) ctxt | CRed : int * dir * (black, 'n) sub_tree * (red, 'n) ctxt -> (black, 'n) ctxt | CBlk : int * dir * ('c1, 'n) sub_tree * (black, 'n succ) ctxt -> ('c, 'n) ctxt # val blacken : (red, 'a) sub_tree -> (black, 'a succ) sub_tree = type _ crep = Red : red crep | Black : black crep val color : ('c, 'n) sub_tree -> 'c crep = # val fill : ('c, 'n) ctxt -> ('c, 'n) sub_tree -> rb_tree = # val recolor : dir -> int -> ('a, 'b) sub_tree -> dir -> int -> (black, 'b succ) sub_tree -> ('c, 'b) sub_tree -> (red, 'b succ) sub_tree = # val rotate : dir -> int -> (black, 'a) sub_tree -> dir -> int -> (black, 'a) sub_tree -> (red, 'a) sub_tree -> (black, 'a succ) sub_tree = # val repair : (red, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = # val ins : int -> ('c, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = # val insert : int -> rb_tree -> rb_tree = # type _ term = Const : int -> int term | Add : (int * int -> int) term | LT : (int * int -> bool) term | Ap : ('a -> 'b) term * 'a term -> 'b term | Pair : 'a term * 'b term -> ('a * 'b) term val ex1 : int term = Ap (Add, Pair (Const 3, Const 5)) val ex2 : (int * int) term = Pair (Ap (Add, Pair (Const 3, Const 5)), Const 1) val eval_term : 'a term -> 'a = type _ rep = Rint : int rep | Rbool : bool rep | Rpair : 'a rep * 'b rep -> ('a * 'b) rep | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep type (_, _) equal = Eq : ('a, 'a) equal val rep_equal : 'a rep -> 'b rep -> ('a, 'b) equal option = # type assoc = Assoc : string * 'a rep * 'a -> assoc val assoc : string -> 'a rep -> assoc list -> 'a = type _ term = Var : string * 'a rep -> 'a term | Abs : string * 'a rep * 'b term -> ('a -> 'b) term | Const : int -> int term | Add : (int * int -> int) term | LT : (int * int -> bool) term | Ap : ('a -> 'b) term * 'a term -> 'b term | Pair : 'a term * 'b term -> ('a * 'b) term val eval_term : assoc list -> 'a term -> 'a = # val ex3 : (int -> int) term = Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))) val ex4 : int term = Ap (Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))), Const 3) val v4 : int = 6 # type rnil type (_, _, _) rcons type _ is_row = Rnil : rnil is_row | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row type (_, _) lam = Const : int -> ('e, int) lam | Var : 'a -> (('a, 't, 'e) rcons, 't) lam | Shift : ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam | Abs : 'a * (('a, 's, 'e) rcons, 't) lam -> ('e, 's -> 't) lam | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam type x = X type y = Y val ex1 : ((x, 'a -> 'b, (y, 'a, 'c) rcons) rcons, 'b) lam = App (Var X, Shift (Var Y)) val ex2 : ('a, ('b -> 'c) -> 'b -> 'c) lam = Abs (, Abs (, App (Shift (Var ), Var ))) # type _ env = Enil : rnil env | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env val eval_lam : 'e env -> ('e, 't) lam -> 't = # type add = Add type suc = Suc val env0 : (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons) rcons env = Econs (Zero, 0, Econs (Suc, , Econs (Add, , Enil))) val _0 : ((zero, int, 'a) rcons, int) lam = Var Zero val suc : (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam -> (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = val _1 : ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons) rcons, int) lam = App (Shift (Var Suc), Var Zero) val _2 : ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons) rcons, int) lam = App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)) val _3 : ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons) rcons, int) lam = App (Shift (Var Suc), App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))) val add : (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons, int -> int -> int) lam = Shift (Shift (Var Add)) val double : (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons, int -> int) lam = Abs (, App (App (Shift (Shift (Shift (Var Add))), Var ), Var )) val ex3 : ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons) rcons, int) lam = App (Abs (, App (App (Shift (Shift (Shift (Var Add))), Var ), Var )), App (Shift (Var Suc), App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))) # val v3 : int = 6 # * type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep val compare : 'a rep -> 'b rep -> (string, ('a, 'b) equal) sum = # type term = C of int | Ab : string * 'a rep * term -> term | Ap of term * term | V of string type _ ctx = Cnil : rnil ctx | Ccons : 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx # type _ checked = Cerror of string | Cok : ('e, 't) lam * 't rep -> 'e checked val lookup : string -> 'e ctx -> 'e checked = # val tc : 'n nat -> 'e ctx -> term -> 'e checked = # val ctx0 : (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons) rcons ctx = Ccons (Zero, "0", I, Ccons (Suc, "S", Ar (I, I), Ccons (Add, "+", Ar (I, Ar (I, I)), Cnil))) val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")) # val c1 : (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons) rcons checked = Cok (Abs (, App (App (Shift (Shift (Shift (Var Add))), Var ), Var )), Ar (I, I)) # val ex2 : term = Ap (Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")), C 3) # val c2 : (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons) rcons checked = Cok (App (Abs (, App (App (Shift (Shift (Shift (Var Add))), Var ), Var )), Const 3), I) # val eval_checked : 'a env -> 'a checked -> int = # val v2 : int = 6 # type pexp type pval type _ mode = Pexp : pexp mode | Pval : pval mode type (_, _) tarr type tint type (_, _) rel = IntR : (tint, int) rel | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel type (_, _, _) lam = Const : ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam | Var : 'a -> (pval, ('a, 't, 'e) rcons, 't) lam | Shift : ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam | Lam : 'a * ('m, ('a, 's, 'e) rcons, 't) lam -> (pval, 'e, ('s, 't) tarr) lam | App : ('m1, 'e, ('s, 't) tarr) lam * ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam # val ex1 : (pexp, 'a, tint) lam = App (Lam (, Var ), Const (IntR, )) val mode : ('m, 'e, 't) lam -> 'm mode = # type (_, _) sub = Id : ('r, 'r) sub | Bind : 't * ('m, 'r2, 'x) lam * ('r, 'r2) sub -> (('t, 'x, 'r) rcons, 'r2) sub | Push : ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam' # val subst : ('m1, 'r, 't) lam -> ('r, 's) sub -> ('s, 't) lam' = # type closed = rnil type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum # val rule : (pval, closed, ('a, 'b) tarr) lam -> (pval, closed, 'a) lam -> 'b rlam = # val onestep : ('m, closed, 't) lam -> 't rlam = # mingw-ocaml/ocaml/testsuite/tests/typing-gadts/test.ml0000644000175000017500000002613212124403241022600 0ustar tootstootsmodule Exp = struct type _ t = | IntLit : int -> int t | BoolLit : bool -> bool t | Pair : 'a t * 'b t -> ('a * 'b) t | App : ('a -> 'b) t * 'a t -> 'b t | Abs : ('a -> 'b) -> ('a -> 'b) t let rec eval : type s . s t -> s = function | IntLit x -> x | BoolLit y -> y | Pair (x,y) -> (eval x,eval y) | App (f,a) -> (eval f) (eval a) | Abs f -> f let discern : type a. a t -> _ = function IntLit _ -> 1 | BoolLit _ -> 2 | Pair _ -> 3 | App _ -> 4 | Abs _ -> 5 end ;; module List = struct type zero type _ t = | Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t let head = function | Cons (a,b) -> a let tail = function | Cons (a,b) -> b let rec length : type a . a t -> int = function | Nil -> 0 | Cons (a,b) -> length b end ;; module Nonexhaustive = struct type 'a u = | C1 : int -> int u | C2 : bool -> bool u type 'a v = | C1 : int -> int v let unexhaustive : type s . s u -> s = function | C2 x -> x module M : sig type t type u end = struct type t = int type u = bool end type 'a t = | Foo : M.t -> M.t t | Bar : M.u -> M.u t let same_type : type s . s t * s t -> bool = function | Foo _ , Foo _ -> true | Bar _, Bar _ -> true end ;; module Exhaustive = struct type t = int type u = bool type 'a v = | Foo : t -> t v | Bar : u -> u v let same_type : type s . s v * s v -> bool = function | Foo _ , Foo _ -> true | Bar _, Bar _ -> true end ;; module Existential_escape = struct type _ t = C : int -> int t type u = D : 'a t -> u let eval (D x) = x end ;; module Rectype = struct type (_,_) t = C : ('a,'a) t let _ = fun (type s) -> let a : (s, s * s) t = failwith "foo" in match a with C -> () end ;; module Or_patterns = struct type _ t = | IntLit : int -> int t | BoolLit : bool -> bool t let rec eval : type s . s t -> unit = function | (IntLit _ | BoolLit _) -> () end ;; module Polymorphic_variants = struct type _ t = | IntLit : int -> int t | BoolLit : bool -> bool t let rec eval : type s . [`A] * s t -> unit = function | `A, IntLit _ -> () | `A, BoolLit _ -> () end ;; module Propagation = struct type _ t = IntLit : int -> int t | BoolLit : bool -> bool t let check : type s. s t -> s = function | IntLit n -> n | BoolLit b -> b let check : type s. s t -> s = fun x -> let r = match x with | IntLit n -> (n : s ) | BoolLit b -> b in r end ;; module Normal_constrs = struct type a = A type b = B let f = function A -> 1 | B -> 2 end;; type _ t = Int : int t ;; let ky x y = ignore (x = y); x ;; let test : type a. a t -> a = function Int -> ky (1 : a) 1 ;; let test : type a. a t -> _ = function Int -> 1 (* ok *) ;; let test : type a. a t -> _ = function Int -> ky (1 : a) 1 (* fails *) ;; let test : type a. a t -> a = fun x -> let r = match x with Int -> ky (1 : a) 1 (* fails *) in r ;; let test : type a. a t -> a = fun x -> let r = match x with Int -> ky 1 (1 : a) (* fails *) in r ;; let test (type a) x = let r = match (x : a t) with Int -> ky 1 1 in r ;; let test : type a. a t -> a = fun x -> let r = match x with Int -> (1 : a) (* ok! *) in r ;; let test : type a. a t -> _ = fun x -> let r = match x with Int -> 1 (* ok! *) in r ;; let test : type a. a t -> a = fun x -> let r : a = match x with Int -> 1 in r (* ok *) ;; let test2 : type a. a t -> a option = fun x -> let r = ref None in begin match x with Int -> r := Some (1 : a) end; !r (* ok *) ;; let test2 : type a. a t -> a option = fun x -> let r : a option ref = ref None in begin match x with Int -> r := Some 1 end; !r (* ok *) ;; let test2 : type a. a t -> a option = fun x -> let r : a option ref = ref None in let u = ref None in begin match x with Int -> r := Some 1; u := !r end; !u ;; (* ok (u non-ambiguous) *) let test2 : type a. a t -> a option = fun x -> let r : a option ref = ref None in let u = ref None in begin match x with Int -> u := Some 1; r := !u end; !u ;; (* fails because u : (int | a) option ref *) let test2 : type a. a t -> a option = fun x -> let u = ref None in let r : a option ref = ref None in begin match x with Int -> r := Some 1; u := !r end; !u ;; (* ok *) let test2 : type a. a t -> a option = fun x -> let u = ref None in let a = let r : a option ref = ref None in begin match x with Int -> r := Some 1; u := !r end; !u in a ;; (* ok *) let either = ky let we_y1x (type a) (x : a) (v : a t) = match v with Int -> let y = either 1 x in y ;; (* fail *) (* Effect of external consraints *) let f (type a) (x : a t) y = ignore (y : a); let r = match x with Int -> (y : a) in (* ok *) r ;; let f (type a) (x : a t) y = let r = match x with Int -> (y : a) in ignore (y : a); (* ok *) r ;; let f (type a) (x : a t) y = ignore (y : a); let r = match x with Int -> y in (* ok *) r ;; let f (type a) (x : a t) y = let r = match x with Int -> y in ignore (y : a); (* ok *) r ;; let f (type a) (x : a t) (y : a) = match x with Int -> y (* returns 'a *) ;; (* Combination with local modules *) let f (type a) (x : a t) y = match x with Int -> let module M = struct type b = a let z = (y : b) end in M.z ;; (* fails because of aliasing... *) let f (type a) (x : a t) y = match x with Int -> let module M = struct type b = int let z = (y : b) end in M.z ;; (* ok *) (* Objects and variants *) type _ h = | Has_m : h | Has_b : h let f : type a. a h -> a = function | Has_m -> object method m = 1 end | Has_b -> object method b = true end ;; type _ j = | Has_A : [`A of int] j | Has_B : [`B of bool] j let f : type a. a j -> a = function | Has_A -> `A 1 | Has_B -> `B true ;; type (_,_) eq = Eq : ('a,'a) eq ;; let f : type a b. (a,b) eq -> ( as 'c) -> ( as 'c) = fun Eq o -> o ;; (* fail *) let f : type a b. (a,b) eq -> -> = fun Eq o -> o ;; (* fail *) let f (type a) (type b) (eq : (a,b) eq) (o : ) : = match eq with Eq -> o ;; (* should fail *) let f : type a b. (a,b) eq -> -> = fun Eq o -> o ;; (* ok *) let int_of_bool : (bool,int) eq = Obj.magic Eq;; let x = object method m = true end;; let y = (x, f int_of_bool x);; let f : type a. (a, int) eq -> -> bool = fun Eq o -> ignore (o : ); o#m = 3 ;; (* should be ok *) let f : type a b. (a,b) eq -> < m : a; .. > -> < m : b > = fun eq o -> ignore (o : < m : a >); let r : < m : b > = match eq with Eq -> o in (* fail with principal *) r;; let f : type a b. (a,b) eq -> < m : a; .. > -> < m : b > = fun eq o -> let r : < m : b > = match eq with Eq -> o in (* fail *) ignore (o : < m : a >); r;; let f : type a b. (a,b) eq -> [> `A of a] -> [> `A of b] = fun Eq o -> o ;; (* fail *) let f (type a) (type b) (eq : (a,b) eq) (v : [> `A of a]) : [> `A of b] = match eq with Eq -> v ;; (* should fail *) let f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] = fun Eq o -> o ;; (* fail *) let f : type a b. (a,b) eq -> [`A of a | `B] -> [`A of b | `B] = fun Eq o -> o ;; (* ok *) let f : type a. (a, int) eq -> [`A of a] -> bool = fun Eq v -> match v with `A 1 -> true | _ -> false ;; (* ok *) let f : type a b. (a,b) eq -> [> `A of a | `B] -> [`A of b | `B] = fun eq o -> ignore (o : [< `A of a | `B]); let r : [`A of b | `B] = match eq with Eq -> o in (* fail with principal *) r;; let f : type a b. (a,b) eq -> [> `A of a | `B] -> [`A of b | `B] = fun eq o -> let r : [`A of b | `B] = match eq with Eq -> o in (* fail *) ignore (o : [< `A of a | `B]); r;; (* Pattern matching *) type 'a t = A of int | B of bool | C of float | D of 'a type _ ty = | TE : 'a ty -> 'a array ty | TA : int ty | TB : bool ty | TC : float ty | TD : string -> bool ty let f : type a. a ty -> a t -> int = fun x y -> match x, y with | _, A z -> z | _, B z -> if z then 1 else 2 | _, C z -> truncate z | TE TC, D [|1.0|] -> 14 | TA, D 0 -> -1 | TA, D z -> z | TD "bye", D false -> 13 | TD "hello", D true -> 12 (* | TB, D z -> if z then 1 else 2 *) | TC, D z -> truncate z | _, D _ -> 0 ;; let f : type a. a ty -> a t -> int = fun x y -> match x, y with | _, A z -> z | _, B z -> if z then 1 else 2 | _, C z -> truncate z | TE TC, D [|1.0|] -> 14 | TA, D 0 -> -1 | TA, D z -> z ;; (* warn *) let f : type a. a ty -> a t -> int = fun x y -> match y, x with | A z, _ -> z | B z, _ -> if z then 1 else 2 | C z, _ -> truncate z | D [|1.0|], TE TC -> 14 | D 0, TA -> -1 | D z, TA -> z ;; (* fail *) type ('a,'b) pair = {right:'a; left:'b} let f : type a. a ty -> a t -> int = fun x y -> match {left=x; right=y} with | {left=_; right=A z} -> z | {left=_; right=B z} -> if z then 1 else 2 | {left=_; right=C z} -> truncate z | {left=TE TC; right=D [|1.0|]} -> 14 | {left=TA; right=D 0} -> -1 | {left=TA; right=D z} -> z ;; (* fail *) type ('a,'b) pair = {left:'a; right:'b} let f : type a. a ty -> a t -> int = fun x y -> match {left=x; right=y} with | {left=_; right=A z} -> z | {left=_; right=B z} -> if z then 1 else 2 | {left=_; right=C z} -> truncate z | {left=TE TC; right=D [|1.0|]} -> 14 | {left=TA; right=D 0} -> -1 | {left=TA; right=D z} -> z ;; (* ok *) (* Injectivity *) module M : sig type 'a t val eq : ('a t, 'b t) eq end = struct type 'a t = int let eq = Eq end ;; let f : type a b. (a M.t, b M.t) eq -> (a, b) eq = function Eq -> Eq (* fail *) ;; let f : type a b. (a M.t * a, b M.t * b) eq -> (a, b) eq = function Eq -> Eq (* ok *) ;; let f : type a b. (a * a M.t, b * b M.t) eq -> (a, b) eq = function Eq -> Eq (* ok *) ;; (* Applications of polymorphic variants *) type _ t = | V1 : [`A | `B] t | V2 : [`C | `D] t let f : type a. a t -> a = function | V1 -> `A | V2 -> `C ;; f V1;; (* PR#5425 and PR#5427 *) type _ int_foo = | IF_constr : int_foo type _ int_bar = | IB_constr : int_bar ;; let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) = let IF_constr, IB_constr = e, e' in (x:) ;; let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) = let IF_constr, IB_constr = e, e' in (x:) ;; let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) = let IF_constr, IB_constr = e, e' in (x:) ;; let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) : t = let IF_constr, IB_constr = e, e' in (x:) ;; let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) = let IF_constr, IB_constr = e, e' in x, x#foo, x#bar ;; (* PR#5554 *) type 'a ty = Int : int -> int ty;; let f : type a. a ty -> a = fun x -> match x with Int y -> y;; let g : type a. a ty -> a = let () = () in fun x -> match x with Int y -> y;; mingw-ocaml/ocaml/testsuite/tests/typing-gadts/term-conv.ml.principal.reference0000644000175000017500000000541112124403241027445 0ustar tootstoots # module Typeable : sig type 'a ty = Int : int ty | String : string ty | List : 'a ty -> 'a list ty | Pair : ('a ty * 'b ty) -> ('a * 'b) ty | Fun : ('a ty * 'b ty) -> ('a -> 'b) ty type (_, _) eq = Eq : ('a, 'a) eq exception CastFailure val check_eq : 't ty -> 't' ty -> ('t, 't') eq val gcast : 't ty -> 't' ty -> 't -> 't' end # module HOAS : sig type _ term = Tag : 't Typeable.ty * int -> 't term | Con : 't -> 't term | Lam : 's Typeable.ty * ('s term -> 't term) -> ('s -> 't) term | App : ('s -> 't) term * 's term -> 't term val intp : 't term -> 't end # module DeBruijn : sig type ('env, 't) ix = ZeroIx : ('env * 't, 't) ix | SuccIx : ('env, 't) ix -> ('env * 's, 't) ix val to_int : ('env, 't) ix -> int type ('env, 't) term = Var : ('env, 't) ix -> ('env, 't) term | Con : 't -> ('env, 't) term | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term type _ stack = Empty : unit stack | Push : 'env stack * 't -> ('env * 't) stack val prj : ('env, 't) ix -> 'env stack -> 't val intp : ('env, 't) term -> 'env stack -> 't end # module Convert : sig type (_, _) layout = EmptyLayout : ('env, unit) layout | PushLayout : 't Typeable.ty * ('env, 'env') layout * ('env, 't) DeBruijn.ix -> ('env, 'env' * 't) layout val size : ('env, 'env') layout -> int val inc : ('env, 'env') layout -> ('env * 't, 'env') layout val prj : 't Typeable.ty -> int -> ('env, 'env') layout -> ('env, 't) DeBruijn.ix val cvt : ('env, 'env) layout -> 't HOAS.term -> ('env, 't) DeBruijn.term val convert : 'a HOAS.term -> (unit, 'a) DeBruijn.term end # module Main : sig val i : 'a Typeable.ty -> ('a -> 'a) HOAS.term val zero : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term val one : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term val two : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term val three : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term val plus : 'a Typeable.ty -> ((('a -> 'a) -> 'a -> 'a) -> (('a -> 'a) -> 'a -> 'a) -> ('a -> 'a) -> 'a -> 'a) HOAS.term val plus_2_3 : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term val i' : (unit, int -> int) DeBruijn.term val plus_2_3' : (unit, (int -> int) -> int -> int) DeBruijn.term val eval_plus_2_3' : int end # mingw-ocaml/ocaml/testsuite/tests/typing-gadts/pr5332.ml.reference0000644000175000017500000000112712124403241024511 0ustar tootstoots # type ('env, 'a) var = Zero : ('a * 'env, 'a) var | Succ : ('env, 'a) var -> ('b * 'env, 'a) var # type ('env, 'a) typ = Tint : ('env, int) typ | Tbool : ('env, bool) typ | Tvar : ('env, 'a) var -> ('env, 'a) typ # Characters 72-156: .match ta, tb with | Tint, Tint -> 0 | Tbool, Tbool -> 1 | Tvar var, tb -> 2 Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (Tbool, Tvar _) val f : ('env, 'a) typ -> ('env, 'a) typ -> int = # Exception: Match_failure ("//toplevel//", 9, 1). # mingw-ocaml/ocaml/testsuite/tests/typing-gadts/yallop_bugs.ml0000644000175000017500000000210312124403241024131 0ustar tootstoots(* Injectivity *) type (_, _) eq = Refl : ('a, 'a) eq let magic : 'a 'b. 'a -> 'b = fun (type a) (type b) (x : a) -> let module M = (functor (T : sig type 'a t end) -> struct let f (Refl : (a T.t, b T.t) eq) = (x :> b) end) (struct type 'a t = unit end) in M.f Refl ;; (* Variance and subtyping *) type (_, +_) eq = Refl : ('a, 'a) eq let magic : 'a 'b. 'a -> 'b = fun (type a) (type b) (x : a) -> let bad_proof (type a) = (Refl : (< m : a>, ) eq :> (, < >) eq) in let downcast : type a. (a, < >) eq -> < > -> a = fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) in (downcast bad_proof ((object method m = x end) :> < >)) # m ;; (* Record patterns *) type _ t = | IntLit : int t | BoolLit : bool t let check : type s . s t * s -> bool = function | BoolLit, false -> false | IntLit , 6 -> false ;; type ('a, 'b) pair = { fst : 'a; snd : 'b } let check : type s . (s t, s) pair -> bool = function | {fst = BoolLit; snd = false} -> false | {fst = IntLit ; snd = 6} -> false ;; mingw-ocaml/ocaml/testsuite/tests/typing-gadts/pr5689.ml0000644000175000017500000000475012124403241022600 0ustar tootstootstype inkind = [ `Link | `Nonlink ] type _ inline_t = | Text: string -> [< inkind > `Nonlink ] inline_t | Bold: 'a inline_t list -> 'a inline_t | Link: string -> [< inkind > `Link ] inline_t | Mref: string * [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t ;; let uppercase seq = let rec process: type a. a inline_t -> a inline_t = function | Text txt -> Text (String.uppercase txt) | Bold xs -> Bold (List.map process xs) | Link lnk -> Link lnk | Mref (lnk, xs) -> Mref (lnk, List.map process xs) in List.map process seq ;; type ast_t = | Ast_Text of string | Ast_Bold of ast_t list | Ast_Link of string | Ast_Mref of string * ast_t list ;; let inlineseq_from_astseq seq = let rec process_nonlink = function | Ast_Text txt -> Text txt | Ast_Bold xs -> Bold (List.map process_nonlink xs) | _ -> assert false in let rec process_any = function | Ast_Text txt -> Text txt | Ast_Bold xs -> Bold (List.map process_any xs) | Ast_Link lnk -> Link lnk | Ast_Mref (lnk, xs) -> Mref (lnk, List.map process_nonlink xs) in List.map process_any seq ;; (* OK *) type _ linkp = | Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp ;; let inlineseq_from_astseq seq = let rec process : type a. a linkp -> ast_t -> a inline_t = fun allow_link ast -> match (allow_link, ast) with | (Maylink, Ast_Text txt) -> Text txt | (Nonlink, Ast_Text txt) -> Text txt | (x, Ast_Bold xs) -> Bold (List.map (process x) xs) | (Maylink, Ast_Link lnk) -> Link lnk | (Nonlink, Ast_Link _) -> assert false | (Maylink, Ast_Mref (lnk, xs)) -> Mref (lnk, List.map (process Nonlink) xs) | (Nonlink, Ast_Mref _) -> assert false in List.map (process Maylink) seq ;; (* Bad *) type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2 ;; let inlineseq_from_astseq seq = let rec process : type a. a linkp2 -> ast_t -> a inline_t = fun allow_link ast -> match (allow_link, ast) with | (Kind _, Ast_Text txt) -> Text txt | (x, Ast_Bold xs) -> Bold (List.map (process x) xs) | (Kind Maylink, Ast_Link lnk) -> Link lnk | (Kind Nonlink, Ast_Link _) -> assert false | (Kind Maylink, Ast_Mref (lnk, xs)) -> Mref (lnk, List.map (process (Kind Nonlink)) xs) | (Kind Nonlink, Ast_Mref _) -> assert false in List.map (process (Kind Maylink)) seq ;; mingw-ocaml/ocaml/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference0000644000175000017500000000216512124403241030056 0ustar tootstoots # Characters 240-248: let f (Refl : (a T.t, b T.t) eq) = (x :> b) ^^^^^^^^ Error: Type a is not a subtype of b # Characters 36-67: type (_, +_) eq = Refl : ('a, 'a) eq ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In this GADT definition, the variance of some parameter cannot be checked # Characters 115-175: .......................................function | BoolLit, false -> false | IntLit , 6 -> false Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (IntLit, 0) type _ t = IntLit : int t | BoolLit : bool t val check : 's t * 's -> bool = # Characters 91-180: .............................................function | {fst = BoolLit; snd = false} -> false | {fst = IntLit ; snd = 6} -> false Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: {fst=IntLit; snd=0} type ('a, 'b) pair = { fst : 'a; snd : 'b; } val check : ('s t, 's) pair -> bool = # mingw-ocaml/ocaml/testsuite/tests/typing-gadts/omega07.ml0000644000175000017500000005314712124403241023066 0ustar tootstoots(* An attempt at encoding omega examples from the 2nd Central European Functional Programming School: Generic Programming in Omega, by Tim Sheard and Nathan Linger http://web.cecs.pdx.edu/~sheard/ *) (* Basic types *) type ('a,'b) sum = Inl of 'a | Inr of 'b type zero = Zero type _ succ type _ nat = | NZ : zero nat | NS : 'a nat -> 'a succ nat ;; (* 2: A simple example *) type (_,_) seq = | Snil : ('a,zero) seq | Scons : 'a * ('a,'n) seq -> ('a, 'n succ) seq ;; let l1 = Scons (3, Scons (5, Snil)) ;; (* We do not have type level functions, so we need to use witnesses. *) (* We copy here the definitions from section 3.9 *) (* Note the addition of the ['a nat] argument to PlusZ, since we do not have kinds *) type (_,_,_) plus = | PlusZ : 'a nat -> (zero, 'a, 'a) plus | PlusS : ('a,'b,'c) plus -> ('a succ, 'b, 'c succ) plus ;; let rec length : type a n. (a,n) seq -> n nat = function | Snil -> NZ | Scons (_, s) -> NS (length s) ;; (* app returns the catenated lists with a witness proving that the size is the sum of its two inputs *) type (_,_,_) app = App : ('a,'p) seq * ('n,'m,'p) plus -> ('a,'n,'m) app let rec app : type a n m. (a,n) seq -> (a,m) seq -> (a,n,m) app = fun xs ys -> match xs with | Snil -> App (ys, PlusZ (length ys)) | Scons (x, xs') -> match app xs' ys with | App (xs'', pl) -> App (Scons (x, xs''), PlusS pl) ;; (* Note: it would be nice to be able to handle existentials in let definitions *) (* 3.1 Feature: kinds *) (* We do not have kinds, but we can encode them as predicates *) type tp type nd type (_,_) fk type _ shape = | Tp : tp shape | Nd : nd shape | Fk : 'a shape * 'b shape -> ('a,'b) fk shape ;; type tt type ff type _ boolean = | BT : tt boolean | BF : ff boolean ;; (* 3.3 Feature : GADTs *) type (_,_) path = | Pnone : 'a -> (tp,'a) path | Phere : (nd,'a) path | Pleft : ('x,'a) path -> (('x,'y) fk, 'a) path | Pright : ('y,'a) path -> (('x,'y) fk, 'a) path ;; type (_,_) tree = | Ttip : (tp,'a) tree | Tnode : 'a -> (nd,'a) tree | Tfork : ('x,'a) tree * ('y,'a) tree -> (('x,'y)fk, 'a) tree ;; let tree1 = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3)) ;; let rec find : type sh. ('a -> 'a -> bool) -> 'a -> (sh,'a) tree -> (sh,'a) path list = fun eq n t -> match t with | Ttip -> [] | Tnode m -> if eq n m then [Phere] else [] | Tfork (x, y) -> List.map (fun x -> Pleft x) (find eq n x) @ List.map (fun x -> Pright x) (find eq n y) ;; let rec extract : type sh. (sh,'a) path -> (sh,'a) tree -> 'a = fun p t -> match (p, t) with | Pnone x, Ttip -> x | Phere, Tnode y -> y | Pleft p, Tfork(l,_) -> extract p l | Pright p, Tfork(_,r) -> extract p r ;; (* 3.4 Pattern : Witness *) type (_,_) le = | LeZ : 'a nat -> (zero, 'a) le | LeS : ('n, 'm) le -> ('n succ, 'm succ) le ;; type _ even = | EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even ;; type one = zero succ type two = one succ type three = two succ type four = three succ ;; let even0 : zero even = EvenZ let even2 : two even = EvenSS EvenZ let even4 : four even = EvenSS (EvenSS EvenZ) ;; let p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ))) ;; let rec summandLessThanSum : type a b c. (a,b,c) plus -> (a,c) le = fun p -> match p with | PlusZ n -> LeZ n | PlusS p' -> LeS (summandLessThanSum p') ;; (* 3.8 Pattern: Leibniz Equality *) type (_,_) equal = Eq : ('a,'a) equal let convert : type a b. (a,b) equal -> a -> b = fun Eq x -> x let rec sameNat : type a b. a nat -> b nat -> (a,b) equal option = fun a b -> match a, b with | NZ, NZ -> Some Eq | NS a', NS b' -> begin match sameNat a' b' with | Some Eq -> Some Eq | None -> None end | _ -> None ;; (* 3.9 Computing Programs and Properties Simultaneously *) (* Plus and app1 are moved to section 2 *) let smaller : type a b. (a succ, b succ) le -> (a,b) le = function LeS x -> x ;; type (_,_) diff = Diff : 'c nat * ('a,'c,'b) plus -> ('a,'b) diff ;; (* let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff = fun le a b -> match a, b, le with | NZ, m, _ -> Diff (m, PlusZ m) | NS x, NZ, _ -> assert false | NS x, NS y, q -> match diff (smaller q) x y with Diff (m, p) -> Diff (m, PlusS p) ;; *) let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff = fun le a b -> match le, a, b with | LeZ _, _, m -> Diff (m, PlusZ m) | LeS q, NS x, NS y -> match diff q x y with Diff (m, p) -> Diff (m, PlusS p) ;; let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff = fun le a b -> match a, b,le with (* warning *) | NZ, m, LeZ _ -> Diff (m, PlusZ m) | NS x, NS y, LeS q -> match diff q x y with Diff (m, p) -> Diff (m, PlusS p) ;; let rec diff : type a b. (a,b) le -> b nat -> (a,b) diff = fun le b -> match b,le with | m, LeZ _ -> Diff (m, PlusZ m) | NS y, LeS q -> match diff q y with Diff (m, p) -> Diff (m, PlusS p) ;; type (_,_) filter = Filter : ('m,'n) le * ('a,'m) seq -> ('a,'n) filter let rec leS' : type m n. (m,n) le -> (m,n succ) le = function | LeZ n -> LeZ (NS n) | LeS le -> LeS (leS' le) ;; let rec filter : type a n. (a -> bool) -> (a,n) seq -> (a,n) filter = fun f s -> match s with | Snil -> Filter (LeZ NZ, Snil) | Scons (a,l) -> match filter f l with Filter (le, l') -> if f a then Filter (LeS le, Scons (a, l')) else Filter (leS' le, l') ;; (* 4.1 AVL trees *) type (_,_,_) balance = | Less : ('h, 'h succ, 'h succ) balance | Same : ('h, 'h, 'h) balance | More : ('h succ, 'h, 'h succ) balance type _ avl = | Leaf : zero avl | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int * 'hR avl -> 'hMax succ avl type avl' = Avl : 'h avl -> avl' ;; let empty = Avl Leaf let rec elem : type h. int -> h avl -> bool = fun x t -> match t with | Leaf -> false | Node (_, l, y, r) -> x = y || if x < y then elem x l else elem x r ;; let rec rotr : type n. (n succ succ) avl -> int -> n avl -> ((n succ succ) avl, (n succ succ succ) avl) sum = fun tL y tR -> match tL with | Node (Same, a, x, b) -> Inr (Node (Less, a, x, Node (More, b, y, tR))) | Node (More, a, x, b) -> Inl (Node (Same, a, x, Node (Same, b, y, tR))) | Node (Less, a, x, Node (Same, b, z, c)) -> Inl (Node (Same, Node (Same, a, x, b), z, Node (Same, c, y, tR))) | Node (Less, a, x, Node (Less, b, z, c)) -> Inl (Node (Same, Node (More, a, x, b), z, Node (Same, c, y, tR))) | Node (Less, a, x, Node (More, b, z, c)) -> Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR))) ;; let rec rotl : type n. n avl -> int -> (n succ succ) avl -> ((n succ succ) avl, (n succ succ succ) avl) sum = fun tL u tR -> match tR with | Node (Same, a, x, b) -> Inr (Node (More, Node (Less, tL, u, a), x, b)) | Node (Less, a, x, b) -> Inl (Node (Same, Node (Same, tL, u, a), x, b)) | Node (More, Node (Same, a, x, b), y, c) -> Inl (Node (Same, Node (Same, tL, u, a), x, Node (Same, b, y, c))) | Node (More, Node (Less, a, x, b), y, c) -> Inl (Node (Same, Node (More, tL, u, a), x, Node (Same, b, y, c))) | Node (More, Node (More, a, x, b), y, c) -> Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c))) ;; let rec ins : type n. int -> n avl -> (n avl, (n succ) avl) sum = fun x t -> match t with | Leaf -> Inr (Node (Same, Leaf, x, Leaf)) | Node (bal, a, y, b) -> if x = y then Inl t else if x < y then begin match ins x a with | Inl a -> Inl (Node (bal, a, y, b)) | Inr a -> match bal with | Less -> Inl (Node (Same, a, y, b)) | Same -> Inr (Node (More, a, y, b)) | More -> rotr a y b end else begin match ins x b with | Inl b -> Inl (Node (bal, a, y, b) : n avl) | Inr b -> match bal with | More -> Inl (Node (Same, a, y, b) : n avl) | Same -> Inr (Node (Less, a, y, b) : n succ avl) | Less -> rotl a y b end ;; let insert x (Avl t) = match ins x t with | Inl t -> Avl t | Inr t -> Avl t ;; let rec del_min : type n. (n succ) avl -> int * (n avl, (n succ) avl) sum = function | Node (Less, Leaf, x, r) -> (x, Inl r) | Node (Same, Leaf, x, r) -> (x, Inl r) | Node (bal, (Node _ as l) , x, r) -> match del_min l with | y, Inr l -> (y, Inr (Node (bal, l, x, r))) | y, Inl l -> (y, match bal with | Same -> Inr (Node (Less, l, x, r)) | More -> Inl (Node (Same, l, x, r)) | Less -> rotl l x r) type _ avl_del = | Dsame : 'n avl -> 'n avl_del | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del let rec del : type n. int -> n avl -> n avl_del = fun y t -> match t with | Leaf -> Dsame Leaf | Node (bal, l, x, r) -> if x = y then begin match r with | Leaf -> begin match bal with | Same -> Ddecr (Eq, l) | More -> Ddecr (Eq, l) end | Node _ -> begin match bal, del_min r with | _, (z, Inr r) -> Dsame (Node (bal, l, z, r)) | Same, (z, Inl r) -> Dsame (Node (More, l, z, r)) | Less, (z, Inl r) -> Ddecr (Eq, Node (Same, l, z, r)) | More, (z, Inl r) -> match rotr l z r with | Inl t -> Ddecr (Eq, t) | Inr t -> Dsame t end end else if y < x then begin match del y l with | Dsame l -> Dsame (Node (bal, l, x, r)) | Ddecr(Eq,l) -> begin match bal with | Same -> Dsame (Node (Less, l, x, r)) | More -> Ddecr (Eq, Node (Same, l, x, r)) | Less -> match rotl l x r with | Inl t -> Ddecr (Eq, t) | Inr t -> Dsame t end end else begin match del y r with | Dsame r -> Dsame (Node (bal, l, x, r)) | Ddecr(Eq,r) -> begin match bal with | Same -> Dsame (Node (More, l, x, r)) | Less -> Ddecr (Eq, Node (Same, l, x, r)) | More -> match rotr l x r with | Inl t -> Ddecr (Eq, t) | Inr t -> Dsame t end end ;; let delete x (Avl t) = match del x t with | Dsame t -> Avl t | Ddecr (_, t) -> Avl t ;; (* Exercise 22: Red-black trees *) type red type black type (_,_) sub_tree = | Bleaf : (black, zero) sub_tree | Rnode : (black, 'n) sub_tree * int * (black, 'n) sub_tree -> (red, 'n) sub_tree | Bnode : ('cL, 'n) sub_tree * int * ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree type rb_tree = Root : (black, 'n) sub_tree -> rb_tree ;; type dir = LeftD | RightD type (_,_) ctxt = | CNil : (black,'n) ctxt | CRed : int * dir * (black,'n) sub_tree * (red,'n) ctxt -> (black,'n) ctxt | CBlk : int * dir * ('c1,'n) sub_tree * (black, 'n succ) ctxt -> ('c,'n) ctxt ;; let blacken = function Rnode (l, e, r) -> Bnode (l, e, r) type _ crep = | Red : red crep | Black : black crep let color : type c n. (c,n) sub_tree -> c crep = function | Bleaf -> Black | Rnode _ -> Red | Bnode _ -> Black ;; let rec fill : type c n. (c,n) ctxt -> (c,n) sub_tree -> rb_tree = fun ct t -> match ct with | CNil -> Root t | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t)) | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle)) | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t)) | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle)) ;; let recolor d1 pE sib d2 gE uncle t = match d1, d2 with | LeftD, RightD -> Rnode (Bnode (sib, pE, t), gE, uncle) | RightD, RightD -> Rnode (Bnode (t, pE, sib), gE, uncle) | LeftD, LeftD -> Rnode (uncle, gE, Bnode (sib, pE, t)) | RightD, LeftD -> Rnode (uncle, gE, Bnode (t, pE, sib)) ;; let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) = match d1, d2 with | RightD, RightD -> Bnode (Rnode (x,e,y), pE, Rnode (sib, gE, uncle)) | LeftD, RightD -> Bnode (Rnode (sib, pE, x), e, Rnode (y, gE, uncle)) | LeftD, LeftD -> Bnode (Rnode (uncle, gE, sib), pE, Rnode (x,e,y)) | RightD, LeftD -> Bnode (Rnode (uncle, gE, x), e, Rnode (y, pE, sib)) ;; let rec repair : type c n. (red,n) sub_tree -> (c,n) ctxt -> rb_tree = fun t ct -> match ct with | CNil -> Root (blacken t) | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t)) | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib)) | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) -> match color uncle with | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct | Black -> fill ct (rotate dir e sib dir' e' uncle t) ;; let rec ins : type c n. int -> (c,n) sub_tree -> (c,n) ctxt -> rb_tree = fun e t ct -> match t with | Rnode (l, e', r) -> if e < e' then ins e l (CRed (e', RightD, r, ct)) else ins e r (CRed (e', LeftD, l, ct)) | Bnode (l, e', r) -> if e < e' then ins e l (CBlk (e', RightD, r, ct)) else ins e r (CBlk (e', LeftD, l, ct)) | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct ;; let insert e (Root t) = ins e t CNil ;; (* 5.7 typed object languages using GADTs *) type _ term = | Const : int -> int term | Add : (int * int -> int) term | LT : (int * int -> bool) term | Ap : ('a -> 'b) term * 'a term -> 'b term | Pair : 'a term * 'b term -> ('a * 'b) term let ex1 = Ap (Add, Pair (Const 3, Const 5)) let ex2 = Pair (ex1, Const 1) let rec eval_term : type a. a term -> a = function | Const x -> x | Add -> fun (x,y) -> x+y | LT -> fun (x,y) -> x eval_term f (eval_term x) | Pair(x,y) -> (eval_term x, eval_term y) type _ rep = | Rint : int rep | Rbool : bool rep | Rpair : 'a rep * 'b rep -> ('a * 'b) rep | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep type (_,_) equal = Eq : ('a,'a) equal let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = fun ra rb -> match ra, rb with | Rint, Rint -> Some Eq | Rbool, Rbool -> Some Eq | Rpair (a1, a2), Rpair (b1, b2) -> begin match rep_equal a1 b1 with | None -> None | Some Eq -> match rep_equal a2 b2 with | None -> None | Some Eq -> Some Eq end | Rfun (a1, a2), Rfun (b1, b2) -> begin match rep_equal a1 b1 with | None -> None | Some Eq -> match rep_equal a2 b2 with | None -> None | Some Eq -> Some Eq end | _ -> None ;; type assoc = Assoc : string * 'a rep * 'a -> assoc let rec assoc : type a. string -> a rep -> assoc list -> a = fun x r -> function | [] -> raise Not_found | Assoc (x', r', v) :: env -> if x = x' then match rep_equal r r' with | None -> failwith ("Wrong type for " ^ x) | Some Eq -> v else assoc x r env type _ term = | Var : string * 'a rep -> 'a term | Abs : string * 'a rep * 'b term -> ('a -> 'b) term | Const : int -> int term | Add : (int * int -> int) term | LT : (int * int -> bool) term | Ap : ('a -> 'b) term * 'a term -> 'b term | Pair : 'a term * 'b term -> ('a * 'b) term let rec eval_term : type a. assoc list -> a term -> a = fun env -> function | Var (x, r) -> assoc x r env | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e | Const x -> x | Add -> fun (x,y) -> x+y | LT -> fun (x,y) -> x eval_term env f (eval_term env x) | Pair(x,y) -> (eval_term env x, eval_term env y) ;; let ex3 = Abs ("x", Rint, Ap (Add, Pair (Var("x",Rint), Var("x",Rint)))) let ex4 = Ap (ex3, Const 3) let v4 = eval_term [] ex4 ;; (* 5.9/5.10 Language with binding *) type rnil type (_,_,_) rcons type _ is_row = | Rnil : rnil is_row | Rcons : 'c is_row -> ('a,'b,'c) rcons is_row type (_,_) lam = | Const : int -> ('e, int) lam | Var : 'a -> (('a,'t,'e) rcons, 't) lam | Shift : ('e,'t) lam -> (('a,'q,'e) rcons, 't) lam | Abs : 'a * (('a,'s,'e) rcons, 't) lam -> ('e, 's -> 't) lam | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam type x = X type y = Y let ex1 = App (Var X, Shift (Var Y)) let ex2 = Abs (X, Abs (Y, App (Shift (Var X), Var Y))) ;; type _ env = | Enil : rnil env | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env let rec eval_lam : type e t. e env -> (e, t) lam -> t = fun env m -> match env, m with | _, Const n -> n | Econs (_, v, r), Var _ -> v | Econs (_, _, r), Shift e -> eval_lam r e | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body | _, App (f, x) -> eval_lam env f (eval_lam env x) ;; type add = Add type suc = Suc let env0 = Econs (Zero, 0, Econs (Suc, succ, Econs (Add, (+), Enil))) let _0 : (_, int) lam = Var Zero let suc x = App (Shift (Var Suc : (_, int -> int) lam), x) let _1 = suc _0 let _2 = suc _1 let _3 = suc _2 let add = Shift (Shift (Var Add : (_, int -> int -> int) lam)) let double = Abs (X, App (App (Shift add, Var X), Var X)) let ex3 = App (double, _3) ;; let v3 = eval_lam env0 ex3 ;; (* 5.13: Constructing typing derivations at runtime *) (* Modified slightly to use the language of 5.10, since this is more fun. Of course this works also with the language of 5.12. *) type _ rep = | I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep let rec compare : type a b. a rep -> b rep -> (string, (a,b) equal) sum = fun a b -> match a, b with | I, I -> Inr Eq | Ar(x,y), Ar(s,t) -> begin match compare x s with | Inl _ as e -> e | Inr Eq -> match compare y t with | Inl _ as e -> e | Inr Eq as e -> e end | I, Ar _ -> Inl "I <> Ar _" | Ar _, I -> Inl "Ar _ <> I" ;; type term = | C of int | Ab : string * 'a rep * term -> term | Ap of term * term | V of string type _ ctx = | Cnil : rnil ctx | Ccons : 't * string * 'x rep * 'e ctx -> ('t,'x,'e) rcons ctx ;; type _ checked = | Cerror of string | Cok : ('e,'t) lam * 't rep -> 'e checked let rec lookup : type e. string -> e ctx -> e checked = fun name ctx -> match ctx with | Cnil -> Cerror ("Name not found: " ^ name) | Ccons (l,s,t,rs) -> if s = name then Cok (Var l,t) else match lookup name rs with | Cerror m -> Cerror m | Cok (v, t) -> Cok (Shift v, t) ;; let rec tc : type n e. n nat -> e ctx -> term -> e checked = fun n ctx t -> match t with | V s -> lookup s ctx | Ap(f,x) -> begin match tc n ctx f with | Cerror _ as e -> e | Cok (f', ft) -> match tc n ctx x with | Cerror _ as e -> e | Cok (x', xt) -> match ft with | Ar (a, b) -> begin match compare a xt with | Inl s -> Cerror s | Inr Eq -> Cok (App (f',x'), b) end | _ -> Cerror "Non fun in Ap" end | Ab(s,t,body) -> begin match tc (NS n) (Ccons (n, s, t, ctx)) body with | Cerror _ as e -> e | Cok (body', et) -> Cok (Abs (n, body'), Ar (t, et)) end | C m -> Cok (Const m, I) ;; let ctx0 = Ccons (Zero, "0", I, Ccons (Suc, "S", Ar(I,I), Ccons (Add, "+", Ar(I,Ar(I,I)), Cnil))) let ex1 = Ab ("x", I, Ap(Ap(V"+",V"x"),V"x"));; let c1 = tc NZ ctx0 ex1;; let ex2 = Ap (ex1, C 3);; let c2 = tc NZ ctx0 ex2;; let eval_checked env = function | Cerror s -> failwith s | Cok (e, I) -> (eval_lam env e : int) | Cok _ -> failwith "Can only evaluate expressions of type I" ;; let v2 = eval_checked env0 c2 ;; (* 5.12 Soundness *) type pexp type pval type _ mode = | Pexp : pexp mode | Pval : pval mode type (_,_) tarr type tint type (_,_) rel = | IntR : (tint, int) rel | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel type (_,_,_) lam = | Const : ('a,'b) rel * 'b -> (pval, 'env, 'a) lam | Var : 'a -> (pval, ('a,'t,'e) rcons, 't) lam | Shift : ('m,'e,'t) lam -> ('m, ('a,'q,'e) rcons, 't) lam | Lam : 'a * ('m, ('a,'s,'e) rcons, 't) lam -> (pval, 'e, ('s,'t) tarr) lam | App : ('m1, 'e, ('s,'t) tarr) lam * ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam ;; let ex1 = App (Lam (X, Var X), Const (IntR, 3)) let rec mode : type m e t. (m,e,t) lam -> m mode = function | Lam (v, body) -> Pval | Var v -> Pval | Const (r, v) -> Pval | Shift e -> mode e | App _ -> Pexp ;; type (_,_) sub = | Id : ('r,'r) sub | Bind : 't * ('m,'r2,'x) lam * ('r,'r2) sub -> (('t,'x,'r) rcons, 'r2) sub | Push : ('r1,'r2) sub -> (('a,'b,'r1) rcons, ('a,'b,'r2) rcons) sub type (_,_) lam' = Ex : ('m, 's, 't) lam -> ('s,'t) lam' ;; let rec subst : type m1 r t s. (m1,r,t) lam -> (r,s) sub -> (s,t) lam' = fun t s -> match t, s with | _, Id -> Ex t | Const(r,c), sub -> Ex (Const (r,c)) | Var v, Bind (x, e, r) -> Ex e | Var v, Push sub -> Ex (Var v) | Shift e, Bind (_, _, r) -> subst e r | Shift e, Push sub -> (match subst e sub with Ex a -> Ex (Shift a)) | App(f,x), sub -> (match subst f sub, subst x sub with Ex g, Ex y -> Ex (App (g,y))) | Lam(v,x), sub -> (match subst x (Push sub) with Ex body -> Ex (Lam (v, body))) ;; type closed = rnil type 'a rlam = ((pexp,closed,'a) lam, (pval,closed,'a) lam) sum ;; let rec rule : type a b. (pval, closed, (a,b) tarr) lam -> (pval, closed, a) lam -> b rlam = fun v1 v2 -> match v1, v2 with | Lam(x,body), v -> begin match subst body (Bind (x, v, Id)) with Ex term -> match mode term with | Pexp -> Inl term | Pval -> Inr term end | Const (IntTo b, f), Const (IntR, x) -> Inr (Const (b, f x)) ;; let rec onestep : type m t. (m,closed,t) lam -> t rlam = function | Lam (v, body) -> Inr (Lam (v, body)) | Const (r, v) -> Inr (Const (r, v)) | App (e1, e2) -> match mode e1, mode e2 with | Pexp, _-> begin match onestep e1 with | Inl e -> Inl(App(e,e2)) | Inr v -> Inl(App(v,e2)) end | Pval, Pexp -> begin match onestep e2 with | Inl e -> Inl(App(e1,e)) | Inr v -> Inl(App(e1,v)) end | Pval, Pval -> rule e1 e2 ;; mingw-ocaml/ocaml/testsuite/tests/lib-digest/0000755000175000017500000000000012124403241020674 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-digest/Makefile0000644000175000017500000000022312124403241022331 0ustar tootstootsBASEDIR=../.. #MODULES= MAIN_MODULE=md5 ADD_COMPFLAGS=-w a include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-digest/md5.ml0000644000175000017500000002070012124403241021712 0ustar tootstoots(* Test int32 arithmetic and optimizations using the MD5 algorithm *) open Printf type context = { buf: string; mutable pos: int; mutable a: int32; mutable b: int32; mutable c: int32; mutable d: int32; mutable bits: int64 } let step1 w x y z data s = let w = Int32.add (Int32.add w data) (Int32.logxor z (Int32.logand x (Int32.logxor y z))) in Int32.add x (Int32.logor (Int32.shift_left w s) (Int32.shift_right_logical w (32-s))) let step2 w x y z data s = let w = Int32.add (Int32.add w data) (Int32.logxor y (Int32.logand z (Int32.logxor x y))) in Int32.add x (Int32.logor (Int32.shift_left w s) (Int32.shift_right_logical w (32-s))) let step3 w x y z data s = let w = Int32.add (Int32.add w data) (Int32.logxor x (Int32.logxor y z)) in Int32.add x (Int32.logor (Int32.shift_left w s) (Int32.shift_right_logical w (32-s))) let step4 w x y z data s = let w = Int32.add (Int32.add w data) (Int32.logxor y (Int32.logor x (Int32.logxor z (-1l)))) in Int32.add x (Int32.logor (Int32.shift_left w s) (Int32.shift_right_logical w (32-s))) let transform ctx data = let a = ctx.a and b = ctx.b and c = ctx.c and d = ctx.d in let a = step1 a b c d (Int32.add data.(0) 0xd76aa478l) 7 in let d = step1 d a b c (Int32.add data.(1) 0xe8c7b756l) 12 in let c = step1 c d a b (Int32.add data.(2) 0x242070dbl) 17 in let b = step1 b c d a (Int32.add data.(3) 0xc1bdceeel) 22 in let a = step1 a b c d (Int32.add data.(4) 0xf57c0fafl) 7 in let d = step1 d a b c (Int32.add data.(5) 0x4787c62al) 12 in let c = step1 c d a b (Int32.add data.(6) 0xa8304613l) 17 in let b = step1 b c d a (Int32.add data.(7) 0xfd469501l) 22 in let a = step1 a b c d (Int32.add data.(8) 0x698098d8l) 7 in let d = step1 d a b c (Int32.add data.(9) 0x8b44f7afl) 12 in let c = step1 c d a b (Int32.add data.(10) 0xffff5bb1l) 17 in let b = step1 b c d a (Int32.add data.(11) 0x895cd7bel) 22 in let a = step1 a b c d (Int32.add data.(12) 0x6b901122l) 7 in let d = step1 d a b c (Int32.add data.(13) 0xfd987193l) 12 in let c = step1 c d a b (Int32.add data.(14) 0xa679438el) 17 in let b = step1 b c d a (Int32.add data.(15) 0x49b40821l) 22 in let a = step2 a b c d (Int32.add data.(1) 0xf61e2562l) 5 in let d = step2 d a b c (Int32.add data.(6) 0xc040b340l) 9 in let c = step2 c d a b (Int32.add data.(11) 0x265e5a51l) 14 in let b = step2 b c d a (Int32.add data.(0) 0xe9b6c7aal) 20 in let a = step2 a b c d (Int32.add data.(5) 0xd62f105dl) 5 in let d = step2 d a b c (Int32.add data.(10) 0x02441453l) 9 in let c = step2 c d a b (Int32.add data.(15) 0xd8a1e681l) 14 in let b = step2 b c d a (Int32.add data.(4) 0xe7d3fbc8l) 20 in let a = step2 a b c d (Int32.add data.(9) 0x21e1cde6l) 5 in let d = step2 d a b c (Int32.add data.(14) 0xc33707d6l) 9 in let c = step2 c d a b (Int32.add data.(3) 0xf4d50d87l) 14 in let b = step2 b c d a (Int32.add data.(8) 0x455a14edl) 20 in let a = step2 a b c d (Int32.add data.(13) 0xa9e3e905l) 5 in let d = step2 d a b c (Int32.add data.(2) 0xfcefa3f8l) 9 in let c = step2 c d a b (Int32.add data.(7) 0x676f02d9l) 14 in let b = step2 b c d a (Int32.add data.(12) 0x8d2a4c8al) 20 in let a = step3 a b c d (Int32.add data.(5) 0xfffa3942l) 4 in let d = step3 d a b c (Int32.add data.(8) 0x8771f681l) 11 in let c = step3 c d a b (Int32.add data.(11) 0x6d9d6122l) 16 in let b = step3 b c d a (Int32.add data.(14) 0xfde5380cl) 23 in let a = step3 a b c d (Int32.add data.(1) 0xa4beea44l) 4 in let d = step3 d a b c (Int32.add data.(4) 0x4bdecfa9l) 11 in let c = step3 c d a b (Int32.add data.(7) 0xf6bb4b60l) 16 in let b = step3 b c d a (Int32.add data.(10) 0xbebfbc70l) 23 in let a = step3 a b c d (Int32.add data.(13) 0x289b7ec6l) 4 in let d = step3 d a b c (Int32.add data.(0) 0xeaa127fal) 11 in let c = step3 c d a b (Int32.add data.(3) 0xd4ef3085l) 16 in let b = step3 b c d a (Int32.add data.(6) 0x04881d05l) 23 in let a = step3 a b c d (Int32.add data.(9) 0xd9d4d039l) 4 in let d = step3 d a b c (Int32.add data.(12) 0xe6db99e5l) 11 in let c = step3 c d a b (Int32.add data.(15) 0x1fa27cf8l) 16 in let b = step3 b c d a (Int32.add data.(2) 0xc4ac5665l) 23 in let a = step4 a b c d (Int32.add data.(0) 0xf4292244l) 6 in let d = step4 d a b c (Int32.add data.(7) 0x432aff97l) 10 in let c = step4 c d a b (Int32.add data.(14) 0xab9423a7l) 15 in let b = step4 b c d a (Int32.add data.(5) 0xfc93a039l) 21 in let a = step4 a b c d (Int32.add data.(12) 0x655b59c3l) 6 in let d = step4 d a b c (Int32.add data.(3) 0x8f0ccc92l) 10 in let c = step4 c d a b (Int32.add data.(10) 0xffeff47dl) 15 in let b = step4 b c d a (Int32.add data.(1) 0x85845dd1l) 21 in let a = step4 a b c d (Int32.add data.(8) 0x6fa87e4fl) 6 in let d = step4 d a b c (Int32.add data.(15) 0xfe2ce6e0l) 10 in let c = step4 c d a b (Int32.add data.(6) 0xa3014314l) 15 in let b = step4 b c d a (Int32.add data.(13) 0x4e0811a1l) 21 in let a = step4 a b c d (Int32.add data.(4) 0xf7537e82l) 6 in let d = step4 d a b c (Int32.add data.(11) 0xbd3af235l) 10 in let c = step4 c d a b (Int32.add data.(2) 0x2ad7d2bbl) 15 in let b = step4 b c d a (Int32.add data.(9) 0xeb86d391l) 21 in ctx.a <- Int32.add ctx.a a; ctx.b <- Int32.add ctx.b b; ctx.c <- Int32.add ctx.c c; ctx.d <- Int32.add ctx.d d let string_to_data s = let data = Array.make 16 0l in for i = 0 to 15 do let j = i lsl 2 in data.(i) <- Int32.logor (Int32.shift_left (Int32.of_int (Char.code s.[j+3])) 24) (Int32.logor (Int32.shift_left (Int32.of_int (Char.code s.[j+2])) 16) (Int32.logor (Int32.shift_left (Int32.of_int (Char.code s.[j+1])) 8) (Int32.of_int (Char.code s.[j])))) done; data let int32_to_string n s i = s.[i+3] <- Char.chr (Int32.to_int (Int32.shift_right n 24) land 0xFF); s.[i+2] <- Char.chr (Int32.to_int (Int32.shift_right n 16) land 0xFF); s.[i+1] <- Char.chr (Int32.to_int (Int32.shift_right n 8) land 0xFF); s.[i] <- Char.chr (Int32.to_int n land 0xFF) let init () = { buf = String.create 64; pos = 0; a = 0x67452301l; b = 0xefcdab89l; c = 0x98badcfel; d = 0x10325476l; bits = 0L } let update ctx input ofs len = let rec upd ofs len = if len <= 0 then () else if ctx.pos + len < 64 then begin (* Just buffer the data *) String.blit input ofs ctx.buf ctx.pos len; ctx.pos <- ctx.pos + len end else begin (* Fill the buffer *) let len' = 64 - ctx.pos in if len' > 0 then String.blit input ofs ctx.buf ctx.pos len'; (* Transform 64 bytes *) transform ctx (string_to_data ctx.buf); ctx.pos <- 0; upd (ofs + len') (len - len') end in upd ofs len; ctx.bits <- Int64.add ctx.bits (Int64.of_int (len lsl 3)) let finish ctx = let padding = String.make 64 '\000' in padding.[0] <- '\x80'; let numbits = ctx.bits in if ctx.pos < 56 then begin update ctx padding 0 (56 - ctx.pos) end else begin update ctx padding 0 (64 + 56 - ctx.pos) end; assert (ctx.pos = 56); let data = string_to_data ctx.buf in data.(14) <- (Int64.to_int32 numbits); data.(15) <- (Int64.to_int32 (Int64.shift_right_logical numbits 32)); transform ctx data; let res = String.create 16 in int32_to_string ctx.a res 0; int32_to_string ctx.b res 4; int32_to_string ctx.c res 8; int32_to_string ctx.d res 12; res let test s = let ctx = init() in update ctx s 0 (String.length s); let res = finish ctx in let exp = Digest.string s in let ok = (res = exp) in if not ok then Printf.printf "Failure for '%s'\n" s; ok let time msg iter fn = let start = Sys.time() in for i = 1 to iter do fn () done; let stop = Sys.time() in printf "%s: %.2f s\n" msg (stop -. start) let _ = (* Test *) if test "" && test "a" && test "abc" && test "message digest" && test "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" then printf "Test vectors passed.\n"; flush stdout; (* Benchmark *) if (Array.length Sys.argv) > 1 && (Sys.argv.(1) = "-benchmark") then begin let s = String.make 50000 'a' in let num_iter = 1000 in time "OCaml implementation" num_iter (fun () -> let ctx = init() in update ctx s 0 (String.length s); ignore (finish ctx)); time "C implementation" num_iter (fun () -> ignore (Digest.string s)) end mingw-ocaml/ocaml/testsuite/tests/lib-digest/md5.reference0000644000175000017500000000002512124403241023236 0ustar tootstootsTest vectors passed. mingw-ocaml/ocaml/testsuite/tests/typing-recmod/0000755000175000017500000000000012124403241021432 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-recmod/t22ok.mli0000644000175000017500000000671312124403241023105 0ustar tootstootsmodule rec A : sig type t = Leaf of int | Node of ASet.t val compare : t -> t -> int end and ASet : Set.S with type elt = A.t module Fib : sig val f : int -> int end module After : sig val x : int end module Before : sig val x : int end module Strengthen : sig type t val f : t -> t end module Strengthen2 : sig type t val f : t -> t module M : sig type u end module R : sig type v end end module PolyRec : sig type 'a t = Leaf of 'a | Node of 'a list t * 'a list t val depth : 'a t -> int end module StringSet : Set.S with type elt = string module rec Expr : sig type t = Var of string | Const of int | Add of t * t | Binding of Binding.t * t val make_let : string -> t -> t -> t val fv : t -> StringSet.t val simpl : t -> t end and Binding : sig type t = (string * Expr.t) list val fv : t -> StringSet.t val bv : t -> StringSet.t val simpl : t -> t end module type ORDERED = sig type t val eq : t -> t -> bool val lt : t -> t -> bool val leq : t -> t -> bool end module type HEAP = sig module Elem : ORDERED type heap val empty : heap val isEmpty : heap -> bool val insert : Elem.t -> heap -> heap val merge : heap -> heap -> heap val findMin : heap -> Elem.t val deleteMin : heap -> heap end module Bootstrap : functor (MakeH : functor (Element : ORDERED) -> sig module Elem : sig type t = Element.t val eq : t -> t -> bool val lt : t -> t -> bool val leq : t -> t -> bool end type heap val empty : heap val isEmpty : heap -> bool val insert : Elem.t -> heap -> heap val merge : heap -> heap -> heap val findMin : heap -> Elem.t val deleteMin : heap -> heap end) -> functor (Element : ORDERED) -> sig module Elem : sig type t = Element.t val eq : t -> t -> bool val lt : t -> t -> bool val leq : t -> t -> bool end type heap val empty : heap val isEmpty : heap -> bool val insert : Elem.t -> heap -> heap val merge : heap -> heap -> heap val findMin : heap -> Elem.t val deleteMin : heap -> heap end module LeftistHeap : functor (Element : ORDERED) -> sig module Elem : sig type t = Element.t val eq : t -> t -> bool val lt : t -> t -> bool val leq : t -> t -> bool end type heap val empty : heap val isEmpty : heap -> bool val insert : Elem.t -> heap -> heap val merge : heap -> heap -> heap val findMin : heap -> Elem.t val deleteMin : heap -> heap end module Ints : sig type t = int val eq : 'a -> 'a -> bool val lt : 'a -> 'a -> bool val leq : 'a -> 'a -> bool end module C : sig module Elem : sig type t = Ints.t val eq : t -> t -> bool val lt : t -> t -> bool val leq : t -> t -> bool end type heap = Bootstrap(LeftistHeap)(Ints).heap val empty : heap val isEmpty : heap -> bool val insert : Elem.t -> heap -> heap val merge : heap -> heap -> heap val findMin : heap -> Elem.t val deleteMin : heap -> heap end mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t16ok.ml0000644000175000017500000000136612124403241022736 0ustar tootstoots(* PR#4450 *) module PR_4450_1 = struct module type MyT = sig type 'a t = Succ of 'a t end module MyMap(X : MyT) = X module rec MyList : MyT = MyMap(MyList) end;; module PR_4450_2 = struct module type MyT = sig type 'a wrap = My of 'a t and 'a t = private < map : 'b. ('a -> 'b) ->'b wrap; .. > val create : 'a list -> 'a t end module MyMap(X : MyT) = struct include X class ['a] c l = object (self) method map : 'b. ('a -> 'b) -> 'b wrap = fun f -> My (create (List.map f l)) end end module rec MyList : sig type 'a wrap = My of 'a t and 'a t = < map : 'b. ('a -> 'b) ->'b wrap > val create : 'a list -> 'a t end = struct include MyMap(MyList) let create l = new c l end end;; mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t02bad.ml0000644000175000017500000000022012124403241023032 0ustar tootstoots(* Bad (t = t) *) module rec A : sig type t = B.t end = struct type t = B.t end and B : sig type t = A.t end = struct type t = A.t end;; mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t18ok.ml0000644000175000017500000000062012124403241022730 0ustar tootstoots(* PR 4470: simplified from OMake's sources *) module rec DirElt : sig type t = DirRoot | DirSub of DirHash.t end = struct type t = DirRoot | DirSub of DirHash.t end and DirCompare : sig type t = DirElt.t end = struct type t = DirElt.t end and DirHash : sig type t = DirElt.t list end = struct type t = DirCompare.t list end mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t03ok.ml0000644000175000017500000000022112124403241022717 0ustar tootstoots(* OK (t = int) *) module rec A : sig type t = B.t end = struct type t = B.t end and B : sig type t = int end = struct type t = int end;; mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t19ok.ml0000644000175000017500000000037112124403241022734 0ustar tootstoots(* PR 4758, PR 4266 *) module PR_4758 = struct module type S = sig end module type Mod = sig module Other : S end module rec A : S = struct end and C : sig include Mod with module Other = A end = struct module Other = A end end mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t04bad.ml0000644000175000017500000000014412124403241023041 0ustar tootstoots(* Bad (t = int * t) *) module rec A : sig type t = int * A.t end = struct type t = int * A.t end;; mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t22ok.ml0000644000175000017500000002674512124403241022743 0ustar tootstoots(* Tests for recursive modules *) let test number result expected = if result = expected then Printf.printf "Test %d passed.\n" number else Printf.printf "Test %d FAILED.\n" number; flush stdout (* Tree of sets *) module rec A : sig type t = Leaf of int | Node of ASet.t val compare: t -> t -> int end = struct type t = Leaf of int | Node of ASet.t let compare x y = match (x,y) with (Leaf i, Leaf j) -> Pervasives.compare i j | (Leaf i, Node t) -> -1 | (Node s, Leaf j) -> 1 | (Node s, Node t) -> ASet.compare s t end and ASet : Set.S with type elt = A.t = Set.Make(A) ;; let _ = let x = A.Node (ASet.add (A.Leaf 3) (ASet.singleton (A.Leaf 2))) in let y = A.Node (ASet.add (A.Leaf 1) (ASet.singleton x)) in test 10 (A.compare x x) 0; test 11 (A.compare x (A.Leaf 3)) 1; test 12 (A.compare (A.Leaf 0) x) (-1); test 13 (A.compare y y) 0; test 14 (A.compare x y) 1 ;; (* Simple value recursion *) module rec Fib : sig val f : int -> int end = struct let f x = if x < 2 then 1 else Fib.f(x-1) + Fib.f(x-2) end ;; let _ = test 20 (Fib.f 10) 89 ;; (* Update function by infix *) module rec Fib2 : sig val f : int -> int end = struct let rec g x = Fib2.f(x-1) + Fib2.f(x-2) and f x = if x < 2 then 1 else g x end ;; let _ = test 21 (Fib2.f 10) 89 ;; (* Early application *) let _ = let res = try let module A = struct module rec Bad : sig val f : int -> int end = struct let f = let y = Bad.f 5 in fun x -> x+y end end in false with Undefined_recursive_module _ -> true in test 30 res true ;; (* Early strict evaluation *) (* module rec Cyclic : sig val x : int end = struct let x = Cyclic.x + 1 end ;; *) (* Reordering of evaluation based on dependencies *) module rec After : sig val x : int end = struct let x = Before.x + 1 end and Before : sig val x : int end = struct let x = 3 end ;; let _ = test 40 After.x 4 ;; (* Type identity between A.t and t within A's definition *) module rec Strengthen : sig type t val f : t -> t end = struct type t = A | B let _ = (A : Strengthen.t) let f x = if true then A else Strengthen.f B end ;; module rec Strengthen2 : sig type t val f : t -> t module M : sig type u end module R : sig type v end end = struct type t = A | B let _ = (A : Strengthen2.t) let f x = if true then A else Strengthen2.f B module M = struct type u = C let _ = (C: Strengthen2.M.u) end module rec R : sig type v = Strengthen2.R.v end = struct type v = D let _ = (D : R.v) let _ = (D : Strengthen2.R.v) end end ;; (* Polymorphic recursion *) module rec PolyRec : sig type 'a t = Leaf of 'a | Node of 'a list t * 'a list t val depth: 'a t -> int end = struct type 'a t = Leaf of 'a | Node of 'a list t * 'a list t let x = (PolyRec.Leaf 1 : int t) let depth = function Leaf x -> 0 | Node(l,r) -> 1 + max (PolyRec.depth l) (PolyRec.depth r) end ;; (* Wrong LHS signatures (PR#4336) *) (* module type ASig = sig type a val a:a val print:a -> unit end module type BSig = sig type b val b:b val print:b -> unit end module A = struct type a = int let a = 0 let print = print_int end module B = struct type b = float let b = 0.0 let print = print_float end module MakeA (Empty:sig end) : ASig = A module MakeB (Empty:sig end) : BSig = B module rec NewA : ASig = MakeA (struct end) and NewB : BSig with type b = NewA.a = MakeB (struct end);; *) (* Expressions and bindings *) module StringSet = Set.Make(String);; module rec Expr : sig type t = Var of string | Const of int | Add of t * t | Binding of Binding.t * t val make_let: string -> t -> t -> t val fv: t -> StringSet.t val simpl: t -> t end = struct type t = Var of string | Const of int | Add of t * t | Binding of Binding.t * t let make_let id e1 e2 = Binding([id, e1], e2) let rec fv = function Var s -> StringSet.singleton s | Const n -> StringSet.empty | Add(t1,t2) -> StringSet.union (fv t1) (fv t2) | Binding(b,t) -> StringSet.union (Binding.fv b) (StringSet.diff (fv t) (Binding.bv b)) let rec simpl = function Var s -> Var s | Const n -> Const n | Add(Const i, Const j) -> Const (i+j) | Add(Const 0, t) -> simpl t | Add(t, Const 0) -> simpl t | Add(t1,t2) -> Add(simpl t1, simpl t2) | Binding(b, t) -> Binding(Binding.simpl b, simpl t) end and Binding : sig type t = (string * Expr.t) list val fv: t -> StringSet.t val bv: t -> StringSet.t val simpl: t -> t end = struct type t = (string * Expr.t) list let fv b = List.fold_left (fun v (id,e) -> StringSet.union v (Expr.fv e)) StringSet.empty b let bv b = List.fold_left (fun v (id,e) -> StringSet.add id v) StringSet.empty b let simpl b = List.map (fun (id,e) -> (id, Expr.simpl e)) b end ;; let _ = let e = Expr.make_let "x" (Expr.Add (Expr.Var "y", Expr.Const 0)) (Expr.Var "x") in let e' = Expr.make_let "x" (Expr.Var "y") (Expr.Var "x") in test 50 (StringSet.elements (Expr.fv e)) ["y"]; test 51 (Expr.simpl e) e' ;; (* Okasaki's bootstrapping *) module type ORDERED = sig type t val eq: t -> t -> bool val lt: t -> t -> bool val leq: t -> t -> bool end module type HEAP = sig module Elem: ORDERED type heap val empty: heap val isEmpty: heap -> bool val insert: Elem.t -> heap -> heap val merge: heap -> heap -> heap val findMin: heap -> Elem.t val deleteMin: heap -> heap end module Bootstrap (MakeH: functor (Element:ORDERED) -> HEAP with module Elem = Element) (Element: ORDERED) : HEAP with module Elem = Element = struct module Elem = Element module rec BE : sig type t = E | H of Elem.t * PrimH.heap val eq: t -> t -> bool val lt: t -> t -> bool val leq: t -> t -> bool end = struct type t = E | H of Elem.t * PrimH.heap let leq t1 t2 = match t1, t2 with | (H(x, _)), (H(y, _)) -> Elem.leq x y | H _, E -> false | E, H _ -> true | E, E -> true let eq t1 t2 = match t1, t2 with | (H(x, _)), (H(y, _)) -> Elem.eq x y | H _, E -> false | E, H _ -> false | E, E -> true let lt t1 t2 = match t1, t2 with | (H(x, _)), (H(y, _)) -> Elem.lt x y | H _, E -> false | E, H _ -> true | E, E -> false end and PrimH : HEAP with type Elem.t = BE.t = MakeH(BE) type heap = BE.t let empty = BE.E let isEmpty = function BE.E -> true | _ -> false let rec merge x y = match (x,y) with (BE.E, _) -> y | (_, BE.E) -> x | (BE.H(e1,p1) as h1), (BE.H(e2,p2) as h2) -> if Elem.leq e1 e2 then BE.H(e1, PrimH.insert h2 p1) else BE.H(e2, PrimH.insert h1 p2) let insert x h = merge (BE.H(x, PrimH.empty)) h let findMin = function BE.E -> raise Not_found | BE.H(x, _) -> x let deleteMin = function BE.E -> raise Not_found | BE.H(x, p) -> if PrimH.isEmpty p then BE.E else begin match PrimH.findMin p with | (BE.H(y, p1)) -> let p2 = PrimH.deleteMin p in BE.H(y, PrimH.merge p1 p2) | BE.E -> assert false end end ;; module LeftistHeap(Element: ORDERED): HEAP with module Elem = Element = struct module Elem = Element type heap = E | T of int * Elem.t * heap * heap let rank = function E -> 0 | T(r,_,_,_) -> r let make x a b = if rank a >= rank b then T(rank b + 1, x, a, b) else T(rank a + 1, x, b, a) let empty = E let isEmpty = function E -> true | _ -> false let rec merge h1 h2 = match (h1, h2) with (_, E) -> h1 | (E, _) -> h2 | (T(_, x1, a1, b1), T(_, x2, a2, b2)) -> if Elem.leq x1 x2 then make x1 a1 (merge b1 h2) else make x2 a2 (merge h1 b2) let insert x h = merge (T(1, x, E, E)) h let findMin = function E -> raise Not_found | T(_, x, _, _) -> x let deleteMin = function E -> raise Not_found | T(_, x, a, b) -> merge a b end ;; module Ints = struct type t = int let eq = (=) let lt = (<) let leq = (<=) end ;; module C = Bootstrap(LeftistHeap)(Ints);; let _ = let h = List.fold_right C.insert [6;4;8;7;3;1] C.empty in test 60 (C.findMin h) 1; test 61 (C.findMin (C.deleteMin h)) 3; test 62 (C.findMin (C.deleteMin (C.deleteMin h))) 4 ;; (* Classes *) module rec Class1 : sig class c : object method m : int -> int end end = struct class c = object method m x = if x <= 0 then x else (new Class2.d)#m x end end and Class2 : sig class d : object method m : int -> int end end = struct class d = object(self) inherit Class1.c as super method m (x:int) = super#m 0 end end ;; let _ = test 70 ((new Class1.c)#m 7) 0 ;; let _ = try let module A = struct module rec BadClass1 : sig class c : object method m : int end end = struct class c = object method m = 123 end end and BadClass2 : sig val x: int end = struct let x = (new BadClass1.c)#m end end in test 71 true false with Undefined_recursive_module _ -> test 71 true true ;; (* Coercions *) module rec Coerce1 : sig val g: int -> int val f: int -> int end = struct module A = (Coerce1: sig val f: int -> int end) let g x = x let f x = if x <= 0 then 1 else A.f (x-1) * x end ;; let _ = test 80 (Coerce1.f 10) 3628800 ;; module CoerceF(S: sig end) = struct let f1 () = 1 let f2 () = 2 let f3 () = 3 let f4 () = 4 let f5 () = 5 end module rec Coerce2: sig val f1: unit -> int end = CoerceF(Coerce3) and Coerce3: sig end = struct end ;; let _ = test 81 (Coerce2.f1 ()) 1 ;; module Coerce4(A : sig val f : int -> int end) = struct let x = 0 let at a = A.f a end module rec Coerce5 : sig val blabla: int -> int val f: int -> int end = struct let blabla x = 0 let f x = 5 end and Coerce6 : sig val at: int -> int end = Coerce4(Coerce5) let _ = test 82 (Coerce6.at 100) 5 ;; (* Miscellaneous bug reports *) module rec F : sig type t = X of int | Y of int val f: t -> bool end = struct type t = X of int | Y of int let f = function | X _ -> false | _ -> true end;; let _ = test 100 (F.f (F.X 1)) false; test 101 (F.f (F.Y 2)) true (* PR#4316 *) module G(S : sig val x : int Lazy.t end) = struct include S end module M1 = struct let x = lazy 3 end let _ = Lazy.force M1.x module rec M2 : sig val x : int Lazy.t end = G(M1) let _ = test 102 (Lazy.force M2.x) 3 let _ = Gc.full_major() (* will shortcut forwarding in M1.x *) module rec M3 : sig val x : int Lazy.t end = G(M1) let _ = test 103 (Lazy.force M3.x) 3 (** Pure type-checking tests: see recmod/*.ml *) mingw-ocaml/ocaml/testsuite/tests/typing-recmod/Makefile0000644000175000017500000000014712124403241023074 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.okbad include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t17ok.ml0000644000175000017500000000170212124403241022731 0ustar tootstoots(* A synthetic example of bootstrapped data structure (suggested by J-C Filliatre) *) module type ORD = sig type t val compare : t -> t -> int end module type SET = sig type elt type t val iter : (elt -> unit) -> t -> unit end type 'a tree = E | N of 'a tree * 'a * 'a tree module Bootstrap2 (MakeDiet : functor (X: ORD) -> SET with type t = X.t tree and type elt = X.t) : SET with type elt = int = struct type elt = int module rec Elt : sig type t = I of int * int | D of int * Diet.t * int val compare : t -> t -> int val iter : (int -> unit) -> t -> unit end = struct type t = I of int * int | D of int * Diet.t * int let compare x1 x2 = 0 let rec iter f = function | I (l, r) -> for i = l to r do f i done | D (_, d, _) -> Diet.iter (iter f) d end and Diet : SET with type t = Elt.t tree and type elt = Elt.t = MakeDiet(Elt) type t = Diet.t let iter f = Diet.iter (Elt.iter f) end mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t08bad.ml0000644000175000017500000000036112124403241023046 0ustar tootstoots(* Bad (not regular) *) module rec A : sig type 'a t = end = struct type 'a t = end and B : sig type 'a t = 'a A.t end = struct type 'a t = 'a A.t end;; mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t14bad.ml0000644000175000017500000000035412124403241023045 0ustar tootstoots(* Bad - PR 4261 *) module PR_4261 = struct module type S = sig type t end module type T = sig module D : S type t = D.t end module rec U : T with module D = U' = U and U' : S with type t = U'.t = U end;; mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t13ok.ml0000644000175000017500000000034112124403241022723 0ustar tootstoots(* OK *) class type [ 'node ] extension = object method node : 'node end class type [ 'ext ] node = object constraint 'ext = 'ext node #extension end class x = object method node : x node = assert false end type t = x node;; mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t21ok.ml0000644000175000017500000000107312124403241022725 0ustar tootstootsmodule F ( X : Set.OrderedType ) = struct module rec Mod : sig module XSet : sig type elt = X.t type t = Set.Make( X ).t end module XMap : sig type key = X.t type 'a t = 'a Map.Make(X).t end type elt = X.t type t = XSet.t XMap.t val compare: t -> t -> int end = struct module XSet = Set.Make( X ) module XMap = Map.Make( X ) type elt = X.t type t = XSet.t XMap.t let compare = (fun x y -> 0) end and ModSet : Set.S with type elt = Mod.t = Set.Make( Mod ) end mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t06ok.ml0000644000175000017500000000023312124403241022725 0ustar tootstoots(* OK (t = ) *) module rec A : sig type t = end = struct type t = end and B : sig type t = A.t end = struct type t = A.t end;; mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t09bad.ml0000644000175000017500000000037612124403241023055 0ustar tootstoots(* Bad (not regular) *) module rec A : sig type 'a t = 'a B.t end = struct type 'a t = 'a B.t end and B : sig type 'a t = end = struct type 'a t = end;; mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t05bad.ml0000644000175000017500000000024512124403241023044 0ustar tootstoots(* Bad (t = t -> int) *) module rec A : sig type t = B.t -> int end = struct type t = B.t -> int end and B : sig type t = A.t end = struct type t = A.t end;; mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t10ok.ml0000644000175000017500000000035312124403241022723 0ustar tootstoots(* OK *) module rec A : sig type 'a t = 'a array B.t * 'a list B.t end = struct type 'a t = 'a array B.t * 'a list B.t end and B : sig type 'a t = end = struct type 'a t = end;; mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t15bad.ml0000644000175000017500000000017212124403241023044 0ustar tootstoots(* Bad - PR 4512 *) module type S' = sig type t = int end module rec M : S' with type t = M.t = struct type t = M.t end;; mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t20ok.ml0000644000175000017500000000123112124403241022720 0ustar tootstoots(* PR 4557 *) module PR_4557 = struct module F ( X : Set.OrderedType ) = struct module rec Mod : sig module XSet : sig type elt = X.t type t = Set.Make( X ).t end module XMap : sig type key = X.t type 'a t = 'a Map.Make(X).t end type elt = X.t type t = XSet.t XMap.t val compare: t -> t -> int end = struct module XSet = Set.Make( X ) module XMap = Map.Make( X ) type elt = X.t type t = XSet.t XMap.t let compare = (fun x y -> 0) end and ModSet : Set.S with type elt = Mod.t = Set.Make( Mod ) end end mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t12bad.ml0000644000175000017500000000044212124403241023041 0ustar tootstoots(* Bad (not regular) *) module rec M : sig class ['a] c : 'a -> object method map : ('a -> 'b) -> 'b M.c end end = struct class ['a] c (x : 'a) = object method map : 'b. ('a -> 'b) -> 'b M.c = fun f -> new M.c (f x) end end;; mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t11bad.ml0000644000175000017500000000035012124403241023036 0ustar tootstoots(* Bad (not regular) *) module rec A : sig type 'a t = 'a list B.t end = struct type 'a t = 'a list B.t end and B : sig type 'a t = end = struct type 'a t = end;; mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t07bad.ml0000644000175000017500000000020512124403241023042 0ustar tootstoots(* Bad (not regular) *) module rec A : sig type 'a t = end = struct type 'a t = end;; mingw-ocaml/ocaml/testsuite/tests/typing-recmod/t01bad.ml0000644000175000017500000000012212124403241023032 0ustar tootstoots(* Bad (t = t) *) module rec A : sig type t = A.t end = struct type t = A.t end;; mingw-ocaml/ocaml/testsuite/tests/lib-systhreads/0000755000175000017500000000000012124403241021606 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-systhreads/testfork.reference0000644000175000017500000000013512124403241025326 0ustar tootstootsForking... In parent... In child... Child did minor GC. Child is exiting. Parent is exiting. mingw-ocaml/ocaml/testsuite/tests/lib-systhreads/Makefile0000644000175000017500000000022712124403241023247 0ustar tootstootsBASEDIR=../.. LIBRARIES=unix threads ADD_COMPFLAGS=-thread include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-systhreads/testfork.ml0000644000175000017500000000143712124403241024006 0ustar tootstoots(* POSIX threads and fork() *) let compute_thread c = ignore c (* while true do print_char c; flush stdout; for i = 1 to 100000 do ignore(ref []) done done *) let main () = ignore(Thread.create compute_thread '1'); Thread.delay 1.0; print_string "Forking..."; print_newline(); match Unix.fork() with | 0 -> Thread.delay 0.5; print_string "In child..."; print_newline(); Gc.minor(); print_string "Child did minor GC."; print_newline(); ignore(Thread.create compute_thread '2'); Thread.delay 1.0; print_string "Child is exiting."; print_newline(); exit 0 | pid -> print_string "In parent..."; print_newline(); Thread.delay 4.0; print_string "Parent is exiting."; print_newline(); exit 0 let _ = main() mingw-ocaml/ocaml/testsuite/tests/basic-private/0000755000175000017500000000000012124403241021402 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/basic-private/tlength.ml0000644000175000017500000000074512124403241023407 0ustar tootstoots(* $Id$ A testbed file for private type abbreviation definitions. We test the Length module that implements positive integers. *) (* We can build a null length. *) let l = Length.make 0;; (* We cannot build a negative length. *) try ignore (Length.make (-1)); assert false with | Failure _ -> () ;; (* We can build a positive length. *) let l3 = Length.make 3 in (* and use the associated injection and projection functions. *) Length.make (Length.from l3 + Length.from l3);; mingw-ocaml/ocaml/testsuite/tests/basic-private/Makefile0000644000175000017500000000021212124403241023035 0ustar tootstootsBASEDIR=../.. MODULES=length MAIN_MODULE=tlength include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/basic-private/length.ml0000644000175000017500000000044712124403241023222 0ustar tootstoots(* $Id$ A testbed file for private type abbreviation definitions. We define a Length module to implement positive integers. *) type t = int;; let make x = if x >= 0 then x else failwith (Printf.sprintf "cannot build negative length : %i" x) ;; external from : t -> int = "%identity";; mingw-ocaml/ocaml/testsuite/tests/basic-private/length.mli0000644000175000017500000000033312124403241023365 0ustar tootstoots(* $Id$ A testbed file for private type abbreviation definitions. We define a Length module to implement positive integers. *) type t = private int;; val make : int -> t;; external from : t -> int = "%identity";; mingw-ocaml/ocaml/testsuite/tests/basic-private/tlength.reference0000644000175000017500000000000012124403241024715 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-poly/0000755000175000017500000000000012124403241021144 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-poly/Makefile0000644000175000017500000000015212124403241022602 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-poly/poly.ml0000644000175000017500000004212212124403241022462 0ustar tootstoots(* $Id$ *) (* Polymorphic methods are now available in the main branch. Enjoy. *) (* Tests for explicit polymorphism *) open StdLabels;; type 'a t = { t : 'a };; type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b };; let f l = { fold = List.fold_left l };; (f [1;2;3]).fold ~f:(+) ~init:0;; class ['b] ilist l = object val l = l method add x = {< l = x :: l >} method fold : 'a. f:('a -> 'b -> 'a) -> init:'a -> 'a = List.fold_left l end ;; class virtual ['a] vlist = object (_ : 'self) method virtual add : 'a -> 'self method virtual fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b end ;; class ilist2 l = object inherit [int] vlist val l = l method add x = {< l = x :: l >} method fold = List.fold_left l end ;; let ilist2 l = object inherit [_] vlist val l = l method add x = {< l = x :: l >} method fold = List.fold_left l end ;; class ['a] ilist3 l = object inherit ['a] vlist val l = l method add x = {< l = x :: l >} method fold = List.fold_left l end ;; class ['a] ilist4 (l : 'a list) = object val l = l method virtual add : _ method add x = {< l = x :: l >} method virtual fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b method fold = List.fold_left l end ;; class ['a] ilist5 (l : 'a list) = object (self) val l = l method add x = {< l = x :: l >} method virtual fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b method virtual fold2 : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b method fold2 ~f ~init = self#fold ~f ~init:(self#fold ~f ~init) method fold = List.fold_left l end ;; class ['a] ilist6 l = object (self) inherit ['a] vlist val l = l method add x = {< l = x :: l >} method virtual fold2 : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b method fold2 ~f ~init = self#fold ~f ~init:(self#fold ~f ~init) method fold = List.fold_left l end ;; class virtual ['a] olist = object method virtual fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c end ;; class ['a] onil = object inherit ['a] olist method fold ~f ~init = init end ;; class ['a] ocons ~hd ~tl = object (_ : 'b) inherit ['a] olist val hd : 'a = hd val tl : 'a olist = tl method fold ~f ~init = f hd (tl#fold ~f ~init) end ;; class ['a] ostream ~hd ~tl = object (_ : 'b) inherit ['a] olist val hd : 'a = hd val tl : _ #olist = (tl : 'a ostream) method fold ~f ~init = f hd (tl#fold ~f ~init) method empty = false end ;; class ['a] ostream1 ~hd ~tl = object (self : 'b) inherit ['a] olist val hd = hd val tl : 'b = tl method hd = hd method tl = tl method fold ~f ~init = self#tl#fold ~f ~init:(f self#hd init) end ;; class vari = object method virtual m : 'a. ([< `A|`B|`C] as 'a) -> int method m = function `A -> 1 | `B|`C -> 0 end ;; class vari = object method m : 'a. ([< `A|`B|`C] as 'a) -> int = function `A -> 1 | `B|`C -> 0 end ;; module V = struct type v = [`A | `B | `C] let m : [< v] -> int = function `A -> 1 | #v -> 0 end ;; class varj = object method virtual m : 'a. ([< V.v] as 'a) -> int method m = V.m end ;; module type T = sig class vari : object method m : 'a. ([< `A | `B | `C] as 'a) -> int end end ;; module M0 = struct class vari = object method virtual m : 'a. ([< `A|`B|`C] as 'a) -> int method m = function `A -> 1 | `B|`C -> 0 end end ;; module M : T = M0 ;; let v = new M.vari;; v#m `A;; class point ~x ~y = object val x : int = x val y : int = y method x = x method y = y end ;; class color_point ~x ~y ~color = object inherit point ~x ~y val color : string = color method color = color end ;; class circle (p : #point) ~r = object val p = (p :> point) val r = r method virtual distance : 'a. (#point as 'a) -> float method distance p' = let dx = p#x - p'#x and dy = p#y - p'#y in let d = sqrt (float (dx * dx + dy * dy)) -. float r in if d < 0. then 0. else d end ;; let p0 = new point ~x:3 ~y:5 let p1 = new point ~x:10 ~y:13 let cp = new color_point ~x:12 ~y:(-5) ~color:"green" let c = new circle p0 ~r:2 let d = c#distance cp ;; let f (x : < m : 'a. 'a -> 'a >) = (x : < m : 'b. 'b -> 'b >) ;; let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >) ;; class id = object method virtual id : 'a. 'a -> 'a method id x = x end ;; class type id_spec = object method id : 'a -> 'a end ;; class id_impl = object (_ : #id_spec) method id x = x end ;; class a = object method m = (new b : id_spec)#id true end and b = object (_ : #id_spec) method id x = x end ;; class ['a] id1 = object method virtual id : 'b. 'b -> 'a method id x = x end ;; class id2 (x : 'a) = object method virtual id : 'b. 'b -> 'a method id x = x end ;; class id3 x = object val x = x method virtual id : 'a. 'a -> 'a method id _ = x end ;; class id4 () = object val mutable r = None method virtual id : 'a. 'a -> 'a method id x = match r with None -> r <- Some x; x | Some y -> y end ;; class c = object method virtual m : 'a 'b. 'a -> 'b -> 'a method m x y = x end ;; let f1 (f : id) = f#id 1, f#id true ;; let f2 f = (f : id)#id 1, (f : id)#id true ;; let f3 f = f#id 1, f#id true ;; let f4 f = ignore(f : id); f#id 1, f#id true ;; class c = object method virtual m : 'a. (#id as 'a) -> int * bool method m (f : #id) = f#id 1, f#id true end ;; class id2 = object (_ : 'b) method virtual id : 'a. 'a -> 'a method id x = x method mono (x : int) = x end ;; let app = new c #m (new id2) ;; type 'a foo = 'a foo list ;; class ['a] bar (x : 'a) = object end ;; type 'a foo = 'a foo bar ;; fun x -> (x : < m : 'a. 'a * 'b > as 'b)#m;; fun x -> (x : < m : 'a. 'b * 'a list> as 'b)#m;; let f x = (x : < m : 'a. 'b * (< n : 'a; .. > as 'a) > as 'b)#m;; fun (x : < p : 'a. < m : 'a ; n : 'b ; .. > as 'a > as 'b) -> x#p;; fun (x : as 'c> as 'd) -> x#m;; (* printer is wrong on the next (no official syntax) *) fun (x : >) -> x#m;; type sum = T of < id: 'a. 'a -> 'a > ;; fun (T x) -> x#id;; type record = { r: < id: 'a. 'a -> 'a > } ;; fun x -> x.r#id;; fun {r=x} -> x#id;; class myself = object (self) method self : 'a. 'a -> 'b = fun _ -> self end;; class number = object (self : 'self) val num = 0 method num = num method succ = {< num = num + 1 >} method prev = self#switch ~zero:(fun () -> failwith "zero") ~prev:(fun x -> x) method switch : 'a. zero:(unit -> 'a) -> prev:('self -> 'a) -> 'a = fun ~zero ~prev -> if num = 0 then zero () else prev {< num = num - 1 >} end ;; let id x = x ;; class c = object method id : 'a. 'a -> 'a = id end ;; class c' = object inherit c method id = id end ;; class d = object inherit c as c val mutable count = 0 method id x = count <- count+1; x method count = count method old : 'a. 'a -> 'a = c#id end ;; class ['a] olist l = object val l = l method fold : 'b. f:('a -> 'b -> 'b) -> init:'b -> 'b = List.fold_right l method cons a = {< l = a :: l >} end ;; let sum (l : 'a #olist) = l#fold ~f:(fun x acc -> x+acc) ~init:0 ;; let count (l : 'a #olist) = l#fold ~f:(fun _ acc -> acc+1) ~init:0 ;; let append (l : 'a #olist) (l' : 'b #olist) = l#fold ~init:l' ~f:(fun x acc -> acc#cons x) ;; type 'a t = unit ;; class o = object method x : 'a. ([> `A] as 'a) t -> unit = fun _ -> () end ;; class c = object method m = new d () end and d ?(x=0) () = object end;; class d ?(x=0) () = object end and c = object method m = new d () end;; class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end class zero = object (_ : #numeral) method fold f x = x end class next (n : #numeral) = object (_ : #numeral) method fold f x = n#fold f (f x) end ;; class type node_type = object method as_variant : [> `Node of node_type] end;; class node : node_type = object (self) method as_variant : 'a. [> `Node of node_type] as 'a = `Node (self :> node_type) end;; class node = object (self : #node_type) method as_variant = `Node (self :> node_type) end;; type bad = {bad : 'a. 'a option ref};; let bad = {bad = ref None};; type bad2 = {mutable bad2 : 'a. 'a option ref option};; let bad2 = {bad2 = None};; bad2.bad2 <- Some (ref None);; (* Type variable scope *) let f (x: as 'b>) (y : 'b) = ();; let f (x: as 'b)>) (y : 'b) = ();; (* PR#1374 *) type 'a t= [`A of 'a];; class c = object (self) method m : 'a. ([> 'a t] as 'a) -> unit = fun x -> self#m x end;; class c = object (self) method m : 'a. ([> 'a t] as 'a) -> unit = function | `A x' -> self#m x' | _ -> failwith "c#m" end;; class c = object (self) method m : 'a. ([> 'a t] as 'a) -> 'a = fun x -> self#m x end;; (* usage avant instance *) class c = object method m : 'a. 'a option -> ([> `A] as 'a) = fun x -> `A end;; (* various old bugs *) class virtual ['a] visitor = object method virtual caseNil : 'a end and virtual int_list = object method virtual visit : 'a.('a visitor -> 'a) end;; type ('a,'b) list_visitor = < caseNil : 'a; caseCons : 'b -> 'b list -> 'a > type 'b alist = < visit : 'a. ('a,'b) list_visitor -> 'a > (* PR#1607 *) class type ct = object ('s) method fold : ('b -> 's -> 'b) -> 'b -> 'b end type t = {f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b};; (* PR#1663 *) type t = u and u = t;; (* PR#1731 *) class ['t] a = object constraint 't = [> `A of 't a] end type t = [ `A of t a ];; (* Wrong in 3.06 *) type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;; (* Full polymorphism if we do not expand *) type 'a t = 'a and u = int t;; (* Loose polymorphism if we expand *) type 'a t constraint 'a = int;; type 'a u = 'a and 'a v = 'a u t;; type 'a u = 'a and 'a v = 'a u t constraint 'a = int;; (* Behaviour is unstable *) type g = int;; type 'a t = unit constraint 'a = g;; type 'a u = 'a and 'a v = 'a u t;; type 'a u = 'a and 'a v = 'a u t constraint 'a = int;; (* Example of wrong expansion *) type 'a u = < m : 'a v > and 'a v = 'a list u;; (* PR#1744: Ctype.matches *) type 'a t = 'a type 'a u = A of 'a t;; (* Unification of cyclic terms *) type 'a t = < a : 'a >;; fun (x : 'a t as 'a) -> (x : 'b t);; type u = 'a t as 'a;; (* Variant tests *) type t = A | B;; function `A,_ -> 1 | _,A -> 2 | _,B -> 3;; function `A,_ -> 1 | _,(A|B) -> 2;; function Some `A, _ -> 1 | Some _, A -> 2 | None, A -> 3 | _, B -> 4;; function Some `A, A -> 1 | Some `A, B -> 1 | Some _, A -> 2 | None, A -> 3 | _, B -> 4;; function A, `A -> 1 | A, `B -> 2 | B, _ -> 3;; function `A, A -> 1 | `B, A -> 2 | _, B -> 3;; function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;; function `B,1 -> 1 | _,1 -> 2;; function 1,`B -> 1 | 1,_ -> 2;; (* pass typetexp, but fails during Typedecl.check_recursion *) type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] and ('a, 'b) b = 'b -> unit constraint 'b = [> `A of ('a, 'b) a as 'a];; (* PR#1917: expanding may change original in Ctype.unify2 *) (* Note: since 3.11, the abbreviations are not used when printing a type where they occur recursively inside. *) class type ['a, 'b] a = object method b: ('a, 'b) #b as 'b method as_a: ('a, 'b) a end and ['a, 'b] b = object method a: ('a, 'b) #a as 'a method as_b: ('a, 'b) b end class type ['b] ca = object ('s) inherit ['s, 'b] a end class type ['a] cb = object ('s) inherit ['a, 's] b end type bt = 'b ca cb as 'b ;; (* final classes, etc... *) class c = object method m = 1 end;; let f () = object (self:c) method m = 1 end;; let f () = object (self:c) method private n = 1 method m = self#n end;; let f () = object method private n = 1 method m = {<>}#n end;; let f () = object (self:c) method n = 1 method m = 2 end;; let f () = object (_:'s) constraint 's = < n : int > method m = 1 end;; class c = object (_ : 's) method x = 1 method private m = object (self: 's) method x = 3 method private m = self end end;; let o = object (_ : 's) method x = 1 method private m = object (self: 's) method x = 3 method private m = self end end;; (* Unsound! *) fun (x : > as 'foo) -> (x : > as 'bar) >);; type 'a foo = type foo' = type 'a bar = > type bar' = let f (x : foo') = (x : bar');; fun (x : as 'foo)>) -> (x : )> as 'bar);; fun (x : as 'foo)>) -> (x : )> as 'bar);; fun (x : as 'foo) -> (x : as 'bar)>);; let f x = (x : ('a * 'bar> as 'bar)> :> ('a * 'foo)> as 'foo);; module M : sig val f : ( as 'bar)>) -> unit end = struct let f (x : as 'foo) = () end;; module M : sig type t = as 'bar)> end = struct type t = as 'foo end;; module M : sig type 'a t type u = end = struct type 'a t = int type u = end;; module M : sig type 'a t val f : -> int end = struct type 'a t = int let f (x : ) = x#m end;; (* The following should be accepted too! *) module M : sig type 'a t val f : -> int end = struct type 'a t = int let f x = x#m end;; let f x y = ignore (x :> 'c * < > > as 'c); ignore (y :> 'd * < > > as 'd); x = y;; (* Subtyping *) type t = [`A|`B];; type v = private [> t];; fun x -> (x : t :> v);; type u = private [< t];; fun x -> (x : u :> v);; fun x -> (x : v :> u);; type v = private [< t];; fun x -> (x : u :> v);; type p = ;; type q = private ;; fun x -> (x : q :> p);; fun x -> (x : p :> q);; let f1 x = (x : as 'a) -> int> :> as 'b) -> int>);; let f2 x = (x : ;..> as 'a) -> int> :> ;..> as 'b) -> int>);; let f3 x = (x : ;..> as 'a) -> int> :> ;..> as 'b) -> int>);; let f4 x = (x : ;..> :> ;..>);; let f5 x = (x : ] as 'a> :> ] as 'a>);; let f6 x = (x : ] as 'a> :> ] as 'a>);; (* Keep sharing the epsilons *) let f x = if true then (x : < m : 'a. 'a -> 'a >) else x;; fun x -> (f x)#m;; (* Warning 18 *) let f (x, y) = if true then (x : < m : 'a. 'a -> 'a >) else x;; fun x -> (f (x,x))#m;; (* Warning 18 *) let f x = if true then [| (x : < m : 'a. 'a -> 'a >) |] else [|x|];; fun x -> (f x).(0)#m;; (* Warning 18 *) (* Not really principal? *) class c = object method id : 'a. 'a -> 'a = fun x -> x end;; type u = c option;; let just = function None -> failwith "just" | Some x -> x;; let f x = let l = [Some x; (None : u)] in (just(List.hd l))#id;; let g x = let none = (fun y -> ignore [y;(None:u)]; y) None in let x = List.hd [Some x; none] in (just x)#id;; let h x = let none = let y = None in ignore [y;(None:u)]; y in let x = List.hd [Some x; none] in (just x)#id;; (* Only solved for parameterless abbreviations *) type 'a u = c option;; let just = function None -> failwith "just" | Some x -> x;; let f x = let l = [Some x; (None : _ u)] in (just(List.hd l))#id;; (* polymorphic recursion *) let rec f : 'a. 'a -> _ = fun x -> 1 and g x = f x;; type 'a t = Leaf of 'a | Node of ('a * 'a) t;; let rec depth : 'a. 'a t -> _ = function Leaf _ -> 1 | Node x -> 1 + depth x;; let rec depth : 'a. 'a t -> _ = function Leaf _ -> 1 | Node x -> 1 + d x and d x = depth x;; (* fails *) let rec depth : 'a. 'a t -> _ = function Leaf x -> x | Node x -> 1 + depth x;; (* fails *) let rec depth : 'a. 'a t -> _ = function Leaf x -> x | Node x -> depth x;; (* fails *) let rec depth : 'a 'b. 'a t -> 'b = function Leaf x -> x | Node x -> depth x;; (* fails *) let rec r : 'a. 'a list * 'b list ref = [], ref [] and q () = r;; let f : 'a. _ -> _ = fun x -> x;; let zero : 'a. [> `Int of int | `B of 'a] as 'a = `Int 0;; (* ok *) let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *) (* compare with records (should be the same) *) type t = {f: 'a. [> `Int of int | `B of 'a] as 'a} let zero = {f = `Int 0} ;; type t = {f: 'a. [< `Int of int] as 'a} let zero = {f = `Int 0} ;; (* fails *) (* Yet another example *) let rec id : 'a. 'a -> 'a = fun x -> x and neg i b = (id (-i), id (not b));; (* De Xavier *) type t = A of int | B of (int*t) list | C of (string*t) list let rec transf f = function | A x -> f x | B l -> B (transf_alist f l) | C l -> C (transf_alist f l) and transf_alist : 'a. _ -> ('a*t) list -> ('a*t) list = fun f -> function | [] -> [] | (k,v)::tl -> (k, transf f v) :: transf_alist f tl ;; (* PR#4862 *) type t = {f: 'a. ('a list -> int) Lazy.t} let l : t = { f = lazy (raise Not_found)};; (* variant *) type t = {f: 'a. 'a -> unit};; let f ?x y = () in {f};; let f ?x y = y in {f};; (* fail *) (* Polux Moon caml-list 2011-07-26 *) module Polux = struct type 'par t = 'par let ident v = v class alias = object method alias : 'a . 'a t -> 'a = ident end let f (x : ) = (x : ) end;; (* PR#5560 *) let (a, b) = (raise Exit : int * int);; type t = { foo : int } let {foo} = (raise Exit : t);; type s = A of int let (A x) = (raise Exit : s);; (* PR#5224 *) type 'x t = < f : 'y. 'y t >;; mingw-ocaml/ocaml/testsuite/tests/typing-poly/poly.ml.reference0000644000175000017500000005474412124403241024434 0ustar tootstoots # * * * # type 'a t = { t : 'a; } # type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; } # val f : 'a list -> 'a fold = # - : int = 6 # class ['b] ilist : 'b list -> object ('c) val l : 'b list method add : 'b -> 'c method fold : f:('a -> 'b -> 'a) -> init:'a -> 'a end # class virtual ['a] vlist : object ('c) method virtual add : 'a -> 'c method virtual fold : f:('b -> 'a -> 'b) -> init:'b -> 'b end # class ilist2 : int list -> object ('a) val l : int list method add : int -> 'a method fold : f:('b -> int -> 'b) -> init:'b -> 'b end # val ilist2 : 'a list -> 'a vlist = # class ['a] ilist3 : 'a list -> object ('c) val l : 'a list method add : 'a -> 'c method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b end # class ['a] ilist4 : 'a list -> object ('c) val l : 'a list method add : 'a -> 'c method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b end # class ['a] ilist5 : 'a list -> object ('c) val l : 'a list method add : 'a -> 'c method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b end # class ['a] ilist6 : 'a list -> object ('c) val l : 'a list method add : 'a -> 'c method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b end # class virtual ['a] olist : object method virtual fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end # class ['a] onil : object method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end # class ['a] ocons : hd:'a -> tl:'a olist -> object val hd : 'a val tl : 'a olist method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end # class ['a] ostream : hd:'a -> tl:'a ostream -> object val hd : 'a val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c > method empty : bool method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end # class ['a] ostream1 : hd:'a -> tl:'b -> object ('b) val hd : 'a val tl : 'b method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c method hd : 'a method tl : 'b end # class vari : object method m : [< `A | `B | `C ] -> int end # class vari : object method m : [< `A | `B | `C ] -> int end # module V : sig type v = [ `A | `B | `C ] val m : [< v ] -> int end # class varj : object method m : [< V.v ] -> int end # module type T = sig class vari : object method m : [< `A | `B | `C ] -> int end end # module M0 : sig class vari : object method m : [< `A | `B | `C ] -> int end end # module M : T # val v : M.vari = # - : int = 1 # class point : x:int -> y:int -> object val x : int val y : int method x : int method y : int end # class color_point : x:int -> y:int -> color:string -> object val color : string val x : int val y : int method color : string method x : int method y : int end # class circle : #point -> r:int -> object val p : point val r : int method distance : #point -> float end # val p0 : point = val p1 : point = val cp : color_point = val c : circle = val d : float = 11.4536240470737098 # val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = # Characters 41-42: let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >) ^ Error: This expression has type < m : 'b. 'b -> 'b list > but an expression was expected of type < m : 'b. 'b -> 'c > The universal variable 'b would escape its scope # class id : object method id : 'a -> 'a end # class type id_spec = object method id : 'a -> 'a end # class id_impl : object method id : 'a -> 'a end # class a : object method m : bool end and b : object method id : 'a -> 'a end # Characters 72-77: method id x = x ^^^^^ Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a # Characters 75-80: method id x = x ^^^^^ Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a # Characters 80-85: method id _ = x ^^^^^ Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a # Characters 92-159: ............x = match r with None -> r <- Some x; x | Some y -> y Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a # class c : object method m : 'a -> 'b -> 'a end # val f1 : id -> int * bool = # val f2 : id -> int * bool = # Characters 24-28: let f3 f = f#id 1, f#id true ^^^^ Error: This expression has type bool but an expression was expected of type int # val f4 : id -> int * bool = # class c : object method m : #id -> int * bool end # class id2 : object method id : 'a -> 'a method mono : int -> int end # val app : int * bool = (1, true) # Characters 4-25: type 'a foo = 'a foo list ^^^^^^^^^^^^^^^^^^^^^ Error: The type abbreviation foo is cyclic # class ['a] bar : 'a -> object end # type 'a foo = 'a foo bar # - : (< m : 'a. 'a * 'b > as 'b) -> 'c * 'b = # - : (< m : 'a. 'b * 'a list > as 'b) -> 'b * 'c list = # val f : (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) -> 'a * (< n : 'c; .. > as 'c) = # - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) -> (< m : 'c; n : 'a; .. > as 'c) = # - : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) -> ('f * < p : 'b. 'b * 'e * 'c > as 'e) = # - : < m : 'a. < p : 'a; .. > as 'b > -> 'b = # type sum = T of < id : 'a. 'a -> 'a > # - : sum -> 'a -> 'a = # type record = { r : < id : 'a. 'a -> 'a >; } # - : record -> 'a -> 'a = # - : record -> 'a -> 'a = # class myself : object ('b) method self : 'a -> 'b end # class number : object ('b) val num : int method num : int method prev : 'b method succ : 'b method switch : zero:(unit -> 'a) -> prev:('b -> 'a) -> 'a end # val id : 'a -> 'a = # class c : object method id : 'a -> 'a end # class c' : object method id : 'a -> 'a end # class d : object val mutable count : int method count : int method id : 'a -> 'a method old : 'a -> 'a end # class ['a] olist : 'a list -> object ('c) val l : 'a list method cons : 'a -> 'c method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end # val sum : int #olist -> int = # val count : 'a #olist -> int = # val append : 'a #olist -> ('a #olist as 'b) -> 'b = # type 'a t = unit # class o : object method x : [> `A ] t -> unit end # class c : object method m : d end and d : ?x:int -> unit -> object end # class d : ?x:int -> unit -> object end and c : object method m : d end # class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end class zero : object method fold : ('a -> 'a) -> 'a -> 'a end class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end # class type node_type = object method as_variant : [> `Node of node_type ] end # class node : node_type # class node : object method as_variant : [> `Node of node_type ] end # type bad = { bad : 'a. 'a option ref; } # Characters 17-25: let bad = {bad = ref None};; ^^^^^^^^ Error: This field value has type 'b option ref which is less general than 'a. 'a option ref # type bad2 = { mutable bad2 : 'a. 'a option ref option; } # val bad2 : bad2 = {bad2 = None} # Characters 13-28: bad2.bad2 <- Some (ref None);; ^^^^^^^^^^^^^^^ Error: This field value has type 'b option ref option which is less general than 'a. 'a option ref option # val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = # val f : < m : 'a. 'a * (< p : int * 'b > as 'b) > -> 'b -> unit = # type 'a t = [ `A of 'a ] # class c : object method m : ([> 'a t ] as 'a) -> unit end # class c : object method m : ([> 'a t ] as 'a) -> unit end # class c : object method m : ([> 'a t ] as 'a) -> 'a end # class c : object method m : ([> `A ] as 'a) option -> 'a end # Characters 145-166: object method virtual visit : 'a.('a visitor -> 'a) end;; ^^^^^^^^^^^^^^^^^^^^^ Error: The universal type variable 'a cannot be generalized: it escapes its scope. # type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a > type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a > class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; } # Characters 20-25: type t = u and u = t;; ^^^^^ Error: The type abbreviation t is cyclic # class ['a] a : object constraint 'a = [> `A of 'a a ] end type t = [ `A of t a ] # Characters 71-80: type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;; ^^^^^^^^^ Error: Constraints are not satisfied in this type. Type ('a, 'b) t should be an instance of ('c, 'c) t # type 'a t = 'a and u = int t # type 'a t constraint 'a = int # Characters 26-32: type 'a u = 'a and 'a v = 'a u t;; ^^^^^^ Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of int t # type 'a u = 'a constraint 'a = int and 'a v = 'a u t constraint 'a = int # type g = int # type 'a t = unit constraint 'a = g # Characters 26-32: type 'a u = 'a and 'a v = 'a u t;; ^^^^^^ Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of g t # type 'a u = 'a constraint 'a = g and 'a v = 'a u t constraint 'a = g # Characters 38-58: type 'a u = < m : 'a v > and 'a v = 'a list u;; ^^^^^^^^^^^^^^^^^^^^ Error: In the definition of v, type 'a list u should be 'a u # type 'a t = 'a type 'a u = A of 'a t # type 'a t = < a : 'a > # - : ('a t as 'a) -> 'a t = # type u = 'a t as 'a # type t = A | B # - : [> `A ] * t -> int = # - : [> `A ] * t -> int = # - : [> `A ] option * t -> int = # - : [> `A ] option * t -> int = # - : t * [< `A | `B ] -> int = # - : [< `A | `B ] * t -> int = # Characters 0-41: function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (`AnyExtraTag, `AnyExtraTag) - : [> `A | `B ] * [> `A | `B ] -> int = # Characters 0-29: function `B,1 -> 1 | _,1 -> 2;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (_, 0) Characters 21-24: function `B,1 -> 1 | _,1 -> 2;; ^^^ Warning 11: this match case is unused. - : [< `B ] * int -> int = # Characters 0-29: function 1,`B -> 1 | 1,_ -> 2;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (0, _) Characters 21-24: function 1,`B -> 1 | 1,_ -> 2;; ^^^ Warning 11: this match case is unused. - : int * [< `B ] -> int = # Characters 69-135: type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Constraints are not satisfied in this type. Type ([> `B of 'a ], 'a) b as 'a should be an instance of (('b, [> `A of 'b ] as 'c) a as 'b, 'c) b # * class type ['a, 'b] a = object constraint 'a = < as_a : ('a, 'b) a as 'c; b : 'b; .. > constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. > method as_a : 'c method b : 'b end and ['a, 'b] b = object constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. > constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. > method a : 'a method as_b : ('a, 'b) b end class type ['a] ca = object ('b) constraint 'a = < a : 'b; as_b : ('b, 'a) b; .. > method as_a : ('b, 'a) a method b : 'a end class type ['a] cb = object ('b) constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. > method a : 'a method as_b : ('a, 'b) b end type bt = 'a ca cb as 'a # class c : object method m : int end # val f : unit -> c = # val f : unit -> c = # Characters 11-60: let f () = object method private n = 1 method m = {<>}#n end;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 15: the following private methods were made public implicitly: n. val f : unit -> < m : int; n : int > = # Characters 11-56: let f () = object (self:c) method n = 1 method m = 2 end;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This object is expected to have type c but actually has type < m : int; n : 'a > The first object type has no method n # Characters 11-69: let f () = object (_:'s) constraint 's = < n : int > method m = 1 end;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This object is expected to have type < n : int > but actually has type < m : 'a > The second object type has no method n # Characters 66-124: object (self: 's) method x = 3 method private m = self end ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This object is expected to have type < x : int; .. > but actually has type < x : int > Self type cannot be unified with a closed object type # val o : < x : int > = # Characters 76-77: (x : > as 'bar) >);; ^ Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b but an expression was expected of type < m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) > Types for method m are incompatible # Characters 176-177: let f (x : foo') = (x : bar');; ^ Error: This expression has type foo' = < m : 'a. 'a * 'a foo > but an expression was expected of type bar' = < m : 'a. 'a * 'a bar > Type 'a foo = < m : 'a * 'a foo > is not compatible with type 'a bar = < m : 'a * < m : 'c. 'c * 'a bar > > Type 'a foo = < m : 'a * 'a foo > is not compatible with type < m : 'c. 'c * 'a bar > Types for method m are incompatible # Characters 67-68: (x : )> as 'bar);; ^ Error: This expression has type < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > but an expression was expected of type < m : 'b. 'b * ('b * < m : 'c. 'c * ('c * 'd) >) > as 'd Types for method m are incompatible # Characters 66-67: (x : )> as 'bar);; ^ Error: This expression has type < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > but an expression was expected of type < m : 'b. 'b * ('b * < m : 'c. 'c * ('b * 'd) >) > as 'd Types for method m are incompatible # Characters 51-52: (x : as 'bar)>);; ^ Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a but an expression was expected of type < m : 'b. 'b * ('b * < m : 'c. 'c * 'd > as 'd) > Types for method m are incompatible # Characters 14-115: ....(x : ('a * 'bar> as 'bar)> :> ('a * 'foo)> as 'foo).. Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) > is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f # Characters 88-150: = struct let f (x : as 'foo) = () end;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Signature mismatch: ... Values do not match: val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit is not included in val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit # Characters 78-132: = struct type t = as 'foo end;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Signature mismatch: Modules do not match: sig type t = < m : 'a. 'a * ('a * 'b) > as 'b end is not included in sig type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > end Type declarations do not match: type t = < m : 'a. 'a * ('a * 'b) > as 'b is not included in type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > # module M : sig type 'a t type u = < m : 'a. 'a t > end # module M : sig type 'a t val f : < m : 'a. 'a t > -> int end # module M : sig type 'a t val f : < m : 'a. 'a t > -> int end # val f : (< m : 'a. 'a -> (< m : 'a. 'a -> 'c * < > > as 'c) * < .. >; .. > as 'b) -> 'b -> bool = # type t = [ `A | `B ] # type v = private [> t ] # - : t -> v = # type u = private [< t ] # - : u -> v = # Characters 9-21: fun x -> (x : v :> u);; ^^^^^^^^^^^^ Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ] # type v = private [< t ] # Characters 9-21: fun x -> (x : u :> v);; ^^^^^^^^^^^^ Error: Type u = [< `A | `B ] is not a subtype of v = [< `A | `B ] # type p = < x : p > # type q = private < x : p; .. > # - : q -> p = # Characters 9-21: fun x -> (x : p :> q);; ^^^^^^^^^^^^ Error: Type p = < x : p > is not a subtype of q = < x : p; .. > # Characters 14-100: ..(x : as 'a) -> int> :> as 'b) -> int>).. Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of < m : 'b. (< p : int; q : int; .. > as 'b) -> int > # val f2 : < m : 'a. (< p : < a : int >; .. > as 'a) -> int > -> < m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = # Characters 13-107: ..(x : ;..> as 'a) -> int> :> ;..> as 'b) -> int>).. Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int > # Characters 11-55: let f4 x = (x : ;..> :> ;..>);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type < p : < a : int; b : int >; .. > is not a subtype of < p : < a : int >; .. > The second object type has no method b # val f5 : < m : 'a. [< `A of < p : int > ] as 'a > -> < m : 'b. [< `A of < > ] as 'b > = # Characters 13-83: (x : ] as 'a> :> ] as 'a>);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of < m : 'b. [< `A of < p : int > ] as 'b > # val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = # - : < m : 'a. 'a -> 'a > -> 'b -> 'b = # val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = # - : < m : 'a. 'a -> 'a > -> 'b -> 'b = # val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = # - : < m : 'a. 'a -> 'a > -> 'b -> 'b = # class c : object method id : 'a -> 'a end # type u = c option # val just : 'a option -> 'a = # val f : c -> 'a -> 'a = # val g : c -> 'a -> 'a = # val h : < id : 'a; .. > -> 'a = # type 'a u = c option # val just : 'a option -> 'a = # val f : c -> 'a -> 'a = # val f : 'a -> int = val g : 'a -> int = # type 'a t = Leaf of 'a | Node of ('a * 'a) t # val depth : 'a t -> int = # Characters 34-74: function Leaf _ -> 1 | Node x -> 1 + d x ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This definition has type 'a t -> int which is less general than 'a0. 'a0 t -> int # Characters 34-78: function Leaf x -> x | Node x -> 1 + depth x;; (* fails *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This definition has type int t -> int which is less general than 'a. 'a t -> int # Characters 34-74: function Leaf x -> x | Node x -> depth x;; (* fails *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This definition has type 'a t -> 'a which is less general than 'a0. 'a0 t -> 'a # Characters 38-78: function Leaf x -> x | Node x -> depth x;; (* fails *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This definition has type 'b. 'b t -> 'b which is less general than 'b 'a. 'a t -> 'b # val r : 'a list * '_b list ref = ([], {contents = []}) val q : unit -> 'a list * '_b list ref = # val f : 'a -> 'a = # val zero : [> `B of 'a | `Int of int ] as 'a = `Int 0 # Characters 39-45: let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *) ^^^^^^ Error: This expression has type [> `Int of int ] but an expression was expected of type [< `Int of int ] Types for tag `Int are incompatible # type t = { f : 'a. [> `B of 'a | `Int of int ] as 'a; } val zero : t = {f = `Int 0} # Characters 56-62: let zero = {f = `Int 0} ;; (* fails *) ^^^^^^ Error: This expression has type [> `Int of int ] but an expression was expected of type [< `Int of int ] Types for tag `Int are incompatible # val id : 'a -> 'a = val neg : int -> bool -> int * bool = # type t = A of int | B of (int * t) list | C of (string * t) list val transf : (int -> t) -> t -> t = val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = # type t = { f : 'a. ('a list -> int) Lazy.t; } val l : t = {f = } # type t = { f : 'a. 'a -> unit; } # - : t = {f = } # Characters 19-20: let f ?x y = y in {f};; (* fail *) ^ Error: This field value has type unit -> unit which is less general than 'a. 'a -> unit # module Polux : sig type 'par t = 'par val ident : 'a -> 'a class alias : object method alias : 'a t -> 'a end val f : < m : 'a. 'a t > -> < m : 'a. 'a > end # Exception: Pervasives.Exit. # Exception: Pervasives.Exit. # Exception: Pervasives.Exit. # Characters 20-44: type 'x t = < f : 'y. 'y t >;; ^^^^^^^^^^^^^^^^^^^^^^^^ Error: In the definition of t, type 'y t should be 'x t # mingw-ocaml/ocaml/testsuite/tests/typing-poly/poly.ml.principal.reference0000644000175000017500000006014312124403241026402 0ustar tootstoots # * * * # type 'a t = { t : 'a; } # type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; } # val f : 'a list -> 'a fold = # - : int = 6 # class ['b] ilist : 'b list -> object ('c) val l : 'b list method add : 'b -> 'c method fold : f:('a -> 'b -> 'a) -> init:'a -> 'a end # class virtual ['a] vlist : object ('c) method virtual add : 'a -> 'c method virtual fold : f:('b -> 'a -> 'b) -> init:'b -> 'b end # class ilist2 : int list -> object ('a) val l : int list method add : int -> 'a method fold : f:('b -> int -> 'b) -> init:'b -> 'b end # val ilist2 : 'a list -> 'a vlist = # class ['a] ilist3 : 'a list -> object ('c) val l : 'a list method add : 'a -> 'c method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b end # class ['a] ilist4 : 'a list -> object ('c) val l : 'a list method add : 'a -> 'c method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b end # class ['a] ilist5 : 'a list -> object ('c) val l : 'a list method add : 'a -> 'c method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b end # class ['a] ilist6 : 'a list -> object ('c) val l : 'a list method add : 'a -> 'c method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b end # class virtual ['a] olist : object method virtual fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end # class ['a] onil : object method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end # class ['a] ocons : hd:'a -> tl:'a olist -> object val hd : 'a val tl : 'a olist method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end # class ['a] ostream : hd:'a -> tl:'a ostream -> object val hd : 'a val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c > method empty : bool method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end # class ['a] ostream1 : hd:'a -> tl:'b -> object ('b) val hd : 'a val tl : 'b method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c method hd : 'a method tl : 'b end # class vari : object method m : [< `A | `B | `C ] -> int end # class vari : object method m : [< `A | `B | `C ] -> int end # module V : sig type v = [ `A | `B | `C ] val m : [< v ] -> int end # class varj : object method m : [< V.v ] -> int end # module type T = sig class vari : object method m : [< `A | `B | `C ] -> int end end # module M0 : sig class vari : object method m : [< `A | `B | `C ] -> int end end # module M : T # val v : M.vari = # - : int = 1 # class point : x:int -> y:int -> object val x : int val y : int method x : int method y : int end # class color_point : x:int -> y:int -> color:string -> object val color : string val x : int val y : int method color : string method x : int method y : int end # class circle : #point -> r:int -> object val p : point val r : int method distance : #point -> float end # val p0 : point = val p1 : point = val cp : color_point = val c : circle = val d : float = 11.4536240470737098 # val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = # Characters 41-42: let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >) ^ Error: This expression has type < m : 'b. 'b -> 'b list > but an expression was expected of type < m : 'b. 'b -> 'c > The universal variable 'b would escape its scope # class id : object method id : 'a -> 'a end # class type id_spec = object method id : 'a -> 'a end # class id_impl : object method id : 'a -> 'a end # class a : object method m : bool end and b : object method id : 'a -> 'a end # Characters 72-77: method id x = x ^^^^^ Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a # Characters 75-80: method id x = x ^^^^^ Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a # Characters 80-85: method id _ = x ^^^^^ Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a # Characters 92-159: ............x = match r with None -> r <- Some x; x | Some y -> y Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a # class c : object method m : 'a -> 'b -> 'a end # val f1 : id -> int * bool = # val f2 : id -> int * bool = # Characters 24-28: let f3 f = f#id 1, f#id true ^^^^ Error: This expression has type bool but an expression was expected of type int # Characters 27-31: let f4 f = ignore(f : id); f#id 1, f#id true ^^^^ Warning 18: this use of a polymorphic method is not principal. Characters 35-39: let f4 f = ignore(f : id); f#id 1, f#id true ^^^^ Warning 18: this use of a polymorphic method is not principal. val f4 : id -> int * bool = # class c : object method m : #id -> int * bool end # class id2 : object method id : 'a -> 'a method mono : int -> int end # val app : int * bool = (1, true) # Characters 4-25: type 'a foo = 'a foo list ^^^^^^^^^^^^^^^^^^^^^ Error: The type abbreviation foo is cyclic # class ['a] bar : 'a -> object end # type 'a foo = 'a foo bar # - : (< m : 'a. 'a * 'b > as 'b) -> 'c * (< m : 'a. 'a * 'd > as 'd) = # - : (< m : 'a. 'b * 'a list > as 'b) -> (< m : 'a. 'c * 'a list > as 'c) * 'd list = # val f : (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) -> (< m : 'd. 'c * (< n : 'd; .. > as 'd) > as 'c) * (< n : 'e; .. > as 'e) = # - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) -> (< m : 'c; n : < p : 'e. < m : 'e; n : 'd; .. > as 'e > as 'd; .. > as 'c) = # - : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) -> ('f * < p : 'b. 'b * 'e * (< m : 'a. 'a * < p : 'b0. 'b0 * 'h * 'g > as 'h > as 'g) > as 'e) = # - : < m : 'a. < p : 'a; .. > as 'b > -> 'b = # type sum = T of < id : 'a. 'a -> 'a > # - : sum -> 'a -> 'a = # type record = { r : < id : 'a. 'a -> 'a >; } # - : record -> 'a -> 'a = # - : record -> 'a -> 'a = # class myself : object ('b) method self : 'a -> 'b end # class number : object ('b) val num : int method num : int method prev : 'b method succ : 'b method switch : zero:(unit -> 'a) -> prev:('b -> 'a) -> 'a end # val id : 'a -> 'a = # class c : object method id : 'a -> 'a end # class c' : object method id : 'a -> 'a end # class d : object val mutable count : int method count : int method id : 'a -> 'a method old : 'a -> 'a end # class ['a] olist : 'a list -> object ('c) val l : 'a list method cons : 'a -> 'c method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end # val sum : int #olist -> int = # val count : 'a #olist -> int = # val append : 'a #olist -> ('a #olist as 'b) -> 'b = # type 'a t = unit # class o : object method x : [> `A ] t -> unit end # class c : object method m : d end and d : ?x:int -> unit -> object end # class d : ?x:int -> unit -> object end and c : object method m : d end # class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end class zero : object method fold : ('a -> 'a) -> 'a -> 'a end class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end # class type node_type = object method as_variant : [> `Node of node_type ] end # class node : node_type # class node : object method as_variant : [> `Node of node_type ] end # type bad = { bad : 'a. 'a option ref; } # Characters 17-25: let bad = {bad = ref None};; ^^^^^^^^ Error: This field value has type 'b option ref which is less general than 'a. 'a option ref # type bad2 = { mutable bad2 : 'a. 'a option ref option; } # val bad2 : bad2 = {bad2 = None} # Characters 13-28: bad2.bad2 <- Some (ref None);; ^^^^^^^^^^^^^^^ Error: This field value has type 'b option ref option which is less general than 'a. 'a option ref option # val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = # val f : < m : 'a. 'a * (< p : int * 'b > as 'b) > -> (< p : int * 'c > as 'c) -> unit = # type 'a t = [ `A of 'a ] # class c : object method m : ([> 'a t ] as 'a) -> unit end # class c : object method m : ([> 'a t ] as 'a) -> unit end # class c : object method m : ([> 'a t ] as 'a) -> 'a end # class c : object method m : ([> `A ] as 'a) option -> 'a end # Characters 145-166: object method virtual visit : 'a.('a visitor -> 'a) end;; ^^^^^^^^^^^^^^^^^^^^^ Error: The universal type variable 'a cannot be generalized: it escapes its scope. # type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a > type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a > class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; } # Characters 20-25: type t = u and u = t;; ^^^^^ Error: The type abbreviation t is cyclic # class ['a] a : object constraint 'a = [> `A of 'a a ] end type t = [ `A of t a ] # Characters 71-80: type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;; ^^^^^^^^^ Error: Constraints are not satisfied in this type. Type ('a, 'b) t should be an instance of ('c, 'c) t # type 'a t = 'a and u = int t # type 'a t constraint 'a = int # Characters 26-32: type 'a u = 'a and 'a v = 'a u t;; ^^^^^^ Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of int t # type 'a u = 'a constraint 'a = int and 'a v = 'a u t constraint 'a = int # type g = int # type 'a t = unit constraint 'a = g # Characters 26-32: type 'a u = 'a and 'a v = 'a u t;; ^^^^^^ Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of g t # type 'a u = 'a constraint 'a = g and 'a v = 'a u t constraint 'a = g # Characters 38-58: type 'a u = < m : 'a v > and 'a v = 'a list u;; ^^^^^^^^^^^^^^^^^^^^ Error: In the definition of v, type 'a list u should be 'a u # type 'a t = 'a type 'a u = A of 'a t # type 'a t = < a : 'a > # - : ('a t as 'a) -> ('b t as 'b) t = # type u = 'a t as 'a # type t = A | B # - : [> `A ] * t -> int = # - : [> `A ] * t -> int = # - : [> `A ] option * t -> int = # - : [> `A ] option * t -> int = # - : t * [< `A | `B ] -> int = # - : [< `A | `B ] * t -> int = # Characters 0-41: function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (`AnyExtraTag, `AnyExtraTag) - : [> `A | `B ] * [> `A | `B ] -> int = # Characters 0-29: function `B,1 -> 1 | _,1 -> 2;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (_, 0) Characters 21-24: function `B,1 -> 1 | _,1 -> 2;; ^^^ Warning 11: this match case is unused. - : [< `B ] * int -> int = # Characters 0-29: function 1,`B -> 1 | 1,_ -> 2;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (0, _) Characters 21-24: function 1,`B -> 1 | 1,_ -> 2;; ^^^ Warning 11: this match case is unused. - : int * [< `B ] -> int = # Characters 69-135: type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Constraints are not satisfied in this type. Type ([> `B of 'a ], 'a) b as 'a should be an instance of (('b, [> `A of ('d, 'c) a as 'd ] as 'c) a as 'b, 'c) b # * class type ['a, 'b] a = object constraint 'a = < as_a : ('a, 'b) a as 'c; b : 'b; .. > constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. > method as_a : 'c method b : 'b end and ['a, 'b] b = object constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. > constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. > method a : 'a method as_b : ('a, 'b) b end class type ['a] ca = object ('b) constraint 'a = < a : 'b; as_b : ('b, 'a) b; .. > method as_a : ('b, 'a) a method b : 'a end class type ['a] cb = object ('b) constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. > method a : 'a method as_b : ('a, 'b) b end type bt = 'a ca cb as 'a # class c : object method m : int end # val f : unit -> c = # val f : unit -> c = # Characters 11-60: let f () = object method private n = 1 method m = {<>}#n end;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 15: the following private methods were made public implicitly: n. val f : unit -> < m : int; n : int > = # Characters 11-56: let f () = object (self:c) method n = 1 method m = 2 end;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This object is expected to have type c but actually has type < m : int; n : 'a > The first object type has no method n # Characters 11-69: let f () = object (_:'s) constraint 's = < n : int > method m = 1 end;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This object is expected to have type < n : int > but actually has type < m : 'a > The second object type has no method n # Characters 66-124: object (self: 's) method x = 3 method private m = self end ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This object is expected to have type < x : int; .. > but actually has type < x : int > Self type cannot be unified with a closed object type # val o : < x : int > = # Characters 76-77: (x : > as 'bar) >);; ^ Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b but an expression was expected of type < m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) > Types for method m are incompatible # Characters 176-177: let f (x : foo') = (x : bar');; ^ Error: This expression has type foo' = < m : 'a. 'a * 'a foo > but an expression was expected of type bar' = < m : 'a. 'a * 'a bar > Type 'a foo = < m : 'a * 'a foo > is not compatible with type 'a bar = < m : 'a * < m : 'c. 'c * 'a bar > > Type 'a foo = < m : 'a * 'a foo > is not compatible with type < m : 'c. 'c * 'a bar > Types for method m are incompatible # Characters 67-68: (x : )> as 'bar);; ^ Error: This expression has type < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > but an expression was expected of type < m : 'b. 'b * ('b * < m : 'c. 'c * ('c * 'd) >) > as 'd Types for method m are incompatible # Characters 66-67: (x : )> as 'bar);; ^ Error: This expression has type < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > but an expression was expected of type < m : 'b. 'b * ('b * < m : 'c. 'c * ('b * 'd) >) > as 'd Types for method m are incompatible # Characters 51-52: (x : as 'bar)>);; ^ Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a but an expression was expected of type < m : 'b. 'b * ('b * < m : 'c. 'c * 'd > as 'd) > Types for method m are incompatible # Characters 14-115: ....(x : ('a * 'bar> as 'bar)> :> ('a * 'foo)> as 'foo).. Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) > is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f # Characters 88-150: = struct let f (x : as 'foo) = () end;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Signature mismatch: Modules do not match: sig val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit end is not included in sig val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit end Values do not match: val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit is not included in val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit # Characters 78-132: = struct type t = as 'foo end;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Signature mismatch: Modules do not match: sig type t = < m : 'a. 'a * ('a * 'b) > as 'b end is not included in sig type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > end Type declarations do not match: type t = < m : 'a. 'a * ('a * 'b) > as 'b is not included in type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > # module M : sig type 'a t type u = < m : 'a. 'a t > end # module M : sig type 'a t val f : < m : 'a. 'a t > -> int end # module M : sig type 'a t val f : < m : 'a. 'a t > -> int end # val f : (< m : 'a. 'a -> (< m : 'a. 'a -> 'c * < > > as 'c) * < .. >; .. > as 'b) -> 'b -> bool = # type t = [ `A | `B ] # type v = private [> t ] # - : t -> v = # type u = private [< t ] # - : u -> v = # Characters 9-21: fun x -> (x : v :> u);; ^^^^^^^^^^^^ Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ] # type v = private [< t ] # Characters 9-21: fun x -> (x : u :> v);; ^^^^^^^^^^^^ Error: Type u = [< `A | `B ] is not a subtype of v = [< `A | `B ] # type p = < x : p > # type q = private < x : p; .. > # - : q -> p = # Characters 9-21: fun x -> (x : p :> q);; ^^^^^^^^^^^^ Error: Type p = < x : p > is not a subtype of q = < x : p; .. > # Characters 14-100: ..(x : as 'a) -> int> :> as 'b) -> int>).. Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of < m : 'b. (< p : int; q : int; .. > as 'b) -> int > # val f2 : < m : 'a. (< p : < a : int >; .. > as 'a) -> int > -> < m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = # Characters 13-107: ..(x : ;..> as 'a) -> int> :> ;..> as 'b) -> int>).. Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int > # Characters 11-55: let f4 x = (x : ;..> :> ;..>);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type < p : < a : int; b : int >; .. > is not a subtype of < p : < a : int >; .. > The second object type has no method b # val f5 : < m : 'a. [< `A of < p : int > ] as 'a > -> < m : 'b. [< `A of < > ] as 'b > = # Characters 13-83: (x : ] as 'a> :> ] as 'a>);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of < m : 'b. [< `A of < p : int > ] as 'b > # val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = # Characters 9-16: fun x -> (f x)#m;; (* Warning 18 *) ^^^^^^^ Warning 18: this use of a polymorphic method is not principal. - : < m : 'a. 'a -> 'a > -> 'b -> 'b = # val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = # Characters 9-20: fun x -> (f (x,x))#m;; (* Warning 18 *) ^^^^^^^^^^^ Warning 18: this use of a polymorphic method is not principal. - : < m : 'a. 'a -> 'a > -> 'b -> 'b = # val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = # Characters 9-20: fun x -> (f x).(0)#m;; (* Warning 18 *) ^^^^^^^^^^^ Warning 18: this use of a polymorphic method is not principal. - : < m : 'a. 'a -> 'a > -> 'b -> 'b = # class c : object method id : 'a -> 'a end # type u = c option # val just : 'a option -> 'a = # Characters 42-62: let f x = let l = [Some x; (None : u)] in (just(List.hd l))#id;; ^^^^^^^^^^^^^^^^^^^^ Warning 18: this use of a polymorphic method is not principal. val f : c -> 'a -> 'a = # Characters 101-112: let x = List.hd [Some x; none] in (just x)#id;; ^^^^^^^^^^^ Warning 18: this use of a polymorphic method is not principal. val g : c -> 'a -> 'a = # val h : < id : 'a; .. > -> 'a = # type 'a u = c option # val just : 'a option -> 'a = # val f : c -> 'a -> 'a = # val f : 'a -> int = val g : 'a -> int = # type 'a t = Leaf of 'a | Node of ('a * 'a) t # val depth : 'a t -> int = # Characters 34-74: function Leaf _ -> 1 | Node x -> 1 + d x ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This definition has type 'a t -> int which is less general than 'a0. 'a0 t -> int # Characters 34-78: function Leaf x -> x | Node x -> 1 + depth x;; (* fails *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This definition has type int t -> int which is less general than 'a. 'a t -> int # Characters 34-74: function Leaf x -> x | Node x -> depth x;; (* fails *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This definition has type 'a t -> 'a which is less general than 'a0. 'a0 t -> 'a # Characters 38-78: function Leaf x -> x | Node x -> depth x;; (* fails *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This definition has type 'b. 'b t -> 'b which is less general than 'b 'a. 'a t -> 'b # val r : 'a list * '_b list ref = ([], {contents = []}) val q : unit -> 'a list * '_b list ref = # val f : 'a -> 'a = # val zero : [> `B of 'a | `Int of int ] as 'a = `Int 0 # Characters 39-45: let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *) ^^^^^^ Error: This expression has type [> `Int of int ] but an expression was expected of type [< `Int of int ] Types for tag `Int are incompatible # type t = { f : 'a. [> `B of 'a | `Int of int ] as 'a; } val zero : t = {f = `Int 0} # Characters 56-62: let zero = {f = `Int 0} ;; (* fails *) ^^^^^^ Error: This expression has type [> `Int of int ] but an expression was expected of type [< `Int of int ] Types for tag `Int are incompatible # val id : 'a -> 'a = val neg : int -> bool -> int * bool = # type t = A of int | B of (int * t) list | C of (string * t) list val transf : (int -> t) -> t -> t = val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = # type t = { f : 'a. ('a list -> int) Lazy.t; } val l : t = {f = } # type t = { f : 'a. 'a -> unit; } # - : t = {f = } # Characters 19-20: let f ?x y = y in {f};; (* fail *) ^ Error: This field value has type unit -> unit which is less general than 'a. 'a -> unit # module Polux : sig type 'par t = 'par val ident : 'a -> 'a class alias : object method alias : 'a t -> 'a end val f : < m : 'a. 'a t > -> < m : 'a. 'a > end # Exception: Pervasives.Exit. # Exception: Pervasives.Exit. # Exception: Pervasives.Exit. # Characters 20-44: type 'x t = < f : 'y. 'y t >;; ^^^^^^^^^^^^^^^^^^^^^^^^ Error: In the definition of t, type 'y t should be 'x t # mingw-ocaml/ocaml/testsuite/tests/typing-labels/0000755000175000017500000000000012124403241021423 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-labels/mixin.ml0000644000175000017500000001167212124403241023110 0ustar tootstoots(* $Id$ *) open StdLabels open MoreLabels (* Use maps for substitutions and sets for free variables *) module Subst = Map.Make(struct type t = string let compare = compare end) module Names = Set.Make(struct type t = string let compare = compare end) (* Variables are common to lambda and expr *) type var = [`Var of string] let subst_var ~subst : var -> _ = function `Var s as x -> try Subst.find s subst with Not_found -> x let free_var : var -> _ = function `Var s -> Names.singleton s (* The lambda language: free variables, substitutions, and evaluation *) type 'a lambda = [`Var of string | `Abs of string * 'a | `App of 'a * 'a] let free_lambda ~free_rec : _ lambda -> _ = function #var as x -> free_var x | `Abs (s, t) -> Names.remove s (free_rec t) | `App (t1, t2) -> Names.union (free_rec t1) (free_rec t2) let map_lambda ~map_rec : _ lambda -> _ = function #var as x -> x | `Abs (s, t) as l -> let t' = map_rec t in if t == t' then l else `Abs(s, t') | `App (t1, t2) as l -> let t'1 = map_rec t1 and t'2 = map_rec t2 in if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2) let next_id = let current = ref 3 in fun () -> incr current; !current let subst_lambda ~subst_rec ~free ~subst : _ lambda -> _ = function #var as x -> subst_var ~subst x | `Abs(s, t) as l -> let used = free t in let used_expr = Subst.fold subst ~init:[] ~f:(fun ~key ~data acc -> if Names.mem s used then data::acc else acc) in if List.exists used_expr ~f:(fun t -> Names.mem s (free t)) then let name = s ^ string_of_int (next_id ()) in `Abs(name, subst_rec ~subst:(Subst.add ~key:s ~data:(`Var name) subst) t) else map_lambda ~map_rec:(subst_rec ~subst:(Subst.remove s subst)) l | `App _ as l -> map_lambda ~map_rec:(subst_rec ~subst) l let eval_lambda ~eval_rec ~subst l = match map_lambda ~map_rec:eval_rec l with `App(`Abs(s,t1), t2) -> eval_rec (subst ~subst:(Subst.add ~key:s ~data:t2 Subst.empty) t1) | t -> t (* Specialized versions to use on lambda *) let rec free1 x = free_lambda ~free_rec:free1 x let rec subst1 ~subst = subst_lambda ~subst_rec:subst1 ~free:free1 ~subst let rec eval1 x = eval_lambda ~eval_rec:eval1 ~subst:subst1 x (* The expr language of arithmetic expressions *) type 'a expr = [`Var of string | `Num of int | `Add of 'a * 'a | `Neg of 'a | `Mult of 'a * 'a] let free_expr ~free_rec : _ expr -> _ = function #var as x -> free_var x | `Num _ -> Names.empty | `Add(x, y) -> Names.union (free_rec x) (free_rec y) | `Neg x -> free_rec x | `Mult(x, y) -> Names.union (free_rec x) (free_rec y) (* Here map_expr helps a lot *) let map_expr ~map_rec : _ expr -> _ = function #var as x -> x | `Num _ as x -> x | `Add(x, y) as e -> let x' = map_rec x and y' = map_rec y in if x == x' && y == y' then e else `Add(x', y') | `Neg x as e -> let x' = map_rec x in if x == x' then e else `Neg x' | `Mult(x, y) as e -> let x' = map_rec x and y' = map_rec y in if x == x' && y == y' then e else `Mult(x', y') let subst_expr ~subst_rec ~subst : _ expr -> _ = function #var as x -> subst_var ~subst x | #expr as e -> map_expr ~map_rec:(subst_rec ~subst) e let eval_expr ~eval_rec e = match map_expr ~map_rec:eval_rec e with `Add(`Num m, `Num n) -> `Num (m+n) | `Neg(`Num n) -> `Num (-n) | `Mult(`Num m, `Num n) -> `Num (m*n) | #expr as e -> e (* Specialized versions *) let rec free2 x = free_expr ~free_rec:free2 x let rec subst2 ~subst = subst_expr ~subst_rec:subst2 ~subst let rec eval2 x = eval_expr ~eval_rec:eval2 x (* The lexpr language, reunion of lambda and expr *) type lexpr = [ `Var of string | `Abs of string * lexpr | `App of lexpr * lexpr | `Num of int | `Add of lexpr * lexpr | `Neg of lexpr | `Mult of lexpr * lexpr ] let rec free : lexpr -> _ = function #lambda as x -> free_lambda ~free_rec:free x | #expr as x -> free_expr ~free_rec:free x let rec subst ~subst:s : lexpr -> _ = function #lambda as x -> subst_lambda ~subst_rec:subst ~subst:s ~free x | #expr as x -> subst_expr ~subst_rec:subst ~subst:s x let rec eval : lexpr -> _ = function #lambda as x -> eval_lambda ~eval_rec:eval ~subst x | #expr as x -> eval_expr ~eval_rec:eval x let rec print = function | `Var id -> print_string id | `Abs (id, l) -> print_string ("\ " ^ id ^ " . "); print l | `App (l1, l2) -> print l1; print_string " "; print l2 | `Num x -> print_int x | `Add (e1, e2) -> print e1; print_string " + "; print e2 | `Neg e -> print_string "-"; print e | `Mult (e1, e2) -> print e1; print_string " * "; print e2 let () = let e1 = eval1 (`App(`Abs("x",`Var"x"), `Var"y")) in let e2 = eval2 (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in let e3 = eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) in print e1; print_newline (); print e2; print_newline (); print e3; print_newline () mingw-ocaml/ocaml/testsuite/tests/typing-labels/Makefile0000644000175000017500000000015112124403241023060 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-labels/mixin3.reference0000644000175000017500000000001312124403241024504 0ustar tootstootsy -6 + x 9 mingw-ocaml/ocaml/testsuite/tests/typing-labels/mixin2.reference0000644000175000017500000000001312124403241024503 0ustar tootstootsy -6 + x 9 mingw-ocaml/ocaml/testsuite/tests/typing-labels/mixin3.ml0000644000175000017500000001243612124403241023172 0ustar tootstoots(* $Id$ *) (* Full fledge version, using objects to structure code *) open StdLabels open MoreLabels (* Use maps for substitutions and sets for free variables *) module Subst = Map.Make(struct type t = string let compare = compare end) module Names = Set.Make(struct type t = string let compare = compare end) (* To build recursive objects *) let lazy_fix make = let rec obj () = make (lazy (obj ()) : _ Lazy.t) in obj () let (!!) = Lazy.force (* The basic operations *) class type ['a, 'b] ops = object method free : 'b -> Names.t method subst : sub:'a Subst.t -> 'b -> 'a method eval : 'b -> 'a end (* Variables are common to lambda and expr *) type var = [`Var of string] let var = object (self : ([>var], var) #ops) method subst ~sub (`Var s as x) = try Subst.find s sub with Not_found -> x method free (`Var s) = Names.singleton s method eval (#var as v) = v end (* The lambda language: free variables, substitutions, and evaluation *) type 'a lambda = [`Var of string | `Abs of string * 'a | `App of 'a * 'a] let next_id = let current = ref 3 in fun () -> incr current; !current let lambda_ops (ops : ('a,'a) #ops Lazy.t) = let free = lazy !!ops#free and subst = lazy !!ops#subst and eval = lazy !!ops#eval in object (self : ([> 'a lambda], 'a lambda) #ops) method free = function #var as x -> var#free x | `Abs (s, t) -> Names.remove s (!!free t) | `App (t1, t2) -> Names.union (!!free t1) (!!free t2) method private map ~f = function #var as x -> x | `Abs (s, t) as l -> let t' = f t in if t == t' then l else `Abs(s, t') | `App (t1, t2) as l -> let t'1 = f t1 and t'2 = f t2 in if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2) method subst ~sub = function #var as x -> var#subst ~sub x | `Abs(s, t) as l -> let used = !!free t in let used_expr = Subst.fold sub ~init:[] ~f:(fun ~key ~data acc -> if Names.mem s used then data::acc else acc) in if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then let name = s ^ string_of_int (next_id ()) in `Abs(name, !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t) else self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l | `App _ as l -> self#map ~f:(!!subst ~sub) l method eval l = match self#map ~f:!!eval l with `App(`Abs(s,t1), t2) -> !!eval (!!subst ~sub:(Subst.add ~key:s ~data:t2 Subst.empty) t1) | t -> t end (* Operations specialized to lambda *) let lambda = lazy_fix lambda_ops (* The expr language of arithmetic expressions *) type 'a expr = [ `Var of string | `Num of int | `Add of 'a * 'a | `Neg of 'a | `Mult of 'a * 'a] let expr_ops (ops : ('a,'a) #ops Lazy.t) = let free = lazy !!ops#free and subst = lazy !!ops#subst and eval = lazy !!ops#eval in object (self : ([> 'a expr], 'a expr) #ops) method free = function #var as x -> var#free x | `Num _ -> Names.empty | `Add(x, y) -> Names.union (!!free x) (!!free y) | `Neg x -> !!free x | `Mult(x, y) -> Names.union (!!free x) (!!free y) method private map ~f = function #var as x -> x | `Num _ as x -> x | `Add(x, y) as e -> let x' = f x and y' = f y in if x == x' && y == y' then e else `Add(x', y') | `Neg x as e -> let x' = f x in if x == x' then e else `Neg x' | `Mult(x, y) as e -> let x' = f x and y' = f y in if x == x' && y == y' then e else `Mult(x', y') method subst ~sub = function #var as x -> var#subst ~sub x | #expr as e -> self#map ~f:(!!subst ~sub) e method eval (#expr as e) = match self#map ~f:!!eval e with `Add(`Num m, `Num n) -> `Num (m+n) | `Neg(`Num n) -> `Num (-n) | `Mult(`Num m, `Num n) -> `Num (m*n) | e -> e end (* Specialized versions *) let expr = lazy_fix expr_ops (* The lexpr language, reunion of lambda and expr *) type 'a lexpr = [ 'a lambda | 'a expr ] let lexpr_ops (ops : ('a,'a) #ops Lazy.t) = let lambda = lambda_ops ops in let expr = expr_ops ops in object (self : ([> 'a lexpr], 'a lexpr) #ops) method free = function #lambda as x -> lambda#free x | #expr as x -> expr#free x method subst ~sub = function #lambda as x -> lambda#subst ~sub x | #expr as x -> expr#subst ~sub x method eval = function #lambda as x -> lambda#eval x | #expr as x -> expr#eval x end let lexpr = lazy_fix lexpr_ops let rec print = function | `Var id -> print_string id | `Abs (id, l) -> print_string ("\ " ^ id ^ " . "); print l | `App (l1, l2) -> print l1; print_string " "; print l2 | `Num x -> print_int x | `Add (e1, e2) -> print e1; print_string " + "; print e2 | `Neg e -> print_string "-"; print e | `Mult (e1, e2) -> print e1; print_string " * "; print e2 let () = let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in let e3 = lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) in print e1; print_newline (); print e2; print_newline (); print e3; print_newline () mingw-ocaml/ocaml/testsuite/tests/typing-labels/mixin2.ml0000644000175000017500000001275512124403241023175 0ustar tootstoots(* $Id$ *) (* Full fledge version, using objects to structure code *) open StdLabels open MoreLabels (* Use maps for substitutions and sets for free variables *) module Subst = Map.Make(struct type t = string let compare = compare end) module Names = Set.Make(struct type t = string let compare = compare end) (* To build recursive objects *) let lazy_fix make = let rec obj () = make (lazy (obj ()) : _ Lazy.t) in obj () let (!!) = Lazy.force (* The basic operations *) class type ['a, 'b] ops = object method free : 'b -> Names.t method subst : sub:'a Subst.t -> 'b -> 'a method eval : 'b -> 'a end (* Variables are common to lambda and expr *) type var = [`Var of string] class ['a] var_ops = object (self : ('a, var) #ops) constraint 'a = [> var] method subst ~sub (`Var s as x) = try Subst.find s sub with Not_found -> x method free (`Var s) = Names.singleton s method eval (#var as v) = v end (* The lambda language: free variables, substitutions, and evaluation *) type 'a lambda = [`Var of string | `Abs of string * 'a | `App of 'a * 'a] let next_id = let current = ref 3 in fun () -> incr current; !current class ['a] lambda_ops (ops : ('a,'a) #ops Lazy.t) = let var : 'a var_ops = new var_ops and free = lazy !!ops#free and subst = lazy !!ops#subst and eval = lazy !!ops#eval in object (self : ('a, 'a lambda) #ops) constraint 'a = [> 'a lambda] method free = function #var as x -> var#free x | `Abs (s, t) -> Names.remove s (!!free t) | `App (t1, t2) -> Names.union (!!free t1) (!!free t2) method map ~f = function #var as x -> x | `Abs (s, t) as l -> let t' = f t in if t == t' then l else `Abs(s, t') | `App (t1, t2) as l -> let t'1 = f t1 and t'2 = f t2 in if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2) method subst ~sub = function #var as x -> var#subst ~sub x | `Abs(s, t) as l -> let used = !!free t in let used_expr = Subst.fold sub ~init:[] ~f:(fun ~key ~data acc -> if Names.mem s used then data::acc else acc) in if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then let name = s ^ string_of_int (next_id ()) in `Abs(name, !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t) else self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l | `App _ as l -> self#map ~f:(!!subst ~sub) l method eval l = match self#map ~f:!!eval l with `App(`Abs(s,t1), t2) -> !!eval (!!subst ~sub:(Subst.add ~key:s ~data:t2 Subst.empty) t1) | t -> t end (* Operations specialized to lambda *) let lambda = lazy_fix (new lambda_ops) (* The expr language of arithmetic expressions *) type 'a expr = [ `Var of string | `Num of int | `Add of 'a * 'a | `Neg of 'a | `Mult of 'a * 'a] class ['a] expr_ops (ops : ('a,'a) #ops Lazy.t) = let var : 'a var_ops = new var_ops and free = lazy !!ops#free and subst = lazy !!ops#subst and eval = lazy !!ops#eval in object (self : ('a, 'a expr) #ops) constraint 'a = [> 'a expr] method free = function #var as x -> var#free x | `Num _ -> Names.empty | `Add(x, y) -> Names.union (!!free x) (!!free y) | `Neg x -> !!free x | `Mult(x, y) -> Names.union (!!free x) (!!free y) method map ~f = function #var as x -> x | `Num _ as x -> x | `Add(x, y) as e -> let x' = f x and y' = f y in if x == x' && y == y' then e else `Add(x', y') | `Neg x as e -> let x' = f x in if x == x' then e else `Neg x' | `Mult(x, y) as e -> let x' = f x and y' = f y in if x == x' && y == y' then e else `Mult(x', y') method subst ~sub = function #var as x -> var#subst ~sub x | #expr as e -> self#map ~f:(!!subst ~sub) e method eval (#expr as e) = match self#map ~f:!!eval e with `Add(`Num m, `Num n) -> `Num (m+n) | `Neg(`Num n) -> `Num (-n) | `Mult(`Num m, `Num n) -> `Num (m*n) | e -> e end (* Specialized versions *) let expr = lazy_fix (new expr_ops) (* The lexpr language, reunion of lambda and expr *) type 'a lexpr = [ 'a lambda | 'a expr ] class ['a] lexpr_ops (ops : ('a,'a) #ops Lazy.t) = let lambda = new lambda_ops ops in let expr = new expr_ops ops in object (self : ('a, 'a lexpr) #ops) constraint 'a = [> 'a lexpr] method free = function #lambda as x -> lambda#free x | #expr as x -> expr#free x method subst ~sub = function #lambda as x -> lambda#subst ~sub x | #expr as x -> expr#subst ~sub x method eval = function #lambda as x -> lambda#eval x | #expr as x -> expr#eval x end let lexpr = lazy_fix (new lexpr_ops) let rec print = function | `Var id -> print_string id | `Abs (id, l) -> print_string ("\ " ^ id ^ " . "); print l | `App (l1, l2) -> print l1; print_string " "; print l2 | `Num x -> print_int x | `Add (e1, e2) -> print e1; print_string " + "; print e2 | `Neg e -> print_string "-"; print e | `Mult (e1, e2) -> print e1; print_string " * "; print e2 let () = let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in let e3 = lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) in print e1; print_newline (); print e2; print_newline (); print e3; print_newline () mingw-ocaml/ocaml/testsuite/tests/typing-labels/mixin.reference0000644000175000017500000000001312124403241024421 0ustar tootstootsy -6 + x 9 mingw-ocaml/ocaml/testsuite/tests/basic-io-2/0000755000175000017500000000000012124403241020476 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/basic-io-2/Makefile0000644000175000017500000000021712124403241022136 0ustar tootstootsBASEDIR=../.. #MODULES= MAIN_MODULE=io EXEC_ARGS=io.ml include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/basic-io-2/io.ml0000644000175000017500000000541012124403241021437 0ustar tootstoots(* Test a file copy function *) let test msg funct f1 f2 = print_string msg; print_newline(); funct f1 f2; if Sys.command ("cmp " ^ f1 ^ " " ^ f2) = 0 then print_string "passed" else print_string "FAILED"; print_newline() (* File copy with constant-sized chunks *) let copy_file sz infile ofile = let ic = open_in_bin infile in let oc = open_out_bin ofile in let buffer = String.create sz in let rec copy () = let n = input ic buffer 0 sz in if n = 0 then () else begin output oc buffer 0 n; copy () end in copy(); close_in ic; close_out oc (* File copy with random-sized chunks *) let copy_random sz infile ofile = let ic = open_in_bin infile in let oc = open_out_bin ofile in let buffer = String.create sz in let rec copy () = let s = 1 + Random.int sz in let n = input ic buffer 0 s in if n = 0 then () else begin output oc buffer 0 n; copy () end in copy(); close_in ic; close_out oc (* File copy line per line *) let copy_line infile ofile = let ic = open_in_bin infile in let oc = open_out_bin ofile in try while true do output_string oc (input_line ic); output_char oc '\n' done with End_of_file -> close_in ic; close_out oc (* Backward copy, with lots of seeks *) let copy_seek chunksize infile ofile = let ic = open_in_bin infile in let oc = open_out_bin ofile in let size = in_channel_length ic in let buffer = String.create chunksize in for i = (size - 1) / chunksize downto 0 do seek_in ic (i * chunksize); seek_out oc (i * chunksize); let n = input ic buffer 0 chunksize in output oc buffer 0 n done; close_in ic; close_out oc (* Create long lines of text *) let make_lines ofile = let oc = open_out_bin ofile in for i = 1 to 256 do output_string oc (String.make (i*64) '.'); output_char oc '\n' done; close_out oc (* The test *) let _ = let src = Sys.argv.(1) in let testio = Filename.temp_file "testio" "" in let lines = Filename.temp_file "lines" "" in test "16-byte chunks" (copy_file 16) src testio; test "256-byte chunks" (copy_file 256) src testio; test "4096-byte chunks" (copy_file 4096) src testio; test "65536-byte chunks" (copy_file 65536) src testio; test "19-byte chunks" (copy_file 19) src testio; test "263-byte chunks" (copy_file 263) src testio; test "4011-byte chunks" (copy_file 4011) src testio; test "0...8192 byte chunks" (copy_random 8192) src testio; test "line per line, short lines" copy_line "/etc/hosts" testio; make_lines lines; test "line per line, short and long lines" copy_line lines testio; test "backwards, 4096-byte chunks" (copy_seek 4096) src testio; test "backwards, 64-byte chunks" (copy_seek 64) src testio; Sys.remove lines; Sys.remove testio; exit 0 mingw-ocaml/ocaml/testsuite/tests/basic-io-2/io.reference0000644000175000017500000000052012124403241022762 0ustar tootstoots16-byte chunks passed 256-byte chunks passed 4096-byte chunks passed 65536-byte chunks passed 19-byte chunks passed 263-byte chunks passed 4011-byte chunks passed 0...8192 byte chunks passed line per line, short lines passed line per line, short and long lines passed backwards, 4096-byte chunks passed backwards, 64-byte chunks passed mingw-ocaml/ocaml/testsuite/tests/regression-pr5080-notes/0000755000175000017500000000000012124403241023113 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/regression-pr5080-notes/.gitignore0000644000175000017500000000000012124403241025071 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-scanf/0000755000175000017500000000000012124403241020507 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-scanf/.ignore0000644000175000017500000000001412124403241021766 0ustar tootstootstscanf_data mingw-ocaml/ocaml/testsuite/tests/lib-scanf/Makefile0000644000175000017500000000026712124403241022154 0ustar tootstootsBASEDIR=../.. #MODULES= MAIN_MODULE=tscanf ADD_COMPFLAGS=-I $(BASEDIR)/lib ADD_MODULES=testing include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-scanf/tscanf.ml0000644000175000017500000012203612124403241022323 0ustar tootstoots(*************************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (*************************************************************************) (* $Id$ A testbed file for the module Scanf. *) open Testing;; open Scanf;; (* The ``continuation'' that returns the scanned value. *) let id x = x;; (* Testing space scanning. *) let test0 () = (sscanf "" "" id) 1 + (sscanf "" " " id) 2 + (sscanf " " " " id) 3 + (sscanf "\t" " " id) 4 + (sscanf "\n" " " id) 5 + (sscanf "\n\t 6" " %d" id) ;; test (test0 () = 21) ;; (* Testing integer scanning %i and %d. *) let test1 () = sscanf "1" "%d" id + sscanf " 2" " %d" id + sscanf " -2" " %d" id + sscanf " +2" " %d" id + sscanf " 2a " " %da" id ;; test (test1 () = 5) ;; let test2 () = sscanf "123" "%2i" id + sscanf "245" "%d" id + sscanf " 2a " " %1da" id ;; test (test2 () = 259) ;; let test3 () = sscanf "0xff" "%3i" id + sscanf "0XEF" "%3i" id + sscanf "x=-245" " x = %d" id + sscanf " 2a " " %1da" id ;; test (test3 () = -214) ;; (* Testing float scanning. *) (* f style. *) let test4 () = bscanf (Scanning.from_string "1") "%f" (fun b0 -> b0 = 1.0) && bscanf (Scanning.from_string "-1") "%f" (fun b0 -> b0 = -1.0) && bscanf (Scanning.from_string "+1") "%f" (fun b0 -> b0 = 1.0) && bscanf (Scanning.from_string "1.") "%f" (fun b0 -> b0 = 1.0) && bscanf (Scanning.from_string ".1") "%f" (fun b0 -> b0 = 0.1) && bscanf (Scanning.from_string "-.1") "%f" (fun b0 -> b0 = -0.1) && bscanf (Scanning.from_string "+.1") "%f" (fun b0 -> b0 = 0.1) && bscanf (Scanning.from_string "+1.") "%f" (fun b0 -> b0 = 1.0) && bscanf (Scanning.from_string "-1.") "%f" (fun b0 -> b0 = -1.0) && bscanf (Scanning.from_string "0 1. 1.3") "%f %f %f" (fun b0 b1 b2 -> b0 = 0.0 && b1 = 1.0 && b2 = 1.3) && bscanf (Scanning.from_string "0.113") "%4f" (fun b0 -> b0 = 0.11) && bscanf (Scanning.from_string "0.113") "%5f" (fun b0 -> b0 = 0.113) && bscanf (Scanning.from_string "000.113") "%15f" (fun b0 -> b0 = 0.113) && bscanf (Scanning.from_string "+000.113") "%15f" (fun b0 -> b0 = 0.113) && bscanf (Scanning.from_string "-000.113") "%15f" (fun b0 -> b0 = -0.113) ;; test (test4 ()) ;; (* e style. *) let test5 () = bscanf (Scanning.from_string "1e1") "%e" (fun b -> b = 10.0) && bscanf (Scanning.from_string "1e+1") "%e" (fun b -> b = 10.0) && bscanf (Scanning.from_string "10e-1") "%e" (fun b -> b = 1.0) && bscanf (Scanning.from_string "10.e-1") "%e" (fun b -> b = 1.0) && bscanf (Scanning.from_string "1e1 1.e+1 1.3e-1") "%e %e %e" (fun b1 b2 b3 -> b1 = 10.0 && b2 = b1 && b3 = 0.13) && (* g style. *) bscanf (Scanning.from_string "1 1.1 0e+1 1.3e-1") "%g %g %g %g" (fun b1 b2 b3 b4 -> b1 = 1.0 && b2 = 1.1 && b3 = 0.0 && b4 = 0.13) ;; test (test5 ()) ;; (* Testing boolean scanning. *) let test6 () = bscanf (Scanning.from_string "truetrue") "%B%B" (fun b1 b2 -> (b1, b2) = (true, true)) && bscanf (Scanning.from_string "truefalse") "%B%B" (fun b1 b2 -> (b1, b2) = (true, false)) && bscanf (Scanning.from_string "falsetrue") "%B%B" (fun b1 b2 -> (b1, b2) = (false, true)) && bscanf (Scanning.from_string "falsefalse") "%B%B" (fun b1 b2 -> (b1, b2) = (false, false)) && bscanf (Scanning.from_string "true false") "%B %B" (fun b1 b2 -> (b1, b2) = (true, false)) ;; test (test6 ()) ;; (* Testing char scanning. *) let test7 () = bscanf (Scanning.from_string "'a' '\n' '\t' '\000' '\032'") "%C %C %C %C %C" (fun c1 c2 c3 c4 c5 -> c1 = 'a' && c2 = '\n' && c3 = '\t' && c4 = '\000' && c5 = '\032') && (* Here \n, \t, and \032 are skipped due to the space semantics of scanf. *) bscanf (Scanning.from_string "a \n \t \000 \032b") "%c %c %c " (fun c1 c2 c3 -> c1 = 'a' && c2 = '\000' && c3 = 'b') ;; test (test7 ()) ;; let verify_read c = let s = Printf.sprintf "%C" c in let ib = Scanning.from_string s in assert (bscanf ib "%C" id = c) ;; let verify_scan_Chars () = for i = 0 to 255 do verify_read (char_of_int i) done ;; let test8 () = verify_scan_Chars () = ();; test (test8 ()) ;; (* Testing string scanning. *) (* %S and %s styles. *) let unit fmt s = let ib = Scanning.from_string (Printf.sprintf "%S" s) in Scanf.bscanf ib fmt id ;; let test_fmt fmt s = unit fmt s = s;; (* The following test9_string is a result for test9 scanning. Test9_string is the string "", that is character i trma, followed by french right guillemet, followed by inverted question mark. It is NOT the string "Ԫ", that is uppercase o with circonflex accent, followed by commercial a, followed by empty set. In other words, the string "" has the following 3 characters "\239\187\191". It has NOT the characters "\212\170\248"! Beware with automatic translation by your own local settings (being your locale or your OS!) *) let test9_string = "";; let test_S = test_fmt "%S";; let test9 () = test_S "poi" && test_S "a\"b" && test_S "a\nb" && test_S "a\010b" && test_S "a\\\n\ b \\\n\ c\010\\\n\ b" && test_S "a\\\n\ \\\n\ \\\n\ b \\\n\ c\010\\\n\ b" && test_S "\xef" && test_S "\\xef" && Scanf.sscanf "\"\\xef\"" "%S" (fun s -> s) = "\xef" && Scanf.sscanf "\"\\xef\\xbb\\xbf\"" "%S" (fun s -> s) = test9_string && Scanf.sscanf "\"\\xef\\xbb\\xbf\"" "%S" (fun s -> s) = "\239\187\191" && Scanf.sscanf "\"\xef\xbb\xbf\"" "%S" (fun s -> s) = test9_string && Scanf.sscanf "\"\\\\xef\\\\xbb\\\\xbf\"" "%S" (fun s -> s) = "\\xef\\xbb\\xbf" && Scanf.sscanf "\"\ \"" "%S" (fun s -> s) = "\ " ;; test (test9 ()) ;; let test10 () = let unit s = let ib = Scanning.from_string s in Scanf.bscanf ib "%S" id in let res = sscanf "Une chane: \"celle-ci\" et \"celle-l\"!" "%s %s %S %s %S %s" (fun s1 s2 s3 s4 s5 s6 -> s1 ^ s2 ^ s3 ^ s4 ^ s5 ^ s6) in res = "Unechane:celle-cietcelle-l!" && (* Testing the result of reading a %S string. *) unit "\"a\\\n b\"" = "ab" && unit "\"\\\n ab\"" = "ab" && unit "\"\n\\\n ab\"" = "\nab" && unit "\"\n\\\n a\nb\"" = "\na\nb" && unit "\"\n\\\n \\\n a\nb\"" = "\na\nb" && unit "\"\n\\\n a\n\\\nb\\\n\"" = "\na\nb" && unit "\"a\\\n \"" = "a" && true ;; test (test10 ()) ;; (* %[] style *) let test11 () = sscanf "Pierre\tWeis\t70" "%s %s %s" (fun prenom nom poids -> prenom = "Pierre" && nom = "Weis" && int_of_string poids = 70) && sscanf "Jean-Luc\tde Lage\t68" "%[^\t] %[^\t] %d" (fun prenom nom poids -> prenom = "Jean-Luc" && nom = "de Lage" && poids = 68) && sscanf "Daniel\tde Rauglaudre\t66" "%s@\t %s@\t %d" (fun prenom nom poids -> prenom = "Daniel" && nom = "de Rauglaudre" && poids = 66) ;; (* Empty string (end of input) testing. *) let test110 () = sscanf "" " " (fun x -> x) "" = "" && sscanf "" "%s" (fun x -> x = "") && sscanf "" "%s%s" (fun x y -> x = "" && y = "") && sscanf "" "%s " (fun x -> x = "") && sscanf "" " %s" (fun x -> x = "") && sscanf "" " %s " (fun x -> x = "") && sscanf "" "%[^\n]" (fun x -> x = "") && sscanf "" "%[^\n] " (fun x -> x = "") && sscanf " " "%s" (fun x -> x = "") && sscanf " " "%s%s" (fun x y -> x = "" && y = "") && sscanf " " " %s " (fun x -> x = "") && sscanf " " " %s %s" (fun x y -> x = "" && x = y) && sscanf " " " %s@ %s" (fun x y -> x = "" && x = y) && sscanf " poi !" " %s@ %s@." (fun x y -> x = "poi" && y = "!") && sscanf " poi !" "%s@ %s@." (fun x y -> x = "" && y = "poi !") ;; let test111 () = sscanf "" "%[^\n]@\n" (fun x -> x = "");; test (test11 () && test110 () && test111 ()) ;; (* Scanning lists. *) let ib () = Scanning.from_string "[1;2;3;4; ]";; (* Statically known lists can be scanned directly. *) let f ib = bscanf ib " [" (); bscanf ib " %i;" (fun i -> bscanf ib " %i;" (fun j -> bscanf ib " %i;" (fun k -> bscanf ib " %i;" (fun l -> bscanf ib " ]" (); [i; j; k; l]))));; let test12 () = f (ib ()) = [1; 2; 3; 4];; test (test12 ()) ;; (* A general list scanner that always fails to succeed. *) let rec scan_elems ib accu = try bscanf ib " %i;" (fun i -> scan_elems ib (i :: accu)) with | _ -> accu ;; let g ib = bscanf ib "[ " (); List.rev (scan_elems ib []);; let test13 () = g (ib ()) = [1; 2; 3; 4];; test (test13 ()) ;; (* A general int list scanner. *) let rec scan_int_list ib = bscanf ib "[ " (); let accu = scan_elems ib [] in bscanf ib " ]" (); List.rev accu ;; let test14 () = scan_int_list (ib ()) = [1; 2; 3; 4];; test (test14 ()) ;; (* A general list scanner that always succeeds. *) let rec scan_elems ib accu = bscanf ib " %i %c" (fun i -> function | ';' -> scan_elems ib (i :: accu) | ']' -> List.rev (i :: accu) | c -> failwith "scan_elems") ;; let rec scan_int_list ib = bscanf ib "[ " (); scan_elems ib [] ;; let test15 () = scan_int_list (Scanning.from_string "[1;2;3;4]") = [1; 2; 3; 4];; test (test15 ()) ;; let rec scan_elems ib accu = try bscanf ib "%c %i" (fun c i -> match c with | ';' -> scan_elems ib (i :: accu) | ']' -> List.rev (i :: accu) | '[' when accu = [] -> scan_elems ib (i :: accu) | c -> print_endline (String.make 1 c); failwith "scan_elems") with | Scan_failure _ -> bscanf ib "]" (); accu | End_of_file -> accu ;; let scan_int_list ib = scan_elems ib [];; let test16 () = scan_int_list (Scanning.from_string "[]") = List.rev [] && scan_int_list (Scanning.from_string "[1;2;3;4]") = List.rev [1;2;3;4] && scan_int_list (Scanning.from_string "[1;2;3;4; ]") = List.rev [1;2;3;4] && (* Should fail but succeeds! *) scan_int_list (Scanning.from_string "[1;2;3;4") = List.rev [1;2;3;4];; test (test16 ()) ;; let rec scan_elems ib accu = bscanf ib " %i%[]; \t\n\r]" (fun i s -> match s with | ";" -> scan_elems ib (i :: accu) | "]" -> List.rev (i :: accu) | s -> List.rev (i :: accu)) ;; let scan_int_list ib = bscanf ib " [" (); scan_elems ib [] ;; let test17 () = scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] && scan_int_list (Scanning.from_string "[1;2;3;4; ]") = [1;2;3;4] && (* Should fail but succeeds! *) scan_int_list (Scanning.from_string "[1;2;3;4 5]") = [1;2;3;4];; test (test17 ()) ;; let rec scan_elems ib accu = bscanf ib " %c " (fun c -> match c with | '[' when accu = [] -> (* begginning of list: could find either - an int, if the list is not empty, - the char ], if the list is empty. *) bscanf ib "%[]]" (function | "]" -> accu | _ -> bscanf ib " %i " (fun i -> scan_rest ib (i :: accu))) | _ -> failwith "scan_elems") and scan_rest ib accu = bscanf ib " %c " (fun c -> match c with | ';' -> bscanf ib "%[]]" (function | "]" -> accu | _ -> bscanf ib " %i " (fun i -> scan_rest ib (i :: accu))) | ']' -> accu | _ -> failwith "scan_rest") ;; let scan_int_list ib = List.rev (scan_elems ib []);; let test18 () = scan_int_list (Scanning.from_string "[]") = [] && scan_int_list (Scanning.from_string "[ ]") = [] && scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] && scan_int_list (Scanning.from_string "[1;2;3;4; ]") = [1;2;3;4];; test (test18 ()) ;; (* Those properly fail *) let test19 () = failure_test scan_int_list (Scanning.from_string "[1;2;3;4 5]") "scan_rest" ;; (test19 ()) ;; let test20 () = scan_failure_test scan_int_list (Scanning.from_string "[1;2;3;4;; 5]");; (test20 ()) ;; let test21 () = scan_failure_test scan_int_list (Scanning.from_string "[1;2;3;4;;");; (test21 ()) ;; let rec scan_elems ib accu = bscanf ib "%1[];]" (function | "]" -> accu | ";" -> scan_rest ib accu | _ -> failwith (Printf.sprintf "scan_int_list" (* "scan_int_list: char %i waiting for ']' or ';' but found %c" (Scanning.char_count ib) (Scanning.peek_char ib)*))) and scan_rest ib accu = bscanf ib "%[]]" (function | "]" -> accu | _ -> scan_elem ib accu) and scan_elem ib accu = bscanf ib " %i " (fun i -> scan_elems ib (i :: accu)) ;; let scan_int_list ib = bscanf ib " [ " (); List.rev (scan_rest ib []) ;; let test22 () = scan_int_list (Scanning.from_string "[]") = [] && scan_int_list (Scanning.from_string "[ ]") = [] && scan_int_list (Scanning.from_string "[1]") = [1] && scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] && scan_int_list (Scanning.from_string "[1;2;3;4;]") = [1;2;3;4];; test (test22 ()) ;; (* Should work but does not with this version of scan_int_list! scan_int_list (Scanning.from_string "[1;2;3;4; ]");; (* Should lead to a bad input error. *) scan_int_list (Scanning.from_string "[1;2;3;4 5]");; scan_int_list (Scanning.from_string "[1;2;3;4;;");; scan_int_list (Scanning.from_string "[1;2;3;4;; 5]");; scan_int_list (Scanning.from_string "[1;2;3;4;; 23]");; *) let rec scan_elems ib accu = try bscanf ib " %i %1[;]" (fun i s -> if s = "" then i :: accu else scan_elems ib (i :: accu)) with | Scan_failure _ -> accu ;; (* The general int list scanner. *) let rec scan_int_list ib = bscanf ib "[ " (); let accu = scan_elems ib [] in bscanf ib " ]" (); List.rev accu ;; (* The general HO list scanner. This version does not fix the separator, nor the spacing before and after the separator (it uses the functional argument [scan_elem] to parse the separator, its spacing, and the item). *) let rec scan_elems ib scan_elem accu = try scan_elem ib (fun i s -> let accu = i :: accu in if s = "" then accu else scan_elems ib scan_elem accu) with | Scan_failure _ -> accu ;; let scan_list scan_elem ib = bscanf ib "[ " (); let accu = scan_elems ib scan_elem [] in bscanf ib " ]" (); List.rev accu ;; (* Deriving particular list scanners from the HO list scanner. *) let scan_int_elem ib = bscanf ib " %i %1[;]";; let scan_int_list = scan_list scan_int_elem;; let test23 () = scan_int_list (Scanning.from_string "[]") = [] && scan_int_list (Scanning.from_string "[ ]") = [] && scan_int_list (Scanning.from_string "[1]") = [1] && scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] && scan_int_list (Scanning.from_string "[1;2;3;4;]") = [1;2;3;4];; test (test23 ()) ;; let test24 () = scan_failure_test scan_int_list (Scanning.from_string "[1;2;3;4 5]") and test25 () = scan_failure_test scan_int_list (Scanning.from_string "[1;2;3;4;;") and test26 () = scan_failure_test scan_int_list (Scanning.from_string "[1;2;3;4;; 5]") and test27 () = scan_failure_test scan_int_list (Scanning.from_string "[1;2;3;4;; 23]");; (test24 ()) && (test25 ()) && (test26 ()) && (test27 ()) ;; (* To scan an OCaml string: the format is "\"%s@\"". A better way would be to add a %S (String.escaped), a %C (Char.escaped). This is now available. *) let scan_string_elem ib = bscanf ib " \"%s@\" %1[;]";; let scan_string_list = scan_list scan_string_elem;; let scan_String_elem ib = bscanf ib " %S %1[;]";; let scan_String_list = scan_list scan_String_elem;; let test28 () = scan_string_list (Scanning.from_string "[]") = [] && scan_string_list (Scanning.from_string "[\"Le\"]") = ["Le"] && scan_string_list (Scanning.from_string "[\"Le\";\"langage\";\"Objective\";\"Caml\"]") = ["Le"; "langage"; "Objective"; "Caml"] && scan_string_list (Scanning.from_string "[\"Le\";\"langage\";\"Objective\";\"Caml\"; ]") = ["Le"; "langage"; "Objective"; "Caml"] && scan_String_list (Scanning.from_string "[]") = [] && scan_String_list (Scanning.from_string "[\"Le\"]") = ["Le"] && scan_String_list (Scanning.from_string "[\"Le\";\"langage\";\"Objective\";\"Caml\"]") = ["Le"; "langage"; "Objective"; "Caml"] && scan_String_list (Scanning.from_string "[\"Le\";\"langage\";\"Objective\";\"Caml\"; ]") = ["Le"; "langage"; "Objective"; "Caml"];; test (test28 ()) ;; (* The general HO list scanner with continuations. *) let rec scan_elems ib scan_elem accu = scan_elem ib (fun i s -> let accu = i :: accu in if s = "" then accu else scan_elems ib scan_elem accu) (fun ib exc -> accu) ;; let scan_list scan_elem ib = bscanf ib "[ " (); let accu = scan_elems ib scan_elem [] in bscanf ib " ]" (); List.rev accu ;; (* Deriving particular list scanners from the HO list scanner. *) let scan_int_elem ib f ek = kscanf ib ek " %i %1[;]" f;; let scan_int_list = scan_list scan_int_elem;; let test29 () = scan_int_list (Scanning.from_string "[]") = [] && scan_int_list (Scanning.from_string "[ ]") = [] && scan_int_list (Scanning.from_string "[1]") = [1] && scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] && scan_int_list (Scanning.from_string "[1;2;3;4;]") = [1;2;3;4];; test (test29 ()) ;; let scan_string_elem ib f ek = kscanf ib ek " %S %1[;]" f;; let scan_string_list = scan_list scan_string_elem;; let test30 () = scan_string_list (Scanning.from_string "[]") = [] && scan_string_list (Scanning.from_string "[ ]") = [] && scan_string_list (Scanning.from_string "[ \"1\" ]") = ["1"] && scan_string_list (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\"]") = ["1"; "2"; "3"; "4"] && scan_string_list (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\";]") = ["1"; "2"; "3"; "4"];; test (test30 ()) ;; (* A generic polymorphic item scanner, *) let scan_elem fmt ib f ek = kscanf ib ek fmt f;; (* Derivation of list scanners from the generic polymorphic item scanner applications. *) let scan_int_list = scan_list (scan_elem " %i %1[;]");; let scan_string_list = scan_list (scan_elem " %S %1[;]");; let scan_bool_list = scan_list (scan_elem " %B %1[;]");; let scan_char_list = scan_list (scan_elem " %C %1[;]");; let scan_float_list = scan_list (scan_elem " %f %1[;]");; (* In this version the [scan_elem] function should be a [kscanf] like scanning function: we give it an error continuation. The [scan_elem] argument, probably use some partial application of the following generic [scan_elem]: let scan_elem fmt ib f ek = kscanf ib ek fmt f;; For instance, a suitable [scan_elem] for integers could be: let scan_integer_elem = scan_elem " %i";; *) let rec scan_elems ib scan_elem accu = scan_elem ib (fun i -> let accu = i :: accu in kscanf ib (fun ib exc -> accu) " %1[;]" (fun s -> if s = "" then accu else scan_elems ib scan_elem accu)) (fun ib exc -> accu) ;; let scan_list scan_elem ib = bscanf ib "[ " (); let accu = scan_elems ib scan_elem [] in bscanf ib " ]" (); List.rev accu ;; let scan_int_list = scan_list (scan_elem " %i");; let scan_string_list = scan_list (scan_elem " %S");; let scan_bool_list = scan_list (scan_elem " %B");; let scan_char_list = scan_list (scan_elem " %C");; let scan_float_list = scan_list (scan_elem " %f");; let test31 () = scan_int_list (Scanning.from_string "[]") = [] && scan_int_list (Scanning.from_string "[ ]") = [] && scan_int_list (Scanning.from_string "[1]") = [1] && scan_int_list (Scanning.from_string "[1;2;3;4]") = [1;2;3;4] && scan_int_list (Scanning.from_string "[1;2;3;4;]") = [1;2;3;4];; test (test31 ()) ;; let test32 () = scan_string_list (Scanning.from_string "[]") = [] && scan_string_list (Scanning.from_string "[ ]") = [] && scan_string_list (Scanning.from_string "[ \"1\" ]") = ["1"] && scan_string_list (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\"]") = ["1"; "2"; "3"; "4"] && scan_string_list (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\";]") = ["1"; "2"; "3"; "4"];; test (test32 ()) ;; (* Using [kscanf] only. We use format values to stand for ``functional'' specifications to scan the elements of lists. The list item separator and the separator spacing are builtin into the [scan_elems] iterator and thus are conveniently omitted from the definitional format for item scanning. *) let rec scan_elems ib scan_elem_fmt accu = kscanf ib (fun ib exc -> accu) scan_elem_fmt (fun i -> let accu = i :: accu in bscanf ib " %1[;] " (function | "" -> accu | _ -> scan_elems ib scan_elem_fmt accu) ) ;; let scan_list scan_elem_fmt ib = bscanf ib "[ " (); let accu = scan_elems ib scan_elem_fmt [] in bscanf ib " ]" (); List.rev accu ;; let scan_int_list = scan_list "%i";; let scan_string_list = scan_list "%S";; let scan_bool_list = scan_list "%B";; let scan_char_list = scan_list "%C";; let scan_float_list = scan_list "%f";; let test33 () = scan_int_list (Scanning.from_string "[]") = [] && scan_int_list (Scanning.from_string "[ ]") = [] && scan_int_list (Scanning.from_string "[ 1 ]") = [1] && scan_int_list (Scanning.from_string "[ 1; 2; 3; 4 ]") = [1; 2; 3; 4] && scan_int_list (Scanning.from_string "[1;2;3;4;]") = [1; 2; 3; 4];; test (test33 ()) ;; let test34 () = scan_string_list (Scanning.from_string "[]") = [] && scan_string_list (Scanning.from_string "[ ]") = [] && scan_string_list (Scanning.from_string "[ \"1\" ]") = ["1"] && scan_string_list (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\"]") = ["1"; "2"; "3"; "4"] && scan_string_list (Scanning.from_string "[\"1\"; \"2\"; \"3\"; \"4\";]") = ["1"; "2"; "3"; "4"];; test (test34 ()) ;; (* Using kscanf only. Same as the preceding functional, except that we no more use format values to scan items: we use scanners that scan elements of the list on the fly. *) (* This version cannot handle empty lists! let rec scan_elems ib scan_elem accu = scan_elem ib (fun elem -> let accu = elem :: accu in kscanf ib (fun ib exc -> accu) " %1[;] " (function | "" -> accu | _ -> scan_elems ib scan_elem accu)) ;; *) (* We use [kscanf] with a [%r] format ! *) let rec scan_elems scan_elem accu ib = kscanf ib (fun ib exc -> accu) "%r" (function ib -> scan_elem ib (function elem -> let accu = elem :: accu in bscanf ib " %1[;] " (function | "" -> accu | _ -> scan_elems scan_elem accu ib))) (function l -> l) ;; let scan_list scan_elem ib = bscanf ib "[ " (); let accu = scan_elems scan_elem [] ib in bscanf ib " ]" (); List.rev accu ;; (* We may also try a version with only one format: We also changed the type of [scan_elem] to partially apply it to its ``natural'' continuation. let rec scan_elems scan_elem accu ib = (* We use [kscanf], so that: if the element reader fails, we can return the list of elements read so far. *) kscanf ib (fun ib exc -> accu) (* The format string for [kscanf]: we read an element using [scan_elem], then find a semi-colon if any, in order to decide if we stop reading or go on with other elements. *) "%r %1[;] " (* The reader: once an element has been read it returns the new accu. *) (scan_elem (function elem -> elem :: accu)) (fun accu s -> (* Cannot find a semi-colon: no more elements to read. *) if s = "" then accu (* We found a semi-colon: go on with the new accu. *) else scan_elems scan_elem accu ib) ;; let scan_list scan_elem ib = bscanf ib "[ %r ]" (scan_elems scan_elem []) List.rev ;; (* For instance: let scan_float f ib = Scanf.bscanf ib "%f" f;; # scan_list scan_float;; - : Scanf.Scanning.scanbuf -> float list = *) (* The element scanner builder. *) let make_scan_elem fmt f ib = Scanf.bscanf ib fmt f;; (* Promote an element reader format to an element list reader. *) let list_scanner fmt = scan_list (make_scan_elem fmt);; let scan_float = make_scan_elem "%f";; scan_list scan_float;; list_scanner "%f";; - : Scanf.Scanning.scanbuf -> float list = *) (* The prototype of a [scan_elem] function for the generic [scan_list] functional. This [scan_elem] scans a floating point number. *) let scan_float ib = Scanf.bscanf ib "%f";; let scan_float_list = scan_list scan_float;; (* In the following list scanners, we directly give the [scan_elem] function as an immediate function value argument to the polymorphic [scan_list]. *) let scan_int_list = scan_list (fun ib -> Scanf.bscanf ib "%i");; let scan_string_list = scan_list (fun ib -> Scanf.bscanf ib "%S");; let scan_bool_list = scan_list (fun ib -> Scanf.bscanf ib "%B");; let scan_char_list = scan_list (fun ib -> Scanf.bscanf ib "%C");; (* [scan_list] is truely polymorphic: scanning a list of lists of items is a one liner! Here we scan list of lists of floats. *) let scan_float_list_list = scan_list (fun ib k -> k (scan_list (fun ib -> Scanf.bscanf ib "%f") ib)) ;; let scan_float_list_list = scan_list (fun ib k -> k (scan_list scan_float ib)) ;; let scan_float_list_list = scan_list (fun ib k -> k (scan_float_list ib)) ;; (* The killer way to define [scan_float_list_list]. *) (* let scan_float_list_list = scan_list scan_float_list;; *) let test340 () = scan_float_list_list (Scanning.from_string "[[1.0] ; []; [2.0; 3; 5.0; 6.];]") = [[1.]; []; [2.; 3.; 5.; 6.]] ;; (* A general scan_list_list functional. *) let scan_list_list scan_elems ib = scan_list (fun ib k -> k (scan_elems ib)) ib ;; let scan_float_list_list = scan_list_list scan_float_list;; (* Programming with continuations :) *) let scan_float_item ib k = k (scan_float ib (fun x -> x));; let scan_float_list ib k = k (scan_list scan_float_item ib);; let scan_float_list_list ib k = k (scan_list scan_float_list ib);; (* Testing the %N format. *) let test35 () = sscanf "" "%N" (fun x -> x) = 0 && sscanf "456" "%N" (fun x -> x) = 0 && sscanf "456" "%d%N" (fun x y -> x, y) = (456, 1) && sscanf " " "%N%s%N" (fun x s y -> x, s, y) = (0, "", 1) ;; test (test340 () && test35 ()) ;; (* The prefered reader functionnals. *) (* To read a list as in OCaml (elements are ``blank + semicolon + blank'' separated, and the list is enclosed in brackets). *) let rec read_elems read_elem accu ib = kscanf ib (fun ib exc -> accu) "%r %1[;] " (read_elem (function elem -> elem :: accu)) (fun accu s -> if s = "" then accu else read_elems read_elem accu ib) ;; let read_list read_elem ib = bscanf ib "[ %r ]" (read_elems read_elem []) List.rev ;; (* The element reader builder. *) let make_read_elem fmt f ib = Scanf.bscanf ib fmt f;; (* Promote an element reader format to an element list reader. *) let scan_List fmt = read_list (make_read_elem fmt);; (* Example for list of floatting point numbers. *) (* scan_List "%f";; - : Scanf.Scanning.scanbuf -> float list = (* To read a list as a succession of elements separated by a blank. *) let rec read_elems read_elem accu ib = kscanf ib (fun ib exc -> accu) "%r " (read_elem (function elem -> elem :: accu)) (fun accu -> read_elems read_elem accu ib) ;; let read_list read_elem ib = List.rev (read_elems read_elem [] ib) ;; (* Promote an element reader format to an element list reader. *) let scan_list fmt = read_list (make_read_elem fmt);; scan_list "%f";; *) (* Testing the %n format. *) let test36 () = sscanf "" "%n" (fun x -> x) = 0 && sscanf "456" "%n" (fun x -> x) = 0 && sscanf "456" "%d%n" (fun x y -> x, y) = (456, 3) && sscanf " " "%n%s%n" (fun x s y -> x, s, y) = (0, "", 0) ;; test (test36 ()) ;; (* Weird tests to empty strings or formats. *) let test37 () = sscanf "" "" true && sscanf "" "" (fun x -> x) 1 = 1 && sscanf "123" "" (fun x -> x) 1 = 1 ;; test (test37 ()) ;; (* Testing end of input condition. *) let test38 () = sscanf "a" "a%!" true && sscanf "a" "a%!%!" true && sscanf " a" " a%!" true && sscanf "a " "a %!" true && sscanf "" "%!" true && sscanf " " " %!" true && sscanf "" " %!" true && sscanf "" " %!%!" true ;; test (test38 ()) ;; (* Weird tests on empty buffers. *) let test39 () = let is_empty_buff ib = Scanning.beginning_of_input ib && Scanning.end_of_input ib in let ib = Scanning.from_string "" in is_empty_buff ib && (* Do it twice since testing empty buff could incorrectly thraw an exception or wrongly change the beginning_of_input condition. *) is_empty_buff ib ;; test (test39 ()) ;; (* Testing ranges. *) let test40 () = let s = "cba" in let ib = Scanning.from_string s in bscanf ib "%[^ab]%s%!" (fun s1 s2 -> s1 = "c" && s2 = "ba") ;; test (test40 ()) ;; let test41 () = let s = "cba" in let ib = Scanning.from_string s in bscanf ib "%[^abc]%[cba]%!" (fun s1 s2 -> s1 = "" && s2 = "cba") ;; test (test41 ()) ;; let test42 () = let s = "defcbaaghi" in let ib = Scanning.from_string s in bscanf ib "%[^abc]%[abc]%s%!" (fun s1 s2 s3 -> s1 = "def" && s2 = "cbaa" && s3 = "ghi") && let ib = Scanning.from_string s in bscanf ib "%s@\t" (fun s -> s = "defcbaaghi") ;; test (test42 ()) ;; (* Testing end of file condition (bug found). *) let test43, test44 = let s = "" in let ib = Scanning.from_string s in (fun () -> bscanf ib "%i%!" (fun i -> i)), (fun () -> bscanf ib "%!%i" (fun i -> i)) ;; test_raises_this_exc End_of_file test43 () && test_raises_this_exc End_of_file test44 () ;; (* Testing small range scanning (bug found once). *) let test45 () = let s = "12.2" in let ib = Scanning.from_string s in bscanf ib "%[0-9].%[0-9]%s%!" (fun s1 s2 s3 -> s1 = "12" && s2 = "2" && s3 = "") ;; test (test45 ()) ;; (* Testing printing of meta formats. *) let test46, test47 = (fun () -> Printf.sprintf "%i %(%s%)." 1 "spells one, %s" "in english"), (fun () -> Printf.sprintf "%i ,%{%s%}, %s." 1 "spells one %s" "in english") ;; test (test46 () = "1 spells one, in english.") ;; test (test47 () = "1 ,%s, in english.") ;; (* Testing scanning of meta formats. *) let test48 () = (* Testing format_from_string. *) let test_meta_read s fmt efmt = format_from_string s fmt = efmt in (* Test if format %i is indeed read as %i. *) let s, fmt = "%i", format_of_string "%i" in test_meta_read s fmt fmt && (* Test if format %i is compatible with %d and indeed read as %i. *) let s, fmt = "%i", format_of_string "%d" in test_meta_read s fmt "%i" && (* Complex test of scanning a meta format specified in the scanner input format string and extraction of its specification from a string. *) sscanf "12 \"%i\"89 " "%i %{%d%}%s %!" (fun i f s -> i = 12 && f = "%i" && s = "89") && (* Testing scanf format string replacement *) let k s = Scanf.sscanf s "%(%f%)" (fun _fmt i -> i) in k "\" : %1f\": 987654321" = 9.0 && k "\" : %2f\": 987654321" = 98.0 && k "\" : %3f\": 9.87654321" = 9.8 && k "\" : %4f\": 9.87654321" = 9.87 && let h s = Scanf.sscanf s "Read integers with %(%i%)" (fun _fmt i -> i) in h "Read integers with \"%1d\"987654321" = 9 && h "Read integers with \"%2d\"987654321" = 98 && h "Read integers with \"%3u\"987654321" = 987 && h "Read integers with \"%4x\"987654321" = 39030 && let i s = Scanf.sscanf s "with %(%i %s%)" (fun _fmt amount currency -> amount, currency) in i "with \" : %d %s\" : 21 euros" = (21, "euros") && i "with \" : %d %s\" : 987654321 dollars" = (987654321, "dollars") && i "with \" : %u %s\" : 54321 pounds" = (54321, "pounds") && i "with \" : %x %s\" : 321 yens" = (801, "yens") && let j s = Scanf.sscanf s "with %(%i %_s %s%)" (fun _fmt amount currency -> amount, currency) in j "with \" : %1d %_s %s\" : 987654321 euros" = (9, "euros") && j "with \" : %2d %_s %s\" : 987654321 dollars" = (98, "dollars") && j "with \" : %3u %_s %s\" : 987654321 pounds" = (987, "pounds") && j "with \" : %4x %_s %s\" : 987654321 yens" = (39030, "yens") ;; test (test48 ()) ;; (* Testing stoppers after ranges. *) let test49 () = sscanf "as" "%[\\]" (fun s -> s = "") && sscanf "as" "%[\\]%s" (fun s t -> s = "" && t = "as") && sscanf "as" "%[\\]%s%!" (fun s t -> s = "" && t = "as") && sscanf "as" "%[a..z]" (fun s -> s = "a") && sscanf "as" "%[a-z]" (fun s -> s = "as") && sscanf "as" "%[a..z]%s" (fun s t -> s = "a" && t = "s") && sscanf "as" "%[a-z]%s" (fun s t -> s = "as" && t = "") && sscanf "-as" "%[-a-z]" (fun s -> s = "-as") && sscanf "-as" "%[-a-z]@s" (fun s -> s = "-a") && sscanf "-as" "-%[a]@s" (fun s -> s = "a") && sscanf "-asb" "-%[a]@sb%!" (fun s -> s = "a") && sscanf "-asb" "-%[a]@s%s" (fun s t -> s = "a" && t = "b") ;; test (test49 ()) ;; (* Testing buffers defined via functions + co-routines that read and write from the same buffers + range chars and proper handling of \n + the end of file condition. *) let next_char ob () = let s = Buffer.contents ob in let len = String.length s in if len = 0 then raise End_of_file else let c = s.[0] in Buffer.clear ob; Buffer.add_string ob (String.sub s 1 (len - 1)); c ;; let send_string ob s = Buffer.add_string ob s; Buffer.add_char ob '\n';; let send_int ob i = send_string ob (string_of_int i);; let rec reader = let count = ref 0 in (fun ib ob -> if Scanf.Scanning.beginning_of_input ib then begin count := 0; send_string ob "start"; writer ib ob end else Scanf.bscanf ib "%[^\n]\n" (function | "stop" -> send_string ob "stop"; writer ib ob | s -> let l = String.length s in count := l + !count; if !count >= 100 then begin send_string ob "stop"; send_int ob !count end else send_int ob l; writer ib ob)) and writer ib ob = Scanf.bscanf ib "%s\n" (function | "start" -> send_string ob "Hello World!"; reader ib ob | "stop" -> Scanf.bscanf ib "%i" (function i -> i) | s -> send_int ob (int_of_string s); reader ib ob);; let go () = let ob = Buffer.create 17 in let ib = Scanf.Scanning.from_function (next_char ob) in reader ib ob ;; let test50 () = go () = 100;; test (test50 ()) ;; (* Simple tests may also fail! Ensure this is not the case with the current version for module [Scanf]. *) let test51 () = sscanf "Hello" "%s" id = "Hello" && sscanf "Hello\n" "%s\n" id = "Hello" && sscanf "Hello\n" "%s%s\n" (fun s1 s2 -> s1 = "Hello" && s2 = "") && sscanf "Hello\nWorld" "%s\n%s%!" (fun s1 s2 -> s1 = "Hello" && s2 = "World") && sscanf "Hello\nWorld!" "%s\n%s" (fun s1 s2 -> s1 = "Hello" && s2 = "World!") && sscanf "Hello\n" "%s@\n%s" (fun s1 s2 -> s1 = "Hello" && s2 = "") && sscanf "Hello \n" "%s@\n%s" (fun s1 s2 -> s1 = "Hello " && s2 = "") ;; test (test51 ()) ;; (* Tests that indeed the [%s@c] format works properly. Also tests the difference between [\n] and [@\n] is correctly handled. In particular, tests that if no [c] character can be found in the input, then the token obtained for [%s@c] spreads to the end of input. *) let test52 () = sscanf "Hello\n" "%s@\n" id = "Hello" && sscanf "Hello" "%s@\n" id = "Hello" && sscanf "Hello" "%s%s@\n" (fun s1 s2 -> s1 = "Hello" && s2 = "") && sscanf "Hello\nWorld" "%s@\n%s%!" (fun s1 s2 -> s1 = "Hello" && s2 = "World") && sscanf "Hello\nWorld!" "%s@\n%s@\n" (fun s1 s2 -> s1 = "Hello" && s2 = "World!") && sscanf "Hello\n" "%s@\n%s" (fun s1 s2 -> s1 = "Hello" && s2 = "") && sscanf "Hello \n" "%s%s@\n" (fun s1 s2 -> s1 = "Hello" && s2 = " ") && sscanf "Hello \n" "%s%s%_1[ ]\n" (fun s1 s2 -> s1 = "Hello" && s2 = "") && sscanf "Hello \n" "%s%_1[ ]%s\n" (fun s1 s2 -> s1 = "Hello" && s2 = "") && sscanf "Hello\nWorld" "%s\n%s%!" (fun s1 s2 -> s1 = "Hello" && s2 = "World") && sscanf "Hello\nWorld!" "%s\n%s%!" (fun s1 s2 -> s1 = "Hello" && s2 = "World!") && sscanf "Hello\nWorld!" "%s\n%s@!%!" (fun s1 s2 -> s1 = "Hello" && s2 = "World") ;; test (test52 ()) ;; (* Reading native, int32 and int64 numbers. *) let test53 () = sscanf "123" "%nd" id = 123n && sscanf "124" "%nd" (fun i -> Nativeint.pred i = 123n) && sscanf "123" "%ld" id = 123l && sscanf "124" "%ld" (fun i -> Int32.succ i = 125l) && sscanf "123" "%Ld" id = 123L && sscanf "124" "%Ld" (fun i -> Int64.pred i = 123L) ;; test (test53 ()) ;; (* Routines to create the file that tscanf uses as a testbed case. *) let create_tscanf_data ob lines = let add_line (p, e) = Buffer.add_string ob (Printf.sprintf "%S" p); Buffer.add_string ob " -> "; Buffer.add_string ob (Printf.sprintf "%S" e); Buffer.add_string ob ";\n" in List.iter add_line lines ;; let write_tscanf_data_file fname lines = let oc = open_out fname in let ob = Buffer.create 42 in create_tscanf_data ob lines; Buffer.output_buffer oc ob; close_out oc ;; (* The tscanf testbed case file name. *) let tscanf_data_file = "tscanf_data";; (* The contents of the tscanf testbed case file. *) let tscanf_data_file_lines = [ "Objective", "Caml"; ] ;; (* We write the tscanf testbed case file. *) write_tscanf_data_file tscanf_data_file tscanf_data_file_lines ;; (* Then we verify that its contents is indeed correct: the lines written into the [tscanf_data] file should be the same as the lines read from it. *) (* Reading back tscanf_data_file_lines (hence, testing data file reading as well). *) let get_lines fname = let ib = Scanf.Scanning.from_file fname in let l = ref [] in try while not (Scanf.Scanning.end_of_input ib) do Scanf.bscanf ib " %S -> %S; " (fun x y -> l := (x, y) :: !l) done; List.rev !l with | Scanf.Scan_failure s -> failwith (Printf.sprintf "in file %s, %s" fname s) | End_of_file -> failwith (Printf.sprintf "in file %s, unexpected end of file" fname) ;; (* Simpy test that the list of lines read from the file are the list of lines written to it!. *) let test54 () = get_lines tscanf_data_file = tscanf_data_file_lines ;; test (test54 ()) ;; (* Creating digests for files. *) let add_digest_ib ob ib = let digest s = String.uppercase (Digest.to_hex (Digest.string s)) in let scan_line ib f = Scanf.bscanf ib "%[^\n\r]\n" f in let output_line_digest s = Buffer.add_string ob s; Buffer.add_char ob '#'; Buffer.add_string ob (digest s); Buffer.add_char ob '\n' in try while true do scan_line ib output_line_digest done; with | End_of_file -> () ;; let digest_file fname = let ib = Scanf.Scanning.from_file fname in let ob = Buffer.create 42 in add_digest_ib ob ib; Buffer.contents ob ;; let test55 () = let ob = Buffer.create 42 in let ib = create_tscanf_data ob tscanf_data_file_lines; let s = Buffer.contents ob in Buffer.clear ob; Scanning.from_string s in let tscanf_data_file_lines_digest = add_digest_ib ob ib; Buffer.contents ob in digest_file tscanf_data_file = tscanf_data_file_lines_digest ;; test (test55 ()) ;; (* Testing the number of characters read. *) let test56 () = let g s = Scanf.sscanf s "%d%n" (fun i n -> (i, n)) in g "99" = (99, 2) && g "99 syntaxes all in a row" = (99, 2) && g "-20 degrees Celsius" = (-20, 3) ;; test (test56 ()) ;; (* Testing the scanning of formats. *) let test57 () = (* Testing format_from_string. *) let test_format_scan s fmt efmt = format_from_string s fmt = efmt in (* Test if format %i is indeed read as %i. *) let s, fmt = " %i ", format_of_string "%i" in test_format_scan s fmt " %i " && (* Test if format %i is compatible with %d and indeed read as %i. *) let s, fmt = "%i", format_of_string "%d" in test_format_scan s fmt "%i" && let s, fmt = "Read an int %i then a string %s.", format_of_string "Spec%difi%scation" in test_format_scan s fmt "Read an int %i then a string %s." && let s, fmt = "Read an int %i then a string \"%s\".", format_of_string "Spec%difi%Scation" in test_format_scan s fmt "Read an int %i then a string \"%s\"." && let s, fmt = "Read an int %i then a string \"%s\".", format_of_string "Spec%difi%scation" in test_format_scan s fmt "Read an int %i then a string \"%s\"." && (* Complex test of scanning a meta format specified in the scanner input format string and extraction of its specification from a string. *) sscanf "12 \"%i\"89 " "%i %{%d%}%s %!" (fun i f s -> i = 12 && f = "%i" && s = "89") ;; test (test57 ()) ;; let test58 () = sscanf "string1%string2" "%s@%%s" id = "string1" && sscanf "string1%string2" "%s@%%%s" (^) = "string1string2" && sscanf "string1@string2" "%[a-z0-9]@%s" (^) = "string1string2" && sscanf "string1@%string2" "%[a-z0-9]%@%%%s" (^) = "string1string2" ;; test (test58 ()) ;; (* let test59 () = ;; test (test59 ()) ;; *) (* To be continued ... (* Trying to scan records. *) let rec scan_fields ib scan_field accu = kscanf ib (fun ib exc -> accu) scan_field (fun i -> let accu = i :: accu in kscanf ib (fun ib exc -> accu) " %1[;] " (fun s -> if s = "" then accu else scan_fields ib scan_field accu)) ;; let scan_record scan_field ib = bscanf ib "{ " (); let accu = scan_fields ib scan_field [] in bscanf ib " }" (); List.rev accu ;; let scan_field ib = bscanf ib "%s = %[^;]" (fun finame ficont -> finame, ficont);; *) mingw-ocaml/ocaml/testsuite/tests/lib-scanf/tscanf.reference0000644000175000017500000000027512124403241023651 0ustar tootstoots 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 All tests succeeded. mingw-ocaml/ocaml/testsuite/tests/prim-revapply/0000755000175000017500000000000012124403241021460 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/prim-revapply/apply.ml0000644000175000017500000000134412124403241023141 0ustar tootstootsexternal ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" let f x = x + x let g x = x * x let h x = x + 1 let add x y = x + y let _ = List.iter (fun x -> print_int x; print_newline () ) [ f @@ 3; (* 6 *) g @@ f @@ 3; (* 36 *) f @@ g @@ 3; (* 18 *) h @@ g @@ f @@ 3; (* 37 *) add 4 @@ g @@ f @@ add 3 @@ add 2 @@ 3; (* 260 *) ] external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" let f x = x + x let g x = x * x let h x = x + 1 let add x y = x + y let _ = List.iter (fun x -> print_int x; print_newline () ) [ f @@ 3; (* 6 *) g @@ f @@ 3; (* 36 *) f @@ g @@ 3; (* 18 *) h @@ g @@ f @@ 3; (* 37 *) add 4 @@ g @@ f @@ add 3 @@ add 2 @@ 3; (* 260 *) ] mingw-ocaml/ocaml/testsuite/tests/prim-revapply/revapply.reference0000644000175000017500000000001712124403241025200 0ustar tootstoots6 36 18 37 260 mingw-ocaml/ocaml/testsuite/tests/prim-revapply/Makefile0000644000175000017500000000015212124403241023116 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/prim-revapply/apply.reference0000644000175000017500000000003612124403241024464 0ustar tootstoots6 36 18 37 260 6 36 18 37 260 mingw-ocaml/ocaml/testsuite/tests/prim-revapply/revapply.ml0000644000175000017500000000056412124403241023661 0ustar tootstootsexternal ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" let f x = x + x let g x = x * x let h x = x + 1 let add x y = x + y let _ = List.iter (fun x -> print_int x; print_newline () ) [ 3 |> f; (* 6 *) 3 |> f |> g; (* 36 *) 3 |> g |> f; (* 18 *) 3 |> f |> g |> h; (* 37 *) 3 |> add 2 |> add 3 |> f |> g |> add 4; (* 260 *) ] mingw-ocaml/ocaml/testsuite/tests/lib-bigarray-2/0000755000175000017500000000000012124403241021354 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-bigarray-2/Makefile0000644000175000017500000000024612124403241023016 0ustar tootstootsBASEDIR=../.. LIBRARIES=unix bigarray C_FILES=bigarrfstub F_FILES=bigarrf include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-bigarray-2/bigarrfml.ml0000644000175000017500000000344612124403241023662 0ustar tootstootsopen Bigarray open Printf (* Test harness *) let error_occurred = ref false let function_tested = ref "" let testing_function s = function_tested := s; print_newline(); print_string s; print_newline() let test test_number answer correct_answer = flush stdout; flush stderr; if answer <> correct_answer then begin eprintf "*** Bad result (%s, test %d)\n" !function_tested test_number; flush stderr; error_occurred := true end else begin printf " %d..." test_number end (* External C and Fortran functions *) external c_filltab : unit -> (float, float64_elt, c_layout) Array2.t = "c_filltab" external c_printtab : (float, float64_elt, c_layout) Array2.t -> unit = "c_printtab" external fortran_filltab : unit -> (float, float32_elt, fortran_layout) Array2.t = "fortran_filltab" external fortran_printtab : (float, float32_elt, fortran_layout) Array2.t -> unit = "fortran_printtab" let _ = let make_array2 kind layout ind0 dim1 dim2 fromint = let a = Array2.create kind layout dim1 dim2 in for i = ind0 to dim1 - 1 + ind0 do for j = ind0 to dim2 - 1 + ind0 do a.{i,j} <- (fromint (i * 1000 + j)) done done; a in print_newline(); testing_function "------ Foreign function interface --------"; testing_function "Passing an array to C"; c_printtab (make_array2 float64 c_layout 0 6 8 float); testing_function "Accessing a C array"; let a = c_filltab () in test 1 a.{0,0} 0.0; test 2 a.{1,0} 100.0; test 3 a.{0,1} 1.0; test 4 a.{5,4} 504.0; testing_function "Passing an array to Fortran"; fortran_printtab (make_array2 float32 fortran_layout 1 5 4 float); testing_function "Accessing a Fortran array"; let a = fortran_filltab () in test 1 a.{1,1} 101.0; test 2 a.{2,1} 201.0; test 3 a.{1,2} 102.0; test 4 a.{5,4} 504.0; mingw-ocaml/ocaml/testsuite/tests/lib-bigarray-2/bigarrfml.reference0000644000175000017500000000136112124403241025202 0ustar tootstoots ------ Foreign function interface -------- Passing an array to C Accessing a C array 1... 2... 3... 4... Passing an array to Fortran 0 0.0 1.0 2.0 3.0 4.0 5.0 6.0 7.0 1 1000.0 1001.0 1002.0 1003.0 1004.0 1005.0 1006.0 1007.0 2 2000.0 2001.0 2002.0 2003.0 2004.0 2005.0 2006.0 2007.0 3 3000.0 3001.0 3002.0 3003.0 3004.0 3005.0 3006.0 3007.0 4 4000.0 4001.0 4002.0 4003.0 4004.0 4005.0 4006.0 4007.0 5 5000.0 5001.0 5002.0 5003.0 5004.0 5005.0 5006.0 5007.0 Accessing a Fortran array 1... 2... 3... 4... 1 1001.01002.01003.01004.0 2 2001.02002.02003.02004.0 3 3001.03002.03003.03004.0 4 4001.04002.04003.04004.0 5 5001.05002.05003.05004.0 mingw-ocaml/ocaml/testsuite/tests/lib-bigarray-2/bigarrfstub.c0000644000175000017500000000221412124403241024031 0ustar tootstoots#include #include #include extern void filltab_(void); extern void printtab_(float * data, int * dimx, int * dimy); extern float ftab_[]; #define DIMX 6 #define DIMY 8 double ctab[DIMX][DIMY]; void filltab(void) { int x, y; for (x = 0; x < DIMX; x++) for (y = 0; y < DIMY; y++) ctab[x][y] = x * 100 + y; } void printtab(double tab[DIMX][DIMY]) { int x, y; for (x = 0; x < DIMX; x++) { printf("%3d", x); for (y = 0; y < DIMY; y++) printf(" %6.1f", tab[x][y]); printf("\n"); } } value c_filltab(value unit) { filltab(); return alloc_bigarray_dims(BIGARRAY_FLOAT64 | BIGARRAY_C_LAYOUT, 2, ctab, DIMX, DIMY); } value c_printtab(value ba) { printtab(Data_bigarray_val(ba)); return Val_unit; } value fortran_filltab(value unit) { filltab_(); return alloc_bigarray_dims(BIGARRAY_FLOAT32 | BIGARRAY_FORTRAN_LAYOUT, 2, ftab_, 8, 6); } value fortran_printtab(value ba) { int dimx = Bigarray_val(ba)->dim[0]; int dimy = Bigarray_val(ba)->dim[1]; printtab_(Data_bigarray_val(ba), &dimx, &dimy); return Val_unit; } mingw-ocaml/ocaml/testsuite/tests/lib-bigarray-2/bigarrf.f0000644000175000017500000000071412124403241023141 0ustar tootstoots subroutine filltab() integer dimx, dimy parameter (dimx = 8, dimy = 6) real ftab(dimx, dimy) common /ftab/ ftab integer x, y do 100 x = 1, dimx do 110 y = 1, dimy ftab(x, y) = x * 100 + y 110 continue 100 continue end subroutine printtab(tab, dimx, dimy) integer dimx, dimy real tab(dimx, dimy) integer x, y do 200 x = 1, dimx print 300, x, (tab(x, y), y = 1, dimy) 300 format(/1X, I3, 2X, 10F6.1/) 200 continue end mingw-ocaml/ocaml/testsuite/tests/lib-scanf-2/0000755000175000017500000000000012124403241020646 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-scanf-2/tscanf2_slave.ml0000644000175000017500000000151012124403241023727 0ustar tootstoots(* A very simple slave: - read the string " Ping" on stdin, - then print the string "-pong" on stderr, - and send it back on stdout - until reading the string "stop" on stdin, - then print the string "!\n" on stderr, - send back the string "OK, bye!" on stdout, - and die. Use the communication module Test_scanf2_io. *) open Tscanf2_io;; let ib = Scanf.Scanning.from_channel stdin;; let ob = Buffer.create 1024 and oc = stdout;; let send_string_pong ob = send_string ob oc "-pong";; let send_string_okbye ob = send_string ob oc "OK, bye!";; while true do let s = receive_string ib in match s with | " Ping" -> Printf.eprintf "-pong"; flush stderr; send_string_pong ob | "stop" -> Printf.eprintf "!\n"; flush stderr; send_string_okbye ob; exit 0 | s -> failwith ("Slave: unbound string " ^ s) done ;; mingw-ocaml/ocaml/testsuite/tests/lib-scanf-2/Makefile0000644000175000017500000000165512124403241022315 0ustar tootstootsBASEDIR=../.. default: compile run compile: tscanf2_io.cmo @$(OCAMLC) unix.cma tscanf2_io.cmo -o master.byte tscanf2_master.ml @$(OCAMLC) tscanf2_io.cmo -o slave.byte tscanf2_slave.ml @if [ -z "$(BYTECODE_ONLY)" ]; then \ $(MAKE) tscanf2_io.cmx; \ $(OCAMLOPT) unix.cmxa tscanf2_io.cmx -o master.native tscanf2_master.ml; \ $(OCAMLOPT) tscanf2_io.cmx -o slave.native tscanf2_slave.ml; \ fi run: @printf " ... testing with ocamlc" @./master.byte ./slave.byte > result.byte 2>&1 @$(DIFF) reference result.byte > /dev/null || (echo " => failed" && exit 1) @if [ -z "$(BYTECODE_ONLY)" ]; then \ printf " ocamlopt" && \ ./master.native ./slave.native > result.native 2>&1 && \ $(DIFF) reference result.native > /dev/null || (echo " => failed" && exit 1) \ fi @echo " => passed" promote: @cp result.byte reference clean: defaultclean @rm -f master.* slave.* result.* include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-scanf-2/tscanf2_master.ml0000644000175000017500000000225312124403241024115 0ustar tootstoots(* A very simple master: - first launch a slave process, - then repeat a random number of times: + print the string " Ping" on stderr, + send it to the slave, + and wait for its answer "-pong", - finally send the string "stop" to the slave and wait for its answer "OK, bye!" and die. Use the communication module Tscanf2_io. Usage: test_master *) open Tscanf2_io;; let slave = Sys.argv.(1);; let ic, oc = Unix.open_process slave;; let ib = Scanf.Scanning.from_channel ic;; let ob = Buffer.create 1024;; let send_string_ping ob = send_string ob oc " Ping";; let send_string_stop ob = send_string ob oc "stop";; let interact i = Printf.eprintf " Ping"; flush stderr; send_string_ping ob; let s = receive_string ib in if s <> "-pong" then failwith ("Master: unbound string " ^ s) ;; begin (* Random.self_init (); let n = max (Random.int 8) 1 in *) let n = 8 in let rec loop i = if i > 0 then (interact i; loop (i - 1)) in loop n end ;; begin send_string_stop ob; let ack = receive_string ib in if ack = "OK, bye!" then (print_endline "Test OK."; exit 0) else (print_endline "Test Failed!"; exit 2) end ;; mingw-ocaml/ocaml/testsuite/tests/lib-scanf-2/tscanf2_io.ml0000644000175000017500000000126612124403241023234 0ustar tootstoots(* A very simple communication module using buffers. It should help detecting advanced character reading by Scanf when using stdin. *) let send_flush send ob oc t = send ob t; Buffer.output_buffer oc ob; Buffer.clear ob; flush oc ;; (* The correct sending format for the test should be "%S\n", but to avoid problems when Scanf ask too early for the next character, "%S\n\n" is fine. *) let send_string = send_flush (fun ob -> Printf.bprintf ob "%S\n");; (* The correct reading format for the test should be "%S\n", but to avoid problems when Scanf ask too early for the next character, " %S\n" is fine. *) let receive_string ib = Scanf.bscanf ib "%S\n" (fun s -> s);; mingw-ocaml/ocaml/testsuite/tests/lib-scanf-2/reference0000644000175000017500000000013312124403241022524 0ustar tootstoots Ping-pong Ping-pong Ping-pong Ping-pong Ping-pong Ping-pong Ping-pong Ping-pong! Test OK. mingw-ocaml/ocaml/testsuite/tests/typing-sigsubst/0000755000175000017500000000000012124403241022024 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-sigsubst/Makefile0000644000175000017500000000015212124403241023462 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-sigsubst/sigsubst.ml0000644000175000017500000000215612124403241024225 0ustar tootstootsmodule type Printable = sig type t val print : Format.formatter -> t -> unit end;; module type Comparable = sig type t val compare : t -> t -> int end;; module type PrintableComparable = sig include Printable include Comparable with type t = t end;; (* Fails *) module type PrintableComparable = sig type t include Printable with type t := t include Comparable with type t := t end;; module type PrintableComparable = sig include Printable include Comparable with type t := t end;; module type ComparableInt = Comparable with type t := int;; module type S = sig type t val f : t -> t end;; module type S' = S with type t := int;; module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end;; module type S1 = S with type 'a t := 'a list;; module type S2 = sig type 'a dict = (string * 'a) list include S with type 'a t := 'a dict end;; module type S = sig module T : sig type exp type arg end val f : T.exp -> T.arg end;; module M = struct type exp = string type arg = int end;; module type S' = S with module T := M;; module type S = sig type 'a t end with type 'a t := unit;; (* Fails *) mingw-ocaml/ocaml/testsuite/tests/typing-sigsubst/sigsubst.ml.reference0000644000175000017500000000277612124403241026172 0ustar tootstoots # module type Printable = sig type t val print : Format.formatter -> t -> unit end # module type Comparable = sig type t val compare : t -> t -> int end # Characters 60-94: include Comparable with type t = t ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Multiple definition of the type name t. Names must be unique in a given structure or signature. # module type PrintableComparable = sig type t val print : Format.formatter -> t -> unit val compare : t -> t -> int end # module type PrintableComparable = sig type t val print : Format.formatter -> t -> unit val compare : t -> t -> int end # module type ComparableInt = sig val compare : int -> int -> int end # module type S = sig type t val f : t -> t end # module type S' = sig val f : int -> int end # module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end # module type S1 = sig val map : ('a -> 'b) -> 'a list -> 'b list end # module type S2 = sig type 'a dict = (string * 'a) list val map : ('a -> 'b) -> 'a dict -> 'b dict end # module type S = sig module T : sig type exp type arg end val f : T.exp -> T.arg end # module M : sig type exp = string type arg = int end # module type S' = sig val f : M.exp -> M.arg end # Characters 41-58: module type S = sig type 'a t end with type 'a t := unit;; (* Fails *) ^^^^^^^^^^^^^^^^^ Error: Only type constructors with identical parameters can be substituted. # mingw-ocaml/ocaml/testsuite/tests/lib-bigarray/0000755000175000017500000000000012124403241021215 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-bigarray/bigarrays.reference0000644000175000017500000000277612124403241025074 0ustar tootstoots ------ Array1 -------- create/set/get 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... set/get (specialized) 1... 2... 3... 4... 5... 6... 7... 8... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... set/get (unsafe, specialized) 1... 2... 3... 6... 7... 8... comparisons 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... 23... 24... 25... 26... 27... 28... 29... 30... 31... 32... 44... 45... 46... 47... 48... 49... dim 1... 2... kind & layout 1... 2... 1... 2... sub 1... 2... 3... 4... 5... 6... 7... 8... 9... blit, fill 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... ------ Array2 -------- create/set/get 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... set/get (specialized) 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... set/get (unsafe, specialized) 1... 2... dim 1... 2... 3... 4... sub 1... 2... slice 1... 2... 3... 4... 5... 6... 7... 8... ------ Array3 -------- create/set/get 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... set/get (specialized) 1... 2... set/get (unsafe, specialized) 1... dim 1... 2... 3... 4... 5... 6... slice1 1... 2... 3... 4... 5... 6... 7... ------ Reshaping -------- reshape_1 1... 2... reshape_2 1... 2... 3... 4... 5... 6... 7... ------ I/O -------- output_value/input_value 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... map_file 1... 2... 3... 4... mingw-ocaml/ocaml/testsuite/tests/lib-bigarray/Makefile0000644000175000017500000000020212124403241022647 0ustar tootstootsBASEDIR=../.. LIBRARIES=unix bigarray include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-bigarray/pr5115.reference0000644000175000017500000000002612124403241024030 0ustar tootstoots***EXEC*** ***EXEC*** mingw-ocaml/ocaml/testsuite/tests/lib-bigarray/fftba.reference0000644000175000017500000000021112124403241024151 0ustar tootstoots16... ok 32... ok 64... ok 128... ok 256... ok 512... ok 1024... ok 2048... ok 4096... ok 8192... ok 16384... ok 32768... ok 65536... ok mingw-ocaml/ocaml/testsuite/tests/lib-bigarray/fftba.ml0000644000175000017500000001200512124403241022627 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Bigarray let pi = 3.14159265358979323846 let tpi = 2.0 *. pi let fft (px : (float, float64_elt, c_layout) Array1.t) (py : (float, float64_elt, c_layout) Array1.t) np = let i = ref 2 in let m = ref 1 in while (!i < np) do i := !i + !i; m := !m + 1 done; let n = !i in if n <> np then begin for i = np+1 to n do px.{i} <- 0.0; py.{i} <- 0.0 done; print_string "Use "; print_int n; print_string " point fft"; print_newline() end; let n2 = ref(n+n) in for k = 1 to !m-1 do n2 := !n2 / 2; let n4 = !n2 / 4 in let e = tpi /. float !n2 in for j = 1 to n4 do let a = e *. float(j - 1) in let a3 = 3.0 *. a in let cc1 = cos(a) in let ss1 = sin(a) in let cc3 = cos(a3) in let ss3 = sin(a3) in let is = ref j in let id = ref(2 * !n2) in while !is < n do let i0r = ref !is in while !i0r < n do let i0 = !i0r in let i1 = i0 + n4 in let i2 = i1 + n4 in let i3 = i2 + n4 in let r1 = px.{i0} -. px.{i2} in px.{i0} <- px.{i0} +. px.{i2}; let r2 = px.{i1} -. px.{i3} in px.{i1} <- px.{i1} +. px.{i3}; let s1 = py.{i0} -. py.{i2} in py.{i0} <- py.{i0} +. py.{i2}; let s2 = py.{i1} -. py.{i3} in py.{i1} <- py.{i1} +. py.{i3}; let s3 = r1 -. s2 in let r1 = r1 +. s2 in let s2 = r2 -. s1 in let r2 = r2 +. s1 in px.{i2} <- r1*.cc1 -. s2*.ss1; py.{i2} <- -.s2*.cc1 -. r1*.ss1; px.{i3} <- s3*.cc3 +. r2*.ss3; py.{i3} <- r2*.cc3 -. s3*.ss3; i0r := i0 + !id done; is := 2 * !id - !n2 + j; id := 4 * !id done done done; (************************************) (* Last stage, length=2 butterfly *) (************************************) let is = ref 1 in let id = ref 4 in while !is < n do let i0r = ref !is in while !i0r <= n do let i0 = !i0r in let i1 = i0 + 1 in let r1 = px.{i0} in px.{i0} <- r1 +. px.{i1}; px.{i1} <- r1 -. px.{i1}; let r1 = py.{i0} in py.{i0} <- r1 +. py.{i1}; py.{i1} <- r1 -. py.{i1}; i0r := i0 + !id done; is := 2 * !id - 1; id := 4 * !id done; (*************************) (* Bit reverse counter *) (*************************) let j = ref 1 in for i = 1 to n - 1 do if i < !j then begin let xt = px.{!j} in px.{!j} <- px.{i}; px.{i} <- xt; let xt = py.{!j} in py.{!j} <- py.{i}; py.{i} <- xt end; let k = ref(n / 2) in while !k < !j do j := !j - !k; k := !k / 2 done; j := !j + !k done; n let test np = print_int np; print_string "... "; flush stdout; let enp = float np in let npm = np / 2 - 1 in let pxr = Array1.create float64 c_layout (np+2) and pxi = Array1.create float64 c_layout (np+2) in let t = pi /. enp in pxr.{1} <- (enp -. 1.0) *. 0.5; pxi.{1} <- 0.0; let n2 = np / 2 in pxr.{n2+1} <- -0.5; pxi.{n2+1} <- 0.0; for i = 1 to npm do let j = np - i in pxr.{i+1} <- -0.5; pxr.{j+1} <- -0.5; let z = t *. float i in let y = -0.5 *. (cos(z)/.sin(z)) in pxi.{i+1} <- y; pxi.{j+1} <- -.y done; (** print_newline(); for i=0 to 15 do Printf.printf "%d %f %f\n" i pxr.{i+1} pxi.{i+1} done; **) let _ = fft pxr pxi np in (** for i=0 to 15 do Printf.printf "%d %f %f\n" i pxr.{i+1} pxi.{i+1} done; **) let zr = ref 0.0 in let zi = ref 0.0 in let kr = ref 0 in let ki = ref 0 in for i = 0 to np-1 do let a = abs_float(pxr.{i+1} -. float i) in if !zr < a then begin zr := a; kr := i end; let a = abs_float(pxi.{i+1}) in if !zi < a then begin zi := a; ki := i end done; (* let zm = if abs_float !zr < abs_float !zi then !zi else !zr in print_float zm; print_newline() *) if abs_float !zr <= 1e-9 && abs_float !zi <= 1e-9 then print_string "ok" else print_string "ERROR"; print_newline() let _ = let np = ref 16 in for i = 1 to 13 do test !np; np := !np*2 done mingw-ocaml/ocaml/testsuite/tests/lib-bigarray/pr5115.ml0000644000175000017500000000033612124403241022506 0ustar tootstoots(* PR#5115 - multiple evaluation of bigarray expr *) open Bigarray let f y0 = Printf.printf "***EXEC***\n%!"; y0 let _ = let y = Array1.of_array float64 fortran_layout [| 1. |] in (f y).{1}; (f y).{1} <- 3.14 mingw-ocaml/ocaml/testsuite/tests/lib-bigarray/bigarrays.ml0000644000175000017500000007421412124403241023542 0ustar tootstootsopen Bigarray open Printf open Complex (* Test harness *) let error_occurred = ref false let function_tested = ref "" let testing_function s = function_tested := s; print_newline(); print_string s; print_newline() let test test_number answer correct_answer = flush stdout; flush stderr; if answer <> correct_answer then begin eprintf "*** Bad result (%s, test %d)\n" !function_tested test_number; flush stderr; error_occurred := true end else begin printf " %d..." test_number end (* One-dimensional arrays *) let _ = testing_function "------ Array1 --------"; testing_function "create/set/get"; let test_setget kind vals = let rec set a i = function [] -> () | (v1, v2) :: tl -> a.{i} <- v1; set a (i+1) tl in let rec test a i = function [] -> true | (v1, v2) :: tl -> a.{i} = v2 && test a (i+1) tl in let ca = Array1.create kind c_layout (List.length vals) in let fa = Array1.create kind fortran_layout (List.length vals) in set ca 0 vals; set fa 1 vals; test ca 0 vals && test fa 1 vals in test 1 true (test_setget int8_signed [0, 0; 123, 123; -123, -123; 456, -56; 0x101, 1]); test 2 true (test_setget int8_unsigned [0, 0; 123, 123; -123, 133; 456, 0xc8; 0x101, 1]); test 3 true (test_setget int16_signed [0, 0; 123, 123; -123, -123; 31456, 31456; -31456, -31456; 65432, -104; 0x10001, 1]); test 4 true (test_setget int16_unsigned [0, 0; 123, 123; -123, 65413; 31456, 31456; -31456, 34080; 65432, 65432; 0x10001, 1]); test 5 true (test_setget int [0, 0; 123, 123; -456, -456; max_int, max_int; min_int, min_int; 0x12345678, 0x12345678; -0x12345678, -0x12345678]); test 6 true (test_setget int32 [Int32.zero, Int32.zero; Int32.of_int 123, Int32.of_int 123; Int32.of_int (-456), Int32.of_int (-456); Int32.max_int, Int32.max_int; Int32.min_int, Int32.min_int; Int32.of_string "0x12345678", Int32.of_string "0x12345678"]); test 7 true (test_setget int64 [Int64.zero, Int64.zero; Int64.of_int 123, Int64.of_int 123; Int64.of_int (-456), Int64.of_int (-456); Int64.max_int, Int64.max_int; Int64.min_int, Int64.min_int; Int64.of_string "0x123456789ABCDEF0", Int64.of_string "0x123456789ABCDEF0"]); test 8 true (test_setget nativeint [Nativeint.zero, Nativeint.zero; Nativeint.of_int 123, Nativeint.of_int 123; Nativeint.of_int (-456), Nativeint.of_int (-456); Nativeint.max_int, Nativeint.max_int; Nativeint.min_int, Nativeint.min_int; Nativeint.of_string "0x12345678", Nativeint.of_string "0x12345678"]); test 9 true (test_setget float32 [0.0, 0.0; 4.0, 4.0; -0.5, -0.5; 655360.0, 655360.0]); test 10 true (test_setget float64 [0.0, 0.0; 4.0, 4.0; -0.5, -0.5; 1.2345678, 1.2345678; 3.1415e10, 3.1415e10]); test 11 true (test_setget complex32 [Complex.zero, Complex.zero; Complex.one, Complex.one; Complex.i, Complex.i; {im = 0.5; re = -2.0}, {im = 0.5; re = -2.0}]); test 12 true (test_setget complex64 [Complex.zero, Complex.zero; Complex.one, Complex.one; Complex.i, Complex.i; {im=0.5;re= -2.0}, {im=0.5;re= -2.0}; {im=3.1415;re=1.2345678}, {im=3.1415;re=1.2345678}]); let from_list kind vals = let a = Array1.create kind c_layout (List.length vals) in let rec set i = function [] -> () | hd :: tl -> a.{i} <- hd; set (i+1) tl in set 0 vals; a in let from_list_fortran kind vals = let a = Array1.create kind fortran_layout (List.length vals) in let rec set i = function [] -> () | hd :: tl -> a.{i} <- hd; set (i+1) tl in set 1 vals; a in testing_function "set/get (specialized)"; let a = Array1.create int c_layout 3 in for i = 0 to 2 do a.{i} <- i done; for i = 0 to 2 do test (i+1) a.{i} i done; test 4 true (try ignore a.{3}; false with Invalid_argument _ -> true); test 5 true (try ignore a.{-1}; false with Invalid_argument _ -> true); let b = Array1.create float64 fortran_layout 3 in for i = 1 to 3 do b.{i} <- float i done; for i = 1 to 3 do test (5 + i) b.{i} (float i) done; test 8 true (try ignore b.{4}; false with Invalid_argument _ -> true); test 9 true (try ignore b.{0}; false with Invalid_argument _ -> true); let c = Array1.create complex64 c_layout 3 in for i = 0 to 2 do c.{i} <- {re=float i; im=0.0} done; for i = 0 to 2 do test (10 + i) c.{i} {re=float i; im=0.0} done; test 13 true (try ignore c.{3}; false with Invalid_argument _ -> true); test 14 true (try ignore c.{-1}; false with Invalid_argument _ -> true); let d = Array1.create complex32 fortran_layout 3 in for i = 1 to 3 do d.{i} <- {re=float i; im=0.0} done; for i = 1 to 3 do test (14 + i) d.{i} {re=float i; im=0.0} done; test 18 true (try ignore d.{4}; false with Invalid_argument _ -> true); test 19 true (try ignore d.{0}; false with Invalid_argument _ -> true); testing_function "set/get (unsafe, specialized)"; let a = Array1.create int c_layout 3 in for i = 0 to 2 do Array1.unsafe_set a i i done; for i = 0 to 2 do test (i+1) (Array1.unsafe_get a i) i done; let b = Array1.create float64 fortran_layout 3 in for i = 1 to 3 do Array1.unsafe_set b i (float i) done; for i = 1 to 3 do test (5 + i) (Array1.unsafe_get b i) (float i) done; testing_function "comparisons"; let normalize_comparison n = if n = 0 then 0 else if n < 0 then -1 else 1 in test 1 0 (normalize_comparison (compare (from_list int8_signed [1;2;3;-4;127;-128]) (from_list int8_signed [1;2;3;-4;127;-128]))); test 2 (-1) (normalize_comparison (compare (from_list int8_signed [1;2;3;-4;127;-128]) (from_list int8_signed [1;2;3;4;127;-128]))); test 3 1 (normalize_comparison (compare (from_list int8_signed [1;2;3;-4;127;-128]) (from_list int8_signed [1;2;3;-4;42;-128]))); test 4 (-1) (normalize_comparison (compare (from_list int8_signed [1;2;3;-4]) (from_list int8_signed [1;2;3;4;127;-128]))); test 5 1 (normalize_comparison (compare (from_list int8_signed [1;2;3;4;127;-128]) (from_list int8_signed [1;2;3;-4]))); test 6 0 (normalize_comparison (compare (from_list int8_unsigned [1;2;3;-4;127;-128]) (from_list int8_unsigned [1;2;3;-4;127;-128]))); test 7 1 (normalize_comparison (compare (from_list int8_unsigned [1;2;3;-4;127;-128]) (from_list int8_unsigned [1;2;3;4;127;-128]))); test 8 1 (normalize_comparison (compare (from_list int8_unsigned [1;2;3;-4;127;-128]) (from_list int8_unsigned [1;2;3;-4;42;-128]))); test 9 0 (normalize_comparison (compare (from_list int16_signed [1;2;3;-4;127;-128]) (from_list int16_signed [1;2;3;-4;127;-128]))); test 10 (-1) (normalize_comparison (compare (from_list int16_signed [1;2;3;-4;127;-128]) (from_list int16_signed [1;2;3;4;127;-128]))); test 11 1 (normalize_comparison (compare (from_list int16_signed [1;2;3;-4;127;-128]) (from_list int16_signed [1;2;3;-4;42;-128]))); test 12 0 (normalize_comparison (compare (from_list int16_unsigned [1;2;3;-4;127;-128]) (from_list int16_unsigned [1;2;3;-4;127;-128]))); test 13 (-1) (normalize_comparison (compare (from_list int16_unsigned [1;2;3;4;127;-128]) (from_list int16_unsigned [1;2;3;0xFFFF;127;-128]))); test 14 1 (normalize_comparison (compare (from_list int16_unsigned [1;2;3;-4;127;-128]) (from_list int16_unsigned [1;2;3;-4;42;-128]))); test 15 0 (normalize_comparison (compare (from_list int [1;2;3;-4;127;-128]) (from_list int [1;2;3;-4;127;-128]))); test 16 (-1) (normalize_comparison (compare (from_list int [1;2;3;-4;127;-128]) (from_list int [1;2;3;4;127;-128]))); test 17 1 (normalize_comparison (compare (from_list int [1;2;3;-4;127;-128]) (from_list int [1;2;3;-4;42;-128]))); test 18 0 (normalize_comparison (compare (from_list int32 (List.map Int32.of_int [1;2;3;-4;127;-128])) (from_list int32 (List.map Int32.of_int [1;2;3;-4;127;-128])))); test 19 (-1) (normalize_comparison (compare (from_list int32 (List.map Int32.of_int [1;2;3;-4;127;-128])) (from_list int32 (List.map Int32.of_int [1;2;3;4;127;-128])))); test 20 1 (normalize_comparison (compare (from_list int32 (List.map Int32.of_int [1;2;3;-4;127;-128])) (from_list int32 (List.map Int32.of_int [1;2;3;-4;42;-128])))); test 21 0 (normalize_comparison (compare (from_list int64 (List.map Int64.of_int [1;2;3;-4;127;-128])) (from_list int64 (List.map Int64.of_int [1;2;3;-4;127;-128])))); test 22 (-1) (normalize_comparison (compare (from_list int64 (List.map Int64.of_int [1;2;3;-4;127;-128])) (from_list int64 (List.map Int64.of_int [1;2;3;4;127;-128])))); test 23 1 (normalize_comparison (compare (from_list int64 (List.map Int64.of_int [1;2;3;-4;127;-128])) (from_list int64 (List.map Int64.of_int [1;2;3;-4;42;-128])))); test 24 0 (normalize_comparison (compare (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;127;-128])) (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;127;-128])))); test 25 (-1) (normalize_comparison (compare (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;127;-128])) (from_list nativeint (List.map Nativeint.of_int [1;2;3;4;127;-128])))); test 26 1 (normalize_comparison (compare (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;127;-128])) (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;42;-128])))); test 27 0 (normalize_comparison (compare (from_list float32 [0.0; 0.25; -4.0; 3.141592654]) (from_list float32 [0.0; 0.25; -4.0; 3.141592654]))); test 28 (-1) (normalize_comparison (compare (from_list float32 [0.0; 0.25; -4.0]) (from_list float32 [0.0; 0.25; 3.14159]))); test 29 1 (normalize_comparison (compare (from_list float32 [0.0; 2.718; -4.0]) (from_list float32 [0.0; 0.25; 3.14159]))); test 30 0 (normalize_comparison (compare (from_list float64 [0.0; 0.25; -4.0; 3.141592654]) (from_list float64 [0.0; 0.25; -4.0; 3.141592654]))); test 31 (-1) (normalize_comparison (compare (from_list float64 [0.0; 0.25; -4.0]) (from_list float64 [0.0; 0.25; 3.14159]))); test 32 1 (normalize_comparison (compare (from_list float64 [0.0; 2.718; -4.0]) (from_list float64 [0.0; 0.25; 3.14159]))); test 44 0 (normalize_comparison (compare (from_list complex32 [Complex.zero; Complex.one; Complex.i]) (from_list complex32 [Complex.zero; Complex.one; Complex.i]))); test 45 (-1) (normalize_comparison (compare (from_list complex32 [Complex.zero; Complex.one; Complex.i]) (from_list complex32 [Complex.zero; Complex.one; Complex.one]))); test 46 1 (normalize_comparison (compare (from_list complex32 [Complex.zero; Complex.one; Complex.one]) (from_list complex32 [Complex.zero; Complex.one; Complex.i]))); test 47 0 (normalize_comparison (compare (from_list complex64 [Complex.zero; Complex.one; Complex.i]) (from_list complex64 [Complex.zero; Complex.one; Complex.i]))); test 48 (-1) (normalize_comparison (compare (from_list complex64 [Complex.zero; Complex.one; Complex.i]) (from_list complex64 [Complex.zero; Complex.one; Complex.one]))); test 49 1 (normalize_comparison (compare (from_list complex64 [Complex.zero; Complex.one; Complex.one]) (from_list complex64 [Complex.zero; Complex.one; Complex.i]))); testing_function "dim"; test 1 (Array1.dim (from_list int [1;2;3;4;5])) 5; test 2 (Array1.dim (from_list_fortran int [1;2;3])) 3; testing_function "kind & layout"; let a = from_list int [1;2;3] in test 1 (Array1.kind a) int; test 2 (Array1.layout a) c_layout; let a = from_list_fortran float32 [1.0;2.0;3.0] in test 1 (Array1.kind a) float32; test 2 (Array1.layout a) fortran_layout; testing_function "sub"; let a = from_list int [1;2;3;4;5;6;7;8] in test 1 (Array1.sub a 2 5) (from_list int [3;4;5;6;7]); test 2 (Array1.sub a 0 2) (from_list int [1;2]); test 3 (Array1.sub a 0 8) (from_list int [1;2;3;4;5;6;7;8]); let a = from_list float64 [1.0;2.0;3.0;4.0;5.0;6.0;7.0;8.0] in test 4 (Array1.sub a 2 5) (from_list float64 [3.0;4.0;5.0;6.0;7.0]); test 5 (Array1.sub a 0 2) (from_list float64 [1.0;2.0]); test 6 (Array1.sub a 0 8) (from_list float64 [1.0;2.0;3.0;4.0;5.0;6.0;7.0;8.0]); let a = from_list_fortran float64 [1.0;2.0;3.0;4.0;5.0;6.0;7.0;8.0] in test 7 (Array1.sub a 2 5) (from_list_fortran float64 [2.0;3.0;4.0;5.0;6.0]); test 8 (Array1.sub a 1 2) (from_list_fortran float64 [1.0;2.0]); test 9 (Array1.sub a 1 8) (from_list_fortran float64 [1.0;2.0;3.0;4.0;5.0;6.0;7.0;8.0]); Gc.full_major(); (* test GC of proxies *) testing_function "blit, fill"; let test_blit_fill kind data initval ofs len = let a = from_list kind data in let b = Array1.create kind c_layout (List.length data) in Array1.blit a b; (a = b) && (Array1.fill (Array1.sub b ofs len) initval; let rec check i = function [] -> true | hd :: tl -> b.{i} = (if i >= ofs && i < ofs + len then initval else hd) && check (i+1) tl in check 0 data) in test 1 true (test_blit_fill int8_signed [1;2;5;8;-100;127] 7 3 2); test 2 true (test_blit_fill int8_unsigned [1;2;5;8;-100;212] 7 3 2); test 3 true (test_blit_fill int16_signed [1;2;5;8;-100;212] 7 3 2); test 4 true (test_blit_fill int16_unsigned [1;2;5;8;-100;212] 7 3 2); test 5 true (test_blit_fill int [1;2;5;8;-100;212] 7 3 2); test 6 true (test_blit_fill int32 (List.map Int32.of_int [1;2;5;8;-100;212]) (Int32.of_int 7) 3 2); test 7 true (test_blit_fill int64 (List.map Int64.of_int [1;2;5;8;-100;212]) (Int64.of_int 7) 3 2); test 8 true (test_blit_fill nativeint (List.map Nativeint.of_int [1;2;5;8;-100;212]) (Nativeint.of_int 7) 3 2); test 9 true (test_blit_fill float32 [1.0;2.0;0.5;0.125;256.0;512.0] 0.25 3 2); test 10 true (test_blit_fill float64 [1.0;2.0;5.0;8.123;-100.456;212e19] 3.1415 3 2); test 11 true (test_blit_fill complex32 [Complex.zero; Complex.one; Complex.i] Complex.i 1 1); test 12 true (test_blit_fill complex64 [Complex.zero; Complex.one; Complex.i] Complex.i 1 1); (* Bi-dimensional arrays *) print_newline(); testing_function "------ Array2 --------"; testing_function "create/set/get"; let make_array2 kind layout ind0 dim1 dim2 fromint = let a = Array2.create kind layout dim1 dim2 in for i = ind0 to dim1 - 1 + ind0 do for j = ind0 to dim2 - 1 + ind0 do a.{i,j} <- (fromint (i * 1000 + j)) done done; a in let check_array2 a ind0 dim1 dim2 fromint = try for i = ind0 to dim1 - 1 + ind0 do for j = ind0 to dim2 - 1 + ind0 do if a.{i,j} <> (fromint (i * 1000 + j)) then raise Exit done done; true with Exit -> false in let id x = x in test 1 true (check_array2 (make_array2 int16_signed c_layout 0 10 20 id) 0 10 20 id); test 2 true (check_array2 (make_array2 int c_layout 0 10 20 id) 0 10 20 id); test 3 true (check_array2 (make_array2 int32 c_layout 0 10 20 Int32.of_int) 0 10 20 Int32.of_int); test 4 true (check_array2 (make_array2 float32 c_layout 0 10 20 float) 0 10 20 float); test 5 true (check_array2 (make_array2 float64 c_layout 0 10 20 float) 0 10 20 float); test 6 true (check_array2 (make_array2 int16_signed fortran_layout 1 10 20 id) 1 10 20 id); test 7 true (check_array2 (make_array2 int fortran_layout 1 10 20 id) 1 10 20 id); test 8 true (check_array2 (make_array2 int32 fortran_layout 1 10 20 Int32.of_int) 1 10 20 Int32.of_int); test 9 true (check_array2 (make_array2 float32 fortran_layout 1 10 20 float) 1 10 20 float); test 10 true (check_array2 (make_array2 float64 fortran_layout 1 10 20 float) 1 10 20 float); let makecomplex i = {re = float i; im = float (-i)} in test 11 true (check_array2 (make_array2 complex32 c_layout 0 10 20 makecomplex) 0 10 20 makecomplex); test 12 true (check_array2 (make_array2 complex64 c_layout 0 10 20 makecomplex) 0 10 20 makecomplex); test 13 true (check_array2 (make_array2 complex32 fortran_layout 1 10 20 makecomplex) 1 10 20 makecomplex); test 14 true (check_array2 (make_array2 complex64 fortran_layout 1 10 20 makecomplex) 1 10 20 makecomplex); testing_function "set/get (specialized)"; let a = Array2.create int16_signed c_layout 3 3 in for i = 0 to 2 do for j = 0 to 2 do a.{i,j} <- i-j done done; let ok = ref true in for i = 0 to 2 do for j = 0 to 2 do if a.{i,j} <> i-j then ok := false done done; test 1 true !ok; test 2 true (try ignore a.{3,0}; false with Invalid_argument _ -> true); test 3 true (try ignore a.{-1,0}; false with Invalid_argument _ -> true); test 4 true (try ignore a.{0,3}; false with Invalid_argument _ -> true); test 5 true (try ignore a.{0,-1}; false with Invalid_argument _ -> true); let b = Array2.create float32 fortran_layout 3 3 in for i = 1 to 3 do for j = 1 to 3 do b.{i,j} <- float(i-j) done done; let ok = ref true in for i = 1 to 3 do for j = 1 to 3 do if b.{i,j} <> float(i-j) then ok := false done done; test 6 true !ok; test 7 true (try ignore b.{4,1}; false with Invalid_argument _ -> true); test 8 true (try ignore b.{0,1}; false with Invalid_argument _ -> true); test 9 true (try ignore b.{1,4}; false with Invalid_argument _ -> true); test 10 true (try ignore b.{1,0}; false with Invalid_argument _ -> true); testing_function "set/get (unsafe, specialized)"; let a = Array2.create int16_signed c_layout 3 3 in for i = 0 to 2 do for j = 0 to 2 do Array2.unsafe_set a i j (i-j) done done; let ok = ref true in for i = 0 to 2 do for j = 0 to 2 do if Array2.unsafe_get a i j <> i-j then ok := false done done; test 1 true !ok; let b = Array2.create float32 fortran_layout 3 3 in for i = 1 to 3 do for j = 1 to 3 do Array2.unsafe_set b i j (float(i-j)) done done; let ok = ref true in for i = 1 to 3 do for j = 1 to 3 do if Array2.unsafe_get b i j <> float(i-j) then ok := false done done; test 2 true !ok; testing_function "dim"; let a = (make_array2 int c_layout 0 4 6 id) in test 1 (Array2.dim1 a) 4; test 2 (Array2.dim2 a) 6; let b = (make_array2 int fortran_layout 1 4 6 id) in test 3 (Array2.dim1 b) 4; test 4 (Array2.dim2 b) 6; testing_function "sub"; let a = make_array2 int c_layout 0 5 3 id in let b = Array2.sub_left a 2 2 in test 1 true (b.{0,0} = 2000 && b.{0,1} = 2001 && b.{0,2} = 2002 && b.{1,0} = 3000 && b.{1,1} = 3001 && b.{1,2} = 3002); let a = make_array2 int fortran_layout 1 5 3 id in let b = Array2.sub_right a 2 2 in test 2 true (b.{1,1} = 1002 && b.{1,2} = 1003 && b.{2,1} = 2002 && b.{2,2} = 2003 && b.{3,1} = 3002 && b.{3,2} = 3003 && b.{4,1} = 4002 && b.{4,2} = 4003 && b.{5,1} = 5002 && b.{5,2} = 5003); testing_function "slice"; let a = make_array2 int c_layout 0 5 3 id in test 1 (Array2.slice_left a 0) (from_list int [0;1;2]); test 2 (Array2.slice_left a 1) (from_list int [1000;1001;1002]); test 3 (Array2.slice_left a 2) (from_list int [2000;2001;2002]); test 4 (Array2.slice_left a 3) (from_list int [3000;3001;3002]); test 5 (Array2.slice_left a 4) (from_list int [4000;4001;4002]); let a = make_array2 int fortran_layout 1 5 3 id in test 6 (Array2.slice_right a 1) (from_list_fortran int [1001;2001;3001;4001;5001]); test 7 (Array2.slice_right a 2) (from_list_fortran int [1002;2002;3002;4002;5002]); test 8 (Array2.slice_right a 3) (from_list_fortran int [1003;2003;3003;4003;5003]); (* Tri-dimensional arrays *) print_newline(); testing_function "------ Array3 --------"; testing_function "create/set/get"; let make_array3 kind layout ind0 dim1 dim2 dim3 fromint = let a = Array3.create kind layout dim1 dim2 dim3 in for i = ind0 to dim1 - 1 + ind0 do for j = ind0 to dim2 - 1 + ind0 do for k = ind0 to dim3 - 1 + ind0 do a.{i, j, k} <- (fromint (i * 100 + j * 10 + k)) done done done; a in let check_array3 a ind0 dim1 dim2 dim3 fromint = try for i = ind0 to dim1 - 1 + ind0 do for j = ind0 to dim2 - 1 + ind0 do for k = ind0 to dim3 - 1 + ind0 do if a.{i, j, k} <> (fromint (i * 100 + j * 10 + k)) then raise Exit done done done; true with Exit -> false in let id x = x in test 1 true (check_array3 (make_array3 int16_signed c_layout 0 4 5 6 id) 0 4 5 6 id); test 2 true (check_array3 (make_array3 int c_layout 0 4 5 6 id) 0 4 5 6 id); test 3 true (check_array3 (make_array3 int32 c_layout 0 4 5 6 Int32.of_int) 0 4 5 6 Int32.of_int); test 4 true (check_array3 (make_array3 float32 c_layout 0 4 5 6 float) 0 4 5 6 float); test 5 true (check_array3 (make_array3 float64 c_layout 0 4 5 6 float) 0 4 5 6 float); test 6 true (check_array3 (make_array3 int16_signed fortran_layout 1 4 5 6 id) 1 4 5 6 id); test 7 true (check_array3 (make_array3 int fortran_layout 1 4 5 6 id) 1 4 5 6 id); test 8 true (check_array3 (make_array3 int32 fortran_layout 1 4 5 6 Int32.of_int) 1 4 5 6 Int32.of_int); test 9 true (check_array3 (make_array3 float32 fortran_layout 1 4 5 6 float) 1 4 5 6 float); test 10 true (check_array3 (make_array3 float64 fortran_layout 1 4 5 6 float) 1 4 5 6 float); test 11 true (check_array3 (make_array3 complex32 c_layout 0 4 5 6 makecomplex) 0 4 5 6 makecomplex); test 12 true (check_array3 (make_array3 complex64 c_layout 0 4 5 6 makecomplex) 0 4 5 6 makecomplex); test 13 true (check_array3 (make_array3 complex32 fortran_layout 1 4 5 6 makecomplex) 1 4 5 6 makecomplex); test 14 true (check_array3 (make_array3 complex64 fortran_layout 1 4 5 6 makecomplex) 1 4 5 6 makecomplex); testing_function "set/get (specialized)"; let a = Array3.create int32 c_layout 2 3 4 in for i = 0 to 1 do for j = 0 to 2 do for k = 0 to 3 do a.{i,j,k} <- Int32.of_int((i lsl 4) + (j lsl 2) + k) done done done; let ok = ref true in for i = 0 to 1 do for j = 0 to 2 do for k = 0 to 3 do if Int32.to_int a.{i,j,k} <> (i lsl 4) + (j lsl 2) + k then ok := false done done done; test 1 true !ok; let b = Array3.create int64 fortran_layout 2 3 4 in for i = 1 to 2 do for j = 1 to 3 do for k = 1 to 4 do b.{i,j,k} <- Int64.of_int((i lsl 4) + (j lsl 2) + k) done done done; let ok = ref true in for i = 1 to 2 do for j = 1 to 3 do for k = 1 to 4 do if Int64.to_int b.{i,j,k} <> (i lsl 4) + (j lsl 2) + k then ok := false done done done; test 2 true !ok; testing_function "set/get (unsafe, specialized)"; let a = Array3.create int32 c_layout 2 3 4 in for i = 0 to 1 do for j = 0 to 2 do for k = 0 to 3 do Array3.unsafe_set a i j k (Int32.of_int((i lsl 4) + (j lsl 2) + k)) done done done; let ok = ref true in for i = 0 to 1 do for j = 0 to 2 do for k = 0 to 3 do if Int32.to_int (Array3.unsafe_get a i j k) <> (i lsl 4) + (j lsl 2) + k then ok := false done done done; test 1 true !ok; testing_function "dim"; let a = (make_array3 int c_layout 0 4 5 6 id) in test 1 (Array3.dim1 a) 4; test 2 (Array3.dim2 a) 5; test 3 (Array3.dim3 a) 6; let b = (make_array3 int fortran_layout 1 4 5 6 id) in test 4 (Array3.dim1 b) 4; test 5 (Array3.dim2 b) 5; test 6 (Array3.dim3 b) 6; testing_function "slice1"; let a = make_array3 int c_layout 0 3 3 3 id in test 1 (Array3.slice_left_1 a 0 0) (from_list int [0;1;2]); test 2 (Array3.slice_left_1 a 0 1) (from_list int [10;11;12]); test 3 (Array3.slice_left_1 a 0 2) (from_list int [20;21;22]); test 4 (Array3.slice_left_1 a 1 1) (from_list int [110;111;112]); test 5 (Array3.slice_left_1 a 2 1) (from_list int [210;211;212]); let a = make_array3 int fortran_layout 1 3 3 3 id in test 6 (Array3.slice_right_1 a 1 2) (from_list_fortran int [112;212;312]); test 7 (Array3.slice_right_1 a 3 1) (from_list_fortran int [131;231;331]); (* Reshaping *) print_newline(); testing_function "------ Reshaping --------"; testing_function "reshape_1"; let a = make_array2 int c_layout 0 3 4 id in let b = make_array2 int fortran_layout 1 3 4 id in let c = reshape_1 (genarray_of_array2 a) 12 in test 1 c (from_list int [0;1;2;3;1000;1001;1002;1003;2000;2001;2002;2003]); let d = reshape_1 (genarray_of_array2 b) 12 in test 2 d (from_list_fortran int [1001;2001;3001;1002;2002;3002;1003;2003;3003;1004;2004;3004]); testing_function "reshape_2"; let c = reshape_2 (genarray_of_array2 a) 4 3 in test 1 (Array2.slice_left c 0) (from_list int [0;1;2]); test 2 (Array2.slice_left c 1) (from_list int [3;1000;1001]); test 3 (Array2.slice_left c 2) (from_list int [1002;1003;2000]); test 4 (Array2.slice_left c 3) (from_list int [2001;2002;2003]); let d = reshape_2 (genarray_of_array2 b) 4 3 in test 5 (Array2.slice_right d 1) (from_list_fortran int [1001;2001;3001;1002]); test 6 (Array2.slice_right d 2) (from_list_fortran int [2002;3002;1003;2003]); test 7 (Array2.slice_right d 3) (from_list_fortran int [3003;1004;2004;3004]); (* I/O *) print_newline(); testing_function "------ I/O --------"; testing_function "output_value/input_value"; let test_structured_io testno value = let tmp = Filename.temp_file "bigarray" ".data" in let oc = open_out_bin tmp in output_value oc value; close_out oc; let ic = open_in_bin tmp in let value' = input_value ic in close_in ic; Sys.remove tmp; test testno value value' in test_structured_io 1 (from_list int8_signed [1;2;3;-4;127;-128]); test_structured_io 2 (from_list int16_signed [1;2;3;-4;127;-128]); test_structured_io 3 (from_list int [1;2;3;-4;127;-128]); test_structured_io 4 (from_list int32 (List.map Int32.of_int [1;2;3;-4;127;-128])); test_structured_io 5 (from_list int64 (List.map Int64.of_int [1;2;3;-4;127;-128])); test_structured_io 6 (from_list nativeint (List.map Nativeint.of_int [1;2;3;-4;127;-128])); test_structured_io 7 (from_list float32 [0.0; 0.25; -4.0; 3.141592654]); test_structured_io 8 (from_list float64 [0.0; 0.25; -4.0; 3.141592654]); test_structured_io 9 (make_array2 int c_layout 0 100 100 id); test_structured_io 10 (make_array2 float64 fortran_layout 1 200 200 float); test_structured_io 11 (make_array3 int32 c_layout 0 20 30 40 Int32.of_int); test_structured_io 12 (make_array3 float32 fortran_layout 1 10 50 100 float); test_structured_io 13 (make_array2 complex32 c_layout 0 100 100 makecomplex); test_structured_io 14 (make_array3 complex64 fortran_layout 1 10 20 30 makecomplex); testing_function "map_file"; let mapped_file = Filename.temp_file "bigarray" ".data" in begin let fd = Unix.openfile mapped_file [Unix.O_RDWR; Unix.O_TRUNC; Unix.O_CREAT] 0o666 in let a = Array1.map_file fd float64 c_layout true 10000 in Unix.close fd; for i = 0 to 9999 do a.{i} <- float i done; let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in let b = Array2.map_file fd float64 fortran_layout false 100 (-1) in Unix.close fd; let ok = ref true in for i = 0 to 99 do for j = 0 to 99 do if b.{j+1,i+1} <> float (100 * i + j) then ok := false done done; test 1 !ok true; b.{50,50} <- (-1.0); let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in let c = Array2.map_file fd float64 c_layout false (-1) 100 in Unix.close fd; let ok = ref true in for i = 0 to 99 do for j = 0 to 99 do if c.{i,j} <> float (100 * i + j) then ok := false done done; test 2 !ok true; let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in let c = Array2.map_file fd ~pos:800L float64 c_layout false (-1) 100 in Unix.close fd; let ok = ref true in for i = 1 to 99 do for j = 0 to 99 do if c.{i-1,j} <> float (100 * i + j) then ok := false done done; test 3 !ok true; let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in let c = Array2.map_file fd ~pos:79200L float64 c_layout false (-1) 100 in Unix.close fd; let ok = ref true in for j = 0 to 99 do if c.{0,j} <> float (100 * 99 + j) then ok := false done; test 4 !ok true end; (* Force garbage collection of the mapped bigarrays above, otherwise Win32 doesn't let us erase the file. Notice the begin...end above so that the VM doesn't keep stack references to the mapped bigarrays. *) Gc.full_major(); Sys.remove mapped_file; () (********* End of test *********) let _ = print_newline(); if !error_occurred then begin prerr_endline "************* TEST FAILED ****************"; exit 2 end else exit 0 mingw-ocaml/ocaml/testsuite/tests/basic-float/0000755000175000017500000000000012124403241021035 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/basic-float/tfloat_record.reference0000644000175000017500000000000312124403241025535 0ustar tootstoots1. mingw-ocaml/ocaml/testsuite/tests/basic-float/Makefile0000644000175000017500000000022512124403241022474 0ustar tootstootsBASEDIR=../.. MODULES=float_record MAIN_MODULE=tfloat_record include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/basic-float/tfloat_record.ml0000644000175000017500000000017412124403241024220 0ustar tootstootslet s = { Float_record.f = Float_record.make 1.0 };; print_float (Float_record.from s.Float_record.f);; print_newline ();; mingw-ocaml/ocaml/testsuite/tests/basic-float/float_record.ml0000644000175000017500000000011112124403241024023 0ustar tootstootstype t = float;; let make f = f;; let from t = t;; type s = {f : t};; mingw-ocaml/ocaml/testsuite/tests/basic-float/float_record.mli0000644000175000017500000000013612124403241024203 0ustar tootstootstype t = private float;; val make : float -> t;; val from : t -> float;; type s = {f : t};; mingw-ocaml/ocaml/testsuite/tests/typing-modules/0000755000175000017500000000000012124403241021631 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-modules/Makefile0000644000175000017500000000012212124403241023264 0ustar tootstootsinclude ../../makefiles/Makefile.toplevel include ../../makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-modules/Test.ml0000644000175000017500000000237112124403241023105 0ustar tootstoots(* with module *) module type S = sig type t and s = t end;; module type S' = S with type t := int;; module type S = sig module rec M : sig end and N : sig end end;; module type S' = S with module M := String;; (* with module type *) (* module type S = sig module type T module F(X:T) : T end;; module type T0 = sig type t end;; module type S1 = S with module type T = T0;; module type S2 = S with module type T := T0;; module type S3 = S with module type T := sig type t = int end;; module H = struct include (Hashtbl : module type of Hashtbl with type statistics := Hashtbl.statistics and module type S := Hashtbl.S and module Make := Hashtbl.Make and module MakeSeeded := Hashtbl.MakeSeeded and module type SeededS := Hashtbl.SeededS and module type HashedType := Hashtbl.HashedType and module type SeededHashedType := Hashtbl.SeededHashedType) end;; *) (* A subtle problem appearing with -principal *) type -'a t class type c = object method m : [ `A ] t end;; module M : sig val v : (#c as 'a) -> 'a end = struct let v x = ignore (x :> c); x end;; (* PR#4838 *) let id = let module M = struct end in fun x -> x;; (* PR#4511 *) let ko = let module M = struct end in fun _ -> ();; mingw-ocaml/ocaml/testsuite/tests/typing-modules/Test.ml.reference0000644000175000017500000000066012124403241025041 0ustar tootstoots # module type S = sig type t and s = t end # module type S' = sig type s = int end # module type S = sig module rec M : sig end and N : sig end end # module type S' = sig module rec N : sig end end # * * * * * * * * * * * * * * * * type -'a t class type c = object method m : [ `A ] t end # module M : sig val v : (#c as 'a) -> 'a end # val id : 'a -> 'a = # val ko : 'a -> unit = # mingw-ocaml/ocaml/testsuite/tests/typing-modules/Test.ml.principal.reference0000644000175000017500000000066012124403241027021 0ustar tootstoots # module type S = sig type t and s = t end # module type S' = sig type s = int end # module type S = sig module rec M : sig end and N : sig end end # module type S' = sig module rec N : sig end end # * * * * * * * * * * * * * * * * type -'a t class type c = object method m : [ `A ] t end # module M : sig val v : (#c as 'a) -> 'a end # val id : 'a -> 'a = # val ko : 'a -> unit = # mingw-ocaml/ocaml/testsuite/tests/callback/0000755000175000017500000000000012124403241020405 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/callback/Makefile0000644000175000017500000000150712124403241022050 0ustar tootstootsBASEDIR=../.. CC=$(NATIVECC) -I $(TOPDIR)/byterun default: run-byte run-opt common: @$(CC) -c callbackprim.c run-byte: common @printf " ... testing 'bytecode':" @$(OCAMLC) -c tcallback.ml @$(OCAMLC) -o ./program -custom unix.cma callbackprim.$(O) tcallback.cmo @./program > bytecode.result @$(DIFF) reference bytecode.result || (echo " => failed" && exit 1) @echo " => passed" run-opt: common @if [ -z "$(BYTECODE_ONLY)" ]; then \ printf " ... testing 'native':"; \ $(OCAMLOPT) -c tcallback.ml; \ $(OCAMLOPT) -o ./program unix.cmxa callbackprim.$(O) tcallback.cmx; \ ./program > native.result; \ $(DIFF) reference native.result || (echo " => failed" && exit 1); \ echo " => passed"; \ fi promote: defaultpromote clean: defaultclean @rm -f *.result ./program include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/callback/callbackprim.c0000644000175000017500000000165612124403241023205 0ustar tootstoots#include "mlvalues.h" #include "memory.h" #include "callback.h" value mycallback1(value fun, value arg) { value res; res = callback(fun, arg); return res; } value mycallback2(value fun, value arg1, value arg2) { value res; res = callback2(fun, arg1, arg2); return res; } value mycallback3(value fun, value arg1, value arg2, value arg3) { value res; res = callback3(fun, arg1, arg2, arg3); return res; } value mycallback4(value fun, value arg1, value arg2, value arg3, value arg4) { value args[4]; value res; args[0] = arg1; args[1] = arg2; args[2] = arg3; args[3] = arg4; res = callbackN(fun, 4, args); return res; } value mypushroot(value v, value fun, value arg) { Begin_root(v) callback(fun, arg); End_roots(); return v; } value mycamlparam (value v, value fun, value arg) { CAMLparam3 (v, fun, arg); CAMLlocal2 (x, y); x = v; y = callback (fun, arg); v = x; CAMLreturn (v); } mingw-ocaml/ocaml/testsuite/tests/callback/tcallback.ml0000644000175000017500000000414212124403241022660 0ustar tootstootsexternal mycallback1 : ('a -> 'b) -> 'a -> 'b = "mycallback1" external mycallback2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = "mycallback2" external mycallback3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd = "mycallback3" external mycallback4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e = "mycallback4" let rec tak (x, y, z as _tuple) = if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y)) else z let tak2 x (y, z) = tak (x, y, z) let tak3 x y z = tak (x, y, z) let tak4 x y z u = tak (x, y, z + u) let raise_exit () = (raise Exit : unit) let trapexit () = begin try mycallback1 raise_exit () with Exit -> () end; tak (18, 12, 6) external mypushroot : 'a -> ('b -> 'c) -> 'b -> 'a = "mypushroot" external mycamlparam : 'a -> ('b -> 'c) -> 'b -> 'a = "mycamlparam" let tripwire f = let s = String.make 5 'a' in f s trapexit () (* Test callbacks performed to handle signals *) let sighandler signo = (* print_string "Got signal, triggering garbage collection..."; print_newline(); *) (* Thoroughly wipe the minor heap *) ignore (tak (18, 12, 6)) external unix_getpid : unit -> int = "unix_getpid" "noalloc" external unix_kill : int -> int -> unit = "unix_kill" "noalloc" let callbacksig () = let pid = unix_getpid() in (* Allocate a block in the minor heap *) let s = String.make 5 'b' in (* Send a signal to self. We want s to remain in a register and not be spilled on the stack, hence we declare unix_kill "noalloc". *) unix_kill pid Sys.sigusr1; (* Allocate some more so that the signal will be tested *) let u = (s, s) in fst u let _ = print_int(mycallback1 tak (18, 12, 6)); print_newline(); print_int(mycallback2 tak2 18 (12, 6)); print_newline(); print_int(mycallback3 tak3 18 12 6); print_newline(); print_int(mycallback4 tak4 18 12 3 3); print_newline(); print_int(trapexit ()); print_newline(); print_string(tripwire mypushroot); print_newline(); print_string(tripwire mycamlparam); print_newline(); Sys.set_signal Sys.sigusr1 (Sys.Signal_handle sighandler); print_string(callbacksig ()); print_newline() mingw-ocaml/ocaml/testsuite/tests/callback/reference0000644000175000017500000000003412124403241022263 0ustar tootstoots7 7 7 7 7 aaaaa aaaaa bbbbb mingw-ocaml/ocaml/testsuite/tests/lib-printf/0000755000175000017500000000000012124403241020717 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-printf/Makefile0000644000175000017500000000024012124403241022353 0ustar tootstoots#MODULES= MAIN_MODULE=tprintf ADD_COMPFLAGS=-I $(BASEDIR)/lib ADD_MODULES=testing include ../../makefiles/Makefile.one include ../../makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-printf/tprintf.reference0000644000175000017500000000272112124403241024267 0ustar tootstootsd/i positive 0 1 2 3 4 5 6 7 8 d/i negative 9 10 11 12 13 14 15 16 17 u positive 18 19 20 21 22 23 24 25 26 u negative 27 x positive 28 29 30 31 32 33 34 35 36 x negative 37 X positive 38 39 40 41 42 43 44 45 46 x negative 47 o positive 48 49 50 51 52 53 54 55 56 o negative 57 s 58 59 60 61 62 63 64 65 66 67 68 69 70 71 S 72 73 74 75 76 77 78 79 80 c 81 82 83 84 C 85 86 87 88 89 f 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 F 108 109 110 111 e 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 E 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 B 148 149 ld/li positive 150 151 152 153 154 155 156 157 158 ld/li negative 159 160 161 162 163 164 165 166 167 lu positive 168 169 170 171 172 173 174 175 176 lu negative 177 lx positive 178 179 180 181 182 183 184 185 186 lx negative 187 lX positive 188 189 190 191 192 193 194 195 196 lx negative 197 lo positive 198 199 200 201 202 203 204 205 206 lo negative 207 Ld/Li positive 208 209 210 211 212 213 214 215 216 Ld/Li negative 217 218 219 220 221 222 223 224 225 Lu positive 226 227 228 229 230 231 232 233 234 Lu negative 235 Lx positive 236 237 238 239 240 241 242 243 244 Lx negative 245 LX positive 246 247 248 249 250 251 252 253 254 Lx negative 255 Lo positive 256 257 258 259 260 261 262 263 264 Lo negative 265 a 266 t 267 (...%) 268 ! % @ , and constants 269 270 271 272 273 274 275 end of tests All tests succeeded. mingw-ocaml/ocaml/testsuite/tests/lib-printf/tprintf.ml0000644000175000017500000004172512124403241022750 0ustar tootstoots(*************************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2011 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (*************************************************************************) (* $Id: tscanf.ml 10713 2010-10-08 11:53:19Z doligez $ *) (* A test file for the Printf module. *) open Testing;; open Printf;; try printf "d/i positive\n%!"; test (sprintf "%d/%i" 42 43 = "42/43"); test (sprintf "%-4d/%-5i" 42 43 = "42 /43 "); test (sprintf "%04d/%05i" 42 43 = "0042/00043"); test (sprintf "%+d/%+i" 42 43 = "+42/+43"); test (sprintf "% d/% i" 42 43 = " 42/ 43"); test (sprintf "%#d/%#i" 42 43 = "42/43"); test (sprintf "%4d/%5i" 42 43 = " 42/ 43"); test (sprintf "%*d/%*i" 4 42 5 43 = " 42/ 43"); test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43 "); printf "\nd/i negative\n%!"; test (sprintf "%d/%i" (-42) (-43) = "-42/-43"); test (sprintf "%-4d/%-5i" (-42) (-43) = "-42 /-43 "); test (sprintf "%04d/%05i" (-42) (-43) = "-042/-0043"); test (sprintf "%+d/%+i" (-42) (-43) = "-42/-43"); test (sprintf "% d/% i" (-42) (-43) = "-42/-43"); test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43"); test (sprintf "%4d/%5i" (-42) (-43) = " -42/ -43"); test (sprintf "%*d/%*i" 4 (-42) 5 (-43) = " -42/ -43"); test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43 "); printf "\nu positive\n%!"; test (sprintf "%u" 42 = "42"); test (sprintf "%-4u" 42 = "42 "); test (sprintf "%04u" 42 = "0042"); test (sprintf "%+u" 42 = "42"); test (sprintf "% u" 42 = "42"); test (sprintf "%#u" 42 = "42"); test (sprintf "%4u" 42 = " 42"); test (sprintf "%*u" 4 42 = " 42"); test (sprintf "%-0+ #6d" 42 = "+42 "); printf "\nu negative\n%!"; begin match Sys.word_size with | 32 -> test (sprintf "%u" (-1) = "2147483647"); | 64 -> test (sprintf "%u" (-1) = "9223372036854775807"); | _ -> test false end; printf "\nx positive\n%!"; test (sprintf "%x" 42 = "2a"); test (sprintf "%-4x" 42 = "2a "); test (sprintf "%04x" 42 = "002a"); test (sprintf "%+x" 42 = "2a"); test (sprintf "% x" 42 = "2a"); test (sprintf "%#x" 42 = "0x2a"); test (sprintf "%4x" 42 = " 2a"); test (sprintf "%*x" 5 42 = " 2a"); test (sprintf "%-0+ #*x" 5 42 = "0x2a "); printf "\nx negative\n%!"; begin match Sys.word_size with | 32 -> test (sprintf "%x" (-42) = "7fffffd6"); | 64 -> test (sprintf "%x" (-42) = "7fffffffffffffd6"); | _ -> test false end; printf "\nX positive\n%!"; test (sprintf "%X" 42 = "2A"); test (sprintf "%-4X" 42 = "2A "); test (sprintf "%04X" 42 = "002A"); test (sprintf "%+X" 42 = "2A"); test (sprintf "% X" 42 = "2A"); test (sprintf "%#X" 42 = "0X2A"); test (sprintf "%4X" 42 = " 2A"); test (sprintf "%*X" 5 42 = " 2A"); test (sprintf "%-0+ #*X" 5 42 = "0X2A "); printf "\nx negative\n%!"; begin match Sys.word_size with | 32 -> test (sprintf "%X" (-42) = "7FFFFFD6"); | 64 -> test (sprintf "%X" (-42) = "7FFFFFFFFFFFFFD6"); | _ -> test false end; printf "\no positive\n%!"; test (sprintf "%o" 42 = "52"); test (sprintf "%-4o" 42 = "52 "); test (sprintf "%04o" 42 = "0052"); test (sprintf "%+o" 42 = "52"); test (sprintf "% o" 42 = "52"); test (sprintf "%#o" 42 = "052"); test (sprintf "%4o" 42 = " 52"); test (sprintf "%*o" 5 42 = " 52"); test (sprintf "%-0+ #*o" 5 42 = "052 "); printf "\no negative\n%!"; begin match Sys.word_size with | 32 -> test (sprintf "%o" (-42) = "17777777726"); | 64 -> test (sprintf "%o" (-42) = "777777777777777777726"); | _ -> test false end; printf "\ns\n%!"; test (sprintf "%s" "foo" = "foo"); test (sprintf "%-5s" "foo" = "foo "); test (sprintf "%05s" "foo" = " foo"); test (sprintf "%+s" "foo" = "foo"); test (sprintf "% s" "foo" = "foo"); test (sprintf "%#s" "foo" = "foo"); test (sprintf "%5s" "foo" = " foo"); test (sprintf "%1s" "foo" = "foo"); test (sprintf "%*s" 6 "foo" = " foo"); test (sprintf "%*s" 2 "foo" = "foo"); test (sprintf "%-0+ #5s" "foo" = "foo "); test (sprintf "%s@" "foo" = "foo@"); test (sprintf "%s@inria.fr" "foo" = "foo@inria.fr"); test (sprintf "%s@%s" "foo" "inria.fr" = "foo@inria.fr"); printf "\nS\n%!"; test (sprintf "%S" "fo\"o" = "\"fo\\\"o\""); (* test (sprintf "%-5S" "foo" = "\"foo\" "); padding not done *) (* test (sprintf "%05S" "foo" = " \"foo\""); padding not done *) test (sprintf "%+S" "foo" = "\"foo\""); test (sprintf "% S" "foo" = "\"foo\""); test (sprintf "%#S" "foo" = "\"foo\""); (* test (sprintf "%5S" "foo" = " \"foo\""); padding not done *) test (sprintf "%1S" "foo" = "\"foo\""); (* test (sprintf "%*S" 6 "foo" = " \"foo\""); padding not done *) test (sprintf "%*S" 2 "foo" = "\"foo\""); (* test (sprintf "%-0+ #5S" "foo" = "\"foo\" "); padding not done *) test (sprintf "%S@" "foo" = "\"foo\"@"); test (sprintf "%S@inria.fr" "foo" = "\"foo\"@inria.fr"); test (sprintf "%S@%S" "foo" "inria.fr" = "\"foo\"@\"inria.fr\""); printf "\nc\n%!"; test (sprintf "%c" 'c' = "c"); (* test (sprintf "%-4c" 'c' = "c "); padding not done *) (* test (sprintf "%04c" 'c' = " c"); padding not done *) test (sprintf "%+c" 'c' = "c"); test (sprintf "% c" 'c' = "c"); test (sprintf "%#c" 'c' = "c"); (* test (sprintf "%4c" 'c' = " c"); padding not done *) (* test (sprintf "%*c" 2 'c' = " c"); padding not done *) (* test (sprintf "%-0+ #4c" 'c' = "c "); padding not done *) printf "\nC\n%!"; test (sprintf "%C" 'c' = "'c'"); test (sprintf "%C" '\'' = "'\\''"); (* test (sprintf "%-4C" 'c' = "c "); padding not done *) (* test (sprintf "%04C" 'c' = " c"); padding not done *) test (sprintf "%+C" 'c' = "'c'"); test (sprintf "% C" 'c' = "'c'"); test (sprintf "%#C" 'c' = "'c'"); (* test (sprintf "%4C" 'c' = " c"); padding not done *) (* test (sprintf "%*C" 2 'c' = " c"); padding not done *) (* test (sprintf "%-0+ #4C" 'c' = "c "); padding not done *) printf "\nf\n%!"; test (sprintf "%f" (-42.42) = "-42.420000"); test (sprintf "%-13f" (-42.42) = "-42.420000 "); test (sprintf "%013f" (-42.42) = "-00042.420000"); test (sprintf "%+f" 42.42 = "+42.420000"); test (sprintf "% f" 42.42 = " 42.420000"); test (sprintf "%#f" 42.42 = "42.420000"); test (sprintf "%13f" 42.42 = " 42.420000"); test (sprintf "%*f" 12 42.42 = " 42.420000"); test (sprintf "%-0+ #12f" 42.42 = "+42.420000 "); test (sprintf "%.3f" (-42.42) = "-42.420"); test (sprintf "%-13.3f" (-42.42) = "-42.420 "); test (sprintf "%013.3f" (-42.42) = "-00000042.420"); test (sprintf "%+.3f" 42.42 = "+42.420"); test (sprintf "% .3f" 42.42 = " 42.420"); test (sprintf "%#.3f" 42.42 = "42.420"); test (sprintf "%13.3f" 42.42 = " 42.420"); test (sprintf "%*.*f" 12 3 42.42 = " 42.420"); test (sprintf "%-0+ #12.3f" 42.42 = "+42.420 "); printf "\nF\n%!"; test (sprintf "%F" 42.42 = "42.42"); test (sprintf "%F" 42.42e42 = "4.242e+43"); test (sprintf "%F" 42.00 = "42."); test (sprintf "%F" 0.042 = "0.042"); (* no padding, no precision test (sprintf "%.3F" 42.42 = "42.420"); test (sprintf "%12.3F" 42.42e42 = " 4.242e+43"); test (sprintf "%.3F" 42.00 = "42.000"); test (sprintf "%.3F" 0.0042 = "0.004"); *) printf "\ne\n%!"; test (sprintf "%e" (-42.42) = "-4.242000e+01"); test (sprintf "%-15e" (-42.42) = "-4.242000e+01 "); test (sprintf "%015e" (-42.42) = "-004.242000e+01"); test (sprintf "%+e" 42.42 = "+4.242000e+01"); test (sprintf "% e" 42.42 = " 4.242000e+01"); test (sprintf "%#e" 42.42 = "4.242000e+01"); test (sprintf "%15e" 42.42 = " 4.242000e+01"); test (sprintf "%*e" 14 42.42 = " 4.242000e+01"); test (sprintf "%-0+ #14e" 42.42 = "+4.242000e+01 "); test (sprintf "%.3e" (-42.42) = "-4.242e+01"); test (sprintf "%-15.3e" (-42.42) = "-4.242e+01 "); test (sprintf "%015.3e" (-42.42) = "-000004.242e+01"); test (sprintf "%+.3e" 42.42 = "+4.242e+01"); test (sprintf "% .3e" 42.42 = " 4.242e+01"); test (sprintf "%#.3e" 42.42 = "4.242e+01"); test (sprintf "%15.3e" 42.42 = " 4.242e+01"); test (sprintf "%*.*e" 11 3 42.42 = " 4.242e+01"); test (sprintf "%-0+ #14.3e" 42.42 = "+4.242e+01 "); printf "\nE\n%!"; test (sprintf "%E" (-42.42) = "-4.242000E+01"); test (sprintf "%-15E" (-42.42) = "-4.242000E+01 "); test (sprintf "%015E" (-42.42) = "-004.242000E+01"); test (sprintf "%+E" 42.42 = "+4.242000E+01"); test (sprintf "% E" 42.42 = " 4.242000E+01"); test (sprintf "%#E" 42.42 = "4.242000E+01"); test (sprintf "%15E" 42.42 = " 4.242000E+01"); test (sprintf "%*E" 14 42.42 = " 4.242000E+01"); test (sprintf "%-0+ #14E" 42.42 = "+4.242000E+01 "); test (sprintf "%.3E" (-42.42) = "-4.242E+01"); test (sprintf "%-15.3E" (-42.42) = "-4.242E+01 "); test (sprintf "%015.3E" (-42.42) = "-000004.242E+01"); test (sprintf "%+.3E" 42.42 = "+4.242E+01"); test (sprintf "% .3E" 42.42 = " 4.242E+01"); test (sprintf "%#.3E" 42.42 = "4.242E+01"); test (sprintf "%15.3E" 42.42 = " 4.242E+01"); test (sprintf "%*.*E" 11 3 42.42 = " 4.242E+01"); test (sprintf "%-0+ #14.3E" 42.42 = "+4.242E+01 "); (* %g gives strange results that correspond to neither %f nor %e printf "\ng\n%!"; test (sprintf "%g" (-42.42) = "-42.42000"); test (sprintf "%-15g" (-42.42) = "-42.42000 "); test (sprintf "%015g" (-42.42) = "-00000042.42000"); test (sprintf "%+g" 42.42 = "+42.42000"); test (sprintf "% g" 42.42 = " 42.42000"); test (sprintf "%#g" 42.42 = "42.42000"); test (sprintf "%15g" 42.42 = " 42.42000"); test (sprintf "%*g" 14 42.42 = " 42.42000"); test (sprintf "%-0+ #14g" 42.42 = "+42.42000 "); test (sprintf "%.3g" (-42.42) = "-42.420"); *) (* Same for %G printf "\nG\n%!"; *) printf "\nB\n%!"; test (sprintf "%B" true = "true"); test (sprintf "%B" false = "false"); printf "\nld/li positive\n%!"; test (sprintf "%ld/%li" 42l 43l = "42/43"); test (sprintf "%-4ld/%-5li" 42l 43l = "42 /43 "); test (sprintf "%04ld/%05li" 42l 43l = "0042/00043"); test (sprintf "%+ld/%+li" 42l 43l = "+42/+43"); test (sprintf "% ld/% li" 42l 43l = " 42/ 43"); test (sprintf "%#ld/%#li" 42l 43l = "42/43"); test (sprintf "%4ld/%5li" 42l 43l = " 42/ 43"); test (sprintf "%*ld/%*li" 4 42l 5 43l = " 42/ 43"); test (sprintf "%-0+#4ld/%-0 #5li" 42l 43l = "+42 / 43 "); printf "\nld/li negative\n%!"; test (sprintf "%ld/%li" (-42l) (-43l) = "-42/-43"); test (sprintf "%-4ld/%-5li" (-42l) (-43l) = "-42 /-43 "); test (sprintf "%04ld/%05li" (-42l) (-43l) = "-042/-0043"); test (sprintf "%+ld/%+li" (-42l) (-43l) = "-42/-43"); test (sprintf "% ld/% li" (-42l) (-43l) = "-42/-43"); test (sprintf "%#ld/%#li" (-42l) (-43l) = "-42/-43"); test (sprintf "%4ld/%5li" (-42l) (-43l) = " -42/ -43"); test (sprintf "%*ld/%*li" 4 (-42l) 5 (-43l) = " -42/ -43"); test (sprintf "%-0+ #4ld/%-0+ #5li" (-42l) (-43l) = "-42 /-43 "); printf "\nlu positive\n%!"; test (sprintf "%lu" 42l = "42"); test (sprintf "%-4lu" 42l = "42 "); test (sprintf "%04lu" 42l = "0042"); test (sprintf "%+lu" 42l = "42"); test (sprintf "% lu" 42l = "42"); test (sprintf "%#lu" 42l = "42"); test (sprintf "%4lu" 42l = " 42"); test (sprintf "%*lu" 4 42l = " 42"); test (sprintf "%-0+ #6ld" 42l = "+42 "); printf "\nlu negative\n%!"; test (sprintf "%lu" (-1l) = "4294967295"); printf "\nlx positive\n%!"; test (sprintf "%lx" 42l = "2a"); test (sprintf "%-4lx" 42l = "2a "); test (sprintf "%04lx" 42l = "002a"); test (sprintf "%+lx" 42l = "2a"); test (sprintf "% lx" 42l = "2a"); test (sprintf "%#lx" 42l = "0x2a"); test (sprintf "%4lx" 42l = " 2a"); test (sprintf "%*lx" 5 42l = " 2a"); test (sprintf "%-0+ #*lx" 5 42l = "0x2a "); printf "\nlx negative\n%!"; test (sprintf "%lx" (-42l) = "ffffffd6"); printf "\nlX positive\n%!"; test (sprintf "%lX" 42l = "2A"); test (sprintf "%-4lX" 42l = "2A "); test (sprintf "%04lX" 42l = "002A"); test (sprintf "%+lX" 42l = "2A"); test (sprintf "% lX" 42l = "2A"); test (sprintf "%#lX" 42l = "0X2A"); test (sprintf "%4lX" 42l = " 2A"); test (sprintf "%*lX" 5 42l = " 2A"); test (sprintf "%-0+ #*lX" 5 42l = "0X2A "); printf "\nlx negative\n%!"; test (sprintf "%lX" (-42l) = "FFFFFFD6"); printf "\nlo positive\n%!"; test (sprintf "%lo" 42l = "52"); test (sprintf "%-4lo" 42l = "52 "); test (sprintf "%04lo" 42l = "0052"); test (sprintf "%+lo" 42l = "52"); test (sprintf "% lo" 42l = "52"); test (sprintf "%#lo" 42l = "052"); test (sprintf "%4lo" 42l = " 52"); test (sprintf "%*lo" 5 42l = " 52"); test (sprintf "%-0+ #*lo" 5 42l = "052 "); printf "\nlo negative\n%!"; test (sprintf "%lo" (-42l) = "37777777726"); (* Nativeint not tested: looks like too much work, and anyway it should work like Int32 or Int64. *) printf "\nLd/Li positive\n%!"; test (sprintf "%Ld/%Li" 42L 43L = "42/43"); test (sprintf "%-4Ld/%-5Li" 42L 43L = "42 /43 "); test (sprintf "%04Ld/%05Li" 42L 43L = "0042/00043"); test (sprintf "%+Ld/%+Li" 42L 43L = "+42/+43"); test (sprintf "% Ld/% Li" 42L 43L = " 42/ 43"); test (sprintf "%#Ld/%#Li" 42L 43L = "42/43"); test (sprintf "%4Ld/%5Li" 42L 43L = " 42/ 43"); test (sprintf "%*Ld/%*Li" 4 42L 5 43L = " 42/ 43"); test (sprintf "%-0+#4Ld/%-0 #5Li" 42L 43L = "+42 / 43 "); printf "\nLd/Li negative\n%!"; test (sprintf "%Ld/%Li" (-42L) (-43L) = "-42/-43"); test (sprintf "%-4Ld/%-5Li" (-42L) (-43L) = "-42 /-43 "); test (sprintf "%04Ld/%05Li" (-42L) (-43L) = "-042/-0043"); test (sprintf "%+Ld/%+Li" (-42L) (-43L) = "-42/-43"); test (sprintf "% Ld/% Li" (-42L) (-43L) = "-42/-43"); test (sprintf "%#Ld/%#Li" (-42L) (-43L) = "-42/-43"); test (sprintf "%4Ld/%5Li" (-42L) (-43L) = " -42/ -43"); test (sprintf "%*Ld/%*Li" 4 (-42L) 5 (-43L) = " -42/ -43"); test (sprintf "%-0+ #4Ld/%-0+ #5Li" (-42L) (-43L) = "-42 /-43 "); printf "\nLu positive\n%!"; test (sprintf "%Lu" 42L = "42"); test (sprintf "%-4Lu" 42L = "42 "); test (sprintf "%04Lu" 42L = "0042"); test (sprintf "%+Lu" 42L = "42"); test (sprintf "% Lu" 42L = "42"); test (sprintf "%#Lu" 42L = "42"); test (sprintf "%4Lu" 42L = " 42"); test (sprintf "%*Lu" 4 42L = " 42"); test (sprintf "%-0+ #6Ld" 42L = "+42 "); printf "\nLu negative\n%!"; test (sprintf "%Lu" (-1L) = "18446744073709551615"); printf "\nLx positive\n%!"; test (sprintf "%Lx" 42L = "2a"); test (sprintf "%-4Lx" 42L = "2a "); test (sprintf "%04Lx" 42L = "002a"); test (sprintf "%+Lx" 42L = "2a"); test (sprintf "% Lx" 42L = "2a"); test (sprintf "%#Lx" 42L = "0x2a"); test (sprintf "%4Lx" 42L = " 2a"); test (sprintf "%*Lx" 5 42L = " 2a"); test (sprintf "%-0+ #*Lx" 5 42L = "0x2a "); printf "\nLx negative\n%!"; test (sprintf "%Lx" (-42L) = "ffffffffffffffd6"); printf "\nLX positive\n%!"; test (sprintf "%LX" 42L = "2A"); test (sprintf "%-4LX" 42L = "2A "); test (sprintf "%04LX" 42L = "002A"); test (sprintf "%+LX" 42L = "2A"); test (sprintf "% LX" 42L = "2A"); test (sprintf "%#LX" 42L = "0X2A"); test (sprintf "%4LX" 42L = " 2A"); test (sprintf "%*LX" 5 42L = " 2A"); test (sprintf "%-0+ #*LX" 5 42L = "0X2A "); printf "\nLx negative\n%!"; test (sprintf "%LX" (-42L) = "FFFFFFFFFFFFFFD6"); printf "\nLo positive\n%!"; test (sprintf "%Lo" 42L = "52"); test (sprintf "%-4Lo" 42L = "52 "); test (sprintf "%04Lo" 42L = "0052"); test (sprintf "%+Lo" 42L = "52"); test (sprintf "% Lo" 42L = "52"); test (sprintf "%#Lo" 42L = "052"); test (sprintf "%4Lo" 42L = " 52"); test (sprintf "%*Lo" 5 42L = " 52"); test (sprintf "%-0+ #*Lo" 5 42L = "052 "); printf "\nLo negative\n%!"; test (sprintf "%Lo" (-42L) = "1777777777777777777726"); printf "\na\n%!"; let x = ref () in let f () y = if y == x then "ok" else "wrong" in test (sprintf "%a" f x = "ok"); printf "\nt\n%!"; let f () = "ok" in test (sprintf "%t" f = "ok"); (* Does not work as expected. Should be fixed to work like %s. printf "\n{...%%}\n%!"; let f = format_of_string "%f/%s" in test (sprintf "%{%f%s%}" f = "%f/%s"); *) printf "\n(...%%)\n%!"; let f = format_of_string "%d/foo/%s" in test (sprintf "%(%d%s%)" f 42 "bar" = "42/foo/bar"); printf "\n! %% @ , and constants\n%!"; test (sprintf "%!" = ""); test (sprintf "%%" = "%"); test (sprintf "%@" = "@"); test (sprintf "%," = ""); test (sprintf "@" = "@"); test (sprintf "@@" = "@@"); test (sprintf "@%%" = "@%"); printf "\nend of tests\n%!"; with e -> printf "unexpected exception: %s\n%!" (Printexc.to_string e); test false; ;; mingw-ocaml/ocaml/testsuite/tests/typing-objects/0000755000175000017500000000000012124403241021612 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-objects/Tests.ml.reference0000644000175000017500000002315512124403241025211 0ustar tootstoots # - : < x : int > -> < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int > = # class ['a] c : unit -> object constraint 'a = int method f : 'a c end and ['a] d : unit -> object constraint 'a = int method f : 'a c end # Characters 238-275: ........d () = object inherit ['a] c () end.. Error: Some type variables are unbound in this type: class d : unit -> object method f : 'a -> unit end The method f has type 'a -> unit where 'a is unbound # class virtual c : unit -> object end and ['a] d : unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end # class ['a] c : unit -> object constraint 'a = int end and ['a] d : unit -> object constraint 'a = int #c end # * class ['a] c : 'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end # - : ('a c as 'a) -> 'a = # * Characters 134-176: ......x () = object method virtual f : int end.. Error: This class should be virtual. The following methods are undefined : f # Characters 139-147: class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end ^^^^^^^^ Error: This pattern cannot match self: it only matches values of type < f : int > # Characters 38-110: ......['a] c () = object constraint 'a = int method f x = (x : bool c) end.. Error: The abbreviation c is used with parameters bool c wich are incompatible with constraints int c # class ['a, 'b] c : unit -> object constraint 'a = int -> 'c constraint 'b = 'a * < x : 'b > * 'c * 'd method f : 'a -> 'b -> unit end # class ['a, 'b] d : unit -> object constraint 'a = int -> 'c constraint 'b = 'a * < x : 'b > * 'c * 'd method f : 'a -> 'b -> unit end # val x : '_a list ref = {contents = []} # Characters 6-50: ......['a] c () = object method f = (x : 'a) end.. Error: The type of this class, class ['a] c : unit -> object constraint 'a = '_b list ref method f : 'a end, contains type variables that cannot be generalized # Characters 24-52: type 'a c = ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In the definition of d, type int c should be 'a c # type 'a c = < f : 'a c; g : 'a d > and 'a d = < f : 'a c > # type 'a c = < f : 'a c > and 'a d = < f : int c > # type 'a u = < x : 'a > and 'a t = 'a t u # Characters 18-32: and 'a t = 'a t u;; ^^^^^^^^^^^^^^ Error: The type abbreviation t is cyclic # type 'a u = 'a # Characters 5-18: type t = t u * t u;; ^^^^^^^^^^^^^ Error: The type abbreviation t is cyclic # type t = < x : 'a > as 'a # type 'a u = 'a # - : t -> t u -> bool = # - : t -> t u -> bool = # module M : sig class ['a, 'b] c : int -> 'b -> object constraint 'a = int -> bool val x : float list val y : 'b method f : 'a -> unit method g : 'b end end # module M' : sig class virtual ['a, 'b] c : int -> 'b -> object constraint 'a = int -> bool val x : float list val y : 'b method f : 'a -> unit method g : 'b end end # class ['a, 'b] d : unit -> 'b -> object constraint 'a = int -> bool val x : float list val y : 'b method f : 'a -> unit method g : 'b end # class ['a, 'b] e : unit -> 'b -> object constraint 'a = int -> bool val x : float list val y : 'b method f : 'a -> unit method g : 'b end # - : string = "a" # - : int = 10 # - : float = 7.1 # # - : bool = true # module M : sig class ['a] c : unit -> object method f : 'a -> unit end end # module M' : sig class ['a] c : unit -> object method f : 'a -> unit end end # - : ('a #M.c as 'b) -> 'b = # - : ('a #M'.c as 'b) -> 'b = # class ['a] c : 'a #c -> object end # class ['a] c : 'a #c -> object end # class c : unit -> object method f : int end and d : unit -> object method f : int end # class e : unit -> object method f : int end # - : int = 2 # Characters 30-34: class c () = object val x = - true val y = -. () end;; ^^^^ Error: This expression has type bool but an expression was expected of type int # class c : unit -> object method f : int method g : int method h : int end # class d : unit -> object method h : int method i : int method j : int end # class e : unit -> object method f : int method g : int method h : int method i : int method j : int end # val e : e = # - : int * int * int * int * int = (1, 3, 2, 2, 3) # class c : 'a -> object val a : 'a val x : int val y : int val z : int end # class d : 'a -> object val b : 'a val t : int val u : int val z : int end # Characters 42-45: inherit c 5 ^^^ Warning 13: the following instance variables are overridden by the class c : x The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) Characters 52-53: val y = 3 ^ Warning 13: the instance variable y is overridden. The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) Characters 80-83: inherit d 7 ^^^ Warning 13: the following instance variables are overridden by the class d : t z The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) Characters 90-91: val u = 3 ^ Warning 13: the instance variable u is overridden. The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) class e : unit -> object val a : int val b : int val t : int val u : int val x : int val y : int val z : int method a : int method b : int method t : int method u : int method x : int method y : int method z : int end # val e : e = # - : int * int * int * int * int * int * int = (1, 3, 2, 2, 3, 5, 7) # class c : int -> int -> object val x : int val y : int method x : int method y : int end # class d : int -> int -> object val x : int val y : int method x : int method y : int end # - : int * int = (1, 2) # - : int * int = (1, 2) # class ['a] c : 'a -> object end # - : 'a -> 'a c = # * * * * * * * * * * * * * * * * * * * * * module M : sig class c : unit -> object method xc : int end end # class d : unit -> object val x : int method xc : int method xd : int end # - : int * int = (1, 2) # Characters 7-156: ......virtual ['a] matrix (sz, init : int * 'a) = object val m = Array.create_matrix sz sz init method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) end.. Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a > but is used with type < m : 'a array array; .. > # class c : unit -> object method m : c end # - : c = # module M : sig class c : unit -> object method m : c end end # - : M.c = # type uu = A of int | B of (< leq : 'a > as 'a) # class virtual c : unit -> object ('a) method virtual m : 'a end # module S : sig val f : (#c as 'a) -> 'a end # Characters 12-43: ............struct let f (x : #c) = x end...... Error: Signature mismatch: Modules do not match: sig val f : (#c as 'a) -> 'a end is not included in sig val f : #c -> #c end Values do not match: val f : (#c as 'a) -> 'a is not included in val f : #c -> #c # Characters 32-55: module M = struct type t = int class t () = object end end;; ^^^^^^^^^^^^^^^^^^^^^^^ Error: Multiple definition of the type name t. Names must be unique in a given structure or signature. # - : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = # Characters 10-39: fun x -> (x : int -> bool :> 'a -> 'a);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type int -> bool is not a subtype of int -> int # Characters 9-40: fun x -> (x : int -> bool :> int -> int);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type int -> bool is not a subtype of int -> int # - : < > -> < > = # - : < .. > -> < > = # val x : '_a list ref = {contents = []} # module F : functor (X : sig end) -> sig type t = int end # - : < m : int > list ref = {contents = []} # type 'a t # Characters 9-19: fun (x : 'a t as 'a) -> ();; ^^^^^^^^^^ Error: This alias is bound to type 'a t but is used as an instance of type 'a The type variable 'a occurs inside 'a t # Characters 19-20: fun (x : 'a t) -> (x : 'a); ();; ^ Error: This expression has type 'a t but an expression was expected of type 'a The type variable 'a occurs inside 'a t # type 'a t = < x : 'a > # - : ('a t as 'a) -> unit = # Characters 18-26: fun (x : 'a t) -> (x : 'a); ();; ^^^^^^^^ Warning 10: this expression should have type unit. - : ('a t as 'a) t -> unit = # class ['a] c : unit -> object constraint 'a = (< .. > as 'b) -> unit method m : 'a end # class ['a] c : unit -> object constraint 'a = unit -> (< .. > as 'b) method m : 'a -> 'b end # class c : unit -> object method private m : int method n : int end # class d : unit -> object method private m : int method n : int method o : int end # - : int * int = (1, 1) # class c : unit -> object method m : int end # - : int = 15 # - : int = 16 # - : int = 17 # - : int * int * int = (18, 19, 20) # - : int * int * int * int * int = (21, 22, 23, 33, 33) # - : int * int * int * int * int = (24, 25, 26, 33, 33) # mingw-ocaml/ocaml/testsuite/tests/typing-objects/Tests.ml.principal.reference0000644000175000017500000002317112124403241027167 0ustar tootstoots # - : < x : int > -> < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int > = # class ['a] c : unit -> object constraint 'a = int method f : int c end and ['a] d : unit -> object constraint 'a = int method f : int c end # Characters 238-275: ........d () = object inherit ['a] c () end.. Error: Some type variables are unbound in this type: class d : unit -> object method f : 'a -> unit end The method f has type 'a -> unit where 'a is unbound # class virtual c : unit -> object end and ['a] d : unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end # class ['a] c : unit -> object constraint 'a = int end and ['a] d : unit -> object constraint 'a = int #c end # * class ['a] c : 'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end # - : ('a c as 'a) -> 'a = # * Characters 134-176: ......x () = object method virtual f : int end.. Error: This class should be virtual. The following methods are undefined : f # Characters 139-147: class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end ^^^^^^^^ Error: This pattern cannot match self: it only matches values of type < f : int > # Characters 38-110: ......['a] c () = object constraint 'a = int method f x = (x : bool c) end.. Error: The abbreviation c is used with parameters bool c wich are incompatible with constraints int c # class ['a, 'b] c : unit -> object constraint 'a = int -> 'c constraint 'b = 'a * < x : 'b > * 'c * 'd method f : 'a -> 'b -> unit end # class ['a, 'b] d : unit -> object constraint 'a = int -> 'c constraint 'b = 'a * < x : 'b > * 'c * 'd method f : 'a -> 'b -> unit end # val x : '_a list ref = {contents = []} # Characters 6-50: ......['a] c () = object method f = (x : 'a) end.. Error: The type of this class, class ['a] c : unit -> object constraint 'a = '_b list ref method f : 'a end, contains type variables that cannot be generalized # Characters 24-52: type 'a c = ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In the definition of d, type int c should be 'a c # type 'a c = < f : 'a c; g : 'a d > and 'a d = < f : 'a c > # type 'a c = < f : 'a c > and 'a d = < f : int c > # type 'a u = < x : 'a > and 'a t = 'a t u # Characters 18-32: and 'a t = 'a t u;; ^^^^^^^^^^^^^^ Error: The type abbreviation t is cyclic # type 'a u = 'a # Characters 5-18: type t = t u * t u;; ^^^^^^^^^^^^^ Error: The type abbreviation t is cyclic # type t = < x : 'a > as 'a # type 'a u = 'a # - : t -> t u -> bool = # - : t -> t u -> bool = # module M : sig class ['a, 'b] c : int -> 'b -> object constraint 'a = int -> bool val x : float list val y : 'b method f : 'a -> unit method g : 'b end end # module M' : sig class virtual ['a, 'b] c : int -> 'b -> object constraint 'a = int -> bool val x : float list val y : 'b method f : 'a -> unit method g : 'b end end # class ['a, 'b] d : unit -> 'b -> object constraint 'a = int -> bool val x : float list val y : 'b method f : 'a -> unit method g : 'b end # class ['a, 'b] e : unit -> 'b -> object constraint 'a = int -> bool val x : float list val y : 'b method f : 'a -> unit method g : 'b end # - : string = "a" # - : int = 10 # - : float = 7.1 # # - : bool = true # module M : sig class ['a] c : unit -> object method f : 'a -> unit end end # module M' : sig class ['a] c : unit -> object method f : 'a -> unit end end # - : ('a #M.c as 'b) -> 'b = # - : ('a #M'.c as 'b) -> 'b = # class ['a] c : 'a #c -> object end # class ['a] c : 'a #c -> object end # class c : unit -> object method f : int end and d : unit -> object method f : int end # class e : unit -> object method f : int end # - : int = 2 # Characters 30-34: class c () = object val x = - true val y = -. () end;; ^^^^ Error: This expression has type bool but an expression was expected of type int # class c : unit -> object method f : int method g : int method h : int end # class d : unit -> object method h : int method i : int method j : int end # class e : unit -> object method f : int method g : int method h : int method i : int method j : int end # val e : e = # - : int * int * int * int * int = (1, 3, 2, 2, 3) # class c : 'a -> object val a : 'a val x : int val y : int val z : int end # class d : 'a -> object val b : 'a val t : int val u : int val z : int end # Characters 42-45: inherit c 5 ^^^ Warning 13: the following instance variables are overridden by the class c : x The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) Characters 52-53: val y = 3 ^ Warning 13: the instance variable y is overridden. The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) Characters 80-83: inherit d 7 ^^^ Warning 13: the following instance variables are overridden by the class d : t z The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) Characters 90-91: val u = 3 ^ Warning 13: the instance variable u is overridden. The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) class e : unit -> object val a : int val b : int val t : int val u : int val x : int val y : int val z : int method a : int method b : int method t : int method u : int method x : int method y : int method z : int end # val e : e = # - : int * int * int * int * int * int * int = (1, 3, 2, 2, 3, 5, 7) # class c : int -> int -> object val x : int val y : int method x : int method y : int end # class d : int -> int -> object val x : int val y : int method x : int method y : int end # - : int * int = (1, 2) # - : int * int = (1, 2) # class ['a] c : 'a -> object end # - : 'a -> 'a c = # * * * * * * * * * * * * * * * * * * * * * module M : sig class c : unit -> object method xc : int end end # class d : unit -> object val x : int method xc : int method xd : int end # - : int * int = (1, 2) # Characters 7-156: ......virtual ['a] matrix (sz, init : int * 'a) = object val m = Array.create_matrix sz sz init method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) end.. Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a > but is used with type < m : 'a array array; .. > # class c : unit -> object method m : c end # - : c = # module M : sig class c : unit -> object method m : c end end # - : M.c = # type uu = A of int | B of (< leq : 'a > as 'a) # class virtual c : unit -> object ('a) method virtual m : 'a end # module S : sig val f : (#c as 'a) -> 'a end # Characters 12-43: ............struct let f (x : #c) = x end...... Error: Signature mismatch: Modules do not match: sig val f : (#c as 'a) -> 'a end is not included in sig val f : #c -> #c end Values do not match: val f : (#c as 'a) -> 'a is not included in val f : #c -> #c # Characters 32-55: module M = struct type t = int class t () = object end end;; ^^^^^^^^^^^^^^^^^^^^^^^ Error: Multiple definition of the type name t. Names must be unique in a given structure or signature. # - : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = # Characters 10-39: fun x -> (x : int -> bool :> 'a -> 'a);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type int -> bool is not a subtype of int -> int # Characters 9-40: fun x -> (x : int -> bool :> int -> int);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type int -> bool is not a subtype of int -> int # - : < > -> < > = # - : < .. > -> < > = # val x : '_a list ref = {contents = []} # module F : functor (X : sig end) -> sig type t = int end # - : < m : int > list ref = {contents = []} # type 'a t # Characters 9-19: fun (x : 'a t as 'a) -> ();; ^^^^^^^^^^ Error: This alias is bound to type 'a t but is used as an instance of type 'a The type variable 'a occurs inside 'a t # Characters 19-20: fun (x : 'a t) -> (x : 'a); ();; ^ Error: This expression has type 'a t but an expression was expected of type 'a The type variable 'a occurs inside 'a t # type 'a t = < x : 'a > # - : ('a t as 'a) -> unit = # Characters 18-26: fun (x : 'a t) -> (x : 'a); ();; ^^^^^^^^ Warning 10: this expression should have type unit. - : ('a t as 'a) t -> unit = # class ['a] c : unit -> object constraint 'a = (< .. > as 'b) -> unit method m : 'b -> unit end # class ['a] c : unit -> object constraint 'a = unit -> (< .. > as 'b) method m : 'a -> 'b end # class c : unit -> object method private m : int method n : int end # class d : unit -> object method private m : int method n : int method o : int end # - : int * int = (1, 1) # class c : unit -> object method m : int end # - : int = 15 # - : int = 16 # - : int = 17 # - : int * int * int = (18, 19, 20) # - : int * int * int * int * int = (21, 22, 23, 33, 33) # - : int * int * int * int * int = (24, 25, 26, 33, 33) # mingw-ocaml/ocaml/testsuite/tests/typing-objects/Exemples.ml.principal.reference0000644000175000017500000002416012124403241027646 0ustar tootstoots # class point : int -> object val mutable x : int method get_x : int method move : int -> unit end # val p : point = # - : int = 7 # - : unit = () # - : int = 10 # val q : < get_x : int; move : int -> unit > = # - : int * int = (10, 17) # class color_point : int -> string -> object val c : string val mutable x : int method color : string method get_x : int method move : int -> unit end # val p' : color_point = # - : int * string = (5, "red") # val l : point list = [; ] # val get_x : < get_x : 'a; .. > -> 'a = # val set_x : < set_x : 'a; .. > -> 'a = # - : int list = [10; 5] # Characters 7-96: ......ref x_init = object val mutable x = x_init method get = x method set y = x <- y end.. Error: Some type variables are unbound in this type: class ref : 'a -> object val mutable x : 'a method get : 'a method set : 'a -> unit end The method get has type 'a where 'a is unbound # class ref : int -> object val mutable x : int method get : int method set : int -> unit end # class ['a] ref : 'a -> object val mutable x : 'a method get : 'a method set : 'a -> unit end # - : int = 2 # class ['a] circle : 'a -> object constraint 'a = < move : int -> unit; .. > val mutable center : 'a method center : 'a method move : int -> unit method set_center : 'a -> unit end # class ['a] circle : 'a -> object constraint 'a = #point val mutable center : 'a method center : 'a method move : int -> unit method set_center : 'a -> unit end # val c : point circle = val c' : < color : string; get_x : int; move : int -> unit > circle = # class ['a] color_circle : 'a -> object constraint 'a = #color_point val mutable center : 'a method center : 'a method color : string method move : int -> unit method set_center : 'a -> unit end # Characters 28-29: let c'' = new color_circle p;; ^ Error: This expression has type point but an expression was expected of type #color_point The first object type has no method color # val c'' : color_point color_circle = # - : color_point circle = # Characters 0-21: (c'' :> point circle);; (* Echec *) ^^^^^^^^^^^^^^^^^^^^^ Error: Type color_point color_circle = < center : color_point; color : string; move : int -> unit; set_center : color_point -> unit > is not a subtype of point circle = < center : point; move : int -> unit; set_center : point -> unit > Type point = point is not a subtype of color_point = color_point # Characters 9-55: fun x -> (x : color_point color_circle :> point circle);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type color_point color_circle = < center : color_point; color : string; move : int -> unit; set_center : color_point -> unit > is not a subtype of point circle = < center : point; move : int -> unit; set_center : point -> unit > Type point = point is not a subtype of color_point = color_point # class printable_point : int -> object val mutable x : int method get_x : int method move : int -> unit method print : unit end # val p : printable_point = # 7- : unit = () # Characters 85-102: inherit printable_point y as super ^^^^^^^^^^^^^^^^^ Warning 13: the following instance variables are overridden by the class printable_point : x The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) class printable_color_point : int -> string -> object val c : string val mutable x : int method color : string method get_x : int method move : int -> unit method print : unit end # val p' : printable_color_point = # (7, red)- : unit = () # class functional_point : int -> object ('a) val x : int method get_x : int method move : int -> 'a end # val p : functional_point = # - : int = 7 # - : int = 10 # - : int = 7 # - : #functional_point -> functional_point = # class virtual ['a] lst : unit -> object method virtual hd : 'a method iter : ('a -> unit) -> unit method map : ('a -> 'a) -> 'a lst method virtual null : bool method print : ('a -> unit) -> unit method virtual tl : 'a lst end and ['a] nil : unit -> object method hd : 'a method iter : ('a -> unit) -> unit method map : ('a -> 'a) -> 'a lst method null : bool method print : ('a -> unit) -> unit method tl : 'a lst end and ['a] cons : 'a -> 'a lst -> object val h : 'a val t : 'a lst method hd : 'a method iter : ('a -> unit) -> unit method map : ('a -> 'a) -> 'a lst method null : bool method print : ('a -> unit) -> unit method tl : 'a lst end # val l1 : int lst = # (3::10::[])- : unit = () # val l2 : int lst = # (4::11::[])- : unit = () # val map_list : ('a -> 'b) -> 'a lst -> 'b lst = # val p1 : printable_color_point lst = # ((3, red)::(10, red)::[])- : unit = () # class virtual comparable : unit -> object ('a) method virtual leq : 'a -> bool end # class int_comparable : int -> object ('a) val x : int method leq : 'a -> bool method x : int end # class int_comparable2 : int -> object ('a) val x : int val mutable x' : int method leq : 'a -> bool method set_x : int -> unit method x : int end # class ['a] sorted_list : unit -> object constraint 'a = #comparable val mutable l : 'a list method add : 'a -> unit method hd : 'a end # val l : _#comparable sorted_list = # val c : int_comparable = # - : unit = () # val c2 : int_comparable2 = # Characters 6-28: l#add (c2 :> int_comparable);; (* Echec : 'a comp2 n'est un sous-type *) ^^^^^^^^^^^^^^^^^^^^^^ Error: Type int_comparable2 = < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > is not a subtype of int_comparable = < leq : int_comparable -> bool; x : int > Type int_comparable = < leq : int_comparable -> bool; x : int > is not a subtype of int_comparable2 = < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > # - : unit = () # class int_comparable3 : int -> object val mutable x : int method leq : int_comparable -> bool method setx : int -> unit method x : int end # val c3 : int_comparable3 = # - : unit = () # Characters 25-27: (new sorted_list ())#add c3;; (* Error; strange message with -principal *) ^^ Error: This expression has type int_comparable3 = < leq : int_comparable -> bool; setx : int -> unit; x : int > but an expression was expected of type #comparable as 'a = < leq : 'a -> bool; .. > Type int_comparable = < leq : int_comparable -> bool; x : int > is not compatible with type 'a = < leq : 'a -> bool; .. > The first object type has no method setx # val sort : (#comparable as 'a) list -> 'a list = # Characters 13-66: List.map (fun c -> print_int c#x; print_string " ") l; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 10: this expression should have type unit. val pr : < x : int; .. > list -> unit = # val l : int_comparable list = [; ; ] # 5 2 4 - : unit = () # 2 4 5 - : unit = () # val l : int_comparable2 list = [; ] # 2 0 - : unit = () # 0 2 - : unit = () # val min : (#comparable as 'a) -> 'a -> 'a = # - : int = 7 # - : int = 3 # class ['a] link : 'a -> object ('b) val mutable next : 'b option val mutable x : 'a method append : 'b option -> unit method next : 'b option method set_next : 'b option -> unit method set_x : 'a -> unit method x : 'a end # class ['a] double_link : 'a -> object ('b) val mutable next : 'b option val mutable prev : 'b option val mutable x : 'a method append : 'b option -> unit method next : 'b option method prev : 'b option method set_next : 'b option -> unit method set_prev : 'b option -> unit method set_x : 'a -> unit method x : 'a end # val fold_right : ('a -> 'b -> 'b) -> 'a #link option -> 'b -> 'b = # class calculator : unit -> object ('a) val mutable acc : float val mutable arg : float val mutable equals : 'a -> float method acc : float method add : 'a method arg : float method enter : float -> 'a method equals : float method sub : 'a end # - : float = 5. # - : float = 1.5 # - : float = 15. # class calculator : unit -> object ('a) val mutable acc : float val mutable arg : float val mutable equals : 'a -> float method acc : float method add : 'a method arg : float method enter : float -> 'a method equals : float method sub : 'a end # - : float = 5. # - : float = 1.5 # - : float = 15. # class calculator : float -> float -> object val acc : float val arg : float method add : calculator method enter : float -> calculator method equals : float method sub : calculator end and calculator_add : float -> float -> object val acc : float val arg : float method add : calculator method enter : float -> calculator method equals : float method sub : calculator end and calculator_sub : float -> float -> object val acc : float val arg : float method add : calculator method enter : float -> calculator method equals : float method sub : calculator end # val calculator : calculator = # - : float = 5. # - : float = 1.5 # - : float = 15. # mingw-ocaml/ocaml/testsuite/tests/typing-objects/Makefile0000644000175000017500000000015212124403241023250 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-objects/Exemples.ml0000644000175000017500000001722012124403241023730 0ustar tootstoots class point x_init = object val mutable x = x_init method get_x = x method move d = x <- x + d end;; let p = new point 7;; p#get_x;; p#move 3;; p#get_x;; let q = Oo.copy p;; q#move 7; p#get_x, q#get_x;; class color_point x (c : string) = object inherit point x val c = c method color = c end;; let p' = new color_point 5 "red";; p'#get_x, p'#color;; let l = [p; (p' :> point)];; let get_x p = p#get_x;; let set_x p = p#set_x;; List.map get_x l;; class ref x_init = object val mutable x = x_init method get = x method set y = x <- y end;; class ref (x_init:int) = object val mutable x = x_init method get = x method set y = x <- y end;; class ['a] ref x_init = object val mutable x = (x_init : 'a) method get = x method set y = x <- y end;; let r = new ref 1 in r#set 2; (r#get);; class ['a] circle (c : 'a) = object val mutable center = c method center = center method set_center c = center <- c method move = (center#move : int -> unit) end;; class ['a] circle (c : 'a) = object constraint 'a = #point val mutable center = c method center = center method set_center c = center <- c method move = center#move end;; let (c, c') = (new circle p, new circle p');; class ['a] color_circle c = object constraint 'a = #color_point inherit ['a] circle c method color = center#color end;; let c'' = new color_circle p;; let c'' = new color_circle p';; (c'' :> color_point circle);; (c'' :> point circle);; (* Echec *) fun x -> (x : color_point color_circle :> point circle);; class printable_point y = object (s) inherit point y method print = print_int s#get_x end;; let p = new printable_point 7;; p#print;; class printable_color_point y c = object (self) inherit color_point y c inherit printable_point y as super method print = print_string "("; super#print; print_string ", "; print_string (self#color); print_string ")" end;; let p' = new printable_color_point 7 "red";; p'#print;; class functional_point y = object val x = y method get_x = x method move d = {< x = x + d >} end;; let p = new functional_point 7;; p#get_x;; (p#move 3)#get_x;; p#get_x;; fun x -> (x :> functional_point);; (*******************************************************************) class virtual ['a] lst () = object (self) method virtual null : bool method virtual hd : 'a method virtual tl : 'a lst method map f = (if self#null then new nil () else new cons (f self#hd) (self#tl#map f) : 'a lst) method iter (f : 'a -> unit) = if self#null then () else begin f self#hd; self#tl#iter f end method print (f : 'a -> unit) = print_string "("; self#iter (fun x -> f x; print_string "::"); print_string "[]"; print_string ")" end and ['a] nil () = object inherit ['a] lst () method null = true method hd = failwith "hd" method tl = failwith "tl" end and ['a] cons h t = object inherit ['a] lst () val h = h val t = t method null = false method hd = h method tl = t end;; let l1 = new cons 3 (new cons 10 (new nil ()));; l1#print print_int;; let l2 = l1#map (fun x -> x + 1);; l2#print print_int;; let rec map_list f (x:'a lst) = if x#null then new nil() else new cons (f x#hd) (map_list f x#tl);; let p1 = (map_list (fun x -> new printable_color_point x "red") l1);; p1#print (fun x -> x#print);; (*******************************************************************) class virtual comparable () = object (self : 'a) method virtual leq : 'a -> bool end;; class int_comparable (x : int) = object inherit comparable () val x = x method x = x method leq p = x <= p#x end;; class int_comparable2 xi = object inherit int_comparable xi val mutable x' = xi method set_x y = x' <- y end;; class ['a] sorted_list () = object constraint 'a = #comparable val mutable l = ([] : 'a list) method add x = let rec insert = function [] -> [x] | a::l as l' -> if a#leq x then a::(insert l) else x::l' in l <- insert l method hd = List.hd l end;; let l = new sorted_list ();; let c = new int_comparable 10;; l#add c;; let c2 = new int_comparable2 15;; l#add (c2 :> int_comparable);; (* Echec : 'a comp2 n'est un sous-type *) (new sorted_list ())#add c2;; class int_comparable3 (x : int) = object val mutable x = x method leq (y : int_comparable) = x < y#x method x = x method setx y = x <- y end;; let c3 = new int_comparable3 15;; l#add (c3 :> int_comparable);; (new sorted_list ())#add c3;; (* Error; strange message with -principal *) let sort (l : #comparable list) = Sort.list (fun x -> x#leq) l;; let pr l = List.map (fun c -> print_int c#x; print_string " ") l; print_newline ();; let l = [new int_comparable 5; (new int_comparable3 2 :> int_comparable); new int_comparable 4];; pr l;; pr (sort l);; let l = [new int_comparable2 2; new int_comparable2 0];; pr l;; pr (sort l);; let min (x : #comparable) y = if x#leq y then x else y;; (min (new int_comparable 7) (new int_comparable 11))#x;; (min (new int_comparable2 5) (new int_comparable2 3))#x;; (*******************************************************************) class ['a] link (x : 'a) = object (self : 'b) val mutable x = x val mutable next = (None : 'b option) method x = x method next = next method set_x y = x <- y method set_next l = next <- l method append l = match next with None -> self#set_next l | Some l' -> l'#append l end;; class ['a] double_link x = object (self) inherit ['a] link x val mutable prev = None method prev = prev method set_next l = next <- l; match l with Some l -> l#set_prev (Some self) | None -> () method set_prev l = prev <- l end;; let rec fold_right f (l : 'a #link option) accu = match l with None -> accu | Some l -> f l#x (fold_right f l#next accu);; (*******************************************************************) class calculator () = object (self) val mutable arg = 0. val mutable acc = 0. val mutable equals = function s -> s#arg method arg = arg method acc = acc method enter n = arg <- n; self method add = acc <- equals self; equals <- (function s -> s#acc +. s#arg); self method sub = acc <- equals self; equals <- (function s -> s#acc -. s#arg); self method equals = equals self end;; ((new calculator ())#enter 5.)#equals;; (((new calculator ())#enter 5.)#sub#enter 3.5)#equals;; ((new calculator ())#enter 5.)#add#add#equals;; class calculator () = object (self) val mutable arg = 0. val mutable acc = 0. val mutable equals = function s -> s#arg method arg = arg method acc = acc method enter n = arg <- n; self method add = {< acc = equals self; equals = function s -> s#acc +. s#arg >} method sub = {< acc = equals self; equals = function s -> s#acc -. s#arg >} method equals = equals self end;; ((new calculator ())#enter 5.)#equals;; (((new calculator ())#enter 5.)#sub#enter 3.5)#equals;; ((new calculator ())#enter 5.)#add#add#equals;; class calculator arg acc = object (self) val arg = arg val acc = acc method enter n = new calculator n acc method add = new calculator_add arg self#equals method sub = new calculator_sub arg self#equals method equals = arg end and calculator_add arg acc = object inherit calculator arg acc method enter n = new calculator_add n acc method equals = acc +. arg end and calculator_sub arg acc = object inherit calculator arg acc method enter n = new calculator_sub n acc method equals = acc -. arg end;; let calculator = new calculator 0. 0.;; (calculator#enter 5.)#equals;; ((calculator#enter 5.)#sub#enter 3.5)#equals;; (calculator#enter 5.)#add#add#equals;; mingw-ocaml/ocaml/testsuite/tests/typing-objects/Exemples.ml.reference0000644000175000017500000002416012124403241025666 0ustar tootstoots # class point : int -> object val mutable x : int method get_x : int method move : int -> unit end # val p : point = # - : int = 7 # - : unit = () # - : int = 10 # val q : point = # - : int * int = (10, 17) # class color_point : int -> string -> object val c : string val mutable x : int method color : string method get_x : int method move : int -> unit end # val p' : color_point = # - : int * string = (5, "red") # val l : point list = [; ] # val get_x : < get_x : 'a; .. > -> 'a = # val set_x : < set_x : 'a; .. > -> 'a = # - : int list = [10; 5] # Characters 7-96: ......ref x_init = object val mutable x = x_init method get = x method set y = x <- y end.. Error: Some type variables are unbound in this type: class ref : 'a -> object val mutable x : 'a method get : 'a method set : 'a -> unit end The method get has type 'a where 'a is unbound # class ref : int -> object val mutable x : int method get : int method set : int -> unit end # class ['a] ref : 'a -> object val mutable x : 'a method get : 'a method set : 'a -> unit end # - : int = 2 # class ['a] circle : 'a -> object constraint 'a = < move : int -> unit; .. > val mutable center : 'a method center : 'a method move : int -> unit method set_center : 'a -> unit end # class ['a] circle : 'a -> object constraint 'a = #point val mutable center : 'a method center : 'a method move : int -> unit method set_center : 'a -> unit end # val c : point circle = val c' : color_point circle = # class ['a] color_circle : 'a -> object constraint 'a = #color_point val mutable center : 'a method center : 'a method color : string method move : int -> unit method set_center : 'a -> unit end # Characters 28-29: let c'' = new color_circle p;; ^ Error: This expression has type point but an expression was expected of type #color_point The first object type has no method color # val c'' : color_point color_circle = # - : color_point circle = # Characters 0-21: (c'' :> point circle);; (* Echec *) ^^^^^^^^^^^^^^^^^^^^^ Error: Type color_point color_circle = < center : color_point; color : string; move : int -> unit; set_center : color_point -> unit > is not a subtype of point circle = < center : point; move : int -> unit; set_center : point -> unit > Type point = point is not a subtype of color_point = color_point # Characters 9-55: fun x -> (x : color_point color_circle :> point circle);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type color_point color_circle = < center : color_point; color : string; move : int -> unit; set_center : color_point -> unit > is not a subtype of point circle = < center : point; move : int -> unit; set_center : point -> unit > Type point = point is not a subtype of color_point = color_point # class printable_point : int -> object val mutable x : int method get_x : int method move : int -> unit method print : unit end # val p : printable_point = # 7- : unit = () # Characters 85-102: inherit printable_point y as super ^^^^^^^^^^^^^^^^^ Warning 13: the following instance variables are overridden by the class printable_point : x The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) class printable_color_point : int -> string -> object val c : string val mutable x : int method color : string method get_x : int method move : int -> unit method print : unit end # val p' : printable_color_point = # (7, red)- : unit = () # class functional_point : int -> object ('a) val x : int method get_x : int method move : int -> 'a end # val p : functional_point = # - : int = 7 # - : int = 10 # - : int = 7 # - : #functional_point -> functional_point = # class virtual ['a] lst : unit -> object method virtual hd : 'a method iter : ('a -> unit) -> unit method map : ('a -> 'a) -> 'a lst method virtual null : bool method print : ('a -> unit) -> unit method virtual tl : 'a lst end and ['a] nil : unit -> object method hd : 'a method iter : ('a -> unit) -> unit method map : ('a -> 'a) -> 'a lst method null : bool method print : ('a -> unit) -> unit method tl : 'a lst end and ['a] cons : 'a -> 'a lst -> object val h : 'a val t : 'a lst method hd : 'a method iter : ('a -> unit) -> unit method map : ('a -> 'a) -> 'a lst method null : bool method print : ('a -> unit) -> unit method tl : 'a lst end # val l1 : int lst = # (3::10::[])- : unit = () # val l2 : int lst = # (4::11::[])- : unit = () # val map_list : ('a -> 'b) -> 'a lst -> 'b lst = # val p1 : printable_color_point lst = # ((3, red)::(10, red)::[])- : unit = () # class virtual comparable : unit -> object ('a) method virtual leq : 'a -> bool end # class int_comparable : int -> object ('a) val x : int method leq : 'a -> bool method x : int end # class int_comparable2 : int -> object ('a) val x : int val mutable x' : int method leq : 'a -> bool method set_x : int -> unit method x : int end # class ['a] sorted_list : unit -> object constraint 'a = #comparable val mutable l : 'a list method add : 'a -> unit method hd : 'a end # val l : _#comparable sorted_list = # val c : int_comparable = # - : unit = () # val c2 : int_comparable2 = # Characters 6-28: l#add (c2 :> int_comparable);; (* Echec : 'a comp2 n'est un sous-type *) ^^^^^^^^^^^^^^^^^^^^^^ Error: Type int_comparable2 = < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > is not a subtype of int_comparable = < leq : int_comparable -> bool; x : int > Type int_comparable = < leq : int_comparable -> bool; x : int > is not a subtype of int_comparable2 = < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > # - : unit = () # class int_comparable3 : int -> object val mutable x : int method leq : int_comparable -> bool method setx : int -> unit method x : int end # val c3 : int_comparable3 = # - : unit = () # Characters 25-27: (new sorted_list ())#add c3;; (* Error; strange message with -principal *) ^^ Error: This expression has type int_comparable3 = < leq : int_comparable -> bool; setx : int -> unit; x : int > but an expression was expected of type #comparable as 'a = < leq : 'a -> bool; .. > Type int_comparable = < leq : int_comparable -> bool; x : int > is not compatible with type int_comparable3 = < leq : int_comparable -> bool; setx : int -> unit; x : int > The first object type has no method setx # val sort : (#comparable as 'a) list -> 'a list = # Characters 13-66: List.map (fun c -> print_int c#x; print_string " ") l; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 10: this expression should have type unit. val pr : < x : int; .. > list -> unit = # val l : int_comparable list = [; ; ] # 5 2 4 - : unit = () # 2 4 5 - : unit = () # val l : int_comparable2 list = [; ] # 2 0 - : unit = () # 0 2 - : unit = () # val min : (#comparable as 'a) -> 'a -> 'a = # - : int = 7 # - : int = 3 # class ['a] link : 'a -> object ('b) val mutable next : 'b option val mutable x : 'a method append : 'b option -> unit method next : 'b option method set_next : 'b option -> unit method set_x : 'a -> unit method x : 'a end # class ['a] double_link : 'a -> object ('b) val mutable next : 'b option val mutable prev : 'b option val mutable x : 'a method append : 'b option -> unit method next : 'b option method prev : 'b option method set_next : 'b option -> unit method set_prev : 'b option -> unit method set_x : 'a -> unit method x : 'a end # val fold_right : ('a -> 'b -> 'b) -> 'a #link option -> 'b -> 'b = # class calculator : unit -> object ('a) val mutable acc : float val mutable arg : float val mutable equals : 'a -> float method acc : float method add : 'a method arg : float method enter : float -> 'a method equals : float method sub : 'a end # - : float = 5. # - : float = 1.5 # - : float = 15. # class calculator : unit -> object ('a) val mutable acc : float val mutable arg : float val mutable equals : 'a -> float method acc : float method add : 'a method arg : float method enter : float -> 'a method equals : float method sub : 'a end # - : float = 5. # - : float = 1.5 # - : float = 15. # class calculator : float -> float -> object val acc : float val arg : float method add : calculator method enter : float -> calculator method equals : float method sub : calculator end and calculator_add : float -> float -> object val acc : float val arg : float method add : calculator method enter : float -> calculator method equals : float method sub : calculator end and calculator_sub : float -> float -> object val acc : float val arg : float method add : calculator method enter : float -> calculator method equals : float method sub : calculator end # val calculator : calculator = # - : float = 5. # - : float = 1.5 # - : float = 15. # mingw-ocaml/ocaml/testsuite/tests/typing-objects/pr5619_bad.ml.principal.reference0000644000175000017500000000117012124403241027634 0ustar tootstoots # class type foo_t = object method foo : string end type 'a name = Foo : foo_t name | Int : int name # class foo : object method cast : foo_t name -> < foo : string > method foo : string end # Characters 22-184: ..object(self) method foo = "foo" method cast: type a. a name -> a = function Foo -> (self :> foo_t) | _ -> ((raise Exit) : a) end Error: The class type object method cast : 'a name -> 'a method foo : string end is not matched by the class type foo_t The public method cast cannot be hidden # mingw-ocaml/ocaml/testsuite/tests/typing-objects/pr5619_bad.ml.reference0000644000175000017500000000117012124403241025654 0ustar tootstoots # class type foo_t = object method foo : string end type 'a name = Foo : foo_t name | Int : int name # class foo : object method cast : foo_t name -> < foo : string > method foo : string end # Characters 22-184: ..object(self) method foo = "foo" method cast: type a. a name -> a = function Foo -> (self :> foo_t) | _ -> ((raise Exit) : a) end Error: The class type object method cast : 'a name -> 'a method foo : string end is not matched by the class type foo_t The public method cast cannot be hidden # mingw-ocaml/ocaml/testsuite/tests/typing-objects/pr5619_bad.ml0000644000175000017500000000071712124403241023725 0ustar tootstootsclass type foo_t = object method foo: string end type 'a name = Foo: foo_t name | Int: int name ;; class foo = object(self) method foo = "foo" method cast = function Foo -> (self :> ) | _ -> raise Exit end ;; class foo: foo_t = object(self) method foo = "foo" method cast: type a. a name -> a = function Foo -> (self :> foo_t) | _ -> ((raise Exit) : a) end ;; mingw-ocaml/ocaml/testsuite/tests/typing-objects/Tests.ml0000644000175000017500000001727112124403241023256 0ustar tootstoots(* Le sous-typage est "syntaxique" *) fun (x : < x : int >) y z -> (y :> 'a), (x :> 'a), (z :> 'a);; (* - : (< x : int > as 'a) -> 'a -> 'a * 'a = *) (* Bizarrerie du typage des classes *) class ['a] c () = object method f = (new c (): int c) end and ['a] d () = object inherit ['a] c () end;; (* class ['a] c : unit -> object constraint 'a = int method f : 'a c end *) (* and ['a] d : unit -> object constraint 'a = int method f : 'a c end *) (* 'a libre dans classe d *) class ['a] c () = object method f (x : 'a) = () end and d () = object inherit ['a] c () end;; (* Instancie #c *) class virtual c () = object end and ['a] d () = object constraint 'a = #c method f (x : #c) = (x#x : int) end;; (* class virtual c : unit -> object end *) (* and ['a] d : *) (* unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end *) class ['a] c () = object constraint 'a = int end and ['a] d () = object constraint 'a = 'b #c end;; (* class ['a] c : unit -> object constraint 'a = int end and ['a] d : unit -> object constraint 'a = int #c end *) (* Self en parametre *) class ['a] c (x : 'a) = object (self : 'b) constraint 'a = 'b method f = self end;; new c;; (* class ['a] c : 'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end *) (* - : ('a c as 'a) -> 'a = *) class x () = object method virtual f : int end;; (* The class x should be virtual: its methods f is undefined *) (* Methode g en trop *) class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end and virtual d x = object (_ : 'a) inherit c x method g = true end;; (* Contrainte non respectee *) class ['a] c () = object constraint 'a = int method f x = (x : bool c) end;; (* Differentes contraintes *) class ['a, 'b] c () = object constraint 'a = int -> 'c constraint 'b = 'a * * 'c * 'd method f (x : 'a) (y : 'b) = () end;; class ['a, 'b] d () = object inherit ['a, 'b] c () end;; (* Contrainte non generique *) let x = ref [];; class ['a] c () = object method f = (x : 'a) end;; (* Abreviations *) type 'a c = and 'a d = ;; type 'a c = and 'a d = ;; type 'a c = and 'a d = ;; type 'a u = < x : 'a> and 'a t = 'a t u;; type 'a u = 'a and 'a t = 'a t u;; type 'a u = 'a;; type t = t u * t u;; type t = as 'a;; type 'a u = 'a;; fun (x : t) (y : 'a u) -> x = y;; fun (x : t) (y : 'a u) -> y = x;; (* - : t -> t u -> bool = *) (* Modules *) module M = struct class ['a, 'b] c (x: int) (y: 'b) = object constraint 'a = int -> bool val x : float list = [] val y = y method f (x : 'a) = () method g = y end end;; module M' = (M : sig class virtual ['a, 'b] c : int -> 'b -> object constraint 'a = int -> bool val x : float list val y : 'b method f : 'a -> unit method g : 'b end end);; class ['a, 'b] d () y = object inherit ['a, 'b] M.c 7 y end;; class ['a, 'b] e () y = object inherit ['a, 'b] M'.c 1 y end;; (new M.c 3 "a")#g;; (new d () 10)#g;; (new e () 7.1)#g;; open M;; (new c 5 true)#g;; (* #cl quand cl est fermee *) module M = struct class ['a] c () = object method f (x : 'a) = () end end;; module M' = (M : sig class ['a] c : unit -> object method f : 'a -> unit end end);; fun x -> (x :> 'a #M.c);; fun x -> (x :> 'a #M'.c);; class ['a] c (x : 'b #c) = object end;; class ['a] c (x : 'b #c) = object end;; (* Ordre de calcul *) class c () = object method f = 1 end and d () = object method f = 2 end;; class e () = object inherit c () inherit d () end;; (new e ())#f;; class c () = object val x = - true val y = -. () end;; class c () = object method f = 1 method g = 1 method h = 1 end;; class d () = object method h = 2 method i = 2 method j = 2 end;; class e () = object method f = 3 inherit c () method g = 3 method i = 3 inherit d () method j = 3 end;; let e = new e ();; e#f, e#g, e#h, e#i, e#j;; class c a = object val x = 1 val y = 1 val z = 1 val a = a end;; class d b = object val z = 2 val t = 2 val u = 2 val b = b end;; class e () = object val x = 3 inherit c 5 val y = 3 val t = 3 inherit d 7 val u = 3 method x = x method y = y method z = z method t = t method u = u method a = a method b = b end;; let e = new e ();; e#x, e#y, e#z, e#t, e#u, e#a, e#b;; class c (x : int) (y : int) = object val x = x val y = y method x = x method y = y end;; class d x y = object inherit c x y end;; let c = new c 1 2 in c#x, c#y;; let d = new d 1 2 in d#x, d#y;; (* Parametres n'apparaissant pas dans le type de l'objet *) class ['a] c (x : 'a) = object end;; new c;; (* Variables privees *) (* module type M = sig class c : unit -> object val x : int end class d : unit -> object inherit c val private x : int val x : bool end end;; class c (x : int) = val private mutable x = x method get = x method set y = x <- y end;; let c = new c 5;; c#get;; c#set 7; c#get;; class c () = val x = 1 val y = 1 method c = x end;; class d () = inherit c () val private x method d = x end;; class e () = val x = 2 val y = 2 inherit d () method x = x method y = y end;; let e = new e () in e#x, e#y, e#c, e#d;; *) (* Oubli de variables dans l'interface *) module M : sig class c : unit -> object method xc : int end end = struct class c () = object val x = 1 method xc = x end end;; class d () = object val x = 2 method xd = x inherit M.c () end;; let d = new d () in d#xc, d#xd;; class virtual ['a] matrix (sz, init : int * 'a) = object val m = Array.create_matrix sz sz init method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) end;; class c () = object method m = new c () end;; (new c ())#m;; module M = struct class c () = object method m = new c () end end;; (new M.c ())#m;; type uu = A of int | B of ( as 'a);; class virtual c () = object (_ : 'a) method virtual m : 'a end;; module S = (struct let f (x : #c) = x end : sig val f : (#c as 'a) -> 'a end);; module S = (struct let f (x : #c) = x end : sig val f : #c -> #c end);; module M = struct type t = int class t () = object end end;; fun x -> (x :> < m : 'a -> 'a > as 'a);; fun x -> (x : int -> bool :> 'a -> 'a);; fun x -> (x : int -> bool :> int -> int);; fun x -> (x : < > :> < .. >);; fun x -> (x : < .. > :> < >);; let x = ref [];; module F(X : sig end) = struct type t = int let _ = (x : < m : t> list ref) end;; x;; type 'a t;; fun (x : 'a t as 'a) -> ();; fun (x : 'a t) -> (x : 'a); ();; type 'a t = < x : 'a >;; fun (x : 'a t as 'a) -> ();; fun (x : 'a t) -> (x : 'a); ();; class ['a] c () = object constraint 'a = < .. > -> unit method m = (fun x -> () : 'a) end;; class ['a] c () = object constraint 'a = unit -> < .. > method m (f : 'a) = f () end;; class c () = object (self) method private m = 1 method n = self#m end;; class d () = object (self) inherit c () method o = self#m end;; let x = new d () in x#n, x#o;; class c () = object method virtual m : int method private m = 1 end;; (* Marshaling (cf. PR#5436) *) Oo.id (object end);; Oo.id (object end);; Oo.id (object end);; let o = object end in let s = Marshal.to_string o [] in let o' : < > = Marshal.from_string s 0 in let o'' : < > = Marshal.from_string s 0 in (Oo.id o, Oo.id o', Oo.id o'');; let o = object val x = 33 method m = x end in let s = Marshal.to_string o [Marshal.Closures] in let o' : = Marshal.from_string s 0 in let o'' : = Marshal.from_string s 0 in (Oo.id o, Oo.id o', Oo.id o'', o#m, o'#m);; let o = object val x = 33 val y = 44 method m = x end in let s = Marshal.to_string o [Marshal.Closures] in let o' : = Marshal.from_string s 0 in let o'' : = Marshal.from_string s 0 in (Oo.id o, Oo.id o', Oo.id o'', o#m, o'#m);; mingw-ocaml/ocaml/testsuite/tests/typing-objects-bugs/0000755000175000017500000000000012124403241022550 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-objects-bugs/woodyatt_ok.ml0000644000175000017500000000044412124403241025447 0ustar tootstoots(* test.ml *) class alfa = object(_:'self) method x: 'a. ('a, out_channel, unit) format -> 'a = Printf.printf end class bravo a = object val y = (a :> alfa) initializer y#x "bravo initialized" end class charlie a = object inherit bravo a initializer y#x "charlie initialized" end mingw-ocaml/ocaml/testsuite/tests/typing-objects-bugs/Makefile0000644000175000017500000000014712124403241024212 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.okbad include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-objects-bugs/pr4435_bad.ml0000644000175000017500000000043512124403241024653 0ustar tootstoots(* Two v's in the same class *) class c v = object initializer print_endline v val v = 42 end;; new c "42";; (* Two hidden v's in the same class! *) class c (v : int) = object method v0 = v inherit ((fun v -> object method v : string = v end) "42") end;; (new c 42)#v0;; mingw-ocaml/ocaml/testsuite/tests/typing-objects-bugs/pr5156_ok.ml0000644000175000017500000000054412124403241024540 0ustar tootstootsclass type t = object end;; class ['a] o1 = object (self : #t as 'a) end;; type 'a obj = ( < .. > as 'a);; class type ['a] o2 = object ('a obj) end;; class ['a] o3 = object (self : 'a obj) end;; class ['a] o4 = object (self) method m = (self : 'a obj) end;; (* let o = object (self : 'a obj) end;; let o = object (self) method m = (self : 'a obj) end;; *) mingw-ocaml/ocaml/testsuite/tests/typing-objects-bugs/pr4824_ok.ml0000644000175000017500000000020412124403241024532 0ustar tootstootsmodule M : sig class x : int -> object method m : int end end = struct class x _ = object method m = 42 end end;; mingw-ocaml/ocaml/testsuite/tests/typing-objects-bugs/pr4766_ok.ml0000644000175000017500000000022012124403241024535 0ustar tootstootsclass virtual ['a] c = object (s : 'a) method virtual m : 'b end let o = object (s :'a) inherit ['a] c method m = 42 end mingw-ocaml/ocaml/testsuite/tests/typing-objects-bugs/pr4018_bad.ml0000644000175000017500000000204212124403241024644 0ustar tootstoots class virtual ['subject, 'event] observer = object method virtual notify : 'subject -> 'event -> unit end class ['event] subject = object (self : 'subject) val mutable observers = ([]: (('subject, 'event) observer) list) method add_observer obs = observers <- (obs :: observers) method notify_observers (e : 'event) = List.iter (fun x -> x#notify self e) observers end type id = int class entity (id : id) = object val ent_destroy_subject = new subject method destroy_subject : (id) subject = ent_destroy_subject method entity_id = id end class ['entity] entity_container = object (self) inherit ['entity, id] observer as observer method add_entity (e : 'entity) = e#destroy_subject#add_observer (self) method notify _ id = () end let f (x : entity entity_container) = () (* class world = object val entity_container : entity entity_container = new entity_container method add_entity (s : entity) = entity_container#add_entity (s :> entity) end *) mingw-ocaml/ocaml/testsuite/tests/typing-objects-bugs/pr3968_bad.ml0000644000175000017500000000052012124403241024660 0ustar tootstootstype expr = [ `Abs of string * expr | `App of expr * expr ] class type exp = object method eval : (string, exp) Hashtbl.t -> expr end;; class app e1 e2 : exp = object val l = e1 val r = e2 method eval env = match l with | `Abs(var,body) -> Hashtbl.add env var r; body | _ -> `App(l,r); end mingw-ocaml/ocaml/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml0000644000175000017500000001140512124403241026026 0ustar tootstoots(* The module begins *) exception Out_of_range class type ['a] cursor = object method get : 'a method incr : unit -> unit method is_last : bool end class type ['a] storage = object ('self) method first : 'a cursor method len : int method nth : int -> 'a cursor method copy : 'self method sub : int -> int -> 'self method concat : 'a storage -> 'self method fold : 'b. ('a -> int -> 'b -> 'b) -> 'b -> 'b method iter : ('a -> unit) -> unit end class virtual ['a, 'cursor] storage_base = object (self : 'self) constraint 'cursor = 'a #cursor method virtual first : 'cursor method virtual len : int method virtual copy : 'self method virtual sub : int -> int -> 'self method virtual concat : 'a storage -> 'self method fold : 'b. ('a -> int -> 'b -> 'b) -> 'b -> 'b = fun f a0 -> let cur = self#first in let rec loop count a = if count >= self#len then a else let a' = f cur#get count a in cur#incr (); loop (count + 1) a' in loop 0 a0 method iter proc = let p = self#first in for i = 0 to self#len - 2 do proc p#get; p#incr () done; if self#len > 0 then proc p#get else () end class type ['a] obj_input_channel = object method get : unit -> 'a method close : unit -> unit end class type ['a] obj_output_channel = object method put : 'a -> unit method flush : unit -> unit method close : unit -> unit end module UChar = struct type t = int let highest_bit = 1 lsl 30 let lower_bits = highest_bit - 1 let char_of c = try Char.chr c with Invalid_argument _ -> raise Out_of_range let of_char = Char.code let code c = if c lsr 30 = 0 then c else raise Out_of_range let chr n = if n >= 0 && (n lsr 31 = 0) then n else raise Out_of_range let uint_code c = c let chr_of_uint n = n end type uchar = UChar.t let int_of_uchar u = UChar.uint_code u let uchar_of_int n = UChar.chr_of_uint n class type ucursor = [uchar] cursor class type ustorage = [uchar] storage class virtual ['ucursor] ustorage_base = [uchar, 'ucursor] storage_base module UText = struct (* the internal representation is UCS4 with big endian*) (* The most significant digit appears first. *) let get_buf s i = let n = Char.code s.[i] in let n = (n lsl 8) lor (Char.code s.[i + 1]) in let n = (n lsl 8) lor (Char.code s.[i + 2]) in let n = (n lsl 8) lor (Char.code s.[i + 3]) in UChar.chr_of_uint n let set_buf s i u = let n = UChar.uint_code u in begin s.[i] <- Char.chr (n lsr 24); s.[i + 1] <- Char.chr (n lsr 16 lor 0xff); s.[i + 2] <- Char.chr (n lsr 8 lor 0xff); s.[i + 3] <- Char.chr (n lor 0xff); end let init_buf buf pos init = if init#len = 0 then () else let cur = init#first in for i = 0 to init#len - 2 do set_buf buf (pos + i lsl 2) (cur#get); cur#incr () done; set_buf buf (pos + (init#len - 1) lsl 2) (cur#get) let make_buf init = let s = String.create (init#len lsl 2) in init_buf s 0 init; s class text_raw buf = object (self : 'self) inherit [cursor] ustorage_base val contents = buf method first = new cursor (self :> text_raw) 0 method len = (String.length contents) / 4 method get i = get_buf contents (4 * i) method nth i = new cursor (self :> text_raw) i method copy = {< contents = String.copy contents >} method sub pos len = {< contents = String.sub contents (pos * 4) (len * 4) >} method concat (text : ustorage) = let buf = String.create (String.length contents + 4 * text#len) in String.blit contents 0 buf 0 (String.length contents); init_buf buf (String.length contents) text; {< contents = buf >} end and cursor text i = object val contents = text val mutable pos = i method get = contents#get pos method incr () = pos <- pos + 1 method is_last = (pos + 1 >= contents#len) end class string_raw buf = object inherit text_raw buf method set i u = set_buf contents (4 * i) u end class text init = text_raw (make_buf init) class string init = string_raw (make_buf init) let of_string s = let buf = String.make (4 * String.length s) '\000' in for i = 0 to String.length s - 1 do buf.[4 * i] <- s.[i] done; new text_raw buf let make len u = let s = String.create (4 * len) in for i = 0 to len - 1 do set_buf s (4 * i) u done; new string_raw s let create len = make len (UChar.chr 0) let copy s = s#copy let sub s start len = s#sub start len let fill s start len u = for i = start to start + len - 1 do s#set i u done let blit src srcoff dst dstoff len = for i = 0 to len - 1 do let u = src#get (srcoff + i) in dst#set (dstoff + i) u done let concat s1 s2 = s1#concat (s2 (* : #ustorage *) :> uchar storage) let iter proc s = s#iter proc end mingw-ocaml/ocaml/testsuite/tests/typing-objects-bugs/pr4824a_bad.ml0000644000175000017500000000030212124403241025007 0ustar tootstootsmodule M : sig class c : 'a -> object val x : 'b end end = struct class c x = object val x = x end end class c (x : int) = object inherit M.c x method x : bool = x end let r = (new c 2)#x;; mingw-ocaml/ocaml/testsuite/tests/asmcomp/0000755000175000017500000000000012124403241020310 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/asmcomp/tagged-integr.cmm0000644000175000017500000000324012124403241023526 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) ("res_square": skip 8) ("h": skip 8) ("x": skip 8) ("s": skip 8) ("res_integr": skip 8) (function "square" (x: addr) (let r "res_square" (store float r ( *f (load float x) (load float x))) r)) (function "integr" (f: addr low: addr high: addr n: int) (let (h "h" x "x" s "s" i n) (store float h (/f (-f (load float high) (load float low)) (floatofint n))) (store float x (load float low)) (store float s 0.0) (while (> i 0) (store float s (+f (load float s) (load float (app f x addr)))) (store float x (+f (load float x) (load float h))) (assign i (- i 1))) (store float "res_integr" ( *f (load float s) (load float h))) "res_integr")) ("low": skip 8) ("hi": skip 8) (function "test" (n: int) (store float "low" 0.0) (store float "hi" 1.0) (load float (app "integr" "square" "low" "hi" n addr))) mingw-ocaml/ocaml/testsuite/tests/asmcomp/.ignore0000644000175000017500000000010012124403241021563 0ustar tootstootscodegen parsecmm.ml parsecmm.mli lexcmm.ml *.s *.out *.out.dSYM mingw-ocaml/ocaml/testsuite/tests/asmcomp/arith.cmm0000644000175000017500000001577112124403241022130 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Regression test for arithmetic instructions *) (function "testarith" () (let r "R" (let d "D" (let x (load int "X") (let y (load int "Y") (let f (load float "F") (let g (load float "G") (addraset r 0 0) (addraset r 1 1) (addraset r 2 -1) (addraset r 3 256) (addraset r 4 65536) (addraset r 5 16777216) (addraset r 6 -256) (addraset r 7 -65536) (addraset r 8 -16777216) (addraset r 9 (+ x y)) (addraset r 10 (+ x 1)) (addraset r 11 (+ x -1)) (addraset r 12 (+a "R" 8)) (addraset r 13 (+a "R" y)) (addraset r 14 (- x y)) (addraset r 15 (- x 1)) (addraset r 16 (- x -1)) (addraset r 17 (-a "R" 8)) (addraset r 18 (-a "R" y)) (addraset r 19 ( * x 2)) (addraset r 20 ( * 2 x)) (addraset r 21 ( * x 16)) (addraset r 22 ( * 16 x)) (addraset r 23 ( * x 12345)) (addraset r 24 ( * 12345 x)) (addraset r 25 ( * x y)) (addraset r 26 (/ x 2)) (addraset r 27 (/ x 16)) (addraset r 28 (/ x 7)) (addraset r 29 (if (!= y 0) (/ x y) 0)) (addraset r 30 (mod x 2)) (addraset r 31 (mod x 16)) (addraset r 32 (if (!= y 0) (mod x y) 0)) (addraset r 33 (and x y)) (addraset r 34 (and x 3)) (addraset r 35 (and 3 x)) (addraset r 36 (or x y)) (addraset r 37 (or x 3)) (addraset r 38 (or 3 x)) (addraset r 39 (xor x y)) (addraset r 40 (xor x 3)) (addraset r 41 (xor 3 x)) (addraset r 42 (<< x y)) (addraset r 43 (<< x 1)) (addraset r 44 (<< x 8)) (addraset r 45 (>>u x y)) (addraset r 46 (>>u x 1)) (addraset r 47 (>>u x 8)) (addraset r 48 (>>s x y)) (addraset r 49 (>>s x 1)) (addraset r 50 (>>s x 8)) (addraset r 51 (== x y)) (addraset r 52 (!= x y)) (addraset r 53 (< x y)) (addraset r 54 (> x y)) (addraset r 55 (<= x y)) (addraset r 56 (>= x y)) (addraset r 57 (== x 1)) (addraset r 58 (!= x 1)) (addraset r 59 (< x 1)) (addraset r 60 (> x 1)) (addraset r 61 (<= x 1)) (addraset r 62 (>= x 1)) (addraset r 63 (==a x y)) (addraset r 64 (!=a x y)) (addraset r 65 (a x y)) (addraset r 67 (<=a x y)) (addraset r 68 (>=a x y)) (addraset r 69 (==a x 1)) (addraset r 70 (!=a x 1)) (addraset r 71 (a x 1)) (addraset r 73 (<=a x 1)) (addraset r 74 (>=a x 1)) (addraset r 75 (+ x (<< y 1))) (addraset r 76 (+ x (<< y 2))) (addraset r 77 (+ x (<< y 3))) (addraset r 78 (- x (<< y 1))) (addraset r 79 (- x (<< y 2))) (addraset r 80 (- x (<< y 3))) (floataset d 0 0.0) (floataset d 1 1.0) (floataset d 2 -1.0) (floataset d 3 (+f f g)) (floataset d 4 (-f f g)) (floataset d 5 ( *f f g)) (floataset d 6 (/f f g)) (floataset d 7 (+f f (+f g 1.0))) (floataset d 8 (-f f (+f g 1.0))) (floataset d 9 ( *f f (+f g 1.0))) (floataset d 10 (/f f (+f g 1.0))) (floataset d 11 (+f (+f f 1.0) g)) (floataset d 12 (-f (+f f 1.0) g)) (floataset d 13 ( *f (+f f 1.0) g)) (floataset d 14 (/f (+f f 1.0) g)) (floataset d 15 (+f (+f f 1.0) (+f g 1.0))) (floataset d 16 (-f (+f f 1.0) (+f g 1.0))) (floataset d 17 ( *f (+f f 1.0) (+f g 1.0))) (floataset d 18 (/f (+f f 1.0) (+f g 1.0))) (addraset r 81 (==f f g)) (addraset r 82 (!=f f g)) (addraset r 83 (f f g)) (addraset r 85 (<=f f g)) (addraset r 86 (>=f f g)) (floataset d 19 (floatofint x)) (addraset r 87 (intoffloat f)) (if (and (>= x 0) (< x y)) (seq (checkbound y x) (addraset r 88 1)) (addraset r 88 0)) (if (< 0 y) (seq (checkbound y 0) (addraset r 89 1)) (addraset r 89 0)) (if (< 5 y) (seq (checkbound y 5) (addraset r 90 1)) (addraset r 90 0)) (addraset r 91 (let res 1 (if (==f f g) [] (assign res 0)) res)) (addraset r 92 (let res 1 (if (!=f f g) [] (assign res 0)) res)) (addraset r 93 (let res 1 (if (f f g) [] (assign res 0)) res)) (addraset r 95 (let res 1 (if (<=f f g) [] (assign res 0)) res)) (addraset r 96 (let res 1 (if (>=f f g) [] (assign res 0)) res)) (addraset r 97 (==f (+f f 1.0) (+f g 1.0))) (addraset r 98 (!=f (+f f 1.0) (+f g 1.0))) (addraset r 99 (f (+f f 1.0) (+f g 1.0))) (addraset r 101 (<=f (+f f 1.0) (+f g 1.0))) (addraset r 102 (>=f (+f f 1.0) (+f g 1.0))) (addraset r 103 (==f f (+f g 1.0))) (addraset r 104 (!=f f (+f g 1.0))) (addraset r 105 (f f (+f g 1.0))) (addraset r 107 (<=f f (+f g 1.0))) (addraset r 108 (>=f f (+f g 1.0))) (addraset r 109 (==f (+f f 1.0) g)) (addraset r 110 (!=f (+f f 1.0) g)) (addraset r 111 (f (+f f 1.0) g)) (addraset r 113 (<=f (+f f 1.0) g)) (addraset r 114 (>=f (+f f 1.0) g)) (floataset d 20 (+f (floatofint x) 1.0)) (addraset r 115 (intoffloat (+f f 1.0))) (floataset d 21 (+f f (load float "G"))) (floataset d 22 (+f (load float "G") f)) (floataset d 23 (-f f (load float "G"))) (floataset d 24 (-f (load float "G") f)) (floataset d 25 ( *f f (load float "G"))) (floataset d 26 ( *f (load float "G") f)) (floataset d 27 (/f f (load float "G"))) (floataset d 28 (/f (load float "G") f)) (floataset d 29 (+f ( *f f 2.0) (load float "G"))) (floataset d 30 (+f (load float "G") ( *f f 2.0))) (floataset d 31 (-f ( *f f 2.0) (load float "G"))) (floataset d 32 (-f (load float "G") ( *f f 2.0))) (floataset d 33 ( *f ( +f f 2.0) (load float "G"))) (floataset d 34 ( *f (load float "G") ( +f f 2.0))) (floataset d 35 (/f ( *f f 2.0) (load float "G"))) (floataset d 36 (/f (load float "G") ( *f f 2.0))) (floataset d 37 (-f f)) (floataset d 38 (absf f)) ))))))) mingw-ocaml/ocaml/testsuite/tests/asmcomp/parsecmm.mly0000644000175000017500000002273312124403241022651 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* $Id$ */ /* A simple parser for C-- */ %{ open Cmm open Parsecmmaux let rec make_letdef def body = match def with [] -> body | (id, def) :: rem -> unbind_ident id; Clet(id, def, make_letdef rem body) let make_switch n selector caselist = let index = Array.create n 0 in let casev = Array.of_list caselist in let actv = Array.create (Array.length casev) (Cexit(0,[])) in for i = 0 to Array.length casev - 1 do let (posl, e) = casev.(i) in List.iter (fun pos -> index.(pos) <- i) posl; actv.(i) <- e done; Cswitch(selector, index, actv) let access_array base numelt size = match numelt with Cconst_int 0 -> base | Cconst_int n -> Cop(Cadda, [base; Cconst_int(n * size)]) | _ -> Cop(Cadda, [base; Cop(Clsl, [numelt; Cconst_int(Misc.log2 size)])]) %} %token ABSF %token ADDA %token ADDF %token ADDI %token ADDR %token ALIGN %token ALLOC %token AND %token APPLY %token ASR %token ASSIGN %token BYTE %token CASE %token CATCH %token CHECKBOUND %token COLON %token DIVF %token DIVI %token EOF %token EQA %token EQF %token EQI %token EXIT %token EXTCALL %token FLOAT %token FLOAT32 %token FLOAT64 %token FLOATCONST %token FLOATOFINT %token FUNCTION %token GEA %token GEF %token GEI %token GTA %token GTF %token GTI %token HALF %token IDENT %token IF %token INT %token INT32 %token INTCONST %token INTOFFLOAT %token KSTRING %token LBRACKET %token LEA %token LEF %token LEI %token LET %token LOAD %token LPAREN %token LSL %token LSR %token LTA %token LTF %token LTI %token MODI %token MULF %token MULI %token NEA %token NEF %token NEI %token OR %token POINTER %token PROJ %token RAISE %token RBRACKET %token RPAREN %token SEQ %token SIGNED %token SKIP %token STAR %token STORE %token STRING %token SUBA %token SUBF %token SUBI %token SWITCH %token TRY %token UNIT %token UNSIGNED %token WHILE %token WITH %token XOR %token ADDRAREF %token INTAREF %token FLOATAREF %token ADDRASET %token INTASET %token FLOATASET %start phrase %type phrase %% phrase: fundecl { Cfunction $1 } | datadecl { Cdata $1 } | EOF { raise End_of_file } ; fundecl: LPAREN FUNCTION STRING LPAREN params RPAREN sequence RPAREN { List.iter (fun (id, ty) -> unbind_ident id) $5; {fun_name = $3; fun_args = $5; fun_body = $7; fun_fast = true; fun_dbg = Debuginfo.none} } ; params: oneparam params { $1 :: $2 } | /**/ { [] } ; oneparam: IDENT COLON machtype { (bind_ident $1, $3) } ; machtype: UNIT { [||] } | componentlist { Array.of_list(List.rev $1) } ; component: ADDR { Addr } | INT { Int } | FLOAT { Float } ; componentlist: component { [$1] } | componentlist STAR component { $3 :: $1 } ; expr: INTCONST { Cconst_int $1 } | FLOATCONST { Cconst_float $1 } | STRING { Cconst_symbol $1 } | POINTER { Cconst_pointer $1 } | IDENT { Cvar(find_ident $1) } | LBRACKET RBRACKET { Ctuple [] } | LPAREN LET letdef sequence RPAREN { make_letdef $3 $4 } | LPAREN ASSIGN IDENT expr RPAREN { Cassign(find_ident $3, $4) } | LPAREN APPLY expr exprlist machtype RPAREN { Cop(Capply($5, Debuginfo.none), $3 :: List.rev $4) } | LPAREN EXTCALL STRING exprlist machtype RPAREN { Cop(Cextcall($3, $5, false, Debuginfo.none), List.rev $4) } | LPAREN SUBF expr RPAREN { Cop(Cnegf, [$3]) } | LPAREN SUBF expr expr RPAREN { Cop(Csubf, [$3; $4]) } | LPAREN unaryop expr RPAREN { Cop($2, [$3]) } | LPAREN binaryop expr expr RPAREN { Cop($2, [$3; $4]) } | LPAREN SEQ sequence RPAREN { $3 } | LPAREN IF expr expr expr RPAREN { Cifthenelse($3, $4, $5) } | LPAREN SWITCH INTCONST expr caselist RPAREN { make_switch $3 $4 $5 } | LPAREN WHILE expr sequence RPAREN { let body = match $3 with Cconst_int x when x <> 0 -> $4 | _ -> Cifthenelse($3, $4, (Cexit(0,[]))) in Ccatch(0, [], Cloop body, Ctuple []) } | LPAREN CATCH sequence WITH sequence RPAREN { Ccatch(0, [], $3, $5) } | EXIT { Cexit(0,[]) } | LPAREN TRY sequence WITH bind_ident sequence RPAREN { unbind_ident $5; Ctrywith($3, $5, $6) } | LPAREN ADDRAREF expr expr RPAREN { Cop(Cload Word, [access_array $3 $4 Arch.size_addr]) } | LPAREN INTAREF expr expr RPAREN { Cop(Cload Word, [access_array $3 $4 Arch.size_int]) } | LPAREN FLOATAREF expr expr RPAREN { Cop(Cload Double_u, [access_array $3 $4 Arch.size_float]) } | LPAREN ADDRASET expr expr expr RPAREN { Cop(Cstore Word, [access_array $3 $4 Arch.size_addr; $5]) } | LPAREN INTASET expr expr expr RPAREN { Cop(Cstore Word, [access_array $3 $4 Arch.size_int; $5]) } | LPAREN FLOATASET expr expr expr RPAREN { Cop(Cstore Double_u, [access_array $3 $4 Arch.size_float; $5]) } ; exprlist: exprlist expr { $2 :: $1 } | /**/ { [] } ; letdef: oneletdef { [$1] } | LPAREN letdefmult RPAREN { $2 } ; letdefmult: /**/ { [] } | oneletdef letdefmult { $1 :: $2 } ; oneletdef: IDENT expr { (bind_ident $1, $2) } ; chunk: UNSIGNED BYTE { Byte_unsigned } | SIGNED BYTE { Byte_signed } | UNSIGNED HALF { Sixteen_unsigned } | SIGNED HALF { Sixteen_signed } | UNSIGNED INT32 { Thirtytwo_unsigned } | SIGNED INT32 { Thirtytwo_signed } | INT { Word } | ADDR { Word } | FLOAT32 { Single } | FLOAT64 { Double } | FLOAT { Double_u } ; unaryop: LOAD chunk { Cload $2 } | ALLOC { Calloc } | FLOATOFINT { Cfloatofint } | INTOFFLOAT { Cintoffloat } | RAISE { Craise Debuginfo.none } | ABSF { Cabsf } ; binaryop: STORE chunk { Cstore $2 } | ADDI { Caddi } | SUBI { Csubi } | MULI { Cmuli } | DIVI { Cdivi } | MODI { Cmodi } | AND { Cand } | OR { Cor } | XOR { Cxor } | LSL { Clsl } | LSR { Clsr } | ASR { Casr } | EQI { Ccmpi Ceq } | NEI { Ccmpi Cne } | LTI { Ccmpi Clt } | LEI { Ccmpi Cle } | GTI { Ccmpi Cgt } | GEI { Ccmpi Cge } | ADDA { Cadda } | SUBA { Csuba } | EQA { Ccmpa Ceq } | NEA { Ccmpa Cne } | LTA { Ccmpa Clt } | LEA { Ccmpa Cle } | GTA { Ccmpa Cgt } | GEA { Ccmpa Cge } | ADDF { Caddf } | MULF { Cmulf } | DIVF { Cdivf } | EQF { Ccmpf Ceq } | NEF { Ccmpf Cne } | LTF { Ccmpf Clt } | LEF { Ccmpf Cle } | GTF { Ccmpf Cgt } | GEF { Ccmpf Cge } | CHECKBOUND { Ccheckbound Debuginfo.none } ; sequence: expr sequence { Csequence($1, $2) } | expr { $1 } ; caselist: onecase sequence caselist { ($1, $2) :: $3 } | /**/ { [] } ; onecase: CASE INTCONST COLON onecase { $2 :: $4 } | CASE INTCONST COLON { [$2] } ; bind_ident: IDENT { bind_ident $1 } ; datadecl: LPAREN datalist RPAREN { List.rev $2 } ; datalist: datalist dataitem { $2 :: $1 } | /**/ { [] } ; dataitem: STRING COLON { Cdefine_symbol $1 } | INTCONST COLON { Cdefine_label $1 } | BYTE INTCONST { Cint8 $2 } | HALF INTCONST { Cint16 $2 } | INT INTCONST { Cint(Nativeint.of_int $2) } | FLOAT FLOATCONST { Cdouble $2 } | ADDR STRING { Csymbol_address $2 } | ADDR INTCONST { Clabel_address $2 } | KSTRING STRING { Cstring $2 } | SKIP INTCONST { Cskip $2 } | ALIGN INTCONST { Calign $2 } ; mingw-ocaml/ocaml/testsuite/tests/asmcomp/sparc.S0000644000175000017500000000260012124403241021542 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* $Id$ */ #if defined(SYS_solaris) || defined(SYS_elf) #define Call_gen_code _call_gen_code #define Caml_c_call _caml_c_call #else #define Call_gen_code call_gen_code #define Caml_c_call caml_c_call #endif .global Call_gen_code Call_gen_code: save %sp, -96, %sp mov %i0, %l0 mov %i1, %i0 mov %i2, %i1 mov %i3, %i2 mov %i4, %i3 mov %i5, %i4 call %l0 nop mov %o0, %i0 ret restore .global Caml_c_call Caml_c_call: jmp %g4 nop mingw-ocaml/ocaml/testsuite/tests/asmcomp/power-elf.S0000644000175000017500000000760312124403241022342 0ustar tootstoots/*********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /*********************************************************************/ /* $Id$ */ /* Save and restore all callee-save registers */ /* GPR 14 at sp+16 ... GPR 31 at sp+84 FPR 14 at sp+92 ... FPR 31 at sp+228 */ #define Save_callee_save \ addic 11, 1, 16-4; \ stwu 14, 4(11); \ stwu 15, 4(11); \ stwu 16, 4(11); \ stwu 17, 4(11); \ stwu 18, 4(11); \ stwu 19, 4(11); \ stwu 20, 4(11); \ stwu 21, 4(11); \ stwu 22, 4(11); \ stwu 23, 4(11); \ stwu 24, 4(11); \ stwu 25, 4(11); \ stwu 26, 4(11); \ stwu 27, 4(11); \ stwu 28, 4(11); \ stwu 29, 4(11); \ stwu 30, 4(11); \ stwu 31, 4(11); \ stfdu 14, 8(11); \ stfdu 15, 8(11); \ stfdu 16, 8(11); \ stfdu 17, 8(11); \ stfdu 18, 8(11); \ stfdu 19, 8(11); \ stfdu 20, 8(11); \ stfdu 21, 8(11); \ stfdu 22, 8(11); \ stfdu 23, 8(11); \ stfdu 24, 8(11); \ stfdu 25, 8(11); \ stfdu 26, 8(11); \ stfdu 27, 8(11); \ stfdu 28, 8(11); \ stfdu 29, 8(11); \ stfdu 30, 8(11); \ stfdu 31, 8(11) #define Restore_callee_save \ addic 11, 1, 16-4; \ lwzu 14, 4(11); \ lwzu 15, 4(11); \ lwzu 16, 4(11); \ lwzu 17, 4(11); \ lwzu 18, 4(11); \ lwzu 19, 4(11); \ lwzu 20, 4(11); \ lwzu 21, 4(11); \ lwzu 22, 4(11); \ lwzu 23, 4(11); \ lwzu 24, 4(11); \ lwzu 25, 4(11); \ lwzu 26, 4(11); \ lwzu 27, 4(11); \ lwzu 28, 4(11); \ lwzu 29, 4(11); \ lwzu 30, 4(11); \ lwzu 31, 4(11); \ lfdu 14, 8(11); \ lfdu 15, 8(11); \ lfdu 16, 8(11); \ lfdu 17, 8(11); \ lfdu 18, 8(11); \ lfdu 19, 8(11); \ lfdu 20, 8(11); \ lfdu 21, 8(11); \ lfdu 22, 8(11); \ lfdu 23, 8(11); \ lfdu 24, 8(11); \ lfdu 25, 8(11); \ lfdu 26, 8(11); \ lfdu 27, 8(11); \ lfdu 28, 8(11); \ lfdu 29, 8(11); \ lfdu 30, 8(11); \ lfdu 31, 8(11) .section ".text" .globl call_gen_code .type call_gen_code, @function call_gen_code: /* Allocate and link stack frame */ stwu 1, -256(1) /* Save return address */ mflr 0 stw 0, 256+4(1) /* Save all callee-save registers */ Save_callee_save /* Shuffle arguments */ mtlr 3 mr 3, 4 mr 4, 5 mr 5, 6 mr 6, 7 /* Call the function */ blrl /* Restore callee-save registers */ Restore_callee_save /* Reload return address */ lwz 0, 256+4(1) mtlr 0 /* Return */ addi 1, 1, 256 blr .globl caml_c_call .type caml_c_call, @function caml_c_call: /* Jump to C function (address in 11) */ mtctr 11 bctr mingw-ocaml/ocaml/testsuite/tests/asmcomp/parsecmmaux.mli0000644000175000017500000000204712124403241023343 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Auxiliary functions for parsing *) val bind_ident: string -> Ident.t val find_ident: string -> Ident.t val unbind_ident: Ident.t -> unit type error = Unbound of string exception Error of error val report_error: error -> unit mingw-ocaml/ocaml/testsuite/tests/asmcomp/arm.S0000644000175000017500000000270512124403241021217 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1998 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* $Id$ */ .text .global call_gen_code .type call_gen_code, %function .align 0 call_gen_code: mov ip, sp stmfd sp!, {r4, r5, r6, r7, r8, r9, fp, ip, lr, pc} sub fp, ip, #4 @ r0 is function to call @ r1, r2, r3 are arguments 1, 2, 3 mov r4, r0 mov r0, r1 mov r1, r2 mov r2, r3 mov lr, pc mov pc, r4 ldmea fp, {r4, r5, r6, r7, r8, r9, fp, sp, pc} .global caml_c_call .type caml_c_call, %function .align 0 caml_c_call: @ function to call is in r10 mov pc, r10 mingw-ocaml/ocaml/testsuite/tests/asmcomp/quicksort.cmm0000644000175000017500000000331212124403241023031 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (function "quicksort" (lo: int hi: int a: addr) (if (< lo hi) (let (i lo j hi pivot (addraref a hi)) (while (< i j) (catch (while 1 (if (>= i hi) exit []) (if (> (addraref a i) pivot) exit []) (assign i (+ i 1))) with []) (catch (while 1 (if (<= j lo) exit []) (if (< (addraref a j) pivot) exit []) (assign j (- j 1))) with []) (if (< i j) (let temp (addraref a i) (addraset a i (addraref a j)) (addraset a j temp)) [])) (let temp (addraref a i) (addraset a i (addraref a hi)) (addraset a hi temp)) (app "quicksort" lo (- i 1) a unit) (app "quicksort" (+ i 1) hi a unit)) [])) mingw-ocaml/ocaml/testsuite/tests/asmcomp/tagged-quicksort.cmm0000644000175000017500000000360012124403241024262 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (function "quick" (lo: int hi: int a: addr) (if (< lo hi) (let (i lo j hi pivot (addraref a (>>s hi 1))) (while (< i j) (catch (while 1 (if (>= i hi) exit []) (if (> (addraref a (>>s i 1)) pivot) exit []) (assign i (+ i 2))) with []) (catch (while 1 (if (<= j lo) exit []) (if (< (addraref a (>>s j 1)) pivot) exit []) (assign j (- j 2))) with []) (if (< i j) (let temp (addraref a (>>s i 1)) (addraset a (>>s i 1) (addraref a (>>s j 1))) (addraset a (>>s j 1) temp)) [])) (let temp (addraref a (>>s i 1)) (addraset a (>>s i 1) (addraref a (>>s hi 1))) (addraset a (>>s hi 1) temp)) (app "quick" lo (- i 2) a unit) (app "quick" (+ i 2) hi a unit)) [])) (function "quicksort" (lo: int hi: int a: addr) (app "quick" (+ (<< lo 1) 1) (+ (<< hi 1) 1) a unit)) mingw-ocaml/ocaml/testsuite/tests/asmcomp/Makefile0000644000175000017500000001056312124403241021755 0ustar tootstootsBASEDIR=../.. CC=$(NATIVECC) CFLAGS=$(NATIVECCCOMPOPTS) -g INCLUDES=\ -I $(TOPDIR)/utils \ -I $(TOPDIR)/typing \ -I $(TOPDIR)/bytecomp \ -I $(TOPDIR)/asmcomp OTHEROBJS=\ $(TOPDIR)/utils/misc.cmo \ $(TOPDIR)/utils/tbl.cmo \ $(TOPDIR)/utils/config.cmo \ $(TOPDIR)/utils/clflags.cmo \ $(TOPDIR)/utils/terminfo.cmo \ $(TOPDIR)/utils/ccomp.cmo \ $(TOPDIR)/utils/warnings.cmo \ $(TOPDIR)/utils/consistbl.cmo \ $(TOPDIR)/parsing/location.cmo \ $(TOPDIR)/parsing/longident.cmo \ $(TOPDIR)/parsing/syntaxerr.cmo \ $(TOPDIR)/parsing/parser.cmo \ $(TOPDIR)/parsing/lexer.cmo \ $(TOPDIR)/parsing/parse.cmo \ $(TOPDIR)/parsing/printast.cmo \ $(TOPDIR)/typing/ident.cmo \ $(TOPDIR)/typing/path.cmo \ $(TOPDIR)/typing/primitive.cmo \ $(TOPDIR)/typing/types.cmo \ $(TOPDIR)/typing/btype.cmo \ $(TOPDIR)/typing/oprint.cmo \ $(TOPDIR)/typing/subst.cmo \ $(TOPDIR)/typing/predef.cmo \ $(TOPDIR)/typing/datarepr.cmo \ $(TOPDIR)/typing/cmi_format.cmo \ $(TOPDIR)/typing/env.cmo \ $(TOPDIR)/typing/typedtree.cmo \ $(TOPDIR)/typing/ctype.cmo \ $(TOPDIR)/typing/printtyp.cmo \ $(TOPDIR)/typing/includeclass.cmo \ $(TOPDIR)/typing/mtype.cmo \ $(TOPDIR)/typing/includecore.cmo \ $(TOPDIR)/typing/includemod.cmo \ $(TOPDIR)/typing/parmatch.cmo \ $(TOPDIR)/typing/typetexp.cmo \ $(TOPDIR)/typing/cmt_format.cmo \ $(TOPDIR)/typing/stypes.cmo \ $(TOPDIR)/typing/typecore.cmo \ $(TOPDIR)/typing/typedecl.cmo \ $(TOPDIR)/typing/typeclass.cmo \ $(TOPDIR)/typing/typemod.cmo \ $(TOPDIR)/bytecomp/lambda.cmo \ $(TOPDIR)/bytecomp/printlambda.cmo \ $(TOPDIR)/bytecomp/typeopt.cmo \ $(TOPDIR)/bytecomp/switch.cmo \ $(TOPDIR)/bytecomp/matching.cmo \ $(TOPDIR)/bytecomp/translobj.cmo \ $(TOPDIR)/bytecomp/translcore.cmo \ $(TOPDIR)/bytecomp/translclass.cmo \ $(TOPDIR)/bytecomp/translmod.cmo \ $(TOPDIR)/bytecomp/simplif.cmo \ $(TOPDIR)/bytecomp/runtimedef.cmo \ $(TOPDIR)/asmcomp/arch.cmo \ $(TOPDIR)/asmcomp/debuginfo.cmo \ $(TOPDIR)/asmcomp/cmm.cmo \ $(TOPDIR)/asmcomp/printcmm.cmo \ $(TOPDIR)/asmcomp/reg.cmo \ $(TOPDIR)/asmcomp/mach.cmo \ $(TOPDIR)/asmcomp/proc.cmo \ $(TOPDIR)/asmcomp/clambda.cmo \ $(TOPDIR)/asmcomp/compilenv.cmo \ $(TOPDIR)/asmcomp/closure.cmo \ $(TOPDIR)/asmcomp/cmmgen.cmo \ $(TOPDIR)/asmcomp/printmach.cmo \ $(TOPDIR)/asmcomp/selectgen.cmo \ $(TOPDIR)/asmcomp/selection.cmo \ $(TOPDIR)/asmcomp/comballoc.cmo \ $(TOPDIR)/asmcomp/liveness.cmo \ $(TOPDIR)/asmcomp/spill.cmo \ $(TOPDIR)/asmcomp/split.cmo \ $(TOPDIR)/asmcomp/interf.cmo \ $(TOPDIR)/asmcomp/coloring.cmo \ $(TOPDIR)/asmcomp/reloadgen.cmo \ $(TOPDIR)/asmcomp/reload.cmo \ $(TOPDIR)/asmcomp/printlinear.cmo \ $(TOPDIR)/asmcomp/linearize.cmo \ $(TOPDIR)/asmcomp/schedgen.cmo \ $(TOPDIR)/asmcomp/scheduling.cmo \ $(TOPDIR)/asmcomp/emitaux.cmo \ $(TOPDIR)/asmcomp/emit.cmo \ $(TOPDIR)/asmcomp/asmgen.cmo OBJS=parsecmmaux.cmo parsecmm.cmo lexcmm.cmo ADD_COMPFLAGS=$(INCLUDES) -g default: @if [ -z "$(BYTECODE_ONLY)" ]; then \ $(MAKE) all; \ fi all: arch codegen tests codegen: parsecmm.ml lexcmm.ml $(OBJS:.cmo=.cmi) $(OBJS) main.cmo @$(OCAMLC) $(LINKFLAGS) -o codegen $(OTHEROBJS) $(OBJS) main.cmo parsecmm.mli parsecmm.ml: parsecmm.mly @$(OCAMLYACC) -q parsecmm.mly lexcmm.ml: lexcmm.mll @$(OCAMLLEX) -q lexcmm.mll CASES=fib tak quicksort quicksort2 soli \ arith checkbound tagged-fib tagged-integr tagged-quicksort tagged-tak ARGS_fib=-DINT_INT -DFUN=fib main.c ARGS_tak=-DUNIT_INT -DFUN=takmain main.c ARGS_quicksort=-DSORT -DFUN=quicksort main.c ARGS_quicksort2=-DSORT -DFUN=quicksort main.c ARGS_soli=-DUNIT_INT -DFUN=solitaire main.c ARGS_integr=-DINT_FLOAT -DFUN=test main.c ARGS_arith=mainarith.c ARGS_checkbound=-DCHECKBOUND main.c ARGS_tagged-fib=-DINT_INT -DFUN=fib main.c ARGS_tagged-integr=-DINT_FLOAT -DFUN=test main.c ARGS_tagged-quicksort=-DSORT -DFUN=quicksort main.c ARGS_tagged-tak=-DUNIT_INT -DFUN=takmain main.c tests: $(CASES:=.o) @for c in $(CASES); do \ printf " ... testing '$$c':"; \ $(MAKE) one CC="$(CC) $(CFLAGS)" NAME=$$c; \ done one: @$(CC) -o $(NAME).out $(ARGS_$(NAME)) $(NAME).o $(ARCH).o || (echo " => failed" && exit 1) @echo " => passed" clean: defaultclean @rm -f ./codegen *.out @rm -f parsecmm.ml parsecmm.mli lexcmm.ml @rm -f $(CASES:=.s) include $(BASEDIR)/makefiles/Makefile.common power.o: power-$(SYSTEM).o @cp power-$(SYSTEM).o power.o promote: arch: $(ARCH).o mingw-ocaml/ocaml/testsuite/tests/asmcomp/quicksort2.cmm0000644000175000017500000000352712124403241023123 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (function "cmp" (i: int j: int) (- i j)) (function "quick" (lo: int hi: int a: addr cmp: addr) (if (< lo hi) (let (i lo j hi pivot (intaref a hi)) (while (< i j) (catch (while 1 (if (>= i hi) exit []) (if (> (app cmp (intaref a i) pivot int) 0) exit []) (assign i (+ i 1))) with []) (catch (while 1 (if (<= j lo) exit []) (if (< (app cmp (intaref a j) pivot int) 0) exit []) (assign j (- j 1))) with []) (if (< i j) (let temp (intaref a i) (intaset a i (intaref a j)) (intaset a j temp)) [])) (let temp (intaref a i) (intaset a i (intaref a hi)) (intaset a hi temp)) (app "quick" lo (- i 1) a cmp unit) (app "quick" (+ i 1) hi a cmp unit)) [])) (function "quicksort" (lo: int hi: int a: addr) (app "quick" lo hi a "cmp" unit)) mingw-ocaml/ocaml/testsuite/tests/asmcomp/i386nt.asm0000644000175000017500000000352112124403241022046 0ustar tootstoots;*********************************************************************; ; ; ; OCaml ; ; ; ; Xavier Leroy, projet Cristal, INRIA Rocquencourt ; ; ; ; Copyright 1996 Institut National de Recherche en Informatique et ; ; en Automatique. All rights reserved. This file is distributed ; ; under the terms of the Q Public License version 1.0. ; ; ; ;*********************************************************************; ; $Id$ .386 .MODEL FLAT .CODE PUBLIC _call_gen_code ALIGN 4 _call_gen_code: push ebp mov ebp, esp push ebx push esi push edi mov eax, [ebp+12] mov ebx, [ebp+16] mov ecx, [ebp+20] mov edx, [ebp+24] call DWORD PTR [ebp+8] pop edi pop esi pop ebx pop ebp ret PUBLIC _caml_c_call ALIGN 4 _caml_c_call: ffree st(0) ffree st(1) ffree st(2) ffree st(3) jmp eax PUBLIC _caml_call_gc PUBLIC _caml_alloc PUBLIC _caml_alloc1 PUBLIC _caml_alloc2 PUBLIC _caml_alloc3 _caml_call_gc: _caml_alloc: _caml_alloc1: _caml_alloc2: _caml_alloc3: int 3 .DATA PUBLIC _caml_exception_pointer _caml_exception_pointer dword 0 PUBLIC _young_ptr _young_ptr dword 0 PUBLIC _young_limit _young_limit dword 0 END mingw-ocaml/ocaml/testsuite/tests/asmcomp/amd64.S0000644000175000017500000000413412124403241021351 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 2000 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* $Id$ */ #ifdef SYS_macosx #define ALIGN 4 #else #define ALIGN 16 #endif #ifdef SYS_macosx #define CALL_GEN_CODE _call_gen_code #define CAML_C_CALL _caml_c_call #define CAML_NEGF_MASK _caml_negf_mask #define CAML_ABSF_MASK _caml_absf_mask #else #define CALL_GEN_CODE call_gen_code #define CAML_C_CALL caml_c_call #define CAML_NEGF_MASK caml_negf_mask #define CAML_ABSF_MASK caml_absf_mask #endif .globl CALL_GEN_CODE .align ALIGN CALL_GEN_CODE: pushq %rbx pushq %rbp pushq %r12 pushq %r13 pushq %r14 pushq %r15 movq %rdi, %r10 movq %rsi, %rax movq %rdx, %rbx movq %rcx, %rdi movq %r8, %rsi call *%r10 popq %r15 popq %r14 popq %r13 popq %r12 popq %rbp popq %rbx ret .globl CAML_C_CALL .align ALIGN CAML_C_CALL: jmp *%rax #ifdef SYS_macosx .literal16 #else .section .rodata.cst8,"aM",@progbits,8 #endif .globl CAML_NEGF_MASK .align ALIGN CAML_NEGF_MASK: .quad 0x8000000000000000, 0 .globl CAML_ABSF_MASK .align ALIGN CAML_ABSF_MASK: .quad 0x7FFFFFFFFFFFFFFF, 0 .comm young_limit, 8 mingw-ocaml/ocaml/testsuite/tests/asmcomp/parsecmmaux.ml0000644000175000017500000000253112124403241023170 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Auxiliary functions for parsing *) type error = Unbound of string exception Error of error let tbl_ident = (Hashtbl.create 57 : (string, Ident.t) Hashtbl.t) let bind_ident s = let id = Ident.create s in Hashtbl.add tbl_ident s id; id let find_ident s = try Hashtbl.find tbl_ident s with Not_found -> raise(Error(Unbound s)) let unbind_ident id = Hashtbl.remove tbl_ident (Ident.name id) let report_error = function Unbound s -> prerr_string "Unbound identifier "; prerr_string s; prerr_endline "." mingw-ocaml/ocaml/testsuite/tests/asmcomp/main.ml0000644000175000017500000000427612124403241021577 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Clflags let compile_file filename = Compilenv.reset "test"; Emit.begin_assembly(); let ic = open_in filename in let lb = Lexing.from_channel ic in try while true do Asmgen.compile_phrase Format.std_formatter (Parsecmm.phrase Lexcmm.token lb) done with End_of_file -> close_in ic; Emit.end_assembly() | Lexcmm.Error msg -> close_in ic; Lexcmm.report_error lb msg | Parsing.Parse_error -> close_in ic; prerr_string "Syntax error near character "; prerr_int (Lexing.lexeme_start lb); prerr_newline() | Parsecmmaux.Error msg -> close_in ic; Parsecmmaux.report_error msg | x -> close_in ic; raise x let usage = "Usage: codegen \noptions are:" let main() = Arg.parse [ "-dcmm", Arg.Set dump_cmm, ""; "-dsel", Arg.Set dump_selection, ""; "-dlive", Arg.Unit(fun () -> dump_live := true; Printmach.print_live := true), ""; "-dspill", Arg.Set dump_spill, ""; "-dsplit", Arg.Set dump_split, ""; "-dinterf", Arg.Set dump_interf, ""; "-dprefer", Arg.Set dump_prefer, ""; "-dalloc", Arg.Set dump_regalloc, ""; "-dreload", Arg.Set dump_reload, ""; "-dscheduling", Arg.Set dump_scheduling, ""; "-dlinear", Arg.Set dump_linear, "" ] compile_file usage let _ = (*Printexc.catch*) main (); exit 0 mingw-ocaml/ocaml/testsuite/tests/asmcomp/tagged-fib.cmm0000644000175000017500000000165312124403241023004 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (function "fib" (n: int) (if (< n 5) 3 (- (+ (app "fib" (- n 2) int) (app "fib" (- n 4) int)) 1))) mingw-ocaml/ocaml/testsuite/tests/asmcomp/alpha.S0000644000175000017500000000374112124403241021526 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* $Id$ */ .globl call_gen_code .ent call_gen_code call_gen_code: lda $sp, -80($sp) stq $26, 0($sp) stq $9, 8($sp) stq $10, 16($sp) stq $11, 24($sp) stq $12, 32($sp) stt $f2, 40($sp) stt $f3, 48($sp) stt $f4, 56($sp) stt $f5, 64($sp) mov $16, $27 mov $17, $16 mov $18, $17 mov $19, $18 mov $20, $19 jsr ($27) ldq $26, 0($sp) ldq $9, 8($sp) ldq $10, 16($sp) ldq $11, 24($sp) ldq $12, 32($sp) ldt $f2, 40($sp) ldt $f3, 48($sp) ldt $f4, 56($sp) ldt $f5, 64($sp) lda $sp, 80($sp) ret ($26) .end call_gen_code .globl caml_c_call .ent caml_c_call caml_c_call: lda $sp, -16($sp) stq $26, 0($sp) stq $gp, 8($sp) mov $25, $27 jsr ($25) ldq $26, 0($sp) ldq $gp, 8($sp) lda $sp, 16($sp) ret ($26) .end caml_c_call mingw-ocaml/ocaml/testsuite/tests/asmcomp/soli.cmm0000644000175000017500000001024012124403241021751 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) ("d1": int 0 int 1 "d2": int 1 int 0 "d3": int 0 int -1 "d4": int -1 int 0 "dir": addr "d1" addr "d2" addr "d3" addr "d4") ("counter": int 0) (* Out = 0 Empty = 1 Peg = 2 *) ("line0": int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 "line1": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0 "line2": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0 "line3": int 0 int 2 int 2 int 2 int 2 int 2 int 2 int 2 int 0 "line4": int 0 int 2 int 2 int 2 int 1 int 2 int 2 int 2 int 0 "line5": int 0 int 2 int 2 int 2 int 2 int 2 int 2 int 2 int 0 "line6": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0 "line7": int 0 int 0 int 0 int 2 int 2 int 2 int 0 int 0 int 0 "line8": int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 int 0 "board": addr "line0" addr "line1" addr "line2" addr "line3" addr "line4" addr "line5" addr "line6" addr "line7" addr "line8") ("format": string "%d\n\000") (function "solve" (m: int) (store int "counter" (+ (load int "counter") 1)) (if (== m 31) (== (intaref (addraref "board" 4) 4) 2) (try (if (== (mod (load int "counter") 500) 0) (extcall "printf_int" "format" (load int "counter") unit) []) (let i 1 (while (<= i 7) (let j 1 (while (<= j 7) (if (== (intaref (addraref "board" i) j) 2) (seq (let k 0 (while (<= k 3) (let (d1 (intaref (addraref "dir" k) 0) d2 (intaref (addraref "dir" k) 1) i1 (+ i d1) i2 (+ i1 d1) j1 (+ j d2) j2 (+ j1 d2)) (if (== (intaref (addraref "board" i1) j1) 2) (if (== (intaref (addraref "board" i2) j2) 1) (seq (intaset (addraref "board" i) j 1) (intaset (addraref "board" i1) j1 1) (intaset (addraref "board" i2) j2 2) (if (app "solve" (+ m 1) int) (raise 0a) []) (intaset (addraref "board" i) j 2) (intaset (addraref "board" i1) j1 2) (intaset (addraref "board" i2) j2 1)) []) [])) (assign k (+ k 1))))) []) (assign j (+ j 1)))) (assign i (+ i 1)))) 0 with bucket 1))) ("format_out": string ".\000") ("format_empty": string " \000") ("format_peg": string "$\000") ("format_newline": string "\n\000") (function "print_board" () (let i 0 (while (< i 9) (let j 0 (while (< j 9) (switch 3 (intaref (addraref "board" i) j) case 0: (extcall "print_string" "format_out" unit) case 1: (extcall "print_string" "format_empty" unit) case 2: (extcall "print_string" "format_peg" unit)) (assign j (+ j 1)))) (extcall "print_string" "format_newline" unit) (assign i (+ i 1))))) (function "solitaire" () (seq (if (app "solve" 0 int) (app "print_board" [] unit) []) 0)) mingw-ocaml/ocaml/testsuite/tests/asmcomp/ia64.S0000644000175000017500000000750512124403241021206 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* $Id$ */ #define ST8OFF(a,b,d) st8 [a] = b, d #define LD8OFF(a,b,d) ld8 a = [b], d #define STFDOFF(a,b,d) stfd [a] = b, d #define LDFDOFF(a,b,d) ldfd a = [b], d #define STFSPILLOFF(a,b,d) stf.spill [a] = b, d #define LDFFILLOFF(a,b,d) ldf.fill a = [b], d .text .align 16 .global call_gen_code# .proc call_gen_code# call_gen_code: /* Allocate 64 "out" registers (for the OCaml code) and no locals */ alloc r3 = ar.pfs, 0, 0, 64, 0 /* Save PFS, return address and GP on stack */ add sp = -368, sp ;; add r2 = 16, sp ;; ST8OFF(r2,r3,8) ;; mov r3 = b0 ;; ST8OFF(r2,r3,8) ;; ST8OFF(r2,gp,8) ;; /* Save predicates on stack */ mov r3 = pr ;; st8 [r2] = r3 /* Save callee-save floating-point registers on stack */ add r2 = 48, sp add r3 = 64, sp ;; STFSPILLOFF(r2,f2,16) ;; STFSPILLOFF(r3,f3,16) ;; STFSPILLOFF(r2,f4,16) ;; STFSPILLOFF(r3,f5,16) ;; STFSPILLOFF(r2,f16,16) ;; STFSPILLOFF(r3,f17,16) ;; STFSPILLOFF(r2,f18,16) ;; STFSPILLOFF(r3,f19,16) ;; STFSPILLOFF(r2,f20,16) ;; STFSPILLOFF(r3,f21,16) ;; STFSPILLOFF(r2,f22,16) ;; STFSPILLOFF(r3,f23,16) ;; STFSPILLOFF(r2,f24,16) ;; STFSPILLOFF(r3,f25,16) ;; STFSPILLOFF(r2,f26,16) ;; STFSPILLOFF(r3,f27,16) ;; STFSPILLOFF(r2,f28,16) ;; STFSPILLOFF(r3,f29,16) ;; STFSPILLOFF(r2,f30,16) ;; STFSPILLOFF(r3,f31,16) ;; /* Recover entry point and gp from the function pointer in in0 */ LD8OFF(r2,r32,8) ;; ld8 r3 = [r32] ;; mov b6 = r2 mov gp = r3 ;; /* Shift arguments r33 ... r35 to r32 ... r34 */ mov r32 = r33 mov r33 = r34 mov r34 = r35 /* Do the call */ br.call.sptk b0 = b6 ;; /* Restore the saved floating-point registers */ add r2 = 48, sp add r3 = 64, sp ;; LDFFILLOFF(f2,r2,16) ;; LDFFILLOFF(f3,r3,16) ;; LDFFILLOFF(f4,r2,16) ;; LDFFILLOFF(f5,r3,16) ;; LDFFILLOFF(f16,r2,16) ;; LDFFILLOFF(f17,r3,16) ;; LDFFILLOFF(f18,r2,16) ;; LDFFILLOFF(f19,r3,16) ;; LDFFILLOFF(f20,r2,16) ;; LDFFILLOFF(f21,r3,16) ;; LDFFILLOFF(f22,r2,16) ;; LDFFILLOFF(f23,r3,16) ;; LDFFILLOFF(f24,r2,16) ;; LDFFILLOFF(f25,r3,16) ;; LDFFILLOFF(f26,r2,16) ;; LDFFILLOFF(f27,r3,16) ;; LDFFILLOFF(f28,r2,16) ;; LDFFILLOFF(f29,r3,16) ;; LDFFILLOFF(f30,r2,16) ;; LDFFILLOFF(f31,r3,16) ;; /* Restore gp, predicates and return */ add r2 = 16, sp ;; LD8OFF(r3,r2,8) ;; mov ar.pfs = r3 LD8OFF(r3,r2,8) ;; mov b0 = r3 LD8OFF(gp,r2,8) ;; LD8OFF(r3,r2,8) ;; mov pr = r3, -1 br.ret.sptk.many b0 ;; .endp call_gen_code# mingw-ocaml/ocaml/testsuite/tests/asmcomp/hppa.S0000644000175000017500000001124512124403241021367 0ustar tootstoots;********************************************************************* ;* * ;* OCaml * ;* * ;* Xavier Leroy, projet Cristal, INRIA Rocquencourt * ;* * ;* Copyright 1996 Institut National de Recherche en Informatique et * ;* en Automatique. All rights reserved. This file is distributed * ;* under the terms of the Q Public License version 1.0. * ;* * ;********************************************************************* ; $Id$ ; Must be preprocessed by cpp #ifdef SYS_hpux #define G(x) x #define CODESPACE .code #define CODE_ALIGN 4 #define EXPORT_CODE(x) .export x, entry, priv_lev=3 #define STARTPROC .proc ! .callinfo frame=0, no_calls ! .entry #define ENDPROC .exit ! .procend #endif #ifdef SYS_nextstep #define G(x) _##x #define CODESPACE .text #define CODE_ALIGN 2 #define EXPORT_CODE(x) .globl x #define STARTPROC #define ENDPROC #endif #ifdef SYS_hpux .space $PRIVATE$ .subspa $DATA$,quad=1,align=8,access=31 .subspa $BSS$,quad=1,align=8,access=31,zero,sort=82 .space $TEXT$ .subspa $LIT$,quad=0,align=8,access=44 .subspa $CODE$,quad=0,align=8,access=44,code_only .import $global$, data .import $$dyncall, millicode #endif CODESPACE .align CODE_ALIGN EXPORT_CODE(G(call_gen_code)) G(call_gen_code): STARTPROC stw %r2,-20(%r30) ldo 256(%r30), %r30 ; Save the callee-save registers ldo -32(%r30), %r1 stws,ma %r3, -4(%r1) stws,ma %r4, -4(%r1) stws,ma %r5, -4(%r1) stws,ma %r6, -4(%r1) stws,ma %r7, -4(%r1) stws,ma %r8, -4(%r1) stws,ma %r9, -4(%r1) stws,ma %r10, -4(%r1) stws,ma %r11, -4(%r1) stws,ma %r12, -4(%r1) stws,ma %r13, -4(%r1) stws,ma %r14, -4(%r1) stws,ma %r15, -4(%r1) stws,ma %r16, -4(%r1) stws,ma %r17, -4(%r1) stws,ma %r18, -4(%r1) fstds,ma %fr12, -8(%r1) fstds,ma %fr13, -8(%r1) fstds,ma %fr14, -8(%r1) fstds,ma %fr15, -8(%r1) fstds,ma %fr16, -8(%r1) fstds,ma %fr17, -8(%r1) fstds,ma %fr18, -8(%r1) fstds,ma %fr19, -8(%r1) fstds,ma %fr20, -8(%r1) fstds,ma %fr21, -8(%r1) fstds,ma %fr22, -8(%r1) fstds,ma %fr23, -8(%r1) fstds,ma %fr24, -8(%r1) fstds,ma %fr25, -8(%r1) fstds,ma %fr26, -8(%r1) fstds,ma %fr27, -8(%r1) fstds,ma %fr28, -8(%r1) fstds,ma %fr29, -8(%r1) fstds,ma %fr30, -8(%r1) fstds,ma %fr31, -8(%r1) ; Shuffle the arguments and call copy %r26, %r22 copy %r25, %r26 copy %r24, %r25 copy %r23, %r24 fcpy,dbl %fr5, %fr4 #ifdef SYS_hpux bl $$dyncall, %r2 nop #else ble 0(4, %r22) copy %r31, %r2 #endif ; Shuffle the results copy %r26, %r28 ; Restore the callee-save registers ldo -32(%r30), %r1 ldws,ma -4(%r1), %r3 ldws,ma -4(%r1), %r4 ldws,ma -4(%r1), %r5 ldws,ma -4(%r1), %r6 ldws,ma -4(%r1), %r7 ldws,ma -4(%r1), %r8 ldws,ma -4(%r1), %r9 ldws,ma -4(%r1), %r10 ldws,ma -4(%r1), %r11 ldws,ma -4(%r1), %r12 ldws,ma -4(%r1), %r13 ldws,ma -4(%r1), %r14 ldws,ma -4(%r1), %r15 ldws,ma -4(%r1), %r16 ldws,ma -4(%r1), %r17 ldws,ma -4(%r1), %r18 fldds,ma -8(%r1), %fr12 fldds,ma -8(%r1), %fr13 fldds,ma -8(%r1), %fr14 fldds,ma -8(%r1), %fr15 fldds,ma -8(%r1), %fr16 fldds,ma -8(%r1), %fr17 fldds,ma -8(%r1), %fr18 fldds,ma -8(%r1), %fr19 fldds,ma -8(%r1), %fr20 fldds,ma -8(%r1), %fr21 fldds,ma -8(%r1), %fr22 fldds,ma -8(%r1), %fr23 fldds,ma -8(%r1), %fr24 fldds,ma -8(%r1), %fr25 fldds,ma -8(%r1), %fr26 fldds,ma -8(%r1), %fr27 fldds,ma -8(%r1), %fr28 fldds,ma -8(%r1), %fr29 fldds,ma -8(%r1), %fr30 fldds,ma -8(%r1), %fr31 ldo -256(%r30), %r30 ldw -20(%r30), %r2 bv 0(%r2) nop ENDPROC .align CODE_ALIGN EXPORT_CODE(caml_c_call) G(caml_c_call): STARTPROC #ifdef SYS_hpux bl $$dyncall, %r0 nop #else bv 0(%r22) nop #endif ENDPROC mingw-ocaml/ocaml/testsuite/tests/asmcomp/mips.s0000644000175000017500000000453112124403241021447 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* $Id$ */ .globl call_gen_code .ent call_gen_code call_gen_code: subu $sp, $sp, 0x90 sd $31, 0x88($sp) /* Save all callee-save registers */ sd $16, 0x0($sp) sd $17, 0x8($sp) sd $18, 0x10($sp) sd $19, 0x18($sp) sd $20, 0x20($sp) sd $21, 0x28($sp) sd $22, 0x30($sp) sd $23, 0x38($sp) sd $30, 0x40($sp) s.d $f20, 0x48($sp) s.d $f22, 0x50($sp) s.d $f24, 0x58($sp) s.d $f26, 0x60($sp) s.d $f28, 0x68($sp) s.d $f30, 0x70($sp) /* Shuffle arguments */ move $8, $5 move $9, $6 move $10, $7 move $25, $4 jal $4 /* Restore registers */ ld $31, 0x88($sp) ld $16, 0x0($sp) ld $17, 0x8($sp) ld $18, 0x10($sp) ld $19, 0x18($sp) ld $20, 0x20($sp) ld $21, 0x28($sp) ld $22, 0x30($sp) ld $23, 0x38($sp) ld $30, 0x40($sp) l.d $f20, 0x48($sp) l.d $f22, 0x50($sp) l.d $f24, 0x58($sp) l.d $f26, 0x60($sp) l.d $f28, 0x68($sp) l.d $f30, 0x70($sp) addu $sp, $sp, 0x90 j $31 .end call_gen_code /* Call a C function */ .globl caml_c_call .ent caml_c_call caml_c_call: move $25, $24 j $24 .end caml_c_call mingw-ocaml/ocaml/testsuite/tests/asmcomp/power-aix.S0000644000175000017500000000753712124403241022363 0ustar tootstoots#********************************************************************* #* * #* OCaml * #* * #* Xavier Leroy, projet Cristal, INRIA Rocquencourt * #* * #* Copyright 1996 Institut National de Recherche en Informatique et * #* en Automatique. All rights reserved. This file is distributed * #* under the terms of the Q Public License version 1.0. * #* * #********************************************************************* # $Id$ .csect .text[PR] .globl .call_gen_code .call_gen_code: # Save return address mflr 0 stw 0, 8(1) # Save all callee-save registers stw 13,-76(1) stw 14,-72(1) stw 15,-68(1) stw 16,-64(1) stw 17,-60(1) stw 18,-56(1) stw 19,-52(1) stw 20,-48(1) stw 21,-44(1) stw 22,-40(1) stw 23,-36(1) stw 24,-32(1) stw 25,-28(1) stw 26,-24(1) stw 27,-20(1) stw 28,-16(1) stw 29,-12(1) stw 30,-8(1) stw 31,-4(1) stfd 14, -224(1) stfd 15, -216(1) stfd 16, -208(1) stfd 17, -200(1) stfd 18, -192(1) stfd 19, -184(1) stfd 20, -176(1) stfd 21, -168(1) stfd 22, -160(1) stfd 23, -152(1) stfd 24, -144(1) stfd 25, -136(1) stfd 26, -128(1) stfd 27, -120(1) stfd 28, -112(1) stfd 29, -104(1) stfd 30, -96(1) stfd 31, -88(1) # Allocate and link stack frame stwu 1, -280(1) # Save global pointer stw 2, 20(1) # Load code to call lwz 0, 0(3) lwz 2, 4(3) mtlr 0 # Shuffle arguments mr 3, 4 mr 4, 5 mr 5, 6 mr 6, 7 # Call the function blrl # Restore global pointer lwz 2, 20(1) # Deallocate stack frame addic 1, 1, 280 # Restore callee-save registers lwz 13,-76(1) lwz 14,-72(1) lwz 15,-68(1) lwz 16,-64(1) lwz 17,-60(1) lwz 18,-56(1) lwz 19,-52(1) lwz 20,-48(1) lwz 21,-44(1) lwz 22,-40(1) lwz 23,-36(1) lwz 24,-32(1) lwz 25,-28(1) lwz 26,-24(1) lwz 27,-20(1) lwz 28,-16(1) lwz 29,-12(1) lwz 30,-8(1) lwz 31,-4(1) lfd 14, -224(1) lfd 15, -216(1) lfd 16, -208(1) lfd 17, -200(1) lfd 18, -192(1) lfd 19, -184(1) lfd 20, -176(1) lfd 21, -168(1) lfd 22, -160(1) lfd 23, -152(1) lfd 24, -144(1) lfd 25, -136(1) lfd 26, -128(1) lfd 27, -120(1) lfd 28, -112(1) lfd 29, -104(1) lfd 30, -96(1) lfd 31, -88(1) # Reload return address lwz 0, 8(1) mtlr 0 # Return blr .globl .caml_c_call .caml_c_call: # Preserve RTOC and return address in callee-save registers # The C function will preserve them, and the OCaml code does not # expect them to be preserved # Return address is in 25, RTOC is in 26 mflr 25 mr 26, 2 # Call desired function (descriptor in r11) lwz 0, 0(11) lwz 2, 4(11) mtlr 0 blrl # Restore return address and RTOC mtlr 25 mr 2, 26 # Return to caller blr # Function closures .globl call_gen_code .csect call_gen_code[DS] call_gen_code: .long .call_gen_code, TOC[tc0], 0 .globl caml_c_call .csect caml_c_call[DS] caml_c_call: .long .caml_c_call, TOC[tc0], 0 mingw-ocaml/ocaml/testsuite/tests/asmcomp/integr.cmm0000644000175000017500000000227512124403241022304 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (function "square" (x: float) ( *f x x)) (function "integr" (f: addr low: float high: float n: int) (let (h (/f (-f high low) (floatofint n)) x low s 0.0 i n) (while (> i 0) (assign s (+f s (app f x float))) (assign x (+f x h)) (assign i (- i 1))) ( *f s h))) (function "test" (n: int) (app "integr" "square" 0.0 1.0 n float)) mingw-ocaml/ocaml/testsuite/tests/asmcomp/tak.cmm0000644000175000017500000000210112124403241021557 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (function "tak" (x:int y:int z:int) (if (> x y) (app "tak" (app "tak" (- x 1) y z int) (app "tak" (- y 1) z x int) (app "tak" (- z 1) x y int) int) z)) (function "takmain" (dummy: int) (app "tak" 18 12 6 int)) mingw-ocaml/ocaml/testsuite/tests/asmcomp/power-rhapsody.S0000644000175000017500000000772412124403241023431 0ustar tootstoots/*********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /*********************************************************************/ /* $Id$ */ /* Save and restore all callee-save registers */ /* GPR 14 at sp+16 ... GPR 31 at sp+84 FPR 14 at sp+92 ... FPR 31 at sp+228 */ #define Save_callee_save \ addic r11, r1, 16-4; \ stwu r14, 4(r11); \ stwu r15, 4(r11); \ stwu r16, 4(r11); \ stwu r17, 4(r11); \ stwu r18, 4(r11); \ stwu r19, 4(r11); \ stwu r20, 4(r11); \ stwu r21, 4(r11); \ stwu r22, 4(r11); \ stwu r23, 4(r11); \ stwu r24, 4(r11); \ stwu r25, 4(r11); \ stwu r26, 4(r11); \ stwu r27, 4(r11); \ stwu r28, 4(r11); \ stwu r29, 4(r11); \ stwu r30, 4(r11); \ stwu r31, 4(r11); \ stfdu f14, 8(r11); \ stfdu f15, 8(r11); \ stfdu f16, 8(r11); \ stfdu f17, 8(r11); \ stfdu f18, 8(r11); \ stfdu f19, 8(r11); \ stfdu f20, 8(r11); \ stfdu f21, 8(r11); \ stfdu f22, 8(r11); \ stfdu f23, 8(r11); \ stfdu f24, 8(r11); \ stfdu f25, 8(r11); \ stfdu f26, 8(r11); \ stfdu f27, 8(r11); \ stfdu f28, 8(r11); \ stfdu f29, 8(r11); \ stfdu f30, 8(r11); \ stfdu f31, 8(r11) #define Restore_callee_save \ addic r11, r1, 16-4; \ lwzu r14, 4(r11); \ lwzu r15, 4(r11); \ lwzu r16, 4(r11); \ lwzu r17, 4(r11); \ lwzu r18, 4(r11); \ lwzu r19, 4(r11); \ lwzu r20, 4(r11); \ lwzu r21, 4(r11); \ lwzu r22, 4(r11); \ lwzu r23, 4(r11); \ lwzu r24, 4(r11); \ lwzu r25, 4(r11); \ lwzu r26, 4(r11); \ lwzu r27, 4(r11); \ lwzu r28, 4(r11); \ lwzu r29, 4(r11); \ lwzu r30, 4(r11); \ lwzu r31, 4(r11); \ lfdu f14, 8(r11); \ lfdu f15, 8(r11); \ lfdu f16, 8(r11); \ lfdu f17, 8(r11); \ lfdu f18, 8(r11); \ lfdu f19, 8(r11); \ lfdu f20, 8(r11); \ lfdu f21, 8(r11); \ lfdu f22, 8(r11); \ lfdu f23, 8(r11); \ lfdu f24, 8(r11); \ lfdu f25, 8(r11); \ lfdu f26, 8(r11); \ lfdu f27, 8(r11); \ lfdu f28, 8(r11); \ lfdu f29, 8(r11); \ lfdu f30, 8(r11); \ lfdu f31, 8(r11) .text .globl _call_gen_code _call_gen_code: /* Allocate and link stack frame */ stwu r1, -256(r1) /* Save return address */ mflr r0 stw r0, 256+4(r1) /* Save all callee-save registers */ Save_callee_save /* Shuffle arguments */ mtlr r3 mr r3, r4 mr r4, r5 mr r5, r6 mr r6, r7 /* Call the function */ blrl /* Restore callee-save registers */ Restore_callee_save /* Reload return address */ lwz r0, 256+4(r1) mtlr r0 /* Return */ addi r1, r1, 256 blr .globl _caml_c_call _caml_c_call: /* Jump to C function (address in 11) */ mtctr r11 bctr mingw-ocaml/ocaml/testsuite/tests/asmcomp/checkbound.cmm0000644000175000017500000000165512124403241023122 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (function "checkbound2" (x: int y: int) (checkbound x y)) (function "checkbound1" (x: int) (checkbound x 2)) mingw-ocaml/ocaml/testsuite/tests/asmcomp/tagged-tak.cmm0000644000175000017500000000210212124403241023011 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (function "tak" (x:int y:int z:int) (if (> x y) (app "tak" (app "tak" (- x 2) y z int) (app "tak" (- y 2) z x int) (app "tak" (- z 2) x y int) int) z)) (function "takmain" (dummy: int) (app "tak" 37 25 13 int)) mingw-ocaml/ocaml/testsuite/tests/asmcomp/main.c0000644000175000017500000000624512124403241021407 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include void caml_ml_array_bound_error(void) { fprintf(stderr, "Fatal error: out-of-bound access in array or string\n"); exit(2); } void print_string(char * s) { fputs(s, stdout); } void printf_int(char * fmt, int arg) { printf(fmt, arg); } #ifdef SORT int cmpint(const void * i, const void * j) { long vi = *((long *) i); long vj = *((long *) j); if (vi == vj) return 0; if (vi < vj) return -1; return 1; } #endif int main(int argc, char **argv) { #ifdef UNIT_INT { extern int FUN(); extern int call_gen_code(); printf("%d\n", call_gen_code(FUN)); } #else if (argc < 2) { fprintf(stderr, "Usage: %s [int arg]\n", argv[0]); exit(2); } #ifdef INT_INT { extern int FUN(); extern int call_gen_code(); printf("%d\n", call_gen_code(FUN, atoi(argv[1]))); } #endif #ifdef INT_FLOAT { extern double FUN(); #ifdef __mc68020__ #define call_gen_code call_gen_code_float #endif extern double call_gen_code(); printf("%f\n", call_gen_code(FUN, atoi(argv[1]))); } #endif #ifdef SORT { extern void FUN(); extern void call_gen_code(); long n; long * a, * b; long i; srand(argc >= 3 ? atoi(argv[2]) : time((time_t *) 0)); n = atoi(argv[1]); a = (long *) malloc(n * sizeof(long)); for (i = 0 ; i < n; i++) a[i] = rand() & 0xFFF; #ifdef DEBUG for (i = 0; i < n; i++) printf("%ld ", a[i]); printf("\n"); #endif b = (long *) malloc(n * sizeof(long)); for (i = 0; i < n; i++) b[i] = a[i]; call_gen_code(FUN, 0, n-1, a); #ifdef DEBUG for (i = 0; i < n; i++) printf("%ld ", a[i]); printf("\n"); #endif qsort(b, n, sizeof(long), cmpint); for (i = 0; i < n; i++) { if (a[i] != b[i]) { printf("Bug!\n"); return 2; } } printf("OK\n"); } #endif #endif #ifdef CHECKBOUND { extern void checkbound1(), checkbound2(); extern void call_gen_code(); long x, y; x = atoi(argv[1]); if (argc >= 3) { y = atoi(argv[2]); if ((unsigned long) x < (unsigned long) y) printf("Should not trap\n"); else printf("Should trap\n"); call_gen_code(checkbound2, y, x); } else { if (2 < (unsigned long) x) printf("Should not trap\n"); else printf("Should trap\n"); call_gen_code(checkbound1, x); } printf("OK\n"); } #endif return 0; } mingw-ocaml/ocaml/testsuite/tests/asmcomp/lexcmm.mli0000644000175000017500000000200712124403241022277 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) val token: Lexing.lexbuf -> Parsecmm.token type error = Illegal_character | Unterminated_comment | Unterminated_string exception Error of error val report_error: Lexing.lexbuf -> error -> unit mingw-ocaml/ocaml/testsuite/tests/asmcomp/lexcmm.mll0000644000175000017500000001362712124403241022314 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) { open Parsecmm type error = Illegal_character | Unterminated_comment | Unterminated_string exception Error of error (* For nested comments *) let comment_depth = ref 0 (* The table of keywords *) let keyword_table = Misc.create_hashtable 149 [ "absf", ABSF; "addr", ADDR; "align", ALIGN; "alloc", ALLOC; "and", AND; "app", APPLY; "assign", ASSIGN; "byte", BYTE; "case", CASE; "catch", CATCH; "checkbound", CHECKBOUND; "exit", EXIT; "extcall", EXTCALL; "float", FLOAT; "float32", FLOAT32; "float64", FLOAT64; "floatofint", FLOATOFINT; "function", FUNCTION; "half", HALF; "if", IF; "int", INT; "int32", INT32; "intoffloat", INTOFFLOAT; "string", KSTRING; "let", LET; "load", LOAD; "mod", MODI; "or", OR; "proj", PROJ; "raise", RAISE; "seq", SEQ; "signed", SIGNED; "skip", SKIP; "store", STORE; "switch", SWITCH; "try", TRY; "unit", UNIT; "unsigned", UNSIGNED; "while", WHILE; "with", WITH; "xor", XOR; "addraref", ADDRAREF; "intaref", INTAREF; "floataref", FLOATAREF; "addraset", ADDRASET; "intaset", INTASET; "floataset", FLOATASET ] (* To buffer string literals *) let initial_string_buffer = String.create 256 let string_buff = ref initial_string_buffer let string_index = ref 0 let reset_string_buffer () = string_buff := initial_string_buffer; string_index := 0 let store_string_char c = if !string_index >= String.length (!string_buff) then begin let new_buff = String.create (String.length (!string_buff) * 2) in String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff)); string_buff := new_buff end; String.unsafe_set (!string_buff) (!string_index) c; incr string_index let get_stored_string () = let s = String.sub (!string_buff) 0 (!string_index) in string_buff := initial_string_buffer; s (* To translate escape sequences *) let char_for_backslash = function 'n' -> '\010' | 'r' -> '\013' | 'b' -> '\008' | 't' -> '\009' | c -> c let char_for_decimal_code lexbuf i = Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48)) (* Error report *) let report_error lexbuf msg = prerr_string "Lexical error around character "; prerr_int (Lexing.lexeme_start lexbuf); match msg with Illegal_character -> prerr_string ": illegal character" | Unterminated_comment -> prerr_string ": unterminated comment" | Unterminated_string -> prerr_string ": unterminated string" } rule token = parse [' ' '\010' '\013' '\009' '\012'] + { token lexbuf } | "+a" { ADDA } | "+f" { ADDF } | "+" { ADDI } | ">>s" { ASR } | ":" { COLON } | "/f" { DIVF } | "/" { DIVI } | eof { EOF } | "==a" { EQA } | "==f" { EQF } | "==" { EQI } | ">=a" { GEA } | ">=f" { GEF } | ">=" { GEI } | ">a" { GTA } | ">f" { GTF } | ">" { GTI } | "[" { LBRACKET } | "<=a" { LEA } | "<=f" { LEF } | "<=" { LEI } | "(" { LPAREN } | "<<" { LSL } | ">>u" { LSR } | " IDENT s } | "\"" { reset_string_buffer(); string lexbuf; STRING (get_stored_string()) } | "(*" { comment_depth := 1; comment lexbuf; token lexbuf } | _ { raise(Error(Illegal_character)) } and comment = parse "(*" { comment_depth := succ !comment_depth; comment lexbuf } | "*)" { comment_depth := pred !comment_depth; if !comment_depth > 0 then comment lexbuf } | eof { raise (Error(Unterminated_comment)) } | _ { comment lexbuf } and string = parse '"' { () } | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] + { string lexbuf } | '\\' ['\\' '"' 'n' 't' 'b' 'r'] { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); string lexbuf } | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_string_char(char_for_decimal_code lexbuf 1); string lexbuf } | eof { raise (Error(Unterminated_string)) } | _ { store_string_char(Lexing.lexeme_char lexbuf 0); string lexbuf } mingw-ocaml/ocaml/testsuite/tests/asmcomp/mainarith.c0000644000175000017500000002151112124403241022430 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* $Id$ */ #include #include #include #include #include void caml_ml_array_bound_error(void) { fprintf(stderr, "Fatal error: out-of-bound access in array or string\n"); exit(2); } long R[200]; double D[40]; long X, Y; double F, G; #define INTTEST(arg,res) \ { long result = (res); \ if (arg != result) \ printf("Failed test \"%s == %s\" for X=%ld and Y=%ld: result %ld, expected %ld\n", \ #arg, #res, X, Y, arg, result); \ } #define INTFLOATTEST(arg,res) \ { long result = (res); \ if (arg != result) \ printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %ld, expected %ld\n", \ #arg, #res, F, G, arg, result); \ } #define FLOATTEST(arg,res) \ { double result = (res); \ if (arg < result || arg > result) \ printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %.15g, expected %.15g\n", \ #arg, #res, F, G, arg, result); \ } #define FLOATINTTEST(arg,res) \ { double result = (res); \ if (arg < result || arg > result) \ printf("Failed test \"%s == %s\" for X=%ld and Y=%ld: result %.15g, expected %.15g\n", \ #arg, #res, X, Y, arg, result); \ } extern void call_gen_code(); extern void testarith(); void do_test(void) { call_gen_code(testarith); INTTEST(R[0], 0); INTTEST(R[1], 1); INTTEST(R[2], -1); INTTEST(R[3], 256); INTTEST(R[4], 65536); INTTEST(R[5], 16777216); INTTEST(R[6], -256); INTTEST(R[7], -65536); INTTEST(R[8], -16777216); INTTEST(R[9], (X + Y)); INTTEST(R[10], (X + 1)); INTTEST(R[11], (X + -1)); INTTEST(R[12], ((long) ((char *)R + 8))); INTTEST(R[13], ((long) ((char *)R + Y))); INTTEST(R[14], (X - Y)); INTTEST(R[15], (X - 1)); INTTEST(R[16], (X - -1)); INTTEST(R[17], ((long) ((char *)R - 8))); INTTEST(R[18], ((long) ((char *)R - Y))); INTTEST(R[19], (X * 2)); INTTEST(R[20], (2 * X)); INTTEST(R[21], (X * 16)); INTTEST(R[22], (16 * X)); INTTEST(R[23], (X * 12345)); INTTEST(R[24], (12345 * X)); INTTEST(R[25], (X * Y)); INTTEST(R[26], (X / 2)); INTTEST(R[27], (X / 16)); INTTEST(R[28], (X / 7)); INTTEST(R[29], (Y != 0 ? X / Y : 0)); INTTEST(R[30], (X % 2)); INTTEST(R[31], (X % 16)); INTTEST(R[32], (Y != 0 ? X % Y : 0)); INTTEST(R[33], (X & Y)); INTTEST(R[34], (X & 3)); INTTEST(R[35], (3 & X)); INTTEST(R[36], (X | Y)); INTTEST(R[37], (X | 3)); INTTEST(R[38], (3 | X)); INTTEST(R[39], (X ^ Y)); INTTEST(R[40], (X ^ 3)); INTTEST(R[41], (3 ^ X)); INTTEST(R[42], (X << Y)); INTTEST(R[43], (X << 1)); INTTEST(R[44], (X << 8)); INTTEST(R[45], ((unsigned long) X >> Y)); INTTEST(R[46], ((unsigned long) X >> 1)); INTTEST(R[47], ((unsigned long) X >> 8)); INTTEST(R[48], (X >> Y)); INTTEST(R[49], (X >> 1)); INTTEST(R[50], (X >> 8)); INTTEST(R[51], (X == Y)); INTTEST(R[52], (X != Y)); INTTEST(R[53], (X < Y)); INTTEST(R[54], (X > Y)); INTTEST(R[55], (X <= Y)); INTTEST(R[56], (X >= Y)); INTTEST(R[57], (X == 1)); INTTEST(R[58], (X != 1)); INTTEST(R[59], (X < 1)); INTTEST(R[60], (X > 1)); INTTEST(R[61], (X <= 1)); INTTEST(R[62], (X >= 1)); INTTEST(R[63], ((char *)X == (char *)Y)); INTTEST(R[64], ((char *)X != (char *)Y)); INTTEST(R[65], ((char *)X < (char *)Y)); INTTEST(R[66], ((char *)X > (char *)Y)); INTTEST(R[67], ((char *)X <= (char *)Y)); INTTEST(R[68], ((char *)X >= (char *)Y)); INTTEST(R[69], ((char *)X == (char *)1)); INTTEST(R[70], ((char *)X != (char *)1)); INTTEST(R[71], ((char *)X < (char *)1)); INTTEST(R[72], ((char *)X > (char *)1)); INTTEST(R[73], ((char *)X <= (char *)1)); INTTEST(R[74], ((char *)X >= (char *)1)); INTTEST(R[75], (X + (Y << 1))); INTTEST(R[76], (X + (Y << 2))); INTTEST(R[77], (X + (Y << 3))); INTTEST(R[78], (X - (Y << 1))); INTTEST(R[79], (X - (Y << 2))); INTTEST(R[80], (X - (Y << 3))); FLOATTEST(D[0], 0.0); FLOATTEST(D[1], 1.0); FLOATTEST(D[2], -1.0); FLOATTEST(D[3], (F + G)); FLOATTEST(D[4], (F - G)); FLOATTEST(D[5], (F * G)); FLOATTEST(D[6], F / G); FLOATTEST(D[7], (F + (G + 1.0))); FLOATTEST(D[8], (F - (G + 1.0))); FLOATTEST(D[9], (F * (G + 1.0))); FLOATTEST(D[10], F / (G + 1.0)); FLOATTEST(D[11], ((F + 1.0) + G)); FLOATTEST(D[12], ((F + 1.0) - G)); FLOATTEST(D[13], ((F + 1.0) * G)); FLOATTEST(D[14], (F + 1.0) / G); FLOATTEST(D[15], ((F + 1.0) + (G + 1.0))); FLOATTEST(D[16], ((F + 1.0) - (G + 1.0))); FLOATTEST(D[17], ((F + 1.0) * (G + 1.0))); FLOATTEST(D[18], (F + 1.0) / (G + 1.0)); INTFLOATTEST(R[81], (F == G)); INTFLOATTEST(R[82], (F != G)); INTFLOATTEST(R[83], (F < G)); INTFLOATTEST(R[84], (F > G)); INTFLOATTEST(R[85], (F <= G)); INTFLOATTEST(R[86], (F >= G)); FLOATINTTEST(D[19], (double) X); INTFLOATTEST(R[87], (long) F); INTTEST(R[88], (X >= 0) && (X < Y)); INTTEST(R[89], (0 < Y)); INTTEST(R[90], (5 < Y)); INTFLOATTEST(R[91], (F == G)); INTFLOATTEST(R[92], (F != G)); INTFLOATTEST(R[93], (F < G)); INTFLOATTEST(R[94], (F > G)); INTFLOATTEST(R[95], (F <= G)); INTFLOATTEST(R[96], (F >= G)); INTFLOATTEST(R[97], (F + 1.0 == G + 1.0)); INTFLOATTEST(R[98], (F + 1.0 != G + 1.0)); INTFLOATTEST(R[99], (F + 1.0 < G + 1.0)); INTFLOATTEST(R[100], (F + 1.0 > G + 1.0)); INTFLOATTEST(R[101], (F + 1.0 <= G + 1.0)); INTFLOATTEST(R[102], (F + 1.0 >= G + 1.0)); INTFLOATTEST(R[103], (F == G + 1.0)); INTFLOATTEST(R[104], (F != G + 1.0)); INTFLOATTEST(R[105], (F < G + 1.0)); INTFLOATTEST(R[106], (F > G + 1.0)); INTFLOATTEST(R[107], (F <= G + 1.0)); INTFLOATTEST(R[108], (F >= G + 1.0)); INTFLOATTEST(R[109], (F + 1.0 == G)); INTFLOATTEST(R[110], (F + 1.0 != G)); INTFLOATTEST(R[111], (F + 1.0 < G)); INTFLOATTEST(R[112], (F + 1.0 > G)); INTFLOATTEST(R[113], (F + 1.0 <= G)); INTFLOATTEST(R[114], (F + 1.0 >= G)); FLOATINTTEST(D[20], ((double) X) + 1.0); INTFLOATTEST(R[115], (long)(F + 1.0)); FLOATTEST(D[21], F + G); FLOATTEST(D[22], G + F); FLOATTEST(D[23], F - G); FLOATTEST(D[24], G - F); FLOATTEST(D[25], F * G); FLOATTEST(D[26], G * F); FLOATTEST(D[27], F / G); FLOATTEST(D[28], G / F); FLOATTEST(D[29], (F * 2.0) + G); FLOATTEST(D[30], G + (F * 2.0)); FLOATTEST(D[31], (F * 2.0) - G); FLOATTEST(D[32], G - (F * 2.0)); FLOATTEST(D[33], (F + 2.0) * G); FLOATTEST(D[34], G * (F + 2.0)); FLOATTEST(D[35], (F * 2.0) / G); FLOATTEST(D[36], G / (F * 2.0)); FLOATTEST(D[37], - F); FLOATTEST(D[38], fabs(F)); } #ifdef __i386__ #ifdef __FreeBSD__ #include #endif #endif void init_ieee_floats(void) { #ifdef __i386__ #ifdef __FreeBSD__ fpsetmask(0); #endif #endif } int main(int argc, char **argv) { double weird[4]; init_ieee_floats(); if (argc >= 5) { X = atoi(argv[1]); Y = atoi(argv[2]); sscanf(argv[3], "%lf", &F); sscanf(argv[4], "%lf", &G); do_test(); return 0; } for(Y = -2; Y <= 2; Y++) { for (X = -2; X <= 2; X++) { F = X; G = Y; do_test(); } } if (!(argc >= 2 && strcmp(argv[1], "noinf"))) { weird[0] = 0.0; weird[1] = 1.0 / weird[0]; /* +infty */ weird[2] = -1.0 / weird[0]; /* -infty */ weird[3] = 0.0 / weird[0]; /* NaN */ for (X = 0; X < 4; X++) { for (Y = 0; Y < 4; Y++) { F = weird[X]; G = weird[Y]; do_test(); } } } while(1) { X = (rand() & 0x1FFFFFFF) - 0x10000000; Y = (rand() & 0x1FFFFFFF) - 0x10000000; F = X / 1e3; G = Y / 1e3; do_test(); printf("."); fflush(stdout); } return 0; } mingw-ocaml/ocaml/testsuite/tests/asmcomp/m68k.S0000644000175000017500000000361112124403241021222 0ustar tootstoots|*********************************************************************** |* * |* OCaml * |* * |* Xavier Leroy, projet Cristal, INRIA Rocquencourt * |* * |* Copyright 1996 Institut National de Recherche en Informatique et * |* en Automatique. All rights reserved. This file is distributed * |* under the terms of the Q Public License version 1.0. * |* * |*********************************************************************** | $Id$ | call_gen_code is used with the following types: | unit -> int | int -> int | int -> double | int * int * address -> void | int * int -> void | unit -> unit | Hence arg1 -> d0, arg2 -> d1, arg3 -> a0, | and we need a special case for int -> double .text .globl _call_gen_code _call_gen_code: link a6, #0 movem d2-d7/a2-a6, a7@- fmovem fp2-fp7, a7@- movel a6@(8), a1 movel a6@(12), d0 movel a6@(16), d1 movel a6@(20), a0 jsr a1@ fmovem a7@+, fp2-fp7 movem a7@+, d2-d7/a2-a6 unlk a6 rts .globl _call_gen_code_float _call_gen_code_float: link a6, #0 moveml d2-d7/a2-a6, a7@- fmovem fp2-fp7, a7@- movel a6@(8), a1 movel a6@(12), d0 jsr a1@ fmoved fp0, a7@- movel a7@+, d0 movel a7@+, d1 fmovem a7@+, fp2-fp7 moveml a7@+, d2-d7/a2-a6 unlk a6 rts .globl _caml_c_call _caml_c_call: jmp a0@ mingw-ocaml/ocaml/testsuite/tests/asmcomp/fib.cmm0000644000175000017500000000165312124403241021553 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (function "fib" (n: int) (if (< n 2) 1 (+ (app "fib" (- n 1) int) (app "fib" (- n 2) int)))) mingw-ocaml/ocaml/testsuite/tests/asmcomp/i386.S0000644000175000017500000000351312124403241021127 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* $Id$ */ /* Linux with ELF binaries does not prefix identifiers with _. Linux with a.out binaries, FreeBSD, and NextStep do. */ #if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \ || defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_gnu) #define G(x) x #define FUNCTION_ALIGN 16 #else #define G(x) _##x #define FUNCTION_ALIGN 4 #endif .globl G(call_gen_code) .align FUNCTION_ALIGN G(call_gen_code): pushl %ebp movl %esp,%ebp pushl %ebx pushl %esi pushl %edi movl 12(%ebp),%eax movl 16(%ebp),%ebx movl 20(%ebp),%ecx movl 24(%ebp),%edx call *8(%ebp) popl %edi popl %esi popl %ebx popl %ebp ret .globl G(caml_c_call) .align FUNCTION_ALIGN G(caml_c_call): ffree %st(0) ffree %st(1) ffree %st(2) ffree %st(3) jmp *%eax .comm G(caml_exception_pointer), 4 .comm G(young_ptr), 4 .comm G(young_start), 4 mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-bytecode/0000755000175000017500000000000012124403241022661 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-dynlink-bytecode/main.reference0000644000175000017500000000030112124403241025457 0ustar tootstootsLoading plug1.cma This is stub1! ABCDEF Loading plug2.cma This is stub2, calling stub1: This is stub1! Ok! This is Plug2.f Result is: 2 This is Plug1.f Result is: 1 This is Main.f Result is: 0 mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-bytecode/.ignore0000644000175000017500000000005312124403241024143 0ustar tootstootsmain static custom custom.exe marshal.data mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-bytecode/Makefile0000644000175000017500000000254112124403241024323 0ustar tootstootsBASEDIR=../.. default: compile run compile: @$(OCAMLC) -c registry.ml @for file in stub*.c; do \ $(OCAMLC) -c $$file; \ $(OCAMLMKLIB) -o `echo $$file | sed -e 's/stub/plug/' | sed -e 's/\.c//'` `basename $$file c`o; \ done @for file in plug*.ml; do \ $(OCAMLC) -c $$file; \ $(OCAMLMKLIB) -o `basename $$file .ml` `basename $$file ml`cmo; \ done @$(OCAMLC) -c main.ml @$(OCAMLC) -o main dynlink.cma registry.cmo main.cmo @$(OCAMLC) -o static -linkall registry.cmo plug1.cma plug2.cma -use-runtime $(PREFIX)/bin/ocamlrun @$(OCAMLC) -o custom -custom -linkall registry.cmo plug2.cma plug1.cma -I . run: @printf " ... testing 'main'" @export LD_LIBRARY_PATH=`pwd` && ./main plug1.cma plug2.cma > main.result @$(DIFF) main.reference main.result > /dev/null || (echo " => failed" && exit 1) @echo " => passed" @printf " ... testing 'static'" @export LD_LIBRARY_PATH=`pwd` && ./static > static.result @$(DIFF) static.reference static.result > /dev/null || (echo " => failed" && exit 1) @echo " => passed" @printf " ... testing 'custom'" @export LD_LIBRARY_PATH=`pwd` && ./custom > custom.result @$(DIFF) custom.reference custom.result > /dev/null || (echo " => failed" && exit 1) @echo " => passed" promote: defaultpromote clean: defaultclean @rm -f ./main ./static ./custom *.result marshal.data include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-bytecode/plug1.ml0000644000175000017500000000023512124403241024243 0ustar tootstootsexternal stub1: unit -> string = "stub1" let f x = print_string "This is Plug1.f\n"; x + 1 let () = Registry.register f let () = print_endline (stub1 ()) mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-bytecode/main.ml0000644000175000017500000000206212124403241024137 0ustar tootstootslet f x = print_string "This is Main.f\n"; x let () = Registry.register f let _ = Dynlink.init (); Dynlink.allow_unsafe_modules true; for i = 1 to Array.length Sys.argv - 1 do let name = Sys.argv.(i) in Printf.printf "Loading %s\n" name; flush stdout; try if name.[0] = '-' then Dynlink.loadfile_private (String.sub name 1 (String.length name - 1)) else Dynlink.loadfile name with | Dynlink.Error err -> Printf.printf "Dynlink error: %s\n" (Dynlink.error_message err) | exn -> Printf.printf "Error: %s\n" (Printexc.to_string exn) done; flush stdout; try let oc = open_out_bin "marshal.data" in Marshal.to_channel oc (Registry.get_functions()) [Marshal.Closures]; close_out oc; let ic = open_in_bin "marshal.data" in let l = (Marshal.from_channel ic : (int -> int) list) in close_in ic; List.iter (fun f -> let res = f 0 in Printf.printf "Result is: %d\n" res) l with Failure s -> Printf.printf "Failure: %s\n" s mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-bytecode/registry.ml0000644000175000017500000000020212124403241025055 0ustar tootstootslet functions = ref ([]: (int -> int) list) let register f = functions := f :: !functions let get_functions () = !functions mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-bytecode/static.reference0000644000175000017500000000010712124403241026026 0ustar tootstootsThis is stub1! ABCDEF This is stub2, calling stub1: This is stub1! Ok! mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-bytecode/custom.reference0000644000175000017500000000010712124403241026051 0ustar tootstootsThis is stub2, calling stub1: This is stub1! Ok! This is stub1! ABCDEF mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-bytecode/plug2.ml0000644000175000017500000000021312124403241024240 0ustar tootstootsexternal stub2: unit -> unit = "stub2" let f x = print_string "This is Plug2.f\n"; x + 2 let () = Registry.register f let () = stub2 () mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-bytecode/stub1.c0000644000175000017500000000033712124403241024066 0ustar tootstoots#include "caml/mlvalues.h" #include "caml/memory.h" #include "caml/alloc.h" #include value stub1() { CAMLlocal1(x); printf("This is stub1!\n"); fflush(stdout); x = caml_copy_string("ABCDEF"); return x; } mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-bytecode/stub2.c0000644000175000017500000000040712124403241024065 0ustar tootstoots#include "caml/mlvalues.h" #include "caml/memory.h" #include "caml/alloc.h" #include extern value stub1(); value stub2() { printf("This is stub2, calling stub1:\n"); fflush(stdout); stub1(); printf("Ok!\n"); fflush(stdout); return Val_unit; } mingw-ocaml/ocaml/testsuite/tests/regression-camlp4-class-type-plus/0000755000175000017500000000000012124403241025252 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/regression-camlp4-class-type-plus/.gitignore0000644000175000017500000000000012124403241027230 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-hashtbl/0000755000175000017500000000000012124403241021042 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-hashtbl/Makefile0000644000175000017500000000015112124403241022477 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-hashtbl/htbl.ml0000644000175000017500000001221712124403241022330 0ustar tootstoots(* Hashtable operations, using maps as a reference *) open Printf module Test(H: Hashtbl.S) (M: Map.S with type key = H.key) = struct let incl_mh m h = try M.iter (fun k d -> let d' = H.find h k in if d <> d' then raise Exit) m; true with Exit | Not_found -> false let domain_hm h m = try H.iter (fun k d -> if not (M.mem k m) then raise Exit) h; true with Exit -> false let incl_hm h m = try H.iter (fun k d -> let d' = M.find k m in if d <> d' then raise Exit) h; true with Exit | Not_found -> false let test data = let n = Array.length data in let h = H.create 51 and m = ref M.empty in (* Insert all data with H.add *) Array.iter (fun (k, d) -> H.add h k d; m := M.add k d !m) data; printf "Insertion: %s\n" (if incl_mh !m h && domain_hm h !m then "passed" else "FAILED"); (* Insert all data with H.replace *) H.clear h; m := M.empty; Array.iter (fun (k, d) -> H.replace h k d; m := M.add k d !m) data; printf "Insertion: %s\n" (if incl_mh !m h && incl_hm h !m then "passed" else "FAILED"); (* Remove some of the data *) for i = 0 to n/3 - 1 do let (k, _) = data.(i) in H.remove h k; m := M.remove k !m done; printf "Removal: %s\n" (if incl_mh !m h && incl_hm h !m then "passed" else "FAILED") end module MS = Map.Make(struct type t = string let compare (x:t) (y:t) = Pervasives.compare x y end) module MI = Map.Make(struct type t = int let compare (x:t) (y:t) = Pervasives.compare x y end) module MSP = Map.Make(struct type t = string*string let compare (x:t) (y:t) = Pervasives.compare x y end) module MSL = Map.Make(struct type t = string list let compare (x:t) (y:t) = Pervasives.compare x y end) (* Generic hash wrapped as a functorial hash *) module HofM (M: Map.S) : Hashtbl.S with type key = M.key = struct type key = M.key type 'a t = (key, 'a) Hashtbl.t let create s = Hashtbl.create s let clear = Hashtbl.clear let reset = Hashtbl.reset let copy = Hashtbl.copy let add = Hashtbl.add let remove = Hashtbl.remove let find = Hashtbl.find let find_all = Hashtbl.find_all let replace = Hashtbl.replace let mem = Hashtbl.mem let iter = Hashtbl.iter let fold = Hashtbl.fold let length = Hashtbl.length let stats = Hashtbl.stats end module HS1 = HofM(MS) module HI1 = HofM(MI) module HSP = HofM(MSP) module HSL = HofM(MSL) (* Specific functorial hashes *) module HS2 = Hashtbl.Make(struct type t = string let equal (x:t) (y:t) = x=y let hash = Hashtbl.hash end) module HI2 = Hashtbl.Make(struct type t = int let equal (x:t) (y:t) = x=y let hash = Hashtbl.hash end) (* Instantiating the test *) module TS1 = Test(HS1)(MS) module TS2 = Test(HS2)(MS) module TI1 = Test(HI1)(MI) module TI2 = Test(HI2)(MI) module TSP = Test(HSP)(MSP) module TSL = Test(HSL)(MSL) (* Data set: strings from a file, associated with their line number *) let file_data filename = let ic = open_in filename in let lineno = ref 0 in let data = ref [] in begin try while true do let l = input_line ic in incr lineno; data := (l, !lineno) :: !data done with End_of_file -> () end; close_in ic; Array.of_list !data (* Data set: fixed strings *) let string_data = [| "Si", 0; "non", 1; "e", 2; "vero", 3; "e", 4; "ben", 5; "trovato", 6; "An", 10; "apple", 11; "a", 12; "day", 13; "keeps", 14; "the", 15; "doctor", 16; "away", 17; "Pierre", 20; "qui", 21; "roule", 22; "n'amasse", 23; "pas", 24; "mousse", 25; "Asinus", 30; "asinum", 31; "fricat", 32 |] (* Data set: random integers *) let random_integers num range = let data = Array.make num (0,0) in for i = 0 to num - 1 do data.(i) <- (Random.int range, i) done; data (* Data set: pairs *) let pair_data data = Array.map (fun (k, d) -> ((k, k), d)) data (* Data set: lists *) let list_data data = let d = Array.make (Array.length data / 10) ([], 0) in let j = ref 0 in let rec mklist n = if n <= 0 || !j >= Array.length data then [] else begin let hd = fst data.(!j) in incr j; let tl = mklist (n-1) in hd :: tl end in for i = 0 to Array.length d - 1 do d.(i) <- (mklist (Random.int 16), i) done; d (* The test *) let _ = printf "-- Random integers, large range\n%!"; TI1.test (random_integers 100_000 1_000_000); printf "-- Random integers, narrow range\n%!"; TI2.test (random_integers 100_000 1_000); let d = try file_data "/usr/share/dict/words" with Sys_error _ -> string_data in printf "-- Strings, generic interface\n%!"; TS1.test d; printf "-- Strings, functorial interface\n%!"; TS2.test d; printf "-- Pairs of strings\n%!"; TSP.test (pair_data d); printf "-- Lists of strings\n%!"; TSL.test (list_data d) mingw-ocaml/ocaml/testsuite/tests/lib-hashtbl/hfun.reference0000644000175000017500000000063012124403241023661 0ustar tootstoots-- Strings: "" 00000000 "Hello world" 364b8272 -- Integers: 0 07be548a -1 3653e015 42 1792870b 2^30-1 23c392d0 -2^30 0c66fde3 -- Floats: +0.0 0f478b8c -0.0 0f478b8c +infty 23ea56fb -infty 059f7872 NaN 3228858d NaN#2 3228858d NaN#3 3228858d -- Native integers: 0 3f19274a -1 3653e015 42 3e33aef8 2^30-1 3711bf46 -2^30 2e71f39c -- Lists: [0..10] 0ade0fc9 [0..12] 0ade0fc9 [10..0] 0cd6259d mingw-ocaml/ocaml/testsuite/tests/lib-hashtbl/hfun.ml0000644000175000017500000000303312124403241022333 0ustar tootstoots(* Testing the hash function Hashtbl.hash *) (* What is tested: - reproducibility on various platforms, esp. 32/64 bit issues - equal values hash equally, esp NaNs. *) open Printf let _ = printf "-- Strings:\n"; printf "\"\"\t\t%08x\n" (Hashtbl.hash ""); printf "\"Hello world\"\t%08x\n" (Hashtbl.hash "Hello world"); printf "-- Integers:\n"; printf "0\t\t%08x\n" (Hashtbl.hash 0); printf "-1\t\t%08x\n" (Hashtbl.hash (-1)); printf "42\t\t%08x\n" (Hashtbl.hash 42); printf "2^30-1\t\t%08x\n" (Hashtbl.hash 0x3FFF_FFFF); printf "-2^30\t\t%08x\n" (Hashtbl.hash (-0x4000_0000)); printf "-- Floats:\n"; printf "+0.0\t\t%08x\n" (Hashtbl.hash 0.0); printf "-0.0\t\t%08x\n" (Hashtbl.hash (-. 0.0)); printf "+infty\t\t%08x\n" (Hashtbl.hash infinity); printf "-infty\t\t%08x\n" (Hashtbl.hash neg_infinity); printf "NaN\t\t%08x\n" (Hashtbl.hash nan); printf "NaN#2\t\t%08x\n" (Hashtbl.hash (Int64.float_of_bits 0xFF_F0_00_12_34_56_78_9AL)); printf "NaN#3\t\t%08x\n" (Hashtbl.hash (0.0 /. 0.0)); printf "-- Native integers:\n"; printf "0\t\t%08x\n" (Hashtbl.hash 0n); printf "-1\t\t%08x\n" (Hashtbl.hash (-1n)); printf "42\t\t%08x\n" (Hashtbl.hash 42n); printf "2^30-1\t\t%08x\n" (Hashtbl.hash 0x3FFF_FFFFn); printf "-2^30\t\t%08x\n" (Hashtbl.hash (-0x4000_0000n)); printf "-- Lists:\n"; printf "[0..10]\t\t%08x\n" (Hashtbl.hash [0;1;2;3;4;5;6;7;8;9;10]); printf "[0..12]\t\t%08x\n" (Hashtbl.hash [0;1;2;3;4;5;6;7;8;9;10;11;12]); printf "[10..0]\t\t%08x\n" (Hashtbl.hash [10;9;8;7;6;5;4;3;2;1;0]); () mingw-ocaml/ocaml/testsuite/tests/lib-hashtbl/htbl.reference0000644000175000017500000000074012124403241023654 0ustar tootstoots-- Random integers, large range Insertion: passed Insertion: passed Removal: passed -- Random integers, narrow range Insertion: passed Insertion: passed Removal: passed -- Strings, generic interface Insertion: passed Insertion: passed Removal: passed -- Strings, functorial interface Insertion: passed Insertion: passed Removal: passed -- Pairs of strings Insertion: passed Insertion: passed Removal: passed -- Lists of strings Insertion: passed Insertion: passed Removal: passed mingw-ocaml/ocaml/testsuite/tests/regression/0000755000175000017500000000000012124403241021031 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/regression/camlp4-class-type-plus/0000755000175000017500000000000012124403241025254 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/regression/camlp4-class-type-plus/Makefile0000644000175000017500000000023412124403241026713 0ustar tootstootsADD_COMPFLAGS = -pp 'camlp4o' MAIN_MODULE = camlp4_class_type_plus_ok include ../../../makefiles/Makefile.okbad include ../../../makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/regression/camlp4-class-type-plus/camlp4_class_type_plus_ok.ml0000644000175000017500000000022312124403241032745 0ustar tootstootstype t;; type xdr_value;; class type [ 't ] engine = object end;; module type T = sig class unbound_async_call : t -> [xdr_value] engine;; end;; mingw-ocaml/ocaml/testsuite/tests/regression/pr5080-notes/0000755000175000017500000000000012124403241023115 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml0000644000175000017500000000014112124403241026302 0ustar tootstootslet marshal_int f = match [] with | _ :: `INT n :: _ -> f n | _ -> failwith "marshal_int" mingw-ocaml/ocaml/testsuite/tests/regression/pr5080-notes/Makefile0000644000175000017500000000023712124403241024557 0ustar tootstootsADD_COMPFLAGS = -pp 'camlp4o pa_macro.cmo' MAIN_MODULE = pr5080_notes_ok include ../../../makefiles/Makefile.okbad include ../../../makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/regression/pr5757/0000755000175000017500000000000012124403241022002 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/regression/pr5757/Makefile0000644000175000017500000000014712124403241023444 0ustar tootstootsMAIN_MODULE=pr5757 include ../../../makefiles/Makefile.one include ../../../makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/regression/pr5757/pr5757.ml0000644000175000017500000000017712124403241023312 0ustar tootstootsRandom.init 3;; for i = 0 to 100_000 do ignore (String.create (Random.int 1_000_000)) done;; Printf.printf "hello world\n";; mingw-ocaml/ocaml/testsuite/tests/regression/pr5757/pr5757.reference0000644000175000017500000000001412124403241024626 0ustar tootstootshello world mingw-ocaml/ocaml/testsuite/tests/regression/pr5233/0000755000175000017500000000000012124403241021767 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/regression/pr5233/Makefile0000644000175000017500000000014712124403241023431 0ustar tootstootsMAIN_MODULE=pr5233 include ../../../makefiles/Makefile.one include ../../../makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/regression/pr5233/pr5233.ml0000644000175000017500000000236312124403241023263 0ustar tootstootsopen Printf;; (* PR#5233: Create a dangling pointer and use it to access random parts of the heap. *) (* The buggy weak array will end up in smuggle. *) let smuggle = ref (Weak.create 1);; (* This will be the weak array (W). *) let t = ref (Weak.create 1);; (* Set a finalisation function on W. *) Gc.finalise (fun w -> smuggle := w) !t;; (* Free W and run its finalisation function. *) t := Weak.create 1;; Gc.full_major ();; (* smuggle now contains W, whose pointers are not erased, even when the contents is deallocated. *) let size = 1_000_000;; let check o = printf "checking..."; match o with | None -> printf " no value\n"; | Some s -> printf " value found / testing..."; for i = 0 to size - 1 do if s.[i] != ' ' then failwith "bad"; done; printf " ok\n"; ;; Weak.set !smuggle 0 (Some (String.make size ' '));; (* Check the data just to make sure. *) check (Weak.get !smuggle 0);; (* Get a dangling pointer in W. *) Gc.full_major ();; (* Fill the heap with other stuff. *) let rec fill n accu = if n = 0 then accu else fill (n-1) (123 :: accu);; let r = fill ((Gc.stat ()).Gc.heap_words / 3) [];; Gc.minor ();; (* Now follow the dangling pointer and exhibit the problem. *) check (Weak.get !smuggle 0);; mingw-ocaml/ocaml/testsuite/tests/regression/pr5233/pr5233.reference0000644000175000017500000000007712124403241024611 0ustar tootstootschecking... value found / testing... ok checking... no value mingw-ocaml/ocaml/testsuite/tests/lib-num/0000755000175000017500000000000012124403241020214 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-num/end_test.reference0000644000175000017500000001101512124403241023677 0ustar tootstoots num_digits_nat -1... 0... 1... length_nat 1... equal_nat 1... 2... 3... 4... incr_nat 1... 2... 3... 4... decr_nat 1... 2... 3... 4... is_zero_nat 1... 2... 3... 4... string_of_nat 1... 2... string_of_nat && nat_of_string 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... gcd_nat 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... sqrt_nat 1... 2... 3... 4... 5... compare_big_int 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... pred_big_int 1... 2... 3... succ_big_int 1... 2... 3... add_big_int 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... sub_big_int 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... mult_int_big_int 1... 2... 3... 4... mult_big_int 1... 2... 3... 4... 5... quomod_big_int 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... 23... 24... 25... gcd_big_int 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... 23... 24... 25... 26... 27... 28... int_of_big_int 1... 2... 3... 4... 5... 6... 7... 8... is_int_big_int 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... sys_string_of_big_int 1... big_int_of_string 1... 2... 4... 5... 6... 7... 9... 10... power_base_int 1... 2... 3... base_power_big_int 1... 2... 3... power_int_positive_big_int 1... 2... 3... 4... 5... 6... 7... power_big_int_positive_int 1... 2... 3... 4... 5... power_big_int_positive_big_int 1... 2... 3... 4... 5... 6... 7... 8... 9... square_big_int 1... 2... 3... 4... big_int_of_nativeint 1... 2... 3... nativeint_of_big_int 1... 2... 2... big_int_of_int32 1... 2... 3... int32_of_big_int 1... 2... 3... 4... 5... 6... 7... 8... big_int_of_int64 1... 2... 3... 4... 5... 6... 7... 8... int64_of_big_int 1... 2... 3... 4... 5... 6... 7... 8... and_big_int 1... 2... 3... 4... 5... 6... or_big_int 1... 2... 3... 4... 5... 6... xor_big_int 1... 2... 3... 4... 5... 6... shift_left_big_int 1... 2... 2... 3... 4... 5... 6... shift_right_big_int 1... 2... 3... 4... 5... 6... shift_right_towards_zero_big_int 1... 2... extract_big_int 1... 2... 3... 4... 5... 6... hashing of big integers 1... 2... 3... 4... 5... 6... create_ratio 1... 2... 3... 4... 5... 6... 7... 8... create_normalized_ratio 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... null_denominator 1... 2... sign_ratio 1... 2... 3... normalize_ratio 1... 2... 3... 4... report_sign_ratio 1... 2... is_integer_ratio 1... 2... add_ratio 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 1... 2... 3... 4... sub_ratio 1... 2... 3... 4... 5... 6... 7... 8... mult_ratio 1... 2... 3... 4... 5... 6... 7... 8... div_ratio 1... 2... 3... 4... 5... 6... 7... 8... integer_ratio 1... 2... 3... 4... 5... floor_ratio 1... 2... 3... 4... 5... round_ratio 1... 2... 3... 4... 5... ceiling_ratio 1... 2... 3... 4... 5... 6... eq_ratio 1... 2... 3... 4... 5... compare_ratio 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... 23... 24... 25... 26... 27... 28... 29... 30... 31... 32... 33... 34... 35... 36... eq_big_int_ratio 1... 2... 3... 4... 5... compare_big_int_ratio 1... 2... 3... 4... 5... 6... 7... 8... 9... int_of_ratio 1... 2... 3... 4... 5... ratio_of_int 1... 2... nat_of_ratio 1... 2... 3... 4... ratio_of_big_int 1... big_int_of_ratio 1... 2... 3... string_of_ratio 1... 2... 3... 4... ratio_of_string 1... 6... 7... 8... round_futur_last_digit 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... 23... 24... approx_ratio_fix 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... approx_ratio_exp 1... 2... 3... 4... 5... 6... 7... 8... 9... add_num 1... 2... 3... 4... 5... 6... 7... 8... 9... sub_num 1... 2... 3... 4... 5... 7... 8... 9... 10... mult_num 1... 2... 3... 4... 5... 6... 7... 8... 9... div_num 1... 2... 3... 4... 5... 6... 7... 8... 9... is_integer_num 1... 2... 3... 4... num_of_ratio 1... 2... 3... num_of_string 1... 7... 8... 11... output_value/input_value on nats 1... 2... 3... 4... 5... 6... 7... output_value/input_value on big ints 1... 2... 3... 4... 5... output_value/input_value on nums 1... 2... 3... 4... 5... 6... 7... 8... ************* TESTS COMPLETED SUCCESSFULLY **************** mingw-ocaml/ocaml/testsuite/tests/lib-num/test_nats.ml0000644000175000017500000000660712124403241022563 0ustar tootstootsopen Test;; open Nat;; (* Can compare nats less than 2**32 *) let equal_nat n1 n2 = eq_nat n1 0 (num_digits_nat n1 0 1) n2 0 (num_digits_nat n2 0 1);; testing_function "num_digits_nat";; test (-1) eq (false,not true);; test 0 eq (true,not false);; test 1 eq_int (let r = make_nat 2 in set_digit_nat r 1 1; num_digits_nat r 0 1,1);; testing_function "length_nat";; test 1 eq_int (let r = make_nat 2 in set_digit_nat r 0 1; length_nat r,2);; testing_function "equal_nat";; let zero_nat = make_nat 1 in test 1 equal_nat (zero_nat,zero_nat);; test 2 equal_nat (nat_of_int 1,nat_of_int 1);; test 3 equal_nat (nat_of_string "2",nat_of_string "2");; test 4 eq (equal_nat (nat_of_string "2")(nat_of_string "3"),false);; testing_function "incr_nat";; let zero = nat_of_int 0 in let res = incr_nat zero 0 1 1 in test 1 equal_nat (zero, nat_of_int 1) && test 2 eq (res,0);; let n = nat_of_int 1 in let res = incr_nat n 0 1 1 in test 3 equal_nat (n, nat_of_int 2) && test 4 eq (res,0);; testing_function "decr_nat";; let n = nat_of_int 1 in let res = decr_nat n 0 1 0 in test 1 equal_nat (n, nat_of_int 0) && test 2 eq (res,1);; let n = nat_of_int 2 in let res = decr_nat n 0 1 0 in test 3 equal_nat (n, nat_of_int 1) && test 4 eq (res,1);; testing_function "is_zero_nat";; let n = nat_of_int 1 in test 1 eq (is_zero_nat n 0 1,false) && test 2 eq (is_zero_nat (make_nat 1) 0 1, true) && test 3 eq (is_zero_nat (make_nat 2) 0 2, true) && (let r = make_nat 2 in set_digit_nat r 1 1; test 4 eq (is_zero_nat r 0 1, true)) ;; testing_function "string_of_nat";; let n = make_nat 4;; test 1 eq_string (string_of_nat n, "0");; complement_nat n 0 (if sixtyfour then 2 else 4);; test 2 eq_string (string_of_nat n, "340282366920938463463374607431768211455");; testing_function "string_of_nat && nat_of_string";; for i = 1 to 20 do let s = String.make i '0' in String.set s 0 '1'; ignore (test i eq_string (string_of_nat (nat_of_string s), s)) done;; let set_mult_digit_nat n1 d1 l1 n2 d2 l2 n3 d3 = ignore (mult_digit_nat n1 d1 l1 n2 d2 l2 n3 d3) ;; let s = "3333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333" in test 21 equal_nat ( nat_of_string s, (let nat = make_nat 15 in set_digit_nat nat 0 3; set_mult_digit_nat nat 0 15 (nat_of_string (String.sub s 0 135)) 0 14 (nat_of_int 10) 0; nat)) ;; test 22 eq_string (string_of_nat(nat_of_string "1073741824"), "1073741824");; testing_function "gcd_nat";; for i = 1 to 20 do let n1 = Random.int 1000000000 and n2 = Random.int 100000 in let nat1 = nat_of_int n1 and nat2 = nat_of_int n2 in ignore (gcd_nat nat1 0 1 nat2 0 1); ignore (test i eq (int_of_nat nat1, gcd_int n1 n2)) done ;; testing_function "sqrt_nat";; test 1 equal_nat (sqrt_nat (nat_of_int 1) 0 1, nat_of_int 1);; test 2 equal_nat (let n = nat_of_string "8589934592" in sqrt_nat n 0 (length_nat n), nat_of_string "92681");; test 3 equal_nat (let n = nat_of_string "4294967295" in sqrt_nat n 0 (length_nat n), nat_of_string "65535");; test 4 equal_nat (let n = nat_of_string "18446744065119617025" in sqrt_nat n 0 (length_nat n), nat_of_string "4294967295");; test 5 equal_nat (sqrt_nat (nat_of_int 15) 0 1, nat_of_int 3);; mingw-ocaml/ocaml/testsuite/tests/lib-num/Makefile0000644000175000017500000000034012124403241021651 0ustar tootstootsBASEDIR=../.. MODULES=test test_nats test_big_ints test_ratios test_nums test_io MAIN_MODULE=end_test ADD_COMPFLAGS=-w a LIBRARIES=nums include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-num/test_io.ml0000644000175000017500000000255312124403241022221 0ustar tootstootsopen Test open Nat open Big_int open Num let intern_extern obj = let f = Filename.temp_file "testnum" ".data" in let oc = open_out_bin f in output_value oc obj; close_out oc; let ic = open_in_bin f in let res = input_value ic in close_in ic; Sys.remove f; res ;; testing_function "output_value/input_value on nats";; let equal_nat n1 n2 = eq_nat n1 0 (length_nat n1) n2 0 (length_nat n2) ;; List.iter (fun (i, s) -> let n = nat_of_string s in ignore(test i equal_nat (n, intern_extern n))) [1, "0"; 2, "1234"; 3, "8589934592"; 4, "340282366920938463463374607431768211455"; 5, String.make 100 '3'; 6, String.make 1000 '9'; 7, String.make 20000 '8'] ;; testing_function "output_value/input_value on big ints";; List.iter (fun (i, s) -> let b = big_int_of_string s in ignore(test i eq_big_int (b, intern_extern b))) [1, "0"; 2, "1234"; 3, "-1234"; 4, "1040259735709286400"; 5, "-" ^ String.make 20000 '7'] ;; testing_function "output_value/input_value on nums";; List.iter (fun (i, s) -> let n = num_of_string s in ignore(test i eq_num (n, intern_extern n))) [1, "0"; 2, "1234"; 3, "-1234"; 4, "159873568791325097646845892426782"; 5, "1/4"; 6, "-15/2"; 7, "159873568791325097646845892426782/24098772507410987265987"; 8, String.make 10000 '3' ^ "/" ^ String.make 5000 '7'] ;; mingw-ocaml/ocaml/testsuite/tests/lib-num/test_big_ints.ml0000644000175000017500000010371712124403241023414 0ustar tootstootsopen Test;; open Nat;; open Big_int;; open List;; testing_function "compare_big_int";; test 1 eq_int (compare_big_int zero_big_int zero_big_int, 0);; test 2 eq_int (compare_big_int zero_big_int (big_int_of_int 1), (-1));; test 3 eq_int (compare_big_int zero_big_int (big_int_of_int (-1)), 1);; test 4 eq_int (compare_big_int (big_int_of_int 1) zero_big_int, 1);; test 5 eq_int (compare_big_int (big_int_of_int (-1)) zero_big_int, (-1));; test 6 eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int 1), 0);; test 7 eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), 0);; test 8 eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int (-1)), 1);; test 9 eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int 1), (-1));; test 10 eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int 2), (-1));; test 11 eq_int (compare_big_int (big_int_of_int 2) (big_int_of_int 1), 1);; test 12 eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), 1);; test 13 eq_int (compare_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), (-1));; testing_function "pred_big_int";; test 1 eq_big_int (pred_big_int zero_big_int, big_int_of_int (-1));; test 2 eq_big_int (pred_big_int unit_big_int, zero_big_int);; test 3 eq_big_int (pred_big_int (big_int_of_int (-1)), big_int_of_int (-2));; testing_function "succ_big_int";; test 1 eq_big_int (succ_big_int zero_big_int, unit_big_int);; test 2 eq_big_int (succ_big_int unit_big_int, big_int_of_int 2);; test 3 eq_big_int (succ_big_int (big_int_of_int (-1)), zero_big_int);; testing_function "add_big_int";; test 1 eq_big_int (add_big_int zero_big_int zero_big_int, zero_big_int);; test 2 eq_big_int (add_big_int zero_big_int (big_int_of_int 1), big_int_of_int 1);; test 3 eq_big_int (add_big_int (big_int_of_int 1) zero_big_int, big_int_of_int 1);; test 4 eq_big_int (add_big_int zero_big_int (big_int_of_int (-1)), big_int_of_int (-1));; test 5 eq_big_int (add_big_int (big_int_of_int (-1)) zero_big_int, big_int_of_int (-1));; test 6 eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 1), big_int_of_int 2);; test 7 eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 2), big_int_of_int 3);; test 8 eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int 1), big_int_of_int 3);; test 9 eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), big_int_of_int (-2));; test 10 eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), big_int_of_int (-3));; test 11 eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), big_int_of_int (-3));; test 12 eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-1)), zero_big_int);; test 13 eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 1), zero_big_int);; test 14 eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-2)), big_int_of_int (-1));; test 15 eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int 1), big_int_of_int (-1));; test 16 eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 2), big_int_of_int 1);; test 17 eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int (-1)), big_int_of_int 1);; testing_function "sub_big_int";; test 1 eq_big_int (sub_big_int zero_big_int zero_big_int, zero_big_int);; test 2 eq_big_int (sub_big_int zero_big_int (big_int_of_int 1), big_int_of_int (-1));; test 3 eq_big_int (sub_big_int (big_int_of_int 1) zero_big_int, big_int_of_int 1);; test 4 eq_big_int (sub_big_int zero_big_int (big_int_of_int (-1)), big_int_of_int 1);; test 5 eq_big_int (sub_big_int (big_int_of_int (-1)) zero_big_int, big_int_of_int (-1));; test 6 eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 1), zero_big_int);; test 7 eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 2), big_int_of_int (-1));; test 8 eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int 1), big_int_of_int 1);; test 9 eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), zero_big_int);; test 10 eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), big_int_of_int 1);; test 11 eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), big_int_of_int (-1));; test 12 eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-1)), big_int_of_int 2);; test 13 eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 1), big_int_of_int (-2));; test 14 eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-2)), big_int_of_int 3);; test 15 eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int 1), big_int_of_int (-3));; test 16 eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 2), big_int_of_int (-3));; test 17 eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int (-1)), big_int_of_int 3);; testing_function "mult_int_big_int";; test 1 eq_big_int (mult_int_big_int 0 (big_int_of_int 3), zero_big_int);; test 2 eq_big_int (mult_int_big_int 1 (big_int_of_int 3), big_int_of_int 3);; test 3 eq_big_int (mult_int_big_int 1 zero_big_int, zero_big_int);; test 4 eq_big_int (mult_int_big_int 2 (big_int_of_int 3), big_int_of_int 6);; testing_function "mult_big_int";; test 1 eq_big_int (mult_big_int zero_big_int zero_big_int, zero_big_int);; test 2 eq_big_int (mult_big_int (big_int_of_int 2) (big_int_of_int 3), big_int_of_int 6);; test 3 eq_big_int (mult_big_int (big_int_of_int 2) (big_int_of_int (-3)), big_int_of_int (-6));; test 4 eq_big_int (mult_big_int (big_int_of_string "12724951") (big_int_of_string "81749606400"), big_int_of_string "1040259735709286400");; test 5 eq_big_int (mult_big_int (big_int_of_string "26542080") (big_int_of_string "81749606400"), big_int_of_string "2169804593037312000");; testing_function "quomod_big_int";; let (quotient, modulo) = quomod_big_int (big_int_of_int 1) (big_int_of_int 1) in test 1 eq_big_int (quotient, big_int_of_int 1) && test 2 eq_big_int (modulo, zero_big_int);; let (quotient, modulo) = quomod_big_int (big_int_of_int 1) (big_int_of_int (-1)) in test 3 eq_big_int (quotient, big_int_of_int (-1)) && test 4 eq_big_int (modulo, zero_big_int);; let (quotient, modulo) = quomod_big_int (big_int_of_int (-1)) (big_int_of_int 1) in test 5 eq_big_int (quotient, big_int_of_int (-1)) && test 6 eq_big_int (modulo, zero_big_int);; let (quotient, modulo) = quomod_big_int (big_int_of_int 3) (big_int_of_int 2) in test 7 eq_big_int (quotient, big_int_of_int 1) && test 8 eq_big_int (modulo, big_int_of_int 1);; let (quotient, modulo) = quomod_big_int (big_int_of_int 5) (big_int_of_int 3) in test 9 eq_big_int (quotient, big_int_of_int 1) && test 10 eq_big_int (modulo, big_int_of_int 2);; let (quotient, modulo) = quomod_big_int (big_int_of_int (-5)) (big_int_of_int 3) in test 11 eq_big_int (quotient, big_int_of_int (-2)) && test 12 eq_big_int (modulo, big_int_of_int 1);; let (quotient, modulo) = quomod_big_int (big_int_of_int 1) (big_int_of_int 2) in test 13 eq_big_int (quotient, zero_big_int) && test 14 eq_big_int (modulo, big_int_of_int 1);; let (quotient, modulo) = quomod_big_int (big_int_of_int (-1)) (big_int_of_int 3) in test 15 eq_big_int (quotient, minus_big_int unit_big_int) && test 16 eq_big_int (modulo, big_int_of_int 2);; failwith_test 17 (quomod_big_int (big_int_of_int 1)) zero_big_int Division_by_zero ;; let (quotient, modulo) = quomod_big_int (big_int_of_int 10) (big_int_of_int 20) in test 18 eq_big_int (quotient, big_int_of_int 0) && test 19 eq_big_int (modulo, big_int_of_int 10);; let (quotient, modulo) = quomod_big_int (big_int_of_int (-10)) (big_int_of_int 20) in test 20 eq_big_int (quotient, big_int_of_int (-1)) && test 21 eq_big_int (modulo, big_int_of_int 10);; let (quotient, modulo) = quomod_big_int (big_int_of_int 10) (big_int_of_int (-20)) in test 22 eq_big_int (quotient, big_int_of_int 0) && test 23 eq_big_int (modulo, big_int_of_int 10);; let (quotient, modulo) = quomod_big_int (big_int_of_int (-10)) (big_int_of_int (-20)) in test 24 eq_big_int (quotient, big_int_of_int 1) && test 25 eq_big_int (modulo, big_int_of_int 10);; testing_function "gcd_big_int";; test 1 eq_big_int (gcd_big_int zero_big_int zero_big_int, zero_big_int);; test 2 eq_big_int (gcd_big_int zero_big_int (big_int_of_int 1), big_int_of_int 1);; test 3 eq_big_int (gcd_big_int (big_int_of_int 1) zero_big_int, big_int_of_int 1);; test 4 eq_big_int (gcd_big_int (big_int_of_int 1) (big_int_of_int 2), big_int_of_int 1);; test 5 eq_big_int (gcd_big_int (big_int_of_int 2) (big_int_of_int 1), big_int_of_int 1);; test 6 eq_big_int (gcd_big_int (big_int_of_int 1) (big_int_of_int 1), big_int_of_int 1);; test 7 eq_big_int (gcd_big_int (big_int_of_int 9) (big_int_of_int 16), big_int_of_int 1);; test 8 eq_big_int (gcd_big_int (big_int_of_int 12) (big_int_of_int 16), big_int_of_int 4);; for i = 9 to 28 do let n1 = Random.int 1000000000 and n2 = Random.int 100000 in let _ = test i eq (int_of_big_int (gcd_big_int (big_int_of_int n1) (big_int_of_int n2)), gcd_int n1 n2) in () done;; testing_function "int_of_big_int";; test 1 eq_int (int_of_big_int (big_int_of_int 1), 1);; test 2 eq_int (int_of_big_int (big_int_of_int(-1)), -1);; test 3 eq_int (int_of_big_int zero_big_int, 0);; test 4 eq_int (int_of_big_int (big_int_of_int max_int), max_int);; test 5 eq_int (int_of_big_int (big_int_of_int min_int), min_int);; failwith_test 6 (fun () -> int_of_big_int (succ_big_int (big_int_of_int max_int))) () (Failure "int_of_big_int");; failwith_test 7 (fun () -> int_of_big_int (pred_big_int (big_int_of_int min_int))) () (Failure "int_of_big_int");; failwith_test 8 (fun () -> int_of_big_int (mult_big_int (big_int_of_int min_int) (big_int_of_int 2))) () (Failure "int_of_big_int");; testing_function "is_int_big_int";; test 1 eq (is_int_big_int (big_int_of_int 1), true);; test 2 eq (is_int_big_int (big_int_of_int (-1)), true);; test 3 eq (is_int_big_int (succ_big_int (big_int_of_int biggest_int)), false);; test 4 eq (int_of_big_int (big_int_of_int monster_int), monster_int);; (* Should be true *) test 5 eq (is_int_big_int (big_int_of_string (string_of_int biggest_int)), true);; test 6 eq (is_int_big_int (big_int_of_string (string_of_int least_int)), true);; test 7 eq (is_int_big_int (big_int_of_string (string_of_int monster_int)), true);; (* Should be false *) (* Successor of biggest_int is not an int *) test 8 eq (is_int_big_int (succ_big_int (big_int_of_int (biggest_int))), false);; test 9 eq (is_int_big_int (succ_big_int (succ_big_int (big_int_of_int (biggest_int)))), false);; (* Negation of monster_int (as a big_int) is not an int *) test 10 eq (is_int_big_int (minus_big_int (big_int_of_string (string_of_int monster_int))), false);; testing_function "sys_string_of_big_int";; test 1 eq_string (string_of_big_int (big_int_of_int 1), "1");; testing_function "big_int_of_string";; test 1 eq_big_int (big_int_of_string "1", big_int_of_int 1);; test 2 eq_big_int (big_int_of_string "-1", big_int_of_int (-1));; test 4 eq_big_int (big_int_of_string "0", zero_big_int);; failwith_test 5 big_int_of_string "sdjdkfighdgf" (Failure "invalid digit");; test 6 eq_big_int (big_int_of_string "123", big_int_of_int 123);; test 7 eq_big_int (big_int_of_string "3456", big_int_of_int 3456);; test 9 eq_big_int (big_int_of_string "-3456", big_int_of_int (-3456));; let implode = List.fold_left (^) "";; (* Au diable l'efficacite *) let l = rev [ "174679877494298468451661416292903906557638850173895426081611831060970135303"; "044177587617233125776581034213405720474892937404345377707655788096850784519"; "539374048533324740018513057210881137248587265169064879918339714405948322501"; "445922724181830422326068913963858377101914542266807281471620827145038901025"; "322784396182858865537924078131032036927586614781817695777639491934361211399"; "888524140253852859555118862284235219972858420374290985423899099648066366558"; "238523612660414395240146528009203942793935957539186742012316630755300111472"; "852707974927265572257203394961525316215198438466177260614187266288417996647"; "132974072337956513457924431633191471716899014677585762010115338540738783163"; "739223806648361958204720897858193606022290696766988489073354139289154127309"; "916985231051926209439373780384293513938376175026016587144157313996556653811"; "793187841050456120649717382553450099049321059330947779485538381272648295449"; "847188233356805715432460040567660999184007627415398722991790542115164516290"; "619821378529926683447345857832940144982437162642295073360087284113248737998"; "046564369129742074737760485635495880623324782103052289938185453627547195245"; "688272436219215066430533447287305048225780425168823659431607654712261368560"; "702129351210471250717394128044019490336608558608922841794819375031757643448"; "32" ] in let bi1 = big_int_of_string (implode (rev l)) in let bi2 = big_int_of_string (implode (rev ("3" :: tl l))) in test 10 eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "10")) (big_int_of_string "2"))) (* test 11 && eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "10e0")) (big_int_of_string "20e-1"))) && test 12 eq_big_int (minus_big_int bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "-10e0")) (big_int_of_string "-20e-1"))) && test 13 eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "+10e0")) (big_int_of_string "+20e-1"))) && test 14 eq_big_int (minus_big_int bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "-10e+0")) (big_int_of_string "-20e-1"))) && test 15 eq_big_int (minus_big_int bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "-1e+1")) (big_int_of_string "-2e-0"))) && test 16 eq_big_int (minus_big_int bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "-0.1e+2")) (big_int_of_string "-2.0e-0"))) && test 17 eq_big_int (minus_big_int bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "-1.000e+1")) (big_int_of_string "-0.02e2")))*) ;; testing_function "power_base_int";; test 1 eq_big_int (big_int_of_nat (power_base_int 10 0), unit_big_int) ;; test 2 eq_big_int (big_int_of_nat (power_base_int 10 8), big_int_of_int 100000000) ;; test 3 eq_big_int (big_int_of_nat (power_base_int 2 (length_of_int + 2)), big_int_of_nat (let nat = make_nat 2 in set_digit_nat nat 1 1; nat)) ;; testing_function "base_power_big_int";; test 1 eq_big_int (base_power_big_int 10 0 (big_int_of_int 2), big_int_of_int 2);; test 2 eq_big_int (base_power_big_int 10 2 (big_int_of_int 2), big_int_of_int 200);; test 3 eq_big_int (base_power_big_int 10 1 (big_int_of_int 123), big_int_of_int 1230) ;; testing_function "power_int_positive_big_int";; test 1 eq_big_int (power_int_positive_big_int 2 (big_int_of_int 10), big_int_of_int 1024);; test 2 eq_big_int (power_int_positive_big_int 2 (big_int_of_int 65), big_int_of_string "36893488147419103232");; test 3 eq_big_int (power_int_positive_big_int 3 (big_int_of_string "47"), big_int_of_string "26588814358957503287787");; test 4 eq_big_int (power_int_positive_big_int 1 (big_int_of_string "1000000000000000000000"), big_int_of_int 1);; test 5 eq_big_int (power_int_positive_big_int (-1) (big_int_of_string "1000000000000000000000"), big_int_of_int 1);; test 6 eq_big_int (power_int_positive_big_int (-1) (big_int_of_string "1000000000000000000001"), big_int_of_int (-1));; test 7 eq_big_int (power_int_positive_big_int 0 (big_int_of_string "1000000000000000000000"), big_int_of_int 0);; testing_function "power_big_int_positive_int";; test 1 eq_big_int (power_big_int_positive_int (big_int_of_int 2) 10, big_int_of_int 1024);; test 2 eq_big_int (power_big_int_positive_int (big_int_of_int 100) 20, big_int_of_string "10000000000000000000000000000000000000000");; test 3 eq_big_int (power_big_int_positive_int (big_int_of_string "3") 47, big_int_of_string "26588814358957503287787");; test 4 eq_big_int (power_big_int_positive_int (big_int_of_string "200000000000000") 34, big_int_of_string "17179869184000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000000000000\ 00000000000");; test 5 eq_big_int (power_big_int_positive_int (big_int_of_string "2197609328765") 243, big_int_of_string "12415638672345366257764851943822299490113545698929764576040102857365\ 27920436565335427676982530274588056944387957287793378051852205028658\ 73008292720317554332284838709453634119919368441951233982592586680844\ 20765201140575612595182857026804842796931784944918059630667794516774\ 58498235838834599150657873894983300999081942159304585449505963892008\ 97855706440206825609657816209327492197604711437269361628626691080334\ 38432768885637928268354258860147333786379766583179851226375449161073\ 10396958979998161989562418169797611757651190037273397850239552735199\ 63719988832594486235837899145390948533078339399890545062510060406048\ 61331200657727576638170520036143007285549092686618686739320973444703\ 33342725604091818763255601206325426337211467746377586080108631634250\ 11232258578207762608797108802386708549785680783113606089879687396654\ 54004281165259352412815385041917713969718327109245777066079665194617\ 29230093411050053217775067781725651590160086483960457766025246936489\ 92234225900994076609973190516835778346886551506344097474301175288686\ 25662752919718480402972207084177612056491949911377568680526080633587\ 33230060757162252611388973328501680433819585006035301408574879645573\ 47126018243568976860515247053858204554293343161581801846081341003624\ 22906934772131205632200433218165757307182816260714026614324014553342\ 77303133877636489457498062819003614421295692889321460150481573909330\ 77301946991278225819671075907191359721824291923283322225480199446258\ 03302645587072103949599624444368321734975586414930425964782010567575\ 43333331963876294983400462908871215572514487548352925949663431718284\ 14589547315559936497408670231851521193150991888789948397029796279240\ 53117024758684807981605608837291399377902947471927467827290844733264\ 70881963357258978768427852958888430774360783419404195056122644913454\ 24537375432013012467418602205343636983874410969339344956536142566292\ 67710105053213729008973121773436382170956191942409859915563249876601\ 97309463059908818473774872128141896864070835259683384180928526600888\ 17480854811931632353621014638284918544379784608050029606475137979896\ 79160729736625134310450643341951675749112836007180865039256361941093\ 99844921135320096085772541537129637055451495234892640418746420370197\ 76655592198723057553855194566534999101921182723711243608938705766658\ 35660299983828999383637476407321955462859142012030390036241831962713\ 40429407146441598507165243069127531565881439971034178400174881243483\ 00001434950666035560134867554719667076133414445044258086968145695386\ 00575860256380332451841441394317283433596457253185221717167880159573\ 60478649571700878049257386910142909926740023800166057094445463624601\ 79490246367497489548435683835329410376623483996271147060314994344869\ 89606855219181727424853876740423210027967733989284801813769926906846\ 45570461348452758744643550541290031199432061998646306091218518879810\ 17848488755494879341886158379140088252013009193050706458824793551984\ 39285914868159111542391208521561221610797141925061986437418522494485\ 59871215531081904861310222368465288125816137210222223075106739997863\ 76953125");; testing_function "power_big_int_positive_big_int";; test 1 eq_big_int (power_big_int_positive_big_int (big_int_of_int 2) (big_int_of_int 10), big_int_of_int 1024);; test 2 eq_big_int (power_big_int_positive_big_int (big_int_of_int 2) (big_int_of_int 65), big_int_of_string "36893488147419103232");; test 3 eq_big_int (power_big_int_positive_big_int (big_int_of_string "3") (big_int_of_string "47"), big_int_of_string "26588814358957503287787");; test 4 eq_big_int (power_big_int_positive_big_int (big_int_of_string "200000000000000") (big_int_of_int 34), big_int_of_string "17179869184000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000000000000\ 00000000000");; test 5 eq_big_int (power_big_int_positive_big_int (big_int_of_string "2197609328765") (big_int_of_string "243"), big_int_of_string "12415638672345366257764851943822299490113545698929764576040102857365\ 27920436565335427676982530274588056944387957287793378051852205028658\ 73008292720317554332284838709453634119919368441951233982592586680844\ 20765201140575612595182857026804842796931784944918059630667794516774\ 58498235838834599150657873894983300999081942159304585449505963892008\ 97855706440206825609657816209327492197604711437269361628626691080334\ 38432768885637928268354258860147333786379766583179851226375449161073\ 10396958979998161989562418169797611757651190037273397850239552735199\ 63719988832594486235837899145390948533078339399890545062510060406048\ 61331200657727576638170520036143007285549092686618686739320973444703\ 33342725604091818763255601206325426337211467746377586080108631634250\ 11232258578207762608797108802386708549785680783113606089879687396654\ 54004281165259352412815385041917713969718327109245777066079665194617\ 29230093411050053217775067781725651590160086483960457766025246936489\ 92234225900994076609973190516835778346886551506344097474301175288686\ 25662752919718480402972207084177612056491949911377568680526080633587\ 33230060757162252611388973328501680433819585006035301408574879645573\ 47126018243568976860515247053858204554293343161581801846081341003624\ 22906934772131205632200433218165757307182816260714026614324014553342\ 77303133877636489457498062819003614421295692889321460150481573909330\ 77301946991278225819671075907191359721824291923283322225480199446258\ 03302645587072103949599624444368321734975586414930425964782010567575\ 43333331963876294983400462908871215572514487548352925949663431718284\ 14589547315559936497408670231851521193150991888789948397029796279240\ 53117024758684807981605608837291399377902947471927467827290844733264\ 70881963357258978768427852958888430774360783419404195056122644913454\ 24537375432013012467418602205343636983874410969339344956536142566292\ 67710105053213729008973121773436382170956191942409859915563249876601\ 97309463059908818473774872128141896864070835259683384180928526600888\ 17480854811931632353621014638284918544379784608050029606475137979896\ 79160729736625134310450643341951675749112836007180865039256361941093\ 99844921135320096085772541537129637055451495234892640418746420370197\ 76655592198723057553855194566534999101921182723711243608938705766658\ 35660299983828999383637476407321955462859142012030390036241831962713\ 40429407146441598507165243069127531565881439971034178400174881243483\ 00001434950666035560134867554719667076133414445044258086968145695386\ 00575860256380332451841441394317283433596457253185221717167880159573\ 60478649571700878049257386910142909926740023800166057094445463624601\ 79490246367497489548435683835329410376623483996271147060314994344869\ 89606855219181727424853876740423210027967733989284801813769926906846\ 45570461348452758744643550541290031199432061998646306091218518879810\ 17848488755494879341886158379140088252013009193050706458824793551984\ 39285914868159111542391208521561221610797141925061986437418522494485\ 59871215531081904861310222368465288125816137210222223075106739997863\ 76953125");; test 6 eq_big_int (power_big_int_positive_big_int (big_int_of_int 1) (big_int_of_string "1000000000000000000000"), big_int_of_int 1);; test 7 eq_big_int (power_big_int_positive_big_int (big_int_of_int (-1)) (big_int_of_string "1000000000000000000000"), big_int_of_int 1);; test 8 eq_big_int (power_big_int_positive_big_int (big_int_of_int (-1)) (big_int_of_string "1000000000000000000001"), big_int_of_int (-1));; test 9 eq_big_int (power_big_int_positive_big_int (big_int_of_int 0) (big_int_of_string "1000000000000000000000"), big_int_of_int 0);; testing_function "square_big_int";; test 1 eq_big_int (square_big_int (big_int_of_string "0"), big_int_of_string "0");; test 2 eq_big_int (square_big_int (big_int_of_string "1"), big_int_of_string "1");; test 3 eq_big_int (square_big_int (big_int_of_string "-1"), big_int_of_string "1");; test 4 eq_big_int (square_big_int (big_int_of_string "-7"), big_int_of_string "49");; testing_function "big_int_of_nativeint";; test 1 eq_big_int (big_int_of_nativeint 0n, zero_big_int);; test 2 eq_big_int (big_int_of_nativeint 1234n, big_int_of_string "1234");; test 3 eq_big_int (big_int_of_nativeint (-1234n), big_int_of_string "-1234");; testing_function "nativeint_of_big_int";; test 1 eq_nativeint (nativeint_of_big_int zero_big_int, 0n);; test 2 eq_nativeint (nativeint_of_big_int (big_int_of_string "1234"), 1234n);; test 2 eq_nativeint (nativeint_of_big_int (big_int_of_string "-1234"), -1234n);; testing_function "big_int_of_int32";; test 1 eq_big_int (big_int_of_int32 0l, zero_big_int);; test 2 eq_big_int (big_int_of_int32 2147483647l, big_int_of_string "2147483647");; test 3 eq_big_int (big_int_of_int32 (-2147483648l), big_int_of_string "-2147483648");; testing_function "int32_of_big_int";; test 1 eq_int32 (int32_of_big_int zero_big_int, 0l);; test 2 eq_int32 (int32_of_big_int (big_int_of_string "2147483647"), 2147483647l);; test 3 eq_int32 (int32_of_big_int (big_int_of_string "-2147483648"), -2147483648l);; test 4 eq_int32 (int32_of_big_int (big_int_of_string "-2147"), -2147l);; let should_fail s = try ignore (int32_of_big_int (big_int_of_string s)); 0 with Failure _ -> 1;; test 5 eq_int (should_fail "2147483648", 1);; test 6 eq_int (should_fail "-2147483649", 1);; test 7 eq_int (should_fail "4294967296", 1);; test 8 eq_int (should_fail "18446744073709551616", 1);; testing_function "big_int_of_int64";; test 1 eq_big_int (big_int_of_int64 0L, zero_big_int);; test 2 eq_big_int (big_int_of_int64 9223372036854775807L, big_int_of_string "9223372036854775807");; test 3 eq_big_int (big_int_of_int64 (-9223372036854775808L), big_int_of_string "-9223372036854775808");; test 4 eq_big_int (*PR#4792*) (big_int_of_int64 (Int64.of_int32 Int32.min_int), big_int_of_string "-2147483648");; test 5 eq_big_int (big_int_of_int64 1234L, big_int_of_string "1234");; test 6 eq_big_int (big_int_of_int64 0x1234567890ABCDEFL, big_int_of_string "1311768467294899695");; test 7 eq_big_int (big_int_of_int64 (-1234L), big_int_of_string "-1234");; test 8 eq_big_int (big_int_of_int64 (-0x1234567890ABCDEFL), big_int_of_string "-1311768467294899695");; testing_function "int64_of_big_int";; test 1 eq_int64 (int64_of_big_int zero_big_int, 0L);; test 2 eq_int64 (int64_of_big_int (big_int_of_string "9223372036854775807"), 9223372036854775807L);; test 3 eq_int64 (int64_of_big_int (big_int_of_string "-9223372036854775808"), -9223372036854775808L);; test 4 eq_int64 (int64_of_big_int (big_int_of_string "-9223372036854775"), -9223372036854775L);; test 5 eq_int64 (* PR#4804 *) (int64_of_big_int (big_int_of_string "2147483648"), 2147483648L);; let should_fail s = try ignore (int64_of_big_int (big_int_of_string s)); 0 with Failure _ -> 1;; test 6 eq_int (should_fail "9223372036854775808", 1);; test 7 eq_int (should_fail "-9223372036854775809", 1);; test 8 eq_int (should_fail "18446744073709551616", 1);; (* build a 128-bit big int from two int64 *) let big_int_128 hi lo = add_big_int (mult_big_int (big_int_of_int64 hi) (big_int_of_string "18446744073709551616")) (big_int_of_int64 lo);; let h1 = 0x7fd05b7ee46a29f8L and h2 = 0x64b28b8ee70b6e6dL and h3 = 0x58546e563f5b44f0L and h4 = 0x1db72f6377ff3ec6L and h5 = 0x4f9bb0a19c543cb1L;; testing_function "and_big_int";; test 1 eq_big_int (and_big_int unit_big_int zero_big_int, zero_big_int);; test 2 eq_big_int (and_big_int zero_big_int unit_big_int, zero_big_int);; test 3 eq_big_int (and_big_int unit_big_int unit_big_int, unit_big_int);; test 4 eq_big_int (and_big_int (big_int_128 h1 h2) (big_int_128 h3 h4), big_int_128 (Int64.logand h1 h3) (Int64.logand h2 h4));; test 5 eq_big_int (and_big_int (big_int_128 h1 h2) (big_int_of_int64 h5), big_int_of_int64 (Int64.logand h2 h5));; test 6 eq_big_int (and_big_int (big_int_of_int64 h5) (big_int_128 h3 h4) , big_int_of_int64 (Int64.logand h5 h4));; testing_function "or_big_int";; test 1 eq_big_int (or_big_int unit_big_int zero_big_int, unit_big_int);; test 2 eq_big_int (or_big_int zero_big_int unit_big_int, unit_big_int);; test 3 eq_big_int (or_big_int unit_big_int unit_big_int, unit_big_int);; test 4 eq_big_int (or_big_int (big_int_128 h1 h2) (big_int_128 h3 h4), big_int_128 (Int64.logor h1 h3) (Int64.logor h2 h4));; test 5 eq_big_int (or_big_int (big_int_128 h1 h2) (big_int_of_int64 h5), big_int_128 h1 (Int64.logor h2 h5));; test 6 eq_big_int (or_big_int (big_int_of_int64 h5) (big_int_128 h3 h4) , big_int_128 h3 (Int64.logor h5 h4));; testing_function "xor_big_int";; test 1 eq_big_int (xor_big_int unit_big_int zero_big_int, unit_big_int);; test 2 eq_big_int (xor_big_int zero_big_int unit_big_int, unit_big_int);; test 3 eq_big_int (xor_big_int unit_big_int unit_big_int, zero_big_int);; test 4 eq_big_int (xor_big_int (big_int_128 h1 h2) (big_int_128 h3 h4), big_int_128 (Int64.logxor h1 h3) (Int64.logxor h2 h4));; test 5 eq_big_int (xor_big_int (big_int_128 h1 h2) (big_int_of_int64 h5), big_int_128 h1 (Int64.logxor h2 h5));; test 6 eq_big_int (xor_big_int (big_int_of_int64 h5) (big_int_128 h3 h4) , big_int_128 h3 (Int64.logxor h5 h4));; testing_function "shift_left_big_int";; test 1 eq_big_int (shift_left_big_int unit_big_int 0, unit_big_int);; test 2 eq_big_int (shift_left_big_int unit_big_int 1, big_int_of_int 2);; test 2 eq_big_int (shift_left_big_int unit_big_int 31, big_int_of_string "2147483648");; test 3 eq_big_int (shift_left_big_int unit_big_int 64, big_int_of_string "18446744073709551616");; test 4 eq_big_int (shift_left_big_int unit_big_int 95, big_int_of_string "39614081257132168796771975168");; test 5 eq_big_int (shift_left_big_int (big_int_of_string "39614081257132168796771975168") 67, big_int_of_string "5846006549323611672814739330865132078623730171904");; test 6 eq_big_int (shift_left_big_int (big_int_of_string "-39614081257132168796771975168") 67, big_int_of_string "-5846006549323611672814739330865132078623730171904");; testing_function "shift_right_big_int";; test 1 eq_big_int (shift_right_big_int unit_big_int 0, unit_big_int);; test 2 eq_big_int (shift_right_big_int (big_int_of_int 12345678) 3, big_int_of_int 1543209);; test 3 eq_big_int (shift_right_big_int (big_int_of_string "5299989648942") 32, big_int_of_int 1234);; test 4 eq_big_int (shift_right_big_int (big_int_of_string "5846006549323611672814739330865132078623730171904") 67, big_int_of_string "39614081257132168796771975168");; test 5 eq_big_int (shift_right_big_int (big_int_of_string "-5299989648942") 32, big_int_of_int (-1235));; test 6 eq_big_int (shift_right_big_int (big_int_of_string "-16570089876543209725755392") 27, big_int_of_string "-123456790123456789");; testing_function "shift_right_towards_zero_big_int";; test 1 eq_big_int (shift_right_towards_zero_big_int (big_int_of_string "-5299989648942") 32, big_int_of_int (-1234));; test 2 eq_big_int (shift_right_towards_zero_big_int (big_int_of_string "-16570089876543209725755392") 27, big_int_of_string "-123456790123456789");; testing_function "extract_big_int";; test 1 eq_big_int (extract_big_int (big_int_of_int64 0x123456789ABCDEFL) 3 13, big_int_of_int 6589);; test 2 eq_big_int (extract_big_int (big_int_128 h1 h2) 67 12, big_int_of_int 1343);; test 3 eq_big_int (extract_big_int (big_int_of_string "-1844674407370955178") 37 9, big_int_of_int 307);; test 4 eq_big_int (extract_big_int unit_big_int 2048 254, zero_big_int);; test 5 eq_big_int (extract_big_int (big_int_of_int64 0x123456789ABCDEFL) 0 32, big_int_of_int64 2309737967L);; test 6 eq_big_int (extract_big_int (big_int_of_int (-1)) 2048 254, zero_big_int);; testing_function "hashing of big integers";; test 1 eq_int (Hashtbl.hash zero_big_int, 955772237);; test 2 eq_int (Hashtbl.hash unit_big_int, 992063522);; test 3 eq_int (Hashtbl.hash (minus_big_int unit_big_int), 161678167);; test 4 eq_int (Hashtbl.hash (big_int_of_string "123456789123456789"), 755417385);; test 5 eq_int (Hashtbl.hash (sub_big_int (big_int_of_string "123456789123456789") (big_int_of_string "123456789123456789")), 955772237);; test 6 eq_int (Hashtbl.hash (sub_big_int (big_int_of_string "123456789123456789") (big_int_of_string "123456789123456788")), 992063522);; mingw-ocaml/ocaml/testsuite/tests/lib-num/test_ratios.ml0000644000175000017500000010141712124403241023112 0ustar tootstootsopen Test;; open Nat;; open Big_int;; open Ratio;; open Arith_status;; set_error_when_null_denominator false ;; let infinite_failure = "infinite or undefined rational number";; testing_function "create_ratio" ;; let r = create_ratio (big_int_of_int 1) (big_int_of_int (-2)) in test 1 eq_big_int (numerator_ratio r, big_int_of_int (-1)) && test 2 eq_big_int (denominator_ratio r, big_int_of_int 2) ;; let r = create_ratio (big_int_of_int 2) (big_int_of_int 3) in test 3 eq_big_int (numerator_ratio r, big_int_of_int 2) && test 4 eq_big_int (denominator_ratio r, big_int_of_int 3) ;; set_normalize_ratio true ;; let r = create_ratio (big_int_of_int 12) (big_int_of_int (-16)) in test 5 eq_big_int (numerator_ratio r, big_int_of_int (-3)) && test 6 eq_big_int (denominator_ratio r, big_int_of_int 4) ;; set_normalize_ratio false ;; let r = create_ratio (big_int_of_int 0) (big_int_of_int 0) in test 7 eq_big_int (numerator_ratio r, big_int_of_int 0) && test 8 eq_big_int (denominator_ratio r, big_int_of_int 0) ;; testing_function "create_normalized_ratio" ;; let r = create_normalized_ratio (big_int_of_int 1) (big_int_of_int (-2)) in test 1 eq_big_int (numerator_ratio r, big_int_of_int (-1)) && test 2 eq_big_int (denominator_ratio r, big_int_of_int 2) ;; let r = create_normalized_ratio (big_int_of_int 2) (big_int_of_int 3) in test 3 eq_big_int (numerator_ratio r, big_int_of_int 2) && test 4 eq_big_int (denominator_ratio r, big_int_of_int 3) ;; set_normalize_ratio true ;; let r = create_normalized_ratio (big_int_of_int 12) (big_int_of_int (-16)) in test 5 eq_big_int (numerator_ratio r, big_int_of_int (-12)) && test 6 eq_big_int (denominator_ratio r, big_int_of_int 16) ;; set_normalize_ratio false ;; let r = create_normalized_ratio (big_int_of_int 1) (big_int_of_int 0) in test 7 eq_big_int (numerator_ratio r, big_int_of_int 1) && test 8 eq_big_int (denominator_ratio r, big_int_of_int 0) ;; let r = create_normalized_ratio (big_int_of_int 0) (big_int_of_int 0) in test 9 eq_big_int (numerator_ratio r, big_int_of_int 0) && test 10 eq_big_int (denominator_ratio r, big_int_of_int 0) ;; testing_function "null_denominator" ;; test 1 eq (null_denominator (create_ratio (big_int_of_int 1) (big_int_of_int (-2))), false) ;; test 2 eq (null_denominator (create_ratio (big_int_of_int 1) zero_big_int),true) ;; (***** testing_function "verify_null_denominator" ;; test 1 eq (verify_null_denominator (ratio_of_string "0/1"), false) ;; test 2 eq (verify_null_denominator (ratio_of_string "0/0"), true) ;; *****) testing_function "sign_ratio" ;; test 1 eq_int (sign_ratio (create_ratio (big_int_of_int (-2)) (big_int_of_int (-3))), 1) ;; test 2 eq_int (sign_ratio (create_ratio (big_int_of_int 2) (big_int_of_int (-3))), (-1)) ;; test 3 eq_int (sign_ratio (create_ratio zero_big_int (big_int_of_int (-3))), 0) ;; testing_function "normalize_ratio" ;; let r = create_ratio (big_int_of_int 12) (big_int_of_int (-16)) in ignore (normalize_ratio r); test 1 eq_big_int (numerator_ratio r, big_int_of_int (-3)) && test 2 eq_big_int (denominator_ratio r, big_int_of_int 4) ;; let r = create_ratio (big_int_of_int (-1)) zero_big_int in ignore (normalize_ratio r); test 3 eq_big_int (numerator_ratio r, big_int_of_int (-1)) && test 4 eq_big_int (denominator_ratio r, zero_big_int) ;; testing_function "report_sign_ratio" ;; test 1 eq_big_int (report_sign_ratio (create_ratio (big_int_of_int 2) (big_int_of_int (-3))) (big_int_of_int 1), big_int_of_int (-1)) ;; test 2 eq_big_int (report_sign_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (big_int_of_int 1), big_int_of_int 1) ;; testing_function "is_integer_ratio" ;; test 1 eq (is_integer_ratio (create_ratio (big_int_of_int 2) (big_int_of_int (-1))), true) ;; test 2 eq (is_integer_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)), false) ;; testing_function "add_ratio" ;; let r = add_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 2)) (create_ratio (big_int_of_int 2) (big_int_of_int 3)) in test 1 eq_big_int (numerator_ratio r, big_int_of_int 7) && test 2 eq_big_int (denominator_ratio r, big_int_of_int 6) ;; let r = add_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in test 3 eq_big_int (numerator_ratio r, big_int_of_int 1) && test 4 eq_big_int (denominator_ratio r, big_int_of_int 6) ;; let r = add_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in test 5 eq_big_int (numerator_ratio r, big_int_of_int 4) && test 6 eq_big_int (denominator_ratio r, zero_big_int) ;; let r = add_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 1) zero_big_int) in test 7 eq_big_int (numerator_ratio r, big_int_of_int 3) && test 8 eq_big_int (denominator_ratio r, zero_big_int) ;; let r = add_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) zero_big_int) in test 9 eq_big_int (numerator_ratio r, zero_big_int) && test 10 eq_big_int (denominator_ratio r, zero_big_int) ;; let r = add_ratio (create_ratio (big_int_of_string "12724951") (big_int_of_string "26542080")) (create_ratio (big_int_of_string "-1") (big_int_of_string "81749606400")) in test 11 eq_big_int (numerator_ratio r, big_int_of_string "1040259735682744320") && test 12 eq_big_int (denominator_ratio r, big_int_of_string "2169804593037312000") ;; let r1,r2 = (create_ratio (big_int_of_string "12724951") (big_int_of_string "26542080"), create_ratio (big_int_of_string "-1") (big_int_of_string "81749606400")) in let bi1 = mult_big_int (numerator_ratio r1) (denominator_ratio r2) and bi2 = mult_big_int (numerator_ratio r2) (denominator_ratio r1) in test 1 eq_big_int (bi1, big_int_of_string "1040259735709286400") && test 2 eq_big_int (bi2, big_int_of_string "-26542080") && test 3 eq_big_int (mult_big_int (denominator_ratio r1) (denominator_ratio r2), big_int_of_string "2169804593037312000") && test 4 eq_big_int (add_big_int bi1 bi2, big_int_of_string "1040259735682744320") ;; testing_function "sub_ratio" ;; let r = sub_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 1) (big_int_of_int 2)) in test 1 eq_big_int (numerator_ratio r, big_int_of_int 1) && test 2 eq_big_int (denominator_ratio r, big_int_of_int 6) ;; let r = sub_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in test 3 eq_big_int (numerator_ratio r, big_int_of_int 4) && test 4 eq_big_int (denominator_ratio r, zero_big_int) ;; let r = sub_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 1) zero_big_int) in test 5 eq_big_int (numerator_ratio r, big_int_of_int (-3)) && test 6 eq_big_int (denominator_ratio r, zero_big_int) ;; let r = sub_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) zero_big_int) in test 7 eq_big_int (numerator_ratio r, zero_big_int) && test 8 eq_big_int (denominator_ratio r, zero_big_int) ;; testing_function "mult_ratio" ;; let r = mult_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 7) (big_int_of_int 5)) in test 1 eq_big_int (numerator_ratio r, big_int_of_int 14) && test 2 eq_big_int (denominator_ratio r, big_int_of_int 15) ;; let r = mult_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in test 3 eq_big_int (numerator_ratio r, big_int_of_int (-2)) && test 4 eq_big_int (denominator_ratio r, zero_big_int) ;; let r = mult_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 1) zero_big_int) in test 5 eq_big_int (numerator_ratio r, big_int_of_int 2) && test 6 eq_big_int (denominator_ratio r, zero_big_int) ;; let r = mult_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) zero_big_int) in test 7 eq_big_int (numerator_ratio r, big_int_of_int 2) && test 8 eq_big_int (denominator_ratio r, zero_big_int) ;; testing_function "div_ratio" ;; let r = div_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 5) (big_int_of_int 7)) in test 1 eq_big_int (numerator_ratio r, big_int_of_int 14) && test 2 eq_big_int (denominator_ratio r, big_int_of_int 15) ;; let r = div_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in test 3 eq_big_int (numerator_ratio r, big_int_of_int (-4)) && test 4 eq_big_int (denominator_ratio r, zero_big_int) ;; let r = div_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 1) zero_big_int) in test 5 eq_big_int (numerator_ratio r, zero_big_int) && test 6 eq_big_int (denominator_ratio r, big_int_of_int 3) ;; let r = div_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) zero_big_int) in test 7 eq_big_int (numerator_ratio r, zero_big_int) && test 8 eq_big_int (denominator_ratio r, zero_big_int) ;; testing_function "integer_ratio" ;; test 1 eq_big_int (integer_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)), big_int_of_int 1) ;; test 2 eq_big_int (integer_ratio (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), big_int_of_int (-1)) ;; test 3 eq_big_int (integer_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)), big_int_of_int 1) ;; test 4 eq_big_int (integer_ratio (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), big_int_of_int (-1)) ;; failwith_test 5 integer_ratio (create_ratio (big_int_of_int 3) zero_big_int) (Failure("integer_ratio "^infinite_failure)) ;; testing_function "floor_ratio" ;; test 1 eq_big_int (floor_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)), big_int_of_int 1) ;; test 2 eq_big_int (floor_ratio (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), big_int_of_int (-2)) ;; test 3 eq_big_int (floor_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)), big_int_of_int 1) ;; test 4 eq_big_int (floor_ratio (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), big_int_of_int (-2)) ;; failwith_test 5 floor_ratio (create_ratio (big_int_of_int 3) zero_big_int) Division_by_zero ;; testing_function "round_ratio" ;; test 1 eq_big_int (round_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)), big_int_of_int 2) ;; test 2 eq_big_int (round_ratio (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), big_int_of_int (-2)) ;; test 3 eq_big_int (round_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)), big_int_of_int 2) ;; test 4 eq_big_int (round_ratio (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), big_int_of_int (-2)) ;; failwith_test 5 round_ratio (create_ratio (big_int_of_int 3) zero_big_int) Division_by_zero ;; testing_function "ceiling_ratio" ;; test 1 eq_big_int (ceiling_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)), big_int_of_int 2) ;; test 2 eq_big_int (ceiling_ratio (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), big_int_of_int (-1)) ;; test 3 eq_big_int (ceiling_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)), big_int_of_int 2) ;; test 4 eq_big_int (ceiling_ratio (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), big_int_of_int (-1)) ;; test 5 eq_big_int (ceiling_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 2)), big_int_of_int 2) ;; failwith_test 6 ceiling_ratio (create_ratio (big_int_of_int 3) zero_big_int) Division_by_zero ;; testing_function "eq_ratio" ;; test 1 eq_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3), create_ratio (big_int_of_int (-20)) (big_int_of_int (-12))) ;; test 2 eq_ratio (create_ratio (big_int_of_int 1) zero_big_int, create_ratio (big_int_of_int 2) zero_big_int) ;; let neq_ratio x y = not (eq_ratio x y);; test 3 neq_ratio (create_ratio (big_int_of_int 1) zero_big_int, create_ratio (big_int_of_int (-1)) zero_big_int) ;; test 4 neq_ratio (create_ratio (big_int_of_int 1) zero_big_int, create_ratio zero_big_int zero_big_int) ;; test 5 eq_ratio (create_ratio zero_big_int zero_big_int, create_ratio zero_big_int zero_big_int) ;; testing_function "compare_ratio" ;; test 1 eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0) ;; test 2 eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) (create_ratio (big_int_of_int 1) (big_int_of_int 0)), 0) ;; test 3 eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), 0) ;; test 4 eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0) ;; test 5 eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0) ;; test 6 eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) (create_ratio (big_int_of_int 5) (big_int_of_int 3)), 0) ;; test 7 eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0) ;; test 8 eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)), 0) ;; test 9 eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)) (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0) ;; test 10 eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) (create_ratio (big_int_of_int 0) (big_int_of_int 1)), 0) ;; test 11 eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 1)) (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0) ;; test 12 eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (create_ratio (big_int_of_int 1) (big_int_of_int 0)), 0) ;; test 13 eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (create_ratio (big_int_of_int 2) (big_int_of_int 0)), 0) ;; test 14 eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), 1) ;; test 15 eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) (create_ratio (big_int_of_int 1) (big_int_of_int 0)), (-1)) ;; test 16 eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) (create_ratio (big_int_of_int 1) (big_int_of_int 0)), (-1)) ;; test 17 eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (create_ratio (big_int_of_int 5) (big_int_of_int 3)), 1) ;; test 18 eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)) (create_ratio (big_int_of_int 1) (big_int_of_int 0)), (-1)) ;; test 19 eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)), 1) ;; test 20 eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (create_ratio (big_int_of_int 0) (big_int_of_int 3)), 1) ;; test 21 eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), 0) ;; test 22 eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) (create_ratio (big_int_of_int (-2)) (big_int_of_int 0)), 0) ;; test 23 eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), 1) ;; test 24 eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) (create_ratio (big_int_of_int 5) (big_int_of_int 3)), (-1)) ;; test 25 eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)) (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), 1) ;; test 26 eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)), (-1)) ;; test 27 eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) (create_ratio (big_int_of_int 0) (big_int_of_int 3)), (-1)) ;; test 28 eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) (create_ratio (big_int_of_int 3) (big_int_of_int 2)), 1) ;; test 29 eq_int (compare_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)) (create_ratio (big_int_of_int 5) (big_int_of_int 3)), (-1)) ;; test 30 eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)), 1) ;; test 31 eq_int (compare_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)) (create_ratio (big_int_of_int 5) (big_int_of_int 3)), (-1)) ;; test 32 eq_int (compare_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)) (create_ratio (big_int_of_int 0) (big_int_of_int 3)), 1) ;; test 33 eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2)) (create_ratio (big_int_of_int 5) (big_int_of_int 3)), (-1)) ;; test 34 eq_int (compare_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)) (create_ratio (big_int_of_int 0) (big_int_of_int 3)), (-1)) ;; test 35 eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2)) (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)), 1) ;; test 36 eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2)) (create_ratio (big_int_of_int 0) (big_int_of_int 3)), 0) ;; testing_function "eq_big_int_ratio" ;; test 1 eq_big_int_ratio (big_int_of_int 3, (create_ratio (big_int_of_int 3) (big_int_of_int 1))) ;; test 2 eq (not (eq_big_int_ratio (big_int_of_int 1) (create_ratio (big_int_of_int 3) (big_int_of_int 1))), true) ;; test 3 eq (not (eq_big_int_ratio (big_int_of_int 1) (create_ratio (big_int_of_int 3) (big_int_of_int 2))), true) ;; test 4 eq (not (eq_big_int_ratio (big_int_of_int 1) (create_ratio (big_int_of_int 3) (big_int_of_int 0))), true) ;; test 5 eq (not (eq_big_int_ratio (big_int_of_int 1) (create_ratio (big_int_of_int (-3)) (big_int_of_int 2))), true) ;; testing_function "compare_big_int_ratio" ;; test 1 eq_int (compare_big_int_ratio (big_int_of_int 1) (create_ratio (big_int_of_int 3) (big_int_of_int 0)), (-1)) ;; test 2 eq_int (compare_big_int_ratio (big_int_of_int 1) (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0) ;; test 3 eq_int (compare_big_int_ratio (big_int_of_int 1) (create_ratio (big_int_of_int (-3)) (big_int_of_int 0)), 1) ;; test 4 eq_int (compare_big_int_ratio (big_int_of_int (-1)) (create_ratio (big_int_of_int 3) (big_int_of_int 0)), (-1)) ;; test 5 eq_int (compare_big_int_ratio (big_int_of_int (-1)) (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0) ;; test 6 eq_int (compare_big_int_ratio (big_int_of_int (-1)) (create_ratio (big_int_of_int (-3)) (big_int_of_int 0)), 1) ;; test 7 eq_int (compare_big_int_ratio (big_int_of_int 1) (create_ratio (big_int_of_int 1) (big_int_of_int 1)), 0) ;; test 8 eq_int (compare_big_int_ratio (big_int_of_int 1) (create_ratio (big_int_of_int 3) (big_int_of_int 2)), (-1)) ;; test 9 eq_int (compare_big_int_ratio (big_int_of_int 1) (create_ratio (big_int_of_int 2) (big_int_of_int 3)), 1) ;; testing_function "int_of_ratio" ;; test 1 eq_int (int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 2)), 2) ;; test 2 eq_int (int_of_ratio (create_ratio (big_int_of_int biggest_int) (big_int_of_int 1)), biggest_int) ;; failwith_test 3 int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 0)) (Failure "integer argument required") ;; failwith_test 4 int_of_ratio (create_ratio (succ_big_int (big_int_of_int biggest_int)) (big_int_of_int 1)) (Failure "integer argument required") ;; failwith_test 5 int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 3)) (Failure "integer argument required") ;; testing_function "ratio_of_int" ;; test 1 eq_ratio (ratio_of_int 3, create_ratio (big_int_of_int 3) (big_int_of_int 1)) ;; test 2 eq_ratio (ratio_of_nat (nat_of_int 2), create_ratio (big_int_of_int 2) (big_int_of_int 1)) ;; testing_function "nat_of_ratio" ;; let nat1 = nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 1)) and nat2 = nat_of_int 3 in test 1 eq (eq_nat nat1 0 (length_nat nat1) nat2 0 (length_nat nat2), true) ;; failwith_test 2 nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 0)) (Failure "nat_of_ratio") ;; failwith_test 3 nat_of_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 1)) (Failure "nat_of_ratio") ;; failwith_test 4 nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)) (Failure "nat_of_ratio") ;; testing_function "ratio_of_big_int" ;; test 1 eq_ratio (ratio_of_big_int (big_int_of_int 3), create_ratio (big_int_of_int 3) (big_int_of_int 1)) ;; testing_function "big_int_of_ratio" ;; test 1 eq_big_int (big_int_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 1)), big_int_of_int 3) ;; test 2 eq_big_int (big_int_of_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 1)), big_int_of_int (-3)) ;; failwith_test 3 big_int_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 0)) (Failure "big_int_of_ratio") ;; testing_function "string_of_ratio" ;; test 1 eq_string (string_of_ratio (create_ratio (big_int_of_int 43) (big_int_of_int 35)), "43/35") ;; test 2 eq_string (string_of_ratio (create_ratio (big_int_of_int 42) (big_int_of_int 0)), "1/0") ;; set_normalize_ratio_when_printing false ;; test 3 eq_string (string_of_ratio (create_ratio (big_int_of_int 42) (big_int_of_int 35)), "42/35") ;; set_normalize_ratio_when_printing true ;; test 4 eq_string (string_of_ratio (create_ratio (big_int_of_int 42) (big_int_of_int 35)), "6/5") ;; testing_function "ratio_of_string" ;; test 1 eq_ratio (ratio_of_string ("123/3456"), create_ratio (big_int_of_int 123) (big_int_of_int 3456)) ;; (*********** test 2 eq_ratio (ratio_of_string ("12.3/34.56"), create_ratio (big_int_of_int 1230) (big_int_of_int 3456)) ;; test 3 eq_ratio (ratio_of_string ("1.23/325.6"), create_ratio (big_int_of_int 123) (big_int_of_int 32560)) ;; test 4 eq_ratio (ratio_of_string ("12.3/345.6"), create_ratio (big_int_of_int 123) (big_int_of_int 3456)) ;; test 5 eq_ratio (ratio_of_string ("12.3/0.0"), create_ratio (big_int_of_int 123) (big_int_of_int 0)) ;; ***********) test 6 eq_ratio (ratio_of_string ("0/0"), create_ratio (big_int_of_int 0) (big_int_of_int 0)) ;; test 7 eq_ratio (ratio_of_string "1234567890", create_ratio (big_int_of_string "1234567890") unit_big_int) ;; failwith_test 8 ratio_of_string "frlshjkurty" (Failure "invalid digit");; (*********** testing_function "msd_ratio" ;; test 1 eq_int (msd_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 1)), 0) ;; test 2 eq_int (msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 12)), (-2)) ;; test 3 eq_int (msd_ratio (create_ratio (big_int_of_int 12) (big_int_of_int 1)), 1) ;; test 4 eq_int (msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 2)), (-1)) ;; test 5 eq_int (msd_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 1)), 0) ;; test 6 eq_int (msd_ratio (create_ratio (big_int_of_int 25) (big_int_of_int 21)), 0) ;; test 7 eq_int (msd_ratio (create_ratio (big_int_of_int 35) (big_int_of_int 21)), 0) ;; test 8 eq_int (msd_ratio (create_ratio (big_int_of_int 215) (big_int_of_int 31)), 0) ;; test 9 eq_int (msd_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 30)), (-2)) ;; test 10 eq_int (msd_ratio (create_ratio (big_int_of_int 2345) (big_int_of_int 23456)), (-2)) ;; test 11 eq_int (msd_ratio (create_ratio (big_int_of_int 2345) (big_int_of_int 2346)), (-1)) ;; test 12 eq_int (msd_ratio (create_ratio (big_int_of_int 2345) (big_int_of_int 2344)), 0) ;; test 13 eq_int (msd_ratio (create_ratio (big_int_of_int 23456) (big_int_of_int 2345)), 1) ;; test 14 eq_int (msd_ratio (create_ratio (big_int_of_int 23467) (big_int_of_int 2345)), 1) ;; failwith_test 15 msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) ("msd_ratio "^infinite_failure) ;; failwith_test 16 msd_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) ("msd_ratio "^infinite_failure) ;; failwith_test 17 msd_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) ("msd_ratio "^infinite_failure) ;; *************************) testing_function "round_futur_last_digit" ;; let s = "+123456" in test 1 eq (round_futur_last_digit s 1 (pred (String.length s)), false) && test 2 eq_string (s, "+123466") ;; let s = "123456" in test 3 eq (round_futur_last_digit s 0 (String.length s), false) && test 4 eq_string (s, "123466") ;; let s = "-123456" in test 5 eq (round_futur_last_digit s 1 (pred (String.length s)), false) && test 6 eq_string (s, "-123466") ;; let s = "+123496" in test 7 eq (round_futur_last_digit s 1 (pred (String.length s)), false) && test 8 eq_string (s, "+123506") ;; let s = "123496" in test 9 eq (round_futur_last_digit s 0 (String.length s), false) && test 10 eq_string (s, "123506") ;; let s = "-123496" in test 11 eq (round_futur_last_digit s 1 (pred (String.length s)), false) && test 12 eq_string (s, "-123506") ;; let s = "+996" in test 13 eq (round_futur_last_digit s 1 (pred (String.length s)), true) && test 14 eq_string (s, "+006") ;; let s = "996" in test 15 eq (round_futur_last_digit s 0 (String.length s), true) && test 16 eq_string (s, "006") ;; let s = "-996" in test 17 eq (round_futur_last_digit s 1 (pred (String.length s)), true) && test 18 eq_string (s, "-006") ;; let s = "+6666666" in test 19 eq (round_futur_last_digit s 1 (pred (String.length s)), false) && test 20 eq_string (s, "+6666676") ;; let s = "6666666" in test 21 eq (round_futur_last_digit s 0 (String.length s), false) && test 22 eq_string (s, "6666676") ;; let s = "-6666666" in test 23 eq (round_futur_last_digit s 1 (pred (String.length s)), false) && test 24 eq_string (s, "-6666676") ;; testing_function "approx_ratio_fix" ;; let s = approx_ratio_fix 5 (create_ratio (big_int_of_int 2) (big_int_of_int 3)) in test 1 eq_string (s, "+0.66667") ;; test 2 eq_string (approx_ratio_fix 5 (create_ratio (big_int_of_int 20) (big_int_of_int 3)), "+6.66667") ;; test 3 eq_string (approx_ratio_fix 5 (create_ratio (big_int_of_int 2) (big_int_of_int 30)), "+0.06667") ;; test 4 eq_string (approx_ratio_fix 5 (create_ratio (big_int_of_string "999996") (big_int_of_string "1000000")), "+1.00000") ;; test 5 eq_string (approx_ratio_fix 5 (create_ratio (big_int_of_string "299996") (big_int_of_string "100000")), "+2.99996") ;; test 6 eq_string (approx_ratio_fix 5 (create_ratio (big_int_of_string "2999996") (big_int_of_string "1000000")), "+3.00000") ;; test 7 eq_string (approx_ratio_fix 4 (create_ratio (big_int_of_string "299996") (big_int_of_string "100000")), "+3.0000") ;; test 8 eq_string (approx_ratio_fix 5 (create_ratio (big_int_of_int 29996) (big_int_of_string "100000")), "+0.29996") ;; test 9 eq_string (approx_ratio_fix 5 (create_ratio (big_int_of_int 0) (big_int_of_int 1)), "+0") ;; failwith_test 10 (approx_ratio_fix 5) (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (Failure "approx_ratio_fix infinite or undefined rational number") ;; failwith_test 11 (approx_ratio_fix 5) (create_ratio (big_int_of_int 0) (big_int_of_int 0)) (Failure "approx_ratio_fix infinite or undefined rational number") ;; (* PR#4566 *) test 12 eq_string (approx_ratio_fix 8 (create_ratio (big_int_of_int 9603) (big_int_of_string "100000000000")), "+0.00000010") ;; test 13 eq_string (approx_ratio_fix 1 (create_ratio (big_int_of_int 94) (big_int_of_int 1000)), "+0.1") ;; test 14 eq_string (approx_ratio_fix 1 (create_ratio (big_int_of_int 49) (big_int_of_int 1000)), "+0.0") ;; testing_function "approx_ratio_exp" ;; test 1 eq_string (approx_ratio_exp 5 (create_ratio (big_int_of_int 2) (big_int_of_int 3)), "+0.66667e0") ;; test 2 eq_string (approx_ratio_exp 5 (create_ratio (big_int_of_int 20) (big_int_of_int 3)), "+0.66667e1") ;; test 3 eq_string (approx_ratio_exp 5 (create_ratio (big_int_of_int 2) (big_int_of_int 30)), "+0.66667e-1") ;; test 4 eq_string (approx_ratio_exp 5 (create_ratio (big_int_of_string "999996") (big_int_of_string "1000000")), "+1.00000e0") ;; test 5 eq_string (approx_ratio_exp 5 (create_ratio (big_int_of_string "299996") (big_int_of_string "100000")), "+0.30000e1") ;; test 6 eq_string (approx_ratio_exp 5 (create_ratio (big_int_of_int 29996) (big_int_of_string "100000")), "+0.29996e0") ;; test 7 eq_string (approx_ratio_exp 5 (create_ratio (big_int_of_int 0) (big_int_of_int 1)), "+0.00000e0") ;; failwith_test 8 (approx_ratio_exp 5) (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (Failure "approx_ratio_exp infinite or undefined rational number") ;; failwith_test 9 (approx_ratio_exp 5) (create_ratio (big_int_of_int 0) (big_int_of_int 0)) (Failure "approx_ratio_exp infinite or undefined rational number") ;; mingw-ocaml/ocaml/testsuite/tests/lib-num/test_nums.ml0000644000175000017500000001460512124403241022575 0ustar tootstootsopen Test;; open Nat;; open Big_int;; open Ratio;; open Num;; open Arith_status;; testing_function "add_num";; test 1 eq_num (add_num (Int 1) (Int 3), Int 4);; test 2 eq_num (add_num (Int 1) (Big_int (big_int_of_int 3)), Int 4);; test 3 eq_num (add_num (Int 1) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "7/4"));; test 4 eq_num (add_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "7/4"));; test 5 eq_num (add_num (Big_int (big_int_of_int 1)) (Big_int (big_int_of_int 3)), Int 4);; test 6 eq_num (add_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "7/4"));; test 7 eq_num (add_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "17/12"));; test 8 eq_num (add_num (Int least_int) (Int 1), Int (- (pred biggest_int)));; test 9 eq_num (add_num (Int biggest_int) (Int 1), Big_int (minus_big_int (pred_big_int (big_int_of_int least_int))));; testing_function "sub_num";; test 1 eq_num (sub_num (Int 1) (Int 3), Int (-2));; test 2 eq_num (sub_num (Int 1) (Big_int (big_int_of_int 3)), Int (-2));; test 3 eq_num (sub_num (Int 1) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "1/4"));; test 4 eq_num (sub_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "1/4"));; test 5 eq_num (sub_num (Big_int (big_int_of_int 1)) (Big_int (big_int_of_int 3)), Int (-2));; test 7 eq_num (sub_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "1/4"));; test 8 eq_num (sub_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "-1/12"));; test 9 eq_num (sub_num (Int least_int) (Int (-1)), Int (- (pred biggest_int)));; test 10 eq_num (sub_num (Int (-1)) (Int biggest_int), pred_num (Int least_int));; testing_function "mult_num";; test 1 eq_num (mult_num (Int 2) (Int 3), Int 6);; test 2 eq_num (mult_num (Int 127) (Int (int_of_string "257")), Int (int_of_string "32639"));; test 3 eq_num (mult_num (Int 257) (Int (int_of_string "260")), Big_int (big_int_of_string "66820"));; test 4 eq_num (mult_num (Int 2) (Big_int (big_int_of_int 3)), Int 6);; test 5 eq_num (mult_num (Int 10) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "15/2"));; test 6 eq_num (mult_num (Big_int (big_int_of_int 10)) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "15/2"));; test 7 eq_num (mult_num (Big_int (big_int_of_int 2)) (Big_int (big_int_of_int 3)), Int 6);; test 8 eq_num (mult_num (Big_int (big_int_of_int 10)) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "15/2"));; test 9 eq_num (mult_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4")) , Ratio (ratio_of_string "1/2"));; testing_function "div_num";; test 1 eq_num (div_num (Int 6) (Int 3), Int 2);; test 2 eq_num (div_num (Int (int_of_string "32639")) (Int (int_of_string "257")), Int 127);; test 3 eq_num (div_num (Big_int (big_int_of_string "66820")) (Int (int_of_string "257")), Int 260);; test 4 eq_num (div_num (Int 6) (Big_int (big_int_of_int 3)), Int 2);; test 5 eq_num (div_num (Ratio (ratio_of_string "15/2")) (Int 10), Ratio (ratio_of_string "3/4"));; test 6 eq_num (div_num (Big_int (big_int_of_int 6)) (Big_int (big_int_of_int 3)), Int 2);; test 7 eq_num (div_num (Ratio (ratio_of_string "15/2")) (Big_int (big_int_of_int 10)), Ratio (ratio_of_string "3/4"));; test 8 eq_num (div_num (Ratio (ratio_of_string "15/2")) (Ratio (ratio_of_string "3/4")), Big_int (big_int_of_int 10));; test 9 eq_num (div_num (Ratio (ratio_of_string "1/2")) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "2/3"));; testing_function "is_integer_num";; test 1 eq (is_integer_num (Int 3),true);; test 2 eq (is_integer_num (Big_int (big_int_of_string "1234567890")),true);; test 3 eq (not (is_integer_num (Ratio (ratio_of_string "1/2"))),true);; test 4 eq (is_integer_num (Ratio (ratio_of_string "1073774590/32770")),true);; testing_function "num_of_ratio";; test 1 eq_num (num_of_ratio (ratio_of_string "4/2"), Int 2);; test 2 eq_num (num_of_ratio (ratio_of_string "11811160075/11"), Big_int (big_int_of_string "1073741825"));; test 3 eq_num (num_of_ratio (ratio_of_string "123456789012/1234"), Ratio (ratio_of_string "61728394506/617"));; testing_function "num_of_string";; test 1 eq_num (num_of_string "123/3456", Ratio (ratio_of_string "123/3456"));; (********* test 2 eq_num (num_of_string "12.3/34.56", Ratio (ratio_of_string "1230/3456"));; test 3 eq_num (num_of_string "1.23/325.6", Ratio (ratio_of_string "123/32560"));; test 4 eq_num (num_of_string "12.3/345.6", Ratio (ratio_of_string "123/3456"));; set_error_when_null_denominator false;; test 5 eq_num (num_of_string "12.3/0.0", Ratio (ratio_of_string "123/0"));; test 6 eq_num (num_of_string "0/0", Ratio (ratio_of_string "0/0"));; set_error_when_null_denominator true;; *********) test 7 eq_num (num_of_string "1234567890", Big_int (big_int_of_string "1234567890"));; test 8 eq_num (num_of_string "12345", Int (int_of_string "12345"));; (********* test 9 eq_num (num_of_string "0.23", Ratio (ratio_of_string "23/100"));; test 10 eq_num (num_of_string "0.23", Ratio (ratio_of_string "0.23/1"));; ********) failwith_test 11 num_of_string ("frlshjkurty") (Failure "num_of_string");; (******* testing_function "immediate numbers";; standard arith false;; let x = (1/2) in test 0 eq_string (string_of_num x, "1/2");; let y = 12345678901 in test 1 eq_string (string_of_num y, "12345678901");; testing_function "immediate numbers";; let x = (1/2) in test 0 eq_string (string_of_num x, "1/2");; let y = 12345678901 in test 1 eq_string (string_of_num y, "12345678901");; testing_function "pattern_matching on nums";; let f1 = function 0 -> true | _ -> false;; test 1 eq (f1 0, true);; test 2 eq (f1 1, false);; test 3 eq (f1 (0/1), true);; test 4 eq (f1 (let n = num_of_string "2000000000000000000000000" in n-n) , true);; test 5 eq (f1 (let n = num_of_string "2000000000000000000000000" in n/n-1) , true);; test 6 eq (f1 (let n = num_of_string "2000000000000000000000000" in n+1) , false);; test 7 eq (f1 (1/2), false);; **************) mingw-ocaml/ocaml/testsuite/tests/lib-num/end_test.ml0000644000175000017500000000002412124403241022347 0ustar tootstootsTest.end_tests ();; mingw-ocaml/ocaml/testsuite/tests/lib-num/test.ml0000644000175000017500000000501512124403241021526 0ustar tootstootsopen Printf;; let flush_all () = flush stdout; flush stderr;; let message s = print_string s; print_newline ();; let error_occurred = ref false;; let immediate_failure = ref true;; let error () = if !immediate_failure then exit 2 else begin error_occurred := true; flush_all (); false end;; let success () = flush_all (); true;; let function_tested = ref "";; let testing_function s = flush_all (); function_tested := s; print_newline(); message s;; let test test_number eq_fun (answer, correct_answer) = flush_all (); if not (eq_fun answer correct_answer) then begin fprintf stderr ">>> Bad result (%s, test %d)\n" !function_tested test_number; error () end else begin printf " %d..." test_number; success () end;; let failure_test test_number fun_to_test arg = flush_all (); try fun_to_test arg; fprintf stderr ">>> Failure expected (%s, test %d)\n" !function_tested test_number; error () with _ -> printf " %d..." test_number; success ();; let failwith_test test_number fun_to_test arg correct_failure = flush_all (); try fun_to_test arg; fprintf stderr ">>> Failure expected (%s, test %d)\n" !function_tested test_number; error () with x -> if x = correct_failure then begin printf " %d..." test_number; success () end else begin fprintf stderr ">>> Bad failure (%s, test %d)\n" !function_tested test_number; error () end;; let end_tests () = flush_all (); print_newline (); if !error_occurred then begin print_endline "************* TESTS FAILED ****************"; exit 2 end else begin print_endline "************* TESTS COMPLETED SUCCESSFULLY ****************"; exit 0 end;; let eq = (==);; let eq_int (i: int) (j: int) = (i = j);; let eq_string (i: string) (j: string) = (i = j);; let eq_nativeint (i: nativeint) (j: nativeint) = (i = j);; let eq_int32 (i: int32) (j: int32) = (i = j);; let eq_int64 (i: int64) (j: int64) = (i = j);; let sixtyfour = (1 lsl 31) <> 0;; let rec gcd_int i1 i2 = if i2 = 0 then abs i1 else gcd_int i2 (i1 mod i2);; let rec num_bits_int_aux n = if n = 0 then 0 else succ(num_bits_int_aux (n lsr 1));; let num_bits_int n = num_bits_int_aux (abs n);; let sign_int i = if i = 0 then 0 else if i > 0 then 1 else -1;; let length_of_int = Sys.word_size - 2;; let monster_int = 1 lsl length_of_int;; let biggest_int = monster_int - 1;; let least_int = - biggest_int;; let compare_int n1 n2 = if n1 == n2 then 0 else if n1 > n2 then 1 else -1;; mingw-ocaml/ocaml/testsuite/tests/gc-roots/0000755000175000017500000000000012124403241020406 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/gc-roots/Makefile0000644000175000017500000000025712124403241022052 0ustar tootstootsBASEDIR=../.. #MODULES= MAIN_MODULE=globroots C_FILES=globrootsprim ADD_COMPFLAGS=-w a include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/gc-roots/globroots.ml0000644000175000017500000000431612124403241022756 0ustar tootstootsmodule type GLOBREF = sig type t val register: string -> t val get: t -> string val set: t -> string -> unit val remove: t -> unit end module Classic : GLOBREF = struct type t external register: string -> t = "gb_classic_register" external get: t -> string = "gb_get" external set: t -> string -> unit = "gb_classic_set" external remove: t -> unit = "gb_classic_remove" end module Generational : GLOBREF = struct type t external register: string -> t = "gb_generational_register" external get: t -> string = "gb_get" external set: t -> string -> unit = "gb_generational_set" external remove: t -> unit = "gb_generational_remove" end module Test(G: GLOBREF) = struct let size = 1024 let vals = Array.init size string_of_int let a = Array.init size (fun i -> G.register (string_of_int i)) let check () = for i = 0 to size - 1 do if G.get a.(i) <> vals.(i) then begin print_string "Error on "; print_int i; print_string ": "; print_string (String.escaped (G.get a.(i))); print_newline() end done let change () = match Random.int 37 with | 0 -> Gc.full_major() | 1|2|3|4 -> Gc.minor() | 5|6|7|8|9|10|11|12 -> (* update with young value *) let i = Random.int size in G.set a.(i) (string_of_int i) | 13|14|15|16|17|18|19|20 -> (* update with old value *) let i = Random.int size in G.set a.(i) vals.(i) | 21|22|23|24|25|26|27|28 -> (* re-register young value *) let i = Random.int size in G.remove a.(i); a.(i) <- G.register (string_of_int i) | (*29|30|31|32|33|34|35|36*) _ -> (* re-register old value *) let i = Random.int size in G.remove a.(i); a.(i) <- G.register vals.(i) let test n = for i = 1 to n do change(); print_string "."; flush stdout done end module TestClassic = Test(Classic) module TestGenerational = Test(Generational) let _ = let n = if Array.length Sys.argv < 2 then 10000 else int_of_string Sys.argv.(1) in print_string "Non-generational API\n"; TestClassic.test n; print_newline(); print_string "Generational API\n"; TestGenerational.test n; print_newline() mingw-ocaml/ocaml/testsuite/tests/gc-roots/globroots.reference0000644000175000017500000004711012124403241024303 0ustar tootstootsNon-generational API ................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................ Generational API ................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................................ mingw-ocaml/ocaml/testsuite/tests/gc-roots/globrootsprim.c0000644000175000017500000000210412124403241023451 0ustar tootstoots/* For testing global root registration */ #include "mlvalues.h" #include "memory.h" #include "alloc.h" struct block { value v; }; #define Block_val(v) ((struct block *) (v)) value gb_get(value vblock) { return Block_val(vblock)->v; } value gb_classic_register(value v) { struct block * b = stat_alloc(sizeof(struct block)); b->v = v; caml_register_global_root(&(b->v)); return (value) b; } value gb_classic_set(value vblock, value newval) { Block_val(vblock)->v = newval; return Val_unit; } value gb_classic_remove(value vblock) { caml_remove_global_root(&(Block_val(vblock)->v)); return Val_unit; } value gb_generational_register(value v) { struct block * b = stat_alloc(sizeof(struct block)); b->v = v; caml_register_generational_global_root(&(b->v)); return (value) b; } value gb_generational_set(value vblock, value newval) { caml_modify_generational_global_root(&(Block_val(vblock)->v), newval); return Val_unit; } value gb_generational_remove(value vblock) { caml_remove_generational_global_root(&(Block_val(vblock)->v)); return Val_unit; } mingw-ocaml/ocaml/testsuite/tests/backtrace/0000755000175000017500000000000012124403241020570 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/backtrace/backtrace2.a.reference0000644000175000017500000000257112124403241024675 0ustar tootstootsa No exception b Uncaught exception Backtrace2.Error("b") Raised at file "backtrace2.ml", line 6, characters 21-32 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 10, characters 4-11 Re-raised at file "backtrace2.ml", line 12, characters 68-71 Called from file "backtrace2.ml", line 17, characters 11-23 Uncaught exception Backtrace2.Error("c") Raised at file "backtrace2.ml", line 13, characters 26-37 Called from file "backtrace2.ml", line 17, characters 11-23 Uncaught exception Backtrace2.Error("d") Raised at file "backtrace2.ml", line 6, characters 21-32 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 10, characters 4-11 Called from file "backtrace2.ml", line 17, characters 11-23 Uncaught exception Invalid_argument("index out of bounds") Raised by primitive operation at file "backtrace2.ml", line 17, characters 14-22 mingw-ocaml/ocaml/testsuite/tests/backtrace/backtrace2.c.reference0000644000175000017500000000257112124403241024677 0ustar tootstootsa No exception b Uncaught exception Backtrace2.Error("b") Raised at file "backtrace2.ml", line 6, characters 21-32 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 10, characters 4-11 Re-raised at file "backtrace2.ml", line 12, characters 68-71 Called from file "backtrace2.ml", line 17, characters 11-23 Uncaught exception Backtrace2.Error("c") Raised at file "backtrace2.ml", line 13, characters 26-37 Called from file "backtrace2.ml", line 17, characters 11-23 Uncaught exception Backtrace2.Error("d") Raised at file "backtrace2.ml", line 6, characters 21-32 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 10, characters 4-11 Called from file "backtrace2.ml", line 17, characters 11-23 Uncaught exception Invalid_argument("index out of bounds") Raised by primitive operation at file "backtrace2.ml", line 17, characters 14-22 mingw-ocaml/ocaml/testsuite/tests/backtrace/backtrace.d.reference0000644000175000017500000000077212124403241024617 0ustar tootstootsFatal error: exception Backtrace.Error("d") Raised at file "backtrace.ml", line 6, characters 21-32 Called from file "backtrace.ml", line 6, characters 42-53 Called from file "backtrace.ml", line 6, characters 42-53 Called from file "backtrace.ml", line 6, characters 42-53 Called from file "backtrace.ml", line 6, characters 42-53 Called from file "backtrace.ml", line 6, characters 42-53 Called from file "backtrace.ml", line 10, characters 4-11 Called from file "backtrace.ml", line 17, characters 9-25 mingw-ocaml/ocaml/testsuite/tests/backtrace/Makefile0000644000175000017500000000110112124403241022221 0ustar tootstootsBASEDIR=../.. EXECNAME=./program run-all: @for file in *.ml; do \ $(OCAMLC) -g -o $(EXECNAME) $$file; \ for arg in a b c d ''; do \ printf " ... testing '$$file' (with argument '$$arg'):"; \ OCAMLRUNPARAM=b=1 $(EXECNAME) $$arg > `basename $$file ml`$$arg.result 2>&1; \ $(DIFF) `basename $$file ml`$$arg.reference `basename $$file ml`$$arg.result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \ done; \ done promote: defaultpromote clean: defaultclean @rm -f *.result $(EXECNAME) include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/backtrace/backtrace2.d.reference0000644000175000017500000000257112124403241024700 0ustar tootstootsa No exception b Uncaught exception Backtrace2.Error("b") Raised at file "backtrace2.ml", line 6, characters 21-32 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 10, characters 4-11 Re-raised at file "backtrace2.ml", line 12, characters 68-71 Called from file "backtrace2.ml", line 17, characters 11-23 Uncaught exception Backtrace2.Error("c") Raised at file "backtrace2.ml", line 13, characters 26-37 Called from file "backtrace2.ml", line 17, characters 11-23 Uncaught exception Backtrace2.Error("d") Raised at file "backtrace2.ml", line 6, characters 21-32 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 10, characters 4-11 Called from file "backtrace2.ml", line 17, characters 11-23 Uncaught exception Invalid_argument("index out of bounds") Raised by primitive operation at file "backtrace2.ml", line 17, characters 14-22 mingw-ocaml/ocaml/testsuite/tests/backtrace/backtrace..reference0000644000175000017500000000021712124403241024445 0ustar tootstootsFatal error: exception Invalid_argument("index out of bounds") Raised by primitive operation at file "backtrace.ml", line 17, characters 12-24 mingw-ocaml/ocaml/testsuite/tests/backtrace/backtrace2.ml0000644000175000017500000000121412124403241023121 0ustar tootstoots(* A test for stack backtraces *) exception Error of string let rec f msg n = if n = 0 then raise(Error msg) else 1 + f msg (n-1) let g msg = try f msg 5 with Error "a" -> print_string "a"; print_newline(); 0 | Error "b" as exn -> print_string "b"; print_newline(); raise exn | Error "c" -> raise (Error "c") let run args = try ignore (g args.(0)); print_string "No exception\n" with exn -> Printf.printf "Uncaught exception %s\n" (Printexc.to_string exn); Printexc.print_backtrace stdout let _ = Printexc.record_backtrace true; run [| "a" |]; run [| "b" |]; run [| "c" |]; run [| "d" |]; run [| |] mingw-ocaml/ocaml/testsuite/tests/backtrace/backtrace.b.reference0000644000175000017500000000107012124403241024605 0ustar tootstootsb Fatal error: exception Backtrace.Error("b") Raised at file "backtrace.ml", line 6, characters 21-32 Called from file "backtrace.ml", line 6, characters 42-53 Called from file "backtrace.ml", line 6, characters 42-53 Called from file "backtrace.ml", line 6, characters 42-53 Called from file "backtrace.ml", line 6, characters 42-53 Called from file "backtrace.ml", line 6, characters 42-53 Called from file "backtrace.ml", line 10, characters 4-11 Re-raised at file "backtrace.ml", line 12, characters 68-71 Called from file "backtrace.ml", line 17, characters 9-25 mingw-ocaml/ocaml/testsuite/tests/backtrace/backtrace2..reference0000644000175000017500000000257112124403241024534 0ustar tootstootsa No exception b Uncaught exception Backtrace2.Error("b") Raised at file "backtrace2.ml", line 6, characters 21-32 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 10, characters 4-11 Re-raised at file "backtrace2.ml", line 12, characters 68-71 Called from file "backtrace2.ml", line 17, characters 11-23 Uncaught exception Backtrace2.Error("c") Raised at file "backtrace2.ml", line 13, characters 26-37 Called from file "backtrace2.ml", line 17, characters 11-23 Uncaught exception Backtrace2.Error("d") Raised at file "backtrace2.ml", line 6, characters 21-32 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 10, characters 4-11 Called from file "backtrace2.ml", line 17, characters 11-23 Uncaught exception Invalid_argument("index out of bounds") Raised by primitive operation at file "backtrace2.ml", line 17, characters 14-22 mingw-ocaml/ocaml/testsuite/tests/backtrace/backtrace.a.reference0000644000175000017500000000000212124403241024576 0ustar tootstootsa mingw-ocaml/ocaml/testsuite/tests/backtrace/backtrace.c.reference0000644000175000017500000000023712124403241024612 0ustar tootstootsFatal error: exception Backtrace.Error("c") Raised at file "backtrace.ml", line 13, characters 26-37 Called from file "backtrace.ml", line 17, characters 9-25 mingw-ocaml/ocaml/testsuite/tests/backtrace/backtrace2.b.reference0000644000175000017500000000257112124403241024676 0ustar tootstootsa No exception b Uncaught exception Backtrace2.Error("b") Raised at file "backtrace2.ml", line 6, characters 21-32 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 10, characters 4-11 Re-raised at file "backtrace2.ml", line 12, characters 68-71 Called from file "backtrace2.ml", line 17, characters 11-23 Uncaught exception Backtrace2.Error("c") Raised at file "backtrace2.ml", line 13, characters 26-37 Called from file "backtrace2.ml", line 17, characters 11-23 Uncaught exception Backtrace2.Error("d") Raised at file "backtrace2.ml", line 6, characters 21-32 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 6, characters 42-53 Called from file "backtrace2.ml", line 10, characters 4-11 Called from file "backtrace2.ml", line 17, characters 11-23 Uncaught exception Invalid_argument("index out of bounds") Raised by primitive operation at file "backtrace2.ml", line 17, characters 14-22 mingw-ocaml/ocaml/testsuite/tests/backtrace/backtrace.ml0000644000175000017500000000062112124403241023040 0ustar tootstoots(* A test for stack backtraces *) exception Error of string let rec f msg n = if n = 0 then raise(Error msg) else 1 + f msg (n-1) let g msg = try f msg 5 with Error "a" -> print_string "a"; print_newline(); 0 | Error "b" as exn -> print_string "b"; print_newline(); raise exn | Error "c" -> raise (Error "c") let _ = Printexc.record_backtrace true; ignore (g Sys.argv.(1)) mingw-ocaml/ocaml/testsuite/tests/lib-marshal/0000755000175000017500000000000012124403241021044 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-marshal/Makefile0000644000175000017500000000022512124403241022503 0ustar tootstootsBASEDIR=../.. #MODULES= MAIN_MODULE=intext C_FILES=intextaux include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-marshal/intext.reference0000644000175000017500000000541412124403241024243 0ustar tootstootsTest 1 passed. Test 2 passed. Test 3 passed. Test 4 passed. Test 5 passed. Test 6 passed. Test 7 passed. Test 8 passed. Test 9 passed. Test 10 passed. Test 11 passed. Test 12 passed. Test 13 passed. Test 14 passed. Test 15 passed. Test 16 passed. Test 17 passed. Test 18 passed. Test 19 passed. Test 20 passed. Test 21 passed. Test 22 passed. Test 23 passed. Test 24 passed. Test 25 passed. Test 26 passed. Test 27 passed. Test 28 passed. Test 29 passed. Test 30 passed. Test 31 passed. Test 32 passed. Test 33 passed. Test 34 passed. Test 35 passed. Test 36 passed. Test 37 passed. Test 38 passed. Test 39 passed. Test 1 passed. Test 2 passed. Test 3 passed. Test 4 passed. Test 5 passed. Test 6 passed. Test 7 passed. Test 8 passed. Test 9 passed. Test 10 passed. Test 11 passed. Test 12 passed. Test 13 passed. Test 14 passed. Test 15 passed. Test 16 passed. Test 17 passed. Test 18 passed. Test 19 passed. Test 20 passed. Test 21 passed. Test 22 passed. Test 23 passed. Test 24 passed. Test 25 passed. Test 26 passed. Test 27 passed. Test 28 passed. Test 29 passed. Test 30 passed. Test 31 passed. Test 32 passed. Test 33 passed. Test 34 passed. Test 35 passed. Test 36 passed. Test 37 passed. Test 38 passed. Test 39 passed. Test 101 passed. Test 102 passed. Test 103 passed. Test 104 passed. Test 105 passed. Test 106 passed. Test 107 passed. Test 108 passed. Test 109 passed. Test 110 passed. Test 111 passed. Test 112 passed. Test 113 passed. Test 114 passed. Test 115 passed. Test 116 passed. Test 117 passed. Test 118 passed. Test 119 passed. Test 120 passed. Test 121 passed. Test 122 passed. Test 123 passed. Test 201 passed. Test 202 passed. Test 203 passed. Test 204 passed. Test 205 passed. Test 206 passed. Test 207 passed. Test 208 passed. Test 209 passed. Test 210 passed. Test 211 passed. Test 212 passed. Test 213 passed. Test 214 passed. Test 215 passed. Test 216 passed. Test 217 passed. Test 218 passed. Test 219 passed. Test 220 passed. Test 221 passed. Test 222 passed. Test 223 passed. Test 300 passed. Test 401 passed. Test 402 passed. Test 403 passed. Test 404 passed. Test 405 passed. Test 406 passed. Test 407 passed. Test 408 passed. Test 409 passed. Test 410 passed. Test 411 passed. Test 412 passed. Test 413 passed. Test 414 passed. Test 415 passed. Test 416 passed. Test 417 passed. Test 418 passed. Test 419 passed. Test 420 passed. Test 421 passed. Test 422 passed. Test 423 passed. Test 424 passed. Test 425 passed. Test 426 passed. Test 500 passed. Test 501 passed. Test 502 passed. Test 503 passed. Test 504 passed. Test 505 passed. Test 506 passed. Test 507 passed. Test 508 passed. Test 509 passed. Test 510 passed. Test 511 passed. Test 512 passed. Test 600 passed. Test 601 passed. Test 602 passed. Test 603 passed. Test 604 passed. Test 605 passed. Test 606 passed. Test 607 passed. mingw-ocaml/ocaml/testsuite/tests/lib-marshal/intext.ml0000644000175000017500000004501512124403241022716 0ustar tootstoots(* Test for output_value / input_value *) let max_data_depth = 500000 type t = A | B of int | C of float | D of string | E of char | F of t | G of t * t | H of int * t | I of t * float | J let longstring = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" let verylongstring = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" let bigint = Int64.to_int 0x123456789ABCDEF0L let rec fib n = if n < 2 then 1 else fib(n-1) + fib(n-2) let test_out filename = let oc = open_out_bin filename in output_value oc 1; output_value oc (-1); output_value oc 258; output_value oc 20000; output_value oc 0x12345678; output_value oc bigint; output_value oc "foobargeebuz"; output_value oc longstring; output_value oc verylongstring; output_value oc 3.141592654; output_value oc (); output_value oc A; output_value oc (B 1); output_value oc (C 2.718); output_value oc (D "hello, world!"); output_value oc (E 'l'); output_value oc (F(B 1)); output_value oc (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))); output_value oc (H(1, A)); output_value oc (I(B 2, 1e-6)); let x = D "sharing" in let y = G(x, x) in let z = G(y, G(x, y)) in output_value oc z; output_value oc [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]; let rec big n = if n <= 0 then A else H(n, big(n-1)) in output_value oc (big 1000); Marshal.to_channel oc y [Marshal.No_sharing]; Marshal.to_channel oc fib [Marshal.Closures]; output_value oc (Int32.of_string "0"); output_value oc (Int32.of_string "123456"); output_value oc (Int32.of_string "-123456"); output_value oc (Int64.of_string "0"); output_value oc (Int64.of_string "123456789123456"); output_value oc (Int64.of_string "-123456789123456"); output_value oc (Nativeint.of_string "0"); output_value oc (Nativeint.of_string "123456"); output_value oc (Nativeint.of_string "-123456"); output_value oc (Nativeint.shift_left (Nativeint.of_string "123456789") 32); output_value oc (Nativeint.shift_left (Nativeint.of_string "-123456789") 32); let i = Int64.of_string "123456789123456" in output_value oc (i,i); close_out oc let test n b = print_string "Test "; print_int n; if b then print_string " passed.\n" else print_string " FAILED.\n"; flush stderr let test_in filename = let ic = open_in_bin filename in test 1 (input_value ic = 1); test 2 (input_value ic = (-1)); test 3 (input_value ic = 258); test 4 (input_value ic = 20000); test 5 (input_value ic = 0x12345678); test 6 (input_value ic = bigint); test 7 (input_value ic = "foobargeebuz"); test 8 (input_value ic = longstring); test 9 (input_value ic = verylongstring); test 10 (input_value ic = 3.141592654); test 11 (input_value ic = ()); test 12 (match input_value ic with A -> true | _ -> false); test 13 (match input_value ic with (B 1) -> true | _ -> false); test 14 (match input_value ic with (C f) -> f = 2.718 | _ -> false); test 15 (match input_value ic with (D "hello, world!") -> true | _ -> false); test 16 (match input_value ic with (E 'l') -> true | _ -> false); test 17 (match input_value ic with (F(B 1)) -> true | _ -> false); test 18 (match input_value ic with (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) -> true | _ -> false); test 19 (match input_value ic with (H(1, A)) -> true | _ -> false); test 20 (match input_value ic with (I(B 2, 1e-6)) -> true | _ -> false); test 21 (match input_value ic with G((G((D "sharing" as t1), t2) as t3), G(t4, t5)) -> t1 == t2 && t3 == t5 && t4 == t1 | _ -> false); test 22 (input_value ic = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); let rec check_big n t = if n <= 0 then test 23 (match t with A -> true | _ -> false) else match t with H(m, s) -> if m = n then check_big (n-1) s else test 23 false | _ -> test 23 false in check_big 1000 (input_value ic); test 24 (match input_value ic with G((D "sharing" as t1), (D "sharing" as t2)) -> t1 != t2 | _ -> false); test 25 (let fib = (input_value ic : int -> int) in fib 5 = 8 && fib 10 = 89); test 26 (input_value ic = Int32.of_string "0"); test 27 (input_value ic = Int32.of_string "123456"); test 28 (input_value ic = Int32.of_string "-123456"); test 29 (input_value ic = Int64.of_string "0"); test 30 (input_value ic = Int64.of_string "123456789123456"); test 31 (input_value ic = Int64.of_string "-123456789123456"); test 32 (input_value ic = Nativeint.of_string "0"); test 33 (input_value ic = Nativeint.of_string "123456"); test 34 (input_value ic = Nativeint.of_string "-123456"); test 35 (input_value ic = Nativeint.shift_left (Nativeint.of_string "123456789") 32); test 36 (input_value ic = Nativeint.shift_left (Nativeint.of_string "-123456789") 32); let ((i, j) : int64 * int64) = input_value ic in test 37 (i = Int64.of_string "123456789123456"); test 38 (j = Int64.of_string "123456789123456"); test 39 (i == j); close_in ic let test_string () = let s = Marshal.to_string 1 [] in test 101 (Marshal.from_string s 0 = 1); let s = Marshal.to_string (-1) [] in test 102 (Marshal.from_string s 0 = (-1)); let s = Marshal.to_string 258 [] in test 103 (Marshal.from_string s 0 = 258); let s = Marshal.to_string 20000 [] in test 104 (Marshal.from_string s 0 = 20000); let s = Marshal.to_string 0x12345678 [] in test 105 (Marshal.from_string s 0 = 0x12345678); let s = Marshal.to_string bigint [] in test 106 (Marshal.from_string s 0 = bigint); let s = Marshal.to_string "foobargeebuz" [] in test 107 (Marshal.from_string s 0 = "foobargeebuz"); let s = Marshal.to_string longstring [] in test 108 (Marshal.from_string s 0 = longstring); let s = Marshal.to_string verylongstring [] in test 109 (Marshal.from_string s 0 = verylongstring); let s = Marshal.to_string 3.141592654 [] in test 110 (Marshal.from_string s 0 = 3.141592654); let s = Marshal.to_string () [] in test 111 (Marshal.from_string s 0 = ()); let s = Marshal.to_string A [] in test 112 (match Marshal.from_string s 0 with A -> true | _ -> false); let s = Marshal.to_string (B 1) [] in test 113 (match Marshal.from_string s 0 with (B 1) -> true | _ -> false); let s = Marshal.to_string (C 2.718) [] in test 114 (match Marshal.from_string s 0 with (C f) -> f = 2.718 | _ -> false); let s = Marshal.to_string (D "hello, world!") [] in test 115 (match Marshal.from_string s 0 with (D "hello, world!") -> true | _ -> false); let s = Marshal.to_string (E 'l') [] in test 116 (match Marshal.from_string s 0 with (E 'l') -> true | _ -> false); let s = Marshal.to_string (F(B 1)) [] in test 117 (match Marshal.from_string s 0 with (F(B 1)) -> true | _ -> false); let s = Marshal.to_string (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) [] in test 118 (match Marshal.from_string s 0 with (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) -> true | _ -> false); let s = Marshal.to_string (H(1, A)) [] in test 119 (match Marshal.from_string s 0 with (H(1, A)) -> true | _ -> false); let s = Marshal.to_string (I(B 2, 1e-6)) [] in test 120 (match Marshal.from_string s 0 with (I(B 2, 1e-6)) -> true | _ -> false); let x = D "sharing" in let y = G(x, x) in let z = G(y, G(x, y)) in let s = Marshal.to_string z [] in test 121 (match Marshal.from_string s 0 with G((G((D "sharing" as t1), t2) as t3), G(t4, t5)) -> t1 == t2 && t3 == t5 && t4 == t1 | _ -> false); let s = Marshal.to_string [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|] [] in test 122 (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); let rec big n = if n <= 0 then A else H(n, big(n-1)) in let s = Marshal.to_string (big 1000) [] in let rec check_big n t = if n <= 0 then test 123 (match t with A -> true | _ -> false) else match t with H(m, s) -> if m = n then check_big (n-1) s else test 123 false | _ -> test 123 false in check_big 1000 (Marshal.from_string s 0) let marshal_to_buffer s start len v flags = ignore (Marshal.to_buffer s start len v flags) ;; let test_buffer () = let s = String.create 512 in marshal_to_buffer s 0 512 1 []; test 201 (Marshal.from_string s 0 = 1); marshal_to_buffer s 0 512 (-1) []; test 202 (Marshal.from_string s 0 = (-1)); marshal_to_buffer s 0 512 258 []; test 203 (Marshal.from_string s 0 = 258); marshal_to_buffer s 0 512 20000 []; test 204 (Marshal.from_string s 0 = 20000); marshal_to_buffer s 0 512 0x12345678 []; test 205 (Marshal.from_string s 0 = 0x12345678); marshal_to_buffer s 0 512 bigint []; test 206 (Marshal.from_string s 0 = bigint); marshal_to_buffer s 0 512 "foobargeebuz" []; test 207 (Marshal.from_string s 0 = "foobargeebuz"); marshal_to_buffer s 0 512 longstring []; test 208 (Marshal.from_string s 0 = longstring); test 209 (try marshal_to_buffer s 0 512 verylongstring []; false with Failure "Marshal.to_buffer: buffer overflow" -> true); marshal_to_buffer s 0 512 3.141592654 []; test 210 (Marshal.from_string s 0 = 3.141592654); marshal_to_buffer s 0 512 () []; test 211 (Marshal.from_string s 0 = ()); marshal_to_buffer s 0 512 A []; test 212 (match Marshal.from_string s 0 with A -> true | _ -> false); marshal_to_buffer s 0 512 (B 1) []; test 213 (match Marshal.from_string s 0 with (B 1) -> true | _ -> false); marshal_to_buffer s 0 512 (C 2.718) []; test 214 (match Marshal.from_string s 0 with (C f) -> f = 2.718 | _ -> false); marshal_to_buffer s 0 512 (D "hello, world!") []; test 215 (match Marshal.from_string s 0 with (D "hello, world!") -> true | _ -> false); marshal_to_buffer s 0 512 (E 'l') []; test 216 (match Marshal.from_string s 0 with (E 'l') -> true | _ -> false); marshal_to_buffer s 0 512 (F(B 1)) []; test 217 (match Marshal.from_string s 0 with (F(B 1)) -> true | _ -> false); marshal_to_buffer s 0 512 (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) []; test 218 (match Marshal.from_string s 0 with (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) -> true | _ -> false); marshal_to_buffer s 0 512 (H(1, A)) []; test 219 (match Marshal.from_string s 0 with (H(1, A)) -> true | _ -> false); marshal_to_buffer s 0 512 (I(B 2, 1e-6)) []; test 220 (match Marshal.from_string s 0 with (I(B 2, 1e-6)) -> true | _ -> false); let x = D "sharing" in let y = G(x, x) in let z = G(y, G(x, y)) in marshal_to_buffer s 0 512 z []; test 221 (match Marshal.from_string s 0 with G((G((D "sharing" as t1), t2) as t3), G(t4, t5)) -> t1 == t2 && t3 == t5 && t4 == t1 | _ -> false); marshal_to_buffer s 0 512 [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|] []; test 222 (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); let rec big n = if n <= 0 then A else H(n, big(n-1)) in test 223 (try marshal_to_buffer s 0 512 (big 1000) []; false with Failure "Marshal.to_buffer: buffer overflow" -> true) let test_size() = let s = Marshal.to_string (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) [] in test 300 (Marshal.header_size + Marshal.data_size s 0 = String.length s) external marshal_to_block : string -> int -> 'a -> Marshal.extern_flags list -> unit = "marshal_to_block" external marshal_from_block : string -> int -> 'a = "marshal_from_block" external static_alloc : int -> string = "caml_static_alloc" let test_block () = let s = static_alloc 512 in marshal_to_block s 512 1 []; test 401 (marshal_from_block s 512 = 1); marshal_to_block s 512 (-1) []; test 402 (marshal_from_block s 512 = (-1)); marshal_to_block s 512 258 []; test 403 (marshal_from_block s 512 = 258); marshal_to_block s 512 20000 []; test 404 (marshal_from_block s 512 = 20000); marshal_to_block s 512 0x12345678 []; test 405 (marshal_from_block s 512 = 0x12345678); marshal_to_block s 512 bigint []; test 406 (marshal_from_block s 512 = bigint); marshal_to_block s 512 "foobargeebuz" []; test 407 (marshal_from_block s 512 = "foobargeebuz"); marshal_to_block s 512 longstring []; test 408 (marshal_from_block s 512 = longstring); test 409 (try marshal_to_block s 512 verylongstring []; false with Failure "Marshal.to_buffer: buffer overflow" -> true); marshal_to_block s 512 3.141592654 []; test 410 (marshal_from_block s 512 = 3.141592654); marshal_to_block s 512 () []; test 411 (marshal_from_block s 512 = ()); marshal_to_block s 512 A []; test 412 (match marshal_from_block s 512 with A -> true | _ -> false); marshal_to_block s 512 (B 1) []; test 413 (match marshal_from_block s 512 with (B 1) -> true | _ -> false); marshal_to_block s 512 (C 2.718) []; test 414 (match marshal_from_block s 512 with (C f) -> f = 2.718 | _ -> false); marshal_to_block s 512 (D "hello, world!") []; test 415 (match marshal_from_block s 512 with (D "hello, world!") -> true | _ -> false); marshal_to_block s 512 (E 'l') []; test 416 (match marshal_from_block s 512 with (E 'l') -> true | _ -> false); marshal_to_block s 512 (F(B 1)) []; test 417 (match marshal_from_block s 512 with (F(B 1)) -> true | _ -> false); marshal_to_block s 512 (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) []; test 418 (match marshal_from_block s 512 with (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) -> true | _ -> false); marshal_to_block s 512 (H(1, A)) []; test 419 (match marshal_from_block s 512 with (H(1, A)) -> true | _ -> false); marshal_to_block s 512 (I(B 2, 1e-6)) []; test 420 (match marshal_from_block s 512 with (I(B 2, 1e-6)) -> true | _ -> false); let x = D "sharing" in let y = G(x, x) in let z = G(y, G(x, y)) in marshal_to_block s 512 z []; test 421 (match marshal_from_block s 512 with G((G((D "sharing" as t1), t2) as t3), G(t4, t5)) -> t1 == t2 && t3 == t5 && t4 == t1 | _ -> false); marshal_to_block s 512 [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|] []; test 422 (marshal_from_block s 512 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); let rec big n = if n <= 0 then A else H(n, big(n-1)) in test 423 (try marshal_to_block s 512 (big 1000) []; false with Failure _ -> true); test 424 (try marshal_to_block s 512 "Hello, world!" []; ignore (marshal_from_block s 8); false with Failure _ -> true) (* Test for really big objects *) let counter = ref 0 let rec make_big n = if n <= 0 then begin incr counter; B !counter end else begin let l = make_big (n-1) in let r = make_big (n-1) in G(l, r) end let rec check_big n x = if n <= 0 then begin match x with B k -> incr counter; k = !counter | _ -> false end else begin match x with G(l, r) -> check_big (n-1) l && check_big (n-1) r | _ -> false end (* Test for really deep data structures *) let test_deep () = (* Right-leaning *) let rec loop acc i = if i < max_data_depth then loop (i :: acc) (i+1) else acc in let x = loop [] 0 in let s = Marshal.to_string x [] in test 425 (Marshal.from_string s 0 = x); (* Left-leaning *) let rec loop acc i = if i < max_data_depth then loop (G(acc, B i)) (i+1) else acc in let x = loop A 0 in let s = Marshal.to_string x [] in test 426 (Marshal.from_string s 0 = x) (* Test for objects *) class foo = object (self : 'self) val data1 = "foo" val data2 = "bar" val data3 = 42L method test1 = data1 ^ data2 method test2 = false method test3 = self#test1 method test4 = data3 end class bar = object (self : 'self) inherit foo as super val! data2 = "test5" val data4 = "test3" val data5 = "test4" method test1 = data1 ^ data2 ^ data4 ^ data5 ^ Int64.to_string self#test4 end class foobar = object (self : 'self) inherit foo as super inherit! bar end (* Test for objects *) let test_objects () = let x = new foo in let s = Marshal.to_string x [Marshal.Closures] in let x = Marshal.from_string s 0 in test 500 (x#test1 = "foobar"); test 501 (x#test2 = false); test 502 (x#test3 = "foobar"); test 503 (x#test4 = 42L); let x = new bar in let s = Marshal.to_string x [Marshal.Closures] in let x = Marshal.from_string s 0 in test 504 (x#test1 = "footest5test3test442"); test 505 (x#test2 = false); test 506 (x#test3 = "footest5test3test442"); test 507 (x#test4 = 42L); let x0 = new foobar in let s = Marshal.to_string x0 [Marshal.Closures] in let x = Marshal.from_string s 0 in test 508 (x#test1 = "footest5test3test442"); test 509 (x#test2 = false); test 510 (x#test3 = "footest5test3test442"); test 511 (x#test4 = 42L); test 512 (Oo.id x = Oo.id x0 + 1) (* PR#5610 *) (* Test for infix pointers *) let test_infix () = let t = true and f = false in let rec odd n = if n = 0 then f else even (n-1) and even n = if n = 0 then t else odd (n-1) in let s = Marshal.to_string (odd, even) [Marshal.Closures] in let (odd', even': (int -> bool) * (int -> bool)) = Marshal.from_string s 0 in test 600 (odd' 41 = true); test 601 (odd' 41 = odd 41); test 602 (odd' 142 = false); test 603 (odd' 142 = odd 142); test 604 (even' 41 = false); test 605 (even' 41 = even 41); test 606 (even' 142 = true); test 607 (even' 142 = even 142) let main() = if Array.length Sys.argv <= 2 then begin test_out "intext.data"; test_in "intext.data"; test_out "intext.data"; test_in "intext.data"; Sys.remove "intext.data"; test_string(); test_buffer(); test_size(); test_block(); test_deep(); test_objects(); test_infix () end else if Sys.argv.(1) = "make" then begin let n = int_of_string Sys.argv.(2) in let oc = open_out_bin "intext.data" in counter := 0; output_value oc (make_big n); close_out oc end else if Sys.argv.(1) = "test" then begin let n = int_of_string Sys.argv.(2) in let ic = open_in_bin "intext.data" in let b = (input_value ic : t) in Gc.full_major(); close_in ic; counter := 0; if check_big n b then Printf.printf "Test big %d passed" n else Printf.printf "Test big %d FAILED" n; print_newline() end let _ = Printexc.catch main (); exit 0 mingw-ocaml/ocaml/testsuite/tests/lib-marshal/intextaux.c0000644000175000017500000000054712124403241023247 0ustar tootstoots#include #include value marshal_to_block(value vbuf, value vlen, value v, value vflags) { return Val_long(output_value_to_block(v, vflags, (char *) vbuf, Long_val(vlen))); } value marshal_from_block(value vbuf, value vlen) { return input_value_from_block((char *) vbuf, Long_val(vlen)); } mingw-ocaml/ocaml/testsuite/tests/basic/0000755000175000017500000000000012124403241017732 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/basic/patmatch.ml0000644000175000017500000000526312124403241022073 0ustar tootstoots(* Tests for matchings on integers and characters *) (* Dense integer switch *) let f = function 1 -> 1 | 2 -> 2 | 3 -> 3 | 4 -> 4 | 5 -> 5 | 6 -> 6 | _ -> 0 (* Sparse integer switch *) let g = function 303 -> 1 | 401 -> 2 | _ -> 0 (* Very sparse integer switch *) let iszero = function 0 -> true | _ -> false (* Simple matching on characters *) let h = function 'a' -> "a" | 'e' -> "e" | 'i' -> "i" | 'o' -> "o" | 'u' -> "u" | _ -> "?" (* Matching with orpats *) let k = function ' ' | '\t' | '\n' | '\r' -> "blk" | 'A'..'Z' | 'a'..'z' | '\192'..'\255' -> "letr" | '0'..'9' -> "dig" | '!'|'%'|'&'|'$'|'#'|'+'|'/'|':'|'<'|'='|'>'|'?'|'@'|'\\'| '~'|'^'|'|'|'*' -> "oper" | _ -> "othr" (* Matching on arrays *) let p = function [| x |] -> x | _ -> assert false let q = function [| x |] -> x | _ -> 0 let r = function [| x |] -> x | _ -> 0.0 let l = function [||] -> 0 | [|x|] -> x + 1 | [|x;y|] -> x + y | [|x;y;z|] -> x + y + z | _ -> assert false (* The test *) open Printf external string_create: int -> string = "caml_create_string" external unsafe_chr: int -> char = "%identity" external string_unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" (* The following function is roughly equivalent to Char.escaped, except that it is locale-independent. *) let escaped = function | '\'' -> "\\'" | '\\' -> "\\\\" | '\n' -> "\\n" | '\t' -> "\\t" | '\r' -> "\\r" | '\b' -> "\\b" | c -> if ((k c) <> "othr") && ((Char.code c) <= 191) then begin let s = string_create 1 in string_unsafe_set s 0 c; s end else begin let n = Char.code c in let s = string_create 4 in string_unsafe_set s 0 '\\'; string_unsafe_set s 1 (unsafe_chr (48 + n / 100)); string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10)); string_unsafe_set s 3 (unsafe_chr (48 + n mod 10)); s end let _ = for i = -5 to 10 do printf "f(%d) = %d\n" i (f i) done; List.iter (fun i -> printf "g(%d) = %d\n" i (g i)) [0;300;303;305;400;401;402;999]; for i = -2 to 2 do printf "iszero(%d) = %B\n" i (iszero i) done; for i = 97 to 126 do let c = Char.chr i in printf "h(%c) = %s\n" c (h c) done; for i = 0 to 255 do let c = Char.chr i in printf "\tk(%s) = %s" (escaped c) (k c) done; printf "\n"; printf "p([|\"hello\"|]) = %s\n" (p [|"hello"|]); printf "p([|1.0|]) = %f\n" (p [|1.0|]); printf "q([|2|]) = %d\n" (q [|2|]); printf "r([|3.0|]) = %f\n" (r [|3.0|]); printf "l([||]) = %d\n" (l [||]); printf "l([|1|]) = %d\n" (l [|1|]); printf "l([|2;3|]) = %d\n" (l [|2;3|]); printf "l([|4;5;6|]) = %d\n" (l [|4;5;6|]); exit 0 mingw-ocaml/ocaml/testsuite/tests/basic/equality.ml0000644000175000017500000000770112124403241022126 0ustar tootstootslet test n check res = print_string "Test "; print_int n; if check res then print_string " passed.\n" else print_string " FAILED.\n"; flush stderr let eq0 = function 0 -> true | _ -> false let eqm1 = function -1 -> true | _ -> false let eq1 = function 1 -> true | _ -> false let eqtrue (b:bool) = b let eqftffff = function (false,true,false,false,false,false) -> true | _ -> false let x = [1;2;3] let f x = 1 :: 2 :: 3 :: x let mklist len = let l = ref [] in for i = 1 to len do l := i :: !l done; !l type tree = Dummy | Leaf | Node of tree * tree let rec mktree depth = if depth <= 0 then Leaf else Node(mktree(depth - 1), mktree(depth - 1)) type 'a leftlist = Nil | Cons of 'a leftlist * 'a let mkleftlist len = let l = ref Nil in for i = 1 to len do l := Cons(!l, i) done; !l let _ = test 1 eq0 (compare 0 0); test 2 eqm1 (compare 0 1); test 3 eq1 (compare 1 0); test 4 eq0 (compare max_int max_int); test 5 eqm1 (compare min_int max_int); test 6 eq1 (compare max_int min_int); test 7 eq0 (compare "foo" "foo"); test 8 eqm1 (compare "foo" "zorglub"); test 9 eqm1 (compare "abcdef" "foo"); test 10 eqm1 (compare "abcdefghij" "abcdefghijkl"); test 11 eq1 (compare "abcdefghij" "abcdefghi"); test 12 eq0 (compare (0,1) (0,1)); test 13 eqm1 (compare (0,1) (0,2)); test 14 eqm1 (compare (0,1) (1,0)); test 15 eq1 (compare (0,1) (0,0)); test 16 eq1 (compare (1,0) (0,1)); test 17 eq0 (compare 0.0 0.0); test 18 eqm1 (compare 0.0 1.0); test 19 eqm1 (compare (-1.0) 0.0); test 20 eq0 (compare [| 0.0; 1.0; 2.0 |] [| 0.0; 1.0; 2.0 |]); test 21 eqm1 (compare [| 0.0; 1.0; 2.0 |] [| 0.0; 1.0; 3.0 |]); test 22 eq1 (compare [| 0.0; 5.0; 2.0 |] [| 0.0; 1.0; 2.0 |]); test 23 eq0 (compare [1;2;3;4] [1;2;3;4]); test 24 eqm1 (compare [1;2;3;4] [1;2;5;6]); test 25 eqm1 (compare [1;2;3;4] [1;2;3;4;5]); test 26 eq1 (compare [1;2;3;4] [1;2;3]); test 27 eq1 (compare [1;2;3;4] [1;2;0;4]); test 28 eq0 (compare (mklist 1000) (mklist 1000)); test 29 eq0 (compare (mkleftlist 1000) (mkleftlist 1000)); test 30 eq0 (compare (mktree 12) (mktree 12)); test 31 eqtrue (x = f []); test 32 eqtrue (stdout <> stderr); test 33 eqm1 (compare nan 0.0); test 34 eqm1 (compare nan neg_infinity); test 35 eq0 (compare nan nan); test 36 eqm1 (compare (0.0, nan) (0.0, 0.0)); test 37 eqm1 (compare (0.0, nan) (0.0, neg_infinity)); test 38 eq0 (compare (nan, 0.0) (nan, 0.0)); let cmpgen x y = (x=y, x<>y, xy, x>=y) in let cmpfloat (x:float) (y:float) = (x=y, x<>y, xy, x>=y) in test 39 eqftffff (cmpgen nan nan); test 40 eqftffff (cmpgen nan 0.0); test 41 eqftffff (cmpfloat nan nan); test 42 eqftffff (cmpfloat nan 0.0); test 43 eqtrue ([||] = [||]); (* Convoluted forms to test both the "positive" and "negative" cases of float tests *) let cmpfloatpos (x:float) (y:float) = ((let r = ref false in (if x = y then r := true); !r), (let r = ref false in (if x <> y then r := true); !r), (let r = ref false in (if x < y then r := true); !r), (let r = ref false in (if x <= y then r := true); !r), (let r = ref false in (if x > y then r := true); !r), (let r = ref false in (if x >= y then r := true); !r)) and cmpfloatneg (x:float) (y:float) = ((let r = ref true in (if not (x = y) then r := false); !r), (let r = ref true in (if not (x <> y) then r := false); !r), (let r = ref true in (if not (x < y) then r := false); !r), (let r = ref true in (if not (x <= y) then r := false); !r), (let r = ref true in (if not (x > y) then r := false); !r), (let r = ref true in (if not (x >= y) then r := false); !r)) in let testcmpfloat x y = cmpfloatpos x y = cmpgen x y && cmpfloatneg x y = cmpgen x y in test 50 eqtrue (testcmpfloat nan nan); test 51 eqtrue (testcmpfloat nan 0.0); test 52 eqtrue (testcmpfloat 0.0 nan); test 53 eqtrue (testcmpfloat 0.0 0.0); test 54 eqtrue (testcmpfloat 1.0 0.0); test 55 eqtrue (testcmpfloat 0.0 1.0) mingw-ocaml/ocaml/testsuite/tests/basic/boxedints.ml0000644000175000017500000005301012124403241022262 0ustar tootstoots(* Test the types nativeint, int32, int64 *) open Printf let error_occurred = ref false let function_tested = ref "" let testing_function s = function_tested := s; print_newline(); print_string s; print_newline() let test test_number answer correct_answer = flush stdout; flush stderr; if answer <> correct_answer then begin eprintf "*** Bad result (%s, test %d)\n" !function_tested test_number; flush stderr; error_occurred := true end else begin printf " %d..." test_number end (***** Tests on 32 bit arithmetic *****) module type TESTSIG = sig type t module Ops : sig val neg: t -> t val add: t -> t -> t val sub: t -> t -> t val mul: t -> t -> t val div: t -> t -> t val rem: t -> t -> t val logand: t -> t -> t val logor: t -> t -> t val logxor: t -> t -> t val shift_left: t -> int -> t val shift_right: t -> int -> t val shift_right_logical: t -> int -> t val of_int: int -> t val to_int: t -> int val of_float: float -> t val to_float: t -> float val zero: t val one: t val minus_one: t val min_int: t val max_int: t val format : string -> t -> string val to_string: t -> string val of_string: string -> t end val testcomp: t -> t -> bool*bool*bool*bool*bool*bool*int val skip_float_tests: bool end module Test32(M: TESTSIG) = struct open M open Ops let _ = testing_function "of_int, to_int"; test 1 (to_int (of_int 0)) 0; test 2 (to_int (of_int 123)) 123; test 3 (to_int (of_int (-456))) (-456); test 4 (to_int (of_int 0x3FFFFFFF)) 0x3FFFFFFF; test 5 (to_int (of_int (-0x40000000))) (-0x40000000); testing_function "of_string"; test 1 (of_string "0") (of_int 0); test 2 (of_string "123") (of_int 123); test 3 (of_string "-456") (of_int (-456)); test 4 (of_string "123456789") (of_int 123456789); test 5 (of_string "0xABCDEF") (of_int 0xABCDEF); test 6 (of_string "-0o1234567012") (of_int (- 0o1234567012)); test 7 (of_string "0b01010111111000001100") (of_int 0b01010111111000001100); test 8 (of_string "0x7FFFFFFF") max_int; test 9 (of_string "-0x80000000") min_int; test 10 (of_string "0x80000000") min_int; test 11 (of_string "0xFFFFFFFF") minus_one; testing_function "to_string, format"; List.iter (fun (n, s) -> test n (to_string (of_string s)) s) [1, "0"; 2, "123"; 3, "-456"; 4, "1234567890"; 5, "1073741824"; 6, "2147483647"; 7, "-2147483648"]; List.iter (fun (n, s) -> test n (format "0x%X" (of_string s)) s) [8, "0x0"; 9, "0x123"; 10, "0xABCDEF"; 11, "0x12345678"; 12, "0x7FFFFFFF"; 13, "0x80000000"; 14, "0xFFFFFFFF"]; test 15 (to_string max_int) "2147483647"; test 16 (to_string min_int) "-2147483648"; test 17 (to_string zero) "0"; test 18 (to_string one) "1"; test 19 (to_string minus_one) "-1"; testing_function "neg"; test 1 (neg (of_int 0)) (of_int 0); test 2 (neg (of_int 123)) (of_int (-123)); test 3 (neg (of_int (-456))) (of_int 456); test 4 (neg (of_int 123456789)) (of_int (-123456789)); test 5 (neg max_int) (of_string "-0x7FFFFFFF"); test 6 (neg min_int) min_int; testing_function "add"; test 1 (add (of_int 0) (of_int 0)) (of_int 0); test 2 (add (of_int 123) (of_int 0)) (of_int 123); test 3 (add (of_int 0) (of_int 456)) (of_int 456); test 4 (add (of_int 123) (of_int 456)) (of_int 579); test 5 (add (of_int (-123)) (of_int 456)) (of_int 333); test 6 (add (of_int 123) (of_int (-456))) (of_int (-333)); test 7 (add (of_int (-123)) (of_int (-456))) (of_int (-579)); test 8 (add (of_string "0x12345678") (of_string "0x9ABCDEF")) (of_string "0x1be02467"); test 9 (add max_int max_int) (of_int (-2)); test 10 (add min_int min_int) zero; test 11 (add max_int one) min_int; test 12 (add min_int minus_one) max_int; test 13 (add max_int min_int) minus_one; testing_function "sub"; test 1 (sub (of_int 0) (of_int 0)) (of_int 0); test 2 (sub (of_int 123) (of_int 0)) (of_int 123); test 3 (sub (of_int 0) (of_int 456)) (of_int (-456)); test 4 (sub (of_int 123) (of_int 456)) (of_int (-333)); test 5 (sub (of_int (-123)) (of_int 456)) (of_int (-579)); test 6 (sub (of_int 123) (of_int (-456))) (of_int 579); test 7 (sub (of_int (-123)) (of_int (-456))) (of_int 333); test 8 (sub (of_string "0x12345678") (of_string "0x9ABCDEF")) (of_string "0x8888889"); test 9 (sub max_int min_int) minus_one; test 10 (sub min_int max_int) one; test 11 (sub min_int one) max_int; test 12 (sub max_int minus_one) min_int; testing_function "mul"; test 1 (mul (of_int 0) (of_int 0)) (of_int 0); test 2 (mul (of_int 123) (of_int 0)) (of_int 0); test 3 (mul (of_int 0) (of_int (-456))) (of_int 0); test 4 (mul (of_int 123) (of_int 1)) (of_int 123); test 5 (mul (of_int 1) (of_int (-456))) (of_int (-456)); test 6 (mul (of_int 123) (of_int (-1))) (of_int (-123)); test 7 (mul (of_int (-1)) (of_int (-456))) (of_int 456); test 8 (mul (of_int 123) (of_int 456)) (of_int 56088); test 9 (mul (of_int (-123)) (of_int 456)) (of_int (-56088)); test 10 (mul (of_int 123) (of_int (-456))) (of_int (-56088)); test 11 (mul (of_int (-123)) (of_int (-456))) (of_int 56088); test 12 (mul (of_string "0x12345678") (of_string "0x9ABCDEF")) (of_string "0xe242d208"); test 13 (mul max_int max_int) one; testing_function "div"; List.iter (fun (n, a, b) -> test n (div (of_int a) (of_int b)) (of_int (a / b))) [1, 0, 2; 2, 123, 1; 3, -123, 1; 4, 123, -1; 5, -123, -1; 6, 127531236, 365; 7, 16384, 256; 8, -127531236, 365; 9, 127531236, -365; 10, 1234567, 12345678; 11, 1234567, -12345678]; test 12 (div min_int (of_int (-1))) min_int; testing_function "mod"; List.iter (fun (n, a, b) -> test n (rem (of_int a) (of_int b)) (of_int (a mod b))) [1, 0, 2; 2, 123, 1; 3, -123, 1; 4, 123, -1; 5, -123, -1; 6, 127531236, 365; 7, 16384, 256; 8, -127531236, 365; 9, 127531236, -365; 10, 1234567, 12345678; 11, 1234567, -12345678]; test 12 (rem min_int (of_int (-1))) (of_int 0); testing_function "and"; List.iter (fun (n, a, b, c) -> test n (logand (of_string a) (of_string b)) (of_string c)) [1, "0x12345678", "0x9abcdef0", "0x12345670"; 2, "0x12345678", "0x0fedcba9", "0x2244228"; 3, "0xFFFFFFFF", "0x12345678", "0x12345678"; 4, "0", "0x12345678", "0"; 5, "0x55555555", "0xAAAAAAAA", "0"]; testing_function "or"; List.iter (fun (n, a, b, c) -> test n (logor (of_string a) (of_string b)) (of_string c)) [1, "0x12345678", "0x9abcdef0", "0x9abcdef8"; 2, "0x12345678", "0x0fedcba9", "0x1ffddff9"; 3, "0xFFFFFFFF", "0x12345678", "0xFFFFFFFF"; 4, "0", "0x12345678", "0x12345678"; 5, "0x55555555", "0xAAAAAAAA", "0xFFFFFFFF"]; testing_function "xor"; List.iter (fun (n, a, b, c) -> test n (logxor (of_string a) (of_string b)) (of_string c)) [1, "0x12345678", "0x9abcdef0", "0x88888888"; 2, "0x12345678", "0x0fedcba9", "0x1dd99dd1"; 3, "0xFFFFFFFF", "0x12345678", "0xedcba987"; 4, "0", "0x12345678", "0x12345678"; 5, "0x55555555", "0xAAAAAAAA", "0xFFFFFFFF"]; testing_function "shift_left"; List.iter (fun (n, a, b, c) -> test n (shift_left (of_string a) b) (of_string c)) [1, "1", 1, "2"; 2, "1", 2, "4"; 3, "1", 4, "0x10"; 4, "1", 30, "0x40000000"; 5, "1", 31, "0x80000000"; 6, "0x16236", 7, "0xb11b00"; 7, "0x10", 27, "0x80000000"; 8, "0x10", 28, "0"]; testing_function "shift_right"; List.iter (fun (n, a, b, c) -> test n (shift_right (of_string a) b) (of_string c)) [1, "2", 1, "1"; 2, "4", 2, "1"; 3, "0x10", 4, "1"; 4, "0x40000000", 10, "0x100000"; 5, "0x80000000", 31, "-1"; 6, "0xb11b00", 7, "0x16236"; 7, "-0xb11b00", 7, "-90678"]; testing_function "shift_right_logical"; List.iter (fun (n, a, b, c) -> test n (shift_right_logical (of_string a) b) (of_string c)) [1, "2", 1, "1"; 2, "4", 2, "1"; 3, "0x10", 4, "1"; 4, "0x40000000", 10, "0x100000"; 5, "0x80000000", 31, "1"; 6, "0xb11b00", 7, "0x16236"; 7, "-0xb11b00", 7, "0x1fe9dca"]; if not (skip_float_tests) then begin testing_function "of_float"; test 1 (of_float 0.0) (of_int 0); test 2 (of_float 123.0) (of_int 123); test 3 (of_float 123.456) (of_int 123); test 4 (of_float 123.999) (of_int 123); test 5 (of_float (-456.0)) (of_int (-456)); test 6 (of_float (-456.123)) (of_int (-456)); test 7 (of_float (-456.789)) (of_int (-456)); testing_function "to_float"; test 1 (to_float (of_int 0)) 0.0; test 2 (to_float (of_int 123)) 123.0; test 3 (to_float (of_int (-456))) (-456.0); test 4 (to_float (of_int 0x3FFFFFFF)) 1073741823.0; test 5 (to_float (of_int (-0x40000000))) (-1073741824.0) end; testing_function "Comparisons"; test 1 (testcomp (of_int 0) (of_int 0)) (true,false,false,false,true,true,0); test 2 (testcomp (of_int 1234567) (of_int 1234567)) (true,false,false,false,true,true,0); test 3 (testcomp (of_int 0) (of_int 1)) (false,true,true,false,true,false,-1); test 4 (testcomp (of_int (-1)) (of_int 0)) (false,true,true,false,true,false,-1); test 5 (testcomp (of_int 1) (of_int 0)) (false,true,false,true,false,true,1); test 6 (testcomp (of_int 0) (of_int (-1))) (false,true,false,true,false,true,1); test 7 (testcomp max_int min_int) (false,true,false,true,false,true,1); () end (********* Tests on 64-bit arithmetic ***********) module Test64(M: TESTSIG) = struct open M open Ops let _ = testing_function "of_int, to_int"; test 1 (to_int (of_int 0)) 0; test 2 (to_int (of_int 123)) 123; test 3 (to_int (of_int (-456))) (-456); test 4 (to_int (of_int 0x3FFFFFFF)) 0x3FFFFFFF; test 5 (to_int (of_int (-0x40000000))) (-0x40000000); testing_function "of_string"; test 1 (of_string "0") (of_int 0); test 2 (of_string "123") (of_int 123); test 3 (of_string "-456") (of_int (-456)); test 4 (of_string "123456789") (of_int 123456789); test 5 (of_string "0xABCDEF") (of_int 0xABCDEF); test 6 (of_string "-0o1234567012") (of_int (- 0o1234567012)); test 7 (of_string "0b01010111111000001100") (of_int 0b01010111111000001100); test 8 (of_string "0x7FFFFFFFFFFFFFFF") max_int; test 9 (of_string "-0x8000000000000000") min_int; test 10 (of_string "0x8000000000000000") min_int; test 11 (of_string "0xFFFFFFFFFFFFFFFF") minus_one; testing_function "to_string, format"; List.iter (fun (n, s) -> test n (to_string (of_string s)) s) [1, "0"; 2, "123"; 3, "-456"; 4, "1234567890"; 5, "1234567890123456789"; 6, "9223372036854775807"; 7, "-9223372036854775808"]; List.iter (fun (n, s) -> test n ("0x" ^ format "%X" (of_string s)) s) [8, "0x0"; 9, "0x123"; 10, "0xABCDEF"; 11, "0x1234567812345678"; 12, "0x7FFFFFFFFFFFFFFF"; 13, "0x8000000000000000"; 14, "0xFFFFFFFFFFFFFFFF"]; test 15 (to_string max_int) "9223372036854775807"; test 16 (to_string min_int) "-9223372036854775808"; test 17 (to_string zero) "0"; test 18 (to_string one) "1"; test 19 (to_string minus_one) "-1"; testing_function "neg"; test 1 (neg (of_int 0)) (of_int 0); test 2 (neg (of_int 123)) (of_int (-123)); test 3 (neg (of_int (-456))) (of_int 456); test 4 (neg (of_int 123456789)) (of_int (-123456789)); test 5 (neg max_int) (of_string "-0x7FFFFFFFFFFFFFFF"); test 6 (neg min_int) min_int; testing_function "add"; test 1 (add (of_int 0) (of_int 0)) (of_int 0); test 2 (add (of_int 123) (of_int 0)) (of_int 123); test 3 (add (of_int 0) (of_int 456)) (of_int 456); test 4 (add (of_int 123) (of_int 456)) (of_int 579); test 5 (add (of_int (-123)) (of_int 456)) (of_int 333); test 6 (add (of_int 123) (of_int (-456))) (of_int (-333)); test 7 (add (of_int (-123)) (of_int (-456))) (of_int (-579)); test 8 (add (of_string "0x1234567812345678") (of_string "0x9ABCDEF09ABCDEF")) (of_string "0x1be024671be02467"); test 9 (add max_int max_int) (of_int (-2)); test 10 (add min_int min_int) zero; test 11 (add max_int one) min_int; test 12 (add min_int minus_one) max_int; test 13 (add max_int min_int) minus_one; testing_function "sub"; test 1 (sub (of_int 0) (of_int 0)) (of_int 0); test 2 (sub (of_int 123) (of_int 0)) (of_int 123); test 3 (sub (of_int 0) (of_int 456)) (of_int (-456)); test 4 (sub (of_int 123) (of_int 456)) (of_int (-333)); test 5 (sub (of_int (-123)) (of_int 456)) (of_int (-579)); test 6 (sub (of_int 123) (of_int (-456))) (of_int 579); test 7 (sub (of_int (-123)) (of_int (-456))) (of_int 333); test 8 (sub (of_string "0x1234567812345678") (of_string "0x9ABCDEF09ABCDEF")) (of_string "0x888888908888889"); test 9 (sub max_int min_int) minus_one; test 10 (sub min_int max_int) one; test 11 (sub min_int one) max_int; test 12 (sub max_int minus_one) min_int; testing_function "mul"; test 1 (mul (of_int 0) (of_int 0)) (of_int 0); test 2 (mul (of_int 123) (of_int 0)) (of_int 0); test 3 (mul (of_int 0) (of_int (-456))) (of_int 0); test 4 (mul (of_int 123) (of_int 1)) (of_int 123); test 5 (mul (of_int 1) (of_int (-456))) (of_int (-456)); test 6 (mul (of_int 123) (of_int (-1))) (of_int (-123)); test 7 (mul (of_int (-1)) (of_int (-456))) (of_int 456); test 8 (mul (of_int 123) (of_int 456)) (of_int 56088); test 9 (mul (of_int (-123)) (of_int 456)) (of_int (-56088)); test 10 (mul (of_int 123) (of_int (-456))) (of_int (-56088)); test 11 (mul (of_int (-123)) (of_int (-456))) (of_int 56088); test 12 (mul (of_string "0x12345678") (of_string "0x9ABCDEF")) (of_string "0xb00ea4e242d208"); test 13 (mul max_int max_int) one; testing_function "div"; List.iter (fun (n, a, b) -> test n (div (of_int a) (of_int b)) (of_int (a / b))) [1, 0, 2; 2, 123, 1; 3, -123, 1; 4, 123, -1; 5, -123, -1; 6, 127531236, 365; 7, 16384, 256; 8, -127531236, 365; 9, 127531236, -365; 10, 1234567, 12345678; 11, 1234567, -12345678]; test 12 (div min_int (of_int (-1))) min_int; testing_function "mod"; List.iter (fun (n, a, b) -> test n (rem (of_int a) (of_int b)) (of_int (a mod b))) [1, 0, 2; 2, 123, 1; 3, -123, 1; 4, 123, -1; 5, -123, -1; 6, 127531236, 365; 7, 16384, 256; 8, -127531236, 365; 9, 127531236, -365; 10, 1234567, 12345678; 11, 1234567, -12345678]; test 12 (rem min_int (of_int (-1))) (of_int 0); testing_function "and"; List.iter (fun (n, a, b, c) -> test n (logand (of_string a) (of_string b)) (of_string c)) [1, "0x1234567812345678", "0x9abcdef09abcdef0", "0x1234567012345670"; 2, "0x1234567812345678", "0x0fedcba90fedcba9", "0x224422802244228"; 3, "0xFFFFFFFFFFFFFFFF", "0x1234000012345678", "0x1234000012345678"; 4, "0", "0x1234567812345678", "0"; 5, "0x5555555555555555", "0xAAAAAAAAAAAAAAAA", "0"]; testing_function "or"; List.iter (fun (n, a, b, c) -> test n (logor (of_string a) (of_string b)) (of_string c)) [1, "0x1234567812345678", "0x9abcdef09abcdef0", "0x9abcdef89abcdef8"; 2, "0x1234567812345678", "0x0fedcba90fedcba9", "0x1ffddff91ffddff9"; 3, "0xFFFFFFFFFFFFFFFF", "0x12345678", "0xFFFFFFFFFFFFFFFF"; 4, "0", "0x1234567812340000", "0x1234567812340000"; 5, "0x5555555555555555", "0xAAAAAAAAAAAAAAAA", "0xFFFFFFFFFFFFFFFF"]; testing_function "xor"; List.iter (fun (n, a, b, c) -> test n (logxor (of_string a) (of_string b)) (of_string c)) [1, "0x1234567812345678", "0x9abcdef09abcdef0", "0x8888888888888888"; 2, "0x1234567812345678", "0x0fedcba90fedcba9", "0x1dd99dd11dd99dd1"; 3, "0xFFFFFFFFFFFFFFFF", "0x123456789ABCDEF", "0xfedcba9876543210"; 4, "0", "0x1234567812340000", "0x1234567812340000"; 5, "0x5555555555555555", "0xAAAAAAAAAAAAAAAA", "0xFFFFFFFFFFFFFFFF"]; testing_function "shift_left"; List.iter (fun (n, a, b, c) -> test n (shift_left (of_string a) b) (of_string c)) [1, "1", 1, "2"; 2, "1", 2, "4"; 3, "1", 4, "0x10"; 4, "1", 62, "0x4000000000000000"; 5, "1", 63, "0x8000000000000000"; 6, "0x16236ABD45673", 7, "0xb11b55ea2b3980"; 7, "0x10", 59, "0x8000000000000000"; 8, "0x10", 60, "0"]; testing_function "shift_right"; List.iter (fun (n, a, b, c) -> test n (shift_right (of_string a) b) (of_string c)) [1, "2", 1, "1"; 2, "4", 2, "1"; 3, "0x10", 4, "1"; 4, "0x40000000", 10, "0x100000"; 5, "0x8000000000000000", 63, "-1"; 6, "0xb11b55ea2b3980", 7, "0x16236ABD45673"; 7, "-0xb11b55ea2b3980", 7, "-389461927286387"]; testing_function "shift_right_logical"; List.iter (fun (n, a, b, c) -> test n (shift_right_logical (of_string a) b) (of_string c)) [1, "2", 1, "1"; 2, "4", 2, "1"; 3, "0x10", 4, "1"; 4, "0x40000000", 10, "0x100000"; 5, "0x8000000000000000", 63, "1"; 6, "0xb11b55ea2b3980", 7, "0x16236ABD45673"; 7, "-0xb11b55ea2b3980", 7, "0x1fe9dc9542ba98d"]; testing_function "Comparisons"; test 1 (testcomp (of_int 0) (of_int 0)) (true,false,false,false,true,true,0); test 2 (testcomp (of_int 1234567) (of_int 1234567)) (true,false,false,false,true,true,0); test 3 (testcomp (of_int 0) (of_int 1)) (false,true,true,false,true,false,-1); test 4 (testcomp (of_int (-1)) (of_int 0)) (false,true,true,false,true,false,-1); test 5 (testcomp (of_int 1) (of_int 0)) (false,true,false,true,false,true,1); test 6 (testcomp (of_int 0) (of_int (-1))) (false,true,false,true,false,true,1); test 7 (testcomp max_int min_int) (false,true,false,true,false,true,1); () end (******** The test proper **********) let testcomp_int32 (a : int32) (b : int32) = (a = b, a <> b, a < b, a > b, a <= b, a >= b, compare a b) let testcomp_int64 (a : int64) (b : int64) = (a = b, a <> b, a < b, a > b, a <= b, a >= b, compare a b) let testcomp_nativeint (a : nativeint) (b : nativeint) = (a = b, a <> b, a < b, a > b, a <= b, a >= b, compare a b) let _ = testing_function "-------- Int32 --------"; let module A = Test32(struct type t = int32 module Ops = Int32 let testcomp = testcomp_int32 let skip_float_tests = false end) in print_newline(); testing_function "-------- Int64 --------"; let module B = Test64(struct type t = int64 module Ops = Int64 let testcomp = testcomp_int64 let skip_float_tests = false end) in print_newline(); testing_function "-------- Nativeint --------"; begin match Sys.word_size with 32 -> let module C = Test32(struct type t = nativeint module Ops = Nativeint let testcomp = testcomp_nativeint let skip_float_tests = true end) in () | 64 -> let module C = Test64(struct type t = nativeint module Ops = Nativeint let testcomp = testcomp_nativeint let skip_float_tests = true end) in () | _ -> assert false end; print_newline(); testing_function "--------- Conversions -----------"; testing_function "nativeint of/to int32"; test 1 (Nativeint.of_int32 (Int32.of_string "0x12345678")) (Nativeint.of_string "0x12345678"); test 2 (Nativeint.to_int32 (Nativeint.of_string "0x12345678")) (Int32.of_string "0x12345678"); if Sys.word_size = 64 then test 3 (Nativeint.to_int32 (Nativeint.of_string "0x123456789ABCDEF0")) (Int32.of_string "0x9ABCDEF0") else test 3 0 0; (* placeholder to have the same output on both 32-bit and 64-bit *) testing_function "int64 of/to int32"; test 1 (Int64.of_int32 (Int32.of_string "-0x12345678")) (Int64.of_string "-0x12345678"); test 2 (Int64.to_int32 (Int64.of_string "-0x12345678")) (Int32.of_string "-0x12345678"); test 3 (Int64.to_int32 (Int64.of_string "0x123456789ABCDEF0")) (Int32.of_string "0x9ABCDEF0"); testing_function "int64 of/to nativeint"; test 1 (Int64.of_nativeint (Nativeint.of_string "0x12345678")) (Int64.of_string "0x12345678"); test 2 (Int64.to_nativeint (Int64.of_string "-0x12345678")) (Nativeint.of_string "-0x12345678"); test 3 (Int64.to_nativeint (Int64.of_string "0x123456789ABCDEF0")) (if Sys.word_size = 64 then Nativeint.of_string "0x123456789ABCDEF0" else Nativeint.of_string "0x9ABCDEF0") (********* End of test *********) let _ = print_newline(); if !error_occurred then begin prerr_endline "************* TEST FAILED ****************"; exit 2 end else exit 0 mingw-ocaml/ocaml/testsuite/tests/basic/Makefile0000644000175000017500000000015112124403241021367 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/basic/patmatch.reference0000644000175000017500000001032612124403241023415 0ustar tootstootsf(-5) = 0 f(-4) = 0 f(-3) = 0 f(-2) = 0 f(-1) = 0 f(0) = 0 f(1) = 1 f(2) = 2 f(3) = 3 f(4) = 4 f(5) = 5 f(6) = 6 f(7) = 0 f(8) = 0 f(9) = 0 f(10) = 0 g(0) = 0 g(300) = 0 g(303) = 1 g(305) = 0 g(400) = 0 g(401) = 2 g(402) = 0 g(999) = 0 iszero(-2) = false iszero(-1) = false iszero(0) = true iszero(1) = false iszero(2) = false h(a) = a h(b) = ? h(c) = ? h(d) = ? h(e) = e h(f) = ? h(g) = ? h(h) = ? h(i) = i h(j) = ? h(k) = ? h(l) = ? h(m) = ? h(n) = ? h(o) = o h(p) = ? h(q) = ? h(r) = ? h(s) = ? h(t) = ? h(u) = u h(v) = ? h(w) = ? h(x) = ? h(y) = ? h(z) = ? h({) = ? h(|) = ? h(}) = ? h(~) = ? k(\000) = othr k(\001) = othr k(\002) = othr k(\003) = othr k(\004) = othr k(\005) = othr k(\006) = othr k(\007) = othr k(\b) = othr k(\t) = blk k(\n) = blk k(\011) = othr k(\012) = othr k(\r) = blk k(\014) = othr k(\015) = othr k(\016) = othr k(\017) = othr k(\018) = othr k(\019) = othr k(\020) = othr k(\021) = othr k(\022) = othr k(\023) = othr k(\024) = othr k(\025) = othr k(\026) = othr k(\027) = othr k(\028) = othr k(\029) = othr k(\030) = othr k(\031) = othr k( ) = blk k(!) = oper k(\034) = othr k(#) = oper k($) = oper k(%) = oper k(&) = oper k(\') = othr k(\040) = othr k(\041) = othr k(*) = oper k(+) = oper k(\044) = othr k(\045) = othr k(\046) = othr k(/) = oper k(0) = dig k(1) = dig k(2) = dig k(3) = dig k(4) = dig k(5) = dig k(6) = dig k(7) = dig k(8) = dig k(9) = dig k(:) = oper k(\059) = othr k(<) = oper k(=) = oper k(>) = oper k(?) = oper k(@) = oper k(A) = letr k(B) = letr k(C) = letr k(D) = letr k(E) = letr k(F) = letr k(G) = letr k(H) = letr k(I) = letr k(J) = letr k(K) = letr k(L) = letr k(M) = letr k(N) = letr k(O) = letr k(P) = letr k(Q) = letr k(R) = letr k(S) = letr k(T) = letr k(U) = letr k(V) = letr k(W) = letr k(X) = letr k(Y) = letr k(Z) = letr k(\091) = othr k(\\) = oper k(\093) = othr k(^) = oper k(\095) = othr k(\096) = othr k(a) = letr k(b) = letr k(c) = letr k(d) = letr k(e) = letr k(f) = letr k(g) = letr k(h) = letr k(i) = letr k(j) = letr k(k) = letr k(l) = letr k(m) = letr k(n) = letr k(o) = letr k(p) = letr k(q) = letr k(r) = letr k(s) = letr k(t) = letr k(u) = letr k(v) = letr k(w) = letr k(x) = letr k(y) = letr k(z) = letr k(\123) = othr k(|) = oper k(\125) = othr k(~) = oper k(\127) = othr k(\128) = othr k(\129) = othr k(\130) = othr k(\131) = othr k(\132) = othr k(\133) = othr k(\134) = othr k(\135) = othr k(\136) = othr k(\137) = othr k(\138) = othr k(\139) = othr k(\140) = othr k(\141) = othr k(\142) = othr k(\143) = othr k(\144) = othr k(\145) = othr k(\146) = othr k(\147) = othr k(\148) = othr k(\149) = othr k(\150) = othr k(\151) = othr k(\152) = othr k(\153) = othr k(\154) = othr k(\155) = othr k(\156) = othr k(\157) = othr k(\158) = othr k(\159) = othr k(\160) = othr k(\161) = othr k(\162) = othr k(\163) = othr k(\164) = othr k(\165) = othr k(\166) = othr k(\167) = othr k(\168) = othr k(\169) = othr k(\170) = othr k(\171) = othr k(\172) = othr k(\173) = othr k(\174) = othr k(\175) = othr k(\176) = othr k(\177) = othr k(\178) = othr k(\179) = othr k(\180) = othr k(\181) = othr k(\182) = othr k(\183) = othr k(\184) = othr k(\185) = othr k(\186) = othr k(\187) = othr k(\188) = othr k(\189) = othr k(\190) = othr k(\191) = othr k(\192) = letr k(\193) = letr k(\194) = letr k(\195) = letr k(\196) = letr k(\197) = letr k(\198) = letr k(\199) = letr k(\200) = letr k(\201) = letr k(\202) = letr k(\203) = letr k(\204) = letr k(\205) = letr k(\206) = letr k(\207) = letr k(\208) = letr k(\209) = letr k(\210) = letr k(\211) = letr k(\212) = letr k(\213) = letr k(\214) = letr k(\215) = letr k(\216) = letr k(\217) = letr k(\218) = letr k(\219) = letr k(\220) = letr k(\221) = letr k(\222) = letr k(\223) = letr k(\224) = letr k(\225) = letr k(\226) = letr k(\227) = letr k(\228) = letr k(\229) = letr k(\230) = letr k(\231) = letr k(\232) = letr k(\233) = letr k(\234) = letr k(\235) = letr k(\236) = letr k(\237) = letr k(\238) = letr k(\239) = letr k(\240) = letr k(\241) = letr k(\242) = letr k(\243) = letr k(\244) = letr k(\245) = letr k(\246) = letr k(\247) = letr k(\248) = letr k(\249) = letr k(\250) = letr k(\251) = letr k(\252) = letr k(\253) = letr k(\254) = letr k(\255) = letr p([|"hello"|]) = hello p([|1.0|]) = 1.000000 q([|2|]) = 2 r([|3.0|]) = 3.000000 l([||]) = 0 l([|1|]) = 2 l([|2;3|]) = 5 l([|4;5;6|]) = 15 mingw-ocaml/ocaml/testsuite/tests/basic/bigints.reference0000644000175000017500000000023312124403241023247 0ustar tootstoots1000000000 10000000000 100000000000 1000000000000 10000000000000 100000000000000 1000000000000000 10000000000000000 100000000000000000 1000000000000000000 mingw-ocaml/ocaml/testsuite/tests/basic/tailcalls.reference0000644000175000017500000000004112124403241023555 0ustar tootstoots10000001 10000001 10000001 11 11 mingw-ocaml/ocaml/testsuite/tests/basic/sets.ml0000644000175000017500000000304112124403241021240 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) module IntSet = Set.Make(struct type t = int let compare x y = x-y end) let even = List.fold_right IntSet.add [0; -2; 2; 4; 6; -10] IntSet.empty let odd = List.fold_right IntSet.add [9; -7; 5; 1; -3] IntSet.empty let _ = for i = -10 to 10 do Printf.printf "%d %B %B\n" i (IntSet.mem i even) (IntSet.mem i odd) done module PowerSet(BaseSet: Set.S) (SetOrd: functor(S: Set.S) -> Set.OrderedType) = Set.Make(SetOrd(BaseSet)) module IntSetSet = PowerSet(IntSet)(functor (S: Set.S) -> S) let setofset = List.fold_right IntSetSet.add [even; odd] IntSetSet.empty let _ = List.iter (fun s -> Printf.printf "%B\n" (IntSetSet.mem s setofset)) [IntSet.empty; even; odd; IntSet.union even odd] let _ = exit 0 mingw-ocaml/ocaml/testsuite/tests/basic/arrays.ml0000644000175000017500000001163012124403241021566 0ustar tootstootslet bigarray n = [| n+0; n+1; n+2; n+3; n+4; n+5; n+6; n+7; n+8; n+9; n+10; n+11; n+12; n+13; n+14; n+15; n+16; n+17; n+18; n+19; n+20; n+21; n+22; n+23; n+24; n+25; n+26; n+27; n+28; n+29; n+30; n+31; n+32; n+33; n+34; n+35; n+36; n+37; n+38; n+39; n+40; n+41; n+42; n+43; n+44; n+45; n+46; n+47; n+48; n+49; n+50; n+51; n+52; n+53; n+54; n+55; n+56; n+57; n+58; n+59; n+60; n+61; n+62; n+63; n+64; n+65; n+66; n+67; n+68; n+69; n+70; n+71; n+72; n+73; n+74; n+75; n+76; n+77; n+78; n+79; n+80; n+81; n+82; n+83; n+84; n+85; n+86; n+87; n+88; n+89; n+90; n+91; n+92; n+93; n+94; n+95; n+96; n+97; n+98; n+99; n+100; n+101; n+102; n+103; n+104; n+105; n+106; n+107; n+108; n+109; n+110; n+111; n+112; n+113; n+114; n+115; n+116; n+117; n+118; n+119; n+120; n+121; n+122; n+123; n+124; n+125; n+126; n+127; n+128; n+129; n+130; n+131; n+132; n+133; n+134; n+135; n+136; n+137; n+138; n+139; n+140; n+141; n+142; n+143; n+144; n+145; n+146; n+147; n+148; n+149; n+150; n+151; n+152; n+153; n+154; n+155; n+156; n+157; n+158; n+159; n+160; n+161; n+162; n+163; n+164; n+165; n+166; n+167; n+168; n+169; n+170; n+171; n+172; n+173; n+174; n+175; n+176; n+177; n+178; n+179; n+180; n+181; n+182; n+183; n+184; n+185; n+186; n+187; n+188; n+189; n+190; n+191; n+192; n+193; n+194; n+195; n+196; n+197; n+198; n+199; n+200; n+201; n+202; n+203; n+204; n+205; n+206; n+207; n+208; n+209; n+210; n+211; n+212; n+213; n+214; n+215; n+216; n+217; n+218; n+219; n+220; n+221; n+222; n+223; n+224; n+225; n+226; n+227; n+228; n+229; n+230; n+231; n+232; n+233; n+234; n+235; n+236; n+237; n+238; n+239; n+240; n+241; n+242; n+243; n+244; n+245; n+246; n+247; n+248; n+249; n+250; n+251; n+252; n+253; n+254; n+255; n+256; n+257; n+258; n+259; n+260; n+261; n+262; n+263; n+264; n+265; n+266; n+267; n+268; n+269; n+270; n+271; n+272; n+273; n+274; n+275; n+276; n+277; n+278; n+279; n+280; n+281; n+282; n+283; n+284; n+285; n+286; n+287; n+288; n+289; n+290; n+291; n+292; n+293; n+294; n+295; n+296; n+297; n+298; n+299 |] let test1 () = let a = bigarray 12345 in Gc.full_major(); for i = 0 to Array.length a - 1 do if a.(i) <> 12345 + i then print_string "Test1: error\n" done let testcopy a = Array.copy a = a let test2 () = if not (testcopy [|1;2;3;4;5|]) then print_string "Test2: failed on int array\n"; if not (testcopy [|1.2;2.3;3.4;4.5|]) then print_string "Test2: failed on float array\n"; if not (testcopy [|"un"; "deux"; "trois"|]) then print_string "Test2: failed on string array\n"; if not (testcopy (bigarray 42)) then print_string "Test2: failed on big array\n" module AbstractFloat = (struct type t = float let to_float x = x let from_float x = x end : sig type t val to_float: t -> float val from_float: float -> t end) let test3 () = let t1 = AbstractFloat.from_float 1.0 and t2 = AbstractFloat.from_float 2.0 and t3 = AbstractFloat.from_float 3.0 in let v = [|t1;t2;t3|] in let w = Array.create 2 t1 in let u = Array.copy v in if not (AbstractFloat.to_float v.(0) = 1.0 && AbstractFloat.to_float v.(1) = 2.0 && AbstractFloat.to_float v.(2) = 3.0) then print_string "Test3: failed on v\n"; if not (AbstractFloat.to_float w.(0) = 1.0 && AbstractFloat.to_float w.(1) = 1.0) then print_string "Test3: failed on w\n"; if not (AbstractFloat.to_float u.(0) = 1.0 && AbstractFloat.to_float u.(1) = 2.0 && AbstractFloat.to_float u.(2) = 3.0) then print_string "Test3: failed on u\n" let test4 () = let a = bigarray 0 in let b = Array.sub a 50 10 in if b <> [| 50;51;52;53;54;55;56;57;58;59 |] then print_string "Test4: failed\n" let test5 () = if Array.append [| 1;2;3 |] [| 4;5 |] <> [| 1;2;3;4;5 |] then print_string "Test5: failed on int arrays\n"; if Array.append [| 1.0;2.0;3.0 |] [| 4.0;5.0 |] <> [| 1.0;2.0;3.0;4.0;5.0 |] then print_string "Test5: failed on float arrays\n" let test6 () = let a = [| 0;1;2;3;4;5;6;7;8;9 |] in let b = Array.concat [a;a;a;a;a;a;a;a;a;a] in if not (Array.length b = 100 && b.(6) = 6 && b.(42) = 2 && b.(99) = 9) then print_string "Test6: failed\n" let test7 () = let a = Array.make 10 "a" in let b = [| "b1"; "b2"; "b3" |] in Array.blit b 0 a 5 3; if a <> [|"a"; "a"; "a"; "a"; "a"; "b1"; "b2"; "b3"; "a"; "a"|] || b <> [|"b1"; "b2"; "b3"|] then print_string "Test7: failed(1)\n"; Array.blit a 5 a 6 4; if a <> [|"a"; "a"; "a"; "a"; "a"; "b1"; "b1"; "b2"; "b3"; "a"|] then print_string "Test7: failed(2)\n" let test8 () = (try ignore (Array.sub [||] 0 1); print_string "Test 8.1: failed\n" with Invalid_argument _ -> ()); (try ignore (Array.sub [|3;4|] 1 (-1)); print_string "Test 8.2: failed\n" with Invalid_argument _ -> ()); (try ignore (Array.sub [|3;4|] max_int 1); print_string "Test 8.3: failed\n" with Invalid_argument _ -> ()) let _ = test1(); test2(); test3(); test4(); test5(); test6(); test7(); test8(); exit 0 mingw-ocaml/ocaml/testsuite/tests/basic/bigints.ml0000644000175000017500000000220512124403241021722 0ustar tootstootslet _ = match Sys.word_size with | 32 -> print_int (1 * 1000000000); print_newline(); print_string "10000000000"; print_newline(); print_string "100000000000"; print_newline(); print_string "1000000000000"; print_newline(); print_string "10000000000000"; print_newline(); print_string "100000000000000"; print_newline(); print_string "1000000000000000"; print_newline(); print_string "10000000000000000"; print_newline(); print_string "100000000000000000"; print_newline(); print_string "1000000000000000000"; print_newline(); | 64 -> print_int (1 * 1000000000); print_newline(); print_int (10 * 1000000000); print_newline(); print_int (100 * 1000000000); print_newline(); print_int (1000 * 1000000000); print_newline(); print_int (10000 * 1000000000); print_newline(); print_int (100000 * 1000000000); print_newline(); print_int (1000000 * 1000000000); print_newline(); print_int (10000000 * 1000000000); print_newline(); print_int (100000000 * 1000000000); print_newline(); print_int (1000000000 * 1000000000); print_newline() | _ -> assert false mingw-ocaml/ocaml/testsuite/tests/basic/arrays.reference0000644000175000017500000000000012124403241023101 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/basic/maps.ml0000644000175000017500000000257412124403241021234 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) module IntMap = Map.Make(struct type t = int let compare x y = x-y end) let m1 = IntMap.add 4 "Y" (IntMap.singleton 3 "X1") let m2 = IntMap.add 4 "Y" (IntMap.singleton 5 "X2") let show m = IntMap.iter (fun k v -> Printf.printf "%d %s\n" k v) m let () = print_endline "Union+concat"; show (IntMap.merge (fun _ l r -> match l, r with Some x, None | None, Some x -> Some x | Some x, Some y -> Some (x ^ x) | _ -> assert false) m1 m2); print_endline "Inter"; show (IntMap.merge (fun _ l r -> match l, r with Some x, Some y when x = y -> Some x | _ -> None) m1 m2); () mingw-ocaml/ocaml/testsuite/tests/basic/includestruct.ml0000644000175000017500000000334112124403241023155 0ustar tootstoots(* Test for "include " inside structures *) module A = struct type t = int let x = (1 : t) let y = (2 : t) let f (z : t) = (x + z : t) end module B = struct include A type u = t * t let p = ((x, y) : u) let g ((x, y) : u) = ((f x, f y) : u) end let _ = let print_pair (x,y) = print_int x; print_string ", "; print_int y; print_newline() in print_pair B.p; print_pair (B.g B.p); print_pair (B.g (123, 456)) module H = struct include A let f (z : t) = (x - 1 : t) end let _ = print_int (H.f H.x); print_newline() module C = struct include (A : sig type t val f : t -> int val x : t end) let z = f x end let _ = print_int C.z; print_newline(); print_int (C.f C.x); print_newline() (* Toplevel inclusion *) include A let _ = print_int x; print_newline(); print_int (f y); print_newline() (* With a functor *) module F(X: sig end) = struct let _ = print_string "F is called"; print_newline() type t = A | B of int let print_t = function A -> print_string "A" | B x -> print_int x end module D = struct include F(struct end) let test() = print_t A; print_newline(); print_t (B 42); print_newline() end let _ = D.test(); D.print_t D.A; print_newline(); D.print_t (D.B 42); print_newline() (* Exceptions and classes *) module E = struct exception Exn of string class c = object method m = 1 end end module G = struct include E let _ = begin try raise (Exn "foo") with Exn s -> print_string s end; print_int ((new c)#m); print_newline() end let _ = begin try raise (G.Exn "foo") with G.Exn s -> print_string s end; print_int ((new G.c)#m); print_newline() mingw-ocaml/ocaml/testsuite/tests/basic/equality.reference0000644000175000017500000000140712124403241023451 0ustar tootstootsTest 1 passed. Test 2 passed. Test 3 passed. Test 4 passed. Test 5 passed. Test 6 passed. Test 7 passed. Test 8 passed. Test 9 passed. Test 10 passed. Test 11 passed. Test 12 passed. Test 13 passed. Test 14 passed. Test 15 passed. Test 16 passed. Test 17 passed. Test 18 passed. Test 19 passed. Test 20 passed. Test 21 passed. Test 22 passed. Test 23 passed. Test 24 passed. Test 25 passed. Test 26 passed. Test 27 passed. Test 28 passed. Test 29 passed. Test 30 passed. Test 31 passed. Test 32 passed. Test 33 passed. Test 34 passed. Test 35 passed. Test 36 passed. Test 37 passed. Test 38 passed. Test 39 passed. Test 40 passed. Test 41 passed. Test 42 passed. Test 43 passed. Test 50 passed. Test 51 passed. Test 52 passed. Test 53 passed. Test 54 passed. Test 55 passed. mingw-ocaml/ocaml/testsuite/tests/basic/tailcalls.ml0000644000175000017500000000166612124403241022245 0ustar tootstootslet rec tailcall4 a b c d = if a < 0 then b else tailcall4 (a-1) (b+1) (c+2) (d+3) let rec tailcall8 a b c d e f g h = if a < 0 then b else tailcall8 (a-1) (b+1) (c+2) (d+3) (e+4) (f+5) (g+6) (h+7) let rec tailcall16 a b c d e f g h i j k l m n o p = if a < 0 then b else tailcall16 (a-1) (b+1) (c+2) (d+3) (e+4) (f+5) (g+6) (h+7) (i+8) (j+9) (k+10) (l+11) (m+12) (n+13) (o+14) (p+15) let indtailcall8 fn a b c d e f g h = fn a b c d e f g h let indtailcall16 fn a b c d e f g h i j k l m n o p = fn a b c d e f g h i j k l m n o p let _ = print_int (tailcall4 10000000 0 0 0); print_newline(); print_int (tailcall8 10000000 0 0 0 0 0 0 0); print_newline(); print_int (tailcall16 10000000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); print_newline(); print_int (indtailcall8 tailcall8 10 0 0 0 0 0 0 0); print_newline(); print_int (indtailcall16 tailcall16 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); print_newline() mingw-ocaml/ocaml/testsuite/tests/basic/float.ml0000644000175000017500000000005512124403241021371 0ustar tootstootsPrintf.printf "1./.0. = %f\n" (1.0 /. 0.0);; mingw-ocaml/ocaml/testsuite/tests/basic/sets.reference0000644000175000017500000000054712124403241022576 0ustar tootstoots-10 true false -9 false false -8 false false -7 false true -6 false false -5 false false -4 false false -3 false true -2 true false -1 false false 0 true false 1 false true 2 true false 3 false false 4 true false 5 false true 6 true false 7 false false 8 false false 9 false true 10 false false false true true false mingw-ocaml/ocaml/testsuite/tests/basic/boxedints.reference0000644000175000017500000000574712124403241023626 0ustar tootstoots -------- Int32 -------- of_int, to_int 1... 2... 3... 4... 5... of_string 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... to_string, format 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... neg 1... 2... 3... 4... 5... 6... add 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... sub 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... mul 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... div 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... mod 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... and 1... 2... 3... 4... 5... or 1... 2... 3... 4... 5... xor 1... 2... 3... 4... 5... shift_left 1... 2... 3... 4... 5... 6... 7... 8... shift_right 1... 2... 3... 4... 5... 6... 7... shift_right_logical 1... 2... 3... 4... 5... 6... 7... of_float 1... 2... 3... 4... 5... 6... 7... to_float 1... 2... 3... 4... 5... Comparisons 1... 2... 3... 4... 5... 6... 7... -------- Int64 -------- of_int, to_int 1... 2... 3... 4... 5... of_string 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... to_string, format 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... neg 1... 2... 3... 4... 5... 6... add 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... sub 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... mul 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... div 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... mod 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... and 1... 2... 3... 4... 5... or 1... 2... 3... 4... 5... xor 1... 2... 3... 4... 5... shift_left 1... 2... 3... 4... 5... 6... 7... 8... shift_right 1... 2... 3... 4... 5... 6... 7... shift_right_logical 1... 2... 3... 4... 5... 6... 7... Comparisons 1... 2... 3... 4... 5... 6... 7... -------- Nativeint -------- of_int, to_int 1... 2... 3... 4... 5... of_string 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... to_string, format 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... neg 1... 2... 3... 4... 5... 6... add 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... sub 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... mul 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... div 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... mod 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... and 1... 2... 3... 4... 5... or 1... 2... 3... 4... 5... xor 1... 2... 3... 4... 5... shift_left 1... 2... 3... 4... 5... 6... 7... 8... shift_right 1... 2... 3... 4... 5... 6... 7... shift_right_logical 1... 2... 3... 4... 5... 6... 7... Comparisons 1... 2... 3... 4... 5... 6... 7... --------- Conversions ----------- nativeint of/to int32 1... 2... 3... int64 of/to int32 1... 2... 3... int64 of/to nativeint 1... 2... 3... mingw-ocaml/ocaml/testsuite/tests/basic/recvalues.reference0000644000175000017500000000010012124403241023572 0ustar tootstootsTest 1: passed Test 2: passed Test 3: passed foo Test 4: passed mingw-ocaml/ocaml/testsuite/tests/basic/float.reference0000644000175000017500000000001512124403241022713 0ustar tootstoots1./.0. = inf mingw-ocaml/ocaml/testsuite/tests/basic/includestruct.reference0000644000175000017500000000007512124403241024504 0ustar tootstoots1, 2 2, 3 124, 457 0 2 2 1 3 F is called A 42 A 42 foo1 foo1 mingw-ocaml/ocaml/testsuite/tests/basic/recvalues.ml0000644000175000017500000000174112124403241022260 0ustar tootstoots(* Recursive value definitions *) let _ = let rec x = 1 :: x in if match x with 1 :: x' -> x == x' | _ -> false then print_string "Test 1: passed\n" else print_string "Test 1: FAILED\n"; let one = 1 in let rec y = (one, one+1) :: y in if match y with (1,2) :: y' -> y == y' | _ -> false then print_string "Test 2: passed\n" else print_string "Test 2: FAILED\n"; let rec z = (Gc.minor(); (one, one+1)) :: z in (* Trash the minor generation *) for i = 0 to 50000 do ignore (ref 0) done; if match z with (1,2) :: z' -> z == z' | _ -> false then print_string "Test 3: passed\n" else print_string "Test 3: FAILED\n"; ;; let rec s = "bar" and idx = 1 and x1 = let f x = Printf.printf "%s\n" x in f "foo"; s, x4 and x2 = [| x1; x1 |] and x3 = (fun () -> fst (x2.(idx))) :: x3 and x4 = {contents = x3} ;; Gc.minor ();; if (List.hd (!(snd (x2.(0))))) () == s then print_string "Test 4: passed\n" else print_string "Test 4: FAILED\n" mingw-ocaml/ocaml/testsuite/tests/basic/maps.reference0000644000175000017500000000004612124403241022552 0ustar tootstootsUnion+concat 3 X1 4 YY 5 X2 Inter 4 Y mingw-ocaml/ocaml/testsuite/tests/typing-private-bugs/0000755000175000017500000000000012124403241022571 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-private-bugs/Makefile0000644000175000017500000000014712124403241024233 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.okbad include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-private-bugs/pr5469_ok.ml0000644000175000017500000000023212124403241024562 0ustar tootstootsmodule M (T:sig type t end) = struct type t = private { t : T.t } end module P = struct module T = struct type t end module R = M(T) end mingw-ocaml/ocaml/testsuite/tests/typing-private-bugs/pr5026_bad.ml0000644000175000017500000000042712124403241024672 0ustar tootstootstype untyped;; type -'a typed = private untyped;; type -'typing wrapped = private sexp and +'a t = 'a typed wrapped and sexp = private untyped wrapped;; class type ['a] s3 = object val underlying : 'a t end;; class ['a] s3object r : ['a] s3 = object val underlying = r end;; mingw-ocaml/ocaml/testsuite/tests/lib-set/0000755000175000017500000000000012124403241020210 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-set/Makefile0000644000175000017500000000015112124403241021645 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-set/testmap.ml0000644000175000017500000000625412124403241022226 0ustar tootstootsmodule M = Map.Make(struct type t = int let compare = compare end) let img x m = try Some(M.find x m) with Not_found -> None let testvals = [0;1;2;3;4;5;6;7;8;9] let check msg cond = if not (List.for_all cond testvals) then Printf.printf "Test %s FAILED\n%!" msg let checkbool msg b = if not b then Printf.printf "Test %s FAILED\n%!" msg let uncurry (f: 'a -> 'b -> 'c) (x, y: 'a * 'b) : 'c = f x y let test x v s1 s2 = checkbool "is_empty" (M.is_empty s1 = List.for_all (fun i -> img i s1 = None) testvals); check "mem" (fun i -> M.mem i s1 = (img i s1 <> None)); check "add" (let s = M.add x v s1 in fun i -> img i s = (if i = x then Some v else img i s1)); check "singleton" (let s = M.singleton x v in fun i -> img i s = (if i = x then Some v else None)); check "remove" (let s = M.remove x s1 in fun i -> img i s = (if i = x then None else img i s1)); check "merge-union" (let f _ o1 o2 = match o1, o2 with | Some v1, Some v2 -> Some (v1 +. v2) | None, _ -> o2 | _, None -> o1 in let s = M.merge f s1 s2 in fun i -> img i s = f i (img i s1) (img i s2)); check "merge-inter" (let f _ o1 o2 = match o1, o2 with | Some v1, Some v2 -> Some (v1 -. v2) | _, _ -> None in let s = M.merge f s1 s2 in fun i -> img i s = f i (img i s1) (img i s2)); checkbool "bindings" (let rec extract = function | [] -> [] | hd :: tl -> match img hd s1 with | None -> extract tl | Some v ->(hd, v) :: extract tl in M.bindings s1 = extract testvals); checkbool "for_all" (let p x y = x mod 2 = 0 in M.for_all p s1 = List.for_all (uncurry p) (M.bindings s1)); checkbool "exists" (let p x y = x mod 3 = 0 in M.exists p s1 = List.exists (uncurry p) (M.bindings s1)); checkbool "filter" (let p x y = x >= 3 && x <= 6 in M.bindings(M.filter p s1) = List.filter (uncurry p) (M.bindings s1)); checkbool "partition" (let p x y = x >= 3 && x <= 6 in let (st,sf) = M.partition p s1 and (lt,lf) = List.partition (uncurry p) (M.bindings s1) in M.bindings st = lt && M.bindings sf = lf); checkbool "cardinal" (M.cardinal s1 = List.length (M.bindings s1)); checkbool "min_binding" (try let (k,v) = M.min_binding s1 in img k s1 = Some v && M.for_all (fun i _ -> k <= i) s1 with Not_found -> M.is_empty s1); checkbool "max_binding" (try let (k,v) = M.max_binding s1 in img k s1 = Some v && M.for_all (fun i _ -> k >= i) s1 with Not_found -> M.is_empty s1); checkbool "choose" (try let (x,v) = M.choose s1 in img x s1 = Some v with Not_found -> M.is_empty s1); check "split" (let (l, p, r) = M.split x s1 in fun i -> if i < x then img i l = img i s1 else if i > x then img i r = img i s1 else p = img i s1) let rkey() = Random.int 10 let rdata() = Random.float 1.0 let rmap() = let s = ref M.empty in for i = 1 to Random.int 10 do s := M.add (rkey()) (rdata()) !s done; !s let _ = Random.init 42; for i = 1 to 25000 do test (rkey()) (rdata()) (rmap()) (rmap()) done mingw-ocaml/ocaml/testsuite/tests/lib-set/testset.ml0000644000175000017500000000571712124403241022247 0ustar tootstootsmodule S = Set.Make(struct type t = int let compare = compare end) let testvals = [0;1;2;3;4;5;6;7;8;9] let check msg cond = if not (List.for_all cond testvals) then Printf.printf "Test %s FAILED\n%!" msg let checkbool msg b = if not b then Printf.printf "Test %s FAILED\n%!" msg let normalize_cmp c = if c = 0 then 0 else if c > 0 then 1 else -1 let test x s1 s2 = checkbool "is_empty" (S.is_empty s1 = List.for_all (fun i -> not (S.mem i s1)) testvals); check "add" (let s = S.add x s1 in fun i -> S.mem i s = (S.mem i s1 || i = x)); check "singleton" (let s = S.singleton x in fun i -> S.mem i s = (i = x)); check "remove" (let s = S.remove x s1 in fun i -> S.mem i s = (S.mem i s1 && i <> x)); check "union" (let s = S.union s1 s2 in fun i -> S.mem i s = (S.mem i s1 || S.mem i s2)); check "inter" (let s = S.inter s1 s2 in fun i -> S.mem i s = (S.mem i s1 && S.mem i s2)); check "diff" (let s = S.diff s1 s2 in fun i -> S.mem i s = (S.mem i s1 && not (S.mem i s2))); checkbool "elements" (S.elements s1 = List.filter (fun i -> S.mem i s1) testvals); checkbool "compare" (normalize_cmp (S.compare s1 s2) = normalize_cmp (compare (S.elements s1) (S.elements s2))); checkbool "equal" (S.equal s1 s2 = (S.elements s1 = S.elements s2)); check "subset" (let b = S.subset s1 s2 in fun i -> if b && S.mem i s1 then S.mem i s2 else true); checkbool "subset2" (let b = S.subset s1 s2 in b || not (S.is_empty (S.diff s1 s2))); checkbool "for_all" (let p x = x mod 2 = 0 in S.for_all p s1 = List.for_all p (S.elements s1)); checkbool "exists" (let p x = x mod 3 = 0 in S.exists p s1 = List.exists p (S.elements s1)); checkbool "filter" (let p x = x >= 3 && x <= 6 in S.elements(S.filter p s1) = List.filter p (S.elements s1)); checkbool "partition" (let p x = x >= 3 && x <= 6 in let (st,sf) = S.partition p s1 and (lt,lf) = List.partition p (S.elements s1) in S.elements st = lt && S.elements sf = lf); checkbool "cardinal" (S.cardinal s1 = List.length (S.elements s1)); checkbool "min_elt" (try let m = S.min_elt s1 in S.mem m s1 && S.for_all (fun i -> m <= i) s1 with Not_found -> S.is_empty s1); checkbool "max_elt" (try let m = S.max_elt s1 in S.mem m s1 && S.for_all (fun i -> m >= i) s1 with Not_found -> S.is_empty s1); checkbool "choose" (try let x = S.choose s1 in S.mem x s1 with Not_found -> S.is_empty s1); check "split" (let (l, p, r) = S.split x s1 in fun i -> if i < x then S.mem i l = S.mem i s1 else if i > x then S.mem i r = S.mem i s1 else p = S.mem i s1) let relt() = Random.int 10 let rset() = let s = ref S.empty in for i = 1 to Random.int 10 do s := S.add (relt()) !s done; !s let _ = Random.init 42; for i = 1 to 25000 do test (relt()) (rset()) (rset()) done mingw-ocaml/ocaml/testsuite/tests/lib-set/testmap.reference0000644000175000017500000000000012124403241023533 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-set/testset.reference0000644000175000017500000000000012124403241023551 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-dynlink-csharp/0000755000175000017500000000000012124403241022343 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-dynlink-csharp/Makefile0000644000175000017500000000401612124403241024004 0ustar tootstootsBASEDIR=../.. CSC=csc default: @if [ -z "$(BYTECODE_ONLY)" ]; then \ $(MAKE) all; \ fi all: prepare bytecode bytecode-dll native native-dll prepare: @$(OCAMLC) -c plugin.ml @$(OCAMLOPT) -o plugin.cmxs -shared plugin.ml bytecode: @printf " ... testing 'bytecode':" @if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \ echo " => passed"; \ else \ $(OCAMLC) -output-obj -o main.dll dynlink.cma main.ml entry.c; \ $(CSC) /out:main.exe main.cs; \ ./main.exe > bytecode.result; \ $(DIFF) bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \ fi bytecode-dll: @printf " ... testing 'bytecode-dll':" @if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \ echo " => passed"; \ else \ $(OCAMLC) -output-obj -o main_obj.$(O) dynlink.cma entry.c main.ml; \ $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) ../../byterun/libcamlrun.$(A) $(BYTECCLIBS) -v; \ $(CSC) /out:main.exe main.cs; \ ./main.exe > bytecode.result; \ $(DIFF) bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \ fi native: @printf " ... testing 'native':" @if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \ echo " => passed"; \ else \ $(OCAMLOPT) -output-obj -o main.dll dynlink.cmxa entry.c main.ml; \ $(CSC) /out:main.exe main.cs; \ ./main.exe > native.result; \ $(DIFF) native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \ fi native-dll: @printf " ... testing 'native-dll':" @if [ ! `which $(CSC) > /dev/null 2>&1` ]; then \ echo " => passed"; \ else \ $(OCAMLOPT) -output-obj -o main_obj.$(O) dynlink.cmxa entry.c main.ml; \ $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) ../../asmrun/libasmrun.lib -v; \ $(CSC) /out:main.exe main.cs; \ ./main.exe > native.result; \ $(DIFF) native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \ fi promote: defaultpromote clean: defaultclean @rm -f *.result *.exe *.dll include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-csharp/native.reference0000644000175000017500000000023212124403241025506 0ustar tootstootsNow starting the OCaml engine. Main is running. Loading ../../../otherlibs/bigarray/bigarray.cmxs I'm the plugin. Loading plugin.cmxs I'm the plugin. OK. mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-csharp/main.ml0000755000175000017500000000075412124403241023632 0ustar tootstootslet load s = Printf.printf "Loading %s\n%!" s; try Dynlink.loadfile s with Dynlink.Error e -> print_endline (Dynlink.error_message e) let () = print_endline "Main is running."; Dynlink.init (); Dynlink.allow_unsafe_modules true; let s1,s2 = if Dynlink.is_native then "../../../otherlibs/bigarray/bigarray.cmxs", "plugin.cmxs" else "../../../otherlibs/bigarray/bigarray.cma", "plugin.cmo" in load s1; load s2; print_endline "OK." mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-csharp/entry.c0000755000175000017500000000044112124403241023652 0ustar tootstoots#include #include #include #include #include #include __declspec(dllexport) void __stdcall start_caml_engine() { char * argv[2]; argv[0] = "--"; argv[1] = NULL; caml_startup(argv); } mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-csharp/main.cs0000755000175000017500000000040112124403241023614 0ustar tootstootsusing System.Runtime.InteropServices; public class M { [DllImport("main.dll")] public static extern void start_caml_engine(); public static void Main() { System.Console.WriteLine("Now starting the OCaml engine."); start_caml_engine(); } } mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-csharp/plugin.ml0000755000175000017500000000007412124403241024177 0ustar tootstootslet f x = x.{2} let () = print_endline "I'm the plugin." mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-csharp/bytecode.reference0000644000175000017500000000023012124403241026014 0ustar tootstootsNow starting the OCaml engine. Main is running. Loading ../../../otherlibs/bigarray/bigarray.cma I'm the plugin. Loading plugin.cmo I'm the plugin. OK. mingw-ocaml/ocaml/testsuite/tests/basic-more/0000755000175000017500000000000012124403241020672 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/basic-more/Makefile0000644000175000017500000000017212124403241022332 0ustar tootstootsBASEDIR=../.. MODULES=testing include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/basic-more/morematch.ml0000644000175000017500000006330712124403241023214 0ustar tootstoots(**************************************************************) (* This suite tests the pattern-matching compiler *) (* it should just compile and run. *) (* While compiling the following messages are normal: *) (**************************************************************) (* File "morematch.ml", line 38, characters 10-93: Warning: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: 0 File "morematch.ml", line 376, characters 2-15: Warning: this match case is unused. File "morematch.ml", line 443, characters 2-7: Warning: this match case is unused. *) let test msg f arg r = if f arg <> r then begin prerr_endline msg ; failwith "Malaise" end ;; type t = A | B | C | D | E | F ;; let f x = match x with | A | B | C -> 1 | D | E -> 2 | F -> 3;; test "un" f C 1 ; test "un" f D 2 ; test "un" f F 3 ; () ;; let g x = match x with 1 -> 1 | 2 -> 2 | 3 -> 3 | 4 | 5 -> 4 | 6 -> 5 | 7 | 8 -> 6 | 9 -> 7 | _ -> assert false ;; test "deux" g 5 4 ; test "deux" g 6 5 ; test "deux" g 9 7 ; () ;; let g x = match x with 1 -> 1 | 2 -> 2 | 3 -> 3 | 4 | 5 -> 4 | 6 -> 5 | 7 | 8 -> 6 | 9 -> 7 | _ -> 8;; test "trois" g 10 8 ;; let g x= match x with 1 -> 1 | 2 -> 2 | 3 -> 3 | 4 | 5 -> 4 | 6 -> 5 | 4|5|7 -> 100 | 7 | 8 -> 6 | 9 -> 7 | _ -> 8;; test "quatre" g 4 4 ; test "quatre" g 7 100 ; () ;; (* File "morematch.ml", line 73, characters 2-5: Warning U: this sub-pattern is unused. File "morematch.ml", line 74, characters 2-3: Warning U: this sub-pattern is unused. *) let h x = match x with (1,1) -> 1 | (2|3), 1 -> 2 | 2,(2|3) -> 3 | (4,4) -> 5 | _ -> 100 ;; test "cinq" h (2,2) 3 ; test "cinq" h (2,1) 2 ; test "cinq" h (2,4) 100 ; () ;; (* idem hh (2,5) *) let hh x = match x with | 1,1 -> 1 | 2,1 -> 2 | (2|3),(1|2|3|4) -> 3 | 2,5 -> 4 | (4,4) -> 5 | _ -> 100 ;; let hhh x = match x with | 1,1 -> 1 | (2|3),1 -> 2 | 2,2 -> 3 | _ -> 100 ;; let h x = match x with (1,1) -> 1 | 3,1 -> 2 | 2,(2|3) -> 3 | (4,4) -> 5 | _ -> 100 ;; let h x = match x with 1 -> 1 | 2|3 -> 2 | 4 -> 4 | 5 -> 5 | 6|7 -> 6 | 8 -> 8 | _ -> 100 ;; let f x = match x with | ((1|2),(3|4))|((3|4),(1|2)) -> 1 | (3,(5|6)) -> 2 | _ -> 3 ;; test "six" f (1,3) 1 ; test "six" f (3,2) 1 ; test "six" f (3,5) 2 ; test "six" f (3,7) 3 ; () ;; type tt = {a : bool list ; b : bool} let f = function | {a=([]|[true])} -> 1 | {a=false::_}|{b=(true|false)} -> 2 ;; test "sept" f {a=[] ; b = true} 1 ; test "sept" f {a=[true] ; b = false} 1 ; test "sept" f {a=[false ; true] ; b = true} 2 ; test "sept" f {a=[false] ; b = false} 2 ; () ;; let f = function | (([]|[true]),_) -> 1 | (false::_,_)|(_,(true|false)) -> 2 ;; test "huit" f ([],true) 1 ; test "huit" f ([true],false) 1 ; test "huit" f ([false ; true], true) 2 ; test "huit" f ([false], false) 2 ; () ;; let split_cases = function | `Nil | `Cons _ as x -> `A x | `Snoc _ as x -> `B x ;; test "oubli" split_cases `Nil (`A `Nil); test "oubli" split_cases (`Cons 1) (`A (`Cons 1)); test "oubli" split_cases (`Snoc 1) (`B (`Snoc 1)) ; () ;; type t1 = A of int | B of int let f1 = function | (A x | B x) -> x ;; test "neuf" f1 (A 1) 1 ; test "neuf" f1 (B 1) 1 ; ;; type coucou = A of int | B of int * int | C ;; let g = function | (A x | B (_,x)) -> x | C -> 0 ;; test "dix" g (A 1) 1 ; test "dix" g (B (1,2)) 2 ; ;; let h = function | ([x]|[1 ; x ]|[1 ; 2 ; x]) -> x | _ -> 0 ;; test "encore" h [1] 1 ; test "encore" h [1;2] 2 ; test "encore" h [1;2;3] 3 ; test "encore" h [0 ; 0] 0 ; () ;; let f = function | (x,(0 as y)) | (y,x) -> y-x ;; test "foo1" f (1,0) (-1); test "foo1" f (1,2) (-1) ;; let f = function (([]|[_]) as x)|(_::([] as x))|(_::_::x) -> x ;; test "zob" f [] [] ; test "zob" f [1] [1] ; test "zob" f [1;2;3] [3] ;; type zob = A | B | C | D of zob * int | E of zob * zob let rec f = function | (A | B | C) -> A | D (x,i) -> D (f x,i) | E (x,_) -> D (f x,0) ;; test "fin" f B A ; test "fin" f (D (C,1)) (D (A,1)) ; test "fin" f (E (C,A)) (D (A,0)) ; () ;; type length = Char of int | Pixel of int | Percent of int | No of string | Default let length = function | Char n -> n | Pixel n -> n | _ -> 0 ;; test "length" length (Char 10) 10 ; test "length" length (Pixel 20) 20 ; test "length" length Default 0 ; test "length" length (Percent 100) 0 ; () ;; let length2 = function | Char n -> n | Percent n -> n | _ -> 0 ;; test "length2" length2 (Char 10) 10 ; test "length2" length2 (Pixel 20) 0 ; test "length2" length2 Default 0 ; test "length2" length2(Percent 100) 100 ; () ;; let length3 = function | Char _ | No _ -> true | _ -> false ;; test "length3" length3 (Char 10) true ; test "length3" length3 (No "") true ; test "length3" length3 (Pixel 20) false ; test "length3" length3 Default false ; test "length3" length3(Percent 100) false ; () ;; type hevea = A | B | C let h x = match x with | A -> 1 | B|C -> 2 ;; test "hevea" h A 1 ; test "hevea" h B 2 ; test "hevea" h B 2 ; () ;; type lambda = Lvar of int | Lconst of int | Lapply of lambda * lambda list | Lfunction of bool * int list * lambda | Llet of bool * int * lambda * lambda | Lletrec of (int * lambda) list * lambda | Lprim of string * lambda list | Lswitch of lambda * lambda_switch | Lstaticfail | Lcatch of lambda * lambda | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * int list) * lambda | Ltrywith of lambda * int * lambda | Lifthenelse of lambda * lambda * lambda | Lsequence of lambda * lambda | Lwhile of lambda * lambda | Lfor of int * lambda * lambda * bool * lambda | Lassign of int * lambda | Lsend of lambda * lambda * lambda list | Levent of lambda * lambda_event | Lifused of int * lambda and lambda_switch = { sw_numconsts: int; (* Number of integer cases *) sw_consts: (int * lambda) list; (* Integer cases *) sw_numblocks: int; (* Number of tag block cases *) sw_blocks: (int * lambda) list; (* Tag block cases *) sw_checked: bool ; (* True if bound checks needed *) sw_nofail: bool} (* True if should not fail *) and lambda_event = { lev_loc: int; lev_kind: bool ; lev_repr: int ref option; lev_env: int list } let rec approx_present v l = true let rec lower_bind v arg lam = match lam with | Lifthenelse (cond, ifso, ifnot) -> 1 | Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as _sw)) when not (approx_present v ls) -> 2 | Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as _sw)) when not (approx_present v ls) -> 3 | Llet (true , vv, lv, l) -> 4 | _ -> 5 ;; test "lower_bind" (lower_bind 0 0) (Llet (true,0, Lvar 1, Lvar 2)) 4 ; test "lower_bind" (lower_bind 0 0) (Lvar 0) 5 ; test "lower_bind" (lower_bind 0 0) (Lifthenelse (Lvar 0, Lvar 1, Lvar 2)) 1 ;; type field_kind = Fvar of field_kind option ref | Fpresent | Fabsent let unify_kind (k1, k2) = match k1, k2 with (Fvar r, (Fvar _ | Fpresent)) -> 1 | (Fpresent, Fvar r) -> 2 | (Fpresent, Fpresent) -> 3 | _ -> 4 let r = ref (Some Fpresent) ;; test "unify" unify_kind (Fvar r, Fpresent) 1 ; test "unify" unify_kind (Fvar r, Fvar r) 1 ; test "unify" unify_kind (Fvar r, Fabsent) 4 ; test "unify" unify_kind (Fpresent, Fvar r) 2 ; test "unify" unify_kind (Fpresent, Fpresent) 3 ; test "unify" unify_kind (Fabsent, Fpresent) 4 ; () ;; type youyou = A | B | C | D of youyou let foo (k1, k2) = match k1,k2 with | D _, (A|D _) -> 1 | (A|B),D _ -> 2 | C,_ -> 3 | _, (A|B|C) -> 4 ;; test "foo2" foo (D A,A) 1 ; test "foo2" foo (D A,B) 4 ; test "foo2" foo (A,A) 4 ; () ;; type yaya = A | B ;; let yaya = function | A,_,_ -> 1 | _,A,_ -> 2 | B,B,_ -> 3 | A,_,(100|103) -> 5 ;; test "yaya" yaya (A,A,0) 1 ; test "yaya" yaya (B,A,0) 2 ; test "yaya" yaya (B,B,100) 3 ; () ;; (* let yoyo = function | [],_,_ -> 1 | _,[],_ -> 2 | _::_,_::_,_ -> 3 | [],_,(100|103|104) -> 5 | [],_,(100|103) -> 6 | [],_,(1000|1001|1002|20000) -> 7 ;; test "yoyo" yoyo ([],[],0) 1 ; test "yoyo" yoyo ([1],[],0) 2 ; test "yoyo" yoyo ([1],[1],100) 3 ; () ;; let youyou = function | (100|103|104) -> 1 | (100|103|101) -> 2 | (1000|1001|1002|20000) -> 3 | _ -> -1 ;; test "youyou" youyou 100 1 ; test "youyou" youyou 101 2 ; test "youyou" youyou 1000 3 ;; *) type autre = | C | D | E of autre | F of autre * autre | H of autre | I | J | K of string let rec autre = function | C,_,_ -> 1 | _,C,_ -> 2 | D,D,_ -> 3 | (D|F (_,_)|H _|K _),_,_ -> 4 | (_, (D|I|E _|F (_, _)|H _|K _), _) -> 8 | (J,J,((C|D) as x |E x|F (_,x))) | (J,_,((C|J) as x)) -> autre (x,x,x) | (J, J, (I|H _|K _)) -> 9 | I,_,_ -> 6 | E _,_,_ -> 7 ;; (* File "morematch.ml", line 437, characters 43-44: Warning U: this sub-pattern is unused. *) test "autre" autre (J,J,F (D,D)) 3 ; test "autre" autre (J,J,D) 3 ; test "autre" autre (J,J,I) 9 ; test "autre" autre (H I,I,I) 4 ; test "autre" autre (J,J,H I) 9 ; () ;; type youpi = YA | YB | YC and hola = X | Y | Z | T of hola | U of hola | V of hola let xyz = function | YA,_,_ -> 1 | _,YA,_ -> 2 | YB,YB,_ -> 3 | ((YB|YC), (YB|YC), (X|Y|Z|V _|T _)) -> 6 | _,_,(X|U _) -> 8 | _,_,Y -> 5 ;; (* File "morematch.ml", line 459, characters 7-8: Warning U: this sub-pattern is unused. File "morematch.ml", line 460, characters 2-7: Warning U: this match case is unused. *) test "xyz" xyz (YC,YC,X) 6 ; test "xyz" xyz (YC,YB,U X) 8 ; test "xyz" xyz (YB,YC,X) 6 ; () ;; (* Ce test est pour le compilo lui-meme *) let eq (x,y) = x=y ;; test "eq" eq ("coucou", "coucou") true ; () ;; (* Test des gardes, non trivial *) let is_none = function | None -> true | _ -> false let garde x = match x with | (Some _, _) when is_none (snd x) -> 1 | (Some (pc, _), Some pc') when pc = pc' -> 2 | _ -> 3 ;; test "garde" garde (Some (1,1),None) 1 ; test "garde" garde (Some (1,1),Some 1) 2 ; test "garde" garde (Some (2,1),Some 1) 3 ; () ;; let orstring = function | ("A"|"B"|"C") -> 2 | "D" -> 3 | _ -> 4 ;; test "orstring" orstring "A" 2 ; test "orstring" orstring "B" 2 ; test "orstring" orstring "C" 2 ; test "orstring" orstring "D" 3 ; test "orstring" orstring "E" 4 ; () ;; type var_t = [`Variant of [ `Some of string | `None | `Foo] ] let crash (pat:var_t) = match pat with | `Variant (`Some tag) -> tag | `Variant (`None) -> "none" | _ -> "foo" ;; test "crash" crash (`Variant `None) "none" ; test "crash" crash (`Variant (`Some "coucou")) "coucou" ; test "crash" crash (`Variant (`Foo)) "foo" ; () ;; let flatgarde c = let x,y = c in match x,y with | (1,2)|(2,3) when y=2 -> 1 | (1,_)|(_,3) -> 2 | _ -> 3 ;; test "flatgarde" flatgarde (1,2) 1 ; test "flatgarde" flatgarde (1,3) 2 ; test "flatgarde" flatgarde (2,3) 2 ; test "flatgarde" flatgarde (2,4) 3 ; () ;; (* Les bugs de jerome *) type f = | ABSENT | FILE | SYMLINK | DIRECTORY type r = | Unchanged | Deleted | Modified | PropsChanged | Created let replicaContent2shortString rc = let (typ, status) = rc in match typ, status with _, Unchanged -> " " | ABSENT, Deleted -> "deleted " | FILE, Created -> "new file" | FILE, Modified -> "changed " | FILE, PropsChanged -> "props " | SYMLINK, Created -> "new link" | SYMLINK, Modified -> "chgd lnk" | DIRECTORY, Created -> "new dir " | DIRECTORY, Modified -> "chgd dir" | DIRECTORY, PropsChanged -> "props " (* Cases that can't happen... *) | ABSENT, (Created | Modified | PropsChanged) | SYMLINK, PropsChanged | (FILE|SYMLINK|DIRECTORY), Deleted -> "assert false" ;; test "jerome_constr" replicaContent2shortString (ABSENT, Unchanged) " " ; test "jerome_constr" replicaContent2shortString (ABSENT, Deleted) "deleted " ; test "jerome_constr" replicaContent2shortString (FILE, Modified) "changed " ; test "jerome_constr" replicaContent2shortString (DIRECTORY, PropsChanged) "props " ; test "jerome_constr" replicaContent2shortString (FILE, Deleted) "assert false" ; test "jerome_constr" replicaContent2shortString (SYMLINK, Deleted) "assert false" ; test "jerome_constr" replicaContent2shortString (SYMLINK, PropsChanged) "assert false" ; test "jerome_constr" replicaContent2shortString (DIRECTORY, Deleted) "assert false" ; test "jerome_constr" replicaContent2shortString (ABSENT, Created) "assert false" ; test "jerome_constr" replicaContent2shortString (ABSENT, Modified) "assert false" ; test "jerome_constr" replicaContent2shortString (ABSENT, PropsChanged) "assert false" ; ;; let replicaContent2shortString rc = let (typ, status) = rc in match typ, status with _, `Unchanged -> " " | `ABSENT, `Deleted -> "deleted " | `FILE, `Created -> "new file" | `FILE, `Modified -> "changed " | `FILE, `PropsChanged -> "props " | `SYMLINK, `Created -> "new link" | `SYMLINK, `Modified -> "chgd lnk" | `DIRECTORY, `Created -> "new dir " | `DIRECTORY, `Modified -> "chgd dir" | `DIRECTORY, `PropsChanged -> "props " (* Cases that can't happen... *) | `ABSENT, (`Created | `Modified | `PropsChanged) | `SYMLINK, `PropsChanged | (`FILE|`SYMLINK|`DIRECTORY), `Deleted -> "assert false" ;; test "jerome_variant" replicaContent2shortString (`ABSENT, `Unchanged) " " ; test "jerome_variant" replicaContent2shortString (`ABSENT, `Deleted) "deleted " ; test "jerome_variant" replicaContent2shortString (`FILE, `Modified) "changed " ; test "jerome_variant" replicaContent2shortString (`DIRECTORY, `PropsChanged) "props " ; test "jerome_variant" replicaContent2shortString (`FILE, `Deleted) "assert false" ; test "jerome_variant" replicaContent2shortString (`SYMLINK, `Deleted) "assert false" ; test "jerome_variant" replicaContent2shortString (`SYMLINK, `PropsChanged) "assert false" ; test "jerome_variant" replicaContent2shortString (`DIRECTORY, `Deleted) "assert false" ; test "jerome_variant" replicaContent2shortString (`ABSENT, `Created) "assert false" ; test "jerome_variant" replicaContent2shortString (`ABSENT, `Modified) "assert false" ; test "jerome_variant" replicaContent2shortString (`ABSENT, `PropsChanged) "assert false" ; ;; (* bug 319 *) type ab = A of int | B of int type cd = C | D let ohl = function | (A (p) | B (p)), C -> p | (A (p) | B (p)), D -> p ;; test "ohl" ohl (A 0,C) 0 ; test "ohl" ohl (B 0,D) 0 ; () ;; (* bug 324 *) type pottier = | A | B ;; let pottier x = match x with | (( (A, 1) | (B, 2)),A) -> false | _ -> true ;; test "pottier" pottier ((B,2),A) false ; test "pottier" pottier ((B,2),B) true ; test "pottier" pottier ((A,2),A) true ; () ;; (* bug 325 in bytecode compiler *) let coquery q = match q with | y,0,([modu;defs]| [defs;modu;_]) -> y+defs-modu | _ -> 0 ;; test "coquery" coquery (1,0,[1 ; 2 ; 3]) 0 ; test "coquery" coquery (1,0,[1 ; 2]) 2 ; () ;; (* Two other variable in or-pat tests *) type vars = A of int | B of (int * int) | C ;; let vars1 = function | (A x | B (_,x)) -> x | C -> 0 ;; test "vars1" vars1 (A 1) 1 ; test "vars1" vars1 (B (1,2)) 2 ; () ;; let vars2 = function | ([x]|[1 ; x ]|[1 ; 2 ; x]) -> x | _ -> 0 ;; test"vars2" vars2 [1] 1 ; test"vars2" vars2 [1;2] 2 ; test"vars2" vars2 [1;2;3] 3 ; test"vars2" vars2 [0 ; 0] 0 ; () ;; (* Bug 342 *) type eber = {x:int; y: int; z:bool} let eber = function | {x=a; z=true} | {y=a; z=false} -> a ;; test "eber" eber {x=0 ; y=1 ; z=true} 0 ; test "eber" eber {x=1 ; y=0 ; z=false} 0 ; () ;; (* Enchainement des test d'intervalle *) let escaped = function | '"' | '\\' | '\n' | '\t' -> 2 | c -> 1 ;; test "escaped" escaped '"' 2 ; test "escaped" escaped '\\' 2 ; test "escaped" escaped '\n' 2 ; test "escaped" escaped '\t' 2 ; test "escaped" escaped '\000' 1 ; test "escaped" escaped ' ' 1 ; test "escaped" escaped '\000' 1 ; test "escaped" escaped '[' 1 ; test "escaped" escaped ']' 1 ; test "escaped" escaped '!' 1 ; test "escaped" escaped '#' 1 ; () ;; (* For compilation speed (due to J. Garigue) *) exception Unknown_Reply of int type command_reply = RPL_TRYAGAIN | RPL_TRACEEND | RPL_TRACELOG | RPL_ADMINEMAIL | RPL_ADMINLOC2 | RPL_ADMINLOC1 | RPL_ADMINME | RPL_LUSERME | RPL_LUSERCHANNELS | RPL_LUSERUNKNOWN | RPL_LUSEROP | RPL_LUSERCLIENT | RPL_STATSDLINE | RPL_STATSDEBUG | RPL_STATSDEFINE | RPL_STATSBLINE | RPL_STATSPING | RPL_STATSSLINE | RPL_STATSHLINE | RPL_STATSOLINE | RPL_STATSUPTIME | RPL_STATSLLINE | RPL_STATSVLINE | RPL_SERVLISTEND | RPL_SERVLIST | RPL_SERVICE | RPL_ENDOFSERVICES | RPL_SERVICEINFO | RPL_UMODEIS | RPL_ENDOFSTATS | RPL_STATSYLINE | RPL_STATSQLINE | RPL_STATSKLINE | RPL_STATSILINE | RPL_STATSNLINE | RPL_STATSCLINE | RPL_STATSCOMMANDS | RPL_STATSLINKINFO | RPL_TRACERECONNECT | RPL_TRACECLASS | RPL_TRACENEWTYPE | RPL_TRACESERVICE | RPL_TRACESERVER | RPL_TRACEUSER | RPL_TRACEOPERATOR | RPL_TRACEUNKNOWN | RPL_TRACEHANDSHAKE | RPL_TRACECONNECTING | RPL_TRACELINK | RPL_NOUSERS | RPL_ENDOFUSERS | RPL_USERS | RPL_USERSSTART | RPL_TIME | RPL_NOTOPERANYMORE | RPL_MYPORTIS | RPL_YOURESERVICE | RPL_REHASHING | RPL_YOUREOPER | RPL_ENDOFMOTD | RPL_MOTDSTART | RPL_ENDOFINFO | RPL_INFOSTART | RPL_MOTD | RPL_INFO | RPL_ENDOFBANLIST | RPL_BANLIST | RPL_ENDOFLINKS | RPL_LINKS | RPL_CLOSEEND | RPL_CLOSING | RPL_KILLDONE | RPL_ENDOFNAMES | RPL_NAMREPLY | RPL_ENDOFWHO | RPL_WHOREPLY | RPL_VERSION | RPL_SUMMONING | RPL_INVITING | RPL_TOPIC | RPL_NOTOPIC | RPL_CHANNELMODEIS | RPL_LISTEND | RPL_LIST | RPL_LISTSTART | RPL_WHOISCHANNELS | RPL_ENDOFWHOIS | RPL_WHOISIDLE | RPL_WHOISCHANOP | RPL_ENDOFWHOWAS | RPL_WHOWASUSER | RPL_WHOISOPERATOR | RPL_WHOISSERVER | RPL_WHOISUSER | RPL_NOWAWAY | RPL_UNAWAY | RPL_TEXT | RPL_ISON | RPL_USERHOST | RPL_AWAY | RPL_NONE let get_command_reply n = match n with 263 -> RPL_TRYAGAIN | 319 -> RPL_WHOISCHANNELS | 318 -> RPL_ENDOFWHOIS | 317 -> RPL_WHOISIDLE | 316 -> RPL_WHOISCHANOP | 369 -> RPL_ENDOFWHOWAS | 314 -> RPL_WHOWASUSER | 313 -> RPL_WHOISOPERATOR | 312 -> RPL_WHOISSERVER | 311 -> RPL_WHOISUSER | 262 -> RPL_TRACEEND | 261 -> RPL_TRACELOG | 259 -> RPL_ADMINEMAIL | 258 -> RPL_ADMINLOC2 | 257 -> RPL_ADMINLOC1 | 256 -> RPL_ADMINME | 255 -> RPL_LUSERME | 254 -> RPL_LUSERCHANNELS | 253 -> RPL_LUSERUNKNOWN | 252 -> RPL_LUSEROP | 251 -> RPL_LUSERCLIENT | 250 -> RPL_STATSDLINE | 249 -> RPL_STATSDEBUG | 248 -> RPL_STATSDEFINE | 247 -> RPL_STATSBLINE | 246 -> RPL_STATSPING | 245 -> RPL_STATSSLINE | 244 -> RPL_STATSHLINE | 243 -> RPL_STATSOLINE | 242 -> RPL_STATSUPTIME | 241 -> RPL_STATSLLINE | 240 -> RPL_STATSVLINE | 235 -> RPL_SERVLISTEND | 234 -> RPL_SERVLIST | 233 -> RPL_SERVICE | 232 -> RPL_ENDOFSERVICES | 231 -> RPL_SERVICEINFO | 221 -> RPL_UMODEIS | 219 -> RPL_ENDOFSTATS | 218 -> RPL_STATSYLINE | 217 -> RPL_STATSQLINE | 216 -> RPL_STATSKLINE | 215 -> RPL_STATSILINE | 214 -> RPL_STATSNLINE | 213 -> RPL_STATSCLINE | 212 -> RPL_STATSCOMMANDS | 211 -> RPL_STATSLINKINFO | 210 -> RPL_TRACERECONNECT | 209 -> RPL_TRACECLASS | 208 -> RPL_TRACENEWTYPE | 207 -> RPL_TRACESERVICE | 206 -> RPL_TRACESERVER | 205 -> RPL_TRACEUSER | 204 -> RPL_TRACEOPERATOR | 203 -> RPL_TRACEUNKNOWN | 202 -> RPL_TRACEHANDSHAKE | 201 -> RPL_TRACECONNECTING | 200 -> RPL_TRACELINK | 395 -> RPL_NOUSERS | 394 -> RPL_ENDOFUSERS | 393 -> RPL_USERS | 392 -> RPL_USERSSTART | 391 -> RPL_TIME | 385 -> RPL_NOTOPERANYMORE | 384 -> RPL_MYPORTIS | 383 -> RPL_YOURESERVICE | 382 -> RPL_REHASHING | 381 -> RPL_YOUREOPER | 376 -> RPL_ENDOFMOTD | 375 -> RPL_MOTDSTART | 374 -> RPL_ENDOFINFO | 373 -> RPL_INFOSTART | 372 -> RPL_MOTD | 371 -> RPL_INFO | 368 -> RPL_ENDOFBANLIST | 367 -> RPL_BANLIST | 365 -> RPL_ENDOFLINKS | 364 -> RPL_LINKS | 363 -> RPL_CLOSEEND | 362 -> RPL_CLOSING | 361 -> RPL_KILLDONE | 366 -> RPL_ENDOFNAMES | 353 -> RPL_NAMREPLY | 315 -> RPL_ENDOFWHO | 352 -> RPL_WHOREPLY | 351 -> RPL_VERSION | 342 -> RPL_SUMMONING | 341 -> RPL_INVITING | 332 -> RPL_TOPIC | 331 -> RPL_NOTOPIC | 324 -> RPL_CHANNELMODEIS | 323 -> RPL_LISTEND | 322 -> RPL_LIST | 321 -> RPL_LISTSTART | 306 -> RPL_NOWAWAY | 305 -> RPL_UNAWAY | 304 -> RPL_TEXT | 303 -> RPL_ISON | 302 -> RPL_USERHOST | 301 -> RPL_AWAY | 300 -> RPL_NONE | _ -> raise (Unknown_Reply n) (* Bug 454 *) type habert_a= | A of habert_c | B of habert_c and habert_c= {lvar:int; lassoc: habert_c;lnb:int} let habert=function | (A {lnb=i}|B {lnb=i}) when i=0 -> 1 | A {lassoc=({lnb=j});lnb=i} -> 2 | _ -> 3 ;; let rec ex0 = {lvar=0 ; lnb=0 ; lassoc=ex1} and ex1 = {lvar=1 ; lnb=1 ; lassoc=ex0} in test "habert" habert (A ex0) 1 ; test "habert" habert (B ex0) 1 ; test "habert" habert (A ex1) 2 ; test "habert" habert (B ex1) 3 ; (* Problems with interval test in arithmetic mod 2^31, bug #359 *) (* From manuel Fahndrich *) type type_expr = [ | `TTuple of type_expr list | `TConstr of type_expr list | `TVar of string | `TVariant of string list | `TBlock of int | `TCopy of type_expr ] and recurs_type_expr = [ | `TTuple of type_expr list | `TConstr of type_expr list | `TVariant of string list ] let rec maf te = match te with | `TCopy te -> 1 | `TVar _ -> 2 | `TBlock _ -> 2 | #recurs_type_expr as desc -> let te = (match desc with `TTuple tl -> 4 | `TConstr tl -> 5 | `TVariant (row) -> 6 ) in te ;; let base = `TBlock 0 ;; test "maf" maf (`TCopy base) 1 ; test "maf" maf (`TVar "test") 2 ; test "maf" maf (`TBlock 0) 2 ; test "maf" maf (`TTuple []) 4 ; test "maf" maf (`TConstr []) 5 ; test "maf" maf (`TVariant []) 6 ;; (* PR#1310 Using ``get_args'' in place or an ad-hoc ``matcher'' function for tuples. Has made the compiler [3.05] to fail. *) type t_seb = Uin | Uout ;; let rec seb = function | ((i, Uin) | (i, Uout)), Uout -> 1 | ((j, Uin) | (j, Uout)), Uin -> 2 ;; test "seb" seb ((0,Uin),Uout) 1 ; test "seb" seb ((0,Uout),Uin) 2 ; () ;; (* Talk with Jacques - type 'b is still open ?? - better case generation, accept intervals of size 1 when ok_inter is false (in Switch) *) (* File "morematch.ml", line 1060, characters 8-65: Warning: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: A `D *) type ('a, 'b) t_j = A of 'a | B of 'b * 'a | C let f = function | A (`A|`C) -> 0 | B (`B,`D) -> 1 | C -> 2 let g x = try f x with Match_failure _ -> 3 let _ = test "jacques" g (A `A) 0 ; test "jacques" g (A `C) 0 ; test "jacques" g (B (`B,`D)) 1 ; test "jacaues" g C 2 ; (* test "jacques" g (B (`A,`D)) 3 ; (* type incorrect expected behavior ? *)*) () (* Compilation bug, segfault, because of incorrect compilation of unused match case .. -> "11" *) type t_l = A | B let f = function | _, _, _, _, _, _, _, _, _, _, _, _, _, B, _, _ -> "0" | _, _, _, B, A, _, _, _, _, _, _, _, _, _, _, _ -> "1" | _, _, _, B, _, A, _, _, A, _, _, _, _, _, _, _ -> "2" | _, _, _, _, _, _, _, _, _, _, B, A, _, A, _, _ -> "3" | _, _, _, _, _, _, _, B, _, _, _, _, B, _, A, A -> "4" | A, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "5" | _, _, _, _, _, _, _, B, _, B, _, _, _, _, _, _ -> "6" | _, B, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "7" | _, A, A, _, A, _, B, _, _, _, _, _, _, _, _, B -> "8" | _, _, _, _, B, _, _, _, _, _, _, _, _, _, B, _ -> "9" | _, _, _, _, _, _, _, _, _, _, _, B, _, _, _, _ -> "10" | _, _, _, _, _, A, _, _, _, _, B, _, _, _, _, _ -> "11" | B, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "12" | _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "13" (* File "morematch.ml", line 1094, characters 5-51: Warning: this match case is unused. File "morematch.ml", line 1096, characters 5-51: Warning: this match case is unused. *) let _ = test "luc" f (B, A, A, A, A, A, A, A, A, A, A, B, A, A, A, A) "10" ; test "luc" f (B, A, A, A, A, A, A, A, A, A, A, A, A, A, A, A) "12" ; () (* By Gilles Peskine, compilation raised some assert false i make_failactionneg *) type bg = [ | `False | `True ] type vg = [ | `A | `B | `U of int | `V of int ] type tg = { v : vg; x : bg; } let predg x = true let rec gilles o = match o with | {v = (`U data | `V data); x = `False} when predg o -> 1 | {v = (`A|`B) ; x = `False} | {v = (`U _ | `V _); x = `False} | {v = _ ; x = `True} -> 2 (* Match in trywith should always have a default case *) exception Found of string * int exception Error of string let lucexn e = try try raise e with Error msg -> msg with Found (s,r) -> s^string_of_int r let () = test "lucexn1" lucexn (Error "coucou") "coucou" ; test "lucexn2" lucexn (Found ("int: ",0)) "int: 0" ; () (* PR#5758: different representations of floats *) let pr5758 x str = match (x, str) with | (1. , "A") -> "Matched A" | (1.0, "B") -> "Matched B" | (1. , "C") -> "Matched C" | result -> match result with | (1., "A") -> "Failed match A then later matched" | _ -> "Failed twice" ;; let () = test "pr5758" (pr5758 1.) "A" "Matched A" ;; mingw-ocaml/ocaml/testsuite/tests/basic-more/tformat.reference0000644000175000017500000000003012124403241024217 0ustar tootstoots 0 All tests succeeded. mingw-ocaml/ocaml/testsuite/tests/basic-more/bounds.reference0000644000175000017500000000016612124403241024047 0ustar tootstoots0: doesn't fail 1: doesn't fail 2: doesn't fail 3: fails 4: fails -1: fails Trail: -1 4 3 2 1 0 All tests succeeded. mingw-ocaml/ocaml/testsuite/tests/basic-more/tprintf.reference0000644000175000017500000000004212124403241024234 0ustar tootstoots 0 1 2 3 4 5 All tests succeeded. mingw-ocaml/ocaml/testsuite/tests/basic-more/bounds.ml0000644000175000017500000000125112124403241022515 0ustar tootstoots(* Test bound checks with ocamlopt *) let a = [| 0; 1; 2 |] let trail = ref [] let test n = let result = try trail := n :: !trail; ignore a.(n); "doesn't fail" with Invalid_argument s -> (* Check well-formedness of s *) if String.length s = 19 && s = "index out of bounds" then "fails" else "bad Invalid_argument" | _ -> "bad exception" in print_int n; print_string ": "; print_string result; print_newline() let _ = test 0; test 1; test 2; test 3; test 4; test (-1); Gc.full_major(); print_string "Trail:"; List.iter (fun n -> print_string " "; print_int n) !trail; print_newline() mingw-ocaml/ocaml/testsuite/tests/basic-more/tprintf.ml0000644000175000017500000000367412124403241022724 0ustar tootstootsopen Testing;; open Printf;; (* Padding floating point numbers. Testing * width specifications. *) let test0 () = sprintf "%.0f" 1.0 = "1" && sprintf "%.0f." 1.7 = "2." && sprintf "%.1f." 1.0 = "1.0." && sprintf "%0.1f." 12.0 = "12.0." && sprintf "%3.1f." 12.0 = "12.0." && sprintf "%5.1f." 12.0 = " 12.0." && sprintf "%10.1f." 12.0 = " 12.0." && sprintf "%010.1f." 12.0 = "00000012.0." && sprintf "% 10.1f." 12.0 = " 12.0." && sprintf "%+10.1f." 12.0 = " +12.0." && sprintf "%+10.1f." (-12.0) = " -12.0." && sprintf "%010.5f." 12.0 = "0012.00000." && sprintf "%010.0f." 12.0 = "0000000012." && sprintf "% 10.0f." 12.0 = " 12." && sprintf "%0.1f." 12.0 = "12.0." && sprintf "%10.1f." 1.001 = " 1.0." && sprintf "%05.1f." 1.001 = "001.0." ;; test (test0 ());; (* Padding integers (cf bug 3955). Testing * width specifications. *) let test1 () = sprintf "%d\n" 1 = "1\n" && sprintf "%05d\n" 1 = "00001\n" && sprintf "%*d\n" 5 1 = " 1\n" && sprintf "%0*d\n" 5 1 = "00001\n";; test (test1 ());; (* FIXME: when positional specification will be OK. *) let test2 () = true (* sprintf "%1$d\n" 5 1 = " 1\n" && sprintf "%01$d\n" 5 1 = "00001\n" *);; test (test2 ());; (* Testing meta format string printing. *) let test3 () = sprintf "%{toto %s titi.\n%}" "Bonjour %s." = "%s" && sprintf "%{%d%s%}" "kk%dkk%s\n" = "%i%s";; test (test3 ());; (* Testing meta format string arguments. *) let test4 () = sprintf "%(%s%)" "Bonjour %s" "toto" = "Bonjour toto" && sprintf "%(%s%)" "Bonjour %s." "vous" = "Bonjour vous." && sprintf "%(%s%)" "Hello %s." "you" = "Hello you." ;; test (test4 ());; let test5 () = sprintf "%(toto %s titi.\n%)" "Bonjour %s." "vous" = "Bonjour vous." && sprintf "%(toto %s titi.\n%).\n" "Bonjour %s" "toto" = "Bonjour toto.\n" && sprintf "%(toto %s titi.\n%)%s\n" "Bonjour %s." "toto" " a va?" = "Bonjour toto. a va?\n" ;; test (test5 ());; mingw-ocaml/ocaml/testsuite/tests/basic-more/tbuffer.ml0000644000175000017500000000077212124403241022667 0ustar tootstoots(* Dummy substitute function. *) open Testing;; open Buffer;; let identity s = s;; let b = Buffer.create 100;; (* Pattern with a '\\' character in it. *) let pat0 = "\\\\a" in let n0 = String.length pat0 in Buffer.add_substitute b identity pat0; test (String.length (Buffer.contents b) = n0) ;; (* Pattern with a '\\' character at the end. *) let pat1 = "b\\" in let n1 = String.length pat1 in Buffer.clear b; Buffer.add_substitute b identity pat1; test (String.length (Buffer.contents b) = n1) ;; mingw-ocaml/ocaml/testsuite/tests/basic-more/tformat.ml0000644000175000017500000000211612124403241022700 0ustar tootstoots(*************************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis, projet Estime, INRIA Rocquencourt *) (* *) (* Copyright 2009 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (*************************************************************************) (* $Id$ A testbed file for the module Format. *) open Testing;; open Format;; (* BR#4769 *) let test0 () = let b = Buffer.create 10 in let msg = "Hello world!" in Format.bprintf b "%s" msg; let s = Buffer.contents b in s = msg ;; test (test0 ()) ;; mingw-ocaml/ocaml/testsuite/tests/basic-more/testrandom.reference0000644000175000017500000000061612124403241024735 0ustar tootstoots 344 685 182 641 439 500 104 20 921 370 217 885 949 678 615 412 401 606 428 869 289 122.128067547 461.324792129 360.006556146 768.75882284 396.500946942 190.217751234 567.660068681 403.59226778 59.8488223602 363.816246826 764.705761642 172.627051105 481.861849093 399.173195422 629.424106752 391.547032203 676.701133948 174.382120878 994.425675487 585.00027757 34.3270777955 All tests succeeded. mingw-ocaml/ocaml/testsuite/tests/basic-more/tbuffer.reference0000644000175000017500000000003212124403241024202 0ustar tootstoots 0 1 All tests succeeded. mingw-ocaml/ocaml/testsuite/tests/basic-more/morematch.reference0000644000175000017500000000002612124403241024527 0ustar tootstoots All tests succeeded. mingw-ocaml/ocaml/testsuite/tests/basic-more/testrandom.ml0000644000175000017500000000033612124403241023406 0ustar tootstootsopen Random let _ = for i = 0 to 20 do print_char ' '; print_int (int 1000); done; print_newline (); print_newline (); for i = 0 to 20 do print_char ' '; print_float (float 1000.); done let _ = exit 0 mingw-ocaml/ocaml/testsuite/tests/typing-polyvariants-bugs/0000755000175000017500000000000012124403241023652 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-polyvariants-bugs/Makefile0000644000175000017500000000014712124403241025314 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.okbad include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml0000644000175000017500000000044512124403241025642 0ustar tootstoots(* PR5057 *) module TT = struct module IntSet = Set.Make(struct type t = int let compare = compare end) end let () = let f flag = let module T = TT in let _ = match flag with `A -> 0 | `B r -> r in let _ = match flag with `A -> T.IntSet.mem | `B r -> r in () in f `A mingw-ocaml/ocaml/testsuite/tests/typing-polyvariants-bugs/privrowsabate_ok.ml0000644000175000017500000000246712124403241027576 0ustar tootstootstype 'a termpc = [`And of 'a * 'a |`Or of 'a * 'a |`Not of 'a |`Atom of string ] type 'a termk = [`Dia of 'a |`Box of 'a |'a termpc ] module type T = sig type term val map : (term -> term) -> term -> term val nnf : term -> term val nnf_not : term -> term end module Fpc(X : T with type term = private [> 'a termpc] as 'a) = struct type term = X.term termpc let nnf = function |`Not(`Atom _) as x -> x |`Not x -> X.nnf_not x | x -> X.map X.nnf x let map f : term -> X.term = function |`Not x -> `Not (f x) |`And(x,y) -> `And (f x, f y) |`Or (x,y) -> `Or (f x, f y) |`Atom _ as x -> x let nnf_not : term -> _ = function |`Not x -> X.nnf x |`And(x,y) -> `Or (X.nnf_not x, X.nnf_not y) |`Or (x,y) -> `And (X.nnf_not x, X.nnf_not y) |`Atom _ as x -> `Not x end module Fk(X : T with type term = private [> 'a termk] as 'a) = struct type term = X.term termk module Pc = Fpc(X) let map f : term -> _ = function |`Dia x -> `Dia (f x) |`Box x -> `Box (f x) |#termpc as x -> Pc.map f x let nnf = Pc.nnf let nnf_not : term -> _ = function |`Dia x -> `Box (X.nnf_not x) |`Box x -> `Dia (X.nnf_not x) |#termpc as x -> Pc.nnf_not x end mingw-ocaml/ocaml/testsuite/tests/typing-polyvariants-bugs/pr4775_ok.ml0000644000175000017500000000044012124403241025643 0ustar tootstootsmodule type Poly = sig type 'a t = 'a constraint 'a = [> ] end module Combine (A : Poly) (B : Poly) = struct type ('a, 'b) t = 'a A.t constraint 'a = 'b B.t end module C = Combine (struct type 'a t = 'a constraint 'a = [> ] end) (struct type 'a t = 'a constraint 'a = [> ] end) mingw-ocaml/ocaml/testsuite/tests/typing-polyvariants-bugs/pr4933_ok.ml0000644000175000017500000000044212124403241025641 0ustar tootstootsmodule type Priv = sig type t = private int end module Make (Unit:sig end): Priv = struct type t = int end module A = Make (struct end) module type Priv' = sig type t = private [> `A] end module Make' (Unit:sig end): Priv' = struct type t = [`A] end module A' = Make' (struct end) mingw-ocaml/ocaml/testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml0000644000175000017500000000034012124403241026112 0ustar tootstoots(* This one should fail *) let f flag = let module T = Set.Make(struct type t = int let compare = compare end) in let _ = match flag with `A -> 0 | `B r -> r in let _ = match flag with `A -> T.mem | `B r -> r in () mingw-ocaml/ocaml/testsuite/tests/typing-modules-bugs/0000755000175000017500000000000012124403241022567 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-modules-bugs/Makefile0000644000175000017500000000011712124403241024226 0ustar tootstootsinclude ../../makefiles/Makefile.okbad include ../../makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-modules-bugs/pr5343_bad.ml0000644000175000017500000000034112124403241024665 0ustar tootstootsmodule M : sig type 'a t type u = u t and v = v t val f : int -> u val g : v -> bool end = struct type 'a t = 'a type u = int and v = bool let f x = x let g x = x end;; let h (x : int) : bool = M.g (M.f x);; mingw-ocaml/ocaml/testsuite/tests/typing-modules-bugs/pr5164_ok.ml0000644000175000017500000000026612124403241024557 0ustar tootstootsmodule type INCLUDING = sig include module type of List include module type of ListLabels end module Including_typed: INCLUDING = struct include List include ListLabels end mingw-ocaml/ocaml/testsuite/tests/lib-str/0000755000175000017500000000000012124403241020225 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-str/Makefile0000644000175000017500000000017012124403241021663 0ustar tootstootsBASEDIR=../.. LIBRARIES=str include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-str/t01.ml0000644000175000017500000007117512124403241021176 0ustar tootstootsopen Printf let build_result ngroups input = let res = Array.make (ngroups + 1) "~" in for i = 0 to ngroups do try res.(i) <- Str.matched_group i input with Not_found -> () done; res let search_forward re ng input start = try ignore(Str.search_forward re input start); build_result ng input with Not_found -> [||] let search_backward re ng input start = try ignore(Str.search_backward re input start); build_result ng input with Not_found -> [||] let partial_match re ng input start = if Str.string_partial_match re input start then build_result ng input else [||] let start_test msg = print_newline(); printf "%s\n " msg let num_failures = ref 0 let test res1 res2 = if res1 = res2 then print_char '.' else begin print_string " FAIL "; incr num_failures end let test_search_forward r ng s exp = test (search_forward r ng s 0) exp let test_search_backward r ng s exp = test (search_backward r ng s (String.length s)) exp let test_partial_match r ng s exp = test (partial_match r ng s 0) exp let end_test () = print_newline(); if !num_failures = 0 then printf "All tests passed\n" else begin printf "TEST FAILED: %d failure(s)\n" !num_failures; exit 2 end let automated_test() = (** Forward searches *) start_test "Search for /the quick brown fox/"; let r = Str.regexp "the quick brown fox" in let n = 0 in test_search_forward r n "the quick brown fox" [|"the quick brown fox"|]; test_search_forward r n "What do you know about the quick brown fox?" [|"the quick brown fox"|]; test_search_forward r n "The quick brown FOX" [||]; test_search_forward r n "What do you know about THE QUICK BROWN FOX?" [||]; start_test "Search for /the quick brown fox/ (case-insensitive)"; let r = Str.regexp_case_fold "the quick brown fox" in let n = 0 in test_search_forward r n "the quick brown fox" [|"the quick brown fox"|]; test_search_forward r n "What do you know about the quick brown fox?" [|"the quick brown fox"|]; test_search_forward r n "The quick brown FOX" [|"The quick brown FOX"|]; test_search_forward r n "What do you know about THE QUICK BROWN FOX?" [|"THE QUICK BROWN FOX"|]; test_search_forward r n "The slow white snail" [||]; start_test "Search for /a*abc?xyz+pqrrrabbb*xyyyyy?pq?q?q?q?q?q?AB*zz/"; let r = Str.regexp "a*abc?xyz+pqrrrabbb*xyyyyy?pq?q?q?q?q?q?AB*zz" in let n = 0 in test_search_forward r n "abxyzpqrrrabbxyyyypqAzz" [|"abxyzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "abxyzpqrrrabbxyyyypqAzz" [|"abxyzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "aabxyzpqrrrabbxyyyypqAzz" [|"aabxyzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "aaabxyzpqrrrabbxyyyypqAzz" [|"aaabxyzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "aaaabxyzpqrrrabbxyyyypqAzz" [|"aaaabxyzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "abcxyzpqrrrabbxyyyypqAzz" [|"abcxyzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "aabcxyzpqrrrabbxyyyypqAzz" [|"aabcxyzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "aaabcxyzpqrrrabbxyyyypAzz" [|"aaabcxyzpqrrrabbxyyyypAzz"|]; test_search_forward r n "aaabcxyzpqrrrabbxyyyypqAzz" [|"aaabcxyzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqAzz" [|"aaabcxyzpqrrrabbxyyyypqqAzz"|]; test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqqAzz" [|"aaabcxyzpqrrrabbxyyyypqqqAzz"|]; test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqqqAzz" [|"aaabcxyzpqrrrabbxyyyypqqqqAzz"|]; test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqqqqAzz" [|"aaabcxyzpqrrrabbxyyyypqqqqqAzz"|]; test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqqqqqAzz" [|"aaabcxyzpqrrrabbxyyyypqqqqqqAzz"|]; test_search_forward r n "aaaabcxyzpqrrrabbxyyyypqAzz" [|"aaaabcxyzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "abxyzzpqrrrabbxyyyypqAzz" [|"abxyzzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "aabxyzzzpqrrrabbxyyyypqAzz" [|"aabxyzzzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "aaabxyzzzzpqrrrabbxyyyypqAzz" [|"aaabxyzzzzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "aaaabxyzzzzpqrrrabbxyyyypqAzz" [|"aaaabxyzzzzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "abcxyzzpqrrrabbxyyyypqAzz" [|"abcxyzzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "aabcxyzzzpqrrrabbxyyyypqAzz" [|"aabcxyzzzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "aaabcxyzzzzpqrrrabbxyyyypqAzz" [|"aaabcxyzzzzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "aaaabcxyzzzzpqrrrabbxyyyypqAzz" [|"aaaabcxyzzzzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "aaaabcxyzzzzpqrrrabbbxyyyypqAzz" [|"aaaabcxyzzzzpqrrrabbbxyyyypqAzz"|]; test_search_forward r n "aaaabcxyzzzzpqrrrabbbxyyyyypqAzz" [|"aaaabcxyzzzzpqrrrabbbxyyyyypqAzz"|]; test_search_forward r n "aaabcxyzpqrrrabbxyyyypABzz" [|"aaabcxyzpqrrrabbxyyyypABzz"|]; test_search_forward r n "aaabcxyzpqrrrabbxyyyypABBzz" [|"aaabcxyzpqrrrabbxyyyypABBzz"|]; test_search_forward r n ">>>aaabxyzpqrrrabbxyyyypqAzz" [|"aaabxyzpqrrrabbxyyyypqAzz"|]; test_search_forward r n ">aaaabxyzpqrrrabbxyyyypqAzz" [|"aaaabxyzpqrrrabbxyyyypqAzz"|]; test_search_forward r n ">>>>abcxyzpqrrrabbxyyyypqAzz" [|"abcxyzpqrrrabbxyyyypqAzz"|]; test_search_forward r n "abxyzpqrrabbxyyyypqAzz" [||]; test_search_forward r n "abxyzpqrrrrabbxyyyypqAzz" [||]; test_search_forward r n "abxyzpqrrrabxyyyypqAzz" [||]; test_search_forward r n "aaaabcxyzzzzpqrrrabbbxyyyyyypqAzz" [||]; test_search_forward r n "aaaabcxyzzzzpqrrrabbbxyyypqAzz" [||]; test_search_forward r n "aaabcxyzpqrrrabbxyyyypqqqqqqqAzz" [||]; start_test "Search for /^abc\\(abc\\)?zz/"; let r = Str.regexp "^abc\\(abc\\)?zz" in let n = 1 in test_search_forward r n "abczz" [|"abczz"; "~"|]; test_search_forward r n "abcabczz" [|"abcabczz"; "abc"|]; test_search_forward r n "zz" [||]; test_search_forward r n "abcabcabczz" [||]; test_search_forward r n ">>abczz" [||]; start_test "Search for /^\\(b+\\|a\\)\\(b+\\|a\\)?c/"; let r = Str.regexp "^\\(b+\\|a\\)\\(b+\\|a\\)?c" in let n = 2 in test_search_forward r n "bc" [|"bc"; "b"; "~"|]; test_search_forward r n "bbc" [|"bbc"; "bb"; "~"|]; test_search_forward r n "bbbc" [|"bbbc"; "bbb"; "~"|]; test_search_forward r n "bac" [|"bac"; "b"; "a"|]; test_search_forward r n "bbac" [|"bbac"; "bb"; "a"|]; test_search_forward r n "aac" [|"aac"; "a"; "a"|]; test_search_forward r n "abbbbbbbbbbbc" [|"abbbbbbbbbbbc"; "a"; "bbbbbbbbbbb"|]; test_search_forward r n "bbbbbbbbbbbac" [|"bbbbbbbbbbbac"; "bbbbbbbbbbb"; "a"|]; test_search_forward r n "aaac" [||]; test_search_forward r n "abbbbbbbbbbbac" [||]; start_test "Search for /r\\(\\(g*\\|k\\)y?\\)*A/"; let r = Str.regexp "r\\(\\(g*\\|k\\)y?\\)*A" in let n = 2 in test_search_forward r n "ArA" [|"rA"; "~"; "~"|]; test_search_forward r n "ArkA" [|"rkA"; "k"; "k"|]; test_search_forward r n "AryA" [|"ryA"; "y"; ""|]; test_search_forward r n "ArgggkyggkA" [|"rgggkyggkA"; "k"; "k"|]; start_test "Search for /A\\(\\(t\\|v\\)\\(q?\\|n\\)\\)*A/"; let r = Str.regexp "A\\(\\(t\\|v\\)\\(q?\\|n\\)\\)*A" in let n = 3 in test_search_forward r n "AvA" [|"AvA"; "v"; "v"; ""|]; start_test "Search for /A\\(\\(b\\(\\(d\\|l*\\)?\\|w\\)\\)*a\\)A/"; let r = Str.regexp "A\\(\\(b\\(\\(d\\|l*\\)?\\|w\\)\\)*a\\)A" in let n = 4 in test_search_forward r n "AbbaA" [|"AbbaA"; "bba"; "b"; ""; ""|]; start_test "Search for /\\(\\|f\\)*x/"; let r = Str.regexp "\\(\\|f\\)*x" in let n = 1 in test_search_forward r n "abcd" [||]; test_search_forward r n "fffff" [||]; test_search_forward r n "fffxab" [|"fffx"; "f"|]; test_search_forward r n "zzzxab" [|"x"; "~"|]; start_test "Search for /\\(\\|f\\)+x/"; let r = Str.regexp "\\(\\|f\\)+x" in let n = 1 in test_search_forward r n "abcd" [||]; test_search_forward r n "fffff" [||]; test_search_forward r n "fffxab" [|"fffx"; "f"|]; test_search_forward r n "zzzxab" [|"x"; ""|]; start_test "Search for /A\\(.?\\)*A/"; let r = Str.regexp "A\\(.?\\)*A" in let n = 1 in test_search_forward r n "AA" [|"AA"; "~"|]; test_search_forward r n "AAA" [|"AAA"; "A"|]; test_search_forward r n "AbA" [|"AbA"; "b"|]; test_search_forward r n "A" [||]; start_test "Search for /\\([ab]*\\)\\1+c/"; let r = Str.regexp "\\([ab]*\\)\\1+c" in let n = 1 in test_search_forward r n "abababc" [| "abababc"; "ab" |]; test_search_forward r n "abbc" [| "bbc"; "b" |]; test_search_forward r n "abc" [| "c"; "" |]; start_test "Search for /^\\(\\(b+\\|a\\)\\(b+\\|a\\)?\\)?bc/"; let r = Str.regexp "^\\(\\(b+\\|a\\)\\(b+\\|a\\)?\\)?bc" in let n = 3 in test_search_forward r n "bbc" [|"bbc"; "b"; "b"; "~"|]; start_test "Search for /^\\(\\(b*\\|ba\\)\\(b*\\|ba\\)?\\)?bc/"; let r = Str.regexp "^\\(\\(b*\\|ba\\)\\(b*\\|ba\\)?\\)?bc" in let n = 3 in test_search_forward r n "babc" [|"babc"; "ba"; ""; "ba"|]; test_search_forward r n "bbabc" [|"bbabc"; "bba"; "b"; "ba"|]; test_search_forward r n "bababc" [|"bababc"; "baba"; "ba"; "ba"|]; test_search_forward r n "bababbc" [||]; test_search_forward r n "babababc" [||]; start_test "Search for /[^a]/"; let r = Str.regexp "[^a]" in let n = 0 in test_search_forward r n "athing" [|"t"|]; test_search_forward r n "Athing" [|"A"|]; start_test "Search for /[^a]/ (case-insensitive)"; let r = Str.regexp_case_fold "[^a]" in let n = 0 in test_search_forward r n "athing" [|"t"|]; test_search_forward r n "Athing" [|"t"|]; start_test "Search for /^[]abcde]/"; let r = Str.regexp "^[]abcde]" in let n = 0 in test_search_forward r n "athing" [|"a"|]; test_search_forward r n "bthing" [|"b"|]; test_search_forward r n "]thing" [|"]"|]; test_search_forward r n "cthing" [|"c"|]; test_search_forward r n "dthing" [|"d"|]; test_search_forward r n "ething" [|"e"|]; test_search_forward r n "fthing" [||]; test_search_forward r n "[thing" [||]; test_search_forward r n "\\\\thing" [||]; start_test "Search for /^[]cde]/"; let r = Str.regexp "^[]cde]" in let n = 0 in test_search_forward r n "]thing" [|"]"|]; test_search_forward r n "cthing" [|"c"|]; test_search_forward r n "dthing" [|"d"|]; test_search_forward r n "ething" [|"e"|]; test_search_forward r n "athing" [||]; test_search_forward r n "fthing" [||]; start_test "Search for /^[^]abcde]/"; let r = Str.regexp "^[^]abcde]" in let n = 0 in test_search_forward r n "fthing" [|"f"|]; test_search_forward r n "[thing" [|"["|]; test_search_forward r n "\\\\thing" [|"\\"|]; test_search_forward r n "athing" [||]; test_search_forward r n "bthing" [||]; test_search_forward r n "]thing" [||]; test_search_forward r n "cthing" [||]; test_search_forward r n "dthing" [||]; test_search_forward r n "ething" [||]; start_test "Search for /^[^]cde]/"; let r = Str.regexp "^[^]cde]" in let n = 0 in test_search_forward r n "athing" [|"a"|]; test_search_forward r n "fthing" [|"f"|]; test_search_forward r n "]thing" [||]; test_search_forward r n "cthing" [||]; test_search_forward r n "dthing" [||]; test_search_forward r n "ething" [||]; start_test "Search for /^/"; let r = Str.regexp "^" in let n = 0 in test_search_forward r n "" [|""|]; start_test "Search for /^[0-9]+$/"; let r = Str.regexp "^[0-9]+$" in let n = 0 in test_search_forward r n "0" [|"0"|]; test_search_forward r n "1" [|"1"|]; test_search_forward r n "2" [|"2"|]; test_search_forward r n "3" [|"3"|]; test_search_forward r n "4" [|"4"|]; test_search_forward r n "5" [|"5"|]; test_search_forward r n "6" [|"6"|]; test_search_forward r n "7" [|"7"|]; test_search_forward r n "8" [|"8"|]; test_search_forward r n "9" [|"9"|]; test_search_forward r n "10" [|"10"|]; test_search_forward r n "100" [|"100"|]; test_search_forward r n "abc" [||]; start_test "Search for /^.*nter/"; let r = Str.regexp "^.*nter" in let n = 0 in test_search_forward r n "enter" [|"enter"|]; test_search_forward r n "inter" [|"inter"|]; test_search_forward r n "uponter" [|"uponter"|]; start_test "Search for /^xxx[0-9]+$/"; let r = Str.regexp "^xxx[0-9]+$" in let n = 0 in test_search_forward r n "xxx0" [|"xxx0"|]; test_search_forward r n "xxx1234" [|"xxx1234"|]; test_search_forward r n "xxx" [||]; start_test "Search for /^.+[0-9][0-9][0-9]$/"; let r = Str.regexp "^.+[0-9][0-9][0-9]$" in let n = 0 in test_search_forward r n "x123" [|"x123"|]; test_search_forward r n "xx123" [|"xx123"|]; test_search_forward r n "123456" [|"123456"|]; test_search_forward r n "123" [||]; test_search_forward r n "x123x" [||]; start_test "Search for /^\\([^!]+\\)!\\(.+\\)=apquxz\\.ixr\\.zzz\\.ac\\.uk$/"; let r = Str.regexp "^\\([^!]+\\)!\\(.+\\)=apquxz\\.ixr\\.zzz\\.ac\\.uk$" in let n = 2 in test_search_forward r n "abc!pqr=apquxz.ixr.zzz.ac.uk" [|"abc!pqr=apquxz.ixr.zzz.ac.uk"; "abc"; "pqr"|]; test_search_forward r n "!pqr=apquxz.ixr.zzz.ac.uk" [||]; test_search_forward r n "abc!=apquxz.ixr.zzz.ac.uk" [||]; test_search_forward r n "abc!pqr=apquxz:ixr.zzz.ac.uk" [||]; test_search_forward r n "abc!pqr=apquxz.ixr.zzz.ac.ukk" [||]; start_test "Search for /\\([0-9a-f:]+\\)$/"; let r = Str.regexp_case_fold "\\([0-9a-f:]+\\)$" in let n = 1 in test_search_forward r n "0abc" [|"0abc"; "0abc"|]; test_search_forward r n "abc" [|"abc"; "abc"|]; test_search_forward r n "fed" [|"fed"; "fed"|]; test_search_forward r n "E" [|"E"; "E"|]; test_search_forward r n "::" [|"::"; "::"|]; test_search_forward r n "5f03:12C0::932e" [|"5f03:12C0::932e"; "5f03:12C0::932e"|]; test_search_forward r n "fed def" [|"def"; "def"|]; test_search_forward r n "Any old stuff" [|"ff"; "ff"|]; test_search_forward r n "0zzz" [||]; test_search_forward r n "gzzz" [||]; test_search_forward r n "fed " [||]; test_search_forward r n "Any old rubbish" [||]; start_test "Search for /^[a-z0-9][a-z0-9-]*\\(\\.[a-z0-9][A-Z0-9-]*\\)*\\.$/"; let r = Str.regexp_case_fold "^[a-z0-9][a-z0-9-]*\\(\\.[a-z0-9][A-Z0-9-]*\\)*\\.$" in let n = 1 in test_search_forward r n "a." [|"a."; "~"|]; test_search_forward r n "Z." [|"Z."; "~"|]; test_search_forward r n "2." [|"2."; "~"|]; test_search_forward r n "ab-c." [|"ab-c."; "~"|]; test_search_forward r n "ab-c.pq-r." [|"ab-c.pq-r."; ".pq-r"|]; test_search_forward r n "sxk.zzz.ac.uk." [|"sxk.zzz.ac.uk."; ".uk"|]; test_search_forward r n "sxk.ZZZ.ac.UK." [|"sxk.ZZZ.ac.UK."; ".UK"|]; test_search_forward r n "x-.y-." [|"x-.y-."; ".y-"|]; test_search_forward r n "-abc.peq." [||]; start_test "Search for /^\\*\\.[a-z]\\([a-z0-9-]*[a-z0-9]+\\)?\\(\\.[a-z]\\([a-z0-9-]*[a-z0-9]+\\)?\\)*$/"; let r = Str.regexp "^\\*\\.[a-z]\\([a-z0-9-]*[a-z0-9]+\\)?\\(\\.[a-z]\\([a-z0-9-]*[a-z0-9]+\\)?\\)*$" in let n = 3 in test_search_forward r n "*.a" [|"*.a"; "~"; "~"; "~"|]; test_search_forward r n "*.b0-a" [|"*.b0-a"; "0-a"; "~"; "~"|]; test_search_forward r n "*.c3-b.c" [|"*.c3-b.c"; "3-b"; ".c"; "~"|]; test_search_forward r n "*.c-a.b-c" [|"*.c-a.b-c"; "-a"; ".b-c"; "-c"|]; test_search_forward r n "*.0" [||]; test_search_forward r n "*.a-" [||]; test_search_forward r n "*.a-b.c-" [||]; test_search_forward r n "*.c-a.0-c" [||]; start_test "Search for /^[0-9a-fA-F]\\(\\.[0-9a-fA-F]\\)*$/"; let r = Str.regexp "^[0-9a-fA-F]\\(\\.[0-9a-fA-F]\\)*$" in let n = 1 in test_search_forward r n "a.b.c.d" [|"a.b.c.d"; ".d"|]; test_search_forward r n "A.B.C.D" [|"A.B.C.D"; ".D"|]; test_search_forward r n "a.b.c.1.2.3.C" [|"a.b.c.1.2.3.C"; ".C"|]; test_search_forward r n "a.b.c.dz" [||]; test_search_forward r n "za" [||]; start_test "Search for /^\\\".*\\\" *\\(;.*\\)?$/"; let r = Str.regexp "^\\\".*\\\" *\\(;.*\\)?$" in let n = 1 in test_search_forward r n "\"1234\"" [|"\"1234\""; "~"|]; test_search_forward r n "\"abcd\" ;" [|"\"abcd\" ;"; ";"|]; test_search_forward r n "\"\" ; rhubarb" [|"\"\" ; rhubarb"; "; rhubarb"|]; test_search_forward r n "\"1234\" : things" [||]; start_test "Search for /^\\(a\\(b\\(c\\)\\)\\)\\(d\\(e\\(f\\)\\)\\)\\(h\\(i\\(j\\)\\)\\)$/"; let r = Str.regexp "^\\(a\\(b\\(c\\)\\)\\)\\(d\\(e\\(f\\)\\)\\)\\(h\\(i\\(j\\)\\)\\)$" in let n = 9 in test_search_forward r n "abcdefhij" [|"abcdefhij"; "abc"; "bc"; "c"; "def"; "ef"; "f"; "hij"; "ij"; "j"|]; start_test "Search for /^[.^$|()*+?{,}]+/"; let r = Str.regexp "^[.^$|()*+?{,}]+" in let n = 0 in test_search_forward r n ".^$*(+)|{?,?}" [|".^$*(+)|{?,?}"|]; start_test "Search for /\\(cat\\(a\\(ract\\|tonic\\)\\|erpillar\\)\\) \\1\\(\\)2\\(3\\)/"; let r = Str.regexp "\\(cat\\(a\\(ract\\|tonic\\)\\|erpillar\\)\\) \\1\\(\\)2\\(3\\)" in let n = 5 in test_search_forward r n "cataract cataract23" [|"cataract cataract23"; "cataract"; "aract"; "ract"; ""; "3"|]; test_search_forward r n "catatonic catatonic23" [|"catatonic catatonic23"; "catatonic"; "atonic"; "tonic"; ""; "3"|]; test_search_forward r n "caterpillar caterpillar23" [|"caterpillar caterpillar23"; "caterpillar"; "erpillar"; "~"; ""; "3"|]; start_test "Search for /^From +\\([^ ]+\\) +[a-zA-Z][a-zA-Z][a-zA-Z] +[a-zA-Z][a-zA-Z][a-zA-Z] +[0-9]?[0-9] +[0-9][0-9]:[0-9][0-9]/"; let r = Str.regexp "^From +\\([^ ]+\\) +[a-zA-Z][a-zA-Z][a-zA-Z] +[a-zA-Z][a-zA-Z][a-zA-Z] +[0-9]?[0-9] +[0-9][0-9]:[0-9][0-9]" in let n = 1 in test_search_forward r n "From abcd Mon Sep 01 12:33:02 1997" [|"From abcd Mon Sep 01 12:33"; "abcd"|]; start_test "Search for /\\ba/"; let r = Str.regexp "\\ba" in let n = 0 in test_search_forward r n "a2cd" [|"a"|]; test_search_forward r n "the a" [|"a"|]; test_search_forward r n ".ab" [|"a"|]; test_search_forward r n "bad" [||]; test_search_forward r n "the ba" [||]; test_search_forward r n "ba." [||]; start_test "Search for /a\\b/"; let r = Str.regexp "a\\b" in let n = 0 in test_search_forward r n "a" [|"a"|]; test_search_forward r n "bc_a" [|"a"|]; test_search_forward r n "a foo" [|"a"|]; test_search_forward r n "a." [|"a"|]; test_search_forward r n "bad" [||]; test_search_forward r n "ab" [||]; start_test "Search for /\\([a-z]*\\)b/"; let r = Str.regexp "\\([a-z]*\\)b" in let n = 1 in test_search_forward r n "abbb" [|"abbb"; "abb"|]; start_test "Search for /\\([a-z]+\\)b/"; let r = Str.regexp "\\([a-z]+\\)b" in let n = 1 in test_search_forward r n "abbb" [|"abbb"; "abb"|]; start_test "Search for /\\([a-z]?\\)b/"; let r = Str.regexp "\\([a-z]?\\)b" in let n = 1 in test_search_forward r n "bbbb" [|"bb"; "b"|]; start_test "Search for /^a/"; let r = Str.regexp "^a" in let n = 0 in test_search_forward r n "abcdef" [|"a"|]; test_search_forward r n "zzzz\nabcdef" [|"a"|]; start_test "Search for /a$/"; let r = Str.regexp "a$" in let n = 0 in test_search_forward r n "xyza" [|"a"|]; test_search_forward r n "xyza\nbcdef" [|"a"|]; start_test "Null characters in regexps"; let r = Str.regexp "ab\000cd" in let n = 0 in test_search_forward r n "qerpoiuab\000cdwerltkh" [| "ab\000cd" |]; let r = Str.regexp "\000cd" in let n = 0 in test_search_forward r n "qerpoiuab\000cdwerltkh" [| "\000cd" |]; (** Backward searches *) start_test "Backward search for /the quick/"; let r = Str.regexp "the quick" in let n = 0 in test_search_backward r n "the quick brown fox" [|"the quick"|]; test_search_backward r n "What do you know about the quick brown fox?" [|"the quick"|]; test_search_backward r n "The quick brown FOX" [||]; test_search_backward r n "What do you know about THE QUICK BROWN FOX?" [||]; start_test "Backward search for /a\\([0-9]+\\)/"; let r = Str.regexp "a\\([0-9]+\\)" in let n = 1 in test_search_backward r n "a123 a456zzzz" [|"a456"; "456"|]; test_search_backward r n "ab123" [||]; (** Partial match searches *) start_test "Partial match for /partial match/"; let r = Str.regexp "partial match" in let n = 0 in test_partial_match r n "" [|""|]; test_partial_match r n "partial matching" [|"partial match"|]; test_partial_match r n "partial m" [|"partial m"|]; start_test "Partial match for /\\(partial\\)\\|\\(match\\)/"; let r = Str.regexp "\\(partial\\)\\|\\(match\\)" in let n = 2 in test_partial_match r n "" [|""; "~"; "~"|]; test_partial_match r n "part" [|"part"; "~"; "~"|]; test_partial_match r n "partial" [|"partial"; "partial"; "~"|]; test_partial_match r n "matching" [|"match"; "~"; "match"|]; test_partial_match r n "mat" [|"mat"; "~"; "~"|]; test_partial_match r n "zorglub" [||]; (** Replacement *) start_test "Global replacement"; test (Str.global_replace (Str.regexp "[aeiou]") ".." "abcdefghijklmnopqrstuvwxyz") "..bcd..fgh..jklmn..pqrst..vwxyz"; test (Str.global_replace (Str.regexp "[0-9]\\([0-9]*\\)") "-\\0-\\1-" "abc012def3ghi45") "abc-012-12-def-3--ghi-45-5-"; test (Str.global_replace (Str.regexp "[0-9]?") "." "abc012def3ghi45") ".a.b.c....d.e.f..g.h.i..."; start_test "First replacement"; test (Str.replace_first (Str.regexp "[eiou]") ".." "abcdefghijklmnopqrstuvwxyz") "abcd..fghijklmnopqrstuvwxyz"; test (Str.replace_first (Str.regexp "[0-9]\\([0-9]*\\)") "-\\0-\\1-" "abc012def3ghi45") "abc-012-12-def3ghi45"; (** Splitting *) start_test "Splitting"; test (Str.split (Str.regexp "[ \t]+") "si non e vero") ["si"; "non"; "e"; "vero"]; test (Str.split (Str.regexp "[ \t]+") " si non\te vero\t") ["si"; "non"; "e"; "vero"]; test (Str.bounded_split (Str.regexp "[ \t]+") " si non e vero " 3) ["si"; "non"; "e vero "]; test (Str.split (Str.regexp "[ \t]*") "si non e vero") ["s"; "i"; "n"; "o"; "n"; "e"; "v"; "e"; "r"; "o"]; test (Str.split_delim (Str.regexp "[ \t]+") " si non e vero\t") [""; "si"; "non"; "e"; "vero"; ""]; test (Str.full_split (Str.regexp "[ \t]+") " si non\te vero\t") [Str.Delim " "; Str.Text "si"; Str.Delim " "; Str.Text "non"; Str.Delim "\t"; Str.Text "e"; Str.Delim " "; Str.Text "vero"; Str.Delim "\t"]; (** XML tokenization *) (* See "REX: XML Shallow Parsing with Regular Expressions", Robert D. Cameron, Simon Fraser University, CMPT TR 1998-17. *) start_test "XML tokenization"; begin let _TextSE = "[^<]+" in let _UntilHyphen = "[^-]*-" in let _Until2Hyphens = _UntilHyphen ^ "\\([^-]" ^ _UntilHyphen ^ "\\)*-" in let _CommentCE = _Until2Hyphens ^ ">?" in let _UntilRSBs = "[^]]*]\\([^]]+]\\)*]+" in let _CDATA_CE = _UntilRSBs ^ "\\([^]>]" ^ _UntilRSBs ^ "\\)*>" in let _S = "[ \n\t\r]+" in let _NameStrt = "[A-Za-z_:]\\|[^\x00-\x7F]" in let _NameChar = "[A-Za-z0-9_:.-]\\|[^\x00-\x7F]" in let _Name = "\\(" ^ _NameStrt ^ "\\)\\(" ^ _NameChar ^ "\\)*" in let _QuoteSE = "\"[^\"]*\"\\|'[^']*'" in let _DT_IdentSE = _S ^ _Name ^ "\\(" ^ _S ^ "\\(" ^ _Name ^ "\\|" ^ _QuoteSE ^ "\\)\\)*" in let _MarkupDeclCE = "\\([^]\"'><]\\|" ^ _QuoteSE ^ "\\)*>" in let _S1 = "[\n\r\t ]" in let _UntilQMs = "[^?]*\\?+" in let _PI_Tail = "\\?>\\|" ^ _S1 ^ _UntilQMs ^ "\\([^>?]" ^ _UntilQMs ^ "\\)*>" in let _DT_ItemSE = "<\\(!\\(--" ^ _Until2Hyphens ^ ">\\|[^-]" ^ _MarkupDeclCE ^ "\\)\\|\\?" ^ _Name ^ "\\(" ^ _PI_Tail ^ "\\)\\)\\|%" ^ _Name ^ ";\\|" ^ _S1 in let _DocTypeCE = _DT_IdentSE ^ "\\(" ^ _S ^ "\\)?\\(\\[\\(" ^ _DT_ItemSE ^ "\\)*]\\(" ^ _S ^ "\\)?\\)?>?" in let _DeclCE = "--\\(" ^ _CommentCE ^ "\\)?\\|\\[_CDATA\\[\\(" ^ _CDATA_CE ^ "\\)?\\|_DOCTYPE\\(" ^ _DocTypeCE ^ "\\)?" in let _PI_CE = _Name ^ "\\(" ^ _PI_Tail ^ "\\)?" in let _EndTagCE = _Name ^ "\\(" ^ _S ^ "\\)?>?" in let _AttValSE = "\"[^<\"]*\"\\|'[^<']*'" in let _ElemTagCE = _Name ^ "\\(" ^ _S ^ _Name ^ "\\(" ^ _S ^ "\\)?=\\(" ^ _S ^ "\\)?\\(" ^ _AttValSE ^ "\\)\\)*\\(" ^ _S ^ "\\)?/?>?" in let _MarkupSPE = "<\\(!\\(" ^ _DeclCE ^ "\\)?\\|\\?\\(" ^ _PI_CE ^ "\\)?\\|/\\(" ^ _EndTagCE ^ "\\)?\\|\\(" ^ _ElemTagCE ^ "\\)?\\)" in let _XML_SPE = _TextSE ^ "\\|" ^ _MarkupSPE in let input = "\ ]> 65 20 300 2400 300 25 50 Avocado Dip Sunnydale 29 11 3 5 210 2 0 1 0 0 0 0 " in let result = [ ""; "\n"; ""; "\n"; "\n "; "\n]>\n"; "\n"; " \n"; ""; "\n"; ""; "\n\t"; ""; "65"; ""; "\n\t"; ""; "20"; ""; "\n\t"; ""; "300"; ""; "\n\t"; ""; "2400"; ""; "\n\t"; ""; "300"; ""; "\n\t"; ""; "25"; ""; "\n\t"; ""; "50"; ""; "\n"; ""; "\n"; ""; "\n\t"; ""; "Avocado Dip"; ""; "\n\t"; ""; "Sunnydale"; ""; "\n\t"; ""; "29"; ""; "\n\t"; ""; "\n\t"; ""; "11"; ""; "\n\t"; ""; "3"; ""; "\n\t"; ""; "5"; ""; "\n\t"; ""; "210"; ""; "\n\t"; ""; "2"; ""; "\n\t"; ""; "0"; ""; "\n\t"; ""; "1"; ""; "\n\t"; ""; "\n\t\t"; ""; "0"; ""; "\n\t\t"; ""; "0"; ""; "\n\t"; ""; "\n\t"; ""; "\n\t\t"; ""; "0"; ""; "\n\t\t"; ""; "0"; ""; "\n\t"; ""; "\n"; ""; "\n"; ""; "\n"] in let re = Str.regexp _XML_SPE in let rec process i l = let j = try Str.search_forward re input i with Not_found -> (-1) in if j < 0 then begin test l [] end else begin match l with [] -> test 0 1 (* failure *) | hd :: tl -> test (Str.matched_string input) hd; process (Str.match_end()) tl end in process 0 result end; end_test() let manual_test regexp text = try ignore (Str.search_forward (Str.regexp regexp) text 0); printf "Matched,"; begin try for i = 0 to 31 do try let s = Str.matched_group i text in printf " \\%d=%s" i s with Not_found -> () done with Invalid_argument "Str.matched_group" -> (*yuck*) () end; print_newline() with Not_found -> printf "Not matched\n" let _ = if Array.length Sys.argv >= 3 then manual_test Sys.argv.(1) Sys.argv.(2) else automated_test() mingw-ocaml/ocaml/testsuite/tests/lib-str/t01.reference0000644000175000017500000000431612124403241022515 0ustar tootstoots Search for /the quick brown fox/ .... Search for /the quick brown fox/ (case-insensitive) ..... Search for /a*abc?xyz+pqrrrabbb*xyyyyy?pq?q?q?q?q?q?AB*zz/ .................................... Search for /^abc\(abc\)?zz/ ..... Search for /^\(b+\|a\)\(b+\|a\)?c/ .......... Search for /r\(\(g*\|k\)y?\)*A/ .... Search for /A\(\(t\|v\)\(q?\|n\)\)*A/ . Search for /A\(\(b\(\(d\|l*\)?\|w\)\)*a\)A/ . Search for /\(\|f\)*x/ .... Search for /\(\|f\)+x/ .... Search for /A\(.?\)*A/ .... Search for /\([ab]*\)\1+c/ ... Search for /^\(\(b+\|a\)\(b+\|a\)?\)?bc/ . Search for /^\(\(b*\|ba\)\(b*\|ba\)?\)?bc/ ..... Search for /[^a]/ .. Search for /[^a]/ (case-insensitive) .. Search for /^[]abcde]/ ......... Search for /^[]cde]/ ...... Search for /^[^]abcde]/ ......... Search for /^[^]cde]/ ...... Search for /^/ . Search for /^[0-9]+$/ ............. Search for /^.*nter/ ... Search for /^xxx[0-9]+$/ ... Search for /^.+[0-9][0-9][0-9]$/ ..... Search for /^\([^!]+\)!\(.+\)=apquxz\.ixr\.zzz\.ac\.uk$/ ..... Search for /\([0-9a-f:]+\)$/ ............ Search for /^[a-z0-9][a-z0-9-]*\(\.[a-z0-9][A-Z0-9-]*\)*\.$/ ......... Search for /^\*\.[a-z]\([a-z0-9-]*[a-z0-9]+\)?\(\.[a-z]\([a-z0-9-]*[a-z0-9]+\)?\)*$/ ........ Search for /^[0-9a-fA-F]\(\.[0-9a-fA-F]\)*$/ ..... Search for /^\".*\" *\(;.*\)?$/ .... Search for /^\(a\(b\(c\)\)\)\(d\(e\(f\)\)\)\(h\(i\(j\)\)\)$/ . Search for /^[.^$|()*+?{,}]+/ . Search for /\(cat\(a\(ract\|tonic\)\|erpillar\)\) \1\(\)2\(3\)/ ... Search for /^From +\([^ ]+\) +[a-zA-Z][a-zA-Z][a-zA-Z] +[a-zA-Z][a-zA-Z][a-zA-Z] +[0-9]?[0-9] +[0-9][0-9]:[0-9][0-9]/ . Search for /\ba/ ...... Search for /a\b/ ...... Search for /\([a-z]*\)b/ . Search for /\([a-z]+\)b/ . Search for /\([a-z]?\)b/ . Search for /^a/ .. Search for /a$/ .. Null characters in regexps .. Backward search for /the quick/ .... Backward search for /a\([0-9]+\)/ .. Partial match for /partial match/ ... Partial match for /\(partial\)\|\(match\)/ ...... Global replacement ... First replacement .. Splitting ...... XML tokenization ......................................................................................................................... All tests passed mingw-ocaml/ocaml/testsuite/tests/lib-stream/0000755000175000017500000000000012124403241020710 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-stream/Makefile0000644000175000017500000000017112124403241022347 0ustar tootstootsBASEDIR=../.. MODULES=testing include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-stream/count_concat_bug.ml0000644000175000017500000000304612124403241024561 0ustar tootstootslet is_empty s = try Stream.empty s; true with Stream.Failure -> false let test_icons = let s = Stream.of_string "ab" in let s = Stream.icons 'c' s in Testing.test (Stream.next s = 'c'); Testing.test (Stream.next s = 'a'); Testing.test (Stream.next s = 'b'); Testing.test (is_empty s); () let test_lcons = let s = Stream.of_string "ab" in let s = Stream.lcons (fun () -> 'c') s in Testing.test (Stream.next s = 'c'); Testing.test (Stream.next s = 'a'); Testing.test (Stream.next s = 'b'); Testing.test (is_empty s); () let test_iapp = let s = Stream.of_string "ab" in let s = Stream.iapp (Stream.of_list ['c']) s in Testing.test (Stream.next s = 'c'); Testing.test (Stream.next s = 'a'); Testing.test (Stream.next s = 'b'); Testing.test (is_empty s); () let test_lapp_right = let s1 = Stream.of_list ['c'] in let s2 = Stream.of_string "ab" in let s = Stream.lapp (fun () -> s1) s2 in Testing.test (Stream.next s = 'c'); Testing.test (Stream.next s = 'a'); Testing.test (Stream.next s = 'b'); Testing.test (is_empty s); () let test_lapp_left = let s1 = Stream.of_string "bc" in let s2 = Stream.of_list ['a'] in Testing.test (Stream.next s1 = 'b'); let s = Stream.lapp (fun () -> s1) s2 in Testing.test (Stream.next s = 'c'); Testing.test (Stream.next s = 'a'); Testing.test (is_empty s); () let test_slazy = let s = Stream.of_string "ab" in Testing.test (Stream.next s = 'a'); let s = Stream.slazy (fun () -> s) in Testing.test (Stream.next s = 'b'); Testing.test (is_empty s); () mingw-ocaml/ocaml/testsuite/tests/lib-stream/count_concat_bug.reference0000644000175000017500000000012112124403241026076 0ustar tootstoots 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 All tests succeeded. mingw-ocaml/ocaml/testsuite/tests/typing-implicit_unpack/0000755000175000017500000000000012124403241023334 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-implicit_unpack/Makefile0000644000175000017500000000015212124403241024772 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml0000644000175000017500000001102312124403241027036 0ustar tootstoots(* Implicit unpack allows to omit the signature in (val ...) expressions. It also adds (module M : S) and (module M) patterns, relying on implicit (val ...) for the implementation. Such patterns can only be used in function definition, match clauses, and let ... in. New: implicit pack is also supported, and you only need to be able to infer the the module type path from the context. *) (* ocaml -principal *) (* Use a module pattern *) let sort (type s) (module Set : Set.S with type elt = s) l = Set.elements (List.fold_right Set.add l Set.empty) (* No real improvement here? *) let make_set (type s) cmp : (module Set.S with type elt = s) = (module Set.Make (struct type t = s let compare = cmp end)) (* No type annotation here *) let sort_cmp (type s) cmp = sort (module Set.Make (struct type t = s let compare = cmp end)) module type S = sig type t val x : t end;; let f (module M : S with type t = int) = M.x;; let f (module M : S with type t = 'a) = M.x;; (* Error *) let f (type a) (module M : S with type t = a) = M.x;; f (module struct type t = int let x = 1 end);; type 'a s = {s: (module S with type t = 'a)};; {s=(module struct type t = int let x = 1 end)};; let f {s=(module M)} = M.x;; (* Error *) let f (type a) ({s=(module M)} : a s) = M.x;; type s = {s: (module S with type t = int)};; let f {s=(module M)} = M.x;; let f {s=(module M)} {s=(module N)} = M.x + N.x;; module type S = sig val x : int end;; let f (module M : S) y (module N : S) = M.x + y + N.x;; let m = (module struct let x = 3 end);; (* Error *) let m = (module struct let x = 3 end : S);; f m 1 m;; f m 1 (module struct let x = 2 end);; let (module M) = m in M.x;; let (module M) = m;; (* Error: only allowed in [let .. in] *) class c = let (module M) = m in object end;; (* Error again *) module M = (val m);; module type S' = sig val f : int -> int end;; (* Even works with recursion, but must be fully explicit *) let rec (module M : S') = (module struct let f n = if n <= 0 then 1 else n * M.f (n-1) end : S') in M.f 3;; (* Subtyping *) module type S = sig type t type u val x : t * u end let f (l : (module S with type t = int and type u = bool) list) = (l :> (module S with type u = bool) list) (* GADTs from the manual *) (* the only modification is in to_string *) module TypEq : sig type ('a, 'b) t val apply: ('a, 'b) t -> 'a -> 'b val refl: ('a, 'a) t val sym: ('a, 'b) t -> ('b, 'a) t end = struct type ('a, 'b) t = ('a -> 'b) * ('b -> 'a) let refl = (fun x -> x), (fun x -> x) let apply (f, _) x = f x let sym (f, g) = (g, f) end module rec Typ : sig module type PAIR = sig type t and t1 and t2 val eq: (t, t1 * t2) TypEq.t val t1: t1 Typ.typ val t2: t2 Typ.typ end type 'a typ = | Int of ('a, int) TypEq.t | String of ('a, string) TypEq.t | Pair of (module PAIR with type t = 'a) end = Typ let int = Typ.Int TypEq.refl let str = Typ.String TypEq.refl let pair (type s1) (type s2) t1 t2 = let module P = struct type t = s1 * s2 type t1 = s1 type t2 = s2 let eq = TypEq.refl let t1 = t1 let t2 = t2 end in Typ.Pair (module P) open Typ let rec to_string: 'a. 'a Typ.typ -> 'a -> string = fun (type s) t x -> match (t : s typ) with | Int eq -> string_of_int (TypEq.apply eq x) | String eq -> Printf.sprintf "%S" (TypEq.apply eq x) | Pair (module P) -> let (x1, x2) = TypEq.apply P.eq x in Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2) (* Wrapping maps *) module type MapT = sig include Map.S type data type map val of_t : data t -> map val to_t : map -> data t end type ('k,'d,'m) map = (module MapT with type key = 'k and type data = 'd and type map = 'm) let add (type k) (type d) (type m) (m:(k,d,m) map) x y s = let module M = (val m:MapT with type key = k and type data = d and type map = m) in M.of_t (M.add x y (M.to_t s)) module SSMap = struct include Map.Make(String) type data = string type map = data t let of_t x = x let to_t x = x end let ssmap = (module SSMap: MapT with type key = string and type data = string and type map = SSMap.map) ;; let ssmap = (module struct include SSMap end : MapT with type key = string and type data = string and type map = SSMap.map) ;; let ssmap = (let module S = struct include SSMap end in (module S) : (module MapT with type key = string and type data = string and type map = SSMap.map)) ;; let ssmap = (module SSMap: MapT with type key = _ and type data = _ and type map = _) ;; let ssmap : (_,_,_) map = (module SSMap);; add ssmap;; mingw-ocaml/ocaml/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference0000644000175000017500000001377312124403241031011 0ustar tootstoots # * * * * * * * * * val sort : (module Set.S with type elt = 'a) -> 'a list -> 'a list = val make_set : ('a -> 'a -> int) -> (module Set.S with type elt = 'a) = val sort_cmp : ('a -> 'a -> int) -> 'a list -> 'a list = module type S = sig type t val x : t end # val f : (module S with type t = int) -> int = # Characters 6-37: let f (module M : S with type t = 'a) = M.x;; (* Error *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The type of this packed module contains variables: (module S with type t = 'a) # val f : (module S with type t = 'a) -> 'a = # - : int = 1 # type 'a s = { s : (module S with type t = 'a); } # - : int s = {s = } # Characters 9-19: let f {s=(module M)} = M.x;; (* Error *) ^^^^^^^^^^ Error: The type of this packed module contains variables: (module S with type t = 'a) # val f : 'a s -> 'a = # type s = { s : (module S with type t = int); } # val f : s -> int = # val f : s -> s -> int = # module type S = sig val x : int end # val f : (module S) -> int -> (module S) -> int = # Characters 8-37: let m = (module struct let x = 3 end);; (* Error *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The signature for this packaged module couldn't be inferred. # val m : (module S) = # - : int = 7 # - : int = 6 # - : int = 3 # Characters 4-14: let (module M) = m;; (* Error: only allowed in [let .. in] *) ^^^^^^^^^^ Error: Modules are not allowed in this pattern. # Characters 14-24: class c = let (module M) = m in object end;; (* Error again *) ^^^^^^^^^^ Error: Modules are not allowed in this pattern. # module M : S # module type S' = sig val f : int -> int end # - : int = 6 # module type S = sig type t type u val x : t * u end val f : (module S with type t = int and type u = bool) list -> (module S with type u = bool) list = module TypEq : sig type ('a, 'b) t val apply : ('a, 'b) t -> 'a -> 'b val refl : ('a, 'a) t val sym : ('a, 'b) t -> ('b, 'a) t end module rec Typ : sig module type PAIR = sig type t and t1 and t2 val eq : (t, t1 * t2) TypEq.t val t1 : t1 Typ.typ val t2 : t2 Typ.typ end type 'a typ = Int of ('a, int) TypEq.t | String of ('a, string) TypEq.t | Pair of (module PAIR with type t = 'a) end val int : int Typ.typ = Int val str : string Typ.typ = String val pair : 'a Typ.typ -> 'b Typ.typ -> ('a * 'b) Typ.typ = val to_string : 'a Typ.typ -> 'a -> string = module type MapT = sig type key type +'a t val empty : 'a t val is_empty : 'a t -> bool val mem : key -> 'a t -> bool val add : key -> 'a -> 'a t -> 'a t val singleton : key -> 'a -> 'a t val remove : key -> 'a t -> 'a t val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val for_all : (key -> 'a -> bool) -> 'a t -> bool val exists : (key -> 'a -> bool) -> 'a t -> bool val filter : (key -> 'a -> bool) -> 'a t -> 'a t val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t val cardinal : 'a t -> int val bindings : 'a t -> (key * 'a) list val min_binding : 'a t -> key * 'a val max_binding : 'a t -> key * 'a val choose : 'a t -> key * 'a val split : key -> 'a t -> 'a t * 'a option * 'a t val find : key -> 'a t -> 'a val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t type data type map val of_t : data t -> map val to_t : map -> data t end type ('k, 'd, 'm) map = (module MapT with type data = 'd and type key = 'k and type map = 'm) val add : ('a, 'b, 'c) map -> 'a -> 'b -> 'c -> 'c = module SSMap : sig type key = String.t type 'a t = 'a Map.Make(String).t val empty : 'a t val is_empty : 'a t -> bool val mem : key -> 'a t -> bool val add : key -> 'a -> 'a t -> 'a t val singleton : key -> 'a -> 'a t val remove : key -> 'a t -> 'a t val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val for_all : (key -> 'a -> bool) -> 'a t -> bool val exists : (key -> 'a -> bool) -> 'a t -> bool val filter : (key -> 'a -> bool) -> 'a t -> 'a t val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t val cardinal : 'a t -> int val bindings : 'a t -> (key * 'a) list val min_binding : 'a t -> key * 'a val max_binding : 'a t -> key * 'a val choose : 'a t -> key * 'a val split : key -> 'a t -> 'a t * 'a option * 'a t val find : key -> 'a t -> 'a val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t type data = string type map = data t val of_t : 'a -> 'a val to_t : 'a -> 'a end val ssmap : (module MapT with type data = string and type key = string and type map = SSMap.map) = # val ssmap : (module MapT with type data = string and type key = string and type map = SSMap.map) = # val ssmap : (module MapT with type data = string and type key = string and type map = SSMap.map) = # val ssmap : (module MapT with type data = SSMap.data and type key = SSMap.key and type map = SSMap.map) = # val ssmap : (SSMap.key, SSMap.data, SSMap.map) map = # - : SSMap.key -> SSMap.data -> SSMap.map -> SSMap.map = # mingw-ocaml/ocaml/testsuite/tests/typing-private/0000755000175000017500000000000012124403241021633 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-private/private.ml.reference0000644000175000017500000000730212124403241025576 0ustar tootstoots # module Foobar : sig type t = private int end # module F0 : sig type t = private int end # Characters 21-22: let f (x : F0.t) = (x : Foobar.t);; (* fails *) ^ Error: This expression has type F0.t but an expression was expected of type Foobar.t # module F : sig type t = Foobar.t end # val f : F.t -> Foobar.t = # module M : sig type t = < m : int > end # module M1 : sig type t = private < m : int; .. > end # module M2 : sig type t = private < m : int; .. > end # Characters 19-20: fun (x : M1.t) -> (x : M2.t);; (* fails *) ^ Error: This expression has type M1.t but an expression was expected of type M2.t # module M3 : sig type t = private M1.t end # - : M3.t -> M1.t = # - : M3.t -> M.t = # Characters 44-46: module M4 : sig type t = private M3.t end = M2;; (* fails *) ^^ Error: Signature mismatch: Modules do not match: sig type t = M2.t end is not included in sig type t = private M3.t end Type declarations do not match: type t = M2.t is not included in type t = private M3.t # Characters 44-45: module M4 : sig type t = private M3.t end = M;; (* fails *) ^ Error: Signature mismatch: Modules do not match: sig type t = < m : int > end is not included in sig type t = private M3.t end Type declarations do not match: type t = < m : int > is not included in type t = private M3.t # Characters 44-46: module M4 : sig type t = private M3.t end = M1;; (* might be ok *) ^^ Error: Signature mismatch: Modules do not match: sig type t = M1.t end is not included in sig type t = private M3.t end Type declarations do not match: type t = M1.t is not included in type t = private M3.t # module M5 : sig type t = private M1.t end # Characters 53-55: module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *) ^^ Error: Signature mismatch: Modules do not match: sig type t = M1.t end is not included in sig type t = private < n : int; .. > end Type declarations do not match: type t = M1.t is not included in type t = private < n : int; .. > # Characters 69-118: struct type t = int let f (x : int) = (x : t) end;; (* must fail *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Signature mismatch: Modules do not match: sig type t = int val f : int -> t end is not included in sig type t = private Foobar.t val f : int -> t end Type declarations do not match: type t = int is not included in type t = private Foobar.t # module M : sig type t = private T of int val mk : int -> t end # module M1 : sig type t = M.t val mk : int -> t end # module M2 : sig type t = M.t val mk : int -> t end # module M3 : sig type t = M.t val mk : int -> t end # Characters 26-44: type t = M.t = T of int ^^^^^^^^^^^^^^^^^^ Error: This variant or record definition does not match that of type M.t A private type would be revealed. # module M5 : sig type t = M.t = private T of int val mk : int -> t end # module M6 : sig type t = private T of int val mk : int -> t end # module M' : sig type t_priv = private T of int type t = t_priv val mk : int -> t end # module M3' : sig type t = M'.t val mk : int -> t end # mingw-ocaml/ocaml/testsuite/tests/typing-private/Makefile0000644000175000017500000000015212124403241023271 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-private/private.ml0000644000175000017500000000355412124403241023646 0ustar tootstootsmodule Foobar : sig type t = private int end = struct type t = int end;; module F0 : sig type t = private int end = Foobar;; let f (x : F0.t) = (x : Foobar.t);; (* fails *) module F = Foobar;; let f (x : F.t) = (x : Foobar.t);; module M = struct type t = end;; module M1 : sig type t = private end = M;; module M2 : sig type t = private end = M1;; fun (x : M1.t) -> (x : M2.t);; (* fails *) module M3 : sig type t = private M1.t end = M1;; fun x -> (x : M3.t :> M1.t);; fun x -> (x : M3.t :> M.t);; module M4 : sig type t = private M3.t end = M2;; (* fails *) module M4 : sig type t = private M3.t end = M;; (* fails *) module M4 : sig type t = private M3.t end = M1;; (* might be ok *) module M5 : sig type t = private M1.t end = M3;; module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *) module Bar : sig type t = private Foobar.t val f : int -> t end = struct type t = int let f (x : int) = (x : t) end;; (* must fail *) module M : sig type t = private T of int val mk : int -> t end = struct type t = T of int let mk x = T(x) end;; module M1 : sig type t = M.t val mk : int -> t end = struct type t = M.t let mk = M.mk end;; module M2 : sig type t = M.t val mk : int -> t end = struct include M end;; module M3 : sig type t = M.t val mk : int -> t end = M;; module M4 : sig type t = M.t = T of int val mk : int -> t end = M;; (* Error: The variant or record definition does not match that of type M.t *) module M5 : sig type t = M.t = private T of int val mk : int -> t end = M;; module M6 : sig type t = private T of int val mk : int -> t end = M;; module M' : sig type t_priv = private T of int type t = t_priv val mk : int -> t end = struct type t_priv = T of int type t = t_priv let mk x = T(x) end;; module M3' : sig type t = M'.t val mk : int -> t end = M';; mingw-ocaml/ocaml/testsuite/tests/tool-ocamldoc/0000755000175000017500000000000012124403241021405 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/tool-ocamldoc/.ignore0000644000175000017500000000004012124403241022663 0ustar tootstoots*.html *.sty *.css ocamldoc.out mingw-ocaml/ocaml/testsuite/tests/tool-ocamldoc/t03.ml0000644000175000017500000000055112124403241022346 0ustar tootstootsmodule Foo = struct type t = int let x = 1 end;; module type MT = module type of Foo;; module Bar = struct type t = int let x = 2 end;; module type MT2 = sig type t val x : t end;; module type Gee = MT2 with type t = float ;; module T = (val (if true then (module Foo:MT2 with type t = int) else (module Bar: MT2 with type t = int)) : MT2 with type t = int);; mingw-ocaml/ocaml/testsuite/tests/tool-ocamldoc/t03.reference0000644000175000017500000000022412124403241023671 0ustar tootstoots# # module T03: # # module T03.Foo: # # module type T03.MT: # # module T03.Bar: # # module type T03.MT2: # # module type T03.Gee: # # module T03.T: mingw-ocaml/ocaml/testsuite/tests/tool-ocamldoc/Makefile0000644000175000017500000000140512124403241023045 0ustar tootstootsBASEDIR=../.. CUSTOM_MODULE=odoc_test ADD_COMPFLAGS=-I +ocamldoc DIFF_OPT=--strip-trailing-cr #DIFF_OPT=-b run: $(CUSTOM_MODULE).cmo @for file in t*.ml; do \ printf " ... testing '$$file'"; \ $(OCAMLDOC) -hide-warnings -g $(CUSTOM_MODULE).cmo -o `basename $$file ml`result $$file; \ $(DIFF) $(DIFF_OPT) `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \ done; @$(OCAMLDOC) -hide-warnings -html t*.ml 2>&1 | grep -v test_types_display || true @$(OCAMLDOC) -hide-warnings -latex t*.ml 2>&1 | grep -v test_types_display || true promote: defaultpromote clean: defaultclean @rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/tool-ocamldoc/t02.reference0000644000175000017500000000020712124403241023671 0ustar tootstoots# # module T02: # # module T02.Foo: # # module type T02.TFoo: # # module type T02.TBar: # # module type T02.Gee: # # module T02.Gee.M: mingw-ocaml/ocaml/testsuite/tests/tool-ocamldoc/t01.ml0000644000175000017500000000044112124403241022342 0ustar tootstoots(** Testing display of types. @test_types_display *) let x = 1 module M = struct let y = 2 end module type MT = sig type t = string -> int -> string -> (string * string * string) -> (string * string * string) -> (string * string * string) -> unit val y : int end mingw-ocaml/ocaml/testsuite/tests/tool-ocamldoc/t02.ml0000644000175000017500000000036012124403241022343 0ustar tootstootsmodule Foo = struct type u type t = int let x = 1 end;; module type TFoo = module type of Foo;; module type TBar = TFoo with type u := float;; module type Gee = sig module M : module type of Foo include module type of Foo end mingw-ocaml/ocaml/testsuite/tests/tool-ocamldoc/odoc_test.ml0000644000175000017500000000707712124403241023735 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2004 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Custom generator to perform test on ocamldoc. *) open Odoc_info open Odoc_info.Module open Odoc_info.Type type test_kind = Types_display let p = Format.fprintf class string_gen = object(self) inherit Odoc_info.Scan.scanner val mutable test_kinds = [] val mutable fmt = Format.str_formatter method must_display_types = List.mem Types_display test_kinds method set_test_kinds_from_module m = test_kinds <- List.fold_left (fun acc (s, _) -> match s with "test_types_display" -> Types_display :: acc | _ -> acc ) [] ( match m.m_info with None -> [] | Some i -> i.i_custom ) method! scan_type t = match test_kinds with [] -> () | _ -> p fmt "# type %s:\n" t.ty_name; if self#must_display_types then ( p fmt "# manifest (Odoc_info.string_of_type_expr):\n<[%s]>\n" (match t.ty_manifest with None -> "None" | Some e -> Odoc_info.string_of_type_expr e ); ); method! scan_module_pre m = p fmt "#\n# module %s:\n" m.m_name ; if self#must_display_types then ( p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n" (Odoc_info.string_of_module_type m.m_type); p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n" (Odoc_info.string_of_module_type ~complete: true m.m_type); ); true method! scan_module_type_pre m = p fmt "#\n# module type %s:\n" m.mt_name ; if self#must_display_types then ( p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n" (match m.mt_type with None -> "None" | Some t -> Odoc_info.string_of_module_type t ); p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n" (match m.mt_type with None -> "None" | Some t -> Odoc_info.string_of_module_type ~complete: true t ); ); true method generate (module_list: Odoc_info.Module.t_module list) = let oc = open_out !Odoc_info.Global.out_file in fmt <- Format.formatter_of_out_channel oc; ( try List.iter (fun m -> self#set_test_kinds_from_module m; self#scan_module_list [m]; ) module_list with e -> prerr_endline (Printexc.to_string e) ); Format.pp_print_flush fmt (); close_out oc end let _ = let module My_generator = struct class generator = let inst = new string_gen in object method generate = inst#generate end end in Odoc_args.set_generator (Odoc_gen.Base (module My_generator : Odoc_gen.Base)) mingw-ocaml/ocaml/testsuite/tests/tool-ocamldoc/t01.reference0000644000175000017500000000137712124403241023701 0ustar tootstoots# # module T01: # Odoc_info.string_of_module_type: <[sig end]> # Odoc_info.string_of_module_type ~complete: true : <[sig end]> # # module T01.M: # Odoc_info.string_of_module_type: <[sig end]> # Odoc_info.string_of_module_type ~complete: true : <[sig val y : int end]> # # module type T01.MT: # Odoc_info.string_of_module_type: <[sig end]> # Odoc_info.string_of_module_type ~complete: true : <[sig type t = string -> int -> string -> string * string * string -> string * string * string -> string * string * string -> unit val y : int end]> # type T01.MT.t: # manifest (Odoc_info.string_of_type_expr): <[string -> int -> string -> string * string * string -> string * string * string -> string * string * string -> unit]> mingw-ocaml/ocaml/testsuite/tests/typing-misc/0000755000175000017500000000000012124403241021114 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-misc/records.ml.reference0000644000175000017500000000117212124403241025045 0ustar tootstoots # type t = { x : int; y : int; } # Characters 5-6: {x=3;z=2};; ^ Error: Unbound record field label z # Characters 9-10: fun {x=3;z=2} -> ();; ^ Error: Unbound record field label z # Characters 26-34: {x=3; contents=2};; ^^^^^^^^ Error: The record field label Pervasives.contents belongs to the type 'a ref but is mixed here with labels of type t # type u = private { mutable u : int; } # Characters 0-5: {u=3};; ^^^^^ Error: Cannot create values of the private type u # Characters 11-12: fun x -> x.u <- 3;; ^ Error: Cannot assign field u of the private type u # mingw-ocaml/ocaml/testsuite/tests/typing-misc/Makefile0000644000175000017500000000015212124403241022552 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-misc/constraints.ml0000644000175000017500000000061312124403241024015 0ustar tootstootstype 'a t = [`A of 'a t t] as 'a;; (* fails *) type 'a t = [`A of 'a t t];; (* fails *) type 'a t = [`A of 'a t t] constraint 'a = 'a t;; type 'a t = [`A of 'a t] constraint 'a = 'a t;; type 'a t = [`A of 'a] as 'a;; type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *) type 'a t = 'a;; let f (x : 'a t as 'a) = ();; (* fails *) let f (x : 'a t) (y : 'a) = x = y;; mingw-ocaml/ocaml/testsuite/tests/typing-misc/records.ml0000644000175000017500000000031612124403241023107 0ustar tootstoots(* undefined labels *) type t = {x:int;y:int};; {x=3;z=2};; fun {x=3;z=2} -> ();; (* mixed labels *) {x=3; contents=2};; (* private types *) type u = private {mutable u:int};; {u=3};; fun x -> x.u <- 3;; mingw-ocaml/ocaml/testsuite/tests/typing-misc/constraints.ml.reference0000644000175000017500000000203012124403241025745 0ustar tootstoots # Characters 12-32: type 'a t = [`A of 'a t t] as 'a;; (* fails *) ^^^^^^^^^^^^^^^^^^^^ Error: Constraints are not satisfied in this type. Type [ `A of 'a ] t t as 'a should be an instance of ([ `A of 'b t t ] as 'b) t # Characters 5-27: type 'a t = [`A of 'a t t];; (* fails *) ^^^^^^^^^^^^^^^^^^^^^^ Error: In the definition of t, type 'a t t should be 'a t # type 'a t = [ `A of 'a t t ] constraint 'a = 'a t # type 'a t = [ `A of 'a t ] constraint 'a = 'a t # type 'a t = 'a constraint 'a = [ `A of 'a ] # Characters 47-52: type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *) ^^^^^ Error: The type abbreviation t is cyclic # type 'a t = 'a # Characters 11-21: let f (x : 'a t as 'a) = ();; (* fails *) ^^^^^^^^^^ Error: This alias is bound to type 'a t = 'a but is used as an instance of type 'a The type variable 'a occurs inside 'a # val f : 'a t -> 'a -> bool = # mingw-ocaml/ocaml/testsuite/tests/tool-lexyacc/0000755000175000017500000000000012124403241021254 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/tool-lexyacc/main.reference0000644000175000017500000002520312124403241024062 0ustar tootstoots66 states, 44 actions. open Syntax open Grammar open Scan_aux let rec action_43 lexbuf = ( comment lexbuf ) and action_42 lexbuf = ( raise(Lexical_error "unterminated comment") ) and action_41 lexbuf = ( reset_string_buffer(); string lexbuf; reset_string_buffer(); comment lexbuf ) and action_40 lexbuf = ( decr comment_depth; if !comment_depth = 0 then () else comment lexbuf ) and action_39 lexbuf = ( incr comment_depth; comment lexbuf ) and action_38 lexbuf = ( raise(Lexical_error "bad character constant") ) and action_37 lexbuf = ( char_for_decimal_code lexbuf 1 ) and action_36 lexbuf = ( char_for_backslash (Lexing.lexeme_char lexbuf 1) ) and action_35 lexbuf = ( Lexing.lexeme_char lexbuf 0 ) and action_34 lexbuf = ( store_string_char(Lexing.lexeme_char lexbuf 0); string lexbuf ) and action_33 lexbuf = ( raise(Lexical_error "unterminated string") ) and action_32 lexbuf = ( store_string_char(char_for_decimal_code lexbuf 1); string lexbuf ) and action_31 lexbuf = ( store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); string lexbuf ) and action_30 lexbuf = ( string lexbuf ) and action_29 lexbuf = ( () ) and action_28 lexbuf = ( action lexbuf ) and action_27 lexbuf = ( raise (Lexical_error "unterminated action") ) and action_26 lexbuf = ( comment_depth := 1; comment lexbuf; action lexbuf ) and action_25 lexbuf = ( let _ = char lexbuf in action lexbuf ) and action_24 lexbuf = ( reset_string_buffer(); string lexbuf; reset_string_buffer(); action lexbuf ) and action_23 lexbuf = ( decr brace_depth; if !brace_depth = 0 then Lexing.lexeme_start lexbuf else action lexbuf ) and action_22 lexbuf = ( incr brace_depth; action lexbuf ) and action_21 lexbuf = ( raise(Lexical_error("illegal character " ^ Lexing.lexeme lexbuf)) ) and action_20 lexbuf = ( raise(Lexical_error "unterminated lexer definition") ) and action_19 lexbuf = ( Tdash ) and action_18 lexbuf = ( Tcaret ) and action_17 lexbuf = ( Trparen ) and action_16 lexbuf = ( Tlparen ) and action_15 lexbuf = ( Tplus ) and action_14 lexbuf = ( Tmaybe ) and action_13 lexbuf = ( Tstar ) and action_12 lexbuf = ( Trbracket ) and action_11 lexbuf = ( Tlbracket ) and action_10 lexbuf = ( Teof ) and action_9 lexbuf = ( Tunderscore ) and action_8 lexbuf = ( Tor ) and action_7 lexbuf = ( Tend ) and action_6 lexbuf = ( Tequal ) and action_5 lexbuf = ( let n1 = Lexing.lexeme_end lexbuf in brace_depth := 1; let n2 = action lexbuf in Taction(Location(n1, n2)) ) and action_4 lexbuf = ( Tchar(char lexbuf) ) and action_3 lexbuf = ( reset_string_buffer(); string lexbuf; Tstring(get_stored_string()) ) and action_2 lexbuf = ( match Lexing.lexeme lexbuf with "rule" -> Trule | "parse" -> Tparse | "and" -> Tand | "eof" -> Teof | s -> Tident s ) and action_1 lexbuf = ( comment_depth := 1; comment lexbuf; main lexbuf ) and action_0 lexbuf = ( main lexbuf ) and state_0 lexbuf = match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A' -> state_51 lexbuf | ' '|'\013'|'\n'|'\t' -> state_40 lexbuf | '|' -> action_8 lexbuf | '{' -> action_5 lexbuf | 'e' -> state_56 lexbuf | '_' -> state_55 lexbuf | '^' -> action_18 lexbuf | ']' -> action_12 lexbuf | '[' -> action_11 lexbuf | '?' -> action_14 lexbuf | '=' -> action_6 lexbuf | ';' -> state_48 lexbuf | '-' -> action_19 lexbuf | '+' -> action_15 lexbuf | '*' -> action_13 lexbuf | ')' -> action_17 lexbuf | '(' -> state_43 lexbuf | '\'' -> action_4 lexbuf | '"' -> action_3 lexbuf | '\000' -> action_20 lexbuf | _ -> action_21 lexbuf and state_1 lexbuf = match lexing.next_char lexbuf with '}' -> action_23 lexbuf | '{' -> action_22 lexbuf | '(' -> state_34 lexbuf | '\'' -> action_25 lexbuf | '"' -> action_24 lexbuf | '\000' -> action_27 lexbuf | _ -> action_28 lexbuf and state_2 lexbuf = match lexing.next_char lexbuf with '\\' -> state_24 lexbuf | '"' -> action_29 lexbuf | '\000' -> action_33 lexbuf | _ -> action_34 lexbuf and state_3 lexbuf = match lexing.next_char lexbuf with '\\' -> state_13 lexbuf | '\000' -> lexing.backtrack lexbuf | _ -> state_12 lexbuf and state_4 lexbuf = match lexing.next_char lexbuf with '*' -> state_9 lexbuf | '(' -> state_8 lexbuf | '"' -> action_41 lexbuf | '\000' -> action_42 lexbuf | _ -> action_43 lexbuf and state_8 lexbuf = Lexing.set_backtrack lexbuf action_43; match lexing.next_char lexbuf with '*' -> action_39 lexbuf | _ -> lexing.backtrack lexbuf and state_9 lexbuf = Lexing.set_backtrack lexbuf action_43; match lexing.next_char lexbuf with ')' -> action_40 lexbuf | _ -> lexing.backtrack lexbuf and state_12 lexbuf = Lexing.set_backtrack lexbuf action_38; match lexing.next_char lexbuf with '\'' -> action_35 lexbuf | _ -> lexing.backtrack lexbuf and state_13 lexbuf = Lexing.set_backtrack lexbuf action_38; match lexing.next_char lexbuf with '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_15 lexbuf | 't'|'r'|'n'|'b'|'\\'|'\'' -> state_14 lexbuf | _ -> lexing.backtrack lexbuf and state_14 lexbuf = match lexing.next_char lexbuf with '\'' -> action_36 lexbuf | _ -> lexing.backtrack lexbuf and state_15 lexbuf = match lexing.next_char lexbuf with '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_16 lexbuf | _ -> lexing.backtrack lexbuf and state_16 lexbuf = match lexing.next_char lexbuf with '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_17 lexbuf | _ -> lexing.backtrack lexbuf and state_17 lexbuf = match lexing.next_char lexbuf with '\'' -> action_37 lexbuf | _ -> lexing.backtrack lexbuf and state_24 lexbuf = Lexing.set_backtrack lexbuf action_34; match lexing.next_char lexbuf with '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_27 lexbuf | 't'|'r'|'n'|'b'|'\\'|'"' -> action_31 lexbuf | ' '|'\026'|'\013'|'\012'|'\n'|'\t' -> state_25 lexbuf | _ -> lexing.backtrack lexbuf and state_25 lexbuf = Lexing.set_backtrack lexbuf action_30; match lexing.next_char lexbuf with ' '|'\026'|'\013'|'\012'|'\n'|'\t' -> state_25 lexbuf | _ -> lexing.backtrack lexbuf and state_27 lexbuf = match lexing.next_char lexbuf with '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_28 lexbuf | _ -> lexing.backtrack lexbuf and state_28 lexbuf = match lexing.next_char lexbuf with '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> action_32 lexbuf | _ -> lexing.backtrack lexbuf and state_34 lexbuf = Lexing.set_backtrack lexbuf action_28; match lexing.next_char lexbuf with '*' -> action_26 lexbuf | _ -> lexing.backtrack lexbuf and state_40 lexbuf = Lexing.set_backtrack lexbuf action_0; match lexing.next_char lexbuf with ' '|'\013'|'\n'|'\t' -> state_65 lexbuf | _ -> lexing.backtrack lexbuf and state_43 lexbuf = Lexing.set_backtrack lexbuf action_16; match lexing.next_char lexbuf with '*' -> action_1 lexbuf | _ -> lexing.backtrack lexbuf and state_48 lexbuf = Lexing.set_backtrack lexbuf action_21; match lexing.next_char lexbuf with ';' -> action_7 lexbuf | _ -> lexing.backtrack lexbuf and state_51 lexbuf = Lexing.set_backtrack lexbuf action_2; match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf | '_' -> state_60 lexbuf | _ -> lexing.backtrack lexbuf and state_55 lexbuf = Lexing.set_backtrack lexbuf action_9; match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf | _ -> lexing.backtrack lexbuf and state_56 lexbuf = Lexing.set_backtrack lexbuf action_2; match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf | 'o' -> state_61 lexbuf | '_' -> state_60 lexbuf | _ -> lexing.backtrack lexbuf and state_59 lexbuf = Lexing.set_backtrack lexbuf action_2; match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf | '_' -> state_60 lexbuf | _ -> lexing.backtrack lexbuf and state_60 lexbuf = match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf | _ -> lexing.backtrack lexbuf and state_61 lexbuf = Lexing.set_backtrack lexbuf action_2; match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf | 'f' -> state_62 lexbuf | '_' -> state_60 lexbuf | _ -> lexing.backtrack lexbuf and state_62 lexbuf = Lexing.set_backtrack lexbuf action_2; match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf | '_' -> state_60 lexbuf | _ -> lexing.backtrack lexbuf and state_65 lexbuf = Lexing.set_backtrack lexbuf action_0; match lexing.next_char lexbuf with ' '|'\013'|'\n'|'\t' -> state_65 lexbuf | _ -> lexing.backtrack lexbuf and main lexbuf = Lexing.init lexbuf; state_0 lexbuf and action lexbuf = Lexing.init lexbuf; state_1 lexbuf and string lexbuf = Lexing.init lexbuf; state_2 lexbuf and char lexbuf = Lexing.init lexbuf; state_3 lexbuf and comment lexbuf = Lexing.init lexbuf; state_4 lexbuf mingw-ocaml/ocaml/testsuite/tests/tool-lexyacc/input.ml0000644000175000017500000002515412124403241022754 0ustar tootstoots open Syntax open Grammar open Scan_aux let rec action_43 lexbuf = ( comment lexbuf ) and action_42 lexbuf = ( raise(Lexical_error "unterminated comment") ) and action_41 lexbuf = ( reset_string_buffer(); string lexbuf; reset_string_buffer(); comment lexbuf ) and action_40 lexbuf = ( decr comment_depth; if !comment_depth = 0 then () else comment lexbuf ) and action_39 lexbuf = ( incr comment_depth; comment lexbuf ) and action_38 lexbuf = ( raise(Lexical_error "bad character constant") ) and action_37 lexbuf = ( char_for_decimal_code lexbuf 1 ) and action_36 lexbuf = ( char_for_backslash (Lexing.lexeme_char lexbuf 1) ) and action_35 lexbuf = ( Lexing.lexeme_char lexbuf 0 ) and action_34 lexbuf = ( store_string_char(Lexing.lexeme_char lexbuf 0); string lexbuf ) and action_33 lexbuf = ( raise(Lexical_error "unterminated string") ) and action_32 lexbuf = ( store_string_char(char_for_decimal_code lexbuf 1); string lexbuf ) and action_31 lexbuf = ( store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); string lexbuf ) and action_30 lexbuf = ( string lexbuf ) and action_29 lexbuf = ( () ) and action_28 lexbuf = ( action lexbuf ) and action_27 lexbuf = ( raise (Lexical_error "unterminated action") ) and action_26 lexbuf = ( comment_depth := 1; comment lexbuf; action lexbuf ) and action_25 lexbuf = ( let _ = char lexbuf in action lexbuf ) and action_24 lexbuf = ( reset_string_buffer(); string lexbuf; reset_string_buffer(); action lexbuf ) and action_23 lexbuf = ( decr brace_depth; if !brace_depth = 0 then Lexing.lexeme_start lexbuf else action lexbuf ) and action_22 lexbuf = ( incr brace_depth; action lexbuf ) and action_21 lexbuf = ( raise(Lexical_error("illegal character " ^ Lexing.lexeme lexbuf)) ) and action_20 lexbuf = ( raise(Lexical_error "unterminated lexer definition") ) and action_19 lexbuf = ( Tdash ) and action_18 lexbuf = ( Tcaret ) and action_17 lexbuf = ( Trparen ) and action_16 lexbuf = ( Tlparen ) and action_15 lexbuf = ( Tplus ) and action_14 lexbuf = ( Tmaybe ) and action_13 lexbuf = ( Tstar ) and action_12 lexbuf = ( Trbracket ) and action_11 lexbuf = ( Tlbracket ) and action_10 lexbuf = ( Teof ) and action_9 lexbuf = ( Tunderscore ) and action_8 lexbuf = ( Tor ) and action_7 lexbuf = ( Tend ) and action_6 lexbuf = ( Tequal ) and action_5 lexbuf = ( let n1 = Lexing.lexeme_end lexbuf in brace_depth := 1; let n2 = action lexbuf in Taction(Location(n1, n2)) ) and action_4 lexbuf = ( Tchar(char lexbuf) ) and action_3 lexbuf = ( reset_string_buffer(); string lexbuf; Tstring(get_stored_string()) ) and action_2 lexbuf = ( match Lexing.lexeme lexbuf with "rule" -> Trule | "parse" -> Tparse | "and" -> Tand | "eof" -> Teof | s -> Tident s ) and action_1 lexbuf = ( comment_depth := 1; comment lexbuf; main lexbuf ) and action_0 lexbuf = ( main lexbuf ) and state_0 lexbuf = match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A' -> state_51 lexbuf | ' '|'\013'|'\n'|'\t' -> state_40 lexbuf | '|' -> action_8 lexbuf | '{' -> action_5 lexbuf | 'e' -> state_56 lexbuf | '_' -> state_55 lexbuf | '^' -> action_18 lexbuf | ']' -> action_12 lexbuf | '[' -> action_11 lexbuf | '?' -> action_14 lexbuf | '=' -> action_6 lexbuf | ';' -> state_48 lexbuf | '-' -> action_19 lexbuf | '+' -> action_15 lexbuf | '*' -> action_13 lexbuf | ')' -> action_17 lexbuf | '(' -> state_43 lexbuf | '\'' -> action_4 lexbuf | '"' -> action_3 lexbuf | '\000' -> action_20 lexbuf | _ -> action_21 lexbuf and state_1 lexbuf = match lexing.next_char lexbuf with '}' -> action_23 lexbuf | '{' -> action_22 lexbuf | '(' -> state_34 lexbuf | '\'' -> action_25 lexbuf | '"' -> action_24 lexbuf | '\000' -> action_27 lexbuf | _ -> action_28 lexbuf and state_2 lexbuf = match lexing.next_char lexbuf with '\\' -> state_24 lexbuf | '"' -> action_29 lexbuf | '\000' -> action_33 lexbuf | _ -> action_34 lexbuf and state_3 lexbuf = match lexing.next_char lexbuf with '\\' -> state_13 lexbuf | '\000' -> lexing.backtrack lexbuf | _ -> state_12 lexbuf and state_4 lexbuf = match lexing.next_char lexbuf with '*' -> state_9 lexbuf | '(' -> state_8 lexbuf | '"' -> action_41 lexbuf | '\000' -> action_42 lexbuf | _ -> action_43 lexbuf and state_8 lexbuf = Lexing.set_backtrack lexbuf action_43; match lexing.next_char lexbuf with '*' -> action_39 lexbuf | _ -> lexing.backtrack lexbuf and state_9 lexbuf = Lexing.set_backtrack lexbuf action_43; match lexing.next_char lexbuf with ')' -> action_40 lexbuf | _ -> lexing.backtrack lexbuf and state_12 lexbuf = Lexing.set_backtrack lexbuf action_38; match lexing.next_char lexbuf with '\'' -> action_35 lexbuf | _ -> lexing.backtrack lexbuf and state_13 lexbuf = Lexing.set_backtrack lexbuf action_38; match lexing.next_char lexbuf with '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_15 lexbuf | 't'|'r'|'n'|'b'|'\\'|'\'' -> state_14 lexbuf | _ -> lexing.backtrack lexbuf and state_14 lexbuf = match lexing.next_char lexbuf with '\'' -> action_36 lexbuf | _ -> lexing.backtrack lexbuf and state_15 lexbuf = match lexing.next_char lexbuf with '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_16 lexbuf | _ -> lexing.backtrack lexbuf and state_16 lexbuf = match lexing.next_char lexbuf with '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_17 lexbuf | _ -> lexing.backtrack lexbuf and state_17 lexbuf = match lexing.next_char lexbuf with '\'' -> action_37 lexbuf | _ -> lexing.backtrack lexbuf and state_24 lexbuf = Lexing.set_backtrack lexbuf action_34; match lexing.next_char lexbuf with '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_27 lexbuf | 't'|'r'|'n'|'b'|'\\'|'"' -> action_31 lexbuf | ' '|'\026'|'\013'|'\012'|'\n'|'\t' -> state_25 lexbuf | _ -> lexing.backtrack lexbuf and state_25 lexbuf = Lexing.set_backtrack lexbuf action_30; match lexing.next_char lexbuf with ' '|'\026'|'\013'|'\012'|'\n'|'\t' -> state_25 lexbuf | _ -> lexing.backtrack lexbuf and state_27 lexbuf = match lexing.next_char lexbuf with '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> state_28 lexbuf | _ -> lexing.backtrack lexbuf and state_28 lexbuf = match lexing.next_char lexbuf with '9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0' -> action_32 lexbuf | _ -> lexing.backtrack lexbuf and state_34 lexbuf = Lexing.set_backtrack lexbuf action_28; match lexing.next_char lexbuf with '*' -> action_26 lexbuf | _ -> lexing.backtrack lexbuf and state_40 lexbuf = Lexing.set_backtrack lexbuf action_0; match lexing.next_char lexbuf with ' '|'\013'|'\n'|'\t' -> state_65 lexbuf | _ -> lexing.backtrack lexbuf and state_43 lexbuf = Lexing.set_backtrack lexbuf action_16; match lexing.next_char lexbuf with '*' -> action_1 lexbuf | _ -> lexing.backtrack lexbuf and state_48 lexbuf = Lexing.set_backtrack lexbuf action_21; match lexing.next_char lexbuf with ';' -> action_7 lexbuf | _ -> lexing.backtrack lexbuf and state_51 lexbuf = Lexing.set_backtrack lexbuf action_2; match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf | '_' -> state_60 lexbuf | _ -> lexing.backtrack lexbuf and state_55 lexbuf = Lexing.set_backtrack lexbuf action_9; match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf | _ -> lexing.backtrack lexbuf and state_56 lexbuf = Lexing.set_backtrack lexbuf action_2; match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf | 'o' -> state_61 lexbuf | '_' -> state_60 lexbuf | _ -> lexing.backtrack lexbuf and state_59 lexbuf = Lexing.set_backtrack lexbuf action_2; match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf | '_' -> state_60 lexbuf | _ -> lexing.backtrack lexbuf and state_60 lexbuf = match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf | _ -> lexing.backtrack lexbuf and state_61 lexbuf = Lexing.set_backtrack lexbuf action_2; match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf | 'f' -> state_62 lexbuf | '_' -> state_60 lexbuf | _ -> lexing.backtrack lexbuf and state_62 lexbuf = Lexing.set_backtrack lexbuf action_2; match lexing.next_char lexbuf with 'z'|'y'|'x'|'w'|'v'|'u'|'t'|'s'|'r'|'q'|'p'|'o'|'n'|'m'|'l'|'k'|'j'|'i'|'h'|'g'|'f'|'e'|'d'|'c'|'b'|'a'|'Z'|'Y'|'X'|'W'|'V'|'U'|'T'|'S'|'R'|'Q'|'P'|'O'|'N'|'M'|'L'|'K'|'J'|'I'|'H'|'G'|'F'|'E'|'D'|'C'|'B'|'A'|'9'|'8'|'7'|'6'|'5'|'4'|'3'|'2'|'1'|'0'|'\'' -> state_59 lexbuf | '_' -> state_60 lexbuf | _ -> lexing.backtrack lexbuf and state_65 lexbuf = Lexing.set_backtrack lexbuf action_0; match lexing.next_char lexbuf with ' '|'\013'|'\n'|'\t' -> state_65 lexbuf | _ -> lexing.backtrack lexbuf and main lexbuf = Lexing.init lexbuf; state_0 lexbuf and action lexbuf = Lexing.init lexbuf; state_1 lexbuf and string lexbuf = Lexing.init lexbuf; state_2 lexbuf and char lexbuf = Lexing.init lexbuf; state_3 lexbuf and comment lexbuf = Lexing.init lexbuf; state_4 lexbuf mingw-ocaml/ocaml/testsuite/tests/tool-lexyacc/.ignore0000644000175000017500000000004212124403241022534 0ustar tootstootsscanner.ml grammar.mli grammar.ml mingw-ocaml/ocaml/testsuite/tests/tool-lexyacc/gram_aux.ml0000644000175000017500000000264012124403241023413 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Auxiliaries for the parser. *) open Syntax let regexp_for_string s = let l = String.length s in if l = 0 then Epsilon else begin let re = ref(Characters [String.get s (l - 1)]) in for i = l - 2 downto 0 do re := Sequence(Characters [String.get s i], !re) done; !re end let char_class c1 c2 = let cl = ref [] in for i = Char.code c2 downto Char.code c1 do cl := Char.chr i :: !cl done; !cl let all_chars = char_class '\001' '\255' let rec subtract l1 l2 = match l1 with [] -> [] | a::l -> if List.mem a l2 then subtract l l2 else a :: subtract l l2 mingw-ocaml/ocaml/testsuite/tests/tool-lexyacc/grammar.mly0000644000175000017500000000507612124403241023435 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* $Id$ */ /* The grammar for lexer definitions */ %{ open Syntax open Gram_aux %} %token Tident %token Tchar %token Tstring %token Taction %token Trule Tparse Tand Tequal Tend Tor Tunderscore Teof Tlbracket Trbracket %token Tstar Tmaybe Tplus Tlparen Trparen Tcaret Tdash %left Tor %left CONCAT %nonassoc Tmaybe %left Tstar %left Tplus %start lexer_definition %type lexer_definition %% lexer_definition: header Trule definition other_definitions Tend { Lexdef($1, $3::(List.rev $4)) } ; header: Taction { $1 } | { Location(0,0) } ; other_definitions: other_definitions Tand definition { $3::$1 } | { [] } ; definition: Tident Tequal entry { ($1,$3) } ; entry: Tparse case rest_of_entry { $2 :: List.rev $3 } ; rest_of_entry: rest_of_entry Tor case { $3::$1 } | { [] } ; case: regexp Taction { ($1,$2) } ; regexp: Tunderscore { Characters all_chars } | Teof { Characters ['\000'] } | Tchar { Characters [$1] } | Tstring { regexp_for_string $1 } | Tlbracket char_class Trbracket { Characters $2 } | regexp Tstar { Repetition $1 } | regexp Tmaybe { Alternative($1, Epsilon) } | regexp Tplus { Sequence($1, Repetition $1) } | regexp Tor regexp { Alternative($1,$3) } | regexp regexp %prec CONCAT { Sequence($1,$2) } | Tlparen regexp Trparen { $2 } ; char_class: Tcaret char_class1 { subtract all_chars $2 } | char_class1 { $1 } ; char_class1: Tchar Tdash Tchar { char_class $1 $3 } | Tchar { [$1] } | char_class char_class %prec CONCAT { $1 @ $2 } ; %% mingw-ocaml/ocaml/testsuite/tests/tool-lexyacc/Makefile0000644000175000017500000000040212124403241022710 0ustar tootstootsBASEDIR=../.. MODULES=syntax gram_aux grammar scan_aux scanner lexgen output MAIN_MODULE=main LEX_MODULES=scanner YACC_MODULES=grammar ADD_COMPFLAGS=-w a EXEC_ARGS=input include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/tool-lexyacc/syntax.ml0000644000175000017500000000265512124403241023144 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* The shallow abstract syntax *) type location = Location of int * int type regular_expression = Epsilon | Characters of char list | Sequence of regular_expression * regular_expression | Alternative of regular_expression * regular_expression | Repetition of regular_expression type lexer_definition = Lexdef of location * (string * (regular_expression * location) list) list (* Representation of automata *) type automata = Perform of int | Shift of automata_trans * automata_move array and automata_trans = No_remember | Remember of int and automata_move = Backtrack | Goto of int mingw-ocaml/ocaml/testsuite/tests/tool-lexyacc/main.ml0000644000175000017500000000725112124403241022537 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* The lexer generator. Command-line parsing. *) open Syntax open Scanner open Grammar open Lexgen open Output let main () = if Array.length Sys.argv <> 2 then begin prerr_string "Usage: camllex \n"; exit 2 end; let source_name = Sys.argv.(1) in let dest_name = if Filename.check_suffix source_name ".mll" then Filename.chop_suffix source_name ".mll" ^ ".ml" else source_name ^ ".ml" in ic := open_in source_name; (* oc := open_out dest_name; *) ignore dest_name; oc := stdout; let lexbuf = Lexing.from_channel !ic in let (Lexdef(header,_) as def) = try Grammar.lexer_definition Scanner.main lexbuf with Parsing.Parse_error -> prerr_string "Syntax error around char "; prerr_int (Lexing.lexeme_start lexbuf); prerr_endline "."; exit 2 | Scan_aux.Lexical_error s -> prerr_string "Lexical error around char "; prerr_int (Lexing.lexeme_start lexbuf); prerr_string ": "; prerr_string s; prerr_endline "."; exit 2 in let ((init, states, acts) as dfa) = make_dfa def in output_lexdef header dfa; close_in !ic; close_out !oc let _ = main(); exit 0 (***** let main () = ic := stdin; oc := stdout; let lexbuf = lexing.from_channel ic in let (Lexdef(header,_) as def) = try grammar.lexer_definition scanner.main lexbuf with parsing.Parse_error x -> prerr_string "Syntax error around char "; prerr_int (lexing.lexeme_start lexbuf); prerr_endline "."; sys.exit 2 | scan_aux.Lexical_error s -> prerr_string "Lexical error around char "; prerr_int (lexing.lexeme_start lexbuf); prerr_string ": "; prerr_string s; prerr_endline "."; sys.exit 2 in let ((init, states, acts) as dfa) = make_dfa def in output_lexdef header dfa ****) (**** let debug_scanner lexbuf = let tok = scanner.main lexbuf in begin match tok with Tident s -> prerr_string "Tident "; prerr_string s | Tchar c -> prerr_string "Tchar "; prerr_char c | Tstring s -> prerr_string "Tstring "; prerr_string s | Taction(Location(i1,i2)) -> prerr_string "Taction "; prerr_int i1; prerr_string "-"; prerr_int i2 | Trule -> prerr_string "Trule" | Tparse -> prerr_string "Tparse" | Tand -> prerr_string "Tand" | Tequal -> prerr_string "Tequal" | Tend -> prerr_string "Tend" | Tor -> prerr_string "Tor" | Tunderscore -> prerr_string "Tunderscore" | Teof -> prerr_string "Teof" | Tlbracket -> prerr_string "Tlbracket" | Trbracket -> prerr_string "Trbracket" | Tstar -> prerr_string "Tstar" | Tmaybe -> prerr_string "Tmaybe" | Tplus -> prerr_string "Tplus" | Tlparen -> prerr_string "Tlparen" | Trparen -> prerr_string "Trparen" | Tcaret -> prerr_string "Tcaret" | Tdash -> prerr_string "Tdash" end; prerr_newline(); tok ****) mingw-ocaml/ocaml/testsuite/tests/tool-lexyacc/scan_aux.ml0000644000175000017500000000402512124403241023410 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Auxiliaries for the lexical analyzer *) let brace_depth = ref 0 let comment_depth = ref 0 exception Lexical_error of string let initial_string_buffer = String.create 256 let string_buff = ref initial_string_buffer let string_index = ref 0 let reset_string_buffer () = string_buff := initial_string_buffer; string_index := 0 let store_string_char c = begin if !string_index >= String.length !string_buff then begin let new_buff = String.create (String.length !string_buff * 2) in String.blit new_buff 0 !string_buff 0 (String.length !string_buff); string_buff := new_buff end end; String.unsafe_set !string_buff !string_index c; incr string_index let get_stored_string () = let s = String.sub !string_buff 0 !string_index in string_buff := initial_string_buffer; s let char_for_backslash = function 'n' -> '\010' (* '\n' when bootstrapped *) | 't' -> '\009' (* '\t' *) | 'b' -> '\008' (* '\b' *) | 'r' -> '\013' (* '\r' *) | c -> c let char_for_decimal_code lexbuf i = Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48)) mingw-ocaml/ocaml/testsuite/tests/tool-lexyacc/input0000644000175000017500000000724212124403241022343 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* The lexical analyzer for lexer definitions. *) { open Syntax open Grammar open Scan_aux } rule main = parse [' ' '\010' '\013' '\009' ] + { main lexbuf } | "(*" { comment_depth := 1; comment lexbuf; main lexbuf } | (['A'-'Z' 'a'-'z'] | '_' ['A'-'Z' 'a'-'z' '\'' '0'-'9']) ( '_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9'] ) * { match Lexing.lexeme lexbuf with "rule" -> Trule | "parse" -> Tparse | "and" -> Tand | "eof" -> Teof | s -> Tident s } | '"' { reset_string_buffer(); string lexbuf; Tstring(get_stored_string()) } | "'" { Tchar(char lexbuf) } | '{' { let n1 = Lexing.lexeme_end lexbuf in brace_depth := 1; let n2 = action lexbuf in Taction(Location(n1, n2)) } | '=' { Tequal } | ";;" { Tend } | '|' { Tor } | '_' { Tunderscore } | "eof" { Teof } | '[' { Tlbracket } | ']' { Trbracket } | '*' { Tstar } | '?' { Tmaybe } | '+' { Tplus } | '(' { Tlparen } | ')' { Trparen } | '^' { Tcaret } | '-' { Tdash } | eof { raise(Lexical_error "unterminated lexer definition") } | _ { raise(Lexical_error("illegal character " ^ Lexing.lexeme lexbuf)) } and action = parse '{' { incr brace_depth; action lexbuf } | '}' { decr brace_depth; if !brace_depth = 0 then Lexing.lexeme_start lexbuf else action lexbuf } | '"' { reset_string_buffer(); string lexbuf; reset_string_buffer(); action lexbuf } | '\'' { let _ = char lexbuf in action lexbuf } | "(*" { comment_depth := 1; comment lexbuf; action lexbuf } | eof { raise (Lexical_error "unterminated action") } | _ { action lexbuf } and string = parse '"' { () } | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] + { string lexbuf } | '\\' ['\\' '"' 'n' 't' 'b' 'r'] { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); string lexbuf } | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_string_char(char_for_decimal_code lexbuf 1); string lexbuf } | eof { raise(Lexical_error "unterminated string") } | _ { store_string_char(Lexing.lexeme_char lexbuf 0); string lexbuf } and char = parse [^ '\\'] "'" { Lexing.lexeme_char lexbuf 0 } | '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" { char_for_backslash (Lexing.lexeme_char lexbuf 1) } | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { char_for_decimal_code lexbuf 1 } | _ { raise(Lexical_error "bad character constant") } and comment = parse "(*" { incr comment_depth; comment lexbuf } | "*)" { decr comment_depth; if !comment_depth = 0 then () else comment lexbuf } | '"' { reset_string_buffer(); string lexbuf; reset_string_buffer(); comment lexbuf } | eof { raise(Lexical_error "unterminated comment") } | _ { comment lexbuf } ;; mingw-ocaml/ocaml/testsuite/tests/tool-lexyacc/lexgen.ml0000644000175000017500000001723212124403241023075 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Compiling a lexer definition *) open Syntax (* Deep abstract syntax for regular expressions *) type regexp = Empty | Chars of int | Action of int | Seq of regexp * regexp | Alt of regexp * regexp | Star of regexp (* From shallow to deep syntax *) (*** let print_char_class c = let print_interval low high = prerr_int low; if high - 1 > low then begin prerr_char '-'; prerr_int (high-1) end; prerr_char ' ' in let rec print_class first next = function [] -> print_interval first next | c::l -> if char.code c = next then print_class first (next+1) l else begin print_interval first next; print_class (char.code c) (char.code c + 1) l end in match c with [] -> prerr_newline() | c::l -> print_class (char.code c) (char.code c + 1) l; prerr_newline() let rec print_regexp = function Empty -> prerr_string "Empty" | Chars n -> prerr_string "Chars "; prerr_int n | Action n -> prerr_string "Action "; prerr_int n | Seq(r1,r2) -> print_regexp r1; prerr_string "; "; print_regexp r2 | Alt(r1,r2) -> prerr_string "("; print_regexp r1; prerr_string " | "; print_regexp r2; prerr_string ")" | Star r -> prerr_string "("; print_regexp r; prerr_string ")*" ***) let chars = ref ([] : char list list) let chars_count = ref 0 let actions = ref ([] : (int * location) list) let actions_count = ref 0 let rec encode_regexp = function Epsilon -> Empty | Characters cl -> let n = !chars_count in (*** prerr_int n; prerr_char ' '; print_char_class cl; ***) chars := cl :: !chars; chars_count := !chars_count + 1; Chars(n) | Sequence(r1,r2) -> Seq(encode_regexp r1, encode_regexp r2) | Alternative(r1,r2) -> Alt(encode_regexp r1, encode_regexp r2) | Repetition r -> Star (encode_regexp r) let encode_casedef = List.fold_left (fun reg (expr,act) -> let act_num = !actions_count in actions_count := !actions_count + 1; actions := (act_num, act) :: !actions; Alt(reg, Seq(encode_regexp expr, Action act_num))) Empty let encode_lexdef (Lexdef(_, ld)) = chars := []; chars_count := 0; actions := []; actions_count := 0; let name_regexp_list = List.map (fun (name, casedef) -> (name, encode_casedef casedef)) ld in (* List.iter print_char_class chars; *) let chr = Array.of_list (List.rev !chars) and act = !actions in chars := []; actions := []; (chr, name_regexp_list, act) (* To generate directly a NFA from a regular expression. Confer Aho-Sethi-Ullman, dragon book, chap. 3 *) type transition = OnChars of int | ToAction of int let rec merge_trans l1 l2 = match (l1, l2) with ([], s2) -> s2 | (s1, []) -> s1 | ((OnChars n1 as t1) :: r1 as s1), ((OnChars n2 as t2) :: r2 as s2) -> if n1 = n2 then t1 :: merge_trans r1 r2 else if n1 < n2 then t1 :: merge_trans r1 s2 else t2 :: merge_trans s1 r2 | ((ToAction n1 as t1) :: r1 as s1), ((ToAction n2 as t2) :: r2 as s2) -> if n1 = n2 then t1 :: merge_trans r1 r2 else if n1 < n2 then t1 :: merge_trans r1 s2 else t2 :: merge_trans s1 r2 | ((OnChars n1 as t1) :: r1), ((ToAction n2) :: r2 as s2) -> t1 :: merge_trans r1 s2 | ((ToAction n1) :: r1 as s1), ((OnChars n2 as t2) :: r2) -> t2 :: merge_trans s1 r2 let rec nullable = function Empty -> true | Chars _ -> false | Action _ -> false | Seq(r1,r2) -> nullable r1 && nullable r2 | Alt(r1,r2) -> nullable r1 || nullable r2 | Star r -> true let rec firstpos = function Empty -> [] | Chars pos -> [OnChars pos] | Action act -> [ToAction act] | Seq(r1,r2) -> if nullable r1 then merge_trans (firstpos r1) (firstpos r2) else firstpos r1 | Alt(r1,r2) -> merge_trans (firstpos r1) (firstpos r2) | Star r -> firstpos r let rec lastpos = function Empty -> [] | Chars pos -> [OnChars pos] | Action act -> [ToAction act] | Seq(r1,r2) -> if nullable r2 then merge_trans (lastpos r1) (lastpos r2) else lastpos r2 | Alt(r1,r2) -> merge_trans (lastpos r1) (lastpos r2) | Star r -> lastpos r let followpos size name_regexp_list = let v = Array.create size [] in let fill_pos first = function OnChars pos -> v.(pos) <- merge_trans first v.(pos); () | ToAction _ -> () in let rec fill = function Seq(r1,r2) -> fill r1; fill r2; List.iter (fill_pos (firstpos r2)) (lastpos r1) | Alt(r1,r2) -> fill r1; fill r2 | Star r -> fill r; List.iter (fill_pos (firstpos r)) (lastpos r) | _ -> () in List.iter (fun (name, regexp) -> fill regexp) name_regexp_list; v let no_action = 0x3FFFFFFF let split_trans_set = List.fold_left (fun (act, pos_set as act_pos_set) trans -> match trans with OnChars pos -> (act, pos :: pos_set) | ToAction act1 -> if act1 < act then (act1, pos_set) else act_pos_set) (no_action, []) let memory = (Hashtbl.create 131 : (transition list, int) Hashtbl.t) let todo = ref ([] : (transition list * int) list) let next = ref 0 let get_state st = try Hashtbl.find memory st with Not_found -> let nbr = !next in next := !next + 1; Hashtbl.add memory st nbr; todo := (st, nbr) :: !todo; nbr let rec map_on_states f = match !todo with [] -> [] | (st,i)::r -> todo := r; let res = f st in (res,i) :: map_on_states f let number_of_states () = !next let goto_state = function [] -> Backtrack | ps -> Goto (get_state ps) let transition_from chars follow pos_set = let tr = Array.create 256 [] and shift = Array.create 256 Backtrack in List.iter (fun pos -> List.iter (fun c -> tr.(Char.code c) <- merge_trans tr.(Char.code c) follow.(pos)) chars.(pos)) pos_set; for i = 0 to 255 do shift.(i) <- goto_state tr.(i) done; shift let translate_state chars follow state = match split_trans_set state with n, [] -> Perform n | n, ps -> Shift( (if n = no_action then No_remember else Remember n), transition_from chars follow ps) let make_dfa lexdef = let (chars, name_regexp_list, actions) = encode_lexdef lexdef in (** List.iter (fun (name, regexp) -> prerr_string name; prerr_string " = "; print_regexp regexp; prerr_newline()) name_regexp_list; **) let follow = followpos (Array.length chars) name_regexp_list in let initial_states = List.map (fun (name, regexp) -> (name, get_state(firstpos regexp))) name_regexp_list in let states = map_on_states (translate_state chars follow) in let v = Array.create (number_of_states()) (Perform 0) in List.iter (fun (auto, i) -> v.(i) <- auto) states; (initial_states, v, actions) mingw-ocaml/ocaml/testsuite/tests/tool-lexyacc/output.ml0000644000175000017500000001160312124403241023147 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Generating a DFA as a set of mutually recursive functions *) open Syntax let ic = ref stdin let oc = ref stdout (* 1- Generating the actions *) let copy_buffer = String.create 1024 let copy_chunk (Location(start,stop)) = seek_in !ic start; let tocopy = ref(stop - start) in while !tocopy > 0 do let m = input !ic copy_buffer 0 (min !tocopy (String.length copy_buffer)) in output !oc copy_buffer 0 m; tocopy := !tocopy - m done let output_action (i,act) = output_string !oc ("action_" ^ string_of_int i ^ " lexbuf = (\n"); copy_chunk act; output_string !oc ")\nand " (* 2- Generating the states *) let states = ref ([||] : automata array) type occurrence = { mutable pos: int list; mutable freq: int } let enumerate_vect v = let env = ref [] in for pos = 0 to Array.length v - 1 do try let occ = List.assoc v.(pos) !env in occ.pos <- pos :: occ.pos; occ.freq <- occ.freq + 1 with Not_found -> env := (v.(pos), {pos = [pos]; freq = 1 }) :: !env done; Sort.list (fun (e1, occ1) (e2, occ2) -> occ1.freq >= occ2.freq) !env let output_move = function Backtrack -> output_string !oc "lexing.backtrack lexbuf" | Goto dest -> match !states.(dest) with Perform act_num -> output_string !oc ("action_" ^ string_of_int act_num ^ " lexbuf") | _ -> output_string !oc ("state_" ^ string_of_int dest ^ " lexbuf") (* Cannot use standard char_for_read because the characters to escape are not the same in CL6 and CL1999. *) let output_char_lit oc = function '\'' -> output_string oc "\\'" | '\\' -> output_string oc "\\\\" | '\n' -> output_string oc "\\n" | '\t' -> output_string oc "\\t" | c -> if Char.code c >= 32 && Char.code c < 128 then output_char oc c else begin let n = Char.code c in output_char oc '\\'; output_char oc (Char.chr (48 + n / 100)); output_char oc (Char.chr (48 + (n / 10) mod 10)); output_char oc (Char.chr (48 + n mod 10)) end let rec output_chars = function [] -> failwith "output_chars" | [c] -> output_string !oc "'"; output_char_lit !oc (Char.chr c); output_string !oc "'" | c::cl -> output_string !oc "'"; output_char_lit !oc (Char.chr c); output_string !oc "'|"; output_chars cl let output_one_trans (dest, occ) = output_chars occ.pos; output_string !oc " -> "; output_move dest; output_string !oc "\n | " let output_all_trans trans = output_string !oc " match lexing.next_char lexbuf with\n "; match enumerate_vect trans with [] -> failwith "output_all_trans" | (default, _) :: rest -> List.iter output_one_trans rest; output_string !oc "_ -> "; output_move default; output_string !oc "\nand " let output_state state_num = function Perform i -> () | Shift(what_to_do, moves) -> output_string !oc ("state_" ^ string_of_int state_num ^ " lexbuf =\n"); begin match what_to_do with No_remember -> () | Remember i -> output_string !oc (" Lexing.set_backtrack lexbuf action_" ^ string_of_int i ^ ";\n") end; output_all_trans moves (* 3- Generating the entry points *) let rec output_entries = function [] -> failwith "output_entries" | (name,state_num) :: rest -> output_string !oc (name ^ " lexbuf =\n"); output_string !oc " Lexing.init lexbuf;\n"; output_string !oc (" state_" ^ string_of_int state_num ^ " lexbuf\n"); match rest with [] -> () | _ -> output_string !oc "\nand "; output_entries rest (* All together *) let output_lexdef header (initial_st, st, actions) = print_int (Array.length st); print_string " states, "; print_int (List.length actions); print_string " actions."; print_newline(); copy_chunk header; output_string !oc "\nlet rec "; states := st; List.iter output_action actions; for i = 0 to Array.length st - 1 do output_state i st.(i) done; output_entries initial_st mingw-ocaml/ocaml/testsuite/tests/tool-lexyacc/scanner.mll0000644000175000017500000000723712124403241023424 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* The lexical analyzer for lexer definitions. *) { open Syntax open Grammar open Scan_aux } rule main = parse [' ' '\010' '\013' '\009' ] + { main lexbuf } | "(*" { comment_depth := 1; comment lexbuf; main lexbuf } | (['A'-'Z' 'a'-'z'] | '_' ['A'-'Z' 'a'-'z' '\'' '0'-'9']) ( '_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9'] ) * { match Lexing.lexeme lexbuf with "rule" -> Trule | "parse" -> Tparse | "and" -> Tand | "eof" -> Teof | s -> Tident s } | '"' { reset_string_buffer(); string lexbuf; Tstring(get_stored_string()) } | "'" { Tchar(char lexbuf) } | '{' { let n1 = Lexing.lexeme_end lexbuf in brace_depth := 1; let n2 = action lexbuf in Taction(Location(n1, n2)) } | '=' { Tequal } | ";;" { Tend } | '|' { Tor } | '_' { Tunderscore } | "eof" { Teof } | '[' { Tlbracket } | ']' { Trbracket } | '*' { Tstar } | '?' { Tmaybe } | '+' { Tplus } | '(' { Tlparen } | ')' { Trparen } | '^' { Tcaret } | '-' { Tdash } | eof { raise(Lexical_error "unterminated lexer definition") } | _ { raise(Lexical_error("illegal character " ^ Lexing.lexeme lexbuf)) } and action = parse '{' { incr brace_depth; action lexbuf } | '}' { decr brace_depth; if !brace_depth = 0 then Lexing.lexeme_start lexbuf else action lexbuf } | '"' { reset_string_buffer(); string lexbuf; reset_string_buffer(); action lexbuf } | '\'' { let _ = char lexbuf in action lexbuf } | "(*" { comment_depth := 1; comment lexbuf; action lexbuf } | eof { raise (Lexical_error "unterminated action") } | _ { action lexbuf } and string = parse '"' { () } | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] + { string lexbuf } | '\\' ['\\' '"' 'n' 't' 'b' 'r'] { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); string lexbuf } | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_string_char(char_for_decimal_code lexbuf 1); string lexbuf } | eof { raise(Lexical_error "unterminated string") } | _ { store_string_char(Lexing.lexeme_char lexbuf 0); string lexbuf } and char = parse [^ '\\'] "'" { Lexing.lexeme_char lexbuf 0 } | '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" { char_for_backslash (Lexing.lexeme_char lexbuf 1) } | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { char_for_decimal_code lexbuf 1 } | _ { raise(Lexical_error "bad character constant") } and comment = parse "(*" { incr comment_depth; comment lexbuf } | "*)" { decr comment_depth; if !comment_depth = 0 then () else comment lexbuf } | '"' { reset_string_buffer(); string lexbuf; reset_string_buffer(); comment lexbuf } | eof { raise(Lexical_error "unterminated comment") } | _ { comment lexbuf } mingw-ocaml/ocaml/testsuite/tests/runtime-errors/0000755000175000017500000000000012124403241021646 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference0000644000175000017500000000006012124403241030210 0ustar tootstootsx = 20000 x = 10000 x = 0 Stack overflow caught mingw-ocaml/ocaml/testsuite/tests/runtime-errors/.ignore0000644000175000017500000000001312124403241023124 0ustar tootstoots*.bytecode mingw-ocaml/ocaml/testsuite/tests/runtime-errors/Makefile0000644000175000017500000000215112124403241023305 0ustar tootstootsBASEDIR=../.. default: compile run compile: @for f in *.ml; do \ $(OCAMLC) -w a -o `basename $$f ml`bytecode $$f; \ test -z "$(BYTECODE_ONLY)" && $(OCAMLOPT) -w a -o `basename $$f ml`native $$f || true; \ done @if [ ! `grep -c HAS_STACK_OVERFLOW_DETECTION ../../../config/s.h` ]; then \ test -z "$(BYTECODE_ONLY)" && rm -f stackoverflow.byte stackoverflow.native || true; \ fi run: @ulimit -s 1024; \ for f in *.bytecode; do \ printf " ... testing '$$f':"; \ (./$$f > $$f.result 2>&1; true); \ $(DIFF) $$f.reference $$f.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \ if [ -z "$(BYTECODE_ONLY)" ]; then \ printf " ... testing '`basename $$f bytecode`native':"; \ (./`basename $$f bytecode`native > `basename $$f bytecode`native.result 2>&1; true); \ $(DIFF) `basename $$f bytecode`native.reference `basename $$f bytecode`native.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \ fi; \ done promote: defaultpromote clean: defaultclean @rm -f *.bytecode *.native *.result include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/runtime-errors/syserror.native.reference0000644000175000017500000000011212124403241026675 0ustar tootstootsFatal error: exception Sys_error("titi:/toto: No such file or directory") mingw-ocaml/ocaml/testsuite/tests/runtime-errors/stackoverflow.native.reference0000644000175000017500000000006012124403241027700 0ustar tootstootsx = 20000 x = 10000 x = 0 Stack overflow caught mingw-ocaml/ocaml/testsuite/tests/runtime-errors/stackoverflow.ml0000644000175000017500000000052212124403241025070 0ustar tootstootslet rec f x = if not (x = 0 || x = 10000 || x = 20000) then 1 + f (x + 1) else try 1 + f (x + 1) with Stack_overflow -> print_string "x = "; print_int x; print_newline(); raise Stack_overflow let _ = try ignore(f 0) with Stack_overflow -> print_string "Stack overflow caught"; print_newline() mingw-ocaml/ocaml/testsuite/tests/runtime-errors/syserror.ml0000644000175000017500000000004412124403241024066 0ustar tootstootslet channel = open_out "titi:/toto" mingw-ocaml/ocaml/testsuite/tests/runtime-errors/syserror.bytecode.reference0000644000175000017500000000011212124403241027205 0ustar tootstootsFatal error: exception Sys_error("titi:/toto: No such file or directory") mingw-ocaml/ocaml/testsuite/tests/misc-kb/0000755000175000017500000000000012124403241020176 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/misc-kb/kbmain.ml0000644000175000017500000000530512124403241021774 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Terms open Equations open Orderings open Kb (**** let group_rules = [ { number = 1; numvars = 1; lhs = Term("*", [Term("U",[]); Var 1]); rhs = Var 1 }; { number = 2; numvars = 1; lhs = Term("*", [Term("I",[Var 1]); Var 1]); rhs = Term("U",[]) }; { number = 3; numvars = 3; lhs = Term("*", [Term("*", [Var 1; Var 2]); Var 3]); rhs = Term("*", [Var 1; Term("*", [Var 2; Var 3])]) } ] ****) let geom_rules = [ { number = 1; numvars = 1; lhs = Term ("*",[(Term ("U",[])); (Var 1)]); rhs = Var 1 }; { number = 2; numvars = 1; lhs = Term ("*",[(Term ("I",[(Var 1)])); (Var 1)]); rhs = Term ("U",[]) }; { number = 3; numvars = 3; lhs = Term ("*",[(Term ("*",[(Var 1); (Var 2)])); (Var 3)]); rhs = Term ("*",[(Var 1); (Term ("*",[(Var 2); (Var 3)]))]) }; { number = 4; numvars = 0; lhs = Term ("*",[(Term ("A",[])); (Term ("B",[]))]); rhs = Term ("*",[(Term ("B",[])); (Term ("A",[]))]) }; { number = 5; numvars = 0; lhs = Term ("*",[(Term ("C",[])); (Term ("C",[]))]); rhs = Term ("U",[]) }; { number = 6; numvars = 0; lhs = Term("*", [(Term ("C",[])); (Term ("*",[(Term ("A",[])); (Term ("I",[(Term ("C",[]))]))]))]); rhs = Term ("I",[(Term ("A",[]))]) }; { number = 7; numvars = 0; lhs = Term("*", [(Term ("C",[])); (Term ("*",[(Term ("B",[])); (Term ("I",[(Term ("C",[]))]))]))]); rhs = Term ("B",[]) } ] let group_rank = function "U" -> 0 | "*" -> 1 | "I" -> 2 | "B" -> 3 | "C" -> 4 | "A" -> 5 | _ -> assert false let group_precedence op1 op2 = let r1 = group_rank op1 and r2 = group_rank op2 in if r1 = r2 then Equal else if r1 > r2 then Greater else NotGE let group_order = rpo group_precedence lex_ext let greater pair = match group_order pair with Greater -> true | _ -> false let _ = for i = 1 to 20 do kb_complete greater [] geom_rules done mingw-ocaml/ocaml/testsuite/tests/misc-kb/Makefile0000644000175000017500000000026112124403241021635 0ustar tootstootsBASEDIR=../.. MODULES=terms equations orderings kb MAIN_MODULE=kbmain ADD_COMPFLAGS=-w a include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/misc-kb/kb.mli0000644000175000017500000000314012124403241021273 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Terms open Equations val super: term -> term -> (int list * (int * term) list) list val super_strict: term -> term -> (int list * (int * term) list) list val critical_pairs: term * term -> term * term -> (term * term) list val strict_critical_pairs: term * term -> term * term -> (term * term) list val mutual_critical_pairs: term * term -> term * term -> (term * term) list val rename: int -> term * term -> term * term val deletion_message: rule -> unit val non_orientable: term * term -> unit val partition: ('a -> bool) -> 'a list -> 'a list * 'a list val get_rule: int -> rule list -> rule val kb_completion: (term * term -> bool) -> int -> rule list -> (term * term) list -> int * int -> (term * term) list -> rule list val kb_complete: (term * term -> bool) -> rule list -> rule list -> unit mingw-ocaml/ocaml/testsuite/tests/misc-kb/kb.ml0000644000175000017500000001436112124403241021131 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Terms open Equations (****************** Critical pairs *********************) (* All (u,subst) such that N/u (&var) unifies with M, with principal unifier subst *) let rec super m = function Term(_,sons) as n -> let rec collate n = function [] -> [] | son::rest -> List.map (fun (u, subst) -> (n::u, subst)) (super m son) @ collate (n+1) rest in let insides = collate 1 sons in begin try ([], unify m n) :: insides with Failure _ -> insides end | _ -> [] (* Ex : let (m,_) = <> and (n,_) = <> in super m n ==> [[1],[2,Term ("B",[])]; x <- B [2],[2,Term ("A",[]); 1,Term ("B",[])]] x <- A y <- B *) (* All (u,subst), u&[], such that n/u unifies with m *) let super_strict m = function Term(_,sons) -> let rec collate n = function [] -> [] | son::rest -> List.map (fun (u, subst) -> (n::u, subst)) (super m son) @ collate (n+1) rest in collate 1 sons | _ -> [] (* Critical pairs of l1=r1 with l2=r2 *) (* critical_pairs : term_pair -> term_pair -> term_pair list *) let critical_pairs (l1,r1) (l2,r2) = let mk_pair (u,subst) = substitute subst (replace l2 u r1), substitute subst r2 in List.map mk_pair (super l1 l2) (* Strict critical pairs of l1=r1 with l2=r2 *) (* strict_critical_pairs : term_pair -> term_pair -> term_pair list *) let strict_critical_pairs (l1,r1) (l2,r2) = let mk_pair (u,subst) = substitute subst (replace l2 u r1), substitute subst r2 in List.map mk_pair (super_strict l1 l2) (* All critical pairs of eq1 with eq2 *) let mutual_critical_pairs eq1 eq2 = (strict_critical_pairs eq1 eq2) @ (critical_pairs eq2 eq1) (* Renaming of variables *) let rename n (t1,t2) = let rec ren_rec = function Var k -> Var(k+n) | Term(op,sons) -> Term(op, List.map ren_rec sons) in (ren_rec t1, ren_rec t2) (************************ Completion ******************************) let deletion_message rule = print_string "Rule ";print_int rule.number; print_string " deleted"; print_newline() (* Generate failure message *) let non_orientable (m,n) = pretty_term m; print_string " = "; pretty_term n; print_newline() let rec partition p = function [] -> ([], []) | x::l -> let (l1, l2) = partition p l in if p x then (x::l1, l2) else (l1, x::l2) let rec get_rule n = function [] -> raise Not_found | r::l -> if n = r.number then r else get_rule n l (* Improved Knuth-Bendix completion procedure *) let kb_completion greater = let rec kbrec j rules = let rec process failures (k,l) eqs = (**** print_string "***kb_completion "; print_int j; print_newline(); pretty_rules rules; List.iter non_orientable failures; print_int k; print_string " "; print_int l; print_newline(); List.iter non_orientable eqs; ***) match eqs with [] -> if k rules (* successful completion *) | _ -> print_string "Non-orientable equations :"; print_newline(); List.iter non_orientable failures; failwith "kb_completion" end | (m,n)::eqs -> let m' = mrewrite_all rules m and n' = mrewrite_all rules n and enter_rule(left,right) = let new_rule = mk_rule (j+1) left right in pretty_rule new_rule; let left_reducible rule = reducible left rule.lhs in let (redl,irredl) = partition left_reducible rules in List.iter deletion_message redl; let right_reduce rule = mk_rule rule.number rule.lhs (mrewrite_all (new_rule::rules) rule.rhs) in let irreds = List.map right_reduce irredl in let eqs' = List.map (fun rule -> (rule.lhs, rule.rhs)) redl in kbrec (j+1) (new_rule::irreds) [] (k,l) (eqs @ eqs' @ failures) in (*** print_string "--- Considering "; non_orientable (m', n'); ***) if m' = n' then process failures (k,l) eqs else if greater(m',n') then enter_rule(m',n') else if greater(n',m') then enter_rule(n',m') else process ((m',n')::failures) (k,l) eqs and next_criticals failures (k,l) = (**** print_string "***next_criticals "; print_int k; print_string " "; print_int l ; print_newline(); ****) try let rl = get_rule l rules in let el = (rl.lhs, rl.rhs) in if k=l then process failures (k,l) (strict_critical_pairs el (rename rl.numvars el)) else try let rk = get_rule k rules in let ek = (rk.lhs, rk.rhs) in process failures (k,l) (mutual_critical_pairs el (rename rl.numvars ek)) with Not_found -> next_criticals failures (k+1,l) with Not_found -> next_criticals failures (1,l+1) in process in kbrec (* complete_rules is assumed locally confluent, and checked Noetherian with ordering greater, rules is any list of rules *) let kb_complete greater complete_rules rules = let n = check_rules complete_rules and eqs = List.map (fun rule -> (rule.lhs, rule.rhs)) rules in let completed_rules = kb_completion greater n complete_rules [] (n,n) eqs in print_string "Canonical set found :"; print_newline(); pretty_rules (List.rev completed_rules) mingw-ocaml/ocaml/testsuite/tests/misc-kb/terms.ml0000644000175000017500000001000212124403241021653 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (****************** Term manipulations *****************) type term = Var of int | Term of string * term list let rec union l1 l2 = match l1 with [] -> l2 | a::r -> if List.mem a l2 then union r l2 else a :: union r l2 let rec vars = function Var n -> [n] | Term(_,l) -> vars_of_list l and vars_of_list = function [] -> [] | t::r -> union (vars t) (vars_of_list r) let rec substitute subst = function Term(oper,sons) -> Term(oper, List.map (substitute subst) sons) | Var(n) as t -> try List.assoc n subst with Not_found -> t (* Term replacement: replace M u N is M[u<-N]. *) let rec replace m u n = match (u, m) with [], _ -> n | i::u, Term(oper, sons) -> Term(oper, replace_nth i sons u n) | _ -> failwith "replace" and replace_nth i sons u n = match sons with s::r -> if i = 1 then replace s u n :: r else s :: replace_nth (i-1) r u n | [] -> failwith "replace_nth" (* Term matching. *) let matching term1 term2 = let rec match_rec subst t1 t2 = match (t1, t2) with Var v, _ -> if List.mem_assoc v subst then if t2 = List.assoc v subst then subst else failwith "matching" else (v, t2) :: subst | Term(op1,sons1), Term(op2,sons2) -> if op1 = op2 then List.fold_left2 match_rec subst sons1 sons2 else failwith "matching" | _ -> failwith "matching" in match_rec [] term1 term2 (* A naive unification algorithm. *) let compsubst subst1 subst2 = (List.map (fun (v,t) -> (v, substitute subst1 t)) subst2) @ subst1 let rec occurs n = function Var m -> m = n | Term(_,sons) -> List.exists (occurs n) sons let rec unify term1 term2 = match (term1, term2) with Var n1, _ -> if term1 = term2 then [] else if occurs n1 term2 then failwith "unify" else [n1, term2] | term1, Var n2 -> if occurs n2 term1 then failwith "unify" else [n2, term1] | Term(op1,sons1), Term(op2,sons2) -> if op1 = op2 then List.fold_left2 (fun s t1 t2 -> compsubst (unify (substitute s t1) (substitute s t2)) s) [] sons1 sons2 else failwith "unify" (* We need to print terms with variables independently from input terms obtained by parsing. We give arbitrary names v1,v2,... to their variables. *) let infixes = ["+";"*"] let rec pretty_term = function Var n -> print_string "v"; print_int n | Term (oper,sons) -> if List.mem oper infixes then begin match sons with [s1;s2] -> pretty_close s1; print_string oper; pretty_close s2 | _ -> failwith "pretty_term : infix arity <> 2" end else begin print_string oper; match sons with [] -> () | t::lt -> print_string "("; pretty_term t; List.iter (fun t -> print_string ","; pretty_term t) lt; print_string ")" end and pretty_close = function Term(oper, _) as m -> if List.mem oper infixes then begin print_string "("; pretty_term m; print_string ")" end else pretty_term m | m -> pretty_term m mingw-ocaml/ocaml/testsuite/tests/misc-kb/orderings.ml0000644000175000017500000000656212124403241022535 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (*********************** Recursive Path Ordering ****************************) open Terms type ordering = Greater | Equal | NotGE let ge_ord order pair = match order pair with NotGE -> false | _ -> true and gt_ord order pair = match order pair with Greater -> true | _ -> false and eq_ord order pair = match order pair with Equal -> true | _ -> false let rec rem_eq equiv x = function [] -> failwith "rem_eq" | y::l -> if equiv (x,y) then l else y :: rem_eq equiv x l let diff_eq equiv (x,y) = let rec diffrec = function ([],_) as p -> p | (h::t, y) -> try diffrec (t, rem_eq equiv h y) with Failure _ -> let (x',y') = diffrec (t,y) in (h::x',y') in if List.length x > List.length y then diffrec(y,x) else diffrec(x,y) (* Multiset extension of order *) let mult_ext order = function Term(_,sons1), Term(_,sons2) -> begin match diff_eq (eq_ord order) (sons1,sons2) with ([],[]) -> Equal | (l1,l2) -> if List.for_all (fun n -> List.exists (fun m -> gt_ord order (m,n)) l1) l2 then Greater else NotGE end | _ -> failwith "mult_ext" (* Lexicographic extension of order *) let lex_ext order = function (Term(_,sons1) as m), (Term(_,sons2) as n) -> let rec lexrec = function ([] , []) -> Equal | ([] , _ ) -> NotGE | ( _ , []) -> Greater | (x1::l1, x2::l2) -> match order (x1,x2) with Greater -> if List.for_all (fun n' -> gt_ord order (m,n')) l2 then Greater else NotGE | Equal -> lexrec (l1,l2) | NotGE -> if List.exists (fun m' -> ge_ord order (m',n)) l1 then Greater else NotGE in lexrec (sons1, sons2) | _ -> failwith "lex_ext" (* Recursive path ordering *) let rpo op_order ext = let rec rporec (m,n) = if m = n then Equal else match m with Var vm -> NotGE | Term(op1,sons1) -> match n with Var vn -> if occurs vn m then Greater else NotGE | Term(op2,sons2) -> match (op_order op1 op2) with Greater -> if List.for_all (fun n' -> gt_ord rporec (m,n')) sons2 then Greater else NotGE | Equal -> ext rporec (m,n) | NotGE -> if List.exists (fun m' -> ge_ord rporec (m',n)) sons1 then Greater else NotGE in rporec mingw-ocaml/ocaml/testsuite/tests/misc-kb/equations.ml0000644000175000017500000000633712124403241022551 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (****************** Equation manipulations *************) open Terms type rule = { number: int; numvars: int; lhs: term; rhs: term } (* standardizes an equation so its variables are 1,2,... *) let mk_rule num m n = let all_vars = union (vars m) (vars n) in let counter = ref 0 in let subst = List.map (fun v -> incr counter; (v, Var !counter)) (List.rev all_vars) in { number = num; numvars = !counter; lhs = substitute subst m; rhs = substitute subst n } (* checks that rules are numbered in sequence and returns their number *) let check_rules rules = let counter = ref 0 in List.iter (fun r -> incr counter; if r.number <> !counter then failwith "Rule numbers not in sequence") rules; !counter let pretty_rule rule = print_int rule.number; print_string " : "; pretty_term rule.lhs; print_string " = "; pretty_term rule.rhs; print_newline() let pretty_rules rules = List.iter pretty_rule rules (****************** Rewriting **************************) (* Top-level rewriting. Let eq:L=R be an equation, M be a term such that L<=M. With sigma = matching L M, we define the image of M by eq as sigma(R) *) let reduce l m r = substitute (matching l m) r (* Test whether m can be reduced by l, i.e. m contains an instance of l. *) let can_match l m = try let _ = matching l m in true with Failure _ -> false let rec reducible l m = can_match l m || (match m with | Term(_,sons) -> List.exists (reducible l) sons | _ -> false) (* Top-level rewriting with multiple rules. *) let rec mreduce rules m = match rules with [] -> failwith "mreduce" | rule::rest -> try reduce rule.lhs m rule.rhs with Failure _ -> mreduce rest m (* One step of rewriting in leftmost-outermost strategy, with multiple rules. Fails if no redex is found *) let rec mrewrite1 rules m = try mreduce rules m with Failure _ -> match m with Var n -> failwith "mrewrite1" | Term(f, sons) -> Term(f, mrewrite1_sons rules sons) and mrewrite1_sons rules = function [] -> failwith "mrewrite1" | son::rest -> try mrewrite1 rules son :: rest with Failure _ -> son :: mrewrite1_sons rules rest (* Iterating rewrite1. Returns a normal form. May loop forever *) let rec mrewrite_all rules m = try mrewrite_all rules (mrewrite1 rules m) with Failure _ -> m mingw-ocaml/ocaml/testsuite/tests/misc-kb/orderings.mli0000644000175000017500000000262012124403241022675 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Terms type ordering = Greater | Equal | NotGE val ge_ord: ('a -> ordering) -> 'a -> bool val gt_ord: ('a -> ordering) -> 'a -> bool val eq_ord: ('a -> ordering) -> 'a -> bool val rem_eq: ('a * 'b -> bool) -> 'a -> 'b list -> 'b list val diff_eq: ('a * 'a -> bool) -> 'a list * 'a list -> 'a list * 'a list val mult_ext: (term * term -> ordering) -> term * term -> ordering val lex_ext: (term * term -> ordering) -> term * term -> ordering val rpo: (string -> string -> ordering) -> ((term * term -> ordering) -> term * term -> ordering) -> term * term -> ordering mingw-ocaml/ocaml/testsuite/tests/misc-kb/terms.mli0000644000175000017500000000264312124403241022040 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) type term = Var of int | Term of string * term list val union: 'a list -> 'a list -> 'a list val vars: term -> int list val vars_of_list: term list -> int list val substitute: (int * term) list -> term -> term val replace: term -> int list -> term -> term val replace_nth: int -> term list -> int list -> term -> term list val matching: term -> term -> (int * term) list val compsubst: (int * term) list -> (int * term) list -> (int * term) list val occurs: int -> term -> bool val unify: term -> term -> (int * term) list val infixes: string list val pretty_term: term -> unit val pretty_close: term -> unit mingw-ocaml/ocaml/testsuite/tests/misc-kb/equations.mli0000644000175000017500000000244412124403241022715 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Terms type rule = { number: int; numvars: int; lhs: term; rhs: term } val mk_rule: int -> term -> term -> rule val check_rules: rule list -> int val pretty_rule: rule -> unit val pretty_rules: rule list -> unit val reduce: term -> term -> term -> term val reducible: term -> term -> bool val mreduce: rule list -> term -> term val mrewrite1: rule list -> term -> term val mrewrite1_sons: rule list -> term list -> term list val mrewrite_all: rule list -> term -> term mingw-ocaml/ocaml/testsuite/tests/misc-kb/kbmain.reference0000644000175000017500000036430012124403241023325 0ustar tootstoots1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*I(C)) 7 : C*(B*I(C)) = B 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 11 : C*(A*(I(C)*A)) = U 12 : C*(B*(I(C)*v1)) = B*v1 13 : I(U)*v1 = v1 14 : I(I(v1))*U = v1 15 : I(v3*v2)*(v3*(v2*v1)) = v1 16 : C*(A*(I(C)*(B*A))) = B 17 : I(C)*U = C 18 : C*(A*(I(C)*(A*v1))) = v1 19 : I(C)*B = B*I(C) 20 : I(I(v2))*v1 = v2*v1 Rule 14 deleted 21 : v1*U = v1 Rule 17 deleted 22 : I(C) = C Rule 19 deleted Rule 18 deleted Rule 16 deleted Rule 12 deleted Rule 11 deleted Rule 7 deleted 23 : C*B = B*C 24 : C*(A*(C*(A*v1))) = v1 25 : C*(A*(C*(B*A))) = B 26 : C*(B*(C*v1)) = B*v1 27 : C*(A*(C*A)) = U 28 : C*(B*C) = B 29 : C*(A*(C*(B*(A*v1)))) = B*v1 30 : I(I(v2*v1)*v2) = v1 31 : I(v2*I(v1))*v2 = v1 32 : I(v4*(v3*v2))*(v4*(v3*(v2*v1))) = v1 33 : I(v1*A)*(v1*(B*A)) = B 34 : I(v1*C)*v1 = C 35 : I(v3*I(v2))*(v3*v1) = v2*v1 36 : I(v2*A)*(v2*(B*(A*v1))) = B*v1 37 : I(v2*C)*(v2*v1) = C*v1 38 : v1*I(v1) = U 39 : I(C*(A*C))*v1 = A*v1 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U Rule 13 deleted 42 : I(I(v1)) = v1 Rule 20 deleted 43 : C*(B*v1) = B*(C*v1) Rule 29 deleted Rule 28 deleted Rule 26 deleted Rule 25 deleted 44 : A*(C*(A*v1)) = C*v1 Rule 24 deleted 45 : A*(C*A) = C Rule 27 deleted 46 : v2*(I(v1*v2)*v1) = U 47 : I(I(v3*(v2*v1))*(v3*v2)) = v1 48 : I(I(B*A)*A) = B 49 : v3*(I(v2*v3)*(v2*v1)) = v1 50 : I(I(v1)*I(v2)) = v2*v1 51 : I(I(B*(A*v1))*A) = B*v1 52 : I(I(v1)*C) = C*v1 53 : I(v2*I(v1*v2)) = v1 54 : I(v3*(v2*I(v1)))*(v3*v2) = v1 55 : I(v1*(C*(A*C)))*v1 = A 56 : v2*I(I(v1)*v2) = v1 57 : I(v2*(I(v3*v1)*v3))*v2 = v1 58 : I(v5*(v4*(v3*v2)))*(v5*(v4*(v3*(v2*v1)))) = v1 59 : I(v2*(v1*A))*(v2*(v1*(B*A))) = B 60 : I(v2*(v1*C))*(v2*v1) = C 61 : I(v4*(v3*I(v2)))*(v4*(v3*v1)) = v2*v1 62 : I(v3*(v2*A))*(v3*(v2*(B*(A*v1)))) = B*v1 63 : I(v3*(v2*C))*(v3*(v2*v1)) = C*v1 64 : I(v3*(I(v4*v2)*v4))*(v3*v1) = v2*v1 65 : v4*(I(v3*(v2*v4))*(v3*(v2*v1))) = v1 66 : I(I(B)*A)*A = B 67 : I(A*A)*(B*(A*A)) = B 68 : v1*(I(A*v1)*(B*A)) = B 69 : I(I(v1*A)*(v1*B))*B = A 70 : v1*I(C*v1) = C 71 : I(A*I(v1))*(B*A) = v1*B 72 : I(C*I(v1)) = v1*C 73 : I(v2*(C*(A*C)))*(v2*v1) = A*v1 74 : I(A*I(v2))*(B*(A*v1)) = v2*(B*v1) 75 : v3*(I(I(v2)*v3)*v1) = v2*v1 76 : I(I(B*I(v1))*A)*(v1*A) = B 77 : I(v1*A)*(v1*(B*(B*A))) = B*B 78 : I(I(B)*A)*(A*v1) = B*v1 79 : I(A*A)*(B*(A*(A*v1))) = B*v1 80 : I(v2*A)*(v2*(B*(B*(A*v1)))) = B*(B*v1) 81 : v2*(I(A*v2)*(B*(A*v1))) = B*v1 82 : I(I(v2*A)*(v2*B))*(B*v1) = A*v1 83 : I(I(B*I(v2))*A)*(v2*(A*v1)) = B*v1 84 : I(A*C)*(B*A) = B*C 85 : I(A*C)*(B*(A*v1)) = B*(C*v1) 86 : v2*(I(C*v2)*v1) = C*v1 87 : I(I(B*C)*A)*(C*A) = B 88 : I(I(B*C)*A)*(C*(A*v1)) = B*v1 89 : v2*(v1*I(v2*v1)) = U 90 : B*(A*I(B)) = A 91 : I(v2*v1)*v2 = I(v1) Rule 64 deleted Rule 57 deleted Rule 55 deleted Rule 46 deleted Rule 34 deleted Rule 31 deleted Rule 30 deleted 92 : I(C*(A*C)) = A Rule 39 deleted 93 : I(v3*(v2*v1))*(v3*v2) = I(v1) Rule 60 deleted Rule 54 deleted Rule 47 deleted 94 : I(v1*I(v2)) = v2*I(v1) Rule 83 deleted Rule 76 deleted Rule 74 deleted Rule 72 deleted Rule 71 deleted Rule 53 deleted Rule 50 deleted Rule 35 deleted 95 : I(v2*(I(B)*A))*(v2*(A*v1)) = B*v1 96 : I(v1*(I(B)*A))*(v1*A) = B 97 : I(v1*A)*(v1*B) = B*(C*(A*C)) Rule 82 deleted Rule 69 deleted 98 : I(v1*C) = C*I(v1) Rule 88 deleted Rule 87 deleted Rule 85 deleted Rule 84 deleted Rule 52 deleted Rule 37 deleted 99 : v3*(v2*(I(v3*v2)*v1)) = v1 100 : B*(A*(I(B)*v1)) = A*v1 101 : I(v3*v2)*(v3*v1) = I(v2)*v1 Rule 97 deleted Rule 96 deleted Rule 95 deleted Rule 93 deleted Rule 80 deleted Rule 77 deleted Rule 73 deleted Rule 65 deleted Rule 63 deleted Rule 62 deleted Rule 61 deleted Rule 59 deleted Rule 58 deleted Rule 49 deleted Rule 36 deleted Rule 33 deleted Rule 32 deleted Rule 15 deleted 102 : B*(C*I(B)) = C 103 : B*(C*(I(B)*v1)) = C*v1 104 : B*(I(B*A)*A) = U 105 : B*(I(B*A)*(A*v1)) = v1 106 : I(B*A)*A = I(B) Rule 104 deleted Rule 48 deleted 107 : B*(v1*(I(B*(A*v1))*A)) = U 108 : I(I(B*(B*A))*A) = B*B 109 : B*(v2*(I(B*(A*v2))*(A*v1))) = v1 110 : I(I(B*(B*(A*v1)))*A) = B*(B*v1) 111 : I(I(B)*A) = B*(C*(A*C)) Rule 78 deleted Rule 66 deleted 112 : I(I(B*v1)*A) = B*(C*(A*(C*v1))) Rule 110 deleted Rule 108 deleted Rule 51 deleted 113 : v3*(v2*I(I(v1)*(v3*v2))) = v1 114 : v1*I(C*(A*(C*v1))) = A 115 : I(I(v1)*v2) = I(v2)*v1 Rule 113 deleted Rule 112 deleted Rule 111 deleted Rule 75 deleted Rule 56 deleted 116 : v2*(v1*(I(A*(v2*v1))*(B*A))) = B 117 : I(A*v1)*(B*A) = I(v1)*B Rule 116 deleted Rule 68 deleted 118 : v2*(v1*I(C*(v2*v1))) = C 119 : I(C*v1) = I(v1)*C Rule 118 deleted Rule 114 deleted Rule 92 deleted Rule 86 deleted Rule 70 deleted 120 : v1*(I(A*(C*v1))*C) = A 121 : I(A*A)*(B*(B*(A*A))) = B*B 122 : I(A*A)*(B*(B*(A*(A*v1)))) = B*(B*v1) 123 : I(A*A)*(B*(A*v1)) = B*(C*(A*(C*v1))) Rule 79 deleted Rule 67 deleted 124 : v3*(v2*(I(A*(v3*v2))*(B*(A*v1)))) = B*v1 125 : v1*(I(A*v1)*(B*(B*A))) = B*B 126 : I(A*v2)*(B*(A*v1)) = I(v2)*(B*v1) Rule 124 deleted Rule 123 deleted Rule 81 deleted 127 : v3*(v2*(v1*I(v3*(v2*v1)))) = U 128 : v2*I(v1*v2) = I(v1) Rule 89 deleted 129 : A*I(B) = I(B)*A Rule 90 deleted 130 : I(v1*v2) = I(v2)*I(v1) Rule 128 deleted Rule 127 deleted Rule 126 deleted Rule 125 deleted Rule 122 deleted Rule 121 deleted Rule 120 deleted Rule 119 deleted Rule 117 deleted Rule 115 deleted Rule 109 deleted Rule 107 deleted Rule 106 deleted Rule 105 deleted Rule 101 deleted Rule 99 deleted Rule 98 deleted Rule 94 deleted Rule 91 deleted 131 : B*(C*(A*(C*(I(B)*(A*v1))))) = v1 132 : B*(C*(A*(C*(I(B)*A)))) = U 133 : C*(A*(C*(I(B)*A))) = I(B) Rule 132 deleted 134 : A*(I(B)*v1) = I(B)*(A*v1) Rule 100 deleted 135 : C*I(B) = I(B)*C Rule 102 deleted 136 : C*(I(B)*v1) = I(B)*(C*v1) Rule 133 deleted Rule 131 deleted Rule 103 deleted Canonical set found : 1 : U*v1 = v1 2 : I(v1)*v1 = U 3 : (v3*v2)*v1 = v3*(v2*v1) 4 : A*B = B*A 5 : C*C = U 6 : I(A) = C*(A*C) 8 : I(v2)*(v2*v1) = v1 9 : A*(B*v1) = B*(A*v1) 10 : C*(C*v1) = v1 21 : v1*U = v1 22 : I(C) = C 23 : C*B = B*C 38 : v1*I(v1) = U 40 : v2*(I(v2)*v1) = v1 41 : I(U) = U 42 : I(I(v1)) = v1 43 : C*(B*v1) = B*(C*v1) 44 : A*(C*(A*v1)) = C*v1 45 : A*(C*A) = C 129 : A*I(B) = I(B)*A 130 : I(v1*v2) = I(v2)*I(v1) 134 : A*(I(B)*v1) = I(B)*(A*v1) 135 : C*I(B) = I(B)*C 136 : C*(I(B)*v1) = I(B)*(C*v1) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/0000755000175000017500000000000012124403241020717 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t320-gc-1.ml0000644000175000017500000007756012124403241022505 0ustar tootstootsopen Lib;; let rec f n = if n <= 0 then [] else n :: f (n-1) in let l = f 300 in Gc.minor (); if List.fold_left (+) 0 l <> 301 * 150 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 746 11 RESTART 12 GRAB 1 14 ACC0 15 BRANCHIFNOT 28 17 ACC1 18 PUSHACC1 19 GETFIELD1 20 PUSHOFFSETCLOSURE0 21 APPLY2 22 PUSHACC1 23 GETFIELD0 24 MAKEBLOCK2 0 26 RETURN 2 28 ACC1 29 RETURN 2 31 RESTART 32 GRAB 3 34 CONST0 35 PUSHACC4 36 LEINT 37 BRANCHIFNOT 42 39 CONST0 40 RETURN 4 42 ACC3 43 PUSHACC3 44 PUSHACC3 45 PUSHACC3 46 C_CALL4 caml_input 48 PUSHCONST0 49 PUSHACC1 50 EQ 51 BRANCHIFNOT 58 53 GETGLOBAL End_of_file 55 MAKEBLOCK1 0 57 RAISE 58 ACC0 59 PUSHACC5 60 SUBINT 61 PUSHACC1 62 PUSHACC5 63 ADDINT 64 PUSHACC4 65 PUSHACC4 66 PUSHOFFSETCLOSURE0 67 APPTERM 4, 9 70 ACC0 71 C_CALL1 caml_input_scan_line 73 PUSHCONST0 74 PUSHACC1 75 EQ 76 BRANCHIFNOT 83 78 GETGLOBAL End_of_file 80 MAKEBLOCK1 0 82 RAISE 83 CONST0 84 PUSHACC1 85 GTINT 86 BRANCHIFNOT 107 88 ACC0 89 OFFSETINT -1 91 C_CALL1 create_string 93 PUSHACC1 94 OFFSETINT -1 96 PUSHCONST0 97 PUSHACC2 98 PUSHACC5 99 C_CALL4 caml_input 101 ACC2 102 C_CALL1 caml_input_char 104 ACC0 105 RETURN 3 107 ACC0 108 NEGINT 109 C_CALL1 create_string 111 PUSHACC1 112 NEGINT 113 PUSHCONST0 114 PUSHACC2 115 PUSHACC5 116 C_CALL4 caml_input 118 CONST0 119 PUSHTRAP 130 121 ACC6 122 PUSHOFFSETCLOSURE0 123 APPLY1 124 PUSHACC5 125 PUSHENVACC1 126 APPLY2 127 POPTRAP 128 RETURN 3 130 PUSHGETGLOBAL End_of_file 132 PUSHACC1 133 GETFIELD0 134 EQ 135 BRANCHIFNOT 140 137 ACC1 138 RETURN 4 140 ACC0 141 RAISE 142 ACC0 143 C_CALL1 caml_flush 145 RETURN 1 147 RESTART 148 GRAB 1 150 ACC1 151 PUSHACC1 152 C_CALL2 caml_output_char 154 RETURN 2 156 RESTART 157 GRAB 1 159 ACC1 160 PUSHACC1 161 C_CALL2 caml_output_char 163 RETURN 2 165 RESTART 166 GRAB 1 168 ACC1 169 PUSHACC1 170 C_CALL2 caml_output_int 172 RETURN 2 174 RESTART 175 GRAB 1 177 ACC1 178 PUSHACC1 179 C_CALL2 caml_seek_out 181 RETURN 2 183 ACC0 184 C_CALL1 caml_pos_out 186 RETURN 1 188 ACC0 189 C_CALL1 caml_channel_size 191 RETURN 1 193 RESTART 194 GRAB 1 196 ACC1 197 PUSHACC1 198 C_CALL2 caml_set_binary_mode 200 RETURN 2 202 ACC0 203 C_CALL1 caml_input_char 205 RETURN 1 207 ACC0 208 C_CALL1 caml_input_char 210 RETURN 1 212 ACC0 213 C_CALL1 caml_input_int 215 RETURN 1 217 ACC0 218 C_CALL1 input_value 220 RETURN 1 222 RESTART 223 GRAB 1 225 ACC1 226 PUSHACC1 227 C_CALL2 caml_seek_in 229 RETURN 2 231 ACC0 232 C_CALL1 caml_pos_in 234 RETURN 1 236 ACC0 237 C_CALL1 caml_channel_size 239 RETURN 1 241 ACC0 242 C_CALL1 caml_close_channel 244 RETURN 1 246 RESTART 247 GRAB 1 249 ACC1 250 PUSHACC1 251 C_CALL2 caml_set_binary_mode 253 RETURN 2 255 CONST0 256 PUSHENVACC1 257 APPLY1 258 ACC0 259 C_CALL1 sys_exit 261 RETURN 1 263 CONST0 264 PUSHENVACC1 265 GETFIELD0 266 APPTERM1 2 268 CONST0 269 PUSHENVACC1 270 APPLY1 271 CONST0 272 PUSHENVACC2 273 APPTERM1 2 275 ENVACC1 276 GETFIELD0 277 PUSHACC0 278 PUSHACC2 279 CLOSURE 2, 268 282 PUSHENVACC1 283 SETFIELD0 284 RETURN 2 286 ENVACC1 287 C_CALL1 caml_flush 289 ENVACC2 290 C_CALL1 caml_flush 292 RETURN 1 294 CONST0 295 PUSHENVACC1 296 APPLY1 297 C_CALL1 float_of_string 299 RETURN 1 301 CONST0 302 PUSHENVACC1 303 APPLY1 304 C_CALL1 int_of_string 306 RETURN 1 308 ENVACC2 309 C_CALL1 caml_flush 311 ENVACC1 312 PUSHENVACC3 313 APPTERM1 2 315 CONSTINT 13 317 PUSHENVACC1 318 C_CALL2 caml_output_char 320 ENVACC1 321 C_CALL1 caml_flush 323 RETURN 1 325 ACC0 326 PUSHENVACC1 327 PUSHENVACC2 328 APPLY2 329 CONSTINT 13 331 PUSHENVACC1 332 C_CALL2 caml_output_char 334 ENVACC1 335 C_CALL1 caml_flush 337 RETURN 1 339 ACC0 340 PUSHENVACC1 341 APPLY1 342 PUSHENVACC2 343 PUSHENVACC3 344 APPTERM2 3 346 ACC0 347 PUSHENVACC1 348 APPLY1 349 PUSHENVACC2 350 PUSHENVACC3 351 APPTERM2 3 353 ACC0 354 PUSHENVACC1 355 PUSHENVACC2 356 APPTERM2 3 358 ACC0 359 PUSHENVACC1 360 C_CALL2 caml_output_char 362 RETURN 1 364 CONSTINT 13 366 PUSHENVACC1 367 C_CALL2 caml_output_char 369 ENVACC1 370 C_CALL1 caml_flush 372 RETURN 1 374 ACC0 375 PUSHENVACC1 376 PUSHENVACC2 377 APPLY2 378 CONSTINT 13 380 PUSHENVACC1 381 C_CALL2 caml_output_char 383 RETURN 1 385 ACC0 386 PUSHENVACC1 387 APPLY1 388 PUSHENVACC2 389 PUSHENVACC3 390 APPTERM2 3 392 ACC0 393 PUSHENVACC1 394 APPLY1 395 PUSHENVACC2 396 PUSHENVACC3 397 APPTERM2 3 399 ACC0 400 PUSHENVACC1 401 PUSHENVACC2 402 APPTERM2 3 404 ACC0 405 PUSHENVACC1 406 C_CALL2 caml_output_char 408 RETURN 1 410 RESTART 411 GRAB 3 413 CONST0 414 PUSHACC3 415 LTINT 416 BRANCHIF 427 418 ACC1 419 C_CALL1 ml_string_length 421 PUSHACC4 422 PUSHACC4 423 ADDINT 424 GTINT 425 BRANCHIFNOT 432 427 GETGLOBAL "really_input" 429 PUSHENVACC1 430 APPTERM1 5 432 ACC3 433 PUSHACC3 434 PUSHACC3 435 PUSHACC3 436 PUSHENVACC2 437 APPTERM 4, 8 440 RESTART 441 GRAB 3 443 CONST0 444 PUSHACC3 445 LTINT 446 BRANCHIF 457 448 ACC1 449 C_CALL1 ml_string_length 451 PUSHACC4 452 PUSHACC4 453 ADDINT 454 GTINT 455 BRANCHIFNOT 462 457 GETGLOBAL "input" 459 PUSHENVACC1 460 APPTERM1 5 462 ACC3 463 PUSHACC3 464 PUSHACC3 465 PUSHACC3 466 C_CALL4 caml_input 468 RETURN 4 470 ACC0 471 PUSHCONST0 472 PUSHGETGLOBAL <0>(0, <0>(6, 0)) 474 PUSHENVACC1 475 APPTERM3 4 477 ACC0 478 PUSHCONST0 479 PUSHGETGLOBAL <0>(0, <0>(7, 0)) 481 PUSHENVACC1 482 APPTERM3 4 484 RESTART 485 GRAB 2 487 ACC1 488 PUSHACC1 489 PUSHACC4 490 C_CALL3 sys_open 492 C_CALL1 caml_open_descriptor 494 RETURN 3 496 ACC0 497 C_CALL1 caml_flush 499 ACC0 500 C_CALL1 caml_close_channel 502 RETURN 1 504 RESTART 505 GRAB 1 507 CONST0 508 PUSHACC2 509 PUSHACC2 510 C_CALL3 output_value 512 RETURN 2 514 RESTART 515 GRAB 3 517 CONST0 518 PUSHACC3 519 LTINT 520 BRANCHIF 531 522 ACC1 523 C_CALL1 ml_string_length 525 PUSHACC4 526 PUSHACC4 527 ADDINT 528 GTINT 529 BRANCHIFNOT 536 531 GETGLOBAL "output" 533 PUSHENVACC1 534 APPTERM1 5 536 ACC3 537 PUSHACC3 538 PUSHACC3 539 PUSHACC3 540 C_CALL4 caml_output 542 RETURN 4 544 RESTART 545 GRAB 1 547 ACC1 548 C_CALL1 ml_string_length 550 PUSHCONST0 551 PUSHACC3 552 PUSHACC3 553 C_CALL4 caml_output 555 RETURN 2 557 ACC0 558 PUSHCONSTINT 438 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0)))) 562 PUSHENVACC1 563 APPTERM3 4 565 ACC0 566 PUSHCONSTINT 438 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0)))) 570 PUSHENVACC1 571 APPTERM3 4 573 RESTART 574 GRAB 2 576 ACC1 577 PUSHACC1 578 PUSHACC4 579 C_CALL3 sys_open 581 C_CALL1 caml_open_descriptor 583 RETURN 3 585 ACC0 586 PUSHGETGLOBAL "%.12g" 588 C_CALL2 format_float 590 RETURN 1 592 ACC0 593 PUSHGETGLOBAL "%d" 595 C_CALL2 format_int 597 RETURN 1 599 GETGLOBAL "false" 601 PUSHACC1 602 C_CALL2 string_equal 604 BRANCHIFNOT 609 606 CONST0 607 RETURN 1 609 GETGLOBAL "true" 611 PUSHACC1 612 C_CALL2 string_equal 614 BRANCHIFNOT 619 616 CONST1 617 RETURN 1 619 GETGLOBAL "bool_of_string" 621 PUSHENVACC1 622 APPTERM1 2 624 ACC0 625 BRANCHIFNOT 631 627 GETGLOBAL "true" 629 RETURN 1 631 GETGLOBAL "false" 633 RETURN 1 635 CONST0 636 PUSHACC1 637 LTINT 638 BRANCHIF 646 640 CONSTINT 255 642 PUSHACC1 643 GTINT 644 BRANCHIFNOT 651 646 GETGLOBAL "char_of_int" 648 PUSHENVACC1 649 APPTERM1 2 651 ACC0 652 RETURN 1 654 RESTART 655 GRAB 1 657 ACC0 658 C_CALL1 ml_string_length 660 PUSHACC2 661 C_CALL1 ml_string_length 663 PUSHACC0 664 PUSHACC2 665 ADDINT 666 C_CALL1 create_string 668 PUSHACC2 669 PUSHCONST0 670 PUSHACC2 671 PUSHCONST0 672 PUSHACC7 673 C_CALL5 blit_string 675 ACC1 676 PUSHACC3 677 PUSHACC2 678 PUSHCONST0 679 PUSHACC 8 681 C_CALL5 blit_string 683 ACC0 684 RETURN 5 686 CONSTINT -1 688 PUSHACC1 689 XORINT 690 RETURN 1 692 CONST0 693 PUSHACC1 694 GEINT 695 BRANCHIFNOT 700 697 ACC0 698 RETURN 1 700 ACC0 701 NEGINT 702 RETURN 1 704 RESTART 705 GRAB 1 707 ACC1 708 PUSHACC1 709 C_CALL2 greaterequal 711 BRANCHIFNOT 716 713 ACC0 714 RETURN 2 716 ACC1 717 RETURN 2 719 RESTART 720 GRAB 1 722 ACC1 723 PUSHACC1 724 C_CALL2 lessequal 726 BRANCHIFNOT 731 728 ACC0 729 RETURN 2 731 ACC1 732 RETURN 2 734 ACC0 735 PUSHGETGLOBAL Invalid_argument 737 MAKEBLOCK2 0 739 RAISE 740 ACC0 741 PUSHGETGLOBAL Failure 743 MAKEBLOCK2 0 745 RAISE 746 CLOSURE 0, 740 749 PUSH 750 CLOSURE 0, 734 753 PUSHGETGLOBAL "Pervasives.Exit" 755 MAKEBLOCK1 0 757 PUSHGETGLOBAL "Pervasives.Assert_failure" 759 MAKEBLOCK1 0 761 PUSH 762 CLOSURE 0, 720 765 PUSH 766 CLOSURE 0, 705 769 PUSH 770 CLOSURE 0, 692 773 PUSH 774 CLOSURE 0, 686 777 PUSHCONST0 778 PUSHCONSTINT 31 780 PUSHCONST1 781 LSLINT 782 EQ 783 BRANCHIFNOT 789 785 CONSTINT 30 787 BRANCH 791 789 CONSTINT 62 791 PUSHCONST1 792 LSLINT 793 PUSHACC0 794 OFFSETINT -1 796 PUSH 797 CLOSURE 0, 655 800 PUSHACC 9 802 CLOSURE 1, 635 805 PUSH 806 CLOSURE 0, 624 809 PUSHACC 11 811 CLOSURE 1, 599 814 PUSH 815 CLOSURE 0, 592 818 PUSH 819 CLOSURE 0, 585 822 PUSH 823 CLOSUREREC 0, 12 827 CONST0 828 C_CALL1 caml_open_descriptor 830 PUSHCONST1 831 C_CALL1 caml_open_descriptor 833 PUSHCONST2 834 C_CALL1 caml_open_descriptor 836 PUSH 837 CLOSURE 0, 574 840 PUSHACC0 841 CLOSURE 1, 565 844 PUSHACC1 845 CLOSURE 1, 557 848 PUSH 849 CLOSURE 0, 545 852 PUSHACC 22 854 CLOSURE 1, 515 857 PUSH 858 CLOSURE 0, 505 861 PUSH 862 CLOSURE 0, 496 865 PUSH 866 CLOSURE 0, 485 869 PUSHACC0 870 CLOSURE 1, 477 873 PUSHACC1 874 CLOSURE 1, 470 877 PUSHACC 28 879 CLOSURE 1, 441 882 PUSH 883 CLOSUREREC 0, 32 887 ACC0 888 PUSHACC 31 890 CLOSURE 2, 411 893 PUSHACC 22 895 CLOSUREREC 1, 70 899 ACC 15 901 CLOSURE 1, 404 904 PUSHACC 11 906 PUSHACC 17 908 CLOSURE 2, 399 911 PUSHACC 12 913 PUSHACC 18 915 PUSHACC 23 917 CLOSURE 3, 392 920 PUSHACC 13 922 PUSHACC 19 924 PUSHACC 23 926 CLOSURE 3, 385 929 PUSHACC 14 931 PUSHACC 20 933 CLOSURE 2, 374 936 PUSHACC 20 938 CLOSURE 1, 364 941 PUSHACC 20 943 CLOSURE 1, 358 946 PUSHACC 17 948 PUSHACC 22 950 CLOSURE 2, 353 953 PUSHACC 18 955 PUSHACC 23 957 PUSHACC 29 959 CLOSURE 3, 346 962 PUSHACC 19 964 PUSHACC 24 966 PUSHACC 29 968 CLOSURE 3, 339 971 PUSHACC 20 973 PUSHACC 25 975 CLOSURE 2, 325 978 PUSHACC 25 980 CLOSURE 1, 315 983 PUSHACC 12 985 PUSHACC 28 987 PUSHACC 30 989 CLOSURE 3, 308 992 PUSHACC0 993 CLOSURE 1, 301 996 PUSHACC1 997 CLOSURE 1, 294 1000 PUSHACC 29 1002 PUSHACC 31 1004 CLOSURE 2, 286 1007 MAKEBLOCK1 0 1009 PUSHACC0 1010 CLOSURE 1, 275 1013 PUSHACC1 1014 CLOSURE 1, 263 1017 PUSHACC0 1018 CLOSURE 1, 255 1021 PUSHACC1 1022 PUSHACC 22 1024 PUSHACC4 1025 PUSHACC3 1026 PUSH 1027 CLOSURE 0, 247 1030 PUSH 1031 CLOSURE 0, 241 1034 PUSH 1035 CLOSURE 0, 236 1038 PUSH 1039 CLOSURE 0, 231 1042 PUSH 1043 CLOSURE 0, 223 1046 PUSH 1047 CLOSURE 0, 217 1050 PUSH 1051 CLOSURE 0, 212 1054 PUSH 1055 CLOSURE 0, 207 1058 PUSHACC 32 1060 PUSHACC 35 1062 PUSHACC 33 1064 PUSH 1065 CLOSURE 0, 202 1068 PUSHACC 41 1070 PUSHACC 40 1072 PUSHACC 42 1074 PUSH 1075 CLOSURE 0, 194 1078 PUSHACC 46 1080 PUSH 1081 CLOSURE 0, 188 1084 PUSH 1085 CLOSURE 0, 183 1088 PUSH 1089 CLOSURE 0, 175 1092 PUSHACC 51 1094 PUSH 1095 CLOSURE 0, 166 1098 PUSH 1099 CLOSURE 0, 157 1102 PUSHACC 55 1104 PUSHACC 57 1106 PUSH 1107 CLOSURE 0, 148 1110 PUSH 1111 CLOSURE 0, 142 1114 PUSHACC 63 1116 PUSHACC 62 1118 PUSHACC 64 1120 PUSHACC 38 1122 PUSHACC 40 1124 PUSHACC 42 1126 PUSHACC 44 1128 PUSHACC 46 1130 PUSHACC 48 1132 PUSHACC 50 1134 PUSHACC 52 1136 PUSHACC 54 1138 PUSHACC 56 1140 PUSHACC 58 1142 PUSHACC 60 1144 PUSHACC 62 1146 PUSHACC 64 1148 PUSHACC 66 1150 PUSHACC 82 1152 PUSHACC 84 1154 PUSHACC 86 1156 PUSHACC 88 1158 PUSHACC 90 1160 PUSHACC 92 1162 PUSHACC 94 1164 PUSHACC 96 1166 PUSHACC 98 1168 PUSHACC 100 1170 PUSHACC 104 1172 PUSHACC 104 1174 PUSHACC 104 1176 PUSHACC 108 1178 PUSHACC 110 1180 PUSHACC 112 1182 PUSHACC 117 1184 PUSHACC 117 1186 PUSHACC 117 1188 PUSHACC 117 1190 MAKEBLOCK 69, 0 1193 POP 53 1195 SETGLOBAL Pervasives 1197 BRANCH 2177 1199 RESTART 1200 GRAB 1 1202 ACC1 1203 BRANCHIFNOT 1213 1205 ACC1 1206 GETFIELD1 1207 PUSHACC1 1208 OFFSETINT 1 1210 PUSHOFFSETCLOSURE0 1211 APPTERM2 4 1213 ACC0 1214 RETURN 2 1216 RESTART 1217 GRAB 1 1219 ACC0 1220 BRANCHIFNOT 1251 1222 CONST0 1223 PUSHACC2 1224 EQ 1225 BRANCHIFNOT 1231 1227 ACC0 1228 GETFIELD0 1229 RETURN 2 1231 CONST0 1232 PUSHACC2 1233 GTINT 1234 BRANCHIFNOT 1244 1236 ACC1 1237 OFFSETINT -1 1239 PUSHACC1 1240 GETFIELD1 1241 PUSHOFFSETCLOSURE0 1242 APPTERM2 4 1244 GETGLOBAL "List.nth" 1246 PUSHGETGLOBALFIELD Pervasives, 2 1249 APPTERM1 3 1251 GETGLOBAL "nth" 1253 PUSHGETGLOBALFIELD Pervasives, 3 1256 APPTERM1 3 1258 RESTART 1259 GRAB 1 1261 ACC0 1262 BRANCHIFNOT 1274 1264 ACC1 1265 PUSHACC1 1266 GETFIELD0 1267 MAKEBLOCK2 0 1269 PUSHACC1 1270 GETFIELD1 1271 PUSHOFFSETCLOSURE0 1272 APPTERM2 4 1274 ACC1 1275 RETURN 2 1277 ACC0 1278 BRANCHIFNOT 1291 1280 ACC0 1281 GETFIELD1 1282 PUSHOFFSETCLOSURE0 1283 APPLY1 1284 PUSHACC1 1285 GETFIELD0 1286 PUSHGETGLOBALFIELD Pervasives, 16 1289 APPTERM2 3 1291 RETURN 1 1293 RESTART 1294 GRAB 1 1296 ACC1 1297 BRANCHIFNOT 1313 1299 ACC1 1300 GETFIELD0 1301 PUSHACC1 1302 APPLY1 1303 PUSHACC2 1304 GETFIELD1 1305 PUSHACC2 1306 PUSHOFFSETCLOSURE0 1307 APPLY2 1308 PUSHACC1 1309 MAKEBLOCK2 0 1311 POP 1 1313 RETURN 2 1315 RESTART 1316 GRAB 1 1318 ACC1 1319 BRANCHIFNOT 1331 1321 ACC1 1322 GETFIELD0 1323 PUSHACC1 1324 APPLY1 1325 ACC1 1326 GETFIELD1 1327 PUSHACC1 1328 PUSHOFFSETCLOSURE0 1329 APPTERM2 4 1331 RETURN 2 1333 RESTART 1334 GRAB 2 1336 ACC2 1337 BRANCHIFNOT 1350 1339 ACC2 1340 GETFIELD1 1341 PUSHACC3 1342 GETFIELD0 1343 PUSHACC3 1344 PUSHACC3 1345 APPLY2 1346 PUSHACC2 1347 PUSHOFFSETCLOSURE0 1348 APPTERM3 6 1350 ACC1 1351 RETURN 3 1353 RESTART 1354 GRAB 2 1356 ACC1 1357 BRANCHIFNOT 1370 1359 ACC2 1360 PUSHACC2 1361 GETFIELD1 1362 PUSHACC2 1363 PUSHOFFSETCLOSURE0 1364 APPLY3 1365 PUSHACC2 1366 GETFIELD0 1367 PUSHACC2 1368 APPTERM2 5 1370 ACC2 1371 RETURN 3 1373 RESTART 1374 GRAB 2 1376 ACC1 1377 BRANCHIFNOT 1400 1379 ACC2 1380 BRANCHIFNOT 1407 1382 ACC2 1383 GETFIELD0 1384 PUSHACC2 1385 GETFIELD0 1386 PUSHACC2 1387 APPLY2 1388 PUSHACC3 1389 GETFIELD1 1390 PUSHACC3 1391 GETFIELD1 1392 PUSHACC3 1393 PUSHOFFSETCLOSURE0 1394 APPLY3 1395 PUSHACC1 1396 MAKEBLOCK2 0 1398 RETURN 4 1400 ACC2 1401 BRANCHIFNOT 1405 1403 BRANCH 1407 1405 RETURN 3 1407 GETGLOBAL "List.map2" 1409 PUSHGETGLOBALFIELD Pervasives, 2 1412 APPTERM1 4 1414 RESTART 1415 GRAB 2 1417 ACC1 1418 BRANCHIFNOT 1437 1420 ACC2 1421 BRANCHIFNOT 1444 1423 ACC2 1424 GETFIELD0 1425 PUSHACC2 1426 GETFIELD0 1427 PUSHACC2 1428 APPLY2 1429 ACC2 1430 GETFIELD1 1431 PUSHACC2 1432 GETFIELD1 1433 PUSHACC2 1434 PUSHOFFSETCLOSURE0 1435 APPTERM3 6 1437 ACC2 1438 BRANCHIFNOT 1442 1440 BRANCH 1444 1442 RETURN 3 1444 GETGLOBAL "List.iter2" 1446 PUSHGETGLOBALFIELD Pervasives, 2 1449 APPTERM1 4 1451 RESTART 1452 GRAB 3 1454 ACC2 1455 BRANCHIFNOT 1476 1457 ACC3 1458 BRANCHIFNOT 1482 1460 ACC3 1461 GETFIELD1 1462 PUSHACC3 1463 GETFIELD1 1464 PUSHACC5 1465 GETFIELD0 1466 PUSHACC5 1467 GETFIELD0 1468 PUSHACC5 1469 PUSHACC5 1470 APPLY3 1471 PUSHACC3 1472 PUSHOFFSETCLOSURE0 1473 APPTERM 4, 8 1476 ACC3 1477 BRANCHIF 1482 1479 ACC1 1480 RETURN 4 1482 GETGLOBAL "List.fold_left2" 1484 PUSHGETGLOBALFIELD Pervasives, 2 1487 APPTERM1 5 1489 RESTART 1490 GRAB 3 1492 ACC1 1493 BRANCHIFNOT 1516 1495 ACC2 1496 BRANCHIFNOT 1522 1498 PUSH_RETADDR 1509 1500 ACC6 1501 PUSHACC6 1502 GETFIELD1 1503 PUSHACC6 1504 GETFIELD1 1505 PUSHACC6 1506 PUSHOFFSETCLOSURE0 1507 APPLY 4 1509 PUSHACC3 1510 GETFIELD0 1511 PUSHACC3 1512 GETFIELD0 1513 PUSHACC3 1514 APPTERM3 7 1516 ACC2 1517 BRANCHIF 1522 1519 ACC3 1520 RETURN 4 1522 GETGLOBAL "List.fold_right2" 1524 PUSHGETGLOBALFIELD Pervasives, 2 1527 APPTERM1 5 1529 RESTART 1530 GRAB 1 1532 ACC1 1533 BRANCHIFNOT 1549 1535 ACC1 1536 GETFIELD0 1537 PUSHACC1 1538 APPLY1 1539 BRANCHIFNOT 1547 1541 ACC1 1542 GETFIELD1 1543 PUSHACC1 1544 PUSHOFFSETCLOSURE0 1545 APPTERM2 4 1547 RETURN 2 1549 CONST1 1550 RETURN 2 1552 RESTART 1553 GRAB 1 1555 ACC1 1556 BRANCHIFNOT 1570 1558 ACC1 1559 GETFIELD0 1560 PUSHACC1 1561 APPLY1 1562 BRANCHIF 1570 1564 ACC1 1565 GETFIELD1 1566 PUSHACC1 1567 PUSHOFFSETCLOSURE0 1568 APPTERM2 4 1570 RETURN 2 1572 RESTART 1573 GRAB 2 1575 ACC1 1576 BRANCHIFNOT 1599 1578 ACC2 1579 BRANCHIFNOT 1605 1581 ACC2 1582 GETFIELD0 1583 PUSHACC2 1584 GETFIELD0 1585 PUSHACC2 1586 APPLY2 1587 BRANCHIFNOT 1597 1589 ACC2 1590 GETFIELD1 1591 PUSHACC2 1592 GETFIELD1 1593 PUSHACC2 1594 PUSHOFFSETCLOSURE0 1595 APPTERM3 6 1597 RETURN 3 1599 ACC2 1600 BRANCHIF 1605 1602 CONST1 1603 RETURN 3 1605 GETGLOBAL "List.for_all2" 1607 PUSHGETGLOBALFIELD Pervasives, 2 1610 APPTERM1 4 1612 RESTART 1613 GRAB 2 1615 ACC1 1616 BRANCHIFNOT 1639 1618 ACC2 1619 BRANCHIFNOT 1646 1621 ACC2 1622 GETFIELD0 1623 PUSHACC2 1624 GETFIELD0 1625 PUSHACC2 1626 APPLY2 1627 BRANCHIF 1637 1629 ACC2 1630 GETFIELD1 1631 PUSHACC2 1632 GETFIELD1 1633 PUSHACC2 1634 PUSHOFFSETCLOSURE0 1635 APPTERM3 6 1637 RETURN 3 1639 ACC2 1640 BRANCHIFNOT 1644 1642 BRANCH 1646 1644 RETURN 3 1646 GETGLOBAL "List.exists2" 1648 PUSHGETGLOBALFIELD Pervasives, 2 1651 APPTERM1 4 1653 RESTART 1654 GRAB 1 1656 ACC1 1657 BRANCHIFNOT 1672 1659 ACC0 1660 PUSHACC2 1661 GETFIELD0 1662 C_CALL2 equal 1664 BRANCHIF 1672 1666 ACC1 1667 GETFIELD1 1668 PUSHACC1 1669 PUSHOFFSETCLOSURE0 1670 APPTERM2 4 1672 RETURN 2 1674 RESTART 1675 GRAB 1 1677 ACC1 1678 BRANCHIFNOT 1692 1680 ACC0 1681 PUSHACC2 1682 GETFIELD0 1683 EQ 1684 BRANCHIF 1692 1686 ACC1 1687 GETFIELD1 1688 PUSHACC1 1689 PUSHOFFSETCLOSURE0 1690 APPTERM2 4 1692 RETURN 2 1694 RESTART 1695 GRAB 1 1697 ACC1 1698 BRANCHIFNOT 1719 1700 ACC1 1701 GETFIELD0 1702 PUSHACC1 1703 PUSHACC1 1704 GETFIELD0 1705 C_CALL2 equal 1707 BRANCHIFNOT 1713 1709 ACC0 1710 GETFIELD1 1711 RETURN 3 1713 ACC2 1714 GETFIELD1 1715 PUSHACC2 1716 PUSHOFFSETCLOSURE0 1717 APPTERM2 5 1719 GETGLOBAL Not_found 1721 MAKEBLOCK1 0 1723 RAISE 1724 RESTART 1725 GRAB 1 1727 ACC1 1728 BRANCHIFNOT 1748 1730 ACC1 1731 GETFIELD0 1732 PUSHACC1 1733 PUSHACC1 1734 GETFIELD0 1735 EQ 1736 BRANCHIFNOT 1742 1738 ACC0 1739 GETFIELD1 1740 RETURN 3 1742 ACC2 1743 GETFIELD1 1744 PUSHACC2 1745 PUSHOFFSETCLOSURE0 1746 APPTERM2 5 1748 GETGLOBAL Not_found 1750 MAKEBLOCK1 0 1752 RAISE 1753 RESTART 1754 GRAB 1 1756 ACC1 1757 BRANCHIFNOT 1773 1759 ACC0 1760 PUSHACC2 1761 GETFIELD0 1762 GETFIELD0 1763 C_CALL2 equal 1765 BRANCHIF 1773 1767 ACC1 1768 GETFIELD1 1769 PUSHACC1 1770 PUSHOFFSETCLOSURE0 1771 APPTERM2 4 1773 RETURN 2 1775 RESTART 1776 GRAB 1 1778 ACC1 1779 BRANCHIFNOT 1794 1781 ACC0 1782 PUSHACC2 1783 GETFIELD0 1784 GETFIELD0 1785 EQ 1786 BRANCHIF 1794 1788 ACC1 1789 GETFIELD1 1790 PUSHACC1 1791 PUSHOFFSETCLOSURE0 1792 APPTERM2 4 1794 RETURN 2 1796 RESTART 1797 GRAB 1 1799 ACC1 1800 BRANCHIFNOT 1825 1802 ACC1 1803 GETFIELD0 1804 PUSHACC2 1805 GETFIELD1 1806 PUSHACC2 1807 PUSHACC2 1808 GETFIELD0 1809 C_CALL2 equal 1811 BRANCHIFNOT 1816 1813 ACC0 1814 RETURN 4 1816 ACC0 1817 PUSHACC3 1818 PUSHOFFSETCLOSURE0 1819 APPLY2 1820 PUSHACC2 1821 MAKEBLOCK2 0 1823 POP 2 1825 RETURN 2 1827 RESTART 1828 GRAB 1 1830 ACC1 1831 BRANCHIFNOT 1855 1833 ACC1 1834 GETFIELD0 1835 PUSHACC2 1836 GETFIELD1 1837 PUSHACC2 1838 PUSHACC2 1839 GETFIELD0 1840 EQ 1841 BRANCHIFNOT 1846 1843 ACC0 1844 RETURN 4 1846 ACC0 1847 PUSHACC3 1848 PUSHOFFSETCLOSURE0 1849 APPLY2 1850 PUSHACC2 1851 MAKEBLOCK2 0 1853 POP 2 1855 RETURN 2 1857 RESTART 1858 GRAB 1 1860 ACC1 1861 BRANCHIFNOT 1879 1863 ACC1 1864 GETFIELD0 1865 PUSHACC0 1866 PUSHACC2 1867 APPLY1 1868 BRANCHIFNOT 1873 1870 ACC0 1871 RETURN 3 1873 ACC2 1874 GETFIELD1 1875 PUSHACC2 1876 PUSHOFFSETCLOSURE0 1877 APPTERM2 5 1879 GETGLOBAL Not_found 1881 MAKEBLOCK1 0 1883 RAISE 1884 RESTART 1885 GRAB 2 1887 ACC2 1888 BRANCHIFNOT 1917 1890 ACC2 1891 GETFIELD0 1892 PUSHACC3 1893 GETFIELD1 1894 PUSHACC1 1895 PUSHENVACC2 1896 APPLY1 1897 BRANCHIFNOT 1908 1899 ACC0 1900 PUSHACC4 1901 PUSHACC4 1902 PUSHACC4 1903 MAKEBLOCK2 0 1905 PUSHOFFSETCLOSURE0 1906 APPTERM3 8 1908 ACC0 1909 PUSHACC4 1910 PUSHACC3 1911 MAKEBLOCK2 0 1913 PUSHACC4 1914 PUSHOFFSETCLOSURE0 1915 APPTERM3 8 1917 ACC1 1918 PUSHENVACC1 1919 APPLY1 1920 PUSHACC1 1921 PUSHENVACC1 1922 APPLY1 1923 MAKEBLOCK2 0 1925 RETURN 3 1927 RESTART 1928 GRAB 1 1930 ACC0 1931 PUSHENVACC1 1932 CLOSUREREC 2, 1885 1936 ACC2 1937 PUSHCONST0 1938 PUSHCONST0 1939 PUSHACC3 1940 APPTERM3 6 1942 ACC0 1943 BRANCHIFNOT 1967 1945 ACC0 1946 GETFIELD0 1947 PUSHACC1 1948 GETFIELD1 1949 PUSHOFFSETCLOSURE0 1950 APPLY1 1951 PUSHACC0 1952 GETFIELD1 1953 PUSHACC2 1954 GETFIELD1 1955 MAKEBLOCK2 0 1957 PUSHACC1 1958 GETFIELD0 1959 PUSHACC3 1960 GETFIELD0 1961 MAKEBLOCK2 0 1963 MAKEBLOCK2 0 1965 RETURN 3 1967 GETGLOBAL <0>(0, 0) 1969 RETURN 1 1971 RESTART 1972 GRAB 1 1974 ACC0 1975 BRANCHIFNOT 1996 1977 ACC1 1978 BRANCHIFNOT 2003 1980 ACC1 1981 GETFIELD1 1982 PUSHACC1 1983 GETFIELD1 1984 PUSHOFFSETCLOSURE0 1985 APPLY2 1986 PUSHACC2 1987 GETFIELD0 1988 PUSHACC2 1989 GETFIELD0 1990 MAKEBLOCK2 0 1992 MAKEBLOCK2 0 1994 RETURN 2 1996 ACC1 1997 BRANCHIFNOT 2001 1999 BRANCH 2003 2001 RETURN 2 2003 GETGLOBAL "List.combine" 2005 PUSHGETGLOBALFIELD Pervasives, 2 2008 APPTERM1 3 2010 RESTART 2011 GRAB 1 2013 ACC1 2014 BRANCHIFNOT 2038 2016 ACC1 2017 GETFIELD0 2018 PUSHACC2 2019 GETFIELD1 2020 PUSHACC1 2021 PUSHENVACC2 2022 APPLY1 2023 BRANCHIFNOT 2033 2025 ACC0 2026 PUSHACC3 2027 PUSHACC3 2028 MAKEBLOCK2 0 2030 PUSHOFFSETCLOSURE0 2031 APPTERM2 6 2033 ACC0 2034 PUSHACC3 2035 PUSHOFFSETCLOSURE0 2036 APPTERM2 6 2038 ACC0 2039 PUSHENVACC1 2040 APPTERM1 3 2042 ACC0 2043 PUSHENVACC1 2044 CLOSUREREC 2, 2011 2048 CONST0 2049 PUSHACC1 2050 APPTERM1 3 2052 RESTART 2053 GRAB 2 2055 ACC1 2056 BRANCHIFNOT 2077 2058 ACC2 2059 BRANCHIFNOT 2084 2061 ACC2 2062 GETFIELD1 2063 PUSHACC2 2064 GETFIELD1 2065 PUSHACC2 2066 PUSHACC5 2067 GETFIELD0 2068 PUSHACC5 2069 GETFIELD0 2070 PUSHENVACC1 2071 APPLY2 2072 MAKEBLOCK2 0 2074 PUSHOFFSETCLOSURE0 2075 APPTERM3 6 2077 ACC2 2078 BRANCHIFNOT 2082 2080 BRANCH 2084 2082 RETURN 3 2084 GETGLOBAL "List.rev_map2" 2086 PUSHGETGLOBALFIELD Pervasives, 2 2089 APPTERM1 4 2091 RESTART 2092 GRAB 2 2094 ACC0 2095 CLOSUREREC 1, 2053 2099 ACC3 2100 PUSHACC3 2101 PUSHCONST0 2102 PUSHACC3 2103 APPTERM3 7 2105 RESTART 2106 GRAB 1 2108 ACC1 2109 BRANCHIFNOT 2123 2111 ACC1 2112 GETFIELD1 2113 PUSHACC1 2114 PUSHACC3 2115 GETFIELD0 2116 PUSHENVACC1 2117 APPLY1 2118 MAKEBLOCK2 0 2120 PUSHOFFSETCLOSURE0 2121 APPTERM2 4 2123 ACC0 2124 RETURN 2 2126 RESTART 2127 GRAB 1 2129 ACC0 2130 CLOSUREREC 1, 2106 2134 ACC2 2135 PUSHCONST0 2136 PUSHACC2 2137 APPTERM2 5 2139 CONST0 2140 PUSHACC1 2141 PUSHENVACC1 2142 APPTERM2 3 2144 ACC0 2145 BRANCHIFNOT 2151 2147 ACC0 2148 GETFIELD1 2149 RETURN 1 2151 GETGLOBAL "tl" 2153 PUSHGETGLOBALFIELD Pervasives, 3 2156 APPTERM1 2 2158 ACC0 2159 BRANCHIFNOT 2165 2161 ACC0 2162 GETFIELD0 2163 RETURN 1 2165 GETGLOBAL "hd" 2167 PUSHGETGLOBALFIELD Pervasives, 3 2170 APPTERM1 2 2172 ACC0 2173 PUSHCONST0 2174 PUSHENVACC1 2175 APPTERM2 3 2177 CLOSUREREC 0, 1200 2181 ACC0 2182 CLOSURE 1, 2172 2185 PUSH 2186 CLOSURE 0, 2158 2189 PUSH 2190 CLOSURE 0, 2144 2193 PUSH 2194 CLOSUREREC 0, 1217 2198 GETGLOBALFIELD Pervasives, 16 2201 PUSH 2202 CLOSUREREC 0, 1259 2206 ACC0 2207 CLOSURE 1, 2139 2210 PUSH 2211 CLOSUREREC 0, 1277 2215 CLOSUREREC 0, 1294 2219 CLOSURE 0, 2127 2222 PUSH 2223 CLOSUREREC 0, 1316 2227 CLOSUREREC 0, 1334 2231 CLOSUREREC 0, 1354 2235 CLOSUREREC 0, 1374 2239 CLOSURE 0, 2092 2242 PUSH 2243 CLOSUREREC 0, 1415 2247 CLOSUREREC 0, 1452 2251 CLOSUREREC 0, 1490 2255 CLOSUREREC 0, 1530 2259 CLOSUREREC 0, 1553 2263 CLOSUREREC 0, 1573 2267 CLOSUREREC 0, 1613 2271 CLOSUREREC 0, 1654 2275 CLOSUREREC 0, 1675 2279 CLOSUREREC 0, 1695 2283 CLOSUREREC 0, 1725 2287 CLOSUREREC 0, 1754 2291 CLOSUREREC 0, 1776 2295 CLOSUREREC 0, 1797 2299 CLOSUREREC 0, 1828 2303 CLOSUREREC 0, 1858 2307 ACC 24 2309 CLOSURE 1, 2042 2312 PUSHACC 25 2314 CLOSUREREC 1, 1928 2318 CLOSUREREC 0, 1942 2322 CLOSUREREC 0, 1972 2326 ACC0 2327 PUSHACC2 2328 PUSHACC7 2329 PUSHACC 9 2331 PUSHACC 11 2333 PUSHACC 13 2335 PUSHACC 15 2337 PUSHACC 17 2339 PUSHACC 10 2341 PUSHACC 12 2343 PUSHACC 13 2345 PUSHACC 15 2347 PUSHACC 23 2349 PUSHACC 25 2351 PUSHACC 27 2353 PUSHACC 29 2355 PUSHACC 31 2357 PUSHACC 33 2359 PUSHACC 35 2361 PUSHACC 37 2363 PUSHACC 40 2365 PUSHACC 42 2367 PUSHACC 41 2369 PUSHACC 45 2371 PUSHACC 47 2373 PUSHACC 50 2375 PUSHACC 52 2377 PUSHACC 51 2379 PUSHACC 55 2381 PUSHACC 56 2383 PUSHACC 59 2385 PUSHACC 61 2387 PUSHACC 60 2389 PUSHACC 64 2391 PUSHACC 66 2393 PUSHACC 68 2395 PUSHACC 70 2397 MAKEBLOCK 37, 0 2400 POP 36 2402 SETGLOBAL List 2404 BRANCH 2432 2406 CONST0 2407 PUSHACC1 2408 LEINT 2409 BRANCHIFNOT 2414 2411 CONST0 2412 RETURN 1 2414 ACC0 2415 OFFSETINT -1 2417 PUSHOFFSETCLOSURE0 2418 APPLY1 2419 PUSHACC1 2420 MAKEBLOCK2 0 2422 RETURN 1 2424 RESTART 2425 GRAB 1 2427 ACC1 2428 PUSHACC1 2429 ADDINT 2430 RETURN 2 2432 CLOSUREREC 0, 2406 2436 CONSTINT 300 2438 PUSHACC1 2439 APPLY1 2440 PUSHCONST0 2441 C_CALL1 gc_minor 2443 CONSTINT 150 2445 PUSHCONSTINT 301 2447 MULINT 2448 PUSHACC1 2449 PUSHCONST0 2450 PUSH 2451 CLOSURE 0, 2425 2454 PUSHGETGLOBALFIELD List, 12 2457 APPLY3 2458 NEQ 2459 BRANCHIFNOT 2466 2461 GETGLOBAL Not_found 2463 MAKEBLOCK1 0 2465 RAISE 2466 POP 2 2468 ATOM0 2469 SETGLOBAL T320-gc-1 2471 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t310-alloc-2.ml0000644000175000017500000013354512124403241023202 0ustar tootstootsopen Lib;; let v = Array.make 200000 2 in let t = ref 0 in Array.iter (fun x -> t := !t + x) v; if !t <> 400000 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 746 11 RESTART 12 GRAB 1 14 ACC0 15 BRANCHIFNOT 28 17 ACC1 18 PUSHACC1 19 GETFIELD1 20 PUSHOFFSETCLOSURE0 21 APPLY2 22 PUSHACC1 23 GETFIELD0 24 MAKEBLOCK2 0 26 RETURN 2 28 ACC1 29 RETURN 2 31 RESTART 32 GRAB 3 34 CONST0 35 PUSHACC4 36 LEINT 37 BRANCHIFNOT 42 39 CONST0 40 RETURN 4 42 ACC3 43 PUSHACC3 44 PUSHACC3 45 PUSHACC3 46 C_CALL4 caml_input 48 PUSHCONST0 49 PUSHACC1 50 EQ 51 BRANCHIFNOT 58 53 GETGLOBAL End_of_file 55 MAKEBLOCK1 0 57 RAISE 58 ACC0 59 PUSHACC5 60 SUBINT 61 PUSHACC1 62 PUSHACC5 63 ADDINT 64 PUSHACC4 65 PUSHACC4 66 PUSHOFFSETCLOSURE0 67 APPTERM 4, 9 70 ACC0 71 C_CALL1 caml_input_scan_line 73 PUSHCONST0 74 PUSHACC1 75 EQ 76 BRANCHIFNOT 83 78 GETGLOBAL End_of_file 80 MAKEBLOCK1 0 82 RAISE 83 CONST0 84 PUSHACC1 85 GTINT 86 BRANCHIFNOT 107 88 ACC0 89 OFFSETINT -1 91 C_CALL1 create_string 93 PUSHACC1 94 OFFSETINT -1 96 PUSHCONST0 97 PUSHACC2 98 PUSHACC5 99 C_CALL4 caml_input 101 ACC2 102 C_CALL1 caml_input_char 104 ACC0 105 RETURN 3 107 ACC0 108 NEGINT 109 C_CALL1 create_string 111 PUSHACC1 112 NEGINT 113 PUSHCONST0 114 PUSHACC2 115 PUSHACC5 116 C_CALL4 caml_input 118 CONST0 119 PUSHTRAP 130 121 ACC6 122 PUSHOFFSETCLOSURE0 123 APPLY1 124 PUSHACC5 125 PUSHENVACC1 126 APPLY2 127 POPTRAP 128 RETURN 3 130 PUSHGETGLOBAL End_of_file 132 PUSHACC1 133 GETFIELD0 134 EQ 135 BRANCHIFNOT 140 137 ACC1 138 RETURN 4 140 ACC0 141 RAISE 142 ACC0 143 C_CALL1 caml_flush 145 RETURN 1 147 RESTART 148 GRAB 1 150 ACC1 151 PUSHACC1 152 C_CALL2 caml_output_char 154 RETURN 2 156 RESTART 157 GRAB 1 159 ACC1 160 PUSHACC1 161 C_CALL2 caml_output_char 163 RETURN 2 165 RESTART 166 GRAB 1 168 ACC1 169 PUSHACC1 170 C_CALL2 caml_output_int 172 RETURN 2 174 RESTART 175 GRAB 1 177 ACC1 178 PUSHACC1 179 C_CALL2 caml_seek_out 181 RETURN 2 183 ACC0 184 C_CALL1 caml_pos_out 186 RETURN 1 188 ACC0 189 C_CALL1 caml_channel_size 191 RETURN 1 193 RESTART 194 GRAB 1 196 ACC1 197 PUSHACC1 198 C_CALL2 caml_set_binary_mode 200 RETURN 2 202 ACC0 203 C_CALL1 caml_input_char 205 RETURN 1 207 ACC0 208 C_CALL1 caml_input_char 210 RETURN 1 212 ACC0 213 C_CALL1 caml_input_int 215 RETURN 1 217 ACC0 218 C_CALL1 input_value 220 RETURN 1 222 RESTART 223 GRAB 1 225 ACC1 226 PUSHACC1 227 C_CALL2 caml_seek_in 229 RETURN 2 231 ACC0 232 C_CALL1 caml_pos_in 234 RETURN 1 236 ACC0 237 C_CALL1 caml_channel_size 239 RETURN 1 241 ACC0 242 C_CALL1 caml_close_channel 244 RETURN 1 246 RESTART 247 GRAB 1 249 ACC1 250 PUSHACC1 251 C_CALL2 caml_set_binary_mode 253 RETURN 2 255 CONST0 256 PUSHENVACC1 257 APPLY1 258 ACC0 259 C_CALL1 sys_exit 261 RETURN 1 263 CONST0 264 PUSHENVACC1 265 GETFIELD0 266 APPTERM1 2 268 CONST0 269 PUSHENVACC1 270 APPLY1 271 CONST0 272 PUSHENVACC2 273 APPTERM1 2 275 ENVACC1 276 GETFIELD0 277 PUSHACC0 278 PUSHACC2 279 CLOSURE 2, 268 282 PUSHENVACC1 283 SETFIELD0 284 RETURN 2 286 ENVACC1 287 C_CALL1 caml_flush 289 ENVACC2 290 C_CALL1 caml_flush 292 RETURN 1 294 CONST0 295 PUSHENVACC1 296 APPLY1 297 C_CALL1 float_of_string 299 RETURN 1 301 CONST0 302 PUSHENVACC1 303 APPLY1 304 C_CALL1 int_of_string 306 RETURN 1 308 ENVACC2 309 C_CALL1 caml_flush 311 ENVACC1 312 PUSHENVACC3 313 APPTERM1 2 315 CONSTINT 13 317 PUSHENVACC1 318 C_CALL2 caml_output_char 320 ENVACC1 321 C_CALL1 caml_flush 323 RETURN 1 325 ACC0 326 PUSHENVACC1 327 PUSHENVACC2 328 APPLY2 329 CONSTINT 13 331 PUSHENVACC1 332 C_CALL2 caml_output_char 334 ENVACC1 335 C_CALL1 caml_flush 337 RETURN 1 339 ACC0 340 PUSHENVACC1 341 APPLY1 342 PUSHENVACC2 343 PUSHENVACC3 344 APPTERM2 3 346 ACC0 347 PUSHENVACC1 348 APPLY1 349 PUSHENVACC2 350 PUSHENVACC3 351 APPTERM2 3 353 ACC0 354 PUSHENVACC1 355 PUSHENVACC2 356 APPTERM2 3 358 ACC0 359 PUSHENVACC1 360 C_CALL2 caml_output_char 362 RETURN 1 364 CONSTINT 13 366 PUSHENVACC1 367 C_CALL2 caml_output_char 369 ENVACC1 370 C_CALL1 caml_flush 372 RETURN 1 374 ACC0 375 PUSHENVACC1 376 PUSHENVACC2 377 APPLY2 378 CONSTINT 13 380 PUSHENVACC1 381 C_CALL2 caml_output_char 383 RETURN 1 385 ACC0 386 PUSHENVACC1 387 APPLY1 388 PUSHENVACC2 389 PUSHENVACC3 390 APPTERM2 3 392 ACC0 393 PUSHENVACC1 394 APPLY1 395 PUSHENVACC2 396 PUSHENVACC3 397 APPTERM2 3 399 ACC0 400 PUSHENVACC1 401 PUSHENVACC2 402 APPTERM2 3 404 ACC0 405 PUSHENVACC1 406 C_CALL2 caml_output_char 408 RETURN 1 410 RESTART 411 GRAB 3 413 CONST0 414 PUSHACC3 415 LTINT 416 BRANCHIF 427 418 ACC1 419 C_CALL1 ml_string_length 421 PUSHACC4 422 PUSHACC4 423 ADDINT 424 GTINT 425 BRANCHIFNOT 432 427 GETGLOBAL "really_input" 429 PUSHENVACC1 430 APPTERM1 5 432 ACC3 433 PUSHACC3 434 PUSHACC3 435 PUSHACC3 436 PUSHENVACC2 437 APPTERM 4, 8 440 RESTART 441 GRAB 3 443 CONST0 444 PUSHACC3 445 LTINT 446 BRANCHIF 457 448 ACC1 449 C_CALL1 ml_string_length 451 PUSHACC4 452 PUSHACC4 453 ADDINT 454 GTINT 455 BRANCHIFNOT 462 457 GETGLOBAL "input" 459 PUSHENVACC1 460 APPTERM1 5 462 ACC3 463 PUSHACC3 464 PUSHACC3 465 PUSHACC3 466 C_CALL4 caml_input 468 RETURN 4 470 ACC0 471 PUSHCONST0 472 PUSHGETGLOBAL <0>(0, <0>(6, 0)) 474 PUSHENVACC1 475 APPTERM3 4 477 ACC0 478 PUSHCONST0 479 PUSHGETGLOBAL <0>(0, <0>(7, 0)) 481 PUSHENVACC1 482 APPTERM3 4 484 RESTART 485 GRAB 2 487 ACC1 488 PUSHACC1 489 PUSHACC4 490 C_CALL3 sys_open 492 C_CALL1 caml_open_descriptor 494 RETURN 3 496 ACC0 497 C_CALL1 caml_flush 499 ACC0 500 C_CALL1 caml_close_channel 502 RETURN 1 504 RESTART 505 GRAB 1 507 CONST0 508 PUSHACC2 509 PUSHACC2 510 C_CALL3 output_value 512 RETURN 2 514 RESTART 515 GRAB 3 517 CONST0 518 PUSHACC3 519 LTINT 520 BRANCHIF 531 522 ACC1 523 C_CALL1 ml_string_length 525 PUSHACC4 526 PUSHACC4 527 ADDINT 528 GTINT 529 BRANCHIFNOT 536 531 GETGLOBAL "output" 533 PUSHENVACC1 534 APPTERM1 5 536 ACC3 537 PUSHACC3 538 PUSHACC3 539 PUSHACC3 540 C_CALL4 caml_output 542 RETURN 4 544 RESTART 545 GRAB 1 547 ACC1 548 C_CALL1 ml_string_length 550 PUSHCONST0 551 PUSHACC3 552 PUSHACC3 553 C_CALL4 caml_output 555 RETURN 2 557 ACC0 558 PUSHCONSTINT 438 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0)))) 562 PUSHENVACC1 563 APPTERM3 4 565 ACC0 566 PUSHCONSTINT 438 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0)))) 570 PUSHENVACC1 571 APPTERM3 4 573 RESTART 574 GRAB 2 576 ACC1 577 PUSHACC1 578 PUSHACC4 579 C_CALL3 sys_open 581 C_CALL1 caml_open_descriptor 583 RETURN 3 585 ACC0 586 PUSHGETGLOBAL "%.12g" 588 C_CALL2 format_float 590 RETURN 1 592 ACC0 593 PUSHGETGLOBAL "%d" 595 C_CALL2 format_int 597 RETURN 1 599 GETGLOBAL "false" 601 PUSHACC1 602 C_CALL2 string_equal 604 BRANCHIFNOT 609 606 CONST0 607 RETURN 1 609 GETGLOBAL "true" 611 PUSHACC1 612 C_CALL2 string_equal 614 BRANCHIFNOT 619 616 CONST1 617 RETURN 1 619 GETGLOBAL "bool_of_string" 621 PUSHENVACC1 622 APPTERM1 2 624 ACC0 625 BRANCHIFNOT 631 627 GETGLOBAL "true" 629 RETURN 1 631 GETGLOBAL "false" 633 RETURN 1 635 CONST0 636 PUSHACC1 637 LTINT 638 BRANCHIF 646 640 CONSTINT 255 642 PUSHACC1 643 GTINT 644 BRANCHIFNOT 651 646 GETGLOBAL "char_of_int" 648 PUSHENVACC1 649 APPTERM1 2 651 ACC0 652 RETURN 1 654 RESTART 655 GRAB 1 657 ACC0 658 C_CALL1 ml_string_length 660 PUSHACC2 661 C_CALL1 ml_string_length 663 PUSHACC0 664 PUSHACC2 665 ADDINT 666 C_CALL1 create_string 668 PUSHACC2 669 PUSHCONST0 670 PUSHACC2 671 PUSHCONST0 672 PUSHACC7 673 C_CALL5 blit_string 675 ACC1 676 PUSHACC3 677 PUSHACC2 678 PUSHCONST0 679 PUSHACC 8 681 C_CALL5 blit_string 683 ACC0 684 RETURN 5 686 CONSTINT -1 688 PUSHACC1 689 XORINT 690 RETURN 1 692 CONST0 693 PUSHACC1 694 GEINT 695 BRANCHIFNOT 700 697 ACC0 698 RETURN 1 700 ACC0 701 NEGINT 702 RETURN 1 704 RESTART 705 GRAB 1 707 ACC1 708 PUSHACC1 709 C_CALL2 greaterequal 711 BRANCHIFNOT 716 713 ACC0 714 RETURN 2 716 ACC1 717 RETURN 2 719 RESTART 720 GRAB 1 722 ACC1 723 PUSHACC1 724 C_CALL2 lessequal 726 BRANCHIFNOT 731 728 ACC0 729 RETURN 2 731 ACC1 732 RETURN 2 734 ACC0 735 PUSHGETGLOBAL Invalid_argument 737 MAKEBLOCK2 0 739 RAISE 740 ACC0 741 PUSHGETGLOBAL Failure 743 MAKEBLOCK2 0 745 RAISE 746 CLOSURE 0, 740 749 PUSH 750 CLOSURE 0, 734 753 PUSHGETGLOBAL "Pervasives.Exit" 755 MAKEBLOCK1 0 757 PUSHGETGLOBAL "Pervasives.Assert_failure" 759 MAKEBLOCK1 0 761 PUSH 762 CLOSURE 0, 720 765 PUSH 766 CLOSURE 0, 705 769 PUSH 770 CLOSURE 0, 692 773 PUSH 774 CLOSURE 0, 686 777 PUSHCONST0 778 PUSHCONSTINT 31 780 PUSHCONST1 781 LSLINT 782 EQ 783 BRANCHIFNOT 789 785 CONSTINT 30 787 BRANCH 791 789 CONSTINT 62 791 PUSHCONST1 792 LSLINT 793 PUSHACC0 794 OFFSETINT -1 796 PUSH 797 CLOSURE 0, 655 800 PUSHACC 9 802 CLOSURE 1, 635 805 PUSH 806 CLOSURE 0, 624 809 PUSHACC 11 811 CLOSURE 1, 599 814 PUSH 815 CLOSURE 0, 592 818 PUSH 819 CLOSURE 0, 585 822 PUSH 823 CLOSUREREC 0, 12 827 CONST0 828 C_CALL1 caml_open_descriptor 830 PUSHCONST1 831 C_CALL1 caml_open_descriptor 833 PUSHCONST2 834 C_CALL1 caml_open_descriptor 836 PUSH 837 CLOSURE 0, 574 840 PUSHACC0 841 CLOSURE 1, 565 844 PUSHACC1 845 CLOSURE 1, 557 848 PUSH 849 CLOSURE 0, 545 852 PUSHACC 22 854 CLOSURE 1, 515 857 PUSH 858 CLOSURE 0, 505 861 PUSH 862 CLOSURE 0, 496 865 PUSH 866 CLOSURE 0, 485 869 PUSHACC0 870 CLOSURE 1, 477 873 PUSHACC1 874 CLOSURE 1, 470 877 PUSHACC 28 879 CLOSURE 1, 441 882 PUSH 883 CLOSUREREC 0, 32 887 ACC0 888 PUSHACC 31 890 CLOSURE 2, 411 893 PUSHACC 22 895 CLOSUREREC 1, 70 899 ACC 15 901 CLOSURE 1, 404 904 PUSHACC 11 906 PUSHACC 17 908 CLOSURE 2, 399 911 PUSHACC 12 913 PUSHACC 18 915 PUSHACC 23 917 CLOSURE 3, 392 920 PUSHACC 13 922 PUSHACC 19 924 PUSHACC 23 926 CLOSURE 3, 385 929 PUSHACC 14 931 PUSHACC 20 933 CLOSURE 2, 374 936 PUSHACC 20 938 CLOSURE 1, 364 941 PUSHACC 20 943 CLOSURE 1, 358 946 PUSHACC 17 948 PUSHACC 22 950 CLOSURE 2, 353 953 PUSHACC 18 955 PUSHACC 23 957 PUSHACC 29 959 CLOSURE 3, 346 962 PUSHACC 19 964 PUSHACC 24 966 PUSHACC 29 968 CLOSURE 3, 339 971 PUSHACC 20 973 PUSHACC 25 975 CLOSURE 2, 325 978 PUSHACC 25 980 CLOSURE 1, 315 983 PUSHACC 12 985 PUSHACC 28 987 PUSHACC 30 989 CLOSURE 3, 308 992 PUSHACC0 993 CLOSURE 1, 301 996 PUSHACC1 997 CLOSURE 1, 294 1000 PUSHACC 29 1002 PUSHACC 31 1004 CLOSURE 2, 286 1007 MAKEBLOCK1 0 1009 PUSHACC0 1010 CLOSURE 1, 275 1013 PUSHACC1 1014 CLOSURE 1, 263 1017 PUSHACC0 1018 CLOSURE 1, 255 1021 PUSHACC1 1022 PUSHACC 22 1024 PUSHACC4 1025 PUSHACC3 1026 PUSH 1027 CLOSURE 0, 247 1030 PUSH 1031 CLOSURE 0, 241 1034 PUSH 1035 CLOSURE 0, 236 1038 PUSH 1039 CLOSURE 0, 231 1042 PUSH 1043 CLOSURE 0, 223 1046 PUSH 1047 CLOSURE 0, 217 1050 PUSH 1051 CLOSURE 0, 212 1054 PUSH 1055 CLOSURE 0, 207 1058 PUSHACC 32 1060 PUSHACC 35 1062 PUSHACC 33 1064 PUSH 1065 CLOSURE 0, 202 1068 PUSHACC 41 1070 PUSHACC 40 1072 PUSHACC 42 1074 PUSH 1075 CLOSURE 0, 194 1078 PUSHACC 46 1080 PUSH 1081 CLOSURE 0, 188 1084 PUSH 1085 CLOSURE 0, 183 1088 PUSH 1089 CLOSURE 0, 175 1092 PUSHACC 51 1094 PUSH 1095 CLOSURE 0, 166 1098 PUSH 1099 CLOSURE 0, 157 1102 PUSHACC 55 1104 PUSHACC 57 1106 PUSH 1107 CLOSURE 0, 148 1110 PUSH 1111 CLOSURE 0, 142 1114 PUSHACC 63 1116 PUSHACC 62 1118 PUSHACC 64 1120 PUSHACC 38 1122 PUSHACC 40 1124 PUSHACC 42 1126 PUSHACC 44 1128 PUSHACC 46 1130 PUSHACC 48 1132 PUSHACC 50 1134 PUSHACC 52 1136 PUSHACC 54 1138 PUSHACC 56 1140 PUSHACC 58 1142 PUSHACC 60 1144 PUSHACC 62 1146 PUSHACC 64 1148 PUSHACC 66 1150 PUSHACC 82 1152 PUSHACC 84 1154 PUSHACC 86 1156 PUSHACC 88 1158 PUSHACC 90 1160 PUSHACC 92 1162 PUSHACC 94 1164 PUSHACC 96 1166 PUSHACC 98 1168 PUSHACC 100 1170 PUSHACC 104 1172 PUSHACC 104 1174 PUSHACC 104 1176 PUSHACC 108 1178 PUSHACC 110 1180 PUSHACC 112 1182 PUSHACC 117 1184 PUSHACC 117 1186 PUSHACC 117 1188 PUSHACC 117 1190 MAKEBLOCK 69, 0 1193 POP 53 1195 SETGLOBAL Pervasives 1197 BRANCH 2177 1199 RESTART 1200 GRAB 1 1202 ACC1 1203 BRANCHIFNOT 1213 1205 ACC1 1206 GETFIELD1 1207 PUSHACC1 1208 OFFSETINT 1 1210 PUSHOFFSETCLOSURE0 1211 APPTERM2 4 1213 ACC0 1214 RETURN 2 1216 RESTART 1217 GRAB 1 1219 ACC0 1220 BRANCHIFNOT 1251 1222 CONST0 1223 PUSHACC2 1224 EQ 1225 BRANCHIFNOT 1231 1227 ACC0 1228 GETFIELD0 1229 RETURN 2 1231 CONST0 1232 PUSHACC2 1233 GTINT 1234 BRANCHIFNOT 1244 1236 ACC1 1237 OFFSETINT -1 1239 PUSHACC1 1240 GETFIELD1 1241 PUSHOFFSETCLOSURE0 1242 APPTERM2 4 1244 GETGLOBAL "List.nth" 1246 PUSHGETGLOBALFIELD Pervasives, 2 1249 APPTERM1 3 1251 GETGLOBAL "nth" 1253 PUSHGETGLOBALFIELD Pervasives, 3 1256 APPTERM1 3 1258 RESTART 1259 GRAB 1 1261 ACC0 1262 BRANCHIFNOT 1274 1264 ACC1 1265 PUSHACC1 1266 GETFIELD0 1267 MAKEBLOCK2 0 1269 PUSHACC1 1270 GETFIELD1 1271 PUSHOFFSETCLOSURE0 1272 APPTERM2 4 1274 ACC1 1275 RETURN 2 1277 ACC0 1278 BRANCHIFNOT 1291 1280 ACC0 1281 GETFIELD1 1282 PUSHOFFSETCLOSURE0 1283 APPLY1 1284 PUSHACC1 1285 GETFIELD0 1286 PUSHGETGLOBALFIELD Pervasives, 16 1289 APPTERM2 3 1291 RETURN 1 1293 RESTART 1294 GRAB 1 1296 ACC1 1297 BRANCHIFNOT 1313 1299 ACC1 1300 GETFIELD0 1301 PUSHACC1 1302 APPLY1 1303 PUSHACC2 1304 GETFIELD1 1305 PUSHACC2 1306 PUSHOFFSETCLOSURE0 1307 APPLY2 1308 PUSHACC1 1309 MAKEBLOCK2 0 1311 POP 1 1313 RETURN 2 1315 RESTART 1316 GRAB 1 1318 ACC1 1319 BRANCHIFNOT 1331 1321 ACC1 1322 GETFIELD0 1323 PUSHACC1 1324 APPLY1 1325 ACC1 1326 GETFIELD1 1327 PUSHACC1 1328 PUSHOFFSETCLOSURE0 1329 APPTERM2 4 1331 RETURN 2 1333 RESTART 1334 GRAB 2 1336 ACC2 1337 BRANCHIFNOT 1350 1339 ACC2 1340 GETFIELD1 1341 PUSHACC3 1342 GETFIELD0 1343 PUSHACC3 1344 PUSHACC3 1345 APPLY2 1346 PUSHACC2 1347 PUSHOFFSETCLOSURE0 1348 APPTERM3 6 1350 ACC1 1351 RETURN 3 1353 RESTART 1354 GRAB 2 1356 ACC1 1357 BRANCHIFNOT 1370 1359 ACC2 1360 PUSHACC2 1361 GETFIELD1 1362 PUSHACC2 1363 PUSHOFFSETCLOSURE0 1364 APPLY3 1365 PUSHACC2 1366 GETFIELD0 1367 PUSHACC2 1368 APPTERM2 5 1370 ACC2 1371 RETURN 3 1373 RESTART 1374 GRAB 2 1376 ACC1 1377 BRANCHIFNOT 1400 1379 ACC2 1380 BRANCHIFNOT 1407 1382 ACC2 1383 GETFIELD0 1384 PUSHACC2 1385 GETFIELD0 1386 PUSHACC2 1387 APPLY2 1388 PUSHACC3 1389 GETFIELD1 1390 PUSHACC3 1391 GETFIELD1 1392 PUSHACC3 1393 PUSHOFFSETCLOSURE0 1394 APPLY3 1395 PUSHACC1 1396 MAKEBLOCK2 0 1398 RETURN 4 1400 ACC2 1401 BRANCHIFNOT 1405 1403 BRANCH 1407 1405 RETURN 3 1407 GETGLOBAL "List.map2" 1409 PUSHGETGLOBALFIELD Pervasives, 2 1412 APPTERM1 4 1414 RESTART 1415 GRAB 2 1417 ACC1 1418 BRANCHIFNOT 1437 1420 ACC2 1421 BRANCHIFNOT 1444 1423 ACC2 1424 GETFIELD0 1425 PUSHACC2 1426 GETFIELD0 1427 PUSHACC2 1428 APPLY2 1429 ACC2 1430 GETFIELD1 1431 PUSHACC2 1432 GETFIELD1 1433 PUSHACC2 1434 PUSHOFFSETCLOSURE0 1435 APPTERM3 6 1437 ACC2 1438 BRANCHIFNOT 1442 1440 BRANCH 1444 1442 RETURN 3 1444 GETGLOBAL "List.iter2" 1446 PUSHGETGLOBALFIELD Pervasives, 2 1449 APPTERM1 4 1451 RESTART 1452 GRAB 3 1454 ACC2 1455 BRANCHIFNOT 1476 1457 ACC3 1458 BRANCHIFNOT 1482 1460 ACC3 1461 GETFIELD1 1462 PUSHACC3 1463 GETFIELD1 1464 PUSHACC5 1465 GETFIELD0 1466 PUSHACC5 1467 GETFIELD0 1468 PUSHACC5 1469 PUSHACC5 1470 APPLY3 1471 PUSHACC3 1472 PUSHOFFSETCLOSURE0 1473 APPTERM 4, 8 1476 ACC3 1477 BRANCHIF 1482 1479 ACC1 1480 RETURN 4 1482 GETGLOBAL "List.fold_left2" 1484 PUSHGETGLOBALFIELD Pervasives, 2 1487 APPTERM1 5 1489 RESTART 1490 GRAB 3 1492 ACC1 1493 BRANCHIFNOT 1516 1495 ACC2 1496 BRANCHIFNOT 1522 1498 PUSH_RETADDR 1509 1500 ACC6 1501 PUSHACC6 1502 GETFIELD1 1503 PUSHACC6 1504 GETFIELD1 1505 PUSHACC6 1506 PUSHOFFSETCLOSURE0 1507 APPLY 4 1509 PUSHACC3 1510 GETFIELD0 1511 PUSHACC3 1512 GETFIELD0 1513 PUSHACC3 1514 APPTERM3 7 1516 ACC2 1517 BRANCHIF 1522 1519 ACC3 1520 RETURN 4 1522 GETGLOBAL "List.fold_right2" 1524 PUSHGETGLOBALFIELD Pervasives, 2 1527 APPTERM1 5 1529 RESTART 1530 GRAB 1 1532 ACC1 1533 BRANCHIFNOT 1549 1535 ACC1 1536 GETFIELD0 1537 PUSHACC1 1538 APPLY1 1539 BRANCHIFNOT 1547 1541 ACC1 1542 GETFIELD1 1543 PUSHACC1 1544 PUSHOFFSETCLOSURE0 1545 APPTERM2 4 1547 RETURN 2 1549 CONST1 1550 RETURN 2 1552 RESTART 1553 GRAB 1 1555 ACC1 1556 BRANCHIFNOT 1570 1558 ACC1 1559 GETFIELD0 1560 PUSHACC1 1561 APPLY1 1562 BRANCHIF 1570 1564 ACC1 1565 GETFIELD1 1566 PUSHACC1 1567 PUSHOFFSETCLOSURE0 1568 APPTERM2 4 1570 RETURN 2 1572 RESTART 1573 GRAB 2 1575 ACC1 1576 BRANCHIFNOT 1599 1578 ACC2 1579 BRANCHIFNOT 1605 1581 ACC2 1582 GETFIELD0 1583 PUSHACC2 1584 GETFIELD0 1585 PUSHACC2 1586 APPLY2 1587 BRANCHIFNOT 1597 1589 ACC2 1590 GETFIELD1 1591 PUSHACC2 1592 GETFIELD1 1593 PUSHACC2 1594 PUSHOFFSETCLOSURE0 1595 APPTERM3 6 1597 RETURN 3 1599 ACC2 1600 BRANCHIF 1605 1602 CONST1 1603 RETURN 3 1605 GETGLOBAL "List.for_all2" 1607 PUSHGETGLOBALFIELD Pervasives, 2 1610 APPTERM1 4 1612 RESTART 1613 GRAB 2 1615 ACC1 1616 BRANCHIFNOT 1639 1618 ACC2 1619 BRANCHIFNOT 1646 1621 ACC2 1622 GETFIELD0 1623 PUSHACC2 1624 GETFIELD0 1625 PUSHACC2 1626 APPLY2 1627 BRANCHIF 1637 1629 ACC2 1630 GETFIELD1 1631 PUSHACC2 1632 GETFIELD1 1633 PUSHACC2 1634 PUSHOFFSETCLOSURE0 1635 APPTERM3 6 1637 RETURN 3 1639 ACC2 1640 BRANCHIFNOT 1644 1642 BRANCH 1646 1644 RETURN 3 1646 GETGLOBAL "List.exists2" 1648 PUSHGETGLOBALFIELD Pervasives, 2 1651 APPTERM1 4 1653 RESTART 1654 GRAB 1 1656 ACC1 1657 BRANCHIFNOT 1672 1659 ACC0 1660 PUSHACC2 1661 GETFIELD0 1662 C_CALL2 equal 1664 BRANCHIF 1672 1666 ACC1 1667 GETFIELD1 1668 PUSHACC1 1669 PUSHOFFSETCLOSURE0 1670 APPTERM2 4 1672 RETURN 2 1674 RESTART 1675 GRAB 1 1677 ACC1 1678 BRANCHIFNOT 1692 1680 ACC0 1681 PUSHACC2 1682 GETFIELD0 1683 EQ 1684 BRANCHIF 1692 1686 ACC1 1687 GETFIELD1 1688 PUSHACC1 1689 PUSHOFFSETCLOSURE0 1690 APPTERM2 4 1692 RETURN 2 1694 RESTART 1695 GRAB 1 1697 ACC1 1698 BRANCHIFNOT 1719 1700 ACC1 1701 GETFIELD0 1702 PUSHACC1 1703 PUSHACC1 1704 GETFIELD0 1705 C_CALL2 equal 1707 BRANCHIFNOT 1713 1709 ACC0 1710 GETFIELD1 1711 RETURN 3 1713 ACC2 1714 GETFIELD1 1715 PUSHACC2 1716 PUSHOFFSETCLOSURE0 1717 APPTERM2 5 1719 GETGLOBAL Not_found 1721 MAKEBLOCK1 0 1723 RAISE 1724 RESTART 1725 GRAB 1 1727 ACC1 1728 BRANCHIFNOT 1748 1730 ACC1 1731 GETFIELD0 1732 PUSHACC1 1733 PUSHACC1 1734 GETFIELD0 1735 EQ 1736 BRANCHIFNOT 1742 1738 ACC0 1739 GETFIELD1 1740 RETURN 3 1742 ACC2 1743 GETFIELD1 1744 PUSHACC2 1745 PUSHOFFSETCLOSURE0 1746 APPTERM2 5 1748 GETGLOBAL Not_found 1750 MAKEBLOCK1 0 1752 RAISE 1753 RESTART 1754 GRAB 1 1756 ACC1 1757 BRANCHIFNOT 1773 1759 ACC0 1760 PUSHACC2 1761 GETFIELD0 1762 GETFIELD0 1763 C_CALL2 equal 1765 BRANCHIF 1773 1767 ACC1 1768 GETFIELD1 1769 PUSHACC1 1770 PUSHOFFSETCLOSURE0 1771 APPTERM2 4 1773 RETURN 2 1775 RESTART 1776 GRAB 1 1778 ACC1 1779 BRANCHIFNOT 1794 1781 ACC0 1782 PUSHACC2 1783 GETFIELD0 1784 GETFIELD0 1785 EQ 1786 BRANCHIF 1794 1788 ACC1 1789 GETFIELD1 1790 PUSHACC1 1791 PUSHOFFSETCLOSURE0 1792 APPTERM2 4 1794 RETURN 2 1796 RESTART 1797 GRAB 1 1799 ACC1 1800 BRANCHIFNOT 1825 1802 ACC1 1803 GETFIELD0 1804 PUSHACC2 1805 GETFIELD1 1806 PUSHACC2 1807 PUSHACC2 1808 GETFIELD0 1809 C_CALL2 equal 1811 BRANCHIFNOT 1816 1813 ACC0 1814 RETURN 4 1816 ACC0 1817 PUSHACC3 1818 PUSHOFFSETCLOSURE0 1819 APPLY2 1820 PUSHACC2 1821 MAKEBLOCK2 0 1823 POP 2 1825 RETURN 2 1827 RESTART 1828 GRAB 1 1830 ACC1 1831 BRANCHIFNOT 1855 1833 ACC1 1834 GETFIELD0 1835 PUSHACC2 1836 GETFIELD1 1837 PUSHACC2 1838 PUSHACC2 1839 GETFIELD0 1840 EQ 1841 BRANCHIFNOT 1846 1843 ACC0 1844 RETURN 4 1846 ACC0 1847 PUSHACC3 1848 PUSHOFFSETCLOSURE0 1849 APPLY2 1850 PUSHACC2 1851 MAKEBLOCK2 0 1853 POP 2 1855 RETURN 2 1857 RESTART 1858 GRAB 1 1860 ACC1 1861 BRANCHIFNOT 1879 1863 ACC1 1864 GETFIELD0 1865 PUSHACC0 1866 PUSHACC2 1867 APPLY1 1868 BRANCHIFNOT 1873 1870 ACC0 1871 RETURN 3 1873 ACC2 1874 GETFIELD1 1875 PUSHACC2 1876 PUSHOFFSETCLOSURE0 1877 APPTERM2 5 1879 GETGLOBAL Not_found 1881 MAKEBLOCK1 0 1883 RAISE 1884 RESTART 1885 GRAB 2 1887 ACC2 1888 BRANCHIFNOT 1917 1890 ACC2 1891 GETFIELD0 1892 PUSHACC3 1893 GETFIELD1 1894 PUSHACC1 1895 PUSHENVACC2 1896 APPLY1 1897 BRANCHIFNOT 1908 1899 ACC0 1900 PUSHACC4 1901 PUSHACC4 1902 PUSHACC4 1903 MAKEBLOCK2 0 1905 PUSHOFFSETCLOSURE0 1906 APPTERM3 8 1908 ACC0 1909 PUSHACC4 1910 PUSHACC3 1911 MAKEBLOCK2 0 1913 PUSHACC4 1914 PUSHOFFSETCLOSURE0 1915 APPTERM3 8 1917 ACC1 1918 PUSHENVACC1 1919 APPLY1 1920 PUSHACC1 1921 PUSHENVACC1 1922 APPLY1 1923 MAKEBLOCK2 0 1925 RETURN 3 1927 RESTART 1928 GRAB 1 1930 ACC0 1931 PUSHENVACC1 1932 CLOSUREREC 2, 1885 1936 ACC2 1937 PUSHCONST0 1938 PUSHCONST0 1939 PUSHACC3 1940 APPTERM3 6 1942 ACC0 1943 BRANCHIFNOT 1967 1945 ACC0 1946 GETFIELD0 1947 PUSHACC1 1948 GETFIELD1 1949 PUSHOFFSETCLOSURE0 1950 APPLY1 1951 PUSHACC0 1952 GETFIELD1 1953 PUSHACC2 1954 GETFIELD1 1955 MAKEBLOCK2 0 1957 PUSHACC1 1958 GETFIELD0 1959 PUSHACC3 1960 GETFIELD0 1961 MAKEBLOCK2 0 1963 MAKEBLOCK2 0 1965 RETURN 3 1967 GETGLOBAL <0>(0, 0) 1969 RETURN 1 1971 RESTART 1972 GRAB 1 1974 ACC0 1975 BRANCHIFNOT 1996 1977 ACC1 1978 BRANCHIFNOT 2003 1980 ACC1 1981 GETFIELD1 1982 PUSHACC1 1983 GETFIELD1 1984 PUSHOFFSETCLOSURE0 1985 APPLY2 1986 PUSHACC2 1987 GETFIELD0 1988 PUSHACC2 1989 GETFIELD0 1990 MAKEBLOCK2 0 1992 MAKEBLOCK2 0 1994 RETURN 2 1996 ACC1 1997 BRANCHIFNOT 2001 1999 BRANCH 2003 2001 RETURN 2 2003 GETGLOBAL "List.combine" 2005 PUSHGETGLOBALFIELD Pervasives, 2 2008 APPTERM1 3 2010 RESTART 2011 GRAB 1 2013 ACC1 2014 BRANCHIFNOT 2038 2016 ACC1 2017 GETFIELD0 2018 PUSHACC2 2019 GETFIELD1 2020 PUSHACC1 2021 PUSHENVACC2 2022 APPLY1 2023 BRANCHIFNOT 2033 2025 ACC0 2026 PUSHACC3 2027 PUSHACC3 2028 MAKEBLOCK2 0 2030 PUSHOFFSETCLOSURE0 2031 APPTERM2 6 2033 ACC0 2034 PUSHACC3 2035 PUSHOFFSETCLOSURE0 2036 APPTERM2 6 2038 ACC0 2039 PUSHENVACC1 2040 APPTERM1 3 2042 ACC0 2043 PUSHENVACC1 2044 CLOSUREREC 2, 2011 2048 CONST0 2049 PUSHACC1 2050 APPTERM1 3 2052 RESTART 2053 GRAB 2 2055 ACC1 2056 BRANCHIFNOT 2077 2058 ACC2 2059 BRANCHIFNOT 2084 2061 ACC2 2062 GETFIELD1 2063 PUSHACC2 2064 GETFIELD1 2065 PUSHACC2 2066 PUSHACC5 2067 GETFIELD0 2068 PUSHACC5 2069 GETFIELD0 2070 PUSHENVACC1 2071 APPLY2 2072 MAKEBLOCK2 0 2074 PUSHOFFSETCLOSURE0 2075 APPTERM3 6 2077 ACC2 2078 BRANCHIFNOT 2082 2080 BRANCH 2084 2082 RETURN 3 2084 GETGLOBAL "List.rev_map2" 2086 PUSHGETGLOBALFIELD Pervasives, 2 2089 APPTERM1 4 2091 RESTART 2092 GRAB 2 2094 ACC0 2095 CLOSUREREC 1, 2053 2099 ACC3 2100 PUSHACC3 2101 PUSHCONST0 2102 PUSHACC3 2103 APPTERM3 7 2105 RESTART 2106 GRAB 1 2108 ACC1 2109 BRANCHIFNOT 2123 2111 ACC1 2112 GETFIELD1 2113 PUSHACC1 2114 PUSHACC3 2115 GETFIELD0 2116 PUSHENVACC1 2117 APPLY1 2118 MAKEBLOCK2 0 2120 PUSHOFFSETCLOSURE0 2121 APPTERM2 4 2123 ACC0 2124 RETURN 2 2126 RESTART 2127 GRAB 1 2129 ACC0 2130 CLOSUREREC 1, 2106 2134 ACC2 2135 PUSHCONST0 2136 PUSHACC2 2137 APPTERM2 5 2139 CONST0 2140 PUSHACC1 2141 PUSHENVACC1 2142 APPTERM2 3 2144 ACC0 2145 BRANCHIFNOT 2151 2147 ACC0 2148 GETFIELD1 2149 RETURN 1 2151 GETGLOBAL "tl" 2153 PUSHGETGLOBALFIELD Pervasives, 3 2156 APPTERM1 2 2158 ACC0 2159 BRANCHIFNOT 2165 2161 ACC0 2162 GETFIELD0 2163 RETURN 1 2165 GETGLOBAL "hd" 2167 PUSHGETGLOBALFIELD Pervasives, 3 2170 APPTERM1 2 2172 ACC0 2173 PUSHCONST0 2174 PUSHENVACC1 2175 APPTERM2 3 2177 CLOSUREREC 0, 1200 2181 ACC0 2182 CLOSURE 1, 2172 2185 PUSH 2186 CLOSURE 0, 2158 2189 PUSH 2190 CLOSURE 0, 2144 2193 PUSH 2194 CLOSUREREC 0, 1217 2198 GETGLOBALFIELD Pervasives, 16 2201 PUSH 2202 CLOSUREREC 0, 1259 2206 ACC0 2207 CLOSURE 1, 2139 2210 PUSH 2211 CLOSUREREC 0, 1277 2215 CLOSUREREC 0, 1294 2219 CLOSURE 0, 2127 2222 PUSH 2223 CLOSUREREC 0, 1316 2227 CLOSUREREC 0, 1334 2231 CLOSUREREC 0, 1354 2235 CLOSUREREC 0, 1374 2239 CLOSURE 0, 2092 2242 PUSH 2243 CLOSUREREC 0, 1415 2247 CLOSUREREC 0, 1452 2251 CLOSUREREC 0, 1490 2255 CLOSUREREC 0, 1530 2259 CLOSUREREC 0, 1553 2263 CLOSUREREC 0, 1573 2267 CLOSUREREC 0, 1613 2271 CLOSUREREC 0, 1654 2275 CLOSUREREC 0, 1675 2279 CLOSUREREC 0, 1695 2283 CLOSUREREC 0, 1725 2287 CLOSUREREC 0, 1754 2291 CLOSUREREC 0, 1776 2295 CLOSUREREC 0, 1797 2299 CLOSUREREC 0, 1828 2303 CLOSUREREC 0, 1858 2307 ACC 24 2309 CLOSURE 1, 2042 2312 PUSHACC 25 2314 CLOSUREREC 1, 1928 2318 CLOSUREREC 0, 1942 2322 CLOSUREREC 0, 1972 2326 ACC0 2327 PUSHACC2 2328 PUSHACC7 2329 PUSHACC 9 2331 PUSHACC 11 2333 PUSHACC 13 2335 PUSHACC 15 2337 PUSHACC 17 2339 PUSHACC 10 2341 PUSHACC 12 2343 PUSHACC 13 2345 PUSHACC 15 2347 PUSHACC 23 2349 PUSHACC 25 2351 PUSHACC 27 2353 PUSHACC 29 2355 PUSHACC 31 2357 PUSHACC 33 2359 PUSHACC 35 2361 PUSHACC 37 2363 PUSHACC 40 2365 PUSHACC 42 2367 PUSHACC 41 2369 PUSHACC 45 2371 PUSHACC 47 2373 PUSHACC 50 2375 PUSHACC 52 2377 PUSHACC 51 2379 PUSHACC 55 2381 PUSHACC 56 2383 PUSHACC 59 2385 PUSHACC 61 2387 PUSHACC 60 2389 PUSHACC 64 2391 PUSHACC 66 2393 PUSHACC 68 2395 PUSHACC 70 2397 MAKEBLOCK 37, 0 2400 POP 36 2402 SETGLOBAL List 2404 BRANCH 3341 2406 RESTART 2407 GRAB 2 2409 ACC2 2410 PUSHACC2 2411 VECTLENGTH 2412 OFFSETINT -1 2414 PUSHCONST0 2415 PUSH 2416 BRANCH 2433 2418 CHECK_SIGNALS 2419 ACC2 2420 PUSHACC2 2421 PUSHACC6 2422 C_CALL2 array_unsafe_get 2424 PUSHACC5 2425 APPLY2 2426 ASSIGN 2 2428 ACC1 2429 OFFSETINT -1 2431 ASSIGN 1 2433 ACC0 2434 PUSHACC2 2435 GEINT 2436 BRANCHIF 2418 2438 CONST0 2439 POP 2 2441 ACC0 2442 RETURN 4 2444 RESTART 2445 GRAB 2 2447 ACC1 2448 PUSHCONST0 2449 PUSHACC4 2450 VECTLENGTH 2451 OFFSETINT -1 2453 PUSH 2454 BRANCH 2471 2456 CHECK_SIGNALS 2457 ACC1 2458 PUSHACC6 2459 C_CALL2 array_unsafe_get 2461 PUSHACC3 2462 PUSHACC5 2463 APPLY2 2464 ASSIGN 2 2466 ACC1 2467 OFFSETINT 1 2469 ASSIGN 1 2471 ACC0 2472 PUSHACC2 2473 LEINT 2474 BRANCHIF 2456 2476 CONST0 2477 POP 2 2479 ACC0 2480 RETURN 4 2482 RESTART 2483 GRAB 1 2485 ACC1 2486 BRANCHIFNOT 2502 2488 ACC1 2489 GETFIELD0 2490 PUSHACC1 2491 PUSHENVACC1 2492 C_CALL3 array_unsafe_set 2494 ACC1 2495 GETFIELD1 2496 PUSHACC1 2497 OFFSETINT 1 2499 PUSHOFFSETCLOSURE0 2500 APPTERM2 4 2502 ENVACC1 2503 RETURN 2 2505 ACC0 2506 BRANCHIFNOT 2531 2508 ACC0 2509 GETFIELD1 2510 PUSHACC1 2511 GETFIELD0 2512 PUSHACC1 2513 PUSHGETGLOBALFIELD List, 0 2516 APPLY1 2517 OFFSETINT 1 2519 C_CALL2 make_vect 2521 PUSHACC0 2522 CLOSUREREC 1, 2483 2526 ACC2 2527 PUSHCONST1 2528 PUSHACC2 2529 APPTERM2 6 2531 ATOM0 2532 RETURN 1 2534 RESTART 2535 GRAB 1 2537 CONST0 2538 PUSHACC1 2539 LTINT 2540 BRANCHIFNOT 2545 2542 ACC1 2543 RETURN 2 2545 ACC1 2546 PUSHACC1 2547 PUSHENVACC1 2548 C_CALL2 array_unsafe_get 2550 MAKEBLOCK2 0 2552 PUSHACC1 2553 OFFSETINT -1 2555 PUSHOFFSETCLOSURE0 2556 APPTERM2 4 2558 ACC0 2559 CLOSUREREC 1, 2535 2563 CONST0 2564 PUSHACC2 2565 VECTLENGTH 2566 OFFSETINT -1 2568 PUSHACC2 2569 APPTERM2 4 2571 RESTART 2572 GRAB 1 2574 ACC1 2575 VECTLENGTH 2576 PUSHCONST0 2577 PUSHACC1 2578 EQ 2579 BRANCHIFNOT 2584 2581 ATOM0 2582 RETURN 3 2584 CONST0 2585 PUSHACC3 2586 C_CALL2 array_unsafe_get 2588 PUSHCONST0 2589 PUSHACC3 2590 APPLY2 2591 PUSHACC1 2592 C_CALL2 make_vect 2594 PUSHCONST1 2595 PUSHACC2 2596 OFFSETINT -1 2598 PUSH 2599 BRANCH 2618 2601 CHECK_SIGNALS 2602 ACC1 2603 PUSHACC6 2604 C_CALL2 array_unsafe_get 2606 PUSHACC2 2607 PUSHACC6 2608 APPLY2 2609 PUSHACC2 2610 PUSHACC4 2611 C_CALL3 array_unsafe_set 2613 ACC1 2614 OFFSETINT 1 2616 ASSIGN 1 2618 ACC0 2619 PUSHACC2 2620 LEINT 2621 BRANCHIF 2601 2623 CONST0 2624 POP 2 2626 ACC0 2627 RETURN 4 2629 RESTART 2630 GRAB 1 2632 CONST0 2633 PUSHACC2 2634 VECTLENGTH 2635 OFFSETINT -1 2637 PUSH 2638 BRANCH 2653 2640 CHECK_SIGNALS 2641 ACC1 2642 PUSHACC4 2643 C_CALL2 array_unsafe_get 2645 PUSHACC2 2646 PUSHACC4 2647 APPLY2 2648 ACC1 2649 OFFSETINT 1 2651 ASSIGN 1 2653 ACC0 2654 PUSHACC2 2655 LEINT 2656 BRANCHIF 2640 2658 CONST0 2659 RETURN 4 2661 RESTART 2662 GRAB 1 2664 ACC1 2665 VECTLENGTH 2666 PUSHCONST0 2667 PUSHACC1 2668 EQ 2669 BRANCHIFNOT 2674 2671 ATOM0 2672 RETURN 3 2674 CONST0 2675 PUSHACC3 2676 C_CALL2 array_unsafe_get 2678 PUSHACC2 2679 APPLY1 2680 PUSHACC1 2681 C_CALL2 make_vect 2683 PUSHCONST1 2684 PUSHACC2 2685 OFFSETINT -1 2687 PUSH 2688 BRANCH 2706 2690 CHECK_SIGNALS 2691 ACC1 2692 PUSHACC6 2693 C_CALL2 array_unsafe_get 2695 PUSHACC5 2696 APPLY1 2697 PUSHACC2 2698 PUSHACC4 2699 C_CALL3 array_unsafe_set 2701 ACC1 2702 OFFSETINT 1 2704 ASSIGN 1 2706 ACC0 2707 PUSHACC2 2708 LEINT 2709 BRANCHIF 2690 2711 CONST0 2712 POP 2 2714 ACC0 2715 RETURN 4 2717 RESTART 2718 GRAB 1 2720 CONST0 2721 PUSHACC2 2722 VECTLENGTH 2723 OFFSETINT -1 2725 PUSH 2726 BRANCH 2740 2728 CHECK_SIGNALS 2729 ACC1 2730 PUSHACC4 2731 C_CALL2 array_unsafe_get 2733 PUSHACC3 2734 APPLY1 2735 ACC1 2736 OFFSETINT 1 2738 ASSIGN 1 2740 ACC0 2741 PUSHACC2 2742 LEINT 2743 BRANCHIF 2728 2745 CONST0 2746 RETURN 4 2748 RESTART 2749 GRAB 4 2751 CONST0 2752 PUSHACC5 2753 LTINT 2754 BRANCHIF 2782 2756 CONST0 2757 PUSHACC2 2758 LTINT 2759 BRANCHIF 2782 2761 ACC0 2762 VECTLENGTH 2763 PUSHACC5 2764 PUSHACC3 2765 ADDINT 2766 GTINT 2767 BRANCHIF 2782 2769 CONST0 2770 PUSHACC4 2771 LTINT 2772 BRANCHIF 2782 2774 ACC2 2775 VECTLENGTH 2776 PUSHACC5 2777 PUSHACC5 2778 ADDINT 2779 GTINT 2780 BRANCHIFNOT 2789 2782 GETGLOBAL "Array.blit" 2784 PUSHGETGLOBALFIELD Pervasives, 2 2787 APPTERM1 6 2789 ACC3 2790 PUSHACC2 2791 LTINT 2792 BRANCHIFNOT 2827 2794 ACC4 2795 OFFSETINT -1 2797 PUSHCONST0 2798 PUSH 2799 BRANCH 2819 2801 CHECK_SIGNALS 2802 ACC1 2803 PUSHACC4 2804 ADDINT 2805 PUSHACC3 2806 C_CALL2 array_unsafe_get 2808 PUSHACC2 2809 PUSHACC7 2810 ADDINT 2811 PUSHACC6 2812 C_CALL3 array_unsafe_set 2814 ACC1 2815 OFFSETINT -1 2817 ASSIGN 1 2819 ACC0 2820 PUSHACC2 2821 GEINT 2822 BRANCHIF 2801 2824 CONST0 2825 RETURN 7 2827 CONST0 2828 PUSHACC5 2829 OFFSETINT -1 2831 PUSH 2832 BRANCH 2852 2834 CHECK_SIGNALS 2835 ACC1 2836 PUSHACC4 2837 ADDINT 2838 PUSHACC3 2839 C_CALL2 array_unsafe_get 2841 PUSHACC2 2842 PUSHACC7 2843 ADDINT 2844 PUSHACC6 2845 C_CALL3 array_unsafe_set 2847 ACC1 2848 OFFSETINT 1 2850 ASSIGN 1 2852 ACC0 2853 PUSHACC2 2854 LEINT 2855 BRANCHIF 2834 2857 CONST0 2858 RETURN 7 2860 RESTART 2861 GRAB 3 2863 CONST0 2864 PUSHACC2 2865 LTINT 2866 BRANCHIF 2881 2868 CONST0 2869 PUSHACC3 2870 LTINT 2871 BRANCHIF 2881 2873 ACC0 2874 VECTLENGTH 2875 PUSHACC3 2876 PUSHACC3 2877 ADDINT 2878 GTINT 2879 BRANCHIFNOT 2888 2881 GETGLOBAL "Array.fill" 2883 PUSHGETGLOBALFIELD Pervasives, 2 2886 APPTERM1 5 2888 ACC1 2889 PUSHACC3 2890 PUSHACC3 2891 ADDINT 2892 OFFSETINT -1 2894 PUSH 2895 BRANCH 2908 2897 CHECK_SIGNALS 2898 ACC5 2899 PUSHACC2 2900 PUSHACC4 2901 C_CALL3 array_unsafe_set 2903 ACC1 2904 OFFSETINT 1 2906 ASSIGN 1 2908 ACC0 2909 PUSHACC2 2910 LEINT 2911 BRANCHIF 2897 2913 CONST0 2914 RETURN 6 2916 RESTART 2917 GRAB 2 2919 CONST0 2920 PUSHACC2 2921 LTINT 2922 BRANCHIF 2937 2924 CONST0 2925 PUSHACC3 2926 LTINT 2927 BRANCHIF 2937 2929 ACC0 2930 VECTLENGTH 2931 PUSHACC3 2932 PUSHACC3 2933 ADDINT 2934 GTINT 2935 BRANCHIFNOT 2944 2937 GETGLOBAL "Array.sub" 2939 PUSHGETGLOBALFIELD Pervasives, 2 2942 APPTERM1 4 2944 CONST0 2945 PUSHACC3 2946 EQ 2947 BRANCHIFNOT 2952 2949 ATOM0 2950 RETURN 3 2952 ACC1 2953 PUSHACC1 2954 C_CALL2 array_unsafe_get 2956 PUSHACC3 2957 C_CALL2 make_vect 2959 PUSHCONST1 2960 PUSHACC4 2961 OFFSETINT -1 2963 PUSH 2964 BRANCH 2982 2966 CHECK_SIGNALS 2967 ACC1 2968 PUSHACC5 2969 ADDINT 2970 PUSHACC4 2971 C_CALL2 array_unsafe_get 2973 PUSHACC2 2974 PUSHACC4 2975 C_CALL3 array_unsafe_set 2977 ACC1 2978 OFFSETINT 1 2980 ASSIGN 1 2982 ACC0 2983 PUSHACC2 2984 LEINT 2985 BRANCHIF 2966 2987 CONST0 2988 POP 2 2990 ACC0 2991 RETURN 4 2993 ACC0 2994 BRANCHIFNOT 3017 2996 ACC0 2997 GETFIELD0 2998 PUSHCONST0 2999 PUSHACC1 3000 VECTLENGTH 3001 GTINT 3002 BRANCHIFNOT 3012 3004 ENVACC2 3005 PUSHCONST0 3006 PUSHACC2 3007 C_CALL2 array_unsafe_get 3009 PUSHENVACC1 3010 APPTERM2 4 3012 ACC1 3013 GETFIELD1 3014 PUSHOFFSETCLOSURE0 3015 APPTERM1 3 3017 ATOM0 3018 RETURN 1 3020 ACC0 3021 PUSHENVACC1 3022 CLOSUREREC 2, 2993 3026 ACC1 3027 PUSHACC1 3028 APPTERM1 3 3030 CONST0 3031 PUSHACC1 3032 VECTLENGTH 3033 OFFSETINT -1 3035 PUSH 3036 BRANCH 3056 3038 CHECK_SIGNALS 3039 ACC1 3040 PUSHACC3 3041 C_CALL2 array_unsafe_get 3043 PUSHENVACC2 3044 GETFIELD0 3045 PUSHENVACC1 3046 C_CALL3 array_unsafe_set 3048 ENVACC2 3049 OFFSETREF 1 3051 ACC1 3052 OFFSETINT 1 3054 ASSIGN 1 3056 ACC0 3057 PUSHACC2 3058 LEINT 3059 BRANCHIF 3038 3061 CONST0 3062 RETURN 3 3064 RESTART 3065 GRAB 1 3067 ACC1 3068 VECTLENGTH 3069 PUSHACC1 3070 ADDINT 3071 RETURN 2 3073 RESTART 3074 GRAB 1 3076 ACC1 3077 PUSHCONST0 3078 PUSH 3079 CLOSURE 0, 3065 3082 PUSHGETGLOBALFIELD List, 12 3085 APPLY3 3086 PUSHACC1 3087 PUSHACC1 3088 C_CALL2 make_vect 3090 PUSHCONST0 3091 MAKEBLOCK1 0 3093 PUSHACC4 3094 PUSHACC1 3095 PUSHACC3 3096 CLOSURE 2, 3030 3099 PUSHGETGLOBALFIELD List, 9 3102 APPLY2 3103 ACC1 3104 RETURN 5 3106 RESTART 3107 GRAB 1 3109 ACC0 3110 VECTLENGTH 3111 PUSHACC2 3112 VECTLENGTH 3113 PUSHCONST0 3114 PUSHACC2 3115 EQ 3116 BRANCHIFNOT 3126 3118 CONST0 3119 PUSHACC1 3120 EQ 3121 BRANCHIFNOT 3126 3123 ATOM0 3124 RETURN 4 3126 CONST0 3127 PUSHCONST0 3128 PUSHACC3 3129 GTINT 3130 BRANCHIFNOT 3135 3132 ACC3 3133 BRANCH 3136 3135 ACC4 3136 C_CALL2 array_unsafe_get 3138 PUSHACC1 3139 PUSHACC3 3140 ADDINT 3141 C_CALL2 make_vect 3143 PUSHCONST0 3144 PUSHACC3 3145 OFFSETINT -1 3147 PUSH 3148 BRANCH 3164 3150 CHECK_SIGNALS 3151 ACC1 3152 PUSHACC6 3153 C_CALL2 array_unsafe_get 3155 PUSHACC2 3156 PUSHACC4 3157 C_CALL3 array_unsafe_set 3159 ACC1 3160 OFFSETINT 1 3162 ASSIGN 1 3164 ACC0 3165 PUSHACC2 3166 LEINT 3167 BRANCHIF 3150 3169 CONST0 3170 POP 2 3172 CONST0 3173 PUSHACC2 3174 OFFSETINT -1 3176 PUSH 3177 BRANCH 3195 3179 CHECK_SIGNALS 3180 ACC1 3181 PUSHACC7 3182 C_CALL2 array_unsafe_get 3184 PUSHACC5 3185 PUSHACC3 3186 ADDINT 3187 PUSHACC4 3188 C_CALL3 array_unsafe_set 3190 ACC1 3191 OFFSETINT 1 3193 ASSIGN 1 3195 ACC0 3196 PUSHACC2 3197 LEINT 3198 BRANCHIF 3179 3200 CONST0 3201 POP 2 3203 ACC0 3204 RETURN 5 3206 ACC0 3207 VECTLENGTH 3208 PUSHCONST0 3209 PUSHACC1 3210 EQ 3211 BRANCHIFNOT 3216 3213 ATOM0 3214 RETURN 2 3216 CONST0 3217 PUSHACC2 3218 C_CALL2 array_unsafe_get 3220 PUSHACC1 3221 C_CALL2 make_vect 3223 PUSHCONST1 3224 PUSHACC2 3225 OFFSETINT -1 3227 PUSH 3228 BRANCH 3244 3230 CHECK_SIGNALS 3231 ACC1 3232 PUSHACC5 3233 C_CALL2 array_unsafe_get 3235 PUSHACC2 3236 PUSHACC4 3237 C_CALL3 array_unsafe_set 3239 ACC1 3240 OFFSETINT 1 3242 ASSIGN 1 3244 ACC0 3245 PUSHACC2 3246 LEINT 3247 BRANCHIF 3230 3249 CONST0 3250 POP 2 3252 ACC0 3253 RETURN 3 3255 RESTART 3256 GRAB 2 3258 ATOM0 3259 PUSHACC1 3260 C_CALL2 make_vect 3262 PUSHCONST0 3263 PUSHACC2 3264 OFFSETINT -1 3266 PUSH 3267 BRANCH 3282 3269 CHECK_SIGNALS 3270 ACC5 3271 PUSHACC5 3272 C_CALL2 make_vect 3274 PUSHACC2 3275 PUSHACC4 3276 SETVECTITEM 3277 ACC1 3278 OFFSETINT 1 3280 ASSIGN 1 3282 ACC0 3283 PUSHACC2 3284 LEINT 3285 BRANCHIF 3269 3287 CONST0 3288 POP 2 3290 ACC0 3291 RETURN 4 3293 RESTART 3294 GRAB 1 3296 CONST0 3297 PUSHACC1 3298 EQ 3299 BRANCHIFNOT 3304 3301 ATOM0 3302 RETURN 2 3304 CONST0 3305 PUSHACC2 3306 APPLY1 3307 PUSHACC1 3308 C_CALL2 make_vect 3310 PUSHCONST1 3311 PUSHACC2 3312 OFFSETINT -1 3314 PUSH 3315 BRANCH 3330 3317 CHECK_SIGNALS 3318 ACC1 3319 PUSHACC5 3320 APPLY1 3321 PUSHACC2 3322 PUSHACC4 3323 C_CALL3 array_unsafe_set 3325 ACC1 3326 OFFSETINT 1 3328 ASSIGN 1 3330 ACC0 3331 PUSHACC2 3332 LEINT 3333 BRANCHIF 3317 3335 CONST0 3336 POP 2 3338 ACC0 3339 RETURN 3 3341 CLOSURE 0, 3294 3344 PUSH 3345 CLOSURE 0, 3256 3348 PUSH 3349 CLOSURE 0, 3206 3352 PUSH 3353 CLOSURE 0, 3107 3356 PUSH 3357 CLOSURE 0, 3074 3360 PUSHACC0 3361 CLOSURE 1, 3020 3364 PUSH 3365 CLOSURE 0, 2917 3368 PUSH 3369 CLOSURE 0, 2861 3372 PUSH 3373 CLOSURE 0, 2749 3376 PUSH 3377 CLOSURE 0, 2718 3380 PUSH 3381 CLOSURE 0, 2662 3384 PUSH 3385 CLOSURE 0, 2630 3388 PUSH 3389 CLOSURE 0, 2572 3392 PUSH 3393 CLOSURE 0, 2558 3396 PUSH 3397 CLOSURE 0, 2505 3400 PUSH 3401 CLOSURE 0, 2445 3404 PUSH 3405 CLOSURE 0, 2407 3408 PUSHACC0 3409 PUSHACC2 3410 PUSHACC6 3411 PUSHACC 8 3413 PUSHACC 10 3415 PUSHACC 12 3417 PUSHACC 8 3419 PUSHACC 10 3421 PUSHACC 16 3423 PUSHACC 18 3425 PUSHACC 24 3427 PUSHACC 21 3429 PUSHACC 23 3431 PUSHACC 26 3433 PUSHACC 29 3435 PUSHACC 30 3437 PUSHACC 32 3439 MAKEBLOCK 17, 0 3442 POP 17 3444 SETGLOBAL Array 3446 BRANCH 3456 3448 ACC0 3449 PUSHENVACC1 3450 GETFIELD0 3451 ADDINT 3452 PUSHENVACC1 3453 SETFIELD0 3454 RETURN 1 3456 CONST2 3457 PUSHCONSTINT 200000 3459 C_CALL2 make_vect 3461 PUSHCONST0 3462 MAKEBLOCK1 0 3464 PUSHACC1 3465 PUSHACC1 3466 CLOSURE 1, 3448 3469 PUSHGETGLOBALFIELD Array, 11 3472 APPLY2 3473 CONSTINT 400000 3475 PUSHACC1 3476 GETFIELD0 3477 NEQ 3478 BRANCHIFNOT 3485 3480 GETGLOBAL Not_found 3482 MAKEBLOCK1 0 3484 RAISE 3485 POP 2 3487 ATOM0 3488 SETGLOBAL T310-alloc-2 3490 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t330-compact-1.ml0000644000175000017500000000037112124403241023525 0ustar tootstootsopen Lib;; Gc.compact ();; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 C_CALL1 gc_compaction 12 ATOM0 13 SETGLOBAL T330-compact-1 15 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t000.ml0000644000175000017500000000012112124403241021726 0ustar tootstoots(* empty file *) (** 0 ATOM0 1 SETGLOBAL T000 3 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-divint-2.ml0000644000175000017500000000062212124403241023370 0ustar tootstootsopen Lib;; if 3 / 2 <> 1 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONST2 11 PUSHCONST3 12 DIVINT 13 NEQ 14 BRANCHIFNOT 21 16 GETGLOBAL Not_found 18 MAKEBLOCK1 0 20 RAISE 21 ATOM0 22 SETGLOBAL T110-divint-2 24 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t041-makeblock.ml0000644000175000017500000000045712124403241023675 0ustar tootstootstype t = { mutable a : int; mutable b : int; mutable c : int; mutable d : int; };; { a = 0; b = 0; c = 0; d = 0 };; (** 0 CONST0 1 PUSHCONST0 2 PUSHCONST0 3 PUSHCONST0 4 MAKEBLOCK 4, 0 7 ATOM0 8 SETGLOBAL T041-makeblock 10 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t165-apply.ml0000644000175000017500000000076012124403241023076 0ustar tootstootsopen Lib;; let f _ _ _ _ = 0 in f 0 0 0 0;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 17 11 RESTART 12 GRAB 3 14 CONST0 15 RETURN 4 17 CLOSURE 0, 12 20 PUSH 21 PUSH_RETADDR 30 23 CONST0 24 PUSHCONST0 25 PUSHCONST0 26 PUSHCONST0 27 PUSHACC7 28 APPLY 4 30 POP 1 32 ATOM0 33 SETGLOBAL T165-apply 35 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t092-pushacc1.ml0000644000175000017500000000063112124403241023454 0ustar tootstootsopen Lib;; let x = false in let y = true in if x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST1 11 PUSHACC1 12 BRANCHIFNOT 19 14 GETGLOBAL Not_found 16 MAKEBLOCK1 0 18 RAISE 19 POP 2 21 ATOM0 22 SETGLOBAL T092-pushacc1 24 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t140-switch-1.ml0000644000175000017500000000105112124403241023373 0ustar tootstootsopen Lib;; match 0 with | 0 -> () | 1 -> raise Not_found | _ -> raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHACC0 11 SWITCH int 0 -> 17 int 1 -> 20 15 BRANCH 25 17 CONST0 18 BRANCH 30 20 GETGLOBAL Not_found 22 MAKEBLOCK1 0 24 RAISE 25 GETGLOBAL Not_found 27 MAKEBLOCK1 0 29 RAISE 30 POP 1 32 ATOM0 33 SETGLOBAL T140-switch-1 35 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t211-setfield.ml0000644000175000017500000000143012124403241023533 0ustar tootstootsopen Lib;; type t = { mutable a : int; mutable b : int; mutable c : int; mutable d : int; mutable e : int; };; let x = {a = 7; b = 6; c = 5; d = 4; e = 5} in x.e <- 11; if x.e <> 11 then raise Not_found; x ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 5 11 PUSHCONSTINT 4 13 PUSHCONSTINT 5 15 PUSHCONSTINT 6 17 PUSHCONSTINT 7 19 MAKEBLOCK 5, 0 22 PUSHCONSTINT 11 24 PUSHACC1 25 SETFIELD 4 27 CONSTINT 11 29 PUSHACC1 30 GETFIELD 4 32 NEQ 33 BRANCHIFNOT 40 35 GETGLOBAL Not_found 37 MAKEBLOCK1 0 39 RAISE 40 ACC0 41 POP 1 43 ATOM0 44 SETGLOBAL T211-setfield 46 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t163.ml0000644000175000017500000000057512124403241021755 0ustar tootstootsopen Lib;; let f _ _ = 0 in f 0;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 17 11 RESTART 12 GRAB 1 14 CONST0 15 RETURN 2 17 CLOSURE 0, 12 20 PUSHCONST0 21 PUSHACC1 22 APPLY1 23 POP 1 25 ATOM0 26 SETGLOBAL T163 28 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t092-pushacc3.ml0000644000175000017500000000074312124403241023462 0ustar tootstootsopen Lib;; let x = false in let y = true in let z = true in let a = true in if x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST1 11 PUSHCONST1 12 PUSHCONST1 13 PUSHACC3 14 BRANCHIFNOT 21 16 GETGLOBAL Not_found 18 MAKEBLOCK1 0 20 RAISE 21 POP 4 23 ATOM0 24 SETGLOBAL T092-pushacc3 26 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t200-getfield3.ml0000644000175000017500000000075512124403241023611 0ustar tootstootsopen Lib;; type t = { a : int; b : int; c : int; d : int; };; if { a = 7; b = 6; c = 5; d = 4 }.d <> 4 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 4 11 PUSHGETGLOBAL <0>(7, 6, 5, 4) 13 GETFIELD3 14 NEQ 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 ATOM0 23 SETGLOBAL T200-getfield3 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t050-getglobal.ml0000644000175000017500000000015512124403241023700 0ustar tootstoots[1];; (** 0 GETGLOBAL <0>(1, 0) 2 ATOM0 3 SETGLOBAL T050-getglobal 5 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t360-stacks-2.ml0000644000175000017500000000171512124403241023376 0ustar tootstootsopen Lib;; let rec f n = if n <= 0 then 12 else 1 + f (n-1) in try ignore (f 3000000); raise Not_found with Stack_overflow -> () ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 29 11 CONST0 12 PUSHACC1 13 LEINT 14 BRANCHIFNOT 20 16 CONSTINT 12 18 RETURN 1 20 ACC0 21 OFFSETINT -1 23 PUSHOFFSETCLOSURE0 24 APPLY1 25 PUSHCONST1 26 ADDINT 27 RETURN 1 29 CLOSUREREC 0, 11 33 PUSHTRAP 44 35 CONSTINT 3000000 37 PUSHACC5 38 APPLY1 39 GETGLOBAL Not_found 41 MAKEBLOCK1 0 43 RAISE 44 PUSHGETGLOBAL Stack_overflow 46 PUSHACC1 47 GETFIELD0 48 EQ 49 BRANCHIFNOT 54 51 CONST0 52 BRANCH 56 54 ACC0 55 RAISE 56 POP 1 58 POP 1 60 ATOM0 61 SETGLOBAL T360-stacks-2 63 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t170-envacc4.ml0000644000175000017500000000153612124403241023272 0ustar tootstootsopen Lib;; let x = 5 in let y = 2 in let z = 1 in let a = 4 in let f _ = ignore x; ignore y; ignore z; a in if f 0 <> 4 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 20 11 ENVACC1 12 CONST0 13 ENVACC2 14 CONST0 15 ENVACC3 16 CONST0 17 ENVACC4 18 RETURN 1 20 CONSTINT 5 22 PUSHCONST2 23 PUSHCONST1 24 PUSHCONSTINT 4 26 PUSHACC0 27 PUSHACC2 28 PUSHACC4 29 PUSHACC6 30 CLOSURE 4, 11 33 PUSHCONSTINT 4 35 PUSHCONST0 36 PUSHACC2 37 APPLY1 38 NEQ 39 BRANCHIFNOT 46 41 GETGLOBAL Not_found 43 MAKEBLOCK1 0 45 RAISE 46 POP 5 48 ATOM0 49 SETGLOBAL T170-envacc4 51 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-asrint-2.ml0000644000175000017500000000062612124403241023377 0ustar tootstootsopen Lib;; if (3 asr 1) <> 1 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONST1 11 PUSHCONST3 12 ASRINT 13 NEQ 14 BRANCHIFNOT 21 16 GETGLOBAL Not_found 18 MAKEBLOCK1 0 20 RAISE 21 ATOM0 22 SETGLOBAL T110-asrint-2 24 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t190-makefloatblock-3.ml0000644000175000017500000000052612124403241025065 0ustar tootstootsopen Lib;; let x = 0.0 in [| x; x; x |];; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL 0 11 PUSHACC0 12 PUSHACC1 13 PUSHACC2 14 MAKEFLOATBLOCK 3 16 POP 1 18 ATOM0 19 SETGLOBAL T190-makefloatblock-3 21 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t150-push-2.ml0000644000175000017500000000126712124403241023064 0ustar tootstootsopen Lib;; let x = 1 in try if x <> 1 then raise Not_found with End_of_file -> () ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSH 11 PUSHTRAP 26 13 CONST1 14 PUSHACC5 15 NEQ 16 BRANCHIFNOT 23 18 GETGLOBAL Not_found 20 MAKEBLOCK1 0 22 RAISE 23 POPTRAP 24 BRANCH 40 26 PUSHGETGLOBAL End_of_file 28 PUSHACC1 29 GETFIELD0 30 EQ 31 BRANCHIFNOT 36 33 CONST0 34 BRANCH 38 36 ACC0 37 RAISE 38 POP 1 40 POP 1 42 ATOM0 43 SETGLOBAL T150-push-2 45 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-offsetint.ml0000644000175000017500000000060512124403241023736 0ustar tootstootsopen Lib;; if 2 + 2 <> 4 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 4 11 PUSHCONST2 12 OFFSETINT 2 14 NEQ 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 ATOM0 23 SETGLOBAL T110-offsetint 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t092-pushacc7.ml0000644000175000017500000000116712124403241023467 0ustar tootstootsopen Lib;; let x = false in let y = true in let z = true in let a = true in let b = true in let c = true in let d = true in let e = true in if x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST1 11 PUSHCONST1 12 PUSHCONST1 13 PUSHCONST1 14 PUSHCONST1 15 PUSHCONST1 16 PUSHCONST1 17 PUSHACC7 18 BRANCHIFNOT 25 20 GETGLOBAL Not_found 22 MAKEBLOCK1 0 24 RAISE 25 POP 8 27 ATOM0 28 SETGLOBAL T092-pushacc7 30 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t121-setstringchar.ml0000644000175000017500000000110512124403241024613 0ustar tootstootsopen Lib;; let x = "foo" in x.[2] <- 'x'; if x.[2] <> 'x' then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL "foo" 11 PUSHCONSTINT 120 13 PUSHCONST2 14 PUSHACC2 15 SETSTRINGCHAR 16 CONSTINT 120 18 PUSHCONST2 19 PUSHACC2 20 GETSTRINGCHAR 21 NEQ 22 BRANCHIFNOT 29 24 GETGLOBAL Not_found 26 MAKEBLOCK1 0 28 RAISE 29 POP 1 31 ATOM0 32 SETGLOBAL T121-setstringchar 34 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t193-setfloatfield-1.ml0000644000175000017500000000124612124403241024735 0ustar tootstootsopen Lib;; type t = { mutable a : float; mutable b : float; };; let x = { a = 0.1; b = 0.2 } in x.a <- 0.3; if x.a <> 0.3 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL 0.2 11 PUSHGETGLOBAL 0.1 13 MAKEFLOATBLOCK 2 15 PUSHGETGLOBAL 0.3 17 PUSHACC1 18 SETFLOATFIELD 0 20 GETGLOBAL 0.3 22 PUSHACC1 23 GETFLOATFIELD 0 25 C_CALL2 neq_float 27 BRANCHIFNOT 34 29 GETGLOBAL Not_found 31 MAKEBLOCK1 0 33 RAISE 34 POP 1 36 ATOM0 37 SETGLOBAL T193-setfloatfield-1 39 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t020.ml0000644000175000017500000000021012124403241021727 0ustar tootstootslet _ = () in ();; (** 0 CONST0 1 PUSHCONST0 2 POP 1 4 ATOM0 5 SETGLOBAL T020 7 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t251-pushoffsetclosurem2.ml0000644000175000017500000000115612124403241025767 0ustar tootstootsopen Lib;; let rec f _ = 4 and g _ = f 2 in if g 5 <> 4 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 19 11 CONSTINT 4 13 RETURN 1 15 CONST2 16 PUSHOFFSETCLOSUREM2 17 APPTERM1 2 19 CLOSUREREC 0, 11, 15 24 CONSTINT 4 26 PUSHCONSTINT 5 28 PUSHACC2 29 APPLY1 30 NEQ 31 BRANCHIFNOT 38 33 GETGLOBAL Not_found 35 MAKEBLOCK1 0 37 RAISE 38 POP 2 40 ATOM0 41 SETGLOBAL T251-pushoffsetclosurem2 43 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t190-makefloatblock-1.ml0000644000175000017500000000045212124403241025061 0ustar tootstootsopen Lib;; let x = 0.0 in [| x |];; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL 0 11 PUSHACC0 12 MAKEFLOATBLOCK 1 14 POP 1 16 ATOM0 17 SETGLOBAL T190-makefloatblock-1 19 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t051-pushgetglobalfield.ml0000644000175000017500000000042012124403241025600 0ustar tootstootslet _ = () in Lib.x;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHGETGLOBALFIELD Lib, 0 13 POP 1 15 ATOM0 16 SETGLOBAL T051-pushgetglobalfield 18 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t330-compact-2.ml0000644000175000017500000003646612124403241023544 0ustar tootstootsopen Lib;; Gc.compact ();; let _ = Pervasives.do_at_exit();; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 746 11 RESTART 12 GRAB 1 14 ACC0 15 BRANCHIFNOT 28 17 ACC1 18 PUSHACC1 19 GETFIELD1 20 PUSHOFFSETCLOSURE0 21 APPLY2 22 PUSHACC1 23 GETFIELD0 24 MAKEBLOCK2 0 26 RETURN 2 28 ACC1 29 RETURN 2 31 RESTART 32 GRAB 3 34 CONST0 35 PUSHACC4 36 LEINT 37 BRANCHIFNOT 42 39 CONST0 40 RETURN 4 42 ACC3 43 PUSHACC3 44 PUSHACC3 45 PUSHACC3 46 C_CALL4 caml_input 48 PUSHCONST0 49 PUSHACC1 50 EQ 51 BRANCHIFNOT 58 53 GETGLOBAL End_of_file 55 MAKEBLOCK1 0 57 RAISE 58 ACC0 59 PUSHACC5 60 SUBINT 61 PUSHACC1 62 PUSHACC5 63 ADDINT 64 PUSHACC4 65 PUSHACC4 66 PUSHOFFSETCLOSURE0 67 APPTERM 4, 9 70 ACC0 71 C_CALL1 caml_input_scan_line 73 PUSHCONST0 74 PUSHACC1 75 EQ 76 BRANCHIFNOT 83 78 GETGLOBAL End_of_file 80 MAKEBLOCK1 0 82 RAISE 83 CONST0 84 PUSHACC1 85 GTINT 86 BRANCHIFNOT 107 88 ACC0 89 OFFSETINT -1 91 C_CALL1 create_string 93 PUSHACC1 94 OFFSETINT -1 96 PUSHCONST0 97 PUSHACC2 98 PUSHACC5 99 C_CALL4 caml_input 101 ACC2 102 C_CALL1 caml_input_char 104 ACC0 105 RETURN 3 107 ACC0 108 NEGINT 109 C_CALL1 create_string 111 PUSHACC1 112 NEGINT 113 PUSHCONST0 114 PUSHACC2 115 PUSHACC5 116 C_CALL4 caml_input 118 CONST0 119 PUSHTRAP 130 121 ACC6 122 PUSHOFFSETCLOSURE0 123 APPLY1 124 PUSHACC5 125 PUSHENVACC1 126 APPLY2 127 POPTRAP 128 RETURN 3 130 PUSHGETGLOBAL End_of_file 132 PUSHACC1 133 GETFIELD0 134 EQ 135 BRANCHIFNOT 140 137 ACC1 138 RETURN 4 140 ACC0 141 RAISE 142 ACC0 143 C_CALL1 caml_flush 145 RETURN 1 147 RESTART 148 GRAB 1 150 ACC1 151 PUSHACC1 152 C_CALL2 caml_output_char 154 RETURN 2 156 RESTART 157 GRAB 1 159 ACC1 160 PUSHACC1 161 C_CALL2 caml_output_char 163 RETURN 2 165 RESTART 166 GRAB 1 168 ACC1 169 PUSHACC1 170 C_CALL2 caml_output_int 172 RETURN 2 174 RESTART 175 GRAB 1 177 ACC1 178 PUSHACC1 179 C_CALL2 caml_seek_out 181 RETURN 2 183 ACC0 184 C_CALL1 caml_pos_out 186 RETURN 1 188 ACC0 189 C_CALL1 caml_channel_size 191 RETURN 1 193 RESTART 194 GRAB 1 196 ACC1 197 PUSHACC1 198 C_CALL2 caml_set_binary_mode 200 RETURN 2 202 ACC0 203 C_CALL1 caml_input_char 205 RETURN 1 207 ACC0 208 C_CALL1 caml_input_char 210 RETURN 1 212 ACC0 213 C_CALL1 caml_input_int 215 RETURN 1 217 ACC0 218 C_CALL1 input_value 220 RETURN 1 222 RESTART 223 GRAB 1 225 ACC1 226 PUSHACC1 227 C_CALL2 caml_seek_in 229 RETURN 2 231 ACC0 232 C_CALL1 caml_pos_in 234 RETURN 1 236 ACC0 237 C_CALL1 caml_channel_size 239 RETURN 1 241 ACC0 242 C_CALL1 caml_close_channel 244 RETURN 1 246 RESTART 247 GRAB 1 249 ACC1 250 PUSHACC1 251 C_CALL2 caml_set_binary_mode 253 RETURN 2 255 CONST0 256 PUSHENVACC1 257 APPLY1 258 ACC0 259 C_CALL1 sys_exit 261 RETURN 1 263 CONST0 264 PUSHENVACC1 265 GETFIELD0 266 APPTERM1 2 268 CONST0 269 PUSHENVACC1 270 APPLY1 271 CONST0 272 PUSHENVACC2 273 APPTERM1 2 275 ENVACC1 276 GETFIELD0 277 PUSHACC0 278 PUSHACC2 279 CLOSURE 2, 268 282 PUSHENVACC1 283 SETFIELD0 284 RETURN 2 286 ENVACC1 287 C_CALL1 caml_flush 289 ENVACC2 290 C_CALL1 caml_flush 292 RETURN 1 294 CONST0 295 PUSHENVACC1 296 APPLY1 297 C_CALL1 float_of_string 299 RETURN 1 301 CONST0 302 PUSHENVACC1 303 APPLY1 304 C_CALL1 int_of_string 306 RETURN 1 308 ENVACC2 309 C_CALL1 caml_flush 311 ENVACC1 312 PUSHENVACC3 313 APPTERM1 2 315 CONSTINT 13 317 PUSHENVACC1 318 C_CALL2 caml_output_char 320 ENVACC1 321 C_CALL1 caml_flush 323 RETURN 1 325 ACC0 326 PUSHENVACC1 327 PUSHENVACC2 328 APPLY2 329 CONSTINT 13 331 PUSHENVACC1 332 C_CALL2 caml_output_char 334 ENVACC1 335 C_CALL1 caml_flush 337 RETURN 1 339 ACC0 340 PUSHENVACC1 341 APPLY1 342 PUSHENVACC2 343 PUSHENVACC3 344 APPTERM2 3 346 ACC0 347 PUSHENVACC1 348 APPLY1 349 PUSHENVACC2 350 PUSHENVACC3 351 APPTERM2 3 353 ACC0 354 PUSHENVACC1 355 PUSHENVACC2 356 APPTERM2 3 358 ACC0 359 PUSHENVACC1 360 C_CALL2 caml_output_char 362 RETURN 1 364 CONSTINT 13 366 PUSHENVACC1 367 C_CALL2 caml_output_char 369 ENVACC1 370 C_CALL1 caml_flush 372 RETURN 1 374 ACC0 375 PUSHENVACC1 376 PUSHENVACC2 377 APPLY2 378 CONSTINT 13 380 PUSHENVACC1 381 C_CALL2 caml_output_char 383 RETURN 1 385 ACC0 386 PUSHENVACC1 387 APPLY1 388 PUSHENVACC2 389 PUSHENVACC3 390 APPTERM2 3 392 ACC0 393 PUSHENVACC1 394 APPLY1 395 PUSHENVACC2 396 PUSHENVACC3 397 APPTERM2 3 399 ACC0 400 PUSHENVACC1 401 PUSHENVACC2 402 APPTERM2 3 404 ACC0 405 PUSHENVACC1 406 C_CALL2 caml_output_char 408 RETURN 1 410 RESTART 411 GRAB 3 413 CONST0 414 PUSHACC3 415 LTINT 416 BRANCHIF 427 418 ACC1 419 C_CALL1 ml_string_length 421 PUSHACC4 422 PUSHACC4 423 ADDINT 424 GTINT 425 BRANCHIFNOT 432 427 GETGLOBAL "really_input" 429 PUSHENVACC1 430 APPTERM1 5 432 ACC3 433 PUSHACC3 434 PUSHACC3 435 PUSHACC3 436 PUSHENVACC2 437 APPTERM 4, 8 440 RESTART 441 GRAB 3 443 CONST0 444 PUSHACC3 445 LTINT 446 BRANCHIF 457 448 ACC1 449 C_CALL1 ml_string_length 451 PUSHACC4 452 PUSHACC4 453 ADDINT 454 GTINT 455 BRANCHIFNOT 462 457 GETGLOBAL "input" 459 PUSHENVACC1 460 APPTERM1 5 462 ACC3 463 PUSHACC3 464 PUSHACC3 465 PUSHACC3 466 C_CALL4 caml_input 468 RETURN 4 470 ACC0 471 PUSHCONST0 472 PUSHGETGLOBAL <0>(0, <0>(6, 0)) 474 PUSHENVACC1 475 APPTERM3 4 477 ACC0 478 PUSHCONST0 479 PUSHGETGLOBAL <0>(0, <0>(7, 0)) 481 PUSHENVACC1 482 APPTERM3 4 484 RESTART 485 GRAB 2 487 ACC1 488 PUSHACC1 489 PUSHACC4 490 C_CALL3 sys_open 492 C_CALL1 caml_open_descriptor 494 RETURN 3 496 ACC0 497 C_CALL1 caml_flush 499 ACC0 500 C_CALL1 caml_close_channel 502 RETURN 1 504 RESTART 505 GRAB 1 507 CONST0 508 PUSHACC2 509 PUSHACC2 510 C_CALL3 output_value 512 RETURN 2 514 RESTART 515 GRAB 3 517 CONST0 518 PUSHACC3 519 LTINT 520 BRANCHIF 531 522 ACC1 523 C_CALL1 ml_string_length 525 PUSHACC4 526 PUSHACC4 527 ADDINT 528 GTINT 529 BRANCHIFNOT 536 531 GETGLOBAL "output" 533 PUSHENVACC1 534 APPTERM1 5 536 ACC3 537 PUSHACC3 538 PUSHACC3 539 PUSHACC3 540 C_CALL4 caml_output 542 RETURN 4 544 RESTART 545 GRAB 1 547 ACC1 548 C_CALL1 ml_string_length 550 PUSHCONST0 551 PUSHACC3 552 PUSHACC3 553 C_CALL4 caml_output 555 RETURN 2 557 ACC0 558 PUSHCONSTINT 438 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0)))) 562 PUSHENVACC1 563 APPTERM3 4 565 ACC0 566 PUSHCONSTINT 438 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0)))) 570 PUSHENVACC1 571 APPTERM3 4 573 RESTART 574 GRAB 2 576 ACC1 577 PUSHACC1 578 PUSHACC4 579 C_CALL3 sys_open 581 C_CALL1 caml_open_descriptor 583 RETURN 3 585 ACC0 586 PUSHGETGLOBAL "%.12g" 588 C_CALL2 format_float 590 RETURN 1 592 ACC0 593 PUSHGETGLOBAL "%d" 595 C_CALL2 format_int 597 RETURN 1 599 GETGLOBAL "false" 601 PUSHACC1 602 C_CALL2 string_equal 604 BRANCHIFNOT 609 606 CONST0 607 RETURN 1 609 GETGLOBAL "true" 611 PUSHACC1 612 C_CALL2 string_equal 614 BRANCHIFNOT 619 616 CONST1 617 RETURN 1 619 GETGLOBAL "bool_of_string" 621 PUSHENVACC1 622 APPTERM1 2 624 ACC0 625 BRANCHIFNOT 631 627 GETGLOBAL "true" 629 RETURN 1 631 GETGLOBAL "false" 633 RETURN 1 635 CONST0 636 PUSHACC1 637 LTINT 638 BRANCHIF 646 640 CONSTINT 255 642 PUSHACC1 643 GTINT 644 BRANCHIFNOT 651 646 GETGLOBAL "char_of_int" 648 PUSHENVACC1 649 APPTERM1 2 651 ACC0 652 RETURN 1 654 RESTART 655 GRAB 1 657 ACC0 658 C_CALL1 ml_string_length 660 PUSHACC2 661 C_CALL1 ml_string_length 663 PUSHACC0 664 PUSHACC2 665 ADDINT 666 C_CALL1 create_string 668 PUSHACC2 669 PUSHCONST0 670 PUSHACC2 671 PUSHCONST0 672 PUSHACC7 673 C_CALL5 blit_string 675 ACC1 676 PUSHACC3 677 PUSHACC2 678 PUSHCONST0 679 PUSHACC 8 681 C_CALL5 blit_string 683 ACC0 684 RETURN 5 686 CONSTINT -1 688 PUSHACC1 689 XORINT 690 RETURN 1 692 CONST0 693 PUSHACC1 694 GEINT 695 BRANCHIFNOT 700 697 ACC0 698 RETURN 1 700 ACC0 701 NEGINT 702 RETURN 1 704 RESTART 705 GRAB 1 707 ACC1 708 PUSHACC1 709 C_CALL2 greaterequal 711 BRANCHIFNOT 716 713 ACC0 714 RETURN 2 716 ACC1 717 RETURN 2 719 RESTART 720 GRAB 1 722 ACC1 723 PUSHACC1 724 C_CALL2 lessequal 726 BRANCHIFNOT 731 728 ACC0 729 RETURN 2 731 ACC1 732 RETURN 2 734 ACC0 735 PUSHGETGLOBAL Invalid_argument 737 MAKEBLOCK2 0 739 RAISE 740 ACC0 741 PUSHGETGLOBAL Failure 743 MAKEBLOCK2 0 745 RAISE 746 CLOSURE 0, 740 749 PUSH 750 CLOSURE 0, 734 753 PUSHGETGLOBAL "Pervasives.Exit" 755 MAKEBLOCK1 0 757 PUSHGETGLOBAL "Pervasives.Assert_failure" 759 MAKEBLOCK1 0 761 PUSH 762 CLOSURE 0, 720 765 PUSH 766 CLOSURE 0, 705 769 PUSH 770 CLOSURE 0, 692 773 PUSH 774 CLOSURE 0, 686 777 PUSHCONST0 778 PUSHCONSTINT 31 780 PUSHCONST1 781 LSLINT 782 EQ 783 BRANCHIFNOT 789 785 CONSTINT 30 787 BRANCH 791 789 CONSTINT 62 791 PUSHCONST1 792 LSLINT 793 PUSHACC0 794 OFFSETINT -1 796 PUSH 797 CLOSURE 0, 655 800 PUSHACC 9 802 CLOSURE 1, 635 805 PUSH 806 CLOSURE 0, 624 809 PUSHACC 11 811 CLOSURE 1, 599 814 PUSH 815 CLOSURE 0, 592 818 PUSH 819 CLOSURE 0, 585 822 PUSH 823 CLOSUREREC 0, 12 827 CONST0 828 C_CALL1 caml_open_descriptor 830 PUSHCONST1 831 C_CALL1 caml_open_descriptor 833 PUSHCONST2 834 C_CALL1 caml_open_descriptor 836 PUSH 837 CLOSURE 0, 574 840 PUSHACC0 841 CLOSURE 1, 565 844 PUSHACC1 845 CLOSURE 1, 557 848 PUSH 849 CLOSURE 0, 545 852 PUSHACC 22 854 CLOSURE 1, 515 857 PUSH 858 CLOSURE 0, 505 861 PUSH 862 CLOSURE 0, 496 865 PUSH 866 CLOSURE 0, 485 869 PUSHACC0 870 CLOSURE 1, 477 873 PUSHACC1 874 CLOSURE 1, 470 877 PUSHACC 28 879 CLOSURE 1, 441 882 PUSH 883 CLOSUREREC 0, 32 887 ACC0 888 PUSHACC 31 890 CLOSURE 2, 411 893 PUSHACC 22 895 CLOSUREREC 1, 70 899 ACC 15 901 CLOSURE 1, 404 904 PUSHACC 11 906 PUSHACC 17 908 CLOSURE 2, 399 911 PUSHACC 12 913 PUSHACC 18 915 PUSHACC 23 917 CLOSURE 3, 392 920 PUSHACC 13 922 PUSHACC 19 924 PUSHACC 23 926 CLOSURE 3, 385 929 PUSHACC 14 931 PUSHACC 20 933 CLOSURE 2, 374 936 PUSHACC 20 938 CLOSURE 1, 364 941 PUSHACC 20 943 CLOSURE 1, 358 946 PUSHACC 17 948 PUSHACC 22 950 CLOSURE 2, 353 953 PUSHACC 18 955 PUSHACC 23 957 PUSHACC 29 959 CLOSURE 3, 346 962 PUSHACC 19 964 PUSHACC 24 966 PUSHACC 29 968 CLOSURE 3, 339 971 PUSHACC 20 973 PUSHACC 25 975 CLOSURE 2, 325 978 PUSHACC 25 980 CLOSURE 1, 315 983 PUSHACC 12 985 PUSHACC 28 987 PUSHACC 30 989 CLOSURE 3, 308 992 PUSHACC0 993 CLOSURE 1, 301 996 PUSHACC1 997 CLOSURE 1, 294 1000 PUSHACC 29 1002 PUSHACC 31 1004 CLOSURE 2, 286 1007 MAKEBLOCK1 0 1009 PUSHACC0 1010 CLOSURE 1, 275 1013 PUSHACC1 1014 CLOSURE 1, 263 1017 PUSHACC0 1018 CLOSURE 1, 255 1021 PUSHACC1 1022 PUSHACC 22 1024 PUSHACC4 1025 PUSHACC3 1026 PUSH 1027 CLOSURE 0, 247 1030 PUSH 1031 CLOSURE 0, 241 1034 PUSH 1035 CLOSURE 0, 236 1038 PUSH 1039 CLOSURE 0, 231 1042 PUSH 1043 CLOSURE 0, 223 1046 PUSH 1047 CLOSURE 0, 217 1050 PUSH 1051 CLOSURE 0, 212 1054 PUSH 1055 CLOSURE 0, 207 1058 PUSHACC 32 1060 PUSHACC 35 1062 PUSHACC 33 1064 PUSH 1065 CLOSURE 0, 202 1068 PUSHACC 41 1070 PUSHACC 40 1072 PUSHACC 42 1074 PUSH 1075 CLOSURE 0, 194 1078 PUSHACC 46 1080 PUSH 1081 CLOSURE 0, 188 1084 PUSH 1085 CLOSURE 0, 183 1088 PUSH 1089 CLOSURE 0, 175 1092 PUSHACC 51 1094 PUSH 1095 CLOSURE 0, 166 1098 PUSH 1099 CLOSURE 0, 157 1102 PUSHACC 55 1104 PUSHACC 57 1106 PUSH 1107 CLOSURE 0, 148 1110 PUSH 1111 CLOSURE 0, 142 1114 PUSHACC 63 1116 PUSHACC 62 1118 PUSHACC 64 1120 PUSHACC 38 1122 PUSHACC 40 1124 PUSHACC 42 1126 PUSHACC 44 1128 PUSHACC 46 1130 PUSHACC 48 1132 PUSHACC 50 1134 PUSHACC 52 1136 PUSHACC 54 1138 PUSHACC 56 1140 PUSHACC 58 1142 PUSHACC 60 1144 PUSHACC 62 1146 PUSHACC 64 1148 PUSHACC 66 1150 PUSHACC 82 1152 PUSHACC 84 1154 PUSHACC 86 1156 PUSHACC 88 1158 PUSHACC 90 1160 PUSHACC 92 1162 PUSHACC 94 1164 PUSHACC 96 1166 PUSHACC 98 1168 PUSHACC 100 1170 PUSHACC 104 1172 PUSHACC 104 1174 PUSHACC 104 1176 PUSHACC 108 1178 PUSHACC 110 1180 PUSHACC 112 1182 PUSHACC 117 1184 PUSHACC 117 1186 PUSHACC 117 1188 PUSHACC 117 1190 MAKEBLOCK 69, 0 1193 POP 53 1195 SETGLOBAL Pervasives 1197 CONST0 1198 C_CALL1 gc_compaction 1200 CONST0 1201 PUSHGETGLOBALFIELD Pervasives, 68 1204 APPLY1 1205 ATOM0 1206 SETGLOBAL T330-compact-2 1208 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t040-makeblock3.ml0000644000175000017500000000037712124403241023760 0ustar tootstootstype t = { mutable a : int; mutable b : int; mutable c : int; };; { a = 0; b = 0; c = 0 };; (** 0 CONST0 1 PUSHCONST0 2 PUSHCONST0 3 MAKEBLOCK3 0 5 ATOM0 6 SETGLOBAL T040-makeblock3 8 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t360-stacks-1.ml0000644000175000017500000000142712124403241023375 0ustar tootstootsopen Lib;; let rec f n = if n <= 0 then 12 else 1 + f (n-1) in if f 30000 <> 30012 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 29 11 CONST0 12 PUSHACC1 13 LEINT 14 BRANCHIFNOT 20 16 CONSTINT 12 18 RETURN 1 20 ACC0 21 OFFSETINT -1 23 PUSHOFFSETCLOSURE0 24 APPLY1 25 PUSHCONST1 26 ADDINT 27 RETURN 1 29 CLOSUREREC 0, 11 33 CONSTINT 30012 35 PUSHCONSTINT 30000 37 PUSHACC2 38 APPLY1 39 NEQ 40 BRANCHIFNOT 47 42 GETGLOBAL Not_found 44 MAKEBLOCK1 0 46 RAISE 47 POP 1 49 ATOM0 50 SETGLOBAL T360-stacks-1 52 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t240-c_call4.ml0000644000175000017500000000117112124403241023241 0ustar tootstootsopen Lib;; let s = "abcdefgh" in String.unsafe_fill s 0 6 'x'; if s.[5] <> 'x' then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL "abcdefgh" 11 PUSHCONSTINT 120 13 PUSHCONSTINT 6 15 PUSHCONST0 16 PUSHACC3 17 C_CALL4 fill_string 19 CONSTINT 120 21 PUSHCONSTINT 5 23 PUSHACC2 24 GETSTRINGCHAR 25 NEQ 26 BRANCHIFNOT 33 28 GETGLOBAL Not_found 30 MAKEBLOCK1 0 32 RAISE 33 POP 1 35 ATOM0 36 SETGLOBAL T240-c_call4 38 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t254-offsetclosure.ml0000644000175000017500000000124112124403241024626 0ustar tootstootsopen Lib;; let rec f _ = 11 and g _ = 0 and h _ = f in if h 3 4 <> 11 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 22 11 CONSTINT 11 13 RETURN 1 15 CONST0 16 RETURN 1 18 OFFSETCLOSURE -4 20 RETURN 1 22 CLOSUREREC 0, 11, 15, 18 28 CONSTINT 11 30 PUSHCONSTINT 4 32 PUSHCONST3 33 PUSHACC3 34 APPLY2 35 NEQ 36 BRANCHIFNOT 43 38 GETGLOBAL Not_found 40 MAKEBLOCK1 0 42 RAISE 43 POP 3 45 ATOM0 46 SETGLOBAL T254-offsetclosure 48 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t100-pushtrap.ml0000644000175000017500000000053012124403241023577 0ustar tootstootsopen Lib;; try raise Not_found with _ -> () ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 PUSHTRAP 16 11 GETGLOBAL Not_found 13 MAKEBLOCK1 0 15 RAISE 16 PUSHCONST0 17 POP 1 19 ATOM0 20 SETGLOBAL T100-pushtrap 22 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t040-makeblock2.ml0000644000175000017500000000032012124403241023743 0ustar tootstootstype t = { mutable a : int; mutable b : int; };; { a = 0; b = 0 };; (** 0 CONST0 1 PUSHCONST0 2 MAKEBLOCK2 0 4 ATOM0 5 SETGLOBAL T040-makeblock2 7 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t140-switch-4.ml0000644000175000017500000000103312124403241023376 0ustar tootstootsopen Lib;; match -1 with | 0 -> raise Not_found | 1 -> raise Not_found | _ -> () ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT -1 11 PUSHACC0 12 SWITCH int 0 -> 18 int 1 -> 23 16 BRANCH 28 18 GETGLOBAL Not_found 20 MAKEBLOCK1 0 22 RAISE 23 GETGLOBAL Not_found 25 MAKEBLOCK1 0 27 RAISE 28 CONST0 29 POP 1 31 ATOM0 32 SETGLOBAL T140-switch-4 34 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t310-alloc-1.ml0000644000175000017500000007752312124403241023204 0ustar tootstootsopen Lib;; let rec f a n = if n <= 0 then a else f (1::a) (n-1) in let l = f [] 30000 in if List.fold_left (+) 0 l <> 30000 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 746 11 RESTART 12 GRAB 1 14 ACC0 15 BRANCHIFNOT 28 17 ACC1 18 PUSHACC1 19 GETFIELD1 20 PUSHOFFSETCLOSURE0 21 APPLY2 22 PUSHACC1 23 GETFIELD0 24 MAKEBLOCK2 0 26 RETURN 2 28 ACC1 29 RETURN 2 31 RESTART 32 GRAB 3 34 CONST0 35 PUSHACC4 36 LEINT 37 BRANCHIFNOT 42 39 CONST0 40 RETURN 4 42 ACC3 43 PUSHACC3 44 PUSHACC3 45 PUSHACC3 46 C_CALL4 caml_input 48 PUSHCONST0 49 PUSHACC1 50 EQ 51 BRANCHIFNOT 58 53 GETGLOBAL End_of_file 55 MAKEBLOCK1 0 57 RAISE 58 ACC0 59 PUSHACC5 60 SUBINT 61 PUSHACC1 62 PUSHACC5 63 ADDINT 64 PUSHACC4 65 PUSHACC4 66 PUSHOFFSETCLOSURE0 67 APPTERM 4, 9 70 ACC0 71 C_CALL1 caml_input_scan_line 73 PUSHCONST0 74 PUSHACC1 75 EQ 76 BRANCHIFNOT 83 78 GETGLOBAL End_of_file 80 MAKEBLOCK1 0 82 RAISE 83 CONST0 84 PUSHACC1 85 GTINT 86 BRANCHIFNOT 107 88 ACC0 89 OFFSETINT -1 91 C_CALL1 create_string 93 PUSHACC1 94 OFFSETINT -1 96 PUSHCONST0 97 PUSHACC2 98 PUSHACC5 99 C_CALL4 caml_input 101 ACC2 102 C_CALL1 caml_input_char 104 ACC0 105 RETURN 3 107 ACC0 108 NEGINT 109 C_CALL1 create_string 111 PUSHACC1 112 NEGINT 113 PUSHCONST0 114 PUSHACC2 115 PUSHACC5 116 C_CALL4 caml_input 118 CONST0 119 PUSHTRAP 130 121 ACC6 122 PUSHOFFSETCLOSURE0 123 APPLY1 124 PUSHACC5 125 PUSHENVACC1 126 APPLY2 127 POPTRAP 128 RETURN 3 130 PUSHGETGLOBAL End_of_file 132 PUSHACC1 133 GETFIELD0 134 EQ 135 BRANCHIFNOT 140 137 ACC1 138 RETURN 4 140 ACC0 141 RAISE 142 ACC0 143 C_CALL1 caml_flush 145 RETURN 1 147 RESTART 148 GRAB 1 150 ACC1 151 PUSHACC1 152 C_CALL2 caml_output_char 154 RETURN 2 156 RESTART 157 GRAB 1 159 ACC1 160 PUSHACC1 161 C_CALL2 caml_output_char 163 RETURN 2 165 RESTART 166 GRAB 1 168 ACC1 169 PUSHACC1 170 C_CALL2 caml_output_int 172 RETURN 2 174 RESTART 175 GRAB 1 177 ACC1 178 PUSHACC1 179 C_CALL2 caml_seek_out 181 RETURN 2 183 ACC0 184 C_CALL1 caml_pos_out 186 RETURN 1 188 ACC0 189 C_CALL1 caml_channel_size 191 RETURN 1 193 RESTART 194 GRAB 1 196 ACC1 197 PUSHACC1 198 C_CALL2 caml_set_binary_mode 200 RETURN 2 202 ACC0 203 C_CALL1 caml_input_char 205 RETURN 1 207 ACC0 208 C_CALL1 caml_input_char 210 RETURN 1 212 ACC0 213 C_CALL1 caml_input_int 215 RETURN 1 217 ACC0 218 C_CALL1 input_value 220 RETURN 1 222 RESTART 223 GRAB 1 225 ACC1 226 PUSHACC1 227 C_CALL2 caml_seek_in 229 RETURN 2 231 ACC0 232 C_CALL1 caml_pos_in 234 RETURN 1 236 ACC0 237 C_CALL1 caml_channel_size 239 RETURN 1 241 ACC0 242 C_CALL1 caml_close_channel 244 RETURN 1 246 RESTART 247 GRAB 1 249 ACC1 250 PUSHACC1 251 C_CALL2 caml_set_binary_mode 253 RETURN 2 255 CONST0 256 PUSHENVACC1 257 APPLY1 258 ACC0 259 C_CALL1 sys_exit 261 RETURN 1 263 CONST0 264 PUSHENVACC1 265 GETFIELD0 266 APPTERM1 2 268 CONST0 269 PUSHENVACC1 270 APPLY1 271 CONST0 272 PUSHENVACC2 273 APPTERM1 2 275 ENVACC1 276 GETFIELD0 277 PUSHACC0 278 PUSHACC2 279 CLOSURE 2, 268 282 PUSHENVACC1 283 SETFIELD0 284 RETURN 2 286 ENVACC1 287 C_CALL1 caml_flush 289 ENVACC2 290 C_CALL1 caml_flush 292 RETURN 1 294 CONST0 295 PUSHENVACC1 296 APPLY1 297 C_CALL1 float_of_string 299 RETURN 1 301 CONST0 302 PUSHENVACC1 303 APPLY1 304 C_CALL1 int_of_string 306 RETURN 1 308 ENVACC2 309 C_CALL1 caml_flush 311 ENVACC1 312 PUSHENVACC3 313 APPTERM1 2 315 CONSTINT 13 317 PUSHENVACC1 318 C_CALL2 caml_output_char 320 ENVACC1 321 C_CALL1 caml_flush 323 RETURN 1 325 ACC0 326 PUSHENVACC1 327 PUSHENVACC2 328 APPLY2 329 CONSTINT 13 331 PUSHENVACC1 332 C_CALL2 caml_output_char 334 ENVACC1 335 C_CALL1 caml_flush 337 RETURN 1 339 ACC0 340 PUSHENVACC1 341 APPLY1 342 PUSHENVACC2 343 PUSHENVACC3 344 APPTERM2 3 346 ACC0 347 PUSHENVACC1 348 APPLY1 349 PUSHENVACC2 350 PUSHENVACC3 351 APPTERM2 3 353 ACC0 354 PUSHENVACC1 355 PUSHENVACC2 356 APPTERM2 3 358 ACC0 359 PUSHENVACC1 360 C_CALL2 caml_output_char 362 RETURN 1 364 CONSTINT 13 366 PUSHENVACC1 367 C_CALL2 caml_output_char 369 ENVACC1 370 C_CALL1 caml_flush 372 RETURN 1 374 ACC0 375 PUSHENVACC1 376 PUSHENVACC2 377 APPLY2 378 CONSTINT 13 380 PUSHENVACC1 381 C_CALL2 caml_output_char 383 RETURN 1 385 ACC0 386 PUSHENVACC1 387 APPLY1 388 PUSHENVACC2 389 PUSHENVACC3 390 APPTERM2 3 392 ACC0 393 PUSHENVACC1 394 APPLY1 395 PUSHENVACC2 396 PUSHENVACC3 397 APPTERM2 3 399 ACC0 400 PUSHENVACC1 401 PUSHENVACC2 402 APPTERM2 3 404 ACC0 405 PUSHENVACC1 406 C_CALL2 caml_output_char 408 RETURN 1 410 RESTART 411 GRAB 3 413 CONST0 414 PUSHACC3 415 LTINT 416 BRANCHIF 427 418 ACC1 419 C_CALL1 ml_string_length 421 PUSHACC4 422 PUSHACC4 423 ADDINT 424 GTINT 425 BRANCHIFNOT 432 427 GETGLOBAL "really_input" 429 PUSHENVACC1 430 APPTERM1 5 432 ACC3 433 PUSHACC3 434 PUSHACC3 435 PUSHACC3 436 PUSHENVACC2 437 APPTERM 4, 8 440 RESTART 441 GRAB 3 443 CONST0 444 PUSHACC3 445 LTINT 446 BRANCHIF 457 448 ACC1 449 C_CALL1 ml_string_length 451 PUSHACC4 452 PUSHACC4 453 ADDINT 454 GTINT 455 BRANCHIFNOT 462 457 GETGLOBAL "input" 459 PUSHENVACC1 460 APPTERM1 5 462 ACC3 463 PUSHACC3 464 PUSHACC3 465 PUSHACC3 466 C_CALL4 caml_input 468 RETURN 4 470 ACC0 471 PUSHCONST0 472 PUSHGETGLOBAL <0>(0, <0>(6, 0)) 474 PUSHENVACC1 475 APPTERM3 4 477 ACC0 478 PUSHCONST0 479 PUSHGETGLOBAL <0>(0, <0>(7, 0)) 481 PUSHENVACC1 482 APPTERM3 4 484 RESTART 485 GRAB 2 487 ACC1 488 PUSHACC1 489 PUSHACC4 490 C_CALL3 sys_open 492 C_CALL1 caml_open_descriptor 494 RETURN 3 496 ACC0 497 C_CALL1 caml_flush 499 ACC0 500 C_CALL1 caml_close_channel 502 RETURN 1 504 RESTART 505 GRAB 1 507 CONST0 508 PUSHACC2 509 PUSHACC2 510 C_CALL3 output_value 512 RETURN 2 514 RESTART 515 GRAB 3 517 CONST0 518 PUSHACC3 519 LTINT 520 BRANCHIF 531 522 ACC1 523 C_CALL1 ml_string_length 525 PUSHACC4 526 PUSHACC4 527 ADDINT 528 GTINT 529 BRANCHIFNOT 536 531 GETGLOBAL "output" 533 PUSHENVACC1 534 APPTERM1 5 536 ACC3 537 PUSHACC3 538 PUSHACC3 539 PUSHACC3 540 C_CALL4 caml_output 542 RETURN 4 544 RESTART 545 GRAB 1 547 ACC1 548 C_CALL1 ml_string_length 550 PUSHCONST0 551 PUSHACC3 552 PUSHACC3 553 C_CALL4 caml_output 555 RETURN 2 557 ACC0 558 PUSHCONSTINT 438 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0)))) 562 PUSHENVACC1 563 APPTERM3 4 565 ACC0 566 PUSHCONSTINT 438 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0)))) 570 PUSHENVACC1 571 APPTERM3 4 573 RESTART 574 GRAB 2 576 ACC1 577 PUSHACC1 578 PUSHACC4 579 C_CALL3 sys_open 581 C_CALL1 caml_open_descriptor 583 RETURN 3 585 ACC0 586 PUSHGETGLOBAL "%.12g" 588 C_CALL2 format_float 590 RETURN 1 592 ACC0 593 PUSHGETGLOBAL "%d" 595 C_CALL2 format_int 597 RETURN 1 599 GETGLOBAL "false" 601 PUSHACC1 602 C_CALL2 string_equal 604 BRANCHIFNOT 609 606 CONST0 607 RETURN 1 609 GETGLOBAL "true" 611 PUSHACC1 612 C_CALL2 string_equal 614 BRANCHIFNOT 619 616 CONST1 617 RETURN 1 619 GETGLOBAL "bool_of_string" 621 PUSHENVACC1 622 APPTERM1 2 624 ACC0 625 BRANCHIFNOT 631 627 GETGLOBAL "true" 629 RETURN 1 631 GETGLOBAL "false" 633 RETURN 1 635 CONST0 636 PUSHACC1 637 LTINT 638 BRANCHIF 646 640 CONSTINT 255 642 PUSHACC1 643 GTINT 644 BRANCHIFNOT 651 646 GETGLOBAL "char_of_int" 648 PUSHENVACC1 649 APPTERM1 2 651 ACC0 652 RETURN 1 654 RESTART 655 GRAB 1 657 ACC0 658 C_CALL1 ml_string_length 660 PUSHACC2 661 C_CALL1 ml_string_length 663 PUSHACC0 664 PUSHACC2 665 ADDINT 666 C_CALL1 create_string 668 PUSHACC2 669 PUSHCONST0 670 PUSHACC2 671 PUSHCONST0 672 PUSHACC7 673 C_CALL5 blit_string 675 ACC1 676 PUSHACC3 677 PUSHACC2 678 PUSHCONST0 679 PUSHACC 8 681 C_CALL5 blit_string 683 ACC0 684 RETURN 5 686 CONSTINT -1 688 PUSHACC1 689 XORINT 690 RETURN 1 692 CONST0 693 PUSHACC1 694 GEINT 695 BRANCHIFNOT 700 697 ACC0 698 RETURN 1 700 ACC0 701 NEGINT 702 RETURN 1 704 RESTART 705 GRAB 1 707 ACC1 708 PUSHACC1 709 C_CALL2 greaterequal 711 BRANCHIFNOT 716 713 ACC0 714 RETURN 2 716 ACC1 717 RETURN 2 719 RESTART 720 GRAB 1 722 ACC1 723 PUSHACC1 724 C_CALL2 lessequal 726 BRANCHIFNOT 731 728 ACC0 729 RETURN 2 731 ACC1 732 RETURN 2 734 ACC0 735 PUSHGETGLOBAL Invalid_argument 737 MAKEBLOCK2 0 739 RAISE 740 ACC0 741 PUSHGETGLOBAL Failure 743 MAKEBLOCK2 0 745 RAISE 746 CLOSURE 0, 740 749 PUSH 750 CLOSURE 0, 734 753 PUSHGETGLOBAL "Pervasives.Exit" 755 MAKEBLOCK1 0 757 PUSHGETGLOBAL "Pervasives.Assert_failure" 759 MAKEBLOCK1 0 761 PUSH 762 CLOSURE 0, 720 765 PUSH 766 CLOSURE 0, 705 769 PUSH 770 CLOSURE 0, 692 773 PUSH 774 CLOSURE 0, 686 777 PUSHCONST0 778 PUSHCONSTINT 31 780 PUSHCONST1 781 LSLINT 782 EQ 783 BRANCHIFNOT 789 785 CONSTINT 30 787 BRANCH 791 789 CONSTINT 62 791 PUSHCONST1 792 LSLINT 793 PUSHACC0 794 OFFSETINT -1 796 PUSH 797 CLOSURE 0, 655 800 PUSHACC 9 802 CLOSURE 1, 635 805 PUSH 806 CLOSURE 0, 624 809 PUSHACC 11 811 CLOSURE 1, 599 814 PUSH 815 CLOSURE 0, 592 818 PUSH 819 CLOSURE 0, 585 822 PUSH 823 CLOSUREREC 0, 12 827 CONST0 828 C_CALL1 caml_open_descriptor 830 PUSHCONST1 831 C_CALL1 caml_open_descriptor 833 PUSHCONST2 834 C_CALL1 caml_open_descriptor 836 PUSH 837 CLOSURE 0, 574 840 PUSHACC0 841 CLOSURE 1, 565 844 PUSHACC1 845 CLOSURE 1, 557 848 PUSH 849 CLOSURE 0, 545 852 PUSHACC 22 854 CLOSURE 1, 515 857 PUSH 858 CLOSURE 0, 505 861 PUSH 862 CLOSURE 0, 496 865 PUSH 866 CLOSURE 0, 485 869 PUSHACC0 870 CLOSURE 1, 477 873 PUSHACC1 874 CLOSURE 1, 470 877 PUSHACC 28 879 CLOSURE 1, 441 882 PUSH 883 CLOSUREREC 0, 32 887 ACC0 888 PUSHACC 31 890 CLOSURE 2, 411 893 PUSHACC 22 895 CLOSUREREC 1, 70 899 ACC 15 901 CLOSURE 1, 404 904 PUSHACC 11 906 PUSHACC 17 908 CLOSURE 2, 399 911 PUSHACC 12 913 PUSHACC 18 915 PUSHACC 23 917 CLOSURE 3, 392 920 PUSHACC 13 922 PUSHACC 19 924 PUSHACC 23 926 CLOSURE 3, 385 929 PUSHACC 14 931 PUSHACC 20 933 CLOSURE 2, 374 936 PUSHACC 20 938 CLOSURE 1, 364 941 PUSHACC 20 943 CLOSURE 1, 358 946 PUSHACC 17 948 PUSHACC 22 950 CLOSURE 2, 353 953 PUSHACC 18 955 PUSHACC 23 957 PUSHACC 29 959 CLOSURE 3, 346 962 PUSHACC 19 964 PUSHACC 24 966 PUSHACC 29 968 CLOSURE 3, 339 971 PUSHACC 20 973 PUSHACC 25 975 CLOSURE 2, 325 978 PUSHACC 25 980 CLOSURE 1, 315 983 PUSHACC 12 985 PUSHACC 28 987 PUSHACC 30 989 CLOSURE 3, 308 992 PUSHACC0 993 CLOSURE 1, 301 996 PUSHACC1 997 CLOSURE 1, 294 1000 PUSHACC 29 1002 PUSHACC 31 1004 CLOSURE 2, 286 1007 MAKEBLOCK1 0 1009 PUSHACC0 1010 CLOSURE 1, 275 1013 PUSHACC1 1014 CLOSURE 1, 263 1017 PUSHACC0 1018 CLOSURE 1, 255 1021 PUSHACC1 1022 PUSHACC 22 1024 PUSHACC4 1025 PUSHACC3 1026 PUSH 1027 CLOSURE 0, 247 1030 PUSH 1031 CLOSURE 0, 241 1034 PUSH 1035 CLOSURE 0, 236 1038 PUSH 1039 CLOSURE 0, 231 1042 PUSH 1043 CLOSURE 0, 223 1046 PUSH 1047 CLOSURE 0, 217 1050 PUSH 1051 CLOSURE 0, 212 1054 PUSH 1055 CLOSURE 0, 207 1058 PUSHACC 32 1060 PUSHACC 35 1062 PUSHACC 33 1064 PUSH 1065 CLOSURE 0, 202 1068 PUSHACC 41 1070 PUSHACC 40 1072 PUSHACC 42 1074 PUSH 1075 CLOSURE 0, 194 1078 PUSHACC 46 1080 PUSH 1081 CLOSURE 0, 188 1084 PUSH 1085 CLOSURE 0, 183 1088 PUSH 1089 CLOSURE 0, 175 1092 PUSHACC 51 1094 PUSH 1095 CLOSURE 0, 166 1098 PUSH 1099 CLOSURE 0, 157 1102 PUSHACC 55 1104 PUSHACC 57 1106 PUSH 1107 CLOSURE 0, 148 1110 PUSH 1111 CLOSURE 0, 142 1114 PUSHACC 63 1116 PUSHACC 62 1118 PUSHACC 64 1120 PUSHACC 38 1122 PUSHACC 40 1124 PUSHACC 42 1126 PUSHACC 44 1128 PUSHACC 46 1130 PUSHACC 48 1132 PUSHACC 50 1134 PUSHACC 52 1136 PUSHACC 54 1138 PUSHACC 56 1140 PUSHACC 58 1142 PUSHACC 60 1144 PUSHACC 62 1146 PUSHACC 64 1148 PUSHACC 66 1150 PUSHACC 82 1152 PUSHACC 84 1154 PUSHACC 86 1156 PUSHACC 88 1158 PUSHACC 90 1160 PUSHACC 92 1162 PUSHACC 94 1164 PUSHACC 96 1166 PUSHACC 98 1168 PUSHACC 100 1170 PUSHACC 104 1172 PUSHACC 104 1174 PUSHACC 104 1176 PUSHACC 108 1178 PUSHACC 110 1180 PUSHACC 112 1182 PUSHACC 117 1184 PUSHACC 117 1186 PUSHACC 117 1188 PUSHACC 117 1190 MAKEBLOCK 69, 0 1193 POP 53 1195 SETGLOBAL Pervasives 1197 BRANCH 2177 1199 RESTART 1200 GRAB 1 1202 ACC1 1203 BRANCHIFNOT 1213 1205 ACC1 1206 GETFIELD1 1207 PUSHACC1 1208 OFFSETINT 1 1210 PUSHOFFSETCLOSURE0 1211 APPTERM2 4 1213 ACC0 1214 RETURN 2 1216 RESTART 1217 GRAB 1 1219 ACC0 1220 BRANCHIFNOT 1251 1222 CONST0 1223 PUSHACC2 1224 EQ 1225 BRANCHIFNOT 1231 1227 ACC0 1228 GETFIELD0 1229 RETURN 2 1231 CONST0 1232 PUSHACC2 1233 GTINT 1234 BRANCHIFNOT 1244 1236 ACC1 1237 OFFSETINT -1 1239 PUSHACC1 1240 GETFIELD1 1241 PUSHOFFSETCLOSURE0 1242 APPTERM2 4 1244 GETGLOBAL "List.nth" 1246 PUSHGETGLOBALFIELD Pervasives, 2 1249 APPTERM1 3 1251 GETGLOBAL "nth" 1253 PUSHGETGLOBALFIELD Pervasives, 3 1256 APPTERM1 3 1258 RESTART 1259 GRAB 1 1261 ACC0 1262 BRANCHIFNOT 1274 1264 ACC1 1265 PUSHACC1 1266 GETFIELD0 1267 MAKEBLOCK2 0 1269 PUSHACC1 1270 GETFIELD1 1271 PUSHOFFSETCLOSURE0 1272 APPTERM2 4 1274 ACC1 1275 RETURN 2 1277 ACC0 1278 BRANCHIFNOT 1291 1280 ACC0 1281 GETFIELD1 1282 PUSHOFFSETCLOSURE0 1283 APPLY1 1284 PUSHACC1 1285 GETFIELD0 1286 PUSHGETGLOBALFIELD Pervasives, 16 1289 APPTERM2 3 1291 RETURN 1 1293 RESTART 1294 GRAB 1 1296 ACC1 1297 BRANCHIFNOT 1313 1299 ACC1 1300 GETFIELD0 1301 PUSHACC1 1302 APPLY1 1303 PUSHACC2 1304 GETFIELD1 1305 PUSHACC2 1306 PUSHOFFSETCLOSURE0 1307 APPLY2 1308 PUSHACC1 1309 MAKEBLOCK2 0 1311 POP 1 1313 RETURN 2 1315 RESTART 1316 GRAB 1 1318 ACC1 1319 BRANCHIFNOT 1331 1321 ACC1 1322 GETFIELD0 1323 PUSHACC1 1324 APPLY1 1325 ACC1 1326 GETFIELD1 1327 PUSHACC1 1328 PUSHOFFSETCLOSURE0 1329 APPTERM2 4 1331 RETURN 2 1333 RESTART 1334 GRAB 2 1336 ACC2 1337 BRANCHIFNOT 1350 1339 ACC2 1340 GETFIELD1 1341 PUSHACC3 1342 GETFIELD0 1343 PUSHACC3 1344 PUSHACC3 1345 APPLY2 1346 PUSHACC2 1347 PUSHOFFSETCLOSURE0 1348 APPTERM3 6 1350 ACC1 1351 RETURN 3 1353 RESTART 1354 GRAB 2 1356 ACC1 1357 BRANCHIFNOT 1370 1359 ACC2 1360 PUSHACC2 1361 GETFIELD1 1362 PUSHACC2 1363 PUSHOFFSETCLOSURE0 1364 APPLY3 1365 PUSHACC2 1366 GETFIELD0 1367 PUSHACC2 1368 APPTERM2 5 1370 ACC2 1371 RETURN 3 1373 RESTART 1374 GRAB 2 1376 ACC1 1377 BRANCHIFNOT 1400 1379 ACC2 1380 BRANCHIFNOT 1407 1382 ACC2 1383 GETFIELD0 1384 PUSHACC2 1385 GETFIELD0 1386 PUSHACC2 1387 APPLY2 1388 PUSHACC3 1389 GETFIELD1 1390 PUSHACC3 1391 GETFIELD1 1392 PUSHACC3 1393 PUSHOFFSETCLOSURE0 1394 APPLY3 1395 PUSHACC1 1396 MAKEBLOCK2 0 1398 RETURN 4 1400 ACC2 1401 BRANCHIFNOT 1405 1403 BRANCH 1407 1405 RETURN 3 1407 GETGLOBAL "List.map2" 1409 PUSHGETGLOBALFIELD Pervasives, 2 1412 APPTERM1 4 1414 RESTART 1415 GRAB 2 1417 ACC1 1418 BRANCHIFNOT 1437 1420 ACC2 1421 BRANCHIFNOT 1444 1423 ACC2 1424 GETFIELD0 1425 PUSHACC2 1426 GETFIELD0 1427 PUSHACC2 1428 APPLY2 1429 ACC2 1430 GETFIELD1 1431 PUSHACC2 1432 GETFIELD1 1433 PUSHACC2 1434 PUSHOFFSETCLOSURE0 1435 APPTERM3 6 1437 ACC2 1438 BRANCHIFNOT 1442 1440 BRANCH 1444 1442 RETURN 3 1444 GETGLOBAL "List.iter2" 1446 PUSHGETGLOBALFIELD Pervasives, 2 1449 APPTERM1 4 1451 RESTART 1452 GRAB 3 1454 ACC2 1455 BRANCHIFNOT 1476 1457 ACC3 1458 BRANCHIFNOT 1482 1460 ACC3 1461 GETFIELD1 1462 PUSHACC3 1463 GETFIELD1 1464 PUSHACC5 1465 GETFIELD0 1466 PUSHACC5 1467 GETFIELD0 1468 PUSHACC5 1469 PUSHACC5 1470 APPLY3 1471 PUSHACC3 1472 PUSHOFFSETCLOSURE0 1473 APPTERM 4, 8 1476 ACC3 1477 BRANCHIF 1482 1479 ACC1 1480 RETURN 4 1482 GETGLOBAL "List.fold_left2" 1484 PUSHGETGLOBALFIELD Pervasives, 2 1487 APPTERM1 5 1489 RESTART 1490 GRAB 3 1492 ACC1 1493 BRANCHIFNOT 1516 1495 ACC2 1496 BRANCHIFNOT 1522 1498 PUSH_RETADDR 1509 1500 ACC6 1501 PUSHACC6 1502 GETFIELD1 1503 PUSHACC6 1504 GETFIELD1 1505 PUSHACC6 1506 PUSHOFFSETCLOSURE0 1507 APPLY 4 1509 PUSHACC3 1510 GETFIELD0 1511 PUSHACC3 1512 GETFIELD0 1513 PUSHACC3 1514 APPTERM3 7 1516 ACC2 1517 BRANCHIF 1522 1519 ACC3 1520 RETURN 4 1522 GETGLOBAL "List.fold_right2" 1524 PUSHGETGLOBALFIELD Pervasives, 2 1527 APPTERM1 5 1529 RESTART 1530 GRAB 1 1532 ACC1 1533 BRANCHIFNOT 1549 1535 ACC1 1536 GETFIELD0 1537 PUSHACC1 1538 APPLY1 1539 BRANCHIFNOT 1547 1541 ACC1 1542 GETFIELD1 1543 PUSHACC1 1544 PUSHOFFSETCLOSURE0 1545 APPTERM2 4 1547 RETURN 2 1549 CONST1 1550 RETURN 2 1552 RESTART 1553 GRAB 1 1555 ACC1 1556 BRANCHIFNOT 1570 1558 ACC1 1559 GETFIELD0 1560 PUSHACC1 1561 APPLY1 1562 BRANCHIF 1570 1564 ACC1 1565 GETFIELD1 1566 PUSHACC1 1567 PUSHOFFSETCLOSURE0 1568 APPTERM2 4 1570 RETURN 2 1572 RESTART 1573 GRAB 2 1575 ACC1 1576 BRANCHIFNOT 1599 1578 ACC2 1579 BRANCHIFNOT 1605 1581 ACC2 1582 GETFIELD0 1583 PUSHACC2 1584 GETFIELD0 1585 PUSHACC2 1586 APPLY2 1587 BRANCHIFNOT 1597 1589 ACC2 1590 GETFIELD1 1591 PUSHACC2 1592 GETFIELD1 1593 PUSHACC2 1594 PUSHOFFSETCLOSURE0 1595 APPTERM3 6 1597 RETURN 3 1599 ACC2 1600 BRANCHIF 1605 1602 CONST1 1603 RETURN 3 1605 GETGLOBAL "List.for_all2" 1607 PUSHGETGLOBALFIELD Pervasives, 2 1610 APPTERM1 4 1612 RESTART 1613 GRAB 2 1615 ACC1 1616 BRANCHIFNOT 1639 1618 ACC2 1619 BRANCHIFNOT 1646 1621 ACC2 1622 GETFIELD0 1623 PUSHACC2 1624 GETFIELD0 1625 PUSHACC2 1626 APPLY2 1627 BRANCHIF 1637 1629 ACC2 1630 GETFIELD1 1631 PUSHACC2 1632 GETFIELD1 1633 PUSHACC2 1634 PUSHOFFSETCLOSURE0 1635 APPTERM3 6 1637 RETURN 3 1639 ACC2 1640 BRANCHIFNOT 1644 1642 BRANCH 1646 1644 RETURN 3 1646 GETGLOBAL "List.exists2" 1648 PUSHGETGLOBALFIELD Pervasives, 2 1651 APPTERM1 4 1653 RESTART 1654 GRAB 1 1656 ACC1 1657 BRANCHIFNOT 1672 1659 ACC0 1660 PUSHACC2 1661 GETFIELD0 1662 C_CALL2 equal 1664 BRANCHIF 1672 1666 ACC1 1667 GETFIELD1 1668 PUSHACC1 1669 PUSHOFFSETCLOSURE0 1670 APPTERM2 4 1672 RETURN 2 1674 RESTART 1675 GRAB 1 1677 ACC1 1678 BRANCHIFNOT 1692 1680 ACC0 1681 PUSHACC2 1682 GETFIELD0 1683 EQ 1684 BRANCHIF 1692 1686 ACC1 1687 GETFIELD1 1688 PUSHACC1 1689 PUSHOFFSETCLOSURE0 1690 APPTERM2 4 1692 RETURN 2 1694 RESTART 1695 GRAB 1 1697 ACC1 1698 BRANCHIFNOT 1719 1700 ACC1 1701 GETFIELD0 1702 PUSHACC1 1703 PUSHACC1 1704 GETFIELD0 1705 C_CALL2 equal 1707 BRANCHIFNOT 1713 1709 ACC0 1710 GETFIELD1 1711 RETURN 3 1713 ACC2 1714 GETFIELD1 1715 PUSHACC2 1716 PUSHOFFSETCLOSURE0 1717 APPTERM2 5 1719 GETGLOBAL Not_found 1721 MAKEBLOCK1 0 1723 RAISE 1724 RESTART 1725 GRAB 1 1727 ACC1 1728 BRANCHIFNOT 1748 1730 ACC1 1731 GETFIELD0 1732 PUSHACC1 1733 PUSHACC1 1734 GETFIELD0 1735 EQ 1736 BRANCHIFNOT 1742 1738 ACC0 1739 GETFIELD1 1740 RETURN 3 1742 ACC2 1743 GETFIELD1 1744 PUSHACC2 1745 PUSHOFFSETCLOSURE0 1746 APPTERM2 5 1748 GETGLOBAL Not_found 1750 MAKEBLOCK1 0 1752 RAISE 1753 RESTART 1754 GRAB 1 1756 ACC1 1757 BRANCHIFNOT 1773 1759 ACC0 1760 PUSHACC2 1761 GETFIELD0 1762 GETFIELD0 1763 C_CALL2 equal 1765 BRANCHIF 1773 1767 ACC1 1768 GETFIELD1 1769 PUSHACC1 1770 PUSHOFFSETCLOSURE0 1771 APPTERM2 4 1773 RETURN 2 1775 RESTART 1776 GRAB 1 1778 ACC1 1779 BRANCHIFNOT 1794 1781 ACC0 1782 PUSHACC2 1783 GETFIELD0 1784 GETFIELD0 1785 EQ 1786 BRANCHIF 1794 1788 ACC1 1789 GETFIELD1 1790 PUSHACC1 1791 PUSHOFFSETCLOSURE0 1792 APPTERM2 4 1794 RETURN 2 1796 RESTART 1797 GRAB 1 1799 ACC1 1800 BRANCHIFNOT 1825 1802 ACC1 1803 GETFIELD0 1804 PUSHACC2 1805 GETFIELD1 1806 PUSHACC2 1807 PUSHACC2 1808 GETFIELD0 1809 C_CALL2 equal 1811 BRANCHIFNOT 1816 1813 ACC0 1814 RETURN 4 1816 ACC0 1817 PUSHACC3 1818 PUSHOFFSETCLOSURE0 1819 APPLY2 1820 PUSHACC2 1821 MAKEBLOCK2 0 1823 POP 2 1825 RETURN 2 1827 RESTART 1828 GRAB 1 1830 ACC1 1831 BRANCHIFNOT 1855 1833 ACC1 1834 GETFIELD0 1835 PUSHACC2 1836 GETFIELD1 1837 PUSHACC2 1838 PUSHACC2 1839 GETFIELD0 1840 EQ 1841 BRANCHIFNOT 1846 1843 ACC0 1844 RETURN 4 1846 ACC0 1847 PUSHACC3 1848 PUSHOFFSETCLOSURE0 1849 APPLY2 1850 PUSHACC2 1851 MAKEBLOCK2 0 1853 POP 2 1855 RETURN 2 1857 RESTART 1858 GRAB 1 1860 ACC1 1861 BRANCHIFNOT 1879 1863 ACC1 1864 GETFIELD0 1865 PUSHACC0 1866 PUSHACC2 1867 APPLY1 1868 BRANCHIFNOT 1873 1870 ACC0 1871 RETURN 3 1873 ACC2 1874 GETFIELD1 1875 PUSHACC2 1876 PUSHOFFSETCLOSURE0 1877 APPTERM2 5 1879 GETGLOBAL Not_found 1881 MAKEBLOCK1 0 1883 RAISE 1884 RESTART 1885 GRAB 2 1887 ACC2 1888 BRANCHIFNOT 1917 1890 ACC2 1891 GETFIELD0 1892 PUSHACC3 1893 GETFIELD1 1894 PUSHACC1 1895 PUSHENVACC2 1896 APPLY1 1897 BRANCHIFNOT 1908 1899 ACC0 1900 PUSHACC4 1901 PUSHACC4 1902 PUSHACC4 1903 MAKEBLOCK2 0 1905 PUSHOFFSETCLOSURE0 1906 APPTERM3 8 1908 ACC0 1909 PUSHACC4 1910 PUSHACC3 1911 MAKEBLOCK2 0 1913 PUSHACC4 1914 PUSHOFFSETCLOSURE0 1915 APPTERM3 8 1917 ACC1 1918 PUSHENVACC1 1919 APPLY1 1920 PUSHACC1 1921 PUSHENVACC1 1922 APPLY1 1923 MAKEBLOCK2 0 1925 RETURN 3 1927 RESTART 1928 GRAB 1 1930 ACC0 1931 PUSHENVACC1 1932 CLOSUREREC 2, 1885 1936 ACC2 1937 PUSHCONST0 1938 PUSHCONST0 1939 PUSHACC3 1940 APPTERM3 6 1942 ACC0 1943 BRANCHIFNOT 1967 1945 ACC0 1946 GETFIELD0 1947 PUSHACC1 1948 GETFIELD1 1949 PUSHOFFSETCLOSURE0 1950 APPLY1 1951 PUSHACC0 1952 GETFIELD1 1953 PUSHACC2 1954 GETFIELD1 1955 MAKEBLOCK2 0 1957 PUSHACC1 1958 GETFIELD0 1959 PUSHACC3 1960 GETFIELD0 1961 MAKEBLOCK2 0 1963 MAKEBLOCK2 0 1965 RETURN 3 1967 GETGLOBAL <0>(0, 0) 1969 RETURN 1 1971 RESTART 1972 GRAB 1 1974 ACC0 1975 BRANCHIFNOT 1996 1977 ACC1 1978 BRANCHIFNOT 2003 1980 ACC1 1981 GETFIELD1 1982 PUSHACC1 1983 GETFIELD1 1984 PUSHOFFSETCLOSURE0 1985 APPLY2 1986 PUSHACC2 1987 GETFIELD0 1988 PUSHACC2 1989 GETFIELD0 1990 MAKEBLOCK2 0 1992 MAKEBLOCK2 0 1994 RETURN 2 1996 ACC1 1997 BRANCHIFNOT 2001 1999 BRANCH 2003 2001 RETURN 2 2003 GETGLOBAL "List.combine" 2005 PUSHGETGLOBALFIELD Pervasives, 2 2008 APPTERM1 3 2010 RESTART 2011 GRAB 1 2013 ACC1 2014 BRANCHIFNOT 2038 2016 ACC1 2017 GETFIELD0 2018 PUSHACC2 2019 GETFIELD1 2020 PUSHACC1 2021 PUSHENVACC2 2022 APPLY1 2023 BRANCHIFNOT 2033 2025 ACC0 2026 PUSHACC3 2027 PUSHACC3 2028 MAKEBLOCK2 0 2030 PUSHOFFSETCLOSURE0 2031 APPTERM2 6 2033 ACC0 2034 PUSHACC3 2035 PUSHOFFSETCLOSURE0 2036 APPTERM2 6 2038 ACC0 2039 PUSHENVACC1 2040 APPTERM1 3 2042 ACC0 2043 PUSHENVACC1 2044 CLOSUREREC 2, 2011 2048 CONST0 2049 PUSHACC1 2050 APPTERM1 3 2052 RESTART 2053 GRAB 2 2055 ACC1 2056 BRANCHIFNOT 2077 2058 ACC2 2059 BRANCHIFNOT 2084 2061 ACC2 2062 GETFIELD1 2063 PUSHACC2 2064 GETFIELD1 2065 PUSHACC2 2066 PUSHACC5 2067 GETFIELD0 2068 PUSHACC5 2069 GETFIELD0 2070 PUSHENVACC1 2071 APPLY2 2072 MAKEBLOCK2 0 2074 PUSHOFFSETCLOSURE0 2075 APPTERM3 6 2077 ACC2 2078 BRANCHIFNOT 2082 2080 BRANCH 2084 2082 RETURN 3 2084 GETGLOBAL "List.rev_map2" 2086 PUSHGETGLOBALFIELD Pervasives, 2 2089 APPTERM1 4 2091 RESTART 2092 GRAB 2 2094 ACC0 2095 CLOSUREREC 1, 2053 2099 ACC3 2100 PUSHACC3 2101 PUSHCONST0 2102 PUSHACC3 2103 APPTERM3 7 2105 RESTART 2106 GRAB 1 2108 ACC1 2109 BRANCHIFNOT 2123 2111 ACC1 2112 GETFIELD1 2113 PUSHACC1 2114 PUSHACC3 2115 GETFIELD0 2116 PUSHENVACC1 2117 APPLY1 2118 MAKEBLOCK2 0 2120 PUSHOFFSETCLOSURE0 2121 APPTERM2 4 2123 ACC0 2124 RETURN 2 2126 RESTART 2127 GRAB 1 2129 ACC0 2130 CLOSUREREC 1, 2106 2134 ACC2 2135 PUSHCONST0 2136 PUSHACC2 2137 APPTERM2 5 2139 CONST0 2140 PUSHACC1 2141 PUSHENVACC1 2142 APPTERM2 3 2144 ACC0 2145 BRANCHIFNOT 2151 2147 ACC0 2148 GETFIELD1 2149 RETURN 1 2151 GETGLOBAL "tl" 2153 PUSHGETGLOBALFIELD Pervasives, 3 2156 APPTERM1 2 2158 ACC0 2159 BRANCHIFNOT 2165 2161 ACC0 2162 GETFIELD0 2163 RETURN 1 2165 GETGLOBAL "hd" 2167 PUSHGETGLOBALFIELD Pervasives, 3 2170 APPTERM1 2 2172 ACC0 2173 PUSHCONST0 2174 PUSHENVACC1 2175 APPTERM2 3 2177 CLOSUREREC 0, 1200 2181 ACC0 2182 CLOSURE 1, 2172 2185 PUSH 2186 CLOSURE 0, 2158 2189 PUSH 2190 CLOSURE 0, 2144 2193 PUSH 2194 CLOSUREREC 0, 1217 2198 GETGLOBALFIELD Pervasives, 16 2201 PUSH 2202 CLOSUREREC 0, 1259 2206 ACC0 2207 CLOSURE 1, 2139 2210 PUSH 2211 CLOSUREREC 0, 1277 2215 CLOSUREREC 0, 1294 2219 CLOSURE 0, 2127 2222 PUSH 2223 CLOSUREREC 0, 1316 2227 CLOSUREREC 0, 1334 2231 CLOSUREREC 0, 1354 2235 CLOSUREREC 0, 1374 2239 CLOSURE 0, 2092 2242 PUSH 2243 CLOSUREREC 0, 1415 2247 CLOSUREREC 0, 1452 2251 CLOSUREREC 0, 1490 2255 CLOSUREREC 0, 1530 2259 CLOSUREREC 0, 1553 2263 CLOSUREREC 0, 1573 2267 CLOSUREREC 0, 1613 2271 CLOSUREREC 0, 1654 2275 CLOSUREREC 0, 1675 2279 CLOSUREREC 0, 1695 2283 CLOSUREREC 0, 1725 2287 CLOSUREREC 0, 1754 2291 CLOSUREREC 0, 1776 2295 CLOSUREREC 0, 1797 2299 CLOSUREREC 0, 1828 2303 CLOSUREREC 0, 1858 2307 ACC 24 2309 CLOSURE 1, 2042 2312 PUSHACC 25 2314 CLOSUREREC 1, 1928 2318 CLOSUREREC 0, 1942 2322 CLOSUREREC 0, 1972 2326 ACC0 2327 PUSHACC2 2328 PUSHACC7 2329 PUSHACC 9 2331 PUSHACC 11 2333 PUSHACC 13 2335 PUSHACC 15 2337 PUSHACC 17 2339 PUSHACC 10 2341 PUSHACC 12 2343 PUSHACC 13 2345 PUSHACC 15 2347 PUSHACC 23 2349 PUSHACC 25 2351 PUSHACC 27 2353 PUSHACC 29 2355 PUSHACC 31 2357 PUSHACC 33 2359 PUSHACC 35 2361 PUSHACC 37 2363 PUSHACC 40 2365 PUSHACC 42 2367 PUSHACC 41 2369 PUSHACC 45 2371 PUSHACC 47 2373 PUSHACC 50 2375 PUSHACC 52 2377 PUSHACC 51 2379 PUSHACC 55 2381 PUSHACC 56 2383 PUSHACC 59 2385 PUSHACC 61 2387 PUSHACC 60 2389 PUSHACC 64 2391 PUSHACC 66 2393 PUSHACC 68 2395 PUSHACC 70 2397 MAKEBLOCK 37, 0 2400 POP 36 2402 SETGLOBAL List 2404 BRANCH 2435 2406 RESTART 2407 GRAB 1 2409 CONST0 2410 PUSHACC2 2411 LEINT 2412 BRANCHIFNOT 2417 2414 ACC0 2415 RETURN 2 2417 ACC1 2418 OFFSETINT -1 2420 PUSHACC1 2421 PUSHCONST1 2422 MAKEBLOCK2 0 2424 PUSHOFFSETCLOSURE0 2425 APPTERM2 4 2427 RESTART 2428 GRAB 1 2430 ACC1 2431 PUSHACC1 2432 ADDINT 2433 RETURN 2 2435 CLOSUREREC 0, 2407 2439 CONSTINT 30000 2441 PUSHCONST0 2442 PUSHACC2 2443 APPLY2 2444 PUSHCONSTINT 30000 2446 PUSHACC1 2447 PUSHCONST0 2448 PUSH 2449 CLOSURE 0, 2428 2452 PUSHGETGLOBALFIELD List, 12 2455 APPLY3 2456 NEQ 2457 BRANCHIFNOT 2464 2459 GETGLOBAL Not_found 2461 MAKEBLOCK1 0 2463 RAISE 2464 POP 2 2466 ATOM0 2467 SETGLOBAL T310-alloc-1 2469 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t092-pushacc0.ml0000644000175000017500000000056412124403241023460 0ustar tootstootsopen Lib;; let x = false in if x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHACC0 11 BRANCHIFNOT 18 13 GETGLOBAL Not_found 15 MAKEBLOCK1 0 17 RAISE 18 POP 1 20 ATOM0 21 SETGLOBAL T092-pushacc0 23 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-modint-2.ml0000644000175000017500000000112712124403241023366 0ustar tootstootsopen Lib;; try ignore (2 mod 0); raise Not_found; with Division_by_zero -> () ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 PUSHTRAP 19 11 CONST0 12 PUSHCONST2 13 MODINT 14 GETGLOBAL Not_found 16 MAKEBLOCK1 0 18 RAISE 19 PUSHGETGLOBAL Division_by_zero 21 PUSHACC1 22 GETFIELD0 23 EQ 24 BRANCHIFNOT 29 26 CONST0 27 BRANCH 31 29 ACC0 30 RAISE 31 POP 1 33 ATOM0 34 SETGLOBAL T110-modint-2 36 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-modint-1.ml0000644000175000017500000000063112124403241023364 0ustar tootstootsopen Lib;; if 20 mod 3 <> 2 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST2 10 PUSHCONST3 11 PUSHCONSTINT 20 13 MODINT 14 NEQ 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 ATOM0 23 SETGLOBAL T110-modint-1 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t192-getfloatfield-1.ml0000644000175000017500000000074612124403241024724 0ustar tootstootsopen Lib;; type t = { a : float; b : float };; if { a = 0.1; b = 0.2 }.a <> 0.1 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL 0.1 11 PUSHGETGLOBAL [|0.1, 0.2|] 13 GETFLOATFIELD 0 15 C_CALL2 neq_float 17 BRANCHIFNOT 24 19 GETGLOBAL Not_found 21 MAKEBLOCK1 0 23 RAISE 24 ATOM0 25 SETGLOBAL T192-getfloatfield-1 27 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t253-offsetclosurem2.ml0000644000175000017500000000115412124403241025067 0ustar tootstootsopen Lib;; let rec f _ = 11 and g _ = f in if g 3 4 <> 11 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 18 11 CONSTINT 11 13 RETURN 1 15 OFFSETCLOSUREM2 16 RETURN 1 18 CLOSUREREC 0, 11, 15 23 CONSTINT 11 25 PUSHCONSTINT 4 27 PUSHCONST3 28 PUSHACC3 29 APPLY2 30 NEQ 31 BRANCHIFNOT 38 33 GETGLOBAL Not_found 35 MAKEBLOCK1 0 37 RAISE 38 POP 2 40 ATOM0 41 SETGLOBAL T253-offsetclosurem2 43 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/Makefile0000644000175000017500000000076512124403241022367 0ustar tootstootsBASEDIR=../.. SHOULD_FAIL=t060-raise.ml compile: lib.cmo @for file in t*.ml; do \ printf " ... testing '$$file'"; \ if [ `echo $(SHOULD_FAIL) | grep $$file` ]; then \ $(OCAML) -w a lib.cmo $$file 2> /dev/null && (echo " => failed" && exit 1) || echo " => passed"; \ else \ $(OCAML) -w a lib.cmo $$file 2> /dev/null && echo " => passed" || (echo " => failed" && exit 1); \ fi; \ done promote: clean: defaultclean @rm -f ./a.out include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t180-appterm2.ml0000644000175000017500000000127112124403241023476 0ustar tootstootsopen Lib;; let f _ _ = 12 in let g _ = f 0 0 in if g 0 <> 12 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 23 11 CONST0 12 PUSHCONST0 13 PUSHENVACC1 14 APPTERM2 3 16 RESTART 17 GRAB 1 19 CONSTINT 12 21 RETURN 2 23 CLOSURE 0, 17 26 PUSHACC0 27 CLOSURE 1, 11 30 PUSHCONSTINT 12 32 PUSHCONST0 33 PUSHACC2 34 APPLY1 35 NEQ 36 BRANCHIFNOT 43 38 GETGLOBAL Not_found 40 MAKEBLOCK1 0 42 RAISE 43 POP 2 45 ATOM0 46 SETGLOBAL T180-appterm2 48 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t142-switch-9.ml0000644000175000017500000000100712124403241023406 0ustar tootstootsopen Lib;; type t = | A | B of int | C of int ;; match B 0 with | B _ -> () | _ -> raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL <0>(0) 11 PUSHACC0 12 SWITCH int 0 -> 20 tag 0 -> 17 tag 1 -> 20 17 CONST0 18 BRANCH 25 20 GETGLOBAL Not_found 22 MAKEBLOCK1 0 24 RAISE 25 POP 1 27 ATOM0 28 SETGLOBAL T142-switch-9 30 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t092-pushacc.ml0000644000175000017500000000123312124403241023372 0ustar tootstootsopen Lib;; let x = false in let y = true in let z = true in let a = true in let b = true in let c = true in let d = true in let e = true in let f = true in if x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST1 11 PUSHCONST1 12 PUSHCONST1 13 PUSHCONST1 14 PUSHCONST1 15 PUSHCONST1 16 PUSHCONST1 17 PUSHCONST1 18 PUSHACC 8 20 BRANCHIFNOT 27 22 GETGLOBAL Not_found 24 MAKEBLOCK1 0 26 RAISE 27 POP 9 29 ATOM0 30 SETGLOBAL T092-pushacc 32 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t230-check_signals.ml0000644000175000017500000000074712124403241024544 0ustar tootstootsopen Lib;; for i = 0 to 0 do () done;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST0 11 PUSH 12 BRANCH 21 14 CHECK_SIGNALS 15 CONST0 16 ACC1 17 OFFSETINT 1 19 ASSIGN 1 21 ACC0 22 PUSHACC2 23 LEINT 24 BRANCHIF 14 26 CONST0 27 POP 2 29 ATOM0 30 SETGLOBAL T230-check_signals 32 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t010-const1.ml0000644000175000017500000000013412124403241023140 0ustar tootstoots1;; (** 0 CONST1 1 ATOM0 2 SETGLOBAL T010-const1 4 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t050-pushgetglobal.ml0000644000175000017500000000023712124403241024601 0ustar tootstootslet _ = () in 0.01;; (** 0 CONST0 1 PUSHGETGLOBAL 0.01 3 POP 1 5 ATOM0 6 SETGLOBAL T050-pushgetglobal 8 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t090-acc0.ml0000644000175000017500000000063212124403241022552 0ustar tootstootsopen Lib;; let x = true in (); if not x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONST0 11 ACC0 12 BOOLNOT 13 BRANCHIFNOT 20 15 GETGLOBAL Not_found 17 MAKEBLOCK1 0 19 RAISE 20 POP 1 22 ATOM0 23 SETGLOBAL T090-acc0 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t210-setfield3.ml0000644000175000017500000000134712124403241023624 0ustar tootstootsopen Lib;; type t = { mutable a : int; mutable b : int; mutable c : int; mutable d : int; };; let x = {a = 7; b = 6; c = 5; d = 4} in x.d <- 11; if x.d <> 11 then raise Not_found; x ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 4 11 PUSHCONSTINT 5 13 PUSHCONSTINT 6 15 PUSHCONSTINT 7 17 MAKEBLOCK 4, 0 20 PUSHCONSTINT 11 22 PUSHACC1 23 SETFIELD3 24 CONSTINT 11 26 PUSHACC1 27 GETFIELD3 28 NEQ 29 BRANCHIFNOT 36 31 GETGLOBAL Not_found 33 MAKEBLOCK1 0 35 RAISE 36 ACC0 37 POP 1 39 ATOM0 40 SETGLOBAL T210-setfield3 42 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t240-c_call1.ml0000644000175000017500000000066212124403241023242 0ustar tootstootsopen Lib;; if Pervasives.int_of_string "123" <> 123 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 123 11 PUSHGETGLOBAL "123" 13 C_CALL1 int_of_string 15 NEQ 16 BRANCHIFNOT 23 18 GETGLOBAL Not_found 20 MAKEBLOCK1 0 22 RAISE 23 ATOM0 24 SETGLOBAL T240-c_call1 26 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t340-weak.ml0000644000175000017500000014667612124403241022714 0ustar tootstootsopen Lib;; let x = Array.make 20 "" in let w = weak_create 20 in for i = 0 to 19 do x.(i) <- String.make 20 's'; weak_set w i (Some x.(i)); done; Gc.full_major (); for i = 0 to 19 do match weak_get w i with | None -> raise Not_found | _ -> () done; for i = 0 to 19 do if i mod 2 = 0 then x.(i) <- "" done; Gc.full_major (); for i = 0 to 19 do match weak_get w i with | None when i mod 2 = 0 -> () | Some s when i mod 2 = 1 -> if s.[5] <> 's' then raise Not_found | _ -> raise Not_found done ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 746 11 RESTART 12 GRAB 1 14 ACC0 15 BRANCHIFNOT 28 17 ACC1 18 PUSHACC1 19 GETFIELD1 20 PUSHOFFSETCLOSURE0 21 APPLY2 22 PUSHACC1 23 GETFIELD0 24 MAKEBLOCK2 0 26 RETURN 2 28 ACC1 29 RETURN 2 31 RESTART 32 GRAB 3 34 CONST0 35 PUSHACC4 36 LEINT 37 BRANCHIFNOT 42 39 CONST0 40 RETURN 4 42 ACC3 43 PUSHACC3 44 PUSHACC3 45 PUSHACC3 46 C_CALL4 caml_input 48 PUSHCONST0 49 PUSHACC1 50 EQ 51 BRANCHIFNOT 58 53 GETGLOBAL End_of_file 55 MAKEBLOCK1 0 57 RAISE 58 ACC0 59 PUSHACC5 60 SUBINT 61 PUSHACC1 62 PUSHACC5 63 ADDINT 64 PUSHACC4 65 PUSHACC4 66 PUSHOFFSETCLOSURE0 67 APPTERM 4, 9 70 ACC0 71 C_CALL1 caml_input_scan_line 73 PUSHCONST0 74 PUSHACC1 75 EQ 76 BRANCHIFNOT 83 78 GETGLOBAL End_of_file 80 MAKEBLOCK1 0 82 RAISE 83 CONST0 84 PUSHACC1 85 GTINT 86 BRANCHIFNOT 107 88 ACC0 89 OFFSETINT -1 91 C_CALL1 create_string 93 PUSHACC1 94 OFFSETINT -1 96 PUSHCONST0 97 PUSHACC2 98 PUSHACC5 99 C_CALL4 caml_input 101 ACC2 102 C_CALL1 caml_input_char 104 ACC0 105 RETURN 3 107 ACC0 108 NEGINT 109 C_CALL1 create_string 111 PUSHACC1 112 NEGINT 113 PUSHCONST0 114 PUSHACC2 115 PUSHACC5 116 C_CALL4 caml_input 118 CONST0 119 PUSHTRAP 130 121 ACC6 122 PUSHOFFSETCLOSURE0 123 APPLY1 124 PUSHACC5 125 PUSHENVACC1 126 APPLY2 127 POPTRAP 128 RETURN 3 130 PUSHGETGLOBAL End_of_file 132 PUSHACC1 133 GETFIELD0 134 EQ 135 BRANCHIFNOT 140 137 ACC1 138 RETURN 4 140 ACC0 141 RAISE 142 ACC0 143 C_CALL1 caml_flush 145 RETURN 1 147 RESTART 148 GRAB 1 150 ACC1 151 PUSHACC1 152 C_CALL2 caml_output_char 154 RETURN 2 156 RESTART 157 GRAB 1 159 ACC1 160 PUSHACC1 161 C_CALL2 caml_output_char 163 RETURN 2 165 RESTART 166 GRAB 1 168 ACC1 169 PUSHACC1 170 C_CALL2 caml_output_int 172 RETURN 2 174 RESTART 175 GRAB 1 177 ACC1 178 PUSHACC1 179 C_CALL2 caml_seek_out 181 RETURN 2 183 ACC0 184 C_CALL1 caml_pos_out 186 RETURN 1 188 ACC0 189 C_CALL1 caml_channel_size 191 RETURN 1 193 RESTART 194 GRAB 1 196 ACC1 197 PUSHACC1 198 C_CALL2 caml_set_binary_mode 200 RETURN 2 202 ACC0 203 C_CALL1 caml_input_char 205 RETURN 1 207 ACC0 208 C_CALL1 caml_input_char 210 RETURN 1 212 ACC0 213 C_CALL1 caml_input_int 215 RETURN 1 217 ACC0 218 C_CALL1 input_value 220 RETURN 1 222 RESTART 223 GRAB 1 225 ACC1 226 PUSHACC1 227 C_CALL2 caml_seek_in 229 RETURN 2 231 ACC0 232 C_CALL1 caml_pos_in 234 RETURN 1 236 ACC0 237 C_CALL1 caml_channel_size 239 RETURN 1 241 ACC0 242 C_CALL1 caml_close_channel 244 RETURN 1 246 RESTART 247 GRAB 1 249 ACC1 250 PUSHACC1 251 C_CALL2 caml_set_binary_mode 253 RETURN 2 255 CONST0 256 PUSHENVACC1 257 APPLY1 258 ACC0 259 C_CALL1 sys_exit 261 RETURN 1 263 CONST0 264 PUSHENVACC1 265 GETFIELD0 266 APPTERM1 2 268 CONST0 269 PUSHENVACC1 270 APPLY1 271 CONST0 272 PUSHENVACC2 273 APPTERM1 2 275 ENVACC1 276 GETFIELD0 277 PUSHACC0 278 PUSHACC2 279 CLOSURE 2, 268 282 PUSHENVACC1 283 SETFIELD0 284 RETURN 2 286 ENVACC1 287 C_CALL1 caml_flush 289 ENVACC2 290 C_CALL1 caml_flush 292 RETURN 1 294 CONST0 295 PUSHENVACC1 296 APPLY1 297 C_CALL1 float_of_string 299 RETURN 1 301 CONST0 302 PUSHENVACC1 303 APPLY1 304 C_CALL1 int_of_string 306 RETURN 1 308 ENVACC2 309 C_CALL1 caml_flush 311 ENVACC1 312 PUSHENVACC3 313 APPTERM1 2 315 CONSTINT 13 317 PUSHENVACC1 318 C_CALL2 caml_output_char 320 ENVACC1 321 C_CALL1 caml_flush 323 RETURN 1 325 ACC0 326 PUSHENVACC1 327 PUSHENVACC2 328 APPLY2 329 CONSTINT 13 331 PUSHENVACC1 332 C_CALL2 caml_output_char 334 ENVACC1 335 C_CALL1 caml_flush 337 RETURN 1 339 ACC0 340 PUSHENVACC1 341 APPLY1 342 PUSHENVACC2 343 PUSHENVACC3 344 APPTERM2 3 346 ACC0 347 PUSHENVACC1 348 APPLY1 349 PUSHENVACC2 350 PUSHENVACC3 351 APPTERM2 3 353 ACC0 354 PUSHENVACC1 355 PUSHENVACC2 356 APPTERM2 3 358 ACC0 359 PUSHENVACC1 360 C_CALL2 caml_output_char 362 RETURN 1 364 CONSTINT 13 366 PUSHENVACC1 367 C_CALL2 caml_output_char 369 ENVACC1 370 C_CALL1 caml_flush 372 RETURN 1 374 ACC0 375 PUSHENVACC1 376 PUSHENVACC2 377 APPLY2 378 CONSTINT 13 380 PUSHENVACC1 381 C_CALL2 caml_output_char 383 RETURN 1 385 ACC0 386 PUSHENVACC1 387 APPLY1 388 PUSHENVACC2 389 PUSHENVACC3 390 APPTERM2 3 392 ACC0 393 PUSHENVACC1 394 APPLY1 395 PUSHENVACC2 396 PUSHENVACC3 397 APPTERM2 3 399 ACC0 400 PUSHENVACC1 401 PUSHENVACC2 402 APPTERM2 3 404 ACC0 405 PUSHENVACC1 406 C_CALL2 caml_output_char 408 RETURN 1 410 RESTART 411 GRAB 3 413 CONST0 414 PUSHACC3 415 LTINT 416 BRANCHIF 427 418 ACC1 419 C_CALL1 ml_string_length 421 PUSHACC4 422 PUSHACC4 423 ADDINT 424 GTINT 425 BRANCHIFNOT 432 427 GETGLOBAL "really_input" 429 PUSHENVACC1 430 APPTERM1 5 432 ACC3 433 PUSHACC3 434 PUSHACC3 435 PUSHACC3 436 PUSHENVACC2 437 APPTERM 4, 8 440 RESTART 441 GRAB 3 443 CONST0 444 PUSHACC3 445 LTINT 446 BRANCHIF 457 448 ACC1 449 C_CALL1 ml_string_length 451 PUSHACC4 452 PUSHACC4 453 ADDINT 454 GTINT 455 BRANCHIFNOT 462 457 GETGLOBAL "input" 459 PUSHENVACC1 460 APPTERM1 5 462 ACC3 463 PUSHACC3 464 PUSHACC3 465 PUSHACC3 466 C_CALL4 caml_input 468 RETURN 4 470 ACC0 471 PUSHCONST0 472 PUSHGETGLOBAL <0>(0, <0>(6, 0)) 474 PUSHENVACC1 475 APPTERM3 4 477 ACC0 478 PUSHCONST0 479 PUSHGETGLOBAL <0>(0, <0>(7, 0)) 481 PUSHENVACC1 482 APPTERM3 4 484 RESTART 485 GRAB 2 487 ACC1 488 PUSHACC1 489 PUSHACC4 490 C_CALL3 sys_open 492 C_CALL1 caml_open_descriptor 494 RETURN 3 496 ACC0 497 C_CALL1 caml_flush 499 ACC0 500 C_CALL1 caml_close_channel 502 RETURN 1 504 RESTART 505 GRAB 1 507 CONST0 508 PUSHACC2 509 PUSHACC2 510 C_CALL3 output_value 512 RETURN 2 514 RESTART 515 GRAB 3 517 CONST0 518 PUSHACC3 519 LTINT 520 BRANCHIF 531 522 ACC1 523 C_CALL1 ml_string_length 525 PUSHACC4 526 PUSHACC4 527 ADDINT 528 GTINT 529 BRANCHIFNOT 536 531 GETGLOBAL "output" 533 PUSHENVACC1 534 APPTERM1 5 536 ACC3 537 PUSHACC3 538 PUSHACC3 539 PUSHACC3 540 C_CALL4 caml_output 542 RETURN 4 544 RESTART 545 GRAB 1 547 ACC1 548 C_CALL1 ml_string_length 550 PUSHCONST0 551 PUSHACC3 552 PUSHACC3 553 C_CALL4 caml_output 555 RETURN 2 557 ACC0 558 PUSHCONSTINT 438 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0)))) 562 PUSHENVACC1 563 APPTERM3 4 565 ACC0 566 PUSHCONSTINT 438 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0)))) 570 PUSHENVACC1 571 APPTERM3 4 573 RESTART 574 GRAB 2 576 ACC1 577 PUSHACC1 578 PUSHACC4 579 C_CALL3 sys_open 581 C_CALL1 caml_open_descriptor 583 RETURN 3 585 ACC0 586 PUSHGETGLOBAL "%.12g" 588 C_CALL2 format_float 590 RETURN 1 592 ACC0 593 PUSHGETGLOBAL "%d" 595 C_CALL2 format_int 597 RETURN 1 599 GETGLOBAL "false" 601 PUSHACC1 602 C_CALL2 string_equal 604 BRANCHIFNOT 609 606 CONST0 607 RETURN 1 609 GETGLOBAL "true" 611 PUSHACC1 612 C_CALL2 string_equal 614 BRANCHIFNOT 619 616 CONST1 617 RETURN 1 619 GETGLOBAL "bool_of_string" 621 PUSHENVACC1 622 APPTERM1 2 624 ACC0 625 BRANCHIFNOT 631 627 GETGLOBAL "true" 629 RETURN 1 631 GETGLOBAL "false" 633 RETURN 1 635 CONST0 636 PUSHACC1 637 LTINT 638 BRANCHIF 646 640 CONSTINT 255 642 PUSHACC1 643 GTINT 644 BRANCHIFNOT 651 646 GETGLOBAL "char_of_int" 648 PUSHENVACC1 649 APPTERM1 2 651 ACC0 652 RETURN 1 654 RESTART 655 GRAB 1 657 ACC0 658 C_CALL1 ml_string_length 660 PUSHACC2 661 C_CALL1 ml_string_length 663 PUSHACC0 664 PUSHACC2 665 ADDINT 666 C_CALL1 create_string 668 PUSHACC2 669 PUSHCONST0 670 PUSHACC2 671 PUSHCONST0 672 PUSHACC7 673 C_CALL5 blit_string 675 ACC1 676 PUSHACC3 677 PUSHACC2 678 PUSHCONST0 679 PUSHACC 8 681 C_CALL5 blit_string 683 ACC0 684 RETURN 5 686 CONSTINT -1 688 PUSHACC1 689 XORINT 690 RETURN 1 692 CONST0 693 PUSHACC1 694 GEINT 695 BRANCHIFNOT 700 697 ACC0 698 RETURN 1 700 ACC0 701 NEGINT 702 RETURN 1 704 RESTART 705 GRAB 1 707 ACC1 708 PUSHACC1 709 C_CALL2 greaterequal 711 BRANCHIFNOT 716 713 ACC0 714 RETURN 2 716 ACC1 717 RETURN 2 719 RESTART 720 GRAB 1 722 ACC1 723 PUSHACC1 724 C_CALL2 lessequal 726 BRANCHIFNOT 731 728 ACC0 729 RETURN 2 731 ACC1 732 RETURN 2 734 ACC0 735 PUSHGETGLOBAL Invalid_argument 737 MAKEBLOCK2 0 739 RAISE 740 ACC0 741 PUSHGETGLOBAL Failure 743 MAKEBLOCK2 0 745 RAISE 746 CLOSURE 0, 740 749 PUSH 750 CLOSURE 0, 734 753 PUSHGETGLOBAL "Pervasives.Exit" 755 MAKEBLOCK1 0 757 PUSHGETGLOBAL "Pervasives.Assert_failure" 759 MAKEBLOCK1 0 761 PUSH 762 CLOSURE 0, 720 765 PUSH 766 CLOSURE 0, 705 769 PUSH 770 CLOSURE 0, 692 773 PUSH 774 CLOSURE 0, 686 777 PUSHCONST0 778 PUSHCONSTINT 31 780 PUSHCONST1 781 LSLINT 782 EQ 783 BRANCHIFNOT 789 785 CONSTINT 30 787 BRANCH 791 789 CONSTINT 62 791 PUSHCONST1 792 LSLINT 793 PUSHACC0 794 OFFSETINT -1 796 PUSH 797 CLOSURE 0, 655 800 PUSHACC 9 802 CLOSURE 1, 635 805 PUSH 806 CLOSURE 0, 624 809 PUSHACC 11 811 CLOSURE 1, 599 814 PUSH 815 CLOSURE 0, 592 818 PUSH 819 CLOSURE 0, 585 822 PUSH 823 CLOSUREREC 0, 12 827 CONST0 828 C_CALL1 caml_open_descriptor 830 PUSHCONST1 831 C_CALL1 caml_open_descriptor 833 PUSHCONST2 834 C_CALL1 caml_open_descriptor 836 PUSH 837 CLOSURE 0, 574 840 PUSHACC0 841 CLOSURE 1, 565 844 PUSHACC1 845 CLOSURE 1, 557 848 PUSH 849 CLOSURE 0, 545 852 PUSHACC 22 854 CLOSURE 1, 515 857 PUSH 858 CLOSURE 0, 505 861 PUSH 862 CLOSURE 0, 496 865 PUSH 866 CLOSURE 0, 485 869 PUSHACC0 870 CLOSURE 1, 477 873 PUSHACC1 874 CLOSURE 1, 470 877 PUSHACC 28 879 CLOSURE 1, 441 882 PUSH 883 CLOSUREREC 0, 32 887 ACC0 888 PUSHACC 31 890 CLOSURE 2, 411 893 PUSHACC 22 895 CLOSUREREC 1, 70 899 ACC 15 901 CLOSURE 1, 404 904 PUSHACC 11 906 PUSHACC 17 908 CLOSURE 2, 399 911 PUSHACC 12 913 PUSHACC 18 915 PUSHACC 23 917 CLOSURE 3, 392 920 PUSHACC 13 922 PUSHACC 19 924 PUSHACC 23 926 CLOSURE 3, 385 929 PUSHACC 14 931 PUSHACC 20 933 CLOSURE 2, 374 936 PUSHACC 20 938 CLOSURE 1, 364 941 PUSHACC 20 943 CLOSURE 1, 358 946 PUSHACC 17 948 PUSHACC 22 950 CLOSURE 2, 353 953 PUSHACC 18 955 PUSHACC 23 957 PUSHACC 29 959 CLOSURE 3, 346 962 PUSHACC 19 964 PUSHACC 24 966 PUSHACC 29 968 CLOSURE 3, 339 971 PUSHACC 20 973 PUSHACC 25 975 CLOSURE 2, 325 978 PUSHACC 25 980 CLOSURE 1, 315 983 PUSHACC 12 985 PUSHACC 28 987 PUSHACC 30 989 CLOSURE 3, 308 992 PUSHACC0 993 CLOSURE 1, 301 996 PUSHACC1 997 CLOSURE 1, 294 1000 PUSHACC 29 1002 PUSHACC 31 1004 CLOSURE 2, 286 1007 MAKEBLOCK1 0 1009 PUSHACC0 1010 CLOSURE 1, 275 1013 PUSHACC1 1014 CLOSURE 1, 263 1017 PUSHACC0 1018 CLOSURE 1, 255 1021 PUSHACC1 1022 PUSHACC 22 1024 PUSHACC4 1025 PUSHACC3 1026 PUSH 1027 CLOSURE 0, 247 1030 PUSH 1031 CLOSURE 0, 241 1034 PUSH 1035 CLOSURE 0, 236 1038 PUSH 1039 CLOSURE 0, 231 1042 PUSH 1043 CLOSURE 0, 223 1046 PUSH 1047 CLOSURE 0, 217 1050 PUSH 1051 CLOSURE 0, 212 1054 PUSH 1055 CLOSURE 0, 207 1058 PUSHACC 32 1060 PUSHACC 35 1062 PUSHACC 33 1064 PUSH 1065 CLOSURE 0, 202 1068 PUSHACC 41 1070 PUSHACC 40 1072 PUSHACC 42 1074 PUSH 1075 CLOSURE 0, 194 1078 PUSHACC 46 1080 PUSH 1081 CLOSURE 0, 188 1084 PUSH 1085 CLOSURE 0, 183 1088 PUSH 1089 CLOSURE 0, 175 1092 PUSHACC 51 1094 PUSH 1095 CLOSURE 0, 166 1098 PUSH 1099 CLOSURE 0, 157 1102 PUSHACC 55 1104 PUSHACC 57 1106 PUSH 1107 CLOSURE 0, 148 1110 PUSH 1111 CLOSURE 0, 142 1114 PUSHACC 63 1116 PUSHACC 62 1118 PUSHACC 64 1120 PUSHACC 38 1122 PUSHACC 40 1124 PUSHACC 42 1126 PUSHACC 44 1128 PUSHACC 46 1130 PUSHACC 48 1132 PUSHACC 50 1134 PUSHACC 52 1136 PUSHACC 54 1138 PUSHACC 56 1140 PUSHACC 58 1142 PUSHACC 60 1144 PUSHACC 62 1146 PUSHACC 64 1148 PUSHACC 66 1150 PUSHACC 82 1152 PUSHACC 84 1154 PUSHACC 86 1156 PUSHACC 88 1158 PUSHACC 90 1160 PUSHACC 92 1162 PUSHACC 94 1164 PUSHACC 96 1166 PUSHACC 98 1168 PUSHACC 100 1170 PUSHACC 104 1172 PUSHACC 104 1174 PUSHACC 104 1176 PUSHACC 108 1178 PUSHACC 110 1180 PUSHACC 112 1182 PUSHACC 117 1184 PUSHACC 117 1186 PUSHACC 117 1188 PUSHACC 117 1190 MAKEBLOCK 69, 0 1193 POP 53 1195 SETGLOBAL Pervasives 1197 BRANCH 2177 1199 RESTART 1200 GRAB 1 1202 ACC1 1203 BRANCHIFNOT 1213 1205 ACC1 1206 GETFIELD1 1207 PUSHACC1 1208 OFFSETINT 1 1210 PUSHOFFSETCLOSURE0 1211 APPTERM2 4 1213 ACC0 1214 RETURN 2 1216 RESTART 1217 GRAB 1 1219 ACC0 1220 BRANCHIFNOT 1251 1222 CONST0 1223 PUSHACC2 1224 EQ 1225 BRANCHIFNOT 1231 1227 ACC0 1228 GETFIELD0 1229 RETURN 2 1231 CONST0 1232 PUSHACC2 1233 GTINT 1234 BRANCHIFNOT 1244 1236 ACC1 1237 OFFSETINT -1 1239 PUSHACC1 1240 GETFIELD1 1241 PUSHOFFSETCLOSURE0 1242 APPTERM2 4 1244 GETGLOBAL "List.nth" 1246 PUSHGETGLOBALFIELD Pervasives, 2 1249 APPTERM1 3 1251 GETGLOBAL "nth" 1253 PUSHGETGLOBALFIELD Pervasives, 3 1256 APPTERM1 3 1258 RESTART 1259 GRAB 1 1261 ACC0 1262 BRANCHIFNOT 1274 1264 ACC1 1265 PUSHACC1 1266 GETFIELD0 1267 MAKEBLOCK2 0 1269 PUSHACC1 1270 GETFIELD1 1271 PUSHOFFSETCLOSURE0 1272 APPTERM2 4 1274 ACC1 1275 RETURN 2 1277 ACC0 1278 BRANCHIFNOT 1291 1280 ACC0 1281 GETFIELD1 1282 PUSHOFFSETCLOSURE0 1283 APPLY1 1284 PUSHACC1 1285 GETFIELD0 1286 PUSHGETGLOBALFIELD Pervasives, 16 1289 APPTERM2 3 1291 RETURN 1 1293 RESTART 1294 GRAB 1 1296 ACC1 1297 BRANCHIFNOT 1313 1299 ACC1 1300 GETFIELD0 1301 PUSHACC1 1302 APPLY1 1303 PUSHACC2 1304 GETFIELD1 1305 PUSHACC2 1306 PUSHOFFSETCLOSURE0 1307 APPLY2 1308 PUSHACC1 1309 MAKEBLOCK2 0 1311 POP 1 1313 RETURN 2 1315 RESTART 1316 GRAB 1 1318 ACC1 1319 BRANCHIFNOT 1331 1321 ACC1 1322 GETFIELD0 1323 PUSHACC1 1324 APPLY1 1325 ACC1 1326 GETFIELD1 1327 PUSHACC1 1328 PUSHOFFSETCLOSURE0 1329 APPTERM2 4 1331 RETURN 2 1333 RESTART 1334 GRAB 2 1336 ACC2 1337 BRANCHIFNOT 1350 1339 ACC2 1340 GETFIELD1 1341 PUSHACC3 1342 GETFIELD0 1343 PUSHACC3 1344 PUSHACC3 1345 APPLY2 1346 PUSHACC2 1347 PUSHOFFSETCLOSURE0 1348 APPTERM3 6 1350 ACC1 1351 RETURN 3 1353 RESTART 1354 GRAB 2 1356 ACC1 1357 BRANCHIFNOT 1370 1359 ACC2 1360 PUSHACC2 1361 GETFIELD1 1362 PUSHACC2 1363 PUSHOFFSETCLOSURE0 1364 APPLY3 1365 PUSHACC2 1366 GETFIELD0 1367 PUSHACC2 1368 APPTERM2 5 1370 ACC2 1371 RETURN 3 1373 RESTART 1374 GRAB 2 1376 ACC1 1377 BRANCHIFNOT 1400 1379 ACC2 1380 BRANCHIFNOT 1407 1382 ACC2 1383 GETFIELD0 1384 PUSHACC2 1385 GETFIELD0 1386 PUSHACC2 1387 APPLY2 1388 PUSHACC3 1389 GETFIELD1 1390 PUSHACC3 1391 GETFIELD1 1392 PUSHACC3 1393 PUSHOFFSETCLOSURE0 1394 APPLY3 1395 PUSHACC1 1396 MAKEBLOCK2 0 1398 RETURN 4 1400 ACC2 1401 BRANCHIFNOT 1405 1403 BRANCH 1407 1405 RETURN 3 1407 GETGLOBAL "List.map2" 1409 PUSHGETGLOBALFIELD Pervasives, 2 1412 APPTERM1 4 1414 RESTART 1415 GRAB 2 1417 ACC1 1418 BRANCHIFNOT 1437 1420 ACC2 1421 BRANCHIFNOT 1444 1423 ACC2 1424 GETFIELD0 1425 PUSHACC2 1426 GETFIELD0 1427 PUSHACC2 1428 APPLY2 1429 ACC2 1430 GETFIELD1 1431 PUSHACC2 1432 GETFIELD1 1433 PUSHACC2 1434 PUSHOFFSETCLOSURE0 1435 APPTERM3 6 1437 ACC2 1438 BRANCHIFNOT 1442 1440 BRANCH 1444 1442 RETURN 3 1444 GETGLOBAL "List.iter2" 1446 PUSHGETGLOBALFIELD Pervasives, 2 1449 APPTERM1 4 1451 RESTART 1452 GRAB 3 1454 ACC2 1455 BRANCHIFNOT 1476 1457 ACC3 1458 BRANCHIFNOT 1482 1460 ACC3 1461 GETFIELD1 1462 PUSHACC3 1463 GETFIELD1 1464 PUSHACC5 1465 GETFIELD0 1466 PUSHACC5 1467 GETFIELD0 1468 PUSHACC5 1469 PUSHACC5 1470 APPLY3 1471 PUSHACC3 1472 PUSHOFFSETCLOSURE0 1473 APPTERM 4, 8 1476 ACC3 1477 BRANCHIF 1482 1479 ACC1 1480 RETURN 4 1482 GETGLOBAL "List.fold_left2" 1484 PUSHGETGLOBALFIELD Pervasives, 2 1487 APPTERM1 5 1489 RESTART 1490 GRAB 3 1492 ACC1 1493 BRANCHIFNOT 1516 1495 ACC2 1496 BRANCHIFNOT 1522 1498 PUSH_RETADDR 1509 1500 ACC6 1501 PUSHACC6 1502 GETFIELD1 1503 PUSHACC6 1504 GETFIELD1 1505 PUSHACC6 1506 PUSHOFFSETCLOSURE0 1507 APPLY 4 1509 PUSHACC3 1510 GETFIELD0 1511 PUSHACC3 1512 GETFIELD0 1513 PUSHACC3 1514 APPTERM3 7 1516 ACC2 1517 BRANCHIF 1522 1519 ACC3 1520 RETURN 4 1522 GETGLOBAL "List.fold_right2" 1524 PUSHGETGLOBALFIELD Pervasives, 2 1527 APPTERM1 5 1529 RESTART 1530 GRAB 1 1532 ACC1 1533 BRANCHIFNOT 1549 1535 ACC1 1536 GETFIELD0 1537 PUSHACC1 1538 APPLY1 1539 BRANCHIFNOT 1547 1541 ACC1 1542 GETFIELD1 1543 PUSHACC1 1544 PUSHOFFSETCLOSURE0 1545 APPTERM2 4 1547 RETURN 2 1549 CONST1 1550 RETURN 2 1552 RESTART 1553 GRAB 1 1555 ACC1 1556 BRANCHIFNOT 1570 1558 ACC1 1559 GETFIELD0 1560 PUSHACC1 1561 APPLY1 1562 BRANCHIF 1570 1564 ACC1 1565 GETFIELD1 1566 PUSHACC1 1567 PUSHOFFSETCLOSURE0 1568 APPTERM2 4 1570 RETURN 2 1572 RESTART 1573 GRAB 2 1575 ACC1 1576 BRANCHIFNOT 1599 1578 ACC2 1579 BRANCHIFNOT 1605 1581 ACC2 1582 GETFIELD0 1583 PUSHACC2 1584 GETFIELD0 1585 PUSHACC2 1586 APPLY2 1587 BRANCHIFNOT 1597 1589 ACC2 1590 GETFIELD1 1591 PUSHACC2 1592 GETFIELD1 1593 PUSHACC2 1594 PUSHOFFSETCLOSURE0 1595 APPTERM3 6 1597 RETURN 3 1599 ACC2 1600 BRANCHIF 1605 1602 CONST1 1603 RETURN 3 1605 GETGLOBAL "List.for_all2" 1607 PUSHGETGLOBALFIELD Pervasives, 2 1610 APPTERM1 4 1612 RESTART 1613 GRAB 2 1615 ACC1 1616 BRANCHIFNOT 1639 1618 ACC2 1619 BRANCHIFNOT 1646 1621 ACC2 1622 GETFIELD0 1623 PUSHACC2 1624 GETFIELD0 1625 PUSHACC2 1626 APPLY2 1627 BRANCHIF 1637 1629 ACC2 1630 GETFIELD1 1631 PUSHACC2 1632 GETFIELD1 1633 PUSHACC2 1634 PUSHOFFSETCLOSURE0 1635 APPTERM3 6 1637 RETURN 3 1639 ACC2 1640 BRANCHIFNOT 1644 1642 BRANCH 1646 1644 RETURN 3 1646 GETGLOBAL "List.exists2" 1648 PUSHGETGLOBALFIELD Pervasives, 2 1651 APPTERM1 4 1653 RESTART 1654 GRAB 1 1656 ACC1 1657 BRANCHIFNOT 1672 1659 ACC0 1660 PUSHACC2 1661 GETFIELD0 1662 C_CALL2 equal 1664 BRANCHIF 1672 1666 ACC1 1667 GETFIELD1 1668 PUSHACC1 1669 PUSHOFFSETCLOSURE0 1670 APPTERM2 4 1672 RETURN 2 1674 RESTART 1675 GRAB 1 1677 ACC1 1678 BRANCHIFNOT 1692 1680 ACC0 1681 PUSHACC2 1682 GETFIELD0 1683 EQ 1684 BRANCHIF 1692 1686 ACC1 1687 GETFIELD1 1688 PUSHACC1 1689 PUSHOFFSETCLOSURE0 1690 APPTERM2 4 1692 RETURN 2 1694 RESTART 1695 GRAB 1 1697 ACC1 1698 BRANCHIFNOT 1719 1700 ACC1 1701 GETFIELD0 1702 PUSHACC1 1703 PUSHACC1 1704 GETFIELD0 1705 C_CALL2 equal 1707 BRANCHIFNOT 1713 1709 ACC0 1710 GETFIELD1 1711 RETURN 3 1713 ACC2 1714 GETFIELD1 1715 PUSHACC2 1716 PUSHOFFSETCLOSURE0 1717 APPTERM2 5 1719 GETGLOBAL Not_found 1721 MAKEBLOCK1 0 1723 RAISE 1724 RESTART 1725 GRAB 1 1727 ACC1 1728 BRANCHIFNOT 1748 1730 ACC1 1731 GETFIELD0 1732 PUSHACC1 1733 PUSHACC1 1734 GETFIELD0 1735 EQ 1736 BRANCHIFNOT 1742 1738 ACC0 1739 GETFIELD1 1740 RETURN 3 1742 ACC2 1743 GETFIELD1 1744 PUSHACC2 1745 PUSHOFFSETCLOSURE0 1746 APPTERM2 5 1748 GETGLOBAL Not_found 1750 MAKEBLOCK1 0 1752 RAISE 1753 RESTART 1754 GRAB 1 1756 ACC1 1757 BRANCHIFNOT 1773 1759 ACC0 1760 PUSHACC2 1761 GETFIELD0 1762 GETFIELD0 1763 C_CALL2 equal 1765 BRANCHIF 1773 1767 ACC1 1768 GETFIELD1 1769 PUSHACC1 1770 PUSHOFFSETCLOSURE0 1771 APPTERM2 4 1773 RETURN 2 1775 RESTART 1776 GRAB 1 1778 ACC1 1779 BRANCHIFNOT 1794 1781 ACC0 1782 PUSHACC2 1783 GETFIELD0 1784 GETFIELD0 1785 EQ 1786 BRANCHIF 1794 1788 ACC1 1789 GETFIELD1 1790 PUSHACC1 1791 PUSHOFFSETCLOSURE0 1792 APPTERM2 4 1794 RETURN 2 1796 RESTART 1797 GRAB 1 1799 ACC1 1800 BRANCHIFNOT 1825 1802 ACC1 1803 GETFIELD0 1804 PUSHACC2 1805 GETFIELD1 1806 PUSHACC2 1807 PUSHACC2 1808 GETFIELD0 1809 C_CALL2 equal 1811 BRANCHIFNOT 1816 1813 ACC0 1814 RETURN 4 1816 ACC0 1817 PUSHACC3 1818 PUSHOFFSETCLOSURE0 1819 APPLY2 1820 PUSHACC2 1821 MAKEBLOCK2 0 1823 POP 2 1825 RETURN 2 1827 RESTART 1828 GRAB 1 1830 ACC1 1831 BRANCHIFNOT 1855 1833 ACC1 1834 GETFIELD0 1835 PUSHACC2 1836 GETFIELD1 1837 PUSHACC2 1838 PUSHACC2 1839 GETFIELD0 1840 EQ 1841 BRANCHIFNOT 1846 1843 ACC0 1844 RETURN 4 1846 ACC0 1847 PUSHACC3 1848 PUSHOFFSETCLOSURE0 1849 APPLY2 1850 PUSHACC2 1851 MAKEBLOCK2 0 1853 POP 2 1855 RETURN 2 1857 RESTART 1858 GRAB 1 1860 ACC1 1861 BRANCHIFNOT 1879 1863 ACC1 1864 GETFIELD0 1865 PUSHACC0 1866 PUSHACC2 1867 APPLY1 1868 BRANCHIFNOT 1873 1870 ACC0 1871 RETURN 3 1873 ACC2 1874 GETFIELD1 1875 PUSHACC2 1876 PUSHOFFSETCLOSURE0 1877 APPTERM2 5 1879 GETGLOBAL Not_found 1881 MAKEBLOCK1 0 1883 RAISE 1884 RESTART 1885 GRAB 2 1887 ACC2 1888 BRANCHIFNOT 1917 1890 ACC2 1891 GETFIELD0 1892 PUSHACC3 1893 GETFIELD1 1894 PUSHACC1 1895 PUSHENVACC2 1896 APPLY1 1897 BRANCHIFNOT 1908 1899 ACC0 1900 PUSHACC4 1901 PUSHACC4 1902 PUSHACC4 1903 MAKEBLOCK2 0 1905 PUSHOFFSETCLOSURE0 1906 APPTERM3 8 1908 ACC0 1909 PUSHACC4 1910 PUSHACC3 1911 MAKEBLOCK2 0 1913 PUSHACC4 1914 PUSHOFFSETCLOSURE0 1915 APPTERM3 8 1917 ACC1 1918 PUSHENVACC1 1919 APPLY1 1920 PUSHACC1 1921 PUSHENVACC1 1922 APPLY1 1923 MAKEBLOCK2 0 1925 RETURN 3 1927 RESTART 1928 GRAB 1 1930 ACC0 1931 PUSHENVACC1 1932 CLOSUREREC 2, 1885 1936 ACC2 1937 PUSHCONST0 1938 PUSHCONST0 1939 PUSHACC3 1940 APPTERM3 6 1942 ACC0 1943 BRANCHIFNOT 1967 1945 ACC0 1946 GETFIELD0 1947 PUSHACC1 1948 GETFIELD1 1949 PUSHOFFSETCLOSURE0 1950 APPLY1 1951 PUSHACC0 1952 GETFIELD1 1953 PUSHACC2 1954 GETFIELD1 1955 MAKEBLOCK2 0 1957 PUSHACC1 1958 GETFIELD0 1959 PUSHACC3 1960 GETFIELD0 1961 MAKEBLOCK2 0 1963 MAKEBLOCK2 0 1965 RETURN 3 1967 GETGLOBAL <0>(0, 0) 1969 RETURN 1 1971 RESTART 1972 GRAB 1 1974 ACC0 1975 BRANCHIFNOT 1996 1977 ACC1 1978 BRANCHIFNOT 2003 1980 ACC1 1981 GETFIELD1 1982 PUSHACC1 1983 GETFIELD1 1984 PUSHOFFSETCLOSURE0 1985 APPLY2 1986 PUSHACC2 1987 GETFIELD0 1988 PUSHACC2 1989 GETFIELD0 1990 MAKEBLOCK2 0 1992 MAKEBLOCK2 0 1994 RETURN 2 1996 ACC1 1997 BRANCHIFNOT 2001 1999 BRANCH 2003 2001 RETURN 2 2003 GETGLOBAL "List.combine" 2005 PUSHGETGLOBALFIELD Pervasives, 2 2008 APPTERM1 3 2010 RESTART 2011 GRAB 1 2013 ACC1 2014 BRANCHIFNOT 2038 2016 ACC1 2017 GETFIELD0 2018 PUSHACC2 2019 GETFIELD1 2020 PUSHACC1 2021 PUSHENVACC2 2022 APPLY1 2023 BRANCHIFNOT 2033 2025 ACC0 2026 PUSHACC3 2027 PUSHACC3 2028 MAKEBLOCK2 0 2030 PUSHOFFSETCLOSURE0 2031 APPTERM2 6 2033 ACC0 2034 PUSHACC3 2035 PUSHOFFSETCLOSURE0 2036 APPTERM2 6 2038 ACC0 2039 PUSHENVACC1 2040 APPTERM1 3 2042 ACC0 2043 PUSHENVACC1 2044 CLOSUREREC 2, 2011 2048 CONST0 2049 PUSHACC1 2050 APPTERM1 3 2052 RESTART 2053 GRAB 2 2055 ACC1 2056 BRANCHIFNOT 2077 2058 ACC2 2059 BRANCHIFNOT 2084 2061 ACC2 2062 GETFIELD1 2063 PUSHACC2 2064 GETFIELD1 2065 PUSHACC2 2066 PUSHACC5 2067 GETFIELD0 2068 PUSHACC5 2069 GETFIELD0 2070 PUSHENVACC1 2071 APPLY2 2072 MAKEBLOCK2 0 2074 PUSHOFFSETCLOSURE0 2075 APPTERM3 6 2077 ACC2 2078 BRANCHIFNOT 2082 2080 BRANCH 2084 2082 RETURN 3 2084 GETGLOBAL "List.rev_map2" 2086 PUSHGETGLOBALFIELD Pervasives, 2 2089 APPTERM1 4 2091 RESTART 2092 GRAB 2 2094 ACC0 2095 CLOSUREREC 1, 2053 2099 ACC3 2100 PUSHACC3 2101 PUSHCONST0 2102 PUSHACC3 2103 APPTERM3 7 2105 RESTART 2106 GRAB 1 2108 ACC1 2109 BRANCHIFNOT 2123 2111 ACC1 2112 GETFIELD1 2113 PUSHACC1 2114 PUSHACC3 2115 GETFIELD0 2116 PUSHENVACC1 2117 APPLY1 2118 MAKEBLOCK2 0 2120 PUSHOFFSETCLOSURE0 2121 APPTERM2 4 2123 ACC0 2124 RETURN 2 2126 RESTART 2127 GRAB 1 2129 ACC0 2130 CLOSUREREC 1, 2106 2134 ACC2 2135 PUSHCONST0 2136 PUSHACC2 2137 APPTERM2 5 2139 CONST0 2140 PUSHACC1 2141 PUSHENVACC1 2142 APPTERM2 3 2144 ACC0 2145 BRANCHIFNOT 2151 2147 ACC0 2148 GETFIELD1 2149 RETURN 1 2151 GETGLOBAL "tl" 2153 PUSHGETGLOBALFIELD Pervasives, 3 2156 APPTERM1 2 2158 ACC0 2159 BRANCHIFNOT 2165 2161 ACC0 2162 GETFIELD0 2163 RETURN 1 2165 GETGLOBAL "hd" 2167 PUSHGETGLOBALFIELD Pervasives, 3 2170 APPTERM1 2 2172 ACC0 2173 PUSHCONST0 2174 PUSHENVACC1 2175 APPTERM2 3 2177 CLOSUREREC 0, 1200 2181 ACC0 2182 CLOSURE 1, 2172 2185 PUSH 2186 CLOSURE 0, 2158 2189 PUSH 2190 CLOSURE 0, 2144 2193 PUSH 2194 CLOSUREREC 0, 1217 2198 GETGLOBALFIELD Pervasives, 16 2201 PUSH 2202 CLOSUREREC 0, 1259 2206 ACC0 2207 CLOSURE 1, 2139 2210 PUSH 2211 CLOSUREREC 0, 1277 2215 CLOSUREREC 0, 1294 2219 CLOSURE 0, 2127 2222 PUSH 2223 CLOSUREREC 0, 1316 2227 CLOSUREREC 0, 1334 2231 CLOSUREREC 0, 1354 2235 CLOSUREREC 0, 1374 2239 CLOSURE 0, 2092 2242 PUSH 2243 CLOSUREREC 0, 1415 2247 CLOSUREREC 0, 1452 2251 CLOSUREREC 0, 1490 2255 CLOSUREREC 0, 1530 2259 CLOSUREREC 0, 1553 2263 CLOSUREREC 0, 1573 2267 CLOSUREREC 0, 1613 2271 CLOSUREREC 0, 1654 2275 CLOSUREREC 0, 1675 2279 CLOSUREREC 0, 1695 2283 CLOSUREREC 0, 1725 2287 CLOSUREREC 0, 1754 2291 CLOSUREREC 0, 1776 2295 CLOSUREREC 0, 1797 2299 CLOSUREREC 0, 1828 2303 CLOSUREREC 0, 1858 2307 ACC 24 2309 CLOSURE 1, 2042 2312 PUSHACC 25 2314 CLOSUREREC 1, 1928 2318 CLOSUREREC 0, 1942 2322 CLOSUREREC 0, 1972 2326 ACC0 2327 PUSHACC2 2328 PUSHACC7 2329 PUSHACC 9 2331 PUSHACC 11 2333 PUSHACC 13 2335 PUSHACC 15 2337 PUSHACC 17 2339 PUSHACC 10 2341 PUSHACC 12 2343 PUSHACC 13 2345 PUSHACC 15 2347 PUSHACC 23 2349 PUSHACC 25 2351 PUSHACC 27 2353 PUSHACC 29 2355 PUSHACC 31 2357 PUSHACC 33 2359 PUSHACC 35 2361 PUSHACC 37 2363 PUSHACC 40 2365 PUSHACC 42 2367 PUSHACC 41 2369 PUSHACC 45 2371 PUSHACC 47 2373 PUSHACC 50 2375 PUSHACC 52 2377 PUSHACC 51 2379 PUSHACC 55 2381 PUSHACC 56 2383 PUSHACC 59 2385 PUSHACC 61 2387 PUSHACC 60 2389 PUSHACC 64 2391 PUSHACC 66 2393 PUSHACC 68 2395 PUSHACC 70 2397 MAKEBLOCK 37, 0 2400 POP 36 2402 SETGLOBAL List 2404 BRANCH 2622 2406 CONSTINT 97 2408 PUSHACC1 2409 GEINT 2410 BRANCHIFNOT 2418 2412 CONSTINT 122 2414 PUSHACC1 2415 LEINT 2416 BRANCHIF 2442 2418 CONSTINT 224 2420 PUSHACC1 2421 GEINT 2422 BRANCHIFNOT 2430 2424 CONSTINT 246 2426 PUSHACC1 2427 LEINT 2428 BRANCHIF 2442 2430 CONSTINT 248 2432 PUSHACC1 2433 GEINT 2434 BRANCHIFNOT 2447 2436 CONSTINT 254 2438 PUSHACC1 2439 LEINT 2440 BRANCHIFNOT 2447 2442 ACC0 2443 OFFSETINT -32 2445 RETURN 1 2447 ACC0 2448 RETURN 1 2450 CONSTINT 65 2452 PUSHACC1 2453 GEINT 2454 BRANCHIFNOT 2462 2456 CONSTINT 90 2458 PUSHACC1 2459 LEINT 2460 BRANCHIF 2486 2462 CONSTINT 192 2464 PUSHACC1 2465 GEINT 2466 BRANCHIFNOT 2474 2468 CONSTINT 214 2470 PUSHACC1 2471 LEINT 2472 BRANCHIF 2486 2474 CONSTINT 216 2476 PUSHACC1 2477 GEINT 2478 BRANCHIFNOT 2491 2480 CONSTINT 222 2482 PUSHACC1 2483 LEINT 2484 BRANCHIFNOT 2491 2486 ACC0 2487 OFFSETINT 32 2489 RETURN 1 2491 ACC0 2492 RETURN 1 2494 CONSTINT 39 2496 PUSHACC1 2497 LTINT 2498 BRANCHIFNOT 2520 2500 CONSTINT 9 2502 PUSHACC1 2503 EQ 2504 BRANCHIFNOT 2510 2506 GETGLOBAL "\\t" 2508 RETURN 1 2510 CONSTINT 13 2512 PUSHACC1 2513 EQ 2514 BRANCHIFNOT 2540 2516 GETGLOBAL "\\n" 2518 RETURN 1 2520 CONSTINT 39 2522 PUSHACC1 2523 EQ 2524 BRANCHIFNOT 2530 2526 GETGLOBAL "\\'" 2528 RETURN 1 2530 CONSTINT 92 2532 PUSHACC1 2533 EQ 2534 BRANCHIFNOT 2540 2536 GETGLOBAL "\\\\" 2538 RETURN 1 2540 ACC0 2541 C_CALL1 is_printable 2543 BRANCHIFNOT 2555 2545 CONST1 2546 C_CALL1 create_string 2548 PUSHACC1 2549 PUSHCONST0 2550 PUSHACC2 2551 SETSTRINGCHAR 2552 ACC0 2553 RETURN 2 2555 ACC0 2556 PUSHCONSTINT 4 2558 C_CALL1 create_string 2560 PUSHCONSTINT 92 2562 PUSHCONST0 2563 PUSHACC2 2564 SETSTRINGCHAR 2565 CONSTINT 100 2567 PUSHACC2 2568 DIVINT 2569 PUSHCONSTINT 48 2571 ADDINT 2572 PUSHCONST1 2573 PUSHACC2 2574 SETSTRINGCHAR 2575 CONSTINT 10 2577 PUSHCONSTINT 10 2579 PUSHACC3 2580 DIVINT 2581 MODINT 2582 PUSHCONSTINT 48 2584 ADDINT 2585 PUSHCONST2 2586 PUSHACC2 2587 SETSTRINGCHAR 2588 CONSTINT 10 2590 PUSHACC2 2591 MODINT 2592 PUSHCONSTINT 48 2594 ADDINT 2595 PUSHCONST3 2596 PUSHACC2 2597 SETSTRINGCHAR 2598 ACC0 2599 RETURN 3 2601 CONST0 2602 PUSHACC1 2603 LTINT 2604 BRANCHIF 2612 2606 CONSTINT 255 2608 PUSHACC1 2609 GTINT 2610 BRANCHIFNOT 2619 2612 GETGLOBAL "Char.chr" 2614 PUSHGETGLOBALFIELD Pervasives, 2 2617 APPTERM1 2 2619 ACC0 2620 RETURN 1 2622 CLOSURE 0, 2601 2625 PUSH 2626 CLOSURE 0, 2494 2629 PUSH 2630 CLOSURE 0, 2450 2633 PUSH 2634 CLOSURE 0, 2406 2637 PUSHACC0 2638 PUSHACC2 2639 PUSHACC4 2640 PUSHACC6 2641 MAKEBLOCK 4, 0 2644 POP 4 2646 SETGLOBAL Char 2648 BRANCH 3540 2650 RESTART 2651 GRAB 3 2653 ACC1 2654 PUSHACC3 2655 GEINT 2656 BRANCHIFNOT 2663 2658 GETGLOBAL Not_found 2660 MAKEBLOCK1 0 2662 RAISE 2663 ACC3 2664 PUSHACC3 2665 PUSHACC2 2666 GETSTRINGCHAR 2667 EQ 2668 BRANCHIFNOT 2673 2670 ACC2 2671 RETURN 4 2673 ACC3 2674 PUSHACC3 2675 OFFSETINT 1 2677 PUSHACC3 2678 PUSHACC3 2679 PUSHOFFSETCLOSURE0 2680 APPTERM 4, 8 2683 RESTART 2684 GRAB 2 2686 CONST0 2687 PUSHACC2 2688 LTINT 2689 BRANCHIFNOT 2696 2691 GETGLOBAL Not_found 2693 MAKEBLOCK1 0 2695 RAISE 2696 ACC2 2697 PUSHACC2 2698 PUSHACC2 2699 GETSTRINGCHAR 2700 EQ 2701 BRANCHIFNOT 2706 2703 ACC1 2704 RETURN 3 2706 ACC2 2707 PUSHACC2 2708 OFFSETINT -1 2710 PUSHACC2 2711 PUSHOFFSETCLOSURE0 2712 APPTERM3 6 2714 RESTART 2715 GRAB 1 2717 ACC1 2718 PUSHCONST0 2719 PUSHACC2 2720 PUSHENVACC1 2721 APPTERM3 5 2723 RESTART 2724 GRAB 2 2726 CONST0 2727 PUSHACC2 2728 LTINT 2729 BRANCHIF 2738 2731 ACC0 2732 C_CALL1 ml_string_length 2734 PUSHACC2 2735 GEINT 2736 BRANCHIFNOT 2745 2738 GETGLOBAL "String.rcontains_from" 2740 PUSHGETGLOBALFIELD Pervasives, 2 2743 APPTERM1 4 2745 PUSHTRAP 2756 2747 ACC6 2748 PUSHACC6 2749 PUSHACC6 2750 PUSHENVACC1 2751 APPLY3 2752 CONST1 2753 POPTRAP 2754 RETURN 3 2756 PUSHGETGLOBAL Not_found 2758 PUSHACC1 2759 GETFIELD0 2760 EQ 2761 BRANCHIFNOT 2766 2763 CONST0 2764 RETURN 4 2766 ACC0 2767 RAISE 2768 RESTART 2769 GRAB 2 2771 CONST0 2772 PUSHACC2 2773 LTINT 2774 BRANCHIF 2783 2776 ACC0 2777 C_CALL1 ml_string_length 2779 PUSHACC2 2780 GTINT 2781 BRANCHIFNOT 2790 2783 GETGLOBAL "String.contains_from" 2785 PUSHGETGLOBALFIELD Pervasives, 2 2788 APPTERM1 4 2790 PUSHTRAP 2811 2792 PUSH_RETADDR 2807 2794 ACC 9 2796 PUSHACC 9 2798 PUSHACC 9 2800 C_CALL1 ml_string_length 2802 PUSHACC 10 2804 PUSHENVACC1 2805 APPLY 4 2807 CONST1 2808 POPTRAP 2809 RETURN 3 2811 PUSHGETGLOBAL Not_found 2813 PUSHACC1 2814 GETFIELD0 2815 EQ 2816 BRANCHIFNOT 2821 2818 CONST0 2819 RETURN 4 2821 ACC0 2822 RAISE 2823 RESTART 2824 GRAB 2 2826 CONST0 2827 PUSHACC2 2828 LTINT 2829 BRANCHIF 2838 2831 ACC0 2832 C_CALL1 ml_string_length 2834 PUSHACC2 2835 GEINT 2836 BRANCHIFNOT 2845 2838 GETGLOBAL "String.rindex_from" 2840 PUSHGETGLOBALFIELD Pervasives, 2 2843 APPTERM1 4 2845 ACC2 2846 PUSHACC2 2847 PUSHACC2 2848 PUSHENVACC1 2849 APPTERM3 6 2851 RESTART 2852 GRAB 1 2854 ACC1 2855 PUSHACC1 2856 C_CALL1 ml_string_length 2858 OFFSETINT -1 2860 PUSHACC2 2861 PUSHENVACC1 2862 APPTERM3 5 2864 RESTART 2865 GRAB 2 2867 CONST0 2868 PUSHACC2 2869 LTINT 2870 BRANCHIF 2879 2872 ACC0 2873 C_CALL1 ml_string_length 2875 PUSHACC2 2876 GTINT 2877 BRANCHIFNOT 2886 2879 GETGLOBAL "String.index_from" 2881 PUSHGETGLOBALFIELD Pervasives, 2 2884 APPTERM1 4 2886 ACC2 2887 PUSHACC2 2888 PUSHACC2 2889 C_CALL1 ml_string_length 2891 PUSHACC3 2892 PUSHENVACC1 2893 APPTERM 4, 7 2896 RESTART 2897 GRAB 1 2899 ACC1 2900 PUSHCONST0 2901 PUSHACC2 2902 C_CALL1 ml_string_length 2904 PUSHACC3 2905 PUSHENVACC1 2906 APPTERM 4, 6 2909 ACC0 2910 PUSHGETGLOBALFIELD Char, 2 2913 PUSHENVACC1 2914 APPTERM2 3 2916 ACC0 2917 PUSHGETGLOBALFIELD Char, 3 2920 PUSHENVACC1 2921 APPTERM2 3 2923 RESTART 2924 GRAB 1 2926 CONST0 2927 PUSHACC2 2928 C_CALL1 ml_string_length 2930 EQ 2931 BRANCHIFNOT 2936 2933 ACC1 2934 RETURN 2 2936 ACC1 2937 PUSHENVACC1 2938 APPLY1 2939 PUSHCONST0 2940 PUSHACC3 2941 GETSTRINGCHAR 2942 PUSHACC2 2943 APPLY1 2944 PUSHCONST0 2945 PUSHACC2 2946 SETSTRINGCHAR 2947 ACC0 2948 RETURN 3 2950 ACC0 2951 PUSHGETGLOBALFIELD Char, 2 2954 PUSHENVACC1 2955 APPTERM2 3 2957 ACC0 2958 PUSHGETGLOBALFIELD Char, 3 2961 PUSHENVACC1 2962 APPTERM2 3 2964 RESTART 2965 GRAB 1 2967 ACC1 2968 C_CALL1 ml_string_length 2970 PUSHCONST0 2971 PUSHACC1 2972 EQ 2973 BRANCHIFNOT 2978 2975 ACC2 2976 RETURN 3 2978 ACC0 2979 C_CALL1 create_string 2981 PUSHCONST0 2982 PUSHACC2 2983 OFFSETINT -1 2985 PUSH 2986 BRANCH 3002 2988 CHECK_SIGNALS 2989 ACC1 2990 PUSHACC6 2991 GETSTRINGCHAR 2992 PUSHACC5 2993 APPLY1 2994 PUSHACC2 2995 PUSHACC4 2996 SETSTRINGCHAR 2997 ACC1 2998 OFFSETINT 1 3000 ASSIGN 1 3002 ACC0 3003 PUSHACC2 3004 LEINT 3005 BRANCHIF 2988 3007 CONST0 3008 POP 2 3010 ACC0 3011 RETURN 4 3013 CONST0 3014 PUSHCONST0 3015 PUSHACC2 3016 C_CALL1 ml_string_length 3018 OFFSETINT -1 3020 PUSH 3021 BRANCH 3059 3023 CHECK_SIGNALS 3024 ACC1 3025 PUSHACC4 3026 GETSTRINGCHAR 3027 PUSHACC0 3028 PUSHGETGLOBAL "\000\"\000\000\004\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" 3030 C_CALL2 bitvect_test 3032 BRANCHIFNOT 3038 3034 CONST0 3035 CONST2 3036 BRANCH 3048 3038 ACC0 3039 C_CALL1 is_printable 3041 BRANCHIFNOT 3046 3043 CONST1 3044 BRANCH 3048 3046 CONSTINT 4 3048 POP 1 3050 PUSHACC3 3051 ADDINT 3052 ASSIGN 2 3054 ACC1 3055 OFFSETINT 1 3057 ASSIGN 1 3059 ACC0 3060 PUSHACC2 3061 LEINT 3062 BRANCHIF 3023 3064 CONST0 3065 POP 2 3067 ACC1 3068 C_CALL1 ml_string_length 3070 PUSHACC1 3071 EQ 3072 BRANCHIFNOT 3077 3074 ACC1 3075 RETURN 2 3077 ACC0 3078 C_CALL1 create_string 3080 PUSHCONST0 3081 ASSIGN 1 3083 CONST0 3084 PUSHACC3 3085 C_CALL1 ml_string_length 3087 OFFSETINT -1 3089 PUSH 3090 BRANCH 3245 3092 CHECK_SIGNALS 3093 ACC1 3094 PUSHACC5 3095 GETSTRINGCHAR 3096 PUSHACC0 3097 PUSHGETGLOBAL "\000\000\000\000\004\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" 3099 C_CALL2 bitvect_test 3101 BRANCHIFNOT 3120 3103 CONST0 3104 CONSTINT 92 3106 PUSHACC5 3107 PUSHACC5 3108 SETSTRINGCHAR 3109 ACC4 3110 OFFSETINT 1 3112 ASSIGN 4 3114 ACC0 3115 PUSHACC5 3116 PUSHACC5 3117 SETSTRINGCHAR 3118 BRANCH 3233 3120 CONSTINT 9 3122 PUSHACC1 3123 EQ 3124 BRANCHIFNOT 3143 3126 CONSTINT 92 3128 PUSHACC5 3129 PUSHACC5 3130 SETSTRINGCHAR 3131 ACC4 3132 OFFSETINT 1 3134 ASSIGN 4 3136 CONSTINT 116 3138 PUSHACC5 3139 PUSHACC5 3140 SETSTRINGCHAR 3141 BRANCH 3233 3143 CONSTINT 13 3145 PUSHACC1 3146 EQ 3147 BRANCHIFNOT 3166 3149 CONSTINT 92 3151 PUSHACC5 3152 PUSHACC5 3153 SETSTRINGCHAR 3154 ACC4 3155 OFFSETINT 1 3157 ASSIGN 4 3159 CONSTINT 110 3161 PUSHACC5 3162 PUSHACC5 3163 SETSTRINGCHAR 3164 BRANCH 3233 3166 ACC0 3167 C_CALL1 is_printable 3169 BRANCHIFNOT 3177 3171 ACC0 3172 PUSHACC5 3173 PUSHACC5 3174 SETSTRINGCHAR 3175 BRANCH 3233 3177 ACC0 3178 PUSHCONSTINT 92 3180 PUSHACC6 3181 PUSHACC6 3182 SETSTRINGCHAR 3183 ACC5 3184 OFFSETINT 1 3186 ASSIGN 5 3188 CONSTINT 100 3190 PUSHACC1 3191 DIVINT 3192 PUSHCONSTINT 48 3194 ADDINT 3195 PUSHACC6 3196 PUSHACC6 3197 SETSTRINGCHAR 3198 ACC5 3199 OFFSETINT 1 3201 ASSIGN 5 3203 CONSTINT 10 3205 PUSHCONSTINT 10 3207 PUSHACC2 3208 DIVINT 3209 MODINT 3210 PUSHCONSTINT 48 3212 ADDINT 3213 PUSHACC6 3214 PUSHACC6 3215 SETSTRINGCHAR 3216 ACC5 3217 OFFSETINT 1 3219 ASSIGN 5 3221 CONSTINT 10 3223 PUSHACC1 3224 MODINT 3225 PUSHCONSTINT 48 3227 ADDINT 3228 PUSHACC6 3229 PUSHACC6 3230 SETSTRINGCHAR 3231 POP 1 3233 POP 1 3235 ACC3 3236 OFFSETINT 1 3238 ASSIGN 3 3240 ACC1 3241 OFFSETINT 1 3243 ASSIGN 1 3245 ACC0 3246 PUSHACC2 3247 LEINT 3248 BRANCHIF 3092 3250 CONST0 3251 POP 2 3253 ACC0 3254 RETURN 3 3256 ENVACC1 3257 C_CALL1 ml_string_length 3259 PUSHENVACC3 3260 GETFIELD0 3261 PUSHENVACC2 3262 PUSHCONST0 3263 PUSHENVACC1 3264 C_CALL5 blit_string 3266 ENVACC1 3267 C_CALL1 ml_string_length 3269 PUSHENVACC3 3270 GETFIELD0 3271 ADDINT 3272 PUSHENVACC3 3273 SETFIELD0 3274 ACC0 3275 C_CALL1 ml_string_length 3277 PUSHENVACC3 3278 GETFIELD0 3279 PUSHENVACC2 3280 PUSHCONST0 3281 PUSHACC4 3282 C_CALL5 blit_string 3284 ACC0 3285 C_CALL1 ml_string_length 3287 PUSHENVACC3 3288 GETFIELD0 3289 ADDINT 3290 PUSHENVACC3 3291 SETFIELD0 3292 RETURN 1 3294 ENVACC1 3295 OFFSETREF 1 3297 ACC0 3298 C_CALL1 ml_string_length 3300 PUSHENVACC2 3301 GETFIELD0 3302 ADDINT 3303 PUSHENVACC2 3304 SETFIELD0 3305 RETURN 1 3307 RESTART 3308 GRAB 1 3310 ACC1 3311 BRANCHIFNOT 3374 3313 ACC1 3314 GETFIELD0 3315 PUSHCONST0 3316 MAKEBLOCK1 0 3318 PUSHCONST0 3319 MAKEBLOCK1 0 3321 PUSHACC4 3322 PUSHACC1 3323 PUSHACC3 3324 CLOSURE 2, 3294 3327 PUSHGETGLOBALFIELD List, 9 3330 APPLY2 3331 ACC1 3332 GETFIELD0 3333 OFFSETINT -1 3335 PUSHACC4 3336 C_CALL1 ml_string_length 3338 MULINT 3339 PUSHACC1 3340 GETFIELD0 3341 ADDINT 3342 C_CALL1 create_string 3344 PUSHACC3 3345 C_CALL1 ml_string_length 3347 PUSHCONST0 3348 PUSHACC2 3349 PUSHCONST0 3350 PUSHACC7 3351 C_CALL5 blit_string 3353 ACC3 3354 C_CALL1 ml_string_length 3356 MAKEBLOCK1 0 3358 PUSHACC6 3359 GETFIELD1 3360 PUSHACC1 3361 PUSHACC3 3362 PUSHACC 8 3364 CLOSURE 3, 3256 3367 PUSHGETGLOBALFIELD List, 9 3370 APPLY2 3371 ACC1 3372 RETURN 7 3374 GETGLOBAL "" 3376 RETURN 2 3378 RESTART 3379 GRAB 4 3381 CONST0 3382 PUSHACC5 3383 LTINT 3384 BRANCHIF 3414 3386 CONST0 3387 PUSHACC2 3388 LTINT 3389 BRANCHIF 3414 3391 ACC0 3392 C_CALL1 ml_string_length 3394 PUSHACC5 3395 PUSHACC3 3396 ADDINT 3397 GTINT 3398 BRANCHIF 3414 3400 CONST0 3401 PUSHACC4 3402 LTINT 3403 BRANCHIF 3414 3405 ACC2 3406 C_CALL1 ml_string_length 3408 PUSHACC5 3409 PUSHACC5 3410 ADDINT 3411 GTINT 3412 BRANCHIFNOT 3421 3414 GETGLOBAL "String.blit" 3416 PUSHGETGLOBALFIELD Pervasives, 2 3419 APPTERM1 6 3421 ACC4 3422 PUSHACC4 3423 PUSHACC4 3424 PUSHACC4 3425 PUSHACC4 3426 C_CALL5 blit_string 3428 RETURN 5 3430 RESTART 3431 GRAB 3 3433 CONST0 3434 PUSHACC2 3435 LTINT 3436 BRANCHIF 3452 3438 CONST0 3439 PUSHACC3 3440 LTINT 3441 BRANCHIF 3452 3443 ACC0 3444 C_CALL1 ml_string_length 3446 PUSHACC3 3447 PUSHACC3 3448 ADDINT 3449 GTINT 3450 BRANCHIFNOT 3459 3452 GETGLOBAL "String.fill" 3454 PUSHGETGLOBALFIELD Pervasives, 2 3457 APPTERM1 5 3459 ACC3 3460 PUSHACC3 3461 PUSHACC3 3462 PUSHACC3 3463 C_CALL4 fill_string 3465 RETURN 4 3467 RESTART 3468 GRAB 2 3470 CONST0 3471 PUSHACC2 3472 LTINT 3473 BRANCHIF 3489 3475 CONST0 3476 PUSHACC3 3477 LTINT 3478 BRANCHIF 3489 3480 ACC0 3481 C_CALL1 ml_string_length 3483 PUSHACC3 3484 PUSHACC3 3485 ADDINT 3486 GTINT 3487 BRANCHIFNOT 3496 3489 GETGLOBAL "String.sub" 3491 PUSHGETGLOBALFIELD Pervasives, 2 3494 APPTERM1 4 3496 ACC2 3497 C_CALL1 create_string 3499 PUSHACC3 3500 PUSHCONST0 3501 PUSHACC2 3502 PUSHACC5 3503 PUSHACC5 3504 C_CALL5 blit_string 3506 ACC0 3507 RETURN 4 3509 ACC0 3510 C_CALL1 ml_string_length 3512 PUSHACC0 3513 C_CALL1 create_string 3515 PUSHACC1 3516 PUSHCONST0 3517 PUSHACC2 3518 PUSHCONST0 3519 PUSHACC6 3520 C_CALL5 blit_string 3522 ACC0 3523 RETURN 3 3525 RESTART 3526 GRAB 1 3528 ACC0 3529 C_CALL1 create_string 3531 PUSHACC2 3532 PUSHACC2 3533 PUSHCONST0 3534 PUSHACC3 3535 C_CALL4 fill_string 3537 ACC0 3538 RETURN 3 3540 CLOSURE 0, 3526 3543 PUSH 3544 CLOSURE 0, 3509 3547 PUSH 3548 CLOSURE 0, 3468 3551 PUSH 3552 CLOSURE 0, 3431 3555 PUSH 3556 CLOSURE 0, 3379 3559 PUSH 3560 CLOSURE 0, 3308 3563 PUSH 3564 CLOSURE 0, 3013 3567 PUSH 3568 CLOSURE 0, 2965 3571 PUSHACC0 3572 CLOSURE 1, 2957 3575 PUSHACC1 3576 CLOSURE 1, 2950 3579 PUSHACC 8 3581 CLOSURE 1, 2924 3584 PUSHACC0 3585 CLOSURE 1, 2916 3588 PUSHACC1 3589 CLOSURE 1, 2909 3592 PUSH 3593 CLOSUREREC 0, 2651 3597 ACC0 3598 CLOSURE 1, 2897 3601 PUSHACC1 3602 CLOSURE 1, 2865 3605 PUSH 3606 CLOSUREREC 0, 2684 3610 ACC0 3611 CLOSURE 1, 2852 3614 PUSHACC1 3615 CLOSURE 1, 2824 3618 PUSHACC5 3619 CLOSURE 1, 2769 3622 PUSHACC3 3623 CLOSURE 1, 2724 3626 PUSHACC1 3627 CLOSURE 1, 2715 3630 PUSHACC 9 3632 PUSHACC 11 3634 PUSHACC 14 3636 PUSHACC 16 3638 PUSHACC5 3639 PUSHACC7 3640 PUSHACC6 3641 PUSHACC 10 3643 PUSHACC 14 3645 PUSHACC 13 3647 PUSHACC 17 3649 PUSHACC 26 3651 PUSHACC 28 3653 PUSHACC 30 3655 PUSHACC 32 3657 PUSHACC 34 3659 PUSHACC 36 3661 PUSHACC 38 3663 MAKEBLOCK 18, 0 3666 POP 22 3668 SETGLOBAL String 3670 GETGLOBAL "" 3672 PUSHCONSTINT 20 3674 C_CALL2 make_vect 3676 PUSHCONSTINT 20 3678 C_CALL1 weak_create 3680 PUSHCONST0 3681 PUSHCONSTINT 19 3683 PUSH 3684 BRANCH 3712 3686 CHECK_SIGNALS 3687 CONSTINT 115 3689 PUSHCONSTINT 20 3691 PUSHGETGLOBALFIELD String, 0 3694 APPLY2 3695 PUSHACC2 3696 PUSHACC5 3697 SETVECTITEM 3698 ACC1 3699 PUSHACC4 3700 GETVECTITEM 3701 MAKEBLOCK1 0 3703 PUSHACC2 3704 PUSHACC4 3705 C_CALL3 weak_set 3707 ACC1 3708 OFFSETINT 1 3710 ASSIGN 1 3712 ACC0 3713 PUSHACC2 3714 LEINT 3715 BRANCHIF 3686 3717 CONST0 3718 POP 2 3720 CONST0 3721 C_CALL1 gc_full_major 3723 CONST0 3724 PUSHCONSTINT 19 3726 PUSH 3727 BRANCH 3750 3729 CHECK_SIGNALS 3730 ACC1 3731 PUSHACC3 3732 C_CALL2 weak_get 3734 PUSHACC0 3735 BRANCHIF 3742 3737 GETGLOBAL Not_found 3739 MAKEBLOCK1 0 3741 RAISE 3742 CONST0 3743 POP 1 3745 ACC1 3746 OFFSETINT 1 3748 ASSIGN 1 3750 ACC0 3751 PUSHACC2 3752 LEINT 3753 BRANCHIF 3729 3755 CONST0 3756 POP 2 3758 CONST0 3759 PUSHCONSTINT 19 3761 PUSH 3762 BRANCH 3782 3764 CHECK_SIGNALS 3765 CONST0 3766 PUSHCONST2 3767 PUSHACC3 3768 MODINT 3769 EQ 3770 BRANCHIFNOT 3777 3772 GETGLOBAL "" 3774 PUSHACC2 3775 PUSHACC5 3776 SETVECTITEM 3777 ACC1 3778 OFFSETINT 1 3780 ASSIGN 1 3782 ACC0 3783 PUSHACC2 3784 LEINT 3785 BRANCHIF 3764 3787 CONST0 3788 POP 2 3790 CONST0 3791 C_CALL1 gc_full_major 3793 CONST0 3794 PUSHCONSTINT 19 3796 PUSH 3797 BRANCH 3851 3799 CHECK_SIGNALS 3800 ACC1 3801 PUSHACC3 3802 C_CALL2 weak_get 3804 PUSHACC0 3805 BRANCHIFNOT 3829 3807 CONST1 3808 PUSHCONST2 3809 PUSHACC4 3810 MODINT 3811 EQ 3812 BRANCHIFNOT 3839 3814 CONSTINT 115 3816 PUSHCONSTINT 5 3818 PUSHACC2 3819 GETFIELD0 3820 GETSTRINGCHAR 3821 NEQ 3822 BRANCHIFNOT 3844 3824 GETGLOBAL Not_found 3826 MAKEBLOCK1 0 3828 RAISE 3829 CONST0 3830 PUSHCONST2 3831 PUSHACC4 3832 MODINT 3833 EQ 3834 BRANCHIFNOT 3839 3836 CONST0 3837 BRANCH 3844 3839 GETGLOBAL Not_found 3841 MAKEBLOCK1 0 3843 RAISE 3844 POP 1 3846 ACC1 3847 OFFSETINT 1 3849 ASSIGN 1 3851 ACC0 3852 PUSHACC2 3853 LEINT 3854 BRANCHIF 3799 3856 CONST0 3857 POP 4 3859 ATOM0 3860 SETGLOBAL T340-weak 3862 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-subint.ml0000644000175000017500000000070012124403241023235 0ustar tootstootsopen Lib;; let x = 1 in if 1 - x <> 0 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONST0 11 PUSHACC1 12 PUSHCONST1 13 SUBINT 14 NEQ 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 POP 1 24 ATOM0 25 SETGLOBAL T110-subint 27 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t021-pushconst2.ml0000644000175000017500000000022212124403241024041 0ustar tootstootslet _ = () in 2;; (** 0 CONST0 1 PUSHCONST2 2 POP 1 4 ATOM0 5 SETGLOBAL T021-pushconst2 7 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t090-acc3.ml0000644000175000017500000000101412124403241022550 0ustar tootstootsopen Lib;; let x = true in let y = false in let z = false in let a = false in (); if not x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONST0 11 PUSHCONST0 12 PUSHCONST0 13 PUSHCONST0 14 ACC3 15 BOOLNOT 16 BRANCHIFNOT 23 18 GETGLOBAL Not_found 20 MAKEBLOCK1 0 22 RAISE 23 POP 4 25 ATOM0 26 SETGLOBAL T090-acc3 28 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-negint.ml0000644000175000017500000000065512124403241023226 0ustar tootstootsopen Lib;; let x = 1 in if -x <> -1 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONSTINT -1 12 PUSHACC1 13 NEGINT 14 NEQ 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 POP 1 24 ATOM0 25 SETGLOBAL T110-negint 27 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t181-appterm.ml0000644000175000017500000000136012124403241023414 0ustar tootstootsopen Lib;; let f _ _ _ _ = -10 in let g _ = f 0 0 0 0 in if g 0 <> -10 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 26 11 CONST0 12 PUSHCONST0 13 PUSHCONST0 14 PUSHCONST0 15 PUSHENVACC1 16 APPTERM 4, 5 19 RESTART 20 GRAB 3 22 CONSTINT -10 24 RETURN 4 26 CLOSURE 0, 20 29 PUSHACC0 30 CLOSURE 1, 11 33 PUSHCONSTINT -10 35 PUSHCONST0 36 PUSHACC2 37 APPLY1 38 NEQ 39 BRANCHIFNOT 46 41 GETGLOBAL Not_found 43 MAKEBLOCK1 0 45 RAISE 46 POP 2 48 ATOM0 49 SETGLOBAL T181-appterm 51 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t200-getfield0.ml0000644000175000017500000000065612124403241023606 0ustar tootstootsopen Lib;; type t = { a : int; };; if { a = 7 }.a <> 7 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 7 11 PUSHGETGLOBAL <0>(7) 13 GETFIELD0 14 NEQ 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 ATOM0 23 SETGLOBAL T200-getfield0 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t141-switch-6.ml0000644000175000017500000000115212124403241023403 0ustar tootstootsopen Lib;; type t = | A of int | B of int | C of int ;; match B 0 with | A _ -> raise Not_found | B _ -> () | _ -> raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL <1>(0) 11 PUSHACC0 12 SWITCH tag 0 -> 17 tag 1 -> 22 tag 2 -> 25 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 CONST0 23 BRANCH 30 25 GETGLOBAL Not_found 27 MAKEBLOCK1 0 29 RAISE 30 POP 1 32 ATOM0 33 SETGLOBAL T141-switch-6 35 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t180-appterm1.ml0000644000175000017500000000117612124403241023501 0ustar tootstootsopen Lib;; let f _ = 12 in let g _ = f 0 in if g 0 <> 12 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 19 11 CONST0 12 PUSHENVACC1 13 APPTERM1 2 15 CONSTINT 12 17 RETURN 1 19 CLOSURE 0, 15 22 PUSHACC0 23 CLOSURE 1, 11 26 PUSHCONSTINT 12 28 PUSHCONST0 29 PUSHACC2 30 APPLY1 31 NEQ 32 BRANCHIFNOT 39 34 GETGLOBAL Not_found 36 MAKEBLOCK1 0 38 RAISE 39 POP 2 41 ATOM0 42 SETGLOBAL T180-appterm1 44 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t021-pushconst3.ml0000644000175000017500000000022212124403241024042 0ustar tootstootslet _ = () in 3;; (** 0 CONST0 1 PUSHCONST3 2 POP 1 4 ATOM0 5 SETGLOBAL T021-pushconst3 7 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t250-closurerec-1.ml0000644000175000017500000000050212124403241024242 0ustar tootstootsopen Lib;; let rec f _ = 0;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 14 11 CONST0 12 RETURN 1 14 CLOSUREREC 0, 11 18 ACC0 19 MAKEBLOCK1 0 21 POP 1 23 SETGLOBAL T250-closurerec-1 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t160-closure.ml0000644000175000017500000000047412124403241023422 0ustar tootstootsopen Lib;; let f () = ();; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 14 11 CONST0 12 RETURN 1 14 CLOSURE 0, 11 17 PUSHACC0 18 MAKEBLOCK1 0 20 POP 1 22 SETGLOBAL T160-closure 24 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t173-pushenvacc.ml0000644000175000017500000000167512124403241024115 0ustar tootstootsopen Lib;; let x = 5 in let y = 4 in let z = 3 in let a = 2 in let b = 1 in let f _ = b + a + z + y + x in if f 0 <> 15 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 24 11 ENVACC1 12 PUSHENVACC2 13 PUSHENVACC3 14 PUSHENVACC 4 16 PUSHENVACC 5 18 ADDINT 19 ADDINT 20 ADDINT 21 ADDINT 22 RETURN 1 24 CONSTINT 5 26 PUSHCONSTINT 4 28 PUSHCONST3 29 PUSHCONST2 30 PUSHCONST1 31 PUSHACC0 32 PUSHACC2 33 PUSHACC4 34 PUSHACC6 35 PUSHACC 8 37 CLOSURE 5, 11 40 PUSHCONSTINT 15 42 PUSHCONST0 43 PUSHACC2 44 APPLY1 45 NEQ 46 BRANCHIFNOT 53 48 GETGLOBAL Not_found 50 MAKEBLOCK1 0 52 RAISE 53 POP 6 55 ATOM0 56 SETGLOBAL T173-pushenvacc 58 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-xorint.ml0000644000175000017500000000063312124403241023261 0ustar tootstootsopen Lib;; if (3 lxor 6) <> 5 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 5 11 PUSHCONSTINT 6 13 PUSHCONST3 14 XORINT 15 NEQ 16 BRANCHIFNOT 23 18 GETGLOBAL Not_found 20 MAKEBLOCK1 0 22 RAISE 23 ATOM0 24 SETGLOBAL T110-xorint 26 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t192-getfloatfield-2.ml0000644000175000017500000000074612124403241024725 0ustar tootstootsopen Lib;; type t = { a : float; b : float };; if { a = 0.1; b = 0.2 }.b <> 0.2 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL 0.2 11 PUSHGETGLOBAL [|0.1, 0.2|] 13 GETFLOATFIELD 1 15 C_CALL2 neq_float 17 BRANCHIFNOT 24 19 GETGLOBAL Not_found 21 MAKEBLOCK1 0 23 RAISE 24 ATOM0 25 SETGLOBAL T192-getfloatfield-2 27 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t300-getmethod.ml0000644000175000017500000035166112124403241023731 0ustar tootstootsopen Lib;; class c = object method m = 23 end;; let o = new c in if o#m <> 23 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 746 11 RESTART 12 GRAB 1 14 ACC0 15 BRANCHIFNOT 28 17 ACC1 18 PUSHACC1 19 GETFIELD1 20 PUSHOFFSETCLOSURE0 21 APPLY2 22 PUSHACC1 23 GETFIELD0 24 MAKEBLOCK2 0 26 RETURN 2 28 ACC1 29 RETURN 2 31 RESTART 32 GRAB 3 34 CONST0 35 PUSHACC4 36 LEINT 37 BRANCHIFNOT 42 39 CONST0 40 RETURN 4 42 ACC3 43 PUSHACC3 44 PUSHACC3 45 PUSHACC3 46 C_CALL4 caml_input 48 PUSHCONST0 49 PUSHACC1 50 EQ 51 BRANCHIFNOT 58 53 GETGLOBAL End_of_file 55 MAKEBLOCK1 0 57 RAISE 58 ACC0 59 PUSHACC5 60 SUBINT 61 PUSHACC1 62 PUSHACC5 63 ADDINT 64 PUSHACC4 65 PUSHACC4 66 PUSHOFFSETCLOSURE0 67 APPTERM 4, 9 70 ACC0 71 C_CALL1 caml_input_scan_line 73 PUSHCONST0 74 PUSHACC1 75 EQ 76 BRANCHIFNOT 83 78 GETGLOBAL End_of_file 80 MAKEBLOCK1 0 82 RAISE 83 CONST0 84 PUSHACC1 85 GTINT 86 BRANCHIFNOT 107 88 ACC0 89 OFFSETINT -1 91 C_CALL1 create_string 93 PUSHACC1 94 OFFSETINT -1 96 PUSHCONST0 97 PUSHACC2 98 PUSHACC5 99 C_CALL4 caml_input 101 ACC2 102 C_CALL1 caml_input_char 104 ACC0 105 RETURN 3 107 ACC0 108 NEGINT 109 C_CALL1 create_string 111 PUSHACC1 112 NEGINT 113 PUSHCONST0 114 PUSHACC2 115 PUSHACC5 116 C_CALL4 caml_input 118 CONST0 119 PUSHTRAP 130 121 ACC6 122 PUSHOFFSETCLOSURE0 123 APPLY1 124 PUSHACC5 125 PUSHENVACC1 126 APPLY2 127 POPTRAP 128 RETURN 3 130 PUSHGETGLOBAL End_of_file 132 PUSHACC1 133 GETFIELD0 134 EQ 135 BRANCHIFNOT 140 137 ACC1 138 RETURN 4 140 ACC0 141 RAISE 142 ACC0 143 C_CALL1 caml_flush 145 RETURN 1 147 RESTART 148 GRAB 1 150 ACC1 151 PUSHACC1 152 C_CALL2 caml_output_char 154 RETURN 2 156 RESTART 157 GRAB 1 159 ACC1 160 PUSHACC1 161 C_CALL2 caml_output_char 163 RETURN 2 165 RESTART 166 GRAB 1 168 ACC1 169 PUSHACC1 170 C_CALL2 caml_output_int 172 RETURN 2 174 RESTART 175 GRAB 1 177 ACC1 178 PUSHACC1 179 C_CALL2 caml_seek_out 181 RETURN 2 183 ACC0 184 C_CALL1 caml_pos_out 186 RETURN 1 188 ACC0 189 C_CALL1 caml_channel_size 191 RETURN 1 193 RESTART 194 GRAB 1 196 ACC1 197 PUSHACC1 198 C_CALL2 caml_set_binary_mode 200 RETURN 2 202 ACC0 203 C_CALL1 caml_input_char 205 RETURN 1 207 ACC0 208 C_CALL1 caml_input_char 210 RETURN 1 212 ACC0 213 C_CALL1 caml_input_int 215 RETURN 1 217 ACC0 218 C_CALL1 input_value 220 RETURN 1 222 RESTART 223 GRAB 1 225 ACC1 226 PUSHACC1 227 C_CALL2 caml_seek_in 229 RETURN 2 231 ACC0 232 C_CALL1 caml_pos_in 234 RETURN 1 236 ACC0 237 C_CALL1 caml_channel_size 239 RETURN 1 241 ACC0 242 C_CALL1 caml_close_channel 244 RETURN 1 246 RESTART 247 GRAB 1 249 ACC1 250 PUSHACC1 251 C_CALL2 caml_set_binary_mode 253 RETURN 2 255 CONST0 256 PUSHENVACC1 257 APPLY1 258 ACC0 259 C_CALL1 sys_exit 261 RETURN 1 263 CONST0 264 PUSHENVACC1 265 GETFIELD0 266 APPTERM1 2 268 CONST0 269 PUSHENVACC1 270 APPLY1 271 CONST0 272 PUSHENVACC2 273 APPTERM1 2 275 ENVACC1 276 GETFIELD0 277 PUSHACC0 278 PUSHACC2 279 CLOSURE 2, 268 282 PUSHENVACC1 283 SETFIELD0 284 RETURN 2 286 ENVACC1 287 C_CALL1 caml_flush 289 ENVACC2 290 C_CALL1 caml_flush 292 RETURN 1 294 CONST0 295 PUSHENVACC1 296 APPLY1 297 C_CALL1 float_of_string 299 RETURN 1 301 CONST0 302 PUSHENVACC1 303 APPLY1 304 C_CALL1 int_of_string 306 RETURN 1 308 ENVACC2 309 C_CALL1 caml_flush 311 ENVACC1 312 PUSHENVACC3 313 APPTERM1 2 315 CONSTINT 13 317 PUSHENVACC1 318 C_CALL2 caml_output_char 320 ENVACC1 321 C_CALL1 caml_flush 323 RETURN 1 325 ACC0 326 PUSHENVACC1 327 PUSHENVACC2 328 APPLY2 329 CONSTINT 13 331 PUSHENVACC1 332 C_CALL2 caml_output_char 334 ENVACC1 335 C_CALL1 caml_flush 337 RETURN 1 339 ACC0 340 PUSHENVACC1 341 APPLY1 342 PUSHENVACC2 343 PUSHENVACC3 344 APPTERM2 3 346 ACC0 347 PUSHENVACC1 348 APPLY1 349 PUSHENVACC2 350 PUSHENVACC3 351 APPTERM2 3 353 ACC0 354 PUSHENVACC1 355 PUSHENVACC2 356 APPTERM2 3 358 ACC0 359 PUSHENVACC1 360 C_CALL2 caml_output_char 362 RETURN 1 364 CONSTINT 13 366 PUSHENVACC1 367 C_CALL2 caml_output_char 369 ENVACC1 370 C_CALL1 caml_flush 372 RETURN 1 374 ACC0 375 PUSHENVACC1 376 PUSHENVACC2 377 APPLY2 378 CONSTINT 13 380 PUSHENVACC1 381 C_CALL2 caml_output_char 383 RETURN 1 385 ACC0 386 PUSHENVACC1 387 APPLY1 388 PUSHENVACC2 389 PUSHENVACC3 390 APPTERM2 3 392 ACC0 393 PUSHENVACC1 394 APPLY1 395 PUSHENVACC2 396 PUSHENVACC3 397 APPTERM2 3 399 ACC0 400 PUSHENVACC1 401 PUSHENVACC2 402 APPTERM2 3 404 ACC0 405 PUSHENVACC1 406 C_CALL2 caml_output_char 408 RETURN 1 410 RESTART 411 GRAB 3 413 CONST0 414 PUSHACC3 415 LTINT 416 BRANCHIF 427 418 ACC1 419 C_CALL1 ml_string_length 421 PUSHACC4 422 PUSHACC4 423 ADDINT 424 GTINT 425 BRANCHIFNOT 432 427 GETGLOBAL "really_input" 429 PUSHENVACC1 430 APPTERM1 5 432 ACC3 433 PUSHACC3 434 PUSHACC3 435 PUSHACC3 436 PUSHENVACC2 437 APPTERM 4, 8 440 RESTART 441 GRAB 3 443 CONST0 444 PUSHACC3 445 LTINT 446 BRANCHIF 457 448 ACC1 449 C_CALL1 ml_string_length 451 PUSHACC4 452 PUSHACC4 453 ADDINT 454 GTINT 455 BRANCHIFNOT 462 457 GETGLOBAL "input" 459 PUSHENVACC1 460 APPTERM1 5 462 ACC3 463 PUSHACC3 464 PUSHACC3 465 PUSHACC3 466 C_CALL4 caml_input 468 RETURN 4 470 ACC0 471 PUSHCONST0 472 PUSHGETGLOBAL <0>(0, <0>(6, 0)) 474 PUSHENVACC1 475 APPTERM3 4 477 ACC0 478 PUSHCONST0 479 PUSHGETGLOBAL <0>(0, <0>(7, 0)) 481 PUSHENVACC1 482 APPTERM3 4 484 RESTART 485 GRAB 2 487 ACC1 488 PUSHACC1 489 PUSHACC4 490 C_CALL3 sys_open 492 C_CALL1 caml_open_descriptor 494 RETURN 3 496 ACC0 497 C_CALL1 caml_flush 499 ACC0 500 C_CALL1 caml_close_channel 502 RETURN 1 504 RESTART 505 GRAB 1 507 CONST0 508 PUSHACC2 509 PUSHACC2 510 C_CALL3 output_value 512 RETURN 2 514 RESTART 515 GRAB 3 517 CONST0 518 PUSHACC3 519 LTINT 520 BRANCHIF 531 522 ACC1 523 C_CALL1 ml_string_length 525 PUSHACC4 526 PUSHACC4 527 ADDINT 528 GTINT 529 BRANCHIFNOT 536 531 GETGLOBAL "output" 533 PUSHENVACC1 534 APPTERM1 5 536 ACC3 537 PUSHACC3 538 PUSHACC3 539 PUSHACC3 540 C_CALL4 caml_output 542 RETURN 4 544 RESTART 545 GRAB 1 547 ACC1 548 C_CALL1 ml_string_length 550 PUSHCONST0 551 PUSHACC3 552 PUSHACC3 553 C_CALL4 caml_output 555 RETURN 2 557 ACC0 558 PUSHCONSTINT 438 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0)))) 562 PUSHENVACC1 563 APPTERM3 4 565 ACC0 566 PUSHCONSTINT 438 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0)))) 570 PUSHENVACC1 571 APPTERM3 4 573 RESTART 574 GRAB 2 576 ACC1 577 PUSHACC1 578 PUSHACC4 579 C_CALL3 sys_open 581 C_CALL1 caml_open_descriptor 583 RETURN 3 585 ACC0 586 PUSHGETGLOBAL "%.12g" 588 C_CALL2 format_float 590 RETURN 1 592 ACC0 593 PUSHGETGLOBAL "%d" 595 C_CALL2 format_int 597 RETURN 1 599 GETGLOBAL "false" 601 PUSHACC1 602 C_CALL2 string_equal 604 BRANCHIFNOT 609 606 CONST0 607 RETURN 1 609 GETGLOBAL "true" 611 PUSHACC1 612 C_CALL2 string_equal 614 BRANCHIFNOT 619 616 CONST1 617 RETURN 1 619 GETGLOBAL "bool_of_string" 621 PUSHENVACC1 622 APPTERM1 2 624 ACC0 625 BRANCHIFNOT 631 627 GETGLOBAL "true" 629 RETURN 1 631 GETGLOBAL "false" 633 RETURN 1 635 CONST0 636 PUSHACC1 637 LTINT 638 BRANCHIF 646 640 CONSTINT 255 642 PUSHACC1 643 GTINT 644 BRANCHIFNOT 651 646 GETGLOBAL "char_of_int" 648 PUSHENVACC1 649 APPTERM1 2 651 ACC0 652 RETURN 1 654 RESTART 655 GRAB 1 657 ACC0 658 C_CALL1 ml_string_length 660 PUSHACC2 661 C_CALL1 ml_string_length 663 PUSHACC0 664 PUSHACC2 665 ADDINT 666 C_CALL1 create_string 668 PUSHACC2 669 PUSHCONST0 670 PUSHACC2 671 PUSHCONST0 672 PUSHACC7 673 C_CALL5 blit_string 675 ACC1 676 PUSHACC3 677 PUSHACC2 678 PUSHCONST0 679 PUSHACC 8 681 C_CALL5 blit_string 683 ACC0 684 RETURN 5 686 CONSTINT -1 688 PUSHACC1 689 XORINT 690 RETURN 1 692 CONST0 693 PUSHACC1 694 GEINT 695 BRANCHIFNOT 700 697 ACC0 698 RETURN 1 700 ACC0 701 NEGINT 702 RETURN 1 704 RESTART 705 GRAB 1 707 ACC1 708 PUSHACC1 709 C_CALL2 greaterequal 711 BRANCHIFNOT 716 713 ACC0 714 RETURN 2 716 ACC1 717 RETURN 2 719 RESTART 720 GRAB 1 722 ACC1 723 PUSHACC1 724 C_CALL2 lessequal 726 BRANCHIFNOT 731 728 ACC0 729 RETURN 2 731 ACC1 732 RETURN 2 734 ACC0 735 PUSHGETGLOBAL Invalid_argument 737 MAKEBLOCK2 0 739 RAISE 740 ACC0 741 PUSHGETGLOBAL Failure 743 MAKEBLOCK2 0 745 RAISE 746 CLOSURE 0, 740 749 PUSH 750 CLOSURE 0, 734 753 PUSHGETGLOBAL "Pervasives.Exit" 755 MAKEBLOCK1 0 757 PUSHGETGLOBAL "Pervasives.Assert_failure" 759 MAKEBLOCK1 0 761 PUSH 762 CLOSURE 0, 720 765 PUSH 766 CLOSURE 0, 705 769 PUSH 770 CLOSURE 0, 692 773 PUSH 774 CLOSURE 0, 686 777 PUSHCONST0 778 PUSHCONSTINT 31 780 PUSHCONST1 781 LSLINT 782 EQ 783 BRANCHIFNOT 789 785 CONSTINT 30 787 BRANCH 791 789 CONSTINT 62 791 PUSHCONST1 792 LSLINT 793 PUSHACC0 794 OFFSETINT -1 796 PUSH 797 CLOSURE 0, 655 800 PUSHACC 9 802 CLOSURE 1, 635 805 PUSH 806 CLOSURE 0, 624 809 PUSHACC 11 811 CLOSURE 1, 599 814 PUSH 815 CLOSURE 0, 592 818 PUSH 819 CLOSURE 0, 585 822 PUSH 823 CLOSUREREC 0, 12 827 CONST0 828 C_CALL1 caml_open_descriptor 830 PUSHCONST1 831 C_CALL1 caml_open_descriptor 833 PUSHCONST2 834 C_CALL1 caml_open_descriptor 836 PUSH 837 CLOSURE 0, 574 840 PUSHACC0 841 CLOSURE 1, 565 844 PUSHACC1 845 CLOSURE 1, 557 848 PUSH 849 CLOSURE 0, 545 852 PUSHACC 22 854 CLOSURE 1, 515 857 PUSH 858 CLOSURE 0, 505 861 PUSH 862 CLOSURE 0, 496 865 PUSH 866 CLOSURE 0, 485 869 PUSHACC0 870 CLOSURE 1, 477 873 PUSHACC1 874 CLOSURE 1, 470 877 PUSHACC 28 879 CLOSURE 1, 441 882 PUSH 883 CLOSUREREC 0, 32 887 ACC0 888 PUSHACC 31 890 CLOSURE 2, 411 893 PUSHACC 22 895 CLOSUREREC 1, 70 899 ACC 15 901 CLOSURE 1, 404 904 PUSHACC 11 906 PUSHACC 17 908 CLOSURE 2, 399 911 PUSHACC 12 913 PUSHACC 18 915 PUSHACC 23 917 CLOSURE 3, 392 920 PUSHACC 13 922 PUSHACC 19 924 PUSHACC 23 926 CLOSURE 3, 385 929 PUSHACC 14 931 PUSHACC 20 933 CLOSURE 2, 374 936 PUSHACC 20 938 CLOSURE 1, 364 941 PUSHACC 20 943 CLOSURE 1, 358 946 PUSHACC 17 948 PUSHACC 22 950 CLOSURE 2, 353 953 PUSHACC 18 955 PUSHACC 23 957 PUSHACC 29 959 CLOSURE 3, 346 962 PUSHACC 19 964 PUSHACC 24 966 PUSHACC 29 968 CLOSURE 3, 339 971 PUSHACC 20 973 PUSHACC 25 975 CLOSURE 2, 325 978 PUSHACC 25 980 CLOSURE 1, 315 983 PUSHACC 12 985 PUSHACC 28 987 PUSHACC 30 989 CLOSURE 3, 308 992 PUSHACC0 993 CLOSURE 1, 301 996 PUSHACC1 997 CLOSURE 1, 294 1000 PUSHACC 29 1002 PUSHACC 31 1004 CLOSURE 2, 286 1007 MAKEBLOCK1 0 1009 PUSHACC0 1010 CLOSURE 1, 275 1013 PUSHACC1 1014 CLOSURE 1, 263 1017 PUSHACC0 1018 CLOSURE 1, 255 1021 PUSHACC1 1022 PUSHACC 22 1024 PUSHACC4 1025 PUSHACC3 1026 PUSH 1027 CLOSURE 0, 247 1030 PUSH 1031 CLOSURE 0, 241 1034 PUSH 1035 CLOSURE 0, 236 1038 PUSH 1039 CLOSURE 0, 231 1042 PUSH 1043 CLOSURE 0, 223 1046 PUSH 1047 CLOSURE 0, 217 1050 PUSH 1051 CLOSURE 0, 212 1054 PUSH 1055 CLOSURE 0, 207 1058 PUSHACC 32 1060 PUSHACC 35 1062 PUSHACC 33 1064 PUSH 1065 CLOSURE 0, 202 1068 PUSHACC 41 1070 PUSHACC 40 1072 PUSHACC 42 1074 PUSH 1075 CLOSURE 0, 194 1078 PUSHACC 46 1080 PUSH 1081 CLOSURE 0, 188 1084 PUSH 1085 CLOSURE 0, 183 1088 PUSH 1089 CLOSURE 0, 175 1092 PUSHACC 51 1094 PUSH 1095 CLOSURE 0, 166 1098 PUSH 1099 CLOSURE 0, 157 1102 PUSHACC 55 1104 PUSHACC 57 1106 PUSH 1107 CLOSURE 0, 148 1110 PUSH 1111 CLOSURE 0, 142 1114 PUSHACC 63 1116 PUSHACC 62 1118 PUSHACC 64 1120 PUSHACC 38 1122 PUSHACC 40 1124 PUSHACC 42 1126 PUSHACC 44 1128 PUSHACC 46 1130 PUSHACC 48 1132 PUSHACC 50 1134 PUSHACC 52 1136 PUSHACC 54 1138 PUSHACC 56 1140 PUSHACC 58 1142 PUSHACC 60 1144 PUSHACC 62 1146 PUSHACC 64 1148 PUSHACC 66 1150 PUSHACC 82 1152 PUSHACC 84 1154 PUSHACC 86 1156 PUSHACC 88 1158 PUSHACC 90 1160 PUSHACC 92 1162 PUSHACC 94 1164 PUSHACC 96 1166 PUSHACC 98 1168 PUSHACC 100 1170 PUSHACC 104 1172 PUSHACC 104 1174 PUSHACC 104 1176 PUSHACC 108 1178 PUSHACC 110 1180 PUSHACC 112 1182 PUSHACC 117 1184 PUSHACC 117 1186 PUSHACC 117 1188 PUSHACC 117 1190 MAKEBLOCK 69, 0 1193 POP 53 1195 SETGLOBAL Pervasives 1197 BRANCH 2177 1199 RESTART 1200 GRAB 1 1202 ACC1 1203 BRANCHIFNOT 1213 1205 ACC1 1206 GETFIELD1 1207 PUSHACC1 1208 OFFSETINT 1 1210 PUSHOFFSETCLOSURE0 1211 APPTERM2 4 1213 ACC0 1214 RETURN 2 1216 RESTART 1217 GRAB 1 1219 ACC0 1220 BRANCHIFNOT 1251 1222 CONST0 1223 PUSHACC2 1224 EQ 1225 BRANCHIFNOT 1231 1227 ACC0 1228 GETFIELD0 1229 RETURN 2 1231 CONST0 1232 PUSHACC2 1233 GTINT 1234 BRANCHIFNOT 1244 1236 ACC1 1237 OFFSETINT -1 1239 PUSHACC1 1240 GETFIELD1 1241 PUSHOFFSETCLOSURE0 1242 APPTERM2 4 1244 GETGLOBAL "List.nth" 1246 PUSHGETGLOBALFIELD Pervasives, 2 1249 APPTERM1 3 1251 GETGLOBAL "nth" 1253 PUSHGETGLOBALFIELD Pervasives, 3 1256 APPTERM1 3 1258 RESTART 1259 GRAB 1 1261 ACC0 1262 BRANCHIFNOT 1274 1264 ACC1 1265 PUSHACC1 1266 GETFIELD0 1267 MAKEBLOCK2 0 1269 PUSHACC1 1270 GETFIELD1 1271 PUSHOFFSETCLOSURE0 1272 APPTERM2 4 1274 ACC1 1275 RETURN 2 1277 ACC0 1278 BRANCHIFNOT 1291 1280 ACC0 1281 GETFIELD1 1282 PUSHOFFSETCLOSURE0 1283 APPLY1 1284 PUSHACC1 1285 GETFIELD0 1286 PUSHGETGLOBALFIELD Pervasives, 16 1289 APPTERM2 3 1291 RETURN 1 1293 RESTART 1294 GRAB 1 1296 ACC1 1297 BRANCHIFNOT 1313 1299 ACC1 1300 GETFIELD0 1301 PUSHACC1 1302 APPLY1 1303 PUSHACC2 1304 GETFIELD1 1305 PUSHACC2 1306 PUSHOFFSETCLOSURE0 1307 APPLY2 1308 PUSHACC1 1309 MAKEBLOCK2 0 1311 POP 1 1313 RETURN 2 1315 RESTART 1316 GRAB 1 1318 ACC1 1319 BRANCHIFNOT 1331 1321 ACC1 1322 GETFIELD0 1323 PUSHACC1 1324 APPLY1 1325 ACC1 1326 GETFIELD1 1327 PUSHACC1 1328 PUSHOFFSETCLOSURE0 1329 APPTERM2 4 1331 RETURN 2 1333 RESTART 1334 GRAB 2 1336 ACC2 1337 BRANCHIFNOT 1350 1339 ACC2 1340 GETFIELD1 1341 PUSHACC3 1342 GETFIELD0 1343 PUSHACC3 1344 PUSHACC3 1345 APPLY2 1346 PUSHACC2 1347 PUSHOFFSETCLOSURE0 1348 APPTERM3 6 1350 ACC1 1351 RETURN 3 1353 RESTART 1354 GRAB 2 1356 ACC1 1357 BRANCHIFNOT 1370 1359 ACC2 1360 PUSHACC2 1361 GETFIELD1 1362 PUSHACC2 1363 PUSHOFFSETCLOSURE0 1364 APPLY3 1365 PUSHACC2 1366 GETFIELD0 1367 PUSHACC2 1368 APPTERM2 5 1370 ACC2 1371 RETURN 3 1373 RESTART 1374 GRAB 2 1376 ACC1 1377 BRANCHIFNOT 1400 1379 ACC2 1380 BRANCHIFNOT 1407 1382 ACC2 1383 GETFIELD0 1384 PUSHACC2 1385 GETFIELD0 1386 PUSHACC2 1387 APPLY2 1388 PUSHACC3 1389 GETFIELD1 1390 PUSHACC3 1391 GETFIELD1 1392 PUSHACC3 1393 PUSHOFFSETCLOSURE0 1394 APPLY3 1395 PUSHACC1 1396 MAKEBLOCK2 0 1398 RETURN 4 1400 ACC2 1401 BRANCHIFNOT 1405 1403 BRANCH 1407 1405 RETURN 3 1407 GETGLOBAL "List.map2" 1409 PUSHGETGLOBALFIELD Pervasives, 2 1412 APPTERM1 4 1414 RESTART 1415 GRAB 2 1417 ACC1 1418 BRANCHIFNOT 1437 1420 ACC2 1421 BRANCHIFNOT 1444 1423 ACC2 1424 GETFIELD0 1425 PUSHACC2 1426 GETFIELD0 1427 PUSHACC2 1428 APPLY2 1429 ACC2 1430 GETFIELD1 1431 PUSHACC2 1432 GETFIELD1 1433 PUSHACC2 1434 PUSHOFFSETCLOSURE0 1435 APPTERM3 6 1437 ACC2 1438 BRANCHIFNOT 1442 1440 BRANCH 1444 1442 RETURN 3 1444 GETGLOBAL "List.iter2" 1446 PUSHGETGLOBALFIELD Pervasives, 2 1449 APPTERM1 4 1451 RESTART 1452 GRAB 3 1454 ACC2 1455 BRANCHIFNOT 1476 1457 ACC3 1458 BRANCHIFNOT 1482 1460 ACC3 1461 GETFIELD1 1462 PUSHACC3 1463 GETFIELD1 1464 PUSHACC5 1465 GETFIELD0 1466 PUSHACC5 1467 GETFIELD0 1468 PUSHACC5 1469 PUSHACC5 1470 APPLY3 1471 PUSHACC3 1472 PUSHOFFSETCLOSURE0 1473 APPTERM 4, 8 1476 ACC3 1477 BRANCHIF 1482 1479 ACC1 1480 RETURN 4 1482 GETGLOBAL "List.fold_left2" 1484 PUSHGETGLOBALFIELD Pervasives, 2 1487 APPTERM1 5 1489 RESTART 1490 GRAB 3 1492 ACC1 1493 BRANCHIFNOT 1516 1495 ACC2 1496 BRANCHIFNOT 1522 1498 PUSH_RETADDR 1509 1500 ACC6 1501 PUSHACC6 1502 GETFIELD1 1503 PUSHACC6 1504 GETFIELD1 1505 PUSHACC6 1506 PUSHOFFSETCLOSURE0 1507 APPLY 4 1509 PUSHACC3 1510 GETFIELD0 1511 PUSHACC3 1512 GETFIELD0 1513 PUSHACC3 1514 APPTERM3 7 1516 ACC2 1517 BRANCHIF 1522 1519 ACC3 1520 RETURN 4 1522 GETGLOBAL "List.fold_right2" 1524 PUSHGETGLOBALFIELD Pervasives, 2 1527 APPTERM1 5 1529 RESTART 1530 GRAB 1 1532 ACC1 1533 BRANCHIFNOT 1549 1535 ACC1 1536 GETFIELD0 1537 PUSHACC1 1538 APPLY1 1539 BRANCHIFNOT 1547 1541 ACC1 1542 GETFIELD1 1543 PUSHACC1 1544 PUSHOFFSETCLOSURE0 1545 APPTERM2 4 1547 RETURN 2 1549 CONST1 1550 RETURN 2 1552 RESTART 1553 GRAB 1 1555 ACC1 1556 BRANCHIFNOT 1570 1558 ACC1 1559 GETFIELD0 1560 PUSHACC1 1561 APPLY1 1562 BRANCHIF 1570 1564 ACC1 1565 GETFIELD1 1566 PUSHACC1 1567 PUSHOFFSETCLOSURE0 1568 APPTERM2 4 1570 RETURN 2 1572 RESTART 1573 GRAB 2 1575 ACC1 1576 BRANCHIFNOT 1599 1578 ACC2 1579 BRANCHIFNOT 1605 1581 ACC2 1582 GETFIELD0 1583 PUSHACC2 1584 GETFIELD0 1585 PUSHACC2 1586 APPLY2 1587 BRANCHIFNOT 1597 1589 ACC2 1590 GETFIELD1 1591 PUSHACC2 1592 GETFIELD1 1593 PUSHACC2 1594 PUSHOFFSETCLOSURE0 1595 APPTERM3 6 1597 RETURN 3 1599 ACC2 1600 BRANCHIF 1605 1602 CONST1 1603 RETURN 3 1605 GETGLOBAL "List.for_all2" 1607 PUSHGETGLOBALFIELD Pervasives, 2 1610 APPTERM1 4 1612 RESTART 1613 GRAB 2 1615 ACC1 1616 BRANCHIFNOT 1639 1618 ACC2 1619 BRANCHIFNOT 1646 1621 ACC2 1622 GETFIELD0 1623 PUSHACC2 1624 GETFIELD0 1625 PUSHACC2 1626 APPLY2 1627 BRANCHIF 1637 1629 ACC2 1630 GETFIELD1 1631 PUSHACC2 1632 GETFIELD1 1633 PUSHACC2 1634 PUSHOFFSETCLOSURE0 1635 APPTERM3 6 1637 RETURN 3 1639 ACC2 1640 BRANCHIFNOT 1644 1642 BRANCH 1646 1644 RETURN 3 1646 GETGLOBAL "List.exists2" 1648 PUSHGETGLOBALFIELD Pervasives, 2 1651 APPTERM1 4 1653 RESTART 1654 GRAB 1 1656 ACC1 1657 BRANCHIFNOT 1672 1659 ACC0 1660 PUSHACC2 1661 GETFIELD0 1662 C_CALL2 equal 1664 BRANCHIF 1672 1666 ACC1 1667 GETFIELD1 1668 PUSHACC1 1669 PUSHOFFSETCLOSURE0 1670 APPTERM2 4 1672 RETURN 2 1674 RESTART 1675 GRAB 1 1677 ACC1 1678 BRANCHIFNOT 1692 1680 ACC0 1681 PUSHACC2 1682 GETFIELD0 1683 EQ 1684 BRANCHIF 1692 1686 ACC1 1687 GETFIELD1 1688 PUSHACC1 1689 PUSHOFFSETCLOSURE0 1690 APPTERM2 4 1692 RETURN 2 1694 RESTART 1695 GRAB 1 1697 ACC1 1698 BRANCHIFNOT 1719 1700 ACC1 1701 GETFIELD0 1702 PUSHACC1 1703 PUSHACC1 1704 GETFIELD0 1705 C_CALL2 equal 1707 BRANCHIFNOT 1713 1709 ACC0 1710 GETFIELD1 1711 RETURN 3 1713 ACC2 1714 GETFIELD1 1715 PUSHACC2 1716 PUSHOFFSETCLOSURE0 1717 APPTERM2 5 1719 GETGLOBAL Not_found 1721 MAKEBLOCK1 0 1723 RAISE 1724 RESTART 1725 GRAB 1 1727 ACC1 1728 BRANCHIFNOT 1748 1730 ACC1 1731 GETFIELD0 1732 PUSHACC1 1733 PUSHACC1 1734 GETFIELD0 1735 EQ 1736 BRANCHIFNOT 1742 1738 ACC0 1739 GETFIELD1 1740 RETURN 3 1742 ACC2 1743 GETFIELD1 1744 PUSHACC2 1745 PUSHOFFSETCLOSURE0 1746 APPTERM2 5 1748 GETGLOBAL Not_found 1750 MAKEBLOCK1 0 1752 RAISE 1753 RESTART 1754 GRAB 1 1756 ACC1 1757 BRANCHIFNOT 1773 1759 ACC0 1760 PUSHACC2 1761 GETFIELD0 1762 GETFIELD0 1763 C_CALL2 equal 1765 BRANCHIF 1773 1767 ACC1 1768 GETFIELD1 1769 PUSHACC1 1770 PUSHOFFSETCLOSURE0 1771 APPTERM2 4 1773 RETURN 2 1775 RESTART 1776 GRAB 1 1778 ACC1 1779 BRANCHIFNOT 1794 1781 ACC0 1782 PUSHACC2 1783 GETFIELD0 1784 GETFIELD0 1785 EQ 1786 BRANCHIF 1794 1788 ACC1 1789 GETFIELD1 1790 PUSHACC1 1791 PUSHOFFSETCLOSURE0 1792 APPTERM2 4 1794 RETURN 2 1796 RESTART 1797 GRAB 1 1799 ACC1 1800 BRANCHIFNOT 1825 1802 ACC1 1803 GETFIELD0 1804 PUSHACC2 1805 GETFIELD1 1806 PUSHACC2 1807 PUSHACC2 1808 GETFIELD0 1809 C_CALL2 equal 1811 BRANCHIFNOT 1816 1813 ACC0 1814 RETURN 4 1816 ACC0 1817 PUSHACC3 1818 PUSHOFFSETCLOSURE0 1819 APPLY2 1820 PUSHACC2 1821 MAKEBLOCK2 0 1823 POP 2 1825 RETURN 2 1827 RESTART 1828 GRAB 1 1830 ACC1 1831 BRANCHIFNOT 1855 1833 ACC1 1834 GETFIELD0 1835 PUSHACC2 1836 GETFIELD1 1837 PUSHACC2 1838 PUSHACC2 1839 GETFIELD0 1840 EQ 1841 BRANCHIFNOT 1846 1843 ACC0 1844 RETURN 4 1846 ACC0 1847 PUSHACC3 1848 PUSHOFFSETCLOSURE0 1849 APPLY2 1850 PUSHACC2 1851 MAKEBLOCK2 0 1853 POP 2 1855 RETURN 2 1857 RESTART 1858 GRAB 1 1860 ACC1 1861 BRANCHIFNOT 1879 1863 ACC1 1864 GETFIELD0 1865 PUSHACC0 1866 PUSHACC2 1867 APPLY1 1868 BRANCHIFNOT 1873 1870 ACC0 1871 RETURN 3 1873 ACC2 1874 GETFIELD1 1875 PUSHACC2 1876 PUSHOFFSETCLOSURE0 1877 APPTERM2 5 1879 GETGLOBAL Not_found 1881 MAKEBLOCK1 0 1883 RAISE 1884 RESTART 1885 GRAB 2 1887 ACC2 1888 BRANCHIFNOT 1917 1890 ACC2 1891 GETFIELD0 1892 PUSHACC3 1893 GETFIELD1 1894 PUSHACC1 1895 PUSHENVACC2 1896 APPLY1 1897 BRANCHIFNOT 1908 1899 ACC0 1900 PUSHACC4 1901 PUSHACC4 1902 PUSHACC4 1903 MAKEBLOCK2 0 1905 PUSHOFFSETCLOSURE0 1906 APPTERM3 8 1908 ACC0 1909 PUSHACC4 1910 PUSHACC3 1911 MAKEBLOCK2 0 1913 PUSHACC4 1914 PUSHOFFSETCLOSURE0 1915 APPTERM3 8 1917 ACC1 1918 PUSHENVACC1 1919 APPLY1 1920 PUSHACC1 1921 PUSHENVACC1 1922 APPLY1 1923 MAKEBLOCK2 0 1925 RETURN 3 1927 RESTART 1928 GRAB 1 1930 ACC0 1931 PUSHENVACC1 1932 CLOSUREREC 2, 1885 1936 ACC2 1937 PUSHCONST0 1938 PUSHCONST0 1939 PUSHACC3 1940 APPTERM3 6 1942 ACC0 1943 BRANCHIFNOT 1967 1945 ACC0 1946 GETFIELD0 1947 PUSHACC1 1948 GETFIELD1 1949 PUSHOFFSETCLOSURE0 1950 APPLY1 1951 PUSHACC0 1952 GETFIELD1 1953 PUSHACC2 1954 GETFIELD1 1955 MAKEBLOCK2 0 1957 PUSHACC1 1958 GETFIELD0 1959 PUSHACC3 1960 GETFIELD0 1961 MAKEBLOCK2 0 1963 MAKEBLOCK2 0 1965 RETURN 3 1967 GETGLOBAL <0>(0, 0) 1969 RETURN 1 1971 RESTART 1972 GRAB 1 1974 ACC0 1975 BRANCHIFNOT 1996 1977 ACC1 1978 BRANCHIFNOT 2003 1980 ACC1 1981 GETFIELD1 1982 PUSHACC1 1983 GETFIELD1 1984 PUSHOFFSETCLOSURE0 1985 APPLY2 1986 PUSHACC2 1987 GETFIELD0 1988 PUSHACC2 1989 GETFIELD0 1990 MAKEBLOCK2 0 1992 MAKEBLOCK2 0 1994 RETURN 2 1996 ACC1 1997 BRANCHIFNOT 2001 1999 BRANCH 2003 2001 RETURN 2 2003 GETGLOBAL "List.combine" 2005 PUSHGETGLOBALFIELD Pervasives, 2 2008 APPTERM1 3 2010 RESTART 2011 GRAB 1 2013 ACC1 2014 BRANCHIFNOT 2038 2016 ACC1 2017 GETFIELD0 2018 PUSHACC2 2019 GETFIELD1 2020 PUSHACC1 2021 PUSHENVACC2 2022 APPLY1 2023 BRANCHIFNOT 2033 2025 ACC0 2026 PUSHACC3 2027 PUSHACC3 2028 MAKEBLOCK2 0 2030 PUSHOFFSETCLOSURE0 2031 APPTERM2 6 2033 ACC0 2034 PUSHACC3 2035 PUSHOFFSETCLOSURE0 2036 APPTERM2 6 2038 ACC0 2039 PUSHENVACC1 2040 APPTERM1 3 2042 ACC0 2043 PUSHENVACC1 2044 CLOSUREREC 2, 2011 2048 CONST0 2049 PUSHACC1 2050 APPTERM1 3 2052 RESTART 2053 GRAB 2 2055 ACC1 2056 BRANCHIFNOT 2077 2058 ACC2 2059 BRANCHIFNOT 2084 2061 ACC2 2062 GETFIELD1 2063 PUSHACC2 2064 GETFIELD1 2065 PUSHACC2 2066 PUSHACC5 2067 GETFIELD0 2068 PUSHACC5 2069 GETFIELD0 2070 PUSHENVACC1 2071 APPLY2 2072 MAKEBLOCK2 0 2074 PUSHOFFSETCLOSURE0 2075 APPTERM3 6 2077 ACC2 2078 BRANCHIFNOT 2082 2080 BRANCH 2084 2082 RETURN 3 2084 GETGLOBAL "List.rev_map2" 2086 PUSHGETGLOBALFIELD Pervasives, 2 2089 APPTERM1 4 2091 RESTART 2092 GRAB 2 2094 ACC0 2095 CLOSUREREC 1, 2053 2099 ACC3 2100 PUSHACC3 2101 PUSHCONST0 2102 PUSHACC3 2103 APPTERM3 7 2105 RESTART 2106 GRAB 1 2108 ACC1 2109 BRANCHIFNOT 2123 2111 ACC1 2112 GETFIELD1 2113 PUSHACC1 2114 PUSHACC3 2115 GETFIELD0 2116 PUSHENVACC1 2117 APPLY1 2118 MAKEBLOCK2 0 2120 PUSHOFFSETCLOSURE0 2121 APPTERM2 4 2123 ACC0 2124 RETURN 2 2126 RESTART 2127 GRAB 1 2129 ACC0 2130 CLOSUREREC 1, 2106 2134 ACC2 2135 PUSHCONST0 2136 PUSHACC2 2137 APPTERM2 5 2139 CONST0 2140 PUSHACC1 2141 PUSHENVACC1 2142 APPTERM2 3 2144 ACC0 2145 BRANCHIFNOT 2151 2147 ACC0 2148 GETFIELD1 2149 RETURN 1 2151 GETGLOBAL "tl" 2153 PUSHGETGLOBALFIELD Pervasives, 3 2156 APPTERM1 2 2158 ACC0 2159 BRANCHIFNOT 2165 2161 ACC0 2162 GETFIELD0 2163 RETURN 1 2165 GETGLOBAL "hd" 2167 PUSHGETGLOBALFIELD Pervasives, 3 2170 APPTERM1 2 2172 ACC0 2173 PUSHCONST0 2174 PUSHENVACC1 2175 APPTERM2 3 2177 CLOSUREREC 0, 1200 2181 ACC0 2182 CLOSURE 1, 2172 2185 PUSH 2186 CLOSURE 0, 2158 2189 PUSH 2190 CLOSURE 0, 2144 2193 PUSH 2194 CLOSUREREC 0, 1217 2198 GETGLOBALFIELD Pervasives, 16 2201 PUSH 2202 CLOSUREREC 0, 1259 2206 ACC0 2207 CLOSURE 1, 2139 2210 PUSH 2211 CLOSUREREC 0, 1277 2215 CLOSUREREC 0, 1294 2219 CLOSURE 0, 2127 2222 PUSH 2223 CLOSUREREC 0, 1316 2227 CLOSUREREC 0, 1334 2231 CLOSUREREC 0, 1354 2235 CLOSUREREC 0, 1374 2239 CLOSURE 0, 2092 2242 PUSH 2243 CLOSUREREC 0, 1415 2247 CLOSUREREC 0, 1452 2251 CLOSUREREC 0, 1490 2255 CLOSUREREC 0, 1530 2259 CLOSUREREC 0, 1553 2263 CLOSUREREC 0, 1573 2267 CLOSUREREC 0, 1613 2271 CLOSUREREC 0, 1654 2275 CLOSUREREC 0, 1675 2279 CLOSUREREC 0, 1695 2283 CLOSUREREC 0, 1725 2287 CLOSUREREC 0, 1754 2291 CLOSUREREC 0, 1776 2295 CLOSUREREC 0, 1797 2299 CLOSUREREC 0, 1828 2303 CLOSUREREC 0, 1858 2307 ACC 24 2309 CLOSURE 1, 2042 2312 PUSHACC 25 2314 CLOSUREREC 1, 1928 2318 CLOSUREREC 0, 1942 2322 CLOSUREREC 0, 1972 2326 ACC0 2327 PUSHACC2 2328 PUSHACC7 2329 PUSHACC 9 2331 PUSHACC 11 2333 PUSHACC 13 2335 PUSHACC 15 2337 PUSHACC 17 2339 PUSHACC 10 2341 PUSHACC 12 2343 PUSHACC 13 2345 PUSHACC 15 2347 PUSHACC 23 2349 PUSHACC 25 2351 PUSHACC 27 2353 PUSHACC 29 2355 PUSHACC 31 2357 PUSHACC 33 2359 PUSHACC 35 2361 PUSHACC 37 2363 PUSHACC 40 2365 PUSHACC 42 2367 PUSHACC 41 2369 PUSHACC 45 2371 PUSHACC 47 2373 PUSHACC 50 2375 PUSHACC 52 2377 PUSHACC 51 2379 PUSHACC 55 2381 PUSHACC 56 2383 PUSHACC 59 2385 PUSHACC 61 2387 PUSHACC 60 2389 PUSHACC 64 2391 PUSHACC 66 2393 PUSHACC 68 2395 PUSHACC 70 2397 MAKEBLOCK 37, 0 2400 POP 36 2402 SETGLOBAL List 2404 BRANCH 3341 2406 RESTART 2407 GRAB 2 2409 ACC2 2410 PUSHACC2 2411 VECTLENGTH 2412 OFFSETINT -1 2414 PUSHCONST0 2415 PUSH 2416 BRANCH 2433 2418 CHECK_SIGNALS 2419 ACC2 2420 PUSHACC2 2421 PUSHACC6 2422 C_CALL2 array_unsafe_get 2424 PUSHACC5 2425 APPLY2 2426 ASSIGN 2 2428 ACC1 2429 OFFSETINT -1 2431 ASSIGN 1 2433 ACC0 2434 PUSHACC2 2435 GEINT 2436 BRANCHIF 2418 2438 CONST0 2439 POP 2 2441 ACC0 2442 RETURN 4 2444 RESTART 2445 GRAB 2 2447 ACC1 2448 PUSHCONST0 2449 PUSHACC4 2450 VECTLENGTH 2451 OFFSETINT -1 2453 PUSH 2454 BRANCH 2471 2456 CHECK_SIGNALS 2457 ACC1 2458 PUSHACC6 2459 C_CALL2 array_unsafe_get 2461 PUSHACC3 2462 PUSHACC5 2463 APPLY2 2464 ASSIGN 2 2466 ACC1 2467 OFFSETINT 1 2469 ASSIGN 1 2471 ACC0 2472 PUSHACC2 2473 LEINT 2474 BRANCHIF 2456 2476 CONST0 2477 POP 2 2479 ACC0 2480 RETURN 4 2482 RESTART 2483 GRAB 1 2485 ACC1 2486 BRANCHIFNOT 2502 2488 ACC1 2489 GETFIELD0 2490 PUSHACC1 2491 PUSHENVACC1 2492 C_CALL3 array_unsafe_set 2494 ACC1 2495 GETFIELD1 2496 PUSHACC1 2497 OFFSETINT 1 2499 PUSHOFFSETCLOSURE0 2500 APPTERM2 4 2502 ENVACC1 2503 RETURN 2 2505 ACC0 2506 BRANCHIFNOT 2531 2508 ACC0 2509 GETFIELD1 2510 PUSHACC1 2511 GETFIELD0 2512 PUSHACC1 2513 PUSHGETGLOBALFIELD List, 0 2516 APPLY1 2517 OFFSETINT 1 2519 C_CALL2 make_vect 2521 PUSHACC0 2522 CLOSUREREC 1, 2483 2526 ACC2 2527 PUSHCONST1 2528 PUSHACC2 2529 APPTERM2 6 2531 ATOM0 2532 RETURN 1 2534 RESTART 2535 GRAB 1 2537 CONST0 2538 PUSHACC1 2539 LTINT 2540 BRANCHIFNOT 2545 2542 ACC1 2543 RETURN 2 2545 ACC1 2546 PUSHACC1 2547 PUSHENVACC1 2548 C_CALL2 array_unsafe_get 2550 MAKEBLOCK2 0 2552 PUSHACC1 2553 OFFSETINT -1 2555 PUSHOFFSETCLOSURE0 2556 APPTERM2 4 2558 ACC0 2559 CLOSUREREC 1, 2535 2563 CONST0 2564 PUSHACC2 2565 VECTLENGTH 2566 OFFSETINT -1 2568 PUSHACC2 2569 APPTERM2 4 2571 RESTART 2572 GRAB 1 2574 ACC1 2575 VECTLENGTH 2576 PUSHCONST0 2577 PUSHACC1 2578 EQ 2579 BRANCHIFNOT 2584 2581 ATOM0 2582 RETURN 3 2584 CONST0 2585 PUSHACC3 2586 C_CALL2 array_unsafe_get 2588 PUSHCONST0 2589 PUSHACC3 2590 APPLY2 2591 PUSHACC1 2592 C_CALL2 make_vect 2594 PUSHCONST1 2595 PUSHACC2 2596 OFFSETINT -1 2598 PUSH 2599 BRANCH 2618 2601 CHECK_SIGNALS 2602 ACC1 2603 PUSHACC6 2604 C_CALL2 array_unsafe_get 2606 PUSHACC2 2607 PUSHACC6 2608 APPLY2 2609 PUSHACC2 2610 PUSHACC4 2611 C_CALL3 array_unsafe_set 2613 ACC1 2614 OFFSETINT 1 2616 ASSIGN 1 2618 ACC0 2619 PUSHACC2 2620 LEINT 2621 BRANCHIF 2601 2623 CONST0 2624 POP 2 2626 ACC0 2627 RETURN 4 2629 RESTART 2630 GRAB 1 2632 CONST0 2633 PUSHACC2 2634 VECTLENGTH 2635 OFFSETINT -1 2637 PUSH 2638 BRANCH 2653 2640 CHECK_SIGNALS 2641 ACC1 2642 PUSHACC4 2643 C_CALL2 array_unsafe_get 2645 PUSHACC2 2646 PUSHACC4 2647 APPLY2 2648 ACC1 2649 OFFSETINT 1 2651 ASSIGN 1 2653 ACC0 2654 PUSHACC2 2655 LEINT 2656 BRANCHIF 2640 2658 CONST0 2659 RETURN 4 2661 RESTART 2662 GRAB 1 2664 ACC1 2665 VECTLENGTH 2666 PUSHCONST0 2667 PUSHACC1 2668 EQ 2669 BRANCHIFNOT 2674 2671 ATOM0 2672 RETURN 3 2674 CONST0 2675 PUSHACC3 2676 C_CALL2 array_unsafe_get 2678 PUSHACC2 2679 APPLY1 2680 PUSHACC1 2681 C_CALL2 make_vect 2683 PUSHCONST1 2684 PUSHACC2 2685 OFFSETINT -1 2687 PUSH 2688 BRANCH 2706 2690 CHECK_SIGNALS 2691 ACC1 2692 PUSHACC6 2693 C_CALL2 array_unsafe_get 2695 PUSHACC5 2696 APPLY1 2697 PUSHACC2 2698 PUSHACC4 2699 C_CALL3 array_unsafe_set 2701 ACC1 2702 OFFSETINT 1 2704 ASSIGN 1 2706 ACC0 2707 PUSHACC2 2708 LEINT 2709 BRANCHIF 2690 2711 CONST0 2712 POP 2 2714 ACC0 2715 RETURN 4 2717 RESTART 2718 GRAB 1 2720 CONST0 2721 PUSHACC2 2722 VECTLENGTH 2723 OFFSETINT -1 2725 PUSH 2726 BRANCH 2740 2728 CHECK_SIGNALS 2729 ACC1 2730 PUSHACC4 2731 C_CALL2 array_unsafe_get 2733 PUSHACC3 2734 APPLY1 2735 ACC1 2736 OFFSETINT 1 2738 ASSIGN 1 2740 ACC0 2741 PUSHACC2 2742 LEINT 2743 BRANCHIF 2728 2745 CONST0 2746 RETURN 4 2748 RESTART 2749 GRAB 4 2751 CONST0 2752 PUSHACC5 2753 LTINT 2754 BRANCHIF 2782 2756 CONST0 2757 PUSHACC2 2758 LTINT 2759 BRANCHIF 2782 2761 ACC0 2762 VECTLENGTH 2763 PUSHACC5 2764 PUSHACC3 2765 ADDINT 2766 GTINT 2767 BRANCHIF 2782 2769 CONST0 2770 PUSHACC4 2771 LTINT 2772 BRANCHIF 2782 2774 ACC2 2775 VECTLENGTH 2776 PUSHACC5 2777 PUSHACC5 2778 ADDINT 2779 GTINT 2780 BRANCHIFNOT 2789 2782 GETGLOBAL "Array.blit" 2784 PUSHGETGLOBALFIELD Pervasives, 2 2787 APPTERM1 6 2789 ACC3 2790 PUSHACC2 2791 LTINT 2792 BRANCHIFNOT 2827 2794 ACC4 2795 OFFSETINT -1 2797 PUSHCONST0 2798 PUSH 2799 BRANCH 2819 2801 CHECK_SIGNALS 2802 ACC1 2803 PUSHACC4 2804 ADDINT 2805 PUSHACC3 2806 C_CALL2 array_unsafe_get 2808 PUSHACC2 2809 PUSHACC7 2810 ADDINT 2811 PUSHACC6 2812 C_CALL3 array_unsafe_set 2814 ACC1 2815 OFFSETINT -1 2817 ASSIGN 1 2819 ACC0 2820 PUSHACC2 2821 GEINT 2822 BRANCHIF 2801 2824 CONST0 2825 RETURN 7 2827 CONST0 2828 PUSHACC5 2829 OFFSETINT -1 2831 PUSH 2832 BRANCH 2852 2834 CHECK_SIGNALS 2835 ACC1 2836 PUSHACC4 2837 ADDINT 2838 PUSHACC3 2839 C_CALL2 array_unsafe_get 2841 PUSHACC2 2842 PUSHACC7 2843 ADDINT 2844 PUSHACC6 2845 C_CALL3 array_unsafe_set 2847 ACC1 2848 OFFSETINT 1 2850 ASSIGN 1 2852 ACC0 2853 PUSHACC2 2854 LEINT 2855 BRANCHIF 2834 2857 CONST0 2858 RETURN 7 2860 RESTART 2861 GRAB 3 2863 CONST0 2864 PUSHACC2 2865 LTINT 2866 BRANCHIF 2881 2868 CONST0 2869 PUSHACC3 2870 LTINT 2871 BRANCHIF 2881 2873 ACC0 2874 VECTLENGTH 2875 PUSHACC3 2876 PUSHACC3 2877 ADDINT 2878 GTINT 2879 BRANCHIFNOT 2888 2881 GETGLOBAL "Array.fill" 2883 PUSHGETGLOBALFIELD Pervasives, 2 2886 APPTERM1 5 2888 ACC1 2889 PUSHACC3 2890 PUSHACC3 2891 ADDINT 2892 OFFSETINT -1 2894 PUSH 2895 BRANCH 2908 2897 CHECK_SIGNALS 2898 ACC5 2899 PUSHACC2 2900 PUSHACC4 2901 C_CALL3 array_unsafe_set 2903 ACC1 2904 OFFSETINT 1 2906 ASSIGN 1 2908 ACC0 2909 PUSHACC2 2910 LEINT 2911 BRANCHIF 2897 2913 CONST0 2914 RETURN 6 2916 RESTART 2917 GRAB 2 2919 CONST0 2920 PUSHACC2 2921 LTINT 2922 BRANCHIF 2937 2924 CONST0 2925 PUSHACC3 2926 LTINT 2927 BRANCHIF 2937 2929 ACC0 2930 VECTLENGTH 2931 PUSHACC3 2932 PUSHACC3 2933 ADDINT 2934 GTINT 2935 BRANCHIFNOT 2944 2937 GETGLOBAL "Array.sub" 2939 PUSHGETGLOBALFIELD Pervasives, 2 2942 APPTERM1 4 2944 CONST0 2945 PUSHACC3 2946 EQ 2947 BRANCHIFNOT 2952 2949 ATOM0 2950 RETURN 3 2952 ACC1 2953 PUSHACC1 2954 C_CALL2 array_unsafe_get 2956 PUSHACC3 2957 C_CALL2 make_vect 2959 PUSHCONST1 2960 PUSHACC4 2961 OFFSETINT -1 2963 PUSH 2964 BRANCH 2982 2966 CHECK_SIGNALS 2967 ACC1 2968 PUSHACC5 2969 ADDINT 2970 PUSHACC4 2971 C_CALL2 array_unsafe_get 2973 PUSHACC2 2974 PUSHACC4 2975 C_CALL3 array_unsafe_set 2977 ACC1 2978 OFFSETINT 1 2980 ASSIGN 1 2982 ACC0 2983 PUSHACC2 2984 LEINT 2985 BRANCHIF 2966 2987 CONST0 2988 POP 2 2990 ACC0 2991 RETURN 4 2993 ACC0 2994 BRANCHIFNOT 3017 2996 ACC0 2997 GETFIELD0 2998 PUSHCONST0 2999 PUSHACC1 3000 VECTLENGTH 3001 GTINT 3002 BRANCHIFNOT 3012 3004 ENVACC2 3005 PUSHCONST0 3006 PUSHACC2 3007 C_CALL2 array_unsafe_get 3009 PUSHENVACC1 3010 APPTERM2 4 3012 ACC1 3013 GETFIELD1 3014 PUSHOFFSETCLOSURE0 3015 APPTERM1 3 3017 ATOM0 3018 RETURN 1 3020 ACC0 3021 PUSHENVACC1 3022 CLOSUREREC 2, 2993 3026 ACC1 3027 PUSHACC1 3028 APPTERM1 3 3030 CONST0 3031 PUSHACC1 3032 VECTLENGTH 3033 OFFSETINT -1 3035 PUSH 3036 BRANCH 3056 3038 CHECK_SIGNALS 3039 ACC1 3040 PUSHACC3 3041 C_CALL2 array_unsafe_get 3043 PUSHENVACC2 3044 GETFIELD0 3045 PUSHENVACC1 3046 C_CALL3 array_unsafe_set 3048 ENVACC2 3049 OFFSETREF 1 3051 ACC1 3052 OFFSETINT 1 3054 ASSIGN 1 3056 ACC0 3057 PUSHACC2 3058 LEINT 3059 BRANCHIF 3038 3061 CONST0 3062 RETURN 3 3064 RESTART 3065 GRAB 1 3067 ACC1 3068 VECTLENGTH 3069 PUSHACC1 3070 ADDINT 3071 RETURN 2 3073 RESTART 3074 GRAB 1 3076 ACC1 3077 PUSHCONST0 3078 PUSH 3079 CLOSURE 0, 3065 3082 PUSHGETGLOBALFIELD List, 12 3085 APPLY3 3086 PUSHACC1 3087 PUSHACC1 3088 C_CALL2 make_vect 3090 PUSHCONST0 3091 MAKEBLOCK1 0 3093 PUSHACC4 3094 PUSHACC1 3095 PUSHACC3 3096 CLOSURE 2, 3030 3099 PUSHGETGLOBALFIELD List, 9 3102 APPLY2 3103 ACC1 3104 RETURN 5 3106 RESTART 3107 GRAB 1 3109 ACC0 3110 VECTLENGTH 3111 PUSHACC2 3112 VECTLENGTH 3113 PUSHCONST0 3114 PUSHACC2 3115 EQ 3116 BRANCHIFNOT 3126 3118 CONST0 3119 PUSHACC1 3120 EQ 3121 BRANCHIFNOT 3126 3123 ATOM0 3124 RETURN 4 3126 CONST0 3127 PUSHCONST0 3128 PUSHACC3 3129 GTINT 3130 BRANCHIFNOT 3135 3132 ACC3 3133 BRANCH 3136 3135 ACC4 3136 C_CALL2 array_unsafe_get 3138 PUSHACC1 3139 PUSHACC3 3140 ADDINT 3141 C_CALL2 make_vect 3143 PUSHCONST0 3144 PUSHACC3 3145 OFFSETINT -1 3147 PUSH 3148 BRANCH 3164 3150 CHECK_SIGNALS 3151 ACC1 3152 PUSHACC6 3153 C_CALL2 array_unsafe_get 3155 PUSHACC2 3156 PUSHACC4 3157 C_CALL3 array_unsafe_set 3159 ACC1 3160 OFFSETINT 1 3162 ASSIGN 1 3164 ACC0 3165 PUSHACC2 3166 LEINT 3167 BRANCHIF 3150 3169 CONST0 3170 POP 2 3172 CONST0 3173 PUSHACC2 3174 OFFSETINT -1 3176 PUSH 3177 BRANCH 3195 3179 CHECK_SIGNALS 3180 ACC1 3181 PUSHACC7 3182 C_CALL2 array_unsafe_get 3184 PUSHACC5 3185 PUSHACC3 3186 ADDINT 3187 PUSHACC4 3188 C_CALL3 array_unsafe_set 3190 ACC1 3191 OFFSETINT 1 3193 ASSIGN 1 3195 ACC0 3196 PUSHACC2 3197 LEINT 3198 BRANCHIF 3179 3200 CONST0 3201 POP 2 3203 ACC0 3204 RETURN 5 3206 ACC0 3207 VECTLENGTH 3208 PUSHCONST0 3209 PUSHACC1 3210 EQ 3211 BRANCHIFNOT 3216 3213 ATOM0 3214 RETURN 2 3216 CONST0 3217 PUSHACC2 3218 C_CALL2 array_unsafe_get 3220 PUSHACC1 3221 C_CALL2 make_vect 3223 PUSHCONST1 3224 PUSHACC2 3225 OFFSETINT -1 3227 PUSH 3228 BRANCH 3244 3230 CHECK_SIGNALS 3231 ACC1 3232 PUSHACC5 3233 C_CALL2 array_unsafe_get 3235 PUSHACC2 3236 PUSHACC4 3237 C_CALL3 array_unsafe_set 3239 ACC1 3240 OFFSETINT 1 3242 ASSIGN 1 3244 ACC0 3245 PUSHACC2 3246 LEINT 3247 BRANCHIF 3230 3249 CONST0 3250 POP 2 3252 ACC0 3253 RETURN 3 3255 RESTART 3256 GRAB 2 3258 ATOM0 3259 PUSHACC1 3260 C_CALL2 make_vect 3262 PUSHCONST0 3263 PUSHACC2 3264 OFFSETINT -1 3266 PUSH 3267 BRANCH 3282 3269 CHECK_SIGNALS 3270 ACC5 3271 PUSHACC5 3272 C_CALL2 make_vect 3274 PUSHACC2 3275 PUSHACC4 3276 SETVECTITEM 3277 ACC1 3278 OFFSETINT 1 3280 ASSIGN 1 3282 ACC0 3283 PUSHACC2 3284 LEINT 3285 BRANCHIF 3269 3287 CONST0 3288 POP 2 3290 ACC0 3291 RETURN 4 3293 RESTART 3294 GRAB 1 3296 CONST0 3297 PUSHACC1 3298 EQ 3299 BRANCHIFNOT 3304 3301 ATOM0 3302 RETURN 2 3304 CONST0 3305 PUSHACC2 3306 APPLY1 3307 PUSHACC1 3308 C_CALL2 make_vect 3310 PUSHCONST1 3311 PUSHACC2 3312 OFFSETINT -1 3314 PUSH 3315 BRANCH 3330 3317 CHECK_SIGNALS 3318 ACC1 3319 PUSHACC5 3320 APPLY1 3321 PUSHACC2 3322 PUSHACC4 3323 C_CALL3 array_unsafe_set 3325 ACC1 3326 OFFSETINT 1 3328 ASSIGN 1 3330 ACC0 3331 PUSHACC2 3332 LEINT 3333 BRANCHIF 3317 3335 CONST0 3336 POP 2 3338 ACC0 3339 RETURN 3 3341 CLOSURE 0, 3294 3344 PUSH 3345 CLOSURE 0, 3256 3348 PUSH 3349 CLOSURE 0, 3206 3352 PUSH 3353 CLOSURE 0, 3107 3356 PUSH 3357 CLOSURE 0, 3074 3360 PUSHACC0 3361 CLOSURE 1, 3020 3364 PUSH 3365 CLOSURE 0, 2917 3368 PUSH 3369 CLOSURE 0, 2861 3372 PUSH 3373 CLOSURE 0, 2749 3376 PUSH 3377 CLOSURE 0, 2718 3380 PUSH 3381 CLOSURE 0, 2662 3384 PUSH 3385 CLOSURE 0, 2630 3388 PUSH 3389 CLOSURE 0, 2572 3392 PUSH 3393 CLOSURE 0, 2558 3396 PUSH 3397 CLOSURE 0, 2505 3400 PUSH 3401 CLOSURE 0, 2445 3404 PUSH 3405 CLOSURE 0, 2407 3408 PUSHACC0 3409 PUSHACC2 3410 PUSHACC6 3411 PUSHACC 8 3413 PUSHACC 10 3415 PUSHACC 12 3417 PUSHACC 8 3419 PUSHACC 10 3421 PUSHACC 16 3423 PUSHACC 18 3425 PUSHACC 24 3427 PUSHACC 21 3429 PUSHACC 23 3431 PUSHACC 26 3433 PUSHACC 29 3435 PUSHACC 30 3437 PUSHACC 32 3439 MAKEBLOCK 17, 0 3442 POP 17 3444 SETGLOBAL Array 3446 BRANCH 3480 3448 ENVACC1 3449 MAKEBLOCK1 0 3451 RAISE 3452 ACC0 3453 BRANCHIFNOT 3465 3455 ENVACC3 3456 CLOSURE 1, 3448 3459 MAKEBLOCK1 0 3461 PUSHENVACC2 3462 PUSHENVACC1 3463 APPTERM2 3 3465 CONST0 3466 PUSHENVACC2 3467 PUSHENVACC1 3468 APPTERM2 3 3470 RESTART 3471 GRAB 1 3473 ACC1 3474 PUSHACC1 3475 C_CALL2 install_signal_handler 3477 CONST0 3478 RETURN 2 3480 CONST0 3481 C_CALL1 sys_get_argv 3483 PUSHCONST0 3484 C_CALL1 sys_get_config 3486 PUSHACC0 3487 GETFIELD1 3488 PUSHACC0 3489 OFFSETINT -10 3491 PUSHCONST1 3492 LSLINT 3493 OFFSETINT -1 3495 PUSHACC0 3496 PUSHCONSTINT 8 3498 PUSHACC3 3499 DIVINT 3500 MULINT 3501 OFFSETINT -1 3503 PUSHCONST0 3504 MAKEBLOCK1 0 3506 PUSH 3507 CLOSURE 0, 3471 3510 PUSHCONSTINT -1 3512 PUSHCONSTINT -2 3514 PUSHCONSTINT -3 3516 PUSHCONSTINT -4 3518 PUSHCONSTINT -5 3520 PUSHCONSTINT -6 3522 PUSHCONSTINT -7 3524 PUSHCONSTINT -8 3526 PUSHCONSTINT -9 3528 PUSHCONSTINT -10 3530 PUSHCONSTINT -11 3532 PUSHCONSTINT -12 3534 PUSHCONSTINT -13 3536 PUSHCONSTINT -14 3538 PUSHCONSTINT -15 3540 PUSHCONSTINT -16 3542 PUSHCONSTINT -17 3544 PUSHCONSTINT -18 3546 PUSHCONSTINT -19 3548 PUSHCONSTINT -20 3550 PUSHCONSTINT -21 3552 PUSHGETGLOBAL "Sys.Break" 3554 MAKEBLOCK1 0 3556 PUSHACC0 3557 PUSHACC 17 3559 PUSHACC 24 3561 CLOSURE 3, 3452 3564 PUSHACC0 3565 PUSHACC2 3566 PUSHACC4 3567 PUSHACC6 3568 PUSHACC 8 3570 PUSHACC 10 3572 PUSHACC 12 3574 PUSHACC 14 3576 PUSHACC 16 3578 PUSHACC 18 3580 PUSHACC 20 3582 PUSHACC 22 3584 PUSHACC 24 3586 PUSHACC 26 3588 PUSHACC 28 3590 PUSHACC 30 3592 PUSHACC 32 3594 PUSHACC 34 3596 PUSHACC 36 3598 PUSHACC 38 3600 PUSHACC 40 3602 PUSHACC 42 3604 PUSHACC 44 3606 PUSHACC 46 3608 PUSHACC 50 3610 PUSHACC 50 3612 PUSHACC 53 3614 PUSHACC 55 3616 GETFIELD0 3617 PUSHACC 52 3619 PUSHACC 58 3621 MAKEBLOCK 30, 0 3624 POP 30 3626 SETGLOBAL Sys 3628 BRANCH 4510 3630 RESTART 3631 GRAB 1 3633 CONST0 3634 PUSHACC1 3635 LTINT 3636 BRANCHIFNOT 3641 3638 CONST1 3639 RETURN 2 3641 ACC1 3642 BRANCHIFNOT 3652 3644 ACC1 3645 GETFIELD2 3646 PUSHACC1 3647 OFFSETINT -1 3649 PUSHOFFSETCLOSURE0 3650 APPTERM2 4 3652 RETURN 2 3654 ACC0 3655 BRANCHIFNOT 3670 3657 ENVACC2 3658 PUSHACC1 3659 GETFIELD0 3660 PUSHENVACC1 3661 GETFIELD0 3662 APPLY2 3663 BRANCHIF 3670 3665 ACC0 3666 GETFIELD2 3667 PUSHOFFSETCLOSURE0 3668 APPTERM1 2 3670 RETURN 1 3672 RESTART 3673 GRAB 1 3675 ACC1 3676 PUSHENVACC1 3677 CLOSUREREC 2, 3654 3681 ACC1 3682 GETFIELD1 3683 VECTLENGTH 3684 PUSHACC3 3685 PUSHENVACC1 3686 GETFIELD1 3687 APPLY1 3688 MODINT 3689 PUSHACC2 3690 GETFIELD1 3691 C_CALL2 array_get_addr 3693 PUSHACC1 3694 APPTERM1 4 3696 ACC0 3697 BRANCHIFNOT 3722 3699 ACC0 3700 GETFIELD2 3701 PUSHENVACC2 3702 PUSHACC2 3703 GETFIELD0 3704 PUSHENVACC1 3705 GETFIELD0 3706 APPLY2 3707 BRANCHIFNOT 3718 3709 ACC0 3710 PUSHOFFSETCLOSURE0 3711 APPLY1 3712 PUSHACC2 3713 GETFIELD1 3714 MAKEBLOCK2 0 3716 RETURN 2 3718 ACC0 3719 PUSHOFFSETCLOSURE0 3720 APPTERM1 3 3722 RETURN 1 3724 RESTART 3725 GRAB 1 3727 ACC1 3728 PUSHENVACC1 3729 CLOSUREREC 2, 3696 3733 ACC1 3734 GETFIELD1 3735 VECTLENGTH 3736 PUSHACC3 3737 PUSHENVACC1 3738 GETFIELD1 3739 APPLY1 3740 MODINT 3741 PUSHACC2 3742 GETFIELD1 3743 C_CALL2 array_get_addr 3745 PUSHACC1 3746 APPTERM1 4 3748 ACC0 3749 BRANCHIFNOT 3768 3751 ACC0 3752 GETFIELD0 3753 PUSHENVACC2 3754 PUSHENVACC1 3755 GETFIELD0 3756 APPLY2 3757 BRANCHIFNOT 3763 3759 ACC0 3760 GETFIELD1 3761 RETURN 1 3763 ACC0 3764 GETFIELD2 3765 PUSHOFFSETCLOSURE0 3766 APPTERM1 2 3768 GETGLOBAL Not_found 3770 MAKEBLOCK1 0 3772 RAISE 3773 RESTART 3774 GRAB 1 3776 ACC0 3777 GETFIELD1 3778 VECTLENGTH 3779 PUSHACC2 3780 PUSHENVACC1 3781 GETFIELD1 3782 APPLY1 3783 MODINT 3784 PUSHACC1 3785 GETFIELD1 3786 C_CALL2 array_get_addr 3788 PUSHACC0 3789 BRANCHIFNOT 3858 3791 ACC0 3792 GETFIELD2 3793 PUSHACC1 3794 GETFIELD0 3795 PUSHACC4 3796 PUSHENVACC1 3797 GETFIELD0 3798 APPLY2 3799 BRANCHIFNOT 3805 3801 ACC1 3802 GETFIELD1 3803 RETURN 4 3805 ACC0 3806 BRANCHIFNOT 3853 3808 ACC0 3809 GETFIELD2 3810 PUSHACC1 3811 GETFIELD0 3812 PUSHACC5 3813 PUSHENVACC1 3814 GETFIELD0 3815 APPLY2 3816 BRANCHIFNOT 3822 3818 ACC1 3819 GETFIELD1 3820 RETURN 5 3822 ACC0 3823 BRANCHIFNOT 3848 3825 ACC0 3826 GETFIELD0 3827 PUSHACC5 3828 PUSHENVACC1 3829 GETFIELD0 3830 APPLY2 3831 BRANCHIFNOT 3837 3833 ACC0 3834 GETFIELD1 3835 RETURN 5 3837 ACC4 3838 PUSHENVACC1 3839 CLOSUREREC 2, 3748 3843 ACC1 3844 GETFIELD2 3845 PUSHACC1 3846 APPTERM1 7 3848 GETGLOBAL Not_found 3850 MAKEBLOCK1 0 3852 RAISE 3853 GETGLOBAL Not_found 3855 MAKEBLOCK1 0 3857 RAISE 3858 GETGLOBAL Not_found 3860 MAKEBLOCK1 0 3862 RAISE 3863 ACC0 3864 BRANCHIFNOT 3890 3866 ACC0 3867 GETFIELD0 3868 PUSHACC1 3869 GETFIELD2 3870 PUSHENVACC2 3871 PUSHACC2 3872 PUSHENVACC1 3873 GETFIELD0 3874 APPLY2 3875 BRANCHIFNOT 3880 3877 ACC0 3878 RETURN 3 3880 ACC0 3881 PUSHOFFSETCLOSURE0 3882 APPLY1 3883 PUSHACC3 3884 GETFIELD1 3885 PUSHACC3 3886 MAKEBLOCK3 0 3888 POP 2 3890 RETURN 1 3892 RESTART 3893 GRAB 1 3895 ACC1 3896 PUSHENVACC1 3897 CLOSUREREC 2, 3863 3901 ACC1 3902 GETFIELD1 3903 VECTLENGTH 3904 PUSHACC3 3905 PUSHENVACC1 3906 GETFIELD1 3907 APPLY1 3908 MODINT 3909 PUSHACC0 3910 PUSHACC3 3911 GETFIELD1 3912 C_CALL2 array_get_addr 3914 PUSHACC2 3915 APPLY1 3916 PUSHACC1 3917 PUSHACC4 3918 GETFIELD1 3919 C_CALL3 array_set_addr 3921 RETURN 4 3923 RESTART 3924 GRAB 2 3926 ACC0 3927 GETFIELD1 3928 VECTLENGTH 3929 PUSHACC2 3930 PUSHENVACC3 3931 GETFIELD1 3932 APPLY1 3933 MODINT 3934 PUSHACC0 3935 PUSHACC2 3936 GETFIELD1 3937 C_CALL2 array_get_addr 3939 PUSHACC4 3940 PUSHACC4 3941 MAKEBLOCK3 0 3943 PUSHACC0 3944 PUSHACC2 3945 PUSHACC4 3946 GETFIELD1 3947 C_CALL3 array_set_addr 3949 ACC0 3950 PUSHACC3 3951 GETFIELD0 3952 PUSHENVACC2 3953 APPLY2 3954 BRANCHIFNOT 3962 3956 ACC2 3957 PUSHENVACC3 3958 GETFIELD1 3959 PUSHENVACC1 3960 APPTERM2 7 3962 RETURN 5 3964 ACC0 3965 PUSHENVACC 4 3967 PUSHENVACC3 3968 CLOSURE 3, 3924 3971 PUSHACC1 3972 CLOSURE 1, 3893 3975 PUSHACC2 3976 CLOSURE 1, 3774 3979 PUSHACC3 3980 CLOSURE 1, 3725 3983 PUSHACC4 3984 CLOSURE 1, 3673 3987 PUSHENVACC 5 3989 PUSHACC1 3990 PUSHACC3 3991 PUSHACC5 3992 PUSHACC7 3993 PUSHACC 9 3995 PUSHENVACC2 3996 PUSHENVACC1 3997 MAKEBLOCK 8, 0 4000 RETURN 6 4002 ACC0 4003 BRANCHIFNOT 4016 4005 ACC0 4006 GETFIELD1 4007 PUSHACC1 4008 GETFIELD0 4009 PUSHENVACC1 4010 APPLY2 4011 ACC0 4012 GETFIELD2 4013 PUSHOFFSETCLOSURE0 4014 APPTERM1 2 4016 RETURN 1 4018 RESTART 4019 GRAB 1 4021 ACC0 4022 CLOSUREREC 1, 4002 4026 ACC2 4027 GETFIELD1 4028 PUSHCONST0 4029 PUSHACC1 4030 VECTLENGTH 4031 OFFSETINT -1 4033 PUSH 4034 BRANCH 4048 4036 CHECK_SIGNALS 4037 ACC1 4038 PUSHACC3 4039 C_CALL2 array_get_addr 4041 PUSHACC4 4042 APPLY1 4043 ACC1 4044 OFFSETINT 1 4046 ASSIGN 1 4048 ACC0 4049 PUSHACC2 4050 LEINT 4051 BRANCHIF 4036 4053 CONST0 4054 RETURN 6 4056 ACC0 4057 BRANCHIFNOT 4071 4059 ENVACC1 4060 PUSHACC1 4061 GETFIELD0 4062 C_CALL2 equal 4064 BRANCHIF 4071 4066 ACC0 4067 GETFIELD2 4068 PUSHOFFSETCLOSURE0 4069 APPTERM1 2 4071 RETURN 1 4073 RESTART 4074 GRAB 1 4076 ACC1 4077 CLOSUREREC 1, 4056 4081 ACC1 4082 GETFIELD1 4083 VECTLENGTH 4084 PUSHACC3 4085 PUSHENVACC1 4086 APPLY1 4087 MODINT 4088 PUSHACC2 4089 GETFIELD1 4090 C_CALL2 array_get_addr 4092 PUSHACC1 4093 APPTERM1 4 4095 ACC0 4096 BRANCHIFNOT 4120 4098 ACC0 4099 GETFIELD2 4100 PUSHENVACC1 4101 PUSHACC2 4102 GETFIELD0 4103 C_CALL2 equal 4105 BRANCHIFNOT 4116 4107 ACC0 4108 PUSHOFFSETCLOSURE0 4109 APPLY1 4110 PUSHACC2 4111 GETFIELD1 4112 MAKEBLOCK2 0 4114 RETURN 2 4116 ACC0 4117 PUSHOFFSETCLOSURE0 4118 APPTERM1 3 4120 RETURN 1 4122 RESTART 4123 GRAB 1 4125 ACC1 4126 CLOSUREREC 1, 4095 4130 ACC1 4131 GETFIELD1 4132 VECTLENGTH 4133 PUSHACC3 4134 PUSHENVACC1 4135 APPLY1 4136 MODINT 4137 PUSHACC2 4138 GETFIELD1 4139 C_CALL2 array_get_addr 4141 PUSHACC1 4142 APPTERM1 4 4144 ACC0 4145 BRANCHIFNOT 4163 4147 ACC0 4148 GETFIELD0 4149 PUSHENVACC1 4150 C_CALL2 equal 4152 BRANCHIFNOT 4158 4154 ACC0 4155 GETFIELD1 4156 RETURN 1 4158 ACC0 4159 GETFIELD2 4160 PUSHOFFSETCLOSURE0 4161 APPTERM1 2 4163 GETGLOBAL Not_found 4165 MAKEBLOCK1 0 4167 RAISE 4168 RESTART 4169 GRAB 1 4171 ACC0 4172 GETFIELD1 4173 VECTLENGTH 4174 PUSHACC2 4175 PUSHENVACC1 4176 APPLY1 4177 MODINT 4178 PUSHACC1 4179 GETFIELD1 4180 C_CALL2 array_get_addr 4182 PUSHACC0 4183 BRANCHIFNOT 4248 4185 ACC0 4186 GETFIELD2 4187 PUSHACC1 4188 GETFIELD0 4189 PUSHACC4 4190 C_CALL2 equal 4192 BRANCHIFNOT 4198 4194 ACC1 4195 GETFIELD1 4196 RETURN 4 4198 ACC0 4199 BRANCHIFNOT 4243 4201 ACC0 4202 GETFIELD2 4203 PUSHACC1 4204 GETFIELD0 4205 PUSHACC5 4206 C_CALL2 equal 4208 BRANCHIFNOT 4214 4210 ACC1 4211 GETFIELD1 4212 RETURN 5 4214 ACC0 4215 BRANCHIFNOT 4238 4217 ACC0 4218 GETFIELD0 4219 PUSHACC5 4220 C_CALL2 equal 4222 BRANCHIFNOT 4228 4224 ACC0 4225 GETFIELD1 4226 RETURN 5 4228 ACC4 4229 CLOSUREREC 1, 4144 4233 ACC1 4234 GETFIELD2 4235 PUSHACC1 4236 APPTERM1 7 4238 GETGLOBAL Not_found 4240 MAKEBLOCK1 0 4242 RAISE 4243 GETGLOBAL Not_found 4245 MAKEBLOCK1 0 4247 RAISE 4248 GETGLOBAL Not_found 4250 MAKEBLOCK1 0 4252 RAISE 4253 ACC0 4254 BRANCHIFNOT 4279 4256 ACC0 4257 GETFIELD0 4258 PUSHACC1 4259 GETFIELD2 4260 PUSHENVACC1 4261 PUSHACC2 4262 C_CALL2 equal 4264 BRANCHIFNOT 4269 4266 ACC0 4267 RETURN 3 4269 ACC0 4270 PUSHOFFSETCLOSURE0 4271 APPLY1 4272 PUSHACC3 4273 GETFIELD1 4274 PUSHACC3 4275 MAKEBLOCK3 0 4277 POP 2 4279 RETURN 1 4281 RESTART 4282 GRAB 1 4284 ACC1 4285 CLOSUREREC 1, 4253 4289 ACC1 4290 GETFIELD1 4291 VECTLENGTH 4292 PUSHACC3 4293 PUSHENVACC1 4294 APPLY1 4295 MODINT 4296 PUSHACC0 4297 PUSHACC3 4298 GETFIELD1 4299 C_CALL2 array_get_addr 4301 PUSHACC2 4302 APPLY1 4303 PUSHACC1 4304 PUSHACC4 4305 GETFIELD1 4306 C_CALL3 array_set_addr 4308 RETURN 4 4310 RESTART 4311 GRAB 2 4313 ACC0 4314 GETFIELD1 4315 VECTLENGTH 4316 PUSHACC2 4317 PUSHENVACC1 4318 APPLY1 4319 MODINT 4320 PUSHACC0 4321 PUSHACC2 4322 GETFIELD1 4323 C_CALL2 array_get_addr 4325 PUSHACC4 4326 PUSHACC4 4327 MAKEBLOCK3 0 4329 PUSHACC0 4330 PUSHACC2 4331 PUSHACC4 4332 GETFIELD1 4333 C_CALL3 array_set_addr 4335 ACC0 4336 PUSHACC3 4337 GETFIELD0 4338 PUSHENVACC3 4339 APPLY2 4340 BRANCHIFNOT 4347 4342 ACC2 4343 PUSHENVACC1 4344 PUSHENVACC2 4345 APPTERM2 7 4347 RETURN 5 4349 ACC0 4350 BRANCHIFNOT 4378 4352 ACC0 4353 GETFIELD0 4354 PUSHACC1 4355 GETFIELD2 4356 PUSHOFFSETCLOSURE0 4357 APPLY1 4358 ENVACC2 4359 PUSHACC1 4360 PUSHENVACC1 4361 APPLY1 4362 MODINT 4363 PUSHACC0 4364 PUSHENVACC3 4365 C_CALL2 array_get_addr 4367 PUSHACC3 4368 GETFIELD1 4369 PUSHACC3 4370 MAKEBLOCK3 0 4372 PUSHACC1 4373 PUSHENVACC3 4374 C_CALL3 array_set_addr 4376 POP 2 4378 RETURN 1 4380 RESTART 4381 GRAB 1 4383 ACC1 4384 GETFIELD1 4385 PUSHACC0 4386 VECTLENGTH 4387 PUSHACC0 4388 PUSHCONST2 4389 MULINT 4390 OFFSETINT 1 4392 PUSHCONST0 4393 PUSHACC1 4394 C_CALL2 make_vect 4396 PUSHACC0 4397 PUSHACC2 4398 PUSHACC6 4399 CLOSUREREC 3, 4349 4403 CONST0 4404 PUSHACC4 4405 OFFSETINT -1 4407 PUSH 4408 BRANCH 4422 4410 CHECK_SIGNALS 4411 ACC1 4412 PUSHACC7 4413 C_CALL2 array_get_addr 4415 PUSHACC3 4416 APPLY1 4417 ACC1 4418 OFFSETINT 1 4420 ASSIGN 1 4422 ACC0 4423 PUSHACC2 4424 LEINT 4425 BRANCHIF 4410 4427 CONST0 4428 POP 2 4430 ACC1 4431 PUSHACC7 4432 SETFIELD1 4433 ACC6 4434 GETFIELD0 4435 PUSHCONST2 4436 MULINT 4437 PUSHACC7 4438 SETFIELD0 4439 RETURN 7 4441 CONST0 4442 PUSHACC1 4443 GETFIELD1 4444 VECTLENGTH 4445 OFFSETINT -1 4447 PUSH 4448 BRANCH 4462 4450 CHECK_SIGNALS 4451 CONST0 4452 PUSHACC2 4453 PUSHACC4 4454 GETFIELD1 4455 C_CALL3 array_set_addr 4457 ACC1 4458 OFFSETINT 1 4460 ASSIGN 1 4462 ACC0 4463 PUSHACC2 4464 LEINT 4465 BRANCHIF 4450 4467 CONST0 4468 RETURN 3 4470 CONST1 4471 PUSHACC1 4472 LTINT 4473 BRANCHIFNOT 4478 4475 CONST1 4476 BRANCH 4479 4478 ACC0 4479 PUSHGETGLOBALFIELD Sys, 5 4482 PUSHACC1 4483 GTINT 4484 BRANCHIFNOT 4491 4486 GETGLOBALFIELD Sys, 5 4489 BRANCH 4492 4491 ACC0 4492 PUSHCONST0 4493 PUSHACC1 4494 C_CALL2 make_vect 4496 PUSHCONST3 4497 MAKEBLOCK2 0 4499 RETURN 3 4501 ACC0 4502 PUSHCONSTINT 100 4504 PUSHCONSTINT 10 4506 C_CALL3 hash_univ_param 4508 RETURN 1 4510 CLOSURE 0, 4501 4513 PUSH 4514 CLOSURE 0, 4470 4517 PUSH 4518 CLOSURE 0, 4441 4521 PUSH 4522 CLOSURE 0, 4381 4525 PUSH 4526 CLOSUREREC 0, 3631 4530 ACC0 4531 PUSHACC2 4532 PUSHACC6 4533 CLOSURE 3, 4311 4536 PUSHACC5 4537 CLOSURE 1, 4282 4540 PUSHACC6 4541 CLOSURE 1, 4169 4544 PUSHACC7 4545 CLOSURE 1, 4123 4548 PUSHACC 8 4550 CLOSURE 1, 4074 4553 PUSH 4554 CLOSURE 0, 4019 4557 PUSHACC0 4558 PUSHACC7 4559 PUSHACC 9 4561 PUSHACC 11 4563 PUSHACC 13 4565 CLOSURE 5, 3964 4568 PUSHACC 11 4570 PUSHACC1 4571 PUSHACC3 4572 PUSHACC 8 4574 PUSHACC6 4575 PUSHACC 8 4577 PUSHACC 10 4579 PUSHACC 13 4581 PUSHACC 17 4583 PUSHACC 19 4585 MAKEBLOCK 10, 0 4588 POP 12 4590 SETGLOBAL Hashtbl 4592 BRANCH 5073 4594 RESTART 4595 GRAB 2 4597 ACC1 4598 BRANCHIFNOT 4638 4600 ACC1 4601 GETFIELD0 4602 PUSHACC3 4603 BRANCHIFNOT 4635 4605 ACC3 4606 GETFIELD0 4607 PUSHACC0 4608 PUSHACC2 4609 PUSHACC4 4610 APPLY2 4611 BRANCHIFNOT 4624 4613 ACC4 4614 PUSHACC4 4615 GETFIELD1 4616 PUSHACC4 4617 PUSHOFFSETCLOSURE0 4618 APPLY3 4619 PUSHACC2 4620 MAKEBLOCK2 0 4622 RETURN 5 4624 ACC4 4625 GETFIELD1 4626 PUSHACC4 4627 PUSHACC4 4628 PUSHOFFSETCLOSURE0 4629 APPLY3 4630 PUSHACC1 4631 MAKEBLOCK2 0 4633 RETURN 5 4635 ACC2 4636 RETURN 4 4638 ACC2 4639 RETURN 3 4641 RESTART 4642 GRAB 1 4644 CONSTINT 6 4646 PUSHACC1 4647 PUSHACC3 4648 SUBINT 4649 GEINT 4650 BRANCHIFNOT 4809 4652 CONST1 4653 PUSHACC2 4654 PUSHACC2 4655 ADDINT 4656 LSRINT 4657 PUSHACC1 4658 PUSHENVACC3 4659 C_CALL2 array_unsafe_get 4661 PUSHACC1 4662 PUSHENVACC3 4663 C_CALL2 array_unsafe_get 4665 PUSHENVACC2 4666 APPLY2 4667 BRANCHIFNOT 4674 4669 ACC1 4670 PUSHACC1 4671 PUSHENVACC3 4672 PUSHENVACC1 4673 APPLY3 4674 ACC0 4675 PUSHENVACC3 4676 C_CALL2 array_unsafe_get 4678 PUSHACC3 4679 PUSHENVACC3 4680 C_CALL2 array_unsafe_get 4682 PUSHENVACC2 4683 APPLY2 4684 BRANCHIFNOT 4708 4686 ACC2 4687 PUSHACC1 4688 PUSHENVACC3 4689 PUSHENVACC1 4690 APPLY3 4691 ACC1 4692 PUSHENVACC3 4693 C_CALL2 array_unsafe_get 4695 PUSHACC1 4696 PUSHENVACC3 4697 C_CALL2 array_unsafe_get 4699 PUSHENVACC2 4700 APPLY2 4701 BRANCHIFNOT 4708 4703 ACC1 4704 PUSHACC1 4705 PUSHENVACC3 4706 PUSHENVACC1 4707 APPLY3 4708 ACC0 4709 PUSHENVACC3 4710 C_CALL2 array_unsafe_get 4712 PUSHACC2 4713 OFFSETINT 1 4715 PUSHACC4 4716 OFFSETINT -1 4718 PUSH 4719 BRANCH 4777 4721 CHECK_SIGNALS 4722 BRANCH 4730 4724 CHECK_SIGNALS 4725 ACC1 4726 OFFSETINT 1 4728 ASSIGN 1 4730 ACC1 4731 PUSHENVACC3 4732 C_CALL2 array_unsafe_get 4734 PUSHACC3 4735 PUSHENVACC2 4736 APPLY2 4737 BRANCHIFNOT 4724 4739 CONST0 4740 BRANCH 4748 4742 CHECK_SIGNALS 4743 ACC0 4744 OFFSETINT -1 4746 ASSIGN 0 4748 ACC2 4749 PUSHACC1 4750 PUSHENVACC3 4751 C_CALL2 array_unsafe_get 4753 PUSHENVACC2 4754 APPLY2 4755 BRANCHIFNOT 4742 4757 ACC0 4758 PUSHACC2 4759 LTINT 4760 BRANCHIFNOT 4767 4762 ACC0 4763 PUSHACC2 4764 PUSHENVACC3 4765 PUSHENVACC1 4766 APPLY3 4767 ACC1 4768 OFFSETINT 1 4770 ASSIGN 1 4772 ACC0 4773 OFFSETINT -1 4775 ASSIGN 0 4777 ACC0 4778 PUSHACC2 4779 LTINT 4780 BRANCHIF 4721 4782 ACC1 4783 PUSHACC6 4784 SUBINT 4785 PUSHACC5 4786 PUSHACC2 4787 SUBINT 4788 LEINT 4789 BRANCHIFNOT 4800 4791 ACC0 4792 PUSHACC5 4793 PUSHOFFSETCLOSURE0 4794 APPLY2 4795 ACC5 4796 PUSHACC2 4797 PUSHOFFSETCLOSURE0 4798 APPTERM2 8 4800 ACC5 4801 PUSHACC2 4802 PUSHOFFSETCLOSURE0 4803 APPLY2 4804 ACC0 4805 PUSHACC5 4806 PUSHOFFSETCLOSURE0 4807 APPTERM2 8 4809 RETURN 2 4811 RESTART 4812 GRAB 1 4814 ACC1 4815 PUSHACC1 4816 PUSHENVACC1 4817 CLOSUREREC 3, 4642 4821 ACC2 4822 VECTLENGTH 4823 OFFSETINT -1 4825 PUSHCONST0 4826 PUSHACC2 4827 APPLY2 4828 CONST1 4829 PUSHACC3 4830 VECTLENGTH 4831 OFFSETINT -1 4833 PUSH 4834 BRANCH 4918 4836 CHECK_SIGNALS 4837 ACC1 4838 PUSHACC5 4839 C_CALL2 array_unsafe_get 4841 PUSHACC0 4842 PUSHACC3 4843 OFFSETINT -1 4845 PUSHACC7 4846 C_CALL2 array_unsafe_get 4848 PUSHACC6 4849 APPLY2 4850 BOOLNOT 4851 BRANCHIFNOT 4911 4853 ACC2 4854 OFFSETINT -1 4856 PUSHACC6 4857 C_CALL2 array_unsafe_get 4859 PUSHACC3 4860 PUSHACC7 4861 C_CALL3 array_unsafe_set 4863 ACC2 4864 OFFSETINT -1 4866 PUSH 4867 BRANCH 4886 4869 CHECK_SIGNALS 4870 ACC0 4871 OFFSETINT -1 4873 PUSHACC7 4874 C_CALL2 array_unsafe_get 4876 PUSHACC1 4877 PUSHACC 8 4879 C_CALL3 array_unsafe_set 4881 ACC0 4882 OFFSETINT -1 4884 ASSIGN 0 4886 CONST1 4887 PUSHACC1 4888 GEINT 4889 BRANCHIFNOT 4903 4891 ACC1 4892 PUSHACC1 4893 OFFSETINT -1 4895 PUSHACC 8 4897 C_CALL2 array_unsafe_get 4899 PUSHACC7 4900 APPLY2 4901 BRANCHIFNOT 4869 4903 ACC1 4904 PUSHACC1 4905 PUSHACC 8 4907 C_CALL3 array_unsafe_set 4909 POP 1 4911 POP 1 4913 ACC1 4914 OFFSETINT 1 4916 ASSIGN 1 4918 ACC0 4919 PUSHACC2 4920 LEINT 4921 BRANCHIF 4836 4923 CONST0 4924 RETURN 5 4926 RESTART 4927 GRAB 2 4929 ACC1 4930 PUSHACC1 4931 C_CALL2 array_unsafe_get 4933 PUSHACC3 4934 PUSHACC2 4935 C_CALL2 array_unsafe_get 4937 PUSHACC3 4938 PUSHACC3 4939 C_CALL3 array_unsafe_set 4941 ACC0 4942 PUSHACC4 4943 PUSHACC3 4944 C_CALL3 array_unsafe_set 4946 RETURN 4 4948 ACC0 4949 BRANCHIFNOT 4999 4951 ACC0 4952 GETFIELD0 4953 PUSHACC1 4954 GETFIELD1 4955 PUSHACC0 4956 BRANCHIFNOT 4990 4958 ACC0 4959 GETFIELD0 4960 PUSHACC1 4961 GETFIELD1 4962 PUSHOFFSETCLOSURE0 4963 APPLY1 4964 PUSHACC1 4965 PUSHACC4 4966 PUSHENVACC1 4967 APPLY2 4968 BRANCHIFNOT 4979 4970 CONST0 4971 PUSHACC2 4972 MAKEBLOCK2 0 4974 PUSHACC4 4975 MAKEBLOCK2 0 4977 BRANCH 4986 4979 CONST0 4980 PUSHACC4 4981 MAKEBLOCK2 0 4983 PUSHACC2 4984 MAKEBLOCK2 0 4986 MAKEBLOCK2 0 4988 RETURN 4 4990 CONST0 4991 PUSHCONST0 4992 PUSHACC3 4993 MAKEBLOCK2 0 4995 MAKEBLOCK2 0 4997 POP 2 4999 RETURN 1 5001 ACC0 5002 BRANCHIFNOT 5028 5004 ACC0 5005 GETFIELD1 5006 PUSHACC0 5007 BRANCHIFNOT 5024 5009 ACC0 5010 GETFIELD1 5011 PUSHOFFSETCLOSURE0 5012 APPLY1 5013 PUSHACC1 5014 GETFIELD0 5015 PUSHACC3 5016 GETFIELD0 5017 PUSHENVACC2 5018 PUSHENVACC1 5019 APPLY3 5020 MAKEBLOCK2 0 5022 RETURN 2 5024 POP 1 5026 BRANCH 5028 5028 ACC0 5029 RETURN 1 5031 ACC0 5032 BRANCHIFNOT 5040 5034 ACC0 5035 GETFIELD1 5036 BRANCHIF 5042 5038 ACC0 5039 GETFIELD0 5040 RETURN 1 5042 ACC0 5043 PUSHENVACC1 5044 APPLY1 5045 PUSHOFFSETCLOSURE0 5046 APPTERM1 2 5048 RESTART 5049 GRAB 1 5051 ACC0 5052 CLOSUREREC 1, 4948 5056 ACC1 5057 PUSHENVACC1 5058 CLOSUREREC 2, 5001 5062 ACC0 5063 CLOSUREREC 1, 5031 5067 ACC4 5068 PUSHACC3 5069 APPLY1 5070 PUSHACC1 5071 APPTERM1 6 5073 CLOSUREREC 0, 4595 5077 ACC0 5078 CLOSURE 1, 5049 5081 PUSH 5082 CLOSURE 0, 4927 5085 PUSHACC0 5086 CLOSURE 1, 4812 5089 PUSHACC3 5090 PUSHACC1 5091 PUSHACC4 5092 MAKEBLOCK3 0 5094 POP 4 5096 SETGLOBAL Sort 5098 BRANCH 5847 5100 ACC0 5101 PUSHENVACC1 5102 APPLY1 5103 PUSHACC0 5104 GETFIELD 11 5106 PUSHACC1 5107 GETFIELD 10 5109 PUSHACC2 5110 GETFIELD 9 5112 PUSHACC3 5113 GETFIELD 6 5115 PUSHACC4 5116 GETFIELD 8 5118 PUSHACC5 5119 GETFIELD 5 5121 PUSHACC6 5122 GETFIELD 4 5124 PUSHACC7 5125 GETFIELD0 5126 MAKEBLOCK 8, 0 5129 RETURN 2 5131 RESTART 5132 GRAB 2 5134 ACC2 5135 BRANCHIFNOT 5201 5137 ACC2 5138 GETFIELD0 5139 PUSHACC3 5140 GETFIELD1 5141 PUSHACC4 5142 GETFIELD2 5143 PUSHACC5 5144 GETFIELD3 5145 PUSHACC2 5146 PUSHACC5 5147 PUSHENVACC1 5148 GETFIELD0 5149 APPLY2 5150 PUSHCONST0 5151 PUSHACC1 5152 EQ 5153 BRANCHIFNOT 5170 5155 ACC7 5156 GETFIELD 4 5158 PUSHACC2 5159 PUSHACC 8 5161 PUSHACC 8 5163 PUSHACC 8 5165 MAKEBLOCK 5, 0 5168 RETURN 8 5170 CONST0 5171 PUSHACC1 5172 LTINT 5173 BRANCHIFNOT 5189 5175 ACC1 5176 PUSHACC3 5177 PUSHACC5 5178 PUSHACC7 5179 PUSHACC 10 5181 PUSHACC 10 5183 PUSHOFFSETCLOSURE0 5184 APPLY3 5185 PUSHENVACC2 5186 APPTERM 4, 12 5189 ACC1 5190 PUSHACC7 5191 PUSHACC7 5192 PUSHOFFSETCLOSURE0 5193 APPLY3 5194 PUSHACC3 5195 PUSHACC5 5196 PUSHACC7 5197 PUSHENVACC2 5198 APPTERM 4, 12 5201 CONST1 5202 PUSHCONST0 5203 PUSHACC3 5204 PUSHACC3 5205 PUSHCONST0 5206 MAKEBLOCK 5, 0 5209 RETURN 3 5211 RESTART 5212 GRAB 1 5214 ACC1 5215 BRANCHIFNOT 5247 5217 ACC1 5218 GETFIELD1 5219 PUSHACC1 5220 PUSHENVACC1 5221 GETFIELD0 5222 APPLY2 5223 PUSHCONST0 5224 PUSHACC1 5225 EQ 5226 BRANCHIFNOT 5232 5228 ACC2 5229 GETFIELD2 5230 RETURN 3 5232 CONST0 5233 PUSHACC1 5234 LTINT 5235 BRANCHIFNOT 5241 5237 ACC2 5238 GETFIELD0 5239 BRANCH 5243 5241 ACC2 5242 GETFIELD3 5243 PUSHACC2 5244 PUSHOFFSETCLOSURE0 5245 APPTERM2 5 5247 GETGLOBAL Not_found 5249 MAKEBLOCK1 0 5251 RAISE 5252 RESTART 5253 GRAB 1 5255 ACC1 5256 BRANCHIFNOT 5286 5258 ACC1 5259 GETFIELD1 5260 PUSHACC1 5261 PUSHENVACC1 5262 GETFIELD0 5263 APPLY2 5264 PUSHCONST0 5265 PUSHACC1 5266 EQ 5267 BRANCHIF 5284 5269 CONST0 5270 PUSHACC1 5271 LTINT 5272 BRANCHIFNOT 5278 5274 ACC2 5275 GETFIELD0 5276 BRANCH 5280 5278 ACC2 5279 GETFIELD3 5280 PUSHACC2 5281 PUSHOFFSETCLOSURE0 5282 APPTERM2 5 5284 POP 1 5286 RETURN 2 5288 RESTART 5289 GRAB 1 5291 ACC0 5292 BRANCHIF 5297 5294 ACC1 5295 RETURN 2 5297 ACC1 5298 BRANCHIF 5303 5300 ACC0 5301 RETURN 2 5303 ACC0 5304 BRANCHIFNOT 5336 5306 ACC1 5307 BRANCHIFNOT 5336 5309 PUSH_RETADDR 5326 5311 ACC4 5312 GETFIELD3 5313 PUSHACC5 5314 GETFIELD2 5315 PUSHACC6 5316 GETFIELD1 5317 PUSHACC7 5318 GETFIELD0 5319 PUSHACC7 5320 GETFIELD3 5321 PUSHOFFSETCLOSURE0 5322 APPLY2 5323 PUSHENVACC1 5324 APPLY 4 5326 PUSHACC1 5327 GETFIELD2 5328 PUSHACC2 5329 GETFIELD1 5330 PUSHACC3 5331 GETFIELD0 5332 PUSHENVACC1 5333 APPTERM 4, 6 5336 GETGLOBAL <0>("map.ml", 3614, 3797) 5338 PUSHGETGLOBAL Match_failure 5340 MAKEBLOCK2 0 5342 RAISE 5343 RESTART 5344 GRAB 1 5346 ACC1 5347 BRANCHIFNOT 5400 5349 ACC1 5350 GETFIELD0 5351 PUSHACC2 5352 GETFIELD1 5353 PUSHACC3 5354 GETFIELD2 5355 PUSHACC4 5356 GETFIELD3 5357 PUSHACC2 5358 PUSHACC5 5359 PUSHENVACC1 5360 GETFIELD0 5361 APPLY2 5362 PUSHCONST0 5363 PUSHACC1 5364 EQ 5365 BRANCHIFNOT 5372 5367 ACC1 5368 PUSHACC5 5369 PUSHENVACC3 5370 APPTERM2 9 5372 CONST0 5373 PUSHACC1 5374 LTINT 5375 BRANCHIFNOT 5389 5377 ACC1 5378 PUSHACC3 5379 PUSHACC5 5380 PUSHACC7 5381 PUSHACC 9 5383 PUSHOFFSETCLOSURE0 5384 APPLY2 5385 PUSHENVACC2 5386 APPTERM 4, 11 5389 ACC1 5390 PUSHACC6 5391 PUSHOFFSETCLOSURE0 5392 APPLY2 5393 PUSHACC3 5394 PUSHACC5 5395 PUSHACC7 5396 PUSHENVACC2 5397 APPTERM 4, 11 5400 RETURN 2 5402 RESTART 5403 GRAB 1 5405 ACC1 5406 BRANCHIFNOT 5425 5408 ACC1 5409 GETFIELD0 5410 PUSHACC1 5411 PUSHOFFSETCLOSURE0 5412 APPLY2 5413 ACC1 5414 GETFIELD2 5415 PUSHACC2 5416 GETFIELD1 5417 PUSHACC2 5418 APPLY2 5419 ACC1 5420 GETFIELD3 5421 PUSHACC1 5422 PUSHOFFSETCLOSURE0 5423 APPTERM2 4 5425 RETURN 2 5427 RESTART 5428 GRAB 1 5430 ACC1 5431 BRANCHIFNOT 5455 5433 ACC1 5434 GETFIELD 4 5436 PUSHACC2 5437 GETFIELD3 5438 PUSHACC2 5439 PUSHOFFSETCLOSURE0 5440 APPLY2 5441 PUSHACC3 5442 GETFIELD2 5443 PUSHACC3 5444 APPLY1 5445 PUSHACC4 5446 GETFIELD1 5447 PUSHACC5 5448 GETFIELD0 5449 PUSHACC5 5450 PUSHOFFSETCLOSURE0 5451 APPLY2 5452 MAKEBLOCK 5, 0 5455 RETURN 2 5457 RESTART 5458 GRAB 2 5460 ACC1 5461 BRANCHIFNOT 5481 5463 ACC2 5464 PUSHACC2 5465 GETFIELD3 5466 PUSHACC2 5467 PUSHOFFSETCLOSURE0 5468 APPLY3 5469 PUSHACC2 5470 GETFIELD2 5471 PUSHACC3 5472 GETFIELD1 5473 PUSHACC3 5474 APPLY3 5475 PUSHACC2 5476 GETFIELD0 5477 PUSHACC2 5478 PUSHOFFSETCLOSURE0 5479 APPTERM3 6 5481 ACC2 5482 RETURN 3 5484 RESTART 5485 GRAB 3 5487 ACC0 5488 BRANCHIFNOT 5495 5490 ACC0 5491 GETFIELD 4 5493 BRANCH 5496 5495 CONST0 5496 PUSHACC4 5497 BRANCHIFNOT 5504 5499 ACC4 5500 GETFIELD 4 5502 BRANCH 5505 5504 CONST0 5505 PUSHACC0 5506 OFFSETINT 2 5508 PUSHACC2 5509 GTINT 5510 BRANCHIFNOT 5603 5512 ACC2 5513 BRANCHIFNOT 5596 5515 ACC2 5516 GETFIELD0 5517 PUSHACC3 5518 GETFIELD1 5519 PUSHACC4 5520 GETFIELD2 5521 PUSHACC5 5522 GETFIELD3 5523 PUSHACC0 5524 PUSHENVACC1 5525 APPLY1 5526 PUSHACC4 5527 PUSHENVACC1 5528 APPLY1 5529 GEINT 5530 BRANCHIFNOT 5551 5532 PUSH_RETADDR 5544 5534 ACC 12 5536 PUSHACC 12 5538 PUSHACC 12 5540 PUSHACC6 5541 PUSHENVACC2 5542 APPLY 4 5544 PUSHACC2 5545 PUSHACC4 5546 PUSHACC6 5547 PUSHENVACC2 5548 APPTERM 4, 14 5551 ACC0 5552 BRANCHIFNOT 5589 5554 PUSH_RETADDR 5567 5556 ACC 12 5558 PUSHACC 12 5560 PUSHACC 12 5562 PUSHACC6 5563 GETFIELD3 5564 PUSHENVACC2 5565 APPLY 4 5567 PUSHACC1 5568 GETFIELD2 5569 PUSHACC2 5570 GETFIELD1 5571 PUSH 5572 PUSH_RETADDR 5585 5574 ACC6 5575 GETFIELD0 5576 PUSHACC 8 5578 PUSHACC 10 5580 PUSHACC 12 5582 PUSHENVACC2 5583 APPLY 4 5585 PUSHENVACC2 5586 APPTERM 4, 14 5589 GETGLOBAL "Map.bal" 5591 PUSHGETGLOBALFIELD Pervasives, 2 5594 APPTERM1 11 5596 GETGLOBAL "Map.bal" 5598 PUSHGETGLOBALFIELD Pervasives, 2 5601 APPTERM1 7 5603 ACC1 5604 OFFSETINT 2 5606 PUSHACC1 5607 GTINT 5608 BRANCHIFNOT 5703 5610 ACC5 5611 BRANCHIFNOT 5696 5613 ACC5 5614 GETFIELD0 5615 PUSHACC6 5616 GETFIELD1 5617 PUSHACC7 5618 GETFIELD2 5619 PUSHACC 8 5621 GETFIELD3 5622 PUSHACC3 5623 PUSHENVACC1 5624 APPLY1 5625 PUSHACC1 5626 PUSHENVACC1 5627 APPLY1 5628 GEINT 5629 BRANCHIFNOT 5652 5631 ACC0 5632 PUSHACC2 5633 PUSHACC4 5634 PUSH 5635 PUSH_RETADDR 5648 5637 ACC 9 5639 PUSHACC 15 5641 PUSHACC 15 5643 PUSHACC 15 5645 PUSHENVACC2 5646 APPLY 4 5648 PUSHENVACC2 5649 APPTERM 4, 14 5652 ACC3 5653 BRANCHIFNOT 5689 5655 PUSH_RETADDR 5666 5657 ACC3 5658 PUSHACC5 5659 PUSHACC7 5660 PUSHACC 9 5662 GETFIELD3 5663 PUSHENVACC2 5664 APPLY 4 5666 PUSHACC4 5667 GETFIELD2 5668 PUSHACC5 5669 GETFIELD1 5670 PUSH 5671 PUSH_RETADDR 5685 5673 ACC 9 5675 GETFIELD0 5676 PUSHACC 15 5678 PUSHACC 15 5680 PUSHACC 15 5682 PUSHENVACC2 5683 APPLY 4 5685 PUSHENVACC2 5686 APPTERM 4, 14 5689 GETGLOBAL "Map.bal" 5691 PUSHGETGLOBALFIELD Pervasives, 2 5694 APPTERM1 11 5696 GETGLOBAL "Map.bal" 5698 PUSHGETGLOBALFIELD Pervasives, 2 5701 APPTERM1 7 5703 ACC0 5704 PUSHACC2 5705 GEINT 5706 BRANCHIFNOT 5713 5708 ACC1 5709 OFFSETINT 1 5711 BRANCH 5716 5713 ACC0 5714 OFFSETINT 1 5716 PUSHACC6 5717 PUSHACC6 5718 PUSHACC6 5719 PUSHACC6 5720 MAKEBLOCK 5, 0 5723 RETURN 6 5725 RESTART 5726 GRAB 3 5728 ACC0 5729 PUSHENVACC1 5730 APPLY1 5731 PUSHACC4 5732 PUSHENVACC1 5733 APPLY1 5734 PUSHACC0 5735 PUSHACC2 5736 GEINT 5737 BRANCHIFNOT 5744 5739 ACC1 5740 OFFSETINT 1 5742 BRANCH 5747 5744 ACC0 5745 OFFSETINT 1 5747 PUSHACC6 5748 PUSHACC6 5749 PUSHACC6 5750 PUSHACC6 5751 MAKEBLOCK 5, 0 5754 RETURN 6 5756 ACC0 5757 BRANCHIFNOT 5764 5759 ACC0 5760 GETFIELD 4 5762 RETURN 1 5764 CONST0 5765 RETURN 1 5767 CONST0 5768 PUSH 5769 CLOSURE 0, 5756 5772 PUSHACC0 5773 CLOSURE 1, 5726 5776 PUSHACC0 5777 PUSHACC2 5778 CLOSURE 2, 5485 5781 PUSHACC0 5782 PUSHACC5 5783 CLOSUREREC 2, 5132 5787 ACC5 5788 CLOSUREREC 1, 5212 5792 ACC6 5793 CLOSUREREC 1, 5253 5797 ACC3 5798 CLOSUREREC 1, 5289 5802 ACC0 5803 PUSHACC5 5804 PUSHACC 10 5806 CLOSUREREC 3, 5344 5810 CLOSUREREC 0, 5403 5814 CLOSUREREC 0, 5428 5818 CLOSUREREC 0, 5458 5822 ACC0 5823 PUSHACC2 5824 PUSHACC4 5825 PUSHACC6 5826 PUSHACC 8 5828 PUSHACC 10 5830 PUSHACC 12 5832 PUSHACC 14 5834 PUSHACC 16 5836 PUSHACC 18 5838 PUSHACC 20 5840 PUSHACC 22 5842 MAKEBLOCK 12, 0 5845 RETURN 13 5847 CLOSURE 0, 5767 5850 PUSHACC0 5851 CLOSURE 1, 5100 5854 MAKEBLOCK1 0 5856 POP 1 5858 SETGLOBAL Map 5860 BRANCH 5957 5862 CONSTINT 16 5864 C_CALL1 create_string 5866 PUSH 5867 PUSH_RETADDR 5879 5869 CONSTINT 16 5871 PUSHCONST0 5872 PUSHACC5 5873 PUSHACC7 5874 PUSHGETGLOBALFIELD Pervasives, 56 5877 APPLY 4 5879 ACC0 5880 RETURN 2 5882 RESTART 5883 GRAB 1 5885 CONSTINT 16 5887 PUSHCONST0 5888 PUSHACC3 5889 PUSHACC3 5890 PUSHGETGLOBALFIELD Pervasives, 41 5893 APPTERM 4, 6 5896 ACC0 5897 PUSHGETGLOBALFIELD Pervasives, 51 5900 APPLY1 5901 PUSHACC0 5902 PUSHGETGLOBALFIELD Pervasives, 62 5905 APPLY1 5906 PUSHACC1 5907 C_CALL2 md5_chan 5909 PUSHACC1 5910 PUSHGETGLOBALFIELD Pervasives, 63 5913 APPLY1 5914 ACC0 5915 RETURN 3 5917 RESTART 5918 GRAB 2 5920 CONST0 5921 PUSHACC2 5922 LTINT 5923 BRANCHIF 5934 5925 ACC0 5926 C_CALL1 ml_string_length 5928 PUSHACC3 5929 PUSHACC3 5930 ADDINT 5931 GTINT 5932 BRANCHIFNOT 5941 5934 GETGLOBAL "Digest.substring" 5936 PUSHGETGLOBALFIELD Pervasives, 2 5939 APPTERM1 4 5941 ACC2 5942 PUSHACC2 5943 PUSHACC2 5944 C_CALL3 md5_string 5946 RETURN 3 5948 ACC0 5949 C_CALL1 ml_string_length 5951 PUSHCONST0 5952 PUSHACC2 5953 C_CALL3 md5_string 5955 RETURN 1 5957 CLOSURE 0, 5948 5960 PUSH 5961 CLOSURE 0, 5918 5964 PUSH 5965 CLOSURE 0, 5896 5968 PUSH 5969 CLOSURE 0, 5883 5972 PUSH 5973 CLOSURE 0, 5862 5976 PUSHACC0 5977 PUSHACC2 5978 PUSHACC4 5979 PUSHACC6 5980 PUSHACC 8 5982 MAKEBLOCK 5, 0 5985 POP 5 5987 SETGLOBAL Digest 5989 BRANCH 6245 5991 CONST0 5992 PUSHENVACC1 5993 APPLY1 5994 PUSHACC1 5995 PUSHACC1 5996 GEINT 5997 BRANCHIFNOT 6003 5999 ACC1 6000 PUSHOFFSETCLOSURE0 6001 APPTERM1 3 6003 ACC0 6004 RETURN 2 6006 CONST0 6007 C_CALL1 sys_random_seed 6009 PUSHENVACC1 6010 APPTERM1 2 6012 CONSTINT 27182818 6014 PUSHENVACC2 6015 APPLY1 6016 CONST0 6017 PUSHACC1 6018 VECTLENGTH 6019 OFFSETINT -1 6021 PUSH 6022 BRANCH 6046 6024 CHECK_SIGNALS 6025 CONSTINT 55 6027 PUSHACC2 6028 MODINT 6029 PUSHACC2 6030 PUSHACC4 6031 GETVECTITEM 6032 PUSHACC1 6033 PUSHENVACC1 6034 GETVECTITEM 6035 ADDINT 6036 PUSHACC1 6037 PUSHENVACC1 6038 SETVECTITEM 6039 POP 1 6041 ACC1 6042 OFFSETINT 1 6044 ASSIGN 1 6046 ACC0 6047 PUSHACC2 6048 LEINT 6049 BRANCHIF 6024 6051 CONST0 6052 RETURN 3 6054 ENVACC1 6055 GETFIELD0 6056 OFFSETINT 1 6058 PUSHENVACC1 6059 SETFIELD0 6060 ENVACC1 6061 GETFIELD0 6062 PUSHGETGLOBALFIELD Pervasives, 14 6065 APPLY1 6066 PUSHGETGLOBALFIELD Digest, 0 6069 APPLY1 6070 PUSHCONSTINT 22 6072 PUSHCONST3 6073 PUSHACC2 6074 C_CALL2 string_get 6076 LSLINT 6077 PUSHCONSTINT 16 6079 PUSHCONST2 6080 PUSHACC3 6081 C_CALL2 string_get 6083 LSLINT 6084 PUSHCONSTINT 8 6086 PUSHCONST1 6087 PUSHACC4 6088 C_CALL2 string_get 6090 LSLINT 6091 PUSHCONST0 6092 PUSHACC4 6093 C_CALL2 string_get 6095 ADDINT 6096 ADDINT 6097 XORINT 6098 RETURN 2 6100 ACC0 6101 MAKEBLOCK1 0 6103 PUSHACC0 6104 CLOSURE 1, 6054 6107 PUSHCONST0 6108 PUSHCONSTINT 54 6110 PUSH 6111 BRANCH 6125 6113 CHECK_SIGNALS 6114 CONST0 6115 PUSHACC3 6116 APPLY1 6117 PUSHACC2 6118 PUSHENVACC1 6119 SETVECTITEM 6120 ACC1 6121 OFFSETINT 1 6123 ASSIGN 1 6125 ACC0 6126 PUSHACC2 6127 LEINT 6128 BRANCHIF 6113 6130 CONST0 6131 POP 2 6133 CONST0 6134 PUSHENVACC2 6135 SETFIELD0 6136 RETURN 3 6138 ACC0 6139 PUSHCONST0 6140 PUSHENVACC1 6141 APPLY1 6142 C_CALL2 mul_float 6144 RETURN 1 6146 CONSTINT 1073741823 6148 PUSHACC1 6149 GTINT 6150 BRANCHIF 6157 6152 CONST0 6153 PUSHACC1 6154 LEINT 6155 BRANCHIFNOT 6164 6157 GETGLOBAL "Random.int" 6159 PUSHGETGLOBALFIELD Pervasives, 2 6162 APPTERM1 2 6164 ACC0 6165 PUSHACC1 6166 PUSHACC2 6167 PUSHCONSTINT 1073741823 6169 DIVINT 6170 MULINT 6171 PUSHENVACC1 6172 APPLY1 6173 MODINT 6174 RETURN 1 6176 GETGLOBAL 1073741824 6178 PUSHCONST0 6179 PUSHENVACC1 6180 APPLY1 6181 C_CALL1 float_of_int 6183 PUSHCONST0 6184 PUSHENVACC1 6185 APPLY1 6186 C_CALL1 float_of_int 6188 PUSHCONST0 6189 PUSHENVACC1 6190 APPLY1 6191 C_CALL1 float_of_int 6193 PUSHACC3 6194 PUSHACC1 6195 PUSHACC5 6196 PUSHACC4 6197 PUSHACC7 6198 PUSHACC7 6199 C_CALL2 div_float 6201 C_CALL2 add_float 6203 C_CALL2 div_float 6205 C_CALL2 add_float 6207 C_CALL2 div_float 6209 RETURN 5 6211 CONSTINT 55 6213 PUSHENVACC2 6214 GETFIELD0 6215 OFFSETINT 1 6217 MODINT 6218 PUSHENVACC2 6219 SETFIELD0 6220 ENVACC2 6221 GETFIELD0 6222 PUSHENVACC1 6223 GETVECTITEM 6224 PUSHCONSTINT 55 6226 PUSHENVACC2 6227 GETFIELD0 6228 OFFSETINT 24 6230 MODINT 6231 PUSHENVACC1 6232 GETVECTITEM 6233 ADDINT 6234 PUSHACC0 6235 PUSHENVACC2 6236 GETFIELD0 6237 PUSHENVACC1 6238 SETVECTITEM 6239 CONSTINT 1073741823 6241 PUSHACC1 6242 ANDINT 6243 RETURN 2 6245 CONSTINT 440266690 6247 PUSHCONSTINT 124177607 6249 PUSHCONSTINT 414576093 6251 PUSHCONSTINT 180326017 6253 PUSHCONSTINT 33747835 6255 PUSHCONSTINT 896816596 6257 PUSHCONSTINT 21528564 6259 PUSHCONSTINT 414383108 6261 PUSHCONSTINT 514922558 6263 PUSHCONSTINT 979459837 6265 PUSHCONSTINT 146577263 6267 PUSHCONSTINT 714526560 6269 PUSHCONSTINT 187230644 6271 PUSHCONSTINT 22990936 6273 PUSHCONSTINT 310632349 6275 PUSHCONSTINT 781847598 6277 PUSHCONSTINT 854580894 6279 PUSHCONSTINT 804670393 6281 PUSHCONSTINT 268309077 6283 PUSHCONSTINT 4136554 6285 PUSHCONSTINT 567327260 6287 PUSHCONSTINT 768795410 6289 PUSHCONSTINT 868098973 6291 PUSHCONSTINT 462134267 6293 PUSHCONSTINT 32881167 6295 PUSHCONSTINT 708896334 6297 PUSHCONSTINT 572927557 6299 PUSHCONSTINT 933858406 6301 PUSHCONSTINT 965168955 6303 PUSHCONSTINT 233350272 6305 PUSHCONSTINT 878960411 6307 PUSHCONSTINT 971004788 6309 PUSHCONSTINT 762624501 6311 PUSHCONSTINT 796925167 6313 PUSHCONSTINT 206134737 6315 PUSHCONSTINT 281896889 6317 PUSHCONSTINT 814302728 6319 PUSHCONSTINT 477485839 6321 PUSHCONSTINT 998499212 6323 PUSHCONSTINT 473370118 6325 PUSHCONSTINT 66770770 6327 PUSHCONSTINT 337696531 6329 PUSHCONSTINT 848741663 6331 PUSHCONSTINT 71648846 6333 PUSHCONSTINT 869261341 6335 PUSHCONSTINT 951240904 6337 PUSHCONSTINT 147054819 6339 PUSHCONSTINT 486882977 6341 PUSHCONSTINT 552627506 6343 PUSHCONSTINT 615350359 6345 PUSHCONSTINT 1023641486 6347 PUSHCONSTINT 9858203 6349 PUSHCONSTINT 764306064 6351 PUSHCONSTINT 1051173471 6353 PUSHCONSTINT 561073064 6355 MAKEBLOCK 55, 0 6358 PUSHCONST0 6359 MAKEBLOCK1 0 6361 PUSHACC0 6362 PUSHACC2 6363 CLOSURE 2, 6211 6366 PUSHACC0 6367 CLOSURE 1, 6176 6370 PUSHACC1 6371 CLOSUREREC 1, 5991 6375 ACC0 6376 CLOSURE 1, 6146 6379 PUSHACC2 6380 CLOSURE 1, 6138 6383 PUSHACC5 6384 PUSHACC7 6385 CLOSURE 2, 6100 6388 PUSHACC0 6389 PUSHACC 8 6391 CLOSURE 2, 6012 6394 PUSHACC1 6395 CLOSURE 1, 6006 6398 PUSHACC3 6399 PUSHACC5 6400 PUSHACC 9 6402 PUSHACC3 6403 PUSHACC5 6404 PUSHACC7 6405 MAKEBLOCK 6, 0 6408 POP 10 6410 SETGLOBAL Random 6412 BRANCH 8038 6414 RESTART 6415 GRAB 1 6417 ACC1 6418 BRANCHIFNOT 6441 6420 ACC1 6421 GETFIELD0 6422 PUSHACC2 6423 GETFIELD1 6424 PUSHACC1 6425 PUSHACC3 6426 EQ 6427 BRANCHIFNOT 6432 6429 ACC0 6430 RETURN 4 6432 ACC0 6433 PUSHACC3 6434 PUSHOFFSETCLOSURE0 6435 APPLY2 6436 PUSHACC2 6437 MAKEBLOCK2 0 6439 POP 2 6441 RETURN 2 6443 RESTART 6444 GRAB 1 6446 CONST0 6447 PUSHACC2 6448 GTINT 6449 BRANCHIFNOT 6512 6451 CONST0 6452 PUSHENVACC2 6453 GETFIELD0 6454 GTINT 6455 BRANCHIFNOT 6512 6457 ENVACC2 6458 GETFIELD0 6459 PUSHGETGLOBALFIELD Random, 4 6462 APPLY1 6463 PUSHACC0 6464 PUSHENVACC1 6465 GETFIELD0 6466 C_CALL2 array_get_addr 6468 PUSHENVACC 5 6470 APPLY1 6471 BRANCHIF 6482 6473 ACC0 6474 PUSHENVACC 4 6476 APPLY1 6477 ACC2 6478 PUSHACC2 6479 PUSHOFFSETCLOSURE0 6480 APPTERM2 5 6482 PUSHTRAP 6496 6484 ACC5 6485 PUSHACC5 6486 PUSHENVACC1 6487 GETFIELD0 6488 C_CALL2 array_get_addr 6490 PUSHENVACC 7 6492 APPLY2 6493 POPTRAP 6494 RETURN 3 6496 PUSHENVACC 6 6498 PUSHACC1 6499 GETFIELD0 6500 EQ 6501 BRANCHIFNOT 6510 6503 ACC3 6504 OFFSETINT -1 6506 PUSHACC3 6507 PUSHOFFSETCLOSURE0 6508 APPTERM2 6 6510 ACC0 6511 RAISE 6512 ACC0 6513 PUSHENVACC3 6514 APPLY1 6515 ACC0 6516 RETURN 2 6518 RESTART 6519 GRAB 1 6521 ACC1 6522 BRANCHIFNOT 6534 6524 ACC0 6525 PUSHACC2 6526 GETFIELD0 6527 APPLY1 6528 ACC1 6529 GETFIELD1 6530 PUSHACC1 6531 PUSHOFFSETCLOSURE0 6532 APPTERM2 4 6534 RETURN 2 6536 CONST0 6537 PUSHENVACC1 6538 OFFSETINT -1 6540 PUSH 6541 BRANCH 6567 6543 CHECK_SIGNALS 6544 ENVACC2 6545 PUSHACC2 6546 PUSHACC4 6547 C_CALL2 array_get 6549 EQ 6550 BRANCHIFNOT 6556 6552 CONSTINT 46 6554 BRANCH 6558 6556 CONSTINT 42 6558 PUSHGETGLOBALFIELD Pervasives, 20 6561 APPLY1 6562 ACC1 6563 OFFSETINT 1 6565 ASSIGN 1 6567 ACC0 6568 PUSHACC2 6569 LEINT 6570 BRANCHIF 6543 6572 CONST0 6573 POP 2 6575 CONST0 6576 PUSHGETGLOBALFIELD Pervasives, 25 6579 APPTERM1 2 6581 ENVACC3 6582 GETFIELD0 6583 PUSHENVACC 4 6585 APPLY1 6586 PUSHENVACC2 6587 PUSHENVACC1 6588 CLOSURE 2, 6536 6591 PUSHGETGLOBALFIELD List, 9 6594 APPTERM2 3 6596 ACC0 6597 GETFIELD1 6598 RETURN 1 6600 RESTART 6601 GRAB 1 6603 ACC1 6604 GETFIELD0 6605 PUSHACC1 6606 GETFIELD0 6607 LEINT 6608 RETURN 2 6610 ACC0 6611 PUSHACC1 6612 PUSHENVACC1 6613 APPLY1 6614 MAKEBLOCK2 0 6616 RETURN 1 6618 ACC0 6619 PUSHENVACC1 6620 CLOSURE 1, 6610 6623 PUSHGETGLOBALFIELD List, 10 6626 APPLY2 6627 PUSH 6628 CLOSURE 0, 6601 6631 PUSHGETGLOBALFIELD Sort, 0 6634 APPLY2 6635 PUSH 6636 CLOSURE 0, 6596 6639 PUSHGETGLOBALFIELD List, 10 6642 APPTERM2 3 6644 ENVACC3 6645 GETFIELD0 6646 VECTLENGTH 6647 PUSHENVACC 4 6649 GETFIELD0 6650 PUSHCONST0 6651 PUSHENVACC 8 6653 APPLY1 6654 PUSHENVACC2 6655 GETFIELD0 6656 PUSHGETGLOBALFIELD List, 0 6659 APPLY1 6660 PUSHENVACC 7 6662 GETFIELD0 6663 PUSHENVACC 6 6665 GETFIELD0 6666 PUSHENVACC1 6667 GETFIELD0 6668 PUSHENVACC 5 6670 GETFIELD0 6671 MAKEBLOCK 8, 0 6674 RETURN 1 6676 ACC0 6677 PUSHENVACC1 6678 APPLY1 6679 PUSHACC0 6680 OFFSETINT -1 6682 PUSHENVACC2 6683 C_CALL2 array_get_addr 6685 OFFSETINT 1 6687 PUSHACC1 6688 OFFSETINT -1 6690 PUSHENVACC2 6691 C_CALL3 array_set_addr 6693 RETURN 2 6695 CONST0 6696 PUSHCONSTINT 32 6698 C_CALL2 make_vect 6700 PUSHENVACC1 6701 GETFIELD0 6702 PUSHACC1 6703 PUSHENVACC2 6704 CLOSURE 2, 6676 6707 PUSHGETGLOBALFIELD List, 9 6710 APPLY2 6711 ACC0 6712 RETURN 2 6714 RESTART 6715 GRAB 1 6717 ACC1 6718 PUSHENVACC1 6719 APPLY1 6720 PUSHACC1 6721 PUSHACC1 6722 GETFIELD1 6723 PUSHACC2 6724 GETFIELD0 6725 PUSHCONST0 6726 PUSHACC5 6727 C_CALL2 array_get_addr 6729 C_CALL2 array_get_addr 6731 C_CALL2 array_get_addr 6733 APPTERM1 4 6735 ACC0 6736 GETFIELD0 6737 C_CALL1 obj_dup 6739 PUSHENVACC1 6740 PUSHACC1 6741 PUSHENVACC2 6742 APPLY2 6743 ACC1 6744 GETFIELD2 6745 PUSHACC1 6746 PUSHENVACC3 6747 APPLY2 6748 ACC0 6749 RETURN 2 6751 RESTART 6752 GRAB 1 6754 ACC1 6755 GETFIELD 7 6757 PUSHCONST0 6758 PUSHACC1 6759 NEQ 6760 BRANCHIFNOT 6767 6762 ACC0 6763 PUSHACC2 6764 PUSHENVACC1 6765 APPTERM2 5 6767 RETURN 3 6769 ACC0 6770 GETFIELD0 6771 PUSHENVACC1 6772 C_CALL2 obj_block 6774 PUSHACC1 6775 GETFIELD1 6776 PUSHCONST0 6777 PUSHACC2 6778 C_CALL3 array_unsafe_set 6780 ENVACC2 6781 PUSHACC1 6782 PUSHENVACC3 6783 APPLY2 6784 ACC0 6785 RETURN 2 6787 ACC0 6788 GETFIELD0 6789 PUSHENVACC3 6790 GETFIELD0 6791 ADDINT 6792 OFFSETINT -1 6794 PUSHENVACC3 6795 SETFIELD0 6796 ENVACC1 6797 GETFIELD0 6798 BRANCHIFNOT 6804 6800 ACC0 6801 GETFIELD1 6802 PUSHENVACC2 6803 APPLY1 6804 ACC0 6805 GETFIELD 7 6807 PUSHGETGLOBALFIELD List, 4 6810 APPLY1 6811 PUSHACC1 6812 SETFIELD 7 6814 RETURN 1 6816 ACC0 6817 PUSHENVACC1 6818 APPLY1 6819 PUSHENVACC 4 6821 GETFIELD2 6822 PUSHACC1 6823 PUSHACC3 6824 PUSHENVACC2 6825 GETFIELD1 6826 APPLY3 6827 PUSHENVACC 4 6829 SETFIELD2 6830 ENVACC4 6831 GETFIELD3 6832 PUSHCONST1 6833 PUSHACC2 6834 PUSHENVACC3 6835 GETFIELD1 6836 APPLY3 6837 PUSHENVACC 4 6839 SETFIELD3 6840 RETURN 2 6842 CONST0 6843 PUSHENVACC 4 6845 APPLY1 6846 PUSHACC1 6847 PUSHACC1 6848 PUSHENVACC3 6849 PUSHENVACC2 6850 PUSHENVACC1 6851 CLOSURE 4, 6816 6854 PUSHGETGLOBALFIELD List, 9 6857 APPLY2 6858 ACC0 6859 RETURN 2 6861 RESTART 6862 GRAB 1 6864 ACC0 6865 GETFIELD 7 6867 PUSHACC2 6868 MAKEBLOCK2 0 6870 PUSHACC1 6871 SETFIELD 7 6873 RETURN 2 6875 ENVACC1 6876 PUSHENVACC3 6877 PUSH 6878 BRANCH 6895 6880 CHECK_SIGNALS 6881 ACC1 6882 PUSHENVACC2 6883 GETVECTITEM 6884 PUSHENVACC 4 6886 PUSHACC3 6887 ADDINT 6888 PUSHACC4 6889 SETVECTITEM 6890 ACC1 6891 OFFSETINT 1 6893 ASSIGN 1 6895 ACC0 6896 PUSHACC2 6897 LEINT 6898 BRANCHIF 6880 6900 CONST0 6901 RETURN 3 6903 ENVACC2 6904 GETFIELD0 6905 PUSHENVACC2 6906 GETFIELD2 6907 GETFIELD0 6908 OFFSETINT -1 6910 PUSHENVACC3 6911 GETFIELD0 6912 OFFSETINT -1 6914 PUSHACC1 6915 PUSHACC1 6916 SUBINT 6917 PUSHACC0 6918 PUSHACC3 6919 PUSHACC5 6920 PUSHENVACC1 6921 CLOSURE 4, 6875 6924 RETURN 5 6926 RESTART 6927 GRAB 1 6929 CONST0 6930 ACC1 6931 PUSHACC1 6932 PUSHENVACC1 6933 CLOSURE 3, 6903 6936 RETURN 2 6938 RESTART 6939 GRAB 1 6941 ACC0 6942 GETFIELD 6 6944 PUSHACC2 6945 PUSHENVACC1 6946 GETFIELD2 6947 APPTERM2 4 6949 RESTART 6950 GRAB 1 6952 ACC0 6953 PUSHENVACC2 6954 APPLY1 6955 PUSHACC1 6956 GETFIELD 6 6958 PUSHACC1 6959 PUSHACC4 6960 PUSHENVACC1 6961 GETFIELD1 6962 APPLY3 6963 PUSHACC2 6964 SETFIELD 6 6966 ACC0 6967 RETURN 3 6969 ACC0 6970 GETFIELD0 6971 PUSHACC0 6972 OFFSETINT 1 6974 PUSHACC2 6975 SETFIELD0 6976 ACC0 6977 RETURN 2 6979 RESTART 6980 GRAB 1 6982 CONST0 6983 PUSHACC1 6984 PUSHACC3 6985 GETFIELD1 6986 APPTERM2 4 6988 RESTART 6989 GRAB 1 6991 ENVACC1 6992 GETFIELD 4 6994 PUSHACC1 6995 GETFIELD0 6996 PUSHGETGLOBALFIELD List, 23 6999 APPLY2 7000 BRANCHIFNOT 7005 7002 ACC1 7003 RETURN 2 7005 ACC1 7006 PUSHACC1 7007 MAKEBLOCK2 0 7009 RETURN 2 7011 RESTART 7012 GRAB 1 7014 ACC0 7015 PUSHENVACC2 7016 GETFIELD 6 7018 PUSHACC3 7019 PUSHENVACC1 7020 GETFIELD2 7021 APPLY2 7022 PUSHACC3 7023 PUSHENVACC1 7024 GETFIELD1 7025 APPTERM3 5 7027 ACC0 7028 GETFIELD 4 7030 PUSHGETGLOBALFIELD List, 1 7033 APPLY1 7034 PUSHACC1 7035 GETFIELD 4 7037 PUSHGETGLOBALFIELD List, 2 7040 APPLY1 7041 PUSHACC2 7042 SETFIELD 4 7044 ACC0 7045 GETFIELD 5 7047 PUSHACC1 7048 GETFIELD3 7049 PUSHACC3 7050 PUSHENVACC1 7051 CLOSURE 2, 7012 7054 PUSHGETGLOBALFIELD List, 12 7057 APPLY3 7058 PUSHACC2 7059 SETFIELD 6 7061 ACC0 7062 GETFIELD0 7063 PUSHACC2 7064 SETFIELD2 7065 ACC0 7066 GETFIELD1 7067 PUSHACC2 7068 SETFIELD3 7069 ACC0 7070 GETFIELD2 7071 PUSHACC2 7072 GETFIELD 5 7074 PUSHACC2 7075 CLOSURE 1, 6989 7078 PUSHGETGLOBALFIELD List, 13 7081 APPLY3 7082 PUSHACC2 7083 SETFIELD 5 7085 RETURN 2 7087 RESTART 7088 GRAB 1 7090 ENVACC1 7091 PUSHACC1 7092 GETFIELD0 7093 PUSHGETGLOBALFIELD List, 23 7096 APPLY2 7097 BRANCHIFNOT 7102 7099 ACC1 7100 RETURN 2 7102 ACC1 7103 PUSHACC1 7104 MAKEBLOCK2 0 7106 RETURN 2 7108 RESTART 7109 GRAB 1 7111 ENVACC3 7112 GETFIELD0 7113 PUSHACC2 7114 PUSHACC2 7115 PUSHENVACC1 7116 GETFIELD1 7117 APPLY3 7118 PUSHENVACC3 7119 SETFIELD0 7120 ENVACC4 7121 GETFIELD0 7122 PUSHCONST0 7123 PUSHACC3 7124 PUSHENVACC2 7125 GETFIELD1 7126 APPLY3 7127 PUSHENVACC 4 7129 SETFIELD0 7130 RETURN 2 7132 ACC0 7133 PUSHENVACC 4 7135 PUSHENVACC3 7136 APPLY2 7137 PUSHENVACC 5 7139 GETFIELD0 7140 PUSHACC1 7141 PUSHACC3 7142 PUSHENVACC1 7143 GETFIELD1 7144 APPLY3 7145 PUSHENVACC 5 7147 SETFIELD0 7148 ENVACC 6 7150 GETFIELD0 7151 PUSH 7152 PUSHTRAP 7163 7154 ENVACC4 7155 GETFIELD3 7156 PUSHACC6 7157 PUSHENVACC2 7158 GETFIELD2 7159 APPLY2 7160 POPTRAP 7161 BRANCH 7177 7163 PUSHGETGLOBAL Not_found 7165 PUSHACC1 7166 GETFIELD0 7167 EQ 7168 BRANCHIFNOT 7173 7170 CONST1 7171 BRANCH 7175 7173 ACC0 7174 RAISE 7175 POP 1 7177 PUSHACC2 7178 PUSHENVACC2 7179 GETFIELD1 7180 APPLY3 7181 PUSHENVACC 6 7183 SETFIELD0 7184 RETURN 2 7186 RESTART 7187 GRAB 3 7189 ACC2 7190 PUSHACC1 7191 PUSHENVACC 4 7193 APPLY1 7194 PUSHGETGLOBALFIELD List, 10 7197 APPLY2 7198 PUSHACC1 7199 GETFIELD 4 7201 PUSHACC3 7202 PUSHACC2 7203 PUSHACC4 7204 GETFIELD 6 7206 PUSHACC5 7207 GETFIELD 5 7209 PUSHACC6 7210 GETFIELD3 7211 PUSHACC7 7212 GETFIELD2 7213 MAKEBLOCK 6, 0 7216 MAKEBLOCK2 0 7218 PUSHACC2 7219 SETFIELD 4 7221 ENVACC1 7222 GETFIELD0 7223 PUSHACC2 7224 SETFIELD 6 7226 ENVACC2 7227 GETFIELD0 7228 MAKEBLOCK1 0 7230 PUSHENVACC3 7231 GETFIELD0 7232 MAKEBLOCK1 0 7234 PUSHACC6 7235 PUSHACC1 7236 PUSHACC3 7237 PUSHACC6 7238 PUSHENVACC 4 7240 PUSHENVACC3 7241 PUSHENVACC2 7242 CLOSURE 6, 7132 7245 PUSHGETGLOBALFIELD List, 9 7248 APPLY2 7249 ACC2 7250 PUSHACC6 7251 PUSHACC2 7252 PUSHACC4 7253 PUSHENVACC3 7254 PUSHENVACC2 7255 CLOSURE 4, 7109 7258 PUSHGETGLOBALFIELD List, 14 7261 APPLY3 7262 ACC1 7263 GETFIELD0 7264 PUSHACC4 7265 SETFIELD2 7266 ACC0 7267 GETFIELD0 7268 PUSHACC4 7269 SETFIELD3 7270 CONST0 7271 PUSHACC4 7272 GETFIELD 5 7274 PUSHACC4 7275 CLOSURE 1, 7088 7278 PUSHGETGLOBALFIELD List, 13 7281 APPLY3 7282 PUSHACC4 7283 SETFIELD 5 7285 RETURN 7 7287 RESTART 7288 GRAB 1 7290 PUSHTRAP 7303 7292 ACC4 7293 GETFIELD 5 7295 PUSHACC6 7296 PUSHGETGLOBALFIELD List, 29 7299 APPLY2 7300 POPTRAP 7301 RETURN 2 7303 PUSHGETGLOBAL Not_found 7305 PUSHACC1 7306 GETFIELD0 7307 EQ 7308 BRANCHIFNOT 7325 7310 ACC2 7311 PUSHENVACC1 7312 APPLY1 7313 PUSHACC0 7314 GETFIELD1 7315 PUSHACC1 7316 GETFIELD0 7317 PUSHACC4 7318 GETFIELD1 7319 C_CALL2 array_get_addr 7321 C_CALL2 array_get 7323 RETURN 4 7325 ACC0 7326 RAISE 7327 RESTART 7328 GRAB 2 7330 ENVACC3 7331 OFFSETREF 1 7333 ACC0 7334 GETFIELD3 7335 PUSHACC2 7336 PUSHENVACC1 7337 GETFIELD2 7338 APPLY2 7339 BRANCHIFNOT 7347 7341 ACC2 7342 PUSHACC2 7343 PUSHACC2 7344 PUSHENVACC2 7345 APPTERM3 6 7347 ACC0 7348 GETFIELD 5 7350 PUSHACC3 7351 PUSHACC3 7352 MAKEBLOCK2 0 7354 MAKEBLOCK2 0 7356 PUSHACC1 7357 SETFIELD 5 7359 RETURN 3 7361 RESTART 7362 GRAB 1 7364 PUSHTRAP 7375 7366 ACC4 7367 GETFIELD2 7368 PUSHACC6 7369 PUSHENVACC2 7370 GETFIELD2 7371 APPLY2 7372 POPTRAP 7373 RETURN 2 7375 PUSHGETGLOBAL Not_found 7377 PUSHACC1 7378 GETFIELD0 7379 EQ 7380 BRANCHIFNOT 7406 7382 CONST0 7383 PUSHENVACC1 7384 APPLY1 7385 PUSHACC2 7386 GETFIELD2 7387 PUSHACC1 7388 PUSHACC5 7389 PUSHENVACC2 7390 GETFIELD1 7391 APPLY3 7392 PUSHACC3 7393 SETFIELD2 7394 ACC2 7395 GETFIELD3 7396 PUSHCONST1 7397 PUSHACC2 7398 PUSHENVACC3 7399 GETFIELD1 7400 APPLY3 7401 PUSHACC3 7402 SETFIELD3 7403 ACC0 7404 RETURN 4 7406 ACC0 7407 RAISE 7408 RESTART 7409 GRAB 2 7411 ACC1 7412 PUSHENVACC1 7413 APPLY1 7414 PUSHACC0 7415 GETFIELD0 7416 PUSHACC0 7417 OFFSETINT 1 7419 PUSHACC3 7420 PUSHENVACC 4 7422 APPLY2 7423 ACC0 7424 PUSHACC3 7425 GETFIELD1 7426 C_CALL2 array_get_addr 7428 PUSHENVACC2 7429 PUSHACC1 7430 EQ 7431 BRANCHIFNOT 7444 7433 CONST0 7434 PUSHENVACC3 7435 APPLY1 7436 ASSIGN 0 7438 ACC0 7439 PUSHACC2 7440 PUSHACC5 7441 GETFIELD1 7442 C_CALL3 array_set_addr 7444 ACC5 7445 PUSHACC3 7446 GETFIELD1 7447 PUSHACC2 7448 C_CALL3 array_set 7450 RETURN 6 7452 RESTART 7453 GRAB 1 7455 ACC0 7456 GETFIELD1 7457 VECTLENGTH 7458 PUSHACC0 7459 PUSHACC3 7460 GTINT 7461 BRANCHIFNOT 7487 7463 ENVACC1 7464 PUSHACC3 7465 C_CALL2 make_vect 7467 PUSH 7468 PUSH_RETADDR 7482 7470 ACC4 7471 PUSHCONST0 7472 PUSHACC5 7473 PUSHCONST0 7474 PUSHACC 9 7476 GETFIELD1 7477 PUSHGETGLOBALFIELD Array, 8 7480 APPLY 5 7482 ACC0 7483 PUSHACC3 7484 SETFIELD1 7485 POP 1 7487 RETURN 3 7489 ENVACC 5 7491 OFFSETREF 1 7493 CONST0 7494 PUSHENVACC2 7495 GETFIELD0 7496 PUSHCONST0 7497 PUSHCONST0 7498 PUSHENVACC 4 7500 GETFIELD0 7501 PUSHENVACC3 7502 GETFIELD0 7503 PUSH 7504 ATOM0 7505 PUSHENVACC1 7506 MAKEBLOCK 8, 0 7509 RETURN 1 7511 RESTART 7512 GRAB 1 7514 ACC1 7515 PUSHACC1 7516 C_CALL2 compare 7518 RETURN 2 7520 RESTART 7521 GRAB 1 7523 ACC1 7524 PUSHACC1 7525 C_CALL2 compare 7527 RETURN 2 7529 RESTART 7530 GRAB 1 7532 ACC1 7533 PUSHACC1 7534 C_CALL2 compare 7536 RETURN 2 7538 PUSHTRAP 7549 7540 ACC4 7541 PUSHENVACC1 7542 PUSHGETGLOBALFIELD Hashtbl, 3 7545 APPLY2 7546 POPTRAP 7547 RETURN 1 7549 PUSHGETGLOBAL Not_found 7551 PUSHACC1 7552 GETFIELD0 7553 EQ 7554 BRANCHIFNOT 7569 7556 CONST0 7557 PUSHENVACC2 7558 APPLY1 7559 PUSHACC0 7560 PUSHACC3 7561 PUSHENVACC1 7562 PUSHGETGLOBALFIELD Hashtbl, 2 7565 APPLY3 7566 ACC0 7567 RETURN 3 7569 ACC0 7570 RAISE 7571 ENVACC2 7572 GETFIELD0 7573 PUSHENVACC2 7574 GETFIELD0 7575 PUSHENVACC1 7576 APPLY1 7577 PUSHENVACC2 7578 SETFIELD0 7579 ACC0 7580 RETURN 2 7582 ENVACC1 7583 PUSHACC1 7584 VECTLENGTH 7585 OFFSETINT -1 7587 PUSH 7588 BRANCH 7606 7590 CHECK_SIGNALS 7591 ACC1 7592 PUSHACC3 7593 C_CALL2 array_get_addr 7595 PUSHENVACC2 7596 APPLY1 7597 PUSHACC2 7598 PUSHACC4 7599 C_CALL3 array_set_addr 7601 ACC1 7602 OFFSETINT 1 7604 ASSIGN 1 7606 ACC0 7607 PUSHACC2 7608 LEINT 7609 BRANCHIF 7590 7611 CONST0 7612 RETURN 3 7614 ENVACC4 7615 PUSHACC1 7616 NEQ 7617 BRANCHIFNOT 7640 7619 ENVACC2 7620 GETFIELD0 7621 PUSHACC1 7622 PUSHENVACC3 7623 APPLY1 7624 EQ 7625 BRANCHIFNOT 7640 7627 ACC0 7628 PUSHENVACC 5 7630 APPLY1 7631 BRANCHIFNOT 7640 7633 ENVACC1 7634 GETFIELD3 7635 PUSHACC1 7636 PUSHENVACC 6 7638 APPTERM2 3 7640 ACC0 7641 RETURN 1 7643 RESTART 7644 GRAB 1 7646 CONST0 7647 PUSHENVACC1 7648 OFFSETINT -1 7650 PUSH 7651 BRANCH 7690 7653 CHECK_SIGNALS 7654 ENVACC2 7655 PUSHACC2 7656 PUSHACC5 7657 C_CALL2 array_get 7659 NEQ 7660 BRANCHIFNOT 7679 7662 ENVACC2 7663 PUSHACC2 7664 PUSHACC4 7665 C_CALL2 array_get 7667 NEQ 7668 BRANCHIFNOT 7679 7670 ACC1 7671 PUSHACC3 7672 C_CALL2 array_get 7674 PUSHACC2 7675 PUSHACC5 7676 C_CALL2 array_get 7678 NEQ 7679 BRANCHIFNOT 7685 7681 ENVACC4 7682 MAKEBLOCK1 0 7684 RAISE 7685 ACC1 7686 OFFSETINT 1 7688 ASSIGN 1 7690 ACC0 7691 PUSHACC2 7692 LEINT 7693 BRANCHIF 7653 7695 CONST0 7696 POP 2 7698 CONST0 7699 PUSHENVACC1 7700 OFFSETINT -1 7702 PUSH 7703 BRANCH 7727 7705 CHECK_SIGNALS 7706 ENVACC2 7707 PUSHACC2 7708 PUSHACC5 7709 C_CALL2 array_get 7711 NEQ 7712 BRANCHIFNOT 7722 7714 ACC1 7715 PUSHACC4 7716 C_CALL2 array_get 7718 PUSHACC2 7719 PUSHACC4 7720 C_CALL3 array_set 7722 ACC1 7723 OFFSETINT 1 7725 ASSIGN 1 7727 ACC0 7728 PUSHACC2 7729 LEINT 7730 BRANCHIF 7705 7732 CONST0 7733 POP 2 7735 ENVACC3 7736 GETFIELD0 7737 PUSHACC2 7738 PUSHENVACC 5 7740 APPLY2 7741 PUSHENVACC3 7742 SETFIELD0 7743 ACC0 7744 RETURN 2 7746 ENVACC1 7747 GETFIELD 4 7749 PUSHACC1 7750 PUSHENVACC2 7751 APPLY1 7752 LEINT 7753 RETURN 1 7755 CONST0 7756 PUSHCONST0 7757 PUSHENVACC1 7758 OFFSETINT -1 7760 PUSH 7761 BRANCH 7782 7763 CHECK_SIGNALS 7764 ENVACC2 7765 PUSHACC2 7766 PUSHACC5 7767 C_CALL2 array_get 7769 NEQ 7770 BRANCHIFNOT 7777 7772 ACC2 7773 OFFSETINT 1 7775 ASSIGN 2 7777 ACC1 7778 OFFSETINT 1 7780 ASSIGN 1 7782 ACC0 7783 PUSHACC2 7784 LEINT 7785 BRANCHIF 7763 7787 CONST0 7788 POP 2 7790 ACC0 7791 RETURN 2 7793 ENVACC2 7794 GETFIELD0 7795 OFFSETINT -1 7797 PUSHENVACC1 7798 GETFIELD0 7799 C_CALL2 array_get_addr 7801 PUSHACC1 7802 PUSHENVACC1 7803 GETFIELD0 7804 C_CALL3 array_set_addr 7806 ENVACC2 7807 OFFSETREF -1 7809 RETURN 1 7811 ENVACC1 7812 GETFIELD0 7813 VECTLENGTH 7814 PUSHACC0 7815 PUSHENVACC2 7816 GETFIELD0 7817 GEINT 7818 BRANCHIFNOT 7845 7820 ATOM0 7821 PUSHACC1 7822 PUSHCONST2 7823 MULINT 7824 C_CALL2 make_vect 7826 PUSH 7827 PUSH_RETADDR 7840 7829 ACC4 7830 PUSHCONST0 7831 PUSHACC5 7832 PUSHCONST0 7833 PUSHENVACC1 7834 GETFIELD0 7835 PUSHGETGLOBALFIELD Array, 8 7838 APPLY 5 7840 ACC0 7841 PUSHENVACC1 7842 SETFIELD0 7843 POP 1 7845 ACC1 7846 PUSHENVACC2 7847 GETFIELD0 7848 PUSHENVACC1 7849 GETFIELD0 7850 C_CALL3 array_set_addr 7852 ENVACC2 7853 OFFSETREF 1 7855 RETURN 2 7857 ACC0 7858 GETFIELD0 7859 PUSHENVACC1 7860 APPLY1 7861 PUSHENVACC2 7862 PUSHACC1 7863 GETFIELD0 7864 EQ 7865 BRANCHIFNOT 7874 7867 ACC1 7868 GETFIELD1 7869 PUSHACC1 7870 GETFIELD1 7871 PUSHENVACC3 7872 C_CALL3 array_set 7874 RETURN 2 7876 RESTART 7877 GRAB 1 7879 CONST0 7880 PUSHENVACC2 7881 APPLY1 7882 PUSHACC2 7883 PUSHGETGLOBALFIELD List, 4 7886 APPLY1 7887 PUSHACC1 7888 PUSHACC3 7889 PUSHENVACC1 7890 CLOSURE 3, 7857 7893 PUSHGETGLOBALFIELD List, 9 7896 APPLY2 7897 ACC0 7898 RETURN 3 7900 ACC0 7901 PUSHGETGLOBALFIELD Array, 6 7904 APPLY1 7905 PUSHACC0 7906 PUSHENVACC3 7907 APPLY1 7908 ENVACC2 7909 GETFIELD0 7910 PUSHENVACC1 7911 PUSHACC2 7912 C_CALL3 array_set 7914 ENVACC4 7915 GETFIELD0 7916 PUSHACC1 7917 MAKEBLOCK2 0 7919 PUSHENVACC 4 7921 SETFIELD0 7922 ACC0 7923 RETURN 2 7925 ENVACC2 7926 PUSHENVACC1 7927 OFFSETINT 1 7929 C_CALL2 make_vect 7931 PUSHACC0 7932 PUSHENVACC3 7933 APPLY1 7934 ENVACC4 7935 GETFIELD0 7936 PUSHACC1 7937 MAKEBLOCK2 0 7939 PUSHENVACC 4 7941 SETFIELD0 7942 ACC0 7943 RETURN 2 7945 ENVACC1 7946 PUSHACC1 7947 C_CALL2 array_get 7949 RETURN 1 7951 ENVACC2 7952 GETFIELD0 7953 PUSHENVACC1 7954 PUSHACC2 7955 C_CALL3 array_set 7957 RETURN 1 7959 ENVACC1 7960 PUSHENVACC2 7961 PUSHENVACC1 7962 MULINT 7963 PUSHACC2 7964 MODINT 7965 DIVINT 7966 PUSHENVACC1 7967 PUSHCONSTINT 65536 7969 PUSHACC3 7970 DIVINT 7971 DIVINT 7972 MAKEBLOCK2 0 7974 RETURN 1 7976 ENVACC3 7977 OFFSETREF 1 7979 ENVACC1 7980 PUSHACC1 7981 ADDINT 7982 PUSHCONST0 7983 PUSHENVACC2 7984 PUSHENVACC1 7985 MULINT 7986 PUSHACC2 7987 MODINT 7988 EQ 7989 BRANCHIFNOT 8001 7991 ENVACC2 7992 PUSHCONSTINT 65536 7994 SUBINT 7995 PUSHENVACC1 7996 MULINT 7997 PUSHACC1 7998 ADDINT 7999 RETURN 2 8001 ACC0 8002 RETURN 2 8004 ACC0 8005 C_CALL1 obj_dup 8007 PUSHENVACC1 8008 PUSHACC1 8009 PUSHENVACC2 8010 APPLY2 8011 ACC0 8012 RETURN 2 8014 RESTART 8015 GRAB 1 8017 ACC1 8018 GETFIELD0 8019 PUSHACC0 8020 PUSHCONST1 8021 PUSHACC3 8022 SETVECTITEM 8023 ACC0 8024 OFFSETINT 1 8026 PUSHACC3 8027 SETFIELD0 8028 RETURN 3 8030 ENVACC1 8031 GETFIELD0 8032 PUSHENVACC1 8033 OFFSETREF 1 8035 ACC0 8036 RETURN 2 8038 CONSTINT 248 8040 PUSHCONST0 8041 MAKEBLOCK1 0 8043 PUSHACC0 8044 CLOSURE 1, 8030 8047 PUSH 8048 CLOSURE 0, 8015 8051 PUSHACC0 8052 PUSHACC3 8053 CLOSURE 2, 8004 8056 PUSHCONSTINT 16 8058 PUSHCONST3 8059 PUSHCONST1 8060 PUSHCONST1 8061 PUSHCONST1 8062 MAKEBLOCK 5, 0 8065 PUSHCONSTINT 16 8067 PUSHGETGLOBALFIELD Sys, 3 8070 DIVINT 8071 PUSHCONST0 8072 PUSHCONSTINT 32 8074 PUSHCONST2 8075 PUSHCONST0 8076 MAKEBLOCK1 0 8078 PUSHACC0 8079 PUSHACC3 8080 PUSHACC6 8081 CLOSURE 3, 7976 8084 PUSHACC3 8085 PUSHACC6 8086 CLOSURE 2, 7959 8089 PUSHCONST0 8090 PUSHCONST0 8091 MAKEBLOCK1 0 8093 PUSHACC0 8094 PUSHACC7 8095 CLOSURE 2, 7951 8098 PUSHACC7 8099 CLOSURE 1, 7945 8102 PUSHCONST0 8103 MAKEBLOCK1 0 8105 PUSH 8106 ATOM0 8107 PUSHACC1 8108 PUSHACC4 8109 PUSHACC7 8110 PUSHACC 13 8112 CLOSURE 4, 7925 8115 PUSHACC2 8116 PUSHACC5 8117 PUSHACC7 8118 PUSHACC 14 8120 CLOSURE 4, 7900 8123 PUSHACC1 8124 PUSHACC 9 8126 CLOSURE 2, 7877 8129 PUSH 8130 ATOM0 8131 PUSHCONSTINT 10 8133 C_CALL2 make_vect 8135 MAKEBLOCK1 0 8137 PUSHCONST0 8138 MAKEBLOCK1 0 8140 PUSHACC0 8141 PUSHACC2 8142 CLOSURE 2, 7811 8145 PUSHACC1 8146 PUSHACC3 8147 CLOSURE 2, 7793 8150 PUSHACC 12 8152 PUSHACC 18 8154 CLOSURE 2, 7755 8157 PUSHACC0 8158 PUSHACC 22 8160 CLOSURE 2, 7746 8163 PUSHGETGLOBAL "Oo.Failed" 8165 MAKEBLOCK1 0 8167 PUSH 8168 CLOSUREREC 0, 6415 8172 ACC0 8173 PUSHACC2 8174 PUSHACC 14 8176 PUSHACC 19 8178 PUSHACC 25 8180 CLOSURE 5, 7644 8183 PUSHACC0 8184 PUSHACC3 8185 PUSHACC5 8186 PUSHACC 8 8188 PUSHACC 10 8190 PUSHACC 12 8192 PUSHACC 14 8194 CLOSUREREC 7, 6444 8198 ACC0 8199 PUSHACC5 8200 PUSHACC 15 8202 PUSHACC 18 8204 PUSHACC 21 8206 PUSHACC 31 8208 CLOSURE 6, 7614 8211 PUSHACC0 8212 PUSHACC 26 8214 CLOSURE 2, 7582 8217 PUSHACC 27 8219 PUSHCONSTINT 65536 8221 PUSHACC 28 8223 MULINT 8224 MULINT 8225 PUSHACC0 8226 MAKEBLOCK1 0 8228 PUSHCONSTINT 101 8230 PUSHGETGLOBALFIELD Hashtbl, 0 8233 APPLY1 8234 PUSHACC1 8235 PUSHACC 26 8237 CLOSURE 2, 7571 8240 PUSHACC0 8241 PUSHACC2 8242 CLOSURE 2, 7538 8245 PUSH 8246 CLOSURE 0, 7530 8249 PUSHACC0 8250 MAKEBLOCK1 0 8252 POP 1 8254 PUSHGETGLOBALFIELD Map, 0 8257 APPLY1 8258 PUSH 8259 CLOSURE 0, 7521 8262 PUSHACC0 8263 MAKEBLOCK1 0 8265 POP 1 8267 PUSHGETGLOBALFIELD Map, 0 8270 APPLY1 8271 PUSH 8272 CLOSURE 0, 7512 8275 PUSHACC0 8276 MAKEBLOCK1 0 8278 POP 1 8280 PUSHGETGLOBALFIELD Map, 0 8283 APPLY1 8284 PUSHCONST0 8285 MAKEBLOCK1 0 8287 PUSHACC0 8288 PUSHACC2 8289 PUSHACC4 8290 PUSHACC6 8291 PUSHACC 37 8293 CLOSURE 5, 7489 8296 PUSHACC 25 8298 CLOSURE 1, 7453 8301 PUSHACC0 8302 PUSHACC 26 8304 PUSHACC 28 8306 PUSHACC 35 8308 CLOSURE 4, 7409 8311 PUSHCONST0 8312 MAKEBLOCK1 0 8314 PUSHCONST0 8315 MAKEBLOCK1 0 8317 PUSHACC6 8318 PUSHACC 8 8320 PUSHACC 12 8322 CLOSURE 3, 7362 8325 PUSHACC2 8326 PUSHACC4 8327 PUSHACC 9 8329 CLOSURE 3, 7328 8332 PUSHACC 37 8334 CLOSURE 1, 7288 8337 PUSHACC2 8338 PUSHACC 10 8340 PUSHACC 12 8342 PUSHACC 14 8344 CLOSURE 4, 7187 8347 PUSHACC 12 8349 CLOSURE 1, 7027 8352 PUSH 8353 CLOSURE 0, 6980 8356 PUSH 8357 CLOSURE 0, 6969 8360 PUSHACC0 8361 PUSHACC 16 8363 CLOSURE 2, 6950 8366 PUSHACC 16 8368 CLOSURE 1, 6939 8371 PUSHACC 47 8373 CLOSURE 1, 6927 8376 PUSH 8377 CLOSURE 0, 6862 8380 PUSHACC 15 8382 PUSHACC 18 8384 PUSHACC 20 8386 PUSHACC 23 8388 CLOSURE 4, 6842 8391 PUSHACC 12 8393 PUSHACC 27 8395 PUSHACC 56 8397 CLOSURE 3, 6787 8400 PUSHACC 57 8402 PUSHACC 60 8404 PUSHACC 62 8406 CLOSURE 3, 6769 8409 PUSH 8410 CLOSUREREC 0, 6519 8414 ACC0 8415 CLOSURE 1, 6752 8418 PUSHACC0 8419 PUSHACC 61 8421 PUSHACC 64 8423 CLOSURE 3, 6735 8426 PUSHACC 52 8428 CLOSURE 1, 6715 8431 PUSHACC 39 8433 PUSHACC 49 8435 CLOSURE 2, 6695 8438 PUSHACC0 8439 PUSHACC 20 8441 PUSHACC 22 8443 PUSHACC 27 8445 PUSHACC 47 8447 PUSHACC 49 8449 PUSHACC 55 8451 PUSHACC 63 8453 CLOSURE 8, 6644 8456 PUSHACC 41 8458 CLOSURE 1, 6618 8461 PUSHACC0 8462 PUSHACC 52 8464 PUSHACC 57 8466 PUSHACC 63 8468 CLOSURE 4, 6581 8471 PUSHACC0 8472 PUSHACC3 8473 PUSHACC 66 8475 PUSHACC7 8476 PUSHACC 9 8478 PUSHACC 11 8480 PUSHACC 14 8482 PUSHACC 16 8484 PUSHACC 18 8486 PUSHACC 20 8488 PUSHACC 27 8490 PUSHACC 29 8492 PUSHACC 32 8494 PUSHACC 32 8496 PUSHACC 35 8498 PUSHACC 27 8500 PUSHACC 29 8502 PUSHACC 31 8504 PUSHACC 34 8506 PUSHACC 50 8508 PUSHACC 85 8510 MAKEBLOCK 21, 0 8513 POP 70 8515 SETGLOBAL Oo 8517 BRANCH 8568 8519 ACC0 8520 BRANCHIFNOT 8525 8522 ACC0 8523 BRANCH 8530 8525 ENVACC1 8526 PUSHGETGLOBALFIELD Oo, 14 8529 APPLY1 8530 PUSHCONST0 8531 ACC1 8532 BRANCHIFNOT 8537 8534 CONST0 8535 BRANCH 8543 8537 ENVACC1 8538 PUSHACC1 8539 PUSHGETGLOBALFIELD Oo, 15 8542 APPLY2 8543 ACC0 8544 RETURN 2 8546 CONSTINT 23 8548 RETURN 1 8550 CLOSURE 0, 8546 8553 PUSHACC0 8554 POP 1 8556 PUSHENVACC1 8557 PUSHACC2 8558 PUSHGETGLOBALFIELD Oo, 8 8561 APPLY3 8562 ACC0 8563 CLOSURE 1, 8519 8566 RETURN 1 8568 GETGLOBALFIELD Oo, 1 8571 PUSHGETGLOBAL "m" 8573 PUSHACC1 8574 APPLY1 8575 PUSHCONST3 8576 C_CALL1 alloc_dummy 8578 PUSHGETGLOBAL <0>("m", 0) 8580 PUSHGETGLOBALFIELD Oo, 12 8583 APPLY1 8584 PUSHACC2 8585 CLOSURE 1, 8550 8588 PUSHACC1 8589 PUSHACC1 8590 APPLY1 8591 PUSHACC2 8592 PUSHGETGLOBALFIELD Oo, 13 8595 APPLY1 8596 ACC2 8597 PUSHACC2 8598 PUSHACC2 8599 MAKEBLOCK3 0 8601 POP 3 8603 PUSHACC1 8604 C_CALL2 update_dummy 8606 CONST0 8607 PUSHACC1 8608 GETFIELD0 8609 APPLY1 8610 PUSHCONSTINT 23 8612 PUSHACC1 8613 PUSHACC4 8614 GETMETHOD 8615 APPLY1 8616 NEQ 8617 BRANCHIFNOT 8624 8619 GETGLOBAL Not_found 8621 MAKEBLOCK1 0 8623 RAISE 8624 POP 1 8626 ACC0 8627 MAKEBLOCK1 0 8629 POP 3 8631 SETGLOBAL T300-getmethod 8633 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-divint-1.ml0000644000175000017500000000062212124403241023367 0ustar tootstootsopen Lib;; if 2 / 2 <> 1 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONST2 11 PUSHCONST2 12 DIVINT 13 NEQ 14 BRANCHIFNOT 21 16 GETGLOBAL Not_found 18 MAKEBLOCK1 0 20 RAISE 21 ATOM0 22 SETGLOBAL T110-divint-1 24 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t092-pushacc4.ml0000644000175000017500000000101012124403241023447 0ustar tootstootsopen Lib;; let x = false in let y = true in let z = true in let a = true in let b = true in if x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST1 11 PUSHCONST1 12 PUSHCONST1 13 PUSHCONST1 14 PUSHACC4 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 POP 5 24 ATOM0 25 SETGLOBAL T092-pushacc4 27 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t171-envacc.ml0000644000175000017500000000167412124403241023212 0ustar tootstootsopen Lib;; let x = 5 in let y = 2 in let z = 1 in let a = 4 in let b = 3 in let f _ = ignore x; ignore y; ignore z; ignore a; b in if f 0 <> 3 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 23 11 ENVACC1 12 CONST0 13 ENVACC2 14 CONST0 15 ENVACC3 16 CONST0 17 ENVACC4 18 CONST0 19 ENVACC 5 21 RETURN 1 23 CONSTINT 5 25 PUSHCONST2 26 PUSHCONST1 27 PUSHCONSTINT 4 29 PUSHCONST3 30 PUSHACC0 31 PUSHACC2 32 PUSHACC4 33 PUSHACC6 34 PUSHACC 8 36 CLOSURE 5, 11 39 PUSHCONST3 40 PUSHCONST0 41 PUSHACC2 42 APPLY1 43 NEQ 44 BRANCHIFNOT 51 46 GETGLOBAL Not_found 48 MAKEBLOCK1 0 50 RAISE 51 POP 6 53 ATOM0 54 SETGLOBAL T171-envacc 56 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t070-branch.ml0000644000175000017500000000055412124403241023202 0ustar tootstootsopen Lib;; if true then 0 else raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 BRANCHIFNOT 15 12 CONST0 13 BRANCH 20 15 GETGLOBAL Not_found 17 MAKEBLOCK1 0 19 RAISE 20 ATOM0 21 SETGLOBAL T070-branch 23 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t080-gtint.ml0000644000175000017500000000054612124403241023074 0ustar tootstootsopen Lib;; if 0 > 0 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST0 11 GTINT 12 BRANCHIFNOT 19 14 GETGLOBAL Not_found 16 MAKEBLOCK1 0 18 RAISE 19 ATOM0 20 SETGLOBAL T080-gtint 22 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t090-acc1.ml0000644000175000017500000000070012124403241022547 0ustar tootstootsopen Lib;; let x = true in let y = false in (); if not x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONST0 11 PUSHCONST0 12 ACC1 13 BOOLNOT 14 BRANCHIFNOT 21 16 GETGLOBAL Not_found 18 MAKEBLOCK1 0 20 RAISE 21 POP 2 23 ATOM0 24 SETGLOBAL T090-acc1 26 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t260-offsetref.ml0000644000175000017500000000102012124403241023716 0ustar tootstootsopen Lib;; let x = ref 32 in incr x; if !x <> 33 then raise Not_found; x ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 32 11 MAKEBLOCK1 0 13 PUSHACC0 14 OFFSETREF 1 16 CONSTINT 33 18 PUSHACC1 19 GETFIELD0 20 NEQ 21 BRANCHIFNOT 28 23 GETGLOBAL Not_found 25 MAKEBLOCK1 0 27 RAISE 28 ACC0 29 POP 1 31 ATOM0 32 SETGLOBAL T260-offsetref 34 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t010-const2.ml0000644000175000017500000000013412124403241023141 0ustar tootstoots2;; (** 0 CONST2 1 ATOM0 2 SETGLOBAL T010-const2 4 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t131-setvectitem.ml0000644000175000017500000000113112124403241024267 0ustar tootstootsopen Lib;; let x = [| 1; 2 |] in x.(0) <- 3; if x.(0) <> 3 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST2 10 PUSHCONST1 11 MAKEBLOCK2 0 13 PUSHCONST3 14 PUSHCONST0 15 PUSHACC2 16 SETVECTITEM 17 CONST3 18 PUSHCONST0 19 PUSHACC2 20 GETVECTITEM 21 NEQ 22 BRANCHIFNOT 29 24 GETGLOBAL Not_found 26 MAKEBLOCK1 0 28 RAISE 29 POP 1 31 ATOM0 32 SETGLOBAL T131-setvectitem 34 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t180-appterm3.ml0000644000175000017500000000132212124403241023474 0ustar tootstootsopen Lib;; let f _ _ _ = 13 in let g _ = f 0 0 0 in if g 0 <> 13 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 24 11 CONST0 12 PUSHCONST0 13 PUSHCONST0 14 PUSHENVACC1 15 APPTERM3 4 17 RESTART 18 GRAB 2 20 CONSTINT 13 22 RETURN 3 24 CLOSURE 0, 18 27 PUSHACC0 28 CLOSURE 1, 11 31 PUSHCONSTINT 13 33 PUSHCONST0 34 PUSHACC2 35 APPLY1 36 NEQ 37 BRANCHIFNOT 44 39 GETGLOBAL Not_found 41 MAKEBLOCK1 0 43 RAISE 44 POP 2 46 ATOM0 47 SETGLOBAL T180-appterm3 49 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t090-acc2.ml0000644000175000017500000000074612124403241022562 0ustar tootstootsopen Lib;; let x = true in let y = false in let z = false in (); if not x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONST0 11 PUSHCONST0 12 PUSHCONST0 13 ACC2 14 BOOLNOT 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 POP 3 24 ATOM0 25 SETGLOBAL T090-acc2 27 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t330-compact-4.ml0000644000175000017500000007757412124403241023553 0ustar tootstootsopen Lib;; let rec f n = if n <= 0 then [] else n :: f (n-1) in Gc.compact (); let l = f 300 in if List.fold_left (+) 0 l <> 301 * 150 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 746 11 RESTART 12 GRAB 1 14 ACC0 15 BRANCHIFNOT 28 17 ACC1 18 PUSHACC1 19 GETFIELD1 20 PUSHOFFSETCLOSURE0 21 APPLY2 22 PUSHACC1 23 GETFIELD0 24 MAKEBLOCK2 0 26 RETURN 2 28 ACC1 29 RETURN 2 31 RESTART 32 GRAB 3 34 CONST0 35 PUSHACC4 36 LEINT 37 BRANCHIFNOT 42 39 CONST0 40 RETURN 4 42 ACC3 43 PUSHACC3 44 PUSHACC3 45 PUSHACC3 46 C_CALL4 caml_input 48 PUSHCONST0 49 PUSHACC1 50 EQ 51 BRANCHIFNOT 58 53 GETGLOBAL End_of_file 55 MAKEBLOCK1 0 57 RAISE 58 ACC0 59 PUSHACC5 60 SUBINT 61 PUSHACC1 62 PUSHACC5 63 ADDINT 64 PUSHACC4 65 PUSHACC4 66 PUSHOFFSETCLOSURE0 67 APPTERM 4, 9 70 ACC0 71 C_CALL1 caml_input_scan_line 73 PUSHCONST0 74 PUSHACC1 75 EQ 76 BRANCHIFNOT 83 78 GETGLOBAL End_of_file 80 MAKEBLOCK1 0 82 RAISE 83 CONST0 84 PUSHACC1 85 GTINT 86 BRANCHIFNOT 107 88 ACC0 89 OFFSETINT -1 91 C_CALL1 create_string 93 PUSHACC1 94 OFFSETINT -1 96 PUSHCONST0 97 PUSHACC2 98 PUSHACC5 99 C_CALL4 caml_input 101 ACC2 102 C_CALL1 caml_input_char 104 ACC0 105 RETURN 3 107 ACC0 108 NEGINT 109 C_CALL1 create_string 111 PUSHACC1 112 NEGINT 113 PUSHCONST0 114 PUSHACC2 115 PUSHACC5 116 C_CALL4 caml_input 118 CONST0 119 PUSHTRAP 130 121 ACC6 122 PUSHOFFSETCLOSURE0 123 APPLY1 124 PUSHACC5 125 PUSHENVACC1 126 APPLY2 127 POPTRAP 128 RETURN 3 130 PUSHGETGLOBAL End_of_file 132 PUSHACC1 133 GETFIELD0 134 EQ 135 BRANCHIFNOT 140 137 ACC1 138 RETURN 4 140 ACC0 141 RAISE 142 ACC0 143 C_CALL1 caml_flush 145 RETURN 1 147 RESTART 148 GRAB 1 150 ACC1 151 PUSHACC1 152 C_CALL2 caml_output_char 154 RETURN 2 156 RESTART 157 GRAB 1 159 ACC1 160 PUSHACC1 161 C_CALL2 caml_output_char 163 RETURN 2 165 RESTART 166 GRAB 1 168 ACC1 169 PUSHACC1 170 C_CALL2 caml_output_int 172 RETURN 2 174 RESTART 175 GRAB 1 177 ACC1 178 PUSHACC1 179 C_CALL2 caml_seek_out 181 RETURN 2 183 ACC0 184 C_CALL1 caml_pos_out 186 RETURN 1 188 ACC0 189 C_CALL1 caml_channel_size 191 RETURN 1 193 RESTART 194 GRAB 1 196 ACC1 197 PUSHACC1 198 C_CALL2 caml_set_binary_mode 200 RETURN 2 202 ACC0 203 C_CALL1 caml_input_char 205 RETURN 1 207 ACC0 208 C_CALL1 caml_input_char 210 RETURN 1 212 ACC0 213 C_CALL1 caml_input_int 215 RETURN 1 217 ACC0 218 C_CALL1 input_value 220 RETURN 1 222 RESTART 223 GRAB 1 225 ACC1 226 PUSHACC1 227 C_CALL2 caml_seek_in 229 RETURN 2 231 ACC0 232 C_CALL1 caml_pos_in 234 RETURN 1 236 ACC0 237 C_CALL1 caml_channel_size 239 RETURN 1 241 ACC0 242 C_CALL1 caml_close_channel 244 RETURN 1 246 RESTART 247 GRAB 1 249 ACC1 250 PUSHACC1 251 C_CALL2 caml_set_binary_mode 253 RETURN 2 255 CONST0 256 PUSHENVACC1 257 APPLY1 258 ACC0 259 C_CALL1 sys_exit 261 RETURN 1 263 CONST0 264 PUSHENVACC1 265 GETFIELD0 266 APPTERM1 2 268 CONST0 269 PUSHENVACC1 270 APPLY1 271 CONST0 272 PUSHENVACC2 273 APPTERM1 2 275 ENVACC1 276 GETFIELD0 277 PUSHACC0 278 PUSHACC2 279 CLOSURE 2, 268 282 PUSHENVACC1 283 SETFIELD0 284 RETURN 2 286 ENVACC1 287 C_CALL1 caml_flush 289 ENVACC2 290 C_CALL1 caml_flush 292 RETURN 1 294 CONST0 295 PUSHENVACC1 296 APPLY1 297 C_CALL1 float_of_string 299 RETURN 1 301 CONST0 302 PUSHENVACC1 303 APPLY1 304 C_CALL1 int_of_string 306 RETURN 1 308 ENVACC2 309 C_CALL1 caml_flush 311 ENVACC1 312 PUSHENVACC3 313 APPTERM1 2 315 CONSTINT 13 317 PUSHENVACC1 318 C_CALL2 caml_output_char 320 ENVACC1 321 C_CALL1 caml_flush 323 RETURN 1 325 ACC0 326 PUSHENVACC1 327 PUSHENVACC2 328 APPLY2 329 CONSTINT 13 331 PUSHENVACC1 332 C_CALL2 caml_output_char 334 ENVACC1 335 C_CALL1 caml_flush 337 RETURN 1 339 ACC0 340 PUSHENVACC1 341 APPLY1 342 PUSHENVACC2 343 PUSHENVACC3 344 APPTERM2 3 346 ACC0 347 PUSHENVACC1 348 APPLY1 349 PUSHENVACC2 350 PUSHENVACC3 351 APPTERM2 3 353 ACC0 354 PUSHENVACC1 355 PUSHENVACC2 356 APPTERM2 3 358 ACC0 359 PUSHENVACC1 360 C_CALL2 caml_output_char 362 RETURN 1 364 CONSTINT 13 366 PUSHENVACC1 367 C_CALL2 caml_output_char 369 ENVACC1 370 C_CALL1 caml_flush 372 RETURN 1 374 ACC0 375 PUSHENVACC1 376 PUSHENVACC2 377 APPLY2 378 CONSTINT 13 380 PUSHENVACC1 381 C_CALL2 caml_output_char 383 RETURN 1 385 ACC0 386 PUSHENVACC1 387 APPLY1 388 PUSHENVACC2 389 PUSHENVACC3 390 APPTERM2 3 392 ACC0 393 PUSHENVACC1 394 APPLY1 395 PUSHENVACC2 396 PUSHENVACC3 397 APPTERM2 3 399 ACC0 400 PUSHENVACC1 401 PUSHENVACC2 402 APPTERM2 3 404 ACC0 405 PUSHENVACC1 406 C_CALL2 caml_output_char 408 RETURN 1 410 RESTART 411 GRAB 3 413 CONST0 414 PUSHACC3 415 LTINT 416 BRANCHIF 427 418 ACC1 419 C_CALL1 ml_string_length 421 PUSHACC4 422 PUSHACC4 423 ADDINT 424 GTINT 425 BRANCHIFNOT 432 427 GETGLOBAL "really_input" 429 PUSHENVACC1 430 APPTERM1 5 432 ACC3 433 PUSHACC3 434 PUSHACC3 435 PUSHACC3 436 PUSHENVACC2 437 APPTERM 4, 8 440 RESTART 441 GRAB 3 443 CONST0 444 PUSHACC3 445 LTINT 446 BRANCHIF 457 448 ACC1 449 C_CALL1 ml_string_length 451 PUSHACC4 452 PUSHACC4 453 ADDINT 454 GTINT 455 BRANCHIFNOT 462 457 GETGLOBAL "input" 459 PUSHENVACC1 460 APPTERM1 5 462 ACC3 463 PUSHACC3 464 PUSHACC3 465 PUSHACC3 466 C_CALL4 caml_input 468 RETURN 4 470 ACC0 471 PUSHCONST0 472 PUSHGETGLOBAL <0>(0, <0>(6, 0)) 474 PUSHENVACC1 475 APPTERM3 4 477 ACC0 478 PUSHCONST0 479 PUSHGETGLOBAL <0>(0, <0>(7, 0)) 481 PUSHENVACC1 482 APPTERM3 4 484 RESTART 485 GRAB 2 487 ACC1 488 PUSHACC1 489 PUSHACC4 490 C_CALL3 sys_open 492 C_CALL1 caml_open_descriptor 494 RETURN 3 496 ACC0 497 C_CALL1 caml_flush 499 ACC0 500 C_CALL1 caml_close_channel 502 RETURN 1 504 RESTART 505 GRAB 1 507 CONST0 508 PUSHACC2 509 PUSHACC2 510 C_CALL3 output_value 512 RETURN 2 514 RESTART 515 GRAB 3 517 CONST0 518 PUSHACC3 519 LTINT 520 BRANCHIF 531 522 ACC1 523 C_CALL1 ml_string_length 525 PUSHACC4 526 PUSHACC4 527 ADDINT 528 GTINT 529 BRANCHIFNOT 536 531 GETGLOBAL "output" 533 PUSHENVACC1 534 APPTERM1 5 536 ACC3 537 PUSHACC3 538 PUSHACC3 539 PUSHACC3 540 C_CALL4 caml_output 542 RETURN 4 544 RESTART 545 GRAB 1 547 ACC1 548 C_CALL1 ml_string_length 550 PUSHCONST0 551 PUSHACC3 552 PUSHACC3 553 C_CALL4 caml_output 555 RETURN 2 557 ACC0 558 PUSHCONSTINT 438 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0)))) 562 PUSHENVACC1 563 APPTERM3 4 565 ACC0 566 PUSHCONSTINT 438 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0)))) 570 PUSHENVACC1 571 APPTERM3 4 573 RESTART 574 GRAB 2 576 ACC1 577 PUSHACC1 578 PUSHACC4 579 C_CALL3 sys_open 581 C_CALL1 caml_open_descriptor 583 RETURN 3 585 ACC0 586 PUSHGETGLOBAL "%.12g" 588 C_CALL2 format_float 590 RETURN 1 592 ACC0 593 PUSHGETGLOBAL "%d" 595 C_CALL2 format_int 597 RETURN 1 599 GETGLOBAL "false" 601 PUSHACC1 602 C_CALL2 string_equal 604 BRANCHIFNOT 609 606 CONST0 607 RETURN 1 609 GETGLOBAL "true" 611 PUSHACC1 612 C_CALL2 string_equal 614 BRANCHIFNOT 619 616 CONST1 617 RETURN 1 619 GETGLOBAL "bool_of_string" 621 PUSHENVACC1 622 APPTERM1 2 624 ACC0 625 BRANCHIFNOT 631 627 GETGLOBAL "true" 629 RETURN 1 631 GETGLOBAL "false" 633 RETURN 1 635 CONST0 636 PUSHACC1 637 LTINT 638 BRANCHIF 646 640 CONSTINT 255 642 PUSHACC1 643 GTINT 644 BRANCHIFNOT 651 646 GETGLOBAL "char_of_int" 648 PUSHENVACC1 649 APPTERM1 2 651 ACC0 652 RETURN 1 654 RESTART 655 GRAB 1 657 ACC0 658 C_CALL1 ml_string_length 660 PUSHACC2 661 C_CALL1 ml_string_length 663 PUSHACC0 664 PUSHACC2 665 ADDINT 666 C_CALL1 create_string 668 PUSHACC2 669 PUSHCONST0 670 PUSHACC2 671 PUSHCONST0 672 PUSHACC7 673 C_CALL5 blit_string 675 ACC1 676 PUSHACC3 677 PUSHACC2 678 PUSHCONST0 679 PUSHACC 8 681 C_CALL5 blit_string 683 ACC0 684 RETURN 5 686 CONSTINT -1 688 PUSHACC1 689 XORINT 690 RETURN 1 692 CONST0 693 PUSHACC1 694 GEINT 695 BRANCHIFNOT 700 697 ACC0 698 RETURN 1 700 ACC0 701 NEGINT 702 RETURN 1 704 RESTART 705 GRAB 1 707 ACC1 708 PUSHACC1 709 C_CALL2 greaterequal 711 BRANCHIFNOT 716 713 ACC0 714 RETURN 2 716 ACC1 717 RETURN 2 719 RESTART 720 GRAB 1 722 ACC1 723 PUSHACC1 724 C_CALL2 lessequal 726 BRANCHIFNOT 731 728 ACC0 729 RETURN 2 731 ACC1 732 RETURN 2 734 ACC0 735 PUSHGETGLOBAL Invalid_argument 737 MAKEBLOCK2 0 739 RAISE 740 ACC0 741 PUSHGETGLOBAL Failure 743 MAKEBLOCK2 0 745 RAISE 746 CLOSURE 0, 740 749 PUSH 750 CLOSURE 0, 734 753 PUSHGETGLOBAL "Pervasives.Exit" 755 MAKEBLOCK1 0 757 PUSHGETGLOBAL "Pervasives.Assert_failure" 759 MAKEBLOCK1 0 761 PUSH 762 CLOSURE 0, 720 765 PUSH 766 CLOSURE 0, 705 769 PUSH 770 CLOSURE 0, 692 773 PUSH 774 CLOSURE 0, 686 777 PUSHCONST0 778 PUSHCONSTINT 31 780 PUSHCONST1 781 LSLINT 782 EQ 783 BRANCHIFNOT 789 785 CONSTINT 30 787 BRANCH 791 789 CONSTINT 62 791 PUSHCONST1 792 LSLINT 793 PUSHACC0 794 OFFSETINT -1 796 PUSH 797 CLOSURE 0, 655 800 PUSHACC 9 802 CLOSURE 1, 635 805 PUSH 806 CLOSURE 0, 624 809 PUSHACC 11 811 CLOSURE 1, 599 814 PUSH 815 CLOSURE 0, 592 818 PUSH 819 CLOSURE 0, 585 822 PUSH 823 CLOSUREREC 0, 12 827 CONST0 828 C_CALL1 caml_open_descriptor 830 PUSHCONST1 831 C_CALL1 caml_open_descriptor 833 PUSHCONST2 834 C_CALL1 caml_open_descriptor 836 PUSH 837 CLOSURE 0, 574 840 PUSHACC0 841 CLOSURE 1, 565 844 PUSHACC1 845 CLOSURE 1, 557 848 PUSH 849 CLOSURE 0, 545 852 PUSHACC 22 854 CLOSURE 1, 515 857 PUSH 858 CLOSURE 0, 505 861 PUSH 862 CLOSURE 0, 496 865 PUSH 866 CLOSURE 0, 485 869 PUSHACC0 870 CLOSURE 1, 477 873 PUSHACC1 874 CLOSURE 1, 470 877 PUSHACC 28 879 CLOSURE 1, 441 882 PUSH 883 CLOSUREREC 0, 32 887 ACC0 888 PUSHACC 31 890 CLOSURE 2, 411 893 PUSHACC 22 895 CLOSUREREC 1, 70 899 ACC 15 901 CLOSURE 1, 404 904 PUSHACC 11 906 PUSHACC 17 908 CLOSURE 2, 399 911 PUSHACC 12 913 PUSHACC 18 915 PUSHACC 23 917 CLOSURE 3, 392 920 PUSHACC 13 922 PUSHACC 19 924 PUSHACC 23 926 CLOSURE 3, 385 929 PUSHACC 14 931 PUSHACC 20 933 CLOSURE 2, 374 936 PUSHACC 20 938 CLOSURE 1, 364 941 PUSHACC 20 943 CLOSURE 1, 358 946 PUSHACC 17 948 PUSHACC 22 950 CLOSURE 2, 353 953 PUSHACC 18 955 PUSHACC 23 957 PUSHACC 29 959 CLOSURE 3, 346 962 PUSHACC 19 964 PUSHACC 24 966 PUSHACC 29 968 CLOSURE 3, 339 971 PUSHACC 20 973 PUSHACC 25 975 CLOSURE 2, 325 978 PUSHACC 25 980 CLOSURE 1, 315 983 PUSHACC 12 985 PUSHACC 28 987 PUSHACC 30 989 CLOSURE 3, 308 992 PUSHACC0 993 CLOSURE 1, 301 996 PUSHACC1 997 CLOSURE 1, 294 1000 PUSHACC 29 1002 PUSHACC 31 1004 CLOSURE 2, 286 1007 MAKEBLOCK1 0 1009 PUSHACC0 1010 CLOSURE 1, 275 1013 PUSHACC1 1014 CLOSURE 1, 263 1017 PUSHACC0 1018 CLOSURE 1, 255 1021 PUSHACC1 1022 PUSHACC 22 1024 PUSHACC4 1025 PUSHACC3 1026 PUSH 1027 CLOSURE 0, 247 1030 PUSH 1031 CLOSURE 0, 241 1034 PUSH 1035 CLOSURE 0, 236 1038 PUSH 1039 CLOSURE 0, 231 1042 PUSH 1043 CLOSURE 0, 223 1046 PUSH 1047 CLOSURE 0, 217 1050 PUSH 1051 CLOSURE 0, 212 1054 PUSH 1055 CLOSURE 0, 207 1058 PUSHACC 32 1060 PUSHACC 35 1062 PUSHACC 33 1064 PUSH 1065 CLOSURE 0, 202 1068 PUSHACC 41 1070 PUSHACC 40 1072 PUSHACC 42 1074 PUSH 1075 CLOSURE 0, 194 1078 PUSHACC 46 1080 PUSH 1081 CLOSURE 0, 188 1084 PUSH 1085 CLOSURE 0, 183 1088 PUSH 1089 CLOSURE 0, 175 1092 PUSHACC 51 1094 PUSH 1095 CLOSURE 0, 166 1098 PUSH 1099 CLOSURE 0, 157 1102 PUSHACC 55 1104 PUSHACC 57 1106 PUSH 1107 CLOSURE 0, 148 1110 PUSH 1111 CLOSURE 0, 142 1114 PUSHACC 63 1116 PUSHACC 62 1118 PUSHACC 64 1120 PUSHACC 38 1122 PUSHACC 40 1124 PUSHACC 42 1126 PUSHACC 44 1128 PUSHACC 46 1130 PUSHACC 48 1132 PUSHACC 50 1134 PUSHACC 52 1136 PUSHACC 54 1138 PUSHACC 56 1140 PUSHACC 58 1142 PUSHACC 60 1144 PUSHACC 62 1146 PUSHACC 64 1148 PUSHACC 66 1150 PUSHACC 82 1152 PUSHACC 84 1154 PUSHACC 86 1156 PUSHACC 88 1158 PUSHACC 90 1160 PUSHACC 92 1162 PUSHACC 94 1164 PUSHACC 96 1166 PUSHACC 98 1168 PUSHACC 100 1170 PUSHACC 104 1172 PUSHACC 104 1174 PUSHACC 104 1176 PUSHACC 108 1178 PUSHACC 110 1180 PUSHACC 112 1182 PUSHACC 117 1184 PUSHACC 117 1186 PUSHACC 117 1188 PUSHACC 117 1190 MAKEBLOCK 69, 0 1193 POP 53 1195 SETGLOBAL Pervasives 1197 BRANCH 2177 1199 RESTART 1200 GRAB 1 1202 ACC1 1203 BRANCHIFNOT 1213 1205 ACC1 1206 GETFIELD1 1207 PUSHACC1 1208 OFFSETINT 1 1210 PUSHOFFSETCLOSURE0 1211 APPTERM2 4 1213 ACC0 1214 RETURN 2 1216 RESTART 1217 GRAB 1 1219 ACC0 1220 BRANCHIFNOT 1251 1222 CONST0 1223 PUSHACC2 1224 EQ 1225 BRANCHIFNOT 1231 1227 ACC0 1228 GETFIELD0 1229 RETURN 2 1231 CONST0 1232 PUSHACC2 1233 GTINT 1234 BRANCHIFNOT 1244 1236 ACC1 1237 OFFSETINT -1 1239 PUSHACC1 1240 GETFIELD1 1241 PUSHOFFSETCLOSURE0 1242 APPTERM2 4 1244 GETGLOBAL "List.nth" 1246 PUSHGETGLOBALFIELD Pervasives, 2 1249 APPTERM1 3 1251 GETGLOBAL "nth" 1253 PUSHGETGLOBALFIELD Pervasives, 3 1256 APPTERM1 3 1258 RESTART 1259 GRAB 1 1261 ACC0 1262 BRANCHIFNOT 1274 1264 ACC1 1265 PUSHACC1 1266 GETFIELD0 1267 MAKEBLOCK2 0 1269 PUSHACC1 1270 GETFIELD1 1271 PUSHOFFSETCLOSURE0 1272 APPTERM2 4 1274 ACC1 1275 RETURN 2 1277 ACC0 1278 BRANCHIFNOT 1291 1280 ACC0 1281 GETFIELD1 1282 PUSHOFFSETCLOSURE0 1283 APPLY1 1284 PUSHACC1 1285 GETFIELD0 1286 PUSHGETGLOBALFIELD Pervasives, 16 1289 APPTERM2 3 1291 RETURN 1 1293 RESTART 1294 GRAB 1 1296 ACC1 1297 BRANCHIFNOT 1313 1299 ACC1 1300 GETFIELD0 1301 PUSHACC1 1302 APPLY1 1303 PUSHACC2 1304 GETFIELD1 1305 PUSHACC2 1306 PUSHOFFSETCLOSURE0 1307 APPLY2 1308 PUSHACC1 1309 MAKEBLOCK2 0 1311 POP 1 1313 RETURN 2 1315 RESTART 1316 GRAB 1 1318 ACC1 1319 BRANCHIFNOT 1331 1321 ACC1 1322 GETFIELD0 1323 PUSHACC1 1324 APPLY1 1325 ACC1 1326 GETFIELD1 1327 PUSHACC1 1328 PUSHOFFSETCLOSURE0 1329 APPTERM2 4 1331 RETURN 2 1333 RESTART 1334 GRAB 2 1336 ACC2 1337 BRANCHIFNOT 1350 1339 ACC2 1340 GETFIELD1 1341 PUSHACC3 1342 GETFIELD0 1343 PUSHACC3 1344 PUSHACC3 1345 APPLY2 1346 PUSHACC2 1347 PUSHOFFSETCLOSURE0 1348 APPTERM3 6 1350 ACC1 1351 RETURN 3 1353 RESTART 1354 GRAB 2 1356 ACC1 1357 BRANCHIFNOT 1370 1359 ACC2 1360 PUSHACC2 1361 GETFIELD1 1362 PUSHACC2 1363 PUSHOFFSETCLOSURE0 1364 APPLY3 1365 PUSHACC2 1366 GETFIELD0 1367 PUSHACC2 1368 APPTERM2 5 1370 ACC2 1371 RETURN 3 1373 RESTART 1374 GRAB 2 1376 ACC1 1377 BRANCHIFNOT 1400 1379 ACC2 1380 BRANCHIFNOT 1407 1382 ACC2 1383 GETFIELD0 1384 PUSHACC2 1385 GETFIELD0 1386 PUSHACC2 1387 APPLY2 1388 PUSHACC3 1389 GETFIELD1 1390 PUSHACC3 1391 GETFIELD1 1392 PUSHACC3 1393 PUSHOFFSETCLOSURE0 1394 APPLY3 1395 PUSHACC1 1396 MAKEBLOCK2 0 1398 RETURN 4 1400 ACC2 1401 BRANCHIFNOT 1405 1403 BRANCH 1407 1405 RETURN 3 1407 GETGLOBAL "List.map2" 1409 PUSHGETGLOBALFIELD Pervasives, 2 1412 APPTERM1 4 1414 RESTART 1415 GRAB 2 1417 ACC1 1418 BRANCHIFNOT 1437 1420 ACC2 1421 BRANCHIFNOT 1444 1423 ACC2 1424 GETFIELD0 1425 PUSHACC2 1426 GETFIELD0 1427 PUSHACC2 1428 APPLY2 1429 ACC2 1430 GETFIELD1 1431 PUSHACC2 1432 GETFIELD1 1433 PUSHACC2 1434 PUSHOFFSETCLOSURE0 1435 APPTERM3 6 1437 ACC2 1438 BRANCHIFNOT 1442 1440 BRANCH 1444 1442 RETURN 3 1444 GETGLOBAL "List.iter2" 1446 PUSHGETGLOBALFIELD Pervasives, 2 1449 APPTERM1 4 1451 RESTART 1452 GRAB 3 1454 ACC2 1455 BRANCHIFNOT 1476 1457 ACC3 1458 BRANCHIFNOT 1482 1460 ACC3 1461 GETFIELD1 1462 PUSHACC3 1463 GETFIELD1 1464 PUSHACC5 1465 GETFIELD0 1466 PUSHACC5 1467 GETFIELD0 1468 PUSHACC5 1469 PUSHACC5 1470 APPLY3 1471 PUSHACC3 1472 PUSHOFFSETCLOSURE0 1473 APPTERM 4, 8 1476 ACC3 1477 BRANCHIF 1482 1479 ACC1 1480 RETURN 4 1482 GETGLOBAL "List.fold_left2" 1484 PUSHGETGLOBALFIELD Pervasives, 2 1487 APPTERM1 5 1489 RESTART 1490 GRAB 3 1492 ACC1 1493 BRANCHIFNOT 1516 1495 ACC2 1496 BRANCHIFNOT 1522 1498 PUSH_RETADDR 1509 1500 ACC6 1501 PUSHACC6 1502 GETFIELD1 1503 PUSHACC6 1504 GETFIELD1 1505 PUSHACC6 1506 PUSHOFFSETCLOSURE0 1507 APPLY 4 1509 PUSHACC3 1510 GETFIELD0 1511 PUSHACC3 1512 GETFIELD0 1513 PUSHACC3 1514 APPTERM3 7 1516 ACC2 1517 BRANCHIF 1522 1519 ACC3 1520 RETURN 4 1522 GETGLOBAL "List.fold_right2" 1524 PUSHGETGLOBALFIELD Pervasives, 2 1527 APPTERM1 5 1529 RESTART 1530 GRAB 1 1532 ACC1 1533 BRANCHIFNOT 1549 1535 ACC1 1536 GETFIELD0 1537 PUSHACC1 1538 APPLY1 1539 BRANCHIFNOT 1547 1541 ACC1 1542 GETFIELD1 1543 PUSHACC1 1544 PUSHOFFSETCLOSURE0 1545 APPTERM2 4 1547 RETURN 2 1549 CONST1 1550 RETURN 2 1552 RESTART 1553 GRAB 1 1555 ACC1 1556 BRANCHIFNOT 1570 1558 ACC1 1559 GETFIELD0 1560 PUSHACC1 1561 APPLY1 1562 BRANCHIF 1570 1564 ACC1 1565 GETFIELD1 1566 PUSHACC1 1567 PUSHOFFSETCLOSURE0 1568 APPTERM2 4 1570 RETURN 2 1572 RESTART 1573 GRAB 2 1575 ACC1 1576 BRANCHIFNOT 1599 1578 ACC2 1579 BRANCHIFNOT 1605 1581 ACC2 1582 GETFIELD0 1583 PUSHACC2 1584 GETFIELD0 1585 PUSHACC2 1586 APPLY2 1587 BRANCHIFNOT 1597 1589 ACC2 1590 GETFIELD1 1591 PUSHACC2 1592 GETFIELD1 1593 PUSHACC2 1594 PUSHOFFSETCLOSURE0 1595 APPTERM3 6 1597 RETURN 3 1599 ACC2 1600 BRANCHIF 1605 1602 CONST1 1603 RETURN 3 1605 GETGLOBAL "List.for_all2" 1607 PUSHGETGLOBALFIELD Pervasives, 2 1610 APPTERM1 4 1612 RESTART 1613 GRAB 2 1615 ACC1 1616 BRANCHIFNOT 1639 1618 ACC2 1619 BRANCHIFNOT 1646 1621 ACC2 1622 GETFIELD0 1623 PUSHACC2 1624 GETFIELD0 1625 PUSHACC2 1626 APPLY2 1627 BRANCHIF 1637 1629 ACC2 1630 GETFIELD1 1631 PUSHACC2 1632 GETFIELD1 1633 PUSHACC2 1634 PUSHOFFSETCLOSURE0 1635 APPTERM3 6 1637 RETURN 3 1639 ACC2 1640 BRANCHIFNOT 1644 1642 BRANCH 1646 1644 RETURN 3 1646 GETGLOBAL "List.exists2" 1648 PUSHGETGLOBALFIELD Pervasives, 2 1651 APPTERM1 4 1653 RESTART 1654 GRAB 1 1656 ACC1 1657 BRANCHIFNOT 1672 1659 ACC0 1660 PUSHACC2 1661 GETFIELD0 1662 C_CALL2 equal 1664 BRANCHIF 1672 1666 ACC1 1667 GETFIELD1 1668 PUSHACC1 1669 PUSHOFFSETCLOSURE0 1670 APPTERM2 4 1672 RETURN 2 1674 RESTART 1675 GRAB 1 1677 ACC1 1678 BRANCHIFNOT 1692 1680 ACC0 1681 PUSHACC2 1682 GETFIELD0 1683 EQ 1684 BRANCHIF 1692 1686 ACC1 1687 GETFIELD1 1688 PUSHACC1 1689 PUSHOFFSETCLOSURE0 1690 APPTERM2 4 1692 RETURN 2 1694 RESTART 1695 GRAB 1 1697 ACC1 1698 BRANCHIFNOT 1719 1700 ACC1 1701 GETFIELD0 1702 PUSHACC1 1703 PUSHACC1 1704 GETFIELD0 1705 C_CALL2 equal 1707 BRANCHIFNOT 1713 1709 ACC0 1710 GETFIELD1 1711 RETURN 3 1713 ACC2 1714 GETFIELD1 1715 PUSHACC2 1716 PUSHOFFSETCLOSURE0 1717 APPTERM2 5 1719 GETGLOBAL Not_found 1721 MAKEBLOCK1 0 1723 RAISE 1724 RESTART 1725 GRAB 1 1727 ACC1 1728 BRANCHIFNOT 1748 1730 ACC1 1731 GETFIELD0 1732 PUSHACC1 1733 PUSHACC1 1734 GETFIELD0 1735 EQ 1736 BRANCHIFNOT 1742 1738 ACC0 1739 GETFIELD1 1740 RETURN 3 1742 ACC2 1743 GETFIELD1 1744 PUSHACC2 1745 PUSHOFFSETCLOSURE0 1746 APPTERM2 5 1748 GETGLOBAL Not_found 1750 MAKEBLOCK1 0 1752 RAISE 1753 RESTART 1754 GRAB 1 1756 ACC1 1757 BRANCHIFNOT 1773 1759 ACC0 1760 PUSHACC2 1761 GETFIELD0 1762 GETFIELD0 1763 C_CALL2 equal 1765 BRANCHIF 1773 1767 ACC1 1768 GETFIELD1 1769 PUSHACC1 1770 PUSHOFFSETCLOSURE0 1771 APPTERM2 4 1773 RETURN 2 1775 RESTART 1776 GRAB 1 1778 ACC1 1779 BRANCHIFNOT 1794 1781 ACC0 1782 PUSHACC2 1783 GETFIELD0 1784 GETFIELD0 1785 EQ 1786 BRANCHIF 1794 1788 ACC1 1789 GETFIELD1 1790 PUSHACC1 1791 PUSHOFFSETCLOSURE0 1792 APPTERM2 4 1794 RETURN 2 1796 RESTART 1797 GRAB 1 1799 ACC1 1800 BRANCHIFNOT 1825 1802 ACC1 1803 GETFIELD0 1804 PUSHACC2 1805 GETFIELD1 1806 PUSHACC2 1807 PUSHACC2 1808 GETFIELD0 1809 C_CALL2 equal 1811 BRANCHIFNOT 1816 1813 ACC0 1814 RETURN 4 1816 ACC0 1817 PUSHACC3 1818 PUSHOFFSETCLOSURE0 1819 APPLY2 1820 PUSHACC2 1821 MAKEBLOCK2 0 1823 POP 2 1825 RETURN 2 1827 RESTART 1828 GRAB 1 1830 ACC1 1831 BRANCHIFNOT 1855 1833 ACC1 1834 GETFIELD0 1835 PUSHACC2 1836 GETFIELD1 1837 PUSHACC2 1838 PUSHACC2 1839 GETFIELD0 1840 EQ 1841 BRANCHIFNOT 1846 1843 ACC0 1844 RETURN 4 1846 ACC0 1847 PUSHACC3 1848 PUSHOFFSETCLOSURE0 1849 APPLY2 1850 PUSHACC2 1851 MAKEBLOCK2 0 1853 POP 2 1855 RETURN 2 1857 RESTART 1858 GRAB 1 1860 ACC1 1861 BRANCHIFNOT 1879 1863 ACC1 1864 GETFIELD0 1865 PUSHACC0 1866 PUSHACC2 1867 APPLY1 1868 BRANCHIFNOT 1873 1870 ACC0 1871 RETURN 3 1873 ACC2 1874 GETFIELD1 1875 PUSHACC2 1876 PUSHOFFSETCLOSURE0 1877 APPTERM2 5 1879 GETGLOBAL Not_found 1881 MAKEBLOCK1 0 1883 RAISE 1884 RESTART 1885 GRAB 2 1887 ACC2 1888 BRANCHIFNOT 1917 1890 ACC2 1891 GETFIELD0 1892 PUSHACC3 1893 GETFIELD1 1894 PUSHACC1 1895 PUSHENVACC2 1896 APPLY1 1897 BRANCHIFNOT 1908 1899 ACC0 1900 PUSHACC4 1901 PUSHACC4 1902 PUSHACC4 1903 MAKEBLOCK2 0 1905 PUSHOFFSETCLOSURE0 1906 APPTERM3 8 1908 ACC0 1909 PUSHACC4 1910 PUSHACC3 1911 MAKEBLOCK2 0 1913 PUSHACC4 1914 PUSHOFFSETCLOSURE0 1915 APPTERM3 8 1917 ACC1 1918 PUSHENVACC1 1919 APPLY1 1920 PUSHACC1 1921 PUSHENVACC1 1922 APPLY1 1923 MAKEBLOCK2 0 1925 RETURN 3 1927 RESTART 1928 GRAB 1 1930 ACC0 1931 PUSHENVACC1 1932 CLOSUREREC 2, 1885 1936 ACC2 1937 PUSHCONST0 1938 PUSHCONST0 1939 PUSHACC3 1940 APPTERM3 6 1942 ACC0 1943 BRANCHIFNOT 1967 1945 ACC0 1946 GETFIELD0 1947 PUSHACC1 1948 GETFIELD1 1949 PUSHOFFSETCLOSURE0 1950 APPLY1 1951 PUSHACC0 1952 GETFIELD1 1953 PUSHACC2 1954 GETFIELD1 1955 MAKEBLOCK2 0 1957 PUSHACC1 1958 GETFIELD0 1959 PUSHACC3 1960 GETFIELD0 1961 MAKEBLOCK2 0 1963 MAKEBLOCK2 0 1965 RETURN 3 1967 GETGLOBAL <0>(0, 0) 1969 RETURN 1 1971 RESTART 1972 GRAB 1 1974 ACC0 1975 BRANCHIFNOT 1996 1977 ACC1 1978 BRANCHIFNOT 2003 1980 ACC1 1981 GETFIELD1 1982 PUSHACC1 1983 GETFIELD1 1984 PUSHOFFSETCLOSURE0 1985 APPLY2 1986 PUSHACC2 1987 GETFIELD0 1988 PUSHACC2 1989 GETFIELD0 1990 MAKEBLOCK2 0 1992 MAKEBLOCK2 0 1994 RETURN 2 1996 ACC1 1997 BRANCHIFNOT 2001 1999 BRANCH 2003 2001 RETURN 2 2003 GETGLOBAL "List.combine" 2005 PUSHGETGLOBALFIELD Pervasives, 2 2008 APPTERM1 3 2010 RESTART 2011 GRAB 1 2013 ACC1 2014 BRANCHIFNOT 2038 2016 ACC1 2017 GETFIELD0 2018 PUSHACC2 2019 GETFIELD1 2020 PUSHACC1 2021 PUSHENVACC2 2022 APPLY1 2023 BRANCHIFNOT 2033 2025 ACC0 2026 PUSHACC3 2027 PUSHACC3 2028 MAKEBLOCK2 0 2030 PUSHOFFSETCLOSURE0 2031 APPTERM2 6 2033 ACC0 2034 PUSHACC3 2035 PUSHOFFSETCLOSURE0 2036 APPTERM2 6 2038 ACC0 2039 PUSHENVACC1 2040 APPTERM1 3 2042 ACC0 2043 PUSHENVACC1 2044 CLOSUREREC 2, 2011 2048 CONST0 2049 PUSHACC1 2050 APPTERM1 3 2052 RESTART 2053 GRAB 2 2055 ACC1 2056 BRANCHIFNOT 2077 2058 ACC2 2059 BRANCHIFNOT 2084 2061 ACC2 2062 GETFIELD1 2063 PUSHACC2 2064 GETFIELD1 2065 PUSHACC2 2066 PUSHACC5 2067 GETFIELD0 2068 PUSHACC5 2069 GETFIELD0 2070 PUSHENVACC1 2071 APPLY2 2072 MAKEBLOCK2 0 2074 PUSHOFFSETCLOSURE0 2075 APPTERM3 6 2077 ACC2 2078 BRANCHIFNOT 2082 2080 BRANCH 2084 2082 RETURN 3 2084 GETGLOBAL "List.rev_map2" 2086 PUSHGETGLOBALFIELD Pervasives, 2 2089 APPTERM1 4 2091 RESTART 2092 GRAB 2 2094 ACC0 2095 CLOSUREREC 1, 2053 2099 ACC3 2100 PUSHACC3 2101 PUSHCONST0 2102 PUSHACC3 2103 APPTERM3 7 2105 RESTART 2106 GRAB 1 2108 ACC1 2109 BRANCHIFNOT 2123 2111 ACC1 2112 GETFIELD1 2113 PUSHACC1 2114 PUSHACC3 2115 GETFIELD0 2116 PUSHENVACC1 2117 APPLY1 2118 MAKEBLOCK2 0 2120 PUSHOFFSETCLOSURE0 2121 APPTERM2 4 2123 ACC0 2124 RETURN 2 2126 RESTART 2127 GRAB 1 2129 ACC0 2130 CLOSUREREC 1, 2106 2134 ACC2 2135 PUSHCONST0 2136 PUSHACC2 2137 APPTERM2 5 2139 CONST0 2140 PUSHACC1 2141 PUSHENVACC1 2142 APPTERM2 3 2144 ACC0 2145 BRANCHIFNOT 2151 2147 ACC0 2148 GETFIELD1 2149 RETURN 1 2151 GETGLOBAL "tl" 2153 PUSHGETGLOBALFIELD Pervasives, 3 2156 APPTERM1 2 2158 ACC0 2159 BRANCHIFNOT 2165 2161 ACC0 2162 GETFIELD0 2163 RETURN 1 2165 GETGLOBAL "hd" 2167 PUSHGETGLOBALFIELD Pervasives, 3 2170 APPTERM1 2 2172 ACC0 2173 PUSHCONST0 2174 PUSHENVACC1 2175 APPTERM2 3 2177 CLOSUREREC 0, 1200 2181 ACC0 2182 CLOSURE 1, 2172 2185 PUSH 2186 CLOSURE 0, 2158 2189 PUSH 2190 CLOSURE 0, 2144 2193 PUSH 2194 CLOSUREREC 0, 1217 2198 GETGLOBALFIELD Pervasives, 16 2201 PUSH 2202 CLOSUREREC 0, 1259 2206 ACC0 2207 CLOSURE 1, 2139 2210 PUSH 2211 CLOSUREREC 0, 1277 2215 CLOSUREREC 0, 1294 2219 CLOSURE 0, 2127 2222 PUSH 2223 CLOSUREREC 0, 1316 2227 CLOSUREREC 0, 1334 2231 CLOSUREREC 0, 1354 2235 CLOSUREREC 0, 1374 2239 CLOSURE 0, 2092 2242 PUSH 2243 CLOSUREREC 0, 1415 2247 CLOSUREREC 0, 1452 2251 CLOSUREREC 0, 1490 2255 CLOSUREREC 0, 1530 2259 CLOSUREREC 0, 1553 2263 CLOSUREREC 0, 1573 2267 CLOSUREREC 0, 1613 2271 CLOSUREREC 0, 1654 2275 CLOSUREREC 0, 1675 2279 CLOSUREREC 0, 1695 2283 CLOSUREREC 0, 1725 2287 CLOSUREREC 0, 1754 2291 CLOSUREREC 0, 1776 2295 CLOSUREREC 0, 1797 2299 CLOSUREREC 0, 1828 2303 CLOSUREREC 0, 1858 2307 ACC 24 2309 CLOSURE 1, 2042 2312 PUSHACC 25 2314 CLOSUREREC 1, 1928 2318 CLOSUREREC 0, 1942 2322 CLOSUREREC 0, 1972 2326 ACC0 2327 PUSHACC2 2328 PUSHACC7 2329 PUSHACC 9 2331 PUSHACC 11 2333 PUSHACC 13 2335 PUSHACC 15 2337 PUSHACC 17 2339 PUSHACC 10 2341 PUSHACC 12 2343 PUSHACC 13 2345 PUSHACC 15 2347 PUSHACC 23 2349 PUSHACC 25 2351 PUSHACC 27 2353 PUSHACC 29 2355 PUSHACC 31 2357 PUSHACC 33 2359 PUSHACC 35 2361 PUSHACC 37 2363 PUSHACC 40 2365 PUSHACC 42 2367 PUSHACC 41 2369 PUSHACC 45 2371 PUSHACC 47 2373 PUSHACC 50 2375 PUSHACC 52 2377 PUSHACC 51 2379 PUSHACC 55 2381 PUSHACC 56 2383 PUSHACC 59 2385 PUSHACC 61 2387 PUSHACC 60 2389 PUSHACC 64 2391 PUSHACC 66 2393 PUSHACC 68 2395 PUSHACC 70 2397 MAKEBLOCK 37, 0 2400 POP 36 2402 SETGLOBAL List 2404 BRANCH 2432 2406 CONST0 2407 PUSHACC1 2408 LEINT 2409 BRANCHIFNOT 2414 2411 CONST0 2412 RETURN 1 2414 ACC0 2415 OFFSETINT -1 2417 PUSHOFFSETCLOSURE0 2418 APPLY1 2419 PUSHACC1 2420 MAKEBLOCK2 0 2422 RETURN 1 2424 RESTART 2425 GRAB 1 2427 ACC1 2428 PUSHACC1 2429 ADDINT 2430 RETURN 2 2432 CLOSUREREC 0, 2406 2436 CONST0 2437 C_CALL1 gc_compaction 2439 CONSTINT 300 2441 PUSHACC1 2442 APPLY1 2443 PUSHCONSTINT 150 2445 PUSHCONSTINT 301 2447 MULINT 2448 PUSHACC1 2449 PUSHCONST0 2450 PUSH 2451 CLOSURE 0, 2425 2454 PUSHGETGLOBALFIELD List, 12 2457 APPLY3 2458 NEQ 2459 BRANCHIFNOT 2466 2461 GETGLOBAL Not_found 2463 MAKEBLOCK1 0 2465 RAISE 2466 POP 2 2468 ATOM0 2469 SETGLOBAL T330-compact-4 2471 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t130-vectlength.ml0000644000175000017500000000070012124403241024076 0ustar tootstootsopen Lib;; if Array.length [| 1; 2 |] <> 2 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST2 10 PUSHCONST2 11 PUSHCONST1 12 MAKEBLOCK2 0 14 VECTLENGTH 15 NEQ 16 BRANCHIFNOT 23 18 GETGLOBAL Not_found 20 MAKEBLOCK1 0 22 RAISE 23 ATOM0 24 SETGLOBAL T130-vectlength 26 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-divint-3.ml0000644000175000017500000000112212124403241023365 0ustar tootstootsopen Lib;; try ignore (3 / 0); raise Not_found; with Division_by_zero -> () (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 PUSHTRAP 19 11 CONST0 12 PUSHCONST3 13 DIVINT 14 GETGLOBAL Not_found 16 MAKEBLOCK1 0 18 RAISE 19 PUSHGETGLOBAL Division_by_zero 21 PUSHACC1 22 GETFIELD0 23 EQ 24 BRANCHIFNOT 29 26 CONST0 27 BRANCH 31 29 ACC0 30 RAISE 31 POP 1 33 ATOM0 34 SETGLOBAL T110-divint-3 36 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t091-acc.ml0000644000175000017500000000131112124403241022466 0ustar tootstootsopen Lib;; let x = true in let y = false in let z = false in let a = false in let b = false in let c = false in let d = false in let e = false in let f = false in (); if not x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONST0 11 PUSHCONST0 12 PUSHCONST0 13 PUSHCONST0 14 PUSHCONST0 15 PUSHCONST0 16 PUSHCONST0 17 PUSHCONST0 18 PUSHCONST0 19 ACC 8 21 BOOLNOT 22 BRANCHIFNOT 29 24 GETGLOBAL Not_found 26 MAKEBLOCK1 0 28 RAISE 29 POP 9 31 ATOM0 32 SETGLOBAL T091-acc 34 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t191-vectlength.ml0000644000175000017500000000074212124403241024113 0ustar tootstootsopen Lib;; let x = 0.0 in if Array.length [| x |] <> 1 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL 0 11 PUSHCONST1 12 PUSHACC1 13 MAKEFLOATBLOCK 1 15 VECTLENGTH 16 NEQ 17 BRANCHIFNOT 24 19 GETGLOBAL Not_found 21 MAKEBLOCK1 0 23 RAISE 24 POP 1 26 ATOM0 27 SETGLOBAL T191-vectlength 29 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t080-leint.ml0000644000175000017500000000057712124403241023066 0ustar tootstootsopen Lib;; if not (0 <= 0) then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST0 11 LEINT 12 BOOLNOT 13 BRANCHIFNOT 20 15 GETGLOBAL Not_found 17 MAKEBLOCK1 0 19 RAISE 20 ATOM0 21 SETGLOBAL T080-leint 23 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t190-makefloatblock-2.ml0000644000175000017500000000050012124403241025054 0ustar tootstootsopen Lib;; let x = 0.0 in [| x; x |];; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL 0 11 PUSHACC0 12 PUSHACC1 13 MAKEFLOATBLOCK 2 15 POP 1 17 ATOM0 18 SETGLOBAL T190-makefloatblock-2 20 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t170-envacc2.ml0000644000175000017500000000122412124403241023262 0ustar tootstootsopen Lib;; let x = 5 in let y = 2 in let f _ = ignore x; y in if f 0 <> 2 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 16 11 ENVACC1 12 CONST0 13 ENVACC2 14 RETURN 1 16 CONSTINT 5 18 PUSHCONST2 19 PUSHACC0 20 PUSHACC2 21 CLOSURE 2, 11 24 PUSHCONST2 25 PUSHCONST0 26 PUSHACC2 27 APPLY1 28 NEQ 29 BRANCHIFNOT 36 31 GETGLOBAL Not_found 33 MAKEBLOCK1 0 35 RAISE 36 POP 3 38 ATOM0 39 SETGLOBAL T170-envacc2 41 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t164-apply2.ml0000644000175000017500000000063312124403241023156 0ustar tootstootsopen Lib;; let f _ _ = 0 in f 0 0;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 17 11 RESTART 12 GRAB 1 14 CONST0 15 RETURN 2 17 CLOSURE 0, 12 20 PUSHCONST0 21 PUSHCONST0 22 PUSHACC2 23 APPLY2 24 POP 1 26 ATOM0 27 SETGLOBAL T164-apply2 29 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t142-switch-8.ml0000644000175000017500000000077212124403241023415 0ustar tootstootsopen Lib;; type t = | A | B of int | C of int ;; match A with | A -> () | _ -> raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHACC0 11 SWITCH int 0 -> 16 tag 0 -> 19 tag 1 -> 19 16 CONST0 17 BRANCH 24 19 GETGLOBAL Not_found 21 MAKEBLOCK1 0 23 RAISE 24 POP 1 26 ATOM0 27 SETGLOBAL T142-switch-8 29 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t140-switch-2.ml0000644000175000017500000000105112124403241023374 0ustar tootstootsopen Lib;; match 1 with | 0 -> raise Not_found | 1 -> () | _ -> raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHACC0 11 SWITCH int 0 -> 17 int 1 -> 22 15 BRANCH 25 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 CONST0 23 BRANCH 30 25 GETGLOBAL Not_found 27 MAKEBLOCK1 0 29 RAISE 30 POP 1 32 ATOM0 33 SETGLOBAL T140-switch-2 35 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-lsrint.ml0000644000175000017500000000063112124403241023247 0ustar tootstootsopen Lib;; if (14 lsr 2) <> 3 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST3 10 PUSHCONST2 11 PUSHCONSTINT 14 13 LSRINT 14 NEQ 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 ATOM0 23 SETGLOBAL T110-lsrint 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-orint.ml0000644000175000017500000000063012124403241023066 0ustar tootstootsopen Lib;; if (3 lor 6) <> 7 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 7 11 PUSHCONSTINT 6 13 PUSHCONST3 14 ORINT 15 NEQ 16 BRANCHIFNOT 23 18 GETGLOBAL Not_found 20 MAKEBLOCK1 0 22 RAISE 23 ATOM0 24 SETGLOBAL T110-orint 26 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t172-pushenvacc3.ml0000644000175000017500000000137612124403241024175 0ustar tootstootsopen Lib;; let x = 5 in let y = 4 in let z = 3 in let f _ = z + y + x in if f 0 <> 12 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 18 11 ENVACC1 12 PUSHENVACC2 13 PUSHENVACC3 14 ADDINT 15 ADDINT 16 RETURN 1 18 CONSTINT 5 20 PUSHCONSTINT 4 22 PUSHCONST3 23 PUSHACC0 24 PUSHACC2 25 PUSHACC4 26 CLOSURE 3, 11 29 PUSHCONSTINT 12 31 PUSHCONST0 32 PUSHACC2 33 APPLY1 34 NEQ 35 BRANCHIFNOT 42 37 GETGLOBAL Not_found 39 MAKEBLOCK1 0 41 RAISE 42 POP 4 44 ATOM0 45 SETGLOBAL T172-pushenvacc3 47 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t201-getfield.ml0000644000175000017500000000077612124403241023532 0ustar tootstootsopen Lib;; type t = { a : int; b : int; c : int; d : int; e : int; };; if { a = 7; b = 6; c = 5; d = 4; e = 3 }.e <> 3 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST3 10 PUSHGETGLOBAL <0>(7, 6, 5, 4, 3) 12 GETFIELD 4 14 NEQ 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 ATOM0 23 SETGLOBAL T201-getfield 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t040-makeblock1.ml0000644000175000017500000000024112124403241023744 0ustar tootstootstype t = { mutable a : int; };; { a = 0 };; (** 0 CONST0 1 MAKEBLOCK1 0 3 ATOM0 4 SETGLOBAL T040-makeblock1 6 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t090-acc6.ml0000644000175000017500000000117612124403241022564 0ustar tootstootsopen Lib;; let x = true in let y = false in let z = false in let a = false in let b = false in let c = false in let d = false in (); if not x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONST0 11 PUSHCONST0 12 PUSHCONST0 13 PUSHCONST0 14 PUSHCONST0 15 PUSHCONST0 16 PUSHCONST0 17 ACC6 18 BOOLNOT 19 BRANCHIFNOT 26 21 GETGLOBAL Not_found 23 MAKEBLOCK1 0 25 RAISE 26 POP 7 28 ATOM0 29 SETGLOBAL T090-acc6 31 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t070-branchif.ml0000644000175000017500000000056012124403241023516 0ustar tootstootsopen Lib;; if not false then 0 else raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 BRANCHIF 15 12 CONST0 13 BRANCH 20 15 GETGLOBAL Not_found 17 MAKEBLOCK1 0 19 RAISE 20 ATOM0 21 SETGLOBAL T070-branchif 23 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t251-pushoffsetclosure2.ml0000644000175000017500000000115412124403241025610 0ustar tootstootsopen Lib;; let rec f _ = g 0 and g _ = 4 in if f 5 <> 4 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 19 11 CONST0 12 PUSHOFFSETCLOSURE2 13 APPTERM1 2 15 CONSTINT 4 17 RETURN 1 19 CLOSUREREC 0, 11, 15 24 CONSTINT 4 26 PUSHCONSTINT 5 28 PUSHACC3 29 APPLY1 30 NEQ 31 BRANCHIFNOT 38 33 GETGLOBAL Not_found 35 MAKEBLOCK1 0 37 RAISE 38 POP 2 40 ATOM0 41 SETGLOBAL T251-pushoffsetclosure2 43 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t200-getfield2.ml0000644000175000017500000000073012124403241023601 0ustar tootstootsopen Lib;; type t = { a : int; b : int; c : int; };; if { a = 7; b = 6; c = 5 }.c <> 5 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 5 11 PUSHGETGLOBAL <0>(7, 6, 5) 13 GETFIELD2 14 NEQ 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 ATOM0 23 SETGLOBAL T200-getfield2 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t090-acc5.ml0000644000175000017500000000113012124403241022551 0ustar tootstootsopen Lib;; let x = true in let y = false in let z = false in let a = false in let b = false in let c = false in (); if not x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONST0 11 PUSHCONST0 12 PUSHCONST0 13 PUSHCONST0 14 PUSHCONST0 15 PUSHCONST0 16 ACC5 17 BOOLNOT 18 BRANCHIFNOT 25 20 GETGLOBAL Not_found 22 MAKEBLOCK1 0 24 RAISE 25 POP 6 27 ATOM0 28 SETGLOBAL T090-acc5 30 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t350-heapcheck.ml0000644000175000017500000014700212124403241023661 0ustar tootstootsopen Lib;; ignore (Gc.stat ()); let x = Array.make 20 "" in let w = weak_create 20 in for i = 0 to 19 do x.(i) <- String.make 20 's'; weak_set w i (Some x.(i)); done; Gc.full_major (); for i = 0 to 19 do match weak_get w i with | None -> raise Not_found | _ -> () done; for i = 0 to 19 do if i mod 2 = 0 then x.(i) <- "" done; Gc.full_major (); for i = 0 to 19 do match weak_get w i with | None when i mod 2 = 0 -> () | Some s when i mod 2 = 1 -> if s.[5] <> 's' then raise Not_found | _ -> raise Not_found done ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 746 11 RESTART 12 GRAB 1 14 ACC0 15 BRANCHIFNOT 28 17 ACC1 18 PUSHACC1 19 GETFIELD1 20 PUSHOFFSETCLOSURE0 21 APPLY2 22 PUSHACC1 23 GETFIELD0 24 MAKEBLOCK2 0 26 RETURN 2 28 ACC1 29 RETURN 2 31 RESTART 32 GRAB 3 34 CONST0 35 PUSHACC4 36 LEINT 37 BRANCHIFNOT 42 39 CONST0 40 RETURN 4 42 ACC3 43 PUSHACC3 44 PUSHACC3 45 PUSHACC3 46 C_CALL4 caml_input 48 PUSHCONST0 49 PUSHACC1 50 EQ 51 BRANCHIFNOT 58 53 GETGLOBAL End_of_file 55 MAKEBLOCK1 0 57 RAISE 58 ACC0 59 PUSHACC5 60 SUBINT 61 PUSHACC1 62 PUSHACC5 63 ADDINT 64 PUSHACC4 65 PUSHACC4 66 PUSHOFFSETCLOSURE0 67 APPTERM 4, 9 70 ACC0 71 C_CALL1 caml_input_scan_line 73 PUSHCONST0 74 PUSHACC1 75 EQ 76 BRANCHIFNOT 83 78 GETGLOBAL End_of_file 80 MAKEBLOCK1 0 82 RAISE 83 CONST0 84 PUSHACC1 85 GTINT 86 BRANCHIFNOT 107 88 ACC0 89 OFFSETINT -1 91 C_CALL1 create_string 93 PUSHACC1 94 OFFSETINT -1 96 PUSHCONST0 97 PUSHACC2 98 PUSHACC5 99 C_CALL4 caml_input 101 ACC2 102 C_CALL1 caml_input_char 104 ACC0 105 RETURN 3 107 ACC0 108 NEGINT 109 C_CALL1 create_string 111 PUSHACC1 112 NEGINT 113 PUSHCONST0 114 PUSHACC2 115 PUSHACC5 116 C_CALL4 caml_input 118 CONST0 119 PUSHTRAP 130 121 ACC6 122 PUSHOFFSETCLOSURE0 123 APPLY1 124 PUSHACC5 125 PUSHENVACC1 126 APPLY2 127 POPTRAP 128 RETURN 3 130 PUSHGETGLOBAL End_of_file 132 PUSHACC1 133 GETFIELD0 134 EQ 135 BRANCHIFNOT 140 137 ACC1 138 RETURN 4 140 ACC0 141 RAISE 142 ACC0 143 C_CALL1 caml_flush 145 RETURN 1 147 RESTART 148 GRAB 1 150 ACC1 151 PUSHACC1 152 C_CALL2 caml_output_char 154 RETURN 2 156 RESTART 157 GRAB 1 159 ACC1 160 PUSHACC1 161 C_CALL2 caml_output_char 163 RETURN 2 165 RESTART 166 GRAB 1 168 ACC1 169 PUSHACC1 170 C_CALL2 caml_output_int 172 RETURN 2 174 RESTART 175 GRAB 1 177 ACC1 178 PUSHACC1 179 C_CALL2 caml_seek_out 181 RETURN 2 183 ACC0 184 C_CALL1 caml_pos_out 186 RETURN 1 188 ACC0 189 C_CALL1 caml_channel_size 191 RETURN 1 193 RESTART 194 GRAB 1 196 ACC1 197 PUSHACC1 198 C_CALL2 caml_set_binary_mode 200 RETURN 2 202 ACC0 203 C_CALL1 caml_input_char 205 RETURN 1 207 ACC0 208 C_CALL1 caml_input_char 210 RETURN 1 212 ACC0 213 C_CALL1 caml_input_int 215 RETURN 1 217 ACC0 218 C_CALL1 input_value 220 RETURN 1 222 RESTART 223 GRAB 1 225 ACC1 226 PUSHACC1 227 C_CALL2 caml_seek_in 229 RETURN 2 231 ACC0 232 C_CALL1 caml_pos_in 234 RETURN 1 236 ACC0 237 C_CALL1 caml_channel_size 239 RETURN 1 241 ACC0 242 C_CALL1 caml_close_channel 244 RETURN 1 246 RESTART 247 GRAB 1 249 ACC1 250 PUSHACC1 251 C_CALL2 caml_set_binary_mode 253 RETURN 2 255 CONST0 256 PUSHENVACC1 257 APPLY1 258 ACC0 259 C_CALL1 sys_exit 261 RETURN 1 263 CONST0 264 PUSHENVACC1 265 GETFIELD0 266 APPTERM1 2 268 CONST0 269 PUSHENVACC1 270 APPLY1 271 CONST0 272 PUSHENVACC2 273 APPTERM1 2 275 ENVACC1 276 GETFIELD0 277 PUSHACC0 278 PUSHACC2 279 CLOSURE 2, 268 282 PUSHENVACC1 283 SETFIELD0 284 RETURN 2 286 ENVACC1 287 C_CALL1 caml_flush 289 ENVACC2 290 C_CALL1 caml_flush 292 RETURN 1 294 CONST0 295 PUSHENVACC1 296 APPLY1 297 C_CALL1 float_of_string 299 RETURN 1 301 CONST0 302 PUSHENVACC1 303 APPLY1 304 C_CALL1 int_of_string 306 RETURN 1 308 ENVACC2 309 C_CALL1 caml_flush 311 ENVACC1 312 PUSHENVACC3 313 APPTERM1 2 315 CONSTINT 13 317 PUSHENVACC1 318 C_CALL2 caml_output_char 320 ENVACC1 321 C_CALL1 caml_flush 323 RETURN 1 325 ACC0 326 PUSHENVACC1 327 PUSHENVACC2 328 APPLY2 329 CONSTINT 13 331 PUSHENVACC1 332 C_CALL2 caml_output_char 334 ENVACC1 335 C_CALL1 caml_flush 337 RETURN 1 339 ACC0 340 PUSHENVACC1 341 APPLY1 342 PUSHENVACC2 343 PUSHENVACC3 344 APPTERM2 3 346 ACC0 347 PUSHENVACC1 348 APPLY1 349 PUSHENVACC2 350 PUSHENVACC3 351 APPTERM2 3 353 ACC0 354 PUSHENVACC1 355 PUSHENVACC2 356 APPTERM2 3 358 ACC0 359 PUSHENVACC1 360 C_CALL2 caml_output_char 362 RETURN 1 364 CONSTINT 13 366 PUSHENVACC1 367 C_CALL2 caml_output_char 369 ENVACC1 370 C_CALL1 caml_flush 372 RETURN 1 374 ACC0 375 PUSHENVACC1 376 PUSHENVACC2 377 APPLY2 378 CONSTINT 13 380 PUSHENVACC1 381 C_CALL2 caml_output_char 383 RETURN 1 385 ACC0 386 PUSHENVACC1 387 APPLY1 388 PUSHENVACC2 389 PUSHENVACC3 390 APPTERM2 3 392 ACC0 393 PUSHENVACC1 394 APPLY1 395 PUSHENVACC2 396 PUSHENVACC3 397 APPTERM2 3 399 ACC0 400 PUSHENVACC1 401 PUSHENVACC2 402 APPTERM2 3 404 ACC0 405 PUSHENVACC1 406 C_CALL2 caml_output_char 408 RETURN 1 410 RESTART 411 GRAB 3 413 CONST0 414 PUSHACC3 415 LTINT 416 BRANCHIF 427 418 ACC1 419 C_CALL1 ml_string_length 421 PUSHACC4 422 PUSHACC4 423 ADDINT 424 GTINT 425 BRANCHIFNOT 432 427 GETGLOBAL "really_input" 429 PUSHENVACC1 430 APPTERM1 5 432 ACC3 433 PUSHACC3 434 PUSHACC3 435 PUSHACC3 436 PUSHENVACC2 437 APPTERM 4, 8 440 RESTART 441 GRAB 3 443 CONST0 444 PUSHACC3 445 LTINT 446 BRANCHIF 457 448 ACC1 449 C_CALL1 ml_string_length 451 PUSHACC4 452 PUSHACC4 453 ADDINT 454 GTINT 455 BRANCHIFNOT 462 457 GETGLOBAL "input" 459 PUSHENVACC1 460 APPTERM1 5 462 ACC3 463 PUSHACC3 464 PUSHACC3 465 PUSHACC3 466 C_CALL4 caml_input 468 RETURN 4 470 ACC0 471 PUSHCONST0 472 PUSHGETGLOBAL <0>(0, <0>(6, 0)) 474 PUSHENVACC1 475 APPTERM3 4 477 ACC0 478 PUSHCONST0 479 PUSHGETGLOBAL <0>(0, <0>(7, 0)) 481 PUSHENVACC1 482 APPTERM3 4 484 RESTART 485 GRAB 2 487 ACC1 488 PUSHACC1 489 PUSHACC4 490 C_CALL3 sys_open 492 C_CALL1 caml_open_descriptor 494 RETURN 3 496 ACC0 497 C_CALL1 caml_flush 499 ACC0 500 C_CALL1 caml_close_channel 502 RETURN 1 504 RESTART 505 GRAB 1 507 CONST0 508 PUSHACC2 509 PUSHACC2 510 C_CALL3 output_value 512 RETURN 2 514 RESTART 515 GRAB 3 517 CONST0 518 PUSHACC3 519 LTINT 520 BRANCHIF 531 522 ACC1 523 C_CALL1 ml_string_length 525 PUSHACC4 526 PUSHACC4 527 ADDINT 528 GTINT 529 BRANCHIFNOT 536 531 GETGLOBAL "output" 533 PUSHENVACC1 534 APPTERM1 5 536 ACC3 537 PUSHACC3 538 PUSHACC3 539 PUSHACC3 540 C_CALL4 caml_output 542 RETURN 4 544 RESTART 545 GRAB 1 547 ACC1 548 C_CALL1 ml_string_length 550 PUSHCONST0 551 PUSHACC3 552 PUSHACC3 553 C_CALL4 caml_output 555 RETURN 2 557 ACC0 558 PUSHCONSTINT 438 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0)))) 562 PUSHENVACC1 563 APPTERM3 4 565 ACC0 566 PUSHCONSTINT 438 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0)))) 570 PUSHENVACC1 571 APPTERM3 4 573 RESTART 574 GRAB 2 576 ACC1 577 PUSHACC1 578 PUSHACC4 579 C_CALL3 sys_open 581 C_CALL1 caml_open_descriptor 583 RETURN 3 585 ACC0 586 PUSHGETGLOBAL "%.12g" 588 C_CALL2 format_float 590 RETURN 1 592 ACC0 593 PUSHGETGLOBAL "%d" 595 C_CALL2 format_int 597 RETURN 1 599 GETGLOBAL "false" 601 PUSHACC1 602 C_CALL2 string_equal 604 BRANCHIFNOT 609 606 CONST0 607 RETURN 1 609 GETGLOBAL "true" 611 PUSHACC1 612 C_CALL2 string_equal 614 BRANCHIFNOT 619 616 CONST1 617 RETURN 1 619 GETGLOBAL "bool_of_string" 621 PUSHENVACC1 622 APPTERM1 2 624 ACC0 625 BRANCHIFNOT 631 627 GETGLOBAL "true" 629 RETURN 1 631 GETGLOBAL "false" 633 RETURN 1 635 CONST0 636 PUSHACC1 637 LTINT 638 BRANCHIF 646 640 CONSTINT 255 642 PUSHACC1 643 GTINT 644 BRANCHIFNOT 651 646 GETGLOBAL "char_of_int" 648 PUSHENVACC1 649 APPTERM1 2 651 ACC0 652 RETURN 1 654 RESTART 655 GRAB 1 657 ACC0 658 C_CALL1 ml_string_length 660 PUSHACC2 661 C_CALL1 ml_string_length 663 PUSHACC0 664 PUSHACC2 665 ADDINT 666 C_CALL1 create_string 668 PUSHACC2 669 PUSHCONST0 670 PUSHACC2 671 PUSHCONST0 672 PUSHACC7 673 C_CALL5 blit_string 675 ACC1 676 PUSHACC3 677 PUSHACC2 678 PUSHCONST0 679 PUSHACC 8 681 C_CALL5 blit_string 683 ACC0 684 RETURN 5 686 CONSTINT -1 688 PUSHACC1 689 XORINT 690 RETURN 1 692 CONST0 693 PUSHACC1 694 GEINT 695 BRANCHIFNOT 700 697 ACC0 698 RETURN 1 700 ACC0 701 NEGINT 702 RETURN 1 704 RESTART 705 GRAB 1 707 ACC1 708 PUSHACC1 709 C_CALL2 greaterequal 711 BRANCHIFNOT 716 713 ACC0 714 RETURN 2 716 ACC1 717 RETURN 2 719 RESTART 720 GRAB 1 722 ACC1 723 PUSHACC1 724 C_CALL2 lessequal 726 BRANCHIFNOT 731 728 ACC0 729 RETURN 2 731 ACC1 732 RETURN 2 734 ACC0 735 PUSHGETGLOBAL Invalid_argument 737 MAKEBLOCK2 0 739 RAISE 740 ACC0 741 PUSHGETGLOBAL Failure 743 MAKEBLOCK2 0 745 RAISE 746 CLOSURE 0, 740 749 PUSH 750 CLOSURE 0, 734 753 PUSHGETGLOBAL "Pervasives.Exit" 755 MAKEBLOCK1 0 757 PUSHGETGLOBAL "Pervasives.Assert_failure" 759 MAKEBLOCK1 0 761 PUSH 762 CLOSURE 0, 720 765 PUSH 766 CLOSURE 0, 705 769 PUSH 770 CLOSURE 0, 692 773 PUSH 774 CLOSURE 0, 686 777 PUSHCONST0 778 PUSHCONSTINT 31 780 PUSHCONST1 781 LSLINT 782 EQ 783 BRANCHIFNOT 789 785 CONSTINT 30 787 BRANCH 791 789 CONSTINT 62 791 PUSHCONST1 792 LSLINT 793 PUSHACC0 794 OFFSETINT -1 796 PUSH 797 CLOSURE 0, 655 800 PUSHACC 9 802 CLOSURE 1, 635 805 PUSH 806 CLOSURE 0, 624 809 PUSHACC 11 811 CLOSURE 1, 599 814 PUSH 815 CLOSURE 0, 592 818 PUSH 819 CLOSURE 0, 585 822 PUSH 823 CLOSUREREC 0, 12 827 CONST0 828 C_CALL1 caml_open_descriptor 830 PUSHCONST1 831 C_CALL1 caml_open_descriptor 833 PUSHCONST2 834 C_CALL1 caml_open_descriptor 836 PUSH 837 CLOSURE 0, 574 840 PUSHACC0 841 CLOSURE 1, 565 844 PUSHACC1 845 CLOSURE 1, 557 848 PUSH 849 CLOSURE 0, 545 852 PUSHACC 22 854 CLOSURE 1, 515 857 PUSH 858 CLOSURE 0, 505 861 PUSH 862 CLOSURE 0, 496 865 PUSH 866 CLOSURE 0, 485 869 PUSHACC0 870 CLOSURE 1, 477 873 PUSHACC1 874 CLOSURE 1, 470 877 PUSHACC 28 879 CLOSURE 1, 441 882 PUSH 883 CLOSUREREC 0, 32 887 ACC0 888 PUSHACC 31 890 CLOSURE 2, 411 893 PUSHACC 22 895 CLOSUREREC 1, 70 899 ACC 15 901 CLOSURE 1, 404 904 PUSHACC 11 906 PUSHACC 17 908 CLOSURE 2, 399 911 PUSHACC 12 913 PUSHACC 18 915 PUSHACC 23 917 CLOSURE 3, 392 920 PUSHACC 13 922 PUSHACC 19 924 PUSHACC 23 926 CLOSURE 3, 385 929 PUSHACC 14 931 PUSHACC 20 933 CLOSURE 2, 374 936 PUSHACC 20 938 CLOSURE 1, 364 941 PUSHACC 20 943 CLOSURE 1, 358 946 PUSHACC 17 948 PUSHACC 22 950 CLOSURE 2, 353 953 PUSHACC 18 955 PUSHACC 23 957 PUSHACC 29 959 CLOSURE 3, 346 962 PUSHACC 19 964 PUSHACC 24 966 PUSHACC 29 968 CLOSURE 3, 339 971 PUSHACC 20 973 PUSHACC 25 975 CLOSURE 2, 325 978 PUSHACC 25 980 CLOSURE 1, 315 983 PUSHACC 12 985 PUSHACC 28 987 PUSHACC 30 989 CLOSURE 3, 308 992 PUSHACC0 993 CLOSURE 1, 301 996 PUSHACC1 997 CLOSURE 1, 294 1000 PUSHACC 29 1002 PUSHACC 31 1004 CLOSURE 2, 286 1007 MAKEBLOCK1 0 1009 PUSHACC0 1010 CLOSURE 1, 275 1013 PUSHACC1 1014 CLOSURE 1, 263 1017 PUSHACC0 1018 CLOSURE 1, 255 1021 PUSHACC1 1022 PUSHACC 22 1024 PUSHACC4 1025 PUSHACC3 1026 PUSH 1027 CLOSURE 0, 247 1030 PUSH 1031 CLOSURE 0, 241 1034 PUSH 1035 CLOSURE 0, 236 1038 PUSH 1039 CLOSURE 0, 231 1042 PUSH 1043 CLOSURE 0, 223 1046 PUSH 1047 CLOSURE 0, 217 1050 PUSH 1051 CLOSURE 0, 212 1054 PUSH 1055 CLOSURE 0, 207 1058 PUSHACC 32 1060 PUSHACC 35 1062 PUSHACC 33 1064 PUSH 1065 CLOSURE 0, 202 1068 PUSHACC 41 1070 PUSHACC 40 1072 PUSHACC 42 1074 PUSH 1075 CLOSURE 0, 194 1078 PUSHACC 46 1080 PUSH 1081 CLOSURE 0, 188 1084 PUSH 1085 CLOSURE 0, 183 1088 PUSH 1089 CLOSURE 0, 175 1092 PUSHACC 51 1094 PUSH 1095 CLOSURE 0, 166 1098 PUSH 1099 CLOSURE 0, 157 1102 PUSHACC 55 1104 PUSHACC 57 1106 PUSH 1107 CLOSURE 0, 148 1110 PUSH 1111 CLOSURE 0, 142 1114 PUSHACC 63 1116 PUSHACC 62 1118 PUSHACC 64 1120 PUSHACC 38 1122 PUSHACC 40 1124 PUSHACC 42 1126 PUSHACC 44 1128 PUSHACC 46 1130 PUSHACC 48 1132 PUSHACC 50 1134 PUSHACC 52 1136 PUSHACC 54 1138 PUSHACC 56 1140 PUSHACC 58 1142 PUSHACC 60 1144 PUSHACC 62 1146 PUSHACC 64 1148 PUSHACC 66 1150 PUSHACC 82 1152 PUSHACC 84 1154 PUSHACC 86 1156 PUSHACC 88 1158 PUSHACC 90 1160 PUSHACC 92 1162 PUSHACC 94 1164 PUSHACC 96 1166 PUSHACC 98 1168 PUSHACC 100 1170 PUSHACC 104 1172 PUSHACC 104 1174 PUSHACC 104 1176 PUSHACC 108 1178 PUSHACC 110 1180 PUSHACC 112 1182 PUSHACC 117 1184 PUSHACC 117 1186 PUSHACC 117 1188 PUSHACC 117 1190 MAKEBLOCK 69, 0 1193 POP 53 1195 SETGLOBAL Pervasives 1197 BRANCH 2177 1199 RESTART 1200 GRAB 1 1202 ACC1 1203 BRANCHIFNOT 1213 1205 ACC1 1206 GETFIELD1 1207 PUSHACC1 1208 OFFSETINT 1 1210 PUSHOFFSETCLOSURE0 1211 APPTERM2 4 1213 ACC0 1214 RETURN 2 1216 RESTART 1217 GRAB 1 1219 ACC0 1220 BRANCHIFNOT 1251 1222 CONST0 1223 PUSHACC2 1224 EQ 1225 BRANCHIFNOT 1231 1227 ACC0 1228 GETFIELD0 1229 RETURN 2 1231 CONST0 1232 PUSHACC2 1233 GTINT 1234 BRANCHIFNOT 1244 1236 ACC1 1237 OFFSETINT -1 1239 PUSHACC1 1240 GETFIELD1 1241 PUSHOFFSETCLOSURE0 1242 APPTERM2 4 1244 GETGLOBAL "List.nth" 1246 PUSHGETGLOBALFIELD Pervasives, 2 1249 APPTERM1 3 1251 GETGLOBAL "nth" 1253 PUSHGETGLOBALFIELD Pervasives, 3 1256 APPTERM1 3 1258 RESTART 1259 GRAB 1 1261 ACC0 1262 BRANCHIFNOT 1274 1264 ACC1 1265 PUSHACC1 1266 GETFIELD0 1267 MAKEBLOCK2 0 1269 PUSHACC1 1270 GETFIELD1 1271 PUSHOFFSETCLOSURE0 1272 APPTERM2 4 1274 ACC1 1275 RETURN 2 1277 ACC0 1278 BRANCHIFNOT 1291 1280 ACC0 1281 GETFIELD1 1282 PUSHOFFSETCLOSURE0 1283 APPLY1 1284 PUSHACC1 1285 GETFIELD0 1286 PUSHGETGLOBALFIELD Pervasives, 16 1289 APPTERM2 3 1291 RETURN 1 1293 RESTART 1294 GRAB 1 1296 ACC1 1297 BRANCHIFNOT 1313 1299 ACC1 1300 GETFIELD0 1301 PUSHACC1 1302 APPLY1 1303 PUSHACC2 1304 GETFIELD1 1305 PUSHACC2 1306 PUSHOFFSETCLOSURE0 1307 APPLY2 1308 PUSHACC1 1309 MAKEBLOCK2 0 1311 POP 1 1313 RETURN 2 1315 RESTART 1316 GRAB 1 1318 ACC1 1319 BRANCHIFNOT 1331 1321 ACC1 1322 GETFIELD0 1323 PUSHACC1 1324 APPLY1 1325 ACC1 1326 GETFIELD1 1327 PUSHACC1 1328 PUSHOFFSETCLOSURE0 1329 APPTERM2 4 1331 RETURN 2 1333 RESTART 1334 GRAB 2 1336 ACC2 1337 BRANCHIFNOT 1350 1339 ACC2 1340 GETFIELD1 1341 PUSHACC3 1342 GETFIELD0 1343 PUSHACC3 1344 PUSHACC3 1345 APPLY2 1346 PUSHACC2 1347 PUSHOFFSETCLOSURE0 1348 APPTERM3 6 1350 ACC1 1351 RETURN 3 1353 RESTART 1354 GRAB 2 1356 ACC1 1357 BRANCHIFNOT 1370 1359 ACC2 1360 PUSHACC2 1361 GETFIELD1 1362 PUSHACC2 1363 PUSHOFFSETCLOSURE0 1364 APPLY3 1365 PUSHACC2 1366 GETFIELD0 1367 PUSHACC2 1368 APPTERM2 5 1370 ACC2 1371 RETURN 3 1373 RESTART 1374 GRAB 2 1376 ACC1 1377 BRANCHIFNOT 1400 1379 ACC2 1380 BRANCHIFNOT 1407 1382 ACC2 1383 GETFIELD0 1384 PUSHACC2 1385 GETFIELD0 1386 PUSHACC2 1387 APPLY2 1388 PUSHACC3 1389 GETFIELD1 1390 PUSHACC3 1391 GETFIELD1 1392 PUSHACC3 1393 PUSHOFFSETCLOSURE0 1394 APPLY3 1395 PUSHACC1 1396 MAKEBLOCK2 0 1398 RETURN 4 1400 ACC2 1401 BRANCHIFNOT 1405 1403 BRANCH 1407 1405 RETURN 3 1407 GETGLOBAL "List.map2" 1409 PUSHGETGLOBALFIELD Pervasives, 2 1412 APPTERM1 4 1414 RESTART 1415 GRAB 2 1417 ACC1 1418 BRANCHIFNOT 1437 1420 ACC2 1421 BRANCHIFNOT 1444 1423 ACC2 1424 GETFIELD0 1425 PUSHACC2 1426 GETFIELD0 1427 PUSHACC2 1428 APPLY2 1429 ACC2 1430 GETFIELD1 1431 PUSHACC2 1432 GETFIELD1 1433 PUSHACC2 1434 PUSHOFFSETCLOSURE0 1435 APPTERM3 6 1437 ACC2 1438 BRANCHIFNOT 1442 1440 BRANCH 1444 1442 RETURN 3 1444 GETGLOBAL "List.iter2" 1446 PUSHGETGLOBALFIELD Pervasives, 2 1449 APPTERM1 4 1451 RESTART 1452 GRAB 3 1454 ACC2 1455 BRANCHIFNOT 1476 1457 ACC3 1458 BRANCHIFNOT 1482 1460 ACC3 1461 GETFIELD1 1462 PUSHACC3 1463 GETFIELD1 1464 PUSHACC5 1465 GETFIELD0 1466 PUSHACC5 1467 GETFIELD0 1468 PUSHACC5 1469 PUSHACC5 1470 APPLY3 1471 PUSHACC3 1472 PUSHOFFSETCLOSURE0 1473 APPTERM 4, 8 1476 ACC3 1477 BRANCHIF 1482 1479 ACC1 1480 RETURN 4 1482 GETGLOBAL "List.fold_left2" 1484 PUSHGETGLOBALFIELD Pervasives, 2 1487 APPTERM1 5 1489 RESTART 1490 GRAB 3 1492 ACC1 1493 BRANCHIFNOT 1516 1495 ACC2 1496 BRANCHIFNOT 1522 1498 PUSH_RETADDR 1509 1500 ACC6 1501 PUSHACC6 1502 GETFIELD1 1503 PUSHACC6 1504 GETFIELD1 1505 PUSHACC6 1506 PUSHOFFSETCLOSURE0 1507 APPLY 4 1509 PUSHACC3 1510 GETFIELD0 1511 PUSHACC3 1512 GETFIELD0 1513 PUSHACC3 1514 APPTERM3 7 1516 ACC2 1517 BRANCHIF 1522 1519 ACC3 1520 RETURN 4 1522 GETGLOBAL "List.fold_right2" 1524 PUSHGETGLOBALFIELD Pervasives, 2 1527 APPTERM1 5 1529 RESTART 1530 GRAB 1 1532 ACC1 1533 BRANCHIFNOT 1549 1535 ACC1 1536 GETFIELD0 1537 PUSHACC1 1538 APPLY1 1539 BRANCHIFNOT 1547 1541 ACC1 1542 GETFIELD1 1543 PUSHACC1 1544 PUSHOFFSETCLOSURE0 1545 APPTERM2 4 1547 RETURN 2 1549 CONST1 1550 RETURN 2 1552 RESTART 1553 GRAB 1 1555 ACC1 1556 BRANCHIFNOT 1570 1558 ACC1 1559 GETFIELD0 1560 PUSHACC1 1561 APPLY1 1562 BRANCHIF 1570 1564 ACC1 1565 GETFIELD1 1566 PUSHACC1 1567 PUSHOFFSETCLOSURE0 1568 APPTERM2 4 1570 RETURN 2 1572 RESTART 1573 GRAB 2 1575 ACC1 1576 BRANCHIFNOT 1599 1578 ACC2 1579 BRANCHIFNOT 1605 1581 ACC2 1582 GETFIELD0 1583 PUSHACC2 1584 GETFIELD0 1585 PUSHACC2 1586 APPLY2 1587 BRANCHIFNOT 1597 1589 ACC2 1590 GETFIELD1 1591 PUSHACC2 1592 GETFIELD1 1593 PUSHACC2 1594 PUSHOFFSETCLOSURE0 1595 APPTERM3 6 1597 RETURN 3 1599 ACC2 1600 BRANCHIF 1605 1602 CONST1 1603 RETURN 3 1605 GETGLOBAL "List.for_all2" 1607 PUSHGETGLOBALFIELD Pervasives, 2 1610 APPTERM1 4 1612 RESTART 1613 GRAB 2 1615 ACC1 1616 BRANCHIFNOT 1639 1618 ACC2 1619 BRANCHIFNOT 1646 1621 ACC2 1622 GETFIELD0 1623 PUSHACC2 1624 GETFIELD0 1625 PUSHACC2 1626 APPLY2 1627 BRANCHIF 1637 1629 ACC2 1630 GETFIELD1 1631 PUSHACC2 1632 GETFIELD1 1633 PUSHACC2 1634 PUSHOFFSETCLOSURE0 1635 APPTERM3 6 1637 RETURN 3 1639 ACC2 1640 BRANCHIFNOT 1644 1642 BRANCH 1646 1644 RETURN 3 1646 GETGLOBAL "List.exists2" 1648 PUSHGETGLOBALFIELD Pervasives, 2 1651 APPTERM1 4 1653 RESTART 1654 GRAB 1 1656 ACC1 1657 BRANCHIFNOT 1672 1659 ACC0 1660 PUSHACC2 1661 GETFIELD0 1662 C_CALL2 equal 1664 BRANCHIF 1672 1666 ACC1 1667 GETFIELD1 1668 PUSHACC1 1669 PUSHOFFSETCLOSURE0 1670 APPTERM2 4 1672 RETURN 2 1674 RESTART 1675 GRAB 1 1677 ACC1 1678 BRANCHIFNOT 1692 1680 ACC0 1681 PUSHACC2 1682 GETFIELD0 1683 EQ 1684 BRANCHIF 1692 1686 ACC1 1687 GETFIELD1 1688 PUSHACC1 1689 PUSHOFFSETCLOSURE0 1690 APPTERM2 4 1692 RETURN 2 1694 RESTART 1695 GRAB 1 1697 ACC1 1698 BRANCHIFNOT 1719 1700 ACC1 1701 GETFIELD0 1702 PUSHACC1 1703 PUSHACC1 1704 GETFIELD0 1705 C_CALL2 equal 1707 BRANCHIFNOT 1713 1709 ACC0 1710 GETFIELD1 1711 RETURN 3 1713 ACC2 1714 GETFIELD1 1715 PUSHACC2 1716 PUSHOFFSETCLOSURE0 1717 APPTERM2 5 1719 GETGLOBAL Not_found 1721 MAKEBLOCK1 0 1723 RAISE 1724 RESTART 1725 GRAB 1 1727 ACC1 1728 BRANCHIFNOT 1748 1730 ACC1 1731 GETFIELD0 1732 PUSHACC1 1733 PUSHACC1 1734 GETFIELD0 1735 EQ 1736 BRANCHIFNOT 1742 1738 ACC0 1739 GETFIELD1 1740 RETURN 3 1742 ACC2 1743 GETFIELD1 1744 PUSHACC2 1745 PUSHOFFSETCLOSURE0 1746 APPTERM2 5 1748 GETGLOBAL Not_found 1750 MAKEBLOCK1 0 1752 RAISE 1753 RESTART 1754 GRAB 1 1756 ACC1 1757 BRANCHIFNOT 1773 1759 ACC0 1760 PUSHACC2 1761 GETFIELD0 1762 GETFIELD0 1763 C_CALL2 equal 1765 BRANCHIF 1773 1767 ACC1 1768 GETFIELD1 1769 PUSHACC1 1770 PUSHOFFSETCLOSURE0 1771 APPTERM2 4 1773 RETURN 2 1775 RESTART 1776 GRAB 1 1778 ACC1 1779 BRANCHIFNOT 1794 1781 ACC0 1782 PUSHACC2 1783 GETFIELD0 1784 GETFIELD0 1785 EQ 1786 BRANCHIF 1794 1788 ACC1 1789 GETFIELD1 1790 PUSHACC1 1791 PUSHOFFSETCLOSURE0 1792 APPTERM2 4 1794 RETURN 2 1796 RESTART 1797 GRAB 1 1799 ACC1 1800 BRANCHIFNOT 1825 1802 ACC1 1803 GETFIELD0 1804 PUSHACC2 1805 GETFIELD1 1806 PUSHACC2 1807 PUSHACC2 1808 GETFIELD0 1809 C_CALL2 equal 1811 BRANCHIFNOT 1816 1813 ACC0 1814 RETURN 4 1816 ACC0 1817 PUSHACC3 1818 PUSHOFFSETCLOSURE0 1819 APPLY2 1820 PUSHACC2 1821 MAKEBLOCK2 0 1823 POP 2 1825 RETURN 2 1827 RESTART 1828 GRAB 1 1830 ACC1 1831 BRANCHIFNOT 1855 1833 ACC1 1834 GETFIELD0 1835 PUSHACC2 1836 GETFIELD1 1837 PUSHACC2 1838 PUSHACC2 1839 GETFIELD0 1840 EQ 1841 BRANCHIFNOT 1846 1843 ACC0 1844 RETURN 4 1846 ACC0 1847 PUSHACC3 1848 PUSHOFFSETCLOSURE0 1849 APPLY2 1850 PUSHACC2 1851 MAKEBLOCK2 0 1853 POP 2 1855 RETURN 2 1857 RESTART 1858 GRAB 1 1860 ACC1 1861 BRANCHIFNOT 1879 1863 ACC1 1864 GETFIELD0 1865 PUSHACC0 1866 PUSHACC2 1867 APPLY1 1868 BRANCHIFNOT 1873 1870 ACC0 1871 RETURN 3 1873 ACC2 1874 GETFIELD1 1875 PUSHACC2 1876 PUSHOFFSETCLOSURE0 1877 APPTERM2 5 1879 GETGLOBAL Not_found 1881 MAKEBLOCK1 0 1883 RAISE 1884 RESTART 1885 GRAB 2 1887 ACC2 1888 BRANCHIFNOT 1917 1890 ACC2 1891 GETFIELD0 1892 PUSHACC3 1893 GETFIELD1 1894 PUSHACC1 1895 PUSHENVACC2 1896 APPLY1 1897 BRANCHIFNOT 1908 1899 ACC0 1900 PUSHACC4 1901 PUSHACC4 1902 PUSHACC4 1903 MAKEBLOCK2 0 1905 PUSHOFFSETCLOSURE0 1906 APPTERM3 8 1908 ACC0 1909 PUSHACC4 1910 PUSHACC3 1911 MAKEBLOCK2 0 1913 PUSHACC4 1914 PUSHOFFSETCLOSURE0 1915 APPTERM3 8 1917 ACC1 1918 PUSHENVACC1 1919 APPLY1 1920 PUSHACC1 1921 PUSHENVACC1 1922 APPLY1 1923 MAKEBLOCK2 0 1925 RETURN 3 1927 RESTART 1928 GRAB 1 1930 ACC0 1931 PUSHENVACC1 1932 CLOSUREREC 2, 1885 1936 ACC2 1937 PUSHCONST0 1938 PUSHCONST0 1939 PUSHACC3 1940 APPTERM3 6 1942 ACC0 1943 BRANCHIFNOT 1967 1945 ACC0 1946 GETFIELD0 1947 PUSHACC1 1948 GETFIELD1 1949 PUSHOFFSETCLOSURE0 1950 APPLY1 1951 PUSHACC0 1952 GETFIELD1 1953 PUSHACC2 1954 GETFIELD1 1955 MAKEBLOCK2 0 1957 PUSHACC1 1958 GETFIELD0 1959 PUSHACC3 1960 GETFIELD0 1961 MAKEBLOCK2 0 1963 MAKEBLOCK2 0 1965 RETURN 3 1967 GETGLOBAL <0>(0, 0) 1969 RETURN 1 1971 RESTART 1972 GRAB 1 1974 ACC0 1975 BRANCHIFNOT 1996 1977 ACC1 1978 BRANCHIFNOT 2003 1980 ACC1 1981 GETFIELD1 1982 PUSHACC1 1983 GETFIELD1 1984 PUSHOFFSETCLOSURE0 1985 APPLY2 1986 PUSHACC2 1987 GETFIELD0 1988 PUSHACC2 1989 GETFIELD0 1990 MAKEBLOCK2 0 1992 MAKEBLOCK2 0 1994 RETURN 2 1996 ACC1 1997 BRANCHIFNOT 2001 1999 BRANCH 2003 2001 RETURN 2 2003 GETGLOBAL "List.combine" 2005 PUSHGETGLOBALFIELD Pervasives, 2 2008 APPTERM1 3 2010 RESTART 2011 GRAB 1 2013 ACC1 2014 BRANCHIFNOT 2038 2016 ACC1 2017 GETFIELD0 2018 PUSHACC2 2019 GETFIELD1 2020 PUSHACC1 2021 PUSHENVACC2 2022 APPLY1 2023 BRANCHIFNOT 2033 2025 ACC0 2026 PUSHACC3 2027 PUSHACC3 2028 MAKEBLOCK2 0 2030 PUSHOFFSETCLOSURE0 2031 APPTERM2 6 2033 ACC0 2034 PUSHACC3 2035 PUSHOFFSETCLOSURE0 2036 APPTERM2 6 2038 ACC0 2039 PUSHENVACC1 2040 APPTERM1 3 2042 ACC0 2043 PUSHENVACC1 2044 CLOSUREREC 2, 2011 2048 CONST0 2049 PUSHACC1 2050 APPTERM1 3 2052 RESTART 2053 GRAB 2 2055 ACC1 2056 BRANCHIFNOT 2077 2058 ACC2 2059 BRANCHIFNOT 2084 2061 ACC2 2062 GETFIELD1 2063 PUSHACC2 2064 GETFIELD1 2065 PUSHACC2 2066 PUSHACC5 2067 GETFIELD0 2068 PUSHACC5 2069 GETFIELD0 2070 PUSHENVACC1 2071 APPLY2 2072 MAKEBLOCK2 0 2074 PUSHOFFSETCLOSURE0 2075 APPTERM3 6 2077 ACC2 2078 BRANCHIFNOT 2082 2080 BRANCH 2084 2082 RETURN 3 2084 GETGLOBAL "List.rev_map2" 2086 PUSHGETGLOBALFIELD Pervasives, 2 2089 APPTERM1 4 2091 RESTART 2092 GRAB 2 2094 ACC0 2095 CLOSUREREC 1, 2053 2099 ACC3 2100 PUSHACC3 2101 PUSHCONST0 2102 PUSHACC3 2103 APPTERM3 7 2105 RESTART 2106 GRAB 1 2108 ACC1 2109 BRANCHIFNOT 2123 2111 ACC1 2112 GETFIELD1 2113 PUSHACC1 2114 PUSHACC3 2115 GETFIELD0 2116 PUSHENVACC1 2117 APPLY1 2118 MAKEBLOCK2 0 2120 PUSHOFFSETCLOSURE0 2121 APPTERM2 4 2123 ACC0 2124 RETURN 2 2126 RESTART 2127 GRAB 1 2129 ACC0 2130 CLOSUREREC 1, 2106 2134 ACC2 2135 PUSHCONST0 2136 PUSHACC2 2137 APPTERM2 5 2139 CONST0 2140 PUSHACC1 2141 PUSHENVACC1 2142 APPTERM2 3 2144 ACC0 2145 BRANCHIFNOT 2151 2147 ACC0 2148 GETFIELD1 2149 RETURN 1 2151 GETGLOBAL "tl" 2153 PUSHGETGLOBALFIELD Pervasives, 3 2156 APPTERM1 2 2158 ACC0 2159 BRANCHIFNOT 2165 2161 ACC0 2162 GETFIELD0 2163 RETURN 1 2165 GETGLOBAL "hd" 2167 PUSHGETGLOBALFIELD Pervasives, 3 2170 APPTERM1 2 2172 ACC0 2173 PUSHCONST0 2174 PUSHENVACC1 2175 APPTERM2 3 2177 CLOSUREREC 0, 1200 2181 ACC0 2182 CLOSURE 1, 2172 2185 PUSH 2186 CLOSURE 0, 2158 2189 PUSH 2190 CLOSURE 0, 2144 2193 PUSH 2194 CLOSUREREC 0, 1217 2198 GETGLOBALFIELD Pervasives, 16 2201 PUSH 2202 CLOSUREREC 0, 1259 2206 ACC0 2207 CLOSURE 1, 2139 2210 PUSH 2211 CLOSUREREC 0, 1277 2215 CLOSUREREC 0, 1294 2219 CLOSURE 0, 2127 2222 PUSH 2223 CLOSUREREC 0, 1316 2227 CLOSUREREC 0, 1334 2231 CLOSUREREC 0, 1354 2235 CLOSUREREC 0, 1374 2239 CLOSURE 0, 2092 2242 PUSH 2243 CLOSUREREC 0, 1415 2247 CLOSUREREC 0, 1452 2251 CLOSUREREC 0, 1490 2255 CLOSUREREC 0, 1530 2259 CLOSUREREC 0, 1553 2263 CLOSUREREC 0, 1573 2267 CLOSUREREC 0, 1613 2271 CLOSUREREC 0, 1654 2275 CLOSUREREC 0, 1675 2279 CLOSUREREC 0, 1695 2283 CLOSUREREC 0, 1725 2287 CLOSUREREC 0, 1754 2291 CLOSUREREC 0, 1776 2295 CLOSUREREC 0, 1797 2299 CLOSUREREC 0, 1828 2303 CLOSUREREC 0, 1858 2307 ACC 24 2309 CLOSURE 1, 2042 2312 PUSHACC 25 2314 CLOSUREREC 1, 1928 2318 CLOSUREREC 0, 1942 2322 CLOSUREREC 0, 1972 2326 ACC0 2327 PUSHACC2 2328 PUSHACC7 2329 PUSHACC 9 2331 PUSHACC 11 2333 PUSHACC 13 2335 PUSHACC 15 2337 PUSHACC 17 2339 PUSHACC 10 2341 PUSHACC 12 2343 PUSHACC 13 2345 PUSHACC 15 2347 PUSHACC 23 2349 PUSHACC 25 2351 PUSHACC 27 2353 PUSHACC 29 2355 PUSHACC 31 2357 PUSHACC 33 2359 PUSHACC 35 2361 PUSHACC 37 2363 PUSHACC 40 2365 PUSHACC 42 2367 PUSHACC 41 2369 PUSHACC 45 2371 PUSHACC 47 2373 PUSHACC 50 2375 PUSHACC 52 2377 PUSHACC 51 2379 PUSHACC 55 2381 PUSHACC 56 2383 PUSHACC 59 2385 PUSHACC 61 2387 PUSHACC 60 2389 PUSHACC 64 2391 PUSHACC 66 2393 PUSHACC 68 2395 PUSHACC 70 2397 MAKEBLOCK 37, 0 2400 POP 36 2402 SETGLOBAL List 2404 BRANCH 2622 2406 CONSTINT 97 2408 PUSHACC1 2409 GEINT 2410 BRANCHIFNOT 2418 2412 CONSTINT 122 2414 PUSHACC1 2415 LEINT 2416 BRANCHIF 2442 2418 CONSTINT 224 2420 PUSHACC1 2421 GEINT 2422 BRANCHIFNOT 2430 2424 CONSTINT 246 2426 PUSHACC1 2427 LEINT 2428 BRANCHIF 2442 2430 CONSTINT 248 2432 PUSHACC1 2433 GEINT 2434 BRANCHIFNOT 2447 2436 CONSTINT 254 2438 PUSHACC1 2439 LEINT 2440 BRANCHIFNOT 2447 2442 ACC0 2443 OFFSETINT -32 2445 RETURN 1 2447 ACC0 2448 RETURN 1 2450 CONSTINT 65 2452 PUSHACC1 2453 GEINT 2454 BRANCHIFNOT 2462 2456 CONSTINT 90 2458 PUSHACC1 2459 LEINT 2460 BRANCHIF 2486 2462 CONSTINT 192 2464 PUSHACC1 2465 GEINT 2466 BRANCHIFNOT 2474 2468 CONSTINT 214 2470 PUSHACC1 2471 LEINT 2472 BRANCHIF 2486 2474 CONSTINT 216 2476 PUSHACC1 2477 GEINT 2478 BRANCHIFNOT 2491 2480 CONSTINT 222 2482 PUSHACC1 2483 LEINT 2484 BRANCHIFNOT 2491 2486 ACC0 2487 OFFSETINT 32 2489 RETURN 1 2491 ACC0 2492 RETURN 1 2494 CONSTINT 39 2496 PUSHACC1 2497 LTINT 2498 BRANCHIFNOT 2520 2500 CONSTINT 9 2502 PUSHACC1 2503 EQ 2504 BRANCHIFNOT 2510 2506 GETGLOBAL "\\t" 2508 RETURN 1 2510 CONSTINT 13 2512 PUSHACC1 2513 EQ 2514 BRANCHIFNOT 2540 2516 GETGLOBAL "\\n" 2518 RETURN 1 2520 CONSTINT 39 2522 PUSHACC1 2523 EQ 2524 BRANCHIFNOT 2530 2526 GETGLOBAL "\\'" 2528 RETURN 1 2530 CONSTINT 92 2532 PUSHACC1 2533 EQ 2534 BRANCHIFNOT 2540 2536 GETGLOBAL "\\\\" 2538 RETURN 1 2540 ACC0 2541 C_CALL1 is_printable 2543 BRANCHIFNOT 2555 2545 CONST1 2546 C_CALL1 create_string 2548 PUSHACC1 2549 PUSHCONST0 2550 PUSHACC2 2551 SETSTRINGCHAR 2552 ACC0 2553 RETURN 2 2555 ACC0 2556 PUSHCONSTINT 4 2558 C_CALL1 create_string 2560 PUSHCONSTINT 92 2562 PUSHCONST0 2563 PUSHACC2 2564 SETSTRINGCHAR 2565 CONSTINT 100 2567 PUSHACC2 2568 DIVINT 2569 PUSHCONSTINT 48 2571 ADDINT 2572 PUSHCONST1 2573 PUSHACC2 2574 SETSTRINGCHAR 2575 CONSTINT 10 2577 PUSHCONSTINT 10 2579 PUSHACC3 2580 DIVINT 2581 MODINT 2582 PUSHCONSTINT 48 2584 ADDINT 2585 PUSHCONST2 2586 PUSHACC2 2587 SETSTRINGCHAR 2588 CONSTINT 10 2590 PUSHACC2 2591 MODINT 2592 PUSHCONSTINT 48 2594 ADDINT 2595 PUSHCONST3 2596 PUSHACC2 2597 SETSTRINGCHAR 2598 ACC0 2599 RETURN 3 2601 CONST0 2602 PUSHACC1 2603 LTINT 2604 BRANCHIF 2612 2606 CONSTINT 255 2608 PUSHACC1 2609 GTINT 2610 BRANCHIFNOT 2619 2612 GETGLOBAL "Char.chr" 2614 PUSHGETGLOBALFIELD Pervasives, 2 2617 APPTERM1 2 2619 ACC0 2620 RETURN 1 2622 CLOSURE 0, 2601 2625 PUSH 2626 CLOSURE 0, 2494 2629 PUSH 2630 CLOSURE 0, 2450 2633 PUSH 2634 CLOSURE 0, 2406 2637 PUSHACC0 2638 PUSHACC2 2639 PUSHACC4 2640 PUSHACC6 2641 MAKEBLOCK 4, 0 2644 POP 4 2646 SETGLOBAL Char 2648 BRANCH 3540 2650 RESTART 2651 GRAB 3 2653 ACC1 2654 PUSHACC3 2655 GEINT 2656 BRANCHIFNOT 2663 2658 GETGLOBAL Not_found 2660 MAKEBLOCK1 0 2662 RAISE 2663 ACC3 2664 PUSHACC3 2665 PUSHACC2 2666 GETSTRINGCHAR 2667 EQ 2668 BRANCHIFNOT 2673 2670 ACC2 2671 RETURN 4 2673 ACC3 2674 PUSHACC3 2675 OFFSETINT 1 2677 PUSHACC3 2678 PUSHACC3 2679 PUSHOFFSETCLOSURE0 2680 APPTERM 4, 8 2683 RESTART 2684 GRAB 2 2686 CONST0 2687 PUSHACC2 2688 LTINT 2689 BRANCHIFNOT 2696 2691 GETGLOBAL Not_found 2693 MAKEBLOCK1 0 2695 RAISE 2696 ACC2 2697 PUSHACC2 2698 PUSHACC2 2699 GETSTRINGCHAR 2700 EQ 2701 BRANCHIFNOT 2706 2703 ACC1 2704 RETURN 3 2706 ACC2 2707 PUSHACC2 2708 OFFSETINT -1 2710 PUSHACC2 2711 PUSHOFFSETCLOSURE0 2712 APPTERM3 6 2714 RESTART 2715 GRAB 1 2717 ACC1 2718 PUSHCONST0 2719 PUSHACC2 2720 PUSHENVACC1 2721 APPTERM3 5 2723 RESTART 2724 GRAB 2 2726 CONST0 2727 PUSHACC2 2728 LTINT 2729 BRANCHIF 2738 2731 ACC0 2732 C_CALL1 ml_string_length 2734 PUSHACC2 2735 GEINT 2736 BRANCHIFNOT 2745 2738 GETGLOBAL "String.rcontains_from" 2740 PUSHGETGLOBALFIELD Pervasives, 2 2743 APPTERM1 4 2745 PUSHTRAP 2756 2747 ACC6 2748 PUSHACC6 2749 PUSHACC6 2750 PUSHENVACC1 2751 APPLY3 2752 CONST1 2753 POPTRAP 2754 RETURN 3 2756 PUSHGETGLOBAL Not_found 2758 PUSHACC1 2759 GETFIELD0 2760 EQ 2761 BRANCHIFNOT 2766 2763 CONST0 2764 RETURN 4 2766 ACC0 2767 RAISE 2768 RESTART 2769 GRAB 2 2771 CONST0 2772 PUSHACC2 2773 LTINT 2774 BRANCHIF 2783 2776 ACC0 2777 C_CALL1 ml_string_length 2779 PUSHACC2 2780 GTINT 2781 BRANCHIFNOT 2790 2783 GETGLOBAL "String.contains_from" 2785 PUSHGETGLOBALFIELD Pervasives, 2 2788 APPTERM1 4 2790 PUSHTRAP 2811 2792 PUSH_RETADDR 2807 2794 ACC 9 2796 PUSHACC 9 2798 PUSHACC 9 2800 C_CALL1 ml_string_length 2802 PUSHACC 10 2804 PUSHENVACC1 2805 APPLY 4 2807 CONST1 2808 POPTRAP 2809 RETURN 3 2811 PUSHGETGLOBAL Not_found 2813 PUSHACC1 2814 GETFIELD0 2815 EQ 2816 BRANCHIFNOT 2821 2818 CONST0 2819 RETURN 4 2821 ACC0 2822 RAISE 2823 RESTART 2824 GRAB 2 2826 CONST0 2827 PUSHACC2 2828 LTINT 2829 BRANCHIF 2838 2831 ACC0 2832 C_CALL1 ml_string_length 2834 PUSHACC2 2835 GEINT 2836 BRANCHIFNOT 2845 2838 GETGLOBAL "String.rindex_from" 2840 PUSHGETGLOBALFIELD Pervasives, 2 2843 APPTERM1 4 2845 ACC2 2846 PUSHACC2 2847 PUSHACC2 2848 PUSHENVACC1 2849 APPTERM3 6 2851 RESTART 2852 GRAB 1 2854 ACC1 2855 PUSHACC1 2856 C_CALL1 ml_string_length 2858 OFFSETINT -1 2860 PUSHACC2 2861 PUSHENVACC1 2862 APPTERM3 5 2864 RESTART 2865 GRAB 2 2867 CONST0 2868 PUSHACC2 2869 LTINT 2870 BRANCHIF 2879 2872 ACC0 2873 C_CALL1 ml_string_length 2875 PUSHACC2 2876 GTINT 2877 BRANCHIFNOT 2886 2879 GETGLOBAL "String.index_from" 2881 PUSHGETGLOBALFIELD Pervasives, 2 2884 APPTERM1 4 2886 ACC2 2887 PUSHACC2 2888 PUSHACC2 2889 C_CALL1 ml_string_length 2891 PUSHACC3 2892 PUSHENVACC1 2893 APPTERM 4, 7 2896 RESTART 2897 GRAB 1 2899 ACC1 2900 PUSHCONST0 2901 PUSHACC2 2902 C_CALL1 ml_string_length 2904 PUSHACC3 2905 PUSHENVACC1 2906 APPTERM 4, 6 2909 ACC0 2910 PUSHGETGLOBALFIELD Char, 2 2913 PUSHENVACC1 2914 APPTERM2 3 2916 ACC0 2917 PUSHGETGLOBALFIELD Char, 3 2920 PUSHENVACC1 2921 APPTERM2 3 2923 RESTART 2924 GRAB 1 2926 CONST0 2927 PUSHACC2 2928 C_CALL1 ml_string_length 2930 EQ 2931 BRANCHIFNOT 2936 2933 ACC1 2934 RETURN 2 2936 ACC1 2937 PUSHENVACC1 2938 APPLY1 2939 PUSHCONST0 2940 PUSHACC3 2941 GETSTRINGCHAR 2942 PUSHACC2 2943 APPLY1 2944 PUSHCONST0 2945 PUSHACC2 2946 SETSTRINGCHAR 2947 ACC0 2948 RETURN 3 2950 ACC0 2951 PUSHGETGLOBALFIELD Char, 2 2954 PUSHENVACC1 2955 APPTERM2 3 2957 ACC0 2958 PUSHGETGLOBALFIELD Char, 3 2961 PUSHENVACC1 2962 APPTERM2 3 2964 RESTART 2965 GRAB 1 2967 ACC1 2968 C_CALL1 ml_string_length 2970 PUSHCONST0 2971 PUSHACC1 2972 EQ 2973 BRANCHIFNOT 2978 2975 ACC2 2976 RETURN 3 2978 ACC0 2979 C_CALL1 create_string 2981 PUSHCONST0 2982 PUSHACC2 2983 OFFSETINT -1 2985 PUSH 2986 BRANCH 3002 2988 CHECK_SIGNALS 2989 ACC1 2990 PUSHACC6 2991 GETSTRINGCHAR 2992 PUSHACC5 2993 APPLY1 2994 PUSHACC2 2995 PUSHACC4 2996 SETSTRINGCHAR 2997 ACC1 2998 OFFSETINT 1 3000 ASSIGN 1 3002 ACC0 3003 PUSHACC2 3004 LEINT 3005 BRANCHIF 2988 3007 CONST0 3008 POP 2 3010 ACC0 3011 RETURN 4 3013 CONST0 3014 PUSHCONST0 3015 PUSHACC2 3016 C_CALL1 ml_string_length 3018 OFFSETINT -1 3020 PUSH 3021 BRANCH 3059 3023 CHECK_SIGNALS 3024 ACC1 3025 PUSHACC4 3026 GETSTRINGCHAR 3027 PUSHACC0 3028 PUSHGETGLOBAL "\000\"\000\000\004\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" 3030 C_CALL2 bitvect_test 3032 BRANCHIFNOT 3038 3034 CONST0 3035 CONST2 3036 BRANCH 3048 3038 ACC0 3039 C_CALL1 is_printable 3041 BRANCHIFNOT 3046 3043 CONST1 3044 BRANCH 3048 3046 CONSTINT 4 3048 POP 1 3050 PUSHACC3 3051 ADDINT 3052 ASSIGN 2 3054 ACC1 3055 OFFSETINT 1 3057 ASSIGN 1 3059 ACC0 3060 PUSHACC2 3061 LEINT 3062 BRANCHIF 3023 3064 CONST0 3065 POP 2 3067 ACC1 3068 C_CALL1 ml_string_length 3070 PUSHACC1 3071 EQ 3072 BRANCHIFNOT 3077 3074 ACC1 3075 RETURN 2 3077 ACC0 3078 C_CALL1 create_string 3080 PUSHCONST0 3081 ASSIGN 1 3083 CONST0 3084 PUSHACC3 3085 C_CALL1 ml_string_length 3087 OFFSETINT -1 3089 PUSH 3090 BRANCH 3245 3092 CHECK_SIGNALS 3093 ACC1 3094 PUSHACC5 3095 GETSTRINGCHAR 3096 PUSHACC0 3097 PUSHGETGLOBAL "\000\000\000\000\004\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" 3099 C_CALL2 bitvect_test 3101 BRANCHIFNOT 3120 3103 CONST0 3104 CONSTINT 92 3106 PUSHACC5 3107 PUSHACC5 3108 SETSTRINGCHAR 3109 ACC4 3110 OFFSETINT 1 3112 ASSIGN 4 3114 ACC0 3115 PUSHACC5 3116 PUSHACC5 3117 SETSTRINGCHAR 3118 BRANCH 3233 3120 CONSTINT 9 3122 PUSHACC1 3123 EQ 3124 BRANCHIFNOT 3143 3126 CONSTINT 92 3128 PUSHACC5 3129 PUSHACC5 3130 SETSTRINGCHAR 3131 ACC4 3132 OFFSETINT 1 3134 ASSIGN 4 3136 CONSTINT 116 3138 PUSHACC5 3139 PUSHACC5 3140 SETSTRINGCHAR 3141 BRANCH 3233 3143 CONSTINT 13 3145 PUSHACC1 3146 EQ 3147 BRANCHIFNOT 3166 3149 CONSTINT 92 3151 PUSHACC5 3152 PUSHACC5 3153 SETSTRINGCHAR 3154 ACC4 3155 OFFSETINT 1 3157 ASSIGN 4 3159 CONSTINT 110 3161 PUSHACC5 3162 PUSHACC5 3163 SETSTRINGCHAR 3164 BRANCH 3233 3166 ACC0 3167 C_CALL1 is_printable 3169 BRANCHIFNOT 3177 3171 ACC0 3172 PUSHACC5 3173 PUSHACC5 3174 SETSTRINGCHAR 3175 BRANCH 3233 3177 ACC0 3178 PUSHCONSTINT 92 3180 PUSHACC6 3181 PUSHACC6 3182 SETSTRINGCHAR 3183 ACC5 3184 OFFSETINT 1 3186 ASSIGN 5 3188 CONSTINT 100 3190 PUSHACC1 3191 DIVINT 3192 PUSHCONSTINT 48 3194 ADDINT 3195 PUSHACC6 3196 PUSHACC6 3197 SETSTRINGCHAR 3198 ACC5 3199 OFFSETINT 1 3201 ASSIGN 5 3203 CONSTINT 10 3205 PUSHCONSTINT 10 3207 PUSHACC2 3208 DIVINT 3209 MODINT 3210 PUSHCONSTINT 48 3212 ADDINT 3213 PUSHACC6 3214 PUSHACC6 3215 SETSTRINGCHAR 3216 ACC5 3217 OFFSETINT 1 3219 ASSIGN 5 3221 CONSTINT 10 3223 PUSHACC1 3224 MODINT 3225 PUSHCONSTINT 48 3227 ADDINT 3228 PUSHACC6 3229 PUSHACC6 3230 SETSTRINGCHAR 3231 POP 1 3233 POP 1 3235 ACC3 3236 OFFSETINT 1 3238 ASSIGN 3 3240 ACC1 3241 OFFSETINT 1 3243 ASSIGN 1 3245 ACC0 3246 PUSHACC2 3247 LEINT 3248 BRANCHIF 3092 3250 CONST0 3251 POP 2 3253 ACC0 3254 RETURN 3 3256 ENVACC1 3257 C_CALL1 ml_string_length 3259 PUSHENVACC3 3260 GETFIELD0 3261 PUSHENVACC2 3262 PUSHCONST0 3263 PUSHENVACC1 3264 C_CALL5 blit_string 3266 ENVACC1 3267 C_CALL1 ml_string_length 3269 PUSHENVACC3 3270 GETFIELD0 3271 ADDINT 3272 PUSHENVACC3 3273 SETFIELD0 3274 ACC0 3275 C_CALL1 ml_string_length 3277 PUSHENVACC3 3278 GETFIELD0 3279 PUSHENVACC2 3280 PUSHCONST0 3281 PUSHACC4 3282 C_CALL5 blit_string 3284 ACC0 3285 C_CALL1 ml_string_length 3287 PUSHENVACC3 3288 GETFIELD0 3289 ADDINT 3290 PUSHENVACC3 3291 SETFIELD0 3292 RETURN 1 3294 ENVACC1 3295 OFFSETREF 1 3297 ACC0 3298 C_CALL1 ml_string_length 3300 PUSHENVACC2 3301 GETFIELD0 3302 ADDINT 3303 PUSHENVACC2 3304 SETFIELD0 3305 RETURN 1 3307 RESTART 3308 GRAB 1 3310 ACC1 3311 BRANCHIFNOT 3374 3313 ACC1 3314 GETFIELD0 3315 PUSHCONST0 3316 MAKEBLOCK1 0 3318 PUSHCONST0 3319 MAKEBLOCK1 0 3321 PUSHACC4 3322 PUSHACC1 3323 PUSHACC3 3324 CLOSURE 2, 3294 3327 PUSHGETGLOBALFIELD List, 9 3330 APPLY2 3331 ACC1 3332 GETFIELD0 3333 OFFSETINT -1 3335 PUSHACC4 3336 C_CALL1 ml_string_length 3338 MULINT 3339 PUSHACC1 3340 GETFIELD0 3341 ADDINT 3342 C_CALL1 create_string 3344 PUSHACC3 3345 C_CALL1 ml_string_length 3347 PUSHCONST0 3348 PUSHACC2 3349 PUSHCONST0 3350 PUSHACC7 3351 C_CALL5 blit_string 3353 ACC3 3354 C_CALL1 ml_string_length 3356 MAKEBLOCK1 0 3358 PUSHACC6 3359 GETFIELD1 3360 PUSHACC1 3361 PUSHACC3 3362 PUSHACC 8 3364 CLOSURE 3, 3256 3367 PUSHGETGLOBALFIELD List, 9 3370 APPLY2 3371 ACC1 3372 RETURN 7 3374 GETGLOBAL "" 3376 RETURN 2 3378 RESTART 3379 GRAB 4 3381 CONST0 3382 PUSHACC5 3383 LTINT 3384 BRANCHIF 3414 3386 CONST0 3387 PUSHACC2 3388 LTINT 3389 BRANCHIF 3414 3391 ACC0 3392 C_CALL1 ml_string_length 3394 PUSHACC5 3395 PUSHACC3 3396 ADDINT 3397 GTINT 3398 BRANCHIF 3414 3400 CONST0 3401 PUSHACC4 3402 LTINT 3403 BRANCHIF 3414 3405 ACC2 3406 C_CALL1 ml_string_length 3408 PUSHACC5 3409 PUSHACC5 3410 ADDINT 3411 GTINT 3412 BRANCHIFNOT 3421 3414 GETGLOBAL "String.blit" 3416 PUSHGETGLOBALFIELD Pervasives, 2 3419 APPTERM1 6 3421 ACC4 3422 PUSHACC4 3423 PUSHACC4 3424 PUSHACC4 3425 PUSHACC4 3426 C_CALL5 blit_string 3428 RETURN 5 3430 RESTART 3431 GRAB 3 3433 CONST0 3434 PUSHACC2 3435 LTINT 3436 BRANCHIF 3452 3438 CONST0 3439 PUSHACC3 3440 LTINT 3441 BRANCHIF 3452 3443 ACC0 3444 C_CALL1 ml_string_length 3446 PUSHACC3 3447 PUSHACC3 3448 ADDINT 3449 GTINT 3450 BRANCHIFNOT 3459 3452 GETGLOBAL "String.fill" 3454 PUSHGETGLOBALFIELD Pervasives, 2 3457 APPTERM1 5 3459 ACC3 3460 PUSHACC3 3461 PUSHACC3 3462 PUSHACC3 3463 C_CALL4 fill_string 3465 RETURN 4 3467 RESTART 3468 GRAB 2 3470 CONST0 3471 PUSHACC2 3472 LTINT 3473 BRANCHIF 3489 3475 CONST0 3476 PUSHACC3 3477 LTINT 3478 BRANCHIF 3489 3480 ACC0 3481 C_CALL1 ml_string_length 3483 PUSHACC3 3484 PUSHACC3 3485 ADDINT 3486 GTINT 3487 BRANCHIFNOT 3496 3489 GETGLOBAL "String.sub" 3491 PUSHGETGLOBALFIELD Pervasives, 2 3494 APPTERM1 4 3496 ACC2 3497 C_CALL1 create_string 3499 PUSHACC3 3500 PUSHCONST0 3501 PUSHACC2 3502 PUSHACC5 3503 PUSHACC5 3504 C_CALL5 blit_string 3506 ACC0 3507 RETURN 4 3509 ACC0 3510 C_CALL1 ml_string_length 3512 PUSHACC0 3513 C_CALL1 create_string 3515 PUSHACC1 3516 PUSHCONST0 3517 PUSHACC2 3518 PUSHCONST0 3519 PUSHACC6 3520 C_CALL5 blit_string 3522 ACC0 3523 RETURN 3 3525 RESTART 3526 GRAB 1 3528 ACC0 3529 C_CALL1 create_string 3531 PUSHACC2 3532 PUSHACC2 3533 PUSHCONST0 3534 PUSHACC3 3535 C_CALL4 fill_string 3537 ACC0 3538 RETURN 3 3540 CLOSURE 0, 3526 3543 PUSH 3544 CLOSURE 0, 3509 3547 PUSH 3548 CLOSURE 0, 3468 3551 PUSH 3552 CLOSURE 0, 3431 3555 PUSH 3556 CLOSURE 0, 3379 3559 PUSH 3560 CLOSURE 0, 3308 3563 PUSH 3564 CLOSURE 0, 3013 3567 PUSH 3568 CLOSURE 0, 2965 3571 PUSHACC0 3572 CLOSURE 1, 2957 3575 PUSHACC1 3576 CLOSURE 1, 2950 3579 PUSHACC 8 3581 CLOSURE 1, 2924 3584 PUSHACC0 3585 CLOSURE 1, 2916 3588 PUSHACC1 3589 CLOSURE 1, 2909 3592 PUSH 3593 CLOSUREREC 0, 2651 3597 ACC0 3598 CLOSURE 1, 2897 3601 PUSHACC1 3602 CLOSURE 1, 2865 3605 PUSH 3606 CLOSUREREC 0, 2684 3610 ACC0 3611 CLOSURE 1, 2852 3614 PUSHACC1 3615 CLOSURE 1, 2824 3618 PUSHACC5 3619 CLOSURE 1, 2769 3622 PUSHACC3 3623 CLOSURE 1, 2724 3626 PUSHACC1 3627 CLOSURE 1, 2715 3630 PUSHACC 9 3632 PUSHACC 11 3634 PUSHACC 14 3636 PUSHACC 16 3638 PUSHACC5 3639 PUSHACC7 3640 PUSHACC6 3641 PUSHACC 10 3643 PUSHACC 14 3645 PUSHACC 13 3647 PUSHACC 17 3649 PUSHACC 26 3651 PUSHACC 28 3653 PUSHACC 30 3655 PUSHACC 32 3657 PUSHACC 34 3659 PUSHACC 36 3661 PUSHACC 38 3663 MAKEBLOCK 18, 0 3666 POP 22 3668 SETGLOBAL String 3670 CONST0 3671 C_CALL1 gc_stat 3673 GETGLOBAL "" 3675 PUSHCONSTINT 20 3677 C_CALL2 make_vect 3679 PUSHCONSTINT 20 3681 C_CALL1 weak_create 3683 PUSHCONST0 3684 PUSHCONSTINT 19 3686 PUSH 3687 BRANCH 3715 3689 CHECK_SIGNALS 3690 CONSTINT 115 3692 PUSHCONSTINT 20 3694 PUSHGETGLOBALFIELD String, 0 3697 APPLY2 3698 PUSHACC2 3699 PUSHACC5 3700 SETVECTITEM 3701 ACC1 3702 PUSHACC4 3703 GETVECTITEM 3704 MAKEBLOCK1 0 3706 PUSHACC2 3707 PUSHACC4 3708 C_CALL3 weak_set 3710 ACC1 3711 OFFSETINT 1 3713 ASSIGN 1 3715 ACC0 3716 PUSHACC2 3717 LEINT 3718 BRANCHIF 3689 3720 CONST0 3721 POP 2 3723 CONST0 3724 C_CALL1 gc_full_major 3726 CONST0 3727 PUSHCONSTINT 19 3729 PUSH 3730 BRANCH 3753 3732 CHECK_SIGNALS 3733 ACC1 3734 PUSHACC3 3735 C_CALL2 weak_get 3737 PUSHACC0 3738 BRANCHIF 3745 3740 GETGLOBAL Not_found 3742 MAKEBLOCK1 0 3744 RAISE 3745 CONST0 3746 POP 1 3748 ACC1 3749 OFFSETINT 1 3751 ASSIGN 1 3753 ACC0 3754 PUSHACC2 3755 LEINT 3756 BRANCHIF 3732 3758 CONST0 3759 POP 2 3761 CONST0 3762 PUSHCONSTINT 19 3764 PUSH 3765 BRANCH 3785 3767 CHECK_SIGNALS 3768 CONST0 3769 PUSHCONST2 3770 PUSHACC3 3771 MODINT 3772 EQ 3773 BRANCHIFNOT 3780 3775 GETGLOBAL "" 3777 PUSHACC2 3778 PUSHACC5 3779 SETVECTITEM 3780 ACC1 3781 OFFSETINT 1 3783 ASSIGN 1 3785 ACC0 3786 PUSHACC2 3787 LEINT 3788 BRANCHIF 3767 3790 CONST0 3791 POP 2 3793 CONST0 3794 C_CALL1 gc_full_major 3796 CONST0 3797 PUSHCONSTINT 19 3799 PUSH 3800 BRANCH 3854 3802 CHECK_SIGNALS 3803 ACC1 3804 PUSHACC3 3805 C_CALL2 weak_get 3807 PUSHACC0 3808 BRANCHIFNOT 3832 3810 CONST1 3811 PUSHCONST2 3812 PUSHACC4 3813 MODINT 3814 EQ 3815 BRANCHIFNOT 3842 3817 CONSTINT 115 3819 PUSHCONSTINT 5 3821 PUSHACC2 3822 GETFIELD0 3823 GETSTRINGCHAR 3824 NEQ 3825 BRANCHIFNOT 3847 3827 GETGLOBAL Not_found 3829 MAKEBLOCK1 0 3831 RAISE 3832 CONST0 3833 PUSHCONST2 3834 PUSHACC4 3835 MODINT 3836 EQ 3837 BRANCHIFNOT 3842 3839 CONST0 3840 BRANCH 3847 3842 GETGLOBAL Not_found 3844 MAKEBLOCK1 0 3846 RAISE 3847 POP 1 3849 ACC1 3850 OFFSETINT 1 3852 ASSIGN 1 3854 ACC0 3855 PUSHACC2 3856 LEINT 3857 BRANCHIF 3802 3859 CONST0 3860 POP 4 3862 ATOM0 3863 SETGLOBAL T350-heapcheck 3865 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t170-envacc3.ml0000644000175000017500000000136612124403241023272 0ustar tootstootsopen Lib;; let x = 5 in let y = 2 in let z = 1 in let f _ = ignore x; ignore y; z in if f 0 <> 1 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 18 11 ENVACC1 12 CONST0 13 ENVACC2 14 CONST0 15 ENVACC3 16 RETURN 1 18 CONSTINT 5 20 PUSHCONST2 21 PUSHCONST1 22 PUSHACC0 23 PUSHACC2 24 PUSHACC4 25 CLOSURE 3, 11 28 PUSHCONST1 29 PUSHCONST0 30 PUSHACC2 31 APPLY1 32 NEQ 33 BRANCHIFNOT 40 35 GETGLOBAL Not_found 37 MAKEBLOCK1 0 39 RAISE 40 POP 4 42 ATOM0 43 SETGLOBAL T170-envacc3 45 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t301-object.ml0000644000175000017500000000117512124403241023210 0ustar tootstoots(**** file testinterp/t301-object.ml suggested by Jacques Garrigue to Basile Starynkevitch compilable with ocamlc -nostdlib -I ../../stdlib \ ../../stdlib/pervasives.cmo ../../stdlib/camlinternalOO.cmo \ t301-object.ml -o t301-object.byte ***) (* $Id$ *) class c = object (self) method pubmet = 1 method privmet = self#pubmet + 1 val o = object method a = 3 method m = 4 end method dynmet = o#m end;; let f () = let c = new c in (c#pubmet, c#privmet, c#dynmet);; let (x,y,z) = f () in if x <> 1 then raise Not_found; if y <> 2 then raise Not_found; if z <> 4 then raise Not_found;; (**** eof $Id$ *) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t270-push_retaddr.ml0000644000175000017500000000124112124403241024425 0ustar tootstootsopen Lib;; let f a b c d = 123 in if f 0 1 2 3 <> 123 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 18 11 RESTART 12 GRAB 3 14 CONSTINT 123 16 RETURN 4 18 CLOSURE 0, 12 21 PUSHCONSTINT 123 23 PUSH 24 PUSH_RETADDR 34 26 CONST3 27 PUSHCONST2 28 PUSHCONST1 29 PUSHCONST0 30 PUSHACC 8 32 APPLY 4 34 NEQ 35 BRANCHIFNOT 42 37 GETGLOBAL Not_found 39 MAKEBLOCK1 0 41 RAISE 42 POP 1 44 ATOM0 45 SETGLOBAL T270-push_retaddr 47 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t092-pushacc5.ml0000644000175000017500000000105512124403241023461 0ustar tootstootsopen Lib;; let x = false in let y = true in let z = true in let a = true in let b = true in let c = true in if x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST1 11 PUSHCONST1 12 PUSHCONST1 13 PUSHCONST1 14 PUSHCONST1 15 PUSHACC5 16 BRANCHIFNOT 23 18 GETGLOBAL Not_found 20 MAKEBLOCK1 0 22 RAISE 23 POP 6 25 ATOM0 26 SETGLOBAL T092-pushacc5 28 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t210-setfield2.ml0000644000175000017500000000126312124403241023620 0ustar tootstootsopen Lib;; type t = { mutable a : int; mutable b : int; mutable c : int; };; let x = {a = 7; b = 6; c = 5} in x.c <- 11; if x.c <> 11 then raise Not_found; x ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 5 11 PUSHCONSTINT 6 13 PUSHCONSTINT 7 15 MAKEBLOCK3 0 17 PUSHCONSTINT 11 19 PUSHACC1 20 SETFIELD2 21 CONSTINT 11 23 PUSHACC1 24 GETFIELD2 25 NEQ 26 BRANCHIFNOT 33 28 GETGLOBAL Not_found 30 MAKEBLOCK1 0 32 RAISE 33 ACC0 34 POP 1 36 ATOM0 37 SETGLOBAL T210-setfield2 39 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t210-setfield0.ml0000644000175000017500000000111712124403241023614 0ustar tootstootsopen Lib;; type t = { mutable a : int; };; let x = {a = 7} in x.a <- 11; if x.a <> 11 then raise Not_found; x ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 7 11 MAKEBLOCK1 0 13 PUSHCONSTINT 11 15 PUSHACC1 16 SETFIELD0 17 CONSTINT 11 19 PUSHACC1 20 GETFIELD0 21 NEQ 22 BRANCHIFNOT 29 24 GETGLOBAL Not_found 26 MAKEBLOCK1 0 28 RAISE 29 ACC0 30 POP 1 32 ATOM0 33 SETGLOBAL T210-setfield0 35 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t141-switch-5.ml0000644000175000017500000000115212124403241023402 0ustar tootstootsopen Lib;; type t = | A of int | B of int | C of int ;; match A 0 with | A _ -> () | B _ -> raise Not_found | _ -> raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL <0>(0) 11 PUSHACC0 12 SWITCH tag 0 -> 17 tag 1 -> 20 tag 2 -> 25 17 CONST0 18 BRANCH 30 20 GETGLOBAL Not_found 22 MAKEBLOCK1 0 24 RAISE 25 GETGLOBAL Not_found 27 MAKEBLOCK1 0 29 RAISE 30 POP 1 32 ATOM0 33 SETGLOBAL T141-switch-5 35 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t141-switch-7.ml0000644000175000017500000000112712124403241023406 0ustar tootstootsopen Lib;; type t = | A of int | B of int | C of int ;; match C 0 with | A _ -> raise Not_found | B _ -> raise Not_found | _ -> () ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL <2>(0) 11 PUSHACC0 12 SWITCH tag 0 -> 17 tag 1 -> 22 tag 2 -> 27 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 GETGLOBAL Not_found 24 MAKEBLOCK1 0 26 RAISE 27 CONST0 28 POP 1 30 ATOM0 31 SETGLOBAL T141-switch-7 33 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t080-eq.ml0000644000175000017500000000057012124403241022351 0ustar tootstootsopen Lib;; if not (0 = 0) then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST0 11 EQ 12 BOOLNOT 13 BRANCHIFNOT 20 15 GETGLOBAL Not_found 17 MAKEBLOCK1 0 19 RAISE 20 ATOM0 21 SETGLOBAL T080-eq 23 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t164-apply3.ml0000644000175000017500000000066412124403241023163 0ustar tootstootsopen Lib;; let f _ _ _ = 0 in f 0 0 0;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 17 11 RESTART 12 GRAB 2 14 CONST0 15 RETURN 3 17 CLOSURE 0, 12 20 PUSHCONST0 21 PUSHCONST0 22 PUSHCONST0 23 PUSHACC3 24 APPLY3 25 POP 1 27 ATOM0 28 SETGLOBAL T164-apply3 30 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t210-setfield1.ml0000644000175000017500000000120112124403241023607 0ustar tootstootsopen Lib;; type t = { mutable a : int; mutable b : int; };; let x = {a = 7; b = 6} in x.b <- 11; if x.b <> 11 then raise Not_found; x ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 6 11 PUSHCONSTINT 7 13 MAKEBLOCK2 0 15 PUSHCONSTINT 11 17 PUSHACC1 18 SETFIELD1 19 CONSTINT 11 21 PUSHACC1 22 GETFIELD1 23 NEQ 24 BRANCHIFNOT 31 26 GETGLOBAL Not_found 28 MAKEBLOCK1 0 30 RAISE 31 ACC0 32 POP 1 34 ATOM0 35 SETGLOBAL T210-setfield1 37 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t240-c_call2.ml0000644000175000017500000000065712124403241023247 0ustar tootstootsopen Lib;; if Pervasives.compare 1 2 <> -1 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT -1 11 PUSHCONST2 12 PUSHCONST1 13 C_CALL2 compare 15 NEQ 16 BRANCHIFNOT 23 18 GETGLOBAL Not_found 20 MAKEBLOCK1 0 22 RAISE 23 ATOM0 24 SETGLOBAL T240-c_call2 26 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t101-poptrap.ml0000644000175000017500000000047512124403241023427 0ustar tootstootsopen Lib;; try () with _ -> () ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 PUSHTRAP 15 11 CONST0 12 POPTRAP 13 BRANCH 18 15 PUSHCONST0 16 POP 1 18 ATOM0 19 SETGLOBAL T101-poptrap 21 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t080-ltint.ml0000644000175000017500000000054612124403241023101 0ustar tootstootsopen Lib;; if 0 < 0 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST0 11 LTINT 12 BRANCHIFNOT 19 14 GETGLOBAL Not_found 16 MAKEBLOCK1 0 18 RAISE 19 ATOM0 20 SETGLOBAL T080-ltint 22 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t161-apply1.ml0000644000175000017500000000134712124403241023155 0ustar tootstootsopen Lib;; let f _ = raise End_of_file in try f 0; raise Not_found; with End_of_file -> 0 ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 16 11 GETGLOBAL End_of_file 13 MAKEBLOCK1 0 15 RAISE 16 CLOSURE 0, 11 19 PUSH 20 PUSHTRAP 30 22 CONST0 23 PUSHACC5 24 APPLY1 25 GETGLOBAL Not_found 27 MAKEBLOCK1 0 29 RAISE 30 PUSHGETGLOBAL End_of_file 32 PUSHACC1 33 GETFIELD0 34 EQ 35 BRANCHIFNOT 40 37 CONST0 38 BRANCH 42 40 ACC0 41 RAISE 42 POP 1 44 POP 1 46 ATOM0 47 SETGLOBAL T161-apply1 49 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t193-setfloatfield-2.ml0000644000175000017500000000124612124403241024736 0ustar tootstootsopen Lib;; type t = { mutable a : float; mutable b : float; };; let x = { a = 0.1; b = 0.2 } in x.b <- 0.3; if x.b <> 0.3 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL 0.2 11 PUSHGETGLOBAL 0.1 13 MAKEFLOATBLOCK 2 15 PUSHGETGLOBAL 0.3 17 PUSHACC1 18 SETFLOATFIELD 1 20 GETGLOBAL 0.3 22 PUSHACC1 23 GETFLOATFIELD 1 25 C_CALL2 neq_float 27 BRANCHIFNOT 34 29 GETGLOBAL Not_found 31 MAKEBLOCK1 0 33 RAISE 34 POP 1 36 ATOM0 37 SETGLOBAL T193-setfloatfield-2 39 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t253-offsetclosure0.ml0000644000175000017500000000116112124403241024706 0ustar tootstootsopen Lib;; let rec f _ = g f and g _ = 10 in if f 3 <> 10 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 19 11 OFFSETCLOSURE0 12 PUSHOFFSETCLOSURE2 13 APPTERM1 2 15 CONSTINT 10 17 RETURN 1 19 CLOSUREREC 0, 11, 15 24 CONSTINT 10 26 PUSHCONST3 27 PUSHACC3 28 APPLY1 29 NEQ 30 BRANCHIFNOT 37 32 GETGLOBAL Not_found 34 MAKEBLOCK1 0 36 RAISE 37 POP 2 39 ATOM0 40 SETGLOBAL T253-offsetclosure0 42 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-lslint.ml0000644000175000017500000000063112124403241023241 0ustar tootstootsopen Lib;; if (3 lsl 2) <> 12 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 12 11 PUSHCONST2 12 PUSHCONST3 13 LSLINT 14 NEQ 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 ATOM0 23 SETGLOBAL T110-lslint 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t060-raise.ml0000644000175000017500000000037612124403241023051 0ustar tootstootsopen Lib;; raise End_of_file;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL End_of_file 11 MAKEBLOCK1 0 13 RAISE 14 SETGLOBAL T060-raise 16 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t253-offsetclosure2.ml0000644000175000017500000000115212124403241024710 0ustar tootstootsopen Lib;; let rec f _ = g and g _ = 10 in if f 3 4 <> 10 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 18 11 OFFSETCLOSURE2 12 RETURN 1 14 CONSTINT 10 16 RETURN 1 18 CLOSUREREC 0, 11, 14 23 CONSTINT 10 25 PUSHCONSTINT 4 27 PUSHCONST3 28 PUSHACC4 29 APPLY2 30 NEQ 31 BRANCHIFNOT 38 33 GETGLOBAL Not_found 35 MAKEBLOCK1 0 37 RAISE 38 POP 2 40 ATOM0 41 SETGLOBAL T253-offsetclosure2 43 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t022-pushconstint.ml0000644000175000017500000000023112124403241024473 0ustar tootstootslet _ = () in -1;; (** 0 CONST0 1 PUSHCONSTINT -1 3 POP 1 5 ATOM0 6 SETGLOBAL T022-pushconstint 8 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t251-pushoffsetclosure0.ml0000644000175000017500000000130012124403241025577 0ustar tootstootsopen Lib;; let rec f = function | 0 -> 13 | n -> f 0 in if f 5 <> 13 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 24 11 CONST0 12 PUSHACC1 13 EQ 14 BRANCHIFNOT 20 16 CONSTINT 13 18 RETURN 1 20 CONST0 21 PUSHOFFSETCLOSURE0 22 APPTERM1 2 24 CLOSUREREC 0, 11 28 CONSTINT 13 30 PUSHCONSTINT 5 32 PUSHACC2 33 APPLY1 34 NEQ 35 BRANCHIFNOT 42 37 GETGLOBAL Not_found 39 MAKEBLOCK1 0 41 RAISE 42 POP 1 44 ATOM0 45 SETGLOBAL T251-pushoffsetclosure0 47 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t250-closurerec-2.ml0000644000175000017500000000101712124403241024245 0ustar tootstootsopen Lib;; let rec f _ = 23 in if f 0 <> 23 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 15 11 CONSTINT 23 13 RETURN 1 15 CLOSUREREC 0, 11 19 CONSTINT 23 21 PUSHCONST0 22 PUSHACC2 23 APPLY1 24 NEQ 25 BRANCHIFNOT 32 27 GETGLOBAL Not_found 29 MAKEBLOCK1 0 31 RAISE 32 POP 1 34 ATOM0 35 SETGLOBAL T250-closurerec-2 37 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t071-boolnot.ml0000644000175000017500000000053012124403241023414 0ustar tootstootsopen Lib;; if not true then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 BOOLNOT 11 BRANCHIFNOT 18 13 GETGLOBAL Not_found 15 MAKEBLOCK1 0 17 RAISE 18 ATOM0 19 SETGLOBAL T071-boolnot 21 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t120-getstringchar.ml0000644000175000017500000000066112124403241024604 0ustar tootstootsopen Lib;; if "foo".[2] <> 'o' then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 111 11 PUSHCONST2 12 PUSHGETGLOBAL "foo" 14 GETSTRINGCHAR 15 NEQ 16 BRANCHIFNOT 23 18 GETGLOBAL Not_found 20 MAKEBLOCK1 0 22 RAISE 23 ATOM0 24 SETGLOBAL T120-getstringchar 26 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t220-assign.ml0000644000175000017500000000070612124403241023225 0ustar tootstootsopen Lib;; let x = ref 1 in x := 3; if !x <> 3 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONST3 11 ASSIGN 0 13 CONST3 14 PUSHACC1 15 NEQ 16 BRANCHIFNOT 23 18 GETGLOBAL Not_found 20 MAKEBLOCK1 0 22 RAISE 23 POP 1 25 ATOM0 26 SETGLOBAL T220-assign 28 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t090-acc4.ml0000644000175000017500000000106212124403241022554 0ustar tootstootsopen Lib;; let x = true in let y = false in let z = false in let a = false in let b = false in (); if not x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONST0 11 PUSHCONST0 12 PUSHCONST0 13 PUSHCONST0 14 PUSHCONST0 15 ACC4 16 BOOLNOT 17 BRANCHIFNOT 24 19 GETGLOBAL Not_found 21 MAKEBLOCK1 0 23 RAISE 24 POP 5 26 ATOM0 27 SETGLOBAL T090-acc4 29 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-asrint-1.ml0000644000175000017500000000064012124403241023372 0ustar tootstootsopen Lib;; if (-2 asr 1) <> -1 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT -1 11 PUSHCONST1 12 PUSHCONSTINT -2 14 ASRINT 15 NEQ 16 BRANCHIFNOT 23 18 GETGLOBAL Not_found 20 MAKEBLOCK1 0 22 RAISE 23 ATOM0 24 SETGLOBAL T110-asrint-1 26 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t021-pushconst1.ml0000644000175000017500000000022212124403241024040 0ustar tootstootslet _ = () in 1;; (** 0 CONST0 1 PUSHCONST1 2 POP 1 4 ATOM0 5 SETGLOBAL T021-pushconst1 7 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-mulint.ml0000644000175000017500000000062312124403241023245 0ustar tootstootsopen Lib;; if 2 * 2 <> 4 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 4 11 PUSHCONST2 12 PUSHCONST2 13 MULINT 14 NEQ 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 ATOM0 23 SETGLOBAL T110-mulint 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t080-neq.ml0000644000175000017500000000054312124403241022527 0ustar tootstootsopen Lib;; if 0 <> 0 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST0 11 NEQ 12 BRANCHIFNOT 19 14 GETGLOBAL Not_found 16 MAKEBLOCK1 0 18 RAISE 19 ATOM0 20 SETGLOBAL T080-neq 22 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t080-geint.ml0000644000175000017500000000057712124403241023061 0ustar tootstootsopen Lib;; if not (0 >= 0) then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST0 11 GEINT 12 BOOLNOT 13 BRANCHIFNOT 20 15 GETGLOBAL Not_found 17 MAKEBLOCK1 0 19 RAISE 20 ATOM0 21 SETGLOBAL T080-geint 23 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t320-gc-2.ml0000644000175000017500000007756012124403241022506 0ustar tootstootsopen Lib;; let rec f n = if n <= 0 then [] else n :: f (n-1) in let l = f 300 in Gc.major (); if List.fold_left (+) 0 l <> 301 * 150 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 746 11 RESTART 12 GRAB 1 14 ACC0 15 BRANCHIFNOT 28 17 ACC1 18 PUSHACC1 19 GETFIELD1 20 PUSHOFFSETCLOSURE0 21 APPLY2 22 PUSHACC1 23 GETFIELD0 24 MAKEBLOCK2 0 26 RETURN 2 28 ACC1 29 RETURN 2 31 RESTART 32 GRAB 3 34 CONST0 35 PUSHACC4 36 LEINT 37 BRANCHIFNOT 42 39 CONST0 40 RETURN 4 42 ACC3 43 PUSHACC3 44 PUSHACC3 45 PUSHACC3 46 C_CALL4 caml_input 48 PUSHCONST0 49 PUSHACC1 50 EQ 51 BRANCHIFNOT 58 53 GETGLOBAL End_of_file 55 MAKEBLOCK1 0 57 RAISE 58 ACC0 59 PUSHACC5 60 SUBINT 61 PUSHACC1 62 PUSHACC5 63 ADDINT 64 PUSHACC4 65 PUSHACC4 66 PUSHOFFSETCLOSURE0 67 APPTERM 4, 9 70 ACC0 71 C_CALL1 caml_input_scan_line 73 PUSHCONST0 74 PUSHACC1 75 EQ 76 BRANCHIFNOT 83 78 GETGLOBAL End_of_file 80 MAKEBLOCK1 0 82 RAISE 83 CONST0 84 PUSHACC1 85 GTINT 86 BRANCHIFNOT 107 88 ACC0 89 OFFSETINT -1 91 C_CALL1 create_string 93 PUSHACC1 94 OFFSETINT -1 96 PUSHCONST0 97 PUSHACC2 98 PUSHACC5 99 C_CALL4 caml_input 101 ACC2 102 C_CALL1 caml_input_char 104 ACC0 105 RETURN 3 107 ACC0 108 NEGINT 109 C_CALL1 create_string 111 PUSHACC1 112 NEGINT 113 PUSHCONST0 114 PUSHACC2 115 PUSHACC5 116 C_CALL4 caml_input 118 CONST0 119 PUSHTRAP 130 121 ACC6 122 PUSHOFFSETCLOSURE0 123 APPLY1 124 PUSHACC5 125 PUSHENVACC1 126 APPLY2 127 POPTRAP 128 RETURN 3 130 PUSHGETGLOBAL End_of_file 132 PUSHACC1 133 GETFIELD0 134 EQ 135 BRANCHIFNOT 140 137 ACC1 138 RETURN 4 140 ACC0 141 RAISE 142 ACC0 143 C_CALL1 caml_flush 145 RETURN 1 147 RESTART 148 GRAB 1 150 ACC1 151 PUSHACC1 152 C_CALL2 caml_output_char 154 RETURN 2 156 RESTART 157 GRAB 1 159 ACC1 160 PUSHACC1 161 C_CALL2 caml_output_char 163 RETURN 2 165 RESTART 166 GRAB 1 168 ACC1 169 PUSHACC1 170 C_CALL2 caml_output_int 172 RETURN 2 174 RESTART 175 GRAB 1 177 ACC1 178 PUSHACC1 179 C_CALL2 caml_seek_out 181 RETURN 2 183 ACC0 184 C_CALL1 caml_pos_out 186 RETURN 1 188 ACC0 189 C_CALL1 caml_channel_size 191 RETURN 1 193 RESTART 194 GRAB 1 196 ACC1 197 PUSHACC1 198 C_CALL2 caml_set_binary_mode 200 RETURN 2 202 ACC0 203 C_CALL1 caml_input_char 205 RETURN 1 207 ACC0 208 C_CALL1 caml_input_char 210 RETURN 1 212 ACC0 213 C_CALL1 caml_input_int 215 RETURN 1 217 ACC0 218 C_CALL1 input_value 220 RETURN 1 222 RESTART 223 GRAB 1 225 ACC1 226 PUSHACC1 227 C_CALL2 caml_seek_in 229 RETURN 2 231 ACC0 232 C_CALL1 caml_pos_in 234 RETURN 1 236 ACC0 237 C_CALL1 caml_channel_size 239 RETURN 1 241 ACC0 242 C_CALL1 caml_close_channel 244 RETURN 1 246 RESTART 247 GRAB 1 249 ACC1 250 PUSHACC1 251 C_CALL2 caml_set_binary_mode 253 RETURN 2 255 CONST0 256 PUSHENVACC1 257 APPLY1 258 ACC0 259 C_CALL1 sys_exit 261 RETURN 1 263 CONST0 264 PUSHENVACC1 265 GETFIELD0 266 APPTERM1 2 268 CONST0 269 PUSHENVACC1 270 APPLY1 271 CONST0 272 PUSHENVACC2 273 APPTERM1 2 275 ENVACC1 276 GETFIELD0 277 PUSHACC0 278 PUSHACC2 279 CLOSURE 2, 268 282 PUSHENVACC1 283 SETFIELD0 284 RETURN 2 286 ENVACC1 287 C_CALL1 caml_flush 289 ENVACC2 290 C_CALL1 caml_flush 292 RETURN 1 294 CONST0 295 PUSHENVACC1 296 APPLY1 297 C_CALL1 float_of_string 299 RETURN 1 301 CONST0 302 PUSHENVACC1 303 APPLY1 304 C_CALL1 int_of_string 306 RETURN 1 308 ENVACC2 309 C_CALL1 caml_flush 311 ENVACC1 312 PUSHENVACC3 313 APPTERM1 2 315 CONSTINT 13 317 PUSHENVACC1 318 C_CALL2 caml_output_char 320 ENVACC1 321 C_CALL1 caml_flush 323 RETURN 1 325 ACC0 326 PUSHENVACC1 327 PUSHENVACC2 328 APPLY2 329 CONSTINT 13 331 PUSHENVACC1 332 C_CALL2 caml_output_char 334 ENVACC1 335 C_CALL1 caml_flush 337 RETURN 1 339 ACC0 340 PUSHENVACC1 341 APPLY1 342 PUSHENVACC2 343 PUSHENVACC3 344 APPTERM2 3 346 ACC0 347 PUSHENVACC1 348 APPLY1 349 PUSHENVACC2 350 PUSHENVACC3 351 APPTERM2 3 353 ACC0 354 PUSHENVACC1 355 PUSHENVACC2 356 APPTERM2 3 358 ACC0 359 PUSHENVACC1 360 C_CALL2 caml_output_char 362 RETURN 1 364 CONSTINT 13 366 PUSHENVACC1 367 C_CALL2 caml_output_char 369 ENVACC1 370 C_CALL1 caml_flush 372 RETURN 1 374 ACC0 375 PUSHENVACC1 376 PUSHENVACC2 377 APPLY2 378 CONSTINT 13 380 PUSHENVACC1 381 C_CALL2 caml_output_char 383 RETURN 1 385 ACC0 386 PUSHENVACC1 387 APPLY1 388 PUSHENVACC2 389 PUSHENVACC3 390 APPTERM2 3 392 ACC0 393 PUSHENVACC1 394 APPLY1 395 PUSHENVACC2 396 PUSHENVACC3 397 APPTERM2 3 399 ACC0 400 PUSHENVACC1 401 PUSHENVACC2 402 APPTERM2 3 404 ACC0 405 PUSHENVACC1 406 C_CALL2 caml_output_char 408 RETURN 1 410 RESTART 411 GRAB 3 413 CONST0 414 PUSHACC3 415 LTINT 416 BRANCHIF 427 418 ACC1 419 C_CALL1 ml_string_length 421 PUSHACC4 422 PUSHACC4 423 ADDINT 424 GTINT 425 BRANCHIFNOT 432 427 GETGLOBAL "really_input" 429 PUSHENVACC1 430 APPTERM1 5 432 ACC3 433 PUSHACC3 434 PUSHACC3 435 PUSHACC3 436 PUSHENVACC2 437 APPTERM 4, 8 440 RESTART 441 GRAB 3 443 CONST0 444 PUSHACC3 445 LTINT 446 BRANCHIF 457 448 ACC1 449 C_CALL1 ml_string_length 451 PUSHACC4 452 PUSHACC4 453 ADDINT 454 GTINT 455 BRANCHIFNOT 462 457 GETGLOBAL "input" 459 PUSHENVACC1 460 APPTERM1 5 462 ACC3 463 PUSHACC3 464 PUSHACC3 465 PUSHACC3 466 C_CALL4 caml_input 468 RETURN 4 470 ACC0 471 PUSHCONST0 472 PUSHGETGLOBAL <0>(0, <0>(6, 0)) 474 PUSHENVACC1 475 APPTERM3 4 477 ACC0 478 PUSHCONST0 479 PUSHGETGLOBAL <0>(0, <0>(7, 0)) 481 PUSHENVACC1 482 APPTERM3 4 484 RESTART 485 GRAB 2 487 ACC1 488 PUSHACC1 489 PUSHACC4 490 C_CALL3 sys_open 492 C_CALL1 caml_open_descriptor 494 RETURN 3 496 ACC0 497 C_CALL1 caml_flush 499 ACC0 500 C_CALL1 caml_close_channel 502 RETURN 1 504 RESTART 505 GRAB 1 507 CONST0 508 PUSHACC2 509 PUSHACC2 510 C_CALL3 output_value 512 RETURN 2 514 RESTART 515 GRAB 3 517 CONST0 518 PUSHACC3 519 LTINT 520 BRANCHIF 531 522 ACC1 523 C_CALL1 ml_string_length 525 PUSHACC4 526 PUSHACC4 527 ADDINT 528 GTINT 529 BRANCHIFNOT 536 531 GETGLOBAL "output" 533 PUSHENVACC1 534 APPTERM1 5 536 ACC3 537 PUSHACC3 538 PUSHACC3 539 PUSHACC3 540 C_CALL4 caml_output 542 RETURN 4 544 RESTART 545 GRAB 1 547 ACC1 548 C_CALL1 ml_string_length 550 PUSHCONST0 551 PUSHACC3 552 PUSHACC3 553 C_CALL4 caml_output 555 RETURN 2 557 ACC0 558 PUSHCONSTINT 438 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0)))) 562 PUSHENVACC1 563 APPTERM3 4 565 ACC0 566 PUSHCONSTINT 438 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0)))) 570 PUSHENVACC1 571 APPTERM3 4 573 RESTART 574 GRAB 2 576 ACC1 577 PUSHACC1 578 PUSHACC4 579 C_CALL3 sys_open 581 C_CALL1 caml_open_descriptor 583 RETURN 3 585 ACC0 586 PUSHGETGLOBAL "%.12g" 588 C_CALL2 format_float 590 RETURN 1 592 ACC0 593 PUSHGETGLOBAL "%d" 595 C_CALL2 format_int 597 RETURN 1 599 GETGLOBAL "false" 601 PUSHACC1 602 C_CALL2 string_equal 604 BRANCHIFNOT 609 606 CONST0 607 RETURN 1 609 GETGLOBAL "true" 611 PUSHACC1 612 C_CALL2 string_equal 614 BRANCHIFNOT 619 616 CONST1 617 RETURN 1 619 GETGLOBAL "bool_of_string" 621 PUSHENVACC1 622 APPTERM1 2 624 ACC0 625 BRANCHIFNOT 631 627 GETGLOBAL "true" 629 RETURN 1 631 GETGLOBAL "false" 633 RETURN 1 635 CONST0 636 PUSHACC1 637 LTINT 638 BRANCHIF 646 640 CONSTINT 255 642 PUSHACC1 643 GTINT 644 BRANCHIFNOT 651 646 GETGLOBAL "char_of_int" 648 PUSHENVACC1 649 APPTERM1 2 651 ACC0 652 RETURN 1 654 RESTART 655 GRAB 1 657 ACC0 658 C_CALL1 ml_string_length 660 PUSHACC2 661 C_CALL1 ml_string_length 663 PUSHACC0 664 PUSHACC2 665 ADDINT 666 C_CALL1 create_string 668 PUSHACC2 669 PUSHCONST0 670 PUSHACC2 671 PUSHCONST0 672 PUSHACC7 673 C_CALL5 blit_string 675 ACC1 676 PUSHACC3 677 PUSHACC2 678 PUSHCONST0 679 PUSHACC 8 681 C_CALL5 blit_string 683 ACC0 684 RETURN 5 686 CONSTINT -1 688 PUSHACC1 689 XORINT 690 RETURN 1 692 CONST0 693 PUSHACC1 694 GEINT 695 BRANCHIFNOT 700 697 ACC0 698 RETURN 1 700 ACC0 701 NEGINT 702 RETURN 1 704 RESTART 705 GRAB 1 707 ACC1 708 PUSHACC1 709 C_CALL2 greaterequal 711 BRANCHIFNOT 716 713 ACC0 714 RETURN 2 716 ACC1 717 RETURN 2 719 RESTART 720 GRAB 1 722 ACC1 723 PUSHACC1 724 C_CALL2 lessequal 726 BRANCHIFNOT 731 728 ACC0 729 RETURN 2 731 ACC1 732 RETURN 2 734 ACC0 735 PUSHGETGLOBAL Invalid_argument 737 MAKEBLOCK2 0 739 RAISE 740 ACC0 741 PUSHGETGLOBAL Failure 743 MAKEBLOCK2 0 745 RAISE 746 CLOSURE 0, 740 749 PUSH 750 CLOSURE 0, 734 753 PUSHGETGLOBAL "Pervasives.Exit" 755 MAKEBLOCK1 0 757 PUSHGETGLOBAL "Pervasives.Assert_failure" 759 MAKEBLOCK1 0 761 PUSH 762 CLOSURE 0, 720 765 PUSH 766 CLOSURE 0, 705 769 PUSH 770 CLOSURE 0, 692 773 PUSH 774 CLOSURE 0, 686 777 PUSHCONST0 778 PUSHCONSTINT 31 780 PUSHCONST1 781 LSLINT 782 EQ 783 BRANCHIFNOT 789 785 CONSTINT 30 787 BRANCH 791 789 CONSTINT 62 791 PUSHCONST1 792 LSLINT 793 PUSHACC0 794 OFFSETINT -1 796 PUSH 797 CLOSURE 0, 655 800 PUSHACC 9 802 CLOSURE 1, 635 805 PUSH 806 CLOSURE 0, 624 809 PUSHACC 11 811 CLOSURE 1, 599 814 PUSH 815 CLOSURE 0, 592 818 PUSH 819 CLOSURE 0, 585 822 PUSH 823 CLOSUREREC 0, 12 827 CONST0 828 C_CALL1 caml_open_descriptor 830 PUSHCONST1 831 C_CALL1 caml_open_descriptor 833 PUSHCONST2 834 C_CALL1 caml_open_descriptor 836 PUSH 837 CLOSURE 0, 574 840 PUSHACC0 841 CLOSURE 1, 565 844 PUSHACC1 845 CLOSURE 1, 557 848 PUSH 849 CLOSURE 0, 545 852 PUSHACC 22 854 CLOSURE 1, 515 857 PUSH 858 CLOSURE 0, 505 861 PUSH 862 CLOSURE 0, 496 865 PUSH 866 CLOSURE 0, 485 869 PUSHACC0 870 CLOSURE 1, 477 873 PUSHACC1 874 CLOSURE 1, 470 877 PUSHACC 28 879 CLOSURE 1, 441 882 PUSH 883 CLOSUREREC 0, 32 887 ACC0 888 PUSHACC 31 890 CLOSURE 2, 411 893 PUSHACC 22 895 CLOSUREREC 1, 70 899 ACC 15 901 CLOSURE 1, 404 904 PUSHACC 11 906 PUSHACC 17 908 CLOSURE 2, 399 911 PUSHACC 12 913 PUSHACC 18 915 PUSHACC 23 917 CLOSURE 3, 392 920 PUSHACC 13 922 PUSHACC 19 924 PUSHACC 23 926 CLOSURE 3, 385 929 PUSHACC 14 931 PUSHACC 20 933 CLOSURE 2, 374 936 PUSHACC 20 938 CLOSURE 1, 364 941 PUSHACC 20 943 CLOSURE 1, 358 946 PUSHACC 17 948 PUSHACC 22 950 CLOSURE 2, 353 953 PUSHACC 18 955 PUSHACC 23 957 PUSHACC 29 959 CLOSURE 3, 346 962 PUSHACC 19 964 PUSHACC 24 966 PUSHACC 29 968 CLOSURE 3, 339 971 PUSHACC 20 973 PUSHACC 25 975 CLOSURE 2, 325 978 PUSHACC 25 980 CLOSURE 1, 315 983 PUSHACC 12 985 PUSHACC 28 987 PUSHACC 30 989 CLOSURE 3, 308 992 PUSHACC0 993 CLOSURE 1, 301 996 PUSHACC1 997 CLOSURE 1, 294 1000 PUSHACC 29 1002 PUSHACC 31 1004 CLOSURE 2, 286 1007 MAKEBLOCK1 0 1009 PUSHACC0 1010 CLOSURE 1, 275 1013 PUSHACC1 1014 CLOSURE 1, 263 1017 PUSHACC0 1018 CLOSURE 1, 255 1021 PUSHACC1 1022 PUSHACC 22 1024 PUSHACC4 1025 PUSHACC3 1026 PUSH 1027 CLOSURE 0, 247 1030 PUSH 1031 CLOSURE 0, 241 1034 PUSH 1035 CLOSURE 0, 236 1038 PUSH 1039 CLOSURE 0, 231 1042 PUSH 1043 CLOSURE 0, 223 1046 PUSH 1047 CLOSURE 0, 217 1050 PUSH 1051 CLOSURE 0, 212 1054 PUSH 1055 CLOSURE 0, 207 1058 PUSHACC 32 1060 PUSHACC 35 1062 PUSHACC 33 1064 PUSH 1065 CLOSURE 0, 202 1068 PUSHACC 41 1070 PUSHACC 40 1072 PUSHACC 42 1074 PUSH 1075 CLOSURE 0, 194 1078 PUSHACC 46 1080 PUSH 1081 CLOSURE 0, 188 1084 PUSH 1085 CLOSURE 0, 183 1088 PUSH 1089 CLOSURE 0, 175 1092 PUSHACC 51 1094 PUSH 1095 CLOSURE 0, 166 1098 PUSH 1099 CLOSURE 0, 157 1102 PUSHACC 55 1104 PUSHACC 57 1106 PUSH 1107 CLOSURE 0, 148 1110 PUSH 1111 CLOSURE 0, 142 1114 PUSHACC 63 1116 PUSHACC 62 1118 PUSHACC 64 1120 PUSHACC 38 1122 PUSHACC 40 1124 PUSHACC 42 1126 PUSHACC 44 1128 PUSHACC 46 1130 PUSHACC 48 1132 PUSHACC 50 1134 PUSHACC 52 1136 PUSHACC 54 1138 PUSHACC 56 1140 PUSHACC 58 1142 PUSHACC 60 1144 PUSHACC 62 1146 PUSHACC 64 1148 PUSHACC 66 1150 PUSHACC 82 1152 PUSHACC 84 1154 PUSHACC 86 1156 PUSHACC 88 1158 PUSHACC 90 1160 PUSHACC 92 1162 PUSHACC 94 1164 PUSHACC 96 1166 PUSHACC 98 1168 PUSHACC 100 1170 PUSHACC 104 1172 PUSHACC 104 1174 PUSHACC 104 1176 PUSHACC 108 1178 PUSHACC 110 1180 PUSHACC 112 1182 PUSHACC 117 1184 PUSHACC 117 1186 PUSHACC 117 1188 PUSHACC 117 1190 MAKEBLOCK 69, 0 1193 POP 53 1195 SETGLOBAL Pervasives 1197 BRANCH 2177 1199 RESTART 1200 GRAB 1 1202 ACC1 1203 BRANCHIFNOT 1213 1205 ACC1 1206 GETFIELD1 1207 PUSHACC1 1208 OFFSETINT 1 1210 PUSHOFFSETCLOSURE0 1211 APPTERM2 4 1213 ACC0 1214 RETURN 2 1216 RESTART 1217 GRAB 1 1219 ACC0 1220 BRANCHIFNOT 1251 1222 CONST0 1223 PUSHACC2 1224 EQ 1225 BRANCHIFNOT 1231 1227 ACC0 1228 GETFIELD0 1229 RETURN 2 1231 CONST0 1232 PUSHACC2 1233 GTINT 1234 BRANCHIFNOT 1244 1236 ACC1 1237 OFFSETINT -1 1239 PUSHACC1 1240 GETFIELD1 1241 PUSHOFFSETCLOSURE0 1242 APPTERM2 4 1244 GETGLOBAL "List.nth" 1246 PUSHGETGLOBALFIELD Pervasives, 2 1249 APPTERM1 3 1251 GETGLOBAL "nth" 1253 PUSHGETGLOBALFIELD Pervasives, 3 1256 APPTERM1 3 1258 RESTART 1259 GRAB 1 1261 ACC0 1262 BRANCHIFNOT 1274 1264 ACC1 1265 PUSHACC1 1266 GETFIELD0 1267 MAKEBLOCK2 0 1269 PUSHACC1 1270 GETFIELD1 1271 PUSHOFFSETCLOSURE0 1272 APPTERM2 4 1274 ACC1 1275 RETURN 2 1277 ACC0 1278 BRANCHIFNOT 1291 1280 ACC0 1281 GETFIELD1 1282 PUSHOFFSETCLOSURE0 1283 APPLY1 1284 PUSHACC1 1285 GETFIELD0 1286 PUSHGETGLOBALFIELD Pervasives, 16 1289 APPTERM2 3 1291 RETURN 1 1293 RESTART 1294 GRAB 1 1296 ACC1 1297 BRANCHIFNOT 1313 1299 ACC1 1300 GETFIELD0 1301 PUSHACC1 1302 APPLY1 1303 PUSHACC2 1304 GETFIELD1 1305 PUSHACC2 1306 PUSHOFFSETCLOSURE0 1307 APPLY2 1308 PUSHACC1 1309 MAKEBLOCK2 0 1311 POP 1 1313 RETURN 2 1315 RESTART 1316 GRAB 1 1318 ACC1 1319 BRANCHIFNOT 1331 1321 ACC1 1322 GETFIELD0 1323 PUSHACC1 1324 APPLY1 1325 ACC1 1326 GETFIELD1 1327 PUSHACC1 1328 PUSHOFFSETCLOSURE0 1329 APPTERM2 4 1331 RETURN 2 1333 RESTART 1334 GRAB 2 1336 ACC2 1337 BRANCHIFNOT 1350 1339 ACC2 1340 GETFIELD1 1341 PUSHACC3 1342 GETFIELD0 1343 PUSHACC3 1344 PUSHACC3 1345 APPLY2 1346 PUSHACC2 1347 PUSHOFFSETCLOSURE0 1348 APPTERM3 6 1350 ACC1 1351 RETURN 3 1353 RESTART 1354 GRAB 2 1356 ACC1 1357 BRANCHIFNOT 1370 1359 ACC2 1360 PUSHACC2 1361 GETFIELD1 1362 PUSHACC2 1363 PUSHOFFSETCLOSURE0 1364 APPLY3 1365 PUSHACC2 1366 GETFIELD0 1367 PUSHACC2 1368 APPTERM2 5 1370 ACC2 1371 RETURN 3 1373 RESTART 1374 GRAB 2 1376 ACC1 1377 BRANCHIFNOT 1400 1379 ACC2 1380 BRANCHIFNOT 1407 1382 ACC2 1383 GETFIELD0 1384 PUSHACC2 1385 GETFIELD0 1386 PUSHACC2 1387 APPLY2 1388 PUSHACC3 1389 GETFIELD1 1390 PUSHACC3 1391 GETFIELD1 1392 PUSHACC3 1393 PUSHOFFSETCLOSURE0 1394 APPLY3 1395 PUSHACC1 1396 MAKEBLOCK2 0 1398 RETURN 4 1400 ACC2 1401 BRANCHIFNOT 1405 1403 BRANCH 1407 1405 RETURN 3 1407 GETGLOBAL "List.map2" 1409 PUSHGETGLOBALFIELD Pervasives, 2 1412 APPTERM1 4 1414 RESTART 1415 GRAB 2 1417 ACC1 1418 BRANCHIFNOT 1437 1420 ACC2 1421 BRANCHIFNOT 1444 1423 ACC2 1424 GETFIELD0 1425 PUSHACC2 1426 GETFIELD0 1427 PUSHACC2 1428 APPLY2 1429 ACC2 1430 GETFIELD1 1431 PUSHACC2 1432 GETFIELD1 1433 PUSHACC2 1434 PUSHOFFSETCLOSURE0 1435 APPTERM3 6 1437 ACC2 1438 BRANCHIFNOT 1442 1440 BRANCH 1444 1442 RETURN 3 1444 GETGLOBAL "List.iter2" 1446 PUSHGETGLOBALFIELD Pervasives, 2 1449 APPTERM1 4 1451 RESTART 1452 GRAB 3 1454 ACC2 1455 BRANCHIFNOT 1476 1457 ACC3 1458 BRANCHIFNOT 1482 1460 ACC3 1461 GETFIELD1 1462 PUSHACC3 1463 GETFIELD1 1464 PUSHACC5 1465 GETFIELD0 1466 PUSHACC5 1467 GETFIELD0 1468 PUSHACC5 1469 PUSHACC5 1470 APPLY3 1471 PUSHACC3 1472 PUSHOFFSETCLOSURE0 1473 APPTERM 4, 8 1476 ACC3 1477 BRANCHIF 1482 1479 ACC1 1480 RETURN 4 1482 GETGLOBAL "List.fold_left2" 1484 PUSHGETGLOBALFIELD Pervasives, 2 1487 APPTERM1 5 1489 RESTART 1490 GRAB 3 1492 ACC1 1493 BRANCHIFNOT 1516 1495 ACC2 1496 BRANCHIFNOT 1522 1498 PUSH_RETADDR 1509 1500 ACC6 1501 PUSHACC6 1502 GETFIELD1 1503 PUSHACC6 1504 GETFIELD1 1505 PUSHACC6 1506 PUSHOFFSETCLOSURE0 1507 APPLY 4 1509 PUSHACC3 1510 GETFIELD0 1511 PUSHACC3 1512 GETFIELD0 1513 PUSHACC3 1514 APPTERM3 7 1516 ACC2 1517 BRANCHIF 1522 1519 ACC3 1520 RETURN 4 1522 GETGLOBAL "List.fold_right2" 1524 PUSHGETGLOBALFIELD Pervasives, 2 1527 APPTERM1 5 1529 RESTART 1530 GRAB 1 1532 ACC1 1533 BRANCHIFNOT 1549 1535 ACC1 1536 GETFIELD0 1537 PUSHACC1 1538 APPLY1 1539 BRANCHIFNOT 1547 1541 ACC1 1542 GETFIELD1 1543 PUSHACC1 1544 PUSHOFFSETCLOSURE0 1545 APPTERM2 4 1547 RETURN 2 1549 CONST1 1550 RETURN 2 1552 RESTART 1553 GRAB 1 1555 ACC1 1556 BRANCHIFNOT 1570 1558 ACC1 1559 GETFIELD0 1560 PUSHACC1 1561 APPLY1 1562 BRANCHIF 1570 1564 ACC1 1565 GETFIELD1 1566 PUSHACC1 1567 PUSHOFFSETCLOSURE0 1568 APPTERM2 4 1570 RETURN 2 1572 RESTART 1573 GRAB 2 1575 ACC1 1576 BRANCHIFNOT 1599 1578 ACC2 1579 BRANCHIFNOT 1605 1581 ACC2 1582 GETFIELD0 1583 PUSHACC2 1584 GETFIELD0 1585 PUSHACC2 1586 APPLY2 1587 BRANCHIFNOT 1597 1589 ACC2 1590 GETFIELD1 1591 PUSHACC2 1592 GETFIELD1 1593 PUSHACC2 1594 PUSHOFFSETCLOSURE0 1595 APPTERM3 6 1597 RETURN 3 1599 ACC2 1600 BRANCHIF 1605 1602 CONST1 1603 RETURN 3 1605 GETGLOBAL "List.for_all2" 1607 PUSHGETGLOBALFIELD Pervasives, 2 1610 APPTERM1 4 1612 RESTART 1613 GRAB 2 1615 ACC1 1616 BRANCHIFNOT 1639 1618 ACC2 1619 BRANCHIFNOT 1646 1621 ACC2 1622 GETFIELD0 1623 PUSHACC2 1624 GETFIELD0 1625 PUSHACC2 1626 APPLY2 1627 BRANCHIF 1637 1629 ACC2 1630 GETFIELD1 1631 PUSHACC2 1632 GETFIELD1 1633 PUSHACC2 1634 PUSHOFFSETCLOSURE0 1635 APPTERM3 6 1637 RETURN 3 1639 ACC2 1640 BRANCHIFNOT 1644 1642 BRANCH 1646 1644 RETURN 3 1646 GETGLOBAL "List.exists2" 1648 PUSHGETGLOBALFIELD Pervasives, 2 1651 APPTERM1 4 1653 RESTART 1654 GRAB 1 1656 ACC1 1657 BRANCHIFNOT 1672 1659 ACC0 1660 PUSHACC2 1661 GETFIELD0 1662 C_CALL2 equal 1664 BRANCHIF 1672 1666 ACC1 1667 GETFIELD1 1668 PUSHACC1 1669 PUSHOFFSETCLOSURE0 1670 APPTERM2 4 1672 RETURN 2 1674 RESTART 1675 GRAB 1 1677 ACC1 1678 BRANCHIFNOT 1692 1680 ACC0 1681 PUSHACC2 1682 GETFIELD0 1683 EQ 1684 BRANCHIF 1692 1686 ACC1 1687 GETFIELD1 1688 PUSHACC1 1689 PUSHOFFSETCLOSURE0 1690 APPTERM2 4 1692 RETURN 2 1694 RESTART 1695 GRAB 1 1697 ACC1 1698 BRANCHIFNOT 1719 1700 ACC1 1701 GETFIELD0 1702 PUSHACC1 1703 PUSHACC1 1704 GETFIELD0 1705 C_CALL2 equal 1707 BRANCHIFNOT 1713 1709 ACC0 1710 GETFIELD1 1711 RETURN 3 1713 ACC2 1714 GETFIELD1 1715 PUSHACC2 1716 PUSHOFFSETCLOSURE0 1717 APPTERM2 5 1719 GETGLOBAL Not_found 1721 MAKEBLOCK1 0 1723 RAISE 1724 RESTART 1725 GRAB 1 1727 ACC1 1728 BRANCHIFNOT 1748 1730 ACC1 1731 GETFIELD0 1732 PUSHACC1 1733 PUSHACC1 1734 GETFIELD0 1735 EQ 1736 BRANCHIFNOT 1742 1738 ACC0 1739 GETFIELD1 1740 RETURN 3 1742 ACC2 1743 GETFIELD1 1744 PUSHACC2 1745 PUSHOFFSETCLOSURE0 1746 APPTERM2 5 1748 GETGLOBAL Not_found 1750 MAKEBLOCK1 0 1752 RAISE 1753 RESTART 1754 GRAB 1 1756 ACC1 1757 BRANCHIFNOT 1773 1759 ACC0 1760 PUSHACC2 1761 GETFIELD0 1762 GETFIELD0 1763 C_CALL2 equal 1765 BRANCHIF 1773 1767 ACC1 1768 GETFIELD1 1769 PUSHACC1 1770 PUSHOFFSETCLOSURE0 1771 APPTERM2 4 1773 RETURN 2 1775 RESTART 1776 GRAB 1 1778 ACC1 1779 BRANCHIFNOT 1794 1781 ACC0 1782 PUSHACC2 1783 GETFIELD0 1784 GETFIELD0 1785 EQ 1786 BRANCHIF 1794 1788 ACC1 1789 GETFIELD1 1790 PUSHACC1 1791 PUSHOFFSETCLOSURE0 1792 APPTERM2 4 1794 RETURN 2 1796 RESTART 1797 GRAB 1 1799 ACC1 1800 BRANCHIFNOT 1825 1802 ACC1 1803 GETFIELD0 1804 PUSHACC2 1805 GETFIELD1 1806 PUSHACC2 1807 PUSHACC2 1808 GETFIELD0 1809 C_CALL2 equal 1811 BRANCHIFNOT 1816 1813 ACC0 1814 RETURN 4 1816 ACC0 1817 PUSHACC3 1818 PUSHOFFSETCLOSURE0 1819 APPLY2 1820 PUSHACC2 1821 MAKEBLOCK2 0 1823 POP 2 1825 RETURN 2 1827 RESTART 1828 GRAB 1 1830 ACC1 1831 BRANCHIFNOT 1855 1833 ACC1 1834 GETFIELD0 1835 PUSHACC2 1836 GETFIELD1 1837 PUSHACC2 1838 PUSHACC2 1839 GETFIELD0 1840 EQ 1841 BRANCHIFNOT 1846 1843 ACC0 1844 RETURN 4 1846 ACC0 1847 PUSHACC3 1848 PUSHOFFSETCLOSURE0 1849 APPLY2 1850 PUSHACC2 1851 MAKEBLOCK2 0 1853 POP 2 1855 RETURN 2 1857 RESTART 1858 GRAB 1 1860 ACC1 1861 BRANCHIFNOT 1879 1863 ACC1 1864 GETFIELD0 1865 PUSHACC0 1866 PUSHACC2 1867 APPLY1 1868 BRANCHIFNOT 1873 1870 ACC0 1871 RETURN 3 1873 ACC2 1874 GETFIELD1 1875 PUSHACC2 1876 PUSHOFFSETCLOSURE0 1877 APPTERM2 5 1879 GETGLOBAL Not_found 1881 MAKEBLOCK1 0 1883 RAISE 1884 RESTART 1885 GRAB 2 1887 ACC2 1888 BRANCHIFNOT 1917 1890 ACC2 1891 GETFIELD0 1892 PUSHACC3 1893 GETFIELD1 1894 PUSHACC1 1895 PUSHENVACC2 1896 APPLY1 1897 BRANCHIFNOT 1908 1899 ACC0 1900 PUSHACC4 1901 PUSHACC4 1902 PUSHACC4 1903 MAKEBLOCK2 0 1905 PUSHOFFSETCLOSURE0 1906 APPTERM3 8 1908 ACC0 1909 PUSHACC4 1910 PUSHACC3 1911 MAKEBLOCK2 0 1913 PUSHACC4 1914 PUSHOFFSETCLOSURE0 1915 APPTERM3 8 1917 ACC1 1918 PUSHENVACC1 1919 APPLY1 1920 PUSHACC1 1921 PUSHENVACC1 1922 APPLY1 1923 MAKEBLOCK2 0 1925 RETURN 3 1927 RESTART 1928 GRAB 1 1930 ACC0 1931 PUSHENVACC1 1932 CLOSUREREC 2, 1885 1936 ACC2 1937 PUSHCONST0 1938 PUSHCONST0 1939 PUSHACC3 1940 APPTERM3 6 1942 ACC0 1943 BRANCHIFNOT 1967 1945 ACC0 1946 GETFIELD0 1947 PUSHACC1 1948 GETFIELD1 1949 PUSHOFFSETCLOSURE0 1950 APPLY1 1951 PUSHACC0 1952 GETFIELD1 1953 PUSHACC2 1954 GETFIELD1 1955 MAKEBLOCK2 0 1957 PUSHACC1 1958 GETFIELD0 1959 PUSHACC3 1960 GETFIELD0 1961 MAKEBLOCK2 0 1963 MAKEBLOCK2 0 1965 RETURN 3 1967 GETGLOBAL <0>(0, 0) 1969 RETURN 1 1971 RESTART 1972 GRAB 1 1974 ACC0 1975 BRANCHIFNOT 1996 1977 ACC1 1978 BRANCHIFNOT 2003 1980 ACC1 1981 GETFIELD1 1982 PUSHACC1 1983 GETFIELD1 1984 PUSHOFFSETCLOSURE0 1985 APPLY2 1986 PUSHACC2 1987 GETFIELD0 1988 PUSHACC2 1989 GETFIELD0 1990 MAKEBLOCK2 0 1992 MAKEBLOCK2 0 1994 RETURN 2 1996 ACC1 1997 BRANCHIFNOT 2001 1999 BRANCH 2003 2001 RETURN 2 2003 GETGLOBAL "List.combine" 2005 PUSHGETGLOBALFIELD Pervasives, 2 2008 APPTERM1 3 2010 RESTART 2011 GRAB 1 2013 ACC1 2014 BRANCHIFNOT 2038 2016 ACC1 2017 GETFIELD0 2018 PUSHACC2 2019 GETFIELD1 2020 PUSHACC1 2021 PUSHENVACC2 2022 APPLY1 2023 BRANCHIFNOT 2033 2025 ACC0 2026 PUSHACC3 2027 PUSHACC3 2028 MAKEBLOCK2 0 2030 PUSHOFFSETCLOSURE0 2031 APPTERM2 6 2033 ACC0 2034 PUSHACC3 2035 PUSHOFFSETCLOSURE0 2036 APPTERM2 6 2038 ACC0 2039 PUSHENVACC1 2040 APPTERM1 3 2042 ACC0 2043 PUSHENVACC1 2044 CLOSUREREC 2, 2011 2048 CONST0 2049 PUSHACC1 2050 APPTERM1 3 2052 RESTART 2053 GRAB 2 2055 ACC1 2056 BRANCHIFNOT 2077 2058 ACC2 2059 BRANCHIFNOT 2084 2061 ACC2 2062 GETFIELD1 2063 PUSHACC2 2064 GETFIELD1 2065 PUSHACC2 2066 PUSHACC5 2067 GETFIELD0 2068 PUSHACC5 2069 GETFIELD0 2070 PUSHENVACC1 2071 APPLY2 2072 MAKEBLOCK2 0 2074 PUSHOFFSETCLOSURE0 2075 APPTERM3 6 2077 ACC2 2078 BRANCHIFNOT 2082 2080 BRANCH 2084 2082 RETURN 3 2084 GETGLOBAL "List.rev_map2" 2086 PUSHGETGLOBALFIELD Pervasives, 2 2089 APPTERM1 4 2091 RESTART 2092 GRAB 2 2094 ACC0 2095 CLOSUREREC 1, 2053 2099 ACC3 2100 PUSHACC3 2101 PUSHCONST0 2102 PUSHACC3 2103 APPTERM3 7 2105 RESTART 2106 GRAB 1 2108 ACC1 2109 BRANCHIFNOT 2123 2111 ACC1 2112 GETFIELD1 2113 PUSHACC1 2114 PUSHACC3 2115 GETFIELD0 2116 PUSHENVACC1 2117 APPLY1 2118 MAKEBLOCK2 0 2120 PUSHOFFSETCLOSURE0 2121 APPTERM2 4 2123 ACC0 2124 RETURN 2 2126 RESTART 2127 GRAB 1 2129 ACC0 2130 CLOSUREREC 1, 2106 2134 ACC2 2135 PUSHCONST0 2136 PUSHACC2 2137 APPTERM2 5 2139 CONST0 2140 PUSHACC1 2141 PUSHENVACC1 2142 APPTERM2 3 2144 ACC0 2145 BRANCHIFNOT 2151 2147 ACC0 2148 GETFIELD1 2149 RETURN 1 2151 GETGLOBAL "tl" 2153 PUSHGETGLOBALFIELD Pervasives, 3 2156 APPTERM1 2 2158 ACC0 2159 BRANCHIFNOT 2165 2161 ACC0 2162 GETFIELD0 2163 RETURN 1 2165 GETGLOBAL "hd" 2167 PUSHGETGLOBALFIELD Pervasives, 3 2170 APPTERM1 2 2172 ACC0 2173 PUSHCONST0 2174 PUSHENVACC1 2175 APPTERM2 3 2177 CLOSUREREC 0, 1200 2181 ACC0 2182 CLOSURE 1, 2172 2185 PUSH 2186 CLOSURE 0, 2158 2189 PUSH 2190 CLOSURE 0, 2144 2193 PUSH 2194 CLOSUREREC 0, 1217 2198 GETGLOBALFIELD Pervasives, 16 2201 PUSH 2202 CLOSUREREC 0, 1259 2206 ACC0 2207 CLOSURE 1, 2139 2210 PUSH 2211 CLOSUREREC 0, 1277 2215 CLOSUREREC 0, 1294 2219 CLOSURE 0, 2127 2222 PUSH 2223 CLOSUREREC 0, 1316 2227 CLOSUREREC 0, 1334 2231 CLOSUREREC 0, 1354 2235 CLOSUREREC 0, 1374 2239 CLOSURE 0, 2092 2242 PUSH 2243 CLOSUREREC 0, 1415 2247 CLOSUREREC 0, 1452 2251 CLOSUREREC 0, 1490 2255 CLOSUREREC 0, 1530 2259 CLOSUREREC 0, 1553 2263 CLOSUREREC 0, 1573 2267 CLOSUREREC 0, 1613 2271 CLOSUREREC 0, 1654 2275 CLOSUREREC 0, 1675 2279 CLOSUREREC 0, 1695 2283 CLOSUREREC 0, 1725 2287 CLOSUREREC 0, 1754 2291 CLOSUREREC 0, 1776 2295 CLOSUREREC 0, 1797 2299 CLOSUREREC 0, 1828 2303 CLOSUREREC 0, 1858 2307 ACC 24 2309 CLOSURE 1, 2042 2312 PUSHACC 25 2314 CLOSUREREC 1, 1928 2318 CLOSUREREC 0, 1942 2322 CLOSUREREC 0, 1972 2326 ACC0 2327 PUSHACC2 2328 PUSHACC7 2329 PUSHACC 9 2331 PUSHACC 11 2333 PUSHACC 13 2335 PUSHACC 15 2337 PUSHACC 17 2339 PUSHACC 10 2341 PUSHACC 12 2343 PUSHACC 13 2345 PUSHACC 15 2347 PUSHACC 23 2349 PUSHACC 25 2351 PUSHACC 27 2353 PUSHACC 29 2355 PUSHACC 31 2357 PUSHACC 33 2359 PUSHACC 35 2361 PUSHACC 37 2363 PUSHACC 40 2365 PUSHACC 42 2367 PUSHACC 41 2369 PUSHACC 45 2371 PUSHACC 47 2373 PUSHACC 50 2375 PUSHACC 52 2377 PUSHACC 51 2379 PUSHACC 55 2381 PUSHACC 56 2383 PUSHACC 59 2385 PUSHACC 61 2387 PUSHACC 60 2389 PUSHACC 64 2391 PUSHACC 66 2393 PUSHACC 68 2395 PUSHACC 70 2397 MAKEBLOCK 37, 0 2400 POP 36 2402 SETGLOBAL List 2404 BRANCH 2432 2406 CONST0 2407 PUSHACC1 2408 LEINT 2409 BRANCHIFNOT 2414 2411 CONST0 2412 RETURN 1 2414 ACC0 2415 OFFSETINT -1 2417 PUSHOFFSETCLOSURE0 2418 APPLY1 2419 PUSHACC1 2420 MAKEBLOCK2 0 2422 RETURN 1 2424 RESTART 2425 GRAB 1 2427 ACC1 2428 PUSHACC1 2429 ADDINT 2430 RETURN 2 2432 CLOSUREREC 0, 2406 2436 CONSTINT 300 2438 PUSHACC1 2439 APPLY1 2440 PUSHCONST0 2441 C_CALL1 gc_major 2443 CONSTINT 150 2445 PUSHCONSTINT 301 2447 MULINT 2448 PUSHACC1 2449 PUSHCONST0 2450 PUSH 2451 CLOSURE 0, 2425 2454 PUSHGETGLOBALFIELD List, 12 2457 APPLY3 2458 NEQ 2459 BRANCHIFNOT 2466 2461 GETGLOBAL Not_found 2463 MAKEBLOCK1 0 2465 RAISE 2466 POP 2 2468 ATOM0 2469 SETGLOBAL T320-gc-2 2471 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t010-const0.ml0000644000175000017500000000013412124403241023137 0ustar tootstoots0;; (** 0 CONST0 1 ATOM0 2 SETGLOBAL T010-const0 4 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t172-pushenvacc2.ml0000644000175000017500000000123412124403241024165 0ustar tootstootsopen Lib;; let x = 5 in let y = 4 in let f _ = y + x in if f 0 <> 9 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 16 11 ENVACC1 12 PUSHENVACC2 13 ADDINT 14 RETURN 1 16 CONSTINT 5 18 PUSHCONSTINT 4 20 PUSHACC0 21 PUSHACC2 22 CLOSURE 2, 11 25 PUSHCONSTINT 9 27 PUSHCONST0 28 PUSHACC2 29 APPLY1 30 NEQ 31 BRANCHIFNOT 38 33 GETGLOBAL Not_found 35 MAKEBLOCK1 0 37 RAISE 38 POP 3 40 ATOM0 41 SETGLOBAL T172-pushenvacc2 43 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t070-branchifnot.ml0000644000175000017500000000050712124403241024240 0ustar tootstootsopen Lib;; if false then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 BRANCHIFNOT 17 12 GETGLOBAL Not_found 14 MAKEBLOCK1 0 16 RAISE 17 ATOM0 18 SETGLOBAL T070-branchifnot 20 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/lib.ml0000644000175000017500000000277312124403241022030 0ustar tootstoots(* file $Id$ *) external raise : exn -> 'a = "%raise" external not : bool -> bool = "%boolnot" external (=) : 'a -> 'a -> bool = "%equal" external (<>) : 'a -> 'a -> bool = "%notequal" external (<) : 'a -> 'a -> bool = "%lessthan" external (>) : 'a -> 'a -> bool = "%greaterthan" external (<=) : 'a -> 'a -> bool = "%lessequal" external (>=) : 'a -> 'a -> bool = "%greaterequal" external (~-) : int -> int = "%negint" external (+) : int -> int -> int = "%addint" external (-) : int -> int -> int = "%subint" external ( * ) : int -> int -> int = "%mulint" external (/) : int -> int -> int = "%divint" external (mod) : int -> int -> int = "%modint" external (land) : int -> int -> int = "%andint" external (lor) : int -> int -> int = "%orint" external (lxor) : int -> int -> int = "%xorint" external (lsl) : int -> int -> int = "%lslint" external (lsr) : int -> int -> int = "%lsrint" external (asr) : int -> int -> int = "%asrint" external ignore : 'a -> unit = "%ignore" type 'a ref = { mutable contents: 'a } external ref : 'a -> 'a ref = "%makemutable" external (!) : 'a ref -> 'a = "%field0" external (:=) : 'a ref -> 'a -> unit = "%setfield0" external incr : int ref -> unit = "%incr" external decr : int ref -> unit = "%decr" type 'a option = None | Some of 'a type 'a weak_t;; external weak_create: int -> 'a weak_t = "caml_weak_create";; external weak_set : 'a weak_t -> int -> 'a option -> unit = "caml_weak_set";; external weak_get: 'a weak_t -> int -> 'a option = "caml_weak_get";; let x = 42;; (* eof $Id$ *) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t130-getvectitem.ml0000644000175000017500000000071612124403241024262 0ustar tootstootsopen Lib;; if [| 1; 2 |].(1) <> 2 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST2 10 PUSHCONST1 11 PUSHCONST2 12 PUSHCONST1 13 MAKEBLOCK2 0 15 GETVECTITEM 16 NEQ 17 BRANCHIFNOT 24 19 GETGLOBAL Not_found 21 MAKEBLOCK1 0 23 RAISE 24 ATOM0 25 SETGLOBAL T130-getvectitem 27 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t200-getfield1.ml0000644000175000017500000000070312124403241023600 0ustar tootstootsopen Lib;; type t = { a : int; b : int; };; if { a = 7; b = 6 }.b <> 6 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 6 11 PUSHGETGLOBAL <0>(7, 6) 13 GETFIELD1 14 NEQ 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 ATOM0 23 SETGLOBAL T200-getfield1 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t011-constint.ml0000644000175000017500000000014112124403241023571 0ustar tootstoots4;; (** 0 CONSTINT 4 2 ATOM0 3 SETGLOBAL T011-constint 5 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t240-c_call5.ml0000644000175000017500000000120112124403241023234 0ustar tootstootsopen Lib;; let s = "abcdefgh" in String.unsafe_blit s 3 s 0 3; if s.[0] <> 'd' then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL "abcdefgh" 11 PUSHCONST3 12 PUSHCONST0 13 PUSHACC2 14 PUSHCONST3 15 PUSHACC4 16 C_CALL5 blit_string 18 CONSTINT 100 20 PUSHCONST0 21 PUSHACC2 22 GETSTRINGCHAR 23 NEQ 24 BRANCHIFNOT 31 26 GETGLOBAL Not_found 28 MAKEBLOCK1 0 30 RAISE 31 POP 1 33 ATOM0 34 SETGLOBAL T240-c_call5 36 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t140-switch-3.ml0000644000175000017500000000102612124403241023377 0ustar tootstootsopen Lib;; match 2 with | 0 -> raise Not_found | 1 -> raise Not_found | _ -> () ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST2 10 PUSHACC0 11 SWITCH int 0 -> 17 int 1 -> 22 15 BRANCH 27 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 GETGLOBAL Not_found 24 MAKEBLOCK1 0 26 RAISE 27 CONST0 28 POP 1 30 ATOM0 31 SETGLOBAL T140-switch-3 33 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t172-pushenvacc1.ml0000644000175000017500000000114612124403241024166 0ustar tootstootsopen Lib;; let x = 5 in let f _ = x + x in if f 0 <> 10 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 16 11 ENVACC1 12 PUSHENVACC1 13 ADDINT 14 RETURN 1 16 CONSTINT 5 18 PUSHACC0 19 CLOSURE 1, 11 22 PUSHCONSTINT 10 24 PUSHCONST0 25 PUSHACC2 26 APPLY1 27 NEQ 28 BRANCHIFNOT 35 30 GETGLOBAL Not_found 32 MAKEBLOCK1 0 34 RAISE 35 POP 2 37 ATOM0 38 SETGLOBAL T172-pushenvacc1 40 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t150-push-1.ml0000644000175000017500000000056612124403241023064 0ustar tootstootsopen Lib;; let _ = 0 in try 0 with _ -> 0 ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSH 11 PUSHTRAP 17 13 CONST0 14 POPTRAP 15 BRANCH 20 17 PUSHCONST0 18 POP 1 20 POP 1 22 ATOM0 23 SETGLOBAL T150-push-1 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-addint.ml0000644000175000017500000000070012124403241023174 0ustar tootstootsopen Lib;; let x = 1 in if 1 + x <> 2 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONST2 11 PUSHACC1 12 PUSHCONST1 13 ADDINT 14 NEQ 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 POP 1 24 ATOM0 25 SETGLOBAL T110-addint 27 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t240-c_call3.ml0000644000175000017500000000100112124403241023230 0ustar tootstootsopen Lib;; if Hashtbl.hash_param 5 6 [1;2;3] <> 697606130 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONSTINT 196799 11 PUSHGETGLOBAL <0>(1, <0>(2, <0>(3, 0))) 13 PUSHCONSTINT 6 15 PUSHCONSTINT 5 17 C_CALL3 hash_univ_param 19 NEQ 20 BRANCHIFNOT 27 22 GETGLOBAL Not_found 24 MAKEBLOCK1 0 26 RAISE 27 ATOM0 28 SETGLOBAL T240-c_call3 30 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t010-const3.ml0000644000175000017500000000013412124403241023142 0ustar tootstoots3;; (** 0 CONST3 1 ATOM0 2 SETGLOBAL T010-const3 4 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t172-pushenvacc4.ml0000644000175000017500000000153612124403241024174 0ustar tootstootsopen Lib;; let x = 5 in let y = 4 in let z = 3 in let a = 2 in let f _ = a + z + y + x in if f 0 <> 14 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 21 11 ENVACC1 12 PUSHENVACC2 13 PUSHENVACC3 14 PUSHENVACC 4 16 ADDINT 17 ADDINT 18 ADDINT 19 RETURN 1 21 CONSTINT 5 23 PUSHCONSTINT 4 25 PUSHCONST3 26 PUSHCONST2 27 PUSHACC0 28 PUSHACC2 29 PUSHACC4 30 PUSHACC6 31 CLOSURE 4, 11 34 PUSHCONSTINT 14 36 PUSHCONST0 37 PUSHACC2 38 APPLY1 39 NEQ 40 BRANCHIFNOT 47 42 GETGLOBAL Not_found 44 MAKEBLOCK1 0 46 RAISE 47 POP 5 49 ATOM0 50 SETGLOBAL T172-pushenvacc4 52 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t092-pushacc2.ml0000644000175000017500000000067612124403241023466 0ustar tootstootsopen Lib;; let x = false in let y = true in let z = true in if x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST1 11 PUSHCONST1 12 PUSHACC2 13 BRANCHIFNOT 20 15 GETGLOBAL Not_found 17 MAKEBLOCK1 0 19 RAISE 20 POP 3 22 ATOM0 23 SETGLOBAL T092-pushacc2 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t252-pushoffsetclosure.ml0000644000175000017500000000130312124403241025523 0ustar tootstootsopen Lib;; let rec f x = x and g _ = f 4 and h _ = f 6 in if h 1 <> 6 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 25 11 ACC0 12 RETURN 1 14 CONSTINT 4 16 PUSHOFFSETCLOSUREM2 17 APPTERM1 2 19 CONSTINT 6 21 PUSHOFFSETCLOSURE -4 23 APPTERM1 2 25 CLOSUREREC 0, 11, 14, 19 31 CONSTINT 6 33 PUSHCONST1 34 PUSHACC2 35 APPLY1 36 NEQ 37 BRANCHIFNOT 44 39 GETGLOBAL Not_found 41 MAKEBLOCK1 0 43 RAISE 44 POP 3 46 ATOM0 47 SETGLOBAL T252-pushoffsetclosure 49 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t320-gc-3.ml0000644000175000017500000007757212124403241022512 0ustar tootstootsopen Lib;; let rec f n = if n <= 0 then [] else n :: f (n-1) in let l = f 300 in Gc.full_major (); if List.fold_left (+) 0 l <> 301 * 150 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 746 11 RESTART 12 GRAB 1 14 ACC0 15 BRANCHIFNOT 28 17 ACC1 18 PUSHACC1 19 GETFIELD1 20 PUSHOFFSETCLOSURE0 21 APPLY2 22 PUSHACC1 23 GETFIELD0 24 MAKEBLOCK2 0 26 RETURN 2 28 ACC1 29 RETURN 2 31 RESTART 32 GRAB 3 34 CONST0 35 PUSHACC4 36 LEINT 37 BRANCHIFNOT 42 39 CONST0 40 RETURN 4 42 ACC3 43 PUSHACC3 44 PUSHACC3 45 PUSHACC3 46 C_CALL4 caml_input 48 PUSHCONST0 49 PUSHACC1 50 EQ 51 BRANCHIFNOT 58 53 GETGLOBAL End_of_file 55 MAKEBLOCK1 0 57 RAISE 58 ACC0 59 PUSHACC5 60 SUBINT 61 PUSHACC1 62 PUSHACC5 63 ADDINT 64 PUSHACC4 65 PUSHACC4 66 PUSHOFFSETCLOSURE0 67 APPTERM 4, 9 70 ACC0 71 C_CALL1 caml_input_scan_line 73 PUSHCONST0 74 PUSHACC1 75 EQ 76 BRANCHIFNOT 83 78 GETGLOBAL End_of_file 80 MAKEBLOCK1 0 82 RAISE 83 CONST0 84 PUSHACC1 85 GTINT 86 BRANCHIFNOT 107 88 ACC0 89 OFFSETINT -1 91 C_CALL1 create_string 93 PUSHACC1 94 OFFSETINT -1 96 PUSHCONST0 97 PUSHACC2 98 PUSHACC5 99 C_CALL4 caml_input 101 ACC2 102 C_CALL1 caml_input_char 104 ACC0 105 RETURN 3 107 ACC0 108 NEGINT 109 C_CALL1 create_string 111 PUSHACC1 112 NEGINT 113 PUSHCONST0 114 PUSHACC2 115 PUSHACC5 116 C_CALL4 caml_input 118 CONST0 119 PUSHTRAP 130 121 ACC6 122 PUSHOFFSETCLOSURE0 123 APPLY1 124 PUSHACC5 125 PUSHENVACC1 126 APPLY2 127 POPTRAP 128 RETURN 3 130 PUSHGETGLOBAL End_of_file 132 PUSHACC1 133 GETFIELD0 134 EQ 135 BRANCHIFNOT 140 137 ACC1 138 RETURN 4 140 ACC0 141 RAISE 142 ACC0 143 C_CALL1 caml_flush 145 RETURN 1 147 RESTART 148 GRAB 1 150 ACC1 151 PUSHACC1 152 C_CALL2 caml_output_char 154 RETURN 2 156 RESTART 157 GRAB 1 159 ACC1 160 PUSHACC1 161 C_CALL2 caml_output_char 163 RETURN 2 165 RESTART 166 GRAB 1 168 ACC1 169 PUSHACC1 170 C_CALL2 caml_output_int 172 RETURN 2 174 RESTART 175 GRAB 1 177 ACC1 178 PUSHACC1 179 C_CALL2 caml_seek_out 181 RETURN 2 183 ACC0 184 C_CALL1 caml_pos_out 186 RETURN 1 188 ACC0 189 C_CALL1 caml_channel_size 191 RETURN 1 193 RESTART 194 GRAB 1 196 ACC1 197 PUSHACC1 198 C_CALL2 caml_set_binary_mode 200 RETURN 2 202 ACC0 203 C_CALL1 caml_input_char 205 RETURN 1 207 ACC0 208 C_CALL1 caml_input_char 210 RETURN 1 212 ACC0 213 C_CALL1 caml_input_int 215 RETURN 1 217 ACC0 218 C_CALL1 input_value 220 RETURN 1 222 RESTART 223 GRAB 1 225 ACC1 226 PUSHACC1 227 C_CALL2 caml_seek_in 229 RETURN 2 231 ACC0 232 C_CALL1 caml_pos_in 234 RETURN 1 236 ACC0 237 C_CALL1 caml_channel_size 239 RETURN 1 241 ACC0 242 C_CALL1 caml_close_channel 244 RETURN 1 246 RESTART 247 GRAB 1 249 ACC1 250 PUSHACC1 251 C_CALL2 caml_set_binary_mode 253 RETURN 2 255 CONST0 256 PUSHENVACC1 257 APPLY1 258 ACC0 259 C_CALL1 sys_exit 261 RETURN 1 263 CONST0 264 PUSHENVACC1 265 GETFIELD0 266 APPTERM1 2 268 CONST0 269 PUSHENVACC1 270 APPLY1 271 CONST0 272 PUSHENVACC2 273 APPTERM1 2 275 ENVACC1 276 GETFIELD0 277 PUSHACC0 278 PUSHACC2 279 CLOSURE 2, 268 282 PUSHENVACC1 283 SETFIELD0 284 RETURN 2 286 ENVACC1 287 C_CALL1 caml_flush 289 ENVACC2 290 C_CALL1 caml_flush 292 RETURN 1 294 CONST0 295 PUSHENVACC1 296 APPLY1 297 C_CALL1 float_of_string 299 RETURN 1 301 CONST0 302 PUSHENVACC1 303 APPLY1 304 C_CALL1 int_of_string 306 RETURN 1 308 ENVACC2 309 C_CALL1 caml_flush 311 ENVACC1 312 PUSHENVACC3 313 APPTERM1 2 315 CONSTINT 13 317 PUSHENVACC1 318 C_CALL2 caml_output_char 320 ENVACC1 321 C_CALL1 caml_flush 323 RETURN 1 325 ACC0 326 PUSHENVACC1 327 PUSHENVACC2 328 APPLY2 329 CONSTINT 13 331 PUSHENVACC1 332 C_CALL2 caml_output_char 334 ENVACC1 335 C_CALL1 caml_flush 337 RETURN 1 339 ACC0 340 PUSHENVACC1 341 APPLY1 342 PUSHENVACC2 343 PUSHENVACC3 344 APPTERM2 3 346 ACC0 347 PUSHENVACC1 348 APPLY1 349 PUSHENVACC2 350 PUSHENVACC3 351 APPTERM2 3 353 ACC0 354 PUSHENVACC1 355 PUSHENVACC2 356 APPTERM2 3 358 ACC0 359 PUSHENVACC1 360 C_CALL2 caml_output_char 362 RETURN 1 364 CONSTINT 13 366 PUSHENVACC1 367 C_CALL2 caml_output_char 369 ENVACC1 370 C_CALL1 caml_flush 372 RETURN 1 374 ACC0 375 PUSHENVACC1 376 PUSHENVACC2 377 APPLY2 378 CONSTINT 13 380 PUSHENVACC1 381 C_CALL2 caml_output_char 383 RETURN 1 385 ACC0 386 PUSHENVACC1 387 APPLY1 388 PUSHENVACC2 389 PUSHENVACC3 390 APPTERM2 3 392 ACC0 393 PUSHENVACC1 394 APPLY1 395 PUSHENVACC2 396 PUSHENVACC3 397 APPTERM2 3 399 ACC0 400 PUSHENVACC1 401 PUSHENVACC2 402 APPTERM2 3 404 ACC0 405 PUSHENVACC1 406 C_CALL2 caml_output_char 408 RETURN 1 410 RESTART 411 GRAB 3 413 CONST0 414 PUSHACC3 415 LTINT 416 BRANCHIF 427 418 ACC1 419 C_CALL1 ml_string_length 421 PUSHACC4 422 PUSHACC4 423 ADDINT 424 GTINT 425 BRANCHIFNOT 432 427 GETGLOBAL "really_input" 429 PUSHENVACC1 430 APPTERM1 5 432 ACC3 433 PUSHACC3 434 PUSHACC3 435 PUSHACC3 436 PUSHENVACC2 437 APPTERM 4, 8 440 RESTART 441 GRAB 3 443 CONST0 444 PUSHACC3 445 LTINT 446 BRANCHIF 457 448 ACC1 449 C_CALL1 ml_string_length 451 PUSHACC4 452 PUSHACC4 453 ADDINT 454 GTINT 455 BRANCHIFNOT 462 457 GETGLOBAL "input" 459 PUSHENVACC1 460 APPTERM1 5 462 ACC3 463 PUSHACC3 464 PUSHACC3 465 PUSHACC3 466 C_CALL4 caml_input 468 RETURN 4 470 ACC0 471 PUSHCONST0 472 PUSHGETGLOBAL <0>(0, <0>(6, 0)) 474 PUSHENVACC1 475 APPTERM3 4 477 ACC0 478 PUSHCONST0 479 PUSHGETGLOBAL <0>(0, <0>(7, 0)) 481 PUSHENVACC1 482 APPTERM3 4 484 RESTART 485 GRAB 2 487 ACC1 488 PUSHACC1 489 PUSHACC4 490 C_CALL3 sys_open 492 C_CALL1 caml_open_descriptor 494 RETURN 3 496 ACC0 497 C_CALL1 caml_flush 499 ACC0 500 C_CALL1 caml_close_channel 502 RETURN 1 504 RESTART 505 GRAB 1 507 CONST0 508 PUSHACC2 509 PUSHACC2 510 C_CALL3 output_value 512 RETURN 2 514 RESTART 515 GRAB 3 517 CONST0 518 PUSHACC3 519 LTINT 520 BRANCHIF 531 522 ACC1 523 C_CALL1 ml_string_length 525 PUSHACC4 526 PUSHACC4 527 ADDINT 528 GTINT 529 BRANCHIFNOT 536 531 GETGLOBAL "output" 533 PUSHENVACC1 534 APPTERM1 5 536 ACC3 537 PUSHACC3 538 PUSHACC3 539 PUSHACC3 540 C_CALL4 caml_output 542 RETURN 4 544 RESTART 545 GRAB 1 547 ACC1 548 C_CALL1 ml_string_length 550 PUSHCONST0 551 PUSHACC3 552 PUSHACC3 553 C_CALL4 caml_output 555 RETURN 2 557 ACC0 558 PUSHCONSTINT 438 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0)))) 562 PUSHENVACC1 563 APPTERM3 4 565 ACC0 566 PUSHCONSTINT 438 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0)))) 570 PUSHENVACC1 571 APPTERM3 4 573 RESTART 574 GRAB 2 576 ACC1 577 PUSHACC1 578 PUSHACC4 579 C_CALL3 sys_open 581 C_CALL1 caml_open_descriptor 583 RETURN 3 585 ACC0 586 PUSHGETGLOBAL "%.12g" 588 C_CALL2 format_float 590 RETURN 1 592 ACC0 593 PUSHGETGLOBAL "%d" 595 C_CALL2 format_int 597 RETURN 1 599 GETGLOBAL "false" 601 PUSHACC1 602 C_CALL2 string_equal 604 BRANCHIFNOT 609 606 CONST0 607 RETURN 1 609 GETGLOBAL "true" 611 PUSHACC1 612 C_CALL2 string_equal 614 BRANCHIFNOT 619 616 CONST1 617 RETURN 1 619 GETGLOBAL "bool_of_string" 621 PUSHENVACC1 622 APPTERM1 2 624 ACC0 625 BRANCHIFNOT 631 627 GETGLOBAL "true" 629 RETURN 1 631 GETGLOBAL "false" 633 RETURN 1 635 CONST0 636 PUSHACC1 637 LTINT 638 BRANCHIF 646 640 CONSTINT 255 642 PUSHACC1 643 GTINT 644 BRANCHIFNOT 651 646 GETGLOBAL "char_of_int" 648 PUSHENVACC1 649 APPTERM1 2 651 ACC0 652 RETURN 1 654 RESTART 655 GRAB 1 657 ACC0 658 C_CALL1 ml_string_length 660 PUSHACC2 661 C_CALL1 ml_string_length 663 PUSHACC0 664 PUSHACC2 665 ADDINT 666 C_CALL1 create_string 668 PUSHACC2 669 PUSHCONST0 670 PUSHACC2 671 PUSHCONST0 672 PUSHACC7 673 C_CALL5 blit_string 675 ACC1 676 PUSHACC3 677 PUSHACC2 678 PUSHCONST0 679 PUSHACC 8 681 C_CALL5 blit_string 683 ACC0 684 RETURN 5 686 CONSTINT -1 688 PUSHACC1 689 XORINT 690 RETURN 1 692 CONST0 693 PUSHACC1 694 GEINT 695 BRANCHIFNOT 700 697 ACC0 698 RETURN 1 700 ACC0 701 NEGINT 702 RETURN 1 704 RESTART 705 GRAB 1 707 ACC1 708 PUSHACC1 709 C_CALL2 greaterequal 711 BRANCHIFNOT 716 713 ACC0 714 RETURN 2 716 ACC1 717 RETURN 2 719 RESTART 720 GRAB 1 722 ACC1 723 PUSHACC1 724 C_CALL2 lessequal 726 BRANCHIFNOT 731 728 ACC0 729 RETURN 2 731 ACC1 732 RETURN 2 734 ACC0 735 PUSHGETGLOBAL Invalid_argument 737 MAKEBLOCK2 0 739 RAISE 740 ACC0 741 PUSHGETGLOBAL Failure 743 MAKEBLOCK2 0 745 RAISE 746 CLOSURE 0, 740 749 PUSH 750 CLOSURE 0, 734 753 PUSHGETGLOBAL "Pervasives.Exit" 755 MAKEBLOCK1 0 757 PUSHGETGLOBAL "Pervasives.Assert_failure" 759 MAKEBLOCK1 0 761 PUSH 762 CLOSURE 0, 720 765 PUSH 766 CLOSURE 0, 705 769 PUSH 770 CLOSURE 0, 692 773 PUSH 774 CLOSURE 0, 686 777 PUSHCONST0 778 PUSHCONSTINT 31 780 PUSHCONST1 781 LSLINT 782 EQ 783 BRANCHIFNOT 789 785 CONSTINT 30 787 BRANCH 791 789 CONSTINT 62 791 PUSHCONST1 792 LSLINT 793 PUSHACC0 794 OFFSETINT -1 796 PUSH 797 CLOSURE 0, 655 800 PUSHACC 9 802 CLOSURE 1, 635 805 PUSH 806 CLOSURE 0, 624 809 PUSHACC 11 811 CLOSURE 1, 599 814 PUSH 815 CLOSURE 0, 592 818 PUSH 819 CLOSURE 0, 585 822 PUSH 823 CLOSUREREC 0, 12 827 CONST0 828 C_CALL1 caml_open_descriptor 830 PUSHCONST1 831 C_CALL1 caml_open_descriptor 833 PUSHCONST2 834 C_CALL1 caml_open_descriptor 836 PUSH 837 CLOSURE 0, 574 840 PUSHACC0 841 CLOSURE 1, 565 844 PUSHACC1 845 CLOSURE 1, 557 848 PUSH 849 CLOSURE 0, 545 852 PUSHACC 22 854 CLOSURE 1, 515 857 PUSH 858 CLOSURE 0, 505 861 PUSH 862 CLOSURE 0, 496 865 PUSH 866 CLOSURE 0, 485 869 PUSHACC0 870 CLOSURE 1, 477 873 PUSHACC1 874 CLOSURE 1, 470 877 PUSHACC 28 879 CLOSURE 1, 441 882 PUSH 883 CLOSUREREC 0, 32 887 ACC0 888 PUSHACC 31 890 CLOSURE 2, 411 893 PUSHACC 22 895 CLOSUREREC 1, 70 899 ACC 15 901 CLOSURE 1, 404 904 PUSHACC 11 906 PUSHACC 17 908 CLOSURE 2, 399 911 PUSHACC 12 913 PUSHACC 18 915 PUSHACC 23 917 CLOSURE 3, 392 920 PUSHACC 13 922 PUSHACC 19 924 PUSHACC 23 926 CLOSURE 3, 385 929 PUSHACC 14 931 PUSHACC 20 933 CLOSURE 2, 374 936 PUSHACC 20 938 CLOSURE 1, 364 941 PUSHACC 20 943 CLOSURE 1, 358 946 PUSHACC 17 948 PUSHACC 22 950 CLOSURE 2, 353 953 PUSHACC 18 955 PUSHACC 23 957 PUSHACC 29 959 CLOSURE 3, 346 962 PUSHACC 19 964 PUSHACC 24 966 PUSHACC 29 968 CLOSURE 3, 339 971 PUSHACC 20 973 PUSHACC 25 975 CLOSURE 2, 325 978 PUSHACC 25 980 CLOSURE 1, 315 983 PUSHACC 12 985 PUSHACC 28 987 PUSHACC 30 989 CLOSURE 3, 308 992 PUSHACC0 993 CLOSURE 1, 301 996 PUSHACC1 997 CLOSURE 1, 294 1000 PUSHACC 29 1002 PUSHACC 31 1004 CLOSURE 2, 286 1007 MAKEBLOCK1 0 1009 PUSHACC0 1010 CLOSURE 1, 275 1013 PUSHACC1 1014 CLOSURE 1, 263 1017 PUSHACC0 1018 CLOSURE 1, 255 1021 PUSHACC1 1022 PUSHACC 22 1024 PUSHACC4 1025 PUSHACC3 1026 PUSH 1027 CLOSURE 0, 247 1030 PUSH 1031 CLOSURE 0, 241 1034 PUSH 1035 CLOSURE 0, 236 1038 PUSH 1039 CLOSURE 0, 231 1042 PUSH 1043 CLOSURE 0, 223 1046 PUSH 1047 CLOSURE 0, 217 1050 PUSH 1051 CLOSURE 0, 212 1054 PUSH 1055 CLOSURE 0, 207 1058 PUSHACC 32 1060 PUSHACC 35 1062 PUSHACC 33 1064 PUSH 1065 CLOSURE 0, 202 1068 PUSHACC 41 1070 PUSHACC 40 1072 PUSHACC 42 1074 PUSH 1075 CLOSURE 0, 194 1078 PUSHACC 46 1080 PUSH 1081 CLOSURE 0, 188 1084 PUSH 1085 CLOSURE 0, 183 1088 PUSH 1089 CLOSURE 0, 175 1092 PUSHACC 51 1094 PUSH 1095 CLOSURE 0, 166 1098 PUSH 1099 CLOSURE 0, 157 1102 PUSHACC 55 1104 PUSHACC 57 1106 PUSH 1107 CLOSURE 0, 148 1110 PUSH 1111 CLOSURE 0, 142 1114 PUSHACC 63 1116 PUSHACC 62 1118 PUSHACC 64 1120 PUSHACC 38 1122 PUSHACC 40 1124 PUSHACC 42 1126 PUSHACC 44 1128 PUSHACC 46 1130 PUSHACC 48 1132 PUSHACC 50 1134 PUSHACC 52 1136 PUSHACC 54 1138 PUSHACC 56 1140 PUSHACC 58 1142 PUSHACC 60 1144 PUSHACC 62 1146 PUSHACC 64 1148 PUSHACC 66 1150 PUSHACC 82 1152 PUSHACC 84 1154 PUSHACC 86 1156 PUSHACC 88 1158 PUSHACC 90 1160 PUSHACC 92 1162 PUSHACC 94 1164 PUSHACC 96 1166 PUSHACC 98 1168 PUSHACC 100 1170 PUSHACC 104 1172 PUSHACC 104 1174 PUSHACC 104 1176 PUSHACC 108 1178 PUSHACC 110 1180 PUSHACC 112 1182 PUSHACC 117 1184 PUSHACC 117 1186 PUSHACC 117 1188 PUSHACC 117 1190 MAKEBLOCK 69, 0 1193 POP 53 1195 SETGLOBAL Pervasives 1197 BRANCH 2177 1199 RESTART 1200 GRAB 1 1202 ACC1 1203 BRANCHIFNOT 1213 1205 ACC1 1206 GETFIELD1 1207 PUSHACC1 1208 OFFSETINT 1 1210 PUSHOFFSETCLOSURE0 1211 APPTERM2 4 1213 ACC0 1214 RETURN 2 1216 RESTART 1217 GRAB 1 1219 ACC0 1220 BRANCHIFNOT 1251 1222 CONST0 1223 PUSHACC2 1224 EQ 1225 BRANCHIFNOT 1231 1227 ACC0 1228 GETFIELD0 1229 RETURN 2 1231 CONST0 1232 PUSHACC2 1233 GTINT 1234 BRANCHIFNOT 1244 1236 ACC1 1237 OFFSETINT -1 1239 PUSHACC1 1240 GETFIELD1 1241 PUSHOFFSETCLOSURE0 1242 APPTERM2 4 1244 GETGLOBAL "List.nth" 1246 PUSHGETGLOBALFIELD Pervasives, 2 1249 APPTERM1 3 1251 GETGLOBAL "nth" 1253 PUSHGETGLOBALFIELD Pervasives, 3 1256 APPTERM1 3 1258 RESTART 1259 GRAB 1 1261 ACC0 1262 BRANCHIFNOT 1274 1264 ACC1 1265 PUSHACC1 1266 GETFIELD0 1267 MAKEBLOCK2 0 1269 PUSHACC1 1270 GETFIELD1 1271 PUSHOFFSETCLOSURE0 1272 APPTERM2 4 1274 ACC1 1275 RETURN 2 1277 ACC0 1278 BRANCHIFNOT 1291 1280 ACC0 1281 GETFIELD1 1282 PUSHOFFSETCLOSURE0 1283 APPLY1 1284 PUSHACC1 1285 GETFIELD0 1286 PUSHGETGLOBALFIELD Pervasives, 16 1289 APPTERM2 3 1291 RETURN 1 1293 RESTART 1294 GRAB 1 1296 ACC1 1297 BRANCHIFNOT 1313 1299 ACC1 1300 GETFIELD0 1301 PUSHACC1 1302 APPLY1 1303 PUSHACC2 1304 GETFIELD1 1305 PUSHACC2 1306 PUSHOFFSETCLOSURE0 1307 APPLY2 1308 PUSHACC1 1309 MAKEBLOCK2 0 1311 POP 1 1313 RETURN 2 1315 RESTART 1316 GRAB 1 1318 ACC1 1319 BRANCHIFNOT 1331 1321 ACC1 1322 GETFIELD0 1323 PUSHACC1 1324 APPLY1 1325 ACC1 1326 GETFIELD1 1327 PUSHACC1 1328 PUSHOFFSETCLOSURE0 1329 APPTERM2 4 1331 RETURN 2 1333 RESTART 1334 GRAB 2 1336 ACC2 1337 BRANCHIFNOT 1350 1339 ACC2 1340 GETFIELD1 1341 PUSHACC3 1342 GETFIELD0 1343 PUSHACC3 1344 PUSHACC3 1345 APPLY2 1346 PUSHACC2 1347 PUSHOFFSETCLOSURE0 1348 APPTERM3 6 1350 ACC1 1351 RETURN 3 1353 RESTART 1354 GRAB 2 1356 ACC1 1357 BRANCHIFNOT 1370 1359 ACC2 1360 PUSHACC2 1361 GETFIELD1 1362 PUSHACC2 1363 PUSHOFFSETCLOSURE0 1364 APPLY3 1365 PUSHACC2 1366 GETFIELD0 1367 PUSHACC2 1368 APPTERM2 5 1370 ACC2 1371 RETURN 3 1373 RESTART 1374 GRAB 2 1376 ACC1 1377 BRANCHIFNOT 1400 1379 ACC2 1380 BRANCHIFNOT 1407 1382 ACC2 1383 GETFIELD0 1384 PUSHACC2 1385 GETFIELD0 1386 PUSHACC2 1387 APPLY2 1388 PUSHACC3 1389 GETFIELD1 1390 PUSHACC3 1391 GETFIELD1 1392 PUSHACC3 1393 PUSHOFFSETCLOSURE0 1394 APPLY3 1395 PUSHACC1 1396 MAKEBLOCK2 0 1398 RETURN 4 1400 ACC2 1401 BRANCHIFNOT 1405 1403 BRANCH 1407 1405 RETURN 3 1407 GETGLOBAL "List.map2" 1409 PUSHGETGLOBALFIELD Pervasives, 2 1412 APPTERM1 4 1414 RESTART 1415 GRAB 2 1417 ACC1 1418 BRANCHIFNOT 1437 1420 ACC2 1421 BRANCHIFNOT 1444 1423 ACC2 1424 GETFIELD0 1425 PUSHACC2 1426 GETFIELD0 1427 PUSHACC2 1428 APPLY2 1429 ACC2 1430 GETFIELD1 1431 PUSHACC2 1432 GETFIELD1 1433 PUSHACC2 1434 PUSHOFFSETCLOSURE0 1435 APPTERM3 6 1437 ACC2 1438 BRANCHIFNOT 1442 1440 BRANCH 1444 1442 RETURN 3 1444 GETGLOBAL "List.iter2" 1446 PUSHGETGLOBALFIELD Pervasives, 2 1449 APPTERM1 4 1451 RESTART 1452 GRAB 3 1454 ACC2 1455 BRANCHIFNOT 1476 1457 ACC3 1458 BRANCHIFNOT 1482 1460 ACC3 1461 GETFIELD1 1462 PUSHACC3 1463 GETFIELD1 1464 PUSHACC5 1465 GETFIELD0 1466 PUSHACC5 1467 GETFIELD0 1468 PUSHACC5 1469 PUSHACC5 1470 APPLY3 1471 PUSHACC3 1472 PUSHOFFSETCLOSURE0 1473 APPTERM 4, 8 1476 ACC3 1477 BRANCHIF 1482 1479 ACC1 1480 RETURN 4 1482 GETGLOBAL "List.fold_left2" 1484 PUSHGETGLOBALFIELD Pervasives, 2 1487 APPTERM1 5 1489 RESTART 1490 GRAB 3 1492 ACC1 1493 BRANCHIFNOT 1516 1495 ACC2 1496 BRANCHIFNOT 1522 1498 PUSH_RETADDR 1509 1500 ACC6 1501 PUSHACC6 1502 GETFIELD1 1503 PUSHACC6 1504 GETFIELD1 1505 PUSHACC6 1506 PUSHOFFSETCLOSURE0 1507 APPLY 4 1509 PUSHACC3 1510 GETFIELD0 1511 PUSHACC3 1512 GETFIELD0 1513 PUSHACC3 1514 APPTERM3 7 1516 ACC2 1517 BRANCHIF 1522 1519 ACC3 1520 RETURN 4 1522 GETGLOBAL "List.fold_right2" 1524 PUSHGETGLOBALFIELD Pervasives, 2 1527 APPTERM1 5 1529 RESTART 1530 GRAB 1 1532 ACC1 1533 BRANCHIFNOT 1549 1535 ACC1 1536 GETFIELD0 1537 PUSHACC1 1538 APPLY1 1539 BRANCHIFNOT 1547 1541 ACC1 1542 GETFIELD1 1543 PUSHACC1 1544 PUSHOFFSETCLOSURE0 1545 APPTERM2 4 1547 RETURN 2 1549 CONST1 1550 RETURN 2 1552 RESTART 1553 GRAB 1 1555 ACC1 1556 BRANCHIFNOT 1570 1558 ACC1 1559 GETFIELD0 1560 PUSHACC1 1561 APPLY1 1562 BRANCHIF 1570 1564 ACC1 1565 GETFIELD1 1566 PUSHACC1 1567 PUSHOFFSETCLOSURE0 1568 APPTERM2 4 1570 RETURN 2 1572 RESTART 1573 GRAB 2 1575 ACC1 1576 BRANCHIFNOT 1599 1578 ACC2 1579 BRANCHIFNOT 1605 1581 ACC2 1582 GETFIELD0 1583 PUSHACC2 1584 GETFIELD0 1585 PUSHACC2 1586 APPLY2 1587 BRANCHIFNOT 1597 1589 ACC2 1590 GETFIELD1 1591 PUSHACC2 1592 GETFIELD1 1593 PUSHACC2 1594 PUSHOFFSETCLOSURE0 1595 APPTERM3 6 1597 RETURN 3 1599 ACC2 1600 BRANCHIF 1605 1602 CONST1 1603 RETURN 3 1605 GETGLOBAL "List.for_all2" 1607 PUSHGETGLOBALFIELD Pervasives, 2 1610 APPTERM1 4 1612 RESTART 1613 GRAB 2 1615 ACC1 1616 BRANCHIFNOT 1639 1618 ACC2 1619 BRANCHIFNOT 1646 1621 ACC2 1622 GETFIELD0 1623 PUSHACC2 1624 GETFIELD0 1625 PUSHACC2 1626 APPLY2 1627 BRANCHIF 1637 1629 ACC2 1630 GETFIELD1 1631 PUSHACC2 1632 GETFIELD1 1633 PUSHACC2 1634 PUSHOFFSETCLOSURE0 1635 APPTERM3 6 1637 RETURN 3 1639 ACC2 1640 BRANCHIFNOT 1644 1642 BRANCH 1646 1644 RETURN 3 1646 GETGLOBAL "List.exists2" 1648 PUSHGETGLOBALFIELD Pervasives, 2 1651 APPTERM1 4 1653 RESTART 1654 GRAB 1 1656 ACC1 1657 BRANCHIFNOT 1672 1659 ACC0 1660 PUSHACC2 1661 GETFIELD0 1662 C_CALL2 equal 1664 BRANCHIF 1672 1666 ACC1 1667 GETFIELD1 1668 PUSHACC1 1669 PUSHOFFSETCLOSURE0 1670 APPTERM2 4 1672 RETURN 2 1674 RESTART 1675 GRAB 1 1677 ACC1 1678 BRANCHIFNOT 1692 1680 ACC0 1681 PUSHACC2 1682 GETFIELD0 1683 EQ 1684 BRANCHIF 1692 1686 ACC1 1687 GETFIELD1 1688 PUSHACC1 1689 PUSHOFFSETCLOSURE0 1690 APPTERM2 4 1692 RETURN 2 1694 RESTART 1695 GRAB 1 1697 ACC1 1698 BRANCHIFNOT 1719 1700 ACC1 1701 GETFIELD0 1702 PUSHACC1 1703 PUSHACC1 1704 GETFIELD0 1705 C_CALL2 equal 1707 BRANCHIFNOT 1713 1709 ACC0 1710 GETFIELD1 1711 RETURN 3 1713 ACC2 1714 GETFIELD1 1715 PUSHACC2 1716 PUSHOFFSETCLOSURE0 1717 APPTERM2 5 1719 GETGLOBAL Not_found 1721 MAKEBLOCK1 0 1723 RAISE 1724 RESTART 1725 GRAB 1 1727 ACC1 1728 BRANCHIFNOT 1748 1730 ACC1 1731 GETFIELD0 1732 PUSHACC1 1733 PUSHACC1 1734 GETFIELD0 1735 EQ 1736 BRANCHIFNOT 1742 1738 ACC0 1739 GETFIELD1 1740 RETURN 3 1742 ACC2 1743 GETFIELD1 1744 PUSHACC2 1745 PUSHOFFSETCLOSURE0 1746 APPTERM2 5 1748 GETGLOBAL Not_found 1750 MAKEBLOCK1 0 1752 RAISE 1753 RESTART 1754 GRAB 1 1756 ACC1 1757 BRANCHIFNOT 1773 1759 ACC0 1760 PUSHACC2 1761 GETFIELD0 1762 GETFIELD0 1763 C_CALL2 equal 1765 BRANCHIF 1773 1767 ACC1 1768 GETFIELD1 1769 PUSHACC1 1770 PUSHOFFSETCLOSURE0 1771 APPTERM2 4 1773 RETURN 2 1775 RESTART 1776 GRAB 1 1778 ACC1 1779 BRANCHIFNOT 1794 1781 ACC0 1782 PUSHACC2 1783 GETFIELD0 1784 GETFIELD0 1785 EQ 1786 BRANCHIF 1794 1788 ACC1 1789 GETFIELD1 1790 PUSHACC1 1791 PUSHOFFSETCLOSURE0 1792 APPTERM2 4 1794 RETURN 2 1796 RESTART 1797 GRAB 1 1799 ACC1 1800 BRANCHIFNOT 1825 1802 ACC1 1803 GETFIELD0 1804 PUSHACC2 1805 GETFIELD1 1806 PUSHACC2 1807 PUSHACC2 1808 GETFIELD0 1809 C_CALL2 equal 1811 BRANCHIFNOT 1816 1813 ACC0 1814 RETURN 4 1816 ACC0 1817 PUSHACC3 1818 PUSHOFFSETCLOSURE0 1819 APPLY2 1820 PUSHACC2 1821 MAKEBLOCK2 0 1823 POP 2 1825 RETURN 2 1827 RESTART 1828 GRAB 1 1830 ACC1 1831 BRANCHIFNOT 1855 1833 ACC1 1834 GETFIELD0 1835 PUSHACC2 1836 GETFIELD1 1837 PUSHACC2 1838 PUSHACC2 1839 GETFIELD0 1840 EQ 1841 BRANCHIFNOT 1846 1843 ACC0 1844 RETURN 4 1846 ACC0 1847 PUSHACC3 1848 PUSHOFFSETCLOSURE0 1849 APPLY2 1850 PUSHACC2 1851 MAKEBLOCK2 0 1853 POP 2 1855 RETURN 2 1857 RESTART 1858 GRAB 1 1860 ACC1 1861 BRANCHIFNOT 1879 1863 ACC1 1864 GETFIELD0 1865 PUSHACC0 1866 PUSHACC2 1867 APPLY1 1868 BRANCHIFNOT 1873 1870 ACC0 1871 RETURN 3 1873 ACC2 1874 GETFIELD1 1875 PUSHACC2 1876 PUSHOFFSETCLOSURE0 1877 APPTERM2 5 1879 GETGLOBAL Not_found 1881 MAKEBLOCK1 0 1883 RAISE 1884 RESTART 1885 GRAB 2 1887 ACC2 1888 BRANCHIFNOT 1917 1890 ACC2 1891 GETFIELD0 1892 PUSHACC3 1893 GETFIELD1 1894 PUSHACC1 1895 PUSHENVACC2 1896 APPLY1 1897 BRANCHIFNOT 1908 1899 ACC0 1900 PUSHACC4 1901 PUSHACC4 1902 PUSHACC4 1903 MAKEBLOCK2 0 1905 PUSHOFFSETCLOSURE0 1906 APPTERM3 8 1908 ACC0 1909 PUSHACC4 1910 PUSHACC3 1911 MAKEBLOCK2 0 1913 PUSHACC4 1914 PUSHOFFSETCLOSURE0 1915 APPTERM3 8 1917 ACC1 1918 PUSHENVACC1 1919 APPLY1 1920 PUSHACC1 1921 PUSHENVACC1 1922 APPLY1 1923 MAKEBLOCK2 0 1925 RETURN 3 1927 RESTART 1928 GRAB 1 1930 ACC0 1931 PUSHENVACC1 1932 CLOSUREREC 2, 1885 1936 ACC2 1937 PUSHCONST0 1938 PUSHCONST0 1939 PUSHACC3 1940 APPTERM3 6 1942 ACC0 1943 BRANCHIFNOT 1967 1945 ACC0 1946 GETFIELD0 1947 PUSHACC1 1948 GETFIELD1 1949 PUSHOFFSETCLOSURE0 1950 APPLY1 1951 PUSHACC0 1952 GETFIELD1 1953 PUSHACC2 1954 GETFIELD1 1955 MAKEBLOCK2 0 1957 PUSHACC1 1958 GETFIELD0 1959 PUSHACC3 1960 GETFIELD0 1961 MAKEBLOCK2 0 1963 MAKEBLOCK2 0 1965 RETURN 3 1967 GETGLOBAL <0>(0, 0) 1969 RETURN 1 1971 RESTART 1972 GRAB 1 1974 ACC0 1975 BRANCHIFNOT 1996 1977 ACC1 1978 BRANCHIFNOT 2003 1980 ACC1 1981 GETFIELD1 1982 PUSHACC1 1983 GETFIELD1 1984 PUSHOFFSETCLOSURE0 1985 APPLY2 1986 PUSHACC2 1987 GETFIELD0 1988 PUSHACC2 1989 GETFIELD0 1990 MAKEBLOCK2 0 1992 MAKEBLOCK2 0 1994 RETURN 2 1996 ACC1 1997 BRANCHIFNOT 2001 1999 BRANCH 2003 2001 RETURN 2 2003 GETGLOBAL "List.combine" 2005 PUSHGETGLOBALFIELD Pervasives, 2 2008 APPTERM1 3 2010 RESTART 2011 GRAB 1 2013 ACC1 2014 BRANCHIFNOT 2038 2016 ACC1 2017 GETFIELD0 2018 PUSHACC2 2019 GETFIELD1 2020 PUSHACC1 2021 PUSHENVACC2 2022 APPLY1 2023 BRANCHIFNOT 2033 2025 ACC0 2026 PUSHACC3 2027 PUSHACC3 2028 MAKEBLOCK2 0 2030 PUSHOFFSETCLOSURE0 2031 APPTERM2 6 2033 ACC0 2034 PUSHACC3 2035 PUSHOFFSETCLOSURE0 2036 APPTERM2 6 2038 ACC0 2039 PUSHENVACC1 2040 APPTERM1 3 2042 ACC0 2043 PUSHENVACC1 2044 CLOSUREREC 2, 2011 2048 CONST0 2049 PUSHACC1 2050 APPTERM1 3 2052 RESTART 2053 GRAB 2 2055 ACC1 2056 BRANCHIFNOT 2077 2058 ACC2 2059 BRANCHIFNOT 2084 2061 ACC2 2062 GETFIELD1 2063 PUSHACC2 2064 GETFIELD1 2065 PUSHACC2 2066 PUSHACC5 2067 GETFIELD0 2068 PUSHACC5 2069 GETFIELD0 2070 PUSHENVACC1 2071 APPLY2 2072 MAKEBLOCK2 0 2074 PUSHOFFSETCLOSURE0 2075 APPTERM3 6 2077 ACC2 2078 BRANCHIFNOT 2082 2080 BRANCH 2084 2082 RETURN 3 2084 GETGLOBAL "List.rev_map2" 2086 PUSHGETGLOBALFIELD Pervasives, 2 2089 APPTERM1 4 2091 RESTART 2092 GRAB 2 2094 ACC0 2095 CLOSUREREC 1, 2053 2099 ACC3 2100 PUSHACC3 2101 PUSHCONST0 2102 PUSHACC3 2103 APPTERM3 7 2105 RESTART 2106 GRAB 1 2108 ACC1 2109 BRANCHIFNOT 2123 2111 ACC1 2112 GETFIELD1 2113 PUSHACC1 2114 PUSHACC3 2115 GETFIELD0 2116 PUSHENVACC1 2117 APPLY1 2118 MAKEBLOCK2 0 2120 PUSHOFFSETCLOSURE0 2121 APPTERM2 4 2123 ACC0 2124 RETURN 2 2126 RESTART 2127 GRAB 1 2129 ACC0 2130 CLOSUREREC 1, 2106 2134 ACC2 2135 PUSHCONST0 2136 PUSHACC2 2137 APPTERM2 5 2139 CONST0 2140 PUSHACC1 2141 PUSHENVACC1 2142 APPTERM2 3 2144 ACC0 2145 BRANCHIFNOT 2151 2147 ACC0 2148 GETFIELD1 2149 RETURN 1 2151 GETGLOBAL "tl" 2153 PUSHGETGLOBALFIELD Pervasives, 3 2156 APPTERM1 2 2158 ACC0 2159 BRANCHIFNOT 2165 2161 ACC0 2162 GETFIELD0 2163 RETURN 1 2165 GETGLOBAL "hd" 2167 PUSHGETGLOBALFIELD Pervasives, 3 2170 APPTERM1 2 2172 ACC0 2173 PUSHCONST0 2174 PUSHENVACC1 2175 APPTERM2 3 2177 CLOSUREREC 0, 1200 2181 ACC0 2182 CLOSURE 1, 2172 2185 PUSH 2186 CLOSURE 0, 2158 2189 PUSH 2190 CLOSURE 0, 2144 2193 PUSH 2194 CLOSUREREC 0, 1217 2198 GETGLOBALFIELD Pervasives, 16 2201 PUSH 2202 CLOSUREREC 0, 1259 2206 ACC0 2207 CLOSURE 1, 2139 2210 PUSH 2211 CLOSUREREC 0, 1277 2215 CLOSUREREC 0, 1294 2219 CLOSURE 0, 2127 2222 PUSH 2223 CLOSUREREC 0, 1316 2227 CLOSUREREC 0, 1334 2231 CLOSUREREC 0, 1354 2235 CLOSUREREC 0, 1374 2239 CLOSURE 0, 2092 2242 PUSH 2243 CLOSUREREC 0, 1415 2247 CLOSUREREC 0, 1452 2251 CLOSUREREC 0, 1490 2255 CLOSUREREC 0, 1530 2259 CLOSUREREC 0, 1553 2263 CLOSUREREC 0, 1573 2267 CLOSUREREC 0, 1613 2271 CLOSUREREC 0, 1654 2275 CLOSUREREC 0, 1675 2279 CLOSUREREC 0, 1695 2283 CLOSUREREC 0, 1725 2287 CLOSUREREC 0, 1754 2291 CLOSUREREC 0, 1776 2295 CLOSUREREC 0, 1797 2299 CLOSUREREC 0, 1828 2303 CLOSUREREC 0, 1858 2307 ACC 24 2309 CLOSURE 1, 2042 2312 PUSHACC 25 2314 CLOSUREREC 1, 1928 2318 CLOSUREREC 0, 1942 2322 CLOSUREREC 0, 1972 2326 ACC0 2327 PUSHACC2 2328 PUSHACC7 2329 PUSHACC 9 2331 PUSHACC 11 2333 PUSHACC 13 2335 PUSHACC 15 2337 PUSHACC 17 2339 PUSHACC 10 2341 PUSHACC 12 2343 PUSHACC 13 2345 PUSHACC 15 2347 PUSHACC 23 2349 PUSHACC 25 2351 PUSHACC 27 2353 PUSHACC 29 2355 PUSHACC 31 2357 PUSHACC 33 2359 PUSHACC 35 2361 PUSHACC 37 2363 PUSHACC 40 2365 PUSHACC 42 2367 PUSHACC 41 2369 PUSHACC 45 2371 PUSHACC 47 2373 PUSHACC 50 2375 PUSHACC 52 2377 PUSHACC 51 2379 PUSHACC 55 2381 PUSHACC 56 2383 PUSHACC 59 2385 PUSHACC 61 2387 PUSHACC 60 2389 PUSHACC 64 2391 PUSHACC 66 2393 PUSHACC 68 2395 PUSHACC 70 2397 MAKEBLOCK 37, 0 2400 POP 36 2402 SETGLOBAL List 2404 BRANCH 2432 2406 CONST0 2407 PUSHACC1 2408 LEINT 2409 BRANCHIFNOT 2414 2411 CONST0 2412 RETURN 1 2414 ACC0 2415 OFFSETINT -1 2417 PUSHOFFSETCLOSURE0 2418 APPLY1 2419 PUSHACC1 2420 MAKEBLOCK2 0 2422 RETURN 1 2424 RESTART 2425 GRAB 1 2427 ACC1 2428 PUSHACC1 2429 ADDINT 2430 RETURN 2 2432 CLOSUREREC 0, 2406 2436 CONSTINT 300 2438 PUSHACC1 2439 APPLY1 2440 PUSHCONST0 2441 C_CALL1 gc_full_major 2443 CONSTINT 150 2445 PUSHCONSTINT 301 2447 MULINT 2448 PUSHACC1 2449 PUSHCONST0 2450 PUSH 2451 CLOSURE 0, 2425 2454 PUSHGETGLOBALFIELD List, 12 2457 APPLY3 2458 NEQ 2459 BRANCHIFNOT 2466 2461 GETGLOBAL Not_found 2463 MAKEBLOCK1 0 2465 RAISE 2466 POP 2 2468 ATOM0 2469 SETGLOBAL T320-gc-3 2471 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t162-return.ml0000644000175000017500000000054012124403241023261 0ustar tootstootsopen Lib;; let f _ = 0 in f 0;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 14 11 CONST0 12 RETURN 1 14 CLOSURE 0, 11 17 PUSHCONST0 18 PUSHACC1 19 APPLY1 20 POP 1 22 ATOM0 23 SETGLOBAL T162-return 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t142-switch-A.ml0000644000175000017500000000100712124403241023416 0ustar tootstootsopen Lib;; type t = | A | B of int | C of int ;; match C 0 with | C _ -> () | _ -> raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBAL <1>(0) 11 PUSHACC0 12 SWITCH int 0 -> 20 tag 0 -> 20 tag 1 -> 17 17 CONST0 18 BRANCH 25 20 GETGLOBAL Not_found 22 MAKEBLOCK1 0 24 RAISE 25 POP 1 27 ATOM0 28 SETGLOBAL T142-switch-A 30 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t093-pushacc.ml0000644000175000017500000000123312124403241023373 0ustar tootstootsopen Lib;; let x = false in let y = true in let z = true in let a = true in let b = true in let c = true in let d = true in let e = true in let f = true in if x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST1 11 PUSHCONST1 12 PUSHCONST1 13 PUSHCONST1 14 PUSHCONST1 15 PUSHCONST1 16 PUSHCONST1 17 PUSHCONST1 18 PUSHACC 8 20 BRANCHIFNOT 27 22 GETGLOBAL Not_found 24 MAKEBLOCK1 0 26 RAISE 27 POP 9 29 ATOM0 30 SETGLOBAL T093-pushacc 32 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t110-andint.ml0000644000175000017500000000063012124403241023210 0ustar tootstootsopen Lib;; if (3 land 6) <> 2 then raise Not_found;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST2 10 PUSHCONSTINT 6 12 PUSHCONST3 13 ANDINT 14 NEQ 15 BRANCHIFNOT 22 17 GETGLOBAL Not_found 19 MAKEBLOCK1 0 21 RAISE 22 ATOM0 23 SETGLOBAL T110-andint 25 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t330-compact-3.ml0000644000175000017500000007757412124403241023552 0ustar tootstootsopen Lib;; let rec f n = if n <= 0 then [] else n :: f (n-1) in let l = f 300 in Gc.compact (); if List.fold_left (+) 0 l <> 301 * 150 then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 BRANCH 746 11 RESTART 12 GRAB 1 14 ACC0 15 BRANCHIFNOT 28 17 ACC1 18 PUSHACC1 19 GETFIELD1 20 PUSHOFFSETCLOSURE0 21 APPLY2 22 PUSHACC1 23 GETFIELD0 24 MAKEBLOCK2 0 26 RETURN 2 28 ACC1 29 RETURN 2 31 RESTART 32 GRAB 3 34 CONST0 35 PUSHACC4 36 LEINT 37 BRANCHIFNOT 42 39 CONST0 40 RETURN 4 42 ACC3 43 PUSHACC3 44 PUSHACC3 45 PUSHACC3 46 C_CALL4 caml_input 48 PUSHCONST0 49 PUSHACC1 50 EQ 51 BRANCHIFNOT 58 53 GETGLOBAL End_of_file 55 MAKEBLOCK1 0 57 RAISE 58 ACC0 59 PUSHACC5 60 SUBINT 61 PUSHACC1 62 PUSHACC5 63 ADDINT 64 PUSHACC4 65 PUSHACC4 66 PUSHOFFSETCLOSURE0 67 APPTERM 4, 9 70 ACC0 71 C_CALL1 caml_input_scan_line 73 PUSHCONST0 74 PUSHACC1 75 EQ 76 BRANCHIFNOT 83 78 GETGLOBAL End_of_file 80 MAKEBLOCK1 0 82 RAISE 83 CONST0 84 PUSHACC1 85 GTINT 86 BRANCHIFNOT 107 88 ACC0 89 OFFSETINT -1 91 C_CALL1 create_string 93 PUSHACC1 94 OFFSETINT -1 96 PUSHCONST0 97 PUSHACC2 98 PUSHACC5 99 C_CALL4 caml_input 101 ACC2 102 C_CALL1 caml_input_char 104 ACC0 105 RETURN 3 107 ACC0 108 NEGINT 109 C_CALL1 create_string 111 PUSHACC1 112 NEGINT 113 PUSHCONST0 114 PUSHACC2 115 PUSHACC5 116 C_CALL4 caml_input 118 CONST0 119 PUSHTRAP 130 121 ACC6 122 PUSHOFFSETCLOSURE0 123 APPLY1 124 PUSHACC5 125 PUSHENVACC1 126 APPLY2 127 POPTRAP 128 RETURN 3 130 PUSHGETGLOBAL End_of_file 132 PUSHACC1 133 GETFIELD0 134 EQ 135 BRANCHIFNOT 140 137 ACC1 138 RETURN 4 140 ACC0 141 RAISE 142 ACC0 143 C_CALL1 caml_flush 145 RETURN 1 147 RESTART 148 GRAB 1 150 ACC1 151 PUSHACC1 152 C_CALL2 caml_output_char 154 RETURN 2 156 RESTART 157 GRAB 1 159 ACC1 160 PUSHACC1 161 C_CALL2 caml_output_char 163 RETURN 2 165 RESTART 166 GRAB 1 168 ACC1 169 PUSHACC1 170 C_CALL2 caml_output_int 172 RETURN 2 174 RESTART 175 GRAB 1 177 ACC1 178 PUSHACC1 179 C_CALL2 caml_seek_out 181 RETURN 2 183 ACC0 184 C_CALL1 caml_pos_out 186 RETURN 1 188 ACC0 189 C_CALL1 caml_channel_size 191 RETURN 1 193 RESTART 194 GRAB 1 196 ACC1 197 PUSHACC1 198 C_CALL2 caml_set_binary_mode 200 RETURN 2 202 ACC0 203 C_CALL1 caml_input_char 205 RETURN 1 207 ACC0 208 C_CALL1 caml_input_char 210 RETURN 1 212 ACC0 213 C_CALL1 caml_input_int 215 RETURN 1 217 ACC0 218 C_CALL1 input_value 220 RETURN 1 222 RESTART 223 GRAB 1 225 ACC1 226 PUSHACC1 227 C_CALL2 caml_seek_in 229 RETURN 2 231 ACC0 232 C_CALL1 caml_pos_in 234 RETURN 1 236 ACC0 237 C_CALL1 caml_channel_size 239 RETURN 1 241 ACC0 242 C_CALL1 caml_close_channel 244 RETURN 1 246 RESTART 247 GRAB 1 249 ACC1 250 PUSHACC1 251 C_CALL2 caml_set_binary_mode 253 RETURN 2 255 CONST0 256 PUSHENVACC1 257 APPLY1 258 ACC0 259 C_CALL1 sys_exit 261 RETURN 1 263 CONST0 264 PUSHENVACC1 265 GETFIELD0 266 APPTERM1 2 268 CONST0 269 PUSHENVACC1 270 APPLY1 271 CONST0 272 PUSHENVACC2 273 APPTERM1 2 275 ENVACC1 276 GETFIELD0 277 PUSHACC0 278 PUSHACC2 279 CLOSURE 2, 268 282 PUSHENVACC1 283 SETFIELD0 284 RETURN 2 286 ENVACC1 287 C_CALL1 caml_flush 289 ENVACC2 290 C_CALL1 caml_flush 292 RETURN 1 294 CONST0 295 PUSHENVACC1 296 APPLY1 297 C_CALL1 float_of_string 299 RETURN 1 301 CONST0 302 PUSHENVACC1 303 APPLY1 304 C_CALL1 int_of_string 306 RETURN 1 308 ENVACC2 309 C_CALL1 caml_flush 311 ENVACC1 312 PUSHENVACC3 313 APPTERM1 2 315 CONSTINT 13 317 PUSHENVACC1 318 C_CALL2 caml_output_char 320 ENVACC1 321 C_CALL1 caml_flush 323 RETURN 1 325 ACC0 326 PUSHENVACC1 327 PUSHENVACC2 328 APPLY2 329 CONSTINT 13 331 PUSHENVACC1 332 C_CALL2 caml_output_char 334 ENVACC1 335 C_CALL1 caml_flush 337 RETURN 1 339 ACC0 340 PUSHENVACC1 341 APPLY1 342 PUSHENVACC2 343 PUSHENVACC3 344 APPTERM2 3 346 ACC0 347 PUSHENVACC1 348 APPLY1 349 PUSHENVACC2 350 PUSHENVACC3 351 APPTERM2 3 353 ACC0 354 PUSHENVACC1 355 PUSHENVACC2 356 APPTERM2 3 358 ACC0 359 PUSHENVACC1 360 C_CALL2 caml_output_char 362 RETURN 1 364 CONSTINT 13 366 PUSHENVACC1 367 C_CALL2 caml_output_char 369 ENVACC1 370 C_CALL1 caml_flush 372 RETURN 1 374 ACC0 375 PUSHENVACC1 376 PUSHENVACC2 377 APPLY2 378 CONSTINT 13 380 PUSHENVACC1 381 C_CALL2 caml_output_char 383 RETURN 1 385 ACC0 386 PUSHENVACC1 387 APPLY1 388 PUSHENVACC2 389 PUSHENVACC3 390 APPTERM2 3 392 ACC0 393 PUSHENVACC1 394 APPLY1 395 PUSHENVACC2 396 PUSHENVACC3 397 APPTERM2 3 399 ACC0 400 PUSHENVACC1 401 PUSHENVACC2 402 APPTERM2 3 404 ACC0 405 PUSHENVACC1 406 C_CALL2 caml_output_char 408 RETURN 1 410 RESTART 411 GRAB 3 413 CONST0 414 PUSHACC3 415 LTINT 416 BRANCHIF 427 418 ACC1 419 C_CALL1 ml_string_length 421 PUSHACC4 422 PUSHACC4 423 ADDINT 424 GTINT 425 BRANCHIFNOT 432 427 GETGLOBAL "really_input" 429 PUSHENVACC1 430 APPTERM1 5 432 ACC3 433 PUSHACC3 434 PUSHACC3 435 PUSHACC3 436 PUSHENVACC2 437 APPTERM 4, 8 440 RESTART 441 GRAB 3 443 CONST0 444 PUSHACC3 445 LTINT 446 BRANCHIF 457 448 ACC1 449 C_CALL1 ml_string_length 451 PUSHACC4 452 PUSHACC4 453 ADDINT 454 GTINT 455 BRANCHIFNOT 462 457 GETGLOBAL "input" 459 PUSHENVACC1 460 APPTERM1 5 462 ACC3 463 PUSHACC3 464 PUSHACC3 465 PUSHACC3 466 C_CALL4 caml_input 468 RETURN 4 470 ACC0 471 PUSHCONST0 472 PUSHGETGLOBAL <0>(0, <0>(6, 0)) 474 PUSHENVACC1 475 APPTERM3 4 477 ACC0 478 PUSHCONST0 479 PUSHGETGLOBAL <0>(0, <0>(7, 0)) 481 PUSHENVACC1 482 APPTERM3 4 484 RESTART 485 GRAB 2 487 ACC1 488 PUSHACC1 489 PUSHACC4 490 C_CALL3 sys_open 492 C_CALL1 caml_open_descriptor 494 RETURN 3 496 ACC0 497 C_CALL1 caml_flush 499 ACC0 500 C_CALL1 caml_close_channel 502 RETURN 1 504 RESTART 505 GRAB 1 507 CONST0 508 PUSHACC2 509 PUSHACC2 510 C_CALL3 output_value 512 RETURN 2 514 RESTART 515 GRAB 3 517 CONST0 518 PUSHACC3 519 LTINT 520 BRANCHIF 531 522 ACC1 523 C_CALL1 ml_string_length 525 PUSHACC4 526 PUSHACC4 527 ADDINT 528 GTINT 529 BRANCHIFNOT 536 531 GETGLOBAL "output" 533 PUSHENVACC1 534 APPTERM1 5 536 ACC3 537 PUSHACC3 538 PUSHACC3 539 PUSHACC3 540 C_CALL4 caml_output 542 RETURN 4 544 RESTART 545 GRAB 1 547 ACC1 548 C_CALL1 ml_string_length 550 PUSHCONST0 551 PUSHACC3 552 PUSHACC3 553 C_CALL4 caml_output 555 RETURN 2 557 ACC0 558 PUSHCONSTINT 438 560 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(6, 0)))) 562 PUSHENVACC1 563 APPTERM3 4 565 ACC0 566 PUSHCONSTINT 438 568 PUSHGETGLOBAL <0>(1, <0>(3, <0>(4, <0>(7, 0)))) 570 PUSHENVACC1 571 APPTERM3 4 573 RESTART 574 GRAB 2 576 ACC1 577 PUSHACC1 578 PUSHACC4 579 C_CALL3 sys_open 581 C_CALL1 caml_open_descriptor 583 RETURN 3 585 ACC0 586 PUSHGETGLOBAL "%.12g" 588 C_CALL2 format_float 590 RETURN 1 592 ACC0 593 PUSHGETGLOBAL "%d" 595 C_CALL2 format_int 597 RETURN 1 599 GETGLOBAL "false" 601 PUSHACC1 602 C_CALL2 string_equal 604 BRANCHIFNOT 609 606 CONST0 607 RETURN 1 609 GETGLOBAL "true" 611 PUSHACC1 612 C_CALL2 string_equal 614 BRANCHIFNOT 619 616 CONST1 617 RETURN 1 619 GETGLOBAL "bool_of_string" 621 PUSHENVACC1 622 APPTERM1 2 624 ACC0 625 BRANCHIFNOT 631 627 GETGLOBAL "true" 629 RETURN 1 631 GETGLOBAL "false" 633 RETURN 1 635 CONST0 636 PUSHACC1 637 LTINT 638 BRANCHIF 646 640 CONSTINT 255 642 PUSHACC1 643 GTINT 644 BRANCHIFNOT 651 646 GETGLOBAL "char_of_int" 648 PUSHENVACC1 649 APPTERM1 2 651 ACC0 652 RETURN 1 654 RESTART 655 GRAB 1 657 ACC0 658 C_CALL1 ml_string_length 660 PUSHACC2 661 C_CALL1 ml_string_length 663 PUSHACC0 664 PUSHACC2 665 ADDINT 666 C_CALL1 create_string 668 PUSHACC2 669 PUSHCONST0 670 PUSHACC2 671 PUSHCONST0 672 PUSHACC7 673 C_CALL5 blit_string 675 ACC1 676 PUSHACC3 677 PUSHACC2 678 PUSHCONST0 679 PUSHACC 8 681 C_CALL5 blit_string 683 ACC0 684 RETURN 5 686 CONSTINT -1 688 PUSHACC1 689 XORINT 690 RETURN 1 692 CONST0 693 PUSHACC1 694 GEINT 695 BRANCHIFNOT 700 697 ACC0 698 RETURN 1 700 ACC0 701 NEGINT 702 RETURN 1 704 RESTART 705 GRAB 1 707 ACC1 708 PUSHACC1 709 C_CALL2 greaterequal 711 BRANCHIFNOT 716 713 ACC0 714 RETURN 2 716 ACC1 717 RETURN 2 719 RESTART 720 GRAB 1 722 ACC1 723 PUSHACC1 724 C_CALL2 lessequal 726 BRANCHIFNOT 731 728 ACC0 729 RETURN 2 731 ACC1 732 RETURN 2 734 ACC0 735 PUSHGETGLOBAL Invalid_argument 737 MAKEBLOCK2 0 739 RAISE 740 ACC0 741 PUSHGETGLOBAL Failure 743 MAKEBLOCK2 0 745 RAISE 746 CLOSURE 0, 740 749 PUSH 750 CLOSURE 0, 734 753 PUSHGETGLOBAL "Pervasives.Exit" 755 MAKEBLOCK1 0 757 PUSHGETGLOBAL "Pervasives.Assert_failure" 759 MAKEBLOCK1 0 761 PUSH 762 CLOSURE 0, 720 765 PUSH 766 CLOSURE 0, 705 769 PUSH 770 CLOSURE 0, 692 773 PUSH 774 CLOSURE 0, 686 777 PUSHCONST0 778 PUSHCONSTINT 31 780 PUSHCONST1 781 LSLINT 782 EQ 783 BRANCHIFNOT 789 785 CONSTINT 30 787 BRANCH 791 789 CONSTINT 62 791 PUSHCONST1 792 LSLINT 793 PUSHACC0 794 OFFSETINT -1 796 PUSH 797 CLOSURE 0, 655 800 PUSHACC 9 802 CLOSURE 1, 635 805 PUSH 806 CLOSURE 0, 624 809 PUSHACC 11 811 CLOSURE 1, 599 814 PUSH 815 CLOSURE 0, 592 818 PUSH 819 CLOSURE 0, 585 822 PUSH 823 CLOSUREREC 0, 12 827 CONST0 828 C_CALL1 caml_open_descriptor 830 PUSHCONST1 831 C_CALL1 caml_open_descriptor 833 PUSHCONST2 834 C_CALL1 caml_open_descriptor 836 PUSH 837 CLOSURE 0, 574 840 PUSHACC0 841 CLOSURE 1, 565 844 PUSHACC1 845 CLOSURE 1, 557 848 PUSH 849 CLOSURE 0, 545 852 PUSHACC 22 854 CLOSURE 1, 515 857 PUSH 858 CLOSURE 0, 505 861 PUSH 862 CLOSURE 0, 496 865 PUSH 866 CLOSURE 0, 485 869 PUSHACC0 870 CLOSURE 1, 477 873 PUSHACC1 874 CLOSURE 1, 470 877 PUSHACC 28 879 CLOSURE 1, 441 882 PUSH 883 CLOSUREREC 0, 32 887 ACC0 888 PUSHACC 31 890 CLOSURE 2, 411 893 PUSHACC 22 895 CLOSUREREC 1, 70 899 ACC 15 901 CLOSURE 1, 404 904 PUSHACC 11 906 PUSHACC 17 908 CLOSURE 2, 399 911 PUSHACC 12 913 PUSHACC 18 915 PUSHACC 23 917 CLOSURE 3, 392 920 PUSHACC 13 922 PUSHACC 19 924 PUSHACC 23 926 CLOSURE 3, 385 929 PUSHACC 14 931 PUSHACC 20 933 CLOSURE 2, 374 936 PUSHACC 20 938 CLOSURE 1, 364 941 PUSHACC 20 943 CLOSURE 1, 358 946 PUSHACC 17 948 PUSHACC 22 950 CLOSURE 2, 353 953 PUSHACC 18 955 PUSHACC 23 957 PUSHACC 29 959 CLOSURE 3, 346 962 PUSHACC 19 964 PUSHACC 24 966 PUSHACC 29 968 CLOSURE 3, 339 971 PUSHACC 20 973 PUSHACC 25 975 CLOSURE 2, 325 978 PUSHACC 25 980 CLOSURE 1, 315 983 PUSHACC 12 985 PUSHACC 28 987 PUSHACC 30 989 CLOSURE 3, 308 992 PUSHACC0 993 CLOSURE 1, 301 996 PUSHACC1 997 CLOSURE 1, 294 1000 PUSHACC 29 1002 PUSHACC 31 1004 CLOSURE 2, 286 1007 MAKEBLOCK1 0 1009 PUSHACC0 1010 CLOSURE 1, 275 1013 PUSHACC1 1014 CLOSURE 1, 263 1017 PUSHACC0 1018 CLOSURE 1, 255 1021 PUSHACC1 1022 PUSHACC 22 1024 PUSHACC4 1025 PUSHACC3 1026 PUSH 1027 CLOSURE 0, 247 1030 PUSH 1031 CLOSURE 0, 241 1034 PUSH 1035 CLOSURE 0, 236 1038 PUSH 1039 CLOSURE 0, 231 1042 PUSH 1043 CLOSURE 0, 223 1046 PUSH 1047 CLOSURE 0, 217 1050 PUSH 1051 CLOSURE 0, 212 1054 PUSH 1055 CLOSURE 0, 207 1058 PUSHACC 32 1060 PUSHACC 35 1062 PUSHACC 33 1064 PUSH 1065 CLOSURE 0, 202 1068 PUSHACC 41 1070 PUSHACC 40 1072 PUSHACC 42 1074 PUSH 1075 CLOSURE 0, 194 1078 PUSHACC 46 1080 PUSH 1081 CLOSURE 0, 188 1084 PUSH 1085 CLOSURE 0, 183 1088 PUSH 1089 CLOSURE 0, 175 1092 PUSHACC 51 1094 PUSH 1095 CLOSURE 0, 166 1098 PUSH 1099 CLOSURE 0, 157 1102 PUSHACC 55 1104 PUSHACC 57 1106 PUSH 1107 CLOSURE 0, 148 1110 PUSH 1111 CLOSURE 0, 142 1114 PUSHACC 63 1116 PUSHACC 62 1118 PUSHACC 64 1120 PUSHACC 38 1122 PUSHACC 40 1124 PUSHACC 42 1126 PUSHACC 44 1128 PUSHACC 46 1130 PUSHACC 48 1132 PUSHACC 50 1134 PUSHACC 52 1136 PUSHACC 54 1138 PUSHACC 56 1140 PUSHACC 58 1142 PUSHACC 60 1144 PUSHACC 62 1146 PUSHACC 64 1148 PUSHACC 66 1150 PUSHACC 82 1152 PUSHACC 84 1154 PUSHACC 86 1156 PUSHACC 88 1158 PUSHACC 90 1160 PUSHACC 92 1162 PUSHACC 94 1164 PUSHACC 96 1166 PUSHACC 98 1168 PUSHACC 100 1170 PUSHACC 104 1172 PUSHACC 104 1174 PUSHACC 104 1176 PUSHACC 108 1178 PUSHACC 110 1180 PUSHACC 112 1182 PUSHACC 117 1184 PUSHACC 117 1186 PUSHACC 117 1188 PUSHACC 117 1190 MAKEBLOCK 69, 0 1193 POP 53 1195 SETGLOBAL Pervasives 1197 BRANCH 2177 1199 RESTART 1200 GRAB 1 1202 ACC1 1203 BRANCHIFNOT 1213 1205 ACC1 1206 GETFIELD1 1207 PUSHACC1 1208 OFFSETINT 1 1210 PUSHOFFSETCLOSURE0 1211 APPTERM2 4 1213 ACC0 1214 RETURN 2 1216 RESTART 1217 GRAB 1 1219 ACC0 1220 BRANCHIFNOT 1251 1222 CONST0 1223 PUSHACC2 1224 EQ 1225 BRANCHIFNOT 1231 1227 ACC0 1228 GETFIELD0 1229 RETURN 2 1231 CONST0 1232 PUSHACC2 1233 GTINT 1234 BRANCHIFNOT 1244 1236 ACC1 1237 OFFSETINT -1 1239 PUSHACC1 1240 GETFIELD1 1241 PUSHOFFSETCLOSURE0 1242 APPTERM2 4 1244 GETGLOBAL "List.nth" 1246 PUSHGETGLOBALFIELD Pervasives, 2 1249 APPTERM1 3 1251 GETGLOBAL "nth" 1253 PUSHGETGLOBALFIELD Pervasives, 3 1256 APPTERM1 3 1258 RESTART 1259 GRAB 1 1261 ACC0 1262 BRANCHIFNOT 1274 1264 ACC1 1265 PUSHACC1 1266 GETFIELD0 1267 MAKEBLOCK2 0 1269 PUSHACC1 1270 GETFIELD1 1271 PUSHOFFSETCLOSURE0 1272 APPTERM2 4 1274 ACC1 1275 RETURN 2 1277 ACC0 1278 BRANCHIFNOT 1291 1280 ACC0 1281 GETFIELD1 1282 PUSHOFFSETCLOSURE0 1283 APPLY1 1284 PUSHACC1 1285 GETFIELD0 1286 PUSHGETGLOBALFIELD Pervasives, 16 1289 APPTERM2 3 1291 RETURN 1 1293 RESTART 1294 GRAB 1 1296 ACC1 1297 BRANCHIFNOT 1313 1299 ACC1 1300 GETFIELD0 1301 PUSHACC1 1302 APPLY1 1303 PUSHACC2 1304 GETFIELD1 1305 PUSHACC2 1306 PUSHOFFSETCLOSURE0 1307 APPLY2 1308 PUSHACC1 1309 MAKEBLOCK2 0 1311 POP 1 1313 RETURN 2 1315 RESTART 1316 GRAB 1 1318 ACC1 1319 BRANCHIFNOT 1331 1321 ACC1 1322 GETFIELD0 1323 PUSHACC1 1324 APPLY1 1325 ACC1 1326 GETFIELD1 1327 PUSHACC1 1328 PUSHOFFSETCLOSURE0 1329 APPTERM2 4 1331 RETURN 2 1333 RESTART 1334 GRAB 2 1336 ACC2 1337 BRANCHIFNOT 1350 1339 ACC2 1340 GETFIELD1 1341 PUSHACC3 1342 GETFIELD0 1343 PUSHACC3 1344 PUSHACC3 1345 APPLY2 1346 PUSHACC2 1347 PUSHOFFSETCLOSURE0 1348 APPTERM3 6 1350 ACC1 1351 RETURN 3 1353 RESTART 1354 GRAB 2 1356 ACC1 1357 BRANCHIFNOT 1370 1359 ACC2 1360 PUSHACC2 1361 GETFIELD1 1362 PUSHACC2 1363 PUSHOFFSETCLOSURE0 1364 APPLY3 1365 PUSHACC2 1366 GETFIELD0 1367 PUSHACC2 1368 APPTERM2 5 1370 ACC2 1371 RETURN 3 1373 RESTART 1374 GRAB 2 1376 ACC1 1377 BRANCHIFNOT 1400 1379 ACC2 1380 BRANCHIFNOT 1407 1382 ACC2 1383 GETFIELD0 1384 PUSHACC2 1385 GETFIELD0 1386 PUSHACC2 1387 APPLY2 1388 PUSHACC3 1389 GETFIELD1 1390 PUSHACC3 1391 GETFIELD1 1392 PUSHACC3 1393 PUSHOFFSETCLOSURE0 1394 APPLY3 1395 PUSHACC1 1396 MAKEBLOCK2 0 1398 RETURN 4 1400 ACC2 1401 BRANCHIFNOT 1405 1403 BRANCH 1407 1405 RETURN 3 1407 GETGLOBAL "List.map2" 1409 PUSHGETGLOBALFIELD Pervasives, 2 1412 APPTERM1 4 1414 RESTART 1415 GRAB 2 1417 ACC1 1418 BRANCHIFNOT 1437 1420 ACC2 1421 BRANCHIFNOT 1444 1423 ACC2 1424 GETFIELD0 1425 PUSHACC2 1426 GETFIELD0 1427 PUSHACC2 1428 APPLY2 1429 ACC2 1430 GETFIELD1 1431 PUSHACC2 1432 GETFIELD1 1433 PUSHACC2 1434 PUSHOFFSETCLOSURE0 1435 APPTERM3 6 1437 ACC2 1438 BRANCHIFNOT 1442 1440 BRANCH 1444 1442 RETURN 3 1444 GETGLOBAL "List.iter2" 1446 PUSHGETGLOBALFIELD Pervasives, 2 1449 APPTERM1 4 1451 RESTART 1452 GRAB 3 1454 ACC2 1455 BRANCHIFNOT 1476 1457 ACC3 1458 BRANCHIFNOT 1482 1460 ACC3 1461 GETFIELD1 1462 PUSHACC3 1463 GETFIELD1 1464 PUSHACC5 1465 GETFIELD0 1466 PUSHACC5 1467 GETFIELD0 1468 PUSHACC5 1469 PUSHACC5 1470 APPLY3 1471 PUSHACC3 1472 PUSHOFFSETCLOSURE0 1473 APPTERM 4, 8 1476 ACC3 1477 BRANCHIF 1482 1479 ACC1 1480 RETURN 4 1482 GETGLOBAL "List.fold_left2" 1484 PUSHGETGLOBALFIELD Pervasives, 2 1487 APPTERM1 5 1489 RESTART 1490 GRAB 3 1492 ACC1 1493 BRANCHIFNOT 1516 1495 ACC2 1496 BRANCHIFNOT 1522 1498 PUSH_RETADDR 1509 1500 ACC6 1501 PUSHACC6 1502 GETFIELD1 1503 PUSHACC6 1504 GETFIELD1 1505 PUSHACC6 1506 PUSHOFFSETCLOSURE0 1507 APPLY 4 1509 PUSHACC3 1510 GETFIELD0 1511 PUSHACC3 1512 GETFIELD0 1513 PUSHACC3 1514 APPTERM3 7 1516 ACC2 1517 BRANCHIF 1522 1519 ACC3 1520 RETURN 4 1522 GETGLOBAL "List.fold_right2" 1524 PUSHGETGLOBALFIELD Pervasives, 2 1527 APPTERM1 5 1529 RESTART 1530 GRAB 1 1532 ACC1 1533 BRANCHIFNOT 1549 1535 ACC1 1536 GETFIELD0 1537 PUSHACC1 1538 APPLY1 1539 BRANCHIFNOT 1547 1541 ACC1 1542 GETFIELD1 1543 PUSHACC1 1544 PUSHOFFSETCLOSURE0 1545 APPTERM2 4 1547 RETURN 2 1549 CONST1 1550 RETURN 2 1552 RESTART 1553 GRAB 1 1555 ACC1 1556 BRANCHIFNOT 1570 1558 ACC1 1559 GETFIELD0 1560 PUSHACC1 1561 APPLY1 1562 BRANCHIF 1570 1564 ACC1 1565 GETFIELD1 1566 PUSHACC1 1567 PUSHOFFSETCLOSURE0 1568 APPTERM2 4 1570 RETURN 2 1572 RESTART 1573 GRAB 2 1575 ACC1 1576 BRANCHIFNOT 1599 1578 ACC2 1579 BRANCHIFNOT 1605 1581 ACC2 1582 GETFIELD0 1583 PUSHACC2 1584 GETFIELD0 1585 PUSHACC2 1586 APPLY2 1587 BRANCHIFNOT 1597 1589 ACC2 1590 GETFIELD1 1591 PUSHACC2 1592 GETFIELD1 1593 PUSHACC2 1594 PUSHOFFSETCLOSURE0 1595 APPTERM3 6 1597 RETURN 3 1599 ACC2 1600 BRANCHIF 1605 1602 CONST1 1603 RETURN 3 1605 GETGLOBAL "List.for_all2" 1607 PUSHGETGLOBALFIELD Pervasives, 2 1610 APPTERM1 4 1612 RESTART 1613 GRAB 2 1615 ACC1 1616 BRANCHIFNOT 1639 1618 ACC2 1619 BRANCHIFNOT 1646 1621 ACC2 1622 GETFIELD0 1623 PUSHACC2 1624 GETFIELD0 1625 PUSHACC2 1626 APPLY2 1627 BRANCHIF 1637 1629 ACC2 1630 GETFIELD1 1631 PUSHACC2 1632 GETFIELD1 1633 PUSHACC2 1634 PUSHOFFSETCLOSURE0 1635 APPTERM3 6 1637 RETURN 3 1639 ACC2 1640 BRANCHIFNOT 1644 1642 BRANCH 1646 1644 RETURN 3 1646 GETGLOBAL "List.exists2" 1648 PUSHGETGLOBALFIELD Pervasives, 2 1651 APPTERM1 4 1653 RESTART 1654 GRAB 1 1656 ACC1 1657 BRANCHIFNOT 1672 1659 ACC0 1660 PUSHACC2 1661 GETFIELD0 1662 C_CALL2 equal 1664 BRANCHIF 1672 1666 ACC1 1667 GETFIELD1 1668 PUSHACC1 1669 PUSHOFFSETCLOSURE0 1670 APPTERM2 4 1672 RETURN 2 1674 RESTART 1675 GRAB 1 1677 ACC1 1678 BRANCHIFNOT 1692 1680 ACC0 1681 PUSHACC2 1682 GETFIELD0 1683 EQ 1684 BRANCHIF 1692 1686 ACC1 1687 GETFIELD1 1688 PUSHACC1 1689 PUSHOFFSETCLOSURE0 1690 APPTERM2 4 1692 RETURN 2 1694 RESTART 1695 GRAB 1 1697 ACC1 1698 BRANCHIFNOT 1719 1700 ACC1 1701 GETFIELD0 1702 PUSHACC1 1703 PUSHACC1 1704 GETFIELD0 1705 C_CALL2 equal 1707 BRANCHIFNOT 1713 1709 ACC0 1710 GETFIELD1 1711 RETURN 3 1713 ACC2 1714 GETFIELD1 1715 PUSHACC2 1716 PUSHOFFSETCLOSURE0 1717 APPTERM2 5 1719 GETGLOBAL Not_found 1721 MAKEBLOCK1 0 1723 RAISE 1724 RESTART 1725 GRAB 1 1727 ACC1 1728 BRANCHIFNOT 1748 1730 ACC1 1731 GETFIELD0 1732 PUSHACC1 1733 PUSHACC1 1734 GETFIELD0 1735 EQ 1736 BRANCHIFNOT 1742 1738 ACC0 1739 GETFIELD1 1740 RETURN 3 1742 ACC2 1743 GETFIELD1 1744 PUSHACC2 1745 PUSHOFFSETCLOSURE0 1746 APPTERM2 5 1748 GETGLOBAL Not_found 1750 MAKEBLOCK1 0 1752 RAISE 1753 RESTART 1754 GRAB 1 1756 ACC1 1757 BRANCHIFNOT 1773 1759 ACC0 1760 PUSHACC2 1761 GETFIELD0 1762 GETFIELD0 1763 C_CALL2 equal 1765 BRANCHIF 1773 1767 ACC1 1768 GETFIELD1 1769 PUSHACC1 1770 PUSHOFFSETCLOSURE0 1771 APPTERM2 4 1773 RETURN 2 1775 RESTART 1776 GRAB 1 1778 ACC1 1779 BRANCHIFNOT 1794 1781 ACC0 1782 PUSHACC2 1783 GETFIELD0 1784 GETFIELD0 1785 EQ 1786 BRANCHIF 1794 1788 ACC1 1789 GETFIELD1 1790 PUSHACC1 1791 PUSHOFFSETCLOSURE0 1792 APPTERM2 4 1794 RETURN 2 1796 RESTART 1797 GRAB 1 1799 ACC1 1800 BRANCHIFNOT 1825 1802 ACC1 1803 GETFIELD0 1804 PUSHACC2 1805 GETFIELD1 1806 PUSHACC2 1807 PUSHACC2 1808 GETFIELD0 1809 C_CALL2 equal 1811 BRANCHIFNOT 1816 1813 ACC0 1814 RETURN 4 1816 ACC0 1817 PUSHACC3 1818 PUSHOFFSETCLOSURE0 1819 APPLY2 1820 PUSHACC2 1821 MAKEBLOCK2 0 1823 POP 2 1825 RETURN 2 1827 RESTART 1828 GRAB 1 1830 ACC1 1831 BRANCHIFNOT 1855 1833 ACC1 1834 GETFIELD0 1835 PUSHACC2 1836 GETFIELD1 1837 PUSHACC2 1838 PUSHACC2 1839 GETFIELD0 1840 EQ 1841 BRANCHIFNOT 1846 1843 ACC0 1844 RETURN 4 1846 ACC0 1847 PUSHACC3 1848 PUSHOFFSETCLOSURE0 1849 APPLY2 1850 PUSHACC2 1851 MAKEBLOCK2 0 1853 POP 2 1855 RETURN 2 1857 RESTART 1858 GRAB 1 1860 ACC1 1861 BRANCHIFNOT 1879 1863 ACC1 1864 GETFIELD0 1865 PUSHACC0 1866 PUSHACC2 1867 APPLY1 1868 BRANCHIFNOT 1873 1870 ACC0 1871 RETURN 3 1873 ACC2 1874 GETFIELD1 1875 PUSHACC2 1876 PUSHOFFSETCLOSURE0 1877 APPTERM2 5 1879 GETGLOBAL Not_found 1881 MAKEBLOCK1 0 1883 RAISE 1884 RESTART 1885 GRAB 2 1887 ACC2 1888 BRANCHIFNOT 1917 1890 ACC2 1891 GETFIELD0 1892 PUSHACC3 1893 GETFIELD1 1894 PUSHACC1 1895 PUSHENVACC2 1896 APPLY1 1897 BRANCHIFNOT 1908 1899 ACC0 1900 PUSHACC4 1901 PUSHACC4 1902 PUSHACC4 1903 MAKEBLOCK2 0 1905 PUSHOFFSETCLOSURE0 1906 APPTERM3 8 1908 ACC0 1909 PUSHACC4 1910 PUSHACC3 1911 MAKEBLOCK2 0 1913 PUSHACC4 1914 PUSHOFFSETCLOSURE0 1915 APPTERM3 8 1917 ACC1 1918 PUSHENVACC1 1919 APPLY1 1920 PUSHACC1 1921 PUSHENVACC1 1922 APPLY1 1923 MAKEBLOCK2 0 1925 RETURN 3 1927 RESTART 1928 GRAB 1 1930 ACC0 1931 PUSHENVACC1 1932 CLOSUREREC 2, 1885 1936 ACC2 1937 PUSHCONST0 1938 PUSHCONST0 1939 PUSHACC3 1940 APPTERM3 6 1942 ACC0 1943 BRANCHIFNOT 1967 1945 ACC0 1946 GETFIELD0 1947 PUSHACC1 1948 GETFIELD1 1949 PUSHOFFSETCLOSURE0 1950 APPLY1 1951 PUSHACC0 1952 GETFIELD1 1953 PUSHACC2 1954 GETFIELD1 1955 MAKEBLOCK2 0 1957 PUSHACC1 1958 GETFIELD0 1959 PUSHACC3 1960 GETFIELD0 1961 MAKEBLOCK2 0 1963 MAKEBLOCK2 0 1965 RETURN 3 1967 GETGLOBAL <0>(0, 0) 1969 RETURN 1 1971 RESTART 1972 GRAB 1 1974 ACC0 1975 BRANCHIFNOT 1996 1977 ACC1 1978 BRANCHIFNOT 2003 1980 ACC1 1981 GETFIELD1 1982 PUSHACC1 1983 GETFIELD1 1984 PUSHOFFSETCLOSURE0 1985 APPLY2 1986 PUSHACC2 1987 GETFIELD0 1988 PUSHACC2 1989 GETFIELD0 1990 MAKEBLOCK2 0 1992 MAKEBLOCK2 0 1994 RETURN 2 1996 ACC1 1997 BRANCHIFNOT 2001 1999 BRANCH 2003 2001 RETURN 2 2003 GETGLOBAL "List.combine" 2005 PUSHGETGLOBALFIELD Pervasives, 2 2008 APPTERM1 3 2010 RESTART 2011 GRAB 1 2013 ACC1 2014 BRANCHIFNOT 2038 2016 ACC1 2017 GETFIELD0 2018 PUSHACC2 2019 GETFIELD1 2020 PUSHACC1 2021 PUSHENVACC2 2022 APPLY1 2023 BRANCHIFNOT 2033 2025 ACC0 2026 PUSHACC3 2027 PUSHACC3 2028 MAKEBLOCK2 0 2030 PUSHOFFSETCLOSURE0 2031 APPTERM2 6 2033 ACC0 2034 PUSHACC3 2035 PUSHOFFSETCLOSURE0 2036 APPTERM2 6 2038 ACC0 2039 PUSHENVACC1 2040 APPTERM1 3 2042 ACC0 2043 PUSHENVACC1 2044 CLOSUREREC 2, 2011 2048 CONST0 2049 PUSHACC1 2050 APPTERM1 3 2052 RESTART 2053 GRAB 2 2055 ACC1 2056 BRANCHIFNOT 2077 2058 ACC2 2059 BRANCHIFNOT 2084 2061 ACC2 2062 GETFIELD1 2063 PUSHACC2 2064 GETFIELD1 2065 PUSHACC2 2066 PUSHACC5 2067 GETFIELD0 2068 PUSHACC5 2069 GETFIELD0 2070 PUSHENVACC1 2071 APPLY2 2072 MAKEBLOCK2 0 2074 PUSHOFFSETCLOSURE0 2075 APPTERM3 6 2077 ACC2 2078 BRANCHIFNOT 2082 2080 BRANCH 2084 2082 RETURN 3 2084 GETGLOBAL "List.rev_map2" 2086 PUSHGETGLOBALFIELD Pervasives, 2 2089 APPTERM1 4 2091 RESTART 2092 GRAB 2 2094 ACC0 2095 CLOSUREREC 1, 2053 2099 ACC3 2100 PUSHACC3 2101 PUSHCONST0 2102 PUSHACC3 2103 APPTERM3 7 2105 RESTART 2106 GRAB 1 2108 ACC1 2109 BRANCHIFNOT 2123 2111 ACC1 2112 GETFIELD1 2113 PUSHACC1 2114 PUSHACC3 2115 GETFIELD0 2116 PUSHENVACC1 2117 APPLY1 2118 MAKEBLOCK2 0 2120 PUSHOFFSETCLOSURE0 2121 APPTERM2 4 2123 ACC0 2124 RETURN 2 2126 RESTART 2127 GRAB 1 2129 ACC0 2130 CLOSUREREC 1, 2106 2134 ACC2 2135 PUSHCONST0 2136 PUSHACC2 2137 APPTERM2 5 2139 CONST0 2140 PUSHACC1 2141 PUSHENVACC1 2142 APPTERM2 3 2144 ACC0 2145 BRANCHIFNOT 2151 2147 ACC0 2148 GETFIELD1 2149 RETURN 1 2151 GETGLOBAL "tl" 2153 PUSHGETGLOBALFIELD Pervasives, 3 2156 APPTERM1 2 2158 ACC0 2159 BRANCHIFNOT 2165 2161 ACC0 2162 GETFIELD0 2163 RETURN 1 2165 GETGLOBAL "hd" 2167 PUSHGETGLOBALFIELD Pervasives, 3 2170 APPTERM1 2 2172 ACC0 2173 PUSHCONST0 2174 PUSHENVACC1 2175 APPTERM2 3 2177 CLOSUREREC 0, 1200 2181 ACC0 2182 CLOSURE 1, 2172 2185 PUSH 2186 CLOSURE 0, 2158 2189 PUSH 2190 CLOSURE 0, 2144 2193 PUSH 2194 CLOSUREREC 0, 1217 2198 GETGLOBALFIELD Pervasives, 16 2201 PUSH 2202 CLOSUREREC 0, 1259 2206 ACC0 2207 CLOSURE 1, 2139 2210 PUSH 2211 CLOSUREREC 0, 1277 2215 CLOSUREREC 0, 1294 2219 CLOSURE 0, 2127 2222 PUSH 2223 CLOSUREREC 0, 1316 2227 CLOSUREREC 0, 1334 2231 CLOSUREREC 0, 1354 2235 CLOSUREREC 0, 1374 2239 CLOSURE 0, 2092 2242 PUSH 2243 CLOSUREREC 0, 1415 2247 CLOSUREREC 0, 1452 2251 CLOSUREREC 0, 1490 2255 CLOSUREREC 0, 1530 2259 CLOSUREREC 0, 1553 2263 CLOSUREREC 0, 1573 2267 CLOSUREREC 0, 1613 2271 CLOSUREREC 0, 1654 2275 CLOSUREREC 0, 1675 2279 CLOSUREREC 0, 1695 2283 CLOSUREREC 0, 1725 2287 CLOSUREREC 0, 1754 2291 CLOSUREREC 0, 1776 2295 CLOSUREREC 0, 1797 2299 CLOSUREREC 0, 1828 2303 CLOSUREREC 0, 1858 2307 ACC 24 2309 CLOSURE 1, 2042 2312 PUSHACC 25 2314 CLOSUREREC 1, 1928 2318 CLOSUREREC 0, 1942 2322 CLOSUREREC 0, 1972 2326 ACC0 2327 PUSHACC2 2328 PUSHACC7 2329 PUSHACC 9 2331 PUSHACC 11 2333 PUSHACC 13 2335 PUSHACC 15 2337 PUSHACC 17 2339 PUSHACC 10 2341 PUSHACC 12 2343 PUSHACC 13 2345 PUSHACC 15 2347 PUSHACC 23 2349 PUSHACC 25 2351 PUSHACC 27 2353 PUSHACC 29 2355 PUSHACC 31 2357 PUSHACC 33 2359 PUSHACC 35 2361 PUSHACC 37 2363 PUSHACC 40 2365 PUSHACC 42 2367 PUSHACC 41 2369 PUSHACC 45 2371 PUSHACC 47 2373 PUSHACC 50 2375 PUSHACC 52 2377 PUSHACC 51 2379 PUSHACC 55 2381 PUSHACC 56 2383 PUSHACC 59 2385 PUSHACC 61 2387 PUSHACC 60 2389 PUSHACC 64 2391 PUSHACC 66 2393 PUSHACC 68 2395 PUSHACC 70 2397 MAKEBLOCK 37, 0 2400 POP 36 2402 SETGLOBAL List 2404 BRANCH 2432 2406 CONST0 2407 PUSHACC1 2408 LEINT 2409 BRANCHIFNOT 2414 2411 CONST0 2412 RETURN 1 2414 ACC0 2415 OFFSETINT -1 2417 PUSHOFFSETCLOSURE0 2418 APPLY1 2419 PUSHACC1 2420 MAKEBLOCK2 0 2422 RETURN 1 2424 RESTART 2425 GRAB 1 2427 ACC1 2428 PUSHACC1 2429 ADDINT 2430 RETURN 2 2432 CLOSUREREC 0, 2406 2436 CONSTINT 300 2438 PUSHACC1 2439 APPLY1 2440 PUSHCONST0 2441 C_CALL1 gc_compaction 2443 CONSTINT 150 2445 PUSHCONSTINT 301 2447 MULINT 2448 PUSHACC1 2449 PUSHCONST0 2450 PUSH 2451 CLOSURE 0, 2425 2454 PUSHGETGLOBALFIELD List, 12 2457 APPLY3 2458 NEQ 2459 BRANCHIFNOT 2466 2461 GETGLOBAL Not_found 2463 MAKEBLOCK1 0 2465 RAISE 2466 POP 2 2468 ATOM0 2469 SETGLOBAL T330-compact-3 2471 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t090-acc7.ml0000644000175000017500000000124412124403241022561 0ustar tootstootsopen Lib;; let x = true in let y = false in let z = false in let a = false in let b = false in let c = false in let d = false in let e = false in (); if not x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST1 10 PUSHCONST0 11 PUSHCONST0 12 PUSHCONST0 13 PUSHCONST0 14 PUSHCONST0 15 PUSHCONST0 16 PUSHCONST0 17 PUSHCONST0 18 ACC7 19 BOOLNOT 20 BRANCHIFNOT 27 22 GETGLOBAL Not_found 24 MAKEBLOCK1 0 26 RAISE 27 POP 8 29 ATOM0 30 SETGLOBAL T090-acc7 32 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t051-getglobalfield.ml0000644000175000017500000000033212124403241024702 0ustar tootstootsLib.x;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 GETGLOBALFIELD Lib, 0 12 ATOM0 13 SETGLOBAL T051-getglobalfield 15 STOP **) mingw-ocaml/ocaml/testsuite/tests/tool-ocaml/t092-pushacc6.ml0000644000175000017500000000112212124403241023455 0ustar tootstootsopen Lib;; let x = false in let y = true in let z = true in let a = true in let b = true in let c = true in let d = true in if x then raise Not_found ;; (** 0 CONSTINT 42 2 PUSHACC0 3 MAKEBLOCK1 0 5 POP 1 7 SETGLOBAL Lib 9 CONST0 10 PUSHCONST1 11 PUSHCONST1 12 PUSHCONST1 13 PUSHCONST1 14 PUSHCONST1 15 PUSHCONST1 16 PUSHACC6 17 BRANCHIFNOT 24 19 GETGLOBAL Not_found 21 MAKEBLOCK1 0 23 RAISE 24 POP 7 26 ATOM0 27 SETGLOBAL T092-pushacc6 29 STOP **) mingw-ocaml/ocaml/testsuite/tests/typing-signatures/0000755000175000017500000000000012124403241022345 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-signatures/Makefile0000644000175000017500000000015212124403241024003 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-signatures/els.ml.reference0000644000175000017500000000576612124403241025435 0ustar tootstoots # * module type VALUE = sig type value type state type usert end # module type CORE0 = sig module V : VALUE val setglobal : V.state -> string -> V.value -> unit end # module type CORE = sig module V : VALUE val setglobal : V.state -> string -> V.value -> unit val apply : V.value -> V.state -> V.value list -> V.value end # module type AST = sig module Value : VALUE type chunk type program val get_value : chunk -> Value.value end # module type EVALUATOR = sig module Value : VALUE module Ast : sig type chunk type program val get_value : chunk -> Value.value end type state = Value.state type value = Value.value exception Error of string val compile : Ast.program -> string val setglobal : Value.state -> string -> Value.value -> unit end # module type PARSER = sig type chunk val parse : string -> chunk end # module type INTERP = sig module Value : VALUE module Ast : sig type chunk type program val get_value : chunk -> Value.value end type state = Value.state type value = Value.value exception Error of string val compile : Ast.program -> string val setglobal : Value.state -> string -> Value.value -> unit module Parser : sig type chunk = Ast.chunk val parse : string -> chunk end val dostring : state -> string -> value list val mk : unit -> state end # module type USERTYPE = sig type t val eq : t -> t -> bool val to_string : t -> string end # module type TYPEVIEW = sig type combined type t val map : (combined -> t) * (t -> combined) end # module type COMBINED_COMMON = sig module T : sig type t end module TV1 : sig type t val map : (T.t -> t) * (t -> T.t) end module TV2 : sig type t val map : (T.t -> t) * (t -> T.t) end end # module type COMBINED_TYPE = sig module T : USERTYPE module TV1 : sig type t val map : (T.t -> t) * (t -> T.t) end module TV2 : sig type t val map : (T.t -> t) * (t -> T.t) end end # module type BARECODE = sig type state val init : state -> unit end # module USERCODE : functor (X : TYPEVIEW) -> sig module type F = functor (C : sig module V : sig type value type state type usert = X.combined end val setglobal : V.state -> string -> V.value -> unit val apply : V.value -> V.state -> V.value list -> V.value end) -> sig val init : C.V.state -> unit end end # module Weapon : sig type t end # module type WEAPON_LIB = sig type t = Weapon.t module T : sig type t = t val eq : t -> t -> bool val to_string : t -> string end module Make : functor (TV : sig type combined type t = t val map : (combined -> t) * (t -> combined) end) -> USERCODE(TV).F end # mingw-ocaml/ocaml/testsuite/tests/typing-signatures/els.ml0000644000175000017500000000414712124403241023470 0ustar tootstoots(* Adapted from: An Expressive Language of Signatures by Norman Ramsey, Kathleen Fisher and Paul Govereau *) module type VALUE = sig type value (* a Lua value *) type state (* the state of a Lua interpreter *) type usert (* a user-defined value *) end;; module type CORE0 = sig module V : VALUE val setglobal : V.state -> string -> V.value -> unit (* five more functions common to core and evaluator *) end;; module type CORE = sig include CORE0 val apply : V.value -> V.state -> V.value list -> V.value (* apply function f in state s to list of args *) end;; module type AST = sig module Value : VALUE type chunk type program val get_value : chunk -> Value.value end;; module type EVALUATOR = sig module Value : VALUE module Ast : (AST with module Value := Value) type state = Value.state type value = Value.value exception Error of string val compile : Ast.program -> string include CORE0 with module V := Value end;; module type PARSER = sig type chunk val parse : string -> chunk end;; module type INTERP = sig include EVALUATOR module Parser : PARSER with type chunk = Ast.chunk val dostring : state -> string -> value list val mk : unit -> state end;; module type USERTYPE = sig type t val eq : t -> t -> bool val to_string : t -> string end;; module type TYPEVIEW = sig type combined type t val map : (combined -> t) * (t -> combined) end;; module type COMBINED_COMMON = sig module T : sig type t end module TV1 : TYPEVIEW with type combined := T.t module TV2 : TYPEVIEW with type combined := T.t end;; module type COMBINED_TYPE = sig module T : USERTYPE include COMBINED_COMMON with module T := T end;; module type BARECODE = sig type state val init : state -> unit end;; module USERCODE(X : TYPEVIEW) = struct module type F = functor (C : CORE with type V.usert = X.combined) -> BARECODE with type state := C.V.state end;; module Weapon = struct type t end;; module type WEAPON_LIB = sig type t = Weapon.t module T : USERTYPE with type t = t module Make : functor (TV : TYPEVIEW with type t = t) -> USERCODE(TV).F end;; mingw-ocaml/ocaml/testsuite/tests/misc-unsafe/0000755000175000017500000000000012124403241021063 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/misc-unsafe/fft.ml0000644000175000017500000001141612124403241022177 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) let pi = 3.14159265358979323846 let tpi = 2.0 *. pi let fft px py np = let i = ref 2 in let m = ref 1 in while (!i < np) do i := !i + !i; m := !m + 1 done; let n = !i in if n <> np then begin for i = np+1 to n do px.(i) <- 0.0; py.(i) <- 0.0 done; print_string "Use "; print_int n; print_string " point fft"; print_newline() end; let n2 = ref(n+n) in for k = 1 to !m-1 do n2 := !n2 / 2; let n4 = !n2 / 4 in let e = tpi /. float !n2 in for j = 1 to n4 do let a = e *. float(j - 1) in let a3 = 3.0 *. a in let cc1 = cos(a) in let ss1 = sin(a) in let cc3 = cos(a3) in let ss3 = sin(a3) in let is = ref j in let id = ref(2 * !n2) in while !is < n do let i0r = ref !is in while !i0r < n do let i0 = !i0r in let i1 = i0 + n4 in let i2 = i1 + n4 in let i3 = i2 + n4 in let r1 = px.(i0) -. px.(i2) in px.(i0) <- px.(i0) +. px.(i2); let r2 = px.(i1) -. px.(i3) in px.(i1) <- px.(i1) +. px.(i3); let s1 = py.(i0) -. py.(i2) in py.(i0) <- py.(i0) +. py.(i2); let s2 = py.(i1) -. py.(i3) in py.(i1) <- py.(i1) +. py.(i3); let s3 = r1 -. s2 in let r1 = r1 +. s2 in let s2 = r2 -. s1 in let r2 = r2 +. s1 in px.(i2) <- r1*.cc1 -. s2*.ss1; py.(i2) <- -.s2*.cc1 -. r1*.ss1; px.(i3) <- s3*.cc3 +. r2*.ss3; py.(i3) <- r2*.cc3 -. s3*.ss3; i0r := i0 + !id done; is := 2 * !id - !n2 + j; id := 4 * !id done done done; (************************************) (* Last stage, length=2 butterfly *) (************************************) let is = ref 1 in let id = ref 4 in while !is < n do let i0r = ref !is in while !i0r <= n do let i0 = !i0r in let i1 = i0 + 1 in let r1 = px.(i0) in px.(i0) <- r1 +. px.(i1); px.(i1) <- r1 -. px.(i1); let r1 = py.(i0) in py.(i0) <- r1 +. py.(i1); py.(i1) <- r1 -. py.(i1); i0r := i0 + !id done; is := 2 * !id - 1; id := 4 * !id done; (*************************) (* Bit reverse counter *) (*************************) let j = ref 1 in for i = 1 to n - 1 do if i < !j then begin let xt = px.(!j) in px.(!j) <- px.(i); px.(i) <- xt; let xt = py.(!j) in py.(!j) <- py.(i); py.(i) <- xt end; let k = ref(n / 2) in while !k < !j do j := !j - !k; k := !k / 2 done; j := !j + !k done; n let test np = print_int np; print_string "... "; flush stdout; let enp = float np in let npm = np / 2 - 1 in let pxr = Array.create (np+2) 0.0 and pxi = Array.create (np+2) 0.0 in let t = pi /. enp in pxr.(1) <- (enp -. 1.0) *. 0.5; pxi.(1) <- 0.0; let n2 = np / 2 in pxr.(n2+1) <- -0.5; pxi.(n2+1) <- 0.0; for i = 1 to npm do let j = np - i in pxr.(i+1) <- -0.5; pxr.(j+1) <- -0.5; let z = t *. float i in let y = -0.5*.(cos(z)/.sin(z)) in pxi.(i+1) <- y; pxi.(j+1) <- -.y done; (** print_newline(); for i=0 to 15 do Printf.printf "%d %f %f\n" i pxr.(i+1) pxi.(i+1) done; **) let _ = fft pxr pxi np in (** for i=0 to 15 do Printf.printf "%d %f %f\n" i pxr.(i+1) pxi.(i+1) done; **) let zr = ref 0.0 in let zi = ref 0.0 in let kr = ref 0 in let ki = ref 0 in for i = 0 to np-1 do let a = abs_float(pxr.(i+1) -. float i) in if !zr < a then begin zr := a; kr := i end; let a = abs_float(pxi.(i+1)) in if !zi < a then begin zi := a; ki := i end done; if abs_float !zr <= 1e-9 && abs_float !zi <= 1e-9 then print_string "ok" else print_string "ERROR"; print_newline() let _ = let np = ref 16 in for i = 1 to 16 do test !np; np := !np*2 done mingw-ocaml/ocaml/testsuite/tests/misc-unsafe/Makefile0000644000175000017500000000016312124403241022523 0ustar tootstootsBASEDIR=../.. UNSAFE=ON include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/misc-unsafe/quicksort.reference0000644000175000017500000000000612124403241024763 0ustar tootstootsOK OK mingw-ocaml/ocaml/testsuite/tests/misc-unsafe/almabench.reference0000644000175000017500000000015612124403241024657 0ustar tootstoots0 17.00 -26.06 1 12.34 1.29 2 6.83 22.95 3 0.04 -1.26 4 2.30 12.54 5 2.93 14.35 6 21.27 -16.57 7 20.41 -19.04 mingw-ocaml/ocaml/testsuite/tests/misc-unsafe/soli.ml0000644000175000017500000000655712124403241022400 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) type peg = Out | Empty | Peg let board = [| [| Out; Out; Out; Out; Out; Out; Out; Out; Out|]; [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|]; [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|]; [| Out; Peg; Peg; Peg; Peg; Peg; Peg; Peg; Out|]; [| Out; Peg; Peg; Peg; Empty; Peg; Peg; Peg; Out|]; [| Out; Peg; Peg; Peg; Peg; Peg; Peg; Peg; Out|]; [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|]; [| Out; Out; Out; Peg; Peg; Peg; Out; Out; Out|]; [| Out; Out; Out; Out; Out; Out; Out; Out; Out|] |] let print_peg = function Out -> print_string "." | Empty -> print_string " " | Peg -> print_string "$" let print_board board = for i=0 to 8 do for j=0 to 8 do print_peg board.(i).(j) done; print_newline() done type direction = { dx: int; dy: int } let dir = [| {dx = 0; dy = 1}; {dx = 1; dy = 0}; {dx = 0; dy = -1}; {dx = -1; dy = 0} |] type move = { x1: int; y1: int; x2: int; y2: int } let moves = Array.create 31 {x1=0;y1=0;x2=0;y2=0} let counter = ref 0 exception Found let rec solve m = counter := !counter + 1; if m = 31 then begin match board.(4).(4) with Peg -> true | _ -> false end else try if !counter mod 500 = 0 then begin print_int !counter; print_newline() end; for i=1 to 7 do for j=1 to 7 do match board.(i).(j) with Peg -> for k=0 to 3 do let d1 = dir.(k).dx in let d2 = dir.(k).dy in let i1 = i+d1 in let i2 = i1+d1 in let j1 = j+d2 in let j2 = j1+d2 in match board.(i1).(j1) with Peg -> begin match board.(i2).(j2) with Empty -> (* print_int i; print_string ", "; print_int j; print_string ") dir "; print_int k; print_string "\n"; *) board.(i).(j) <- Empty; board.(i1).(j1) <- Empty; board.(i2).(j2) <- Peg; if solve(m+1) then begin moves.(m) <- { x1=i; y1=j; x2=i2; y2=j2 }; raise Found end; board.(i).(j) <- Peg; board.(i1).(j1) <- Peg; board.(i2).(j2) <- Empty | _ -> () end | _ -> () done | _ -> () done done; false with Found -> true let _ = if solve 0 then (print_string "\n"; print_board board) mingw-ocaml/ocaml/testsuite/tests/misc-unsafe/fft.reference0000644000175000017500000000026012124403241023520 0ustar tootstoots16... ok 32... ok 64... ok 128... ok 256... ok 512... ok 1024... ok 2048... ok 4096... ok 8192... ok 16384... ok 32768... ok 65536... ok 131072... ok 262144... ok 524288... ok mingw-ocaml/ocaml/testsuite/tests/misc-unsafe/soli.reference0000644000175000017500000000046712124403241023720 0ustar tootstoots500 1000 1500 2000 2500 3000 3500 4000 4500 5000 5500 6000 6500 7000 7500 8000 8500 9000 9500 10000 10500 11000 11500 12000 12500 13000 13500 14000 14500 15000 15500 16000 16500 17000 17500 18000 18500 19000 19500 20000 ......... ... ... ... ... . . . $ . . . ... ... ... ... ......... mingw-ocaml/ocaml/testsuite/tests/misc-unsafe/almabench.ml0000644000175000017500000003412712124403241023336 0ustar tootstoots(* * ALMABENCH 1.0.1 * OCaml version * * A number-crunching benchmark designed for cross-language and vendor * comparisons. * * Written by Shawn Wagner, from Scott Robert Ladd's versions for * C++ and java. * * No rights reserved. This is public domain software, for use by anyone. * * This program calculates the daily ephemeris (at noon) for the years * 2000-2099 using an algorithm developed by J.L. Simon, P. Bretagnon, J. * Chapront, M. Chapront-Touze, G. Francou and J. Laskar of the Bureau des * Longitudes, Paris, France), as detailed in Astronomy & Astrophysics * 282, 663 (1994) * * Note that the code herein is design for the purpose of testing * computational performance; error handling and other such "niceties" * is virtually non-existent. * * Actual (and oft-updated) benchmark results can be found at: * http://www.coyotegulch.com * * Please do not use this information or algorithm in any way that might * upset the balance of the universe or otherwise cause planets to impact * upon one another. *) let pic = 3.14159265358979323846 and j2000 = 2451545.0 and jcentury = 36525.0 and jmillenia = 365250.0 let twopi = 2.0 *. pic and a2r = pic /. 648000.0 and r2h = 12.0 /. pic and r2d = 180.0 /. pic and gaussk = 0.01720209895 (* number of days to include in test *) let test_loops = 5 (* was: 20 *) and test_length = 36525 (* sin and cos of j2000 mean obliquity (iau 1976) *) and sineps = 0.3977771559319137 and coseps = 0.9174820620691818 and amas = [| 6023600.0; 408523.5; 328900.5; 3098710.0; 1047.355; 3498.5; 22869.0; 19314.0 |] (* * tables giving the mean keplerian elements, limited to t**2 terms: * a semi-major axis (au) * dlm mean longitude (degree and arcsecond) * e eccentricity * pi longitude of the perihelion (degree and arcsecond) * dinc inclination (degree and arcsecond) * omega longitude of the ascending node (degree and arcsecond) *) and a = [| [| 0.3870983098; 0.0; 0.0 |]; [| 0.7233298200; 0.0; 0.0 |]; [| 1.0000010178; 0.0; 0.0 |]; [| 1.5236793419; 3e-10; 0.0 |]; [| 5.2026032092; 19132e-10; -39e-10 |]; [| 9.5549091915; -0.0000213896; 444e-10 |]; [| 19.2184460618; -3716e-10; 979e-10 |]; [| 30.1103868694; -16635e-10; 686e-10 |] |] and dlm = [| [| 252.25090552; 5381016286.88982; -1.92789 |]; [| 181.97980085; 2106641364.33548; 0.59381 |]; [| 100.46645683; 1295977422.83429; -2.04411 |]; [| 355.43299958; 689050774.93988; 0.94264 |]; [| 34.35151874; 109256603.77991; -30.60378 |]; [| 50.07744430; 43996098.55732; 75.61614 |]; [| 314.05500511; 15424811.93933; -1.75083 |]; [| 304.34866548; 7865503.20744; 0.21103 |] |] and e = [| [| 0.2056317526; 0.0002040653; -28349e-10 |]; [| 0.0067719164; -0.0004776521; 98127e-10 |]; [| 0.0167086342; -0.0004203654; -0.0000126734 |]; [| 0.0934006477; 0.0009048438; -80641e-10 |]; [| 0.0484979255; 0.0016322542; -0.0000471366 |]; [| 0.0555481426; -0.0034664062; -0.0000643639 |]; [| 0.0463812221; -0.0002729293; 0.0000078913 |]; [| 0.0094557470; 0.0000603263; 0.0 |] |] and pi = [| [| 77.45611904; 5719.11590; -4.83016 |]; [| 131.56370300; 175.48640; -498.48184 |]; [| 102.93734808; 11612.35290; 53.27577 |]; [| 336.06023395; 15980.45908; -62.32800 |]; [| 14.33120687; 7758.75163; 259.95938 |]; [| 93.05723748; 20395.49439; 190.25952 |]; [| 173.00529106; 3215.56238; -34.09288 |]; [| 48.12027554; 1050.71912; 27.39717 |] |] and dinc = [| [| 7.00498625; -214.25629; 0.28977 |]; [| 3.39466189; -30.84437; -11.67836 |]; [| 0.0; 469.97289; -3.35053 |]; [| 1.84972648; -293.31722; -8.11830 |]; [| 1.30326698; -71.55890; 11.95297 |]; [| 2.48887878; 91.85195; -17.66225 |]; [| 0.77319689; -60.72723; 1.25759 |]; [| 1.76995259; 8.12333; 0.08135 |] |] and omega = [| [| 48.33089304; -4515.21727; -31.79892 |]; [| 76.67992019; -10008.48154; -51.32614 |]; [| 174.87317577; -8679.27034; 15.34191 |]; [| 49.55809321; -10620.90088; -230.57416 |]; [| 100.46440702; 6362.03561; 326.52178 |]; [| 113.66550252; -9240.19942; -66.23743 |]; [| 74.00595701; 2669.15033; 145.93964 |]; [| 131.78405702; -221.94322; -0.78728 |] |] (* tables for trigonometric terms to be added to the mean elements of the semi-major axes. *) and kp = [| [| 69613.0; 75645.0; 88306.0; 59899.0; 15746.0; 71087.0; 142173.0; 3086.0; 0.0 |]; [| 21863.0; 32794.0; 26934.0; 10931.0; 26250.0; 43725.0; 53867.0; 28939.0; 0.0 |]; [| 16002.0; 21863.0; 32004.0; 10931.0; 14529.0; 16368.0; 15318.0; 32794.0; 0.0 |]; [| 6345.0; 7818.0; 15636.0; 7077.0; 8184.0; 14163.0; 1107.0; 4872.0; 0.0 |]; [| 1760.0; 1454.0; 1167.0; 880.0; 287.0; 2640.0; 19.0; 2047.0; 1454.0 |]; [| 574.0; 0.0; 880.0; 287.0; 19.0; 1760.0; 1167.0; 306.0; 574.0 |]; [| 204.0; 0.0; 177.0; 1265.0; 4.0; 385.0; 200.0; 208.0; 204.0 |]; [| 0.0; 102.0; 106.0; 4.0; 98.0; 1367.0; 487.0; 204.0; 0.0 |] |] and ca = [| [| 4.0; -13.0; 11.0; -9.0; -9.0; -3.0; -1.0; 4.0; 0.0 |]; [| -156.0; 59.0; -42.0; 6.0; 19.0; -20.0; -10.0; -12.0; 0.0 |]; [| 64.0; -152.0; 62.0; -8.0; 32.0; -41.0; 19.0; -11.0; 0.0 |]; [| 124.0; 621.0; -145.0; 208.0; 54.0; -57.0; 30.0; 15.0; 0.0 |]; [| -23437.0; -2634.0; 6601.0; 6259.0; -1507.0; -1821.0; 2620.0; -2115.0;-1489.0 |]; [| 62911.0;-119919.0; 79336.0; 17814.0;-24241.0; 12068.0; 8306.0; -4893.0; 8902.0 |]; [| 389061.0;-262125.0;-44088.0; 8387.0;-22976.0; -2093.0; -615.0; -9720.0; 6633.0 |]; [| -412235.0;-157046.0;-31430.0; 37817.0; -9740.0; -13.0; -7449.0; 9644.0; 0.0 |] |] and sa = [| [| -29.0; -1.0; 9.0; 6.0; -6.0; 5.0; 4.0; 0.0; 0.0 |]; [| -48.0; -125.0; -26.0; -37.0; 18.0; -13.0; -20.0; -2.0; 0.0 |]; [| -150.0; -46.0; 68.0; 54.0; 14.0; 24.0; -28.0; 22.0; 0.0 |]; [| -621.0; 532.0; -694.0; -20.0; 192.0; -94.0; 71.0; -73.0; 0.0 |]; [| -14614.0;-19828.0; -5869.0; 1881.0; -4372.0; -2255.0; 782.0; 930.0; 913.0 |]; [| 139737.0; 0.0; 24667.0; 51123.0; -5102.0; 7429.0; -4095.0; -1976.0;-9566.0 |]; [| -138081.0; 0.0; 37205.0;-49039.0;-41901.0;-33872.0;-27037.0;-12474.0;18797.0 |]; [| 0.0; 28492.0;133236.0; 69654.0; 52322.0;-49577.0;-26430.0; -3593.0; 0.0 |] |] (* tables giving the trigonometric terms to be added to the mean elements of the mean longitudes . *) and kq = [| [| 3086.0; 15746.0; 69613.0; 59899.0; 75645.0; 88306.0; 12661.0; 2658.0; 0.0; 0.0 |]; [| 21863.0; 32794.0; 10931.0; 73.0; 4387.0; 26934.0; 1473.0; 2157.0; 0.0; 0.0 |]; [| 10.0; 16002.0; 21863.0; 10931.0; 1473.0; 32004.0; 4387.0; 73.0; 0.0; 0.0 |]; [| 10.0; 6345.0; 7818.0; 1107.0; 15636.0; 7077.0; 8184.0; 532.0; 10.0; 0.0 |]; [| 19.0; 1760.0; 1454.0; 287.0; 1167.0; 880.0; 574.0; 2640.0; 19.0;1454.0 |]; [| 19.0; 574.0; 287.0; 306.0; 1760.0; 12.0; 31.0; 38.0; 19.0; 574.0 |]; [| 4.0; 204.0; 177.0; 8.0; 31.0; 200.0; 1265.0; 102.0; 4.0; 204.0 |]; [| 4.0; 102.0; 106.0; 8.0; 98.0; 1367.0; 487.0; 204.0; 4.0; 102.0 |] |] and cl = [| [| 21.0; -95.0; -157.0; 41.0; -5.0; 42.0; 23.0; 30.0; 0.0; 0.0 |]; [| -160.0; -313.0; -235.0; 60.0; -74.0; -76.0; -27.0; 34.0; 0.0; 0.0 |]; [| -325.0; -322.0; -79.0; 232.0; -52.0; 97.0; 55.0; -41.0; 0.0; 0.0 |]; [| 2268.0; -979.0; 802.0; 602.0; -668.0; -33.0; 345.0; 201.0; -55.0; 0.0 |]; [| 7610.0; -4997.0;-7689.0;-5841.0;-2617.0; 1115.0; -748.0; -607.0; 6074.0; 354.0 |]; [| -18549.0; 30125.0;20012.0; -730.0; 824.0; 23.0; 1289.0; -352.0;-14767.0;-2062.0 |]; [| -135245.0;-14594.0; 4197.0;-4030.0;-5630.0;-2898.0; 2540.0; -306.0; 2939.0; 1986.0 |]; [| 89948.0; 2103.0; 8963.0; 2695.0; 3682.0; 1648.0; 866.0; -154.0; -1963.0; -283.0 |] |] and sl = [| [| -342.0; 136.0; -23.0; 62.0; 66.0; -52.0; -33.0; 17.0; 0.0; 0.0 |]; [| 524.0; -149.0; -35.0; 117.0; 151.0; 122.0; -71.0; -62.0; 0.0; 0.0 |]; [| -105.0; -137.0; 258.0; 35.0; -116.0; -88.0; -112.0; -80.0; 0.0; 0.0 |]; [| 854.0; -205.0; -936.0; -240.0; 140.0; -341.0; -97.0; -232.0; 536.0; 0.0 |]; [| -56980.0; 8016.0; 1012.0; 1448.0;-3024.0;-3710.0; 318.0; 503.0; 3767.0; 577.0 |]; [| 138606.0;-13478.0;-4964.0; 1441.0;-1319.0;-1482.0; 427.0; 1236.0; -9167.0;-1918.0 |]; [| 71234.0;-41116.0; 5334.0;-4935.0;-1848.0; 66.0; 434.0;-1748.0; 3780.0; -701.0 |]; [| -47645.0; 11647.0; 2166.0; 3194.0; 679.0; 0.0; -244.0; -419.0; -2531.0; 48.0 |] |] (* Normalize angle into the range -pi <= A < +pi. *) let anpm a = let w = mod_float a twopi in if abs_float w >= pic then begin if a < 0.0 then w +. twopi else w -. twopi end else w (* The reference frame is equatorial and is with respect to the * mean equator and equinox of epoch j2000. *) let planetpv epoch np pv = (* time: julian millennia since j2000. *) let t = ((epoch.(0) -. j2000) +. epoch.(1)) /. jmillenia in (* compute the mean elements. *) let da = ref (a.(np).(0) +. (a.(np).(1) +. a.(np).(2) *. t ) *. t) and dl = ref ((3600.0 *. dlm.(np).(0) +. (dlm.(np).(1) +. dlm.(np).(2) *. t ) *. t) *. a2r) and de = e.(np).(0) +. (e.(np).(1) +. e.(np).(2) *. t ) *. t and dp = anpm ((3600.0 *. pi.(np).(0) +. (pi.(np).(1) +. pi.(np).(2) *. t ) *. t ) *. a2r ) and di = (3600.0 *. dinc.(np).(0) +. (dinc.(np).(1) +. dinc.(np).(2) *. t ) *. t ) *. a2r and doh = anpm ((3600.0 *. omega.(np).(0) +. (omega.(np).(1) +. omega.(np).(2) *. t ) *. t ) *. a2r ) (* apply the trigonometric terms. *) and dmu = 0.35953620 *. t in (* loop invariant *) let kp = kp.(np) and kq = kq.(np) and ca = ca.(np) and sa = sa.(np) and cl = cl.(np) and sl = sl.(np) in for k = 0 to 7 do let arga = kp.(k) *. dmu and argl = kq.(k) *. dmu in da := !da +. (ca.(k) *. cos arga +. sa.(k) *. sin arga) *. 0.0000001; dl := !dl +. (cl.(k) *. cos argl +. sl.(k) *. sin argl) *. 0.0000001 done; begin let arga = kp.(8) *. dmu in da := !da +. t *. (ca.(8) *. cos arga +. sa.(8) *. sin arga ) *. 0.0000001; for k = 8 to 9 do let argl = kq.(k) *. dmu in dl := !dl +. t *. ( cl.(k) *. cos argl +. sl.(k) *. sin argl ) *. 0.0000001 done; end; dl := mod_float !dl twopi; (* iterative solution of kepler's equation to get eccentric anomaly. *) let am = !dl -. dp in let ae = ref (am +. de *. sin am) and k = ref 0 in let dae = ref ((am -. !ae +. de *. sin !ae) /. (1.0 -. de *. cos !ae)) in ae := !ae +. !dae; incr k; while !k < 10 or abs_float !dae >= 1e-12 do dae := (am -. !ae +. de *. sin !ae) /. (1.0 -. de *. cos !ae); ae := !ae +. !dae; incr k done; (* true anomaly. *) let ae2 = !ae /. 2.0 in let at = 2.0 *. atan2 (sqrt ((1.0 +. de) /. (1.0 -. de)) *. sin ae2) (cos ae2) (* distance (au) and speed (radians per day). *) and r = !da *. (1.0 -. de *. cos !ae) and v = gaussk *. sqrt ((1.0 +. 1.0 /. amas.(np) ) /. (!da *. !da *. !da)) and si2 = sin (di /. 2.0) in let xq = si2 *. cos doh and xp = si2 *. sin doh and tl = at +. dp in let xsw = sin tl and xcw = cos tl in let xm2 = 2.0 *. (xp *. xcw -. xq *. xsw ) and xf = !da /. sqrt (1.0 -. de *. de) and ci2 = cos (di /. 2.0) in let xms = (de *. sin dp +. xsw) *. xf and xmc = (de *. cos dp +. xcw) *. xf and xpxq2 = 2.0 *. xp *. xq in (* position (j2000 ecliptic x,y,z in au). *) let x = r *. (xcw -. xm2 *. xp) and y = r *. (xsw +. xm2 *. xq) and z = r *. (-.xm2 *. ci2) in (* rotate to equatorial. *) pv.(0).(0) <- x; pv.(0).(1) <- y *. coseps -. z *. sineps; pv.(0).(2) <- y *. sineps +. z *. coseps; (* velocity (j2000 ecliptic xdot,ydot,zdot in au/d). *) let x = v *. ((-1.0 +. 2.0 *. xp *. xp) *. xms +. xpxq2 *. xmc) and y = v *. (( 1.0 -. 2.0 *. xq *. xq ) *. xmc -. xpxq2 *. xms) and z = v *. (2.0 *. ci2 *. (xp *. xms +. xq *. xmc)) in (* rotate to equatorial *) pv.(1).(0) <- x; pv.(1).(1) <- y *. coseps -. z *. sineps; pv.(1).(2) <- y *. sineps +. z *. coseps (* Computes RA, Declination, and distance from a state vector returned by * planetpv. *) let radecdist state rdd = (* Distance *) rdd.(2) <- sqrt (state.(0).(0) *. state.(0).(0) +. state.(0).(1) *. state.(0).(1) +. state.(0).(2) *. state.(0).(2)); (* RA *) rdd.(0) <- atan2 state.(0).(1) state.(0).(0) *. r2h; if rdd.(0) < 0.0 then rdd.(0) <- rdd.(0) +. 24.0; (* Declination *) rdd.(1) <- asin (state.(0).(2) /. rdd.(2)) *. r2d (* Entry point. Calculate RA and Dec for noon on every day in 1900-2100 *) let _ = let jd = [| 0.0; 0.0 |] and pv = [| [| 0.0; 0.0; 0.0 |]; [| 0.0; 0.0; 0.0 |] |] and position = [| 0.0; 0.0; 0.0 |] in (* Test *) jd.(0) <- j2000; jd.(1) <- 1.0; for p = 0 to 7 do planetpv jd p pv; radecdist pv position; Printf.printf "%d %.2f %.2f\n%!" p position.(0) position.(1) done; (* Benchmark *) for i = 0 to test_loops - 1 do jd.(0) <- j2000; jd.(1) <- 0.0; for n = 0 to test_length - 1 do jd.(0) <- jd.(0) +. 1.0; for p = 0 to 7 do planetpv jd p pv; radecdist pv position; done done done mingw-ocaml/ocaml/testsuite/tests/misc-unsafe/quicksort.ml0000644000175000017500000000524312124403241023445 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Good test for loops. Best compiled with -unsafe. *) let rec qsort lo hi (a : int array) = if lo < hi then begin let i = ref lo in let j = ref hi in let pivot = a.(hi) in while !i < !j do while !i < hi && a.(!i) <= pivot do incr i done; while !j > lo && a.(!j) >= pivot do decr j done; if !i < !j then begin let temp = a.(!i) in a.(!i) <- a.(!j); a.(!j) <- temp end done; let temp = a.(!i) in a.(!i) <- a.(hi); a.(hi) <- temp; qsort lo (!i-1) a; qsort (!i+1) hi a end (* Same but abstract over the comparison to force spilling *) let cmp i j = i - j let rec qsort2 lo hi (a : int array) = if lo < hi then begin let i = ref lo in let j = ref hi in let pivot = a.(hi) in while !i < !j do while !i < hi && cmp a.(!i) pivot <= 0 do incr i done; while !j > lo && cmp a.(!j) pivot >= 0 do decr j done; if !i < !j then begin let temp = a.(!i) in a.(!i) <- a.(!j); a.(!j) <- temp end done; let temp = a.(!i) in a.(!i) <- a.(hi); a.(hi) <- temp; qsort2 lo (!i-1) a; qsort2 (!i+1) hi a end (* Test *) let seed = ref 0 let random() = seed := !seed * 25173 + 17431; !seed land 0xFFF exception Failed let test_sort sort_fun size = let a = Array.create size 0 in let check = Array.create 4096 0 in for i = 0 to size-1 do let n = random() in a.(i) <- n; check.(n) <- check.(n)+1 done; sort_fun 0 (size-1) a; try check.(a.(0)) <- check.(a.(0)) - 1; for i = 1 to size-1 do if a.(i-1) > a.(i) then raise Failed; check.(a.(i)) <- check.(a.(i)) - 1 done; for i = 0 to 4095 do if check.(i) <> 0 then raise Failed done; print_string "OK"; print_newline() with Failed -> print_string "failed"; print_newline() let main () = test_sort qsort 500000; test_sort qsort2 500000 let _ = main(); exit 0 mingw-ocaml/ocaml/testsuite/tests/basic-manyargs/0000755000175000017500000000000012124403241021551 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/basic-manyargs/Makefile0000644000175000017500000000023212124403241023206 0ustar tootstootsBASEDIR=../.. #MODULES= MAIN_MODULE=manyargs C_FILES=manyargsprim include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/basic-manyargs/manyargsprim.c0000644000175000017500000000136112124403241024427 0ustar tootstoots#include "mlvalues.h" #include "stdio.h" value manyargs(value a, value b, value c, value d, value e, value f, value g, value h, value i, value j, value k) { printf("a = %d\n", Int_val(a)); printf("b = %d\n", Int_val(b)); printf("c = %d\n", Int_val(c)); printf("d = %d\n", Int_val(d)); printf("e = %d\n", Int_val(e)); printf("f = %d\n", Int_val(f)); printf("g = %d\n", Int_val(g)); printf("h = %d\n", Int_val(h)); printf("i = %d\n", Int_val(i)); printf("j = %d\n", Int_val(j)); printf("k = %d\n", Int_val(k)); return Val_unit; } value manyargs_argv(value *argv, int argc) { return manyargs(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8], argv[9], argv[10]); } mingw-ocaml/ocaml/testsuite/tests/basic-manyargs/manyargs.reference0000644000175000017500000000062412124403241025254 0ustar tootstootsa = 1 b = 2 c = 3 d = 4 e = 5 f = 6 g = 7 h = 8 i = 9 j = 10 k = 11 l = 12 m = 13 n = 14 o = 15 --- tail1: a = 1 b = 2 c = 3 d = 4 e = 5 f = 6 g = 7 h = 8 i = 9 j = 10 k = 11 l = 12 m = 13 n = 14 o = 15 --- tail2: a = 0 b = 1 c = 0 d = 1 e = 0 f = 1 g = 0 h = 1 i = 0 j = 1 k = 0 l = 1 m = 0 n = 1 o = 0 --- tail3: o = 15 --- external: a = 1 b = 2 c = 3 d = 4 e = 5 f = 6 g = 7 h = 8 i = 9 j = 10 k = 11 mingw-ocaml/ocaml/testsuite/tests/basic-manyargs/manyargs.ml0000644000175000017500000000321212124403241023722 0ustar tootstootslet manyargs a b c d e f g h i j k l m n o = print_string "a = "; print_int a; print_newline(); print_string "b = "; print_int b; print_newline(); print_string "c = "; print_int c; print_newline(); print_string "d = "; print_int d; print_newline(); print_string "e = "; print_int e; print_newline(); print_string "f = "; print_int f; print_newline(); print_string "g = "; print_int g; print_newline(); print_string "h = "; print_int h; print_newline(); print_string "i = "; print_int i; print_newline(); print_string "j = "; print_int j; print_newline(); print_string "k = "; print_int k; print_newline(); print_string "l = "; print_int l; print_newline(); print_string "m = "; print_int m; print_newline(); print_string "n = "; print_int n; print_newline(); print_string "o = "; print_int o; print_newline(); print_string "---"; print_newline() let manyargs_tail1 a b c d e f g h i j k l m n o = print_string "tail1:\n"; manyargs a b c d e f g h i j k l m n o let manyargs_tail2 a b = print_string "tail2:\n"; manyargs a b a b a b a b a b a b a b a let manyargs_tail3 a b c d e f g h i j k l m n o = print_string "tail3:\n"; print_string "o = "; print_int o; print_newline(); print_string "---"; print_newline() let _ = manyargs 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15; manyargs_tail1 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15; manyargs_tail2 0 1; manyargs_tail3 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 external manyargs_ext: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "manyargs_argv" "manyargs" let _ = print_string "external:\n"; flush stdout; manyargs_ext 1 2 3 4 5 6 7 8 9 10 11 mingw-ocaml/ocaml/testsuite/tests/lib-num-2/0000755000175000017500000000000012124403241020353 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-num-2/pi_num.ml0000644000175000017500000000313012124403241022171 0ustar tootstoots (* Pi digits computed with the sreaming algorithm given on pages 4, 6 & 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy Gibbons, August 2004. *) open Printf;; open Num;; let zero = num_of_int 0 and one = num_of_int 1 and three = num_of_int 3 and four = num_of_int 4 and ten = num_of_int 10 and neg_ten = num_of_int(-10) ;; (* Linear Fractional Transformation *) module LFT = struct let floor_ev (q, r, s, t) x = quo_num (q */ x +/ r) (s */ x +/ t);; let unit = (one, zero, zero, one);; let comp (q, r, s, t) (q', r', s', t') = (q */ q' +/ r */ s', q */ r' +/ r */ t', s */ q' +/ t */ s', s */ r' +/ t */ t') ;; end ;; let next z = LFT.floor_ev z three and safe z n = (n =/ LFT.floor_ev z four) and prod z n = LFT.comp (ten, neg_ten */ n, zero, one) z and cons z k = let den = 2 * k + 1 in LFT.comp z (num_of_int k, num_of_int(2 * den), zero, num_of_int den) ;; let rec digit k z n row col = if n > 0 then let y = next z in if safe z y then if col = 10 then ( let row = row + 10 in printf "\t:%i\n%s" row (string_of_num y); digit k (prod z y) (n-1) row 1 ) else ( print_string(string_of_num y); digit k (prod z y) (n-1) row (col + 1) ) else digit (k + 1) (cons z k) n row col else printf "%*s\t:%i\n" (10 - col) "" (row + col) ;; let digits n = digit 1 LFT.unit n 0 0 ;; let usage () = prerr_endline "Usage: pi_num "; exit 2 ;; let main () = let args = Sys.argv in if Array.length args <> 2 then usage () else digits (int_of_string Sys.argv.(1)) ;; main () ;; mingw-ocaml/ocaml/testsuite/tests/lib-num-2/pi_big_int.ml0000644000175000017500000000336612124403241023020 0ustar tootstoots(* Pi digits computed with the sreaming algorithm given on pages 4, 6 & 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy Gibbons, August 2004. *) open Printf;; open Big_int;; let ( !$ ) = Big_int.big_int_of_int and ( +$ ) = Big_int.add_big_int and ( *$ ) = Big_int.mult_big_int and ( =$ ) = Big_int.eq_big_int ;; let zero = Big_int.zero_big_int and one = Big_int.unit_big_int and three = !$ 3 and four = !$ 4 and ten = !$ 10 and neg_ten = !$(-10) ;; (* Linear Fractional (aka M=F6bius) Transformations *) module LFT = struct let floor_ev (q, r, s, t) x = div_big_int (q *$ x +$ r) (s *$ x +$ t);; let unit = (one, zero, zero, one);; let comp (q, r, s, t) (q', r', s', t') = (q *$ q' +$ r *$ s', q *$ r' +$ r *$ t', s *$ q' +$ t *$ s', s *$ r' +$ t *$ t') ;; end ;; let next z = LFT.floor_ev z three and safe z n = (n =$ LFT.floor_ev z four) and prod z n = LFT.comp (ten, neg_ten *$ n, zero, one) z and cons z k = let den = 2 * k + 1 in LFT.comp z (!$ k, !$(2 * den), zero, !$ den) ;; let rec digit k z n row col = if n > 0 then let y = next z in if safe z y then if col = 10 then ( let row = row + 10 in printf "\t:%i\n%s" row (string_of_big_int y); digit k (prod z y) (n - 1) row 1 ) else ( print_string(string_of_big_int y); digit k (prod z y) (n - 1) row (col + 1) ) else digit (k + 1) (cons z k) n row col else printf "%*s\t:%i\n" (10 - col) "" (row + col) ;; let digits n = digit 1 LFT.unit n 0 0 ;; let usage () = prerr_endline "Usage: pi_big_int "; exit 2 ;; let main () = let args = Sys.argv in if Array.length args <> 2 then usage () else digits (int_of_string Sys.argv.(1)) ;; main () ;; mingw-ocaml/ocaml/testsuite/tests/lib-num-2/Makefile0000644000175000017500000000021312124403241022007 0ustar tootstootsBASEDIR=../.. LIBRARIES=nums PROGRAM_ARGS=1000 include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-num-2/pi_big_int.reference0000644000175000017500000000307012124403241024336 0ustar tootstoots3141592653 :10 5897932384 :20 6264338327 :30 9502884197 :40 1693993751 :50 0582097494 :60 4592307816 :70 4062862089 :80 9862803482 :90 5342117067 :100 9821480865 :110 1328230664 :120 7093844609 :130 5505822317 :140 2535940812 :150 8481117450 :160 2841027019 :170 3852110555 :180 9644622948 :190 9549303819 :200 6442881097 :210 5665933446 :220 1284756482 :230 3378678316 :240 5271201909 :250 1456485669 :260 2346034861 :270 0454326648 :280 2133936072 :290 6024914127 :300 3724587006 :310 6063155881 :320 7488152092 :330 0962829254 :340 0917153643 :350 6789259036 :360 0011330530 :370 5488204665 :380 2138414695 :390 1941511609 :400 4330572703 :410 6575959195 :420 3092186117 :430 3819326117 :440 9310511854 :450 8074462379 :460 9627495673 :470 5188575272 :480 4891227938 :490 1830119491 :500 2983367336 :510 2440656643 :520 0860213949 :530 4639522473 :540 7190702179 :550 8609437027 :560 7053921717 :570 6293176752 :580 3846748184 :590 6766940513 :600 2000568127 :610 1452635608 :620 2778577134 :630 2757789609 :640 1736371787 :650 2146844090 :660 1224953430 :670 1465495853 :680 7105079227 :690 9689258923 :700 5420199561 :710 1212902196 :720 0864034418 :730 1598136297 :740 7477130996 :750 0518707211 :760 3499999983 :770 7297804995 :780 1059731732 :790 8160963185 :800 9502445945 :810 5346908302 :820 6425223082 :830 5334468503 :840 5261931188 :850 1710100031 :860 3783875288 :870 6587533208 :880 3814206171 :890 7766914730 :900 3598253490 :910 4287554687 :920 3115956286 :930 3882353787 :940 5937519577 :950 8185778053 :960 2171226806 :970 6130019278 :980 7661119590 :990 9216420198 :1000 mingw-ocaml/ocaml/testsuite/tests/lib-num-2/pi_num.reference0000644000175000017500000000307012124403241023522 0ustar tootstoots3141592653 :10 5897932384 :20 6264338327 :30 9502884197 :40 1693993751 :50 0582097494 :60 4592307816 :70 4062862089 :80 9862803482 :90 5342117067 :100 9821480865 :110 1328230664 :120 7093844609 :130 5505822317 :140 2535940812 :150 8481117450 :160 2841027019 :170 3852110555 :180 9644622948 :190 9549303819 :200 6442881097 :210 5665933446 :220 1284756482 :230 3378678316 :240 5271201909 :250 1456485669 :260 2346034861 :270 0454326648 :280 2133936072 :290 6024914127 :300 3724587006 :310 6063155881 :320 7488152092 :330 0962829254 :340 0917153643 :350 6789259036 :360 0011330530 :370 5488204665 :380 2138414695 :390 1941511609 :400 4330572703 :410 6575959195 :420 3092186117 :430 3819326117 :440 9310511854 :450 8074462379 :460 9627495673 :470 5188575272 :480 4891227938 :490 1830119491 :500 2983367336 :510 2440656643 :520 0860213949 :530 4639522473 :540 7190702179 :550 8609437027 :560 7053921717 :570 6293176752 :580 3846748184 :590 6766940513 :600 2000568127 :610 1452635608 :620 2778577134 :630 2757789609 :640 1736371787 :650 2146844090 :660 1224953430 :670 1465495853 :680 7105079227 :690 9689258923 :700 5420199561 :710 1212902196 :720 0864034418 :730 1598136297 :740 7477130996 :750 0518707211 :760 3499999983 :770 7297804995 :780 1059731732 :790 8160963185 :800 9502445945 :810 5346908302 :820 6425223082 :830 5334468503 :840 5261931188 :850 1710100031 :860 3783875288 :870 6587533208 :880 3814206171 :890 7766914730 :900 3598253490 :910 4287554687 :920 3115956286 :930 3882353787 :940 5937519577 :950 8185778053 :960 2171226806 :970 6130019278 :980 7661119590 :990 9216420198 :1000 mingw-ocaml/ocaml/testsuite/tests/typing-typeparam/0000755000175000017500000000000012124403241022163 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-typeparam/newtype.ml0000644000175000017500000000162612124403241024215 0ustar tootstootslet property (type t) () = let module M = struct exception E of t end in (fun x -> M.E x), (function M.E x -> Some x | _ -> None) ;; let () = let (int_inj, int_proj) = property () in let (string_inj, string_proj) = property () in let i = int_inj 3 in let s = string_inj "abc" in Printf.printf "%b\n%!" (int_proj i = None); Printf.printf "%b\n%!" (int_proj s = None); Printf.printf "%b\n%!" (string_proj i = None); Printf.printf "%b\n%!" (string_proj s = None) ;; let sort_uniq (type s) cmp l = let module S = Set.Make(struct type t = s let compare = cmp end) in S.elements (List.fold_right S.add l S.empty) ;; let () = print_endline (String.concat "," (sort_uniq compare [ "abc"; "xyz"; "abc" ])) ;; let f x (type a) (y : a) = (x = y);; (* Fails *) class ['a] c = object (self) method m : 'a -> 'a = fun x -> x method n : 'a -> 'a = fun (type g) (x:g) -> self#m x end;; (* Fails *) mingw-ocaml/ocaml/testsuite/tests/typing-typeparam/Makefile0000644000175000017500000000015212124403241023621 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-typeparam/newtype.ml.reference0000644000175000017500000000132112124403241026142 0ustar tootstoots # val property : unit -> ('a -> exn) * (exn -> 'a option) = # false true true false # val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list = # abc,xyz # Characters 33-34: let f x (type a) (y : a) = (x = y);; (* Fails *) ^ Error: This expression has type a but an expression was expected of type a The type constructor a would escape its scope # Characters 117-118: method n : 'a -> 'a = fun (type g) (x:g) -> self#m x ^ Error: This expression has type g but an expression was expected of type g The type constructor g would escape its scope # mingw-ocaml/ocaml/testsuite/tests/typing-fstclassmod/0000755000175000017500000000000012124403241022503 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-fstclassmod/Makefile0000644000175000017500000000023312124403241024141 0ustar tootstootsBASEDIR=../.. #MODULES= MAIN_MODULE=fstclassmod ADD_COMPFLAGS=-w a include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-fstclassmod/fstclassmod.reference0000644000175000017500000000007112124403241026703 0ustar tootstootsabc/def/xyz xyz/def/abc 1 2 XXXXXXXX 10 (123,("A",456)) mingw-ocaml/ocaml/testsuite/tests/typing-fstclassmod/fstclassmod.ml0000644000175000017500000000613212124403241025361 0ustar tootstoots(* Example of algorithm parametrized with modules *) let sort (type s) set l = let module Set = (val set : Set.S with type elt = s) in Set.elements (List.fold_right Set.add l Set.empty) let make_set (type s) cmp = let module S = Set.Make(struct type t = s let compare = cmp end) in (module S : Set.S with type elt = s) let both l = List.map (fun set -> sort set l) [ make_set compare; make_set (fun x y -> compare y x) ] let () = print_endline (String.concat " " (List.map (String.concat "/") (both ["abc";"xyz";"def"]))) (* Hiding the internal representation *) module type S = sig type t val to_string: t -> string val apply: t -> t val x: t end let create (type s) to_string apply x = let module M = struct type t = s let to_string = to_string let apply = apply let x = x end in (module M : S with type t = s) let forget (type s) x = let module M = (val x : S with type t = s) in (module M : S) let print x = let module M = (val x : S) in print_endline (M.to_string M.x) let apply x = let module M = (val x : S) in let module N = struct include M let x = apply x end in (module N : S) let () = let int = forget (create string_of_int succ 0) in let str = forget (create (fun s -> s) (fun s -> s ^ s) "X") in List.iter print (List.map apply [int; apply int; apply (apply str)]) (* Existential types + type equality witnesses -> pseudo GADT *) module TypEq : sig type ('a, 'b) t val apply: ('a, 'b) t -> 'a -> 'b val refl: ('a, 'a) t val sym: ('a, 'b) t -> ('b, 'a) t end = struct type ('a, 'b) t = unit let apply _ = Obj.magic let refl = () let sym () = () end module rec Typ : sig module type PAIR = sig type t type t1 type t2 val eq: (t, t1 * t2) TypEq.t val t1: t1 Typ.typ val t2: t2 Typ.typ end type 'a typ = | Int of ('a, int) TypEq.t | String of ('a, string) TypEq.t | Pair of (module PAIR with type t = 'a) end = struct module type PAIR = sig type t type t1 type t2 val eq: (t, t1 * t2) TypEq.t val t1: t1 Typ.typ val t2: t2 Typ.typ end type 'a typ = | Int of ('a, int) TypEq.t | String of ('a, string) TypEq.t | Pair of (module PAIR with type t = 'a) end open Typ let int = Int TypEq.refl let str = String TypEq.refl let pair (type s1) (type s2) t1 t2 = let module P = struct type t = s1 * s2 type t1 = s1 type t2 = s2 let eq = TypEq.refl let t1 = t1 let t2 = t2 end in let pair = (module P : PAIR with type t = s1 * s2) in Pair pair module rec Print : sig val to_string: 'a Typ.typ -> 'a -> string end = struct let to_string (type s) t x = match t with | Int eq -> string_of_int (TypEq.apply eq x) | String eq -> Printf.sprintf "%S" (TypEq.apply eq x) | Pair p -> let module P = (val p : PAIR with type t = s) in let (x1, x2) = TypEq.apply P.eq x in Printf.sprintf "(%s,%s)" (Print.to_string P.t1 x1) (Print.to_string P.t2 x2) end let () = print_endline (Print.to_string int 10); print_endline (Print.to_string (pair int (pair str int)) (123, ("A", 456))) mingw-ocaml/ocaml/testsuite/tests/typing-poly-bugs/0000755000175000017500000000000012124403241022102 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-poly-bugs/pr5322_ok.ml0000644000175000017500000000030112124403241024054 0ustar tootstootstype 'par t = 'par module M : sig val x : end = struct let x : = Obj.magic () end let ident v = v class alias = object method alias : 'a . 'a t -> 'a = ident end mingw-ocaml/ocaml/testsuite/tests/typing-poly-bugs/Makefile0000644000175000017500000000014712124403241023544 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.okbad include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/letrec/0000755000175000017500000000000012124403241020127 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/letrec/lists.reference0000644000175000017500000000000012124403241023133 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/letrec/evaluation_order_3.ml0000644000175000017500000000042312124403241024244 0ustar tootstootstype t = { x : t; y : t } let p = print_endline let test = let rec x = p "x"; { x = (p "x_x"; x); y = (p "x_y"; y) } and y = p "y"; { x = (p "y_x"; x); y = (p "y_y"; y) } in assert (x.x == x); assert (x.y == y); assert (y.x == x); assert (y.y == y); () mingw-ocaml/ocaml/testsuite/tests/letrec/Makefile0000644000175000017500000000015212124403241021565 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/letrec/evaluation_order_1.reference0000644000175000017500000000000612124403241025565 0ustar tootstootsy x z mingw-ocaml/ocaml/testsuite/tests/letrec/evaluation_order_3.reference0000644000175000017500000000002412124403241025567 0ustar tootstootsx x_y x_x y y_y y_x mingw-ocaml/ocaml/testsuite/tests/letrec/mixing_value_closures_2.ml0000644000175000017500000000027112124403241025310 0ustar tootstoots(* a polymorphic variant of test3.ml; found a real bug once *) let test = let rec x = `A f and f = function | 0 -> 2 | n -> match x with `A g -> g 0 in assert (f 1 = 2) mingw-ocaml/ocaml/testsuite/tests/letrec/class_2.reference0000644000175000017500000000000412124403241023327 0ustar tootstootsf g mingw-ocaml/ocaml/testsuite/tests/letrec/class_1.reference0000644000175000017500000000000012124403241023322 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/letrec/lists.ml0000644000175000017500000000040712124403241021620 0ustar tootstoots(* a test with lists, because cyclic lists are fun *) let test = let rec li = 0::1::2::3::4::5::6::7::8::9::li in match li with | 0::1::2::3::4::5::6::7::8::9:: 0::1::2::3::4::5::6::7::8::9::li' -> assert (li == li') | _ -> assert false mingw-ocaml/ocaml/testsuite/tests/letrec/backreferences.reference0000644000175000017500000000000012124403241024737 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/letrec/evaluation_order_2.ml0000644000175000017500000000077612124403241024256 0ustar tootstoots(* A variant of evaluation_order_1.ml where the side-effects are inside the blocks. Note that this changes the evaluation order, as y is considered recursive. *) type tree = Tree of tree list let test = let rec x = (Tree [(print_endline "x"; y); z]) and y = Tree (print_endline "y"; []) and z = Tree (print_endline "z"; [x]) in match (x, y, z) with | (Tree [y1; z1], Tree[], Tree[x1]) -> assert (y1 == y); assert (z1 == z); assert (x1 == x) | _ -> assert false mingw-ocaml/ocaml/testsuite/tests/letrec/float_block_2.reference0000644000175000017500000000000012124403241024475 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/letrec/float_block_2.ml0000644000175000017500000000033312124403241023160 0ustar tootstoots(* a bug in cmmgen.ml provokes a segfault in certain natively compiled letrec-bindings involving float arrays *) let test = let rec x = [| y; y |] and y = 1. in assert (x = [| 1.; 1. |]); assert (y = 1.); () mingw-ocaml/ocaml/testsuite/tests/letrec/mixing_value_closures_1.reference0000644000175000017500000000000012124403241026623 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/letrec/backreferences.ml0000644000175000017500000000076712124403241023435 0ustar tootstoots(* testing backreferences; some compilation scheme may handle differently recursive references to a mutually-recursive RHS depending on whether it is before or after in the bindings list *) type t = { x : t; y : t; z : t } let test = let rec x = { x; y; z } and y = { x; y; z } and z = { x; y; z } in List.iter (fun (f, t_ref) -> List.iter (fun t -> assert (f t == t_ref)) [x; y; z] ) [ (fun t -> t.x), x; (fun t -> t.y), y; (fun t -> t.z), z; ] mingw-ocaml/ocaml/testsuite/tests/letrec/float_block_1.reference0000644000175000017500000000000412124403241024500 0ustar tootstootsx y mingw-ocaml/ocaml/testsuite/tests/letrec/mixing_value_closures_1.ml0000644000175000017500000000032612124403241025310 0ustar tootstoots(* mixing values and closures may exercise interesting code paths *) type t = A of (int -> int) let test = let rec x = A f and f = function | 0 -> 2 | n -> match x with A g -> g 0 in assert (f 1 = 2) mingw-ocaml/ocaml/testsuite/tests/letrec/class_2.ml0000644000175000017500000000037312124403241022012 0ustar tootstoots(* class expressions may also contain local recursive bindings *) class test = let rec f = print_endline "f"; fun x -> g x and g = print_endline "g"; fun x -> f x in object method f : 'a 'b. 'a -> 'b = f method g : 'a 'b. 'a -> 'b = g end mingw-ocaml/ocaml/testsuite/tests/letrec/mixing_value_closures_2.reference0000644000175000017500000000000012124403241026624 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/letrec/class_1.ml0000644000175000017500000000014112124403241022002 0ustar tootstoots(* class expression are compiled to recursive bindings *) class test = object method x = 1 end mingw-ocaml/ocaml/testsuite/tests/letrec/float_block_1.ml0000644000175000017500000000051112124403241023155 0ustar tootstoots(* a bug in cmmgen.ml provokes a change in compilation order between ocamlc and ocamlopt in certain letrec-bindings involving float arrays *) let test = let rec x = print_endline "x"; [| 1; 2; 3 |] and y = print_endline "y"; [| 1.; 2.; 3. |] in assert (x = [| 1; 2; 3 |]); assert (y = [| 1.; 2.; 3. |]); () mingw-ocaml/ocaml/testsuite/tests/letrec/evaluation_order_2.reference0000644000175000017500000000000612124403241025566 0ustar tootstootsx y z mingw-ocaml/ocaml/testsuite/tests/letrec/mutual_functions.reference0000644000175000017500000000000012124403241025374 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/letrec/evaluation_order_1.ml0000644000175000017500000000103312124403241024240 0ustar tootstoots(* test evaluation order 'y' is translated into a constant, and is therefore considered non-recursive. With the current letrec compilation method, it should be evaluated before x and z. *) type tree = Tree of tree list let test = let rec x = (print_endline "x"; Tree [y; z]) and y = (print_endline "y"; Tree []) and z = (print_endline "z"; Tree [x]) in match (x, y, z) with | (Tree [y1; z1], Tree[], Tree[x1]) -> assert (y1 == y); assert (z1 == z); assert (x1 == x) | _ -> assert false mingw-ocaml/ocaml/testsuite/tests/letrec/mutual_functions.ml0000644000175000017500000000044312124403241024061 0ustar tootstoots(* a simple test with mutually recursive functions *) let test = let rec even = function | 0 -> true | n -> odd (n - 1) and odd = function | 0 -> false | n -> even (n - 1) in List.iter (fun i -> assert (even i <> odd i && even i = (i mod 2 = 0))) [0;1;2;3;4;5;6] mingw-ocaml/ocaml/testsuite/tests/lib-threads/0000755000175000017500000000000012124403241021047 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-threads/test1.ml0000644000175000017500000000263712124403241022451 0ustar tootstoots(* Classic producer-consumer *) type 'a prodcons = { buffer: 'a array; lock: Mutex.t; mutable readpos: int; mutable writepos: int; notempty: Condition.t; notfull: Condition.t } let create size init = { buffer = Array.create size init; lock = Mutex.create(); readpos = 0; writepos = 0; notempty = Condition.create(); notfull = Condition.create() } let output_lock = Mutex.create() let put p data = Mutex.lock p.lock; while (p.writepos + 1) mod Array.length p.buffer = p.readpos do Condition.wait p.notfull p.lock done; p.buffer.(p.writepos) <- data; p.writepos <- (p.writepos + 1) mod Array.length p.buffer; Condition.signal p.notempty; Mutex.unlock p.lock let get p = Mutex.lock p.lock; while p.writepos = p.readpos do Condition.wait p.notempty p.lock done; let data = p.buffer.(p.readpos) in p.readpos <- (p.readpos + 1) mod Array.length p.buffer; Condition.signal p.notfull; Mutex.unlock p.lock; data (* Test *) let buff = create 20 0 let rec produce n = Mutex.lock output_lock; print_int n; print_string "-->"; print_newline(); Mutex.unlock output_lock; put buff n; if n < 10000 then produce (n+1) let rec consume () = let n = get buff in Mutex.lock output_lock; print_string "-->"; print_int n; print_newline(); Mutex.unlock output_lock; if n < 10000 then consume () let t1 = Thread.create produce 0 let _ = consume () ;; mingw-ocaml/ocaml/testsuite/tests/lib-threads/.ignore0000644000175000017500000000000612124403241022327 0ustar tootstoots*.byt mingw-ocaml/ocaml/testsuite/tests/lib-threads/testsignal2.ml0000644000175000017500000000060712124403241023643 0ustar tootstootslet print_message delay c = while true do print_char c; flush stdout; Thread.delay delay done let _ = Thread.sigmask Unix.SIG_BLOCK [Sys.sigint; Sys.sigterm]; let th1 = Thread.create (print_message 0.6666666666) 'a' in let th2 = Thread.create (print_message 1.0) 'b' in let s = Thread.wait_signal [Sys.sigint; Sys.sigterm] in Printf.printf "Got signal %d, exiting...\n" s mingw-ocaml/ocaml/testsuite/tests/lib-threads/torture.data0000644000175000017500000000001412124403241023401 0ustar tootstootsabc def ghi mingw-ocaml/ocaml/testsuite/tests/lib-threads/torture.runner0000644000175000017500000000007712124403241024012 0ustar tootstoots./program < torture.data > torture.result 2> /dev/null || true mingw-ocaml/ocaml/testsuite/tests/lib-threads/testexit.reference0000644000175000017500000000024512124403241024601 0ustar tootstootsA exiting A: 1 A: 2 A: 3 A: 4 B exiting B: 1 B: 2 B: 3 B: 4 B: 5 B: 6 B: 7 C exiting C: 1 C: 10 C: 2 C: 3 C: 4 C: 5 C: 6 C: 7 C: 8 C: 9 Main exiting Main: 1 Main: 2 mingw-ocaml/ocaml/testsuite/tests/lib-threads/test5.reference0000644000175000017500000000004412124403241023771 0ustar tootstootsA: hello A: world B: hello B: world mingw-ocaml/ocaml/testsuite/tests/lib-threads/token1.ml0000644000175000017500000000173212124403241022605 0ustar tootstoots(* Performance test for mutexes and conditions *) let mut = Mutex.create() let niter = ref 0 let token = ref 0 let process (n, conds, nprocs) = while true do Mutex.lock mut; while !token <> n do (* Printf.printf "Thread %d waiting (token = %d)\n" n !token; *) Condition.wait conds.(n) mut done; (* Printf.printf "Thread %d got token %d\n" n !token; *) incr token; if !token >= nprocs then token := 0; if n = 0 then begin decr niter; if !niter <= 0 then exit 0 end; Condition.signal conds.(!token); Mutex.unlock mut done let main() = let nprocs = try int_of_string Sys.argv.(1) with _ -> 100 in let iter = try int_of_string Sys.argv.(2) with _ -> 1000 in let conds = Array.create nprocs (Condition.create()) in for i = 1 to nprocs - 1 do conds.(i) <- Condition.create() done; niter := iter; for i = 0 to nprocs - 1 do Thread.create process (i, conds, nprocs) done; Thread.delay 3600. let _ = main() mingw-ocaml/ocaml/testsuite/tests/lib-threads/testsignal.ml0000644000175000017500000000051012124403241023552 0ustar tootstootslet sighandler _ = print_string "Got ctrl-C, exiting..."; print_newline(); exit 0 let print_message delay c = while true do print_char c; flush stdout; Thread.delay delay done let _ = Sys.signal Sys.sigint (Sys.Signal_handle sighandler); Thread.create (print_message 0.6666666666) 'a'; print_message 1.0 'b' mingw-ocaml/ocaml/testsuite/tests/lib-threads/test7.ml0000644000175000017500000000110212124403241022441 0ustar tootstootsopen Event let add_ch = new_channel() let sub_ch = new_channel() let read_ch = new_channel() let rec accu n = select [ wrap (receive add_ch) (fun x -> accu (n+x)); wrap (receive sub_ch) (fun x -> accu (n-x)); wrap (send read_ch n) (fun () -> accu n) ] let rec sender chan value = sync(send chan value); sender chan value let read () = print_int(sync(receive read_ch)); print_newline() let main () = Thread.create accu 0; Thread.create (sender add_ch) 1; Thread.create (sender sub_ch) 1; while true do read() done let _ = Printexc.catch main () mingw-ocaml/ocaml/testsuite/tests/lib-threads/test4.reference0000644000175000017500000000003412124403241023767 0ustar tootstoots317811 >> abc >> def >> ghi mingw-ocaml/ocaml/testsuite/tests/lib-threads/token2.ml0000644000175000017500000000200212124403241022575 0ustar tootstoots(* Performance test for I/O scheduling *) let mut = Mutex.create() let niter = ref 0 let token = ref 0 let process (n, ins, outs, nprocs) = let buf = String.create 1 in while true do Unix.read ins.(n) buf 0 1; (* Printf.printf "Thread %d got the token\n" n; *) if n = 0 then begin decr niter; if !niter <= 0 then exit 0 end; let next = if n + 1 >= nprocs then 0 else n + 1 in (* Printf.printf "Thread %d sending token to thread %d\n" n next; *) Unix.write outs.(next) buf 0 1 done let main() = let nprocs = try int_of_string Sys.argv.(1) with _ -> 100 in let iter = try int_of_string Sys.argv.(2) with _ -> 1000 in let ins = Array.create nprocs Unix.stdin in let outs = Array.create nprocs Unix.stdout in for n = 0 to nprocs - 1 do let (i, o) = Unix.pipe() in ins.(n) <- i; outs.(n) <- o done; niter := iter; for i = 0 to nprocs - 1 do Thread.create process (i, ins, outs, nprocs) done; Unix.write outs.(0) "X" 0 1; Thread.delay 3600. let _ = main() mingw-ocaml/ocaml/testsuite/tests/lib-threads/test2.checker0000644000175000017500000000005212124403241023433 0ustar tootstootssed -e 1q test2.result | grep -q '^[ab]*' mingw-ocaml/ocaml/testsuite/tests/lib-threads/testsignal2.checker0000644000175000017500000000006012124403241024630 0ustar tootstootssed -e 1q testsignal2.result | grep -q '^[ab]*' mingw-ocaml/ocaml/testsuite/tests/lib-threads/test4.data0000644000175000017500000000001412124403241022740 0ustar tootstootsabc def ghi mingw-ocaml/ocaml/testsuite/tests/lib-threads/torture.reference0000644000175000017500000000003712124403241024433 0ustar tootstoots> >>> abc > >>> def > >>> ghi >mingw-ocaml/ocaml/testsuite/tests/lib-threads/test3.checker0000644000175000017500000000005212124403241023434 0ustar tootstootssed -e 1q test3.result | grep -q '^[ab]*' mingw-ocaml/ocaml/testsuite/tests/lib-threads/testio.ml0000644000175000017500000000657712124403241022727 0ustar tootstoots(* Test a file copy function *) let test msg producer consumer src dst = print_string msg; print_newline(); let ic = open_in_bin src in let oc = open_out_bin dst in let (in_fd, out_fd) = Unix.pipe() in let ipipe = Unix.in_channel_of_descr in_fd in let opipe = Unix.out_channel_of_descr out_fd in let prod = Thread.create producer (ic, opipe) in let cons = Thread.create consumer (ipipe, oc) in Thread.join prod; Thread.join cons; if Unix.system ("cmp " ^ src ^ " " ^ dst) = Unix.WEXITED 0 then print_string "passed" else print_string "FAILED"; print_newline() (* File copy with constant-sized chunks *) let copy_file sz (ic, oc) = let buffer = String.create sz in let rec copy () = let n = input ic buffer 0 sz in if n = 0 then () else begin output oc buffer 0 n; copy () end in copy(); close_in ic; close_out oc (* File copy with random-sized chunks *) let copy_random sz (ic, oc) = let buffer = String.create sz in let rec copy () = let s = 1 + Random.int sz in let n = input ic buffer 0 s in if n = 0 then () else begin output oc buffer 0 n; copy () end in copy(); close_in ic; close_out oc (* File copy line per line *) let copy_line (ic, oc) = try while true do output_string oc (input_line ic); output_char oc '\n' done with End_of_file -> close_in ic; close_out oc (* Create long lines of text *) let make_lines ofile = let oc = open_out ofile in for i = 1 to 256 do output_string oc (String.make (i*16) '.'); output_char oc '\n' done; close_out oc (* Test input_line on truncated lines *) let test_trunc_line ofile = print_string "truncated line"; print_newline(); let oc = open_out ofile in output_string oc "A line without newline!"; close_out oc; try let ic = open_in ofile in let s = input_line ic in close_in ic; if s = "A line without newline!" then print_string "passed" else print_string "FAILED"; print_newline() with End_of_file -> print_string "FAILED"; print_newline() (* The test *) let main() = let ifile = try Sys.argv.(1) with _ -> "testio.ml" in let ofile = Filename.temp_file "testio" "" in test "256-byte chunks, 256-byte chunks" (copy_file 256) (copy_file 256) ifile ofile; test "4096-byte chunks, 4096-byte chunks" (copy_file 4096) (copy_file 4096) ifile ofile; test "65536-byte chunks, 65536-byte chunks" (copy_file 65536) (copy_file 65536) ifile ofile; test "256-byte chunks, 4096-byte chunks" (copy_file 256) (copy_file 4096) ifile ofile; test "4096-byte chunks, 256-byte chunks" (copy_file 4096) (copy_file 256) ifile ofile; test "4096-byte chunks, 65536-byte chunks" (copy_file 4096) (copy_file 65536) ifile ofile; test "263-byte chunks, 4011-byte chunks" (copy_file 263) (copy_file 4011) ifile ofile; test "613-byte chunks, 1027-byte chunks" (copy_file 613) (copy_file 1027) ifile ofile; test "0...8192 byte chunks" (copy_random 8192) (copy_random 8192) ifile ofile; test "line per line, short lines" copy_line copy_line "/etc/hosts" ofile; let linesfile = Filename.temp_file "lines" "" in make_lines linesfile; test "line per line, short and long lines" copy_line copy_line linesfile ofile; test_trunc_line ofile; Sys.remove linesfile; Sys.remove ofile; exit 0 let _ = Unix.handle_unix_error main (); exit 0 mingw-ocaml/ocaml/testsuite/tests/lib-threads/Makefile0000644000175000017500000000022712124403241022510 0ustar tootstootsBASEDIR=../.. LIBRARIES=unix threads ADD_COMPFLAGS=-thread include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-threads/test9.ml0000644000175000017500000000111212124403241022444 0ustar tootstootsopen Event type 'a swap_chan = ('a * 'a channel) channel let swap msg_out ch = guard (fun () -> let ic = new_channel() in choose [ wrap (receive ch) (fun (msg_in, oc) -> sync (send oc msg_out); msg_in); wrap (send ch (msg_out, ic)) (fun () -> sync (receive ic)) ]) let ch = new_channel() let f () = let res = sync (swap "F" ch) in print_string "f "; print_string res; print_newline() let g () = let res = sync (swap "G" ch) in print_string "g "; print_string res; print_newline() let _ = let id = Thread.create f () in g (); Thread.join id mingw-ocaml/ocaml/testsuite/tests/lib-threads/test8.reference0000644000175000017500000000001212124403241023767 0ustar tootstoots3 un deux mingw-ocaml/ocaml/testsuite/tests/lib-threads/test6.reference0000644000175000017500000000002212124403241023766 0ustar tootstootsA: world B: hello mingw-ocaml/ocaml/testsuite/tests/lib-threads/test8.ml0000644000175000017500000000207612124403241022455 0ustar tootstootsopen Event type 'a buffer_channel = { input: 'a channel; output: 'a channel } let new_buffer_channel() = let ic = new_channel() in let oc = new_channel() in let buff = Queue.create() in let rec buffer_process front rear = match (front, rear) with ([], []) -> buffer_process [sync(receive ic)] [] | (hd::tl, _) -> select [ wrap (receive ic) (fun x -> buffer_process front (x::rear)); wrap (send oc hd) (fun () -> buffer_process tl rear) ] | ([], _) -> buffer_process (List.rev rear) [] in Thread.create (buffer_process []) []; { input = ic; output = oc } let buffer_send bc data = sync(send bc.input data) let buffer_receive bc = receive bc.output (* Test *) let box = new_buffer_channel() let ch = new_channel() let f () = buffer_send box "un"; buffer_send box "deux"; sync (send ch 3) let g () = print_int (sync(receive ch)); print_newline(); print_string (sync(buffer_receive box)); print_newline(); print_string (sync(buffer_receive box)); print_newline() let _ = Thread.create f (); g() mingw-ocaml/ocaml/testsuite/tests/lib-threads/testA.checker0000644000175000017500000000006712124403241023460 0ustar tootstootsLC_ALL=C sort testA.result | diff -q testA.reference - mingw-ocaml/ocaml/testsuite/tests/lib-threads/sieve.ml0000644000175000017500000000135012124403241022513 0ustar tootstootsopen Printf open Thread let rec integers n ch = Event.sync (Event.send ch n); integers (n+1) ch let rec sieve n chin chout = let m = Event.sync (Event.receive chin) in if m mod n = 0 then sieve n chin chout else Event.sync (Event.send chout m); sieve n chin chout let rec print_primes ch max = let n = Event.sync (Event.receive ch) in if n > max then () else begin printf "%d\n" n; flush stdout; let ch_after_n = Event.new_channel () in Thread.create (sieve n ch) ch_after_n; print_primes ch_after_n max end let go max = let ch = Event.new_channel () in Thread.create (integers 2) ch; print_primes ch max;; let _ = go 1000 ;; mingw-ocaml/ocaml/testsuite/tests/lib-threads/test6.ml0000644000175000017500000000041312124403241022444 0ustar tootstootsopen Event let ch = (new_channel() : string channel) let rec f tag msg = select [ send ch msg; wrap (receive ch) (fun x -> print_string(tag ^ ": " ^ x); print_newline()) ]; f tag msg let _ = Thread.create (f "A") "hello"; f "B" "world"; exit 0 mingw-ocaml/ocaml/testsuite/tests/lib-threads/test1.checker0000644000175000017500000000006712124403241023440 0ustar tootstootsLC_ALL=C sort test1.result | diff -q test1.reference - mingw-ocaml/ocaml/testsuite/tests/lib-threads/test1.reference0000644000175000017500000046414612124403241024006 0ustar tootstoots-->0 -->1 -->10 -->100 -->1000 -->10000 -->1001 -->1002 -->1003 -->1004 -->1005 -->1006 -->1007 -->1008 -->1009 -->101 -->1010 -->1011 -->1012 -->1013 -->1014 -->1015 -->1016 -->1017 -->1018 -->1019 -->102 -->1020 -->1021 -->1022 -->1023 -->1024 -->1025 -->1026 -->1027 -->1028 -->1029 -->103 -->1030 -->1031 -->1032 -->1033 -->1034 -->1035 -->1036 -->1037 -->1038 -->1039 -->104 -->1040 -->1041 -->1042 -->1043 -->1044 -->1045 -->1046 -->1047 -->1048 -->1049 -->105 -->1050 -->1051 -->1052 -->1053 -->1054 -->1055 -->1056 -->1057 -->1058 -->1059 -->106 -->1060 -->1061 -->1062 -->1063 -->1064 -->1065 -->1066 -->1067 -->1068 -->1069 -->107 -->1070 -->1071 -->1072 -->1073 -->1074 -->1075 -->1076 -->1077 -->1078 -->1079 -->108 -->1080 -->1081 -->1082 -->1083 -->1084 -->1085 -->1086 -->1087 -->1088 -->1089 -->109 -->1090 -->1091 -->1092 -->1093 -->1094 -->1095 -->1096 -->1097 -->1098 -->1099 -->11 -->110 -->1100 -->1101 -->1102 -->1103 -->1104 -->1105 -->1106 -->1107 -->1108 -->1109 -->111 -->1110 -->1111 -->1112 -->1113 -->1114 -->1115 -->1116 -->1117 -->1118 -->1119 -->112 -->1120 -->1121 -->1122 -->1123 -->1124 -->1125 -->1126 -->1127 -->1128 -->1129 -->113 -->1130 -->1131 -->1132 -->1133 -->1134 -->1135 -->1136 -->1137 -->1138 -->1139 -->114 -->1140 -->1141 -->1142 -->1143 -->1144 -->1145 -->1146 -->1147 -->1148 -->1149 -->115 -->1150 -->1151 -->1152 -->1153 -->1154 -->1155 -->1156 -->1157 -->1158 -->1159 -->116 -->1160 -->1161 -->1162 -->1163 -->1164 -->1165 -->1166 -->1167 -->1168 -->1169 -->117 -->1170 -->1171 -->1172 -->1173 -->1174 -->1175 -->1176 -->1177 -->1178 -->1179 -->118 -->1180 -->1181 -->1182 -->1183 -->1184 -->1185 -->1186 -->1187 -->1188 -->1189 -->119 -->1190 -->1191 -->1192 -->1193 -->1194 -->1195 -->1196 -->1197 -->1198 -->1199 -->12 -->120 -->1200 -->1201 -->1202 -->1203 -->1204 -->1205 -->1206 -->1207 -->1208 -->1209 -->121 -->1210 -->1211 -->1212 -->1213 -->1214 -->1215 -->1216 -->1217 -->1218 -->1219 -->122 -->1220 -->1221 -->1222 -->1223 -->1224 -->1225 -->1226 -->1227 -->1228 -->1229 -->123 -->1230 -->1231 -->1232 -->1233 -->1234 -->1235 -->1236 -->1237 -->1238 -->1239 -->124 -->1240 -->1241 -->1242 -->1243 -->1244 -->1245 -->1246 -->1247 -->1248 -->1249 -->125 -->1250 -->1251 -->1252 -->1253 -->1254 -->1255 -->1256 -->1257 -->1258 -->1259 -->126 -->1260 -->1261 -->1262 -->1263 -->1264 -->1265 -->1266 -->1267 -->1268 -->1269 -->127 -->1270 -->1271 -->1272 -->1273 -->1274 -->1275 -->1276 -->1277 -->1278 -->1279 -->128 -->1280 -->1281 -->1282 -->1283 -->1284 -->1285 -->1286 -->1287 -->1288 -->1289 -->129 -->1290 -->1291 -->1292 -->1293 -->1294 -->1295 -->1296 -->1297 -->1298 -->1299 -->13 -->130 -->1300 -->1301 -->1302 -->1303 -->1304 -->1305 -->1306 -->1307 -->1308 -->1309 -->131 -->1310 -->1311 -->1312 -->1313 -->1314 -->1315 -->1316 -->1317 -->1318 -->1319 -->132 -->1320 -->1321 -->1322 -->1323 -->1324 -->1325 -->1326 -->1327 -->1328 -->1329 -->133 -->1330 -->1331 -->1332 -->1333 -->1334 -->1335 -->1336 -->1337 -->1338 -->1339 -->134 -->1340 -->1341 -->1342 -->1343 -->1344 -->1345 -->1346 -->1347 -->1348 -->1349 -->135 -->1350 -->1351 -->1352 -->1353 -->1354 -->1355 -->1356 -->1357 -->1358 -->1359 -->136 -->1360 -->1361 -->1362 -->1363 -->1364 -->1365 -->1366 -->1367 -->1368 -->1369 -->137 -->1370 -->1371 -->1372 -->1373 -->1374 -->1375 -->1376 -->1377 -->1378 -->1379 -->138 -->1380 -->1381 -->1382 -->1383 -->1384 -->1385 -->1386 -->1387 -->1388 -->1389 -->139 -->1390 -->1391 -->1392 -->1393 -->1394 -->1395 -->1396 -->1397 -->1398 -->1399 -->14 -->140 -->1400 -->1401 -->1402 -->1403 -->1404 -->1405 -->1406 -->1407 -->1408 -->1409 -->141 -->1410 -->1411 -->1412 -->1413 -->1414 -->1415 -->1416 -->1417 -->1418 -->1419 -->142 -->1420 -->1421 -->1422 -->1423 -->1424 -->1425 -->1426 -->1427 -->1428 -->1429 -->143 -->1430 -->1431 -->1432 -->1433 -->1434 -->1435 -->1436 -->1437 -->1438 -->1439 -->144 -->1440 -->1441 -->1442 -->1443 -->1444 -->1445 -->1446 -->1447 -->1448 -->1449 -->145 -->1450 -->1451 -->1452 -->1453 -->1454 -->1455 -->1456 -->1457 -->1458 -->1459 -->146 -->1460 -->1461 -->1462 -->1463 -->1464 -->1465 -->1466 -->1467 -->1468 -->1469 -->147 -->1470 -->1471 -->1472 -->1473 -->1474 -->1475 -->1476 -->1477 -->1478 -->1479 -->148 -->1480 -->1481 -->1482 -->1483 -->1484 -->1485 -->1486 -->1487 -->1488 -->1489 -->149 -->1490 -->1491 -->1492 -->1493 -->1494 -->1495 -->1496 -->1497 -->1498 -->1499 -->15 -->150 -->1500 -->1501 -->1502 -->1503 -->1504 -->1505 -->1506 -->1507 -->1508 -->1509 -->151 -->1510 -->1511 -->1512 -->1513 -->1514 -->1515 -->1516 -->1517 -->1518 -->1519 -->152 -->1520 -->1521 -->1522 -->1523 -->1524 -->1525 -->1526 -->1527 -->1528 -->1529 -->153 -->1530 -->1531 -->1532 -->1533 -->1534 -->1535 -->1536 -->1537 -->1538 -->1539 -->154 -->1540 -->1541 -->1542 -->1543 -->1544 -->1545 -->1546 -->1547 -->1548 -->1549 -->155 -->1550 -->1551 -->1552 -->1553 -->1554 -->1555 -->1556 -->1557 -->1558 -->1559 -->156 -->1560 -->1561 -->1562 -->1563 -->1564 -->1565 -->1566 -->1567 -->1568 -->1569 -->157 -->1570 -->1571 -->1572 -->1573 -->1574 -->1575 -->1576 -->1577 -->1578 -->1579 -->158 -->1580 -->1581 -->1582 -->1583 -->1584 -->1585 -->1586 -->1587 -->1588 -->1589 -->159 -->1590 -->1591 -->1592 -->1593 -->1594 -->1595 -->1596 -->1597 -->1598 -->1599 -->16 -->160 -->1600 -->1601 -->1602 -->1603 -->1604 -->1605 -->1606 -->1607 -->1608 -->1609 -->161 -->1610 -->1611 -->1612 -->1613 -->1614 -->1615 -->1616 -->1617 -->1618 -->1619 -->162 -->1620 -->1621 -->1622 -->1623 -->1624 -->1625 -->1626 -->1627 -->1628 -->1629 -->163 -->1630 -->1631 -->1632 -->1633 -->1634 -->1635 -->1636 -->1637 -->1638 -->1639 -->164 -->1640 -->1641 -->1642 -->1643 -->1644 -->1645 -->1646 -->1647 -->1648 -->1649 -->165 -->1650 -->1651 -->1652 -->1653 -->1654 -->1655 -->1656 -->1657 -->1658 -->1659 -->166 -->1660 -->1661 -->1662 -->1663 -->1664 -->1665 -->1666 -->1667 -->1668 -->1669 -->167 -->1670 -->1671 -->1672 -->1673 -->1674 -->1675 -->1676 -->1677 -->1678 -->1679 -->168 -->1680 -->1681 -->1682 -->1683 -->1684 -->1685 -->1686 -->1687 -->1688 -->1689 -->169 -->1690 -->1691 -->1692 -->1693 -->1694 -->1695 -->1696 -->1697 -->1698 -->1699 -->17 -->170 -->1700 -->1701 -->1702 -->1703 -->1704 -->1705 -->1706 -->1707 -->1708 -->1709 -->171 -->1710 -->1711 -->1712 -->1713 -->1714 -->1715 -->1716 -->1717 -->1718 -->1719 -->172 -->1720 -->1721 -->1722 -->1723 -->1724 -->1725 -->1726 -->1727 -->1728 -->1729 -->173 -->1730 -->1731 -->1732 -->1733 -->1734 -->1735 -->1736 -->1737 -->1738 -->1739 -->174 -->1740 -->1741 -->1742 -->1743 -->1744 -->1745 -->1746 -->1747 -->1748 -->1749 -->175 -->1750 -->1751 -->1752 -->1753 -->1754 -->1755 -->1756 -->1757 -->1758 -->1759 -->176 -->1760 -->1761 -->1762 -->1763 -->1764 -->1765 -->1766 -->1767 -->1768 -->1769 -->177 -->1770 -->1771 -->1772 -->1773 -->1774 -->1775 -->1776 -->1777 -->1778 -->1779 -->178 -->1780 -->1781 -->1782 -->1783 -->1784 -->1785 -->1786 -->1787 -->1788 -->1789 -->179 -->1790 -->1791 -->1792 -->1793 -->1794 -->1795 -->1796 -->1797 -->1798 -->1799 -->18 -->180 -->1800 -->1801 -->1802 -->1803 -->1804 -->1805 -->1806 -->1807 -->1808 -->1809 -->181 -->1810 -->1811 -->1812 -->1813 -->1814 -->1815 -->1816 -->1817 -->1818 -->1819 -->182 -->1820 -->1821 -->1822 -->1823 -->1824 -->1825 -->1826 -->1827 -->1828 -->1829 -->183 -->1830 -->1831 -->1832 -->1833 -->1834 -->1835 -->1836 -->1837 -->1838 -->1839 -->184 -->1840 -->1841 -->1842 -->1843 -->1844 -->1845 -->1846 -->1847 -->1848 -->1849 -->185 -->1850 -->1851 -->1852 -->1853 -->1854 -->1855 -->1856 -->1857 -->1858 -->1859 -->186 -->1860 -->1861 -->1862 -->1863 -->1864 -->1865 -->1866 -->1867 -->1868 -->1869 -->187 -->1870 -->1871 -->1872 -->1873 -->1874 -->1875 -->1876 -->1877 -->1878 -->1879 -->188 -->1880 -->1881 -->1882 -->1883 -->1884 -->1885 -->1886 -->1887 -->1888 -->1889 -->189 -->1890 -->1891 -->1892 -->1893 -->1894 -->1895 -->1896 -->1897 -->1898 -->1899 -->19 -->190 -->1900 -->1901 -->1902 -->1903 -->1904 -->1905 -->1906 -->1907 -->1908 -->1909 -->191 -->1910 -->1911 -->1912 -->1913 -->1914 -->1915 -->1916 -->1917 -->1918 -->1919 -->192 -->1920 -->1921 -->1922 -->1923 -->1924 -->1925 -->1926 -->1927 -->1928 -->1929 -->193 -->1930 -->1931 -->1932 -->1933 -->1934 -->1935 -->1936 -->1937 -->1938 -->1939 -->194 -->1940 -->1941 -->1942 -->1943 -->1944 -->1945 -->1946 -->1947 -->1948 -->1949 -->195 -->1950 -->1951 -->1952 -->1953 -->1954 -->1955 -->1956 -->1957 -->1958 -->1959 -->196 -->1960 -->1961 -->1962 -->1963 -->1964 -->1965 -->1966 -->1967 -->1968 -->1969 -->197 -->1970 -->1971 -->1972 -->1973 -->1974 -->1975 -->1976 -->1977 -->1978 -->1979 -->198 -->1980 -->1981 -->1982 -->1983 -->1984 -->1985 -->1986 -->1987 -->1988 -->1989 -->199 -->1990 -->1991 -->1992 -->1993 -->1994 -->1995 -->1996 -->1997 -->1998 -->1999 -->2 -->20 -->200 -->2000 -->2001 -->2002 -->2003 -->2004 -->2005 -->2006 -->2007 -->2008 -->2009 -->201 -->2010 -->2011 -->2012 -->2013 -->2014 -->2015 -->2016 -->2017 -->2018 -->2019 -->202 -->2020 -->2021 -->2022 -->2023 -->2024 -->2025 -->2026 -->2027 -->2028 -->2029 -->203 -->2030 -->2031 -->2032 -->2033 -->2034 -->2035 -->2036 -->2037 -->2038 -->2039 -->204 -->2040 -->2041 -->2042 -->2043 -->2044 -->2045 -->2046 -->2047 -->2048 -->2049 -->205 -->2050 -->2051 -->2052 -->2053 -->2054 -->2055 -->2056 -->2057 -->2058 -->2059 -->206 -->2060 -->2061 -->2062 -->2063 -->2064 -->2065 -->2066 -->2067 -->2068 -->2069 -->207 -->2070 -->2071 -->2072 -->2073 -->2074 -->2075 -->2076 -->2077 -->2078 -->2079 -->208 -->2080 -->2081 -->2082 -->2083 -->2084 -->2085 -->2086 -->2087 -->2088 -->2089 -->209 -->2090 -->2091 -->2092 -->2093 -->2094 -->2095 -->2096 -->2097 -->2098 -->2099 -->21 -->210 -->2100 -->2101 -->2102 -->2103 -->2104 -->2105 -->2106 -->2107 -->2108 -->2109 -->211 -->2110 -->2111 -->2112 -->2113 -->2114 -->2115 -->2116 -->2117 -->2118 -->2119 -->212 -->2120 -->2121 -->2122 -->2123 -->2124 -->2125 -->2126 -->2127 -->2128 -->2129 -->213 -->2130 -->2131 -->2132 -->2133 -->2134 -->2135 -->2136 -->2137 -->2138 -->2139 -->214 -->2140 -->2141 -->2142 -->2143 -->2144 -->2145 -->2146 -->2147 -->2148 -->2149 -->215 -->2150 -->2151 -->2152 -->2153 -->2154 -->2155 -->2156 -->2157 -->2158 -->2159 -->216 -->2160 -->2161 -->2162 -->2163 -->2164 -->2165 -->2166 -->2167 -->2168 -->2169 -->217 -->2170 -->2171 -->2172 -->2173 -->2174 -->2175 -->2176 -->2177 -->2178 -->2179 -->218 -->2180 -->2181 -->2182 -->2183 -->2184 -->2185 -->2186 -->2187 -->2188 -->2189 -->219 -->2190 -->2191 -->2192 -->2193 -->2194 -->2195 -->2196 -->2197 -->2198 -->2199 -->22 -->220 -->2200 -->2201 -->2202 -->2203 -->2204 -->2205 -->2206 -->2207 -->2208 -->2209 -->221 -->2210 -->2211 -->2212 -->2213 -->2214 -->2215 -->2216 -->2217 -->2218 -->2219 -->222 -->2220 -->2221 -->2222 -->2223 -->2224 -->2225 -->2226 -->2227 -->2228 -->2229 -->223 -->2230 -->2231 -->2232 -->2233 -->2234 -->2235 -->2236 -->2237 -->2238 -->2239 -->224 -->2240 -->2241 -->2242 -->2243 -->2244 -->2245 -->2246 -->2247 -->2248 -->2249 -->225 -->2250 -->2251 -->2252 -->2253 -->2254 -->2255 -->2256 -->2257 -->2258 -->2259 -->226 -->2260 -->2261 -->2262 -->2263 -->2264 -->2265 -->2266 -->2267 -->2268 -->2269 -->227 -->2270 -->2271 -->2272 -->2273 -->2274 -->2275 -->2276 -->2277 -->2278 -->2279 -->228 -->2280 -->2281 -->2282 -->2283 -->2284 -->2285 -->2286 -->2287 -->2288 -->2289 -->229 -->2290 -->2291 -->2292 -->2293 -->2294 -->2295 -->2296 -->2297 -->2298 -->2299 -->23 -->230 -->2300 -->2301 -->2302 -->2303 -->2304 -->2305 -->2306 -->2307 -->2308 -->2309 -->231 -->2310 -->2311 -->2312 -->2313 -->2314 -->2315 -->2316 -->2317 -->2318 -->2319 -->232 -->2320 -->2321 -->2322 -->2323 -->2324 -->2325 -->2326 -->2327 -->2328 -->2329 -->233 -->2330 -->2331 -->2332 -->2333 -->2334 -->2335 -->2336 -->2337 -->2338 -->2339 -->234 -->2340 -->2341 -->2342 -->2343 -->2344 -->2345 -->2346 -->2347 -->2348 -->2349 -->235 -->2350 -->2351 -->2352 -->2353 -->2354 -->2355 -->2356 -->2357 -->2358 -->2359 -->236 -->2360 -->2361 -->2362 -->2363 -->2364 -->2365 -->2366 -->2367 -->2368 -->2369 -->237 -->2370 -->2371 -->2372 -->2373 -->2374 -->2375 -->2376 -->2377 -->2378 -->2379 -->238 -->2380 -->2381 -->2382 -->2383 -->2384 -->2385 -->2386 -->2387 -->2388 -->2389 -->239 -->2390 -->2391 -->2392 -->2393 -->2394 -->2395 -->2396 -->2397 -->2398 -->2399 -->24 -->240 -->2400 -->2401 -->2402 -->2403 -->2404 -->2405 -->2406 -->2407 -->2408 -->2409 -->241 -->2410 -->2411 -->2412 -->2413 -->2414 -->2415 -->2416 -->2417 -->2418 -->2419 -->242 -->2420 -->2421 -->2422 -->2423 -->2424 -->2425 -->2426 -->2427 -->2428 -->2429 -->243 -->2430 -->2431 -->2432 -->2433 -->2434 -->2435 -->2436 -->2437 -->2438 -->2439 -->244 -->2440 -->2441 -->2442 -->2443 -->2444 -->2445 -->2446 -->2447 -->2448 -->2449 -->245 -->2450 -->2451 -->2452 -->2453 -->2454 -->2455 -->2456 -->2457 -->2458 -->2459 -->246 -->2460 -->2461 -->2462 -->2463 -->2464 -->2465 -->2466 -->2467 -->2468 -->2469 -->247 -->2470 -->2471 -->2472 -->2473 -->2474 -->2475 -->2476 -->2477 -->2478 -->2479 -->248 -->2480 -->2481 -->2482 -->2483 -->2484 -->2485 -->2486 -->2487 -->2488 -->2489 -->249 -->2490 -->2491 -->2492 -->2493 -->2494 -->2495 -->2496 -->2497 -->2498 -->2499 -->25 -->250 -->2500 -->2501 -->2502 -->2503 -->2504 -->2505 -->2506 -->2507 -->2508 -->2509 -->251 -->2510 -->2511 -->2512 -->2513 -->2514 -->2515 -->2516 -->2517 -->2518 -->2519 -->252 -->2520 -->2521 -->2522 -->2523 -->2524 -->2525 -->2526 -->2527 -->2528 -->2529 -->253 -->2530 -->2531 -->2532 -->2533 -->2534 -->2535 -->2536 -->2537 -->2538 -->2539 -->254 -->2540 -->2541 -->2542 -->2543 -->2544 -->2545 -->2546 -->2547 -->2548 -->2549 -->255 -->2550 -->2551 -->2552 -->2553 -->2554 -->2555 -->2556 -->2557 -->2558 -->2559 -->256 -->2560 -->2561 -->2562 -->2563 -->2564 -->2565 -->2566 -->2567 -->2568 -->2569 -->257 -->2570 -->2571 -->2572 -->2573 -->2574 -->2575 -->2576 -->2577 -->2578 -->2579 -->258 -->2580 -->2581 -->2582 -->2583 -->2584 -->2585 -->2586 -->2587 -->2588 -->2589 -->259 -->2590 -->2591 -->2592 -->2593 -->2594 -->2595 -->2596 -->2597 -->2598 -->2599 -->26 -->260 -->2600 -->2601 -->2602 -->2603 -->2604 -->2605 -->2606 -->2607 -->2608 -->2609 -->261 -->2610 -->2611 -->2612 -->2613 -->2614 -->2615 -->2616 -->2617 -->2618 -->2619 -->262 -->2620 -->2621 -->2622 -->2623 -->2624 -->2625 -->2626 -->2627 -->2628 -->2629 -->263 -->2630 -->2631 -->2632 -->2633 -->2634 -->2635 -->2636 -->2637 -->2638 -->2639 -->264 -->2640 -->2641 -->2642 -->2643 -->2644 -->2645 -->2646 -->2647 -->2648 -->2649 -->265 -->2650 -->2651 -->2652 -->2653 -->2654 -->2655 -->2656 -->2657 -->2658 -->2659 -->266 -->2660 -->2661 -->2662 -->2663 -->2664 -->2665 -->2666 -->2667 -->2668 -->2669 -->267 -->2670 -->2671 -->2672 -->2673 -->2674 -->2675 -->2676 -->2677 -->2678 -->2679 -->268 -->2680 -->2681 -->2682 -->2683 -->2684 -->2685 -->2686 -->2687 -->2688 -->2689 -->269 -->2690 -->2691 -->2692 -->2693 -->2694 -->2695 -->2696 -->2697 -->2698 -->2699 -->27 -->270 -->2700 -->2701 -->2702 -->2703 -->2704 -->2705 -->2706 -->2707 -->2708 -->2709 -->271 -->2710 -->2711 -->2712 -->2713 -->2714 -->2715 -->2716 -->2717 -->2718 -->2719 -->272 -->2720 -->2721 -->2722 -->2723 -->2724 -->2725 -->2726 -->2727 -->2728 -->2729 -->273 -->2730 -->2731 -->2732 -->2733 -->2734 -->2735 -->2736 -->2737 -->2738 -->2739 -->274 -->2740 -->2741 -->2742 -->2743 -->2744 -->2745 -->2746 -->2747 -->2748 -->2749 -->275 -->2750 -->2751 -->2752 -->2753 -->2754 -->2755 -->2756 -->2757 -->2758 -->2759 -->276 -->2760 -->2761 -->2762 -->2763 -->2764 -->2765 -->2766 -->2767 -->2768 -->2769 -->277 -->2770 -->2771 -->2772 -->2773 -->2774 -->2775 -->2776 -->2777 -->2778 -->2779 -->278 -->2780 -->2781 -->2782 -->2783 -->2784 -->2785 -->2786 -->2787 -->2788 -->2789 -->279 -->2790 -->2791 -->2792 -->2793 -->2794 -->2795 -->2796 -->2797 -->2798 -->2799 -->28 -->280 -->2800 -->2801 -->2802 -->2803 -->2804 -->2805 -->2806 -->2807 -->2808 -->2809 -->281 -->2810 -->2811 -->2812 -->2813 -->2814 -->2815 -->2816 -->2817 -->2818 -->2819 -->282 -->2820 -->2821 -->2822 -->2823 -->2824 -->2825 -->2826 -->2827 -->2828 -->2829 -->283 -->2830 -->2831 -->2832 -->2833 -->2834 -->2835 -->2836 -->2837 -->2838 -->2839 -->284 -->2840 -->2841 -->2842 -->2843 -->2844 -->2845 -->2846 -->2847 -->2848 -->2849 -->285 -->2850 -->2851 -->2852 -->2853 -->2854 -->2855 -->2856 -->2857 -->2858 -->2859 -->286 -->2860 -->2861 -->2862 -->2863 -->2864 -->2865 -->2866 -->2867 -->2868 -->2869 -->287 -->2870 -->2871 -->2872 -->2873 -->2874 -->2875 -->2876 -->2877 -->2878 -->2879 -->288 -->2880 -->2881 -->2882 -->2883 -->2884 -->2885 -->2886 -->2887 -->2888 -->2889 -->289 -->2890 -->2891 -->2892 -->2893 -->2894 -->2895 -->2896 -->2897 -->2898 -->2899 -->29 -->290 -->2900 -->2901 -->2902 -->2903 -->2904 -->2905 -->2906 -->2907 -->2908 -->2909 -->291 -->2910 -->2911 -->2912 -->2913 -->2914 -->2915 -->2916 -->2917 -->2918 -->2919 -->292 -->2920 -->2921 -->2922 -->2923 -->2924 -->2925 -->2926 -->2927 -->2928 -->2929 -->293 -->2930 -->2931 -->2932 -->2933 -->2934 -->2935 -->2936 -->2937 -->2938 -->2939 -->294 -->2940 -->2941 -->2942 -->2943 -->2944 -->2945 -->2946 -->2947 -->2948 -->2949 -->295 -->2950 -->2951 -->2952 -->2953 -->2954 -->2955 -->2956 -->2957 -->2958 -->2959 -->296 -->2960 -->2961 -->2962 -->2963 -->2964 -->2965 -->2966 -->2967 -->2968 -->2969 -->297 -->2970 -->2971 -->2972 -->2973 -->2974 -->2975 -->2976 -->2977 -->2978 -->2979 -->298 -->2980 -->2981 -->2982 -->2983 -->2984 -->2985 -->2986 -->2987 -->2988 -->2989 -->299 -->2990 -->2991 -->2992 -->2993 -->2994 -->2995 -->2996 -->2997 -->2998 -->2999 -->3 -->30 -->300 -->3000 -->3001 -->3002 -->3003 -->3004 -->3005 -->3006 -->3007 -->3008 -->3009 -->301 -->3010 -->3011 -->3012 -->3013 -->3014 -->3015 -->3016 -->3017 -->3018 -->3019 -->302 -->3020 -->3021 -->3022 -->3023 -->3024 -->3025 -->3026 -->3027 -->3028 -->3029 -->303 -->3030 -->3031 -->3032 -->3033 -->3034 -->3035 -->3036 -->3037 -->3038 -->3039 -->304 -->3040 -->3041 -->3042 -->3043 -->3044 -->3045 -->3046 -->3047 -->3048 -->3049 -->305 -->3050 -->3051 -->3052 -->3053 -->3054 -->3055 -->3056 -->3057 -->3058 -->3059 -->306 -->3060 -->3061 -->3062 -->3063 -->3064 -->3065 -->3066 -->3067 -->3068 -->3069 -->307 -->3070 -->3071 -->3072 -->3073 -->3074 -->3075 -->3076 -->3077 -->3078 -->3079 -->308 -->3080 -->3081 -->3082 -->3083 -->3084 -->3085 -->3086 -->3087 -->3088 -->3089 -->309 -->3090 -->3091 -->3092 -->3093 -->3094 -->3095 -->3096 -->3097 -->3098 -->3099 -->31 -->310 -->3100 -->3101 -->3102 -->3103 -->3104 -->3105 -->3106 -->3107 -->3108 -->3109 -->311 -->3110 -->3111 -->3112 -->3113 -->3114 -->3115 -->3116 -->3117 -->3118 -->3119 -->312 -->3120 -->3121 -->3122 -->3123 -->3124 -->3125 -->3126 -->3127 -->3128 -->3129 -->313 -->3130 -->3131 -->3132 -->3133 -->3134 -->3135 -->3136 -->3137 -->3138 -->3139 -->314 -->3140 -->3141 -->3142 -->3143 -->3144 -->3145 -->3146 -->3147 -->3148 -->3149 -->315 -->3150 -->3151 -->3152 -->3153 -->3154 -->3155 -->3156 -->3157 -->3158 -->3159 -->316 -->3160 -->3161 -->3162 -->3163 -->3164 -->3165 -->3166 -->3167 -->3168 -->3169 -->317 -->3170 -->3171 -->3172 -->3173 -->3174 -->3175 -->3176 -->3177 -->3178 -->3179 -->318 -->3180 -->3181 -->3182 -->3183 -->3184 -->3185 -->3186 -->3187 -->3188 -->3189 -->319 -->3190 -->3191 -->3192 -->3193 -->3194 -->3195 -->3196 -->3197 -->3198 -->3199 -->32 -->320 -->3200 -->3201 -->3202 -->3203 -->3204 -->3205 -->3206 -->3207 -->3208 -->3209 -->321 -->3210 -->3211 -->3212 -->3213 -->3214 -->3215 -->3216 -->3217 -->3218 -->3219 -->322 -->3220 -->3221 -->3222 -->3223 -->3224 -->3225 -->3226 -->3227 -->3228 -->3229 -->323 -->3230 -->3231 -->3232 -->3233 -->3234 -->3235 -->3236 -->3237 -->3238 -->3239 -->324 -->3240 -->3241 -->3242 -->3243 -->3244 -->3245 -->3246 -->3247 -->3248 -->3249 -->325 -->3250 -->3251 -->3252 -->3253 -->3254 -->3255 -->3256 -->3257 -->3258 -->3259 -->326 -->3260 -->3261 -->3262 -->3263 -->3264 -->3265 -->3266 -->3267 -->3268 -->3269 -->327 -->3270 -->3271 -->3272 -->3273 -->3274 -->3275 -->3276 -->3277 -->3278 -->3279 -->328 -->3280 -->3281 -->3282 -->3283 -->3284 -->3285 -->3286 -->3287 -->3288 -->3289 -->329 -->3290 -->3291 -->3292 -->3293 -->3294 -->3295 -->3296 -->3297 -->3298 -->3299 -->33 -->330 -->3300 -->3301 -->3302 -->3303 -->3304 -->3305 -->3306 -->3307 -->3308 -->3309 -->331 -->3310 -->3311 -->3312 -->3313 -->3314 -->3315 -->3316 -->3317 -->3318 -->3319 -->332 -->3320 -->3321 -->3322 -->3323 -->3324 -->3325 -->3326 -->3327 -->3328 -->3329 -->333 -->3330 -->3331 -->3332 -->3333 -->3334 -->3335 -->3336 -->3337 -->3338 -->3339 -->334 -->3340 -->3341 -->3342 -->3343 -->3344 -->3345 -->3346 -->3347 -->3348 -->3349 -->335 -->3350 -->3351 -->3352 -->3353 -->3354 -->3355 -->3356 -->3357 -->3358 -->3359 -->336 -->3360 -->3361 -->3362 -->3363 -->3364 -->3365 -->3366 -->3367 -->3368 -->3369 -->337 -->3370 -->3371 -->3372 -->3373 -->3374 -->3375 -->3376 -->3377 -->3378 -->3379 -->338 -->3380 -->3381 -->3382 -->3383 -->3384 -->3385 -->3386 -->3387 -->3388 -->3389 -->339 -->3390 -->3391 -->3392 -->3393 -->3394 -->3395 -->3396 -->3397 -->3398 -->3399 -->34 -->340 -->3400 -->3401 -->3402 -->3403 -->3404 -->3405 -->3406 -->3407 -->3408 -->3409 -->341 -->3410 -->3411 -->3412 -->3413 -->3414 -->3415 -->3416 -->3417 -->3418 -->3419 -->342 -->3420 -->3421 -->3422 -->3423 -->3424 -->3425 -->3426 -->3427 -->3428 -->3429 -->343 -->3430 -->3431 -->3432 -->3433 -->3434 -->3435 -->3436 -->3437 -->3438 -->3439 -->344 -->3440 -->3441 -->3442 -->3443 -->3444 -->3445 -->3446 -->3447 -->3448 -->3449 -->345 -->3450 -->3451 -->3452 -->3453 -->3454 -->3455 -->3456 -->3457 -->3458 -->3459 -->346 -->3460 -->3461 -->3462 -->3463 -->3464 -->3465 -->3466 -->3467 -->3468 -->3469 -->347 -->3470 -->3471 -->3472 -->3473 -->3474 -->3475 -->3476 -->3477 -->3478 -->3479 -->348 -->3480 -->3481 -->3482 -->3483 -->3484 -->3485 -->3486 -->3487 -->3488 -->3489 -->349 -->3490 -->3491 -->3492 -->3493 -->3494 -->3495 -->3496 -->3497 -->3498 -->3499 -->35 -->350 -->3500 -->3501 -->3502 -->3503 -->3504 -->3505 -->3506 -->3507 -->3508 -->3509 -->351 -->3510 -->3511 -->3512 -->3513 -->3514 -->3515 -->3516 -->3517 -->3518 -->3519 -->352 -->3520 -->3521 -->3522 -->3523 -->3524 -->3525 -->3526 -->3527 -->3528 -->3529 -->353 -->3530 -->3531 -->3532 -->3533 -->3534 -->3535 -->3536 -->3537 -->3538 -->3539 -->354 -->3540 -->3541 -->3542 -->3543 -->3544 -->3545 -->3546 -->3547 -->3548 -->3549 -->355 -->3550 -->3551 -->3552 -->3553 -->3554 -->3555 -->3556 -->3557 -->3558 -->3559 -->356 -->3560 -->3561 -->3562 -->3563 -->3564 -->3565 -->3566 -->3567 -->3568 -->3569 -->357 -->3570 -->3571 -->3572 -->3573 -->3574 -->3575 -->3576 -->3577 -->3578 -->3579 -->358 -->3580 -->3581 -->3582 -->3583 -->3584 -->3585 -->3586 -->3587 -->3588 -->3589 -->359 -->3590 -->3591 -->3592 -->3593 -->3594 -->3595 -->3596 -->3597 -->3598 -->3599 -->36 -->360 -->3600 -->3601 -->3602 -->3603 -->3604 -->3605 -->3606 -->3607 -->3608 -->3609 -->361 -->3610 -->3611 -->3612 -->3613 -->3614 -->3615 -->3616 -->3617 -->3618 -->3619 -->362 -->3620 -->3621 -->3622 -->3623 -->3624 -->3625 -->3626 -->3627 -->3628 -->3629 -->363 -->3630 -->3631 -->3632 -->3633 -->3634 -->3635 -->3636 -->3637 -->3638 -->3639 -->364 -->3640 -->3641 -->3642 -->3643 -->3644 -->3645 -->3646 -->3647 -->3648 -->3649 -->365 -->3650 -->3651 -->3652 -->3653 -->3654 -->3655 -->3656 -->3657 -->3658 -->3659 -->366 -->3660 -->3661 -->3662 -->3663 -->3664 -->3665 -->3666 -->3667 -->3668 -->3669 -->367 -->3670 -->3671 -->3672 -->3673 -->3674 -->3675 -->3676 -->3677 -->3678 -->3679 -->368 -->3680 -->3681 -->3682 -->3683 -->3684 -->3685 -->3686 -->3687 -->3688 -->3689 -->369 -->3690 -->3691 -->3692 -->3693 -->3694 -->3695 -->3696 -->3697 -->3698 -->3699 -->37 -->370 -->3700 -->3701 -->3702 -->3703 -->3704 -->3705 -->3706 -->3707 -->3708 -->3709 -->371 -->3710 -->3711 -->3712 -->3713 -->3714 -->3715 -->3716 -->3717 -->3718 -->3719 -->372 -->3720 -->3721 -->3722 -->3723 -->3724 -->3725 -->3726 -->3727 -->3728 -->3729 -->373 -->3730 -->3731 -->3732 -->3733 -->3734 -->3735 -->3736 -->3737 -->3738 -->3739 -->374 -->3740 -->3741 -->3742 -->3743 -->3744 -->3745 -->3746 -->3747 -->3748 -->3749 -->375 -->3750 -->3751 -->3752 -->3753 -->3754 -->3755 -->3756 -->3757 -->3758 -->3759 -->376 -->3760 -->3761 -->3762 -->3763 -->3764 -->3765 -->3766 -->3767 -->3768 -->3769 -->377 -->3770 -->3771 -->3772 -->3773 -->3774 -->3775 -->3776 -->3777 -->3778 -->3779 -->378 -->3780 -->3781 -->3782 -->3783 -->3784 -->3785 -->3786 -->3787 -->3788 -->3789 -->379 -->3790 -->3791 -->3792 -->3793 -->3794 -->3795 -->3796 -->3797 -->3798 -->3799 -->38 -->380 -->3800 -->3801 -->3802 -->3803 -->3804 -->3805 -->3806 -->3807 -->3808 -->3809 -->381 -->3810 -->3811 -->3812 -->3813 -->3814 -->3815 -->3816 -->3817 -->3818 -->3819 -->382 -->3820 -->3821 -->3822 -->3823 -->3824 -->3825 -->3826 -->3827 -->3828 -->3829 -->383 -->3830 -->3831 -->3832 -->3833 -->3834 -->3835 -->3836 -->3837 -->3838 -->3839 -->384 -->3840 -->3841 -->3842 -->3843 -->3844 -->3845 -->3846 -->3847 -->3848 -->3849 -->385 -->3850 -->3851 -->3852 -->3853 -->3854 -->3855 -->3856 -->3857 -->3858 -->3859 -->386 -->3860 -->3861 -->3862 -->3863 -->3864 -->3865 -->3866 -->3867 -->3868 -->3869 -->387 -->3870 -->3871 -->3872 -->3873 -->3874 -->3875 -->3876 -->3877 -->3878 -->3879 -->388 -->3880 -->3881 -->3882 -->3883 -->3884 -->3885 -->3886 -->3887 -->3888 -->3889 -->389 -->3890 -->3891 -->3892 -->3893 -->3894 -->3895 -->3896 -->3897 -->3898 -->3899 -->39 -->390 -->3900 -->3901 -->3902 -->3903 -->3904 -->3905 -->3906 -->3907 -->3908 -->3909 -->391 -->3910 -->3911 -->3912 -->3913 -->3914 -->3915 -->3916 -->3917 -->3918 -->3919 -->392 -->3920 -->3921 -->3922 -->3923 -->3924 -->3925 -->3926 -->3927 -->3928 -->3929 -->393 -->3930 -->3931 -->3932 -->3933 -->3934 -->3935 -->3936 -->3937 -->3938 -->3939 -->394 -->3940 -->3941 -->3942 -->3943 -->3944 -->3945 -->3946 -->3947 -->3948 -->3949 -->395 -->3950 -->3951 -->3952 -->3953 -->3954 -->3955 -->3956 -->3957 -->3958 -->3959 -->396 -->3960 -->3961 -->3962 -->3963 -->3964 -->3965 -->3966 -->3967 -->3968 -->3969 -->397 -->3970 -->3971 -->3972 -->3973 -->3974 -->3975 -->3976 -->3977 -->3978 -->3979 -->398 -->3980 -->3981 -->3982 -->3983 -->3984 -->3985 -->3986 -->3987 -->3988 -->3989 -->399 -->3990 -->3991 -->3992 -->3993 -->3994 -->3995 -->3996 -->3997 -->3998 -->3999 -->4 -->40 -->400 -->4000 -->4001 -->4002 -->4003 -->4004 -->4005 -->4006 -->4007 -->4008 -->4009 -->401 -->4010 -->4011 -->4012 -->4013 -->4014 -->4015 -->4016 -->4017 -->4018 -->4019 -->402 -->4020 -->4021 -->4022 -->4023 -->4024 -->4025 -->4026 -->4027 -->4028 -->4029 -->403 -->4030 -->4031 -->4032 -->4033 -->4034 -->4035 -->4036 -->4037 -->4038 -->4039 -->404 -->4040 -->4041 -->4042 -->4043 -->4044 -->4045 -->4046 -->4047 -->4048 -->4049 -->405 -->4050 -->4051 -->4052 -->4053 -->4054 -->4055 -->4056 -->4057 -->4058 -->4059 -->406 -->4060 -->4061 -->4062 -->4063 -->4064 -->4065 -->4066 -->4067 -->4068 -->4069 -->407 -->4070 -->4071 -->4072 -->4073 -->4074 -->4075 -->4076 -->4077 -->4078 -->4079 -->408 -->4080 -->4081 -->4082 -->4083 -->4084 -->4085 -->4086 -->4087 -->4088 -->4089 -->409 -->4090 -->4091 -->4092 -->4093 -->4094 -->4095 -->4096 -->4097 -->4098 -->4099 -->41 -->410 -->4100 -->4101 -->4102 -->4103 -->4104 -->4105 -->4106 -->4107 -->4108 -->4109 -->411 -->4110 -->4111 -->4112 -->4113 -->4114 -->4115 -->4116 -->4117 -->4118 -->4119 -->412 -->4120 -->4121 -->4122 -->4123 -->4124 -->4125 -->4126 -->4127 -->4128 -->4129 -->413 -->4130 -->4131 -->4132 -->4133 -->4134 -->4135 -->4136 -->4137 -->4138 -->4139 -->414 -->4140 -->4141 -->4142 -->4143 -->4144 -->4145 -->4146 -->4147 -->4148 -->4149 -->415 -->4150 -->4151 -->4152 -->4153 -->4154 -->4155 -->4156 -->4157 -->4158 -->4159 -->416 -->4160 -->4161 -->4162 -->4163 -->4164 -->4165 -->4166 -->4167 -->4168 -->4169 -->417 -->4170 -->4171 -->4172 -->4173 -->4174 -->4175 -->4176 -->4177 -->4178 -->4179 -->418 -->4180 -->4181 -->4182 -->4183 -->4184 -->4185 -->4186 -->4187 -->4188 -->4189 -->419 -->4190 -->4191 -->4192 -->4193 -->4194 -->4195 -->4196 -->4197 -->4198 -->4199 -->42 -->420 -->4200 -->4201 -->4202 -->4203 -->4204 -->4205 -->4206 -->4207 -->4208 -->4209 -->421 -->4210 -->4211 -->4212 -->4213 -->4214 -->4215 -->4216 -->4217 -->4218 -->4219 -->422 -->4220 -->4221 -->4222 -->4223 -->4224 -->4225 -->4226 -->4227 -->4228 -->4229 -->423 -->4230 -->4231 -->4232 -->4233 -->4234 -->4235 -->4236 -->4237 -->4238 -->4239 -->424 -->4240 -->4241 -->4242 -->4243 -->4244 -->4245 -->4246 -->4247 -->4248 -->4249 -->425 -->4250 -->4251 -->4252 -->4253 -->4254 -->4255 -->4256 -->4257 -->4258 -->4259 -->426 -->4260 -->4261 -->4262 -->4263 -->4264 -->4265 -->4266 -->4267 -->4268 -->4269 -->427 -->4270 -->4271 -->4272 -->4273 -->4274 -->4275 -->4276 -->4277 -->4278 -->4279 -->428 -->4280 -->4281 -->4282 -->4283 -->4284 -->4285 -->4286 -->4287 -->4288 -->4289 -->429 -->4290 -->4291 -->4292 -->4293 -->4294 -->4295 -->4296 -->4297 -->4298 -->4299 -->43 -->430 -->4300 -->4301 -->4302 -->4303 -->4304 -->4305 -->4306 -->4307 -->4308 -->4309 -->431 -->4310 -->4311 -->4312 -->4313 -->4314 -->4315 -->4316 -->4317 -->4318 -->4319 -->432 -->4320 -->4321 -->4322 -->4323 -->4324 -->4325 -->4326 -->4327 -->4328 -->4329 -->433 -->4330 -->4331 -->4332 -->4333 -->4334 -->4335 -->4336 -->4337 -->4338 -->4339 -->434 -->4340 -->4341 -->4342 -->4343 -->4344 -->4345 -->4346 -->4347 -->4348 -->4349 -->435 -->4350 -->4351 -->4352 -->4353 -->4354 -->4355 -->4356 -->4357 -->4358 -->4359 -->436 -->4360 -->4361 -->4362 -->4363 -->4364 -->4365 -->4366 -->4367 -->4368 -->4369 -->437 -->4370 -->4371 -->4372 -->4373 -->4374 -->4375 -->4376 -->4377 -->4378 -->4379 -->438 -->4380 -->4381 -->4382 -->4383 -->4384 -->4385 -->4386 -->4387 -->4388 -->4389 -->439 -->4390 -->4391 -->4392 -->4393 -->4394 -->4395 -->4396 -->4397 -->4398 -->4399 -->44 -->440 -->4400 -->4401 -->4402 -->4403 -->4404 -->4405 -->4406 -->4407 -->4408 -->4409 -->441 -->4410 -->4411 -->4412 -->4413 -->4414 -->4415 -->4416 -->4417 -->4418 -->4419 -->442 -->4420 -->4421 -->4422 -->4423 -->4424 -->4425 -->4426 -->4427 -->4428 -->4429 -->443 -->4430 -->4431 -->4432 -->4433 -->4434 -->4435 -->4436 -->4437 -->4438 -->4439 -->444 -->4440 -->4441 -->4442 -->4443 -->4444 -->4445 -->4446 -->4447 -->4448 -->4449 -->445 -->4450 -->4451 -->4452 -->4453 -->4454 -->4455 -->4456 -->4457 -->4458 -->4459 -->446 -->4460 -->4461 -->4462 -->4463 -->4464 -->4465 -->4466 -->4467 -->4468 -->4469 -->447 -->4470 -->4471 -->4472 -->4473 -->4474 -->4475 -->4476 -->4477 -->4478 -->4479 -->448 -->4480 -->4481 -->4482 -->4483 -->4484 -->4485 -->4486 -->4487 -->4488 -->4489 -->449 -->4490 -->4491 -->4492 -->4493 -->4494 -->4495 -->4496 -->4497 -->4498 -->4499 -->45 -->450 -->4500 -->4501 -->4502 -->4503 -->4504 -->4505 -->4506 -->4507 -->4508 -->4509 -->451 -->4510 -->4511 -->4512 -->4513 -->4514 -->4515 -->4516 -->4517 -->4518 -->4519 -->452 -->4520 -->4521 -->4522 -->4523 -->4524 -->4525 -->4526 -->4527 -->4528 -->4529 -->453 -->4530 -->4531 -->4532 -->4533 -->4534 -->4535 -->4536 -->4537 -->4538 -->4539 -->454 -->4540 -->4541 -->4542 -->4543 -->4544 -->4545 -->4546 -->4547 -->4548 -->4549 -->455 -->4550 -->4551 -->4552 -->4553 -->4554 -->4555 -->4556 -->4557 -->4558 -->4559 -->456 -->4560 -->4561 -->4562 -->4563 -->4564 -->4565 -->4566 -->4567 -->4568 -->4569 -->457 -->4570 -->4571 -->4572 -->4573 -->4574 -->4575 -->4576 -->4577 -->4578 -->4579 -->458 -->4580 -->4581 -->4582 -->4583 -->4584 -->4585 -->4586 -->4587 -->4588 -->4589 -->459 -->4590 -->4591 -->4592 -->4593 -->4594 -->4595 -->4596 -->4597 -->4598 -->4599 -->46 -->460 -->4600 -->4601 -->4602 -->4603 -->4604 -->4605 -->4606 -->4607 -->4608 -->4609 -->461 -->4610 -->4611 -->4612 -->4613 -->4614 -->4615 -->4616 -->4617 -->4618 -->4619 -->462 -->4620 -->4621 -->4622 -->4623 -->4624 -->4625 -->4626 -->4627 -->4628 -->4629 -->463 -->4630 -->4631 -->4632 -->4633 -->4634 -->4635 -->4636 -->4637 -->4638 -->4639 -->464 -->4640 -->4641 -->4642 -->4643 -->4644 -->4645 -->4646 -->4647 -->4648 -->4649 -->465 -->4650 -->4651 -->4652 -->4653 -->4654 -->4655 -->4656 -->4657 -->4658 -->4659 -->466 -->4660 -->4661 -->4662 -->4663 -->4664 -->4665 -->4666 -->4667 -->4668 -->4669 -->467 -->4670 -->4671 -->4672 -->4673 -->4674 -->4675 -->4676 -->4677 -->4678 -->4679 -->468 -->4680 -->4681 -->4682 -->4683 -->4684 -->4685 -->4686 -->4687 -->4688 -->4689 -->469 -->4690 -->4691 -->4692 -->4693 -->4694 -->4695 -->4696 -->4697 -->4698 -->4699 -->47 -->470 -->4700 -->4701 -->4702 -->4703 -->4704 -->4705 -->4706 -->4707 -->4708 -->4709 -->471 -->4710 -->4711 -->4712 -->4713 -->4714 -->4715 -->4716 -->4717 -->4718 -->4719 -->472 -->4720 -->4721 -->4722 -->4723 -->4724 -->4725 -->4726 -->4727 -->4728 -->4729 -->473 -->4730 -->4731 -->4732 -->4733 -->4734 -->4735 -->4736 -->4737 -->4738 -->4739 -->474 -->4740 -->4741 -->4742 -->4743 -->4744 -->4745 -->4746 -->4747 -->4748 -->4749 -->475 -->4750 -->4751 -->4752 -->4753 -->4754 -->4755 -->4756 -->4757 -->4758 -->4759 -->476 -->4760 -->4761 -->4762 -->4763 -->4764 -->4765 -->4766 -->4767 -->4768 -->4769 -->477 -->4770 -->4771 -->4772 -->4773 -->4774 -->4775 -->4776 -->4777 -->4778 -->4779 -->478 -->4780 -->4781 -->4782 -->4783 -->4784 -->4785 -->4786 -->4787 -->4788 -->4789 -->479 -->4790 -->4791 -->4792 -->4793 -->4794 -->4795 -->4796 -->4797 -->4798 -->4799 -->48 -->480 -->4800 -->4801 -->4802 -->4803 -->4804 -->4805 -->4806 -->4807 -->4808 -->4809 -->481 -->4810 -->4811 -->4812 -->4813 -->4814 -->4815 -->4816 -->4817 -->4818 -->4819 -->482 -->4820 -->4821 -->4822 -->4823 -->4824 -->4825 -->4826 -->4827 -->4828 -->4829 -->483 -->4830 -->4831 -->4832 -->4833 -->4834 -->4835 -->4836 -->4837 -->4838 -->4839 -->484 -->4840 -->4841 -->4842 -->4843 -->4844 -->4845 -->4846 -->4847 -->4848 -->4849 -->485 -->4850 -->4851 -->4852 -->4853 -->4854 -->4855 -->4856 -->4857 -->4858 -->4859 -->486 -->4860 -->4861 -->4862 -->4863 -->4864 -->4865 -->4866 -->4867 -->4868 -->4869 -->487 -->4870 -->4871 -->4872 -->4873 -->4874 -->4875 -->4876 -->4877 -->4878 -->4879 -->488 -->4880 -->4881 -->4882 -->4883 -->4884 -->4885 -->4886 -->4887 -->4888 -->4889 -->489 -->4890 -->4891 -->4892 -->4893 -->4894 -->4895 -->4896 -->4897 -->4898 -->4899 -->49 -->490 -->4900 -->4901 -->4902 -->4903 -->4904 -->4905 -->4906 -->4907 -->4908 -->4909 -->491 -->4910 -->4911 -->4912 -->4913 -->4914 -->4915 -->4916 -->4917 -->4918 -->4919 -->492 -->4920 -->4921 -->4922 -->4923 -->4924 -->4925 -->4926 -->4927 -->4928 -->4929 -->493 -->4930 -->4931 -->4932 -->4933 -->4934 -->4935 -->4936 -->4937 -->4938 -->4939 -->494 -->4940 -->4941 -->4942 -->4943 -->4944 -->4945 -->4946 -->4947 -->4948 -->4949 -->495 -->4950 -->4951 -->4952 -->4953 -->4954 -->4955 -->4956 -->4957 -->4958 -->4959 -->496 -->4960 -->4961 -->4962 -->4963 -->4964 -->4965 -->4966 -->4967 -->4968 -->4969 -->497 -->4970 -->4971 -->4972 -->4973 -->4974 -->4975 -->4976 -->4977 -->4978 -->4979 -->498 -->4980 -->4981 -->4982 -->4983 -->4984 -->4985 -->4986 -->4987 -->4988 -->4989 -->499 -->4990 -->4991 -->4992 -->4993 -->4994 -->4995 -->4996 -->4997 -->4998 -->4999 -->5 -->50 -->500 -->5000 -->5001 -->5002 -->5003 -->5004 -->5005 -->5006 -->5007 -->5008 -->5009 -->501 -->5010 -->5011 -->5012 -->5013 -->5014 -->5015 -->5016 -->5017 -->5018 -->5019 -->502 -->5020 -->5021 -->5022 -->5023 -->5024 -->5025 -->5026 -->5027 -->5028 -->5029 -->503 -->5030 -->5031 -->5032 -->5033 -->5034 -->5035 -->5036 -->5037 -->5038 -->5039 -->504 -->5040 -->5041 -->5042 -->5043 -->5044 -->5045 -->5046 -->5047 -->5048 -->5049 -->505 -->5050 -->5051 -->5052 -->5053 -->5054 -->5055 -->5056 -->5057 -->5058 -->5059 -->506 -->5060 -->5061 -->5062 -->5063 -->5064 -->5065 -->5066 -->5067 -->5068 -->5069 -->507 -->5070 -->5071 -->5072 -->5073 -->5074 -->5075 -->5076 -->5077 -->5078 -->5079 -->508 -->5080 -->5081 -->5082 -->5083 -->5084 -->5085 -->5086 -->5087 -->5088 -->5089 -->509 -->5090 -->5091 -->5092 -->5093 -->5094 -->5095 -->5096 -->5097 -->5098 -->5099 -->51 -->510 -->5100 -->5101 -->5102 -->5103 -->5104 -->5105 -->5106 -->5107 -->5108 -->5109 -->511 -->5110 -->5111 -->5112 -->5113 -->5114 -->5115 -->5116 -->5117 -->5118 -->5119 -->512 -->5120 -->5121 -->5122 -->5123 -->5124 -->5125 -->5126 -->5127 -->5128 -->5129 -->513 -->5130 -->5131 -->5132 -->5133 -->5134 -->5135 -->5136 -->5137 -->5138 -->5139 -->514 -->5140 -->5141 -->5142 -->5143 -->5144 -->5145 -->5146 -->5147 -->5148 -->5149 -->515 -->5150 -->5151 -->5152 -->5153 -->5154 -->5155 -->5156 -->5157 -->5158 -->5159 -->516 -->5160 -->5161 -->5162 -->5163 -->5164 -->5165 -->5166 -->5167 -->5168 -->5169 -->517 -->5170 -->5171 -->5172 -->5173 -->5174 -->5175 -->5176 -->5177 -->5178 -->5179 -->518 -->5180 -->5181 -->5182 -->5183 -->5184 -->5185 -->5186 -->5187 -->5188 -->5189 -->519 -->5190 -->5191 -->5192 -->5193 -->5194 -->5195 -->5196 -->5197 -->5198 -->5199 -->52 -->520 -->5200 -->5201 -->5202 -->5203 -->5204 -->5205 -->5206 -->5207 -->5208 -->5209 -->521 -->5210 -->5211 -->5212 -->5213 -->5214 -->5215 -->5216 -->5217 -->5218 -->5219 -->522 -->5220 -->5221 -->5222 -->5223 -->5224 -->5225 -->5226 -->5227 -->5228 -->5229 -->523 -->5230 -->5231 -->5232 -->5233 -->5234 -->5235 -->5236 -->5237 -->5238 -->5239 -->524 -->5240 -->5241 -->5242 -->5243 -->5244 -->5245 -->5246 -->5247 -->5248 -->5249 -->525 -->5250 -->5251 -->5252 -->5253 -->5254 -->5255 -->5256 -->5257 -->5258 -->5259 -->526 -->5260 -->5261 -->5262 -->5263 -->5264 -->5265 -->5266 -->5267 -->5268 -->5269 -->527 -->5270 -->5271 -->5272 -->5273 -->5274 -->5275 -->5276 -->5277 -->5278 -->5279 -->528 -->5280 -->5281 -->5282 -->5283 -->5284 -->5285 -->5286 -->5287 -->5288 -->5289 -->529 -->5290 -->5291 -->5292 -->5293 -->5294 -->5295 -->5296 -->5297 -->5298 -->5299 -->53 -->530 -->5300 -->5301 -->5302 -->5303 -->5304 -->5305 -->5306 -->5307 -->5308 -->5309 -->531 -->5310 -->5311 -->5312 -->5313 -->5314 -->5315 -->5316 -->5317 -->5318 -->5319 -->532 -->5320 -->5321 -->5322 -->5323 -->5324 -->5325 -->5326 -->5327 -->5328 -->5329 -->533 -->5330 -->5331 -->5332 -->5333 -->5334 -->5335 -->5336 -->5337 -->5338 -->5339 -->534 -->5340 -->5341 -->5342 -->5343 -->5344 -->5345 -->5346 -->5347 -->5348 -->5349 -->535 -->5350 -->5351 -->5352 -->5353 -->5354 -->5355 -->5356 -->5357 -->5358 -->5359 -->536 -->5360 -->5361 -->5362 -->5363 -->5364 -->5365 -->5366 -->5367 -->5368 -->5369 -->537 -->5370 -->5371 -->5372 -->5373 -->5374 -->5375 -->5376 -->5377 -->5378 -->5379 -->538 -->5380 -->5381 -->5382 -->5383 -->5384 -->5385 -->5386 -->5387 -->5388 -->5389 -->539 -->5390 -->5391 -->5392 -->5393 -->5394 -->5395 -->5396 -->5397 -->5398 -->5399 -->54 -->540 -->5400 -->5401 -->5402 -->5403 -->5404 -->5405 -->5406 -->5407 -->5408 -->5409 -->541 -->5410 -->5411 -->5412 -->5413 -->5414 -->5415 -->5416 -->5417 -->5418 -->5419 -->542 -->5420 -->5421 -->5422 -->5423 -->5424 -->5425 -->5426 -->5427 -->5428 -->5429 -->543 -->5430 -->5431 -->5432 -->5433 -->5434 -->5435 -->5436 -->5437 -->5438 -->5439 -->544 -->5440 -->5441 -->5442 -->5443 -->5444 -->5445 -->5446 -->5447 -->5448 -->5449 -->545 -->5450 -->5451 -->5452 -->5453 -->5454 -->5455 -->5456 -->5457 -->5458 -->5459 -->546 -->5460 -->5461 -->5462 -->5463 -->5464 -->5465 -->5466 -->5467 -->5468 -->5469 -->547 -->5470 -->5471 -->5472 -->5473 -->5474 -->5475 -->5476 -->5477 -->5478 -->5479 -->548 -->5480 -->5481 -->5482 -->5483 -->5484 -->5485 -->5486 -->5487 -->5488 -->5489 -->549 -->5490 -->5491 -->5492 -->5493 -->5494 -->5495 -->5496 -->5497 -->5498 -->5499 -->55 -->550 -->5500 -->5501 -->5502 -->5503 -->5504 -->5505 -->5506 -->5507 -->5508 -->5509 -->551 -->5510 -->5511 -->5512 -->5513 -->5514 -->5515 -->5516 -->5517 -->5518 -->5519 -->552 -->5520 -->5521 -->5522 -->5523 -->5524 -->5525 -->5526 -->5527 -->5528 -->5529 -->553 -->5530 -->5531 -->5532 -->5533 -->5534 -->5535 -->5536 -->5537 -->5538 -->5539 -->554 -->5540 -->5541 -->5542 -->5543 -->5544 -->5545 -->5546 -->5547 -->5548 -->5549 -->555 -->5550 -->5551 -->5552 -->5553 -->5554 -->5555 -->5556 -->5557 -->5558 -->5559 -->556 -->5560 -->5561 -->5562 -->5563 -->5564 -->5565 -->5566 -->5567 -->5568 -->5569 -->557 -->5570 -->5571 -->5572 -->5573 -->5574 -->5575 -->5576 -->5577 -->5578 -->5579 -->558 -->5580 -->5581 -->5582 -->5583 -->5584 -->5585 -->5586 -->5587 -->5588 -->5589 -->559 -->5590 -->5591 -->5592 -->5593 -->5594 -->5595 -->5596 -->5597 -->5598 -->5599 -->56 -->560 -->5600 -->5601 -->5602 -->5603 -->5604 -->5605 -->5606 -->5607 -->5608 -->5609 -->561 -->5610 -->5611 -->5612 -->5613 -->5614 -->5615 -->5616 -->5617 -->5618 -->5619 -->562 -->5620 -->5621 -->5622 -->5623 -->5624 -->5625 -->5626 -->5627 -->5628 -->5629 -->563 -->5630 -->5631 -->5632 -->5633 -->5634 -->5635 -->5636 -->5637 -->5638 -->5639 -->564 -->5640 -->5641 -->5642 -->5643 -->5644 -->5645 -->5646 -->5647 -->5648 -->5649 -->565 -->5650 -->5651 -->5652 -->5653 -->5654 -->5655 -->5656 -->5657 -->5658 -->5659 -->566 -->5660 -->5661 -->5662 -->5663 -->5664 -->5665 -->5666 -->5667 -->5668 -->5669 -->567 -->5670 -->5671 -->5672 -->5673 -->5674 -->5675 -->5676 -->5677 -->5678 -->5679 -->568 -->5680 -->5681 -->5682 -->5683 -->5684 -->5685 -->5686 -->5687 -->5688 -->5689 -->569 -->5690 -->5691 -->5692 -->5693 -->5694 -->5695 -->5696 -->5697 -->5698 -->5699 -->57 -->570 -->5700 -->5701 -->5702 -->5703 -->5704 -->5705 -->5706 -->5707 -->5708 -->5709 -->571 -->5710 -->5711 -->5712 -->5713 -->5714 -->5715 -->5716 -->5717 -->5718 -->5719 -->572 -->5720 -->5721 -->5722 -->5723 -->5724 -->5725 -->5726 -->5727 -->5728 -->5729 -->573 -->5730 -->5731 -->5732 -->5733 -->5734 -->5735 -->5736 -->5737 -->5738 -->5739 -->574 -->5740 -->5741 -->5742 -->5743 -->5744 -->5745 -->5746 -->5747 -->5748 -->5749 -->575 -->5750 -->5751 -->5752 -->5753 -->5754 -->5755 -->5756 -->5757 -->5758 -->5759 -->576 -->5760 -->5761 -->5762 -->5763 -->5764 -->5765 -->5766 -->5767 -->5768 -->5769 -->577 -->5770 -->5771 -->5772 -->5773 -->5774 -->5775 -->5776 -->5777 -->5778 -->5779 -->578 -->5780 -->5781 -->5782 -->5783 -->5784 -->5785 -->5786 -->5787 -->5788 -->5789 -->579 -->5790 -->5791 -->5792 -->5793 -->5794 -->5795 -->5796 -->5797 -->5798 -->5799 -->58 -->580 -->5800 -->5801 -->5802 -->5803 -->5804 -->5805 -->5806 -->5807 -->5808 -->5809 -->581 -->5810 -->5811 -->5812 -->5813 -->5814 -->5815 -->5816 -->5817 -->5818 -->5819 -->582 -->5820 -->5821 -->5822 -->5823 -->5824 -->5825 -->5826 -->5827 -->5828 -->5829 -->583 -->5830 -->5831 -->5832 -->5833 -->5834 -->5835 -->5836 -->5837 -->5838 -->5839 -->584 -->5840 -->5841 -->5842 -->5843 -->5844 -->5845 -->5846 -->5847 -->5848 -->5849 -->585 -->5850 -->5851 -->5852 -->5853 -->5854 -->5855 -->5856 -->5857 -->5858 -->5859 -->586 -->5860 -->5861 -->5862 -->5863 -->5864 -->5865 -->5866 -->5867 -->5868 -->5869 -->587 -->5870 -->5871 -->5872 -->5873 -->5874 -->5875 -->5876 -->5877 -->5878 -->5879 -->588 -->5880 -->5881 -->5882 -->5883 -->5884 -->5885 -->5886 -->5887 -->5888 -->5889 -->589 -->5890 -->5891 -->5892 -->5893 -->5894 -->5895 -->5896 -->5897 -->5898 -->5899 -->59 -->590 -->5900 -->5901 -->5902 -->5903 -->5904 -->5905 -->5906 -->5907 -->5908 -->5909 -->591 -->5910 -->5911 -->5912 -->5913 -->5914 -->5915 -->5916 -->5917 -->5918 -->5919 -->592 -->5920 -->5921 -->5922 -->5923 -->5924 -->5925 -->5926 -->5927 -->5928 -->5929 -->593 -->5930 -->5931 -->5932 -->5933 -->5934 -->5935 -->5936 -->5937 -->5938 -->5939 -->594 -->5940 -->5941 -->5942 -->5943 -->5944 -->5945 -->5946 -->5947 -->5948 -->5949 -->595 -->5950 -->5951 -->5952 -->5953 -->5954 -->5955 -->5956 -->5957 -->5958 -->5959 -->596 -->5960 -->5961 -->5962 -->5963 -->5964 -->5965 -->5966 -->5967 -->5968 -->5969 -->597 -->5970 -->5971 -->5972 -->5973 -->5974 -->5975 -->5976 -->5977 -->5978 -->5979 -->598 -->5980 -->5981 -->5982 -->5983 -->5984 -->5985 -->5986 -->5987 -->5988 -->5989 -->599 -->5990 -->5991 -->5992 -->5993 -->5994 -->5995 -->5996 -->5997 -->5998 -->5999 -->6 -->60 -->600 -->6000 -->6001 -->6002 -->6003 -->6004 -->6005 -->6006 -->6007 -->6008 -->6009 -->601 -->6010 -->6011 -->6012 -->6013 -->6014 -->6015 -->6016 -->6017 -->6018 -->6019 -->602 -->6020 -->6021 -->6022 -->6023 -->6024 -->6025 -->6026 -->6027 -->6028 -->6029 -->603 -->6030 -->6031 -->6032 -->6033 -->6034 -->6035 -->6036 -->6037 -->6038 -->6039 -->604 -->6040 -->6041 -->6042 -->6043 -->6044 -->6045 -->6046 -->6047 -->6048 -->6049 -->605 -->6050 -->6051 -->6052 -->6053 -->6054 -->6055 -->6056 -->6057 -->6058 -->6059 -->606 -->6060 -->6061 -->6062 -->6063 -->6064 -->6065 -->6066 -->6067 -->6068 -->6069 -->607 -->6070 -->6071 -->6072 -->6073 -->6074 -->6075 -->6076 -->6077 -->6078 -->6079 -->608 -->6080 -->6081 -->6082 -->6083 -->6084 -->6085 -->6086 -->6087 -->6088 -->6089 -->609 -->6090 -->6091 -->6092 -->6093 -->6094 -->6095 -->6096 -->6097 -->6098 -->6099 -->61 -->610 -->6100 -->6101 -->6102 -->6103 -->6104 -->6105 -->6106 -->6107 -->6108 -->6109 -->611 -->6110 -->6111 -->6112 -->6113 -->6114 -->6115 -->6116 -->6117 -->6118 -->6119 -->612 -->6120 -->6121 -->6122 -->6123 -->6124 -->6125 -->6126 -->6127 -->6128 -->6129 -->613 -->6130 -->6131 -->6132 -->6133 -->6134 -->6135 -->6136 -->6137 -->6138 -->6139 -->614 -->6140 -->6141 -->6142 -->6143 -->6144 -->6145 -->6146 -->6147 -->6148 -->6149 -->615 -->6150 -->6151 -->6152 -->6153 -->6154 -->6155 -->6156 -->6157 -->6158 -->6159 -->616 -->6160 -->6161 -->6162 -->6163 -->6164 -->6165 -->6166 -->6167 -->6168 -->6169 -->617 -->6170 -->6171 -->6172 -->6173 -->6174 -->6175 -->6176 -->6177 -->6178 -->6179 -->618 -->6180 -->6181 -->6182 -->6183 -->6184 -->6185 -->6186 -->6187 -->6188 -->6189 -->619 -->6190 -->6191 -->6192 -->6193 -->6194 -->6195 -->6196 -->6197 -->6198 -->6199 -->62 -->620 -->6200 -->6201 -->6202 -->6203 -->6204 -->6205 -->6206 -->6207 -->6208 -->6209 -->621 -->6210 -->6211 -->6212 -->6213 -->6214 -->6215 -->6216 -->6217 -->6218 -->6219 -->622 -->6220 -->6221 -->6222 -->6223 -->6224 -->6225 -->6226 -->6227 -->6228 -->6229 -->623 -->6230 -->6231 -->6232 -->6233 -->6234 -->6235 -->6236 -->6237 -->6238 -->6239 -->624 -->6240 -->6241 -->6242 -->6243 -->6244 -->6245 -->6246 -->6247 -->6248 -->6249 -->625 -->6250 -->6251 -->6252 -->6253 -->6254 -->6255 -->6256 -->6257 -->6258 -->6259 -->626 -->6260 -->6261 -->6262 -->6263 -->6264 -->6265 -->6266 -->6267 -->6268 -->6269 -->627 -->6270 -->6271 -->6272 -->6273 -->6274 -->6275 -->6276 -->6277 -->6278 -->6279 -->628 -->6280 -->6281 -->6282 -->6283 -->6284 -->6285 -->6286 -->6287 -->6288 -->6289 -->629 -->6290 -->6291 -->6292 -->6293 -->6294 -->6295 -->6296 -->6297 -->6298 -->6299 -->63 -->630 -->6300 -->6301 -->6302 -->6303 -->6304 -->6305 -->6306 -->6307 -->6308 -->6309 -->631 -->6310 -->6311 -->6312 -->6313 -->6314 -->6315 -->6316 -->6317 -->6318 -->6319 -->632 -->6320 -->6321 -->6322 -->6323 -->6324 -->6325 -->6326 -->6327 -->6328 -->6329 -->633 -->6330 -->6331 -->6332 -->6333 -->6334 -->6335 -->6336 -->6337 -->6338 -->6339 -->634 -->6340 -->6341 -->6342 -->6343 -->6344 -->6345 -->6346 -->6347 -->6348 -->6349 -->635 -->6350 -->6351 -->6352 -->6353 -->6354 -->6355 -->6356 -->6357 -->6358 -->6359 -->636 -->6360 -->6361 -->6362 -->6363 -->6364 -->6365 -->6366 -->6367 -->6368 -->6369 -->637 -->6370 -->6371 -->6372 -->6373 -->6374 -->6375 -->6376 -->6377 -->6378 -->6379 -->638 -->6380 -->6381 -->6382 -->6383 -->6384 -->6385 -->6386 -->6387 -->6388 -->6389 -->639 -->6390 -->6391 -->6392 -->6393 -->6394 -->6395 -->6396 -->6397 -->6398 -->6399 -->64 -->640 -->6400 -->6401 -->6402 -->6403 -->6404 -->6405 -->6406 -->6407 -->6408 -->6409 -->641 -->6410 -->6411 -->6412 -->6413 -->6414 -->6415 -->6416 -->6417 -->6418 -->6419 -->642 -->6420 -->6421 -->6422 -->6423 -->6424 -->6425 -->6426 -->6427 -->6428 -->6429 -->643 -->6430 -->6431 -->6432 -->6433 -->6434 -->6435 -->6436 -->6437 -->6438 -->6439 -->644 -->6440 -->6441 -->6442 -->6443 -->6444 -->6445 -->6446 -->6447 -->6448 -->6449 -->645 -->6450 -->6451 -->6452 -->6453 -->6454 -->6455 -->6456 -->6457 -->6458 -->6459 -->646 -->6460 -->6461 -->6462 -->6463 -->6464 -->6465 -->6466 -->6467 -->6468 -->6469 -->647 -->6470 -->6471 -->6472 -->6473 -->6474 -->6475 -->6476 -->6477 -->6478 -->6479 -->648 -->6480 -->6481 -->6482 -->6483 -->6484 -->6485 -->6486 -->6487 -->6488 -->6489 -->649 -->6490 -->6491 -->6492 -->6493 -->6494 -->6495 -->6496 -->6497 -->6498 -->6499 -->65 -->650 -->6500 -->6501 -->6502 -->6503 -->6504 -->6505 -->6506 -->6507 -->6508 -->6509 -->651 -->6510 -->6511 -->6512 -->6513 -->6514 -->6515 -->6516 -->6517 -->6518 -->6519 -->652 -->6520 -->6521 -->6522 -->6523 -->6524 -->6525 -->6526 -->6527 -->6528 -->6529 -->653 -->6530 -->6531 -->6532 -->6533 -->6534 -->6535 -->6536 -->6537 -->6538 -->6539 -->654 -->6540 -->6541 -->6542 -->6543 -->6544 -->6545 -->6546 -->6547 -->6548 -->6549 -->655 -->6550 -->6551 -->6552 -->6553 -->6554 -->6555 -->6556 -->6557 -->6558 -->6559 -->656 -->6560 -->6561 -->6562 -->6563 -->6564 -->6565 -->6566 -->6567 -->6568 -->6569 -->657 -->6570 -->6571 -->6572 -->6573 -->6574 -->6575 -->6576 -->6577 -->6578 -->6579 -->658 -->6580 -->6581 -->6582 -->6583 -->6584 -->6585 -->6586 -->6587 -->6588 -->6589 -->659 -->6590 -->6591 -->6592 -->6593 -->6594 -->6595 -->6596 -->6597 -->6598 -->6599 -->66 -->660 -->6600 -->6601 -->6602 -->6603 -->6604 -->6605 -->6606 -->6607 -->6608 -->6609 -->661 -->6610 -->6611 -->6612 -->6613 -->6614 -->6615 -->6616 -->6617 -->6618 -->6619 -->662 -->6620 -->6621 -->6622 -->6623 -->6624 -->6625 -->6626 -->6627 -->6628 -->6629 -->663 -->6630 -->6631 -->6632 -->6633 -->6634 -->6635 -->6636 -->6637 -->6638 -->6639 -->664 -->6640 -->6641 -->6642 -->6643 -->6644 -->6645 -->6646 -->6647 -->6648 -->6649 -->665 -->6650 -->6651 -->6652 -->6653 -->6654 -->6655 -->6656 -->6657 -->6658 -->6659 -->666 -->6660 -->6661 -->6662 -->6663 -->6664 -->6665 -->6666 -->6667 -->6668 -->6669 -->667 -->6670 -->6671 -->6672 -->6673 -->6674 -->6675 -->6676 -->6677 -->6678 -->6679 -->668 -->6680 -->6681 -->6682 -->6683 -->6684 -->6685 -->6686 -->6687 -->6688 -->6689 -->669 -->6690 -->6691 -->6692 -->6693 -->6694 -->6695 -->6696 -->6697 -->6698 -->6699 -->67 -->670 -->6700 -->6701 -->6702 -->6703 -->6704 -->6705 -->6706 -->6707 -->6708 -->6709 -->671 -->6710 -->6711 -->6712 -->6713 -->6714 -->6715 -->6716 -->6717 -->6718 -->6719 -->672 -->6720 -->6721 -->6722 -->6723 -->6724 -->6725 -->6726 -->6727 -->6728 -->6729 -->673 -->6730 -->6731 -->6732 -->6733 -->6734 -->6735 -->6736 -->6737 -->6738 -->6739 -->674 -->6740 -->6741 -->6742 -->6743 -->6744 -->6745 -->6746 -->6747 -->6748 -->6749 -->675 -->6750 -->6751 -->6752 -->6753 -->6754 -->6755 -->6756 -->6757 -->6758 -->6759 -->676 -->6760 -->6761 -->6762 -->6763 -->6764 -->6765 -->6766 -->6767 -->6768 -->6769 -->677 -->6770 -->6771 -->6772 -->6773 -->6774 -->6775 -->6776 -->6777 -->6778 -->6779 -->678 -->6780 -->6781 -->6782 -->6783 -->6784 -->6785 -->6786 -->6787 -->6788 -->6789 -->679 -->6790 -->6791 -->6792 -->6793 -->6794 -->6795 -->6796 -->6797 -->6798 -->6799 -->68 -->680 -->6800 -->6801 -->6802 -->6803 -->6804 -->6805 -->6806 -->6807 -->6808 -->6809 -->681 -->6810 -->6811 -->6812 -->6813 -->6814 -->6815 -->6816 -->6817 -->6818 -->6819 -->682 -->6820 -->6821 -->6822 -->6823 -->6824 -->6825 -->6826 -->6827 -->6828 -->6829 -->683 -->6830 -->6831 -->6832 -->6833 -->6834 -->6835 -->6836 -->6837 -->6838 -->6839 -->684 -->6840 -->6841 -->6842 -->6843 -->6844 -->6845 -->6846 -->6847 -->6848 -->6849 -->685 -->6850 -->6851 -->6852 -->6853 -->6854 -->6855 -->6856 -->6857 -->6858 -->6859 -->686 -->6860 -->6861 -->6862 -->6863 -->6864 -->6865 -->6866 -->6867 -->6868 -->6869 -->687 -->6870 -->6871 -->6872 -->6873 -->6874 -->6875 -->6876 -->6877 -->6878 -->6879 -->688 -->6880 -->6881 -->6882 -->6883 -->6884 -->6885 -->6886 -->6887 -->6888 -->6889 -->689 -->6890 -->6891 -->6892 -->6893 -->6894 -->6895 -->6896 -->6897 -->6898 -->6899 -->69 -->690 -->6900 -->6901 -->6902 -->6903 -->6904 -->6905 -->6906 -->6907 -->6908 -->6909 -->691 -->6910 -->6911 -->6912 -->6913 -->6914 -->6915 -->6916 -->6917 -->6918 -->6919 -->692 -->6920 -->6921 -->6922 -->6923 -->6924 -->6925 -->6926 -->6927 -->6928 -->6929 -->693 -->6930 -->6931 -->6932 -->6933 -->6934 -->6935 -->6936 -->6937 -->6938 -->6939 -->694 -->6940 -->6941 -->6942 -->6943 -->6944 -->6945 -->6946 -->6947 -->6948 -->6949 -->695 -->6950 -->6951 -->6952 -->6953 -->6954 -->6955 -->6956 -->6957 -->6958 -->6959 -->696 -->6960 -->6961 -->6962 -->6963 -->6964 -->6965 -->6966 -->6967 -->6968 -->6969 -->697 -->6970 -->6971 -->6972 -->6973 -->6974 -->6975 -->6976 -->6977 -->6978 -->6979 -->698 -->6980 -->6981 -->6982 -->6983 -->6984 -->6985 -->6986 -->6987 -->6988 -->6989 -->699 -->6990 -->6991 -->6992 -->6993 -->6994 -->6995 -->6996 -->6997 -->6998 -->6999 -->7 -->70 -->700 -->7000 -->7001 -->7002 -->7003 -->7004 -->7005 -->7006 -->7007 -->7008 -->7009 -->701 -->7010 -->7011 -->7012 -->7013 -->7014 -->7015 -->7016 -->7017 -->7018 -->7019 -->702 -->7020 -->7021 -->7022 -->7023 -->7024 -->7025 -->7026 -->7027 -->7028 -->7029 -->703 -->7030 -->7031 -->7032 -->7033 -->7034 -->7035 -->7036 -->7037 -->7038 -->7039 -->704 -->7040 -->7041 -->7042 -->7043 -->7044 -->7045 -->7046 -->7047 -->7048 -->7049 -->705 -->7050 -->7051 -->7052 -->7053 -->7054 -->7055 -->7056 -->7057 -->7058 -->7059 -->706 -->7060 -->7061 -->7062 -->7063 -->7064 -->7065 -->7066 -->7067 -->7068 -->7069 -->707 -->7070 -->7071 -->7072 -->7073 -->7074 -->7075 -->7076 -->7077 -->7078 -->7079 -->708 -->7080 -->7081 -->7082 -->7083 -->7084 -->7085 -->7086 -->7087 -->7088 -->7089 -->709 -->7090 -->7091 -->7092 -->7093 -->7094 -->7095 -->7096 -->7097 -->7098 -->7099 -->71 -->710 -->7100 -->7101 -->7102 -->7103 -->7104 -->7105 -->7106 -->7107 -->7108 -->7109 -->711 -->7110 -->7111 -->7112 -->7113 -->7114 -->7115 -->7116 -->7117 -->7118 -->7119 -->712 -->7120 -->7121 -->7122 -->7123 -->7124 -->7125 -->7126 -->7127 -->7128 -->7129 -->713 -->7130 -->7131 -->7132 -->7133 -->7134 -->7135 -->7136 -->7137 -->7138 -->7139 -->714 -->7140 -->7141 -->7142 -->7143 -->7144 -->7145 -->7146 -->7147 -->7148 -->7149 -->715 -->7150 -->7151 -->7152 -->7153 -->7154 -->7155 -->7156 -->7157 -->7158 -->7159 -->716 -->7160 -->7161 -->7162 -->7163 -->7164 -->7165 -->7166 -->7167 -->7168 -->7169 -->717 -->7170 -->7171 -->7172 -->7173 -->7174 -->7175 -->7176 -->7177 -->7178 -->7179 -->718 -->7180 -->7181 -->7182 -->7183 -->7184 -->7185 -->7186 -->7187 -->7188 -->7189 -->719 -->7190 -->7191 -->7192 -->7193 -->7194 -->7195 -->7196 -->7197 -->7198 -->7199 -->72 -->720 -->7200 -->7201 -->7202 -->7203 -->7204 -->7205 -->7206 -->7207 -->7208 -->7209 -->721 -->7210 -->7211 -->7212 -->7213 -->7214 -->7215 -->7216 -->7217 -->7218 -->7219 -->722 -->7220 -->7221 -->7222 -->7223 -->7224 -->7225 -->7226 -->7227 -->7228 -->7229 -->723 -->7230 -->7231 -->7232 -->7233 -->7234 -->7235 -->7236 -->7237 -->7238 -->7239 -->724 -->7240 -->7241 -->7242 -->7243 -->7244 -->7245 -->7246 -->7247 -->7248 -->7249 -->725 -->7250 -->7251 -->7252 -->7253 -->7254 -->7255 -->7256 -->7257 -->7258 -->7259 -->726 -->7260 -->7261 -->7262 -->7263 -->7264 -->7265 -->7266 -->7267 -->7268 -->7269 -->727 -->7270 -->7271 -->7272 -->7273 -->7274 -->7275 -->7276 -->7277 -->7278 -->7279 -->728 -->7280 -->7281 -->7282 -->7283 -->7284 -->7285 -->7286 -->7287 -->7288 -->7289 -->729 -->7290 -->7291 -->7292 -->7293 -->7294 -->7295 -->7296 -->7297 -->7298 -->7299 -->73 -->730 -->7300 -->7301 -->7302 -->7303 -->7304 -->7305 -->7306 -->7307 -->7308 -->7309 -->731 -->7310 -->7311 -->7312 -->7313 -->7314 -->7315 -->7316 -->7317 -->7318 -->7319 -->732 -->7320 -->7321 -->7322 -->7323 -->7324 -->7325 -->7326 -->7327 -->7328 -->7329 -->733 -->7330 -->7331 -->7332 -->7333 -->7334 -->7335 -->7336 -->7337 -->7338 -->7339 -->734 -->7340 -->7341 -->7342 -->7343 -->7344 -->7345 -->7346 -->7347 -->7348 -->7349 -->735 -->7350 -->7351 -->7352 -->7353 -->7354 -->7355 -->7356 -->7357 -->7358 -->7359 -->736 -->7360 -->7361 -->7362 -->7363 -->7364 -->7365 -->7366 -->7367 -->7368 -->7369 -->737 -->7370 -->7371 -->7372 -->7373 -->7374 -->7375 -->7376 -->7377 -->7378 -->7379 -->738 -->7380 -->7381 -->7382 -->7383 -->7384 -->7385 -->7386 -->7387 -->7388 -->7389 -->739 -->7390 -->7391 -->7392 -->7393 -->7394 -->7395 -->7396 -->7397 -->7398 -->7399 -->74 -->740 -->7400 -->7401 -->7402 -->7403 -->7404 -->7405 -->7406 -->7407 -->7408 -->7409 -->741 -->7410 -->7411 -->7412 -->7413 -->7414 -->7415 -->7416 -->7417 -->7418 -->7419 -->742 -->7420 -->7421 -->7422 -->7423 -->7424 -->7425 -->7426 -->7427 -->7428 -->7429 -->743 -->7430 -->7431 -->7432 -->7433 -->7434 -->7435 -->7436 -->7437 -->7438 -->7439 -->744 -->7440 -->7441 -->7442 -->7443 -->7444 -->7445 -->7446 -->7447 -->7448 -->7449 -->745 -->7450 -->7451 -->7452 -->7453 -->7454 -->7455 -->7456 -->7457 -->7458 -->7459 -->746 -->7460 -->7461 -->7462 -->7463 -->7464 -->7465 -->7466 -->7467 -->7468 -->7469 -->747 -->7470 -->7471 -->7472 -->7473 -->7474 -->7475 -->7476 -->7477 -->7478 -->7479 -->748 -->7480 -->7481 -->7482 -->7483 -->7484 -->7485 -->7486 -->7487 -->7488 -->7489 -->749 -->7490 -->7491 -->7492 -->7493 -->7494 -->7495 -->7496 -->7497 -->7498 -->7499 -->75 -->750 -->7500 -->7501 -->7502 -->7503 -->7504 -->7505 -->7506 -->7507 -->7508 -->7509 -->751 -->7510 -->7511 -->7512 -->7513 -->7514 -->7515 -->7516 -->7517 -->7518 -->7519 -->752 -->7520 -->7521 -->7522 -->7523 -->7524 -->7525 -->7526 -->7527 -->7528 -->7529 -->753 -->7530 -->7531 -->7532 -->7533 -->7534 -->7535 -->7536 -->7537 -->7538 -->7539 -->754 -->7540 -->7541 -->7542 -->7543 -->7544 -->7545 -->7546 -->7547 -->7548 -->7549 -->755 -->7550 -->7551 -->7552 -->7553 -->7554 -->7555 -->7556 -->7557 -->7558 -->7559 -->756 -->7560 -->7561 -->7562 -->7563 -->7564 -->7565 -->7566 -->7567 -->7568 -->7569 -->757 -->7570 -->7571 -->7572 -->7573 -->7574 -->7575 -->7576 -->7577 -->7578 -->7579 -->758 -->7580 -->7581 -->7582 -->7583 -->7584 -->7585 -->7586 -->7587 -->7588 -->7589 -->759 -->7590 -->7591 -->7592 -->7593 -->7594 -->7595 -->7596 -->7597 -->7598 -->7599 -->76 -->760 -->7600 -->7601 -->7602 -->7603 -->7604 -->7605 -->7606 -->7607 -->7608 -->7609 -->761 -->7610 -->7611 -->7612 -->7613 -->7614 -->7615 -->7616 -->7617 -->7618 -->7619 -->762 -->7620 -->7621 -->7622 -->7623 -->7624 -->7625 -->7626 -->7627 -->7628 -->7629 -->763 -->7630 -->7631 -->7632 -->7633 -->7634 -->7635 -->7636 -->7637 -->7638 -->7639 -->764 -->7640 -->7641 -->7642 -->7643 -->7644 -->7645 -->7646 -->7647 -->7648 -->7649 -->765 -->7650 -->7651 -->7652 -->7653 -->7654 -->7655 -->7656 -->7657 -->7658 -->7659 -->766 -->7660 -->7661 -->7662 -->7663 -->7664 -->7665 -->7666 -->7667 -->7668 -->7669 -->767 -->7670 -->7671 -->7672 -->7673 -->7674 -->7675 -->7676 -->7677 -->7678 -->7679 -->768 -->7680 -->7681 -->7682 -->7683 -->7684 -->7685 -->7686 -->7687 -->7688 -->7689 -->769 -->7690 -->7691 -->7692 -->7693 -->7694 -->7695 -->7696 -->7697 -->7698 -->7699 -->77 -->770 -->7700 -->7701 -->7702 -->7703 -->7704 -->7705 -->7706 -->7707 -->7708 -->7709 -->771 -->7710 -->7711 -->7712 -->7713 -->7714 -->7715 -->7716 -->7717 -->7718 -->7719 -->772 -->7720 -->7721 -->7722 -->7723 -->7724 -->7725 -->7726 -->7727 -->7728 -->7729 -->773 -->7730 -->7731 -->7732 -->7733 -->7734 -->7735 -->7736 -->7737 -->7738 -->7739 -->774 -->7740 -->7741 -->7742 -->7743 -->7744 -->7745 -->7746 -->7747 -->7748 -->7749 -->775 -->7750 -->7751 -->7752 -->7753 -->7754 -->7755 -->7756 -->7757 -->7758 -->7759 -->776 -->7760 -->7761 -->7762 -->7763 -->7764 -->7765 -->7766 -->7767 -->7768 -->7769 -->777 -->7770 -->7771 -->7772 -->7773 -->7774 -->7775 -->7776 -->7777 -->7778 -->7779 -->778 -->7780 -->7781 -->7782 -->7783 -->7784 -->7785 -->7786 -->7787 -->7788 -->7789 -->779 -->7790 -->7791 -->7792 -->7793 -->7794 -->7795 -->7796 -->7797 -->7798 -->7799 -->78 -->780 -->7800 -->7801 -->7802 -->7803 -->7804 -->7805 -->7806 -->7807 -->7808 -->7809 -->781 -->7810 -->7811 -->7812 -->7813 -->7814 -->7815 -->7816 -->7817 -->7818 -->7819 -->782 -->7820 -->7821 -->7822 -->7823 -->7824 -->7825 -->7826 -->7827 -->7828 -->7829 -->783 -->7830 -->7831 -->7832 -->7833 -->7834 -->7835 -->7836 -->7837 -->7838 -->7839 -->784 -->7840 -->7841 -->7842 -->7843 -->7844 -->7845 -->7846 -->7847 -->7848 -->7849 -->785 -->7850 -->7851 -->7852 -->7853 -->7854 -->7855 -->7856 -->7857 -->7858 -->7859 -->786 -->7860 -->7861 -->7862 -->7863 -->7864 -->7865 -->7866 -->7867 -->7868 -->7869 -->787 -->7870 -->7871 -->7872 -->7873 -->7874 -->7875 -->7876 -->7877 -->7878 -->7879 -->788 -->7880 -->7881 -->7882 -->7883 -->7884 -->7885 -->7886 -->7887 -->7888 -->7889 -->789 -->7890 -->7891 -->7892 -->7893 -->7894 -->7895 -->7896 -->7897 -->7898 -->7899 -->79 -->790 -->7900 -->7901 -->7902 -->7903 -->7904 -->7905 -->7906 -->7907 -->7908 -->7909 -->791 -->7910 -->7911 -->7912 -->7913 -->7914 -->7915 -->7916 -->7917 -->7918 -->7919 -->792 -->7920 -->7921 -->7922 -->7923 -->7924 -->7925 -->7926 -->7927 -->7928 -->7929 -->793 -->7930 -->7931 -->7932 -->7933 -->7934 -->7935 -->7936 -->7937 -->7938 -->7939 -->794 -->7940 -->7941 -->7942 -->7943 -->7944 -->7945 -->7946 -->7947 -->7948 -->7949 -->795 -->7950 -->7951 -->7952 -->7953 -->7954 -->7955 -->7956 -->7957 -->7958 -->7959 -->796 -->7960 -->7961 -->7962 -->7963 -->7964 -->7965 -->7966 -->7967 -->7968 -->7969 -->797 -->7970 -->7971 -->7972 -->7973 -->7974 -->7975 -->7976 -->7977 -->7978 -->7979 -->798 -->7980 -->7981 -->7982 -->7983 -->7984 -->7985 -->7986 -->7987 -->7988 -->7989 -->799 -->7990 -->7991 -->7992 -->7993 -->7994 -->7995 -->7996 -->7997 -->7998 -->7999 -->8 -->80 -->800 -->8000 -->8001 -->8002 -->8003 -->8004 -->8005 -->8006 -->8007 -->8008 -->8009 -->801 -->8010 -->8011 -->8012 -->8013 -->8014 -->8015 -->8016 -->8017 -->8018 -->8019 -->802 -->8020 -->8021 -->8022 -->8023 -->8024 -->8025 -->8026 -->8027 -->8028 -->8029 -->803 -->8030 -->8031 -->8032 -->8033 -->8034 -->8035 -->8036 -->8037 -->8038 -->8039 -->804 -->8040 -->8041 -->8042 -->8043 -->8044 -->8045 -->8046 -->8047 -->8048 -->8049 -->805 -->8050 -->8051 -->8052 -->8053 -->8054 -->8055 -->8056 -->8057 -->8058 -->8059 -->806 -->8060 -->8061 -->8062 -->8063 -->8064 -->8065 -->8066 -->8067 -->8068 -->8069 -->807 -->8070 -->8071 -->8072 -->8073 -->8074 -->8075 -->8076 -->8077 -->8078 -->8079 -->808 -->8080 -->8081 -->8082 -->8083 -->8084 -->8085 -->8086 -->8087 -->8088 -->8089 -->809 -->8090 -->8091 -->8092 -->8093 -->8094 -->8095 -->8096 -->8097 -->8098 -->8099 -->81 -->810 -->8100 -->8101 -->8102 -->8103 -->8104 -->8105 -->8106 -->8107 -->8108 -->8109 -->811 -->8110 -->8111 -->8112 -->8113 -->8114 -->8115 -->8116 -->8117 -->8118 -->8119 -->812 -->8120 -->8121 -->8122 -->8123 -->8124 -->8125 -->8126 -->8127 -->8128 -->8129 -->813 -->8130 -->8131 -->8132 -->8133 -->8134 -->8135 -->8136 -->8137 -->8138 -->8139 -->814 -->8140 -->8141 -->8142 -->8143 -->8144 -->8145 -->8146 -->8147 -->8148 -->8149 -->815 -->8150 -->8151 -->8152 -->8153 -->8154 -->8155 -->8156 -->8157 -->8158 -->8159 -->816 -->8160 -->8161 -->8162 -->8163 -->8164 -->8165 -->8166 -->8167 -->8168 -->8169 -->817 -->8170 -->8171 -->8172 -->8173 -->8174 -->8175 -->8176 -->8177 -->8178 -->8179 -->818 -->8180 -->8181 -->8182 -->8183 -->8184 -->8185 -->8186 -->8187 -->8188 -->8189 -->819 -->8190 -->8191 -->8192 -->8193 -->8194 -->8195 -->8196 -->8197 -->8198 -->8199 -->82 -->820 -->8200 -->8201 -->8202 -->8203 -->8204 -->8205 -->8206 -->8207 -->8208 -->8209 -->821 -->8210 -->8211 -->8212 -->8213 -->8214 -->8215 -->8216 -->8217 -->8218 -->8219 -->822 -->8220 -->8221 -->8222 -->8223 -->8224 -->8225 -->8226 -->8227 -->8228 -->8229 -->823 -->8230 -->8231 -->8232 -->8233 -->8234 -->8235 -->8236 -->8237 -->8238 -->8239 -->824 -->8240 -->8241 -->8242 -->8243 -->8244 -->8245 -->8246 -->8247 -->8248 -->8249 -->825 -->8250 -->8251 -->8252 -->8253 -->8254 -->8255 -->8256 -->8257 -->8258 -->8259 -->826 -->8260 -->8261 -->8262 -->8263 -->8264 -->8265 -->8266 -->8267 -->8268 -->8269 -->827 -->8270 -->8271 -->8272 -->8273 -->8274 -->8275 -->8276 -->8277 -->8278 -->8279 -->828 -->8280 -->8281 -->8282 -->8283 -->8284 -->8285 -->8286 -->8287 -->8288 -->8289 -->829 -->8290 -->8291 -->8292 -->8293 -->8294 -->8295 -->8296 -->8297 -->8298 -->8299 -->83 -->830 -->8300 -->8301 -->8302 -->8303 -->8304 -->8305 -->8306 -->8307 -->8308 -->8309 -->831 -->8310 -->8311 -->8312 -->8313 -->8314 -->8315 -->8316 -->8317 -->8318 -->8319 -->832 -->8320 -->8321 -->8322 -->8323 -->8324 -->8325 -->8326 -->8327 -->8328 -->8329 -->833 -->8330 -->8331 -->8332 -->8333 -->8334 -->8335 -->8336 -->8337 -->8338 -->8339 -->834 -->8340 -->8341 -->8342 -->8343 -->8344 -->8345 -->8346 -->8347 -->8348 -->8349 -->835 -->8350 -->8351 -->8352 -->8353 -->8354 -->8355 -->8356 -->8357 -->8358 -->8359 -->836 -->8360 -->8361 -->8362 -->8363 -->8364 -->8365 -->8366 -->8367 -->8368 -->8369 -->837 -->8370 -->8371 -->8372 -->8373 -->8374 -->8375 -->8376 -->8377 -->8378 -->8379 -->838 -->8380 -->8381 -->8382 -->8383 -->8384 -->8385 -->8386 -->8387 -->8388 -->8389 -->839 -->8390 -->8391 -->8392 -->8393 -->8394 -->8395 -->8396 -->8397 -->8398 -->8399 -->84 -->840 -->8400 -->8401 -->8402 -->8403 -->8404 -->8405 -->8406 -->8407 -->8408 -->8409 -->841 -->8410 -->8411 -->8412 -->8413 -->8414 -->8415 -->8416 -->8417 -->8418 -->8419 -->842 -->8420 -->8421 -->8422 -->8423 -->8424 -->8425 -->8426 -->8427 -->8428 -->8429 -->843 -->8430 -->8431 -->8432 -->8433 -->8434 -->8435 -->8436 -->8437 -->8438 -->8439 -->844 -->8440 -->8441 -->8442 -->8443 -->8444 -->8445 -->8446 -->8447 -->8448 -->8449 -->845 -->8450 -->8451 -->8452 -->8453 -->8454 -->8455 -->8456 -->8457 -->8458 -->8459 -->846 -->8460 -->8461 -->8462 -->8463 -->8464 -->8465 -->8466 -->8467 -->8468 -->8469 -->847 -->8470 -->8471 -->8472 -->8473 -->8474 -->8475 -->8476 -->8477 -->8478 -->8479 -->848 -->8480 -->8481 -->8482 -->8483 -->8484 -->8485 -->8486 -->8487 -->8488 -->8489 -->849 -->8490 -->8491 -->8492 -->8493 -->8494 -->8495 -->8496 -->8497 -->8498 -->8499 -->85 -->850 -->8500 -->8501 -->8502 -->8503 -->8504 -->8505 -->8506 -->8507 -->8508 -->8509 -->851 -->8510 -->8511 -->8512 -->8513 -->8514 -->8515 -->8516 -->8517 -->8518 -->8519 -->852 -->8520 -->8521 -->8522 -->8523 -->8524 -->8525 -->8526 -->8527 -->8528 -->8529 -->853 -->8530 -->8531 -->8532 -->8533 -->8534 -->8535 -->8536 -->8537 -->8538 -->8539 -->854 -->8540 -->8541 -->8542 -->8543 -->8544 -->8545 -->8546 -->8547 -->8548 -->8549 -->855 -->8550 -->8551 -->8552 -->8553 -->8554 -->8555 -->8556 -->8557 -->8558 -->8559 -->856 -->8560 -->8561 -->8562 -->8563 -->8564 -->8565 -->8566 -->8567 -->8568 -->8569 -->857 -->8570 -->8571 -->8572 -->8573 -->8574 -->8575 -->8576 -->8577 -->8578 -->8579 -->858 -->8580 -->8581 -->8582 -->8583 -->8584 -->8585 -->8586 -->8587 -->8588 -->8589 -->859 -->8590 -->8591 -->8592 -->8593 -->8594 -->8595 -->8596 -->8597 -->8598 -->8599 -->86 -->860 -->8600 -->8601 -->8602 -->8603 -->8604 -->8605 -->8606 -->8607 -->8608 -->8609 -->861 -->8610 -->8611 -->8612 -->8613 -->8614 -->8615 -->8616 -->8617 -->8618 -->8619 -->862 -->8620 -->8621 -->8622 -->8623 -->8624 -->8625 -->8626 -->8627 -->8628 -->8629 -->863 -->8630 -->8631 -->8632 -->8633 -->8634 -->8635 -->8636 -->8637 -->8638 -->8639 -->864 -->8640 -->8641 -->8642 -->8643 -->8644 -->8645 -->8646 -->8647 -->8648 -->8649 -->865 -->8650 -->8651 -->8652 -->8653 -->8654 -->8655 -->8656 -->8657 -->8658 -->8659 -->866 -->8660 -->8661 -->8662 -->8663 -->8664 -->8665 -->8666 -->8667 -->8668 -->8669 -->867 -->8670 -->8671 -->8672 -->8673 -->8674 -->8675 -->8676 -->8677 -->8678 -->8679 -->868 -->8680 -->8681 -->8682 -->8683 -->8684 -->8685 -->8686 -->8687 -->8688 -->8689 -->869 -->8690 -->8691 -->8692 -->8693 -->8694 -->8695 -->8696 -->8697 -->8698 -->8699 -->87 -->870 -->8700 -->8701 -->8702 -->8703 -->8704 -->8705 -->8706 -->8707 -->8708 -->8709 -->871 -->8710 -->8711 -->8712 -->8713 -->8714 -->8715 -->8716 -->8717 -->8718 -->8719 -->872 -->8720 -->8721 -->8722 -->8723 -->8724 -->8725 -->8726 -->8727 -->8728 -->8729 -->873 -->8730 -->8731 -->8732 -->8733 -->8734 -->8735 -->8736 -->8737 -->8738 -->8739 -->874 -->8740 -->8741 -->8742 -->8743 -->8744 -->8745 -->8746 -->8747 -->8748 -->8749 -->875 -->8750 -->8751 -->8752 -->8753 -->8754 -->8755 -->8756 -->8757 -->8758 -->8759 -->876 -->8760 -->8761 -->8762 -->8763 -->8764 -->8765 -->8766 -->8767 -->8768 -->8769 -->877 -->8770 -->8771 -->8772 -->8773 -->8774 -->8775 -->8776 -->8777 -->8778 -->8779 -->878 -->8780 -->8781 -->8782 -->8783 -->8784 -->8785 -->8786 -->8787 -->8788 -->8789 -->879 -->8790 -->8791 -->8792 -->8793 -->8794 -->8795 -->8796 -->8797 -->8798 -->8799 -->88 -->880 -->8800 -->8801 -->8802 -->8803 -->8804 -->8805 -->8806 -->8807 -->8808 -->8809 -->881 -->8810 -->8811 -->8812 -->8813 -->8814 -->8815 -->8816 -->8817 -->8818 -->8819 -->882 -->8820 -->8821 -->8822 -->8823 -->8824 -->8825 -->8826 -->8827 -->8828 -->8829 -->883 -->8830 -->8831 -->8832 -->8833 -->8834 -->8835 -->8836 -->8837 -->8838 -->8839 -->884 -->8840 -->8841 -->8842 -->8843 -->8844 -->8845 -->8846 -->8847 -->8848 -->8849 -->885 -->8850 -->8851 -->8852 -->8853 -->8854 -->8855 -->8856 -->8857 -->8858 -->8859 -->886 -->8860 -->8861 -->8862 -->8863 -->8864 -->8865 -->8866 -->8867 -->8868 -->8869 -->887 -->8870 -->8871 -->8872 -->8873 -->8874 -->8875 -->8876 -->8877 -->8878 -->8879 -->888 -->8880 -->8881 -->8882 -->8883 -->8884 -->8885 -->8886 -->8887 -->8888 -->8889 -->889 -->8890 -->8891 -->8892 -->8893 -->8894 -->8895 -->8896 -->8897 -->8898 -->8899 -->89 -->890 -->8900 -->8901 -->8902 -->8903 -->8904 -->8905 -->8906 -->8907 -->8908 -->8909 -->891 -->8910 -->8911 -->8912 -->8913 -->8914 -->8915 -->8916 -->8917 -->8918 -->8919 -->892 -->8920 -->8921 -->8922 -->8923 -->8924 -->8925 -->8926 -->8927 -->8928 -->8929 -->893 -->8930 -->8931 -->8932 -->8933 -->8934 -->8935 -->8936 -->8937 -->8938 -->8939 -->894 -->8940 -->8941 -->8942 -->8943 -->8944 -->8945 -->8946 -->8947 -->8948 -->8949 -->895 -->8950 -->8951 -->8952 -->8953 -->8954 -->8955 -->8956 -->8957 -->8958 -->8959 -->896 -->8960 -->8961 -->8962 -->8963 -->8964 -->8965 -->8966 -->8967 -->8968 -->8969 -->897 -->8970 -->8971 -->8972 -->8973 -->8974 -->8975 -->8976 -->8977 -->8978 -->8979 -->898 -->8980 -->8981 -->8982 -->8983 -->8984 -->8985 -->8986 -->8987 -->8988 -->8989 -->899 -->8990 -->8991 -->8992 -->8993 -->8994 -->8995 -->8996 -->8997 -->8998 -->8999 -->9 -->90 -->900 -->9000 -->9001 -->9002 -->9003 -->9004 -->9005 -->9006 -->9007 -->9008 -->9009 -->901 -->9010 -->9011 -->9012 -->9013 -->9014 -->9015 -->9016 -->9017 -->9018 -->9019 -->902 -->9020 -->9021 -->9022 -->9023 -->9024 -->9025 -->9026 -->9027 -->9028 -->9029 -->903 -->9030 -->9031 -->9032 -->9033 -->9034 -->9035 -->9036 -->9037 -->9038 -->9039 -->904 -->9040 -->9041 -->9042 -->9043 -->9044 -->9045 -->9046 -->9047 -->9048 -->9049 -->905 -->9050 -->9051 -->9052 -->9053 -->9054 -->9055 -->9056 -->9057 -->9058 -->9059 -->906 -->9060 -->9061 -->9062 -->9063 -->9064 -->9065 -->9066 -->9067 -->9068 -->9069 -->907 -->9070 -->9071 -->9072 -->9073 -->9074 -->9075 -->9076 -->9077 -->9078 -->9079 -->908 -->9080 -->9081 -->9082 -->9083 -->9084 -->9085 -->9086 -->9087 -->9088 -->9089 -->909 -->9090 -->9091 -->9092 -->9093 -->9094 -->9095 -->9096 -->9097 -->9098 -->9099 -->91 -->910 -->9100 -->9101 -->9102 -->9103 -->9104 -->9105 -->9106 -->9107 -->9108 -->9109 -->911 -->9110 -->9111 -->9112 -->9113 -->9114 -->9115 -->9116 -->9117 -->9118 -->9119 -->912 -->9120 -->9121 -->9122 -->9123 -->9124 -->9125 -->9126 -->9127 -->9128 -->9129 -->913 -->9130 -->9131 -->9132 -->9133 -->9134 -->9135 -->9136 -->9137 -->9138 -->9139 -->914 -->9140 -->9141 -->9142 -->9143 -->9144 -->9145 -->9146 -->9147 -->9148 -->9149 -->915 -->9150 -->9151 -->9152 -->9153 -->9154 -->9155 -->9156 -->9157 -->9158 -->9159 -->916 -->9160 -->9161 -->9162 -->9163 -->9164 -->9165 -->9166 -->9167 -->9168 -->9169 -->917 -->9170 -->9171 -->9172 -->9173 -->9174 -->9175 -->9176 -->9177 -->9178 -->9179 -->918 -->9180 -->9181 -->9182 -->9183 -->9184 -->9185 -->9186 -->9187 -->9188 -->9189 -->919 -->9190 -->9191 -->9192 -->9193 -->9194 -->9195 -->9196 -->9197 -->9198 -->9199 -->92 -->920 -->9200 -->9201 -->9202 -->9203 -->9204 -->9205 -->9206 -->9207 -->9208 -->9209 -->921 -->9210 -->9211 -->9212 -->9213 -->9214 -->9215 -->9216 -->9217 -->9218 -->9219 -->922 -->9220 -->9221 -->9222 -->9223 -->9224 -->9225 -->9226 -->9227 -->9228 -->9229 -->923 -->9230 -->9231 -->9232 -->9233 -->9234 -->9235 -->9236 -->9237 -->9238 -->9239 -->924 -->9240 -->9241 -->9242 -->9243 -->9244 -->9245 -->9246 -->9247 -->9248 -->9249 -->925 -->9250 -->9251 -->9252 -->9253 -->9254 -->9255 -->9256 -->9257 -->9258 -->9259 -->926 -->9260 -->9261 -->9262 -->9263 -->9264 -->9265 -->9266 -->9267 -->9268 -->9269 -->927 -->9270 -->9271 -->9272 -->9273 -->9274 -->9275 -->9276 -->9277 -->9278 -->9279 -->928 -->9280 -->9281 -->9282 -->9283 -->9284 -->9285 -->9286 -->9287 -->9288 -->9289 -->929 -->9290 -->9291 -->9292 -->9293 -->9294 -->9295 -->9296 -->9297 -->9298 -->9299 -->93 -->930 -->9300 -->9301 -->9302 -->9303 -->9304 -->9305 -->9306 -->9307 -->9308 -->9309 -->931 -->9310 -->9311 -->9312 -->9313 -->9314 -->9315 -->9316 -->9317 -->9318 -->9319 -->932 -->9320 -->9321 -->9322 -->9323 -->9324 -->9325 -->9326 -->9327 -->9328 -->9329 -->933 -->9330 -->9331 -->9332 -->9333 -->9334 -->9335 -->9336 -->9337 -->9338 -->9339 -->934 -->9340 -->9341 -->9342 -->9343 -->9344 -->9345 -->9346 -->9347 -->9348 -->9349 -->935 -->9350 -->9351 -->9352 -->9353 -->9354 -->9355 -->9356 -->9357 -->9358 -->9359 -->936 -->9360 -->9361 -->9362 -->9363 -->9364 -->9365 -->9366 -->9367 -->9368 -->9369 -->937 -->9370 -->9371 -->9372 -->9373 -->9374 -->9375 -->9376 -->9377 -->9378 -->9379 -->938 -->9380 -->9381 -->9382 -->9383 -->9384 -->9385 -->9386 -->9387 -->9388 -->9389 -->939 -->9390 -->9391 -->9392 -->9393 -->9394 -->9395 -->9396 -->9397 -->9398 -->9399 -->94 -->940 -->9400 -->9401 -->9402 -->9403 -->9404 -->9405 -->9406 -->9407 -->9408 -->9409 -->941 -->9410 -->9411 -->9412 -->9413 -->9414 -->9415 -->9416 -->9417 -->9418 -->9419 -->942 -->9420 -->9421 -->9422 -->9423 -->9424 -->9425 -->9426 -->9427 -->9428 -->9429 -->943 -->9430 -->9431 -->9432 -->9433 -->9434 -->9435 -->9436 -->9437 -->9438 -->9439 -->944 -->9440 -->9441 -->9442 -->9443 -->9444 -->9445 -->9446 -->9447 -->9448 -->9449 -->945 -->9450 -->9451 -->9452 -->9453 -->9454 -->9455 -->9456 -->9457 -->9458 -->9459 -->946 -->9460 -->9461 -->9462 -->9463 -->9464 -->9465 -->9466 -->9467 -->9468 -->9469 -->947 -->9470 -->9471 -->9472 -->9473 -->9474 -->9475 -->9476 -->9477 -->9478 -->9479 -->948 -->9480 -->9481 -->9482 -->9483 -->9484 -->9485 -->9486 -->9487 -->9488 -->9489 -->949 -->9490 -->9491 -->9492 -->9493 -->9494 -->9495 -->9496 -->9497 -->9498 -->9499 -->95 -->950 -->9500 -->9501 -->9502 -->9503 -->9504 -->9505 -->9506 -->9507 -->9508 -->9509 -->951 -->9510 -->9511 -->9512 -->9513 -->9514 -->9515 -->9516 -->9517 -->9518 -->9519 -->952 -->9520 -->9521 -->9522 -->9523 -->9524 -->9525 -->9526 -->9527 -->9528 -->9529 -->953 -->9530 -->9531 -->9532 -->9533 -->9534 -->9535 -->9536 -->9537 -->9538 -->9539 -->954 -->9540 -->9541 -->9542 -->9543 -->9544 -->9545 -->9546 -->9547 -->9548 -->9549 -->955 -->9550 -->9551 -->9552 -->9553 -->9554 -->9555 -->9556 -->9557 -->9558 -->9559 -->956 -->9560 -->9561 -->9562 -->9563 -->9564 -->9565 -->9566 -->9567 -->9568 -->9569 -->957 -->9570 -->9571 -->9572 -->9573 -->9574 -->9575 -->9576 -->9577 -->9578 -->9579 -->958 -->9580 -->9581 -->9582 -->9583 -->9584 -->9585 -->9586 -->9587 -->9588 -->9589 -->959 -->9590 -->9591 -->9592 -->9593 -->9594 -->9595 -->9596 -->9597 -->9598 -->9599 -->96 -->960 -->9600 -->9601 -->9602 -->9603 -->9604 -->9605 -->9606 -->9607 -->9608 -->9609 -->961 -->9610 -->9611 -->9612 -->9613 -->9614 -->9615 -->9616 -->9617 -->9618 -->9619 -->962 -->9620 -->9621 -->9622 -->9623 -->9624 -->9625 -->9626 -->9627 -->9628 -->9629 -->963 -->9630 -->9631 -->9632 -->9633 -->9634 -->9635 -->9636 -->9637 -->9638 -->9639 -->964 -->9640 -->9641 -->9642 -->9643 -->9644 -->9645 -->9646 -->9647 -->9648 -->9649 -->965 -->9650 -->9651 -->9652 -->9653 -->9654 -->9655 -->9656 -->9657 -->9658 -->9659 -->966 -->9660 -->9661 -->9662 -->9663 -->9664 -->9665 -->9666 -->9667 -->9668 -->9669 -->967 -->9670 -->9671 -->9672 -->9673 -->9674 -->9675 -->9676 -->9677 -->9678 -->9679 -->968 -->9680 -->9681 -->9682 -->9683 -->9684 -->9685 -->9686 -->9687 -->9688 -->9689 -->969 -->9690 -->9691 -->9692 -->9693 -->9694 -->9695 -->9696 -->9697 -->9698 -->9699 -->97 -->970 -->9700 -->9701 -->9702 -->9703 -->9704 -->9705 -->9706 -->9707 -->9708 -->9709 -->971 -->9710 -->9711 -->9712 -->9713 -->9714 -->9715 -->9716 -->9717 -->9718 -->9719 -->972 -->9720 -->9721 -->9722 -->9723 -->9724 -->9725 -->9726 -->9727 -->9728 -->9729 -->973 -->9730 -->9731 -->9732 -->9733 -->9734 -->9735 -->9736 -->9737 -->9738 -->9739 -->974 -->9740 -->9741 -->9742 -->9743 -->9744 -->9745 -->9746 -->9747 -->9748 -->9749 -->975 -->9750 -->9751 -->9752 -->9753 -->9754 -->9755 -->9756 -->9757 -->9758 -->9759 -->976 -->9760 -->9761 -->9762 -->9763 -->9764 -->9765 -->9766 -->9767 -->9768 -->9769 -->977 -->9770 -->9771 -->9772 -->9773 -->9774 -->9775 -->9776 -->9777 -->9778 -->9779 -->978 -->9780 -->9781 -->9782 -->9783 -->9784 -->9785 -->9786 -->9787 -->9788 -->9789 -->979 -->9790 -->9791 -->9792 -->9793 -->9794 -->9795 -->9796 -->9797 -->9798 -->9799 -->98 -->980 -->9800 -->9801 -->9802 -->9803 -->9804 -->9805 -->9806 -->9807 -->9808 -->9809 -->981 -->9810 -->9811 -->9812 -->9813 -->9814 -->9815 -->9816 -->9817 -->9818 -->9819 -->982 -->9820 -->9821 -->9822 -->9823 -->9824 -->9825 -->9826 -->9827 -->9828 -->9829 -->983 -->9830 -->9831 -->9832 -->9833 -->9834 -->9835 -->9836 -->9837 -->9838 -->9839 -->984 -->9840 -->9841 -->9842 -->9843 -->9844 -->9845 -->9846 -->9847 -->9848 -->9849 -->985 -->9850 -->9851 -->9852 -->9853 -->9854 -->9855 -->9856 -->9857 -->9858 -->9859 -->986 -->9860 -->9861 -->9862 -->9863 -->9864 -->9865 -->9866 -->9867 -->9868 -->9869 -->987 -->9870 -->9871 -->9872 -->9873 -->9874 -->9875 -->9876 -->9877 -->9878 -->9879 -->988 -->9880 -->9881 -->9882 -->9883 -->9884 -->9885 -->9886 -->9887 -->9888 -->9889 -->989 -->9890 -->9891 -->9892 -->9893 -->9894 -->9895 -->9896 -->9897 -->9898 -->9899 -->99 -->990 -->9900 -->9901 -->9902 -->9903 -->9904 -->9905 -->9906 -->9907 -->9908 -->9909 -->991 -->9910 -->9911 -->9912 -->9913 -->9914 -->9915 -->9916 -->9917 -->9918 -->9919 -->992 -->9920 -->9921 -->9922 -->9923 -->9924 -->9925 -->9926 -->9927 -->9928 -->9929 -->993 -->9930 -->9931 -->9932 -->9933 -->9934 -->9935 -->9936 -->9937 -->9938 -->9939 -->994 -->9940 -->9941 -->9942 -->9943 -->9944 -->9945 -->9946 -->9947 -->9948 -->9949 -->995 -->9950 -->9951 -->9952 -->9953 -->9954 -->9955 -->9956 -->9957 -->9958 -->9959 -->996 -->9960 -->9961 -->9962 -->9963 -->9964 -->9965 -->9966 -->9967 -->9968 -->9969 -->997 -->9970 -->9971 -->9972 -->9973 -->9974 -->9975 -->9976 -->9977 -->9978 -->9979 -->998 -->9980 -->9981 -->9982 -->9983 -->9984 -->9985 -->9986 -->9987 -->9988 -->9989 -->999 -->9990 -->9991 -->9992 -->9993 -->9994 -->9995 -->9996 -->9997 -->9998 -->9999 0--> 1--> 10--> 100--> 1000--> 10000--> 1001--> 1002--> 1003--> 1004--> 1005--> 1006--> 1007--> 1008--> 1009--> 101--> 1010--> 1011--> 1012--> 1013--> 1014--> 1015--> 1016--> 1017--> 1018--> 1019--> 102--> 1020--> 1021--> 1022--> 1023--> 1024--> 1025--> 1026--> 1027--> 1028--> 1029--> 103--> 1030--> 1031--> 1032--> 1033--> 1034--> 1035--> 1036--> 1037--> 1038--> 1039--> 104--> 1040--> 1041--> 1042--> 1043--> 1044--> 1045--> 1046--> 1047--> 1048--> 1049--> 105--> 1050--> 1051--> 1052--> 1053--> 1054--> 1055--> 1056--> 1057--> 1058--> 1059--> 106--> 1060--> 1061--> 1062--> 1063--> 1064--> 1065--> 1066--> 1067--> 1068--> 1069--> 107--> 1070--> 1071--> 1072--> 1073--> 1074--> 1075--> 1076--> 1077--> 1078--> 1079--> 108--> 1080--> 1081--> 1082--> 1083--> 1084--> 1085--> 1086--> 1087--> 1088--> 1089--> 109--> 1090--> 1091--> 1092--> 1093--> 1094--> 1095--> 1096--> 1097--> 1098--> 1099--> 11--> 110--> 1100--> 1101--> 1102--> 1103--> 1104--> 1105--> 1106--> 1107--> 1108--> 1109--> 111--> 1110--> 1111--> 1112--> 1113--> 1114--> 1115--> 1116--> 1117--> 1118--> 1119--> 112--> 1120--> 1121--> 1122--> 1123--> 1124--> 1125--> 1126--> 1127--> 1128--> 1129--> 113--> 1130--> 1131--> 1132--> 1133--> 1134--> 1135--> 1136--> 1137--> 1138--> 1139--> 114--> 1140--> 1141--> 1142--> 1143--> 1144--> 1145--> 1146--> 1147--> 1148--> 1149--> 115--> 1150--> 1151--> 1152--> 1153--> 1154--> 1155--> 1156--> 1157--> 1158--> 1159--> 116--> 1160--> 1161--> 1162--> 1163--> 1164--> 1165--> 1166--> 1167--> 1168--> 1169--> 117--> 1170--> 1171--> 1172--> 1173--> 1174--> 1175--> 1176--> 1177--> 1178--> 1179--> 118--> 1180--> 1181--> 1182--> 1183--> 1184--> 1185--> 1186--> 1187--> 1188--> 1189--> 119--> 1190--> 1191--> 1192--> 1193--> 1194--> 1195--> 1196--> 1197--> 1198--> 1199--> 12--> 120--> 1200--> 1201--> 1202--> 1203--> 1204--> 1205--> 1206--> 1207--> 1208--> 1209--> 121--> 1210--> 1211--> 1212--> 1213--> 1214--> 1215--> 1216--> 1217--> 1218--> 1219--> 122--> 1220--> 1221--> 1222--> 1223--> 1224--> 1225--> 1226--> 1227--> 1228--> 1229--> 123--> 1230--> 1231--> 1232--> 1233--> 1234--> 1235--> 1236--> 1237--> 1238--> 1239--> 124--> 1240--> 1241--> 1242--> 1243--> 1244--> 1245--> 1246--> 1247--> 1248--> 1249--> 125--> 1250--> 1251--> 1252--> 1253--> 1254--> 1255--> 1256--> 1257--> 1258--> 1259--> 126--> 1260--> 1261--> 1262--> 1263--> 1264--> 1265--> 1266--> 1267--> 1268--> 1269--> 127--> 1270--> 1271--> 1272--> 1273--> 1274--> 1275--> 1276--> 1277--> 1278--> 1279--> 128--> 1280--> 1281--> 1282--> 1283--> 1284--> 1285--> 1286--> 1287--> 1288--> 1289--> 129--> 1290--> 1291--> 1292--> 1293--> 1294--> 1295--> 1296--> 1297--> 1298--> 1299--> 13--> 130--> 1300--> 1301--> 1302--> 1303--> 1304--> 1305--> 1306--> 1307--> 1308--> 1309--> 131--> 1310--> 1311--> 1312--> 1313--> 1314--> 1315--> 1316--> 1317--> 1318--> 1319--> 132--> 1320--> 1321--> 1322--> 1323--> 1324--> 1325--> 1326--> 1327--> 1328--> 1329--> 133--> 1330--> 1331--> 1332--> 1333--> 1334--> 1335--> 1336--> 1337--> 1338--> 1339--> 134--> 1340--> 1341--> 1342--> 1343--> 1344--> 1345--> 1346--> 1347--> 1348--> 1349--> 135--> 1350--> 1351--> 1352--> 1353--> 1354--> 1355--> 1356--> 1357--> 1358--> 1359--> 136--> 1360--> 1361--> 1362--> 1363--> 1364--> 1365--> 1366--> 1367--> 1368--> 1369--> 137--> 1370--> 1371--> 1372--> 1373--> 1374--> 1375--> 1376--> 1377--> 1378--> 1379--> 138--> 1380--> 1381--> 1382--> 1383--> 1384--> 1385--> 1386--> 1387--> 1388--> 1389--> 139--> 1390--> 1391--> 1392--> 1393--> 1394--> 1395--> 1396--> 1397--> 1398--> 1399--> 14--> 140--> 1400--> 1401--> 1402--> 1403--> 1404--> 1405--> 1406--> 1407--> 1408--> 1409--> 141--> 1410--> 1411--> 1412--> 1413--> 1414--> 1415--> 1416--> 1417--> 1418--> 1419--> 142--> 1420--> 1421--> 1422--> 1423--> 1424--> 1425--> 1426--> 1427--> 1428--> 1429--> 143--> 1430--> 1431--> 1432--> 1433--> 1434--> 1435--> 1436--> 1437--> 1438--> 1439--> 144--> 1440--> 1441--> 1442--> 1443--> 1444--> 1445--> 1446--> 1447--> 1448--> 1449--> 145--> 1450--> 1451--> 1452--> 1453--> 1454--> 1455--> 1456--> 1457--> 1458--> 1459--> 146--> 1460--> 1461--> 1462--> 1463--> 1464--> 1465--> 1466--> 1467--> 1468--> 1469--> 147--> 1470--> 1471--> 1472--> 1473--> 1474--> 1475--> 1476--> 1477--> 1478--> 1479--> 148--> 1480--> 1481--> 1482--> 1483--> 1484--> 1485--> 1486--> 1487--> 1488--> 1489--> 149--> 1490--> 1491--> 1492--> 1493--> 1494--> 1495--> 1496--> 1497--> 1498--> 1499--> 15--> 150--> 1500--> 1501--> 1502--> 1503--> 1504--> 1505--> 1506--> 1507--> 1508--> 1509--> 151--> 1510--> 1511--> 1512--> 1513--> 1514--> 1515--> 1516--> 1517--> 1518--> 1519--> 152--> 1520--> 1521--> 1522--> 1523--> 1524--> 1525--> 1526--> 1527--> 1528--> 1529--> 153--> 1530--> 1531--> 1532--> 1533--> 1534--> 1535--> 1536--> 1537--> 1538--> 1539--> 154--> 1540--> 1541--> 1542--> 1543--> 1544--> 1545--> 1546--> 1547--> 1548--> 1549--> 155--> 1550--> 1551--> 1552--> 1553--> 1554--> 1555--> 1556--> 1557--> 1558--> 1559--> 156--> 1560--> 1561--> 1562--> 1563--> 1564--> 1565--> 1566--> 1567--> 1568--> 1569--> 157--> 1570--> 1571--> 1572--> 1573--> 1574--> 1575--> 1576--> 1577--> 1578--> 1579--> 158--> 1580--> 1581--> 1582--> 1583--> 1584--> 1585--> 1586--> 1587--> 1588--> 1589--> 159--> 1590--> 1591--> 1592--> 1593--> 1594--> 1595--> 1596--> 1597--> 1598--> 1599--> 16--> 160--> 1600--> 1601--> 1602--> 1603--> 1604--> 1605--> 1606--> 1607--> 1608--> 1609--> 161--> 1610--> 1611--> 1612--> 1613--> 1614--> 1615--> 1616--> 1617--> 1618--> 1619--> 162--> 1620--> 1621--> 1622--> 1623--> 1624--> 1625--> 1626--> 1627--> 1628--> 1629--> 163--> 1630--> 1631--> 1632--> 1633--> 1634--> 1635--> 1636--> 1637--> 1638--> 1639--> 164--> 1640--> 1641--> 1642--> 1643--> 1644--> 1645--> 1646--> 1647--> 1648--> 1649--> 165--> 1650--> 1651--> 1652--> 1653--> 1654--> 1655--> 1656--> 1657--> 1658--> 1659--> 166--> 1660--> 1661--> 1662--> 1663--> 1664--> 1665--> 1666--> 1667--> 1668--> 1669--> 167--> 1670--> 1671--> 1672--> 1673--> 1674--> 1675--> 1676--> 1677--> 1678--> 1679--> 168--> 1680--> 1681--> 1682--> 1683--> 1684--> 1685--> 1686--> 1687--> 1688--> 1689--> 169--> 1690--> 1691--> 1692--> 1693--> 1694--> 1695--> 1696--> 1697--> 1698--> 1699--> 17--> 170--> 1700--> 1701--> 1702--> 1703--> 1704--> 1705--> 1706--> 1707--> 1708--> 1709--> 171--> 1710--> 1711--> 1712--> 1713--> 1714--> 1715--> 1716--> 1717--> 1718--> 1719--> 172--> 1720--> 1721--> 1722--> 1723--> 1724--> 1725--> 1726--> 1727--> 1728--> 1729--> 173--> 1730--> 1731--> 1732--> 1733--> 1734--> 1735--> 1736--> 1737--> 1738--> 1739--> 174--> 1740--> 1741--> 1742--> 1743--> 1744--> 1745--> 1746--> 1747--> 1748--> 1749--> 175--> 1750--> 1751--> 1752--> 1753--> 1754--> 1755--> 1756--> 1757--> 1758--> 1759--> 176--> 1760--> 1761--> 1762--> 1763--> 1764--> 1765--> 1766--> 1767--> 1768--> 1769--> 177--> 1770--> 1771--> 1772--> 1773--> 1774--> 1775--> 1776--> 1777--> 1778--> 1779--> 178--> 1780--> 1781--> 1782--> 1783--> 1784--> 1785--> 1786--> 1787--> 1788--> 1789--> 179--> 1790--> 1791--> 1792--> 1793--> 1794--> 1795--> 1796--> 1797--> 1798--> 1799--> 18--> 180--> 1800--> 1801--> 1802--> 1803--> 1804--> 1805--> 1806--> 1807--> 1808--> 1809--> 181--> 1810--> 1811--> 1812--> 1813--> 1814--> 1815--> 1816--> 1817--> 1818--> 1819--> 182--> 1820--> 1821--> 1822--> 1823--> 1824--> 1825--> 1826--> 1827--> 1828--> 1829--> 183--> 1830--> 1831--> 1832--> 1833--> 1834--> 1835--> 1836--> 1837--> 1838--> 1839--> 184--> 1840--> 1841--> 1842--> 1843--> 1844--> 1845--> 1846--> 1847--> 1848--> 1849--> 185--> 1850--> 1851--> 1852--> 1853--> 1854--> 1855--> 1856--> 1857--> 1858--> 1859--> 186--> 1860--> 1861--> 1862--> 1863--> 1864--> 1865--> 1866--> 1867--> 1868--> 1869--> 187--> 1870--> 1871--> 1872--> 1873--> 1874--> 1875--> 1876--> 1877--> 1878--> 1879--> 188--> 1880--> 1881--> 1882--> 1883--> 1884--> 1885--> 1886--> 1887--> 1888--> 1889--> 189--> 1890--> 1891--> 1892--> 1893--> 1894--> 1895--> 1896--> 1897--> 1898--> 1899--> 19--> 190--> 1900--> 1901--> 1902--> 1903--> 1904--> 1905--> 1906--> 1907--> 1908--> 1909--> 191--> 1910--> 1911--> 1912--> 1913--> 1914--> 1915--> 1916--> 1917--> 1918--> 1919--> 192--> 1920--> 1921--> 1922--> 1923--> 1924--> 1925--> 1926--> 1927--> 1928--> 1929--> 193--> 1930--> 1931--> 1932--> 1933--> 1934--> 1935--> 1936--> 1937--> 1938--> 1939--> 194--> 1940--> 1941--> 1942--> 1943--> 1944--> 1945--> 1946--> 1947--> 1948--> 1949--> 195--> 1950--> 1951--> 1952--> 1953--> 1954--> 1955--> 1956--> 1957--> 1958--> 1959--> 196--> 1960--> 1961--> 1962--> 1963--> 1964--> 1965--> 1966--> 1967--> 1968--> 1969--> 197--> 1970--> 1971--> 1972--> 1973--> 1974--> 1975--> 1976--> 1977--> 1978--> 1979--> 198--> 1980--> 1981--> 1982--> 1983--> 1984--> 1985--> 1986--> 1987--> 1988--> 1989--> 199--> 1990--> 1991--> 1992--> 1993--> 1994--> 1995--> 1996--> 1997--> 1998--> 1999--> 2--> 20--> 200--> 2000--> 2001--> 2002--> 2003--> 2004--> 2005--> 2006--> 2007--> 2008--> 2009--> 201--> 2010--> 2011--> 2012--> 2013--> 2014--> 2015--> 2016--> 2017--> 2018--> 2019--> 202--> 2020--> 2021--> 2022--> 2023--> 2024--> 2025--> 2026--> 2027--> 2028--> 2029--> 203--> 2030--> 2031--> 2032--> 2033--> 2034--> 2035--> 2036--> 2037--> 2038--> 2039--> 204--> 2040--> 2041--> 2042--> 2043--> 2044--> 2045--> 2046--> 2047--> 2048--> 2049--> 205--> 2050--> 2051--> 2052--> 2053--> 2054--> 2055--> 2056--> 2057--> 2058--> 2059--> 206--> 2060--> 2061--> 2062--> 2063--> 2064--> 2065--> 2066--> 2067--> 2068--> 2069--> 207--> 2070--> 2071--> 2072--> 2073--> 2074--> 2075--> 2076--> 2077--> 2078--> 2079--> 208--> 2080--> 2081--> 2082--> 2083--> 2084--> 2085--> 2086--> 2087--> 2088--> 2089--> 209--> 2090--> 2091--> 2092--> 2093--> 2094--> 2095--> 2096--> 2097--> 2098--> 2099--> 21--> 210--> 2100--> 2101--> 2102--> 2103--> 2104--> 2105--> 2106--> 2107--> 2108--> 2109--> 211--> 2110--> 2111--> 2112--> 2113--> 2114--> 2115--> 2116--> 2117--> 2118--> 2119--> 212--> 2120--> 2121--> 2122--> 2123--> 2124--> 2125--> 2126--> 2127--> 2128--> 2129--> 213--> 2130--> 2131--> 2132--> 2133--> 2134--> 2135--> 2136--> 2137--> 2138--> 2139--> 214--> 2140--> 2141--> 2142--> 2143--> 2144--> 2145--> 2146--> 2147--> 2148--> 2149--> 215--> 2150--> 2151--> 2152--> 2153--> 2154--> 2155--> 2156--> 2157--> 2158--> 2159--> 216--> 2160--> 2161--> 2162--> 2163--> 2164--> 2165--> 2166--> 2167--> 2168--> 2169--> 217--> 2170--> 2171--> 2172--> 2173--> 2174--> 2175--> 2176--> 2177--> 2178--> 2179--> 218--> 2180--> 2181--> 2182--> 2183--> 2184--> 2185--> 2186--> 2187--> 2188--> 2189--> 219--> 2190--> 2191--> 2192--> 2193--> 2194--> 2195--> 2196--> 2197--> 2198--> 2199--> 22--> 220--> 2200--> 2201--> 2202--> 2203--> 2204--> 2205--> 2206--> 2207--> 2208--> 2209--> 221--> 2210--> 2211--> 2212--> 2213--> 2214--> 2215--> 2216--> 2217--> 2218--> 2219--> 222--> 2220--> 2221--> 2222--> 2223--> 2224--> 2225--> 2226--> 2227--> 2228--> 2229--> 223--> 2230--> 2231--> 2232--> 2233--> 2234--> 2235--> 2236--> 2237--> 2238--> 2239--> 224--> 2240--> 2241--> 2242--> 2243--> 2244--> 2245--> 2246--> 2247--> 2248--> 2249--> 225--> 2250--> 2251--> 2252--> 2253--> 2254--> 2255--> 2256--> 2257--> 2258--> 2259--> 226--> 2260--> 2261--> 2262--> 2263--> 2264--> 2265--> 2266--> 2267--> 2268--> 2269--> 227--> 2270--> 2271--> 2272--> 2273--> 2274--> 2275--> 2276--> 2277--> 2278--> 2279--> 228--> 2280--> 2281--> 2282--> 2283--> 2284--> 2285--> 2286--> 2287--> 2288--> 2289--> 229--> 2290--> 2291--> 2292--> 2293--> 2294--> 2295--> 2296--> 2297--> 2298--> 2299--> 23--> 230--> 2300--> 2301--> 2302--> 2303--> 2304--> 2305--> 2306--> 2307--> 2308--> 2309--> 231--> 2310--> 2311--> 2312--> 2313--> 2314--> 2315--> 2316--> 2317--> 2318--> 2319--> 232--> 2320--> 2321--> 2322--> 2323--> 2324--> 2325--> 2326--> 2327--> 2328--> 2329--> 233--> 2330--> 2331--> 2332--> 2333--> 2334--> 2335--> 2336--> 2337--> 2338--> 2339--> 234--> 2340--> 2341--> 2342--> 2343--> 2344--> 2345--> 2346--> 2347--> 2348--> 2349--> 235--> 2350--> 2351--> 2352--> 2353--> 2354--> 2355--> 2356--> 2357--> 2358--> 2359--> 236--> 2360--> 2361--> 2362--> 2363--> 2364--> 2365--> 2366--> 2367--> 2368--> 2369--> 237--> 2370--> 2371--> 2372--> 2373--> 2374--> 2375--> 2376--> 2377--> 2378--> 2379--> 238--> 2380--> 2381--> 2382--> 2383--> 2384--> 2385--> 2386--> 2387--> 2388--> 2389--> 239--> 2390--> 2391--> 2392--> 2393--> 2394--> 2395--> 2396--> 2397--> 2398--> 2399--> 24--> 240--> 2400--> 2401--> 2402--> 2403--> 2404--> 2405--> 2406--> 2407--> 2408--> 2409--> 241--> 2410--> 2411--> 2412--> 2413--> 2414--> 2415--> 2416--> 2417--> 2418--> 2419--> 242--> 2420--> 2421--> 2422--> 2423--> 2424--> 2425--> 2426--> 2427--> 2428--> 2429--> 243--> 2430--> 2431--> 2432--> 2433--> 2434--> 2435--> 2436--> 2437--> 2438--> 2439--> 244--> 2440--> 2441--> 2442--> 2443--> 2444--> 2445--> 2446--> 2447--> 2448--> 2449--> 245--> 2450--> 2451--> 2452--> 2453--> 2454--> 2455--> 2456--> 2457--> 2458--> 2459--> 246--> 2460--> 2461--> 2462--> 2463--> 2464--> 2465--> 2466--> 2467--> 2468--> 2469--> 247--> 2470--> 2471--> 2472--> 2473--> 2474--> 2475--> 2476--> 2477--> 2478--> 2479--> 248--> 2480--> 2481--> 2482--> 2483--> 2484--> 2485--> 2486--> 2487--> 2488--> 2489--> 249--> 2490--> 2491--> 2492--> 2493--> 2494--> 2495--> 2496--> 2497--> 2498--> 2499--> 25--> 250--> 2500--> 2501--> 2502--> 2503--> 2504--> 2505--> 2506--> 2507--> 2508--> 2509--> 251--> 2510--> 2511--> 2512--> 2513--> 2514--> 2515--> 2516--> 2517--> 2518--> 2519--> 252--> 2520--> 2521--> 2522--> 2523--> 2524--> 2525--> 2526--> 2527--> 2528--> 2529--> 253--> 2530--> 2531--> 2532--> 2533--> 2534--> 2535--> 2536--> 2537--> 2538--> 2539--> 254--> 2540--> 2541--> 2542--> 2543--> 2544--> 2545--> 2546--> 2547--> 2548--> 2549--> 255--> 2550--> 2551--> 2552--> 2553--> 2554--> 2555--> 2556--> 2557--> 2558--> 2559--> 256--> 2560--> 2561--> 2562--> 2563--> 2564--> 2565--> 2566--> 2567--> 2568--> 2569--> 257--> 2570--> 2571--> 2572--> 2573--> 2574--> 2575--> 2576--> 2577--> 2578--> 2579--> 258--> 2580--> 2581--> 2582--> 2583--> 2584--> 2585--> 2586--> 2587--> 2588--> 2589--> 259--> 2590--> 2591--> 2592--> 2593--> 2594--> 2595--> 2596--> 2597--> 2598--> 2599--> 26--> 260--> 2600--> 2601--> 2602--> 2603--> 2604--> 2605--> 2606--> 2607--> 2608--> 2609--> 261--> 2610--> 2611--> 2612--> 2613--> 2614--> 2615--> 2616--> 2617--> 2618--> 2619--> 262--> 2620--> 2621--> 2622--> 2623--> 2624--> 2625--> 2626--> 2627--> 2628--> 2629--> 263--> 2630--> 2631--> 2632--> 2633--> 2634--> 2635--> 2636--> 2637--> 2638--> 2639--> 264--> 2640--> 2641--> 2642--> 2643--> 2644--> 2645--> 2646--> 2647--> 2648--> 2649--> 265--> 2650--> 2651--> 2652--> 2653--> 2654--> 2655--> 2656--> 2657--> 2658--> 2659--> 266--> 2660--> 2661--> 2662--> 2663--> 2664--> 2665--> 2666--> 2667--> 2668--> 2669--> 267--> 2670--> 2671--> 2672--> 2673--> 2674--> 2675--> 2676--> 2677--> 2678--> 2679--> 268--> 2680--> 2681--> 2682--> 2683--> 2684--> 2685--> 2686--> 2687--> 2688--> 2689--> 269--> 2690--> 2691--> 2692--> 2693--> 2694--> 2695--> 2696--> 2697--> 2698--> 2699--> 27--> 270--> 2700--> 2701--> 2702--> 2703--> 2704--> 2705--> 2706--> 2707--> 2708--> 2709--> 271--> 2710--> 2711--> 2712--> 2713--> 2714--> 2715--> 2716--> 2717--> 2718--> 2719--> 272--> 2720--> 2721--> 2722--> 2723--> 2724--> 2725--> 2726--> 2727--> 2728--> 2729--> 273--> 2730--> 2731--> 2732--> 2733--> 2734--> 2735--> 2736--> 2737--> 2738--> 2739--> 274--> 2740--> 2741--> 2742--> 2743--> 2744--> 2745--> 2746--> 2747--> 2748--> 2749--> 275--> 2750--> 2751--> 2752--> 2753--> 2754--> 2755--> 2756--> 2757--> 2758--> 2759--> 276--> 2760--> 2761--> 2762--> 2763--> 2764--> 2765--> 2766--> 2767--> 2768--> 2769--> 277--> 2770--> 2771--> 2772--> 2773--> 2774--> 2775--> 2776--> 2777--> 2778--> 2779--> 278--> 2780--> 2781--> 2782--> 2783--> 2784--> 2785--> 2786--> 2787--> 2788--> 2789--> 279--> 2790--> 2791--> 2792--> 2793--> 2794--> 2795--> 2796--> 2797--> 2798--> 2799--> 28--> 280--> 2800--> 2801--> 2802--> 2803--> 2804--> 2805--> 2806--> 2807--> 2808--> 2809--> 281--> 2810--> 2811--> 2812--> 2813--> 2814--> 2815--> 2816--> 2817--> 2818--> 2819--> 282--> 2820--> 2821--> 2822--> 2823--> 2824--> 2825--> 2826--> 2827--> 2828--> 2829--> 283--> 2830--> 2831--> 2832--> 2833--> 2834--> 2835--> 2836--> 2837--> 2838--> 2839--> 284--> 2840--> 2841--> 2842--> 2843--> 2844--> 2845--> 2846--> 2847--> 2848--> 2849--> 285--> 2850--> 2851--> 2852--> 2853--> 2854--> 2855--> 2856--> 2857--> 2858--> 2859--> 286--> 2860--> 2861--> 2862--> 2863--> 2864--> 2865--> 2866--> 2867--> 2868--> 2869--> 287--> 2870--> 2871--> 2872--> 2873--> 2874--> 2875--> 2876--> 2877--> 2878--> 2879--> 288--> 2880--> 2881--> 2882--> 2883--> 2884--> 2885--> 2886--> 2887--> 2888--> 2889--> 289--> 2890--> 2891--> 2892--> 2893--> 2894--> 2895--> 2896--> 2897--> 2898--> 2899--> 29--> 290--> 2900--> 2901--> 2902--> 2903--> 2904--> 2905--> 2906--> 2907--> 2908--> 2909--> 291--> 2910--> 2911--> 2912--> 2913--> 2914--> 2915--> 2916--> 2917--> 2918--> 2919--> 292--> 2920--> 2921--> 2922--> 2923--> 2924--> 2925--> 2926--> 2927--> 2928--> 2929--> 293--> 2930--> 2931--> 2932--> 2933--> 2934--> 2935--> 2936--> 2937--> 2938--> 2939--> 294--> 2940--> 2941--> 2942--> 2943--> 2944--> 2945--> 2946--> 2947--> 2948--> 2949--> 295--> 2950--> 2951--> 2952--> 2953--> 2954--> 2955--> 2956--> 2957--> 2958--> 2959--> 296--> 2960--> 2961--> 2962--> 2963--> 2964--> 2965--> 2966--> 2967--> 2968--> 2969--> 297--> 2970--> 2971--> 2972--> 2973--> 2974--> 2975--> 2976--> 2977--> 2978--> 2979--> 298--> 2980--> 2981--> 2982--> 2983--> 2984--> 2985--> 2986--> 2987--> 2988--> 2989--> 299--> 2990--> 2991--> 2992--> 2993--> 2994--> 2995--> 2996--> 2997--> 2998--> 2999--> 3--> 30--> 300--> 3000--> 3001--> 3002--> 3003--> 3004--> 3005--> 3006--> 3007--> 3008--> 3009--> 301--> 3010--> 3011--> 3012--> 3013--> 3014--> 3015--> 3016--> 3017--> 3018--> 3019--> 302--> 3020--> 3021--> 3022--> 3023--> 3024--> 3025--> 3026--> 3027--> 3028--> 3029--> 303--> 3030--> 3031--> 3032--> 3033--> 3034--> 3035--> 3036--> 3037--> 3038--> 3039--> 304--> 3040--> 3041--> 3042--> 3043--> 3044--> 3045--> 3046--> 3047--> 3048--> 3049--> 305--> 3050--> 3051--> 3052--> 3053--> 3054--> 3055--> 3056--> 3057--> 3058--> 3059--> 306--> 3060--> 3061--> 3062--> 3063--> 3064--> 3065--> 3066--> 3067--> 3068--> 3069--> 307--> 3070--> 3071--> 3072--> 3073--> 3074--> 3075--> 3076--> 3077--> 3078--> 3079--> 308--> 3080--> 3081--> 3082--> 3083--> 3084--> 3085--> 3086--> 3087--> 3088--> 3089--> 309--> 3090--> 3091--> 3092--> 3093--> 3094--> 3095--> 3096--> 3097--> 3098--> 3099--> 31--> 310--> 3100--> 3101--> 3102--> 3103--> 3104--> 3105--> 3106--> 3107--> 3108--> 3109--> 311--> 3110--> 3111--> 3112--> 3113--> 3114--> 3115--> 3116--> 3117--> 3118--> 3119--> 312--> 3120--> 3121--> 3122--> 3123--> 3124--> 3125--> 3126--> 3127--> 3128--> 3129--> 313--> 3130--> 3131--> 3132--> 3133--> 3134--> 3135--> 3136--> 3137--> 3138--> 3139--> 314--> 3140--> 3141--> 3142--> 3143--> 3144--> 3145--> 3146--> 3147--> 3148--> 3149--> 315--> 3150--> 3151--> 3152--> 3153--> 3154--> 3155--> 3156--> 3157--> 3158--> 3159--> 316--> 3160--> 3161--> 3162--> 3163--> 3164--> 3165--> 3166--> 3167--> 3168--> 3169--> 317--> 3170--> 3171--> 3172--> 3173--> 3174--> 3175--> 3176--> 3177--> 3178--> 3179--> 318--> 3180--> 3181--> 3182--> 3183--> 3184--> 3185--> 3186--> 3187--> 3188--> 3189--> 319--> 3190--> 3191--> 3192--> 3193--> 3194--> 3195--> 3196--> 3197--> 3198--> 3199--> 32--> 320--> 3200--> 3201--> 3202--> 3203--> 3204--> 3205--> 3206--> 3207--> 3208--> 3209--> 321--> 3210--> 3211--> 3212--> 3213--> 3214--> 3215--> 3216--> 3217--> 3218--> 3219--> 322--> 3220--> 3221--> 3222--> 3223--> 3224--> 3225--> 3226--> 3227--> 3228--> 3229--> 323--> 3230--> 3231--> 3232--> 3233--> 3234--> 3235--> 3236--> 3237--> 3238--> 3239--> 324--> 3240--> 3241--> 3242--> 3243--> 3244--> 3245--> 3246--> 3247--> 3248--> 3249--> 325--> 3250--> 3251--> 3252--> 3253--> 3254--> 3255--> 3256--> 3257--> 3258--> 3259--> 326--> 3260--> 3261--> 3262--> 3263--> 3264--> 3265--> 3266--> 3267--> 3268--> 3269--> 327--> 3270--> 3271--> 3272--> 3273--> 3274--> 3275--> 3276--> 3277--> 3278--> 3279--> 328--> 3280--> 3281--> 3282--> 3283--> 3284--> 3285--> 3286--> 3287--> 3288--> 3289--> 329--> 3290--> 3291--> 3292--> 3293--> 3294--> 3295--> 3296--> 3297--> 3298--> 3299--> 33--> 330--> 3300--> 3301--> 3302--> 3303--> 3304--> 3305--> 3306--> 3307--> 3308--> 3309--> 331--> 3310--> 3311--> 3312--> 3313--> 3314--> 3315--> 3316--> 3317--> 3318--> 3319--> 332--> 3320--> 3321--> 3322--> 3323--> 3324--> 3325--> 3326--> 3327--> 3328--> 3329--> 333--> 3330--> 3331--> 3332--> 3333--> 3334--> 3335--> 3336--> 3337--> 3338--> 3339--> 334--> 3340--> 3341--> 3342--> 3343--> 3344--> 3345--> 3346--> 3347--> 3348--> 3349--> 335--> 3350--> 3351--> 3352--> 3353--> 3354--> 3355--> 3356--> 3357--> 3358--> 3359--> 336--> 3360--> 3361--> 3362--> 3363--> 3364--> 3365--> 3366--> 3367--> 3368--> 3369--> 337--> 3370--> 3371--> 3372--> 3373--> 3374--> 3375--> 3376--> 3377--> 3378--> 3379--> 338--> 3380--> 3381--> 3382--> 3383--> 3384--> 3385--> 3386--> 3387--> 3388--> 3389--> 339--> 3390--> 3391--> 3392--> 3393--> 3394--> 3395--> 3396--> 3397--> 3398--> 3399--> 34--> 340--> 3400--> 3401--> 3402--> 3403--> 3404--> 3405--> 3406--> 3407--> 3408--> 3409--> 341--> 3410--> 3411--> 3412--> 3413--> 3414--> 3415--> 3416--> 3417--> 3418--> 3419--> 342--> 3420--> 3421--> 3422--> 3423--> 3424--> 3425--> 3426--> 3427--> 3428--> 3429--> 343--> 3430--> 3431--> 3432--> 3433--> 3434--> 3435--> 3436--> 3437--> 3438--> 3439--> 344--> 3440--> 3441--> 3442--> 3443--> 3444--> 3445--> 3446--> 3447--> 3448--> 3449--> 345--> 3450--> 3451--> 3452--> 3453--> 3454--> 3455--> 3456--> 3457--> 3458--> 3459--> 346--> 3460--> 3461--> 3462--> 3463--> 3464--> 3465--> 3466--> 3467--> 3468--> 3469--> 347--> 3470--> 3471--> 3472--> 3473--> 3474--> 3475--> 3476--> 3477--> 3478--> 3479--> 348--> 3480--> 3481--> 3482--> 3483--> 3484--> 3485--> 3486--> 3487--> 3488--> 3489--> 349--> 3490--> 3491--> 3492--> 3493--> 3494--> 3495--> 3496--> 3497--> 3498--> 3499--> 35--> 350--> 3500--> 3501--> 3502--> 3503--> 3504--> 3505--> 3506--> 3507--> 3508--> 3509--> 351--> 3510--> 3511--> 3512--> 3513--> 3514--> 3515--> 3516--> 3517--> 3518--> 3519--> 352--> 3520--> 3521--> 3522--> 3523--> 3524--> 3525--> 3526--> 3527--> 3528--> 3529--> 353--> 3530--> 3531--> 3532--> 3533--> 3534--> 3535--> 3536--> 3537--> 3538--> 3539--> 354--> 3540--> 3541--> 3542--> 3543--> 3544--> 3545--> 3546--> 3547--> 3548--> 3549--> 355--> 3550--> 3551--> 3552--> 3553--> 3554--> 3555--> 3556--> 3557--> 3558--> 3559--> 356--> 3560--> 3561--> 3562--> 3563--> 3564--> 3565--> 3566--> 3567--> 3568--> 3569--> 357--> 3570--> 3571--> 3572--> 3573--> 3574--> 3575--> 3576--> 3577--> 3578--> 3579--> 358--> 3580--> 3581--> 3582--> 3583--> 3584--> 3585--> 3586--> 3587--> 3588--> 3589--> 359--> 3590--> 3591--> 3592--> 3593--> 3594--> 3595--> 3596--> 3597--> 3598--> 3599--> 36--> 360--> 3600--> 3601--> 3602--> 3603--> 3604--> 3605--> 3606--> 3607--> 3608--> 3609--> 361--> 3610--> 3611--> 3612--> 3613--> 3614--> 3615--> 3616--> 3617--> 3618--> 3619--> 362--> 3620--> 3621--> 3622--> 3623--> 3624--> 3625--> 3626--> 3627--> 3628--> 3629--> 363--> 3630--> 3631--> 3632--> 3633--> 3634--> 3635--> 3636--> 3637--> 3638--> 3639--> 364--> 3640--> 3641--> 3642--> 3643--> 3644--> 3645--> 3646--> 3647--> 3648--> 3649--> 365--> 3650--> 3651--> 3652--> 3653--> 3654--> 3655--> 3656--> 3657--> 3658--> 3659--> 366--> 3660--> 3661--> 3662--> 3663--> 3664--> 3665--> 3666--> 3667--> 3668--> 3669--> 367--> 3670--> 3671--> 3672--> 3673--> 3674--> 3675--> 3676--> 3677--> 3678--> 3679--> 368--> 3680--> 3681--> 3682--> 3683--> 3684--> 3685--> 3686--> 3687--> 3688--> 3689--> 369--> 3690--> 3691--> 3692--> 3693--> 3694--> 3695--> 3696--> 3697--> 3698--> 3699--> 37--> 370--> 3700--> 3701--> 3702--> 3703--> 3704--> 3705--> 3706--> 3707--> 3708--> 3709--> 371--> 3710--> 3711--> 3712--> 3713--> 3714--> 3715--> 3716--> 3717--> 3718--> 3719--> 372--> 3720--> 3721--> 3722--> 3723--> 3724--> 3725--> 3726--> 3727--> 3728--> 3729--> 373--> 3730--> 3731--> 3732--> 3733--> 3734--> 3735--> 3736--> 3737--> 3738--> 3739--> 374--> 3740--> 3741--> 3742--> 3743--> 3744--> 3745--> 3746--> 3747--> 3748--> 3749--> 375--> 3750--> 3751--> 3752--> 3753--> 3754--> 3755--> 3756--> 3757--> 3758--> 3759--> 376--> 3760--> 3761--> 3762--> 3763--> 3764--> 3765--> 3766--> 3767--> 3768--> 3769--> 377--> 3770--> 3771--> 3772--> 3773--> 3774--> 3775--> 3776--> 3777--> 3778--> 3779--> 378--> 3780--> 3781--> 3782--> 3783--> 3784--> 3785--> 3786--> 3787--> 3788--> 3789--> 379--> 3790--> 3791--> 3792--> 3793--> 3794--> 3795--> 3796--> 3797--> 3798--> 3799--> 38--> 380--> 3800--> 3801--> 3802--> 3803--> 3804--> 3805--> 3806--> 3807--> 3808--> 3809--> 381--> 3810--> 3811--> 3812--> 3813--> 3814--> 3815--> 3816--> 3817--> 3818--> 3819--> 382--> 3820--> 3821--> 3822--> 3823--> 3824--> 3825--> 3826--> 3827--> 3828--> 3829--> 383--> 3830--> 3831--> 3832--> 3833--> 3834--> 3835--> 3836--> 3837--> 3838--> 3839--> 384--> 3840--> 3841--> 3842--> 3843--> 3844--> 3845--> 3846--> 3847--> 3848--> 3849--> 385--> 3850--> 3851--> 3852--> 3853--> 3854--> 3855--> 3856--> 3857--> 3858--> 3859--> 386--> 3860--> 3861--> 3862--> 3863--> 3864--> 3865--> 3866--> 3867--> 3868--> 3869--> 387--> 3870--> 3871--> 3872--> 3873--> 3874--> 3875--> 3876--> 3877--> 3878--> 3879--> 388--> 3880--> 3881--> 3882--> 3883--> 3884--> 3885--> 3886--> 3887--> 3888--> 3889--> 389--> 3890--> 3891--> 3892--> 3893--> 3894--> 3895--> 3896--> 3897--> 3898--> 3899--> 39--> 390--> 3900--> 3901--> 3902--> 3903--> 3904--> 3905--> 3906--> 3907--> 3908--> 3909--> 391--> 3910--> 3911--> 3912--> 3913--> 3914--> 3915--> 3916--> 3917--> 3918--> 3919--> 392--> 3920--> 3921--> 3922--> 3923--> 3924--> 3925--> 3926--> 3927--> 3928--> 3929--> 393--> 3930--> 3931--> 3932--> 3933--> 3934--> 3935--> 3936--> 3937--> 3938--> 3939--> 394--> 3940--> 3941--> 3942--> 3943--> 3944--> 3945--> 3946--> 3947--> 3948--> 3949--> 395--> 3950--> 3951--> 3952--> 3953--> 3954--> 3955--> 3956--> 3957--> 3958--> 3959--> 396--> 3960--> 3961--> 3962--> 3963--> 3964--> 3965--> 3966--> 3967--> 3968--> 3969--> 397--> 3970--> 3971--> 3972--> 3973--> 3974--> 3975--> 3976--> 3977--> 3978--> 3979--> 398--> 3980--> 3981--> 3982--> 3983--> 3984--> 3985--> 3986--> 3987--> 3988--> 3989--> 399--> 3990--> 3991--> 3992--> 3993--> 3994--> 3995--> 3996--> 3997--> 3998--> 3999--> 4--> 40--> 400--> 4000--> 4001--> 4002--> 4003--> 4004--> 4005--> 4006--> 4007--> 4008--> 4009--> 401--> 4010--> 4011--> 4012--> 4013--> 4014--> 4015--> 4016--> 4017--> 4018--> 4019--> 402--> 4020--> 4021--> 4022--> 4023--> 4024--> 4025--> 4026--> 4027--> 4028--> 4029--> 403--> 4030--> 4031--> 4032--> 4033--> 4034--> 4035--> 4036--> 4037--> 4038--> 4039--> 404--> 4040--> 4041--> 4042--> 4043--> 4044--> 4045--> 4046--> 4047--> 4048--> 4049--> 405--> 4050--> 4051--> 4052--> 4053--> 4054--> 4055--> 4056--> 4057--> 4058--> 4059--> 406--> 4060--> 4061--> 4062--> 4063--> 4064--> 4065--> 4066--> 4067--> 4068--> 4069--> 407--> 4070--> 4071--> 4072--> 4073--> 4074--> 4075--> 4076--> 4077--> 4078--> 4079--> 408--> 4080--> 4081--> 4082--> 4083--> 4084--> 4085--> 4086--> 4087--> 4088--> 4089--> 409--> 4090--> 4091--> 4092--> 4093--> 4094--> 4095--> 4096--> 4097--> 4098--> 4099--> 41--> 410--> 4100--> 4101--> 4102--> 4103--> 4104--> 4105--> 4106--> 4107--> 4108--> 4109--> 411--> 4110--> 4111--> 4112--> 4113--> 4114--> 4115--> 4116--> 4117--> 4118--> 4119--> 412--> 4120--> 4121--> 4122--> 4123--> 4124--> 4125--> 4126--> 4127--> 4128--> 4129--> 413--> 4130--> 4131--> 4132--> 4133--> 4134--> 4135--> 4136--> 4137--> 4138--> 4139--> 414--> 4140--> 4141--> 4142--> 4143--> 4144--> 4145--> 4146--> 4147--> 4148--> 4149--> 415--> 4150--> 4151--> 4152--> 4153--> 4154--> 4155--> 4156--> 4157--> 4158--> 4159--> 416--> 4160--> 4161--> 4162--> 4163--> 4164--> 4165--> 4166--> 4167--> 4168--> 4169--> 417--> 4170--> 4171--> 4172--> 4173--> 4174--> 4175--> 4176--> 4177--> 4178--> 4179--> 418--> 4180--> 4181--> 4182--> 4183--> 4184--> 4185--> 4186--> 4187--> 4188--> 4189--> 419--> 4190--> 4191--> 4192--> 4193--> 4194--> 4195--> 4196--> 4197--> 4198--> 4199--> 42--> 420--> 4200--> 4201--> 4202--> 4203--> 4204--> 4205--> 4206--> 4207--> 4208--> 4209--> 421--> 4210--> 4211--> 4212--> 4213--> 4214--> 4215--> 4216--> 4217--> 4218--> 4219--> 422--> 4220--> 4221--> 4222--> 4223--> 4224--> 4225--> 4226--> 4227--> 4228--> 4229--> 423--> 4230--> 4231--> 4232--> 4233--> 4234--> 4235--> 4236--> 4237--> 4238--> 4239--> 424--> 4240--> 4241--> 4242--> 4243--> 4244--> 4245--> 4246--> 4247--> 4248--> 4249--> 425--> 4250--> 4251--> 4252--> 4253--> 4254--> 4255--> 4256--> 4257--> 4258--> 4259--> 426--> 4260--> 4261--> 4262--> 4263--> 4264--> 4265--> 4266--> 4267--> 4268--> 4269--> 427--> 4270--> 4271--> 4272--> 4273--> 4274--> 4275--> 4276--> 4277--> 4278--> 4279--> 428--> 4280--> 4281--> 4282--> 4283--> 4284--> 4285--> 4286--> 4287--> 4288--> 4289--> 429--> 4290--> 4291--> 4292--> 4293--> 4294--> 4295--> 4296--> 4297--> 4298--> 4299--> 43--> 430--> 4300--> 4301--> 4302--> 4303--> 4304--> 4305--> 4306--> 4307--> 4308--> 4309--> 431--> 4310--> 4311--> 4312--> 4313--> 4314--> 4315--> 4316--> 4317--> 4318--> 4319--> 432--> 4320--> 4321--> 4322--> 4323--> 4324--> 4325--> 4326--> 4327--> 4328--> 4329--> 433--> 4330--> 4331--> 4332--> 4333--> 4334--> 4335--> 4336--> 4337--> 4338--> 4339--> 434--> 4340--> 4341--> 4342--> 4343--> 4344--> 4345--> 4346--> 4347--> 4348--> 4349--> 435--> 4350--> 4351--> 4352--> 4353--> 4354--> 4355--> 4356--> 4357--> 4358--> 4359--> 436--> 4360--> 4361--> 4362--> 4363--> 4364--> 4365--> 4366--> 4367--> 4368--> 4369--> 437--> 4370--> 4371--> 4372--> 4373--> 4374--> 4375--> 4376--> 4377--> 4378--> 4379--> 438--> 4380--> 4381--> 4382--> 4383--> 4384--> 4385--> 4386--> 4387--> 4388--> 4389--> 439--> 4390--> 4391--> 4392--> 4393--> 4394--> 4395--> 4396--> 4397--> 4398--> 4399--> 44--> 440--> 4400--> 4401--> 4402--> 4403--> 4404--> 4405--> 4406--> 4407--> 4408--> 4409--> 441--> 4410--> 4411--> 4412--> 4413--> 4414--> 4415--> 4416--> 4417--> 4418--> 4419--> 442--> 4420--> 4421--> 4422--> 4423--> 4424--> 4425--> 4426--> 4427--> 4428--> 4429--> 443--> 4430--> 4431--> 4432--> 4433--> 4434--> 4435--> 4436--> 4437--> 4438--> 4439--> 444--> 4440--> 4441--> 4442--> 4443--> 4444--> 4445--> 4446--> 4447--> 4448--> 4449--> 445--> 4450--> 4451--> 4452--> 4453--> 4454--> 4455--> 4456--> 4457--> 4458--> 4459--> 446--> 4460--> 4461--> 4462--> 4463--> 4464--> 4465--> 4466--> 4467--> 4468--> 4469--> 447--> 4470--> 4471--> 4472--> 4473--> 4474--> 4475--> 4476--> 4477--> 4478--> 4479--> 448--> 4480--> 4481--> 4482--> 4483--> 4484--> 4485--> 4486--> 4487--> 4488--> 4489--> 449--> 4490--> 4491--> 4492--> 4493--> 4494--> 4495--> 4496--> 4497--> 4498--> 4499--> 45--> 450--> 4500--> 4501--> 4502--> 4503--> 4504--> 4505--> 4506--> 4507--> 4508--> 4509--> 451--> 4510--> 4511--> 4512--> 4513--> 4514--> 4515--> 4516--> 4517--> 4518--> 4519--> 452--> 4520--> 4521--> 4522--> 4523--> 4524--> 4525--> 4526--> 4527--> 4528--> 4529--> 453--> 4530--> 4531--> 4532--> 4533--> 4534--> 4535--> 4536--> 4537--> 4538--> 4539--> 454--> 4540--> 4541--> 4542--> 4543--> 4544--> 4545--> 4546--> 4547--> 4548--> 4549--> 455--> 4550--> 4551--> 4552--> 4553--> 4554--> 4555--> 4556--> 4557--> 4558--> 4559--> 456--> 4560--> 4561--> 4562--> 4563--> 4564--> 4565--> 4566--> 4567--> 4568--> 4569--> 457--> 4570--> 4571--> 4572--> 4573--> 4574--> 4575--> 4576--> 4577--> 4578--> 4579--> 458--> 4580--> 4581--> 4582--> 4583--> 4584--> 4585--> 4586--> 4587--> 4588--> 4589--> 459--> 4590--> 4591--> 4592--> 4593--> 4594--> 4595--> 4596--> 4597--> 4598--> 4599--> 46--> 460--> 4600--> 4601--> 4602--> 4603--> 4604--> 4605--> 4606--> 4607--> 4608--> 4609--> 461--> 4610--> 4611--> 4612--> 4613--> 4614--> 4615--> 4616--> 4617--> 4618--> 4619--> 462--> 4620--> 4621--> 4622--> 4623--> 4624--> 4625--> 4626--> 4627--> 4628--> 4629--> 463--> 4630--> 4631--> 4632--> 4633--> 4634--> 4635--> 4636--> 4637--> 4638--> 4639--> 464--> 4640--> 4641--> 4642--> 4643--> 4644--> 4645--> 4646--> 4647--> 4648--> 4649--> 465--> 4650--> 4651--> 4652--> 4653--> 4654--> 4655--> 4656--> 4657--> 4658--> 4659--> 466--> 4660--> 4661--> 4662--> 4663--> 4664--> 4665--> 4666--> 4667--> 4668--> 4669--> 467--> 4670--> 4671--> 4672--> 4673--> 4674--> 4675--> 4676--> 4677--> 4678--> 4679--> 468--> 4680--> 4681--> 4682--> 4683--> 4684--> 4685--> 4686--> 4687--> 4688--> 4689--> 469--> 4690--> 4691--> 4692--> 4693--> 4694--> 4695--> 4696--> 4697--> 4698--> 4699--> 47--> 470--> 4700--> 4701--> 4702--> 4703--> 4704--> 4705--> 4706--> 4707--> 4708--> 4709--> 471--> 4710--> 4711--> 4712--> 4713--> 4714--> 4715--> 4716--> 4717--> 4718--> 4719--> 472--> 4720--> 4721--> 4722--> 4723--> 4724--> 4725--> 4726--> 4727--> 4728--> 4729--> 473--> 4730--> 4731--> 4732--> 4733--> 4734--> 4735--> 4736--> 4737--> 4738--> 4739--> 474--> 4740--> 4741--> 4742--> 4743--> 4744--> 4745--> 4746--> 4747--> 4748--> 4749--> 475--> 4750--> 4751--> 4752--> 4753--> 4754--> 4755--> 4756--> 4757--> 4758--> 4759--> 476--> 4760--> 4761--> 4762--> 4763--> 4764--> 4765--> 4766--> 4767--> 4768--> 4769--> 477--> 4770--> 4771--> 4772--> 4773--> 4774--> 4775--> 4776--> 4777--> 4778--> 4779--> 478--> 4780--> 4781--> 4782--> 4783--> 4784--> 4785--> 4786--> 4787--> 4788--> 4789--> 479--> 4790--> 4791--> 4792--> 4793--> 4794--> 4795--> 4796--> 4797--> 4798--> 4799--> 48--> 480--> 4800--> 4801--> 4802--> 4803--> 4804--> 4805--> 4806--> 4807--> 4808--> 4809--> 481--> 4810--> 4811--> 4812--> 4813--> 4814--> 4815--> 4816--> 4817--> 4818--> 4819--> 482--> 4820--> 4821--> 4822--> 4823--> 4824--> 4825--> 4826--> 4827--> 4828--> 4829--> 483--> 4830--> 4831--> 4832--> 4833--> 4834--> 4835--> 4836--> 4837--> 4838--> 4839--> 484--> 4840--> 4841--> 4842--> 4843--> 4844--> 4845--> 4846--> 4847--> 4848--> 4849--> 485--> 4850--> 4851--> 4852--> 4853--> 4854--> 4855--> 4856--> 4857--> 4858--> 4859--> 486--> 4860--> 4861--> 4862--> 4863--> 4864--> 4865--> 4866--> 4867--> 4868--> 4869--> 487--> 4870--> 4871--> 4872--> 4873--> 4874--> 4875--> 4876--> 4877--> 4878--> 4879--> 488--> 4880--> 4881--> 4882--> 4883--> 4884--> 4885--> 4886--> 4887--> 4888--> 4889--> 489--> 4890--> 4891--> 4892--> 4893--> 4894--> 4895--> 4896--> 4897--> 4898--> 4899--> 49--> 490--> 4900--> 4901--> 4902--> 4903--> 4904--> 4905--> 4906--> 4907--> 4908--> 4909--> 491--> 4910--> 4911--> 4912--> 4913--> 4914--> 4915--> 4916--> 4917--> 4918--> 4919--> 492--> 4920--> 4921--> 4922--> 4923--> 4924--> 4925--> 4926--> 4927--> 4928--> 4929--> 493--> 4930--> 4931--> 4932--> 4933--> 4934--> 4935--> 4936--> 4937--> 4938--> 4939--> 494--> 4940--> 4941--> 4942--> 4943--> 4944--> 4945--> 4946--> 4947--> 4948--> 4949--> 495--> 4950--> 4951--> 4952--> 4953--> 4954--> 4955--> 4956--> 4957--> 4958--> 4959--> 496--> 4960--> 4961--> 4962--> 4963--> 4964--> 4965--> 4966--> 4967--> 4968--> 4969--> 497--> 4970--> 4971--> 4972--> 4973--> 4974--> 4975--> 4976--> 4977--> 4978--> 4979--> 498--> 4980--> 4981--> 4982--> 4983--> 4984--> 4985--> 4986--> 4987--> 4988--> 4989--> 499--> 4990--> 4991--> 4992--> 4993--> 4994--> 4995--> 4996--> 4997--> 4998--> 4999--> 5--> 50--> 500--> 5000--> 5001--> 5002--> 5003--> 5004--> 5005--> 5006--> 5007--> 5008--> 5009--> 501--> 5010--> 5011--> 5012--> 5013--> 5014--> 5015--> 5016--> 5017--> 5018--> 5019--> 502--> 5020--> 5021--> 5022--> 5023--> 5024--> 5025--> 5026--> 5027--> 5028--> 5029--> 503--> 5030--> 5031--> 5032--> 5033--> 5034--> 5035--> 5036--> 5037--> 5038--> 5039--> 504--> 5040--> 5041--> 5042--> 5043--> 5044--> 5045--> 5046--> 5047--> 5048--> 5049--> 505--> 5050--> 5051--> 5052--> 5053--> 5054--> 5055--> 5056--> 5057--> 5058--> 5059--> 506--> 5060--> 5061--> 5062--> 5063--> 5064--> 5065--> 5066--> 5067--> 5068--> 5069--> 507--> 5070--> 5071--> 5072--> 5073--> 5074--> 5075--> 5076--> 5077--> 5078--> 5079--> 508--> 5080--> 5081--> 5082--> 5083--> 5084--> 5085--> 5086--> 5087--> 5088--> 5089--> 509--> 5090--> 5091--> 5092--> 5093--> 5094--> 5095--> 5096--> 5097--> 5098--> 5099--> 51--> 510--> 5100--> 5101--> 5102--> 5103--> 5104--> 5105--> 5106--> 5107--> 5108--> 5109--> 511--> 5110--> 5111--> 5112--> 5113--> 5114--> 5115--> 5116--> 5117--> 5118--> 5119--> 512--> 5120--> 5121--> 5122--> 5123--> 5124--> 5125--> 5126--> 5127--> 5128--> 5129--> 513--> 5130--> 5131--> 5132--> 5133--> 5134--> 5135--> 5136--> 5137--> 5138--> 5139--> 514--> 5140--> 5141--> 5142--> 5143--> 5144--> 5145--> 5146--> 5147--> 5148--> 5149--> 515--> 5150--> 5151--> 5152--> 5153--> 5154--> 5155--> 5156--> 5157--> 5158--> 5159--> 516--> 5160--> 5161--> 5162--> 5163--> 5164--> 5165--> 5166--> 5167--> 5168--> 5169--> 517--> 5170--> 5171--> 5172--> 5173--> 5174--> 5175--> 5176--> 5177--> 5178--> 5179--> 518--> 5180--> 5181--> 5182--> 5183--> 5184--> 5185--> 5186--> 5187--> 5188--> 5189--> 519--> 5190--> 5191--> 5192--> 5193--> 5194--> 5195--> 5196--> 5197--> 5198--> 5199--> 52--> 520--> 5200--> 5201--> 5202--> 5203--> 5204--> 5205--> 5206--> 5207--> 5208--> 5209--> 521--> 5210--> 5211--> 5212--> 5213--> 5214--> 5215--> 5216--> 5217--> 5218--> 5219--> 522--> 5220--> 5221--> 5222--> 5223--> 5224--> 5225--> 5226--> 5227--> 5228--> 5229--> 523--> 5230--> 5231--> 5232--> 5233--> 5234--> 5235--> 5236--> 5237--> 5238--> 5239--> 524--> 5240--> 5241--> 5242--> 5243--> 5244--> 5245--> 5246--> 5247--> 5248--> 5249--> 525--> 5250--> 5251--> 5252--> 5253--> 5254--> 5255--> 5256--> 5257--> 5258--> 5259--> 526--> 5260--> 5261--> 5262--> 5263--> 5264--> 5265--> 5266--> 5267--> 5268--> 5269--> 527--> 5270--> 5271--> 5272--> 5273--> 5274--> 5275--> 5276--> 5277--> 5278--> 5279--> 528--> 5280--> 5281--> 5282--> 5283--> 5284--> 5285--> 5286--> 5287--> 5288--> 5289--> 529--> 5290--> 5291--> 5292--> 5293--> 5294--> 5295--> 5296--> 5297--> 5298--> 5299--> 53--> 530--> 5300--> 5301--> 5302--> 5303--> 5304--> 5305--> 5306--> 5307--> 5308--> 5309--> 531--> 5310--> 5311--> 5312--> 5313--> 5314--> 5315--> 5316--> 5317--> 5318--> 5319--> 532--> 5320--> 5321--> 5322--> 5323--> 5324--> 5325--> 5326--> 5327--> 5328--> 5329--> 533--> 5330--> 5331--> 5332--> 5333--> 5334--> 5335--> 5336--> 5337--> 5338--> 5339--> 534--> 5340--> 5341--> 5342--> 5343--> 5344--> 5345--> 5346--> 5347--> 5348--> 5349--> 535--> 5350--> 5351--> 5352--> 5353--> 5354--> 5355--> 5356--> 5357--> 5358--> 5359--> 536--> 5360--> 5361--> 5362--> 5363--> 5364--> 5365--> 5366--> 5367--> 5368--> 5369--> 537--> 5370--> 5371--> 5372--> 5373--> 5374--> 5375--> 5376--> 5377--> 5378--> 5379--> 538--> 5380--> 5381--> 5382--> 5383--> 5384--> 5385--> 5386--> 5387--> 5388--> 5389--> 539--> 5390--> 5391--> 5392--> 5393--> 5394--> 5395--> 5396--> 5397--> 5398--> 5399--> 54--> 540--> 5400--> 5401--> 5402--> 5403--> 5404--> 5405--> 5406--> 5407--> 5408--> 5409--> 541--> 5410--> 5411--> 5412--> 5413--> 5414--> 5415--> 5416--> 5417--> 5418--> 5419--> 542--> 5420--> 5421--> 5422--> 5423--> 5424--> 5425--> 5426--> 5427--> 5428--> 5429--> 543--> 5430--> 5431--> 5432--> 5433--> 5434--> 5435--> 5436--> 5437--> 5438--> 5439--> 544--> 5440--> 5441--> 5442--> 5443--> 5444--> 5445--> 5446--> 5447--> 5448--> 5449--> 545--> 5450--> 5451--> 5452--> 5453--> 5454--> 5455--> 5456--> 5457--> 5458--> 5459--> 546--> 5460--> 5461--> 5462--> 5463--> 5464--> 5465--> 5466--> 5467--> 5468--> 5469--> 547--> 5470--> 5471--> 5472--> 5473--> 5474--> 5475--> 5476--> 5477--> 5478--> 5479--> 548--> 5480--> 5481--> 5482--> 5483--> 5484--> 5485--> 5486--> 5487--> 5488--> 5489--> 549--> 5490--> 5491--> 5492--> 5493--> 5494--> 5495--> 5496--> 5497--> 5498--> 5499--> 55--> 550--> 5500--> 5501--> 5502--> 5503--> 5504--> 5505--> 5506--> 5507--> 5508--> 5509--> 551--> 5510--> 5511--> 5512--> 5513--> 5514--> 5515--> 5516--> 5517--> 5518--> 5519--> 552--> 5520--> 5521--> 5522--> 5523--> 5524--> 5525--> 5526--> 5527--> 5528--> 5529--> 553--> 5530--> 5531--> 5532--> 5533--> 5534--> 5535--> 5536--> 5537--> 5538--> 5539--> 554--> 5540--> 5541--> 5542--> 5543--> 5544--> 5545--> 5546--> 5547--> 5548--> 5549--> 555--> 5550--> 5551--> 5552--> 5553--> 5554--> 5555--> 5556--> 5557--> 5558--> 5559--> 556--> 5560--> 5561--> 5562--> 5563--> 5564--> 5565--> 5566--> 5567--> 5568--> 5569--> 557--> 5570--> 5571--> 5572--> 5573--> 5574--> 5575--> 5576--> 5577--> 5578--> 5579--> 558--> 5580--> 5581--> 5582--> 5583--> 5584--> 5585--> 5586--> 5587--> 5588--> 5589--> 559--> 5590--> 5591--> 5592--> 5593--> 5594--> 5595--> 5596--> 5597--> 5598--> 5599--> 56--> 560--> 5600--> 5601--> 5602--> 5603--> 5604--> 5605--> 5606--> 5607--> 5608--> 5609--> 561--> 5610--> 5611--> 5612--> 5613--> 5614--> 5615--> 5616--> 5617--> 5618--> 5619--> 562--> 5620--> 5621--> 5622--> 5623--> 5624--> 5625--> 5626--> 5627--> 5628--> 5629--> 563--> 5630--> 5631--> 5632--> 5633--> 5634--> 5635--> 5636--> 5637--> 5638--> 5639--> 564--> 5640--> 5641--> 5642--> 5643--> 5644--> 5645--> 5646--> 5647--> 5648--> 5649--> 565--> 5650--> 5651--> 5652--> 5653--> 5654--> 5655--> 5656--> 5657--> 5658--> 5659--> 566--> 5660--> 5661--> 5662--> 5663--> 5664--> 5665--> 5666--> 5667--> 5668--> 5669--> 567--> 5670--> 5671--> 5672--> 5673--> 5674--> 5675--> 5676--> 5677--> 5678--> 5679--> 568--> 5680--> 5681--> 5682--> 5683--> 5684--> 5685--> 5686--> 5687--> 5688--> 5689--> 569--> 5690--> 5691--> 5692--> 5693--> 5694--> 5695--> 5696--> 5697--> 5698--> 5699--> 57--> 570--> 5700--> 5701--> 5702--> 5703--> 5704--> 5705--> 5706--> 5707--> 5708--> 5709--> 571--> 5710--> 5711--> 5712--> 5713--> 5714--> 5715--> 5716--> 5717--> 5718--> 5719--> 572--> 5720--> 5721--> 5722--> 5723--> 5724--> 5725--> 5726--> 5727--> 5728--> 5729--> 573--> 5730--> 5731--> 5732--> 5733--> 5734--> 5735--> 5736--> 5737--> 5738--> 5739--> 574--> 5740--> 5741--> 5742--> 5743--> 5744--> 5745--> 5746--> 5747--> 5748--> 5749--> 575--> 5750--> 5751--> 5752--> 5753--> 5754--> 5755--> 5756--> 5757--> 5758--> 5759--> 576--> 5760--> 5761--> 5762--> 5763--> 5764--> 5765--> 5766--> 5767--> 5768--> 5769--> 577--> 5770--> 5771--> 5772--> 5773--> 5774--> 5775--> 5776--> 5777--> 5778--> 5779--> 578--> 5780--> 5781--> 5782--> 5783--> 5784--> 5785--> 5786--> 5787--> 5788--> 5789--> 579--> 5790--> 5791--> 5792--> 5793--> 5794--> 5795--> 5796--> 5797--> 5798--> 5799--> 58--> 580--> 5800--> 5801--> 5802--> 5803--> 5804--> 5805--> 5806--> 5807--> 5808--> 5809--> 581--> 5810--> 5811--> 5812--> 5813--> 5814--> 5815--> 5816--> 5817--> 5818--> 5819--> 582--> 5820--> 5821--> 5822--> 5823--> 5824--> 5825--> 5826--> 5827--> 5828--> 5829--> 583--> 5830--> 5831--> 5832--> 5833--> 5834--> 5835--> 5836--> 5837--> 5838--> 5839--> 584--> 5840--> 5841--> 5842--> 5843--> 5844--> 5845--> 5846--> 5847--> 5848--> 5849--> 585--> 5850--> 5851--> 5852--> 5853--> 5854--> 5855--> 5856--> 5857--> 5858--> 5859--> 586--> 5860--> 5861--> 5862--> 5863--> 5864--> 5865--> 5866--> 5867--> 5868--> 5869--> 587--> 5870--> 5871--> 5872--> 5873--> 5874--> 5875--> 5876--> 5877--> 5878--> 5879--> 588--> 5880--> 5881--> 5882--> 5883--> 5884--> 5885--> 5886--> 5887--> 5888--> 5889--> 589--> 5890--> 5891--> 5892--> 5893--> 5894--> 5895--> 5896--> 5897--> 5898--> 5899--> 59--> 590--> 5900--> 5901--> 5902--> 5903--> 5904--> 5905--> 5906--> 5907--> 5908--> 5909--> 591--> 5910--> 5911--> 5912--> 5913--> 5914--> 5915--> 5916--> 5917--> 5918--> 5919--> 592--> 5920--> 5921--> 5922--> 5923--> 5924--> 5925--> 5926--> 5927--> 5928--> 5929--> 593--> 5930--> 5931--> 5932--> 5933--> 5934--> 5935--> 5936--> 5937--> 5938--> 5939--> 594--> 5940--> 5941--> 5942--> 5943--> 5944--> 5945--> 5946--> 5947--> 5948--> 5949--> 595--> 5950--> 5951--> 5952--> 5953--> 5954--> 5955--> 5956--> 5957--> 5958--> 5959--> 596--> 5960--> 5961--> 5962--> 5963--> 5964--> 5965--> 5966--> 5967--> 5968--> 5969--> 597--> 5970--> 5971--> 5972--> 5973--> 5974--> 5975--> 5976--> 5977--> 5978--> 5979--> 598--> 5980--> 5981--> 5982--> 5983--> 5984--> 5985--> 5986--> 5987--> 5988--> 5989--> 599--> 5990--> 5991--> 5992--> 5993--> 5994--> 5995--> 5996--> 5997--> 5998--> 5999--> 6--> 60--> 600--> 6000--> 6001--> 6002--> 6003--> 6004--> 6005--> 6006--> 6007--> 6008--> 6009--> 601--> 6010--> 6011--> 6012--> 6013--> 6014--> 6015--> 6016--> 6017--> 6018--> 6019--> 602--> 6020--> 6021--> 6022--> 6023--> 6024--> 6025--> 6026--> 6027--> 6028--> 6029--> 603--> 6030--> 6031--> 6032--> 6033--> 6034--> 6035--> 6036--> 6037--> 6038--> 6039--> 604--> 6040--> 6041--> 6042--> 6043--> 6044--> 6045--> 6046--> 6047--> 6048--> 6049--> 605--> 6050--> 6051--> 6052--> 6053--> 6054--> 6055--> 6056--> 6057--> 6058--> 6059--> 606--> 6060--> 6061--> 6062--> 6063--> 6064--> 6065--> 6066--> 6067--> 6068--> 6069--> 607--> 6070--> 6071--> 6072--> 6073--> 6074--> 6075--> 6076--> 6077--> 6078--> 6079--> 608--> 6080--> 6081--> 6082--> 6083--> 6084--> 6085--> 6086--> 6087--> 6088--> 6089--> 609--> 6090--> 6091--> 6092--> 6093--> 6094--> 6095--> 6096--> 6097--> 6098--> 6099--> 61--> 610--> 6100--> 6101--> 6102--> 6103--> 6104--> 6105--> 6106--> 6107--> 6108--> 6109--> 611--> 6110--> 6111--> 6112--> 6113--> 6114--> 6115--> 6116--> 6117--> 6118--> 6119--> 612--> 6120--> 6121--> 6122--> 6123--> 6124--> 6125--> 6126--> 6127--> 6128--> 6129--> 613--> 6130--> 6131--> 6132--> 6133--> 6134--> 6135--> 6136--> 6137--> 6138--> 6139--> 614--> 6140--> 6141--> 6142--> 6143--> 6144--> 6145--> 6146--> 6147--> 6148--> 6149--> 615--> 6150--> 6151--> 6152--> 6153--> 6154--> 6155--> 6156--> 6157--> 6158--> 6159--> 616--> 6160--> 6161--> 6162--> 6163--> 6164--> 6165--> 6166--> 6167--> 6168--> 6169--> 617--> 6170--> 6171--> 6172--> 6173--> 6174--> 6175--> 6176--> 6177--> 6178--> 6179--> 618--> 6180--> 6181--> 6182--> 6183--> 6184--> 6185--> 6186--> 6187--> 6188--> 6189--> 619--> 6190--> 6191--> 6192--> 6193--> 6194--> 6195--> 6196--> 6197--> 6198--> 6199--> 62--> 620--> 6200--> 6201--> 6202--> 6203--> 6204--> 6205--> 6206--> 6207--> 6208--> 6209--> 621--> 6210--> 6211--> 6212--> 6213--> 6214--> 6215--> 6216--> 6217--> 6218--> 6219--> 622--> 6220--> 6221--> 6222--> 6223--> 6224--> 6225--> 6226--> 6227--> 6228--> 6229--> 623--> 6230--> 6231--> 6232--> 6233--> 6234--> 6235--> 6236--> 6237--> 6238--> 6239--> 624--> 6240--> 6241--> 6242--> 6243--> 6244--> 6245--> 6246--> 6247--> 6248--> 6249--> 625--> 6250--> 6251--> 6252--> 6253--> 6254--> 6255--> 6256--> 6257--> 6258--> 6259--> 626--> 6260--> 6261--> 6262--> 6263--> 6264--> 6265--> 6266--> 6267--> 6268--> 6269--> 627--> 6270--> 6271--> 6272--> 6273--> 6274--> 6275--> 6276--> 6277--> 6278--> 6279--> 628--> 6280--> 6281--> 6282--> 6283--> 6284--> 6285--> 6286--> 6287--> 6288--> 6289--> 629--> 6290--> 6291--> 6292--> 6293--> 6294--> 6295--> 6296--> 6297--> 6298--> 6299--> 63--> 630--> 6300--> 6301--> 6302--> 6303--> 6304--> 6305--> 6306--> 6307--> 6308--> 6309--> 631--> 6310--> 6311--> 6312--> 6313--> 6314--> 6315--> 6316--> 6317--> 6318--> 6319--> 632--> 6320--> 6321--> 6322--> 6323--> 6324--> 6325--> 6326--> 6327--> 6328--> 6329--> 633--> 6330--> 6331--> 6332--> 6333--> 6334--> 6335--> 6336--> 6337--> 6338--> 6339--> 634--> 6340--> 6341--> 6342--> 6343--> 6344--> 6345--> 6346--> 6347--> 6348--> 6349--> 635--> 6350--> 6351--> 6352--> 6353--> 6354--> 6355--> 6356--> 6357--> 6358--> 6359--> 636--> 6360--> 6361--> 6362--> 6363--> 6364--> 6365--> 6366--> 6367--> 6368--> 6369--> 637--> 6370--> 6371--> 6372--> 6373--> 6374--> 6375--> 6376--> 6377--> 6378--> 6379--> 638--> 6380--> 6381--> 6382--> 6383--> 6384--> 6385--> 6386--> 6387--> 6388--> 6389--> 639--> 6390--> 6391--> 6392--> 6393--> 6394--> 6395--> 6396--> 6397--> 6398--> 6399--> 64--> 640--> 6400--> 6401--> 6402--> 6403--> 6404--> 6405--> 6406--> 6407--> 6408--> 6409--> 641--> 6410--> 6411--> 6412--> 6413--> 6414--> 6415--> 6416--> 6417--> 6418--> 6419--> 642--> 6420--> 6421--> 6422--> 6423--> 6424--> 6425--> 6426--> 6427--> 6428--> 6429--> 643--> 6430--> 6431--> 6432--> 6433--> 6434--> 6435--> 6436--> 6437--> 6438--> 6439--> 644--> 6440--> 6441--> 6442--> 6443--> 6444--> 6445--> 6446--> 6447--> 6448--> 6449--> 645--> 6450--> 6451--> 6452--> 6453--> 6454--> 6455--> 6456--> 6457--> 6458--> 6459--> 646--> 6460--> 6461--> 6462--> 6463--> 6464--> 6465--> 6466--> 6467--> 6468--> 6469--> 647--> 6470--> 6471--> 6472--> 6473--> 6474--> 6475--> 6476--> 6477--> 6478--> 6479--> 648--> 6480--> 6481--> 6482--> 6483--> 6484--> 6485--> 6486--> 6487--> 6488--> 6489--> 649--> 6490--> 6491--> 6492--> 6493--> 6494--> 6495--> 6496--> 6497--> 6498--> 6499--> 65--> 650--> 6500--> 6501--> 6502--> 6503--> 6504--> 6505--> 6506--> 6507--> 6508--> 6509--> 651--> 6510--> 6511--> 6512--> 6513--> 6514--> 6515--> 6516--> 6517--> 6518--> 6519--> 652--> 6520--> 6521--> 6522--> 6523--> 6524--> 6525--> 6526--> 6527--> 6528--> 6529--> 653--> 6530--> 6531--> 6532--> 6533--> 6534--> 6535--> 6536--> 6537--> 6538--> 6539--> 654--> 6540--> 6541--> 6542--> 6543--> 6544--> 6545--> 6546--> 6547--> 6548--> 6549--> 655--> 6550--> 6551--> 6552--> 6553--> 6554--> 6555--> 6556--> 6557--> 6558--> 6559--> 656--> 6560--> 6561--> 6562--> 6563--> 6564--> 6565--> 6566--> 6567--> 6568--> 6569--> 657--> 6570--> 6571--> 6572--> 6573--> 6574--> 6575--> 6576--> 6577--> 6578--> 6579--> 658--> 6580--> 6581--> 6582--> 6583--> 6584--> 6585--> 6586--> 6587--> 6588--> 6589--> 659--> 6590--> 6591--> 6592--> 6593--> 6594--> 6595--> 6596--> 6597--> 6598--> 6599--> 66--> 660--> 6600--> 6601--> 6602--> 6603--> 6604--> 6605--> 6606--> 6607--> 6608--> 6609--> 661--> 6610--> 6611--> 6612--> 6613--> 6614--> 6615--> 6616--> 6617--> 6618--> 6619--> 662--> 6620--> 6621--> 6622--> 6623--> 6624--> 6625--> 6626--> 6627--> 6628--> 6629--> 663--> 6630--> 6631--> 6632--> 6633--> 6634--> 6635--> 6636--> 6637--> 6638--> 6639--> 664--> 6640--> 6641--> 6642--> 6643--> 6644--> 6645--> 6646--> 6647--> 6648--> 6649--> 665--> 6650--> 6651--> 6652--> 6653--> 6654--> 6655--> 6656--> 6657--> 6658--> 6659--> 666--> 6660--> 6661--> 6662--> 6663--> 6664--> 6665--> 6666--> 6667--> 6668--> 6669--> 667--> 6670--> 6671--> 6672--> 6673--> 6674--> 6675--> 6676--> 6677--> 6678--> 6679--> 668--> 6680--> 6681--> 6682--> 6683--> 6684--> 6685--> 6686--> 6687--> 6688--> 6689--> 669--> 6690--> 6691--> 6692--> 6693--> 6694--> 6695--> 6696--> 6697--> 6698--> 6699--> 67--> 670--> 6700--> 6701--> 6702--> 6703--> 6704--> 6705--> 6706--> 6707--> 6708--> 6709--> 671--> 6710--> 6711--> 6712--> 6713--> 6714--> 6715--> 6716--> 6717--> 6718--> 6719--> 672--> 6720--> 6721--> 6722--> 6723--> 6724--> 6725--> 6726--> 6727--> 6728--> 6729--> 673--> 6730--> 6731--> 6732--> 6733--> 6734--> 6735--> 6736--> 6737--> 6738--> 6739--> 674--> 6740--> 6741--> 6742--> 6743--> 6744--> 6745--> 6746--> 6747--> 6748--> 6749--> 675--> 6750--> 6751--> 6752--> 6753--> 6754--> 6755--> 6756--> 6757--> 6758--> 6759--> 676--> 6760--> 6761--> 6762--> 6763--> 6764--> 6765--> 6766--> 6767--> 6768--> 6769--> 677--> 6770--> 6771--> 6772--> 6773--> 6774--> 6775--> 6776--> 6777--> 6778--> 6779--> 678--> 6780--> 6781--> 6782--> 6783--> 6784--> 6785--> 6786--> 6787--> 6788--> 6789--> 679--> 6790--> 6791--> 6792--> 6793--> 6794--> 6795--> 6796--> 6797--> 6798--> 6799--> 68--> 680--> 6800--> 6801--> 6802--> 6803--> 6804--> 6805--> 6806--> 6807--> 6808--> 6809--> 681--> 6810--> 6811--> 6812--> 6813--> 6814--> 6815--> 6816--> 6817--> 6818--> 6819--> 682--> 6820--> 6821--> 6822--> 6823--> 6824--> 6825--> 6826--> 6827--> 6828--> 6829--> 683--> 6830--> 6831--> 6832--> 6833--> 6834--> 6835--> 6836--> 6837--> 6838--> 6839--> 684--> 6840--> 6841--> 6842--> 6843--> 6844--> 6845--> 6846--> 6847--> 6848--> 6849--> 685--> 6850--> 6851--> 6852--> 6853--> 6854--> 6855--> 6856--> 6857--> 6858--> 6859--> 686--> 6860--> 6861--> 6862--> 6863--> 6864--> 6865--> 6866--> 6867--> 6868--> 6869--> 687--> 6870--> 6871--> 6872--> 6873--> 6874--> 6875--> 6876--> 6877--> 6878--> 6879--> 688--> 6880--> 6881--> 6882--> 6883--> 6884--> 6885--> 6886--> 6887--> 6888--> 6889--> 689--> 6890--> 6891--> 6892--> 6893--> 6894--> 6895--> 6896--> 6897--> 6898--> 6899--> 69--> 690--> 6900--> 6901--> 6902--> 6903--> 6904--> 6905--> 6906--> 6907--> 6908--> 6909--> 691--> 6910--> 6911--> 6912--> 6913--> 6914--> 6915--> 6916--> 6917--> 6918--> 6919--> 692--> 6920--> 6921--> 6922--> 6923--> 6924--> 6925--> 6926--> 6927--> 6928--> 6929--> 693--> 6930--> 6931--> 6932--> 6933--> 6934--> 6935--> 6936--> 6937--> 6938--> 6939--> 694--> 6940--> 6941--> 6942--> 6943--> 6944--> 6945--> 6946--> 6947--> 6948--> 6949--> 695--> 6950--> 6951--> 6952--> 6953--> 6954--> 6955--> 6956--> 6957--> 6958--> 6959--> 696--> 6960--> 6961--> 6962--> 6963--> 6964--> 6965--> 6966--> 6967--> 6968--> 6969--> 697--> 6970--> 6971--> 6972--> 6973--> 6974--> 6975--> 6976--> 6977--> 6978--> 6979--> 698--> 6980--> 6981--> 6982--> 6983--> 6984--> 6985--> 6986--> 6987--> 6988--> 6989--> 699--> 6990--> 6991--> 6992--> 6993--> 6994--> 6995--> 6996--> 6997--> 6998--> 6999--> 7--> 70--> 700--> 7000--> 7001--> 7002--> 7003--> 7004--> 7005--> 7006--> 7007--> 7008--> 7009--> 701--> 7010--> 7011--> 7012--> 7013--> 7014--> 7015--> 7016--> 7017--> 7018--> 7019--> 702--> 7020--> 7021--> 7022--> 7023--> 7024--> 7025--> 7026--> 7027--> 7028--> 7029--> 703--> 7030--> 7031--> 7032--> 7033--> 7034--> 7035--> 7036--> 7037--> 7038--> 7039--> 704--> 7040--> 7041--> 7042--> 7043--> 7044--> 7045--> 7046--> 7047--> 7048--> 7049--> 705--> 7050--> 7051--> 7052--> 7053--> 7054--> 7055--> 7056--> 7057--> 7058--> 7059--> 706--> 7060--> 7061--> 7062--> 7063--> 7064--> 7065--> 7066--> 7067--> 7068--> 7069--> 707--> 7070--> 7071--> 7072--> 7073--> 7074--> 7075--> 7076--> 7077--> 7078--> 7079--> 708--> 7080--> 7081--> 7082--> 7083--> 7084--> 7085--> 7086--> 7087--> 7088--> 7089--> 709--> 7090--> 7091--> 7092--> 7093--> 7094--> 7095--> 7096--> 7097--> 7098--> 7099--> 71--> 710--> 7100--> 7101--> 7102--> 7103--> 7104--> 7105--> 7106--> 7107--> 7108--> 7109--> 711--> 7110--> 7111--> 7112--> 7113--> 7114--> 7115--> 7116--> 7117--> 7118--> 7119--> 712--> 7120--> 7121--> 7122--> 7123--> 7124--> 7125--> 7126--> 7127--> 7128--> 7129--> 713--> 7130--> 7131--> 7132--> 7133--> 7134--> 7135--> 7136--> 7137--> 7138--> 7139--> 714--> 7140--> 7141--> 7142--> 7143--> 7144--> 7145--> 7146--> 7147--> 7148--> 7149--> 715--> 7150--> 7151--> 7152--> 7153--> 7154--> 7155--> 7156--> 7157--> 7158--> 7159--> 716--> 7160--> 7161--> 7162--> 7163--> 7164--> 7165--> 7166--> 7167--> 7168--> 7169--> 717--> 7170--> 7171--> 7172--> 7173--> 7174--> 7175--> 7176--> 7177--> 7178--> 7179--> 718--> 7180--> 7181--> 7182--> 7183--> 7184--> 7185--> 7186--> 7187--> 7188--> 7189--> 719--> 7190--> 7191--> 7192--> 7193--> 7194--> 7195--> 7196--> 7197--> 7198--> 7199--> 72--> 720--> 7200--> 7201--> 7202--> 7203--> 7204--> 7205--> 7206--> 7207--> 7208--> 7209--> 721--> 7210--> 7211--> 7212--> 7213--> 7214--> 7215--> 7216--> 7217--> 7218--> 7219--> 722--> 7220--> 7221--> 7222--> 7223--> 7224--> 7225--> 7226--> 7227--> 7228--> 7229--> 723--> 7230--> 7231--> 7232--> 7233--> 7234--> 7235--> 7236--> 7237--> 7238--> 7239--> 724--> 7240--> 7241--> 7242--> 7243--> 7244--> 7245--> 7246--> 7247--> 7248--> 7249--> 725--> 7250--> 7251--> 7252--> 7253--> 7254--> 7255--> 7256--> 7257--> 7258--> 7259--> 726--> 7260--> 7261--> 7262--> 7263--> 7264--> 7265--> 7266--> 7267--> 7268--> 7269--> 727--> 7270--> 7271--> 7272--> 7273--> 7274--> 7275--> 7276--> 7277--> 7278--> 7279--> 728--> 7280--> 7281--> 7282--> 7283--> 7284--> 7285--> 7286--> 7287--> 7288--> 7289--> 729--> 7290--> 7291--> 7292--> 7293--> 7294--> 7295--> 7296--> 7297--> 7298--> 7299--> 73--> 730--> 7300--> 7301--> 7302--> 7303--> 7304--> 7305--> 7306--> 7307--> 7308--> 7309--> 731--> 7310--> 7311--> 7312--> 7313--> 7314--> 7315--> 7316--> 7317--> 7318--> 7319--> 732--> 7320--> 7321--> 7322--> 7323--> 7324--> 7325--> 7326--> 7327--> 7328--> 7329--> 733--> 7330--> 7331--> 7332--> 7333--> 7334--> 7335--> 7336--> 7337--> 7338--> 7339--> 734--> 7340--> 7341--> 7342--> 7343--> 7344--> 7345--> 7346--> 7347--> 7348--> 7349--> 735--> 7350--> 7351--> 7352--> 7353--> 7354--> 7355--> 7356--> 7357--> 7358--> 7359--> 736--> 7360--> 7361--> 7362--> 7363--> 7364--> 7365--> 7366--> 7367--> 7368--> 7369--> 737--> 7370--> 7371--> 7372--> 7373--> 7374--> 7375--> 7376--> 7377--> 7378--> 7379--> 738--> 7380--> 7381--> 7382--> 7383--> 7384--> 7385--> 7386--> 7387--> 7388--> 7389--> 739--> 7390--> 7391--> 7392--> 7393--> 7394--> 7395--> 7396--> 7397--> 7398--> 7399--> 74--> 740--> 7400--> 7401--> 7402--> 7403--> 7404--> 7405--> 7406--> 7407--> 7408--> 7409--> 741--> 7410--> 7411--> 7412--> 7413--> 7414--> 7415--> 7416--> 7417--> 7418--> 7419--> 742--> 7420--> 7421--> 7422--> 7423--> 7424--> 7425--> 7426--> 7427--> 7428--> 7429--> 743--> 7430--> 7431--> 7432--> 7433--> 7434--> 7435--> 7436--> 7437--> 7438--> 7439--> 744--> 7440--> 7441--> 7442--> 7443--> 7444--> 7445--> 7446--> 7447--> 7448--> 7449--> 745--> 7450--> 7451--> 7452--> 7453--> 7454--> 7455--> 7456--> 7457--> 7458--> 7459--> 746--> 7460--> 7461--> 7462--> 7463--> 7464--> 7465--> 7466--> 7467--> 7468--> 7469--> 747--> 7470--> 7471--> 7472--> 7473--> 7474--> 7475--> 7476--> 7477--> 7478--> 7479--> 748--> 7480--> 7481--> 7482--> 7483--> 7484--> 7485--> 7486--> 7487--> 7488--> 7489--> 749--> 7490--> 7491--> 7492--> 7493--> 7494--> 7495--> 7496--> 7497--> 7498--> 7499--> 75--> 750--> 7500--> 7501--> 7502--> 7503--> 7504--> 7505--> 7506--> 7507--> 7508--> 7509--> 751--> 7510--> 7511--> 7512--> 7513--> 7514--> 7515--> 7516--> 7517--> 7518--> 7519--> 752--> 7520--> 7521--> 7522--> 7523--> 7524--> 7525--> 7526--> 7527--> 7528--> 7529--> 753--> 7530--> 7531--> 7532--> 7533--> 7534--> 7535--> 7536--> 7537--> 7538--> 7539--> 754--> 7540--> 7541--> 7542--> 7543--> 7544--> 7545--> 7546--> 7547--> 7548--> 7549--> 755--> 7550--> 7551--> 7552--> 7553--> 7554--> 7555--> 7556--> 7557--> 7558--> 7559--> 756--> 7560--> 7561--> 7562--> 7563--> 7564--> 7565--> 7566--> 7567--> 7568--> 7569--> 757--> 7570--> 7571--> 7572--> 7573--> 7574--> 7575--> 7576--> 7577--> 7578--> 7579--> 758--> 7580--> 7581--> 7582--> 7583--> 7584--> 7585--> 7586--> 7587--> 7588--> 7589--> 759--> 7590--> 7591--> 7592--> 7593--> 7594--> 7595--> 7596--> 7597--> 7598--> 7599--> 76--> 760--> 7600--> 7601--> 7602--> 7603--> 7604--> 7605--> 7606--> 7607--> 7608--> 7609--> 761--> 7610--> 7611--> 7612--> 7613--> 7614--> 7615--> 7616--> 7617--> 7618--> 7619--> 762--> 7620--> 7621--> 7622--> 7623--> 7624--> 7625--> 7626--> 7627--> 7628--> 7629--> 763--> 7630--> 7631--> 7632--> 7633--> 7634--> 7635--> 7636--> 7637--> 7638--> 7639--> 764--> 7640--> 7641--> 7642--> 7643--> 7644--> 7645--> 7646--> 7647--> 7648--> 7649--> 765--> 7650--> 7651--> 7652--> 7653--> 7654--> 7655--> 7656--> 7657--> 7658--> 7659--> 766--> 7660--> 7661--> 7662--> 7663--> 7664--> 7665--> 7666--> 7667--> 7668--> 7669--> 767--> 7670--> 7671--> 7672--> 7673--> 7674--> 7675--> 7676--> 7677--> 7678--> 7679--> 768--> 7680--> 7681--> 7682--> 7683--> 7684--> 7685--> 7686--> 7687--> 7688--> 7689--> 769--> 7690--> 7691--> 7692--> 7693--> 7694--> 7695--> 7696--> 7697--> 7698--> 7699--> 77--> 770--> 7700--> 7701--> 7702--> 7703--> 7704--> 7705--> 7706--> 7707--> 7708--> 7709--> 771--> 7710--> 7711--> 7712--> 7713--> 7714--> 7715--> 7716--> 7717--> 7718--> 7719--> 772--> 7720--> 7721--> 7722--> 7723--> 7724--> 7725--> 7726--> 7727--> 7728--> 7729--> 773--> 7730--> 7731--> 7732--> 7733--> 7734--> 7735--> 7736--> 7737--> 7738--> 7739--> 774--> 7740--> 7741--> 7742--> 7743--> 7744--> 7745--> 7746--> 7747--> 7748--> 7749--> 775--> 7750--> 7751--> 7752--> 7753--> 7754--> 7755--> 7756--> 7757--> 7758--> 7759--> 776--> 7760--> 7761--> 7762--> 7763--> 7764--> 7765--> 7766--> 7767--> 7768--> 7769--> 777--> 7770--> 7771--> 7772--> 7773--> 7774--> 7775--> 7776--> 7777--> 7778--> 7779--> 778--> 7780--> 7781--> 7782--> 7783--> 7784--> 7785--> 7786--> 7787--> 7788--> 7789--> 779--> 7790--> 7791--> 7792--> 7793--> 7794--> 7795--> 7796--> 7797--> 7798--> 7799--> 78--> 780--> 7800--> 7801--> 7802--> 7803--> 7804--> 7805--> 7806--> 7807--> 7808--> 7809--> 781--> 7810--> 7811--> 7812--> 7813--> 7814--> 7815--> 7816--> 7817--> 7818--> 7819--> 782--> 7820--> 7821--> 7822--> 7823--> 7824--> 7825--> 7826--> 7827--> 7828--> 7829--> 783--> 7830--> 7831--> 7832--> 7833--> 7834--> 7835--> 7836--> 7837--> 7838--> 7839--> 784--> 7840--> 7841--> 7842--> 7843--> 7844--> 7845--> 7846--> 7847--> 7848--> 7849--> 785--> 7850--> 7851--> 7852--> 7853--> 7854--> 7855--> 7856--> 7857--> 7858--> 7859--> 786--> 7860--> 7861--> 7862--> 7863--> 7864--> 7865--> 7866--> 7867--> 7868--> 7869--> 787--> 7870--> 7871--> 7872--> 7873--> 7874--> 7875--> 7876--> 7877--> 7878--> 7879--> 788--> 7880--> 7881--> 7882--> 7883--> 7884--> 7885--> 7886--> 7887--> 7888--> 7889--> 789--> 7890--> 7891--> 7892--> 7893--> 7894--> 7895--> 7896--> 7897--> 7898--> 7899--> 79--> 790--> 7900--> 7901--> 7902--> 7903--> 7904--> 7905--> 7906--> 7907--> 7908--> 7909--> 791--> 7910--> 7911--> 7912--> 7913--> 7914--> 7915--> 7916--> 7917--> 7918--> 7919--> 792--> 7920--> 7921--> 7922--> 7923--> 7924--> 7925--> 7926--> 7927--> 7928--> 7929--> 793--> 7930--> 7931--> 7932--> 7933--> 7934--> 7935--> 7936--> 7937--> 7938--> 7939--> 794--> 7940--> 7941--> 7942--> 7943--> 7944--> 7945--> 7946--> 7947--> 7948--> 7949--> 795--> 7950--> 7951--> 7952--> 7953--> 7954--> 7955--> 7956--> 7957--> 7958--> 7959--> 796--> 7960--> 7961--> 7962--> 7963--> 7964--> 7965--> 7966--> 7967--> 7968--> 7969--> 797--> 7970--> 7971--> 7972--> 7973--> 7974--> 7975--> 7976--> 7977--> 7978--> 7979--> 798--> 7980--> 7981--> 7982--> 7983--> 7984--> 7985--> 7986--> 7987--> 7988--> 7989--> 799--> 7990--> 7991--> 7992--> 7993--> 7994--> 7995--> 7996--> 7997--> 7998--> 7999--> 8--> 80--> 800--> 8000--> 8001--> 8002--> 8003--> 8004--> 8005--> 8006--> 8007--> 8008--> 8009--> 801--> 8010--> 8011--> 8012--> 8013--> 8014--> 8015--> 8016--> 8017--> 8018--> 8019--> 802--> 8020--> 8021--> 8022--> 8023--> 8024--> 8025--> 8026--> 8027--> 8028--> 8029--> 803--> 8030--> 8031--> 8032--> 8033--> 8034--> 8035--> 8036--> 8037--> 8038--> 8039--> 804--> 8040--> 8041--> 8042--> 8043--> 8044--> 8045--> 8046--> 8047--> 8048--> 8049--> 805--> 8050--> 8051--> 8052--> 8053--> 8054--> 8055--> 8056--> 8057--> 8058--> 8059--> 806--> 8060--> 8061--> 8062--> 8063--> 8064--> 8065--> 8066--> 8067--> 8068--> 8069--> 807--> 8070--> 8071--> 8072--> 8073--> 8074--> 8075--> 8076--> 8077--> 8078--> 8079--> 808--> 8080--> 8081--> 8082--> 8083--> 8084--> 8085--> 8086--> 8087--> 8088--> 8089--> 809--> 8090--> 8091--> 8092--> 8093--> 8094--> 8095--> 8096--> 8097--> 8098--> 8099--> 81--> 810--> 8100--> 8101--> 8102--> 8103--> 8104--> 8105--> 8106--> 8107--> 8108--> 8109--> 811--> 8110--> 8111--> 8112--> 8113--> 8114--> 8115--> 8116--> 8117--> 8118--> 8119--> 812--> 8120--> 8121--> 8122--> 8123--> 8124--> 8125--> 8126--> 8127--> 8128--> 8129--> 813--> 8130--> 8131--> 8132--> 8133--> 8134--> 8135--> 8136--> 8137--> 8138--> 8139--> 814--> 8140--> 8141--> 8142--> 8143--> 8144--> 8145--> 8146--> 8147--> 8148--> 8149--> 815--> 8150--> 8151--> 8152--> 8153--> 8154--> 8155--> 8156--> 8157--> 8158--> 8159--> 816--> 8160--> 8161--> 8162--> 8163--> 8164--> 8165--> 8166--> 8167--> 8168--> 8169--> 817--> 8170--> 8171--> 8172--> 8173--> 8174--> 8175--> 8176--> 8177--> 8178--> 8179--> 818--> 8180--> 8181--> 8182--> 8183--> 8184--> 8185--> 8186--> 8187--> 8188--> 8189--> 819--> 8190--> 8191--> 8192--> 8193--> 8194--> 8195--> 8196--> 8197--> 8198--> 8199--> 82--> 820--> 8200--> 8201--> 8202--> 8203--> 8204--> 8205--> 8206--> 8207--> 8208--> 8209--> 821--> 8210--> 8211--> 8212--> 8213--> 8214--> 8215--> 8216--> 8217--> 8218--> 8219--> 822--> 8220--> 8221--> 8222--> 8223--> 8224--> 8225--> 8226--> 8227--> 8228--> 8229--> 823--> 8230--> 8231--> 8232--> 8233--> 8234--> 8235--> 8236--> 8237--> 8238--> 8239--> 824--> 8240--> 8241--> 8242--> 8243--> 8244--> 8245--> 8246--> 8247--> 8248--> 8249--> 825--> 8250--> 8251--> 8252--> 8253--> 8254--> 8255--> 8256--> 8257--> 8258--> 8259--> 826--> 8260--> 8261--> 8262--> 8263--> 8264--> 8265--> 8266--> 8267--> 8268--> 8269--> 827--> 8270--> 8271--> 8272--> 8273--> 8274--> 8275--> 8276--> 8277--> 8278--> 8279--> 828--> 8280--> 8281--> 8282--> 8283--> 8284--> 8285--> 8286--> 8287--> 8288--> 8289--> 829--> 8290--> 8291--> 8292--> 8293--> 8294--> 8295--> 8296--> 8297--> 8298--> 8299--> 83--> 830--> 8300--> 8301--> 8302--> 8303--> 8304--> 8305--> 8306--> 8307--> 8308--> 8309--> 831--> 8310--> 8311--> 8312--> 8313--> 8314--> 8315--> 8316--> 8317--> 8318--> 8319--> 832--> 8320--> 8321--> 8322--> 8323--> 8324--> 8325--> 8326--> 8327--> 8328--> 8329--> 833--> 8330--> 8331--> 8332--> 8333--> 8334--> 8335--> 8336--> 8337--> 8338--> 8339--> 834--> 8340--> 8341--> 8342--> 8343--> 8344--> 8345--> 8346--> 8347--> 8348--> 8349--> 835--> 8350--> 8351--> 8352--> 8353--> 8354--> 8355--> 8356--> 8357--> 8358--> 8359--> 836--> 8360--> 8361--> 8362--> 8363--> 8364--> 8365--> 8366--> 8367--> 8368--> 8369--> 837--> 8370--> 8371--> 8372--> 8373--> 8374--> 8375--> 8376--> 8377--> 8378--> 8379--> 838--> 8380--> 8381--> 8382--> 8383--> 8384--> 8385--> 8386--> 8387--> 8388--> 8389--> 839--> 8390--> 8391--> 8392--> 8393--> 8394--> 8395--> 8396--> 8397--> 8398--> 8399--> 84--> 840--> 8400--> 8401--> 8402--> 8403--> 8404--> 8405--> 8406--> 8407--> 8408--> 8409--> 841--> 8410--> 8411--> 8412--> 8413--> 8414--> 8415--> 8416--> 8417--> 8418--> 8419--> 842--> 8420--> 8421--> 8422--> 8423--> 8424--> 8425--> 8426--> 8427--> 8428--> 8429--> 843--> 8430--> 8431--> 8432--> 8433--> 8434--> 8435--> 8436--> 8437--> 8438--> 8439--> 844--> 8440--> 8441--> 8442--> 8443--> 8444--> 8445--> 8446--> 8447--> 8448--> 8449--> 845--> 8450--> 8451--> 8452--> 8453--> 8454--> 8455--> 8456--> 8457--> 8458--> 8459--> 846--> 8460--> 8461--> 8462--> 8463--> 8464--> 8465--> 8466--> 8467--> 8468--> 8469--> 847--> 8470--> 8471--> 8472--> 8473--> 8474--> 8475--> 8476--> 8477--> 8478--> 8479--> 848--> 8480--> 8481--> 8482--> 8483--> 8484--> 8485--> 8486--> 8487--> 8488--> 8489--> 849--> 8490--> 8491--> 8492--> 8493--> 8494--> 8495--> 8496--> 8497--> 8498--> 8499--> 85--> 850--> 8500--> 8501--> 8502--> 8503--> 8504--> 8505--> 8506--> 8507--> 8508--> 8509--> 851--> 8510--> 8511--> 8512--> 8513--> 8514--> 8515--> 8516--> 8517--> 8518--> 8519--> 852--> 8520--> 8521--> 8522--> 8523--> 8524--> 8525--> 8526--> 8527--> 8528--> 8529--> 853--> 8530--> 8531--> 8532--> 8533--> 8534--> 8535--> 8536--> 8537--> 8538--> 8539--> 854--> 8540--> 8541--> 8542--> 8543--> 8544--> 8545--> 8546--> 8547--> 8548--> 8549--> 855--> 8550--> 8551--> 8552--> 8553--> 8554--> 8555--> 8556--> 8557--> 8558--> 8559--> 856--> 8560--> 8561--> 8562--> 8563--> 8564--> 8565--> 8566--> 8567--> 8568--> 8569--> 857--> 8570--> 8571--> 8572--> 8573--> 8574--> 8575--> 8576--> 8577--> 8578--> 8579--> 858--> 8580--> 8581--> 8582--> 8583--> 8584--> 8585--> 8586--> 8587--> 8588--> 8589--> 859--> 8590--> 8591--> 8592--> 8593--> 8594--> 8595--> 8596--> 8597--> 8598--> 8599--> 86--> 860--> 8600--> 8601--> 8602--> 8603--> 8604--> 8605--> 8606--> 8607--> 8608--> 8609--> 861--> 8610--> 8611--> 8612--> 8613--> 8614--> 8615--> 8616--> 8617--> 8618--> 8619--> 862--> 8620--> 8621--> 8622--> 8623--> 8624--> 8625--> 8626--> 8627--> 8628--> 8629--> 863--> 8630--> 8631--> 8632--> 8633--> 8634--> 8635--> 8636--> 8637--> 8638--> 8639--> 864--> 8640--> 8641--> 8642--> 8643--> 8644--> 8645--> 8646--> 8647--> 8648--> 8649--> 865--> 8650--> 8651--> 8652--> 8653--> 8654--> 8655--> 8656--> 8657--> 8658--> 8659--> 866--> 8660--> 8661--> 8662--> 8663--> 8664--> 8665--> 8666--> 8667--> 8668--> 8669--> 867--> 8670--> 8671--> 8672--> 8673--> 8674--> 8675--> 8676--> 8677--> 8678--> 8679--> 868--> 8680--> 8681--> 8682--> 8683--> 8684--> 8685--> 8686--> 8687--> 8688--> 8689--> 869--> 8690--> 8691--> 8692--> 8693--> 8694--> 8695--> 8696--> 8697--> 8698--> 8699--> 87--> 870--> 8700--> 8701--> 8702--> 8703--> 8704--> 8705--> 8706--> 8707--> 8708--> 8709--> 871--> 8710--> 8711--> 8712--> 8713--> 8714--> 8715--> 8716--> 8717--> 8718--> 8719--> 872--> 8720--> 8721--> 8722--> 8723--> 8724--> 8725--> 8726--> 8727--> 8728--> 8729--> 873--> 8730--> 8731--> 8732--> 8733--> 8734--> 8735--> 8736--> 8737--> 8738--> 8739--> 874--> 8740--> 8741--> 8742--> 8743--> 8744--> 8745--> 8746--> 8747--> 8748--> 8749--> 875--> 8750--> 8751--> 8752--> 8753--> 8754--> 8755--> 8756--> 8757--> 8758--> 8759--> 876--> 8760--> 8761--> 8762--> 8763--> 8764--> 8765--> 8766--> 8767--> 8768--> 8769--> 877--> 8770--> 8771--> 8772--> 8773--> 8774--> 8775--> 8776--> 8777--> 8778--> 8779--> 878--> 8780--> 8781--> 8782--> 8783--> 8784--> 8785--> 8786--> 8787--> 8788--> 8789--> 879--> 8790--> 8791--> 8792--> 8793--> 8794--> 8795--> 8796--> 8797--> 8798--> 8799--> 88--> 880--> 8800--> 8801--> 8802--> 8803--> 8804--> 8805--> 8806--> 8807--> 8808--> 8809--> 881--> 8810--> 8811--> 8812--> 8813--> 8814--> 8815--> 8816--> 8817--> 8818--> 8819--> 882--> 8820--> 8821--> 8822--> 8823--> 8824--> 8825--> 8826--> 8827--> 8828--> 8829--> 883--> 8830--> 8831--> 8832--> 8833--> 8834--> 8835--> 8836--> 8837--> 8838--> 8839--> 884--> 8840--> 8841--> 8842--> 8843--> 8844--> 8845--> 8846--> 8847--> 8848--> 8849--> 885--> 8850--> 8851--> 8852--> 8853--> 8854--> 8855--> 8856--> 8857--> 8858--> 8859--> 886--> 8860--> 8861--> 8862--> 8863--> 8864--> 8865--> 8866--> 8867--> 8868--> 8869--> 887--> 8870--> 8871--> 8872--> 8873--> 8874--> 8875--> 8876--> 8877--> 8878--> 8879--> 888--> 8880--> 8881--> 8882--> 8883--> 8884--> 8885--> 8886--> 8887--> 8888--> 8889--> 889--> 8890--> 8891--> 8892--> 8893--> 8894--> 8895--> 8896--> 8897--> 8898--> 8899--> 89--> 890--> 8900--> 8901--> 8902--> 8903--> 8904--> 8905--> 8906--> 8907--> 8908--> 8909--> 891--> 8910--> 8911--> 8912--> 8913--> 8914--> 8915--> 8916--> 8917--> 8918--> 8919--> 892--> 8920--> 8921--> 8922--> 8923--> 8924--> 8925--> 8926--> 8927--> 8928--> 8929--> 893--> 8930--> 8931--> 8932--> 8933--> 8934--> 8935--> 8936--> 8937--> 8938--> 8939--> 894--> 8940--> 8941--> 8942--> 8943--> 8944--> 8945--> 8946--> 8947--> 8948--> 8949--> 895--> 8950--> 8951--> 8952--> 8953--> 8954--> 8955--> 8956--> 8957--> 8958--> 8959--> 896--> 8960--> 8961--> 8962--> 8963--> 8964--> 8965--> 8966--> 8967--> 8968--> 8969--> 897--> 8970--> 8971--> 8972--> 8973--> 8974--> 8975--> 8976--> 8977--> 8978--> 8979--> 898--> 8980--> 8981--> 8982--> 8983--> 8984--> 8985--> 8986--> 8987--> 8988--> 8989--> 899--> 8990--> 8991--> 8992--> 8993--> 8994--> 8995--> 8996--> 8997--> 8998--> 8999--> 9--> 90--> 900--> 9000--> 9001--> 9002--> 9003--> 9004--> 9005--> 9006--> 9007--> 9008--> 9009--> 901--> 9010--> 9011--> 9012--> 9013--> 9014--> 9015--> 9016--> 9017--> 9018--> 9019--> 902--> 9020--> 9021--> 9022--> 9023--> 9024--> 9025--> 9026--> 9027--> 9028--> 9029--> 903--> 9030--> 9031--> 9032--> 9033--> 9034--> 9035--> 9036--> 9037--> 9038--> 9039--> 904--> 9040--> 9041--> 9042--> 9043--> 9044--> 9045--> 9046--> 9047--> 9048--> 9049--> 905--> 9050--> 9051--> 9052--> 9053--> 9054--> 9055--> 9056--> 9057--> 9058--> 9059--> 906--> 9060--> 9061--> 9062--> 9063--> 9064--> 9065--> 9066--> 9067--> 9068--> 9069--> 907--> 9070--> 9071--> 9072--> 9073--> 9074--> 9075--> 9076--> 9077--> 9078--> 9079--> 908--> 9080--> 9081--> 9082--> 9083--> 9084--> 9085--> 9086--> 9087--> 9088--> 9089--> 909--> 9090--> 9091--> 9092--> 9093--> 9094--> 9095--> 9096--> 9097--> 9098--> 9099--> 91--> 910--> 9100--> 9101--> 9102--> 9103--> 9104--> 9105--> 9106--> 9107--> 9108--> 9109--> 911--> 9110--> 9111--> 9112--> 9113--> 9114--> 9115--> 9116--> 9117--> 9118--> 9119--> 912--> 9120--> 9121--> 9122--> 9123--> 9124--> 9125--> 9126--> 9127--> 9128--> 9129--> 913--> 9130--> 9131--> 9132--> 9133--> 9134--> 9135--> 9136--> 9137--> 9138--> 9139--> 914--> 9140--> 9141--> 9142--> 9143--> 9144--> 9145--> 9146--> 9147--> 9148--> 9149--> 915--> 9150--> 9151--> 9152--> 9153--> 9154--> 9155--> 9156--> 9157--> 9158--> 9159--> 916--> 9160--> 9161--> 9162--> 9163--> 9164--> 9165--> 9166--> 9167--> 9168--> 9169--> 917--> 9170--> 9171--> 9172--> 9173--> 9174--> 9175--> 9176--> 9177--> 9178--> 9179--> 918--> 9180--> 9181--> 9182--> 9183--> 9184--> 9185--> 9186--> 9187--> 9188--> 9189--> 919--> 9190--> 9191--> 9192--> 9193--> 9194--> 9195--> 9196--> 9197--> 9198--> 9199--> 92--> 920--> 9200--> 9201--> 9202--> 9203--> 9204--> 9205--> 9206--> 9207--> 9208--> 9209--> 921--> 9210--> 9211--> 9212--> 9213--> 9214--> 9215--> 9216--> 9217--> 9218--> 9219--> 922--> 9220--> 9221--> 9222--> 9223--> 9224--> 9225--> 9226--> 9227--> 9228--> 9229--> 923--> 9230--> 9231--> 9232--> 9233--> 9234--> 9235--> 9236--> 9237--> 9238--> 9239--> 924--> 9240--> 9241--> 9242--> 9243--> 9244--> 9245--> 9246--> 9247--> 9248--> 9249--> 925--> 9250--> 9251--> 9252--> 9253--> 9254--> 9255--> 9256--> 9257--> 9258--> 9259--> 926--> 9260--> 9261--> 9262--> 9263--> 9264--> 9265--> 9266--> 9267--> 9268--> 9269--> 927--> 9270--> 9271--> 9272--> 9273--> 9274--> 9275--> 9276--> 9277--> 9278--> 9279--> 928--> 9280--> 9281--> 9282--> 9283--> 9284--> 9285--> 9286--> 9287--> 9288--> 9289--> 929--> 9290--> 9291--> 9292--> 9293--> 9294--> 9295--> 9296--> 9297--> 9298--> 9299--> 93--> 930--> 9300--> 9301--> 9302--> 9303--> 9304--> 9305--> 9306--> 9307--> 9308--> 9309--> 931--> 9310--> 9311--> 9312--> 9313--> 9314--> 9315--> 9316--> 9317--> 9318--> 9319--> 932--> 9320--> 9321--> 9322--> 9323--> 9324--> 9325--> 9326--> 9327--> 9328--> 9329--> 933--> 9330--> 9331--> 9332--> 9333--> 9334--> 9335--> 9336--> 9337--> 9338--> 9339--> 934--> 9340--> 9341--> 9342--> 9343--> 9344--> 9345--> 9346--> 9347--> 9348--> 9349--> 935--> 9350--> 9351--> 9352--> 9353--> 9354--> 9355--> 9356--> 9357--> 9358--> 9359--> 936--> 9360--> 9361--> 9362--> 9363--> 9364--> 9365--> 9366--> 9367--> 9368--> 9369--> 937--> 9370--> 9371--> 9372--> 9373--> 9374--> 9375--> 9376--> 9377--> 9378--> 9379--> 938--> 9380--> 9381--> 9382--> 9383--> 9384--> 9385--> 9386--> 9387--> 9388--> 9389--> 939--> 9390--> 9391--> 9392--> 9393--> 9394--> 9395--> 9396--> 9397--> 9398--> 9399--> 94--> 940--> 9400--> 9401--> 9402--> 9403--> 9404--> 9405--> 9406--> 9407--> 9408--> 9409--> 941--> 9410--> 9411--> 9412--> 9413--> 9414--> 9415--> 9416--> 9417--> 9418--> 9419--> 942--> 9420--> 9421--> 9422--> 9423--> 9424--> 9425--> 9426--> 9427--> 9428--> 9429--> 943--> 9430--> 9431--> 9432--> 9433--> 9434--> 9435--> 9436--> 9437--> 9438--> 9439--> 944--> 9440--> 9441--> 9442--> 9443--> 9444--> 9445--> 9446--> 9447--> 9448--> 9449--> 945--> 9450--> 9451--> 9452--> 9453--> 9454--> 9455--> 9456--> 9457--> 9458--> 9459--> 946--> 9460--> 9461--> 9462--> 9463--> 9464--> 9465--> 9466--> 9467--> 9468--> 9469--> 947--> 9470--> 9471--> 9472--> 9473--> 9474--> 9475--> 9476--> 9477--> 9478--> 9479--> 948--> 9480--> 9481--> 9482--> 9483--> 9484--> 9485--> 9486--> 9487--> 9488--> 9489--> 949--> 9490--> 9491--> 9492--> 9493--> 9494--> 9495--> 9496--> 9497--> 9498--> 9499--> 95--> 950--> 9500--> 9501--> 9502--> 9503--> 9504--> 9505--> 9506--> 9507--> 9508--> 9509--> 951--> 9510--> 9511--> 9512--> 9513--> 9514--> 9515--> 9516--> 9517--> 9518--> 9519--> 952--> 9520--> 9521--> 9522--> 9523--> 9524--> 9525--> 9526--> 9527--> 9528--> 9529--> 953--> 9530--> 9531--> 9532--> 9533--> 9534--> 9535--> 9536--> 9537--> 9538--> 9539--> 954--> 9540--> 9541--> 9542--> 9543--> 9544--> 9545--> 9546--> 9547--> 9548--> 9549--> 955--> 9550--> 9551--> 9552--> 9553--> 9554--> 9555--> 9556--> 9557--> 9558--> 9559--> 956--> 9560--> 9561--> 9562--> 9563--> 9564--> 9565--> 9566--> 9567--> 9568--> 9569--> 957--> 9570--> 9571--> 9572--> 9573--> 9574--> 9575--> 9576--> 9577--> 9578--> 9579--> 958--> 9580--> 9581--> 9582--> 9583--> 9584--> 9585--> 9586--> 9587--> 9588--> 9589--> 959--> 9590--> 9591--> 9592--> 9593--> 9594--> 9595--> 9596--> 9597--> 9598--> 9599--> 96--> 960--> 9600--> 9601--> 9602--> 9603--> 9604--> 9605--> 9606--> 9607--> 9608--> 9609--> 961--> 9610--> 9611--> 9612--> 9613--> 9614--> 9615--> 9616--> 9617--> 9618--> 9619--> 962--> 9620--> 9621--> 9622--> 9623--> 9624--> 9625--> 9626--> 9627--> 9628--> 9629--> 963--> 9630--> 9631--> 9632--> 9633--> 9634--> 9635--> 9636--> 9637--> 9638--> 9639--> 964--> 9640--> 9641--> 9642--> 9643--> 9644--> 9645--> 9646--> 9647--> 9648--> 9649--> 965--> 9650--> 9651--> 9652--> 9653--> 9654--> 9655--> 9656--> 9657--> 9658--> 9659--> 966--> 9660--> 9661--> 9662--> 9663--> 9664--> 9665--> 9666--> 9667--> 9668--> 9669--> 967--> 9670--> 9671--> 9672--> 9673--> 9674--> 9675--> 9676--> 9677--> 9678--> 9679--> 968--> 9680--> 9681--> 9682--> 9683--> 9684--> 9685--> 9686--> 9687--> 9688--> 9689--> 969--> 9690--> 9691--> 9692--> 9693--> 9694--> 9695--> 9696--> 9697--> 9698--> 9699--> 97--> 970--> 9700--> 9701--> 9702--> 9703--> 9704--> 9705--> 9706--> 9707--> 9708--> 9709--> 971--> 9710--> 9711--> 9712--> 9713--> 9714--> 9715--> 9716--> 9717--> 9718--> 9719--> 972--> 9720--> 9721--> 9722--> 9723--> 9724--> 9725--> 9726--> 9727--> 9728--> 9729--> 973--> 9730--> 9731--> 9732--> 9733--> 9734--> 9735--> 9736--> 9737--> 9738--> 9739--> 974--> 9740--> 9741--> 9742--> 9743--> 9744--> 9745--> 9746--> 9747--> 9748--> 9749--> 975--> 9750--> 9751--> 9752--> 9753--> 9754--> 9755--> 9756--> 9757--> 9758--> 9759--> 976--> 9760--> 9761--> 9762--> 9763--> 9764--> 9765--> 9766--> 9767--> 9768--> 9769--> 977--> 9770--> 9771--> 9772--> 9773--> 9774--> 9775--> 9776--> 9777--> 9778--> 9779--> 978--> 9780--> 9781--> 9782--> 9783--> 9784--> 9785--> 9786--> 9787--> 9788--> 9789--> 979--> 9790--> 9791--> 9792--> 9793--> 9794--> 9795--> 9796--> 9797--> 9798--> 9799--> 98--> 980--> 9800--> 9801--> 9802--> 9803--> 9804--> 9805--> 9806--> 9807--> 9808--> 9809--> 981--> 9810--> 9811--> 9812--> 9813--> 9814--> 9815--> 9816--> 9817--> 9818--> 9819--> 982--> 9820--> 9821--> 9822--> 9823--> 9824--> 9825--> 9826--> 9827--> 9828--> 9829--> 983--> 9830--> 9831--> 9832--> 9833--> 9834--> 9835--> 9836--> 9837--> 9838--> 9839--> 984--> 9840--> 9841--> 9842--> 9843--> 9844--> 9845--> 9846--> 9847--> 9848--> 9849--> 985--> 9850--> 9851--> 9852--> 9853--> 9854--> 9855--> 9856--> 9857--> 9858--> 9859--> 986--> 9860--> 9861--> 9862--> 9863--> 9864--> 9865--> 9866--> 9867--> 9868--> 9869--> 987--> 9870--> 9871--> 9872--> 9873--> 9874--> 9875--> 9876--> 9877--> 9878--> 9879--> 988--> 9880--> 9881--> 9882--> 9883--> 9884--> 9885--> 9886--> 9887--> 9888--> 9889--> 989--> 9890--> 9891--> 9892--> 9893--> 9894--> 9895--> 9896--> 9897--> 9898--> 9899--> 99--> 990--> 9900--> 9901--> 9902--> 9903--> 9904--> 9905--> 9906--> 9907--> 9908--> 9909--> 991--> 9910--> 9911--> 9912--> 9913--> 9914--> 9915--> 9916--> 9917--> 9918--> 9919--> 992--> 9920--> 9921--> 9922--> 9923--> 9924--> 9925--> 9926--> 9927--> 9928--> 9929--> 993--> 9930--> 9931--> 9932--> 9933--> 9934--> 9935--> 9936--> 9937--> 9938--> 9939--> 994--> 9940--> 9941--> 9942--> 9943--> 9944--> 9945--> 9946--> 9947--> 9948--> 9949--> 995--> 9950--> 9951--> 9952--> 9953--> 9954--> 9955--> 9956--> 9957--> 9958--> 9959--> 996--> 9960--> 9961--> 9962--> 9963--> 9964--> 9965--> 9966--> 9967--> 9968--> 9969--> 997--> 9970--> 9971--> 9972--> 9973--> 9974--> 9975--> 9976--> 9977--> 9978--> 9979--> 998--> 9980--> 9981--> 9982--> 9983--> 9984--> 9985--> 9986--> 9987--> 9988--> 9989--> 999--> 9990--> 9991--> 9992--> 9993--> 9994--> 9995--> 9996--> 9997--> 9998--> 9999--> mingw-ocaml/ocaml/testsuite/tests/lib-threads/testA.reference0000644000175000017500000000007012124403241024004 0ustar tootstoots1 --> un 2 --> deux 3 --> trois 4 --> quatre 5 --> cinq mingw-ocaml/ocaml/testsuite/tests/lib-threads/test5.runner0000644000175000017500000000006712124403241023351 0ustar tootstoots./program > test5.result & pid=$! sleep 3 kill -9 $pid mingw-ocaml/ocaml/testsuite/tests/lib-threads/test5.ml0000644000175000017500000000054112124403241022445 0ustar tootstootsopen Event let ch = (new_channel() : string channel) let rec sender msg = sync (send ch msg); sender msg let rec receiver name = print_string (name ^ ": " ^ sync (receive ch) ^ "\n"); flush stdout; receiver name let _ = Thread.create sender "hello"; Thread.create sender "world"; Thread.create receiver "A"; receiver "B"; exit 0 mingw-ocaml/ocaml/testsuite/tests/lib-threads/test9.reference0000644000175000017500000000001012124403241023766 0ustar tootstootsg F f G mingw-ocaml/ocaml/testsuite/tests/lib-threads/test5.checker0000644000175000017500000000007212124403241023440 0ustar tootstootsLC_ALL=C sort -u test5.result | diff -q test5.reference - mingw-ocaml/ocaml/testsuite/tests/lib-threads/close.reference0000644000175000017500000000003112124403241024026 0ustar tootstootsreading... read returned mingw-ocaml/ocaml/testsuite/tests/lib-threads/testsieve.ml0000644000175000017500000000227312124403241023420 0ustar tootstootslet sieve primes= Event.sync (Event.send primes 0); Event.sync (Event.send primes 1); Event.sync (Event.send primes 2); let integers = Event.new_channel () in let rec enumerate n= Event.sync (Event.send integers n); enumerate (n + 2) and filter inpout = let n = Event.sync (Event.receive inpout) (* On prepare le terrain pour l'appel recursif *) and output = Event.new_channel () in (* Celui qui etait en tete du crible est premier *) Event.sync (Event.send primes n); Thread.create filter output; (* On elimine de la sortie ceux qui sont des multiples de n *) while true do let m = Event.sync (Event.receive inpout) in (* print_int n; print_string ": "; print_int m; print_newline(); *) if (m mod n) = 0 then () else ((Event.sync (Event.send output m));()) done in Thread.create filter integers; Thread.create enumerate 3 let premiers = Event.new_channel () let main _ = Thread.create sieve premiers; while true do for i = 1 to 100 do let n = Event.sync (Event.receive premiers) in print_int n; print_newline() done; exit 0 done let _ = try main () with _ -> exit 0;; mingw-ocaml/ocaml/testsuite/tests/lib-threads/token2.reference0000644000175000017500000000000012124403241024117 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-threads/testsignal.checker0000644000175000017500000000010612124403241024547 0ustar tootstootssed -e 1q testsignal.result | grep -q '^[ab]*Got ctrl-C, exiting...$' mingw-ocaml/ocaml/testsuite/tests/lib-threads/close.ml0000644000175000017500000000061112124403241022504 0ustar tootstootslet main () = let (rd, wr) = Unix.pipe() in let _ = Thread.create (fun () -> ignore (Unix.write wr "0123456789" 0 10); Thread.delay 3.0; print_endline "closing fd..."; Unix.close rd) () in let buf = String.create 10 in print_endline "reading..."; ignore (Unix.read rd buf 0 10); print_endline "read returned" let _ = Unix.handle_unix_error main () mingw-ocaml/ocaml/testsuite/tests/lib-threads/test7.checker0000644000175000017500000000012512124403241023441 0ustar tootstootstest `grep -E '^-?[0123456789]+$' test7.result | wc -l` = `cat test7.result | wc -l` mingw-ocaml/ocaml/testsuite/tests/lib-threads/test4.ml0000644000175000017500000000070212124403241022443 0ustar tootstootslet output_lock = Mutex.create() let rec fib n = if n <= 2 then 1 else fib(n-1) + fib(n-2) let fibtask n = while true do Mutex.lock output_lock; print_int(fib n); print_newline(); Mutex.unlock output_lock done let _ = Thread.create fibtask 28; Thread.delay 1.0; while true do let l = read_line () in Mutex.lock output_lock; print_string ">> "; print_string l; print_newline(); Mutex.unlock output_lock done mingw-ocaml/ocaml/testsuite/tests/lib-threads/testsocket.ml0000644000175000017500000000227712124403241023601 0ustar tootstootsopen Unix let engine verbose number address = print_int number; print_string "> connecting"; print_newline(); let (ic, oc) = open_connection (ADDR_INET(address, 80)) in print_int number; print_string "> connected"; print_newline(); output_string oc "GET / HTTP1.0\r\n\r\n"; flush oc; try while true do let s = input_line ic in if verbose then (print_int number; print_string ">"; print_string s; print_newline()) done; with End_of_file -> close_out oc; print_int number; print_string "> data retrieved"; print_newline() let main() = let verbose, argv = match Sys.argv with | [| _ |] -> false, [| Sys.argv.(0); "caml.inria.fr" |] | _ -> true, Sys.argv in let addresses = Array.create (Array.length argv - 1) inet_addr_any in for i = 1 to Array.length argv - 1 do addresses.(i - 1) <- (gethostbyname argv.(i)).h_addr_list.(0) done; let processes = Array.create (Array.length addresses) (Thread.self()) in for i = 0 to Array.length addresses - 1 do processes.(i) <- Thread.create (engine verbose i) addresses.(i) done; for i = 0 to Array.length processes - 1 do Thread.join processes.(i) done let _ = Printexc.catch main (); exit 0 mingw-ocaml/ocaml/testsuite/tests/lib-threads/testA.ml0000644000175000017500000000150212124403241022457 0ustar tootstootslet private_data = (Hashtbl.create 17 : (Thread.t, string) Hashtbl.t) let private_data_lock = Mutex.create() let output_lock = Mutex.create() let set_private_data data = Mutex.lock private_data_lock; Hashtbl.add private_data (Thread.self()) data; Mutex.unlock private_data_lock let get_private_data () = Hashtbl.find private_data (Thread.self()) let process id data = set_private_data data; Mutex.lock output_lock; print_int id; print_string " --> "; print_string(get_private_data()); Mutex.unlock output_lock; print_newline() let _ = let t1 = Thread.create (process 1) "un" in let t2 = Thread.create (process 2) "deux" in let t3 = Thread.create (process 3) "trois" in let t4 = Thread.create (process 4) "quatre" in let t5 = Thread.create (process 5) "cinq" in List.iter Thread.join [t1;t2;t3;t4;t5] mingw-ocaml/ocaml/testsuite/tests/lib-threads/testio.reference0000644000175000017500000000071412124403241024240 0ustar tootstoots256-byte chunks, 256-byte chunks passed 4096-byte chunks, 4096-byte chunks passed 65536-byte chunks, 65536-byte chunks passed 256-byte chunks, 4096-byte chunks passed 4096-byte chunks, 256-byte chunks passed 4096-byte chunks, 65536-byte chunks passed 263-byte chunks, 4011-byte chunks passed 613-byte chunks, 1027-byte chunks passed 0...8192 byte chunks passed line per line, short lines passed line per line, short and long lines passed truncated line passed mingw-ocaml/ocaml/testsuite/tests/lib-threads/test6.checker0000644000175000017500000000007212124403241023441 0ustar tootstootsLC_ALL=C sort -u test6.result | diff -q test6.reference - mingw-ocaml/ocaml/testsuite/tests/lib-threads/test3.ml0000644000175000017500000000027112124403241022443 0ustar tootstootslet print_message delay c = while true do print_char c; flush stdout; Thread.delay delay done let _ = Thread.create (print_message 0.6666666666) 'a'; print_message 1.0 'b' mingw-ocaml/ocaml/testsuite/tests/lib-threads/test4.runner0000644000175000017500000000007312124403241023345 0ustar tootstoots./program < test4.data > test4.result 2> /dev/null || true mingw-ocaml/ocaml/testsuite/tests/lib-threads/test3.runner0000644000175000017500000000006712124403241023347 0ustar tootstoots./program > test3.result & pid=$! sleep 5 kill -9 $pid mingw-ocaml/ocaml/testsuite/tests/lib-threads/testexit.checker0000644000175000017500000000007512124403241024250 0ustar tootstootsLC_ALL=C sort testexit.result | diff -q testexit.reference - mingw-ocaml/ocaml/testsuite/tests/lib-threads/test2.ml0000644000175000017500000000050012124403241022435 0ustar tootstootslet yield = ref false let print_message c = for i = 1 to 10000 do print_char c; flush stdout; if !yield then Thread.yield() done let _ = yield := (Array.length Sys.argv > 1) let t1 = Thread.create print_message 'a' let t2 = Thread.create print_message 'b' let _ = Thread.join t1 let _ = Thread.join t2 ;; mingw-ocaml/ocaml/testsuite/tests/lib-threads/test7.runner0000644000175000017500000000006712124403241023353 0ustar tootstoots./program > test7.result & pid=$! sleep 1 kill -9 $pid mingw-ocaml/ocaml/testsuite/tests/lib-threads/test6.runner0000644000175000017500000000006712124403241023352 0ustar tootstoots./program > test6.result & pid=$! sleep 1 kill -9 $pid mingw-ocaml/ocaml/testsuite/tests/lib-threads/testsignal.runner0000644000175000017500000000007612124403241024462 0ustar tootstoots./program > testsignal.result & pid=$! sleep 3 kill -INT $pid mingw-ocaml/ocaml/testsuite/tests/lib-threads/testsocket.reference0000644000175000017500000000005512124403241025117 0ustar tootstoots0> connecting 0> connected 0> data retrieved mingw-ocaml/ocaml/testsuite/tests/lib-threads/testsignal2.runner0000644000175000017500000000014112124403241024535 0ustar tootstoots./program > testsignal2.result & pid=$! sleep 3 kill -INT $pid sleep 1 kill -9 $pid 2>&- || true mingw-ocaml/ocaml/testsuite/tests/lib-threads/test4.checker0000644000175000017500000000007212124403241023437 0ustar tootstootsLC_ALL=C sort -u test4.result | diff -q test4.reference - mingw-ocaml/ocaml/testsuite/tests/lib-threads/token1.reference0000644000175000017500000000000012124403241024116 0ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-threads/torture.ml0000644000175000017500000000225012124403241023104 0ustar tootstoots(* Torture test - lots of GC *) let gc_thread () = while true do (* print_string "gc"; print_newline(); *) Gc.minor(); Thread.yield() done let stdin_thread () = while true do print_string ">"; flush stdout; let s = read_line() in print_string " >>> "; print_string s; print_newline() done let writer_thread (oc, size) = while true do (* print_string "writer "; print_int size; print_newline(); *) let buff = String.make size 'a' in Unix.write oc buff 0 size done let reader_thread (ic, size) = while true do (* print_string "reader "; print_int size; print_newline(); *) let buff = String.create size in let n = Unix.read ic buff 0 size in (* print_string "reader "; print_int n; print_newline(); *) for i = 0 to n-1 do if buff.[i] <> 'a' then prerr_endline "error in reader_thread" done done let main() = Thread.create gc_thread (); let (out1, in1) = Unix.pipe() in Thread.create writer_thread (in1, 4096); Thread.create reader_thread (out1, 4096); let (out2, in2) = Unix.pipe() in Thread.create writer_thread (in2, 16); Thread.create reader_thread (out2, 16); stdin_thread() let _ = main() mingw-ocaml/ocaml/testsuite/tests/lib-threads/testsieve.reference0000644000175000017500000000055712124403241024751 0ustar tootstoots0 1 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509 521 mingw-ocaml/ocaml/testsuite/tests/lib-threads/sieve.reference0000644000175000017500000000120312124403241024036 0ustar tootstoots2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509 521 523 541 547 557 563 569 571 577 587 593 599 601 607 613 617 619 631 641 643 647 653 659 661 673 677 683 691 701 709 719 727 733 739 743 751 757 761 769 773 787 797 809 811 821 823 827 829 839 853 857 859 863 877 881 883 887 907 911 919 929 937 941 947 953 967 971 977 983 991 997 mingw-ocaml/ocaml/testsuite/tests/lib-threads/testexit.ml0000644000175000017500000000111112124403241023244 0ustar tootstoots(* Test Thread.exit *) let somethread (name, limit, last) = let counter = ref 0 in while true do incr counter; if !counter >= limit then begin print_string (name ^ " exiting\n"); flush stdout; if last then exit 0 else Thread.exit() end; print_string (name ^ ": " ^ string_of_int !counter ^ "\n"); flush stdout; Thread.delay 0.5 done let _ = let _ = Thread.create somethread ("A", 5, false) in let _ = Thread.create somethread ("B", 8, false) in let _ = Thread.create somethread ("C", 11, true) in somethread ("Main", 3, false) mingw-ocaml/ocaml/testsuite/tests/basic-multdef/0000755000175000017500000000000012124403241021370 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/basic-multdef/Makefile0000644000175000017500000000021512124403241023026 0ustar tootstootsBASEDIR=../.. MODULES=multdef MAIN_MODULE=usemultdef include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/basic-multdef/usemultdef.reference0000644000175000017500000000000212124403241025415 0ustar tootstoots2 mingw-ocaml/ocaml/testsuite/tests/basic-multdef/multdef.mli0000644000175000017500000000007412124403241023534 0ustar tootstootsval f : int -> int val f : int -> int val g : string -> int mingw-ocaml/ocaml/testsuite/tests/basic-multdef/usemultdef.ml0000644000175000017500000000007012124403241024074 0ustar tootstootslet _ = print_int(Multdef.f 1); print_newline(); exit 0 mingw-ocaml/ocaml/testsuite/tests/basic-multdef/multdef.ml0000644000175000017500000000010212124403241023353 0ustar tootstootslet f x = x + 1 external g : string -> int = "caml_int_of_string" mingw-ocaml/ocaml/testsuite/tests/embedded/0000755000175000017500000000000012124403241020402 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/embedded/Makefile0000644000175000017500000000103312124403241022037 0ustar tootstootsBASEDIR=../.. default: compile run compile: @$(OCAMLC) -ccopt -I -ccopt $(TOPDIR)/byterun cmstub.c @$(OCAMLC) -ccopt -I -ccopt $(TOPDIR)/byterun cmmain.c @$(OCAMLC) -c cmcaml.ml @$(OCAMLC) -custom -o program cmstub.o cmcaml.cmo cmmain.o run: @printf " ... testing 'cmmain':" @./program > program.result @$(DIFF) program.reference program.result > /dev/null || (echo " => failed" && exit 1) @echo " => passed" promote: defaultpromote clean: defaultclean @rm -f *.result ./program include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/embedded/cmcaml.ml0000644000175000017500000000055612124403241022176 0ustar tootstoots(* OCaml part of the code *) let rec fib n = if n < 2 then 1 else fib(n-1) + fib(n-2) let format_result n = let r = "Result = " ^ string_of_int n in (* Allocate gratuitously to test GC *) for i = 1 to 1500 do ignore (String.create 256) done; r (* Registration *) let _ = Callback.register "fib" fib; Callback.register "format_result" format_result mingw-ocaml/ocaml/testsuite/tests/embedded/cmmain.c0000644000175000017500000000066312124403241022017 0ustar tootstoots/* Main program -- in C */ #include #include #include extern int fib(int n); extern char * format_result(int n); int main(int argc, char ** argv) { printf("Initializing OCaml code...\n"); #ifdef NO_BYTECODE_FILE caml_startup(argv); #else caml_main(argv); #endif printf("Back in C code...\n"); printf("Computing fib(20)...\n"); printf("%s\n", format_result(fib(20))); return 0; } mingw-ocaml/ocaml/testsuite/tests/embedded/cmstub.c0000644000175000017500000000064012124403241022043 0ustar tootstoots#include #include #include /* Functions callable directly from C */ int fib(int n) { value * fib_closure = caml_named_value("fib"); return Int_val(callback(*fib_closure, Val_int(n))); } char * format_result(int n) { value * format_result_closure = caml_named_value("format_result"); return strdup(String_val(callback(*format_result_closure, Val_int(n)))); } mingw-ocaml/ocaml/testsuite/tests/embedded/program.reference0000644000175000017500000000012112124403241023723 0ustar tootstootsInitializing OCaml code... Back in C code... Computing fib(20)... Result = 10946 mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/0000755000175000017500000000000012124403241022351 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/.ignore0000644000175000017500000000006012124403241023631 0ustar tootstootsmypack.pack.s result main main.exe marshal.data mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/plugin2.ml0000644000175000017500000000036512124403241024267 0ustar tootstoots(*external ex: int -> int = "caml_ex"*) let () = Api.reg_mod "Plugin2"; Api.add_cb (fun () -> print_endline "Callback from plugin2"); (* let i = ex 3 in*) List.iter (fun i -> Printf.printf "%i\n" i) Plugin.facts; Printf.printf "XXX\n" mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/plugin4.ml0000644000175000017500000000011612124403241024263 0ustar tootstootslet () = Printf.printf "time = %f\n" (Unix.time ()); Api.reg_mod "Plugin" mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/plugin_ref.ml0000644000175000017500000000023512124403241025035 0ustar tootstootslet x = ref 0 let () = Api.reg_mod "Plugin_ref"; Api.add_cb (fun () -> Printf.printf "current value for ref = %i\n" !x; incr x ) mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/packed1.ml0000644000175000017500000000013212124403241024207 0ustar tootstootslet () = Api.reg_mod "Packed1" let bla = Sys.argv.(0) ^ "XXX" let mykey = Sys.argv.(0) mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/bug.ml0000644000175000017500000000015012124403241023454 0ustar tootstootslet () = try raise (Invalid_argument "X") with Invalid_argument s -> raise (Invalid_argument (s ^ s)) mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/Makefile0000644000175000017500000000464212124403241024017 0ustar tootstootsBASEDIR=../.. default: @if [ -z "$(BYTECODE_ONLY)" ]; then \ $(MAKE) all; \ fi all: compile run PLUGINS=plugin.so plugin2.so sub/plugin.so sub/plugin3.so plugin4.so mypack.so packed1.so packed1_client.so pack_client.so plugin_ref.so plugin_high_arity.so plugin_ext.so plugin_simple.so bug.so plugin_thread.so plugin4_unix.so a.so b.so c.so ADD_COMPFLAGS=-thread compile: $(PLUGINS) main mylib.so run: @printf " ... testing 'main'" @./main plugin.so plugin2.so plugin_thread.so > result @$(DIFF) reference result > /dev/null || (echo " => failed" && exit 1) @echo " => passed" main: api.cmx main.cmx @$(OCAMLOPT) -thread -o main -linkall unix.cmxa threads.cmxa dynlink.cmxa api.cmx main.cmx $(PTHREAD_LINK) main_ext: api.cmx main.cmx factorial.$(O) @$(OCAMLOPT) -o main_ext dynlink.cmxa api.cmx main.cmx factorial.$(O) sub/plugin3.cmx: sub/api.cmi sub/api.cmx sub/plugin3.ml @(cd sub; mv api.cmx api.cmx.bak; $(OCAMLOPT) -c $(COMPFLAGS) plugin3.ml; mv api.cmx.bak api.cmx) plugin2.cmx: api.cmx plugin.cmi plugin.cmx @(mv plugin.cmx plugin.cmx.bak; $(OCAMLOPT) -c $(COMPFLAGS) plugin2.ml; mv plugin.cmx.bak plugin.cmx) sub/api.so: sub/api.cmi sub/api.ml @(cd sub; $(OCAMLOPT) -c $(COMPFLAGS) $(SHARED) api.ml) sub/api.cmi: sub/api.mli @(cd sub; $(OCAMLOPT) -c $(COMPFLAGS) api.mli) sub/api.cmx: sub/api.cmi sub/api.ml @(cd sub; $(OCAMLOPT) -c $(COMPFLAGS) api.ml) plugin.cmx: api.cmx plugin.cmi sub/plugin.cmx: api.cmx plugin4.cmx: api.cmx main.cmx: api.cmx plugin_ext.cmx: api.cmx plugin_ext.ml @$(OCAMLOPT) -c $(COMPFLAGS) plugin_ext.ml plugin_ext.so: factorial.$(O) plugin_ext.cmx @$(OCAMLOPT) $(COMPFLAGS) -shared -o plugin_ext.so factorial.$(O) plugin_ext.cmx plugin4_unix.so: plugin4.cmx @$(OCAMLOPT) -shared -o plugin4_unix.so unix.cmxa plugin4.cmx packed1_client.cmx: packed1.cmx pack_client.cmx: mypack.cmx packed1.cmx: api.cmx packed1.ml @$(OCAMLOPT) -c $(COMPFLAGS) -for-pack Mypack packed1.ml mypack.cmx: packed1.cmx @$(OCAMLOPT) $(COMPFLAGS) -S -pack -o mypack.cmx packed1.cmx mylib.cmxa: plugin.cmx plugin2.cmx @$(OCAMLOPT) $(COMPFLAGS) -a -o mylib.cmxa plugin.cmx plugin2.cmx factorial.$(O): factorial.c @$(OCAMLOPT) -c -ccopt "$(SHAREDCCCOMPOPTS)" factorial.c promote: @cp result reference clean: defaultclean @rm -f result *.so *.o *.cm* main main_ext *.exe *.s *.asm *.obj @rm -f *.a *.lib @rm -f sub/*.so sub/*.o sub/*.cm* sub/*.s sub/*.asm sub/*.obj include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/c.ml0000755000175000017500000000012712124403241023130 0ustar tootstootslet () = print_endline "C is running"; incr A.x; Printf.printf "A.x = %i\n" !A.x mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/plugin_simple.ml0000644000175000017500000000012112124403241025544 0ustar tootstootslet facts = [ (Random.int 4) ] let () = print_endline "COUCOU"; print_char '\n' mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/main.ml0000644000175000017500000000172112124403241023630 0ustar tootstootslet () = Api.add_cb (fun () -> print_endline "Callback from main") let () = Dynlink.init (); Dynlink.allow_unsafe_modules true; for i = 1 to Array.length Sys.argv - 1 do let name = Sys.argv.(i) in Printf.printf "Loading %s\n" name; flush stdout; try if name.[0] = '-' then Dynlink.loadfile_private (String.sub name 1 (String.length name - 1)) else Dynlink.loadfile name with | Dynlink.Error err -> Printf.printf "Dynlink error: %s\n" (Dynlink.error_message err) | exn -> Printf.printf "Error: %s\n" (Printexc.to_string exn) done; flush stdout; try let oc = open_out_bin "marshal.data" in Marshal.to_channel oc !Api.cbs [Marshal.Closures]; close_out oc; let ic = open_in_bin "marshal.data" in let l = (Marshal.from_channel ic : (unit -> unit) list) in close_in ic; List.iter (fun f -> f()) l with Failure s -> Printf.printf "Failure: %s\n" s mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/pack_client.ml0000644000175000017500000000005612124403241025160 0ustar tootstootslet () = print_endline Mypack.Packed1.mykey mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/b.ml0000755000175000017500000000012712124403241023127 0ustar tootstootslet () = print_endline "B is running"; incr A.x; Printf.printf "A.x = %i\n" !A.x mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/plugin_ext.ml0000644000175000017500000000017412124403241025063 0ustar tootstootsexternal fact: int -> string = "factorial" let () = Api.reg_mod "plugin_ext"; Printf.printf "fact 10 = %s\n" (fact 10) mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/api.ml0000644000175000017500000000052012124403241023451 0ustar tootstootslet mods = ref [] let reg_mod name = if List.mem name !mods then Printf.printf "Reloading module %s\n" name else ( mods := name :: !mods; Printf.printf "Registering module %s\n" name ) let cbs = ref [] let add_cb f = cbs := f :: !cbs let runall () = List.iter (fun f -> f ()) !cbs (* let () = at_exit runall *) mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/a.ml0000755000175000017500000000013212124403241023122 0ustar tootstootslet x = ref 0 let u = Random.int 1000 let () = Printf.printf "A is running (%i)\n%!" u mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml0000644000175000017500000000013712124403241026411 0ustar tootstootslet f x x x x x x x x x x x x x = () let g x = f x x x x x x x x let () = Api.reg_mod "HA" mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/sub/0000755000175000017500000000000012124403241023142 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/sub/api.ml0000644000175000017500000000010312124403241024237 0ustar tootstootslet f i = Printf.printf "Sub/api: f called with %i\n" i; i + 1 mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/sub/api.mli0000644000175000017500000000002312124403241024411 0ustar tootstootsval f : int -> int mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/sub/plugin.ml0000644000175000017500000000022112124403241024765 0ustar tootstootslet rec fact n = if n = 0 then 1 else n * fact (n - 1) let facts = [ fact 1; fact 2; fact 3; fact 4; fact 5 ] let () = Api.reg_mod "Plugin'" mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/sub/plugin3.ml0000644000175000017500000000003512124403241025053 0ustar tootstootslet () = ignore (Api.f 10) mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/packed1_client.ml0000644000175000017500000000010712124403241025547 0ustar tootstootslet () = Api.reg_mod "Packed1_client"; print_endline Packed1.mykey mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/plugin.ml0000644000175000017500000000042512124403241024202 0ustar tootstootslet rec f x = ignore ([x]); f x let rec fact n = if n = 0 then 1 else n * fact (n - 1) let facts = [ fact 1; fact 2; fact 3; fact (Random.int 4) ] let () = Api.reg_mod "Plugin"; Api.add_cb (fun () -> print_endline "Callback from plugin"); print_endline "COUCOU"; () mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/plugin.mli0000644000175000017500000000002412124403241024346 0ustar tootstootsval facts: int list mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/plugin_thread.ml0000644000175000017500000000047112124403241025532 0ustar tootstootslet () = Api.reg_mod "Plugin_thread"; let _t = Thread.create (fun () -> for i = 1 to 5 do print_endline "Thread"; flush stdout; Thread.delay 1.; done ) () in for i = 1 to 10 do print_endline "Thread"; flush stdout; Thread.delay 0.50; done mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/factorial.c0000644000175000017500000000050712124403241024463 0ustar tootstoots#include "caml/mlvalues.h" #include "caml/memory.h" #include "caml/alloc.h" #include value factorial(value n){ CAMLparam1(n); CAMLlocal1(s); static char buf[256]; int x = 1; int i; int m = Int_val(n); for (i = 1; i <= m; i++) x *= i; sprintf(buf,"%i",x); s = copy_string(buf); CAMLreturn (s); } mingw-ocaml/ocaml/testsuite/tests/lib-dynlink-native/reference0000644000175000017500000000051612124403241024234 0ustar tootstootsLoading plugin.so Registering module Plugin COUCOU Loading plugin2.so Registering module Plugin2 1 2 6 1 XXX Loading plugin_thread.so Registering module Plugin_thread Thread Thread Thread Thread Thread Thread Thread Thread Thread Thread Thread Thread Thread Thread Thread Callback from plugin2 Callback from plugin Callback from main mingw-ocaml/ocaml/testsuite/tests/warnings/0000755000175000017500000000000012124403241020501 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/warnings/Makefile0000644000175000017500000000067712124403241022153 0ustar tootstootsBASEDIR=../.. FLAGS=-w A EXECNAME=./program run-all: @for file in *.ml; do \ printf " ... testing '$$file':"; \ $(OCAMLC) $(FLAGS) -o $(EXECNAME) $$file 2> `basename $$file ml`result; \ $(DIFF) `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || echo " => failed"; \ done; promote: defaultpromote clean: defaultclean @rm -f *.result $(EXECNAME) include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/warnings/w01.ml0000644000175000017500000000034712124403241021446 0ustar tootstoots (* C *) let foo = ( *);; (* F *) let f x y = x;; f 1; f 1;; (* M *) (* duh *) (* P *) let 1 = 1;; (* S *) 1; 1;; (* U *) match 1 with | 1 -> () | 1 -> () | _ -> () ;; (* V *) (* re-duh *) (* X *) (* re-re *) mingw-ocaml/ocaml/testsuite/tests/warnings/w01.reference0000644000175000017500000000112212124403241022764 0ustar tootstootsFile "w01.ml", line 4, characters 12-14: Warning 2: this is not the end of a comment. File "w01.ml", line 10, characters 0-3: Warning 5: this function application is partial, maybe some arguments are missing. File "w01.ml", line 20, characters 4-5: Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: 0 File "w01.ml", line 25, characters 0-1: Warning 10: this expression should have type unit. File "w01.ml", line 9, characters 8-9: Warning 27: unused variable y. File "w01.ml", line 32, characters 2-3: Warning 11: this match case is unused. mingw-ocaml/ocaml/testsuite/tests/typing-polyvariants-bugs-2/0000755000175000017500000000000012124403241024011 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/typing-polyvariants-bugs-2/pr3918b.mli0000644000175000017500000000006012124403241025620 0ustar tootstootstype 'a vlist = ('a * 'b) Pr3918a.voption as 'b mingw-ocaml/ocaml/testsuite/tests/typing-polyvariants-bugs-2/Makefile0000644000175000017500000000037212124403241025453 0ustar tootstootsBASEDIR=../.. default: @printf " ... testing 'pr3918':" @($(OCAMLC) -c pr3918a.mli && $(OCAMLC) -c pr3918b.mli && $(OCAMLC) -c pr3918c.ml && echo " => passed") || echo " => failed" clean: defaultclean include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/typing-polyvariants-bugs-2/pr3918a.mli0000644000175000017500000000005112124403241025617 0ustar tootstootstype 'a voption = [ `None | `Some of 'a] mingw-ocaml/ocaml/testsuite/tests/typing-polyvariants-bugs-2/pr3918c.ml0000644000175000017500000000025712124403241025460 0ustar tootstoots(* ocamlc -c pr3918a.mli pr3918b.mli rm -f pr3918a.cmi ocamlc -c pr3918c.ml *) open Pr3918b let f x = (x : 'a vlist :> 'b vlist) let f (x : 'a vlist) = (x : 'b vlist) mingw-ocaml/ocaml/testsuite/tests/misc/0000755000175000017500000000000012124403241017604 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/misc/fib.reference0000644000175000017500000000001212124403241022215 0ustar tootstoots165580141 mingw-ocaml/ocaml/testsuite/tests/misc/weaktest.reference0000644000175000017500000000000512124403241023306 0ustar tootstootspass mingw-ocaml/ocaml/testsuite/tests/misc/weaktest.ml0000644000175000017500000000267012124403241021772 0ustar tootstoots(* $Id$ *) let debug = false;; open Printf;; module Hashed = struct type t = string list;; let equal x y = eprintf "equal: %s / %s\n" (List.hd x) (List.hd y); x = y ;; let hash x = Hashtbl.hash (List.hd x);; end;; module HT = Weak.Make (Hashed);; let tbl = HT.create 7;; let r = ref [];; let bunch = if Array.length Sys.argv < 2 then 10000 else int_of_string Sys.argv.(1) ;; Random.init 314;; let random_string n = let result = String.create n in for i = 0 to n - 1 do result.[i] <- Char.chr (32 + Random.int 95); done; result ;; let added = ref 0;; let mistakes = ref 0;; let print_status () = let (len, entries, sumbuck, buckmin, buckmed, buckmax) = HT.stats tbl in if entries > bunch * (!added + 1) then begin if debug then begin printf "\n===================\n"; printf "len = %d\n" len; printf "entries = %d\n" entries; printf "sum of bucket sizes = %d\n" sumbuck; printf "min bucket = %d\n" buckmin; printf "med bucket = %d\n" buckmed; printf "max bucket = %d\n" buckmax; printf "GC count = %d\n" (Gc.quick_stat ()).Gc.major_collections; flush stdout; end; incr mistakes; end; added := 0; ;; Gc.create_alarm print_status;; for j = 0 to 99 do r := []; incr added; for i = 1 to bunch do let c = random_string 7 in r := c :: !r; HT.add tbl !r; done; done;; if !mistakes < 5 then printf "pass\n" else printf "fail\n";; mingw-ocaml/ocaml/testsuite/tests/misc/bdd.ml0000644000175000017500000001606212124403241020674 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Translated to OCaml by Xavier Leroy *) (* Original code written in SML by ... *) type bdd = One | Zero | Node of bdd * int * int * bdd let rec eval bdd vars = match bdd with Zero -> false | One -> true | Node(l, v, _, h) -> if vars.(v) then eval h vars else eval l vars let getId bdd = match bdd with Node(_,_,id,_) -> id | Zero -> 0 | One -> 1 let initSize_1 = 8*1024 - 1 let nodeC = ref 1 let sz_1 = ref initSize_1 let htab = ref(Array.create (!sz_1+1) []) let n_items = ref 0 let hashVal x y v = x lsl 1 + y + v lsl 2 let resize newSize = let arr = !htab in let newSz_1 = newSize-1 in let newArr = Array.create newSize [] in let rec copyBucket bucket = match bucket with [] -> () | n :: ns -> match n with | Node(l,v,_,h) -> let ind = hashVal (getId l) (getId h) v land newSz_1 in newArr.(ind) <- (n :: newArr.(ind)); copyBucket ns | _ -> assert false in for n = 0 to !sz_1 do copyBucket(arr.(n)) done; htab := newArr; sz_1 := newSz_1 let rec insert idl idh v ind bucket newNode = if !n_items <= !sz_1 then ( (!htab).(ind) <- (newNode :: bucket); incr n_items ) else ( resize(!sz_1 + !sz_1 + 2); let ind = hashVal idl idh v land (!sz_1) in (!htab).(ind) <- newNode :: (!htab).(ind) ) let resetUnique () = ( sz_1 := initSize_1; htab := Array.create (!sz_1+1) []; n_items := 0; nodeC := 1 ) let mkNode low v high = let idl = getId low in let idh = getId high in if idl = idh then low else let ind = hashVal idl idh v land (!sz_1) in let bucket = (!htab).(ind) in let rec lookup b = match b with [] -> let n = Node(low, v, (incr nodeC; !nodeC), high) in insert (getId low) (getId high) v ind bucket n; n | n :: ns -> match n with | Node(l,v',id,h) -> if v = v' && idl = getId l && idh = getId h then n else lookup ns | _ -> assert false in lookup bucket type ordering = LESS | EQUAL | GREATER let cmpVar (x : int) (y : int) = if xy then GREATER else EQUAL let zero = Zero let one = One let mkVar x = mkNode zero x one let cacheSize = 1999 let andslot1 = Array.create cacheSize 0 let andslot2 = Array.create cacheSize 0 let andslot3 = Array.create cacheSize zero let xorslot1 = Array.create cacheSize 0 let xorslot2 = Array.create cacheSize 0 let xorslot3 = Array.create cacheSize zero let notslot1 = Array.create cacheSize 0 let notslot2 = Array.create cacheSize one let hash x y = ((x lsl 1)+y) mod cacheSize let rec not n = match n with Zero -> One | One -> Zero | Node(l, v, id, r) -> let h = id mod cacheSize in if id=notslot1.(h) then notslot2.(h) else let f = mkNode (not l) v (not r) in notslot1.(h) <- id; notslot2.(h) <- f; f let rec and2 n1 n2 = match n1 with Node(l1, v1, i1, r1) -> (match n2 with Node(l2, v2, i2, r2) -> let h = hash i1 i2 in if i1=andslot1.(h) && i2=andslot2.(h) then andslot3.(h) else let f = match cmpVar v1 v2 with EQUAL -> mkNode (and2 l1 l2) v1 (and2 r1 r2) | LESS -> mkNode (and2 l1 n2) v1 (and2 r1 n2) | GREATER -> mkNode (and2 n1 l2) v2 (and2 n1 r2) in andslot1.(h) <- i1; andslot2.(h) <- i2; andslot3.(h) <- f; f | Zero -> Zero | One -> n1) | Zero -> Zero | One -> n2 let rec xor n1 n2 = match n1 with Node(l1, v1, i1, r1) -> (match n2 with Node(l2, v2, i2, r2) -> let h = hash i1 i2 in if i1=andslot1.(h) && i2=andslot2.(h) then andslot3.(h) else let f = match cmpVar v1 v2 with EQUAL -> mkNode (xor l1 l2) v1 (xor r1 r2) | LESS -> mkNode (xor l1 n2) v1 (xor r1 n2) | GREATER -> mkNode (xor n1 l2) v2 (xor n1 r2) in andslot1.(h) <- i1; andslot2.(h) <- i2; andslot3.(h) <- f; f | Zero -> n1 | One -> not n1) | Zero -> n2 | One -> not n2 let hwb n = let rec h i j = if i=j then mkVar i else xor (and2 (not(mkVar j)) (h i (j-1))) (and2 (mkVar j) (g i (j-1))) and g i j = if i=j then mkVar i else xor (and2 (not(mkVar i)) (h (i+1) j)) (and2 (mkVar i) (g (i+1) j)) in h 0 (n-1) (* Testing *) let seed = ref 0 let random() = seed := !seed * 25173 + 17431; !seed land 1 > 0 let random_vars n = let vars = Array.create n false in for i = 0 to n - 1 do vars.(i) <- random() done; vars let test_hwb bdd vars = (* We should have eval bdd vars = vars.(n-1) if n > 0 eval bdd vars = false if n = 0 where n is the number of "true" elements in vars. *) let ntrue = ref 0 in for i = 0 to Array.length vars - 1 do if vars.(i) then incr ntrue done; eval bdd vars = (if !ntrue > 0 then vars.(!ntrue-1) else false) let main () = let n = if Array.length Sys.argv >= 2 then int_of_string Sys.argv.(1) else 22 in let ntests = if Array.length Sys.argv >= 3 then int_of_string Sys.argv.(2) else 100 in let bdd = hwb n in let succeeded = ref true in for i = 1 to ntests do succeeded := !succeeded && test_hwb bdd (random_vars n) done; if !succeeded then print_string "OK\n" else print_string "FAILED\n"; exit 0 let _ = main() mingw-ocaml/ocaml/testsuite/tests/misc/nucleic.ml0000644000175000017500000044244012124403241021570 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Use floating-point arithmetic *) external (+) : float -> float -> float = "%addfloat" external (-) : float -> float -> float = "%subfloat" external ( * ) : float -> float -> float = "%mulfloat" external (/) : float -> float -> float = "%divfloat" (* -- MATH UTILITIES --------------------------------------------------------*) let constant_pi = 3.14159265358979323846 let constant_minus_pi = -3.14159265358979323846 let constant_pi2 = 1.57079632679489661923 let constant_minus_pi2 = -1.57079632679489661923 (* -- POINTS ----------------------------------------------------------------*) type pt = { x : float; y : float; z : float } let pt_sub p1 p2 = { x = p1.x - p2.x; y = p1.y - p2.y; z = p1.z - p2.z } let pt_dist p1 p2 = let dx = p1.x - p2.x and dy = p1.y - p2.y and dz = p1.z - p2.z in sqrt ((dx * dx) + (dy * dy) + (dz * dz)) let pt_phi p = let b = atan2 p.x p.z in atan2 ((cos b) * p.z + (sin b) * p.x) p.y let pt_theta p = atan2 p.x p.z (* -- COORDINATE TRANSFORMATIONS --------------------------------------------*) (* The notation for the transformations follows "Paul, R.P. (1981) Robot Manipulators. MIT Press." with the exception that our transformation matrices don't have the perspective terms and are the transpose of Paul's one. See also "M\"antyl\"a, M. (1985) An Introduction to Solid Modeling, Computer Science Press" Appendix A. The components of a transformation matrix are named like this: a b c d e f g h i tx ty tz The components tx, ty, and tz are the translation vector. *) type tfo = {a: float; b: float; c: float; d: float; e: float; f: float; g: float; h: float; i: float; tx: float; ty: float; tz: float} let tfo_id = {a=1.0; b=0.0; c=0.0; d=0.0; e=1.0; f=0.0; g=0.0; h=0.0; i=1.0; tx=0.0; ty=0.0; tz=0.0} (* The function "tfo-apply" multiplies a transformation matrix, tfo, by a point vector, p. The result is a new point. *) let tfo_apply t p = { x = ((p.x * t.a) + (p.y * t.d) + (p.z * t.g) + t.tx); y = ((p.x * t.b) + (p.y * t.e) + (p.z * t.h) + t.ty); z = ((p.x * t.c) + (p.y * t.f) + (p.z * t.i) + t.tz) } (* The function "tfo-combine" multiplies two transformation matrices A and B. The result is a new matrix which cumulates the transformations described by A and B. *) let tfo_combine a b = (* *) (* Hand elimination of common subexpressions. Assumes lots of float registers (32 is perfect, 16 still OK). Loses on the I386, of course. *) let a_a = a.a and a_b = a.b and a_c = a.c and a_d = a.d and a_e = a.e and a_f = a.f and a_g = a.g and a_h = a.h and a_i = a.i and a_tx = a.tx and a_ty = a.ty and a_tz = a.tz and b_a = b.a and b_b = b.b and b_c = b.c and b_d = b.d and b_e = b.e and b_f = b.f and b_g = b.g and b_h = b.h and b_i = b.i and b_tx = b.tx and b_ty = b.ty and b_tz = b.tz in { a = ((a_a * b_a) + (a_b * b_d) + (a_c * b_g)); b = ((a_a * b_b) + (a_b * b_e) + (a_c * b_h)); c = ((a_a * b_c) + (a_b * b_f) + (a_c * b_i)); d = ((a_d * b_a) + (a_e * b_d) + (a_f * b_g)); e = ((a_d * b_b) + (a_e * b_e) + (a_f * b_h)); f = ((a_d * b_c) + (a_e * b_f) + (a_f * b_i)); g = ((a_g * b_a) + (a_h * b_d) + (a_i * b_g)); h = ((a_g * b_b) + (a_h * b_e) + (a_i * b_h)); i = ((a_g * b_c) + (a_h * b_f) + (a_i * b_i)); tx = ((a_tx * b_a) + (a_ty * b_d) + (a_tz * b_g) + b_tx); ty = ((a_tx * b_b) + (a_ty * b_e) + (a_tz * b_h) + b_ty); tz = ((a_tx * b_c) + (a_ty * b_f) + (a_tz * b_i) + b_tz) } (* *) (* Original without CSE *) (* *) (*** { a = ((a.a * b.a) + (a.b * b.d) + (a.c * b.g)); b = ((a.a * b.b) + (a.b * b.e) + (a.c * b.h)); c = ((a.a * b.c) + (a.b * b.f) + (a.c * b.i)); d = ((a.d * b.a) + (a.e * b.d) + (a.f * b.g)); e = ((a.d * b.b) + (a.e * b.e) + (a.f * b.h)); f = ((a.d * b.c) + (a.e * b.f) + (a.f * b.i)); g = ((a.g * b.a) + (a.h * b.d) + (a.i * b.g)); h = ((a.g * b.b) + (a.h * b.e) + (a.i * b.h)); i = ((a.g * b.c) + (a.h * b.f) + (a.i * b.i)); tx = ((a.tx * b.a) + (a.ty * b.d) + (a.tz * b.g) + b.tx); ty = ((a.tx * b.b) + (a.ty * b.e) + (a.tz * b.h) + b.ty); tz = ((a.tx * b.c) + (a.ty * b.f) + (a.tz * b.i) + b.tz) } ***) (* *) (* The function "tfo-inv-ortho" computes the inverse of a homogeneous transformation matrix. *) let tfo_inv_ortho t = { a = t.a; b = t.d; c = t.g; d = t.b; e = t.e; f = t.h; g = t.c; h = t.f; i = t.i; tx = (-.((t.a * t.tx) + (t.b * t.ty) + (t.c * t.tz))); ty = (-.((t.d * t.tx) + (t.e * t.ty) + (t.f * t.tz))); tz = (-.((t.g * t.tx) + (t.h * t.ty) + (t.i * t.tz))) } (* Given three points p1, p2, and p3, the function "tfo-align" computes a transformation matrix such that point p1 gets mapped to (0,0,0), p2 gets mapped to the Y axis and p3 gets mapped to the YZ plane. *) let tfo_align p1 p2 p3 = let x31 = p3.x - p1.x in let y31 = p3.y - p1.y in let z31 = p3.z - p1.z in let rotpy = pt_sub p2 p1 in let phi = pt_phi rotpy in let theta = pt_theta rotpy in let sinp = sin phi in let sint = sin theta in let cosp = cos phi in let cost = cos theta in let sinpsint = sinp * sint in let sinpcost = sinp * cost in let cospsint = cosp * sint in let cospcost = cosp * cost in let rotpz = { x = ((cost * x31) - (sint * z31)); y = ((sinpsint * x31) + (cosp * y31) + (sinpcost * z31)); z = ((cospsint * x31) + (-.(sinp * y31)) + (cospcost * z31)) } in let rho = pt_theta rotpz in let cosr = cos rho in let sinr = sin rho in let x = (-.(p1.x * cost)) + (p1.z * sint) in let y = ((-.(p1.x * sinpsint)) - (p1.y * cosp)) - (p1.z * sinpcost) in let z = ((-.(p1.x * cospsint) + (p1.y * sinp))) - (p1.z * cospcost) in { a = ((cost * cosr) - (cospsint * sinr)); b = sinpsint; c = ((cost * sinr) + (cospsint * cosr)); d = (sinp * sinr); e = cosp; f = (-.(sinp * cosr)); g = ((-.(sint * cosr)) - (cospcost * sinr)); h = sinpcost; i = ((-.(sint * sinr) + (cospcost * cosr))); tx = ((x * cosr) - (z * sinr)); ty = y; tz = ((x * sinr + (z * cosr))) } (* -- NUCLEIC ACID CONFORMATIONS DATA BASE ----------------------------------*) (* Numbering of atoms follows the paper: IUPAC-IUB Joint Commission on Biochemical Nomenclature (JCBN) (1983) Abbreviations and Symbols for the Description of Conformations of Polynucleotide Chains. Eur. J. Biochem 131, 9-15. *) (* Define remaining atoms for each nucleotide type. *) type nuc_specific = A of pt*pt*pt*pt*pt*pt*pt*pt | C of pt*pt*pt*pt*pt*pt | G of pt*pt*pt*pt*pt*pt*pt*pt*pt | U of pt*pt*pt*pt*pt (* A n6 n7 n9 c8 h2 h61 h62 h8 C n4 o2 h41 h42 h5 h6 G n2 n7 n9 c8 o6 h1 h21 h22 h8 U o2 o4 h3 h5 h6 *) (* Define part common to all 4 nucleotide types. *) type nuc = N of tfo*tfo*tfo*tfo* pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt* pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt* pt*nuc_specific (* dgf_base_tfo ; defines the standard position for wc and wc_dumas p_o3'_275_tfo ; defines the standard position for the connect function p_o3'_180_tfo p_o3'_60_tfo p o1p o2p o5' c5' h5' h5'' c4' h4' o4' c1' h1' c2' h2'' o2' h2' c3' h3' o3' n1 n3 c2 c4 c5 c6 *) let is_A = function N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,A(_,_,_,_,_,_,_,_)) -> true | _ -> false let is_C = function N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,C(_,_,_,_,_,_)) -> true | _ -> false let is_G = function N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,G(_,_,_,_,_,_,_,_,_)) -> true | _ -> false let nuc_C1' (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,_)) = c1' let nuc_C2 (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,_)) = c2 let nuc_C3' (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,_)) = c3' let nuc_C4 (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,_)) = c4 let nuc_C4' (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,_)) = c4' let nuc_N1 (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,_)) = n1 let nuc_O3' (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,_)) = o3' let nuc_P (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,_)) = p let nuc_dgf_base_tfo (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,_)) = dgf_base_tfo let nuc_p_o3'_180_tfo (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,_)) = p_o3'_180_tfo let nuc_p_o3'_275_tfo (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,_)) = p_o3'_275_tfo let nuc_p_o3'_60_tfo (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,_)) = p_o3'_60_tfo let rA_N9 = function | (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,A (n6,n7,n9,c8,h2,h61,h62,h8))) -> n9 | _ -> assert false let rG_N9 = function | (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,G (n2,n7,n9,c8,o6,h1,h21,h22,h8))) -> n9 | _ -> assert false (* Database of nucleotide conformations: *) let rA = N( { a= -0.0018; b= -0.8207; c=0.5714; (* dgf_base_tfo *) d=0.2679; e= -0.5509; f= -0.7904; g=0.9634; h=0.1517; i=0.2209; tx=0.0073; ty=8.4030; tz=0.6232 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 5.4550; y = 8.2120; z = -2.8810 }, (* C5' *) { x = 5.4546; y = 8.8508; z = -1.9978 }, (* H5' *) { x = 5.7588; y = 8.6625; z = -3.8259 }, (* H5'' *) { x = 6.4970; y = 7.1480; z = -2.5980 }, (* C4' *) { x = 7.4896; y = 7.5919; z = -2.5214 }, (* H4' *) { x = 6.1630; y = 6.4860; z = -1.3440 }, (* O4' *) { x = 6.5400; y = 5.1200; z = -1.4190 }, (* C1' *) { x = 7.2763; y = 4.9681; z = -0.6297 }, (* H1' *) { x = 7.1940; y = 4.8830; z = -2.7770 }, (* C2' *) { x = 6.8667; y = 3.9183; z = -3.1647 }, (* H2'' *) { x = 8.5860; y = 5.0910; z = -2.6140 }, (* O2' *) { x = 8.9510; y = 4.7626; z = -1.7890 }, (* H2' *) { x = 6.5720; y = 6.0040; z = -3.6090 }, (* C3' *) { x = 5.5636; y = 5.7066; z = -3.8966 }, (* H3' *) { x = 7.3801; y = 6.3562; z = -4.7350 }, (* O3' *) { x = 4.7150; y = 0.4910; z = -0.1360 }, (* N1 *) { x = 6.3490; y = 2.1730; z = -0.6020 }, (* N3 *) { x = 5.9530; y = 0.9650; z = -0.2670 }, (* C2 *) { x = 5.2900; y = 2.9790; z = -0.8260 }, (* C4 *) { x = 3.9720; y = 2.6390; z = -0.7330 }, (* C5 *) { x = 3.6770; y = 1.3160; z = -0.3660 }, (* C6 *) (A ( { x = 2.4280; y = 0.8450; z = -0.2360 }, (* N6 *) { x = 3.1660; y = 3.7290; z = -1.0360 }, (* N7 *) { x = 5.3170; y = 4.2990; z = -1.1930 }, (* N9 *) { x = 4.0100; y = 4.6780; z = -1.2990 }, (* C8 *) { x = 6.6890; y = 0.1903; z = -0.0518 }, (* H2 *) { x = 1.6470; y = 1.4460; z = -0.4040 }, (* H61 *) { x = 2.2780; y = -0.1080; z = -0.0280 }, (* H62 *) { x = 3.4421; y = 5.5744; z = -1.5482 }) (* H8 *) ) ) let rA01 = N( { a= -0.0043; b= -0.8175; c=0.5759; (* dgf_base_tfo *) d=0.2617; e= -0.5567; f= -0.7884; g=0.9651; h=0.1473; i=0.2164; tx=0.0359; ty=8.3929; tz=0.5532 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5' *) { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5' *) { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *) { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4' *) { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4' *) { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4' *) { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1' *) { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1' *) { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2' *) { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *) { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2' *) { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2' *) { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3' *) { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3' *) { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3' *) { x = 4.7442; y = 0.4514; z = -0.1390 }, (* N1 *) { x = 6.3687; y = 2.1459; z = -0.5926 }, (* N3 *) { x = 5.9795; y = 0.9335; z = -0.2657 }, (* C2 *) { x = 5.3052; y = 2.9471; z = -0.8125 }, (* C4 *) { x = 3.9891; y = 2.5987; z = -0.7230 }, (* C5 *) { x = 3.7016; y = 1.2717; z = -0.3647 }, (* C6 *) (A ( { x = 2.4553; y = 0.7925; z = -0.2390 }, (* N6 *) { x = 3.1770; y = 3.6859; z = -1.0198 }, (* N7 *) { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9 *) { x = 4.0156; y = 4.6415; z = -1.2759 }, (* C8 *) { x = 6.7198; y = 0.1618; z = -0.0547 }, (* H2 *) { x = 1.6709; y = 1.3900; z = -0.4039 }, (* H61 *) { x = 2.3107; y = -0.1627; z = -0.0373 }, (* H62 *) { x = 3.4426; y = 5.5361; z = -1.5199 }) (* H8 *) ) ) let rA02 = N( { a=0.5566; b=0.0449; c=0.8296; (* dgf_base_tfo *) d=0.5125; e=0.7673; f= -0.3854; g= -0.6538; h=0.6397; i=0.4041; tx= -9.1161; ty= -3.7679; tz= -2.9968 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5' *) { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5' *) { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *) { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4' *) { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4' *) { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4' *) { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1' *) { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1' *) { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2' *) { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *) { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2' *) { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2' *) { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3' *) { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3' *) { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3' *) { x = 10.3245; y = 8.5459; z = 1.5467 }, (* N1 *) { x = 9.8051; y = 6.9432; z = -0.1497 }, (* N3 *) { x = 10.5175; y = 7.4328; z = 0.8408 }, (* C2 *) { x = 8.7523; y = 7.7422; z = -0.4228 }, (* C4 *) { x = 8.4257; y = 8.9060; z = 0.2099 }, (* C5 *) { x = 9.2665; y = 9.3242; z = 1.2540 }, (* C6 *) (A ( { x = 9.0664; y = 10.4462; z = 1.9610 }, (* N6 *) { x = 7.2750; y = 9.4537; z = -0.3428 }, (* N7 *) { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9 *) { x = 6.9479; y = 8.6157; z = -1.2771 }, (* C8 *) { x = 11.4063; y = 6.9047; z = 1.1859 }, (* H2 *) { x = 8.2845; y = 11.0341; z = 1.7552 }, (* H61 *) { x = 9.6584; y = 10.6647; z = 2.7198 }, (* H62 *) { x = 6.0430; y = 8.9853; z = -1.7594 }) (* H8 *) ) ) let rA03 = N( { a= -0.5021; b=0.0731; c=0.8617; (* dgf_base_tfo *) d= -0.8112; e=0.3054; f= -0.4986; g= -0.2996; h= -0.9494; i= -0.0940; tx=6.4273; ty= -5.1944; tz= -3.7807 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5' *) { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5' *) { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *) { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4' *) { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4' *) { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4' *) { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1' *) { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1' *) { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2' *) { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *) { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2' *) { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2' *) { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3' *) { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3' *) { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3' *) { x = 9.6740; y = 4.7656; z = -7.6614 }, (* N1 *) { x = 9.0739; y = 4.3013; z = -5.3941 }, (* N3 *) { x = 9.8416; y = 4.2192; z = -6.4581 }, (* C2 *) { x = 7.9885; y = 5.0632; z = -5.6446 }, (* C4 *) { x = 7.6822; y = 5.6856; z = -6.8194 }, (* C5 *) { x = 8.5831; y = 5.5215; z = -7.8840 }, (* C6 *) (A ( { x = 8.4084; y = 6.0747; z = -9.0933 }, (* N6 *) { x = 6.4857; y = 6.3816; z = -6.7035 }, (* N7 *) { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9 *) { x = 6.1133; y = 6.1613; z = -5.4808 }, (* C8 *) { x = 10.7627; y = 3.6375; z = -6.4220 }, (* H2 *) { x = 7.6031; y = 6.6390; z = -9.2733 }, (* H61 *) { x = 9.1004; y = 5.9708; z = -9.7893 }, (* H62 *) { x = 5.1705; y = 6.6830; z = -5.3167 }) (* H8 *) ) ) let rA04 = N( { a= -0.5426; b= -0.8175; c=0.1929; (* dgf_base_tfo *) d=0.8304; e= -0.5567; f= -0.0237; g=0.1267; h=0.1473; i=0.9809; tx= -0.5075; ty=8.3929; tz=0.2229 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5' *) { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5' *) { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *) { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4' *) { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4' *) { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4' *) { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1' *) { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1' *) { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2' *) { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *) { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2' *) { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2' *) { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3' *) { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3' *) { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3' *) { x = 3.6343; y = 2.6680; z = 2.0783 }, (* N1 *) { x = 5.4505; y = 3.9805; z = 1.2446 }, (* N3 *) { x = 4.7540; y = 3.3816; z = 2.1851 }, (* C2 *) { x = 4.8805; y = 3.7951; z = 0.0354 }, (* C4 *) { x = 3.7416; y = 3.0925; z = -0.2305 }, (* C5 *) { x = 3.0873; y = 2.4980; z = 0.8606 }, (* C6 *) (A ( { x = 1.9600; y = 1.7805; z = 0.7462 }, (* N6 *) { x = 3.4605; y = 3.1184; z = -1.5906 }, (* N7 *) { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9 *) { x = 4.4244; y = 3.8244; z = -2.0953 }, (* C8 *) { x = 5.0814; y = 3.4352; z = 3.2234 }, (* H2 *) { x = 1.5423; y = 1.6454; z = -0.1520 }, (* H61 *) { x = 1.5716; y = 1.3398; z = 1.5392 }, (* H62 *) { x = 4.2675; y = 3.8876; z = -3.1721 }) (* H8 *) ) ) let rA05 = N( { a= -0.5891; b=0.0449; c=0.8068; (* dgf_base_tfo *) d=0.5375; e=0.7673; f=0.3498; g= -0.6034; h=0.6397; i= -0.4762; tx= -0.3019; ty= -3.7679; tz= -9.5913 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5' *) { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5' *) { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *) { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4' *) { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4' *) { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4' *) { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1' *) { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1' *) { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2' *) { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *) { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2' *) { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2' *) { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3' *) { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3' *) { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3' *) { x = 10.2594; y = 10.6774; z = -1.0056 }, (* N1 *) { x = 9.7528; y = 8.7080; z = -2.2631 }, (* N3 *) { x = 10.4471; y = 9.7876; z = -1.9791 }, (* C2 *) { x = 8.7271; y = 8.5575; z = -1.3991 }, (* C4 *) { x = 8.4100; y = 9.3803; z = -0.3580 }, (* C5 *) { x = 9.2294; y = 10.5030; z = -0.1574 }, (* C6 *) (A ( { x = 9.0349; y = 11.3951; z = 0.8250 }, (* N6 *) { x = 7.2891; y = 8.9068; z = 0.3121 }, (* N7 *) { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9 *) { x = 6.9702; y = 7.8292; z = -0.3353 }, (* C8 *) { x = 11.3132; y = 10.0537; z = -2.5851 }, (* H2 *) { x = 8.2741; y = 11.2784; z = 1.4629 }, (* H61 *) { x = 9.6733; y = 12.1368; z = 0.9529 }, (* H62 *) { x = 6.0888; y = 7.3990; z = 0.1403 }) (* H8 *) ) ) let rA06 = N( { a= -0.9815; b=0.0731; c= -0.1772; (* dgf_base_tfo *) d=0.1912; e=0.3054; f= -0.9328; g= -0.0141; h= -0.9494; i= -0.3137; tx=5.7506; ty= -5.1944; tz=4.7470 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5' *) { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5' *) { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *) { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4' *) { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4' *) { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4' *) { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1' *) { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1' *) { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2' *) { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *) { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2' *) { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2' *) { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3' *) { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3' *) { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3' *) { x = 6.6624; y = 3.5061; z = -8.2986 }, (* N1 *) { x = 6.5810; y = 3.2570; z = -5.9221 }, (* N3 *) { x = 6.5151; y = 2.8263; z = -7.1625 }, (* C2 *) { x = 6.8364; y = 4.5817; z = -5.8882 }, (* C4 *) { x = 7.0116; y = 5.4064; z = -6.9609 }, (* C5 *) { x = 6.9173; y = 4.8260; z = -8.2361 }, (* C6 *) (A ( { x = 7.0668; y = 5.5163; z = -9.3763 }, (* N6 *) { x = 7.2573; y = 6.7070; z = -6.5394 }, (* N7 *) { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9 *) { x = 7.2238; y = 6.6275; z = -5.2453 }, (* C8 *) { x = 6.3146; y = 1.7741; z = -7.3641 }, (* H2 *) { x = 7.2568; y = 6.4972; z = -9.3456 }, (* H61 *) { x = 7.0437; y = 5.0478; z = -10.2446 }, (* H62 *) { x = 7.4108; y = 7.6227; z = -4.8418 }) (* H8 *) ) ) let rA07 = N( { a=0.2379; b=0.1310; c= -0.9624; (* dgf_base_tfo *) d= -0.5876; e= -0.7696; f= -0.2499; g= -0.7734; h=0.6249; i= -0.1061; tx=30.9870; ty= -26.9344; tz=42.6416 }, { a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *) d=0.2952; e= -0.9481; f= -0.1180; g=0.5882; h=0.2777; i= -0.7595; tx= -58.8919; ty= -11.3095; tz=6.0866 }, { a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *) d=0.9731; e= -0.0359; f= -0.2275; g= -0.2290; h= -0.2532; i= -0.9399; tx=3.5401; ty= -29.7913; tz=52.2796 }, { a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *) d= -0.1183; e=0.1805; f= -0.9764; g=0.4380; h= -0.8730; i= -0.2145; tx=19.9023; ty=54.8054; tz=15.2799 }, { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P *) { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P *) { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P *) { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5' *) { x = 39.3505; y = 8.4697; z = 42.6565 }, (* C5' *) { x = 39.1377; y = 7.5433; z = 42.1230 }, (* H5' *) { x = 39.7203; y = 9.3119; z = 42.0717 }, (* H5'' *) { x = 38.0405; y = 8.9195; z = 43.2869 }, (* C4' *) { x = 37.3687; y = 9.3036; z = 42.5193 }, (* H4' *) { x = 37.4319; y = 7.8146; z = 43.9387 }, (* O4' *) { x = 37.1959; y = 8.1354; z = 45.3237 }, (* C1' *) { x = 36.1788; y = 8.5202; z = 45.3970 }, (* H1' *) { x = 38.1721; y = 9.2328; z = 45.6504 }, (* C2' *) { x = 39.1555; y = 8.7939; z = 45.8188 }, (* H2'' *) { x = 37.7862; y = 10.0617; z = 46.7013 }, (* O2' *) { x = 37.3087; y = 9.6229; z = 47.4092 }, (* H2' *) { x = 38.1844; y = 10.0268; z = 44.3367 }, (* C3' *) { x = 39.1578; y = 10.5054; z = 44.2289 }, (* H3' *) { x = 37.0547; y = 10.9127; z = 44.3441 }, (* O3' *) { x = 34.8811; y = 4.2072; z = 47.5784 }, (* N1 *) { x = 35.1084; y = 6.1336; z = 46.1818 }, (* N3 *) { x = 34.4108; y = 5.1360; z = 46.7207 }, (* C2 *) { x = 36.3908; y = 6.1224; z = 46.6053 }, (* C4 *) { x = 36.9819; y = 5.2334; z = 47.4697 }, (* C5 *) { x = 36.1786; y = 4.1985; z = 48.0035 }, (* C6 *) (A ( { x = 36.6103; y = 3.2749; z = 48.8452 }, (* N6 *) { x = 38.3236; y = 5.5522; z = 47.6595 }, (* N7 *) { x = 37.3887; y = 7.0024; z = 46.2437 }, (* N9 *) { x = 38.5055; y = 6.6096; z = 46.9057 }, (* C8 *) { x = 33.3553; y = 5.0152; z = 46.4771 }, (* H2 *) { x = 37.5730; y = 3.2804; z = 49.1507 }, (* H61 *) { x = 35.9775; y = 2.5638; z = 49.1828 }, (* H62 *) { x = 39.5461; y = 6.9184; z = 47.0041 }) (* H8 *) ) ) let rA08 = N( { a=0.1084; b= -0.0895; c= -0.9901; (* dgf_base_tfo *) d=0.9789; e= -0.1638; f=0.1220; g= -0.1731; h= -0.9824; i=0.0698; tx= -2.9039; ty=47.2655; tz=33.0094 }, { a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *) d=0.2952; e= -0.9481; f= -0.1180; g=0.5882; h=0.2777; i= -0.7595; tx= -58.8919; ty= -11.3095; tz=6.0866 }, { a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *) d=0.9731; e= -0.0359; f= -0.2275; g= -0.2290; h= -0.2532; i= -0.9399; tx=3.5401; ty= -29.7913; tz=52.2796 }, { a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *) d= -0.1183; e=0.1805; f= -0.9764; g=0.4380; h= -0.8730; i= -0.2145; tx=19.9023; ty=54.8054; tz=15.2799 }, { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P *) { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P *) { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P *) { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5' *) { x = 39.4850; y = 8.9301; z = 44.6977 }, (* C5' *) { x = 39.0638; y = 9.8199; z = 44.2296 }, (* H5' *) { x = 40.0757; y = 9.0713; z = 45.6029 }, (* H5'' *) { x = 38.3102; y = 8.0414; z = 45.0789 }, (* C4' *) { x = 37.7842; y = 8.4637; z = 45.9351 }, (* H4' *) { x = 37.4200; y = 7.9453; z = 43.9769 }, (* O4' *) { x = 37.2249; y = 6.5609; z = 43.6273 }, (* C1' *) { x = 36.3360; y = 6.2168; z = 44.1561 }, (* H1' *) { x = 38.4347; y = 5.8414; z = 44.1590 }, (* C2' *) { x = 39.2688; y = 5.9974; z = 43.4749 }, (* H2'' *) { x = 38.2344; y = 4.4907; z = 44.4348 }, (* O2' *) { x = 37.6374; y = 4.0386; z = 43.8341 }, (* H2' *) { x = 38.6926; y = 6.6079; z = 45.4637 }, (* C3' *) { x = 39.7585; y = 6.5640; z = 45.6877 }, (* H3' *) { x = 37.8238; y = 6.0705; z = 46.4723 }, (* O3' *) { x = 33.9162; y = 6.2598; z = 39.7758 }, (* N1 *) { x = 34.6709; y = 6.5759; z = 42.0215 }, (* N3 *) { x = 33.7257; y = 6.5186; z = 41.0858 }, (* C2 *) { x = 35.8935; y = 6.3324; z = 41.5018 }, (* C4 *) { x = 36.2105; y = 6.0601; z = 40.1932 }, (* C5 *) { x = 35.1538; y = 6.0151; z = 39.2537 }, (* C6 *) (A ( { x = 35.3088; y = 5.7642; z = 37.9649 }, (* N6 *) { x = 37.5818; y = 5.8677; z = 40.0507 }, (* N7 *) { x = 37.0932; y = 6.3197; z = 42.1810 }, (* N9 *) { x = 38.0509; y = 6.0354; z = 41.2635 }, (* C8 *) { x = 32.6830; y = 6.6898; z = 41.3532 }, (* H2 *) { x = 36.2305; y = 5.5855; z = 37.5925 }, (* H61 *) { x = 34.5056; y = 5.7512; z = 37.3528 }, (* H62 *) { x = 39.1318; y = 5.8993; z = 41.2285 }) (* H8 *) ) ) let rA09 = N( { a=0.8467; b=0.4166; c= -0.3311; (* dgf_base_tfo *) d= -0.3962; e=0.9089; f=0.1303; g=0.3552; h=0.0209; i=0.9346; tx= -42.7319; ty= -26.6223; tz= -29.8163 }, { a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *) d=0.2952; e= -0.9481; f= -0.1180; g=0.5882; h=0.2777; i= -0.7595; tx= -58.8919; ty= -11.3095; tz=6.0866 }, { a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *) d=0.9731; e= -0.0359; f= -0.2275; g= -0.2290; h= -0.2532; i= -0.9399; tx=3.5401; ty= -29.7913; tz=52.2796 }, { a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *) d= -0.1183; e=0.1805; f= -0.9764; g=0.4380; h= -0.8730; i= -0.2145; tx=19.9023; ty=54.8054; tz=15.2799 }, { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P *) { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P *) { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P *) { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5' *) { x = 39.3505; y = 8.4697; z = 42.6565 }, (* C5' *) { x = 39.1377; y = 7.5433; z = 42.1230 }, (* H5' *) { x = 39.7203; y = 9.3119; z = 42.0717 }, (* H5'' *) { x = 38.0405; y = 8.9195; z = 43.2869 }, (* C4' *) { x = 37.6479; y = 8.1347; z = 43.9335 }, (* H4' *) { x = 38.2691; y = 10.0933; z = 44.0524 }, (* O4' *) { x = 37.3999; y = 11.1488; z = 43.5973 }, (* C1' *) { x = 36.5061; y = 11.1221; z = 44.2206 }, (* H1' *) { x = 37.0364; y = 10.7838; z = 42.1836 }, (* C2' *) { x = 37.8636; y = 11.0489; z = 41.5252 }, (* H2'' *) { x = 35.8275; y = 11.3133; z = 41.7379 }, (* O2' *) { x = 35.6214; y = 12.1896; z = 42.0714 }, (* H2' *) { x = 36.9316; y = 9.2556; z = 42.2837 }, (* C3' *) { x = 37.1778; y = 8.8260; z = 41.3127 }, (* H3' *) { x = 35.6285; y = 8.9334; z = 42.7926 }, (* O3' *) { x = 38.1482; y = 15.2833; z = 46.4641 }, (* N1 *) { x = 37.3641; y = 13.0968; z = 45.9007 }, (* N3 *) { x = 37.5032; y = 14.1288; z = 46.7300 }, (* C2 *) { x = 37.9570; y = 13.3377; z = 44.7113 }, (* C4 *) { x = 38.6397; y = 14.4660; z = 44.3267 }, (* C5 *) { x = 38.7473; y = 15.5229; z = 45.2609 }, (* C6 *) (A ( { x = 39.3720; y = 16.6649; z = 45.0297 }, (* N6 *) { x = 39.1079; y = 14.3351; z = 43.0223 }, (* N7 *) { x = 38.0132; y = 12.4868; z = 43.6280 }, (* N9 *) { x = 38.7058; y = 13.1402; z = 42.6620 }, (* C8 *) { x = 37.0731; y = 14.0857; z = 47.7306 }, (* H2 *) { x = 39.8113; y = 16.8281; z = 44.1350 }, (* H61 *) { x = 39.4100; y = 17.3741; z = 45.7478 }, (* H62 *) { x = 39.0412; y = 12.9660; z = 41.6397 }) (* H8 *) ) ) let rA10 = N( { a=0.7063; b=0.6317; c= -0.3196; (* dgf_base_tfo *) d= -0.0403; e= -0.4149; f= -0.9090; g= -0.7068; h=0.6549; i= -0.2676; tx=6.4402; ty= -52.1496; tz=30.8246 }, { a=0.7529; b=0.1548; c=0.6397; (* P_O3'_275_tfo *) d=0.2952; e= -0.9481; f= -0.1180; g=0.5882; h=0.2777; i= -0.7595; tx= -58.8919; ty= -11.3095; tz=6.0866 }, { a= -0.0239; b=0.9667; c= -0.2546; (* P_O3'_180_tfo *) d=0.9731; e= -0.0359; f= -0.2275; g= -0.2290; h= -0.2532; i= -0.9399; tx=3.5401; ty= -29.7913; tz=52.2796 }, { a= -0.8912; b= -0.4531; c=0.0242; (* P_O3'_60_tfo *) d= -0.1183; e=0.1805; f= -0.9764; g=0.4380; h= -0.8730; i= -0.2145; tx=19.9023; ty=54.8054; tz=15.2799 }, { x = 41.8210; y = 8.3880; z = 43.5890 }, (* P *) { x = 42.5400; y = 8.0450; z = 44.8330 }, (* O1P *) { x = 42.2470; y = 9.6920; z = 42.9910 }, (* O2P *) { x = 40.2550; y = 8.2030; z = 43.7340 }, (* O5' *) { x = 39.4850; y = 8.9301; z = 44.6977 }, (* C5' *) { x = 39.0638; y = 9.8199; z = 44.2296 }, (* H5' *) { x = 40.0757; y = 9.0713; z = 45.6029 }, (* H5'' *) { x = 38.3102; y = 8.0414; z = 45.0789 }, (* C4' *) { x = 37.7099; y = 7.8166; z = 44.1973 }, (* H4' *) { x = 38.8012; y = 6.8321; z = 45.6380 }, (* O4' *) { x = 38.2431; y = 6.6413; z = 46.9529 }, (* C1' *) { x = 37.3505; y = 6.0262; z = 46.8385 }, (* H1' *) { x = 37.8484; y = 8.0156; z = 47.4214 }, (* C2' *) { x = 38.7381; y = 8.5406; z = 47.7690 }, (* H2'' *) { x = 36.8286; y = 8.0368; z = 48.3701 }, (* O2' *) { x = 36.8392; y = 7.3063; z = 48.9929 }, (* H2' *) { x = 37.3576; y = 8.6512; z = 46.1132 }, (* C3' *) { x = 37.5207; y = 9.7275; z = 46.1671 }, (* H3' *) { x = 35.9985; y = 8.2392; z = 45.9032 }, (* O3' *) { x = 39.9117; y = 2.2278; z = 48.8527 }, (* N1 *) { x = 38.6207; y = 3.6941; z = 47.4757 }, (* N3 *) { x = 38.9872; y = 2.4888; z = 47.9057 }, (* C2 *) { x = 39.2961; y = 4.6720; z = 48.1174 }, (* C4 *) { x = 40.2546; y = 4.5307; z = 49.0912 }, (* C5 *) { x = 40.5932; y = 3.2189; z = 49.4985 }, (* C6 *) (A ( { x = 41.4938; y = 2.9317; z = 50.4229 }, (* N6 *) { x = 40.7195; y = 5.7755; z = 49.5060 }, (* N7 *) { x = 39.1730; y = 6.0305; z = 47.9170 }, (* N9 *) { x = 40.0413; y = 6.6250; z = 48.7728 }, (* C8 *) { x = 38.5257; y = 1.5960; z = 47.4838 }, (* H2 *) { x = 41.9907; y = 3.6753; z = 50.8921 }, (* H61 *) { x = 41.6848; y = 1.9687; z = 50.6599 }, (* H62 *) { x = 40.3571; y = 7.6321; z = 49.0452 }) (* H8 *) ) ) let rAs = [rA01;rA02;rA03;rA04;rA05;rA06;rA07;rA08;rA09;rA10] let rC = N( { a= -0.0359; b= -0.8071; c=0.5894; (* dgf_base_tfo *) d= -0.2669; e=0.5761; f=0.7726; g= -0.9631; h= -0.1296; i= -0.2361; tx=0.1584; ty=8.3434; tz=0.5434 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 5.2430; y = -8.2420; z = 2.8260 }, (* C5' *) { x = 5.1974; y = -8.8497; z = 1.9223 }, (* H5' *) { x = 5.5548; y = -8.7348; z = 3.7469 }, (* H5'' *) { x = 6.3140; y = -7.2060; z = 2.5510 }, (* C4' *) { x = 7.2954; y = -7.6762; z = 2.4898 }, (* H4' *) { x = 6.0140; y = -6.5420; z = 1.2890 }, (* O4' *) { x = 6.4190; y = -5.1840; z = 1.3620 }, (* C1' *) { x = 7.1608; y = -5.0495; z = 0.5747 }, (* H1' *) { x = 7.0760; y = -4.9560; z = 2.7270 }, (* C2' *) { x = 6.7770; y = -3.9803; z = 3.1099 }, (* H2'' *) { x = 8.4500; y = -5.1930; z = 2.5810 }, (* O2' *) { x = 8.8309; y = -4.8755; z = 1.7590 }, (* H2' *) { x = 6.4060; y = -6.0590; z = 3.5580 }, (* C3' *) { x = 5.4021; y = -5.7313; z = 3.8281 }, (* H3' *) { x = 7.1570; y = -6.4240; z = 4.7070 }, (* O3' *) { x = 5.2170; y = -4.3260; z = 1.1690 }, (* N1 *) { x = 4.2960; y = -2.2560; z = 0.6290 }, (* N3 *) { x = 5.4330; y = -3.0200; z = 0.7990 }, (* C2 *) { x = 2.9930; y = -2.6780; z = 0.7940 }, (* C4 *) { x = 2.8670; y = -4.0630; z = 1.1830 }, (* C5 *) { x = 3.9570; y = -4.8300; z = 1.3550 }, (* C6 *) (C ( { x = 2.0187; y = -1.8047; z = 0.5874 }, (* N4 *) { x = 6.5470; y = -2.5560; z = 0.6290 }, (* O2 *) { x = 1.0684; y = -2.1236; z = 0.7109 }, (* H41 *) { x = 2.2344; y = -0.8560; z = 0.3162 }, (* H42 *) { x = 1.8797; y = -4.4972; z = 1.3404 }, (* H5 *) { x = 3.8479; y = -5.8742; z = 1.6480 }) (* H6 *) ) ) let rC01 = N( { a= -0.0137; b= -0.8012; c=0.5983; (* dgf_base_tfo *) d= -0.2523; e=0.5817; f=0.7733; g= -0.9675; h= -0.1404; i= -0.2101; tx=0.2031; ty=8.3874; tz=0.4228 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5' *) { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5' *) { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *) { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4' *) { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4' *) { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4' *) { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1' *) { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1' *) { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2' *) { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *) { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2' *) { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2' *) { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3' *) { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3' *) { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3' *) { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1 *) { x = 4.3777; y = -2.2062; z = 0.7229 }, (* N3 *) { x = 5.5069; y = -2.9779; z = 0.9088 }, (* C2 *) { x = 3.0693; y = -2.6246; z = 0.8500 }, (* C4 *) { x = 2.9279; y = -4.0146; z = 1.2149 }, (* C5 *) { x = 4.0101; y = -4.7892; z = 1.4017 }, (* C6 *) (C ( { x = 2.1040; y = -1.7437; z = 0.6331 }, (* N4 *) { x = 6.6267; y = -2.5166; z = 0.7728 }, (* O2 *) { x = 1.1496; y = -2.0600; z = 0.7287 }, (* H41 *) { x = 2.3303; y = -0.7921; z = 0.3815 }, (* H42 *) { x = 1.9353; y = -4.4465; z = 1.3419 }, (* H5 *) { x = 3.8895; y = -5.8371; z = 1.6762 }) (* H6 *) ) ) let rC02 = N( { a=0.5141; b=0.0246; c=0.8574; (* dgf_base_tfo *) d= -0.5547; e= -0.7529; f=0.3542; g=0.6542; h= -0.6577; i= -0.3734; tx= -9.1111; ty= -3.4598; tz= -3.2939 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5' *) { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5' *) { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *) { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4' *) { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4' *) { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4' *) { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1' *) { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1' *) { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2' *) { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *) { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2' *) { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2' *) { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3' *) { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3' *) { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3' *) { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1 *) { x = 8.6945; y = -8.7046; z = -0.2857 }, (* N3 *) { x = 8.6943; y = -7.6514; z = 0.6066 }, (* C2 *) { x = 7.7426; y = -9.6987; z = -0.3801 }, (* C4 *) { x = 6.6642; y = -9.5742; z = 0.5722 }, (* C5 *) { x = 6.6391; y = -8.5592; z = 1.4526 }, (* C6 *) (C ( { x = 7.9033; y = -10.6371; z = -1.3010 }, (* N4 *) { x = 9.5840; y = -6.8186; z = 0.6136 }, (* O2 *) { x = 7.2009; y = -11.3604; z = -1.3619 }, (* H41 *) { x = 8.7058; y = -10.6168; z = -1.9140 }, (* H42 *) { x = 5.8585; y = -10.3083; z = 0.5822 }, (* H5 *) { x = 5.8197; y = -8.4773; z = 2.1667 }) (* H6 *) ) ) let rC03 = N( { a= -0.4993; b=0.0476; c=0.8651; (* dgf_base_tfo *) d=0.8078; e= -0.3353; f=0.4847; g=0.3132; h=0.9409; i=0.1290; tx=6.2989; ty= -5.2303; tz= -3.8577 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5' *) { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5' *) { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *) { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4' *) { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4' *) { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4' *) { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1' *) { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1' *) { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2' *) { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *) { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2' *) { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2' *) { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3' *) { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3' *) { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3' *) { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1 *) { x = 7.9218; y = -5.5700; z = 6.8877 }, (* N3 *) { x = 7.8908; y = -5.0886; z = 5.5944 }, (* C2 *) { x = 6.9789; y = -6.3827; z = 7.4823 }, (* C4 *) { x = 5.8742; y = -6.7319; z = 6.6202 }, (* C5 *) { x = 5.8182; y = -6.2769; z = 5.3570 }, (* C6 *) (C ( { x = 7.1702; y = -6.7511; z = 8.7402 }, (* N4 *) { x = 8.7747; y = -4.3728; z = 5.1568 }, (* O2 *) { x = 6.4741; y = -7.3461; z = 9.1662 }, (* H41 *) { x = 7.9889; y = -6.4396; z = 9.2429 }, (* H42 *) { x = 5.0736; y = -7.3713; z = 6.9922 }, (* H5 *) { x = 4.9784; y = -6.5473; z = 4.7170 }) (* H6 *) ) ) let rC04 = N( { a= -0.5669; b= -0.8012; c=0.1918; (* dgf_base_tfo *) d= -0.8129; e=0.5817; f=0.0273; g= -0.1334; h= -0.1404; i= -0.9811; tx= -0.3279; ty=8.3874; tz=0.3355 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5' *) { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5' *) { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *) { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4' *) { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4' *) { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4' *) { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1' *) { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1' *) { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2' *) { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *) { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2' *) { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2' *) { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3' *) { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3' *) { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3' *) { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1 *) { x = 3.8961; y = -3.0896; z = -0.1893 }, (* N3 *) { x = 5.0095; y = -3.8907; z = -0.0346 }, (* C2 *) { x = 3.0480; y = -2.6632; z = 0.8116 }, (* C4 *) { x = 3.4093; y = -3.1310; z = 2.1292 }, (* C5 *) { x = 4.4878; y = -3.9124; z = 2.3088 }, (* C6 *) (C ( { x = 2.0216; y = -1.8941; z = 0.4804 }, (* N4 *) { x = 5.7005; y = -4.2164; z = -0.9842 }, (* O2 *) { x = 1.4067; y = -1.5873; z = 1.2205 }, (* H41 *) { x = 1.8721; y = -1.6319; z = -0.4835 }, (* H42 *) { x = 2.8048; y = -2.8507; z = 2.9918 }, (* H5 *) { x = 4.7491; y = -4.2593; z = 3.3085 }) (* H6 *) ) ) let rC05 = N( { a= -0.6298; b=0.0246; c=0.7763; (* dgf_base_tfo *) d= -0.5226; e= -0.7529; f= -0.4001; g=0.5746; h= -0.6577; i=0.4870; tx= -0.0208; ty= -3.4598; tz= -9.6882 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5' *) { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5' *) { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *) { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4' *) { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4' *) { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4' *) { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1' *) { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1' *) { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2' *) { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *) { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2' *) { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2' *) { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3' *) { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3' *) { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3' *) { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1 *) { x = 8.5977; y = -9.5977; z = 0.7329 }, (* N3 *) { x = 8.5951; y = -8.5745; z = 1.6594 }, (* C2 *) { x = 7.7372; y = -9.7371; z = -0.3364 }, (* C4 *) { x = 6.7596; y = -8.6801; z = -0.4476 }, (* C5 *) { x = 6.7338; y = -7.6721; z = 0.4408 }, (* C6 *) (C ( { x = 7.8849; y = -10.7881; z = -1.1289 }, (* N4 *) { x = 9.3993; y = -8.5377; z = 2.5743 }, (* O2 *) { x = 7.2499; y = -10.8809; z = -1.9088 }, (* H41 *) { x = 8.6122; y = -11.4649; z = -0.9468 }, (* H42 *) { x = 6.0317; y = -8.6941; z = -1.2588 }, (* H5 *) { x = 5.9901; y = -6.8809; z = 0.3459 }) (* H6 *) ) ) let rC06 = N( { a= -0.9837; b=0.0476; c= -0.1733; (* dgf_base_tfo *) d= -0.1792; e= -0.3353; f=0.9249; g= -0.0141; h=0.9409; i=0.3384; tx=5.7793; ty= -5.2303; tz=4.5997 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5' *) { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5' *) { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *) { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4' *) { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4' *) { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4' *) { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1' *) { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1' *) { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2' *) { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *) { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2' *) { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2' *) { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3' *) { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3' *) { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3' *) { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1 *) { x = 6.6920; y = -5.0495; z = 7.1354 }, (* N3 *) { x = 6.6201; y = -4.5500; z = 5.8506 }, (* C2 *) { x = 6.9254; y = -6.3614; z = 7.4926 }, (* C4 *) { x = 7.1046; y = -7.2543; z = 6.3718 }, (* C5 *) { x = 7.0391; y = -6.7951; z = 5.1106 }, (* C6 *) (C ( { x = 6.9614; y = -6.6648; z = 8.7815 }, (* N4 *) { x = 6.4083; y = -3.3696; z = 5.6340 }, (* O2 *) { x = 7.1329; y = -7.6280; z = 9.0324 }, (* H41 *) { x = 6.8204; y = -5.9469; z = 9.4777 }, (* H42 *) { x = 7.2954; y = -8.3135; z = 6.5440 }, (* H5 *) { x = 7.1753; y = -7.4798; z = 4.2735 }) (* H6 *) ) ) let rC07 = N( { a=0.0033; b=0.2720; c= -0.9623; (* dgf_base_tfo *) d=0.3013; e= -0.9179; f= -0.2584; g= -0.9535; h= -0.2891; i= -0.0850; tx=43.0403; ty=13.7233; tz=34.5710 }, { a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *) d=0.0302; e= -0.7316; f=0.6811; g=0.3938; h= -0.6176; i= -0.6808; tx= -48.4330; ty=26.3254; tz=13.6383 }, { a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *) d=0.7581; e=0.4893; f=0.4311; g=0.6345; h= -0.4010; i= -0.6607; tx= -31.9784; ty= -13.4285; tz=44.9650 }, { a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *) d= -0.6890; e=0.5694; f= -0.4484; g=0.3694; h= -0.2564; i= -0.8932; tx=12.1105; ty=30.8774; tz=46.0946 }, { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P *) { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P *) { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P *) { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5' *) { x = 30.8152; y = 11.1619; z = 46.2003 }, (* C5' *) { x = 30.4519; y = 10.9454; z = 45.1957 }, (* H5' *) { x = 31.0379; y = 12.2016; z = 46.4400 }, (* H5'' *) { x = 29.7081; y = 10.7448; z = 47.1428 }, (* C4' *) { x = 28.8710; y = 11.4416; z = 47.0982 }, (* H4' *) { x = 29.2550; y = 9.4394; z = 46.8162 }, (* O4' *) { x = 29.3907; y = 8.5625; z = 47.9460 }, (* C1' *) { x = 28.4416; y = 8.5669; z = 48.4819 }, (* H1' *) { x = 30.4468; y = 9.2031; z = 48.7952 }, (* C2' *) { x = 31.4222; y = 8.9651; z = 48.3709 }, (* H2'' *) { x = 30.3701; y = 8.9157; z = 50.1624 }, (* O2' *) { x = 30.0652; y = 8.0304; z = 50.3740 }, (* H2' *) { x = 30.1622; y = 10.6879; z = 48.6120 }, (* C3' *) { x = 31.0952; y = 11.2399; z = 48.7254 }, (* H3' *) { x = 29.1076; y = 11.1535; z = 49.4702 }, (* O3' *) { x = 29.7883; y = 7.2209; z = 47.5235 }, (* N1 *) { x = 29.1825; y = 5.0438; z = 46.8275 }, (* N3 *) { x = 28.8008; y = 6.2912; z = 47.2263 }, (* C2 *) { x = 30.4888; y = 4.6890; z = 46.7186 }, (* C4 *) { x = 31.5034; y = 5.6405; z = 47.0249 }, (* C5 *) { x = 31.1091; y = 6.8691; z = 47.4156 }, (* C6 *) (C ( { x = 30.8109; y = 3.4584; z = 46.3336 }, (* N4 *) { x = 27.6171; y = 6.5989; z = 47.3189 }, (* O2 *) { x = 31.7923; y = 3.2301; z = 46.2638 }, (* H41 *) { x = 30.0880; y = 2.7857; z = 46.1215 }, (* H42 *) { x = 32.5542; y = 5.3634; z = 46.9395 }, (* H5 *) { x = 31.8523; y = 7.6279; z = 47.6603 }) (* H6 *) ) ) let rC08 = N( { a=0.0797; b= -0.6026; c= -0.7941; (* dgf_base_tfo *) d=0.7939; e=0.5201; f= -0.3150; g=0.6028; h= -0.6054; i=0.5198; tx= -36.8341; ty=41.5293; tz=1.6628 }, { a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *) d=0.0302; e= -0.7316; f=0.6811; g=0.3938; h= -0.6176; i= -0.6808; tx= -48.4330; ty=26.3254; tz=13.6383 }, { a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *) d=0.7581; e=0.4893; f=0.4311; g=0.6345; h= -0.4010; i= -0.6607; tx= -31.9784; ty= -13.4285; tz=44.9650 }, { a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *) d= -0.6890; e=0.5694; f= -0.4484; g=0.3694; h= -0.2564; i= -0.8932; tx=12.1105; ty=30.8774; tz=46.0946 }, { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P *) { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P *) { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P *) { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5' *) { x = 31.8779; y = 9.9369; z = 47.8760 }, (* C5' *) { x = 31.3239; y = 10.6931; z = 48.4322 }, (* H5' *) { x = 32.8647; y = 9.6624; z = 48.2489 }, (* H5'' *) { x = 31.0429; y = 8.6773; z = 47.9401 }, (* C4' *) { x = 31.0779; y = 8.2331; z = 48.9349 }, (* H4' *) { x = 29.6956; y = 8.9669; z = 47.5983 }, (* O4' *) { x = 29.2784; y = 8.1700; z = 46.4782 }, (* C1' *) { x = 28.8006; y = 7.2731; z = 46.8722 }, (* H1' *) { x = 30.5544; y = 7.7940; z = 45.7875 }, (* C2' *) { x = 30.8837; y = 8.6410; z = 45.1856 }, (* H2'' *) { x = 30.5100; y = 6.6007; z = 45.0582 }, (* O2' *) { x = 29.6694; y = 6.4168; z = 44.6326 }, (* H2' *) { x = 31.5146; y = 7.5954; z = 46.9527 }, (* C3' *) { x = 32.5255; y = 7.8261; z = 46.6166 }, (* H3' *) { x = 31.3876; y = 6.2951; z = 47.5516 }, (* O3' *) { x = 28.3976; y = 8.9302; z = 45.5933 }, (* N1 *) { x = 26.2155; y = 9.6135; z = 44.9910 }, (* N3 *) { x = 27.0281; y = 8.8961; z = 45.8192 }, (* C2 *) { x = 26.7044; y = 10.3489; z = 43.9595 }, (* C4 *) { x = 28.1088; y = 10.3837; z = 43.7247 }, (* C5 *) { x = 28.8978; y = 9.6708; z = 44.5535 }, (* C6 *) (C ( { x = 25.8715; y = 11.0249; z = 43.1749 }, (* N4 *) { x = 26.5733; y = 8.2371; z = 46.7484 }, (* O2 *) { x = 26.2707; y = 11.5609; z = 42.4177 }, (* H41 *) { x = 24.8760; y = 10.9939; z = 43.3427 }, (* H42 *) { x = 28.5089; y = 10.9722; z = 42.8990 }, (* H5 *) { x = 29.9782; y = 9.6687; z = 44.4097 }) (* H6 *) ) ) let rC09 = N( { a=0.8727; b=0.4760; c= -0.1091; (* dgf_base_tfo *) d= -0.4188; e=0.6148; f= -0.6682; g= -0.2510; h=0.6289; i=0.7359; tx= -8.1687; ty= -52.0761; tz= -25.0726 }, { a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *) d=0.0302; e= -0.7316; f=0.6811; g=0.3938; h= -0.6176; i= -0.6808; tx= -48.4330; ty=26.3254; tz=13.6383 }, { a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *) d=0.7581; e=0.4893; f=0.4311; g=0.6345; h= -0.4010; i= -0.6607; tx= -31.9784; ty= -13.4285; tz=44.9650 }, { a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *) d= -0.6890; e=0.5694; f= -0.4484; g=0.3694; h= -0.2564; i= -0.8932; tx=12.1105; ty=30.8774; tz=46.0946 }, { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P *) { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P *) { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P *) { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5' *) { x = 30.8152; y = 11.1619; z = 46.2003 }, (* C5' *) { x = 30.4519; y = 10.9454; z = 45.1957 }, (* H5' *) { x = 31.0379; y = 12.2016; z = 46.4400 }, (* H5'' *) { x = 29.7081; y = 10.7448; z = 47.1428 }, (* C4' *) { x = 29.4506; y = 9.6945; z = 47.0059 }, (* H4' *) { x = 30.1045; y = 10.9634; z = 48.4885 }, (* O4' *) { x = 29.1794; y = 11.8418; z = 49.1490 }, (* C1' *) { x = 28.4388; y = 11.2210; z = 49.6533 }, (* H1' *) { x = 28.5211; y = 12.6008; z = 48.0367 }, (* C2' *) { x = 29.1947; y = 13.3949; z = 47.7147 }, (* H2'' *) { x = 27.2316; y = 13.0683; z = 48.3134 }, (* O2' *) { x = 27.0851; y = 13.3391; z = 49.2227 }, (* H2' *) { x = 28.4131; y = 11.5507; z = 46.9391 }, (* C3' *) { x = 28.4451; y = 12.0512; z = 45.9713 }, (* H3' *) { x = 27.2707; y = 10.6955; z = 47.1097 }, (* O3' *) { x = 29.8751; y = 12.7405; z = 50.0682 }, (* N1 *) { x = 30.7172; y = 13.1841; z = 52.2328 }, (* N3 *) { x = 30.0617; y = 12.3404; z = 51.3847 }, (* C2 *) { x = 31.1834; y = 14.3941; z = 51.8297 }, (* C4 *) { x = 30.9913; y = 14.8074; z = 50.4803 }, (* C5 *) { x = 30.3434; y = 13.9610; z = 49.6548 }, (* C6 *) (C ( { x = 31.8090; y = 15.1847; z = 52.6957 }, (* N4 *) { x = 29.6470; y = 11.2494; z = 51.7616 }, (* O2 *) { x = 32.1422; y = 16.0774; z = 52.3606 }, (* H41 *) { x = 31.9392; y = 14.8893; z = 53.6527 }, (* H42 *) { x = 31.3632; y = 15.7771; z = 50.1491 }, (* H5 *) { x = 30.1742; y = 14.2374; z = 48.6141 }) (* H6 *) ) ) let rC10 = N( { a=0.1549; b=0.8710; c= -0.4663; (* dgf_base_tfo *) d=0.6768; e= -0.4374; f= -0.5921; g= -0.7197; h= -0.2239; i= -0.6572; tx=25.2447; ty= -14.1920; tz=50.3201 }, { a=0.9187; b=0.2887; c=0.2694; (* P_O3'_275_tfo *) d=0.0302; e= -0.7316; f=0.6811; g=0.3938; h= -0.6176; i= -0.6808; tx= -48.4330; ty=26.3254; tz=13.6383 }, { a= -0.1504; b=0.7744; c= -0.6145; (* P_O3'_180_tfo *) d=0.7581; e=0.4893; f=0.4311; g=0.6345; h= -0.4010; i= -0.6607; tx= -31.9784; ty= -13.4285; tz=44.9650 }, { a= -0.6236; b= -0.7810; c= -0.0337; (* P_O3'_60_tfo *) d= -0.6890; e=0.5694; f= -0.4484; g=0.3694; h= -0.2564; i= -0.8932; tx=12.1105; ty=30.8774; tz=46.0946 }, { x = 33.3400; y = 11.0980; z = 46.1750 }, (* P *) { x = 34.5130; y = 10.2320; z = 46.4660 }, (* O1P *) { x = 33.4130; y = 12.3960; z = 46.9340 }, (* O2P *) { x = 31.9810; y = 10.3390; z = 46.4820 }, (* O5' *) { x = 31.8779; y = 9.9369; z = 47.8760 }, (* C5' *) { x = 31.3239; y = 10.6931; z = 48.4322 }, (* H5' *) { x = 32.8647; y = 9.6624; z = 48.2489 }, (* H5'' *) { x = 31.0429; y = 8.6773; z = 47.9401 }, (* C4' *) { x = 30.0440; y = 8.8473; z = 47.5383 }, (* H4' *) { x = 31.6749; y = 7.6351; z = 47.2119 }, (* O4' *) { x = 31.9159; y = 6.5022; z = 48.0616 }, (* C1' *) { x = 31.0691; y = 5.8243; z = 47.9544 }, (* H1' *) { x = 31.9300; y = 7.0685; z = 49.4493 }, (* C2' *) { x = 32.9024; y = 7.5288; z = 49.6245 }, (* H2'' *) { x = 31.5672; y = 6.1750; z = 50.4632 }, (* O2' *) { x = 31.8416; y = 5.2663; z = 50.3200 }, (* H2' *) { x = 30.8618; y = 8.1514; z = 49.3749 }, (* C3' *) { x = 31.1122; y = 8.9396; z = 50.0850 }, (* H3' *) { x = 29.5351; y = 7.6245; z = 49.5409 }, (* O3' *) { x = 33.1890; y = 5.8629; z = 47.7343 }, (* N1 *) { x = 34.4004; y = 4.2636; z = 46.4828 }, (* N3 *) { x = 33.2062; y = 4.8497; z = 46.7851 }, (* C2 *) { x = 35.5600; y = 4.6374; z = 47.0822 }, (* C4 *) { x = 35.5444; y = 5.6751; z = 48.0577 }, (* C5 *) { x = 34.3565; y = 6.2450; z = 48.3432 }, (* C6 *) (C ( { x = 36.6977; y = 4.0305; z = 46.7598 }, (* N4 *) { x = 32.1661; y = 4.5034; z = 46.2348 }, (* O2 *) { x = 37.5405; y = 4.3347; z = 47.2259 }, (* H41 *) { x = 36.7033; y = 3.2923; z = 46.0706 }, (* H42 *) { x = 36.4713; y = 5.9811; z = 48.5428 }, (* H5 *) { x = 34.2986; y = 7.0426; z = 49.0839 }) (* H6 *) ) ) let rCs = [rC01;rC02;rC03;rC04;rC05;rC06;rC07;rC08;rC09;rC10] let rG = N( { a= -0.0018; b= -0.8207; c=0.5714; (* dgf_base_tfo *) d=0.2679; e= -0.5509; f= -0.7904; g=0.9634; h=0.1517; i=0.2209; tx=0.0073; ty=8.4030; tz=0.6232 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 5.4550; y = 8.2120; z = -2.8810 }, (* C5' *) { x = 5.4546; y = 8.8508; z = -1.9978 }, (* H5' *) { x = 5.7588; y = 8.6625; z = -3.8259 }, (* H5'' *) { x = 6.4970; y = 7.1480; z = -2.5980 }, (* C4' *) { x = 7.4896; y = 7.5919; z = -2.5214 }, (* H4' *) { x = 6.1630; y = 6.4860; z = -1.3440 }, (* O4' *) { x = 6.5400; y = 5.1200; z = -1.4190 }, (* C1' *) { x = 7.2763; y = 4.9681; z = -0.6297 }, (* H1' *) { x = 7.1940; y = 4.8830; z = -2.7770 }, (* C2' *) { x = 6.8667; y = 3.9183; z = -3.1647 }, (* H2'' *) { x = 8.5860; y = 5.0910; z = -2.6140 }, (* O2' *) { x = 8.9510; y = 4.7626; z = -1.7890 }, (* H2' *) { x = 6.5720; y = 6.0040; z = -3.6090 }, (* C3' *) { x = 5.5636; y = 5.7066; z = -3.8966 }, (* H3' *) { x = 7.3801; y = 6.3562; z = -4.7350 }, (* O3' *) { x = 4.7150; y = 0.4910; z = -0.1360 }, (* N1 *) { x = 6.3490; y = 2.1730; z = -0.6020 }, (* N3 *) { x = 5.9530; y = 0.9650; z = -0.2670 }, (* C2 *) { x = 5.2900; y = 2.9790; z = -0.8260 }, (* C4 *) { x = 3.9720; y = 2.6390; z = -0.7330 }, (* C5 *) { x = 3.6770; y = 1.3160; z = -0.3660 }, (* C6 *) (G ( { x = 6.8426; y = 0.0056; z = -0.0019 }, (* N2 *) { x = 3.1660; y = 3.7290; z = -1.0360 }, (* N7 *) { x = 5.3170; y = 4.2990; z = -1.1930 }, (* N9 *) { x = 4.0100; y = 4.6780; z = -1.2990 }, (* C8 *) { x = 2.4280; y = 0.8450; z = -0.2360 }, (* O6 *) { x = 4.6151; y = -0.4677; z = 0.1305 }, (* H1 *) { x = 6.6463; y = -0.9463; z = 0.2729 }, (* H21 *) { x = 7.8170; y = 0.2642; z = -0.0640 }, (* H22 *) { x = 3.4421; y = 5.5744; z = -1.5482 }) (* H8 *) ) ) let rG01 = N( { a= -0.0043; b= -0.8175; c=0.5759; (* dgf_base_tfo *) d=0.2617; e= -0.5567; f= -0.7884; g=0.9651; h=0.1473; i=0.2164; tx=0.0359; ty=8.3929; tz=0.5532 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5' *) { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5' *) { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *) { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4' *) { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4' *) { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4' *) { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1' *) { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1' *) { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2' *) { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *) { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2' *) { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2' *) { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3' *) { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3' *) { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3' *) { x = 4.7442; y = 0.4514; z = -0.1390 }, (* N1 *) { x = 6.3687; y = 2.1459; z = -0.5926 }, (* N3 *) { x = 5.9795; y = 0.9335; z = -0.2657 }, (* C2 *) { x = 5.3052; y = 2.9471; z = -0.8125 }, (* C4 *) { x = 3.9891; y = 2.5987; z = -0.7230 }, (* C5 *) { x = 3.7016; y = 1.2717; z = -0.3647 }, (* C6 *) (G ( { x = 6.8745; y = -0.0224; z = -0.0058 }, (* N2 *) { x = 3.1770; y = 3.6859; z = -1.0198 }, (* N7 *) { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9 *) { x = 4.0156; y = 4.6415; z = -1.2759 }, (* C8 *) { x = 2.4553; y = 0.7925; z = -0.2390 }, (* O6 *) { x = 4.6497; y = -0.5095; z = 0.1212 }, (* H1 *) { x = 6.6836; y = -0.9771; z = 0.2627 }, (* H21 *) { x = 7.8474; y = 0.2424; z = -0.0653 }, (* H22 *) { x = 3.4426; y = 5.5361; z = -1.5199 }) (* H8 *) ) ) let rG02 = N( { a=0.5566; b=0.0449; c=0.8296; (* dgf_base_tfo *) d=0.5125; e=0.7673; f= -0.3854; g= -0.6538; h=0.6397; i=0.4041; tx= -9.1161; ty= -3.7679; tz= -2.9968 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5' *) { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5' *) { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *) { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4' *) { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4' *) { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4' *) { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1' *) { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1' *) { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2' *) { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *) { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2' *) { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2' *) { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3' *) { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3' *) { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3' *) { x = 10.3245; y = 8.5459; z = 1.5467 }, (* N1 *) { x = 9.8051; y = 6.9432; z = -0.1497 }, (* N3 *) { x = 10.5175; y = 7.4328; z = 0.8408 }, (* C2 *) { x = 8.7523; y = 7.7422; z = -0.4228 }, (* C4 *) { x = 8.4257; y = 8.9060; z = 0.2099 }, (* C5 *) { x = 9.2665; y = 9.3242; z = 1.2540 }, (* C6 *) (G ( { x = 11.6077; y = 6.7966; z = 1.2752 }, (* N2 *) { x = 7.2750; y = 9.4537; z = -0.3428 }, (* N7 *) { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9 *) { x = 6.9479; y = 8.6157; z = -1.2771 }, (* C8 *) { x = 9.0664; y = 10.4462; z = 1.9610 }, (* O6 *) { x = 10.9838; y = 8.7524; z = 2.2697 }, (* H1 *) { x = 12.2274; y = 7.0896; z = 2.0170 }, (* H21 *) { x = 11.8502; y = 5.9398; z = 0.7984 }, (* H22 *) { x = 6.0430; y = 8.9853; z = -1.7594 }) (* H8 *) ) ) let rG03 = N( { a= -0.5021; b=0.0731; c=0.8617; (* dgf_base_tfo *) d= -0.8112; e=0.3054; f= -0.4986; g= -0.2996; h= -0.9494; i= -0.0940; tx=6.4273; ty= -5.1944; tz= -3.7807 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5' *) { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5' *) { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *) { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4' *) { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4' *) { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4' *) { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1' *) { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1' *) { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2' *) { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *) { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2' *) { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2' *) { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3' *) { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3' *) { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3' *) { x = 9.6740; y = 4.7656; z = -7.6614 }, (* N1 *) { x = 9.0739; y = 4.3013; z = -5.3941 }, (* N3 *) { x = 9.8416; y = 4.2192; z = -6.4581 }, (* C2 *) { x = 7.9885; y = 5.0632; z = -5.6446 }, (* C4 *) { x = 7.6822; y = 5.6856; z = -6.8194 }, (* C5 *) { x = 8.5831; y = 5.5215; z = -7.8840 }, (* C6 *) (G ( { x = 10.9733; y = 3.5117; z = -6.4286 }, (* N2 *) { x = 6.4857; y = 6.3816; z = -6.7035 }, (* N7 *) { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9 *) { x = 6.1133; y = 6.1613; z = -5.4808 }, (* C8 *) { x = 8.4084; y = 6.0747; z = -9.0933 }, (* O6 *) { x = 10.3759; y = 4.5855; z = -8.3504 }, (* H1 *) { x = 11.6254; y = 3.3761; z = -7.1879 }, (* H21 *) { x = 11.1917; y = 3.0460; z = -5.5593 }, (* H22 *) { x = 5.1705; y = 6.6830; z = -5.3167 }) (* H8 *) ) ) let rG04 = N( { a= -0.5426; b= -0.8175; c=0.1929; (* dgf_base_tfo *) d=0.8304; e= -0.5567; f= -0.0237; g=0.1267; h=0.1473; i=0.9809; tx= -0.5075; ty=8.3929; tz=0.2229 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 5.4352; y = 8.2183; z = -2.7757 }, (* C5' *) { x = 5.3830; y = 8.7883; z = -1.8481 }, (* H5' *) { x = 5.7729; y = 8.7436; z = -3.6691 }, (* H5'' *) { x = 6.4830; y = 7.1518; z = -2.5252 }, (* C4' *) { x = 7.4749; y = 7.5972; z = -2.4482 }, (* H4' *) { x = 6.1626; y = 6.4620; z = -1.2827 }, (* O4' *) { x = 6.5431; y = 5.0992; z = -1.3905 }, (* C1' *) { x = 7.2871; y = 4.9328; z = -0.6114 }, (* H1' *) { x = 7.1852; y = 4.8935; z = -2.7592 }, (* C2' *) { x = 6.8573; y = 3.9363; z = -3.1645 }, (* H2'' *) { x = 8.5780; y = 5.1025; z = -2.6046 }, (* O2' *) { x = 8.9516; y = 4.7577; z = -1.7902 }, (* H2' *) { x = 6.5522; y = 6.0300; z = -3.5612 }, (* C3' *) { x = 5.5420; y = 5.7356; z = -3.8459 }, (* H3' *) { x = 7.3487; y = 6.4089; z = -4.6867 }, (* O3' *) { x = 3.6343; y = 2.6680; z = 2.0783 }, (* N1 *) { x = 5.4505; y = 3.9805; z = 1.2446 }, (* N3 *) { x = 4.7540; y = 3.3816; z = 2.1851 }, (* C2 *) { x = 4.8805; y = 3.7951; z = 0.0354 }, (* C4 *) { x = 3.7416; y = 3.0925; z = -0.2305 }, (* C5 *) { x = 3.0873; y = 2.4980; z = 0.8606 }, (* C6 *) (G ( { x = 5.1433; y = 3.4373; z = 3.4609 }, (* N2 *) { x = 3.4605; y = 3.1184; z = -1.5906 }, (* N7 *) { x = 5.3247; y = 4.2695; z = -1.1710 }, (* N9 *) { x = 4.4244; y = 3.8244; z = -2.0953 }, (* C8 *) { x = 1.9600; y = 1.7805; z = 0.7462 }, (* O6 *) { x = 3.2489; y = 2.2879; z = 2.9191 }, (* H1 *) { x = 4.6785; y = 3.0243; z = 4.2568 }, (* H21 *) { x = 5.9823; y = 3.9654; z = 3.6539 }, (* H22 *) { x = 4.2675; y = 3.8876; z = -3.1721 }) (* H8 *) ) ) let rG05 = N( { a= -0.5891; b=0.0449; c=0.8068; (* dgf_base_tfo *) d=0.5375; e=0.7673; f=0.3498; g= -0.6034; h=0.6397; i= -0.4762; tx= -0.3019; ty= -3.7679; tz= -9.5913 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.5778; y = 6.6594; z = -4.0364 }, (* C5' *) { x = 4.9220; y = 7.1963; z = -4.9204 }, (* H5' *) { x = 3.7996; y = 5.9091; z = -4.1764 }, (* H5'' *) { x = 5.7873; y = 5.8869; z = -3.5482 }, (* C4' *) { x = 6.0405; y = 5.0875; z = -4.2446 }, (* H4' *) { x = 6.9135; y = 6.8036; z = -3.4310 }, (* O4' *) { x = 7.7293; y = 6.4084; z = -2.3392 }, (* C1' *) { x = 8.7078; y = 6.1815; z = -2.7624 }, (* H1' *) { x = 7.1305; y = 5.1418; z = -1.7347 }, (* C2' *) { x = 7.2040; y = 5.1982; z = -0.6486 }, (* H2'' *) { x = 7.7417; y = 4.0392; z = -2.3813 }, (* O2' *) { x = 8.6785; y = 4.1443; z = -2.5630 }, (* H2' *) { x = 5.6666; y = 5.2728; z = -2.1536 }, (* C3' *) { x = 5.1747; y = 5.9805; z = -1.4863 }, (* H3' *) { x = 4.9997; y = 4.0086; z = -2.1973 }, (* O3' *) { x = 10.2594; y = 10.6774; z = -1.0056 }, (* N1 *) { x = 9.7528; y = 8.7080; z = -2.2631 }, (* N3 *) { x = 10.4471; y = 9.7876; z = -1.9791 }, (* C2 *) { x = 8.7271; y = 8.5575; z = -1.3991 }, (* C4 *) { x = 8.4100; y = 9.3803; z = -0.3580 }, (* C5 *) { x = 9.2294; y = 10.5030; z = -0.1574 }, (* C6 *) (G ( { x = 11.5110; y = 10.1256; z = -2.7114 }, (* N2 *) { x = 7.2891; y = 8.9068; z = 0.3121 }, (* N7 *) { x = 7.7962; y = 7.5519; z = -1.3859 }, (* N9 *) { x = 6.9702; y = 7.8292; z = -0.3353 }, (* C8 *) { x = 9.0349; y = 11.3951; z = 0.8250 }, (* O6 *) { x = 10.9013; y = 11.4422; z = -0.9512 }, (* H1 *) { x = 12.1031; y = 10.9341; z = -2.5861 }, (* H21 *) { x = 11.7369; y = 9.5180; z = -3.4859 }, (* H22 *) { x = 6.0888; y = 7.3990; z = 0.1403 }) (* H8 *) ) ) let rG06 = N( { a= -0.9815; b=0.0731; c= -0.1772; (* dgf_base_tfo *) d=0.1912; e=0.3054; f= -0.9328; g= -0.0141; h= -0.9494; i= -0.3137; tx=5.7506; ty= -5.1944; tz=4.7470 }, { a= -0.8143; b= -0.5091; c= -0.2788; (* P_O3'_275_tfo *) d= -0.0433; e= -0.4257; f=0.9038; g= -0.5788; h=0.7480; i=0.3246; tx=1.5227; ty=6.9114; tz= -7.0765 }, { a=0.3822; b= -0.7477; c=0.5430; (* P_O3'_180_tfo *) d=0.4552; e=0.6637; f=0.5935; g= -0.8042; h=0.0203; i=0.5941; tx= -6.9472; ty= -4.1186; tz= -5.9108 }, { a=0.5640; b=0.8007; c= -0.2022; (* P_O3'_60_tfo *) d= -0.8247; e=0.5587; f= -0.0878; g=0.0426; h=0.2162; i=0.9754; tx=6.2694; ty= -7.0540; tz=3.3316 }, { x = 2.8930; y = 8.5380; z = -3.3280 }, (* P *) { x = 1.6980; y = 7.6960; z = -3.5570 }, (* O1P *) { x = 3.2260; y = 9.5010; z = -4.4020 }, (* O2P *) { x = 4.1590; y = 7.6040; z = -3.0340 }, (* O5' *) { x = 4.1214; y = 6.7116; z = -1.9049 }, (* C5' *) { x = 3.3465; y = 5.9610; z = -2.0607 }, (* H5' *) { x = 4.0789; y = 7.2928; z = -0.9837 }, (* H5'' *) { x = 5.4170; y = 5.9293; z = -1.8186 }, (* C4' *) { x = 5.4506; y = 5.3400; z = -0.9023 }, (* H4' *) { x = 5.5067; y = 5.0417; z = -2.9703 }, (* O4' *) { x = 6.8650; y = 4.9152; z = -3.3612 }, (* C1' *) { x = 7.1090; y = 3.8577; z = -3.2603 }, (* H1' *) { x = 7.7152; y = 5.7282; z = -2.3894 }, (* C2' *) { x = 8.5029; y = 6.2356; z = -2.9463 }, (* H2'' *) { x = 8.1036; y = 4.8568; z = -1.3419 }, (* O2' *) { x = 8.3270; y = 3.9651; z = -1.6184 }, (* H2' *) { x = 6.7003; y = 6.7565; z = -1.8911 }, (* C3' *) { x = 6.5898; y = 7.5329; z = -2.6482 }, (* H3' *) { x = 7.0505; y = 7.2878; z = -0.6105 }, (* O3' *) { x = 6.6624; y = 3.5061; z = -8.2986 }, (* N1 *) { x = 6.5810; y = 3.2570; z = -5.9221 }, (* N3 *) { x = 6.5151; y = 2.8263; z = -7.1625 }, (* C2 *) { x = 6.8364; y = 4.5817; z = -5.8882 }, (* C4 *) { x = 7.0116; y = 5.4064; z = -6.9609 }, (* C5 *) { x = 6.9173; y = 4.8260; z = -8.2361 }, (* C6 *) (G ( { x = 6.2717; y = 1.5402; z = -7.4250 }, (* N2 *) { x = 7.2573; y = 6.7070; z = -6.5394 }, (* N7 *) { x = 6.9740; y = 5.3703; z = -4.7760 }, (* N9 *) { x = 7.2238; y = 6.6275; z = -5.2453 }, (* C8 *) { x = 7.0668; y = 5.5163; z = -9.3763 }, (* O6 *) { x = 6.5754; y = 2.9964; z = -9.1545 }, (* H1 *) { x = 6.1908; y = 1.1105; z = -8.3354 }, (* H21 *) { x = 6.1346; y = 0.9352; z = -6.6280 }, (* H22 *) { x = 7.4108; y = 7.6227; z = -4.8418 }) (* H8 *) ) ) let rG07 = N( { a=0.0894; b= -0.6059; c=0.7905; (* dgf_base_tfo *) d= -0.6810; e=0.5420; f=0.4924; g= -0.7268; h= -0.5824; i= -0.3642; tx=34.1424; ty=45.9610; tz= -11.8600 }, { a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *) d= -0.0427; e=0.2409; f= -0.9696; g=0.5010; h= -0.8345; i= -0.2294; tx=4.0167; ty=54.5377; tz=12.4779 }, { a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *) d= -0.2867; e= -0.7872; f= -0.5460; g=0.8834; h=0.0032; i= -0.4686; tx= -52.9020; ty=18.6313; tz= -0.6709 }, { a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *) d=0.9040; e= -0.4236; f= -0.0582; g= -0.1007; h= -0.0786; i= -0.9918; tx= -7.6624; ty= -25.2080; tz=49.5181 }, { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P *) { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P *) { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P *) { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5' *) { x = 33.8709; y = 0.7918; z = 47.2113 }, (* C5' *) { x = 34.1386; y = 0.5870; z = 46.1747 }, (* H5' *) { x = 34.0186; y = -0.0095; z = 47.9353 }, (* H5'' *) { x = 34.7297; y = 1.9687; z = 47.6685 }, (* C4' *) { x = 35.7723; y = 1.6845; z = 47.8113 }, (* H4' *) { x = 34.6455; y = 2.9768; z = 46.6660 }, (* O4' *) { x = 34.1690; y = 4.1829; z = 47.2627 }, (* C1' *) { x = 35.0437; y = 4.7633; z = 47.5560 }, (* H1' *) { x = 33.4145; y = 3.7532; z = 48.4954 }, (* C2' *) { x = 32.4340; y = 3.3797; z = 48.2001 }, (* H2'' *) { x = 33.3209; y = 4.6953; z = 49.5217 }, (* O2' *) { x = 33.2374; y = 5.6059; z = 49.2295 }, (* H2' *) { x = 34.2724; y = 2.5970; z = 48.9773 }, (* C3' *) { x = 33.6373; y = 1.8935; z = 49.5157 }, (* H3' *) { x = 35.3453; y = 3.1884; z = 49.7285 }, (* O3' *) { x = 34.0511; y = 7.8930; z = 43.7791 }, (* N1 *) { x = 34.9937; y = 6.3369; z = 45.3199 }, (* N3 *) { x = 35.0882; y = 7.3126; z = 44.4200 }, (* C2 *) { x = 33.7190; y = 5.9650; z = 45.5374 }, (* C4 *) { x = 32.5845; y = 6.4770; z = 44.9458 }, (* C5 *) { x = 32.7430; y = 7.5179; z = 43.9914 }, (* C6 *) (G ( { x = 36.3030; y = 7.7827; z = 44.1036 }, (* N2 *) { x = 31.4499; y = 5.8335; z = 45.4368 }, (* N7 *) { x = 33.2760; y = 4.9817; z = 46.4043 }, (* N9 *) { x = 31.9235; y = 4.9639; z = 46.2934 }, (* C8 *) { x = 31.8602; y = 8.1000; z = 43.3695 }, (* O6 *) { x = 34.2623; y = 8.6223; z = 43.1283 }, (* H1 *) { x = 36.5188; y = 8.5081; z = 43.4347 }, (* H21 *) { x = 37.0888; y = 7.3524; z = 44.5699 }, (* H22 *) { x = 31.0815; y = 4.4201; z = 46.7218 }) (* H8 *) ) ) let rG08 = N( { a=0.2224; b=0.6335; c=0.7411; (* dgf_base_tfo *) d= -0.3644; e= -0.6510; f=0.6659; g=0.9043; h= -0.4181; i=0.0861; tx= -47.6824; ty= -0.5823; tz= -31.7554 }, { a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *) d= -0.0427; e=0.2409; f= -0.9696; g=0.5010; h= -0.8345; i= -0.2294; tx=4.0167; ty=54.5377; tz=12.4779 }, { a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *) d= -0.2867; e= -0.7872; f= -0.5460; g=0.8834; h=0.0032; i= -0.4686; tx= -52.9020; ty=18.6313; tz= -0.6709 }, { a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *) d=0.9040; e= -0.4236; f= -0.0582; g= -0.1007; h= -0.0786; i= -0.9918; tx= -7.6624; ty= -25.2080; tz=49.5181 }, { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P *) { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P *) { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P *) { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5' *) { x = 32.5924; y = 2.3488; z = 48.2255 }, (* C5' *) { x = 33.3674; y = 2.1246; z = 48.9584 }, (* H5' *) { x = 31.5994; y = 2.5917; z = 48.6037 }, (* H5'' *) { x = 33.0722; y = 3.5577; z = 47.4258 }, (* C4' *) { x = 33.0310; y = 4.4778; z = 48.0089 }, (* H4' *) { x = 34.4173; y = 3.3055; z = 47.0316 }, (* O4' *) { x = 34.5056; y = 3.3910; z = 45.6094 }, (* C1' *) { x = 34.7881; y = 4.4152; z = 45.3663 }, (* H1' *) { x = 33.1122; y = 3.1198; z = 45.1010 }, (* C2' *) { x = 32.9230; y = 2.0469; z = 45.1369 }, (* H2'' *) { x = 32.7946; y = 3.6590; z = 43.8529 }, (* O2' *) { x = 33.5170; y = 3.6707; z = 43.2207 }, (* H2' *) { x = 32.2730; y = 3.8173; z = 46.1566 }, (* C3' *) { x = 31.3094; y = 3.3123; z = 46.2244 }, (* H3' *) { x = 32.2391; y = 5.2039; z = 45.7807 }, (* O3' *) { x = 39.3337; y = 2.7157; z = 44.1441 }, (* N1 *) { x = 37.4430; y = 3.8242; z = 45.0824 }, (* N3 *) { x = 38.7276; y = 3.7646; z = 44.7403 }, (* C2 *) { x = 36.7791; y = 2.6963; z = 44.7704 }, (* C4 *) { x = 37.2860; y = 1.5653; z = 44.1678 }, (* C5 *) { x = 38.6647; y = 1.5552; z = 43.8235 }, (* C6 *) (G ( { x = 39.5123; y = 4.8216; z = 44.9936 }, (* N2 *) { x = 36.2829; y = 0.6110; z = 44.0078 }, (* N7 *) { x = 35.4394; y = 2.4314; z = 44.9931 }, (* N9 *) { x = 35.2180; y = 1.1815; z = 44.5128 }, (* C8 *) { x = 39.2907; y = 0.6514; z = 43.2796 }, (* O6 *) { x = 40.3076; y = 2.8048; z = 43.9352 }, (* H1 *) { x = 40.4994; y = 4.9066; z = 44.7977 }, (* H21 *) { x = 39.0738; y = 5.6108; z = 45.4464 }, (* H22 *) { x = 34.3856; y = 0.4842; z = 44.4185 }) (* H8 *) ) ) let rG09 = N( { a= -0.9699; b= -0.1688; c= -0.1753; (* dgf_base_tfo *) d= -0.1050; e= -0.3598; f=0.9271; g= -0.2196; h=0.9176; i=0.3312; tx=45.6217; ty= -38.9484; tz= -12.3208 }, { a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *) d= -0.0427; e=0.2409; f= -0.9696; g=0.5010; h= -0.8345; i= -0.2294; tx=4.0167; ty=54.5377; tz=12.4779 }, { a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *) d= -0.2867; e= -0.7872; f= -0.5460; g=0.8834; h=0.0032; i= -0.4686; tx= -52.9020; ty=18.6313; tz= -0.6709 }, { a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *) d=0.9040; e= -0.4236; f= -0.0582; g= -0.1007; h= -0.0786; i= -0.9918; tx= -7.6624; ty= -25.2080; tz=49.5181 }, { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P *) { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P *) { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P *) { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5' *) { x = 33.8709; y = 0.7918; z = 47.2113 }, (* C5' *) { x = 34.1386; y = 0.5870; z = 46.1747 }, (* H5' *) { x = 34.0186; y = -0.0095; z = 47.9353 }, (* H5'' *) { x = 34.7297; y = 1.9687; z = 47.6685 }, (* C4' *) { x = 34.5880; y = 2.8482; z = 47.0404 }, (* H4' *) { x = 34.3575; y = 2.2770; z = 49.0081 }, (* O4' *) { x = 35.5157; y = 2.1993; z = 49.8389 }, (* C1' *) { x = 35.9424; y = 3.2010; z = 49.8893 }, (* H1' *) { x = 36.4701; y = 1.2820; z = 49.1169 }, (* C2' *) { x = 36.1545; y = 0.2498; z = 49.2683 }, (* H2'' *) { x = 37.8262; y = 1.4547; z = 49.4008 }, (* O2' *) { x = 38.0227; y = 1.6945; z = 50.3094 }, (* H2' *) { x = 36.2242; y = 1.6797; z = 47.6725 }, (* C3' *) { x = 36.4297; y = 0.8197; z = 47.0351 }, (* H3' *) { x = 37.0289; y = 2.8480; z = 47.4426 }, (* O3' *) { x = 34.3005; y = 3.5042; z = 54.6070 }, (* N1 *) { x = 34.7693; y = 3.7936; z = 52.2874 }, (* N3 *) { x = 34.4484; y = 4.2541; z = 53.4939 }, (* C2 *) { x = 34.9354; y = 2.4584; z = 52.2785 }, (* C4 *) { x = 34.8092; y = 1.5915; z = 53.3422 }, (* C5 *) { x = 34.4646; y = 2.1367; z = 54.6085 }, (* C6 *) (G ( { x = 34.2514; y = 5.5708; z = 53.6503 }, (* N2 *) { x = 35.0641; y = 0.2835; z = 52.9337 }, (* N7 *) { x = 35.2669; y = 1.6690; z = 51.1915 }, (* N9 *) { x = 35.3288; y = 0.3954; z = 51.6563 }, (* C8 *) { x = 34.3151; y = 1.5317; z = 55.6650 }, (* O6 *) { x = 34.0623; y = 3.9797; z = 55.4539 }, (* H1 *) { x = 33.9950; y = 6.0502; z = 54.5016 }, (* H21 *) { x = 34.3512; y = 6.1432; z = 52.8242 }, (* H22 *) { x = 35.5414; y = -0.6006; z = 51.2679 }) (* H8 *) ) ) let rG10 = N( { a= -0.0980; b= -0.9723; c=0.2122; (* dgf_base_tfo *) d= -0.9731; e=0.1383; f=0.1841; g= -0.2083; h= -0.1885; i= -0.9597; tx=17.8469; ty=38.8265; tz=37.0475 }, { a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *) d= -0.0427; e=0.2409; f= -0.9696; g=0.5010; h= -0.8345; i= -0.2294; tx=4.0167; ty=54.5377; tz=12.4779 }, { a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *) d= -0.2867; e= -0.7872; f= -0.5460; g=0.8834; h=0.0032; i= -0.4686; tx= -52.9020; ty=18.6313; tz= -0.6709 }, { a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *) d=0.9040; e= -0.4236; f= -0.0582; g= -0.1007; h= -0.0786; i= -0.9918; tx= -7.6624; ty= -25.2080; tz=49.5181 }, { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P *) { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P *) { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P *) { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5' *) { x = 32.5924; y = 2.3488; z = 48.2255 }, (* C5' *) { x = 33.3674; y = 2.1246; z = 48.9584 }, (* H5' *) { x = 31.5994; y = 2.5917; z = 48.6037 }, (* H5'' *) { x = 33.0722; y = 3.5577; z = 47.4258 }, (* C4' *) { x = 34.0333; y = 3.3761; z = 46.9447 }, (* H4' *) { x = 32.0890; y = 3.8338; z = 46.4332 }, (* O4' *) { x = 31.6377; y = 5.1787; z = 46.5914 }, (* C1' *) { x = 32.2499; y = 5.8016; z = 45.9392 }, (* H1' *) { x = 31.9167; y = 5.5319; z = 48.0305 }, (* C2' *) { x = 31.1507; y = 5.0820; z = 48.6621 }, (* H2'' *) { x = 32.0865; y = 6.8890; z = 48.3114 }, (* O2' *) { x = 31.5363; y = 7.4819; z = 47.7942 }, (* H2' *) { x = 33.2398; y = 4.8224; z = 48.2563 }, (* C3' *) { x = 33.3166; y = 4.5570; z = 49.3108 }, (* H3' *) { x = 34.2528; y = 5.7056; z = 47.7476 }, (* O3' *) { x = 28.2782; y = 6.3049; z = 42.9364 }, (* N1 *) { x = 30.4001; y = 5.8547; z = 43.9258 }, (* N3 *) { x = 29.6195; y = 6.1568; z = 42.8913 }, (* C2 *) { x = 29.7005; y = 5.7006; z = 45.0649 }, (* C4 *) { x = 28.3383; y = 5.8221; z = 45.2343 }, (* C5 *) { x = 27.5519; y = 6.1461; z = 44.0958 }, (* C6 *) (G ( { x = 30.1838; y = 6.3385; z = 41.6890 }, (* N2 *) { x = 27.9936; y = 5.5926; z = 46.5651 }, (* N7 *) { x = 30.2046; y = 5.3825; z = 46.3136 }, (* N9 *) { x = 29.1371; y = 5.3398; z = 47.1506 }, (* C8 *) { x = 26.3361; y = 6.3024; z = 44.0495 }, (* O6 *) { x = 27.8122; y = 6.5394; z = 42.0833 }, (* H1 *) { x = 29.7125; y = 6.5595; z = 40.8235 }, (* H21 *) { x = 31.1859; y = 6.2231; z = 41.6389 }, (* H22 *) { x = 28.9406; y = 5.1504; z = 48.2059 }) (* H8 *) ) ) let rGs = [rG01;rG02;rG03;rG04;rG05;rG06;rG07;rG08;rG09;rG10] let rU = N( { a= -0.0359; b= -0.8071; c=0.5894; (* dgf_base_tfo *) d= -0.2669; e=0.5761; f=0.7726; g= -0.9631; h= -0.1296; i= -0.2361; tx=0.1584; ty=8.3434; tz=0.5434 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 5.2430; y = -8.2420; z = 2.8260 }, (* C5' *) { x = 5.1974; y = -8.8497; z = 1.9223 }, (* H5' *) { x = 5.5548; y = -8.7348; z = 3.7469 }, (* H5'' *) { x = 6.3140; y = -7.2060; z = 2.5510 }, (* C4' *) { x = 7.2954; y = -7.6762; z = 2.4898 }, (* H4' *) { x = 6.0140; y = -6.5420; z = 1.2890 }, (* O4' *) { x = 6.4190; y = -5.1840; z = 1.3620 }, (* C1' *) { x = 7.1608; y = -5.0495; z = 0.5747 }, (* H1' *) { x = 7.0760; y = -4.9560; z = 2.7270 }, (* C2' *) { x = 6.7770; y = -3.9803; z = 3.1099 }, (* H2'' *) { x = 8.4500; y = -5.1930; z = 2.5810 }, (* O2' *) { x = 8.8309; y = -4.8755; z = 1.7590 }, (* H2' *) { x = 6.4060; y = -6.0590; z = 3.5580 }, (* C3' *) { x = 5.4021; y = -5.7313; z = 3.8281 }, (* H3' *) { x = 7.1570; y = -6.4240; z = 4.7070 }, (* O3' *) { x = 5.2170; y = -4.3260; z = 1.1690 }, (* N1 *) { x = 4.2960; y = -2.2560; z = 0.6290 }, (* N3 *) { x = 5.4330; y = -3.0200; z = 0.7990 }, (* C2 *) { x = 2.9930; y = -2.6780; z = 0.7940 }, (* C4 *) { x = 2.8670; y = -4.0630; z = 1.1830 }, (* C5 *) { x = 3.9570; y = -4.8300; z = 1.3550 }, (* C6 *) (U ( { x = 6.5470; y = -2.5560; z = 0.6290 }, (* O2 *) { x = 2.0540; y = -1.9000; z = 0.6130 }, (* O4 *) { x = 4.4300; y = -1.3020; z = 0.3600 }, (* H3 *) { x = 1.9590; y = -4.4570; z = 1.3250 }, (* H5 *) { x = 3.8460; y = -5.7860; z = 1.6240 }) (* H6 *) ) ) let rU01 = N( { a= -0.0137; b= -0.8012; c=0.5983; (* dgf_base_tfo *) d= -0.2523; e=0.5817; f=0.7733; g= -0.9675; h= -0.1404; i= -0.2101; tx=0.2031; ty=8.3874; tz=0.4228 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5' *) { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5' *) { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *) { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4' *) { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4' *) { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4' *) { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1' *) { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1' *) { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2' *) { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *) { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2' *) { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2' *) { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3' *) { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3' *) { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3' *) { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1 *) { x = 4.3777; y = -2.2062; z = 0.7229 }, (* N3 *) { x = 5.5069; y = -2.9779; z = 0.9088 }, (* C2 *) { x = 3.0693; y = -2.6246; z = 0.8500 }, (* C4 *) { x = 2.9279; y = -4.0146; z = 1.2149 }, (* C5 *) { x = 4.0101; y = -4.7892; z = 1.4017 }, (* C6 *) (U ( { x = 6.6267; y = -2.5166; z = 0.7728 }, (* O2 *) { x = 2.1383; y = -1.8396; z = 0.6581 }, (* O4 *) { x = 4.5223; y = -1.2489; z = 0.4716 }, (* H3 *) { x = 2.0151; y = -4.4065; z = 1.3290 }, (* H5 *) { x = 3.8886; y = -5.7486; z = 1.6535 }) (* H6 *) ) ) let rU02 = N( { a=0.5141; b=0.0246; c=0.8574; (* dgf_base_tfo *) d= -0.5547; e= -0.7529; f=0.3542; g=0.6542; h= -0.6577; i= -0.3734; tx= -9.1111; ty= -3.4598; tz= -3.2939 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5' *) { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5' *) { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *) { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4' *) { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4' *) { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4' *) { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1' *) { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1' *) { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2' *) { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *) { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2' *) { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2' *) { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3' *) { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3' *) { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3' *) { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1 *) { x = 8.6945; y = -8.7046; z = -0.2857 }, (* N3 *) { x = 8.6943; y = -7.6514; z = 0.6066 }, (* C2 *) { x = 7.7426; y = -9.6987; z = -0.3801 }, (* C4 *) { x = 6.6642; y = -9.5742; z = 0.5722 }, (* C5 *) { x = 6.6391; y = -8.5592; z = 1.4526 }, (* C6 *) (U ( { x = 9.5840; y = -6.8186; z = 0.6136 }, (* O2 *) { x = 7.8505; y = -10.5925; z = -1.2223 }, (* O4 *) { x = 9.4601; y = -8.7514; z = -0.9277 }, (* H3 *) { x = 5.9281; y = -10.2509; z = 0.5782 }, (* H5 *) { x = 5.8831; y = -8.4931; z = 2.1028 }) (* H6 *) ) ) let rU03 = N( { a= -0.4993; b=0.0476; c=0.8651; (* dgf_base_tfo *) d=0.8078; e= -0.3353; f=0.4847; g=0.3132; h=0.9409; i=0.1290; tx=6.2989; ty= -5.2303; tz= -3.8577 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5' *) { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5' *) { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *) { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4' *) { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4' *) { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4' *) { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1' *) { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1' *) { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2' *) { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *) { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2' *) { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2' *) { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3' *) { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3' *) { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3' *) { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1 *) { x = 7.9218; y = -5.5700; z = 6.8877 }, (* N3 *) { x = 7.8908; y = -5.0886; z = 5.5944 }, (* C2 *) { x = 6.9789; y = -6.3827; z = 7.4823 }, (* C4 *) { x = 5.8742; y = -6.7319; z = 6.6202 }, (* C5 *) { x = 5.8182; y = -6.2769; z = 5.3570 }, (* C6 *) (U ( { x = 8.7747; y = -4.3728; z = 5.1568 }, (* O2 *) { x = 7.1154; y = -6.7509; z = 8.6509 }, (* O4 *) { x = 8.7055; y = -5.3037; z = 7.4491 }, (* H3 *) { x = 5.1416; y = -7.3178; z = 6.9665 }, (* H5 *) { x = 5.0441; y = -6.5310; z = 4.7784 }) (* H6 *) ) ) let rU04 = N( { a= -0.5669; b= -0.8012; c=0.1918; (* dgf_base_tfo *) d= -0.8129; e=0.5817; f=0.0273; g= -0.1334; h= -0.1404; i= -0.9811; tx= -0.3279; ty=8.3874; tz=0.3355 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 5.2416; y = -8.2422; z = 2.8181 }, (* C5' *) { x = 5.2050; y = -8.8128; z = 1.8901 }, (* H5' *) { x = 5.5368; y = -8.7738; z = 3.7227 }, (* H5'' *) { x = 6.3232; y = -7.2037; z = 2.6002 }, (* C4' *) { x = 7.3048; y = -7.6757; z = 2.5577 }, (* H4' *) { x = 6.0635; y = -6.5092; z = 1.3456 }, (* O4' *) { x = 6.4697; y = -5.1547; z = 1.4629 }, (* C1' *) { x = 7.2354; y = -5.0043; z = 0.7018 }, (* H1' *) { x = 7.0856; y = -4.9610; z = 2.8521 }, (* C2' *) { x = 6.7777; y = -3.9935; z = 3.2487 }, (* H2'' *) { x = 8.4627; y = -5.1992; z = 2.7423 }, (* O2' *) { x = 8.8693; y = -4.8638; z = 1.9399 }, (* H2' *) { x = 6.3877; y = -6.0809; z = 3.6362 }, (* C3' *) { x = 5.3770; y = -5.7562; z = 3.8834 }, (* H3' *) { x = 7.1024; y = -6.4754; z = 4.7985 }, (* O3' *) { x = 5.2764; y = -4.2883; z = 1.2538 }, (* N1 *) { x = 3.8961; y = -3.0896; z = -0.1893 }, (* N3 *) { x = 5.0095; y = -3.8907; z = -0.0346 }, (* C2 *) { x = 3.0480; y = -2.6632; z = 0.8116 }, (* C4 *) { x = 3.4093; y = -3.1310; z = 2.1292 }, (* C5 *) { x = 4.4878; y = -3.9124; z = 2.3088 }, (* C6 *) (U ( { x = 5.7005; y = -4.2164; z = -0.9842 }, (* O2 *) { x = 2.0800; y = -1.9458; z = 0.5503 }, (* O4 *) { x = 3.6834; y = -2.7882; z = -1.1190 }, (* H3 *) { x = 2.8508; y = -2.8721; z = 2.9172 }, (* H5 *) { x = 4.7188; y = -4.2247; z = 3.2295 }) (* H6 *) ) ) let rU05 = N( { a= -0.6298; b=0.0246; c=0.7763; (* dgf_base_tfo *) d= -0.5226; e= -0.7529; f= -0.4001; g=0.5746; h= -0.6577; i=0.4870; tx= -0.0208; ty= -3.4598; tz= -9.6882 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 4.3825; y = -6.6585; z = 4.0489 }, (* C5' *) { x = 4.6841; y = -7.2019; z = 4.9443 }, (* H5' *) { x = 3.6189; y = -5.8889; z = 4.1625 }, (* H5'' *) { x = 5.6255; y = -5.9175; z = 3.5998 }, (* C4' *) { x = 5.8732; y = -5.1228; z = 4.3034 }, (* H4' *) { x = 6.7337; y = -6.8605; z = 3.5222 }, (* O4' *) { x = 7.5932; y = -6.4923; z = 2.4548 }, (* C1' *) { x = 8.5661; y = -6.2983; z = 2.9064 }, (* H1' *) { x = 7.0527; y = -5.2012; z = 1.8322 }, (* C2' *) { x = 7.1627; y = -5.2525; z = 0.7490 }, (* H2'' *) { x = 7.6666; y = -4.1249; z = 2.4880 }, (* O2' *) { x = 8.5944; y = -4.2543; z = 2.6981 }, (* H2' *) { x = 5.5661; y = -5.3029; z = 2.2009 }, (* C3' *) { x = 5.0841; y = -6.0018; z = 1.5172 }, (* H3' *) { x = 4.9062; y = -4.0452; z = 2.2042 }, (* O3' *) { x = 7.6298; y = -7.6136; z = 1.4752 }, (* N1 *) { x = 8.5977; y = -9.5977; z = 0.7329 }, (* N3 *) { x = 8.5951; y = -8.5745; z = 1.6594 }, (* C2 *) { x = 7.7372; y = -9.7371; z = -0.3364 }, (* C4 *) { x = 6.7596; y = -8.6801; z = -0.4476 }, (* C5 *) { x = 6.7338; y = -7.6721; z = 0.4408 }, (* C6 *) (U ( { x = 9.3993; y = -8.5377; z = 2.5743 }, (* O2 *) { x = 7.8374; y = -10.6990; z = -1.1008 }, (* O4 *) { x = 9.2924; y = -10.3081; z = 0.8477 }, (* H3 *) { x = 6.0932; y = -8.6982; z = -1.1929 }, (* H5 *) { x = 6.0481; y = -6.9515; z = 0.3446 }) (* H6 *) ) ) let rU06 = N( { a= -0.9837; b=0.0476; c= -0.1733; (* dgf_base_tfo *) d= -0.1792; e= -0.3353; f=0.9249; g= -0.0141; h=0.9409; i=0.3384; tx=5.7793; ty= -5.2303; tz=4.5997 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 3.9938; y = -6.7042; z = 1.9023 }, (* C5' *) { x = 3.2332; y = -5.9343; z = 2.0319 }, (* H5' *) { x = 3.9666; y = -7.2863; z = 0.9812 }, (* H5'' *) { x = 5.3098; y = -5.9546; z = 1.8564 }, (* C4' *) { x = 5.3863; y = -5.3702; z = 0.9395 }, (* H4' *) { x = 5.3851; y = -5.0642; z = 3.0076 }, (* O4' *) { x = 6.7315; y = -4.9724; z = 3.4462 }, (* C1' *) { x = 7.0033; y = -3.9202; z = 3.3619 }, (* H1' *) { x = 7.5997; y = -5.8018; z = 2.4948 }, (* C2' *) { x = 8.3627; y = -6.3254; z = 3.0707 }, (* H2'' *) { x = 8.0410; y = -4.9501; z = 1.4724 }, (* O2' *) { x = 8.2781; y = -4.0644; z = 1.7570 }, (* H2' *) { x = 6.5701; y = -6.8129; z = 1.9714 }, (* C3' *) { x = 6.4186; y = -7.5809; z = 2.7299 }, (* H3' *) { x = 6.9357; y = -7.3841; z = 0.7235 }, (* O3' *) { x = 6.8024; y = -5.4718; z = 4.8475 }, (* N1 *) { x = 6.6920; y = -5.0495; z = 7.1354 }, (* N3 *) { x = 6.6201; y = -4.5500; z = 5.8506 }, (* C2 *) { x = 6.9254; y = -6.3614; z = 7.4926 }, (* C4 *) { x = 7.1046; y = -7.2543; z = 6.3718 }, (* C5 *) { x = 7.0391; y = -6.7951; z = 5.1106 }, (* C6 *) (U ( { x = 6.4083; y = -3.3696; z = 5.6340 }, (* O2 *) { x = 6.9679; y = -6.6901; z = 8.6800 }, (* O4 *) { x = 6.5626; y = -4.3957; z = 7.8812 }, (* H3 *) { x = 7.2781; y = -8.2254; z = 6.5350 }, (* H5 *) { x = 7.1657; y = -7.4312; z = 4.3503 }) (* H6 *) ) ) let rU07 = N( { a= -0.9434; b=0.3172; c=0.0971; (* dgf_base_tfo *) d=0.2294; e=0.4125; f=0.8816; g=0.2396; h=0.8539; i= -0.4619; tx=8.3625; ty= -52.7147; tz=1.3745 }, { a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *) d= -0.8297; e=0.4733; f= -0.2959; g=0.4850; h=0.8737; i=0.0379; tx= -14.7774; ty= -45.2464; tz=21.9088 }, { a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *) d= -0.5932; e= -0.6591; f=0.4624; g= -0.7980; h=0.4055; i= -0.4458; tx=43.7634; ty=4.3296; tz=28.4890 }, { a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *) d=0.6803; e=0.3317; f=0.6536; g= -0.1673; h= -0.7979; i=0.5791; tx= -17.1858; ty=41.4390; tz= -27.0751 }, { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P *) { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P *) { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P *) { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5' *) { x = 21.5037; y = 16.8594; z = 43.7323 }, (* C5' *) { x = 20.8147; y = 17.6663; z = 43.9823 }, (* H5' *) { x = 21.1086; y = 16.0230; z = 43.1557 }, (* H5'' *) { x = 22.5654; y = 17.4874; z = 42.8616 }, (* C4' *) { x = 22.1584; y = 17.7243; z = 41.8785 }, (* H4' *) { x = 23.0557; y = 18.6826; z = 43.4751 }, (* O4' *) { x = 24.4788; y = 18.6151; z = 43.6455 }, (* C1' *) { x = 24.9355; y = 19.0840; z = 42.7739 }, (* H1' *) { x = 24.7958; y = 17.1427; z = 43.6474 }, (* C2' *) { x = 24.5652; y = 16.7400; z = 44.6336 }, (* H2'' *) { x = 26.1041; y = 16.8773; z = 43.2455 }, (* O2' *) { x = 26.7516; y = 17.5328; z = 43.5149 }, (* H2' *) { x = 23.8109; y = 16.5979; z = 42.6377 }, (* C3' *) { x = 23.5756; y = 15.5686; z = 42.9084 }, (* H3' *) { x = 24.2890; y = 16.7447; z = 41.2729 }, (* O3' *) { x = 24.9420; y = 19.2174; z = 44.8923 }, (* N1 *) { x = 25.2655; y = 20.5636; z = 44.8883 }, (* N3 *) { x = 25.1663; y = 21.2219; z = 43.8561 }, (* C2 *) { x = 25.6911; y = 21.1219; z = 46.0494 }, (* C4 *) { x = 25.8051; y = 20.4068; z = 47.2048 }, (* C5 *) { x = 26.2093; y = 20.9962; z = 48.2534 }, (* C6 *) (U ( { x = 25.4692; y = 19.0221; z = 47.2053 }, (* O2 *) { x = 25.0502; y = 18.4827; z = 46.0370 }, (* O4 *) { x = 25.9599; y = 22.1772; z = 46.0966 }, (* H3 *) { x = 25.5545; y = 18.4409; z = 48.1234 }, (* H5 *) { x = 24.7854; y = 17.4265; z = 45.9883 }) (* H6 *) ) ) let rU08 = N( { a= -0.0080; b= -0.7928; c=0.6094; (* dgf_base_tfo *) d= -0.7512; e=0.4071; f=0.5197; g= -0.6601; h= -0.4536; i= -0.5988; tx=44.1482; ty=30.7036; tz=2.1088 }, { a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *) d= -0.8297; e=0.4733; f= -0.2959; g=0.4850; h=0.8737; i=0.0379; tx= -14.7774; ty= -45.2464; tz=21.9088 }, { a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *) d= -0.5932; e= -0.6591; f=0.4624; g= -0.7980; h=0.4055; i= -0.4458; tx=43.7634; ty=4.3296; tz=28.4890 }, { a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *) d=0.6803; e=0.3317; f=0.6536; g= -0.1673; h= -0.7979; i=0.5791; tx= -17.1858; ty=41.4390; tz= -27.0751 }, { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P *) { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P *) { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P *) { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5' *) { x = 23.5096; y = 16.1227; z = 44.5783 }, (* C5' *) { x = 23.5649; y = 15.8588; z = 43.5222 }, (* H5' *) { x = 23.9621; y = 15.4341; z = 45.2919 }, (* H5'' *) { x = 24.2805; y = 17.4138; z = 44.7151 }, (* C4' *) { x = 25.3492; y = 17.2309; z = 44.6030 }, (* H4' *) { x = 23.8497; y = 18.3471; z = 43.7208 }, (* O4' *) { x = 23.4090; y = 19.5681; z = 44.3321 }, (* C1' *) { x = 24.2595; y = 20.2496; z = 44.3524 }, (* H1' *) { x = 23.0418; y = 19.1813; z = 45.7407 }, (* C2' *) { x = 22.0532; y = 18.7224; z = 45.7273 }, (* H2'' *) { x = 23.1307; y = 20.2521; z = 46.6291 }, (* O2' *) { x = 22.8888; y = 21.1051; z = 46.2611 }, (* H2' *) { x = 24.0799; y = 18.1326; z = 46.0700 }, (* C3' *) { x = 23.6490; y = 17.4370; z = 46.7900 }, (* H3' *) { x = 25.3329; y = 18.7227; z = 46.5109 }, (* O3' *) { x = 22.2515; y = 20.1624; z = 43.6698 }, (* N1 *) { x = 22.4760; y = 21.0609; z = 42.6406 }, (* N3 *) { x = 23.6229; y = 21.3462; z = 42.3061 }, (* C2 *) { x = 21.3986; y = 21.6081; z = 42.0236 }, (* C4 *) { x = 20.1189; y = 21.3012; z = 42.3804 }, (* C5 *) { x = 19.1599; y = 21.8516; z = 41.7578 }, (* C6 *) (U ( { x = 19.8919; y = 20.3745; z = 43.4387 }, (* O2 *) { x = 20.9790; y = 19.8423; z = 44.0440 }, (* O4 *) { x = 21.5235; y = 22.3222; z = 41.2097 }, (* H3 *) { x = 18.8732; y = 20.1200; z = 43.7312 }, (* H5 *) { x = 20.8545; y = 19.1313; z = 44.8608 }) (* H6 *) ) ) let rU09 = N( { a= -0.0317; b=0.1374; c=0.9900; (* dgf_base_tfo *) d= -0.3422; e= -0.9321; f=0.1184; g=0.9391; h= -0.3351; i=0.0765; tx= -32.1929; ty=25.8198; tz= -28.5088 }, { a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *) d= -0.8297; e=0.4733; f= -0.2959; g=0.4850; h=0.8737; i=0.0379; tx= -14.7774; ty= -45.2464; tz=21.9088 }, { a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *) d= -0.5932; e= -0.6591; f=0.4624; g= -0.7980; h=0.4055; i= -0.4458; tx=43.7634; ty=4.3296; tz=28.4890 }, { a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *) d=0.6803; e=0.3317; f=0.6536; g= -0.1673; h= -0.7979; i=0.5791; tx= -17.1858; ty=41.4390; tz= -27.0751 }, { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P *) { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P *) { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P *) { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5' *) { x = 21.5037; y = 16.8594; z = 43.7323 }, (* C5' *) { x = 20.8147; y = 17.6663; z = 43.9823 }, (* H5' *) { x = 21.1086; y = 16.0230; z = 43.1557 }, (* H5'' *) { x = 22.5654; y = 17.4874; z = 42.8616 }, (* C4' *) { x = 23.0565; y = 18.3036; z = 43.3915 }, (* H4' *) { x = 23.5375; y = 16.5054; z = 42.4925 }, (* O4' *) { x = 23.6574; y = 16.4257; z = 41.0649 }, (* C1' *) { x = 24.4701; y = 17.0882; z = 40.7671 }, (* H1' *) { x = 22.3525; y = 16.9643; z = 40.5396 }, (* C2' *) { x = 21.5993; y = 16.1799; z = 40.6133 }, (* H2'' *) { x = 22.4693; y = 17.4849; z = 39.2515 }, (* O2' *) { x = 23.0899; y = 17.0235; z = 38.6827 }, (* H2' *) { x = 22.0341; y = 18.0633; z = 41.5279 }, (* C3' *) { x = 20.9509; y = 18.1709; z = 41.5846 }, (* H3' *) { x = 22.7249; y = 19.3020; z = 41.2100 }, (* O3' *) { x = 23.8580; y = 15.0648; z = 40.5757 }, (* N1 *) { x = 25.1556; y = 14.5982; z = 40.4523 }, (* N3 *) { x = 26.1047; y = 15.3210; z = 40.7448 }, (* C2 *) { x = 25.3391; y = 13.3315; z = 40.0020 }, (* C4 *) { x = 24.2974; y = 12.5148; z = 39.6749 }, (* C5 *) { x = 24.5450; y = 11.3410; z = 39.2610 }, (* C6 *) (U ( { x = 22.9633; y = 12.9979; z = 39.8053 }, (* O2 *) { x = 22.8009; y = 14.2648; z = 40.2524 }, (* O4 *) { x = 26.3414; y = 12.9194; z = 39.8855 }, (* H3 *) { x = 22.1227; y = 12.3533; z = 39.5486 }, (* H5 *) { x = 21.7989; y = 14.6788; z = 40.3650 }) (* H6 *) ) ) let rU10 = N( { a= -0.9674; b=0.1021; c= -0.2318; (* dgf_base_tfo *) d= -0.2514; e= -0.2766; f=0.9275; g=0.0306; h=0.9555; i=0.2933; tx=27.8571; ty= -42.1305; tz= -24.4563 }, { a=0.2765; b= -0.1121; c= -0.9545; (* P_O3'_275_tfo *) d= -0.8297; e=0.4733; f= -0.2959; g=0.4850; h=0.8737; i=0.0379; tx= -14.7774; ty= -45.2464; tz=21.9088 }, { a=0.1063; b= -0.6334; c= -0.7665; (* P_O3'_180_tfo *) d= -0.5932; e= -0.6591; f=0.4624; g= -0.7980; h=0.4055; i= -0.4458; tx=43.7634; ty=4.3296; tz=28.4890 }, { a=0.7136; b= -0.5032; c= -0.4873; (* P_O3'_60_tfo *) d=0.6803; e=0.3317; f=0.6536; g= -0.1673; h= -0.7979; i=0.5791; tx= -17.1858; ty=41.4390; tz= -27.0751 }, { x = 21.3880; y = 15.0780; z = 45.5770 }, (* P *) { x = 21.9980; y = 14.5500; z = 46.8210 }, (* O1P *) { x = 21.1450; y = 14.0270; z = 44.5420 }, (* O2P *) { x = 22.1250; y = 16.3600; z = 44.9460 }, (* O5' *) { x = 23.5096; y = 16.1227; z = 44.5783 }, (* C5' *) { x = 23.5649; y = 15.8588; z = 43.5222 }, (* H5' *) { x = 23.9621; y = 15.4341; z = 45.2919 }, (* H5'' *) { x = 24.2805; y = 17.4138; z = 44.7151 }, (* C4' *) { x = 23.8509; y = 18.1819; z = 44.0720 }, (* H4' *) { x = 24.2506; y = 17.8583; z = 46.0741 }, (* O4' *) { x = 25.5830; y = 18.0320; z = 46.5775 }, (* C1' *) { x = 25.8569; y = 19.0761; z = 46.4256 }, (* H1' *) { x = 26.4410; y = 17.1555; z = 45.7033 }, (* C2' *) { x = 26.3459; y = 16.1253; z = 46.0462 }, (* H2'' *) { x = 27.7649; y = 17.5888; z = 45.6478 }, (* O2' *) { x = 28.1004; y = 17.9719; z = 46.4616 }, (* H2' *) { x = 25.7796; y = 17.2997; z = 44.3513 }, (* C3' *) { x = 25.9478; y = 16.3824; z = 43.7871 }, (* H3' *) { x = 26.2154; y = 18.4984; z = 43.6541 }, (* O3' *) { x = 25.7321; y = 17.6281; z = 47.9726 }, (* N1 *) { x = 25.5136; y = 18.5779; z = 48.9560 }, (* N3 *) { x = 25.2079; y = 19.7276; z = 48.6503 }, (* C2 *) { x = 25.6482; y = 18.1987; z = 50.2518 }, (* C4 *) { x = 25.9847; y = 16.9266; z = 50.6092 }, (* C5 *) { x = 26.0918; y = 16.6439; z = 51.8416 }, (* C6 *) (U ( { x = 26.2067; y = 15.9515; z = 49.5943 }, (* O2 *) { x = 26.0713; y = 16.3497; z = 48.3080 }, (* O4 *) { x = 25.4890; y = 18.9105; z = 51.0618 }, (* H3 *) { x = 26.4742; y = 14.9310; z = 49.8682 }, (* H5 *) { x = 26.2346; y = 15.6394; z = 47.4975 }) (* H6 *) ) ) let rUs = [rU01;rU02;rU03;rU04;rU05;rU06;rU07;rU08;rU09;rU10] let rG' = N( { a= -0.2067; b= -0.0264; c=0.9780; (* dgf_base_tfo *) d=0.9770; e= -0.0586; f=0.2049; g=0.0519; h=0.9979; i=0.0379; tx=1.0331; ty= -46.8078; tz= -36.4742 }, { a= -0.8644; b= -0.4956; c= -0.0851; (* P_O3'_275_tfo *) d= -0.0427; e=0.2409; f= -0.9696; g=0.5010; h= -0.8345; i= -0.2294; tx=4.0167; ty=54.5377; tz=12.4779 }, { a=0.3706; b= -0.6167; c=0.6945; (* P_O3'_180_tfo *) d= -0.2867; e= -0.7872; f= -0.5460; g=0.8834; h=0.0032; i= -0.4686; tx= -52.9020; ty=18.6313; tz= -0.6709 }, { a=0.4155; b=0.9025; c= -0.1137; (* P_O3'_60_tfo *) d=0.9040; e= -0.4236; f= -0.0582; g= -0.1007; h= -0.0786; i= -0.9918; tx= -7.6624; ty= -25.2080; tz=49.5181 }, { x = 31.3810; y = 0.1400; z = 47.5810 }, (* P *) { x = 29.9860; y = 0.6630; z = 47.6290 }, (* O1P *) { x = 31.7210; y = -0.6460; z = 48.8090 }, (* O2P *) { x = 32.4940; y = 1.2540; z = 47.2740 }, (* O5' *) { x = 32.1610; y = 2.2370; z = 46.2560 }, (* C5' *) { x = 31.2986; y = 2.8190; z = 46.5812 }, (* H5' *) { x = 32.0980; y = 1.7468; z = 45.2845 }, (* H5'' *) { x = 33.3476; y = 3.1959; z = 46.1947 }, (* C4' *) { x = 33.2668; y = 3.8958; z = 45.3630 }, (* H4' *) { x = 33.3799; y = 3.9183; z = 47.4216 }, (* O4' *) { x = 34.6515; y = 3.7222; z = 48.0398 }, (* C1' *) { x = 35.2947; y = 4.5412; z = 47.7180 }, (* H1' *) { x = 35.1756; y = 2.4228; z = 47.4827 }, (* C2' *) { x = 34.6778; y = 1.5937; z = 47.9856 }, (* H2'' *) { x = 36.5631; y = 2.2672; z = 47.4798 }, (* O2' *) { x = 37.0163; y = 2.6579; z = 48.2305 }, (* H2' *) { x = 34.6953; y = 2.5043; z = 46.0448 }, (* C3' *) { x = 34.5444; y = 1.4917; z = 45.6706 }, (* H3' *) { x = 35.6679; y = 3.3009; z = 45.3487 }, (* O3' *) { x = 37.4804; y = 4.0914; z = 52.2559 }, (* N1 *) { x = 36.9670; y = 4.1312; z = 49.9281 }, (* N3 *) { x = 37.8045; y = 4.2519; z = 50.9550 }, (* C2 *) { x = 35.7171; y = 3.8264; z = 50.3222 }, (* C4 *) { x = 35.2668; y = 3.6420; z = 51.6115 }, (* C5 *) { x = 36.2037; y = 3.7829; z = 52.6706 }, (* C6 *) (G ( { x = 39.0869; y = 4.5552; z = 50.7092 }, (* N2 *) { x = 33.9075; y = 3.3338; z = 51.6102 }, (* N7 *) { x = 34.6126; y = 3.6358; z = 49.5108 }, (* N9 *) { x = 33.5805; y = 3.3442; z = 50.3425 }, (* C8 *) { x = 35.9958; y = 3.6512; z = 53.8724 }, (* O6 *) { x = 38.2106; y = 4.2053; z = 52.9295 }, (* H1 *) { x = 39.8218; y = 4.6863; z = 51.3896 }, (* H21 *) { x = 39.3420; y = 4.6857; z = 49.7407 }, (* H22 *) { x = 32.5194; y = 3.1070; z = 50.2664 }) (* H8 *) ) ) let rU' = N( { a= -0.0109; b=0.5907; c=0.8068; (* dgf_base_tfo *) d=0.2217; e= -0.7853; f=0.5780; g=0.9751; h=0.1852; i= -0.1224; tx= -1.4225; ty= -11.0956; tz= -2.5217 }, { a= -0.8313; b= -0.4738; c= -0.2906; (* P_O3'_275_tfo *) d=0.0649; e=0.4366; f= -0.8973; g=0.5521; h= -0.7648; i= -0.3322; tx=1.6833; ty=6.8060; tz= -7.0011 }, { a=0.3445; b= -0.7630; c=0.5470; (* P_O3'_180_tfo *) d= -0.4628; e= -0.6450; f= -0.6082; g=0.8168; h= -0.0436; i= -0.5753; tx= -6.8179; ty= -3.9778; tz= -5.9887 }, { a=0.5855; b=0.7931; c= -0.1682; (* P_O3'_60_tfo *) d=0.8103; e= -0.5790; f=0.0906; g= -0.0255; h= -0.1894; i= -0.9816; tx=6.1203; ty= -7.1051; tz=3.1984 }, { x = 2.6760; y = -8.4960; z = 3.2880 }, (* P *) { x = 1.4950; y = -7.6230; z = 3.4770 }, (* O1P *) { x = 2.9490; y = -9.4640; z = 4.3740 }, (* O2P *) { x = 3.9730; y = -7.5950; z = 3.0340 }, (* O5' *) { x = 5.2430; y = -8.2420; z = 2.8260 }, (* C5' *) { x = 5.1974; y = -8.8497; z = 1.9223 }, (* H5' *) { x = 5.5548; y = -8.7348; z = 3.7469 }, (* H5'' *) { x = 6.3140; y = -7.2060; z = 2.5510 }, (* C4' *) { x = 5.8744; y = -6.2116; z = 2.4731 }, (* H4' *) { x = 7.2798; y = -7.2260; z = 3.6420 }, (* O4' *) { x = 8.5733; y = -6.9410; z = 3.1329 }, (* C1' *) { x = 8.9047; y = -6.0374; z = 3.6446 }, (* H1' *) { x = 8.4429; y = -6.6596; z = 1.6327 }, (* C2' *) { x = 9.2880; y = -7.1071; z = 1.1096 }, (* H2'' *) { x = 8.2502; y = -5.2799; z = 1.4754 }, (* O2' *) { x = 8.7676; y = -4.7284; z = 2.0667 }, (* H2' *) { x = 7.1642; y = -7.4416; z = 1.3021 }, (* C3' *) { x = 7.4125; y = -8.5002; z = 1.2260 }, (* H3' *) { x = 6.5160; y = -6.9772; z = 0.1267 }, (* O3' *) { x = 9.4531; y = -8.1107; z = 3.4087 }, (* N1 *) { x = 11.5931; y = -9.0015; z = 3.6357 }, (* N3 *) { x = 10.8101; y = -7.8950; z = 3.3748 }, (* C2 *) { x = 11.1439; y = -10.2744; z = 3.9206 }, (* C4 *) { x = 9.7056; y = -10.4026; z = 3.9332 }, (* C5 *) { x = 8.9192; y = -9.3419; z = 3.6833 }, (* C6 *) (U ( { x = 11.3013; y = -6.8063; z = 3.1326 }, (* O2 *) { x = 11.9431; y = -11.1876; z = 4.1375 }, (* O4 *) { x = 12.5840; y = -8.8673; z = 3.6158 }, (* H3 *) { x = 9.2891; y = -11.2898; z = 4.1313 }, (* H5 *) { x = 7.9263; y = -9.4537; z = 3.6977 }) (* H6 *) ) ) (* -- PARTIAL INSTANTIATIONS ------------------------------------------------*) type variable = { id : int; t : tfo; n : nuc } let mk_var i t n = { id = i; t = t; n = n } let absolute_pos v p = tfo_apply v.t p let atom_pos atom v = absolute_pos v (atom v.n) let rec get_var id = function | (v::lst) -> if id = v.id then v else get_var id lst | _ -> assert false (* -- SEARCH ----------------------------------------------------------------*) (* Sequential backtracking algorithm *) let rec search (partial_inst : variable list) l constr = match l with [] -> [partial_inst] | (h::t) -> let rec try_assignments = function [] -> [] | v::vs -> if constr v partial_inst then (search (v::partial_inst) t constr) @ (try_assignments vs) else try_assignments vs in try_assignments (h partial_inst) (* -- DOMAINS ---------------------------------------------------------------*) (* Primary structure: strand A CUGCCACGUCUG, strand B CAGACGUGGCAG Secondary structure: strand A CUGCCACGUCUG |||||||||||| GACGGUGCAGAC strand B Tertiary structure: 5' end of strand A C1----G12 3' end of strand B U2-------A11 G3-------C10 C4-----G9 C5---G8 A6 G6-C7 C5----G8 A4-------U9 G3--------C10 A2-------U11 5' end of strand B C1----G12 3' end of strand A "helix", "stacked" and "connected" describe the spatial relationship between two consecutive nucleotides. E.g. the nucleotides C1 and U2 from the strand A. "wc" (stands for Watson-Crick and is a type of base-pairing), and "wc-dumas" describe the spatial relationship between nucleotides from two chains that are growing in opposite directions. E.g. the nucleotides C1 from strand A and G12 from strand B. *) (* Dynamic Domains *) (* Given, "refnuc" a nucleotide which is already positioned, "nucl" the nucleotide to be placed, and "tfo" a transformation matrix which expresses the desired relationship between "refnuc" and "nucl", the function "dgf-base" computes the transformation matrix that places the nucleotide "nucl" in the given relationship to "refnuc". *) let dgf_base tfo v nucl = let x = if is_A v.n then tfo_align (atom_pos nuc_C1' v) (atom_pos rA_N9 v) (atom_pos nuc_C4 v) else if is_C v.n then tfo_align (atom_pos nuc_C1' v) (atom_pos nuc_N1 v) (atom_pos nuc_C2 v) else if is_G v.n then tfo_align (atom_pos nuc_C1' v) (atom_pos rG_N9 v) (atom_pos nuc_C4 v) else tfo_align (atom_pos nuc_C1' v) (atom_pos nuc_N1 v) (atom_pos nuc_C2 v) in tfo_combine (nuc_dgf_base_tfo nucl) (tfo_combine tfo (tfo_inv_ortho x)) (* Placement of first nucleotide. *) let reference n i partial_inst = [ mk_var i tfo_id n ] (* The transformation matrix for wc is from: Chandrasekaran R. et al (1989) A Re-Examination of the Crystal Structure of A-DNA Using Fiber Diffraction Data. J. Biomol. Struct. & Dynamics 6(6):1189-1202. *) let wc_tfo = ( { a= -1.0000; b=0.0028; c= -0.0019; d=0.0028; e=0.3468; f= -0.9379; g= -0.0019; h= -0.9379; i= -0.3468; tx= -0.0080; ty=6.0730; tz=8.7208 } ) let wc nucl i j partial_inst = [ mk_var i (dgf_base wc_tfo (get_var j partial_inst) nucl) nucl ] let wc_dumas_tfo = ( { a= -0.9737; b= -0.1834; c=0.1352; d= -0.1779; e=0.2417; f= -0.9539; g=0.1422; h= -0.9529; i= -0.2679; tx=0.4837; ty=6.2649; tz=8.0285 } ) let wc_dumas nucl i j partial_inst = [ mk_var i (dgf_base wc_dumas_tfo (get_var j partial_inst) nucl) nucl ] let helix5'_tfo = ( { a=0.9886; b= -0.0961; c=0.1156; d=0.1424; e=0.8452; f= -0.5152; g= -0.0482; h=0.5258; i=0.8492; tx= -3.8737; ty=0.5480; tz=3.8024 } ) let helix5' nucl i j partial_inst = [ mk_var i (dgf_base helix5'_tfo (get_var j partial_inst) nucl) nucl ] let helix3'_tfo = ( { a=0.9886; b=0.1424; c= -0.0482; d= -0.0961; e=0.8452; f=0.5258; g=0.1156; h= -0.5152; i=0.8492; tx=3.4426; ty=2.0474; tz= -3.7042 } ) let helix3' nucl i j partial_inst = [ mk_var i (dgf_base helix3'_tfo (get_var j partial_inst) nucl) nucl ] let g37_a38_tfo = ( { a=0.9991; b=0.0164; c= -0.0387; d= -0.0375; e=0.7616; f= -0.6470; g=0.0189; h=0.6478; i=0.7615; tx= -3.3018; ty=0.9975; tz=2.5585 } ) let g37_a38 nucl i j partial_inst = mk_var i (dgf_base g37_a38_tfo (get_var j partial_inst) nucl) nucl let stacked5' nucl i j partial_inst = (g37_a38 nucl i j partial_inst) :: (helix5' nucl i j partial_inst) let a38_g37_tfo = ( { a=0.9991; b= -0.0375; c=0.0189; d=0.0164; e=0.7616; f=0.6478; g= -0.0387; h= -0.6470; i=0.7615; tx=3.3819; ty=0.7718; tz= -2.5321 } ) let a38_g37 nucl i j partial_inst = mk_var i (dgf_base a38_g37_tfo (get_var j partial_inst) nucl) nucl let stacked3' nucl i j partial_inst = (a38_g37 nucl i j partial_inst) :: (helix3' nucl i j partial_inst) let p_o3' nucls i j partial_inst = let refnuc = get_var j partial_inst in let align = tfo_inv_ortho (tfo_align (atom_pos nuc_O3' refnuc) (atom_pos nuc_C3' refnuc) (atom_pos nuc_C4' refnuc)) in let rec generate domains = function [] -> domains | n::ns -> generate ((mk_var i (tfo_combine (nuc_p_o3'_60_tfo n) align) n):: (mk_var i (tfo_combine (nuc_p_o3'_180_tfo n) align) n):: (mk_var i (tfo_combine (nuc_p_o3'_275_tfo n) align) n)::domains) ns in generate [] nucls (* -- PROBLEM STATEMENT -----------------------------------------------------*) (* Define anticodon problem -- Science 253:1255 Figure 3a, 3b and 3c *) let anticodon_domains = [ reference rC 27; helix5' rC 28 27; helix5' rA 29 28; helix5' rG 30 29; helix5' rA 31 30; wc rU 39 31; helix5' rC 40 39; helix5' rU 41 40; helix5' rG 42 41; helix5' rG 43 42; stacked3' rA 38 39; stacked3' rG 37 38; stacked3' rA 36 37; stacked3' rA 35 36; stacked3' rG 34 35; (* <-. Distance *) p_o3' rCs 32 31; (* | Constraint *) p_o3' rUs 33 32 (* <-' 3.0 Angstroms *) ] (* Anticodon constraint *) let anticodon_constraint v partial_inst = let rec dist j = let p = atom_pos nuc_P (get_var j partial_inst) in let o3' = atom_pos nuc_O3' v in pt_dist p o3' in if v.id = 33 then (dist 34) <= 3.0 else true let anticodon () = search [] anticodon_domains anticodon_constraint (* Define pseudoknot problem -- Science 253:1255 Figure 4a and 4b *) let pseudoknot_domains = [ reference rA 23; wc_dumas rU 8 23; helix3' rG 22 23; wc_dumas rC 9 22; helix3' rG 21 22; wc_dumas rC 10 21; helix3' rC 20 21; wc_dumas rG 11 20; helix3' rU' 19 20; (* <-. *) wc_dumas rA 12 19; (* | Distance *) (* | Constraint *) (* Helix 1 | 4.0 Angstroms *) helix3' rC 3 19; (* | *) wc_dumas rG 13 3; (* | *) helix3' rC 2 3; (* | *) wc_dumas rG 14 2; (* | *) helix3' rC 1 2; (* | *) wc_dumas rG' 15 1; (* | *) (* | *) (* L2 LOOP | *) p_o3' rUs 16 15; (* | *) p_o3' rCs 17 16; (* | *) p_o3' rAs 18 17; (* <-' *) (* *) (* L1 LOOP *) helix3' rU 7 8; (* <-. *) p_o3' rCs 4 3; (* | Constraint *) stacked5' rU 5 4; (* | 4.5 Angstroms *) stacked5' rC 6 5 (* <-' *) ] (* Pseudoknot constraint *) let pseudoknot_constraint v partial_inst = let rec dist j = let p = atom_pos nuc_P (get_var j partial_inst) in let o3' = atom_pos nuc_O3' v in pt_dist p o3' in if v.id = 18 then (dist 19) <= 4.0 else if v.id = 6 then (dist 7) <= 4.5 else true let pseudoknot () = search [] pseudoknot_domains pseudoknot_constraint (* -- TESTING ---------------------------------------------------------------*) let list_of_atoms = function (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6, A (n6,n7,n9,c8,h2,h61,h62,h8))) -> [|p;o1p;o2p;o5';c5';h5';h5'';c4';h4';o4';c1';h1';c2';h2'';o2';h2';c3'; h3';o3';n1;n3;c2;c4;c5;c6;n6;n7;n9;c8;h2;h61;h62;h8|] | (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6, C (n4,o2,h41,h42,h5,h6))) -> [|p;o1p;o2p;o5';c5';h5';h5'';c4';h4';o4';c1';h1';c2';h2'';o2';h2';c3'; h3';o3';n1;n3;c2;c4;c5;c6;n4;o2;h41;h42;h5;h6|] | (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6, G (n2,n7,n9,c8,o6,h1,h21,h22,h8))) -> [|p;o1p;o2p;o5';c5';h5';h5'';c4';h4';o4';c1';h1';c2';h2'';o2';h2';c3'; h3';o3';n1;n3;c2;c4;c5;c6;n2;n7;n9;c8;o6;h1;h21;h22;h8|] | (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6, U (o2,o4,h3,h5,h6))) -> [|p;o1p;o2p;o5';c5';h5';h5'';c4';h4';o4';c1';h1';c2';h2'';o2';h2';c3'; h3';o3';n1;n3;c2;c4;c5;c6;o2;o4;h3;h5;h6|] let maximum = function | x::xs -> let rec iter m = function [] -> m | (a::b) -> iter (if a > m then a else m) b in iter x xs | _ -> assert false let var_most_distant_atom v = let atoms = list_of_atoms v.n in let max_dist = ref 0.0 in for i = 0 to pred (Array.length atoms) do let p = atoms.(i) in let distance = let pos = absolute_pos v p in sqrt ((pos.x * pos.x) + (pos.y * pos.y) + (pos.z * pos.z)) in if distance > !max_dist then max_dist := distance done; !max_dist let sol_most_distant_atom s = maximum (List.map var_most_distant_atom s) let most_distant_atom sols = maximum (List.map sol_most_distant_atom sols) let check () = List.length (pseudoknot ()) let run () = most_distant_atom (pseudoknot ()) let main () = for i = 1 to 50 do ignore(run()) done; Printf.printf "%.4f" (run ()); print_newline() let _ = main () mingw-ocaml/ocaml/testsuite/tests/misc/Makefile0000644000175000017500000000015112124403241021241 0ustar tootstootsBASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/misc/hamming.ml0000644000175000017500000000563412124403241021566 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* We cannot use bignums because we don't do custom runtimes, but int64 is a bit short, so we roll our own 37-digit numbers... *) let n0 = Int64.of_int 0;; let n1 = Int64.of_int 1;; let n2 = Int64.of_int 2;; let n3 = Int64.of_int 3;; let n5 = Int64.of_int 5;; let ( % ) = Int64.rem;; let ( * ) = Int64.mul;; let ( / ) = Int64.div;; let ( + ) = Int64.add;; let digit = Int64.of_string "1000000000000000000";; let mul n (pl, ph) = ((n * pl) % digit, n * ph + (n * pl) / digit);; let cmp (nl, nh) (pl, ph) = if nh < ph then -1 else if nh > ph then 1 else if nl < pl then -1 else if nl > pl then 1 else 0 ;; let x2 = fun p -> mul n2 p;; let x3 = fun p -> mul n3 p;; let x5 = fun p -> mul n5 p;; let nn1 = (n1, n0);; let pr (nl, nh) = if compare nh n0 = 0 then Printf.printf "%Ld\n" nl else Printf.printf "%Ld%018Ld\n" nh nl ;; (* (* bignum version *) open Num;; let nn1 = num_of_int 1;; let x2 = fun p -> (num_of_int 2) */ p;; let x3 = fun p -> (num_of_int 3) */ p;; let x5 = fun p -> (num_of_int 5) */ p;; let cmp n p = sign_num (n -/ p);; let pr n = Printf.printf "%s\n" (string_of_num n);; *) (* This is where the interesting stuff begins. *) open Lazy;; type 'a lcons = Cons of 'a * 'a lcons Lazy.t;; type 'a llist = 'a lcons Lazy.t;; let rec map f l = lazy ( match force l with | Cons (x, ll) -> Cons (f x, map f ll) ) ;; let rec merge cmp l1 l2 = lazy ( match force l1, force l2 with | Cons (x1, ll1), Cons (x2, ll2) -> let c = cmp x1 x2 in if c = 0 then Cons (x1, merge cmp ll1 ll2) else if c < 0 then Cons (x1, merge cmp ll1 l2) else Cons (x2, merge cmp l1 ll2) ) ;; let rec iter_interval f l (start, stop) = if stop = 0 then () else match force l with | Cons (x, ll) -> if start <= 0 then f x; iter_interval f ll (start-1, stop-1) ;; let rec hamming = lazy (Cons (nn1, merge cmp ham2 (merge cmp ham3 ham5))) and ham2 = lazy (force (map x2 hamming)) and ham3 = lazy (force (map x3 hamming)) and ham5 = lazy (force (map x5 hamming)) ;; iter_interval pr hamming (88000, 88100);; mingw-ocaml/ocaml/testsuite/tests/misc/bdd.reference0000644000175000017500000000000312124403241022206 0ustar tootstootsOK mingw-ocaml/ocaml/testsuite/tests/misc/sieve.ml0000644000175000017500000000327512124403241021260 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Eratosthene's sieve *) (* interval min max = [min; min+1; ...; max-1; max] *) let rec interval min max = if min > max then [] else min :: interval (min + 1) max (* filter p L returns the list of the elements in list L that satisfy predicate p *) let rec filter p = function [] -> [] | a::r -> if p a then a :: filter p r else filter p r (* Application: removing all numbers multiple of n from a list of integers *) let remove_multiples_of n = filter (fun m -> m mod n <> 0) (* The sieve itself *) let sieve max = let rec filter_again = function [] -> [] | n::r as l -> if n*n > max then l else n :: filter_again (remove_multiples_of n r) in filter_again (interval 2 max) let rec do_list f = function [] -> () | a::l -> f a; do_list f l let _ = do_list (fun n -> print_string " "; print_int n) (sieve 50000); print_newline(); exit 0 mingw-ocaml/ocaml/testsuite/tests/misc/hamming.reference0000644000175000017500000000733012124403241023107 0ustar tootstoots6726050156250000000000000000000000000 6729216728661136606575523242669244416 6730293634611118019721084375000000000 6731430439413948088320000000000000000 6733644878411293029785156250000000000 6736815026358904613608094481682268160 6739031236724077363200000000000000000 6743282904874568941599068856042651648 6744421903677486140423997176256921600 6746640616477458432000000000000000000 6750000000000000000000000000000000000 6750897085400702945836103937453588480 6752037370304563380023474956271616000 6754258588364960445000000000000000000 6755399441055744000000000000000000000 6757621765136718750000000000000000000 6758519863481752323552044362431792300 6759661435938757375539248533340160000 6761885162088395001166534423828125000 6763027302973440000000000000000000000 6765252136392518877983093261718750000 6767294110289640371843415775641600000 6768437164792816653010961694720000000 6770663777894400000000000000000000000 6774935403077748181101173538816000000 6776079748261363229431903027200000000 6778308875544000000000000000000000000 6782585324034592562287109312160000000 6783730961356018699387011072000000000 6785962605658597412109375000000000000 6789341568946838378906250000000000000 6791390813820928754681118720000000000 6794772480000000000000000000000000000 6799059315411241693033267200000000000 6800207735332289107722240000000000000 6802444800000000000000000000000000000 6806736475893120841673472000000000000 6807886192552970708582400000000000000 6810125783203125000000000000000000000 6814422305043756994967597929687500000 6815573319906622439424000000000000000 6817815439391434192657470703125000000 6821025214188390921278195662703296512 6821210263296961784362792968750000000 6823269127183128330240000000000000000 6828727177473454717179297140960133120 6830973624183426662400000000000000000 6834375000000000000000000000000000000 6835283298968211732659055236671758336 6836437837433370422273768393225011200 6838686820719522450562500000000000000 6839841934068940800000000000000000000 6842092037200927734375000000000000000 6844157203887991842733489140006912000 6845313241232438768082197309030400000 6847565144260608000000000000000000000 6849817788097425363957881927490234375 6851885286668260876491458472837120000 6853042629352726861173598715904000000 6855297075118080000000000000000000000 6859622095616220033364938208051200000 6860780745114630269799801815040000000 6863037736488300000000000000000000000 6866455078125000000000000000000000000 6867367640585024969315698178562000000 6868527598372968933129348710400000000 6870787138229329879760742187500000000 6871947673600000000000000000000000000 6874208338558673858642578125000000000 6876283198993690364114632704000000000 6879707136000000000000000000000000000 6884047556853882214196183040000000000 6885210332023942721568768000000000000 6887475360000000000000000000000000000 6891820681841784852194390400000000000 6892984769959882842439680000000000000 6895252355493164062500000000000000000 6899602583856803957404692903808593750 6900767986405455219916800000000000000 6903038132383827120065689086914062500 6906475391588173806667327880859375000 6908559991272917434368000000000000000 6912000000000000000000000000000000000 6914086267191872901144038355222134784 6916360794485719495680000000000000000 6917529027641081856000000000000000000 6919804687500000000000000000000000000 6921893310401287552552190498140323840 6924170405978516481194531250000000000 6925339958244802560000000000000000000 6927618187665939331054687500000000000 6929709168936591740767657754256998400 6930879656747844252683224775393280000 6933159708563865600000000000000000000 6937533852751614137447601703747584000 6938705662219635946938268699852800000 6940988288557056000000000000000000000 6945367371811422783781999935651840000 6946540504428563148172299337728000000 6948825708194403750000000000000000000 mingw-ocaml/ocaml/testsuite/tests/misc/nucleic.reference0000644000175000017500000000001012124403241023075 0ustar tootstoots33.7976 mingw-ocaml/ocaml/testsuite/tests/misc/taku.reference0000644000175000017500000000000612124403241022424 0ustar tootstoots14000 mingw-ocaml/ocaml/testsuite/tests/misc/fib.ml0000644000175000017500000000201212124403241020671 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) let rec fib n = if n < 2 then 1 else fib(n-1) + fib(n-2) let _ = let n = if Array.length Sys.argv >= 2 then int_of_string Sys.argv.(1) else 40 in print_int(fib n); print_newline(); exit 0 mingw-ocaml/ocaml/testsuite/tests/misc/sorts.reference0000644000175000017500000003164612124403241022650 0ustar tootstootsCommand line arguments are: Testing List.sort... List.sort with constant ints 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.sort with sorted ints 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.sort with reverse-sorted ints 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.sort with random ints (many dups) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.sort with random ints (few dups) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.sort with records (str) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.sort with records (int[1]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.sort with records (int[10]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.sort with records (int[100]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.sort with records (int[1000]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Testing List.stable_sort... List.stable_sort with constant ints 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.stable_sort with sorted ints 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.stable_sort with reverse-sorted ints 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.stable_sort with random ints (many dups) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.stable_sort with random ints (few dups) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.stable_sort with records (str) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.stable_sort with records (int[1]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.stable_sort with records (int[10]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.stable_sort with records (int[100]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.stable_sort with records (int[1000]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.stable_sort with records (int[1]) [stable] 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.stable_sort with records (int[10]) [stable] 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.stable_sort with records (int[100]) [stable] 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. List.stable_sort with records (int[1000]) [stable] 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Testing Array.sort... Array.sort with constant ints 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.sort with sorted ints 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.sort with reverse-sorted ints 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.sort with random ints (many dups) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.sort with random ints (few dups) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.sort with records (str) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.sort with records (int[1]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.sort with records (int[10]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.sort with records (int[100]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.sort with records (int[1000]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Testing Array.stable_sort... Array.stable_sort with constant ints 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.stable_sort with sorted ints 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.stable_sort with reverse-sorted ints 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.stable_sort with random ints (many dups) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.stable_sort with random ints (few dups) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.stable_sort with records (str) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.stable_sort with records (int[1]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.stable_sort with records (int[10]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.stable_sort with records (int[100]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.stable_sort with records (int[1000]) 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.stable_sort with records (int[1]) [stable] 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.stable_sort with records (int[10]) [stable] 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.stable_sort with records (int[100]) [stable] 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Array.stable_sort with records (int[1000]) [stable] 0. 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 28. 100. 127. 128. 129. 191. 192. 193. 506. 1000. 1023. 1024. 1025. 1535. 1536. 1537. 2323. 4000. 4094. 4096. 4098. 5123. Number of tests failed: 0 mingw-ocaml/ocaml/testsuite/tests/misc/boyer.ml0000644000175000017500000006166312124403241021272 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Manipulations over terms *) type term = Var of int | Prop of head * term list and head = { name: string; mutable props: (term * term) list } let rec print_term = function Var v -> print_string "v"; print_int v | Prop (head,argl) -> print_string "("; print_string head.name; List.iter (fun t -> print_string " "; print_term t) argl; print_string ")" let lemmas = ref ([] : head list) (* Replacement for property lists *) let get name = let rec get_rec = function hd1::hdl -> if hd1.name = name then hd1 else get_rec hdl | [] -> let entry = {name = name; props = []} in lemmas := entry :: !lemmas; entry in get_rec !lemmas let add_lemma = function | Prop(_, [(Prop(headl,_) as left); right]) -> headl.props <- (left, right) :: headl.props | _ -> assert false (* Substitutions *) type subst = Bind of int * term let get_binding v list = let rec get_rec = function [] -> failwith "unbound" | Bind(w,t)::rest -> if v = w then t else get_rec rest in get_rec list let apply_subst alist term = let rec as_rec = function Var v -> begin try get_binding v alist with Failure _ -> term end | Prop (head,argl) -> Prop (head, List.map as_rec argl) in as_rec term exception Unify let rec unify term1 term2 = unify1 term1 term2 [] and unify1 term1 term2 unify_subst = match term2 with Var v -> begin try if get_binding v unify_subst = term1 then unify_subst else raise Unify with Failure _ -> Bind(v,term1) :: unify_subst end | Prop (head2, argl2) -> match term1 with Var _ -> raise Unify | Prop (head1,argl1) -> if head1 == head2 then unify1_lst argl1 argl2 unify_subst else raise Unify and unify1_lst l1 l2 unify_subst = match (l1, l2) with ([], []) -> unify_subst | (h1::r1, h2::r2) -> unify1_lst r1 r2 (unify1 h1 h2 unify_subst) | _ -> raise Unify let rec rewrite = function Var _ as term -> term | Prop (head, argl) -> rewrite_with_lemmas (Prop (head, List.map rewrite argl)) head.props and rewrite_with_lemmas term lemmas = match lemmas with [] -> term | (t1,t2)::rest -> try rewrite (apply_subst (unify term t1) t2) with Unify -> rewrite_with_lemmas term rest type cterm = CVar of int | CProp of string * cterm list let rec cterm_to_term = function CVar v -> Var v | CProp(p, l) -> Prop(get p, List.map cterm_to_term l) let add t = add_lemma (cterm_to_term t) let _ = add (CProp ("equal", [CProp ("compile",[CVar 5]); CProp ("reverse", [CProp ("codegen",[CProp ("optimize",[CVar 5]); CProp ("nil",[])])])])); add (CProp ("equal", [CProp ("eqp",[CVar 23; CVar 24]); CProp ("equal",[CProp ("fix",[CVar 23]); CProp ("fix",[CVar 24])])])); add (CProp ("equal", [CProp ("gt",[CVar 23; CVar 24]); CProp ("lt",[CVar 24; CVar 23])])); add (CProp ("equal", [CProp ("le",[CVar 23; CVar 24]); CProp ("ge",[CVar 24; CVar 23])])); add (CProp ("equal", [CProp ("ge",[CVar 23; CVar 24]); CProp ("le",[CVar 24; CVar 23])])); add (CProp ("equal", [CProp ("boolean",[CVar 23]); CProp ("or", [CProp ("equal",[CVar 23; CProp ("true",[])]); CProp ("equal",[CVar 23; CProp ("false",[])])])])); add (CProp ("equal", [CProp ("iff",[CVar 23; CVar 24]); CProp ("and", [CProp ("implies",[CVar 23; CVar 24]); CProp ("implies",[CVar 24; CVar 23])])])); add (CProp ("equal", [CProp ("even1",[CVar 23]); CProp ("if", [CProp ("zerop",[CVar 23]); CProp ("true",[]); CProp ("odd",[CProp ("sub1",[CVar 23])])])])); add (CProp ("equal", [CProp ("countps_",[CVar 11; CVar 15]); CProp ("countps_loop",[CVar 11; CVar 15; CProp ("zero",[])])])); add (CProp ("equal", [CProp ("fact_",[CVar 8]); CProp ("fact_loop",[CVar 8; CProp ("one",[])])])); add (CProp ("equal", [CProp ("reverse_",[CVar 23]); CProp ("reverse_loop",[CVar 23; CProp ("nil",[])])])); add (CProp ("equal", [CProp ("divides",[CVar 23; CVar 24]); CProp ("zerop",[CProp ("remainder",[CVar 24; CVar 23])])])); add (CProp ("equal", [CProp ("assume_true",[CVar 21; CVar 0]); CProp ("cons",[CProp ("cons",[CVar 21; CProp ("true",[])]); CVar 0])])); add (CProp ("equal", [CProp ("assume_false",[CVar 21; CVar 0]); CProp ("cons",[CProp ("cons",[CVar 21; CProp ("false",[])]); CVar 0])])); add (CProp ("equal", [CProp ("tautology_checker",[CVar 23]); CProp ("tautologyp",[CProp ("normalize",[CVar 23]); CProp ("nil",[])])])); add (CProp ("equal", [CProp ("falsify",[CVar 23]); CProp ("falsify1",[CProp ("normalize",[CVar 23]); CProp ("nil",[])])])); add (CProp ("equal", [CProp ("prime",[CVar 23]); CProp ("and", [CProp ("not",[CProp ("zerop",[CVar 23])]); CProp ("not", [CProp ("equal",[CVar 23; CProp ("add1",[CProp ("zero",[])])])]); CProp ("prime1",[CVar 23; CProp ("sub1",[CVar 23])])])])); add (CProp ("equal", [CProp ("and",[CVar 15; CVar 16]); CProp ("if", [CVar 15; CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); CProp ("false",[])])])); add (CProp ("equal", [CProp ("or",[CVar 15; CVar 16]); CProp ("if", [CVar 15; CProp ("true",[]); CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); CProp ("false",[])])])); add (CProp ("equal", [CProp ("not",[CVar 15]); CProp ("if",[CVar 15; CProp ("false",[]); CProp ("true",[])])])); add (CProp ("equal", [CProp ("implies",[CVar 15; CVar 16]); CProp ("if", [CVar 15; CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); CProp ("true",[])])])); add (CProp ("equal", [CProp ("fix",[CVar 23]); CProp ("if",[CProp ("numberp",[CVar 23]); CVar 23; CProp ("zero",[])])])); add (CProp ("equal", [CProp ("if",[CProp ("if",[CVar 0; CVar 1; CVar 2]); CVar 3; CVar 4]); CProp ("if", [CVar 0; CProp ("if",[CVar 1; CVar 3; CVar 4]); CProp ("if",[CVar 2; CVar 3; CVar 4])])])); add (CProp ("equal", [CProp ("zerop",[CVar 23]); CProp ("or", [CProp ("equal",[CVar 23; CProp ("zero",[])]); CProp ("not",[CProp ("numberp",[CVar 23])])])])); add (CProp ("equal", [CProp ("plus",[CProp ("plus",[CVar 23; CVar 24]); CVar 25]); CProp ("plus",[CVar 23; CProp ("plus",[CVar 24; CVar 25])])])); add (CProp ("equal", [CProp ("equal",[CProp ("plus",[CVar 0; CVar 1]); CProp ("zero",[])]); CProp ("and",[CProp ("zerop",[CVar 0]); CProp ("zerop",[CVar 1])])])); add (CProp ("equal",[CProp ("difference",[CVar 23; CVar 23]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("equal", [CProp ("plus",[CVar 0; CVar 1]); CProp ("plus",[CVar 0; CVar 2])]); CProp ("equal",[CProp ("fix",[CVar 1]); CProp ("fix",[CVar 2])])])); add (CProp ("equal", [CProp ("equal",[CProp ("zero",[]); CProp ("difference",[CVar 23; CVar 24])]); CProp ("not",[CProp ("gt",[CVar 24; CVar 23])])])); add (CProp ("equal", [CProp ("equal",[CVar 23; CProp ("difference",[CVar 23; CVar 24])]); CProp ("and", [CProp ("numberp",[CVar 23]); CProp ("or", [CProp ("equal",[CVar 23; CProp ("zero",[])]); CProp ("zerop",[CVar 24])])])])); add (CProp ("equal", [CProp ("meaning", [CProp ("plus_tree",[CProp ("append",[CVar 23; CVar 24])]); CVar 0]); CProp ("plus", [CProp ("meaning",[CProp ("plus_tree",[CVar 23]); CVar 0]); CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0])])])); add (CProp ("equal", [CProp ("meaning", [CProp ("plus_tree",[CProp ("plus_fringe",[CVar 23])]); CVar 0]); CProp ("fix",[CProp ("meaning",[CVar 23; CVar 0])])])); add (CProp ("equal", [CProp ("append",[CProp ("append",[CVar 23; CVar 24]); CVar 25]); CProp ("append",[CVar 23; CProp ("append",[CVar 24; CVar 25])])])); add (CProp ("equal", [CProp ("reverse",[CProp ("append",[CVar 0; CVar 1])]); CProp ("append",[CProp ("reverse",[CVar 1]); CProp ("reverse",[CVar 0])])])); add (CProp ("equal", [CProp ("times",[CVar 23; CProp ("plus",[CVar 24; CVar 25])]); CProp ("plus", [CProp ("times",[CVar 23; CVar 24]); CProp ("times",[CVar 23; CVar 25])])])); add (CProp ("equal", [CProp ("times",[CProp ("times",[CVar 23; CVar 24]); CVar 25]); CProp ("times",[CVar 23; CProp ("times",[CVar 24; CVar 25])])])); add (CProp ("equal", [CProp ("equal",[CProp ("times",[CVar 23; CVar 24]); CProp ("zero",[])]); CProp ("or",[CProp ("zerop",[CVar 23]); CProp ("zerop",[CVar 24])])])); add (CProp ("equal", [CProp ("exec",[CProp ("append",[CVar 23; CVar 24]); CVar 15; CVar 4]); CProp ("exec",[CVar 24; CProp ("exec",[CVar 23; CVar 15; CVar 4]); CVar 4])])); add (CProp ("equal", [CProp ("mc_flatten",[CVar 23; CVar 24]); CProp ("append",[CProp ("flatten",[CVar 23]); CVar 24])])); add (CProp ("equal", [CProp ("member",[CVar 23; CProp ("append",[CVar 0; CVar 1])]); CProp ("or", [CProp ("member",[CVar 23; CVar 0]); CProp ("member",[CVar 23; CVar 1])])])); add (CProp ("equal", [CProp ("member",[CVar 23; CProp ("reverse",[CVar 24])]); CProp ("member",[CVar 23; CVar 24])])); add (CProp ("equal", [CProp ("length",[CProp ("reverse",[CVar 23])]); CProp ("length",[CVar 23])])); add (CProp ("equal", [CProp ("member",[CVar 0; CProp ("intersect",[CVar 1; CVar 2])]); CProp ("and", [CProp ("member",[CVar 0; CVar 1]); CProp ("member",[CVar 0; CVar 2])])])); add (CProp ("equal",[CProp ("nth",[CProp ("zero",[]); CVar 8]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("exp",[CVar 8; CProp ("plus",[CVar 9; CVar 10])]); CProp ("times", [CProp ("exp",[CVar 8; CVar 9]); CProp ("exp",[CVar 8; CVar 10])])])); add (CProp ("equal", [CProp ("exp",[CVar 8; CProp ("times",[CVar 9; CVar 10])]); CProp ("exp",[CProp ("exp",[CVar 8; CVar 9]); CVar 10])])); add (CProp ("equal", [CProp ("reverse_loop",[CVar 23; CVar 24]); CProp ("append",[CProp ("reverse",[CVar 23]); CVar 24])])); add (CProp ("equal", [CProp ("reverse_loop",[CVar 23; CProp ("nil",[])]); CProp ("reverse",[CVar 23])])); add (CProp ("equal", [CProp ("count_list",[CVar 25; CProp ("sort_lp",[CVar 23; CVar 24])]); CProp ("plus", [CProp ("count_list",[CVar 25; CVar 23]); CProp ("count_list",[CVar 25; CVar 24])])])); add (CProp ("equal", [CProp ("equal", [CProp ("append",[CVar 0; CVar 1]); CProp ("append",[CVar 0; CVar 2])]); CProp ("equal",[CVar 1; CVar 2])])); add (CProp ("equal", [CProp ("plus", [CProp ("remainder",[CVar 23; CVar 24]); CProp ("times",[CVar 24; CProp ("quotient",[CVar 23; CVar 24])])]); CProp ("fix",[CVar 23])])); add (CProp ("equal", [CProp ("power_eval",[CProp ("big_plus",[CVar 11; CVar 8; CVar 1]); CVar 1]); CProp ("plus",[CProp ("power_eval",[CVar 11; CVar 1]); CVar 8])])); add (CProp ("equal", [CProp ("power_eval", [CProp ("big_plus",[CVar 23; CVar 24; CVar 8; CVar 1]); CVar 1]); CProp ("plus", [CVar 8; CProp ("plus", [CProp ("power_eval",[CVar 23; CVar 1]); CProp ("power_eval",[CVar 24; CVar 1])])])])); add (CProp ("equal", [CProp ("remainder",[CVar 24; CProp ("one",[])]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("lt",[CProp ("remainder",[CVar 23; CVar 24]); CVar 24]); CProp ("not",[CProp ("zerop",[CVar 24])])])); add (CProp ("equal",[CProp ("remainder",[CVar 23; CVar 23]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("lt",[CProp ("quotient",[CVar 8; CVar 9]); CVar 8]); CProp ("and", [CProp ("not",[CProp ("zerop",[CVar 8])]); CProp ("or", [CProp ("zerop",[CVar 9]); CProp ("not",[CProp ("equal",[CVar 9; CProp ("one",[])])])])])])); add (CProp ("equal", [CProp ("lt",[CProp ("remainder",[CVar 23; CVar 24]); CVar 23]); CProp ("and", [CProp ("not",[CProp ("zerop",[CVar 24])]); CProp ("not",[CProp ("zerop",[CVar 23])]); CProp ("not",[CProp ("lt",[CVar 23; CVar 24])])])])); add (CProp ("equal", [CProp ("power_eval",[CProp ("power_rep",[CVar 8; CVar 1]); CVar 1]); CProp ("fix",[CVar 8])])); add (CProp ("equal", [CProp ("power_eval", [CProp ("big_plus", [CProp ("power_rep",[CVar 8; CVar 1]); CProp ("power_rep",[CVar 9; CVar 1]); CProp ("zero",[]); CVar 1]); CVar 1]); CProp ("plus",[CVar 8; CVar 9])])); add (CProp ("equal", [CProp ("gcd",[CVar 23; CVar 24]); CProp ("gcd",[CVar 24; CVar 23])])); add (CProp ("equal", [CProp ("nth",[CProp ("append",[CVar 0; CVar 1]); CVar 8]); CProp ("append", [CProp ("nth",[CVar 0; CVar 8]); CProp ("nth", [CVar 1; CProp ("difference",[CVar 8; CProp ("length",[CVar 0])])])])])); add (CProp ("equal", [CProp ("difference",[CProp ("plus",[CVar 23; CVar 24]); CVar 23]); CProp ("fix",[CVar 24])])); add (CProp ("equal", [CProp ("difference",[CProp ("plus",[CVar 24; CVar 23]); CVar 23]); CProp ("fix",[CVar 24])])); add (CProp ("equal", [CProp ("difference", [CProp ("plus",[CVar 23; CVar 24]); CProp ("plus",[CVar 23; CVar 25])]); CProp ("difference",[CVar 24; CVar 25])])); add (CProp ("equal", [CProp ("times",[CVar 23; CProp ("difference",[CVar 2; CVar 22])]); CProp ("difference", [CProp ("times",[CVar 2; CVar 23]); CProp ("times",[CVar 22; CVar 23])])])); add (CProp ("equal", [CProp ("remainder",[CProp ("times",[CVar 23; CVar 25]); CVar 25]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("difference", [CProp ("plus",[CVar 1; CProp ("plus",[CVar 0; CVar 2])]); CVar 0]); CProp ("plus",[CVar 1; CVar 2])])); add (CProp ("equal", [CProp ("difference", [CProp ("add1",[CProp ("plus",[CVar 24; CVar 25])]); CVar 25]); CProp ("add1",[CVar 24])])); add (CProp ("equal", [CProp ("lt", [CProp ("plus",[CVar 23; CVar 24]); CProp ("plus",[CVar 23; CVar 25])]); CProp ("lt",[CVar 24; CVar 25])])); add (CProp ("equal", [CProp ("lt", [CProp ("times",[CVar 23; CVar 25]); CProp ("times",[CVar 24; CVar 25])]); CProp ("and", [CProp ("not",[CProp ("zerop",[CVar 25])]); CProp ("lt",[CVar 23; CVar 24])])])); add (CProp ("equal", [CProp ("lt",[CVar 24; CProp ("plus",[CVar 23; CVar 24])]); CProp ("not",[CProp ("zerop",[CVar 23])])])); add (CProp ("equal", [CProp ("gcd", [CProp ("times",[CVar 23; CVar 25]); CProp ("times",[CVar 24; CVar 25])]); CProp ("times",[CVar 25; CProp ("gcd",[CVar 23; CVar 24])])])); add (CProp ("equal", [CProp ("value",[CProp ("normalize",[CVar 23]); CVar 0]); CProp ("value",[CVar 23; CVar 0])])); add (CProp ("equal", [CProp ("equal", [CProp ("flatten",[CVar 23]); CProp ("cons",[CVar 24; CProp ("nil",[])])]); CProp ("and", [CProp ("nlistp",[CVar 23]); CProp ("equal",[CVar 23; CVar 24])])])); add (CProp ("equal", [CProp ("listp",[CProp ("gother",[CVar 23])]); CProp ("listp",[CVar 23])])); add (CProp ("equal", [CProp ("samefringe",[CVar 23; CVar 24]); CProp ("equal",[CProp ("flatten",[CVar 23]); CProp ("flatten",[CVar 24])])])); add (CProp ("equal", [CProp ("equal", [CProp ("greatest_factor",[CVar 23; CVar 24]); CProp ("zero",[])]); CProp ("and", [CProp ("or", [CProp ("zerop",[CVar 24]); CProp ("equal",[CVar 24; CProp ("one",[])])]); CProp ("equal",[CVar 23; CProp ("zero",[])])])])); add (CProp ("equal", [CProp ("equal", [CProp ("greatest_factor",[CVar 23; CVar 24]); CProp ("one",[])]); CProp ("equal",[CVar 23; CProp ("one",[])])])); add (CProp ("equal", [CProp ("numberp",[CProp ("greatest_factor",[CVar 23; CVar 24])]); CProp ("not", [CProp ("and", [CProp ("or", [CProp ("zerop",[CVar 24]); CProp ("equal",[CVar 24; CProp ("one",[])])]); CProp ("not",[CProp ("numberp",[CVar 23])])])])])); add (CProp ("equal", [CProp ("times_list",[CProp ("append",[CVar 23; CVar 24])]); CProp ("times", [CProp ("times_list",[CVar 23]); CProp ("times_list",[CVar 24])])])); add (CProp ("equal", [CProp ("prime_list",[CProp ("append",[CVar 23; CVar 24])]); CProp ("and", [CProp ("prime_list",[CVar 23]); CProp ("prime_list",[CVar 24])])])); add (CProp ("equal", [CProp ("equal",[CVar 25; CProp ("times",[CVar 22; CVar 25])]); CProp ("and", [CProp ("numberp",[CVar 25]); CProp ("or", [CProp ("equal",[CVar 25; CProp ("zero",[])]); CProp ("equal",[CVar 22; CProp ("one",[])])])])])); add (CProp ("equal", [CProp ("ge",[CVar 23; CVar 24]); CProp ("not",[CProp ("lt",[CVar 23; CVar 24])])])); add (CProp ("equal", [CProp ("equal",[CVar 23; CProp ("times",[CVar 23; CVar 24])]); CProp ("or", [CProp ("equal",[CVar 23; CProp ("zero",[])]); CProp ("and", [CProp ("numberp",[CVar 23]); CProp ("equal",[CVar 24; CProp ("one",[])])])])])); add (CProp ("equal", [CProp ("remainder",[CProp ("times",[CVar 24; CVar 23]); CVar 24]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("equal",[CProp ("times",[CVar 0; CVar 1]); CProp ("one",[])]); CProp ("and", [CProp ("not",[CProp ("equal",[CVar 0; CProp ("zero",[])])]); CProp ("not",[CProp ("equal",[CVar 1; CProp ("zero",[])])]); CProp ("numberp",[CVar 0]); CProp ("numberp",[CVar 1]); CProp ("equal",[CProp ("sub1",[CVar 0]); CProp ("zero",[])]); CProp ("equal",[CProp ("sub1",[CVar 1]); CProp ("zero",[])])])])); add (CProp ("equal", [CProp ("lt", [CProp ("length",[CProp ("delete",[CVar 23; CVar 11])]); CProp ("length",[CVar 11])]); CProp ("member",[CVar 23; CVar 11])])); add (CProp ("equal", [CProp ("sort2",[CProp ("delete",[CVar 23; CVar 11])]); CProp ("delete",[CVar 23; CProp ("sort2",[CVar 11])])])); add (CProp ("equal",[CProp ("dsort",[CVar 23]); CProp ("sort2",[CVar 23])])); add (CProp ("equal", [CProp ("length", [CProp ("cons", [CVar 0; CProp ("cons", [CVar 1; CProp ("cons", [CVar 2; CProp ("cons", [CVar 3; CProp ("cons",[CVar 4; CProp ("cons",[CVar 5; CVar 6])])])])])])]) ; CProp ("plus",[CProp ("six",[]); CProp ("length",[CVar 6])])])); add (CProp ("equal", [CProp ("difference", [CProp ("add1",[CProp ("add1",[CVar 23])]); CProp ("two",[])]); CProp ("fix",[CVar 23])])); add (CProp ("equal", [CProp ("quotient", [CProp ("plus",[CVar 23; CProp ("plus",[CVar 23; CVar 24])]); CProp ("two",[])]); CProp ("plus",[CVar 23; CProp ("quotient",[CVar 24; CProp ("two",[])])])])); add (CProp ("equal", [CProp ("sigma",[CProp ("zero",[]); CVar 8]); CProp ("quotient", [CProp ("times",[CVar 8; CProp ("add1",[CVar 8])]); CProp ("two",[])])])); add (CProp ("equal", [CProp ("plus",[CVar 23; CProp ("add1",[CVar 24])]); CProp ("if", [CProp ("numberp",[CVar 24]); CProp ("add1",[CProp ("plus",[CVar 23; CVar 24])]); CProp ("add1",[CVar 23])])])); add (CProp ("equal", [CProp ("equal", [CProp ("difference",[CVar 23; CVar 24]); CProp ("difference",[CVar 25; CVar 24])]); CProp ("if", [CProp ("lt",[CVar 23; CVar 24]); CProp ("not",[CProp ("lt",[CVar 24; CVar 25])]); CProp ("if", [CProp ("lt",[CVar 25; CVar 24]); CProp ("not",[CProp ("lt",[CVar 24; CVar 23])]); CProp ("equal",[CProp ("fix",[CVar 23]); CProp ("fix",[CVar 25])])])])]) ); add (CProp ("equal", [CProp ("meaning", [CProp ("plus_tree",[CProp ("delete",[CVar 23; CVar 24])]); CVar 0]); CProp ("if", [CProp ("member",[CVar 23; CVar 24]); CProp ("difference", [CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0]); CProp ("meaning",[CVar 23; CVar 0])]); CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0])])])); add (CProp ("equal", [CProp ("times",[CVar 23; CProp ("add1",[CVar 24])]); CProp ("if", [CProp ("numberp",[CVar 24]); CProp ("plus", [CVar 23; CProp ("times",[CVar 23; CVar 24]); CProp ("fix",[CVar 23])])])])); add (CProp ("equal", [CProp ("nth",[CProp ("nil",[]); CVar 8]); CProp ("if",[CProp ("zerop",[CVar 8]); CProp ("nil",[]); CProp ("zero",[])])])); add (CProp ("equal", [CProp ("last",[CProp ("append",[CVar 0; CVar 1])]); CProp ("if", [CProp ("listp",[CVar 1]); CProp ("last",[CVar 1]); CProp ("if", [CProp ("listp",[CVar 0]); CProp ("cons",[CProp ("car",[CProp ("last",[CVar 0])]); CVar 1]); CVar 1])])])); add (CProp ("equal", [CProp ("equal",[CProp ("lt",[CVar 23; CVar 24]); CVar 25]); CProp ("if", [CProp ("lt",[CVar 23; CVar 24]); CProp ("equal",[CProp ("true",[]); CVar 25]); CProp ("equal",[CProp ("false",[]); CVar 25])])])); add (CProp ("equal", [CProp ("assignment",[CVar 23; CProp ("append",[CVar 0; CVar 1])]); CProp ("if", [CProp ("assignedp",[CVar 23; CVar 0]); CProp ("assignment",[CVar 23; CVar 0]); CProp ("assignment",[CVar 23; CVar 1])])])); add (CProp ("equal", [CProp ("car",[CProp ("gother",[CVar 23])]); CProp ("if", [CProp ("listp",[CVar 23]); CProp ("car",[CProp ("flatten",[CVar 23])]); CProp ("zero",[])])])); add (CProp ("equal", [CProp ("flatten",[CProp ("cdr",[CProp ("gother",[CVar 23])])]); CProp ("if", [CProp ("listp",[CVar 23]); CProp ("cdr",[CProp ("flatten",[CVar 23])]); CProp ("cons",[CProp ("zero",[]); CProp ("nil",[])])])])); add (CProp ("equal", [CProp ("quotient",[CProp ("times",[CVar 24; CVar 23]); CVar 24]); CProp ("if", [CProp ("zerop",[CVar 24]); CProp ("zero",[]); CProp ("fix",[CVar 23])])])); add (CProp ("equal", [CProp ("get",[CVar 9; CProp ("set",[CVar 8; CVar 21; CVar 12])]); CProp ("if", [CProp ("eqp",[CVar 9; CVar 8]); CVar 21; CProp ("get",[CVar 9; CVar 12])])])) (* Tautology checker *) let truep x lst = match x with Prop(head, _) -> head.name = "true" || List.mem x lst | _ -> List.mem x lst and falsep x lst = match x with Prop(head, _) -> head.name = "false" || List.mem x lst | _ -> List.mem x lst let rec tautologyp x true_lst false_lst = if truep x true_lst then true else if falsep x false_lst then false else begin (* print_term x; print_newline(); *) match x with Var _ -> false | Prop (head,[test; yes; no]) -> if head.name = "if" then if truep test true_lst then tautologyp yes true_lst false_lst else if falsep test false_lst then tautologyp no true_lst false_lst else tautologyp yes (test::true_lst) false_lst && tautologyp no true_lst (test::false_lst) else false | _ -> assert false end let tautp x = (* print_term x; print_string"\n"; *) let y = rewrite x in (* print_term y; print_string "\n"; *) tautologyp y [] [] (* the benchmark *) let subst = [Bind(23, cterm_to_term( CProp ("f", [CProp ("plus", [CProp ("plus",[CVar 0; CVar 1]); CProp ("plus",[CVar 2; CProp ("zero",[])])])]))); Bind(24, cterm_to_term( CProp ("f", [CProp ("times", [CProp ("times",[CVar 0; CVar 1]); CProp ("plus",[CVar 2; CVar 3])])]))); Bind(25, cterm_to_term( CProp ("f", [CProp ("reverse", [CProp ("append", [CProp ("append",[CVar 0; CVar 1]); CProp ("nil",[])])])]))); Bind(20, cterm_to_term( CProp ("equal", [CProp ("plus",[CVar 0; CVar 1]); CProp ("difference",[CVar 23; CVar 24])]))); Bind(22, cterm_to_term( CProp ("lt", [CProp ("remainder",[CVar 0; CVar 1]); CProp ("member",[CVar 0; CProp ("length",[CVar 1])])])))] let term = cterm_to_term( CProp ("implies", [CProp ("and", [CProp ("implies",[CVar 23; CVar 24]); CProp ("and", [CProp ("implies",[CVar 24; CVar 25]); CProp ("and", [CProp ("implies",[CVar 25; CVar 20]); CProp ("implies",[CVar 20; CVar 22])])])]); CProp ("implies",[CVar 23; CVar 22])])) let _ = let ok = ref true in for i = 1 to 50 do if not (tautp (apply_subst subst term)) then ok := false done; if !ok then print_string "Proved!\n" else print_string "Cannot prove!\n"; exit 0 (********* with failure s -> print_string "Exception failure("; print_string s; print_string ")\n" | Unify -> print_string "Exception Unify\n" | match_failure(file,start,stop) -> print_string "Exception match_failure("; print_string file; print_string ","; print_int start; print_string ","; print_int stop; print_string ")\n" | _ -> print_string "Exception ?\n" **********) mingw-ocaml/ocaml/testsuite/tests/misc/taku.ml0000644000175000017500000000205512124403241021104 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) let rec tak (x, y, z) = if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y)) else z let rec repeat n = if n <= 0 then 0 else tak(18,12,6) + repeat(n-1) let _ = print_int (repeat 2000); print_newline(); exit 0 mingw-ocaml/ocaml/testsuite/tests/misc/boyer.reference0000644000175000017500000000001012124403241022573 0ustar tootstootsProved! mingw-ocaml/ocaml/testsuite/tests/misc/takc.reference0000644000175000017500000000000612124403241022402 0ustar tootstoots14000 mingw-ocaml/ocaml/testsuite/tests/misc/takc.ml0000644000175000017500000000204512124403241021061 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) let rec tak x y z = if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y) else z let rec repeat n = if n <= 0 then 0 else tak 18 12 6 + repeat(n-1) let _ = print_int (repeat 2000); print_newline(); exit 0 mingw-ocaml/ocaml/testsuite/tests/misc/sieve.reference0000644000175000017500000007127512124403241022613 0ustar tootstoots 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509 521 523 541 547 557 563 569 571 577 587 593 599 601 607 613 617 619 631 641 643 647 653 659 661 673 677 683 691 701 709 719 727 733 739 743 751 757 761 769 773 787 797 809 811 821 823 827 829 839 853 857 859 863 877 881 883 887 907 911 919 929 937 941 947 953 967 971 977 983 991 997 1009 1013 1019 1021 1031 1033 1039 1049 1051 1061 1063 1069 1087 1091 1093 1097 1103 1109 1117 1123 1129 1151 1153 1163 1171 1181 1187 1193 1201 1213 1217 1223 1229 1231 1237 1249 1259 1277 1279 1283 1289 1291 1297 1301 1303 1307 1319 1321 1327 1361 1367 1373 1381 1399 1409 1423 1427 1429 1433 1439 1447 1451 1453 1459 1471 1481 1483 1487 1489 1493 1499 1511 1523 1531 1543 1549 1553 1559 1567 1571 1579 1583 1597 1601 1607 1609 1613 1619 1621 1627 1637 1657 1663 1667 1669 1693 1697 1699 1709 1721 1723 1733 1741 1747 1753 1759 1777 1783 1787 1789 1801 1811 1823 1831 1847 1861 1867 1871 1873 1877 1879 1889 1901 1907 1913 1931 1933 1949 1951 1973 1979 1987 1993 1997 1999 2003 2011 2017 2027 2029 2039 2053 2063 2069 2081 2083 2087 2089 2099 2111 2113 2129 2131 2137 2141 2143 2153 2161 2179 2203 2207 2213 2221 2237 2239 2243 2251 2267 2269 2273 2281 2287 2293 2297 2309 2311 2333 2339 2341 2347 2351 2357 2371 2377 2381 2383 2389 2393 2399 2411 2417 2423 2437 2441 2447 2459 2467 2473 2477 2503 2521 2531 2539 2543 2549 2551 2557 2579 2591 2593 2609 2617 2621 2633 2647 2657 2659 2663 2671 2677 2683 2687 2689 2693 2699 2707 2711 2713 2719 2729 2731 2741 2749 2753 2767 2777 2789 2791 2797 2801 2803 2819 2833 2837 2843 2851 2857 2861 2879 2887 2897 2903 2909 2917 2927 2939 2953 2957 2963 2969 2971 2999 3001 3011 3019 3023 3037 3041 3049 3061 3067 3079 3083 3089 3109 3119 3121 3137 3163 3167 3169 3181 3187 3191 3203 3209 3217 3221 3229 3251 3253 3257 3259 3271 3299 3301 3307 3313 3319 3323 3329 3331 3343 3347 3359 3361 3371 3373 3389 3391 3407 3413 3433 3449 3457 3461 3463 3467 3469 3491 3499 3511 3517 3527 3529 3533 3539 3541 3547 3557 3559 3571 3581 3583 3593 3607 3613 3617 3623 3631 3637 3643 3659 3671 3673 3677 3691 3697 3701 3709 3719 3727 3733 3739 3761 3767 3769 3779 3793 3797 3803 3821 3823 3833 3847 3851 3853 3863 3877 3881 3889 3907 3911 3917 3919 3923 3929 3931 3943 3947 3967 3989 4001 4003 4007 4013 4019 4021 4027 4049 4051 4057 4073 4079 4091 4093 4099 4111 4127 4129 4133 4139 4153 4157 4159 4177 4201 4211 4217 4219 4229 4231 4241 4243 4253 4259 4261 4271 4273 4283 4289 4297 4327 4337 4339 4349 4357 4363 4373 4391 4397 4409 4421 4423 4441 4447 4451 4457 4463 4481 4483 4493 4507 4513 4517 4519 4523 4547 4549 4561 4567 4583 4591 4597 4603 4621 4637 4639 4643 4649 4651 4657 4663 4673 4679 4691 4703 4721 4723 4729 4733 4751 4759 4783 4787 4789 4793 4799 4801 4813 4817 4831 4861 4871 4877 4889 4903 4909 4919 4931 4933 4937 4943 4951 4957 4967 4969 4973 4987 4993 4999 5003 5009 5011 5021 5023 5039 5051 5059 5077 5081 5087 5099 5101 5107 5113 5119 5147 5153 5167 5171 5179 5189 5197 5209 5227 5231 5233 5237 5261 5273 5279 5281 5297 5303 5309 5323 5333 5347 5351 5381 5387 5393 5399 5407 5413 5417 5419 5431 5437 5441 5443 5449 5471 5477 5479 5483 5501 5503 5507 5519 5521 5527 5531 5557 5563 5569 5573 5581 5591 5623 5639 5641 5647 5651 5653 5657 5659 5669 5683 5689 5693 5701 5711 5717 5737 5741 5743 5749 5779 5783 5791 5801 5807 5813 5821 5827 5839 5843 5849 5851 5857 5861 5867 5869 5879 5881 5897 5903 5923 5927 5939 5953 5981 5987 6007 6011 6029 6037 6043 6047 6053 6067 6073 6079 6089 6091 6101 6113 6121 6131 6133 6143 6151 6163 6173 6197 6199 6203 6211 6217 6221 6229 6247 6257 6263 6269 6271 6277 6287 6299 6301 6311 6317 6323 6329 6337 6343 6353 6359 6361 6367 6373 6379 6389 6397 6421 6427 6449 6451 6469 6473 6481 6491 6521 6529 6547 6551 6553 6563 6569 6571 6577 6581 6599 6607 6619 6637 6653 6659 6661 6673 6679 6689 6691 6701 6703 6709 6719 6733 6737 6761 6763 6779 6781 6791 6793 6803 6823 6827 6829 6833 6841 6857 6863 6869 6871 6883 6899 6907 6911 6917 6947 6949 6959 6961 6967 6971 6977 6983 6991 6997 7001 7013 7019 7027 7039 7043 7057 7069 7079 7103 7109 7121 7127 7129 7151 7159 7177 7187 7193 7207 7211 7213 7219 7229 7237 7243 7247 7253 7283 7297 7307 7309 7321 7331 7333 7349 7351 7369 7393 7411 7417 7433 7451 7457 7459 7477 7481 7487 7489 7499 7507 7517 7523 7529 7537 7541 7547 7549 7559 7561 7573 7577 7583 7589 7591 7603 7607 7621 7639 7643 7649 7669 7673 7681 7687 7691 7699 7703 7717 7723 7727 7741 7753 7757 7759 7789 7793 7817 7823 7829 7841 7853 7867 7873 7877 7879 7883 7901 7907 7919 7927 7933 7937 7949 7951 7963 7993 8009 8011 8017 8039 8053 8059 8069 8081 8087 8089 8093 8101 8111 8117 8123 8147 8161 8167 8171 8179 8191 8209 8219 8221 8231 8233 8237 8243 8263 8269 8273 8287 8291 8293 8297 8311 8317 8329 8353 8363 8369 8377 8387 8389 8419 8423 8429 8431 8443 8447 8461 8467 8501 8513 8521 8527 8537 8539 8543 8563 8573 8581 8597 8599 8609 8623 8627 8629 8641 8647 8663 8669 8677 8681 8689 8693 8699 8707 8713 8719 8731 8737 8741 8747 8753 8761 8779 8783 8803 8807 8819 8821 8831 8837 8839 8849 8861 8863 8867 8887 8893 8923 8929 8933 8941 8951 8963 8969 8971 8999 9001 9007 9011 9013 9029 9041 9043 9049 9059 9067 9091 9103 9109 9127 9133 9137 9151 9157 9161 9173 9181 9187 9199 9203 9209 9221 9227 9239 9241 9257 9277 9281 9283 9293 9311 9319 9323 9337 9341 9343 9349 9371 9377 9391 9397 9403 9413 9419 9421 9431 9433 9437 9439 9461 9463 9467 9473 9479 9491 9497 9511 9521 9533 9539 9547 9551 9587 9601 9613 9619 9623 9629 9631 9643 9649 9661 9677 9679 9689 9697 9719 9721 9733 9739 9743 9749 9767 9769 9781 9787 9791 9803 9811 9817 9829 9833 9839 9851 9857 9859 9871 9883 9887 9901 9907 9923 9929 9931 9941 9949 9967 9973 10007 10009 10037 10039 10061 10067 10069 10079 10091 10093 10099 10103 10111 10133 10139 10141 10151 10159 10163 10169 10177 10181 10193 10211 10223 10243 10247 10253 10259 10267 10271 10273 10289 10301 10303 10313 10321 10331 10333 10337 10343 10357 10369 10391 10399 10427 10429 10433 10453 10457 10459 10463 10477 10487 10499 10501 10513 10529 10531 10559 10567 10589 10597 10601 10607 10613 10627 10631 10639 10651 10657 10663 10667 10687 10691 10709 10711 10723 10729 10733 10739 10753 10771 10781 10789 10799 10831 10837 10847 10853 10859 10861 10867 10883 10889 10891 10903 10909 10937 10939 10949 10957 10973 10979 10987 10993 11003 11027 11047 11057 11059 11069 11071 11083 11087 11093 11113 11117 11119 11131 11149 11159 11161 11171 11173 11177 11197 11213 11239 11243 11251 11257 11261 11273 11279 11287 11299 11311 11317 11321 11329 11351 11353 11369 11383 11393 11399 11411 11423 11437 11443 11447 11467 11471 11483 11489 11491 11497 11503 11519 11527 11549 11551 11579 11587 11593 11597 11617 11621 11633 11657 11677 11681 11689 11699 11701 11717 11719 11731 11743 11777 11779 11783 11789 11801 11807 11813 11821 11827 11831 11833 11839 11863 11867 11887 11897 11903 11909 11923 11927 11933 11939 11941 11953 11959 11969 11971 11981 11987 12007 12011 12037 12041 12043 12049 12071 12073 12097 12101 12107 12109 12113 12119 12143 12149 12157 12161 12163 12197 12203 12211 12227 12239 12241 12251 12253 12263 12269 12277 12281 12289 12301 12323 12329 12343 12347 12373 12377 12379 12391 12401 12409 12413 12421 12433 12437 12451 12457 12473 12479 12487 12491 12497 12503 12511 12517 12527 12539 12541 12547 12553 12569 12577 12583 12589 12601 12611 12613 12619 12637 12641 12647 12653 12659 12671 12689 12697 12703 12713 12721 12739 12743 12757 12763 12781 12791 12799 12809 12821 12823 12829 12841 12853 12889 12893 12899 12907 12911 12917 12919 12923 12941 12953 12959 12967 12973 12979 12983 13001 13003 13007 13009 13033 13037 13043 13049 13063 13093 13099 13103 13109 13121 13127 13147 13151 13159 13163 13171 13177 13183 13187 13217 13219 13229 13241 13249 13259 13267 13291 13297 13309 13313 13327 13331 13337 13339 13367 13381 13397 13399 13411 13417 13421 13441 13451 13457 13463 13469 13477 13487 13499 13513 13523 13537 13553 13567 13577 13591 13597 13613 13619 13627 13633 13649 13669 13679 13681 13687 13691 13693 13697 13709 13711 13721 13723 13729 13751 13757 13759 13763 13781 13789 13799 13807 13829 13831 13841 13859 13873 13877 13879 13883 13901 13903 13907 13913 13921 13931 13933 13963 13967 13997 13999 14009 14011 14029 14033 14051 14057 14071 14081 14083 14087 14107 14143 14149 14153 14159 14173 14177 14197 14207 14221 14243 14249 14251 14281 14293 14303 14321 14323 14327 14341 14347 14369 14387 14389 14401 14407 14411 14419 14423 14431 14437 14447 14449 14461 14479 14489 14503 14519 14533 14537 14543 14549 14551 14557 14561 14563 14591 14593 14621 14627 14629 14633 14639 14653 14657 14669 14683 14699 14713 14717 14723 14731 14737 14741 14747 14753 14759 14767 14771 14779 14783 14797 14813 14821 14827 14831 14843 14851 14867 14869 14879 14887 14891 14897 14923 14929 14939 14947 14951 14957 14969 14983 15013 15017 15031 15053 15061 15073 15077 15083 15091 15101 15107 15121 15131 15137 15139 15149 15161 15173 15187 15193 15199 15217 15227 15233 15241 15259 15263 15269 15271 15277 15287 15289 15299 15307 15313 15319 15329 15331 15349 15359 15361 15373 15377 15383 15391 15401 15413 15427 15439 15443 15451 15461 15467 15473 15493 15497 15511 15527 15541 15551 15559 15569 15581 15583 15601 15607 15619 15629 15641 15643 15647 15649 15661 15667 15671 15679 15683 15727 15731 15733 15737 15739 15749 15761 15767 15773 15787 15791 15797 15803 15809 15817 15823 15859 15877 15881 15887 15889 15901 15907 15913 15919 15923 15937 15959 15971 15973 15991 16001 16007 16033 16057 16061 16063 16067 16069 16073 16087 16091 16097 16103 16111 16127 16139 16141 16183 16187 16189 16193 16217 16223 16229 16231 16249 16253 16267 16273 16301 16319 16333 16339 16349 16361 16363 16369 16381 16411 16417 16421 16427 16433 16447 16451 16453 16477 16481 16487 16493 16519 16529 16547 16553 16561 16567 16573 16603 16607 16619 16631 16633 16649 16651 16657 16661 16673 16691 16693 16699 16703 16729 16741 16747 16759 16763 16787 16811 16823 16829 16831 16843 16871 16879 16883 16889 16901 16903 16921 16927 16931 16937 16943 16963 16979 16981 16987 16993 17011 17021 17027 17029 17033 17041 17047 17053 17077 17093 17099 17107 17117 17123 17137 17159 17167 17183 17189 17191 17203 17207 17209 17231 17239 17257 17291 17293 17299 17317 17321 17327 17333 17341 17351 17359 17377 17383 17387 17389 17393 17401 17417 17419 17431 17443 17449 17467 17471 17477 17483 17489 17491 17497 17509 17519 17539 17551 17569 17573 17579 17581 17597 17599 17609 17623 17627 17657 17659 17669 17681 17683 17707 17713 17729 17737 17747 17749 17761 17783 17789 17791 17807 17827 17837 17839 17851 17863 17881 17891 17903 17909 17911 17921 17923 17929 17939 17957 17959 17971 17977 17981 17987 17989 18013 18041 18043 18047 18049 18059 18061 18077 18089 18097 18119 18121 18127 18131 18133 18143 18149 18169 18181 18191 18199 18211 18217 18223 18229 18233 18251 18253 18257 18269 18287 18289 18301 18307 18311 18313 18329 18341 18353 18367 18371 18379 18397 18401 18413 18427 18433 18439 18443 18451 18457 18461 18481 18493 18503 18517 18521 18523 18539 18541 18553 18583 18587 18593 18617 18637 18661 18671 18679 18691 18701 18713 18719 18731 18743 18749 18757 18773 18787 18793 18797 18803 18839 18859 18869 18899 18911 18913 18917 18919 18947 18959 18973 18979 19001 19009 19013 19031 19037 19051 19069 19073 19079 19081 19087 19121 19139 19141 19157 19163 19181 19183 19207 19211 19213 19219 19231 19237 19249 19259 19267 19273 19289 19301 19309 19319 19333 19373 19379 19381 19387 19391 19403 19417 19421 19423 19427 19429 19433 19441 19447 19457 19463 19469 19471 19477 19483 19489 19501 19507 19531 19541 19543 19553 19559 19571 19577 19583 19597 19603 19609 19661 19681 19687 19697 19699 19709 19717 19727 19739 19751 19753 19759 19763 19777 19793 19801 19813 19819 19841 19843 19853 19861 19867 19889 19891 19913 19919 19927 19937 19949 19961 19963 19973 19979 19991 19993 19997 20011 20021 20023 20029 20047 20051 20063 20071 20089 20101 20107 20113 20117 20123 20129 20143 20147 20149 20161 20173 20177 20183 20201 20219 20231 20233 20249 20261 20269 20287 20297 20323 20327 20333 20341 20347 20353 20357 20359 20369 20389 20393 20399 20407 20411 20431 20441 20443 20477 20479 20483 20507 20509 20521 20533 20543 20549 20551 20563 20593 20599 20611 20627 20639 20641 20663 20681 20693 20707 20717 20719 20731 20743 20747 20749 20753 20759 20771 20773 20789 20807 20809 20849 20857 20873 20879 20887 20897 20899 20903 20921 20929 20939 20947 20959 20963 20981 20983 21001 21011 21013 21017 21019 21023 21031 21059 21061 21067 21089 21101 21107 21121 21139 21143 21149 21157 21163 21169 21179 21187 21191 21193 21211 21221 21227 21247 21269 21277 21283 21313 21317 21319 21323 21341 21347 21377 21379 21383 21391 21397 21401 21407 21419 21433 21467 21481 21487 21491 21493 21499 21503 21517 21521 21523 21529 21557 21559 21563 21569 21577 21587 21589 21599 21601 21611 21613 21617 21647 21649 21661 21673 21683 21701 21713 21727 21737 21739 21751 21757 21767 21773 21787 21799 21803 21817 21821 21839 21841 21851 21859 21863 21871 21881 21893 21911 21929 21937 21943 21961 21977 21991 21997 22003 22013 22027 22031 22037 22039 22051 22063 22067 22073 22079 22091 22093 22109 22111 22123 22129 22133 22147 22153 22157 22159 22171 22189 22193 22229 22247 22259 22271 22273 22277 22279 22283 22291 22303 22307 22343 22349 22367 22369 22381 22391 22397 22409 22433 22441 22447 22453 22469 22481 22483 22501 22511 22531 22541 22543 22549 22567 22571 22573 22613 22619 22621 22637 22639 22643 22651 22669 22679 22691 22697 22699 22709 22717 22721 22727 22739 22741 22751 22769 22777 22783 22787 22807 22811 22817 22853 22859 22861 22871 22877 22901 22907 22921 22937 22943 22961 22963 22973 22993 23003 23011 23017 23021 23027 23029 23039 23041 23053 23057 23059 23063 23071 23081 23087 23099 23117 23131 23143 23159 23167 23173 23189 23197 23201 23203 23209 23227 23251 23269 23279 23291 23293 23297 23311 23321 23327 23333 23339 23357 23369 23371 23399 23417 23431 23447 23459 23473 23497 23509 23531 23537 23539 23549 23557 23561 23563 23567 23581 23593 23599 23603 23609 23623 23627 23629 23633 23663 23669 23671 23677 23687 23689 23719 23741 23743 23747 23753 23761 23767 23773 23789 23801 23813 23819 23827 23831 23833 23857 23869 23873 23879 23887 23893 23899 23909 23911 23917 23929 23957 23971 23977 23981 23993 24001 24007 24019 24023 24029 24043 24049 24061 24071 24077 24083 24091 24097 24103 24107 24109 24113 24121 24133 24137 24151 24169 24179 24181 24197 24203 24223 24229 24239 24247 24251 24281 24317 24329 24337 24359 24371 24373 24379 24391 24407 24413 24419 24421 24439 24443 24469 24473 24481 24499 24509 24517 24527 24533 24547 24551 24571 24593 24611 24623 24631 24659 24671 24677 24683 24691 24697 24709 24733 24749 24763 24767 24781 24793 24799 24809 24821 24841 24847 24851 24859 24877 24889 24907 24917 24919 24923 24943 24953 24967 24971 24977 24979 24989 25013 25031 25033 25037 25057 25073 25087 25097 25111 25117 25121 25127 25147 25153 25163 25169 25171 25183 25189 25219 25229 25237 25243 25247 25253 25261 25301 25303 25307 25309 25321 25339 25343 25349 25357 25367 25373 25391 25409 25411 25423 25439 25447 25453 25457 25463 25469 25471 25523 25537 25541 25561 25577 25579 25583 25589 25601 25603 25609 25621 25633 25639 25643 25657 25667 25673 25679 25693 25703 25717 25733 25741 25747 25759 25763 25771 25793 25799 25801 25819 25841 25847 25849 25867 25873 25889 25903 25913 25919 25931 25933 25939 25943 25951 25969 25981 25997 25999 26003 26017 26021 26029 26041 26053 26083 26099 26107 26111 26113 26119 26141 26153 26161 26171 26177 26183 26189 26203 26209 26227 26237 26249 26251 26261 26263 26267 26293 26297 26309 26317 26321 26339 26347 26357 26371 26387 26393 26399 26407 26417 26423 26431 26437 26449 26459 26479 26489 26497 26501 26513 26539 26557 26561 26573 26591 26597 26627 26633 26641 26647 26669 26681 26683 26687 26693 26699 26701 26711 26713 26717 26723 26729 26731 26737 26759 26777 26783 26801 26813 26821 26833 26839 26849 26861 26863 26879 26881 26891 26893 26903 26921 26927 26947 26951 26953 26959 26981 26987 26993 27011 27017 27031 27043 27059 27061 27067 27073 27077 27091 27103 27107 27109 27127 27143 27179 27191 27197 27211 27239 27241 27253 27259 27271 27277 27281 27283 27299 27329 27337 27361 27367 27397 27407 27409 27427 27431 27437 27449 27457 27479 27481 27487 27509 27527 27529 27539 27541 27551 27581 27583 27611 27617 27631 27647 27653 27673 27689 27691 27697 27701 27733 27737 27739 27743 27749 27751 27763 27767 27773 27779 27791 27793 27799 27803 27809 27817 27823 27827 27847 27851 27883 27893 27901 27917 27919 27941 27943 27947 27953 27961 27967 27983 27997 28001 28019 28027 28031 28051 28057 28069 28081 28087 28097 28099 28109 28111 28123 28151 28163 28181 28183 28201 28211 28219 28229 28277 28279 28283 28289 28297 28307 28309 28319 28349 28351 28387 28393 28403 28409 28411 28429 28433 28439 28447 28463 28477 28493 28499 28513 28517 28537 28541 28547 28549 28559 28571 28573 28579 28591 28597 28603 28607 28619 28621 28627 28631 28643 28649 28657 28661 28663 28669 28687 28697 28703 28711 28723 28729 28751 28753 28759 28771 28789 28793 28807 28813 28817 28837 28843 28859 28867 28871 28879 28901 28909 28921 28927 28933 28949 28961 28979 29009 29017 29021 29023 29027 29033 29059 29063 29077 29101 29123 29129 29131 29137 29147 29153 29167 29173 29179 29191 29201 29207 29209 29221 29231 29243 29251 29269 29287 29297 29303 29311 29327 29333 29339 29347 29363 29383 29387 29389 29399 29401 29411 29423 29429 29437 29443 29453 29473 29483 29501 29527 29531 29537 29567 29569 29573 29581 29587 29599 29611 29629 29633 29641 29663 29669 29671 29683 29717 29723 29741 29753 29759 29761 29789 29803 29819 29833 29837 29851 29863 29867 29873 29879 29881 29917 29921 29927 29947 29959 29983 29989 30011 30013 30029 30047 30059 30071 30089 30091 30097 30103 30109 30113 30119 30133 30137 30139 30161 30169 30181 30187 30197 30203 30211 30223 30241 30253 30259 30269 30271 30293 30307 30313 30319 30323 30341 30347 30367 30389 30391 30403 30427 30431 30449 30467 30469 30491 30493 30497 30509 30517 30529 30539 30553 30557 30559 30577 30593 30631 30637 30643 30649 30661 30671 30677 30689 30697 30703 30707 30713 30727 30757 30763 30773 30781 30803 30809 30817 30829 30839 30841 30851 30853 30859 30869 30871 30881 30893 30911 30931 30937 30941 30949 30971 30977 30983 31013 31019 31033 31039 31051 31063 31069 31079 31081 31091 31121 31123 31139 31147 31151 31153 31159 31177 31181 31183 31189 31193 31219 31223 31231 31237 31247 31249 31253 31259 31267 31271 31277 31307 31319 31321 31327 31333 31337 31357 31379 31387 31391 31393 31397 31469 31477 31481 31489 31511 31513 31517 31531 31541 31543 31547 31567 31573 31583 31601 31607 31627 31643 31649 31657 31663 31667 31687 31699 31721 31723 31727 31729 31741 31751 31769 31771 31793 31799 31817 31847 31849 31859 31873 31883 31891 31907 31957 31963 31973 31981 31991 32003 32009 32027 32029 32051 32057 32059 32063 32069 32077 32083 32089 32099 32117 32119 32141 32143 32159 32173 32183 32189 32191 32203 32213 32233 32237 32251 32257 32261 32297 32299 32303 32309 32321 32323 32327 32341 32353 32359 32363 32369 32371 32377 32381 32401 32411 32413 32423 32429 32441 32443 32467 32479 32491 32497 32503 32507 32531 32533 32537 32561 32563 32569 32573 32579 32587 32603 32609 32611 32621 32633 32647 32653 32687 32693 32707 32713 32717 32719 32749 32771 32779 32783 32789 32797 32801 32803 32831 32833 32839 32843 32869 32887 32909 32911 32917 32933 32939 32941 32957 32969 32971 32983 32987 32993 32999 33013 33023 33029 33037 33049 33053 33071 33073 33083 33091 33107 33113 33119 33149 33151 33161 33179 33181 33191 33199 33203 33211 33223 33247 33287 33289 33301 33311 33317 33329 33331 33343 33347 33349 33353 33359 33377 33391 33403 33409 33413 33427 33457 33461 33469 33479 33487 33493 33503 33521 33529 33533 33547 33563 33569 33577 33581 33587 33589 33599 33601 33613 33617 33619 33623 33629 33637 33641 33647 33679 33703 33713 33721 33739 33749 33751 33757 33767 33769 33773 33791 33797 33809 33811 33827 33829 33851 33857 33863 33871 33889 33893 33911 33923 33931 33937 33941 33961 33967 33997 34019 34031 34033 34039 34057 34061 34123 34127 34129 34141 34147 34157 34159 34171 34183 34211 34213 34217 34231 34253 34259 34261 34267 34273 34283 34297 34301 34303 34313 34319 34327 34337 34351 34361 34367 34369 34381 34403 34421 34429 34439 34457 34469 34471 34483 34487 34499 34501 34511 34513 34519 34537 34543 34549 34583 34589 34591 34603 34607 34613 34631 34649 34651 34667 34673 34679 34687 34693 34703 34721 34729 34739 34747 34757 34759 34763 34781 34807 34819 34841 34843 34847 34849 34871 34877 34883 34897 34913 34919 34939 34949 34961 34963 34981 35023 35027 35051 35053 35059 35069 35081 35083 35089 35099 35107 35111 35117 35129 35141 35149 35153 35159 35171 35201 35221 35227 35251 35257 35267 35279 35281 35291 35311 35317 35323 35327 35339 35353 35363 35381 35393 35401 35407 35419 35423 35437 35447 35449 35461 35491 35507 35509 35521 35527 35531 35533 35537 35543 35569 35573 35591 35593 35597 35603 35617 35671 35677 35729 35731 35747 35753 35759 35771 35797 35801 35803 35809 35831 35837 35839 35851 35863 35869 35879 35897 35899 35911 35923 35933 35951 35963 35969 35977 35983 35993 35999 36007 36011 36013 36017 36037 36061 36067 36073 36083 36097 36107 36109 36131 36137 36151 36161 36187 36191 36209 36217 36229 36241 36251 36263 36269 36277 36293 36299 36307 36313 36319 36341 36343 36353 36373 36383 36389 36433 36451 36457 36467 36469 36473 36479 36493 36497 36523 36527 36529 36541 36551 36559 36563 36571 36583 36587 36599 36607 36629 36637 36643 36653 36671 36677 36683 36691 36697 36709 36713 36721 36739 36749 36761 36767 36779 36781 36787 36791 36793 36809 36821 36833 36847 36857 36871 36877 36887 36899 36901 36913 36919 36923 36929 36931 36943 36947 36973 36979 36997 37003 37013 37019 37021 37039 37049 37057 37061 37087 37097 37117 37123 37139 37159 37171 37181 37189 37199 37201 37217 37223 37243 37253 37273 37277 37307 37309 37313 37321 37337 37339 37357 37361 37363 37369 37379 37397 37409 37423 37441 37447 37463 37483 37489 37493 37501 37507 37511 37517 37529 37537 37547 37549 37561 37567 37571 37573 37579 37589 37591 37607 37619 37633 37643 37649 37657 37663 37691 37693 37699 37717 37747 37781 37783 37799 37811 37813 37831 37847 37853 37861 37871 37879 37889 37897 37907 37951 37957 37963 37967 37987 37991 37993 37997 38011 38039 38047 38053 38069 38083 38113 38119 38149 38153 38167 38177 38183 38189 38197 38201 38219 38231 38237 38239 38261 38273 38281 38287 38299 38303 38317 38321 38327 38329 38333 38351 38371 38377 38393 38431 38447 38449 38453 38459 38461 38501 38543 38557 38561 38567 38569 38593 38603 38609 38611 38629 38639 38651 38653 38669 38671 38677 38693 38699 38707 38711 38713 38723 38729 38737 38747 38749 38767 38783 38791 38803 38821 38833 38839 38851 38861 38867 38873 38891 38903 38917 38921 38923 38933 38953 38959 38971 38977 38993 39019 39023 39041 39043 39047 39079 39089 39097 39103 39107 39113 39119 39133 39139 39157 39161 39163 39181 39191 39199 39209 39217 39227 39229 39233 39239 39241 39251 39293 39301 39313 39317 39323 39341 39343 39359 39367 39371 39373 39383 39397 39409 39419 39439 39443 39451 39461 39499 39503 39509 39511 39521 39541 39551 39563 39569 39581 39607 39619 39623 39631 39659 39667 39671 39679 39703 39709 39719 39727 39733 39749 39761 39769 39779 39791 39799 39821 39827 39829 39839 39841 39847 39857 39863 39869 39877 39883 39887 39901 39929 39937 39953 39971 39979 39983 39989 40009 40013 40031 40037 40039 40063 40087 40093 40099 40111 40123 40127 40129 40151 40153 40163 40169 40177 40189 40193 40213 40231 40237 40241 40253 40277 40283 40289 40343 40351 40357 40361 40387 40423 40427 40429 40433 40459 40471 40483 40487 40493 40499 40507 40519 40529 40531 40543 40559 40577 40583 40591 40597 40609 40627 40637 40639 40693 40697 40699 40709 40739 40751 40759 40763 40771 40787 40801 40813 40819 40823 40829 40841 40847 40849 40853 40867 40879 40883 40897 40903 40927 40933 40939 40949 40961 40973 40993 41011 41017 41023 41039 41047 41051 41057 41077 41081 41113 41117 41131 41141 41143 41149 41161 41177 41179 41183 41189 41201 41203 41213 41221 41227 41231 41233 41243 41257 41263 41269 41281 41299 41333 41341 41351 41357 41381 41387 41389 41399 41411 41413 41443 41453 41467 41479 41491 41507 41513 41519 41521 41539 41543 41549 41579 41593 41597 41603 41609 41611 41617 41621 41627 41641 41647 41651 41659 41669 41681 41687 41719 41729 41737 41759 41761 41771 41777 41801 41809 41813 41843 41849 41851 41863 41879 41887 41893 41897 41903 41911 41927 41941 41947 41953 41957 41959 41969 41981 41983 41999 42013 42017 42019 42023 42043 42061 42071 42073 42083 42089 42101 42131 42139 42157 42169 42179 42181 42187 42193 42197 42209 42221 42223 42227 42239 42257 42281 42283 42293 42299 42307 42323 42331 42337 42349 42359 42373 42379 42391 42397 42403 42407 42409 42433 42437 42443 42451 42457 42461 42463 42467 42473 42487 42491 42499 42509 42533 42557 42569 42571 42577 42589 42611 42641 42643 42649 42667 42677 42683 42689 42697 42701 42703 42709 42719 42727 42737 42743 42751 42767 42773 42787 42793 42797 42821 42829 42839 42841 42853 42859 42863 42899 42901 42923 42929 42937 42943 42953 42961 42967 42979 42989 43003 43013 43019 43037 43049 43051 43063 43067 43093 43103 43117 43133 43151 43159 43177 43189 43201 43207 43223 43237 43261 43271 43283 43291 43313 43319 43321 43331 43391 43397 43399 43403 43411 43427 43441 43451 43457 43481 43487 43499 43517 43541 43543 43573 43577 43579 43591 43597 43607 43609 43613 43627 43633 43649 43651 43661 43669 43691 43711 43717 43721 43753 43759 43777 43781 43783 43787 43789 43793 43801 43853 43867 43889 43891 43913 43933 43943 43951 43961 43963 43969 43973 43987 43991 43997 44017 44021 44027 44029 44041 44053 44059 44071 44087 44089 44101 44111 44119 44123 44129 44131 44159 44171 44179 44189 44201 44203 44207 44221 44249 44257 44263 44267 44269 44273 44279 44281 44293 44351 44357 44371 44381 44383 44389 44417 44449 44453 44483 44491 44497 44501 44507 44519 44531 44533 44537 44543 44549 44563 44579 44587 44617 44621 44623 44633 44641 44647 44651 44657 44683 44687 44699 44701 44711 44729 44741 44753 44771 44773 44777 44789 44797 44809 44819 44839 44843 44851 44867 44879 44887 44893 44909 44917 44927 44939 44953 44959 44963 44971 44983 44987 45007 45013 45053 45061 45077 45083 45119 45121 45127 45131 45137 45139 45161 45179 45181 45191 45197 45233 45247 45259 45263 45281 45289 45293 45307 45317 45319 45329 45337 45341 45343 45361 45377 45389 45403 45413 45427 45433 45439 45481 45491 45497 45503 45523 45533 45541 45553 45557 45569 45587 45589 45599 45613 45631 45641 45659 45667 45673 45677 45691 45697 45707 45737 45751 45757 45763 45767 45779 45817 45821 45823 45827 45833 45841 45853 45863 45869 45887 45893 45943 45949 45953 45959 45971 45979 45989 46021 46027 46049 46051 46061 46073 46091 46093 46099 46103 46133 46141 46147 46153 46171 46181 46183 46187 46199 46219 46229 46237 46261 46271 46273 46279 46301 46307 46309 46327 46337 46349 46351 46381 46399 46411 46439 46441 46447 46451 46457 46471 46477 46489 46499 46507 46511 46523 46549 46559 46567 46573 46589 46591 46601 46619 46633 46639 46643 46649 46663 46679 46681 46687 46691 46703 46723 46727 46747 46751 46757 46769 46771 46807 46811 46817 46819 46829 46831 46853 46861 46867 46877 46889 46901 46919 46933 46957 46993 46997 47017 47041 47051 47057 47059 47087 47093 47111 47119 47123 47129 47137 47143 47147 47149 47161 47189 47207 47221 47237 47251 47269 47279 47287 47293 47297 47303 47309 47317 47339 47351 47353 47363 47381 47387 47389 47407 47417 47419 47431 47441 47459 47491 47497 47501 47507 47513 47521 47527 47533 47543 47563 47569 47581 47591 47599 47609 47623 47629 47639 47653 47657 47659 47681 47699 47701 47711 47713 47717 47737 47741 47743 47777 47779 47791 47797 47807 47809 47819 47837 47843 47857 47869 47881 47903 47911 47917 47933 47939 47947 47951 47963 47969 47977 47981 48017 48023 48029 48049 48073 48079 48091 48109 48119 48121 48131 48157 48163 48179 48187 48193 48197 48221 48239 48247 48259 48271 48281 48299 48311 48313 48337 48341 48353 48371 48383 48397 48407 48409 48413 48437 48449 48463 48473 48479 48481 48487 48491 48497 48523 48527 48533 48539 48541 48563 48571 48589 48593 48611 48619 48623 48647 48649 48661 48673 48677 48679 48731 48733 48751 48757 48761 48767 48779 48781 48787 48799 48809 48817 48821 48823 48847 48857 48859 48869 48871 48883 48889 48907 48947 48953 48973 48989 48991 49003 49009 49019 49031 49033 49037 49043 49057 49069 49081 49103 49109 49117 49121 49123 49139 49157 49169 49171 49177 49193 49199 49201 49207 49211 49223 49253 49261 49277 49279 49297 49307 49331 49333 49339 49363 49367 49369 49391 49393 49409 49411 49417 49429 49433 49451 49459 49463 49477 49481 49499 49523 49529 49531 49537 49547 49549 49559 49597 49603 49613 49627 49633 49639 49663 49667 49669 49681 49697 49711 49727 49739 49741 49747 49757 49783 49787 49789 49801 49807 49811 49823 49831 49843 49853 49871 49877 49891 49919 49921 49927 49937 49939 49943 49957 49991 49993 49999 mingw-ocaml/ocaml/testsuite/tests/misc/sorts.ml0000644000175000017500000036300712124403241021321 0ustar tootstoots(* Test bench for sorting algorithms. *) (* ocamlopt -noassert sorts.ml -cclib -lunix *) open Printf;; (* Criteres: 0. overhead en pile: doit etre logn au maximum. 1. stable ou non. 2. overhead en espace. 3. vitesse. *) (************************************************************************) (* auxiliary functions *) let rec exp2 n = if n <= 0 then 1 else 2 * exp2 (n-1);; let id x = x;; let postl x y = Array.of_list y;; let posta x y = x;; let mkconst n = Array.make n 0;; let chkconst _ n a = (a = mkconst n);; let mksorted n = let a = Array.make n 0 in for i = 0 to n - 1 do a.(i) <- i; done; a ;; let chksorted _ n a = (a = mksorted n);; let mkrev n = let a = Array.make n 0 in for i = 0 to n - 1 do a.(i) <- n - 1 - i; done; a ;; let chkrev _ n a = (a = mksorted n);; let seed = ref 0;; let random_reinit () = Random.init !seed;; let random_get_state () = let a = Array.make 55 0 in for i = 0 to 54 do a.(i) <- Random.bits (); done; Random.full_init a; a ;; let random_set_state a = Random.full_init a;; let chkgen mke cmp rstate n a = let marks = Array.make n (-1) in let skipmarks l = if marks.(l) = -1 then l else begin let m = ref marks.(l) in while marks.(!m) <> -1 do incr m; done; marks.(l) <- !m; !m end in let linear e l = let l = skipmarks l in let rec loop l = if cmp a.(l) e > 0 then raise Exit else if e = a.(l) then marks.(l) <- l+1 else loop (l+1) in loop l in let rec dicho e l r = if l = r then linear e l else begin assert (l < r); let m = (l + r) / 2 in if cmp a.(m) e >= 0 then dicho e l m else dicho e (m + 1) r end in try for i = 0 to n-2 do if cmp a.(i) a.(i+1) > 0 then raise Exit; done; random_set_state rstate; for i = 0 to n-1 do dicho (mke i) 0 (Array.length a - 1); done; true with Exit | Invalid_argument _ -> false; ;; let mkrand_dup n = let a = Array.make n 0 in for i = 0 to (n-1) do a.(i) <- Random.int n; done; a ;; let chkrand_dup rstate n a = chkgen (fun i -> Random.int n) compare rstate n a ;; let mkrand_nodup n = let a = Array.make n 0 in for i = 0 to (n-1) do a.(i) <- Random.bits (); done; a ;; let chkrand_nodup rstate n a = chkgen (fun i -> Random.bits ()) compare rstate n a ;; let mkfloats n = let a = Array.make n 0.0 in for i = 0 to (n-1) do a.(i) <- Random.float 1.0; done; a ;; let chkfloats rstate n a = chkgen (fun i -> Random.float 1.0) compare rstate n a ;; type record = { s1 : string; s2 : string; i1 : int; i2 : int; };; let rand_string () = let len = Random.int 10 in let s = String.create len in for i = 0 to len-1 do s.[i] <- Char.chr (Random.int 256); done; s ;; let mkrec1 b i = { s1 = rand_string (); s2 = rand_string (); i1 = Random.int b; i2 = i; };; let mkrecs b n = Array.init n (mkrec1 b);; let mkrec1_rev b i = { s1 = rand_string (); s2 = rand_string (); i1 = - i; i2 = i; };; let mkrecs_rev n = Array.init n (mkrec1_rev 0);; let cmpstr r1 r2 = let c1 = compare r1.s1 r2.s1 in if c1 = 0 then compare r1.s2 r2.s2 else c1 ;; let lestr r1 r2 = let c1 = compare r1.s1 r2.s1 in if c1 = 0 then r1.s2 <= r2.s2 else (c1 < 0) ;; let chkstr b rstate n a = chkgen (mkrec1 b) cmpstr rstate n a;; let cmpint r1 r2 = compare r1.i1 r2.i1;; let leint r1 r2 = r1.i1 <= r2.i1;; let chkint b rstate n a = chkgen (mkrec1 b) cmpint rstate n a;; let cmplex r1 r2 = let c1 = compare r1.i1 r2.i1 in if c1 = 0 then compare r1.i2 r2.i2 else c1 ;; let lelex r1 r2 = let c1 = compare r1.i1 r2.i1 in if c1 = 0 then r1.i2 <= r2.i2 else (c1 < 0) ;; let chklex b rstate n a = chkgen (mkrec1 b) cmplex rstate n a;; (************************************************************************) let lens = [ 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 28; 100; 127; 128; 129; 191; 192; 193; 506; 1000; 1023; 1024; 1025; 1535; 1536; 1537; 2323; 4000; 4094; 4096; 4098; 5123; ];; type ('a, 'b, 'c, 'd) aux = { prepf : ('a -> 'a -> int) -> ('a -> 'a -> bool) -> 'b; prepd : 'a array -> 'c; postd : 'a array -> 'd -> 'a array; };; let ll = { prepf = (fun x y -> y); prepd = Array.to_list; postd = postl };; let lc = { prepf = (fun x y -> x); prepd = Array.to_list; postd = postl };; let al = { prepf = (fun x y -> y); prepd = id; postd = posta };; let ac = { prepf = (fun x y -> x); prepd = id; postd = posta };; type 'a outcome = Value of 'a | Exception of exn;; let numfailed = ref 0;; let test1 name f prepdata postdata cmp desc mk chk = random_reinit (); printf " %s with %s" name desc; let i = ref 0 in List.iter (fun n -> if !i = 0 then printf "\n "; incr i; if !i > 11 then i := 0; printf "%5d" n; flush stdout; let rstate = random_get_state () in let a = mk n in let input = prepdata a in let output = try Value (f cmp input) with e -> Exception e in printf "."; flush stdout; begin match output with | Value v -> if not (chk rstate n (postdata a v)) then (incr numfailed; printf "\n*** FAIL\n") | Exception e -> incr numfailed; printf "\n*** %s\n" (Printexc.to_string e) end; flush stdout; ) lens; printf "\n"; ;; let test name stable f1 f2 aux1 aux2 = printf "Testing %s...\n" name; let t a b c d = test1 name f1 aux1.prepd aux1.postd a b c d in let cmp = aux1.prepf compare (<=) in t cmp "constant ints" mkconst chkconst; t cmp "sorted ints" mksorted chksorted; t cmp "reverse-sorted ints" mkrev chkrev; t cmp "random ints (many dups)" mkrand_dup chkrand_dup; t cmp "random ints (few dups)" mkrand_nodup chkrand_nodup; (* let t a b c d = test1 name f3 aux3.prepd aux3.postd a b c d in t cmp "random floats" mkfloats chkfloats; *) let t a b c d = test1 name f2 aux2.prepd aux2.postd a b c d in let cmp = aux2.prepf cmpstr lestr in t cmp "records (str)" (mkrecs 1) (chkstr 1); let cmp = aux2.prepf cmpint leint in List.iter (fun m -> t cmp (sprintf "records (int[%d])" m) (mkrecs m) (chkint m) ) [1; 10; 100; 1000]; if stable then List.iter (fun m -> t cmp (sprintf "records (int[%d]) [stable]" m) (mkrecs m) (chklex m) ) [1; 10; 100; 1000]; ;; (************************************************************************) (* Warning: rpt_timer cannot be used for the array sorts because the sorting functions have effects. *) let rpt_timer1 repeat f x = Gc.compact (); ignore (f x); let st = Sys.time () in for i = 1 to repeat do ignore (f x); done; let en = Sys.time () in en -. st ;; let rpt_timer f x = let repeat = ref 1 in let t = ref (rpt_timer1 !repeat f x) in while !t < 0.2 do repeat := 10 * !repeat; t := rpt_timer1 !repeat f x; done; if !t < 2.0 then begin repeat := (int_of_float (10. *. (float !repeat) /. !t) + 1); t := rpt_timer1 !repeat f x; end; !t /. (float !repeat) ;; let timer f x = let st = Sys.time () in ignore (f x); let en = Sys.time () in (en -. st) ;; let table1 limit f mkarg = printf " %10s %9s %9s %9s %9s %9s\n" "n" "t1" "t2" "t3" "t4" "t5"; let sz = ref 49151 in while !sz < int_of_float (2. ** float limit) do begin try printf " %10d " !sz; flush stdout; for i = 0 to 4 do let arg = mkarg !sz in let t = timer f arg in printf " %.2e " t; flush stdout; done; printf "\n"; with e -> printf "*** %s\n" (Printexc.to_string e); end; flush stdout; sz := 2 * !sz + 1; done; ;; let table2 limit f mkarg = printf " %10s %9s %9s %9s %9s %9s\n" " n" "t" "t/n" "t/nlogn" "t/nlog^2n" "t/n^2"; let sz = ref 49151 in while float !sz < 2. ** float limit do begin try printf " %10d " !sz; flush stdout; Gc.compact (); let arg = mkarg !sz in let t = timer f arg in let n = float !sz in let logn = log (float !sz) /. log 2. in printf "%.2e %.2e %.2e %.2e %.2e\n" t (t/.n) (t/.n/.logn) (t/.n/.logn/.logn) (t/.n/.n); with e -> printf "*** %s\n" (Printexc.to_string e); end; flush stdout; sz := 2 * !sz + 1; done; ;; let table3 limit f mkarg = printf " %10s %9s %9s %9s %9s %9s\n" "n" "t1" "t2" "t3" "t4" "t5"; let sz = ref 2 in while float !sz < 2. ** float limit do begin try printf " %10d " !sz; flush stdout; for i = 0 to 4 do let arg = mkarg !sz in let t = rpt_timer f arg in printf " %.2e " t; flush stdout; done; printf "\n"; with e -> printf "*** %s\n" (Printexc.to_string e); end; flush stdout; sz := 2 * !sz + 1; done; ;; (************************************************************************) (* benchmarks: 1a. random records, sorted with two keys 1b. random integers 1c. random floats 2a. integers, constant 2b. integers, already sorted 2c. integers, reverse sorted only for short lists: 3a. random records, sorted with two keys 3b. random integers 3c. random floats *) let bench1a limit name f aux = (* Don't do benchmarks with assertions enabled. *) assert (not true); random_reinit (); printf "\n%s with random records [10]:\n" name; let cmp = aux.prepf cmplex lelex in table1 limit (f cmp) (fun n -> aux.prepd (mkrecs 10 n)); ;; let bench1b limit name f aux = (* Don't do benchmarks with assertions enabled. *) assert (not true); random_reinit (); printf "\n%s with random integers:\n" name; let cmp = aux.prepf (-) (<=) in table1 limit (f cmp) (fun n -> aux.prepd (mkrand_nodup n)); ;; let bench1c limit name f aux = (* Don't do benchmarks with assertions enabled. *) assert (not true); random_reinit (); printf "\n%s with random floats:\n" name; let cmp = aux.prepf compare (<=) in table1 limit (f cmp) (fun n -> aux.prepd (mkfloats n)); ;; let bench2 limit name f aux = (* Don't do benchmarks with assertions enabled. *) assert (not true); printf "\n%s with constant integers:\n" name; let cmp = aux.prepf compare (<=) in table2 limit (f cmp) (fun n -> aux.prepd (mkconst n)); printf "\n%s with sorted integers:\n" name; let cmp = aux.prepf compare (<=) in table2 limit (f cmp) (fun n -> aux.prepd (mksorted n)); printf "\n%s with reverse-sorted integers:\n" name; let cmp = aux.prepf compare (<=) in table2 limit (f cmp) (fun n -> aux.prepd (mkrev n)); ;; let bench3a limit name f aux = (* Don't do benchmarks with assertions enabled. *) assert (not true); random_reinit (); printf "\n%s with random records [10]:\n" name; let cmp = aux.prepf cmplex lelex in table3 limit (f cmp) (fun n -> aux.prepd (mkrecs 10 n)); ;; let bench3b limit name f aux = (* Don't do benchmarks with assertions enabled. *) assert (not true); random_reinit (); printf "\n%s with random integers:\n" name; let cmp = aux.prepf (-) (<=) in table3 limit (f cmp) (fun n -> aux.prepd (mkrand_nodup n)); ;; let bench3c limit name f aux = (* Don't do benchmarks with assertions enabled. *) assert (not true); random_reinit (); printf "\n%s with random floats:\n" name; let cmp = aux.prepf compare (<=) in table3 limit (f cmp) (fun n -> aux.prepd (mkfloats n)); ;; (************************************************************************) (* merge sort on lists *) (* FIXME to do: cutoff to do: cascader les pattern-matchings (enlever les paires) to do: fermeture intermediaire pour merge *) let (@@) = List.rev_append;; let lmerge_1a cmp l = let rec init accu = function | [] -> accu | e::rest -> init ([e] :: accu) rest in let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward; accu,accu2 are rev *) match l1, l2 with | [] , _ -> mergepairs ((l2 @@ accu)::accu2) rest | _ , [] -> mergepairs ((l1 @@ accu)::accu2) rest | h1::t1, h2::t2 -> if cmp h1 h2 <= 0 then merge rest accu2 (h1::accu) t1 l2 else merge rest accu2 (h2::accu) l1 t2 and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward; l1,l2,rest are rev *) match l1, l2 with | [] , _ -> mergepairs_rev ((l2 @@ accu)::accu2) rest | _ , [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest | h1::t1, h2::t2 -> if cmp h2 h1 <= 0 then merge_rev rest accu2 (h1::accu) t1 l2 else merge_rev rest accu2 (h2::accu) l1 t2 and mergepairs accu = function (* accu is rev, arg is forward *) | [] -> mergeall_rev accu | [l] -> mergeall_rev ((List.rev l)::accu) | l1::l2::rest -> merge rest accu [] l1 l2 and mergepairs_rev accu = function (* accu is forward, arg is rev *) | [] -> mergeall accu | [l] -> mergeall ((List.rev l)::accu) | l1::l2::rest -> merge_rev rest accu [] l1 l2 and mergeall = function (* arg is forward *) | [] -> [] | [l] -> l | llist -> mergepairs [] llist and mergeall_rev = function (* arg is rev *) | [] -> [] | [l] -> List.rev l | llist -> mergepairs_rev [] llist in mergeall_rev (init [] l) ;; let lmerge_1b cmp l = let rec init accu = function | [] -> accu | [e] -> [e] :: accu | e1::e2::rest -> init ((if cmp e1 e2 <= 0 then [e2;e1] else [e1;e2])::accu) rest in let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward; accu,accu2 are rev *) match l1, l2 with | [] , _ -> mergepairs ((l2 @@ accu)::accu2) rest | _ , [] -> mergepairs ((l1 @@ accu)::accu2) rest | h1::t1, h2::t2 -> if cmp h1 h2 <= 0 then merge rest accu2 (h1::accu) t1 l2 else merge rest accu2 (h2::accu) l1 t2 and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward; l1,l2,rest are rev *) match l1, l2 with | [] , _ -> mergepairs_rev ((l2 @@ accu)::accu2) rest | _ , [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest | h1::t1, h2::t2 -> if cmp h2 h1 <= 0 then merge_rev rest accu2 (h1::accu) t1 l2 else merge_rev rest accu2 (h2::accu) l1 t2 and mergepairs accu = function (* accu is rev, arg is forward *) | [] -> mergeall_rev accu | [l] -> mergeall_rev ((List.rev l)::accu) | l1::l2::rest -> merge rest accu [] l1 l2 and mergepairs_rev accu = function (* accu is forward, arg is rev *) | [] -> mergeall accu | [l] -> mergeall ((List.rev l)::accu) | l1::l2::rest -> merge_rev rest accu [] l1 l2 and mergeall = function (* arg is forward *) | [] -> [] | [l] -> l | llist -> mergepairs [] llist and mergeall_rev = function (* arg is rev *) | [] -> [] | [l] -> List.rev l | llist -> mergepairs_rev [] llist in mergeall_rev (init [] l) ;; let lmerge_1c cmp l = let rec init accu = function | [] -> accu | [e] -> [e] :: accu | e1::e2::rest -> init ((if cmp e1 e2 <= 0 then [e2;e1] else [e1;e2])::accu) rest in let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward; accu,accu2 are rev *) match l1 with | [] -> mergepairs ((l2 @@ accu)::accu2) rest | h1::t1 -> match l2 with | [] -> mergepairs ((l1 @@ accu)::accu2) rest | h2::t2 -> if cmp h1 h2 <= 0 then merge rest accu2 (h1::accu) t1 l2 else merge rest accu2 (h2::accu) l1 t2 and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward; l1,l2,rest are rev *) match l1 with | [] -> mergepairs_rev ((l2 @@ accu)::accu2) rest | h1::t1 -> match l2 with | [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest | h2::t2 -> if cmp h2 h1 <= 0 then merge_rev rest accu2 (h1::accu) t1 l2 else merge_rev rest accu2 (h2::accu) l1 t2 and mergepairs accu = function (* accu is rev, arg is forward *) | [] -> mergeall_rev accu | [l] -> mergeall_rev ((List.rev l)::accu) | l1::l2::rest -> merge rest accu [] l1 l2 and mergepairs_rev accu = function (* accu is forward, arg is rev *) | [] -> mergeall accu | [l] -> mergeall ((List.rev l)::accu) | l1::l2::rest -> merge_rev rest accu [] l1 l2 and mergeall = function (* arg is forward *) | [] -> [] | [l] -> l | llist -> mergepairs [] llist and mergeall_rev = function (* arg is rev *) | [] -> [] | [l] -> List.rev l | llist -> mergepairs_rev [] llist in mergeall_rev (init [] l) ;; let lmerge_1d cmp l = let rec init accu = function | [] -> accu | [e] -> [e] :: accu | e1::e2::rest -> init ((if cmp e1 e2 <= 0 then [e2;e1] else [e1;e2])::accu) rest in let rec merge rest accu2 accu l1 l2 = (* l1,l2,rest are forward; accu,accu2 are rev *) let merge_rest_accu2 accu l1 l2 = match l1 with | [] -> mergepairs ((l2 @@ accu)::accu2) rest | h1::t1 -> match l2 with | [] -> mergepairs ((l1 @@ accu)::accu2) rest | h2::t2 -> if cmp h1 h2 <= 0 then merge rest accu2 (h1::accu) t1 l2 else merge rest accu2 (h2::accu) l1 t2 in merge_rest_accu2 accu l1 l2 and merge_rev rest accu2 accu l1 l2 = (* accu, accu2 are forward; l1,l2,rest are rev *) let merge_rev_rest_accu2 accu l1 l2 = match l1 with | [] -> mergepairs_rev ((l2 @@ accu)::accu2) rest | h1::t1 -> match l2 with | [] -> mergepairs_rev ((l1 @@ accu)::accu2) rest | h2::t2 -> if cmp h2 h1 <= 0 then merge_rev rest accu2 (h1::accu) t1 l2 else merge_rev rest accu2 (h2::accu) l1 t2 in merge_rev_rest_accu2 accu l1 l2 and mergepairs accu = function (* accu is rev, arg is forward *) | [] -> mergeall_rev accu | [l] -> mergeall_rev ((List.rev l)::accu) | l1::l2::rest -> merge rest accu [] l1 l2 and mergepairs_rev accu = function (* accu is forward, arg is rev *) | [] -> mergeall accu | [l] -> mergeall ((List.rev l)::accu) | l1::l2::rest -> merge_rev rest accu [] l1 l2 and mergeall = function (* arg is forward *) | [] -> [] | [l] -> l | llist -> mergepairs [] llist and mergeall_rev = function (* arg is rev *) | [] -> [] | [l] -> List.rev l | llist -> mergepairs_rev [] llist in mergeall_rev (init [] l) ;; (************************************************************************) (* merge sort on lists, user-contributed (NOT STABLE) *) (* BEGIN code contributed by Yann Coscoy *) let rec rev_merge_append order l1 l2 acc = match l1 with [] -> List.rev_append l2 acc | h1 :: t1 -> match l2 with [] -> List.rev_append l1 acc | h2 :: t2 -> if order h1 h2 then rev_merge_append order t1 l2 (h1::acc) else rev_merge_append order l1 t2 (h2::acc) let rev_merge order l1 l2 = rev_merge_append order l1 l2 [] let rec rev_merge_append' order l1 l2 acc = match l1 with | [] -> List.rev_append l2 acc | h1 :: t1 -> match l2 with | [] -> List.rev_append l1 acc | h2 :: t2 -> if order h2 h1 then rev_merge_append' order t1 l2 (h1::acc) else rev_merge_append' order l1 t2 (h2::acc) let rev_merge' order l1 l2 = rev_merge_append' order l1 l2 [] let lmerge_3 order l = let rec initlist l acc = match l with | e1::e2::rest -> initlist rest ((if order e1 e2 then [e1;e2] else [e2;e1])::acc) | [e] -> [e]::acc | [] -> acc in let rec merge2 ll acc = match ll with | [] -> acc | [l] -> [List.rev l]@acc | l1::l2::rest -> merge2 rest (rev_merge order l1 l2::acc) in let rec merge2' ll acc = match ll with | [] -> acc | [l] -> [List.rev l]@acc | l1::l2::rest -> merge2' rest (rev_merge' order l1 l2::acc) in let rec mergeall rev = function | [] -> [] | [l] -> if rev then List.rev l else l | llist -> mergeall (not rev) ((if rev then merge2' else merge2) llist []) in mergeall false (initlist l []) (* END code contributed by Yann Coscoy *) (************************************************************************) (* merge sort on short lists, Francois Pottier *) (* BEGIN code contributed by Francois Pottier *) (* [chop k l] returns the list [l] deprived of its [k] first elements. The length of the list [l] must be [k] at least. *) let rec chop k l = match k, l with | 0, _ -> l | _, x :: l -> chop (k-1) l | _, _ -> assert false ;; let rec merge order l1 l2 = match l1 with [] -> l2 | h1 :: t1 -> match l2 with [] -> l1 | h2 :: t2 -> if order h1 h2 then h1 :: merge order t1 l2 else h2 :: merge order l1 t2 ;; let rec lmerge_4a order l = match l with | [] | [ _ ] -> l | _ -> let rec sort k l = (* k > 1 *) match k, l with | 2, x1 :: x2 :: _ -> if order x1 x2 then [ x1; x2 ] else [ x2; x1 ] | 3, x1 :: x2 :: x3 :: _ -> if order x1 x2 then if order x2 x3 then [ x1 ; x2 ; x3 ] else if order x1 x3 then [ x1 ; x3 ; x2 ] else [ x3; x1; x2 ] else if order x1 x3 then [ x2; x1; x3 ] else if order x2 x3 then [ x2; x3; x1 ] else [ x3; x2; x1 ] | _, _ -> let k1 = k / 2 in let k2 = k - k1 in merge order (sort k1 l) (sort k2 (chop k1 l)) in sort (List.length l) l ;; (* END code contributed by Francois Pottier *) (************************************************************************) (* merge sort on short lists, Francois Pottier, adapted to new-style interface *) (* BEGIN code contributed by Francois Pottier *) (* [chop k l] returns the list [l] deprived of its [k] first elements. The length of the list [l] must be [k] at least. *) let rec chop k l = match k, l with | 0, _ -> l | _, x :: l -> chop (k-1) l | _, _ -> assert false ;; let rec merge order l1 l2 = match l1 with [] -> l2 | h1 :: t1 -> match l2 with [] -> l1 | h2 :: t2 -> if order h1 h2 <= 0 then h1 :: merge order t1 l2 else h2 :: merge order l1 t2 ;; let rec lmerge_4b order l = match l with | [] | [ _ ] -> l | _ -> let rec sort k l = (* k > 1 *) match k, l with | 2, x1 :: x2 :: _ -> if order x1 x2 <= 0 then [ x1; x2 ] else [ x2; x1 ] | 3, x1 :: x2 :: x3 :: _ -> if order x1 x2 <= 0 then if order x2 x3 <= 0 then [ x1 ; x2 ; x3 ] else if order x1 x3 <= 0 then [ x1 ; x3 ; x2 ] else [ x3; x1; x2 ] else if order x1 x3 <= 0 then [ x2; x1; x3 ] else if order x2 x3 <= 0 then [ x2; x3; x1 ] else [ x3; x2; x1 ] | _, _ -> let k1 = k / 2 in let k2 = k - k1 in merge order (sort k1 l) (sort k2 (chop k1 l)) in sort (List.length l) l ;; (* END code contributed by Francois Pottier *) (************************************************************************) (* merge sort on short lists a la Pottier, modified merge *) let rec chop k l = if k = 0 then l else begin match l with | x::t -> chop (k-1) t | _ -> assert false end ;; let lmerge_4c cmp l = let rec merge1 h1 t1 l2 = match l2 with | [] -> h1 :: t1 | h2 :: t2 -> if cmp h1 h2 <= 0 then h1 :: (merge2 t1 h2 t2) else h2 :: (merge1 h1 t1 t2) and merge2 l1 h2 t2 = match l1 with | [] -> h2 :: t2 | h1 :: t1 -> if cmp h1 h2 <= 0 then h1 :: (merge2 t1 h2 t2) else h2 :: (merge1 h1 t1 t2) in let merge l1 = function | [] -> l1 | h2 :: t2 -> merge2 l1 h2 t2 in let rec sort n l = match n, l with | 2, x1 :: x2 :: _ -> if cmp x1 x2 <= 0 then [x1; x2] else [x2; x1] | 3, x1 :: x2 :: x3 :: _ -> if cmp x1 x2 <= 0 then begin if cmp x2 x3 <= 0 then [x1; x2; x3] else if cmp x1 x3 <= 0 then [x1; x3; x2] else [x3; x1; x2] end else begin if cmp x1 x3 <= 0 then [x2; x1; x3] else if cmp x2 x3 <= 0 then [x2; x3; x1] else [x3; x2; x1] end | n, l -> let n1 = n asr 1 in let n2 = n - n1 in merge (sort n1 l) (sort n2 (chop n1 l)) in let len = List.length l in if len < 2 then l else sort len l ;; (************************************************************************) (* merge sort on short lists a la Pottier, logarithmic stack space *) let rec chop k l = if k = 0 then l else begin match l with | x::t -> chop (k-1) t | _ -> assert false end ;; let lmerge_4d cmp l = let rec rev_merge l1 l2 accu = match l1, l2 with | [], l2 -> l2 @@ accu | l1, [] -> l1 @@ accu | h1::t1, h2::t2 -> if cmp h1 h2 <= 0 then rev_merge t1 l2 (h1::accu) else rev_merge l1 t2 (h2::accu) in let rec rev_merge_rev l1 l2 accu = match l1, l2 with | [], l2 -> l2 @@ accu | l1, [] -> l1 @@ accu | h1::t1, h2::t2 -> if cmp h1 h2 > 0 then rev_merge_rev t1 l2 (h1::accu) else rev_merge_rev l1 t2 (h2::accu) in let rec sort n l = match n, l with | 2, x1 :: x2 :: _ -> if cmp x1 x2 <= 0 then [x1; x2] else [x2; x1] | 3, x1 :: x2 :: x3 :: _ -> if cmp x1 x2 <= 0 then begin if cmp x2 x3 <= 0 then [x1; x2; x3] else if cmp x1 x3 <= 0 then [x1; x3; x2] else [x3; x1; x2] end else begin if cmp x1 x3 <= 0 then [x2; x1; x3] else if cmp x2 x3 <= 0 then [x2; x3; x1] else [x3; x2; x1] end | n, l -> let n1 = n asr 1 in let n2 = n - n1 in rev_merge_rev (rev_sort n1 l) (rev_sort n2 (chop n1 l)) [] and rev_sort n l = match n, l with | 2, x1 :: x2 :: _ -> if cmp x1 x2 > 0 then [x1; x2] else [x2; x1] | 3, x1 :: x2 :: x3 :: _ -> if cmp x1 x2 > 0 then begin if cmp x2 x3 > 0 then [x1; x2; x3] else if cmp x1 x3 > 0 then [x1; x3; x2] else [x3; x1; x2] end else begin if cmp x1 x3 > 0 then [x2; x1; x3] else if cmp x2 x3 > 0 then [x2; x3; x1] else [x3; x2; x1] end | n, l -> let n1 = n asr 1 in let n2 = n - n1 in rev_merge (sort n1 l) (sort n2 (chop n1 l)) [] in let len = List.length l in if len < 2 then l else sort len l ;; (************************************************************************) (* merge sort on short lists a la Pottier, logarithmic stack space, in place: input list is freed as the output is being computed. *) let rec chop k l = if k = 0 then l else begin match l with | x::t -> chop (k-1) t | _ -> assert false end ;; let lmerge_4e cmp l = let rec rev_merge l1 l2 accu = match l1, l2 with | [], l2 -> l2 @@ accu | l1, [] -> l1 @@ accu | h1::t1, h2::t2 -> if cmp h1 h2 <= 0 then rev_merge t1 l2 (h1::accu) else rev_merge l1 t2 (h2::accu) in let rec rev_merge_rev l1 l2 accu = match l1, l2 with | [], l2 -> l2 @@ accu | l1, [] -> l1 @@ accu | h1::t1, h2::t2 -> if cmp h1 h2 > 0 then rev_merge_rev t1 l2 (h1::accu) else rev_merge_rev l1 t2 (h2::accu) in let rec sort n l = match n, l with | 2, x1 :: x2 :: _ -> if cmp x1 x2 <= 0 then [x1; x2] else [x2; x1] | 3, x1 :: x2 :: x3 :: _ -> if cmp x1 x2 <= 0 then begin if cmp x2 x3 <= 0 then [x1; x2; x3] else if cmp x1 x3 <= 0 then [x1; x3; x2] else [x3; x1; x2] end else begin if cmp x1 x3 <= 0 then [x2; x1; x3] else if cmp x2 x3 <= 0 then [x2; x3; x1] else [x3; x2; x1] end | n, l -> let n1 = n asr 1 in let n2 = n - n1 in let l2 = chop n1 l in let s1 = rev_sort n1 l in let s2 = rev_sort n2 l2 in rev_merge_rev s1 s2 [] and rev_sort n l = match n, l with | 2, x1 :: x2 :: _ -> if cmp x1 x2 > 0 then [x1; x2] else [x2; x1] | 3, x1 :: x2 :: x3 :: _ -> if cmp x1 x2 > 0 then begin if cmp x2 x3 > 0 then [x1; x2; x3] else if cmp x1 x3 > 0 then [x1; x3; x2] else [x3; x1; x2] end else begin if cmp x1 x3 > 0 then [x2; x1; x3] else if cmp x2 x3 > 0 then [x2; x3; x1] else [x3; x2; x1] end | n, l -> let n1 = n asr 1 in let n2 = n - n1 in let l2 = chop n1 l in let s1 = sort n1 l in let s2 = sort n2 l2 in rev_merge s1 s2 [] in let len = List.length l in if len < 2 then l else sort len l ;; (************************************************************************) (* chop-free version of Pottier's code, binary version *) let rec merge cmp l1 l2 = match l1, l2 with | [], l2 -> l2 | l1, [] -> l1 | h1 :: t1, h2 :: t2 -> if cmp h1 h2 <= 0 then h1 :: merge cmp t1 l2 else h2 :: merge cmp l1 t2 ;; let lmerge_5a cmp l = let rem = ref l in let rec sort_prefix n = if n <= 1 then begin match !rem with | [] -> [] | [x] as l -> rem := []; l | x::y::t -> rem := t; if cmp x y <= 0 then [x;y] else [y;x] end else if !rem = [] then [] else begin let l1 = sort_prefix (n-1) in let l2 = sort_prefix (n-1) in merge cmp l1 l2 end in let len = ref (List.length l) in let i = ref 0 in while !len > 0 do incr i; len := !len lsr 1; done; sort_prefix !i ;; (************************************************************************) (* chop-free version of Pottier's code, dichotomic version, ground cases 1 & 2 *) let rec merge cmp l1 l2 = match l1, l2 with | [], l2 -> l2 | l1, [] -> l1 | h1 :: t1, h2 :: t2 -> if cmp h1 h2 <= 0 then h1 :: merge cmp t1 l2 else h2 :: merge cmp l1 t2 ;; let lmerge_5b cmp l = let rem = ref l in let rec sort_prefix n = match n, !rem with | 1, x::t -> rem := t; [x] | 2, x::y::t -> rem := t; if cmp x y <= 0 then [x;y] else [y;x] | n, _ -> let n1 = n/2 in let n2 = n - n1 in let l1 = sort_prefix n1 in let l2 = sort_prefix n2 in merge cmp l1 l2 in let len = List.length l in if len <= 1 then l else sort_prefix len ;; (************************************************************************) (* chop-free version of Pottier's code, dichotomic version, ground cases 2 & 3 *) let rec merge cmp l1 l2 = match l1, l2 with | [], l2 -> l2 | l1, [] -> l1 | h1 :: t1, h2 :: t2 -> if cmp h1 h2 <= 0 then h1 :: merge cmp t1 l2 else h2 :: merge cmp l1 t2 ;; let lmerge_5c cmp l = let rem = ref l in let rec sort_prefix n = match n, !rem with | 2, x::y::t -> rem := t; if cmp x y <= 0 then [x;y] else [y;x] | 3, x::y::z::t -> rem := t; if cmp x y <= 0 then if cmp y z <= 0 then [x; y; z] else if cmp x z <= 0 then [x; z; y] else [z; x; y] else if cmp x z <= 0 then [y; x; z] else if cmp y z <= 0 then [y; z; x] else [z; y; x] | n, _ -> let n1 = n/2 in let n2 = n - n1 in let l1 = sort_prefix n1 in let l2 = sort_prefix n2 in merge cmp l1 l2 in let len = List.length l in if len <= 1 then l else sort_prefix len ;; (************************************************************************) (* chop-free, ref-free version of Pottier's code, dichotomic version, ground cases 2 & 3, modified merge *) let lmerge_5d cmp l = let rec merge1 h1 t1 l2 = match l2 with | [] -> h1::t1 | h2 :: t2 -> if cmp h1 h2 <= 0 then h1 :: merge2 t1 h2 t2 else h2 :: merge1 h1 t1 t2 and merge2 l1 h2 t2 = match l1 with | [] -> h2::t2 | h1 :: t1 -> if cmp h1 h2 <= 0 then h1 :: merge2 t1 h2 t2 else h2 :: merge1 h1 t1 t2 in let rec sort_prefix n l = match n, l with | 2, x::y::t -> ((if cmp x y <= 0 then [x;y] else [y;x]), t) | 3, x::y::z::t -> ((if cmp x y <= 0 then if cmp y z <= 0 then [x; y; z] else if cmp x z <= 0 then [x; z; y] else [z; x; y] else if cmp x z <= 0 then [y; x; z] else if cmp y z <= 0 then [y; z; x] else [z; y; x]), t) | n, _ -> let n1 = n/2 in let n2 = n - n1 in let (l1, rest1) = sort_prefix n1 l in match sort_prefix n2 rest1 with | (h2::t2, rest2) -> ((merge2 l1 h2 t2), rest2) | _ -> assert false in let len = List.length l in if len <= 1 then l else fst (sort_prefix len l) ;; (************************************************************************) (* merge sort on arrays, merge with tail-rec function *) let amerge_1a cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let src1r = src1ofs + src1len and src2r = src2ofs + src2len in let rec loop i1 s1 i2 s2 d = if cmp s1 s2 <= 0 then begin dst.(d) <- s1; let i1 = i1 + 1 in if i1 < src1r then loop i1 a.(i1) i2 s2 (d + 1) else Array.blit src2 i2 dst (d + 1) (src2r - i2) end else begin dst.(d) <- s2; let i2 = i2 + 1 in if i2 < src2r then loop i1 s1 i2 src2.(i2) (d + 1) else Array.blit a i1 dst (d + 1) (src1r - i1) end in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; in let rec sortto srcofs dst dstofs len = assert (len > 0); if len = 1 then dst.(dstofs) <- a.(srcofs) else begin let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs + l1) dst (dstofs + l1) l2; sortto srcofs a (srcofs + l2) l1; merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; end; in let l = Array.length a in if l <= 1 then () else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let amerge_1b cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let src1r = src1ofs + src1len and src2r = src2ofs + src2len in let rec loop i1 s1 i2 s2 d = if cmp s1 s2 <= 0 then begin dst.(d) <- s1; let i1 = i1 + 1 in if i1 < src1r then loop i1 a.(i1) i2 s2 (d + 1) else Array.blit src2 i2 dst (d + 1) (src2r - i2) end else begin dst.(d) <- s2; let i2 = i2 + 1 in if i2 < src2r then loop i1 s1 i2 src2.(i2) (d + 1) else Array.blit a i1 dst (d + 1) (src1r - i1) end in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; in let rec sortto srcofs dst dstofs len = assert (len > 0); if len = 1 then dst.(dstofs) <- a.(srcofs) else if len = 2 then begin if cmp a.(srcofs) a.(srcofs+1) <= 0 then begin dst.(dstofs) <- a.(srcofs); dst.(dstofs+1) <- a.(srcofs+1); end else begin dst.(dstofs) <- a.(srcofs+1); dst.(dstofs+1) <- a.(srcofs); end; end else begin let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs + l1) dst (dstofs + l1) l2; sortto srcofs a (srcofs + l2) l1; merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; end; in let l = Array.length a in if l <= 1 then () else if l = 2 then begin if cmp a.(0) a.(1) > 0 then begin let e = a.(0) in a.(0) <- a.(1); a.(1) <- e; end; end else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 3;; let amerge_1c cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let src1r = src1ofs + src1len and src2r = src2ofs + src2len in let rec loop i1 s1 i2 s2 d = if cmp s1 s2 <= 0 then begin dst.(d) <- s1; let i1 = i1 + 1 in if i1 < src1r then loop i1 a.(i1) i2 s2 (d + 1) else Array.blit src2 i2 dst (d + 1) (src2r - i2) end else begin dst.(d) <- s2; let i2 = i2 + 1 in if i2 < src2r then loop i1 s1 i2 src2.(i2) (d + 1) else Array.blit a i1 dst (d + 1) (src1r - i1) end in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; in let isortto srcofs dst dstofs len = for i = 0 to len - 1 do let e = a.(srcofs + i) in let j = ref (dstofs + i - 1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else begin let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs + l1) dst (dstofs + l1) l2; sortto srcofs a (srcofs + l2) l1; merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; end; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 4;; let amerge_1d cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let src1r = src1ofs + src1len and src2r = src2ofs + src2len in let rec loop i1 s1 i2 s2 d = if cmp s1 s2 <= 0 then begin dst.(d) <- s1; let i1 = i1 + 1 in if i1 < src1r then loop i1 a.(i1) i2 s2 (d + 1) else Array.blit src2 i2 dst (d + 1) (src2r - i2) end else begin dst.(d) <- s2; let i2 = i2 + 1 in if i2 < src2r then loop i1 s1 i2 src2.(i2) (d + 1) else Array.blit a i1 dst (d + 1) (src1r - i1) end in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; in let isortto srcofs dst dstofs len = for i = 0 to len - 1 do let e = a.(srcofs + i) in let j = ref (dstofs + i - 1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else begin let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs + l1) dst (dstofs + l1) l2; sortto srcofs a (srcofs + l2) l1; merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; end; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 5;; let amerge_1e cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let src1r = src1ofs + src1len and src2r = src2ofs + src2len in let rec loop i1 s1 i2 s2 d = if cmp s1 s2 <= 0 then begin dst.(d) <- s1; let i1 = i1 + 1 in if i1 < src1r then loop i1 a.(i1) i2 s2 (d + 1) else Array.blit src2 i2 dst (d + 1) (src2r - i2) end else begin dst.(d) <- s2; let i2 = i2 + 1 in if i2 < src2r then loop i1 s1 i2 src2.(i2) (d + 1) else Array.blit a i1 dst (d + 1) (src1r - i1) end in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; in let isortto srcofs dst dstofs len = for i = 0 to len - 1 do let e = a.(srcofs + i) in let j = ref (dstofs + i - 1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else begin let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs + l1) dst (dstofs + l1) l2; sortto srcofs a (srcofs + l2) l1; merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; end; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 6;; let amerge_1f cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let src1r = src1ofs + src1len and src2r = src2ofs + src2len in let rec loop i1 s1 i2 s2 d = if cmp s1 s2 <= 0 then begin dst.(d) <- s1; let i1 = i1 + 1 in if i1 < src1r then loop i1 a.(i1) i2 s2 (d + 1) else Array.blit src2 i2 dst (d + 1) (src2r - i2) end else begin dst.(d) <- s2; let i2 = i2 + 1 in if i2 < src2r then loop i1 s1 i2 src2.(i2) (d + 1) else Array.blit a i1 dst (d + 1) (src1r - i1) end in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; in let isortto srcofs dst dstofs len = for i = 0 to len - 1 do let e = a.(srcofs + i) in let j = ref (dstofs + i - 1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else begin let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs + l1) dst (dstofs + l1) l2; sortto srcofs a (srcofs + l2) l1; merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; end; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 7;; let amerge_1g cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let src1r = src1ofs + src1len and src2r = src2ofs + src2len in let rec loop i1 s1 i2 s2 d = if cmp s1 s2 <= 0 then begin dst.(d) <- s1; let i1 = i1 + 1 in if i1 < src1r then loop i1 a.(i1) i2 s2 (d + 1) else Array.blit src2 i2 dst (d + 1) (src2r - i2) end else begin dst.(d) <- s2; let i2 = i2 + 1 in if i2 < src2r then loop i1 s1 i2 src2.(i2) (d + 1) else Array.blit a i1 dst (d + 1) (src1r - i1) end in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; in let isortto srcofs dst dstofs len = for i = 0 to len - 1 do let e = a.(srcofs + i) in let j = ref (dstofs + i - 1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else begin let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs + l1) dst (dstofs + l1) l2; sortto srcofs a (srcofs + l2) l1; merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; end; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 8;; let amerge_1h cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let src1r = src1ofs + src1len and src2r = src2ofs + src2len in let rec loop i1 s1 i2 s2 d = if cmp s1 s2 <= 0 then begin dst.(d) <- s1; let i1 = i1 + 1 in if i1 < src1r then loop i1 a.(i1) i2 s2 (d + 1) else Array.blit src2 i2 dst (d + 1) (src2r - i2) end else begin dst.(d) <- s2; let i2 = i2 + 1 in if i2 < src2r then loop i1 s1 i2 src2.(i2) (d + 1) else Array.blit a i1 dst (d + 1) (src1r - i1) end in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; in let isortto srcofs dst dstofs len = for i = 0 to len - 1 do let e = a.(srcofs + i) in let j = ref (dstofs + i - 1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else begin let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs + l1) dst (dstofs + l1) l2; sortto srcofs a (srcofs + l2) l1; merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; end; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 9;; let amerge_1i cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let src1r = src1ofs + src1len and src2r = src2ofs + src2len in let rec loop i1 s1 i2 s2 d = if cmp s1 s2 <= 0 then begin dst.(d) <- s1; let i1 = i1 + 1 in if i1 < src1r then loop i1 a.(i1) i2 s2 (d + 1) else Array.blit src2 i2 dst (d + 1) (src2r - i2) end else begin dst.(d) <- s2; let i2 = i2 + 1 in if i2 < src2r then loop i1 s1 i2 src2.(i2) (d + 1) else Array.blit a i1 dst (d + 1) (src1r - i1) end in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; in let isortto srcofs dst dstofs len = for i = 0 to len - 1 do let e = a.(srcofs + i) in let j = ref (dstofs + i - 1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else begin let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs + l1) dst (dstofs + l1) l2; sortto srcofs a (srcofs + l2) l1; merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; end; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 10;; let amerge_1j cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let src1r = src1ofs + src1len and src2r = src2ofs + src2len in let rec loop i1 s1 i2 s2 d = if cmp s1 s2 <= 0 then begin dst.(d) <- s1; let i1 = i1 + 1 in if i1 < src1r then loop i1 a.(i1) i2 s2 (d + 1) else Array.blit src2 i2 dst (d + 1) (src2r - i2) end else begin dst.(d) <- s2; let i2 = i2 + 1 in if i2 < src2r then loop i1 s1 i2 src2.(i2) (d + 1) else Array.blit a i1 dst (d + 1) (src1r - i1) end in loop src1ofs a.(src1ofs) src2ofs src2.(src2ofs) dstofs; in let isortto srcofs dst dstofs len = for i = 0 to len - 1 do let e = a.(srcofs + i) in let j = ref (dstofs + i - 1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else begin let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs + l1) dst (dstofs + l1) l2; sortto srcofs a (srcofs + l2) l1; merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; end; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; (* FIXME a essayer: *) (* list->array->list direct et array->list->array direct *) (* overhead = 1/3, 1/4, etc. *) (* overhead = sqrt (n) *) (* overhead = n/3 jusqu'a 30k, 30k jusqu'a 900M, sqrt (n) au-dela *) (************************************************************************) (* merge sort on arrays, merge with loop *) (* cutoff = 1 *) let amerge_3a cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let i1 = ref src1ofs and i2 = ref src2ofs and d = ref dstofs and src1r = src1ofs + src1len and src2r = src2ofs + src2len in while !i1 < src1r && !i2 < src2r do let s1 = a.(!i1) and s2 = src2.(!i2) in if cmp s1 s2 <= 0 then begin dst.(!d) <- s1; incr i1; end else begin dst.(!d) <- s2; incr i2; end; incr d; done; if !i1 < src1r then Array.blit a !i1 dst !d (src1r - !i1) else Array.blit src2 !i2 dst !d (src2r - !i2) in let rec sortto srcofs dst dstofs len = assert (len > 0); if len = 1 then dst.(dstofs) <- a.(srcofs) else let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs+l1) dst (dstofs+l1) l2; sortto srcofs a (srcofs+l2) l1; merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; in let l = Array.length a in if l <= 1 then () else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let amerge_3b cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let i1 = ref src1ofs and i2 = ref src2ofs and d = ref dstofs and src1r = src1ofs + src1len and src2r = src2ofs + src2len in while !i1 < src1r && !i2 < src2r do let s1 = a.(!i1) and s2 = src2.(!i2) in if cmp s1 s2 <= 0 then begin dst.(!d) <- s1; incr i1; end else begin dst.(!d) <- s2; incr i2; end; incr d; done; if !i1 < src1r then Array.blit a !i1 dst !d (src1r - !i1) else Array.blit src2 !i2 dst !d (src2r - !i2) in let rec sortto srcofs dst dstofs len = assert (len > 0); if len = 1 then dst.(dstofs) <- a.(srcofs) else if len = 2 then begin if cmp a.(srcofs) a.(srcofs+1) <= 0 then begin dst.(dstofs) <- a.(srcofs); dst.(dstofs+1) <- a.(srcofs+1); end else begin dst.(dstofs) <- a.(srcofs+1); dst.(dstofs+1) <- a.(srcofs); end end else begin let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs+l1) dst (dstofs+l1) l2; sortto srcofs a (srcofs+l2) l1; merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; end in let l = Array.length a in if l <= 1 then () else if l = 2 then begin if cmp a.(0) a.(1) > 0 then begin let e = a.(0) in a.(0) <- a.(1); a.(1) <- e; end; end else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 3;; let amerge_3c cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let i1 = ref src1ofs and i2 = ref src2ofs and d = ref dstofs and src1r = src1ofs + src1len and src2r = src2ofs + src2len in while !i1 < src1r && !i2 < src2r do let s1 = a.(!i1) and s2 = src2.(!i2) in if cmp s1 s2 <= 0 then begin dst.(!d) <- s1; incr i1; end else begin dst.(!d) <- s2; incr i2; end; incr d; done; if !i1 < src1r then Array.blit a !i1 dst !d (src1r - !i1) else Array.blit src2 !i2 dst !d (src2r - !i2) in let isortto srcofs dst dstofs len = for i = 0 to len-1 do let e = a.(srcofs+i) in let j = ref (dstofs+i-1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs+l1) dst (dstofs+l1) l2; sortto srcofs a (srcofs+l2) l1; merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 4;; let amerge_3d cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let i1 = ref src1ofs and i2 = ref src2ofs and d = ref dstofs and src1r = src1ofs + src1len and src2r = src2ofs + src2len in while !i1 < src1r && !i2 < src2r do let s1 = a.(!i1) and s2 = src2.(!i2) in if cmp s1 s2 <= 0 then begin dst.(!d) <- s1; incr i1; end else begin dst.(!d) <- s2; incr i2; end; incr d; done; if !i1 < src1r then Array.blit a !i1 dst !d (src1r - !i1) else Array.blit src2 !i2 dst !d (src2r - !i2) in let isortto srcofs dst dstofs len = for i = 0 to len-1 do let e = a.(srcofs+i) in let j = ref (dstofs+i-1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs+l1) dst (dstofs+l1) l2; sortto srcofs a (srcofs+l2) l1; merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 5;; let amerge_3e cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let i1 = ref src1ofs and i2 = ref src2ofs and d = ref dstofs and src1r = src1ofs + src1len and src2r = src2ofs + src2len in while !i1 < src1r && !i2 < src2r do let s1 = a.(!i1) and s2 = src2.(!i2) in if cmp s1 s2 <= 0 then begin dst.(!d) <- s1; incr i1; end else begin dst.(!d) <- s2; incr i2; end; incr d; done; if !i1 < src1r then Array.blit a !i1 dst !d (src1r - !i1) else Array.blit src2 !i2 dst !d (src2r - !i2) in let isortto srcofs dst dstofs len = for i = 0 to len-1 do let e = a.(srcofs+i) in let j = ref (dstofs+i-1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs+l1) dst (dstofs+l1) l2; sortto srcofs a (srcofs+l2) l1; merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 6;; let amerge_3f cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let i1 = ref src1ofs and i2 = ref src2ofs and d = ref dstofs and src1r = src1ofs + src1len and src2r = src2ofs + src2len in while !i1 < src1r && !i2 < src2r do let s1 = a.(!i1) and s2 = src2.(!i2) in if cmp s1 s2 <= 0 then begin dst.(!d) <- s1; incr i1; end else begin dst.(!d) <- s2; incr i2; end; incr d; done; if !i1 < src1r then Array.blit a !i1 dst !d (src1r - !i1) else Array.blit src2 !i2 dst !d (src2r - !i2) in let isortto srcofs dst dstofs len = for i = 0 to len-1 do let e = a.(srcofs+i) in let j = ref (dstofs+i-1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs+l1) dst (dstofs+l1) l2; sortto srcofs a (srcofs+l2) l1; merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 7;; let amerge_3g cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let i1 = ref src1ofs and i2 = ref src2ofs and d = ref dstofs and src1r = src1ofs + src1len and src2r = src2ofs + src2len in while !i1 < src1r && !i2 < src2r do let s1 = a.(!i1) and s2 = src2.(!i2) in if cmp s1 s2 <= 0 then begin dst.(!d) <- s1; incr i1; end else begin dst.(!d) <- s2; incr i2; end; incr d; done; if !i1 < src1r then Array.blit a !i1 dst !d (src1r - !i1) else Array.blit src2 !i2 dst !d (src2r - !i2) in let isortto srcofs dst dstofs len = for i = 0 to len-1 do let e = a.(srcofs+i) in let j = ref (dstofs+i-1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs+l1) dst (dstofs+l1) l2; sortto srcofs a (srcofs+l2) l1; merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 8;; let amerge_3h cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let i1 = ref src1ofs and i2 = ref src2ofs and d = ref dstofs and src1r = src1ofs + src1len and src2r = src2ofs + src2len in while !i1 < src1r && !i2 < src2r do let s1 = a.(!i1) and s2 = src2.(!i2) in if cmp s1 s2 <= 0 then begin dst.(!d) <- s1; incr i1; end else begin dst.(!d) <- s2; incr i2; end; incr d; done; if !i1 < src1r then Array.blit a !i1 dst !d (src1r - !i1) else Array.blit src2 !i2 dst !d (src2r - !i2) in let isortto srcofs dst dstofs len = for i = 0 to len-1 do let e = a.(srcofs+i) in let j = ref (dstofs+i-1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs+l1) dst (dstofs+l1) l2; sortto srcofs a (srcofs+l2) l1; merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 9;; let amerge_3i cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let i1 = ref src1ofs and i2 = ref src2ofs and d = ref dstofs and src1r = src1ofs + src1len and src2r = src2ofs + src2len in while !i1 < src1r && !i2 < src2r do let s1 = a.(!i1) and s2 = src2.(!i2) in if cmp s1 s2 <= 0 then begin dst.(!d) <- s1; incr i1; end else begin dst.(!d) <- s2; incr i2; end; incr d; done; if !i1 < src1r then Array.blit a !i1 dst !d (src1r - !i1) else Array.blit src2 !i2 dst !d (src2r - !i2) in let isortto srcofs dst dstofs len = for i = 0 to len-1 do let e = a.(srcofs+i) in let j = ref (dstofs+i-1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs+l1) dst (dstofs+l1) l2; sortto srcofs a (srcofs+l2) l1; merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; let cutoff = 10;; let amerge_3j cmp a = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let i1 = ref src1ofs and i2 = ref src2ofs and d = ref dstofs and src1r = src1ofs + src1len and src2r = src2ofs + src2len in while !i1 < src1r && !i2 < src2r do let s1 = a.(!i1) and s2 = src2.(!i2) in if cmp s1 s2 <= 0 then begin dst.(!d) <- s1; incr i1; end else begin dst.(!d) <- s2; incr i2; end; incr d; done; if !i1 < src1r then Array.blit a !i1 dst !d (src1r - !i1) else Array.blit src2 !i2 dst !d (src2r - !i2) in let isortto srcofs dst dstofs len = for i = 0 to len-1 do let e = a.(srcofs+i) in let j = ref (dstofs+i-1) in while (!j >= dstofs && cmp dst.(!j) e > 0) do dst.(!j + 1) <- dst.(!j); decr j; done; dst.(!j + 1) <- e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs+l1) dst (dstofs+l1) l2; sortto srcofs a (srcofs+l2) l1; merge (srcofs+l2) l1 dst (dstofs+l1) l2 dst dstofs; in let l = Array.length a in if l <= cutoff then isortto 0 a 0 l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 a.(0) in sortto l1 t 0 l2; sortto 0 a l2 l1; merge l2 l1 t 0 l2 a 0; end; ;; (* FIXME essayer bottom-up merge on arrays ? *) (************************************************************************) (* Shell sort on arrays *) let ashell_1 cmp a = let l = Array.length a in let step = ref 1 in while !step < l do step := !step * 3 + 1; done; step := !step / 3; while !step > 0 do for j = !step to l-1 do let e = a.(j) in let k = ref (j - !step) in let k1 = ref j in while !k >= 0 && cmp a.(!k) e > 0 do a.(!k1) <- a.(!k); k1 := !k; k := !k - !step; done; a.(!k1) <- e; done; step := !step / 3; done; ;; let ashell_2 cmp a = let l = Array.length a in let step = ref 1 in while !step < l do step := !step * 3 + 1; done; step := !step / 3; while !step > 0 do for j = !step to l-1 do let e = a.(j) in let k = ref (j - !step) in while !k >= 0 && cmp a.(!k) e > 0 do a.(!k + !step) <- a.(!k); k := !k - !step; done; a.(!k + !step) <- e; done; step := !step / 3; done; ;; let ashell_3 cmp a = let l = Array.length a in let step = ref 1 in while !step < l do step := !step * 3 + 1; done; step := !step / 3; while !step > 0 do for i = 0 to !step - 1 do let j = ref (i + !step) in while !j < l do let e = ref a.(!j) in let k = ref (!j - !step) in if cmp !e a.(i) < 0 then begin let x = !e in e := a.(i); a.(i) <- x; end; while cmp a.(!k) !e > 0 do a.(!k + !step) <- a.(!k); k := !k - !step; done; a.(!k + !step) <- !e; j := !j + !step; done; done; step := !step / 3; done; ;; let force = Lazy.force;; type iilist = Cons of int * iilist Lazy.t;; let rec mult n (Cons (x,l)) = Cons (n*x, lazy (mult n (force l))) let rec merge (Cons (x1, t1) as l1) (Cons (x2, t2) as l2) = if x1 = x2 then Cons (x1, lazy (merge (force t1) (force t2))) else if x1 < x2 then Cons (x1, lazy (merge (force t1) l2)) else Cons (x2, lazy (merge l1 (force t2))) ;; let rec scale = Cons (1, lazy (merge (mult 2 scale) (mult 3 scale)));; let ashell_4 cmp a = let l = Array.length a in let rec loop1 accu (Cons (x, t)) = if x > l then accu else loop1 (x::accu) (force t) in let sc = loop1 [] scale in let rec loop2 = function | [] -> () | step::t -> for i = 0 to step - 1 do let j = ref (i + step) in while !j < l do let e = a.(!j) in let k = ref (!j - step) in while !k >= 0 && cmp a.(!k) e > 0 do a.(!k + step) <- a.(!k); k := !k - step; done; a.(!k + step) <- e; j := !j + step; done; done; loop2 t; in loop2 sc; ;; (************************************************************************) (* Quicksort on arrays *) let cutoff = 1;; let aquick_1a cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in while !p2 <= !p3 do let e = a.(!p3) in let c = cmp e pivot in if c > 0 then begin decr p3; end else if c < 0 then begin a.(!p3) <- a.(!p2); a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end else begin a.(!p3) <- a.(!p2); a.(!p2) <- e; incr p2; end; done; incr p3; let len1 = !p1 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p1; qsort !p3 r) else (qsort !p3 r; qsort l !p1) end else qsort l !p1 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 1 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 2;; let aquick_1b cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in while !p2 <= !p3 do let e = a.(!p3) in let c = cmp e pivot in if c > 0 then begin decr p3; end else if c < 0 then begin a.(!p3) <- a.(!p2); a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end else begin a.(!p3) <- a.(!p2); a.(!p2) <- e; incr p2; end; done; incr p3; let len1 = !p1 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p1; qsort !p3 r) else (qsort !p3 r; qsort l !p1) end else qsort l !p1 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 1 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 3;; let aquick_1c cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in while !p2 <= !p3 do let e = a.(!p3) in let c = cmp e pivot in if c > 0 then begin decr p3; end else if c < 0 then begin a.(!p3) <- a.(!p2); a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end else begin a.(!p3) <- a.(!p2); a.(!p2) <- e; incr p2; end; done; incr p3; let len1 = !p1 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p1; qsort !p3 r) else (qsort !p3 r; qsort l !p1) end else qsort l !p1 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 1 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 4;; let aquick_1d cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in while !p2 <= !p3 do let e = a.(!p3) in let c = cmp e pivot in if c > 0 then begin decr p3; end else if c < 0 then begin a.(!p3) <- a.(!p2); a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end else begin a.(!p3) <- a.(!p2); a.(!p2) <- e; incr p2; end; done; incr p3; let len1 = !p1 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p1; qsort !p3 r) else (qsort !p3 r; qsort l !p1) end else qsort l !p1 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 1 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 5;; let aquick_1e cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in while !p2 <= !p3 do let e = a.(!p3) in let c = cmp e pivot in if c > 0 then begin decr p3; end else if c < 0 then begin a.(!p3) <- a.(!p2); a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end else begin a.(!p3) <- a.(!p2); a.(!p2) <- e; incr p2; end; done; incr p3; let len1 = !p1 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p1; qsort !p3 r) else (qsort !p3 r; qsort l !p1) end else qsort l !p1 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 1 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 6;; let aquick_1f cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in while !p2 <= !p3 do let e = a.(!p3) in let c = cmp e pivot in if c > 0 then begin decr p3; end else if c < 0 then begin a.(!p3) <- a.(!p2); a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end else begin a.(!p3) <- a.(!p2); a.(!p2) <- e; incr p2; end; done; incr p3; let len1 = !p1 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p1; qsort !p3 r) else (qsort !p3 r; qsort l !p1) end else qsort l !p1 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 1 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 7;; let aquick_1g cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref (r - 1) in while !p2 <= !p3 do let e = a.(!p3) in let c = cmp e pivot in if c > 0 then begin decr p3; end else if c < 0 then begin a.(!p3) <- a.(!p2); a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end else begin a.(!p3) <- a.(!p2); a.(!p2) <- e; incr p2; end; done; incr p3; let len1 = !p1 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p1; qsort !p3 r) else (qsort !p3 r; qsort l !p1) end else qsort l !p1 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 1 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 1;; let aquick_2a cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end else begin incr p2; end; done; let len1 = !p1 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p1; qsort !p3 r) else (qsort !p3 r; qsort l !p1) end else qsort l !p1 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 2;; let aquick_2b cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end else begin incr p2; end; done; let len1 = !p1 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p1; qsort !p3 r) else (qsort !p3 r; qsort l !p1) end else qsort l !p1 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 3;; let aquick_2c cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end else begin incr p2; end; done; let len1 = !p1 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p1; qsort !p3 r) else (qsort !p3 r; qsort l !p1) end else qsort l !p1 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 4;; let aquick_2d cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end else begin incr p2; end; done; let len1 = !p1 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p1; qsort !p3 r) else (qsort !p3 r; qsort l !p1) end else qsort l !p1 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 5;; let aquick_2e cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end else begin incr p2; end; done; let len1 = !p1 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p1; qsort !p3 r) else (qsort !p3 r; qsort l !p1) end else qsort l !p1 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 6;; let aquick_2f cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end else begin incr p2; end; done; let len1 = !p1 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p1; qsort !p3 r) else (qsort !p3 r; qsort l !p1) end else qsort l !p1 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 7;; let aquick_2g cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end else begin incr p2; end; done; let len1 = !p1 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p1; qsort !p3 r) else (qsort !p3 r; qsort l !p1) end else qsort l !p1 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 1;; let aquick_3a cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin incr p2; end else begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end done; while !p1 > l do decr p1; decr p2; let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; done; let len1 = !p2 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p2; qsort !p3 r) else (qsort !p3 r; qsort l !p2) end else qsort l !p2 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 2;; let aquick_3b cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin incr p2; end else begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end done; while !p1 > l do decr p1; decr p2; let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; done; let len1 = !p2 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p2; qsort !p3 r) else (qsort !p3 r; qsort l !p2) end else qsort l !p2 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 3;; let aquick_3c cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin incr p2; end else begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end done; while !p1 > l do decr p1; decr p2; let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; done; let len1 = !p2 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p2; qsort !p3 r) else (qsort !p3 r; qsort l !p2) end else qsort l !p2 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 4;; let aquick_3d cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin incr p2; end else begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end done; while !p1 > l do decr p1; decr p2; let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; done; let len1 = !p2 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p2; qsort !p3 r) else (qsort !p3 r; qsort l !p2) end else qsort l !p2 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 5;; let aquick_3e cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin incr p2; end else begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end done; while !p1 > l do decr p1; decr p2; let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; done; let len1 = !p2 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p2; qsort !p3 r) else (qsort !p3 r; qsort l !p2) end else qsort l !p2 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 6;; let aquick_3f cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin incr p2; end else begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end done; while !p1 > l do decr p1; decr p2; let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; done; let len1 = !p2 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p2; qsort !p3 r) else (qsort !p3 r; qsort l !p2) end else qsort l !p2 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 7;; let aquick_3g cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin incr p2; end else begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end done; while !p1 > l do decr p1; decr p2; let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; done; let len1 = !p2 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p2; qsort !p3 r) else (qsort !p3 r; qsort l !p2) end else qsort l !p2 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 8;; let aquick_3h cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin incr p2; end else begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end done; while !p1 > l do decr p1; decr p2; let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; done; let len1 = !p2 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p2; qsort !p3 r) else (qsort !p3 r; qsort l !p2) end else qsort l !p2 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 9;; let aquick_3i cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin incr p2; end else begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end done; while !p1 > l do decr p1; decr p2; let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; done; let len1 = !p2 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p2; qsort !p3 r) else (qsort !p3 r; qsort l !p2) end else qsort l !p2 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; let cutoff = 10;; let aquick_3j cmp a = let rec qsort l r = (* ASSUMES r - l >= 2 *) let m = (l + r) / 2 in let al = a.(l) and am = a.(m) and ar = a.(r - 1) in let pivot = if cmp al am <= 0 then if cmp am ar <= 0 then am else if cmp al ar <= 0 then ar else al else if cmp al ar <= 0 then al else if cmp am ar <= 0 then ar else am in let p1 = ref l and p2 = ref l and p3 = ref r in while !p2 < !p3 do let e = a.(!p2) in let c = cmp e pivot in if c > 0 then begin decr p3; a.(!p2) <- a.(!p3); a.(!p3) <- e; end else if c < 0 then begin incr p2; end else begin a.(!p2) <- a.(!p1); a.(!p1) <- e; incr p1; incr p2; end done; while !p1 > l do decr p1; decr p2; let e = a.(!p1) in a.(!p1) <- a.(!p2); a.(!p2) <- e; done; let len1 = !p2 - l and len2 = r - !p3 in if len1 > cutoff then if len2 > cutoff then begin if len1 < len2 then (qsort l !p2; qsort !p3 r) else (qsort !p3 r; qsort l !p2) end else qsort l !p2 else if len2 > cutoff then qsort !p3 r; in let l = Array.length a in if l > 1 then begin qsort 0 l; let mini = ref 0 in for i = 0 to (min l cutoff) - 1 do if cmp a.(i) a.(!mini) < 0 then mini := i; done; let e = a.(0) in a.(0) <- a.(!mini); a.(!mini) <- e; for i = 1 to l - 1 do let e = a.(i) in let j = ref (i - 1) in while cmp a.(!j) e > 0 do a.(!j + 1) <- a.(!j); decr j; done; a.(!j + 1) <- e; done; end; ;; (************************************************************************) (* Heap sort on arrays (top-down, ternary) *) let aheap_1 cmp a = let l = ref (Array.length a) in let l3 = ref ((!l + 1) / 3) in (* l3 is the first element without sons *) let maxson i = (* ASSUMES i < !l3 *) let i31 = i+i+i+1 in let x = ref i31 in if i31+2 < !l then begin if cmp a.(i31) a.(i31+1) < 0 then x := i31+1; if cmp a.(!x) a.(i31+2) < 0 then x := i31+2; !x end else begin if i31+1 < !l && cmp a.(i31) a.(i31+1) < 0 then i31+1 else i31 end in let rec trickledown i e = (* ASSUMES i < !l3 *) let j = maxson i in if cmp a.(j) e > 0 then begin a.(i) <- a.(j); if j < !l3 then trickledown j e else a.(j) <- e; end else begin a.(i) <- e; end; in for i = !l3 - 1 downto 0 do trickledown i a.(i); done; let m = ref (!l + 1 - 3 * !l3) in while !l > 2 do decr l; if !m = 0 then (m := 2; decr l3) else decr m; let e = a.(!l) in a.(!l) <- a.(0); trickledown 0 e; done; if !l > 1 then begin let e = a.(1) in a.(1) <- a.(0); a.(0) <- e; end; ;; (************************************************************************) (* Heap sort on arrays (top-down, binary) *) (* FIXME essayer application partielle de trickledown (merge avec down) *) (* FIXME essayer expanser maxson dans trickledown; supprimer l'exception. *) let aheap_2 cmp a = let maxson l i e = let i21 = i + i + 1 in if i21 + 1 < l && cmp a.(i21) a.(i21+1) < 0 then i21 + 1 else if i21 < l then i21 else (a.(i) <- e; raise Exit) in let rec trickledown l i e = let j = maxson l i e in if cmp a.(j) e > 0 then begin a.(i) <- a.(j); trickledown l j e; end else begin a.(i) <- e; end; in let down l i e = try trickledown l i e with Exit -> () in let l = Array.length a in for i = l / 2 -1 downto 0 do down l i a.(i); done; for i = l - 1 downto 1 do let e = a.(i) in a.(i) <- a.(0); down i 0 e; done; ;; (************************************************************************) (* Heap sort on arrays (bottom-up, ternary) *) exception Bottom of int;; let aheap_3 cmp a = let maxson l i = let i31 = i+i+i+1 in let x = ref i31 in if i31+2 < l then begin if cmp a.(i31) a.(i31+1) < 0 then x := i31+1; if cmp a.(!x) a.(i31+2) < 0 then x := i31+2; !x end else if i31+1 < l && cmp a.(i31) a.(i31+1) < 0 then i31+1 else if i31 < l then i31 else raise (Bottom i) in let rec trickledown l i e = let j = maxson l i in if cmp a.(j) e > 0 then begin a.(i) <- a.(j); trickledown l j e; end else begin a.(i) <- e; end; in let rec trickle l i e = try trickledown l i e with Bottom i -> a.(i) <- e in let rec bubbledown l i = let j = maxson l i in a.(i) <- a.(j); bubbledown l j; in let bubble l i = try bubbledown l i with Bottom i -> i in let rec trickleup i e = let father = (i - 1) / 3 in assert (i <> father); if cmp a.(father) e < 0 then begin a.(i) <- a.(father); if father > 0 then trickleup father e else a.(0) <- e; end else begin a.(i) <- e; end; in let l = Array.length a in for i = (l + 1) / 3 - 1 downto 0 do trickle l i a.(i); done; for i = l - 1 downto 2 do let e = a.(i) in a.(i) <- a.(0); trickleup (bubble i 0) e; done; if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e); ;; (************************************************************************) (* Heap sort on arrays (bottom-up, binary) *) let aheap_4 cmp a = let maxson l i = let i21 = i + i + 1 in if i21 + 1 < l && cmp a.(i21) a.(i21 + 1) < 0 then i21 + 1 else if i21 < l then i21 else raise (Bottom i) in let rec trickledown l i e = let j = maxson l i in if cmp a.(j) e > 0 then begin a.(i) <- a.(j); trickledown l j e; end else begin a.(i) <- e; end; in let trickle l i e = try trickledown l i e with Bottom i -> a.(i) <- e in let rec bubbledown l i = let j = maxson l i in a.(i) <- a.(j); bubbledown l j; in let bubble l i = try bubbledown l i with Bottom i -> i in let rec trickleup i e = let father = (i - 1) / 2 in assert (i <> father); if cmp a.(father) e < 0 then begin a.(i) <- a.(father); if father > 0 then trickleup father e else a.(0) <- e; end else begin a.(i) <- e; end; in let l = Array.length a in for i = l / 2 - 1 downto 0 do trickle l i a.(i); done; for i = l - 1 downto 2 do let e = a.(i) in a.(i) <- a.(0); trickleup (bubble i 0) e; done; if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e); ;; (************************************************************************) (* heap sort, top-down, ternary, recursive final loop *) let aheap_5 cmp a = let maxson l i = (* ASSUMES i < (l+1)/3 *) let i31 = i+i+i+1 in let x = ref i31 in if i31+2 < l then begin if cmp a.(i31) a.(i31+1) < 0 then x := i31+1; if cmp a.(!x) a.(i31+2) < 0 then x := i31+2; !x end else begin if i31+1 < l && cmp a.(i31) a.(i31+1) < 0 then i31+1 else i31 end in let rec trickledown l l3 i e = (* ASSUMES i < l3 *) let j = maxson l i in if cmp a.(j) e > 0 then begin a.(i) <- a.(j); if j < l3 then trickledown l l3 j e else a.(j) <- e; end else begin a.(i) <- e; end; in let l = Array.length a in let l3 = (l + 1) / 3 in for i = l3 - 1 downto 0 do trickledown l l3 i a.(i); done; let rec loop0 l l3 = let e = a.(l) in a.(l) <- a.(0); trickledown l l3 0 e; loop2 (l-1) (l3-1); and loop1 l l3 = let e = a.(l) in a.(l) <- a.(0); trickledown l l3 0 e; loop0 (l-1) l3; and loop2 l l3 = if l > 1 then begin let e = a.(l) in a.(l) <- a.(0); trickledown l l3 0 e; loop1 (l-1) l3; end else begin let e = a.(1) in a.(1) <- a.(0); a.(0) <- e; end; in if l > 1 then match l + 1 - 3 * l3 with | 0 -> loop2 (l-1) (l3-1); | 1 -> loop0 (l-1) l3; | 2 -> loop1 (l-1) l3; | _ -> assert false; ;; (************************************************************************) (* heap sort, top-down, ternary, with exception *) let aheap_6 cmp a = let maxson e l i = let i31 = i + i + i + 1 in let x = ref i31 in if i31+2 < l then begin if cmp a.(i31) a.(i31+1) < 0 then x := i31+1; if cmp a.(!x) a.(i31+2) < 0 then x := i31+2; !x end else begin if i31+1 < l && cmp a.(i31) a.(i31+1) < 0 then i31+1 else if i31 < l then i31 else (a.(i) <- e; raise Exit) end in let rec trickledown e l i = let j = maxson e l i in if cmp a.(j) e > 0 then begin a.(i) <- a.(j); trickledown e l j; end else begin a.(i) <- e; end; in let down e l i = try trickledown e l i with Exit -> (); in let l = Array.length a in for i = (l + 1) / 3 - 1 downto 0 do down a.(i) l i; done; for i = l - 1 downto 2 do let e = a.(i) in a.(i) <- a.(0); down e i 0; done; if l > 1 then (let e = a.(1) in a.(1) <- a.(0); a.(0) <- e); ;; (* FIXME essayer cutoff pour heapsort *) (************************************************************************) (* Insertion sort with dichotomic search *) let ainsertion_1 cmp a = let rec dicho l r e = if l = r then l else begin let m = (l + r) / 2 in if cmp a.(m) e <= 0 then dicho (m+1) r e else dicho l m e end in for i = 1 to Array.length a - 1 do let e = a.(i) in let j = dicho 0 i e in Array.blit a j a (j + 1) (i - j); a.(j) <- e; done; ;; (************************************************************************) (* merge sort on lists via arrays *) let array_to_list_in_place a = let l = Array.length a in let rec loop accu n p = if p <= 0 then accu else begin if p = n then begin Obj.truncate (Obj.repr a) p; loop (a.(p-1) :: accu) (n-1000) (p-1) end else begin loop (a.(p-1) :: accu) n (p-1) end end in loop [] l l ;; let array_of_list l len = match l with | [] -> [| |] | h::t -> let a = Array.make len h in let rec loop i l = match l with | [] -> () | h::t -> a.(i) <- h; loop (i+1) t in loop 1 t; a ;; let lmerge_0a cmp l = let a = Array.of_list l in amerge_1e cmp a; array_to_list_in_place a ;; let lmerge_0b cmp l = let len = List.length l in if len > 256 then Gc.minor (); let a = array_of_list l len in amerge_1e cmp a; array_to_list_in_place a ;; let lshell_0 cmp l = let a = Array.of_list l in ashell_2 cmp a; array_to_list_in_place a ;; let lquick_0 cmp l = let a = Array.of_list l in aquick_3f cmp a; array_to_list_in_place a ;; (************************************************************************) (* merge sort on arrays via lists *) let amerge_0 cmp a = (* cutoff is not yet used *) let l = lmerge_4e cmp (Array.to_list a) in let rec loop i = function | [] -> () | h::t -> a.(i) <- h; loop (i + 1) t in loop 0 l ;; (************************************************************************) let lold = [ "Sort.list", Sort.list, true; "lmerge_3", lmerge_3, false; "lmerge_4a", lmerge_4a, true; ];; let lnew = [ "List.stable_sort", List.stable_sort, true; "lmerge_0a", lmerge_0a, true; "lmerge_0b", lmerge_0b, true; "lshell_0", lshell_0, false; "lquick_0", lquick_0, false; "lmerge_1a", lmerge_1a, true; "lmerge_1b", lmerge_1b, true; "lmerge_1c", lmerge_1c, true; "lmerge_1d", lmerge_1d, true; "lmerge_4b", lmerge_4b, true; "lmerge_4c", lmerge_4c, true; "lmerge_4d", lmerge_4d, true; "lmerge_4e", lmerge_4e, true; "lmerge_5a", lmerge_5a, true; "lmerge_5b", lmerge_5b, true; "lmerge_5c", lmerge_5c, true; "lmerge_5d", lmerge_5d, true; ];; let anew = [ "Array.stable_sort", Array.stable_sort, true; "Array.sort", Array.sort, false; "amerge_0", amerge_0, true; "amerge_1a", amerge_1a, true; "amerge_1b", amerge_1b, true; "amerge_1c", amerge_1c, true; "amerge_1d", amerge_1d, true; "amerge_1e", amerge_1e, true; "amerge_1f", amerge_1f, true; "amerge_1g", amerge_1g, true; "amerge_1h", amerge_1h, true; "amerge_1i", amerge_1i, true; "amerge_1j", amerge_1j, true; "amerge_3a", amerge_3a, true; "amerge_3b", amerge_3b, true; "amerge_3c", amerge_3c, true; "amerge_3d", amerge_3d, true; "amerge_3e", amerge_3e, true; "amerge_3f", amerge_3f, true; "amerge_3g", amerge_3g, true; "amerge_3h", amerge_3h, true; "amerge_3i", amerge_3i, true; "amerge_3j", amerge_3j, true; "ashell_1", ashell_1, false; "ashell_2", ashell_2, false; "ashell_3", ashell_3, false; "ashell_4", ashell_4, false; "aquick_1a", aquick_1a, false; "aquick_1b", aquick_1b, false; "aquick_1c", aquick_1c, false; "aquick_1d", aquick_1d, false; "aquick_1e", aquick_1e, false; "aquick_1f", aquick_1f, false; "aquick_1g", aquick_1g, false; "aquick_2a", aquick_2a, false; "aquick_2b", aquick_2b, false; "aquick_2c", aquick_2c, false; "aquick_2d", aquick_2d, false; "aquick_2e", aquick_2e, false; "aquick_2f", aquick_2f, false; "aquick_2g", aquick_2g, false; "aquick_3a", aquick_3a, false; "aquick_3b", aquick_3b, false; "aquick_3c", aquick_3c, false; "aquick_3d", aquick_3d, false; "aquick_3e", aquick_3e, false; "aquick_3f", aquick_3f, false; "aquick_3g", aquick_3g, false; "aquick_3h", aquick_3h, false; "aquick_3i", aquick_3i, false; "aquick_3j", aquick_3j, false; "aheap_1", aheap_1, false; "aheap_2", aheap_2, false; "aheap_3", aheap_3, false; "aheap_4", aheap_4, false; "aheap_5", aheap_5, false; "aheap_6", aheap_6, false; "ainsertion_1", ainsertion_1, true; ];; (************************************************************************) (* main program *) type mode = Test_std | Test | Bench1 | Bench2 | Bench3;; let size = ref 22 and mem = ref 0 and mode = ref Test_std and only = ref [] ;; let usage = "Usage: sorts [-size ] [-mem ]\n\ \032 [-seed ] [-test|-bench]" ;; let options = [ "-size", Arg.Int ((:=) size), " Maximum size for benchmarks (default 22)"; "-meg",Arg.Int ((:=) mem)," How many megabytes to preallocate (default 0)"; "-seed", Arg.Int ((:=) seed), " PRNG seed (default 0)"; "-teststd", Arg.Unit (fun () -> mode := Test_std), " Test stdlib (default)"; "-test", Arg.Unit (fun () -> mode := Test), " Select test mode"; "-bench1", Arg.Unit (fun () -> mode := Bench1), " Select bench mode 1"; "-bench2", Arg.Unit (fun () -> mode := Bench2), " Select bench mode 2"; "-bench3", Arg.Unit (fun () -> mode := Bench3), " Select bench mode 3"; "-fn", Arg.String (fun x -> only := x :: !only), " Test/Bench this function (default all)"; ];; let anonymous x = raise (Arg.Bad ("unrecognised option "^x));; let main () = Arg.parse options anonymous usage; Printf.printf "Command line arguments are:"; for i = 1 to Array.length Sys.argv - 1 do Printf.printf " %s" Sys.argv.(i); done; Printf.printf "\n"; ignore (String.create (1048576 * !mem)); Gc.full_major (); (* let a2l = Array.to_list in let l2ak x y = Array.of_list x in let id = fun x -> x in let fst x y = x in let snd x y = y in *) let benchonly f x y z t = match !only with | [] -> f x y z t | l -> if List.mem y l then f x y z t in let testonly x1 x2 x3 x4 x5 x6 = match !only with | [] -> test x1 x2 x3 x4 x5 x6 | l -> if List.mem x1 l then test x1 x2 x3 x4 x5 x6 in match !mode with | Test_std -> begin testonly "List.sort" false List.sort List.sort lc lc; testonly "List.stable_sort" true List.stable_sort List.stable_sort lc lc; testonly "Array.sort" false Array.sort Array.sort ac ac; testonly "Array.stable_sort" true Array.stable_sort Array.stable_sort ac ac; printf "Number of tests failed: %d\n" !numfailed; end; | Test -> begin for i = 0 to List.length lold - 1 do let (name, f1, stable) = List.nth lold i in let (_, f2, _) = List.nth lold i in testonly name stable f1 f2 ll ll; done; testonly "Sort.array" false Sort.array Sort.array al al; for i = 0 to List.length lnew - 1 do let (name, f1, stable) = List.nth lnew i in let (_, f2, _) = List.nth lnew i in testonly name stable f1 f2 lc lc; done; for i = 0 to List.length anew - 1 do let (name, f1, stable) = List.nth anew i in let (_, f2, _) = List.nth anew i in testonly name stable f1 f2 ac ac; done; printf "Number of tests failed: %d\n" !numfailed; end; | Bench1 -> begin let ba = fun x y z -> benchonly bench1a !size x y z and bb = fun x y z -> benchonly bench1b !size x y z and bc = fun x y z -> benchonly bench1c !size x y z in for i = 0 to List.length lold - 1 do let (name, f, stable) = List.nth lold i in ba name f ll; let (name, f, stable) = List.nth lold i in bb name f ll; let (name, f, stable) = List.nth lold i in bc name f ll; done; ba "Sort.array" Sort.array al; bb "Sort.array" Sort.array al; bc "Sort.array" Sort.array al; for i = 0 to List.length lnew - 1 do let (name, f, stable) = List.nth lnew i in ba name f lc; let (name, f, stable) = List.nth lnew i in bb name f lc; let (name, f, stable) = List.nth lnew i in bc name f lc; done; for i = 0 to List.length anew - 1 do let (name, f, stable) = List.nth anew i in ba name f ac; let (name, f, stable) = List.nth anew i in bb name f ac; let (name, f, stable) = List.nth anew i in bc name f ac; done; end; | Bench2 -> begin let b = fun x y z -> benchonly bench2 !size x y z in for i = 0 to List.length lold - 1 do let (name, f, stable) = List.nth lold i in b name f ll; done; b "Sort.array" Sort.array al; for i = 0 to List.length lnew - 1 do let (name, f, stable) = List.nth lnew i in b name f lc; done; for i = 0 to List.length anew - 1 do let (name, f, stable) = List.nth anew i in b name f ac; done; end; | Bench3 -> begin let ba = fun x y z -> benchonly bench3a !size x y z and bb = fun x y z -> benchonly bench3b !size x y z and bc = fun x y z -> benchonly bench3c !size x y z in for i = 0 to List.length lold - 1 do let (name, f, stable) = List.nth lold i in ba name f ll; let (name, f, stable) = List.nth lold i in bb name f ll; let (name, f, stable) = List.nth lold i in bc name f ll; done; for i = 0 to List.length lnew - 1 do let (name, f, stable) = List.nth lnew i in ba name f lc; let (name, f, stable) = List.nth lnew i in bb name f lc; let (name, f, stable) = List.nth lnew i in bc name f lc; done; end; ;; if not !Sys.interactive then Printexc.catch main ();; (* $Id$ *) mingw-ocaml/ocaml/testsuite/tests/basic-io/0000755000175000017500000000000012124403241020337 5ustar tootstootsmingw-ocaml/ocaml/testsuite/tests/basic-io/wc.ml0000644000175000017500000000225612124403241021307 0ustar tootstoots(* Counts characters, lines and words in one or several files. *) let chars = ref 0 and words = ref 0 and lines = ref 0 type state = Inside_word | Outside_word let count_channel in_channel = let rec count status = let c = input_char in_channel in incr chars; match c with '\n' -> incr lines; count Outside_word | ' ' | '\t' -> count Outside_word | _ -> if status = Outside_word then begin incr words; () end; count Inside_word in try count Outside_word with End_of_file -> () let count_file name = let ic = open_in name in count_channel ic; close_in ic let print_result () = print_int !chars; print_string " characters, "; print_int !words; print_string " words, "; print_int !lines; print_string " lines"; print_newline() let count name = count_file name; print_result () let _ = try if Array.length Sys.argv <= 1 then count_channel stdin (* No command-line arguments *) else for i = 1 to Array.length Sys.argv - 1 do count_file Sys.argv.(i) done; print_result () with Sys_error s -> print_string "I/O error: "; print_string s; print_newline() mingw-ocaml/ocaml/testsuite/tests/basic-io/Makefile0000644000175000017500000000021712124403241021777 0ustar tootstootsBASEDIR=../.. #MODULES= MAIN_MODULE=wc EXEC_ARGS=wc.ml include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/tests/basic-io/wc.reference0000644000175000017500000000004512124403241022627 0ustar tootstoots1198 characters, 178 words, 54 lines mingw-ocaml/ocaml/testsuite/interactive/0000755000175000017500000000000012124403241020024 5ustar tootstootsmingw-ocaml/ocaml/testsuite/interactive/lib-signals/0000755000175000017500000000000012124403241022230 5ustar tootstootsmingw-ocaml/ocaml/testsuite/interactive/lib-signals/Makefile0000644000175000017500000000034412124403241023671 0ustar tootstootsBASEDIR=../.. default: @$(OCAMLC) -o program.byte signals.ml @./program.byte @$(OCAMLOPT) -o program.native signals.ml @./program.native clean: defaultclean @rm -fr program.* include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/interactive/lib-signals/signals.ml0000644000175000017500000000212512124403241024222 0ustar tootstootslet rec tak (x, y, z) = if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y)) else z let break_handler _ = print_string "Thank you for pressing ctrl-C."; print_newline(); print_string "Allocating a bit..."; flush stdout; ignore (tak(18,12,6)); print_string "done."; print_newline() let stop_handler _ = print_string "Thank you for pressing ctrl-Z."; print_newline(); print_string "Now raising an exception..."; print_newline(); raise Exit let _ = ignore (Sys.signal Sys.sigint (Sys.Signal_handle break_handler)); ignore (Sys.signal Sys.sigtstp (Sys.Signal_handle stop_handler)); begin try print_string "Computing like crazy..."; print_newline(); for i = 1 to 1000 do ignore (tak(18,12,6)) done; print_string "Reading on input..."; print_newline(); for i = 1 to 5 do try let s = read_line () in print_string ">> "; print_string s; print_newline() with Exit -> print_string "Got Exit, continuing."; print_newline() done with Exit -> print_string "Got Exit, exiting."; print_newline() end; exit 0 mingw-ocaml/ocaml/testsuite/interactive/lib-graph-3/0000755000175000017500000000000012124403241022031 5ustar tootstootsmingw-ocaml/ocaml/testsuite/interactive/lib-graph-3/Makefile0000644000175000017500000000027012124403241023470 0ustar tootstootsBASEDIR=../.. #MODULES= MAIN_MODULE=sorts ADD_COMPFLAGS=-thread LIBRARIES=unix threads graphics include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/interactive/lib-graph-3/sorts.reference0000644000175000017500000000000012124403241025051 0ustar tootstootsmingw-ocaml/ocaml/testsuite/interactive/lib-graph-3/sorts.ml0000644000175000017500000001436512124403241023546 0ustar tootstoots(* Animation of sorting algorithms. *) open Graphics (* Information on a given sorting process *) type graphic_context = { array: int array; (* Data to sort *) x0: int; (* X coordinate, lower left corner *) y0: int; (* Y coordinate, lower left corner *) width: int; (* Width in pixels *) height: int; (* Height in pixels *) nelts: int; (* Number of elements in the array *) maxval: int; (* Max val in the array + 1 *) rad: int (* Dimension of the rectangles *) } (* Array assignment and exchange with screen update *) let screen_mutex = Mutex.create() let draw gc i v = fill_rect (gc.x0 + (gc.width * i) / gc.nelts) (gc.y0 + (gc.height * v) / gc.maxval) gc.rad gc.rad let assign gc i v = Mutex.lock screen_mutex; set_color background; draw gc i gc.array.(i); set_color foreground; draw gc i v; gc.array.(i) <- v; Mutex.unlock screen_mutex let exchange gc i j = let val_i = gc.array.(i) in assign gc i gc.array.(j); assign gc j val_i (* Construction of a graphic context *) let initialize name array maxval x y w h = let (_, label_height) = text_size name in let rad = (w - 2) / (Array.length array) - 1 in let gc = { array = Array.copy array; x0 = x + 1; (* Leave one pixel left for Y axis *) y0 = y + 1; (* Leave one pixel below for X axis *) width = w - 2; (* 1 pixel left, 1 pixel right *) height = h - 1 - label_height - rad; nelts = Array.length array; maxval = maxval; rad = rad } in moveto (gc.x0 - 1) (gc.y0 + gc.height); lineto (gc.x0 - 1) (gc.y0 - 1); lineto (gc.x0 + gc.width) (gc.y0 - 1); moveto (gc.x0 - 1) (gc.y0 + gc.height); draw_string name; for i = 0 to Array.length array - 1 do draw gc i array.(i) done; gc (* Main animation function *) let display functs nelts maxval = let a = Array.create nelts 0 in for i = 0 to nelts - 1 do a.(i) <- Random.int maxval done; let num_finished = ref 0 in let lock_finished = Mutex.create() in let cond_finished = Condition.create() in for i = 0 to Array.length functs - 1 do let (name, funct, x, y, w, h) = functs.(i) in let gc = initialize name a maxval x y w h in Thread.create (fun () -> funct gc; Mutex.lock lock_finished; incr num_finished; Mutex.unlock lock_finished; Condition.signal cond_finished) () done; Mutex.lock lock_finished; while !num_finished < Array.length functs do Condition.wait cond_finished lock_finished done; Mutex.unlock lock_finished; read_key() (***** let delay = ref 0 in try while true do let gc = Queue.take q in begin match gc.action with Finished -> () | Pause f -> gc.action <- f (); for i = 0 to !delay do () done; Queue.add gc q end; if key_pressed() then begin match read_key() with 'q'|'Q' -> raise Exit | '0'..'9' as c -> delay := (Char.code c - 48) * 500 | _ -> () end done with Exit -> () | Queue.Empty -> read_key(); () *****) (* The sorting functions. *) (* Bubble sort *) let bubble_sort gc = let ordered = ref false in while not !ordered do ordered := true; for i = 0 to Array.length gc.array - 2 do if gc.array.(i+1) < gc.array.(i) then begin exchange gc i (i+1); ordered := false end done done (* Insertion sort *) let insertion_sort gc = for i = 1 to Array.length gc.array - 1 do let val_i = gc.array.(i) in let j = ref (i - 1) in while !j >= 0 && val_i < gc.array.(!j) do assign gc (!j + 1) gc.array.(!j); decr j done; assign gc (!j + 1) val_i done (* Selection sort *) let selection_sort gc = for i = 0 to Array.length gc.array - 1 do let min = ref i in for j = i+1 to Array.length gc.array - 1 do if gc.array.(j) < gc.array.(!min) then min := j done; exchange gc i !min done (* Quick sort *) let quick_sort gc = let rec quick lo hi = if lo < hi then begin let i = ref lo in let j = ref hi in let pivot = gc.array.(hi) in while !i < !j do while !i < hi && gc.array.(!i) <= pivot do incr i done; while !j > lo && gc.array.(!j) >= pivot do decr j done; if !i < !j then exchange gc !i !j done; exchange gc !i hi; quick lo (!i-1); quick (!i+1) hi end in quick 0 (Array.length gc.array - 1) (* Merge sort *) let merge_sort gc = let rec merge i l1 l2 = match (l1, l2) with ([], []) -> () | ([], v2::r2) -> assign gc i v2; merge (i+1) l1 r2 | (v1::r1, []) -> assign gc i v1; merge (i+1) r1 l2 | (v1::r1, v2::r2) -> if v1 < v2 then begin assign gc i v1; merge (i+1) r1 l2 end else begin assign gc i v2; merge (i+1) l1 r2 end in let rec msort start len = if len < 2 then () else begin let m = len / 2 in msort start m; msort (start+m) (len-m); merge start (Array.to_list (Array.sub gc.array start m)) (Array.to_list (Array.sub gc.array (start+m) (len-m))) end in msort 0 (Array.length gc.array) (* Main program *) let animate() = open_graph ""; moveto 0 0; draw_string "Press a key to start..."; let seed = ref 0 in while not (key_pressed()) do incr seed done; read_key(); Random.init !seed; clear_graph(); let prompt = "0: fastest ... 9: slowest, press 'q' to quit" in moveto 0 0; draw_string prompt; let (_, h) = text_size prompt in let sx = size_x() / 2 and sy = (size_y() - h) / 3 in display [| "Bubble", bubble_sort, 0, h, sx, sy; "Insertion", insertion_sort, 0, h+sy, sx, sy; "Selection", selection_sort, 0, h+2*sy, sx, sy; "Quicksort", quick_sort, sx, h, sx, sy; (** "Heapsort", heap_sort, sx, h+sy, sx, sy; **) "Mergesort", merge_sort, sx, h+2*sy, sx, sy |] 100 1000; close_graph() let _ = if !Sys.interactive then () else begin animate(); exit 0 end ;; mingw-ocaml/ocaml/testsuite/interactive/lib-gc/0000755000175000017500000000000012124403241021161 5ustar tootstootsmingw-ocaml/ocaml/testsuite/interactive/lib-gc/Makefile0000644000175000017500000000034012124403241022616 0ustar tootstootsBASEDIR=../.. default: @$(OCAMLC) -o program.byte alloc.ml @./program.byte @$(OCAMLOPT) -o program.native alloc.ml @./program.native clean: defaultclean @rm -fr program.* include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/interactive/lib-gc/alloc.ml0000644000175000017500000000305012124403241022603 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Random allocation test *) (* Allocate arrays of strings, of random sizes in [0..1000[, and put them into an array of 32768. Replace a randomly-selected array with a new random-length array. Reiterate ad infinitum. *) let l = 32768;; let m = 1000;; let ar = Array.create l "";; Random.init 1234;; let compact_flag = ref false;; let main () = while true do for i = 1 to 100000 do ar.(Random.int l) <- String.create (Random.int m); done; if !compact_flag then Gc.compact () else Gc.full_major (); print_newline (); Gc.print_stat stdout; flush stdout; done ;; let argspecs = [ "-c", Arg.Set compact_flag, "do heap compactions"; ];; Arg.parse argspecs (fun _ -> ()) "Usage: alloc [-c]";; main ();; mingw-ocaml/ocaml/testsuite/interactive/lib-gc/alloc.result0000644000175000017500000002417112124403241023520 0ustar tootstoots minor_words: 6410964 promoted_words: 6332175 major_words: 6393661 minor_collections: 196 major_collections: 14 heap_words: 3936256 heap_chunks: 31 top_heap_words: 3936256 live_words: 2034808 live_blocks: 31786 free_words: 1901339 free_blocks: 16531 largest_free: 1357 fragments: 109 compactions: 0 minor_words: 12805330 promoted_words: 12664909 major_words: 12739763 minor_collections: 391 major_collections: 21 heap_words: 4571136 heap_chunks: 36 top_heap_words: 4571136 live_words: 2126718 live_blocks: 33282 free_words: 2444325 free_blocks: 19124 largest_free: 1824 fragments: 93 compactions: 0 minor_words: 19215544 promoted_words: 18998176 major_words: 19100845 minor_collections: 586 major_collections: 28 heap_words: 4698112 heap_chunks: 37 top_heap_words: 4698112 live_words: 2135891 live_blocks: 33344 free_words: 2562126 free_blocks: 19238 largest_free: 1405 fragments: 95 compactions: 0 minor_words: 25638028 promoted_words: 25361252 major_words: 25472205 minor_collections: 782 major_collections: 35 heap_words: 4698112 heap_chunks: 37 top_heap_words: 4698112 live_words: 2137378 live_blocks: 33350 free_words: 2560637 free_blocks: 19112 largest_free: 1634 fragments: 97 compactions: 0 minor_words: 32062298 promoted_words: 31721945 major_words: 31842628 minor_collections: 978 major_collections: 41 heap_words: 4698112 heap_chunks: 37 top_heap_words: 4698112 live_words: 2145462 live_blocks: 33351 free_words: 2552521 free_blocks: 19013 largest_free: 1999 fragments: 129 compactions: 0 minor_words: 38449694 promoted_words: 38049841 major_words: 38176354 minor_collections: 1173 major_collections: 48 heap_words: 4698112 heap_chunks: 37 top_heap_words: 4698112 live_words: 2125014 live_blocks: 33351 free_words: 2572992 free_blocks: 19080 largest_free: 1525 fragments: 106 compactions: 0 minor_words: 44846324 promoted_words: 44379560 major_words: 44521194 minor_collections: 1368 major_collections: 55 heap_words: 4698112 heap_chunks: 37 top_heap_words: 4698112 live_words: 2136556 live_blocks: 33351 free_words: 2561444 free_blocks: 19191 largest_free: 1760 fragments: 112 compactions: 0 minor_words: 51240537 promoted_words: 50707711 major_words: 50862160 minor_collections: 1563 major_collections: 61 heap_words: 4698112 heap_chunks: 37 top_heap_words: 4698112 live_words: 2136623 live_blocks: 33351 free_words: 2561383 free_blocks: 18967 largest_free: 1526 fragments: 106 compactions: 0 minor_words: 57628061 promoted_words: 57038039 major_words: 57197286 minor_collections: 1758 major_collections: 68 heap_words: 4698112 heap_chunks: 37 top_heap_words: 4698112 live_words: 2133895 live_blocks: 33351 free_words: 2564119 free_blocks: 19273 largest_free: 1793 fragments: 98 compactions: 0 minor_words: 64028127 promoted_words: 63367620 major_words: 63545093 minor_collections: 1953 major_collections: 74 heap_words: 4698112 heap_chunks: 37 top_heap_words: 4698112 live_words: 2138085 live_blocks: 33351 free_words: 2559920 free_blocks: 19111 largest_free: 1800 fragments: 107 compactions: 0 minor_words: 70438812 promoted_words: 69698963 major_words: 69904882 minor_collections: 2148 major_collections: 80 heap_words: 4698112 heap_chunks: 37 top_heap_words: 4698112 live_words: 2131008 live_blocks: 33351 free_words: 2566995 free_blocks: 19079 largest_free: 1451 fragments: 109 compactions: 0 minor_words: 76852923 promoted_words: 76032234 major_words: 76270123 minor_collections: 2343 major_collections: 86 heap_words: 4698112 heap_chunks: 37 top_heap_words: 4698112 live_words: 2135699 live_blocks: 33351 free_words: 2562313 free_blocks: 19201 largest_free: 2056 fragments: 100 compactions: 0 minor_words: 83248665 promoted_words: 82362663 major_words: 82613979 minor_collections: 2538 major_collections: 92 heap_words: 4698112 heap_chunks: 37 top_heap_words: 4698112 live_words: 2126387 live_blocks: 33351 free_words: 2571625 free_blocks: 19099 largest_free: 1498 fragments: 100 compactions: 0 minor_words: 89636938 promoted_words: 88694885 major_words: 88952817 minor_collections: 2733 major_collections: 99 heap_words: 4698112 heap_chunks: 37 top_heap_words: 4698112 live_words: 2136754 live_blocks: 33351 free_words: 2561246 free_blocks: 19220 largest_free: 1697 fragments: 112 compactions: 0 minor_words: 96030388 promoted_words: 95026453 major_words: 95296004 minor_collections: 2928 major_collections: 106 heap_words: 4698112 heap_chunks: 37 top_heap_words: 4698112 live_words: 2126039 live_blocks: 33351 free_words: 2571956 free_blocks: 19250 largest_free: 1593 fragments: 117 compactions: 0 minor_words: 102436652 promoted_words: 101356198 major_words: 101649957 minor_collections: 3123 major_collections: 113 heap_words: 4698112 heap_chunks: 37 top_heap_words: 4698112 live_words: 2140261 live_blocks: 33351 free_words: 2557747 free_blocks: 19192 largest_free: 1731 fragments: 104 compactions: 0 minor_words: 108832359 promoted_words: 107686065 major_words: 107994506 minor_collections: 3318 major_collections: 119 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2124817 live_blocks: 33351 free_words: 2700160 free_blocks: 19149 largest_free: 1617 fragments: 111 compactions: 0 minor_words: 115220373 promoted_words: 114018413 major_words: 114333086 minor_collections: 3513 major_collections: 125 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2124190 live_blocks: 33351 free_words: 2700795 free_blocks: 19303 largest_free: 1567 fragments: 103 compactions: 0 minor_words: 121628396 promoted_words: 120347328 major_words: 120688494 minor_collections: 3708 major_collections: 131 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2133563 live_blocks: 33351 free_words: 2691408 free_blocks: 19134 largest_free: 2129 fragments: 117 compactions: 0 minor_words: 128038304 promoted_words: 126675491 major_words: 127045570 minor_collections: 3903 major_collections: 137 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2135379 live_blocks: 33351 free_words: 2689601 free_blocks: 19345 largest_free: 1699 fragments: 108 compactions: 0 minor_words: 134429672 promoted_words: 133007487 major_words: 133387404 minor_collections: 4098 major_collections: 143 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2127333 live_blocks: 33351 free_words: 2697647 free_blocks: 19276 largest_free: 1758 fragments: 108 compactions: 0 minor_words: 140831438 promoted_words: 139333508 major_words: 139733383 minor_collections: 4293 major_collections: 149 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2145113 live_blocks: 33351 free_words: 2679876 free_blocks: 19365 largest_free: 1650 fragments: 99 compactions: 0 minor_words: 147229656 promoted_words: 145661743 major_words: 146077858 minor_collections: 4488 major_collections: 155 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2132556 live_blocks: 33351 free_words: 2692441 free_blocks: 19150 largest_free: 1431 fragments: 91 compactions: 0 minor_words: 153646155 promoted_words: 152024536 major_words: 152442636 minor_collections: 4684 major_collections: 161 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2130394 live_blocks: 33351 free_words: 2694592 free_blocks: 19164 largest_free: 1288 fragments: 102 compactions: 0 minor_words: 160038986 promoted_words: 158352855 major_words: 158781961 minor_collections: 4879 major_collections: 167 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2131838 live_blocks: 33351 free_words: 2693140 free_blocks: 19355 largest_free: 1741 fragments: 110 compactions: 0 minor_words: 166458940 promoted_words: 164714552 major_words: 165149249 minor_collections: 5075 major_collections: 173 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2146731 live_blocks: 33351 free_words: 2678258 free_blocks: 19338 largest_free: 1951 fragments: 99 compactions: 0 minor_words: 172869183 promoted_words: 171044208 major_words: 171507681 minor_collections: 5270 major_collections: 179 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2130620 live_blocks: 33351 free_words: 2694346 free_blocks: 19355 largest_free: 1716 fragments: 122 compactions: 0 minor_words: 179276123 promoted_words: 177371439 major_words: 177859651 minor_collections: 5465 major_collections: 185 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2141174 live_blocks: 33351 free_words: 2683827 free_blocks: 19340 largest_free: 1707 fragments: 87 compactions: 0 minor_words: 185681086 promoted_words: 183702557 major_words: 184213391 minor_collections: 5660 major_collections: 191 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2133699 live_blocks: 33351 free_words: 2691284 free_blocks: 19303 largest_free: 1557 fragments: 105 compactions: 0 minor_words: 192087937 promoted_words: 190033229 major_words: 190568763 minor_collections: 5855 major_collections: 197 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2133162 live_blocks: 33351 free_words: 2691831 free_blocks: 19299 largest_free: 1561 fragments: 95 compactions: 0 minor_words: 198496824 promoted_words: 196364203 major_words: 196926470 minor_collections: 6050 major_collections: 203 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2129841 live_blocks: 33351 free_words: 2695139 free_blocks: 19163 largest_free: 1653 fragments: 108 compactions: 0 minor_words: 204889797 promoted_words: 202693452 major_words: 203267275 minor_collections: 6245 major_collections: 209 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2130715 live_blocks: 33351 free_words: 2694271 free_blocks: 19257 largest_free: 1491 fragments: 102 compactions: 0 minor_words: 211268811 promoted_words: 208990042 major_words: 209593734 minor_collections: 6439 major_collections: 215 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2128683 live_blocks: 33351 free_words: 2696320 free_blocks: 19306 largest_free: 1789 fragments: 85 compactions: 0 minor_words: 217673548 promoted_words: 215319820 major_words: 215946607 minor_collections: 6634 major_collections: 221 heap_words: 4825088 heap_chunks: 38 top_heap_words: 4825088 live_words: 2134523 live_blocks: 33351 free_words: 2690457 free_blocks: 19391 largest_free: 1845 fragments: 108 compactions: 0 mingw-ocaml/ocaml/testsuite/interactive/lib-graph/0000755000175000017500000000000012124403241021671 5ustar tootstootsmingw-ocaml/ocaml/testsuite/interactive/lib-graph/Makefile0000644000175000017500000000025512124403241023333 0ustar tootstootsBASEDIR=../.. #MODULES= MAIN_MODULE=graph_example #ADD_COMPFLAGS= LIBRARIES=graphics include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/interactive/lib-graph/graph_example.reference0000644000175000017500000000000012124403241026353 0ustar tootstootsmingw-ocaml/ocaml/testsuite/interactive/lib-graph/graph_example.ml0000644000175000017500000001101212124403241025032 0ustar tootstoots(* To run this example: ******************** 1. Select all the text in this window. 2. Drag it to the toplevel window. 3. Watch the colors. 4. Drag the mouse over the graphics window and click here and there. 5. Type any key to the graphics window to stop the program. *) open Graphics;; open_graph " 480x270";; let xr = size_x () / 2 - 30 and yr = size_y () / 2 - 26 and xg = size_x () / 2 + 30 and yg = size_y () / 2 - 26 and xb = size_x () / 2 and yb = size_y () / 2 + 26 ;; let point x y = let dr = (x-xr)*(x-xr) + (y-yr)*(y-yr) and dg = (x-xg)*(x-xg) + (y-yg)*(y-yg) and db = (x-xb)*(x-xb) + (y-yb)*(y-yb) in if dr > dg && dr > db then set_color (rgb 255 (255*dg/dr) (255*db/dr)) else if dg > db then set_color (rgb (255*dr/dg) 255 (255*db/dg)) else set_color (rgb (255*dr/db) (255*dg/db) 255); fill_rect x y 2 2; ;; for y = (size_y () - 1) / 2 downto 0 do for x = 0 to (size_x () - 1) / 2 do point (2*x) (2*y); done done ;; let n = 0x000000 and w = 0xFFFFFF and b = 0xFFCC99 and y = 0xFFFF00 and o = 0xCC9966 and v = 0x00BB00 and g = 0x888888 and c = 0xDDDDDD and t = transp ;; let caml = make_image [| [|t;t;t;t;t;t;t;t;t;t;t;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;t;t;t;t;|]; [|t;t;t;t;t;t;t;t;t;t;n;n;n;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;t;t;|]; [|t;t;t;t;t;t;t;t;n;n;n;n;n;n;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;t;|]; [|n;n;n;n;n;n;t;n;n;n;n;n;b;b;b;b;b;b;b;n;n;t;t;t;t;t;n;n;n;n;n;t;|]; [|n;o;o;o;o;o;n;n;n;n;b;b;b;b;b;b;b;b;b;b;b;n;n;n;n;n;n;n;n;n;n;t;|]; [|n;o;o;o;o;o;o;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;|]; [|n;o;o;o;o;o;o;o;n;n;n;g;g;g;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;t;|]; [|n;n;o;o;o;o;o;o;o;n;n;n;c;c;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;t;|]; [|t;n;n;o;o;o;o;o;o;o;n;n;n;c;n;n;n;n;n;n;n;b;b;n;n;n;n;n;n;t;t;t;|]; [|t;t;n;n;n;o;o;o;o;o;o;n;n;n;n;n;n;n;n;n;b;b;b;b;n;n;n;n;t;t;t;t;|]; [|t;t;t;t;n;n;o;o;o;o;o;o;n;n;n;n;n;n;n;n;b;b;b;b;b;b;n;n;t;t;t;t;|]; [|t;t;t;t;t;n;n;o;o;o;o;o;o;n;n;n;n;n;n;o;o;b;b;b;b;b;b;n;n;t;t;t;|]; [|t;t;t;t;t;n;n;o;o;o;o;o;o;b;b;b;b;b;n;n;o;o;b;b;b;b;b;b;n;n;t;t;|]; [|t;t;t;t;n;n;n;o;o;o;o;o;b;b;b;b;b;b;b;n;n;o;o;b;b;b;b;b;b;n;n;t;|]; [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;b;b;b;b;n;n;o;o;b;b;b;b;b;b;n;n;|]; [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;n;n;o;o;b;b;b;b;b;n;n;|]; [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;b;n;n;o;o;b;o;b;b;n;n;|]; [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;b;b;n;n;o;o;o;o;o;n;n;|]; [|t;t;t;t;n;n;n;o;o;o;o;b;b;b;b;b;n;n;b;b;b;b;b;b;n;n;o;o;o;o;n;n;|]; [|t;t;t;t;n;n;n;o;o;o;o;o;b;b;b;b;n;n;b;b;b;b;b;b;b;n;n;o;o;n;n;n;|]; [|t;t;t;t;n;n;n;n;o;o;o;o;o;b;b;b;n;n;n;b;b;b;b;b;b;b;n;n;o;n;b;n;|]; [|t;t;t;t;t;n;n;n;o;o;o;o;o;o;b;b;n;n;n;b;b;b;b;b;b;b;b;n;n;n;b;n;|]; [|t;t;t;t;t;t;n;n;o;o;o;o;o;o;o;y;v;y;n;b;b;b;b;b;b;b;b;n;n;b;b;n;|]; [|t;t;t;t;t;t;t;n;o;o;o;o;o;v;y;o;o;n;n;n;b;b;b;b;b;b;b;n;n;b;b;n;|]; [|t;t;t;t;t;t;t;n;o;o;o;y;v;o;o;o;o;n;n;n;n;b;b;b;b;b;b;n;n;b;b;n;|]; [|t;t;t;t;t;t;n;n;o;v;y;o;y;o;o;o;o;o;o;n;n;n;b;b;b;b;b;n;n;b;b;n;|]; [|t;t;t;t;t;t;n;o;y;y;o;o;v;o;o;o;o;o;o;o;n;n;n;b;b;b;n;n;n;b;n;t;|]; [|t;t;t;t;t;n;n;v;o;v;o;o;o;o;o;o;o;o;o;o;o;n;n;n;b;n;n;n;n;b;n;t;|]; [|t;t;t;t;t;n;v;o;o;v;o;o;o;o;o;o;o;o;o;o;o;o;n;n;n;n;n;n;n;n;t;t;|]; [|t;t;t;t;n;n;o;o;o;o;o;o;o;o;o;o;o;o;o;o;o;n;n;n;n;n;n;t;t;t;t;t;|]; [|t;t;t;t;n;o;o;o;o;o;o;o;o;o;o;o;o;o;o;o;n;n;t;t;t;t;t;t;t;t;t;t;|]; [|t;t;t;t;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;n;t;t;t;t;t;t;t;t;t;t;t;|]; |];; (* let x = ref 0 and y = ref 0;; let bg = get_image !x !y 32 32;; while true do let st = wait_next_event [Mouse_motion; Button_down] in if not st.button then draw_image bg !x !y; x := st.mouse_x; y := st.mouse_y; blit_image bg !x !y; draw_image caml !x !y; done;; *) set_color (rgb 0 0 0); remember_mode false; try while true do let st = wait_next_event [Mouse_motion; Button_down; Key_pressed] in synchronize (); if st.keypressed then raise Exit; if st.button then begin remember_mode true; draw_image caml st.mouse_x st.mouse_y; remember_mode false; end; let x = st.mouse_x + 16 and y = st.mouse_y + 16 in moveto 0 y; lineto (x - 25) y; moveto 10000 y; lineto (x + 25) y; moveto x 0; lineto x (y - 25); moveto x 10000; lineto x (y + 25); draw_image caml st.mouse_x st.mouse_y; done with Exit -> () ;; (* To run this example: ******************** 1. Select all the text in this window. 2. Drag it to the toplevel window. 3. Watch the colors. 4. Drag the mouse over the graphics window and click here and there. 5. Type any key to the graphics window to stop the program. *) mingw-ocaml/ocaml/testsuite/interactive/lib-graph-2/0000755000175000017500000000000012124403241022030 5ustar tootstootsmingw-ocaml/ocaml/testsuite/interactive/lib-graph-2/Makefile0000644000175000017500000000025212124403241023467 0ustar tootstootsBASEDIR=../.. #MODULES= MAIN_MODULE=graph_test #ADD_COMPFLAGS= LIBRARIES=graphics include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common mingw-ocaml/ocaml/testsuite/interactive/lib-graph-2/graph_test.ml0000644000175000017500000001476112124403241024533 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2000 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* graph_test.ml : tests various drawing and filling primitives of the Graphics library. *) (* To run this example just load this file into a suitable toplevel. Alternatively execute ocamlc graphics.cma graph_test.ml *) open Graphics;; auto_synchronize false;; display_mode false;; remember_mode true;; let sz = 450;; open_graph (Printf.sprintf " %ix%i" sz sz);; (* To be defined for older versions of OCaml Lineto, moveto and draw_rect. let rlineto x y = let xc, yc = current_point () in lineto (x + xc) (y + yc);; let rmoveto x y = let xc, yc = current_point () in moveto (x + xc) (y + yc);; let draw_rect x y w h = let x0, y0 = current_point () in moveto x y; rlineto w 0; rlineto 0 h; rlineto (- w) 0; rlineto 0 (-h); moveto x0 y0;; *) (* A set of points. *) set_color foreground;; let dashes y = for i = 1 to 100 do plot y (2 * i); plot y (3 * i); plot y (4 * i); done;; dashes 3;; set_line_width 20;; dashes (sz - 20);; (* Drawing chars *) draw_char 'C'; draw_char 'a'; draw_char 'm'; draw_char 'l';; (* More and more red enlarging squares *) moveto 10 10;; set_line_width 5;; let carre c = rlineto 0 c; rlineto c 0; rlineto 0 (- c); rlineto (- c) 0;; for i = 1 to 10 do moveto (10 * i) (10 * i); set_color (rgb (155 + 10 * i) 0 0); carre (10 * i) done;; (* Blue squares in arithmetic progression *) moveto 10 210;; set_color blue;; set_line_width 1;; for i = 1 to 10 do carre (10 * i) done;; (* Tiny circles filled or not *) rmoveto 0 120;; (* Must not change the current point *) fill_circle 20 190 10;; set_color green;; rlineto 0 10;; rmoveto 50 10;; let x, y = current_point () in (* Must not change the current point *) draw_circle x y 20;; set_color black;; rlineto 0 20;; (* Cyan rectangles as a kind of graphical representation *) set_color cyan;; let lw = 15;; set_line_width lw;; let go_caption l = moveto 210 (130 - lw + l);; let go_legend () = go_caption (- 3 * lw);; go_caption 0;; fill_rect 210 130 5 10;; fill_rect 220 130 10 20;; fill_rect 235 130 15 40;; fill_rect 255 130 20 80;; fill_rect 280 130 25 160;; (* A green rectangle below the graph. *) set_color green;; rlineto 50 0;; (* A black frame for each of our rectangles *) set_color black;; set_line_width (lw / 4);; draw_rect 210 130 5 10;; draw_rect 220 130 10 20;; draw_rect 235 130 15 40;; draw_rect 255 130 20 80;; draw_rect 280 130 25 160;; (* A black rectangle after the green one, below the graph. *) set_line_width lw;; rlineto 50 0;; (* Write a text in yellow on a blue background. *) (* x = 210, y = 70 *) go_legend ();; set_text_size 10;; set_color (rgb 150 100 250);; let x,y = current_point () in fill_rect x (y - 5) (8 * 20) 25;; set_color yellow;; go_legend ();; draw_string "Graphics (OCaml)";; (* Pie parts in different colors. *) let draw_green_string s = set_color green; draw_string s;; let draw_red_string s = set_color red; draw_string s;; moveto 120 210;; set_color red;; fill_arc 150 260 25 25 60 300; draw_green_string "A "; draw_red_string "red"; draw_green_string " pie."; set_text_size 5; moveto 180 240; draw_red_string "A "; draw_green_string "green"; draw_red_string " slice.";; set_color green; fill_arc 200 260 25 25 0 60; set_color black; set_line_width 2; draw_arc 200 260 27 27 0 60;; (* Should do nothing since this is a line *) set_color red;; fill_poly [| (40, 10); (150, 70); (150, 10); (40, 10) |];; set_color blue;; (* Drawing polygones. *) (* Redefining the draw_poly primitive for the usual library. *) let draw_poly v = let l = Array.length v in if l > 0 then begin let x0, y0 = current_point () in let p0 = v.(0) in let x, y = p0 in moveto x y; for i = 1 to l - 1 do let x, y = v.(i) in lineto x y done; lineto x y; moveto x0 y0 end;; draw_poly [| (150, 10); (150, 70); (260, 10); (150, 10) |];; (* Filling polygones. *) (* Two equilateral triangles, one red and one blue, and their inside filled in black. *) let equi x y l = [| (x - l / 2, y); (x, y + int_of_float (float_of_int l *. (sqrt 3.0 /. 2.0))); (x + l / 2, y) |];; set_color black;; fill_poly (Array.append (equi 300 20 40) (equi 300 44 (- 40)));; set_line_width 1;; set_color cyan;; draw_poly (equi 300 20 40);; set_color red;; draw_poly (equi 300 44 (- 40));; (* Drawing and filling ellipses. *) let x, y = current_point () in rlineto 10 10; moveto x y; moveto 395 100;; let x, y = current_point () in fill_ellipse x y 25 15;; set_color (rgb 0xFF 0x00 0xFF);; rmoveto 0 (- 50);; let x, y = current_point () in fill_ellipse x y 15 30;; rmoveto (- 45) 0;; let x, y = current_point () in draw_ellipse x y 25 10;; (* Drawing and filling arcs. *) let draw_arc_ellipse x y r1 r2 = set_color green; draw_arc x y r1 r2 60 120; set_color black; draw_arc x y r1 r2 120 420;; set_line_width 3;; let draw_arc_ellipses x y r1 r2 = let step = 5 in for i = 0 to (r1 - step) / (2 * step) do for j = 0 to (r2 - step) / (2 * step) do draw_arc_ellipse x y (3 * i * step) (3 * j * step) done done;; draw_arc_ellipses 20 128 15 50;; let fill_arc_ellipse x y r1 r2 c1 c2 = set_color c1; fill_arc x y r1 r2 60 120; set_color c2; fill_arc x y r1 r2 120 420;; let fill_arc_ellipses x y r1 r2 = let step = 3 in let c1 = ref black and c2 = ref yellow in let exchange r1 r2 = let tmp = !r1 in r1 := !r2; r2 := tmp in for i = r1 / (2 * step) downto 10 do for j = r2 / (2 * step) downto 30 do exchange c1 c2; fill_arc_ellipse x y (3 * i) (3 * j) !c1 !c2 done done;; fill_arc_ellipses 400 240 150 200;; synchronize ();; (* transparent color drawing *) set_color transp;; draw_circle 400 240 50;; draw_circle 400 240 40;; draw_circle 400 240 30;; (* try to go back a normal color *) set_color red;; draw_circle 400 240 20;; synchronize ();; ignore (wait_next_event [Key_pressed]) mingw-ocaml/ocaml/testsuite/interactive/lib-graph-2/graph_test.reference0000644000175000017500000000000012124403241026036 0ustar tootstootsmingw-ocaml/ocaml/testsuite/lib/0000755000175000017500000000000012124403241016255 5ustar tootstootsmingw-ocaml/ocaml/testsuite/lib/Makefile0000644000175000017500000000034412124403241017716 0ustar tootstoots# $Id$ compile: compile-targets promote: defaultpromote clean: defaultclean include ../makefiles/Makefile.common compile-targets: testing.cmi testing.cmo @if [ -z "$(BYTECODE_ONLY)" ]; then \ $(MAKE) testing.cmx; \ fi mingw-ocaml/ocaml/testsuite/lib/testing.mli0000644000175000017500000000315612124403241020442 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Testing auxilliaries. *) val test : bool -> unit;; (** [test e] tests that [e] evaluates to [true]. *) val failure_test : ('a -> 'b) -> 'a -> string -> bool;; (** [failure_test f x s] tests that [f x] raises the exception [Failure s]. *) val test_raises_some_exc : ('a -> 'b) -> 'a -> bool;; (** [test_raises_some_exc f x] tests that [f x] raises an exception. *) val test_raises_this_exc : exn -> ('a -> 'b) -> 'a -> bool;; (** [test_raises_this_exc exc f x] tests that [f x] raises the exception [exc]. *) val test_raises_exc_p : (exn -> bool) -> ('a -> 'b) -> 'a -> bool;; (** [test_raises_exc_p p f x] tests that [f x] raises an exception that verifies predicate [p]. *) val scan_failure_test : ('a -> 'b) -> 'a -> bool;; (** [scan_failure_test f x] tests that [f x] raises [Scanf.Scan_failure]. *) mingw-ocaml/ocaml/testsuite/lib/testing.ml0000644000175000017500000000564112124403241020272 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Pierre Weis, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2006 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Testing auxilliaries. *) open Scanf;; let all_tests_ok = ref true;; let finish () = match !all_tests_ok with | true -> print_endline "\nAll tests succeeded." | _ -> print_endline "\n\n********* Test suite failed. ***********\n";; at_exit finish;; let test_num = ref (-1);; let print_test_number () = print_string " "; print_int !test_num; flush stdout;; let next_test () = incr test_num; print_test_number ();; let print_test_fail () = all_tests_ok := false; print_string (Printf.sprintf "\n********* Test number %i failed ***********\n" !test_num);; let print_failure_test_fail () = all_tests_ok := false; print_string (Printf.sprintf "\n********* Failure Test number %i incorrectly failed ***********\n" !test_num);; let print_failure_test_succeed () = all_tests_ok := false; print_string (Printf.sprintf "\n********* Failure Test number %i failed to fail ***********\n" !test_num);; let test b = next_test (); if not b then print_test_fail ();; (* Applies f to x and checks that the evaluation indeed raises an exception that verifies the predicate [pred]. *) let test_raises_exc_p pred f x = next_test (); try ignore (f x); print_failure_test_succeed (); false with | x -> pred x || (print_failure_test_fail (); false);; (* Applies f to x and checks that the evaluation indeed raises some exception. *) let test_raises_some_exc f = test_raises_exc_p (fun _ -> true) f;; let test_raises_this_exc exc = test_raises_exc_p (fun x -> x = exc);; (* Applies f to x and checks that the evaluation indeed raises exception Failure s. *) let test_raises_this_failure s f x = test_raises_exc_p (fun x -> x = Failure s) f x;; (* Applies f to x and checks that the evaluation indeed raises the exception Failure. *) let test_raises_some_failure f x = test_raises_exc_p (function Failure _ -> true | _ -> false) f x;; let failure_test f x s = test_raises_this_failure s f x;; let any_failure_test = test_raises_some_failure;; let scan_failure_test f x = test_raises_exc_p (function Scan_failure _ -> true | _ -> false) f x;; mingw-ocaml/ocaml/testsuite/makefiles/0000755000175000017500000000000012124403241017447 5ustar tootstootsmingw-ocaml/ocaml/testsuite/makefiles/Makefile.several0000644000175000017500000000433112124403241022550 0ustar tootstoots# $Id$ CC=$(NATIVECC) $(NATIVECCCOMPOPTS) FC=$(FORTAN_COMPILER) CMO_FILES=$(MODULES:=.cmo) CMX_FILES=$(MODULES:=.cmx) CMA_FILES=$(LIBRARIES:=.cma) CMXA_FILES=$(LIBRARIES:=.cmxa) O_FILES=$(C_FILES:=.o) CUSTOM_FLAG=`if [ -z "$(C_FILES)" ]; then true; else echo '-custom'; fi` ADD_CFLAGS+=$(CUSTOM_FLAG) FORTRAN_LIB=`if [ -z "$(F_FILES)" ]; then true; else echo '$(FORTRAN_LIBRARY)'; fi` ADD_CFLAGS+=$(FORTRAN_LIB) ADD_OPTFLAGS+=$(FORTRAN_LIB) check: @if [ -n "$(FORTRAN_COMPILER)" -o -z "$(F_FILES)" ]; then $(MAKE) run-all; fi run-all: @for file in $(C_FILES); do \ $(CC) -c -I$(PREFIX)/lib/ocaml/caml $$file.c; \ done; @for file in $(F_FILES); do \ $(FORTRAN_COMPILER) -c -I$(PREFIX)/lib/ocaml/caml $$file.f; \ done; @for file in *.ml; do \ printf " ... testing '$$file':"; \ $(MAKE) run-file DESC=ocamlc COMP='$(OCAMLC)' COMPFLAGS='$(ADD_COMPFLAGS) $(ADD_CFLAGS) $(O_FILES) -w a $(CMA_FILES) -I $(BASEDIR)/lib $(CMO_FILES)' FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS) && \ if [ -z "$(BYTECODE_ONLY)" ]; then \ $(MAKE) run-file DESC=ocamlopt COMP=$(PREFIX)/bin/ocamlopt COMPFLAGS='$(ADD_COMPFLAGS) $(ADD_OPTFLAGS) $(O_FILES) -w a $(CMXA_FILES) -I $(BASEDIR)/lib $(CMX_FILES)' FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS); \ fi && \ if [ ! -z $(UNSAFE) ]; then \ $(MAKE) run-file DESC=ocamlc-unsafe COMP=$(PREFIX)/bin/ocamlc COMPFLAGS='-w a -unsafe -I $(BASEDIR)/lib $(CMO_FILES)' FILE=$$file && \ if [ -z "$(BYTECODE_ONLY)" ]; then \ $(MAKE) run-file DESC=ocamlopt-unsafe COMP=$(PREFIX)/bin/ocamlopt COMPFLAGS='-w a -unsafe -I $(BASEDIR)/lib $(CMX_FILES)' FILE=$$file; \ fi; \ fi && \ echo " => passed"; \ done; run-file: @printf " $(DESC)" @rm -f program program.exe @$(COMP) $(COMPFLAGS) $(FILE) -o program @if [ -f `basename $(FILE) ml`runner ]; then \ sh `basename $(FILE) ml`runner; \ else \ ./program $(PROGRAM_ARGS) > `basename $(FILE) ml`result; \ fi || (echo " => failed" && exit 1) @if [ -f `basename $(FILE) ml`checker ]; then \ sh `basename $(FILE) ml`checker; \ else \ $(DIFF) `basename $(FILE) ml`reference `basename $(FILE) ml`result > /dev/null; \ fi || (echo " => failed" && exit 1) promote: defaultpromote clean: defaultclean @rm -f *.result ./program program.exe mingw-ocaml/ocaml/testsuite/makefiles/Makefile.toplevel0000644000175000017500000000103012124403241022732 0ustar tootstoots# $Id$ default: @for file in *.ml; do \ $(OCAML) < $$file 2>&1 | grep -v '^ OCaml version' > $$file.result; \ if [ -f $$file.principal.reference ]; then \ $(OCAML) -principal < $$file 2>&1 | grep -v '^ OCaml version' > $$file.principal.result; \ fi; \ done @for file in *.reference; do \ printf " ... testing '$$file':"; \ $(DIFF) $$file `basename $$file reference`result || (echo " => failed" && exit 1) && echo " => passed"; \ done promote: defaultpromote clean: defaultclean @rm -f *.result mingw-ocaml/ocaml/testsuite/makefiles/Makefile.okbad0000644000175000017500000000136612124403241022174 0ustar tootstoots# $Id$ default: compile compile: @for file in *.ml; do \ printf " ... testing '$$file'"; \ if [ `echo $$file | grep bad` ]; then \ $(OCAMLC) -c -w a $$file 2> /dev/null && (echo " => failed" && exit 1) || echo " => passed"; \ else \ test -f `basename $$file ml`mli && $(OCAMLC) -c -w a `basename $$file ml`mli; \ $(OCAMLC) -c -w a $$file 2> /dev/null || (echo " => failed" && exit 1); \ test -f `basename $$file ml`reference && $(OCAMLC) `basename $$file ml`cmo && ./a.out > `basename $$file ml`result && ($(DIFF) `basename $$file ml`reference `basename $$file ml`result || (echo " => failed" && exit 1)); \ echo " => passed"; \ fi; \ done promote: defaultpromote clean: defaultclean @rm -f ./a.out *.cm* *.result mingw-ocaml/ocaml/testsuite/makefiles/Makefile.common0000644000175000017500000000346012124403241022401 0ustar tootstoots# $Id$ TOPDIR=$(BASEDIR)/.. include $(TOPDIR)/config/Makefile DIFF=diff -q BOOTDIR=$(TOPDIR)/boot OCAMLRUN=$(BOOTDIR)/ocamlrun$(EXE) OCAML=$(OCAMLRUN) $(TOPDIR)/ocaml -I $(TOPDIR)/stdlib OCAMLC=$(OCAMLRUN) $(TOPDIR)/ocamlc -I $(TOPDIR)/stdlib OCAMLOPT=$(OCAMLRUN) $(TOPDIR)/ocamlopt -I $(TOPDIR)/stdlib OCAMLDOC=$(OCAMLRUN) $(TOPDIR)/ocamldoc/ocamldoc OCAMLLEX=$(OCAMLRUN) $(TOPDIR)/lex/ocamllex OCAMLMKLIB=$(OCAMLRUN) $(TOPDIR)/tools/ocamlmklib OCAMLYACC=$(TOPDIR)/yacc/ocamlyacc$(EXE) OCAMLBUILD=$(TOPDIR)/_build/ocamlbuild/ocamlbuild.native DUMPOBJ=$(OCAMLRUN) $(TOPDIR)/tool/dumpobj BYTECODE_ONLY=`if [ "$(ARCH)" = "none" -o "$(ASM)" = "none" ]; then echo 'YES'; else echo ''; fi` #COMPFLAGS= #FORTRAN_COMPILER= #FORTRAN_LIBRARY= defaultpromote: @for file in *.reference; do \ cp `basename $$file reference`result $$file; \ done defaultclean: @rm -f *.cmo *.cmi *.cmx *.cma *.cmxa *.cmxs *.$(O) *.$(SO) *.$(A) @for dsym in *.dSYM; do \ if [ -d $$dsym ]; then \ rm -fr $$dsym; \ fi \ done .SUFFIXES: .SUFFIXES: .mli .ml .mly .mll .cmi .cmo .cmx .cmm .cmxa .s .S .o .so .mli.cmi: @$(OCAMLC) -c $(COMPFLAGS) $(ADD_COMPFLAGS) $< .ml.cmi: @$(OCAMLC) -c $(COMPFLAGS) $(ADD_COMPFLAGS) $< .ml.cmo: @if [ -f $ /dev/null .mll.ml: @$(OCAMLLEX) -q $< > /dev/null .cmm.o: @$(OCAMLRUN) ./codegen $*.cmm > $*.s @$(AS) $(ASFLAGS) -o $*.o $*.s .S.o: @$(ASPP) $(ASPPFLAGS) -DSYS_$(SYSTEM) -o $*.o $*.S .s.o: @$(ASPP) $(ASPPFLAGS) -DSYS_$(SYSTEM) -o $*.o $*.s mingw-ocaml/ocaml/testsuite/makefiles/Makefile.one0000644000175000017500000000341112124403241021666 0ustar tootstoots# $Id$ CMI_FILES=$(MODULES:=.cmi) CMO_FILES=$(MODULES:=.cmo) CMX_FILES=$(MODULES:=.cmx) CMA_FILES=$(LIBRARIES:=.cma) CMXA_FILES=$(LIBRARIES:=.cmxa) ML_LEX_FILES=$(LEX_MODULES:=.ml) ML_YACC_FILES=$(YACC_MODULES:=.ml) MLI_YACC_FILES=$(YACC_MODULES:=.mli) ML_FILES=$(ML_LEX_FILES) $(ML_YACC_FILES) O_FILES=$(C_FILES:=.o) ADD_CMO_FILES=$(ADD_MODULES:=.cmo) ADD_CMX_FILES=$(ADD_MODULES:=.cmx) GENERATED_SOURCES=$(ML_LEX_FILES) $(ML_YACC_FILES) $(MLI_YACC_FILES) CUSTOM_FLAG=`if [ -z "$(C_FILES)" ]; then true; else echo '-custom'; fi` ADD_CFLAGS+=$(CUSTOM_FLAG) default: compile run compile: $(ML_FILES) $(CMO_FILES) $(MAIN_MODULE).cmo @for file in $(C_FILES); do \ $(NATIVECC) $(NATIVECCCOMPOPTS) -c -I$(TOPDIR)/byterun $$file.c; \ done; @rm -f program.byte program.byte.exe @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) $(MAIN_MODULE).cmo @if [ -z "$(BYTECODE_ONLY)" ]; then \ rm -f program.native program.native.exe; \ $(MAKE) $(CMX_FILES) $(MAIN_MODULE).cmx; \ $(OCAMLOPT) $(ADD_COMPFLAGS) -o program.native $(O_FILES) $(CMXA_FILES) $(CMX_FILES) $(ADD_CMX_FILES) $(MAIN_MODULE).cmx; \ fi run: @printf " ... testing with ocamlc" @./program.byte $(EXEC_ARGS) > $(MAIN_MODULE).result || (echo " => failed" && exit 1) @$(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result > /dev/null || (echo " => failed" && exit 1) @if [ -z "$(BYTECODE_ONLY)" ]; then \ printf " ocamlopt"; \ ./program.native $(EXEC_ARGS) > $(MAIN_MODULE).result || (echo " => failed" && exit 1); \ $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result > /dev/null || (echo " => failed" && exit 1); \ fi @echo " => passed" promote: defaultpromote clean: defaultclean @rm -f *.result ./program.* $(GENERATED_SOURCES) $(O_FILES) mingw-ocaml/ocaml/yacc/0000755000175000017500000000000012124403241014375 5ustar tootstootsmingw-ocaml/ocaml/yacc/.ignore0000644000175000017500000000005712124403241015663 0ustar tootstootsocamlyacc ocamlyacc.exe version.h .gdb_history mingw-ocaml/ocaml/yacc/error.c0000644000175000017500000001651512124403241015702 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* Based on public-domain code from Berkeley Yacc */ /* $Id$ */ /* routines for printing error messages */ #include "defs.h" void fatal(char *msg) { fprintf(stderr, "%s: f - %s\n", myname, msg); done(2); } void no_space(void) { fprintf(stderr, "%s: f - out of space\n", myname); done(2); } void open_error(char *filename) { fprintf(stderr, "%s: f - cannot open \"%s\"\n", myname, filename); done(2); } void unexpected_EOF(void) { fprintf(stderr, "File \"%s\", line %d: unexpected end-of-file\n", virtual_input_file_name, lineno); done(1); } void print_pos(char *st_line, char *st_cptr) { register char *s; if (st_line == 0) return; for (s = st_line; *s != '\n'; ++s) { if (isprint((unsigned char) *s) || *s == '\t') putc(*s, stderr); else putc('?', stderr); } putc('\n', stderr); for (s = st_line; s < st_cptr; ++s) { if (*s == '\t') putc('\t', stderr); else putc(' ', stderr); } putc('^', stderr); putc('\n', stderr); } void syntax_error(int st_lineno, char *st_line, char *st_cptr) { fprintf(stderr, "File \"%s\", line %d: syntax error\n", virtual_input_file_name, st_lineno); print_pos(st_line, st_cptr); done(1); } void unterminated_comment(int c_lineno, char *c_line, char *c_cptr) { fprintf(stderr, "File \"%s\", line %d: unmatched /*\n", virtual_input_file_name, c_lineno); print_pos(c_line, c_cptr); done(1); } void unterminated_string(int s_lineno, char *s_line, char *s_cptr) { fprintf(stderr, "File \"%s\", line %d: unterminated string\n", virtual_input_file_name, s_lineno); print_pos(s_line, s_cptr); done(1); } void unterminated_text(int t_lineno, char *t_line, char *t_cptr) { fprintf(stderr, "File \"%s\", line %d: unmatched %%{\n", virtual_input_file_name, t_lineno); print_pos(t_line, t_cptr); done(1); } void unterminated_union(int u_lineno, char *u_line, char *u_cptr) { fprintf(stderr, "File \"%s\", line %d: unterminated %%union declaration\n", virtual_input_file_name, u_lineno); print_pos(u_line, u_cptr); done(1); } void over_unionized(char *u_cptr) { fprintf(stderr, "File \"%s\", line %d: too many %%union declarations\n", virtual_input_file_name, lineno); print_pos(line, u_cptr); done(1); } void illegal_tag(int t_lineno, char *t_line, char *t_cptr) { fprintf(stderr, "File \"%s\", line %d: illegal tag\n", virtual_input_file_name, t_lineno); print_pos(t_line, t_cptr); done(1); } void illegal_character(char *c_cptr) { fprintf(stderr, "File \"%s\", line %d: illegal character\n", virtual_input_file_name, lineno); print_pos(line, c_cptr); done(1); } void used_reserved(char *s) { fprintf(stderr, "File \"%s\", line %d: illegal use of reserved symbol \ `%s'\n", virtual_input_file_name, lineno, s); done(1); } void tokenized_start(char *s) { fprintf(stderr, "File \"%s\", line %d: the start symbol `%s' cannot \ be declared to be a token\n", virtual_input_file_name, lineno, s); done(1); } void retyped_warning(char *s) { fprintf(stderr, "File \"%s\", line %d: warning: the type of `%s' has been \ redeclared\n", virtual_input_file_name, lineno, s); } void reprec_warning(char *s) { fprintf(stderr, "File \"%s\", line %d: warning: the precedence of `%s' has \ been redeclared\n", virtual_input_file_name, lineno, s); } void revalued_warning(char *s) { fprintf(stderr, "File \"%s\", line %d: warning: the value of `%s' has been \ redeclared\n", virtual_input_file_name, lineno, s); } void terminal_start(char *s) { fprintf(stderr, "File \"%s\", line %d: the entry point `%s' is a \ token\n", virtual_input_file_name, lineno, s); done(1); } void too_many_entries(void) { fprintf(stderr, "File \"%s\", line %d: more than 256 entry points\n", virtual_input_file_name, lineno); done(1); } void no_grammar(void) { fprintf(stderr, "File \"%s\", line %d: no grammar has been specified\n", virtual_input_file_name, lineno); done(1); } void terminal_lhs(int s_lineno) { fprintf(stderr, "File \"%s\", line %d: a token appears on the lhs \ of a production\n", virtual_input_file_name, s_lineno); done(1); } void prec_redeclared(void) { fprintf(stderr, "File \"%s\", line %d: warning: conflicting %%prec \ specifiers\n", virtual_input_file_name, lineno); } void unterminated_action(int a_lineno, char *a_line, char *a_cptr) { fprintf(stderr, "File \"%s\", line %d: unterminated action\n", virtual_input_file_name, a_lineno); print_pos(a_line, a_cptr); done(1); } void dollar_warning(int a_lineno, int i) { fprintf(stderr, "File \"%s\", line %d: warning: $%d references beyond the \ end of the current rule\n", virtual_input_file_name, a_lineno, i); } void dollar_error(int a_lineno, char *a_line, char *a_cptr) { fprintf(stderr, "File \"%s\", line %d: illegal $-name\n", virtual_input_file_name, a_lineno); print_pos(a_line, a_cptr); done(1); } void untyped_lhs(void) { fprintf(stderr, "File \"%s\", line %d: $$ is untyped\n", virtual_input_file_name, lineno); done(1); } void untyped_rhs(int i, char *s) { fprintf(stderr, "File \"%s\", line %d: $%d (%s) is untyped\n", virtual_input_file_name, lineno, i, s); done(1); } void unknown_rhs(int i) { fprintf(stderr, "File \"%s\", line %d: $%d is unbound\n", virtual_input_file_name, lineno, i); done(1); } void illegal_token_ref(int i, char *name) { fprintf(stderr, "File \"%s\", line %d: $%d refers to terminal `%s', \ which has no argument\n", virtual_input_file_name, lineno, i, name); done(1); } void default_action_error(void) { fprintf(stderr, "File \"%s\", line %d: no action specified for this \ production\n", virtual_input_file_name, lineno); done(1); } void undefined_goal(char *s) { fprintf(stderr, "%s: e - the start symbol `%s' is undefined\n", myname, s); done(1); } void undefined_symbol(char *s) { fprintf(stderr, "%s: e - the symbol `%s' is undefined\n", myname, s); done(1); } void entry_without_type(char *s) { fprintf(stderr, "%s: e - no type has been declared for the start symbol `%s'\n", myname, s); done(1); } void polymorphic_entry_point(char *s) { fprintf(stderr, "%s: e - the start symbol `%s' has a polymorphic type\n", myname, s); done(1); } mingw-ocaml/ocaml/yacc/symtab.c0000644000175000017500000000522412124403241016043 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* Based on public-domain code from Berkeley Yacc */ /* $Id$ */ #include #include "defs.h" bucket **symbol_table; bucket *first_symbol; bucket *last_symbol; int hash(char *name) { register char *s; register int c, k; assert(name && *name); s = name; k = *s; while ((c = *++s)) k = (31*k + c) & (TABLE_SIZE - 1); return (k); } bucket * make_bucket(char *name) { register bucket *bp; assert(name); bp = (bucket *) MALLOC(sizeof(bucket)); if (bp == 0) no_space(); bp->link = 0; bp->next = 0; bp->name = MALLOC(strlen(name) + 1); if (bp->name == 0) no_space(); bp->tag = 0; bp->value = UNDEFINED; bp->index = 0; bp->prec = 0; bp-> class = UNKNOWN; bp->assoc = TOKEN; bp->entry = 0; bp->true_token = 0; if (bp->name == 0) no_space(); strcpy(bp->name, name); return (bp); } bucket * lookup(char *name) { register bucket *bp, **bpp; bpp = symbol_table + hash(name); bp = *bpp; while (bp) { if (strcmp(name, bp->name) == 0) return (bp); bpp = &bp->link; bp = *bpp; } *bpp = bp = make_bucket(name); last_symbol->next = bp; last_symbol = bp; return (bp); } void create_symbol_table(void) { register int i; register bucket *bp; symbol_table = (bucket **) MALLOC(TABLE_SIZE*sizeof(bucket *)); if (symbol_table == 0) no_space(); for (i = 0; i < TABLE_SIZE; i++) symbol_table[i] = 0; bp = make_bucket("error"); bp->index = 1; bp->class = TERM; first_symbol = bp; last_symbol = bp; symbol_table[hash("error")] = bp; } void free_symbol_table(void) { FREE(symbol_table); symbol_table = 0; } void free_symbols(void) { register bucket *p, *q; for (p = first_symbol; p; p = q) { q = p->next; FREE(p); } } mingw-ocaml/ocaml/yacc/reader.c0000644000175000017500000012470612124403241016015 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* Based on public-domain code from Berkeley Yacc */ /* $Id$ */ #include #include "defs.h" /* The line size must be a positive integer. One hundred was chosen */ /* because few lines in Yacc input grammars exceed 100 characters. */ /* Note that if a line exceeds LINESIZE characters, the line buffer */ /* will be expanded to accomodate it. */ #define LINESIZE 100 char *cache; int cinc, cache_size; int ntags, tagmax; char **tag_table; char saw_eof, unionized; char *cptr, *line; int linesize; bucket *goal; int prec; int gensym; char last_was_action; int maxitems; bucket **pitem; int maxrules; bucket **plhs; int name_pool_size; char *name_pool; char line_format[] = "# %d \"%s\"\n"; void start_rule (register bucket *bp, int s_lineno); void cachec(int c) { assert(cinc >= 0); if (cinc >= cache_size) { cache_size += 256; cache = REALLOC(cache, cache_size); if (cache == 0) no_space(); } cache[cinc] = c; ++cinc; } void get_line(void) { register FILE *f = input_file; register int c; register int i; if (saw_eof || (c = getc(f)) == EOF) { if (line) { FREE(line); line = 0; } cptr = 0; saw_eof = 1; return; } if (line == 0 || linesize != (LINESIZE + 1)) { if (line) FREE(line); linesize = LINESIZE + 1; line = MALLOC(linesize); if (line == 0) no_space(); } i = 0; ++lineno; for (;;) { line[i] = c; if (++i >= linesize) { linesize += LINESIZE; line = REALLOC(line, linesize); if (line == 0) no_space(); } if (c == '\n') { line[i] = '\0'; cptr = line; return; } c = getc(f); if (c == EOF) { saw_eof = 1; c = '\n'; } } } char * dup_line(void) { register char *p, *s, *t; if (line == 0) return (0); s = line; while (*s != '\n') ++s; p = MALLOC(s - line + 1); if (p == 0) no_space(); s = line; t = p; while ((*t++ = *s++) != '\n') continue; return (p); } void skip_comment(void) { register char *s; int st_lineno = lineno; char *st_line = dup_line(); char *st_cptr = st_line + (cptr - line); s = cptr + 2; for (;;) { if (*s == '*' && s[1] == '/') { cptr = s + 2; FREE(st_line); return; } if (*s == '\n') { get_line(); if (line == 0) unterminated_comment(st_lineno, st_line, st_cptr); s = cptr; } else ++s; } } char *substring (char *str, int start, int len) { int i; char *buf = MALLOC (len+1); if (buf == NULL) return NULL; for (i = 0; i < len; i++){ buf[i] = str[start+i]; } buf[i] = '\0'; /* PR#4796 */ return buf; } void parse_line_directive (void) { int i = 0, j = 0; int line_number = 0; char *file_name = NULL; again: if (line == 0) return; if (line[i] != '#') return; ++ i; while (line[i] == ' ' || line[i] == '\t') ++ i; if (line[i] < '0' || line[i] > '9') return; while (line[i] >= '0' && line[i] <= '9'){ line_number = line_number * 10 + line[i] - '0'; ++ i; } while (line[i] == ' ' || line[i] == '\t') ++ i; if (line[i] == '"'){ ++ i; j = i; while (line[j] != '"' && line[j] != '\0') ++j; if (line[j] == '"'){ file_name = substring (line, i, j - i); if (file_name == NULL) no_space (); } } lineno = line_number - 1; if (file_name != NULL){ if (virtual_input_file_name != NULL) FREE (virtual_input_file_name); virtual_input_file_name = file_name; } get_line (); goto again; } int nextc(void) { register char *s; if (line == 0) { get_line(); parse_line_directive (); if (line == 0) return (EOF); } s = cptr; for (;;) { switch (*s) { case '\n': get_line(); parse_line_directive (); if (line == 0) return (EOF); s = cptr; break; case ' ': case '\t': case '\f': case '\r': case '\v': case ',': case ';': ++s; break; case '\\': cptr = s; return ('%'); case '/': if (s[1] == '*') { cptr = s; skip_comment(); s = cptr; break; } else if (s[1] == '/') { get_line(); parse_line_directive (); if (line == 0) return (EOF); s = cptr; break; } /* fall through */ default: cptr = s; return (*s); } } } int keyword(void) { register int c; char *t_cptr = cptr; c = *++cptr; if (isalpha(c)) { cinc = 0; for (;;) { if (isalpha(c)) { if (isupper(c)) c = tolower(c); cachec(c); } else if (isdigit(c) || c == '_' || c == '.' || c == '$') cachec(c); else break; c = *++cptr; } cachec(NUL); if (strcmp(cache, "token") == 0 || strcmp(cache, "term") == 0) return (TOKEN); if (strcmp(cache, "type") == 0) return (TYPE); if (strcmp(cache, "left") == 0) return (LEFT); if (strcmp(cache, "right") == 0) return (RIGHT); if (strcmp(cache, "nonassoc") == 0 || strcmp(cache, "binary") == 0) return (NONASSOC); if (strcmp(cache, "start") == 0) return (START); if (strcmp(cache, "union") == 0) return (UNION); if (strcmp(cache, "ident") == 0) return (IDENT); } else { ++cptr; if (c == '{') return (TEXT); if (c == '%' || c == '\\') return (MARK); if (c == '<') return (LEFT); if (c == '>') return (RIGHT); if (c == '0') return (TOKEN); if (c == '2') return (NONASSOC); } syntax_error(lineno, line, t_cptr); /*NOTREACHED*/ return 0; } void copy_ident(void) { register int c; register FILE *f = output_file; c = nextc(); if (c == EOF) unexpected_EOF(); if (c != '"') syntax_error(lineno, line, cptr); ++outline; fprintf(f, "#ident \""); for (;;) { c = *++cptr; if (c == '\n') { fprintf(f, "\"\n"); return; } putc(c, f); if (c == '"') { putc('\n', f); ++cptr; return; } } } void copy_text(void) { register int c; int quote; register FILE *f = text_file; int need_newline = 0; int t_lineno = lineno; char *t_line = dup_line(); char *t_cptr = t_line + (cptr - line - 2); if (*cptr == '\n') { get_line(); if (line == 0) unterminated_text(t_lineno, t_line, t_cptr); } fprintf(f, line_format, lineno, input_file_name); loop: c = *cptr++; switch (c) { case '\n': putc('\n', f); need_newline = 0; get_line(); if (line) goto loop; unterminated_text(t_lineno, t_line, t_cptr); case '"': { int s_lineno = lineno; char *s_line = dup_line(); char *s_cptr = s_line + (cptr - line - 1); quote = c; putc(c, f); for (;;) { c = *cptr++; putc(c, f); if (c == quote) { need_newline = 1; FREE(s_line); goto loop; } if (c == '\n') unterminated_string(s_lineno, s_line, s_cptr); if (c == '\\') { c = *cptr++; putc(c, f); if (c == '\n') { get_line(); if (line == 0) unterminated_string(s_lineno, s_line, s_cptr); } } } } case '\'': putc(c, f); if (cptr[0] != 0 && cptr[0] != '\\' && cptr[1] == '\'') { fwrite(cptr, 1, 2, f); cptr += 2; } else if (cptr[0] == '\\' && isdigit((unsigned char) cptr[1]) && isdigit((unsigned char) cptr[2]) && isdigit((unsigned char) cptr[3]) && cptr[4] == '\'') { fwrite(cptr, 1, 5, f); cptr += 5; } else if (cptr[0] == '\\' && cptr[2] == '\'') { fwrite(cptr, 1, 3, f); cptr += 3; } goto loop; case '(': putc(c, f); need_newline = 1; c = *cptr; if (c == '*') { int c_lineno = lineno; char *c_line = dup_line(); char *c_cptr = c_line + (cptr - line - 1); putc('*', f); ++cptr; for (;;) { c = *cptr++; putc(c, f); if (c == '*' && *cptr == ')') { putc(')', f); ++cptr; FREE(c_line); goto loop; } if (c == '\n') { get_line(); if (line == 0) unterminated_comment(c_lineno, c_line, c_cptr); } } } need_newline = 1; goto loop; case '%': case '\\': if (*cptr == '}') { if (need_newline) putc('\n', f); ++cptr; FREE(t_line); return; } /* fall through */ default: putc(c, f); need_newline = 1; goto loop; } } void copy_union(void) { register int c; int quote; int depth; int u_lineno = lineno; char *u_line = dup_line(); char *u_cptr = u_line + (cptr - line - 6); if (unionized) over_unionized(cptr - 6); unionized = 1; if (!lflag) fprintf(text_file, line_format, lineno, input_file_name); fprintf(text_file, "typedef union"); if (dflag) fprintf(union_file, "typedef union"); depth = 1; cptr++; loop: c = *cptr++; putc(c, text_file); if (dflag) putc(c, union_file); switch (c) { case '\n': get_line(); if (line == 0) unterminated_union(u_lineno, u_line, u_cptr); goto loop; case '{': ++depth; goto loop; case '}': --depth; if (c == '}' && depth == 0) { fprintf(text_file, " YYSTYPE;\n"); FREE(u_line); return; } goto loop; case '\'': case '"': { int s_lineno = lineno; char *s_line = dup_line(); char *s_cptr = s_line + (cptr - line - 1); quote = c; for (;;) { c = *cptr++; putc(c, text_file); if (dflag) putc(c, union_file); if (c == quote) { FREE(s_line); goto loop; } if (c == '\n') unterminated_string(s_lineno, s_line, s_cptr); if (c == '\\') { c = *cptr++; putc(c, text_file); if (dflag) putc(c, union_file); if (c == '\n') { get_line(); if (line == 0) unterminated_string(s_lineno, s_line, s_cptr); } } } } case '(': c = *cptr; if (c == '*') { int c_lineno = lineno; char *c_line = dup_line(); char *c_cptr = c_line + (cptr - line - 1); putc('*', text_file); if (dflag) putc('*', union_file); ++cptr; for (;;) { c = *cptr++; putc(c, text_file); if (dflag) putc(c, union_file); if (c == '*' && *cptr == ')') { putc(')', text_file); if (dflag) putc(')', union_file); ++cptr; FREE(c_line); goto loop; } if (c == '\n') { get_line(); if (line == 0) unterminated_comment(c_lineno, c_line, c_cptr); } } } goto loop; default: goto loop; } } int hexval(int c) { if (c >= '0' && c <= '9') return (c - '0'); if (c >= 'A' && c <= 'F') return (c - 'A' + 10); if (c >= 'a' && c <= 'f') return (c - 'a' + 10); return (-1); } bucket * get_literal(void) { register int c, quote; register int i; register int n; register char *s; register bucket *bp; int s_lineno = lineno; char *s_line = dup_line(); char *s_cptr = s_line + (cptr - line); quote = *cptr++; cinc = 0; for (;;) { c = *cptr++; if (c == quote) break; if (c == '\n') unterminated_string(s_lineno, s_line, s_cptr); if (c == '\\') { char *c_cptr = cptr - 1; c = *cptr++; switch (c) { case '\n': get_line(); if (line == 0) unterminated_string(s_lineno, s_line, s_cptr); continue; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': n = c - '0'; c = *cptr; if (IS_OCTAL(c)) { n = (n << 3) + (c - '0'); c = *++cptr; if (IS_OCTAL(c)) { n = (n << 3) + (c - '0'); ++cptr; } } if (n > MAXCHAR) illegal_character(c_cptr); c = n; break; case 'x': c = *cptr++; n = hexval(c); if (n < 0 || n >= 16) illegal_character(c_cptr); for (;;) { c = *cptr; i = hexval(c); if (i < 0 || i >= 16) break; ++cptr; n = (n << 4) + i; if (n > MAXCHAR) illegal_character(c_cptr); } c = n; break; case 'a': c = 7; break; case 'b': c = '\b'; break; case 'f': c = '\f'; break; case 'n': c = '\n'; break; case 'r': c = '\r'; break; case 't': c = '\t'; break; case 'v': c = '\v'; break; } } cachec(c); } FREE(s_line); n = cinc; s = MALLOC(n); if (s == 0) no_space(); for (i = 0; i < n; ++i) s[i] = cache[i]; cinc = 0; if (n == 1) cachec('\''); else cachec('"'); for (i = 0; i < n; ++i) { c = ((unsigned char *)s)[i]; if (c == '\\' || c == cache[0]) { cachec('\\'); cachec(c); } else if (isprint(c)) cachec(c); else { cachec('\\'); switch (c) { case 7: cachec('a'); break; case '\b': cachec('b'); break; case '\f': cachec('f'); break; case '\n': cachec('n'); break; case '\r': cachec('r'); break; case '\t': cachec('t'); break; case '\v': cachec('v'); break; default: cachec(((c >> 6) & 7) + '0'); cachec(((c >> 3) & 7) + '0'); cachec((c & 7) + '0'); break; } } } if (n == 1) cachec('\''); else cachec('"'); cachec(NUL); bp = lookup(cache); bp->class = TERM; if (n == 1 && bp->value == UNDEFINED) bp->value = *(unsigned char *)s; FREE(s); return (bp); } int is_reserved(char *name) { char *s; if (strcmp(name, ".") == 0 || strcmp(name, "$accept") == 0 || strcmp(name, "$end") == 0) return (1); if (name[0] == '$' && name[1] == '$' && isdigit((unsigned char) name[2])) { s = name + 3; while (isdigit((unsigned char) *s)) ++s; if (*s == NUL) return (1); } return (0); } bucket * get_name(void) { register int c; cinc = 0; for (c = *cptr; IS_IDENT(c); c = *++cptr) cachec(c); cachec(NUL); if (is_reserved(cache)) used_reserved(cache); return (lookup(cache)); } int get_number(void) { register int c; register int n; n = 0; for (c = *cptr; isdigit(c); c = *++cptr) n = 10*n + (c - '0'); return (n); } char * get_tag(void) { register int c; register int i; register char *s; char *t_line = dup_line(); long bracket_depth; cinc = 0; bracket_depth = 0; while (1) { c = *++cptr; if (c == EOF) unexpected_EOF(); if (c == '\n') syntax_error(lineno, line, cptr); if (c == '>' && 0 == bracket_depth && cptr[-1] != '-') break; if (c == '[') ++ bracket_depth; if (c == ']') -- bracket_depth; cachec(c); } ++cptr; cachec(NUL); for (i = 0; i < ntags; ++i) { if (strcmp(cache, tag_table[i]) == 0) return (tag_table[i]); } if (ntags >= tagmax) { tagmax += 16; tag_table = (char **) (tag_table ? REALLOC(tag_table, tagmax*sizeof(char *)) : MALLOC(tagmax*sizeof(char *))); if (tag_table == 0) no_space(); } s = MALLOC(cinc); if (s == 0) no_space(); strcpy(s, cache); tag_table[ntags] = s; ++ntags; FREE(t_line); return (s); } void declare_tokens(int assoc) { register int c; register bucket *bp; int value; char *tag = 0; if (assoc != TOKEN) ++prec; c = nextc(); if (c == EOF) unexpected_EOF(); if (c == '<') { tag = get_tag(); c = nextc(); if (c == EOF) unexpected_EOF(); } for (;;) { if (isalpha(c) || c == '_' || c == '.' || c == '$') bp = get_name(); else if (c == '\'' || c == '"') bp = get_literal(); else return; if (bp == goal) tokenized_start(bp->name); bp->class = TERM; if (tag) { if (bp->tag && tag != bp->tag) retyped_warning(bp->name); bp->tag = tag; } if (assoc == TOKEN) { bp->true_token = 1; } else { if (bp->prec && prec != bp->prec) reprec_warning(bp->name); bp->assoc = assoc; bp->prec = prec; } if (strcmp(bp->name, "EOF") == 0) bp->value = 0; c = nextc(); if (c == EOF) unexpected_EOF(); value = UNDEFINED; if (isdigit(c)) { value = get_number(); if (bp->value != UNDEFINED && value != bp->value) revalued_warning(bp->name); bp->value = value; c = nextc(); if (c == EOF) unexpected_EOF(); } } } void declare_types(void) { register int c; register bucket *bp; char *tag; c = nextc(); if (c == EOF) unexpected_EOF(); if (c != '<') syntax_error(lineno, line, cptr); tag = get_tag(); for (;;) { c = nextc(); if (isalpha(c) || c == '_' || c == '.' || c == '$') bp = get_name(); else if (c == '\'' || c == '"') bp = get_literal(); else return; if (bp->tag && tag != bp->tag) retyped_warning(bp->name); bp->tag = tag; } } void declare_start(void) { register int c; register bucket *bp; static int entry_counter = 0; for (;;) { c = nextc(); if (!isalpha(c) && c != '_' && c != '.' && c != '$') return; bp = get_name(); if (bp->class == TERM) terminal_start(bp->name); bp->entry = ++entry_counter; if (entry_counter == 256) too_many_entries(); } } void read_declarations(void) { register int c, k; cache_size = 256; cache = MALLOC(cache_size); if (cache == 0) no_space(); for (;;) { c = nextc(); if (c == EOF) unexpected_EOF(); if (c != '%') syntax_error(lineno, line, cptr); switch (k = keyword()) { case MARK: return; case IDENT: copy_ident(); break; case TEXT: copy_text(); break; case UNION: copy_union(); break; case TOKEN: case LEFT: case RIGHT: case NONASSOC: declare_tokens(k); break; case TYPE: declare_types(); break; case START: declare_start(); break; } } } void output_token_type(void) { bucket * bp; int n; fprintf(interface_file, "type token =\n"); if (!rflag) ++outline; fprintf(output_file, "type token =\n"); n = 0; for (bp = first_symbol; bp; bp = bp->next) { if (bp->class == TERM && bp->true_token) { fprintf(interface_file, " | %s", bp->name); fprintf(output_file, " | %s", bp->name); if (bp->tag) { /* Print the type expression in parentheses to make sure that the constructor is unary */ fprintf(interface_file, " of (%s)", bp->tag); fprintf(output_file, " of (%s)", bp->tag); } fprintf(interface_file, "\n"); if (!rflag) ++outline; fprintf(output_file, "\n"); n++; } } fprintf(interface_file, "\n"); if (!rflag) ++outline; fprintf(output_file, "\n"); } void initialize_grammar(void) { nitems = 4; maxitems = 300; pitem = (bucket **) MALLOC(maxitems*sizeof(bucket *)); if (pitem == 0) no_space(); pitem[0] = 0; pitem[1] = 0; pitem[2] = 0; pitem[3] = 0; nrules = 3; maxrules = 100; plhs = (bucket **) MALLOC(maxrules*sizeof(bucket *)); if (plhs == 0) no_space(); plhs[0] = 0; plhs[1] = 0; plhs[2] = 0; rprec = (short *) MALLOC(maxrules*sizeof(short)); if (rprec == 0) no_space(); rprec[0] = 0; rprec[1] = 0; rprec[2] = 0; rassoc = (char *) MALLOC(maxrules*sizeof(char)); if (rassoc == 0) no_space(); rassoc[0] = TOKEN; rassoc[1] = TOKEN; rassoc[2] = TOKEN; } void expand_items(void) { maxitems += 300; pitem = (bucket **) REALLOC(pitem, maxitems*sizeof(bucket *)); if (pitem == 0) no_space(); } void expand_rules(void) { maxrules += 100; plhs = (bucket **) REALLOC(plhs, maxrules*sizeof(bucket *)); if (plhs == 0) no_space(); rprec = (short *) REALLOC(rprec, maxrules*sizeof(short)); if (rprec == 0) no_space(); rassoc = (char *) REALLOC(rassoc, maxrules*sizeof(char)); if (rassoc == 0) no_space(); } void advance_to_start(void) { register int c; register bucket *bp; char *s_cptr; int s_lineno; for (;;) { c = nextc(); if (c != '%') break; s_cptr = cptr; switch (keyword()) { case MARK: no_grammar(); case TEXT: copy_text(); break; case START: declare_start(); break; default: syntax_error(lineno, line, s_cptr); } } c = nextc(); if (!isalpha(c) && c != '_' && c != '.' && c != '_') syntax_error(lineno, line, cptr); bp = get_name(); if (goal == 0) { if (bp->class == TERM) terminal_start(bp->name); goal = bp; } s_lineno = lineno; c = nextc(); if (c == EOF) unexpected_EOF(); if (c != ':') syntax_error(lineno, line, cptr); start_rule(bp, s_lineno); ++cptr; } int at_first; void start_rule(register bucket *bp, int s_lineno) { if (bp->class == TERM) terminal_lhs(s_lineno); bp->class = NONTERM; if (nrules >= maxrules) expand_rules(); plhs[nrules] = bp; rprec[nrules] = UNDEFINED; rassoc[nrules] = TOKEN; at_first = 1; } void end_rule(void) { if (!last_was_action) default_action_error(); last_was_action = 0; if (nitems >= maxitems) expand_items(); pitem[nitems] = 0; ++nitems; ++nrules; } void insert_empty_rule(void) { register bucket *bp, **bpp; assert(cache); sprintf(cache, "$$%d", ++gensym); bp = make_bucket(cache); last_symbol->next = bp; last_symbol = bp; bp->tag = plhs[nrules]->tag; bp->class = NONTERM; if ((nitems += 2) > maxitems) expand_items(); bpp = pitem + nitems - 1; *bpp-- = bp; while ((bpp[0] = bpp[-1])) --bpp; if (++nrules >= maxrules) expand_rules(); plhs[nrules] = plhs[nrules-1]; plhs[nrules-1] = bp; rprec[nrules] = rprec[nrules-1]; rprec[nrules-1] = 0; rassoc[nrules] = rassoc[nrules-1]; rassoc[nrules-1] = TOKEN; } void add_symbol(void) { register int c; register bucket *bp; int s_lineno = lineno; char *ecptr = cptr; c = *cptr; if (c == '\'' || c == '"') bp = get_literal(); else bp = get_name(); c = nextc(); if (c == ':') { end_rule(); start_rule(bp, s_lineno); ++cptr; return; } if (last_was_action) syntax_error (lineno, line, ecptr); last_was_action = 0; if (++nitems > maxitems) expand_items(); pitem[nitems-1] = bp; } void copy_action(void) { register int c; register int i, n; int depth; int quote; bucket *item; char *tagres; register FILE *f = action_file; int a_lineno = lineno; char *a_line = dup_line(); char *a_cptr = a_line + (cptr - line); if (last_was_action) syntax_error (lineno, line, cptr); last_was_action = 1; /* fprintf(f, "(* Rule %d, file %s, line %d *)\n", nrules-2, input_file_name, lineno); */ if (sflag) fprintf(f, "yyact.(%d) <- (fun __caml_parser_env ->\n", nrules-2); else fprintf(f, "; (fun __caml_parser_env ->\n"); n = 0; for (i = nitems - 1; pitem[i]; --i) ++n; for (i = 1; i <= n; i++) { item = pitem[nitems + i - n - 1]; if (item->class == TERM && !item->tag) continue; fprintf(f, " let _%d = ", i); if (item->tag) fprintf(f, "(Parsing.peek_val __caml_parser_env %d : %s) in\n", n - i, item->tag); else if (sflag) fprintf(f, "Parsing.peek_val __caml_parser_env %d in\n", n - i); else fprintf(f, "(Parsing.peek_val __caml_parser_env %d : '%s) in\n", n - i, item->name); } fprintf(f, " Obj.repr(\n"); fprintf(f, line_format, lineno, input_file_name); for (i = 0; i < cptr - line; i++) fputc(' ', f); fputc ('(', f); depth = 1; cptr++; loop: c = *cptr; if (c == '$') { if (isdigit((unsigned char) cptr[1])) { ++cptr; i = get_number(); if (i <= 0 || i > n) unknown_rhs(i); item = pitem[nitems + i - n - 1]; if (item->class == TERM && !item->tag) illegal_token_ref(i, item->name); fprintf(f, "_%d", i); goto loop; } } if (isalpha(c) || c == '_' || c == '$') { do { putc(c, f); c = *++cptr; } while (isalnum(c) || c == '_' || c == '$'); goto loop; } if (c == '}' && depth == 1) { fprintf(f, ")\n# 0\n "); cptr++; tagres = plhs[nrules]->tag; if (tagres) fprintf(f, " : %s))\n", tagres); else if (sflag) fprintf(f, "))\n"); else fprintf(f, " : '%s))\n", plhs[nrules]->name); if (sflag) fprintf(f, "\n"); return; } putc(c, f); ++cptr; switch (c) { case '\n': get_line(); if (line) goto loop; unterminated_action(a_lineno, a_line, a_cptr); case '{': ++depth; goto loop; case '}': --depth; goto loop; case '"': { int s_lineno = lineno; char *s_line = dup_line(); char *s_cptr = s_line + (cptr - line - 1); quote = c; for (;;) { c = *cptr++; putc(c, f); if (c == quote) { FREE(s_line); goto loop; } if (c == '\n') unterminated_string(s_lineno, s_line, s_cptr); if (c == '\\') { c = *cptr++; putc(c, f); if (c == '\n') { get_line(); if (line == 0) unterminated_string(s_lineno, s_line, s_cptr); } } } } case '\'': if (cptr[0] != 0 && cptr[0] != '\\' && cptr[1] == '\'') { fwrite(cptr, 1, 2, f); cptr += 2; } else if (cptr[0] == '\\' && isdigit((unsigned char) cptr[1]) && isdigit((unsigned char) cptr[2]) && isdigit((unsigned char) cptr[3]) && cptr[4] == '\'') { fwrite(cptr, 1, 5, f); cptr += 5; } else if (cptr[0] == '\\' && cptr[2] == '\'') { fwrite(cptr, 1, 3, f); cptr += 3; } goto loop; case '(': c = *cptr; if (c == '*') { int c_lineno = lineno; char *c_line = dup_line(); char *c_cptr = c_line + (cptr - line - 1); putc('*', f); ++cptr; for (;;) { c = *cptr++; putc(c, f); if (c == '*' && *cptr == ')') { putc(')', f); ++cptr; FREE(c_line); goto loop; } if (c == '\n') { get_line(); if (line == 0) unterminated_comment(c_lineno, c_line, c_cptr); } } } goto loop; default: goto loop; } } int mark_symbol(void) { register int c; register bucket *bp; c = cptr[1]; if (c == '%' || c == '\\') { cptr += 2; return (1); } if (c == '=') cptr += 2; else if ((c == 'p' || c == 'P') && ((c = cptr[2]) == 'r' || c == 'R') && ((c = cptr[3]) == 'e' || c == 'E') && ((c = cptr[4]) == 'c' || c == 'C') && ((c = cptr[5], !IS_IDENT(c)))) cptr += 5; else syntax_error(lineno, line, cptr); c = nextc(); if (isalpha(c) || c == '_' || c == '.' || c == '$') bp = get_name(); else if (c == '\'' || c == '"') bp = get_literal(); else { syntax_error(lineno, line, cptr); /*NOTREACHED*/ } if (rprec[nrules] != UNDEFINED && bp->prec != rprec[nrules]) prec_redeclared(); rprec[nrules] = bp->prec; rassoc[nrules] = bp->assoc; return (0); } void read_grammar(void) { register int c; initialize_grammar(); advance_to_start(); for (;;) { c = nextc(); if (c == '|' && at_first){ ++cptr; c = nextc(); } at_first = 0; if (c == EOF) break; if (isalpha(c) || c == '_' || c == '.' || c == '$' || c == '\'' || c == '"') add_symbol(); else if (c == '{' || c == '=') copy_action(); else if (c == '|') { end_rule(); start_rule(plhs[nrules-1], 0); ++cptr; } else if (c == '%') { if (mark_symbol()) break; } else syntax_error(lineno, line, cptr); } end_rule(); } void free_tags(void) { register int i; if (tag_table == 0) return; for (i = 0; i < ntags; ++i) { assert(tag_table[i]); FREE(tag_table[i]); } FREE(tag_table); } void pack_names(void) { register bucket *bp; register char *p, *s, *t; name_pool_size = 13; /* 13 == sizeof("$end") + sizeof("$accept") */ for (bp = first_symbol; bp; bp = bp->next) name_pool_size += strlen(bp->name) + 1; name_pool = MALLOC(name_pool_size); if (name_pool == 0) no_space(); strcpy(name_pool, "$accept"); strcpy(name_pool+8, "$end"); t = name_pool + 13; for (bp = first_symbol; bp; bp = bp->next) { p = t; s = bp->name; while ((*t++ = *s++)) continue; FREE(bp->name); bp->name = p; } } void check_symbols(void) { register bucket *bp; if (goal->class == UNKNOWN) undefined_goal(goal->name); for (bp = first_symbol; bp; bp = bp->next) { if (bp->class == UNKNOWN) { undefined_symbol(bp->name); bp->class = TERM; } } } void pack_symbols(void) { register bucket *bp; register bucket **v; register int i, j, k, n; nsyms = 2; ntokens = 1; for (bp = first_symbol; bp; bp = bp->next) { ++nsyms; if (bp->class == TERM) ++ntokens; } start_symbol = ntokens; nvars = nsyms - ntokens; symbol_name = (char **) MALLOC(nsyms*sizeof(char *)); if (symbol_name == 0) no_space(); symbol_value = (short *) MALLOC(nsyms*sizeof(short)); if (symbol_value == 0) no_space(); symbol_prec = (short *) MALLOC(nsyms*sizeof(short)); if (symbol_prec == 0) no_space(); symbol_assoc = MALLOC(nsyms); if (symbol_assoc == 0) no_space(); symbol_tag = (char **) MALLOC(nsyms*sizeof(char *)); if (symbol_tag == 0) no_space(); symbol_true_token = (char *) MALLOC(nsyms*sizeof(char)); if (symbol_true_token == 0) no_space(); v = (bucket **) MALLOC(nsyms*sizeof(bucket *)); if (v == 0) no_space(); v[0] = 0; v[start_symbol] = 0; i = 1; j = start_symbol + 1; for (bp = first_symbol; bp; bp = bp->next) { if (bp->class == TERM) v[i++] = bp; else v[j++] = bp; } assert(i == ntokens && j == nsyms); for (i = 1; i < ntokens; ++i) v[i]->index = i; goal->index = start_symbol + 1; k = start_symbol + 2; while (++i < nsyms) if (v[i] != goal) { v[i]->index = k; ++k; } goal->value = 0; k = 1; for (i = start_symbol + 1; i < nsyms; ++i) { if (v[i] != goal) { v[i]->value = k; ++k; } } k = 0; for (i = 1; i < ntokens; ++i) { n = v[i]->value; if (n > 256) { for (j = k++; j > 0 && symbol_value[j-1] > n; --j) symbol_value[j] = symbol_value[j-1]; symbol_value[j] = n; } } if (v[1]->value == UNDEFINED) v[1]->value = 256; j = 0; n = 257; for (i = 2; i < ntokens; ++i) { if (v[i]->value == UNDEFINED) { while (j < k && n == symbol_value[j]) { while (++j < k && n == symbol_value[j]) continue; ++n; } v[i]->value = n; ++n; } } symbol_name[0] = name_pool + 8; symbol_value[0] = 0; symbol_prec[0] = 0; symbol_assoc[0] = TOKEN; symbol_tag[0] = ""; symbol_true_token[0] = 0; for (i = 1; i < ntokens; ++i) { symbol_name[i] = v[i]->name; symbol_value[i] = v[i]->value; symbol_prec[i] = v[i]->prec; symbol_assoc[i] = v[i]->assoc; symbol_tag[i] = v[i]->tag; symbol_true_token[i] = v[i]->true_token; } symbol_name[start_symbol] = name_pool; symbol_value[start_symbol] = -1; symbol_prec[start_symbol] = 0; symbol_assoc[start_symbol] = TOKEN; symbol_tag[start_symbol] = ""; symbol_true_token[start_symbol] = 0; for (++i; i < nsyms; ++i) { k = v[i]->index; symbol_name[k] = v[i]->name; symbol_value[k] = v[i]->value; symbol_prec[k] = v[i]->prec; symbol_assoc[k] = v[i]->assoc; symbol_tag[i] = v[i]->tag; symbol_true_token[i] = v[i]->true_token; } FREE(v); } static unsigned char caml_ident_start[32] = "\000\000\000\000\000\000\000\000\376\377\377\207\376\377\377\007\000\000\000\000\000\000\000\000\377\377\177\377\377\377\177\377"; static unsigned char caml_ident_body[32] = "\000\000\000\000\200\000\377\003\376\377\377\207\376\377\377\007\000\000\000\000\000\000\000\000\377\377\177\377\377\377\177\377"; #define In_bitmap(bm,c) (bm[(unsigned char)(c) >> 3] & (1 << ((c) & 7))) static int is_polymorphic(char * s) { while (*s != 0) { char c = *s++; if (c == '\'' || c == '#') return 1; if (c == '[') { c = *s; while (c == ' ' || c == '\t' || c == '\r' || c == '\n') c = *++s; if (c == '<' || c == '>') return 1; } if (In_bitmap(caml_ident_start, c)) { while (In_bitmap(caml_ident_body, *s)) s++; } } return 0; } void make_goal(void) { static char name[7] = "'\\xxx'"; bucket * bp; bucket * bc; goal = lookup("%entry%"); ntotalrules = nrules - 2; for(bp = first_symbol; bp != 0; bp = bp->next) { if (bp->entry) { start_rule(goal, 0); if (nitems + 2> maxitems) expand_items(); name[2] = '0' + ((bp->entry >> 6) & 7); name[3] = '0' + ((bp->entry >> 3) & 7); name[4] = '0' + (bp->entry & 7); bc = lookup(name); bc->class = TERM; bc->value = (unsigned char) bp->entry; pitem[nitems++] = bc; pitem[nitems++] = bp; if (bp->tag == NULL) entry_without_type(bp->name); if (is_polymorphic(bp->tag)) polymorphic_entry_point(bp->name); fprintf(entry_file, "let %s (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) =\n (Parsing.yyparse yytables %d lexfun lexbuf : %s)\n", bp->name, bp->entry, bp->tag); fprintf(interface_file, "val %s :\n (Lexing.lexbuf -> token) -> Lexing.lexbuf -> %s\n", bp->name, bp->tag); fprintf(action_file, "(* Entry %s *)\n", bp->name); if (sflag) fprintf(action_file, "yyact.(%d) <- (fun __caml_parser_env -> raise " "(Parsing.YYexit (Parsing.peek_val __caml_parser_env 0)))\n", ntotalrules); else fprintf(action_file, "; (fun __caml_parser_env -> raise " "(Parsing.YYexit (Parsing.peek_val __caml_parser_env 0)))\n"); ntotalrules++; last_was_action = 1; end_rule(); } } } void pack_grammar(void) { register int i, j; int assoc, prec; ritem = (short *) MALLOC(nitems*sizeof(short)); if (ritem == 0) no_space(); rlhs = (short *) MALLOC(nrules*sizeof(short)); if (rlhs == 0) no_space(); rrhs = (short *) MALLOC((nrules+1)*sizeof(short)); if (rrhs == 0) no_space(); rprec = (short *) REALLOC(rprec, nrules*sizeof(short)); if (rprec == 0) no_space(); rassoc = REALLOC(rassoc, nrules); if (rassoc == 0) no_space(); ritem[0] = -1; ritem[1] = goal->index; ritem[2] = 0; ritem[3] = -2; rlhs[0] = 0; rlhs[1] = 0; rlhs[2] = start_symbol; rrhs[0] = 0; rrhs[1] = 0; rrhs[2] = 1; j = 4; for (i = 3; i < nrules; ++i) { rlhs[i] = plhs[i]->index; rrhs[i] = j; assoc = TOKEN; prec = 0; while (pitem[j]) { ritem[j] = pitem[j]->index; if (pitem[j]->class == TERM) { prec = pitem[j]->prec; assoc = pitem[j]->assoc; } ++j; } ritem[j] = -i; ++j; if (rprec[i] == UNDEFINED) { rprec[i] = prec; rassoc[i] = assoc; } } rrhs[i] = j; FREE(plhs); FREE(pitem); } void print_grammar(void) { register int i, j, k; int spacing = 0; register FILE *f = verbose_file; if (!vflag) return; k = 1; for (i = 2; i < nrules; ++i) { if (rlhs[i] != rlhs[i-1]) { if (i != 2) fprintf(f, "\n"); fprintf(f, "%4d %s :", i - 2, symbol_name[rlhs[i]]); spacing = strlen(symbol_name[rlhs[i]]) + 1; } else { fprintf(f, "%4d ", i - 2); j = spacing; while (--j >= 0) putc(' ', f); putc('|', f); } while (ritem[k] >= 0) { fprintf(f, " %s", symbol_name[ritem[k]]); ++k; } ++k; putc('\n', f); } } void reader(void) { virtual_input_file_name = substring (input_file_name, 0, strlen (input_file_name)); create_symbol_table(); read_declarations(); output_token_type(); read_grammar(); make_goal(); free_symbol_table(); free_tags(); pack_names(); check_symbols(); pack_symbols(); pack_grammar(); free_symbols(); print_grammar(); } mingw-ocaml/ocaml/yacc/warshall.c0000644000175000017500000000445712124403241016370 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* Based on public-domain code from Berkeley Yacc */ /* $Id$ */ #include "defs.h" void transitive_closure(unsigned int *R, int n) { register int rowsize; register unsigned mask; register unsigned *rowj; register unsigned *rp; register unsigned *rend; register unsigned *ccol; register unsigned *relend; register unsigned *cword; register unsigned *rowi; rowsize = WORDSIZE(n); relend = R + n*rowsize; cword = R; mask = 1; rowi = R; while (rowi < relend) { ccol = cword; rowj = R; while (rowj < relend) { if (*ccol & mask) { rp = rowi; rend = rowj + rowsize; while (rowj < rend) *rowj++ |= *rp++; } else { rowj += rowsize; } ccol += rowsize; } mask <<= 1; if (mask == 0) { mask = 1; cword++; } rowi += rowsize; } } void reflexive_transitive_closure(unsigned int *R, int n) { register int rowsize; register unsigned mask; register unsigned *rp; register unsigned *relend; transitive_closure(R, n); rowsize = WORDSIZE(n); relend = R + n*rowsize; mask = 1; rp = R; while (rp < relend) { *rp |= mask; mask <<= 1; if (mask == 0) { mask = 1; rp++; } rp += rowsize; } } mingw-ocaml/ocaml/yacc/Makefile0000644000175000017500000000275512124403241016046 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # $Id$ # Makefile for the parser generator. include ../config/Makefile CC=$(BYTECC) CFLAGS=-O -DNDEBUG $(BYTECCCOMPOPTS) OBJS= closure.o error.o lalr.o lr0.o main.o mkpar.o output.o reader.o \ skeleton.o symtab.o verbose.o warshall.o all: ocamlyacc$(EXE) ocamlyacc$(EXE): $(OBJS) $(CC) $(CFLAGS) $(CCLINKFLAGS) -o ocamlyacc $(OBJS) version.h : ../VERSION echo "#define OCAML_VERSION \"`sed -e 1q ../VERSION`\"" >version.h clean: rm -f *.o ocamlyacc$(EXE) *~ version.h depend: closure.o: defs.h error.o: defs.h lalr.o: defs.h lr0.o: defs.h main.o: defs.h version.h mkpar.o: defs.h output.o: defs.h reader.o: defs.h skeleton.o: defs.h symtab.o: defs.h verbose.o: defs.h warshall.o: defs.h mingw-ocaml/ocaml/yacc/lr0.c0000644000175000017500000003015312124403241015240 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* Based on public-domain code from Berkeley Yacc */ /* $Id$ */ #include "defs.h" extern short *itemset; extern short *itemsetend; extern unsigned *ruleset; int nstates; core *first_state; shifts *first_shift; reductions *first_reduction; int get_state(int symbol); core *new_state(int symbol); static core **state_set; static core *this_state; static core *last_state; static shifts *last_shift; static reductions *last_reduction; static int nshifts; static short *shift_symbol; static short *redset; static short *shiftset; static short **kernel_base; static short **kernel_end; static short *kernel_items; void initialize_states (void); void save_reductions (void); void new_itemsets (void); void save_shifts (void); void print_derives (); void show_cores (void), show_ritems (void), show_rrhs (void), show_shifts (void); void allocate_itemsets(void) { register short *itemp; register short *item_end; register int symbol; register int i; register int count; register int max; register short *symbol_count; count = 0; symbol_count = NEW2(nsyms, short); item_end = ritem + nitems; for (itemp = ritem; itemp < item_end; itemp++) { symbol = *itemp; if (symbol >= 0) { count++; symbol_count[symbol]++; } } kernel_base = NEW2(nsyms, short *); kernel_items = NEW2(count, short); count = 0; max = 0; for (i = 0; i < nsyms; i++) { kernel_base[i] = kernel_items + count; count += symbol_count[i]; if (max < symbol_count[i]) max = symbol_count[i]; } shift_symbol = symbol_count; kernel_end = NEW2(nsyms, short *); } void allocate_storage(void) { allocate_itemsets(); shiftset = NEW2(nsyms, short); redset = NEW2(nrules + 1, short); state_set = NEW2(nitems, core *); } void append_states(void) { register int i; register int j; register int symbol; #ifdef TRACE fprintf(stderr, "Entering append_states()\n"); #endif for (i = 1; i < nshifts; i++) { symbol = shift_symbol[i]; j = i; while (j > 0 && shift_symbol[j - 1] > symbol) { shift_symbol[j] = shift_symbol[j - 1]; j--; } shift_symbol[j] = symbol; } for (i = 0; i < nshifts; i++) { symbol = shift_symbol[i]; shiftset[i] = get_state(symbol); } } void free_storage(void) { FREE(shift_symbol); FREE(redset); FREE(shiftset); FREE(kernel_base); FREE(kernel_end); FREE(kernel_items); FREE(state_set); } void generate_states(void) { allocate_storage(); itemset = NEW2(nitems, short); ruleset = NEW2(WORDSIZE(nrules), unsigned); set_first_derives(); initialize_states(); while (this_state) { closure(this_state->items, this_state->nitems); save_reductions(); new_itemsets(); append_states(); if (nshifts > 0) save_shifts(); this_state = this_state->next; } finalize_closure(); free_storage(); } int get_state(int symbol) { register int key; register short *isp1; register short *isp2; register short *iend; register core *sp; register int found; register int n; #ifdef TRACE fprintf(stderr, "Entering get_state(%d)\n", symbol); #endif isp1 = kernel_base[symbol]; iend = kernel_end[symbol]; n = iend - isp1; key = *isp1; assert(0 <= key && key < nitems); sp = state_set[key]; if (sp) { found = 0; while (!found) { if (sp->nitems == n) { found = 1; isp1 = kernel_base[symbol]; isp2 = sp->items; while (found && isp1 < iend) { if (*isp1++ != *isp2++) found = 0; } } if (!found) { if (sp->link) { sp = sp->link; } else { sp = sp->link = new_state(symbol); found = 1; } } } } else { state_set[key] = sp = new_state(symbol); } return (sp->number); } void initialize_states(void) { register int i; register short *start_derives; register core *p; start_derives = derives[start_symbol]; for (i = 0; start_derives[i] >= 0; ++i) continue; p = (core *) MALLOC(sizeof(core) + i*sizeof(short)); if (p == 0) no_space(); p->next = 0; p->link = 0; p->number = 0; p->accessing_symbol = 0; p->nitems = i; for (i = 0; start_derives[i] >= 0; ++i) p->items[i] = rrhs[start_derives[i]]; first_state = last_state = this_state = p; nstates = 1; } void new_itemsets(void) { register int i; register int shiftcount; register short *isp; register short *ksp; register int symbol; for (i = 0; i < nsyms; i++) kernel_end[i] = 0; shiftcount = 0; isp = itemset; while (isp < itemsetend) { i = *isp++; symbol = ritem[i]; if (symbol > 0) { ksp = kernel_end[symbol]; if (!ksp) { shift_symbol[shiftcount++] = symbol; ksp = kernel_base[symbol]; } *ksp++ = i + 1; kernel_end[symbol] = ksp; } } nshifts = shiftcount; } core * new_state(int symbol) { register int n; register core *p; register short *isp1; register short *isp2; register short *iend; #ifdef TRACE fprintf(stderr, "Entering new_state(%d)\n", symbol); #endif if (nstates >= MAXSHORT) fatal("too many states"); isp1 = kernel_base[symbol]; iend = kernel_end[symbol]; n = iend - isp1; p = (core *) allocate((unsigned) (sizeof(core) + (n - 1) * sizeof(short))); p->accessing_symbol = symbol; p->number = nstates; p->nitems = n; isp2 = p->items; while (isp1 < iend) *isp2++ = *isp1++; last_state->next = p; last_state = p; nstates++; return (p); } /* show_cores is used for debugging */ void show_cores(void) { core *p; int i, j, k, n; int itemno; k = 0; for (p = first_state; p; ++k, p = p->next) { if (k) printf("\n"); printf("state %d, number = %d, accessing symbol = %s\n", k, p->number, symbol_name[p->accessing_symbol]); n = p->nitems; for (i = 0; i < n; ++i) { itemno = p->items[i]; printf("%4d ", itemno); j = itemno; while (ritem[j] >= 0) ++j; printf("%s :", symbol_name[rlhs[-ritem[j]]]); j = rrhs[-ritem[j]]; while (j < itemno) printf(" %s", symbol_name[ritem[j++]]); printf(" ."); while (ritem[j] >= 0) printf(" %s", symbol_name[ritem[j++]]); printf("\n"); fflush(stdout); } } } /* show_ritems is used for debugging */ void show_ritems(void) { int i; for (i = 0; i < nitems; ++i) printf("ritem[%d] = %d\n", i, ritem[i]); } /* show_rrhs is used for debugging */ void show_rrhs(void) { int i; for (i = 0; i < nrules; ++i) printf("rrhs[%d] = %d\n", i, rrhs[i]); } /* show_shifts is used for debugging */ void show_shifts(void) { shifts *p; int i, j, k; k = 0; for (p = first_shift; p; ++k, p = p->next) { if (k) printf("\n"); printf("shift %d, number = %d, nshifts = %d\n", k, p->number, p->nshifts); j = p->nshifts; for (i = 0; i < j; ++i) printf("\t%d\n", p->shift[i]); } } void save_shifts(void) { register shifts *p; register short *sp1; register short *sp2; register short *send; p = (shifts *) allocate((unsigned) (sizeof(shifts) + (nshifts - 1) * sizeof(short))); p->number = this_state->number; p->nshifts = nshifts; sp1 = shiftset; sp2 = p->shift; send = shiftset + nshifts; while (sp1 < send) *sp2++ = *sp1++; if (last_shift) { last_shift->next = p; last_shift = p; } else { first_shift = p; last_shift = p; } } void save_reductions(void) { register short *isp; register short *rp1; register short *rp2; register int item; register int count; register reductions *p; register short *rend; count = 0; for (isp = itemset; isp < itemsetend; isp++) { item = ritem[*isp]; if (item < 0) { redset[count++] = -item; } } if (count) { p = (reductions *) allocate((unsigned) (sizeof(reductions) + (count - 1) * sizeof(short))); p->number = this_state->number; p->nreds = count; rp1 = redset; rp2 = p->rules; rend = rp1 + count; while (rp1 < rend) *rp2++ = *rp1++; if (last_reduction) { last_reduction->next = p; last_reduction = p; } else { first_reduction = p; last_reduction = p; } } } void set_derives(void) { register int i, k; register int lhs; register short *rules; derives = NEW2(nsyms, short *); rules = NEW2(nvars + nrules, short); k = 0; for (lhs = start_symbol; lhs < nsyms; lhs++) { derives[lhs] = rules + k; for (i = 0; i < nrules; i++) { if (rlhs[i] == lhs) { rules[k] = i; k++; } } rules[k] = -1; k++; } #ifdef DEBUG print_derives(); #endif } void free_derives(void) { FREE(derives[start_symbol]); FREE(derives); } #ifdef DEBUG void print_derives(void) { register int i; register short *sp; printf("\nDERIVES\n\n"); for (i = start_symbol; i < nsyms; i++) { printf("%s derives ", symbol_name[i]); for (sp = derives[i]; *sp >= 0; sp++) { printf(" %d", *sp); } putchar('\n'); } putchar('\n'); } #endif void set_nullable(void) { register int i, j; register int empty; int done; nullable = MALLOC(nsyms); if (nullable == 0) no_space(); for (i = 0; i < nsyms; ++i) nullable[i] = 0; done = 0; while (!done) { done = 1; for (i = 1; i < nitems; i++) { empty = 1; while ((j = ritem[i]) >= 0) { if (!nullable[j]) empty = 0; ++i; } if (empty) { j = rlhs[-j]; if (!nullable[j]) { nullable[j] = 1; done = 0; } } } } #ifdef DEBUG for (i = 0; i < nsyms; i++) { if (nullable[i]) printf("%s is nullable\n", symbol_name[i]); else printf("%s is not nullable\n", symbol_name[i]); } #endif } void free_nullable(void) { FREE(nullable); } void lr0(void) { set_derives(); set_nullable(); generate_states(); } mingw-ocaml/ocaml/yacc/Makefile.nt0000644000175000017500000000312312124403241016454 0ustar tootstoots######################################################################### # # # OCaml # # # # Xavier Leroy, projet Cristal, INRIA Rocquencourt # # # # Copyright 1999 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # # under the terms of the Q Public License version 1.0. # # # ######################################################################### # $Id$ # Makefile for the parser generator. include ../config/Makefile OBJS= closure.$(O) error.$(O) lalr.$(O) lr0.$(O) main.$(O) \ mkpar.$(O) output.$(O) reader.$(O) \ skeleton.$(O) symtab.$(O) verbose.$(O) warshall.$(O) all: ocamlyacc.exe ocamlyacc.exe: $(OBJS) $(MKEXE) -o ocamlyacc.exe $(OBJS) $(EXTRALIBS) version.h : ../VERSION echo "#define OCAML_VERSION \"`sed -e 1q ../VERSION`\"" >version.h clean: rm -f *.$(O) ocamlyacc.exe *~ version.h .SUFFIXES: .c .$(O) .c.$(O): $(BYTECC) -DNDEBUG -DNO_UNIX $(BYTECCCOMPOPTS) -c $< depend: closure.$(O): defs.h error.$(O): defs.h lalr.$(O): defs.h lr0.$(O): defs.h main.$(O): defs.h version.h mkpar.$(O): defs.h output.$(O): defs.h reader.$(O): defs.h skeleton.$(O): defs.h symtab.$(O): defs.h verbose.$(O): defs.h warshall.$(O): defs.h mingw-ocaml/ocaml/yacc/closure.c0000644000175000017500000001373512124403241016226 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* Based on public-domain code from Berkeley Yacc */ /* $Id$ */ #include "defs.h" short *itemset; short *itemsetend; unsigned *ruleset; static unsigned *first_derives; static unsigned *EFF; void print_EFF (); void print_first_derives (); void print_closure (); void set_EFF(void) { register unsigned *row; register int symbol; register short *sp; register int rowsize; register int i; register int rule; rowsize = WORDSIZE(nvars); EFF = NEW2(nvars * rowsize, unsigned); row = EFF; for (i = start_symbol; i < nsyms; i++) { sp = derives[i]; for (rule = *sp; rule > 0; rule = *++sp) { symbol = ritem[rrhs[rule]]; if (ISVAR(symbol)) { symbol -= start_symbol; SETBIT(row, symbol); } } row += rowsize; } reflexive_transitive_closure(EFF, nvars); #ifdef DEBUG print_EFF(); #endif } void set_first_derives(void) { register unsigned *rrow; register unsigned *vrow; register int j; register unsigned mask; register unsigned cword; register short *rp; int rule; int i; int rulesetsize; int varsetsize; rulesetsize = WORDSIZE(nrules); varsetsize = WORDSIZE(nvars); first_derives = NEW2(nvars * rulesetsize, unsigned) - ntokens * rulesetsize; set_EFF(); rrow = first_derives + ntokens * rulesetsize; for (i = start_symbol; i < nsyms; i++) { vrow = EFF + ((i - ntokens) * varsetsize); cword = *vrow++; mask = 1; for (j = start_symbol; j < nsyms; j++) { if (cword & mask) { rp = derives[j]; while ((rule = *rp++) >= 0) { SETBIT(rrow, rule); } } mask <<= 1; if (mask == 0) { cword = *vrow++; mask = 1; } } vrow += varsetsize; rrow += rulesetsize; } #ifdef DEBUG print_first_derives(); #endif FREE(EFF); } void closure(short int *nucleus, int n) { register int ruleno; register unsigned word; register unsigned mask; register short *csp; register unsigned *dsp; register unsigned *rsp; register int rulesetsize; short *csend; unsigned *rsend; int symbol; int itemno; rulesetsize = WORDSIZE(nrules); rsp = ruleset; rsend = ruleset + rulesetsize; for (rsp = ruleset; rsp < rsend; rsp++) *rsp = 0; csend = nucleus + n; for (csp = nucleus; csp < csend; ++csp) { symbol = ritem[*csp]; if (ISVAR(symbol)) { dsp = first_derives + symbol * rulesetsize; rsp = ruleset; while (rsp < rsend) *rsp++ |= *dsp++; } } ruleno = 0; itemsetend = itemset; csp = nucleus; for (rsp = ruleset; rsp < rsend; ++rsp) { word = *rsp; if (word == 0) ruleno += BITS_PER_WORD; else { mask = 1; while (mask) { if (word & mask) { itemno = rrhs[ruleno]; while (csp < csend && *csp < itemno) *itemsetend++ = *csp++; *itemsetend++ = itemno; while (csp < csend && *csp == itemno) ++csp; } mask <<= 1; ++ruleno; } } } while (csp < csend) *itemsetend++ = *csp++; #ifdef DEBUG print_closure(n); #endif } void finalize_closure(void) { FREE(itemset); FREE(ruleset); FREE(first_derives + ntokens * WORDSIZE(nrules)); } #ifdef DEBUG void print_closure(int n) { register short *isp; printf("\n\nn = %d\n\n", n); for (isp = itemset; isp < itemsetend; isp++) printf(" %d\n", *isp); } void print_EFF(void) { register int i, j; register unsigned *rowp; register unsigned word; register unsigned mask; printf("\n\nEpsilon Free Firsts\n"); for (i = start_symbol; i < nsyms; i++) { printf("\n%s", symbol_name[i]); rowp = EFF + ((i - start_symbol) * WORDSIZE(nvars)); word = *rowp++; mask = 1; for (j = 0; j < nvars; j++) { if (word & mask) printf(" %s", symbol_name[start_symbol + j]); mask <<= 1; if (mask == 0) { word = *rowp++; mask = 1; } } } } void print_first_derives(void) { register int i; register int j; register unsigned *rp; register unsigned cword; register unsigned mask; printf("\n\n\nFirst Derives\n"); for (i = start_symbol; i < nsyms; i++) { printf("\n%s derives\n", symbol_name[i]); rp = first_derives + i * WORDSIZE(nrules); cword = *rp++; mask = 1; for (j = 0; j <= nrules; j++) { if (cword & mask) printf(" %d\n", j); mask <<= 1; if (mask == 0) { cword = *rp++; mask = 1; } } } fflush(stdout); } #endif mingw-ocaml/ocaml/yacc/skeleton.c0000644000175000017500000000347712124403241016400 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* Based on public-domain code from Berkeley Yacc */ /* $Id$ */ #include "defs.h" char *header[] = { "open Parsing;;", "let _ = parse_error;;", /* avoid warning 33 (PR#5719) */ 0 }; char *define_tables[] = { "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 }", 0 }; void write_section(char **section) { register int i; register FILE *fp; fp = code_file; for (i = 0; section[i]; ++i) { ++outline; fprintf(fp, "%s\n", section[i]); } } mingw-ocaml/ocaml/yacc/verbose.c0000644000175000017500000002125112124403241016207 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* Based on public-domain code from Berkeley Yacc */ /* $Id$ */ #include "defs.h" static short *null_rules; void print_state (int state); void log_unused (void); void log_conflicts (void); void print_conflicts (int state); void print_core (int state); void print_nulls (int state); void print_actions (int stateno); void print_shifts (register action *p); void print_reductions (register action *p, register int defred); void print_gotos (int stateno); void verbose(void) { register int i; if (!vflag) return; null_rules = (short *) MALLOC(nrules*sizeof(short)); if (null_rules == 0) no_space(); fprintf(verbose_file, "\f\n"); for (i = 0; i < nstates; i++) print_state(i); FREE(null_rules); if (nunused) log_unused(); if (SRtotal || RRtotal) log_conflicts(); fprintf(verbose_file, "\n\n%d terminals, %d nonterminals\n", ntokens, nvars); fprintf(verbose_file, "%d grammar rules, %d states\n", nrules - 2, nstates); } void log_unused(void) { register int i; register short *p; fprintf(verbose_file, "\n\nRules never reduced:\n"); for (i = 3; i < nrules; ++i) { if (!rules_used[i]) { fprintf(verbose_file, "\t%s :", symbol_name[rlhs[i]]); for (p = ritem + rrhs[i]; *p >= 0; ++p) fprintf(verbose_file, " %s", symbol_name[*p]); fprintf(verbose_file, " (%d)\n", i - 2); } } } void log_conflicts(void) { register int i; fprintf(verbose_file, "\n\n"); for (i = 0; i < nstates; i++) { if (SRconflicts[i] || RRconflicts[i]) { fprintf(verbose_file, "State %d contains ", i); if (SRconflicts[i] == 1) fprintf(verbose_file, "1 shift/reduce conflict"); else if (SRconflicts[i] > 1) fprintf(verbose_file, "%d shift/reduce conflicts", SRconflicts[i]); if (SRconflicts[i] && RRconflicts[i]) fprintf(verbose_file, ", "); if (RRconflicts[i] == 1) fprintf(verbose_file, "1 reduce/reduce conflict"); else if (RRconflicts[i] > 1) fprintf(verbose_file, "%d reduce/reduce conflicts", RRconflicts[i]); fprintf(verbose_file, ".\n"); } } } void print_state(int state) { if (state) fprintf(verbose_file, "\n\n"); if (SRconflicts[state] || RRconflicts[state]) print_conflicts(state); fprintf(verbose_file, "state %d\n", state); print_core(state); print_nulls(state); print_actions(state); } void print_conflicts(int state) { register int symbol, act, number; register action *p; symbol = -1; act = 0; number = 0; for (p = parser[state]; p; p = p->next) { if (p->suppressed == 2) continue; if (p->symbol != symbol) { symbol = p->symbol; number = p->number; if (p->action_code == SHIFT) act = SHIFT; else act = REDUCE; } else if (p->suppressed == 1) { if (state == final_state && symbol == 0) { fprintf(verbose_file, "%d: shift/reduce conflict \ (accept, reduce %d) on $end\n", state, p->number - 2); } else { if (act == SHIFT) { fprintf(verbose_file, "%d: shift/reduce conflict \ (shift %d, reduce %d) on %s\n", state, number, p->number - 2, symbol_name[symbol]); } else { fprintf(verbose_file, "%d: reduce/reduce conflict \ (reduce %d, reduce %d) on %s\n", state, number - 2, p->number - 2, symbol_name[symbol]); } } } } } void print_core(int state) { register int i; register int k; register int rule; register core *statep; register short *sp; register short *sp1; statep = state_table[state]; k = statep->nitems; for (i = 0; i < k; i++) { sp1 = sp = ritem + statep->items[i]; while (*sp >= 0) ++sp; rule = -(*sp); fprintf(verbose_file, "\t%s : ", symbol_name[rlhs[rule]]); for (sp = ritem + rrhs[rule]; sp < sp1; sp++) fprintf(verbose_file, "%s ", symbol_name[*sp]); putc('.', verbose_file); while (*sp >= 0) { fprintf(verbose_file, " %s", symbol_name[*sp]); sp++; } fprintf(verbose_file, " (%d)\n", -2 - *sp); } } void print_nulls(int state) { register action *p; register int i, j, k, nnulls; nnulls = 0; for (p = parser[state]; p; p = p->next) { if (p->action_code == REDUCE && (p->suppressed == 0 || p->suppressed == 1)) { i = p->number; if (rrhs[i] + 1 == rrhs[i+1]) { for (j = 0; j < nnulls && i > null_rules[j]; ++j) continue; if (j == nnulls) { ++nnulls; null_rules[j] = i; } else if (i != null_rules[j]) { ++nnulls; for (k = nnulls - 1; k > j; --k) null_rules[k] = null_rules[k-1]; null_rules[j] = i; } } } } for (i = 0; i < nnulls; ++i) { j = null_rules[i]; fprintf(verbose_file, "\t%s : . (%d)\n", symbol_name[rlhs[j]], j - 2); } fprintf(verbose_file, "\n"); } void print_actions(int stateno) { register action *p; register shifts *sp; register int as; if (stateno == final_state) fprintf(verbose_file, "\t$end accept\n"); p = parser[stateno]; if (p) { print_shifts(p); print_reductions(p, defred[stateno]); } sp = shift_table[stateno]; if (sp && sp->nshifts > 0) { as = accessing_symbol[sp->shift[sp->nshifts - 1]]; if (ISVAR(as)) print_gotos(stateno); } } void print_shifts(register action *p) { register int count; register action *q; count = 0; for (q = p; q; q = q->next) { if (q->suppressed < 2 && q->action_code == SHIFT) ++count; } if (count > 0) { for (; p; p = p->next) { if (p->action_code == SHIFT && p->suppressed == 0) fprintf(verbose_file, "\t%s shift %d\n", symbol_name[p->symbol], p->number); } } } void print_reductions(register action *p, register int defred) { register int k, anyreds; register action *q; anyreds = 0; for (q = p; q ; q = q->next) { if (q->action_code == REDUCE && q->suppressed < 2) { anyreds = 1; break; } } if (anyreds == 0) fprintf(verbose_file, "\t. error\n"); else { for (; p; p = p->next) { if (p->action_code == REDUCE && p->number != defred) { k = p->number - 2; if (p->suppressed == 0) fprintf(verbose_file, "\t%s reduce %d\n", symbol_name[p->symbol], k); } } if (defred > 0) fprintf(verbose_file, "\t. reduce %d\n", defred - 2); } } void print_gotos(int stateno) { register int i, k; register int as; register short *to_state; register shifts *sp; putc('\n', verbose_file); sp = shift_table[stateno]; to_state = sp->shift; for (i = 0; i < sp->nshifts; ++i) { k = to_state[i]; as = accessing_symbol[k]; if (ISVAR(as)) fprintf(verbose_file, "\t%s goto %d\n", symbol_name[as], k); } } mingw-ocaml/ocaml/yacc/mkpar.c0000644000175000017500000002035612124403241015661 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* Based on public-domain code from Berkeley Yacc */ /* $Id$ */ #include "defs.h" action **parser; int SRtotal; int RRtotal; short *SRconflicts; short *RRconflicts; short *defred; short *rules_used; short nunused; short final_state; static int SRcount; static int RRcount; void find_final_state (void); void remove_conflicts (void); void unused_rules (void); void total_conflicts (void); void defreds (void); void make_parser(void) { register int i; parser = NEW2(nstates, action *); for (i = 0; i < nstates; i++) parser[i] = parse_actions(i); find_final_state(); remove_conflicts(); unused_rules(); if (SRtotal + RRtotal > 0) total_conflicts(); defreds(); } action * parse_actions(register int stateno) { register action *actions; actions = get_shifts(stateno); actions = add_reductions(stateno, actions); return (actions); } action * get_shifts(int stateno) { register action *actions, *temp; register shifts *sp; register short *to_state; register int i, k; register int symbol; actions = 0; sp = shift_table[stateno]; if (sp) { to_state = sp->shift; for (i = sp->nshifts - 1; i >= 0; i--) { k = to_state[i]; symbol = accessing_symbol[k]; if (ISTOKEN(symbol)) { temp = NEW(action); temp->next = actions; temp->symbol = symbol; temp->number = k; temp->prec = symbol_prec[symbol]; temp->action_code = SHIFT; temp->assoc = symbol_assoc[symbol]; actions = temp; } } } return (actions); } action * add_reductions(int stateno, register action *actions) { register int i, j, m, n; register int ruleno, tokensetsize; register unsigned *rowp; tokensetsize = WORDSIZE(ntokens); m = lookaheads[stateno]; n = lookaheads[stateno + 1]; for (i = m; i < n; i++) { ruleno = LAruleno[i]; rowp = LA + i * tokensetsize; for (j = ntokens - 1; j >= 0; j--) { if (BIT(rowp, j)) actions = add_reduce(actions, ruleno, j); } } return (actions); } action * add_reduce(register action *actions, register int ruleno, register int symbol) { register action *temp, *prev, *next; prev = 0; for (next = actions; next && next->symbol < symbol; next = next->next) prev = next; while (next && next->symbol == symbol && next->action_code == SHIFT) { prev = next; next = next->next; } while (next && next->symbol == symbol && next->action_code == REDUCE && next->number < ruleno) { prev = next; next = next->next; } temp = NEW(action); temp->next = next; temp->symbol = symbol; temp->number = ruleno; temp->prec = rprec[ruleno]; temp->action_code = REDUCE; temp->assoc = rassoc[ruleno]; if (prev) prev->next = temp; else actions = temp; return (actions); } void find_final_state(void) { register int goal, i; register short *to_state; register shifts *p; p = shift_table[0]; to_state = p->shift; goal = ritem[1]; for (i = p->nshifts - 1; i >= 0; --i) { final_state = to_state[i]; if (accessing_symbol[final_state] == goal) break; } } void unused_rules(void) { register int i; register action *p; rules_used = (short *) MALLOC(nrules*sizeof(short)); if (rules_used == 0) no_space(); for (i = 0; i < nrules; ++i) rules_used[i] = 0; for (i = 0; i < nstates; ++i) { for (p = parser[i]; p; p = p->next) { if (p->action_code == REDUCE && p->suppressed == 0) rules_used[p->number] = 1; } } nunused = 0; for (i = 3; i < nrules; ++i) if (!rules_used[i]) ++nunused; if (nunused){ if (nunused == 1) fprintf(stderr, "1 rule never reduced\n"); else fprintf(stderr, "%d rules never reduced\n", nunused); } } void remove_conflicts(void) { register int i; register int symbol; register action *p, *pref; SRtotal = 0; RRtotal = 0; SRconflicts = NEW2(nstates, short); RRconflicts = NEW2(nstates, short); pref = NULL; for (i = 0; i < nstates; i++) { SRcount = 0; RRcount = 0; symbol = -1; for (p = parser[i]; p; p = p->next) { if (p->symbol != symbol) { pref = p; symbol = p->symbol; } else if (i == final_state && symbol == 0) { SRcount++; p->suppressed = 1; } else if (pref->action_code == SHIFT) { if (pref->prec > 0 && p->prec > 0) { if (pref->prec < p->prec) { pref->suppressed = 2; pref = p; } else if (pref->prec > p->prec) { p->suppressed = 2; } else if (pref->assoc == LEFT) { pref->suppressed = 2; pref = p; } else if (pref->assoc == RIGHT) { p->suppressed = 2; } else { pref->suppressed = 2; p->suppressed = 2; } } else { SRcount++; p->suppressed = 1; } } else { RRcount++; p->suppressed = 1; } } SRtotal += SRcount; RRtotal += RRcount; SRconflicts[i] = SRcount; RRconflicts[i] = RRcount; } } void total_conflicts(void) { if (SRtotal == 1) fprintf(stderr, "1 shift/reduce conflict"); else if (SRtotal > 1) fprintf(stderr, "%d shift/reduce conflicts", SRtotal); if (SRtotal && RRtotal) fprintf(stderr, ", "); if (RRtotal == 1) fprintf(stderr, "1 reduce/reduce conflict"); else if (RRtotal > 1) fprintf(stderr, "%d reduce/reduce conflicts", RRtotal); fprintf(stderr, ".\n"); } int sole_reduction(int stateno) { register int count, ruleno; register action *p; count = 0; ruleno = 0; for (p = parser[stateno]; p; p = p->next) { if (p->action_code == SHIFT && p->suppressed == 0) return (0); else if (p->action_code == REDUCE && p->suppressed == 0) { if (ruleno > 0 && p->number != ruleno) return (0); if (p->symbol != 1) ++count; ruleno = p->number; } } if (count == 0) return (0); return (ruleno); } void defreds(void) { register int i; defred = NEW2(nstates, short); for (i = 0; i < nstates; i++) defred[i] = sole_reduction(i); } void free_action_row(register action *p) { register action *q; while (p) { q = p->next; FREE(p); p = q; } } void free_parser(void) { register int i; for (i = 0; i < nstates; i++) free_action_row(parser[i]); FREE(parser); } mingw-ocaml/ocaml/yacc/output.c0000644000175000017500000005202712124403241016107 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* Based on public-domain code from Berkeley Yacc */ /* $Id$ */ #include "defs.h" static int nvectors; static int nentries; static short **froms; static short **tos; static short *tally; static short *width; static short *state_count; static short *order; static short *base; static short *pos; static int maxtable; static short *table; static short *check; static int lowzero; static int high; void free_itemsets (void); void free_shifts (void); void free_reductions (void); void output_stored_text (void); void output_transl (void); void output_rule_data (void); void output_yydefred (void); void output_actions (void); void output_debug (void); void output_trailing_text (void); void output_semantic_actions (void); void output_entries (void); void token_actions (void); void goto_actions (void); void sort_actions (void); void pack_table (void); void output_base (void); void output_table (void); void output_check (void); int default_goto (int symbol); void save_column (int symbol, int default_state); int matching_vector (int vector); int pack_vector (int vector); void output(void) { extern char *header[], *define_tables[]; free_itemsets(); free_shifts(); free_reductions(); write_section(header); output_stored_text(); output_transl(); output_rule_data(); output_yydefred(); output_actions(); output_debug(); free_parser(); if (sflag){ if (!rflag) ++outline; fprintf(output_file, "let yyact = Array.new %d (fun _ -> (failwith \"parser\" : Obj.t))\n", ntotalrules); }else{ if (!rflag) outline += 2; fprintf(output_file, "let yyact = [|\n (fun _ -> failwith \"parser\")\n"); } output_semantic_actions(); if (!sflag){ if (!rflag) ++outline; fprintf(output_file, "|]\n"); } write_section(define_tables); output_entries(); output_trailing_text(); } static void output_char(unsigned int n) { n = n & 0xFF; putc('\\', output_file); putc('0' + n / 100, output_file); putc('0' + (n / 10) % 10, output_file); putc('0' + n % 10, output_file); } static void output_short(int n) { output_char(n); output_char(n >> 8); } void output_rule_data(void) { register int i; register int j; fprintf(output_file, "let yylhs = \""); output_short(symbol_value[start_symbol]); j = 8; for (i = 3; i < nrules; i++) { if (j >= 8) { if (!rflag) ++outline; fprintf(output_file, "\\\n"); j = 1; } else ++j; output_short(symbol_value[rlhs[i]]); } if (!rflag) outline += 2; fprintf(output_file, "\"\n\n"); fprintf(output_file, "let yylen = \""); output_short(2); j = 8; for (i = 3; i < nrules; i++) { if (j >= 8) { if (!rflag) ++outline; fprintf(output_file, "\\\n"); j = 1; } else j++; output_short(rrhs[i + 1] - rrhs[i] - 1); } if (!rflag) outline += 2; fprintf(output_file, "\"\n\n"); } void output_yydefred(void) { register int i, j; fprintf(output_file, "let yydefred = \""); output_short(defred[0] ? defred[0] - 2 : 0); j = 8; for (i = 1; i < nstates; i++) { if (j < 8) ++j; else { if (!rflag) ++outline; fprintf(output_file, "\\\n"); j = 1; } output_short(defred[i] ? defred[i] - 2 : 0); } if (!rflag) outline += 2; fprintf(output_file, "\"\n\n"); } void output_actions(void) { nvectors = 2*nstates + nvars; froms = NEW2(nvectors, short *); tos = NEW2(nvectors, short *); tally = NEW2(nvectors, short); width = NEW2(nvectors, short); token_actions(); FREE(lookaheads); FREE(LA); FREE(LAruleno); FREE(accessing_symbol); goto_actions(); FREE(goto_map + ntokens); FREE(from_state); FREE(to_state); sort_actions(); pack_table(); output_base(); output_table(); output_check(); } void token_actions(void) { register int i, j; register int shiftcount, reducecount; register int max, min; register short *actionrow, *r, *s; register action *p; actionrow = NEW2(2*ntokens, short); for (i = 0; i < nstates; ++i) { if (parser[i]) { for (j = 0; j < 2*ntokens; ++j) actionrow[j] = 0; shiftcount = 0; reducecount = 0; for (p = parser[i]; p; p = p->next) { if (p->suppressed == 0) { if (p->action_code == SHIFT) { ++shiftcount; actionrow[p->symbol] = p->number; } else if (p->action_code == REDUCE && p->number != defred[i]) { ++reducecount; actionrow[p->symbol + ntokens] = p->number; } } } tally[i] = shiftcount; tally[nstates+i] = reducecount; width[i] = 0; width[nstates+i] = 0; if (shiftcount > 0) { froms[i] = r = NEW2(shiftcount, short); tos[i] = s = NEW2(shiftcount, short); min = MAXSHORT; max = 0; for (j = 0; j < ntokens; ++j) { if (actionrow[j]) { if (min > symbol_value[j]) min = symbol_value[j]; if (max < symbol_value[j]) max = symbol_value[j]; *r++ = symbol_value[j]; *s++ = actionrow[j]; } } width[i] = max - min + 1; } if (reducecount > 0) { froms[nstates+i] = r = NEW2(reducecount, short); tos[nstates+i] = s = NEW2(reducecount, short); min = MAXSHORT; max = 0; for (j = 0; j < ntokens; ++j) { if (actionrow[ntokens+j]) { if (min > symbol_value[j]) min = symbol_value[j]; if (max < symbol_value[j]) max = symbol_value[j]; *r++ = symbol_value[j]; *s++ = actionrow[ntokens+j] - 2; } } width[nstates+i] = max - min + 1; } } } FREE(actionrow); } void goto_actions(void) { register int i, j, k; state_count = NEW2(nstates, short); k = default_goto(start_symbol + 1); fprintf(output_file, "let yydgoto = \""); output_short(k); save_column(start_symbol + 1, k); j = 8; for (i = start_symbol + 2; i < nsyms; i++) { if (j >= 8) { if (!rflag) ++outline; fprintf(output_file, "\\\n"); j = 1; } else ++j; k = default_goto(i); output_short(k); save_column(i, k); } if (!rflag) outline += 2; fprintf(output_file, "\"\n\n"); FREE(state_count); } int default_goto(int symbol) { register int i; register int m; register int n; register int default_state; register int max; m = goto_map[symbol]; n = goto_map[symbol + 1]; if (m == n) return (0); for (i = 0; i < nstates; i++) state_count[i] = 0; for (i = m; i < n; i++) state_count[to_state[i]]++; max = 0; default_state = 0; for (i = 0; i < nstates; i++) { if (state_count[i] > max) { max = state_count[i]; default_state = i; } } return (default_state); } void save_column(int symbol, int default_state) { register int i; register int m; register int n; register short *sp; register short *sp1; register short *sp2; register int count; register int symno; m = goto_map[symbol]; n = goto_map[symbol + 1]; count = 0; for (i = m; i < n; i++) { if (to_state[i] != default_state) ++count; } if (count == 0) return; symno = symbol_value[symbol] + 2*nstates; froms[symno] = sp1 = sp = NEW2(count, short); tos[symno] = sp2 = NEW2(count, short); for (i = m; i < n; i++) { if (to_state[i] != default_state) { *sp1++ = from_state[i]; *sp2++ = to_state[i]; } } tally[symno] = count; width[symno] = sp1[-1] - sp[0] + 1; } void sort_actions(void) { register int i; register int j; register int k; register int t; register int w; order = NEW2(nvectors, short); nentries = 0; for (i = 0; i < nvectors; i++) { if (tally[i] > 0) { t = tally[i]; w = width[i]; j = nentries - 1; while (j >= 0 && (width[order[j]] < w)) j--; while (j >= 0 && (width[order[j]] == w) && (tally[order[j]] < t)) j--; for (k = nentries - 1; k > j; k--) order[k + 1] = order[k]; order[j + 1] = i; nentries++; } } } void pack_table(void) { register int i; register int place; register int state; base = NEW2(nvectors, short); pos = NEW2(nentries, short); maxtable = 1000; table = NEW2(maxtable, short); check = NEW2(maxtable, short); lowzero = 0; high = 0; for (i = 0; i < maxtable; i++) check[i] = -1; for (i = 0; i < nentries; i++) { state = matching_vector(i); if (state < 0) place = pack_vector(i); else place = base[state]; pos[i] = place; base[order[i]] = place; } for (i = 0; i < nvectors; i++) { if (froms[i]) FREE(froms[i]); if (tos[i]) FREE(tos[i]); } FREE(froms); FREE(tos); FREE(pos); } /* The function matching_vector determines if the vector specified by */ /* the input parameter matches a previously considered vector. The */ /* test at the start of the function checks if the vector represents */ /* a row of shifts over terminal symbols or a row of reductions, or a */ /* column of shifts over a nonterminal symbol. Berkeley Yacc does not */ /* check if a column of shifts over a nonterminal symbols matches a */ /* previously considered vector. Because of the nature of LR parsing */ /* tables, no two columns can match. Therefore, the only possible */ /* match would be between a row and a column. Such matches are */ /* unlikely. Therefore, to save time, no attempt is made to see if a */ /* column matches a previously considered vector. */ /* */ /* Matching_vector is poorly designed. The test could easily be made */ /* faster. Also, it depends on the vectors being in a specific */ /* order. */ int matching_vector(int vector) { register int i; register int j; register int k; register int t; register int w; register int match; register int prev; i = order[vector]; if (i >= 2*nstates) return (-1); t = tally[i]; w = width[i]; for (prev = vector - 1; prev >= 0; prev--) { j = order[prev]; if (width[j] != w || tally[j] != t) return (-1); match = 1; for (k = 0; match && k < t; k++) { if (tos[j][k] != tos[i][k] || froms[j][k] != froms[i][k]) match = 0; } if (match) return (j); } return (-1); } int pack_vector(int vector) { register int i, j, k, l; register int t; register int loc; register int ok; register short *from; register short *to; int newmax; i = order[vector]; t = tally[i]; assert(t); from = froms[i]; to = tos[i]; j = lowzero - from[0]; for (k = 1; k < t; ++k) if (lowzero - from[k] > j) j = lowzero - from[k]; for (;; ++j) { if (j == 0) continue; ok = 1; for (k = 0; ok && k < t; k++) { loc = j + from[k]; if (loc >= maxtable) { if (loc >= MAXTABLE) fatal("maximum table size exceeded"); newmax = maxtable; do { newmax += 200; } while (newmax <= loc); table = (short *) REALLOC(table, newmax*sizeof(short)); if (table == 0) no_space(); check = (short *) REALLOC(check, newmax*sizeof(short)); if (check == 0) no_space(); for (l = maxtable; l < newmax; ++l) { table[l] = 0; check[l] = -1; } maxtable = newmax; } if (check[loc] != -1) ok = 0; } for (k = 0; ok && k < vector; k++) { if (pos[k] == j) ok = 0; } if (ok) { for (k = 0; k < t; k++) { loc = j + from[k]; table[loc] = to[k]; check[loc] = from[k]; if (loc > high) high = loc; } while (lowzero < maxtable && check[lowzero] != -1) ++lowzero; return (j); } } } void output_base(void) { register int i, j; fprintf(output_file, "let yysindex = \""); output_short(base[0]); j = 8; for (i = 1; i < nstates; i++) { if (j >= 8) { if (!rflag) ++outline; fprintf(output_file, "\\\n"); j = 1; } else ++j; output_short(base[i]); } if (!rflag) outline += 2; fprintf(output_file, "\"\n\n"); fprintf(output_file, "let yyrindex = \""); output_short(base[nstates]); j = 8; for (i = nstates + 1; i < 2*nstates; i++) { if (j >= 8) { if (!rflag) ++outline; fprintf(output_file, "\\\n"); j = 1; } else ++j; output_short(base[i]); } if (!rflag) outline += 2; fprintf(output_file, "\"\n\n"); fprintf(output_file, "let yygindex = \""); output_short(base[2*nstates]); j = 8; for (i = 2*nstates + 1; i < nvectors - 1; i++) { if (j >= 8) { if (!rflag) ++outline; fprintf(output_file, "\\\n"); j = 1; } else ++j; output_short(base[i]); } if (!rflag) outline += 2; fprintf(output_file, "\"\n\n"); FREE(base); } void output_table(void) { register int i; register int j; ++outline; fprintf(code_file, "let yytablesize = %d\n", high); fprintf(output_file, "let yytable = \""); output_short(table[0]); j = 8; for (i = 1; i <= high; i++) { if (j >= 8) { if (!rflag) ++outline; fprintf(output_file, "\\\n"); j = 1; } else ++j; output_short(table[i]); } if (!rflag) outline += 2; fprintf(output_file, "\"\n\n"); FREE(table); } void output_check(void) { register int i; register int j; fprintf(output_file, "let yycheck = \""); output_short(check[0]); j = 8; for (i = 1; i <= high; i++) { if (j >= 8) { if (!rflag) ++outline; fprintf(output_file, "\\\n"); j = 1; } else ++j; output_short(check[i]); } if (!rflag) outline += 2; fprintf(output_file, "\"\n\n"); FREE(check); } void output_transl(void) { int i; ++outline; fprintf(code_file, "let yytransl_const = [|\n"); for (i = 0; i < ntokens; i++) { if (symbol_true_token[i] && symbol_tag[i] == NULL) { ++outline; fprintf(code_file, " %3d (* %s *);\n", symbol_value[i], symbol_name[i]); } } outline += 2; fprintf(code_file, " 0|]\n\n"); ++outline; fprintf(code_file, "let yytransl_block = [|\n"); for (i = 0; i < ntokens; i++) { if (symbol_true_token[i] && symbol_tag[i] != NULL) { ++outline; fprintf(code_file, " %3d (* %s *);\n", symbol_value[i], symbol_name[i]); } } outline += 2; fprintf(code_file, " 0|]\n\n"); } void output_stored_text(void) { register int c; register FILE *in, *out; fclose(text_file); text_file = fopen(text_file_name, "r"); if (text_file == NULL) open_error(text_file_name); in = text_file; if ((c = getc(in)) == EOF) return; out = code_file; if (c == '\n') ++outline; putc(c, out); while ((c = getc(in)) != EOF) { if (c == '\n') ++outline; putc(c, out); } if (!lflag) fprintf(out, line_format, ++outline + 1, code_file_name); } void output_debug(void) { int i; ++outline; fprintf(code_file, "let yynames_const = \"\\\n"); for (i = 0; i < ntokens; i++) { if (symbol_true_token[i] && symbol_tag[i] == NULL) { ++outline; fprintf(code_file, " %s\\000\\\n", symbol_name[i]); } } outline += 2; fprintf(code_file, " \"\n\n"); ++outline; fprintf(code_file, "let yynames_block = \"\\\n"); for (i = 0; i < ntokens; i++) { if (symbol_true_token[i] && symbol_tag[i] != NULL) { ++outline; fprintf(code_file, " %s\\000\\\n", symbol_name[i]); } } outline += 2; fprintf(code_file, " \"\n\n"); } void output_trailing_text(void) { register int c, last; register FILE *in, *out; if (line == 0) return; in = input_file; out = code_file; ++outline; fprintf (out, ";;\n"); c = *cptr; if (c == '\n') { ++lineno; if ((c = getc(in)) == EOF) return; if (!lflag) { ++outline; fprintf(out, line_format, lineno, input_file_name); } if (c == '\n') ++outline; putc(c, out); last = c; } else { if (!lflag) { ++outline; fprintf(out, line_format, lineno, input_file_name); } do { putc(c, out); } while ((c = *++cptr) != '\n'); ++outline; putc('\n', out); last = '\n'; } while ((c = getc(in)) != EOF) { if (c == '\n') ++outline; putc(c, out); last = c; } if (last != '\n') { ++outline; putc('\n', out); } if (!lflag) fprintf(out, line_format, ++outline + 1, code_file_name); } void copy_file(FILE **file, char *file_name) { register int c, last; register FILE *out = code_file; int state = 0; fclose(*file); *file = fopen(file_name, "r"); if (*file == NULL) open_error(file_name); last = '\n'; while ((c = getc(*file)) != EOF) { switch (c){ case '\n': state = 1; break; case '#': state = (state == 1) ? 2 : 0; break; case ' ': state = (state == 2) ? 3 : 0; break; case '0': if (state == 3){ fprintf (out, "%d \"%s", outline+2, code_file_name); c = '"'; } state = 0; break; default: state = 0; break; } if (c == '\n') ++outline; putc(c, out); last = c; } if (last != '\n') { ++outline; putc('\n', out); } } void output_semantic_actions(void) { copy_file (&action_file, action_file_name); } void output_entries(void) { copy_file (&entry_file, entry_file_name); } void free_itemsets(void) { register core *cp, *next; FREE(state_table); for (cp = first_state; cp; cp = next) { next = cp->next; FREE(cp); } } void free_shifts(void) { register shifts *sp, *next; FREE(shift_table); for (sp = first_shift; sp; sp = next) { next = sp->next; FREE(sp); } } void free_reductions(void) { register reductions *rp, *next; FREE(reduction_table); for (rp = first_reduction; rp; rp = next) { next = rp->next; FREE(rp); } } mingw-ocaml/ocaml/yacc/defs.h0000644000175000017500000002367512124403241015504 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* Based on public-domain code from Berkeley Yacc */ /* $Id$ */ #include #include #include #include #include #include #include "../config/s.h" /* machine-dependent definitions */ /* the following definitions are for the Tahoe */ /* they might have to be changed for other machines */ /* MAXCHAR is the largest unsigned character value */ /* MAXSHORT is the largest value of a C short */ /* MINSHORT is the most negative value of a C short */ /* MAXTABLE is the maximum table size */ /* BITS_PER_WORD is the number of bits in a C unsigned */ /* WORDSIZE computes the number of words needed to */ /* store n bits */ /* BIT returns the value of the n-th bit starting */ /* from r (0-indexed) */ /* SETBIT sets the n-th bit starting from r */ #define MAXCHAR UCHAR_MAX #define MAXSHORT SHRT_MAX #define MINSHORT SHRT_MIN #define MAXTABLE 32500 #define BITS_PER_WORD (8*sizeof(unsigned)) #define WORDSIZE(n) (((n)+(BITS_PER_WORD-1))/BITS_PER_WORD) #define BIT(r, n) ((((r)[(n)/BITS_PER_WORD])>>((n)%BITS_PER_WORD))&1) #define SETBIT(r, n) ((r)[(n)/BITS_PER_WORD]|=(1<<((n)%BITS_PER_WORD))) /* character names */ #define NUL '\0' /* the null character */ #define NEWLINE '\n' /* line feed */ #define SP ' ' /* space */ #define BS '\b' /* backspace */ #define HT '\t' /* horizontal tab */ #define VT '\013' /* vertical tab */ #define CR '\r' /* carriage return */ #define FF '\f' /* form feed */ #define QUOTE '\'' /* single quote */ #define DOUBLE_QUOTE '\"' /* double quote */ #define BACKSLASH '\\' /* backslash */ /* defines for constructing filenames */ #define CODE_SUFFIX ".code.c" #define DEFINES_SUFFIX ".tab.h" #define OUTPUT_SUFFIX ".ml" #define VERBOSE_SUFFIX ".output" #define INTERFACE_SUFFIX ".mli" /* keyword codes */ #define TOKEN 0 #define LEFT 1 #define RIGHT 2 #define NONASSOC 3 #define MARK 4 #define TEXT 5 #define TYPE 6 #define START 7 #define UNION 8 #define IDENT 9 /* symbol classes */ #define UNKNOWN 0 #define TERM 1 #define NONTERM 2 /* the undefined value */ #define UNDEFINED (-1) /* action codes */ #define SHIFT 1 #define REDUCE 2 /* character macros */ #define IS_IDENT(c) (isalnum(c) || (c) == '_' || (c) == '.' || (c) == '$') #define IS_OCTAL(c) ((c) >= '0' && (c) <= '7') #define NUMERIC_VALUE(c) ((c) - '0') /* symbol macros */ #define ISTOKEN(s) ((s) < start_symbol) #define ISVAR(s) ((s) >= start_symbol) /* storage allocation macros */ #define CALLOC(k,n) (calloc((unsigned)(k),(unsigned)(n))) #define FREE(x) (free((char*)(x))) #define MALLOC(n) (malloc((unsigned)(n))) #define NEW(t) ((t*)allocate(sizeof(t))) #define NEW2(n,t) ((t*)allocate((unsigned)((n)*sizeof(t)))) #define REALLOC(p,n) (realloc((char*)(p),(unsigned)(n))) /* the structure of a symbol table entry */ typedef struct bucket bucket; struct bucket { struct bucket *link; struct bucket *next; char *name; char *tag; short value; short index; short prec; char class; char assoc; char entry; char true_token; }; /* TABLE_SIZE is the number of entries in the symbol table. */ /* TABLE_SIZE must be a power of two. */ #define TABLE_SIZE 4096 /* the structure of the LR(0) state machine */ typedef struct core core; struct core { struct core *next; struct core *link; short number; short accessing_symbol; short nitems; short items[1]; }; /* the structure used to record shifts */ typedef struct shifts shifts; struct shifts { struct shifts *next; short number; short nshifts; short shift[1]; }; /* the structure used to store reductions */ typedef struct reductions reductions; struct reductions { struct reductions *next; short number; short nreds; short rules[1]; }; /* the structure used to represent parser actions */ typedef struct action action; struct action { struct action *next; short symbol; short number; short prec; char action_code; char assoc; char suppressed; }; /* global variables */ extern char dflag; extern char lflag; extern char rflag; extern char tflag; extern char vflag; extern char qflag; extern char sflag; extern char big_endian; extern char *myname; extern char *cptr; extern char *line; extern int lineno; extern char *virtual_input_file_name; extern int outline; extern char *action_file_name; extern char *entry_file_name; extern char *code_file_name; extern char *defines_file_name; extern char *input_file_name; extern char *output_file_name; extern char *text_file_name; extern char *union_file_name; extern char *verbose_file_name; extern char *interface_file_name; extern FILE *action_file; extern FILE *entry_file; extern FILE *code_file; extern FILE *defines_file; extern FILE *input_file; extern FILE *output_file; extern FILE *text_file; extern FILE *union_file; extern FILE *verbose_file; extern FILE *interface_file; extern int nitems; extern int nrules; extern int ntotalrules; extern int nsyms; extern int ntokens; extern int nvars; extern int ntags; extern char unionized; extern char line_format[]; extern int start_symbol; extern char **symbol_name; extern short *symbol_value; extern short *symbol_prec; extern char *symbol_assoc; extern char **symbol_tag; extern char *symbol_true_token; extern short *ritem; extern short *rlhs; extern short *rrhs; extern short *rprec; extern char *rassoc; extern short **derives; extern char *nullable; extern bucket *first_symbol; extern bucket *last_symbol; extern int nstates; extern core *first_state; extern shifts *first_shift; extern reductions *first_reduction; extern short *accessing_symbol; extern core **state_table; extern shifts **shift_table; extern reductions **reduction_table; extern unsigned *LA; extern short *LAruleno; extern short *lookaheads; extern short *goto_map; extern short *from_state; extern short *to_state; extern action **parser; extern int SRtotal; extern int RRtotal; extern short *SRconflicts; extern short *RRconflicts; extern short *defred; extern short *rules_used; extern short nunused; extern short final_state; /* global functions */ #ifdef __GNUC__ /* Works only in GCC 2.5 and later */ #define Noreturn __attribute ((noreturn)) #else #define Noreturn #endif extern char *allocate(unsigned int n); extern bucket *lookup(char *name); extern bucket *make_bucket(char *name); extern action *parse_actions(register int stateno); extern action *get_shifts(int stateno); extern action *add_reductions(int stateno, register action *actions); extern action *add_reduce(register action *actions, register int ruleno, register int symbol); extern void closure (short int *nucleus, int n); extern void create_symbol_table (void); extern void default_action_error (void); extern void done (int k) Noreturn; extern void entry_without_type (char *s); extern void fatal (char *msg); extern void finalize_closure (void); extern void free_parser (void); extern void free_symbol_table (void); extern void free_symbols (void); extern void illegal_character (char *c_cptr); extern void illegal_token_ref (int i, char *name); extern void lalr (void); extern void lr0 (void); extern void make_parser (void); extern void no_grammar (void); extern void no_space (void); extern void open_error (char *filename); extern void output (void); extern void over_unionized (char *u_cptr); extern void prec_redeclared (void); extern void polymorphic_entry_point(char *s); extern void reader (void); extern void reflexive_transitive_closure (unsigned int *R, int n); extern void reprec_warning (char *s); extern void retyped_warning (char *s); extern void revalued_warning (char *s); extern void set_first_derives (void); extern void syntax_error (int st_lineno, char *st_line, char *st_cptr) Noreturn, terminal_lhs (int s_lineno); extern void terminal_start (char *s); extern void tokenized_start (char *s); extern void too_many_entries (void); extern void undefined_goal (char *s); extern void undefined_symbol (char *s); extern void unexpected_EOF (void); extern void unknown_rhs (int i); extern void unterminated_action (int a_lineno, char *a_line, char *a_cptr); extern void unterminated_comment (int c_lineno, char *c_line, char *c_cptr); extern void unterminated_string (int s_lineno, char *s_line, char *s_cptr); extern void unterminated_text (int t_lineno, char *t_line, char *t_cptr); extern void unterminated_union (int u_lineno, char *u_line, char *u_cptr); extern void used_reserved (char *s); extern void verbose (void); extern void write_section (char **section); mingw-ocaml/ocaml/yacc/main.c0000644000175000017500000002554112124403241015474 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* Based on public-domain code from Berkeley Yacc */ /* $Id$ */ #include #include #include "defs.h" #ifdef HAS_UNISTD #include #endif #include "version.h" char dflag; char lflag; char rflag; char tflag; char vflag; char qflag; char sflag; char big_endian; char *file_prefix = 0; char *myname = "yacc"; #ifdef NO_UNIX char temp_form[] = "yacc.X"; #else char temp_form[] = "yacc.XXXXXXX"; #endif int lineno; char *virtual_input_file_name = NULL; int outline; char *action_file_name; char *entry_file_name; char *code_file_name; char *interface_file_name; char *defines_file_name; char *input_file_name = ""; char *output_file_name; char *text_file_name; char *union_file_name; char *verbose_file_name; #if defined(__OpenBSD__) || defined(__NetBSD__) || defined(__FreeBSD__) || defined(__DragonFly__) || (__APPLE__) #define HAVE_MKSTEMP #endif #ifdef HAVE_MKSTEMP int action_fd = -1, entry_fd = -1, text_fd = -1, union_fd = -1; #endif FILE *action_file; /* a temp file, used to save actions associated */ /* with rules until the parser is written */ FILE *entry_file; FILE *code_file; /* y.code.c (used when the -r option is specified) */ FILE *defines_file; /* y.tab.h */ FILE *input_file; /* the input file */ FILE *output_file; /* y.tab.c */ FILE *text_file; /* a temp file, used to save text until all */ /* symbols have been defined */ FILE *union_file; /* a temp file, used to save the union */ /* definition until all symbol have been */ /* defined */ FILE *verbose_file; /* y.output */ FILE *interface_file; int nitems; int nrules; int ntotalrules; int nsyms; int ntokens; int nvars; int start_symbol; char **symbol_name; short *symbol_value; short *symbol_prec; char *symbol_assoc; char **symbol_tag; char *symbol_true_token; short *ritem; short *rlhs; short *rrhs; short *rprec; char *rassoc; short **derives; char *nullable; #if !defined(HAVE_MKSTEMP) extern char *mktemp(char *); #endif extern char *getenv(const char *); void done(int k) { #ifdef HAVE_MKSTEMP if (action_fd != -1) unlink(action_file_name); if (entry_fd != -1) unlink(entry_file_name); if (text_fd != -1) unlink(text_file_name); if (union_fd != -1) unlink(union_file_name); #else if (action_file) { fclose(action_file); unlink(action_file_name); } if (entry_file) { fclose(entry_file); unlink(entry_file_name); } if (text_file) { fclose(text_file); unlink(text_file_name); } if (union_file) { fclose(union_file); unlink(union_file_name); } #endif if (output_file && k > 0) { fclose(output_file); unlink(output_file_name); } if (interface_file && k > 0) { fclose(interface_file); unlink(interface_file_name); } exit(k); } void onintr(int dummy) { done(1); } void set_signals(void) { #ifdef SIGINT if (signal(SIGINT, SIG_IGN) != SIG_IGN) signal(SIGINT, onintr); #endif #ifdef SIGTERM if (signal(SIGTERM, SIG_IGN) != SIG_IGN) signal(SIGTERM, onintr); #endif #ifdef SIGHUP if (signal(SIGHUP, SIG_IGN) != SIG_IGN) signal(SIGHUP, onintr); #endif } void usage(void) { fprintf(stderr, "usage: %s [-v] [-q] [-b file_prefix] filename\n", myname); exit(1); } void getargs(int argc, char **argv) { register int i; register char *s; if (argc > 0) myname = argv[0]; for (i = 1; i < argc; ++i) { s = argv[i]; if (*s != '-') break; switch (*++s) { case '\0': input_file = stdin; file_prefix = "stdin"; if (i + 1 < argc) usage(); return; case '-': ++i; goto no_more_options; case 'v': if (!strcmp (argv[i], "-version")){ printf ("The OCaml parser generator, version " OCAML_VERSION "\n"); exit (0); }else if (!strcmp (argv[i], "-vnum")){ printf (OCAML_VERSION "\n"); exit (0); }else{ vflag = 1; } break; case 'q': qflag = 1; break; case 'b': if (*++s) file_prefix = s; else if (++i < argc) file_prefix = argv[i]; else usage(); continue; default: usage(); } for (;;) { switch (*++s) { case '\0': goto end_of_option; case 'v': vflag = 1; break; case 'q': qflag = 1; break; default: usage(); } } end_of_option:; } no_more_options:; if (i + 1 != argc) usage(); input_file_name = argv[i]; if (file_prefix == 0) { int len; len = strlen(argv[i]); file_prefix = malloc(len + 1); if (file_prefix == 0) no_space(); strcpy(file_prefix, argv[i]); while (len > 0) { len--; if (file_prefix[len] == '.') { file_prefix[len] = 0; break; } } } } char * allocate(unsigned int n) { register char *p; p = NULL; if (n) { p = CALLOC(1, n); if (!p) no_space(); } return (p); } void create_file_names(void) { int i, len; char *tmpdir; #ifdef NO_UNIX len = 0; i = sizeof(temp_form); #else tmpdir = getenv("TMPDIR"); if (tmpdir == 0) tmpdir = "/tmp"; len = strlen(tmpdir); i = len + sizeof(temp_form); if (len && tmpdir[len-1] != '/') ++i; #endif action_file_name = MALLOC(i); if (action_file_name == 0) no_space(); entry_file_name = MALLOC(i); if (entry_file_name == 0) no_space(); text_file_name = MALLOC(i); if (text_file_name == 0) no_space(); union_file_name = MALLOC(i); if (union_file_name == 0) no_space(); #ifndef NO_UNIX strcpy(action_file_name, tmpdir); strcpy(entry_file_name, tmpdir); strcpy(text_file_name, tmpdir); strcpy(union_file_name, tmpdir); if (len && tmpdir[len - 1] != '/') { action_file_name[len] = '/'; entry_file_name[len] = '/'; text_file_name[len] = '/'; union_file_name[len] = '/'; ++len; } #endif strcpy(action_file_name + len, temp_form); strcpy(entry_file_name + len, temp_form); strcpy(text_file_name + len, temp_form); strcpy(union_file_name + len, temp_form); action_file_name[len + 5] = 'a'; entry_file_name[len + 5] = 'e'; text_file_name[len + 5] = 't'; union_file_name[len + 5] = 'u'; #ifndef NO_UNIX #ifdef HAVE_MKSTEMP action_fd = mkstemp(action_file_name); if (action_fd == -1) open_error(action_file_name); entry_fd = mkstemp(entry_file_name); if (entry_fd == -1) open_error(entry_file_name); text_fd = mkstemp(text_file_name); if (text_fd == -1) open_error(text_file_name); union_fd = mkstemp(union_file_name); if (union_fd == -1) open_error(union_file_name); #else mktemp(action_file_name); mktemp(entry_file_name); mktemp(text_file_name); mktemp(union_file_name); #endif #endif len = strlen(file_prefix); output_file_name = MALLOC(len + 7); if (output_file_name == 0) no_space(); strcpy(output_file_name, file_prefix); strcpy(output_file_name + len, OUTPUT_SUFFIX); code_file_name = output_file_name; if (vflag) { verbose_file_name = MALLOC(len + 8); if (verbose_file_name == 0) no_space(); strcpy(verbose_file_name, file_prefix); strcpy(verbose_file_name + len, VERBOSE_SUFFIX); } interface_file_name = MALLOC(len + 8); if (interface_file_name == 0) no_space(); strcpy(interface_file_name, file_prefix); strcpy(interface_file_name + len, INTERFACE_SUFFIX); } void open_files(void) { create_file_names(); if (input_file == 0) { input_file = fopen(input_file_name, "r"); if (input_file == 0) open_error(input_file_name); } #ifdef HAVE_MKSTEMP action_file = fdopen(action_fd, "w"); #else action_file = fopen(action_file_name, "w"); #endif if (action_file == 0) open_error(action_file_name); #ifdef HAVE_MKSTEMP entry_file = fdopen(entry_fd, "w"); #else entry_file = fopen(entry_file_name, "w"); #endif if (entry_file == 0) open_error(entry_file_name); #ifdef HAVE_MKSTEMP text_file = fdopen(text_fd, "w"); #else text_file = fopen(text_file_name, "w"); #endif if (text_file == 0) open_error(text_file_name); if (vflag) { verbose_file = fopen(verbose_file_name, "w"); if (verbose_file == 0) open_error(verbose_file_name); } if (dflag) { defines_file = fopen(defines_file_name, "w"); if (defines_file == 0) open_error(defines_file_name); #ifdef HAVE_MKSTEMP union_file = fdopen(union_fd, "w"); #else union_file = fopen(union_file_name, "w"); #endif if (union_file == 0) open_error(union_file_name); } output_file = fopen(output_file_name, "w"); if (output_file == 0) open_error(output_file_name); if (rflag) { code_file = fopen(code_file_name, "w"); if (code_file == 0) open_error(code_file_name); } else code_file = output_file; interface_file = fopen(interface_file_name, "w"); if (interface_file == 0) open_error(interface_file_name); } int main(int argc, char **argv) { set_signals(); getargs(argc, argv); open_files(); reader(); lr0(); lalr(); make_parser(); verbose(); output(); done(0); /*NOTREACHED*/ return 0; } mingw-ocaml/ocaml/yacc/lalr.c0000644000175000017500000003076112124403241015502 0ustar tootstoots/***********************************************************************/ /* */ /* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ /* Copyright 1996 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the Q Public License version 1.0. */ /* */ /***********************************************************************/ /* Based on public-domain code from Berkeley Yacc */ /* $Id$ */ #include "defs.h" typedef struct shorts { struct shorts *next; short value; } shorts; int tokensetsize; short *lookaheads; short *LAruleno; unsigned *LA; short *accessing_symbol; core **state_table; shifts **shift_table; reductions **reduction_table; short *goto_map; short *from_state; short *to_state; short **transpose(short int **R, int n); static int infinity; static int maxrhs; static int ngotos; static unsigned *F; static short **includes; static shorts **lookback; static short **R; static short *INDEX; static short *VERTICES; static int top; void set_state_table (void); void set_accessing_symbol (void); void set_shift_table (void); void set_reduction_table (void); void set_maxrhs (void); void initialize_LA (void); void set_goto_map (void); void initialize_F (void); void build_relations (void); void compute_FOLLOWS (void); void compute_lookaheads (void); void digraph (short int **relation); void add_lookback_edge (int stateno, int ruleno, int gotono); void traverse (register int i); void lalr(void) { tokensetsize = WORDSIZE(ntokens); set_state_table(); set_accessing_symbol(); set_shift_table(); set_reduction_table(); set_maxrhs(); initialize_LA(); set_goto_map(); initialize_F(); build_relations(); compute_FOLLOWS(); compute_lookaheads(); } void set_state_table(void) { register core *sp; state_table = NEW2(nstates, core *); for (sp = first_state; sp; sp = sp->next) state_table[sp->number] = sp; } void set_accessing_symbol(void) { register core *sp; accessing_symbol = NEW2(nstates, short); for (sp = first_state; sp; sp = sp->next) accessing_symbol[sp->number] = sp->accessing_symbol; } void set_shift_table(void) { register shifts *sp; shift_table = NEW2(nstates, shifts *); for (sp = first_shift; sp; sp = sp->next) shift_table[sp->number] = sp; } void set_reduction_table(void) { register reductions *rp; reduction_table = NEW2(nstates, reductions *); for (rp = first_reduction; rp; rp = rp->next) reduction_table[rp->number] = rp; } void set_maxrhs(void) { register short *itemp; register short *item_end; register int length; register int max; length = 0; max = 0; item_end = ritem + nitems; for (itemp = ritem; itemp < item_end; itemp++) { if (*itemp >= 0) { length++; } else { if (length > max) max = length; length = 0; } } maxrhs = max; } void initialize_LA(void) { register int i, j, k; register reductions *rp; lookaheads = NEW2(nstates + 1, short); k = 0; for (i = 0; i < nstates; i++) { lookaheads[i] = k; rp = reduction_table[i]; if (rp) k += rp->nreds; } lookaheads[nstates] = k; LA = NEW2(k * tokensetsize, unsigned); LAruleno = NEW2(k, short); lookback = NEW2(k, shorts *); k = 0; for (i = 0; i < nstates; i++) { rp = reduction_table[i]; if (rp) { for (j = 0; j < rp->nreds; j++) { LAruleno[k] = rp->rules[j]; k++; } } } } void set_goto_map(void) { register shifts *sp; register int i; register int symbol; register int k; register short *temp_map; register int state2; register int state1; goto_map = NEW2(nvars + 1, short) - ntokens; temp_map = NEW2(nvars + 1, short) - ntokens; ngotos = 0; for (sp = first_shift; sp; sp = sp->next) { for (i = sp->nshifts - 1; i >= 0; i--) { symbol = accessing_symbol[sp->shift[i]]; if (ISTOKEN(symbol)) break; if (ngotos == MAXSHORT) fatal("too many gotos"); ngotos++; goto_map[symbol]++; } } k = 0; for (i = ntokens; i < nsyms; i++) { temp_map[i] = k; k += goto_map[i]; } for (i = ntokens; i < nsyms; i++) goto_map[i] = temp_map[i]; goto_map[nsyms] = ngotos; temp_map[nsyms] = ngotos; from_state = NEW2(ngotos, short); to_state = NEW2(ngotos, short); for (sp = first_shift; sp; sp = sp->next) { state1 = sp->number; for (i = sp->nshifts - 1; i >= 0; i--) { state2 = sp->shift[i]; symbol = accessing_symbol[state2]; if (ISTOKEN(symbol)) break; k = temp_map[symbol]++; from_state[k] = state1; to_state[k] = state2; } } FREE(temp_map + ntokens); } /* Map_goto maps a state/symbol pair into its numeric representation. */ int map_goto(int state, int symbol) { register int high; register int low; register int middle; register int s; low = goto_map[symbol]; high = goto_map[symbol + 1]; for (;;) { assert(low <= high); middle = (low + high) >> 1; s = from_state[middle]; if (s == state) return (middle); else if (s < state) low = middle + 1; else high = middle - 1; } } void initialize_F(void) { register int i; register int j; register int k; register shifts *sp; register short *edge; register unsigned *rowp; register short *rp; register short **reads; register int nedges; register int stateno; register int symbol; register int nwords; nwords = ngotos * tokensetsize; F = NEW2(nwords, unsigned); reads = NEW2(ngotos, short *); edge = NEW2(ngotos + 1, short); nedges = 0; rowp = F; for (i = 0; i < ngotos; i++) { stateno = to_state[i]; sp = shift_table[stateno]; if (sp) { k = sp->nshifts; for (j = 0; j < k; j++) { symbol = accessing_symbol[sp->shift[j]]; if (ISVAR(symbol)) break; SETBIT(rowp, symbol); } for (; j < k; j++) { symbol = accessing_symbol[sp->shift[j]]; if (nullable[symbol]) edge[nedges++] = map_goto(stateno, symbol); } if (nedges) { reads[i] = rp = NEW2(nedges + 1, short); for (j = 0; j < nedges; j++) rp[j] = edge[j]; rp[nedges] = -1; nedges = 0; } } rowp += tokensetsize; } SETBIT(F, 0); digraph(reads); for (i = 0; i < ngotos; i++) { if (reads[i]) FREE(reads[i]); } FREE(reads); FREE(edge); } void build_relations(void) { register int i; register int j; register int k; register short *rulep; register short *rp; register shifts *sp; register int length; register int nedges; register int done; register int state1; register int stateno; register int symbol1; register int symbol2; register short *shortp; register short *edge; register short *states; register short **new_includes; includes = NEW2(ngotos, short *); edge = NEW2(ngotos + 1, short); states = NEW2(maxrhs + 1, short); for (i = 0; i < ngotos; i++) { nedges = 0; state1 = from_state[i]; symbol1 = accessing_symbol[to_state[i]]; for (rulep = derives[symbol1]; *rulep >= 0; rulep++) { length = 1; states[0] = state1; stateno = state1; for (rp = ritem + rrhs[*rulep]; *rp >= 0; rp++) { symbol2 = *rp; sp = shift_table[stateno]; k = sp->nshifts; for (j = 0; j < k; j++) { stateno = sp->shift[j]; if (accessing_symbol[stateno] == symbol2) break; } states[length++] = stateno; } add_lookback_edge(stateno, *rulep, i); length--; done = 0; while (!done) { done = 1; rp--; if (ISVAR(*rp)) { stateno = states[--length]; edge[nedges++] = map_goto(stateno, *rp); if (nullable[*rp] && length > 0) done = 0; } } } if (nedges) { includes[i] = shortp = NEW2(nedges + 1, short); for (j = 0; j < nedges; j++) shortp[j] = edge[j]; shortp[nedges] = -1; } } new_includes = transpose(includes, ngotos); for (i = 0; i < ngotos; i++) if (includes[i]) FREE(includes[i]); FREE(includes); includes = new_includes; FREE(edge); FREE(states); } void add_lookback_edge(int stateno, int ruleno, int gotono) { register int i, k; register int found; register shorts *sp; i = lookaheads[stateno]; k = lookaheads[stateno + 1]; found = 0; while (!found && i < k) { if (LAruleno[i] == ruleno) found = 1; else ++i; } assert(found); sp = NEW(shorts); sp->next = lookback[i]; sp->value = gotono; lookback[i] = sp; } short ** transpose(short int **R, int n) { register short **new_R; register short **temp_R; register short *nedges; register short *sp; register int i; register int k; nedges = NEW2(n, short); for (i = 0; i < n; i++) { sp = R[i]; if (sp) { while (*sp >= 0) nedges[*sp++]++; } } new_R = NEW2(n, short *); temp_R = NEW2(n, short *); for (i = 0; i < n; i++) { k = nedges[i]; if (k > 0) { sp = NEW2(k + 1, short); new_R[i] = sp; temp_R[i] = sp; sp[k] = -1; } } FREE(nedges); for (i = 0; i < n; i++) { sp = R[i]; if (sp) { while (*sp >= 0) *temp_R[*sp++]++ = i; } } FREE(temp_R); return (new_R); } void compute_FOLLOWS(void) { digraph(includes); } void compute_lookaheads(void) { register int i, n; register unsigned *fp1, *fp2, *fp3; register shorts *sp, *next; register unsigned *rowp; rowp = LA; n = lookaheads[nstates]; for (i = 0; i < n; i++) { fp3 = rowp + tokensetsize; for (sp = lookback[i]; sp; sp = sp->next) { fp1 = rowp; fp2 = F + tokensetsize * sp->value; while (fp1 < fp3) *fp1++ |= *fp2++; } rowp = fp3; } for (i = 0; i < n; i++) for (sp = lookback[i]; sp; sp = next) { next = sp->next; FREE(sp); } FREE(lookback); FREE(F); } void digraph(short int **relation) { register int i; infinity = ngotos + 2; INDEX = NEW2(ngotos + 1, short); VERTICES = NEW2(ngotos + 1, short); top = 0; R = relation; for (i = 0; i < ngotos; i++) INDEX[i] = 0; for (i = 0; i < ngotos; i++) { if (INDEX[i] == 0 && R[i]) traverse(i); } FREE(INDEX); FREE(VERTICES); } void traverse(register int i) { register unsigned *fp1; register unsigned *fp2; register unsigned *fp3; register int j; register short *rp; int height; unsigned *base; VERTICES[++top] = i; INDEX[i] = height = top; base = F + i * tokensetsize; fp3 = base + tokensetsize; rp = R[i]; if (rp) { while ((j = *rp++) >= 0) { if (INDEX[j] == 0) traverse(j); if (INDEX[i] > INDEX[j]) INDEX[i] = INDEX[j]; fp1 = base; fp2 = F + j * tokensetsize; while (fp1 < fp3) *fp1++ |= *fp2++; } } if (INDEX[i] == height) { for (;;) { j = VERTICES[top--]; INDEX[j] = infinity; if (i == j) break; fp1 = base; fp2 = F + j * tokensetsize; while (fp1 < fp3) *fp2++ = *fp1++; } } } mingw-ocaml/ocaml/binary-compat/0000755000175000017500000000000012124403241016223 5ustar tootstootsmingw-ocaml/ocaml/binary-compat/compat/0000755000175000017500000000000012124403241017506 5ustar tootstootsmingw-ocaml/ocaml/binary-compat/compat/3.11.2/0000755000175000017500000000000012124403241020230 5ustar tootstootsmingw-ocaml/ocaml/binary-compat/compat/3.11.2/.gitignore0000644000175000017500000000000012124403241022206 0ustar tootstootsmingw-ocaml/ocaml/binary-compat/compat/3.12.0/0000755000175000017500000000000012124403241020227 5ustar tootstootsmingw-ocaml/ocaml/binary-compat/compat/3.12.0/.gitignore0000644000175000017500000000000012124403241022205 0ustar tootstootsmingw-ocaml/ocaml/testasmcomp/0000755000175000017500000000000012124403241016015 5ustar tootstootsmingw-ocaml/ocaml/testasmcomp/.gitignore0000644000175000017500000000000012124403241017773 0ustar tootstootsmingw-ocaml/ocaml/test/0000755000175000017500000000000012124403241014435 5ustar tootstootsmingw-ocaml/ocaml/test/Results/0000755000175000017500000000000012124403241016076 5ustar tootstootsmingw-ocaml/ocaml/test/Results/.gitignore0000644000175000017500000000000012124403241020054 0ustar tootstootsmingw-ocaml/ocaml/test/testinterp/0000755000175000017500000000000012124403241016636 5ustar tootstootsmingw-ocaml/ocaml/test/testinterp/.gitignore0000644000175000017500000000000012124403241020614 0ustar tootstootsmingw-ocaml/ocaml/test/.gitignore0000644000175000017500000000000012124403241016413 0ustar tootstootsmingw-ocaml/ocaml/test/Moretest/0000755000175000017500000000000012124403241016237 5ustar tootstootsmingw-ocaml/ocaml/test/Moretest/.gitignore0000644000175000017500000000000012124403241020215 0ustar tootstootsmingw-ocaml/ocaml/toplevel/0000755000175000017500000000000012124403242015311 5ustar tootstootsmingw-ocaml/ocaml/toplevel/opttopdirs.mli0000644000175000017500000000251212124403241020222 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* The toplevel directives. *) open Format val dir_quit : unit -> unit val dir_directory : string -> unit val dir_cd : string -> unit val dir_load : formatter -> string -> unit val dir_use : formatter -> string -> unit val dir_install_printer : formatter -> Longident.t -> unit val dir_remove_printer : formatter -> Longident.t -> unit type 'a printer_type_new = Format.formatter -> 'a -> unit type 'a printer_type_old = 'a -> unit (* For topmain.ml. Maybe shouldn't be there *) val load_file : formatter -> string -> bool mingw-ocaml/ocaml/toplevel/opttoploop.ml0000644000175000017500000003413112124403242020064 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* The interactive toplevel loop *) open Path open Lexing open Format open Config open Misc open Parsetree open Types open Typedtree open Outcometree open Lambda type res = Ok of Obj.t | Err of string type evaluation_outcome = Result of Obj.t | Exception of exn external ndl_run_toplevel: string -> string -> res = "caml_natdynlink_run_toplevel" external ndl_loadsym: string -> Obj.t = "caml_natdynlink_loadsym" let global_symbol id = let sym = Compilenv.symbol_for_global id in try ndl_loadsym sym with _ -> fatal_error ("Opttoploop.global_symbol " ^ (Ident.unique_name id)) let need_symbol sym = try ignore (ndl_loadsym sym); false with _ -> true let dll_run dll entry = match (try Result (Obj.magic (ndl_run_toplevel dll entry)) with exn -> Exception exn) with | Exception _ as r -> r | Result r -> match Obj.magic r with | Ok x -> Result x | Err s -> fatal_error ("Opttoploop.dll_run " ^ s) type directive_fun = | Directive_none of (unit -> unit) | Directive_string of (string -> unit) | Directive_int of (int -> unit) | Directive_ident of (Longident.t -> unit) | Directive_bool of (bool -> unit) (* Return the value referred to by a path *) let toplevel_value id = let (glb,pos) = Translmod.nat_toplevel_name id in (Obj.magic (global_symbol glb)).(pos) let rec eval_path = function | Pident id -> if Ident.persistent id || Ident.global id then global_symbol id else toplevel_value id | Pdot(p, s, pos) -> Obj.field (eval_path p) pos | Papply(p1, p2) -> fatal_error "Toploop.eval_path" (* To print values *) module EvalPath = struct type value = Obj.t exception Error let eval_path p = try eval_path p with _ -> raise Error let same_value v1 v2 = (v1 == v2) end module Printer = Genprintval.Make(Obj)(EvalPath) let max_printer_depth = ref 100 let max_printer_steps = ref 300 let print_out_value = Oprint.out_value let print_out_type = Oprint.out_type let print_out_class_type = Oprint.out_class_type let print_out_module_type = Oprint.out_module_type let print_out_sig_item = Oprint.out_sig_item let print_out_signature = Oprint.out_signature let print_out_phrase = Oprint.out_phrase let print_untyped_exception ppf obj = !print_out_value ppf (Printer.outval_of_untyped_exception obj) let outval_of_value env obj ty = Printer.outval_of_value !max_printer_steps !max_printer_depth (fun _ _ _ -> None) env obj ty let print_value env obj ppf ty = !print_out_value ppf (outval_of_value env obj ty) let install_printer = Printer.install_printer let remove_printer = Printer.remove_printer (* Hooks for parsing functions *) let parse_toplevel_phrase = ref Parse.toplevel_phrase let parse_use_file = ref Parse.use_file let print_location = Location.print_error (* FIXME change back to print *) let print_error = Location.print_error let print_warning = Location.print_warning let input_name = Location.input_name (* Hooks for initialization *) let toplevel_startup_hook = ref (fun () -> ()) (* Load in-core and execute a lambda term *) let phrase_seqid = ref 0 let phrase_name = ref "TOP" open Lambda let load_lambda ppf (size, lam) = if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; let slam = Simplif.simplify_lambda lam in if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam; let dll = if !Clflags.keep_asm_file then !phrase_name ^ ext_dll else Filename.temp_file ("caml" ^ !phrase_name) ext_dll in let fn = Filename.chop_extension dll in Asmgen.compile_implementation ~toplevel:need_symbol fn ppf (size, lam); Asmlink.call_linker_shared [fn ^ ext_obj] dll; Sys.remove (fn ^ ext_obj); let dll = if Filename.is_implicit dll then Filename.concat (Sys.getcwd ()) dll else dll in let res = dll_run dll !phrase_name in (try Sys.remove dll with Sys_error _ -> ()); (* note: under windows, cannot remove a loaded dll (should remember the handles, close them in at_exit, and then remove files) *) res (* Print the outcome of an evaluation *) let rec pr_item env = function | Tsig_value(id, decl) :: rem -> let tree = Printtyp.tree_of_value_description id decl in let valopt = match decl.val_kind with | Val_prim _ -> None | _ -> let v = outval_of_value env (toplevel_value id) decl.val_type in Some v in Some (tree, valopt, rem) | Tsig_type(id, _, _) :: rem when Btype.is_row_name (Ident.name id) -> pr_item env rem | Tsig_type(id, decl, rs) :: rem -> let tree = Printtyp.tree_of_type_declaration id decl rs in Some (tree, None, rem) | Tsig_exception(id, decl) :: rem -> let tree = Printtyp.tree_of_exception_declaration id decl in Some (tree, None, rem) | Tsig_module(id, mty, rs) :: rem -> let tree = Printtyp.tree_of_module id mty rs in Some (tree, None, rem) | Tsig_modtype(id, decl) :: rem -> let tree = Printtyp.tree_of_modtype_declaration id decl in Some (tree, None, rem) | Tsig_class(id, decl, rs) :: cltydecl :: tydecl1 :: tydecl2 :: rem -> let tree = Printtyp.tree_of_class_declaration id decl rs in Some (tree, None, rem) | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> let tree = Printtyp.tree_of_cltype_declaration id decl rs in Some (tree, None, rem) | _ -> None let rec item_list env = function | [] -> [] | items -> match pr_item env items with | None -> [] | Some (tree, valopt, items) -> (tree, valopt) :: item_list env items (* The current typing environment for the toplevel *) let toplevel_env = ref Env.empty (* Print an exception produced by an evaluation *) let print_out_exception ppf exn outv = !print_out_phrase ppf (Ophr_exception (exn, outv)) let print_exception_outcome ppf exn = if exn = Out_of_memory then Gc.full_major (); let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in print_out_exception ppf exn outv (* The table of toplevel directives. Filled by functions from module topdirs. *) let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t) (* Execute a toplevel phrase *) let execute_phrase print_outcome ppf phr = match phr with | Ptop_def sstr -> let oldenv = !toplevel_env in incr phrase_seqid; phrase_name := Printf.sprintf "TOP%i" !phrase_seqid; Compilenv.reset ?packname:None !phrase_name; Typecore.reset_delayed_checks (); let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none in Typecore.force_delayed_checks (); let res = Translmod.transl_store_phrases !phrase_name str in Warnings.check_fatal (); begin try toplevel_env := newenv; let res = load_lambda ppf res in let out_phr = match res with | Result v -> Compilenv.record_global_approx_toplevel (); if print_outcome then match str with | [Tstr_eval exp] -> let outv = outval_of_value newenv v exp.exp_type in let ty = Printtyp.tree_of_type_scheme exp.exp_type in Ophr_eval (outv, ty) | [] -> Ophr_signature [] | _ -> Ophr_signature (item_list newenv (Typemod.simplify_signature sg)) else Ophr_signature [] | Exception exn -> toplevel_env := oldenv; if exn = Out_of_memory then Gc.full_major(); let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in Ophr_exception (exn, outv) in !print_out_phrase ppf out_phr; begin match out_phr with | Ophr_eval (_, _) | Ophr_signature _ -> true | Ophr_exception _ -> false end with x -> toplevel_env := oldenv; raise x end | Ptop_dir(dir_name, dir_arg) -> try match (Hashtbl.find directive_table dir_name, dir_arg) with | (Directive_none f, Pdir_none) -> f (); true | (Directive_string f, Pdir_string s) -> f s; true | (Directive_int f, Pdir_int n) -> f n; true | (Directive_ident f, Pdir_ident lid) -> f lid; true | (Directive_bool f, Pdir_bool b) -> f b; true | (_, _) -> fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name; false with Not_found -> fprintf ppf "Unknown directive `%s'.@." dir_name; false (* Temporary assignment to a reference *) let protect r newval body = let oldval = !r in try r := newval; let res = body() in r := oldval; res with x -> r := oldval; raise x (* Read and execute commands from a file *) let use_print_results = ref true let use_file ppf name = try let (filename, ic, must_close) = if name = "" then ("(stdin)", stdin, false) else begin let filename = find_in_path !Config.load_path name in let ic = open_in_bin filename in (filename, ic, true) end in let lb = Lexing.from_channel ic in Location.init lb filename; (* Skip initial #! line if any *) Lexer.skip_sharp_bang lb; let success = protect Location.input_name filename (fun () -> try List.iter (fun ph -> if !Clflags.dump_parsetree then Printast.top_phrase ppf ph; if not (execute_phrase !use_print_results ppf ph) then raise Exit) (!parse_use_file lb); true with | Exit -> false | Sys.Break -> fprintf ppf "Interrupted.@."; false | x -> Opterrors.report_error ppf x; false) in if must_close then close_in ic; success with Not_found -> fprintf ppf "Cannot find file %s.@." name; false let use_silently ppf name = protect use_print_results false (fun () -> use_file ppf name) (* Reading function for interactive use *) let first_line = ref true let got_eof = ref false;; let read_input_default prompt buffer len = output_string Pervasives.stdout prompt; flush Pervasives.stdout; let i = ref 0 in try while true do if !i >= len then raise Exit; let c = input_char stdin in buffer.[!i] <- c; incr i; if c = '\n' then raise Exit; done; (!i, false) with | End_of_file -> (!i, true) | Exit -> (!i, false) let read_interactive_input = ref read_input_default let refill_lexbuf buffer len = if !got_eof then (got_eof := false; 0) else begin let prompt = if !Clflags.noprompt then "" else if !first_line then "# " else if !Clflags.nopromptcont then "" else if Lexer.in_comment () then "* " else " " in first_line := false; let (len, eof) = !read_interactive_input prompt buffer len in if eof then begin Location.echo_eof (); if len > 0 then got_eof := true; len end else len end (* Toplevel initialization. Performed here instead of at the beginning of loop() so that user code linked in with ocamlmktop can call directives from Topdirs. *) let _ = Sys.interactive := true; Dynlink.init (); Optcompile.init_path(); Clflags.dlcode := true; () let load_ocamlinit ppf = match !Clflags.init_file with | Some f -> if Sys.file_exists f then ignore (use_silently ppf f) else fprintf ppf "Init file not found: \"%s\".@." f | None -> if Sys.file_exists ".ocamlinit" then ignore (use_silently ppf ".ocamlinit") else try let home_init = Filename.concat (Sys.getenv "HOME") ".ocamlinit" in if Sys.file_exists home_init then ignore (use_silently ppf home_init) with Not_found -> () ;; let set_paths () = (* Add whatever -I options have been specified on the command line, but keep the directories that user code linked in with ocamlmktop may have added to load_path. *) load_path := !load_path @ [Filename.concat Config.standard_library "camlp4"]; load_path := "" :: (List.rev !Clflags.include_dirs @ !load_path); () let initialize_toplevel_env () = toplevel_env := Optcompile.initial_env() (* The interactive loop *) exception PPerror let loop ppf = fprintf ppf " OCaml version %s - native toplevel@.@." Config.version; initialize_toplevel_env (); let lb = Lexing.from_function refill_lexbuf in Location.init lb "//toplevel//"; Location.input_name := "//toplevel//"; Location.input_lexbuf := Some lb; Sys.catch_break true; load_ocamlinit ppf; while true do let snap = Btype.snapshot () in try Lexing.flush_input lb; Location.reset(); first_line := true; let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; ignore(execute_phrase true ppf phr) with | End_of_file -> exit 0 | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap | PPerror -> () | x -> Opterrors.report_error ppf x; Btype.backtrack snap done (* Execute a script *) let run_script ppf name args = let len = Array.length args in if Array.length Sys.argv < len then invalid_arg "Toploop.run_script"; Array.blit args 0 Sys.argv 0 len; Obj.truncate (Obj.repr Sys.argv) len; Arg.current := 0; Optcompile.init_path(); toplevel_env := Optcompile.initial_env(); Sys.interactive := false; use_silently ppf name mingw-ocaml/ocaml/toplevel/toplevellib.mllib0000644000175000017500000000120712124403242020653 0ustar tootstootsMyocamlbuild_config Misc Tbl Config Clflags Terminfo Ccomp Warnings Consistbl Location Longident Syntaxerr Parser Lexer Parse Printast Ident Path Primitive Types Btype Oprint Subst Predef Datarepr Cmi_format Env Typedtree Cmt_format Ctype Printtyp Includeclass Mtype Includecore Includemod Parmatch Typetexp Stypes Typecore Typedecl Typeclass Typemod Lambda Printlambda Typeopt Switch Matching Translobj Translcore Translclass Translmod Simplif Runtimedef Meta Instruct Bytegen Printinstr Opcodes Emitcode Bytesections Dll Symtable Bytelink Bytelibrarian Bytepackager Pparse Errors Compile Main_args Genprintval Toploop Trace Topdirs Topmain mingw-ocaml/ocaml/toplevel/trace.ml0000644000175000017500000001263612124403242016751 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* The "trace" facility *) open Format open Misc open Longident open Types open Toploop type codeptr = Obj.t type traced_function = { path: Path.t; (* Name under which it is traced *) closure: Obj.t; (* Its function closure (patched) *) actual_code: codeptr; (* Its original code pointer *) instrumented_fun: codeptr -> Obj.t -> Obj.t -> Obj.t } (* Printing function *) let traced_functions = ref ([] : traced_function list) (* Check if a function is already traced *) let is_traced clos = let rec is_traced = function [] -> None | tf :: rem -> if tf.closure == clos then Some tf.path else is_traced rem in is_traced !traced_functions (* Get or overwrite the code pointer of a closure *) let get_code_pointer cls = Obj.field cls 0 let set_code_pointer cls ptr = Obj.set_field cls 0 ptr (* Call a traced function (use old code pointer, but new closure as environment so that recursive calls are also traced). It is necessary to wrap Meta.invoke_traced_function in an ML function so that the RETURN at the end of the ML wrapper takes us to the code of the function. *) let invoke_traced_function codeptr env arg = Meta.invoke_traced_function codeptr env arg let print_label ppf l = if l <> "" then fprintf ppf "%s:" l (* If a function returns a functional value, wrap it into a trace code *) let rec instrument_result env name ppf clos_typ = match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with | Tarrow(l, t1, t2, _) -> let starred_name = match name with | Lident s -> Lident(s ^ "*") | Ldot(lid, s) -> Ldot(lid, s ^ "*") | Lapply(l1, l2) -> fatal_error "Trace.instrument_result" in let trace_res = instrument_result env starred_name ppf t2 in (fun clos_val -> Obj.repr (fun arg -> if not !may_trace then (Obj.magic clos_val : Obj.t -> Obj.t) arg else begin may_trace := false; try fprintf ppf "@[<2>%a <--@ %a%a@]@." Printtyp.longident starred_name print_label l (print_value !toplevel_env arg) t1; may_trace := true; let res = (Obj.magic clos_val : Obj.t -> Obj.t) arg in may_trace := false; fprintf ppf "@[<2>%a -->@ %a@]@." Printtyp.longident starred_name (print_value !toplevel_env res) t2; may_trace := true; trace_res res with exn -> may_trace := false; fprintf ppf "@[<2>%a raises@ %a@]@." Printtyp.longident starred_name (print_value !toplevel_env (Obj.repr exn)) Predef.type_exn; may_trace := true; raise exn end)) | _ -> (fun v -> v) (* Same as instrument_result, but for a toplevel closure (modified in place) *) let instrument_closure env name ppf clos_typ = match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with | Tarrow(l, t1, t2, _) -> let trace_res = instrument_result env name ppf t2 in (fun actual_code closure arg -> if not !may_trace then begin let res = invoke_traced_function actual_code closure arg in res (* do not remove let, prevents tail-call to invoke_traced_ *) end else begin may_trace := false; try fprintf ppf "@[<2>%a <--@ %a%a@]@." Printtyp.longident name print_label l (print_value !toplevel_env arg) t1; may_trace := true; let res = invoke_traced_function actual_code closure arg in may_trace := false; fprintf ppf "@[<2>%a -->@ %a@]@." Printtyp.longident name (print_value !toplevel_env res) t2; may_trace := true; trace_res res with exn -> may_trace := false; fprintf ppf "@[<2>%a raises@ %a@]@." Printtyp.longident name (print_value !toplevel_env (Obj.repr exn)) Predef.type_exn; may_trace := true; raise exn end) | _ -> assert false (* Given the address of a closure, find its tracing info *) let rec find_traced_closure clos = function | [] -> fatal_error "Trace.find_traced_closure" | f :: rem -> if f.closure == clos then f else find_traced_closure clos rem (* Trace the application of an (instrumented) closure to an argument *) let print_trace clos arg = let f = find_traced_closure clos !traced_functions in f.instrumented_fun f.actual_code clos arg mingw-ocaml/ocaml/toplevel/genprintval.mli0000644000175000017500000000325612124403242020353 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Printing of values *) open Types open Format module type OBJ = sig type t val obj : t -> 'a val is_block : t -> bool val tag : t -> int val size : t -> int val field : t -> int -> t end module type EVALPATH = sig type valu val eval_path: Path.t -> valu exception Error val same_value: valu -> valu -> bool end module type S = sig type t val install_printer : Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit val remove_printer : Path.t -> unit val outval_of_untyped_exception : t -> Outcometree.out_value val outval_of_value : int -> int -> (int -> t -> Types.type_expr -> Outcometree.out_value option) -> Env.t -> t -> type_expr -> Outcometree.out_value end module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) : (S with type t = O.t) mingw-ocaml/ocaml/toplevel/topstart.ml0000644000175000017500000000152212124403242017523 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) let _ = Topmain.main() mingw-ocaml/ocaml/toplevel/toploop.mli0000644000175000017500000001040312124403242017506 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Format (* Accessors for the table of toplevel value bindings. These functions must appear as first and second exported functions in this module. (See module Translmod.) *) val getvalue : string -> Obj.t val setvalue : string -> Obj.t -> unit (* Set the load paths, before running anything *) val set_paths : unit -> unit (* The interactive toplevel loop *) val loop : formatter -> unit (* Read and execute a script from the given file *) val run_script : formatter -> string -> string array -> bool (* true if successful, false if error *) (* Interface with toplevel directives *) type directive_fun = | Directive_none of (unit -> unit) | Directive_string of (string -> unit) | Directive_int of (int -> unit) | Directive_ident of (Longident.t -> unit) | Directive_bool of (bool -> unit) val directive_table : (string, directive_fun) Hashtbl.t (* Table of known directives, with their execution function *) val toplevel_env : Env.t ref (* Typing environment for the toplevel *) val initialize_toplevel_env : unit -> unit (* Initialize the typing environment for the toplevel *) val print_exception_outcome : formatter -> exn -> unit (* Print an exception resulting from the evaluation of user code. *) val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool (* Execute the given toplevel phrase. Return [true] if the phrase executed with no errors and [false] otherwise. First bool says whether the values and types of the results should be printed. Uncaught exceptions are always printed. *) val use_file : formatter -> string -> bool val use_silently : formatter -> string -> bool (* Read and execute commands from a file. [use_file] prints the types and values of the results. [use_silently] does not print them. *) val eval_path: Path.t -> Obj.t (* Return the toplevel object referred to by the given path *) (* Printing of values *) val print_value: Env.t -> Obj.t -> formatter -> Types.type_expr -> unit val print_untyped_exception: formatter -> Obj.t -> unit val install_printer : Path.t -> Types.type_expr -> (formatter -> Obj.t -> unit) -> unit val remove_printer : Path.t -> unit val max_printer_depth: int ref val max_printer_steps: int ref (* Hooks for external parsers and printers *) val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref val print_location : formatter -> Location.t -> unit val print_error : formatter -> Location.t -> unit val print_warning : Location.t -> formatter -> Warnings.t -> unit val input_name : string ref val print_out_value : (formatter -> Outcometree.out_value -> unit) ref val print_out_type : (formatter -> Outcometree.out_type -> unit) ref val print_out_class_type : (formatter -> Outcometree.out_class_type -> unit) ref val print_out_module_type : (formatter -> Outcometree.out_module_type -> unit) ref val print_out_sig_item : (formatter -> Outcometree.out_sig_item -> unit) ref val print_out_signature : (formatter -> Outcometree.out_sig_item list -> unit) ref val print_out_phrase : (formatter -> Outcometree.out_phrase -> unit) ref (* Hooks for external line editor *) val read_interactive_input : (string -> string -> int -> int * bool) ref (* Hooks for initialization *) val toplevel_startup_hook : (unit -> unit) ref (* Used by Trace module *) val may_trace : bool ref mingw-ocaml/ocaml/toplevel/topdirs.ml0000644000175000017500000002650312124403242017335 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Toplevel directives *) open Format open Misc open Longident open Path open Types open Cmo_format open Trace open Toploop (* The standard output formatter *) let std_out = std_formatter (* To quit *) let dir_quit () = exit 0 let _ = Hashtbl.add directive_table "quit" (Directive_none dir_quit) (* To add a directory to the load path *) let dir_directory s = let d = expand_directory Config.standard_library s in Config.load_path := d :: !Config.load_path; Dll.add_path [d] let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory) (* To remove a directory from the load path *) let dir_remove_directory s = let d = expand_directory Config.standard_library s in Config.load_path := List.filter (fun d' -> d' <> d) !Config.load_path; Dll.remove_path [d] let _ = Hashtbl.add directive_table "remove_directory" (Directive_string dir_remove_directory) (* To change the current directory *) let dir_cd s = Sys.chdir s let _ = Hashtbl.add directive_table "cd" (Directive_string dir_cd) (* Load in-core a .cmo file *) exception Load_failed let check_consistency ppf filename cu = try List.iter (fun (name, crc) -> Consistbl.check Env.crc_units name crc filename) cu.cu_imports with Consistbl.Inconsistency(name, user, auth) -> fprintf ppf "@[The files %s@ and %s@ \ disagree over interface %s@]@." user auth name; raise Load_failed let load_compunit ic filename ppf compunit = check_consistency ppf filename compunit; seek_in ic compunit.cu_pos; let code_size = compunit.cu_codesize + 8 in let code = Meta.static_alloc code_size in unsafe_really_input ic code 0 compunit.cu_codesize; String.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); String.unsafe_blit "\000\000\000\001\000\000\000" 0 code (compunit.cu_codesize + 1) 7; let initial_symtable = Symtable.current_state() in Symtable.patch_object code compunit.cu_reloc; Symtable.update_global_table(); begin try may_trace := true; ignore((Meta.reify_bytecode code code_size) ()); may_trace := false; with exn -> may_trace := false; Symtable.restore_state initial_symtable; print_exception_outcome ppf exn; raise Load_failed end let rec load_file recursive ppf name = let filename = try Some (find_in_path !Config.load_path name) with Not_found -> None in match filename with | None -> fprintf ppf "Cannot find file %s.@." name; false | Some filename -> let ic = open_in_bin filename in try let success = really_load_file recursive ppf name filename ic in close_in ic; success with exn -> close_in ic; raise exn and really_load_file recursive ppf name filename ic = let ic = open_in_bin filename in let buffer = Misc.input_bytes ic (String.length Config.cmo_magic_number) in try if buffer = Config.cmo_magic_number then begin let compunit_pos = input_binary_int ic in (* Go to descriptor *) seek_in ic compunit_pos; let cu : compilation_unit = input_value ic in if recursive then List.iter (function | (Reloc_getglobal id, _) when not (Symtable.is_global_defined id) -> let file = Ident.name id ^ ".cmo" in begin match try Some (Misc.find_in_path_uncap !Config.load_path file) with Not_found -> None with | None -> () | Some file -> if not (load_file recursive ppf file) then raise Load_failed end | _ -> () ) cu.cu_reloc; load_compunit ic filename ppf cu; true end else if buffer = Config.cma_magic_number then begin let toc_pos = input_binary_int ic in (* Go to table of contents *) seek_in ic toc_pos; let lib = (input_value ic : library) in List.iter (fun dllib -> let name = Dll.extract_dll_name dllib in try Dll.open_dlls Dll.For_execution [name] with Failure reason -> fprintf ppf "Cannot load required shared library %s.@.Reason: %s.@." name reason; raise Load_failed) lib.lib_dllibs; List.iter (load_compunit ic filename ppf) lib.lib_units; true end else begin fprintf ppf "File %s is not a bytecode object file.@." name; false end with Load_failed -> false let dir_load ppf name = ignore (load_file false ppf name) let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_out)) let dir_load_rec ppf name = ignore (load_file true ppf name) let _ = Hashtbl.add directive_table "load_rec" (Directive_string (dir_load_rec std_out)) let load_file = load_file false (* Load commands from a file *) let dir_use ppf name = ignore(Toploop.use_file ppf name) let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_out)) (* Install, remove a printer *) type 'a printer_type_new = Format.formatter -> 'a -> unit type 'a printer_type_old = 'a -> unit let match_printer_type ppf desc typename = let (printer_type, _) = try Env.lookup_type (Ldot(Lident "Topdirs", typename)) !toplevel_env with Not_found -> fprintf ppf "Cannot find type Topdirs.%s.@." typename; raise Exit in Ctype.init_def(Ident.current_time()); Ctype.begin_def(); let ty_arg = Ctype.newvar() in Ctype.unify !toplevel_env (Ctype.newconstr printer_type [ty_arg]) (Ctype.instance_def desc.val_type); Ctype.end_def(); Ctype.generalize ty_arg; ty_arg let find_printer_type ppf lid = try let (path, desc) = Env.lookup_value lid !toplevel_env in let (ty_arg, is_old_style) = try (match_printer_type ppf desc "printer_type_new", false) with Ctype.Unify _ -> (match_printer_type ppf desc "printer_type_old", true) in (ty_arg, path, is_old_style) with | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid; raise Exit | Ctype.Unify _ -> fprintf ppf "%a has a wrong type for a printing function.@." Printtyp.longident lid; raise Exit let dir_install_printer ppf lid = try let (ty_arg, path, is_old_style) = find_printer_type ppf lid in let v = eval_path path in let print_function = if is_old_style then (fun formatter repr -> Obj.obj v (Obj.obj repr)) else (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in install_printer path ty_arg print_function with Exit -> () let dir_remove_printer ppf lid = try let (ty_arg, path, is_old_style) = find_printer_type ppf lid in begin try remove_printer path with Not_found -> fprintf ppf "No printer named %a.@." Printtyp.longident lid end with Exit -> () let _ = Hashtbl.add directive_table "install_printer" (Directive_ident (dir_install_printer std_out)) let _ = Hashtbl.add directive_table "remove_printer" (Directive_ident (dir_remove_printer std_out)) (* The trace *) external current_environment: unit -> Obj.t = "caml_get_current_environment" let tracing_function_ptr = get_code_pointer (Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg)) let dir_trace ppf lid = try let (path, desc) = Env.lookup_value lid !toplevel_env in (* Check if this is a primitive *) match desc.val_kind with | Val_prim p -> fprintf ppf "%a is an external function and cannot be traced.@." Printtyp.longident lid | _ -> let clos = eval_path path in (* Nothing to do if it's not a closure *) if Obj.is_block clos && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag) then begin match is_traced clos with | Some opath -> fprintf ppf "%a is already traced (under the name %a).@." Printtyp.path path Printtyp.path opath | None -> (* Instrument the old closure *) traced_functions := { path = path; closure = clos; actual_code = get_code_pointer clos; instrumented_fun = instrument_closure !toplevel_env lid ppf desc.val_type } :: !traced_functions; (* Redirect the code field of the closure to point to the instrumentation function *) set_code_pointer clos tracing_function_ptr; fprintf ppf "%a is now traced.@." Printtyp.longident lid end else fprintf ppf "%a is not a function.@." Printtyp.longident lid with | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid let dir_untrace ppf lid = try let (path, desc) = Env.lookup_value lid !toplevel_env in let rec remove = function | [] -> fprintf ppf "%a was not traced.@." Printtyp.longident lid; [] | f :: rem -> if Path.same f.path path then begin set_code_pointer f.closure f.actual_code; fprintf ppf "%a is no longer traced.@." Printtyp.longident lid; rem end else f :: remove rem in traced_functions := remove !traced_functions with | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid let dir_untrace_all ppf () = List.iter (fun f -> set_code_pointer f.closure f.actual_code; fprintf ppf "%a is no longer traced.@." Printtyp.path f.path) !traced_functions; traced_functions := [] let parse_warnings ppf iserr s = try Warnings.parse_options iserr s with Arg.Bad err -> fprintf ppf "%s.@." err let _ = Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out)); Hashtbl.add directive_table "untrace" (Directive_ident (dir_untrace std_out)); Hashtbl.add directive_table "untrace_all" (Directive_none (dir_untrace_all std_out)); (* Control the printing of values *) Hashtbl.add directive_table "print_depth" (Directive_int(fun n -> max_printer_depth := n)); Hashtbl.add directive_table "print_length" (Directive_int(fun n -> max_printer_steps := n)); (* Set various compiler flags *) Hashtbl.add directive_table "labels" (Directive_bool(fun b -> Clflags.classic := not b)); Hashtbl.add directive_table "principal" (Directive_bool(fun b -> Clflags.principal := b)); Hashtbl.add directive_table "rectypes" (Directive_none(fun () -> Clflags.recursive_types := true)); Hashtbl.add directive_table "warnings" (Directive_string (parse_warnings std_out false)); Hashtbl.add directive_table "warn_error" (Directive_string (parse_warnings std_out true)) mingw-ocaml/ocaml/toplevel/expunge.ml0000644000175000017500000000556312124403242017327 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* "Expunge" a toplevel by removing compiler modules from the global List.map. Usage: expunge *) open Sys open Misc module StringSet = Set.Make(struct type t = string let compare = compare end) let is_exn = let h = Hashtbl.create 64 in Array.iter (fun n -> Hashtbl.add h n ()) Runtimedef.builtin_exceptions; Hashtbl.mem h let to_keep = ref StringSet.empty let negate = Sys.argv.(3) = "-v" let keep = if negate then fun name -> is_exn name || not (StringSet.mem name !to_keep) else fun name -> is_exn name || (StringSet.mem name !to_keep) let expunge_map tbl = Symtable.filter_global_map (fun id -> keep (Ident.name id)) tbl let expunge_crcs tbl = List.filter (fun (unit, crc) -> keep unit) tbl let main () = let input_name = Sys.argv.(1) in let output_name = Sys.argv.(2) in for i = (if negate then 4 else 3) to Array.length Sys.argv - 1 do to_keep := StringSet.add (String.capitalize Sys.argv.(i)) !to_keep done; let ic = open_in_bin input_name in Bytesections.read_toc ic; let toc = Bytesections.toc() in let pos_first_section = Bytesections.pos_first_section ic in let oc = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o777 output_name in (* Copy the file up to the symbol section as is *) seek_in ic 0; copy_file_chunk ic oc pos_first_section; (* Copy each section, modifying the symbol section in passing *) Bytesections.init_record oc; List.iter (fun (name, len) -> begin match name with "SYMB" -> let global_map = (input_value ic : Symtable.global_map) in output_value oc (expunge_map global_map) | "CRCS" -> let crcs = (input_value ic : (string * Digest.t) list) in output_value oc (expunge_crcs crcs) | _ -> copy_file_chunk ic oc len end; Bytesections.record oc name) toc; (* Rewrite the toc and trailer *) Bytesections.write_toc_and_trailer oc; (* Done *) close_in ic; close_out oc let _ = Printexc.catch main (); exit 0 mingw-ocaml/ocaml/toplevel/opttopmain.ml0000644000175000017500000000736212124403242020045 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Clflags let usage = "Usage: ocamlnat [script-file]\noptions are:" let preload_objects = ref [] let prepare ppf = Opttoploop.set_paths (); try let res = List.for_all (Opttopdirs.load_file ppf) (List.rev !preload_objects) in !Opttoploop.toplevel_startup_hook (); res with x -> try Opterrors.report_error ppf x; false with x -> Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x); false let file_argument name = let ppf = Format.err_formatter in if Filename.check_suffix name ".cmxs" || Filename.check_suffix name ".cmx" || Filename.check_suffix name ".cmxa" then preload_objects := name :: !preload_objects else begin let newargs = Array.sub Sys.argv !Arg.current (Array.length Sys.argv - !Arg.current) in if prepare ppf && Opttoploop.run_script ppf name newargs then exit 0 else exit 2 end let print_version () = Printf.printf "The OCaml toplevel, version %s\n" Sys.ocaml_version; exit 0; ;; let print_version_num () = Printf.printf "%s\n" Sys.ocaml_version; exit 0; ;; module Options = Main_args.Make_opttop_options (struct let set r () = r := true let clear r () = r := false let _absname = set Location.absname let _compact = clear optimize_for_speed let _I dir = let dir = Misc.expand_directory Config.standard_library dir in include_dirs := dir :: !include_dirs let _init s = init_file := Some s let _inline n = inline_threshold := n * 8 let _labels = clear classic let _no_app_funct = clear applicative_functors let _noassert = set noassert let _nolabels = set classic let _noprompt = set noprompt let _nopromptcont = set nopromptcont let _nostdlib = set no_std_include let _principal = set principal let _rectypes = set recursive_types let _strict_sequence = set strict_sequence let _S = set keep_asm_file let _stdin () = file_argument "" let _unsafe = set fast let _version () = print_version () let _vnum () = print_version_num () let _w s = Warnings.parse_options false s let _warn_error s = Warnings.parse_options true s let _warn_help = Warnings.help_warnings let _dparsetree = set dump_parsetree let _drawlambda = set dump_rawlambda let _dlambda = set dump_lambda let _dcmm = set dump_cmm let _dsel = set dump_selection let _dcombine = set dump_combine let _dlive () = dump_live := true; Printmach.print_live := true let _dspill = set dump_spill let _dsplit = set dump_split let _dinterf = set dump_interf let _dprefer = set dump_prefer let _dalloc = set dump_regalloc let _dreload = set dump_reload let _dscheduling = set dump_scheduling let _dlinear = set dump_linear let _dstartup = set keep_startup_file let anonymous = file_argument end);; let main () = Arg.parse Options.list file_argument usage; if not (prepare Format.err_formatter) then exit 2; Opttoploop.loop Format.std_formatter mingw-ocaml/ocaml/toplevel/opttopdirs.ml0000644000175000017500000001342512124403242020057 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Toplevel directives *) open Format open Misc open Longident open Path open Types open Opttoploop (* The standard output formatter *) let std_out = std_formatter (* To quit *) let dir_quit () = exit 0 let _ = Hashtbl.add directive_table "quit" (Directive_none dir_quit) (* To add a directory to the load path *) let dir_directory s = let d = expand_directory Config.standard_library s in Config.load_path := d :: !Config.load_path let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory) let _ = Hashtbl.add directive_table "show_dirs" (Directive_none (fun () -> List.iter print_endline !Config.load_path )) (* To change the current directory *) let dir_cd s = Sys.chdir s let _ = Hashtbl.add directive_table "cd" (Directive_string dir_cd) (* Load in-core a .cmxs file *) let load_file ppf name0 = let name = try Some (find_in_path !Config.load_path name0) with Not_found -> None in match name with | None -> fprintf ppf "File not found: %s@." name0; false | Some name -> let fn,tmp = if Filename.check_suffix name ".cmx" || Filename.check_suffix name ".cmxa" then let cmxs = Filename.temp_file "caml" ".cmxs" in Asmlink.link_shared ppf [name] cmxs; cmxs,true else name,false in let success = (* The Dynlink interface does not allow us to distinguish between a Dynlink.Error exceptions raised in the loaded modules or a genuine error during dynlink... *) try Dynlink.loadfile fn; true with | Dynlink.Error err -> fprintf ppf "Error while loading %s: %s.@." name (Dynlink.error_message err); false | exn -> print_exception_outcome ppf exn; false in if tmp then (try Sys.remove fn with Sys_error _ -> ()); success let dir_load ppf name = ignore (load_file ppf name) let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_out)) (* Load commands from a file *) let dir_use ppf name = ignore(Opttoploop.use_file ppf name) let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_out)) (* Install, remove a printer *) type 'a printer_type_new = Format.formatter -> 'a -> unit type 'a printer_type_old = 'a -> unit let match_printer_type ppf desc typename = let (printer_type, _) = try Env.lookup_type (Ldot(Lident "Topdirs", typename)) !toplevel_env with Not_found -> fprintf ppf "Cannot find type Topdirs.%s.@." typename; raise Exit in Ctype.init_def(Ident.current_time()); Ctype.begin_def(); let ty_arg = Ctype.newvar() in Ctype.unify !toplevel_env (Ctype.newconstr printer_type [ty_arg]) (Ctype.instance_def desc.val_type); Ctype.end_def(); Ctype.generalize ty_arg; ty_arg let find_printer_type ppf lid = try let (path, desc) = Env.lookup_value lid !toplevel_env in let (ty_arg, is_old_style) = try (match_printer_type ppf desc "printer_type_new", false) with Ctype.Unify _ -> (match_printer_type ppf desc "printer_type_old", true) in (ty_arg, path, is_old_style) with | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid; raise Exit | Ctype.Unify _ -> fprintf ppf "%a has a wrong type for a printing function.@." Printtyp.longident lid; raise Exit let dir_install_printer ppf lid = try let (ty_arg, path, is_old_style) = find_printer_type ppf lid in let v = eval_path path in let print_function = if is_old_style then (fun formatter repr -> Obj.obj v (Obj.obj repr)) else (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in install_printer path ty_arg print_function with Exit -> () let dir_remove_printer ppf lid = try let (ty_arg, path, is_old_style) = find_printer_type ppf lid in begin try remove_printer path with Not_found -> fprintf ppf "No printer named %a.@." Printtyp.longident lid end with Exit -> () let _ = Hashtbl.add directive_table "install_printer" (Directive_ident (dir_install_printer std_out)) let _ = Hashtbl.add directive_table "remove_printer" (Directive_ident (dir_remove_printer std_out)) let parse_warnings ppf iserr s = try Warnings.parse_options iserr s with Arg.Bad err -> fprintf ppf "%s.@." err let _ = (* Control the printing of values *) Hashtbl.add directive_table "print_depth" (Directive_int(fun n -> max_printer_depth := n)); Hashtbl.add directive_table "print_length" (Directive_int(fun n -> max_printer_steps := n)); (* Set various compiler flags *) Hashtbl.add directive_table "labels" (Directive_bool(fun b -> Clflags.classic := not b)); Hashtbl.add directive_table "principal" (Directive_bool(fun b -> Clflags.principal := b)); Hashtbl.add directive_table "warnings" (Directive_string (parse_warnings std_out false)); Hashtbl.add directive_table "warn_error" (Directive_string (parse_warnings std_out true)) mingw-ocaml/ocaml/toplevel/opttopstart.ml0000644000175000017500000000152512124403242020251 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) let _ = Opttopmain.main() mingw-ocaml/ocaml/toplevel/trace.mli0000644000175000017500000000307512124403242017117 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* The "trace" facility *) open Format type codeptr type traced_function = { path: Path.t; (* Name under which it is traced *) closure: Obj.t; (* Its function closure (patched) *) actual_code: codeptr; (* Its original code pointer *) instrumented_fun: codeptr -> Obj.t -> Obj.t -> Obj.t } (* Printing function *) val traced_functions: traced_function list ref val is_traced: Obj.t -> Path.t option val get_code_pointer: Obj.t -> codeptr val set_code_pointer: Obj.t -> codeptr -> unit val instrument_closure: Env.t -> Longident.t -> formatter -> Types.type_expr -> codeptr -> Obj.t -> Obj.t -> Obj.t val print_trace: Obj.t -> Obj.t -> Obj.t mingw-ocaml/ocaml/toplevel/genprintval.ml0000644000175000017500000003534012124403242020201 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* To print values *) open Misc open Format open Longident open Path open Types open Outcometree module type OBJ = sig type t val obj : t -> 'a val is_block : t -> bool val tag : t -> int val size : t -> int val field : t -> int -> t end module type EVALPATH = sig type valu val eval_path: Path.t -> valu exception Error val same_value: valu -> valu -> bool end module type S = sig type t val install_printer : Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit val remove_printer : Path.t -> unit val outval_of_untyped_exception : t -> Outcometree.out_value val outval_of_value : int -> int -> (int -> t -> Types.type_expr -> Outcometree.out_value option) -> Env.t -> t -> type_expr -> Outcometree.out_value end module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct type t = O.t (* Given an exception value, we cannot recover its type, hence we cannot print its arguments in general. Here, we do a feeble attempt to print integer, string and float arguments... *) let outval_of_untyped_exception_args obj start_offset = if O.size obj > start_offset then begin let list = ref [] in for i = start_offset to O.size obj - 1 do let arg = O.field obj i in if not (O.is_block arg) then list := Oval_int (O.obj arg : int) :: !list (* Note: this could be a char or a constant constructor... *) else if O.tag arg = Obj.string_tag then list := Oval_string (String.escaped (O.obj arg : string)) :: !list else if O.tag arg = Obj.double_tag then list := Oval_float (O.obj arg : float) :: !list else list := Oval_constr (Oide_ident "_", []) :: !list done; List.rev !list end else [] let outval_of_untyped_exception bucket = let name = (O.obj(O.field(O.field bucket 0) 0) : string) in let args = if (name = "Match_failure" || name = "Assert_failure" || name = "Undefined_recursive_module") && O.size bucket = 2 && O.tag(O.field bucket 1) = 0 then outval_of_untyped_exception_args (O.field bucket 1) 0 else outval_of_untyped_exception_args bucket 1 in Oval_constr (Oide_ident name, args) (* The user-defined printers. Also used for some builtin types. *) let printers = ref ([ Pident(Ident.create "print_int"), Predef.type_int, (fun x -> Oval_int (O.obj x : int)); Pident(Ident.create "print_float"), Predef.type_float, (fun x -> Oval_float (O.obj x : float)); Pident(Ident.create "print_char"), Predef.type_char, (fun x -> Oval_char (O.obj x : char)); Pident(Ident.create "print_string"), Predef.type_string, (fun x -> Oval_string (O.obj x : string)); Pident(Ident.create "print_int32"), Predef.type_int32, (fun x -> Oval_int32 (O.obj x : int32)); Pident(Ident.create "print_nativeint"), Predef.type_nativeint, (fun x -> Oval_nativeint (O.obj x : nativeint)); Pident(Ident.create "print_int64"), Predef.type_int64, (fun x -> Oval_int64 (O.obj x : int64)) ] : (Path.t * type_expr * (O.t -> Outcometree.out_value)) list) let install_printer path ty fn = let print_val ppf obj = try fn ppf obj with | exn -> fprintf ppf "" Printtyp.path path in let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in printers := (path, ty, printer) :: !printers let remove_printer path = let rec remove = function | [] -> raise Not_found | (p, ty, fn as printer) :: rem -> if Path.same p path then rem else printer :: remove rem in printers := remove !printers let find_printer env ty = let rec find = function | [] -> raise Not_found | (name, sch, printer) :: remainder -> if Ctype.moregeneral env false sch ty then printer else find remainder in find !printers (* Print a constructor or label, giving it the same prefix as the type it comes from. Attempt to omit the prefix if the type comes from a module that has been opened. *) let tree_of_qualified lookup_fun env ty_path name = match ty_path with | Pident id -> Oide_ident name | Pdot(p, s, pos) -> if try match (lookup_fun (Lident name) env).desc with | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path' | _ -> false with Not_found -> false then Oide_ident name else Oide_dot (Printtyp.tree_of_path p, name) | Papply(p1, p2) -> Printtyp.tree_of_path ty_path let tree_of_constr = tree_of_qualified (fun lid env -> (snd (Env.lookup_constructor lid env)).cstr_res) and tree_of_label = tree_of_qualified (fun lid env -> (snd (Env.lookup_label lid env)).lbl_res) (* An abstract type *) let abstract_type = Ctype.newty (Tconstr (Pident (Ident.create "abstract"), [], ref Mnil)) (* The main printing function *) let outval_of_value max_steps max_depth check_depth env obj ty = let printer_steps = ref max_steps in let rec tree_of_val depth obj ty = decr printer_steps; if !printer_steps < 0 || depth < 0 then Oval_ellipsis else begin try find_printer env ty obj with Not_found -> match (Ctype.repr ty).desc with | Tvar _ | Tunivar _ -> Oval_stuff "" | Tarrow(_, ty1, ty2, _) -> Oval_stuff "" | Ttuple(ty_list) -> Oval_tuple (tree_of_val_list 0 depth obj ty_list) | Tconstr(path, [], _) when Path.same path Predef.path_exn -> tree_of_exception depth obj | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list -> if O.is_block obj then match check_depth depth obj ty with Some x -> x | None -> let rec tree_of_conses tree_list obj = if !printer_steps < 0 || depth < 0 then Oval_ellipsis :: tree_list else if O.is_block obj then let tree = tree_of_val (depth - 1) (O.field obj 0) ty_arg in let next_obj = O.field obj 1 in tree_of_conses (tree :: tree_list) next_obj else tree_list in Oval_list (List.rev (tree_of_conses [] obj)) else Oval_list [] | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array -> let length = O.size obj in if length > 0 then match check_depth depth obj ty with Some x -> x | None -> let rec tree_of_items tree_list i = if !printer_steps < 0 || depth < 0 then Oval_ellipsis :: tree_list else if i < length then let tree = tree_of_val (depth - 1) (O.field obj i) ty_arg in tree_of_items (tree :: tree_list) (i + 1) else tree_list in Oval_array (List.rev (tree_of_items [] 0)) else Oval_array [] | Tconstr (path, [ty_arg], _) when Path.same path Predef.path_lazy_t -> if Lazy.lazy_is_val (O.obj obj) then let v = tree_of_val depth (Lazy.force (O.obj obj)) ty_arg in Oval_constr (Oide_ident "lazy", [v]) else Oval_stuff "" | Tconstr(path, ty_list, _) -> begin try let decl = Env.find_type path env in match decl with | {type_kind = Type_abstract; type_manifest = None} -> Oval_stuff "" | {type_kind = Type_abstract; type_manifest = Some body} -> tree_of_val depth obj (try Ctype.apply env decl.type_params body ty_list with Ctype.Cannot_apply -> abstract_type) | {type_kind = Type_variant constr_list} -> let tag = if O.is_block obj then Cstr_block(O.tag obj) else Cstr_constant(O.obj obj) in let (constr_name, constr_args,ret_type) = Datarepr.find_constr_by_tag tag constr_list in let type_params = match ret_type with Some t -> begin match (Ctype.repr t).desc with Tconstr (_,params,_) -> params | _ -> assert false end | None -> decl.type_params in let ty_args = List.map (function ty -> try Ctype.apply env type_params ty ty_list with Ctype.Cannot_apply -> abstract_type) constr_args in tree_of_constr_with_args (tree_of_constr env path) (Ident.name constr_name) 0 depth obj ty_args | {type_kind = Type_record(lbl_list, rep)} -> begin match check_depth depth obj ty with Some x -> x | None -> let rec tree_of_fields pos = function | [] -> [] | (lbl_name, _, lbl_arg) :: remainder -> let ty_arg = try Ctype.apply env decl.type_params lbl_arg ty_list with Ctype.Cannot_apply -> abstract_type in let lid = tree_of_label env path (Ident.name lbl_name) in let v = tree_of_val (depth - 1) (O.field obj pos) ty_arg in (lid, v) :: tree_of_fields (pos + 1) remainder in Oval_record (tree_of_fields 0 lbl_list) end with Not_found -> (* raised by Env.find_type *) Oval_stuff "" | Datarepr.Constr_not_found -> (* raised by find_constr_by_tag *) Oval_stuff "" end | Tvariant row -> let row = Btype.row_repr row in if O.is_block obj then let tag : int = O.obj (O.field obj 0) in let rec find = function | (l, f) :: fields -> if Btype.hash_variant l = tag then match Btype.row_field_repr f with | Rpresent(Some ty) | Reither(_,[ty],_,_) -> let args = tree_of_val (depth - 1) (O.field obj 1) ty in Oval_variant (l, Some args) | _ -> find fields else find fields | [] -> Oval_stuff "" in find row.row_fields else let tag : int = O.obj obj in let rec find = function | (l, _) :: fields -> if Btype.hash_variant l = tag then Oval_variant (l, None) else find fields | [] -> Oval_stuff "" in find row.row_fields | Tobject (_, _) -> Oval_stuff "" | Tsubst ty -> tree_of_val (depth - 1) obj ty | Tfield(_, _, _, _) | Tnil | Tlink _ -> fatal_error "Printval.outval_of_value" | Tpoly (ty, _) -> tree_of_val (depth - 1) obj ty | Tpackage _ -> Oval_stuff "" end and tree_of_val_list start depth obj ty_list = let rec tree_list i = function | [] -> [] | ty :: ty_list -> let tree = tree_of_val (depth - 1) (O.field obj i) ty in tree :: tree_list (i + 1) ty_list in tree_list start ty_list and tree_of_constr_with_args tree_of_cstr cstr_name start depth obj ty_args = let lid = tree_of_cstr cstr_name in let args = tree_of_val_list start depth obj ty_args in Oval_constr (lid, args) and tree_of_exception depth bucket = let name = (O.obj(O.field(O.field bucket 0) 0) : string) in let lid = Longident.parse name in try (* Attempt to recover the constructor description for the exn from its name *) let cstr = snd (Env.lookup_constructor lid env) in let path = match cstr.cstr_tag with Cstr_exception (p, _) -> p | _ -> raise Not_found in (* Make sure this is the right exception and not an homonym, by evaluating the exception found and comparing with the identifier contained in the exception bucket *) if not (EVP.same_value (O.field bucket 0) (EVP.eval_path path)) then raise Not_found; tree_of_constr_with_args (fun x -> Oide_ident x) name 1 depth bucket cstr.cstr_args with Not_found | EVP.Error -> match check_depth depth bucket ty with Some x -> x | None -> outval_of_untyped_exception bucket in tree_of_val max_depth obj ty end mingw-ocaml/ocaml/toplevel/topmain.ml0000644000175000017500000000635212124403242017320 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Clflags let usage = "Usage: ocaml [script-file [arguments]]\n\ options are:" let preload_objects = ref [] let prepare ppf = Toploop.set_paths (); try let res = List.for_all (Topdirs.load_file ppf) (List.rev !preload_objects) in !Toploop.toplevel_startup_hook (); res with x -> try Errors.report_error ppf x; false with x -> Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x); false (* If [name] is "", then the "file" is stdin treated as a script file. *) let file_argument name = let ppf = Format.err_formatter in if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma" then preload_objects := name :: !preload_objects else begin let newargs = Array.sub Sys.argv !Arg.current (Array.length Sys.argv - !Arg.current) in if prepare ppf && Toploop.run_script ppf name newargs then exit 0 else exit 2 end let print_version () = Printf.printf "The OCaml toplevel, version %s\n" Sys.ocaml_version; exit 0; ;; let print_version_num () = Printf.printf "%s\n" Sys.ocaml_version; exit 0; ;; module Options = Main_args.Make_bytetop_options (struct let set r () = r := true let clear r () = r := false let _absname = set Location.absname let _I dir = let dir = Misc.expand_directory Config.standard_library dir in include_dirs := dir :: !include_dirs let _init s = init_file := Some s let _labels = clear classic let _no_app_funct = clear applicative_functors let _noassert = set noassert let _nolabels = set classic let _noprompt = set noprompt let _nopromptcont = set nopromptcont let _nostdlib = set no_std_include let _principal = set principal let _rectypes = set recursive_types let _stdin () = file_argument "" let _strict_sequence = set strict_sequence let _unsafe = set fast let _version () = print_version () let _vnum () = print_version_num () let _w s = Warnings.parse_options false s let _warn_error s = Warnings.parse_options true s let _warn_help = Warnings.help_warnings let _dparsetree = set dump_parsetree let _drawlambda = set dump_rawlambda let _dlambda = set dump_lambda let _dinstr = set dump_instr let anonymous s = file_argument s end);; let main () = Arg.parse Options.list file_argument usage; if not (prepare Format.err_formatter) then exit 2; Toploop.loop Format.std_formatter mingw-ocaml/ocaml/toplevel/topdirs.mli0000644000175000017500000000301012124403242017472 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* The toplevel directives. *) open Format val dir_quit : unit -> unit val dir_directory : string -> unit val dir_remove_directory : string -> unit val dir_cd : string -> unit val dir_load : formatter -> string -> unit val dir_use : formatter -> string -> unit val dir_install_printer : formatter -> Longident.t -> unit val dir_remove_printer : formatter -> Longident.t -> unit val dir_trace : formatter -> Longident.t -> unit val dir_untrace : formatter -> Longident.t -> unit val dir_untrace_all : formatter -> unit -> unit type 'a printer_type_new = Format.formatter -> 'a -> unit type 'a printer_type_old = 'a -> unit (* For topmain.ml. Maybe shouldn't be there *) val load_file : formatter -> string -> bool mingw-ocaml/ocaml/toplevel/opttoploop.mli0000644000175000017500000000773212124403242020244 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Format (* Set the load paths, before running anything *) val set_paths : unit -> unit (* The interactive toplevel loop *) val loop : formatter -> unit (* Read and execute a script from the given file *) val run_script : formatter -> string -> string array -> bool (* true if successful, false if error *) (* Interface with toplevel directives *) type directive_fun = | Directive_none of (unit -> unit) | Directive_string of (string -> unit) | Directive_int of (int -> unit) | Directive_ident of (Longident.t -> unit) | Directive_bool of (bool -> unit) val directive_table : (string, directive_fun) Hashtbl.t (* Table of known directives, with their execution function *) val toplevel_env : Env.t ref (* Typing environment for the toplevel *) val initialize_toplevel_env : unit -> unit (* Initialize the typing environment for the toplevel *) val print_exception_outcome : formatter -> exn -> unit (* Print an exception resulting from the evaluation of user code. *) val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool (* Execute the given toplevel phrase. Return [true] if the phrase executed with no errors and [false] otherwise. First bool says whether the values and types of the results should be printed. Uncaught exceptions are always printed. *) val use_file : formatter -> string -> bool val use_silently : formatter -> string -> bool (* Read and execute commands from a file. [use_file] prints the types and values of the results. [use_silently] does not print them. *) val eval_path: Path.t -> Obj.t (* Return the toplevel object referred to by the given path *) (* Printing of values *) val print_value: Env.t -> Obj.t -> formatter -> Types.type_expr -> unit val print_untyped_exception: formatter -> Obj.t -> unit val install_printer : Path.t -> Types.type_expr -> (formatter -> Obj.t -> unit) -> unit val remove_printer : Path.t -> unit val max_printer_depth: int ref val max_printer_steps: int ref (* Hooks for external parsers and printers *) val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref val print_location : formatter -> Location.t -> unit val print_error : formatter -> Location.t -> unit val print_warning : Location.t -> formatter -> Warnings.t -> unit val input_name : string ref val print_out_value : (formatter -> Outcometree.out_value -> unit) ref val print_out_type : (formatter -> Outcometree.out_type -> unit) ref val print_out_class_type : (formatter -> Outcometree.out_class_type -> unit) ref val print_out_module_type : (formatter -> Outcometree.out_module_type -> unit) ref val print_out_sig_item : (formatter -> Outcometree.out_sig_item -> unit) ref val print_out_signature : (formatter -> Outcometree.out_sig_item list -> unit) ref val print_out_phrase : (formatter -> Outcometree.out_phrase -> unit) ref (* Hooks for external line editor *) val read_interactive_input : (string -> string -> int -> int * bool) ref (* Hooks for initialization *) val toplevel_startup_hook : (unit -> unit) ref mingw-ocaml/ocaml/toplevel/topmain.mli0000644000175000017500000000157112124403242017467 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Start the [ocaml] toplevel loop *) val main: unit -> unit mingw-ocaml/ocaml/toplevel/opttopmain.mli0000644000175000017500000000157112124403242020212 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Start the [ocaml] toplevel loop *) val main: unit -> unit mingw-ocaml/ocaml/toplevel/toploop.ml0000644000175000017500000003414612124403242017347 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* The interactive toplevel loop *) open Path open Lexing open Format open Config open Misc open Parsetree open Types open Typedtree open Outcometree type directive_fun = | Directive_none of (unit -> unit) | Directive_string of (string -> unit) | Directive_int of (int -> unit) | Directive_ident of (Longident.t -> unit) | Directive_bool of (bool -> unit) (* The table of toplevel value bindings and its accessors *) let toplevel_value_bindings = (Hashtbl.create 37 : (string, Obj.t) Hashtbl.t) let getvalue name = try Hashtbl.find toplevel_value_bindings name with Not_found -> fatal_error (name ^ " unbound at toplevel") let setvalue name v = Hashtbl.replace toplevel_value_bindings name v (* Return the value referred to by a path *) let rec eval_path = function | Pident id -> if Ident.persistent id || Ident.global id then Symtable.get_global_value id else begin let name = Translmod.toplevel_name id in try Hashtbl.find toplevel_value_bindings name with Not_found -> raise (Symtable.Error(Symtable.Undefined_global name)) end | Pdot(p, s, pos) -> Obj.field (eval_path p) pos | Papply(p1, p2) -> fatal_error "Toploop.eval_path" (* To print values *) module EvalPath = struct type valu = Obj.t exception Error let eval_path p = try eval_path p with Symtable.Error _ -> raise Error let same_value v1 v2 = (v1 == v2) end module Printer = Genprintval.Make(Obj)(EvalPath) let max_printer_depth = ref 100 let max_printer_steps = ref 300 let print_out_value = Oprint.out_value let print_out_type = Oprint.out_type let print_out_class_type = Oprint.out_class_type let print_out_module_type = Oprint.out_module_type let print_out_sig_item = Oprint.out_sig_item let print_out_signature = Oprint.out_signature let print_out_phrase = Oprint.out_phrase let print_untyped_exception ppf obj = !print_out_value ppf (Printer.outval_of_untyped_exception obj) let outval_of_value env obj ty = Printer.outval_of_value !max_printer_steps !max_printer_depth (fun _ _ _ -> None) env obj ty let print_value env obj ppf ty = !print_out_value ppf (outval_of_value env obj ty) let install_printer = Printer.install_printer let remove_printer = Printer.remove_printer (* Hooks for parsing functions *) let parse_toplevel_phrase = ref Parse.toplevel_phrase let parse_use_file = ref Parse.use_file let print_location = Location.print_error (* FIXME change back to print *) let print_error = Location.print_error let print_warning = Location.print_warning let input_name = Location.input_name (* Hooks for initialization *) let toplevel_startup_hook = ref (fun () -> ()) (* Load in-core and execute a lambda term *) let may_trace = ref false (* Global lock on tracing *) type evaluation_outcome = Result of Obj.t | Exception of exn let load_lambda ppf lam = if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; let slam = Simplif.simplify_lambda lam in if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam; let (init_code, fun_code) = Bytegen.compile_phrase slam in if !Clflags.dump_instr then fprintf ppf "%a%a@." Printinstr.instrlist init_code Printinstr.instrlist fun_code; let (code, code_size, reloc) = Emitcode.to_memory init_code fun_code in let can_free = (fun_code = []) in let initial_symtable = Symtable.current_state() in Symtable.patch_object code reloc; Symtable.check_global_initialized reloc; Symtable.update_global_table(); try may_trace := true; let retval = (Meta.reify_bytecode code code_size) () in may_trace := false; if can_free then begin Meta.static_release_bytecode code code_size; Meta.static_free code; end; Result retval with x -> may_trace := false; if can_free then begin Meta.static_release_bytecode code code_size; Meta.static_free code; end; Symtable.restore_state initial_symtable; Exception x (* Print the outcome of an evaluation *) let rec pr_item env = function | Sig_value(id, decl) :: rem -> let tree = Printtyp.tree_of_value_description id decl in let valopt = match decl.val_kind with | Val_prim _ -> None | _ -> let v = outval_of_value env (getvalue (Translmod.toplevel_name id)) decl.val_type in Some v in Some (tree, valopt, rem) | Sig_type(id, _, _) :: rem when Btype.is_row_name (Ident.name id) -> pr_item env rem | Sig_type(id, decl, rs) :: rem -> let tree = Printtyp.tree_of_type_declaration id decl rs in Some (tree, None, rem) | Sig_exception(id, decl) :: rem -> let tree = Printtyp.tree_of_exception_declaration id decl in Some (tree, None, rem) | Sig_module(id, mty, rs) :: rem -> let tree = Printtyp.tree_of_module id mty rs in Some (tree, None, rem) | Sig_modtype(id, decl) :: rem -> let tree = Printtyp.tree_of_modtype_declaration id decl in Some (tree, None, rem) | Sig_class(id, decl, rs) :: cltydecl :: tydecl1 :: tydecl2 :: rem -> let tree = Printtyp.tree_of_class_declaration id decl rs in Some (tree, None, rem) | Sig_class_type(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> let tree = Printtyp.tree_of_cltype_declaration id decl rs in Some (tree, None, rem) | _ -> None let rec item_list env = function | [] -> [] | items -> match pr_item env items with | None -> [] | Some (tree, valopt, items) -> (tree, valopt) :: item_list env items (* The current typing environment for the toplevel *) let toplevel_env = ref Env.empty (* Print an exception produced by an evaluation *) let print_out_exception ppf exn outv = !print_out_phrase ppf (Ophr_exception (exn, outv)) let print_exception_outcome ppf exn = if exn = Out_of_memory then Gc.full_major (); let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in print_out_exception ppf exn outv (* The table of toplevel directives. Filled by functions from module topdirs. *) let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t) (* Execute a toplevel phrase *) let execute_phrase print_outcome ppf phr = match phr with | Ptop_def sstr -> let oldenv = !toplevel_env in Typecore.reset_delayed_checks (); let (str, sg, newenv) = Typemod.type_toplevel_phrase oldenv sstr in let sg' = Typemod.simplify_signature sg in ignore (Includemod.signatures oldenv sg sg'); Typecore.force_delayed_checks (); let lam = Translmod.transl_toplevel_definition str in Warnings.check_fatal (); begin try toplevel_env := newenv; let res = load_lambda ppf lam in let out_phr = match res with | Result v -> if print_outcome then match str.str_items with | [ { str_desc = Tstr_eval exp }] -> let outv = outval_of_value newenv v exp.exp_type in let ty = Printtyp.tree_of_type_scheme exp.exp_type in Ophr_eval (outv, ty) | [] -> Ophr_signature [] | _ -> Ophr_signature (item_list newenv sg') else Ophr_signature [] | Exception exn -> toplevel_env := oldenv; if exn = Out_of_memory then Gc.full_major(); let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in Ophr_exception (exn, outv) in !print_out_phrase ppf out_phr; begin match out_phr with | Ophr_eval (_, _) | Ophr_signature _ -> true | Ophr_exception _ -> false end with x -> toplevel_env := oldenv; raise x end | Ptop_dir(dir_name, dir_arg) -> try match (Hashtbl.find directive_table dir_name, dir_arg) with | (Directive_none f, Pdir_none) -> f (); true | (Directive_string f, Pdir_string s) -> f s; true | (Directive_int f, Pdir_int n) -> f n; true | (Directive_ident f, Pdir_ident lid) -> f lid; true | (Directive_bool f, Pdir_bool b) -> f b; true | (_, _) -> fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name; false with Not_found -> fprintf ppf "Unknown directive `%s'.@." dir_name; false (* Temporary assignment to a reference *) let protect r newval body = let oldval = !r in try r := newval; let res = body() in r := oldval; res with x -> r := oldval; raise x (* Read and execute commands from a file, or from stdin if [name] is "". *) let use_print_results = ref true let use_file ppf name = try let (filename, ic, must_close) = if name = "" then ("(stdin)", stdin, false) else begin let filename = find_in_path !Config.load_path name in let ic = open_in_bin filename in (filename, ic, true) end in let lb = Lexing.from_channel ic in Location.init lb filename; (* Skip initial #! line if any *) Lexer.skip_sharp_bang lb; let success = protect Location.input_name filename (fun () -> try List.iter (fun ph -> if !Clflags.dump_parsetree then Printast.top_phrase ppf ph; if not (execute_phrase !use_print_results ppf ph) then raise Exit) (!parse_use_file lb); true with | Exit -> false | Sys.Break -> fprintf ppf "Interrupted.@."; false | x -> Errors.report_error ppf x; false) in if must_close then close_in ic; success with Not_found -> fprintf ppf "Cannot find file %s.@." name; false let use_silently ppf name = protect use_print_results false (fun () -> use_file ppf name) (* Reading function for interactive use *) let first_line = ref true let got_eof = ref false;; let read_input_default prompt buffer len = output_string Pervasives.stdout prompt; flush Pervasives.stdout; let i = ref 0 in try while true do if !i >= len then raise Exit; let c = input_char Pervasives.stdin in buffer.[!i] <- c; incr i; if c = '\n' then raise Exit; done; (!i, false) with | End_of_file -> (!i, true) | Exit -> (!i, false) let read_interactive_input = ref read_input_default let refill_lexbuf buffer len = if !got_eof then (got_eof := false; 0) else begin let prompt = if !Clflags.noprompt then "" else if !first_line then "# " else if !Clflags.nopromptcont then "" else if Lexer.in_comment () then "* " else " " in first_line := false; let (len, eof) = !read_interactive_input prompt buffer len in if eof then begin Location.echo_eof (); if len > 0 then got_eof := true; len end else len end (* Toplevel initialization. Performed here instead of at the beginning of loop() so that user code linked in with ocamlmktop can call directives from Topdirs. *) let _ = Sys.interactive := true; let crc_intfs = Symtable.init_toplevel() in Compile.init_path(); List.iter (fun (name, crc) -> Consistbl.set Env.crc_units name crc Sys.executable_name) crc_intfs let load_ocamlinit ppf = match !Clflags.init_file with | Some f -> if Sys.file_exists f then ignore (use_silently ppf f) else fprintf ppf "Init file not found: \"%s\".@." f | None -> if Sys.file_exists ".ocamlinit" then ignore (use_silently ppf ".ocamlinit") else try let home_init = Filename.concat (Sys.getenv "HOME") ".ocamlinit" in if Sys.file_exists home_init then ignore (use_silently ppf home_init) with Not_found -> () ;; let set_paths () = (* Add whatever -I options have been specified on the command line, but keep the directories that user code linked in with ocamlmktop may have added to load_path. *) load_path := !load_path @ [Filename.concat Config.standard_library "camlp4"]; load_path := "" :: (List.rev !Clflags.include_dirs @ !load_path); Dll.add_path !load_path let initialize_toplevel_env () = toplevel_env := Compile.initial_env() (* The interactive loop *) exception PPerror let loop ppf = fprintf ppf " OCaml version %s@.@." Config.version; initialize_toplevel_env (); let lb = Lexing.from_function refill_lexbuf in Location.init lb "//toplevel//"; Location.input_name := "//toplevel//"; Location.input_lexbuf := Some lb; Sys.catch_break true; load_ocamlinit ppf; while true do let snap = Btype.snapshot () in try Lexing.flush_input lb; Location.reset(); first_line := true; let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; Env.reset_missing_cmis (); ignore(execute_phrase true ppf phr) with | End_of_file -> exit 0 | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap | PPerror -> () | x -> Errors.report_error ppf x; Btype.backtrack snap done (* Execute a script. If [name] is "", read the script from stdin. *) let run_script ppf name args = let len = Array.length args in if Array.length Sys.argv < len then invalid_arg "Toploop.run_script"; Array.blit args 0 Sys.argv 0 len; Obj.truncate (Obj.repr Sys.argv) len; Arg.current := 0; Compile.init_path(); toplevel_env := Compile.initial_env(); Sys.interactive := false; use_silently ppf name mingw-ocaml/ocaml/typing/0000755000175000017500000000000012124403242014771 5ustar tootstootsmingw-ocaml/ocaml/typing/primitive.ml0000644000175000017500000000525312124403242017340 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Description of primitive functions *) open Misc type description = { prim_name: string; (* Name of primitive or C function *) prim_arity: int; (* Number of arguments *) prim_alloc: bool; (* Does it allocates or raise? *) prim_native_name: string; (* Name of C function for the nat. code gen. *) prim_native_float: bool } (* Does the above operate on unboxed floats? *) let parse_declaration arity decl = match decl with | name :: "noalloc" :: name2 :: "float" :: _ -> {prim_name = name; prim_arity = arity; prim_alloc = false; prim_native_name = name2; prim_native_float = true} | name :: "noalloc" :: name2 :: _ -> {prim_name = name; prim_arity = arity; prim_alloc = false; prim_native_name = name2; prim_native_float = false} | name :: name2 :: "float" :: _ -> {prim_name = name; prim_arity = arity; prim_alloc = true; prim_native_name = name2; prim_native_float = true} | name :: "noalloc" :: _ -> {prim_name = name; prim_arity = arity; prim_alloc = false; prim_native_name = ""; prim_native_float = false} | name :: name2 :: _ -> {prim_name = name; prim_arity = arity; prim_alloc = true; prim_native_name = name2; prim_native_float = false} | name :: _ -> {prim_name = name; prim_arity = arity; prim_alloc = true; prim_native_name = ""; prim_native_float = false} | [] -> fatal_error "Primitive.parse_declaration" let description_list p = let list = [p.prim_name] in let list = if not p.prim_alloc then "noalloc" :: list else list in let list = if p.prim_native_name <> "" then p.prim_native_name :: list else list in let list = if p.prim_native_float then "float" :: list else list in List.rev list let native_name p = if p.prim_native_name <> "" then p.prim_native_name else p.prim_name let byte_name p = p.prim_name mingw-ocaml/ocaml/typing/typetexp.mli0000644000175000017500000000770212124403242017364 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Typechecking of type expressions for the core language *) open Format;; val transl_simple_type: Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type val transl_simple_type_univars: Env.t -> Parsetree.core_type -> Typedtree.core_type val transl_simple_type_delayed: Env.t -> Parsetree.core_type -> Typedtree.core_type * (unit -> unit) (* Translate a type, but leave type variables unbound. Returns the type and a function that binds the type variable. *) val transl_type_scheme: Env.t -> Parsetree.core_type -> Typedtree.core_type val reset_type_variables: unit -> unit val enter_type_variable: bool -> Location.t -> string -> Types.type_expr val type_variable: Location.t -> string -> Types.type_expr type variable_context val narrow: unit -> variable_context val widen: variable_context -> unit exception Already_bound type error = Unbound_type_variable of string | Unbound_type_constructor of Longident.t | Unbound_type_constructor_2 of Path.t | Type_arity_mismatch of Longident.t * int * int | Bound_type_variable of string | Recursive_type | Unbound_row_variable of Longident.t | Type_mismatch of (Types.type_expr * Types.type_expr) list | Alias_type_mismatch of (Types.type_expr * Types.type_expr) list | Present_has_conjunction of string | Present_has_no_type of string | Constructor_mismatch of Types.type_expr * Types.type_expr | Not_a_variant of Types.type_expr | Variant_tags of string * string | Invalid_variable_name of string | Cannot_quantify of string * Types.type_expr | Multiple_constraints_on_type of Longident.t | Repeated_method_label of string | Unbound_value of Longident.t | Unbound_constructor of Longident.t | Unbound_label of Longident.t | Unbound_module of Longident.t | Unbound_class of Longident.t | Unbound_modtype of Longident.t | Unbound_cltype of Longident.t | Ill_typed_functor_application of Longident.t exception Error of Location.t * error val report_error: formatter -> error -> unit (* Support for first-class modules. *) val transl_modtype_longident: (* from Typemod *) (Location.t -> Env.t -> Longident.t -> Path.t) ref val transl_modtype: (* from Typemod *) (Env.t -> Parsetree.module_type -> Typedtree.module_type) ref val create_package_mty: Location.t -> Env.t -> Parsetree.package_type -> (Longident.t Asttypes.loc * Parsetree.core_type) list * Parsetree.module_type val find_type: Env.t -> Location.t -> Longident.t -> Path.t * Types.type_declaration val find_constructor: Env.t -> Location.t -> Longident.t -> Path.t * Types.constructor_description val find_label: Env.t -> Location.t -> Longident.t -> Path.t * Types.label_description val find_value: Env.t -> Location.t -> Longident.t -> Path.t * Types.value_description val find_class: Env.t -> Location.t -> Longident.t -> Path.t * Types.class_declaration val find_module: Env.t -> Location.t -> Longident.t -> Path.t * Types.module_type val find_modtype: Env.t -> Location.t -> Longident.t -> Path.t * Types.modtype_declaration val find_class_type: Env.t -> Location.t -> Longident.t -> Path.t * Types.class_type_declaration mingw-ocaml/ocaml/typing/predef.ml0000644000175000017500000002214212124403242016571 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Predefined type constructors (with special typing rules in typecore) *) open Asttypes open Path open Types open Btype let builtin_idents = ref [] let wrap create s = let id = create s in builtin_idents := (s, id) :: !builtin_idents; id let ident_create = wrap Ident.create let ident_create_predef_exn = wrap Ident.create_predef_exn let ident_int = ident_create "int" and ident_char = ident_create "char" and ident_string = ident_create "string" and ident_float = ident_create "float" and ident_bool = ident_create "bool" and ident_unit = ident_create "unit" and ident_exn = ident_create "exn" and ident_array = ident_create "array" and ident_list = ident_create "list" and ident_format6 = ident_create "format6" and ident_option = ident_create "option" and ident_nativeint = ident_create "nativeint" and ident_int32 = ident_create "int32" and ident_int64 = ident_create "int64" and ident_lazy_t = ident_create "lazy_t" let path_int = Pident ident_int and path_char = Pident ident_char and path_string = Pident ident_string and path_float = Pident ident_float and path_bool = Pident ident_bool and path_unit = Pident ident_unit and path_exn = Pident ident_exn and path_array = Pident ident_array and path_list = Pident ident_list and path_format6 = Pident ident_format6 and path_option = Pident ident_option and path_nativeint = Pident ident_nativeint and path_int32 = Pident ident_int32 and path_int64 = Pident ident_int64 and path_lazy_t = Pident ident_lazy_t let type_int = newgenty (Tconstr(path_int, [], ref Mnil)) and type_char = newgenty (Tconstr(path_char, [], ref Mnil)) and type_string = newgenty (Tconstr(path_string, [], ref Mnil)) and type_float = newgenty (Tconstr(path_float, [], ref Mnil)) and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil)) and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil)) and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil)) and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil)) and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil)) and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil)) and type_nativeint = newgenty (Tconstr(path_nativeint, [], ref Mnil)) and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil)) and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil)) and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil)) let ident_match_failure = ident_create_predef_exn "Match_failure" and ident_out_of_memory = ident_create_predef_exn "Out_of_memory" and ident_invalid_argument = ident_create_predef_exn "Invalid_argument" and ident_failure = ident_create_predef_exn "Failure" and ident_not_found = ident_create_predef_exn "Not_found" and ident_sys_error = ident_create_predef_exn "Sys_error" and ident_end_of_file = ident_create_predef_exn "End_of_file" and ident_division_by_zero = ident_create_predef_exn "Division_by_zero" and ident_stack_overflow = ident_create_predef_exn "Stack_overflow" and ident_sys_blocked_io = ident_create_predef_exn "Sys_blocked_io" and ident_assert_failure = ident_create_predef_exn "Assert_failure" and ident_undefined_recursive_module = ident_create_predef_exn "Undefined_recursive_module" let path_match_failure = Pident ident_match_failure and path_assert_failure = Pident ident_assert_failure and path_undefined_recursive_module = Pident ident_undefined_recursive_module let ident_false = ident_create "false" and ident_true = ident_create "true" and ident_void = ident_create "()" and ident_nil = ident_create "[]" and ident_cons = ident_create "::" and ident_none = ident_create "None" and ident_some = ident_create "Some" let build_initial_env add_type add_exception empty_env = let decl_abstr = {type_params = []; type_arity = 0; type_kind = Type_abstract; type_loc = Location.none; type_private = Public; type_manifest = None; type_variance = []; type_newtype_level = None} and decl_bool = {type_params = []; type_arity = 0; type_kind = Type_variant([ident_false, [], None; ident_true, [], None]); type_loc = Location.none; type_private = Public; type_manifest = None; type_variance = []; type_newtype_level = None} and decl_unit = {type_params = []; type_arity = 0; type_kind = Type_variant([ident_void, [], None]); type_loc = Location.none; type_private = Public; type_manifest = None; type_variance = []; type_newtype_level = None} and decl_exn = {type_params = []; type_arity = 0; type_kind = Type_variant []; type_loc = Location.none; type_private = Public; type_manifest = None; type_variance = []; type_newtype_level = None} and decl_array = let tvar = newgenvar() in {type_params = [tvar]; type_arity = 1; type_kind = Type_abstract; type_loc = Location.none; type_private = Public; type_manifest = None; type_variance = [true, true, true]; type_newtype_level = None} and decl_list = let tvar = newgenvar() in {type_params = [tvar]; type_arity = 1; type_kind = Type_variant([ident_nil, [], None; ident_cons, [tvar; type_list tvar], None]); type_loc = Location.none; type_private = Public; type_manifest = None; type_variance = [true, false, false]; type_newtype_level = None} and decl_format6 = {type_params = [ newgenvar(); newgenvar(); newgenvar(); newgenvar(); newgenvar(); newgenvar(); ]; type_arity = 6; type_kind = Type_abstract; type_loc = Location.none; type_private = Public; type_manifest = None; type_variance = [ true, true, true; true, true, true; true, true, true; true, true, true; true, true, true; true, true, true; ]; type_newtype_level = None} and decl_option = let tvar = newgenvar() in {type_params = [tvar]; type_arity = 1; type_kind = Type_variant([ident_none, [], None; ident_some, [tvar], None]); type_loc = Location.none; type_private = Public; type_manifest = None; type_variance = [true, false, false]; type_newtype_level = None} and decl_lazy_t = let tvar = newgenvar() in {type_params = [tvar]; type_arity = 1; type_kind = Type_abstract; type_loc = Location.none; type_private = Public; type_manifest = None; type_variance = [true, false, false]; type_newtype_level = None} in let add_exception id l = add_exception id { exn_args = l; exn_loc = Location.none } in add_exception ident_match_failure [newgenty (Ttuple[type_string; type_int; type_int])] ( add_exception ident_out_of_memory [] ( add_exception ident_stack_overflow [] ( add_exception ident_invalid_argument [type_string] ( add_exception ident_failure [type_string] ( add_exception ident_not_found [] ( add_exception ident_sys_blocked_io [] ( add_exception ident_sys_error [type_string] ( add_exception ident_end_of_file [] ( add_exception ident_division_by_zero [] ( add_exception ident_assert_failure [newgenty (Ttuple[type_string; type_int; type_int])] ( add_exception ident_undefined_recursive_module [newgenty (Ttuple[type_string; type_int; type_int])] ( add_type ident_int64 decl_abstr ( add_type ident_int32 decl_abstr ( add_type ident_nativeint decl_abstr ( add_type ident_lazy_t decl_lazy_t ( add_type ident_option decl_option ( add_type ident_format6 decl_format6 ( add_type ident_list decl_list ( add_type ident_array decl_array ( add_type ident_exn decl_exn ( add_type ident_unit decl_unit ( add_type ident_bool decl_bool ( add_type ident_float decl_abstr ( add_type ident_string decl_abstr ( add_type ident_char decl_abstr ( add_type ident_int decl_abstr ( empty_env))))))))))))))))))))))))))) let builtin_values = List.map (fun id -> Ident.make_global id; (Ident.name id, id)) [ident_match_failure; ident_out_of_memory; ident_stack_overflow; ident_invalid_argument; ident_failure; ident_not_found; ident_sys_error; ident_end_of_file; ident_division_by_zero; ident_sys_blocked_io; ident_assert_failure; ident_undefined_recursive_module ] (* Start non-predef identifiers at 1000. This way, more predefs can be defined in this file (above!) without breaking .cmi compatibility. *) let _ = Ident.set_current_time 999 let builtin_idents = List.rev !builtin_idents mingw-ocaml/ocaml/typing/subst.mli0000644000175000017500000000457012124403242016642 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Substitutions *) open Types type t (* Substitutions are used to translate a type from one context to another. This requires substituing paths for identifiers, and possibly also lowering the level of non-generic variables so that it be inferior to the maximum level of the new context. Substitutions can also be used to create a "clean" copy of a type. Indeed, non-variable node of a type are duplicated, with their levels set to generic level. That way, the resulting type is well-formed (decreasing levels), even if the original one was not. *) val identity: t val add_type: Ident.t -> Path.t -> t -> t val add_module: Ident.t -> Path.t -> t -> t val add_modtype: Ident.t -> module_type -> t -> t val for_saving: t -> t val reset_for_saving: unit -> unit val module_path: t -> Path.t -> Path.t val type_path: t -> Path.t -> Path.t val type_expr: t -> type_expr -> type_expr val class_type: t -> class_type -> class_type val value_description: t -> value_description -> value_description val type_declaration: t -> type_declaration -> type_declaration val exception_declaration: t -> exception_declaration -> exception_declaration val class_declaration: t -> class_declaration -> class_declaration val cltype_declaration: t -> class_type_declaration -> class_type_declaration val modtype: t -> module_type -> module_type val signature: t -> signature -> signature val modtype_declaration: t -> modtype_declaration -> modtype_declaration (* Composition of substitutions: apply (compose s1 s2) x = apply s2 (apply s1 x) *) val compose: t -> t -> t mingw-ocaml/ocaml/typing/ctype.mli0000644000175000017500000002771212124403242016631 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Operations on core types *) open Asttypes open Types exception Unify of (type_expr * type_expr) list exception Tags of label * label exception Subtype of (type_expr * type_expr) list * (type_expr * type_expr) list exception Cannot_expand exception Cannot_apply exception Recursive_abbrev exception Unification_recursive_abbrev of (type_expr * type_expr) list val init_def: int -> unit (* Set the initial variable level *) val begin_def: unit -> unit (* Raise the variable level by one at the beginning of a definition. *) val end_def: unit -> unit (* Lower the variable level by one at the end of a definition *) val begin_class_def: unit -> unit val raise_nongen_level: unit -> unit val reset_global_level: unit -> unit (* Reset the global level before typing an expression *) val increase_global_level: unit -> int val restore_global_level: int -> unit (* This pair of functions is only used in Typetexp *) val newty: type_desc -> type_expr val newvar: ?name:string -> unit -> type_expr val newvar2: ?name:string -> int -> type_expr (* Return a fresh variable *) val new_global_var: ?name:string -> unit -> type_expr (* Return a fresh variable, bound at toplevel (as type variables ['a] in type constraints). *) val newobj: type_expr -> type_expr val newconstr: Path.t -> type_expr list -> type_expr val none: type_expr (* A dummy type expression *) val repr: type_expr -> type_expr (* Return the canonical representative of a type. *) val object_fields: type_expr -> type_expr val flatten_fields: type_expr -> (string * field_kind * type_expr) list * type_expr (* Transform a field type into a list of pairs label-type *) (* The fields are sorted *) val associate_fields: (string * field_kind * type_expr) list -> (string * field_kind * type_expr) list -> (string * field_kind * type_expr * field_kind * type_expr) list * (string * field_kind * type_expr) list * (string * field_kind * type_expr) list val opened_object: type_expr -> bool val close_object: type_expr -> unit val row_variable: type_expr -> type_expr (* Return the row variable of an open object type *) val set_object_name: Ident.t -> type_expr -> type_expr list -> type_expr -> unit val remove_object_name: type_expr -> unit val hide_private_methods: type_expr -> unit val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr val lid_of_path: ?sharp:string -> Path.t -> Longident.t val sort_row_fields: (label * row_field) list -> (label * row_field) list val merge_row_fields: (label * row_field) list -> (label * row_field) list -> (label * row_field) list * (label * row_field) list * (label * row_field * row_field) list val filter_row_fields: bool -> (label * row_field) list -> (label * row_field) list val generalize: type_expr -> unit (* Generalize in-place the given type *) val iterative_generalization: int -> type_expr list -> type_expr list (* Efficient repeated generalization of a type *) val generalize_expansive: Env.t -> type_expr -> unit (* Generalize the covariant part of a type, making contravariant branches non-generalizable *) val generalize_global: type_expr -> unit (* Generalize the structure of a type, lowering variables to !global_level *) val generalize_structure: type_expr -> unit (* Same, but variables are only lowered to !current_level *) val generalize_spine: type_expr -> unit (* Special function to generalize a method during inference *) val correct_levels: type_expr -> type_expr (* Returns a copy with decreasing levels *) val limited_generalize: type_expr -> type_expr -> unit (* Only generalize some part of the type Make the remaining of the type non-generalizable *) val instance: ?partial:bool -> Env.t -> type_expr -> type_expr (* Take an instance of a type scheme *) (* partial=None -> normal partial=false -> newvar() for non generic subterms partial=true -> newty2 ty.level Tvar for non generic subterms *) val instance_def: type_expr -> type_expr (* use defaults *) val instance_list: Env.t -> type_expr list -> type_expr list (* Take an instance of a list of type schemes *) val instance_constructor: ?in_pattern:Env.t ref * int -> constructor_description -> type_expr list * type_expr (* Same, for a constructor *) val instance_parameterized_type: ?keep_names:bool -> type_expr list -> type_expr -> type_expr list * type_expr val instance_parameterized_type_2: type_expr list -> type_expr list -> type_expr -> type_expr list * type_expr list * type_expr val instance_declaration: type_declaration -> type_declaration val instance_class: type_expr list -> class_type -> type_expr list * class_type val instance_poly: ?keep_names:bool -> bool -> type_expr list -> type_expr -> type_expr list * type_expr (* Take an instance of a type scheme containing free univars *) val instance_label: bool -> label_description -> type_expr list * type_expr * type_expr (* Same, for a label *) val apply: Env.t -> type_expr list -> type_expr -> type_expr list -> type_expr (* [apply [p1...pN] t [a1...aN]] match the arguments [ai] to the parameters [pi] and returns the corresponding instance of [t]. Exception [Cannot_apply] is raised in case of failure. *) val expand_head_once: Env.t -> type_expr -> type_expr val expand_head: Env.t -> type_expr -> type_expr val try_expand_once_opt: Env.t -> type_expr -> type_expr val expand_head_opt: Env.t -> type_expr -> type_expr (** The compiler's own version of [expand_head] necessary for type-based optimisations. *) val full_expand: Env.t -> type_expr -> type_expr val enforce_constraints: Env.t -> type_expr -> unit val unify: Env.t -> type_expr -> type_expr -> unit (* Unify the two types given. Raise [Unify] if not possible. *) val unify_gadt: newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit (* Unify the two types given and update the environment with the local constraints. Raise [Unify] if not possible. *) val unify_var: Env.t -> type_expr -> type_expr -> unit (* Same as [unify], but allow free univars when first type is a variable. *) val filter_arrow: Env.t -> type_expr -> label -> type_expr * type_expr (* A special case of unification (with l:'a -> 'b). *) val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr (* A special case of unification (with {m : 'a; 'b}). *) val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit (* A special case of unification (with {m : 'a; 'b}), returning unit. *) val occur_in: Env.t -> type_expr -> type_expr -> bool val deep_occur: type_expr -> type_expr -> bool val filter_self_method: Env.t -> string -> private_flag -> (Ident.t * type_expr) Meths.t ref -> type_expr -> Ident.t * type_expr val moregeneral: Env.t -> bool -> type_expr -> type_expr -> bool (* Check if the first type scheme is more general than the second. *) val rigidify: type_expr -> type_expr list (* "Rigidify" a type and return its type variable *) val all_distinct_vars: Env.t -> type_expr list -> bool (* Check those types are all distinct type variables *) val matches: Env.t -> type_expr -> type_expr -> bool (* Same as [moregeneral false], implemented using the two above functions and backtracking. Ignore levels *) type class_match_failure = CM_Virtual_class | CM_Parameter_arity_mismatch of int * int | CM_Type_parameter_mismatch of (type_expr * type_expr) list | CM_Class_type_mismatch of class_type * class_type | CM_Parameter_mismatch of (type_expr * type_expr) list | CM_Val_type_mismatch of string * (type_expr * type_expr) list | CM_Meth_type_mismatch of string * (type_expr * type_expr) list | CM_Non_mutable_value of string | CM_Non_concrete_value of string | CM_Missing_value of string | CM_Missing_method of string | CM_Hide_public of string | CM_Hide_virtual of string * string | CM_Public_method of string | CM_Private_method of string | CM_Virtual_method of string val match_class_types: ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list (* Check if the first class type is more general than the second. *) val equal: Env.t -> bool -> type_expr list -> type_expr list -> bool (* [equal env [x1...xn] tau [y1...yn] sigma] checks whether the parameterized types [/\x1.../\xn.tau] and [/\y1.../\yn.sigma] are equivalent. *) val match_class_declarations: Env.t -> type_expr list -> class_type -> type_expr list -> class_type -> class_match_failure list (* Check if the first class type is more general than the second. *) val enlarge_type: Env.t -> type_expr -> type_expr * bool (* Make a type larger, flag is true if some pruning had to be done *) val subtype: Env.t -> type_expr -> type_expr -> unit -> unit (* [subtype env t1 t2] checks that [t1] is a subtype of [t2]. It accumulates the constraints the type variables must enforce and returns a function that inforce this constraints. *) val nondep_type: Env.t -> Ident.t -> type_expr -> type_expr (* Return a type equivalent to the given type but without references to the given module identifier. Raise [Not_found] if no such type exists. *) val nondep_type_decl: Env.t -> Ident.t -> Ident.t -> bool -> type_declaration -> type_declaration (* Same for type declarations. *) val nondep_class_declaration: Env.t -> Ident.t -> class_declaration -> class_declaration (* Same for class declarations. *) val nondep_cltype_declaration: Env.t -> Ident.t -> class_type_declaration -> class_type_declaration (* Same for class type declarations. *) val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit val cyclic_abbrev: Env.t -> Ident.t -> type_expr -> bool val normalize_type: Env.t -> type_expr -> unit val closed_schema: type_expr -> bool (* Check whether the given type scheme contains no non-generic type variables *) val free_variables: ?env:Env.t -> type_expr -> type_expr list (* If env present, then check for incomplete definitions too *) val closed_type_decl: type_declaration -> type_expr option type closed_class_failure = CC_Method of type_expr * bool * string * type_expr | CC_Value of type_expr * bool * string * type_expr val closed_class: type_expr list -> class_signature -> closed_class_failure option (* Check whether all type variables are bound *) val unalias: type_expr -> type_expr val signature_of_class_type: class_type -> class_signature val self_type: class_type -> type_expr val class_type_arity: class_type -> int val arity: type_expr -> int (* Return the arity (as for curried functions) of the given type. *) val collapse_conj_params: Env.t -> type_expr list -> unit (* Collapse conjunctive types in class parameters *) val get_current_level: unit -> int mingw-ocaml/ocaml/typing/ctype.ml0000644000175000017500000042442512124403242016462 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Operations on core types *) open Misc open Asttypes open Types open Btype (* Type manipulation after type inference ====================================== If one wants to manipulate a type after type inference (for instance, during code generation or in the debugger), one must first make sure that the type levels are correct, using the function [correct_levels]. Then, this type can be correctely manipulated by [apply], [expand_head] and [moregeneral]. *) (* General notes ============= - As much sharing as possible should be kept : it makes types smaller and better abbreviated. When necessary, some sharing can be lost. Types will still be printed correctly (+++ TO DO...), and abbreviations defined by a class do not depend on sharing thanks to constrained abbreviations. (Of course, even if some sharing is lost, typing will still be correct.) - All nodes of a type have a level : that way, one know whether a node need to be duplicated or not when instantiating a type. - Levels of a type are decreasing (generic level being considered as greatest). - The level of a type constructor is superior to the binding time of its path. - Recursive types without limitation should be handled (even if there is still an occur check). This avoid treating specially the case for objects, for instance. Furthermore, the occur check policy can then be easily changed. *) (* A faire ======= - Revoir affichage des types. - Etendre la portee d'un alias [... as 'a] a tout le type englobant. - #-type implementes comme de vraies abreviations. - Niveaux plus fins pour les identificateurs : Champ [global] renomme en [level]; Niveau -1 : global 0 : module toplevel 1 : module contenu dans module toplevel ... En fait, incrementer le niveau a chaque fois que l'on rentre dans un module. 3 4 6 \ / / 1 2 5 \|/ 0 [Subst] doit ecreter les niveaux (pour qu'un variable non generalisable dans un module de niveau 2 ne se retrouve pas generalisable lorsque l'on l'utilise au niveau 0). - Traitement de la trace de l'unification separe de la fonction [unify]. *) (**** Errors ****) exception Unify of (type_expr * type_expr) list exception Tags of label * label exception Subtype of (type_expr * type_expr) list * (type_expr * type_expr) list exception Cannot_expand exception Cannot_apply exception Recursive_abbrev (* GADT: recursive abbrevs can appear as a result of local constraints *) exception Unification_recursive_abbrev of (type_expr * type_expr) list (**** Type level management ****) let current_level = ref 0 let nongen_level = ref 0 let global_level = ref 1 let saved_level = ref [] let get_current_level () = !current_level let init_def level = current_level := level; nongen_level := level let begin_def () = saved_level := (!current_level, !nongen_level) :: !saved_level; incr current_level; nongen_level := !current_level let begin_class_def () = saved_level := (!current_level, !nongen_level) :: !saved_level; incr current_level let raise_nongen_level () = saved_level := (!current_level, !nongen_level) :: !saved_level; nongen_level := !current_level let end_def () = let (cl, nl) = List.hd !saved_level in saved_level := List.tl !saved_level; current_level := cl; nongen_level := nl let reset_global_level () = global_level := !current_level + 1 let increase_global_level () = let gl = !global_level in global_level := !current_level; gl let restore_global_level gl = global_level := gl (**** Whether a path points to an object type (with hidden row variable) ****) let is_object_type path = let name = match path with Path.Pident id -> Ident.name id | Path.Pdot(_, s,_) -> s | Path.Papply _ -> assert false in name.[0] = '#' (**** Abbreviations without parameters ****) (* Shall reset after generalizing *) let trace_gadt_instances = ref false let check_trace_gadt_instances env = not !trace_gadt_instances && Env.has_local_constraints env && (trace_gadt_instances := true; cleanup_abbrev (); true) let simple_abbrevs = ref Mnil let proper_abbrevs path tl abbrev = if tl <> [] || !trace_gadt_instances || !Clflags.principal || is_object_type path then abbrev else simple_abbrevs (**** Some type creators ****) (* Re-export generic type creators *) let newty2 = Btype.newty2 let newty desc = newty2 !current_level desc let new_global_ty desc = newty2 !global_level desc let newvar ?name () = newty2 !current_level (Tvar name) let newvar2 ?name level = newty2 level (Tvar name) let new_global_var ?name () = newty2 !global_level (Tvar name) let newobj fields = newty (Tobject (fields, ref None)) let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil)) let none = newty (Ttuple []) (* Clearly ill-formed type *) (**** Representative of a type ****) (* Re-export repr *) let repr = repr (**** Type maps ****) module TypePairs = Hashtbl.Make (struct type t = type_expr * type_expr let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2') let hash (t, t') = t.id + 93 * t'.id end) (**** unification mode ****) type unification_mode = | Expression (* unification in expression *) | Pattern (* unification in pattern which may add local constraints *) let umode = ref Expression let generate_equations = ref false let set_mode mode ?(generate = (mode = Pattern)) f = let old_unification_mode = !umode and old_gen = !generate_equations in try umode := mode; generate_equations := generate; let ret = f () in umode := old_unification_mode; generate_equations := old_gen; ret with e -> umode := old_unification_mode; generate_equations := old_gen; raise e (*** Checks for type definitions ***) let in_current_module = function | Path.Pident _ -> true | Path.Pdot _ | Path.Papply _ -> false let in_pervasives p = try ignore (Env.find_type p Env.initial); true with Not_found -> false let is_datatype decl= match decl.type_kind with Type_record _ | Type_variant _ -> true | Type_abstract -> false (**********************************************) (* Miscellaneous operations on object types *) (**********************************************) (* Note: We need to maintain some invariants: * cty_self must be a Tobject * ... *) (**** Object field manipulation. ****) let object_fields ty = match (repr ty).desc with Tobject (fields, _) -> fields | _ -> assert false let flatten_fields ty = let rec flatten l ty = let ty = repr ty in match ty.desc with Tfield(s, k, ty1, ty2) -> flatten ((s, k, ty1)::l) ty2 | _ -> (l, ty) in let (l, r) = flatten [] ty in (Sort.list (fun (n, _, _) (n', _, _) -> n < n') l, r) let build_fields level = List.fold_right (fun (s, k, ty1) ty2 -> newty2 level (Tfield(s, k, ty1, ty2))) let associate_fields fields1 fields2 = let rec associate p s s' = function (l, []) -> (List.rev p, (List.rev s) @ l, List.rev s') | ([], l') -> (List.rev p, List.rev s, (List.rev s') @ l') | ((n, k, t)::r, (n', k', t')::r') when n = n' -> associate ((n, k, t, k', t')::p) s s' (r, r') | ((n, k, t)::r, ((n', k', t')::_ as l')) when n < n' -> associate p ((n, k, t)::s) s' (r, l') | (((n, k, t)::r as l), (n', k', t')::r') (* when n > n' *) -> associate p s ((n', k', t')::s') (l, r') in associate [] [] [] (fields1, fields2) (**** Check whether an object is open ****) (* +++ Il faudra penser a eventuellement expanser l'abreviation *) let rec object_row ty = let ty = repr ty in match ty.desc with Tobject (t, _) -> object_row t | Tfield(_, _, _, t) -> object_row t | _ -> ty let opened_object ty = match (object_row ty).desc with | Tvar _ | Tunivar _ | Tconstr _ -> true | _ -> false let concrete_object ty = match (object_row ty).desc with | Tvar _ -> false | _ -> true (**** Close an object ****) let close_object ty = let rec close ty = let ty = repr ty in match ty.desc with Tvar _ -> link_type ty (newty2 ty.level Tnil) | Tfield(_, _, _, ty') -> close ty' | _ -> assert false in match (repr ty).desc with Tobject (ty, _) -> close ty | _ -> assert false (**** Row variable of an object type ****) let row_variable ty = let rec find ty = let ty = repr ty in match ty.desc with Tfield (_, _, _, ty) -> find ty | Tvar _ -> ty | _ -> assert false in match (repr ty).desc with Tobject (fi, _) -> find fi | _ -> assert false (**** Object name manipulation ****) (* +++ Bientot obsolete *) let set_object_name id rv params ty = match (repr ty).desc with Tobject (fi, nm) -> set_name nm (Some (Path.Pident id, rv::params)) | _ -> assert false let remove_object_name ty = match (repr ty).desc with Tobject (_, nm) -> set_name nm None | Tconstr (_, _, _) -> () | _ -> fatal_error "Ctype.remove_object_name" (**** Hiding of private methods ****) let hide_private_methods ty = match (repr ty).desc with Tobject (fi, nm) -> nm := None; let (fl, _) = flatten_fields fi in List.iter (function (_, k, _) -> match field_kind_repr k with Fvar r -> set_kind r Fabsent | _ -> ()) fl | _ -> assert false (*******************************) (* Operations on class types *) (*******************************) let rec signature_of_class_type = function Cty_constr (_, _, cty) -> signature_of_class_type cty | Cty_signature sign -> sign | Cty_fun (_, ty, cty) -> signature_of_class_type cty let self_type cty = repr (signature_of_class_type cty).cty_self let rec class_type_arity = function Cty_constr (_, _, cty) -> class_type_arity cty | Cty_signature _ -> 0 | Cty_fun (_, _, cty) -> 1 + class_type_arity cty (*******************************************) (* Miscellaneous operations on row types *) (*******************************************) let sort_row_fields = Sort.list (fun (p,_) (q,_) -> p < q) let rec merge_rf r1 r2 pairs fi1 fi2 = match fi1, fi2 with (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' -> if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else if l1 < l2 then merge_rf (p1::r1) r2 pairs fi1' fi2 else merge_rf r1 (p2::r2) pairs fi1 fi2' | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs) | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs) let merge_row_fields fi1 fi2 = match fi1, fi2 with [], _ | _, [] -> (fi1, fi2, []) | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, []) | _, [p2] when not (List.mem_assoc (fst p2) fi1) -> (fi1, fi2, []) | _ -> merge_rf [] [] [] (sort_row_fields fi1) (sort_row_fields fi2) let rec filter_row_fields erase = function [] -> [] | (l,f as p)::fi -> let fi = filter_row_fields erase fi in match row_field_repr f with Rabsent -> fi | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi | _ -> p :: fi (**************************************) (* Check genericity of type schemes *) (**************************************) exception Non_closed let rec closed_schema_rec ty = let ty = repr ty in if ty.level >= lowest_level then begin let level = ty.level in ty.level <- pivot_level - level; match ty.desc with Tvar _ when level <> generic_level -> raise Non_closed | Tfield(_, kind, t1, t2) -> if field_kind_repr kind = Fpresent then closed_schema_rec t1; closed_schema_rec t2 | Tvariant row -> let row = row_repr row in iter_row closed_schema_rec row; if not (static_row row) then closed_schema_rec row.row_more | _ -> iter_type_expr closed_schema_rec ty end (* Return whether all variables of type [ty] are generic. *) let closed_schema ty = try closed_schema_rec ty; unmark_type ty; true with Non_closed -> unmark_type ty; false exception Non_closed of type_expr * bool let free_variables = ref [] let really_closed = ref None let rec free_vars_rec real ty = let ty = repr ty in if ty.level >= lowest_level then begin ty.level <- pivot_level - ty.level; begin match ty.desc, !really_closed with Tvar _, _ -> free_variables := (ty, real) :: !free_variables | Tconstr (path, tl, _), Some env -> begin try let (_, body, _) = Env.find_type_expansion path env in if (repr body).level <> generic_level then free_variables := (ty, real) :: !free_variables with Not_found -> () end; List.iter (free_vars_rec true) tl (* Do not count "virtual" free variables | Tobject(ty, {contents = Some (_, p)}) -> free_vars_rec false ty; List.iter (free_vars_rec true) p *) | Tobject (ty, _), _ -> free_vars_rec false ty | Tfield (_, _, ty1, ty2), _ -> free_vars_rec true ty1; free_vars_rec false ty2 | Tvariant row, _ -> let row = row_repr row in iter_row (free_vars_rec true) row; if not (static_row row) then free_vars_rec false row.row_more | _ -> iter_type_expr (free_vars_rec true) ty end; end let free_vars ?env ty = free_variables := []; really_closed := env; free_vars_rec true ty; let res = !free_variables in free_variables := []; really_closed := None; res let free_variables ?env ty = let tl = List.map fst (free_vars ?env ty) in unmark_type ty; tl let rec closed_type ty = match free_vars ty with [] -> () | (v, real) :: _ -> raise (Non_closed (v, real)) let closed_parameterized_type params ty = List.iter mark_type params; let ok = try closed_type ty; true with Non_closed _ -> false in List.iter unmark_type params; unmark_type ty; ok let closed_type_decl decl = try List.iter mark_type decl.type_params; begin match decl.type_kind with Type_abstract -> () | Type_variant v -> List.iter (fun (_, tyl,ret_type_opt) -> match ret_type_opt with | Some _ -> () | None -> List.iter closed_type tyl) v | Type_record(r, rep) -> List.iter (fun (_, _, ty) -> closed_type ty) r end; begin match decl.type_manifest with None -> () | Some ty -> closed_type ty end; unmark_type_decl decl; None with Non_closed (ty, _) -> unmark_type_decl decl; Some ty type closed_class_failure = CC_Method of type_expr * bool * string * type_expr | CC_Value of type_expr * bool * string * type_expr exception Failure of closed_class_failure let closed_class params sign = let ty = object_fields (repr sign.cty_self) in let (fields, rest) = flatten_fields ty in List.iter mark_type params; mark_type rest; List.iter (fun (lab, _, ty) -> if lab = dummy_method then mark_type ty) fields; try mark_type_node (repr sign.cty_self); List.iter (fun (lab, kind, ty) -> if field_kind_repr kind = Fpresent then try closed_type ty with Non_closed (ty0, real) -> raise (Failure (CC_Method (ty0, real, lab, ty)))) fields; mark_type_params (repr sign.cty_self); List.iter unmark_type params; unmark_class_signature sign; None with Failure reason -> mark_type_params (repr sign.cty_self); List.iter unmark_type params; unmark_class_signature sign; Some reason (**********************) (* Type duplication *) (**********************) (* Duplicate a type, preserving only type variables *) let duplicate_type ty = Subst.type_expr Subst.identity ty (* Same, for class types *) let duplicate_class_type ty = Subst.class_type Subst.identity ty (*****************************) (* Type level manipulation *) (*****************************) (* It would be a bit more efficient to remove abbreviation expansions rather than generalizing them: these expansions will usually not be used anymore. However, this is not possible in the general case, as [expand_abbrev] (via [subst]) requires these expansions to be preserved. Does it worth duplicating this code ? *) let rec iter_generalize tyl ty = let ty = repr ty in if (ty.level > !current_level) && (ty.level <> generic_level) then begin set_level ty generic_level; begin match ty.desc with Tconstr (_, _, abbrev) -> iter_abbrev (iter_generalize tyl) !abbrev | _ -> () end; iter_type_expr (iter_generalize tyl) ty end else tyl := ty :: !tyl let iter_generalize tyl ty = simple_abbrevs := Mnil; iter_generalize tyl ty let generalize ty = iter_generalize (ref []) ty (* Efficient repeated generalisation of the same type *) let iterative_generalization min_level tyl = let tyl' = ref [] in List.iter (iter_generalize tyl') tyl; List.fold_right (fun ty l -> if ty.level <= min_level then l else ty::l) !tyl' [] (* Generalize the structure and lower the variables *) let rec generalize_structure var_level ty = let ty = repr ty in if ty.level <> generic_level then begin if is_Tvar ty && ty.level > var_level then set_level ty var_level else if ty.level > !current_level && match ty.desc with Tconstr (p, _, abbrev) -> not (is_object_type p) && (abbrev := Mnil; true) | _ -> true then begin set_level ty generic_level; iter_type_expr (generalize_structure var_level) ty end end let generalize_structure var_level ty = simple_abbrevs := Mnil; generalize_structure var_level ty (* Generalize the spine of a function, if the level >= !current_level *) let rec generalize_spine ty = let ty = repr ty in if ty.level < !current_level || ty.level = generic_level then () else match ty.desc with Tarrow (_, ty1, ty2, _) -> set_level ty generic_level; generalize_spine ty1; generalize_spine ty2; | Tpoly (ty', _) -> set_level ty generic_level; generalize_spine ty' | Ttuple tyl | Tpackage (_, _, tyl) -> set_level ty generic_level; List.iter generalize_spine tyl | Tconstr (p, tyl, memo) when not (is_object_type p) -> set_level ty generic_level; memo := Mnil; List.iter generalize_spine tyl | _ -> () let forward_try_expand_once = (* Forward declaration *) ref (fun env ty -> raise Cannot_expand) (* Lower the levels of a type (assume [level] is not [generic_level]). *) (* The level of a type constructor must be greater than its binding time. That way, a type constructor cannot escape the scope of its definition, as would be the case in let x = ref [] module M = struct type t let _ = (x : t list ref) end (without this constraint, the type system would actually be unsound.) *) let get_level env p = try match (Env.find_type p env).type_newtype_level with | None -> Path.binding_time p | Some (x, _) -> x with | Not_found -> (* no newtypes in predef *) Path.binding_time p let rec update_level env level ty = let ty = repr ty in if ty.level > level then begin if Env.has_local_constraints env then begin match Env.gadt_instance_level env ty with Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)]) | None -> () end; match ty.desc with Tconstr(p, tl, abbrev) when level < get_level env p -> (* Try first to replace an abbreviation by its expansion. *) begin try (* if is_newtype env p then raise Cannot_expand; *) link_type ty (!forward_try_expand_once env ty); update_level env level ty with Cannot_expand -> (* +++ Levels should be restored... *) (* Format.printf "update_level: %i < %i@." level (get_level env p); *) if level < get_level env p then raise (Unify [(ty, newvar2 level)]); iter_type_expr (update_level env level) ty end | Tpackage (p, _, _) when level < get_level env p -> raise (Unify [(ty, newvar2 level)]) | Tobject(_, ({contents=Some(p, tl)} as nm)) when level < get_level env p -> set_name nm None; update_level env level ty | Tvariant row -> let row = row_repr row in begin match row.row_name with | Some (p, tl) when level < get_level env p -> log_type ty; ty.desc <- Tvariant {row with row_name = None} | _ -> () end; set_level ty level; iter_type_expr (update_level env level) ty | Tfield(lab, _, ty1, _) when lab = dummy_method && (repr ty1).level > level-> raise (Unify [(ty, newvar2 level)]) | _ -> set_level ty level; (* XXX what about abbreviations in Tconstr ? *) iter_type_expr (update_level env level) ty end (* Generalize and lower levels of contravariant branches simultaneously *) let generalize_contravariant env = if !Clflags.principal then generalize_structure else update_level env let rec generalize_expansive env var_level ty = let ty = repr ty in if ty.level <> generic_level then begin if ty.level > var_level then begin set_level ty generic_level; match ty.desc with Tconstr (path, tyl, abbrev) -> let variance = try (Env.find_type path env).type_variance with Not_found -> List.map (fun _ -> (true,true,true)) tyl in abbrev := Mnil; List.iter2 (fun (co,cn,ct) t -> if ct then generalize_contravariant env var_level t else generalize_expansive env var_level t) variance tyl | Tpackage (_, _, tyl) -> List.iter (generalize_contravariant env var_level) tyl | Tarrow (_, t1, t2, _) -> generalize_contravariant env var_level t1; generalize_expansive env var_level t2 | _ -> iter_type_expr (generalize_expansive env var_level) ty end end let generalize_expansive env ty = simple_abbrevs := Mnil; try generalize_expansive env !nongen_level ty with Unify ([_, ty'] as tr) -> raise (Unify ((ty, ty') :: tr)) let generalize_global ty = generalize_structure !global_level ty let generalize_structure ty = generalize_structure !current_level ty (* Correct the levels of type [ty]. *) let correct_levels ty = duplicate_type ty (* Only generalize the type ty0 in ty *) let limited_generalize ty0 ty = let ty0 = repr ty0 in let graph = Hashtbl.create 17 in let idx = ref lowest_level in let roots = ref [] in let rec inverse pty ty = let ty = repr ty in if (ty.level > !current_level) || (ty.level = generic_level) then begin decr idx; Hashtbl.add graph !idx (ty, ref pty); if (ty.level = generic_level) || (ty == ty0) then roots := ty :: !roots; set_level ty !idx; iter_type_expr (inverse [ty]) ty end else if ty.level < lowest_level then begin let (_, parents) = Hashtbl.find graph ty.level in parents := pty @ !parents end and generalize_parents ty = let idx = ty.level in if idx <> generic_level then begin set_level ty generic_level; List.iter generalize_parents !(snd (Hashtbl.find graph idx)); (* Special case for rows: must generalize the row variable *) match ty.desc with Tvariant row -> let more = row_more row in let lv = more.level in if (lv < lowest_level || lv > !current_level) && lv <> generic_level then set_level more generic_level | _ -> () end in inverse [] ty; if ty0.level < lowest_level then iter_type_expr (inverse []) ty0; List.iter generalize_parents !roots; Hashtbl.iter (fun _ (ty, _) -> if ty.level <> generic_level then set_level ty !current_level) graph (* Compute statically the free univars of all nodes in a type *) (* This avoids doing it repeatedly during instantiation *) type inv_type_expr = { inv_type : type_expr; mutable inv_parents : inv_type_expr list } let rec inv_type hash pty ty = let ty = repr ty in try let inv = TypeHash.find hash ty in inv.inv_parents <- pty @ inv.inv_parents with Not_found -> let inv = { inv_type = ty; inv_parents = pty } in TypeHash.add hash ty inv; iter_type_expr (inv_type hash [inv]) ty let compute_univars ty = let inverted = TypeHash.create 17 in inv_type inverted [] ty; let node_univars = TypeHash.create 17 in let rec add_univar univ inv = match inv.inv_type.desc with Tpoly (ty, tl) when List.memq univ (List.map repr tl) -> () | _ -> try let univs = TypeHash.find node_univars inv.inv_type in if not (TypeSet.mem univ !univs) then begin univs := TypeSet.add univ !univs; List.iter (add_univar univ) inv.inv_parents end with Not_found -> TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ)); List.iter (add_univar univ) inv.inv_parents in TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv) inverted; fun ty -> try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty (*******************) (* Instantiation *) (*******************) let rec find_repr p1 = function Mnil -> None | Mcons (Public, p2, ty, _, _) when Path.same p1 p2 -> Some ty | Mcons (_, _, _, _, rem) -> find_repr p1 rem | Mlink {contents = rem} -> find_repr p1 rem (* Generic nodes are duplicated, while non-generic nodes are left as-is. During instantiation, the description of a generic node is first replaced by a link to a stub ([Tsubst (newvar ())]). Once the copy is made, it replaces the stub. After instantiation, the description of generic node, which was stored by [save_desc], must be put back, using [cleanup_types]. *) let abbreviations = ref (ref Mnil) (* Abbreviation memorized. *) (* partial: we may not wish to copy the non generic types before we call type_pat *) let rec copy ?env ?partial ?keep_names ty = let copy = copy ?env ?partial ?keep_names in let ty = repr ty in match ty.desc with Tsubst ty -> ty | _ -> if ty.level <> generic_level && partial = None then ty else (* We only forget types that are non generic and do not contain free univars *) let forget = if ty.level = generic_level then generic_level else match partial with None -> assert false | Some (free_univars, keep) -> if TypeSet.is_empty (free_univars ty) then if keep then ty.level else !current_level else generic_level in if forget <> generic_level then newty2 forget (Tvar None) else let desc = ty.desc in save_desc ty desc; let t = newvar() in (* Stub *) begin match env with Some env when Env.has_local_constraints env -> begin match Env.gadt_instance_level env ty with Some lv -> Env.add_gadt_instances env lv [t] | None -> () end | _ -> () end; ty.desc <- Tsubst t; t.desc <- begin match desc with | Tconstr (p, tl, _) -> let abbrevs = proper_abbrevs p tl !abbreviations in begin match find_repr p !abbrevs with Some ty when repr ty != t -> (* XXX Commentaire... *) Tlink ty | _ -> (* One must allocate a new reference, so that abbrevia- tions belonging to different branches of a type are independent. Moreover, a reference containing a [Mcons] must be shared, so that the memorized expansion of an abbrevi- ation can be released by changing the content of just one reference. *) Tconstr (p, List.map copy tl, ref (match !(!abbreviations) with Mcons _ -> Mlink !abbreviations | abbrev -> abbrev)) end | Tvariant row0 -> let row = row_repr row0 in let more = repr row.row_more in (* We must substitute in a subtle way *) (* Tsubst takes a tuple containing the row var and the variant *) begin match more.desc with Tsubst {desc = Ttuple [_;ty2]} -> (* This variant type has been already copied *) ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *) Tlink ty2 | _ -> (* If the row variable is not generic, we must keep it *) let keep = more.level <> generic_level in let more' = match more.desc with Tsubst ty -> ty | Tconstr _ | Tnil -> if keep then save_desc more more.desc; copy more | Tvar _ | Tunivar _ -> save_desc more more.desc; if keep then more else newty more.desc | _ -> assert false in (* Register new type first for recursion *) more.desc <- Tsubst(newgenty(Ttuple[more';t])); (* Return a new copy *) Tvariant (copy_row copy true row keep more') end | Tfield (p, k, ty1, ty2) -> begin match field_kind_repr k with Fabsent -> Tlink (copy ty2) | Fpresent -> copy_type_desc copy desc | Fvar r -> dup_kind r; copy_type_desc copy desc end | Tobject (ty1, _) when partial <> None -> Tobject (copy ty1, ref None) | _ -> copy_type_desc ?keep_names copy desc end; t (**** Variants of instantiations ****) let gadt_env env = if Env.has_local_constraints env then Some env else None let instance ?partial env sch = let env = gadt_env env in let partial = match partial with None -> None | Some keep -> Some (compute_univars sch, keep) in let ty = copy ?env ?partial sch in cleanup_types (); ty let instance_def sch = let ty = copy sch in cleanup_types (); ty let instance_list env schl = let env = gadt_env env in let tyl = List.map (copy ?env) schl in cleanup_types (); tyl let reified_var_counter = ref Vars.empty (* names given to new type constructors. Used for existential types and local constraints *) let get_new_abstract_name s = let index = try Vars.find s !reified_var_counter + 1 with Not_found -> 0 in reified_var_counter := Vars.add s index !reified_var_counter; Printf.sprintf "%s#%d" s index let new_declaration newtype manifest = { type_params = []; type_arity = 0; type_kind = Type_abstract; type_private = Public; type_manifest = manifest; type_variance = []; type_newtype_level = newtype; type_loc = Location.none; } let instance_constructor ?in_pattern cstr = let ty_res = copy cstr.cstr_res in let ty_args = List.map copy cstr.cstr_args in begin match in_pattern with | None -> () | Some (env, newtype_lev) -> let process existential = let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in let name = match repr existential with {desc = Tvar (Some name)} -> name | _ -> "ex" in let (id, new_env) = Env.enter_type (get_new_abstract_name name) decl !env in env := new_env; let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in link_type (copy existential) to_unify in List.iter process cstr.cstr_existentials end; cleanup_types (); (ty_args, ty_res) let instance_parameterized_type ?keep_names sch_args sch = let ty_args = List.map (copy ?keep_names) sch_args in let ty = copy sch in cleanup_types (); (ty_args, ty) let instance_parameterized_type_2 sch_args sch_lst sch = let ty_args = List.map copy sch_args in let ty_lst = List.map copy sch_lst in let ty = copy sch in cleanup_types (); (ty_args, ty_lst, ty) let instance_declaration decl = let decl = {decl with type_params = List.map copy decl.type_params; type_manifest = may_map copy decl.type_manifest; type_kind = match decl.type_kind with | Type_abstract -> Type_abstract | Type_variant cl -> Type_variant ( List.map (fun (s,tl,ot) -> (s, List.map copy tl, may_map copy ot)) cl) | Type_record (fl, rr) -> Type_record (List.map (fun (s,m,ty) -> (s, m, copy ty)) fl, rr)} in cleanup_types (); decl let instance_class params cty = let rec copy_class_type = function Cty_constr (path, tyl, cty) -> Cty_constr (path, List.map copy tyl, copy_class_type cty) | Cty_signature sign -> Cty_signature {cty_self = copy sign.cty_self; cty_vars = Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.cty_vars; cty_concr = sign.cty_concr; cty_inher = List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher} | Cty_fun (l, ty, cty) -> Cty_fun (l, copy ty, copy_class_type cty) in let params' = List.map copy params in let cty' = copy_class_type cty in cleanup_types (); (params', cty') (**** Instanciation for types with free universal variables ****) let rec diff_list l1 l2 = if l1 == l2 then [] else match l1 with [] -> invalid_arg "Ctype.diff_list" | a :: l1 -> a :: diff_list l1 l2 let conflicts free bound = let bound = List.map repr bound in TypeSet.exists (fun t -> List.memq (repr t) bound) free let delayed_copy = ref [] (* copying to do later *) (* Copy without sharing until there are no free univars left *) (* all free univars must be included in [visited] *) let rec copy_sep fixed free bound visited ty = let ty = repr ty in let univars = free ty in if TypeSet.is_empty univars then if ty.level <> generic_level then ty else let t = newvar () in delayed_copy := lazy (t.desc <- Tlink (copy ty)) :: !delayed_copy; t else try let t, bound_t = List.assq ty visited in let dl = if is_Tunivar ty then [] else diff_list bound bound_t in if dl <> [] && conflicts univars dl then raise Not_found; t with Not_found -> begin let t = newvar() in (* Stub *) let visited = match ty.desc with Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ -> (ty,(t,bound)) :: visited | _ -> visited in let copy_rec = copy_sep fixed free bound visited in t.desc <- begin match ty.desc with | Tvariant row0 -> let row = row_repr row0 in let more = repr row.row_more in (* We shall really check the level on the row variable *) let keep = is_Tvar more && more.level <> generic_level in let more' = copy_rec more in let fixed' = fixed && is_Tvar (repr more') in let row = copy_row copy_rec fixed' row keep more' in Tvariant row | Tpoly (t1, tl) -> let tl = List.map repr tl in let tl' = List.map (fun t -> newty t.desc) tl in let bound = tl @ bound in let visited = List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in Tpoly (copy_sep fixed free bound visited t1, tl') | _ -> copy_type_desc copy_rec ty.desc end; t end let instance_poly ?(keep_names=false) fixed univars sch = let univars = List.map repr univars in let copy_var ty = match ty.desc with Tunivar name -> if keep_names then newty (Tvar name) else newvar () | _ -> assert false in let vars = List.map copy_var univars in let pairs = List.map2 (fun u v -> u, (v, [])) univars vars in delayed_copy := []; let ty = copy_sep fixed (compute_univars sch) [] pairs sch in List.iter Lazy.force !delayed_copy; delayed_copy := []; cleanup_types (); vars, ty let instance_label fixed lbl = let ty_res = copy lbl.lbl_res in let vars, ty_arg = match repr lbl.lbl_arg with {desc = Tpoly (ty, tl)} -> instance_poly fixed tl ty | ty -> [], copy lbl.lbl_arg in cleanup_types (); (vars, ty_arg, ty_res) (**** Instantiation with parameter substitution ****) let unify' = (* Forward declaration *) ref (fun env ty1 ty2 -> raise (Unify [])) let rec subst env level priv abbrev ty params args body = if List.length params <> List.length args then raise (Unify []); let old_level = !current_level in current_level := level; try let body0 = newvar () in (* Stub *) begin match ty with None -> () | Some ({desc = Tconstr (path, tl, _)} as ty) -> let abbrev = proper_abbrevs path tl abbrev in memorize_abbrev abbrev priv path ty body0 | _ -> assert false end; abbreviations := abbrev; let (params', body') = instance_parameterized_type params body in abbreviations := ref Mnil; !unify' env body0 body'; List.iter2 (!unify' env) params' args; current_level := old_level; body' with Unify _ as exn -> current_level := old_level; raise exn (* Only the shape of the type matters, not whether is is generic or not. [generic_level] might be somewhat slower, but it ensures invariants on types are enforced (decreasing levels.), and we don't care about efficiency here. *) let apply env params body args = try subst env generic_level Public (ref Mnil) None params args body with Unify _ -> raise Cannot_apply (****************************) (* Abbreviation expansion *) (****************************) (* If the environnement has changed, memorized expansions might not be correct anymore, and so we flush the cache. This is safe but quite pessimistic: it would be enough to flush the cache when a type or module definition is overridden in the environnement. *) let previous_env = ref Env.empty let string_of_kind = function Public -> "public" | Private -> "private" let check_abbrev_env env = if env != !previous_env then begin (* prerr_endline "cleanup expansion cache"; *) cleanup_abbrev (); previous_env := env end (* Expand an abbreviation. The expansion is memorized. *) (* Assume the level is greater than the path binding time of the expanded abbreviation. *) (* An abbreviation expansion will fail in either of these cases: 1. The type constructor does not correspond to a manifest type. 2. The type constructor is defined in an external file, and this file is not in the path (missing -I options). 3. The type constructor is not in the "local" environment. This can happens when a non-generic type variable has been instantiated afterwards to the not yet defined type constructor. (Actually, this cannot happen at the moment due to the strong constraints between type levels and constructor binding time.) 4. The expansion requires the expansion of another abbreviation, and this other expansion fails. *) let expand_abbrev_gen kind find_type_expansion env ty = check_abbrev_env env; match ty with {desc = Tconstr (path, args, abbrev); level = level} -> let lookup_abbrev = proper_abbrevs path args abbrev in begin match find_expans kind path !lookup_abbrev with Some ty -> (* prerr_endline ("found a "^string_of_kind kind^" expansion for "^Path.name path);*) if level <> generic_level then begin try update_level env level ty with Unify _ -> (* XXX This should not happen. However, levels are not correctly restored after a typing error *) () end; ty | None -> let (params, body, lv) = try find_type_expansion level path env with Not_found -> raise Cannot_expand in (* prerr_endline ("add a "^string_of_kind kind^" expansion for "^Path.name path);*) let ty' = subst env level kind abbrev (Some ty) params args body in (* Hack to name the variant type *) begin match repr ty' with {desc=Tvariant row} as ty when static_row row -> ty.desc <- Tvariant { row with row_name = Some (path, args) } | _ -> () end; (* For gadts, remember type as non exportable *) if !trace_gadt_instances then begin match lv with Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)]); Env.add_gadt_instances env lv [ty; ty'] | None -> match Env.gadt_instance_level env ty with Some lv -> Env.add_gadt_instances env lv [ty'] | None -> () end; ty' end | _ -> assert false (* inside objects and variants we do not want to use local constraints *) let expand_abbrev ty = expand_abbrev_gen Public (fun level -> Env.find_type_expansion ~level) ty let safe_abbrev env ty = let snap = Btype.snapshot () in try ignore (expand_abbrev env ty); true with Cannot_expand | Unify _ -> Btype.backtrack snap; false let try_expand_once env ty = let ty = repr ty in match ty.desc with Tconstr (p, _, _) -> repr (expand_abbrev env ty) | _ -> raise Cannot_expand let _ = forward_try_expand_once := try_expand_once (* Fully expand the head of a type. Raise Cannot_expand if the type cannot be expanded. May raise Unify, if a recursion was hidden in the type. *) let rec try_expand_head env ty = let ty' = try_expand_once env ty in let ty'' = try try_expand_head env ty' with Cannot_expand -> ty' in if Env.has_local_constraints env then begin match Env.gadt_instance_level env ty'' with None -> () | Some lv -> Env.add_gadt_instance_chain env lv ty end; ty'' (* Expand once the head of a type *) let expand_head_once env ty = try expand_abbrev env (repr ty) with Cannot_expand -> assert false (* Fully expand the head of a type. *) let expand_head_unif env ty = try try_expand_head env ty with Cannot_expand -> repr ty let expand_head env ty = let snap = Btype.snapshot () in try try_expand_head env ty with Cannot_expand | Unify _ -> (* expand_head shall never fail *) Btype.backtrack snap; repr ty (* Implementing function [expand_head_opt], the compiler's own version of [expand_head] used for type-based optimisations. [expand_head_opt] uses [Env.find_type_expansion_opt] to access the manifest type information of private abstract data types which is normally hidden to the type-checker out of the implementation module of the private abbreviation. *) let expand_abbrev_opt = expand_abbrev_gen Private (fun level -> Env.find_type_expansion_opt) let try_expand_once_opt env ty = let ty = repr ty in match ty.desc with Tconstr _ -> repr (expand_abbrev_opt env ty) | _ -> raise Cannot_expand let rec try_expand_head_opt env ty = let ty' = try_expand_once_opt env ty in begin try try_expand_head_opt env ty' with Cannot_expand -> ty' end let expand_head_opt env ty = let snap = Btype.snapshot () in try try_expand_head_opt env ty with Cannot_expand | Unify _ -> (* expand_head shall never fail *) Btype.backtrack snap; repr ty (* Make sure that the type parameters of the type constructor [ty] respect the type constraints *) let enforce_constraints env ty = match ty with {desc = Tconstr (path, args, abbrev); level = level} -> begin try let decl = Env.find_type path env in ignore (subst env level Public (ref Mnil) None decl.type_params args (newvar2 level)) with Not_found -> () end | _ -> assert false (* Recursively expand the head of a type. Also expand #-types. *) let rec full_expand env ty = let ty = repr (expand_head env ty) in match ty.desc with Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) -> newty2 ty.level (Tobject (fi, ref None)) | _ -> ty (* Check whether the abbreviation expands to a well-defined type. During the typing of a class, abbreviations for correspondings types expand to non-generic types. *) let generic_abbrev env path = try let (_, body, _) = Env.find_type_expansion path env in (repr body).level = generic_level with Not_found -> false (*****************) (* Occur check *) (*****************) exception Occur (* The marks are already used by [expand_abbrev]... *) let visited = ref [] let rec non_recursive_abbrev env ty0 ty = let ty = repr ty in if ty == repr ty0 then raise Recursive_abbrev; if not (List.memq ty !visited) then begin visited := ty :: !visited; match ty.desc with Tconstr(p, args, abbrev) -> begin try non_recursive_abbrev env ty0 (try_expand_once_opt env ty) with Cannot_expand -> if !Clflags.recursive_types && (in_current_module p || in_pervasives p || try is_datatype (Env.find_type p env) with Not_found -> false) then () else iter_type_expr (non_recursive_abbrev env ty0) ty end | Tobject _ | Tvariant _ -> () | _ -> if !Clflags.recursive_types then () else iter_type_expr (non_recursive_abbrev env ty0) ty end let correct_abbrev env path params ty = check_abbrev_env env; let ty0 = newgenvar () in visited := []; let abbrev = Mcons (Public, path, ty0, ty0, Mnil) in simple_abbrevs := abbrev; try non_recursive_abbrev env ty0 (subst env generic_level Public (ref abbrev) None [] [] ty); simple_abbrevs := Mnil; visited := [] with exn -> simple_abbrevs := Mnil; visited := []; raise exn let rec occur_rec env visited ty0 ty = if ty == ty0 then raise Occur; match ty.desc with Tconstr(p, tl, abbrev) -> begin try if List.memq ty visited || !Clflags.recursive_types then raise Occur; iter_type_expr (occur_rec env (ty::visited) ty0) ty with Occur -> try let ty' = try_expand_head env ty in (* Maybe we could simply make a recursive call here, but it seems it could make the occur check loop (see change in rev. 1.58) *) if ty' == ty0 || List.memq ty' visited then raise Occur; match ty'.desc with Tobject _ | Tvariant _ -> () | _ -> if not !Clflags.recursive_types then iter_type_expr (occur_rec env (ty'::visited) ty0) ty' with Cannot_expand -> if not !Clflags.recursive_types then raise Occur end | Tobject _ | Tvariant _ -> () | _ -> if not !Clflags.recursive_types then iter_type_expr (occur_rec env visited ty0) ty let type_changed = ref false (* trace possible changes to the studied type *) let merge r b = if b then r := true let occur env ty0 ty = let old = !type_changed in try while type_changed := false; occur_rec env [] ty0 ty; !type_changed do () (* prerr_endline "changed" *) done; merge type_changed old with exn -> merge type_changed old; raise (match exn with Occur -> Unify [] | _ -> exn) let occur_in env ty0 t = try occur env ty0 t; false with Unify _ -> true (* checks that a local constraint is non recursive *) let rec local_non_recursive_abbrev visited env p ty = let ty = repr ty in if not (List.memq ty !visited) then begin visited := ty :: !visited; match ty.desc with Tconstr(p', args, abbrev) -> if Path.same p p' then raise Recursive_abbrev; begin try local_non_recursive_abbrev visited env p (try_expand_once_opt env ty) with Cannot_expand -> if !Clflags.recursive_types then () else iter_type_expr (local_non_recursive_abbrev visited env p) ty end | Tobject _ | Tvariant _ -> () | _ -> if !Clflags.recursive_types then () else iter_type_expr (local_non_recursive_abbrev visited env p) ty end let local_non_recursive_abbrev = local_non_recursive_abbrev (ref []) (*****************************) (* Polymorphic Unification *) (*****************************) (* Since we cannot duplicate universal variables, unification must be done at meta-level, using bindings in univar_pairs *) let rec unify_univar t1 t2 = function (cl1, cl2) :: rem -> let find_univ t cl = try let (_, r) = List.find (fun (t',_) -> t == repr t') cl in Some r with Not_found -> None in begin match find_univ t1 cl1, find_univ t2 cl2 with Some {contents=Some t'2}, Some _ when t2 == repr t'2 -> () | Some({contents=None} as r1), Some({contents=None} as r2) -> set_univar r1 t2; set_univar r2 t1 | None, None -> unify_univar t1 t2 rem | _ -> raise (Unify []) end | [] -> raise (Unify []) (* Test the occurence of free univars in a type *) (* that's way too expansive. Must do some kind of cacheing *) let occur_univar env ty = let visited = ref TypeMap.empty in let rec occur_rec bound ty = let ty = repr ty in if ty.level >= lowest_level && if TypeSet.is_empty bound then (ty.level <- pivot_level - ty.level; true) else try let bound' = TypeMap.find ty !visited in if TypeSet.exists (fun x -> not (TypeSet.mem x bound)) bound' then (visited := TypeMap.add ty (TypeSet.inter bound bound') !visited; true) else false with Not_found -> visited := TypeMap.add ty bound !visited; true then match ty.desc with Tunivar _ -> if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar ()]) | Tpoly (ty, tyl) -> let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in occur_rec bound ty | Tconstr (_, [], _) -> () | Tconstr (p, tl, _) -> begin try let td = Env.find_type p env in List.iter2 (fun t (pos,neg,_) -> if pos || neg then occur_rec bound t) tl td.type_variance with Not_found -> List.iter (occur_rec bound) tl end | _ -> iter_type_expr (occur_rec bound) ty in try occur_rec TypeSet.empty ty; unmark_type ty with exn -> unmark_type ty; raise exn (* Grouping univars by families according to their binders *) let add_univars = List.fold_left (fun s (t,_) -> TypeSet.add (repr t) s) let get_univar_family univar_pairs univars = if univars = [] then TypeSet.empty else let rec insert s = function cl1, (_::_ as cl2) -> if List.exists (fun (t1,_) -> TypeSet.mem (repr t1) s) cl1 then add_univars s cl2 else s | _ -> s in let s = List.fold_right TypeSet.add univars TypeSet.empty in List.fold_left insert s univar_pairs (* Whether a family of univars escapes from a type *) let univars_escape env univar_pairs vl ty = let family = get_univar_family univar_pairs vl in let visited = ref TypeSet.empty in let rec occur t = let t = repr t in if TypeSet.mem t !visited then () else begin visited := TypeSet.add t !visited; match t.desc with Tpoly (t, tl) -> if List.exists (fun t -> TypeSet.mem (repr t) family) tl then () else occur t | Tunivar _ -> if TypeSet.mem t family then raise Occur | Tconstr (_, [], _) -> () | Tconstr (p, tl, _) -> begin try let td = Env.find_type p env in List.iter2 (fun t (pos,neg,_) -> if pos || neg then occur t) tl td.type_variance with Not_found -> List.iter occur tl end | _ -> iter_type_expr occur t end in try occur ty; false with Occur -> true (* Wrapper checking that no variable escapes and updating univar_pairs *) let enter_poly env univar_pairs t1 tl1 t2 tl2 f = let old_univars = !univar_pairs in let known_univars = List.fold_left (fun s (cl,_) -> add_univars s cl) TypeSet.empty old_univars in let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in if List.exists (fun t -> TypeSet.mem t known_univars) tl1 && univars_escape env old_univars tl1 (newty(Tpoly(t2,tl2))) || List.exists (fun t -> TypeSet.mem t known_univars) tl2 && univars_escape env old_univars tl2 (newty(Tpoly(t1,tl1))) then raise (Unify []); let cl1 = List.map (fun t -> t, ref None) tl1 and cl2 = List.map (fun t -> t, ref None) tl2 in univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars; try let res = f t1 t2 in univar_pairs := old_univars; res with exn -> univar_pairs := old_univars; raise exn let univar_pairs = ref [] (*****************) (* Unification *) (*****************) let rec has_cached_expansion p abbrev = match abbrev with Mnil -> false | Mcons(_, p', _, _, rem) -> Path.same p p' || has_cached_expansion p rem | Mlink rem -> has_cached_expansion p !rem (**** Transform error trace ****) (* +++ Move it to some other place ? *) let expand_trace env trace = List.fold_right (fun (t1, t2) rem -> (repr t1, full_expand env t1)::(repr t2, full_expand env t2)::rem) trace [] (* build a dummy variant type *) let mkvariant fields closed = newgenty (Tvariant {row_fields = fields; row_closed = closed; row_more = newvar(); row_bound = (); row_fixed = false; row_name = None }) (* force unification in Reither when one side has as non-conjunctive type *) let rigid_variants = ref false (**** Unification ****) (* Return whether [t0] occurs in [ty]. Objects are also traversed. *) let deep_occur t0 ty = let rec occur_rec ty = let ty = repr ty in if ty.level >= lowest_level then begin if ty == t0 then raise Occur; ty.level <- pivot_level - ty.level; iter_type_expr occur_rec ty end in try occur_rec ty; unmark_type ty; false with Occur -> unmark_type ty; true (* 1. When unifying two non-abbreviated types, one type is made a link to the other. When unifying an abbreviated type with a non-abbreviated type, the non-abbreviated type is made a link to the other one. When unifying to abbreviated types, these two types are kept distincts, but they are made to (temporally) expand to the same type. 2. Abbreviations with at least one parameter are systematically expanded. The overhead does not seem to high, and that way abbreviations where some parameters does not appear in the expansion, such as ['a t = int], are correctly handled. In particular, for this example, unifying ['a t] with ['b t] keeps ['a] and ['b] distincts. (Is it really important ?) 3. Unifying an abbreviation ['a t = 'a] with ['a] should not yield ['a t as 'a]. Indeed, the type variable would otherwise be lost. This problem occurs for abbreviations expanding to a type variable, but also to many other constrained abbreviations (for instance, [(< x : 'a > -> unit) t = ]). The solution is that, if an abbreviation is unified with some subpart of its parameters, then the parameter actually does not get abbreviated. It would be possible to check whether some information is indeed lost, but it probably does not worth it. *) let newtype_level = ref None let get_newtype_level () = match !newtype_level with | None -> assert false | Some x -> x (* a local constraint can be added only if the rhs of the constraint does not contain any Tvars. They need to be removed using this function *) let reify env t = let newtype_level = get_newtype_level () in let create_fresh_constr lev name = let decl = new_declaration (Some (newtype_level, newtype_level)) None in let name = get_new_abstract_name name in let (id, new_env) = Env.enter_type name decl !env in let t = newty2 lev (Tconstr (Path.Pident id,[],ref Mnil)) in env := new_env; t in let visited = ref TypeSet.empty in let rec iterator ty = let ty = repr ty in if TypeSet.mem ty !visited then () else begin visited := TypeSet.add ty !visited; match ty.desc with Tvar o -> let name = match o with Some s -> s | _ -> "ex" in let t = create_fresh_constr ty.level name in link_type ty t | Tvariant r -> if not (static_row r) then iterator (row_more r); iter_row iterator r | Tconstr (p, _, _) when is_object_type p -> iter_type_expr iterator (full_expand !env ty) | _ -> iter_type_expr iterator ty end in iterator t let is_abstract_newtype env p = try let decl = Env.find_type p env in not (decl.type_newtype_level = None) && decl.type_manifest = None && decl.type_kind = Type_abstract with Not_found -> false (* mcomp type_pairs subst env t1 t2 does not raise an exception if it is possible that t1 and t2 are actually equal, assuming the types in type_pairs are equal and that the mapping subst holds. Assumes that both t1 and t2 do not contain any tvars and that both their objects and variants are closed *) let rec mcomp type_pairs subst env t1 t2 = if t1 == t2 then () else let t1 = repr t1 in let t2 = repr t2 in if t1 == t2 then () else match (t1.desc, t2.desc) with | (Tvar _, _) | (_, Tvar _) -> fatal_error "types should not include variables" | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> () | _ -> let t1' = expand_head_opt env t1 in let t2' = expand_head_opt env t2 in (* Expansion may have changed the representative of the types... *) let t1' = repr t1' and t2' = repr t2' in if t1' == t2' then () else begin try TypePairs.find type_pairs (t1', t2') with Not_found -> TypePairs.add type_pairs (t1', t2') (); match (t1'.desc, t2'.desc) with (Tvar _, Tvar _) -> assert false | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 || not (is_optional l1 || is_optional l2) -> mcomp type_pairs subst env t1 t2; mcomp type_pairs subst env u1 u2; | (Ttuple tl1, Ttuple tl2) -> mcomp_list type_pairs subst env tl1 tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) -> mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when Path.same p1 p2 && n1 = n2 -> mcomp_list type_pairs subst env tl1 tl2 | (Tvariant row1, Tvariant row2) -> mcomp_row type_pairs subst env row1 row2 | (Tobject (fi1, _), Tobject (fi2, _)) -> mcomp_fields type_pairs subst env fi1 fi2 | (Tfield _, Tfield _) -> (* Actually unused *) mcomp_fields type_pairs subst env t1' t2' | (Tnil, Tnil) -> () | (Tpoly (t1, []), Tpoly (t2, [])) -> mcomp type_pairs subst env t1 t2 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> enter_poly env univar_pairs t1 tl1 t2 tl2 (mcomp type_pairs subst env) | (Tunivar _, Tunivar _) -> unify_univar t1' t2' !univar_pairs | (_, _) -> raise (Unify []) end and mcomp_list type_pairs subst env tl1 tl2 = if List.length tl1 <> List.length tl2 then raise (Unify []); List.iter2 (mcomp type_pairs subst env) tl1 tl2 and mcomp_fields type_pairs subst env ty1 ty2 = if not (concrete_object ty1 && concrete_object ty2) then assert false; let (fields2, rest2) = flatten_fields ty2 in let (fields1, rest1) = flatten_fields ty1 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in mcomp type_pairs subst env rest1 rest2; if miss1 <> [] && (object_row ty1).desc = Tnil || miss2 <> [] && (object_row ty2).desc = Tnil then raise (Unify []); List.iter (function (n, k1, t1, k2, t2) -> mcomp_kind k1 k2; mcomp type_pairs subst env t1 t2) pairs and mcomp_kind k1 k2 = let k1 = field_kind_repr k1 in let k2 = field_kind_repr k2 in match k1, k2 with (Fvar _, Fvar _) | (Fpresent, Fpresent) -> () | _ -> raise (Unify []) and mcomp_row type_pairs subst env row1 row2 = let row1 = row_repr row1 and row2 = row_repr row2 in let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in let cannot_erase (_,f) = match row_field_repr f with Rpresent _ -> true | Rabsent | Reither _ -> false in if row1.row_closed && List.exists cannot_erase r2 || row2.row_closed && List.exists cannot_erase r1 then raise (Unify []); List.iter (fun (_,f1,f2) -> match row_field_repr f1, row_field_repr f2 with | Rpresent None, (Rpresent (Some _) | Reither (_, _::_, _, _) | Rabsent) | Rpresent (Some _), (Rpresent None | Reither (true, _, _, _) | Rabsent) | (Reither (_, _::_, _, _) | Rabsent), Rpresent None | (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) -> raise (Unify []) | Rpresent(Some t1), Rpresent(Some t2) -> mcomp type_pairs subst env t1 t2 | Rpresent(Some t1), Reither(false, tl2, _, _) -> List.iter (mcomp type_pairs subst env t1) tl2 | Reither(false, tl1, _, _), Rpresent(Some t2) -> List.iter (mcomp type_pairs subst env t2) tl1 | _ -> ()) pairs and mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 = let non_aliased p decl = in_pervasives p || in_current_module p && decl.type_newtype_level = None in try let decl = Env.find_type p1 env in let decl' = Env.find_type p2 env in if Path.same p1 p2 then (if non_aliased p1 decl then mcomp_list type_pairs subst env tl1 tl2) else match decl.type_kind, decl'.type_kind with | Type_record (lst,r), Type_record (lst',r') when r = r' -> mcomp_list type_pairs subst env tl1 tl2; mcomp_record_description type_pairs subst env lst lst' | Type_variant v1, Type_variant v2 -> mcomp_list type_pairs subst env tl1 tl2; mcomp_variant_description type_pairs subst env v1 v2 | Type_variant _, Type_record _ | Type_record _, Type_variant _ -> raise (Unify []) | _ -> if non_aliased p1 decl && (non_aliased p2 decl' || is_datatype decl') || is_datatype decl && non_aliased p2 decl' then raise (Unify []) with Not_found -> () and mcomp_type_option type_pairs subst env t t' = match t, t' with None, None -> () | Some t, Some t' -> mcomp type_pairs subst env t t' | _ -> raise (Unify []) and mcomp_variant_description type_pairs subst env = let rec iter = fun x y -> match x, y with (name,mflag,t) :: xs, (name', mflag', t') :: ys -> mcomp_type_option type_pairs subst env t t'; if name = name' && mflag = mflag' then iter xs ys else raise (Unify []) | [],[] -> () | _ -> raise (Unify []) in iter and mcomp_record_description type_pairs subst env = let rec iter = fun x y -> match x, y with (name, mutable_flag, t) :: xs, (name', mutable_flag', t') :: ys -> mcomp type_pairs subst env t t'; if name = name' && mutable_flag = mutable_flag' then iter xs ys else raise (Unify []) | [], [] -> () | _ -> raise (Unify []) in iter let mcomp env t1 t2 = mcomp (TypePairs.create 4) () env t1 t2 (* Real unification *) let find_lowest_level ty = let lowest = ref generic_level in let rec find ty = let ty = repr ty in if ty.level >= lowest_level then begin if ty.level < !lowest then lowest := ty.level; ty.level <- pivot_level - ty.level; iter_type_expr find ty end in find ty; unmark_type ty; !lowest let find_newtype_level env path = try match (Env.find_type path env).type_newtype_level with Some x -> x | None -> assert false with Not_found -> assert false let add_gadt_equation env source destination = let destination = duplicate_type destination in let source_lev = find_newtype_level !env (Path.Pident source) in let decl = new_declaration (Some source_lev) (Some destination) in let newtype_level = get_newtype_level () in env := Env.add_local_constraint source decl newtype_level !env; cleanup_abbrev () let unify_eq_set = TypePairs.create 11 let order_type_pair t1 t2 = if t1.id <= t2.id then (t1, t2) else (t2, t1) let add_type_equality t1 t2 = TypePairs.add unify_eq_set (order_type_pair t1 t2) () let unify_eq env t1 t2 = t1 == t2 || match !umode with | Expression -> false | Pattern -> try TypePairs.find unify_eq_set (order_type_pair t1 t2); true with Not_found -> false let rec unify (env:Env.t ref) t1 t2 = (* First step: special cases (optimizations) *) if unify_eq !env t1 t2 then () else let t1 = repr t1 in let t2 = repr t2 in if unify_eq !env t1 t2 then () else let reset_tracing = check_trace_gadt_instances !env in try type_changed := true; begin match (t1.desc, t2.desc) with (Tvar _, Tconstr _) when deep_occur t1 t2 -> unify2 env t1 t2 | (Tconstr _, Tvar _) when deep_occur t2 t1 -> unify2 env t1 t2 | (Tvar _, _) -> occur !env t1 t2; occur_univar !env t2; link_type t1 t2; update_level !env t1.level t2 | (_, Tvar _) -> occur !env t2 t1; occur_univar !env t1; link_type t2 t1; update_level !env t2.level t1 | (Tunivar _, Tunivar _) -> unify_univar t1 t2 !univar_pairs; update_level !env t1.level t2; link_type t1 t2 | (Tconstr (p1, [], a1), Tconstr (p2, [], a2)) when Path.same p1 p2 (* && actual_mode !env = Old *) (* This optimization assumes that t1 does not expand to t2 (and conversely), so we fall back to the general case when any of the types has a cached expansion. *) && not (has_cached_expansion p1 !a1 || has_cached_expansion p2 !a2) -> update_level !env t1.level t2; link_type t1 t2 | _ -> unify2 env t1 t2 end; if reset_tracing then trace_gadt_instances := false; with Unify trace -> if reset_tracing then trace_gadt_instances := false; raise (Unify ((t1, t2)::trace)) and unify2 env t1 t2 = (* Second step: expansion of abbreviations *) let rec expand_both t1'' t2'' = let t1' = expand_head_unif !env t1 in let t2' = expand_head_unif !env t2 in (* Expansion may have changed the representative of the types... *) if unify_eq !env t1' t1'' && unify_eq !env t2' t2'' then (t1',t2') else expand_both t1' t2' in let t1', t2' = expand_both t1 t2 in let lv = min t1'.level t2'.level in update_level !env lv t2; update_level !env lv t1; if unify_eq !env t1' t2' then () else let t1 = repr t1 and t2 = repr t2 in if !trace_gadt_instances then begin match Env.gadt_instance_level !env t1',Env.gadt_instance_level !env t2' with Some lv1, Some lv2 -> if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else if lv2 > lv2 then Env.add_gadt_instance_chain !env lv2 t1 | Some lv1, None -> Env.add_gadt_instance_chain !env lv1 t2 | None, Some lv2 -> Env.add_gadt_instance_chain !env lv2 t1 | None, None -> () end; let t1, t2 = if !Clflags.principal && (find_lowest_level t1' < lv || find_lowest_level t2' < lv) then (* Expand abbreviations hiding a lower level *) (* Should also do it for parameterized types, after unification... *) (match t1.desc with Tconstr (_, [], _) -> t1' | _ -> t1), (match t2.desc with Tconstr (_, [], _) -> t2' | _ -> t2) else (t1, t2) in if unify_eq !env t1 t1' || not (unify_eq !env t2 t2') then unify3 env t1 t1' t2 t2' else try unify3 env t2 t2' t1 t1' with Unify trace -> raise (Unify (List.map (fun (x, y) -> (y, x)) trace)) and unify3 env t1 t1' t2 t2' = (* Third step: truly unification *) (* Assumes either [t1 == t1'] or [t2 != t2'] *) let d1 = t1'.desc and d2 = t2'.desc in let create_recursion = (t2 != t2') && (deep_occur t1' t2) in begin match (d1, d2) with (* handle vars and univars specially *) (Tunivar _, Tunivar _) -> unify_univar t1' t2' !univar_pairs; link_type t1' t2' | (Tvar _, _) -> occur !env t1 t2'; occur_univar !env t2; link_type t1' t2; | (_, Tvar _) -> occur !env t2 t1'; occur_univar !env t1; link_type t2' t1; | (Tfield _, Tfield _) -> (* special case for GADTs *) unify_fields env t1' t2' | _ -> begin match !umode with | Expression -> occur !env t1' t2'; link_type t1' t2 | Pattern -> add_type_equality t1' t2' end; try begin match (d1, d2) with (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 || !Clflags.classic && not (is_optional l1 || is_optional l2) -> unify env t1 t2; unify env u1 u2; begin match commu_repr c1, commu_repr c2 with Clink r, c2 -> set_commu r c2 | c1, Clink r -> set_commu r c1 | _ -> () end | (Ttuple tl1, Ttuple tl2) -> unify_list env tl1 tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> if !umode = Expression || not !generate_equations || in_current_module p1 || in_pervasives p1 || try is_datatype (Env.find_type p1 !env) with Not_found -> false then unify_list env tl1 tl2 else set_mode Pattern ~generate:false (fun () -> unify_list env tl1 tl2) | (Tconstr ((Path.Pident p) as path,[],_), Tconstr ((Path.Pident p') as path',[],_)) when is_abstract_newtype !env path && is_abstract_newtype !env path' && !generate_equations -> let source,destination = if find_newtype_level !env path > find_newtype_level !env path' then p,t2' else p',t1' in add_gadt_equation env source destination | (Tconstr ((Path.Pident p) as path,[],_), _) when is_abstract_newtype !env path && !generate_equations -> reify env t2'; local_non_recursive_abbrev !env (Path.Pident p) t2'; add_gadt_equation env p t2' | (_, Tconstr ((Path.Pident p) as path,[],_)) when is_abstract_newtype !env path && !generate_equations -> reify env t1' ; local_non_recursive_abbrev !env (Path.Pident p) t1'; add_gadt_equation env p t1' | (Tconstr (_,[],_), _) | (_, Tconstr (_,[],_)) when !umode = Pattern -> reify env t1'; reify env t2'; mcomp !env t1' t2' | (Tobject (fi1, nm1), Tobject (fi2, _)) -> unify_fields env fi1 fi2; (* Type [t2'] may have been instantiated by [unify_fields] *) (* XXX One should do some kind of unification... *) begin match (repr t2').desc with Tobject (_, {contents = Some (_, va::_)}) when (match (repr va).desc with Tvar _|Tunivar _|Tnil -> true | _ -> false) -> () | Tobject (_, nm2) -> set_name nm2 !nm1 | _ -> () end | (Tvariant row1, Tvariant row2) -> unify_row env row1 row2 | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) -> begin match field_kind_repr kind with Fvar r when f <> dummy_method -> set_kind r Fabsent; if d2 = Tnil then unify env rem t2' else unify env (newty2 rem.level Tnil) rem | _ -> raise (Unify []) end | (Tnil, Tnil) -> () | (Tpoly (t1, []), Tpoly (t2, [])) -> unify env t1 t2 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify env) | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when Path.same p1 p2 && n1 = n2 -> unify_list env tl1 tl2 | (_, _) -> raise (Unify []) end; (* XXX Commentaires + changer "create_recursion" *) if create_recursion then match t2.desc with Tconstr (p, tl, abbrev) -> forget_abbrev abbrev p; let t2'' = expand_head_unif !env t2 in if not (closed_parameterized_type tl t2'') then link_type (repr t2) (repr t2') | _ -> () (* t2 has already been expanded by update_level *) with Unify trace -> t1'.desc <- d1; raise (Unify trace) end and unify_list env tl1 tl2 = if List.length tl1 <> List.length tl2 then raise (Unify []); List.iter2 (unify env) tl1 tl2 (* Build a fresh row variable for unification *) and make_rowvar level use1 rest1 use2 rest2 = let set_name ty name = match ty.desc with Tvar None -> log_type ty; ty.desc <- Tvar name | _ -> () in let name = match rest1.desc, rest2.desc with Tvar (Some _ as name1), Tvar (Some _ as name2) -> if rest1.level <= rest2.level then name1 else name2 | Tvar (Some _ as name), _ -> if use2 then set_name rest2 name; name | _, Tvar (Some _ as name) -> if use1 then set_name rest2 name; name | _ -> None in if use1 then rest1 else if use2 then rest2 else newvar2 ?name level and unify_fields env ty1 ty2 = (* Optimization *) let (fields1, rest1) = flatten_fields ty1 and (fields2, rest2) = flatten_fields ty2 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in let l1 = (repr ty1).level and l2 = (repr ty2).level in let va = make_rowvar (min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in let d1 = rest1.desc and d2 = rest2.desc in try unify env (build_fields l1 miss1 va) rest2; unify env rest1 (build_fields l2 miss2 va); List.iter (fun (n, k1, t1, k2, t2) -> unify_kind k1 k2; try if !trace_gadt_instances then update_level !env va.level t1; unify env t1 t2 with Unify trace -> raise (Unify ((newty (Tfield(n, k1, t1, newty Tnil)), newty (Tfield(n, k2, t2, newty Tnil)))::trace))) pairs with exn -> log_type rest1; rest1.desc <- d1; log_type rest2; rest2.desc <- d2; raise exn and unify_kind k1 k2 = let k1 = field_kind_repr k1 in let k2 = field_kind_repr k2 in if k1 == k2 then () else match k1, k2 with (Fvar r, (Fvar _ | Fpresent)) -> set_kind r k2 | (Fpresent, Fvar r) -> set_kind r k1 | (Fpresent, Fpresent) -> () | _ -> assert false and unify_pairs mode env tpl = List.iter (fun (t1, t2) -> unify env t1 t2) tpl and unify_row env row1 row2 = let row1 = row_repr row1 and row2 = row_repr row2 in let rm1 = row_more row1 and rm2 = row_more row2 in if unify_eq !env rm1 rm2 then () else let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in if r1 <> [] && r2 <> [] then begin let ht = Hashtbl.create (List.length r1) in List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1; List.iter (fun (l,_) -> try raise (Tags(l, Hashtbl.find ht (hash_variant l))) with Not_found -> ()) r2 end; let fixed1 = row_fixed row1 and fixed2 = row_fixed row2 in let more = if fixed1 then rm1 else if fixed2 then rm2 else newty2 (min rm1.level rm2.level) (Tvar None) in let fixed = fixed1 || fixed2 and closed = row1.row_closed || row2.row_closed in let keep switch = List.for_all (fun (_,f1,f2) -> let f1, f2 = switch f1 f2 in row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent) pairs in let empty fields = List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in (* Check whether we are going to build an empty type *) if closed && (empty r1 || row2.row_closed) && (empty r2 || row1.row_closed) && List.for_all (fun (_,f1,f2) -> row_field_repr f1 = Rabsent || row_field_repr f2 = Rabsent) pairs then raise (Unify [mkvariant [] true, mkvariant [] true]); let name = if row1.row_name <> None && (row1.row_closed || empty r2) && (not row2.row_closed || keep (fun f1 f2 -> f1, f2) && empty r1) then row1.row_name else if row2.row_name <> None && (row2.row_closed || empty r1) && (not row1.row_closed || keep (fun f1 f2 -> f2, f1) && empty r2) then row2.row_name else None in let row0 = {row_fields = []; row_more = more; row_bound = (); row_closed = closed; row_fixed = fixed; row_name = name} in let set_more row rest = let rest = if closed then filter_row_fields row.row_closed rest else rest in if rest <> [] && (row.row_closed || row_fixed row) || closed && row_fixed row && not row.row_closed then begin let t1 = mkvariant [] true and t2 = mkvariant rest false in raise (Unify [if row == row1 then (t1,t2) else (t2,t1)]) end; (* The following test is not principal... should rather use Tnil *) let rm = row_more row in if !trace_gadt_instances && rm.desc = Tnil then () else if !trace_gadt_instances then update_level !env rm.level (newgenty (Tvariant row)); if row_fixed row then if more == rm then () else if is_Tvar rm then link_type rm more else unify env rm more else let ty = newgenty (Tvariant {row0 with row_fields = rest}) in update_level !env rm.level ty; link_type rm ty in let md1 = rm1.desc and md2 = rm2.desc in begin try set_more row2 r1; set_more row1 r2; List.iter (fun (l,f1,f2) -> try unify_row_field env fixed1 fixed2 more l f1 f2 with Unify trace -> raise (Unify ((mkvariant [l,f1] true, mkvariant [l,f2] true) :: trace))) pairs; with exn -> log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn end and unify_row_field env fixed1 fixed2 more l f1 f2 = let f1 = row_field_repr f1 and f2 = row_field_repr f2 in if f1 == f2 then () else match f1, f2 with Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2 | Rpresent None, Rpresent None -> () | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) -> if e1 == e2 then () else let redo = (m1 || m2 || fixed1 || fixed2 || !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) && begin match tl1 @ tl2 with [] -> false | t1 :: tl -> if c1 || c2 then raise (Unify []); List.iter (unify env t1) tl; !e1 <> None || !e2 <> None end in if redo then unify_row_field env fixed1 fixed2 more l f1 f2 else let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in let rec remq tl = function [] -> [] | ty :: tl' -> if List.memq ty tl then remq tl tl' else ty :: remq tl tl' in let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in (* Is this handling of levels really principal? *) List.iter (update_level !env (repr more).level) (tl1' @ tl2'); let e = ref None in let f1' = Reither(c1 || c2, tl1', m1 || m2, e) and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in set_row_field e1 f1'; set_row_field e2 f2'; | Reither(_, _, false, e1), Rabsent when not fixed1 -> set_row_field e1 f2 | Rabsent, Reither(_, _, false, e2) when not fixed2 -> set_row_field e2 f1 | Rabsent, Rabsent -> () | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 -> set_row_field e1 f2; update_level !env (repr more).level t2; (try List.iter (fun t1 -> unify env t1 t2) tl with exn -> e1 := None; raise exn) | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 -> set_row_field e2 f1; update_level !env (repr more).level t1; (try List.iter (unify env t1) tl with exn -> e2 := None; raise exn) | Reither(true, [], _, e1), Rpresent None when not fixed1 -> set_row_field e1 f2 | Rpresent None, Reither(true, [], _, e2) when not fixed2 -> set_row_field e2 f1 | _ -> raise (Unify []) let unify env ty1 ty2 = try unify env ty1 ty2 with Unify trace -> raise (Unify (expand_trace !env trace)) | Recursive_abbrev -> raise (Unification_recursive_abbrev (expand_trace !env [(ty1,ty2)])) let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 = try univar_pairs := []; newtype_level := Some lev; set_mode Pattern (fun () -> unify env ty1 ty2); newtype_level := None; TypePairs.clear unify_eq_set; with e -> TypePairs.clear unify_eq_set; match e with Unify e -> raise (Unify e) | e -> newtype_level := None; raise e let unify_var env t1 t2 = let t1 = repr t1 and t2 = repr t2 in if t1 == t2 then () else match t1.desc with Tvar _ -> let reset_tracing = check_trace_gadt_instances env in begin try occur env t1 t2; update_level env t1.level t2; link_type t1 t2; if reset_tracing then trace_gadt_instances := false; with Unify trace -> if reset_tracing then trace_gadt_instances := false; let expanded_trace = expand_trace env ((t1,t2)::trace) in raise (Unify expanded_trace) end | _ -> unify (ref env) t1 t2 let _ = unify' := unify_var let unify_pairs env ty1 ty2 pairs = univar_pairs := pairs; unify env ty1 ty2 let unify env ty1 ty2 = unify_pairs (ref env) ty1 ty2 [] (**** Special cases of unification ****) let expand_head_trace env t = let reset_tracing = check_trace_gadt_instances env in let t = expand_head_unif env t in if reset_tracing then trace_gadt_instances := false; t (* Unify [t] and [l:'a -> 'b]. Return ['a] and ['b]. In label mode, label mismatch is accepted when (1) the requested label is "" (2) the original label is not optional *) let rec filter_arrow env t l = let t = expand_head_trace env t in match t.desc with Tvar _ -> let lv = t.level in let t1 = newvar2 lv and t2 = newvar2 lv in let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in link_type t t'; (t1, t2) | Tarrow(l', t1, t2, _) when l = l' || !Clflags.classic && l = "" && not (is_optional l') -> (t1, t2) | _ -> raise (Unify []) (* Used by [filter_method]. *) let rec filter_method_field env name priv ty = let ty = expand_head_trace env ty in match ty.desc with Tvar _ -> let level = ty.level in let ty1 = newvar2 level and ty2 = newvar2 level in let ty' = newty2 level (Tfield (name, begin match priv with Private -> Fvar (ref None) | Public -> Fpresent end, ty1, ty2)) in link_type ty ty'; ty1 | Tfield(n, kind, ty1, ty2) -> let kind = field_kind_repr kind in if (n = name) && (kind <> Fabsent) then begin if priv = Public then unify_kind kind Fpresent; ty1 end else filter_method_field env name priv ty2 | _ -> raise (Unify []) (* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *) let rec filter_method env name priv ty = let ty = expand_head_trace env ty in match ty.desc with Tvar _ -> let ty1 = newvar () in let ty' = newobj ty1 in update_level env ty.level ty'; link_type ty ty'; filter_method_field env name priv ty1 | Tobject(f, _) -> filter_method_field env name priv f | _ -> raise (Unify []) let check_filter_method env name priv ty = ignore(filter_method env name priv ty) let filter_self_method env lab priv meths ty = let ty' = filter_method env lab priv ty in try Meths.find lab !meths with Not_found -> let pair = (Ident.create lab, ty') in meths := Meths.add lab pair !meths; pair (***********************************) (* Matching between type schemes *) (***********************************) (* Update the level of [ty]. First check that the levels of generic variables from the subject are not lowered. *) let moregen_occur env level ty = let rec occur ty = let ty = repr ty in if ty.level > level then begin if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur; ty.level <- pivot_level - ty.level; match ty.desc with Tvariant row when static_row row -> iter_row occur row | _ -> iter_type_expr occur ty end in begin try occur ty; unmark_type ty with Occur -> unmark_type ty; raise (Unify []) end; (* also check for free univars *) occur_univar env ty; update_level env level ty let may_instantiate inst_nongen t1 = if inst_nongen then t1.level <> generic_level - 1 else t1.level = generic_level let rec moregen inst_nongen type_pairs env t1 t2 = if t1 == t2 then () else let t1 = repr t1 in let t2 = repr t2 in if t1 == t2 then () else try match (t1.desc, t2.desc) with (Tvar _, _) when may_instantiate inst_nongen t1 -> moregen_occur env t1.level t2; occur env t1 t2; link_type t1 t2 | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> () | _ -> let t1' = expand_head_unif env t1 in let t2' = expand_head_unif env t2 in (* Expansion may have changed the representative of the types... *) let t1' = repr t1' and t2' = repr t2' in if t1' == t2' then () else begin try TypePairs.find type_pairs (t1', t2') with Not_found -> TypePairs.add type_pairs (t1', t2') (); match (t1'.desc, t2'.desc) with (Tvar _, _) when may_instantiate inst_nongen t1' -> moregen_occur env t1'.level t2; link_type t1' t2 | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 || !Clflags.classic && not (is_optional l1 || is_optional l2) -> moregen inst_nongen type_pairs env t1 t2; moregen inst_nongen type_pairs env u1 u2 | (Ttuple tl1, Ttuple tl2) -> moregen_list inst_nongen type_pairs env tl1 tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> moregen_list inst_nongen type_pairs env tl1 tl2 | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when Path.same p1 p2 && n1 = n2 -> moregen_list inst_nongen type_pairs env tl1 tl2 | (Tvariant row1, Tvariant row2) -> moregen_row inst_nongen type_pairs env row1 row2 | (Tobject (fi1, nm1), Tobject (fi2, nm2)) -> moregen_fields inst_nongen type_pairs env fi1 fi2 | (Tfield _, Tfield _) -> (* Actually unused *) moregen_fields inst_nongen type_pairs env t1' t2' | (Tnil, Tnil) -> () | (Tpoly (t1, []), Tpoly (t2, [])) -> moregen inst_nongen type_pairs env t1 t2 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> enter_poly env univar_pairs t1 tl1 t2 tl2 (moregen inst_nongen type_pairs env) | (Tunivar _, Tunivar _) -> unify_univar t1' t2' !univar_pairs | (_, _) -> raise (Unify []) end with Unify trace -> raise (Unify ((t1, t2)::trace)) and moregen_list inst_nongen type_pairs env tl1 tl2 = if List.length tl1 <> List.length tl2 then raise (Unify []); List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 and moregen_fields inst_nongen type_pairs env ty1 ty2 = let (fields1, rest1) = flatten_fields ty1 and (fields2, rest2) = flatten_fields ty2 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in if miss1 <> [] then raise (Unify []); moregen inst_nongen type_pairs env rest1 (build_fields (repr ty2).level miss2 rest2); List.iter (fun (n, k1, t1, k2, t2) -> moregen_kind k1 k2; try moregen inst_nongen type_pairs env t1 t2 with Unify trace -> raise (Unify ((newty (Tfield(n, k1, t1, rest2)), newty (Tfield(n, k2, t2, rest2)))::trace))) pairs and moregen_kind k1 k2 = let k1 = field_kind_repr k1 in let k2 = field_kind_repr k2 in if k1 == k2 then () else match k1, k2 with (Fvar r, (Fvar _ | Fpresent)) -> set_kind r k2 | (Fpresent, Fpresent) -> () | _ -> raise (Unify []) and moregen_row inst_nongen type_pairs env row1 row2 = let row1 = row_repr row1 and row2 = row_repr row2 in let rm1 = repr row1.row_more and rm2 = repr row2.row_more in if rm1 == rm2 then () else let may_inst = is_Tvar rm1 && may_instantiate inst_nongen rm1 || rm1.desc = Tnil in let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in let r1, r2 = if row2.row_closed then filter_row_fields may_inst r1, filter_row_fields false r2 else r1, r2 in if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> []) then raise (Unify []); begin match rm1.desc, rm2.desc with Tunivar _, Tunivar _ -> unify_univar rm1 rm2 !univar_pairs | Tunivar _, _ | _, Tunivar _ -> raise (Unify []) | _ when static_row row1 -> () | _ when may_inst -> if not (static_row row2) then moregen_occur env rm1.level rm2; let ext = if r2 = [] then rm2 else let row_ext = {row2 with row_fields = r2} in iter_row (moregen_occur env rm1.level) row_ext; newty2 rm1.level (Tvariant row_ext) in link_type rm1 ext | Tconstr _, Tconstr _ -> moregen inst_nongen type_pairs env rm1 rm2 | _ -> raise (Unify []) end; List.iter (fun (l,f1,f2) -> let f1 = row_field_repr f1 and f2 = row_field_repr f2 in if f1 == f2 then () else match f1, f2 with Rpresent(Some t1), Rpresent(Some t2) -> moregen inst_nongen type_pairs env t1 t2 | Rpresent None, Rpresent None -> () | Reither(false, tl1, _, e1), Rpresent(Some t2) when may_inst -> set_row_field e1 f2; List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1 | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) -> if e1 != e2 then begin if c1 && not c2 then raise(Unify []); set_row_field e1 (Reither (c2, [], m2, e2)); if List.length tl1 = List.length tl2 then List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 else match tl2 with t2 :: _ -> List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1 | [] -> if tl1 <> [] then raise (Unify []) end | Reither(true, [], _, e1), Rpresent None when may_inst -> set_row_field e1 f2 | Reither(_, _, _, e1), Rabsent when may_inst -> set_row_field e1 f2 | Rabsent, Rabsent -> () | _ -> raise (Unify [])) pairs (* Must empty univar_pairs first *) let moregen inst_nongen type_pairs env patt subj = univar_pairs := []; moregen inst_nongen type_pairs env patt subj (* Non-generic variable can be instanciated only if [inst_nongen] is true. So, [inst_nongen] should be set to false if the subject might contain non-generic variables (and we do not want them to be instanciated). Usually, the subject is given by the user, and the pattern is unimportant. So, no need to propagate abbreviations. *) let moregeneral env inst_nongen pat_sch subj_sch = let old_level = !current_level in current_level := generic_level - 1; (* Generic variables are first duplicated with [instance]. So, their levels are lowered to [generic_level - 1]. The subject is then copied with [duplicate_type]. That way, its levels won't be changed. *) let subj = duplicate_type (instance env subj_sch) in current_level := generic_level; (* Duplicate generic variables *) let patt = instance env pat_sch in let res = try moregen inst_nongen (TypePairs.create 13) env patt subj; true with Unify _ -> false in current_level := old_level; res (* Alternative approach: "rigidify" a type scheme, and check validity after unification *) (* Simpler, no? *) let rec rigidify_rec vars ty = let ty = repr ty in if ty.level >= lowest_level then begin ty.level <- pivot_level - ty.level; match ty.desc with | Tvar _ -> if not (List.memq ty !vars) then vars := ty :: !vars | Tvariant row -> let row = row_repr row in let more = repr row.row_more in if is_Tvar more && not (row_fixed row) then begin let more' = newty2 more.level more.desc in let row' = {row with row_fixed=true; row_fields=[]; row_more=more'} in link_type more (newty2 ty.level (Tvariant row')) end; iter_row (rigidify_rec vars) row; (* only consider the row variable if the variant is not static *) if not (static_row row) then rigidify_rec vars (row_more row) | _ -> iter_type_expr (rigidify_rec vars) ty end let rigidify ty = let vars = ref [] in rigidify_rec vars ty; unmark_type ty; !vars let all_distinct_vars env vars = let tyl = ref [] in List.for_all (fun ty -> let ty = expand_head env ty in if List.memq ty !tyl then false else (tyl := ty :: !tyl; is_Tvar ty)) vars let matches env ty ty' = let snap = snapshot () in let vars = rigidify ty in cleanup_abbrev (); let ok = try unify env ty ty'; all_distinct_vars env vars with Unify _ -> false in backtrack snap; ok (*********************************************) (* Equivalence between parameterized types *) (*********************************************) let rec get_object_row ty = match repr ty with | {desc=Tfield (_, _, _, tl)} -> get_object_row tl | ty -> ty let expand_head_rigid env ty = let old = !rigid_variants in rigid_variants := true; let ty' = expand_head_unif env ty in rigid_variants := old; ty' let normalize_subst subst = if List.exists (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false) !subst then subst := List.map (fun (t1,t2) -> repr t1, repr t2) !subst let rec eqtype rename type_pairs subst env t1 t2 = if t1 == t2 then () else let t1 = repr t1 in let t2 = repr t2 in if t1 == t2 then () else try match (t1.desc, t2.desc) with (Tvar _, Tvar _) when rename -> begin try normalize_subst subst; if List.assq t1 !subst != t2 then raise (Unify []) with Not_found -> if List.exists (fun (_, t) -> t == t2) !subst then raise (Unify []); subst := (t1, t2) :: !subst end | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> () | _ -> let t1' = expand_head_rigid env t1 in let t2' = expand_head_rigid env t2 in (* Expansion may have changed the representative of the types... *) let t1' = repr t1' and t2' = repr t2' in if t1' == t2' then () else begin try TypePairs.find type_pairs (t1', t2') with Not_found -> TypePairs.add type_pairs (t1', t2') (); match (t1'.desc, t2'.desc) with (Tvar _, Tvar _) when rename -> begin try normalize_subst subst; if List.assq t1' !subst != t2' then raise (Unify []) with Not_found -> if List.exists (fun (_, t) -> t == t2') !subst then raise (Unify []); subst := (t1', t2') :: !subst end | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 || !Clflags.classic && not (is_optional l1 || is_optional l2) -> eqtype rename type_pairs subst env t1 t2; eqtype rename type_pairs subst env u1 u2; | (Ttuple tl1, Ttuple tl2) -> eqtype_list rename type_pairs subst env tl1 tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> eqtype_list rename type_pairs subst env tl1 tl2 | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when Path.same p1 p2 && n1 = n2 -> eqtype_list rename type_pairs subst env tl1 tl2 | (Tvariant row1, Tvariant row2) -> eqtype_row rename type_pairs subst env row1 row2 | (Tobject (fi1, nm1), Tobject (fi2, nm2)) -> eqtype_fields rename type_pairs subst env fi1 fi2 | (Tfield _, Tfield _) -> (* Actually unused *) eqtype_fields rename type_pairs subst env t1' t2' | (Tnil, Tnil) -> () | (Tpoly (t1, []), Tpoly (t2, [])) -> eqtype rename type_pairs subst env t1 t2 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> enter_poly env univar_pairs t1 tl1 t2 tl2 (eqtype rename type_pairs subst env) | (Tunivar _, Tunivar _) -> unify_univar t1' t2' !univar_pairs | (_, _) -> raise (Unify []) end with Unify trace -> raise (Unify ((t1, t2)::trace)) and eqtype_list rename type_pairs subst env tl1 tl2 = if List.length tl1 <> List.length tl2 then raise (Unify []); List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 and eqtype_fields rename type_pairs subst env ty1 ty2 = let (fields1, rest1) = flatten_fields ty1 in let (fields2, rest2) = flatten_fields ty2 in (* First check if same row => already equal *) let same_row = rest1 == rest2 || TypePairs.mem type_pairs (rest1,rest2) || (rename && List.mem (rest1, rest2) !subst) in if same_row then () else (* Try expansion, needed when called from Includecore.type_manifest *) match expand_head_rigid env rest2 with {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2 | _ -> let (pairs, miss1, miss2) = associate_fields fields1 fields2 in eqtype rename type_pairs subst env rest1 rest2; if (miss1 <> []) || (miss2 <> []) then raise (Unify []); List.iter (function (n, k1, t1, k2, t2) -> eqtype_kind k1 k2; try eqtype rename type_pairs subst env t1 t2 with Unify trace -> raise (Unify ((newty (Tfield(n, k1, t1, rest2)), newty (Tfield(n, k2, t2, rest2)))::trace))) pairs and eqtype_kind k1 k2 = let k1 = field_kind_repr k1 in let k2 = field_kind_repr k2 in match k1, k2 with (Fvar _, Fvar _) | (Fpresent, Fpresent) -> () | _ -> raise (Unify []) and eqtype_row rename type_pairs subst env row1 row2 = (* Try expansion, needed when called from Includecore.type_manifest *) match expand_head_rigid env (row_more row2) with {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2 | _ -> let row1 = row_repr row1 and row2 = row_repr row2 in let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in if row1.row_closed <> row2.row_closed || not row1.row_closed && (r1 <> [] || r2 <> []) || filter_row_fields false (r1 @ r2) <> [] then raise (Unify []); if not (static_row row1) then eqtype rename type_pairs subst env row1.row_more row2.row_more; List.iter (fun (_,f1,f2) -> match row_field_repr f1, row_field_repr f2 with Rpresent(Some t1), Rpresent(Some t2) -> eqtype rename type_pairs subst env t1 t2 | Reither(true, [], _, _), Reither(true, [], _, _) -> () | Reither(false, t1::tl1, _, _), Reither(false, t2::tl2, _, _) -> eqtype rename type_pairs subst env t1 t2; if List.length tl1 = List.length tl2 then (* if same length allow different types (meaning?) *) List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 else begin (* otherwise everything must be equal *) List.iter (eqtype rename type_pairs subst env t1) tl2; List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1 end | Rpresent None, Rpresent None -> () | Rabsent, Rabsent -> () | _ -> raise (Unify [])) pairs (* Two modes: with or without renaming of variables *) let equal env rename tyl1 tyl2 = try univar_pairs := []; eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2; true with Unify _ -> false (* Must empty univar_pairs first *) let eqtype rename type_pairs subst env t1 t2 = univar_pairs := []; eqtype rename type_pairs subst env t1 t2 (*************************) (* Class type matching *) (*************************) type class_match_failure = CM_Virtual_class | CM_Parameter_arity_mismatch of int * int | CM_Type_parameter_mismatch of (type_expr * type_expr) list | CM_Class_type_mismatch of class_type * class_type | CM_Parameter_mismatch of (type_expr * type_expr) list | CM_Val_type_mismatch of string * (type_expr * type_expr) list | CM_Meth_type_mismatch of string * (type_expr * type_expr) list | CM_Non_mutable_value of string | CM_Non_concrete_value of string | CM_Missing_value of string | CM_Missing_method of string | CM_Hide_public of string | CM_Hide_virtual of string * string | CM_Public_method of string | CM_Private_method of string | CM_Virtual_method of string exception Failure of class_match_failure list let rec moregen_clty trace type_pairs env cty1 cty2 = try match cty1, cty2 with Cty_constr (_, _, cty1), _ -> moregen_clty true type_pairs env cty1 cty2 | _, Cty_constr (_, _, cty2) -> moregen_clty true type_pairs env cty1 cty2 | Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 -> begin try moregen true type_pairs env ty1 ty2 with Unify trace -> raise (Failure [CM_Parameter_mismatch (expand_trace env trace)]) end; moregen_clty false type_pairs env cty1' cty2' | Cty_signature sign1, Cty_signature sign2 -> let ty1 = object_fields (repr sign1.cty_self) in let ty2 = object_fields (repr sign2.cty_self) in let (fields1, rest1) = flatten_fields ty1 and (fields2, rest2) = flatten_fields ty2 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in List.iter (fun (lab, k1, t1, k2, t2) -> begin try moregen true type_pairs env t1 t2 with Unify trace -> raise (Failure [CM_Meth_type_mismatch (lab, expand_trace env trace)]) end) pairs; Vars.iter (fun lab (mut, v, ty) -> let (mut', v', ty') = Vars.find lab sign1.cty_vars in try moregen true type_pairs env ty' ty with Unify trace -> raise (Failure [CM_Val_type_mismatch (lab, expand_trace env trace)])) sign2.cty_vars | _ -> raise (Failure []) with Failure error when trace || error = [] -> raise (Failure (CM_Class_type_mismatch (cty1, cty2)::error)) let match_class_types ?(trace=true) env pat_sch subj_sch = let type_pairs = TypePairs.create 53 in let old_level = !current_level in current_level := generic_level - 1; (* Generic variables are first duplicated with [instance]. So, their levels are lowered to [generic_level - 1]. The subject is then copied with [duplicate_type]. That way, its levels won't be changed. *) let (_, subj_inst) = instance_class [] subj_sch in let subj = duplicate_class_type subj_inst in current_level := generic_level; (* Duplicate generic variables *) let (_, patt) = instance_class [] pat_sch in let res = let sign1 = signature_of_class_type patt in let sign2 = signature_of_class_type subj in let t1 = repr sign1.cty_self in let t2 = repr sign2.cty_self in TypePairs.add type_pairs (t1, t2) (); let (fields1, rest1) = flatten_fields (object_fields t1) and (fields2, rest2) = flatten_fields (object_fields t2) in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in let error = List.fold_right (fun (lab, k, _) err -> let err = let k = field_kind_repr k in begin match k with Fvar r -> set_kind r Fabsent; err | _ -> CM_Hide_public lab::err end in if Concr.mem lab sign1.cty_concr then err else CM_Hide_virtual ("method", lab) :: err) miss1 [] in let missing_method = List.map (fun (m, _, _) -> m) miss2 in let error = (List.map (fun m -> CM_Missing_method m) missing_method) @ error in (* Always succeeds *) moregen true type_pairs env rest1 rest2; let error = List.fold_right (fun (lab, k1, t1, k2, t2) err -> try moregen_kind k1 k2; err with Unify _ -> CM_Public_method lab::err) pairs error in let error = Vars.fold (fun lab (mut, vr, ty) err -> try let (mut', vr', ty') = Vars.find lab sign1.cty_vars in if mut = Mutable && mut' <> Mutable then CM_Non_mutable_value lab::err else if vr = Concrete && vr' <> Concrete then CM_Non_concrete_value lab::err else err with Not_found -> CM_Missing_value lab::err) sign2.cty_vars error in let error = Vars.fold (fun lab (_,vr,_) err -> if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then CM_Hide_virtual ("instance variable", lab) :: err else err) sign1.cty_vars error in let error = List.fold_right (fun e l -> if List.mem e missing_method then l else CM_Virtual_method e::l) (Concr.elements (Concr.diff sign2.cty_concr sign1.cty_concr)) error in match error with [] -> begin try moregen_clty trace type_pairs env patt subj; [] with Failure r -> r end | error -> CM_Class_type_mismatch (patt, subj)::error in current_level := old_level; res let rec equal_clty trace type_pairs subst env cty1 cty2 = try match cty1, cty2 with Cty_constr (_, _, cty1), Cty_constr (_, _, cty2) -> equal_clty true type_pairs subst env cty1 cty2 | Cty_constr (_, _, cty1), _ -> equal_clty true type_pairs subst env cty1 cty2 | _, Cty_constr (_, _, cty2) -> equal_clty true type_pairs subst env cty1 cty2 | Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 -> begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace -> raise (Failure [CM_Parameter_mismatch (expand_trace env trace)]) end; equal_clty false type_pairs subst env cty1' cty2' | Cty_signature sign1, Cty_signature sign2 -> let ty1 = object_fields (repr sign1.cty_self) in let ty2 = object_fields (repr sign2.cty_self) in let (fields1, rest1) = flatten_fields ty1 and (fields2, rest2) = flatten_fields ty2 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in List.iter (fun (lab, k1, t1, k2, t2) -> begin try eqtype true type_pairs subst env t1 t2 with Unify trace -> raise (Failure [CM_Meth_type_mismatch (lab, expand_trace env trace)]) end) pairs; Vars.iter (fun lab (_, _, ty) -> let (_, _, ty') = Vars.find lab sign1.cty_vars in try eqtype true type_pairs subst env ty' ty with Unify trace -> raise (Failure [CM_Val_type_mismatch (lab, expand_trace env trace)])) sign2.cty_vars | _ -> raise (Failure (if trace then [] else [CM_Class_type_mismatch (cty1, cty2)])) with Failure error when trace -> raise (Failure (CM_Class_type_mismatch (cty1, cty2)::error)) let match_class_declarations env patt_params patt_type subj_params subj_type = let type_pairs = TypePairs.create 53 in let subst = ref [] in let sign1 = signature_of_class_type patt_type in let sign2 = signature_of_class_type subj_type in let t1 = repr sign1.cty_self in let t2 = repr sign2.cty_self in TypePairs.add type_pairs (t1, t2) (); let (fields1, rest1) = flatten_fields (object_fields t1) and (fields2, rest2) = flatten_fields (object_fields t2) in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in let error = List.fold_right (fun (lab, k, _) err -> let err = let k = field_kind_repr k in begin match k with Fvar r -> err | _ -> CM_Hide_public lab::err end in if Concr.mem lab sign1.cty_concr then err else CM_Hide_virtual ("method", lab) :: err) miss1 [] in let missing_method = List.map (fun (m, _, _) -> m) miss2 in let error = (List.map (fun m -> CM_Missing_method m) missing_method) @ error in (* Always succeeds *) eqtype true type_pairs subst env rest1 rest2; let error = List.fold_right (fun (lab, k1, t1, k2, t2) err -> let k1 = field_kind_repr k1 in let k2 = field_kind_repr k2 in match k1, k2 with (Fvar _, Fvar _) | (Fpresent, Fpresent) -> err | (Fvar _, Fpresent) -> CM_Private_method lab::err | (Fpresent, Fvar _) -> CM_Public_method lab::err | _ -> assert false) pairs error in let error = Vars.fold (fun lab (mut, vr, ty) err -> try let (mut', vr', ty') = Vars.find lab sign1.cty_vars in if mut = Mutable && mut' <> Mutable then CM_Non_mutable_value lab::err else if vr = Concrete && vr' <> Concrete then CM_Non_concrete_value lab::err else err with Not_found -> CM_Missing_value lab::err) sign2.cty_vars error in let error = Vars.fold (fun lab (_,vr,_) err -> if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then CM_Hide_virtual ("instance variable", lab) :: err else err) sign1.cty_vars error in let error = List.fold_right (fun e l -> if List.mem e missing_method then l else CM_Virtual_method e::l) (Concr.elements (Concr.diff sign2.cty_concr sign1.cty_concr)) error in match error with [] -> begin try let lp = List.length patt_params in let ls = List.length subj_params in if lp <> ls then raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]); List.iter2 (fun p s -> try eqtype true type_pairs subst env p s with Unify trace -> raise (Failure [CM_Type_parameter_mismatch (expand_trace env trace)])) patt_params subj_params; (* old code: equal_clty false type_pairs subst env patt_type subj_type; *) equal_clty false type_pairs subst env (Cty_signature sign1) (Cty_signature sign2); (* Use moregeneral for class parameters, need to recheck everything to keeps relationships (PR#4824) *) let clty_params = List.fold_right (fun ty cty -> Cty_fun ("*",ty,cty)) in match_class_types ~trace:false env (clty_params patt_params patt_type) (clty_params subj_params subj_type) with Failure r -> r end | error -> error (***************) (* Subtyping *) (***************) (**** Build a subtype of a given type. ****) (* build_subtype: [visited] traces traversed object and variant types [loops] is a mapping from variables to variables, to reproduce positive loops in a class type [posi] true if the current variance is positive [level] number of expansions/enlargement allowed on this branch *) let warn = ref false (* whether double coercion might do better *) let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n let pred_enlarge n = if n mod 2 = 1 then pred n else n type change = Unchanged | Equiv | Changed let collect l = List.fold_left (fun c1 (_, c2) -> max c1 c2) Unchanged l let rec filter_visited = function [] -> [] | {desc=Tobject _|Tvariant _} :: _ as l -> l | _ :: l -> filter_visited l let memq_warn t visited = if List.memq t visited then (warn := true; true) else false let rec lid_of_path ?(sharp="") = function Path.Pident id -> Longident.Lident (sharp ^ Ident.name id) | Path.Pdot (p1, s, _) -> Longident.Ldot (lid_of_path p1, sharp ^ s) | Path.Papply (p1, p2) -> Longident.Lapply (lid_of_path ~sharp p1, lid_of_path p2) let find_cltype_for_path env p = let path, cl_abbr = Env.lookup_type (lid_of_path ~sharp:"#" p) env in match cl_abbr.type_manifest with Some ty -> begin match (repr ty).desc with Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty | _ -> raise Not_found end | None -> assert false let has_constr_row' env t = has_constr_row (expand_abbrev env t) let rec build_subtype env visited loops posi level t = let t = repr t in match t.desc with Tvar _ -> if posi then try let t' = List.assq t loops in warn := true; (t', Equiv) with Not_found -> (t, Unchanged) else (t, Unchanged) | Tarrow(l, t1, t2, _) -> if memq_warn t visited then (t, Unchanged) else let visited = t :: visited in let (t1', c1) = build_subtype env visited loops (not posi) level t1 in let (t2', c2) = build_subtype env visited loops posi level t2 in let c = max c1 c2 in if c > Unchanged then (newty (Tarrow(l, t1', t2', Cok)), c) else (t, Unchanged) | Ttuple tlist -> if memq_warn t visited then (t, Unchanged) else let visited = t :: visited in let tlist' = List.map (build_subtype env visited loops posi level) tlist in let c = collect tlist' in if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c) else (t, Unchanged) | Tconstr(p, tl, abbrev) when level > 0 && generic_abbrev env p && safe_abbrev env t && not (has_constr_row' env t) -> let t' = repr (expand_abbrev env t) in let level' = pred_expand level in begin try match t'.desc with Tobject _ when posi && not (opened_object t') -> let cl_abbr, body = find_cltype_for_path env p in let ty = subst env !current_level Public abbrev None cl_abbr.type_params tl body in let ty = repr ty in let ty1, tl1 = match ty.desc with Tobject(ty1,{contents=Some(p',tl1)}) when Path.same p p' -> ty1, tl1 | _ -> raise Not_found in (* Fix PR4505: do not set ty to Tvar when it appears in tl1, as this occurence might break the occur check. XXX not clear whether this correct anyway... *) if List.exists (deep_occur ty) tl1 then raise Not_found; ty.desc <- Tvar None; let t'' = newvar () in let loops = (ty, t'') :: loops in (* May discard [visited] as level is going down *) let (ty1', c) = build_subtype env [t'] loops posi (pred_enlarge level') ty1 in assert (is_Tvar t''); let nm = if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in t''.desc <- Tobject (ty1', ref nm); (try unify_var env ty t with Unify _ -> assert false); (t'', Changed) | _ -> raise Not_found with Not_found -> let (t'',c) = build_subtype env visited loops posi level' t' in if c > Unchanged then (t'',c) else (t, Unchanged) end | Tconstr(p, tl, abbrev) -> (* Must check recursion on constructors, since we do not always expand them *) if memq_warn t visited then (t, Unchanged) else let visited = t :: visited in begin try let decl = Env.find_type p env in if level = 0 && generic_abbrev env p && safe_abbrev env t && not (has_constr_row' env t) then warn := true; let tl' = List.map2 (fun (co,cn,_) t -> if cn then if co then (t, Unchanged) else build_subtype env visited loops (not posi) level t else if co then build_subtype env visited loops posi level t else (newvar(), Changed)) decl.type_variance tl in let c = collect tl' in if c > Unchanged then (newconstr p (List.map fst tl'), c) else (t, Unchanged) with Not_found -> (t, Unchanged) end | Tvariant row -> let row = row_repr row in if memq_warn t visited || not (static_row row) then (t, Unchanged) else let level' = pred_enlarge level in let visited = t :: if level' < level then [] else filter_visited visited in let fields = filter_row_fields false row.row_fields in let fields = List.map (fun (l,f as orig) -> match row_field_repr f with Rpresent None -> if posi then (l, Reither(true, [], false, ref None)), Unchanged else orig, Unchanged | Rpresent(Some t) -> let (t', c) = build_subtype env visited loops posi level' t in let f = if posi && level > 0 then Reither(false, [t'], false, ref None) else Rpresent(Some t') in (l, f), c | _ -> assert false) fields in let c = collect fields in let row = { row_fields = List.map fst fields; row_more = newvar(); row_bound = (); row_closed = posi; row_fixed = false; row_name = if c > Unchanged then None else row.row_name } in (newty (Tvariant row), Changed) | Tobject (t1, _) -> if memq_warn t visited || opened_object t1 then (t, Unchanged) else let level' = pred_enlarge level in let visited = t :: if level' < level then [] else filter_visited visited in let (t1', c) = build_subtype env visited loops posi level' t1 in if c > Unchanged then (newty (Tobject (t1', ref None)), c) else (t, Unchanged) | Tfield(s, _, t1, t2) (* Always present *) -> let (t1', c1) = build_subtype env visited loops posi level t1 in let (t2', c2) = build_subtype env visited loops posi level t2 in let c = max c1 c2 in if c > Unchanged then (newty (Tfield(s, Fpresent, t1', t2')), c) else (t, Unchanged) | Tnil -> if posi then let v = newvar () in (v, Changed) else begin warn := true; (t, Unchanged) end | Tsubst _ | Tlink _ -> assert false | Tpoly(t1, tl) -> let (t1', c) = build_subtype env visited loops posi level t1 in if c > Unchanged then (newty (Tpoly(t1', tl)), c) else (t, Unchanged) | Tunivar _ | Tpackage _ -> (t, Unchanged) let enlarge_type env ty = warn := false; (* [level = 4] allows 2 expansions involving objects/variants *) let (ty', _) = build_subtype env [] [] true 4 ty in (ty', !warn) (**** Check whether a type is a subtype of another type. ****) (* During the traversal, a trace of visited types is maintained. It is printed in case of error. Constraints (pairs of types that must be equals) are accumulated rather than being enforced straight. Indeed, the result would otherwise depend on the order in which these constraints are enforced. A function enforcing these constraints is returned. That way, type variables can be bound to their actual values before this function is called (see Typecore). Only well-defined abbreviations are expanded (hence the tests [generic_abbrev ...]). *) let subtypes = TypePairs.create 17 let subtype_error env trace = raise (Subtype (expand_trace env (List.rev trace), [])) let private_abbrev env path = try let decl = Env.find_type path env in decl.type_private = Private && decl.type_manifest <> None with Not_found -> false (* check list inclusion, assuming lists are ordered *) let rec included nl1 nl2 = match nl1, nl2 with (a::nl1', b::nl2') -> if a = b then included nl1' nl2' else a > b && included nl1 nl2' | ([], _) -> true | (_, []) -> false let rec extract_assoc nl1 nl2 tl2 = match (nl1, nl2, tl2) with (a::nl1', b::nl2, t::tl2) -> if a = b then t :: extract_assoc nl1' nl2 tl2 else extract_assoc nl1 nl2 tl2 | ([], _, _) -> [] | _ -> assert false let rec subtype_rec env trace t1 t2 cstrs = let t1 = repr t1 in let t2 = repr t2 in if t1 == t2 then cstrs else begin try TypePairs.find subtypes (t1, t2); cstrs with Not_found -> TypePairs.add subtypes (t1, t2) (); match (t1.desc, t2.desc) with (Tvar _, _) | (_, Tvar _) -> (trace, t1, t2, !univar_pairs)::cstrs | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2 || !Clflags.classic && not (is_optional l1 || is_optional l2) -> let cstrs = subtype_rec env ((t2, t1)::trace) t2 t1 cstrs in subtype_rec env ((u1, u2)::trace) u1 u2 cstrs | (Ttuple tl1, Ttuple tl2) -> subtype_list env trace tl1 tl2 cstrs | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 -> cstrs | (Tconstr(p1, tl1, abbrev1), _) when generic_abbrev env p1 && safe_abbrev env t1 -> subtype_rec env trace (expand_abbrev env t1) t2 cstrs | (_, Tconstr(p2, tl2, abbrev2)) when generic_abbrev env p2 && safe_abbrev env t2 -> subtype_rec env trace t1 (expand_abbrev env t2) cstrs | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 -> begin try let decl = Env.find_type p1 env in List.fold_left2 (fun cstrs (co, cn, _) (t1, t2) -> if co then if cn then (trace, newty2 t1.level (Ttuple[t1]), newty2 t2.level (Ttuple[t2]), !univar_pairs) :: cstrs else subtype_rec env ((t1, t2)::trace) t1 t2 cstrs else if cn then subtype_rec env ((t2, t1)::trace) t2 t1 cstrs else cstrs) cstrs decl.type_variance (List.combine tl1 tl2) with Not_found -> (trace, t1, t2, !univar_pairs)::cstrs end | (Tconstr(p1, tl1, _), _) when private_abbrev env p1 -> subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs | (Tobject (f1, _), Tobject (f2, _)) when is_Tvar (object_row f1) && is_Tvar (object_row f2) -> (* Same row variable implies same object. *) (trace, t1, t2, !univar_pairs)::cstrs | (Tobject (f1, _), Tobject (f2, _)) -> subtype_fields env trace f1 f2 cstrs | (Tvariant row1, Tvariant row2) -> begin try subtype_row env trace row1 row2 cstrs with Exit -> (trace, t1, t2, !univar_pairs)::cstrs end | (Tpoly (u1, []), Tpoly (u2, [])) -> subtype_rec env trace u1 u2 cstrs | (Tpoly (u1, tl1), Tpoly (u2, [])) -> let _, u1' = instance_poly false tl1 u1 in subtype_rec env trace u1' u2 cstrs | (Tpoly (u1, tl1), Tpoly (u2,tl2)) -> begin try enter_poly env univar_pairs u1 tl1 u2 tl2 (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs) with Unify _ -> (trace, t1, t2, !univar_pairs)::cstrs end | (Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2)) when Path.same p1 p2 && included nl2 nl1 -> List.map2 (fun t1 t2 -> (trace, t1, t2, !univar_pairs)) (extract_assoc nl2 nl1 tl1) tl2 @ cstrs | (_, _) -> (trace, t1, t2, !univar_pairs)::cstrs end and subtype_list env trace tl1 tl2 cstrs = if List.length tl1 <> List.length tl2 then subtype_error env trace; List.fold_left2 (fun cstrs t1 t2 -> subtype_rec env ((t1, t2)::trace) t1 t2 cstrs) cstrs tl1 tl2 and subtype_fields env trace ty1 ty2 cstrs = (* Assume that either rest1 or rest2 is not Tvar *) let (fields1, rest1) = flatten_fields ty1 in let (fields2, rest2) = flatten_fields ty2 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in let cstrs = if rest2.desc = Tnil then cstrs else if miss1 = [] then subtype_rec env ((rest1, rest2)::trace) rest1 rest2 cstrs else (trace, build_fields (repr ty1).level miss1 rest1, rest2, !univar_pairs) :: cstrs in let cstrs = if miss2 = [] then cstrs else (trace, rest1, build_fields (repr ty2).level miss2 (newvar ()), !univar_pairs) :: cstrs in List.fold_left (fun cstrs (_, k1, t1, k2, t2) -> (* Theses fields are always present *) subtype_rec env ((t1, t2)::trace) t1 t2 cstrs) cstrs pairs and subtype_row env trace row1 row2 cstrs = let row1 = row_repr row1 and row2 = row_repr row2 in let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in let more1 = repr row1.row_more and more2 = repr row2.row_more in match more1.desc, more2.desc with Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 -> subtype_rec env ((more1,more2)::trace) more1 more2 cstrs | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil) when row1.row_closed && r1 = [] -> List.fold_left (fun cstrs (_,f1,f2) -> match row_field_repr f1, row_field_repr f2 with (Rpresent None|Reither(true,_,_,_)), Rpresent None -> cstrs | Rpresent(Some t1), Rpresent(Some t2) -> subtype_rec env ((t1, t2)::trace) t1 t2 cstrs | Reither(false, t1::_, _, _), Rpresent(Some t2) -> subtype_rec env ((t1, t2)::trace) t1 t2 cstrs | Rabsent, _ -> cstrs | _ -> raise Exit) cstrs pairs | Tunivar _, Tunivar _ when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] -> let cstrs = subtype_rec env ((more1,more2)::trace) more1 more2 cstrs in List.fold_left (fun cstrs (_,f1,f2) -> match row_field_repr f1, row_field_repr f2 with Rpresent None, Rpresent None | Reither(true,[],_,_), Reither(true,[],_,_) | Rabsent, Rabsent -> cstrs | Rpresent(Some t1), Rpresent(Some t2) | Reither(false,[t1],_,_), Reither(false,[t2],_,_) -> subtype_rec env ((t1, t2)::trace) t1 t2 cstrs | _ -> raise Exit) cstrs pairs | _ -> raise Exit let subtype env ty1 ty2 = TypePairs.clear subtypes; univar_pairs := []; (* Build constraint set. *) let cstrs = subtype_rec env [(ty1, ty2)] ty1 ty2 [] in TypePairs.clear subtypes; (* Enforce constraints. *) function () -> List.iter (function (trace0, t1, t2, pairs) -> try unify_pairs (ref env) t1 t2 pairs with Unify trace -> raise (Subtype (expand_trace env (List.rev trace0), List.tl (List.tl trace)))) (List.rev cstrs) (*******************) (* Miscellaneous *) (*******************) (* Utility for printing. The resulting type is not used in computation. *) let rec unalias_object ty = let ty = repr ty in match ty.desc with Tfield (s, k, t1, t2) -> newty2 ty.level (Tfield (s, k, t1, unalias_object t2)) | Tvar _ | Tnil -> newty2 ty.level ty.desc | Tunivar _ -> ty | Tconstr _ -> newvar2 ty.level | _ -> assert false let unalias ty = let ty = repr ty in match ty.desc with Tvar _ | Tunivar _ -> ty | Tvariant row -> let row = row_repr row in let more = row.row_more in newty2 ty.level (Tvariant {row with row_more = newty2 more.level more.desc}) | Tobject (ty, nm) -> newty2 ty.level (Tobject (unalias_object ty, nm)) | _ -> newty2 ty.level ty.desc (* Return the arity (as for curried functions) of the given type. *) let rec arity ty = match (repr ty).desc with Tarrow(_, t1, t2, _) -> 1 + arity t2 | _ -> 0 (* Check whether an abbreviation expands to itself. *) let cyclic_abbrev env id ty = let rec check_cycle seen ty = let ty = repr ty in match ty.desc with Tconstr (p, tl, abbrev) -> p = Path.Pident id || List.memq ty seen || begin try check_cycle (ty :: seen) (expand_abbrev_opt env ty) with Cannot_expand -> false | Unify _ -> true end | _ -> false in check_cycle [] ty (* Normalize a type before printing, saving... *) (* Cannot use mark_type because deep_occur uses it too *) let rec normalize_type_rec env visited ty = let ty = repr ty in if not (TypeSet.mem ty !visited) then begin visited := TypeSet.add ty !visited; begin match ty.desc with | Tvariant row -> let row = row_repr row in let fields = List.map (fun (l,f0) -> let f = row_field_repr f0 in l, match f with Reither(b, ty::(_::_ as tyl), m, e) -> let tyl' = List.fold_left (fun tyl ty -> if List.exists (fun ty' -> equal env false [ty] [ty']) tyl then tyl else ty::tyl) [ty] tyl in if f != f0 || List.length tyl' < List.length tyl then Reither(b, List.rev tyl', m, e) else f | _ -> f) row.row_fields in let fields = List.sort (fun (p,_) (q,_) -> compare p q) (List.filter (fun (_,fi) -> fi <> Rabsent) fields) in log_type ty; ty.desc <- Tvariant {row with row_fields = fields} | Tobject (fi, nm) -> begin match !nm with | None -> () | Some (n, v :: l) -> if deep_occur ty (newgenty (Ttuple l)) then (* The abbreviation may be hiding something, so remove it *) set_name nm None else let v' = repr v in begin match v'.desc with | Tvar _ | Tunivar _ -> if v' != v then set_name nm (Some (n, v' :: l)) | Tnil -> log_type ty; ty.desc <- Tconstr (n, l, ref Mnil) | _ -> set_name nm None end | _ -> fatal_error "Ctype.normalize_type_rec" end; let fi = repr fi in if fi.level < lowest_level then () else let fields, row = flatten_fields fi in let fi' = build_fields fi.level fields row in log_type ty; fi.desc <- fi'.desc | _ -> () end; iter_type_expr (normalize_type_rec env visited) ty end let normalize_type env ty = normalize_type_rec env (ref TypeSet.empty) ty (*************************) (* Remove dependencies *) (*************************) (* Variables are left unchanged. Other type nodes are duplicated, with levels set to generic level. We cannot use Tsubst here, because unification may be called by expand_abbrev. *) let nondep_hash = TypeHash.create 47 let nondep_variants = TypeHash.create 17 let clear_hash () = TypeHash.clear nondep_hash; TypeHash.clear nondep_variants let rec nondep_type_rec env id ty = match ty.desc with Tvar _ | Tunivar _ -> ty | Tlink ty -> nondep_type_rec env id ty | _ -> try TypeHash.find nondep_hash ty with Not_found -> let ty' = newgenvar () in (* Stub *) TypeHash.add nondep_hash ty ty'; ty'.desc <- begin match ty.desc with | Tconstr(p, tl, abbrev) -> if Path.isfree id p then begin try Tlink (nondep_type_rec env id (expand_abbrev env (newty2 ty.level ty.desc))) (* The [Tlink] is important. The expanded type may be a variable, or may not be completely copied yet (recursive type), so one cannot just take its description. *) with Cannot_expand | Unify _ -> raise Not_found end else Tconstr(p, List.map (nondep_type_rec env id) tl, ref Mnil) | Tpackage(p, _, _) when Path.isfree id p -> raise Not_found | Tobject (t1, name) -> Tobject (nondep_type_rec env id t1, ref (match !name with None -> None | Some (p, tl) -> if Path.isfree id p then None else Some (p, List.map (nondep_type_rec env id) tl))) | Tvariant row -> let row = row_repr row in let more = repr row.row_more in (* We must keep sharing according to the row variable *) begin try let ty2 = TypeHash.find nondep_variants more in (* This variant type has been already copied *) TypeHash.add nondep_hash ty ty2; Tlink ty2 with Not_found -> (* Register new type first for recursion *) TypeHash.add nondep_variants more ty'; let static = static_row row in let more' = if static then newgenty Tnil else more in (* Return a new copy *) let row = copy_row (nondep_type_rec env id) true row true more' in match row.row_name with Some (p, tl) when Path.isfree id p -> Tvariant {row with row_name = None} | _ -> Tvariant row end | _ -> copy_type_desc (nondep_type_rec env id) ty.desc end; ty' let nondep_type env id ty = try let ty' = nondep_type_rec env id ty in clear_hash (); ty' with Not_found -> clear_hash (); raise Not_found let unroll_abbrev id tl ty = let ty = repr ty and path = Path.Pident id in if is_Tvar ty || (List.exists (deep_occur ty) tl) || is_object_type path then ty else let ty' = newty2 ty.level ty.desc in link_type ty (newty2 ty.level (Tconstr (path, tl, ref Mnil))); ty' (* Preserve sharing inside type declarations. *) let nondep_type_decl env mid id is_covariant decl = try let params = List.map (nondep_type_rec env mid) decl.type_params in let tk = try match decl.type_kind with Type_abstract -> Type_abstract | Type_variant cstrs -> Type_variant (List.map (fun (c, tl,ret_type_opt) -> let ret_type_opt = may_map (nondep_type_rec env mid) ret_type_opt in (c, List.map (nondep_type_rec env mid) tl,ret_type_opt)) cstrs) | Type_record(lbls, rep) -> Type_record (List.map (fun (c, mut, t) -> (c, mut, nondep_type_rec env mid t)) lbls, rep) with Not_found when is_covariant -> Type_abstract and tm = try match decl.type_manifest with None -> None | Some ty -> Some (unroll_abbrev id params (nondep_type_rec env mid ty)) with Not_found when is_covariant -> None in clear_hash (); let priv = match tm with | Some ty when Btype.has_constr_row ty -> Private | _ -> decl.type_private in { type_params = params; type_arity = decl.type_arity; type_kind = tk; type_manifest = tm; type_private = priv; type_variance = decl.type_variance; type_newtype_level = None; type_loc = decl.type_loc; } with Not_found -> clear_hash (); raise Not_found (* Preserve sharing inside class types. *) let nondep_class_signature env id sign = { cty_self = nondep_type_rec env id sign.cty_self; cty_vars = Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t)) sign.cty_vars; cty_concr = sign.cty_concr; cty_inher = List.map (fun (p,tl) -> (p, List.map (nondep_type_rec env id) tl)) sign.cty_inher } let rec nondep_class_type env id = function Cty_constr (p, _, cty) when Path.isfree id p -> nondep_class_type env id cty | Cty_constr (p, tyl, cty) -> Cty_constr (p, List.map (nondep_type_rec env id) tyl, nondep_class_type env id cty) | Cty_signature sign -> Cty_signature (nondep_class_signature env id sign) | Cty_fun (l, ty, cty) -> Cty_fun (l, nondep_type_rec env id ty, nondep_class_type env id cty) let nondep_class_declaration env id decl = assert (not (Path.isfree id decl.cty_path)); let decl = { cty_params = List.map (nondep_type_rec env id) decl.cty_params; cty_variance = decl.cty_variance; cty_type = nondep_class_type env id decl.cty_type; cty_path = decl.cty_path; cty_new = begin match decl.cty_new with None -> None | Some ty -> Some (nondep_type_rec env id ty) end } in clear_hash (); decl let nondep_cltype_declaration env id decl = assert (not (Path.isfree id decl.clty_path)); let decl = { clty_params = List.map (nondep_type_rec env id) decl.clty_params; clty_variance = decl.clty_variance; clty_type = nondep_class_type env id decl.clty_type; clty_path = decl.clty_path } in clear_hash (); decl (* collapse conjonctive types in class parameters *) let rec collapse_conj env visited ty = let ty = repr ty in if List.memq ty visited then () else let visited = ty :: visited in match ty.desc with Tvariant row -> let row = row_repr row in List.iter (fun (l,fi) -> match row_field_repr fi with Reither (c, t1::(_::_ as tl), m, e) -> List.iter (unify env t1) tl; set_row_field e (Reither (c, [t1], m, ref None)) | _ -> ()) row.row_fields; iter_row (collapse_conj env visited) row | _ -> iter_type_expr (collapse_conj env visited) ty let collapse_conj_params env params = List.iter (collapse_conj env []) params mingw-ocaml/ocaml/typing/typeclass.ml0000644000175000017500000017011612124403242017340 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Misc open Parsetree open Asttypes open Path open Types open Typecore open Typetexp open Format type error = Unconsistent_constraint of (type_expr * type_expr) list | Field_type_mismatch of string * string * (type_expr * type_expr) list | Structure_expected of class_type | Cannot_apply of class_type | Apply_wrong_label of label | Pattern_type_clash of type_expr | Repeated_parameter | Unbound_class_2 of Longident.t | Unbound_class_type_2 of Longident.t | Abbrev_type_clash of type_expr * type_expr * type_expr | Constructor_type_mismatch of string * (type_expr * type_expr) list | Virtual_class of bool * string list * string list | Parameter_arity_mismatch of Longident.t * int * int | Parameter_mismatch of (type_expr * type_expr) list | Bad_parameters of Ident.t * type_expr * type_expr | Class_match_failure of Ctype.class_match_failure list | Unbound_val of string | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure | Make_nongen_seltype of type_expr | Non_generalizable_class of Ident.t * Types.class_declaration | Cannot_coerce_self of type_expr | Non_collapsable_conjunction of Ident.t * Types.class_declaration * (type_expr * type_expr) list | Final_self_clash of (type_expr * type_expr) list | Mutability_mismatch of string * mutable_flag | No_overriding of string * string open Typedtree let ctyp desc typ env loc = { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env } let cltyp desc typ env loc = { cltyp_desc = desc; cltyp_type = typ; cltyp_loc = loc; cltyp_env = env } let mkcf desc loc = { cf_desc = desc; cf_loc = loc } let mkctf desc loc = { ctf_desc = desc; ctf_loc = loc } exception Error of Location.t * error (**********************) (* Useful constants *) (**********************) (* Self type have a dummy private method, thus preventing it to become closed. *) let dummy_method = Btype.dummy_method (* Path associated to the temporary class type of a class being typed (its constructor is not available). *) let unbound_class = Path.Pident (Ident.create "") (************************************) (* Some operations on class types *) (************************************) (* Fully expand the head of a class type *) let rec scrape_class_type = function Cty_constr (_, _, cty) -> scrape_class_type cty | cty -> cty (* Generalize a class type *) let rec generalize_class_type = function Cty_constr (_, params, cty) -> List.iter Ctype.generalize params; generalize_class_type cty | Cty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} -> Ctype.generalize sty; Vars.iter (fun _ (_, _, ty) -> Ctype.generalize ty) vars; List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher | Cty_fun (_, ty, cty) -> Ctype.generalize ty; generalize_class_type cty (* Return the virtual methods of a class type *) let virtual_methods sign = let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in List.fold_left (fun virt (lab, _, _) -> if lab = dummy_method then virt else if Concr.mem lab sign.cty_concr then virt else lab::virt) [] fields (* Return the constructor type associated to a class type *) let rec constructor_type constr cty = match cty with Cty_constr (_, _, cty) -> constructor_type constr cty | Cty_signature sign -> constr | Cty_fun (l, ty, cty) -> Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok)) let rec class_body cty = match cty with Cty_constr (_, _, cty') -> cty (* Only class bodies can be abbreviated *) | Cty_signature sign -> cty | Cty_fun (_, ty, cty) -> class_body cty let rec extract_constraints cty = let sign = Ctype.signature_of_class_type cty in (Vars.fold (fun lab _ vars -> lab :: vars) sign.cty_vars [], begin let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in List.fold_left (fun meths (lab, _, _) -> if lab = dummy_method then meths else lab::meths) [] fields end, sign.cty_concr) let rec abbreviate_class_type path params cty = match cty with Cty_constr (_, _, _) | Cty_signature _ -> Cty_constr (path, params, cty) | Cty_fun (l, ty, cty) -> Cty_fun (l, ty, abbreviate_class_type path params cty) let rec closed_class_type = function Cty_constr (_, params, _) -> List.for_all Ctype.closed_schema params | Cty_signature sign -> Ctype.closed_schema sign.cty_self && Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc) sign.cty_vars true | Cty_fun (_, ty, cty) -> Ctype.closed_schema ty && closed_class_type cty let closed_class cty = List.for_all Ctype.closed_schema cty.cty_params && closed_class_type cty.cty_type let rec limited_generalize rv = function Cty_constr (path, params, cty) -> List.iter (Ctype.limited_generalize rv) params; limited_generalize rv cty | Cty_signature sign -> Ctype.limited_generalize rv sign.cty_self; Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty) sign.cty_vars; List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl) sign.cty_inher | Cty_fun (_, ty, cty) -> Ctype.limited_generalize rv ty; limited_generalize rv cty (* Record a class type *) let rc node = Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node); Stypes.record (Stypes.Ti_class node); (* moved to genannot *) node (***********************************) (* Primitives for typing classes *) (***********************************) (* Enter a value in the method environment only *) let enter_met_env ?check loc lab kind ty val_env met_env par_env = let (id, val_env) = Env.enter_value lab {val_type = ty; val_kind = Val_unbound; Types.val_loc = loc} val_env in (id, val_env, Env.add_value ?check id {val_type = ty; val_kind = kind; Types.val_loc = loc} met_env, Env.add_value id {val_type = ty; val_kind = Val_unbound; Types.val_loc = loc} par_env) (* Enter an instance variable in the environment *) let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc = let instance = Ctype.instance val_env in let (id, virt) = try let (id, mut', virt', ty') = Vars.find lab !vars in if mut' <> mut then raise (Error(loc, Mutability_mismatch(lab, mut))); Ctype.unify val_env (instance ty) (instance ty'); (if not inh then Some id else None), (if virt' = Concrete then virt' else virt) with Ctype.Unify tr -> raise (Error(loc, Field_type_mismatch("instance variable", lab, tr))) | Not_found -> None, virt in let (id, _, _, _) as result = match id with Some id -> (id, val_env, met_env, par_env) | None -> enter_met_env Location.none lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env in vars := Vars.add lab (id, mut, virt, ty) !vars; result let concr_vals vars = Vars.fold (fun id (_, vf, _) s -> if vf = Virtual then s else Concr.add id s) vars Concr.empty let inheritance self_type env ovf concr_meths warn_vals loc parent = match scrape_class_type parent with Cty_signature cl_sig -> (* Methods *) begin try Ctype.unify env self_type cl_sig.cty_self with Ctype.Unify trace -> match trace with _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem -> raise(Error(loc, Field_type_mismatch ("method", n, rem))) | _ -> assert false end; (* Overriding *) let over_meths = Concr.inter cl_sig.cty_concr concr_meths in let concr_vals = concr_vals cl_sig.cty_vars in let over_vals = Concr.inter concr_vals warn_vals in begin match ovf with Some Fresh -> let cname = match parent with Cty_constr (p, _, _) -> Path.name p | _ -> "inherited" in if not (Concr.is_empty over_meths) then Location.prerr_warning loc (Warnings.Method_override (cname :: Concr.elements over_meths)); if not (Concr.is_empty over_vals) then Location.prerr_warning loc (Warnings.Instance_variable_override (cname :: Concr.elements over_vals)); | Some Override when Concr.is_empty over_meths && Concr.is_empty over_vals -> raise (Error(loc, No_overriding ("",""))) | _ -> () end; let concr_meths = Concr.union cl_sig.cty_concr concr_meths and warn_vals = Concr.union concr_vals warn_vals in (cl_sig, concr_meths, warn_vals) | _ -> raise(Error(loc, Structure_expected parent)) let virtual_method val_env meths self_type lab priv sty loc = let (_, ty') = Ctype.filter_self_method val_env lab priv meths self_type in let cty = transl_simple_type val_env false sty in let ty = cty.ctyp_type in begin try Ctype.unify val_env ty ty' with Ctype.Unify trace -> raise(Error(loc, Field_type_mismatch ("method", lab, trace))); end; cty let delayed_meth_specs = ref [] let declare_method val_env meths self_type lab priv sty loc = let (_, ty') = Ctype.filter_self_method val_env lab priv meths self_type in let unif ty = try Ctype.unify val_env ty ty' with Ctype.Unify trace -> raise(Error(loc, Field_type_mismatch ("method", lab, trace))) in match sty.ptyp_desc, priv with Ptyp_poly ([],sty'), Public -> (* TODO: we moved the [transl_simple_type_univars] outside of the lazy, so that we can get an immediate value. Is that correct ? Ask Jacques. *) let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in delayed_meth_specs := lazy ( let cty = transl_simple_type_univars val_env sty' in let ty = cty.ctyp_type in unif ty; returned_cty.ctyp_desc <- Ttyp_poly ([], cty); returned_cty.ctyp_type <- ty; ) :: !delayed_meth_specs; returned_cty | _ -> let cty = transl_simple_type val_env false sty in let ty = cty.ctyp_type in unif ty; cty let type_constraint val_env sty sty' loc = let cty = transl_simple_type val_env false sty in let ty = cty.ctyp_type in let cty' = transl_simple_type val_env false sty' in let ty' = cty'.ctyp_type in begin try Ctype.unify val_env ty ty' with Ctype.Unify trace -> raise(Error(loc, Unconsistent_constraint trace)); end; (cty, cty') let make_method self_loc cl_num expr = let mkpat d = { ppat_desc = d; ppat_loc = self_loc } in let mkid s = mkloc s self_loc in { pexp_desc = Pexp_function ("", None, [mkpat (Ppat_alias (mkpat (Ppat_var (mkid "self-*")), mkid ("self-" ^ cl_num))), expr]); pexp_loc = expr.pexp_loc } (*******************************) let add_val env loc lab (mut, virt, ty) val_sig = let virt = try let (mut', virt', ty') = Vars.find lab val_sig in if virt' = Concrete then virt' else virt with Not_found -> virt in Vars.add lab (mut, virt, ty) val_sig let rec class_type_field env self_type meths (fields, val_sig, concr_meths, inher) ctf = let loc = ctf.pctf_loc in match ctf.pctf_desc with Pctf_inher sparent -> let parent = class_type env sparent in let inher = match parent.cltyp_type with Cty_constr (p, tl, _) -> (p, tl) :: inher | _ -> inher in let (cl_sig, concr_meths, _) = inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc parent.cltyp_type in let val_sig = Vars.fold (add_val env sparent.pcty_loc) cl_sig.cty_vars val_sig in (mkctf (Tctf_inher parent) loc :: fields, val_sig, concr_meths, inher) | Pctf_val (lab, mut, virt, sty) -> let cty = transl_simple_type env false sty in let ty = cty.ctyp_type in (mkctf (Tctf_val (lab, mut, virt, cty)) loc :: fields, add_val env ctf.pctf_loc lab (mut, virt, ty) val_sig, concr_meths, inher) | Pctf_virt (lab, priv, sty) -> let cty = declare_method env meths self_type lab priv sty ctf.pctf_loc in (mkctf (Tctf_virt (lab, priv, cty)) loc :: fields, val_sig, concr_meths, inher) | Pctf_meth (lab, priv, sty) -> let cty = declare_method env meths self_type lab priv sty ctf.pctf_loc in (mkctf (Tctf_meth (lab, priv, cty)) loc :: fields, val_sig, Concr.add lab concr_meths, inher) | Pctf_cstr (sty, sty') -> let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in (mkctf (Tctf_cstr (cty, cty')) loc :: fields, val_sig, concr_meths, inher) and class_signature env sty sign loc = let meths = ref Meths.empty in let self_cty = transl_simple_type env false sty in let self_cty = { self_cty with ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in let self_type = self_cty.ctyp_type in (* Check that the binder is a correct type, and introduce a dummy method preventing self type from being closed. *) let dummy_obj = Ctype.newvar () in Ctype.unify env (Ctype.filter_method env dummy_method Private dummy_obj) (Ctype.newty (Ttuple [])); begin try Ctype.unify env self_type dummy_obj with Ctype.Unify _ -> raise(Error(sty.ptyp_loc, Pattern_type_clash self_type)) end; (* Class type fields *) let (fields, val_sig, concr_meths, inher) = List.fold_left (class_type_field env self_type meths) ([], Vars.empty, Concr.empty, []) sign in let cty = {cty_self = self_type; cty_vars = val_sig; cty_concr = concr_meths; cty_inher = inher} in { csig_self = self_cty; csig_fields = fields; csig_type = cty; csig_loc = loc; } and class_type env scty = let loc = scty.pcty_loc in match scty.pcty_desc with Pcty_constr (lid, styl) -> let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in if Path.same decl.clty_path unbound_class then raise(Error(scty.pcty_loc, Unbound_class_type_2 lid.txt)); let (params, clty) = Ctype.instance_class decl.clty_params decl.clty_type in if List.length params <> List.length styl then raise(Error(scty.pcty_loc, Parameter_arity_mismatch (lid.txt, List.length params, List.length styl))); let ctys = List.map2 (fun sty ty -> let cty' = transl_simple_type env false sty in let ty' = cty'.ctyp_type in begin try Ctype.unify env ty' ty with Ctype.Unify trace -> raise(Error(sty.ptyp_loc, Parameter_mismatch trace)) end; cty' ) styl params in let typ = Cty_constr (path, params, clty) in cltyp (Tcty_constr ( path, lid , ctys)) typ env loc | Pcty_signature pcsig -> let clsig = class_signature env pcsig.pcsig_self pcsig.pcsig_fields pcsig.pcsig_loc in let typ = Cty_signature clsig.csig_type in cltyp (Tcty_signature clsig) typ env loc | Pcty_fun (l, sty, scty) -> let cty = transl_simple_type env false sty in let ty = cty.ctyp_type in let clty = class_type env scty in let typ = Cty_fun (l, ty, clty.cltyp_type) in cltyp (Tcty_fun (l, cty, clty)) typ env loc let class_type env scty = delayed_meth_specs := []; let cty = class_type env scty in List.iter Lazy.force (List.rev !delayed_meth_specs); delayed_meth_specs := []; cty (*******************************) let rec class_field self_loc cl_num self_type meths vars (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher) cf = let loc = cf.pcf_loc in match cf.pcf_desc with Pcf_inher (ovf, sparent, super) -> let parent = class_expr cl_num val_env par_env sparent in let inher = match parent.cl_type with Cty_constr (p, tl, _) -> (p, tl) :: inher | _ -> inher in let (cl_sig, concr_meths, warn_vals) = inheritance self_type val_env (Some ovf) concr_meths warn_vals sparent.pcl_loc parent.cl_type in (* Variables *) let (val_env, met_env, par_env, inh_vars) = Vars.fold (fun lab info (val_env, met_env, par_env, inh_vars) -> let mut, vr, ty = info in let (id, val_env, met_env, par_env) = enter_val cl_num vars true lab mut vr ty val_env met_env par_env sparent.pcl_loc in (val_env, met_env, par_env, (lab, id) :: inh_vars)) cl_sig.cty_vars (val_env, met_env, par_env, []) in (* Inherited concrete methods *) let inh_meths = Concr.fold (fun lab rem -> (lab, Ident.create lab)::rem) cl_sig.cty_concr [] in (* Super *) let (val_env, met_env, par_env) = match super with None -> (val_env, met_env, par_env) | Some name -> let (id, val_env, met_env, par_env) = enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s) sparent.pcl_loc name (Val_anc (inh_meths, cl_num)) self_type val_env met_env par_env in (val_env, met_env, par_env) in (val_env, met_env, par_env, lazy (mkcf (Tcf_inher (ovf, parent, super, inh_vars, inh_meths)) loc) :: fields, concr_meths, warn_vals, inher) | Pcf_valvirt (lab, mut, styp) -> if !Clflags.principal then Ctype.begin_def (); let cty = Typetexp.transl_simple_type val_env false styp in let ty = cty.ctyp_type in if !Clflags.principal then begin Ctype.end_def (); Ctype.generalize_structure ty end; let (id, val_env, met_env', par_env) = enter_val cl_num vars false lab.txt mut Virtual ty val_env met_env par_env loc in (val_env, met_env', par_env, lazy (mkcf (Tcf_val (lab.txt, lab, mut, id, Tcfk_virtual cty, met_env' == met_env)) loc) :: fields, concr_meths, warn_vals, inher) | Pcf_val (lab, mut, ovf, sexp) -> if Concr.mem lab.txt warn_vals then begin if ovf = Fresh then Location.prerr_warning lab.loc (Warnings.Instance_variable_override[lab.txt]) end else begin if ovf = Override then raise(Error(loc, No_overriding ("instance variable", lab.txt))) end; if !Clflags.principal then Ctype.begin_def (); let exp = try type_exp val_env sexp with Ctype.Unify [(ty, _)] -> raise(Error(loc, Make_nongen_seltype ty)) in if !Clflags.principal then begin Ctype.end_def (); Ctype.generalize_structure exp.exp_type end; let (id, val_env, met_env', par_env) = enter_val cl_num vars false lab.txt mut Concrete exp.exp_type val_env met_env par_env loc in (val_env, met_env', par_env, lazy (mkcf (Tcf_val (lab.txt, lab, mut, id, Tcfk_concrete exp, met_env' == met_env)) loc) :: fields, concr_meths, Concr.add lab.txt warn_vals, inher) | Pcf_virt (lab, priv, sty) -> let cty = virtual_method val_env meths self_type lab.txt priv sty loc in (val_env, met_env, par_env, lazy (mkcf(Tcf_meth (lab.txt, lab, priv, Tcfk_virtual cty, true)) loc) ::fields, concr_meths, warn_vals, inher) | Pcf_meth (lab, priv, ovf, expr) -> if Concr.mem lab.txt concr_meths then begin if ovf = Fresh then Location.prerr_warning loc (Warnings.Method_override [lab.txt]) end else begin if ovf = Override then raise(Error(loc, No_overriding("method", lab.txt))) end; let (_, ty) = Ctype.filter_self_method val_env lab.txt priv meths self_type in begin try match expr.pexp_desc with Pexp_poly (sbody, sty) -> begin match sty with None -> () | Some sty -> let cty' = Typetexp.transl_simple_type val_env false sty in let ty' = cty'.ctyp_type in Ctype.unify val_env ty' ty end; begin match (Ctype.repr ty).desc with Tvar _ -> let ty' = Ctype.newvar () in Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty; Ctype.unify val_env (type_approx val_env sbody) ty' | Tpoly (ty1, tl) -> let _, ty1' = Ctype.instance_poly false tl ty1 in let ty2 = type_approx val_env sbody in Ctype.unify val_env ty2 ty1' | _ -> assert false end | _ -> assert false with Ctype.Unify trace -> raise(Error(loc, Field_type_mismatch ("method", lab.txt, trace))) end; let meth_expr = make_method self_loc cl_num expr in (* backup variables for Pexp_override *) let vars_local = !vars in let field = lazy begin let meth_type = Btype.newgenty (Tarrow("", self_type, ty, Cok)) in Ctype.raise_nongen_level (); vars := vars_local; let texp = type_expect met_env meth_expr meth_type in Ctype.end_def (); mkcf (Tcf_meth (lab.txt, lab, priv, Tcfk_concrete texp, match ovf with Override -> true | Fresh -> false)) loc end in (val_env, met_env, par_env, field::fields, Concr.add lab.txt concr_meths, warn_vals, inher) | Pcf_constr (sty, sty') -> let (cty, cty') = type_constraint val_env sty sty' loc in (val_env, met_env, par_env, lazy (mkcf (Tcf_constr (cty, cty')) loc) :: fields, concr_meths, warn_vals, inher) | Pcf_init expr -> let expr = make_method self_loc cl_num expr in let vars_local = !vars in let field = lazy begin Ctype.raise_nongen_level (); let meth_type = Ctype.newty (Tarrow ("", self_type, Ctype.instance_def Predef.type_unit, Cok)) in vars := vars_local; let texp = type_expect met_env expr meth_type in Ctype.end_def (); mkcf (Tcf_init texp) loc end in (val_env, met_env, par_env, field::fields, concr_meths, warn_vals, inher) and class_structure cl_num final val_env met_env loc { pcstr_pat = spat; pcstr_fields = str } = (* Environment for substructures *) let par_env = met_env in (* Location of self. Used for locations of self arguments *) let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in (* Self type, with a dummy method preventing it from being closed/escaped. *) let self_type = Ctype.newvar () in Ctype.unify val_env (Ctype.filter_method val_env dummy_method Private self_type) (Ctype.newty (Ttuple [])); (* Private self is used for private method calls *) let private_self = if final then Ctype.newvar () else self_type in (* Self binder *) let (pat, meths, vars, val_env, meth_env, par_env) = type_self_pattern cl_num private_self val_env met_env par_env spat in let public_self = pat.pat_type in (* Check that the binder has a correct type *) let ty = if final then Ctype.newty (Tobject (Ctype.newvar(), ref None)) else self_type in begin try Ctype.unify val_env public_self ty with Ctype.Unify _ -> raise(Error(spat.ppat_loc, Pattern_type_clash public_self)) end; let get_methods ty = (fst (Ctype.flatten_fields (Ctype.object_fields (Ctype.expand_head val_env ty)))) in if final then begin (* Copy known information to still empty self_type *) List.iter (fun (lab,kind,ty) -> let k = if Btype.field_kind_repr kind = Fpresent then Public else Private in try Ctype.unify val_env ty (Ctype.filter_method val_env lab k self_type) with _ -> assert false) (get_methods public_self) end; (* Typing of class fields *) let (_, _, _, fields, concr_meths, _, inher) = List.fold_left (class_field self_loc cl_num self_type meths vars) (val_env, meth_env, par_env, [], Concr.empty, Concr.empty, []) str in Ctype.unify val_env self_type (Ctype.newvar ()); let sign = {cty_self = public_self; cty_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars; cty_concr = concr_meths; cty_inher = inher} in let methods = get_methods self_type in let priv_meths = List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent) methods in if final then begin (* Unify private_self and a copy of self_type. self_type will not be modified after this point *) Ctype.close_object self_type; let mets = virtual_methods {sign with cty_self = self_type} in let vals = Vars.fold (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) sign.cty_vars [] in if mets <> [] || vals <> [] then raise(Error(loc, Virtual_class(true, mets, vals))); let self_methods = List.fold_right (fun (lab,kind,ty) rem -> if lab = dummy_method then (* allow public self and private self to be unified *) match Btype.field_kind_repr kind with Fvar r -> Btype.set_kind r Fabsent; rem | _ -> rem else Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem))) methods (Ctype.newty Tnil) in begin try Ctype.unify val_env private_self (Ctype.newty (Tobject(self_methods, ref None))); Ctype.unify val_env public_self self_type with Ctype.Unify trace -> raise(Error(loc, Final_self_clash trace)) end; end; (* Typing of method bodies *) if !Clflags.principal then List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods; let fields = List.map Lazy.force (List.rev fields) in if !Clflags.principal then List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) methods; let meths = Meths.map (function (id, ty) -> id) !meths in (* Check for private methods made public *) let pub_meths' = List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent) (get_methods public_self) in let names = List.map (fun (x,_,_) -> x) in let l1 = names priv_meths and l2 = names pub_meths' in let added = List.filter (fun x -> List.mem x l1) l2 in if added <> [] then Location.prerr_warning loc (Warnings.Implicit_public_methods added); let sign = if final then sign else {sign with cty_self = Ctype.expand_head val_env public_self} in { cstr_pat = pat; cstr_fields = fields; cstr_type = sign; cstr_meths = meths}, sign (* redondant, since already in cstr_type *) and class_expr cl_num val_env met_env scl = match scl.pcl_desc with Pcl_constr (lid, styl) -> let (path, decl) = Typetexp.find_class val_env scl.pcl_loc lid.txt in if Path.same decl.cty_path unbound_class then raise(Error(scl.pcl_loc, Unbound_class_2 lid.txt)); let tyl = List.map (fun sty -> transl_simple_type val_env false sty) styl in let (params, clty) = Ctype.instance_class decl.cty_params decl.cty_type in let clty' = abbreviate_class_type path params clty in if List.length params <> List.length tyl then raise(Error(scl.pcl_loc, Parameter_arity_mismatch (lid.txt, List.length params, List.length tyl))); List.iter2 (fun cty' ty -> let ty' = cty'.ctyp_type in try Ctype.unify val_env ty' ty with Ctype.Unify trace -> raise(Error(cty'.ctyp_loc, Parameter_mismatch trace))) tyl params; let cl = rc {cl_desc = Tcl_ident (path, lid, tyl); cl_loc = scl.pcl_loc; cl_type = clty'; cl_env = val_env} in let (vals, meths, concrs) = extract_constraints clty in rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs); cl_loc = scl.pcl_loc; cl_type = clty'; cl_env = val_env} | Pcl_structure cl_str -> let (desc, ty) = class_structure cl_num false val_env met_env scl.pcl_loc cl_str in rc {cl_desc = Tcl_structure desc; cl_loc = scl.pcl_loc; cl_type = Cty_signature ty; cl_env = val_env} | Pcl_fun (l, Some default, spat, sbody) -> let loc = default.pexp_loc in let scases = [{ppat_loc = loc; ppat_desc = Ppat_construct ( mknoloc (Longident.(Ldot (Lident"*predef*", "Some"))), Some{ppat_loc = loc; ppat_desc = Ppat_var (mknoloc "*sth*")}, false)}, {pexp_loc = loc; pexp_desc = Pexp_ident(mknoloc (Longident.Lident"*sth*"))}; {ppat_loc = loc; ppat_desc = Ppat_construct(mknoloc (Longident.(Ldot (Lident"*predef*", "None"))), None, false)}, default] in let smatch = {pexp_loc = loc; pexp_desc = Pexp_match({pexp_loc = loc; pexp_desc = Pexp_ident(mknoloc (Longident.Lident"*opt*"))}, scases)} in let sfun = {pcl_loc = scl.pcl_loc; pcl_desc = Pcl_fun(l, None, {ppat_loc = loc; ppat_desc = Ppat_var (mknoloc "*opt*")}, {pcl_loc = scl.pcl_loc; pcl_desc = Pcl_let(Default, [spat, smatch], sbody)})} in class_expr cl_num val_env met_env sfun | Pcl_fun (l, None, spat, scl') -> if !Clflags.principal then Ctype.begin_def (); let (pat, pv, val_env', met_env) = Typecore.type_class_arg_pattern cl_num val_env met_env l spat in if !Clflags.principal then begin Ctype.end_def (); iter_pattern (fun {pat_type=ty} -> Ctype.generalize_structure ty) pat end; let pv = List.map begin fun (id, id_loc, id', ty) -> let path = Pident id' in (* do not mark the value as being used *) let vd = Env.find_value path val_env' in (id, id_loc, {exp_desc = Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd); exp_loc = Location.none; exp_extra = []; exp_type = Ctype.instance val_env' vd.val_type; exp_env = val_env'}) end pv in let rec not_function = function Cty_fun _ -> false | _ -> true in let partial = Parmatch.check_partial pat.pat_loc [pat, (* Dummy expression *) {exp_desc = Texp_constant (Asttypes.Const_int 1); exp_loc = Location.none; exp_extra = []; exp_type = Ctype.none; exp_env = Env.empty }] in Ctype.raise_nongen_level (); let cl = class_expr cl_num val_env' met_env scl' in Ctype.end_def (); if Btype.is_optional l && not_function cl.cl_type then Location.prerr_warning pat.pat_loc Warnings.Unerasable_optional_argument; rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial); cl_loc = scl.pcl_loc; cl_type = Cty_fun (l, Ctype.instance_def pat.pat_type, cl.cl_type); cl_env = val_env} | Pcl_apply (scl', sargs) -> let cl = class_expr cl_num val_env met_env scl' in let rec nonopt_labels ls ty_fun = match ty_fun with | Cty_fun (l, _, ty_res) -> if Btype.is_optional l then nonopt_labels ls ty_res else nonopt_labels (l::ls) ty_res | _ -> ls in let ignore_labels = !Clflags.classic || let labels = nonopt_labels [] cl.cl_type in List.length labels = List.length sargs && List.for_all (fun (l,_) -> l = "") sargs && List.exists (fun l -> l <> "") labels && begin Location.prerr_warning cl.cl_loc Warnings.Labels_omitted; true end in let rec type_args args omitted ty_fun sargs more_sargs = match ty_fun with | Cty_fun (l, ty, ty_fun) when sargs <> [] || more_sargs <> [] -> let name = Btype.label_name l and optional = if Btype.is_optional l then Optional else Required in let sargs, more_sargs, arg = if ignore_labels && not (Btype.is_optional l) then begin match sargs, more_sargs with (l', sarg0)::_, _ -> raise(Error(sarg0.pexp_loc, Apply_wrong_label(l'))) | _, (l', sarg0)::more_sargs -> if l <> l' && l' <> "" then raise(Error(sarg0.pexp_loc, Apply_wrong_label l')) else ([], more_sargs, Some (type_argument val_env sarg0 ty ty)) | _ -> assert false end else try let (l', sarg0, sargs, more_sargs) = try let (l', sarg0, sargs1, sargs2) = Btype.extract_label name sargs in (l', sarg0, sargs1 @ sargs2, more_sargs) with Not_found -> let (l', sarg0, sargs1, sargs2) = Btype.extract_label name more_sargs in (l', sarg0, sargs @ sargs1, sargs2) in sargs, more_sargs, if Btype.is_optional l' || not (Btype.is_optional l) then Some (type_argument val_env sarg0 ty ty) else let ty0 = extract_option_type val_env ty in let arg = type_argument val_env sarg0 ty0 ty0 in Some (option_some arg) with Not_found -> sargs, more_sargs, if Btype.is_optional l && (List.mem_assoc "" sargs || List.mem_assoc "" more_sargs) then Some (option_none ty Location.none) else None in let omitted = if arg = None then (l,ty) :: omitted else omitted in type_args ((l,arg,optional)::args) omitted ty_fun sargs more_sargs | _ -> match sargs @ more_sargs with (l, sarg0)::_ -> if omitted <> [] then raise(Error(sarg0.pexp_loc, Apply_wrong_label l)) else raise(Error(cl.cl_loc, Cannot_apply cl.cl_type)) | [] -> (List.rev args, List.fold_left (fun ty_fun (l,ty) -> Cty_fun(l,ty,ty_fun)) ty_fun omitted) in let (args, cty) = if ignore_labels then type_args [] [] cl.cl_type [] sargs else type_args [] [] cl.cl_type sargs [] in rc {cl_desc = Tcl_apply (cl, args); cl_loc = scl.pcl_loc; cl_type = cty; cl_env = val_env} | Pcl_let (rec_flag, sdefs, scl') -> let (defs, val_env) = try Typecore.type_let val_env rec_flag sdefs None with Ctype.Unify [(ty, _)] -> raise(Error(scl.pcl_loc, Make_nongen_seltype ty)) in let (vals, met_env) = List.fold_right (fun (id, id_loc) (vals, met_env) -> let path = Pident id in (* do not mark the value as used *) let vd = Env.find_value path val_env in Ctype.begin_def (); let expr = {exp_desc = Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd); exp_loc = Location.none; exp_extra = []; exp_type = Ctype.instance val_env vd.val_type; exp_env = val_env; } in Ctype.end_def (); Ctype.generalize expr.exp_type; let desc = {val_type = expr.exp_type; val_kind = Val_ivar (Immutable, cl_num); Types.val_loc = vd.Types.val_loc; } in let id' = Ident.create (Ident.name id) in ((id', id_loc, expr) :: vals, Env.add_value id' desc met_env)) (let_bound_idents_with_loc defs) ([], met_env) in let cl = class_expr cl_num val_env met_env scl' in rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl); cl_loc = scl.pcl_loc; cl_type = cl.cl_type; cl_env = val_env} | Pcl_constraint (scl', scty) -> Ctype.begin_class_def (); let context = Typetexp.narrow () in let cl = class_expr cl_num val_env met_env scl' in Typetexp.widen context; let context = Typetexp.narrow () in let clty = class_type val_env scty in Typetexp.widen context; Ctype.end_def (); limited_generalize (Ctype.row_variable (Ctype.self_type cl.cl_type)) cl.cl_type; limited_generalize (Ctype.row_variable (Ctype.self_type clty.cltyp_type)) clty.cltyp_type; begin match Includeclass.class_types val_env cl.cl_type clty.cltyp_type with [] -> () | error -> raise(Error(cl.cl_loc, Class_match_failure error)) end; let (vals, meths, concrs) = extract_constraints clty.cltyp_type in rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs); cl_loc = scl.pcl_loc; cl_type = snd (Ctype.instance_class [] clty.cltyp_type); cl_env = val_env} (*******************************) (* Approximate the type of the constructor to allow recursive use *) (* of optional parameters *) let var_option = Predef.type_option (Btype.newgenvar ()) let rec approx_declaration cl = match cl.pcl_desc with Pcl_fun (l, _, _, cl) -> let arg = if Btype.is_optional l then Ctype.instance_def var_option else Ctype.newvar () in Ctype.newty (Tarrow (l, arg, approx_declaration cl, Cok)) | Pcl_let (_, _, cl) -> approx_declaration cl | Pcl_constraint (cl, _) -> approx_declaration cl | _ -> Ctype.newvar () let rec approx_description ct = match ct.pcty_desc with Pcty_fun (l, _, ct) -> let arg = if Btype.is_optional l then Ctype.instance_def var_option else Ctype.newvar () in Ctype.newty (Tarrow (l, arg, approx_description ct, Cok)) | _ -> Ctype.newvar () (*******************************) let temp_abbrev loc env id arity = let params = ref [] in for i = 1 to arity do params := Ctype.newvar () :: !params done; let ty = Ctype.newobj (Ctype.newvar ()) in let env = Env.add_type id {type_params = !params; type_arity = arity; type_kind = Type_abstract; type_private = Public; type_manifest = Some ty; type_variance = List.map (fun _ -> true, true, true) !params; type_newtype_level = None; type_loc = loc; } env in (!params, ty, env) let rec initial_env define_class approx (res, env) (cl, id, ty_id, obj_id, cl_id) = (* Temporary abbreviations *) let arity = List.length (fst cl.pci_params) in let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity in let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity in (* Temporary type for the class constructor *) let constr_type = approx cl.pci_expr in if !Clflags.principal then Ctype.generalize_spine constr_type; let dummy_cty = Cty_signature { cty_self = Ctype.newvar (); cty_vars = Vars.empty; cty_concr = Concr.empty; cty_inher = [] } in let dummy_class = {cty_params = []; (* Dummy value *) cty_variance = []; cty_type = dummy_cty; (* Dummy value *) cty_path = unbound_class; cty_new = match cl.pci_virt with Virtual -> None | Concrete -> Some constr_type} in let env = Env.add_cltype ty_id {clty_params = []; (* Dummy value *) clty_variance = []; clty_type = dummy_cty; (* Dummy value *) clty_path = unbound_class} ( if define_class then Env.add_class id dummy_class env else env) in ((cl, id, ty_id, obj_id, obj_params, obj_ty, cl_id, cl_params, cl_ty, constr_type, dummy_class)::res, env) let class_infos define_class kind (cl, id, ty_id, obj_id, obj_params, obj_ty, cl_id, cl_params, cl_ty, constr_type, dummy_class) (res, env) = reset_type_variables (); Ctype.begin_class_def (); (* Introduce class parameters *) let params = try let params, loc = cl.pci_params in List.map (fun x -> enter_type_variable true loc x.txt) params with Already_bound -> raise(Error(snd cl.pci_params, Repeated_parameter)) in (* Allow self coercions (only for class declarations) *) let coercion_locs = ref [] in (* Type the class expression *) let (expr, typ) = try Typecore.self_coercion := (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion; let res = kind env cl.pci_expr in Typecore.self_coercion := List.tl !Typecore.self_coercion; res with exn -> Typecore.self_coercion := []; raise exn in Ctype.end_def (); let sty = Ctype.self_type typ in ignore (Ctype.object_fields sty); (* Generalize the row variable *) let rv = Ctype.row_variable sty in List.iter (Ctype.limited_generalize rv) params; limited_generalize rv typ; (* Check the abbreviation for the object type *) let (obj_params', obj_type) = Ctype.instance_class params typ in let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in begin let ty = Ctype.self_type obj_type in Ctype.hide_private_methods ty; Ctype.close_object ty; begin try List.iter2 (Ctype.unify env) obj_params obj_params' with Ctype.Unify _ -> raise(Error(cl.pci_loc, Bad_parameters (obj_id, constr, Ctype.newconstr (Path.Pident obj_id) obj_params'))) end; begin try Ctype.unify env ty constr with Ctype.Unify _ -> raise(Error(cl.pci_loc, Abbrev_type_clash (constr, ty, Ctype.expand_head env constr))) end end; (* Check the other temporary abbreviation (#-type) *) begin let (cl_params', cl_type) = Ctype.instance_class params typ in let ty = Ctype.self_type cl_type in Ctype.hide_private_methods ty; Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty; begin try List.iter2 (Ctype.unify env) cl_params cl_params' with Ctype.Unify _ -> raise(Error(cl.pci_loc, Bad_parameters (cl_id, Ctype.newconstr (Path.Pident cl_id) cl_params, Ctype.newconstr (Path.Pident cl_id) cl_params'))) end; begin try Ctype.unify env ty cl_ty with Ctype.Unify _ -> let constr = Ctype.newconstr (Path.Pident cl_id) params in raise(Error(cl.pci_loc, Abbrev_type_clash (constr, ty, cl_ty))) end end; (* Type of the class constructor *) begin try Ctype.unify env (constructor_type constr obj_type) (Ctype.instance env constr_type) with Ctype.Unify trace -> raise(Error(cl.pci_loc, Constructor_type_mismatch (cl.pci_name.txt, trace))) end; (* Class and class type temporary definitions *) let cty_variance = List.map (fun _ -> true, true) params in let cltydef = {clty_params = params; clty_type = class_body typ; clty_variance = cty_variance; clty_path = Path.Pident obj_id} and clty = {cty_params = params; cty_type = typ; cty_variance = cty_variance; cty_path = Path.Pident obj_id; cty_new = match cl.pci_virt with Virtual -> None | Concrete -> Some constr_type} in dummy_class.cty_type <- typ; let env = Env.add_cltype ty_id cltydef ( if define_class then Env.add_class id clty env else env) in if cl.pci_virt = Concrete then begin let sign = Ctype.signature_of_class_type typ in let mets = virtual_methods sign in let vals = Vars.fold (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) sign.cty_vars [] in if mets <> [] || vals <> [] then raise(Error(cl.pci_loc, Virtual_class(true, mets, vals))); end; (* Misc. *) let arity = Ctype.class_type_arity typ in let pub_meths = let (fields, _) = Ctype.flatten_fields (Ctype.object_fields (Ctype.expand_head env obj_ty)) in List.map (function (lab, _, _) -> lab) fields in (* Final definitions *) let (params', typ') = Ctype.instance_class params typ in let cltydef = {clty_params = params'; clty_type = class_body typ'; clty_variance = cty_variance; clty_path = Path.Pident obj_id} and clty = {cty_params = params'; cty_type = typ'; cty_variance = cty_variance; cty_path = Path.Pident obj_id; cty_new = match cl.pci_virt with Virtual -> None | Concrete -> Some (Ctype.instance env constr_type)} in let obj_abbr = {type_params = obj_params; type_arity = List.length obj_params; type_kind = Type_abstract; type_private = Public; type_manifest = Some obj_ty; type_variance = List.map (fun _ -> true, true, true) obj_params; type_newtype_level = None; type_loc = cl.pci_loc} in let (cl_params, cl_ty) = Ctype.instance_parameterized_type params (Ctype.self_type typ) in Ctype.hide_private_methods cl_ty; Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty; let cl_abbr = {type_params = cl_params; type_arity = List.length cl_params; type_kind = Type_abstract; type_private = Public; type_manifest = Some cl_ty; type_variance = List.map (fun _ -> true, true, true) cl_params; type_newtype_level = None; type_loc = cl.pci_loc} in ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, arity, pub_meths, List.rev !coercion_locs, expr) :: res, env) let final_decl env define_class (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, arity, pub_meths, coe, expr) = begin try Ctype.collapse_conj_params env clty.cty_params with Ctype.Unify trace -> raise(Error(cl.pci_loc, Non_collapsable_conjunction (id, clty, trace))) end; List.iter Ctype.generalize clty.cty_params; generalize_class_type clty.cty_type; begin match clty.cty_new with None -> () | Some ty -> Ctype.generalize ty end; List.iter Ctype.generalize obj_abbr.type_params; begin match obj_abbr.type_manifest with None -> () | Some ty -> Ctype.generalize ty end; List.iter Ctype.generalize cl_abbr.type_params; begin match cl_abbr.type_manifest with None -> () | Some ty -> Ctype.generalize ty end; if not (closed_class clty) then raise(Error(cl.pci_loc, Non_generalizable_class (id, clty))); begin match Ctype.closed_class clty.cty_params (Ctype.signature_of_class_type clty.cty_type) with None -> () | Some reason -> let printer = if define_class then function ppf -> Printtyp.class_declaration id ppf clty else function ppf -> Printtyp.cltype_declaration id ppf cltydef in raise(Error(cl.pci_loc, Unbound_type_var(printer, reason))) end; (id, cl.pci_name, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, arity, pub_meths, coe, expr, { ci_variance = cl.pci_variance; ci_loc = cl.pci_loc; ci_virt = cl.pci_virt; ci_params = cl.pci_params; (* TODO : check that we have the correct use of identifiers *) ci_id_name = cl.pci_name; ci_id_class = id; ci_id_class_type = ty_id; ci_id_object = obj_id; ci_id_typesharp = cl_id; ci_expr = expr; ci_decl = clty; ci_type_decl = cltydef; }) (* (cl.pci_variance, cl.pci_loc)) *) let extract_type_decls (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, arity, pub_meths, coe, expr, required) decls = (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) :: decls let merge_type_decls (id, id_loc, _clty, ty_id, _cltydef, obj_id, _obj_abbr, cl_id, _cl_abbr, arity, pub_meths, coe, expr, req) (obj_abbr, cl_abbr, clty, cltydef) = (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, arity, pub_meths, coe, expr, req) let final_env define_class env (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, arity, pub_meths, coe, expr, req) = (* Add definitions after cleaning them *) Env.add_type obj_id (Subst.type_declaration Subst.identity obj_abbr) ( Env.add_type cl_id (Subst.type_declaration Subst.identity cl_abbr) ( Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) ( if define_class then Env.add_class id (Subst.class_declaration Subst.identity clty) env else env))) (* Check that #c is coercible to c if there is a self-coercion *) let check_coercions env (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, arity, pub_meths, coercion_locs, expr, req) = begin match coercion_locs with [] -> () | loc :: _ -> let cl_ty, obj_ty = match cl_abbr.type_manifest, obj_abbr.type_manifest with Some cl_ab, Some obj_ab -> let cl_params, cl_ty = Ctype.instance_parameterized_type cl_abbr.type_params cl_ab and obj_params, obj_ty = Ctype.instance_parameterized_type obj_abbr.type_params obj_ab in List.iter2 (Ctype.unify env) cl_params obj_params; cl_ty, obj_ty | _ -> assert false in begin try Ctype.subtype env cl_ty obj_ty () with Ctype.Subtype (tr1, tr2) -> raise(Typecore.Error(loc, Typecore.Not_subtype(tr1, tr2))) end; if not (Ctype.opened_object cl_ty) then raise(Error(loc, Cannot_coerce_self obj_ty)) end; (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, arity, pub_meths, req) (*******************************) let type_classes define_class approx kind env cls = let cls = List.map (function cl -> (cl, Ident.create cl.pci_name.txt, Ident.create cl.pci_name.txt, Ident.create cl.pci_name.txt, Ident.create ("#" ^ cl.pci_name.txt))) cls in Ctype.init_def (Ident.current_time ()); Ctype.begin_class_def (); let (res, env) = List.fold_left (initial_env define_class approx) ([], env) cls in let (res, env) = List.fold_right (class_infos define_class kind) res ([], env) in Ctype.end_def (); let res = List.rev_map (final_decl env define_class) res in let decls = List.fold_right extract_type_decls res [] in let decls = Typedecl.compute_variance_decls env decls in let res = List.map2 merge_type_decls res decls in let env = List.fold_left (final_env define_class) env res in let res = List.map (check_coercions env) res in (res, env) let class_num = ref 0 let class_declaration env sexpr = incr class_num; let expr = class_expr (string_of_int !class_num) env env sexpr in (expr, expr.cl_type) let class_description env sexpr = let expr = class_type env sexpr in (expr, expr.cltyp_type) let class_declarations env cls = type_classes true approx_declaration class_declaration env cls let class_descriptions env cls = type_classes true approx_description class_description env cls let class_type_declarations env cls = let (decl, env) = type_classes false approx_description class_description env cls in (List.map (function (_, id_loc, _, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, _, _, ci) -> (ty_id, id_loc, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci)) decl, env) let rec unify_parents env ty cl = match cl.cl_desc with Tcl_ident (p, _, _) -> begin try let decl = Env.find_class p env in let _, body = Ctype.find_cltype_for_path env decl.cty_path in Ctype.unify env ty (Ctype.instance env body) with Not_found -> () | exn -> assert false end | Tcl_structure st -> unify_parents_struct env ty st | Tcl_fun (_, _, _, cl, _) | Tcl_apply (cl, _) | Tcl_let (_, _, _, cl) | Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl and unify_parents_struct env ty st = List.iter (function {cf_desc = Tcf_inher (_, cl, _, _, _)} -> unify_parents env ty cl | _ -> ()) st.cstr_fields let type_object env loc s = incr class_num; let (desc, sign) = class_structure (string_of_int !class_num) true env env loc s in let sty = Ctype.expand_head env sign.cty_self in Ctype.hide_private_methods sty; let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in let meths = List.map (fun (s,_,_) -> s) fields in unify_parents_struct env sign.cty_self desc; (desc, sign, meths) let () = Typecore.type_object := type_object (*******************************) (* Approximate the class declaration as class ['params] id = object end *) let approx_class sdecl = let self' = { ptyp_desc = Ptyp_any; ptyp_loc = Location.none } in let clty' = { pcty_desc = Pcty_signature { pcsig_self = self'; pcsig_fields = []; pcsig_loc = Location.none }; pcty_loc = sdecl.pci_expr.pcty_loc } in { sdecl with pci_expr = clty' } let approx_class_declarations env sdecls = fst (class_type_declarations env (List.map approx_class sdecls)) (*******************************) (* Error report *) open Format let report_error ppf = function | Repeated_parameter -> fprintf ppf "A type parameter occurs several times" | Unconsistent_constraint trace -> fprintf ppf "The class constraints are not consistent.@."; Printtyp.report_unification_error ppf trace (fun ppf -> fprintf ppf "Type") (fun ppf -> fprintf ppf "is not compatible with type") | Field_type_mismatch (k, m, trace) -> Printtyp.report_unification_error ppf trace (function ppf -> fprintf ppf "The %s %s@ has type" k m) (function ppf -> fprintf ppf "but is expected to have type") | Structure_expected clty -> fprintf ppf "@[This class expression is not a class structure; it has type@ %a@]" Printtyp.class_type clty | Cannot_apply clty -> fprintf ppf "This class expression is not a class function, it cannot be applied" | Apply_wrong_label l -> let mark_label = function | "" -> "out label" | l -> sprintf " label ~%s" l in fprintf ppf "This argument cannot be applied with%s" (mark_label l) | Pattern_type_clash ty -> (* XXX Trace *) (* XXX Revoir message d'erreur *) Printtyp.reset_and_mark_loops ty; fprintf ppf "@[%s@ %a@]" "This pattern cannot match self: it only matches values of type" Printtyp.type_expr ty | Unbound_class_2 cl -> fprintf ppf "@[The class@ %a@ is not yet completely defined@]" Printtyp.longident cl | Unbound_class_type_2 cl -> fprintf ppf "@[The class type@ %a@ is not yet completely defined@]" Printtyp.longident cl | Abbrev_type_clash (abbrev, actual, expected) -> (* XXX Afficher une trace ? *) Printtyp.reset_and_mark_loops_list [abbrev; actual; expected]; fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \ but is used with type@ %a@]" Printtyp.type_expr abbrev Printtyp.type_expr actual Printtyp.type_expr expected | Constructor_type_mismatch (c, trace) -> Printtyp.report_unification_error ppf trace (function ppf -> fprintf ppf "The expression \"new %s\" has type" c) (function ppf -> fprintf ppf "but is used with type") | Virtual_class (cl, mets, vals) -> let print_mets ppf mets = List.iter (function met -> fprintf ppf "@ %s" met) mets in let cl_mark = if cl then "" else " type" in let missings = match mets, vals with [], _ -> "variables" | _, [] -> "methods" | _ -> "methods and variables" in fprintf ppf "@[This class%s should be virtual.@ \ @[<2>The following %s are undefined :%a@]@]" cl_mark missings print_mets (mets @ vals) | Parameter_arity_mismatch(lid, expected, provided) -> fprintf ppf "@[The class constructor %a@ expects %i type argument(s),@ \ but is here applied to %i type argument(s)@]" Printtyp.longident lid expected provided | Parameter_mismatch trace -> Printtyp.report_unification_error ppf trace (function ppf -> fprintf ppf "The type parameter") (function ppf -> fprintf ppf "does not meet its constraint: it should be") | Bad_parameters (id, params, cstrs) -> Printtyp.reset_and_mark_loops_list [params; cstrs]; fprintf ppf "@[The abbreviation %a@ is used with parameters@ %a@ \ wich are incompatible with constraints@ %a@]" Printtyp.ident id Printtyp.type_expr params Printtyp.type_expr cstrs | Class_match_failure error -> Includeclass.report_error ppf error | Unbound_val lab -> fprintf ppf "Unbound instance variable %s" lab | Unbound_type_var (printer, reason) -> let print_common ppf kind ty0 real lab ty = let ty1 = if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in Printtyp.mark_loops ty1; fprintf ppf "The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound" kind lab Printtyp.type_expr ty Printtyp.type_expr ty0 in let print_reason ppf = function | Ctype.CC_Method (ty0, real, lab, ty) -> print_common ppf "method" ty0 real lab ty | Ctype.CC_Value (ty0, real, lab, ty) -> print_common ppf "instance variable" ty0 real lab ty in Printtyp.reset (); fprintf ppf "@[@[Some type variables are unbound in this type:@;<1 2>%t@]@ \ @[%a@]@]" printer print_reason reason | Make_nongen_seltype ty -> fprintf ppf "@[@[Self type should not occur in the non-generic type@;<1 2>\ %a@]@,\ It would escape the scope of its class@]" Printtyp.type_scheme ty | Non_generalizable_class (id, clty) -> fprintf ppf "@[The type of this class,@ %a,@ \ contains type variables that cannot be generalized@]" (Printtyp.class_declaration id) clty | Cannot_coerce_self ty -> fprintf ppf "@[The type of self cannot be coerced to@ \ the type of the current class:@ %a.@.\ Some occurrences are contravariant@]" Printtyp.type_scheme ty | Non_collapsable_conjunction (id, clty, trace) -> fprintf ppf "@[The type of this class,@ %a,@ \ contains non-collapsible conjunctive types in constraints@]" (Printtyp.class_declaration id) clty; Printtyp.report_unification_error ppf trace (fun ppf -> fprintf ppf "Type") (fun ppf -> fprintf ppf "is not compatible with type") | Final_self_clash trace -> Printtyp.report_unification_error ppf trace (function ppf -> fprintf ppf "This object is expected to have type") (function ppf -> fprintf ppf "but actually has type") | Mutability_mismatch (lab, mut) -> let mut1, mut2 = if mut = Immutable then "mutable", "immutable" else "immutable", "mutable" in fprintf ppf "@[The instance variable is %s;@ it cannot be redefined as %s@]" mut1 mut2 | No_overriding (_, "") -> fprintf ppf "@[This inheritance does not override any method@ %s@]" "instance variable" | No_overriding (kind, name) -> fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name mingw-ocaml/ocaml/typing/printtyped.mli0000644000175000017500000000176512124403242017707 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id: printast.mli 12404 2012-04-26 13:20:09Z lefessan $ *) open Typedtree;; open Format;; val interface : formatter -> signature -> unit;; val implementation : formatter -> structure -> unit;; mingw-ocaml/ocaml/typing/types.mli0000644000175000017500000001663412124403242016652 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Representation of types and declarations *) open Asttypes (* Type expressions for the core language *) type type_expr = { mutable desc: type_desc; mutable level: int; mutable id: int } and type_desc = Tvar of string option | Tarrow of label * type_expr * type_expr * commutable | Ttuple of type_expr list | Tconstr of Path.t * type_expr list * abbrev_memo ref | Tobject of type_expr * (Path.t * type_expr list) option ref | Tfield of string * field_kind * type_expr * type_expr | Tnil | Tlink of type_expr | Tsubst of type_expr (* for copying *) | Tvariant of row_desc | Tunivar of string option | Tpoly of type_expr * type_expr list | Tpackage of Path.t * Longident.t list * type_expr list and row_desc = { row_fields: (label * row_field) list; row_more: type_expr; row_bound: unit; (* kept for compatibility *) row_closed: bool; row_fixed: bool; row_name: (Path.t * type_expr list) option } and row_field = Rpresent of type_expr option | Reither of bool * type_expr list * bool * row_field option ref (* 1st true denotes a constant constructor *) (* 2nd true denotes a tag in a pattern matching, and is erased later *) | Rabsent and abbrev_memo = Mnil | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo | Mlink of abbrev_memo ref and field_kind = Fvar of field_kind option ref | Fpresent | Fabsent and commutable = Cok | Cunknown | Clink of commutable ref module TypeOps : sig type t = type_expr val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int end (* Maps of methods and instance variables *) module Meths : Map.S with type key = string module Vars : Map.S with type key = string (* Value descriptions *) type value_description = { val_type: type_expr; (* Type of the value *) val_kind: value_kind; val_loc: Location.t; } and value_kind = Val_reg (* Regular value *) | Val_prim of Primitive.description (* Primitive *) | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) | Val_self of (Ident.t * type_expr) Meths.t ref * (Ident.t * mutable_flag * virtual_flag * type_expr) Vars.t ref * string * type_expr (* Self *) | Val_anc of (string * Ident.t) list * string (* Ancestor *) | Val_unbound (* Unbound variable *) (* Constructor descriptions *) type constructor_description = { cstr_res: type_expr; (* Type of the result *) cstr_existentials: type_expr list; (* list of existentials *) cstr_args: type_expr list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) cstr_tag: constructor_tag; (* Tag for heap blocks *) cstr_consts: int; (* Number of constant constructors *) cstr_nonconsts: int; (* Number of non-const constructors *) cstr_normal: int; (* Number of non generalized constrs *) cstr_generalized: bool; (* Constrained return type? *) cstr_private: private_flag } (* Read-only constructor? *) and constructor_tag = Cstr_constant of int (* Constant constructor (an int) *) | Cstr_block of int (* Regular constructor (a block) *) | Cstr_exception of Path.t * Location.t (* Exception constructor *) (* Record label descriptions *) type label_description = { lbl_name: string; (* Short name *) lbl_res: type_expr; (* Type of the result *) lbl_arg: type_expr; (* Type of the argument *) lbl_mut: mutable_flag; (* Is this a mutable field? *) lbl_pos: int; (* Position in block *) lbl_all: label_description array; (* All the labels in this type *) lbl_repres: record_representation; (* Representation for this record *) lbl_private: private_flag } (* Read-only field? *) and record_representation = Record_regular (* All fields are boxed / tagged *) | Record_float (* All fields are floats *) (* Type definitions *) type type_declaration = { type_params: type_expr list; type_arity: int; type_kind: type_kind; type_private: private_flag; type_manifest: type_expr option; type_variance: (bool * bool * bool) list; (* covariant, contravariant, weakly contravariant *) type_newtype_level: (int * int) option; (* definition level * expansion level *) type_loc: Location.t } and type_kind = Type_abstract | Type_record of (Ident.t * mutable_flag * type_expr) list * record_representation | Type_variant of (Ident.t * type_expr list * type_expr option) list type exception_declaration = { exn_args: type_expr list; exn_loc: Location.t } (* Type expressions for the class language *) module Concr : Set.S with type elt = string type class_type = Cty_constr of Path.t * type_expr list * class_type | Cty_signature of class_signature | Cty_fun of label * type_expr * class_type and class_signature = { cty_self: type_expr; cty_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; cty_concr: Concr.t; cty_inher: (Path.t * type_expr list) list } type class_declaration = { cty_params: type_expr list; mutable cty_type: class_type; cty_path: Path.t; cty_new: type_expr option; cty_variance: (bool * bool) list } type class_type_declaration = { clty_params: type_expr list; clty_type: class_type; clty_path: Path.t; clty_variance: (bool * bool) list } (* Type expressions for the module language *) type module_type = Mty_ident of Path.t | Mty_signature of signature | Mty_functor of Ident.t * module_type * module_type and signature = signature_item list and signature_item = Sig_value of Ident.t * value_description | Sig_type of Ident.t * type_declaration * rec_status | Sig_exception of Ident.t * exception_declaration | Sig_module of Ident.t * module_type * rec_status | Sig_modtype of Ident.t * modtype_declaration | Sig_class of Ident.t * class_declaration * rec_status | Sig_class_type of Ident.t * class_type_declaration * rec_status and modtype_declaration = Modtype_abstract | Modtype_manifest of module_type and rec_status = Trec_not (* not recursive *) | Trec_first (* first in a recursive group *) | Trec_next (* not first in a recursive group *) mingw-ocaml/ocaml/typing/typedecl.ml0000644000175000017500000012270312124403242017141 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (**** Typing of type definitions ****) open Misc open Asttypes open Parsetree open Primitive open Types open Typetexp type error = Repeated_parameter | Duplicate_constructor of string | Too_many_constructors | Duplicate_label of string | Recursive_abbrev of string | Definition_mismatch of type_expr * Includecore.type_mismatch list | Constraint_failed of type_expr * type_expr | Inconsistent_constraint of (type_expr * type_expr) list | Type_clash of (type_expr * type_expr) list | Parameters_differ of Path.t * type_expr * type_expr | Null_arity_external | Missing_native_external | Unbound_type_var of type_expr * type_declaration | Unbound_exception of Longident.t | Not_an_exception of Longident.t | Bad_variance of int * (bool * bool) * (bool * bool) | Unavailable_type_constructor of Path.t | Bad_fixed_type of string | Unbound_type_var_exc of type_expr * type_expr | Varying_anonymous open Typedtree exception Error of Location.t * error (* Enter all declared types in the environment as abstract types *) let enter_type env (name, sdecl) id = let decl = { type_params = List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; type_arity = List.length sdecl.ptype_params; type_kind = Type_abstract; type_private = sdecl.ptype_private; type_manifest = begin match sdecl.ptype_manifest with None -> None | Some _ -> Some(Ctype.newvar ()) end; type_variance = List.map (fun _ -> true, true, true) sdecl.ptype_params; type_newtype_level = None; type_loc = sdecl.ptype_loc; } in Env.add_type id decl env let update_type temp_env env id loc = let path = Path.Pident id in let decl = Env.find_type path temp_env in match decl.type_manifest with None -> () | Some ty -> let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in try Ctype.unify env (Ctype.newconstr path params) ty with Ctype.Unify trace -> raise (Error(loc, Type_clash trace)) (* Determine if a type is (an abbreviation for) the type "float" *) (* We use the Ctype.expand_head_opt version of expand_head to get access to the manifest type of private abbreviations. *) let is_float env ty = match Ctype.repr (Ctype.expand_head_opt env ty) with {desc = Tconstr(p, _, _)} -> Path.same p Predef.path_float | _ -> false (* Determine if a type definition defines a fixed type. (PW) *) let is_fixed_type sd = (match sd.ptype_manifest with | Some { ptyp_desc = (Ptyp_variant _|Ptyp_object _|Ptyp_class _|Ptyp_alias ({ptyp_desc = Ptyp_variant _|Ptyp_object _|Ptyp_class _},_)) } -> true | _ -> false) && sd.ptype_kind = Ptype_abstract && sd.ptype_private = Private (* Set the row variable in a fixed type *) let set_fixed_row env loc p decl = let tm = match decl.type_manifest with None -> assert false | Some t -> Ctype.expand_head env t in let rv = match tm.desc with Tvariant row -> let row = Btype.row_repr row in tm.desc <- Tvariant {row with row_fixed = true}; if Btype.static_row row then Btype.newgenty Tnil else row.row_more | Tobject (ty, _) -> snd (Ctype.flatten_fields ty) | _ -> raise (Error (loc, Bad_fixed_type "is not an object or variant")) in if not (Btype.is_Tvar rv) then raise (Error (loc, Bad_fixed_type "has no row variable")); rv.desc <- Tconstr (p, decl.type_params, ref Mnil) (* Translate one type declaration *) module StringSet = Set.Make(struct type t = string let compare = compare end) let make_params sdecl = try List.map (function None -> Ctype.new_global_var ~name:"_" () | Some x -> enter_type_variable true sdecl.ptype_loc x.txt) sdecl.ptype_params with Already_bound -> raise(Error(sdecl.ptype_loc, Repeated_parameter)) let transl_declaration env (name, sdecl) id = (* Bind type parameters *) reset_type_variables(); Ctype.begin_def (); let params = make_params sdecl in let cstrs = List.map (fun (sty, sty', loc) -> transl_simple_type env false sty, transl_simple_type env false sty', loc) sdecl.ptype_cstrs in let (tkind, kind) = match sdecl.ptype_kind with Ptype_abstract -> Ttype_abstract, Type_abstract | Ptype_variant cstrs -> let all_constrs = ref StringSet.empty in List.iter (fun ({ txt = name}, _, _, loc) -> if StringSet.mem name !all_constrs then raise(Error(sdecl.ptype_loc, Duplicate_constructor name)); all_constrs := StringSet.add name !all_constrs) cstrs; if List.length (List.filter (fun (_, args, _, _) -> args <> []) cstrs) > (Config.max_tag + 1) then raise(Error(sdecl.ptype_loc, Too_many_constructors)); let make_cstr (lid, args, ret_type, loc) = let name = Ident.create lid.txt in match ret_type with | None -> (name, lid, List.map (transl_simple_type env true) args, None, loc) | Some sty -> (* if it's a generalized constructor we must first narrow and then widen so as to not introduce any new constraints *) let z = narrow () in reset_type_variables (); let args = List.map (transl_simple_type env false) args in let ret_type = let cty = transl_simple_type env false sty in let ty = cty.ctyp_type in let p = Path.Pident id in match (Ctype.repr ty).desc with Tconstr (p', _, _) when Path.same p p' -> ty | _ -> raise (Error (sty.ptyp_loc, Constraint_failed (ty, Ctype.newconstr p params))) in widen z; (name, lid, args, Some ret_type, loc) in let cstrs = List.map make_cstr cstrs in Ttype_variant (List.map (fun (name, lid, ctys, _, loc) -> name, lid, ctys, loc ) cstrs), Type_variant (List.map (fun (name, name_loc, ctys, option, loc) -> name, List.map (fun cty -> cty.ctyp_type) ctys, option) cstrs) | Ptype_record lbls -> let all_labels = ref StringSet.empty in List.iter (fun ({ txt = name }, mut, arg, loc) -> if StringSet.mem name !all_labels then raise(Error(sdecl.ptype_loc, Duplicate_label name)); all_labels := StringSet.add name !all_labels) lbls; let lbls = List.map (fun (name, mut, arg, loc) -> let cty = transl_simple_type env true arg in (Ident.create name.txt, name, mut, cty, loc) ) lbls in let lbls' = List.map (fun (name, name_loc, mut, cty, loc) -> let ty = cty.ctyp_type in name, mut, match ty.desc with Tpoly(t,[]) -> t | _ -> ty) lbls in let rep = if List.for_all (fun (name, mut, arg) -> is_float env arg) lbls' then Record_float else Record_regular in Ttype_record lbls, Type_record(lbls', rep) in let (tman, man) = match sdecl.ptype_manifest with None -> None, None | Some sty -> let no_row = not (is_fixed_type sdecl) in let cty = transl_simple_type env no_row sty in Some cty, Some cty.ctyp_type in let decl = { type_params = params; type_arity = List.length params; type_kind = kind; type_private = sdecl.ptype_private; type_manifest = man; type_variance = List.map (fun _ -> true, true, true) params; type_newtype_level = None; type_loc = sdecl.ptype_loc; } in (* Check constraints *) List.iter (fun (cty, cty', loc) -> let ty = cty.ctyp_type in let ty' = cty'.ctyp_type in try Ctype.unify env ty ty' with Ctype.Unify tr -> raise(Error(loc, Inconsistent_constraint tr))) cstrs; Ctype.end_def (); (* Add abstract row *) if is_fixed_type sdecl then begin let (p, _) = try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env with Not_found -> assert false in set_fixed_row env sdecl.ptype_loc p decl end; (* Check for cyclic abbreviations *) begin match decl.type_manifest with None -> () | Some ty -> if Ctype.cyclic_abbrev env id ty then raise(Error(sdecl.ptype_loc, Recursive_abbrev name.txt)); end; let tdecl = { typ_params = sdecl.ptype_params; typ_type = decl; typ_cstrs = cstrs; typ_loc = sdecl.ptype_loc; typ_manifest = tman; typ_kind = tkind; typ_variance = sdecl.ptype_variance; typ_private = sdecl.ptype_private; } in (id, name, tdecl) (* Generalize a type declaration *) let generalize_decl decl = List.iter Ctype.generalize decl.type_params; begin match decl.type_kind with Type_abstract -> () | Type_variant v -> List.iter (fun (_, tyl, ret_type) -> List.iter Ctype.generalize tyl; may Ctype.generalize ret_type) v | Type_record(r, rep) -> List.iter (fun (_, _, ty) -> Ctype.generalize ty) r end; begin match decl.type_manifest with | None -> () | Some ty -> Ctype.generalize ty end (* Check that all constraints are enforced *) module TypeSet = Btype.TypeSet let rec check_constraints_rec env loc visited ty = let ty = Ctype.repr ty in if TypeSet.mem ty !visited then () else begin visited := TypeSet.add ty !visited; match ty.desc with | Tconstr (path, args, _) -> let args' = List.map (fun _ -> Ctype.newvar ()) args in let ty' = Ctype.newconstr path args' in begin try Ctype.enforce_constraints env ty' with Ctype.Unify _ -> assert false | Not_found -> raise (Error(loc, Unavailable_type_constructor path)) end; if not (Ctype.matches env ty ty') then raise (Error(loc, Constraint_failed (ty, ty'))); List.iter (check_constraints_rec env loc visited) args | Tpoly (ty, tl) -> let _, ty = Ctype.instance_poly false tl ty in check_constraints_rec env loc visited ty | _ -> Btype.iter_type_expr (check_constraints_rec env loc visited) ty end let check_constraints env (_, sdecl) (_, decl) = let visited = ref TypeSet.empty in begin match decl.type_kind with | Type_abstract -> () | Type_variant l -> let rec find_pl = function Ptype_variant pl -> pl | Ptype_record _ | Ptype_abstract -> assert false in let pl = find_pl sdecl.ptype_kind in List.iter (fun (name, tyl, ret_type) -> let (styl, sret_type) = try let (_, sty, sret_type, _) = List.find (fun (n,_,_,_) -> n.txt = Ident.name name) pl in (sty, sret_type) with Not_found -> assert false in List.iter2 (fun sty ty -> check_constraints_rec env sty.ptyp_loc visited ty) styl tyl; match sret_type, ret_type with | Some sr, Some r -> check_constraints_rec env sr.ptyp_loc visited r | _ -> () ) l | Type_record (l, _) -> let rec find_pl = function Ptype_record pl -> pl | Ptype_variant _ | Ptype_abstract -> assert false in let pl = find_pl sdecl.ptype_kind in let rec get_loc name = function [] -> assert false | (name', _, sty, _) :: tl -> if name = name'.txt then sty.ptyp_loc else get_loc name tl in List.iter (fun (name, _, ty) -> check_constraints_rec env (get_loc (Ident.name name) pl) visited ty) l end; begin match decl.type_manifest with | None -> () | Some ty -> let sty = match sdecl.ptype_manifest with Some sty -> sty | _ -> assert false in check_constraints_rec env sty.ptyp_loc visited ty end (* If both a variant/record definition and a type equation are given, need to check that the equation refers to a type of the same kind with the same constructors and labels. *) let check_abbrev env (_, sdecl) (id, decl) = match decl with {type_kind = (Type_variant _ | Type_record _); type_manifest = Some ty} -> begin match (Ctype.repr ty).desc with Tconstr(path, args, _) -> begin try let decl' = Env.find_type path env in let err = if List.length args <> List.length decl.type_params then [Includecore.Arity] else if not (Ctype.equal env false args decl.type_params) then [Includecore.Constraint] else Includecore.type_declarations ~equality:true env (Path.last path) decl' id (Subst.type_declaration (Subst.add_type id path Subst.identity) decl) in if err <> [] then raise(Error(sdecl.ptype_loc, Definition_mismatch (ty, err))) with Not_found -> raise(Error(sdecl.ptype_loc, Unavailable_type_constructor path)) end | _ -> raise(Error(sdecl.ptype_loc, Definition_mismatch (ty, []))) end | _ -> () (* Check that recursion is well-founded *) let check_well_founded env loc path decl = Misc.may (fun body -> try Ctype.correct_abbrev env path decl.type_params body with | Ctype.Recursive_abbrev -> raise(Error(loc, Recursive_abbrev (Path.name path))) | Ctype.Unify trace -> raise(Error(loc, Type_clash trace))) decl.type_manifest (* Check for ill-defined abbrevs *) let check_recursion env loc path decl to_check = (* to_check is true for potentially mutually recursive paths. (path, decl) is the type declaration to be checked. *) if decl.type_params = [] then () else let visited = ref [] in let rec check_regular cpath args prev_exp ty = let ty = Ctype.repr ty in if not (List.memq ty !visited) then begin visited := ty :: !visited; match ty.desc with | Tconstr(path', args', _) -> if Path.same path path' then begin if not (Ctype.equal env false args args') then raise (Error(loc, Parameters_differ(cpath, ty, Ctype.newconstr path args))) end (* Attempt to expand a type abbreviation if: 1- [to_check path'] holds (otherwise the expansion cannot involve [path]); 2- we haven't expanded this type constructor before (otherwise we could loop if [path'] is itself a non-regular abbreviation). *) else if to_check path' && not (List.mem path' prev_exp) then begin try (* Attempt expansion *) let (params0, body0, _) = Env.find_type_expansion path' env in let (params, body) = Ctype.instance_parameterized_type params0 body0 in begin try List.iter2 (Ctype.unify env) params args' with Ctype.Unify _ -> raise (Error(loc, Constraint_failed (ty, Ctype.newconstr path' params0))); end; check_regular path' args (path' :: prev_exp) body with Not_found -> () end; List.iter (check_regular cpath args prev_exp) args' | Tpoly (ty, tl) -> let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in check_regular cpath args prev_exp ty | _ -> Btype.iter_type_expr (check_regular cpath args prev_exp) ty end in Misc.may (fun body -> let (args, body) = Ctype.instance_parameterized_type ~keep_names:true decl.type_params body in check_regular path args [] body) decl.type_manifest let check_abbrev_recursion env id_loc_list (id, _, tdecl) = let decl = tdecl.typ_type in check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl (function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false) (* Compute variance *) let compute_variance env tvl nega posi cntr ty = let pvisited = ref TypeSet.empty and nvisited = ref TypeSet.empty and cvisited = ref TypeSet.empty in let rec compute_variance_rec posi nega cntr ty = let ty = Ctype.repr ty in if (not posi || TypeSet.mem ty !pvisited) && (not nega || TypeSet.mem ty !nvisited) && (not cntr || TypeSet.mem ty !cvisited) then () else begin if posi then pvisited := TypeSet.add ty !pvisited; if nega then nvisited := TypeSet.add ty !nvisited; if cntr then cvisited := TypeSet.add ty !cvisited; let compute_same = compute_variance_rec posi nega cntr in match ty.desc with Tarrow (_, ty1, ty2, _) -> compute_variance_rec nega posi true ty1; compute_same ty2 | Ttuple tl -> List.iter compute_same tl | Tconstr (path, tl, _) -> if tl = [] then () else begin try let decl = Env.find_type path env in List.iter2 (fun ty (co,cn,ct) -> compute_variance_rec (posi && co || nega && cn) (posi && cn || nega && co) (cntr || ct) ty) tl decl.type_variance with Not_found -> List.iter (compute_variance_rec true true true) tl end | Tobject (ty, _) -> compute_same ty | Tfield (_, _, ty1, ty2) -> compute_same ty1; compute_same ty2 | Tsubst ty -> compute_same ty | Tvariant row -> let row = Btype.row_repr row in List.iter (fun (_,f) -> match Btype.row_field_repr f with Rpresent (Some ty) -> compute_same ty | Reither (_, tyl, _, _) -> List.iter compute_same tyl | _ -> ()) row.row_fields; compute_same row.row_more | Tpoly (ty, _) -> compute_same ty | Tvar _ | Tnil | Tlink _ | Tunivar _ -> () | Tpackage (_, _, tyl) -> List.iter (compute_variance_rec true true true) tyl end in compute_variance_rec nega posi cntr ty; List.iter (fun (ty, covar, convar, ctvar) -> if TypeSet.mem ty !pvisited then covar := true; if TypeSet.mem ty !nvisited then convar := true; if TypeSet.mem ty !cvisited then ctvar := true) tvl let make_variance ty = (ty, ref false, ref false, ref false) let whole_type decl = match decl.type_kind with Type_variant tll -> Btype.newgenty (Ttuple (List.map (fun (_, tl, _) -> Btype.newgenty (Ttuple tl)) tll)) | Type_record (ftl, _) -> Btype.newgenty (Ttuple (List.map (fun (_, _, ty) -> ty) ftl)) | Type_abstract -> match decl.type_manifest with Some ty -> ty | _ -> Btype.newgenty (Ttuple []) let compute_variance_type env check (required, loc) decl tyl = let params = List.map Btype.repr decl.type_params in let tvl0 = List.map make_variance params in let args = Btype.newgenty (Ttuple params) in let fvl = if check then Ctype.free_variables args else [] in let fvl = List.filter (fun v -> not (List.memq v params)) fvl in let tvl1 = List.map make_variance fvl in let tvl2 = List.map make_variance fvl in let tvl = tvl0 @ tvl1 in List.iter (fun (cn,ty) -> compute_variance env tvl true cn cn ty) tyl; let required = List.map (fun (c,n as r) -> if c || n then r else (true,true)) required in List.iter2 (fun (ty, co, cn, ct) (c, n) -> if not (Btype.is_Tvar ty) then begin co := c; cn := n; ct := n; compute_variance env tvl2 c n n ty end) tvl0 required; List.iter2 (fun (ty, c1, n1, t1) (_, c2, n2, t2) -> if !c1 && not !c2 || !n1 && not !n2 then raise (Error(loc, Bad_variance (0, (!c1,!n1), (!c2,!n2))))) tvl1 tvl2; let pos = ref 0 in List.map2 (fun (_, co, cn, ct) (c, n) -> incr pos; if !co && not c || !cn && not n then raise (Error(loc, Bad_variance (!pos, (!co,!cn), (c,n)))); if decl.type_private = Private then (c,n,n) else let ct = if decl.type_kind = Type_abstract then ct else cn in (!co, !cn, !ct)) tvl0 required let add_false = List.map (fun ty -> false, ty) (* A parameter is constrained if either is is instantiated, or it is a variable appearing in another parameter *) let constrained env vars ty = let ty = Ctype.expand_head env ty in match ty.desc with | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars | _ -> true let compute_variance_gadt env check (required, loc as rloc) decl (_, tl, ret_type_opt) = match ret_type_opt with | None -> compute_variance_type env check rloc {decl with type_private = Private} (add_false tl) | Some ret_type -> match Ctype.repr ret_type with | {desc=Tconstr (path, tyl, _)} -> let fvl = List.map Ctype.free_variables tyl in let _ = List.fold_left2 (fun (fv1,fv2) ty (c,n) -> match fv2 with [] -> assert false | fv :: fv2 -> (* fv1 @ fv2 = free_variables of other parameters *) if (c||n) && constrained env (fv1 @ fv2) ty then raise (Error(loc, Varying_anonymous)); (fv :: fv1, fv2)) ([], fvl) tyl required in compute_variance_type env check rloc {decl with type_params = tyl; type_private = Private} (add_false tl) | _ -> assert false let compute_variance_decl env check decl (required, loc as rloc) = if decl.type_kind = Type_abstract && decl.type_manifest = None then List.map (fun (c, n) -> if c || n then (c, n, n) else (true, true, true)) required else match decl.type_kind with | Type_abstract -> begin match decl.type_manifest with None -> assert false | Some ty -> compute_variance_type env check rloc decl [false, ty] end | Type_variant tll -> if List.for_all (fun (_,_,ret) -> ret = None) tll then compute_variance_type env check rloc decl (add_false (List.flatten (List.map (fun (_,tyl,_) -> tyl) tll))) else begin match List.map (compute_variance_gadt env check rloc decl) tll with | vari :: _ -> vari | _ -> assert false end | Type_record (ftl, _) -> compute_variance_type env check rloc decl (List.map (fun (_, mut, ty) -> (mut = Mutable, ty)) ftl) let is_sharp id = let s = Ident.name id in String.length s > 0 && s.[0] = '#' let rec compute_variance_fixpoint env decls required variances = let new_decls = List.map2 (fun (id, decl) variance -> id, {decl with type_variance = variance}) decls variances in let new_env = List.fold_right (fun (id, decl) env -> Env.add_type id decl env) new_decls env in let new_variances = List.map2 (fun (id, decl) -> compute_variance_decl new_env false decl) new_decls required in let new_variances = List.map2 (List.map2 (fun (c1,n1,t1) (c2,n2,t2) -> c1||c2, n1||n2, t1||t2)) new_variances variances in if new_variances <> variances then compute_variance_fixpoint env decls required new_variances else begin List.iter2 (fun (id, decl) req -> if not (is_sharp id) then ignore (compute_variance_decl new_env true decl req)) new_decls required; new_decls, new_env end let init_variance (id, decl) = List.map (fun _ -> (false, false, false)) decl.type_params (* for typeclass.ml *) let compute_variance_decls env cldecls = let decls, required = List.fold_right (fun (obj_id, obj_abbr, cl_abbr, clty, cltydef, ci) (decls, req) -> (obj_id, obj_abbr) :: decls, (ci.ci_variance, ci.ci_loc) :: req) cldecls ([],[]) in let variances = List.map init_variance decls in let (decls, _) = compute_variance_fixpoint env decls required variances in List.map2 (fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) -> let variance = List.map (fun (c,n,t) -> (c,n)) decl.type_variance in (decl, {cl_abbr with type_variance = decl.type_variance}, {clty with cty_variance = variance}, {cltydef with clty_variance = variance})) decls cldecls (* Check multiple declarations of labels/constructors *) let check_duplicates name_sdecl_list = let labels = Hashtbl.create 7 and constrs = Hashtbl.create 7 in List.iter (fun (name, sdecl) -> match sdecl.ptype_kind with Ptype_variant cl -> List.iter (fun (cname, _, _, loc) -> try let name' = Hashtbl.find constrs cname.txt in Location.prerr_warning loc (Warnings.Duplicate_definitions ("constructor", cname.txt, name', name.txt)) with Not_found -> Hashtbl.add constrs cname.txt name.txt) cl | Ptype_record fl -> List.iter (fun (cname, _, _, loc) -> try let name' = Hashtbl.find labels cname.txt in Location.prerr_warning loc (Warnings.Duplicate_definitions ("label", cname.txt, name', name.txt)) with Not_found -> Hashtbl.add labels cname.txt name.txt) fl | Ptype_abstract -> ()) name_sdecl_list (* Force recursion to go through id for private types*) let name_recursion sdecl id decl = match decl with | { type_kind = Type_abstract; type_manifest = Some ty; type_private = Private; } when is_fixed_type sdecl -> let ty = Ctype.repr ty in let ty' = Btype.newty2 ty.level ty.desc in if Ctype.deep_occur ty ty' then let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in Btype.link_type ty (Btype.newty2 ty.level td); {decl with type_manifest = Some ty'} else decl | _ -> decl (* Translate a set of mutually recursive type declarations *) let transl_type_decl env name_sdecl_list = (* Add dummy types for fixed rows *) let fixed_types = List.filter (fun (_, sd) -> is_fixed_type sd) name_sdecl_list in let name_sdecl_list = List.map (fun (name, sdecl) -> mkloc (name.txt ^"#row") name.loc, {sdecl with ptype_kind = Ptype_abstract; ptype_manifest = None}) fixed_types @ name_sdecl_list in (* Create identifiers. *) let id_list = List.map (fun (name, _) -> Ident.create name.txt) name_sdecl_list in (* Since we've introduced fresh idents, make sure the definition level is at least the binding time of these events. Otherwise, passing one of the recursively-defined type constrs as argument to an abbreviation may fail. *) Ctype.init_def(Ident.current_time()); Ctype.begin_def(); (* Enter types. *) let temp_env = List.fold_left2 enter_type env name_sdecl_list id_list in (* Translate each declaration. *) let current_slot = ref None in let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in let id_slots id = if not warn_unused then id, None else (* See typecore.ml for a description of the algorithm used to detect unused declarations in a set of recursive definitions. *) let slot = ref [] in let td = Env.find_type (Path.Pident id) temp_env in let name = Ident.name id in Env.set_type_used_callback name td (fun old_callback -> match !current_slot with | Some slot -> slot := (name, td) :: !slot | None -> List.iter (fun (name, d) -> Env.mark_type_used name d) (get_ref slot); old_callback () ); id, Some slot in let transl_declaration name_sdecl (id, slot) = current_slot := slot; transl_declaration temp_env name_sdecl id in let tdecls = List.map2 transl_declaration name_sdecl_list (List.map id_slots id_list) in let decls = List.map (fun (id, name_loc, tdecl) -> (id, tdecl.typ_type)) tdecls in current_slot := None; (* Check for duplicates *) check_duplicates name_sdecl_list; (* Build the final env. *) let newenv = List.fold_right (fun (id, decl) env -> Env.add_type id decl env) decls env in (* Update stubs *) List.iter2 (fun id (_, sdecl) -> update_type temp_env newenv id sdecl.ptype_loc) id_list name_sdecl_list; (* Generalize type declarations. *) Ctype.end_def(); List.iter (fun (_, decl) -> generalize_decl decl) decls; (* Check for ill-formed abbrevs *) let id_loc_list = List.map2 (fun id (_,sdecl) -> (id, sdecl.ptype_loc)) id_list name_sdecl_list in List.iter (fun (id, decl) -> check_well_founded newenv (List.assoc id id_loc_list) (Path.Pident id) decl) decls; List.iter (check_abbrev_recursion newenv id_loc_list) tdecls; (* Check that all type variable are closed *) List.iter2 (fun (_, sdecl) (id, _, tdecl) -> let decl = tdecl.typ_type in match Ctype.closed_type_decl decl with Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) | None -> ()) name_sdecl_list tdecls; (* Check re-exportation *) List.iter2 (check_abbrev newenv) name_sdecl_list decls; (* Check that constraints are enforced *) List.iter2 (check_constraints newenv) name_sdecl_list decls; (* Name recursion *) let decls = List.map2 (fun (_, sdecl) (id, decl) -> id, name_recursion sdecl id decl) name_sdecl_list decls in (* Add variances to the environment *) let required = List.map (fun (_, sdecl) -> sdecl.ptype_variance, sdecl.ptype_loc) name_sdecl_list in let final_decls, final_env = compute_variance_fixpoint env decls required (List.map init_variance decls) in let final_decls = List.map2 (fun (id, name_loc, tdecl) (id2, decl) -> (id, name_loc, { tdecl with typ_type = decl }) ) tdecls final_decls in (* Done *) (final_decls, final_env) (* Translate an exception declaration *) let transl_closed_type env sty = let cty = transl_simple_type env true sty in let ty = cty.ctyp_type in let ty = match Ctype.free_variables ty with | [] -> ty | tv :: _ -> raise (Error (sty.ptyp_loc, Unbound_type_var_exc (tv, ty))) in { cty with ctyp_type = ty } let transl_exception env loc excdecl = reset_type_variables(); Ctype.begin_def(); let ttypes = List.map (transl_closed_type env) excdecl in Ctype.end_def(); let types = List.map (fun cty -> cty.ctyp_type) ttypes in List.iter Ctype.generalize types; let exn_decl = { exn_args = types; Types.exn_loc = loc } in { exn_params = ttypes; exn_exn = exn_decl; Typedtree.exn_loc = loc } (* Translate an exception rebinding *) let transl_exn_rebind env loc lid = let (path, cdescr) = try Env.lookup_constructor lid env with Not_found -> raise(Error(loc, Unbound_exception lid)) in Env.mark_constructor Env.Positive env (Longident.last lid) cdescr; match cdescr.cstr_tag with Cstr_exception (path, _) -> (path, {exn_args = cdescr.cstr_args; Types.exn_loc = loc}) | _ -> raise(Error(loc, Not_an_exception lid)) (* Translate a value declaration *) let transl_value_decl env loc valdecl = let cty = Typetexp.transl_type_scheme env valdecl.pval_type in let ty = cty.ctyp_type in let v = match valdecl.pval_prim with [] -> { val_type = ty; val_kind = Val_reg; Types.val_loc = loc } | decl -> let arity = Ctype.arity ty in if arity = 0 then raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external)); let prim = Primitive.parse_declaration arity decl in if !Clflags.native_code && prim.prim_arity > 5 && prim.prim_native_name = "" then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external)); { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc } in { val_desc = cty; val_val = v; val_prim = valdecl.pval_prim; val_loc = valdecl.pval_loc; } (* Translate a "with" constraint -- much simplified version of transl_type_decl. *) let transl_with_constraint env id row_path orig_decl sdecl = Env.mark_type_used (Ident.name id) orig_decl; reset_type_variables(); Ctype.begin_def(); let params = make_params sdecl in let orig_decl = Ctype.instance_declaration orig_decl in let arity_ok = List.length params = orig_decl.type_arity in if arity_ok then List.iter2 (Ctype.unify_var env) params orig_decl.type_params; let constraints = List.map (function (ty, ty', loc) -> try let cty = transl_simple_type env false ty in let cty' = transl_simple_type env false ty' in let ty = cty.ctyp_type in let ty' = cty'.ctyp_type in Ctype.unify env ty ty'; (cty, cty', loc) with Ctype.Unify tr -> raise(Error(loc, Inconsistent_constraint tr))) sdecl.ptype_cstrs in let no_row = not (is_fixed_type sdecl) in let (tman, man) = match sdecl.ptype_manifest with None -> None, None | Some sty -> let cty = transl_simple_type env no_row sty in Some cty, Some cty.ctyp_type in let decl = { type_params = params; type_arity = List.length params; type_kind = if arity_ok then orig_decl.type_kind else Type_abstract; type_private = sdecl.ptype_private; type_manifest = man; type_variance = []; type_newtype_level = None; type_loc = sdecl.ptype_loc; } in begin match row_path with None -> () | Some p -> set_fixed_row env sdecl.ptype_loc p decl end; begin match Ctype.closed_type_decl decl with None -> () | Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) end; let decl = name_recursion sdecl id decl in let decl = {decl with type_variance = compute_variance_decl env false decl (sdecl.ptype_variance, sdecl.ptype_loc)} in Ctype.end_def(); generalize_decl decl; { typ_params = sdecl.ptype_params; typ_type = decl; typ_cstrs = constraints; typ_loc = sdecl.ptype_loc; typ_manifest = tman; typ_kind = Ttype_abstract; typ_variance = sdecl.ptype_variance; typ_private = sdecl.ptype_private; } (* Approximate a type declaration: just make all types abstract *) let abstract_type_decl arity = let rec make_params n = if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in Ctype.begin_def(); let decl = { type_params = make_params arity; type_arity = arity; type_kind = Type_abstract; type_private = Public; type_manifest = None; type_variance = replicate_list (true, true, true) arity; type_newtype_level = None; type_loc = Location.none; } in Ctype.end_def(); generalize_decl decl; decl let approx_type_decl env name_sdecl_list = List.map (fun (name, sdecl) -> (Ident.create name.txt, abstract_type_decl (List.length sdecl.ptype_params))) name_sdecl_list (* Variant of check_abbrev_recursion to check the well-formedness conditions on type abbreviations defined within recursive modules. *) let check_recmod_typedecl env loc recmod_ids path decl = (* recmod_ids is the list of recursively-defined module idents. (path, decl) is the type declaration to be checked. *) check_well_founded env loc path decl; check_recursion env loc path decl (fun path -> List.exists (fun id -> Path.isfree id path) recmod_ids) (**** Error report ****) open Format let explain_unbound ppf tv tl typ kwd lab = try let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in let ty0 = (* Hack to force aliasing when needed *) Btype.newgenty (Tobject(tv, ref None)) in Printtyp.reset_and_mark_loops_list [typ ti; ty0]; fprintf ppf ".@.@[In %s@ %s%a@;<1 -2>the variable %a is unbound@]" kwd (lab ti) Printtyp.type_expr (typ ti) Printtyp.type_expr tv with Not_found -> () let explain_unbound_single ppf tv ty = let trivial ty = explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in match (Ctype.repr ty).desc with Tobject(fi,_) -> let (tl, rv) = Ctype.flatten_fields fi in if rv == tv then trivial ty else explain_unbound ppf tv tl (fun (_,_,t) -> t) "method" (fun (lab,_,_) -> lab ^ ": ") | Tvariant row -> let row = Btype.row_repr row in if row.row_more == tv then trivial ty else explain_unbound ppf tv row.row_fields (fun (l,f) -> match Btype.row_field_repr f with Rpresent (Some t) -> t | Reither (_,[t],_,_) -> t | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl) | _ -> Btype.newgenty (Ttuple[])) "case" (fun (lab,_) -> "`" ^ lab ^ " of ") | _ -> trivial ty let report_error ppf = function | Repeated_parameter -> fprintf ppf "A type parameter occurs several times" | Duplicate_constructor s -> fprintf ppf "Two constructors are named %s" s | Too_many_constructors -> fprintf ppf "@[Too many non-constant constructors@ -- maximum is %i %s@]" (Config.max_tag + 1) "non-constant constructors" | Duplicate_label s -> fprintf ppf "Two labels are named %s" s | Recursive_abbrev s -> fprintf ppf "The type abbreviation %s is cyclic" s | Definition_mismatch (ty, errs) -> Printtyp.reset_and_mark_loops ty; fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" "This variant or record definition" "does not match that of type" Printtyp.type_expr ty (Includecore.report_type_mismatch "the original" "this" "definition") errs | Constraint_failed (ty, ty') -> Printtyp.reset_and_mark_loops ty; Printtyp.mark_loops ty'; fprintf ppf "@[%s@ @[Type@ %a@ should be an instance of@ %a@]@]" "Constraints are not satisfied in this type." Printtyp.type_expr ty Printtyp.type_expr ty' | Parameters_differ (path, ty, ty') -> Printtyp.reset_and_mark_loops ty; Printtyp.mark_loops ty'; fprintf ppf "@[In the definition of %s, type@ %a@ should be@ %a@]" (Path.name path) Printtyp.type_expr ty Printtyp.type_expr ty' | Inconsistent_constraint trace -> fprintf ppf "The type constraints are not consistent.@."; Printtyp.report_unification_error ppf trace (fun ppf -> fprintf ppf "Type") (fun ppf -> fprintf ppf "is not compatible with type") | Type_clash trace -> Printtyp.report_unification_error ppf trace (function ppf -> fprintf ppf "This type constructor expands to type") (function ppf -> fprintf ppf "but is used here with type") | Null_arity_external -> fprintf ppf "External identifiers must be functions" | Missing_native_external -> fprintf ppf "@[An external function with more than 5 arguments \ requires a second stub function@ \ for native-code compilation@]" | Unbound_type_var (ty, decl) -> fprintf ppf "A type variable is unbound in this type declaration"; let ty = Ctype.repr ty in begin match decl.type_kind, decl.type_manifest with | Type_variant tl, _ -> explain_unbound ppf ty tl (fun (_,tl,_) -> Btype.newgenty (Ttuple tl)) "case" (fun (lab,_,_) -> Ident.name lab ^ " of ") | Type_record (tl, _), _ -> explain_unbound ppf ty tl (fun (_,_,t) -> t) "field" (fun (lab,_,_) -> Ident.name lab ^ ": ") | Type_abstract, Some ty' -> explain_unbound_single ppf ty ty' | _ -> () end | Unbound_type_var_exc (tv, ty) -> fprintf ppf "A type variable is unbound in this exception declaration"; explain_unbound_single ppf (Ctype.repr tv) ty | Unbound_exception lid -> fprintf ppf "Unbound exception constructor@ %a" Printtyp.longident lid | Not_an_exception lid -> fprintf ppf "The constructor@ %a@ is not an exception" Printtyp.longident lid | Bad_variance (n, v1, v2) -> let variance = function (true, true) -> "invariant" | (true, false) -> "covariant" | (false,true) -> "contravariant" | (false,false) -> "unrestricted" in let suffix n = let teen = (n mod 100)/10 = 1 in match n mod 10 with | 1 when not teen -> "st" | 2 when not teen -> "nd" | 3 when not teen -> "rd" | _ -> "th" in if n < 1 then fprintf ppf "@[%s@ %s@]" "In this definition, a type variable has a variance that" "is not reflected by its occurrence in type parameters." else fprintf ppf "@[%s@ %s@ %s %d%s %s %s,@ %s %s@]" "In this definition, expected parameter" "variances are not satisfied." "The" n (suffix n) "type parameter was expected to be" (variance v2) "but it is" (variance v1) | Unavailable_type_constructor p -> fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p | Bad_fixed_type r -> fprintf ppf "This fixed type %s" r | Varying_anonymous -> fprintf ppf "@[%s@ %s@ %s@]" "In this GADT definition," "the variance of some parameter" "cannot be checked" mingw-ocaml/ocaml/typing/stypes.ml0000644000175000017500000001156212124403242016657 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocquencourt *) (* *) (* Copyright 2003 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Recording and dumping (partial) type information *) (* We record all types in a list as they are created. This means we can dump type information even if type inference fails, which is extremely important, since type information is most interesting in case of errors. *) open Annot;; open Format;; open Lexing;; open Location;; open Typedtree;; type annotation = | Ti_pat of pattern | Ti_expr of expression | Ti_class of class_expr | Ti_mod of module_expr | An_call of Location.t * Annot.call | An_ident of Location.t * string * Annot.ident ;; let get_location ti = match ti with Ti_pat p -> p.pat_loc | Ti_expr e -> e.exp_loc | Ti_class c -> c.cl_loc | Ti_mod m -> m.mod_loc | An_call (l, k) -> l | An_ident (l, s, k) -> l ;; let annotations = ref ([] : annotation list);; let phrases = ref ([] : Location.t list);; let record ti = if !Clflags.annotations && not (get_location ti).Location.loc_ghost then annotations := ti :: !annotations ;; let record_phrase loc = if !Clflags.annotations then phrases := loc :: !phrases; ;; (* comparison order: the intervals are sorted by order of increasing upper bound same upper bound -> sorted by decreasing lower bound *) let cmp_loc_inner_first loc1 loc2 = match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum | x -> x ;; let cmp_ti_inner_first ti1 ti2 = cmp_loc_inner_first (get_location ti1) (get_location ti2) ;; let print_position pp pos = if pos = dummy_pos then fprintf pp "--" else fprintf pp "%S %d %d %d" pos.pos_fname pos.pos_lnum pos.pos_bol pos.pos_cnum; ;; let print_location pp loc = print_position pp loc.loc_start; fprintf pp " "; print_position pp loc.loc_end; ;; let sort_filter_phrases () = let ph = List.sort (fun x y -> cmp_loc_inner_first y x) !phrases in let rec loop accu cur l = match l with | [] -> accu | loc :: t -> if cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum && cur.loc_end.pos_cnum >= loc.loc_end.pos_cnum then loop accu cur t else loop (loc :: accu) loc t in phrases := loop [] Location.none ph; ;; let rec printtyp_reset_maybe loc = match !phrases with | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum -> Printtyp.reset (); phrases := t; printtyp_reset_maybe loc; | _ -> () ;; let call_kind_string k = match k with | Tail -> "tail" | Stack -> "stack" | Inline -> "inline" ;; let print_ident_annot pp str k = match k with | Idef l -> fprintf pp "def %s %a@." str print_location l; | Iref_internal l -> fprintf pp "int_ref %s %a@." str print_location l; | Iref_external -> fprintf pp "ext_ref %s@." str; ;; (* The format of the annotation file is documented in emacs/caml-types.el. *) let print_info pp prev_loc ti = match ti with | Ti_class _ | Ti_mod _ -> prev_loc | Ti_pat {pat_loc = loc; pat_type = typ} | Ti_expr {exp_loc = loc; exp_type = typ} -> if loc <> prev_loc then fprintf pp "%a@." print_location loc; fprintf pp "type(@. "; printtyp_reset_maybe loc; Printtyp.mark_loops typ; Printtyp.type_sch pp typ; fprintf pp "@.)@."; loc | An_call (loc, k) -> if loc <> prev_loc then fprintf pp "%a@." print_location loc; fprintf pp "call(@. %s@.)@." (call_kind_string k); loc | An_ident (loc, str, k) -> if loc <> prev_loc then fprintf pp "%a@." print_location loc; fprintf pp "ident(@. "; print_ident_annot pp str k; fprintf pp ")@."; loc ;; let get_info () = let info = List.fast_sort cmp_ti_inner_first !annotations in annotations := []; info ;; let dump filename = if !Clflags.annotations then begin let info = get_info () in let pp = match filename with None -> std_formatter | Some filename -> formatter_of_out_channel (open_out filename) in sort_filter_phrases (); ignore (List.fold_left (print_info pp) Location.none info); phrases := []; end else begin annotations := []; end; ;; mingw-ocaml/ocaml/typing/stypes.mli0000644000175000017500000000251312124403242017024 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Moscova, INRIA Rocquencourt *) (* *) (* Copyright 2003 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Recording and dumping (partial) type information *) (* Clflags.save_types must be true *) open Typedtree;; type annotation = | Ti_pat of pattern | Ti_expr of expression | Ti_class of class_expr | Ti_mod of module_expr | An_call of Location.t * Annot.call | An_ident of Location.t * string * Annot.ident ;; val record : annotation -> unit;; val record_phrase : Location.t -> unit;; val dump : string option -> unit;; val get_location : annotation -> Location.t;; val get_info : unit -> annotation list;; mingw-ocaml/ocaml/typing/path.mli0000644000175000017500000000224512124403242016433 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Access paths *) type t = Pident of Ident.t | Pdot of t * string * int | Papply of t * t val same: t -> t -> bool val isfree: Ident.t -> t -> bool val binding_time: t -> int val nopos: int val name: ?paren:(string -> bool) -> t -> string (* [paren] tells whether a path suffix needs parentheses *) val head: t -> Ident.t val last: t -> string mingw-ocaml/ocaml/typing/includeclass.mli0000644000175000017500000000243412124403242020150 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Inclusion checks for the class language *) open Types open Ctype open Format val class_types: Env.t -> class_type -> class_type -> class_match_failure list val class_type_declarations: Env.t -> class_type_declaration -> class_type_declaration -> class_match_failure list val class_declarations: Env.t -> class_declaration -> class_declaration -> class_match_failure list val report_error: formatter -> class_match_failure list -> unit mingw-ocaml/ocaml/typing/printtyp.ml0000644000175000017500000011032512124403242017216 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Printing functions *) open Misc open Ctype open Format open Longident open Path open Asttypes open Types open Btype open Outcometree (* Print a long identifier *) let rec longident ppf = function | Lident s -> fprintf ppf "%s" s | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2 (* Print an identifier *) let unique_names = ref Ident.empty let ident_name id = try Ident.find_same id !unique_names with Not_found -> Ident.name id let add_unique id = try ignore (Ident.find_same id !unique_names) with Not_found -> unique_names := Ident.add id (Ident.unique_toplevel_name id) !unique_names let ident ppf id = fprintf ppf "%s" (ident_name id) (* Print a path *) let ident_pervasive = Ident.create_persistent "Pervasives" let rec tree_of_path = function | Pident id -> Oide_ident (ident_name id) | Pdot(Pident id, s, pos) when Ident.same id ident_pervasive -> Oide_ident s | Pdot(p, s, pos) -> Oide_dot (tree_of_path p, s) | Papply(p1, p2) -> Oide_apply (tree_of_path p1, tree_of_path p2) let rec path ppf = function | Pident id -> ident ppf id | Pdot(Pident id, s, pos) when Ident.same id ident_pervasive -> fprintf ppf "%s" s | Pdot(p, s, pos) -> fprintf ppf "%a.%s" path p s | Papply(p1, p2) -> fprintf ppf "%a(%a)" path p1 path p2 (* Print a recursive annotation *) let tree_of_rec = function | Trec_not -> Orec_not | Trec_first -> Orec_first | Trec_next -> Orec_next (* Print a raw type expression, with sharing *) let raw_list pr ppf = function [] -> fprintf ppf "[]" | a :: l -> fprintf ppf "@[<1>[%a%t]@]" pr a (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l) let rec safe_kind_repr v = function Fvar {contents=Some k} -> if List.memq k v then "Fvar loop" else safe_kind_repr (k::v) k | Fvar _ -> "Fvar None" | Fpresent -> "Fpresent" | Fabsent -> "Fabsent" let rec safe_commu_repr v = function Cok -> "Cok" | Cunknown -> "Cunknown" | Clink r -> if List.memq r v then "Clink loop" else safe_commu_repr (r::v) !r let rec safe_repr v = function {desc = Tlink t} when not (List.memq t v) -> safe_repr (t::v) t | t -> t let rec list_of_memo = function Mnil -> [] | Mcons (priv, p, t1, t2, rem) -> p :: list_of_memo rem | Mlink rem -> list_of_memo !rem let print_name ppf = function None -> fprintf ppf "None" | Some name -> fprintf ppf "\"%s\"" name let visited = ref [] let rec raw_type ppf ty = let ty = safe_repr [] ty in if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin visited := ty :: !visited; fprintf ppf "@[<1>{id=%d;level=%d;desc=@,%a}@]" ty.id ty.level raw_type_desc ty.desc end and raw_type_list tl = raw_list raw_type tl and raw_type_desc ppf = function Tvar name -> fprintf ppf "Tvar %a" print_name name | Tarrow(l,t1,t2,c) -> fprintf ppf "@[Tarrow(%s,@,%a,@,%a,@,%s)@]" l raw_type t1 raw_type t2 (safe_commu_repr [] c) | Ttuple tl -> fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl | Tconstr (p, tl, abbrev) -> fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p raw_type_list tl (raw_list path) (list_of_memo !abbrev) | Tobject (t, nm) -> fprintf ppf "@[Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t (fun ppf -> match !nm with None -> fprintf ppf " None" | Some(p,tl) -> fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl) | Tfield (f, k, t1, t2) -> fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f (safe_kind_repr [] k) raw_type t1 raw_type t2 | Tnil -> fprintf ppf "Tnil" | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t | Tunivar name -> fprintf ppf "Tunivar %a" print_name name | Tpoly (t, tl) -> fprintf ppf "@[Tpoly(@,%a,@,%a)@]" raw_type t raw_type_list tl | Tvariant row -> fprintf ppf "@[{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%b;@ %s%b;@ @[<1>%s%t@]}@]" "row_fields=" (raw_list (fun ppf (l, f) -> fprintf ppf "@[%s,@ %a@]" l raw_field f)) row.row_fields "row_more=" raw_type row.row_more "row_closed=" row.row_closed "row_fixed=" row.row_fixed "row_name=" (fun ppf -> match row.row_name with None -> fprintf ppf "None" | Some(p,tl) -> fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) | Tpackage (p, _, tl) -> fprintf ppf "@[Tpackage(@,%a@,%a)@]" path p raw_type_list tl and raw_field ppf = function Rpresent None -> fprintf ppf "Rpresent None" | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t | Reither (c,tl,m,e) -> fprintf ppf "@[Reither(%b,@,%a,@,%b,@,@[<1>ref%t@])@]" c raw_type_list tl m (fun ppf -> match !e with None -> fprintf ppf " None" | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f) | Rabsent -> fprintf ppf "Rabsent" let raw_type_expr ppf t = visited := []; raw_type ppf t; visited := [] let () = Btype.print_raw := raw_type_expr (* Print a type expression *) let names = ref ([] : (type_expr * string) list) let name_counter = ref 0 let named_vars = ref ([] : string list) let reset_names () = names := []; name_counter := 0; named_vars := [] let add_named_var ty = match ty.desc with Tvar (Some name) | Tunivar (Some name) -> if List.mem name !named_vars then () else named_vars := name :: !named_vars | _ -> () let rec new_name () = let name = if !name_counter < 26 then String.make 1 (Char.chr(97 + !name_counter)) else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^ string_of_int(!name_counter / 26) in incr name_counter; if List.mem name !named_vars || List.exists (fun (_, name') -> name = name') !names then new_name () else name let name_of_type t = (* We've already been through repr at this stage, so t is our representative of the union-find class. *) try List.assq t !names with Not_found -> let name = match t.desc with Tvar (Some name) | Tunivar (Some name) -> (* Some part of the type we've already printed has assigned another * unification variable to that name. We want to keep the name, so try * adding a number until we find a name that's not taken. *) let current_name = ref name in let i = ref 0 in while List.exists (fun (_, name') -> !current_name = name') !names do current_name := name ^ (string_of_int !i); i := !i + 1; done; !current_name | _ -> (* No name available, create a new one *) new_name () in (* Exception for type declarations *) if name <> "_" then names := (t, name) :: !names; name let check_name_of_type t = ignore(name_of_type t) let remove_names tyl = let tyl = List.map repr tyl in names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names let non_gen_mark sch ty = if sch && is_Tvar ty && ty.level <> generic_level then "_" else "" let print_name_of_type sch ppf t = fprintf ppf "'%s%s" (non_gen_mark sch t) (name_of_type t) let visited_objects = ref ([] : type_expr list) let aliased = ref ([] : type_expr list) let delayed = ref ([] : type_expr list) let add_delayed t = if not (List.memq t !delayed) then delayed := t :: !delayed let is_aliased ty = List.memq (proxy ty) !aliased let add_alias ty = let px = proxy ty in if not (is_aliased px) then begin aliased := px :: !aliased; add_named_var px end let aliasable ty = match ty.desc with Tvar _ | Tunivar _ | Tpoly _ -> false | _ -> true let namable_row row = row.row_name <> None && List.for_all (fun (_, f) -> match row_field_repr f with | Reither(c, l, _, _) -> row.row_closed && if c then l = [] else List.length l = 1 | _ -> true) row.row_fields let rec mark_loops_rec visited ty = let ty = repr ty in let px = proxy ty in if List.memq px visited && aliasable ty then add_alias px else let visited = px :: visited in match ty.desc with | Tvar _ -> add_named_var ty | Tarrow(_, ty1, ty2, _) -> mark_loops_rec visited ty1; mark_loops_rec visited ty2 | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl | Tconstr(_, tyl, _) | Tpackage (_, _, tyl) -> List.iter (mark_loops_rec visited) tyl | Tvariant row -> if List.memq px !visited_objects then add_alias px else begin let row = row_repr row in if not (static_row row) then visited_objects := px :: !visited_objects; match row.row_name with | Some(p, tyl) when namable_row row -> List.iter (mark_loops_rec visited) tyl | _ -> iter_row (mark_loops_rec visited) row end | Tobject (fi, nm) -> if List.memq px !visited_objects then add_alias px else begin if opened_object ty then visited_objects := px :: !visited_objects; begin match !nm with | None -> let fields, _ = flatten_fields fi in List.iter (fun (_, kind, ty) -> if field_kind_repr kind = Fpresent then mark_loops_rec visited ty) fields | Some (_, l) -> List.iter (mark_loops_rec visited) (List.tl l) end end | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent -> mark_loops_rec visited ty1; mark_loops_rec visited ty2 | Tfield(_, _, _, ty2) -> mark_loops_rec visited ty2 | Tnil -> () | Tsubst ty -> mark_loops_rec visited ty | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)" | Tpoly (ty, tyl) -> List.iter (fun t -> add_alias t) tyl; mark_loops_rec visited ty | Tunivar _ -> add_named_var ty let mark_loops ty = normalize_type Env.empty ty; mark_loops_rec [] ty;; let reset_loop_marks () = visited_objects := []; aliased := []; delayed := [] let reset () = unique_names := Ident.empty; reset_names (); reset_loop_marks () let reset_and_mark_loops ty = reset (); mark_loops ty let reset_and_mark_loops_list tyl = reset (); List.iter mark_loops tyl (* Disabled in classic mode when printing an unification error *) let print_labels = ref true let print_label ppf l = if !print_labels && l <> "" || is_optional l then fprintf ppf "%s:" l let rec tree_of_typexp sch ty = let ty = repr ty in let px = proxy ty in if List.mem_assq px !names && not (List.memq px !delayed) then let mark = is_non_gen sch ty in Otyp_var (mark, name_of_type px) else let pr_typ () = match ty.desc with | Tvar _ -> Otyp_var (is_non_gen sch ty, name_of_type ty) | Tarrow(l, ty1, ty2, _) -> let pr_arrow l ty1 ty2 = let lab = if !print_labels && l <> "" || is_optional l then l else "" in let t1 = if is_optional l then match (repr ty1).desc with | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> tree_of_typexp sch ty | _ -> Otyp_stuff "" else tree_of_typexp sch ty1 in Otyp_arrow (lab, t1, tree_of_typexp sch ty2) in pr_arrow l ty1 ty2 | Ttuple tyl -> Otyp_tuple (tree_of_typlist sch tyl) | Tconstr(p, tyl, abbrev) -> Otyp_constr (tree_of_path p, tree_of_typlist sch tyl) | Tvariant row -> let row = row_repr row in let fields = if row.row_closed then List.filter (fun (_, f) -> row_field_repr f <> Rabsent) row.row_fields else row.row_fields in let present = List.filter (fun (_, f) -> match row_field_repr f with | Rpresent _ -> true | _ -> false) fields in let all_present = List.length present = List.length fields in begin match row.row_name with | Some(p, tyl) when namable_row row -> let id = tree_of_path p in let args = tree_of_typlist sch tyl in if row.row_closed && all_present then Otyp_constr (id, args) else let non_gen = is_non_gen sch px in let tags = if all_present then None else Some (List.map fst present) in Otyp_variant (non_gen, Ovar_name(tree_of_path p, args), row.row_closed, tags) | _ -> let non_gen = not (row.row_closed && all_present) && is_non_gen sch px in let fields = List.map (tree_of_row_field sch) fields in let tags = if all_present then None else Some (List.map fst present) in Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags) end | Tobject (fi, nm) -> tree_of_typobject sch fi !nm | Tnil | Tfield _ -> tree_of_typobject sch ty None | Tsubst ty -> tree_of_typexp sch ty | Tlink _ -> fatal_error "Printtyp.tree_of_typexp" | Tpoly (ty, []) -> tree_of_typexp sch ty | Tpoly (ty, tyl) -> (*let print_names () = List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; prerr_string "; " in *) let tyl = List.map repr tyl in if tyl = [] then tree_of_typexp sch ty else begin let old_delayed = !delayed in (* Make the names delayed, so that the real type is printed once when used as proxy *) List.iter add_delayed tyl; let tl = List.map name_of_type tyl in let tr = Otyp_poly (tl, tree_of_typexp sch ty) in (* Forget names when we leave scope *) remove_names tyl; delayed := old_delayed; tr end | Tunivar _ -> Otyp_var (false, name_of_type ty) | Tpackage (p, n, tyl) -> let n = List.map (fun li -> String.concat "." (Longident.flatten li)) n in Otyp_module (Path.name p, n, tree_of_typlist sch tyl) in if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed; if is_aliased px && aliasable ty then begin check_name_of_type px; Otyp_alias (pr_typ (), name_of_type px) end else pr_typ () and tree_of_row_field sch (l, f) = match row_field_repr f with | Rpresent None | Reither(true, [], _, _) -> (l, false, []) | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty]) | Reither(c, tyl, _, _) -> if c (* contradiction: un constructeur constant qui a un argument *) then (l, true, tree_of_typlist sch tyl) else (l, false, tree_of_typlist sch tyl) | Rabsent -> (l, false, [] (* une erreur, en fait *)) and tree_of_typlist sch tyl = List.map (tree_of_typexp sch) tyl and tree_of_typobject sch fi nm = begin match nm with | None -> let pr_fields fi = let (fields, rest) = flatten_fields fi in let present_fields = List.fold_right (fun (n, k, t) l -> match field_kind_repr k with | Fpresent -> (n, t) :: l | _ -> l) fields [] in let sorted_fields = List.sort (fun (n, _) (n', _) -> compare n n') present_fields in tree_of_typfields sch rest sorted_fields in let (fields, rest) = pr_fields fi in Otyp_object (fields, rest) | Some (p, ty :: tyl) -> let non_gen = is_non_gen sch (repr ty) in let args = tree_of_typlist sch tyl in Otyp_class (non_gen, tree_of_path p, args) | _ -> fatal_error "Printtyp.tree_of_typobject" end and is_non_gen sch ty = sch && is_Tvar ty && ty.level <> generic_level and tree_of_typfields sch rest = function | [] -> let rest = match rest.desc with | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest) | Tconstr _ -> Some false | Tnil -> None | _ -> fatal_error "typfields (1)" in ([], rest) | (s, t) :: l -> let field = (s, tree_of_typexp sch t) in let (fields, rest) = tree_of_typfields sch rest l in (field :: fields, rest) let typexp sch prio ppf ty = !Oprint.out_type ppf (tree_of_typexp sch ty) let type_expr ppf ty = typexp false 0 ppf ty and type_sch ppf ty = typexp true 0 ppf ty and type_scheme ppf ty = reset_and_mark_loops ty; typexp true 0 ppf ty (* Maxence *) let type_scheme_max ?(b_reset_names=true) ppf ty = if b_reset_names then reset_names () ; typexp true 0 ppf ty (* Fin Maxence *) let tree_of_type_scheme ty = reset_and_mark_loops ty; tree_of_typexp true ty (* Print one type declaration *) let tree_of_constraints params = List.fold_right (fun ty list -> let ty' = unalias ty in if proxy ty != proxy ty' then let tr = tree_of_typexp true ty in (tr, tree_of_typexp true ty') :: list else list) params [] let filter_params tyl = let params = List.fold_left (fun tyl ty -> let ty = repr ty in if List.memq ty tyl then Btype.newgenty (Tsubst ty) :: tyl else ty :: tyl) [] tyl in List.rev params let string_of_mutable = function | Immutable -> "" | Mutable -> "mutable " let rec tree_of_type_decl id decl = reset(); let params = filter_params decl.type_params in List.iter add_alias params; List.iter mark_loops params; List.iter check_name_of_type (List.map proxy params); let ty_manifest = match decl.type_manifest with | None -> None | Some ty -> let ty = (* Special hack to hide variant name *) match repr ty with {desc=Tvariant row} -> let row = row_repr row in begin match row.row_name with Some (Pident id', _) when Ident.same id id' -> newgenty (Tvariant {row with row_name = None}) | _ -> ty end | _ -> ty in mark_loops ty; Some ty in begin match decl.type_kind with | Type_abstract -> () | Type_variant cstrs -> List.iter (fun (_, args,ret_type_opt) -> List.iter mark_loops args; may mark_loops ret_type_opt) cstrs | Type_record(l, rep) -> List.iter (fun (_, _, ty) -> mark_loops ty) l end; let type_param = function | Otyp_var (_, id) -> id | _ -> "?" in let type_defined decl = let abstr = match decl.type_kind with Type_abstract -> decl.type_manifest = None || decl.type_private = Private | Type_record _ -> decl.type_private = Private | Type_variant tll -> decl.type_private = Private || List.exists (fun (_,_,ret) -> ret <> None) tll in let vari = List.map2 (fun ty (co,cn,ct) -> if abstr || not (is_Tvar (repr ty)) then (co,cn) else (true,true)) decl.type_params decl.type_variance in (Ident.name id, List.map2 (fun ty cocn -> type_param (tree_of_typexp false ty), cocn) params vari) in let tree_of_manifest ty1 = match ty_manifest with | None -> ty1 | Some ty -> Otyp_manifest (tree_of_typexp false ty, ty1) in let (name, args) = type_defined decl in let constraints = tree_of_constraints params in let ty, priv = match decl.type_kind with | Type_abstract -> begin match ty_manifest with | None -> (Otyp_abstract, Public) | Some ty -> tree_of_typexp false ty, decl.type_private end | Type_variant cstrs -> tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)), decl.type_private | Type_record(lbls, rep) -> tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), decl.type_private in (name, args, ty, priv, constraints) and tree_of_constructor (name, args, ret_type_opt) = let name = Ident.name name in if ret_type_opt = None then (name, tree_of_typlist false args, None) else let nm = !names in names := []; let ret = may_map (tree_of_typexp false) ret_type_opt in let args = tree_of_typlist false args in names := nm; (name, args, ret) and tree_of_constructor_ret = function | None -> None | Some ret_type -> Some (tree_of_typexp false ret_type) and tree_of_label (name, mut, arg) = (Ident.name name, mut = Mutable, tree_of_typexp false arg) let tree_of_type_declaration id decl rs = Osig_type (tree_of_type_decl id decl, tree_of_rec rs) let type_declaration id ppf decl = !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first) (* Print an exception declaration *) let tree_of_exception_declaration id decl = reset_and_mark_loops_list decl.exn_args; let tyl = tree_of_typlist false decl.exn_args in Osig_exception (Ident.name id, tyl) let exception_declaration id ppf decl = !Oprint.out_sig_item ppf (tree_of_exception_declaration id decl) (* Print a value declaration *) let tree_of_value_description id decl = let id = Ident.name id in let ty = tree_of_type_scheme decl.val_type in let prims = match decl.val_kind with | Val_prim p -> Primitive.description_list p | _ -> [] in Osig_value (id, ty, prims) let value_description id ppf decl = !Oprint.out_sig_item ppf (tree_of_value_description id decl) (* Print a class type *) let class_var sch ppf l (m, t) = fprintf ppf "@ @[<2>val %s%s :@ %a@]" (string_of_mutable m) l (typexp sch 0) t let method_type (_, kind, ty) = match field_kind_repr kind, repr ty with Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl) | _ , ty -> (ty, []) let tree_of_metho sch concrete csil (lab, kind, ty) = if lab <> dummy_method then begin let kind = field_kind_repr kind in let priv = kind <> Fpresent in let virt = not (Concr.mem lab concrete) in let (ty, tyl) = method_type (lab, kind, ty) in let tty = tree_of_typexp sch ty in remove_names tyl; Ocsg_method (lab, priv, virt, tty) :: csil end else csil let rec prepare_class_type params = function | Cty_constr (p, tyl, cty) -> let sty = Ctype.self_type cty in if List.memq (proxy sty) !visited_objects || not (List.for_all is_Tvar params) || List.exists (deep_occur sty) tyl then prepare_class_type params cty else List.iter mark_loops tyl | Cty_signature sign -> let sty = repr sign.cty_self in (* Self may have a name *) let px = proxy sty in if List.memq px !visited_objects then add_alias sty else visited_objects := px :: !visited_objects; let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in List.iter (fun met -> mark_loops (fst (method_type met))) fields; Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars | Cty_fun (_, ty, cty) -> mark_loops ty; prepare_class_type params cty let rec tree_of_class_type sch params = function | Cty_constr (p', tyl, cty) -> let sty = Ctype.self_type cty in if List.memq (proxy sty) !visited_objects || not (List.for_all is_Tvar params) then tree_of_class_type sch params cty else Octy_constr (tree_of_path p', tree_of_typlist true tyl) | Cty_signature sign -> let sty = repr sign.cty_self in let self_ty = if is_aliased sty then Some (Otyp_var (false, name_of_type (proxy sty))) else None in let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in let csil = [] in let csil = List.fold_left (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil) csil (tree_of_constraints params) in let all_vars = Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.cty_vars [] in (* Consequence of PR#3607: order of Map.fold has changed! *) let all_vars = List.rev all_vars in let csil = List.fold_left (fun csil (l, m, v, t) -> Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t) :: csil) csil all_vars in let csil = List.fold_left (tree_of_metho sch sign.cty_concr) csil fields in Octy_signature (self_ty, List.rev csil) | Cty_fun (l, ty, cty) -> let lab = if !print_labels && l <> "" || is_optional l then l else "" in let ty = if is_optional l then match (repr ty).desc with | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty | _ -> newconstr (Path.Pident(Ident.create "")) [] else ty in let tr = tree_of_typexp sch ty in Octy_fun (lab, tr, tree_of_class_type sch params cty) let class_type ppf cty = reset (); prepare_class_type [] cty; !Oprint.out_class_type ppf (tree_of_class_type false [] cty) let tree_of_class_param param variance = (match tree_of_typexp true param with Otyp_var (_, s) -> s | _ -> "?"), if is_Tvar (repr param) then (true, true) else variance let tree_of_class_params params = let tyl = tree_of_typlist true params in List.map (function Otyp_var (_, s) -> s | _ -> "?") tyl let tree_of_class_declaration id cl rs = let params = filter_params cl.cty_params in reset (); List.iter add_alias params; prepare_class_type params cl.cty_type; let sty = Ctype.self_type cl.cty_type in List.iter mark_loops params; List.iter check_name_of_type (List.map proxy params); if is_aliased sty then check_name_of_type (proxy sty); let vir_flag = cl.cty_new = None in Osig_class (vir_flag, Ident.name id, List.map2 tree_of_class_param params cl.cty_variance, tree_of_class_type true params cl.cty_type, tree_of_rec rs) let class_declaration id ppf cl = !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first) let tree_of_cltype_declaration id cl rs = let params = List.map repr cl.clty_params in reset (); List.iter add_alias params; prepare_class_type params cl.clty_type; let sty = Ctype.self_type cl.clty_type in List.iter mark_loops params; List.iter check_name_of_type (List.map proxy params); if is_aliased sty then check_name_of_type (proxy sty); let sign = Ctype.signature_of_class_type cl.clty_type in let virt = let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in List.exists (fun (lab, _, ty) -> not (lab = dummy_method || Concr.mem lab sign.cty_concr)) fields || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.cty_vars false in Osig_class_type (virt, Ident.name id, List.map2 tree_of_class_param params cl.clty_variance, tree_of_class_type true params cl.clty_type, tree_of_rec rs) let cltype_declaration id ppf cl = !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first) (* Print a module type *) let rec tree_of_modtype = function | Mty_ident p -> Omty_ident (tree_of_path p) | Mty_signature sg -> Omty_signature (tree_of_signature sg) | Mty_functor(param, ty_arg, ty_res) -> Omty_functor (Ident.name param, tree_of_modtype ty_arg, tree_of_modtype ty_res) and tree_of_signature = function | [] -> [] | Sig_value(id, decl) :: rem -> tree_of_value_description id decl :: tree_of_signature rem | Sig_type(id, _, _) :: rem when is_row_name (Ident.name id) -> tree_of_signature rem | Sig_type(id, decl, rs) :: rem -> Osig_type(tree_of_type_decl id decl, tree_of_rec rs) :: tree_of_signature rem | Sig_exception(id, decl) :: rem -> tree_of_exception_declaration id decl :: tree_of_signature rem | Sig_module(id, mty, rs) :: rem -> Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) :: tree_of_signature rem | Sig_modtype(id, decl) :: rem -> tree_of_modtype_declaration id decl :: tree_of_signature rem | Sig_class(id, decl, rs) :: ctydecl :: tydecl1 :: tydecl2 :: rem -> tree_of_class_declaration id decl rs :: tree_of_signature rem | Sig_class_type(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> tree_of_cltype_declaration id decl rs :: tree_of_signature rem | _ -> assert false and tree_of_modtype_declaration id decl = let mty = match decl with | Modtype_abstract -> Omty_abstract | Modtype_manifest mty -> tree_of_modtype mty in Osig_modtype (Ident.name id, mty) let tree_of_module id mty rs = Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) let modtype_declaration id ppf decl = !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) (* Print a signature body (used by -i when compiling a .ml) *) let print_signature ppf tree = fprintf ppf "@[%a@]" !Oprint.out_signature tree let signature ppf sg = fprintf ppf "%a" print_signature (tree_of_signature sg) (* Print an unification error *) let type_expansion t ppf t' = if t == t' then type_expr ppf t else let t' = if proxy t == proxy t' then unalias t' else t' in fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t' let rec trace fst txt ppf = function | (t1, t1') :: (t2, t2') :: rem -> if not fst then fprintf ppf "@,"; fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a" (type_expansion t1) t1' txt (type_expansion t2) t2' (trace false txt) rem | _ -> () let rec filter_trace = function | (_, t1') :: (_, t2') :: [] when is_Tvar t1' || is_Tvar t2' -> [] | (t1, t1') :: (t2, t2') :: rem -> let rem' = filter_trace rem in if t1 == t1' && t2 == t2' then rem' else (t1, t1') :: (t2, t2') :: rem' | _ -> [] (* Hide variant name and var, to force printing the expanded type *) let hide_variant_name t = match repr t with | {desc = Tvariant row} as t when (row_repr row).row_name <> None -> newty2 t.level (Tvariant {(row_repr row) with row_name = None; row_more = newvar2 (row_more row).level}) | _ -> t let prepare_expansion (t, t') = let t' = hide_variant_name t' in mark_loops t; if t != t' then mark_loops t'; (t, t') let may_prepare_expansion compact (t, t') = match (repr t').desc with Tvariant _ | Tobject _ when compact -> mark_loops t; (t, t) | _ -> prepare_expansion (t, t') let print_tags ppf fields = match fields with [] -> () | (t, _) :: fields -> fprintf ppf "`%s" t; List.iter (fun (t, _) -> fprintf ppf ",@ `%s" t) fields let has_explanation unif t3 t4 = match t3.desc, t4.desc with Tfield _, (Tnil|Tconstr _) | (Tnil|Tconstr _), Tfield _ | _, Tvar _ | Tvar _, _ | Tvariant _, Tvariant _ -> true | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) -> l = l' | _ -> false let rec mismatch unif = function (_, t) :: (_, t') :: rem -> begin match mismatch unif rem with Some _ as m -> m | None -> if has_explanation unif t t' then Some(t,t') else None end | [] -> None | _ -> assert false let explanation unif t3 t4 ppf = match t3.desc, t4.desc with | Ttuple [], Tvar _ | Tvar _, Ttuple [] -> fprintf ppf "@,Self type cannot escape its class" | Tconstr (p, tl, _), Tvar _ when unif && t4.level < Path.binding_time p -> fprintf ppf "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" path p | Tvar _, Tconstr (p, tl, _) when unif && t3.level < Path.binding_time p -> fprintf ppf "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" path p | Tvar _, Tunivar _ | Tunivar _, Tvar _ -> fprintf ppf "@,The universal variable %a would escape its scope" type_expr (if is_Tunivar t3 then t3 else t4) | Tvar _, _ | _, Tvar _ -> let t, t' = if is_Tvar t3 then (t3, t4) else (t4, t3) in if occur_in Env.empty t t' then fprintf ppf "@,@[The type variable %a occurs inside@ %a@]" type_expr t type_expr t' else fprintf ppf "@,@[This instance of %a is ambiguous:@ %s@]" type_expr t' "it would escape the scope of its equation" | Tfield (lab, _, _, _), _ | _, Tfield (lab, _, _, _) when lab = dummy_method -> fprintf ppf "@,Self type cannot be unified with a closed object type" | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) when l = l' -> fprintf ppf "@,Types for method %s are incompatible" l | (Tnil|Tconstr _), Tfield (l, _, _, _) -> fprintf ppf "@,@[The first object type has no method %s@]" l | Tfield (l, _, _, _), (Tnil|Tconstr _) -> fprintf ppf "@,@[The second object type has no method %s@]" l | Tvariant row1, Tvariant row2 -> let row1 = row_repr row1 and row2 = row_repr row2 in begin match row1.row_fields, row1.row_closed, row2.row_fields, row2.row_closed with | [], true, [], true -> fprintf ppf "@,These two variant types have no intersection" | [], true, fields, _ -> fprintf ppf "@,@[The first variant type does not allow tag(s)@ @[%a@]@]" print_tags fields | fields, _, [], true -> fprintf ppf "@,@[The second variant type does not allow tag(s)@ @[%a@]@]" print_tags fields | [l1,_], true, [l2,_], true when l1 = l2 -> fprintf ppf "@,Types for tag `%s are incompatible" l1 | _ -> () end | _ -> () let explanation unif mis ppf = match mis with None -> () | Some (t3, t4) -> explanation unif t3 t4 ppf let ident_same_name id1 id2 = if Ident.equal id1 id2 && not (Ident.same id1 id2) then begin add_unique id1; add_unique id2 end let rec path_same_name p1 p2 = match p1, p2 with Pident id1, Pident id2 -> ident_same_name id1 id2 | Pdot (p1, s1, _), Pdot (p2, s2, _) when s1 = s2 -> path_same_name p1 p2 | Papply (p1, p1'), Papply (p2, p2') -> path_same_name p1 p2; path_same_name p1' p2' | _ -> () let type_same_name t1 t2 = match (repr t1).desc, (repr t2).desc with Tconstr (p1, _, _), Tconstr (p2, _, _) -> path_same_name p1 p2 | _ -> () let rec trace_same_names = function (t1, t1') :: (t2, t2') :: rem -> type_same_name t1 t2; type_same_name t1' t2'; trace_same_names rem | _ -> () let unification_error unif tr txt1 ppf txt2 = reset (); trace_same_names tr; let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in let mis = mismatch unif tr in match tr with | [] | _ :: [] -> assert false | t1 :: t2 :: tr -> try let tr = filter_trace tr in let t1, t1' = may_prepare_expansion (tr = []) t1 and t2, t2' = may_prepare_expansion (tr = []) t2 in print_labels := not !Clflags.classic; let tr = List.map prepare_expansion tr in fprintf ppf "@[\ @[%t@;<1 2>%a@ \ %t@;<1 2>%a\ @]%a%t\ @]" txt1 (type_expansion t1) t1' txt2 (type_expansion t2) t2' (trace false "is not compatible with type") tr (explanation unif mis); print_labels := true with exn -> print_labels := true; raise exn let report_unification_error ppf tr txt1 txt2 = unification_error true tr txt1 ppf txt2;; let trace fst txt ppf tr = print_labels := not !Clflags.classic; trace_same_names tr; try match tr with t1 :: t2 :: tr' -> if fst then trace fst txt ppf (t1 :: t2 :: filter_trace tr') else trace fst txt ppf (filter_trace tr); print_labels := true | _ -> () with exn -> print_labels := true; raise exn let report_subtyping_error ppf tr1 txt1 tr2 = reset (); let tr1 = List.map prepare_expansion tr1 and tr2 = List.map prepare_expansion tr2 in trace true txt1 ppf tr1; if tr2 = [] then () else let mis = mismatch true tr2 in trace false "is not compatible with type" ppf tr2; explanation true mis ppf mingw-ocaml/ocaml/typing/oprint.mli0000644000175000017500000000243612124403242017014 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Format open Outcometree val out_value : (formatter -> out_value -> unit) ref val out_type : (formatter -> out_type -> unit) ref val out_class_type : (formatter -> out_class_type -> unit) ref val out_module_type : (formatter -> out_module_type -> unit) ref val out_sig_item : (formatter -> out_sig_item -> unit) ref val out_signature : (formatter -> out_sig_item list -> unit) ref val out_phrase : (formatter -> out_phrase -> unit) ref val parenthesized_ident : string -> bool mingw-ocaml/ocaml/typing/includemod.ml0000644000175000017500000004271212124403242017454 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Inclusion checks for the module language *) open Misc open Path open Typedtree open Types type symptom = Missing_field of Ident.t | Value_descriptions of Ident.t * value_description * value_description | Type_declarations of Ident.t * type_declaration * type_declaration * Includecore.type_mismatch list | Exception_declarations of Ident.t * exception_declaration * exception_declaration | Module_types of module_type * module_type | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration | Modtype_permutation | Interface_mismatch of string * string | Class_type_declarations of Ident.t * class_type_declaration * class_type_declaration * Ctype.class_match_failure list | Class_declarations of Ident.t * class_declaration * class_declaration * Ctype.class_match_failure list | Unbound_modtype_path of Path.t type pos = Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t type error = pos list * symptom exception Error of error list (* All functions "blah env x1 x2" check that x1 is included in x2, i.e. that x1 is the type of an implementation that fulfills the specification x2. If not, Error is raised with a backtrace of the error. *) (* Inclusion between value descriptions *) let value_descriptions env cxt subst id vd1 vd2 = Env.mark_value_used (Ident.name id) vd1; let vd2 = Subst.value_description subst vd2 in try Includecore.value_descriptions env vd1 vd2 with Includecore.Dont_match -> raise(Error[cxt, Value_descriptions(id, vd1, vd2)]) (* Inclusion between type declarations *) let type_declarations env cxt subst id decl1 decl2 = Env.mark_type_used (Ident.name id) decl1; let decl2 = Subst.type_declaration subst decl2 in let err = Includecore.type_declarations env (Ident.name id) decl1 id decl2 in if err <> [] then raise(Error[cxt, Type_declarations(id, decl1, decl2, err)]) (* Inclusion between exception declarations *) let exception_declarations env cxt subst id decl1 decl2 = Env.mark_exception_used Env.Positive decl1 (Ident.name id); let decl2 = Subst.exception_declaration subst decl2 in if Includecore.exception_declarations env decl1 decl2 then () else raise(Error[cxt, Exception_declarations(id, decl1, decl2)]) (* Inclusion between class declarations *) let class_type_declarations env cxt subst id decl1 decl2 = let decl2 = Subst.cltype_declaration subst decl2 in match Includeclass.class_type_declarations env decl1 decl2 with [] -> () | reason -> raise(Error[cxt, Class_type_declarations(id, decl1, decl2, reason)]) let class_declarations env cxt subst id decl1 decl2 = let decl2 = Subst.class_declaration subst decl2 in match Includeclass.class_declarations env decl1 decl2 with [] -> () | reason -> raise(Error[cxt, Class_declarations(id, decl1, decl2, reason)]) (* Expand a module type identifier when possible *) exception Dont_match let expand_module_path env cxt path = try Env.find_modtype_expansion path env with Not_found -> raise(Error[cxt, Unbound_modtype_path path]) (* Extract name, kind and ident from a signature item *) type field_desc = Field_value of string | Field_type of string | Field_exception of string | Field_module of string | Field_modtype of string | Field_class of string | Field_classtype of string let item_ident_name = function Sig_value(id, _) -> (id, Field_value(Ident.name id)) | Sig_type(id, _, _) -> (id, Field_type(Ident.name id)) | Sig_exception(id, _) -> (id, Field_exception(Ident.name id)) | Sig_module(id, _, _) -> (id, Field_module(Ident.name id)) | Sig_modtype(id, _) -> (id, Field_modtype(Ident.name id)) | Sig_class(id, _, _) -> (id, Field_class(Ident.name id)) | Sig_class_type(id, _, _) -> (id, Field_classtype(Ident.name id)) (* Simplify a structure coercion *) let simplify_structure_coercion cc = let rec is_identity_coercion pos = function | [] -> true | (n, c) :: rem -> n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in if is_identity_coercion 0 cc then Tcoerce_none else Tcoerce_structure cc (* Inclusion between module types. Return the restriction that transforms a value of the smaller type into a value of the bigger type. *) let rec modtypes env cxt subst mty1 mty2 = try try_modtypes env cxt subst mty1 mty2 with Dont_match -> raise(Error[cxt, Module_types(mty1, Subst.modtype subst mty2)]) | Error reasons -> raise(Error((cxt, Module_types(mty1, Subst.modtype subst mty2)) :: reasons)) and try_modtypes env cxt subst mty1 mty2 = match (mty1, mty2) with (_, Mty_ident p2) -> try_modtypes2 env cxt mty1 (Subst.modtype subst mty2) | (Mty_ident p1, _) -> try_modtypes env cxt subst (expand_module_path env cxt p1) mty2 | (Mty_signature sig1, Mty_signature sig2) -> signatures env cxt subst sig1 sig2 | (Mty_functor(param1, arg1, res1), Mty_functor(param2, arg2, res2)) -> let arg2' = Subst.modtype subst arg2 in let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in let cc_res = modtypes (Env.add_module param1 arg2' env) (Body param1::cxt) (Subst.add_module param2 (Pident param1) subst) res1 res2 in begin match (cc_arg, cc_res) with (Tcoerce_none, Tcoerce_none) -> Tcoerce_none | _ -> Tcoerce_functor(cc_arg, cc_res) end | (_, _) -> raise Dont_match and try_modtypes2 env cxt mty1 mty2 = (* mty2 is an identifier *) match (mty1, mty2) with (Mty_ident p1, Mty_ident p2) when Path.same p1 p2 -> Tcoerce_none | (_, Mty_ident p2) -> try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2) | (_, _) -> assert false (* Inclusion between signatures *) and signatures env cxt subst sig1 sig2 = (* Environment used to check inclusion of components *) let new_env = Env.add_signature sig1 (Env.in_signature env) in (* Build a table of the components of sig1, along with their positions. The table is indexed by kind and name of component *) let rec build_component_table pos tbl = function [] -> tbl | item :: rem -> let (id, name) = item_ident_name item in let nextpos = match item with Sig_value(_,{val_kind = Val_prim _}) | Sig_type(_,_,_) | Sig_modtype(_,_) | Sig_class_type(_,_,_) -> pos | Sig_value(_,_) | Sig_exception(_,_) | Sig_module(_,_,_) | Sig_class(_, _,_) -> pos+1 in build_component_table nextpos (Tbl.add name (id, item, pos) tbl) rem in let comps1 = build_component_table 0 Tbl.empty sig1 in (* Pair each component of sig2 with a component of sig1, identifying the names along the way. Return a coercion list indicating, for all run-time components of sig2, the position of the matching run-time components of sig1 and the coercion to be applied to it. *) let rec pair_components subst paired unpaired = function [] -> begin match unpaired with [] -> signature_components new_env cxt subst (List.rev paired) | _ -> raise(Error unpaired) end | item2 :: rem -> let (id2, name2) = item_ident_name item2 in let name2, report = match item2, name2 with Sig_type (_, {type_manifest=None}, _), Field_type s when let l = String.length s in l >= 4 && String.sub s (l-4) 4 = "#row" -> (* Do not report in case of failure, as the main type will generate an error *) Field_type (String.sub s 0 (String.length s - 4)), false | _ -> name2, true in begin try let (id1, item1, pos1) = Tbl.find name2 comps1 in let new_subst = match item2 with Sig_type _ -> Subst.add_type id2 (Pident id1) subst | Sig_module _ -> Subst.add_module id2 (Pident id1) subst | Sig_modtype _ -> Subst.add_modtype id2 (Mty_ident (Pident id1)) subst | Sig_value _ | Sig_exception _ | Sig_class _ | Sig_class_type _ -> subst in pair_components new_subst ((item1, item2, pos1) :: paired) unpaired rem with Not_found -> let unpaired = if report then (cxt, Missing_field id2) :: unpaired else unpaired in pair_components subst paired unpaired rem end in (* Do the pairing and checking, and return the final coercion *) simplify_structure_coercion (pair_components subst [] [] sig2) (* Inclusion between signature components *) and signature_components env cxt subst = function [] -> [] | (Sig_value(id1, valdecl1), Sig_value(id2, valdecl2), pos) :: rem -> let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in begin match valdecl2.val_kind with Val_prim p -> signature_components env cxt subst rem | _ -> (pos, cc) :: signature_components env cxt subst rem end | (Sig_type(id1, tydecl1, _), Sig_type(id2, tydecl2, _), pos) :: rem -> type_declarations env cxt subst id1 tydecl1 tydecl2; signature_components env cxt subst rem | (Sig_exception(id1, excdecl1), Sig_exception(id2, excdecl2), pos) :: rem -> exception_declarations env cxt subst id1 excdecl1 excdecl2; (pos, Tcoerce_none) :: signature_components env cxt subst rem | (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem -> let cc = modtypes env (Module id1::cxt) subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in (pos, cc) :: signature_components env cxt subst rem | (Sig_modtype(id1, info1), Sig_modtype(id2, info2), pos) :: rem -> modtype_infos env cxt subst id1 info1 info2; signature_components env cxt subst rem | (Sig_class(id1, decl1, _), Sig_class(id2, decl2, _), pos) :: rem -> class_declarations env cxt subst id1 decl1 decl2; (pos, Tcoerce_none) :: signature_components env cxt subst rem | (Sig_class_type(id1, info1, _), Sig_class_type(id2, info2, _), pos) :: rem -> class_type_declarations env cxt subst id1 info1 info2; signature_components env cxt subst rem | _ -> assert false (* Inclusion between module type specifications *) and modtype_infos env cxt subst id info1 info2 = let info2 = Subst.modtype_declaration subst info2 in let cxt' = Modtype id :: cxt in try match (info1, info2) with (Modtype_abstract, Modtype_abstract) -> () | (Modtype_manifest mty1, Modtype_abstract) -> () | (Modtype_manifest mty1, Modtype_manifest mty2) -> check_modtype_equiv env cxt' mty1 mty2 | (Modtype_abstract, Modtype_manifest mty2) -> check_modtype_equiv env cxt' (Mty_ident(Pident id)) mty2 with Error reasons -> raise(Error((cxt, Modtype_infos(id, info1, info2)) :: reasons)) and check_modtype_equiv env cxt mty1 mty2 = match (modtypes env cxt Subst.identity mty1 mty2, modtypes env cxt Subst.identity mty2 mty1) with (Tcoerce_none, Tcoerce_none) -> () | (_, _) -> raise(Error [cxt, Modtype_permutation]) (* Simplified inclusion check between module types (for Env) *) let check_modtype_inclusion env mty1 path1 mty2 = try ignore(modtypes env [] Subst.identity (Mtype.strengthen env mty1 path1) mty2) with Error reasons -> raise Not_found let _ = Env.check_modtype_inclusion := check_modtype_inclusion (* Check that an implementation of a compilation unit meets its interface. *) let compunit impl_name impl_sig intf_name intf_sig = try signatures Env.initial [] Subst.identity impl_sig intf_sig with Error reasons -> raise(Error(([], Interface_mismatch(impl_name, intf_name)) :: reasons)) (* Hide the context and substitution parameters to the outside world *) let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2 let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2 let type_declarations env id decl1 decl2 = type_declarations env [] Subst.identity id decl1 decl2 (* Error report *) open Format open Printtyp let show_loc msg ppf loc = let pos = loc.Location.loc_start in if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then () else fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg let show_locs ppf (loc1, loc2) = show_loc "Expected declaration" ppf loc2; show_loc "Actual declaration" ppf loc1 let include_err ppf = function | Missing_field id -> fprintf ppf "The field `%a' is required but not provided" ident id | Value_descriptions(id, d1, d2) -> fprintf ppf "@[Values do not match:@ %a@;<1 -2>is not included in@ %a@]" (value_description id) d1 (value_description id) d2; show_locs ppf (d1.val_loc, d2.val_loc); | Type_declarations(id, d1, d2, errs) -> fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" "Type declarations do not match" (type_declaration id) d1 "is not included in" (type_declaration id) d2 show_locs (d1.type_loc, d2.type_loc) (Includecore.report_type_mismatch "the first" "the second" "declaration") errs | Exception_declarations(id, d1, d2) -> fprintf ppf "@[Exception declarations do not match:@ \ %a@;<1 -2>is not included in@ %a@]" (exception_declaration id) d1 (exception_declaration id) d2; show_locs ppf (d1.exn_loc, d2.exn_loc) | Module_types(mty1, mty2)-> fprintf ppf "@[Modules do not match:@ \ %a@;<1 -2>is not included in@ %a@]" modtype mty1 modtype mty2 | Modtype_infos(id, d1, d2) -> fprintf ppf "@[Module type declarations do not match:@ \ %a@;<1 -2>does not match@ %a@]" (modtype_declaration id) d1 (modtype_declaration id) d2 | Modtype_permutation -> fprintf ppf "Illegal permutation of structure fields" | Interface_mismatch(impl_name, intf_name) -> fprintf ppf "@[The implementation %s@ does not match the interface %s:" impl_name intf_name | Class_type_declarations(id, d1, d2, reason) -> fprintf ppf "@[Class type declarations do not match:@ \ %a@;<1 -2>does not match@ %a@]@ %a" (Printtyp.cltype_declaration id) d1 (Printtyp.cltype_declaration id) d2 Includeclass.report_error reason | Class_declarations(id, d1, d2, reason) -> fprintf ppf "@[Class declarations do not match:@ \ %a@;<1 -2>does not match@ %a@]@ %a" (Printtyp.class_declaration id) d1 (Printtyp.class_declaration id) d2 Includeclass.report_error reason | Unbound_modtype_path path -> fprintf ppf "Unbound module type %a" Printtyp.path path let rec context ppf = function Module id :: rem -> fprintf ppf "@[<2>module %a%a@]" ident id args rem | Modtype id :: rem -> fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem | Body x :: rem -> fprintf ppf "functor (%a) ->@ %a" ident x context_mty rem | Arg x :: rem -> fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem | [] -> fprintf ppf "" and context_mty ppf = function (Module _ | Modtype _) :: _ as rem -> fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem | cxt -> context ppf cxt and args ppf = function Body x :: rem -> fprintf ppf "(%a)%a" ident x args rem | Arg x :: rem -> fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem | cxt -> fprintf ppf " :@ %a" context_mty cxt let path_of_context = function Module id :: rem -> let rec subm path = function [] -> path | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem | _ -> assert false in subm (Pident id) rem | _ -> assert false let context ppf cxt = if cxt = [] then () else if List.for_all (function Module _ -> true | _ -> false) cxt then fprintf ppf "In module %a:@ " path (path_of_context cxt) else fprintf ppf "@[At position@ %a@]@ " context cxt let include_err ppf (cxt, err) = fprintf ppf "@[%a%a@]" context (List.rev cxt) include_err err let buffer = ref "" let is_big obj = let size = !Clflags.error_size in size > 0 && begin if String.length !buffer < size then buffer := String.create size; try ignore (Marshal.to_buffer !buffer 0 size obj []); false with _ -> true end let report_error ppf errs = if errs = [] then () else let (errs , err) = split_last errs in let pe = ref true in let include_err' ppf err = if not (is_big err) then fprintf ppf "%a@ " include_err err else if !pe then (fprintf ppf "...@ "; pe := false) in let print_errs ppf = List.iter (include_err' ppf) in fprintf ppf "@[%a%a@]" print_errs errs include_err err mingw-ocaml/ocaml/typing/printtyp.mli0000644000175000017500000000672112124403242017373 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Printing functions *) open Format open Types open Outcometree val longident: formatter -> Longident.t -> unit val ident: formatter -> Ident.t -> unit val tree_of_path: Path.t -> out_ident val path: formatter -> Path.t -> unit val raw_type_expr: formatter -> type_expr -> unit val reset: unit -> unit val mark_loops: type_expr -> unit val reset_and_mark_loops: type_expr -> unit val reset_and_mark_loops_list: type_expr list -> unit val type_expr: formatter -> type_expr -> unit val tree_of_type_scheme: type_expr -> out_type val type_sch : formatter -> type_expr -> unit val type_scheme: formatter -> type_expr -> unit (* Maxence *) val reset_names: unit -> unit val type_scheme_max: ?b_reset_names: bool -> formatter -> type_expr -> unit (* Fin Maxence *) val tree_of_value_description: Ident.t -> value_description -> out_sig_item val value_description: Ident.t -> formatter -> value_description -> unit val tree_of_type_declaration: Ident.t -> type_declaration -> rec_status -> out_sig_item val type_declaration: Ident.t -> formatter -> type_declaration -> unit val tree_of_exception_declaration: Ident.t -> exception_declaration -> out_sig_item val exception_declaration: Ident.t -> formatter -> exception_declaration -> unit val tree_of_module: Ident.t -> module_type -> rec_status -> out_sig_item val modtype: formatter -> module_type -> unit val signature: formatter -> signature -> unit val tree_of_modtype_declaration: Ident.t -> modtype_declaration -> out_sig_item val tree_of_signature: Types.signature -> out_sig_item list val tree_of_typexp: bool -> type_expr -> out_type val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit val class_type: formatter -> class_type -> unit val tree_of_class_declaration: Ident.t -> class_declaration -> rec_status -> out_sig_item val class_declaration: Ident.t -> formatter -> class_declaration -> unit val tree_of_cltype_declaration: Ident.t -> class_type_declaration -> rec_status -> out_sig_item val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit val type_expansion: type_expr -> Format.formatter -> type_expr -> unit val prepare_expansion: type_expr * type_expr -> type_expr * type_expr val trace: bool -> string -> formatter -> (type_expr * type_expr) list -> unit val unification_error: bool -> (type_expr * type_expr) list -> (formatter -> unit) -> formatter -> (formatter -> unit) -> unit val report_unification_error: formatter -> (type_expr * type_expr) list -> (formatter -> unit) -> (formatter -> unit) -> unit val report_subtyping_error: formatter -> (type_expr * type_expr) list -> string -> (type_expr * type_expr) list -> unit mingw-ocaml/ocaml/typing/predef.mli0000644000175000017500000000427212124403242016746 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Predefined type constructors (with special typing rules in typecore) *) open Types val type_int: type_expr val type_char: type_expr val type_string: type_expr val type_float: type_expr val type_bool: type_expr val type_unit: type_expr val type_exn: type_expr val type_array: type_expr -> type_expr val type_list: type_expr -> type_expr val type_option: type_expr -> type_expr val type_nativeint: type_expr val type_int32: type_expr val type_int64: type_expr val type_lazy_t: type_expr -> type_expr val path_int: Path.t val path_char: Path.t val path_string: Path.t val path_float: Path.t val path_bool: Path.t val path_unit: Path.t val path_exn: Path.t val path_array: Path.t val path_list: Path.t val path_format6: Path.t val path_option: Path.t val path_nativeint: Path.t val path_int32: Path.t val path_int64: Path.t val path_lazy_t: Path.t val path_match_failure: Path.t val path_assert_failure : Path.t val path_undefined_recursive_module : Path.t (* To build the initial environment. Since there is a nasty mutual recursion between predef and env, we break it by parameterizing over Env.t, Env.add_type and Env.add_exception. *) val build_initial_env: (Ident.t -> type_declaration -> 'a -> 'a) -> (Ident.t -> exception_declaration -> 'a -> 'a) -> 'a -> 'a (* To initialize linker tables *) val builtin_values: (string * Ident.t) list val builtin_idents: (string * Ident.t) list mingw-ocaml/ocaml/typing/cmi_format.mli0000644000175000017500000000302212124403242017611 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Fabrice Le Fessant, INRIA Saclay *) (* *) (* Copyright 2012 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) type pers_flags = Rectypes type cmi_infos = { cmi_name : string; cmi_sign : Types.signature_item list; cmi_crcs : (string * Digest.t) list; cmi_flags : pers_flags list; } (* write the magic + the cmi information *) val output_cmi : string -> out_channel -> cmi_infos -> Digest.t (* read the cmi information (the magic is supposed to have already been read) *) val input_cmi : in_channel -> cmi_infos (* read a cmi from a filename, checking the magic *) val read_cmi : string -> cmi_infos (* Error report *) type error = Not_an_interface of string | Wrong_version_interface of string * string | Corrupted_interface of string exception Error of error open Format val report_error: formatter -> error -> unit mingw-ocaml/ocaml/typing/btype.mli0000644000175000017500000001475212124403242016630 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Basic operations on core types *) open Asttypes open Types (**** Sets, maps and hashtables of types ****) module TypeSet : Set.S with type elt = type_expr module TypeMap : Map.S with type key = type_expr module TypeHash : Hashtbl.S with type key = type_expr (**** Levels ****) val generic_level: int val newty2: int -> type_desc -> type_expr (* Create a type *) val newgenty: type_desc -> type_expr (* Create a generic type *) val newgenvar: ?name:string -> unit -> type_expr (* Return a fresh generic variable *) (* Use Tsubst instead val newmarkedvar: int -> type_expr (* Return a fresh marked variable *) val newmarkedgenvar: unit -> type_expr (* Return a fresh marked generic variable *) *) val is_Tvar: type_expr -> bool val is_Tunivar: type_expr -> bool val dummy_method: label val repr: type_expr -> type_expr (* Return the canonical representative of a type. *) val field_kind_repr: field_kind -> field_kind (* Return the canonical representative of an object field kind. *) val commu_repr: commutable -> commutable (* Return the canonical representative of a commutation lock *) (**** polymorphic variants ****) val row_repr: row_desc -> row_desc (* Return the canonical representative of a row description *) val row_field_repr: row_field -> row_field val row_field: label -> row_desc -> row_field (* Return the canonical representative of a row field *) val row_more: row_desc -> type_expr (* Return the extension variable of the row *) val row_fixed: row_desc -> bool (* Return whether the row should be treated as fixed or not *) val static_row: row_desc -> bool (* Return whether the row is static or not *) val hash_variant: label -> int (* Hash function for variant tags *) val proxy: type_expr -> type_expr (* Return the proxy representative of the type: either itself or a row variable *) (**** Utilities for private abbreviations with fixed rows ****) val has_constr_row: type_expr -> bool val is_row_name: string -> bool (**** Utilities for type traversal ****) val iter_type_expr: (type_expr -> unit) -> type_expr -> unit (* Iteration on types *) val iter_row: (type_expr -> unit) -> row_desc -> unit (* Iteration on types in a row *) val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit (* Iteration on types in an abbreviation list *) val copy_type_desc: ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc (* Copy on types *) val copy_row: (type_expr -> type_expr) -> bool -> row_desc -> bool -> type_expr -> row_desc val copy_kind: field_kind -> field_kind val save_desc: type_expr -> type_desc -> unit (* Save a type description *) val dup_kind: field_kind option ref -> unit (* Save a None field_kind, and make it point to a fresh Fvar *) val cleanup_types: unit -> unit (* Restore type descriptions *) val lowest_level: int (* Marked type: ty.level < lowest_level *) val pivot_level: int (* Type marking: ty.level <- pivot_level - ty.level *) val mark_type: type_expr -> unit (* Mark a type *) val mark_type_node: type_expr -> unit (* Mark a type node (but not its sons) *) val mark_type_params: type_expr -> unit (* Mark the sons of a type node *) val unmark_type: type_expr -> unit val unmark_type_decl: type_declaration -> unit val unmark_class_type: class_type -> unit val unmark_class_signature: class_signature -> unit (* Remove marks from a type *) (**** Memorization of abbreviation expansion ****) val find_expans: private_flag -> Path.t -> abbrev_memo -> type_expr option (* Look up a memorized abbreviation *) val cleanup_abbrev: unit -> unit (* Flush the cache of abbreviation expansions. When some types are saved (using [output_value]), this function MUST be called just before. *) val memorize_abbrev: abbrev_memo ref -> private_flag -> Path.t -> type_expr -> type_expr -> unit (* Add an expansion in the cache *) val forget_abbrev: abbrev_memo ref -> Path.t -> unit (* Remove an abbreviation from the cache *) (**** Utilities for labels ****) val is_optional : label -> bool val label_name : label -> label val extract_label : label -> (label * 'a) list -> label * 'a * (label * 'a) list * (label * 'a) list (* actual label, value, before list, after list *) (**** Utilities for backtracking ****) type snapshot (* A snapshot for backtracking *) val snapshot: unit -> snapshot (* Make a snapshot for later backtracking. Costs nothing *) val backtrack: snapshot -> unit (* Backtrack to a given snapshot. Only possible if you have not already backtracked to a previous snapshot. Calls [cleanup_abbrev] internally *) (* Functions to use when modifying a type (only Ctype?) *) val link_type: type_expr -> type_expr -> unit (* Set the desc field of [t1] to [Tlink t2], logging the old value if there is an active snapshot *) val set_level: type_expr -> int -> unit val set_name: (Path.t * type_expr list) option ref -> (Path.t * type_expr list) option -> unit val set_row_field: row_field option ref -> row_field -> unit val set_univar: type_expr option ref -> type_expr -> unit val set_kind: field_kind option ref -> field_kind -> unit val set_commu: commutable ref -> commutable -> unit val set_typeset: TypeSet.t ref -> TypeSet.t -> unit (* Set references, logging the old value *) val log_type: type_expr -> unit (* Log the old value of a type, before modifying it by hand *) (**** Forward declarations ****) val print_raw: (Format.formatter -> type_expr -> unit) ref mingw-ocaml/ocaml/typing/typecore.mli0000644000175000017500000001230312124403242017325 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Type inference for the core language *) open Asttypes open Types open Format val is_nonexpansive: Typedtree.expression -> bool val type_binding: Env.t -> rec_flag -> (Parsetree.pattern * Parsetree.expression) list -> Annot.ident option -> (Typedtree.pattern * Typedtree.expression) list * Env.t val type_let: Env.t -> rec_flag -> (Parsetree.pattern * Parsetree.expression) list -> Annot.ident option -> (Typedtree.pattern * Typedtree.expression) list * Env.t val type_expression: Env.t -> Parsetree.expression -> Typedtree.expression val type_class_arg_pattern: string -> Env.t -> Env.t -> label -> Parsetree.pattern -> Typedtree.pattern * (Ident.t * string loc * Ident.t * type_expr) list * Env.t * Env.t val type_self_pattern: string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern -> Typedtree.pattern * (Ident.t * type_expr) Meths.t ref * (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t ref * Env.t * Env.t * Env.t val type_expect: ?in_function:(Location.t * type_expr) -> Env.t -> Parsetree.expression -> type_expr -> Typedtree.expression val type_exp: Env.t -> Parsetree.expression -> Typedtree.expression val type_approx: Env.t -> Parsetree.expression -> type_expr val type_argument: Env.t -> Parsetree.expression -> type_expr -> type_expr -> Typedtree.expression val option_some: Typedtree.expression -> Typedtree.expression val option_none: type_expr -> Location.t -> Typedtree.expression val extract_option_type: Env.t -> type_expr -> type_expr val iter_pattern: (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit val generalizable: int -> type_expr -> bool val reset_delayed_checks: unit -> unit val force_delayed_checks: unit -> unit val self_coercion : (Path.t * Location.t list ref) list ref type error = Polymorphic_label of Longident.t | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * (type_expr * type_expr) list | Pattern_type_clash of (type_expr * type_expr) list | Multiply_bound_variable of string | Orpat_vars of Ident.t | Expr_type_clash of (type_expr * type_expr) list | Apply_non_function of type_expr | Apply_wrong_label of label * type_expr | Label_multiply_defined of Longident.t | Label_missing of Ident.t list | Label_not_mutable of Longident.t | Incomplete_format of string | Bad_conversion of string * int * char | Undefined_method of type_expr * string | Undefined_inherited_method of string | Virtual_class of Longident.t | Private_type of type_expr | Private_label of Longident.t * type_expr | Unbound_instance_variable of string | Instance_variable_not_mutable of bool * string | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list | Outside_class | Value_multiply_overridden of string | Coercion_failure of type_expr * type_expr * (type_expr * type_expr) list * bool | Too_many_arguments of bool * type_expr | Abstract_wrong_label of label * type_expr | Scoping_let_module of string * type_expr | Masked_instance_variable of Longident.t | Not_a_variant_type of Longident.t | Incoherent_label_order | Less_general of string * (type_expr * type_expr) list | Modules_not_allowed | Cannot_infer_signature | Not_a_packed_module of type_expr | Recursive_local_constraint of (type_expr * type_expr) list | Unexpected_existential exception Error of Location.t * error val report_error: formatter -> error -> unit (* Forward declaration, to be filled in by Typemod.type_module *) val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref (* Forward declaration, to be filled in by Typemod.type_open *) val type_open: (Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t) ref (* Forward declaration, to be filled in by Typeclass.class_structure *) val type_object: (Env.t -> Location.t -> Parsetree.class_structure -> Typedtree.class_structure * Types.class_signature * string list) ref val type_package: (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list -> type_expr list -> Typedtree.module_expr * type_expr list) ref val create_package_type : Location.t -> Env.t -> Longident.t * (Longident.t * Parsetree.core_type) list -> Path.t * (Longident.t * Typedtree.core_type) list * Types.type_expr mingw-ocaml/ocaml/typing/annot.mli0000644000175000017500000000202612124403242016613 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Damien Doligez, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Data types for annotations (Stypes.ml) *) type call = Tail | Stack | Inline;; type ident = | Iref_internal of Location.t (* defining occurrence *) | Iref_external | Idef of Location.t (* scope *) ;; mingw-ocaml/ocaml/typing/typecore.ml0000644000175000017500000035440012124403242017163 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Typechecking for the core language *) open Misc open Asttypes open Parsetree open Types open Typedtree open Btype open Ctype type error = Polymorphic_label of Longident.t | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * (type_expr * type_expr) list | Pattern_type_clash of (type_expr * type_expr) list | Multiply_bound_variable of string | Orpat_vars of Ident.t | Expr_type_clash of (type_expr * type_expr) list | Apply_non_function of type_expr | Apply_wrong_label of label * type_expr | Label_multiply_defined of Longident.t | Label_missing of Ident.t list | Label_not_mutable of Longident.t | Incomplete_format of string | Bad_conversion of string * int * char | Undefined_method of type_expr * string | Undefined_inherited_method of string | Virtual_class of Longident.t | Private_type of type_expr | Private_label of Longident.t * type_expr | Unbound_instance_variable of string | Instance_variable_not_mutable of bool * string | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list | Outside_class | Value_multiply_overridden of string | Coercion_failure of type_expr * type_expr * (type_expr * type_expr) list * bool | Too_many_arguments of bool * type_expr | Abstract_wrong_label of label * type_expr | Scoping_let_module of string * type_expr | Masked_instance_variable of Longident.t | Not_a_variant_type of Longident.t | Incoherent_label_order | Less_general of string * (type_expr * type_expr) list | Modules_not_allowed | Cannot_infer_signature | Not_a_packed_module of type_expr | Recursive_local_constraint of (type_expr * type_expr) list | Unexpected_existential exception Error of Location.t * error (* Forward declaration, to be filled in by Typemod.type_module *) let type_module = ref ((fun env md -> assert false) : Env.t -> Parsetree.module_expr -> Typedtree.module_expr) (* Forward declaration, to be filled in by Typemod.type_open *) let type_open = ref (fun _ -> assert false) (* Forward declaration, to be filled in by Typemod.type_package *) let type_package = ref (fun _ -> assert false) (* Forward declaration, to be filled in by Typeclass.class_structure *) let type_object = ref (fun env s -> assert false : Env.t -> Location.t -> Parsetree.class_structure -> Typedtree.class_structure * Types.class_signature * string list) (* Saving and outputting type information. We keep these function names short, because they have to be called each time we create a record of type [Typedtree.expression] or [Typedtree.pattern] that will end up in the typed AST. *) let re node = Cmt_format.add_saved_type (Cmt_format.Partial_expression node); Stypes.record (Stypes.Ti_expr node); node ;; let rp node = Cmt_format.add_saved_type (Cmt_format.Partial_pattern node); Stypes.record (Stypes.Ti_pat node); node ;; let snd3 (_,x,_) = x let thd4 (_,_, x,_) = x (* Upper approximation of free identifiers on the parse tree *) let iter_expression f e = let rec expr e = f e; match e.pexp_desc with | Pexp_ident _ | Pexp_assertfalse | Pexp_new _ | Pexp_constant _ -> () | Pexp_function (_, eo, pel) -> may expr eo; List.iter (fun (_, e) -> expr e) pel | Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel | Pexp_let (_, pel, e) | Pexp_match (e, pel) | Pexp_try (e, pel) -> expr e; List.iter (fun (_, e) -> expr e) pel | Pexp_array el | Pexp_tuple el -> List.iter expr el | Pexp_construct (_, eo, _) | Pexp_variant (_, eo) -> may expr eo | Pexp_record (iel, eo) -> may expr eo; List.iter (fun (_, e) -> expr e) iel | Pexp_open (_, e) | Pexp_newtype (_, e) | Pexp_poly (e, _) | Pexp_lazy e | Pexp_assert e | Pexp_setinstvar (_, e) | Pexp_send (e, _) | Pexp_constraint (e, _, _) | Pexp_field (e, _) -> expr e | Pexp_when (e1, e2) | Pexp_while (e1, e2) | Pexp_sequence (e1, e2) | Pexp_setfield (e1, _, e2) -> expr e1; expr e2 | Pexp_ifthenelse (e1, e2, eo) -> expr e1; expr e2; may expr eo | Pexp_for (_, e1, e2, _, e3) -> expr e1; expr e2; expr e3 | Pexp_override sel -> List.iter (fun (_, e) -> expr e) sel | Pexp_letmodule (_, me, e) -> expr e; module_expr me | Pexp_object { pcstr_fields = fs } -> List.iter class_field fs | Pexp_pack me -> module_expr me and module_expr me = match me.pmod_desc with | Pmod_ident _ -> () | Pmod_structure str -> List.iter structure_item str | Pmod_constraint (me, _) | Pmod_functor (_, _, me) -> module_expr me | Pmod_apply (me1, me2) -> module_expr me1; module_expr me2 | Pmod_unpack e -> expr e and structure_item str = match str.pstr_desc with | Pstr_eval e -> expr e | Pstr_value (_, pel) -> List.iter (fun (_, e) -> expr e) pel | Pstr_primitive _ | Pstr_type _ | Pstr_exception _ | Pstr_modtype _ | Pstr_open _ | Pstr_class_type _ | Pstr_exn_rebind _ -> () | Pstr_include me | Pstr_module (_, me) -> module_expr me | Pstr_recmodule l -> List.iter (fun (_, _, me) -> module_expr me) l | Pstr_class cdl -> List.iter (fun c -> class_expr c.pci_expr) cdl and class_expr ce = match ce.pcl_desc with | Pcl_constr _ -> () | Pcl_structure { pcstr_fields = fs } -> List.iter class_field fs | Pcl_fun (_, eo, _, ce) -> may expr eo; class_expr ce | Pcl_apply (ce, lel) -> class_expr ce; List.iter (fun (_, e) -> expr e) lel | Pcl_let (_, pel, ce) -> List.iter (fun (_, e) -> expr e) pel; class_expr ce | Pcl_constraint (ce, _) -> class_expr ce and class_field cf = match cf.pcf_desc with | Pcf_inher (_, ce, _) -> class_expr ce | Pcf_valvirt _ | Pcf_virt _ | Pcf_constr _ -> () | Pcf_val (_,_,_,e) | Pcf_meth (_,_,_,e) -> expr e | Pcf_init e -> expr e in expr e let all_idents el = let idents = Hashtbl.create 8 in let f = function | {pexp_desc=Pexp_ident { txt = Longident.Lident id; _ }; _} -> Hashtbl.replace idents id () | _ -> () in List.iter (iter_expression f) el; Hashtbl.fold (fun x () rest -> x :: rest) idents [] (* Typing of constants *) let type_constant = function Const_int _ -> instance_def Predef.type_int | Const_char _ -> instance_def Predef.type_char | Const_string _ -> instance_def Predef.type_string | Const_float _ -> instance_def Predef.type_float | Const_int32 _ -> instance_def Predef.type_int32 | Const_int64 _ -> instance_def Predef.type_int64 | Const_nativeint _ -> instance_def Predef.type_nativeint (* Specific version of type_option, using newty rather than newgenty *) let type_option ty = newty (Tconstr(Predef.path_option,[ty], ref Mnil)) let mkexp exp_desc exp_type exp_loc exp_env = { exp_desc; exp_type; exp_loc; exp_env; exp_extra = [] } let option_none ty loc = let lid = Longident.Lident "None" in let (path, cnone) = Env.lookup_constructor lid Env.initial in mkexp (Texp_construct( path, mknoloc lid, cnone, [], false)) ty loc Env.initial let option_some texp = let lid = Longident.Lident "Some" in let (path, csome) = Env.lookup_constructor lid Env.initial in mkexp ( Texp_construct(path, mknoloc lid , csome, [texp],false) ) (type_option texp.exp_type) texp.exp_loc texp.exp_env let extract_option_type env ty = match expand_head env ty with {desc = Tconstr(path, [ty], _)} when Path.same path Predef.path_option -> ty | _ -> assert false let rec extract_label_names sexp env ty = let ty = expand_head env ty in match ty.desc with | Tconstr (path, _, _) -> let td = Env.find_type path env in begin match td.type_kind with | Type_record (fields, _) -> List.map (fun (name, _, _) -> name) fields | Type_abstract when td.type_manifest <> None -> extract_label_names sexp env (expand_head env ty) | _ -> assert false end | _ -> assert false (* Typing of patterns *) (* unification inside type_pat*) let unify_pat_types loc env ty ty' = try unify env ty ty' with Unify trace -> raise(Error(loc, Pattern_type_clash(trace))) | Tags(l1,l2) -> raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2))) (* unification inside type_exp and type_expect *) let unify_exp_types loc env ty expected_ty = (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type Printtyp.raw_type_expr expected_ty; *) try unify env ty expected_ty with Unify trace -> raise(Error(loc, Expr_type_clash(trace))) | Tags(l1,l2) -> raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2))) (* level at which to create the local type declarations *) let newtype_level = ref None let get_newtype_level () = match !newtype_level with Some y -> y | None -> assert false let unify_pat_types_gadt loc env ty ty' = let newtype_level = match !newtype_level with | None -> assert false | Some x -> x in try unify_gadt ~newtype_level env ty ty' with Unify trace -> raise(Error(loc, Pattern_type_clash(trace))) | Tags(l1,l2) -> raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2))) | Unification_recursive_abbrev trace -> raise(Error(loc, Recursive_local_constraint trace)) (* Creating new conjunctive types is not allowed when typing patterns *) let unify_pat env pat expected_ty = unify_pat_types pat.pat_loc env pat.pat_type expected_ty (* make all Reither present in open variants *) let finalize_variant pat = match pat.pat_desc with Tpat_variant(tag, opat, r) -> let row = match expand_head pat.pat_env pat.pat_type with {desc = Tvariant row} -> r := row; row_repr row | _ -> assert false in begin match row_field tag row with | Rabsent -> assert false | Reither (true, [], _, e) when not row.row_closed -> set_row_field e (Rpresent None) | Reither (false, ty::tl, _, e) when not row.row_closed -> set_row_field e (Rpresent (Some ty)); begin match opat with None -> assert false | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl) end | Reither (c, l, true, e) when not (row_fixed row) -> set_row_field e (Reither (c, [], false, ref None)) | _ -> () end; (* Force check of well-formedness WHY? *) (* unify_pat pat.pat_env pat (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false; row_bound=(); row_fixed=false; row_name=None})); *) | _ -> () let rec iter_pattern f p = f p; iter_pattern_desc (iter_pattern f) p.pat_desc let has_variants p = try iter_pattern (function {pat_desc=Tpat_variant _} -> raise Exit | _ -> ()) p; false with Exit -> true (* pattern environment *) let pattern_variables = ref ([] : (Ident.t * type_expr * string loc * Location.t * bool (* as-variable *)) list) let pattern_force = ref ([] : (unit -> unit) list) let pattern_scope = ref (None : Annot.ident option);; let allow_modules = ref false let module_variables = ref ([] : (string loc * Location.t) list) let reset_pattern scope allow = pattern_variables := []; pattern_force := []; pattern_scope := scope; allow_modules := allow; module_variables := []; ;; let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty = if List.exists (fun (id, _, _, _, _) -> Ident.name id = name.txt) !pattern_variables then raise(Error(loc, Multiply_bound_variable name.txt)); let id = Ident.create name.txt in pattern_variables := (id, ty, name, loc, is_as_variable) :: !pattern_variables; if is_module then begin (* Note: unpack patterns enter a variable of the same name *) if not !allow_modules then raise (Error (loc, Modules_not_allowed)); module_variables := (name, loc) :: !module_variables end else (* moved to genannot *) may (fun s -> Stypes.record (Stypes.An_ident (name.loc, name.txt, s))) !pattern_scope; id let sort_pattern_variables vs = List.sort (fun (x,_,_,_,_) (y,_,_,_,_) -> Pervasives.compare (Ident.name x) (Ident.name y)) vs let enter_orpat_variables loc env p1_vs p2_vs = (* unify_vars operate on sorted lists *) let p1_vs = sort_pattern_variables p1_vs and p2_vs = sort_pattern_variables p2_vs in let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with | (x1,t1,_,l1,a1)::rem1, (x2,t2,_,l2,a2)::rem2 when Ident.equal x1 x2 -> if x1==x2 then unify_vars rem1 rem2 else begin begin try unify env t1 t2 with | Unify trace -> raise(Error(loc, Pattern_type_clash(trace))) end; (x2,x1)::unify_vars rem1 rem2 end | [],[] -> [] | (x,_,_,_,_)::_, [] -> raise (Error (loc, Orpat_vars x)) | [],(x,_,_,_,_)::_ -> raise (Error (loc, Orpat_vars x)) | (x,_,_,_,_)::_, (y,_,_,_,_)::_ -> let min_var = if Ident.name x < Ident.name y then x else y in raise (Error (loc, Orpat_vars min_var)) in unify_vars p1_vs p2_vs let rec build_as_type env p = match p.pat_desc with Tpat_alias(p1,_, _) -> build_as_type env p1 | Tpat_tuple pl -> let tyl = List.map (build_as_type env) pl in newty (Ttuple tyl) | Tpat_construct(_, _, cstr, pl,_) -> let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in if keep then p.pat_type else let tyl = List.map (build_as_type env) pl in let ty_args, ty_res = instance_constructor cstr in List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty}) (List.combine pl tyl) ty_args; ty_res | Tpat_variant(l, p', _) -> let ty = may_map (build_as_type env) p' in newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar(); row_bound=(); row_name=None; row_fixed=false; row_closed=false}) | Tpat_record (lpl,_) -> let lbl = thd4 (List.hd lpl) in if lbl.lbl_private = Private then p.pat_type else let ty = newvar () in let ppl = List.map (fun (_, _, l, p) -> l.lbl_pos, p) lpl in let do_label lbl = let _, ty_arg, ty_res = instance_label false lbl in unify_pat env {p with pat_type = ty} ty_res; let refinable = lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl && match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in if refinable then begin let arg = List.assoc lbl.lbl_pos ppl in unify_pat env {arg with pat_type = build_as_type env arg} ty_arg end else begin let _, ty_arg', ty_res' = instance_label false lbl in unify env ty_arg ty_arg'; unify_pat env p ty_res' end in Array.iter do_label lbl.lbl_all; ty | Tpat_or(p1, p2, row) -> begin match row with None -> let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in unify_pat env {p2 with pat_type = ty2} ty1; ty1 | Some row -> let row = row_repr row in newty (Tvariant{row with row_closed=false; row_more=newvar()}) end | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_array _ | Tpat_lazy _ -> p.pat_type let build_or_pat env loc lid = let path, decl = Typetexp.find_type env loc lid in let tyl = List.map (fun _ -> newvar()) decl.type_params in let row0 = let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in match ty.desc with Tvariant row when static_row row -> row | _ -> raise(Error(loc, Not_a_variant_type lid)) in let pats, fields = List.fold_left (fun (pats,fields) (l,f) -> match row_field_repr f with Rpresent None -> (l,None) :: pats, (l, Reither(true,[], true, ref None)) :: fields | Rpresent (Some ty) -> (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; pat_type=ty; pat_extra=[];}) :: pats, (l, Reither(false, [ty], true, ref None)) :: fields | _ -> pats, fields) ([],[]) (row_repr row0).row_fields in let row = { row_fields = List.rev fields; row_more = newvar(); row_bound = (); row_closed = false; row_fixed = false; row_name = Some (path, tyl) } in let ty = newty (Tvariant row) in let gloc = {loc with Location.loc_ghost=true} in let row' = ref {row with row_more=newvar()} in let pats = List.map (fun (l,p) -> {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc; pat_env=env; pat_type=ty; pat_extra=[];}) pats in match pats with [] -> raise(Error(loc, Not_a_variant_type lid)) | pat :: pats -> let r = List.fold_left (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[]; pat_loc=gloc; pat_env=env; pat_type=ty}) pat pats in (path, rp { r with pat_loc = loc },ty) (* Records *) let rec find_record_qual = function | [] -> None | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname | _ :: rest -> find_record_qual rest let type_label_a_list ?labels env type_lbl_a lid_a_list = let record_qual = find_record_qual lid_a_list in let lbl_a_list = List.map (fun (lid, a) -> let path, label = match lid.txt, labels, record_qual with Longident.Lident s, Some labels, _ when Hashtbl.mem labels s -> (Hashtbl.find labels s : Path.t * Types.label_description) | Longident.Lident s, _, Some modname -> Typetexp.find_label env lid.loc (Longident.Ldot (modname, s)) | _ -> Typetexp.find_label env lid.loc lid.txt in (path, lid, label, a) ) lid_a_list in (* Invariant: records are sorted in the typed tree *) let lbl_a_list = List.sort (fun ( _, _, lbl1,_) ( _,_, lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos) lbl_a_list in List.map type_lbl_a lbl_a_list ;; let lid_of_label label = match repr label.lbl_res with | {desc = Tconstr(Path.Pdot(mpath,_,_),_,_)} -> Longident.Ldot(lid_of_path mpath, label.lbl_name) | _ -> Longident.Lident label.lbl_name (* Checks over the labels mentioned in a record pattern: no duplicate definitions (error); properly closed (warning) *) let check_recordpat_labels loc lbl_pat_list closed = match lbl_pat_list with | [] -> () (* should not happen *) | (_, _, label1, _) :: _ -> let all = label1.lbl_all in let defined = Array.make (Array.length all) false in let check_defined (_, _, label, _) = if defined.(label.lbl_pos) then raise(Error(loc, Label_multiply_defined (Longident.Lident label.lbl_name))) else defined.(label.lbl_pos) <- true in List.iter check_defined lbl_pat_list; if closed = Closed && Warnings.is_active (Warnings.Non_closed_record_pattern "") then begin let undefined = ref [] in for i = 0 to Array.length all - 1 do if not defined.(i) then undefined := all.(i).lbl_name :: !undefined done; if !undefined <> [] then begin let u = String.concat ", " (List.rev !undefined) in Location.prerr_warning loc (Warnings.Non_closed_record_pattern u) end end (* unification of a type with a tconstr with freshly created arguments *) let unify_head_only loc env ty constr = let (_, ty_res) = instance_constructor constr in match (repr ty_res).desc with | Tconstr(p,args,m) -> ty_res.desc <- Tconstr(p,List.map (fun _ -> newvar ()) args,m); enforce_constraints env ty_res; unify_pat_types loc env ty ty_res | _ -> assert false (* Typing of patterns *) (* type_pat does not generate local constraints inside or patterns *) type type_pat_mode = | Normal | Inside_or (* type_pat propagates the expected type as well as maps for constructors and labels. Unification may update the typing environment. *) let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = let type_pat ?(mode=mode) ?(env=env) = type_pat ~constrs ~labels ~no_existentials ~mode ~env in let loc = sp.ppat_loc in match sp.ppat_desc with Ppat_any -> rp { pat_desc = Tpat_any; pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_var name -> let id = enter_variable loc name expected_ty in rp { pat_desc = Tpat_var (id, name); pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_unpack name -> let id = enter_variable loc name expected_ty ~is_module:true in rp { pat_desc = Tpat_var (id, name); pat_loc = sp.ppat_loc; pat_extra=[Tpat_unpack, loc]; pat_type = expected_ty; pat_env = !env } | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=lloc}, ({ptyp_desc=Ptyp_poly _} as sty)) -> (* explicitly polymorphic type *) let cty, force = Typetexp.transl_simple_type_delayed !env sty in let ty = cty.ctyp_type in unify_pat_types lloc !env ty expected_ty; pattern_force := force :: !pattern_force; begin match ty.desc with | Tpoly (body, tyl) -> begin_def (); let _, ty' = instance_poly ~keep_names:true false tyl body in end_def (); generalize ty'; let id = enter_variable lloc name ty' in rp { pat_desc = Tpat_var (id, name); pat_loc = lloc; pat_extra = [Tpat_constraint cty, loc]; pat_type = ty; pat_env = !env } | _ -> assert false end | Ppat_alias(sq, name) -> let q = type_pat sq expected_ty in begin_def (); let ty_var = build_as_type !env q in end_def (); generalize ty_var; let id = enter_variable ~is_as_variable:true loc name ty_var in rp { pat_desc = Tpat_alias(q, id, name); pat_loc = loc; pat_extra=[]; pat_type = q.pat_type; pat_env = !env } | Ppat_constant cst -> unify_pat_types loc !env (type_constant cst) expected_ty; rp { pat_desc = Tpat_constant cst; pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_tuple spl -> let spl_ann = List.map (fun p -> (p,newvar ())) spl in let ty = newty (Ttuple(List.map snd spl_ann)) in unify_pat_types loc !env ty expected_ty; let pl = List.map (fun (p,t) -> type_pat p t) spl_ann in rp { pat_desc = Tpat_tuple pl; pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_construct(lid, sarg, explicit_arity) -> let (constr_path, constr) = match lid.txt, constrs with Longident.Lident s, Some constrs when Hashtbl.mem constrs s -> Hashtbl.find constrs s | _ -> Typetexp.find_constructor !env loc lid.txt in Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr; if no_existentials && constr.cstr_existentials <> [] then raise (Error (loc, Unexpected_existential)); (* if constructor is gadt, we must verify that the expected type has the correct head *) if constr.cstr_generalized then unify_head_only loc !env expected_ty constr; let sargs = match sarg with None -> [] | Some {ppat_desc = Ppat_tuple spl} when explicit_arity -> spl | Some {ppat_desc = Ppat_tuple spl} when constr.cstr_arity > 1 -> spl | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 -> if constr.cstr_arity = 0 then Location.prerr_warning sp.ppat_loc Warnings.Wildcard_arg_to_constant_constr; replicate_list sp constr.cstr_arity | Some sp -> [sp] in if List.length sargs <> constr.cstr_arity then raise(Error(loc, Constructor_arity_mismatch(lid.txt, constr.cstr_arity, List.length sargs))); let (ty_args, ty_res) = instance_constructor ~in_pattern:(env, get_newtype_level ()) constr in if constr.cstr_generalized && mode = Normal then unify_pat_types_gadt loc env ty_res expected_ty else unify_pat_types loc !env ty_res expected_ty; let args = List.map2 (fun p t -> type_pat p t) sargs ty_args in rp { pat_desc=Tpat_construct(constr_path, lid, constr, args,explicit_arity); pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_variant(l, sarg) -> let arg = may_map (fun p -> type_pat p (newvar())) sarg in let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in let row = { row_fields = [l, Reither(arg = None, arg_type, true, ref None)]; row_bound = (); row_closed = false; row_more = newvar (); row_fixed = false; row_name = None } in unify_pat_types loc !env (newty (Tvariant row)) expected_ty; rp { pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()}); pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_record(lid_sp_list, closed) -> let type_label_pat (label_path, label_lid, label, sarg) = begin_def (); let (vars, ty_arg, ty_res) = instance_label false label in if vars = [] then end_def (); begin try unify_pat_types loc !env ty_res expected_ty with Unify trace -> raise(Error(loc, Label_mismatch(lid_of_label label, trace))) end; let arg = type_pat sarg ty_arg in if vars <> [] then begin end_def (); generalize ty_arg; List.iter generalize vars; let instantiated tv = let tv = expand_head !env tv in not (is_Tvar tv) || tv.level <> generic_level in if List.exists instantiated vars then raise (Error(loc, Polymorphic_label (lid_of_label label))) end; (label_path, label_lid, label, arg) in let lbl_pat_list = type_label_a_list ?labels !env type_label_pat lid_sp_list in check_recordpat_labels loc lbl_pat_list closed; rp { pat_desc = Tpat_record (lbl_pat_list, closed); pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_array spl -> let ty_elt = newvar() in unify_pat_types loc !env (instance_def (Predef.type_array ty_elt)) expected_ty; let spl_ann = List.map (fun p -> (p,newvar())) spl in let pl = List.map (fun (p,t) -> type_pat p ty_elt) spl_ann in rp { pat_desc = Tpat_array pl; pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_or(sp1, sp2) -> let initial_pattern_variables = !pattern_variables in let p1 = type_pat ~mode:Inside_or sp1 expected_ty in let p1_variables = !pattern_variables in pattern_variables := initial_pattern_variables; let p2 = type_pat ~mode:Inside_or sp2 expected_ty in let p2_variables = !pattern_variables in let alpha_env = enter_orpat_variables loc !env p1_variables p2_variables in pattern_variables := p1_variables; rp { pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None); pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_lazy sp1 -> let nv = newvar () in unify_pat_types loc !env (instance_def (Predef.type_lazy_t nv)) expected_ty; let p1 = type_pat sp1 nv in rp { pat_desc = Tpat_lazy p1; pat_loc = loc; pat_extra=[]; pat_type = expected_ty; pat_env = !env } | Ppat_constraint(sp, sty) -> (* Separate when not already separated by !principal *) let separate = true in if separate then begin_def(); let cty, force = Typetexp.transl_simple_type_delayed !env sty in let ty = cty.ctyp_type in let ty, expected_ty' = if separate then begin end_def(); generalize_structure ty; instance !env ty, instance !env ty end else ty, ty in unify_pat_types loc !env ty expected_ty; let p = type_pat sp expected_ty' in (*Format.printf "%a@.%a@." Printtyp.raw_type_expr ty Printtyp.raw_type_expr p.pat_type;*) pattern_force := force :: !pattern_force; if separate then match p.pat_desc with Tpat_var (id,s) -> {p with pat_type = ty; pat_desc = Tpat_alias ({p with pat_desc = Tpat_any}, id,s); pat_extra = [Tpat_constraint cty, loc]; } | _ -> {p with pat_type = ty; pat_extra = (Tpat_constraint cty,loc) :: p.pat_extra} else p | Ppat_type lid -> let (path, p,ty) = build_or_pat !env loc lid.txt in unify_pat_types loc !env ty expected_ty; { p with pat_extra = (Tpat_type (path, lid), loc) :: p.pat_extra } let type_pat ?(allow_existentials=false) ?constrs ?labels ?(lev=get_current_level()) env sp expected_ty = newtype_level := Some lev; try let r = type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels ~mode:Normal ~env sp expected_ty in iter_pattern (fun p -> p.pat_env <- !env) r; newtype_level := None; r with e -> newtype_level := None; raise e (* this function is passed to Partial.parmatch to type check gadt nonexhaustiveness *) let partial_pred ~lev env expected_ty constrs labels p = let snap = snapshot () in try reset_pattern None true; let typed_p = type_pat ~allow_existentials:true ~lev ~constrs ~labels (ref env) p expected_ty in backtrack snap; (* types are invalidated but we don't need them here *) Some typed_p with _ -> backtrack snap; None let rec iter3 f lst1 lst2 lst3 = match lst1,lst2,lst3 with | x1::xs1,x2::xs2,x3::xs3 -> f x1 x2 x3; iter3 f xs1 xs2 xs3 | [],[],[] -> () | _ -> assert false let add_pattern_variables ?check ?check_as env = let pv = get_ref pattern_variables in (List.fold_right (fun (id, ty, name, loc, as_var) env -> let check = if as_var then check_as else check in let e1 = Env.add_value ?check id {val_type = ty; val_kind = Val_reg; Types.val_loc = loc} env in Env.add_annot id (Annot.Iref_internal loc) e1) pv env, get_ref module_variables) let type_pattern ~lev env spat scope expected_ty = reset_pattern scope true; let new_env = ref env in let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in let new_env, unpacks = add_pattern_variables !new_env ~check:(fun s -> Warnings.Unused_var_strict s) ~check_as:(fun s -> Warnings.Unused_var s) in (pat, new_env, get_ref pattern_force, unpacks) let type_pattern_list env spatl scope expected_tys allow = reset_pattern scope allow; let new_env = ref env in let patl = List.map2 (type_pat new_env) spatl expected_tys in let new_env, unpacks = add_pattern_variables !new_env in (patl, new_env, get_ref pattern_force, unpacks) let type_class_arg_pattern cl_num val_env met_env l spat = reset_pattern None false; let nv = newvar () in let pat = type_pat (ref val_env) spat nv in if has_variants pat then begin Parmatch.pressure_variants val_env [pat]; iter_pattern finalize_variant pat end; List.iter (fun f -> f()) (get_ref pattern_force); if is_optional l then unify_pat val_env pat (type_option (newvar ())); let (pv, met_env) = List.fold_right (fun (id, ty, name, loc, as_var) (pv, env) -> let check s = if as_var then Warnings.Unused_var s else Warnings.Unused_var_strict s in let id' = Ident.create (Ident.name id) in ((id', name, id, ty)::pv, Env.add_value id' {val_type = ty; val_kind = Val_ivar (Immutable, cl_num); Types.val_loc = loc; } ~check env)) !pattern_variables ([], met_env) in let val_env, _ = add_pattern_variables val_env in (pat, pv, val_env, met_env) let mkpat d = { ppat_desc = d; ppat_loc = Location.none } let type_self_pattern cl_num privty val_env met_env par_env spat = let spat = mkpat (Ppat_alias (mkpat(Ppat_alias (spat, mknoloc "selfpat-*")), mknoloc ("selfpat-" ^ cl_num))) in reset_pattern None false; let nv = newvar() in let pat = type_pat (ref val_env) spat nv in List.iter (fun f -> f()) (get_ref pattern_force); let meths = ref Meths.empty in let vars = ref Vars.empty in let pv = !pattern_variables in pattern_variables := []; let (val_env, met_env, par_env) = List.fold_right (fun (id, ty, name, loc, as_var) (val_env, met_env, par_env) -> (Env.add_value id {val_type = ty; val_kind = Val_unbound; Types.val_loc = loc; } val_env, Env.add_value id {val_type = ty; val_kind = Val_self (meths, vars, cl_num, privty); Types.val_loc = loc; } ~check:(fun s -> if as_var then Warnings.Unused_var s else Warnings.Unused_var_strict s) met_env, Env.add_value id {val_type = ty; val_kind = Val_unbound; Types.val_loc = loc; } par_env)) pv (val_env, met_env, par_env) in (pat, meths, vars, val_env, met_env, par_env) let delayed_checks = ref [] let reset_delayed_checks () = delayed_checks := [] let add_delayed_check f = delayed_checks := f :: !delayed_checks let force_delayed_checks () = (* checks may change type levels *) let snap = Btype.snapshot () in List.iter (fun f -> f ()) (List.rev !delayed_checks); reset_delayed_checks (); Btype.backtrack snap let fst3 (x, _, _) = x let snd3 (_, x, _) = x (* Generalization criterion for expressions *) let rec is_nonexpansive exp = match exp.exp_desc with Texp_ident(_,_,_) -> true | Texp_constant _ -> true | Texp_let(rec_flag, pat_exp_list, body) -> List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list && is_nonexpansive body | Texp_function _ -> true | Texp_apply(e, (_,None,_)::el) -> is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd3 el) | Texp_tuple el -> List.for_all is_nonexpansive el | Texp_construct(_, _, _, el,_) -> List.for_all is_nonexpansive el | Texp_variant(_, arg) -> is_nonexpansive_opt arg | Texp_record(lbl_exp_list, opt_init_exp) -> List.for_all (fun (_, _, lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp) lbl_exp_list && is_nonexpansive_opt opt_init_exp | Texp_field(exp, _, lbl, _) -> is_nonexpansive exp | Texp_array [] -> true | Texp_ifthenelse(cond, ifso, ifnot) -> is_nonexpansive ifso && is_nonexpansive_opt ifnot | Texp_sequence (e1, e2) -> is_nonexpansive e2 (* PR#4354 *) | Texp_new (_, _, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 -> true (* Note: nonexpansive only means no _observable_ side effects *) | Texp_lazy e -> is_nonexpansive e | Texp_object ({cstr_fields=fields; cstr_type = { cty_vars=vars}}, _) -> let count = ref 0 in List.for_all (fun field -> match field.cf_desc with Tcf_meth _ -> true | Tcf_val (_,_, _, _, Tcfk_concrete e,_) -> incr count; is_nonexpansive e | Tcf_val (_,_, _, _, Tcfk_virtual _,_) -> incr count; true | Tcf_init e -> is_nonexpansive e | Tcf_constr _ -> true | Tcf_inher _ -> false) fields && Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable) vars true && !count = 0 | Texp_letmodule (_, _, mexp, e) -> is_nonexpansive_mod mexp && is_nonexpansive e | Texp_pack mexp -> is_nonexpansive_mod mexp | _ -> false and is_nonexpansive_mod mexp = match mexp.mod_desc with | Tmod_ident _ -> true | Tmod_functor _ -> true | Tmod_unpack (e, _) -> is_nonexpansive e | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m | Tmod_structure str -> List.for_all (fun item -> match item.str_desc with | Tstr_eval _ | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ | Tstr_open _ | Tstr_class_type _ | Tstr_exn_rebind _ -> true | Tstr_value (_, pat_exp_list) -> List.for_all (fun (_, exp) -> is_nonexpansive exp) pat_exp_list | Tstr_module (_, _, m) | Tstr_include (m, _) -> is_nonexpansive_mod m | Tstr_recmodule id_mod_list -> List.for_all (fun (_, _, _, m) -> is_nonexpansive_mod m) id_mod_list | Tstr_exception _ -> false (* true would be unsound *) | Tstr_class _ -> false (* could be more precise *) ) str.str_items | Tmod_apply _ -> false and is_nonexpansive_opt = function None -> true | Some e -> is_nonexpansive e (* Typing format strings for printing or reading. These format strings are used by functions in modules Printf, Format, and Scanf. (Handling of * modifiers contributed by Thorsten Ohl.) *) external string_to_format : string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" external format_to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity" let type_format loc fmt = let ty_arrow gty ty = newty (Tarrow ("", instance_def gty, ty, Cok)) in let bad_conversion fmt i c = raise (Error (loc, Bad_conversion (fmt, i, c))) in let incomplete_format fmt = raise (Error (loc, Incomplete_format fmt)) in let rec type_in_format fmt = let len = String.length fmt in let ty_input = newvar () and ty_result = newvar () and ty_aresult = newvar () and ty_uresult = newvar () in let meta = ref 0 in let rec scan_format i = if i >= len then if !meta = 0 then ty_uresult, ty_result else incomplete_format fmt else match fmt.[i] with | '%' -> scan_opts i (i + 1) | _ -> scan_format (i + 1) and scan_opts i j = if j >= len then incomplete_format fmt else match fmt.[j] with | '_' -> scan_rest true i (j + 1) | _ -> scan_rest false i j and scan_rest skip i j = let rec scan_flags i j = if j >= len then incomplete_format fmt else match fmt.[j] with | '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j + 1) | _ -> scan_width i j and scan_width i j = scan_width_or_prec_value scan_precision i j and scan_decimal_string scan i j = if j >= len then incomplete_format fmt else match fmt.[j] with | '0' .. '9' -> scan_decimal_string scan i (j + 1) | _ -> scan i j and scan_width_or_prec_value scan i j = if j >= len then incomplete_format fmt else match fmt.[j] with | '*' -> let ty_uresult, ty_result = scan i (j + 1) in ty_uresult, ty_arrow Predef.type_int ty_result | '-' | '+' -> scan_decimal_string scan i (j + 1) | _ -> scan_decimal_string scan i j and scan_precision i j = if j >= len then incomplete_format fmt else match fmt.[j] with | '.' -> scan_width_or_prec_value scan_conversion i (j + 1) | _ -> scan_conversion i j and scan_indication j = if j >= len then j - 1 else match fmt.[j] with | '@' -> let k = j + 1 in if k >= len then j - 1 else begin match fmt.[k] with | '%' -> let k = k + 1 in if k >= len then j - 1 else begin match fmt.[k] with | '%' | '@' -> k | _c -> j - 1 end | _c -> k end | _c -> j - 1 and scan_range j = let rec scan_closing j = if j >= len then incomplete_format fmt else match fmt.[j] with | ']' -> j | '%' -> let j = j + 1 in if j >= len then incomplete_format fmt else begin match fmt.[j] with | '%' | '@' -> scan_closing (j + 1) | c -> bad_conversion fmt j c end | c -> scan_closing (j + 1) in let scan_first_pos j = if j >= len then incomplete_format fmt else match fmt.[j] with | ']' -> scan_closing (j + 1) | c -> scan_closing j in let rec scan_first_neg j = if j >= len then incomplete_format fmt else match fmt.[j] with | '^' -> scan_first_pos (j + 1) | c -> scan_first_pos j in scan_first_neg j and conversion j ty_arg = let ty_uresult, ty_result = scan_format (j + 1) in ty_uresult, if skip then ty_result else ty_arrow ty_arg ty_result and conversion_a j ty_e ty_arg = let ty_uresult, ty_result = conversion j ty_arg in let ty_a = ty_arrow ty_input (ty_arrow ty_e ty_aresult) in ty_uresult, ty_arrow ty_a ty_result and conversion_r j ty_e ty_arg = let ty_uresult, ty_result = conversion j ty_arg in let ty_r = ty_arrow ty_input ty_e in ty_arrow ty_r ty_uresult, ty_result and scan_conversion i j = if j >= len then incomplete_format fmt else match fmt.[j] with | '%' | '@' | '!' | ',' -> scan_format (j + 1) | 's' | 'S' -> let j = scan_indication (j + 1) in conversion j Predef.type_string | '[' -> let j = scan_range (j + 1) in let j = scan_indication (j + 1) in conversion j Predef.type_string | 'c' | 'C' -> conversion j Predef.type_char | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' -> conversion j Predef.type_int | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float | 'B' | 'b' -> conversion j Predef.type_bool | 'a' | 'r' as conv -> let conversion = if conv = 'a' then conversion_a else conversion_r in let ty_e = newvar () in let j = j + 1 in if j >= len then conversion (j - 1) ty_e ty_e else begin match fmt.[j] with (* | 'a' | 'A' -> conversion j ty_e (Predef.type_array ty_e) | 'l' | 'L' -> conversion j ty_e (Predef.type_list ty_e) | 'o' | 'O' -> conversion j ty_e (Predef.type_option ty_e)*) | _ -> conversion (j - 1) ty_e ty_e end (* | 'r' -> let ty_e = newvar () in let j = j + 1 in if j >= len then conversion_r (j - 1) ty_e ty_e else begin match fmt.[j] with | 'a' | 'A' -> conversion_r j ty_e (Pref.type_array ty_e) | 'l' | 'L' -> conversion_r j ty_e (Pref.type_list ty_e) | 'o' | 'O' -> conversion_r j ty_e (Pref.type_option ty_e) | _ -> conversion_r (j - 1) ty_e ty_e end *) | 't' -> conversion j (ty_arrow ty_input ty_aresult) | 'l' | 'n' | 'L' as c -> let j = j + 1 in if j >= len then conversion (j - 1) Predef.type_int else begin match fmt.[j] with | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> let ty_arg = match c with | 'l' -> Predef.type_int32 | 'n' -> Predef.type_nativeint | _ -> Predef.type_int64 in conversion j ty_arg | c -> conversion (j - 1) Predef.type_int end | '{' | '(' as c -> let j = j + 1 in if j >= len then incomplete_format fmt else let sj = Printf.CamlinternalPr.Tformat.sub_format (fun fmt -> incomplete_format (format_to_string fmt)) (fun fmt -> bad_conversion (format_to_string fmt)) c (string_to_format fmt) j in let sfmt = String.sub fmt j (sj - 2 - j) in let ty_sfmt = type_in_format sfmt in begin match c with | '{' -> conversion (sj - 1) ty_sfmt | _ -> incr meta; conversion (j - 1) ty_sfmt end | ')' when !meta > 0 -> decr meta; scan_format (j + 1) | c -> bad_conversion fmt i c in scan_flags i j in let ty_ureader, ty_args = scan_format 0 in newty (Tconstr (Predef.path_format6, [ ty_args; ty_input; ty_aresult; ty_ureader; ty_uresult; ty_result; ], ref Mnil)) in type_in_format fmt (* Approximate the type of an expression, for better recursion *) let rec approx_type env sty = match sty.ptyp_desc with Ptyp_arrow (p, _, sty) -> let ty1 = if is_optional p then type_option (newvar ()) else newvar () in newty (Tarrow (p, ty1, approx_type env sty, Cok)) | Ptyp_tuple args -> newty (Ttuple (List.map (approx_type env) args)) | Ptyp_constr (lid, ctl) -> begin try let (path, decl) = Env.lookup_type lid.txt env in if List.length ctl <> decl.type_arity then raise Not_found; let tyl = List.map (approx_type env) ctl in newconstr path tyl with Not_found -> newvar () end | Ptyp_poly (_, sty) -> approx_type env sty | _ -> newvar () let rec type_approx env sexp = match sexp.pexp_desc with Pexp_let (_, _, e) -> type_approx env e | Pexp_function (p,_,(_,e)::_) when is_optional p -> newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok)) | Pexp_function (p,_,(_,e)::_) -> newty (Tarrow(p, newvar (), type_approx env e, Cok)) | Pexp_match (_, (_,e)::_) -> type_approx env e | Pexp_try (e, _) -> type_approx env e | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l)) | Pexp_ifthenelse (_,e,_) -> type_approx env e | Pexp_sequence (_,e) -> type_approx env e | Pexp_constraint (e, sty1, sty2) -> let approx_ty_opt = function | None -> newvar () | Some sty -> approx_type env sty in let ty = type_approx env e and ty1 = approx_ty_opt sty1 and ty2 = approx_ty_opt sty2 in begin try unify env ty ty1 with Unify trace -> raise(Error(sexp.pexp_loc, Expr_type_clash trace)) end; if sty2 = None then ty1 else ty2 | _ -> newvar () (* List labels in a function type, and whether return type is a variable *) let rec list_labels_aux env visited ls ty_fun = let ty = expand_head env ty_fun in if List.memq ty visited then List.rev ls, false else match ty.desc with Tarrow (l, _, ty_res, _) -> list_labels_aux env (ty::visited) (l::ls) ty_res | _ -> List.rev ls, is_Tvar ty let list_labels env ty = list_labels_aux env [] [] ty (* Check that all univars are safe in a type *) let check_univars env expans kind exp ty_expected vars = if expans && not (is_nonexpansive exp) then generalize_expansive env exp.exp_type; (* need to expand twice? cf. Ctype.unify2 *) let vars = List.map (expand_head env) vars in let vars = List.map (expand_head env) vars in let vars' = List.filter (fun t -> let t = repr t in generalize t; match t.desc with Tvar name when t.level = generic_level -> log_type t; t.desc <- Tunivar name; true | _ -> false) vars in if List.length vars = List.length vars' then () else let ty = newgenty (Tpoly(repr exp.exp_type, vars')) and ty_expected = repr ty_expected in raise (Error (exp.exp_loc, Less_general(kind, [ty, ty; ty_expected, ty_expected]))) (* Check that a type is not a function *) let check_application_result env statement exp = let loc = exp.exp_loc in match (expand_head env exp.exp_type).desc with | Tarrow _ -> Location.prerr_warning exp.exp_loc Warnings.Partial_application | Tvar _ -> () | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () | _ -> if statement then Location.prerr_warning loc Warnings.Statement_type (* Check that a type is generalizable at some level *) let generalizable level ty = let rec check ty = let ty = repr ty in if ty.level < lowest_level then () else if ty.level <= level then raise Exit else (mark_type_node ty; iter_type_expr check ty) in try check ty; unmark_type ty; true with Exit -> unmark_type ty; false (* Hack to allow coercion of self. Will clean-up later. *) let self_coercion = ref ([] : (Path.t * Location.t list ref) list) (* Helpers for packaged modules. *) let create_package_type loc env (p, l) = let s = !Typetexp.transl_modtype_longident loc env p in let fields = List.map (fun (name, ct) -> name, Typetexp.transl_simple_type env false ct) l in let ty = newty (Tpackage (s, List.map fst l, List.map (fun (_, cty) -> cty.ctyp_type) fields)) in (s, fields, ty) let wrap_unpacks sexp unpacks = List.fold_left (fun sexp (name, loc) -> {pexp_loc = sexp.pexp_loc; pexp_desc = Pexp_letmodule ( name, {pmod_loc = loc; pmod_desc = Pmod_unpack {pexp_desc=Pexp_ident(mkloc (Longident.Lident name.txt) name.loc); pexp_loc=name.loc}}, sexp)}) sexp unpacks (* Helpers for type_cases *) let iter_ppat f p = match p.ppat_desc with | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_type _ | Ppat_unpack _ -> () | Ppat_array pats -> List.iter f pats | Ppat_or (p1,p2) -> f p1; f p2 | Ppat_variant (_, arg) | Ppat_construct (_, arg, _) -> may f arg | Ppat_tuple lst -> List.iter f lst | Ppat_alias (p,_) | Ppat_constraint (p,_) | Ppat_lazy p -> f p | Ppat_record (args, flag) -> List.iter (fun (_,p) -> f p) args let contains_polymorphic_variant p = let rec loop p = match p.ppat_desc with Ppat_variant _ | Ppat_type _ -> raise Exit | _ -> iter_ppat loop p in try loop p; false with Exit -> true let contains_gadt env p = let rec loop p = match p.ppat_desc with Ppat_construct (lid, _, _) -> begin try let (_path, cstr) = Env.lookup_constructor lid.txt env in if cstr.cstr_generalized then raise Exit with Not_found -> () end; iter_ppat loop p | _ -> iter_ppat loop p in try loop p; false with Exit -> true let dummy_expr = {pexp_desc = Pexp_tuple []; pexp_loc = Location.none} (* Duplicate types of values in the environment *) (* XXX Should we do something about global type variables too? *) let duplicate_ident_types loc caselist env = let caselist = List.filter (fun (pat, _) -> contains_gadt env pat) caselist in let idents = all_idents (List.map snd caselist) in List.fold_left (fun env s -> try (* XXX This will mark the value as being used; I don't think this is what we want *) let (path, desc) = Env.lookup_value (Longident.Lident s) env in match path with Path.Pident id -> let desc = {desc with val_type = correct_levels desc.val_type} in Env.add_value id desc env | _ -> env with Not_found -> env) env idents (* Typing of expressions *) let unify_exp env exp expected_ty = (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type Printtyp.raw_type_expr expected_ty; *) unify_exp_types exp.exp_loc env exp.exp_type expected_ty let rec type_exp env sexp = (* We now delegate everything to type_expect *) type_expect env sexp (newvar ()) (* Typing of an expression with an expected type. This provide better error messages, and allows controlled propagation of return type information. In the principal case, [type_expected'] may be at generic_level. *) and type_expect ?in_function env sexp ty_expected = let loc = sexp.pexp_loc in (* Record the expression type before unifying it with the expected type *) let rue exp = Cmt_format.add_saved_type (Cmt_format.Partial_expression exp); Stypes.record (Stypes.Ti_expr exp); unify_exp env exp (instance env ty_expected); exp in match sexp.pexp_desc with | Pexp_ident lid -> begin if !Clflags.annotations then begin try let (path, annot) = Env.lookup_annot lid.txt env in Stypes.record (Stypes.An_ident ( loc, Path.name ~paren:Oprint.parenthesized_ident path, annot)) with _ -> () end; let (path, desc) = Typetexp.find_value env loc lid.txt in rue { exp_desc = begin match desc.val_kind with Val_ivar (_, cl_num) -> let (self_path, _) = Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env in Texp_instvar(self_path, path, match lid.txt with Longident.Lident txt -> { txt; loc = lid.loc } | _ -> assert false) | Val_self (_, _, cl_num, _) -> let (path, _) = Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env in Texp_ident(path, lid, desc) | Val_unbound -> raise(Error(loc, Masked_instance_variable lid.txt)) | _ -> Texp_ident(path, lid, desc) end; exp_loc = loc; exp_extra = []; exp_type = instance env desc.val_type; exp_env = env } end | Pexp_constant(Const_string s as cst) -> rue { exp_desc = Texp_constant cst; exp_loc = loc; exp_extra = []; exp_type = (* Terrible hack for format strings *) begin match (repr (expand_head env ty_expected)).desc with Tconstr(path, _, _) when Path.same path Predef.path_format6 -> type_format loc s | _ -> instance_def Predef.type_string end; exp_env = env } | Pexp_constant cst -> rue { exp_desc = Texp_constant cst; exp_loc = loc; exp_extra = []; exp_type = type_constant cst; exp_env = env } | Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat -> type_expect ?in_function env {sexp with pexp_desc = Pexp_match (sval, [spat, sbody])} ty_expected | Pexp_let(rec_flag, spat_sexp_list, sbody) -> let scp = match rec_flag with | Recursive -> Some (Annot.Idef loc) | Nonrecursive -> Some (Annot.Idef sbody.pexp_loc) | Default -> None in let (pat_exp_list, new_env, unpacks) = type_let env rec_flag spat_sexp_list scp true in let body = type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in re { exp_desc = Texp_let(rec_flag, pat_exp_list, body); exp_loc = loc; exp_extra = []; exp_type = body.exp_type; exp_env = env } | Pexp_function (l, Some default, [spat, sbody]) -> let default_loc = default.pexp_loc in let scases = [ {ppat_loc = default_loc; ppat_desc = Ppat_construct (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))), Some {ppat_loc = default_loc; ppat_desc = Ppat_var (mknoloc "*sth*")}, false)}, {pexp_loc = default_loc; pexp_desc = Pexp_ident(mknoloc (Longident.Lident "*sth*"))}; {ppat_loc = default_loc; ppat_desc = Ppat_construct (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))), None, false)}, default; ] in let smatch = { pexp_loc = loc; pexp_desc = Pexp_match ({ pexp_loc = loc; pexp_desc = Pexp_ident(mknoloc (Longident.Lident "*opt*")) }, scases ) } in let sfun = { pexp_loc = loc; pexp_desc = Pexp_function ( l, None, [ {ppat_loc = loc; ppat_desc = Ppat_var (mknoloc "*opt*")}, {pexp_loc = loc; pexp_desc = Pexp_let(Default, [spat, smatch], sbody); } ] ) } in type_expect ?in_function env sfun ty_expected | Pexp_function (l, _, caselist) -> let (loc_fun, ty_fun) = match in_function with Some p -> p | None -> (loc, instance env ty_expected) in let separate = !Clflags.principal || Env.has_local_constraints env in if separate then begin_def (); let (ty_arg, ty_res) = try filter_arrow env (instance env ty_expected) l with Unify _ -> match expand_head env ty_expected with {desc = Tarrow _} as ty -> raise(Error(loc, Abstract_wrong_label(l, ty))) | _ -> raise(Error(loc_fun, Too_many_arguments (in_function <> None, ty_fun))) in let ty_arg = if is_optional l then let tv = newvar() in begin try unify env ty_arg (type_option tv) with Unify _ -> assert false end; type_option tv else ty_arg in if separate then begin end_def (); generalize_structure ty_arg; generalize_structure ty_res end; let cases, partial = type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res true loc caselist in let not_function ty = let ls, tvar = list_labels env ty in ls = [] && not tvar in if is_optional l && not_function ty_res then Location.prerr_warning (fst (List.hd cases)).pat_loc Warnings.Unerasable_optional_argument; re { exp_desc = Texp_function(l,cases, partial); exp_loc = loc; exp_extra = []; exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok))); exp_env = env } | Pexp_apply(sfunct, sargs) -> begin_def (); (* one more level for non-returning functions *) if !Clflags.principal then begin_def (); let funct = type_exp env sfunct in if !Clflags.principal then begin end_def (); generalize_structure funct.exp_type end; let rec lower_args seen ty_fun = let ty = expand_head env ty_fun in if List.memq ty seen then () else match ty.desc with Tarrow (l, ty_arg, ty_fun, com) -> (try unify_var env (newvar()) ty_arg with Unify _ -> assert false); lower_args (ty::seen) ty_fun | _ -> () in let ty = instance env funct.exp_type in end_def (); lower_args [] ty; begin_def (); let (args, ty_res) = type_application env funct sargs in end_def (); unify_var env (newvar()) funct.exp_type; rue { exp_desc = Texp_apply(funct, args); exp_loc = loc; exp_extra = []; exp_type = ty_res; exp_env = env } | Pexp_match(sarg, caselist) -> begin_def (); let arg = type_exp env sarg in end_def (); if is_nonexpansive arg then generalize arg.exp_type else generalize_expansive env arg.exp_type; let cases, partial = type_cases env arg.exp_type ty_expected true loc caselist in re { exp_desc = Texp_match(arg, cases, partial); exp_loc = loc; exp_extra = []; exp_type = instance env ty_expected; exp_env = env } | Pexp_try(sbody, caselist) -> let body = type_expect env sbody ty_expected in let cases, _ = type_cases env Predef.type_exn ty_expected false loc caselist in re { exp_desc = Texp_try(body, cases); exp_loc = loc; exp_extra = []; exp_type = body.exp_type; exp_env = env } | Pexp_tuple sexpl -> let subtypes = List.map (fun _ -> newgenvar ()) sexpl in let to_unify = newgenty (Ttuple subtypes) in unify_exp_types loc env to_unify ty_expected; let expl = List.map2 (fun body ty -> type_expect env body ty) sexpl subtypes in re { exp_desc = Texp_tuple expl; exp_loc = loc; exp_extra = []; (* Keep sharing *) exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl)); exp_env = env } | Pexp_construct(lid, sarg, explicit_arity) -> type_construct env loc lid sarg explicit_arity ty_expected | Pexp_variant(l, sarg) -> (* Keep sharing *) let ty_expected0 = instance env ty_expected in begin try match sarg, expand_head env ty_expected, expand_head env ty_expected0 with | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} -> let row = row_repr row in begin match row_field_repr (List.assoc l row.row_fields), row_field_repr (List.assoc l row0.row_fields) with Rpresent (Some ty), Rpresent (Some ty0) -> let arg = type_argument env sarg ty ty0 in re { exp_desc = Texp_variant(l, Some arg); exp_loc = loc; exp_extra = []; exp_type = ty_expected0; exp_env = env } | _ -> raise Not_found end | _ -> raise Not_found with Not_found -> let arg = may_map (type_exp env) sarg in let arg_type = may_map (fun arg -> arg.exp_type) arg in rue { exp_desc = Texp_variant(l, arg); exp_loc = loc; exp_extra = []; exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type]; row_more = newvar (); row_bound = (); row_closed = false; row_fixed = false; row_name = None}); exp_env = env } end | Pexp_record(lid_sexp_list, opt_sexp) -> let lbl_exp_list = type_label_a_list env (type_label_exp true env loc ty_expected) lid_sexp_list in let rec check_duplicates seen_pos lid_sexp lbl_exp = match (lid_sexp, lbl_exp) with ((lid, _) :: rem1, (_, _, lbl, _) :: rem2) -> if List.mem lbl.lbl_pos seen_pos then raise(Error(loc, Label_multiply_defined lid.txt)) else check_duplicates (lbl.lbl_pos :: seen_pos) rem1 rem2 | (_, _) -> () in check_duplicates [] lid_sexp_list lbl_exp_list; let opt_exp = match opt_sexp, lbl_exp_list with None, _ -> None | Some sexp, (_, _, lbl, _) :: _ -> if !Clflags.principal then begin_def (); let ty_exp = newvar () in let unify_kept lbl = if List.for_all (fun (_, _, lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos) lbl_exp_list then begin let _, ty_arg1, ty_res1 = instance_label false lbl and _, ty_arg2, ty_res2 = instance_label false lbl in unify env ty_exp ty_res1; unify env (instance env ty_expected) ty_res2; unify env ty_arg1 ty_arg2 end in Array.iter unify_kept lbl.lbl_all; if !Clflags.principal then begin end_def (); generalize_structure ty_exp end; Some(type_expect env sexp ty_exp) | _ -> assert false in let num_fields = match lbl_exp_list with [] -> assert false | (_,_, lbl,_)::_ -> Array.length lbl.lbl_all in if opt_sexp = None && List.length lid_sexp_list <> num_fields then begin let present_indices = List.map (fun (_,_, lbl, _) -> lbl.lbl_pos) lbl_exp_list in let label_names = extract_label_names sexp env ty_expected in let rec missing_labels n = function [] -> [] | lbl :: rem -> if List.mem n present_indices then missing_labels (n + 1) rem else lbl :: missing_labels (n + 1) rem in let missing = missing_labels 0 label_names in raise(Error(loc, Label_missing missing)) end else if opt_sexp <> None && List.length lid_sexp_list = num_fields then Location.prerr_warning loc Warnings.Useless_record_with; re { exp_desc = Texp_record(lbl_exp_list, opt_exp); exp_loc = loc; exp_extra = []; exp_type = instance env ty_expected; exp_env = env } | Pexp_field(sarg, lid) -> let arg = type_exp env sarg in let (label_path,label) = Typetexp.find_label env loc lid.txt in let (_, ty_arg, ty_res) = instance_label false label in unify_exp env arg ty_res; rue { exp_desc = Texp_field(arg, label_path, lid, label); exp_loc = loc; exp_extra = []; exp_type = ty_arg; exp_env = env } | Pexp_setfield(srecord, lid, snewval) -> let record = type_exp env srecord in let (label_path, label) = Typetexp.find_label env loc lid.txt in let (label_path, label_loc, label, newval) = type_label_exp false env loc record.exp_type (label_path, lid, label, snewval) in if label.lbl_mut = Immutable then raise(Error(loc, Label_not_mutable lid.txt)); rue { exp_desc = Texp_setfield(record, label_path, label_loc, label, newval); exp_loc = loc; exp_extra = []; exp_type = instance_def Predef.type_unit; exp_env = env } | Pexp_array(sargl) -> let ty = newgenvar() in let to_unify = Predef.type_array ty in unify_exp_types loc env to_unify ty_expected; let argl = List.map (fun sarg -> type_expect env sarg ty) sargl in re { exp_desc = Texp_array argl; exp_loc = loc; exp_extra = []; exp_type = instance env ty_expected; exp_env = env } | Pexp_ifthenelse(scond, sifso, sifnot) -> let cond = type_expect env scond Predef.type_bool in begin match sifnot with None -> let ifso = type_expect env sifso Predef.type_unit in rue { exp_desc = Texp_ifthenelse(cond, ifso, None); exp_loc = loc; exp_extra = []; exp_type = ifso.exp_type; exp_env = env } | Some sifnot -> let ifso = type_expect env sifso ty_expected in let ifnot = type_expect env sifnot ty_expected in (* Keep sharing *) unify_exp env ifnot ifso.exp_type; re { exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); exp_loc = loc; exp_extra = []; exp_type = ifso.exp_type; exp_env = env } end | Pexp_sequence(sexp1, sexp2) -> let exp1 = type_statement env sexp1 in let exp2 = type_expect env sexp2 ty_expected in re { exp_desc = Texp_sequence(exp1, exp2); exp_loc = loc; exp_extra = []; exp_type = exp2.exp_type; exp_env = env } | Pexp_while(scond, sbody) -> let cond = type_expect env scond Predef.type_bool in let body = type_statement env sbody in rue { exp_desc = Texp_while(cond, body); exp_loc = loc; exp_extra = []; exp_type = instance_def Predef.type_unit; exp_env = env } | Pexp_for(param, slow, shigh, dir, sbody) -> let low = type_expect env slow Predef.type_int in let high = type_expect env shigh Predef.type_int in let (id, new_env) = Env.enter_value param.txt {val_type = instance_def Predef.type_int; val_kind = Val_reg; Types.val_loc = loc; } env ~check:(fun s -> Warnings.Unused_for_index s) in let body = type_statement new_env sbody in rue { exp_desc = Texp_for(id, param, low, high, dir, body); exp_loc = loc; exp_extra = []; exp_type = instance_def Predef.type_unit; exp_env = env } | Pexp_constraint(sarg, sty, sty') -> let separate = true (* always separate, 1% slowdown for lablgtk *) (* !Clflags.principal || Env.has_local_constraints env *) in let (arg, ty',cty,cty') = match (sty, sty') with (None, None) -> (* Case actually unused *) let arg = type_exp env sarg in (arg, arg.exp_type,None,None) | (Some sty, None) -> if separate then begin_def (); let cty = Typetexp.transl_simple_type env false sty in let ty = cty.ctyp_type in if separate then begin end_def (); generalize_structure ty; (type_argument env sarg ty (instance env ty), instance env ty, Some cty, None) end else (type_argument env sarg ty ty, ty, Some cty, None) | (None, Some sty') -> let (cty', force) = Typetexp.transl_simple_type_delayed env sty' in let ty' = cty'.ctyp_type in if separate then begin_def (); let arg = type_exp env sarg in let gen = if separate then begin end_def (); let tv = newvar () in let gen = generalizable tv.level arg.exp_type in unify_var env tv arg.exp_type; gen end else true in begin match arg.exp_desc, !self_coercion, (repr ty').desc with Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _, Tconstr(path',_,_) when Path.same path path' -> (* prerr_endline "self coercion"; *) r := loc :: !r; force () | _ when free_variables ~env arg.exp_type = [] && free_variables ~env ty' = [] -> if not gen && (* first try a single coercion *) let snap = snapshot () in let ty, b = enlarge_type env ty' in try force (); Ctype.unify env arg.exp_type ty; true with Unify _ -> backtrack snap; false then () else begin try let force' = subtype env arg.exp_type ty' in force (); force' (); if not gen then Location.prerr_warning loc (Warnings.Not_principal "this ground coercion"); with Subtype (tr1, tr2) -> (* prerr_endline "coercion failed"; *) raise(Error(loc, Not_subtype(tr1, tr2))) end; | _ -> let ty, b = enlarge_type env ty' in force (); begin try Ctype.unify env arg.exp_type ty with Unify trace -> raise(Error(sarg.pexp_loc, Coercion_failure(ty', full_expand env ty', trace, b))) end end; (arg, ty', None, Some cty') | (Some sty, Some sty') -> if separate then begin_def (); let (cty, force) = Typetexp.transl_simple_type_delayed env sty and (cty', force') = Typetexp.transl_simple_type_delayed env sty' in let ty = cty.ctyp_type in let ty' = cty'.ctyp_type in begin try let force'' = subtype env ty ty' in force (); force' (); force'' () with Subtype (tr1, tr2) -> raise(Error(loc, Not_subtype(tr1, tr2))) end; if separate then begin end_def (); generalize_structure ty; generalize_structure ty'; (type_argument env sarg ty (instance env ty), instance env ty', Some cty, Some cty') end else (type_argument env sarg ty ty, ty', Some cty, Some cty') in rue { exp_desc = arg.exp_desc; exp_loc = arg.exp_loc; exp_type = ty'; exp_env = env; exp_extra = (Texp_constraint (cty, cty'), loc) :: arg.exp_extra; } | Pexp_when(scond, sbody) -> let cond = type_expect env scond Predef.type_bool in let body = type_expect env sbody ty_expected in re { exp_desc = Texp_when(cond, body); exp_loc = loc; exp_extra = []; exp_type = body.exp_type; exp_env = env } | Pexp_send (e, met) -> if !Clflags.principal then begin_def (); let obj = type_exp env e in begin try let (meth, exp, typ) = match obj.exp_desc with Texp_ident(path, _, {val_kind = Val_self (meths, _, _, privty)}) -> let (id, typ) = filter_self_method env met Private meths privty in if is_Tvar (repr typ) then Location.prerr_warning loc (Warnings.Undeclared_virtual_method met); (Tmeth_val id, None, typ) | Texp_ident(path, lid, {val_kind = Val_anc (methods, cl_num)}) -> let method_id = begin try List.assoc met methods with Not_found -> raise(Error(e.pexp_loc, Undefined_inherited_method met)) end in begin match Env.lookup_value (Longident.Lident ("selfpat-" ^ cl_num)) env, Env.lookup_value (Longident.Lident ("self-" ^cl_num)) env with (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)), (path, _) -> let (_, typ) = filter_self_method env met Private meths privty in let method_type = newvar () in let (obj_ty, res_ty) = filter_arrow env method_type "" in unify env obj_ty desc.val_type; unify env res_ty (instance env typ); let exp = Texp_apply({exp_desc = Texp_ident(Path.Pident method_id, lid, {val_type = method_type; val_kind = Val_reg; Types.val_loc = Location.none}); exp_loc = loc; exp_extra = []; exp_type = method_type; exp_env = env}, ["", Some {exp_desc = Texp_ident(path, lid, desc); exp_loc = obj.exp_loc; exp_extra = []; exp_type = desc.val_type; exp_env = env}, Required]) in (Tmeth_name met, Some (re {exp_desc = exp; exp_loc = loc; exp_extra = []; exp_type = typ; exp_env = env}), typ) | _ -> assert false end | _ -> (Tmeth_name met, None, filter_method env met Public obj.exp_type) in if !Clflags.principal then begin end_def (); generalize_structure typ; end; let typ = match repr typ with {desc = Tpoly (ty, [])} -> instance env ty | {desc = Tpoly (ty, tl); level = l} -> if !Clflags.principal && l <> generic_level then Location.prerr_warning loc (Warnings.Not_principal "this use of a polymorphic method"); snd (instance_poly false tl ty) | {desc = Tvar _} as ty -> let ty' = newvar () in unify env (instance_def ty) (newty(Tpoly(ty',[]))); (* if not !Clflags.nolabels then Location.prerr_warning loc (Warnings.Unknown_method met); *) ty' | _ -> assert false in rue { exp_desc = Texp_send(obj, meth, exp); exp_loc = loc; exp_extra = []; exp_type = typ; exp_env = env } with Unify _ -> raise(Error(e.pexp_loc, Undefined_method (obj.exp_type, met))) end | Pexp_new cl -> let (cl_path, cl_decl) = Typetexp.find_class env loc cl.txt in begin match cl_decl.cty_new with None -> raise(Error(loc, Virtual_class cl.txt)) | Some ty -> rue { exp_desc = Texp_new (cl_path, cl, cl_decl); exp_loc = loc; exp_extra = []; exp_type = instance_def ty; exp_env = env } end | Pexp_setinstvar (lab, snewval) -> begin try let (path, desc) = Env.lookup_value (Longident.Lident lab.txt) env in match desc.val_kind with Val_ivar (Mutable, cl_num) -> let newval = type_expect env snewval (instance env desc.val_type) in let (path_self, _) = Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env in rue { exp_desc = Texp_setinstvar(path_self, path, lab, newval); exp_loc = loc; exp_extra = []; exp_type = instance_def Predef.type_unit; exp_env = env } | Val_ivar _ -> raise(Error(loc,Instance_variable_not_mutable(true,lab.txt))) | _ -> raise(Error(loc,Instance_variable_not_mutable(false,lab.txt))) with Not_found -> raise(Error(loc, Unbound_instance_variable lab.txt)) end | Pexp_override lst -> let _ = List.fold_right (fun (lab, _) l -> if List.exists (fun l -> l.txt = lab.txt) l then raise(Error(loc, Value_multiply_overridden lab.txt)); lab::l) lst [] in begin match try Env.lookup_value (Longident.Lident "selfpat-*") env, Env.lookup_value (Longident.Lident "self-*") env with Not_found -> raise(Error(loc, Outside_class)) with (_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}), (path_self, _) -> let type_override (lab, snewval) = begin try let (id, _, _, ty) = Vars.find lab.txt !vars in (Path.Pident id, lab, type_expect env snewval (instance env ty)) with Not_found -> raise(Error(loc, Unbound_instance_variable lab.txt)) end in let modifs = List.map type_override lst in rue { exp_desc = Texp_override(path_self, modifs); exp_loc = loc; exp_extra = []; exp_type = self_ty; exp_env = env } | _ -> assert false end | Pexp_letmodule(name, smodl, sbody) -> let ty = newvar() in (* remember original level *) begin_def (); Ident.set_current_time ty.level; let context = Typetexp.narrow () in let modl = !type_module env smodl in let (id, new_env) = Env.enter_module name.txt modl.mod_type env in Ctype.init_def(Ident.current_time()); Typetexp.widen context; let body = type_expect new_env sbody ty_expected in (* go back to original level *) end_def (); (* Unification of body.exp_type with the fresh variable ty fails if and only if the prefix condition is violated, i.e. if generative types rooted at id show up in the type body.exp_type. Thus, this unification enforces the scoping condition on "let module". *) begin try Ctype.unify_var new_env ty body.exp_type with Unify _ -> raise(Error(loc, Scoping_let_module(name.txt, body.exp_type))) end; re { exp_desc = Texp_letmodule(id, name, modl, body); exp_loc = loc; exp_extra = []; exp_type = ty; exp_env = env } | Pexp_assert (e) -> let cond = type_expect env e Predef.type_bool in rue { exp_desc = Texp_assert (cond); exp_loc = loc; exp_extra = []; exp_type = instance_def Predef.type_unit; exp_env = env; } | Pexp_assertfalse -> re { exp_desc = Texp_assertfalse; exp_loc = loc; exp_extra = []; exp_type = instance env ty_expected; exp_env = env; } | Pexp_lazy e -> let ty = newgenvar () in let to_unify = Predef.type_lazy_t ty in unify_exp_types loc env to_unify ty_expected; let arg = type_expect env e ty in re { exp_desc = Texp_lazy arg; exp_loc = loc; exp_extra = []; exp_type = instance env ty_expected; exp_env = env; } | Pexp_object s -> let desc, sign, meths = !type_object env loc s in rue { exp_desc = Texp_object (desc, (*sign,*) meths); exp_loc = loc; exp_extra = []; exp_type = sign.cty_self; exp_env = env; } | Pexp_poly(sbody, sty) -> if !Clflags.principal then begin_def (); let ty, cty = match sty with None -> repr ty_expected, None | Some sty -> let cty = Typetexp.transl_simple_type env false sty in repr cty.ctyp_type, Some cty in if !Clflags.principal then begin end_def (); generalize_structure ty end; if sty <> None then unify_exp_types loc env (instance env ty) (instance env ty_expected); let exp = match (expand_head env ty).desc with Tpoly (ty', []) -> let exp = type_expect env sbody ty' in { exp with exp_type = instance env ty } | Tpoly (ty', tl) -> (* One more level to generalize locally *) begin_def (); if !Clflags.principal then begin_def (); let vars, ty'' = instance_poly true tl ty' in if !Clflags.principal then begin end_def (); generalize_structure ty'' end; let exp = type_expect env sbody ty'' in end_def (); check_univars env false "method" exp ty_expected vars; { exp with exp_type = instance env ty } | Tvar _ -> let exp = type_exp env sbody in let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in unify_exp env exp ty; exp | _ -> assert false in re { exp with exp_extra = (Texp_poly cty, loc) :: exp.exp_extra } | Pexp_newtype(name, sbody) -> let ty = newvar () in (* remember original level *) begin_def (); (* Create a fake abstract type declaration for name. *) let level = get_current_level () in let decl = { type_params = []; type_arity = 0; type_kind = Type_abstract; type_private = Public; type_manifest = None; type_variance = []; type_newtype_level = Some (level, level); type_loc = loc; } in Ident.set_current_time ty.level; let (id, new_env) = Env.enter_type name decl env in Ctype.init_def(Ident.current_time()); let body = type_exp new_env sbody in (* Replace every instance of this type constructor in the resulting type. *) let seen = Hashtbl.create 8 in let rec replace t = if Hashtbl.mem seen t.id then () else begin Hashtbl.add seen t.id (); match t.desc with | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty | _ -> Btype.iter_type_expr replace t end in let ety = Subst.type_expr Subst.identity body.exp_type in replace ety; (* back to original level *) end_def (); (* lower the levels of the result type *) (* unify_var env ty ety; *) (* non-expansive if the body is non-expansive, so we don't introduce any new extra node in the typed AST. *) rue { body with exp_loc = loc; exp_type = ety; exp_extra = (Texp_newtype name, loc) :: body.exp_extra } | Pexp_pack m -> let (p, nl, tl) = match Ctype.expand_head env (instance env ty_expected) with {desc = Tpackage (p, nl, tl)} -> if !Clflags.principal && (Ctype.expand_head env ty_expected).level < Btype.generic_level then Location.prerr_warning loc (Warnings.Not_principal "this module packing"); (p, nl, tl) | {desc = Tvar _} -> raise (Error (loc, Cannot_infer_signature)) | _ -> raise (Error (loc, Not_a_packed_module ty_expected)) in let (modl, tl') = !type_package env m p nl tl in rue { exp_desc = Texp_pack modl; exp_loc = loc; exp_extra = []; exp_type = newty (Tpackage (p, nl, tl')); exp_env = env } | Pexp_open (lid, e) -> let (path, newenv) = !type_open env sexp.pexp_loc lid in let exp = type_expect newenv e ty_expected in { exp with exp_extra = (Texp_open (path, lid, newenv), loc) :: exp.exp_extra; } and type_label_exp create env loc ty_expected (label_path, lid, label, sarg) = (* Here also ty_expected may be at generic_level *) begin_def (); let separate = !Clflags.principal || Env.has_local_constraints env in if separate then (begin_def (); begin_def ()); let (vars, ty_arg, ty_res) = instance_label true label in if separate then begin end_def (); (* Generalize label information *) generalize_structure ty_arg; generalize_structure ty_res end; begin try unify env (instance_def ty_res) (instance env ty_expected) with Unify trace -> raise (Error(lid.loc, Label_mismatch(lid_of_label label, trace))) end; (* Instantiate so that we can generalize internal nodes *) let ty_arg = instance_def ty_arg in if separate then begin end_def (); (* Generalize information merged from ty_expected *) generalize_structure ty_arg end; if label.lbl_private = Private then if create then raise (Error(loc, Private_type ty_expected)) else raise (Error(lid.loc, Private_label(lid_of_label label, ty_expected))); let arg = let snap = if vars = [] then None else Some (Btype.snapshot ()) in let arg = type_argument env sarg ty_arg (instance env ty_arg) in end_def (); try check_univars env (vars <> []) "field value" arg label.lbl_arg vars; arg with exn when not (is_nonexpansive arg) -> try (* Try to retype without propagating ty_arg, cf PR#4862 *) may Btype.backtrack snap; begin_def (); let arg = type_exp env sarg in end_def (); generalize_expansive env arg.exp_type; unify_exp env arg ty_arg; check_univars env false "field value" arg label.lbl_arg vars; arg with Error (_, Less_general _) as e -> raise e | _ -> raise exn (* In case of failure return the first error *) in (label_path, lid, label, {arg with exp_type = instance env arg.exp_type}) and type_argument env sarg ty_expected' ty_expected = (* ty_expected' may be generic *) let no_labels ty = let ls, tvar = list_labels env ty in not tvar && List.for_all ((=) "") ls in let rec is_inferred sexp = match sexp.pexp_desc with Pexp_ident _ | Pexp_apply _ | Pexp_send _ | Pexp_field _ -> true | Pexp_open (_, e) -> is_inferred e | _ -> false in match expand_head env ty_expected' with {desc = Tarrow("",ty_arg,ty_res,_); level = lv} when is_inferred sarg -> (* apply optional arguments when expected type is "" *) (* we must be very careful about not breaking the semantics *) if !Clflags.principal then begin_def (); let texp = type_exp env sarg in if !Clflags.principal then begin end_def (); generalize_structure texp.exp_type end; let rec make_args args ty_fun = match (expand_head env ty_fun).desc with | Tarrow (l,ty_arg,ty_fun,_) when is_optional l -> make_args ((Some(option_none (instance env ty_arg) sarg.pexp_loc), Optional) :: args) ty_fun | Tarrow (l,_,ty_res',_) when l = "" || !Clflags.classic -> args, ty_fun, no_labels ty_res' | Tvar _ -> args, ty_fun, false | _ -> [], texp.exp_type, false in let args, ty_fun', simple_res = make_args [] texp.exp_type in let warn = !Clflags.principal && (lv <> generic_level || (repr ty_fun').level <> generic_level) and texp = {texp with exp_type = instance env texp.exp_type} and ty_fun = instance env ty_fun' in if not (simple_res || no_labels ty_res) then begin unify_exp env texp ty_expected; texp end else begin unify_exp env {texp with exp_type = ty_fun} ty_expected; if args = [] then texp else (* eta-expand to avoid side effects *) let var_pair name ty = let id = Ident.create name in {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[]; pat_loc = Location.none; pat_env = env}, {exp_type = ty; exp_loc = Location.none; exp_env = env; exp_extra = []; exp_desc = Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), {val_type = ty; val_kind = Val_reg; Types.val_loc = Location.none})} in let eta_pat, eta_var = var_pair "eta" ty_arg in let func texp = { texp with exp_type = ty_fun; exp_desc = Texp_function("", [eta_pat, {texp with exp_type = ty_res; exp_desc = Texp_apply (texp, (List.map (fun (label, exp) -> ("", label, exp)) args)@ ["", Some eta_var, Required])}], Total) } in if warn then Location.prerr_warning texp.exp_loc (Warnings.Without_principality "eliminated optional argument"); if is_nonexpansive texp then func texp else (* let-expand to have side effects *) let let_pat, let_var = var_pair "let" texp.exp_type in re { texp with exp_type = ty_fun; exp_desc = Texp_let (Nonrecursive, [let_pat, texp], func let_var) } end | _ -> let texp = type_expect env sarg ty_expected' in unify_exp env texp ty_expected; texp and type_application env funct sargs = (* funct.exp_type may be generic *) let result_type omitted ty_fun = List.fold_left (fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok))) ty_fun omitted in let has_label l ty_fun = let ls, tvar = list_labels env ty_fun in tvar || List.mem l ls in let ignored = ref [] in let rec type_unknown_args (args : (Asttypes.label * (unit -> Typedtree.expression) option * Typedtree.optional) list) omitted ty_fun = function [] -> (List.map (function l, None, x -> l, None, x | l, Some f, x -> l, Some (f ()), x) (List.rev args), instance env (result_type omitted ty_fun)) | (l1, sarg1) :: sargl -> let (ty1, ty2) = let ty_fun = expand_head env ty_fun in match ty_fun.desc with Tvar _ -> let t1 = newvar () and t2 = newvar () in let not_identity = function Texp_ident(_,_,{val_kind=Val_prim {Primitive.prim_name="%identity"}}) -> false | _ -> true in if ty_fun.level >= t1.level && not_identity funct.exp_desc then Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown)))); (t1, t2) | Tarrow (l,t1,t2,_) when l = l1 || !Clflags.classic && l1 = "" && not (is_optional l) -> (t1, t2) | td -> let ty_fun = match td with Tarrow _ -> newty td | _ -> ty_fun in let ty_res = result_type (omitted @ !ignored) ty_fun in match ty_res.desc with Tarrow _ -> if (!Clflags.classic || not (has_label l1 ty_fun)) then raise(Error(sarg1.pexp_loc, Apply_wrong_label(l1, ty_res))) else raise(Error(funct.exp_loc, Incoherent_label_order)) | _ -> raise(Error(funct.exp_loc, Apply_non_function (expand_head env funct.exp_type))) in let optional = if is_optional l1 then Optional else Required in let arg1 () = let arg1 = type_expect env sarg1 ty1 in if optional = Optional then unify_exp env arg1 (type_option(newvar())); arg1 in type_unknown_args ((l1, Some arg1, optional) :: args) omitted ty2 sargl in let ignore_labels = !Clflags.classic || begin let ls, tvar = list_labels env funct.exp_type in not tvar && let labels = List.filter (fun l -> not (is_optional l)) ls in List.length labels = List.length sargs && List.for_all (fun (l,_) -> l = "") sargs && List.exists (fun l -> l <> "") labels && (Location.prerr_warning funct.exp_loc Warnings.Labels_omitted; true) end in let warned = ref false in let rec type_args args omitted ty_fun ty_fun0 ty_old sargs more_sargs = match expand_head env ty_fun, expand_head env ty_fun0 with {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun', {desc=Tarrow (_, ty0, ty_fun0, _)} when (sargs <> [] || more_sargs <> []) && commu_repr com = Cok -> let may_warn loc w = if not !warned && !Clflags.principal && lv <> generic_level then begin warned := true; Location.prerr_warning loc w end in let name = label_name l and optional = if is_optional l then Optional else Required in let sargs, more_sargs, arg = if ignore_labels && not (is_optional l) then begin (* In classic mode, omitted = [] *) match sargs, more_sargs with (l', sarg0) :: _, _ -> raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_old))) | _, (l', sarg0) :: more_sargs -> if l <> l' && l' <> "" then raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_fun'))) else ([], more_sargs, Some (fun () -> type_argument env sarg0 ty ty0)) | _ -> assert false end else try let (l', sarg0, sargs, more_sargs) = try let (l', sarg0, sargs1, sargs2) = extract_label name sargs in if sargs1 <> [] then may_warn sarg0.pexp_loc (Warnings.Not_principal "commuting this argument"); (l', sarg0, sargs1 @ sargs2, more_sargs) with Not_found -> let (l', sarg0, sargs1, sargs2) = extract_label name more_sargs in if sargs1 <> [] || sargs <> [] then may_warn sarg0.pexp_loc (Warnings.Not_principal "commuting this argument"); (l', sarg0, sargs @ sargs1, sargs2) in sargs, more_sargs, if optional = Required || is_optional l' then Some (fun () -> type_argument env sarg0 ty ty0) else begin may_warn sarg0.pexp_loc (Warnings.Not_principal "using an optional argument here"); Some (fun () -> option_some (type_argument env sarg0 (extract_option_type env ty) (extract_option_type env ty0))) end with Not_found -> sargs, more_sargs, if optional = Optional && (List.mem_assoc "" sargs || List.mem_assoc "" more_sargs) then begin may_warn funct.exp_loc (Warnings.Without_principality "eliminated optional argument"); ignored := (l,ty,lv) :: !ignored; Some (fun () -> option_none (instance env ty) Location.none) end else begin may_warn funct.exp_loc (Warnings.Without_principality "commuted an argument"); None end in let omitted = if arg = None then (l,ty,lv) :: omitted else omitted in let ty_old = if sargs = [] then ty_fun else ty_old in type_args ((l,arg,optional)::args) omitted ty_fun ty_fun0 ty_old sargs more_sargs | _ -> match sargs with (l, sarg0) :: _ when ignore_labels -> raise(Error(sarg0.pexp_loc, Apply_wrong_label(l, ty_old))) | _ -> type_unknown_args args omitted ty_fun0 (sargs @ more_sargs) in match funct.exp_desc, sargs with (* Special case for ignore: avoid discarding warning *) Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}), ["", sarg] -> let ty_arg, ty_res = filter_arrow env (instance env funct.exp_type) "" in let exp = type_expect env sarg ty_arg in begin match (expand_head env exp.exp_type).desc with | Tarrow _ -> Location.prerr_warning exp.exp_loc Warnings.Partial_application | Tvar _ -> add_delayed_check (fun () -> check_application_result env false exp) | _ -> () end; (["", Some exp, Required], ty_res) | _ -> let ty = funct.exp_type in if ignore_labels then type_args [] [] ty (instance env ty) ty [] sargs else type_args [] [] ty (instance env ty) ty sargs [] and type_construct env loc lid sarg explicit_arity ty_expected = let (path,constr) = Typetexp.find_constructor env loc lid.txt in Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr; let sargs = match sarg with None -> [] | Some {pexp_desc = Pexp_tuple sel} when explicit_arity -> sel | Some {pexp_desc = Pexp_tuple sel} when constr.cstr_arity > 1 -> sel | Some se -> [se] in if List.length sargs <> constr.cstr_arity then raise(Error(loc, Constructor_arity_mismatch (lid.txt, constr.cstr_arity, List.length sargs))); let separate = !Clflags.principal || Env.has_local_constraints env in if separate then (begin_def (); begin_def ()); let (ty_args, ty_res) = instance_constructor constr in let texp = re { exp_desc = Texp_construct(path, lid, constr, [],explicit_arity); exp_loc = loc; exp_extra = []; exp_type = ty_res; exp_env = env } in if separate then begin end_def (); generalize_structure ty_res; unify_exp env {texp with exp_type = instance_def ty_res} (instance env ty_expected); end_def (); List.iter generalize_structure ty_args; generalize_structure ty_res; end; let ty_args0, ty_res = match instance_list env (ty_res :: ty_args) with t :: tl -> tl, t | _ -> assert false in let texp = {texp with exp_type = ty_res} in if not separate then unify_exp env texp (instance env ty_expected); let args = List.map2 (fun e (t,t0) -> type_argument env e t t0) sargs (List.combine ty_args ty_args0) in if constr.cstr_private = Private then raise(Error(loc, Private_type ty_res)); { texp with exp_desc = Texp_construct(path, lid, constr, args, explicit_arity) } (* Typing of statements (expressions whose values are discarded) *) and type_statement env sexp = let loc = sexp.pexp_loc in begin_def(); let exp = type_exp env sexp in end_def(); if !Clflags.strict_sequence then let expected_ty = instance_def Predef.type_unit in unify_exp env exp expected_ty; exp else let ty = expand_head env exp.exp_type and tv = newvar() in begin match ty.desc with | Tarrow _ -> Location.prerr_warning loc Warnings.Partial_application | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () | Tvar _ when ty.level > tv.level -> Location.prerr_warning loc Warnings.Nonreturning_statement | Tvar _ -> add_delayed_check (fun () -> check_application_result env true exp) | _ -> Location.prerr_warning loc Warnings.Statement_type end; unify_var env tv ty; exp (* Typing of match cases *) and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist = (* ty_arg is _fully_ generalized *) let dont_propagate, has_gadts = let patterns = List.map fst caselist in List.exists contains_polymorphic_variant patterns, List.exists (contains_gadt env) patterns in (* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *) let ty_arg, ty_res, env = if has_gadts && not !Clflags.principal then correct_levels ty_arg, correct_levels ty_res, duplicate_ident_types loc caselist env else ty_arg, ty_res, env in let lev, env = if has_gadts then begin (* raise level for existentials *) begin_def (); Ident.set_current_time (get_current_level ()); let lev = Ident.current_time () in Ctype.init_def (lev+1000); (* up to 1000 existentials *) (lev, Env.add_gadt_instance_level lev env) end else (get_current_level (), env) in (* if has_gadts then Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *) begin_def (); (* propagation of the argument *) let ty_arg' = newvar () in let pattern_force = ref [] in (* Format.printf "@[%i %i@ %a@]@." lev (get_current_level()) Printtyp.raw_type_expr ty_arg; *) let pat_env_list = List.map (fun (spat, sexp) -> let loc = sexp.pexp_loc in if !Clflags.principal then begin_def (); (* propagation of pattern *) let scope = Some (Annot.Idef loc) in let (pat, ext_env, force, unpacks) = let partial = if !Clflags.principal then Some false else None in let ty_arg = if dont_propagate then newvar () else instance ?partial env ty_arg in type_pattern ~lev env spat scope ty_arg in pattern_force := force @ !pattern_force; let pat = if !Clflags.principal then begin end_def (); iter_pattern (fun {pat_type=t} -> generalize_structure t) pat; { pat with pat_type = instance env pat.pat_type } end else pat in unify_pat env pat ty_arg'; (pat, (ext_env, unpacks))) caselist in (* Check for polymorphic variants to close *) let patl = List.map fst pat_env_list in if List.exists has_variants patl then begin Parmatch.pressure_variants env patl; List.iter (iter_pattern finalize_variant) patl end; (* `Contaminating' unifications start here *) List.iter (fun f -> f()) !pattern_force; (* Post-processing and generalization *) let patl = List.map fst pat_env_list in List.iter (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar()))) patl; List.iter (fun pat -> unify_pat env pat (instance env ty_arg)) patl; end_def (); List.iter (iter_pattern (fun {pat_type=t} -> generalize t)) patl; (* type bodies *) let in_function = if List.length caselist = 1 then in_function else None in let cases = List.map2 (fun (pat, (ext_env, unpacks)) (spat, sexp) -> let sexp = wrap_unpacks sexp unpacks in let ty_res' = if !Clflags.principal then begin begin_def (); let ty = instance ~partial:true env ty_res in end_def (); generalize_structure ty; ty end else if contains_gadt env spat then correct_levels ty_res else ty_res in (* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level()) Printtyp.raw_type_expr ty_res'; *) let exp = type_expect ?in_function ext_env sexp ty_res' in (pat, {exp with exp_type = instance env ty_res'})) pat_env_list caselist in if !Clflags.principal || has_gadts then begin let ty_res' = instance env ty_res in List.iter (fun (_,exp) -> unify_exp env exp ty_res') cases end; let partial = if partial_flag then Parmatch.check_partial_gadt (partial_pred ~lev env ty_arg) loc cases else Partial in add_delayed_check (fun () -> Parmatch.check_unused env cases); if has_gadts then begin end_def (); (* Ensure that existential types do not escape *) unify_exp_types loc env (instance env ty_res) (newvar ()) ; end; cases, partial (* Typing of let bindings *) and type_let ?(check = fun s -> Warnings.Unused_var s) ?(check_strict = fun s -> Warnings.Unused_var_strict s) env rec_flag spat_sexp_list scope allow = begin_def(); if !Clflags.principal then begin_def (); let is_fake_let = match spat_sexp_list with | [_, {pexp_desc=Pexp_match( {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}] -> true (* the fake let-declaration introduced by fun ?(x = e) -> ... *) | _ -> false in let check = if is_fake_let then check_strict else check in let spatl = List.map (fun (spat, sexp) -> match spat.ppat_desc, sexp.pexp_desc with (Ppat_any | Ppat_constraint _), _ -> spat | _, Pexp_constraint (_, _, Some sty) | _, Pexp_constraint (_, Some sty, None) when !Clflags.principal -> (* propagate type annotation to pattern, to allow it to be generalized in -principal mode *) {ppat_desc = Ppat_constraint (spat, sty); ppat_loc = {spat.ppat_loc with Location.loc_ghost=true}} | _ -> spat) spat_sexp_list in let nvs = List.map (fun _ -> newvar ()) spatl in let (pat_list, new_env, force, unpacks) = type_pattern_list env spatl scope nvs allow in let is_recursive = (rec_flag = Recursive) in (* If recursive, first unify with an approximation of the expression *) if is_recursive then List.iter2 (fun pat (_, sexp) -> let pat = match pat.pat_type.desc with | Tpoly (ty, tl) -> {pat with pat_type = snd (instance_poly ~keep_names:true false tl ty)} | _ -> pat in unify_pat env pat (type_approx env sexp)) pat_list spat_sexp_list; (* Polymorphic variant processing *) List.iter (fun pat -> if has_variants pat then begin Parmatch.pressure_variants env [pat]; iter_pattern finalize_variant pat end) pat_list; (* Generalize the structure *) let pat_list = if !Clflags.principal then begin end_def (); List.map (fun pat -> iter_pattern (fun pat -> generalize_structure pat.pat_type) pat; {pat with pat_type = instance env pat.pat_type}) pat_list end else pat_list in (* Only bind pattern variables after generalizing *) List.iter (fun f -> f()) force; let exp_env = if is_recursive then new_env else env in let current_slot = ref None in let rec_needed = ref false in let warn_unused = Warnings.is_active (check "") || Warnings.is_active (check_strict "") || (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag)) in let pat_slot_list = (* Algorithm to detect unused declarations in recursive bindings: - During type checking of the definitions, we capture the 'value_used' events on the bound identifiers and record them in a slot corresponding to the current definition (!current_slot). In effect, this creates a dependency graph between definitions. - After type checking the definition (!current_slot = None), when one of the bound identifier is effectively used, we trigger again all the events recorded in the corresponding slot. The effect is to traverse the transitive closure of the graph created in the first step. We also keep track of whether *all* variables in a given pattern are unused. If this is the case, for local declarations, the issued warning is 26, not 27. *) List.map (fun pat -> if not warn_unused then pat, None else let some_used = ref false in (* has one of the identifier of this pattern been used? *) let slot = ref [] in List.iter (fun (id,_) -> let vd = Env.find_value (Path.Pident id) new_env in (* note: Env.find_value does not trigger the value_used event *) let name = Ident.name id in let used = ref false in if not (name = "" || name.[0] = '_' || name.[0] = '#') then add_delayed_check (fun () -> if not !used then Location.prerr_warning vd.Types.val_loc ((if !some_used then check_strict else check) name) ); Env.set_value_used_callback name vd (fun () -> match !current_slot with | Some slot -> slot := (name, vd) :: !slot; rec_needed := true | None -> List.iter (fun (name, vd) -> Env.mark_value_used name vd) (get_ref slot); used := true; some_used := true ) ) (Typedtree.pat_bound_idents pat); pat, Some slot ) pat_list in let exp_list = List.map2 (fun (spat, sexp) (pat, slot) -> let sexp = if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in if is_recursive then current_slot := slot; match pat.pat_type.desc with | Tpoly (ty, tl) -> begin_def (); if !Clflags.principal then begin_def (); let vars, ty' = instance_poly ~keep_names:true true tl ty in if !Clflags.principal then begin end_def (); generalize_structure ty' end; let exp = type_expect exp_env sexp ty' in end_def (); check_univars env true "definition" exp pat.pat_type vars; {exp with exp_type = instance env exp.exp_type} | _ -> type_expect exp_env sexp pat.pat_type) spat_sexp_list pat_slot_list in current_slot := None; if is_recursive && not !rec_needed && Warnings.is_active Warnings.Unused_rec_flag then Location.prerr_warning (fst (List.hd spat_sexp_list)).ppat_loc Warnings.Unused_rec_flag; List.iter2 (fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [pat, exp])) pat_list exp_list; end_def(); List.iter2 (fun pat exp -> if not (is_nonexpansive exp) then iter_pattern (fun pat -> generalize_expansive env pat.pat_type) pat) pat_list exp_list; List.iter (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat) pat_list; (List.combine pat_list exp_list, new_env, unpacks) (* Typing of toplevel bindings *) let type_binding env rec_flag spat_sexp_list scope = Typetexp.reset_type_variables(); let (pat_exp_list, new_env, unpacks) = type_let ~check:(fun s -> Warnings.Unused_value_declaration s) ~check_strict:(fun s -> Warnings.Unused_value_declaration s) env rec_flag spat_sexp_list scope false in (pat_exp_list, new_env) let type_let env rec_flag spat_sexp_list scope = let (pat_exp_list, new_env, unpacks) = type_let env rec_flag spat_sexp_list scope false in (pat_exp_list, new_env) (* Typing of toplevel expressions *) let type_expression env sexp = Typetexp.reset_type_variables(); begin_def(); let exp = type_exp env sexp in end_def(); if is_nonexpansive exp then generalize exp.exp_type else generalize_expansive env exp.exp_type; match sexp.pexp_desc with Pexp_ident lid -> (* Special case for keeping type variables when looking-up a variable *) let (path, desc) = Env.lookup_value lid.txt env in {exp with exp_type = desc.val_type} | _ -> exp (* Error report *) open Format open Printtyp let report_error ppf = function | Polymorphic_label lid -> fprintf ppf "@[The record field label %a is polymorphic.@ %s@]" longident lid "You cannot instantiate it in a pattern." | Constructor_arity_mismatch(lid, expected, provided) -> fprintf ppf "@[The constructor %a@ expects %i argument(s),@ \ but is applied here to %i argument(s)@]" longident lid expected provided | Label_mismatch(lid, trace) -> report_unification_error ppf trace (function ppf -> fprintf ppf "The record field label %a@ belongs to the type" longident lid) (function ppf -> fprintf ppf "but is mixed here with labels of type") | Pattern_type_clash trace -> report_unification_error ppf trace (function ppf -> fprintf ppf "This pattern matches values of type") (function ppf -> fprintf ppf "but a pattern was expected which matches values of type") | Multiply_bound_variable name -> fprintf ppf "Variable %s is bound several times in this matching" name | Orpat_vars id -> fprintf ppf "Variable %s must occur on both sides of this | pattern" (Ident.name id) | Expr_type_clash trace -> report_unification_error ppf trace (function ppf -> fprintf ppf "This expression has type") (function ppf -> fprintf ppf "but an expression was expected of type") | Apply_non_function typ -> begin match (repr typ).desc with Tarrow _ -> fprintf ppf "This function is applied to too many arguments;@ "; fprintf ppf "maybe you forgot a `;'" | _ -> fprintf ppf "This expression is not a function; it cannot be applied" end | Apply_wrong_label (l, ty) -> let print_label ppf = function | "" -> fprintf ppf "without label" | l -> fprintf ppf "with label %s%s" (if is_optional l then "" else "~") l in reset_and_mark_loops ty; fprintf ppf "@[@[<2>The function applied to this argument has type@ %a@]@.\ This argument cannot be applied %a@]" type_expr ty print_label l | Label_multiply_defined lid -> fprintf ppf "The record field label %a is defined several times" longident lid | Label_missing labels -> let print_labels ppf = List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in fprintf ppf "@[Some record field labels are undefined:%a@]" print_labels labels | Label_not_mutable lid -> fprintf ppf "The record field label %a is not mutable" longident lid | Incomplete_format s -> fprintf ppf "Premature end of format string ``%S''" s | Bad_conversion (fmt, i, c) -> fprintf ppf "Bad conversion %%%c, at char number %d \ in format string ``%s''" c i fmt | Undefined_method (ty, me) -> reset_and_mark_loops ty; fprintf ppf "@[@[This expression has type@;<1 2>%a@]@,\ It has no method %s@]" type_expr ty me | Undefined_inherited_method me -> fprintf ppf "This expression has no method %s" me | Virtual_class cl -> fprintf ppf "Cannot instantiate the virtual class %a" longident cl | Unbound_instance_variable v -> fprintf ppf "Unbound instance variable %s" v | Instance_variable_not_mutable (b, v) -> if b then fprintf ppf "The instance variable %s is not mutable" v else fprintf ppf "The value %s is not an instance variable" v | Not_subtype(tr1, tr2) -> report_subtyping_error ppf tr1 "is not a subtype of" tr2 | Outside_class -> fprintf ppf "This object duplication occurs outside a method definition" | Value_multiply_overridden v -> fprintf ppf "The instance variable %s is overridden several times" v | Coercion_failure (ty, ty', trace, b) -> report_unification_error ppf trace (function ppf -> let ty, ty' = prepare_expansion (ty, ty') in fprintf ppf "This expression cannot be coerced to type@;<1 2>%a;@ it has type" (type_expansion ty) ty') (function ppf -> fprintf ppf "but is here used with type"); if b then fprintf ppf ".@.@[%s@ %s@]" "This simple coercion was not fully general." "Consider using a double coercion." | Too_many_arguments (in_function, ty) -> reset_and_mark_loops ty; if in_function then begin fprintf ppf "This function expects too many arguments,@ "; fprintf ppf "it should have type@ %a" type_expr ty end else begin fprintf ppf "This expression should not be a function,@ "; fprintf ppf "the expected type is@ %a" type_expr ty end | Abstract_wrong_label (l, ty) -> let label_mark = function | "" -> "but its first argument is not labelled" | l -> sprintf "but its first argument is labelled ~%s" l in reset_and_mark_loops ty; fprintf ppf "@[@[<2>This function should have type@ %a@]@,%s@]" type_expr ty (label_mark l) | Scoping_let_module(id, ty) -> reset_and_mark_loops ty; fprintf ppf "This `let module' expression has type@ %a@ " type_expr ty; fprintf ppf "In this type, the locally bound module name %s escapes its scope" id | Masked_instance_variable lid -> fprintf ppf "The instance variable %a@ \ cannot be accessed from the definition of another instance variable" longident lid | Private_type ty -> fprintf ppf "Cannot create values of the private type %a" type_expr ty | Private_label (lid, ty) -> fprintf ppf "Cannot assign field %a of the private type %a" longident lid type_expr ty | Not_a_variant_type lid -> fprintf ppf "The type %a@ is not a variant type" longident lid | Incoherent_label_order -> fprintf ppf "This function is applied to arguments@ "; fprintf ppf "in an order different from other calls.@ "; fprintf ppf "This is only allowed when the real type is known." | Less_general (kind, trace) -> report_unification_error ppf trace (fun ppf -> fprintf ppf "This %s has type" kind) (fun ppf -> fprintf ppf "which is less general than") | Modules_not_allowed -> fprintf ppf "Modules are not allowed in this pattern." | Cannot_infer_signature -> fprintf ppf "The signature for this packaged module couldn't be inferred." | Not_a_packed_module ty -> fprintf ppf "This expression is packed module, but the expected type is@ %a" type_expr ty | Recursive_local_constraint trace -> report_unification_error ppf trace (function ppf -> fprintf ppf "Recursive local constraint when unifying") (function ppf -> fprintf ppf "with") | Unexpected_existential -> fprintf ppf "Unexpected existential" let () = Env.add_delayed_check_forward := add_delayed_check mingw-ocaml/ocaml/typing/typeclass.mli0000644000175000017500000000765312124403242017516 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Asttypes open Types open Format val class_declarations: Env.t -> Parsetree.class_declaration list -> (Ident.t * string loc * class_declaration * Ident.t * class_type_declaration * Ident.t * type_declaration * Ident.t * type_declaration * int * string list * Typedtree.class_declaration) list * Env.t (* and class_declaration = (class_expr, Types.class_declaration) class_infos *) val class_descriptions: Env.t -> Parsetree.class_description list -> (Ident.t * string loc * class_declaration * Ident.t * class_type_declaration * Ident.t * type_declaration * Ident.t * type_declaration * int * string list * Typedtree.class_description) list * Env.t (* and class_description = (class_type, unit) class_infos *) val class_type_declarations: Env.t -> Parsetree.class_description list -> (Ident.t * string loc * class_type_declaration * Ident.t * type_declaration * Ident.t * type_declaration * Typedtree.class_type_declaration) list * Env.t (* and class_type_declaration = (class_type, Types.class_type_declaration) class_infos *) val approx_class_declarations: Env.t -> Parsetree.class_description list -> (Ident.t * string loc * class_type_declaration * Ident.t * type_declaration * Ident.t * type_declaration * Typedtree.class_type_declaration) list val virtual_methods: Types.class_signature -> label list (* val type_classes : bool -> ('a -> Types.type_expr) -> (Env.t -> 'a -> 'b * Types.class_type) -> Env.t -> 'a Parsetree.class_infos list -> ( Ident.t * Types.class_declaration * Ident.t * Types.class_type_declaration * Ident.t * Types.type_declaration * Ident.t * Types.type_declaration * int * string list * 'b * 'b Typedtree.class_infos) list * Env.t *) type error = Unconsistent_constraint of (type_expr * type_expr) list | Field_type_mismatch of string * string * (type_expr * type_expr) list | Structure_expected of class_type | Cannot_apply of class_type | Apply_wrong_label of label | Pattern_type_clash of type_expr | Repeated_parameter | Unbound_class_2 of Longident.t | Unbound_class_type_2 of Longident.t | Abbrev_type_clash of type_expr * type_expr * type_expr | Constructor_type_mismatch of string * (type_expr * type_expr) list | Virtual_class of bool * string list * string list | Parameter_arity_mismatch of Longident.t * int * int | Parameter_mismatch of (type_expr * type_expr) list | Bad_parameters of Ident.t * type_expr * type_expr | Class_match_failure of Ctype.class_match_failure list | Unbound_val of string | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure | Make_nongen_seltype of type_expr | Non_generalizable_class of Ident.t * Types.class_declaration | Cannot_coerce_self of type_expr | Non_collapsable_conjunction of Ident.t * Types.class_declaration * (type_expr * type_expr) list | Final_self_clash of (type_expr * type_expr) list | Mutability_mismatch of string * mutable_flag | No_overriding of string * string exception Error of Location.t * error val report_error : formatter -> error -> unit mingw-ocaml/ocaml/typing/typemod.mli0000644000175000017500000000515212124403242017160 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Type-checking of the module language *) open Types open Format val type_module: Env.t -> Parsetree.module_expr -> Typedtree.module_expr val type_structure: Env.t -> Parsetree.structure -> Location.t -> Typedtree.structure * Types.signature * Env.t val type_toplevel_phrase: Env.t -> Parsetree.structure -> Typedtree.structure * Types.signature * Env.t val type_implementation: string -> string -> string -> Env.t -> Parsetree.structure -> Typedtree.structure * Typedtree.module_coercion val transl_signature: Env.t -> Parsetree.signature -> Typedtree.signature val check_nongen_schemes: Env.t -> Typedtree.structure_item list -> unit val simplify_signature: signature -> signature val save_signature : string -> Typedtree.signature -> string -> string -> Env.t -> Types.signature_item list -> unit val package_units: string list -> string -> string -> Typedtree.module_coercion val bound_value_identifiers : Types.signature_item list -> Ident.t list type error = Cannot_apply of module_type | Not_included of Includemod.error list | Cannot_eliminate_dependency of module_type | Signature_expected | Structure_expected of module_type | With_no_component of Longident.t | With_mismatch of Longident.t * Includemod.error list | Repeated_name of string * string | Non_generalizable of type_expr | Non_generalizable_class of Ident.t * class_declaration | Non_generalizable_module of module_type | Implementation_is_required of string | Interface_not_compiled of string | Not_allowed_in_functor_body | With_need_typeconstr | Not_a_packed_module of type_expr | Incomplete_packed_module of type_expr | Scoping_pack of Longident.t * type_expr exception Error of Location.t * error val report_error: formatter -> error -> unit mingw-ocaml/ocaml/typing/typemod.ml0000644000175000017500000015674212124403242017023 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Misc open Longident open Path open Asttypes open Parsetree open Types open Format type error = Cannot_apply of module_type | Not_included of Includemod.error list | Cannot_eliminate_dependency of module_type | Signature_expected | Structure_expected of module_type | With_no_component of Longident.t | With_mismatch of Longident.t * Includemod.error list | Repeated_name of string * string | Non_generalizable of type_expr | Non_generalizable_class of Ident.t * class_declaration | Non_generalizable_module of module_type | Implementation_is_required of string | Interface_not_compiled of string | Not_allowed_in_functor_body | With_need_typeconstr | Not_a_packed_module of type_expr | Incomplete_packed_module of type_expr | Scoping_pack of Longident.t * type_expr exception Error of Location.t * error open Typedtree let fst3 (x,_,_) = x let rec path_concat head p = match p with Pident tail -> Pdot (Pident head, Ident.name tail, 0) | Pdot (pre, s, pos) -> Pdot (path_concat head pre, s, pos) | Papply _ -> assert false (* Extract a signature from a module type *) let extract_sig env loc mty = match Mtype.scrape env mty with Mty_signature sg -> sg | _ -> raise(Error(loc, Signature_expected)) let extract_sig_open env loc mty = match Mtype.scrape env mty with Mty_signature sg -> sg | _ -> raise(Error(loc, Structure_expected mty)) (* Compute the environment after opening a module *) let type_open ?toplevel env loc lid = let (path, mty) = Typetexp.find_module env loc lid.txt in let sg = extract_sig_open env loc mty in path, Env.open_signature ~loc ?toplevel path sg env (* Record a module type *) let rm node = Stypes.record (Stypes.Ti_mod node); node (* Forward declaration, to be filled in by type_module_type_of *) let type_module_type_of_fwd : (Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Types.module_type) ref = ref (fun env m -> assert false) (* Merge one "with" constraint in a signature *) let rec add_rec_types env = function Sig_type(id, decl, Trec_next) :: rem -> add_rec_types (Env.add_type id decl env) rem | _ -> env let check_type_decl env id row_id newdecl decl rs rem = let env = Env.add_type id newdecl env in let env = match row_id with None -> env | Some id -> Env.add_type id newdecl env in let env = if rs = Trec_not then env else add_rec_types env rem in Includemod.type_declarations env id newdecl decl let rec make_params n = function [] -> [] | _ :: l -> ("a" ^ string_of_int n) :: make_params (n+1) l let wrap_param s = {ptyp_desc=Ptyp_var s; ptyp_loc=Location.none} let make_next_first rs rem = if rs = Trec_first then match rem with Sig_type (id, decl, Trec_next) :: rem -> Sig_type (id, decl, Trec_first) :: rem | Sig_module (id, mty, Trec_next) :: rem -> Sig_module (id, mty, Trec_first) :: rem | _ -> rem else rem let sig_item desc typ env loc = { Typedtree.sig_desc = desc; sig_loc = loc; sig_env = env } let merge_constraint initial_env loc sg lid constr = let real_id = ref None in let rec merge env sg namelist row_id = match (sg, namelist, constr) with ([], _, _) -> raise(Error(loc, With_no_component lid.txt)) | (Sig_type(id, decl, rs) :: rem, [s], Pwith_type ({ptype_kind = Ptype_abstract} as sdecl)) when Ident.name id = s && Typedecl.is_fixed_type sdecl -> let decl_row = { type_params = List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params; type_arity = List.length sdecl.ptype_params; type_kind = Type_abstract; type_private = Private; type_manifest = None; type_variance = List.map (fun (c,n) -> (not n, not c, not c)) sdecl.ptype_variance; type_loc = Location.none; type_newtype_level = None } and id_row = Ident.create (s^"#row") in let initial_env = Env.add_type id_row decl_row initial_env in let tdecl = Typedecl.transl_with_constraint initial_env id (Some(Pident id_row)) decl sdecl in let newdecl = tdecl.typ_type in check_type_decl env id row_id newdecl decl rs rem; let decl_row = {decl_row with type_params = newdecl.type_params} in let rs' = if rs = Trec_first then Trec_not else rs in (Pident id, lid, Twith_type tdecl), Sig_type(id_row, decl_row, rs') :: Sig_type(id, newdecl, rs) :: rem | (Sig_type(id, decl, rs) :: rem , [s], Pwith_type sdecl) when Ident.name id = s -> let tdecl = Typedecl.transl_with_constraint initial_env id None decl sdecl in let newdecl = tdecl.typ_type in check_type_decl env id row_id newdecl decl rs rem; (Pident id, lid, Twith_type tdecl), Sig_type(id, newdecl, rs) :: rem | (Sig_type(id, decl, rs) :: rem, [s], (Pwith_type _ | Pwith_typesubst _)) when Ident.name id = s ^ "#row" -> merge env rem namelist (Some id) | (Sig_type(id, decl, rs) :: rem, [s], Pwith_typesubst sdecl) when Ident.name id = s -> (* Check as for a normal with constraint, but discard definition *) let tdecl = Typedecl.transl_with_constraint initial_env id None decl sdecl in let newdecl = tdecl.typ_type in check_type_decl env id row_id newdecl decl rs rem; real_id := Some id; (Pident id, lid, Twith_typesubst tdecl), make_next_first rs rem | (Sig_module(id, mty, rs) :: rem, [s], Pwith_module (lid)) when Ident.name id = s -> let (path, mty') = Typetexp.find_module initial_env loc lid.txt in let newmty = Mtype.strengthen env mty' path in ignore(Includemod.modtypes env newmty mty); (Pident id, lid, Twith_module (path, lid)), Sig_module(id, newmty, rs) :: rem | (Sig_module(id, mty, rs) :: rem, [s], Pwith_modsubst (lid)) when Ident.name id = s -> let (path, mty') = Typetexp.find_module initial_env loc lid.txt in let newmty = Mtype.strengthen env mty' path in ignore(Includemod.modtypes env newmty mty); real_id := Some id; (Pident id, lid, Twith_modsubst (path, lid)), make_next_first rs rem | (Sig_module(id, mty, rs) :: rem, s :: namelist, _) when Ident.name id = s -> let ((path, path_loc, tcstr), newsg) = merge env (extract_sig env loc mty) namelist None in (path_concat id path, lid, tcstr), Sig_module(id, Mty_signature newsg, rs) :: rem | (item :: rem, _, _) -> let (cstr, items) = merge (Env.add_item item env) rem namelist row_id in cstr, item :: items in try let names = Longident.flatten lid.txt in let (tcstr, sg) = merge initial_env sg names None in let sg = match names, constr with [s], Pwith_typesubst sdecl -> let id = match !real_id with None -> assert false | Some id -> id in let lid = try match sdecl.ptype_manifest with | Some {ptyp_desc = Ptyp_constr (lid, stl)} when List.length stl = List.length sdecl.ptype_params -> let params = List.map (function {ptyp_desc=Ptyp_var s} -> s | _ -> raise Exit) stl in List.iter2 (fun x ox -> match ox with Some y when x = y.txt -> () | _ -> raise Exit ) params sdecl.ptype_params; lid | _ -> raise Exit with Exit -> raise (Error (sdecl.ptype_loc, With_need_typeconstr)) in let (path, _) = try Env.lookup_type lid.txt initial_env with Not_found -> assert false in let sub = Subst.add_type id path Subst.identity in Subst.signature sub sg | [s], Pwith_modsubst (lid) -> let id = match !real_id with None -> assert false | Some id -> id in let (path, _) = Typetexp.find_module initial_env loc lid.txt in let sub = Subst.add_module id path Subst.identity in Subst.signature sub sg | _ -> sg in (tcstr, sg) with Includemod.Error explanation -> raise(Error(loc, With_mismatch(lid.txt, explanation))) (* Add recursion flags on declarations arising from a mutually recursive block. *) let map_rec fn decls rem = match decls with | [] -> rem | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem let rec map_rec' fn decls rem = match decls with | (id,_ as d1) :: dl when Btype.is_row_name (Ident.name id) -> fn Trec_not d1 :: map_rec' fn dl rem | _ -> map_rec fn decls rem let rec map_rec'' fn decls rem = match decls with | (id, _,_ as d1) :: dl when Btype.is_row_name (Ident.name id) -> fn Trec_not d1 :: map_rec'' fn dl rem | _ -> map_rec fn decls rem (* Auxiliary for translating recursively-defined module types. Return a module type that approximates the shape of the given module type AST. Retain only module, type, and module type components of signatures. For types, retain only their arity, making them abstract otherwise. *) let rec approx_modtype env smty = match smty.pmty_desc with Pmty_ident lid -> let (path, info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in Mty_ident path | Pmty_signature ssg -> Mty_signature(approx_sig env ssg) | Pmty_functor(param, sarg, sres) -> let arg = approx_modtype env sarg in let (id, newenv) = Env.enter_module param.txt arg env in let res = approx_modtype newenv sres in Mty_functor(id, arg, res) | Pmty_with(sbody, constraints) -> approx_modtype env sbody | Pmty_typeof smod -> let (_, mty) = !type_module_type_of_fwd env smod in mty and approx_sig env ssg = match ssg with [] -> [] | item :: srem -> match item.psig_desc with | Psig_type sdecls -> let decls = Typedecl.approx_type_decl env sdecls in let rem = approx_sig env srem in map_rec' (fun rs (id, info) -> Sig_type(id, info, rs)) decls rem | Psig_module(name, smty) -> let mty = approx_modtype env smty in let (id, newenv) = Env.enter_module name.txt mty env in Sig_module(id, mty, Trec_not) :: approx_sig newenv srem | Psig_recmodule sdecls -> let decls = List.map (fun (name, smty) -> (Ident.create name.txt, approx_modtype env smty)) sdecls in let newenv = List.fold_left (fun env (id, mty) -> Env.add_module id mty env) env decls in map_rec (fun rs (id, mty) -> Sig_module(id, mty, rs)) decls (approx_sig newenv srem) | Psig_modtype(name, sinfo) -> let info = approx_modtype_info env sinfo in let (id, newenv) = Env.enter_modtype name.txt info env in Sig_modtype(id, info) :: approx_sig newenv srem | Psig_open lid -> let (path, mty) = type_open env item.psig_loc lid in approx_sig mty srem | Psig_include smty -> let mty = approx_modtype env smty in let sg = Subst.signature Subst.identity (extract_sig env smty.pmty_loc mty) in let newenv = Env.add_signature sg env in sg @ approx_sig newenv srem | Psig_class sdecls | Psig_class_type sdecls -> let decls = Typeclass.approx_class_declarations env sdecls in let rem = approx_sig env srem in List.flatten (map_rec (fun rs (i1, _, d1, i2, d2, i3, d3, _) -> [Sig_class_type(i1, d1, rs); Sig_type(i2, d2, rs); Sig_type(i3, d3, rs)]) decls [rem]) | _ -> approx_sig env srem and approx_modtype_info env sinfo = match sinfo with Pmodtype_abstract -> Modtype_abstract | Pmodtype_manifest smty -> Modtype_manifest(approx_modtype env smty) (* Additional validity checks on type definitions arising from recursive modules *) let check_recmod_typedecls env sdecls decls = let recmod_ids = List.map fst3 decls in List.iter2 (fun (_, smty) (id, _, mty) -> let mty = mty.mty_type in List.iter (fun path -> Typedecl.check_recmod_typedecl env smty.pmty_loc recmod_ids path (Env.find_type path env)) (Mtype.type_paths env (Pident id) mty)) sdecls decls (* Auxiliaries for checking uniqueness of names in signatures and structures *) module StringSet = Set.Make(struct type t = string let compare = compare end) let check cl loc set_ref name = if StringSet.mem name !set_ref then raise(Error(loc, Repeated_name(cl, name))) else set_ref := StringSet.add name !set_ref let check_sig_item type_names module_names modtype_names loc = function Sig_type(id, _, _) -> check "type" loc type_names (Ident.name id) | Sig_module(id, _, _) -> check "module" loc module_names (Ident.name id) | Sig_modtype(id, _) -> check "module type" loc modtype_names (Ident.name id) | _ -> () let rec remove_values ids = function [] -> [] | Sig_value (id, _) :: rem when List.exists (Ident.equal id) ids -> remove_values ids rem | f :: rem -> f :: remove_values ids rem let rec get_values = function [] -> [] | Sig_value (id, _) :: rem -> id :: get_values rem | f :: rem -> get_values rem (* Check and translate a module type expression *) let transl_modtype_longident loc env lid = let (path, info) = Typetexp.find_modtype env loc lid in path let mkmty desc typ env loc = let mty = { mty_desc = desc; mty_type = typ; mty_loc = loc; mty_env = env; } in Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty); mty let mksig desc env loc = let sg = { sig_desc = desc; sig_loc = loc; sig_env = env } in Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg); sg (* let signature sg = List.map (fun item -> item.sig_type) sg *) let rec transl_modtype env smty = let loc = smty.pmty_loc in match smty.pmty_desc with Pmty_ident lid -> let path = transl_modtype_longident loc env lid.txt in mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc | Pmty_signature ssg -> let sg = transl_signature env ssg in mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc | Pmty_functor(param, sarg, sres) -> let arg = transl_modtype env sarg in let (id, newenv) = Env.enter_module param.txt arg.mty_type env in let res = transl_modtype newenv sres in mkmty (Tmty_functor (id, param, arg, res)) (Mty_functor(id, arg.mty_type, res.mty_type)) env loc | Pmty_with(sbody, constraints) -> let body = transl_modtype env sbody in let init_sg = extract_sig env sbody.pmty_loc body.mty_type in let (tcstrs, final_sg) = List.fold_left (fun (tcstrs,sg) (lid, sdecl) -> let (tcstr, sg) = merge_constraint env smty.pmty_loc sg lid sdecl in (tcstr :: tcstrs, sg) ) ([],init_sg) constraints in mkmty (Tmty_with ( body, tcstrs)) (Mtype.freshen (Mty_signature final_sg)) env loc | Pmty_typeof smod -> let tmty, mty = !type_module_type_of_fwd env smod in mkmty (Tmty_typeof tmty) mty env loc and transl_signature env sg = let type_names = ref StringSet.empty and module_names = ref StringSet.empty and modtype_names = ref StringSet.empty in let rec transl_sig env sg = Ctype.init_def(Ident.current_time()); match sg with [] -> [], [], env | item :: srem -> let loc = item.psig_loc in match item.psig_desc with | Psig_value(name, sdesc) -> let tdesc = Typedecl.transl_value_decl env item.psig_loc sdesc in let desc = tdesc.val_val in let (id, newenv) = Env.enter_value name.txt desc env ~check:(fun s -> Warnings.Unused_value_declaration s) in let (trem,rem, final_env) = transl_sig newenv srem in mksig (Tsig_value (id, name, tdesc)) env loc :: trem, (if List.exists (Ident.equal id) (get_values rem) then rem else Sig_value(id, desc) :: rem), final_env | Psig_type sdecls -> List.iter (fun (name, decl) -> check "type" item.psig_loc type_names name.txt) sdecls; let (decls, newenv) = Typedecl.transl_type_decl env sdecls in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_type decls) env loc :: trem, map_rec'' (fun rs (id, _, info) -> Sig_type(id, info.typ_type, rs)) decls rem, final_env | Psig_exception(name, sarg) -> let arg = Typedecl.transl_exception env item.psig_loc sarg in let (id, newenv) = Env.enter_exception name.txt arg.exn_exn env in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_exception (id, name, arg)) env loc :: trem, Sig_exception(id, arg.exn_exn) :: rem, final_env | Psig_module(name, smty) -> check "module" item.psig_loc module_names name.txt; let tmty = transl_modtype env smty in let mty = tmty.mty_type in let (id, newenv) = Env.enter_module name.txt mty env in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_module (id, name, tmty)) env loc :: trem, Sig_module(id, mty, Trec_not) :: rem, final_env | Psig_recmodule sdecls -> List.iter (fun (name, smty) -> check "module" item.psig_loc module_names name.txt) sdecls; let (decls, newenv) = transl_recmodule_modtypes item.psig_loc env sdecls in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_recmodule decls) env loc :: trem, map_rec (fun rs (id, _, tmty) -> Sig_module(id, tmty.mty_type, rs)) decls rem, final_env | Psig_modtype(name, sinfo) -> check "module type" item.psig_loc modtype_names name.txt; let (tinfo, info) = transl_modtype_info env sinfo in let (id, newenv) = Env.enter_modtype name.txt info env in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_modtype (id, name, tinfo)) env loc :: trem, Sig_modtype(id, info) :: rem, final_env | Psig_open lid -> let (path, newenv) = type_open env item.psig_loc lid in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_open (path,lid)) env loc :: trem, rem, final_env | Psig_include smty -> let tmty = transl_modtype env smty in let mty = tmty.mty_type in let sg = Subst.signature Subst.identity (extract_sig env smty.pmty_loc mty) in List.iter (check_sig_item type_names module_names modtype_names item.psig_loc) sg; let newenv = Env.add_signature sg env in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_include (tmty, sg)) env loc :: trem, remove_values (get_values rem) sg @ rem, final_env | Psig_class cl -> List.iter (fun {pci_name = name} -> check "type" item.psig_loc type_names name.txt ) cl; let (classes, newenv) = Typeclass.class_descriptions env cl in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_class (List.map2 (fun pcl tcl -> let (_, _, _, _, _, _, _, _, _, _, _, tcl) = tcl in tcl) cl classes)) env loc :: trem, List.flatten (map_rec (fun rs (i, _, d, i', d', i'', d'', i''', d''', _, _, _) -> [Sig_class(i, d, rs); Sig_class_type(i', d', rs); Sig_type(i'', d'', rs); Sig_type(i''', d''', rs)]) classes [rem]), final_env | Psig_class_type cl -> List.iter (fun {pci_name = name} -> check "type" item.psig_loc type_names name.txt) cl; let (classes, newenv) = Typeclass.class_type_declarations env cl in let (trem,rem, final_env) = transl_sig newenv srem in mksig (Tsig_class_type (List.map2 (fun pcl tcl -> let (_, _, _, _, _, _, _, tcl) = tcl in tcl ) cl classes)) env loc :: trem, List.flatten (map_rec (fun rs (i, _, d, i', d', i'', d'', _) -> [Sig_class_type(i, d, rs); Sig_type(i', d', rs); Sig_type(i'', d'', rs)]) classes [rem]), final_env in let previous_saved_types = Cmt_format.get_saved_types () in let (trem, rem, final_env) = transl_sig (Env.in_signature env) sg in let sg = { sig_items = trem; sig_type = rem; sig_final_env = final_env } in Cmt_format.set_saved_types ((Cmt_format.Partial_signature sg) :: previous_saved_types); sg and transl_modtype_info env sinfo = match sinfo with Pmodtype_abstract -> Tmodtype_abstract, Modtype_abstract | Pmodtype_manifest smty -> let tmty = transl_modtype env smty in Tmodtype_manifest tmty, Modtype_manifest tmty.mty_type and transl_recmodule_modtypes loc env sdecls = let make_env curr = List.fold_left (fun env (id, _, mty) -> Env.add_module id mty env) env curr in let make_env2 curr = List.fold_left (fun env (id, _, mty) -> Env.add_module id mty.mty_type env) env curr in let transition env_c curr = List.map2 (fun (_,smty) (id,id_loc,mty) -> (id, id_loc, transl_modtype env_c smty)) sdecls curr in let init = List.map (fun (name, smty) -> (Ident.create name.txt, name, approx_modtype env smty)) sdecls in let env0 = make_env init in let dcl1 = transition env0 init in let env1 = make_env2 dcl1 in check_recmod_typedecls env1 sdecls dcl1; let dcl2 = transition env1 dcl1 in (* List.iter (fun (id, mty) -> Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty) dcl2; *) let env2 = make_env2 dcl2 in check_recmod_typedecls env2 sdecls dcl2; (dcl2, env2) (* Try to convert a module expression to a module path. *) exception Not_a_path let rec path_of_module mexp = match mexp.mod_desc with Tmod_ident (p,_) -> p | Tmod_apply(funct, arg, coercion) when !Clflags.applicative_functors -> Papply(path_of_module funct, path_of_module arg) | _ -> raise Not_a_path (* Check that all core type schemes in a structure are closed *) let rec closed_modtype = function Mty_ident p -> true | Mty_signature sg -> List.for_all closed_signature_item sg | Mty_functor(id, param, body) -> closed_modtype body and closed_signature_item = function Sig_value(id, desc) -> Ctype.closed_schema desc.val_type | Sig_module(id, mty, _) -> closed_modtype mty | _ -> true let check_nongen_scheme env str = match str.str_desc with Tstr_value(rec_flag, pat_exp_list) -> List.iter (fun (pat, exp) -> if not (Ctype.closed_schema exp.exp_type) then raise(Error(exp.exp_loc, Non_generalizable exp.exp_type))) pat_exp_list | Tstr_module(id, _, md) -> if not (closed_modtype md.mod_type) then raise(Error(md.mod_loc, Non_generalizable_module md.mod_type)) | _ -> () let check_nongen_schemes env str = List.iter (check_nongen_scheme env) str (* Extract the list of "value" identifiers bound by a signature. "Value" identifiers are identifiers for signature components that correspond to a run-time value: values, exceptions, modules, classes. Note: manifest primitives do not correspond to a run-time value! *) let rec bound_value_identifiers = function [] -> [] | Sig_value(id, {val_kind = Val_reg}) :: rem -> id :: bound_value_identifiers rem | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem | _ :: rem -> bound_value_identifiers rem (* Helpers for typing recursive modules *) let anchor_submodule name anchor = match anchor with None -> None | Some p -> Some(Pdot(p, name, nopos)) let anchor_recmodule id anchor = Some (Pident id) let enrich_type_decls anchor decls oldenv newenv = match anchor with None -> newenv | Some p -> List.fold_left (fun e (id, _, info) -> let info' = Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id, nopos)) info.typ_type in Env.add_type id info' e) oldenv decls let enrich_module_type anchor name mty env = match anchor with None -> mty | Some p -> Mtype.enrich_modtype env (Pdot(p, name, nopos)) mty let check_recmodule_inclusion env bindings = (* PR#4450, PR#4470: consider module rec X : DECL = MOD where MOD has inferred type ACTUAL The "natural" typing condition E, X: ACTUAL |- ACTUAL <: DECL leads to circularities through manifest types. Instead, we "unroll away" the potential circularities a finite number of times. The (weaker) condition we implement is: E, X: DECL, X1: ACTUAL, X2: ACTUAL{X <- X1}/X1 ... Xn: ACTUAL{X <- X(n-1)}/X(n-1) |- ACTUAL{X <- Xn}/Xn <: DECL{X <- Xn} so that manifest types rooted at X(n+1) are expanded in terms of X(n), avoiding circularities. The strengthenings ensure that Xn.t = X(n-1).t = ... = X2.t = X1.t. N can be chosen arbitrarily; larger values of N result in more recursive definitions being accepted. A good choice appears to be the number of mutually recursive declarations. *) let subst_and_strengthen env s id mty = Mtype.strengthen env (Subst.modtype s mty) (Subst.module_path s (Pident id)) in let rec check_incl first_time n env s = if n > 0 then begin (* Generate fresh names Y_i for the rec. bound module idents X_i *) let bindings1 = List.map (fun (id, _, mty_decl, modl, mty_actual) -> (id, Ident.rename id, mty_actual)) bindings in (* Enter the Y_i in the environment with their actual types substituted by the input substitution s *) let env' = List.fold_left (fun env (id, id', mty_actual) -> let mty_actual' = if first_time then mty_actual else subst_and_strengthen env s id mty_actual in Env.add_module id' mty_actual' env) env bindings1 in (* Build the output substitution Y_i <- X_i *) let s' = List.fold_left (fun s (id, id', mty_actual) -> Subst.add_module id (Pident id') s) Subst.identity bindings1 in (* Recurse with env' and s' *) check_incl false (n-1) env' s' end else begin (* Base case: check inclusion of s(mty_actual) in s(mty_decl) and insert coercion if needed *) let check_inclusion (id, id_loc, mty_decl, modl, mty_actual) = let mty_decl' = Subst.modtype s mty_decl.mty_type and mty_actual' = subst_and_strengthen env s id mty_actual in let coercion = try Includemod.modtypes env mty_actual' mty_decl' with Includemod.Error msg -> raise(Error(modl.mod_loc, Not_included msg)) in let modl' = { mod_desc = Tmod_constraint(modl, mty_decl.mty_type, Tmodtype_explicit mty_decl, coercion); mod_type = mty_decl.mty_type; mod_env = env; mod_loc = modl.mod_loc } in (id, id_loc, mty_decl, modl') in List.map check_inclusion bindings end in check_incl true (List.length bindings) env Subst.identity (* Helper for unpack *) let rec package_constraints env loc mty constrs = if constrs = [] then mty else let sg = extract_sig env loc mty in let sg' = List.map (function | Sig_type (id, ({type_params=[]} as td), rs) when List.mem_assoc [Ident.name id] constrs -> let ty = List.assoc [Ident.name id] constrs in Sig_type (id, {td with type_manifest = Some ty}, rs) | Sig_module (id, mty, rs) -> let rec aux = function | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> (l, t) :: aux rest | _ :: rest -> aux rest | [] -> [] in Sig_module (id, package_constraints env loc mty (aux constrs), rs) | item -> item ) sg in Mty_signature sg' let modtype_of_package env loc p nl tl = try match Env.find_modtype p env with | Modtype_manifest mty when nl <> [] -> package_constraints env loc mty (List.combine (List.map Longident.flatten nl) tl) | _ -> if nl = [] then Mty_ident p else raise(Error(loc, Signature_expected)) with Not_found -> raise(Typetexp.Error(loc, Typetexp.Unbound_modtype (Ctype.lid_of_path p))) let wrap_constraint env arg mty explicit = let coercion = try Includemod.modtypes env arg.mod_type mty with Includemod.Error msg -> raise(Error(arg.mod_loc, Not_included msg)) in { mod_desc = Tmod_constraint(arg, mty, explicit, coercion); mod_type = mty; mod_env = env; mod_loc = arg.mod_loc } (* Type a module value expression *) let mkstr desc loc env = let str = { str_desc = desc; str_loc = loc; str_env = env } in Cmt_format.add_saved_type (Cmt_format.Partial_structure_item str); str let rec type_module sttn funct_body anchor env smod = match smod.pmod_desc with Pmod_ident lid -> let (path, mty) = Typetexp.find_module env smod.pmod_loc lid.txt in rm { mod_desc = Tmod_ident (path, lid); mod_type = if sttn then Mtype.strengthen env mty path else mty; mod_env = env; mod_loc = smod.pmod_loc } | Pmod_structure sstr -> let (str, sg, finalenv) = type_structure funct_body anchor env sstr smod.pmod_loc in rm { mod_desc = Tmod_structure str; mod_type = Mty_signature sg; mod_env = env; mod_loc = smod.pmod_loc } | Pmod_functor(name, smty, sbody) -> let mty = transl_modtype env smty in let (id, newenv) = Env.enter_module name.txt mty.mty_type env in let body = type_module sttn true None newenv sbody in rm { mod_desc = Tmod_functor(id, name, mty, body); mod_type = Mty_functor(id, mty.mty_type, body.mod_type); mod_env = env; mod_loc = smod.pmod_loc } | Pmod_apply(sfunct, sarg) -> let arg = type_module true funct_body None env sarg in let path = try Some (path_of_module arg) with Not_a_path -> None in let funct = type_module (sttn && path <> None) funct_body None env sfunct in begin match Mtype.scrape env funct.mod_type with Mty_functor(param, mty_param, mty_res) as mty_functor -> let coercion = try Includemod.modtypes env arg.mod_type mty_param with Includemod.Error msg -> raise(Error(sarg.pmod_loc, Not_included msg)) in let mty_appl = match path with Some path -> Subst.modtype (Subst.add_module param path Subst.identity) mty_res | None -> try Mtype.nondep_supertype (Env.add_module param arg.mod_type env) param mty_res with Not_found -> raise(Error(smod.pmod_loc, Cannot_eliminate_dependency mty_functor)) in rm { mod_desc = Tmod_apply(funct, arg, coercion); mod_type = mty_appl; mod_env = env; mod_loc = smod.pmod_loc } | _ -> raise(Error(sfunct.pmod_loc, Cannot_apply funct.mod_type)) end | Pmod_constraint(sarg, smty) -> let arg = type_module true funct_body anchor env sarg in let mty = transl_modtype env smty in rm {(wrap_constraint env arg mty.mty_type (Tmodtype_explicit mty)) with mod_loc = smod.pmod_loc} | Pmod_unpack sexp -> if funct_body then raise (Error (smod.pmod_loc, Not_allowed_in_functor_body)); if !Clflags.principal then Ctype.begin_def (); let exp = Typecore.type_exp env sexp in if !Clflags.principal then begin Ctype.end_def (); Ctype.generalize_structure exp.exp_type end; let mty = match Ctype.expand_head env exp.exp_type with {desc = Tpackage (p, nl, tl)} -> if List.exists (fun t -> Ctype.free_variables t <> []) tl then raise (Error (smod.pmod_loc, Incomplete_packed_module exp.exp_type)); if !Clflags.principal && not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type) then Location.prerr_warning smod.pmod_loc (Warnings.Not_principal "this module unpacking"); modtype_of_package env smod.pmod_loc p nl tl | {desc = Tvar _} -> raise (Typecore.Error (smod.pmod_loc, Typecore.Cannot_infer_signature)) | _ -> raise (Error (smod.pmod_loc, Not_a_packed_module exp.exp_type)) in rm { mod_desc = Tmod_unpack(exp, mty); mod_type = mty; mod_env = env; mod_loc = smod.pmod_loc } and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let type_names = ref StringSet.empty and module_names = ref StringSet.empty and modtype_names = ref StringSet.empty in let rec type_struct env sstr = let mkstr desc loc = mkstr desc loc env in Ctype.init_def(Ident.current_time()); match sstr with [] -> ([], [], env) | pstr :: srem -> let loc = pstr.pstr_loc in match pstr.pstr_desc with | Pstr_eval sexpr -> let expr = Typecore.type_expression env sexpr in let (str_rem, sig_rem, final_env) = type_struct env srem in (mkstr (Tstr_eval expr) loc :: str_rem, sig_rem, final_env) | Pstr_value(rec_flag, sdefs) -> let scope = match rec_flag with | Recursive -> Some (Annot.Idef {scope with Location.loc_start = loc.Location.loc_start}) | Nonrecursive -> let start = match srem with | [] -> loc.Location.loc_end | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start in Some (Annot.Idef {scope with Location.loc_start = start}) | Default -> None in let (defs, newenv) = Typecore.type_binding env rec_flag sdefs scope in let (str_rem, sig_rem, final_env) = type_struct newenv srem in let bound_idents = let_bound_idents defs in (* Note: Env.find_value does not trigger the value_used event. Values will be marked as being used during the signature inclusion test. *) let make_sig_value id = Sig_value(id, Env.find_value (Pident id) newenv) in (mkstr (Tstr_value(rec_flag, defs)) loc :: str_rem, map_end make_sig_value bound_idents sig_rem, final_env) | Pstr_primitive(name, sdesc) -> let desc = Typedecl.transl_value_decl env loc sdesc in let (id, newenv) = Env.enter_value name.txt desc.val_val env ~check:(fun s -> Warnings.Unused_value_declaration s) in let (str_rem, sig_rem, final_env) = type_struct newenv srem in (mkstr (Tstr_primitive(id, name, desc)) loc :: str_rem, Sig_value(id, desc.val_val) :: sig_rem, final_env) | Pstr_type sdecls -> List.iter (fun (name, decl) -> check "type" loc type_names name.txt) sdecls; let (decls, newenv) = Typedecl.transl_type_decl env sdecls in let newenv' = enrich_type_decls anchor decls env newenv in let (str_rem, sig_rem, final_env) = type_struct newenv' srem in (mkstr (Tstr_type decls) loc :: str_rem, map_rec'' (fun rs (id, _, info) -> Sig_type(id, info.typ_type, rs)) decls sig_rem, final_env) | Pstr_exception(name, sarg) -> let arg = Typedecl.transl_exception env loc sarg in let (id, newenv) = Env.enter_exception name.txt arg.exn_exn env in let (str_rem, sig_rem, final_env) = type_struct newenv srem in (mkstr (Tstr_exception(id, name, arg)) loc :: str_rem, Sig_exception(id, arg.exn_exn) :: sig_rem, final_env) | Pstr_exn_rebind(name, longid) -> let (path, arg) = Typedecl.transl_exn_rebind env loc longid.txt in let (id, newenv) = Env.enter_exception name.txt arg env in let (str_rem, sig_rem, final_env) = type_struct newenv srem in (mkstr (Tstr_exn_rebind(id, name, path, longid)) loc :: str_rem, Sig_exception(id, arg) :: sig_rem, final_env) | Pstr_module(name, smodl) -> check "module" loc module_names name.txt; let modl = type_module true funct_body (anchor_submodule name.txt anchor) env smodl in let mty = enrich_module_type anchor name.txt modl.mod_type env in let (id, newenv) = Env.enter_module name.txt mty env in let (str_rem, sig_rem, final_env) = type_struct newenv srem in (mkstr (Tstr_module(id, name, modl)) loc :: str_rem, Sig_module(id, modl.mod_type, Trec_not) :: sig_rem, final_env) | Pstr_recmodule sbind -> List.iter (fun (name, _, _) -> check "module" loc module_names name.txt) sbind; let (decls, newenv) = transl_recmodule_modtypes loc env (List.map (fun (name, smty, smodl) -> (name, smty)) sbind) in let bindings1 = List.map2 (fun (id, _, mty) (name, _, smodl) -> let modl = type_module true funct_body (anchor_recmodule id anchor) newenv smodl in let mty' = enrich_module_type anchor (Ident.name id) modl.mod_type newenv in (id, name, mty, modl, mty')) decls sbind in let bindings2 = check_recmodule_inclusion newenv bindings1 in let (str_rem, sig_rem, final_env) = type_struct newenv srem in (mkstr (Tstr_recmodule bindings2) loc :: str_rem, map_rec (fun rs (id, _, _, modl) -> Sig_module(id, modl.mod_type, rs)) bindings2 sig_rem, final_env) | Pstr_modtype(name, smty) -> check "module type" loc modtype_names name.txt; let mty = transl_modtype env smty in let (id, newenv) = Env.enter_modtype name.txt (Modtype_manifest mty.mty_type) env in let (str_rem, sig_rem, final_env) = type_struct newenv srem in (mkstr (Tstr_modtype(id, name, mty)) loc :: str_rem, Sig_modtype(id, Modtype_manifest mty.mty_type) :: sig_rem, final_env) | Pstr_open (lid) -> let (path, newenv) = type_open ~toplevel env loc lid in let (str_rem, sig_rem, final_env) = type_struct newenv srem in (mkstr (Tstr_open (path, lid)) loc :: str_rem, sig_rem, final_env) | Pstr_class cl -> List.iter (fun {pci_name = name} -> check "type" loc type_names name.txt) cl; let (classes, new_env) = Typeclass.class_declarations env cl in let (str_rem, sig_rem, final_env) = type_struct new_env srem in (mkstr (Tstr_class (List.map (fun (i, _, d, _,_,_,_,_,_, s, m, c) -> let vf = if d.cty_new = None then Virtual else Concrete in (* (i, s, m, c, vf) *) (c, m, vf)) classes)) loc :: (* TODO: check with Jacques why this is here Tstr_class_type (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) :: Tstr_type (List.map (fun (_,_,_,_, i, d, _,_,_,_,_) -> (i, d)) classes) :: Tstr_type (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) :: *) str_rem, List.flatten (map_rec (fun rs (i, _, d, i', d', i'', d'', i''', d''', _, _, _) -> [Sig_class(i, d, rs); Sig_class_type(i', d', rs); Sig_type(i'', d'', rs); Sig_type(i''', d''', rs)]) classes [sig_rem]), final_env) | Pstr_class_type cl -> List.iter (fun {pci_name = name} -> check "type" loc type_names name.txt) cl; let (classes, new_env) = Typeclass.class_type_declarations env cl in let (str_rem, sig_rem, final_env) = type_struct new_env srem in (mkstr (Tstr_class_type (List.map (fun (i, i_loc, d, _, _, _, _, c) -> (i, i_loc, c)) classes)) loc :: (* TODO: check with Jacques why this is here Tstr_type (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) :: Tstr_type (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *) str_rem, List.flatten (map_rec (fun rs (i, _, d, i', d', i'', d'', _) -> [Sig_class_type(i, d, rs); Sig_type(i', d', rs); Sig_type(i'', d'', rs)]) classes [sig_rem]), final_env) | Pstr_include smodl -> let modl = type_module true funct_body None env smodl in (* Rename all identifiers bound by this signature to avoid clashes *) let sg = Subst.signature Subst.identity (extract_sig_open env smodl.pmod_loc modl.mod_type) in List.iter (check_sig_item type_names module_names modtype_names loc) sg; let new_env = Env.add_signature sg env in let (str_rem, sig_rem, final_env) = type_struct new_env srem in (mkstr (Tstr_include (modl, bound_value_identifiers sg)) loc :: str_rem, sg @ sig_rem, final_env) in if !Clflags.annotations then (* moved to genannot *) List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr; let previous_saved_types = Cmt_format.get_saved_types () in let (items, sg, final_env) = type_struct env sstr in let str = { str_items = items; str_type = sg; str_final_env = final_env } in Cmt_format.set_saved_types (Cmt_format.Partial_structure str :: previous_saved_types); str, sg, final_env let type_toplevel_phrase env s = type_structure ~toplevel:true false None env s Location.none let type_module = type_module true false None let type_structure = type_structure false None (* Normalize types in a signature *) let rec normalize_modtype env = function Mty_ident p -> () | Mty_signature sg -> normalize_signature env sg | Mty_functor(id, param, body) -> normalize_modtype env body and normalize_signature env = List.iter (normalize_signature_item env) and normalize_signature_item env = function Sig_value(id, desc) -> Ctype.normalize_type env desc.val_type | Sig_module(id, mty, _) -> normalize_modtype env mty | _ -> () (* Simplify multiple specifications of a value or an exception in a signature. (Other signature components, e.g. types, modules, etc, are checked for name uniqueness.) If multiple specifications with the same name, keep only the last (rightmost) one. *) let rec simplify_modtype mty = match mty with Mty_ident path -> mty | Mty_functor(id, arg, res) -> Mty_functor(id, arg, simplify_modtype res) | Mty_signature sg -> Mty_signature(simplify_signature sg) and simplify_signature sg = let rec simplif val_names exn_names res = function [] -> res | (Sig_value(id, descr) as component) :: sg -> let name = Ident.name id in simplif (StringSet.add name val_names) exn_names (if StringSet.mem name val_names then res else component :: res) sg | (Sig_exception(id, decl) as component) :: sg -> let name = Ident.name id in simplif val_names (StringSet.add name exn_names) (if StringSet.mem name exn_names then res else component :: res) sg | Sig_module(id, mty, rs) :: sg -> simplif val_names exn_names (Sig_module(id, simplify_modtype mty, rs) :: res) sg | component :: sg -> simplif val_names exn_names (component :: res) sg in simplif StringSet.empty StringSet.empty [] (List.rev sg) (* Extract the module type of a module expression *) let type_module_type_of env smod = let tmty = match smod.pmod_desc with | Pmod_ident lid -> (* turn off strengthening in this case *) let (path, mty) = Typetexp.find_module env smod.pmod_loc lid.txt in rm { mod_desc = Tmod_ident (path, lid); mod_type = mty; mod_env = env; mod_loc = smod.pmod_loc } | _ -> type_module env smod in let mty = tmty.mod_type in (* PR#5037: clean up inferred signature to remove duplicate specs *) let mty = simplify_modtype mty in (* PR#5036: must not contain non-generalized type variables *) if not (closed_modtype mty) then raise(Error(smod.pmod_loc, Non_generalizable_module mty)); tmty, mty (* For Typecore *) let rec get_manifest_types = function [] -> [] | Sig_type (id, {type_params=[]; type_manifest=Some ty}, _) :: rem -> (Ident.name id, ty) :: get_manifest_types rem | _ :: rem -> get_manifest_types rem let type_package env m p nl tl = (* Same as Pexp_letmodule *) (* remember original level *) let lv = Ctype.get_current_level () in Ctype.begin_def (); Ident.set_current_time lv; let context = Typetexp.narrow () in let modl = type_module env m in Ctype.init_def(Ident.current_time()); Typetexp.widen context; let (mp, env) = match modl.mod_desc with Tmod_ident (mp,_) -> (mp, env) | _ -> let (id, new_env) = Env.enter_module "%M" modl.mod_type env in (Pident id, new_env) in let rec mkpath mp = function | Lident name -> Pdot(mp, name, nopos) | Ldot (m, name) -> Pdot(mkpath mp m, name, nopos) | _ -> assert false in let tl' = List.map (fun name -> Ctype.newconstr (mkpath mp name) []) nl in (* go back to original level *) Ctype.end_def (); if nl = [] then (wrap_constraint env modl (Mty_ident p) Tmodtype_implicit, []) else let mty = modtype_of_package env modl.mod_loc p nl tl' in List.iter2 (fun n ty -> try Ctype.unify env ty (Ctype.newvar ()) with Ctype.Unify _ -> raise (Error(m.pmod_loc, Scoping_pack (n,ty)))) nl tl'; (wrap_constraint env modl mty Tmodtype_implicit, tl') (* Fill in the forward declarations *) let () = Typecore.type_module := type_module; Typetexp.transl_modtype_longident := transl_modtype_longident; Typetexp.transl_modtype := transl_modtype; Typecore.type_open := type_open; Typecore.type_package := type_package; type_module_type_of_fwd := type_module_type_of (* Typecheck an implementation file *) let type_implementation sourcefile outputprefix modulename initial_env ast = Cmt_format.set_saved_types []; try Typecore.reset_delayed_checks (); let (str, sg, finalenv) = type_structure initial_env ast Location.none in let simple_sg = simplify_signature sg in if !Clflags.print_types then begin fprintf std_formatter "%a@." Printtyp.signature simple_sg; (str, Tcoerce_none) (* result is ignored by Compile.implementation *) end else begin let sourceintf = Misc.chop_extension_if_any sourcefile ^ !Config.interface_suffix in if Sys.file_exists sourceintf then begin let intf_file = try find_in_path_uncap !Config.load_path (modulename ^ ".cmi") with Not_found -> raise(Error(Location.none, Interface_not_compiled sourceintf)) in let dclsig = Env.read_signature modulename intf_file in let coercion = Includemod.compunit sourcefile sg intf_file dclsig in Typecore.force_delayed_checks (); (* It is important to run these checks after the inclusion test above, so that value declarations which are not used internally but exported are not reported as being unused. *) Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename (Cmt_format.Implementation str) (Some sourcefile) initial_env None; (str, coercion) end else begin check_nongen_schemes finalenv str.str_items; normalize_signature finalenv simple_sg; let coercion = Includemod.compunit sourcefile sg "(inferred signature)" simple_sg in Typecore.force_delayed_checks (); (* See comment above. Here the target signature contains all the value being exported. We can still capture unused declarations like "let x = true;; let x = 1;;", because in this case, the inferred signature contains only the last declaration. *) if not !Clflags.dont_write_files then begin let sg = Env.save_signature simple_sg modulename (outputprefix ^ ".cmi") in Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename (Cmt_format.Implementation str) (Some sourcefile) initial_env (Some sg); end; (str, coercion) end end with e -> Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename (Cmt_format.Partial_implementation (Array.of_list (Cmt_format.get_saved_types ()))) (Some sourcefile) initial_env None; raise e let save_signature modname tsg outputprefix source_file initial_env cmi = Cmt_format.save_cmt (outputprefix ^ ".cmti") modname (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi) (* "Packaging" of several compilation units into one unit having them as sub-modules. *) let rec package_signatures subst = function [] -> [] | (name, sg) :: rem -> let sg' = Subst.signature subst sg in let oldid = Ident.create_persistent name and newid = Ident.create name in Sig_module(newid, Mty_signature sg', Trec_not) :: package_signatures (Subst.add_module oldid (Pident newid) subst) rem let package_units objfiles cmifile modulename = (* Read the signatures of the units *) let units = List.map (fun f -> let pref = chop_extensions f in let modname = String.capitalize(Filename.basename pref) in let sg = Env.read_signature modname (pref ^ ".cmi") in if Filename.check_suffix f ".cmi" && not(Mtype.no_code_needed_sig Env.initial sg) then raise(Error(Location.none, Implementation_is_required f)); (modname, Env.read_signature modname (pref ^ ".cmi"))) objfiles in (* Compute signature of packaged unit *) Ident.reinit(); let sg = package_signatures Subst.identity units in (* See if explicit interface is provided *) let prefix = chop_extension_if_any cmifile in let mlifile = prefix ^ !Config.interface_suffix in if Sys.file_exists mlifile then begin if not (Sys.file_exists cmifile) then begin raise(Error(Location.in_file mlifile, Interface_not_compiled mlifile)) end; let dclsig = Env.read_signature modulename cmifile in Cmt_format.save_cmt (prefix ^ ".cmt") modulename (Cmt_format.Packed (sg, objfiles)) None Env.initial None ; Includemod.compunit "(obtained by packing)" sg mlifile dclsig end else begin (* Determine imports *) let unit_names = List.map fst units in let imports = List.filter (fun (name, crc) -> not (List.mem name unit_names)) (Env.imported_units()) in (* Write packaged signature *) if not !Clflags.dont_write_files then begin let sg = Env.save_signature_with_imports sg modulename (prefix ^ ".cmi") imports in Cmt_format.save_cmt (prefix ^ ".cmt") modulename (Cmt_format.Packed (sg, objfiles)) None Env.initial (Some sg) end; Tcoerce_none end (* Error report *) open Printtyp let report_error ppf = function Cannot_apply mty -> fprintf ppf "@[This module is not a functor; it has type@ %a@]" modtype mty | Not_included errs -> fprintf ppf "@[Signature mismatch:@ %a@]" Includemod.report_error errs | Cannot_eliminate_dependency mty -> fprintf ppf "@[This functor has type@ %a@ \ The parameter cannot be eliminated in the result type.@ \ Please bind the argument to a module identifier.@]" modtype mty | Signature_expected -> fprintf ppf "This module type is not a signature" | Structure_expected mty -> fprintf ppf "@[This module is not a structure; it has type@ %a" modtype mty | With_no_component lid -> fprintf ppf "@[The signature constrained by `with' has no component named %a@]" longident lid | With_mismatch(lid, explanation) -> fprintf ppf "@[\ @[In this `with' constraint, the new definition of %a@ \ does not match its original definition@ \ in the constrained signature:@]@ \ %a@]" longident lid Includemod.report_error explanation | Repeated_name(kind, name) -> fprintf ppf "@[Multiple definition of the %s name %s.@ \ Names must be unique in a given structure or signature.@]" kind name | Non_generalizable typ -> fprintf ppf "@[The type of this expression,@ %a,@ \ contains type variables that cannot be generalized@]" type_scheme typ | Non_generalizable_class (id, desc) -> fprintf ppf "@[The type of this class,@ %a,@ \ contains type variables that cannot be generalized@]" (class_declaration id) desc | Non_generalizable_module mty -> fprintf ppf "@[The type of this module,@ %a,@ \ contains type variables that cannot be generalized@]" modtype mty | Implementation_is_required intf_name -> fprintf ppf "@[The interface %a@ declares values, not just types.@ \ An implementation must be provided.@]" Location.print_filename intf_name | Interface_not_compiled intf_name -> fprintf ppf "@[Could not find the .cmi file for interface@ %a.@]" Location.print_filename intf_name | Not_allowed_in_functor_body -> fprintf ppf "This kind of expression is not allowed within the body of a functor." | With_need_typeconstr -> fprintf ppf "Only type constructors with identical parameters can be substituted." | Not_a_packed_module ty -> fprintf ppf "This expression is not a packed module. It has type@ %a" type_expr ty | Incomplete_packed_module ty -> fprintf ppf "The type of this packed module contains variables:@ %a" type_expr ty | Scoping_pack (lid, ty) -> fprintf ppf "The type %a in this module cannot be exported.@ " longident lid; fprintf ppf "Its type contains local dependencies:@ %a" type_expr ty mingw-ocaml/ocaml/typing/includeclass.ml0000644000175000017500000001015212124403242017773 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1997 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Inclusion checks for the class language *) open Types let class_types env cty1 cty2 = Ctype.match_class_types env cty1 cty2 let class_type_declarations env cty1 cty2 = Ctype.match_class_declarations env cty1.clty_params cty1.clty_type cty2.clty_params cty2.clty_type let class_declarations env cty1 cty2 = match cty1.cty_new, cty2.cty_new with None, Some _ -> [Ctype.CM_Virtual_class] | _ -> Ctype.match_class_declarations env cty1.cty_params cty1.cty_type cty2.cty_params cty2.cty_type open Format open Ctype (* let rec hide_params = function Tcty_fun ("*", _, cty) -> hide_params cty | cty -> cty *) let include_err ppf = function | CM_Virtual_class -> fprintf ppf "A class cannot be changed from virtual to concrete" | CM_Parameter_arity_mismatch (ls, lp) -> fprintf ppf "The classes do not have the same number of type parameters" | CM_Type_parameter_mismatch trace -> fprintf ppf "@[%a@]" (Printtyp.unification_error false trace (function ppf -> fprintf ppf "A type parameter has type")) (function ppf -> fprintf ppf "but is expected to have type") | CM_Class_type_mismatch (cty1, cty2) -> fprintf ppf "@[The class type@;<1 2>%a@ is not matched by the class type@;<1 2>%a@]" Printtyp.class_type cty1 Printtyp.class_type cty2 | CM_Parameter_mismatch trace -> fprintf ppf "@[%a@]" (Printtyp.unification_error false trace (function ppf -> fprintf ppf "A parameter has type")) (function ppf -> fprintf ppf "but is expected to have type") | CM_Val_type_mismatch (lab, trace) -> fprintf ppf "@[%a@]" (Printtyp.unification_error false trace (function ppf -> fprintf ppf "The instance variable %s@ has type" lab)) (function ppf -> fprintf ppf "but is expected to have type") | CM_Meth_type_mismatch (lab, trace) -> fprintf ppf "@[%a@]" (Printtyp.unification_error false trace (function ppf -> fprintf ppf "The method %s@ has type" lab)) (function ppf -> fprintf ppf "but is expected to have type") | CM_Non_mutable_value lab -> fprintf ppf "@[The non-mutable instance variable %s cannot become mutable@]" lab | CM_Non_concrete_value lab -> fprintf ppf "@[The virtual instance variable %s cannot become concrete@]" lab | CM_Missing_value lab -> fprintf ppf "@[The first class type has no instance variable %s@]" lab | CM_Missing_method lab -> fprintf ppf "@[The first class type has no method %s@]" lab | CM_Hide_public lab -> fprintf ppf "@[The public method %s cannot be hidden@]" lab | CM_Hide_virtual (k, lab) -> fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab | CM_Public_method lab -> fprintf ppf "@[The public method %s cannot become private" lab | CM_Virtual_method lab -> fprintf ppf "@[The virtual method %s cannot become concrete" lab | CM_Private_method lab -> fprintf ppf "The private method %s cannot become public" lab let report_error ppf = function | [] -> () | err :: errs -> let print_errs ppf errs = List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in fprintf ppf "@[%a%a@]" include_err err print_errs errs mingw-ocaml/ocaml/typing/includecore.mli0000644000175000017500000000330312124403242017767 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Inclusion checks for the core language *) open Typedtree open Types exception Dont_match type type_mismatch = Arity | Privacy | Kind | Constraint | Manifest | Variance | Field_type of Ident.t | Field_mutable of Ident.t | Field_arity of Ident.t | Field_names of int * Ident.t * Ident.t | Field_missing of bool * Ident.t | Record_representation of bool val value_descriptions: Env.t -> value_description -> value_description -> module_coercion val type_declarations: ?equality:bool -> Env.t -> string -> type_declaration -> Ident.t -> type_declaration -> type_mismatch list val exception_declarations: Env.t -> exception_declaration -> exception_declaration -> bool (* val class_types: Env.t -> class_type -> class_type -> bool *) val report_type_mismatch: string -> string -> string -> Format.formatter -> type_mismatch list -> unit mingw-ocaml/ocaml/typing/mtype.ml0000644000175000017500000001721712124403242016471 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Operations on module types *) open Asttypes open Path open Types let rec scrape env mty = match mty with Mty_ident p -> begin try scrape env (Env.find_modtype_expansion p env) with Not_found -> mty end | _ -> mty let freshen mty = Subst.modtype Subst.identity mty let rec strengthen env mty p = match scrape env mty with Mty_signature sg -> Mty_signature(strengthen_sig env sg p) | Mty_functor(param, arg, res) when !Clflags.applicative_functors -> Mty_functor(param, arg, strengthen env res (Papply(p, Pident param))) | mty -> mty and strengthen_sig env sg p = match sg with [] -> [] | (Sig_value(id, desc) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p | Sig_type(id, decl, rs) :: rem -> let newdecl = match decl.type_manifest, decl.type_private, decl.type_kind with Some _, Public, _ -> decl | Some _, Private, (Type_record _ | Type_variant _) -> decl | _ -> let manif = Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos), decl.type_params, ref Mnil))) in if decl.type_kind = Type_abstract then { decl with type_private = Public; type_manifest = manif } else { decl with type_manifest = manif } in Sig_type(id, newdecl, rs) :: strengthen_sig env rem p | (Sig_exception(id, d) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p | Sig_module(id, mty, rs) :: rem -> Sig_module(id, strengthen env mty (Pdot(p, Ident.name id, nopos)), rs) :: strengthen_sig (Env.add_module id mty env) rem p (* Need to add the module in case it defines manifest module types *) | Sig_modtype(id, decl) :: rem -> let newdecl = match decl with Modtype_abstract -> Modtype_manifest(Mty_ident(Pdot(p, Ident.name id, nopos))) | Modtype_manifest _ -> decl in Sig_modtype(id, newdecl) :: strengthen_sig (Env.add_modtype id decl env) rem p (* Need to add the module type in case it is manifest *) | (Sig_class(id, decl, rs) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p | (Sig_class_type(id, decl, rs) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p (* In nondep_supertype, env is only used for the type it assigns to id. Hence there is no need to keep env up-to-date by adding the bindings traversed. *) type variance = Co | Contra | Strict let nondep_supertype env mid mty = let rec nondep_mty env va mty = match mty with Mty_ident p -> if Path.isfree mid p then nondep_mty env va (Env.find_modtype_expansion p env) else mty | Mty_signature sg -> Mty_signature(nondep_sig env va sg) | Mty_functor(param, arg, res) -> let var_inv = match va with Co -> Contra | Contra -> Co | Strict -> Strict in Mty_functor(param, nondep_mty env var_inv arg, nondep_mty (Env.add_module param arg env) va res) and nondep_sig env va = function [] -> [] | item :: rem -> let rem' = nondep_sig env va rem in match item with Sig_value(id, d) -> Sig_value(id, {val_type = Ctype.nondep_type env mid d.val_type; val_kind = d.val_kind; val_loc = d.val_loc; }) :: rem' | Sig_type(id, d, rs) -> Sig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs) :: rem' | Sig_exception(id, d) -> let d = {exn_args = List.map (Ctype.nondep_type env mid) d.exn_args; exn_loc = d.exn_loc} in Sig_exception(id, d) :: rem' | Sig_module(id, mty, rs) -> Sig_module(id, nondep_mty env va mty, rs) :: rem' | Sig_modtype(id, d) -> begin try Sig_modtype(id, nondep_modtype_decl env d) :: rem' with Not_found -> match va with Co -> Sig_modtype(id, Modtype_abstract) :: rem' | _ -> raise Not_found end | Sig_class(id, d, rs) -> Sig_class(id, Ctype.nondep_class_declaration env mid d, rs) :: rem' | Sig_class_type(id, d, rs) -> Sig_class_type(id, Ctype.nondep_cltype_declaration env mid d, rs) :: rem' and nondep_modtype_decl env = function Modtype_abstract -> Modtype_abstract | Modtype_manifest mty -> Modtype_manifest(nondep_mty env Strict mty) in nondep_mty env Co mty let enrich_typedecl env p decl = match decl.type_manifest with Some ty -> decl | None -> try let orig_decl = Env.find_type p env in if orig_decl.type_arity <> decl.type_arity then decl else {decl with type_manifest = Some(Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil)))} with Not_found -> decl let rec enrich_modtype env p mty = match mty with Mty_signature sg -> Mty_signature(List.map (enrich_item env p) sg) | _ -> mty and enrich_item env p = function Sig_type(id, decl, rs) -> Sig_type(id, enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl, rs) | Sig_module(id, mty, rs) -> Sig_module(id, enrich_modtype env (Pdot(p, Ident.name id, nopos)) mty, rs) | item -> item let rec type_paths env p mty = match scrape env mty with Mty_ident p -> [] | Mty_signature sg -> type_paths_sig env p 0 sg | Mty_functor(param, arg, res) -> [] and type_paths_sig env p pos sg = match sg with [] -> [] | Sig_value(id, decl) :: rem -> let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in type_paths_sig env p pos' rem | Sig_type(id, decl, _) :: rem -> Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem | Sig_module(id, mty, _) :: rem -> type_paths env (Pdot(p, Ident.name id, pos)) mty @ type_paths_sig (Env.add_module id mty env) p (pos+1) rem | Sig_modtype(id, decl) :: rem -> type_paths_sig (Env.add_modtype id decl env) p pos rem | (Sig_exception _ | Sig_class _) :: rem -> type_paths_sig env p (pos+1) rem | (Sig_class_type _) :: rem -> type_paths_sig env p pos rem let rec no_code_needed env mty = match scrape env mty with Mty_ident p -> false | Mty_signature sg -> no_code_needed_sig env sg | Mty_functor(_, _, _) -> false and no_code_needed_sig env sg = match sg with [] -> true | Sig_value(id, decl) :: rem -> begin match decl.val_kind with | Val_prim _ -> no_code_needed_sig env rem | _ -> false end | Sig_module(id, mty, _) :: rem -> no_code_needed env mty && no_code_needed_sig (Env.add_module id mty env) rem | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem -> no_code_needed_sig env rem | (Sig_exception _ | Sig_class _) :: rem -> false mingw-ocaml/ocaml/typing/primitive.mli0000644000175000017500000000261712124403242017512 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Description of primitive functions *) type description = { prim_name: string; (* Name of primitive or C function *) prim_arity: int; (* Number of arguments *) prim_alloc: bool; (* Does it allocates or raise? *) prim_native_name: string; (* Name of C function for the nat. code gen. *) prim_native_float: bool } (* Does the above operate on unboxed floats? *) val parse_declaration: int -> string list -> description val description_list: description -> string list val native_name: description -> string val byte_name: description -> string mingw-ocaml/ocaml/typing/datarepr.ml0000644000175000017500000001161312124403242017127 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Compute constructor and label descriptions from type declarations, determining their representation. *) open Misc open Asttypes open Types open Btype (* Simplified version of Ctype.free_vars *) let rec free_vars ty = let ret = ref TypeSet.empty in let rec loop ty = let ty = repr ty in if ty.level >= lowest_level then begin ty.level <- pivot_level - ty.level; match ty.desc with | Tvar _ -> ret := TypeSet.add ty !ret | Tvariant row -> let row = row_repr row in iter_row loop row; if not (static_row row) then loop row.row_more | _ -> iter_type_expr loop ty end in loop ty; unmark_type ty; !ret let constructor_descrs ty_res cstrs priv = let num_consts = ref 0 and num_nonconsts = ref 0 and num_normal = ref 0 in List.iter (fun (name, args, ret) -> if args = [] then incr num_consts else incr num_nonconsts; if ret = None then incr num_normal) cstrs; let rec describe_constructors idx_const idx_nonconst = function [] -> [] | (name, ty_args, ty_res_opt) :: rem -> let ty_res = match ty_res_opt with | Some ty_res' -> ty_res' | None -> ty_res in let (tag, descr_rem) = match ty_args with [] -> (Cstr_constant idx_const, describe_constructors (idx_const+1) idx_nonconst rem) | _ -> (Cstr_block idx_nonconst, describe_constructors idx_const (idx_nonconst+1) rem) in let existentials = match ty_res_opt with | None -> [] | Some type_ret -> let res_vars = free_vars type_ret in let arg_vars = free_vars (newgenty (Ttuple ty_args)) in TypeSet.elements (TypeSet.diff arg_vars res_vars) in let cstr = { cstr_res = ty_res; cstr_existentials = existentials; cstr_args = ty_args; cstr_arity = List.length ty_args; cstr_tag = tag; cstr_consts = !num_consts; cstr_nonconsts = !num_nonconsts; cstr_normal = !num_normal; cstr_private = priv; cstr_generalized = ty_res_opt <> None } in (name, cstr) :: descr_rem in describe_constructors 0 0 cstrs let exception_descr path_exc decl = { cstr_res = Predef.type_exn; cstr_existentials = []; cstr_args = decl.exn_args; cstr_arity = List.length decl.exn_args; cstr_tag = Cstr_exception (path_exc, decl.exn_loc); cstr_consts = -1; cstr_nonconsts = -1; cstr_private = Public; cstr_normal = -1; cstr_generalized = false } let none = {desc = Ttuple []; level = -1; id = -1} (* Clearly ill-formed type *) let dummy_label = { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular; lbl_private = Public } let label_descrs ty_res lbls repres priv = let all_labels = Array.create (List.length lbls) dummy_label in let rec describe_labels num = function [] -> [] | (name, mut_flag, ty_arg) :: rest -> let lbl = { lbl_name = Ident.name name; lbl_res = ty_res; lbl_arg = ty_arg; lbl_mut = mut_flag; lbl_pos = num; lbl_all = all_labels; lbl_repres = repres; lbl_private = priv } in all_labels.(num) <- lbl; (name, lbl) :: describe_labels (num+1) rest in describe_labels 0 lbls exception Constr_not_found let rec find_constr tag num_const num_nonconst = function [] -> raise Constr_not_found | (name, ([] as cstr),(_ as ret_type_opt)) :: rem -> if tag = Cstr_constant num_const then (name,cstr,ret_type_opt) else find_constr tag (num_const + 1) num_nonconst rem | (name, (_ as cstr),(_ as ret_type_opt)) :: rem -> if tag = Cstr_block num_nonconst then (name,cstr,ret_type_opt) else find_constr tag num_const (num_nonconst + 1) rem let find_constr_by_tag tag cstrlist = find_constr tag 0 0 cstrlist mingw-ocaml/ocaml/typing/includemod.mli0000644000175000017500000000425412124403242017624 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Inclusion checks for the module language *) open Typedtree open Types open Format val modtypes: Env.t -> module_type -> module_type -> module_coercion val signatures: Env.t -> signature -> signature -> module_coercion val compunit: string -> signature -> string -> signature -> module_coercion val type_declarations: Env.t -> Ident.t -> type_declaration -> type_declaration -> unit type symptom = Missing_field of Ident.t | Value_descriptions of Ident.t * value_description * value_description | Type_declarations of Ident.t * type_declaration * type_declaration * Includecore.type_mismatch list | Exception_declarations of Ident.t * exception_declaration * exception_declaration | Module_types of module_type * module_type | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration | Modtype_permutation | Interface_mismatch of string * string | Class_type_declarations of Ident.t * class_type_declaration * class_type_declaration * Ctype.class_match_failure list | Class_declarations of Ident.t * class_declaration * class_declaration * Ctype.class_match_failure list | Unbound_modtype_path of Path.t type pos = Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t type error = pos list * symptom exception Error of error list val report_error: formatter -> error list -> unit mingw-ocaml/ocaml/typing/env.mli0000644000175000017500000002017612124403242016272 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Environment handling *) open Types type summary = Env_empty | Env_value of summary * Ident.t * value_description | Env_type of summary * Ident.t * type_declaration | Env_exception of summary * Ident.t * exception_declaration | Env_module of summary * Ident.t * module_type | Env_modtype of summary * Ident.t * modtype_declaration | Env_class of summary * Ident.t * class_declaration | Env_cltype of summary * Ident.t * class_type_declaration | Env_open of summary * Path.t type t val empty: t val initial: t val diff: t -> t -> Ident.t list (* Lookup by paths *) val find_value: Path.t -> t -> value_description val find_annot: Path.t -> t -> Annot.ident val find_type: Path.t -> t -> type_declaration val find_constructors: Path.t -> t -> constructor_description list val find_module: Path.t -> t -> module_type val find_modtype: Path.t -> t -> modtype_declaration val find_class: Path.t -> t -> class_declaration val find_cltype: Path.t -> t -> class_type_declaration val find_type_expansion: ?level:int -> Path.t -> t -> type_expr list * type_expr * int option val find_type_expansion_opt: Path.t -> t -> type_expr list * type_expr * int option (* Find the manifest type information associated to a type for the sake of the compiler's type-based optimisations. *) val find_modtype_expansion: Path.t -> t -> Types.module_type val has_local_constraints: t -> bool val add_gadt_instance_level: int -> t -> t val gadt_instance_level: t -> type_expr -> int option val add_gadt_instances: t -> int -> type_expr list -> unit val add_gadt_instance_chain: t -> int -> type_expr -> unit (* Lookup by long identifiers *) val lookup_value: Longident.t -> t -> Path.t * value_description val lookup_annot: Longident.t -> t -> Path.t * Annot.ident val lookup_constructor: Longident.t -> t -> Path.t * constructor_description val lookup_label: Longident.t -> t -> Path.t * label_description val lookup_type: Longident.t -> t -> Path.t * type_declaration val lookup_module: Longident.t -> t -> Path.t * module_type val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration val lookup_class: Longident.t -> t -> Path.t * class_declaration val lookup_cltype: Longident.t -> t -> Path.t * class_type_declaration (* Insertion by identifier *) val add_value: ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t val add_annot: Ident.t -> Annot.ident -> t -> t val add_type: Ident.t -> type_declaration -> t -> t val add_exception: Ident.t -> exception_declaration -> t -> t val add_module: Ident.t -> module_type -> t -> t val add_modtype: Ident.t -> modtype_declaration -> t -> t val add_class: Ident.t -> class_declaration -> t -> t val add_cltype: Ident.t -> class_type_declaration -> t -> t val add_local_constraint: Ident.t -> type_declaration -> int -> t -> t (* Insertion of all fields of a signature. *) val add_item: signature_item -> t -> t val add_signature: signature -> t -> t (* Insertion of all fields of a signature, relative to the given path. Used to implement open. *) val open_signature: ?loc:Location.t -> ?toplevel:bool -> Path.t -> signature -> t -> t val open_pers_signature: string -> t -> t (* Insertion by name *) val enter_value: ?check:(string -> Warnings.t) -> string -> value_description -> t -> Ident.t * t val enter_type: string -> type_declaration -> t -> Ident.t * t val enter_exception: string -> exception_declaration -> t -> Ident.t * t val enter_module: string -> module_type -> t -> Ident.t * t val enter_modtype: string -> modtype_declaration -> t -> Ident.t * t val enter_class: string -> class_declaration -> t -> Ident.t * t val enter_cltype: string -> class_type_declaration -> t -> Ident.t * t (* Initialize the cache of in-core module interfaces. *) val reset_cache: unit -> unit val reset_missing_cmis: unit -> unit (* Remember the name of the current compilation unit. *) val set_unit_name: string -> unit (* Read, save a signature to/from a file *) val read_signature: string -> string -> signature (* Arguments: module name, file name. Results: signature. *) val save_signature: signature -> string -> string -> signature (* Arguments: signature, module name, file name. *) val save_signature_with_imports: signature -> string -> string -> (string * Digest.t) list -> signature (* Arguments: signature, module name, file name, imported units with their CRCs. *) (* Return the CRC of the interface of the given compilation unit *) val crc_of_unit: string -> Digest.t (* Return the set of compilation units imported, with their CRC *) val imported_units: unit -> (string * Digest.t) list (* Direct access to the table of imported compilation units with their CRC *) val crc_units: Consistbl.t (* Summaries -- compact representation of an environment, to be exported in debugging information. *) val summary: t -> summary (* Return an equivalent environment where all fields have been reset, except the summary. The initial environment can be rebuilt from the summary, using Envaux.env_of_only_summary. *) val keep_only_summary : t -> t val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t (* Error report *) type error = | Illegal_renaming of string * string | Inconsistent_import of string * string * string | Need_recursive_types of string * string exception Error of error open Format val report_error: formatter -> error -> unit val mark_value_used: string -> value_description -> unit val mark_type_used: string -> type_declaration -> unit type constructor_usage = Positive | Pattern | Privatize val mark_constructor_used: constructor_usage -> string -> type_declaration -> string -> unit val mark_constructor: constructor_usage -> t -> string -> constructor_description -> unit val mark_exception_used: constructor_usage -> exception_declaration -> string -> unit val in_signature: t -> t val set_value_used_callback: string -> value_description -> (unit -> unit) -> unit val set_type_used_callback: string -> type_declaration -> ((unit -> unit) -> unit) -> unit (* Forward declaration to break mutual recursion with Includemod. *) val check_modtype_inclusion: (t -> module_type -> Path.t -> module_type -> unit) ref (* Forward declaration to break mutual recursion with Typecore. *) val add_delayed_check_forward: ((unit -> unit) -> unit) ref (** Folding over all identifiers (for analysis purpose) *) val fold_values: (string -> Path.t -> Types.value_description -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a val fold_types: (string -> Path.t -> Types.type_declaration -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a val fold_constructors: (string -> Path.t -> Types.constructor_description -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a val fold_labels: (string -> Path.t -> Types.label_description -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a (** Persistent structures are only traversed if they are already loaded. *) val fold_modules: (string -> Path.t -> Types.module_type -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a val fold_modtypes: (string -> Path.t -> Types.modtype_declaration -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a val fold_classs: (string -> Path.t -> Types.class_declaration -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a val fold_cltypes: (string -> Path.t -> Types.class_type_declaration -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a mingw-ocaml/ocaml/typing/includecore.ml0000644000175000017500000002523112124403242017622 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Inclusion checks for the core language *) open Misc open Asttypes open Path open Types open Typedtree (* Inclusion between value descriptions *) exception Dont_match let value_descriptions env vd1 vd2 = if Ctype.moregeneral env true vd1.val_type vd2.val_type then begin match (vd1.val_kind, vd2.val_kind) with (Val_prim p1, Val_prim p2) -> if p1 = p2 then Tcoerce_none else raise Dont_match | (Val_prim p, _) -> Tcoerce_primitive p | (_, Val_prim p) -> raise Dont_match | (_, _) -> Tcoerce_none end else raise Dont_match (* Inclusion between "private" annotations *) let private_flags decl1 decl2 = match decl1.type_private, decl2.type_private with | Private, Public -> decl2.type_kind = Type_abstract && (decl2.type_manifest = None || decl1.type_kind <> Type_abstract) | _, _ -> true (* Inclusion between manifest types (particularly for private row types) *) let is_absrow env ty = match ty.desc with Tconstr(Pident id, _, _) -> begin match Ctype.expand_head env ty with {desc=Tobject _|Tvariant _} -> true | _ -> false end | _ -> false let type_manifest env ty1 params1 ty2 params2 priv2 = let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in match ty1'.desc, ty2'.desc with Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) -> let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in Ctype.equal env true (ty1::params1) (row2.row_more::params2) && begin match row1.row_more with {desc=Tvar _|Tconstr _|Tnil} -> true | _ -> false end && let r1, r2, pairs = Ctype.merge_row_fields row1.row_fields row2.row_fields in (not row2.row_closed || row1.row_closed && Ctype.filter_row_fields false r1 = []) && List.for_all (fun (_,f) -> match Btype.row_field_repr f with Rabsent | Reither _ -> true | Rpresent _ -> false) r2 && let to_equal = ref (List.combine params1 params2) in List.for_all (fun (_, f1, f2) -> match Btype.row_field_repr f1, Btype.row_field_repr f2 with Rpresent(Some t1), (Rpresent(Some t2) | Reither(false, [t2], _, _)) -> to_equal := (t1,t2) :: !to_equal; true | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_) when List.length tl1 = List.length tl2 && c1 = c2 -> to_equal := List.combine tl1 tl2 @ !to_equal; true | Rabsent, (Reither _ | Rabsent) -> true | _ -> false) pairs && let tl1, tl2 = List.split !to_equal in Ctype.equal env true tl1 tl2 | Tobject (fi1, _), Tobject (fi2, _) when is_absrow env (snd(Ctype.flatten_fields fi2)) -> let (fields2,rest2) = Ctype.flatten_fields fi2 in Ctype.equal env true (ty1::params1) (rest2::params2) && let (fields1,rest1) = Ctype.flatten_fields fi1 in (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) && let pairs, miss1, miss2 = Ctype.associate_fields fields1 fields2 in miss2 = [] && let tl1, tl2 = List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in Ctype.equal env true (params1 @ tl1) (params2 @ tl2) | _ -> let rec check_super ty1 = Ctype.equal env true (ty1 :: params1) (ty2 :: params2) || priv2 = Private && try check_super (Ctype.try_expand_once_opt env (Ctype.expand_head env ty1)) with Ctype.Cannot_expand -> false in check_super ty1 (* Inclusion between type declarations *) type type_mismatch = Arity | Privacy | Kind | Constraint | Manifest | Variance | Field_type of Ident.t | Field_mutable of Ident.t | Field_arity of Ident.t | Field_names of int * Ident.t * Ident.t | Field_missing of bool * Ident.t | Record_representation of bool let nth n = if n = 1 then "first" else if n = 2 then "2nd" else if n = 3 then "3rd" else string_of_int n ^ "th" let report_type_mismatch0 first second decl ppf err = let pr fmt = Format.fprintf ppf fmt in match err with Arity -> pr "They have different arities" | Privacy -> pr "A private type would be revealed" | Kind -> pr "Their kinds differ" | Constraint -> pr "Their constraints differ" | Manifest -> () | Variance -> pr "Their variances do not agree" | Field_type s -> pr "The types for field %s are not equal" (Ident.name s) | Field_mutable s -> pr "The mutability of field %s is different" (Ident.name s) | Field_arity s -> pr "The arities for field %s differ" (Ident.name s) | Field_names (n, name1, name2) -> pr "Their %s fields have different names, %s and %s" (nth n) (Ident.name name1) (Ident.name name2) | Field_missing (b, s) -> pr "The field %s is only present in %s %s" (Ident.name s) (if b then second else first) decl | Record_representation b -> pr "Their internal representations differ:@ %s %s %s" (if b then second else first) decl "uses unboxed float representation" let report_type_mismatch first second decl ppf = List.iter (fun err -> if err = Manifest then () else Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err) let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 = match cstrs1, cstrs2 with [], [] -> [] | [], (cstr2,_,_)::_ -> [Field_missing (true, cstr2)] | (cstr1,_,_)::_, [] -> [Field_missing (false, cstr1)] | (cstr1, arg1, ret1)::rem1, (cstr2, arg2,ret2)::rem2 -> if Ident.name cstr1 <> Ident.name cstr2 then [Field_names (n, cstr1, cstr2)] else if List.length arg1 <> List.length arg2 then [Field_arity cstr1] else match ret1, ret2 with | Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> [Field_type cstr1] | Some _, None | None, Some _ -> [Field_type cstr1] | _ -> if Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env true (ty1::decl1.type_params) (ty2::decl2.type_params)) (arg1) (arg2) then compare_variants env decl1 decl2 (n+1) rem1 rem2 else [Field_type cstr1] let rec compare_records env decl1 decl2 n labels1 labels2 = match labels1, labels2 with [], [] -> [] | [], (lab2,_,_)::_ -> [Field_missing (true, lab2)] | (lab1,_,_)::_, [] -> [Field_missing (false, lab1)] | (lab1, mut1, arg1)::rem1, (lab2, mut2, arg2)::rem2 -> if Ident.name lab1 <> Ident.name lab2 then [Field_names (n, lab1, lab2)] else if mut1 <> mut2 then [Field_mutable lab1] else if Ctype.equal env true (arg1::decl1.type_params) (arg2::decl2.type_params) then compare_records env decl1 decl2 (n+1) rem1 rem2 else [Field_type lab1] let type_declarations ?(equality = false) env name decl1 id decl2 = if decl1.type_arity <> decl2.type_arity then [Arity] else if not (private_flags decl1 decl2) then [Privacy] else let err = match (decl1.type_kind, decl2.type_kind) with (_, Type_abstract) -> [] | (Type_variant cstrs1, Type_variant cstrs2) -> let mark cstrs usage name decl = List.iter (fun (c, _, _) -> Env.mark_constructor_used usage name decl (Ident.name c)) cstrs in let usage = if decl1.type_private = Private || decl2.type_private = Public then Env.Positive else Env.Privatize in mark cstrs1 usage name decl1; if equality then mark cstrs2 Env.Positive (Ident.name id) decl2; compare_variants env decl1 decl2 1 cstrs1 cstrs2 | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> let err = compare_records env decl1 decl2 1 labels1 labels2 in if err <> [] || rep1 = rep2 then err else [Record_representation (rep2 = Record_float)] | (_, _) -> [Kind] in if err <> [] then err else let err = match (decl1.type_manifest, decl2.type_manifest) with (_, None) -> if Ctype.equal env true decl1.type_params decl2.type_params then [] else [Constraint] | (Some ty1, Some ty2) -> if type_manifest env ty1 decl1.type_params ty2 decl2.type_params decl2.type_private then [] else [Manifest] | (None, Some ty2) -> let ty1 = Btype.newgenty (Tconstr(Pident id, decl2.type_params, ref Mnil)) in if Ctype.equal env true decl1.type_params decl2.type_params then if Ctype.equal env false [ty1] [ty2] then [] else [Manifest] else [Constraint] in if err <> [] then err else if match decl2.type_kind with | Type_record (_,_) | Type_variant _ -> decl2.type_private = Private | Type_abstract -> match decl2.type_manifest with | None -> true | Some ty -> Btype.has_constr_row (Ctype.expand_head env ty) then if List.for_all2 (fun (co1,cn1,ct1) (co2,cn2,ct2) -> (not co1 || co2)&&(not cn1 || cn2)) decl1.type_variance decl2.type_variance then [] else [Variance] else [] (* Inclusion between exception declarations *) let exception_declarations env ed1 ed2 = Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env false [ty1] [ty2]) ed1.exn_args ed2.exn_args (* Inclusion between class types *) let encode_val (mut, ty) rem = begin match mut with Asttypes.Mutable -> Predef.type_unit | Asttypes.Immutable -> Btype.newgenvar () end ::ty::rem let meths meths1 meths2 = Meths.fold (fun nam t2 (ml1, ml2) -> (begin try Meths.find nam meths1 :: ml1 with Not_found -> ml1 end, t2 :: ml2)) meths2 ([], []) let vars vars1 vars2 = Vars.fold (fun lab v2 (vl1, vl2) -> (begin try encode_val (Vars.find lab vars1) vl1 with Not_found -> vl1 end, encode_val v2 vl2)) vars2 ([], []) mingw-ocaml/ocaml/typing/env.ml0000644000175000017500000013003312124403242016113 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Environment handling *) open Cmi_format open Config open Misc open Asttypes open Longident open Path open Types open Btype let add_delayed_check_forward = ref (fun _ -> assert false) let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t = Hashtbl.create 16 (* This table is used to usage of value declarations. A declaration is identified with its name and location. The callback attached to a declaration is called whenever the value is used explicitly (lookup_value) or implicitly (inclusion test between signatures, cf Includemod.value_descriptions). *) let type_declarations = Hashtbl.create 16 type constructor_usage = Positive | Pattern | Privatize type constructor_usages = { mutable cu_positive: bool; mutable cu_pattern: bool; mutable cu_privatize: bool; } let add_constructor_usage cu = function | Positive -> cu.cu_positive <- true | Pattern -> cu.cu_pattern <- true | Privatize -> cu.cu_privatize <- true let constructor_usages () = {cu_positive = false; cu_pattern = false; cu_privatize = false} let used_constructors : (string * Location.t * string, (constructor_usage -> unit)) Hashtbl.t = Hashtbl.create 16 type error = | Illegal_renaming of string * string | Inconsistent_import of string * string * string | Need_recursive_types of string * string exception Error of error module EnvLazy : sig type ('a,'b) t val force : ('a -> 'b) -> ('a,'b) t -> 'b val create : 'a -> ('a,'b) t end = struct type ('a,'b) t = ('a,'b) eval ref and ('a,'b) eval = Done of 'b | Raise of exn | Thunk of 'a let force f x = match !x with Done x -> x | Raise e -> raise e | Thunk e -> try let y = f e in x := Done y; y with e -> x := Raise e; raise e let create x = let x = ref (Thunk x) in x end type summary = Env_empty | Env_value of summary * Ident.t * value_description | Env_type of summary * Ident.t * type_declaration | Env_exception of summary * Ident.t * exception_declaration | Env_module of summary * Ident.t * module_type | Env_modtype of summary * Ident.t * modtype_declaration | Env_class of summary * Ident.t * class_declaration | Env_cltype of summary * Ident.t * class_type_declaration | Env_open of summary * Path.t module EnvTbl = struct (* A table indexed by identifier, with an extra slot to record usage. *) type 'a t = ('a * bool ref) Ident.tbl let empty = Ident.empty let current_slot = ref (ref true) let add id x tbl = Ident.add id (x, !current_slot) tbl let find_same_not_using id tbl = fst (Ident.find_same id tbl) let find_same id tbl = let (x, slot) = Ident.find_same id tbl in slot := true; x let find_name s tbl = let (x, slot) = Ident.find_name s tbl in slot := true; x let with_slot slot f x = let old_slot = !current_slot in current_slot := slot; try_finally (fun () -> f x) (fun () -> current_slot := old_slot) let keys tbl = Ident.keys tbl end type t = { values: (Path.t * value_description) EnvTbl.t; annotations: (Path.t * Annot.ident) EnvTbl.t; constrs: (Path.t * constructor_description) EnvTbl.t; labels: (Path.t * label_description) EnvTbl.t; constrs_by_path: (Path.t * (constructor_description list)) EnvTbl.t; types: (Path.t * type_declaration) EnvTbl.t; modules: (Path.t * module_type) EnvTbl.t; modtypes: (Path.t * modtype_declaration) EnvTbl.t; components: (Path.t * module_components) EnvTbl.t; classes: (Path.t * class_declaration) EnvTbl.t; cltypes: (Path.t * class_type_declaration) EnvTbl.t; summary: summary; local_constraints: bool; gadt_instances: (int * TypeSet.t ref) list; in_signature: bool; } and module_components = (t * Subst.t * Path.t * Types.module_type, module_components_repr) EnvLazy.t and module_components_repr = Structure_comps of structure_components | Functor_comps of functor_components and structure_components = { mutable comp_values: (string, (value_description * int)) Tbl.t; mutable comp_annotations: (string, (Annot.ident * int)) Tbl.t; mutable comp_constrs: (string, (constructor_description * int)) Tbl.t; mutable comp_labels: (string, (label_description * int)) Tbl.t; mutable comp_constrs_by_path: (string, (constructor_description list * int)) Tbl.t; mutable comp_types: (string, (type_declaration * int)) Tbl.t; mutable comp_modules: (string, ((Subst.t * Types.module_type,module_type) EnvLazy.t * int)) Tbl.t; mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t; mutable comp_components: (string, (module_components * int)) Tbl.t; mutable comp_classes: (string, (class_declaration * int)) Tbl.t; mutable comp_cltypes: (string, (class_type_declaration * int)) Tbl.t } and functor_components = { fcomp_param: Ident.t; (* Formal parameter *) fcomp_arg: module_type; (* Argument signature *) fcomp_res: module_type; (* Result signature *) fcomp_env: t; (* Environment in which the result signature makes sense *) fcomp_subst: Subst.t; (* Prefixing substitution for the result signature *) fcomp_cache: (Path.t, module_components) Hashtbl.t (* For memoization *) } let subst_modtype_maker (subst, mty) = Subst.modtype subst mty let empty = { values = EnvTbl.empty; annotations = EnvTbl.empty; constrs = EnvTbl.empty; labels = EnvTbl.empty; types = EnvTbl.empty; constrs_by_path = EnvTbl.empty; modules = EnvTbl.empty; modtypes = EnvTbl.empty; components = EnvTbl.empty; classes = EnvTbl.empty; cltypes = EnvTbl.empty; summary = Env_empty; local_constraints = false; gadt_instances = []; in_signature = false; } let in_signature env = {env with in_signature = true} let diff_keys is_local tbl1 tbl2 = let keys2 = EnvTbl.keys tbl2 in List.filter (fun id -> is_local (EnvTbl.find_same_not_using id tbl2) && try ignore (EnvTbl.find_same_not_using id tbl1); false with Not_found -> true) keys2 let is_ident = function Pident _ -> true | Pdot _ | Papply _ -> false let is_local (p, _) = is_ident p let diff env1 env2 = diff_keys is_local env1.values env2.values @ diff_keys is_local env1.constrs env2.constrs @ diff_keys is_local env1.modules env2.modules @ diff_keys is_local env1.classes env2.classes (* Forward declarations *) let components_of_module' = ref ((fun env sub path mty -> assert false) : t -> Subst.t -> Path.t -> module_type -> module_components) let components_of_module_maker' = ref ((fun (env, sub, path, mty) -> assert false) : t * Subst.t * Path.t * module_type -> module_components_repr) let components_of_functor_appl' = ref ((fun f p1 p2 -> assert false) : functor_components -> Path.t -> Path.t -> module_components) let check_modtype_inclusion = (* to be filled with Includemod.check_modtype_inclusion *) ref ((fun env mty1 path1 mty2 -> assert false) : t -> module_type -> Path.t -> module_type -> unit) (* The name of the compilation unit currently compiled. "" if outside a compilation unit. *) let current_unit = ref "" (* Persistent structure descriptions *) type pers_struct = { ps_name: string; ps_sig: signature; ps_comps: module_components; ps_crcs: (string * Digest.t) list; ps_filename: string; ps_flags: pers_flags list } let persistent_structures = (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t) (* Consistency between persistent structures *) let crc_units = Consistbl.create() let check_consistency filename crcs = try List.iter (fun (name, crc) -> Consistbl.check crc_units name crc filename) crcs with Consistbl.Inconsistency(name, source, auth) -> raise(Error(Inconsistent_import(name, auth, source))) (* Reading persistent structures from .cmi files *) let read_pers_struct modname filename = let cmi = read_cmi filename in let name = cmi.cmi_name in let sign = cmi.cmi_sign in let crcs = cmi.cmi_crcs in let flags = cmi.cmi_flags in let comps = !components_of_module' empty Subst.identity (Pident(Ident.create_persistent name)) (Mty_signature sign) in let ps = { ps_name = name; ps_sig = sign; ps_comps = comps; ps_crcs = crcs; ps_filename = filename; ps_flags = flags } in if ps.ps_name <> modname then raise(Error(Illegal_renaming(ps.ps_name, filename))); check_consistency filename ps.ps_crcs; List.iter (function Rectypes -> if not !Clflags.recursive_types then raise(Error(Need_recursive_types(ps.ps_name, !current_unit)))) ps.ps_flags; Hashtbl.add persistent_structures modname (Some ps); ps let find_pers_struct name = if name = "*predef*" then raise Not_found; let r = try Some (Hashtbl.find persistent_structures name) with Not_found -> None in match r with | Some None -> raise Not_found | Some (Some sg) -> sg | None -> let filename = try find_in_path_uncap !load_path (name ^ ".cmi") with Not_found -> Hashtbl.add persistent_structures name None; raise Not_found in read_pers_struct name filename let reset_cache () = current_unit := ""; Hashtbl.clear persistent_structures; Consistbl.clear crc_units; Hashtbl.clear value_declarations; Hashtbl.clear type_declarations let reset_missing_cmis () = let l = Hashtbl.fold (fun name r acc -> if r = None then name :: acc else acc) persistent_structures [] in List.iter (Hashtbl.remove persistent_structures) l let set_unit_name name = current_unit := name (* Lookup by identifier *) let rec find_module_descr path env = match path with Pident id -> begin try let (p, desc) = EnvTbl.find_same id env.components in desc with Not_found -> if Ident.persistent id then (find_pers_struct (Ident.name id)).ps_comps else raise Not_found end | Pdot(p, s, pos) -> begin match EnvLazy.force !components_of_module_maker' (find_module_descr p env) with Structure_comps c -> let (descr, pos) = Tbl.find s c.comp_components in descr | Functor_comps f -> raise Not_found end | Papply(p1, p2) -> begin match EnvLazy.force !components_of_module_maker' (find_module_descr p1 env) with Functor_comps f -> !components_of_functor_appl' f p1 p2 | Structure_comps c -> raise Not_found end let find proj1 proj2 path env = match path with Pident id -> let (p, data) = EnvTbl.find_same id (proj1 env) in data | Pdot(p, s, pos) -> begin match EnvLazy.force !components_of_module_maker' (find_module_descr p env) with Structure_comps c -> let (data, pos) = Tbl.find s (proj2 c) in data | Functor_comps f -> raise Not_found end | Papply(p1, p2) -> raise Not_found let find_value = find (fun env -> env.values) (fun sc -> sc.comp_values) and find_annot = find (fun env -> env.annotations) (fun sc -> sc.comp_annotations) and find_type = find (fun env -> env.types) (fun sc -> sc.comp_types) and find_constructors = find (fun env -> env.constrs_by_path) (fun sc -> sc.comp_constrs_by_path) and find_modtype = find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) and find_class = find (fun env -> env.classes) (fun sc -> sc.comp_classes) and find_cltype = find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) (* Find the manifest type associated to a type when appropriate: - the type should be public or should have a private row, - the type should have an associated manifest type. *) let find_type_expansion ?level path env = let decl = find_type path env in match decl.type_manifest with | Some body when decl.type_private = Public || decl.type_kind <> Type_abstract || Btype.has_constr_row body -> (decl.type_params, body, may_map snd decl.type_newtype_level) (* The manifest type of Private abstract data types without private row are still considered unknown to the type system. Hence, this case is caught by the following clause that also handles purely abstract data types without manifest type definition. *) | _ -> raise Not_found (* Find the manifest type information associated to a type, i.e. the necessary information for the compiler's type-based optimisations. In particular, the manifest type associated to a private abstract type is revealed for the sake of compiler's type-based optimisations. *) let find_type_expansion_opt path env = let decl = find_type path env in match decl.type_manifest with (* The manifest type of Private abstract data types can still get an approximation using their manifest type. *) | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level) | _ -> raise Not_found let find_modtype_expansion path env = match find_modtype path env with Modtype_abstract -> raise Not_found | Modtype_manifest mty -> mty let find_module path env = match path with Pident id -> begin try let (p, data) = EnvTbl.find_same id env.modules in data with Not_found -> if Ident.persistent id then let ps = find_pers_struct (Ident.name id) in Mty_signature(ps.ps_sig) else raise Not_found end | Pdot(p, s, pos) -> begin match EnvLazy.force !components_of_module_maker' (find_module_descr p env) with Structure_comps c -> let (data, pos) = Tbl.find s c.comp_modules in EnvLazy.force subst_modtype_maker data | Functor_comps f -> raise Not_found end | Papply(p1, p2) -> raise Not_found (* not right *) (* Lookup by name *) let rec lookup_module_descr lid env = match lid with Lident s -> begin try EnvTbl.find_name s env.components with Not_found -> if s = !current_unit then raise Not_found; let ps = find_pers_struct s in (Pident(Ident.create_persistent s), ps.ps_comps) end | Ldot(l, s) -> let (p, descr) = lookup_module_descr l env in begin match EnvLazy.force !components_of_module_maker' descr with Structure_comps c -> let (descr, pos) = Tbl.find s c.comp_components in (Pdot(p, s, pos), descr) | Functor_comps f -> raise Not_found end | Lapply(l1, l2) -> let (p1, desc1) = lookup_module_descr l1 env in let (p2, mty2) = lookup_module l2 env in begin match EnvLazy.force !components_of_module_maker' desc1 with Functor_comps f -> !check_modtype_inclusion env mty2 p2 f.fcomp_arg; (Papply(p1, p2), !components_of_functor_appl' f p1 p2) | Structure_comps c -> raise Not_found end and lookup_module lid env = match lid with Lident s -> begin try EnvTbl.find_name s env.modules with Not_found -> if s = !current_unit then raise Not_found; let ps = find_pers_struct s in (Pident(Ident.create_persistent s), Mty_signature ps.ps_sig) end | Ldot(l, s) -> let (p, descr) = lookup_module_descr l env in begin match EnvLazy.force !components_of_module_maker' descr with Structure_comps c -> let (data, pos) = Tbl.find s c.comp_modules in (Pdot(p, s, pos), EnvLazy.force subst_modtype_maker data) | Functor_comps f -> raise Not_found end | Lapply(l1, l2) -> let (p1, desc1) = lookup_module_descr l1 env in let (p2, mty2) = lookup_module l2 env in let p = Papply(p1, p2) in begin match EnvLazy.force !components_of_module_maker' desc1 with Functor_comps f -> !check_modtype_inclusion env mty2 p2 f.fcomp_arg; (p, Subst.modtype (Subst.add_module f.fcomp_param p2 f.fcomp_subst) f.fcomp_res) | Structure_comps c -> raise Not_found end let lookup proj1 proj2 lid env = match lid with Lident s -> EnvTbl.find_name s (proj1 env) | Ldot(l, s) -> let (p, desc) = lookup_module_descr l env in begin match EnvLazy.force !components_of_module_maker' desc with Structure_comps c -> let (data, pos) = Tbl.find s (proj2 c) in (Pdot(p, s, pos), data) | Functor_comps f -> raise Not_found end | Lapply(l1, l2) -> raise Not_found let lookup_simple proj1 proj2 lid env = match lid with Lident s -> EnvTbl.find_name s (proj1 env) | Ldot(l, s) -> let (p, desc) = lookup_module_descr l env in begin match EnvLazy.force !components_of_module_maker' desc with Structure_comps c -> let (data, pos) = Tbl.find s (proj2 c) in data | Functor_comps f -> raise Not_found end | Lapply(l1, l2) -> raise Not_found let has_local_constraints env = env.local_constraints let lookup_value = lookup (fun env -> env.values) (fun sc -> sc.comp_values) let lookup_annot id e = lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e and lookup_constructor = lookup (fun env -> env.constrs) (fun sc -> sc.comp_constrs) and lookup_label = lookup (fun env -> env.labels) (fun sc -> sc.comp_labels) and lookup_type = lookup (fun env -> env.types) (fun sc -> sc.comp_types) and lookup_modtype = lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) and lookup_class = lookup (fun env -> env.classes) (fun sc -> sc.comp_classes) and lookup_cltype = lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) let mark_value_used name vd = try Hashtbl.find value_declarations (name, vd.val_loc) () with Not_found -> () let mark_type_used name vd = try Hashtbl.find type_declarations (name, vd.type_loc) () with Not_found -> () let mark_constructor_used usage name vd constr = try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage with Not_found -> () let mark_exception_used usage ed constr = try Hashtbl.find used_constructors ("exn", ed.exn_loc, constr) usage with Not_found -> () let set_value_used_callback name vd callback = let key = (name, vd.val_loc) in try let old = Hashtbl.find value_declarations key in Hashtbl.replace value_declarations key (fun () -> old (); callback ()) (* this is to support cases like: let x = let x = 1 in x in x where the two declarations have the same location (e.g. resulting from Camlp4 expansion of grammar entries) *) with Not_found -> Hashtbl.add value_declarations key callback let set_type_used_callback name td callback = let old = try Hashtbl.find type_declarations (name, td.type_loc) with Not_found -> assert false in Hashtbl.replace type_declarations (name, td.type_loc) (fun () -> callback old) let lookup_value lid env = let (_, desc) as r = lookup_value lid env in mark_value_used (Longident.last lid) desc; r let lookup_type lid env = let (_, desc) as r = lookup_type lid env in mark_type_used (Longident.last lid) desc; r (* [path] must be the path to a type, not to a module ! *) let rec path_subst_last path id = match path with Pident _ -> Pident id | Pdot (p, name, pos) -> Pdot(p, Ident.name id, pos) | Papply (p1, p2) -> assert false let mark_type_path env path = let decl = try find_type path env with Not_found -> assert false in mark_type_used (Path.last path) decl let ty_path = function | {desc=Tconstr(path, _, _)} -> path | _ -> assert false let lookup_constructor lid env = let (_,desc) as c = lookup_constructor lid env in mark_type_path env (ty_path desc.cstr_res); c let mark_constructor usage env name desc = match desc.cstr_tag with | Cstr_exception (_, loc) -> begin try Hashtbl.find used_constructors ("exn", loc, name) usage with Not_found -> () end | _ -> let ty_path = ty_path desc.cstr_res in let ty_decl = try find_type ty_path env with Not_found -> assert false in let ty_name = Path.last ty_path in mark_constructor_used usage ty_name ty_decl name let lookup_label lid env = let (_,desc) as c = lookup_label lid env in mark_type_path env (ty_path desc.lbl_res); c let lookup_class lid env = let (_, desc) as r = lookup_class lid env in (* special support for Typeclass.unbound_class *) if Path.name desc.cty_path = "" then ignore (lookup_type lid env) else mark_type_path env desc.cty_path; r let lookup_cltype lid env = let (_, desc) as r = lookup_cltype lid env in if Path.name desc.clty_path = "" then ignore (lookup_type lid env) else mark_type_path env desc.clty_path; mark_type_path env desc.clty_path; r (* GADT instance tracking *) let add_gadt_instance_level lv env = {env with gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances} let is_Tlink = function {desc = Tlink _} -> true | _ -> false let gadt_instance_level env t = let rec find_instance = function [] -> None | (lv, r) :: rem -> if TypeSet.exists is_Tlink !r then (* Should we use set_typeset ? *) r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty; if TypeSet.mem t !r then Some lv else find_instance rem in find_instance env.gadt_instances let add_gadt_instances env lv tl = let r = try List.assoc lv env.gadt_instances with Not_found -> assert false in (* Format.eprintf "Added"; List.iter (fun ty -> Format.eprintf "@ %a" !Btype.print_raw ty) tl; Format.eprintf "@."; *) set_typeset r (List.fold_right TypeSet.add tl !r) (* Only use this after expand_head! *) let add_gadt_instance_chain env lv t = let r = try List.assoc lv env.gadt_instances with Not_found -> assert false in let rec add_instance t = let t = repr t in if not (TypeSet.mem t !r) then begin (* Format.eprintf "@ %a" !Btype.print_raw t; *) set_typeset r (TypeSet.add t !r); match t.desc with Tconstr (p, _, memo) -> may add_instance (find_expans Private p !memo) | _ -> () end in (* Format.eprintf "Added chain"; *) add_instance t (* Format.eprintf "@." *) (* Expand manifest module type names at the top of the given module type *) let rec scrape_modtype mty env = match mty with Mty_ident path -> begin try scrape_modtype (find_modtype_expansion path env) env with Not_found -> mty end | _ -> mty (* Compute constructor descriptions *) let constructors_of_type ty_path decl = let handle_variants cstrs = Datarepr.constructor_descrs (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) cstrs decl.type_private in match decl.type_kind with | Type_variant cstrs -> handle_variants cstrs | Type_record _ | Type_abstract -> [] (* Compute label descriptions *) let labels_of_type ty_path decl = match decl.type_kind with Type_record(labels, rep) -> Datarepr.label_descrs (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) labels rep decl.type_private | Type_variant _ | Type_abstract -> [] (* Given a signature and a root path, prefix all idents in the signature by the root path and build the corresponding substitution. *) let rec prefix_idents root pos sub = function [] -> ([], sub) | Sig_value(id, decl) :: rem -> let p = Pdot(root, Ident.name id, pos) in let nextpos = match decl.val_kind with Val_prim _ -> pos | _ -> pos+1 in let (pl, final_sub) = prefix_idents root nextpos sub rem in (p::pl, final_sub) | Sig_type(id, decl, _) :: rem -> let p = Pdot(root, Ident.name id, nopos) in let (pl, final_sub) = prefix_idents root pos (Subst.add_type id p sub) rem in (p::pl, final_sub) | Sig_exception(id, decl) :: rem -> let p = Pdot(root, Ident.name id, pos) in let (pl, final_sub) = prefix_idents root (pos+1) sub rem in (p::pl, final_sub) | Sig_module(id, mty, _) :: rem -> let p = Pdot(root, Ident.name id, pos) in let (pl, final_sub) = prefix_idents root (pos+1) (Subst.add_module id p sub) rem in (p::pl, final_sub) | Sig_modtype(id, decl) :: rem -> let p = Pdot(root, Ident.name id, nopos) in let (pl, final_sub) = prefix_idents root pos (Subst.add_modtype id (Mty_ident p) sub) rem in (p::pl, final_sub) | Sig_class(id, decl, _) :: rem -> let p = Pdot(root, Ident.name id, pos) in let (pl, final_sub) = prefix_idents root (pos + 1) sub rem in (p::pl, final_sub) | Sig_class_type(id, decl, _) :: rem -> let p = Pdot(root, Ident.name id, nopos) in let (pl, final_sub) = prefix_idents root pos sub rem in (p::pl, final_sub) (* Compute structure descriptions *) let rec components_of_module env sub path mty = EnvLazy.create (env, sub, path, mty) and components_of_module_maker (env, sub, path, mty) = (match scrape_modtype mty env with Mty_signature sg -> let c = { comp_values = Tbl.empty; comp_annotations = Tbl.empty; comp_constrs = Tbl.empty; comp_labels = Tbl.empty; comp_types = Tbl.empty; comp_constrs_by_path = Tbl.empty; comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; comp_components = Tbl.empty; comp_classes = Tbl.empty; comp_cltypes = Tbl.empty } in let (pl, sub) = prefix_idents path 0 sub sg in let env = ref env in let pos = ref 0 in List.iter2 (fun item path -> match item with Sig_value(id, decl) -> let decl' = Subst.value_description sub decl in c.comp_values <- Tbl.add (Ident.name id) (decl', !pos) c.comp_values; if !Clflags.annotations then begin c.comp_annotations <- Tbl.add (Ident.name id) (Annot.Iref_external, !pos) c.comp_annotations; end; begin match decl.val_kind with Val_prim _ -> () | _ -> incr pos end | Sig_type(id, decl, _) -> let decl' = Subst.type_declaration sub decl in c.comp_types <- Tbl.add (Ident.name id) (decl', nopos) c.comp_types; let constructors = constructors_of_type path decl' in c.comp_constrs_by_path <- Tbl.add (Ident.name id) (List.map snd constructors, nopos) c.comp_constrs_by_path; List.iter (fun (name, descr) -> c.comp_constrs <- Tbl.add (Ident.name name) (descr, nopos) c.comp_constrs) constructors; let labels = labels_of_type path decl' in List.iter (fun (name, descr) -> c.comp_labels <- Tbl.add (Ident.name name) (descr, nopos) c.comp_labels) (labels); env := store_type_infos id path decl !env | Sig_exception(id, decl) -> let decl' = Subst.exception_declaration sub decl in let cstr = Datarepr.exception_descr path decl' in c.comp_constrs <- Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs; incr pos | Sig_module(id, mty, _) -> let mty' = EnvLazy.create (sub, mty) in c.comp_modules <- Tbl.add (Ident.name id) (mty', !pos) c.comp_modules; let comps = components_of_module !env sub path mty in c.comp_components <- Tbl.add (Ident.name id) (comps, !pos) c.comp_components; env := store_module id path mty !env; incr pos | Sig_modtype(id, decl) -> let decl' = Subst.modtype_declaration sub decl in c.comp_modtypes <- Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes; env := store_modtype id path decl !env | Sig_class(id, decl, _) -> let decl' = Subst.class_declaration sub decl in c.comp_classes <- Tbl.add (Ident.name id) (decl', !pos) c.comp_classes; incr pos | Sig_class_type(id, decl, _) -> let decl' = Subst.cltype_declaration sub decl in c.comp_cltypes <- Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes) sg pl; Structure_comps c | Mty_functor(param, ty_arg, ty_res) -> Functor_comps { fcomp_param = param; (* fcomp_arg must be prefixed eagerly, because it is interpreted in the outer environment, not in env *) fcomp_arg = Subst.modtype sub ty_arg; (* fcomp_res is prefixed lazily, because it is interpreted in env *) fcomp_res = ty_res; fcomp_env = env; fcomp_subst = sub; fcomp_cache = Hashtbl.create 17 } | Mty_ident p -> Structure_comps { comp_values = Tbl.empty; comp_annotations = Tbl.empty; comp_constrs = Tbl.empty; comp_labels = Tbl.empty; comp_types = Tbl.empty; comp_constrs_by_path = Tbl.empty; comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; comp_components = Tbl.empty; comp_classes = Tbl.empty; comp_cltypes = Tbl.empty }) (* Insertion of bindings by identifier + path *) and check_usage loc id warn tbl = if not loc.Location.loc_ghost && Warnings.is_active (warn "") then begin let name = Ident.name id in let key = (name, loc) in if Hashtbl.mem tbl key then () else let used = ref false in Hashtbl.add tbl key (fun () -> used := true); if not (name = "" || name.[0] = '_' || name.[0] = '#') then !add_delayed_check_forward (fun () -> if not !used then Location.prerr_warning loc (warn name)) end; and store_value ?check id path decl env = may (fun f -> check_usage decl.val_loc id f value_declarations) check; { env with values = EnvTbl.add id (path, decl) env.values; summary = Env_value(env.summary, id, decl) } and store_annot id path annot env = if !Clflags.annotations then { env with annotations = EnvTbl.add id (path, annot) env.annotations } else env and store_type id path info env = let loc = info.type_loc in check_usage loc id (fun s -> Warnings.Unused_type_declaration s) type_declarations; let constructors = constructors_of_type path info in let labels = labels_of_type path info in if not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_constructor ("", false, false)) then begin let ty = Ident.name id in List.iter begin fun (c, _) -> let c = Ident.name c in let k = (ty, loc, c) in if not (Hashtbl.mem used_constructors k) then let used = constructor_usages () in Hashtbl.add used_constructors k (add_constructor_usage used); if not (ty = "" || ty.[0] = '_') then !add_delayed_check_forward (fun () -> if not env.in_signature && not used.cu_positive then Location.prerr_warning loc (Warnings.Unused_constructor (c, used.cu_pattern, used.cu_privatize))) end constructors end; { env with constrs = List.fold_right (fun (name, descr) constrs -> EnvTbl.add name (path_subst_last path name, descr) constrs) constructors env.constrs; constrs_by_path = EnvTbl.add id (path,List.map snd constructors) env.constrs_by_path; labels = List.fold_right (fun (name, descr) labels -> EnvTbl.add name (path_subst_last path name, descr) labels) labels env.labels; types = EnvTbl.add id (path, info) env.types; summary = Env_type(env.summary, id, info) } and store_type_infos id path info env = (* Simplified version of store_type that doesn't compute and store constructor and label infos, but simply record the arity and manifest-ness of the type. Used in components_of_module to keep track of type abbreviations (e.g. type t = float) in the computation of label representations. *) { env with types = EnvTbl.add id (path, info) env.types; summary = Env_type(env.summary, id, info) } and store_exception id path decl env = let loc = decl.exn_loc in if not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_exception ("", false)) then begin let ty = "exn" in let c = Ident.name id in let k = (ty, loc, c) in if not (Hashtbl.mem used_constructors k) then begin let used = constructor_usages () in Hashtbl.add used_constructors k (add_constructor_usage used); !add_delayed_check_forward (fun () -> if not env.in_signature && not used.cu_positive then Location.prerr_warning loc (Warnings.Unused_exception (c, used.cu_pattern) ) ) end; end; { env with constrs = EnvTbl.add id (path_subst_last path id, Datarepr.exception_descr path decl) env.constrs; summary = Env_exception(env.summary, id, decl) } and store_module id path mty env = { env with modules = EnvTbl.add id (path, mty) env.modules; components = EnvTbl.add id (path, components_of_module env Subst.identity path mty) env.components; summary = Env_module(env.summary, id, mty) } and store_modtype id path info env = { env with modtypes = EnvTbl.add id (path, info) env.modtypes; summary = Env_modtype(env.summary, id, info) } and store_class id path desc env = { env with classes = EnvTbl.add id (path, desc) env.classes; summary = Env_class(env.summary, id, desc) } and store_cltype id path desc env = { env with cltypes = EnvTbl.add id (path, desc) env.cltypes; summary = Env_cltype(env.summary, id, desc) } (* Compute the components of a functor application in a path. *) let components_of_functor_appl f p1 p2 = try Hashtbl.find f.fcomp_cache p2 with Not_found -> let p = Papply(p1, p2) in let mty = Subst.modtype (Subst.add_module f.fcomp_param p2 Subst.identity) f.fcomp_res in let comps = components_of_module f.fcomp_env f.fcomp_subst p mty in Hashtbl.add f.fcomp_cache p2 comps; comps (* Define forward functions *) let _ = components_of_module' := components_of_module; components_of_functor_appl' := components_of_functor_appl; components_of_module_maker' := components_of_module_maker (* Insertion of bindings by identifier *) let add_value ?check id desc env = store_value ?check id (Pident id) desc env let add_annot id annot env = store_annot id (Pident id) annot env and add_type id info env = store_type id (Pident id) info env and add_exception id decl env = store_exception id (Pident id) decl env and add_module id mty env = store_module id (Pident id) mty env and add_modtype id info env = store_modtype id (Pident id) info env and add_class id ty env = store_class id (Pident id) ty env and add_cltype id ty env = store_cltype id (Pident id) ty env let add_local_constraint id info elv env = match info with {type_manifest = Some ty; type_newtype_level = Some (lv, _)} -> (* elv is the expansion level, lv is the definition level *) let env = add_type id {info with type_newtype_level = Some (lv, elv)} env in { env with local_constraints = true } | _ -> assert false (* Insertion of bindings by name *) let enter store_fun name data env = let id = Ident.create name in (id, store_fun id (Pident id) data env) let enter_value ?check = enter (store_value ?check) and enter_type = enter store_type and enter_exception = enter store_exception and enter_module = enter store_module and enter_modtype = enter store_modtype and enter_class = enter store_class and enter_cltype = enter store_cltype (* Insertion of all components of a signature *) let add_item comp env = match comp with Sig_value(id, decl) -> add_value id decl env | Sig_type(id, decl, _) -> add_type id decl env | Sig_exception(id, decl) -> add_exception id decl env | Sig_module(id, mty, _) -> add_module id mty env | Sig_modtype(id, decl) -> add_modtype id decl env | Sig_class(id, decl, _) -> add_class id decl env | Sig_class_type(id, decl, _) -> add_cltype id decl env let rec add_signature sg env = match sg with [] -> env | comp :: rem -> add_signature rem (add_item comp env) (* Open a signature path *) let open_signature root sg env = (* First build the paths and substitution *) let (pl, sub) = prefix_idents root 0 Subst.identity sg in (* Then enter the components in the environment after substitution *) let newenv = List.fold_left2 (fun env item p -> match item with Sig_value(id, decl) -> let e1 = store_value (Ident.hide id) p (Subst.value_description sub decl) env in store_annot (Ident.hide id) p (Annot.Iref_external) e1 | Sig_type(id, decl, _) -> store_type (Ident.hide id) p (Subst.type_declaration sub decl) env | Sig_exception(id, decl) -> store_exception (Ident.hide id) p (Subst.exception_declaration sub decl) env | Sig_module(id, mty, _) -> store_module (Ident.hide id) p (Subst.modtype sub mty) env | Sig_modtype(id, decl) -> store_modtype (Ident.hide id) p (Subst.modtype_declaration sub decl) env | Sig_class(id, decl, _) -> store_class (Ident.hide id) p (Subst.class_declaration sub decl) env | Sig_class_type(id, decl, _) -> store_cltype (Ident.hide id) p (Subst.cltype_declaration sub decl) env) env sg pl in { newenv with summary = Env_open(env.summary, root) } (* Open a signature from a file *) let open_pers_signature name env = let ps = find_pers_struct name in open_signature (Pident(Ident.create_persistent name)) ps.ps_sig env let open_signature ?(loc = Location.none) ?(toplevel = false) root sg env = if not toplevel && not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_open "") then begin let used = ref false in !add_delayed_check_forward (fun () -> if not !used then Location.prerr_warning loc (Warnings.Unused_open (Path.name root)) ); EnvTbl.with_slot used (open_signature root sg) env end else open_signature root sg env (* Read a signature from a file *) let read_signature modname filename = let ps = read_pers_struct modname filename in ps.ps_sig (* Return the CRC of the interface of the given compilation unit *) let crc_of_unit name = let ps = find_pers_struct name in try List.assoc name ps.ps_crcs with Not_found -> assert false (* Return the list of imported interfaces with their CRCs *) let imported_units() = Consistbl.extract crc_units (* Save a signature to a file *) let save_signature_with_imports sg modname filename imports = Btype.cleanup_abbrev (); Subst.reset_for_saving (); let sg = Subst.signature (Subst.for_saving Subst.identity) sg in let oc = open_out_bin filename in try let cmi = { cmi_name = modname; cmi_sign = sg; cmi_crcs = imports; cmi_flags = if !Clflags.recursive_types then [Rectypes] else []; } in let crc = output_cmi filename oc cmi in close_out oc; (* Enter signature in persistent table so that imported_unit() will also return its crc *) let comps = components_of_module empty Subst.identity (Pident(Ident.create_persistent modname)) (Mty_signature sg) in let ps = { ps_name = modname; ps_sig = sg; ps_comps = comps; ps_crcs = (cmi.cmi_name, crc) :: imports; ps_filename = filename; ps_flags = cmi.cmi_flags } in Hashtbl.add persistent_structures modname (Some ps); Consistbl.set crc_units modname crc filename; sg with exn -> close_out oc; remove_file filename; raise exn let save_signature sg modname filename = save_signature_with_imports sg modname filename (imported_units()) (* Folding on environments *) let ident_tbl_fold f t acc = List.fold_right (fun key acc -> f key (EnvTbl.find_same_not_using key t) acc) (EnvTbl.keys t) acc let find_all proj1 proj2 f lid env acc = match lid with | None -> ident_tbl_fold (fun id (p, data) acc -> f (Ident.name id) p data acc) (proj1 env) acc | Some l -> let p, desc = lookup_module_descr l env in begin match EnvLazy.force components_of_module_maker desc with Structure_comps c -> Tbl.fold (fun s (data, pos) acc -> f s (Pdot (p, s, pos)) data acc) (proj2 c) acc | Functor_comps _ -> raise Not_found end let fold_modules f lid env acc = match lid with | None -> let acc = ident_tbl_fold (fun id (p, data) acc -> f (Ident.name id) p data acc) env.modules acc in Hashtbl.fold (fun name ps acc -> match ps with None -> acc | Some ps -> f name (Pident(Ident.create_persistent name)) (Mty_signature ps.ps_sig) acc) persistent_structures acc | Some l -> let p, desc = lookup_module_descr l env in begin match EnvLazy.force components_of_module_maker desc with Structure_comps c -> Tbl.fold (fun s (data, pos) acc -> f s (Pdot (p, s, pos)) (EnvLazy.force subst_modtype_maker data) acc) c.comp_modules acc | Functor_comps _ -> raise Not_found end let fold_values f = find_all (fun env -> env.values) (fun sc -> sc.comp_values) f and fold_constructors f = find_all (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f and fold_labels f = find_all (fun env -> env.labels) (fun sc -> sc.comp_labels) f and fold_types f = find_all (fun env -> env.types) (fun sc -> sc.comp_types) f and fold_modtypes f = find_all (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f and fold_classs f = find_all (fun env -> env.classes) (fun sc -> sc.comp_classes) f and fold_cltypes f = find_all (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) f (* Make the initial environment *) let initial = Predef.build_initial_env add_type add_exception empty (* Return the environment summary *) let summary env = env.summary let keep_only_summary env = { empty with summary = env.summary; local_constraints = env.local_constraints; in_signature = env.in_signature; } let env_of_only_summary env_from_summary env = let new_env = env_from_summary env.summary Subst.identity in { new_env with local_constraints = env.local_constraints; in_signature = env.in_signature; } (* Error report *) open Format let report_error ppf = function | Illegal_renaming(modname, filename) -> fprintf ppf "Wrong file naming: %a@ contains the compiled interface for@ %s" Location.print_filename filename modname | Inconsistent_import(name, source1, source2) -> fprintf ppf "@[The files %a@ and %a@ \ make inconsistent assumptions@ over interface %s@]" Location.print_filename source1 Location.print_filename source2 name | Need_recursive_types(import, export) -> fprintf ppf "@[Unit %s imports from %s, which uses recursive types.@ %s@]" export import "The compilation flag -rectypes is required" mingw-ocaml/ocaml/typing/types.ml0000644000175000017500000001670212124403242016475 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Representation of types and declarations *) open Misc open Asttypes (* Type expressions for the core language *) type type_expr = { mutable desc: type_desc; mutable level: int; mutable id: int } and type_desc = Tvar of string option | Tarrow of label * type_expr * type_expr * commutable | Ttuple of type_expr list | Tconstr of Path.t * type_expr list * abbrev_memo ref | Tobject of type_expr * (Path.t * type_expr list) option ref | Tfield of string * field_kind * type_expr * type_expr | Tnil | Tlink of type_expr | Tsubst of type_expr (* for copying *) | Tvariant of row_desc | Tunivar of string option | Tpoly of type_expr * type_expr list | Tpackage of Path.t * Longident.t list * type_expr list and row_desc = { row_fields: (label * row_field) list; row_more: type_expr; row_bound: unit; row_closed: bool; row_fixed: bool; row_name: (Path.t * type_expr list) option } and row_field = Rpresent of type_expr option | Reither of bool * type_expr list * bool * row_field option ref (* 1st true denotes a constant constructor *) (* 2nd true denotes a tag in a pattern matching, and is erased later *) | Rabsent and abbrev_memo = Mnil | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo | Mlink of abbrev_memo ref and field_kind = Fvar of field_kind option ref | Fpresent | Fabsent and commutable = Cok | Cunknown | Clink of commutable ref module TypeOps = struct type t = type_expr let compare t1 t2 = t1.id - t2.id let hash t = t.id let equal t1 t2 = t1 == t2 end (* Maps of methods and instance variables *) module OrderedString = struct type t = string let compare = compare end module Meths = Map.Make(OrderedString) module Vars = Meths (* Value descriptions *) type value_description = { val_type: type_expr; (* Type of the value *) val_kind: value_kind; val_loc: Location.t; } and value_kind = Val_reg (* Regular value *) | Val_prim of Primitive.description (* Primitive *) | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) | Val_self of (Ident.t * type_expr) Meths.t ref * (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t ref * string * type_expr (* Self *) | Val_anc of (string * Ident.t) list * string (* Ancestor *) | Val_unbound (* Unbound variable *) (* Constructor descriptions *) type constructor_description = { cstr_res: type_expr; (* Type of the result *) cstr_existentials: type_expr list; (* list of existentials *) cstr_args: type_expr list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) cstr_tag: constructor_tag; (* Tag for heap blocks *) cstr_consts: int; (* Number of constant constructors *) cstr_nonconsts: int; (* Number of non-const constructors *) cstr_normal: int; (* Number of non generalized constrs *) cstr_generalized: bool; (* Constrained return type? *) cstr_private: private_flag } (* Read-only constructor? *) and constructor_tag = Cstr_constant of int (* Constant constructor (an int) *) | Cstr_block of int (* Regular constructor (a block) *) | Cstr_exception of Path.t * Location.t (* Exception constructor *) (* Record label descriptions *) type label_description = { lbl_name: string; (* Short name *) lbl_res: type_expr; (* Type of the result *) lbl_arg: type_expr; (* Type of the argument *) lbl_mut: mutable_flag; (* Is this a mutable field? *) lbl_pos: int; (* Position in block *) lbl_all: label_description array; (* All the labels in this type *) lbl_repres: record_representation; (* Representation for this record *) lbl_private: private_flag } (* Read-only field? *) and record_representation = Record_regular (* All fields are boxed / tagged *) | Record_float (* All fields are floats *) (* Type definitions *) type type_declaration = { type_params: type_expr list; type_arity: int; type_kind: type_kind; type_private: private_flag; type_manifest: type_expr option; type_variance: (bool * bool * bool) list; (* covariant, contravariant, weakly contravariant *) type_newtype_level: (int * int) option; type_loc: Location.t } and type_kind = Type_abstract | Type_record of (Ident.t * mutable_flag * type_expr) list * record_representation | Type_variant of (Ident.t * type_expr list * type_expr option) list type exception_declaration = { exn_args: type_expr list; exn_loc: Location.t } (* Type expressions for the class language *) module Concr = Set.Make(OrderedString) type class_type = Cty_constr of Path.t * type_expr list * class_type | Cty_signature of class_signature | Cty_fun of label * type_expr * class_type and class_signature = { cty_self: type_expr; cty_vars: (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; cty_concr: Concr.t; cty_inher: (Path.t * type_expr list) list } type class_declaration = { cty_params: type_expr list; mutable cty_type: class_type; cty_path: Path.t; cty_new: type_expr option; cty_variance: (bool * bool) list } type class_type_declaration = { clty_params: type_expr list; clty_type: class_type; clty_path: Path.t; clty_variance: (bool * bool) list } (* Type expressions for the module language *) type module_type = Mty_ident of Path.t | Mty_signature of signature | Mty_functor of Ident.t * module_type * module_type and signature = signature_item list and signature_item = Sig_value of Ident.t * value_description | Sig_type of Ident.t * type_declaration * rec_status | Sig_exception of Ident.t * exception_declaration | Sig_module of Ident.t * module_type * rec_status | Sig_modtype of Ident.t * modtype_declaration | Sig_class of Ident.t * class_declaration * rec_status | Sig_class_type of Ident.t * class_type_declaration * rec_status and modtype_declaration = Modtype_abstract | Modtype_manifest of module_type and rec_status = Trec_not (* not recursive *) | Trec_first (* first in a recursive group *) | Trec_next (* not first in a recursive group *) mingw-ocaml/ocaml/typing/ident.mli0000644000175000017500000000426212124403242016603 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Identifiers (unique names) *) type t = { stamp: int; name: string; mutable flags: int } val create: string -> t val create_persistent: string -> t val create_predef_exn: string -> t val rename: t -> t val name: t -> string val unique_name: t -> string val unique_toplevel_name: t -> string val persistent: t -> bool val equal: t -> t -> bool (* Compare identifiers by name. *) val same: t -> t -> bool (* Compare identifiers by binding location. Two identifiers are the same either if they are both non-persistent and have been created by the same call to [new], or if they are both persistent and have the same name. *) val hide: t -> t (* Return an identifier with same name as the given identifier, but stamp different from any stamp returned by new. When put in a 'a tbl, this identifier can only be looked up by name. *) val make_global: t -> unit val global: t -> bool val is_predef_exn: t -> bool val binding_time: t -> int val current_time: unit -> int val set_current_time: int -> unit val reinit: unit -> unit val print: Format.formatter -> t -> unit type 'a tbl (* Association tables from identifiers to type 'a. *) val empty: 'a tbl val add: t -> 'a -> 'a tbl -> 'a tbl val find_same: t -> 'a tbl -> 'a val find_name: string -> 'a tbl -> 'a val keys: 'a tbl -> t list mingw-ocaml/ocaml/typing/path.ml0000644000175000017500000000370312124403242016262 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) type t = Pident of Ident.t | Pdot of t * string * int | Papply of t * t let nopos = -1 let rec same p1 p2 = match (p1, p2) with (Pident id1, Pident id2) -> Ident.same id1 id2 | (Pdot(p1, s1, pos1), Pdot(p2, s2, pos2)) -> s1 = s2 && same p1 p2 | (Papply(fun1, arg1), Papply(fun2, arg2)) -> same fun1 fun2 && same arg1 arg2 | (_, _) -> false let rec isfree id = function Pident id' -> Ident.same id id' | Pdot(p, s, pos) -> isfree id p | Papply(p1, p2) -> isfree id p1 || isfree id p2 let rec binding_time = function Pident id -> Ident.binding_time id | Pdot(p, s, pos) -> binding_time p | Papply(p1, p2) -> max (binding_time p1) (binding_time p2) let kfalse x = false let rec name ?(paren=kfalse) = function Pident id -> Ident.name id | Pdot(p, s, pos) -> name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")" let rec head = function Pident id -> id | Pdot(p, s, pos) -> head p | Papply(p1, p2) -> assert false let rec last = function | Pident id -> Ident.name id | Pdot(_, s, _) -> s | Papply(_, p) -> last p mingw-ocaml/ocaml/typing/typetexp.ml0000644000175000017500000006541012124403242017213 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* typetexp.ml,v 1.34.4.9 2002/01/07 08:39:16 garrigue Exp *) (* Typechecking of type expressions for the core language *) open Asttypes open Misc open Parsetree open Typedtree open Types open Ctype exception Already_bound type error = Unbound_type_variable of string | Unbound_type_constructor of Longident.t | Unbound_type_constructor_2 of Path.t | Type_arity_mismatch of Longident.t * int * int | Bound_type_variable of string | Recursive_type | Unbound_row_variable of Longident.t | Type_mismatch of (type_expr * type_expr) list | Alias_type_mismatch of (type_expr * type_expr) list | Present_has_conjunction of string | Present_has_no_type of string | Constructor_mismatch of type_expr * type_expr | Not_a_variant of type_expr | Variant_tags of string * string | Invalid_variable_name of string | Cannot_quantify of string * type_expr | Multiple_constraints_on_type of Longident.t | Repeated_method_label of string | Unbound_value of Longident.t | Unbound_constructor of Longident.t | Unbound_label of Longident.t | Unbound_module of Longident.t | Unbound_class of Longident.t | Unbound_modtype of Longident.t | Unbound_cltype of Longident.t | Ill_typed_functor_application of Longident.t exception Error of Location.t * error type variable_context = int * (string, type_expr) Tbl.t (* Local definitions *) let instance_list = Ctype.instance_list Env.empty (* Narrowing unbound identifier errors. *) let rec narrow_unbound_lid_error env loc lid make_error = let check_module mlid = try ignore (Env.lookup_module mlid env) with Not_found -> narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid); assert false in begin match lid with | Longident.Lident _ -> () | Longident.Ldot (mlid, _) -> check_module mlid | Longident.Lapply (flid, mlid) -> check_module flid; check_module mlid; raise (Error (loc, Ill_typed_functor_application lid)) end; raise (Error (loc, make_error lid)) let find_component lookup make_error env loc lid = try match lid with | Longident.Ldot (Longident.Lident "*predef*", s) -> lookup (Longident.Lident s) Env.initial | _ -> lookup lid env with Not_found -> (narrow_unbound_lid_error env loc lid make_error : unit (* to avoid a warning *)); assert false let find_type = find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid) let find_constructor = find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid) let find_label = find_component Env.lookup_label (fun lid -> Unbound_label lid) let find_class = find_component Env.lookup_class (fun lid -> Unbound_class lid) let find_value = find_component Env.lookup_value (fun lid -> Unbound_value lid) let find_module = find_component Env.lookup_module (fun lid -> Unbound_module lid) let find_modtype = find_component Env.lookup_modtype (fun lid -> Unbound_modtype lid) let find_class_type = find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid) (* Support for first-class modules. *) let transl_modtype_longident = ref (fun _ -> assert false) let transl_modtype = ref (fun _ -> assert false) let create_package_mty fake loc env (p, l) = let l = List.sort (fun (s1, t1) (s2, t2) -> if s1.txt = s2.txt then raise (Error (loc, Multiple_constraints_on_type s1.txt)); compare s1 s2) l in l, List.fold_left (fun mty (s, t) -> let d = {ptype_params = []; ptype_cstrs = []; ptype_kind = Ptype_abstract; ptype_private = Asttypes.Public; ptype_manifest = if fake then None else Some t; ptype_variance = []; ptype_loc = loc} in {pmty_desc=Pmty_with (mty, [ { txt = s.txt; loc }, Pwith_type d ]); pmty_loc=loc} ) {pmty_desc=Pmty_ident p; pmty_loc=loc} l (* Translation of type expressions *) let type_variables = ref (Tbl.empty : (string, type_expr) Tbl.t) let univars = ref ([] : (string * type_expr) list) let pre_univars = ref ([] : type_expr list) let used_variables = ref (Tbl.empty : (string, type_expr * Location.t) Tbl.t) let reset_type_variables () = reset_global_level (); type_variables := Tbl.empty let narrow () = (increase_global_level (), !type_variables) let widen (gl, tv) = restore_global_level gl; type_variables := tv let strict_lowercase c = (c = '_' || c >= 'a' && c <= 'z') let validate_name = function None -> None | Some name as s -> if name <> "" && strict_lowercase name.[0] then s else None let new_global_var ?name () = new_global_var ?name:(validate_name name) () let newvar ?name () = newvar ?name:(validate_name name) () let enter_type_variable strict loc name = try if name <> "" && name.[0] = '_' then raise (Error (loc, Invalid_variable_name ("'" ^ name))); let v = Tbl.find name !type_variables in if strict then raise Already_bound; v with Not_found -> let v = new_global_var ~name () in type_variables := Tbl.add name v !type_variables; v let type_variable loc name = try Tbl.find name !type_variables with Not_found -> raise(Error(loc, Unbound_type_variable ("'" ^ name))) let wrap_method ty = match (Ctype.repr ty).desc with Tpoly _ -> ty | _ -> Ctype.newty (Tpoly (ty, [])) let new_pre_univar ?name () = let v = newvar ?name () in pre_univars := v :: !pre_univars; v let rec swap_list = function x :: y :: l -> y :: x :: swap_list l | l -> l type policy = Fixed | Extensible | Univars let ctyp ctyp_desc ctyp_type ctyp_env ctyp_loc = { ctyp_desc; ctyp_type; ctyp_env; ctyp_loc } let rec transl_type env policy styp = let loc = styp.ptyp_loc in match styp.ptyp_desc with Ptyp_any -> let ty = if policy = Univars then new_pre_univar () else if policy = Fixed then raise (Error (styp.ptyp_loc, Unbound_type_variable "_")) else newvar () in ctyp Ttyp_any ty env loc | Ptyp_var name -> let ty = if name <> "" && name.[0] = '_' then raise (Error (styp.ptyp_loc, Invalid_variable_name ("'" ^ name))); begin try instance env (List.assoc name !univars) with Not_found -> try instance env (fst(Tbl.find name !used_variables)) with Not_found -> let v = if policy = Univars then new_pre_univar ~name () else newvar ~name () in used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables; v end in ctyp (Ttyp_var name) ty env loc | Ptyp_arrow(l, st1, st2) -> let cty1 = transl_type env policy st1 in let cty2 = transl_type env policy st2 in let ty = newty (Tarrow(l, cty1.ctyp_type, cty2.ctyp_type, Cok)) in ctyp (Ttyp_arrow (l, cty1, cty2)) ty env loc | Ptyp_tuple stl -> let ctys = List.map (transl_type env policy) stl in let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in ctyp (Ttyp_tuple ctys) ty env loc | Ptyp_constr(lid, stl) -> let (path, decl) = find_type env styp.ptyp_loc lid.txt in if List.length stl <> decl.type_arity then raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid.txt, decl.type_arity, List.length stl))); let args = List.map (transl_type env policy) stl in let params = instance_list decl.type_params in let unify_param = match decl.type_manifest with None -> unify_var | Some ty -> if (repr ty).level = Btype.generic_level then unify_var else unify in List.iter2 (fun (sty, cty) ty' -> try unify_param env ty' cty.ctyp_type with Unify trace -> raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace)))) (List.combine stl args) params; let constr = newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in begin try Ctype.enforce_constraints env constr with Unify trace -> raise (Error(styp.ptyp_loc, Type_mismatch trace)) end; ctyp (Ttyp_constr (path, lid, args)) constr env loc | Ptyp_object fields -> let fields = List.map (fun pf -> let desc = match pf.pfield_desc with | Pfield_var -> Tcfield_var | Pfield (s,e) -> let ty1 = transl_type env policy e in Tcfield (s, ty1) in { field_desc = desc; field_loc = pf.pfield_loc }) fields in let ty = newobj (transl_fields env policy [] fields) in ctyp (Ttyp_object fields) ty env loc | Ptyp_class(lid, stl, present) -> let (path, decl, is_variant) = try let (path, decl) = Env.lookup_type lid.txt env in let rec check decl = match decl.type_manifest with None -> raise Not_found | Some ty -> match (repr ty).desc with Tvariant row when Btype.static_row row -> () | Tconstr (path, _, _) -> check (Env.find_type path env) | _ -> raise Not_found in check decl; Location.prerr_warning styp.ptyp_loc Warnings.Deprecated; (path, decl,true) with Not_found -> try if present <> [] then raise Not_found; let lid2 = match lid.txt with Longident.Lident s -> Longident.Lident ("#" ^ s) | Longident.Ldot(r, s) -> Longident.Ldot (r, "#" ^ s) | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type" in let (path, decl) = Env.lookup_type lid2 env in (path, decl, false) with Not_found -> raise(Error(styp.ptyp_loc, Unbound_class lid.txt)) in if List.length stl <> decl.type_arity then raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid.txt, decl.type_arity, List.length stl))); let args = List.map (transl_type env policy) stl in let params = instance_list decl.type_params in List.iter2 (fun (sty, cty) ty' -> try unify_var env ty' cty.ctyp_type with Unify trace -> raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace)))) (List.combine stl args) params; let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in let ty = try Ctype.expand_head env (newconstr path ty_args) with Unify trace -> raise (Error(styp.ptyp_loc, Type_mismatch trace)) in let ty = match ty.desc with Tvariant row -> let row = Btype.row_repr row in List.iter (fun l -> if not (List.mem_assoc l row.row_fields) then raise(Error(styp.ptyp_loc, Present_has_no_type l))) present; let fields = List.map (fun (l,f) -> l, if List.mem l present then f else match Btype.row_field_repr f with | Rpresent (Some ty) -> Reither(false, [ty], false, ref None) | Rpresent None -> Reither (true, [], false, ref None) | _ -> f) row.row_fields in let row = { row_closed = true; row_fields = fields; row_bound = (); row_name = Some (path, ty_args); row_fixed = false; row_more = newvar () } in let static = Btype.static_row row in let row = if static then { row with row_more = newty Tnil } else if policy <> Univars then row else { row with row_more = new_pre_univar () } in newty (Tvariant row) | Tobject (fi, _) -> let _, tv = flatten_fields fi in if policy = Univars then pre_univars := tv :: !pre_univars; ty | _ -> assert false in ctyp (Ttyp_class (path, lid, args, present)) ty env loc | Ptyp_alias(st, alias) -> let cty = try let t = try List.assoc alias !univars with Not_found -> instance env (fst(Tbl.find alias !used_variables)) in let ty = transl_type env policy st in begin try unify_var env t ty.ctyp_type with Unify trace -> let trace = swap_list trace in raise(Error(styp.ptyp_loc, Alias_type_mismatch trace)) end; ty with Not_found -> if !Clflags.principal then begin_def (); let t = newvar () in used_variables := Tbl.add alias (t, styp.ptyp_loc) !used_variables; let ty = transl_type env policy st in begin try unify_var env t ty.ctyp_type with Unify trace -> let trace = swap_list trace in raise(Error(styp.ptyp_loc, Alias_type_mismatch trace)) end; if !Clflags.principal then begin end_def (); generalize_structure t; end; let t = instance env t in let px = Btype.proxy t in begin match px.desc with | Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias) | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias) | _ -> () end; { ty with ctyp_type = t } in ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type env loc | Ptyp_variant(fields, closed, present) -> let name = ref None in let mkfield l f = newty (Tvariant {row_fields=[l,f]; row_more=newvar(); row_bound=(); row_closed=true; row_fixed=false; row_name=None}) in let hfields = Hashtbl.create 17 in let add_typed_field loc l f = let h = Btype.hash_variant l in try let (l',f') = Hashtbl.find hfields h in (* Check for tag conflicts *) if l <> l' then raise(Error(styp.ptyp_loc, Variant_tags(l, l'))); let ty = mkfield l f and ty' = mkfield l f' in if equal env false [ty] [ty'] then () else try unify env ty ty' with Unify trace -> raise(Error(loc, Constructor_mismatch (ty,ty'))) with Not_found -> Hashtbl.add hfields h (l,f) in let rec add_field = function Rtag (l, c, stl) -> name := None; let tl = List.map (transl_type env policy) stl in let f = match present with Some present when not (List.mem l present) -> let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in Reither(c, ty_tl, false, ref None) | _ -> if List.length stl > 1 || c && stl <> [] then raise(Error(styp.ptyp_loc, Present_has_conjunction l)); match tl with [] -> Rpresent None | st :: _ -> Rpresent (Some st.ctyp_type) in add_typed_field styp.ptyp_loc l f; Ttag (l,c,tl) | Rinherit sty -> let cty = transl_type env policy sty in let ty = cty.ctyp_type in let nm = match repr cty.ctyp_type with {desc=Tconstr(p, tl, _)} -> Some(p, tl) | _ -> None in begin try (* Set name if there are no fields yet *) Hashtbl.iter (fun _ _ -> raise Exit) hfields; name := nm with Exit -> (* Unset it otherwise *) name := None end; let fl = match expand_head env cty.ctyp_type, nm with {desc=Tvariant row}, _ when Btype.static_row row -> let row = Btype.row_repr row in row.row_fields | {desc=Tvar _}, Some(p, _) -> raise(Error(sty.ptyp_loc, Unbound_type_constructor_2 p)) | _ -> raise(Error(sty.ptyp_loc, Not_a_variant ty)) in List.iter (fun (l, f) -> let f = match present with Some present when not (List.mem l present) -> begin match f with Rpresent(Some ty) -> Reither(false, [ty], false, ref None) | Rpresent None -> Reither(true, [], false, ref None) | _ -> assert false end | _ -> f in add_typed_field sty.ptyp_loc l f) fl; Tinherit cty in let tfields = List.map add_field fields in let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in begin match present with None -> () | Some present -> List.iter (fun l -> if not (List.mem_assoc l fields) then raise(Error(styp.ptyp_loc, Present_has_no_type l))) present end; let row = { row_fields = List.rev fields; row_more = newvar (); row_bound = (); row_closed = closed; row_fixed = false; row_name = !name } in let static = Btype.static_row row in let row = if static then { row with row_more = newty Tnil } else if policy <> Univars then row else { row with row_more = new_pre_univar () } in let ty = newty (Tvariant row) in ctyp (Ttyp_variant (tfields, closed, present)) ty env loc | Ptyp_poly(vars, st) -> begin_def(); let new_univars = List.map (fun name -> name, newvar ~name ()) vars in let old_univars = !univars in univars := new_univars @ !univars; let cty = transl_type env policy st in let ty = cty.ctyp_type in univars := old_univars; end_def(); generalize ty; let ty_list = List.fold_left (fun tyl (name, ty1) -> let v = Btype.proxy ty1 in if deep_occur v ty then begin match v.desc with Tvar name when v.level = Btype.generic_level -> v.desc <- Tunivar name; v :: tyl | _ -> raise (Error (styp.ptyp_loc, Cannot_quantify (name, v))) end else tyl) [] new_univars in let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in unify_var env (newvar()) ty'; ctyp (Ttyp_poly (vars, cty)) ty' env loc | Ptyp_package (p, l) -> let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in let z = narrow () in let mty = !transl_modtype env mty in widen z; let ptys = List.map (fun (s, pty) -> s, transl_type env policy pty ) l in let path = !transl_modtype_longident styp.ptyp_loc env p.txt in let ty = newty (Tpackage (path, List.map (fun (s, pty) -> s.txt) l, List.map (fun (_,cty) -> cty.ctyp_type) ptys)) in ctyp (Ttyp_package { pack_name = path; pack_type = mty.mty_type; pack_fields = ptys; pack_txt = p; }) ty env loc and transl_fields env policy seen = function [] -> newty Tnil | {field_desc = Tcfield_var}::_ -> if policy = Univars then new_pre_univar () else newvar () | {field_desc = Tcfield(s, ty1); field_loc = loc}::l -> if List.mem s seen then raise (Error (loc, Repeated_method_label s)); let ty2 = transl_fields env policy (s::seen) l in newty (Tfield (s, Fpresent, ty1.ctyp_type, ty2)) (* Make the rows "fixed" in this type, to make universal check easier *) let rec make_fixed_univars ty = let ty = repr ty in if ty.level >= Btype.lowest_level then begin Btype.mark_type_node ty; match ty.desc with | Tvariant row -> let row = Btype.row_repr row in if Btype.is_Tunivar (Btype.row_more row) then ty.desc <- Tvariant {row with row_fixed=true; row_fields = List.map (fun (s,f as p) -> match Btype.row_field_repr f with Reither (c, tl, m, r) -> s, Reither (c, tl, true, r) | _ -> p) row.row_fields}; Btype.iter_row make_fixed_univars row | _ -> Btype.iter_type_expr make_fixed_univars ty end let make_fixed_univars ty = make_fixed_univars ty; Btype.unmark_type ty let create_package_mty = create_package_mty false let globalize_used_variables env fixed = let r = ref [] in Tbl.iter (fun name (ty, loc) -> let v = new_global_var () in let snap = Btype.snapshot () in if try unify env v ty; true with _ -> Btype.backtrack snap; false then try r := (loc, v, Tbl.find name !type_variables) :: !r with Not_found -> if fixed && Btype.is_Tvar (repr ty) then raise(Error(loc, Unbound_type_variable ("'"^name))); let v2 = new_global_var () in r := (loc, v, v2) :: !r; type_variables := Tbl.add name v2 !type_variables) !used_variables; used_variables := Tbl.empty; fun () -> List.iter (function (loc, t1, t2) -> try unify env t1 t2 with Unify trace -> raise (Error(loc, Type_mismatch trace))) !r let transl_simple_type env fixed styp = univars := []; used_variables := Tbl.empty; let typ = transl_type env (if fixed then Fixed else Extensible) styp in globalize_used_variables env fixed (); make_fixed_univars typ.ctyp_type; typ let transl_simple_type_univars env styp = univars := []; used_variables := Tbl.empty; pre_univars := []; begin_def (); let typ = transl_type env Univars styp in (* Only keep already global variables in used_variables *) let new_variables = !used_variables in used_variables := Tbl.empty; Tbl.iter (fun name p -> if Tbl.mem name !type_variables then used_variables := Tbl.add name p !used_variables) new_variables; globalize_used_variables env false (); end_def (); generalize typ.ctyp_type; let univs = List.fold_left (fun acc v -> let v = repr v in match v.desc with Tvar name when v.level = Btype.generic_level -> v.desc <- Tunivar name; v :: acc | _ -> acc) [] !pre_univars in make_fixed_univars typ.ctyp_type; { typ with ctyp_type = instance env (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) } let transl_simple_type_delayed env styp = univars := []; used_variables := Tbl.empty; let typ = transl_type env Extensible styp in make_fixed_univars typ.ctyp_type; (typ, globalize_used_variables env false) let transl_type_scheme env styp = reset_type_variables(); begin_def(); let typ = transl_simple_type env false styp in end_def(); generalize typ.ctyp_type; typ (* Error report *) open Format open Printtyp let report_error ppf = function | Unbound_type_variable name -> fprintf ppf "Unbound type parameter %s" name | Unbound_type_constructor lid -> fprintf ppf "Unbound type constructor %a" longident lid | Unbound_type_constructor_2 p -> fprintf ppf "The type constructor@ %a@ is not yet completely defined" path p | Type_arity_mismatch(lid, expected, provided) -> fprintf ppf "@[The type constructor %a@ expects %i argument(s),@ \ but is here applied to %i argument(s)@]" longident lid expected provided | Bound_type_variable name -> fprintf ppf "Already bound type parameter '%s" name | Recursive_type -> fprintf ppf "This type is recursive" | Unbound_row_variable lid -> fprintf ppf "Unbound row variable in #%a" longident lid | Type_mismatch trace -> Printtyp.unification_error true trace (function ppf -> fprintf ppf "This type") ppf (function ppf -> fprintf ppf "should be an instance of type") | Alias_type_mismatch trace -> Printtyp.unification_error true trace (function ppf -> fprintf ppf "This alias is bound to type") ppf (function ppf -> fprintf ppf "but is used as an instance of type") | Present_has_conjunction l -> fprintf ppf "The present constructor %s has a conjunctive type" l | Present_has_no_type l -> fprintf ppf "The present constructor %s has no type" l | Constructor_mismatch (ty, ty') -> Printtyp.reset_and_mark_loops_list [ty; ty']; fprintf ppf "@[%s %a@ %s@ %a@]" "This variant type contains a constructor" Printtyp.type_expr ty "which should be" Printtyp.type_expr ty' | Not_a_variant ty -> Printtyp.reset_and_mark_loops ty; fprintf ppf "@[The type %a@ is not a polymorphic variant type@]" Printtyp.type_expr ty | Variant_tags (lab1, lab2) -> fprintf ppf "@[Variant tags `%s@ and `%s have the same hash value.@ %s@]" lab1 lab2 "Change one of them." | Invalid_variable_name name -> fprintf ppf "The type variable name %s is not allowed in programs" name | Cannot_quantify (name, v) -> fprintf ppf "@[The universal type variable '%s cannot be generalized:@ %s.@]" name (if Btype.is_Tvar v then "it escapes its scope" else if Btype.is_Tunivar v then "it is already bound to another variable" else "it is not a variable") | Multiple_constraints_on_type s -> fprintf ppf "Multiple constraints for type %a" longident s | Repeated_method_label s -> fprintf ppf "@[This is the second method `%s' of this object type.@ %s@]" s "Multiple occurences are not allowed." | Unbound_value lid -> fprintf ppf "Unbound value %a" longident lid | Unbound_module lid -> fprintf ppf "Unbound module %a" longident lid | Unbound_constructor lid -> fprintf ppf "Unbound constructor %a" longident lid | Unbound_label lid -> fprintf ppf "Unbound record field label %a" longident lid | Unbound_class lid -> fprintf ppf "Unbound class %a" longident lid | Unbound_modtype lid -> fprintf ppf "Unbound module type %a" longident lid | Unbound_cltype lid -> fprintf ppf "Unbound class type %a" longident lid | Ill_typed_functor_application lid -> fprintf ppf "Ill-typed functor application %a" longident lid mingw-ocaml/ocaml/typing/cmi_format.ml0000644000175000017500000000614512124403242017451 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Fabrice Le Fessant, INRIA Saclay *) (* *) (* Copyright 2012 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) type pers_flags = Rectypes type error = Not_an_interface of string | Wrong_version_interface of string * string | Corrupted_interface of string exception Error of error type cmi_infos = { cmi_name : string; cmi_sign : Types.signature_item list; cmi_crcs : (string * Digest.t) list; cmi_flags : pers_flags list; } let input_cmi ic = let (name, sign) = input_value ic in let crcs = input_value ic in let flags = input_value ic in { cmi_name = name; cmi_sign = sign; cmi_crcs = crcs; cmi_flags = flags; } let read_cmi filename = let ic = open_in_bin filename in try let buffer = Misc.input_bytes ic (String.length Config.cmi_magic_number) in if buffer <> Config.cmi_magic_number then begin close_in ic; let pre_len = String.length Config.cmi_magic_number - 3 in if String.sub buffer 0 pre_len = String.sub Config.cmi_magic_number 0 pre_len then begin let msg = if buffer < Config.cmi_magic_number then "an older" else "a newer" in raise (Error (Wrong_version_interface (filename, msg))) end else begin raise(Error(Not_an_interface filename)) end end; let cmi = input_cmi ic in close_in ic; cmi with End_of_file | Failure _ -> close_in ic; raise(Error(Corrupted_interface(filename))) | Error e -> close_in ic; raise (Error e) let output_cmi filename oc cmi = (* beware: the provided signature must have been substituted for saving *) output_string oc Config.cmi_magic_number; output_value oc (cmi.cmi_name, cmi.cmi_sign); flush oc; let crc = Digest.file filename in let crcs = (cmi.cmi_name, crc) :: cmi.cmi_crcs in output_value oc crcs; output_value oc cmi.cmi_flags; crc (* Error report *) open Format let report_error ppf = function | Not_an_interface filename -> fprintf ppf "%a@ is not a compiled interface" Location.print_filename filename | Wrong_version_interface (filename, older_newer) -> fprintf ppf "%a@ is not a compiled interface for this version of OCaml.@.\ It seems to be for %s version of OCaml." Location.print_filename filename older_newer | Corrupted_interface filename -> fprintf ppf "Corrupted compiled interface@ %a" Location.print_filename filename mingw-ocaml/ocaml/typing/typedtree.mli0000644000175000017500000003174312124403242017511 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Abstract syntax tree after typing *) open Asttypes open Types (* Value expressions for the core language *) type partial = Partial | Total type optional = Required | Optional type pattern = { pat_desc: pattern_desc; pat_loc: Location.t; pat_extra : (pat_extra * Location.t) list; pat_type: type_expr; mutable pat_env: Env.t } and pat_extra = | Tpat_constraint of core_type | Tpat_type of Path.t * Longident.t loc | Tpat_unpack and pattern_desc = Tpat_any | Tpat_var of Ident.t * string loc | Tpat_alias of pattern * Ident.t * string loc | Tpat_constant of constant | Tpat_tuple of pattern list | Tpat_construct of Path.t * Longident.t loc * constructor_description * pattern list * bool | Tpat_variant of label * pattern option * row_desc ref | Tpat_record of (Path.t * Longident.t loc * label_description * pattern) list * closed_flag | Tpat_array of pattern list | Tpat_or of pattern * pattern * row_desc option | Tpat_lazy of pattern and expression = { exp_desc: expression_desc; exp_loc: Location.t; exp_extra : (exp_extra * Location.t) list; exp_type: type_expr; exp_env: Env.t } and exp_extra = | Texp_constraint of core_type option * core_type option | Texp_open of Path.t * Longident.t loc * Env.t | Texp_poly of core_type option | Texp_newtype of string and expression_desc = Texp_ident of Path.t * Longident.t loc * Types.value_description | Texp_constant of constant | Texp_let of rec_flag * (pattern * expression) list * expression | Texp_function of label * (pattern * expression) list * partial | Texp_apply of expression * (label * expression option * optional) list | Texp_match of expression * (pattern * expression) list * partial | Texp_try of expression * (pattern * expression) list | Texp_tuple of expression list | Texp_construct of Path.t * Longident.t loc * constructor_description * expression list * bool | Texp_variant of label * expression option | Texp_record of (Path.t * Longident.t loc * label_description * expression) list * expression option | Texp_field of expression * Path.t * Longident.t loc * label_description | Texp_setfield of expression * Path.t * Longident.t loc * label_description * expression | Texp_array of expression list | Texp_ifthenelse of expression * expression * expression option | Texp_sequence of expression * expression | Texp_while of expression * expression | Texp_for of Ident.t * string loc * expression * expression * direction_flag * expression | Texp_when of expression * expression | Texp_send of expression * meth * expression option | Texp_new of Path.t * Longident.t loc * Types.class_declaration | Texp_instvar of Path.t * Path.t * string loc | Texp_setinstvar of Path.t * Path.t * string loc * expression | Texp_override of Path.t * (Path.t * string loc * expression) list | Texp_letmodule of Ident.t * string loc * module_expr * expression | Texp_assert of expression | Texp_assertfalse | Texp_lazy of expression | Texp_object of class_structure * string list | Texp_pack of module_expr and meth = Tmeth_name of string | Tmeth_val of Ident.t (* Value expressions for the class language *) and class_expr = { cl_desc: class_expr_desc; cl_loc: Location.t; cl_type: Types.class_type; cl_env: Env.t } and class_expr_desc = Tcl_ident of Path.t * Longident.t loc * core_type list | Tcl_structure of class_structure | Tcl_fun of label * pattern * (Ident.t * string loc * expression) list * class_expr * partial | Tcl_apply of class_expr * (label * expression option * optional) list | Tcl_let of rec_flag * (pattern * expression) list * (Ident.t * string loc * expression) list * class_expr | Tcl_constraint of class_expr * class_type option * string list * string list * Concr.t (* Visible instance variables, methods and concretes methods *) and class_structure = { cstr_pat : pattern; cstr_fields: class_field list; cstr_type : Types.class_signature; cstr_meths: Ident.t Meths.t } and class_field = { cf_desc : class_field_desc; cf_loc : Location.t; } and class_field_kind = Tcfk_virtual of core_type | Tcfk_concrete of expression and class_field_desc = Tcf_inher of override_flag * class_expr * string option * (string * Ident.t) list * (string * Ident.t) list (* Inherited instance variables and concrete methods *) | Tcf_val of string * string loc * mutable_flag * Ident.t * class_field_kind * bool (* None = virtual, true = override *) | Tcf_meth of string * string loc * private_flag * class_field_kind * bool | Tcf_constr of core_type * core_type (* | Tcf_let of rec_flag * (pattern * expression) list * (Ident.t * string loc * expression) list *) | Tcf_init of expression (* Value expressions for the module language *) and module_expr = { mod_desc: module_expr_desc; mod_loc: Location.t; mod_type: Types.module_type; mod_env: Env.t } and module_type_constraint = Tmodtype_implicit | Tmodtype_explicit of module_type and module_expr_desc = Tmod_ident of Path.t * Longident.t loc | Tmod_structure of structure | Tmod_functor of Ident.t * string loc * module_type * module_expr | Tmod_apply of module_expr * module_expr * module_coercion | Tmod_constraint of module_expr * Types.module_type * module_type_constraint * module_coercion | Tmod_unpack of expression * Types.module_type and structure = { str_items : structure_item list; str_type : Types.signature; str_final_env : Env.t; } and structure_item = { str_desc : structure_item_desc; str_loc : Location.t; str_env : Env.t } and structure_item_desc = Tstr_eval of expression | Tstr_value of rec_flag * (pattern * expression) list | Tstr_primitive of Ident.t * string loc * value_description | Tstr_type of (Ident.t * string loc * type_declaration) list | Tstr_exception of Ident.t * string loc * exception_declaration | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc | Tstr_module of Ident.t * string loc * module_expr | Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list | Tstr_modtype of Ident.t * string loc * module_type | Tstr_open of Path.t * Longident.t loc | Tstr_class of (class_declaration * string list * virtual_flag) list | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list | Tstr_include of module_expr * Ident.t list and module_coercion = Tcoerce_none | Tcoerce_structure of (int * module_coercion) list | Tcoerce_functor of module_coercion * module_coercion | Tcoerce_primitive of Primitive.description and module_type = { mty_desc: module_type_desc; mty_type : Types.module_type; mty_env : Env.t; mty_loc: Location.t } and module_type_desc = Tmty_ident of Path.t * Longident.t loc | Tmty_signature of signature | Tmty_functor of Ident.t * string loc * module_type * module_type | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list | Tmty_typeof of module_expr and signature = { sig_items : signature_item list; sig_type : Types.signature; sig_final_env : Env.t; } and signature_item = { sig_desc: signature_item_desc; sig_env : Env.t; (* BINANNOT ADDED *) sig_loc: Location.t } and signature_item_desc = Tsig_value of Ident.t * string loc * value_description | Tsig_type of (Ident.t * string loc * type_declaration) list | Tsig_exception of Ident.t * string loc * exception_declaration | Tsig_module of Ident.t * string loc * module_type | Tsig_recmodule of (Ident.t * string loc * module_type) list | Tsig_modtype of Ident.t * string loc * modtype_declaration | Tsig_open of Path.t * Longident.t loc | Tsig_include of module_type * Types.signature | Tsig_class of class_description list | Tsig_class_type of class_type_declaration list and modtype_declaration = Tmodtype_abstract | Tmodtype_manifest of module_type and with_constraint = Twith_type of type_declaration | Twith_module of Path.t * Longident.t loc | Twith_typesubst of type_declaration | Twith_modsubst of Path.t * Longident.t loc and core_type = (* mutable because of [Typeclass.declare_method] *) { mutable ctyp_desc : core_type_desc; mutable ctyp_type : type_expr; ctyp_env : Env.t; (* BINANNOT ADDED *) ctyp_loc : Location.t } and core_type_desc = Ttyp_any | Ttyp_var of string | Ttyp_arrow of label * core_type * core_type | Ttyp_tuple of core_type list | Ttyp_constr of Path.t * Longident.t loc * core_type list | Ttyp_object of core_field_type list | Ttyp_class of Path.t * Longident.t loc * core_type list * label list | Ttyp_alias of core_type * string | Ttyp_variant of row_field list * bool * label list option | Ttyp_poly of string list * core_type | Ttyp_package of package_type and package_type = { pack_name : Path.t; pack_fields : (Longident.t loc * core_type) list; pack_type : Types.module_type; pack_txt : Longident.t loc; } and core_field_type = { field_desc: core_field_desc; field_loc: Location.t } and core_field_desc = Tcfield of string * core_type | Tcfield_var and row_field = Ttag of label * bool * core_type list | Tinherit of core_type and value_description = { val_desc : core_type; val_val : Types.value_description; val_prim : string list; val_loc : Location.t; } and type_declaration = { typ_params: string loc option list; typ_type : Types.type_declaration; typ_cstrs: (core_type * core_type * Location.t) list; typ_kind: type_kind; typ_private: private_flag; typ_manifest: core_type option; typ_variance: (bool * bool) list; typ_loc: Location.t } and type_kind = Ttype_abstract | Ttype_variant of (Ident.t * string loc * core_type list * Location.t) list | Ttype_record of (Ident.t * string loc * mutable_flag * core_type * Location.t) list and exception_declaration = { exn_params : core_type list; exn_exn : Types.exception_declaration; exn_loc : Location.t } and class_type = { cltyp_desc: class_type_desc; cltyp_type : Types.class_type; cltyp_env : Env.t; (* BINANNOT ADDED *) cltyp_loc: Location.t } and class_type_desc = Tcty_constr of Path.t * Longident.t loc * core_type list | Tcty_signature of class_signature | Tcty_fun of label * core_type * class_type and class_signature = { csig_self : core_type; csig_fields : class_type_field list; csig_type : Types.class_signature; csig_loc : Location.t; } and class_type_field = { ctf_desc : class_type_field_desc; ctf_loc : Location.t; } and class_type_field_desc = Tctf_inher of class_type | Tctf_val of (string * mutable_flag * virtual_flag * core_type) | Tctf_virt of (string * private_flag * core_type) | Tctf_meth of (string * private_flag * core_type) | Tctf_cstr of (core_type * core_type) and class_declaration = class_expr class_infos and class_description = class_type class_infos and class_type_declaration = class_type class_infos and 'a class_infos = { ci_virt: virtual_flag; ci_params: string loc list * Location.t; ci_id_name : string loc; ci_id_class: Ident.t; ci_id_class_type : Ident.t; ci_id_object : Ident.t; ci_id_typesharp : Ident.t; ci_expr: 'a; ci_decl: Types.class_declaration; ci_type_decl : Types.class_type_declaration; ci_variance: (bool * bool) list; ci_loc: Location.t } (* Auxiliary functions over the a.s.t. *) val iter_pattern_desc: (pattern -> unit) -> pattern_desc -> unit val map_pattern_desc: (pattern -> pattern) -> pattern_desc -> pattern_desc val let_bound_idents: (pattern * expression) list -> Ident.t list val rev_let_bound_idents: (pattern * expression) list -> Ident.t list val pat_bound_idents: pattern -> Ident.t list val let_bound_idents_with_loc: (pattern * expression) list -> (Ident.t * string loc) list val rev_let_bound_idents_with_loc: (pattern * expression) list -> (Ident.t * string loc) list (* Alpha conversion of patterns *) val alpha_pat: (Ident.t * Ident.t) list -> pattern -> pattern val mknoloc: 'a -> 'a Asttypes.loc val mkloc: 'a -> Location.t -> 'a Asttypes.loc val pat_bound_idents: pattern -> (Ident.t * string Asttypes.loc) list mingw-ocaml/ocaml/typing/typedtree.ml0000644000175000017500000003570112124403242017336 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Abstract syntax tree after typing *) open Misc open Asttypes open Types (* Value expressions for the core language *) type partial = Partial | Total type optional = Required | Optional type pattern = { pat_desc: pattern_desc; pat_loc: Location.t; pat_extra : (pat_extra * Location.t) list; pat_type: type_expr; mutable pat_env: Env.t } and pat_extra = | Tpat_constraint of core_type | Tpat_type of Path.t * Longident.t loc | Tpat_unpack and pattern_desc = Tpat_any | Tpat_var of Ident.t * string loc | Tpat_alias of pattern * Ident.t * string loc | Tpat_constant of constant | Tpat_tuple of pattern list | Tpat_construct of Path.t * Longident.t loc * constructor_description * pattern list * bool | Tpat_variant of label * pattern option * row_desc ref | Tpat_record of (Path.t * Longident.t loc * label_description * pattern) list * closed_flag | Tpat_array of pattern list | Tpat_or of pattern * pattern * row_desc option | Tpat_lazy of pattern and expression = { exp_desc: expression_desc; exp_loc: Location.t; exp_extra : (exp_extra * Location.t) list; exp_type: type_expr; exp_env: Env.t } and exp_extra = | Texp_constraint of core_type option * core_type option | Texp_open of Path.t * Longident.t loc * Env.t | Texp_poly of core_type option | Texp_newtype of string and expression_desc = Texp_ident of Path.t * Longident.t loc * Types.value_description | Texp_constant of constant | Texp_let of rec_flag * (pattern * expression) list * expression | Texp_function of label * (pattern * expression) list * partial | Texp_apply of expression * (label * expression option * optional) list | Texp_match of expression * (pattern * expression) list * partial | Texp_try of expression * (pattern * expression) list | Texp_tuple of expression list | Texp_construct of Path.t * Longident.t loc * constructor_description * expression list * bool | Texp_variant of label * expression option | Texp_record of (Path.t * Longident.t loc * label_description * expression) list * expression option | Texp_field of expression * Path.t * Longident.t loc * label_description | Texp_setfield of expression * Path.t * Longident.t loc * label_description * expression | Texp_array of expression list | Texp_ifthenelse of expression * expression * expression option | Texp_sequence of expression * expression | Texp_while of expression * expression | Texp_for of Ident.t * string loc * expression * expression * direction_flag * expression | Texp_when of expression * expression | Texp_send of expression * meth * expression option | Texp_new of Path.t * Longident.t loc * Types.class_declaration | Texp_instvar of Path.t * Path.t * string loc | Texp_setinstvar of Path.t * Path.t * string loc * expression | Texp_override of Path.t * (Path.t * string loc * expression) list | Texp_letmodule of Ident.t * string loc * module_expr * expression | Texp_assert of expression | Texp_assertfalse | Texp_lazy of expression | Texp_object of class_structure * string list | Texp_pack of module_expr and meth = Tmeth_name of string | Tmeth_val of Ident.t (* Value expressions for the class language *) and class_expr = { cl_desc: class_expr_desc; cl_loc: Location.t; cl_type: Types.class_type; cl_env: Env.t } and class_expr_desc = Tcl_ident of Path.t * Longident.t loc * core_type list (* Pcl_constr *) | Tcl_structure of class_structure | Tcl_fun of label * pattern * (Ident.t * string loc * expression) list * class_expr * partial | Tcl_apply of class_expr * (label * expression option * optional) list | Tcl_let of rec_flag * (pattern * expression) list * (Ident.t * string loc * expression) list * class_expr | Tcl_constraint of class_expr * class_type option * string list * string list * Concr.t (* Visible instance variables, methods and concretes methods *) and class_structure = { cstr_pat : pattern; cstr_fields: class_field list; cstr_type : Types.class_signature; cstr_meths: Ident.t Meths.t } and class_field = { cf_desc : class_field_desc; cf_loc : Location.t; } and class_field_kind = Tcfk_virtual of core_type | Tcfk_concrete of expression and class_field_desc = Tcf_inher of override_flag * class_expr * string option * (string * Ident.t) list * (string * Ident.t) list (* Inherited instance variables and concrete methods *) | Tcf_val of string * string loc * mutable_flag * Ident.t * class_field_kind * bool (* None = virtual, true = override *) | Tcf_meth of string * string loc * private_flag * class_field_kind * bool | Tcf_constr of core_type * core_type (* | Tcf_let of rec_flag * (pattern * expression) list * (Ident.t * string loc * expression) list *) | Tcf_init of expression (* Value expressions for the module language *) and module_expr = { mod_desc: module_expr_desc; mod_loc: Location.t; mod_type: Types.module_type; mod_env: Env.t } and module_type_constraint = Tmodtype_implicit | Tmodtype_explicit of module_type and module_expr_desc = Tmod_ident of Path.t * Longident.t loc | Tmod_structure of structure | Tmod_functor of Ident.t * string loc * module_type * module_expr | Tmod_apply of module_expr * module_expr * module_coercion | Tmod_constraint of module_expr * Types.module_type * module_type_constraint * module_coercion | Tmod_unpack of expression * Types.module_type and structure = { str_items : structure_item list; str_type : Types.signature; str_final_env : Env.t; } and structure_item = { str_desc : structure_item_desc; str_loc : Location.t; str_env : Env.t } and structure_item_desc = Tstr_eval of expression | Tstr_value of rec_flag * (pattern * expression) list | Tstr_primitive of Ident.t * string loc * value_description | Tstr_type of (Ident.t * string loc * type_declaration) list | Tstr_exception of Ident.t * string loc * exception_declaration | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc | Tstr_module of Ident.t * string loc * module_expr | Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list | Tstr_modtype of Ident.t * string loc * module_type | Tstr_open of Path.t * Longident.t loc | Tstr_class of (class_declaration * string list * virtual_flag) list | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list | Tstr_include of module_expr * Ident.t list and module_coercion = Tcoerce_none | Tcoerce_structure of (int * module_coercion) list | Tcoerce_functor of module_coercion * module_coercion | Tcoerce_primitive of Primitive.description and module_type = { mty_desc: module_type_desc; mty_type : Types.module_type; mty_env : Env.t; (* BINANNOT ADDED *) mty_loc: Location.t } and module_type_desc = Tmty_ident of Path.t * Longident.t loc | Tmty_signature of signature | Tmty_functor of Ident.t * string loc * module_type * module_type | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list | Tmty_typeof of module_expr and signature = { sig_items : signature_item list; sig_type : Types.signature; sig_final_env : Env.t; } and signature_item = { sig_desc: signature_item_desc; sig_env : Env.t; (* BINANNOT ADDED *) sig_loc: Location.t } and signature_item_desc = Tsig_value of Ident.t * string loc * value_description | Tsig_type of (Ident.t * string loc * type_declaration) list | Tsig_exception of Ident.t * string loc * exception_declaration | Tsig_module of Ident.t * string loc * module_type | Tsig_recmodule of (Ident.t * string loc * module_type) list | Tsig_modtype of Ident.t * string loc * modtype_declaration | Tsig_open of Path.t * Longident.t loc | Tsig_include of module_type * Types.signature | Tsig_class of class_description list | Tsig_class_type of class_type_declaration list and modtype_declaration = Tmodtype_abstract | Tmodtype_manifest of module_type and with_constraint = Twith_type of type_declaration | Twith_module of Path.t * Longident.t loc | Twith_typesubst of type_declaration | Twith_modsubst of Path.t * Longident.t loc and core_type = (* mutable because of [Typeclass.declare_method] *) { mutable ctyp_desc : core_type_desc; mutable ctyp_type : type_expr; ctyp_env : Env.t; (* BINANNOT ADDED *) ctyp_loc : Location.t } and core_type_desc = Ttyp_any | Ttyp_var of string | Ttyp_arrow of label * core_type * core_type | Ttyp_tuple of core_type list | Ttyp_constr of Path.t * Longident.t loc * core_type list | Ttyp_object of core_field_type list | Ttyp_class of Path.t * Longident.t loc * core_type list * label list | Ttyp_alias of core_type * string | Ttyp_variant of row_field list * bool * label list option | Ttyp_poly of string list * core_type | Ttyp_package of package_type and package_type = { pack_name : Path.t; pack_fields : (Longident.t loc * core_type) list; pack_type : Types.module_type; pack_txt : Longident.t loc; } and core_field_type = { field_desc: core_field_desc; field_loc: Location.t } and core_field_desc = Tcfield of string * core_type | Tcfield_var and row_field = Ttag of label * bool * core_type list | Tinherit of core_type and value_description = { val_desc : core_type; val_val : Types.value_description; val_prim : string list; val_loc : Location.t; } and type_declaration = { typ_params: string loc option list; typ_type : Types.type_declaration; typ_cstrs: (core_type * core_type * Location.t) list; typ_kind: type_kind; typ_private: private_flag; typ_manifest: core_type option; typ_variance: (bool * bool) list; typ_loc: Location.t } and type_kind = Ttype_abstract | Ttype_variant of (Ident.t * string loc * core_type list * Location.t) list | Ttype_record of (Ident.t * string loc * mutable_flag * core_type * Location.t) list and exception_declaration = { exn_params : core_type list; exn_exn : Types.exception_declaration; exn_loc : Location.t } and class_type = { cltyp_desc: class_type_desc; cltyp_type : Types.class_type; cltyp_env : Env.t; (* BINANNOT ADDED *) cltyp_loc: Location.t } and class_type_desc = Tcty_constr of Path.t * Longident.t loc * core_type list | Tcty_signature of class_signature | Tcty_fun of label * core_type * class_type and class_signature = { csig_self : core_type; csig_fields : class_type_field list; csig_type : Types.class_signature; csig_loc : Location.t; } and class_type_field = { ctf_desc : class_type_field_desc; ctf_loc : Location.t; } and class_type_field_desc = Tctf_inher of class_type | Tctf_val of (string * mutable_flag * virtual_flag * core_type) | Tctf_virt of (string * private_flag * core_type) | Tctf_meth of (string * private_flag * core_type) | Tctf_cstr of (core_type * core_type) and class_declaration = class_expr class_infos and class_description = class_type class_infos and class_type_declaration = class_type class_infos and 'a class_infos = { ci_virt: virtual_flag; ci_params: string loc list * Location.t; ci_id_name : string loc; ci_id_class: Ident.t; ci_id_class_type : Ident.t; ci_id_object : Ident.t; ci_id_typesharp : Ident.t; ci_expr: 'a; ci_decl: Types.class_declaration; ci_type_decl : Types.class_type_declaration; ci_variance: (bool * bool) list; ci_loc: Location.t } (* Auxiliary functions over the a.s.t. *) let iter_pattern_desc f = function | Tpat_alias(p, _, _) -> f p | Tpat_tuple patl -> List.iter f patl | Tpat_construct(_, _, cstr, patl, _) -> List.iter f patl | Tpat_variant(_, pat, _) -> may f pat | Tpat_record (lbl_pat_list, _) -> List.iter (fun (_, _, lbl, pat) -> f pat) lbl_pat_list | Tpat_array patl -> List.iter f patl | Tpat_or(p1, p2, _) -> f p1; f p2 | Tpat_lazy p -> f p | Tpat_any | Tpat_var _ | Tpat_constant _ -> () let map_pattern_desc f d = match d with | Tpat_alias (p1, id, s) -> Tpat_alias (f p1, id, s) | Tpat_tuple pats -> Tpat_tuple (List.map f pats) | Tpat_record (lpats, closed) -> Tpat_record (List.map (fun ( lid, lid_loc, l,p) -> lid, lid_loc, l, f p) lpats, closed) | Tpat_construct (lid, lid_loc, c,pats, arity) -> Tpat_construct (lid, lid_loc, c, List.map f pats, arity) | Tpat_array pats -> Tpat_array (List.map f pats) | Tpat_lazy p1 -> Tpat_lazy (f p1) | Tpat_variant (x1, Some p1, x2) -> Tpat_variant (x1, Some (f p1), x2) | Tpat_or (p1,p2,path) -> Tpat_or (f p1, f p2, path) | Tpat_var _ | Tpat_constant _ | Tpat_any | Tpat_variant (_,None,_) -> d (* List the identifiers bound by a pattern or a let *) let idents = ref([]: (Ident.t * string loc) list) let rec bound_idents pat = match pat.pat_desc with | Tpat_var (id,s) -> idents := (id,s) :: !idents | Tpat_alias(p, id, s ) -> bound_idents p; idents := (id,s) :: !idents | Tpat_or(p1, _, _) -> (* Invariant : both arguments binds the same variables *) bound_idents p1 | d -> iter_pattern_desc bound_idents d let pat_bound_idents pat = idents := []; bound_idents pat; let res = !idents in idents := []; res let rev_let_bound_idents_with_loc pat_expr_list = idents := []; List.iter (fun (pat, expr) -> bound_idents pat) pat_expr_list; let res = !idents in idents := []; res let let_bound_idents_with_loc pat_expr_list = List.rev(rev_let_bound_idents_with_loc pat_expr_list) let rev_let_bound_idents pat = List.map fst (rev_let_bound_idents_with_loc pat) let let_bound_idents pat = List.map fst (let_bound_idents_with_loc pat) let alpha_var env id = List.assoc id env let rec alpha_pat env p = match p.pat_desc with | Tpat_var (id, s) -> (* note the ``Not_found'' case *) {p with pat_desc = try Tpat_var (alpha_var env id, s) with | Not_found -> Tpat_any} | Tpat_alias (p1, id, s) -> let new_p = alpha_pat env p1 in begin try {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)} with | Not_found -> new_p end | d -> {p with pat_desc = map_pattern_desc (alpha_pat env) d} let mkloc = Location.mkloc let mknoloc = Location.mknoloc mingw-ocaml/ocaml/typing/ident.ml0000644000175000017500000001203212124403242016424 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Format type t = { stamp: int; name: string; mutable flags: int } let global_flag = 1 let predef_exn_flag = 2 (* A stamp of 0 denotes a persistent identifier *) let currentstamp = ref 0 let create s = incr currentstamp; { name = s; stamp = !currentstamp; flags = 0 } let create_predef_exn s = incr currentstamp; { name = s; stamp = !currentstamp; flags = predef_exn_flag } let create_persistent s = { name = s; stamp = 0; flags = global_flag } let rename i = incr currentstamp; { i with stamp = !currentstamp } let name i = i.name let stamp i = i.stamp let unique_name i = i.name ^ "_" ^ string_of_int i.stamp let unique_toplevel_name i = i.name ^ "/" ^ string_of_int i.stamp let persistent i = (i.stamp = 0) let equal i1 i2 = i1.name = i2.name let same i1 i2 = i1 = i2 (* Possibly more efficient version (with a real compiler, at least): if i1.stamp <> 0 then i1.stamp = i2.stamp else i2.stamp = 0 && i1.name = i2.name *) let binding_time i = i.stamp let current_time() = !currentstamp let set_current_time t = currentstamp := max !currentstamp t let reinit_level = ref (-1) let reinit () = if !reinit_level < 0 then reinit_level := !currentstamp else currentstamp := !reinit_level let hide i = { i with stamp = -1 } let make_global i = i.flags <- i.flags lor global_flag let global i = (i.flags land global_flag) <> 0 let is_predef_exn i = (i.flags land predef_exn_flag) <> 0 let print ppf i = match i.stamp with | 0 -> fprintf ppf "%s!" i.name | -1 -> fprintf ppf "%s#" i.name | n -> fprintf ppf "%s/%i%s" i.name n (if global i then "g" else "") type 'a tbl = Empty | Node of 'a tbl * 'a data * 'a tbl * int and 'a data = { ident: t; data: 'a; previous: 'a data option } let empty = Empty (* Inline expansion of height for better speed * let height = function * Empty -> 0 * | Node(_,_,_,h) -> h *) let mknode l d r = let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in Node(l, d, r, (if hl >= hr then hl + 1 else hr + 1)) let balance l d r = let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in if hl > hr + 1 then match l with | Node (ll, ld, lr, _) when (match ll with Empty -> 0 | Node(_,_,_,h) -> h) >= (match lr with Empty -> 0 | Node(_,_,_,h) -> h) -> mknode ll ld (mknode lr d r) | Node (ll, ld, Node(lrl, lrd, lrr, _), _) -> mknode (mknode ll ld lrl) lrd (mknode lrr d r) | _ -> assert false else if hr > hl + 1 then match r with | Node (rl, rd, rr, _) when (match rr with Empty -> 0 | Node(_,_,_,h) -> h) >= (match rl with Empty -> 0 | Node(_,_,_,h) -> h) -> mknode (mknode l d rl) rd rr | Node (Node (rll, rld, rlr, _), rd, rr, _) -> mknode (mknode l d rll) rld (mknode rlr rd rr) | _ -> assert false else mknode l d r let rec add id data = function Empty -> Node(Empty, {ident = id; data = data; previous = None}, Empty, 1) | Node(l, k, r, h) -> let c = compare id.name k.ident.name in if c = 0 then Node(l, {ident = id; data = data; previous = Some k}, r, h) else if c < 0 then balance (add id data l) k r else balance l k (add id data r) let rec find_stamp s = function None -> raise Not_found | Some k -> if k.ident.stamp = s then k.data else find_stamp s k.previous let rec find_same id = function Empty -> raise Not_found | Node(l, k, r, _) -> let c = compare id.name k.ident.name in if c = 0 then if id.stamp = k.ident.stamp then k.data else find_stamp id.stamp k.previous else find_same id (if c < 0 then l else r) let rec find_name name = function Empty -> raise Not_found | Node(l, k, r, _) -> let c = compare name k.ident.name in if c = 0 then k.data else find_name name (if c < 0 then l else r) let rec keys_aux stack accu = function Empty -> begin match stack with [] -> accu | a :: l -> keys_aux l accu a end | Node(l, k, r, _) -> keys_aux (l :: stack) (k.ident :: accu) r let keys tbl = keys_aux [] [] tbl mingw-ocaml/ocaml/typing/mtype.mli0000644000175000017500000000401112124403242016626 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Operations on module types *) open Types val scrape: Env.t -> module_type -> module_type (* Expand toplevel module type abbreviations till hitting a "hard" module type (signature, functor, or abstract module type ident. *) val freshen: module_type -> module_type (* Return an alpha-equivalent copy of the given module type where bound identifiers are fresh. *) val strengthen: Env.t -> module_type -> Path.t -> module_type (* Strengthen abstract type components relative to the given path. *) val nondep_supertype: Env.t -> Ident.t -> module_type -> module_type (* Return the smallest supertype of the given type in which the given ident does not appear. Raise [Not_found] if no such type exists. *) val no_code_needed: Env.t -> module_type -> bool val no_code_needed_sig: Env.t -> signature -> bool (* Determine whether a module needs no implementation code, i.e. consists only of type definitions. *) val enrich_modtype: Env.t -> Path.t -> module_type -> module_type val enrich_typedecl: Env.t -> Path.t -> type_declaration -> type_declaration val type_paths: Env.t -> Path.t -> module_type -> Path.t list mingw-ocaml/ocaml/typing/cmt_format.ml0000644000175000017500000011504412124403242017463 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Fabrice Le Fessant, INRIA Saclay *) (* *) (* Copyright 2012 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) open Cmi_format open Typedtree (* Note that in Typerex, there is an awful hack to save a cmt file together with the interface file that was generated by ocaml (this is because the installed version of ocaml might differ from the one integrated in Typerex). *) let read_magic_number ic = let len_magic_number = String.length Config.cmt_magic_number in let magic_number = String.create len_magic_number in really_input ic magic_number 0 len_magic_number; magic_number type binary_annots = | Packed of Types.signature * string list | Implementation of structure | Interface of signature | Partial_implementation of binary_part array | Partial_interface of binary_part array and binary_part = | Partial_structure of structure | Partial_structure_item of structure_item | Partial_expression of expression | Partial_pattern of pattern | Partial_class_expr of class_expr | Partial_signature of signature | Partial_signature_item of signature_item | Partial_module_type of module_type type cmt_infos = { cmt_modname : string; cmt_annots : binary_annots; cmt_comments : (string * Location.t) list; cmt_args : string array; cmt_sourcefile : string option; cmt_builddir : string; cmt_loadpath : string list; cmt_source_digest : Digest.t option; cmt_initial_env : Env.t; cmt_imports : (string * Digest.t) list; cmt_interface_digest : Digest.t option; cmt_use_summaries : bool; } type error = Not_a_typedtree of string let need_to_clear_env = try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false with Not_found -> true (* Re-introduce sharing after clearing environments *) let env_hcons = Hashtbl.create 133 let keep_only_summary env = let new_env = Env.keep_only_summary env in try Hashtbl.find env_hcons new_env with Not_found -> Hashtbl.add env_hcons new_env new_env; new_env let clear_env_hcons () = Hashtbl.clear env_hcons module TypedtreeMap : sig open Asttypes open Typedtree module type MapArgument = sig val enter_structure : structure -> structure val enter_value_description : value_description -> value_description val enter_type_declaration : type_declaration -> type_declaration val enter_exception_declaration : exception_declaration -> exception_declaration val enter_pattern : pattern -> pattern val enter_expression : expression -> expression val enter_package_type : package_type -> package_type val enter_signature : signature -> signature val enter_signature_item : signature_item -> signature_item val enter_modtype_declaration : modtype_declaration -> modtype_declaration val enter_module_type : module_type -> module_type val enter_module_expr : module_expr -> module_expr val enter_with_constraint : with_constraint -> with_constraint val enter_class_expr : class_expr -> class_expr val enter_class_signature : class_signature -> class_signature val enter_class_description : class_description -> class_description val enter_class_type_declaration : class_type_declaration -> class_type_declaration val enter_class_infos : 'a class_infos -> 'a class_infos val enter_class_type : class_type -> class_type val enter_class_type_field : class_type_field -> class_type_field val enter_core_type : core_type -> core_type val enter_core_field_type : core_field_type -> core_field_type val enter_class_structure : class_structure -> class_structure val enter_class_field : class_field -> class_field val enter_structure_item : structure_item -> structure_item val leave_structure : structure -> structure val leave_value_description : value_description -> value_description val leave_type_declaration : type_declaration -> type_declaration val leave_exception_declaration : exception_declaration -> exception_declaration val leave_pattern : pattern -> pattern val leave_expression : expression -> expression val leave_package_type : package_type -> package_type val leave_signature : signature -> signature val leave_signature_item : signature_item -> signature_item val leave_modtype_declaration : modtype_declaration -> modtype_declaration val leave_module_type : module_type -> module_type val leave_module_expr : module_expr -> module_expr val leave_with_constraint : with_constraint -> with_constraint val leave_class_expr : class_expr -> class_expr val leave_class_signature : class_signature -> class_signature val leave_class_description : class_description -> class_description val leave_class_type_declaration : class_type_declaration -> class_type_declaration val leave_class_infos : 'a class_infos -> 'a class_infos val leave_class_type : class_type -> class_type val leave_class_type_field : class_type_field -> class_type_field val leave_core_type : core_type -> core_type val leave_core_field_type : core_field_type -> core_field_type val leave_class_structure : class_structure -> class_structure val leave_class_field : class_field -> class_field val leave_structure_item : structure_item -> structure_item end module MakeMap : functor (Iter : MapArgument) -> sig val map_structure : structure -> structure val map_pattern : pattern -> pattern val map_structure_item : structure_item -> structure_item val map_expression : expression -> expression val map_class_expr : class_expr -> class_expr val map_signature : signature -> signature val map_signature_item : signature_item -> signature_item val map_module_type : module_type -> module_type end module DefaultMapArgument : MapArgument end = struct open Asttypes open Typedtree module type MapArgument = sig val enter_structure : structure -> structure val enter_value_description : value_description -> value_description val enter_type_declaration : type_declaration -> type_declaration val enter_exception_declaration : exception_declaration -> exception_declaration val enter_pattern : pattern -> pattern val enter_expression : expression -> expression val enter_package_type : package_type -> package_type val enter_signature : signature -> signature val enter_signature_item : signature_item -> signature_item val enter_modtype_declaration : modtype_declaration -> modtype_declaration val enter_module_type : module_type -> module_type val enter_module_expr : module_expr -> module_expr val enter_with_constraint : with_constraint -> with_constraint val enter_class_expr : class_expr -> class_expr val enter_class_signature : class_signature -> class_signature val enter_class_description : class_description -> class_description val enter_class_type_declaration : class_type_declaration -> class_type_declaration val enter_class_infos : 'a class_infos -> 'a class_infos val enter_class_type : class_type -> class_type val enter_class_type_field : class_type_field -> class_type_field val enter_core_type : core_type -> core_type val enter_core_field_type : core_field_type -> core_field_type val enter_class_structure : class_structure -> class_structure val enter_class_field : class_field -> class_field val enter_structure_item : structure_item -> structure_item val leave_structure : structure -> structure val leave_value_description : value_description -> value_description val leave_type_declaration : type_declaration -> type_declaration val leave_exception_declaration : exception_declaration -> exception_declaration val leave_pattern : pattern -> pattern val leave_expression : expression -> expression val leave_package_type : package_type -> package_type val leave_signature : signature -> signature val leave_signature_item : signature_item -> signature_item val leave_modtype_declaration : modtype_declaration -> modtype_declaration val leave_module_type : module_type -> module_type val leave_module_expr : module_expr -> module_expr val leave_with_constraint : with_constraint -> with_constraint val leave_class_expr : class_expr -> class_expr val leave_class_signature : class_signature -> class_signature val leave_class_description : class_description -> class_description val leave_class_type_declaration : class_type_declaration -> class_type_declaration val leave_class_infos : 'a class_infos -> 'a class_infos val leave_class_type : class_type -> class_type val leave_class_type_field : class_type_field -> class_type_field val leave_core_type : core_type -> core_type val leave_core_field_type : core_field_type -> core_field_type val leave_class_structure : class_structure -> class_structure val leave_class_field : class_field -> class_field val leave_structure_item : structure_item -> structure_item end module MakeMap(Map : MapArgument) = struct let may_map f v = match v with None -> v | Some x -> Some (f x) open Misc open Asttypes let rec map_structure str = let str = Map.enter_structure str in let str_items = List.map map_structure_item str.str_items in Map.leave_structure { str with str_items = str_items } and map_binding (pat, exp) = (map_pattern pat, map_expression exp) and map_bindings rec_flag list = List.map map_binding list and map_structure_item item = let item = Map.enter_structure_item item in let str_desc = match item.str_desc with Tstr_eval exp -> Tstr_eval (map_expression exp) | Tstr_value (rec_flag, list) -> Tstr_value (rec_flag, map_bindings rec_flag list) | Tstr_primitive (id, name, v) -> Tstr_primitive (id, name, map_value_description v) | Tstr_type list -> Tstr_type (List.map ( fun (id, name, decl) -> (id, name, map_type_declaration decl) ) list) | Tstr_exception (id, name, decl) -> Tstr_exception (id, name, map_exception_declaration decl) | Tstr_exn_rebind (id, name, path, lid) -> Tstr_exn_rebind (id, name, path, lid) | Tstr_module (id, name, mexpr) -> Tstr_module (id, name, map_module_expr mexpr) | Tstr_recmodule list -> let list = List.map (fun (id, name, mtype, mexpr) -> (id, name, map_module_type mtype, map_module_expr mexpr) ) list in Tstr_recmodule list | Tstr_modtype (id, name, mtype) -> Tstr_modtype (id, name, map_module_type mtype) | Tstr_open (path, lid) -> Tstr_open (path, lid) | Tstr_class list -> let list = List.map (fun (ci, string_list, virtual_flag) -> let ci = Map.enter_class_infos ci in let ci_expr = map_class_expr ci.ci_expr in (Map.leave_class_infos { ci with ci_expr = ci_expr}, string_list, virtual_flag) ) list in Tstr_class list | Tstr_class_type list -> let list = List.map (fun (id, name, ct) -> let ct = Map.enter_class_infos ct in let ci_expr = map_class_type ct.ci_expr in (id, name, Map.leave_class_infos { ct with ci_expr = ci_expr}) ) list in Tstr_class_type list | Tstr_include (mexpr, idents) -> Tstr_include (map_module_expr mexpr, idents) in Map.leave_structure_item { item with str_desc = str_desc} and map_value_description v = let v = Map.enter_value_description v in let val_desc = map_core_type v.val_desc in Map.leave_value_description { v with val_desc = val_desc } and map_type_declaration decl = let decl = Map.enter_type_declaration decl in let typ_cstrs = List.map (fun (ct1, ct2, loc) -> (map_core_type ct1, map_core_type ct2, loc) ) decl.typ_cstrs in let typ_kind = match decl.typ_kind with Ttype_abstract -> Ttype_abstract | Ttype_variant list -> let list = List.map (fun (s, name, cts, loc) -> (s, name, List.map map_core_type cts, loc) ) list in Ttype_variant list | Ttype_record list -> let list = List.map (fun (s, name, mut, ct, loc) -> (s, name, mut, map_core_type ct, loc) ) list in Ttype_record list in let typ_manifest = match decl.typ_manifest with None -> None | Some ct -> Some (map_core_type ct) in Map.leave_type_declaration { decl with typ_cstrs = typ_cstrs; typ_kind = typ_kind; typ_manifest = typ_manifest } and map_exception_declaration decl = let decl = Map.enter_exception_declaration decl in let exn_params = List.map map_core_type decl.exn_params in let decl = { exn_params = exn_params; exn_exn = decl.exn_exn; exn_loc = decl.exn_loc } in Map.leave_exception_declaration decl; and map_pattern pat = let pat = Map.enter_pattern pat in let pat_desc = match pat.pat_desc with | Tpat_alias (pat1, p, text) -> let pat1 = map_pattern pat1 in Tpat_alias (pat1, p, text) | Tpat_tuple list -> Tpat_tuple (List.map map_pattern list) | Tpat_construct (path, lid, cstr_decl, args, arity) -> Tpat_construct (path, lid, cstr_decl, List.map map_pattern args, arity) | Tpat_variant (label, pato, rowo) -> let pato = match pato with None -> pato | Some pat -> Some (map_pattern pat) in Tpat_variant (label, pato, rowo) | Tpat_record (list, closed) -> Tpat_record (List.map (fun (path, lid, lab_desc, pat) -> (path, lid, lab_desc, map_pattern pat) ) list, closed) | Tpat_array list -> Tpat_array (List.map map_pattern list) | Tpat_or (p1, p2, rowo) -> Tpat_or (map_pattern p1, map_pattern p2, rowo) | Tpat_lazy p -> Tpat_lazy (map_pattern p) | Tpat_constant _ | Tpat_any | Tpat_var _ -> pat.pat_desc in let pat_extra = List.map map_pat_extra pat.pat_extra in Map.leave_pattern { pat with pat_desc = pat_desc; pat_extra = pat_extra } and map_pat_extra pat_extra = match pat_extra with | Tpat_constraint ct, loc -> (Tpat_constraint (map_core_type ct), loc) | (Tpat_type _ | Tpat_unpack), _ -> pat_extra and map_expression exp = let exp = Map.enter_expression exp in let exp_desc = match exp.exp_desc with Texp_ident (_, _, _) | Texp_constant _ -> exp.exp_desc | Texp_let (rec_flag, list, exp) -> Texp_let (rec_flag, map_bindings rec_flag list, map_expression exp) | Texp_function (label, cases, partial) -> Texp_function (label, map_bindings Nonrecursive cases, partial) | Texp_apply (exp, list) -> Texp_apply (map_expression exp, List.map (fun (label, expo, optional) -> let expo = match expo with None -> expo | Some exp -> Some (map_expression exp) in (label, expo, optional) ) list ) | Texp_match (exp, list, partial) -> Texp_match ( map_expression exp, map_bindings Nonrecursive list, partial ) | Texp_try (exp, list) -> Texp_try ( map_expression exp, map_bindings Nonrecursive list ) | Texp_tuple list -> Texp_tuple (List.map map_expression list) | Texp_construct (path, lid, cstr_desc, args, arity) -> Texp_construct (path, lid, cstr_desc, List.map map_expression args, arity ) | Texp_variant (label, expo) -> let expo =match expo with None -> expo | Some exp -> Some (map_expression exp) in Texp_variant (label, expo) | Texp_record (list, expo) -> let list = List.map (fun (path, lid, lab_desc, exp) -> (path, lid, lab_desc, map_expression exp) ) list in let expo = match expo with None -> expo | Some exp -> Some (map_expression exp) in Texp_record (list, expo) | Texp_field (exp, path, lid, label) -> Texp_field (map_expression exp, path, lid, label) | Texp_setfield (exp1, path, lid, label, exp2) -> Texp_setfield ( map_expression exp1, path, lid, label, map_expression exp2) | Texp_array list -> Texp_array (List.map map_expression list) | Texp_ifthenelse (exp1, exp2, expo) -> Texp_ifthenelse ( map_expression exp1, map_expression exp2, match expo with None -> expo | Some exp -> Some (map_expression exp) ) | Texp_sequence (exp1, exp2) -> Texp_sequence ( map_expression exp1, map_expression exp2 ) | Texp_while (exp1, exp2) -> Texp_while ( map_expression exp1, map_expression exp2 ) | Texp_for (id, name, exp1, exp2, dir, exp3) -> Texp_for ( id, name, map_expression exp1, map_expression exp2, dir, map_expression exp3 ) | Texp_when (exp1, exp2) -> Texp_when ( map_expression exp1, map_expression exp2 ) | Texp_send (exp, meth, expo) -> Texp_send (map_expression exp, meth, may_map map_expression expo) | Texp_new (path, lid, cl_decl) -> exp.exp_desc | Texp_instvar (_, path, _) -> exp.exp_desc | Texp_setinstvar (path, lid, path2, exp) -> Texp_setinstvar (path, lid, path2, map_expression exp) | Texp_override (path, list) -> Texp_override ( path, List.map (fun (path, lid, exp) -> (path, lid, map_expression exp) ) list ) | Texp_letmodule (id, name, mexpr, exp) -> Texp_letmodule ( id, name, map_module_expr mexpr, map_expression exp ) | Texp_assert exp -> Texp_assert (map_expression exp) | Texp_assertfalse -> exp.exp_desc | Texp_lazy exp -> Texp_lazy (map_expression exp) | Texp_object (cl, string_list) -> Texp_object (map_class_structure cl, string_list) | Texp_pack (mexpr) -> Texp_pack (map_module_expr mexpr) in let exp_extra = List.map map_exp_extra exp.exp_extra in Map.leave_expression { exp with exp_desc = exp_desc; exp_extra = exp_extra } and map_exp_extra exp_extra = let loc = snd exp_extra in match fst exp_extra with | Texp_constraint (Some ct, None) -> Texp_constraint (Some (map_core_type ct), None), loc | Texp_constraint (None, Some ct) -> Texp_constraint (None, Some (map_core_type ct)), loc | Texp_constraint (Some ct1, Some ct2) -> Texp_constraint (Some (map_core_type ct1), Some (map_core_type ct2)), loc | Texp_poly (Some ct) -> Texp_poly (Some ( map_core_type ct )), loc | Texp_newtype _ | Texp_constraint (None, None) | Texp_open _ | Texp_poly None -> exp_extra and map_package_type pack = let pack = Map.enter_package_type pack in let pack_fields = List.map ( fun (s, ct) -> (s, map_core_type ct) ) pack.pack_fields in Map.leave_package_type { pack with pack_fields = pack_fields } and map_signature sg = let sg = Map.enter_signature sg in let sig_items = List.map map_signature_item sg.sig_items in Map.leave_signature { sg with sig_items = sig_items } and map_signature_item item = let item = Map.enter_signature_item item in let sig_desc = match item.sig_desc with Tsig_value (id, name, v) -> Tsig_value (id, name, map_value_description v) | Tsig_type list -> Tsig_type ( List.map (fun (id, name, decl) -> (id, name, map_type_declaration decl) ) list ) | Tsig_exception (id, name, decl) -> Tsig_exception (id, name, map_exception_declaration decl) | Tsig_module (id, name, mtype) -> Tsig_module (id, name, map_module_type mtype) | Tsig_recmodule list -> Tsig_recmodule (List.map ( fun (id, name, mtype) -> (id, name, map_module_type mtype) ) list) | Tsig_modtype (id, name, mdecl) -> Tsig_modtype (id, name, map_modtype_declaration mdecl) | Tsig_open (path, lid) -> item.sig_desc | Tsig_include (mty, lid) -> Tsig_include (map_module_type mty, lid) | Tsig_class list -> Tsig_class (List.map map_class_description list) | Tsig_class_type list -> Tsig_class_type (List.map map_class_type_declaration list) in Map.leave_signature_item { item with sig_desc = sig_desc } and map_modtype_declaration mdecl = let mdecl = Map.enter_modtype_declaration mdecl in let mdecl = match mdecl with Tmodtype_abstract -> Tmodtype_abstract | Tmodtype_manifest mtype -> Tmodtype_manifest (map_module_type mtype) in Map.leave_modtype_declaration mdecl and map_class_description cd = let cd = Map.enter_class_description cd in let ci_expr = map_class_type cd.ci_expr in Map.leave_class_description { cd with ci_expr = ci_expr} and map_class_type_declaration cd = let cd = Map.enter_class_type_declaration cd in let ci_expr = map_class_type cd.ci_expr in Map.leave_class_type_declaration { cd with ci_expr = ci_expr } and map_module_type mty = let mty = Map.enter_module_type mty in let mty_desc = match mty.mty_desc with Tmty_ident (path, lid) -> mty.mty_desc | Tmty_signature sg -> Tmty_signature (map_signature sg) | Tmty_functor (id, name, mtype1, mtype2) -> Tmty_functor (id, name, map_module_type mtype1, map_module_type mtype2) | Tmty_with (mtype, list) -> Tmty_with (map_module_type mtype, List.map (fun (path, lid, withc) -> (path, lid, map_with_constraint withc) ) list) | Tmty_typeof mexpr -> Tmty_typeof (map_module_expr mexpr) in Map.leave_module_type { mty with mty_desc = mty_desc} and map_with_constraint cstr = let cstr = Map.enter_with_constraint cstr in let cstr = match cstr with Twith_type decl -> Twith_type (map_type_declaration decl) | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl) | Twith_module (path, lid) -> cstr | Twith_modsubst (path, lid) -> cstr in Map.leave_with_constraint cstr and map_module_expr mexpr = let mexpr = Map.enter_module_expr mexpr in let mod_desc = match mexpr.mod_desc with Tmod_ident (p, lid) -> mexpr.mod_desc | Tmod_structure st -> Tmod_structure (map_structure st) | Tmod_functor (id, name, mtype, mexpr) -> Tmod_functor (id, name, map_module_type mtype, map_module_expr mexpr) | Tmod_apply (mexp1, mexp2, coercion) -> Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion) | Tmod_constraint (mexpr, mod_type, Tmodtype_implicit, coercion ) -> Tmod_constraint (map_module_expr mexpr, mod_type, Tmodtype_implicit, coercion) | Tmod_constraint (mexpr, mod_type, Tmodtype_explicit mtype, coercion) -> Tmod_constraint (map_module_expr mexpr, mod_type, Tmodtype_explicit (map_module_type mtype), coercion) | Tmod_unpack (exp, mod_type) -> Tmod_unpack (map_expression exp, mod_type) in Map.leave_module_expr { mexpr with mod_desc = mod_desc } and map_class_expr cexpr = let cexpr = Map.enter_class_expr cexpr in let cl_desc = match cexpr.cl_desc with | Tcl_constraint (cl, None, string_list1, string_list2, concr ) -> Tcl_constraint (map_class_expr cl, None, string_list1, string_list2, concr) | Tcl_structure clstr -> Tcl_structure (map_class_structure clstr) | Tcl_fun (label, pat, priv, cl, partial) -> Tcl_fun (label, map_pattern pat, List.map (fun (id, name, exp) -> (id, name, map_expression exp)) priv, map_class_expr cl, partial) | Tcl_apply (cl, args) -> Tcl_apply (map_class_expr cl, List.map (fun (label, expo, optional) -> (label, may_map map_expression expo, optional) ) args) | Tcl_let (rec_flat, bindings, ivars, cl) -> Tcl_let (rec_flat, map_bindings rec_flat bindings, List.map (fun (id, name, exp) -> (id, name, map_expression exp)) ivars, map_class_expr cl) | Tcl_constraint (cl, Some clty, vals, meths, concrs) -> Tcl_constraint ( map_class_expr cl, Some (map_class_type clty), vals, meths, concrs) | Tcl_ident (id, name, tyl) -> Tcl_ident (id, name, List.map map_core_type tyl) in Map.leave_class_expr { cexpr with cl_desc = cl_desc } and map_class_type ct = let ct = Map.enter_class_type ct in let cltyp_desc = match ct.cltyp_desc with Tcty_signature csg -> Tcty_signature (map_class_signature csg) | Tcty_constr (path, lid, list) -> Tcty_constr (path, lid, List.map map_core_type list) | Tcty_fun (label, ct, cl) -> Tcty_fun (label, map_core_type ct, map_class_type cl) in Map.leave_class_type { ct with cltyp_desc = cltyp_desc } and map_class_signature cs = let cs = Map.enter_class_signature cs in let csig_self = map_core_type cs.csig_self in let csig_fields = List.map map_class_type_field cs.csig_fields in Map.leave_class_signature { cs with csig_self = csig_self; csig_fields = csig_fields } and map_class_type_field ctf = let ctf = Map.enter_class_type_field ctf in let ctf_desc = match ctf.ctf_desc with Tctf_inher ct -> Tctf_inher (map_class_type ct) | Tctf_val (s, mut, virt, ct) -> Tctf_val (s, mut, virt, map_core_type ct) | Tctf_virt (s, priv, ct) -> Tctf_virt (s, priv, map_core_type ct) | Tctf_meth (s, priv, ct) -> Tctf_meth (s, priv, map_core_type ct) | Tctf_cstr (ct1, ct2) -> Tctf_cstr (map_core_type ct1, map_core_type ct2) in Map.leave_class_type_field { ctf with ctf_desc = ctf_desc } and map_core_type ct = let ct = Map.enter_core_type ct in let ctyp_desc = match ct.ctyp_desc with Ttyp_any | Ttyp_var _ -> ct.ctyp_desc | Ttyp_arrow (label, ct1, ct2) -> Ttyp_arrow (label, map_core_type ct1, map_core_type ct2) | Ttyp_tuple list -> Ttyp_tuple (List.map map_core_type list) | Ttyp_constr (path, lid, list) -> Ttyp_constr (path, lid, List.map map_core_type list) | Ttyp_object list -> Ttyp_object (List.map map_core_field_type list) | Ttyp_class (path, lid, list, labels) -> Ttyp_class (path, lid, List.map map_core_type list, labels) | Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s) | Ttyp_variant (list, bool, labels) -> Ttyp_variant (List.map map_row_field list, bool, labels) | Ttyp_poly (list, ct) -> Ttyp_poly (list, map_core_type ct) | Ttyp_package pack -> Ttyp_package (map_package_type pack) in Map.leave_core_type { ct with ctyp_desc = ctyp_desc } and map_core_field_type cft = let cft = Map.enter_core_field_type cft in let field_desc = match cft.field_desc with Tcfield_var -> Tcfield_var | Tcfield (s, ct) -> Tcfield (s, map_core_type ct) in Map.leave_core_field_type { cft with field_desc = field_desc } and map_class_structure cs = let cs = Map.enter_class_structure cs in let cstr_pat = map_pattern cs.cstr_pat in let cstr_fields = List.map map_class_field cs.cstr_fields in Map.leave_class_structure { cs with cstr_pat = cstr_pat; cstr_fields = cstr_fields } and map_row_field rf = match rf with Ttag (label, bool, list) -> Ttag (label, bool, List.map map_core_type list) | Tinherit ct -> Tinherit (map_core_type ct) and map_class_field cf = let cf = Map.enter_class_field cf in let cf_desc = match cf.cf_desc with Tcf_inher (ovf, cl, super, vals, meths) -> Tcf_inher (ovf, map_class_expr cl, super, vals, meths) | Tcf_constr (cty, cty') -> Tcf_constr (map_core_type cty, map_core_type cty') | Tcf_val (lab, name, mut, ident, Tcfk_virtual cty, override) -> Tcf_val (lab, name, mut, ident, Tcfk_virtual (map_core_type cty), override) | Tcf_val (lab, name, mut, ident, Tcfk_concrete exp, override) -> Tcf_val (lab, name, mut, ident, Tcfk_concrete (map_expression exp), override) | Tcf_meth (lab, name, priv, Tcfk_virtual cty, override) -> Tcf_meth (lab, name, priv, Tcfk_virtual (map_core_type cty), override) | Tcf_meth (lab, name, priv, Tcfk_concrete exp, override) -> Tcf_meth (lab, name, priv, Tcfk_concrete (map_expression exp), override) | Tcf_init exp -> Tcf_init (map_expression exp) in Map.leave_class_field { cf with cf_desc = cf_desc } end module DefaultMapArgument = struct let enter_structure t = t let enter_value_description t = t let enter_type_declaration t = t let enter_exception_declaration t = t let enter_pattern t = t let enter_expression t = t let enter_package_type t = t let enter_signature t = t let enter_signature_item t = t let enter_modtype_declaration t = t let enter_module_type t = t let enter_module_expr t = t let enter_with_constraint t = t let enter_class_expr t = t let enter_class_signature t = t let enter_class_description t = t let enter_class_type_declaration t = t let enter_class_infos t = t let enter_class_type t = t let enter_class_type_field t = t let enter_core_type t = t let enter_core_field_type t = t let enter_class_structure t = t let enter_class_field t = t let enter_structure_item t = t let leave_structure t = t let leave_value_description t = t let leave_type_declaration t = t let leave_exception_declaration t = t let leave_pattern t = t let leave_expression t = t let leave_package_type t = t let leave_signature t = t let leave_signature_item t = t let leave_modtype_declaration t = t let leave_module_type t = t let leave_module_expr t = t let leave_with_constraint t = t let leave_class_expr t = t let leave_class_signature t = t let leave_class_description t = t let leave_class_type_declaration t = t let leave_class_infos t = t let leave_class_type t = t let leave_class_type_field t = t let leave_core_type t = t let leave_core_field_type t = t let leave_class_structure t = t let leave_class_field t = t let leave_structure_item t = t end end module ClearEnv = TypedtreeMap.MakeMap (struct open TypedtreeMap include DefaultMapArgument let leave_pattern p = { p with pat_env = keep_only_summary p.pat_env } let leave_expression e = let exp_extra = List.map (function (Texp_open (path, lloc, env), loc) -> (Texp_open (path, lloc, keep_only_summary env), loc) | exp_extra -> exp_extra) e.exp_extra in { e with exp_env = keep_only_summary e.exp_env; exp_extra = exp_extra } let leave_class_expr c = { c with cl_env = keep_only_summary c.cl_env } let leave_module_expr m = { m with mod_env = keep_only_summary m.mod_env } let leave_structure s = { s with str_final_env = keep_only_summary s.str_final_env } let leave_structure_item str = { str with str_env = keep_only_summary str.str_env } let leave_module_type m = { m with mty_env = keep_only_summary m.mty_env } let leave_signature s = { s with sig_final_env = keep_only_summary s.sig_final_env } let leave_signature_item s = { s with sig_env = keep_only_summary s.sig_env } let leave_core_type c = { c with ctyp_env = keep_only_summary c.ctyp_env } let leave_class_type c = { c with cltyp_env = keep_only_summary c.cltyp_env } end) let rec clear_part p = match p with | Partial_structure s -> Partial_structure (ClearEnv.map_structure s) | Partial_structure_item s -> Partial_structure_item (ClearEnv.map_structure_item s) | Partial_expression e -> Partial_expression (ClearEnv.map_expression e) | Partial_pattern p -> Partial_pattern (ClearEnv.map_pattern p) | Partial_class_expr ce -> Partial_class_expr (ClearEnv.map_class_expr ce) | Partial_signature s -> Partial_signature (ClearEnv.map_signature s) | Partial_signature_item s -> Partial_signature_item (ClearEnv.map_signature_item s) | Partial_module_type s -> Partial_module_type (ClearEnv.map_module_type s) let clear_env binary_annots = if need_to_clear_env then match binary_annots with | Implementation s -> Implementation (ClearEnv.map_structure s) | Interface s -> Interface (ClearEnv.map_signature s) | Packed _ -> binary_annots | Partial_implementation array -> Partial_implementation (Array.map clear_part array) | Partial_interface array -> Partial_interface (Array.map clear_part array) else binary_annots exception Error of error let input_cmt ic = (input_value ic : cmt_infos) let output_cmt oc cmt = output_string oc Config.cmt_magic_number; output_value oc (cmt : cmt_infos) let read filename = (* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) let ic = open_in_bin filename in try let magic_number = read_magic_number ic in let cmi, cmt = if magic_number = Config.cmt_magic_number then None, Some (input_cmt ic) else if magic_number = Config.cmi_magic_number then let cmi = Cmi_format.input_cmi ic in let cmt = try let magic_number = read_magic_number ic in if magic_number = Config.cmt_magic_number then let cmt = input_cmt ic in Some cmt else None with _ -> None in Some cmi, cmt else raise(Cmi_format.Error(Cmi_format.Not_an_interface filename)) in close_in ic; (* Printf.fprintf stderr "Cmt_format.read done\n%!"; *) cmi, cmt with e -> close_in ic; raise e let string_of_file filename = let ic = open_in filename in let s = Misc.string_of_file ic in close_in ic; s let read_cmt filename = match read filename with _, None -> raise (Error (Not_a_typedtree filename)) | _, Some cmt -> cmt let read_cmi filename = match read filename with None, _ -> raise (Cmi_format.Error (Cmi_format.Not_an_interface filename)) | Some cmi, _ -> cmi let saved_types = ref [] let add_saved_type b = saved_types := b :: !saved_types let get_saved_types () = !saved_types let set_saved_types l = saved_types := l let save_cmt filename modname binary_annots sourcefile initial_env sg = if !Clflags.binary_annotations && not !Clflags.print_types && not !Clflags.dont_write_files then begin let imports = Env.imported_units () in let oc = open_out_bin filename in let this_crc = match sg with None -> None | Some (sg) -> let cmi = { cmi_name = modname; cmi_sign = sg; cmi_flags = if !Clflags.recursive_types then [Cmi_format.Rectypes] else []; cmi_crcs = imports; } in Some (output_cmi filename oc cmi) in let source_digest = Misc.may_map Digest.file sourcefile in let cmt = { cmt_modname = modname; cmt_annots = clear_env binary_annots; cmt_comments = Lexer.comments (); cmt_args = Sys.argv; cmt_sourcefile = sourcefile; cmt_builddir = Sys.getcwd (); cmt_loadpath = !Config.load_path; cmt_source_digest = source_digest; cmt_initial_env = if need_to_clear_env then keep_only_summary initial_env else initial_env; cmt_imports = List.sort compare imports; cmt_interface_digest = this_crc; cmt_use_summaries = need_to_clear_env; } in clear_env_hcons (); output_cmt oc cmt; close_out oc; set_saved_types []; end; set_saved_types [] mingw-ocaml/ocaml/typing/oprint.ml0000644000175000017500000004044112124403242016641 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2002 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) open Format open Outcometree exception Ellipsis let cautious f ppf arg = try f ppf arg with Ellipsis -> fprintf ppf "..." let rec print_ident ppf = function Oide_ident s -> fprintf ppf "%s" s | Oide_dot (id, s) -> fprintf ppf "%a.%s" print_ident id s | Oide_apply (id1, id2) -> fprintf ppf "%a(%a)" print_ident id1 print_ident id2 let parenthesized_ident name = (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]) || (match name.[0] with 'a'..'z' | 'A'..'Z' | '\223'..'\246' | '\248'..'\255' | '_' -> false | _ -> true) let value_ident ppf name = if parenthesized_ident name then fprintf ppf "( %s )" name else fprintf ppf "%s" name (* Values *) let valid_float_lexeme s = let l = String.length s in let rec loop i = if i >= l then s ^ "." else match s.[i] with | '0' .. '9' | '-' -> loop (i+1) | _ -> s in loop 0 let float_repres f = match classify_float f with FP_nan -> "nan" | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" | _ -> let float_val = let s1 = Printf.sprintf "%.12g" f in if f = float_of_string s1 then s1 else let s2 = Printf.sprintf "%.15g" f in if f = float_of_string s2 then s2 else Printf.sprintf "%.18g" f in valid_float_lexeme float_val let parenthesize_if_neg ppf fmt v isneg = if isneg then pp_print_char ppf '('; fprintf ppf fmt v; if isneg then pp_print_char ppf ')' let print_out_value ppf tree = let rec print_tree_1 ppf = function | Oval_constr (name, [param]) -> fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param | Oval_constr (name, (_ :: _ as params)) -> fprintf ppf "@[<1>%a@ (%a)@]" print_ident name (print_tree_list print_tree_1 ",") params | Oval_variant (name, Some param) -> fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param | tree -> print_simple_tree ppf tree and print_constr_param ppf = function | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0) | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l) | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L) | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n) | Oval_float f -> parenthesize_if_neg ppf "%s" (float_repres f) (f < 0.0) | tree -> print_simple_tree ppf tree and print_simple_tree ppf = function Oval_int i -> fprintf ppf "%i" i | Oval_int32 i -> fprintf ppf "%lil" i | Oval_int64 i -> fprintf ppf "%LiL" i | Oval_nativeint i -> fprintf ppf "%nin" i | Oval_float f -> fprintf ppf "%s" (float_repres f) | Oval_char c -> fprintf ppf "%C" c | Oval_string s -> begin try fprintf ppf "%S" s with Invalid_argument "String.create" -> fprintf ppf "" end | Oval_list tl -> fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl | Oval_array tl -> fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl | Oval_constr (name, []) -> print_ident ppf name | Oval_variant (name, None) -> fprintf ppf "`%s" name | Oval_stuff s -> fprintf ppf "%s" s | Oval_record fel -> fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel | Oval_ellipsis -> raise Ellipsis | Oval_printer f -> f ppf | Oval_tuple tree_list -> fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree and print_fields first ppf = function [] -> () | (name, tree) :: fields -> if not first then fprintf ppf ";@ "; fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1) tree; print_fields false ppf fields and print_tree_list print_item sep ppf tree_list = let rec print_list first ppf = function [] -> () | tree :: tree_list -> if not first then fprintf ppf "%s@ " sep; print_item ppf tree; print_list false ppf tree_list in cautious (print_list true) ppf tree_list in cautious print_tree_1 ppf tree let out_value = ref print_out_value (* Types *) let rec print_list_init pr sep ppf = function [] -> () | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l let rec print_list pr sep ppf = function [] -> () | [a] -> pr ppf a | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l let pr_present = print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") let pr_vars = print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ") let rec print_out_type ppf = function | Otyp_alias (ty, s) -> fprintf ppf "@[%a@ as '%s@]" print_out_type ty s | Otyp_poly (sl, ty) -> fprintf ppf "@[%a.@ %a@]" pr_vars sl print_out_type ty | ty -> print_out_type_1 ppf ty and print_out_type_1 ppf = function Otyp_arrow (lab, ty1, ty2) -> fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") print_out_type_2 ty1 print_out_type_1 ty2 | ty -> print_out_type_2 ppf ty and print_out_type_2 ppf = function Otyp_tuple tyl -> fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl | ty -> print_simple_out_type ppf ty and print_simple_out_type ppf = function Otyp_class (ng, id, tyl) -> fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "") print_ident id | Otyp_constr (id, tyl) -> fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id | Otyp_object (fields, rest) -> fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields | Otyp_stuff s -> fprintf ppf "%s" s | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s | Otyp_variant (non_gen, row_fields, closed, tags) -> let print_present ppf = function None | Some [] -> () | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l in let print_fields ppf = function Ovar_fields fields -> print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ") ppf fields | Ovar_name (id, tyl) -> fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id in fprintf ppf "%s[%s@[@[%a@]%a ]@]" (if non_gen then "_" else "") (if closed then if tags = None then " " else "< " else if tags = None then "> " else "? ") print_fields row_fields print_present tags | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty -> fprintf ppf "@[<1>(%a)@]" print_out_type ty | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> () | Otyp_module (p, n, tyl) -> fprintf ppf "@[<1>(module %s" p; let first = ref true in List.iter2 (fun s t -> let sep = if !first then (first := false; "with") else "and" in fprintf ppf " %s type %s = %a" sep s print_out_type t ) n tyl; fprintf ppf ")@]" and print_fields rest ppf = function [] -> begin match rest with Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "") | None -> () end | [s, t] -> fprintf ppf "%s : %a" s print_out_type t; begin match rest with Some _ -> fprintf ppf ";@ " | None -> () end; print_fields rest ppf [] | (s, t) :: l -> fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l and print_row_field ppf (l, opt_amp, tyl) = let pr_of ppf = if opt_amp then fprintf ppf " of@ &@ " else if tyl <> [] then fprintf ppf " of@ " else fprintf ppf "" in fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") tyl and print_typlist print_elem sep ppf = function [] -> () | [ty] -> print_elem ppf ty | ty :: tyl -> fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep) tyl and print_typargs ppf = function [] -> () | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1 | tyl -> fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl let out_type = ref print_out_type (* Class types *) let type_parameter ppf (ty, (co, cn)) = fprintf ppf "%s%s" (if not cn then "+" else if not co then "-" else "") (if ty = "_" then ty else "'"^ty) let print_out_class_params ppf = function [] -> () | tyl -> fprintf ppf "@[<1>[%a]@]@ " (print_list type_parameter (fun ppf -> fprintf ppf ", ")) tyl let rec print_out_class_type ppf = function Octy_constr (id, tyl) -> let pr_tyl ppf = function [] -> () | tyl -> fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl in fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id | Octy_fun (lab, ty, cty) -> fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") print_out_type_2 ty print_out_class_type cty | Octy_signature (self_ty, csil) -> let pr_param ppf = function Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty | None -> () in fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) csil and print_out_class_sig_item ppf = function Ocsg_constraint (ty1, ty2) -> fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1 !out_type ty2 | Ocsg_method (name, priv, virt, ty) -> fprintf ppf "@[<2>method %s%s%s :@ %a@]" (if priv then "private " else "") (if virt then "virtual " else "") name !out_type ty | Ocsg_value (name, mut, vr, ty) -> fprintf ppf "@[<2>val %s%s%s :@ %a@]" (if mut then "mutable " else "") (if vr then "virtual " else "") name !out_type ty let out_class_type = ref print_out_class_type (* Signature *) let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type") let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item") let out_signature = ref (fun _ -> failwith "Oprint.out_signature") let rec print_out_module_type ppf = function Omty_abstract -> () | Omty_functor (name, mty_arg, mty_res) -> fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name print_out_module_type mty_arg print_out_module_type mty_res | Omty_ident id -> fprintf ppf "%a" print_ident id | Omty_signature sg -> fprintf ppf "@[sig@ %a@;<1 -2>end@]" !out_signature sg and print_out_signature ppf = function [] -> () | [item] -> !out_sig_item ppf item | item :: items -> fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items and print_out_sig_item ppf = function Osig_class (vir_flag, name, params, clt, rs) -> fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]" (if rs = Orec_next then "and" else "class") (if vir_flag then " virtual" else "") print_out_class_params params name !out_class_type clt | Osig_class_type (vir_flag, name, params, clt, rs) -> fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]" (if rs = Orec_next then "and" else "class type") (if vir_flag then " virtual" else "") print_out_class_params params name !out_class_type clt | Osig_exception (id, tyl) -> fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl,None) | Osig_modtype (name, Omty_abstract) -> fprintf ppf "@[<2>module type %s@]" name | Osig_modtype (name, mty) -> fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty | Osig_module (name, mty, rs) -> fprintf ppf "@[<2>%s %s :@ %a@]" (match rs with Orec_not -> "module" | Orec_first -> "module rec" | Orec_next -> "and") name !out_module_type mty | Osig_type(td, rs) -> print_out_type_decl (if rs = Orec_next then "and" else "type") ppf td | Osig_value (name, ty, prims) -> let kwd = if prims = [] then "val" else "external" in let pr_prims ppf = function [] -> () | s :: sl -> fprintf ppf "@ = \"%s\"" s; List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl in fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name !out_type ty pr_prims prims and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) = let print_constraints ppf params = List.iter (fun (ty1, ty2) -> fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1 !out_type ty2) params in let type_defined ppf = match args with [] -> fprintf ppf "%s" name | [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name | _ -> fprintf ppf "@[(@[%a)@]@ %s@]" (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) args name in let print_manifest ppf = function Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty | _ -> () in let print_name_args ppf = fprintf ppf "%s %t%a" kwd type_defined print_manifest ty in let ty = match ty with Otyp_manifest (_, ty) -> ty | _ -> ty in let print_private ppf = function Asttypes.Private -> fprintf ppf " private" | Asttypes.Public -> () in let rec print_out_tkind ppf = function | Otyp_abstract -> () | Otyp_record lbls -> fprintf ppf " =%a {%a@;<1 -2>}" print_private priv (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls | Otyp_sum constrs -> fprintf ppf " =%a@;<1 2>%a" print_private priv (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs | ty -> fprintf ppf " =%a@;<1 2>%a" print_private priv !out_type ty in fprintf ppf "@[<2>@[%t%a@]%a@]" print_name_args print_out_tkind ty print_constraints constraints and print_out_constr ppf (name, tyl,ret_type_opt) = match ret_type_opt with | None -> begin match tyl with | [] -> fprintf ppf "%s" name | _ -> fprintf ppf "@[<2>%s of@ %a@]" name (print_typlist print_simple_out_type " *") tyl end | Some ret_type -> begin match tyl with | [] -> fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type ret_type | _ -> fprintf ppf "@[<2>%s :@ %a -> %a@]" name (print_typlist print_simple_out_type " *") tyl print_simple_out_type ret_type end and print_out_label ppf (name, mut, arg) = fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name !out_type arg let _ = out_module_type := print_out_module_type let _ = out_signature := print_out_signature let _ = out_sig_item := print_out_sig_item (* Phrases *) let print_out_exception ppf exn outv = match exn with Sys.Break -> fprintf ppf "Interrupted.@." | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." | Stack_overflow -> fprintf ppf "Stack overflow during evaluation (looping recursion?).@." | _ -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv let rec print_items ppf = function [] -> () | (tree, valopt) :: items -> begin match valopt with Some v -> fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree !out_value v | None -> fprintf ppf "@[%a@]" !out_sig_item tree end; if items <> [] then fprintf ppf "@ %a" print_items items let print_out_phrase ppf = function Ophr_eval (outv, ty) -> fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv | Ophr_signature [] -> () | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv let out_phrase = ref print_out_phrase mingw-ocaml/ocaml/typing/outcometree.mli0000644000175000017500000000761412124403242020037 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (* Module [Outcometree]: results displayed by the toplevel *) (* These types represent messages that the toplevel displays as normal results or errors. The real displaying is customisable using the hooks: [Toploop.print_out_value] [Toploop.print_out_type] [Toploop.print_out_sig_item] [Toploop.print_out_phrase] *) type out_ident = | Oide_apply of out_ident * out_ident | Oide_dot of out_ident * string | Oide_ident of string type out_value = | Oval_array of out_value list | Oval_char of char | Oval_constr of out_ident * out_value list | Oval_ellipsis | Oval_float of float | Oval_int of int | Oval_int32 of int32 | Oval_int64 of int64 | Oval_nativeint of nativeint | Oval_list of out_value list | Oval_printer of (Format.formatter -> unit) | Oval_record of (out_ident * out_value) list | Oval_string of string | Oval_stuff of string | Oval_tuple of out_value list | Oval_variant of string * out_value option type out_type = | Otyp_abstract | Otyp_alias of out_type * string | Otyp_arrow of string * out_type * out_type | Otyp_class of bool * out_ident * out_type list | Otyp_constr of out_ident * out_type list | Otyp_manifest of out_type * out_type | Otyp_object of (string * out_type) list * bool option | Otyp_record of (string * bool * out_type) list | Otyp_stuff of string | Otyp_sum of (string * out_type list * out_type option) list | Otyp_tuple of out_type list | Otyp_var of bool * string | Otyp_variant of bool * out_variant * bool * (string list) option | Otyp_poly of string list * out_type | Otyp_module of string * string list * out_type list and out_variant = | Ovar_fields of (string * bool * out_type list) list | Ovar_name of out_ident * out_type list type out_class_type = | Octy_constr of out_ident * out_type list | Octy_fun of string * out_type * out_class_type | Octy_signature of out_type option * out_class_sig_item list and out_class_sig_item = | Ocsg_constraint of out_type * out_type | Ocsg_method of string * bool * bool * out_type | Ocsg_value of string * bool * bool * out_type type out_module_type = | Omty_abstract | Omty_functor of string * out_module_type * out_module_type | Omty_ident of out_ident | Omty_signature of out_sig_item list and out_sig_item = | Osig_class of bool * string * (string * (bool * bool)) list * out_class_type * out_rec_status | Osig_class_type of bool * string * (string * (bool * bool)) list * out_class_type * out_rec_status | Osig_exception of string * out_type list | Osig_modtype of string * out_module_type | Osig_module of string * out_module_type * out_rec_status | Osig_type of out_type_decl * out_rec_status | Osig_value of string * out_type * string list and out_type_decl = string * (string * (bool * bool)) list * out_type * Asttypes.private_flag * (out_type * out_type) list and out_rec_status = | Orec_not | Orec_first | Orec_next type out_phrase = | Ophr_eval of out_value * out_type | Ophr_signature of (out_sig_item * out_value option) list | Ophr_exception of (exn * out_value) mingw-ocaml/ocaml/typing/printtyped.ml0000644000175000017500000006064312124403242017536 0ustar tootstoots(***********************************************************************) (* *) (* OCaml *) (* *) (* Fabrice Le Fessant, INRIA Saclay *) (* *) (* Copyright 1999 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Tublic License version 1.0. *) (* *) (***********************************************************************) (* $Id: printast.ml 12414 2012-05-02 14:36:55Z lefessan $ *) open Asttypes;; open Format;; open Lexing;; open Location;; open Typedtree;; let fmt_position f l = if l.pos_lnum = -1 then fprintf f "%s[%d]" l.pos_fname l.pos_cnum else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol (l.pos_cnum - l.pos_bol) ;; let fmt_location f loc = fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end; if loc.loc_ghost then fprintf f " ghost"; ;; let rec fmt_longident_aux f x = match x with | Longident.Lident (s) -> fprintf f "%s" s; | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s; | Longident.Lapply (y, z) -> fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; ;; let fmt_longident_noloc f x = fprintf f "\"%a\"" fmt_longident_aux x;; let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;; let fmt_ident = Ident.print let rec fmt_path_aux f x = match x with | Path.Pident (s) -> fprintf f "%a" fmt_ident s; | Path.Pdot (y, s, _pos) -> fprintf f "%a.%s" fmt_path_aux y s; | Path.Papply (y, z) -> fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z; ;; let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x;; let fmt_path_loc f x = fprintf f "\"%a\"" fmt_path_aux x.txt;; let fmt_constant f x = match x with | Const_int (i) -> fprintf f "Const_int %d" i; | Const_char (c) -> fprintf f "Const_char %02x" (Char.code c); | Const_string (s) -> fprintf f "Const_string %S" s; | Const_float (s) -> fprintf f "Const_float %s" s; | Const_int32 (i) -> fprintf f "Const_int32 %ld" i; | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i; | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i; ;; let fmt_mutable_flag f x = match x with | Immutable -> fprintf f "Immutable"; | Mutable -> fprintf f "Mutable"; ;; let fmt_virtual_flag f x = match x with | Virtual -> fprintf f "Virtual"; | Concrete -> fprintf f "Concrete"; ;; let fmt_override_flag f x = match x with | Override -> fprintf f "Override"; | Fresh -> fprintf f "Fresh"; ;; let fmt_rec_flag f x = match x with | Nonrecursive -> fprintf f "Nonrec"; | Recursive -> fprintf f "Rec"; | Default -> fprintf f "Default"; ;; let fmt_direction_flag f x = match x with | Upto -> fprintf f "Up"; | Downto -> fprintf f "Down"; ;; let fmt_private_flag f x = match x with | Public -> fprintf f "Public"; | Private -> fprintf f "Private"; ;; let line i f s (*...*) = fprintf f "%s" (String.make (2*i) ' '); fprintf f s (*...*) ;; let list i f ppf l = match l with | [] -> line i ppf "[]\n"; | _ :: _ -> line i ppf "[\n"; List.iter (f (i+1) ppf) l; line i ppf "]\n"; ;; let option i f ppf x = match x with | None -> line i ppf "None\n"; | Some x -> line i ppf "Some\n"; f (i+1) ppf x; ;; let longident i ppf li = line i ppf "%a\n" fmt_longident li;; let path i ppf li = line i ppf "%a\n" fmt_path li;; let ident i ppf li = line i ppf "%a\n" fmt_ident li;; let string i ppf s = line i ppf "\"%s\"\n" s;; let string_loc i ppf s = line i ppf "\"%s\"\n" s.txt;; let bool i ppf x = line i ppf "%s\n" (string_of_bool x);; let label i ppf x = line i ppf "label=\"%s\"\n" x;; let rec core_type i ppf x = line i ppf "core_type %a\n" fmt_location x.ctyp_loc; let i = i+1 in match x.ctyp_desc with | Ttyp_any -> line i ppf "Ptyp_any\n"; | Ttyp_var (s) -> line i ppf "Ptyp_var %s\n" s; | Ttyp_arrow (l, ct1, ct2) -> line i ppf "Ptyp_arrow\n"; string i ppf l; core_type i ppf ct1; core_type i ppf ct2; | Ttyp_tuple l -> line i ppf "Ptyp_tuple\n"; list i core_type ppf l; | Ttyp_constr (li, _, l) -> line i ppf "Ptyp_constr %a\n" fmt_path li; list i core_type ppf l; | Ttyp_variant (l, closed, low) -> line i ppf "Ptyp_variant closed=%s\n" (string_of_bool closed); list i label_x_bool_x_core_type_list ppf l; option i (fun i -> list i string) ppf low | Ttyp_object (l) -> line i ppf "Ptyp_object\n"; list i core_field_type ppf l; | Ttyp_class (li, _, l, low) -> line i ppf "Ptyp_class %a\n" fmt_path li; list i core_type ppf l; list i string ppf low | Ttyp_alias (ct, s) -> line i ppf "Ptyp_alias \"%s\"\n" s; core_type i ppf ct; | Ttyp_poly (sl, ct) -> line i ppf "Ptyp_poly%a\n" (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl; core_type i ppf ct; | Ttyp_package { pack_name = s; pack_fields = l } -> line i ppf "Ptyp_package %a\n" fmt_path s; list i package_with ppf l; and package_with i ppf (s, t) = line i ppf "with type %a\n" fmt_longident s; core_type i ppf t and core_field_type i ppf x = line i ppf "core_field_type %a\n" fmt_location x.field_loc; let i = i+1 in match x.field_desc with | Tcfield (s, ct) -> line i ppf "Pfield \"%s\"\n" s; core_type i ppf ct; | Tcfield_var -> line i ppf "Pfield_var\n"; and pattern i ppf x = line i ppf "pattern %a\n" fmt_location x.pat_loc; let i = i+1 in match x.pat_extra with | (Tpat_unpack, _) :: rem -> line i ppf "Tpat_unpack\n"; pattern i ppf { x with pat_extra = rem } | (Tpat_constraint cty, _) :: rem -> line i ppf "Tpat_constraint\n"; core_type i ppf cty; pattern i ppf { x with pat_extra = rem } | (Tpat_type (id, _), _) :: rem -> line i ppf "Tpat_type %a\n" fmt_path id; pattern i ppf { x with pat_extra = rem } | [] -> match x.pat_desc with | Tpat_any -> line i ppf "Ppat_any\n"; | Tpat_var (s,_) -> line i ppf "Ppat_var \"%a\"\n" fmt_ident s; | Tpat_alias (p, s,_) -> line i ppf "Ppat_alias \"%a\"\n" fmt_ident s; pattern i ppf p; | Tpat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; | Tpat_tuple (l) -> line i ppf "Ppat_tuple\n"; list i pattern ppf l; | Tpat_construct (li, _, _, po, explicity_arity) -> line i ppf "Ppat_construct %a\n" fmt_path li; list i pattern ppf po; bool i ppf explicity_arity; | Tpat_variant (l, po, _) -> line i ppf "Ppat_variant \"%s\"\n" l; option i pattern ppf po; | Tpat_record (l, c) -> line i ppf "Ppat_record\n"; list i longident_x_pattern ppf l; | Tpat_array (l) -> line i ppf "Ppat_array\n"; list i pattern ppf l; | Tpat_or (p1, p2, _) -> line i ppf "Ppat_or\n"; pattern i ppf p1; pattern i ppf p2; | Tpat_lazy p -> line i ppf "Ppat_lazy\n"; pattern i ppf p; and expression_extra i ppf x = match x with | Texp_constraint (cto1, cto2) -> line i ppf "Pexp_constraint\n"; option i core_type ppf cto1; option i core_type ppf cto2; | Texp_open (m, _, _) -> line i ppf "Pexp_open \"%a\"\n" fmt_path m; | Texp_poly cto -> line i ppf "Pexp_poly\n"; option i core_type ppf cto; | Texp_newtype s -> line i ppf "Pexp_newtype \"%s\"\n" s; and expression i ppf x = line i ppf "expression %a\n" fmt_location x.exp_loc; let i = List.fold_left (fun i (extra,_) -> expression_extra i ppf extra; i+1) (i+1) x.exp_extra in match x.exp_desc with | Texp_ident (li,_,_) -> line i ppf "Pexp_ident %a\n" fmt_path li; | Texp_instvar (_, li,_) -> line i ppf "Pexp_instvar %a\n" fmt_path li; | Texp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; | Texp_let (rf, l, e) -> line i ppf "Pexp_let %a\n" fmt_rec_flag rf; list i pattern_x_expression_def ppf l; expression i ppf e; | Texp_function (p, l, _partial) -> line i ppf "Pexp_function \"%s\"\n" p; (* option i expression ppf eo; *) list i pattern_x_expression_case ppf l; | Texp_apply (e, l) -> line i ppf "Pexp_apply\n"; expression i ppf e; list i label_x_expression ppf l; | Texp_match (e, l, partial) -> line i ppf "Pexp_match\n"; expression i ppf e; list i pattern_x_expression_case ppf l; | Texp_try (e, l) -> line i ppf "Pexp_try\n"; expression i ppf e; list i pattern_x_expression_case ppf l; | Texp_tuple (l) -> line i ppf "Pexp_tuple\n"; list i expression ppf l; | Texp_construct (li, _, _, eo, b) -> line i ppf "Pexp_construct %a\n" fmt_path li; list i expression ppf eo; bool i ppf b; | Texp_variant (l, eo) -> line i ppf "Pexp_variant \"%s\"\n" l; option i expression ppf eo; | Texp_record (l, eo) -> line i ppf "Pexp_record\n"; list i longident_x_expression ppf l; option i expression ppf eo; | Texp_field (e, li, _, _) -> line i ppf "Pexp_field\n"; expression i ppf e; path i ppf li; | Texp_setfield (e1, li, _, _, e2) -> line i ppf "Pexp_setfield\n"; expression i ppf e1; path i ppf li; expression i ppf e2; | Texp_array (l) -> line i ppf "Pexp_array\n"; list i expression ppf l; | Texp_ifthenelse (e1, e2, eo) -> line i ppf "Pexp_ifthenelse\n"; expression i ppf e1; expression i ppf e2; option i expression ppf eo; | Texp_sequence (e1, e2) -> line i ppf "Pexp_sequence\n"; expression i ppf e1; expression i ppf e2; | Texp_while (e1, e2) -> line i ppf "Pexp_while\n"; expression i ppf e1; expression i ppf e2; | Texp_for (s, _, e1, e2, df, e3) -> line i ppf "Pexp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df; expression i ppf e1; expression i ppf e2; expression i ppf e3; | Texp_when (e1, e2) -> line i ppf "Pexp_when\n"; expression i ppf e1; expression i ppf e2; | Texp_send (e, Tmeth_name s, eo) -> line i ppf "Pexp_send \"%s\"\n" s; expression i ppf e; option i expression ppf eo | Texp_send (e, Tmeth_val s, eo) -> line i ppf "Pexp_send \"%a\"\n" fmt_ident s; expression i ppf e; option i expression ppf eo | Texp_new (li, _, _) -> line i ppf "Pexp_new %a\n" fmt_path li; | Texp_setinstvar (_, s, _, e) -> line i ppf "Pexp_setinstvar \"%a\"\n" fmt_path s; expression i ppf e; | Texp_override (_, l) -> line i ppf "Pexp_override\n"; list i string_x_expression ppf l; | Texp_letmodule (s, _, me, e) -> line i ppf "Pexp_letmodule \"%a\"\n" fmt_ident s; module_expr i ppf me; expression i ppf e; | Texp_assert (e) -> line i ppf "Pexp_assert"; expression i ppf e; | Texp_assertfalse -> line i ppf "Pexp_assertfalse"; | Texp_lazy (e) -> line i ppf "Pexp_lazy"; expression i ppf e; | Texp_object (s, _) -> line i ppf "Pexp_object"; class_structure i ppf s | Texp_pack me -> line i ppf "Pexp_pack"; module_expr i ppf me and value_description i ppf x = line i ppf "value_description\n"; core_type (i+1) ppf x.val_desc; list (i+1) string ppf x.val_prim; and string_option_underscore i ppf = function | Some x -> string i ppf x.txt | None -> string i ppf "_" and type_declaration i ppf x = line i ppf "type_declaration %a\n" fmt_location x.typ_loc; let i = i+1 in line i ppf "ptype_params =\n"; list (i+1) string_option_underscore ppf x.typ_params; line i ppf "ptype_cstrs =\n"; list (i+1) core_type_x_core_type_x_location ppf x.typ_cstrs; line i ppf "ptype_kind =\n"; type_kind (i+1) ppf x.typ_kind; line i ppf "ptype_private = %a\n" fmt_private_flag x.typ_private; line i ppf "ptype_manifest =\n"; option (i+1) core_type ppf x.typ_manifest; and type_kind i ppf x = match x with | Ttype_abstract -> line i ppf "Ptype_abstract\n" | Ttype_variant l -> line i ppf "Ptype_variant\n"; list (i+1) string_x_core_type_list_x_location ppf l; | Ttype_record l -> line i ppf "Ptype_record\n"; list (i+1) string_x_mutable_flag_x_core_type_x_location ppf l; and exception_declaration i ppf x = list i core_type ppf x and class_type i ppf x = line i ppf "class_type %a\n" fmt_location x.cltyp_loc; let i = i+1 in match x.cltyp_desc with | Tcty_constr (li, _, l) -> line i ppf "Pcty_constr %a\n" fmt_path li; list i core_type ppf l; | Tcty_signature (cs) -> line i ppf "Pcty_signature\n"; class_signature i ppf cs; | Tcty_fun (l, co, cl) -> line i ppf "Pcty_fun \"%s\"\n" l; core_type i ppf co; class_type i ppf cl; and class_signature i ppf { csig_self = ct; csig_fields = l } = line i ppf "class_signature\n"; core_type (i+1) ppf ct; list (i+1) class_type_field ppf l; and class_type_field i ppf x = let loc = x.ctf_loc in match x.ctf_desc with | Tctf_inher (ct) -> line i ppf "Pctf_inher\n"; class_type i ppf ct; | Tctf_val (s, mf, vf, ct) -> line i ppf "Pctf_val \"%s\" %a %a %a\n" s fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc; core_type (i+1) ppf ct; | Tctf_virt (s, pf, ct) -> line i ppf "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; core_type (i+1) ppf ct; | Tctf_meth (s, pf, ct) -> line i ppf "Pctf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; core_type (i+1) ppf ct; | Tctf_cstr (ct1, ct2) -> line i ppf "Pctf_cstr %a\n" fmt_location loc; core_type i ppf ct1; core_type i ppf ct2; and class_description i ppf x = line i ppf "class_description %a\n" fmt_location x.ci_loc; let i = i+1 in line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; line i ppf "pci_params =\n"; string_list_x_location (i+1) ppf x.ci_params; line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; line i ppf "pci_expr =\n"; class_type (i+1) ppf x.ci_expr; and class_type_declaration i ppf x = line i ppf "class_type_declaration %a\n" fmt_location x.ci_loc; let i = i+1 in line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; line i ppf "pci_params =\n"; string_list_x_location (i+1) ppf x.ci_params; line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; line i ppf "pci_expr =\n"; class_type (i+1) ppf x.ci_expr; and class_expr i ppf x = line i ppf "class_expr %a\n" fmt_location x.cl_loc; let i = i+1 in match x.cl_desc with | Tcl_ident (li, _, l) -> line i ppf "Pcl_constr %a\n" fmt_path li; list i core_type ppf l; | Tcl_structure (cs) -> line i ppf "Pcl_structure\n"; class_structure i ppf cs; | Tcl_fun (l, eo, p, e, _) -> assert false (* TODO *) (* line i ppf "Pcl_fun\n"; label i ppf l; option i expression ppf eo; pattern i ppf p; class_expr i ppf e; *) | Tcl_apply (ce, l) -> line i ppf "Pcl_apply\n"; class_expr i ppf ce; list i label_x_expression ppf l; | Tcl_let (rf, l1, l2, ce) -> line i ppf "Pcl_let %a\n" fmt_rec_flag rf; list i pattern_x_expression_def ppf l1; list i ident_x_loc_x_expression_def ppf l2; class_expr i ppf ce; | Tcl_constraint (ce, Some ct, _, _, _) -> line i ppf "Pcl_constraint\n"; class_expr i ppf ce; class_type i ppf ct; | Tcl_constraint (_, None, _, _, _) -> assert false (* TODO : is it possible ? see parsetree *) and class_structure i ppf { cstr_pat = p; cstr_fields = l } = line i ppf "class_structure\n"; pattern (i+1) ppf p; list (i+1) class_field ppf l; and class_field i ppf x = assert false (* TODO *) (* let loc = x.cf_loc in match x.cf_desc with | Tcf_inher (ovf, ce, so) -> line i ppf "Pcf_inher %a\n" fmt_override_flag ovf; class_expr (i+1) ppf ce; option (i+1) string ppf so; | Tcf_valvirt (s, mf, ct) -> line i ppf "Pcf_valvirt \"%s\" %a %a\n" s.txt fmt_mutable_flag mf fmt_location loc; core_type (i+1) ppf ct; | Tcf_val (s, mf, ovf, e) -> line i ppf "Pcf_val \"%s\" %a %a %a\n" s.txt fmt_mutable_flag mf fmt_override_flag ovf fmt_location loc; expression (i+1) ppf e; | Tcf_virt (s, pf, ct) -> line i ppf "Pcf_virt \"%s\" %a %a\n" s.txt fmt_private_flag pf fmt_location loc; core_type (i+1) ppf ct; | Tcf_meth (s, pf, ovf, e) -> line i ppf "Pcf_meth \"%s\" %a %a %a\n" s.txt fmt_private_flag pf fmt_override_flag ovf fmt_location loc; expression (i+1) ppf e; | Tcf_constr (ct1, ct2) -> line i ppf "Pcf_constr %a\n" fmt_location loc; core_type (i+1) ppf ct1; core_type (i+1) ppf ct2; | Tcf_init (e) -> line i ppf "Pcf_init\n"; expression (i+1) ppf e; *) and class_declaration i ppf x = line i ppf "class_declaration %a\n" fmt_location x.ci_loc; let i = i+1 in line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; line i ppf "pci_params =\n"; string_list_x_location (i+1) ppf x.ci_params; line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; line i ppf "pci_expr =\n"; class_expr (i+1) ppf x.ci_expr; and module_type i ppf x = line i ppf "module_type %a\n" fmt_location x.mty_loc; let i = i+1 in match x.mty_desc with | Tmty_ident (li,_) -> line i ppf "Pmty_ident %a\n" fmt_path li; | Tmty_signature (s) -> line i ppf "Pmty_signature\n"; signature i ppf s; | Tmty_functor (s, _, mt1, mt2) -> line i ppf "Pmty_functor \"%a\"\n" fmt_ident s; module_type i ppf mt1; module_type i ppf mt2; | Tmty_with (mt, l) -> line i ppf "Pmty_with\n"; module_type i ppf mt; list i longident_x_with_constraint ppf l; | Tmty_typeof m -> line i ppf "Pmty_typeof\n"; module_expr i ppf m; and signature i ppf x = list i signature_item ppf x.sig_items and signature_item i ppf x = line i ppf "signature_item %a\n" fmt_location x.sig_loc; let i = i+1 in match x.sig_desc with | Tsig_value (s, _, vd) -> line i ppf "Psig_value \"%a\"\n" fmt_ident s; value_description i ppf vd; | Tsig_type (l) -> line i ppf "Psig_type\n"; list i string_x_type_declaration ppf l; | Tsig_exception (s, _, ed) -> line i ppf "Psig_exception \"%a\"\n" fmt_ident s; exception_declaration i ppf ed.exn_params; | Tsig_module (s, _, mt) -> line i ppf "Psig_module \"%a\"\n" fmt_ident s; module_type i ppf mt; | Tsig_recmodule decls -> line i ppf "Psig_recmodule\n"; list i string_x_module_type ppf decls; | Tsig_modtype (s, _, md) -> line i ppf "Psig_modtype \"%a\"\n" fmt_ident s; modtype_declaration i ppf md; | Tsig_open (li,_) -> line i ppf "Psig_open %a\n" fmt_path li; | Tsig_include (mt, _) -> line i ppf "Psig_include\n"; module_type i ppf mt; | Tsig_class (l) -> line i ppf "Psig_class\n"; list i class_description ppf l; | Tsig_class_type (l) -> line i ppf "Psig_class_type\n"; list i class_type_declaration ppf l; and modtype_declaration i ppf x = match x with | Tmodtype_abstract -> line i ppf "Pmodtype_abstract\n"; | Tmodtype_manifest (mt) -> line i ppf "Pmodtype_manifest\n"; module_type (i+1) ppf mt; and with_constraint i ppf x = match x with | Twith_type (td) -> line i ppf "Pwith_type\n"; type_declaration (i+1) ppf td; | Twith_typesubst (td) -> line i ppf "Pwith_typesubst\n"; type_declaration (i+1) ppf td; | Twith_module (li,_) -> line i ppf "Pwith_module %a\n" fmt_path li; | Twith_modsubst (li,_) -> line i ppf "Pwith_modsubst %a\n" fmt_path li; and module_expr i ppf x = line i ppf "module_expr %a\n" fmt_location x.mod_loc; let i = i+1 in match x.mod_desc with | Tmod_ident (li,_) -> line i ppf "Pmod_ident %a\n" fmt_path li; | Tmod_structure (s) -> line i ppf "Pmod_structure\n"; structure i ppf s; | Tmod_functor (s, _, mt, me) -> line i ppf "Pmod_functor \"%a\"\n" fmt_ident s; module_type i ppf mt; module_expr i ppf me; | Tmod_apply (me1, me2, _) -> line i ppf "Pmod_apply\n"; module_expr i ppf me1; module_expr i ppf me2; | Tmod_constraint (me, _, Tmodtype_explicit mt, _) -> line i ppf "Pmod_constraint\n"; module_expr i ppf me; module_type i ppf mt; | Tmod_constraint (me, _, Tmodtype_implicit, _) -> assert false (* TODO *) (* line i ppf "Pmod_constraint\n"; module_expr i ppf me; module_type i ppf mt; *) | Tmod_unpack (e, _) -> line i ppf "Pmod_unpack\n"; expression i ppf e; and structure i ppf x = list i structure_item ppf x.str_items and structure_item i ppf x = line i ppf "structure_item %a\n" fmt_location x.str_loc; let i = i+1 in match x.str_desc with | Tstr_eval (e) -> line i ppf "Pstr_eval\n"; expression i ppf e; | Tstr_value (rf, l) -> line i ppf "Pstr_value %a\n" fmt_rec_flag rf; list i pattern_x_expression_def ppf l; | Tstr_primitive (s, _, vd) -> line i ppf "Pstr_primitive \"%a\"\n" fmt_ident s; value_description i ppf vd; | Tstr_type l -> line i ppf "Pstr_type\n"; list i string_x_type_declaration ppf l; | Tstr_exception (s, _, ed) -> line i ppf "Pstr_exception \"%a\"\n" fmt_ident s; exception_declaration i ppf ed.exn_params; | Tstr_exn_rebind (s, _, li, _) -> line i ppf "Pstr_exn_rebind \"%a\" %a\n" fmt_ident s fmt_path li; | Tstr_module (s, _, me) -> line i ppf "Pstr_module \"%a\"\n" fmt_ident s; module_expr i ppf me; | Tstr_recmodule bindings -> line i ppf "Pstr_recmodule\n"; list i string_x_modtype_x_module ppf bindings; | Tstr_modtype (s, _, mt) -> line i ppf "Pstr_modtype \"%a\"\n" fmt_ident s; module_type i ppf mt; | Tstr_open (li, _) -> line i ppf "Pstr_open %a\n" fmt_path li; | Tstr_class (l) -> line i ppf "Pstr_class\n"; list i class_declaration ppf (List.map (fun (cl, _,_) -> cl) l); | Tstr_class_type (l) -> line i ppf "Pstr_class_type\n"; list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l); | Tstr_include (me, _) -> line i ppf "Pstr_include"; module_expr i ppf me and string_x_type_declaration i ppf (s, _, td) = ident i ppf s; type_declaration (i+1) ppf td; and string_x_module_type i ppf (s, _, mty) = ident i ppf s; module_type (i+1) ppf mty; and string_x_modtype_x_module i ppf (s, _, mty, modl) = ident i ppf s; module_type (i+1) ppf mty; module_expr (i+1) ppf modl; and longident_x_with_constraint i ppf (li, _, wc) = line i ppf "%a\n" fmt_path li; with_constraint (i+1) ppf wc; and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = line i ppf " %a\n" fmt_location l; core_type (i+1) ppf ct1; core_type (i+1) ppf ct2; and string_x_core_type_list_x_location i ppf (s, _, l, r_opt) = line i ppf "\"%a\"\n" fmt_ident s; list (i+1) core_type ppf l; (* option (i+1) core_type ppf r_opt; *) and string_x_mutable_flag_x_core_type_x_location i ppf (s, _, mf, ct, loc) = line i ppf "\"%a\" %a %a\n" fmt_ident s fmt_mutable_flag mf fmt_location loc; core_type (i+1) ppf ct; and string_list_x_location i ppf (l, loc) = line i ppf " %a\n" fmt_location loc; list (i+1) string_loc ppf l; and longident_x_pattern i ppf (li, _, _, p) = line i ppf "%a\n" fmt_path li; pattern (i+1) ppf p; and pattern_x_expression_case i ppf (p, e) = line i ppf "\n"; pattern (i+1) ppf p; expression (i+1) ppf e; and pattern_x_expression_def i ppf (p, e) = line i ppf "\n"; pattern (i+1) ppf p; expression (i+1) ppf e; and string_x_expression i ppf (s, _, e) = line i ppf " \"%a\"\n" fmt_path s; expression (i+1) ppf e; and longident_x_expression i ppf (li, _, _, e) = line i ppf "%a\n" fmt_path li; expression (i+1) ppf e; and label_x_expression i ppf (l, e, _) = line i ppf "
\n"; let print_one constr = bs b "\n\n\n"; ( match constr.vc_text with None -> () | Some t -> bs b ""; bs b ""; bs b ""; ); bs b "\n" in print_concat b "\n" print_one l; bs b "
\n"; bs b ""; bs b (self#keyword "|"); bs b "\n"; bs b ""; bp b "%s" (Naming.const_target t constr) (self#constructor constr.vc_name); ( match constr.vc_args, constr.vc_ret with [], None -> () | l,None -> bs b (" " ^ (self#keyword "of") ^ " "); self#html_of_type_expr_list ~par: false b father " * " l; | [],Some r -> bs b (" " ^ (self#keyword ":") ^ " "); self#html_of_type_expr b father r; | l,Some r -> bs b (" " ^ (self#keyword ":") ^ " "); self#html_of_type_expr_list ~par: false b father " * " l; bs b (" " ^ (self#keyword "->") ^ " "); self#html_of_type_expr b father r; ); bs b ""; bs b ""; bs b "(*"; bs b ""; self#html_of_text b t; bs b ""; bs b ""; bs b "*)"; bs b "
\n" | Type_record l -> bs b "= "; if priv then bs b "private " ; bs b "{"; bs b ( match t.ty_manifest with None -> "" | Some _ -> "" ); bs b "\n" ; let print_one r = bs b "\n\n\n"; ( match r.rf_text with None -> () | Some t -> bs b ""; bs b ""; ); bs b "\n" in print_concat b "\n" print_one l; bs b "
\n"; bs b "  "; bs b "\n"; bs b ""; if r.rf_mutable then bs b (self#keyword "mutable ") ; bp b "%s :" (Naming.recfield_target t r) r.rf_name; self#html_of_type_expr b father r.rf_type; bs b ";"; bs b ""; bs b "(*"; bs b ""; self#html_of_text b t; bs b ""; bs b "*)
\n}\n" ); bs b "\n"; self#html_of_info b t.ty_info; bs b "\n" (** Print html code for a class attribute. *) method html_of_attribute b a = let module_name = Name.father (Name.father a.att_value.val_name) in bs b "
" ;
      bp b "" (Naming.attribute_target a);
      bs b (self#keyword "val");
      bs b " ";
      (
       if a.att_virtual then
         bs b ((self#keyword "virtual")^ " ")
       else
         ()
      );
      (
       if a.att_mutable then
         bs b ((self#keyword Odoc_messages.mutab)^ " ")
       else
         ()
      );(
       match a.att_value.val_code with
         None -> bs b (Name.simple a.att_value.val_name)
       | Some c ->
           let file = Naming.file_code_attribute_complete_target a in
           self#output_code a.att_value.val_name (Filename.concat !Global.target_dir file) c;
           bp b "%s" file (Name.simple a.att_value.val_name);
      );
      bs b "";
      bs b " : ";
      self#html_of_type_expr b module_name a.att_value.val_type;
      bs b "
"; self#html_of_info b a.att_value.val_info (** Print html code for a class method. *) method html_of_method b m = let module_name = Name.father (Name.father m.met_value.val_name) in bs b "
";
      (* html mark *)
      bp b "" (Naming.method_target m);
     bs b ((self#keyword "method")^" ");
       if m.met_private then bs b ((self#keyword "private")^" ");
      if m.met_virtual then bs b ((self#keyword "virtual")^" ");
      (
       match m.met_value.val_code with
         None -> bs b  (Name.simple m.met_value.val_name)
       | Some c ->
           let file = Naming.file_code_method_complete_target m in
           self#output_code m.met_value.val_name (Filename.concat !Global.target_dir file) c;
           bp b "%s" file (Name.simple m.met_value.val_name);
      );
      bs b "";
      bs b " : ";
      self#html_of_type_expr b module_name m.met_value.val_type;
      bs b "
"; self#html_of_info b m.met_value.val_info; ( if !with_parameter_list then self#html_of_parameter_list b module_name m.met_value.val_parameters else self#html_of_described_parameter_list b module_name m.met_value.val_parameters ) (** Print html code for the description of a function parameter. *) method html_of_parameter_description b p = match Parameter.names p with [] -> () | name :: [] -> ( (* Only one name, no need for label for the description. *) match Parameter.desc_by_name p name with None -> () | Some t -> self#html_of_text b t ) | l -> (* A list of names, we display those with a description. *) let l2 = List.filter (fun n -> (Parameter.desc_by_name p n) <> None) l in let print_one n = match Parameter.desc_by_name p n with None -> () | Some t -> bs b ""; bs b n; bs b " : "; self#html_of_text b t in print_concat b "
\n" print_one l2 (** Print html code for a list of parameters. *) method html_of_parameter_list b m_name l = match l with [] -> () | _ -> bs b "
"; bs b "\n"; bs b "\n\n" ; bs b "\n\n
"; bs b ""; bs b Odoc_messages.parameters; bs b ": \n\n"; let print_one p = bs b "\n\n\n"; bs b "\n"; in List.iter print_one l; bs b "
\n"; bs b ( match Parameter.complete_name p with "" -> "?" | s -> s ); bs b ":"; self#html_of_type_expr b m_name (Parameter.typ p); bs b "
\n"; self#html_of_parameter_description b p; bs b "\n
\n
\n" (** Print html code for the parameters which have a name and description. *) method html_of_described_parameter_list b m_name l = (* get the params which have a name, and at least one name described. *) let l2 = List.filter (fun p -> List.exists (fun n -> (Parameter.desc_by_name p n) <> None) (Parameter.names p)) l in let f p = bs b "
"; bs b (Parameter.complete_name p); bs b " : " ; self#html_of_parameter_description b p; bs b "
\n" in List.iter f l2 (** Print html code for a list of module parameters. *) method html_of_module_parameter_list b m_name l = match l with [] -> () | _ -> bs b "\n"; bs b "\n"; bs b "\n\n\n
"; bs b Odoc_messages.parameters ; bs b ": \n"; bs b "\n"; List.iter (fun (p, desc_opt) -> bs b "\n"; bs b "\n" ; bs b "\n"; bs b "\n" ; ) ) l; bs b "
\n" ; bs b p.mp_name; bs b ":" ; self#html_of_module_parameter_type b m_name p; bs b "\n"; ( match desc_opt with None -> () | Some t -> bs b "
"; self#html_of_text b t; bs b "\n
\n
\n" (** Print html code for a module. *) method html_of_module b ?(info=true) ?(complete=true) ?(with_link=true) m = let (html_file, _) = Naming.html_files m.m_name in let father = Name.father m.m_name in bs b "
";
      bs b ((self#keyword "module")^" ");
      (
       if with_link then
         bp b "%s" html_file (Name.simple m.m_name)
       else
         bs b (Name.simple m.m_name)
      );
      (
       match m.m_kind with
         Module_functor _ when !html_short_functors  ->
           ()
       | _ -> bs b ": "
      );
      self#html_of_module_kind b father ~modu: m m.m_kind;
      bs b "
"; if info then ( if complete then self#html_of_info ~indent: true else self#html_of_info_first_sentence ) b m.m_info else () (** Print html code for a module type. *) method html_of_modtype b ?(info=true) ?(complete=true) ?(with_link=true) mt = let (html_file, _) = Naming.html_files mt.mt_name in let father = Name.father mt.mt_name in bs b "
";
      bs b ((self#keyword "module type")^" ");
      (
       if with_link then
         bp b "%s" html_file (Name.simple mt.mt_name)
         else
         bs b (Name.simple mt.mt_name)
      );
      (match mt.mt_kind with
        None -> ()
      | Some k ->
          bs b " = ";
          self#html_of_module_type_kind b father ~mt k
      );
      bs b "
"; if info then ( if complete then self#html_of_info ~indent: true else self#html_of_info_first_sentence ) b mt.mt_info else () (** Print html code for an included module. *) method html_of_included_module b im = bs b "
";
      bs b ((self#keyword "include")^" ");
      (
       match im.im_module with
         None ->
           bs b im.im_name
       | Some mmt ->
           let (file, name) =
             match mmt with
               Mod m ->
                 let (html_file, _) = Naming.html_files m.m_name in
                 (html_file, m.m_name)
             | Modtype mt ->
                 let (html_file, _) = Naming.html_files mt.mt_name in
                 (html_file, mt.mt_name)
           in
           bp b "%s" file name
      );
      bs b "
\n"; self#html_of_info b im.im_info method html_of_class_element b element = match element with Class_attribute a -> self#html_of_attribute b a | Class_method m -> self#html_of_method b m | Class_comment t -> self#html_of_class_comment b t method html_of_class_kind b father ?cl kind = match kind with Class_structure (inh, eles) -> self#html_of_text b [Code "object"]; ( match cl with None -> bs b "\n"; ( match inh with [] -> () | _ -> self#generate_inheritance_info b inh ); List.iter (self#html_of_class_element b) eles; | Some cl -> let (html_file, _) = Naming.html_files cl.cl_name in bp b " .. " html_file ); self#html_of_text b [Code "end"] | Class_apply capp -> (* TODO: display final type from typedtree *) self#html_of_text b [Raw "class application not handled yet"] | Class_constr cco -> ( match cco.cco_type_parameters with [] -> () | l -> self#html_of_class_type_param_expr_list b father l; bs b " " ); bs b ""; bs b (self#create_fully_qualified_idents_links father cco.cco_name); bs b "" | Class_constraint (ck, ctk) -> self#html_of_text b [Code "( "] ; self#html_of_class_kind b father ck; self#html_of_text b [Code " : "] ; self#html_of_class_type_kind b father ctk; self#html_of_text b [Code " )"] method html_of_class_type_kind b father ?ct kind = match kind with Class_type cta -> ( match cta.cta_type_parameters with [] -> () | l -> self#html_of_class_type_param_expr_list b father l; bs b " " ); bs b ""; bs b (self#create_fully_qualified_idents_links father cta.cta_name); bs b "" | Class_signature (inh, eles) -> self#html_of_text b [Code "object"]; ( match ct with None -> bs b "\n"; ( match inh with [] -> () | _ -> self#generate_inheritance_info b inh ); List.iter (self#html_of_class_element b) eles | Some ct -> let (html_file, _) = Naming.html_files ct.clt_name in bp b " .. " html_file ); self#html_of_text b [Code "end"] (** Print html code for a class. *) method html_of_class b ?(complete=true) ?(with_link=true) c = let father = Name.father c.cl_name in Odoc_info.reset_type_names (); let (html_file, _) = Naming.html_files c.cl_name in bs b "
";
      (* we add a html id, the same as for a type so we can
         go directly here when the class name is used as a type name *)
      bp b ""
        (Naming.type_target
           { ty_name = c.cl_name ;
             ty_info = None ; ty_parameters = [] ;
             ty_kind = Type_abstract ; ty_private = Asttypes.Public; ty_manifest = None ;
             ty_loc = Odoc_info.dummy_loc ;
             ty_code = None ;
           }
        );
      bs b ((self#keyword "class")^" ");
      print_DEBUG "html#html_of_class : virtual or not" ;
      if c.cl_virtual then bs b ((self#keyword "virtual")^" ");
      (
       match c.cl_type_parameters with
         [] -> ()
       | l ->
           self#html_of_class_type_param_expr_list b father l;
           bs b " "
      );
      print_DEBUG "html#html_of_class : with link or not" ;
      (
       if with_link then
         bp b "%s" html_file (Name.simple c.cl_name)
       else
         bs b (Name.simple c.cl_name)
      );
      bs b "";
      bs b " : " ;
      self#html_of_class_parameter_list b father c ;
      self#html_of_class_kind b father ~cl: c c.cl_kind;
      bs b "
" ; print_DEBUG "html#html_of_class : info" ; ( if complete then self#html_of_info ~indent: true else self#html_of_info_first_sentence ) b c.cl_info (** Print html code for a class type. *) method html_of_class_type b ?(complete=true) ?(with_link=true) ct = Odoc_info.reset_type_names (); let father = Name.father ct.clt_name in let (html_file, _) = Naming.html_files ct.clt_name in bs b "
";
      (* we add a html id, the same as for a type so we can
         go directly here when the class type name is used as a type name *)
      bp b ""
        (Naming.type_target
           { ty_name = ct.clt_name ;
             ty_info = None ; ty_parameters = [] ;
             ty_kind = Type_abstract ; ty_private = Asttypes.Public; ty_manifest = None ;
             ty_loc = Odoc_info.dummy_loc ;
             ty_code = None ;
           }
        );
      bs b ((self#keyword "class type")^" ");
      if ct.clt_virtual then bs b ((self#keyword "virtual")^" ");
      (
       match ct.clt_type_parameters with
        [] -> ()
      | l ->
          self#html_of_class_type_param_expr_list b father l;
          bs b " "
      );

      if with_link then
        bp b "%s" html_file (Name.simple ct.clt_name)
      else
        bs b (Name.simple ct.clt_name);

      bs b "";
      bs b " = ";
      self#html_of_class_type_kind b father ~ct ct.clt_kind;
      bs b "
"; ( if complete then self#html_of_info ~indent: true else self#html_of_info_first_sentence ) b ct.clt_info (** Return html code to represent a dag, represented as in Odoc_dag2html. *) method html_of_dag dag = let f n = let (name, cct_opt) = n.Odoc_dag2html.valu in (* if we have a c_opt = Some class then we take its information because we are sure the name is complete. *) let (name2, html_file) = match cct_opt with None -> (name, fst (Naming.html_files name)) | Some (Cl c) -> (c.cl_name, fst (Naming.html_files c.cl_name)) | Some (Cltype (ct, _)) -> (ct.clt_name, fst (Naming.html_files ct.clt_name)) in let new_v = "\n\n
"^ ""^name2^""^ "
\n" in { n with Odoc_dag2html.valu = new_v } in let a = Array.map f dag.Odoc_dag2html.dag in Odoc_dag2html.html_of_dag { Odoc_dag2html.dag = a } (** Print html code for a module comment.*) method html_of_module_comment b text = bs b "
\n"; self#html_of_text b text; bs b "
\n" (** Print html code for a class comment.*) method html_of_class_comment b text = (* Add some style if there is no style for the first part of the text. *) let text2 = match text with | (Odoc_info.Raw s) :: q -> (Odoc_info.Title (2, None, [Odoc_info.Raw s])) :: q | _ -> text in self#html_of_text b text2 (** Generate html code for the given list of inherited classes.*) method generate_inheritance_info b inher_l = let f inh = match inh.ic_class with None -> (* we can't make the link. *) (Odoc_info.Code inh.ic_name) :: (match inh.ic_text with None -> [] | Some t -> (Odoc_info.Raw " ") :: t) | Some cct -> (* we can create the link. *) let real_name = (* even if it should be the same *) match cct with Cl c -> c.cl_name | Cltype (ct, _) -> ct.clt_name in let (class_file, _) = Naming.html_files real_name in (Odoc_info.Link (class_file, [Odoc_info.Code real_name])) :: (match inh.ic_text with None -> [] | Some t -> (Odoc_info.Raw " ") :: t) in let text = [ Odoc_info.Bold [Odoc_info.Raw Odoc_messages.inherits] ; Odoc_info.List (List.map f inher_l) ] in self#html_of_text b text (** Generate html code for the inherited classes of the given class. *) method generate_class_inheritance_info b cl = let rec iter_kind k = match k with Class_structure ([], _) -> () | Class_structure (l, _) -> self#generate_inheritance_info b l | Class_constraint (k, ct) -> iter_kind k | Class_apply _ | Class_constr _ -> () in iter_kind cl.cl_kind (** Generate html code for the inherited classes of the given class type. *) method generate_class_type_inheritance_info b clt = match clt.clt_kind with Class_signature ([], _) -> () | Class_signature (l, _) -> self#generate_inheritance_info b l | Class_type _ -> () (** A method to create index files. *) method generate_elements_index : 'a. 'a list -> ('a -> Odoc_info.Name.t) -> ('a -> Odoc_info.info option) -> ('a -> string) -> string -> string -> unit = fun elements name info target title simple_file -> try let chanout = open_out (Filename.concat !Global.target_dir simple_file) in let b = new_buf () in bs b "\n"; self#print_header b (self#inner_title title); bs b "\n"; self#print_navbar b None None ""; bs b "

"; bs b title; bs b "

\n" ; let sorted_elements = List.sort (fun e1 e2 -> compare (Name.simple (name e1)) (Name.simple (name e2))) elements in let groups = Odoc_info.create_index_lists sorted_elements (fun e -> Name.simple (name e)) in let f_ele e = let simple_name = Name.simple (name e) in let father_name = Name.father (name e) in bp b "%s " (target e) (self#escape simple_name); if simple_name <> father_name && father_name <> "" then bp b "[%s]" (fst (Naming.html_files father_name)) father_name; bs b "\n"; self#html_of_info_first_sentence b (info e); bs b "\n"; in let f_group l = match l with [] -> () | e :: _ -> let s = match (Char.uppercase (Name.simple (name e)).[0]) with 'A'..'Z' as c -> String.make 1 c | _ -> "" in bs b "
"; bs b s ; bs b "\n" ; List.iter f_ele l in bs b "\n"; List.iter f_group groups ; bs b "
\n" ; bs b "\n"; Buffer.output_buffer chanout b; close_out chanout with Sys_error s -> raise (Failure s) (** A method to generate a list of module/class files. *) method generate_elements : 'a. ('a option -> 'a option -> 'a -> unit) -> 'a list -> unit = fun f_generate l -> let rec iter pre_opt = function [] -> () | ele :: [] -> f_generate pre_opt None ele | ele1 :: ele2 :: q -> f_generate pre_opt (Some ele2) ele1 ; iter (Some ele1) (ele2 :: q) in iter None l (** Generate the code of the html page for the given class.*) method generate_for_class pre post cl = Odoc_info.reset_type_names (); let (html_file, _) = Naming.html_files cl.cl_name in let type_file = Naming.file_type_class_complete_target cl.cl_name in try let chanout = open_out (Filename.concat !Global.target_dir html_file) in let b = new_buf () in let pre_name = opt (fun c -> c.cl_name) pre in let post_name = opt (fun c -> c.cl_name) post in bs b doctype ; bs b "\n"; self#print_header b ~nav: (Some (pre_name, post_name, cl.cl_name)) ~comments: (Class.class_comments cl) (self#inner_title cl.cl_name); bs b "\n"; self#print_navbar b pre_name post_name cl.cl_name; bs b "

"; bs b (Odoc_messages.clas^" "); if cl.cl_virtual then bs b "virtual " ; bp b "%s" type_file cl.cl_name; bs b "

\n"; self#html_of_class b ~with_link: false cl; (* parameters *) self#html_of_described_parameter_list b (Name.father cl.cl_name) cl.cl_parameters; (* class inheritance *) self#generate_class_inheritance_info b cl; (* a horizontal line *) bs b "
\n"; (* the various elements *) List.iter (self#html_of_class_element b) (Class.class_elements ~trans:false cl); bs b ""; Buffer.output_buffer chanout b; close_out chanout; (* generate the file with the complete class type *) self#output_class_type cl.cl_name (Filename.concat !Global.target_dir type_file) cl.cl_type with Sys_error s -> raise (Failure s) (** Generate the code of the html page for the given class type.*) method generate_for_class_type pre post clt = Odoc_info.reset_type_names (); let (html_file, _) = Naming.html_files clt.clt_name in let type_file = Naming.file_type_class_complete_target clt.clt_name in try let chanout = open_out (Filename.concat !Global.target_dir html_file) in let b = new_buf () in let pre_name = opt (fun ct -> ct.clt_name) pre in let post_name = opt (fun ct -> ct.clt_name) post in bs b doctype ; bs b "\n"; self#print_header b ~nav: (Some (pre_name, post_name, clt.clt_name)) ~comments: (Class.class_type_comments clt) (self#inner_title clt.clt_name); bs b "\n"; self#print_navbar b pre_name post_name clt.clt_name; bs b "

"; bs b (Odoc_messages.class_type^" "); if clt.clt_virtual then bs b "virtual "; bp b "%s" type_file clt.clt_name; bs b "

\n"; self#html_of_class_type b ~with_link: false clt; (* class inheritance *) self#generate_class_type_inheritance_info b clt; (* a horizontal line *) bs b "
\n"; (* the various elements *) List.iter (self#html_of_class_element b) (Class.class_type_elements ~trans: false clt); bs b ""; Buffer.output_buffer chanout b; close_out chanout; (* generate the file with the complete class type *) self#output_class_type clt.clt_name (Filename.concat !Global.target_dir type_file) clt.clt_type with Sys_error s -> raise (Failure s) (** Generate the html file for the given module type. @raise Failure if an error occurs.*) method generate_for_module_type pre post mt = try let (html_file, _) = Naming.html_files mt.mt_name in let type_file = Naming.file_type_module_complete_target mt.mt_name in let chanout = open_out (Filename.concat !Global.target_dir html_file) in let b = new_buf () in let pre_name = opt (fun mt -> mt.mt_name) pre in let post_name = opt (fun mt -> mt.mt_name) post in bs b doctype ; bs b "\n"; self#print_header b ~nav: (Some (pre_name, post_name, mt.mt_name)) ~comments: (Module.module_type_comments mt) (self#inner_title mt.mt_name); bs b "\n"; self#print_navbar b pre_name post_name mt.mt_name; bp b "

"; bs b (Odoc_messages.module_type^" "); ( match mt.mt_type with Some _ -> bp b "%s" type_file mt.mt_name | None-> bs b mt.mt_name ); bs b "

\n" ; self#html_of_modtype b ~with_link: false mt; (* parameters for functors *) self#html_of_module_parameter_list b (Name.father mt.mt_name) (Module.module_type_parameters mt); (* a horizontal line *) bs b "
\n"; (* module elements *) List.iter (self#html_of_module_element b (Name.father mt.mt_name)) (Module.module_type_elements mt); bs b ""; Buffer.output_buffer chanout b; close_out chanout; (* generate html files for submodules *) self#generate_elements self#generate_for_module (Module.module_type_modules mt); (* generate html files for module types *) self#generate_elements self#generate_for_module_type (Module.module_type_module_types mt); (* generate html files for classes *) self#generate_elements self#generate_for_class (Module.module_type_classes mt); (* generate html files for class types *) self#generate_elements self#generate_for_class_type (Module.module_type_class_types mt); (* generate the file with the complete module type *) ( match mt.mt_type with None -> () | Some mty -> self#output_module_type mt.mt_name (Filename.concat !Global.target_dir type_file) mty ) with Sys_error s -> raise (Failure s) (** Generate the html file for the given module. @raise Failure if an error occurs.*) method generate_for_module pre post modu = try Odoc_info.verbose ("Generate for module "^modu.m_name); let (html_file, _) = Naming.html_files modu.m_name in let type_file = Naming.file_type_module_complete_target modu.m_name in let code_file = Naming.file_code_module_complete_target modu.m_name in let chanout = open_out (Filename.concat !Global.target_dir html_file) in let b = new_buf () in let pre_name = opt (fun m -> m.m_name) pre in let post_name = opt (fun m -> m.m_name) post in bs b doctype ; bs b "\n"; self#print_header b ~nav: (Some (pre_name, post_name, modu.m_name)) ~comments: (Module.module_comments modu) (self#inner_title modu.m_name); bs b "\n" ; self#print_navbar b pre_name post_name modu.m_name ; bs b "

"; if modu.m_text_only then bs b modu.m_name else ( bs b ( if Module.module_is_functor modu then Odoc_messages.functo else Odoc_messages.modul ); bp b " %s" type_file modu.m_name; ( match modu.m_code with None -> () | Some _ -> bp b " (.ml)" code_file ) ); bs b "

\n"; if not modu.m_text_only then self#html_of_module b ~with_link: false modu; (* parameters for functors *) self#html_of_module_parameter_list b (Name.father modu.m_name) (Module.module_parameters modu); (* a horizontal line *) if not modu.m_text_only then bs b "
\n"; (* module elements *) List.iter (self#html_of_module_element b (Name.father modu.m_name)) (Module.module_elements modu); bs b ""; Buffer.output_buffer chanout b; close_out chanout; (* generate html files for submodules *) self#generate_elements self#generate_for_module (Module.module_modules modu); (* generate html files for module types *) self#generate_elements self#generate_for_module_type (Module.module_module_types modu); (* generate html files for classes *) self#generate_elements self#generate_for_class (Module.module_classes modu); (* generate html files for class types *) self#generate_elements self#generate_for_class_type (Module.module_class_types modu); (* generate the file with the complete module type *) self#output_module_type modu.m_name (Filename.concat !Global.target_dir type_file) modu.m_type; match modu.m_code with None -> () | Some code -> self#output_code modu.m_name (Filename.concat !Global.target_dir code_file) code with Sys_error s -> raise (Failure s) (** Generate the [.html] file corresponding to the given module list. @raise Failure if an error occurs.*) method generate_index module_list = try let chanout = open_out (Filename.concat !Global.target_dir self#index) in let b = new_buf () in let title = match !Global.title with None -> "" | Some t -> self#escape t in bs b doctype ; bs b "\n"; self#print_header b self#title; bs b "\n"; bs b "

"; bs b title; bs b "

\n" ; let info = Odoc_info.apply_opt (Odoc_info.info_of_comment_file module_list) !Odoc_info.Global.intro_file in ( match info with None -> self#html_of_Index_list b; bs b "
"; self#html_of_Module_list b (List.map (fun m -> m.m_name) module_list); | Some i -> self#html_of_info ~indent: false b info ); bs b "\n"; Buffer.output_buffer chanout b; close_out chanout with Sys_error s -> raise (Failure s) (** Generate the values index in the file [index_values.html]. *) method generate_values_index module_list = self#generate_elements_index self#list_values (fun v -> v.val_name) (fun v -> v.val_info) Naming.complete_value_target Odoc_messages.index_of_values self#index_values (** Generate the exceptions index in the file [index_exceptions.html]. *) method generate_exceptions_index module_list = self#generate_elements_index self#list_exceptions (fun e -> e.ex_name) (fun e -> e.ex_info) Naming.complete_exception_target Odoc_messages.index_of_exceptions self#index_exceptions (** Generate the types index in the file [index_types.html]. *) method generate_types_index module_list = self#generate_elements_index self#list_types (fun t -> t.ty_name) (fun t -> t.ty_info) Naming.complete_type_target Odoc_messages.index_of_types self#index_types (** Generate the attributes index in the file [index_attributes.html]. *) method generate_attributes_index module_list = self#generate_elements_index self#list_attributes (fun a -> a.att_value.val_name) (fun a -> a.att_value.val_info) Naming.complete_attribute_target Odoc_messages.index_of_attributes self#index_attributes (** Generate the methods index in the file [index_methods.html]. *) method generate_methods_index module_list = self#generate_elements_index self#list_methods (fun m -> m.met_value.val_name) (fun m -> m.met_value.val_info) Naming.complete_method_target Odoc_messages.index_of_methods self#index_methods (** Generate the classes index in the file [index_classes.html]. *) method generate_classes_index module_list = self#generate_elements_index self#list_classes (fun c -> c.cl_name) (fun c -> c.cl_info) (fun c -> fst (Naming.html_files c.cl_name)) Odoc_messages.index_of_classes self#index_classes (** Generate the class types index in the file [index_class_types.html]. *) method generate_class_types_index module_list = self#generate_elements_index self#list_class_types (fun ct -> ct.clt_name) (fun ct -> ct.clt_info) (fun ct -> fst (Naming.html_files ct.clt_name)) Odoc_messages.index_of_class_types self#index_class_types (** Generate the modules index in the file [index_modules.html]. *) method generate_modules_index module_list = self#generate_elements_index self#list_modules (fun m -> m.m_name) (fun m -> m.m_info) (fun m -> fst (Naming.html_files m.m_name)) Odoc_messages.index_of_modules self#index_modules (** Generate the module types index in the file [index_module_types.html]. *) method generate_module_types_index module_list = self#generate_elements_index self#list_module_types (fun mt -> mt.mt_name) (fun mt -> mt.mt_info) (fun mt -> fst (Naming.html_files mt.mt_name)) Odoc_messages.index_of_module_types self#index_module_types (** Generate all the html files from a module list. The main file is [.html]. *) method generate module_list = (* init the style *) self#init_style ; (* init the lists of elements *) list_values <- Odoc_info.Search.values module_list ; list_exceptions <- Odoc_info.Search.exceptions module_list ; list_types <- Odoc_info.Search.types module_list ; list_attributes <- Odoc_info.Search.attributes module_list ; list_methods <- Odoc_info.Search.methods module_list ; list_classes <- Odoc_info.Search.classes module_list ; list_class_types <- Odoc_info.Search.class_types module_list ; list_modules <- Odoc_info.Search.modules module_list ; list_module_types <- Odoc_info.Search.module_types module_list ; (* prepare the page header *) self#prepare_header module_list ; (* Get the names of all known types. *) let types = Odoc_info.Search.types module_list in known_types_names <- List.fold_left (fun acc t -> StringSet.add t.ty_name acc) known_types_names types ; (* Get the names of all class and class types. *) let classes = Odoc_info.Search.classes module_list in let class_types = Odoc_info.Search.class_types module_list in known_classes_names <- List.fold_left (fun acc c -> StringSet.add c.cl_name acc) known_classes_names classes ; known_classes_names <- List.fold_left (fun acc ct -> StringSet.add ct.clt_name acc) known_classes_names class_types ; (* Get the names of all known modules and module types. *) let module_types = Odoc_info.Search.module_types module_list in let modules = Odoc_info.Search.modules module_list in known_modules_names <- List.fold_left (fun acc m -> StringSet.add m.m_name acc) known_modules_names modules ; known_modules_names <- List.fold_left (fun acc mt -> StringSet.add mt.mt_name acc) known_modules_names module_types ; (* generate html for each module *) if not !index_only then self#generate_elements self#generate_for_module module_list ; try self#generate_index module_list; self#generate_values_index module_list ; self#generate_exceptions_index module_list ; self#generate_types_index module_list ; self#generate_attributes_index module_list ; self#generate_methods_index module_list ; self#generate_classes_index module_list ; self#generate_class_types_index module_list ; self#generate_modules_index module_list ; self#generate_module_types_index module_list ; with Failure s -> prerr_endline s ; incr Odoc_info.errors initializer Odoc_ocamlhtml.html_of_comment := (fun s -> let b = new_buf () in self#html_of_text b (Odoc_text.Texter.text_of_string s); Buffer.contents b ) end end module type Html_generator = module type of Generator mingw-ocaml/ocaml/ocamldoc/odoc_texi.ml0000644000175000017500000012334212124403242017554 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Olivier Andrieu, base sur du code de Maxence Guesdon *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Generation of Texinfo documentation. *) open Odoc_info open Parameter open Value open Type open Exception open Class open Module let esc_8bits = ref false let info_section = ref "OCaml" let info_entry = ref [] (** {2 Some small helper functions} *) let puts_nl chan s = output_string chan s ; output_char chan '\n' let puts chan s = output_string chan s let nl chan = output_char chan '\n' let is = function | None -> false | Some _ -> true let pad_to n s = let len = String.length s in if len < n then let s' = String.make n ' ' in String.blit s 0 s' 0 len ; s' else s let indent nb_sp s = let c = ref 0 in let len = pred (String.length s) in for i = 0 to len do if s.[i] = '\n' then incr c done ; let s' = String.make (succ len + (succ !c) * nb_sp ) ' ' in c := nb_sp ; for i = 0 to len do s'.[!c] <- s.[i] ; if s.[i] = '\n' then c := !c + nb_sp ; incr c done ; s' type subparts = [ | `Module of Odoc_info.Module.t_module | `Module_type of Odoc_info.Module.t_module_type | `Class of Odoc_info.Class.t_class | `Class_type of Odoc_info.Class.t_class_type ] type menu_data = [ | subparts | `Blank | `Comment of string | `Texi of string | `Index of string ] list let nothing = Verbatim "" let module_subparts = let rec iter acc = function | [] -> List.rev acc (* skip aliases *) | Element_module { m_kind = Module_alias _ } :: n -> iter acc n | Element_module_type { mt_kind = Some (Module_type_alias _) } :: n -> iter acc n (* keep modules, module types, classes and class types *) | Element_module m :: n -> iter (`Module m :: acc) n | Element_module_type mt :: n -> iter (`Module_type mt :: acc) n | Element_class c :: n -> iter (`Class c :: acc) n | Element_class_type ct :: n -> iter (`Class_type ct :: acc) n (* forget the rest *) | _ :: n -> iter acc n in iter [] type indices = [ | `Type | `Exception | `Value | `Class_att | `Method | `Class | `Class_type | `Module | `Module_type ] let indices = function | `Type -> "ty" | `Exception -> "ex" | `Value -> "va" | `Class_att -> "ca" | `Method -> "me" | `Class -> "cl" | `Class_type -> "ct" | `Module -> "mo" | `Module_type -> "mt" let indices_names = [ "Types" , "ty" ; "Exceptions" , "ex" ; "Values" , "va" ; "Class attributes", "ca" ; "Methods" , "me" ; "Classes" , "cl" ; "Class types" , "ct" ; "Modules" , "mo" ; "Module types" , "mt" ; ] (** Module for generating various Texinfo things (menus, xrefs, ...) *) module Texi = struct (** Associations of strings to subsitute in Texinfo code. *) let subst_strings = [ (Str.regexp "@", "@@") ; (Str.regexp "{", "@{") ; (Str.regexp "}", "@}") ; (Str.regexp "\\.\\.\\.", "@dots{}") ; ] @ (if !esc_8bits then [ (Str.regexp "\xE0", "@`a") ; (Str.regexp "\xE2", "@^a") ; (Str.regexp "\xE9", "@'e") ; (Str.regexp "\xE8", "@`e") ; (Str.regexp "\xEA", "@^e") ; (Str.regexp "\xEB", "@\"e") ; (Str.regexp "\xF7", "@,{c}") ; (Str.regexp "\xF4", "@^o") ; (Str.regexp "\xF6", "@\"o") ; (Str.regexp "\xEE", "@^i") ; (Str.regexp "\xEF", "@\"i") ; (Str.regexp "\xF9", "@`u") ; (Str.regexp "\xFB", "@^u") ; (Str.regexp "\xE6", "@ae{}" ) ; (Str.regexp "\xC6", "@AE{}" ) ; (Str.regexp "\xDF", "@ss{}" ) ; (Str.regexp "\xA9", "@copyright{}" ) ; ] else []) (** Escape the strings which would clash with Texinfo syntax. *) let escape s = List.fold_left (fun acc (p, r) -> Str.global_replace p r acc) s subst_strings (** Removes dots (no good for a node name). *) let fix_nodename s = Str.global_replace (Str.regexp "\\.") "/" (escape s) (** Generates a Texinfo menu. *) let generate_menu chan subpart_list = if subpart_list <> [] then begin let menu_line part_qual name = let sname = Name.simple name in if sname = name then ( puts chan (pad_to 35 ("* " ^ sname ^ ":: ")) ; puts_nl chan part_qual ) else ( puts chan (pad_to 35 ("* " ^ sname ^ ": " ^ (fix_nodename name) ^ ". " )) ; puts_nl chan part_qual ) in puts_nl chan "@menu" ; List.iter (function | `Module { m_name = name } -> menu_line Odoc_messages.modul name | `Module_type { mt_name = name } -> menu_line Odoc_messages.module_type name | `Class { cl_name = name } -> menu_line Odoc_messages.clas name | `Class_type { clt_name = name } -> menu_line Odoc_messages.class_type name | `Blank -> nl chan | `Comment c -> puts_nl chan (escape c) | `Texi t -> puts_nl chan t | `Index ind -> Printf.fprintf chan "* %s::\n" ind) subpart_list ; puts_nl chan "@end menu" end (** cross reference to node [name] *) let xref ?xname name = "@xref{" ^ (fix_nodename name) ^ (match xname with | None -> "" | Some s -> "," ^ s) ^ "}." (** enclose the string between [\@ifinfo] tags *) let ifinfo s = String.concat "\n" [ "@ifinfo" ; s ; "@end ifinfo" ; "" ] (** [install-info] information *) let dirsection sec = "@dircategory " ^ (escape sec) let direntry ent = [ "@direntry" ] @ (List.map escape ent) @ [ "@end direntry" ] end (** {2 Generation of Texinfo code} *) (** This class generates Texinfo code from text structures *) class text = object(self) (** Associations between a title number and texinfo code. *) val titles = [ 1, "@chapter " ; 2, "@section " ; 3, "@subsection " ; 4, "@subsubsection " ; ] val fallback_title = "@unnumberedsubsubsec " val headings = [ 1, "@majorheading " ; 2, "@heading " ; 3, "@subheading " ; 4, "@subsubheading " ; ] val fallback_heading = "@subsubheading " method escape = Texi.escape (** this method is not used here but is virtual in a class we will inherit later *) method label ?(no_ : bool option) (_ : string) : string = failwith "gni" (** Return the Texinfo code corresponding to the [text] parameter.*) method texi_of_text t = String.concat "" (List.map self#texi_of_text_element t) (** {3 Conversion methods} [texi_of_????] converts a [text_element] to a Texinfo string. *) (** Return the Texinfo code for the [text_element] in parameter. *) method texi_of_text_element = function | Verbatim s | Latex s -> self#texi_of_Verbatim s | Raw s -> self#texi_of_Raw s | Code s -> self#texi_of_Code s | CodePre s -> self#texi_of_CodePre s | Bold t -> self#texi_of_Bold t | Italic t -> self#texi_of_Italic t | Emphasize t -> self#texi_of_Emphasize t | Center t -> self#texi_of_Center t | Left t -> self#texi_of_Left t | Right t -> self#texi_of_Right t | List tl -> self#texi_of_List tl | Enum tl -> self#texi_of_Enum tl | Newline -> self#texi_of_Newline | Block t -> self#texi_of_Block t | Title (n, _, t) -> self#texi_of_Title n t | Link (s, t) -> self#texi_of_Link s t | Ref (name, kind, _) ->self#texi_of_Ref name kind | Superscript t -> self#texi_of_Superscript t | Subscript t -> self#texi_of_Subscript t | Odoc_info.Module_list _ -> "" | Odoc_info.Index_list -> "" | Odoc_info.Custom (s,t) -> self#texi_of_custom_text s t | Odoc_info.Target (target, code) -> self#texi_of_Target ~target ~code method texi_of_custom_text s t = "" method texi_of_Target ~target ~code = if String.lowercase target = "texi" then code else "" method texi_of_Verbatim s = s method texi_of_Raw s = self#escape s method texi_of_Code s = "@code{" ^ (self#escape s) ^ "}" method texi_of_CodePre s = String.concat "\n" [ "" ; "@example" ; self#escape s ; "@end example" ; "" ] method texi_of_Bold t = "@strong{" ^ (self#texi_of_text t) ^ "}" method texi_of_Italic t = "@i{" ^ (self#texi_of_text t) ^ "}" method texi_of_Emphasize t = "@emph{" ^ (self#texi_of_text t) ^ "}" method texi_of_Center t = let sl = Str.split (Str.regexp "\n") (self#texi_of_text t) in String.concat "" ((List.map (fun s -> "\n@center "^s) sl) @ [ "\n" ]) method texi_of_Left t = String.concat "\n" [ "" ; "@flushleft" ; self#texi_of_text t ; "@end flushleft" ; "" ] method texi_of_Right t = String.concat "\n" [ "" ; "@flushright" ; self#texi_of_text t ; "@end flushright"; "" ] method texi_of_List tl = String.concat "\n" ( [ "" ; "@itemize" ] @ (List.map (fun t -> "@item\n" ^ (self#texi_of_text t)) tl) @ [ "@end itemize"; "" ] ) method texi_of_Enum tl = String.concat "\n" ( [ "" ; "@enumerate" ] @ (List.map (fun t -> "@item\n" ^ (self#texi_of_text t)) tl) @ [ "@end enumerate"; "" ] ) method texi_of_Newline = "\n" method texi_of_Block t = String.concat "\n" [ "@format" ; self#texi_of_text t ; "@end format" ; "" ] method texi_of_Title n t = let t_begin = try List.assoc n titles with Not_found -> fallback_title in t_begin ^ (self#texi_of_text t) ^ "\n" method texi_of_Link s t = String.concat "" [ "@uref{" ; s ; "," ; self#texi_of_text t ; "}" ] method texi_of_Ref name kind = let xname = match kind with | Some RK_module -> Odoc_messages.modul ^ " " ^ (Name.simple name) | Some RK_module_type -> Odoc_messages.module_type ^ " " ^ (Name.simple name) | Some RK_class -> Odoc_messages.clas ^ " " ^ (Name.simple name) | Some RK_class_type -> Odoc_messages.class_type ^ " " ^ (Name.simple name) | _ -> "" in if xname = "" then self#escape name else Texi.xref ~xname name method texi_of_Superscript t = "^@{" ^ (self#texi_of_text t) ^ "@}" method texi_of_Subscript t = "_@{" ^ (self#texi_of_text t) ^ "@}" method heading n t = let f = try List.assoc n headings with Not_found -> fallback_heading in f ^ (self#texi_of_text t) ^ "\n" method fixedblock t = Block ( ( Verbatim "@t{" :: t ) @ [ Verbatim "}" ] ) end exception Aliased_node module Generator = struct (** This class is used to create objects which can generate a simple Texinfo documentation. *) class texi = object (self) inherit text as to_texi inherit Odoc_to_text.to_text as to_text (** {3 Small helper stuff.} *) val maxdepth = 4 val bullet = Verbatim " @bullet{} " val minus = Verbatim " @minus{} " val linebreak = Verbatim "@*\n" val mutable indices_to_build = [ `Module ] (** Keep a set of nodes we create. If we try to create one a second time, that means it is some kind of alias, so don't do it, just link to the previous one *) val node_tbl = Hashtbl.create 37 method node depth name = if Hashtbl.mem node_tbl name then raise Aliased_node ; Hashtbl.add node_tbl name () ; if depth <= maxdepth then Verbatim ("@node " ^ (Texi.fix_nodename name) ^ ",\n") else nothing method index (ind : indices) ent = Verbatim (if !Global.with_index then (assert(List.mem ind indices_to_build) ; String.concat "" [ "@" ; indices ind ; "index " ; Texi.escape (Name.simple ent) ; "\n" ]) else "") (** Two hacks to fix linebreaks in the descriptions.*) method private fix_linebreaks = let re = Str.regexp "\n[ \t]*" in fun t -> List.map (function | Newline -> Raw "\n" | Raw s -> Raw (Str.global_replace re "\n" s) | List tel -> List (List.map self#fix_linebreaks tel) | Enum tel -> Enum (List.map self#fix_linebreaks tel) | te -> te) t method private soft_fix_linebreaks = let re = Str.regexp "\n[ \t]*" in fun ind t -> let rep = String.make (succ ind) ' ' in rep.[0] <- '\n' ; List.map (function | Raw s -> Raw (Str.global_replace re rep s) | te -> te) t (** {3 [text] values generation} Generates [text] values out of description parts. Redefines some of methods of {! Odoc_to_text.to_text}. *) method text_of_desc = function | None -> [] | Some [ Raw "" ] -> [] | Some t -> (self#fix_linebreaks t) @ [ Newline ] method text_of_sees_opt see_l = List.concat (List.map (function | (See_url s, t) -> [ linebreak ; Bold [ Raw Odoc_messages.see_also ] ; Raw " " ; Link (s, t) ; Newline ] | (See_file s, t) | (See_doc s, t) -> [ linebreak ; Bold [ Raw Odoc_messages.see_also ] ; Raw " " ; Raw s ] @ t @ [ Newline ]) see_l) method text_of_before l = List.flatten (List.map (fun x -> linebreak :: (to_text#text_of_before [x])) l) method text_of_params params_list = List.concat (List.map (fun (s, t) -> [ linebreak ; Bold [ Raw Odoc_messages.parameters ] ; Raw " " ; Raw s ; Raw ": " ] @ t @ [ Newline ] ) params_list) method! text_of_raised_exceptions = function | [] -> [] | (s, t) :: [] -> [ linebreak ; Bold [ Raw Odoc_messages.raises ] ; Raw " " ; Code s ; Raw " " ] @ t @ [ Newline ] | l -> [ linebreak ; Bold [ Raw Odoc_messages.raises ] ; Raw " :" ; List (List.map (fun (ex, desc) ->(Code ex) :: (Raw " ") :: desc ) l ) ; Newline ] method! text_of_return_opt = function | None -> [] | Some t -> (Bold [Raw Odoc_messages.returns ]) :: Raw " " :: t @ [ Newline ] method! text_of_custom c_l = List.flatten (List.rev (List.fold_left (fun acc -> fun (tag, text) -> try let f = List.assoc tag tag_functions in ( linebreak :: (f text) @ [ Newline ] ) :: acc with Not_found -> Odoc_info.warning (Odoc_messages.tag_not_handled tag) ; acc ) [] c_l)) method! text_of_info ?(block=false) = function | None -> [] | Some info -> let t = List.concat [ ( match info.i_deprecated with | None -> [] | Some t -> (Raw (Odoc_messages.deprecated ^ " ")) :: (self#fix_linebreaks t) @ [ Newline ; Newline ] ) ; self#text_of_desc info.i_desc ; if info.i_authors <> [] then ( linebreak :: self#text_of_author_list info.i_authors ) else [] ; if is info.i_version then ( linebreak :: self#text_of_version_opt info.i_version ) else [] ; self#text_of_sees_opt info.i_sees ; self#text_of_before info.i_before ; if is info.i_since then ( linebreak :: self#text_of_since_opt info.i_since ) else [] ; self#text_of_params info.i_params ; self#text_of_raised_exceptions info.i_raised_exceptions ; if is info.i_return_value then ( linebreak :: self#text_of_return_opt info.i_return_value ) else [] ; self#text_of_custom info.i_custom ; ] in if block then [ Block t ] else (t @ [ Newline ] ) method texi_of_info i = self#texi_of_text (self#text_of_info i) (** {3 Conversion of [module_elements] into Texinfo strings} The following functions convert [module_elements] and their description to [text] values then to Texinfo strings using the functions above. *) method text_el_of_type_expr m_name typ = Raw (indent 5 (self#relative_idents m_name (Odoc_info.string_of_type_expr typ))) method! text_of_short_type_expr m_name typ = [ Raw (self#normal_type m_name typ) ] (** Return Texinfo code for a value. *) method texi_of_value v = Odoc_info.reset_type_names () ; let t = [ self#fixedblock [ Newline ; minus ; Raw ("val " ^ (Name.simple v.val_name) ^ " :\n") ; self#text_el_of_type_expr (Name.father v.val_name) v.val_type ] ; self#index `Value v.val_name ; Newline ] @ (self#text_of_info v.val_info) in self#texi_of_text t (** Return Texinfo code for a class attribute. *) method texi_of_attribute a = Odoc_info.reset_type_names () ; let t = [ self#fixedblock [ Newline ; minus ; Raw "val " ; Raw (if a.att_virtual then "virtual " else "") ; Raw (if a.att_mutable then "mutable " else "") ; Raw (Name.simple a.att_value.val_name) ; Raw " :\n" ; self#text_el_of_type_expr (Name.father a.att_value.val_name) a.att_value.val_type ] ; self#index `Class_att a.att_value.val_name ; Newline ] @ (self#text_of_info a.att_value.val_info) in self#texi_of_text t (** Return Texinfo code for a class method. *) method texi_of_method m = Odoc_info.reset_type_names () ; let t = [ self#fixedblock [ Newline ; minus ; Raw "method " ; Raw (if m.met_private then "private " else "") ; Raw (if m.met_virtual then "virtual " else "") ; Raw (Name.simple m.met_value.val_name) ; Raw " :\n" ; self#text_el_of_type_expr (Name.father m.met_value.val_name) m.met_value.val_type ] ; self#index `Method m.met_value.val_name ; Newline ] @ (self#text_of_info m.met_value.val_info) in self#texi_of_text t method string_of_type_parameters t = let f (tp, co, cn) = Printf.sprintf "%s%s" (Odoc_info.string_of_variance t (co, cn)) (Odoc_info.string_of_type_expr tp) in match t.ty_parameters with | [] -> "" | [ (tp, co, cn) ] -> (f (tp, co, cn))^" " | l -> Printf.sprintf "(%s) " (String.concat ", " (List.map f l)) method string_of_type_args (args:Types.type_expr list) (ret:Types.type_expr option) = match args, ret with | [], None -> "" | args, None -> " of " ^ (Odoc_info.string_of_type_list " * " args) | [], Some r -> " : " ^ (Odoc_info.string_of_type_expr r) | args, Some r -> " : " ^ (Odoc_info.string_of_type_list " * " args) ^ " -> " ^ (Odoc_info.string_of_type_expr r) (** Return Texinfo code for a type. *) method texi_of_type ty = Odoc_info.reset_type_names () ; let t = [ self#fixedblock ( [ Newline ; minus ; Raw "type " ; Raw (self#string_of_type_parameters ty) ; Raw (Name.simple ty.ty_name) ] @ let priv = ty.ty_private = Asttypes.Private in ( match ty.ty_manifest with | None -> [] | Some typ -> (Raw " = ") :: (Raw (if priv then "private " else "")) :: (self#text_of_short_type_expr (Name.father ty.ty_name) typ) ) @ ( match ty.ty_kind with | Type_abstract -> [ Newline ] | Type_variant l -> (Raw (" ="^(if priv then " private" else "")^"\n")) :: (List.flatten (List.map (fun constr -> (Raw (" | " ^ constr.vc_name)) :: (Raw (self#string_of_type_args constr.vc_args constr.vc_ret)) :: (match constr.vc_text with | None -> [ Newline ] | Some t -> (Raw (indent 5 "\n(* ") :: self#soft_fix_linebreaks 8 t) @ [ Raw " *)" ; Newline ] ) ) l ) ) | Type_record l -> (Raw (" = "^(if priv then "private " else "")^"{\n")) :: (List.flatten (List.map (fun r -> [ Raw (" " ^ r.rf_name ^ " : ") ] @ (self#text_of_short_type_expr (Name.father r.rf_name) r.rf_type) @ [ Raw " ;" ] @ (match r.rf_text with | None -> [ Newline ] | Some t -> ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @ [ Raw " *)" ; Newline ] ) ) l ) ) @ [ Raw " }" ] ) ) ; self#index `Type ty.ty_name ; Newline ] @ (self#text_of_info ty.ty_info) in self#texi_of_text t (** Return Texinfo code for an exception. *) method texi_of_exception e = Odoc_info.reset_type_names () ; let t = [ self#fixedblock ( [ Newline ; minus ; Raw "exception " ; Raw (Name.simple e.ex_name) ; Raw (self#string_of_type_args e.ex_args None) ] @ (match e.ex_alias with | None -> [] | Some ea -> [ Raw " = " ; Raw ( match ea.ea_ex with | None -> ea.ea_name | Some e -> e.ex_name ) ; ] ) ) ; self#index `Exception e.ex_name ; Newline ] @ (self#text_of_info e.ex_info) in self#texi_of_text t (** Return the Texinfo code for the given module. *) method texi_of_module m = let is_alias = function | { m_kind = Module_alias _ } -> true | _ -> false in let is_alias_there = function | { m_kind = Module_alias { ma_module = None } } -> false | _ -> true in let resolve_alias_name = function | { m_kind = Module_alias { ma_name = name } } -> name | { m_name = name } -> name in let t = [ [ self#fixedblock [ Newline ; minus ; Raw "module " ; Raw (Name.simple m.m_name) ; Raw (if is_alias m then " = " ^ (resolve_alias_name m) else "" ) ] ] ; ( if is_alias_there m then [ Ref (resolve_alias_name m, Some RK_module, None) ; Newline ; ] else [] ) ; ( if is_alias m then [ self#index `Module m.m_name ; Newline ] else [ Newline ] ) ; self#text_of_info m.m_info ] in self#texi_of_text (List.flatten t) (** Return the Texinfo code for the given module type. *) method texi_of_module_type mt = let is_alias = function | { mt_kind = Some (Module_type_alias _) } -> true | _ -> false in let is_alias_there = function | { mt_kind = Some (Module_type_alias { mta_module = None }) } -> false | _ -> true in let resolve_alias_name = function | { mt_kind = Some (Module_type_alias { mta_name = name }) } -> name | { mt_name = name } -> name in let t = [ [ self#fixedblock [ Newline ; minus ; Raw "module type " ; Raw (Name.simple mt.mt_name) ; Raw (if is_alias mt then " = " ^ (resolve_alias_name mt) else "" ) ] ] ; ( if is_alias_there mt then [ Ref (resolve_alias_name mt, Some RK_module_type, None) ; Newline ; ] else [] ) ; ( if is_alias mt then [ self#index `Module_type mt.mt_name ; Newline ] else [ Newline ] ) ; self#text_of_info mt.mt_info ] in self#texi_of_text (List.flatten t) (** Return the Texinfo code for the given included module. *) method texi_of_included_module im = let t = [ self#fixedblock ( Newline :: minus :: (Raw "include ") :: ( match im.im_module with | None -> [ Raw im.im_name ] | Some (Mod { m_name = name }) -> [ Raw name ; Raw "\n " ; Ref (name, Some RK_module, None) ] | Some (Modtype { mt_name = name }) -> [ Raw name ; Raw "\n " ; Ref (name, Some RK_module_type, None) ] ) @ [ Newline ] @ (self#text_of_info im.im_info) ) ] in self#texi_of_text t (** Return the Texinfo code for the given class. *) method texi_of_class c = Odoc_info.reset_type_names () ; let t = [ self#fixedblock [ Newline ; minus ; Raw "class " ; Raw (Name.simple c.cl_name) ] ; Ref (c.cl_name, Some RK_class, None) ; Newline ; Newline ] @ (self#text_of_info c.cl_info) in self#texi_of_text t (** Return the Texinfo code for the given class type. *) method texi_of_class_type ct = Odoc_info.reset_type_names () ; let t = [ self#fixedblock [ Newline ; minus ; Raw "class type " ; Raw (Name.simple ct.clt_name) ] ; Ref (ct.clt_name, Some RK_class_type, None) ; Newline ; Newline ] @ (self#text_of_info ct.clt_info) in self#texi_of_text t (** Return the Texinfo code for the given class element. *) method texi_of_class_element class_name class_ele = match class_ele with | Class_attribute att -> self#texi_of_attribute att | Class_method met -> self#texi_of_method met | Class_comment t -> self#texi_of_text t (** Return the Texinfo code for the given module element. *) method texi_of_module_element module_name module_ele = (match module_ele with | Element_module m -> self#texi_of_module m | Element_module_type mt -> self#texi_of_module_type mt | Element_included_module im -> self#texi_of_included_module im | Element_class c -> self#texi_of_class c | Element_class_type ct -> self#texi_of_class_type ct | Element_value v -> self#texi_of_value v | Element_exception e -> self#texi_of_exception e | Element_type t -> self#texi_of_type t | Element_module_comment t -> self#texi_of_text (Newline :: t @ [Newline]) ) (** {3 Generating methods } These methods write Texinfo code to an [out_channel] *) (** Generate the Texinfo code for the given list of inherited classes.*) method generate_inheritance_info chanout inher_l = let f inh = match inh.ic_class with | None -> (* we can't make the reference *) (Code inh.ic_name) :: (match inh.ic_text with | None -> [] | Some t -> Newline :: t) | Some cct -> (* we can create the reference *) let kind = match cct with | Cl _ -> Some RK_class | Cltype _ -> Some RK_class_type in (Code inh.ic_name) :: (Ref (inh.ic_name, kind, None)) :: ( match inh.ic_text with | None -> [] | Some t -> Newline :: t) in let text = [ Bold [ Raw Odoc_messages.inherits ] ; List (List.map f inher_l) ; Newline ] in puts chanout (self#texi_of_text text) (** Generate the Texinfo code for the inherited classes of the given class. *) method generate_class_inheritance_info chanout cl = let rec iter_kind = function | Class_structure ([], _) -> () | Class_structure (l, _) -> self#generate_inheritance_info chanout l | Class_constraint (k, _) -> iter_kind k | Class_apply _ | Class_constr _ -> () in iter_kind cl.cl_kind (** Generate the Texinfo code for the inherited classes of the given class type. *) method generate_class_type_inheritance_info chanout clt = match clt.clt_kind with | Class_signature ([], _) -> () | Class_signature (l, _) -> self#generate_inheritance_info chanout l | Class_type _ -> () (** Generate the Texinfo code for the given class, in the given out channel. *) method generate_for_class chanout c = try Odoc_info.reset_type_names () ; let depth = Name.depth c.cl_name in let title = [ self#node depth c.cl_name ; Title (depth, None, [ Raw (Odoc_messages.clas ^ " ") ; Code c.cl_name ]) ; self#index `Class c.cl_name ] in puts chanout (self#texi_of_text title) ; if is c.cl_info then begin let descr = [ Title (succ depth, None, [ Raw Odoc_messages.description ]) ] in puts chanout (self#texi_of_text descr) ; puts chanout (self#texi_of_info c.cl_info) end ; let intf = [ Title (succ depth, None, [ Raw Odoc_messages.interface]) ] in puts chanout (self#texi_of_text intf); self#generate_class_inheritance_info chanout c ; List.iter (fun ele -> puts chanout (self#texi_of_class_element c.cl_name ele)) (Class.class_elements ~trans:false c) with Aliased_node -> () (** Generate the Texinfo code for the given class type, in the given out channel. *) method generate_for_class_type chanout ct = try Odoc_info.reset_type_names () ; let depth = Name.depth ct.clt_name in let title = [ self#node depth ct.clt_name ; Title (depth, None, [ Raw (Odoc_messages.class_type ^ " ") ; Code ct.clt_name ]) ; self#index `Class_type ct.clt_name ] in puts chanout (self#texi_of_text title) ; if is ct.clt_info then begin let descr = [ Title (succ depth, None, [ Raw Odoc_messages.description ]) ] in puts chanout (self#texi_of_text descr) ; puts chanout (self#texi_of_info ct.clt_info) end ; let intf = [ Title (succ depth, None, [ Raw Odoc_messages.interface ]) ] in puts chanout (self#texi_of_text intf) ; self#generate_class_type_inheritance_info chanout ct; List.iter (fun ele -> puts chanout (self#texi_of_class_element ct.clt_name ele)) (Class.class_type_elements ~trans:false ct) with Aliased_node -> () (** Generate the Texinfo code for the given module type, in the given out channel. *) method generate_for_module_type chanout mt = try let depth = Name.depth mt.mt_name in let title = [ self#node depth mt.mt_name ; Title (depth, None, [ Raw (Odoc_messages.module_type ^ " ") ; Code mt.mt_name ]) ; self#index `Module_type mt.mt_name ; Newline ] in puts chanout (self#texi_of_text title) ; if is mt.mt_info then begin let descr = [ Title (succ depth, None, [ Raw Odoc_messages.description ]) ] in puts chanout (self#texi_of_text descr) ; puts chanout (self#texi_of_info mt.mt_info) end ; let mt_ele = Module.module_type_elements ~trans:true mt in let subparts = module_subparts mt_ele in if depth < maxdepth && subparts <> [] then begin let menu = Texi.ifinfo ( self#heading (succ depth) [ Raw "Subparts" ]) in puts chanout menu ; Texi.generate_menu chanout (subparts :> menu_data) end ; let intf = [ Title (succ depth, None, [ Raw Odoc_messages.interface ]) ] in puts chanout (self#texi_of_text intf) ; List.iter (fun ele -> puts chanout (self#texi_of_module_element mt.mt_name ele)) mt_ele ; (* create sub parts for modules, module types, classes and class types *) List.iter (function | `Module m -> self#generate_for_module chanout m | `Module_type mt -> self#generate_for_module_type chanout mt | `Class c -> self#generate_for_class chanout c | `Class_type ct -> self#generate_for_class_type chanout ct) subparts with Aliased_node -> () (** Generate the Texinfo code for the given module, in the given out channel. *) method generate_for_module chanout m = try Odoc_info.verbose ("Generate for module " ^ m.m_name) ; let depth = Name.depth m.m_name in let title = [ self#node depth m.m_name ; Title (depth, None, if m.m_text_only then [ Raw m.m_name ] else [ Raw (Odoc_messages.modul ^ " ") ; Code m.m_name ] ) ; self#index `Module m.m_name ; Newline ] in puts chanout (self#texi_of_text title) ; if is m.m_info then begin let descr = [ Title (succ depth, None, [ Raw Odoc_messages.description ]) ] in puts chanout (self#texi_of_text descr) ; puts chanout (self#texi_of_info m.m_info) end ; let m_ele = Module.module_elements ~trans:true m in let subparts = module_subparts m_ele in if depth < maxdepth && subparts <> [] then begin let menu = Texi.ifinfo ( self#heading (succ depth) [ Raw "Subparts" ]) in puts chanout menu ; Texi.generate_menu chanout (subparts :> menu_data) end ; let intf = [ Title (succ depth, None, [ Raw Odoc_messages.interface]) ] in puts chanout (self#texi_of_text intf) ; List.iter (fun ele -> puts chanout (self#texi_of_module_element m.m_name ele)) m_ele ; (* create sub nodes for modules, module types, classes and class types *) List.iter (function | `Module m -> self#generate_for_module chanout m | `Module_type mt -> self#generate_for_module_type chanout mt | `Class c -> self#generate_for_class chanout c | `Class_type ct -> self#generate_for_class_type chanout ct ) subparts with Aliased_node -> () (** Writes the header of the TeXinfo document. *) method generate_texi_header chan texi_filename m_list = let title = match !Global.title with | None -> "" | Some s -> self#escape s in let filename = if texi_filename <> "ocamldoc.texi" then let fn = Filename.basename texi_filename in (if Filename.check_suffix fn ".texi" then Filename.chop_suffix fn ".texi" else fn) ^ ".info" else if title <> "" then title ^ ".info" else "doc.info" in (* write a standard Texinfo header *) List.iter (puts_nl chan) (List.flatten [ [ "\\input texinfo @c -*-texinfo-*-" ; "@c %**start of header" ; "@setfilename " ^ filename ; "@settitle " ^ title ; "@c %**end of header" ; ] ; (if !Global.with_index then List.map (fun ind -> "@defcodeindex " ^ (indices ind)) indices_to_build else []) ; [ Texi.dirsection !info_section ] ; Texi.direntry (if !info_entry <> [] then !info_entry else [ Printf.sprintf "* %s: (%s)." title (Filename.chop_suffix filename ".info") ]) ; [ "@ifinfo" ; "This file was generated by Ocamldoc using the Texinfo generator." ; "@end ifinfo" ; "@c no titlepage." ; "@node Top, , , (dir)" ; "@top "^ title ; ] ] ) ; (* insert the intro file *) begin match !Odoc_info.Global.intro_file with | None when title <> "" -> puts_nl chan "@ifinfo" ; puts_nl chan ("Documentation for " ^ title) ; puts_nl chan "@end ifinfo" | None -> puts_nl chan "@c no title given" | Some f -> nl chan ; puts_nl chan (self#texi_of_info (Some (Odoc_info.info_of_comment_file m_list f))) end ; (* write a top menu *) Texi.generate_menu chan ((List.map (fun m -> `Module m) m_list) @ (if !Global.with_index then let indices_names_to_build = List.map indices indices_to_build in List.rev (List.fold_left (fun acc -> function (longname, shortname) when List.mem shortname indices_names_to_build -> (`Index (longname ^ " index")) :: acc | _ -> acc) [ `Comment "Indices :" ; `Blank ] indices_names ) else [] )) (** Writes the trailer of the TeXinfo document. *) method generate_texi_trailer chan = nl chan ; if !Global.with_index then let indices_names_to_build = List.map indices indices_to_build in List.iter (puts_nl chan) (List.flatten (List.map (fun (longname, shortname) -> if List.mem shortname indices_names_to_build then [ "@node " ^ longname ^ " index," ; "@unnumbered " ^ longname ^ " index" ; "@printindex " ^ shortname ; ] else []) indices_names )) ; if !Global.with_toc then puts_nl chan "@contents" ; puts_nl chan "@bye" method do_index it = if not (List.mem it indices_to_build) then indices_to_build <- it :: indices_to_build (** Scan the whole module information to know which indices need to be build *) method scan_for_index : subparts -> unit = function | `Module m -> let m_ele = Module.module_elements ~trans:true m in List.iter self#scan_for_index_in_mod m_ele | `Module_type mt -> let m_ele = Module.module_type_elements ~trans:true mt in List.iter self#scan_for_index_in_mod m_ele | `Class c -> let c_ele = Class.class_elements ~trans:true c in List.iter self#scan_for_index_in_class c_ele | `Class_type ct -> let c_ele = Class.class_type_elements ~trans:true ct in List.iter self#scan_for_index_in_class c_ele method scan_for_index_in_mod = function (* no recursion *) | Element_value _ -> self#do_index `Value | Element_exception _ -> self#do_index `Exception | Element_type _ -> self#do_index `Type | Element_included_module _ | Element_module_comment _ -> () (* recursion *) | Element_module m -> self#do_index `Module ; self#scan_for_index (`Module m) | Element_module_type mt -> self#do_index `Module_type ; self#scan_for_index (`Module_type mt) | Element_class c -> self#do_index `Class ; self#scan_for_index (`Class c) | Element_class_type ct -> self#do_index `Class_type ; self#scan_for_index (`Class_type ct) method scan_for_index_in_class = function | Class_attribute _ -> self#do_index `Class_att | Class_method _ -> self#do_index `Method | Class_comment _ -> () (** Generate the Texinfo file from a module list, in the {!Odoc_info.Global.out_file} file. *) method generate module_list = Hashtbl.clear node_tbl ; let filename = if !Global.out_file = Odoc_messages.default_out_file then "ocamldoc.texi" else !Global.out_file in if !Global.with_index then List.iter self#scan_for_index (List.map (fun m -> `Module m) module_list) ; try let chanout = open_out (Filename.concat !Global.target_dir filename) in if !Global.with_header then self#generate_texi_header chanout filename module_list ; List.iter (self#generate_for_module chanout) module_list ; if !Global.with_trailer then self#generate_texi_trailer chanout ; close_out chanout with | Failure s | Sys_error s -> prerr_endline s ; incr Odoc_info.errors end end module type Texi_generator = module type of Generator mingw-ocaml/ocaml/ocamldoc/odoc_text.mli0000644000175000017500000000215412124403242017735 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** A module with a function to parse strings to obtain a [Odoc_types.text] value. *) (** Syntax error in a text. *) exception Text_syntax of int * int * string (* line, char, string *) (** Transformation of strings to text structures. *) module Texter : sig val text_of_string : string -> Odoc_types.text val string_of_text : Odoc_types.text -> string end mingw-ocaml/ocaml/ocamldoc/odoc_class.ml0000644000175000017500000002003012124403242017676 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Representation and manipulation of classes and class types.*) module Name = Odoc_name (** To keep the order of elements in a class *) type class_element = Class_attribute of Odoc_value.t_attribute | Class_method of Odoc_value.t_method | Class_comment of Odoc_types.text (** Used when we can reference t_class or t_class_type. *) type cct = Cl of t_class | Cltype of t_class_type * Types.type_expr list (** class type and type parameters *) and inherited_class = { ic_name : Name.t ; (** Complete name of the inherited class *) mutable ic_class : cct option ; (** The associated t_class or t_class_type *) ic_text : Odoc_types.text option ; (** The inheritance comment, if any *) } and class_apply = { capp_name : Name.t ; (** The complete name of the applied class *) mutable capp_class : t_class option; (** The associated t_class if we found it *) capp_params : Types.type_expr list; (** The type of expressions the class is applied to *) capp_params_code : string list ; (** The code of these expressions *) } and class_constr = { cco_name : Name.t ; (** The complete name of the applied class *) mutable cco_class : cct option; (** The associated class ot class type if we found it *) cco_type_parameters : Types.type_expr list; (** The type parameters of the class, if needed *) } and class_kind = Class_structure of inherited_class list * class_element list (** an explicit class structure, used in implementation and interface *) | Class_apply of class_apply (** application/alias of a class, used in implementation only *) | Class_constr of class_constr (** a class used to give the type of the defined class, instead of a structure, used in interface only. For example, it will be used with the name "M1.M2....tutu" when the class to is defined like this : class toto : int -> tutu *) | Class_constraint of class_kind * class_type_kind (** A class definition with a constraint. *) (** Representation of a class. *) and t_class = { cl_name : Name.t ; (** Name of the class *) mutable cl_info : Odoc_types.info option ; (** The optional associated user information *) cl_type : Types.class_type ; cl_type_parameters : Types.type_expr list ; (** Type parameters *) cl_virtual : bool ; (** true = virtual *) mutable cl_kind : class_kind ; mutable cl_parameters : Odoc_parameter.parameter list ; mutable cl_loc : Odoc_types.location ; } and class_type_alias = { cta_name : Name.t ; mutable cta_class : cct option ; (** we can have a t_class or a t_class_type *) cta_type_parameters : Types.type_expr list ; (** the type parameters *) } and class_type_kind = Class_signature of inherited_class list * class_element list | Class_type of class_type_alias (** a class type eventually applied to type args *) (** Representation of a class type. *) and t_class_type = { clt_name : Name.t ; mutable clt_info : Odoc_types.info option ; (** The optional associated user information *) clt_type : Types.class_type ; clt_type_parameters : Types.type_expr list ; (** type parameters *) clt_virtual : bool ; (** true = virtual *) mutable clt_kind : class_type_kind ; mutable clt_loc : Odoc_types.location ; } (** {2 Functions} *) (** Returns the text associated to the given parameter label in the given class, or None. *) let class_parameter_text_by_name cl label = match cl.cl_info with None -> None | Some i -> try let t = List.assoc label i.Odoc_types.i_params in Some t with Not_found -> None (** Returns the list of elements of a t_class. *) let rec class_elements ?(trans=true) cl = let rec iter_kind k = match k with Class_structure (_, elements) -> elements | Class_constraint (c_kind, ct_kind) -> iter_kind c_kind (* A VOIR : utiliser le c_kind ou le ct_kind ? Pour l'instant, comme le ct_kind n'est pas analyse, on cherche dans le c_kind class_type_elements ~trans: trans { clt_name = "" ; clt_info = None ; clt_type_parameters = [] ; clt_virtual = false ; clt_kind = ct_kind } *) | Class_apply capp -> ( match capp.capp_class with Some c when trans -> class_elements ~trans: trans c | _ -> [] ) | Class_constr cco -> ( match cco.cco_class with Some (Cl c) when trans -> class_elements ~trans: trans c | Some (Cltype (ct,_)) when trans -> class_type_elements ~trans: trans ct | _ -> [] ) in iter_kind cl.cl_kind (** Returns the list of elements of a t_class_type. *) and class_type_elements ?(trans=true) clt = match clt.clt_kind with Class_signature (_, elements) -> elements | Class_type { cta_class = Some (Cltype (ct, _)) } when trans -> class_type_elements ~trans ct | Class_type { cta_class = Some (Cl c) } when trans -> class_elements ~trans c | Class_type _ -> [] (** Returns the attributes of a t_class. *) let class_attributes ?(trans=true) cl = List.fold_left (fun acc -> fun ele -> match ele with Class_attribute a -> acc @ [ a ] | _ -> acc ) [] (class_elements ~trans cl) (** Returns the methods of a t_class. *) let class_methods ?(trans=true) cl = List.fold_left (fun acc -> fun ele -> match ele with Class_method m -> acc @ [ m ] | _ -> acc ) [] (class_elements ~trans cl) (** Returns the comments in a t_class. *) let class_comments ?(trans=true) cl = List.fold_left (fun acc -> fun ele -> match ele with Class_comment t -> acc @ [ t ] | _ -> acc ) [] (class_elements ~trans cl) (** Update the parameters text of a t_class, according to the cl_info field. *) let class_update_parameters_text cl = let f p = Odoc_parameter.update_parameter_text (class_parameter_text_by_name cl) p in List.iter f cl.cl_parameters (** Returns the attributes of a t_class_type. *) let class_type_attributes ?(trans=true) clt = List.fold_left (fun acc -> fun ele -> match ele with Class_attribute a -> acc @ [ a ] | _ -> acc ) [] (class_type_elements ~trans clt) (** Returns the methods of a t_class_type. *) let class_type_methods ?(trans=true) clt = List.fold_left (fun acc -> fun ele -> match ele with Class_method m -> acc @ [ m ] | _ -> acc ) [] (class_type_elements ~trans clt) (** Returns the comments in a t_class_type. *) let class_type_comments ?(trans=true) clt = List.fold_left (fun acc -> fun ele -> match ele with Class_comment m -> acc @ [ m ] | _ -> acc ) [] (class_type_elements ~trans clt) (** Returns the text associated to the given parameter label in the given class type, or None. *) let class_type_parameter_text_by_name clt label = match clt.clt_info with None -> None | Some i -> try let t = List.assoc label i.Odoc_types.i_params in Some t with Not_found -> None (* eof $Id$ *) mingw-ocaml/ocaml/ocamldoc/odoc_str.mli0000644000175000017500000000452412124403242017564 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** The functions to get a string from different kinds of elements (types, modules, ...). *) (** @return the variance string for the given type and (covariant, contravariant) information. *) val string_of_variance : Odoc_type.t_type -> (bool * bool) -> string (** This function returns a string to represent the given list of types, with a given separator. @param par can be used to force the addition or not of parentheses around the returned string. *) val string_of_type_list : ?par: bool -> string -> Types.type_expr list -> string (** This function returns a string to represent the list of type parameters for the given type. *) val string_of_type_param_list : Odoc_type.t_type -> string (** This function returns a string to represent the given list of type parameters of a class or class type, with a given separator. *) val string_of_class_type_param_list : Types.type_expr list -> string (** @return a string to describe the given type. *) val string_of_type : Odoc_type.t_type -> string (** @return a string to display the parameters of the given class, in the same form as the compiler. *) val string_of_class_params : Odoc_class.t_class -> string (** @return a string to describe the given exception. *) val string_of_exception : Odoc_exception.t_exception -> string (** @return a string to describe the given value. *) val string_of_value : Odoc_value.t_value -> string (** @return a string to describe the given attribute. *) val string_of_attribute : Odoc_value.t_attribute -> string (** @return a string to describe the given method. *) val string_of_method : Odoc_value.t_method -> string mingw-ocaml/ocaml/ocamldoc/odoc_name.mli0000644000175000017500000000465612124403242017702 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Representation of element names. *) type t = string (** Add parenthesis to the given simple name if needed. *) val parens_if_infix : t -> t (** Return a simple name from a name.*) val simple : t -> t (** Return the name of the 'father' (like dirname for a file name).*) val father : t -> t (** Concatenates two names. *) val concat : t -> t -> t (** Normalize the given name by removing the beginning and ending spaces of the simple name and adding parenthesis if needed. *) val normalize_name : t -> t (** Returns the head of a name. *) val head : t -> t (** Returns the depth of the name, i.e. the numer of levels to the root. Example : [Toto.Tutu.name] has depth 3. *) val depth : t -> int (** Returns true if the first name is a prefix of the second name. If the two names are equals, then if is false (strict prefix).*) val prefix : t -> t -> bool (** Take two names n1 and n2 = n3.n4 and return n4 if n3=n1 or else n2. *) val get_relative : t -> t -> t (** Take two names n1=n3.n4 and n2 = n5.n6 and return n6 if n3=n5 or else n2. *) val get_relative_raw : t -> t -> t (** Take a list of module names to hide and a name, and return the name when the module name (or part of it) was removed, according to the list of module names to hide.*) val hide_given_modules : t list -> t -> t (** Indicate if a name if qualified or not. *) val qualified : t -> bool (** Get a name from an [Ident.t]. *) val from_ident : Ident.t -> t (** Get a name from a [Path.t]. *) val from_path : Path.t -> t (** Get a [Path.t] from a name.*) val to_path : t -> Path.t (** Get a name from a [Longident.t].*) val from_longident : Longident.t -> t (** Set of Name.t *) module Set : Set.S with type elt = t mingw-ocaml/ocaml/ocamldoc/odoc_global.ml0000644000175000017500000000414212124403242020037 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Global variables. *) (* Tell ocaml compiler not to generate files. *) let _ = Clflags.dont_write_files := true open Clflags type source_file = Impl_file of string | Intf_file of string | Text_file of string let include_dirs = Clflags.include_dirs let errors = ref 0 let warn_error = ref false let pwarning s = if !Odoc_config.print_warnings then prerr_endline (Odoc_messages.warning^": "^s); if !warn_error then incr errors let merge_options = ref ([] : Odoc_types.merge_option list) let classic = Clflags.classic let dump = ref (None : string option) let load = ref ([] : string list) (** Allow arbitrary recursive types. *) let recursive_types = Clflags.recursive_types (** Optional preprocessor command. *) let preprocessor = Clflags.preprocessor let sort_modules = ref false let no_custom_tags = ref false let no_stop = ref false let remove_stars = ref false let keep_code = ref false let inverse_merge_ml_mli = ref false let filter_with_module_constraints = ref true let hidden_modules = ref ([] : string list) let files = ref [] let out_file = ref Odoc_messages.default_out_file let verbose = ref false let target_dir = ref Filename.current_dir_name let title = ref (None : string option) let intro_file = ref (None : string option) let with_header = ref true let with_trailer = ref true let with_toc = ref true let with_index = ref true mingw-ocaml/ocaml/ocamldoc/odoc_print.mli0000644000175000017500000000313012124403242020100 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Printing functions. *) (** This function takes a Types.type_expr and returns a string. It writes in and flushes [Format.str_formatter].*) val string_of_type_expr : Types.type_expr -> string (** This function returns a string representing a [Types.module_type]. @param complete indicates if we must print complete signatures or just [sig end]. Default if [false]. @param code if [complete = false] and the type contains something else than identificators and functors, then the given code is used. *) val string_of_module_type : ?code: string -> ?complete: bool -> Types.module_type -> string (** This function returns a string representing a [Types.class_type]. @param complete indicates if we must print complete signatures or just [object end]. Default if [false]. *) val string_of_class_type : ?complete: bool -> Types.class_type -> string mingw-ocaml/ocaml/ocamldoc/odoc_inherit.ml0000644000175000017500000000136012124403242020240 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) mingw-ocaml/ocaml/ocamldoc/odoc_search.ml0000644000175000017500000004625412124403242020056 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Research of elements through modules. *) module Name = Odoc_name open Odoc_parameter open Odoc_value open Odoc_type open Odoc_exception open Odoc_class open Odoc_module type result_element = Res_module of t_module | Res_module_type of t_module_type | Res_class of t_class | Res_class_type of t_class_type | Res_value of t_value | Res_type of t_type | Res_exception of t_exception | Res_attribute of t_attribute | Res_method of t_method | Res_section of string * Odoc_types.text | Res_recfield of t_type * record_field | Res_const of t_type * variant_constructor type result = result_element list module type Predicates = sig type t val p_module : t_module -> t -> bool * bool val p_module_type : t_module_type -> t -> bool * bool val p_class : t_class -> t -> bool * bool val p_class_type : t_class_type -> t -> bool * bool val p_value : t_value -> t -> bool val p_recfield : t_type -> record_field -> t -> bool val p_const : t_type -> variant_constructor -> t -> bool val p_type : t_type -> t -> (bool * bool) val p_exception : t_exception -> t -> bool val p_attribute : t_attribute -> t -> bool val p_method : t_method -> t -> bool val p_section : string -> t -> bool end module Search = functor (P : Predicates) -> struct let search_section t s v = if P.p_section s v then [Res_section (s,t)] else [] let rec search_text root t v = List.flatten (List.map (fun e -> search_text_ele root e v) t) and search_text_ele root e v = let module T = Odoc_types in match e with | T.Raw _ | T.Code _ | T.CodePre _ | T.Latex _ | T.Verbatim _ | T.Ref (_, _, _) -> [] | T.Bold t | T.Italic t | T.Center t | T.Left t | T.Right t | T.Emphasize t | T.Block t | T.Superscript t | T.Subscript t | T.Custom (_,t) | T.Link (_, t) -> search_text root t v | T.List l | T.Enum l -> List.flatten (List.map (fun t -> search_text root t v) l) | T.Newline | T.Module_list _ | T.Index_list -> [] | T.Target _ -> [] | T.Title (n, l_opt, t) -> (match l_opt with None -> [] | Some s -> search_section t (Name.concat root s) v) @ (search_text root t v) let search_value va v = if P.p_value va v then [Res_value va] else [] let search_recfield t f v = if P.p_recfield t f v then [Res_recfield (t,f)] else [] let search_const t f v = if P.p_const t f v then [Res_const (t,f)] else [] let search_type t v = let (go_deeper, ok) = P.p_type t v in let l = match go_deeper with false -> [] | true -> match t.ty_kind with Type_abstract -> [] | Type_record l -> List.flatten (List.map (fun rf -> search_recfield t rf v) l) | Type_variant l -> List.flatten (List.map (fun rf -> search_const t rf v) l) in if ok then (Res_type t) :: l else l let search_exception e v = if P.p_exception e v then [Res_exception e] else [] let search_attribute a v = if P.p_attribute a v then [Res_attribute a] else [] let search_method m v = if P.p_method m v then [Res_method m] else [] let search_class c v = let (go_deeper, ok) = P.p_class c v in let l = if go_deeper then let res_att = List.fold_left (fun acc -> fun att -> acc @ (search_attribute att v)) [] (Odoc_class.class_attributes c) in let res_met = List.fold_left (fun acc -> fun m -> acc @ (search_method m v)) [] (Odoc_class.class_methods c) in let res_sec = List.fold_left (fun acc -> fun t -> acc @ (search_text c.cl_name t v)) [] (Odoc_class.class_comments c) in let l = res_att @ res_met @ res_sec in l else [] in if ok then (Res_class c) :: l else l let search_class_type ct v = let (go_deeper, ok) = P.p_class_type ct v in let l = if go_deeper then let res_att = List.fold_left (fun acc -> fun att -> acc @ (search_attribute att v)) [] (Odoc_class.class_type_attributes ct) in let res_met = List.fold_left (fun acc -> fun m -> acc @ (search_method m v)) [] (Odoc_class.class_type_methods ct) in let res_sec = List.fold_left (fun acc -> fun t -> acc @ (search_text ct.clt_name t v)) [] (Odoc_class.class_type_comments ct) in let l = res_att @ res_met @ res_sec in l else [] in if ok then (Res_class_type ct) :: l else l let rec search_module_type mt v = let (go_deeper, ok) = P.p_module_type mt v in let l = if go_deeper then let res_val = List.fold_left (fun acc -> fun va -> acc @ (search_value va v)) [] (Odoc_module.module_type_values mt) in let res_typ = List.fold_left (fun acc -> fun t -> acc @ (search_type t v)) [] (Odoc_module.module_type_types mt) in let res_exc = List.fold_left (fun acc -> fun e -> acc @ (search_exception e v)) [] (Odoc_module.module_type_exceptions mt) in let res_mod = search (Odoc_module.module_type_modules mt) v in let res_modtyp = List.fold_left (fun acc -> fun mt -> acc @ (search_module_type mt v)) [] (Odoc_module.module_type_module_types mt) in let res_cl = List.fold_left (fun acc -> fun cl -> acc @ (search_class cl v)) [] (Odoc_module.module_type_classes mt) in let res_cltyp = List.fold_left (fun acc -> fun clt -> acc @ (search_class_type clt v)) [] (Odoc_module.module_type_class_types mt) in let res_sec = List.fold_left (fun acc -> fun t -> acc @ (search_text mt.mt_name t v)) [] (Odoc_module.module_type_comments mt) in let l = res_val @ res_typ @ res_exc @ res_mod @ res_modtyp @ res_cl @ res_cltyp @ res_sec in l else [] in if ok then (Res_module_type mt) :: l else l and search_module m v = let (go_deeper, ok) = P.p_module m v in let l = if go_deeper then let res_val = List.fold_left (fun acc -> fun va -> acc @ (search_value va v)) [] (Odoc_module.module_values m) in let res_typ = List.fold_left (fun acc -> fun t -> acc @ (search_type t v)) [] (Odoc_module.module_types m) in let res_exc = List.fold_left (fun acc -> fun e -> acc @ (search_exception e v)) [] (Odoc_module.module_exceptions m) in let res_mod = search (Odoc_module.module_modules m) v in let res_modtyp = List.fold_left (fun acc -> fun mt -> acc @ (search_module_type mt v)) [] (Odoc_module.module_module_types m) in let res_cl = List.fold_left (fun acc -> fun cl -> acc @ (search_class cl v)) [] (Odoc_module.module_classes m) in let res_cltyp = List.fold_left (fun acc -> fun clt -> acc @ (search_class_type clt v)) [] (Odoc_module.module_class_types m) in let res_sec = List.fold_left (fun acc -> fun t -> acc @ (search_text m.m_name t v)) [] (Odoc_module.module_comments m) in let l = res_val @ res_typ @ res_exc @ res_mod @ res_modtyp @ res_cl @ res_cltyp @ res_sec in l else [] in if ok then (Res_module m) :: l else l and search module_list v = List.fold_left (fun acc -> fun m -> List.fold_left (fun acc2 -> fun ele -> if List.mem ele acc2 then acc2 else acc2 @ [ele] ) acc (search_module m v) ) [] module_list end module P_name = struct type t = Str.regexp let (=~) name regexp = Str.string_match regexp name 0 let p_module m r = (true, m.m_name =~ r) let p_module_type mt r = (true, mt.mt_name =~ r) let p_class c r = (true, c.cl_name =~ r) let p_class_type ct r = (true, ct.clt_name =~ r) let p_value v r = v.val_name =~ r let p_recfield t f r = let name = Printf.sprintf "%s.%s" t.ty_name f.rf_name in name =~ r let p_const t f r = let name = Printf.sprintf "%s.%s" t.ty_name f.vc_name in name =~ r let p_type t r = (true, t.ty_name =~ r) let p_exception e r = e.ex_name =~ r let p_attribute a r = a.att_value.val_name =~ r let p_method m r = m.met_value.val_name =~ r let p_section s r = s =~ r end module Search_by_name = Search ( P_name ) module P_values = struct type t = unit let p_module _ _ = (true, false) let p_module_type _ _ = (true, false) let p_class _ _ = (false, false) let p_class_type _ _ = (false, false) let p_value _ _ = true let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false let p_section _ _ = false end module Search_values = Search ( P_values ) let values l = let l_ele = Search_values.search l () in let p v1 v2 = v1.val_name = v2.val_name in let rec iter acc = function (Res_value v) :: q -> if List.exists (p v) acc then iter acc q else iter (v :: acc) q | _ :: q -> iter acc q | [] -> acc in iter [] l_ele module P_exceptions = struct type t = unit let p_module _ _ = (true, false) let p_module_type _ _ = (true, false) let p_class _ _ = (false, false) let p_class_type _ _ = (false, false) let p_value _ _ = false let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) let p_exception _ _ = true let p_attribute _ _ = false let p_method _ _ = false let p_section _ _ = false end module Search_exceptions = Search ( P_exceptions ) let exceptions l = let l_ele = Search_exceptions.search l () in let p e1 e2 = e1.ex_name = e2.ex_name in let rec iter acc = function (Res_exception t) :: q -> if List.exists (p t) acc then iter acc q else iter (t :: acc) q | _ :: q -> iter acc q | [] -> acc in iter [] l_ele module P_types = struct type t = unit let p_module _ _ = (true, false) let p_module_type _ _ = (true, false) let p_class _ _ = (false, false) let p_class_type _ _ = (false, false) let p_value _ _ = false let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, true) let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false let p_section _ _ = false end module Search_types = Search ( P_types ) let types l = let l_ele = Search_types.search l () in let p t1 t2 = t1.ty_name = t2.ty_name in let rec iter acc = function (Res_type t) :: q -> if List.exists (p t) acc then iter acc q else iter (t :: acc) q | _ :: q -> iter acc q | [] -> acc in iter [] l_ele module P_attributes = struct type t = unit let p_module _ _ = (true, false) let p_module_type _ _ = (true, false) let p_class _ _ = (true, false) let p_class_type _ _ = (true, false) let p_value _ _ = false let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) let p_exception _ _ = false let p_attribute _ _ = true let p_method _ _ = false let p_section _ _ = false end module Search_attributes = Search ( P_attributes ) let attributes l = let l_ele = Search_attributes.search l () in let p a1 a2 = a1.att_value.val_name = a2.att_value.val_name in let rec iter acc = function (Res_attribute t) :: q -> if List.exists (p t) acc then iter acc q else iter (t :: acc) q | _ :: q -> iter acc q | [] -> acc in iter [] l_ele module P_methods = struct type t = unit let p_module _ _ = (true, false) let p_module_type _ _ = (true, false) let p_class _ _ = (true, false) let p_class_type _ _ = (true, false) let p_value _ _ = false let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = true let p_section _ _ = true end module Search_methods = Search ( P_methods ) let methods l = let l_ele = Search_methods.search l () in let p m1 m2 = m1.met_value.val_name = m2.met_value.val_name in let rec iter acc = function (Res_method t) :: q -> if List.exists (p t) acc then iter acc q else iter (t :: acc) q | _ :: q -> iter acc q | [] -> acc in iter [] l_ele module P_classes = struct type t = unit let p_module _ _ = (true, false) let p_module_type _ _ = (true, false) let p_class _ _ = (false, true) let p_class_type _ _ = (false, false) let p_value _ _ = false let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false let p_section _ _ = false end module Search_classes = Search ( P_classes ) let classes l = let l_ele = Search_classes.search l () in let p c1 c2 = c1.cl_name = c2.cl_name in let rec iter acc = function (Res_class c) :: q -> if List.exists (p c) acc then iter acc q else iter (c :: acc) q | _ :: q -> iter acc q | [] -> acc in iter [] l_ele module P_class_types = struct type t = unit let p_module _ _ = (true, false) let p_module_type _ _ = (true, false) let p_class _ _ = (false, false) let p_class_type _ _ = (false, true) let p_value _ _ = false let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false let p_section _ _ = false end module Search_class_types = Search ( P_class_types ) let class_types l = let l_ele = Search_class_types.search l () in let p c1 c2 = c1.clt_name = c2.clt_name in let rec iter acc = function (Res_class_type c) :: q -> if List.exists (p c) acc then iter acc q else iter (c :: acc) q | _ :: q -> iter acc q | [] -> acc in iter [] l_ele module P_modules = struct type t = unit let p_module _ _ = (true, true) let p_module_type _ _ = (true, false) let p_class _ _ = (false, false) let p_class_type _ _ = (false, false) let p_value _ _ = false let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false let p_section _ _ = false end module Search_modules = Search ( P_modules ) let modules l = let l_ele = Search_modules.search l () in let p m1 m2 = m1.m_name = m2.m_name in let rec iter acc = function (Res_module m) :: q -> if List.exists (p m) acc then iter acc q else iter (m :: acc) q | _ :: q -> iter acc q | [] -> acc in iter [] l_ele module P_module_types = struct type t = unit let p_module _ _ = (true, false) let p_module_type _ _ = (true, true) let p_class _ _ = (false, false) let p_class_type _ _ = (false, false) let p_value _ _ = false let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false let p_section _ _ = false end module Search_module_types = Search ( P_module_types ) let module_types l = let l_ele = Search_module_types.search l () in let p m1 m2 = m1.mt_name = m2.mt_name in let rec iter acc = function (Res_module_type m) :: q -> if List.exists (p m) acc then iter acc q else iter (m :: acc) q | _ :: q -> iter acc q | [] -> acc in iter [] l_ele let type_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function Res_type _ -> true | _ -> false ) l let value_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function Res_value _ -> true | _ -> false ) l let class_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function Res_class _ -> true | _ -> false ) l let class_type_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function Res_class_type _ -> true | _ -> false ) l let module_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function Res_module _ -> true | _ -> false ) l let module_type_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function Res_module_type _ -> true | _ -> false ) l let exception_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function Res_exception _ -> true | _ -> false ) l let attribute_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function Res_attribute _ -> true | _ -> false ) l let method_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists (function Res_method _ -> true | _ -> false ) l let find_section mods regexp = let l = Search_by_name.search mods regexp in match List.find (function Res_section _ -> true | _ -> false ) l with Res_section (_,t) -> t | _ -> assert false (* eof $Id$ *) mingw-ocaml/ocaml/ocamldoc/odoc_dag2html.mli0000644000175000017500000000254612124403242020460 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** The types and functions to create a html table representing a dag. Thanks to Daniel de Rauglaudre. *) type 'a dag = { mutable dag : 'a node array } and 'a node = { mutable pare : idag list; valu : 'a; mutable chil : idag list } and idag = int (** This function returns the html code to represent the given dag. *) val html_of_dag : string dag -> string (** This function takes a list of classes and a list of class types and creates the associate dag. *) val create_class_dag : Odoc_info.Class.t_class list -> Odoc_info.Class.t_class_type list -> (Odoc_info.Name.t * Odoc_info.Class.cct option) dag mingw-ocaml/ocaml/ocamldoc/odoc_cross.ml0000644000175000017500000011531112124403242017731 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Cross referencing. *) module Name = Odoc_name open Odoc_module open Odoc_class open Odoc_exception open Odoc_types open Odoc_value open Odoc_type open Odoc_parameter (*** Replacements of aliases : if e1 = e2 and e2 = e3, then replace e2 by e3 to have e1 = e3, in order to associate the element with complete information. *) (** The module used to keep what refs were modified. *) module S = Set.Make ( struct type t = string * ref_kind option let compare = Pervasives.compare end ) let verified_refs = ref S.empty let add_verified v = verified_refs := S.add v !verified_refs let was_verified v = S.mem v !verified_refs (** The module with the predicates used to get the aliased modules, classes and exceptions. *) module P_alias = struct type t = int let p_module m _ = (true, match m.m_kind with Module_alias _ -> true | _ -> false ) let p_module_type mt _ = (true, match mt.mt_kind with Some (Module_type_alias _) -> true | _ -> false ) let p_class c _ = (false, false) let p_class_type ct _ = (false, false) let p_value v _ = false let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type t _ = (false, false) let p_exception e _ = e.ex_alias <> None let p_attribute a _ = false let p_method m _ = false let p_section s _ = false end (** The module used to get the aliased elements. *) module Search_alias = Odoc_search.Search (P_alias) type alias_state = Alias_resolved | Alias_to_resolve (** Couples of module name aliases. *) let (module_aliases : (Name.t, Name.t * alias_state) Hashtbl.t) = Hashtbl.create 13 ;; (** Couples of module or module type name aliases. *) let module_and_modtype_aliases = Hashtbl.create 13;; (** Couples of exception name aliases. *) let exception_aliases = Hashtbl.create 13;; let rec build_alias_list = function [] -> () | (Odoc_search.Res_module m) :: q -> ( match m.m_kind with Module_alias ma -> Hashtbl.add module_aliases m.m_name (ma.ma_name, Alias_to_resolve); Hashtbl.add module_and_modtype_aliases m.m_name (ma.ma_name, Alias_to_resolve) | _ -> () ); build_alias_list q | (Odoc_search.Res_module_type mt) :: q -> ( match mt.mt_kind with Some (Module_type_alias mta) -> Hashtbl.add module_and_modtype_aliases mt.mt_name (mta.mta_name, Alias_to_resolve) | _ -> () ); build_alias_list q | (Odoc_search.Res_exception e) :: q -> ( match e.ex_alias with None -> () | Some ea -> Hashtbl.add exception_aliases e.ex_name (ea.ea_name,Alias_to_resolve) ); build_alias_list q | _ :: q -> build_alias_list q (** Retrieve the aliases for modules, module types and exceptions and put them in global hash tables. *) let get_alias_names module_list = Hashtbl.clear module_aliases; Hashtbl.clear module_and_modtype_aliases; Hashtbl.clear exception_aliases; build_alias_list (Search_alias.search module_list 0) exception Found of string let name_alias = let rec f t name = try match Hashtbl.find t name with (s, Alias_resolved) -> s | (s, Alias_to_resolve) -> f t s with Not_found -> try Hashtbl.iter (fun n2 (n3, _) -> if Name.prefix n2 name then let ln2 = String.length n2 in let s = n3^(String.sub name ln2 ((String.length name) - ln2)) in raise (Found s) ) t ; Hashtbl.replace t name (name, Alias_resolved); name with Found s -> let s2 = f t s in Hashtbl.replace t s2 (s2, Alias_resolved); s2 in fun name alias_tbl -> f alias_tbl name module Map_ord = struct type t = string let compare = Pervasives.compare end module Ele_map = Map.Make (Map_ord) let known_elements = ref Ele_map.empty let add_known_element name k = try let l = Ele_map.find name !known_elements in let s = Ele_map.remove name !known_elements in known_elements := Ele_map.add name (k::l) s with Not_found -> known_elements := Ele_map.add name [k] !known_elements let rec get_known_elements name = try Ele_map.find name !known_elements with Not_found -> [] let kind_name_exists kind = let pred = match kind with RK_module -> (fun e -> match e with Odoc_search.Res_module _ -> true | _ -> false) | RK_module_type -> (fun e -> match e with Odoc_search.Res_module_type _ -> true | _ -> false) | RK_class -> (fun e -> match e with Odoc_search.Res_class _ -> true | _ -> false) | RK_class_type -> (fun e -> match e with Odoc_search.Res_class_type _ -> true | _ -> false) | RK_value -> (fun e -> match e with Odoc_search.Res_value _ -> true | _ -> false) | RK_type -> (fun e -> match e with Odoc_search.Res_type _ -> true | _ -> false) | RK_exception -> (fun e -> match e with Odoc_search.Res_exception _ -> true | _ -> false) | RK_attribute -> (fun e -> match e with Odoc_search.Res_attribute _ -> true | _ -> false) | RK_method -> (fun e -> match e with Odoc_search.Res_method _ -> true | _ -> false) | RK_section _ -> assert false | RK_recfield -> (fun e -> match e with Odoc_search.Res_recfield _ -> true | _ -> false) | RK_const -> (fun e -> match e with Odoc_search.Res_const _ -> true | _ -> false) in fun name -> try List.exists pred (get_known_elements name) with Not_found -> false let module_exists = kind_name_exists RK_module let module_type_exists = kind_name_exists RK_module_type let class_exists = kind_name_exists RK_class let class_type_exists = kind_name_exists RK_class_type let value_exists = kind_name_exists RK_value let type_exists = kind_name_exists RK_type let exception_exists = kind_name_exists RK_exception let attribute_exists = kind_name_exists RK_attribute let method_exists = kind_name_exists RK_method let recfield_exists = kind_name_exists RK_recfield let const_exists = kind_name_exists RK_const let lookup_module name = match List.find (fun k -> match k with Odoc_search.Res_module _ -> true | _ -> false) (get_known_elements name) with | Odoc_search.Res_module m -> m | _ -> assert false let lookup_module_type name = match List.find (fun k -> match k with Odoc_search.Res_module_type _ -> true | _ -> false) (get_known_elements name) with | Odoc_search.Res_module_type m -> m | _ -> assert false let lookup_class name = match List.find (fun k -> match k with Odoc_search.Res_class _ -> true | _ -> false) (get_known_elements name) with | Odoc_search.Res_class c -> c | _ -> assert false let lookup_class_type name = match List.find (fun k -> match k with Odoc_search.Res_class_type _ -> true | _ -> false) (get_known_elements name) with | Odoc_search.Res_class_type c -> c | _ -> assert false let lookup_exception name = match List.find (fun k -> match k with Odoc_search.Res_exception _ -> true | _ -> false) (get_known_elements name) with | Odoc_search.Res_exception e -> e | _ -> assert false class scan = object inherit Odoc_scan.scanner method! scan_value v = add_known_element v.val_name (Odoc_search.Res_value v) method! scan_type_recfield t f = add_known_element (Printf.sprintf "%s.%s" t.ty_name f.rf_name) (Odoc_search.Res_recfield (t, f)) method! scan_type_const t f = add_known_element (Printf.sprintf "%s.%s" t.ty_name f.vc_name) (Odoc_search.Res_const (t, f)) method! scan_type_pre t = add_known_element t.ty_name (Odoc_search.Res_type t); true method! scan_exception e = add_known_element e.ex_name (Odoc_search.Res_exception e) method! scan_attribute a = add_known_element a.att_value.val_name (Odoc_search.Res_attribute a) method! scan_method m = add_known_element m.met_value.val_name (Odoc_search.Res_method m) method! scan_class_pre c = add_known_element c.cl_name (Odoc_search.Res_class c); true method! scan_class_type_pre c = add_known_element c.clt_name (Odoc_search.Res_class_type c); true method! scan_module_pre m = add_known_element m.m_name (Odoc_search.Res_module m); true method! scan_module_type_pre m = add_known_element m.mt_name (Odoc_search.Res_module_type m); true end let init_known_elements_map module_list = let c = new scan in c#scan_module_list module_list (** The type to describe the names not found. *) type not_found_name = NF_m of Name.t | NF_mt of Name.t | NF_mmt of Name.t | NF_c of Name.t | NF_ct of Name.t | NF_cct of Name.t | NF_ex of Name.t (** Functions to find and associate aliases elements. *) let rec associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m = let rec iter_kind (acc_b, acc_inc, acc_names) k = match k with Module_struct elements -> List.fold_left (associate_in_module_element module_list m.m_name) (acc_b, acc_inc, acc_names) elements | Module_alias ma -> ( match ma.ma_module with Some _ -> (acc_b, acc_inc, acc_names) | None -> let mmt_opt = try Some (Mod (lookup_module ma.ma_name)) with Not_found -> try Some (Modtype (lookup_module_type ma.ma_name)) with Not_found -> None in match mmt_opt with None -> (acc_b, (Name.head m.m_name) :: acc_inc, (* we don't want to output warning messages for "sig ... end" or "struct ... end" modules not found *) (if ma.ma_name = Odoc_messages.struct_end or ma.ma_name = Odoc_messages.sig_end then acc_names else (NF_mmt ma.ma_name) :: acc_names) ) | Some mmt -> ma.ma_module <- Some mmt ; (true, acc_inc, acc_names) ) | Module_functor (_, k) -> iter_kind (acc_b, acc_inc, acc_names) k | Module_with (tk, _) -> associate_in_module_type module_list (acc_b, acc_inc, acc_names) { mt_name = "" ; mt_info = None ; mt_type = None ; mt_is_interface = false ; mt_file = ""; mt_kind = Some tk ; mt_loc = Odoc_types.dummy_loc } | Module_apply (k1, k2) -> let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) k1 in iter_kind (acc_b2, acc_inc2, acc_names2) k2 | Module_constraint (k, tk) -> let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) k in associate_in_module_type module_list (acc_b2, acc_inc2, acc_names2) { mt_name = "" ; mt_info = None ; mt_type = None ; mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ; mt_loc = Odoc_types.dummy_loc } | Module_typeof _ -> (acc_b, acc_inc, acc_names) | Module_unpack (code, mta) -> begin match mta.mta_module with Some _ -> (acc_b, acc_inc, acc_names) | None -> let mt_opt = try Some (lookup_module_type mta.mta_name) with Not_found -> None in match mt_opt with None -> (acc_b, (Name.head m.m_name) :: acc_inc, (* we don't want to output warning messages for "sig ... end" or "struct ... end" modules not found *) (if mta.mta_name = Odoc_messages.struct_end or mta.mta_name = Odoc_messages.sig_end then acc_names else (NF_mt mta.mta_name) :: acc_names) ) | Some mt -> mta.mta_module <- Some mt ; (true, acc_inc, acc_names) end in iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m.m_kind and associate_in_module_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) mt = let rec iter_kind (acc_b, acc_inc, acc_names) k = match k with Module_type_struct elements -> List.fold_left (associate_in_module_element module_list mt.mt_name) (acc_b, acc_inc, acc_names) elements | Module_type_functor (_, k) -> iter_kind (acc_b, acc_inc, acc_names) k | Module_type_with (k, _) -> iter_kind (acc_b, acc_inc, acc_names) k | Module_type_alias mta -> begin match mta.mta_module with Some _ -> (acc_b, acc_inc, acc_names) | None -> let mt_opt = try Some (lookup_module_type mta.mta_name) with Not_found -> None in match mt_opt with None -> (acc_b, (Name.head mt.mt_name) :: acc_inc, (* we don't want to output warning messages for "sig ... end" or "struct ... end" modules not found *) (if mta.mta_name = Odoc_messages.struct_end or mta.mta_name = Odoc_messages.sig_end then acc_names else (NF_mt mta.mta_name) :: acc_names) ) | Some mt -> mta.mta_module <- Some mt ; (true, acc_inc, acc_names) end | Module_type_typeof _ -> (acc_b, acc_inc, acc_names) in match mt.mt_kind with None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) | Some k -> iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) k and associate_in_module_element module_list m_name (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) element = match element with Element_module m -> associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) m | Element_module_type mt -> associate_in_module_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) mt | Element_included_module im -> ( match im.im_module with Some _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) | None -> let mmt_opt = try Some (Mod (lookup_module im.im_name)) with Not_found -> try Some (Modtype (lookup_module_type im.im_name)) with Not_found -> None in match mmt_opt with None -> (acc_b_modif, (Name.head m_name) :: acc_incomplete_top_module_names, (* we don't want to output warning messages for "sig ... end" or "struct ... end" modules not found *) (if im.im_name = Odoc_messages.struct_end or im.im_name = Odoc_messages.sig_end then acc_names_not_found else (NF_mmt im.im_name) :: acc_names_not_found) ) | Some mmt -> im.im_module <- Some mmt ; (true, acc_incomplete_top_module_names, acc_names_not_found) ) | Element_class cl -> associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) cl | Element_class_type ct -> associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct | Element_value _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) | Element_exception ex -> ( match ex.ex_alias with None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) | Some ea -> match ea.ea_ex with Some _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) | None -> let ex_opt = try Some (lookup_exception ea.ea_name) with Not_found -> None in match ex_opt with None -> (acc_b_modif, (Name.head m_name) :: acc_incomplete_top_module_names, (NF_ex ea.ea_name) :: acc_names_not_found) | Some e -> ea.ea_ex <- Some e ; (true, acc_incomplete_top_module_names, acc_names_not_found) ) | Element_type _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) | Element_module_comment _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) and associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) c = let rec iter_kind (acc_b, acc_inc, acc_names) k = match k with Class_structure (inher_l, _) -> let f (acc_b2, acc_inc2, acc_names2) ic = match ic.ic_class with Some _ -> (acc_b2, acc_inc2, acc_names2) | None -> let cct_opt = try Some (Cl (lookup_class ic.ic_name)) with Not_found -> try Some (Cltype (lookup_class_type ic.ic_name, [])) with Not_found -> None in match cct_opt with None -> (acc_b2, (Name.head c.cl_name) :: acc_inc2, (* we don't want to output warning messages for "object ... end" classes not found *) (if ic.ic_name = Odoc_messages.object_end then acc_names2 else (NF_cct ic.ic_name) :: acc_names2)) | Some cct -> ic.ic_class <- Some cct ; (true, acc_inc2, acc_names2) in List.fold_left f (acc_b, acc_inc, acc_names) inher_l | Class_apply capp -> ( match capp.capp_class with Some _ -> (acc_b, acc_inc, acc_names) | None -> let cl_opt = try Some (lookup_class capp.capp_name) with Not_found -> None in match cl_opt with None -> (acc_b, (Name.head c.cl_name) :: acc_inc, (* we don't want to output warning messages for "object ... end" classes not found *) (if capp.capp_name = Odoc_messages.object_end then acc_names else (NF_c capp.capp_name) :: acc_names)) | Some c -> capp.capp_class <- Some c ; (true, acc_inc, acc_names) ) | Class_constr cco -> ( match cco.cco_class with Some _ -> (acc_b, acc_inc, acc_names) | None -> let cl_opt = try Some (lookup_class cco.cco_name) with Not_found -> None in match cl_opt with None -> ( let clt_opt = try Some (lookup_class_type cco.cco_name) with Not_found -> None in match clt_opt with None -> (acc_b, (Name.head c.cl_name) :: acc_inc, (* we don't want to output warning messages for "object ... end" classes not found *) (if cco.cco_name = Odoc_messages.object_end then acc_names else (NF_cct cco.cco_name) :: acc_names)) | Some ct -> cco.cco_class <- Some (Cltype (ct, [])) ; (true, acc_inc, acc_names) ) | Some c -> cco.cco_class <- Some (Cl c) ; (true, acc_inc, acc_names) ) | Class_constraint (ckind, ctkind) -> let (acc_b2, acc_inc2, acc_names2) = iter_kind (acc_b, acc_inc, acc_names) ckind in associate_in_class_type module_list (acc_b2, acc_inc2, acc_names2) { clt_name = "" ; clt_info = None ; clt_type = c.cl_type ; (* should be ok *) clt_type_parameters = [] ; clt_virtual = false ; clt_kind = ctkind ; clt_loc = Odoc_types.dummy_loc } in iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) c.cl_kind and associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct = let rec iter_kind (acc_b, acc_inc, acc_names) k = match k with Class_signature (inher_l, _) -> let f (acc_b2, acc_inc2, acc_names2) ic = match ic.ic_class with Some _ -> (acc_b2, acc_inc2, acc_names2) | None -> let cct_opt = try Some (Cltype (lookup_class_type ic.ic_name, [])) with Not_found -> try Some (Cl (lookup_class ic.ic_name)) with Not_found -> None in match cct_opt with None -> (acc_b2, (Name.head ct.clt_name) :: acc_inc2, (* we don't want to output warning messages for "object ... end" class types not found *) (if ic.ic_name = Odoc_messages.object_end then acc_names2 else (NF_cct ic.ic_name) :: acc_names2)) | Some cct -> ic.ic_class <- Some cct ; (true, acc_inc2, acc_names2) in List.fold_left f (acc_b, acc_inc, acc_names) inher_l | Class_type cta -> ( match cta.cta_class with Some _ -> (acc_b, acc_inc, acc_names) | None -> let cct_opt = try Some (Cltype (lookup_class_type cta.cta_name, [])) with Not_found -> try Some (Cl (lookup_class cta.cta_name)) with Not_found -> None in match cct_opt with None -> (acc_b, (Name.head ct.clt_name) :: acc_inc, (* we don't want to output warning messages for "object ... end" class types not found *) (if cta.cta_name = Odoc_messages.object_end then acc_names else (NF_cct cta.cta_name) :: acc_names)) | Some c -> cta.cta_class <- Some c ; (true, acc_inc, acc_names) ) in iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct.clt_kind (*************************************************************) (** Association of types to elements referenced in comments .*) let ao = Odoc_misc.apply_opt let not_found_of_kind kind name = (match kind with RK_module -> Odoc_messages.cross_module_not_found | RK_module_type -> Odoc_messages.cross_module_type_not_found | RK_class -> Odoc_messages.cross_class_not_found | RK_class_type -> Odoc_messages.cross_class_type_not_found | RK_value -> Odoc_messages.cross_value_not_found | RK_type -> Odoc_messages.cross_type_not_found | RK_exception -> Odoc_messages.cross_exception_not_found | RK_attribute -> Odoc_messages.cross_attribute_not_found | RK_method -> Odoc_messages.cross_method_not_found | RK_section _ -> Odoc_messages.cross_section_not_found | RK_recfield -> Odoc_messages.cross_recfield_not_found | RK_const -> Odoc_messages.cross_const_not_found ) name let rec assoc_comments_text_elements parent_name module_list t_ele = match t_ele with | Raw _ | Code _ | CodePre _ | Latex _ | Verbatim _ -> t_ele | Bold t -> Bold (assoc_comments_text parent_name module_list t) | Italic t -> Italic (assoc_comments_text parent_name module_list t) | Center t -> Center (assoc_comments_text parent_name module_list t) | Left t -> Left (assoc_comments_text parent_name module_list t) | Right t -> Right (assoc_comments_text parent_name module_list t) | Emphasize t -> Emphasize (assoc_comments_text parent_name module_list t) | List l -> List (List.map (assoc_comments_text parent_name module_list) l) | Enum l -> Enum (List.map (assoc_comments_text parent_name module_list) l) | Newline -> Newline | Block t -> Block (assoc_comments_text parent_name module_list t) | Superscript t -> Superscript (assoc_comments_text parent_name module_list t) | Subscript t -> Subscript (assoc_comments_text parent_name module_list t) | Title (n, l_opt, t) -> Title (n, l_opt, (assoc_comments_text parent_name module_list t)) | Link (s, t) -> Link (s, (assoc_comments_text parent_name module_list t)) | Ref (initial_name, None, text_option) -> ( let rec iter_parent ?parent_name name = let name = Odoc_name.normalize_name name in let res = match get_known_elements name with [] -> ( try let re = Str.regexp ("^"^(Str.quote name)^"$") in let t = Odoc_search.find_section module_list re in let v2 = (name, Some (RK_section t)) in add_verified v2 ; (name, Some (RK_section t)) with Not_found -> (name, None) ) | ele :: _ -> (* we look for the first element with this name *) let (name, kind) = match ele with Odoc_search.Res_module m -> (m.m_name, RK_module) | Odoc_search.Res_module_type mt -> (mt.mt_name, RK_module_type) | Odoc_search.Res_class c -> (c.cl_name, RK_class) | Odoc_search.Res_class_type ct -> (ct.clt_name, RK_class_type) | Odoc_search.Res_value v -> (v.val_name, RK_value) | Odoc_search.Res_type t -> (t.ty_name, RK_type) | Odoc_search.Res_exception e -> (e.ex_name, RK_exception) | Odoc_search.Res_attribute a -> (a.att_value.val_name, RK_attribute) | Odoc_search.Res_method m -> (m.met_value.val_name, RK_method) | Odoc_search.Res_section (_ ,t)-> assert false | Odoc_search.Res_recfield (t, f) -> (Printf.sprintf "%s.%s" t.ty_name f.rf_name, RK_recfield) | Odoc_search.Res_const (t, f) -> (Printf.sprintf "%s.%s" t.ty_name f.vc_name, RK_const) in add_verified (name, Some kind) ; (name, Some kind) in match res with | (name, Some k) -> Ref (name, Some k, text_option) | (_, None) -> match parent_name with None -> Odoc_global.pwarning (Odoc_messages.cross_element_not_found initial_name); Ref (initial_name, None, text_option) | Some p -> let parent_name = match Name.father p with "" -> None | s -> Some s in iter_parent ?parent_name (Name.concat p initial_name) in iter_parent ~parent_name initial_name ) | Ref (initial_name, Some kind, text_option) -> ( let rec iter_parent ?parent_name name = let v = (name, Some kind) in if was_verified v then Ref (name, Some kind, text_option) else let res = match kind with | RK_section _ -> ( (** we just verify that we find an element of this kind with this name *) try let re = Str.regexp ("^"^(Str.quote name)^"$") in let t = Odoc_search.find_section module_list re in let v2 = (name, Some (RK_section t)) in add_verified v2 ; (name, Some (RK_section t)) with Not_found -> (name, None) ) | _ -> let f = match kind with RK_module -> module_exists | RK_module_type -> module_type_exists | RK_class -> class_exists | RK_class_type -> class_type_exists | RK_value -> value_exists | RK_type -> type_exists | RK_exception -> exception_exists | RK_attribute -> attribute_exists | RK_method -> method_exists | RK_section _ -> assert false | RK_recfield -> recfield_exists | RK_const -> const_exists in if f name then ( add_verified v ; (name, Some kind) ) else (name, None) in match res with | (name, Some k) -> Ref (name, Some k, text_option) | (_, None) -> match parent_name with None -> Odoc_global.pwarning (not_found_of_kind kind initial_name); Ref (initial_name, None, text_option) | Some p -> let parent_name = match Name.father p with "" -> None | s -> Some s in iter_parent ?parent_name (Name.concat p initial_name) in iter_parent ~parent_name initial_name ) | Module_list l -> Module_list l | Index_list -> Index_list | Custom (s,t) -> Custom (s, (assoc_comments_text parent_name module_list t)) | Target (target, code) -> Target (target, code) and assoc_comments_text parent_name module_list text = List.map (assoc_comments_text_elements parent_name module_list) text and assoc_comments_info parent_name module_list i = let ft = assoc_comments_text parent_name module_list in { i with i_desc = ao ft i.i_desc ; i_sees = List.map (fun (sr, t) -> (sr, ft t)) i.i_sees; i_deprecated = ao ft i.i_deprecated ; i_params = List.map (fun (name, t) -> (name, ft t)) i.i_params; i_raised_exceptions = List.map (fun (name, t) -> (name, ft t)) i.i_raised_exceptions; i_return_value = ao ft i.i_return_value ; i_custom = List.map (fun (tag, t) -> (tag, ft t)) i.i_custom ; } let rec assoc_comments_module_element parent_name module_list m_ele = match m_ele with Element_module m -> Element_module (assoc_comments_module module_list m) | Element_module_type mt -> Element_module_type (assoc_comments_module_type module_list mt) | Element_included_module _ -> m_ele (* don't go down into the aliases *) | Element_class c -> Element_class (assoc_comments_class module_list c) | Element_class_type ct -> Element_class_type (assoc_comments_class_type module_list ct) | Element_value v -> Element_value (assoc_comments_value module_list v) | Element_exception e -> Element_exception (assoc_comments_exception module_list e) | Element_type t -> Element_type (assoc_comments_type module_list t) | Element_module_comment t -> Element_module_comment (assoc_comments_text parent_name module_list t) and assoc_comments_class_element parent_name module_list c_ele = match c_ele with Class_attribute a -> Class_attribute (assoc_comments_attribute module_list a) | Class_method m -> Class_method (assoc_comments_method module_list m) | Class_comment t -> Class_comment (assoc_comments_text parent_name module_list t) and assoc_comments_module_kind parent_name module_list mk = match mk with | Module_struct eles -> Module_struct (List.map (assoc_comments_module_element parent_name module_list) eles) | Module_alias _ | Module_functor _ -> mk | Module_apply (mk1, mk2) -> Module_apply (assoc_comments_module_kind parent_name module_list mk1, assoc_comments_module_kind parent_name module_list mk2) | Module_with (mtk, s) -> Module_with (assoc_comments_module_type_kind parent_name module_list mtk, s) | Module_constraint (mk1, mtk) -> Module_constraint (assoc_comments_module_kind parent_name module_list mk1, assoc_comments_module_type_kind parent_name module_list mtk) | Module_typeof _ -> mk | Module_unpack _ -> mk and assoc_comments_module_type_kind parent_name module_list mtk = match mtk with | Module_type_struct eles -> Module_type_struct (List.map (assoc_comments_module_element parent_name module_list) eles) | Module_type_functor (params, mtk1) -> Module_type_functor (params, assoc_comments_module_type_kind parent_name module_list mtk1) | Module_type_alias _ -> mtk | Module_type_with (mtk1, s) -> Module_type_with (assoc_comments_module_type_kind parent_name module_list mtk1, s) | Module_type_typeof _ -> mtk and assoc_comments_class_kind parent_name module_list ck = match ck with Class_structure (inher, eles) -> let inher2 = List.map (fun ic -> { ic with ic_text = ao (assoc_comments_text parent_name module_list) ic.ic_text }) inher in Class_structure (inher2, List.map (assoc_comments_class_element parent_name module_list) eles) | Class_apply _ | Class_constr _ -> ck | Class_constraint (ck1, ctk) -> Class_constraint (assoc_comments_class_kind parent_name module_list ck1, assoc_comments_class_type_kind parent_name module_list ctk) and assoc_comments_class_type_kind parent_name module_list ctk = match ctk with Class_signature (inher, eles) -> let inher2 = List.map (fun ic -> { ic with ic_text = ao (assoc_comments_text parent_name module_list) ic.ic_text }) inher in Class_signature (inher2, List.map (assoc_comments_class_element parent_name module_list) eles) | Class_type _ -> ctk and assoc_comments_module module_list m = m.m_info <- ao (assoc_comments_info m.m_name module_list) m.m_info ; m.m_kind <- assoc_comments_module_kind m.m_name module_list m.m_kind ; m and assoc_comments_module_type module_list mt = mt.mt_info <- ao (assoc_comments_info mt.mt_name module_list) mt.mt_info ; mt.mt_kind <- ao (assoc_comments_module_type_kind mt.mt_name module_list) mt.mt_kind ; mt and assoc_comments_class module_list c = c.cl_info <- ao (assoc_comments_info c.cl_name module_list) c.cl_info ; c.cl_kind <- assoc_comments_class_kind c.cl_name module_list c.cl_kind ; assoc_comments_parameter_list c.cl_name module_list c.cl_parameters; c and assoc_comments_class_type module_list ct = ct.clt_info <- ao (assoc_comments_info ct.clt_name module_list) ct.clt_info ; ct.clt_kind <- assoc_comments_class_type_kind ct.clt_name module_list ct.clt_kind ; ct and assoc_comments_parameter parent_name module_list p = match p with Simple_name sn -> sn.sn_text <- ao (assoc_comments_text parent_name module_list) sn.sn_text | Tuple (l, t) -> List.iter (assoc_comments_parameter parent_name module_list) l and assoc_comments_parameter_list parent_name module_list pl = List.iter (assoc_comments_parameter parent_name module_list) pl and assoc_comments_value module_list v = let parent = Name.father v.val_name in v.val_info <- ao (assoc_comments_info parent module_list) v.val_info ; assoc_comments_parameter_list parent module_list v.val_parameters; v and assoc_comments_exception module_list e = let parent = Name.father e.ex_name in e.ex_info <- ao (assoc_comments_info parent module_list) e.ex_info ; e and assoc_comments_type module_list t = let parent = Name.father t.ty_name in t.ty_info <- ao (assoc_comments_info parent module_list) t.ty_info ; (match t.ty_kind with Type_abstract -> () | Type_variant vl -> List.iter (fun vc -> vc.vc_text <- ao (assoc_comments_text parent module_list) vc.vc_text) vl | Type_record fl -> List.iter (fun rf -> rf.rf_text <- ao (assoc_comments_text parent module_list) rf.rf_text) fl ); t and assoc_comments_attribute module_list a = let _ = assoc_comments_value module_list a.att_value in a and assoc_comments_method module_list m = let parent_name = Name.father m.met_value.val_name in let _ = assoc_comments_value module_list m.met_value in assoc_comments_parameter_list parent_name module_list m.met_value.val_parameters; m let associate_type_of_elements_in_comments module_list = List.map (assoc_comments_module module_list) module_list (***********************************************************) (** The function which performs all the cross referencing. *) let associate module_list = get_alias_names module_list ; init_known_elements_map module_list; let rec remove_doubles acc = function [] -> acc | h :: q -> if List.mem h acc then remove_doubles acc q else remove_doubles (h :: acc) q in let rec iter incomplete_modules = let (b_modif, remaining_inc_modules, acc_names_not_found) = List.fold_left (associate_in_module module_list) (false, [], []) incomplete_modules in let remaining_no_doubles = remove_doubles [] remaining_inc_modules in let remaining_modules = List.filter (fun m -> List.mem m.m_name remaining_no_doubles) incomplete_modules in if b_modif then (* we may be able to associate something else *) iter remaining_modules else (* nothing changed, we won't be able to associate any more *) acc_names_not_found in let names_not_found = iter module_list in ( match names_not_found with [] -> () | l -> List.iter (fun nf -> Odoc_global.pwarning ( match nf with NF_m n -> Odoc_messages.cross_module_not_found n | NF_mt n -> Odoc_messages.cross_module_type_not_found n | NF_mmt n -> Odoc_messages.cross_module_or_module_type_not_found n | NF_c n -> Odoc_messages.cross_class_not_found n | NF_ct n -> Odoc_messages.cross_class_type_not_found n | NF_cct n -> Odoc_messages.cross_class_or_class_type_not_found n | NF_ex n -> Odoc_messages.cross_exception_not_found n ); ) l ) ; (* Find a type for each name of element which is referenced in comments. *) ignore (associate_type_of_elements_in_comments module_list) mingw-ocaml/ocaml/ocamldoc/odoc_text_lexer.mll0000644000175000017500000005266312124403242021151 0ustar tootstoots{ (***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** The lexer for string to build text structures. *) open Lexing open Odoc_text_parser let line_number = ref 0 let char_number = ref 0 let string_buffer = Buffer.create 32 (** Fonction de remise a zero de la chaine de caracteres tampon *) let reset_string_buffer () = Buffer.reset string_buffer (** Fonction d'ajout d'un caractere dans la chaine de caracteres tampon *) let ajout_char_string = Buffer.add_char string_buffer (** Add a string to the buffer. *) let ajout_string = Buffer.add_string string_buffer let lecture_string () = Buffer.contents string_buffer (** the variable which will contain the description string. Is initialized when we encounter the start of a special comment. *) let description = ref "" let blank = "[ \013\009\012]" let print_DEBUG s = print_string s; print_newline () (** this flag indicates whether we're in a string between begin_code and end_code tokens, to remember the number of open '[' and handle ']' correctly. *) let open_brackets = ref 0 (** this flag indicates if we're in verbatim mode or not, to handle any special expression like a string when we're in verbatim mode.*) let verb_mode = ref false (** this flag indicates if we're in "target format" mode or not, to handle any special expression like a string when we're in this mode.*) let target_mode = ref false (** this flag indicates if we're in shortcut list mode or not, to handle end_shortcut_list correctly.*) let shortcut_list_mode = ref false (** this flag indicates if we're in an element reference. *) let ele_ref_mode = ref false (** this flag indicates if we're in a preformatted code string. *) let code_pre_mode = ref false let init () = open_brackets := 0; verb_mode := false; target_mode := false; shortcut_list_mode := false; ele_ref_mode := false ; code_pre_mode := false ; line_number := 0 ; char_number := 0 let incr_cpts lexbuf = let s = Lexing.lexeme lexbuf in let l = Str.split_delim (Str.regexp_string "\n") s in match List.rev l with [] -> () (* should not occur *) | [s2] -> (* no newline *) char_number := !char_number + (String.length s2) | s2 :: _ -> line_number := !line_number + ((List.length l) - 1) ; char_number := String.length s2 } (** html marks, to use as alternative possible special strings *) let html_bold = "<"('b'|'B')">" let html_end_bold = "" let html_italic = "<"('i'|'I')">" let html_end_italic = "" let html_title = "<"('h'|'H')(['0'-'9'])+">" let html_end_title = "" let html_list = "<"('u'|'U')('l'|'L')">" let html_end_list = "" let html_enum = "<"('o'|'O')('l'|'L')">" let html_end_enum = "" let html_item = "<"('l'|'L')('i'|'I')">" let html_end_item = "" let html_code = "<"('c'|'C')('o'|'O')('d'|'D')('e'|'E')">" let html_end_code = "" let html_center = "<"('c'|'C')('e'|'E')('n'|'N')('t'|'T')('e'|'E')('r'|'R')">" let html_end_center = "" let html_left = "<"('l'|'L')('e'|'E')('f'|'F')('t'|'T')">" let html_end_left = "" let html_right = "<"('r'|'R')('i'|'I')('g'|'G')('h'|'H')('t'|'T')">" let html_end_right = "" let blank = [' ' '\013' '\009' '\012'] let blank_nl = [' ' '\013' '\009' '\012' '\010'] let label = ['a'-'z']+['a'-'z' 'A'-'Z' '0'-'9' '_']* (** special strings *) let end = "}" | html_end_bold | html_end_italic | html_end_title | html_end_list | html_end_enum | html_end_item | html_end_center let begin_title = ("{" ['0'-'9']+(":"label)? blank_nl) | html_title let begin_bold = "{b"blank_nl | html_bold let begin_emp = "{e"blank_nl let begin_center = "{C"blank_nl | html_center let begin_left = "{L"blank_nl let begin_right = "{R"blank_nl let begin_italic = "{i"blank_nl | html_italic let begin_list = "{ul"blank_nl? | html_list let begin_enum = "{ol"blank_nl? | html_enum let begin_item = "{li"blank_nl | "{- " | html_item let begin_link = "{{:" let begin_target = "{%"['a'-'z''A'-'Z''0'-'9''-''_']+":"blank_nl? let begin_latex = "{%"blank_nl let end_target = "%}" let begin_code = "[" | html_code let end_code = "]" | html_end_code let begin_code_pre = "{[" let end_code_pre = "]}" let begin_verb = "{v"blank_nl let end_verb = blank_nl"v}" let begin_ele_ref = "{!"blank_nl | "{!" let begin_val_ref = "{!val:"blank_nl | "{!val:" let begin_typ_ref = "{!type:"blank_nl | "{!type:" let begin_exc_ref = "{!exception:"blank_nl | "{!exception:" let begin_mod_ref = "{!module:"blank_nl | "{!module:" let begin_modt_ref = "{!modtype:"blank_nl | "{!modtype:" let begin_cla_ref = "{!class:"blank_nl | "{!class:" let begin_clt_ref = "{!classtype:"blank_nl | "{!classtype:" let begin_att_ref = "{!attribute:"blank_nl | "{!attribute:" let begin_met_ref = "{!method:"blank_nl | "{!method:" let begin_sec_ref = "{!section:"blank_nl | "{!section:" let begin_recf_ref = "{!recfield:"blank_nl | "{!recfield:" let begin_const_ref = "{!const:"blank_nl | "{!const:" let begin_mod_list_ref = "{!modules:"blank_nl | "{!modules:" let index_list = "{!indexlist}" let begin_custom = "{"['a'-'z''A'-'Z']['a'-'z''A'-'Z''0'-'9']* let begin_superscript = "{^"blank_nl | "{^" let begin_subscript = "{_"blank_nl | "{_" let shortcut_list_item = '\n'blank*"- " let shortcut_enum_item = '\n'blank*"+ " let end_shortcut_list = '\n'(blank*'\n')+ rule main = parse | "\\{" | "\\}" | "\\[" | "\\]" { incr_cpts lexbuf ; let s = Lexing.lexeme lexbuf in Char (String.sub s 1 1) } | end { print_DEBUG "end"; incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) then Char (Lexing.lexeme lexbuf) else let _ = if !ele_ref_mode then ele_ref_mode := false in END } | begin_title { print_DEBUG "begin_title"; incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else let s = Lexing.lexeme lexbuf in try (* chech if the "{..." or html_title mark was used. *) if s.[0] = '<' then let (n, l) = (2, (String.length s - 3)) in let s2 = String.sub s n l in Title (int_of_string s2, None) else let (n, l) = (1, (String.length s - 2)) in let s2 = String.sub s n l in try let i = String.index s2 ':' in let s_n = String.sub s2 0 i in let s_label = String.sub s2 (i+1) (l-i-1) in Title (int_of_string s_n, Some s_label) with Not_found -> Title (int_of_string s2, None) with _ -> Title (1, None) } | begin_bold { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else BOLD } | begin_italic { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else ITALIC } | begin_link { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else LINK } | begin_emp { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else EMP } | begin_superscript { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else SUPERSCRIPT } | begin_subscript { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else SUBSCRIPT } | begin_center { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else CENTER } | begin_left { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else LEFT } | begin_right { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else RIGHT } | begin_list { print_DEBUG "LIST"; incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else LIST } | begin_enum { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else ENUM } | begin_item { print_DEBUG "ITEM"; incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else ITEM } | begin_target { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else ( let s = Lexing.lexeme lexbuf in let fmt = let p1 = String.index s '%' in let p2 = String.index s ':' in String.sub s (p1 + 1) (p2 - p1 - 1) in target_mode := true; Target fmt ) } | begin_latex { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else ( target_mode := true; LATEX ) } | end_target { incr_cpts lexbuf ; if !verb_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else ( target_mode := false; END_TARGET ) } | begin_code end_code { incr_cpts lexbuf ; Char (Lexing.lexeme lexbuf) } | begin_code { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else if !open_brackets <= 0 then ( open_brackets := 1; CODE ) else ( incr open_brackets; Char (Lexing.lexeme lexbuf) ) } | end_code { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else if !open_brackets > 1 then ( decr open_brackets; Char "]" ) else ( open_brackets := 0; END_CODE ) } | begin_code_pre end_code_pre { incr_cpts lexbuf ; Char (Lexing.lexeme lexbuf) } | begin_code_pre { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else ( code_pre_mode := true; CODE_PRE ) } | end_code_pre { incr_cpts lexbuf ; if !verb_mode or !target_mode or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else if !open_brackets >= 1 then ( lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1 } ; decr char_number ; if !open_brackets > 1 then ( decr open_brackets; Char "]" ) else ( open_brackets := 0; END_CODE ) ) else if !code_pre_mode then ( code_pre_mode := false; END_CODE_PRE ) else Char (Lexing.lexeme lexbuf) } | begin_ele_ref end { incr_cpts lexbuf ; Char (Lexing.lexeme lexbuf) } | begin_ele_ref { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then ( ele_ref_mode := true; ELE_REF ) else ( Char (Lexing.lexeme lexbuf) ) } | begin_val_ref { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then ( ele_ref_mode := true; VAL_REF ) else ( Char (Lexing.lexeme lexbuf) ) } | begin_typ_ref { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then ( ele_ref_mode := true; TYP_REF ) else ( Char (Lexing.lexeme lexbuf) ) } | begin_exc_ref { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then ( ele_ref_mode := true; EXC_REF ) else ( Char (Lexing.lexeme lexbuf) ) } | begin_mod_ref { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then ( ele_ref_mode := true; MOD_REF ) else ( Char (Lexing.lexeme lexbuf) ) } | begin_modt_ref { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then ( ele_ref_mode := true; MODT_REF ) else ( Char (Lexing.lexeme lexbuf) ) } | begin_cla_ref { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then ( ele_ref_mode := true; CLA_REF ) else ( Char (Lexing.lexeme lexbuf) ) } | begin_clt_ref { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then ( ele_ref_mode := true; CLT_REF ) else ( Char (Lexing.lexeme lexbuf) ) } | begin_att_ref { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then ( ele_ref_mode := true; ATT_REF ) else ( Char (Lexing.lexeme lexbuf) ) } | begin_met_ref { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then ( ele_ref_mode := true; MET_REF ) else ( Char (Lexing.lexeme lexbuf) ) } | begin_sec_ref { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then ( ele_ref_mode := true; SEC_REF ) else ( Char (Lexing.lexeme lexbuf) ) } | begin_recf_ref { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then ( ele_ref_mode := true; RECF_REF ) else ( Char (Lexing.lexeme lexbuf) ) } | begin_const_ref { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then ( ele_ref_mode := true; CONST_REF ) else ( Char (Lexing.lexeme lexbuf) ) } | begin_mod_list_ref { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then ( ele_ref_mode := true; MOD_LIST_REF ) else ( Char (Lexing.lexeme lexbuf) ) } | index_list { incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then Char (Lexing.lexeme lexbuf) else if not !ele_ref_mode then INDEX_LIST else Char (Lexing.lexeme lexbuf) } | begin_verb { incr_cpts lexbuf ; if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else ( verb_mode := true; VERB ) } | end_verb { incr_cpts lexbuf ; if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else ( verb_mode := false; END_VERB ) } | shortcut_list_item { incr_cpts lexbuf ; if !target_mode || (!open_brackets >= 1) || !code_pre_mode || !ele_ref_mode || !verb_mode then Char (Lexing.lexeme lexbuf) else if !shortcut_list_mode then ( SHORTCUT_LIST_ITEM ) else ( shortcut_list_mode := true; BEGIN_SHORTCUT_LIST_ITEM ) } | shortcut_enum_item { incr_cpts lexbuf ; if !target_mode || (!open_brackets >= 1) || !code_pre_mode || !ele_ref_mode || !verb_mode then Char (Lexing.lexeme lexbuf) else if !shortcut_list_mode then SHORTCUT_ENUM_ITEM else ( shortcut_list_mode := true; BEGIN_SHORTCUT_ENUM_ITEM ) } | end_shortcut_list { incr_cpts lexbuf ; lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1 ; } ; decr line_number ; if !shortcut_list_mode then ( shortcut_list_mode := false; (* go back one char to re-use the last '\n', so we can restart another shortcut-list with a single blank line, and not two.*) END_SHORTCUT_LIST ) else if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode or !verb_mode then Char (Lexing.lexeme lexbuf) else BLANK_LINE } | eof { EOF } | begin_custom { print_DEBUG "begin_custom"; incr_cpts lexbuf ; if !verb_mode or !target_mode or !code_pre_mode or (!open_brackets >= 1) or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else let s = Lexing.lexeme lexbuf in let len = String.length s in (* remove this starting '{' *) let tag = Odoc_misc.no_blanks (String.sub s 1 (len - 1)) in CUSTOM tag } | "{" { incr_cpts lexbuf ; if !target_mode or (!open_brackets >= 1) or !code_pre_mode or !ele_ref_mode then Char (Lexing.lexeme lexbuf) else LBRACE } | _ { incr_cpts lexbuf ; Char (Lexing.lexeme lexbuf) } mingw-ocaml/ocaml/ocamldoc/odoc_global.mli0000644000175000017500000000655312124403242020220 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Global variables. *) (** The kind of source file in arguments. *) type source_file = Impl_file of string | Intf_file of string | Text_file of string (** The include_dirs in the OCaml compiler. *) val include_dirs : string list ref (** Optional preprocessor command to pass to ocaml compiler. *) val preprocessor : string option ref (** Recursive types flag to passe to ocaml compiler. *) val recursive_types : bool ref (** The merge options to be used. *) val merge_options : Odoc_types.merge_option list ref (** Classic mode or not. *) val classic : bool ref (** The optional file name to dump the collected information into.*) val dump : string option ref (** The list of information files to load. *) val load : string list ref (** We must sort the list of top modules or not.*) val sort_modules : bool ref (** We must not stop at the stop special comments. Default is false (we stop).*) val no_stop : bool ref (** We must raise an exception when we find an unknown @-tag. *) val no_custom_tags : bool ref (** We must remove the the first characters of each comment line, until the first asterisk '*'. *) val remove_stars : bool ref (** To keep the code while merging, when we have both .ml and .mli files for a module. *) val keep_code : bool ref (** To inverse implementation and interface files when merging. *) val inverse_merge_ml_mli : bool ref (** To filter module elements according to module type constraints. *) val filter_with_module_constraints : bool ref (** The list of module names to hide. *) val hidden_modules : string list ref (** The files to be analysed. *) val files : source_file list ref (** A counter for errors. *) val errors : int ref (** Indicate if a warning is an error. *) val warn_error : bool ref (** Print the given warning, adding it to the list of {!errors} if {!warn_error} is [true]. *) val pwarning : string -> unit (** The file used by the generators outputting only one file. *) val out_file : string ref (** Verbose mode or not. *) val verbose : bool ref (** The optional file whose content can be used as intro text. *) val intro_file : string option ref (** The optional title to use in the generated documentation. *) val title : string option ref (** The directory where files have to be generated. *) val target_dir : string ref (** The flag which indicates if we must generate a table of contents. *) val with_toc : bool ref (** The flag which indicates if we must generate an index. *) val with_index : bool ref (** The flag which indicates if we must generate a header.*) val with_header : bool ref (** The flag which indicates if we must generate a trailer.*) val with_trailer : bool ref mingw-ocaml/ocaml/ocamldoc/odoc_exception.ml0000644000175000017500000000233712124403242020601 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Representation and manipulation of exceptions. *) module Name = Odoc_name type exception_alias = { ea_name : Name.t ; mutable ea_ex : t_exception option ; } and t_exception = { ex_name : Name.t ; mutable ex_info : Odoc_types.info option ; (** optional user information *) ex_args : Types.type_expr list ; (** the types of the parameters *) ex_alias : exception_alias option ; mutable ex_loc : Odoc_types.location ; mutable ex_code : string option ; } mingw-ocaml/ocaml/ocamldoc/Changes.txt0000644000175000017500000002323312124403242017354 0ustar tootstootsTODO: - need to fix display of type parameters for inherited classes/class types - need to add an environment while generating to print correct links: file foo.mli: type u module type M = sig type u end module N : sig include M val f: u -> unit end Here, in html for example, f in displayed being of type Foo.u instead of Foo.M.u - latex: types variant polymorphes depassent de la page quand ils sont trop longs - utilisation nouvelles infos de Xavier: "debut de rec", etc. - xml generator ===== Release > 3.11.0: - option -g also for native code version (loading custom generators) ===== Release 3.09.3: - mod: PR#4017 new option -short-functors to use a short form to display functors in html generator - fix: PR#4016 (using modtype constraint to filter module elements displayed in doc) - fix: PR#4066 (missing crossref in text from intro files) - fix: PR#4007 (error in merging of top dependencies of modules) - fix: PR#3981 (-dot-colors has no effect) - mod: name resolution in cross-referencing: {!name} if name is not found, then it is searched in the parent module/class, and in the parent of the parent, and so on until it is found. ===== Release 3.09.1: - fix: remove .TP for generated man pages, use .sp instead (.TP caused a lot of odd margins) - fix: html generator now output DOCTYPE and character encoding information. - add: m_text_only field in Module.t_module, to separate real modules from text files handled as modules. - fix: display only text for "text modules" - extensible {foo } syntax - user can give .txt files on the command line, containing ocamldoc formatted text, to be able to include bigger texts out of source files - -o option is now used by the html generator to indicate the prefix of generated index files (to avoid conflict when a Index module exists on case-insensitive file systems). ===== Release 3.08.4: - some improvements in html display - better error messages for misplaced variant constructors comments - some fixes in man page generation (escaping characters) ===== Release 3.08.2: - fix: error "Lexing: empty token" (PR#3173) ===== Release 3.08.1: - add: new -intf and -impl options supported (PR#3036) - fix: display of class parameters in HTML and LaTeX (PR#2994) - fix: display of link to class page in html (PR#2994) ===== Release 3.08.0: - fix: method parameters names in signature are now retrieved correctly (fix of Odoc_value.parameter_list_from_arrows to handle Tpoly for methods) - ajout a la doc de Module_list et Index_list (utilise dans le html seulement) - ajout a la doc: fichier de l'option -intro utilise pour l'index en html - fix: create a Module_with instead of a Module_alias when we encounter module A : Foo in a signature - latex: style latex pour indenter dans les module kind et les class kind - latex: il manque la generation des parametres de classe - parse des {!modules: } et {!indexlist} - gestion des Module_list et Index_list - no need to Dynlink.add_available_units any more - generate html from module_kind rather than from module_type + same for classes and class types - add the kind to module parameters (the way the parameter was build in the parsetree) - fix: the generated ocamldoc.sty is more robust for paragraphs in ocamldocdescription environment - fix: when generating separated files in latex, generate them in the same directory than the main file, (the one specified by -o) - mod: one section per to module in latex output + improve latex output - mod: odoc_latex: use buffers instead of string concatenation - add: new ocamldoc man page, thanks to Samuel Mimram - fix: useless parenthesis around agruments of arguments of a type constructor in type definitions, and aournd arguments of exceptions in exception definitions. - fix: blank lines in verbatim, latex, code pre, code and ele ref modes are now accepted - fix: html generator: included module names were displayed with their simple name rather than their fully qualified name - fix: use a formatter from a buffer rather Format.str_formatter in Odoc_mist.sting_of_module_type, to avoid too much blanks - new module odoc_print, will work when Format.pp_print_flush is fixed - odoc_html: use buffers instead of string concatenation - odoc_man: use buffers instead of string concatenation - odoc_cross.ml: use hash tables modified on the fly to resolve (module | module type | exception) name aliases - odoc_html: replace some calls to Str. by specific functions on strings - odoc_cross.ml: use a Map to associate a complete name to the known elements with this name, instead of searching each time through the whole list of modules -> a gain of more than 90% in speed for cross-referencing (Odoc_cross.associate) - fix: Odoc_name.cut printed a '(' instead of a '.' - add: new option -customdir - add: new option -i (to add a path to the directory where to look for custom generators) - add: add odoc_config.ml{,i} - add: keep_code in Odoc_info.Args interface - add: m_code_intf and m_code fields for modules, fit when the Odoc_args.keep_code option is set, and fit for all modules, not only toplevel ones - fix: bug preventing to get the code in a .mli - fix: missing spaces after carriage return in types (Odoc_misc.string_of_type_expr) - fixes: some bugs in the text parser ( ]} meaning end of code and somehting else instead of end of precode) - add: in Odoc_info: text_of_string, text_string_of_text, info_of_string - fix: better output of titles in html (use more the style) - add: -intro option to use a file content as ocamldoc comment to use as introduction for LaTeX document and HTML index page - add: the HTML generator generates the code of the module if available - add: field m_code for modules, to keep the code of top modules - fix: display "include Foo" instead of "include module Foo" in Latex, Man, Texi - fix: not display comments associated to include directives - fix: bad display of type parameters for class and class types ====== Release 3.05 : - added link tags in html header to reference sections and subsections in each page (for browser which handle those tags) - no titles nor lists in first sentence of text in indexes and latex titles - only one table for the titles in HTML output - fix of bad comment association for types in .ml files - dumps now contain a magic number, checked when dumps are loaded - new option -o to use with texi, latex and dot generators - new .code CSS class used - better output for classes and modules, with their type - added texinfo generator, by Olivier Andrieu - removed iso generator, which became the odoc_check custom generator - link syntax {{:url}text} added to the manual - (** comments in code is colorized in ocaml code html pages - new class .code in style - new generator : -dot . Output dot code to display modules or types dependencies. - new option -inv-merge-ml-mli to inverse the priority of .ml and .mli when merging - option -werr becomes -warn-error - possibility to define and reference section labels Exemple: (** {2:mysectionlabel My title bla bla bla} *) in module Foo This section is referenced with {!Foo.mysectionlabel} in a comment. Pre-release 4 : - new option -werr to treat ocamldoc warnings as errors - new option -hide to remove some modules from complete names, (e.g., print ref instead of Pervasives.ref) - HTML doc in classic style only contain indexes to existing element kinds (i.e. there is no class index if the doc does not contain any class.) - First description sentence now stops at the first period followed by a blank, or at the first blank line. - update of user manual - check report generator added (options -iso and -iso-{val|ty|cl|ex|mod}) - Odoc_info.Scan.scanner base class added - support for custom tags (@xxx with xxx not a predefined tag), see manual - new classes info in Odoc_html, Odoc_to_text, Odoc_latex, and Odoc_man, which contains the functions for printing info structures - replacement of modules Odoc_html.Text and Odoc_latex.Text by classes Odoc_html.text and Odoc_latex.text to allow the redefinition of their methods in custom generators - bug fix : a shortcut list can be pu after a blank line - improved display of variant constructors, record fields and their comments in classic HTML - blank lines in comments become

in HTML instead of
- bug fix : there can be blanks between the last item and the ending } of a list - new option -latextitles - number of errors encountered is displayed - if at least one error occurs, exit code is not 0 - more precise error messages - bug fix : \n and other blanks are accepted after, for example, {i Pre-release 3 : - option -stars - complete paths of executables in the generated Makefile - names of executables changed to ocamldoc and ocamldoc.opt - better LaTeX output - option -sepfiles for LaTeX - ocamldoc.sty used by the generated LaTeX - ocamldoc.hva added to use Hevea on the generated LaTeX - user manual updated - {[ ]} marks to put pre-formatted code on more than one line - {!Toto.tutu} to add cross references between elements - some bug fixes Rep-release 2 : - generator of texinfo files : odoc_texi.cma - use of CSS in generated html - new option -css-style to provide a different style sheet - improved html - added more precise titles in generated html pages - no more links to unknown elements - added indexes - simple html : added in : compliant browsers should display quick access to modules and indexes in their navigation bar (for example, mozilla 0.9.5 is compliant) - '{bone}' doesn't work any more ; a space is required as in '{b one}'. Same for {e, {i, and some others marks. Check the manual - bug fixes mingw-ocaml/ocaml/ocamldoc/ocamldoc.sty0000644000175000017500000000261412124403242017565 0ustar tootstoots%% Support macros for LaTeX documentation generated by ocamldoc. %% This file is in the public domain; do what you want with it. \NeedsTeXFormat{LaTeX2e} \ProvidesPackage{ocamldoc} [2001/12/04 v1.0 ocamldoc support] \newenvironment{ocamldoccode}{% \bgroup \leftskip\@totalleftmargin \rightskip\z@skip \parindent\z@ \parfillskip\@flushglue \parskip\z@skip %\noindent \@@par\smallskip \@tempswafalse \def\par{% \if@tempswa \leavevmode\null\@@par\penalty\interlinepenalty \else \@tempswatrue \ifhmode\@@par\penalty\interlinepenalty\fi \fi} \obeylines \verbatim@font \let\org@prime~% \@noligs \let\org@dospecials\dospecials \g@remfrom@specials{\\} \g@remfrom@specials{\{} \g@remfrom@specials{\}} \let\do\@makeother \dospecials \let\dospecials\org@dospecials \frenchspacing\@vobeyspaces \everypar \expandafter{\the\everypar \unpenalty}} {\egroup\par} \def\g@remfrom@specials#1{% \def\@new@specials{} \def\@remove##1{% \ifx##1#1\else \g@addto@macro\@new@specials{\do ##1}\fi} \let\do\@remove\dospecials \let\dospecials\@new@specials } \newenvironment{ocamldocdescription} {\list{}{\rightmargin0pt \topsep0pt}\raggedright\item\relax} {\endlist\medskip} \newenvironment{ocamldoccomment} {\list{}{\leftmargin 2\leftmargini \rightmargin0pt \topsep0pt}\raggedright\item\relax} {\endlist} \let\ocamldocvspace\vspace \endinput mingw-ocaml/ocaml/ocamldoc/odoc_env.mli0000644000175000017500000000604312124403242017542 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Environment for finding complete names from relative names. *) (** An environment of known names, from simple name to complete name. *) type env (** The empty environment. *) val empty : env (** Extending an environment *) val add_signature : env -> string -> ?rel:string -> Types.signature -> env val add_exception : env -> Odoc_name.t -> env val add_type : env -> Odoc_name.t -> env val add_value : env -> Odoc_name.t -> env val add_module : env -> Odoc_name.t -> env val add_module_type : env -> Odoc_name.t -> env val add_class : env -> Odoc_name.t -> env val add_class_type : env -> Odoc_name.t -> env (** Retrieving fully qualified names from an environment *) (** Get the fully qualified module name from a name.*) val full_module_name : env -> Odoc_name.t -> Odoc_name.t (** Get the fully qualified module type name from a name.*) val full_module_type_name : env -> Odoc_name.t -> Odoc_name.t (** Get the fully qualified module or module type name from a name. We look for a module type if we don't find a module.*) val full_module_or_module_type_name : env -> Odoc_name.t -> Odoc_name.t (** Get the fully qualified type name from a name.*) val full_type_name : env -> Odoc_name.t -> Odoc_name.t (** Get the fully qualified value name from a name.*) val full_value_name : env -> Odoc_name.t -> Odoc_name.t (** Get the fully qualified exception name from a name.*) val full_exception_name : env -> Odoc_name.t -> Odoc_name.t (** Get the fully qualified class name from a name.*) val full_class_name : env -> Odoc_name.t -> Odoc_name.t (** Get the fully qualified class type name from a name.*) val full_class_type_name : env -> Odoc_name.t -> Odoc_name.t (** Get the fully qualified class or class type name from a name.*) val full_class_or_class_type_name : env -> Odoc_name.t -> Odoc_name.t (** Substitutions *) (** Replace the [Path.t] by a complete [Path.t] in a [Types.type_expr].*) val subst_type : env -> Types.type_expr -> Types.type_expr (** Replace the [Path.t] by a complete [Path.t] in a [Types.module_type].*) val subst_module_type : env -> Types.module_type -> Types.module_type (** Replace the [Path.t] by a complete [Path.t] in a [Types.class_type]. Also empty the structures to get only [object end] when the type is printed. *) val subst_class_type : env -> Types.class_type -> Types.class_type mingw-ocaml/ocaml/ocamldoc/odoc_sig.mli0000644000175000017500000002006612124403242017535 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** The module for analysing a signature and source code and creating modules, classes, ..., elements.*) (** The functions used to retrieve information from a signature. *) module Signature_search : sig type ele type tab = (ele, Types.signature_item) Hashtbl.t (** Create a table from a signature. This table is used by some of the search functions below. *) val table : Types.signature -> tab (** This function returns the type expression for the value whose name is given, in the given signature. @raise Not_found if error.*) val search_value : tab -> string -> Types.type_expr (** This function returns the type expression list for the exception whose name is given, in the given table. @raise Not_found if error.*) val search_exception : tab -> string -> Types.exception_declaration (** This function returns the Types.type_declaration for the type whose name is given, in the given table. @raise Not_found if error.*) val search_type : tab -> string -> Types.type_declaration (** This function returns the Types.class_declaration for the class whose name is given, in the given table. @raise Not_found if error.*) val search_class : tab -> string -> Types.class_declaration (** This function returns the Types.cltype_declaration for the class type whose name is given, in the given table. @raise Not_found if error.*) val search_class_type : tab -> string -> Types.class_type_declaration (** This function returns the Types.module_type for the module whose name is given, in the given table. @raise Not_found if error.*) val search_module : tab -> string -> Types.module_type (** This function returns the optional Types.module_type for the module type whose name is given, in the given table. @raise Not_found if error.*) val search_module_type : tab -> string -> Types.module_type option (** This function returns the Types.type_expr for the given val name in the given class signature. @raise Not_found if error.*) val search_attribute_type : Types.Vars.key -> Types.class_signature -> Types.type_expr (** This function returns the Types.type_expr for the given method name in the given class signature. @raise Not_found if error.*) val search_method_type : string -> Types.class_signature -> Types.type_expr end (** Functions to retrieve simple and special comments from strings. *) module type Info_retriever = sig (** Return the couple [(n, list)] where [n] is the number of characters read to retrieve [list], which is the list of special comments found in the string. *) val all_special : string -> string -> int * Odoc_types.info list (** Return true if the given string contains a blank line. *) val blank_line_outside_simple : string -> string -> bool (** [just_after_special file str] return the pair ([length], [info_opt]) where [info_opt] is the first optional special comment found in [str], without any blank line before. [length] is the number of chars from the beginning of [str] to the end of the special comment. *) val just_after_special : string -> string -> (int * Odoc_types.info option) (** [first_special file str] return the pair ([length], [info_opt]) where [info_opt] is the first optional special comment found in [str]. [length] is the number of chars from the beginning of [str] to the end of the special comment. *) val first_special : string -> string -> (int * Odoc_types.info option) (** Return a pair [(comment_opt, element_comment_list)], where [comment_opt] is the last special comment found in the given string and not followed by a blank line, and [element_comment_list] the list of values built from the other special comments found and the given function. *) val get_comments : (Odoc_types.text -> 'a) -> string -> string -> (Odoc_types.info option * 'a list) end module Analyser : functor (My_ir : Info_retriever) -> sig (** This variable is used to load a file as a string and retrieve characters from it.*) val file : string ref (** The name of the analysed file. *) val file_name : string ref (** This function takes two indexes (start and end) and return the string corresponding to the indexes in the file global variable. The function prepare_file must have been called to fill the file global variable.*) val get_string_of_file : int -> int -> string (** [prepare_file f input_f] sets [file_name] with [f] and loads the file [input_f] into [file].*) val prepare_file : string -> string -> unit (** The function used to get the comments in a class. *) val get_comments_in_class : int -> int -> (Odoc_types.info option * Odoc_class.class_element list) (** The function used to get the comments in a module. *) val get_comments_in_module : int -> int -> (Odoc_types.info option * Odoc_module.module_element list) (** [name_comment_from_type_kind pos_end pos_limit type_kind]. This function takes a [Parsetree.type_kind] and returns the list of (name, optional comment) for the various fields/constructors of the type, or an empty list for an abstract type. [pos_end] is last char of the complete type definition. [pos_limit] is the position of the last char we could use to look for a comment, i.e. usually the beginning on the next element.*) val name_comment_from_type_kind : int -> int -> Parsetree.type_kind -> int * (string * Odoc_types.info option) list (** This function converts a [Types.type_kind] into a [Odoc_type.type_kind], by associating the comment found in the parsetree of each constructor/field, if any.*) val get_type_kind : Odoc_env.env -> (string * Odoc_types.info option) list -> Types.type_kind -> Odoc_type.type_kind (** This function merge two optional info structures. *) val merge_infos : Odoc_types.info option -> Odoc_types.info option -> Odoc_types.info option (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *) val analyse_module_type_kind : ?erased:Odoc_name.Set.t -> Odoc_env.env -> Odoc_name.t -> Parsetree.module_type -> Types.module_type -> Odoc_module.module_type_kind (** Analysis of a Parsetree.class_type and a Types.class_type to return a class_type_kind.*) val analyse_class_type_kind : Odoc_env.env -> Odoc_name.t -> int -> Parsetree.class_type -> Types.class_type -> Odoc_class.class_type_kind (** This function takes an interface file name, a file containg the code, a parse tree and the signature obtained from the compiler. It goes through the parse tree, creating values for encountered functions, modules, ..., looking in the source file for comments, and in the signature for types information. *) val analyse_signature : string -> string -> Parsetree.signature -> Types.signature -> Odoc_module.t_module end mingw-ocaml/ocaml/ocamldoc/odoc_misc.mli0000644000175000017500000001153012124403242017702 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Miscelaneous functions *) (** [no_blanks s] returns the given string without any blank characters, i.e. '\n' '\r' ' ' '\t'. *) val no_blanks : string -> string (** This function returns a file in the form of one string.*) val input_file_as_string : string -> string (** [split_with_blanks s] splits the given string [s] according to blanks. *) val split_with_blanks : string -> string list (** This function creates a string from a Longident.t .*) val string_of_longident : Longident.t -> string (** This function returns the list of (label, type_expr) describing the methods of a type_expr in a Tobject.*) val get_fields : Types.type_expr -> (string * Types.type_expr) list (** get a string from a text *) val string_of_text : Odoc_types.text -> string (** @return a string for an authors list. *) val string_of_author_list : string list -> string (** @return a string for the given optional version information.*) val string_of_version_opt : string option -> string (** @return a string for the given optional since information.*) val string_of_since_opt : string option -> string (** @return a string for the given list of raised exceptions.*) val string_of_raised_exceptions : (string * Odoc_types.text) list -> string (** @return a string for the given "see also" reference.*) val string_of_see : Odoc_types.see_ref * Odoc_types.text -> string (** @return a string for the given list of "see also" references.*) val string_of_sees : (Odoc_types.see_ref * Odoc_types.text) list -> string (** @return a string for the given optional return information.*) val string_of_return_opt : Odoc_types.text option -> string (** get a string from a Odoc_info.info structure *) val string_of_info : Odoc_types.info -> string (** Apply a function to an optional value. *) val apply_opt : ('a -> 'b) -> 'a option -> 'b option (** Return a string representing a date given as a number of seconds since 1970. The hour is optionnaly displayed. *) val string_of_date : ?hour:bool -> float -> string (** Return the first sentence (until the first dot) of a text. Don't stop in the middle of [Code], [Verbatim], [List], [Lnum], [Latex], [Link], or [Ref]. *) val first_sentence_of_text : Odoc_types.text -> Odoc_types.text (** Return the first sentence (until the first dot) of a text, and the remaining text after. Don't stop in the middle of [Code], [Verbatim], [List], [Lnum], [Latex], [Link], or [Ref]. *) val first_sentence_and_rest_of_text : Odoc_types.text -> Odoc_types.text * Odoc_types.text (** Return the given [text] without any title or list. *) val text_no_title_no_list : Odoc_types.text -> Odoc_types.text (** [concat sep l] concats the given list of text [l], each separated with the text [sep]. *) val text_concat : Odoc_types.text -> Odoc_types.text list -> Odoc_types.text (** Return the list of titles in a [text]. A title is a title level, an optional label and a text.*) val get_titles_in_text : Odoc_types.text -> (int * string option * Odoc_types.text) list (** Take a sorted list of elements, a function to get the name of an element and return the list of list of elements, where each list group elements beginning by the same letter. Since the original list is sorted, elements whose name does not begin with a letter should be in the first returned list.*) val create_index_lists : 'a list -> ('a -> string) -> 'a list list (** [remove_ending_newline s] returns [s] without the optional ending newline. *) val remove_ending_newline : string -> string (** [search_string_backward pat s] searches backward string [pat] in string [s]. Return position in string [s] where [pat] appears, orelse raise [Not_found]. *) val search_string_backward : pat: string -> s: string -> int (** Take a type and remove the option top constructor. This is useful when printing labels, we we then remove the top option contructor for optional labels.*) val remove_option : Types.type_expr -> Types.type_expr (** Return [true] if the given label is optional.*) val is_optional : string -> bool (** Return the label name for the given label, i.e. removes the beginning '?' if present.*) val label_name : string -> string mingw-ocaml/ocaml/ocamldoc/odoc_args.ml0000644000175000017500000003445312124403242017543 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* cvsid $Id$ *) (** Command-line arguments. *) module M = Odoc_messages let current_generator = ref (None : Odoc_gen.generator option) let get_html_generator () = match !current_generator with None -> (module Odoc_html.Generator : Odoc_html.Html_generator) | Some (Odoc_gen.Html m) -> m | Some _ -> failwith (M.current_generator_is_not "html") ;; let get_latex_generator () = match !current_generator with None -> (module Odoc_latex.Generator : Odoc_latex.Latex_generator) | Some (Odoc_gen.Latex m) -> m | Some _ -> failwith (M.current_generator_is_not "latex") ;; let get_texi_generator () = match !current_generator with None -> (module Odoc_texi.Generator : Odoc_texi.Texi_generator) | Some (Odoc_gen.Texi m) -> m | Some _ -> failwith (M.current_generator_is_not "texi") ;; let get_man_generator () = match !current_generator with None -> (module Odoc_man.Generator : Odoc_man.Man_generator) | Some (Odoc_gen.Man m) -> m | Some _ -> failwith (M.current_generator_is_not "man") ;; let get_dot_generator () = match !current_generator with None -> (module Odoc_dot.Generator : Odoc_dot.Dot_generator) | Some (Odoc_gen.Dot m) -> m | Some _ -> failwith (M.current_generator_is_not "dot") ;; let get_base_generator () = match !current_generator with None -> (module Odoc_gen.Base_generator : Odoc_gen.Base) | Some (Odoc_gen.Base m) -> m | Some _ -> failwith (M.current_generator_is_not "base") ;; let extend_html_generator f = let current = get_html_generator () in let module Current = (val current : Odoc_html.Html_generator) in let module F = (val f : Odoc_gen.Html_functor) in let module M = F(Current) in current_generator := Some (Odoc_gen.Html (module M : Odoc_html.Html_generator)) ;; let extend_latex_generator f = let current = get_latex_generator () in let module Current = (val current : Odoc_latex.Latex_generator) in let module F = (val f : Odoc_gen.Latex_functor) in let module M = F(Current) in current_generator := Some(Odoc_gen.Latex (module M : Odoc_latex.Latex_generator)) ;; let extend_texi_generator f = let current = get_texi_generator () in let module Current = (val current : Odoc_texi.Texi_generator) in let module F = (val f : Odoc_gen.Texi_functor) in let module M = F(Current) in current_generator := Some(Odoc_gen.Texi (module M : Odoc_texi.Texi_generator)) ;; let extend_man_generator f = let current = get_man_generator () in let module Current = (val current : Odoc_man.Man_generator) in let module F = (val f : Odoc_gen.Man_functor) in let module M = F(Current) in current_generator := Some(Odoc_gen.Man (module M : Odoc_man.Man_generator)) ;; let extend_dot_generator f = let current = get_dot_generator () in let module Current = (val current : Odoc_dot.Dot_generator) in let module F = (val f : Odoc_gen.Dot_functor) in let module M = F(Current) in current_generator := Some (Odoc_gen.Dot (module M : Odoc_dot.Dot_generator)) ;; let extend_base_generator f = let current = get_base_generator () in let module Current = (val current : Odoc_gen.Base) in let module F = (val f : Odoc_gen.Base_functor) in let module M = F(Current) in current_generator := Some (Odoc_gen.Base (module M : Odoc_gen.Base)) ;; (** Analysis of a string defining options. Return the list of options according to the list giving associations between [(character, _)] and a list of options. *) let analyse_option_string l s = List.fold_left (fun acc -> fun ((c,_), v) -> if String.contains s c then acc @ v else acc) [] l (** Analysis of a string defining the merge options to be used. Returns the list of options specified.*) let analyse_merge_options s = let l = [ (M.merge_description, [Odoc_types.Merge_description]) ; (M.merge_author, [Odoc_types.Merge_author]) ; (M.merge_version, [Odoc_types.Merge_version]) ; (M.merge_see, [Odoc_types.Merge_see]) ; (M.merge_since, [Odoc_types.Merge_since]) ; (M.merge_before, [Odoc_types.Merge_before]) ; (M.merge_deprecated, [Odoc_types.Merge_deprecated]) ; (M.merge_param, [Odoc_types.Merge_param]) ; (M.merge_raised_exception, [Odoc_types.Merge_raised_exception]) ; (M.merge_return_value, [Odoc_types.Merge_return_value]) ; (M.merge_custom, [Odoc_types.Merge_custom]) ; (M.merge_all, Odoc_types.all_merge_options) ] in analyse_option_string l s let f_latex_title s = try let pos = String.index s ',' in let n = int_of_string (String.sub s 0 pos) in let len = String.length s in let command = String.sub s (pos + 1) (len - pos - 1) in Odoc_latex.latex_titles := List.remove_assoc n !Odoc_latex.latex_titles ; Odoc_latex.latex_titles := (n, command) :: !Odoc_latex.latex_titles with Not_found | Invalid_argument _ -> incr Odoc_global.errors ; prerr_endline (M.wrong_format s) let add_hidden_modules s = let l = Str.split (Str.regexp ",") s in List.iter (fun n -> let name = Str.global_replace (Str.regexp "[ \n\r\t]+") "" n in match name with "" -> () | _ -> match name.[0] with 'A'..'Z' -> Odoc_global.hidden_modules := name :: !Odoc_global.hidden_modules | _ -> incr Odoc_global.errors; prerr_endline (M.not_a_module_name name) ) l let set_generator (g : Odoc_gen.generator) = current_generator := Some g (** The default option list *) let default_options = [ "-version", Arg.Unit (fun () -> print_string M.message_version ; print_newline () ; exit 0) , M.option_version ; "-vnum", Arg.Unit (fun () -> print_string M.config_version ; print_newline () ; exit 0) , M.option_version ; "-v", Arg.Unit (fun () -> Odoc_global.verbose := true), M.verbose_mode ; "-I", Arg.String (fun s -> Odoc_global.include_dirs := (Misc.expand_directory Config.standard_library s) :: !Odoc_global.include_dirs), M.include_dirs ; "-pp", Arg.String (fun s -> Odoc_global.preprocessor := Some s), M.preprocess ; "-impl", Arg.String (fun s -> Odoc_global.files := !Odoc_global.files @ [Odoc_global.Impl_file s]), M.option_impl ; "-intf", Arg.String (fun s -> Odoc_global.files := !Odoc_global.files @ [Odoc_global.Intf_file s]), M.option_intf ; "-text", Arg.String (fun s -> Odoc_global.files := !Odoc_global.files @ [Odoc_global.Text_file s]), M.option_text ; "-rectypes", Arg.Set Odoc_global.recursive_types, M.rectypes ; "-nolabels", Arg.Unit (fun () -> Odoc_global.classic := true), M.nolabels ; "-warn-error", Arg.Set Odoc_global.warn_error, M.werr ; "-hide-warnings", Arg.Clear Odoc_config.print_warnings, M.hide_warnings ; "-o", Arg.String (fun s -> Odoc_global.out_file := s), M.out_file ; "-d", Arg.String (fun s -> Odoc_global.target_dir := s), M.target_dir ; "-sort", Arg.Unit (fun () -> Odoc_global.sort_modules := true), M.sort_modules ; "-no-stop", Arg.Set Odoc_global.no_stop, M.no_stop ; "-no-custom-tags", Arg.Set Odoc_global.no_custom_tags, M.no_custom_tags ; "-stars", Arg.Set Odoc_global.remove_stars, M.remove_stars ; "-inv-merge-ml-mli", Arg.Set Odoc_global.inverse_merge_ml_mli, M.inverse_merge_ml_mli ; "-no-module-constraint-filter", Arg.Clear Odoc_global.filter_with_module_constraints, M.no_filter_with_module_constraints ; "-keep-code", Arg.Set Odoc_global.keep_code, M.keep_code^"\n" ; "-dump", Arg.String (fun s -> Odoc_global.dump := Some s), M.dump ; "-load", Arg.String (fun s -> Odoc_global.load := !Odoc_global.load @ [s]), M.load^"\n" ; "-t", Arg.String (fun s -> Odoc_global.title := Some s), M.option_title ; "-intro", Arg.String (fun s -> Odoc_global.intro_file := Some s), M.option_intro ; "-hide", Arg.String add_hidden_modules, M.hide_modules ; "-m", Arg.String (fun s -> Odoc_global.merge_options := !Odoc_global.merge_options @ (analyse_merge_options s)), M.merge_options ^ "\n\n *** choosing a generator ***\n"; (* generators *) "-html", Arg.Unit (fun () -> set_generator (Odoc_gen.Html (module Odoc_html.Generator : Odoc_html.Html_generator))), M.generate_html ; "-latex", Arg.Unit (fun () -> set_generator (Odoc_gen.Latex (module Odoc_latex.Generator : Odoc_latex.Latex_generator))), M.generate_latex ; "-texi", Arg.Unit (fun () -> set_generator (Odoc_gen.Texi (module Odoc_texi.Generator : Odoc_texi.Texi_generator))), M.generate_texinfo ; "-man", Arg.Unit (fun () -> set_generator (Odoc_gen.Man (module Odoc_man.Generator : Odoc_man.Man_generator))), M.generate_man ; "-dot", Arg.Unit (fun () -> set_generator (Odoc_gen.Dot (module Odoc_dot.Generator : Odoc_dot.Dot_generator))), M.generate_dot ; "-customdir", Arg.Unit (fun () -> Printf.printf "%s\n" Odoc_config.custom_generators_path; exit 0), M.display_custom_generators_dir ; "-i", Arg.String (fun s -> ()), M.add_load_dir ; "-g", Arg.String (fun s -> ()), M.load_file ^ "\n\n *** HTML options ***\n"; (* html only options *) "-all-params", Arg.Set Odoc_html.with_parameter_list, M.with_parameter_list ; "-css-style", Arg.String (fun s -> Odoc_html.css_style := Some s), M.css_style ; "-index-only", Arg.Set Odoc_html.index_only, M.index_only ; "-colorize-code", Arg.Set Odoc_html.colorize_code, M.colorize_code ; "-short-functors", Arg.Set Odoc_html.html_short_functors, M.html_short_functors ; "-charset", Arg.Set_string Odoc_html.charset, (M.charset !Odoc_html.charset)^ "\n\n *** LaTeX options ***\n"; (* latex only options *) "-noheader", Arg.Unit (fun () -> Odoc_global.with_header := false), M.no_header ; "-notrailer", Arg.Unit (fun () -> Odoc_global.with_trailer := false), M.no_trailer ; "-sepfiles", Arg.Set Odoc_latex.separate_files, M.separate_files ; "-latextitle", Arg.String f_latex_title, M.latex_title Odoc_latex.latex_titles ; "-latex-value-prefix", Arg.String (fun s -> Odoc_latex.latex_value_prefix := s), M.latex_value_prefix ; "-latex-type-prefix", Arg.String (fun s -> Odoc_latex.latex_type_prefix := s), M.latex_type_prefix ; "-latex-exception-prefix", Arg.String (fun s -> Odoc_latex.latex_exception_prefix := s), M.latex_exception_prefix ; "-latex-attribute-prefix", Arg.String (fun s -> Odoc_latex.latex_attribute_prefix := s), M.latex_attribute_prefix ; "-latex-method-prefix", Arg.String (fun s -> Odoc_latex.latex_method_prefix := s), M.latex_method_prefix ; "-latex-module-prefix", Arg.String (fun s -> Odoc_latex.latex_module_prefix := s), M.latex_module_prefix ; "-latex-module-type-prefix", Arg.String (fun s -> Odoc_latex.latex_module_type_prefix := s), M.latex_module_type_prefix ; "-latex-class-prefix", Arg.String (fun s -> Odoc_latex.latex_class_prefix := s), M.latex_class_prefix ; "-latex-class-type-prefix", Arg.String (fun s -> Odoc_latex.latex_class_type_prefix := s), M.latex_class_type_prefix ; "-notoc", Arg.Unit (fun () -> Odoc_global.with_toc := false), M.no_toc ^ "\n\n *** texinfo options ***\n"; (* texi only options *) "-noindex", Arg.Clear Odoc_global.with_index, M.no_index ; "-esc8", Arg.Set Odoc_texi.esc_8bits, M.esc_8bits ; "-info-section", Arg.String ((:=) Odoc_texi.info_section), M.info_section ; "-info-entry", Arg.String (fun s -> Odoc_texi.info_entry := !Odoc_texi.info_entry @ [ s ]), M.info_entry ^ "\n\n *** dot options ***\n"; (* dot only options *) "-dot-colors", Arg.String (fun s -> Odoc_dot.dot_colors := Str.split (Str.regexp_string ",") s), M.dot_colors ; "-dot-include-all", Arg.Set Odoc_dot.dot_include_all, M.dot_include_all ; "-dot-types", Arg.Set Odoc_dot.dot_types, M.dot_types ; "-dot-reduce", Arg.Set Odoc_dot.dot_reduce, M.dot_reduce^ "\n\n *** man pages options ***\n"; (* man only options *) "-man-mini", Arg.Set Odoc_man.man_mini, M.man_mini ; "-man-suffix", Arg.String (fun s -> Odoc_man.man_suffix := s), M.man_suffix ; "-man-section", Arg.String (fun s -> Odoc_man.man_section := s), M.man_section ; ] let options = ref default_options let modified_options () = !options != default_options let append_last_doc suffix = match List.rev !options with | (key, spec, doc) :: tl -> options := List.rev ((key, spec, doc ^ suffix) :: tl) | [] -> () (** The help option list, overriding the default ones from the Arg module *) let help_options = ref [] let help_action () = let msg = Arg.usage_string (!options @ !help_options) (M.usage ^ M.options_are) in print_string msg let () = help_options := [ "-help", Arg.Unit help_action, M.help ; "--help", Arg.Unit help_action, M.help ] let add_option o = if not (modified_options ()) then append_last_doc "\n *** custom generator options ***\n"; let (s,_,_) = o in let rec iter = function [] -> [o] | (s2,f,m) :: q -> if s = s2 then o :: q else (s2,f,m) :: (iter q) in options := iter !options let parse () = let anonymous f = let sf = if Filename.check_suffix f "ml" then Odoc_global.Impl_file f else if Filename.check_suffix f "mli" then Odoc_global.Intf_file f else if Filename.check_suffix f "txt" then Odoc_global.Text_file f else failwith (Odoc_messages.unknown_extension f) in Odoc_global.files := !Odoc_global.files @ [sf] in if modified_options () then append_last_doc "\n"; let options = !options @ !help_options in let _ = Arg.parse options anonymous (M.usage^M.options_are) in (* we sort the hidden modules by name, to be sure that for example, A.B is before A, so we will match against A.B before A in Odoc_name.hide_modules.*) Odoc_global.hidden_modules := List.sort (fun a -> fun b -> - (compare a b)) !Odoc_global.hidden_modules mingw-ocaml/ocaml/ocamldoc/odoc_types.ml0000644000175000017500000000624312124403242017747 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) type ref_kind = RK_module | RK_module_type | RK_class | RK_class_type | RK_value | RK_type | RK_exception | RK_attribute | RK_method | RK_section of text | RK_recfield | RK_const and text_element = | Raw of string | Code of string | CodePre of string | Verbatim of string | Bold of text | Italic of text | Emphasize of text | Center of text | Left of text | Right of text | List of text list | Enum of text list | Newline | Block of text | Title of int * string option * text | Latex of string | Link of string * text | Ref of string * ref_kind option * text option | Superscript of text | Subscript of text | Module_list of string list | Index_list | Custom of string * text | Target of string * string and text = text_element list type see_ref = See_url of string | See_file of string | See_doc of string type see = see_ref * text type param = (string * text) type raised_exception = (string * text) type info = { i_desc : text option; i_authors : string list; i_version : string option; i_sees : see list; i_since : string option; i_before : (string * text) list; i_deprecated : text option; i_params : param list; i_raised_exceptions : raised_exception list; i_return_value : text option ; i_custom : (string * text) list ; } let dummy_info = { i_desc = None ; i_authors = [] ; i_version = None ; i_sees = [] ; i_since = None ; i_before = [] ; i_deprecated = None ; i_params = [] ; i_raised_exceptions = [] ; i_return_value = None ; i_custom = [] ; } type location = { loc_impl : Location.t option ; loc_inter : Location.t option ; } let dummy_loc = { loc_impl = None ; loc_inter = None } type merge_option = | Merge_description | Merge_author | Merge_version | Merge_see | Merge_since | Merge_before | Merge_deprecated | Merge_param | Merge_raised_exception | Merge_return_value | Merge_custom let all_merge_options = [ Merge_description ; Merge_author ; Merge_version ; Merge_see ; Merge_since ; Merge_before ; Merge_deprecated ; Merge_param ; Merge_raised_exception ; Merge_return_value ; Merge_custom ; ] type magic = string let magic = Odoc_messages.magic type 'a dump = Dump of magic * 'a let make_dump a = Dump (magic, a) let open_dump = function Dump (m, a) -> if m = magic then a else raise (Failure Odoc_messages.bad_magic_number) mingw-ocaml/ocaml/ocamldoc/odoc_comments_global.mli0000644000175000017500000000324212124403242022115 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** The global variables used by the special comment parser.*) (** the number of chars used in the lexer. *) val nb_chars : int ref (** the authors list *) val authors : string list ref (** the version string *) val version : string option ref (** the see references *) val sees : string list ref (** the since string *) val since : string option ref (** the before tag information *) val before : (string * string) list ref (** the deprecated flag *) val deprecated : string option ref (** parameters, with name and description *) val params : (string * string) list ref (** the raised exceptions, with name and description *) val raised_exceptions : (string * string) list ref (** the description of the return value *) val return_value : string option ref (** the strings associated to custom tags. *) val customs : (string * string) list ref (** this function inits the variables filled by the parser. *) val init : unit -> unit mingw-ocaml/ocaml/ocamldoc/odoc_name.ml0000644000175000017500000001264212124403242017523 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Representation of element names. *) let infix_chars = [ '|' ; '<' ; '>' ; '@' ; '^' ; '&' ; '+' ; '-' ; '*' ; '/' ; '$' ; '%' ; '=' ; ':' ; '~' ; '!' ; ] type t = string let strip_string s = let len = String.length s in let rec iter_first n = if n >= len then None else match s.[n] with ' ' | '\t' | '\n' | '\r' -> iter_first (n+1) | _ -> Some n in match iter_first 0 with None -> "" | Some first -> let rec iter_last n = if n <= first then None else match s.[n] with ' ' | '\t' | '\n' | '\r' -> iter_last (n-1) | _ -> Some n in match iter_last (len-1) with None -> String.sub s first 1 | Some last -> String.sub s first ((last-first)+1) let parens_if_infix name = match strip_string name with | "" -> "" | s when s.[0] = '*' || s.[String.length s - 1] = '*' -> "( " ^ s ^ " )" | s when List.mem s.[0] infix_chars -> "(" ^ s ^ ")" | "or" | "mod" | "land" | "lor" | "lxor" | "lsl" | "lsr" | "asr" -> "(" ^ name ^ ")" | name -> name ;; let cut name = match name with "" -> ("", "") | s -> let len = String.length s in match s.[len-1] with ')' -> ( let j = ref 0 in let buf = [|Buffer.create len ; Buffer.create len |] in for i = 0 to len - 1 do match s.[i] with '.' when !j = 0 -> if i < len - 1 then match s.[i+1] with '(' -> j := 1 | _ -> Buffer.add_char buf.(!j) '.' else Buffer.add_char buf.(!j) s.[i] | c -> Buffer.add_char buf.(!j) c done; (Buffer.contents buf.(0), Buffer.contents buf.(1)) ) | _ -> match List.rev (Str.split (Str.regexp_string ".") s) with [] -> ("", "") | h :: q -> (String.concat "." (List.rev q), h) let simple name = snd (cut name) let father name = fst (cut name) let concat n1 n2 = n1^"."^n2 let normalize_name name = let (p,s) = cut name in let len = String.length s in let s = if len >= 2 && s.[0] = '(' && s.[len - 1] = ')' then parens_if_infix (strip_string (String.sub s 1 (len - 2))) else s in match p with "" -> s | p -> concat p s ;; let head_and_tail n = try let pos = String.index n '.' in if pos > 0 then let h = String.sub n 0 pos in try ignore (String.index h '('); (n, "") with Not_found -> let len = String.length n in if pos >= (len - 1) then (h, "") else (h, String.sub n (pos + 1) (len - pos - 1)) else (n, "") with Not_found -> (n, "") let head n = fst (head_and_tail n) let tail n = snd (head_and_tail n) let depth name = try List.length (Str.split (Str.regexp "\\.") name) with _ -> 1 let prefix n1 n2 = (n1 <> n2) & (try let len1 = String.length n1 in ((String.sub n2 0 len1) = n1) & (n2.[len1] = '.') with _ -> false) let rec get_relative_raw n1 n2 = let (f1,s1) = head_and_tail n1 in let (f2,s2) = head_and_tail n2 in if f1 = f2 then if f2 = s2 or s2 = "" then s2 else if f1 = s1 or s1 = "" then s2 else get_relative_raw s1 s2 else n2 let get_relative n1 n2 = if prefix n1 n2 then let len1 = String.length n1 in try String.sub n2 (len1+1) ((String.length n2) - len1 - 1) with _ -> n2 else n2 let hide_given_modules l s = let rec iter = function [] -> s | h :: q -> let s2 = get_relative h s in if s = s2 then iter q else s2 in iter l let qualified name = String.contains name '.' let from_ident ident = Ident.name ident let from_path path = Path.name path let to_path n = match List.fold_left (fun acc_opt -> fun s -> match acc_opt with None -> Some (Path.Pident (Ident.create s)) | Some acc -> Some (Path.Pdot (acc, s, 0))) None (Str.split (Str.regexp "\\.") n) with None -> raise (Failure "to_path") | Some p -> p let from_longident = Odoc_misc.string_of_longident module Set = Set.Make (struct type z = t type t = z let compare = String.compare end) mingw-ocaml/ocaml/ocamldoc/odoc_type.ml0000644000175000017500000000421712124403242017563 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Representation and manipulation of a type, but not class nor module type.*) module Name = Odoc_name type private_flag = Asttypes.private_flag = Private | Public (** Description of a variant type constructor. *) type variant_constructor = { vc_name : string ; vc_args : Types.type_expr list ; (** arguments of the constructor *) vc_ret : Types.type_expr option ; mutable vc_text : Odoc_types.text option ; (** optional user description *) } (** Description of a record type field. *) type record_field = { rf_name : string ; rf_mutable : bool ; (** true if mutable *) rf_type : Types.type_expr ; mutable rf_text : Odoc_types.text option ; (** optional user description *) } (** The various kinds of type. *) type type_kind = Type_abstract | Type_variant of variant_constructor list (** constructors *) | Type_record of record_field list (** fields *) (** Representation of a type. *) type t_type = { ty_name : Name.t ; mutable ty_info : Odoc_types.info option ; (** optional user information *) ty_parameters : (Types.type_expr * bool * bool) list ; (** type parameters: (type, covariant, contravariant) *) ty_kind : type_kind ; ty_private : private_flag; ty_manifest : Types.type_expr option; (** type manifest *) mutable ty_loc : Odoc_types.location ; mutable ty_code : string option; } mingw-ocaml/ocaml/ocamldoc/ocamldoc.hva0000644000175000017500000000275512124403242017532 0ustar tootstoots%(***********************************************************************) %(* OCamldoc *) %(* *) %(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) %(* *) %(* Copyright 2001 Institut National de Recherche en Informatique et *) %(* en Automatique. All rights reserved. This file is distributed *) %(* under the terms of the Q Public License version 1.0. *) %(* *) %(***********************************************************************) \usepackage{alltt} \newenvironment{ocamldoccode}{\begin{alltt}}{\end{alltt}} \newenvironment{ocamldocdescription}{\begin{quote}}{\end{quote}} \newenvironment{ocamldoccomment}{\begin{quote}}{\end{quote}} \newcommand\textbar{|} \newcommand\textbackslash{\begin{rawhtml}\\end{rawhtml}} \newcommand\textasciicircum{\^{}} \newcommand\sharp{#} \let\ocamldocvspace\vspace \newenvironment{ocamldocindent}{\list{}{}\item\relax}{\endlist} \newenvironment{ocamldocsigend} {\noindent\quad\texttt{sig}\ocamldocindent} {\endocamldocindent\vskip -\lastskip \noindent\quad\texttt{end}\medskip} \newenvironment{ocamldocobjectend} {\noindent\quad\texttt{object}\ocamldocindent} {\endocamldocindent\vskip -\lastskip \noindent\quad\texttt{end}\medskip} mingw-ocaml/ocaml/ocamldoc/odoc_gen.ml0000644000175000017500000000461112124403242017351 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Gallium, INRIA Rocquencourt *) (* *) (* Copyright 2010 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (** *) class type doc_generator = object method generate : Odoc_module.t_module list -> unit end;; module type Base = sig class generator : doc_generator end;; module Base_generator : Base = struct class generator : doc_generator = object method generate l = () end end;; module type Base_functor = functor (G: Base) -> Base module type Html_functor = functor (G: Odoc_html.Html_generator) -> Odoc_html.Html_generator module type Latex_functor = functor (G: Odoc_latex.Latex_generator) -> Odoc_latex.Latex_generator module type Texi_functor = functor (G: Odoc_texi.Texi_generator) -> Odoc_texi.Texi_generator module type Man_functor = functor (G: Odoc_man.Man_generator) -> Odoc_man.Man_generator module type Dot_functor = functor (G: Odoc_dot.Dot_generator) -> Odoc_dot.Dot_generator type generator = | Html of (module Odoc_html.Html_generator) | Latex of (module Odoc_latex.Latex_generator) | Texi of (module Odoc_texi.Texi_generator) | Man of (module Odoc_man.Man_generator) | Dot of (module Odoc_dot.Dot_generator) | Base of (module Base) ;; let get_minimal_generator = function Html m -> let module M = (val m : Odoc_html.Html_generator) in (new M.html :> doc_generator) | Latex m -> let module M = (val m : Odoc_latex.Latex_generator) in (new M.latex :> doc_generator) | Man m -> let module M = (val m : Odoc_man.Man_generator) in (new M.man :> doc_generator) | Texi m -> let module M = (val m : Odoc_texi.Texi_generator) in (new M.texi :> doc_generator) | Dot m -> let module M = (val m : Odoc_dot.Dot_generator) in (new M.dot :> doc_generator) | Base m -> let module M = (val m : Base) in new M.generator ;; mingw-ocaml/ocaml/ocamldoc/odoc_lexer.mll0000644000175000017500000002645012124403242020100 0ustar tootstoots{ (***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** The lexer for special comments. *) open Lexing open Odoc_parser let line_number = ref 0 let string_buffer = Buffer.create 32 (** Fonction de remise a zero de la chaine de caracteres tampon *) let reset_string_buffer () = Buffer.reset string_buffer (** Fonction d'ajout d'un caractere dans la chaine de caracteres tampon *) let ajout_char_string = Buffer.add_char string_buffer (** Add a string to the buffer. *) let ajout_string = Buffer.add_string string_buffer let lecture_string () = Buffer.contents string_buffer (** The variable which will contain the description string. Is initialized when we encounter the start of a special comment. *) let description = ref "" let blank = "[ \013\009\012]" (** The nested comments level. *) let comments_level = ref 0 let print_DEBUG2 s = print_string s; print_newline () (** This function returns the given string without the leading and trailing blanks.*) let remove_blanks s = print_DEBUG2 ("remove_blanks "^s); let l = Str.split_delim (Str.regexp "\n") s in let l2 = let rec iter liste = match liste with h :: q -> let h2 = Str.global_replace (Str.regexp ("^"^blank^"+")) "" h in if h2 = "" then ( print_DEBUG2 (h^" n'a que des blancs"); (* we remove this line and must remove leading blanks of the next one *) iter q ) else (* we don't remove leading blanks in the remaining lines *) h2 :: q | _ -> [] in iter l in let l3 = let rec iter liste = match liste with h :: q -> let h2 = Str.global_replace (Str.regexp (blank^"+$")) "" h in if h2 = "" then ( print_DEBUG2 (h^" n'a que des blancs"); (* we remove this line and must remove trailing blanks of the next one *) iter q ) else (* we don't remove trailing blanks in the remaining lines *) h2 :: q | _ -> [] in List.rev (iter (List.rev l2)) in String.concat "\n" l3 (** Remove first blank characters of each line of a string, until the first '*' *) let remove_stars s = let s2 = Str.global_replace (Str.regexp ("^"^blank^"*\\*")) "" s in s2 } let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] let identchar = ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] rule main = parse [' ' '\013' '\009' '\012'] + { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); main lexbuf } | [ '\010' ] { incr line_number; incr Odoc_comments_global.nb_chars; main lexbuf } | "(**)" { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); Description ("", None) } | "(**"("*"+)")" { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); main lexbuf } | "(***" { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); incr comments_level; main lexbuf } | "(**" { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); incr comments_level; if !comments_level = 1 then ( reset_string_buffer (); description := ""; special_comment lexbuf ) else main lexbuf } | eof { EOF } | "*)" { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); decr comments_level ; main lexbuf } | "(*" { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); incr comments_level ; main lexbuf } | _ { incr Odoc_comments_global.nb_chars; main lexbuf } and special_comment = parse | "*)" { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); if !comments_level = 1 then ( (* there is just a description *) let s2 = lecture_string () in let s3 = remove_blanks s2 in let s4 = if !Odoc_global.remove_stars then remove_stars s3 else s3 in Description (s4, None) ) else ( ajout_string s; decr comments_level; special_comment lexbuf ) } | "(*" { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); incr comments_level ; ajout_string s; special_comment lexbuf } | "\\@" { let s = Lexing.lexeme lexbuf in let c = (Lexing.lexeme_char lexbuf 1) in ajout_char_string c; Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); special_comment lexbuf } | "@"lowercase+ { (* we keep the description before we go further *) let s = lecture_string () in description := remove_blanks s; reset_string_buffer (); let len = String.length (Lexing.lexeme lexbuf) in lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - len; lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - len } ; (* we don't increment the Odoc_comments_global.nb_chars *) special_comment_part2 lexbuf } | _ { let c = (Lexing.lexeme_char lexbuf 0) in ajout_char_string c; if c = '\010' then incr line_number; incr Odoc_comments_global.nb_chars; special_comment lexbuf } and special_comment_part2 = parse | "*)" { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); if !comments_level = 1 then (* finally we return the description we kept *) let desc = if !Odoc_global.remove_stars then remove_stars !description else !description in let remain = lecture_string () in let remain2 = if !Odoc_global.remove_stars then remove_stars remain else remain in Description (desc, Some remain2) else ( ajout_string s ; decr comments_level ; special_comment_part2 lexbuf ) } | "(*" { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); ajout_string s; incr comments_level ; special_comment_part2 lexbuf } | _ { let c = (Lexing.lexeme_char lexbuf 0) in ajout_char_string c; if c = '\010' then incr line_number; incr Odoc_comments_global.nb_chars; special_comment_part2 lexbuf } and elements = parse | [' ' '\013' '\009' '\012'] + { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); elements lexbuf } | [ '\010' ] { incr line_number; incr Odoc_comments_global.nb_chars; print_DEBUG2 "newline"; elements lexbuf } | "@"lowercase+ { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); let s2 = String.sub s 1 ((String.length s) - 1) in print_DEBUG2 s2; match s2 with "param" -> T_PARAM | "author" -> T_AUTHOR | "version" -> T_VERSION | "see" -> T_SEE | "since" -> T_SINCE | "before" -> T_BEFORE | "deprecated" -> T_DEPRECATED | "raise" -> T_RAISES | "return" -> T_RETURN | s -> if !Odoc_global.no_custom_tags then raise (Failure (Odoc_messages.not_a_valid_tag s)) else T_CUSTOM s } | ("\\@" | [^'@'])+ { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); let s = Lexing.lexeme lexbuf in let s = Str.global_replace (Str.regexp_string "\\@") "@" s in let s = remove_blanks s in print_DEBUG2 ("Desc "^s); Desc s } | eof { EOF } and simple = parse [' ' '\013' '\009' '\012'] + { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); simple lexbuf } | [ '\010' ] { incr line_number; incr Odoc_comments_global.nb_chars; simple lexbuf } | "(**"("*"+) { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); incr comments_level; simple lexbuf } | "(*"("*"+)")" { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); simple lexbuf } | "(**" { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); incr comments_level; simple lexbuf } | "(*" { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); incr comments_level; if !comments_level = 1 then ( reset_string_buffer (); description := ""; special_comment lexbuf ) else ( ajout_string s; simple lexbuf ) } | eof { EOF } | "*)" { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); decr comments_level ; simple lexbuf } | _ { incr Odoc_comments_global.nb_chars; simple lexbuf } mingw-ocaml/ocaml/ocamldoc/odoc_info.ml0000644000175000017500000002072112124403242017533 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Interface for analysing documented OCaml source files and to the collected information. *) type ref_kind = Odoc_types.ref_kind = RK_module | RK_module_type | RK_class | RK_class_type | RK_value | RK_type | RK_exception | RK_attribute | RK_method | RK_section of text | RK_recfield | RK_const and text_element = Odoc_types.text_element = | Raw of string | Code of string | CodePre of string | Verbatim of string | Bold of text | Italic of text | Emphasize of text | Center of text | Left of text | Right of text | List of text list | Enum of text list | Newline | Block of text | Title of int * string option * text | Latex of string | Link of string * text | Ref of string * ref_kind option * text option | Superscript of text | Subscript of text | Module_list of string list | Index_list | Custom of string * text | Target of string * string and text = text_element list exception Text_syntax = Odoc_text.Text_syntax type see_ref = Odoc_types.see_ref = See_url of string | See_file of string | See_doc of string type see = see_ref * text type param = (string * text) type raised_exception = (string * text) type info = Odoc_types.info = { i_desc : text option; i_authors : string list; i_version : string option; i_sees : see list; i_since : string option; i_before : (string * text) list ; i_deprecated : text option; i_params : param list; i_raised_exceptions : raised_exception list; i_return_value : text option ; i_custom : (string * text) list ; } type location = Odoc_types.location = { loc_impl : Location.t option ; loc_inter : Location.t option ; } let dummy_loc = { loc_impl = None ; loc_inter = None } module Name = Odoc_name module Parameter = Odoc_parameter module Exception = Odoc_exception module Type = Odoc_type module Value = Odoc_value module Class = Odoc_class module Module = Odoc_module let analyse_files ?(merge_options=([] : Odoc_types.merge_option list)) ?(include_dirs=([] : string list)) ?(labels=false) ?(sort_modules=false) ?(no_stop=false) ?(init=[]) files = Odoc_global.merge_options := merge_options; Odoc_global.include_dirs := include_dirs; Odoc_global.classic := not labels; Odoc_global.sort_modules := sort_modules; Odoc_global.no_stop := no_stop; Odoc_analyse.analyse_files ~init: init files let dump_modules = Odoc_analyse.dump_modules let load_modules = Odoc_analyse.load_modules let reset_type_names = Printtyp.reset let string_of_variance t (co,cn) = Odoc_str.string_of_variance t (co, cn) let string_of_type_expr t = Odoc_print.string_of_type_expr t let string_of_class_params = Odoc_str.string_of_class_params let string_of_type_list ?par sep type_list = Odoc_str.string_of_type_list ?par sep type_list let string_of_type_param_list t = Odoc_str.string_of_type_param_list t let string_of_class_type_param_list l = Odoc_str.string_of_class_type_param_list l let string_of_module_type = Odoc_print.string_of_module_type let string_of_class_type = Odoc_print.string_of_class_type let string_of_text t = Odoc_misc.string_of_text t let string_of_info i = Odoc_misc.string_of_info i let string_of_type t = Odoc_str.string_of_type t let string_of_exception e = Odoc_str.string_of_exception e let string_of_value v = Odoc_str.string_of_value v let string_of_attribute att = Odoc_str.string_of_attribute att let string_of_method m = Odoc_str.string_of_method m let first_sentence_of_text = Odoc_misc.first_sentence_of_text let first_sentence_and_rest_of_text = Odoc_misc.first_sentence_and_rest_of_text let text_no_title_no_list = Odoc_misc.text_no_title_no_list let text_concat = Odoc_misc.text_concat let get_titles_in_text = Odoc_misc.get_titles_in_text let create_index_lists = Odoc_misc.create_index_lists let remove_ending_newline = Odoc_misc.remove_ending_newline let remove_option = Odoc_misc.remove_option let is_optional = Odoc_misc.is_optional let label_name = Odoc_misc.label_name let use_hidden_modules n = Odoc_name.hide_given_modules !Odoc_global.hidden_modules n let verbose s = if !Odoc_global.verbose then (print_string s ; print_newline ()) else () let warning s = Odoc_global.pwarning s let print_warnings = Odoc_config.print_warnings let errors = Odoc_global.errors let apply_opt = Odoc_misc.apply_opt let apply_if_equal f v1 v2 = if v1 = v2 then f v1 else v2 let text_of_string = Odoc_text.Texter.text_of_string let text_string_of_text = Odoc_text.Texter.string_of_text let escape_arobas s = let len = String.length s in let b = Buffer.create len in for i = 0 to len - 1 do match s.[i] with '@' -> Buffer.add_string b "\\@" | c -> Buffer.add_char b c done; Buffer.contents b let info_string_of_info i = let b = Buffer.create 256 in let p = Printf.bprintf in ( match i.i_desc with None -> () | Some t -> p b "%s" (escape_arobas (text_string_of_text t)) ); List.iter (fun s -> p b "\n@@author %s" (escape_arobas s)) i.i_authors; ( match i.i_version with None -> () | Some s -> p b "\n@@version %s" (escape_arobas s) ); ( (* TODO: escape characters ? *) let f_see_ref = function See_url s -> Printf.sprintf "<%s>" s | See_file s -> Printf.sprintf "'%s'" s | See_doc s -> Printf.sprintf "\"%s\"" s in List.iter (fun (sref, t) -> p b "\n@@see %s %s" (escape_arobas (f_see_ref sref)) (escape_arobas (text_string_of_text t)) ) i.i_sees ); ( match i.i_since with None -> () | Some s -> p b "\n@@since %s" (escape_arobas s) ); ( match i.i_deprecated with None -> () | Some t -> p b "\n@@deprecated %s" (escape_arobas (text_string_of_text t)) ); List.iter (fun (s, t) -> p b "\n@@param %s %s" (escape_arobas s) (escape_arobas (text_string_of_text t)) ) i.i_params; List.iter (fun (s, t) -> p b "\n@@raise %s %s" (escape_arobas s) (escape_arobas (text_string_of_text t)) ) i.i_raised_exceptions; ( match i.i_return_value with None -> () | Some t -> p b "\n@@return %s" (escape_arobas (text_string_of_text t)) ); List.iter (fun (s, t) -> p b "\n@@%s %s" s (escape_arobas (text_string_of_text t)) ) i.i_custom; Buffer.contents b let info_of_string = Odoc_comments.info_of_string let info_of_comment_file = Odoc_comments.info_of_comment_file module Search = struct type result_element = Odoc_search.result_element = Res_module of Module.t_module | Res_module_type of Module.t_module_type | Res_class of Class.t_class | Res_class_type of Class.t_class_type | Res_value of Value.t_value | Res_type of Type.t_type | Res_exception of Exception.t_exception | Res_attribute of Value.t_attribute | Res_method of Value.t_method | Res_section of string * text | Res_recfield of Type.t_type * Type.record_field | Res_const of Type.t_type * Type.variant_constructor type search_result = result_element list let search_by_name = Odoc_search.Search_by_name.search let values = Odoc_search.values let exceptions = Odoc_search.exceptions let types = Odoc_search.types let attributes = Odoc_search.attributes let methods = Odoc_search.methods let classes = Odoc_search.classes let class_types = Odoc_search.class_types let modules = Odoc_search.modules let module_types = Odoc_search.module_types end module Scan = struct class scanner = Odoc_scan.scanner end module Dep = struct let kernel_deps_of_modules = Odoc_dep.kernel_deps_of_modules let deps_of_types = Odoc_dep.deps_of_types end module Global = Odoc_global mingw-ocaml/ocaml/ocamldoc/.depend0000644000175000017500000003506612124403242016512 0ustar tootstootsodoc.cmo : ../typing/typedtree.cmi odoc_messages.cmo odoc_info.cmi \ odoc_global.cmi odoc_gen.cmi odoc_config.cmi odoc_args.cmi \ odoc_analyse.cmi ../utils/misc.cmi ../utils/config.cmi \ ../utils/clflags.cmi odoc.cmx : ../typing/typedtree.cmx odoc_messages.cmx odoc_info.cmx \ odoc_global.cmx odoc_gen.cmx odoc_config.cmx odoc_args.cmx \ odoc_analyse.cmx ../utils/misc.cmx ../utils/config.cmx \ ../utils/clflags.cmx odoc_analyse.cmo : ../utils/warnings.cmi ../typing/typetexp.cmi \ ../typing/types.cmi ../typing/typemod.cmi ../typing/typedtree.cmi \ ../typing/typedecl.cmi ../typing/typecore.cmi ../typing/typeclass.cmi \ ../bytecomp/translcore.cmi ../bytecomp/translclass.cmi \ ../parsing/syntaxerr.cmi ../parsing/parse.cmi odoc_types.cmi \ odoc_text.cmi odoc_sig.cmi odoc_module.cmo odoc_misc.cmi \ odoc_messages.cmo odoc_merge.cmi odoc_global.cmi odoc_dep.cmo \ odoc_cross.cmi odoc_comments.cmi odoc_class.cmo odoc_ast.cmi \ ../utils/misc.cmi ../parsing/location.cmi ../parsing/lexer.cmi \ ../typing/includemod.cmi ../typing/env.cmi ../typing/ctype.cmi \ ../utils/config.cmi ../typing/cmi_format.cmi ../utils/clflags.cmi \ ../utils/ccomp.cmi odoc_analyse.cmi odoc_analyse.cmx : ../utils/warnings.cmx ../typing/typetexp.cmx \ ../typing/types.cmx ../typing/typemod.cmx ../typing/typedtree.cmx \ ../typing/typedecl.cmx ../typing/typecore.cmx ../typing/typeclass.cmx \ ../bytecomp/translcore.cmx ../bytecomp/translclass.cmx \ ../parsing/syntaxerr.cmx ../parsing/parse.cmx odoc_types.cmx \ odoc_text.cmx odoc_sig.cmx odoc_module.cmx odoc_misc.cmx \ odoc_messages.cmx odoc_merge.cmx odoc_global.cmx odoc_dep.cmx \ odoc_cross.cmx odoc_comments.cmx odoc_class.cmx odoc_ast.cmx \ ../utils/misc.cmx ../parsing/location.cmx ../parsing/lexer.cmx \ ../typing/includemod.cmx ../typing/env.cmx ../typing/ctype.cmx \ ../utils/config.cmx ../typing/cmi_format.cmx ../utils/clflags.cmx \ ../utils/ccomp.cmx odoc_analyse.cmi odoc_args.cmo : odoc_types.cmi odoc_texi.cmo odoc_messages.cmo odoc_man.cmo \ odoc_latex.cmo odoc_html.cmo odoc_global.cmi odoc_gen.cmi odoc_dot.cmo \ odoc_config.cmi ../utils/misc.cmi ../utils/config.cmi odoc_args.cmi odoc_args.cmx : odoc_types.cmx odoc_texi.cmx odoc_messages.cmx odoc_man.cmx \ odoc_latex.cmx odoc_html.cmx odoc_global.cmx odoc_gen.cmx odoc_dot.cmx \ odoc_config.cmx ../utils/misc.cmx ../utils/config.cmx odoc_args.cmi odoc_ast.cmo : ../typing/types.cmi ../typing/typedtree.cmi \ ../typing/predef.cmi ../typing/path.cmi ../parsing/parsetree.cmi \ odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_sig.cmi \ odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \ odoc_global.cmi odoc_exception.cmo odoc_env.cmi odoc_class.cmo \ ../utils/misc.cmi ../parsing/location.cmi ../typing/ident.cmi \ ../parsing/asttypes.cmi odoc_ast.cmi odoc_ast.cmx : ../typing/types.cmx ../typing/typedtree.cmx \ ../typing/predef.cmx ../typing/path.cmx ../parsing/parsetree.cmi \ odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_sig.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \ odoc_global.cmx odoc_exception.cmx odoc_env.cmx odoc_class.cmx \ ../utils/misc.cmx ../parsing/location.cmx ../typing/ident.cmx \ ../parsing/asttypes.cmi odoc_ast.cmi odoc_class.cmo : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_parameter.cmo odoc_name.cmi odoc_class.cmx : ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_comments.cmo : odoc_types.cmi odoc_text.cmi odoc_see_lexer.cmo \ odoc_parser.cmi odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi \ odoc_lexer.cmo odoc_global.cmi odoc_cross.cmi odoc_comments_global.cmi \ odoc_comments.cmi odoc_comments.cmx : odoc_types.cmx odoc_text.cmx odoc_see_lexer.cmx \ odoc_parser.cmx odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx \ odoc_lexer.cmx odoc_global.cmx odoc_cross.cmx odoc_comments_global.cmx \ odoc_comments.cmi odoc_comments_global.cmo : odoc_comments_global.cmi odoc_comments_global.cmx : odoc_comments_global.cmi odoc_config.cmo : ../utils/config.cmi odoc_config.cmi odoc_config.cmx : ../utils/config.cmx odoc_config.cmi odoc_control.cmo : odoc_control.cmx : odoc_cross.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_search.cmi \ odoc_scan.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ odoc_misc.cmi odoc_messages.cmo odoc_global.cmi odoc_exception.cmo \ odoc_class.cmo odoc_cross.cmi odoc_cross.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_search.cmx \ odoc_scan.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ odoc_misc.cmx odoc_messages.cmx odoc_global.cmx odoc_exception.cmx \ odoc_class.cmx odoc_cross.cmi odoc_dag2html.cmo : odoc_info.cmi odoc_dag2html.cmi odoc_dag2html.cmx : odoc_info.cmx odoc_dag2html.cmi odoc_dep.cmo : ../parsing/parsetree.cmi odoc_type.cmo odoc_print.cmi \ odoc_module.cmo ../tools/depend.cmi odoc_dep.cmx : ../parsing/parsetree.cmi odoc_type.cmx odoc_print.cmx \ odoc_module.cmx ../tools/depend.cmx odoc_dot.cmo : odoc_messages.cmo odoc_info.cmi odoc_dot.cmx : odoc_messages.cmx odoc_info.cmx odoc_env.cmo : ../typing/types.cmi ../typing/printtyp.cmi \ ../typing/predef.cmi ../typing/path.cmi odoc_name.cmi ../typing/btype.cmi \ odoc_env.cmi odoc_env.cmx : ../typing/types.cmx ../typing/printtyp.cmx \ ../typing/predef.cmx ../typing/path.cmx odoc_name.cmx ../typing/btype.cmx \ odoc_env.cmi odoc_exception.cmo : ../typing/types.cmi odoc_types.cmi odoc_name.cmi odoc_exception.cmx : ../typing/types.cmx odoc_types.cmx odoc_name.cmx odoc_gen.cmo : odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \ odoc_html.cmo odoc_dot.cmo odoc_gen.cmi odoc_gen.cmx : odoc_texi.cmx odoc_module.cmx odoc_man.cmx odoc_latex.cmx \ odoc_html.cmx odoc_dot.cmx odoc_gen.cmi odoc_global.cmo : odoc_types.cmi odoc_messages.cmo odoc_config.cmi \ ../utils/clflags.cmi odoc_global.cmi odoc_global.cmx : odoc_types.cmx odoc_messages.cmx odoc_config.cmx \ ../utils/clflags.cmx odoc_global.cmi odoc_html.cmo : odoc_text.cmi odoc_ocamlhtml.cmo odoc_messages.cmo \ odoc_info.cmi odoc_global.cmi odoc_dag2html.cmi ../parsing/asttypes.cmi odoc_html.cmx : odoc_text.cmx odoc_ocamlhtml.cmx odoc_messages.cmx \ odoc_info.cmx odoc_global.cmx odoc_dag2html.cmx ../parsing/asttypes.cmi odoc_info.cmo : ../typing/printtyp.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_text.cmi odoc_str.cmi odoc_search.cmi odoc_scan.cmo \ odoc_print.cmi odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ odoc_misc.cmi odoc_global.cmi odoc_exception.cmo odoc_dep.cmo \ odoc_config.cmi odoc_comments.cmi odoc_class.cmo odoc_analyse.cmi \ ../parsing/location.cmi odoc_info.cmi odoc_info.cmx : ../typing/printtyp.cmx odoc_value.cmx odoc_types.cmx \ odoc_type.cmx odoc_text.cmx odoc_str.cmx odoc_search.cmx odoc_scan.cmx \ odoc_print.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ odoc_misc.cmx odoc_global.cmx odoc_exception.cmx odoc_dep.cmx \ odoc_config.cmx odoc_comments.cmx odoc_class.cmx odoc_analyse.cmx \ ../parsing/location.cmx odoc_info.cmi odoc_inherit.cmo : odoc_inherit.cmx : odoc_latex.cmo : odoc_to_text.cmo odoc_messages.cmo odoc_latex_style.cmo \ odoc_info.cmi ../parsing/asttypes.cmi odoc_latex.cmx : odoc_to_text.cmx odoc_messages.cmx odoc_latex_style.cmx \ odoc_info.cmx ../parsing/asttypes.cmi odoc_latex_style.cmo : odoc_latex_style.cmx : odoc_lexer.cmo : odoc_parser.cmi odoc_messages.cmo odoc_global.cmi \ odoc_comments_global.cmi odoc_lexer.cmx : odoc_parser.cmx odoc_messages.cmx odoc_global.cmx \ odoc_comments_global.cmx odoc_man.cmo : odoc_str.cmi odoc_print.cmi odoc_misc.cmi odoc_messages.cmo \ odoc_info.cmi ../parsing/asttypes.cmi odoc_man.cmx : odoc_str.cmx odoc_print.cmx odoc_misc.cmx odoc_messages.cmx \ odoc_info.cmx ../parsing/asttypes.cmi odoc_merge.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo \ odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \ odoc_global.cmi odoc_exception.cmo odoc_class.cmo odoc_merge.cmi odoc_merge.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \ odoc_global.cmx odoc_exception.cmx odoc_class.cmx odoc_merge.cmi odoc_messages.cmo : ../utils/config.cmi odoc_messages.cmx : ../utils/config.cmx odoc_misc.cmo : ../typing/types.cmi ../typing/predef.cmi ../typing/path.cmi \ odoc_types.cmi odoc_messages.cmo ../parsing/longident.cmi \ ../typing/ctype.cmi ../typing/btype.cmi odoc_misc.cmi odoc_misc.cmx : ../typing/types.cmx ../typing/predef.cmx ../typing/path.cmx \ odoc_types.cmx odoc_messages.cmx ../parsing/longident.cmx \ ../typing/ctype.cmx ../typing/btype.cmx odoc_misc.cmi odoc_module.cmo : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_name.cmi odoc_exception.cmo odoc_class.cmo odoc_module.cmx : ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ odoc_type.cmx odoc_name.cmx odoc_exception.cmx odoc_class.cmx odoc_name.cmo : ../typing/path.cmi odoc_misc.cmi ../typing/ident.cmi \ odoc_name.cmi odoc_name.cmx : ../typing/path.cmx odoc_misc.cmx ../typing/ident.cmx \ odoc_name.cmi odoc_ocamlhtml.cmo : odoc_ocamlhtml.cmx : odoc_parameter.cmo : ../typing/types.cmi odoc_types.cmi odoc_parameter.cmx : ../typing/types.cmx odoc_types.cmx odoc_parser.cmo : odoc_types.cmi odoc_comments_global.cmi odoc_parser.cmi odoc_parser.cmx : odoc_types.cmx odoc_comments_global.cmx odoc_parser.cmi odoc_print.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_print.cmi odoc_print.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_print.cmi odoc_scan.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_module.cmo \ odoc_exception.cmo odoc_class.cmo odoc_scan.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_module.cmx \ odoc_exception.cmx odoc_class.cmx odoc_search.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo \ odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_exception.cmo \ odoc_class.cmo odoc_search.cmi odoc_search.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_exception.cmx \ odoc_class.cmx odoc_search.cmi odoc_see_lexer.cmo : odoc_parser.cmi odoc_see_lexer.cmx : odoc_parser.cmx odoc_sig.cmo : ../typing/types.cmi ../typing/typedtree.cmi \ ../typing/path.cmi ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi odoc_global.cmi \ odoc_exception.cmo odoc_env.cmi odoc_class.cmo ../utils/misc.cmi \ ../parsing/location.cmi ../typing/ident.cmi ../typing/btype.cmi \ ../parsing/asttypes.cmi odoc_sig.cmi odoc_sig.cmx : ../typing/types.cmx ../typing/typedtree.cmx \ ../typing/path.cmx ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx \ odoc_type.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx odoc_global.cmx \ odoc_exception.cmx odoc_env.cmx odoc_class.cmx ../utils/misc.cmx \ ../parsing/location.cmx ../typing/ident.cmx ../typing/btype.cmx \ ../parsing/asttypes.cmi odoc_sig.cmi odoc_str.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_value.cmo \ odoc_type.cmo odoc_print.cmi odoc_name.cmi odoc_misc.cmi \ odoc_messages.cmo odoc_exception.cmo odoc_class.cmo \ ../parsing/asttypes.cmi odoc_str.cmi odoc_str.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_value.cmx \ odoc_type.cmx odoc_print.cmx odoc_name.cmx odoc_misc.cmx \ odoc_messages.cmx odoc_exception.cmx odoc_class.cmx \ ../parsing/asttypes.cmi odoc_str.cmi odoc_test.cmo : odoc_info.cmi odoc_gen.cmi odoc_args.cmi odoc_test.cmx : odoc_info.cmx odoc_gen.cmx odoc_args.cmx odoc_texi.cmo : ../typing/types.cmi odoc_to_text.cmo odoc_messages.cmo \ odoc_info.cmi ../parsing/asttypes.cmi odoc_texi.cmx : ../typing/types.cmx odoc_to_text.cmx odoc_messages.cmx \ odoc_info.cmx ../parsing/asttypes.cmi odoc_text.cmo : odoc_types.cmi odoc_text_parser.cmi odoc_text_lexer.cmo \ odoc_text.cmi odoc_text.cmx : odoc_types.cmx odoc_text_parser.cmx odoc_text_lexer.cmx \ odoc_text.cmi odoc_text_lexer.cmo : odoc_text_parser.cmi odoc_misc.cmi odoc_text_lexer.cmx : odoc_text_parser.cmx odoc_misc.cmx odoc_text_parser.cmo : odoc_types.cmi odoc_misc.cmi odoc_text_parser.cmi odoc_text_parser.cmx : odoc_types.cmx odoc_misc.cmx odoc_text_parser.cmi odoc_to_text.cmo : odoc_module.cmo odoc_messages.cmo odoc_info.cmi odoc_to_text.cmx : odoc_module.cmx odoc_messages.cmx odoc_info.cmx odoc_type.cmo : ../typing/types.cmi odoc_types.cmi odoc_name.cmi \ ../parsing/asttypes.cmi odoc_type.cmx : ../typing/types.cmx odoc_types.cmx odoc_name.cmx \ ../parsing/asttypes.cmi odoc_types.cmo : odoc_messages.cmo ../parsing/location.cmi odoc_types.cmi odoc_types.cmx : odoc_messages.cmx ../parsing/location.cmx odoc_types.cmi odoc_value.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_types.cmi \ odoc_parameter.cmo odoc_name.cmi odoc_value.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_types.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_analyse.cmi : odoc_module.cmo odoc_global.cmi odoc_args.cmi : odoc_gen.cmi odoc_ast.cmi : ../typing/types.cmi ../typing/typedtree.cmi \ ../typing/path.cmi ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi \ odoc_module.cmo odoc_comments.cmi : odoc_types.cmi odoc_module.cmo odoc_comments_global.cmi : odoc_config.cmi : odoc_cross.cmi : odoc_types.cmi odoc_module.cmo odoc_dag2html.cmi : odoc_info.cmi odoc_env.cmi : ../typing/types.cmi odoc_name.cmi odoc_gen.cmi : odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \ odoc_html.cmo odoc_dot.cmo odoc_global.cmi : odoc_types.cmi odoc_info.cmi : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_search.cmi odoc_parameter.cmo odoc_module.cmo \ odoc_global.cmi odoc_exception.cmo odoc_class.cmo ../parsing/location.cmi odoc_merge.cmi : odoc_types.cmi odoc_module.cmo odoc_misc.cmi : ../typing/types.cmi odoc_types.cmi ../parsing/longident.cmi odoc_name.cmi : ../typing/path.cmi ../parsing/longident.cmi \ ../typing/ident.cmi odoc_parser.cmi : odoc_types.cmi odoc_print.cmi : ../typing/types.cmi odoc_search.cmi : odoc_value.cmo odoc_types.cmi odoc_type.cmo \ odoc_module.cmo odoc_exception.cmo odoc_class.cmo odoc_sig.cmi : ../typing/types.cmi ../parsing/parsetree.cmi odoc_types.cmi \ odoc_type.cmo odoc_name.cmi odoc_module.cmo odoc_env.cmi odoc_class.cmo odoc_str.cmi : ../typing/types.cmi odoc_value.cmo odoc_type.cmo \ odoc_exception.cmo odoc_class.cmo odoc_text.cmi : odoc_types.cmi odoc_text_parser.cmi : odoc_types.cmi odoc_types.cmi : ../parsing/location.cmi mingw-ocaml/ocaml/ocamldoc/odoc_cross.mli0000644000175000017500000000165512124403242020107 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Cross-referencing. *) val associate : Odoc_module.t_module list -> unit val assoc_comments_info : string -> Odoc_module.t_module list -> Odoc_types.info -> Odoc_types.info mingw-ocaml/ocaml/ocamldoc/odoc_comments.ml0000644000175000017500000003135512124403242020432 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Analysis of comments. *) open Odoc_types let print_DEBUG s = print_string s ; print_newline ();; (** This variable contains the regular expression representing a blank but not a '\n'.*) let simple_blank = "[ \013\009\012]" module type Texter = sig (** Return a text structure from a string. *) val text_of_string : string -> text end module Info_retriever = functor (MyTexter : Texter) -> struct let create_see s = try let lexbuf = Lexing.from_string s in let (see_ref, s) = Odoc_parser.see_info Odoc_see_lexer.main lexbuf in (see_ref, MyTexter.text_of_string s) with | Odoc_text.Text_syntax (l, c, s) -> raise (Failure (Odoc_messages.text_parse_error l c s)) | _ -> raise (Failure ("Unknown error while parsing @see tag: "^s)) let retrieve_info fun_lex file (s : string) = try let _ = Odoc_comments_global.init () in Odoc_lexer.comments_level := 0; let lexbuf = Lexing.from_string s in match Odoc_parser.main fun_lex lexbuf with None -> (0, None) | Some (desc, remain_opt) -> let mem_nb_chars = !Odoc_comments_global.nb_chars in let _ = match remain_opt with None -> () | Some s -> (*DEBUG*)print_string ("remain: "^s); print_newline(); let lexbuf2 = Lexing.from_string s in Odoc_parser.info_part2 Odoc_lexer.elements lexbuf2 in (mem_nb_chars, Some { i_desc = (match desc with "" -> None | _ -> Some (MyTexter.text_of_string desc)); i_authors = !Odoc_comments_global.authors; i_version = !Odoc_comments_global.version; i_sees = (List.map create_see !Odoc_comments_global.sees) ; i_since = !Odoc_comments_global.since; i_before = Odoc_merge.merge_before_tags (List.map (fun (n, s) -> (n, MyTexter.text_of_string s)) !Odoc_comments_global.before) ; i_deprecated = (match !Odoc_comments_global.deprecated with None -> None | Some s -> Some (MyTexter.text_of_string s)); i_params = (List.map (fun (n, s) -> (n, MyTexter.text_of_string s)) !Odoc_comments_global.params); i_raised_exceptions = (List.map (fun (n, s) -> (n, MyTexter.text_of_string s)) !Odoc_comments_global.raised_exceptions); i_return_value = (match !Odoc_comments_global.return_value with None -> None | Some s -> Some (MyTexter.text_of_string s)) ; i_custom = (List.map (fun (tag, s) -> (tag, MyTexter.text_of_string s)) !Odoc_comments_global.customs) } ) with Failure s -> incr Odoc_global.errors ; prerr_endline (file^" : "^s^"\n"); (0, None) | Odoc_text.Text_syntax (l, c, s) -> incr Odoc_global.errors ; prerr_endline (file^" : "^(Odoc_messages.text_parse_error l c s)); (0, None) | _ -> incr Odoc_global.errors ; prerr_endline (file^" : "^Odoc_messages.parse_error^"\n"); (0, None) (** This function takes a string where a simple comment may has been found. It returns false if there is a blank line or the first comment is a special one, or if there is no comment if the string.*) let nothing_before_simple_comment s = (* get the position of the first "(*" *) try print_DEBUG ("comment_is_attached: "^s); let pos = Str.search_forward (Str.regexp "(\\*") s 0 in let next_char = if (String.length s) >= (pos + 1) then s.[pos + 2] else '_' in (next_char <> '*') && ( (* there is no special comment between the constructor and the coment we got *) let s2 = String.sub s 0 pos in print_DEBUG ("s2="^s2); try let _ = Str.search_forward (Str.regexp ("['\n']"^simple_blank^"*['\n']")) s2 0 in (* a blank line was before the comment *) false with Not_found -> true ) with Not_found -> false (** Return true if the given string contains a blank line. *) let blank_line s = try let _ = Str.search_forward (Str.regexp ("['\n']"^simple_blank^"*['\n']")) s 0 in (* a blank line was before the comment *) true with Not_found -> false let retrieve_info_special file (s : string) = retrieve_info Odoc_lexer.main file s let retrieve_info_simple file (s : string) = let _ = Odoc_comments_global.init () in Odoc_lexer.comments_level := 0; let lexbuf = Lexing.from_string s in match Odoc_parser.main Odoc_lexer.simple lexbuf with None -> (0, None) | Some (desc, remain_opt) -> (!Odoc_comments_global.nb_chars, Some Odoc_types.dummy_info) (** Return true if the given string contains a blank line outside a simple comment. *) let blank_line_outside_simple file s = let rec iter s2 = match retrieve_info_simple file s2 with (_, None) -> blank_line s2 | (len, Some _) -> try let pos = Str.search_forward (Str.regexp_string "(*") s2 0 in let s_before = String.sub s2 0 pos in let s_after = String.sub s2 len ((String.length s2) - len) in (blank_line s_before) || (iter s_after) with Not_found -> (* we shouldn't get here *) false in iter s (** This function returns the first simple comment in the given string. If strict is [true] then no comment is returned if a blank line or a special comment is found before the simple comment. *) let retrieve_first_info_simple ?(strict=true) file (s : string) = match retrieve_info_simple file s with (_, None) -> (0, None) | (len, Some d) -> (* we check if the comment we got was really attached to the constructor, i.e. that there was no blank line or any special comment "(**" before *) if (not strict) or (nothing_before_simple_comment s) then (* ok, we attach the comment to the constructor *) (len, Some d) else (* a blank line or special comment was before the comment, so we must not attach this comment to the constructor. *) (0, None) let retrieve_last_info_simple file (s : string) = print_DEBUG ("retrieve_last_info_simple:"^s); let rec f cur_len cur_d = try let s2 = String.sub s cur_len ((String.length s) - cur_len) in print_DEBUG ("retrieve_last_info_simple.f:"^s2); match retrieve_info_simple file s2 with (len, None) -> print_DEBUG "retrieve_last_info_simple: None"; (cur_len + len, cur_d) | (len, Some d) -> print_DEBUG "retrieve_last_info_simple: Some"; f (len + cur_len) (Some d) with _ -> print_DEBUG "retrieve_last_info_simple : Erreur String.sub"; (cur_len, cur_d) in f 0 None let retrieve_last_special_no_blank_after file (s : string) = print_DEBUG ("retrieve_last_special_no_blank_after:"^s); let rec f cur_len cur_d = try let s2 = String.sub s cur_len ((String.length s) - cur_len) in print_DEBUG ("retrieve_last_special_no_blank_after.f:"^s2); match retrieve_info_special file s2 with (len, None) -> print_DEBUG "retrieve_last_special_no_blank_after: None"; (cur_len + len, cur_d) | (len, Some d) -> print_DEBUG "retrieve_last_special_no_blank_after: Some"; f (len + cur_len) (Some d) with _ -> print_DEBUG "retrieve_last_special_no_blank_after : Erreur String.sub"; (cur_len, cur_d) in f 0 None let all_special file s = print_DEBUG ("all_special: "^s); let rec iter acc n s2 = match retrieve_info_special file s2 with (_, None) -> (n, acc) | (n2, Some i) -> print_DEBUG ("all_special: avant String.sub new_s="^s2); print_DEBUG ("n2="^(string_of_int n2)) ; print_DEBUG ("len(s2)="^(string_of_int (String.length s2))) ; let new_s = String.sub s2 n2 ((String.length s2) - n2) in print_DEBUG ("all_special: apres String.sub new_s="^new_s); iter (acc @ [i]) (n + n2) new_s in let res = iter [] 0 s in print_DEBUG ("all_special: end"); res let just_after_special file s = print_DEBUG ("just_after_special: "^s); let res = match retrieve_info_special file s with (_, None) -> (0, None) | (len, Some d) -> (* we must not have a simple comment or a blank line before. *) match retrieve_info_simple file (String.sub s 0 len) with (_, None) -> ( try (* if the special comment is the stop comment (**/**), then we must not associate it. *) let pos = Str.search_forward (Str.regexp_string "(**") s 0 in if blank_line (String.sub s 0 pos) or d.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"] then (0, None) else (len, Some d) with Not_found -> (* should not occur *) (0, None) ) | (len2, Some d2) -> (0, None) in print_DEBUG ("just_after_special:end"); res let first_special file s = retrieve_info_special file s let get_comments f_create_ele file s = let (assoc_com, ele_coms) = (* get the comments *) let (len, special_coms) = all_special file s in (* if there is no blank line after the special comments, and if the last special comment is not the stop special comment, then the last special comments must be associated to the element. *) match List.rev special_coms with [] -> (None, []) | h :: q -> if (blank_line_outside_simple file (String.sub s len ((String.length s) - len)) ) or h.Odoc_types.i_desc = Some [Odoc_types.Raw "/*"] then (None, special_coms) else (Some h, List.rev q) in let ele_comments = List.fold_left (fun acc -> fun sc -> match sc.Odoc_types.i_desc with None -> acc | Some t -> acc @ [f_create_ele t]) [] ele_coms in (assoc_com, ele_comments) end module Basic_info_retriever = Info_retriever (Odoc_text.Texter) let info_of_string s = let dummy = { i_desc = None ; i_authors = [] ; i_version = None ; i_sees = [] ; i_since = None ; i_before = [] ; i_deprecated = None ; i_params = [] ; i_raised_exceptions = [] ; i_return_value = None ; i_custom = [] ; } in let s2 = Printf.sprintf "(** %s *)" s in let (_, i_opt) = Basic_info_retriever.first_special "-" s2 in match i_opt with None -> dummy | Some i -> i let info_of_comment_file modlist f = try let s = Odoc_misc.input_file_as_string f in let i = info_of_string s in Odoc_cross.assoc_comments_info "" modlist i with Sys_error s -> failwith s mingw-ocaml/ocaml/ocamldoc/odoc_latex.ml0000644000175000017500000012223512124403242017720 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Generation of LaTeX documentation. *) let print_DEBUG s = print_string s ; print_newline () open Odoc_info open Parameter open Value open Type open Exception open Class open Module let separate_files = ref false let latex_titles = ref [ 1, "section" ; 2, "subsection" ; 3, "subsubsection" ; 4, "paragraph" ; 5, "subparagraph" ; ] let latex_value_prefix = ref Odoc_messages.default_latex_value_prefix let latex_type_prefix = ref Odoc_messages.default_latex_type_prefix let latex_type_elt_prefix = ref Odoc_messages.default_latex_type_elt_prefix let latex_exception_prefix = ref Odoc_messages.default_latex_exception_prefix let latex_module_prefix = ref Odoc_messages.default_latex_module_prefix let latex_module_type_prefix = ref Odoc_messages.default_latex_module_type_prefix let latex_class_prefix = ref Odoc_messages.default_latex_class_prefix let latex_class_type_prefix = ref Odoc_messages.default_latex_class_type_prefix let latex_attribute_prefix = ref Odoc_messages.default_latex_attribute_prefix let latex_method_prefix = ref Odoc_messages.default_latex_method_prefix let new_buf () = Buffer.create 1024 let new_fmt () = let b = new_buf () in let fmt = Format.formatter_of_buffer b in (fmt, fun () -> Format.pp_print_flush fmt (); let s = Buffer.contents b in Buffer.reset b; s ) let p = Format.fprintf let ps f s = Format.fprintf f "%s" s let bp = Printf.bprintf let bs = Buffer.add_string let print_concat fmt sep f = let rec iter = function [] -> () | [c] -> f c | c :: q -> f c; ps fmt sep; iter q in iter (** Generation of LaTeX code from text structures. *) class text = object (self) (** Return latex code to make a sectionning according to the given level, and with the given latex code. *) method section_style level s = try let sec = List.assoc level !latex_titles in "\\"^sec^"{"^s^"}\n" with Not_found -> s (** Associations of strings to substitute in latex code. *) val subst_strings = List.map (fun (x, y) -> (Str.regexp x, y)) [ "\001", "\001\002"; "\\\\", "\001b"; "{", "\\\\{"; "}", "\\\\}"; "\\$", "\\\\$"; "\\^", "{\\\\textasciicircum}"; "\xE0", "\\\\`a"; "\xE2", "\\\\^a"; "\xE9", "\\\\'e"; "\xE8", "\\\\`e"; "\xEA", "\\\\^e"; "\xEB", "\\\\\"e"; "\xE7", "\\\\c{c}"; "\xF4", "\\\\^o"; "\xF6", "\\\\\"o"; "\xEE", "\\\\^i"; "\xEF", "\\\\\"i"; "\xF9", "\\\\`u"; "\xFB", "\\\\^u"; "%", "\\\\%"; "_", "\\\\_"; "~", "\\\\~{}"; "#", "{\\char35}"; "->", "$\\\\rightarrow$"; "<-", "$\\\\leftarrow$"; ">=", "$\\\\geq$"; "<=", "$\\\\leq$"; ">", "$>$"; "<", "$<$"; "=", "$=$"; "|", "{\\\\textbar}"; "\\.\\.\\.", "$\\\\ldots$"; "&", "\\\\&"; "\001b", "{\\\\char92}"; "\001\002", "\001"; ] val subst_strings_simple = List.map (fun (x, y) -> (Str.regexp x, y)) [ "\001", "\001\002"; "\\\\", "\001b"; "{", "\001l"; "}", "{\\\\char125}"; "'", "{\\\\textquotesingle}"; "`", "{\\\\textasciigrave}"; "\001b", "{\\\\char92}"; "\001l", "{\\\\char123}"; "\001\002", "\001"; ] val subst_strings_code = List.map (fun (x, y) -> (Str.regexp x, y)) [ "\001", "\001\002"; "\\\\", "\001b"; "{", "\001l"; "}", "{\\\\char125}"; "'", "{\\\\textquotesingle}"; "`", "{\\\\textasciigrave}"; "%", "\\\\%"; "_", "\\\\_"; "~", "{\\\\char126}"; "#", "{\\\\char35}"; "&", "\\\\&"; "\\$", "\\\\$"; "\\^", "{\\\\char94}"; "\001b", "{\\\\char92}"; "\001l", "{\\\\char123}"; "\001\002", "\001"; ] method subst l s = List.fold_left (fun acc (re, st) -> Str.global_replace re st acc) s l (** Escape the strings which would clash with LaTeX syntax. *) method escape s = self#subst subst_strings s (** Escape the ['\'], ['{'] and ['}'] characters. *) method escape_simple s = self#subst subst_strings_simple s (** Escape some characters for the code style. *) method escape_code s = self#subst subst_strings_code s (** Make a correct latex label from a name. *) (* The following characters are forbidden in LaTeX \index: \ { } $ & # ^ _ % ~ ! " @ | (" to close the double quote) The following characters are forbidden in LaTeX \label: \ { } $ & # ^ _ % ~ So we will use characters not forbidden in \index if no_ = true. *) method label ?(no_=true) name = let len = String.length name in let buf = Buffer.create len in for i = 0 to len - 1 do let (s_no_, s) = match name.[i] with '_' -> ("-underscore", "_") | '~' -> ("-tilde", "~") | '%' -> ("-percent", "%") | '@' -> ("-at", "\"@") | '!' -> ("-bang", "\"!") | '|' -> ("-pipe", "\"|") | '<' -> ("-lt", "<") | '>' -> ("-gt", ">") | '^' -> ("-exp", "^") | '&' -> ("-ampersand", "&") | '+' -> ("-plus", "+") | '-' -> ("-minus", "-") | '*' -> ("-star", "*") | '/' -> ("-slash", "/") | '$' -> ("-dollar", "$") | '=' -> ("-equal", "=") | ':' -> ("-colon", ":") | c -> (String.make 1 c, String.make 1 c) in Buffer.add_string buf (if no_ then s_no_ else s) done; Buffer.contents buf (** Make a correct label from a value name. *) method value_label ?no_ name = !latex_value_prefix^(self#label ?no_ name) (** Make a correct label from an attribute name. *) method attribute_label ?no_ name = !latex_attribute_prefix^(self#label ?no_ name) (** Make a correct label from a method name. *) method method_label ?no_ name = !latex_method_prefix^(self#label ?no_ name) (** Make a correct label from a class name. *) method class_label ?no_ name = !latex_class_prefix^(self#label ?no_ name) (** Make a correct label from a class type name. *) method class_type_label ?no_ name = !latex_class_type_prefix^(self#label ?no_ name) (** Make a correct label from a module name. *) method module_label ?no_ name = !latex_module_prefix^(self#label ?no_ name) (** Make a correct label from a module type name. *) method module_type_label ?no_ name = !latex_module_type_prefix^(self#label ?no_ name) (** Make a correct label from an exception name. *) method exception_label ?no_ name = !latex_exception_prefix^(self#label ?no_ name) (** Make a correct label from a type name. *) method type_label ?no_ name = !latex_type_prefix^(self#label ?no_ name) (** Make a correct label from a record field. *) method recfield_label ?no_ name = !latex_type_elt_prefix^(self#label ?no_ name) (** Make a correct label from a variant constructor. *) method const_label ?no_ name = !latex_type_elt_prefix^(self#label ?no_ name) (** Return latex code for the label of a given label. *) method make_label label = "\\label{"^label^"}" (** Return latex code for the ref to a given label. *) method make_ref label = "\\ref{"^label^"}" (** Print the LaTeX code corresponding to the [text] parameter.*) method latex_of_text fmt t = List.iter (self#latex_of_text_element fmt) t (** Print the LaTeX code for the [text_element] in parameter. *) method latex_of_text_element fmt te = match te with | Odoc_info.Raw s -> self#latex_of_Raw fmt s | Odoc_info.Code s -> self#latex_of_Code fmt s | Odoc_info.CodePre s -> self#latex_of_CodePre fmt s | Odoc_info.Verbatim s -> self#latex_of_Verbatim fmt s | Odoc_info.Bold t -> self#latex_of_Bold fmt t | Odoc_info.Italic t -> self#latex_of_Italic fmt t | Odoc_info.Emphasize t -> self#latex_of_Emphasize fmt t | Odoc_info.Center t -> self#latex_of_Center fmt t | Odoc_info.Left t -> self#latex_of_Left fmt t | Odoc_info.Right t -> self#latex_of_Right fmt t | Odoc_info.List tl -> self#latex_of_List fmt tl | Odoc_info.Enum tl -> self#latex_of_Enum fmt tl | Odoc_info.Newline -> self#latex_of_Newline fmt | Odoc_info.Block t -> self#latex_of_Block fmt t | Odoc_info.Title (n, l_opt, t) -> self#latex_of_Title fmt n l_opt t | Odoc_info.Latex s -> self#latex_of_Latex fmt s | Odoc_info.Link (s, t) -> self#latex_of_Link fmt s t | Odoc_info.Ref (name, ref_opt, text_opt) -> self#latex_of_Ref fmt name ref_opt text_opt | Odoc_info.Superscript t -> self#latex_of_Superscript fmt t | Odoc_info.Subscript t -> self#latex_of_Subscript fmt t | Odoc_info.Module_list _ -> () | Odoc_info.Index_list -> () | Odoc_info.Custom (s,t) -> self#latex_of_custom_text fmt s t | Odoc_info.Target (target, code) -> self#latex_of_Target fmt ~target ~code method latex_of_custom_text fmt s t = () method latex_of_Target fmt ~target ~code = if String.lowercase target = "latex" then self#latex_of_Latex fmt code else () method latex_of_Raw fmt s = ps fmt (self#escape s) method latex_of_Code fmt s = let s2 = self#escape_code s in let s3 = Str.global_replace (Str.regexp "\n") ("\\\\\n") s2 in p fmt "{\\tt{%s}}" s3 method latex_of_CodePre fmt s = ps fmt "\\begin{ocamldoccode}\n"; ps fmt (self#escape_simple s); ps fmt "\n\\end{ocamldoccode}\n" method latex_of_Verbatim fmt s = ps fmt "\n\\begin{verbatim}\n"; ps fmt s; ps fmt "\n\\end{verbatim}\n" method latex_of_Bold fmt t = ps fmt "{\\bf "; self#latex_of_text fmt t; ps fmt "}" method latex_of_Italic fmt t = ps fmt "{\\it "; self#latex_of_text fmt t; ps fmt "}" method latex_of_Emphasize fmt t = ps fmt "{\\em "; self#latex_of_text fmt t; ps fmt "}" method latex_of_Center fmt t = ps fmt "\\begin{center}\n"; self#latex_of_text fmt t; ps fmt "\\end{center}\n" method latex_of_Left fmt t = ps fmt "\\begin{flushleft}\n"; self#latex_of_text fmt t; ps fmt "\\end{flushleft}\n" method latex_of_Right fmt t = ps fmt "\\begin{flushright}\n"; self#latex_of_text fmt t; ps fmt "\\end{flushright}\n" method latex_of_List fmt tl = ps fmt "\\begin{itemize}\n"; List.iter (fun t -> ps fmt "\\item "; self#latex_of_text fmt t; ps fmt "\n" ) tl; ps fmt "\\end{itemize}\n" method latex_of_Enum fmt tl = ps fmt "\\begin{enumerate}\n"; List.iter (fun t -> ps fmt "\\item "; self#latex_of_text fmt t; ps fmt "\n" ) tl; ps fmt "\\end{enumerate}\n" method latex_of_Newline fmt = ps fmt "\n\n" method latex_of_Block fmt t = ps fmt "\\begin{ocamldocdescription}\n"; self#latex_of_text fmt t; ps fmt "\n\\end{ocamldocdescription}\n" method latex_of_Title fmt n label_opt t = let (fmt2, flush) = new_fmt () in self#latex_of_text fmt2 t; let s_title2 = self#section_style n (flush ()) in ps fmt s_title2; ( match label_opt with None -> () | Some l -> ps fmt (self#make_label (self#label ~no_: false l)) ) method latex_of_Latex fmt s = ps fmt s method latex_of_Link fmt s t = self#latex_of_text fmt t ; ps fmt "[\\url{"; ps fmt s ; ps fmt "}]" method latex_of_Ref fmt name ref_opt text_opt = match ref_opt with None -> self#latex_of_text fmt (match text_opt with None -> [Odoc_info.Code (Odoc_info.use_hidden_modules name)] | Some t -> t ) | Some (RK_section _) -> self#latex_of_text_element fmt (Latex ("["^(self#make_ref (self#label ~no_:false (Name.simple name)))^"]")) | Some kind -> let f_label = match kind with Odoc_info.RK_module -> self#module_label | Odoc_info.RK_module_type -> self#module_type_label | Odoc_info.RK_class -> self#class_label | Odoc_info.RK_class_type -> self#class_type_label | Odoc_info.RK_value -> self#value_label | Odoc_info.RK_type -> self#type_label | Odoc_info.RK_exception -> self#exception_label | Odoc_info.RK_attribute -> self#attribute_label | Odoc_info.RK_method -> self#method_label | Odoc_info.RK_section _ -> assert false | Odoc_info.RK_recfield -> self#recfield_label | Odoc_info.RK_const -> self#const_label in let text = match text_opt with None -> [Odoc_info.Code (Odoc_info.use_hidden_modules name)] | Some t -> t in self#latex_of_text fmt (text @ [Latex ("["^(self#make_ref (f_label name))^"]")]) method latex_of_Superscript fmt t = ps fmt "$^{"; self#latex_of_text fmt t; ps fmt "}$" method latex_of_Subscript fmt t = ps fmt "$_{"; self#latex_of_text fmt t; ps fmt "}$" end (** A class used to generate LaTeX code for info structures. *) class virtual info = object (self) (** The method used to get LaTeX code from a [text]. *) method virtual latex_of_text : Format.formatter -> Odoc_info.text -> unit (** The method used to get a [text] from an optionel info structure. *) method virtual text_of_info : ?block: bool -> Odoc_info.info option -> Odoc_info.text (** Print LaTeX code for a description, except for the [i_params] field. *) method latex_of_info fmt ?(block=false) info_opt = self#latex_of_text fmt (self#text_of_info ~block info_opt) end module Generator = struct (** This class is used to create objects which can generate a simple LaTeX documentation. *) class latex = object (self) inherit text inherit Odoc_to_text.to_text as to_text inherit info (** Get the first sentence and the rest of a description, from an optional [info] structure. The first sentence can be empty if it would not appear right in a title. In the first sentence, the titles and lists has been removed, since it is used in LaTeX titles and would make LaTeX complain if we has two nested \section commands. *) method first_and_rest_of_info i_opt = match i_opt with None -> ([], []) | Some i -> match i.Odoc_info.i_desc with None -> ([], self#text_of_info ~block: true i_opt) | Some t -> let (first,_) = Odoc_info.first_sentence_and_rest_of_text t in let (_, rest) = Odoc_info.first_sentence_and_rest_of_text (self#text_of_info ~block: false i_opt) in (Odoc_info.text_no_title_no_list first, rest) (** Print LaTeX code for a value. *) method latex_of_value fmt v = Odoc_info.reset_type_names () ; let label = self#value_label v.val_name in let latex = self#make_label label in self#latex_of_text fmt ((Latex latex) :: (to_text#text_of_value v)) (** Print LaTeX code for a class attribute. *) method latex_of_attribute fmt a = self#latex_of_text fmt ((Latex (self#make_label (self#attribute_label a.att_value.val_name))) :: (to_text#text_of_attribute a)) (** Print LaTeX code for a class method. *) method latex_of_method fmt m = self#latex_of_text fmt ((Latex (self#make_label (self#method_label m.met_value.val_name))) :: (to_text#text_of_method m)) (** Print LaTeX code for the parameters of a type. *) method latex_of_type_params fmt m_name t = let print_one (p, co, cn) = ps fmt (Odoc_info.string_of_variance t (co,cn)); ps fmt (self#normal_type m_name p) in match t.ty_parameters with [] -> () | [(p,co,cn)] -> print_one (p, co, cn) | l -> ps fmt "("; print_concat fmt ", " print_one t.ty_parameters; ps fmt ")" method latex_of_class_parameter_list fmt father c = self#latex_of_text fmt (self#text_of_class_params father c) (** Print LaTeX code for a type. *) method latex_of_type fmt t = let s_name = Name.simple t.ty_name in let text = let (fmt2, flush2) = new_fmt () in Odoc_info.reset_type_names () ; let mod_name = Name.father t.ty_name in Format.fprintf fmt2 "@[type "; self#latex_of_type_params fmt2 mod_name t; (match t.ty_parameters with [] -> () | _ -> ps fmt2 " "); ps fmt2 s_name; let priv = t.ty_private = Asttypes.Private in ( match t.ty_manifest with None -> () | Some typ -> p fmt2 " = %s%s" (if priv then "private " else "") (self#normal_type mod_name typ) ); let s_type3 = p fmt2 " %s" ( match t.ty_kind with Type_abstract -> "" | Type_variant _ -> "="^(if priv then " private" else "") | Type_record _ -> "= "^(if priv then "private " else "")^"{" ) ; flush2 () in let defs = match t.ty_kind with Type_abstract -> [] | Type_variant l -> (List.flatten (List.map (fun constr -> let s_cons = p fmt2 "@[ | %s" constr.vc_name; ( match constr.vc_args, constr.vc_ret with [], None -> () | l, None -> p fmt2 " %s@ %s" "of" (self#normal_type_list ~par: false mod_name " * " l) | [], Some r -> p fmt2 " %s@ %s" ":" (self#normal_type mod_name r) | l, Some r -> p fmt2 " %s@ %s@ %s@ %s" ":" (self#normal_type_list ~par: false mod_name " * " l) "->" (self#normal_type mod_name r) ); flush2 () in [ CodePre s_cons ] @ (match constr.vc_text with None -> [] | Some t -> let s = ps fmt2 "\\begin{ocamldoccomment}\n"; self#latex_of_text fmt2 t; ps fmt2 "\n\\end{ocamldoccomment}\n"; flush2 () in [ Latex s] ) ) l ) ) | Type_record l -> (List.flatten (List.map (fun r -> let s_field = p fmt2 "@[ %s%s :@ %s ;" (if r.rf_mutable then "mutable " else "") r.rf_name (self#normal_type mod_name r.rf_type); flush2 () in [ CodePre s_field ] @ (match r.rf_text with None -> [] | Some t -> let s = ps fmt2 "\\begin{ocamldoccomment}\n"; self#latex_of_text fmt2 t; ps fmt2 "\n\\end{ocamldoccomment}\n"; flush2 () in [ Latex s] ) ) l ) ) @ [ CodePre "}" ] in let defs2 = (CodePre s_type3) :: defs in let rec iter = function [] -> [] | [e] -> [e] | (CodePre s1) :: (CodePre s2) :: q -> iter ((CodePre (s1^"\n"^s2)) :: q) | e :: q -> e :: (iter q) in (iter defs2) @ [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ (self#text_of_info t.ty_info) in self#latex_of_text fmt ((Latex (self#make_label (self#type_label t.ty_name))) :: text) (** Print LaTeX code for an exception. *) method latex_of_exception fmt e = Odoc_info.reset_type_names () ; self#latex_of_text fmt ((Latex (self#make_label (self#exception_label e.ex_name))) :: (to_text#text_of_exception e)) method latex_of_module_parameter fmt m_name p = self#latex_of_text fmt [ Code "functor ("; Code p.mp_name ; Code " : "; ] ; self#latex_of_module_type_kind fmt m_name p.mp_kind; self#latex_of_text fmt [ Code ") -> "] method latex_of_module_type_kind fmt father kind = match kind with Module_type_struct eles -> self#latex_of_text fmt [Latex "\\begin{ocamldocsigend}\n"]; List.iter (self#latex_of_module_element fmt father) eles; self#latex_of_text fmt [Latex "\\end{ocamldocsigend}\n"] | Module_type_functor (p, k) -> self#latex_of_module_parameter fmt father p; self#latex_of_module_type_kind fmt father k | Module_type_alias a -> self#latex_of_text fmt [Code (self#relative_module_idents father a.mta_name)] | Module_type_with (k, s) -> self#latex_of_module_type_kind fmt father k; self#latex_of_text fmt [ Code " "; Code (self#relative_idents father s); ] | Module_type_typeof s -> self#latex_of_text fmt [ Code "module type of "; Code (self#relative_idents father s); ] method latex_of_module_kind fmt father kind = match kind with Module_struct eles -> self#latex_of_text fmt [Latex "\\begin{ocamldocsigend}\n"]; List.iter (self#latex_of_module_element fmt father) eles; self#latex_of_text fmt [Latex "\\end{ocamldocsigend}\n"] | Module_alias a -> self#latex_of_text fmt [Code (self#relative_module_idents father a.ma_name)] | Module_functor (p, k) -> self#latex_of_module_parameter fmt father p; self#latex_of_module_kind fmt father k | Module_apply (k1, k2) -> (* TODO: l'application n'est pas correcte dans un .mli. Que faire ? -> afficher le module_type du typedtree *) self#latex_of_module_kind fmt father k1; self#latex_of_text fmt [Code "("]; self#latex_of_module_kind fmt father k2; self#latex_of_text fmt [Code ")"] | Module_with (k, s) -> (* TODO: a modifier quand Module_with sera plus detaille *) self#latex_of_module_type_kind fmt father k; self#latex_of_text fmt [ Code " "; Code (self#relative_idents father s) ; ] | Module_constraint (k, tk) -> (* TODO: on affiche quoi ? *) self#latex_of_module_kind fmt father k | Module_typeof s -> self#latex_of_text fmt [ Code "module type of "; Code (self#relative_idents father s); ] | Module_unpack (s, _) -> self#latex_of_text fmt [ Code (self#relative_idents father s); ] method latex_of_class_kind fmt father kind = match kind with Class_structure (inh, eles) -> self#latex_of_text fmt [Latex "\\begin{ocamldocobjectend}\n"]; self#generate_inheritance_info fmt inh; List.iter (self#latex_of_class_element fmt father) eles; self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"] | Class_apply capp -> (* TODO: afficher le type final a partir du typedtree *) self#latex_of_text fmt [Raw "class application not handled yet"] | Class_constr cco -> ( match cco.cco_type_parameters with [] -> () | l -> self#latex_of_text fmt ( Code "[" :: (self#text_of_class_type_param_expr_list father l) @ [Code "] "] ) ); self#latex_of_text fmt [Code (self#relative_idents father cco.cco_name)] | Class_constraint (ck, ctk) -> self#latex_of_text fmt [Code "( "] ; self#latex_of_class_kind fmt father ck; self#latex_of_text fmt [Code " : "] ; self#latex_of_class_type_kind fmt father ctk; self#latex_of_text fmt [Code " )"] method latex_of_class_type_kind fmt father kind = match kind with Class_type cta -> ( match cta.cta_type_parameters with [] -> () | l -> self#latex_of_text fmt (Code "[" :: (self#text_of_class_type_param_expr_list father l) @ [Code "] "] ) ); self#latex_of_text fmt [Code (self#relative_idents father cta.cta_name)] | Class_signature (inh, eles) -> self#latex_of_text fmt [Latex "\\begin{ocamldocobjectend}\n"]; self#generate_inheritance_info fmt inh; List.iter (self#latex_of_class_element fmt father) eles; self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"] method latex_for_module_index fmt m = let s_name = Name.simple m.m_name in self#latex_of_text fmt [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^ (self#label ~no_:false s_name)^"`}\n" ) ] method latex_for_module_type_index fmt mt = let s_name = Name.simple mt.mt_name in self#latex_of_text fmt [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^ (self#label ~no_:false (Name.simple s_name))^"`}\n" ) ] method latex_for_module_label fmt m = ps fmt (self#make_label (self#module_label m.m_name)) method latex_for_module_type_label fmt mt = ps fmt (self#make_label (self#module_type_label mt.mt_name)) method latex_for_class_index fmt c = let s_name = Name.simple c.cl_name in self#latex_of_text fmt [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^ (self#label ~no_:false s_name)^"`}\n" ) ] method latex_for_class_type_index fmt ct = let s_name = Name.simple ct.clt_name in self#latex_of_text fmt [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^ (self#label ~no_:false s_name)^"`}\n" ) ] method latex_for_class_label fmt c = ps fmt (self#make_label (self#class_label c.cl_name)) method latex_for_class_type_label fmt ct = ps fmt (self#make_label (self#class_type_label ct.clt_name)) (** Print the LaTeX code for the given module. *) method latex_of_module fmt m = let father = Name.father m.m_name in let t = [ Latex "\\begin{ocamldoccode}\n" ; Code "module "; Code (Name.simple m.m_name); Code " : "; ] in self#latex_of_text fmt t; self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ]; self#latex_for_module_label fmt m; self#latex_for_module_index fmt m; p fmt "@["; self#latex_of_module_kind fmt father m.m_kind; ( match Module.module_is_functor m with false -> () | true -> self#latex_of_text fmt [Newline]; ( match List.filter (fun (_,d) -> d <> None) (module_parameters ~trans: false m) with [] -> () | l -> let t = [ Bold [Raw "Parameters: "]; List (List.map (fun (p,text_opt) -> let t = match text_opt with None -> [] | Some t -> t in ( Raw p.mp_name :: Raw ": " :: t) ) l ) ] in self#latex_of_text fmt t ); ); self#latex_of_text fmt [Newline]; self#latex_of_info fmt ~block: true m.m_info; p fmt "@]"; (** Print the LaTeX code for the given module type. *) method latex_of_module_type fmt mt = let father = Name.father mt.mt_name in let t = [ Latex "\\begin{ocamldoccode}\n" ; Code "module type " ; Code (Name.simple mt.mt_name); ] in self#latex_of_text fmt t; ( match mt.mt_type, mt.mt_kind with | Some mtyp, Some kind -> self#latex_of_text fmt [ Code " = " ]; self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ]; self#latex_for_module_type_label fmt mt; self#latex_for_module_type_index fmt mt; p fmt "@["; self#latex_of_module_type_kind fmt father kind | _ -> self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ]; self#latex_for_module_type_index fmt mt; p fmt "@["; ); ( match Module.module_type_is_functor mt with false -> () | true -> self#latex_of_text fmt [Newline]; ( match List.filter (fun (_,d) -> d <> None) (module_type_parameters ~trans: false mt) with [] -> () | l -> let t = [ Bold [Raw "Parameters: "]; List (List.map (fun (p,text_opt) -> let t = match text_opt with None -> [] | Some t -> t in ( Raw p.mp_name :: Raw ": " :: t) ) l ) ] in self#latex_of_text fmt t ); ); self#latex_of_text fmt [Newline]; self#latex_of_info fmt ~block: true mt.mt_info; p fmt "@]"; (** Print the LaTeX code for the given included module. *) method latex_of_included_module fmt im = self#latex_of_text fmt ((Code "include ") :: (Code (match im.im_module with None -> im.im_name | Some (Mod m) -> m.m_name | Some (Modtype mt) -> mt.mt_name) ) :: (self#text_of_info im.im_info) ) (** Print the LaTeX code for the given class. *) method latex_of_class fmt c = Odoc_info.reset_type_names () ; let father = Name.father c.cl_name in let type_params = match c.cl_type_parameters with [] -> "" | l -> (self#normal_class_type_param_list father l)^" " in let t = [ Latex "\\begin{ocamldoccode}\n" ; Code (Printf.sprintf "class %s%s%s : " (if c.cl_virtual then "virtual " else "") type_params (Name.simple c.cl_name) ) ] in self#latex_of_text fmt t; self#latex_of_class_parameter_list fmt father c; (* avoid a big gap if the kind is a consrt *) ( match c.cl_kind with Class.Class_constr _ -> self#latex_of_class_kind fmt father c.cl_kind | _ -> () ); self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ]; self#latex_for_class_label fmt c; self#latex_for_class_index fmt c; p fmt "@["; (match c.cl_kind with Class.Class_constr _ -> () | _ -> self#latex_of_class_kind fmt father c.cl_kind ); self#latex_of_text fmt [Newline]; self#latex_of_info fmt ~block: true c.cl_info; p fmt "@]" (** Print the LaTeX code for the given class type. *) method latex_of_class_type fmt ct = Odoc_info.reset_type_names () ; let father = Name.father ct.clt_name in let type_params = match ct.clt_type_parameters with [] -> "" | l -> (self#normal_class_type_param_list father l)^" " in let t = [ Latex "\\begin{ocamldoccode}\n" ; Code (Printf.sprintf "class type %s%s%s = " (if ct.clt_virtual then "virtual " else "") type_params (Name.simple ct.clt_name) ) ] in self#latex_of_text fmt t; self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ]; self#latex_for_class_type_label fmt ct; self#latex_for_class_type_index fmt ct; p fmt "@["; self#latex_of_class_type_kind fmt father ct.clt_kind; self#latex_of_text fmt [Newline]; self#latex_of_info fmt ~block: true ct.clt_info; p fmt "@]" (** Print the LaTeX code for the given class element. *) method latex_of_class_element fmt class_name class_ele = self#latex_of_text fmt [Newline]; match class_ele with Class_attribute att -> self#latex_of_attribute fmt att | Class_method met -> self#latex_of_method fmt met | Class_comment t -> match t with | [] -> () | (Title (_,_,_)) :: _ -> self#latex_of_text fmt t | _ -> self#latex_of_text fmt [ Title ((Name.depth class_name) + 2, None, t) ] (** Print the LaTeX code for the given module element. *) method latex_of_module_element fmt module_name module_ele = self#latex_of_text fmt [Newline]; match module_ele with Element_module m -> self#latex_of_module fmt m | Element_module_type mt -> self#latex_of_module_type fmt mt | Element_included_module im -> self#latex_of_included_module fmt im | Element_class c -> self#latex_of_class fmt c | Element_class_type ct -> self#latex_of_class_type fmt ct | Element_value v -> self#latex_of_value fmt v | Element_exception e -> self#latex_of_exception fmt e | Element_type t -> self#latex_of_type fmt t | Element_module_comment t -> self#latex_of_text fmt t (** Generate the LaTeX code for the given list of inherited classes.*) method generate_inheritance_info fmt inher_l = let f inh = match inh.ic_class with None -> (* we can't make the reference *) Newline :: Code ("inherit "^inh.ic_name) :: (match inh.ic_text with None -> [] | Some t -> Newline :: t ) | Some cct -> let label = match cct with Cl _ -> self#class_label inh.ic_name | Cltype _ -> self#class_type_label inh.ic_name in (* we can create the reference *) Newline :: Odoc_info.Code ("inherit "^inh.ic_name) :: (Odoc_info.Latex (" ["^(self#make_ref label)^"]")) :: (match inh.ic_text with None -> [] | Some t -> Newline :: t ) in List.iter (self#latex_of_text fmt) (List.map f inher_l) (** Generate the LaTeX code for the inherited classes of the given class. *) method generate_class_inheritance_info fmt cl = let rec iter_kind k = match k with Class_structure ([], _) -> () | Class_structure (l, _) -> self#generate_inheritance_info fmt l | Class_constraint (k, _) -> iter_kind k | Class_apply _ | Class_constr _ -> () in iter_kind cl.cl_kind (** Generate the LaTeX code for the inherited classes of the given class type. *) method generate_class_type_inheritance_info fmt clt = match clt.clt_kind with Class_signature ([], _) -> () | Class_signature (l, _) -> self#generate_inheritance_info fmt l | Class_type _ -> () (** Generate the LaTeX code for the given top module, in the given buffer. *) method generate_for_top_module fmt m = let (first_t, rest_t) = self#first_and_rest_of_info m.m_info in let text = if m.m_text_only then [ Title (1, None, [Raw m.m_name] @ (match first_t with [] -> [] | t -> (Raw " : ") :: t) ) ; ] else [ Title (1, None, [ Raw (Odoc_messages.modul^" ") ; Code m.m_name ] @ (match first_t with [] -> [] | t -> (Raw " : ") :: t)) ; ] in self#latex_of_text fmt text; self#latex_for_module_label fmt m; self#latex_for_module_index fmt m; self#latex_of_text fmt rest_t ; self#latex_of_text fmt [ Newline ] ; if not m.m_text_only then ps fmt "\\ocamldocvspace{0.5cm}\n\n"; List.iter (fun ele -> self#latex_of_module_element fmt m.m_name ele; ps fmt "\n\n" ) (Module.module_elements ~trans: false m) (** Print the header of the TeX document. *) method latex_header fmt module_list = ps fmt "\\documentclass[11pt]{article} \n"; ps fmt "\\usepackage[latin1]{inputenc} \n"; ps fmt "\\usepackage[T1]{fontenc} \n"; ps fmt "\\usepackage{textcomp}\n"; ps fmt "\\usepackage{fullpage} \n"; ps fmt "\\usepackage{url} \n"; ps fmt "\\usepackage{ocamldoc}\n"; ( match !Global.title with None -> () | Some s -> ps fmt "\\title{"; ps fmt (self#escape s); ps fmt "}\n" ); ps fmt "\\begin{document}\n"; (match !Global.title with None -> () | Some _ -> ps fmt "\\maketitle\n" ); if !Global.with_toc then ps fmt "\\tableofcontents\n"; ( let info = Odoc_info.apply_opt (Odoc_info.info_of_comment_file module_list) !Odoc_info.Global.intro_file in (match info with None -> () | Some _ -> ps fmt "\\vspace{0.2cm}"); self#latex_of_info fmt info; (match info with None -> () | Some _ -> ps fmt "\n\n") ) (** Generate the LaTeX style file, if it does not exists. *) method generate_style_file = try let dir = Filename.dirname !Global.out_file in let file = Filename.concat dir "ocamldoc.sty" in if Sys.file_exists file then Odoc_info.verbose (Odoc_messages.file_exists_dont_generate file) else ( let chanout = open_out file in output_string chanout Odoc_latex_style.content ; flush chanout ; close_out chanout; Odoc_info.verbose (Odoc_messages.file_generated file) ) with Sys_error s -> prerr_endline s ; incr Odoc_info.errors ; (** Generate the LaTeX file from a module list, in the {!Odoc_info.Global.out_file} file. *) method generate module_list = self#generate_style_file ; let main_file = !Global.out_file in let dir = Filename.dirname main_file in if !separate_files then ( let f m = try let chanout = open_out ((Filename.concat dir (Name.simple m.m_name))^".tex") in let fmt = Format.formatter_of_out_channel chanout in self#generate_for_top_module fmt m ; Format.pp_print_flush fmt (); close_out chanout with Failure s | Sys_error s -> prerr_endline s ; incr Odoc_info.errors in List.iter f module_list ); try let chanout = open_out main_file in let fmt = Format.formatter_of_out_channel chanout in if !Global.with_header then self#latex_header fmt module_list; List.iter (fun m -> if !separate_files then ps fmt ("\\input{"^((Name.simple m.m_name))^".tex}\n") else self#generate_for_top_module fmt m ) module_list ; if !Global.with_trailer then ps fmt "\\end{document}"; Format.pp_print_flush fmt (); close_out chanout with Failure s | Sys_error s -> prerr_endline s ; incr Odoc_info.errors end end module type Latex_generator = module type of Generator mingw-ocaml/ocaml/ocamldoc/odoc_info.mli0000644000175000017500000012257112124403242017712 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Interface to the information collected in source files. *) (** The differents kinds of element references. *) type ref_kind = Odoc_types.ref_kind = RK_module | RK_module_type | RK_class | RK_class_type | RK_value | RK_type | RK_exception | RK_attribute | RK_method | RK_section of text | RK_recfield | RK_const and text_element = Odoc_types.text_element = | Raw of string (** Raw text. *) | Code of string (** The string is source code. *) | CodePre of string (** The string is pre-formatted source code. *) | Verbatim of string (** String 'as is'. *) | Bold of text (** Text in bold style. *) | Italic of text (** Text in italic. *) | Emphasize of text (** Emphasized text. *) | Center of text (** Centered text. *) | Left of text (** Left alignment. *) | Right of text (** Right alignment. *) | List of text list (** A list. *) | Enum of text list (** An enumerated list. *) | Newline (** To force a line break. *) | Block of text (** Like html's block quote. *) | Title of int * string option * text (** Style number, optional label, and text. *) | Latex of string (** A string for latex. *) | Link of string * text (** A reference string and the link text. *) | Ref of string * ref_kind option * text option (** A reference to an element. Complete name and kind. An optional text can be given to display this text instead of the element name.*) | Superscript of text (** Superscripts. *) | Subscript of text (** Subscripts. *) | Module_list of string list (** The table of the given modules with their abstract. *) | Index_list (** The links to the various indexes (values, types, ...) *) | Custom of string * text (** to extend \{foo syntax *) | Target of string * string (** (target, code) : to specify code specific to a target format *) (** A text is a list of [text_element]. The order matters. *) and text = text_element list (** The different forms of references in \@see tags. *) type see_ref = Odoc_types.see_ref = See_url of string | See_file of string | See_doc of string (** Raised when parsing string to build a {!Odoc_info.text} structure. [(line, char, string)] *) exception Text_syntax of int * int * string (** The information in a \@see tag. *) type see = see_ref * text (** Parameter name and description. *) type param = (string * text) (** Raised exception name and description. *) type raised_exception = (string * text) (** Information in a special comment @before 3.12.0 \@before information was not present. *) type info = Odoc_types.info = { i_desc : text option; (** The description text. *) i_authors : string list; (** The list of authors in \@author tags. *) i_version : string option; (** The string in the \@version tag. *) i_sees : see list; (** The list of \@see tags. *) i_since : string option; (** The string in the \@since tag. *) i_before : (string * text) list ; (** the version number and text in \@before tag *) i_deprecated : text option; (** The of the \@deprecated tag. *) i_params : param list; (** The list of parameter descriptions. *) i_raised_exceptions : raised_exception list; (** The list of raised exceptions. *) i_return_value : text option; (** The description text of the return value. *) i_custom : (string * text) list ; (** A text associated to a custom @-tag. *) } (** Location of elements in implementation and interface files. *) type location = Odoc_types.location = { loc_impl : Location.t option ; (** implementation location *) loc_inter : Location.t option ; (** interface location *) } (** A dummy location. *) val dummy_loc : location (** Representation of element names. *) module Name : sig type t = string (** Access to the simple name. *) val simple : t -> t (** [concat t1 t2] returns the concatenation of [t1] and [t2].*) val concat : t -> t -> t (** Return the depth of the name, i.e. the numer of levels to the root. Example : [depth "Toto.Tutu.name"] = [3]. *) val depth : t -> int (** Take two names n1 and n2 = n3.n4 and return n4 if n3=n1 or else n2. *) val get_relative : t -> t -> t (** Return the name of the 'father' (like [dirname] for a file name).*) val father : t -> t end (** Representation and manipulation of method / function / class / module parameters.*) module Parameter : sig (** {3 Types} *) (** Representation of a simple parameter name *) type simple_name = Odoc_parameter.simple_name = { sn_name : string ; sn_type : Types.type_expr ; mutable sn_text : text option ; } (** Representation of parameter names. We need it to represent parameter names in tuples. The value [Tuple ([], t)] stands for an anonymous parameter.*) type param_info = Odoc_parameter.param_info = Simple_name of simple_name | Tuple of param_info list * Types.type_expr (** A parameter is just a param_info.*) type parameter = param_info (** {3 Functions} *) (** Acces to the name as a string. For tuples, parenthesis and commas are added. *) val complete_name : parameter -> string (** Access to the complete type. *) val typ : parameter -> Types.type_expr (** Access to the list of names ; only one for a simple parameter, or a list for a tuple. *) val names : parameter -> string list (** Access to the description of a specific name. @raise Not_found if no description is associated to the given name. *) val desc_by_name : parameter -> string -> text option (** Access to the type of a specific name. @raise Not_found if no type is associated to the given name. *) val type_by_name : parameter -> string -> Types.type_expr end (** Representation and manipulation of exceptions. *) module Exception : sig (** Used when the exception is a rebind of another exception, when we have [exception Ex = Target_ex].*) type exception_alias = Odoc_exception.exception_alias = { ea_name : Name.t ; (** The complete name of the target exception. *) mutable ea_ex : t_exception option ; (** The target exception, if we found it.*) } and t_exception = Odoc_exception.t_exception = { ex_name : Name.t ; mutable ex_info : info option ; (** Information found in the optional associated comment. *) ex_args : Types.type_expr list ; (** The types of the parameters. *) ex_alias : exception_alias option ; (** [None] when the exception is not a rebind. *) mutable ex_loc : location ; mutable ex_code : string option ; } end (** Representation and manipulation of types.*) module Type : sig type private_flag = Odoc_type.private_flag = Private | Public (** Description of a variant type constructor. *) type variant_constructor = Odoc_type.variant_constructor = { vc_name : string ; (** Name of the constructor. *) vc_args : Types.type_expr list ; (** Arguments of the constructor. *) vc_ret : Types.type_expr option ; mutable vc_text : text option ; (** Optional description in the associated comment. *) } (** Description of a record type field. *) type record_field = Odoc_type.record_field = { rf_name : string ; (** Name of the field. *) rf_mutable : bool ; (** [true] if mutable. *) rf_type : Types.type_expr ; (** Type of the field. *) mutable rf_text : text option ; (** Optional description in the associated comment.*) } (** The various kinds of a type. *) type type_kind = Odoc_type.type_kind = Type_abstract (** Type is abstract, for example [type t]. *) | Type_variant of variant_constructor list (** constructors *) | Type_record of record_field list (** fields *) (** Representation of a type. *) type t_type = Odoc_type.t_type = { ty_name : Name.t ; (** Complete name of the type. *) mutable ty_info : info option ; (** Information found in the optional associated comment. *) ty_parameters : (Types.type_expr * bool * bool) list ; (** type parameters: (type, covariant, contravariant) *) ty_kind : type_kind; (** Type kind. *) ty_private : private_flag; (** Private or public type. *) ty_manifest : Types.type_expr option; (** Type manifest. *) mutable ty_loc : location ; mutable ty_code : string option; } end (** Representation and manipulation of values, class attributes and class methods. *) module Value : sig (** Representation of a value. *) type t_value = Odoc_value.t_value = { val_name : Name.t ; (** Complete name of the value. *) mutable val_info : info option ; (** Information found in the optional associated comment. *) val_type : Types.type_expr ; (** Type of the value. *) val_recursive : bool ; (** [true] if the value is recursive. *) mutable val_parameters : Odoc_parameter.parameter list ; (** The parameters, if any. *) mutable val_code : string option ; (** The code of the value, if we had the only the implementation file. *) mutable val_loc : location ; } (** Representation of a class attribute. *) type t_attribute = Odoc_value.t_attribute = { att_value : t_value ; (** an attribute has almost all the same information as a value *) att_mutable : bool ; (** [true] if the attribute is mutable. *) att_virtual : bool ; (** [true] if the attribute is virtual. *) } (** Representation of a class method. *) type t_method = Odoc_value.t_method = { met_value : t_value ; (** a method has almost all the same information as a value *) met_private : bool ; (** [true] if the method is private.*) met_virtual : bool ; (** [true] if the method is virtual. *) } (** Return [true] if the value is a function, i.e. it has a functional type. *) val is_function : t_value -> bool (** Access to the description associated to the given parameter name.*) val value_parameter_text_by_name : t_value -> string -> text option end (** Representation and manipulation of classes and class types.*) module Class : sig (** {3 Types} *) (** To keep the order of elements in a class. *) type class_element = Odoc_class.class_element = Class_attribute of Value.t_attribute | Class_method of Value.t_method | Class_comment of text (** Used when we can reference a t_class or a t_class_type. *) type cct = Odoc_class.cct = Cl of t_class | Cltype of t_class_type * Types.type_expr list (** Class type and type parameters. *) and inherited_class = Odoc_class.inherited_class = { ic_name : Name.t ; (** Complete name of the inherited class. *) mutable ic_class : cct option ; (** The associated t_class or t_class_type. *) ic_text : text option ; (** The inheritance description, if any. *) } and class_apply = Odoc_class.class_apply = { capp_name : Name.t ; (** The complete name of the applied class. *) mutable capp_class : t_class option; (** The associated t_class if we found it. *) capp_params : Types.type_expr list; (** The type of expressions the class is applied to. *) capp_params_code : string list ; (** The code of these exprssions. *) } and class_constr = Odoc_class.class_constr = { cco_name : Name.t ; (** The complete name of the applied class. *) mutable cco_class : cct option; (** The associated class or class type if we found it. *) cco_type_parameters : Types.type_expr list; (** The type parameters of the class, if needed. *) } and class_kind = Odoc_class.class_kind = Class_structure of inherited_class list * class_element list (** An explicit class structure, used in implementation and interface. *) | Class_apply of class_apply (** Application/alias of a class, used in implementation only. *) | Class_constr of class_constr (** A class used to give the type of the defined class, instead of a structure, used in interface only. For example, it will be used with the name [M1.M2....bar] when the class foo is defined like this : [class foo : int -> bar] *) | Class_constraint of class_kind * class_type_kind (** A class definition with a constraint. *) (** Representation of a class. *) and t_class = Odoc_class.t_class = { cl_name : Name.t ; (** Complete name of the class. *) mutable cl_info : info option ; (** Information found in the optional associated comment. *) cl_type : Types.class_type ; (** Type of the class. *) cl_type_parameters : Types.type_expr list ; (** Type parameters. *) cl_virtual : bool ; (** [true] when the class is virtual. *) mutable cl_kind : class_kind ; (** The way the class is defined. *) mutable cl_parameters : Parameter.parameter list ; (** The parameters of the class. *) mutable cl_loc : location ; } and class_type_alias = Odoc_class.class_type_alias = { cta_name : Name.t ; (** Complete name of the target class type. *) mutable cta_class : cct option ; (** The target t_class or t_class_type, if we found it.*) cta_type_parameters : Types.type_expr list ; (** The type parameters. A VOIR : mettre des string ? *) } and class_type_kind = Odoc_class.class_type_kind = Class_signature of inherited_class list * class_element list | Class_type of class_type_alias (** A class type eventually applied to type args. *) (** Representation of a class type. *) and t_class_type = Odoc_class.t_class_type = { clt_name : Name.t ; (** Complete name of the type. *) mutable clt_info : info option ; (** Information found in the optional associated comment. *) clt_type : Types.class_type ; clt_type_parameters : Types.type_expr list ; (** Type parameters. *) clt_virtual : bool ; (** [true] if the class type is virtual *) mutable clt_kind : class_type_kind ; (** The way the class type is defined. *) mutable clt_loc : location ; } (** {3 Functions} *) (** Access to the elements of a class. *) val class_elements : ?trans:bool -> t_class -> class_element list (** Access to the list of class attributes. *) val class_attributes : ?trans:bool -> t_class -> Value.t_attribute list (** Access to the description associated to the given class parameter name. *) val class_parameter_text_by_name : t_class -> string -> text option (** Access to the methods of a class. *) val class_methods : ?trans:bool -> t_class -> Value.t_method list (** Access to the comments of a class. *) val class_comments : ?trans:bool -> t_class -> text list (** Access to the elements of a class type. *) val class_type_elements : ?trans:bool -> t_class_type -> class_element list (** Access to the list of class type attributes. *) val class_type_attributes : ?trans:bool -> t_class_type -> Value.t_attribute list (** Access to the description associated to the given class type parameter name. *) val class_type_parameter_text_by_name : t_class_type -> string -> text option (** Access to the methods of a class type. *) val class_type_methods : ?trans:bool -> t_class_type -> Value.t_method list (** Access to the comments of a class type. *) val class_type_comments : ?trans:bool -> t_class_type -> text list end (** Representation and manipulation of modules and module types. *) module Module : sig (** {3 Types} *) (** To keep the order of elements in a module. *) type module_element = Odoc_module.module_element = Element_module of t_module | Element_module_type of t_module_type | Element_included_module of included_module | Element_class of Class.t_class | Element_class_type of Class.t_class_type | Element_value of Value.t_value | Element_exception of Exception.t_exception | Element_type of Type.t_type | Element_module_comment of text (** Used where we can reference t_module or t_module_type. *) and mmt = Odoc_module.mmt = | Mod of t_module | Modtype of t_module_type and included_module = Odoc_module.included_module = { im_name : Name.t ; (** Complete name of the included module. *) mutable im_module : mmt option ; (** The included module or module type, if we found it. *) mutable im_info : Odoc_types.info option ; (** comment associated to the includ directive *) } and module_alias = Odoc_module.module_alias = { ma_name : Name.t ; (** Complete name of the target module. *) mutable ma_module : mmt option ; (** The real module or module type if we could associate it. *) } and module_parameter = Odoc_module.module_parameter = { mp_name : string ; (** the name *) mp_type : Types.module_type ; (** the type *) mp_type_code : string ; (** the original code *) mp_kind : module_type_kind ; (** the way the parameter was built *) } (** Different kinds of a module. *) and module_kind = Odoc_module.module_kind = | Module_struct of module_element list (** A complete module structure. *) | Module_alias of module_alias (** Complete name and corresponding module if we found it *) | Module_functor of module_parameter * module_kind (** A functor, with its parameter and the rest of its definition *) | Module_apply of module_kind * module_kind (** A module defined by application of a functor. *) | Module_with of module_type_kind * string (** A module whose type is a with ... constraint. Should appear in interface files only. *) | Module_constraint of module_kind * module_type_kind (** A module constraint by a module type. *) | Module_typeof of string (** by now only the code of the module expression *) | Module_unpack of string * module_type_alias (** code of the expression and module type alias *) (** Representation of a module. *) and t_module = Odoc_module.t_module = { m_name : Name.t ; (** Complete name of the module. *) mutable m_type : Types.module_type ; (** The type of the module. *) mutable m_info : info option ; (** Information found in the optional associated comment. *) m_is_interface : bool ; (** [true] for modules read from interface files *) m_file : string ; (** The file the module is defined in. *) mutable m_kind : module_kind ; (** The way the module is defined. *) mutable m_loc : location ; mutable m_top_deps : Name.t list ; (** The toplevels module names this module depends on. *) mutable m_code : string option ; (** The whole code of the module *) mutable m_code_intf : string option ; (** The whole code of the interface of the module *) m_text_only : bool ; (** [true] if the module comes from a text file *) } and module_type_alias = Odoc_module.module_type_alias = { mta_name : Name.t ; (** Complete name of the target module type. *) mutable mta_module : t_module_type option ; (** The real module type if we could associate it. *) } (** Different kinds of module type. *) and module_type_kind = Odoc_module.module_type_kind = | Module_type_struct of module_element list (** A complete module signature. *) | Module_type_functor of module_parameter * module_type_kind (** A functor, with its parameter and the rest of its definition *) | Module_type_alias of module_type_alias (** Complete alias name and corresponding module type if we found it. *) | Module_type_with of module_type_kind * string (** The module type kind and the code of the with constraint. *) | Module_type_typeof of string (** by now only the code of the module expression *) (** Representation of a module type. *) and t_module_type = Odoc_module.t_module_type = { mt_name : Name.t ; (** Complete name of the module type. *) mutable mt_info : info option ; (** Information found in the optional associated comment. *) mutable mt_type : Types.module_type option ; (** [None] means that the module type is abstract. *) mt_is_interface : bool ; (** [true] for modules read from interface files. *) mt_file : string ; (** The file the module type is defined in. *) mutable mt_kind : module_type_kind option ; (** The way the module is defined. [None] means that module type is abstract. It is always [None] when the module type was extracted from the implementation file. That means module types are only analysed in interface files. *) mutable mt_loc : location ; } (** {3 Functions for modules} *) (** Access to the elements of a module. *) val module_elements : ?trans:bool -> t_module -> module_element list (** Access to the submodules of a module. *) val module_modules : ?trans:bool -> t_module -> t_module list (** Access to the module types of a module. *) val module_module_types : ?trans:bool -> t_module -> t_module_type list (** Access to the included modules of a module. *) val module_included_modules : ?trans:bool-> t_module -> included_module list (** Access to the exceptions of a module. *) val module_exceptions : ?trans:bool-> t_module -> Exception.t_exception list (** Access to the types of a module. *) val module_types : ?trans:bool-> t_module -> Type.t_type list (** Access to the values of a module. *) val module_values : ?trans:bool -> t_module -> Value.t_value list (** Access to functional values of a module. *) val module_functions : ?trans:bool-> t_module -> Value.t_value list (** Access to non-functional values of a module. *) val module_simple_values : ?trans:bool-> t_module -> Value.t_value list (** Access to the classes of a module. *) val module_classes : ?trans:bool-> t_module -> Class.t_class list (** Access to the class types of a module. *) val module_class_types : ?trans:bool-> t_module -> Class.t_class_type list (** The list of classes defined in this module and all its submodules and functors. *) val module_all_classes : ?trans:bool-> t_module -> Class.t_class list (** [true] if the module is functor. *) val module_is_functor : t_module -> bool (** The list of couples (module parameter, optional description). *) val module_parameters : ?trans:bool-> t_module -> (module_parameter * text option) list (** The list of module comments. *) val module_comments : ?trans:bool-> t_module -> text list (** {3 Functions for module types} *) (** Access to the elements of a module type. *) val module_type_elements : ?trans:bool-> t_module_type -> module_element list (** Access to the submodules of a module type. *) val module_type_modules : ?trans:bool-> t_module_type -> t_module list (** Access to the module types of a module type. *) val module_type_module_types : ?trans:bool-> t_module_type -> t_module_type list (** Access to the included modules of a module type. *) val module_type_included_modules : ?trans:bool-> t_module_type -> included_module list (** Access to the exceptions of a module type. *) val module_type_exceptions : ?trans:bool-> t_module_type -> Exception.t_exception list (** Access to the types of a module type. *) val module_type_types : ?trans:bool-> t_module_type -> Type.t_type list (** Access to the values of a module type. *) val module_type_values : ?trans:bool-> t_module_type -> Value.t_value list (** Access to functional values of a module type. *) val module_type_functions : ?trans:bool-> t_module_type -> Value.t_value list (** Access to non-functional values of a module type. *) val module_type_simple_values : ?trans:bool-> t_module_type -> Value.t_value list (** Access to the classes of a module type. *) val module_type_classes : ?trans:bool-> t_module_type -> Class.t_class list (** Access to the class types of a module type. *) val module_type_class_types : ?trans:bool-> t_module_type -> Class.t_class_type list (** The list of classes defined in this module type and all its submodules and functors. *) val module_type_all_classes : ?trans:bool-> t_module_type -> Class.t_class list (** [true] if the module type is functor. *) val module_type_is_functor : t_module_type -> bool (** The list of couples (module parameter, optional description). *) val module_type_parameters : ?trans:bool-> t_module_type -> (module_parameter * text option) list (** The list of module comments. *) val module_type_comments : ?trans:bool-> t_module_type -> text list end (** {3 Getting strings from values} *) (** This function is used to reset the names of type variables. It must be called when printing the whole type of a function, but not when printing the type of its parameters. Same for classes (call it) and methods and attributes (don't call it).*) val reset_type_names : unit -> unit (** [string_of_variance t (covariant, invariant)] returns ["+"] if the given information means "covariant", ["-"] if the it means "contravariant", orelse [""], and always [""] if the given type is not an abstract type with no manifest (i.e. no need for the variance to be printed.*) val string_of_variance : Type.t_type -> (bool * bool) -> string (** This function returns a string representing a Types.type_expr. *) val string_of_type_expr : Types.type_expr -> string (** @return a string to display the parameters of the given class, in the same form as the compiler. *) val string_of_class_params : Class.t_class -> string (** This function returns a string to represent the given list of types, with a given separator. *) val string_of_type_list : ?par: bool -> string -> Types.type_expr list -> string (** This function returns a string to represent the list of type parameters for the given type. *) val string_of_type_param_list : Type.t_type -> string (** This function returns a string to represent the given list of type parameters of a class or class type, with a given separator. *) val string_of_class_type_param_list : Types.type_expr list -> string (** This function returns a string representing a [Types.module_type]. @param complete indicates if we must print complete signatures or just [sig end]. Default if [false]. @param code if [complete = false] and the type contains something else than identificators and functors, then the given code is used. *) val string_of_module_type : ?code: string -> ?complete: bool -> Types.module_type -> string (** This function returns a string representing a [Types.class_type]. @param complete indicates if we must print complete signatures or just [object end]. Default if [false]. *) val string_of_class_type : ?complete: bool -> Types.class_type -> string (** Get a string from a text. *) val string_of_text : text -> string (** Get a string from an info structure. *) val string_of_info : info -> string (** @return a string to describe the given type. *) val string_of_type : Type.t_type -> string (** @return a string to describe the given exception. *) val string_of_exception : Exception.t_exception -> string (** @return a string to describe the given value. *) val string_of_value : Value.t_value -> string (** @return a string to describe the given attribute. *) val string_of_attribute : Value.t_attribute -> string (** @return a string to describe the given method. *) val string_of_method : Value.t_method -> string (** {3 Miscelaneous functions} *) (** Return the first sentence (until the first dot followed by a blank or the first blank line) of a text. Don't stop in the middle of [Code], [CodePre], [Verbatim], [List], [Enum], [Latex], [Link], [Ref], [Subscript] or [Superscript]. *) val first_sentence_of_text : text -> text (** Return the first sentence (until the first dot followed by a blank or the first blank line) of a text, and the remaining text after. Don't stop in the middle of [Code], [CodePre], [Verbatim], [List], [Enum], [Latex], [Link], [Ref], [Subscript] or [Superscript].*) val first_sentence_and_rest_of_text : text -> text * text (** Return the given [text] without any title or list. *) val text_no_title_no_list : text -> text (** [concat sep l] concats the given list of text [l], each separated with the text [sep]. *) val text_concat : Odoc_types.text -> Odoc_types.text list -> Odoc_types.text (** Return the list of titles in a [text]. A title is a title level, an optional label and a text.*) val get_titles_in_text : text -> (int * string option * text) list (** Take a sorted list of elements, a function to get the name of an element and return the list of list of elements, where each list group elements beginning by the same letter. Since the original list is sorted, elements whose name does not begin with a letter should be in the first returned list.*) val create_index_lists : 'a list -> ('a -> string) -> 'a list list (** Take a type and remove the option top constructor. This is useful when printing labels, we we then remove the top option contructor for optional labels.*) val remove_option : Types.type_expr -> Types.type_expr (** Return [true] if the given label is optional.*) val is_optional : string -> bool (** Return the label name for the given label, i.e. removes the beginning '?' if present.*) val label_name : string -> string (** Return the given name where the module name or part of it was removed, according to the list of modules which must be hidden (cf {!Odoc_args.hidden_modules})*) val use_hidden_modules : Name.t -> Name.t (** Print the given string if the verbose mode is activated. *) val verbose : string -> unit (** Print a warning message to stderr. If warnings must be treated as errors, then the error counter is incremented. *) val warning : string -> unit (** A flag to indicate whether ocamldoc warnings must be printed or not. *) val print_warnings : bool ref (** Increment this counter when an error is encountered. The ocamldoc tool will print the number of errors encountered exit with code 1 if this number is greater than 0. *) val errors : int ref (** Apply a function to an optional value. *) val apply_opt : ('a -> 'b) -> 'a option -> 'b option (** Apply a function to a first value if it is not different from a second value. If the two values are different, return the second one.*) val apply_if_equal : ('a -> 'a) -> 'a -> 'a -> 'a (** [text_of_string s] returns the text structure from the given string. @raise Text_syntax if a syntax error is encountered. *) val text_of_string : string -> text (** [text_string_of_text text] returns the string representing the given [text]. This string can then be parsed again by {!Odoc_info.text_of_string}.*) val text_string_of_text : text -> string (** [info_of_string s] parses the given string like a regular ocamldoc comment and return an {!Odoc_info.info} structure. @return an empty structure if there was a syntax error. TODO: change this *) val info_of_string : string -> info (** [info_string_of_info info] returns the string representing the given [info]. This string can then be parsed again by {!Odoc_info.info_of_string}.*) val info_string_of_info : info -> string (** [info_of_comment_file file] parses the given file and return an {!Odoc_info.info} structure. The content of the file must have the same syntax as the content of a special comment. The given module list is used for cross reference. @raise Failure is the file could not be opened or there is a syntax error. *) val info_of_comment_file : Module.t_module list -> string -> info (** [remove_ending_newline s] returns [s] without the optional ending newline. *) val remove_ending_newline : string -> string (** Research in elements *) module Search : sig type result_element = Odoc_search.result_element = Res_module of Module.t_module | Res_module_type of Module.t_module_type | Res_class of Class.t_class | Res_class_type of Class.t_class_type | Res_value of Value.t_value | Res_type of Type.t_type | Res_exception of Exception.t_exception | Res_attribute of Value.t_attribute | Res_method of Value.t_method | Res_section of string * text | Res_recfield of Type.t_type * Type.record_field | Res_const of Type.t_type * Type.variant_constructor (** The type representing a research result.*) type search_result = result_element list (** Research of the elements whose name matches the given regular expression.*) val search_by_name : Module.t_module list -> Str.regexp -> search_result (** A function to search all the values in a list of modules. *) val values : Module.t_module list -> Value.t_value list (** A function to search all the exceptions in a list of modules. *) val exceptions : Module.t_module list -> Exception.t_exception list (** A function to search all the types in a list of modules. *) val types : Module.t_module list -> Type.t_type list (** A function to search all the class attributes in a list of modules. *) val attributes : Module.t_module list -> Value.t_attribute list (** A function to search all the class methods in a list of modules. *) val methods : Module.t_module list -> Value.t_method list (** A function to search all the classes in a list of modules. *) val classes : Module.t_module list -> Class.t_class list (** A function to search all the class types in a list of modules. *) val class_types : Module.t_module list -> Class.t_class_type list (** A function to search all the modules in a list of modules. *) val modules : Module.t_module list -> Module.t_module list (** A function to search all the module types in a list of modules. *) val module_types : Module.t_module list -> Module.t_module_type list end (** Scanning of collected information *) module Scan : sig class scanner : object (** Scan of 'leaf elements'. *) method scan_value : Value.t_value -> unit method scan_type_pre : Type.t_type -> bool method scan_type_const : Type.t_type -> Type.variant_constructor -> unit method scan_type_recfield : Type.t_type -> Type.record_field -> unit method scan_type : Type.t_type -> unit method scan_exception : Exception.t_exception -> unit method scan_attribute : Value.t_attribute -> unit method scan_method : Value.t_method -> unit method scan_included_module : Module.included_module -> unit (** Scan of a class. *) (** Scan of a comment inside a class. *) method scan_class_comment : text -> unit (** Override this method to perform controls on the class comment and params. This method is called before scanning the class elements. @return true if the class elements must be scanned.*) method scan_class_pre : Class.t_class -> bool (** This method scan the elements of the given class. *) method scan_class_elements : Class.t_class -> unit (** Scan of a class. Should not be overridden. It calls [scan_class_pre] and if [scan_class_pre] returns [true], then it calls scan_class_elements.*) method scan_class : Class.t_class -> unit (** Scan of a class type. *) (** Scan of a comment inside a class type. *) method scan_class_type_comment : text -> unit (** Override this method to perform controls on the class type comment and form. This method is called before scanning the class type elements. @return true if the class type elements must be scanned.*) method scan_class_type_pre : Class.t_class_type -> bool (** This method scan the elements of the given class type. *) method scan_class_type_elements : Class.t_class_type -> unit (** Scan of a class type. Should not be overridden. It calls [scan_class_type_pre] and if [scan_class_type_pre] returns [true], then it calls scan_class_type_elements.*) method scan_class_type : Class.t_class_type -> unit (** Scan of modules. *) (** Scan of a comment inside a module. *) method scan_module_comment : text -> unit (** Override this method to perform controls on the module comment and form. This method is called before scanning the module elements. @return true if the module elements must be scanned.*) method scan_module_pre : Module.t_module -> bool (** This method scan the elements of the given module. *) method scan_module_elements : Module.t_module -> unit (** Scan of a module. Should not be overridden. It calls [scan_module_pre] and if [scan_module_pre] returns [true], then it calls scan_module_elements.*) method scan_module : Module.t_module -> unit (** Scan of module types. *) (** Scan of a comment inside a module type. *) method scan_module_type_comment : text -> unit (** Override this method to perform controls on the module type comment and form. This method is called before scanning the module type elements. @return true if the module type elements must be scanned. *) method scan_module_type_pre : Module.t_module_type -> bool (** This method scan the elements of the given module type. *) method scan_module_type_elements : Module.t_module_type -> unit (** Scan of a module type. Should not be overridden. It calls [scan_module_type_pre] and if [scan_module_type_pre] returns [true], then it calls scan_module_type_elements.*) method scan_module_type : Module.t_module_type -> unit (** Main scanning method. *) (** Scan a list of modules. *) method scan_module_list : Module.t_module list -> unit end end (** Computation of dependencies. *) module Dep : sig (** Modify the modules depencies of the given list of modules, to get the minimum transitivity kernel. *) val kernel_deps_of_modules : Module.t_module list -> unit (** Return the list of dependencies between the given types, in the form of a list [(type name, names of types it depends on)]. @param kernel indicates if we must keep only the transitivity kernel of the dependencies. Default is [false]. *) val deps_of_types : ?kernel: bool -> Type.t_type list -> (Type.t_type * (Name.t list)) list end (** {2 Some global variables} *) module Global : sig val errors : int ref val warn_error : bool ref (** The file used by the generators outputting only one file. *) val out_file : string ref (** Verbose mode or not. *) val verbose : bool ref (** The directory where files have to be generated. *) val target_dir : string ref (** The optional title to use in the generated documentation. *) val title : string option ref (** The optional file whose content can be used as intro text. *) val intro_file : string option ref (** The flag which indicates if we must generate a table of contents. *) val with_toc : bool ref (** The flag which indicates if we must generate an index. *) val with_index : bool ref (** The flag which indicates if we must generate a header.*) val with_header : bool ref (** The flag which indicates if we must generate a trailer.*) val with_trailer : bool ref end (** Analysis of the given source files. @param init is the list of modules already known from a previous analysis. @return the list of analysed top modules. *) val analyse_files : ?merge_options:Odoc_types.merge_option list -> ?include_dirs:string list -> ?labels:bool -> ?sort_modules:bool -> ?no_stop:bool -> ?init: Odoc_module.t_module list -> Odoc_global.source_file list -> Module.t_module list (** Dump of a list of modules into a file. @raise Failure if an error occurs.*) val dump_modules : string -> Odoc_module.t_module list -> unit (** Load of a list of modules from a file. @raise Failure if an error occurs.*) val load_modules : string -> Odoc_module.t_module list mingw-ocaml/ocaml/ocamldoc/odoc_test.ml0000644000175000017500000000721012124403242017555 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2004 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Custom generator to perform test on ocamldoc. *) open Odoc_info open Odoc_info.Module open Odoc_info.Type type test_kind = Types_display let p = Format.fprintf module Generator (G : Odoc_gen.Base) = struct class string_gen = object(self) inherit Odoc_info.Scan.scanner val mutable test_kinds = [] val mutable fmt = Format.str_formatter method must_display_types = List.mem Types_display test_kinds method set_test_kinds_from_module m = test_kinds <- List.fold_left (fun acc (s, _) -> match s with "test_types_display" -> Types_display :: acc | _ -> acc ) [] ( match m.m_info with None -> [] | Some i -> i.i_custom ) method! scan_type t = match test_kinds with [] -> () | _ -> p fmt "# type %s:\n" t.ty_name; if self#must_display_types then ( p fmt "# manifest (Odoc_info.string_of_type_expr):\n<[%s]>\n" (match t.ty_manifest with None -> "None" | Some e -> Odoc_info.string_of_type_expr e ); ); method! scan_module_pre m = p fmt "#\n# module %s:\n" m.m_name ; if self#must_display_types then ( p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n" (Odoc_info.string_of_module_type m.m_type); p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n" (Odoc_info.string_of_module_type ~complete: true m.m_type); ); true method! scan_module_type_pre m = p fmt "#\n# module type %s:\n" m.mt_name ; if self#must_display_types then ( p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n" (match m.mt_type with None -> "None" | Some t -> Odoc_info.string_of_module_type t ); p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n" (match m.mt_type with None -> "None" | Some t -> Odoc_info.string_of_module_type ~complete: true t ); ); true method generate (module_list: Odoc_info.Module.t_module list) = let oc = open_out !Odoc_info.Global.out_file in fmt <- Format.formatter_of_out_channel oc; ( try List.iter (fun m -> self#set_test_kinds_from_module m; self#scan_module_list [m]; ) module_list with e -> prerr_endline (Printexc.to_string e) ); Format.pp_print_flush fmt (); close_out oc end class generator = let g = new string_gen in object inherit G.generator as base method generate l = base#generate l; g#generate l end end;; let _ = Odoc_args.extend_base_generator (module Generator : Odoc_gen.Base_functor);; mingw-ocaml/ocaml/ocamldoc/odoc_man.ml0000644000175000017500000011012212124403242017346 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** The man pages generator. *) open Odoc_info open Parameter open Value open Type open Exception open Class open Module open Search let man_suffix = ref Odoc_messages.default_man_suffix let man_section = ref Odoc_messages.default_man_section let man_mini = ref false let new_buf () = Buffer.create 1024 let bp = Printf.bprintf let bs = Buffer.add_string (** A class used to get a [text] for info structures. *) class virtual info = object (self) (** The list of pairs [(tag, f)] where [f] is a function taking the [text] associated to [tag] and returning man code. Add a pair here to handle a tag.*) val mutable tag_functions = ([] : (string * (Odoc_info.text -> string)) list) (** Return man code for a [text]. *) method virtual man_of_text : Buffer.t -> Odoc_info.text -> unit (** Print groff string for an author list. *) method man_of_author_list b l = match l with [] -> () | _ -> bs b ".B \""; bs b Odoc_messages.authors; bs b "\"\n:\n"; bs b (String.concat ", " l); bs b "\n.sp\n" (** Print groff string for the given optional version information.*) method man_of_version_opt b v_opt = match v_opt with None -> () | Some v -> bs b ".B \""; bs b Odoc_messages.version; bs b "\"\n:\n"; bs b v; bs b "\n.sp\n" (** Printf groff string for the \@before information. *) method man_of_before b = function [] -> () | l -> List.iter (fun (v, text) -> bp b ".B \"%s" Odoc_messages.before; bs b v; bs b "\"\n"; self#man_of_text b text; bs b "\n"; bs b "\n.sp\n" ) l (** Print groff string for the given optional since information.*) method man_of_since_opt b s_opt = match s_opt with None -> () | Some s -> bs b ".B \""; bs b Odoc_messages.since; bs b "\"\n"; bs b s; bs b "\n.sp\n" (** Print groff string for the given list of raised exceptions.*) method man_of_raised_exceptions b l = match l with [] -> () | (s, t) :: [] -> bs b ".B \""; bs b Odoc_messages.raises; bs b (" "^s^"\"\n"); self#man_of_text b t; bs b "\n.sp\n" | _ -> bs b ".B \""; bs b Odoc_messages.raises; bs b "\"\n"; List.iter (fun (ex, desc) -> bs b ".sp\n.B \""; bs b ex; bs b "\"\n"; self#man_of_text b desc; bs b "\n" ) l; bs b "\n.sp\n" (** Print groff string for the given "see also" reference. *) method man_of_see b (see_ref, t) = let t_ref = match see_ref with Odoc_info.See_url s -> [ Odoc_info.Link (s, t) ] | Odoc_info.See_file s -> (Odoc_info.Code s) :: (Odoc_info.Raw " ") :: t | Odoc_info.See_doc s -> (Odoc_info.Italic [Odoc_info.Raw s]) :: (Odoc_info.Raw " ") :: t in self#man_of_text b t_ref (** Print groff string for the given list of "see also" references.*) method man_of_sees b l = match l with [] -> () | see :: [] -> bs b ".B \""; bs b Odoc_messages.see_also; bs b "\"\n"; self#man_of_see b see; bs b "\n.sp\n" | _ -> bs b ".B \""; bs b Odoc_messages.see_also; bs b "\"\n"; List.iter (fun see -> bs b ".sp\n"; self#man_of_see b see; bs b "\n" ) l; bs b "\n.sp\n" (** Print groff string for the given optional return information.*) method man_of_return_opt b return_opt = match return_opt with None -> () | Some s -> bs b ".B "; bs b Odoc_messages.returns; bs b "\n"; self#man_of_text b s; bs b "\n.sp\n" (** Print man code for the given list of custom tagged texts. *) method man_of_custom b l = let buf = Buffer.create 50 in List.iter (fun (tag, text) -> try let f = List.assoc tag tag_functions in Buffer.add_string buf (f text) with Not_found -> Odoc_info.warning (Odoc_messages.tag_not_handled tag) ) l (** Print the groff string to display an optional info structure. *) method man_of_info b info_opt = match info_opt with None -> () | Some info -> let module M = Odoc_info in ( match info.M.i_deprecated with None -> () | Some d -> bs b ".B \""; bs b Odoc_messages.deprecated; bs b "\"\n"; self#man_of_text b d; bs b "\n.sp\n" ); ( match info.M.i_desc with None -> () | Some d when d = [Odoc_info.Raw ""] -> () | Some d -> self#man_of_text b d; bs b "\n.sp\n" ); self#man_of_author_list b info.M.i_authors; self#man_of_version_opt b info.M.i_version; self#man_of_before b info.M.i_before; self#man_of_since_opt b info.M.i_since; self#man_of_raised_exceptions b info.M.i_raised_exceptions; self#man_of_return_opt b info.M.i_return_value; self#man_of_sees b info.M.i_sees; self#man_of_custom b info.M.i_custom end module Generator = struct (** This class is used to create objects which can generate a simple html documentation. *) class man = let re_slash = Str.regexp_string "/" in object (self) inherit info (** Get a file name from a complete name. *) method file_name name = let s = Printf.sprintf "%s.%s" name !man_suffix in Str.global_replace re_slash "slash" s (** Escape special sequences of characters in a string. *) method escape (s : string) = let len = String.length s in let b = Buffer.create len in for i = 0 to len - 1 do match s.[i] with '\\' -> Buffer.add_string b "\\(rs" | '.' -> Buffer.add_string b "\\&." | '\'' -> Buffer.add_string b "\\&'" | '-' -> Buffer.add_string b "\\-" | c -> Buffer.add_char b c done; Buffer.contents b (** Open a file for output. Add the target directory.*) method open_out file = let f = Filename.concat !Global.target_dir file in open_out f (** Print groff string for a text, without correction of blanks. *) method private man_of_text2 b t = List.iter (self#man_of_text_element b) t (** Print the groff string for a text, with blanks corrected. *) method man_of_text b t = let b2 = new_buf () in self#man_of_text2 b2 t ; let s = Buffer.contents b2 in let s2 = Str.global_replace (Str.regexp "\n[ ]*") "\n" s in bs b (Str.global_replace (Str.regexp "\n\n") "\n" s2) (** Return the given string without no newlines. *) method remove_newlines s = Str.global_replace (Str.regexp "[ ]*\n[ ]*") " " s (** Print the groff string for a text element. *) method man_of_text_element b te = match te with | Odoc_info.Raw s -> bs b (self#escape s) | Odoc_info.Code s -> bs b "\n.B "; bs b ((Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n") | Odoc_info.CodePre s -> bs b "\n.B "; bs b ((Str.global_replace (Str.regexp "\n") "\n.B " (self#escape s))^"\n") | Odoc_info.Verbatim s -> bs b (self#escape s) | Odoc_info.Bold t | Odoc_info.Italic t | Odoc_info.Emphasize t | Odoc_info.Center t | Odoc_info.Left t | Odoc_info.Right t -> self#man_of_text2 b t | Odoc_info.List tl -> List.iter (fun t -> bs b "\n.sp\n \\-"; self#man_of_text2 b t; bs b "\n") tl; bs b "\n" | Odoc_info.Enum tl -> List.iter (fun t -> bs b "\n.sp\n \\-"; self#man_of_text2 b t; bs b "\n") tl; bs b "\n" | Odoc_info.Newline -> bs b "\n.sp\n" | Odoc_info.Block t -> bs b "\n.sp\n"; self#man_of_text2 b t; bs b "\n.sp\n" | Odoc_info.Title (n, l_opt, t) -> self#man_of_text2 b [Odoc_info.Code (Odoc_info.string_of_text t)] | Odoc_info.Latex _ -> (* don't care about LaTeX stuff in HTML. *) () | Odoc_info.Link (s, t) -> self#man_of_text2 b t | Odoc_info.Ref (name, _, _) -> self#man_of_text_element b (Odoc_info.Code (Odoc_info.use_hidden_modules name)) | Odoc_info.Superscript t -> bs b "^{"; self#man_of_text2 b t | Odoc_info.Subscript t -> bs b "_{"; self#man_of_text2 b t | Odoc_info.Module_list _ -> () | Odoc_info.Index_list -> () | Odoc_info.Custom (s,t) -> self#man_of_custom_text b s t | Odoc_info.Target (target, code) -> self#man_of_Target b ~target ~code method man_of_custom_text b s t = () method man_of_Target b ~target ~code = if String.lowercase target = "man" then bs b code else () (** Print groff string to display code. *) method man_of_code b s = self#man_of_text b [ Code s ] (** Take a string and return the string where fully qualified idents have been replaced by idents relative to the given module name.*) method relative_idents m_name s = let f str_t = let match_s = Str.matched_string str_t in Odoc_info.apply_if_equal Odoc_info.use_hidden_modules match_s (Name.get_relative m_name match_s) in let s2 = Str.global_substitute (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([a-z][a-zA-Z_'0-9]*\\)") f s in s2 (** Print groff string to display a [Types.type_expr].*) method man_of_type_expr b m_name t = let s = String.concat "\n" (Str.split (Str.regexp "\n") (Odoc_print.string_of_type_expr t)) in let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in bs b "\n.B "; bs b (self#relative_idents m_name s2); bs b "\n" (** Print groff string to display a [Types.class_type].*) method man_of_class_type_expr b m_name t = let s = String.concat "\n" (Str.split (Str.regexp "\n") (Odoc_print.string_of_class_type t)) in let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in bs b "\n.B "; bs b (self#relative_idents m_name s2); bs b "\n" (** Print groff string to display a [Types.type_expr list].*) method man_of_type_expr_list ?par b m_name sep l = let s = Odoc_str.string_of_type_list ?par sep l in let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in bs b "\n.B "; bs b (self#relative_idents m_name s2); bs b "\n" (** Print groff string to display the parameters of a type.*) method man_of_type_expr_param_list b m_name t = match t.ty_parameters with [] -> () | l -> let s = Odoc_str.string_of_type_param_list t in let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in bs b "\n.B "; bs b (self#relative_idents m_name s2); bs b "\n" (** Print groff string to display a [Types.module_type]. *) method man_of_module_type b m_name t = let s = String.concat "\n" (Str.split (Str.regexp "\n") (Odoc_print.string_of_module_type t)) in let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in bs b "\n.B "; bs b (self#relative_idents m_name s2); bs b "\n" (** Print groff string code for a value. *) method man_of_value b v = Odoc_info.reset_type_names () ; bs b "\n.I val "; bs b (Name.simple v.val_name); bs b " \n: "; self#man_of_type_expr b (Name.father v.val_name) v.val_type; bs b ".sp\n"; self#man_of_info b v.val_info; bs b "\n.sp\n" (** Print groff string code for an exception. *) method man_of_exception b e = Odoc_info.reset_type_names () ; bs b "\n.I exception "; bs b (Name.simple e.ex_name); bs b " \n"; ( match e.ex_args with [] -> () | _ -> bs b ".B of "; self#man_of_type_expr_list ~par: false b (Name.father e.ex_name) " * " e.ex_args ); ( match e.ex_alias with None -> () | Some ea -> bs b " = "; bs b ( match ea.ea_ex with None -> ea.ea_name | Some e -> e.ex_name ) ); bs b "\n.sp\n"; self#man_of_info b e.ex_info; bs b "\n.sp\n" (** Print groff string for a type. *) method man_of_type b t = Odoc_info.reset_type_names () ; let father = Name.father t.ty_name in bs b ".I type "; self#man_of_type_expr_param_list b father t; ( match t.ty_parameters with [] -> () | _ -> bs b ".I " ); bs b (Name.simple t.ty_name); bs b " \n"; let priv = t.ty_private = Asttypes.Private in ( match t.ty_manifest with None -> () | Some typ -> bs b "= "; if priv then bs b "private "; self#man_of_type_expr b father typ ); ( match t.ty_kind with Type_abstract -> () | Type_variant l -> bs b "="; if priv then bs b " private"; bs b "\n "; List.iter (fun constr -> bs b ("| "^constr.vc_name); ( match constr.vc_args, constr.vc_text,constr.vc_ret with | [], None, None -> bs b "\n " | [], (Some t), None -> bs b " (* "; self#man_of_text b t; bs b " *)\n " | l, None, None -> bs b "\n.B of "; self#man_of_type_expr_list ~par: false b father " * " l; bs b " " | l, (Some t), None -> bs b "\n.B of "; self#man_of_type_expr_list ~par: false b father " * " l; bs b ".I \" \"\n"; bs b "(* "; self#man_of_text b t; bs b " *)\n " | [], None, Some r -> bs b "\n.B : "; self#man_of_type_expr b father r; bs b " " | [], (Some t), Some r -> bs b "\n.B : "; self#man_of_type_expr b father r; bs b ".I \" \"\n"; bs b "(* "; self#man_of_text b t; bs b " *)\n " | l, None, Some r -> bs b "\n.B : "; self#man_of_type_expr_list ~par: false b father " * " l; bs b ".B -> "; self#man_of_type_expr b father r; bs b " " | l, (Some t), Some r -> bs b "\n.B of "; self#man_of_type_expr_list ~par: false b father " * " l; bs b ".B -> "; self#man_of_type_expr b father r; bs b ".I \" \"\n"; bs b "(* "; self#man_of_text b t; bs b " *)\n " ) ) l | Type_record l -> bs b "= "; if priv then bs b "private "; bs b "{"; List.iter (fun r -> bs b (if r.rf_mutable then "\n\n.B mutable \n" else "\n "); bs b (r.rf_name^" : "); self#man_of_type_expr b father r.rf_type; bs b ";"; ( match r.rf_text with None -> () | Some t -> bs b " (* "; self#man_of_text b t; bs b " *) " ); ) l; bs b "\n }\n" ); bs b "\n.sp\n"; self#man_of_info b t.ty_info; bs b "\n.sp\n" (** Print groff string for a class attribute. *) method man_of_attribute b a = bs b ".I val "; if a.att_virtual then bs b ("virtual "); if a.att_mutable then bs b (Odoc_messages.mutab^" "); bs b ((Name.simple a.att_value.val_name)^" : "); self#man_of_type_expr b (Name.father a.att_value.val_name) a.att_value.val_type; bs b "\n.sp\n"; self#man_of_info b a.att_value.val_info; bs b "\n.sp\n" (** Print groff string for a class method. *) method man_of_method b m = bs b ".I method "; if m.met_private then bs b "private "; if m.met_virtual then bs b "virtual "; bs b ((Name.simple m.met_value.val_name)^" : "); self#man_of_type_expr b (Name.father m.met_value.val_name) m.met_value.val_type; bs b "\n.sp\n"; self#man_of_info b m.met_value.val_info; bs b "\n.sp\n" (** Groff for a list of parameters. *) method man_of_parameter_list b m_name l = match l with [] -> () | _ -> bs b "\n.B "; bs b Odoc_messages.parameters; bs b ": \n"; List.iter (fun p -> bs b ".sp\n"; bs b "\""; bs b (Parameter.complete_name p); bs b "\"\n"; self#man_of_type_expr b m_name (Parameter.typ p); bs b "\n"; self#man_of_parameter_description b p; bs b "\n" ) l; bs b "\n" (** Groff for the description of a function parameter. *) method man_of_parameter_description b p = match Parameter.names p with [] -> () | name :: [] -> ( (* Only one name, no need for label for the description. *) match Parameter.desc_by_name p name with None -> () | Some t -> bs b "\n "; self#man_of_text b t ) | l -> (* A list of names, we display those with a description. *) List.iter (fun n -> match Parameter.desc_by_name p n with None -> () | Some t -> self#man_of_code b (n^" : "); self#man_of_text b t ) l (** Print groff string for a list of module parameters. *) method man_of_module_parameter_list b m_name l = match l with [] -> () | _ -> bs b ".B \""; bs b Odoc_messages.parameters; bs b ":\"\n"; List.iter (fun (p, desc_opt) -> bs b ".sp\n"; bs b ("\""^p.mp_name^"\"\n"); self#man_of_module_type b m_name p.mp_type; bs b "\n"; ( match desc_opt with None -> () | Some t -> self#man_of_text b t ); bs b "\n" ) l; bs b "\n\n" (** Print groff string for a class. *) method man_of_class b c = Odoc_info.reset_type_names () ; let father = Name.father c.cl_name in bs b ".I class "; if c.cl_virtual then bs b "virtual "; ( match c.cl_type_parameters with [] -> () | l -> bs b (Odoc_str.string_of_class_type_param_list l); bs b " " ); bs b (Name.simple c.cl_name); bs b " : " ; self#man_of_class_type_expr b father c.cl_type; bs b "\n.sp\n"; self#man_of_info b c.cl_info; bs b "\n.sp\n" (** Print groff string for a class type. *) method man_of_class_type b ct = Odoc_info.reset_type_names () ; bs b ".I class type "; if ct.clt_virtual then bs b "virtual " ; ( match ct.clt_type_parameters with [] -> () | l -> bs b (Odoc_str.string_of_class_type_param_list l); bs b " " ); bs b (Name.simple ct.clt_name); bs b " = " ; self#man_of_class_type_expr b (Name.father ct.clt_name) ct.clt_type; bs b "\n.sp\n"; self#man_of_info b ct.clt_info; bs b "\n.sp\n" (** Print groff string for a module. *) method man_of_module b m = bs b ".I module "; bs b (Name.simple m.m_name); bs b " : "; self#man_of_module_type b (Name.father m.m_name) m.m_type; bs b "\n.sp\n"; self#man_of_info b m.m_info; bs b "\n.sp\n" (** Print groff string for a module type. *) method man_of_modtype b mt = bs b ".I module type "; bs b (Name.simple mt.mt_name); bs b " = "; (match mt.mt_type with None -> () | Some t -> self#man_of_module_type b (Name.father mt.mt_name) t ); bs b "\n.sp\n"; self#man_of_info b mt.mt_info; bs b "\n.sp\n" (** Print groff string for a module comment.*) method man_of_module_comment b text = bs b "\n.PP\n"; self#man_of_text b [Code ("=== "^(Odoc_misc.string_of_text text)^" ===")]; bs b "\n.PP\n" (** Print groff string for a class comment.*) method man_of_class_comment b text = bs b "\n.PP\n"; self#man_of_text b [Code ("=== "^(Odoc_misc.string_of_text text)^" ===")]; bs b "\n.PP\n" (** Print groff string for an included module. *) method man_of_included_module b m_name im = bs b ".I include "; ( match im.im_module with None -> bs b im.im_name | Some mmt -> let name = match mmt with Mod m -> m.m_name | Modtype mt -> mt.mt_name in bs b (self#relative_idents m_name name) ); bs b "\n.sp\n"; self#man_of_info b im.im_info; bs b "\n.sp\n" (** Generate the man page for the given class.*) method generate_for_class cl = Odoc_info.reset_type_names () ; let date = Unix.time () in let file = self#file_name cl.cl_name in try let chanout = self#open_out file in let b = new_buf () in bs b (".TH \""^cl.cl_name^"\" "); bs b !man_section ; bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" "); bs b "OCamldoc "; bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n"); let abstract = match cl.cl_info with None | Some { i_desc = None } -> "no description" | Some { i_desc = Some t } -> let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in self#remove_newlines s in bs b ".SH NAME\n"; bs b (cl.cl_name^" \\- "^abstract^"\n"); bs b (".SH "^Odoc_messages.clas^"\n"); bs b (Odoc_messages.clas^" "^cl.cl_name^"\n"); bs b (".SH "^Odoc_messages.documentation^"\n"); bs b ".sp\n"; self#man_of_class b cl; (* parameters *) self#man_of_parameter_list b "" cl.cl_parameters; (* a large blank *) bs b "\n.sp\n.sp\n"; (* (* class inheritance *) self#generate_class_inheritance_info chanout cl; *) (* the various elements *) List.iter (fun element -> match element with Class_attribute a -> self#man_of_attribute b a | Class_method m -> self#man_of_method b m | Class_comment t -> self#man_of_class_comment b t ) (Class.class_elements cl); Buffer.output_buffer chanout b; close_out chanout with Sys_error s -> incr Odoc_info.errors ; prerr_endline s (** Generate the man page for the given class type.*) method generate_for_class_type ct = Odoc_info.reset_type_names () ; let date = Unix.time () in let file = self#file_name ct.clt_name in try let chanout = self#open_out file in let b = new_buf () in bs b (".TH \""^ct.clt_name^"\" "); bs b !man_section ; bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" "); bs b "OCamldoc "; bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n"); let abstract = match ct.clt_info with None | Some { i_desc = None } -> "no description" | Some { i_desc = Some t } -> let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in self#remove_newlines s in bs b ".SH NAME\n"; bs b (ct.clt_name^" \\- "^abstract^"\n"); bs b (".SH "^Odoc_messages.class_type^"\n"); bs b (Odoc_messages.class_type^" "^ct.clt_name^"\n"); bs b (".SH "^Odoc_messages.documentation^"\n"); bs b ".sp\n"; self#man_of_class_type b ct; (* a large blank *) bs b "\n.sp\n.sp\n"; (* (* class inheritance *) self#generate_class_inheritance_info chanout cl; *) (* the various elements *) List.iter (fun element -> match element with Class_attribute a -> self#man_of_attribute b a | Class_method m -> self#man_of_method b m | Class_comment t -> self#man_of_class_comment b t ) (Class.class_type_elements ct); Buffer.output_buffer chanout b; close_out chanout with Sys_error s -> incr Odoc_info.errors ; prerr_endline s (** Generate the man file for the given module type. @raise Failure if an error occurs.*) method generate_for_module_type mt = let date = Unix.time () in let file = self#file_name mt.mt_name in try let chanout = self#open_out file in let b = new_buf () in bs b (".TH \""^mt.mt_name^"\" "); bs b !man_section ; bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" "); bs b "OCamldoc "; bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n"); let abstract = match mt.mt_info with None | Some { i_desc = None } -> "no description" | Some { i_desc = Some t } -> let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in self#remove_newlines s in bs b ".SH NAME\n"; bs b (mt.mt_name^" \\- "^abstract^"\n"); bs b (".SH "^Odoc_messages.module_type^"\n"); bs b (Odoc_messages.module_type^" "^mt.mt_name^"\n"); bs b (".SH "^Odoc_messages.documentation^"\n"); bs b ".sp\n"; bs b (Odoc_messages.module_type^"\n"); bs b (".BI \""^(Name.simple mt.mt_name)^"\"\n"); bs b " = "; ( match mt.mt_type with None -> () | Some t -> self#man_of_module_type b (Name.father mt.mt_name) t ); bs b "\n.sp\n"; self#man_of_info b mt.mt_info; bs b "\n.sp\n"; (* parameters for functors *) self#man_of_module_parameter_list b "" (Module.module_type_parameters mt); (* a large blank *) bs b "\n.sp\n.sp\n"; (* module elements *) List.iter (fun ele -> match ele with Element_module m -> self#man_of_module b m | Element_module_type mt -> self#man_of_modtype b mt | Element_included_module im -> self#man_of_included_module b mt.mt_name im | Element_class c -> self#man_of_class b c | Element_class_type ct -> self#man_of_class_type b ct | Element_value v -> self#man_of_value b v | Element_exception e -> self#man_of_exception b e | Element_type t -> self#man_of_type b t | Element_module_comment text -> self#man_of_module_comment b text ) (Module.module_type_elements mt); Buffer.output_buffer chanout b; close_out chanout with Sys_error s -> incr Odoc_info.errors ; prerr_endline s (** Generate the man file for the given module. @raise Failure if an error occurs.*) method generate_for_module m = let date = Unix.time () in let file = self#file_name m.m_name in try let chanout = self#open_out file in let b = new_buf () in bs b (".TH \""^m.m_name^"\" "); bs b !man_section ; bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" "); bs b "OCamldoc "; bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n"); let abstract = match m.m_info with None | Some { i_desc = None } -> "no description" | Some { i_desc = Some t } -> let s = Odoc_info.string_of_text (Odoc_info.first_sentence_of_text t) in self#remove_newlines s in bs b ".SH NAME\n"; bs b (m.m_name^" \\- "^abstract^"\n"); bs b (".SH "^Odoc_messages.modul^"\n"); bs b (Odoc_messages.modul^" "^m.m_name^"\n"); bs b (".SH "^Odoc_messages.documentation^"\n"); bs b ".sp\n"; bs b (Odoc_messages.modul^"\n"); bs b (".BI \""^(Name.simple m.m_name)^"\"\n"); bs b " : "; self#man_of_module_type b (Name.father m.m_name) m.m_type; bs b "\n.sp\n"; self#man_of_info b m.m_info; bs b "\n.sp\n"; (* parameters for functors *) self#man_of_module_parameter_list b "" (Module.module_parameters m); (* a large blank *) bs b "\n.sp\n.sp\n"; (* module elements *) List.iter (fun ele -> match ele with Element_module m -> self#man_of_module b m | Element_module_type mt -> self#man_of_modtype b mt | Element_included_module im -> self#man_of_included_module b m.m_name im | Element_class c -> self#man_of_class b c | Element_class_type ct -> self#man_of_class_type b ct | Element_value v -> self#man_of_value b v | Element_exception e -> self#man_of_exception b e | Element_type t -> self#man_of_type b t | Element_module_comment text -> self#man_of_module_comment b text ) (Module.module_elements m); Buffer.output_buffer chanout b; close_out chanout with Sys_error s -> raise (Failure s) (** Create the groups of elements to generate pages for. *) method create_groups module_list = let name res_ele = match res_ele with Res_module m -> m.m_name | Res_module_type mt -> mt.mt_name | Res_class c -> c.cl_name | Res_class_type ct -> ct.clt_name | Res_value v -> Name.simple v.val_name | Res_type t -> Name.simple t.ty_name | Res_exception e -> Name.simple e.ex_name | Res_attribute a -> Name.simple a.att_value.val_name | Res_method m -> Name.simple m.met_value.val_name | Res_section _ -> assert false | Res_recfield (_,f) -> f.rf_name | Res_const (_,f) -> f.vc_name in let all_items_pre = Odoc_info.Search.search_by_name module_list (Str.regexp ".*") in let all_items = List.filter (fun r -> match r with Res_section _ -> false | _ -> true) all_items_pre in let sorted_items = List.sort (fun e1 -> fun e2 -> compare (name e1) (name e2)) all_items in let rec f acc1 acc2 l = match l with [] -> acc2 :: acc1 | h :: q -> match acc2 with [] -> f acc1 [h] q | h2 :: q2 -> if (name h) = (name h2) then if List.mem h acc2 then f acc1 acc2 q else f acc1 (acc2 @ [h]) q else f (acc2 :: acc1) [h] q in f [] [] sorted_items (** Generate a man page for a group of elements with the same name. A group must not be empty.*) method generate_for_group l = let name = Name.simple ( match List.hd l with Res_module m -> m.m_name | Res_module_type mt -> mt.mt_name | Res_class c -> c.cl_name | Res_class_type ct -> ct.clt_name | Res_value v -> v.val_name | Res_type t -> t.ty_name | Res_exception e -> e.ex_name | Res_attribute a -> a.att_value.val_name | Res_method m -> m.met_value.val_name | Res_section (s,_) -> s | Res_recfield (_,f) -> f.rf_name | Res_const (_,f) -> f.vc_name ) in let date = Unix.time () in let file = self#file_name name in try let chanout = self#open_out file in let b = new_buf () in bs b (".TH \""^name^"\" "); bs b !man_section ; bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" "); bs b "OCamldoc "; bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n"); bs b ".SH NAME\n"; bs b (name^" \\- all "^name^" elements\n\n"); let f ele = match ele with Res_value v -> bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father v.val_name)^"\n"); self#man_of_value b v | Res_type t -> bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father t.ty_name)^"\n"); self#man_of_type b t | Res_exception e -> bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father e.ex_name)^"\n"); self#man_of_exception b e | Res_attribute a -> bs b ("\n.SH "^Odoc_messages.clas^" "^(Name.father a.att_value.val_name)^"\n"); self#man_of_attribute b a | Res_method m -> bs b ("\n.SH "^Odoc_messages.clas^" "^(Name.father m.met_value.val_name)^"\n"); self#man_of_method b m | Res_class c -> bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father c.cl_name)^"\n"); self#man_of_class b c | Res_class_type ct -> bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father ct.clt_name)^"\n"); self#man_of_class_type b ct | _ -> (* normalement on ne peut pas avoir de module ici. *) () in List.iter f l; Buffer.output_buffer chanout b; close_out chanout with Sys_error s -> incr Odoc_info.errors ; prerr_endline s (** Generate all the man pages from a module list. *) method generate module_list = let sorted_module_list = Sort.list (fun m1 -> fun m2 -> m1.m_name < m2.m_name) module_list in let groups = self#create_groups sorted_module_list in let f group = match group with [] -> () | [Res_module m] -> self#generate_for_module m | [Res_module_type mt] -> self#generate_for_module_type mt | [Res_class cl] -> self#generate_for_class cl | [Res_class_type ct] -> self#generate_for_class_type ct | l -> if !man_mini then () else self#generate_for_group l in List.iter f groups end end module type Man_generator = module type of Generator mingw-ocaml/ocaml/ocamldoc/odoc_sig.ml0000644000175000017500000016460312124403242017372 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Analysis of interface files. *) open Misc open Asttypes open Types open Typedtree open Path let print_DEBUG s = print_string s ; print_newline ();; module Name = Odoc_name open Odoc_parameter open Odoc_value open Odoc_type open Odoc_exception open Odoc_class open Odoc_module open Odoc_types module Signature_search = struct type ele = | M of string | MT of string | V of string | T of string | C of string | CT of string | E of string | ER of string | P of string type tab = (ele, Types.signature_item) Hashtbl.t let add_to_hash table signat = match signat with Types.Sig_value (ident, _) -> Hashtbl.add table (V (Name.from_ident ident)) signat | Types.Sig_exception (ident, _) -> Hashtbl.add table (E (Name.from_ident ident)) signat | Types.Sig_type (ident, _, _) -> Hashtbl.add table (T (Name.from_ident ident)) signat | Types.Sig_class (ident, _, _) -> Hashtbl.add table (C (Name.from_ident ident)) signat | Types.Sig_class_type (ident, _, _) -> Hashtbl.add table (CT (Name.from_ident ident)) signat | Types.Sig_module (ident, _, _) -> Hashtbl.add table (M (Name.from_ident ident)) signat | Types.Sig_modtype (ident,_) -> Hashtbl.add table (MT (Name.from_ident ident)) signat let table signat = let t = Hashtbl.create 13 in List.iter (add_to_hash t) signat; t let search_value table name = match Hashtbl.find table (V name) with | (Types.Sig_value (_, val_desc)) -> val_desc.Types.val_type | _ -> assert false let search_exception table name = match Hashtbl.find table (E name) with | (Types.Sig_exception (_, type_expr_list)) -> type_expr_list | _ -> assert false let search_type table name = match Hashtbl.find table (T name) with | (Types.Sig_type (_, type_decl, _)) -> type_decl | _ -> assert false let search_class table name = match Hashtbl.find table (C name) with | (Types.Sig_class (_, class_decl, _)) -> class_decl | _ -> assert false let search_class_type table name = match Hashtbl.find table (CT name) with | (Types.Sig_class_type (_, cltype_decl, _)) -> cltype_decl | _ -> assert false let search_module table name = match Hashtbl.find table (M name) with | (Types.Sig_module (ident, module_type, _)) -> module_type | _ -> assert false let search_module_type table name = match Hashtbl.find table (MT name) with | (Types.Sig_modtype (_, Types.Modtype_manifest module_type)) -> Some module_type | (Types.Sig_modtype (_, Types.Modtype_abstract)) -> None | _ -> assert false let search_attribute_type name class_sig = let (_, _, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in type_expr let search_method_type name class_sig = let fields = Odoc_misc.get_fields class_sig.Types.cty_self in List.assoc name fields end module type Info_retriever = sig val all_special : string -> string -> int * (Odoc_types.info list) val blank_line_outside_simple : string -> string -> bool val just_after_special : string -> string -> (int * Odoc_types.info option) val first_special : string -> string -> (int * Odoc_types.info option) val get_comments : (Odoc_types.text -> 'a) -> string -> string -> (Odoc_types.info option * 'a list) end module Analyser = functor (My_ir : Info_retriever) -> struct (** This variable is used to load a file as a string and retrieve characters from it.*) let file = ref "" (** The name of the analysed file. *) let file_name = ref "" (** This function takes two indexes (start and end) and return the string corresponding to the indexes in the file global variable. The function prepare_file must have been called to fill the file global variable.*) let get_string_of_file the_start the_end = try let s = String.sub !file the_start (the_end-the_start) in s with Invalid_argument _ -> "" (** This function loads the given file in the file global variable, and sets file_name.*) let prepare_file f input_f = try let s = Odoc_misc.input_file_as_string input_f in file := s; file_name := f with e -> file := ""; raise e (** The function used to get the comments in a class. *) let get_comments_in_class pos_start pos_end = My_ir.get_comments (fun t -> Class_comment t) !file_name (get_string_of_file pos_start pos_end) (** The function used to get the comments in a module. *) let get_comments_in_module pos_start pos_end = My_ir.get_comments (fun t -> Element_module_comment t) !file_name (get_string_of_file pos_start pos_end) let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options let name_comment_from_type_kind pos_end pos_limit tk = match tk with Parsetree.Ptype_abstract -> (0, []) | Parsetree.Ptype_variant cons_core_type_list_list -> let rec f acc cons_core_type_list_list = match cons_core_type_list_list with [] -> (0, acc) | (name, _, _, loc) :: [] -> let s = get_string_of_file loc.Location.loc_end.Lexing.pos_cnum pos_limit in let (len, comment_opt) = My_ir.just_after_special !file_name s in (len, acc @ [ (name.txt, comment_opt) ]) | (name, _, _, loc) :: (name2, core_type_list2, ret_type2, loc2) :: q -> let pos_end_first = loc.Location.loc_end.Lexing.pos_cnum in let pos_start_second = loc2.Location.loc_start.Lexing.pos_cnum in let s = get_string_of_file pos_end_first pos_start_second in let (_,comment_opt) = My_ir.just_after_special !file_name s in f (acc @ [name.txt, comment_opt]) ((name2, core_type_list2, ret_type2, loc2) :: q) in f [] cons_core_type_list_list | Parsetree.Ptype_record name_mutable_type_list (* of (string * mutable_flag * core_type) list*) -> let rec f = function [] -> [] | (name, _, ct, xxloc) :: [] -> let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in let s = get_string_of_file pos pos_end in let (_,comment_opt) = My_ir.just_after_special !file_name s in [name.txt, comment_opt] | (name,_,ct,xxloc) :: ((name2,_,ct2,xxloc2) as ele2) :: q -> let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in let s = get_string_of_file pos pos2 in let (_,comment_opt) = My_ir.just_after_special !file_name s in (name.txt, comment_opt) :: (f (ele2 :: q)) in (0, f name_mutable_type_list) let get_type_kind env name_comment_list type_kind = match type_kind with Types.Type_abstract -> Odoc_type.Type_abstract | Types.Type_variant l -> let f (constructor_name, type_expr_list, ret_type) = let constructor_name = Ident.name constructor_name in let comment_opt = try match List.assoc constructor_name name_comment_list with None -> None | Some d -> d.Odoc_types.i_desc with Not_found -> None in { vc_name = constructor_name ; vc_args = List.map (Odoc_env.subst_type env) type_expr_list ; vc_ret = may_map (Odoc_env.subst_type env) ret_type; vc_text = comment_opt } in Odoc_type.Type_variant (List.map f l) | Types.Type_record (l, _) -> let f (field_name, mutable_flag, type_expr) = let field_name = Ident.name field_name in let comment_opt = try match List.assoc field_name name_comment_list with None -> None | Some d -> d.Odoc_types.i_desc with Not_found -> None in { rf_name = field_name ; rf_mutable = mutable_flag = Mutable ; rf_type = Odoc_env.subst_type env type_expr ; rf_text = comment_opt } in Odoc_type.Type_record (List.map f l) let erased_names_of_constraints constraints acc = List.fold_right (fun (longident, constraint_) acc -> match constraint_ with | Parsetree.Pwith_type _ | Parsetree.Pwith_module _ -> acc | Parsetree.Pwith_typesubst _ | Parsetree.Pwith_modsubst _ -> Name.Set.add (Name.from_longident longident.txt) acc) constraints acc let filter_out_erased_items_from_signature erased signature = if Name.Set.is_empty erased then signature else List.fold_right (fun sig_item acc -> let take_item psig_desc = { sig_item with Parsetree.psig_desc } :: acc in match sig_item.Parsetree.psig_desc with | Parsetree.Psig_value (_, _) | Parsetree.Psig_exception (_, _) | Parsetree.Psig_open _ | Parsetree.Psig_include _ | Parsetree.Psig_class _ | Parsetree.Psig_class_type _ as tp -> take_item tp | Parsetree.Psig_type types -> (match List.filter (fun (name, _) -> not (Name.Set.mem name.txt erased)) types with | [] -> acc | types -> take_item (Parsetree.Psig_type types)) | Parsetree.Psig_module (name, _) | Parsetree.Psig_modtype (name, _) as m -> if Name.Set.mem name.txt erased then acc else take_item m | Parsetree.Psig_recmodule mods -> (match List.filter (fun (name, _) -> not (Name.Set.mem name.txt erased)) mods with | [] -> acc | mods -> take_item (Parsetree.Psig_recmodule mods))) signature [] (** Analysis of the elements of a class, from the information in the parsetree and in the class signature. @return the couple (inherited_class list, elements).*) let analyse_class_elements env current_class_name last_pos pos_limit class_type_field_list class_signature = let get_pos_limit2 q = match q with [] -> pos_limit | ele2 :: _ -> let loc = ele2.Parsetree.pctf_loc in match ele2.Parsetree.pctf_desc with Parsetree.Pctf_val (_, _, _, _) | Parsetree.Pctf_virt (_, _, _) | Parsetree.Pctf_meth (_, _, _) | Parsetree.Pctf_cstr (_, _) -> loc.Location.loc_start.Lexing.pos_cnum | Parsetree.Pctf_inher class_type -> class_type.Parsetree.pcty_loc.Location.loc_start.Lexing.pos_cnum in let get_method name comment_opt private_flag loc q = let complete_name = Name.concat current_class_name name in let typ = try Signature_search.search_method_type name class_signature with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name name)) in let subst_typ = Odoc_env.subst_type env typ in let met = { met_value = { val_name = complete_name ; val_info = comment_opt ; val_type = subst_typ ; val_recursive = false ; val_parameters = Odoc_value.dummy_parameter_list subst_typ ; val_code = None ; val_loc = { loc_impl = None ; loc_inter = Some loc }; } ; met_private = private_flag = Asttypes.Private ; met_virtual = false ; } in let pos_limit2 = get_pos_limit2 q in let pos_end = loc.Location.loc_end.Lexing.pos_cnum in let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end pos_limit2) in met.met_value.val_info <- merge_infos met.met_value.val_info info_after_opt ; (* update the parameter description *) Odoc_value.update_value_parameters_text met.met_value; (met, maybe_more) in let rec f last_pos class_type_field_list = match class_type_field_list with [] -> let s = get_string_of_file last_pos pos_limit in let (_, ele_coms) = My_ir.all_special !file_name s in let ele_comments = List.fold_left (fun acc -> fun sc -> match sc.Odoc_types.i_desc with None -> acc | Some t -> acc @ [Class_comment t]) [] ele_coms in ([], ele_comments) | item :: q -> let loc = item.Parsetree.pctf_loc in match item.Parsetree.pctf_desc with | Parsetree.Pctf_val (name, mutable_flag, virtual_flag, _) -> (* of (string * mutable_flag * core_type option * Location.t)*) let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let complete_name = Name.concat current_class_name name in let typ = try Signature_search.search_attribute_type name class_signature with Not_found -> raise (Failure (Odoc_messages.attribute_type_not_found current_class_name name)) in let subst_typ = Odoc_env.subst_type env typ in let att = { att_value = { val_name = complete_name ; val_info = comment_opt ; val_type = subst_typ; val_recursive = false ; val_parameters = [] ; val_code = None ; val_loc = { loc_impl = None ; loc_inter = Some loc} ; } ; att_mutable = mutable_flag = Asttypes.Mutable ; att_virtual = virtual_flag = Asttypes.Virtual ; } in let pos_limit2 = get_pos_limit2 q in let pos_end = loc.Location.loc_end.Lexing.pos_cnum in let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end pos_limit2) in att.att_value.val_info <- merge_infos att.att_value.val_info info_after_opt ; let (inher_l, eles) = f (pos_end + maybe_more) q in (inher_l, eles_comments @ ((Class_attribute att) :: eles)) | Parsetree.Pctf_virt (name, private_flag, _) -> (* of (string * private_flag * core_type * Location.t) *) let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let (met, maybe_more) = get_method name comment_opt private_flag loc q in let met2 = { met with met_virtual = true } in let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in (inher_l, eles_comments @ ((Class_method met2) :: eles)) | Parsetree.Pctf_meth (name, private_flag, _) -> (* of (string * private_flag * core_type * Location.t) *) let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let (met, maybe_more) = get_method name comment_opt private_flag loc q in let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in (inher_l, eles_comments @ ((Class_method met) :: eles)) | (Parsetree.Pctf_cstr (_, _)) -> (* of (core_type * core_type * Location.t) *) (* A VOIR : cela correspond aux contraintes, non ? on ne les garde pas pour l'instant *) let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let (inher_l, eles) = f loc.Location.loc_end.Lexing.pos_cnum q in (inher_l, eles_comments @ eles) | Parsetree.Pctf_inher class_type -> let loc = class_type.Parsetree.pcty_loc in let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let pos_limit2 = get_pos_limit2 q in let pos_end = loc.Location.loc_end.Lexing.pos_cnum in let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end pos_limit2) in let comment_opt2 = merge_infos comment_opt info_after_opt in let text_opt = match comment_opt2 with None -> None | Some i -> i.Odoc_types.i_desc in let inh = match class_type.Parsetree.pcty_desc with Parsetree.Pcty_constr (longident, _) -> (*of Longident.t * core_type list*) let name = Name.from_longident longident.txt in let ic = { ic_name = Odoc_env.full_class_or_class_type_name env name ; ic_class = None ; ic_text = text_opt ; } in ic | Parsetree.Pcty_signature _ | Parsetree.Pcty_fun _ -> (* we don't have a name for the class signature, so we call it "object ... end" *) { ic_name = Odoc_messages.object_end ; ic_class = None ; ic_text = text_opt ; } in let (inher_l, eles) = f (pos_end + maybe_more) q in (inh :: inher_l , eles_comments @ eles) in f last_pos class_type_field_list (** Analyse of a .mli parse tree, to get the corresponding elements. last_pos is the position of the first character which may be used to look for special comments. *) let rec analyse_parsetree env signat current_module_name last_pos pos_limit sig_item_list = let table = Signature_search.table signat in (* we look for the comment of each item then analyse the item *) let rec f acc_eles acc_env last_pos = function [] -> let s = get_string_of_file last_pos pos_limit in let (_, ele_coms) = My_ir.all_special !file_name s in let ele_comments = List.fold_left (fun acc -> fun sc -> match sc.Odoc_types.i_desc with None -> acc | Some t -> acc @ [Element_module_comment t]) [] ele_coms in acc_eles @ ele_comments | ele :: q -> let (assoc_com, ele_comments) = get_comments_in_module last_pos ele.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum in let (maybe_more, new_env, elements) = analyse_signature_item_desc acc_env signat table current_module_name ele.Parsetree.psig_loc ele.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum (match q with [] -> pos_limit | ele2 :: _ -> ele2.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum ) assoc_com ele.Parsetree.psig_desc in f (acc_eles @ (ele_comments @ elements)) new_env (ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum + maybe_more) (* for the comments of constructors in types, which are after the constructor definition and can go beyond ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum *) q in f [] env last_pos sig_item_list (** Analyse the given signature_item_desc to create the corresponding module element (with the given attached comment).*) and analyse_signature_item_desc env signat table current_module_name sig_item_loc pos_start_ele pos_end_ele pos_limit comment_opt sig_item_desc = match sig_item_desc with Parsetree.Psig_value (name_pre, value_desc) -> let type_expr = try Signature_search.search_value table name_pre.txt with Not_found -> raise (Failure (Odoc_messages.value_not_found current_module_name name_pre.txt)) in let name = Name.parens_if_infix name_pre.txt in let subst_typ = Odoc_env.subst_type env type_expr in let v = { val_name = Name.concat current_module_name name ; val_info = comment_opt ; val_type = subst_typ ; val_recursive = false ; val_parameters = Odoc_value.dummy_parameter_list subst_typ ; val_code = None ; val_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; } in let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end_ele pos_limit) in v.val_info <- merge_infos v.val_info info_after_opt ; (* update the parameter description *) Odoc_value.update_value_parameters_text v; let new_env = Odoc_env.add_value env v.val_name in (maybe_more, new_env, [ Element_value v ]) | Parsetree.Psig_exception (name, exception_decl) -> let types_excep_decl = try Signature_search.search_exception table name.txt with Not_found -> raise (Failure (Odoc_messages.exception_not_found current_module_name name.txt)) in let e = { ex_name = Name.concat current_module_name name.txt ; ex_info = comment_opt ; ex_args = List.map (Odoc_env.subst_type env) types_excep_decl.exn_args ; ex_alias = None ; ex_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; ex_code = ( if !Odoc_global.keep_code then Some (get_string_of_file pos_start_ele pos_end_ele) else None ) ; } in let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end_ele pos_limit) in e.ex_info <- merge_infos e.ex_info info_after_opt ; let new_env = Odoc_env.add_exception env e.ex_name in (maybe_more, new_env, [ Element_exception e ]) | Parsetree.Psig_type name_type_decl_list -> (* we start by extending the environment *) let new_env = List.fold_left (fun acc_env -> fun (name, _) -> let complete_name = Name.concat current_module_name name.txt in Odoc_env.add_type acc_env complete_name ) env name_type_decl_list in let rec f ?(first=false) acc_maybe_more last_pos name_type_decl_list = match name_type_decl_list with [] -> (acc_maybe_more, []) | (name, type_decl) :: q -> let (assoc_com, ele_comments) = if first then (comment_opt, []) else get_comments_in_module last_pos type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in let pos_limit2 = match q with [] -> pos_limit | ( _, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in let (maybe_more, name_comment_list) = name_comment_from_type_kind type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum pos_limit2 type_decl.Parsetree.ptype_kind in print_DEBUG ("Type "^name.txt^" : "^(match assoc_com with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c)); let f_DEBUG (name, c_opt) = print_DEBUG ("constructor/field "^name^": "^(match c_opt with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c)) in List.iter f_DEBUG name_comment_list; (* get the information for the type in the signature *) let sig_type_decl = try Signature_search.search_type table name.txt with Not_found -> raise (Failure (Odoc_messages.type_not_found current_module_name name.txt)) in (* get the type kind with the associated comments *) let type_kind = get_type_kind new_env name_comment_list sig_type_decl.Types.type_kind in let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in let new_end = type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum + maybe_more in (* associate the comments to each constructor and build the [Type.t_type] *) let new_type = { ty_name = Name.concat current_module_name name.txt ; ty_info = assoc_com ; ty_parameters = List.map2 (fun p (co,cn,_) -> (Odoc_env.subst_type new_env p, co, cn) ) sig_type_decl.Types.type_params sig_type_decl.Types.type_variance; ty_kind = type_kind; ty_private = sig_type_decl.Types.type_private; ty_manifest = (match sig_type_decl.Types.type_manifest with None -> None | Some t -> Some (Odoc_env.subst_type new_env t)); ty_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; ty_code = ( if !Odoc_global.keep_code then Some (get_string_of_file loc_start new_end) else None ) ; } in let (maybe_more2, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file new_end pos_limit2) in new_type.ty_info <- merge_infos new_type.ty_info info_after_opt ; let (new_maybe_more, eles) = f (maybe_more + maybe_more2) (new_end + maybe_more2) q in (new_maybe_more, (ele_comments @ [Element_type new_type]) @ eles) in let (maybe_more, types) = f ~first: true 0 pos_start_ele name_type_decl_list in (maybe_more, new_env, types) | Parsetree.Psig_open _ -> (* A VOIR *) let ele_comments = match comment_opt with None -> [] | Some i -> match i.i_desc with None -> [] | Some t -> [Element_module_comment t] in (0, env, ele_comments) | Parsetree.Psig_module (name, module_type) -> let complete_name = Name.concat current_module_name name.txt in (* get the the module type in the signature by the module name *) let sig_module_type = try Signature_search.search_module table name.txt with Not_found -> raise (Failure (Odoc_messages.module_not_found current_module_name name.txt)) in let module_kind = analyse_module_kind env complete_name module_type sig_module_type in let code_intf = if !Odoc_global.keep_code then let loc = module_type.Parsetree.pmty_loc in let st = loc.Location.loc_start.Lexing.pos_cnum in let en = loc.Location.loc_end.Lexing.pos_cnum in Some (get_string_of_file st en) else None in let new_module = { m_name = complete_name ; m_type = sig_module_type; m_info = comment_opt ; m_is_interface = true ; m_file = !file_name ; m_kind = module_kind ; m_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; m_top_deps = [] ; m_code = None ; m_code_intf = code_intf ; m_text_only = false ; } in let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end_ele pos_limit) in new_module.m_info <- merge_infos new_module.m_info info_after_opt ; let new_env = Odoc_env.add_module env new_module.m_name in let new_env2 = match new_module.m_type with (* A VOIR : cela peut-il etre Tmty_ident ? dans ce cas, on aurait pas la signature *) Types.Mty_signature s -> Odoc_env.add_signature new_env new_module.m_name ~rel: (Name.simple new_module.m_name) s | _ -> new_env in (maybe_more, new_env2, [ Element_module new_module ]) | Parsetree.Psig_recmodule decls -> (* we start by extending the environment *) let new_env = List.fold_left (fun acc_env -> fun ({ txt = name }, _) -> let complete_name = Name.concat current_module_name name in let e = Odoc_env.add_module acc_env complete_name in (* get the information for the module in the signature *) let sig_module_type = try Signature_search.search_module table name with Not_found -> raise (Failure (Odoc_messages.module_not_found current_module_name name)) in match sig_module_type with (* A VOIR : cela peut-il etre Tmty_ident ? dans ce cas, on aurait pas la signature *) Types.Mty_signature s -> Odoc_env.add_signature e complete_name ~rel: name s | _ -> print_DEBUG "not a Tmty_signature"; e ) env decls in let rec f ?(first=false) acc_maybe_more last_pos name_mtype_list = match name_mtype_list with [] -> (acc_maybe_more, []) | (name, modtype) :: q -> let complete_name = Name.concat current_module_name name.txt in let loc = modtype.Parsetree.pmty_loc in let loc_start = loc.Location.loc_start.Lexing.pos_cnum in let loc_end = loc.Location.loc_end.Lexing.pos_cnum in let (assoc_com, ele_comments) = if first then (comment_opt, []) else get_comments_in_module last_pos loc_start in let pos_limit2 = match q with [] -> pos_limit | (_, mty) :: _ -> loc.Location.loc_start.Lexing.pos_cnum in (* get the information for the module in the signature *) let sig_module_type = try Signature_search.search_module table name.txt with Not_found -> raise (Failure (Odoc_messages.module_not_found current_module_name name.txt)) in (* associate the comments to each constructor and build the [Type.t_type] *) let module_kind = analyse_module_kind new_env complete_name modtype sig_module_type in let code_intf = if !Odoc_global.keep_code then let st = loc.Location.loc_start.Lexing.pos_cnum in let en = loc.Location.loc_end.Lexing.pos_cnum in Some (get_string_of_file st en) else None in let new_module = { m_name = complete_name ; m_type = sig_module_type; m_info = assoc_com ; m_is_interface = true ; m_file = !file_name ; m_kind = module_kind ; m_loc = { loc_impl = None ; loc_inter = Some loc } ; m_top_deps = [] ; m_code = None ; m_code_intf = code_intf ; m_text_only = false ; } in let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file loc_end pos_limit2) in new_module.m_info <- merge_infos new_module.m_info info_after_opt ; let (maybe_more2, eles) = f maybe_more (loc_end + maybe_more) q in (maybe_more2, (ele_comments @ [Element_module new_module]) @ eles) in let (maybe_more, mods) = f ~first: true 0 pos_start_ele decls in (maybe_more, new_env, mods) | Parsetree.Psig_modtype (name, pmodtype_decl) -> let complete_name = Name.concat current_module_name name.txt in let sig_mtype = try Signature_search.search_module_type table name.txt with Not_found -> raise (Failure (Odoc_messages.module_type_not_found current_module_name name.txt)) in let module_type_kind = match pmodtype_decl with Parsetree.Pmodtype_abstract -> None | Parsetree.Pmodtype_manifest module_type -> match sig_mtype with | Some sig_mtype -> Some (analyse_module_type_kind env complete_name module_type sig_mtype) | None -> None in let mt = { mt_name = complete_name ; mt_info = comment_opt ; mt_type = sig_mtype ; mt_is_interface = true ; mt_file = !file_name ; mt_kind = module_type_kind ; mt_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; } in let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end_ele pos_limit) in mt.mt_info <- merge_infos mt.mt_info info_after_opt ; let new_env = Odoc_env.add_module_type env mt.mt_name in let new_env2 = match sig_mtype with (* A VOIR : cela peut-il etre Tmty_ident ? dans ce cas, on aurait pas la signature *) Some (Types.Mty_signature s) -> Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s | _ -> new_env in (maybe_more, new_env2, [ Element_module_type mt ]) | Parsetree.Psig_include module_type -> let rec f = function Parsetree.Pmty_ident longident -> Name.from_longident longident.txt | Parsetree.Pmty_signature _ -> "??" | Parsetree.Pmty_functor _ -> "??" | Parsetree.Pmty_with (mt, _) -> f mt.Parsetree.pmty_desc | Parsetree.Pmty_typeof mexpr -> match mexpr.Parsetree.pmod_desc with Parsetree.Pmod_ident longident -> Name.from_longident longident.txt | _ -> "??" in let name = f module_type.Parsetree.pmty_desc in let full_name = Odoc_env.full_module_or_module_type_name env name in let im = { im_name = full_name ; im_module = None ; im_info = comment_opt; } in (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *) | Parsetree.Psig_class class_description_list -> (* we start by extending the environment *) let new_env = List.fold_left (fun acc_env -> fun class_desc -> let complete_name = Name.concat current_module_name class_desc.Parsetree.pci_name.txt in Odoc_env.add_class acc_env complete_name ) env class_description_list in let rec f ?(first=false) acc_maybe_more last_pos class_description_list = match class_description_list with [] -> (acc_maybe_more, []) | class_desc :: q -> let (assoc_com, ele_comments) = if first then (comment_opt, []) else get_comments_in_module last_pos class_desc.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum in let pos_end = class_desc.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in let pos_limit2 = match q with [] -> pos_limit | cd :: _ -> cd.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum in let name = class_desc.Parsetree.pci_name in let complete_name = Name.concat current_module_name name.txt in let sig_class_decl = try Signature_search.search_class table name.txt with Not_found -> raise (Failure (Odoc_messages.class_not_found current_module_name name.txt)) in let sig_class_type = sig_class_decl.Types.cty_type in let (parameters, class_kind) = analyse_class_kind new_env complete_name class_desc.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum class_desc.Parsetree.pci_expr sig_class_type in let new_class = { cl_name = complete_name ; cl_info = assoc_com ; cl_type = Odoc_env.subst_class_type env sig_class_type ; cl_type_parameters = sig_class_decl.Types.cty_params; cl_virtual = class_desc.Parsetree.pci_virt = Asttypes.Virtual ; cl_kind = class_kind ; cl_parameters = parameters ; cl_loc = { loc_impl = None ; loc_inter = Some class_desc.Parsetree.pci_loc } ; } in let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end pos_limit2) in new_class.cl_info <- merge_infos new_class.cl_info info_after_opt ; Odoc_class.class_update_parameters_text new_class ; let (new_maybe_more, eles) = f maybe_more (pos_end + maybe_more) q in (new_maybe_more, ele_comments @ (( Element_class new_class ) :: eles)) in let (maybe_more, eles) = f ~first: true 0 pos_start_ele class_description_list in (maybe_more, new_env, eles) | Parsetree.Psig_class_type class_type_declaration_list -> (* we start by extending the environment *) let new_env = List.fold_left (fun acc_env -> fun class_type_decl -> let complete_name = Name.concat current_module_name class_type_decl.Parsetree.pci_name.txt in Odoc_env.add_class_type acc_env complete_name ) env class_type_declaration_list in let rec f ?(first=false) acc_maybe_more last_pos class_type_description_list = match class_type_description_list with [] -> (acc_maybe_more, []) | ct_decl :: q -> let (assoc_com, ele_comments) = if first then (comment_opt, []) else get_comments_in_module last_pos ct_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum in let pos_end = ct_decl.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in let pos_limit2 = match q with [] -> pos_limit | ct_decl2 :: _ -> ct_decl2.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum in let name = ct_decl.Parsetree.pci_name in let complete_name = Name.concat current_module_name name.txt in let sig_cltype_decl = try Signature_search.search_class_type table name.txt with Not_found -> raise (Failure (Odoc_messages.class_type_not_found current_module_name name.txt)) in let sig_class_type = sig_cltype_decl.Types.clty_type in let kind = analyse_class_type_kind new_env complete_name ct_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum ct_decl.Parsetree.pci_expr sig_class_type in let ct = { clt_name = complete_name ; clt_info = assoc_com ; clt_type = Odoc_env.subst_class_type env sig_class_type ; clt_type_parameters = sig_cltype_decl.clty_params ; clt_virtual = ct_decl.Parsetree.pci_virt = Asttypes.Virtual ; clt_kind = kind ; clt_loc = { loc_impl = None ; loc_inter = Some ct_decl.Parsetree.pci_loc } ; } in let (maybe_more, info_after_opt) = My_ir.just_after_special !file_name (get_string_of_file pos_end pos_limit2) in ct.clt_info <- merge_infos ct.clt_info info_after_opt ; let (new_maybe_more, eles) = f maybe_more (pos_end + maybe_more) q in (new_maybe_more, ele_comments @ (( Element_class_type ct) :: eles)) in let (maybe_more, eles) = f ~first: true 0 pos_start_ele class_type_declaration_list in (maybe_more, new_env, eles) (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *) and analyse_module_type_kind ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type = match module_type.Parsetree.pmty_desc with Parsetree.Pmty_ident longident -> let name = match sig_module_type with Types.Mty_ident path -> Name.from_path path | _ -> Name.from_longident longident.txt (* A VOIR cela arrive quand on fait module type F : functor ... -> Toto, Toto n'est pas un ident mais une structure *) in Module_type_alias { mta_name = Odoc_env.full_module_type_name env name ; mta_module = None } | Parsetree.Pmty_signature ast -> ( let ast = filter_out_erased_items_from_signature erased ast in (* we must have a signature in the module type *) match sig_module_type with Types.Mty_signature signat -> let pos_start = module_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in let pos_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let elements = analyse_parsetree env signat current_module_name pos_start pos_end ast in Module_type_struct elements | _ -> raise (Failure "Parsetree.Pmty_signature signature but not Types.Mty_signature signat") ) | Parsetree.Pmty_functor (_, pmodule_type2, module_type2) -> ( let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let mp_type_code = get_string_of_file loc_start loc_end in print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); match sig_module_type with Types.Mty_functor (ident, param_module_type, body_module_type) -> let mp_kind = analyse_module_type_kind env current_module_name pmodule_type2 param_module_type in let param = { mp_name = Name.from_ident ident ; mp_type = Odoc_env.subst_module_type env param_module_type ; mp_type_code = mp_type_code ; mp_kind = mp_kind ; } in let k = analyse_module_type_kind ~erased env current_module_name module_type2 body_module_type in Module_type_functor (param, k) | _ -> (* if we're here something's wrong *) raise (Failure "Parsetree.Pmty_functor _ but not Types.Mty_functor _") ) | Parsetree.Pmty_with (module_type2, constraints) -> (* of module_type * (Longident.t * with_constraint) list *) ( let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let s = get_string_of_file loc_start loc_end in let erased = erased_names_of_constraints constraints erased in let k = analyse_module_type_kind ~erased env current_module_name module_type2 sig_module_type in Module_type_with (k, s) ) | Parsetree.Pmty_typeof module_expr -> let loc_start = module_expr.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in let loc_end = module_expr.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in let s = get_string_of_file loc_start loc_end in Module_type_typeof s (** analyse of a Parsetree.module_type and a Types.module_type.*) and analyse_module_kind ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type = match module_type.Parsetree.pmty_desc with Parsetree.Pmty_ident longident -> let k = analyse_module_type_kind env current_module_name module_type sig_module_type in Module_with ( k, "" ) | Parsetree.Pmty_signature signature -> ( let signature = filter_out_erased_items_from_signature erased signature in match sig_module_type with Types.Mty_signature signat -> Module_struct (analyse_parsetree env signat current_module_name module_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum signature ) | _ -> (* if we're here something's wrong *) raise (Failure "Parsetree.Pmty_signature signature but not Types.Mty_signature signat") ) | Parsetree.Pmty_functor (_, pmodule_type2,module_type2) (* of string * module_type * module_type *) -> ( match sig_module_type with Types.Mty_functor (ident, param_module_type, body_module_type) -> let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let mp_type_code = get_string_of_file loc_start loc_end in print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); let mp_kind = analyse_module_type_kind env current_module_name pmodule_type2 param_module_type in let param = { mp_name = Name.from_ident ident ; mp_type = Odoc_env.subst_module_type env param_module_type ; mp_type_code = mp_type_code ; mp_kind = mp_kind ; } in let k = analyse_module_kind ~erased env current_module_name module_type2 body_module_type in Module_functor (param, k) | _ -> (* if we're here something's wrong *) raise (Failure "Parsetree.Pmty_functor _ but not Types.Mty_functor _") ) | Parsetree.Pmty_with (module_type2, constraints) -> (*of module_type * (Longident.t * with_constraint) list*) ( let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let s = get_string_of_file loc_start loc_end in let erased = erased_names_of_constraints constraints erased in let k = analyse_module_type_kind ~erased env current_module_name module_type2 sig_module_type in Module_with (k, s) ) | Parsetree.Pmty_typeof module_expr -> let loc_start = module_expr.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in let loc_end = module_expr.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in let s = get_string_of_file loc_start loc_end in Module_typeof s (** Analyse of a Parsetree.class_type and a Types.class_type to return a couple (class parameters, class_kind).*) and analyse_class_kind env current_class_name last_pos parse_class_type sig_class_type = match parse_class_type.Parsetree.pcty_desc, sig_class_type with (Parsetree.Pcty_constr (_, _) (*of Longident.t * core_type list *), Types.Cty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) -> print_DEBUG "Cty_constr _"; let path_name = Name.from_path p in let name = Odoc_env.full_class_or_class_type_name env path_name in let k = Class_constr { cco_name = name ; cco_class = None ; cco_type_parameters = List.map (Odoc_env.subst_type env) typ_list } in ([], k) | (Parsetree.Pcty_signature { Parsetree.pcsig_fields = class_type_field_list }, Types.Cty_signature class_signature) -> (* we get the elements of the class in class_type_field_list *) let (inher_l, ele) = analyse_class_elements env current_class_name last_pos parse_class_type.Parsetree.pcty_loc.Location.loc_end.Lexing.pos_cnum class_type_field_list class_signature in ([], Class_structure (inher_l, ele)) | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Cty_fun (label, type_expr, class_type)) -> (* label = string. Dans les signatures, pas de nom de parametres a l'interieur des tuples *) (* si label = "", pas de label. ici on a l'information pour savoir si on a un label explicite. *) if parse_label = label then ( let new_param = Simple_name { sn_name = Btype.label_name label ; sn_type = Odoc_env.subst_type env type_expr ; sn_text = None ; (* will be updated when the class will be created *) } in let (l, k) = analyse_class_kind env current_class_name last_pos pclass_type class_type in ( (new_param :: l), k ) ) else ( raise (Failure "Parsetree.Pcty_fun (parse_label, _, pclass_type), labels différents") ) | _ -> raise (Failure "analyse_class_kind pas de correspondance dans le match") (** Analyse of a Parsetree.class_type and a Types.class_type to return a class_type_kind.*) and analyse_class_type_kind env current_class_name last_pos parse_class_type sig_class_type = match parse_class_type.Parsetree.pcty_desc, sig_class_type with (Parsetree.Pcty_constr (_, _) (*of Longident.t * core_type list *), Types.Cty_constr (p, typ_list, _) (*of Path.t * type_expr list * class_type*)) -> print_DEBUG "Cty_constr _"; let k = Class_type { cta_name = Odoc_env.full_class_or_class_type_name env (Name.from_path p) ; cta_class = None ; cta_type_parameters = List.map (Odoc_env.subst_type env) typ_list } in k | (Parsetree.Pcty_signature { Parsetree.pcsig_fields = class_type_field_list; }, Types.Cty_signature class_signature) -> (* we get the elements of the class in class_type_field_list *) let (inher_l, ele) = analyse_class_elements env current_class_name last_pos parse_class_type.Parsetree.pcty_loc.Location.loc_end.Lexing.pos_cnum class_type_field_list class_signature in Class_signature (inher_l, ele) | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Cty_fun (label, type_expr, class_type)) -> raise (Failure "analyse_class_type_kind : Parsetree.Pcty_fun (...) with Types.Cty_fun (...)") (* | (Parsetree.Pcty_constr (longident, _) (*of Longident.t * core_type list *), Types.Cty_signature class_signature) -> (* A VOIR : c'est pour le cas des contraintes de classes : class type cons = object method m : int end class ['a] maxou x = (object val a = (x : 'a) method m = a end : cons ) ^^^^^^ *) let k = Class_type { cta_name = Odoc_env.full_class_name env (Name.from_longident longident) ; cta_class = None ; cta_type_parameters = List.map (Odoc_env.subst_type env) typ_list (* ?? *) } in ([], k) *) | _ -> raise (Failure "analyse_class_type_kind pas de correspondance dans le match") let analyse_signature source_file input_file (ast : Parsetree.signature) (signat : Types.signature) = let complete_source_file = try let curdir = Sys.getcwd () in let (dirname, basename) = (Filename.dirname source_file, Filename.basename source_file) in Sys.chdir dirname ; let complete = Filename.concat (Sys.getcwd ()) basename in Sys.chdir curdir ; complete with Sys_error s -> prerr_endline s ; incr Odoc_global.errors ; source_file in prepare_file complete_source_file input_file; (* We create the t_module for this file. *) let mod_name = String.capitalize (Filename.basename (try Filename.chop_extension source_file with _ -> source_file)) in let (len,info_opt) = My_ir.first_special !file_name !file in let elements = analyse_parsetree Odoc_env.empty signat mod_name len (String.length !file) ast in let code_intf = if !Odoc_global.keep_code then Some !file else None in { m_name = mod_name ; m_type = Types.Mty_signature signat ; m_info = info_opt ; m_is_interface = true ; m_file = !file_name ; m_kind = Module_struct elements ; m_loc = { loc_impl = None ; loc_inter = Some (Location.in_file !file_name) } ; m_top_deps = [] ; m_code = None ; m_code_intf = code_intf ; m_text_only = false ; } end mingw-ocaml/ocaml/ocamldoc/odoc.ml0000644000175000017500000000752412124403242016526 0ustar tootstoots(***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Main module for bytecode. @todo coucou le todo*) open Config open Clflags open Misc open Format open Typedtree module M = Odoc_messages let print_DEBUG s = print_string s ; print_newline () (* we check if we must load a module given on the command line *) let arg_list = Array.to_list Sys.argv let (plugins, paths) = let rec iter (files, incs) = function [] | _ :: [] -> (List.rev files, List.rev incs) | "-g" :: file :: q when ((Filename.check_suffix file "cmo") or (Filename.check_suffix file "cma") or (Filename.check_suffix file "cmxs")) -> iter (file :: files, incs) q | "-i" :: dir :: q -> iter (files, dir :: incs) q | _ :: q -> iter (files, incs) q in iter ([], []) arg_list let _ = print_DEBUG "Fin analyse des arguments pour le dynamic load" (** Return the real name of the file to load, searching it in the paths if it is a simple name and not in the current directory. *) let get_real_filename name = if Filename.basename name <> name then name else ( let paths = Filename.current_dir_name :: paths @ [Odoc_config.custom_generators_path] in try let d = List.find (fun d -> Sys.file_exists (Filename.concat d name)) paths in Filename.concat d name with Not_found -> failwith (M.file_not_found_in_paths paths name) ) let load_plugin file = let file = Dynlink.adapt_filename file in Dynlink.allow_unsafe_modules true; try let real_file = get_real_filename file in ignore(Dynlink.loadfile real_file) with Dynlink.Error e -> prerr_endline (Odoc_messages.load_file_error file (Dynlink.error_message e)) ; exit 1 | Not_found -> prerr_endline (Odoc_messages.load_file_error file "Not_found"); exit 1 | Sys_error s | Failure s -> prerr_endline (Odoc_messages.load_file_error file s); exit 1 ;; List.iter load_plugin plugins;; let () = print_DEBUG "Fin du chargement dynamique eventuel" let () = Odoc_args.parse () let loaded_modules = List.flatten (List.map (fun f -> Odoc_info.verbose (Odoc_messages.loading f); try let l = Odoc_analyse.load_modules f in Odoc_info.verbose Odoc_messages.ok; l with Failure s -> prerr_endline s ; incr Odoc_global.errors ; [] ) !Odoc_global.load ) let modules = Odoc_analyse.analyse_files ~init: loaded_modules !Odoc_global.files let _ = match !Odoc_global.dump with None -> () | Some f -> try Odoc_analyse.dump_modules f modules with Failure s -> prerr_endline s ; incr Odoc_global.errors let _ = match !Odoc_args.current_generator with None -> () | Some gen -> let generator = Odoc_gen.get_minimal_generator gen in Odoc_info.verbose Odoc_messages.generating_doc; generator#generate modules; Odoc_info.verbose Odoc_messages.ok let _ = if !Odoc_global.errors > 0 then ( prerr_endline (Odoc_messages.errors_occured !Odoc_global.errors) ; exit 1 ) else exit 0 mingw-ocaml/ocaml/ocamldoc/odoc_ocamlhtml.mll0000644000175000017500000004270312124403242020740 0ustar tootstoots { (***********************************************************************) (* OCamldoc *) (* *) (* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 2001 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) (** Generation of html code to display OCaml code. *) open Lexing exception Fatal_error let fatal_error msg = prerr_string ">> Fatal error: "; prerr_endline msg; raise Fatal_error type error = | Illegal_character of char | Unterminated_comment | Unterminated_string | Unterminated_string_in_comment | Keyword_as_label of string ;; exception Error of error * int * int let base_escape_strings = [ ("&", "&") ; ("<", "<") ; (">", ">") ; ] let pre_escape_strings = [ (" ", " ") ; ("\n", "
\n") ; ("\t", "        ") ; ] let pre = ref false let fmt = ref Format.str_formatter (** Escape the strings which would clash with html syntax, and some other strings if we want to get a PRE style.*) let escape s = List.fold_left (fun acc -> fun (s, s2) -> Str.global_replace (Str.regexp s) s2 acc) s (if !pre then base_escape_strings @ pre_escape_strings else base_escape_strings) (** Escape the strings which would clash with html syntax. *) let escape_base s = List.fold_left (fun acc -> fun (s, s2) -> Str.global_replace (Str.regexp s) s2 acc) s base_escape_strings (** The output functions *) let print ?(esc=true) s = Format.pp_print_string !fmt (if esc then escape s else s) ;; let print_class ?(esc=true) cl s = print ~esc: false (""^ (if esc then escape s else s)^ "") ;; (** The table of keywords with colors *) let create_hashtable size init = let tbl = Hashtbl.create size in List.iter (fun (key, data) -> Hashtbl.add tbl key data) init; tbl (** The function used to return html code for the given comment body. *) let html_of_comment = ref (fun (s : string) -> "Odoc_ocamlhtml.html_of_comment not initialized") let keyword_table = create_hashtable 149 [ "and", "keyword" ; "as", "keyword" ; "assert", "keyword" ; "begin", "keyword" ; "class", "keyword" ; "constraint", "keyword" ; "do", "keyword" ; "done", "keyword" ; "downto", "keyword" ; "else", "keyword" ; "end", "keyword" ; "exception", "keyword" ; "external", "keyword" ; "false", "keyword" ; "for", "keyword" ; "fun", "keyword" ; "function", "keyword" ; "functor", "keyword" ; "if", "keyword" ; "in", "keyword" ; "include", "keyword" ; "inherit", "keyword" ; "initializer", "keyword" ; "lazy", "keyword" ; "let", "keyword" ; "match", "keyword" ; "method", "keyword" ; "module", "keyword" ; "mutable", "keyword" ; "new", "keyword" ; "object", "keyword" ; "of", "keyword" ; "open", "keyword" ; "or", "keyword" ; "parser", "keyword" ; "private", "keyword" ; "rec", "keyword" ; "sig", "keyword" ; "struct", "keyword" ; "then", "keyword" ; "to", "keyword" ; "true", "keyword" ; "try", "keyword" ; "type", "keyword" ; "val", "keyword" ; "virtual", "keyword" ; "when", "keyword" ; "while", "keyword" ; "with", "keyword" ; "mod", "keyword" ; "land", "keyword" ; "lor", "keyword" ; "lxor", "keyword" ; "lsl", "keyword" ; "lsr", "keyword" ; "asr", "keyword" ; ] let kwsign_class = "keywordsign" let constructor_class = "constructor" let comment_class = "comment" let string_class = "string" let code_class = "code" (** To buffer and print comments *) let margin = ref 0 let comment_buffer = Buffer.create 32 let reset_comment_buffer () = Buffer.reset comment_buffer let store_comment_char = Buffer.add_char comment_buffer let add_comment_string = Buffer.add_string comment_buffer let make_margin () = let rec iter n = if n <= 0 then "" else " "^(iter (n-1)) in iter !margin let print_comment () = let s = Buffer.contents comment_buffer in let len = String.length s in let code = if len < 1 then "(*"^(escape s)^"*)" else match s.[0] with '*' -> ( try let html = !html_of_comment (String.sub s 1 (len-1)) in "
"^(make_margin ())^""^ ""^ "(**"^html^"*)"^ "
" with e -> prerr_endline (Printexc.to_string e); "(*"^(escape s)^"*)" ) | _ -> "(*"^(escape s)^"*)" in print ~esc: false code (** To buffer string literals *) let string_buffer = Buffer.create 32 let reset_string_buffer () = Buffer.reset string_buffer let store_string_char = Buffer.add_char string_buffer let get_stored_string () = let s = Buffer.contents string_buffer in s (** To translate escape sequences *) let char_for_backslash = function | 'n' -> '\010' | 'r' -> '\013' | 'b' -> '\008' | 't' -> '\009' | c -> c let char_for_decimal_code lexbuf i = let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in Char.chr(c land 0xFF) let char_for_hexa_code lexbuf i = let c = 16 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) in Char.chr(c land 0xFF) (** To store the position of the beginning of a string and comment *) let string_start_pos = ref 0;; let comment_start_pos = ref [];; let in_comment () = !comment_start_pos <> [];; (** Error report *) open Format let report_error ppf = function | Illegal_character c -> fprintf ppf "Illegal character (%s)" (Char.escaped c) | Unterminated_comment -> fprintf ppf "Comment not terminated" | Unterminated_string -> fprintf ppf "String literal not terminated" | Unterminated_string_in_comment -> fprintf ppf "This comment contains an unterminated string literal" | Keyword_as_label kwd -> fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd ;; } let blank = [' ' '\010' '\013' '\009' '\012'] let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] let identchar = ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] let symbolchar = ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] let decimal_literal = ['0'-'9']+ let hex_literal = '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ let oct_literal = '0' ['o' 'O'] ['0'-'7']+ let bin_literal = '0' ['b' 'B'] ['0'-'1']+ let float_literal = ['0'-'9']+ ('.' ['0'-'9']* )? (['e' 'E'] ['+' '-']? ['0'-'9']+)? rule token = parse blank { let s = Lexing.lexeme lexbuf in ( match s with " " -> incr margin | "\t" -> margin := !margin + 8 | "\n" -> margin := 0 | _ -> () ); print s; token lexbuf } | "_" { print "_" ; token lexbuf } | "~" { print "~" ; token lexbuf } | "~" lowercase identchar * ':' { let s = Lexing.lexeme lexbuf in let name = String.sub s 1 (String.length s - 2) in if Hashtbl.mem keyword_table name then raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)); print s ; token lexbuf } | "?" { print "?" ; token lexbuf } | "?" lowercase identchar * ':' { let s = Lexing.lexeme lexbuf in let name = String.sub s 1 (String.length s - 2) in if Hashtbl.mem keyword_table name then raise (Error(Keyword_as_label name, Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)); print s ; token lexbuf } | lowercase identchar * { let s = Lexing.lexeme lexbuf in try let cl = Hashtbl.find keyword_table s in (print_class cl s ; token lexbuf ) with Not_found -> (print s ; token lexbuf )} | uppercase identchar * { print_class constructor_class (Lexing.lexeme lexbuf) ; token lexbuf } (* No capitalized keywords *) | decimal_literal | hex_literal | oct_literal | bin_literal { print (Lexing.lexeme lexbuf) ; token lexbuf } | float_literal { print (Lexing.lexeme lexbuf) ; token lexbuf } | "\"" { reset_string_buffer(); let string_start = Lexing.lexeme_start lexbuf in string_start_pos := string_start; string lexbuf; lexbuf.Lexing.lex_start_pos <- string_start - lexbuf.Lexing.lex_abs_pos; print_class string_class ("\""^(get_stored_string())^"\"") ; token lexbuf } | "'" [^ '\\' '\''] "'" { print_class string_class (Lexing.lexeme lexbuf) ; token lexbuf } | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" { print_class string_class (Lexing.lexeme lexbuf ) ; token lexbuf } | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { print_class string_class (Lexing.lexeme lexbuf ) ; token lexbuf } | "(*" { reset_comment_buffer (); comment_start_pos := [Lexing.lexeme_start lexbuf]; comment lexbuf ; print_comment (); token lexbuf } | "(*)" { reset_comment_buffer (); comment_start_pos := [Lexing.lexeme_start lexbuf]; comment lexbuf ; print_comment (); token lexbuf } | "*)" { lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - 1 } ; print (Lexing.lexeme lexbuf) ; token lexbuf } | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n") (* # linenum ... *) { print (Lexing.lexeme lexbuf); token lexbuf } | "#" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } | "&" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } | "&&" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } | "`" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } | "'" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } | "(" { print (Lexing.lexeme lexbuf) ; token lexbuf } | ")" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "*" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "," { print (Lexing.lexeme lexbuf) ; token lexbuf } | "??" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } | "->" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } | "." { print (Lexing.lexeme lexbuf) ; token lexbuf } | ".." { print (Lexing.lexeme lexbuf) ; token lexbuf } | ":" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "::" { print (Lexing.lexeme lexbuf) ; token lexbuf } | ":=" { print (Lexing.lexeme lexbuf) ; token lexbuf } | ":>" { print (Lexing.lexeme lexbuf) ; token lexbuf } | ";" { print (Lexing.lexeme lexbuf) ; token lexbuf } | ";;" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "<" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "<-" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "=" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "[" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "[|" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "[<" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "]" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "{" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "{<" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "|" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } | "||" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } | "|]" { print (Lexing.lexeme lexbuf) ; token lexbuf } | ">" { print (Lexing.lexeme lexbuf) ; token lexbuf } | ">]" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "}" { print (Lexing.lexeme lexbuf) ; token lexbuf } | ">}" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "!=" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "+" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "-" { print (Lexing.lexeme lexbuf) ; token lexbuf } | "-." { print (Lexing.lexeme lexbuf) ; token lexbuf } | "!" symbolchar * { print (Lexing.lexeme lexbuf) ; token lexbuf } | ['~' '?'] symbolchar + { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } | ['=' '<' '>' '|' '&' '$'] symbolchar * { print (Lexing.lexeme lexbuf) ; token lexbuf } | ['@' '^'] symbolchar * { print (Lexing.lexeme lexbuf) ; token lexbuf } | ['+' '-'] symbolchar * { print (Lexing.lexeme lexbuf) ; token lexbuf } | "**" symbolchar * { print (Lexing.lexeme lexbuf) ; token lexbuf } | ['*' '/' '%'] symbolchar * { print (Lexing.lexeme lexbuf) ; token lexbuf } | eof { () } | _ { raise (Error(Illegal_character ((Lexing.lexeme lexbuf).[0]), Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) } and comment = parse "(*" { comment_start_pos := Lexing.lexeme_start lexbuf :: !comment_start_pos; store_comment_char '('; store_comment_char '*'; comment lexbuf; } | "*)" { match !comment_start_pos with | [] -> assert false | [x] -> comment_start_pos := [] | _ :: l -> store_comment_char '*'; store_comment_char ')'; comment_start_pos := l; comment lexbuf; } (* These filters are useless | "\"" { reset_string_buffer(); string_start_pos := Lexing.lexeme_start lexbuf; store_comment_char '"'; begin try string lexbuf; add_comment_string ((get_stored_string()^"\"")) with Error (Unterminated_string, _, _) -> let st = List.hd !comment_start_pos in raise (Error (Unterminated_string_in_comment, st, st + 2)) end; comment lexbuf } | "'" [^ '\\' '\''] "'" { store_comment_char '\''; store_comment_char (Lexing.lexeme_char lexbuf 1); store_comment_char '\''; comment lexbuf } | "'\\" ['\\' '\'' 'n' 't' 'b' 'r'] "'" { store_comment_char '\''; store_comment_char '\\'; store_comment_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)) ; store_comment_char '\''; comment lexbuf } | "\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_comment_char(char_for_decimal_code lexbuf 1); comment lexbuf } | "\\x" ['0'-'9' 'A'-'Z' 'a'-'z' ] ['0'-'9' 'A'-'Z' 'a'-'z'] { store_comment_char(char_for_hexa_code lexbuf 2); string lexbuf } | "''" { store_comment_char '\''; store_comment_char '\''; comment lexbuf } *) | eof { let st = List.hd !comment_start_pos in raise (Error (Unterminated_comment, st, st + 2)); } | _ { store_comment_char(Lexing.lexeme_char lexbuf 0); comment lexbuf } and string = parse '"' { () } | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] * { string lexbuf } | '\\' ['\\' '"' 'n' 't' 'b' 'r' ] { Buffer.add_string string_buffer (Lexing.lexeme lexbuf) ; string lexbuf } | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { Buffer.add_string string_buffer (Lexing.lexeme lexbuf) ; string lexbuf } | '\\' 'x' ['0'-'9' 'A'-'Z' 'a'-'z' ] ['0'-'9' 'A'-'Z' 'a'-'z'] { Buffer.add_string string_buffer (Lexing.lexeme lexbuf) ; string lexbuf } | eof { raise (Error (Unterminated_string, !string_start_pos, !string_start_pos+1)) } | _ { store_string_char(Lexing.lexeme_char lexbuf 0); string lexbuf } { let html_of_code b ?(with_pre=true) code = let old_pre = !pre in let old_margin = !margin in let old_comment_buffer = Buffer.contents comment_buffer in let old_string_buffer = Buffer.contents string_buffer in let buf = Buffer.create 256 in let old_fmt = !fmt in fmt := Format.formatter_of_buffer buf ; pre := with_pre; margin := 0; let start = "" in let ending = "" in let html = ( try print ~esc: false start ; let lexbuf = Lexing.from_string code in let _ = token lexbuf in print ~esc: false ending ; Format.pp_print_flush !fmt () ; Buffer.contents buf with _ -> (* flush str_formatter because we already output something in it *) Format.pp_print_flush !fmt () ; start^code^ending ) in pre := old_pre; margin := old_margin ; Buffer.reset comment_buffer; Buffer.add_string comment_buffer old_comment_buffer ; Buffer.reset string_buffer; Buffer.add_string string_buffer old_string_buffer ; fmt := old_fmt ; Buffer.add_string b html } mingw-ocaml/README0000644000175000017500000000415412124403240013246 0ustar tootstootsMingw-ocaml is a set of patch and Makefile that can build an OCaml cross-compiler using the mingw32 compilation tools. You can build cross-compilers that creates native binary for windows, both 32 and 64 bits. By native, we mean that the binary are compliant with the original windows API/ABI, and do not use a POSIX emulation such as cygwin. This also means that the compiler may not support some unix-specific features, in particular in the domain of threads management. The compiler supports, in fact, exactly the features supported by the native OCaml compiler for Windows. To build the windows 32 bits compiler, just type: make To build the windows 64 bits compiler, just type: make MINGW_HOST=x86_64-w64-mingw32 By default, all binaries are placed into the binary/ folder. They wil not be functional unless you install them all in your system root though. You can do that by typing, as root: # make install If you are not already familiar with mingw64, i686-w64-mingw32 refers to 32 bits windows cross-compiling tools and x86_64-w64 to 64 bits windows cross-compiling tools. In the following, we use i686-w64-mingw32 but all instructions apply to x86_64-w64 as well. The compiler also includes a support for ocamlfind. In order to use it, you should set the environment variable OCAMLFIND_CONF to /etc/i686-w64-mingw32-ocamlfind.conf: export OCAMLFIND_CONF=/etc/i686-w64-mingw32-ocamlfind.conf When the build system uses the autoconf tool, you can build the C libraries with the following options: ./configure --prefix=/usr/i686-w64-mingw32 --host=i686-w64-mingw32 It is convenient to install those libs directly in /usr/i686-w64-mingw32. Additionally, if your configuration script uses pkg-config to detect libraries, you may want to set the PKG_CONFIG_PATH variable to /usr/i686-w64-mingw32/lib/pkgconfig: export PKG_CONFIG_PATH=/usr/i686-w64-mingw32/lib/pkgconfig This project is not in any way supported by the OCaml original maintainers. Please report any issue with this package there: https://github.com/savonet/mingw-ocaml -- Romain Beauxis Sat Mar 23 07:07:20 CDT 2013 mingw-ocaml/patches.in/0000755000175000017500000000000012124403242014420 5ustar tootstootsmingw-ocaml/patches.in/findlib-fix-build.patch0000644000175000017500000000107312124403242020732 0ustar tootstootsIndex: mingw-ocaml/build/findlib/src/findlib/Makefile =================================================================== --- mingw-ocaml.orig/build/findlib/src/findlib/Makefile 2013-03-25 07:57:15.116394979 -0500 +++ mingw-ocaml/build/findlib/src/findlib/Makefile 2013-03-25 07:58:44.399727226 -0500 @@ -11,8 +11,8 @@ NAME = findlib -OCAMLC = ocamlc -OCAMLOPT = ocamlopt +OCAMLC = ocamlc -I /usr/lib/ocaml/compiler-libs +OCAMLOPT = ocamlopt -I /usr/lib/ocaml/compiler-libs OCAMLDEP = ocamldep OCAMLLEX = ocamllex CAMLP4O = camlp4 pa_o.cmo pa_op.cmo pr_o.cmo -- mingw-ocaml/patches.in/ocaml-no-stdlib-dir.patch0000644000175000017500000000153512124403242021205 0ustar tootstootsNot sure if this is right, but OCAML_STDLIB_DIR can be undefined in our cross-compiler. It's only used in a one place in the C code so this works around it. Index: mingw-ocaml/build/ocaml/byterun/dynlink.c =================================================================== --- mingw-ocaml.orig/build/ocaml/byterun/dynlink.c 2013-03-22 13:57:37.908583643 -0500 +++ mingw-ocaml/build/ocaml/byterun/dynlink.c 2013-03-22 13:57:37.888593644 -0500 @@ -80,7 +80,12 @@ stdlib = getenv("OCAMLLIB"); if (stdlib == NULL) stdlib = getenv("CAMLLIB"); - if (stdlib == NULL) stdlib = OCAML_STDLIB_DIR; + if (stdlib == NULL) +#ifdef OCAML_STDLIB_DIR + stdlib = OCAML_STDLIB_DIR; +#else + stdlib = "."; +#endif ldconfname = caml_stat_alloc(strlen(stdlib) + 2 + sizeof(LD_CONF_NAME)); strcpy(ldconfname, stdlib); strcat(ldconfname, "/" LD_CONF_NAME); mingw-ocaml/patches.in/ocaml-revert-win32unix-select.patch0000644000175000017500000010512312124403242023164 0ustar tootstootsSee: http://caml.inria.fr/mantis/view.php?id=5959 diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c index a035e66..af9766f 100644 --- a/build/ocaml/otherlibs/win32unix/select.c +++ b/build/ocaml/otherlibs/win32unix/select.c @@ -31,7 +31,7 @@ * It takes the following parameters into account: * - limitation on number of objects is mostly due to limitation * a WaitForMultipleObjects - * - there is always an event "hStop" to watch + * - there is always an event "hStop" to watch * * This lead to pick the following value as the biggest possible * value @@ -114,9 +114,9 @@ typedef enum _SELECTHANDLETYPE { typedef enum _SELECTMODE { SELECT_MODE_NONE = 0, - SELECT_MODE_READ = 1, - SELECT_MODE_WRITE = 2, - SELECT_MODE_EXCEPT = 4, + SELECT_MODE_READ, + SELECT_MODE_WRITE, + SELECT_MODE_EXCEPT, } SELECTMODE; typedef enum _SELECTSTATE { @@ -157,9 +157,7 @@ typedef SELECTQUERY *LPSELECTQUERY; typedef struct _SELECTDATA { LIST lst; SELECTTYPE EType; - /* Sockets may generate a result for all three lists from one single query object - */ - SELECTRESULT aResults[MAXIMUM_SELECT_OBJECTS * 3]; + SELECTRESULT aResults[MAXIMUM_SELECT_OBJECTS]; DWORD nResultsCount; /* Data following are dedicated to APC like call, they will be initialized if required. @@ -191,18 +189,18 @@ LPSELECTDATA select_data_new (LPSELECTDATA lpSelectData, SELECTTYPE EType) /* Allocate the data structure */ LPSELECTDATA res; DWORD i; - - res = (LPSELECTDATA)caml_stat_alloc(sizeof(SELECTDATA)); + + res = (LPSELECTDATA)caml_stat_alloc(sizeof(SELECTDATA)); /* Init common data */ list_init((LPLIST)res); list_next_set((LPLIST)res, (LPLIST)lpSelectData); res->EType = EType; res->nResultsCount = 0; - + /* Data following are dedicated to APC like call, they - will be initialized if required. For now they are set to + will be initialized if required. For now they are set to invalid values. */ res->funcWorker = NULL; @@ -242,7 +240,7 @@ DWORD select_data_result_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, int l DWORD i; res = 0; - if (lpSelectData->nResultsCount < MAXIMUM_SELECT_OBJECTS * 3) + if (lpSelectData->nResultsCount < MAXIMUM_SELECT_OBJECTS) { i = lpSelectData->nResultsCount; lpSelectData->aResults[i].EMode = EMode; @@ -255,14 +253,14 @@ DWORD select_data_result_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, int l } /* Add a query to select data, return zero if something goes wrong */ -DWORD select_data_query_add (LPSELECTDATA lpSelectData, - SELECTMODE EMode, - HANDLE hFileDescr, +DWORD select_data_query_add (LPSELECTDATA lpSelectData, + SELECTMODE EMode, + HANDLE hFileDescr, int lpOrigIdx, unsigned int uFlagsFd) { DWORD res; - DWORD i; + DWORD i; res = 0; if (lpSelectData->nQueriesCount < MAXIMUM_SELECT_OBJECTS) @@ -280,22 +278,22 @@ DWORD select_data_query_add (LPSELECTDATA lpSelectData, } /* Search for a job that has available query slots and that match provided type. - * If none is found, create a new one. Return the corresponding SELECTDATA, and + * If none is found, create a new one. Return the corresponding SELECTDATA, and * update provided SELECTDATA head, if required. */ LPSELECTDATA select_data_job_search (LPSELECTDATA *lppSelectData, SELECTTYPE EType) { LPSELECTDATA res; - + res = NULL; - + /* Search for job */ DEBUG_PRINT("Searching an available job for type %d", EType); res = *lppSelectData; while ( res != NULL && !( - res->EType == EType + res->EType == EType && res->nQueriesCount < MAXIMUM_SELECT_OBJECTS ) ) @@ -326,7 +324,7 @@ void read_console_poll(HANDLE hStop, void *_data) DWORD n; LPSELECTDATA lpSelectData; LPSELECTQUERY lpQuery; - + DEBUG_PRINT("Waiting for data on console"); record; @@ -338,7 +336,7 @@ void read_console_poll(HANDLE hStop, void *_data) events[0] = hStop; events[1] = lpQuery->hFileDescr; while (lpSelectData->EState == SELECT_STATE_NONE) - { + { waitRes = WaitForMultipleObjects(2, events, FALSE, INFINITE); if (waitRes == WAIT_OBJECT_0 || check_error(lpSelectData, waitRes == WAIT_FAILED)) { @@ -359,7 +357,7 @@ void read_console_poll(HANDLE hStop, void *_data) lpSelectData->EState = SELECT_STATE_SIGNALED; break; } - else + else { /* discard everything else and try again */ if (check_error(lpSelectData, ReadConsoleInput(lpQuery->hFileDescr, &record, 1, &n) == 0)) @@ -371,9 +369,9 @@ void read_console_poll(HANDLE hStop, void *_data) } /* Add a function to monitor console input */ -LPSELECTDATA read_console_poll_add (LPSELECTDATA lpSelectData, - SELECTMODE EMode, - HANDLE hFileDescr, +LPSELECTDATA read_console_poll_add (LPSELECTDATA lpSelectData, + SELECTMODE EMode, + HANDLE hFileDescr, int lpOrigIdx, unsigned int uFlagsFd) { @@ -414,14 +412,14 @@ void read_pipe_poll (HANDLE hStop, void *_data) { iterQuery = &(lpSelectData->aQueries[i]); res = PeekNamedPipe( - iterQuery->hFileDescr, - NULL, - 0, - NULL, - &n, + iterQuery->hFileDescr, + NULL, + 0, + NULL, + &n, NULL); - if (check_error(lpSelectData, - (res == 0) && + if (check_error(lpSelectData, + (res == 0) && (GetLastError() != ERROR_BROKEN_PIPE))) { break; @@ -435,7 +433,7 @@ void read_pipe_poll (HANDLE hStop, void *_data) }; /* Alas, nothing except polling seems to work for pipes. - Check the state & stop_worker_event every 10 ms + Check the state & stop_worker_event every 10 ms */ if (lpSelectData->EState == SELECT_STATE_NONE) { @@ -446,7 +444,7 @@ void read_pipe_poll (HANDLE hStop, void *_data) * a chance that one of the 4 first calls succeed. */ wait = 2 * wait; - if (wait > 10) + if (wait > 10) { wait = 10; }; @@ -460,23 +458,23 @@ void read_pipe_poll (HANDLE hStop, void *_data) } /* Add a function to monitor pipe input */ -LPSELECTDATA read_pipe_poll_add (LPSELECTDATA lpSelectData, - SELECTMODE EMode, - HANDLE hFileDescr, +LPSELECTDATA read_pipe_poll_add (LPSELECTDATA lpSelectData, + SELECTMODE EMode, + HANDLE hFileDescr, int lpOrigIdx, unsigned int uFlagsFd) { LPSELECTDATA res; LPSELECTDATA hd; - + hd = lpSelectData; /* Polling pipe is a non blocking operation by default. This means that each - worker can handle many pipe. We begin to try to find a worker that is + worker can handle many pipe. We begin to try to find a worker that is polling pipe, but for which there is under the limit of pipe per worker. */ DEBUG_PRINT("Searching an available worker handling pipe"); res = select_data_job_search(&hd, SELECT_TYPE_PIPE_READ); - + /* Add a new pipe to poll */ res->funcWorker = read_pipe_poll; select_data_query_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); @@ -492,58 +490,51 @@ LPSELECTDATA read_pipe_poll_add (LPSELECTDATA lpSelectData, void socket_poll (HANDLE hStop, void *_data) { LPSELECTDATA lpSelectData; - LPSELECTQUERY iterQuery; - HANDLE aEvents[MAXIMUM_SELECT_OBJECTS]; - DWORD nEvents; - long maskEvents; - DWORD i; - u_long iMode; - SELECTMODE mode; - WSANETWORKEVENTS events; + LPSELECTQUERY iterQuery; + HANDLE aEvents[MAXIMUM_SELECT_OBJECTS]; + DWORD nEvents; + long maskEvents; + DWORD i; + u_long iMode; lpSelectData = (LPSELECTDATA)_data; - DEBUG_PRINT("Worker has %d queries to service", lpSelectData->nQueriesCount); for (nEvents = 0; nEvents < lpSelectData->nQueriesCount; nEvents++) { iterQuery = &(lpSelectData->aQueries[nEvents]); aEvents[nEvents] = CreateEvent(NULL, TRUE, FALSE, NULL); maskEvents = 0; - mode = iterQuery->EMode; - if ((mode & SELECT_MODE_READ) != 0) + switch (iterQuery->EMode) { - DEBUG_PRINT("Polling read for %d", iterQuery->hFileDescr); - maskEvents |= FD_READ | FD_ACCEPT | FD_CLOSE; - } - if ((mode & SELECT_MODE_WRITE) != 0) - { - DEBUG_PRINT("Polling write for %d", iterQuery->hFileDescr); - maskEvents |= FD_WRITE | FD_CONNECT | FD_CLOSE; - } - if ((mode & SELECT_MODE_EXCEPT) != 0) - { - DEBUG_PRINT("Polling exceptions for %d", iterQuery->hFileDescr); - maskEvents |= FD_OOB; + case SELECT_MODE_READ: + maskEvents = FD_READ | FD_ACCEPT | FD_CLOSE; + break; + case SELECT_MODE_WRITE: + maskEvents = FD_WRITE | FD_CONNECT | FD_CLOSE; + break; + case SELECT_MODE_EXCEPT: + maskEvents = FD_OOB; + break; } check_error(lpSelectData, WSAEventSelect( - (SOCKET)(iterQuery->hFileDescr), - aEvents[nEvents], + (SOCKET)(iterQuery->hFileDescr), + aEvents[nEvents], maskEvents) == SOCKET_ERROR); } - + /* Add stop event */ aEvents[nEvents] = hStop; nEvents++; if (lpSelectData->nError == 0) { - check_error(lpSelectData, + check_error(lpSelectData, WaitForMultipleObjects( - nEvents, - aEvents, - FALSE, + nEvents, + aEvents, + FALSE, INFINITE) == WAIT_FAILED); }; @@ -557,23 +548,7 @@ void socket_poll (HANDLE hStop, void *_data) DEBUG_PRINT("Socket %d has pending events", (i - 1)); if (iterQuery != NULL) { - /* Find out what kind of events were raised - */ - if (WSAEnumNetworkEvents((SOCKET)(iterQuery->hFileDescr), aEvents[i], &events) == 0) - { - if ((iterQuery->EMode & SELECT_MODE_READ) != 0 && (events.lNetworkEvents & (FD_READ | FD_ACCEPT | FD_CLOSE)) != 0) - { - select_data_result_add(lpSelectData, SELECT_MODE_READ, iterQuery->lpOrigIdx); - } - if ((iterQuery->EMode & SELECT_MODE_WRITE) != 0 && (events.lNetworkEvents & (FD_WRITE | FD_CONNECT | FD_CLOSE)) != 0) - { - select_data_result_add(lpSelectData, SELECT_MODE_WRITE, iterQuery->lpOrigIdx); - } - if ((iterQuery->EMode & SELECT_MODE_EXCEPT) != 0 && (events.lNetworkEvents & FD_OOB) != 0) - { - select_data_result_add(lpSelectData, SELECT_MODE_EXCEPT, iterQuery->lpOrigIdx); - } - } + select_data_result_add(lpSelectData, iterQuery->EMode, iterQuery->lpOrigIdx); } } /* WSAEventSelect() automatically sets socket to nonblocking mode. @@ -599,95 +574,30 @@ void socket_poll (HANDLE hStop, void *_data) } /* Add a function to monitor socket */ -LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData, - SELECTMODE EMode, - HANDLE hFileDescr, +LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData, + SELECTMODE EMode, + HANDLE hFileDescr, int lpOrigIdx, unsigned int uFlagsFd) { LPSELECTDATA res; - LPSELECTDATA candidate; - DWORD i; - LPSELECTQUERY aQueries; - - res = lpSelectData; - candidate = NULL; - aQueries = NULL; - + LPSELECTDATA hd; + + hd = lpSelectData; /* Polling socket can be done mulitple handle at the same time. You just need one worker to use it. Try to find if there is already a worker handling this kind of request. - Only one event can be associated with a given socket which means that if a socket - is in more than one of the fd_sets then we have to find that particular query and update - EMode with the additional flag. */ DEBUG_PRINT("Scanning list of worker to find one that already handle socket"); - /* Search for job */ - DEBUG_PRINT("Searching for an available job for type %d for descriptor %d", SELECT_TYPE_SOCKET, hFileDescr); - while (res != NULL) - { - if (res->EType == SELECT_TYPE_SOCKET) - { - i = res->nQueriesCount - 1; - aQueries = res->aQueries; - while (i >= 0 && aQueries[i].hFileDescr != hFileDescr) - { - i--; - } - /* If we didn't find the socket but this worker has available slots, store it - */ - if (i < 0) - { - if ( res->nQueriesCount < MAXIMUM_SELECT_OBJECTS) - { - candidate = res; - } - res = LIST_NEXT(LPSELECTDATA, res); - } - else - { - /* Previous socket query located -- we're finished - */ - aQueries = &aQueries[i]; - break; - } - } - else - { - res = LIST_NEXT(LPSELECTDATA, res); - } - } - - if (res == NULL) - { - res = candidate; - - /* No matching job found, create one */ - if (res == NULL) - { - DEBUG_PRINT("No job for type %d found, create one", SELECT_TYPE_SOCKET); - res = select_data_new(lpSelectData, SELECT_TYPE_SOCKET); - res->funcWorker = socket_poll; - res->nQueriesCount = 1; - aQueries = &res->aQueries[0]; - } - else - { - aQueries = &(res->aQueries[res->nQueriesCount++]); - } - aQueries->EMode = EMode; - aQueries->hFileDescr = hFileDescr; - aQueries->lpOrigIdx = lpOrigIdx; - aQueries->uFlagsFd = uFlagsFd; - DEBUG_PRINT("Socket %x added", hFileDescr); - } - else - { - aQueries->EMode |= EMode; - DEBUG_PRINT("Socket %x updated to %d", hFileDescr, aQueries->EMode); - } + res = select_data_job_search(&hd, SELECT_TYPE_SOCKET); + + /* Add a new socket to poll */ + res->funcWorker = socket_poll; + DEBUG_PRINT("Add socket %x to worker", hFileDescr); + select_data_query_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); + DEBUG_PRINT("Socket %x added", hFileDescr); - return res; + return hd; } /***********************/ @@ -695,19 +605,19 @@ LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData, /***********************/ /* Add a static result */ -LPSELECTDATA static_poll_add (LPSELECTDATA lpSelectData, - SELECTMODE EMode, - HANDLE hFileDescr, +LPSELECTDATA static_poll_add (LPSELECTDATA lpSelectData, + SELECTMODE EMode, + HANDLE hFileDescr, int lpOrigIdx, unsigned int uFlagsFd) { LPSELECTDATA res; LPSELECTDATA hd; - + /* Look for an already initialized static element */ hd = lpSelectData; res = select_data_job_search(&hd, SELECT_TYPE_STATIC); - + /* Add a new query/result */ select_data_query_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); select_data_result_add(res, EMode, lpOrigIdx); @@ -738,7 +648,7 @@ static SELECTHANDLETYPE get_handle_type(value fd) { switch(GetFileType(Handle_val(fd))) { - case FILE_TYPE_DISK: + case FILE_TYPE_DISK: res = SELECT_HANDLE_DISK; break; @@ -783,8 +693,8 @@ LPSELECTDATA select_data_dispatch (LPSELECTDATA lpSelectData, SELECTMODE EMode, DEBUG_PRINT("Begin dispatching handle %x", hFileDescr); DEBUG_PRINT("Waiting for %d on handle %x", EMode, hFileDescr); - - /* There is only 2 way to have except mode: transmission of OOB data through + + /* There is only 2 way to have except mode: transmission of OOB data through a socket TCP/IP and through a strange interaction with a TTY. With windows, we only consider the TCP/IP except condition */ @@ -879,7 +789,7 @@ static value find_handle(LPSELECTRESULT iterResult, value readfds, value writefd CAMLlocal2(result, list); int i; - switch( iterResult->EMode ) + switch( iterResult->EMode ) { case SELECT_MODE_READ: list = readfds; @@ -892,12 +802,12 @@ static value find_handle(LPSELECTRESULT iterResult, value readfds, value writefd break; }; - for(i=0; list != Val_unit && i < iterResult->lpOrigIdx; ++i ) + for(i=0; list != Val_unit && i < iterResult->lpOrigIdx; ++i ) { list = Field(list, 1); } - if (list == Val_unit) + if (list == Val_unit) failwith ("select.c: original file handle not found"); result = Field(list, 0); @@ -907,49 +817,13 @@ static value find_handle(LPSELECTRESULT iterResult, value readfds, value writefd #define MAX(a, b) ((a) > (b) ? (a) : (b)) -/* Convert fdlist to an fd_set if all the handles in fdlist are sockets and return 0. - * Returns 1 if a non-socket value is encountered. - */ -static int fdlist_to_fdset(value fdlist, fd_set *fdset) -{ - value l, c; - FD_ZERO(fdset); - for (l = fdlist; l != Val_int(0); l = Field(l, 1)) { - c = Field(l, 0); - if (Descr_kind_val(c) == KIND_SOCKET) { - FD_SET(Socket_val(c), fdset); - } else { - DEBUG_PRINT("Non socket value encountered"); - return 0; - } - } - return 1; -} - -static value fdset_to_fdlist(value fdlist, fd_set *fdset) -{ - value res = Val_int(0); - Begin_roots2(fdlist, res) - for (/*nothing*/; fdlist != Val_int(0); fdlist = Field(fdlist, 1)) { - value s = Field(fdlist, 0); - if (FD_ISSET(Socket_val(s), fdset)) { - value newres = alloc_small(2, 0); - Field(newres, 0) = s; - Field(newres, 1) = res; - res = newres; - } - } - End_roots(); - return res; -} - CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value timeout) -{ +{ /* Event associated to handle */ DWORD nEventsCount; DWORD nEventsMax; HANDLE *lpEventsDone; - + /* Data for all handles */ LPSELECTDATA lpSelectData; LPSELECTDATA iterSelectData; @@ -986,287 +860,246 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value CAMLlocal5 (read_list, write_list, except_list, res, l); CAMLlocal1 (fd); - fd_set read, write, except; - double tm; - struct timeval tv; - struct timeval * tvp; - DEBUG_PRINT("in select"); - err = 0; - tm = Double_val(timeout); - if (readfds == Val_int(0) && writefds == Val_int(0) && exceptfds == Val_int(0)) { - DEBUG_PRINT("nothing to do"); - if ( tm > 0.0 ) { - enter_blocking_section(); - Sleep( (int)(tm * 1000)); - leave_blocking_section(); + nEventsCount = 0; + nEventsMax = 0; + lpEventsDone = NULL; + lpSelectData = NULL; + iterSelectData = NULL; + iterResult = NULL; + err = 0; + hasStaticData = 0; + waitRet = 0; + readfds_len = caml_list_length(readfds); + writefds_len = caml_list_length(writefds); + exceptfds_len = caml_list_length(exceptfds); + hdsMax = MAX(readfds_len, MAX(writefds_len, exceptfds_len)); + + hdsData = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * hdsMax); + + if (Double_val(timeout) >= 0.0) + { + milliseconds = 1000 * Double_val(timeout); + DEBUG_PRINT("Will wait %d ms", milliseconds); + } + else + { + milliseconds = INFINITE; + } + + + /* Create list of select data, based on the different list of fd to watch */ + DEBUG_PRINT("Dispatch read fd"); + handle_set_init(&hds, hdsData, hdsMax); + i=0; + for (l = readfds; l != Val_int(0); l = Field(l, 1)) + { + fd = Field(l, 0); + if (!handle_set_mem(&hds, Handle_val(fd))) + { + handle_set_add(&hds, Handle_val(fd)); + lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_READ, fd, i++); } - read_list = write_list = except_list = Val_int(0); - } else { - if (fdlist_to_fdset(readfds, &read) && fdlist_to_fdset(writefds, &write) && fdlist_to_fdset(exceptfds, &except)) { - DEBUG_PRINT("only sockets to select on, using classic select"); - if (tm < 0.0) { - tvp = (struct timeval *) NULL; - } else { - tv.tv_sec = (int) tm; - tv.tv_usec = (int) (1e6 * (tm - (int) tm)); - tvp = &tv; - } - enter_blocking_section(); - if (select(FD_SETSIZE, &read, &write, &except, tvp) == -1) { - err = WSAGetLastError(); - DEBUG_PRINT("Error %ld occurred", err); - } - leave_blocking_section(); - if (err) { - DEBUG_PRINT("Error %ld occurred", err); - win32_maperr(err); - uerror("select", Nothing); - } - read_list = fdset_to_fdlist(readfds, &read); - write_list = fdset_to_fdlist(writefds, &write); - except_list = fdset_to_fdlist(exceptfds, &except); - } else { - nEventsCount = 0; - nEventsMax = 0; - lpEventsDone = NULL; - lpSelectData = NULL; - iterSelectData = NULL; - iterResult = NULL; - hasStaticData = 0; - waitRet = 0; - readfds_len = caml_list_length(readfds); - writefds_len = caml_list_length(writefds); - exceptfds_len = caml_list_length(exceptfds); - hdsMax = MAX(readfds_len, MAX(writefds_len, exceptfds_len)); - - hdsData = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * hdsMax); - - if (tm >= 0.0) - { - milliseconds = 1000 * tm; - DEBUG_PRINT("Will wait %d ms", milliseconds); - } - else - { - milliseconds = INFINITE; - } + else + { + DEBUG_PRINT("Discarding handle %x which is already monitor for read", Handle_val(fd)); + } + } + handle_set_reset(&hds); + DEBUG_PRINT("Dispatch write fd"); + handle_set_init(&hds, hdsData, hdsMax); + i=0; + for (l = writefds; l != Val_int(0); l = Field(l, 1)) + { + fd = Field(l, 0); + if (!handle_set_mem(&hds, Handle_val(fd))) + { + handle_set_add(&hds, Handle_val(fd)); + lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_WRITE, fd, i++); + } + else + { + DEBUG_PRINT("Discarding handle %x which is already monitor for write", Handle_val(fd)); + } + } + handle_set_reset(&hds); - /* Create list of select data, based on the different list of fd to watch */ - DEBUG_PRINT("Dispatch read fd"); - handle_set_init(&hds, hdsData, hdsMax); - i=0; - for (l = readfds; l != Val_int(0); l = Field(l, 1)) - { - fd = Field(l, 0); - if (!handle_set_mem(&hds, Handle_val(fd))) - { - handle_set_add(&hds, Handle_val(fd)); - lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_READ, fd, i++); - } - else - { - DEBUG_PRINT("Discarding handle %x which is already monitor for read", Handle_val(fd)); - } - } - handle_set_reset(&hds); + DEBUG_PRINT("Dispatch exceptional fd"); + handle_set_init(&hds, hdsData, hdsMax); + i=0; + for (l = exceptfds; l != Val_int(0); l = Field(l, 1)) + { + fd = Field(l, 0); + if (!handle_set_mem(&hds, Handle_val(fd))) + { + handle_set_add(&hds, Handle_val(fd)); + lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_EXCEPT, fd, i++); + } + else + { + DEBUG_PRINT("Discarding handle %x which is already monitor for exceptional", Handle_val(fd)); + } + } + handle_set_reset(&hds); - DEBUG_PRINT("Dispatch write fd"); - handle_set_init(&hds, hdsData, hdsMax); - i=0; - for (l = writefds; l != Val_int(0); l = Field(l, 1)) - { - fd = Field(l, 0); - if (!handle_set_mem(&hds, Handle_val(fd))) - { - handle_set_add(&hds, Handle_val(fd)); - lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_WRITE, fd, i++); - } - else - { - DEBUG_PRINT("Discarding handle %x which is already monitor for write", Handle_val(fd)); - } - } - handle_set_reset(&hds); + /* Building the list of handle to wait for */ + DEBUG_PRINT("Building events done array"); + nEventsMax = list_length((LPLIST)lpSelectData); + nEventsCount = 0; + lpEventsDone = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * nEventsMax); - DEBUG_PRINT("Dispatch exceptional fd"); - handle_set_init(&hds, hdsData, hdsMax); - i=0; - for (l = exceptfds; l != Val_int(0); l = Field(l, 1)) - { - fd = Field(l, 0); - if (!handle_set_mem(&hds, Handle_val(fd))) - { - handle_set_add(&hds, Handle_val(fd)); - lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_EXCEPT, fd, i++); - } - else - { - DEBUG_PRINT("Discarding handle %x which is already monitor for exceptional", Handle_val(fd)); - } - } - handle_set_reset(&hds); + iterSelectData = lpSelectData; + while (iterSelectData != NULL) + { + /* Check if it is static data. If this is the case, launch everything + * but don't wait for events. It helps to test if there are events on + * any other fd (which are not static), knowing that there is at least + * one result (the static data). + */ + if (iterSelectData->EType == SELECT_TYPE_STATIC) + { + hasStaticData = TRUE; + }; - /* Building the list of handle to wait for */ - DEBUG_PRINT("Building events done array"); - nEventsMax = list_length((LPLIST)lpSelectData); - nEventsCount = 0; - lpEventsDone = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * nEventsMax); + /* Execute APC */ + if (iterSelectData->funcWorker != NULL) + { + iterSelectData->lpWorker = + worker_job_submit( + iterSelectData->funcWorker, + (void *)iterSelectData); + DEBUG_PRINT("Job submitted to worker %x", iterSelectData->lpWorker); + lpEventsDone[nEventsCount] = worker_job_event_done(iterSelectData->lpWorker); + nEventsCount++; + }; + iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); + }; - iterSelectData = lpSelectData; - while (iterSelectData != NULL) - { - /* Check if it is static data. If this is the case, launch everything - * but don't wait for events. It helps to test if there are events on - * any other fd (which are not static), knowing that there is at least - * one result (the static data). - */ - if (iterSelectData->EType == SELECT_TYPE_STATIC) - { - hasStaticData = TRUE; - }; - - /* Execute APC */ - if (iterSelectData->funcWorker != NULL) - { - iterSelectData->lpWorker = - worker_job_submit( - iterSelectData->funcWorker, - (void *)iterSelectData); - DEBUG_PRINT("Job submitted to worker %x", iterSelectData->lpWorker); - lpEventsDone[nEventsCount] = worker_job_event_done(iterSelectData->lpWorker); - nEventsCount++; - }; - iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); - }; + DEBUG_PRINT("Need to watch %d workers", nEventsCount); - DEBUG_PRINT("Need to watch %d workers", nEventsCount); + /* Processing select itself */ + enter_blocking_section(); + /* There are worker started, waiting to be monitored */ + if (nEventsCount > 0) + { + /* Waiting for event */ + if (err == 0 && !hasStaticData) + { + DEBUG_PRINT("Waiting for one select worker to be done"); + switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, FALSE, milliseconds)) + { + case WAIT_FAILED: + err = GetLastError(); + break; - /* Processing select itself */ - enter_blocking_section(); - /* There are worker started, waiting to be monitored */ - if (nEventsCount > 0) - { - /* Waiting for event */ - if (err == 0 && !hasStaticData) - { - DEBUG_PRINT("Waiting for one select worker to be done"); - switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, FALSE, milliseconds)) - { - case WAIT_FAILED: - err = GetLastError(); - break; - - case WAIT_TIMEOUT: - DEBUG_PRINT("Select timeout"); - break; - - default: - DEBUG_PRINT("One worker is done"); - break; - }; - } - - /* Ordering stop to every worker */ - DEBUG_PRINT("Sending stop signal to every select workers"); - iterSelectData = lpSelectData; - while (iterSelectData != NULL) - { - if (iterSelectData->lpWorker != NULL) - { - worker_job_stop(iterSelectData->lpWorker); - }; - iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); - }; - - DEBUG_PRINT("Waiting for every select worker to be done"); - switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, TRUE, INFINITE)) - { - case WAIT_FAILED: - err = GetLastError(); - break; - - default: - DEBUG_PRINT("Every worker is done"); - break; - } - } - /* Nothing to monitor but some time to wait. */ - else if (!hasStaticData) - { - Sleep(milliseconds); - } - leave_blocking_section(); + case WAIT_TIMEOUT: + DEBUG_PRINT("Select timeout"); + break; - DEBUG_PRINT("Error status: %d (0 is ok)", err); - /* Build results */ - if (err == 0) - { - DEBUG_PRINT("Building result"); - read_list = Val_unit; - write_list = Val_unit; - except_list = Val_unit; - - iterSelectData = lpSelectData; - while (iterSelectData != NULL) - { - for (i = 0; i < iterSelectData->nResultsCount; i++) - { - iterResult = &(iterSelectData->aResults[i]); - l = alloc_small(2, 0); - Store_field(l, 0, find_handle(iterResult, readfds, writefds, exceptfds)); - switch (iterResult->EMode) - { - case SELECT_MODE_READ: - Store_field(l, 1, read_list); - read_list = l; - break; - case SELECT_MODE_WRITE: - Store_field(l, 1, write_list); - write_list = l; - break; - case SELECT_MODE_EXCEPT: - Store_field(l, 1, except_list); - except_list = l; - break; - } - } - /* We try to only process the first error, bypass other errors */ - if (err == 0 && iterSelectData->EState == SELECT_STATE_ERROR) - { - err = iterSelectData->nError; - } - iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); - } - } + default: + DEBUG_PRINT("One worker is done"); + break; + }; + } - /* Free resources */ - DEBUG_PRINT("Free selectdata resources"); - iterSelectData = lpSelectData; - while (iterSelectData != NULL) - { - lpSelectData = iterSelectData; - iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); - select_data_free(lpSelectData); - } - lpSelectData = NULL; + /* Ordering stop to every worker */ + DEBUG_PRINT("Sending stop signal to every select workers"); + iterSelectData = lpSelectData; + while (iterSelectData != NULL) + { + if (iterSelectData->lpWorker != NULL) + { + worker_job_stop(iterSelectData->lpWorker); + }; + iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); + }; + + DEBUG_PRINT("Waiting for every select worker to be done"); + switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, TRUE, INFINITE)) + { + case WAIT_FAILED: + err = GetLastError(); + break; + + default: + DEBUG_PRINT("Every worker is done"); + break; + } + } + /* Nothing to monitor but some time to wait. */ + else if (!hasStaticData) + { + Sleep(milliseconds); + } + leave_blocking_section(); - /* Free allocated events/handle set array */ - DEBUG_PRINT("Free local allocated resources"); - caml_stat_free(lpEventsDone); - caml_stat_free(hdsData); + DEBUG_PRINT("Error status: %d (0 is ok)", err); + /* Build results */ + if (err == 0) + { + DEBUG_PRINT("Building result"); + read_list = Val_unit; + write_list = Val_unit; + except_list = Val_unit; - DEBUG_PRINT("Raise error if required"); - if (err != 0) + iterSelectData = lpSelectData; + while (iterSelectData != NULL) + { + for (i = 0; i < iterSelectData->nResultsCount; i++) + { + iterResult = &(iterSelectData->aResults[i]); + l = alloc_small(2, 0); + Store_field(l, 0, find_handle(iterResult, readfds, writefds, exceptfds)); + switch (iterResult->EMode) { - win32_maperr(err); - uerror("select", Nothing); + case SELECT_MODE_READ: + Store_field(l, 1, read_list); + read_list = l; + break; + case SELECT_MODE_WRITE: + Store_field(l, 1, write_list); + write_list = l; + break; + case SELECT_MODE_EXCEPT: + Store_field(l, 1, except_list); + except_list = l; + break; } + } + /* We try to only process the first error, bypass other errors */ + if (err == 0 && iterSelectData->EState == SELECT_STATE_ERROR) + { + err = iterSelectData->nError; + } + iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); } } + /* Free resources */ + DEBUG_PRINT("Free selectdata resources"); + iterSelectData = lpSelectData; + while (iterSelectData != NULL) + { + lpSelectData = iterSelectData; + iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); + select_data_free(lpSelectData); + } + lpSelectData = NULL; + + /* Free allocated events/handle set array */ + DEBUG_PRINT("Free local allocated resources"); + caml_stat_free(lpEventsDone); + caml_stat_free(hdsData); + + DEBUG_PRINT("Raise error if required"); + if (err != 0) + { + win32_maperr(err); + uerror("select", Nothing); + } + DEBUG_PRINT("Build final result"); res = alloc_small(3, 0); Store_field(res, 0, read_list); mingw-ocaml/patches.in/findlib-fix-camlp4.patch0000644000175000017500000000301012124403242021004 0ustar tootstootsIndex: mingw-ocaml/build/findlib/configure =================================================================== --- mingw-ocaml.orig/build/findlib/configure 2013-03-22 13:57:38.384345627 -0500 +++ mingw-ocaml/build/findlib/configure 2013-03-22 13:57:38.364355628 -0500 @@ -113,6 +113,7 @@ ocamlfind_bin="" ocamlfind_man="" ocaml_sitelib="" +camlp4bin="camlp4" ocamlfind_config="" with_toolbox=0 with_topfind=1 @@ -132,6 +133,9 @@ -config) ocamlfind_config=$2 shift 2 ;; + -camlp4bin) camlp4bin=$2 + shift 2 + ;; -cygpath) system=mingw shift ;; @@ -415,8 +419,8 @@ # Check on camlp4: -if in_path camlp4; then - camlp4_dir=`camlp4 -where | tr -d '\015'` +if test -x "${camlp4bin}" || in_path ${camlp4bin}; then + camlp4_dir=`${camlp4bin} -where | tr -d '\r'` if [ ${use_cygpath} -gt 0 ]; then camlp4_dir=`echo x | env USE_CYGPATH=1 tools/patch x "$camlp4_dir"` # This makes camlp4_dir a windows path @@ -424,14 +428,14 @@ # Must double the backslahes camlp4_dir="$(echo "${camlp4_dir}" | sed -e 's;\\;\\\\;g')" fi - camlp4_version=`camlp4 -v 2>&1` + camlp4_version=`${camlp4bin} -v | tr -d '\r' 2>&1` if [ "$have_dlls" = "yes" ]; then camlp4_cmd="camlp4" else camlp4_cmd="safe_camlp4" fi # Check whether 3.09 or 3.10 style: - if camlp4 -loaded-modules >/dev/null 2>/dev/null; then + if ${camlp4bin} -loaded-modules >/dev/null 2>/dev/null; then camlp4style=310 else camlp4style=309 mingw-ocaml/patches.in/ocaml-fix-opt-link-opts.patch0000644000175000017500000000624112124403242022041 0ustar tootstootsIndex: mingw-ocaml/build/ocaml/otherlibs/win32unix/Makefile.nt =================================================================== --- mingw-ocaml.orig/build/ocaml/otherlibs/win32unix/Makefile.nt 2013-03-22 13:57:38.024525639 -0500 +++ mingw-ocaml/build/ocaml/otherlibs/win32unix/Makefile.nt 2013-03-22 13:57:38.000537640 -0500 @@ -40,7 +40,7 @@ COBJS=$(ALL_FILES:.c=.$(O)) CAMLOBJS=unix.cmo unixLabels.cmo LINKOPTS=-cclib $(WSOCKLIB) -LDOPTS=-ldopt $(WSOCKLIB) +LDOPTS=-L/usr/@mingw_host@/lib -ldopt $(WSOCKLIB) EXTRACAMLFLAGS=-nolabels EXTRACFLAGS=-I../unix HEADERS=unixsupport.h socketaddr.h Index: mingw-ocaml/build/ocaml/otherlibs/str/Makefile =================================================================== --- mingw-ocaml.orig/build/ocaml/otherlibs/str/Makefile 2013-03-22 13:57:38.024525639 -0500 +++ mingw-ocaml/build/ocaml/otherlibs/str/Makefile 2013-03-22 13:57:38.000537640 -0500 @@ -20,6 +20,7 @@ COBJS=strstubs.$(O) CLIBNAME=camlstr CAMLOBJS=str.cmo +LDOPTS=-L/usr/@mingw_host@/lib include ../Makefile Index: mingw-ocaml/build/ocaml/otherlibs/num/Makefile =================================================================== --- mingw-ocaml.orig/build/ocaml/otherlibs/num/Makefile 2013-03-22 13:57:38.024525639 -0500 +++ mingw-ocaml/build/ocaml/otherlibs/num/Makefile 2013-03-22 13:57:38.004535640 -0500 @@ -21,6 +21,7 @@ ratio.cmo num.cmo arith_status.cmo CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi COBJS=bng.$(O) nat_stubs.$(O) +LDOPTS=-L/usr/@mingw_host@/lib include ../Makefile Index: mingw-ocaml/build/ocaml/otherlibs/win32graph/Makefile.nt =================================================================== --- mingw-ocaml.orig/build/ocaml/otherlibs/win32graph/Makefile.nt 2013-03-22 13:57:38.024525639 -0500 +++ mingw-ocaml/build/ocaml/otherlibs/win32graph/Makefile.nt 2013-03-22 13:57:38.004535640 -0500 @@ -18,7 +18,7 @@ CAMLOBJS=graphics.cmo WIN32LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,gdi32) $(call SYSLIB,user32) LINKOPTS=-cclib "\"$(WIN32LIBS)\"" -LDOPTS=-ldopt "$(WIN32LIBS)" +LDOPTS=-L/usr/@mingw_host@/lib -ldopt "$(WIN32LIBS)" include ../Makefile.nt Index: mingw-ocaml/build/ocaml/otherlibs/bigarray/Makefile.nt =================================================================== --- mingw-ocaml.orig/build/ocaml/otherlibs/bigarray/Makefile.nt 2013-03-22 13:57:38.024525639 -0500 +++ mingw-ocaml/build/ocaml/otherlibs/bigarray/Makefile.nt 2013-03-22 13:57:38.004535640 -0500 @@ -19,6 +19,7 @@ COBJS=bigarray_stubs.$(O) mmap_win32.$(O) CAMLOBJS=bigarray.cmo HEADERS=bigarray.h +LDOPTS=-L/usr/@mingw_host@/lib include ../Makefile.nt Index: mingw-ocaml/build/ocaml/otherlibs/systhreads/Makefile.nt =================================================================== --- mingw-ocaml.orig/build/ocaml/otherlibs/systhreads/Makefile.nt 2013-03-22 13:57:38.024525639 -0500 +++ mingw-ocaml/build/ocaml/otherlibs/systhreads/Makefile.nt 2013-03-22 13:58:01.000000000 -0500 @@ -21,6 +21,7 @@ COMPFLAGS=-warn-error A -g MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib CFLAGS=-I../../byterun $(EXTRACFLAGS) +LDOPTS=-L/usr/@mingw_host@/lib CAMLOBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo CMIFILES=$(CAMLOBJS:.cmo=.cmi) mingw-ocaml/patches.in/flexdll-fix-get_output1.patch0000644000175000017500000000073112124403242022136 0ustar tootstootsIndex: mingw-ocaml/build/flexdll/reloc.ml =================================================================== --- mingw-ocaml.orig/build/flexdll/reloc.ml 2013-03-23 08:17:49.419422123 -0500 +++ mingw-ocaml/build/flexdll/reloc.ml 2013-03-23 08:19:31.578877699 -0500 @@ -82,7 +82,9 @@ r let get_output1 ?use_bash cmd = - List.hd (get_output ?use_bash cmd) + match get_output ?use_bash cmd with + | x :: _ -> x + | [] -> "" (* Preparing command line *) mingw-ocaml/patches.in/series0000644000175000017500000000070712124403242015641 0ustar tootstootsflexdll-cross-mingw.patch flexdll-fix-get_output1.patch ocaml-disable-cmxs.patch ocaml-win32unix-path.patch ocaml-combined-Makefile.patch ocaml-filename-win32-dirsep.patch ocaml-no-stdlib-dir.patch ocaml-fix-opt-link-opts.patch ocaml-run-ranlib-on-threads.patch ocaml-force-os-type.patch ocaml-i386-profiling.patch ocaml-win32-compat.patch ocaml-fix-ocamlrun-path.patch ocaml-revert-win32unix-select.patch findlib-fix-camlp4.patch findlib-fix-build.patch mingw-ocaml/patches.in/ocaml-win32-compat.patch0000644000175000017500000000402512124403242020756 0ustar tootstootsIndex: mingw-ocaml/build/ocaml/byterun/win32.c =================================================================== --- mingw-ocaml.orig/build/ocaml/byterun/win32.c 2013-03-22 18:31:05.280868358 -0500 +++ mingw-ocaml/build/ocaml/byterun/win32.c 2013-03-22 18:31:05.256880360 -0500 @@ -37,6 +37,26 @@ #include "flexdll.h" +/* XXX including gets ../byterun/io.h for some reason. + * Including the real io.h using the full path fails because of + * some strange bug in the system header file itself. Give up and + * just define _finddata_t explicitly here. + */ +#ifndef _FSIZE_T_DEFINED +typedef unsigned long _fsize_t; +#define _FSIZE_T_DEFINED + +struct _finddata_t +{ + unsigned attrib; + time_t time_create; + time_t time_access; + time_t time_write; + _fsize_t size; + char name[FILENAME_MAX]; +}; +#endif + #ifndef S_ISREG #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) #endif @@ -95,7 +115,7 @@ pathlen = strlen(name) + 1; if (pathlen < 256) pathlen = 256; while (1) { - fullname = stat_alloc(pathlen); + fullname = caml_stat_alloc(pathlen); retcode = SearchPath(NULL, /* use system search path */ name, ".exe", /* add .exe extension if needed */ @@ -109,7 +129,7 @@ break; } if (retcode < pathlen) break; - stat_free(fullname); + caml_stat_free(fullname); pathlen = retcode + 1; } return fullname; @@ -482,4 +502,4 @@ return 3; } -#endif /* WIN32 */ +#endif Index: mingw-ocaml/build/ocaml/otherlibs/systhreads/st_win32.h =================================================================== --- mingw-ocaml.orig/build/ocaml/otherlibs/systhreads/st_win32.h 2013-03-22 18:31:05.280868358 -0500 +++ mingw-ocaml/build/ocaml/otherlibs/systhreads/st_win32.h 2013-03-22 18:31:05.256880360 -0500 @@ -17,7 +17,7 @@ #define _WIN32_WINNT 0x0400 #include -#include +#include #include #include mingw-ocaml/patches.in/ocaml-disable-cmxs.patch0000644000175000017500000000230212124403242021102 0ustar tootstootsI couldn't get *.cmxs files to build in the cross-compiler. This patch disables them. Index: mingw-ocaml/build/ocaml/otherlibs/Makefile.shared =================================================================== --- mingw-ocaml.orig/build/ocaml/otherlibs/Makefile.shared 2013-03-22 18:18:47.754870103 -0500 +++ mingw-ocaml/build/ocaml/otherlibs/Makefile.shared 2013-03-22 18:18:47.734880104 -0500 @@ -42,7 +42,8 @@ all: lib$(CLIBNAME).$(A) $(LIBNAME).cma $(CMIFILES) -allopt: lib$(CLIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).$(CMXS) $(CMIFILES) +allopt: lib$(CLIBNAME).$(A) $(LIBNAME).cmxa $(CMIFILES) +# $(LIBNAME).$(CMXS) $(LIBNAME).cma: $(CAMLOBJS) $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlc '$(CAMLC)' -linkall $(CAMLOBJS) $(LINKOPTS) @@ -50,8 +51,8 @@ $(LIBNAME).cmxa: $(CAMLOBJS_NAT) $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlopt '$(CAMLOPT)' -linkall $(CAMLOBJS_NAT) $(LINKOPTS) -$(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(CLIBNAME).$(A) - $(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa +#$(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(CLIBNAME).$(A) +# $(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa lib$(CLIBNAME).$(A): $(COBJS) $(MKLIB) -oc $(CLIBNAME) $(COBJS) $(LDOPTS) mingw-ocaml/patches.in/flexdll-cross-mingw.patch0000644000175000017500000000176512124403242021352 0ustar tootstootsIndex: mingw-ocaml/build/flexdll/Makefile =================================================================== --- mingw-ocaml.orig/build/flexdll/Makefile 2013-03-23 06:26:44.629083711 -0500 +++ mingw-ocaml/build/flexdll/Makefile 2013-03-23 06:27:41.072845588 -0500 @@ -1,8 +1,6 @@ VERSION = 0.30 all: flexlink.exe support -include $(shell cygpath -ad "$(shell ocamlopt -where)/Makefile.config") - MINGW_PREFIX = i686-w64-mingw32 MINCC = $(MINGW_PREFIX)-gcc @@ -45,11 +43,7 @@ #OCAMLOPT = FLEXLINKFLAGS=-real-manifest ocamlopt #LINKFLAGS = unix.cmxa -#ifeq ($(SYSTEM), win64) -#LINKFLAGS= -#else -LINKFLAGS = -ccopt "-link version_res.o" -#endif +LINKFLAGS= support: for i in $(CHAINS); do $(MAKE) build_$$i ; done @@ -62,7 +56,7 @@ OBJS = version.ml coff.ml cmdline.ml create_dll.ml reloc.ml -flexlink.exe: $(OBJS) version_res.o +flexlink.exe: $(OBJS) @echo Building flexlink.exe with TOOLCHAIN=$(TOOLCHAIN) rm -f flexlink.exe $(OCAMLOPT) -w -105 -o flexlink.exe $(LINKFLAGS) $(OBJS) mingw-ocaml/patches.in/ocaml-hardcode_mingw_include.patch0000644000175000017500000000246612124403242023217 0ustar tootstoots--- mingw-ocaml.orig/build/ocaml/utils/clflags.ml 2010-01-07 04:00:11.000000000 +0100 +++ mingw-ocaml/build/ocaml/utils/clflags.ml 2010-01-07 04:00:24.000000000 +0100 @@ -20,7 +20,7 @@ let compile_only = ref false (* -c *) and output_name = ref (None : string option) (* -o *) -and include_dirs = ref ([] : string list)(* -I *) +and include_dirs = ref (["/usr/@mingw_host@/lib"] : string list)(* -I *) and no_std_include = ref false (* -nostdlib *) and print_types = ref false (* -i *) and make_archive = ref false (* -a *) --- mingw-ocaml.orig/build/ocaml/tools/ocamlmklib.mlp 2010-02-22 20:15:57.000000000 -0600 +++ mingw-ocaml/build/ocaml/tools/ocamlmklib.mlp 2010-02-22 20:16:20.000000000 -0600 @@ -29,7 +29,7 @@ and failsafe = ref false (* whether to fall back on static build only *) and c_libs = ref [] (* libs to pass to mksharedlib and ocamlc -cclib *) and c_opts = ref [] (* options to pass to mksharedlib and ocamlc -ccopt *) -and ld_opts = ref [] (* options to pass only to the linker *) +and ld_opts = ref ["-I /usr/@mingw_host@/lib"] (* options to pass only to the linker *) and ocamlc = ref (compiler_path "ocamlc") and ocamlopt = ref (compiler_path "ocamlopt") and output = ref "a" (* Output name for Caml part of library *) mingw-ocaml/patches.in/ocaml-i386-profiling.patch0000644000175000017500000000115512124403242021214 0ustar tootstootsIndex: mingw-ocaml/build/ocaml/asmrun/i386.S =================================================================== --- mingw-ocaml.orig/build/ocaml/asmrun/i386.S 2013-03-22 16:08:07.554296392 -0500 +++ mingw-ocaml/build/ocaml/asmrun/i386.S 2013-03-22 17:20:07.749047630 -0500 @@ -62,6 +62,9 @@ popl %edx; popl %ecx; popl %eax; popl %ebp #define PROFILE_C \ pushl %ebp; movl %esp, %ebp; call mcount; popl %ebp +#elif defined(SYS_mingw) +#define PROFILE_CAML +#define PROFILE_C #elif defined(SYS_bsd_elf) #define PROFILE_CAML \ pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \ mingw-ocaml/patches.in/ocaml-filename-win32-dirsep.patch0000644000175000017500000000147112124403242022541 0ustar tootstootsOur compiler will think that os_type = "Win32". Unfortunately in the default OCaml this has the negative effect of causing it to use '\' character in paths. Since it's really running on a Linux kernel, that won't work. This is a quick and dirty fix. Index: mingw-ocaml/build/ocaml/stdlib/filename.ml =================================================================== --- mingw-ocaml.orig/build/ocaml/stdlib/filename.ml 2013-03-22 13:57:37.792641647 -0500 +++ mingw-ocaml/build/ocaml/stdlib/filename.ml 2013-03-22 13:57:37.776649648 -0500 @@ -93,7 +93,7 @@ module Win32 = struct let current_dir_name = "." let parent_dir_name = ".." - let dir_sep = "\\" + let dir_sep = "/" let is_dir_sep s i = let c = s.[i] in c = '/' || c = '\\' || c = ':' let is_relative n = (String.length n < 1 || n.[0] <> '/') mingw-ocaml/patches.in/ocaml-combined-Makefile.patch0000644000175000017500000001162112124403242022026 0ustar tootstootsOCaml sources uses separate Makefile and Makefile.nt in each directory, which is a pain when cross-compiling. Instead of that, it's better to combine all objects into one Makefile, and make sure the source is defended by #ifdef/#ifndef WIN32 ... #endif, around the whole files as necessary. Index: mingw-ocaml/build/ocaml/asmrun/Makefile =================================================================== --- mingw-ocaml.orig/build/ocaml/asmrun/Makefile 2013-03-22 13:57:35.401837727 -0500 +++ mingw-ocaml/build/ocaml/asmrun/Makefile 2013-03-22 13:57:35.373851729 -0500 @@ -26,7 +26,7 @@ misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \ floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \ gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \ - compact.o finalise.o custom.o unix.o backtrace.o natdynlink.o debugger.o \ + compact.o finalise.o custom.o unix.o win32.o backtrace.o natdynlink.o debugger.o \ meta.o dynlink.o ASMOBJS=$(ARCH).o @@ -153,6 +153,8 @@ ln -s ../byterun/globroots.c globroots.c unix.c: ../byterun/unix.c ln -s ../byterun/unix.c unix.c +win32.c: ../byterun/win32.c + ln -s ../byterun/win32.c win32.c dynlink.c: ../byterun/dynlink.c ln -s ../byterun/dynlink.c dynlink.c signals.c: ../byterun/signals.c @@ -163,7 +165,7 @@ LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \ - weak.c compact.c finalise.c meta.c custom.c main.c globroots.c unix.c \ + weak.c compact.c finalise.c meta.c custom.c main.c globroots.c unix.c win32.c \ dynlink.c signals.c debugger.c clean:: Index: mingw-ocaml/build/ocaml/byterun/Makefile.common =================================================================== --- mingw-ocaml.orig/build/ocaml/byterun/Makefile.common 2013-03-22 13:57:35.401837727 -0500 +++ mingw-ocaml/build/ocaml/byterun/Makefile.common 2013-03-22 13:57:35.373851729 -0500 @@ -24,7 +24,7 @@ compare.o ints.o floats.o str.o array.o io.o extern.o intern.o \ hash.o sys.o meta.o parsing.o gc_ctrl.o terminfo.o md5.o obj.o \ lexing.o callback.o debugger.o weak.o compact.o finalise.o custom.o \ - dynlink.o + dynlink.o win32.o PRIMS=\ alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \ Index: mingw-ocaml/build/ocaml/byterun/unix.c =================================================================== --- mingw-ocaml.orig/build/ocaml/byterun/unix.c 2013-03-22 13:57:35.401837727 -0500 +++ mingw-ocaml/build/ocaml/byterun/unix.c 2013-03-22 13:57:35.373851729 -0500 @@ -15,6 +15,8 @@ /* Unix-specific stuff */ +#ifndef WIN32 + #define _GNU_SOURCE /* Helps finding RTLD_DEFAULT in glibc */ @@ -323,3 +325,5 @@ } #endif + +#endif /* !WIN32 */ Index: mingw-ocaml/build/ocaml/byterun/win32.c =================================================================== --- mingw-ocaml.orig/build/ocaml/byterun/win32.c 2013-03-22 13:57:35.401837727 -0500 +++ mingw-ocaml/build/ocaml/byterun/win32.c 2013-03-22 13:57:35.373851729 -0500 @@ -13,6 +13,8 @@ /* $Id$ */ +#ifdef WIN32 + /* Win32-specific stuff */ #include @@ -479,3 +481,5 @@ data[2] = GetCurrentProcessId(); return 3; } + +#endif /* WIN32 */ Index: mingw-ocaml/build/ocaml/otherlibs/systhreads/Makefile =================================================================== --- mingw-ocaml.orig/build/ocaml/otherlibs/systhreads/Makefile 2013-03-22 13:57:35.401837727 -0500 +++ mingw-ocaml/build/ocaml/otherlibs/systhreads/Makefile 2013-03-22 13:57:35.373851729 -0500 @@ -20,8 +20,8 @@ MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib COMPFLAGS=-warn-error A -g -BYTECODE_C_OBJS=st_stubs_b.o -NATIVECODE_C_OBJS=st_stubs_n.o +BYTECODE_C_OBJS=st_stubs_b.o win32_b.o +NATIVECODE_C_OBJS=st_stubs_n.o win32_n.o THREAD_OBJS= thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo @@ -37,6 +37,10 @@ -c st_stubs.c mv st_stubs.o st_stubs_b.o +win32_b.$(O): st_stubs.c st_win32.h + $(BYTECC) -I ../../byterun $(BYTECCCOMPOPTS) $(CFLAGS) -c st_stubs.c + mv st_stubs.$(O) win32_b.$(O) + # Dynamic linking with -lpthread is risky on many platforms, so # do not create a shared object for libthreadsnat. libthreadsnat.a: $(NATIVECODE_C_OBJS) @@ -46,9 +50,13 @@ $(NATIVECC) -O -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) -c st_stubs.c mv st_stubs.o st_stubs_n.o +win32_n.$(O): st_stubs.c st_win32.h + $(NATIVECC) -DNATIVE_CODE -O -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) -c st_stubs.c + mv st_stubs.$(O) win32_n.$(O) + threads.cma: $(THREAD_OBJS) $(MKLIB) -ocamlc '$(CAMLC)' -o threads $(THREAD_OBJS) \ - -cclib -lunix $(PTHREAD_LINK) + -cclib -lunix $(PTHREAD_LINK) -lcamlrun # See remark above: force static linking of libthreadsnat.a threads.cmxa: $(THREAD_OBJS:.cmo=.cmx) mingw-ocaml/patches.in/ocaml-fix-ocamlrun-path.patch0000644000175000017500000000214012124403242022065 0ustar tootstootsIndex: mingw-ocaml/build/ocaml/otherlibs/systhreads/Makefile.nt =================================================================== --- mingw-ocaml.orig/build/ocaml/otherlibs/systhreads/Makefile.nt 2013-03-22 18:31:50.522234841 -0500 +++ mingw-ocaml/build/ocaml/otherlibs/systhreads/Makefile.nt 2013-03-22 18:31:50.502244843 -0500 @@ -35,7 +35,7 @@ allopt: lib$(LIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).cmxs $(CMIFILES) $(LIBNAME).cma: $(CAMLOBJS) - $(MKLIB) -o $(LIBNAME) -ocamlc "..\\..\\boot\\ocamlrun ..\\..\\ocamlc" -linkall $(CAMLOBJS) $(LINKOPTS) + $(MKLIB) -o $(LIBNAME) -ocamlc "../../boot/ocamlrun ../../ocamlc" -linkall $(CAMLOBJS) $(LINKOPTS) lib$(LIBNAME).$(A): $(COBJS) $(MKLIB) -o $(LIBNAME) $(COBJS) $(LDOPTS) @@ -47,7 +47,7 @@ $(LIBNAME).cmxa: $(CAMLOBJS:.cmo=.cmx) - $(MKLIB) -o $(LIBNAME)nat -ocamlopt "..\\..\\boot\\ocamlrun ..\\..\\ocamlopt" -linkall $(CAMLOBJS:.cmo=.cmx) $(LINKOPTS) + $(MKLIB) -o $(LIBNAME)nat -ocamlopt "../../boot/ocamlrun ../../ocamlopt" -linkall $(CAMLOBJS:.cmo=.cmx) $(LINKOPTS) mv $(LIBNAME)nat.cmxa $(LIBNAME).cmxa mv $(LIBNAME)nat.$(A) $(LIBNAME).$(A) mingw-ocaml/patches.in/ocaml-run-ranlib-on-threads.patch0000644000175000017500000000152512124403242022650 0ustar tootstootsIndex: mingw-ocaml/build/ocaml/otherlibs/systhreads/Makefile.nt =================================================================== --- mingw-ocaml.orig/build/ocaml/otherlibs/systhreads/Makefile.nt 2013-03-22 13:57:38.144465635 -0500 +++ mingw-ocaml/build/ocaml/otherlibs/systhreads/Makefile.nt 2013-03-22 13:57:38.124475636 -0500 @@ -72,6 +72,7 @@ install: cp dllthreads.dll $(STUBLIBDIR)/dllthreads.dll cp libthreads.$(A) $(LIBDIR)/libthreads.$(A) + cd $(LIBDIR); $(RANLIB) libthreads.$(A) mkdir -p $(LIBDIR)/threads cp $(CMIFILES) threads.cma $(LIBDIR)/threads rm -f $(LIBDIR)/threads/stdlib.cma @@ -79,6 +80,7 @@ installopt: cp libthreadsnat.$(A) $(LIBDIR)/libthreadsnat.$(A) + cd $(LIBDIR); $(RANLIB) libthreadsnat.$(A) cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.$(A) $(LIBDIR)/threads cp threads.cmxs $(LIBDIR)/threads mingw-ocaml/patches.in/ocaml-win32unix-path.patch0000644000175000017500000000546012124403242021337 0ustar tootstootsCombined Makefiles again: These libraries depend on the unix library, but really they depend on either the ("real") unix library or the win32unix library. Include both, with win32unix first, on the basis that this should pick up the correct one in all cases. Index: mingw-ocaml/build/ocaml/otherlibs/systhreads/Makefile =================================================================== --- mingw-ocaml.orig/build/ocaml/otherlibs/systhreads/Makefile 2013-03-22 22:00:21.243028361 -0500 +++ mingw-ocaml/build/ocaml/otherlibs/systhreads/Makefile 2013-03-22 22:00:21.223028362 -0500 @@ -15,8 +15,8 @@ include ../../config/Makefile -CAMLC=../../ocamlcomp.sh -I ../unix -CAMLOPT=../../ocamlcompopt.sh -I ../unix +CAMLC=../../ocamlcomp.sh -I ../win32unix -I ../unix +CAMLOPT=../../ocamlcompopt.sh -I ../win32unix -I ../unix MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib COMPFLAGS=-warn-error A -g Index: mingw-ocaml/build/ocaml/otherlibs/bigarray/Makefile =================================================================== --- mingw-ocaml.orig/build/ocaml/otherlibs/bigarray/Makefile 2013-03-22 22:00:21.243028361 -0500 +++ mingw-ocaml/build/ocaml/otherlibs/bigarray/Makefile 2013-03-22 22:00:21.223028362 -0500 @@ -14,8 +14,8 @@ # $Id$ LIBNAME=bigarray -EXTRACFLAGS=-I../unix -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE -EXTRACAMLFLAGS=-I ../unix +EXTRACFLAGS=-I../win32unix -I../unix -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE +EXTRACAMLFLAGS=-I ../win32unix -I ../unix COBJS=bigarray_stubs.$(O) mmap_unix.$(O) CAMLOBJS=bigarray.cmo HEADERS=bigarray.h Index: mingw-ocaml/build/ocaml/myocamlbuild.ml =================================================================== --- mingw-ocaml.orig/build/ocaml/myocamlbuild.ml 2013-03-22 22:00:21.243028361 -0500 +++ mingw-ocaml/build/ocaml/myocamlbuild.ml 2013-03-22 22:01:00.715026971 -0500 @@ -107,9 +107,10 @@ if mixed then ".."/dir else dir;; let unix_dir = - match Sys.os_type with - | "Win32" -> if_mixed_dir "otherlibs/win32unix" - | _ -> if_mixed_dir "otherlibs/unix";; + if_mixed_dir ( + if Sys.file_exists "stamp-build-mingw-win32" then "otherlibs/win32unix" + else "otherlibs/unix" + );; let threads_dir = if_mixed_dir "otherlibs/threads";; let systhreads_dir = if_mixed_dir "otherlibs/systhreads";; Index: mingw-ocaml/build/ocaml/ocamldoc/Makefile =================================================================== --- mingw-ocaml.orig/build/ocaml/ocamldoc/Makefile 2013-03-22 22:00:21.243028361 -0500 +++ mingw-ocaml/build/ocaml/ocamldoc/Makefile 2013-03-22 22:00:21.223028362 -0500 @@ -69,6 +69,7 @@ INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ -I $(OCAMLSRCDIR)/otherlibs/str \ -I $(OCAMLSRCDIR)/otherlibs/dynlink \ + -I $(OCAMLSRCDIR)/otherlibs/win32unix \ -I $(OCAMLSRCDIR)/otherlibs/unix \ -I $(OCAMLSRCDIR)/otherlibs/num \ -I $(OCAMLSRCDIR)/otherlibs/graph mingw-ocaml/patches.in/ocaml-force-os-type.patch0000644000175000017500000000176212124403242021234 0ustar tootstootsDisplayed os_type when calling ocamlc -config is wrong. This patch forces the correct value without changing anything in the Sys module. Index: mingw-ocaml/build/ocaml/utils/config.mlp =================================================================== --- mingw-ocaml.orig/build/ocaml/utils/config.mlp 2013-03-22 13:57:38.268403632 -0500 +++ mingw-ocaml/build/ocaml/utils/config.mlp 2013-03-22 13:57:38.244415632 -0500 @@ -86,11 +86,7 @@ let ext_lib = "%%EXT_LIB%%" let ext_dll = "%%EXT_DLL%%" -let default_executable_name = - match Sys.os_type with - "Unix" -> "a.out" - | "Win32" | "Cygwin" -> "camlprog.exe" - | _ -> "camlprog" +let default_executable_name = "camlprog.exe" let systhread_supported = %%SYSTHREAD_SUPPORT%%;; @@ -118,7 +114,7 @@ p "ext_asm" ext_asm; p "ext_lib" ext_lib; p "ext_dll" ext_dll; - p "os_type" Sys.os_type; + p "os_type" "Win32"; p "default_executable_name" default_executable_name; p_bool "systhread_supported" systhread_supported; flush oc; mingw-ocaml/files/0000755000175000017500000000000012124403240013464 5ustar tootstootsmingw-ocaml/files/ocaml/0000755000175000017500000000000012124403240014557 5ustar tootstootsmingw-ocaml/files/ocaml/Makefile-mingw.in0000644000175000017500000000326112124403240017745 0ustar tootstootsPREFIX=@prefix@ BINDIR=@bindir@ LIBDIR=@libdir@ STUBLIBDIR=$(LIBDIR)/stublibs MANDIR=$(PREFIX)/man MANEXT=1 RANLIB=@mingw_host@-ranlib RANLIBCMD=@mingw_host@-ranlib SHARPBANGSCRIPTS=true BNG_ARCH=@arch@.S BNG_ASM_LEVEL=1 PTHREAD_LINK= X11_INCLUDES= X11_LINK= DBM_INCLUDES= DBM_LINK= TK_DEFS= TK_LINK= BYTECC=@mingw_host@-gcc BYTECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused BYTECCLINKOPTS=-L/usr/@mingw_host@/lib BYTECCLIBS= BYTECCRPATH= EXE= SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= MKSHAREDLIBRPATH= NATDYNLINK=true NATDYNLINKOPTS= SYSLIB=-l$(1) RUNTIMED=noruntimed #ml let syslib x = "-l"^x;; ### How to build a static library MKLIB=@mingw_host@-ar rcs $(1) $(2) #ml let mklib out files opts = Printf.sprintf "@mingw_host@-ar rcs %s %s %s" out opts files;; ARCH=@arch@ MODEL=default SYSTEM=@mingw_system@ NATIVECC=@mingw_host@-gcc NATIVECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused NATIVECCPROFOPTS=-pg NATIVECCLINKOPTS=-L/usr/@mingw_host@/lib NATIVECCRPATH= NATIVECCLIBS= ARCMD=@mingw_host@-ar ASM=@mingw_host@-as ASM_CFI_SUPPORTED=false ASPP=@mingw_host@-gcc -c ASPPPROFFLAGS=-DPROFILING PROFILING=prof DYNLINKOPTS=-ldl OTHERLIBRARIES=@otherlibraries@ DEBUGGER=ocamldebugger CC_PROFILE=-pg SYSTHREAD_SUPPORT=true PARTIALLD=@mingw_host@-ld -r PACKLD=$(PARTIALLD) $(NATIVECCLINKOPTS) -o DLLCCCOMPOPTS= IFLEXDIR=-I@flexdir@ O=o A=a SO=dll EXT_OBJ=.o EXT_ASM=.s EXT_LIB=.a EXT_DLL=.dll EXTRALIBS= CCOMPTYPE=cc TOOLCHAIN=cc CMXS=cmxs FLEXLINK=flexlink -chain @flexlink_mingw_chain@ MKEXE=$(FLEXLINK) -exe MKDLL=$(FLEXLINK) MKMAINDLL=$(FLEXLINK) -maindll # Build compiler for cross-compilation. BUILD_MKEXE=gcc BUILD_RANLIB=ranlib BUILD_MKDLL=gcc -shared BUILD_CC=gcc BUILD_CCLIBS=-lm BUILD_CFLAGS= mingw-ocaml/files/findlib/0000755000175000017500000000000012124403240015073 5ustar tootstootsmingw-ocaml/files/findlib/ocamlfind.conf.in0000644000175000017500000000027212124403240020304 0ustar tootstootsstdlib="@libdir@/ocaml" ldconf="@libdir@/ocaml/ld.conf" destdir="@libdir@/ocaml" path="@libdir@/ocaml" ocamlc="@target@-ocamlc" ocamlopt="@target@-ocamlopt" ocamldep="@target@-ocamldep" mingw-ocaml/flexdll/0000755000175000017500000000000012124403242014016 5ustar tootstootsmingw-ocaml/flexdll/coff.ml0000644000175000017500000006441712124403240015277 0ustar tootstoots(************************************************************************) (* FlexDLL *) (* Alain Frisch *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. *) (************************************************************************) (* This module implements a reader/writer for COFF object files and libraries. *) module Buf : sig type t val create: unit -> t val length: t -> int val dump: out_channel -> t -> unit val string: t -> string -> unit val int8: t -> int -> unit val int32: t -> int32 -> unit val int16: t -> int -> unit val lazy_int32: t -> int32 Lazy.t -> unit val patch_lazy_int32: t -> int -> int32 Lazy.t -> unit val future_int32: t -> int32 Lazy.t -> int32 ref val set_future: t -> int32 ref -> unit end = struct type t = { mutable buf: string; mutable pos: int; mutable len: int; mutable patches: (unit -> unit) list; } let create () = { buf = String.create 16; pos = 0; len = 16; patches = [] } let ensure b n = let len = ref b.len in let pos = b.pos in while n > !len do len := !len * 2 done; let nbuf = String.create !len in String.blit b.buf 0 nbuf 0 pos; b.buf <- nbuf; b.len <- !len let int8 b x = let pos = b.pos in if pos = b.len then begin let nlen = b.len * 2 in let nbuf = String.create nlen in String.blit b.buf 0 nbuf 0 pos; b.buf <- nbuf; b.len <- nlen end; b.buf.[pos] <- Char.chr (x land 0xff); b.pos <- succ pos let int16 b x = int8 b x; int8 b (x asr 8) let length b = b.pos let patch b = List.iter (fun f -> f ()) b.patches; b.patches <- [] let add_patch b f = b.patches <- f :: b.patches let dump oc b = patch b; output_string oc (String.sub b.buf 0 b.pos) let string b s = let l = String.length s in let r = b.pos + l in if r > b.len then ensure b r; String.blit s 0 b.buf b.pos l; b.pos <- r let blit_int32 s pos i = s.[pos] <- Char.chr ((Int32.to_int i) land 0xff); s.[pos+1] <- Char.chr ((Int32.to_int (Int32.shift_right i 8)) land 0xff); s.[pos+2] <- Char.chr ((Int32.to_int (Int32.shift_right i 16)) land 0xff); s.[pos+3] <- Char.chr ((Int32.to_int (Int32.shift_right i 24)) land 0xff) let int32 b i = let r = b.pos + 4 in if r > b.len then ensure b r; blit_int32 b.buf b.pos i; b.pos <- r let lazy_int32 b i = let pos = b.pos in let r = b.pos + 4 in if r > b.len then ensure b r; b.pos <- r; add_patch b (fun () -> blit_int32 b.buf pos (Lazy.force i)) let patch_lazy_int32 b pos i = add_patch b (fun () -> blit_int32 b.buf pos (Lazy.force i)) let future_int32 b ofs = let r = ref 0l in lazy_int32 b (lazy (Int32.add !r (Lazy.force ofs))); r let set_future b r = r := Int32.of_int (length b) end (* Internal representation of COFF object files *) type symbol = { mutable sym_pos: int; sym_name: string; mutable value: int32; mutable section: [ `Num of int | `Section of section ]; stype: int; storage: int; auxn: int; mutable auxs: string; mutable extra_info: [ `Alias of symbol | `Section of section | `None ]; } and reloc = { addr: int32; symbol: symbol; rtype: int; } and section = { mutable sec_pos: int; sec_name: string; mutable vsize: int32; mutable vaddress: int32; mutable data: [ `String of string | `Uninit of int | `Buf of Buf.t list | `Lazy of in_channel * int * int | `Sxdata of symbol array ]; mutable relocs: reloc list; sec_opts: int32; } type coff = { obj_name: string; machine: int; date: int32; mutable sections: section list; mutable symbols: symbol list; opts: int; } (* Misc *) let (++) = Int32.add let (&&&) = Int32.logand let (|||) = Int32.logor let (>>>) = Int32.shift_right_logical let filter f l = let rec aux accu = function | [] -> accu | hd::tl -> if f hd then aux (hd::accu) tl else aux accu tl in aux [] l let is_zero s = try for i = 0 to String.length s - 1 do if s.[i] <> '\000' then raise Exit done; true with Exit -> false (* Tools to read/write binary data *) let mk_int32 a b c d = let a = Int32.of_int a and b = Int32.shift_left (Int32.of_int b) 8 and c = Int32.shift_left (Int32.of_int c) 16 and d = Int32.shift_left (Int32.of_int d) 24 in a ++ b ++ c ++ d let read ic pos len = if len = 0 then "" else ( seek_in ic pos; let buf = String.create len in really_input ic buf 0 len; buf ) let int32 buf loc = mk_int32 (Char.code buf.[loc]) (Char.code buf.[loc + 1]) (Char.code buf.[loc + 2]) (Char.code buf.[loc + 3]) let emit_int32 oc i = output_byte oc (Int32.to_int (i &&& 0xffl)); output_byte oc (Int32.to_int ((i >>> 8) &&& 0xffl)); output_byte oc (Int32.to_int ((i >>> 16) &&& 0xffl)); output_byte oc (Int32.to_int ((i >>> 24) &&& 0xffl)) let patch_int32 oc pos i = let bak = pos_out oc in seek_out oc pos; emit_int32 oc i; seek_out oc bak let emit_int16 oc i = output_byte oc (i land 0xff); output_byte oc (i lsr 8) let emit_int8 = output_byte let int32_ buf loc = Int32.to_int (int32 buf loc) let int16 buf loc = Char.code buf.[loc] + (Char.code buf.[loc + 1]) lsl 8 let int8 buf loc = Char.code buf.[loc] let strz buf loc ?(max=String.length buf - loc) c = let i = try String.index_from buf loc c with Not_found -> String.length buf in String.sub buf loc (min max (i - loc)) let emit_zero oc n = for i = 1 to n do output_char oc '\000' done let delayed_ptr oc f = let bak = pos_out oc in emit_int32 oc 0l; (fun () -> patch_int32 oc bak (Int32.of_int (pos_out oc)); f () ) let force_section_data sec = match sec.data with | `Lazy (ic,pos,len) -> let r = `String (read ic pos len) in sec.data <- r; r | x -> x let copy_data ic pos oc len = (* TODO: bufferized copy when len > threshold *) output_string oc (read ic pos len) (* Human readable pretty-printers *) let flags x = let b = Buffer.create 16 in for i = 0 to 31 do let m = Int32.shift_left 1l i in if m &&& x <> 0l then Printf.bprintf b "0x%08lx " m done; Buffer.contents b let rec dump ic pos len w = if len = 0 then (Printf.printf "---\n"; flush stdout) else let l = min len w in let b = read ic pos l in Printf.printf "%08x: " pos; for i = 0 to l - 1 do Printf.printf "%02x " (Char.code b.[i]) done; for i = l to w - 1 do Printf.printf " " done; Printf.printf " "; for i = 0 to l - 1 do match b.[i] with | '\032'..'\127' as c -> print_char c | _ -> print_char '.' done; Printf.printf "\n"; flush stdout; dump ic (pos + l) (len - l) w module Symbol = struct let counter = ref 0 let gen_sym () = incr counter; Printf.sprintf "_DREL%i" !counter let empty () = { sym_pos = (-1); sym_name = gen_sym(); value = 0l; section = `Num 0; storage = 0; stype = 0; auxn = 0; auxs = ""; extra_info = `None } let intern sec addr = { (empty ()) with section = `Section sec; storage = 3; value = addr } let named_intern name sec addr = { (empty ()) with sym_name = name; section = `Section sec; storage = 3; value = addr } let label name sec addr = { (empty ()) with sym_name = name; section = `Section sec; storage = 6; value = addr } let export name sec addr = { (empty ()) with sym_name = name; value = addr; section = `Section sec; storage = 2 } let extern name = { (empty ()) with sym_pos = (-1); sym_name = name; section = `Num 0; storage = 2 } let get strtbl ic pos = let buf = read ic pos 18 in let auxn = int8 buf 17 in { sym_pos = (-1); sym_name = (if int32_ buf 0 <> 0 then strz buf 0 ~max:8 '\000' else strtbl (int32_ buf 4)); value = int32 buf 8; section = `Num (int16 buf 12); stype = int16 buf 14; storage = int8 buf 16; auxn = auxn; auxs = read ic (pos + 18) (18 * auxn); extra_info = `None; } let is_extern = function | { storage = 2; section = `Num 0; value = 0l } -> true | _ -> false let is_export = function | { storage = 2; section = `Section _ } -> true | { storage = 2; section = `Num 0; value = 0l } -> false | { storage = 2; section = `Num 0 } -> true | _ -> false let is_defin = function | { storage = 2; section = `Section _ } -> true | { storage = 2; section = `Num 0; value = 0l } -> false | { storage = 2; section = `Num (0 | 0xffff) } -> true | _ -> false let dump s = Printf.printf " %s: " s.sym_name; if s.stype <> 0 then Printf.printf "(typ:%i) " s.stype; let sect = match s.section with | `Num 0xffff -> "absolute" | `Num 0xfffe -> "debug" | `Num i -> string_of_int i | `Section s -> Printf.sprintf "%S" s.sec_name in let storage = match s.storage with | 2 -> "extern" | 3 -> "static" | 6 -> "label" | 103 -> "srcfile" | n -> string_of_int n in match s with | { storage = 6 } -> Printf.printf "label %s @ 0x%08lx\n" sect s.value | { storage = 2; section = `Section _ } -> Printf.printf "export %s @ 0x%08lx\n" sect s.value | { storage = 2; section = `Num 0; value = 0l } -> Printf.printf "extern\n" | { storage = 2; section = `Num 0; value = n } -> Printf.printf "common symbol, size %ld\n" n | { storage = 3; value = 0l; auxn = auxn } when auxn > 0 -> Printf.printf "section %s, num %i, select %i\n" sect (int16 s.auxs 12) (int8 s.auxs 14) | { storage = 3 } -> Printf.printf "static %s @ 0x%08lx\n" sect s.value | { storage = 103 } -> Printf.printf "filename %s\n" (strz s.auxs 0 '\000') | { storage = 105 } -> Printf.printf "weak ext\n" | _ -> Printf.printf "value=0x%08lx, sect=%s, storage=%s, aux=%S\n" s.value sect storage s.auxs let put strtbl oc s = if String.length s.sym_name <= 8 then (output_string oc s.sym_name; emit_zero oc (8 - String.length s.sym_name)) else (emit_zero oc 4; emit_int32 oc (strtbl s.sym_name)); emit_int32 oc s.value; let sec = match s.section with | `Num i -> i | `Section sec when sec.sec_pos <= 0 -> failwith (Printf.sprintf "Cannot emit section for symbol %s" s.sym_name) | `Section sec -> sec.sec_pos in emit_int16 oc sec; emit_int16 oc s.stype; emit_int8 oc s.storage; emit_int8 oc s.auxn; match s with | { storage = 105; extra_info = `Alias s' } when s'.sym_pos >= 0 -> (* weak ext *) emit_int32 oc (Int32.of_int s'.sym_pos); output_string oc (String.sub s.auxs 4 (String.length s.auxs - 4)) | { storage = 3; extra_info = `Section s' } when int8 s.auxs 14 = 5 (* IMAGE_COMDAT_SELECT_ASSOCIATIVE *) -> (* section def *) output_string oc (String.sub s.auxs 0 12); emit_int16 oc s'.sec_pos; output_string oc (String.sub s.auxs 14 (String.length s.auxs - 14)) | { storage = 3; extra_info = `Section s' } -> (* section def *) Printf.eprintf "!!! section symbol not supported (symbol: %s -> section:%s)\n%!" s.sym_name s'.sec_name; Printf.eprintf "length = %i\n" (int32_ s.auxs 0); Printf.eprintf "# reloc = %i\n" (int16 s.auxs 4); Printf.eprintf "# linenum = %i\n" (int16 s.auxs 6); Printf.eprintf "checksum = %i\n" (int32_ s.auxs 8); Printf.eprintf "idx = %i\n" (int16 s.auxs 12); Printf.eprintf "sel = %i\n" (int8 s.auxs 14); assert false | _ -> if s.storage = 105 then assert (int16 s.auxs 12 = 0); output_string oc s.auxs end module Reloc = struct let abs machine sec addr sym = let rtype = match machine with | `x86 -> 0x06 | `x64 -> 0x01 in sec.relocs <- { addr = addr; symbol = sym; rtype = rtype } :: sec.relocs let rel32 machine sec addr sym = let rtype = match machine with | `x86 -> 0x14 | `x64 -> 0x04 in sec.relocs <- { addr = addr; symbol = sym; rtype = rtype } :: sec.relocs let get symtbl va ic base = let buf = read ic base 10 in { addr = Int32.sub (int32 buf 00) va; symbol = (try match symtbl.(int32_ buf 4) with Some s -> s | None -> assert false with exn -> assert false); rtype = int16 buf 8 } let dump x = Printf.printf " Reloc %ld -> %s, type 0x%04x\n" x.addr x.symbol.sym_name x.rtype let put oc x = emit_int32 oc x.addr; if x.symbol.sym_pos < 0 then failwith (Printf.sprintf "Cannot emit relocation for symbol %s\n" x.symbol.sym_name); emit_int32 oc (Int32.of_int x.symbol.sym_pos); emit_int16 oc x.rtype end module Section = struct let create name flags = { sec_pos = (-1); sec_name = name; data = `String ""; relocs = []; vaddress = 0l; vsize = 0l; sec_opts = flags; } let get filebase strtbl symtbl ic base = let buf = read ic base 40 in let size = int32_ buf 16 in let name = if buf.[0] = '/' then strtbl (int_of_string (strz buf 1 ~max:7 '\000')) else strz buf 0 ~max:8 '\000' in let va = int32 buf 12 in let nrelocs = int16 buf 32 in let more_relocs = int32 buf 36 &&& 0x01000000l <> 0l in let base_relocs = filebase + int32_ buf 24 in let base_relocs, nrelocs = if more_relocs then begin let buf_first_reloc = read ic base_relocs 4 in let n = int32_ buf_first_reloc 0 in base_relocs + 10, n - 1 end else base_relocs, nrelocs in let relocs = let r = ref [] in for i = 0 to nrelocs - 1 do r := Reloc.get symtbl va ic (base_relocs + 10 * i) :: !r done; !r in let data = if name = ".sxdata" then let s = read ic (filebase + int32_ buf 20) size in `Sxdata (Array.init (size /4) (fun i -> match symtbl.(int32_ s (i * 4)) with None -> assert false | Some s -> s)) else if int32_ buf 20 = 0 then `Uninit size else `String (read ic (filebase + int32_ buf 20) size) (* `Lazy (ic, filebase + int32_ buf 20, size) *) in { sec_pos = (-1); sec_name = name; vsize = int32 buf 8; vaddress = 0l; data = data; relocs = relocs; sec_opts = int32 buf 36 } let dump x = Printf.printf "Section %s (0x%08lx: %s)\n" x.sec_name x.sec_opts (flags x.sec_opts); List.iter Reloc.dump x.relocs let size s = match s.data with | `String s -> String.length s | `Lazy (_,_,len) -> len | `Uninit len -> len | `Buf bufs -> List.fold_left (fun s b -> s + Buf.length b) 0 bufs | `Sxdata syms -> Array.length syms * 4 let put strtbl oc x = let name = if String.length x.sec_name <= 8 then x.sec_name else Printf.sprintf "/%ld" (strtbl x.sec_name) in output_string oc name; emit_zero oc (8 - String.length name); emit_int32 oc x.vsize; (* assert(x.vaddress = 0l); *) emit_int32 oc x.vaddress; emit_int32 oc (Int32.of_int (size x)); let send_data = match x.data with | `String s -> delayed_ptr oc (fun () -> output_string oc s) | `Lazy (ic,pos,len) -> delayed_ptr oc (fun () -> copy_data ic pos oc len) | `Uninit len -> emit_int32 oc 0l; (fun () -> ()) | `Buf bufs -> delayed_ptr oc (fun () -> List.iter (Buf.dump oc) bufs) | `Sxdata syms -> delayed_ptr oc (fun () -> Array.iter (fun sym -> assert(sym.sym_pos >= 0); emit_int32 oc (Int32.of_int sym.sym_pos)) syms ) in let nrelocs = List.length x.relocs in let many_relocs = nrelocs > 0xffff in let send_reloc = if x.relocs = [] then (emit_int32 oc 0l; fun () -> ()) else delayed_ptr oc (fun () -> if many_relocs then begin emit_int32 oc (Int32.of_int nrelocs); emit_int32 oc 0l; emit_int16 oc 0 end; List.iter (Reloc.put oc) x.relocs ) in emit_int32 oc 0l; if many_relocs then emit_int16 oc 0xffff else emit_int16 oc nrelocs; emit_int16 oc 0; let sec_opts = if many_relocs then x.sec_opts ||| 0x01000000l else x.sec_opts in emit_int32 oc sec_opts; send_data, send_reloc end module Coff = struct let add_section x sect = x.sections <- sect :: x.sections let add_symbol x sym = x.symbols <- sym :: x.symbols let create machine = let machine = match machine with | `x64 -> 0x8664 | `x86 -> 0x14c in { obj_name = "generated"; machine = machine; date = 0x4603de0el; sections = []; symbols = []; opts = 0 } let parse_directives s = let rec find_end i = if i = 0 || s.[i - 1] <> '\000' then i else find_end (i - 1) in let l = find_end (String.length s) in let rec aux0 i = if i = l then [] else match s.[i] with | ' ' -> aux0 (i+1) | '-' | '/' -> aux1 (i+1) (i+1) | _ -> raise Exit and aux1 i0 i = if i = l then (String.sub s i0 (i - i0), [])::[] else match s.[i] with | 'a'..'z' | 'A'..'Z' -> aux1 i0 (i+1) | ' ' -> (String.sub s i0 (i - i0), []) :: aux0 (i+1) | ':' -> aux2 (String.sub s i0 (i - i0)) [] (i+1) | _ -> raise Exit and aux2 cmd args i = match s.[i] with | '"' -> aux3 cmd args (i+1) (i+1) | _ -> aux4 cmd args i i and aux3 cmd args i0 i = match s.[i] with | '"' -> aux5 cmd (String.sub s i0 (i - i0) :: args) (i+1) | _ -> aux3 cmd args i0 (i+1) and aux4 cmd args i0 i = if i = l then (cmd, String.sub s i0 (i - i0) :: args)::[] else match s.[i] with | ' ' -> (cmd, String.sub s i0 (i - i0) :: args) :: aux0 (i+1) | ',' -> aux2 cmd (String.sub s i0 (i - i0) :: args) (i+1) | _ -> aux4 cmd args i0 (i+1) and aux5 cmd args i = if i = l then (cmd, args) :: [] else match s.[i] with | ' ' -> (cmd,args) :: aux0 (i+1) | ',' -> aux2 cmd args (i+1) | _ -> raise Exit in try List.map (fun (cmd,args) -> (cmd,List.rev args)) (aux0 0) with _ -> failwith (Printf.sprintf "Cannot parse directive: %s\n" s) let directives obj = try let sec = List.find (fun s -> s.sec_name = ".drectve") obj.sections in match force_section_data sec with | `String s -> parse_directives s | `Uninit _ | `Sxdata _ -> [] | `Lazy _ | `Buf _ -> assert false with Not_found -> [] let get ic ofs base name = let buf = read ic ofs 20 in let opthdr = int16 buf 16 in let symtable = base + int32_ buf 8 in let symcount = int32_ buf 12 in (* the string table *) let strtbl = let pos = symtable + 18 * symcount in if pos = 0 then fun i -> assert false else let len = int32_ (read ic pos 4) 0 in let data = read ic pos len in fun i -> strz data i '\000' in (* the symbol table *) let symbols,symtbl = let tbl = Array.create symcount None in let rec fill accu i = if i = symcount then List.rev accu else let s = Symbol.get strtbl ic (symtable + 18 * i) in (try tbl.(i) <- Some s with Invalid_argument _ -> assert false); fill (s :: accu) (i + 1 + s.auxn) in fill [] 0, tbl in (* the sections *) let sectable = ofs + 20 + opthdr in let sections = Array.init (int16 buf 2) (fun i -> Section.get base strtbl symtbl ic (sectable + 40 * i)) in (* remove .bf/.ef/.lf symbols *) let symbols = List.filter (function { storage = 101 } -> false | _ -> true) symbols in List.iter (fun s -> (match s with | { storage = 105; auxn = 1 } -> (* weak ext *) (try match symtbl.(Int32.to_int (int32 s.auxs 0)) with | Some s' -> s.extra_info <- `Alias s' | None -> assert false with Invalid_argument _ -> assert false); | { storage = 3; stype = 0; auxn = auxn } when auxn > 0 -> (* section def *) let num = int16 s.auxs 12 in if num > 0 then (try s.extra_info <- `Section sections.(num - 1) with Invalid_argument _ -> Printf.eprintf "** section %i / %i (%s)\n" num (Array.length sections) s.sym_name; assert false); | { storage = 103 } | { auxn = 0 } -> () | { storage = (2|3); stype = 0x20; auxn = 1; auxs = auxs } -> (* Remove extra information for function symbols *) s.auxs <- String.make (String.length s.auxs) '\000' | _ -> Symbol.dump s; Printf.printf "aux=%S\n" s.auxs; assert false); (match s.section with | `Num i when i > 0 && i <= Array.length sections -> assert (i <= Array.length sections); (try s.section <- `Section sections.(i - 1) with Invalid_argument _ -> assert false); | _ -> ())) symbols; { obj_name = name; machine = int16 buf 0; sections = Array.to_list sections; date = int32 buf 4; symbols = symbols; opts = int16 buf 18; } let aliases x = let a = ref [] in List.iter (fun s -> match s.extra_info with | `Alias s' -> a := (s.sym_name,s'.sym_name) :: !a | _ -> () ) x.symbols; !a let dump x = Printf.printf "machine: 0x%x\n" x.machine; Printf.printf "date: 0x%lx\n" x.date; Printf.printf "opts: 0x%x\n" x.opts; List.iter Symbol.dump x.symbols; List.iter Section.dump x.sections; () let put oc x = emit_int16 oc x.machine; let () = let no = ref 0 in List.iter (fun s -> incr no; assert(s.sec_pos < 0); s.sec_pos <- !no) x.sections in emit_int16 oc (List.length x.sections); emit_int32 oc x.date; let strbuf = Buffer.create 1024 in let strtbl s = let pos = Buffer.length strbuf in Buffer.add_string strbuf s; Buffer.add_char strbuf '\000'; Int32.of_int (4 + pos) in let patch_sym = delayed_ptr oc (fun () -> List.iter (Symbol.put strtbl oc) x.symbols) in let nbsym = let no = ref 0 in List.iter (fun s -> assert(s.sym_pos < 0); s.sym_pos <- !no; no := !no + 1 + s.auxn ) x.symbols; !no in emit_int32 oc (Int32.of_int nbsym); emit_int16 oc 0; emit_int16 oc x.opts; let sects = List.map (Section.put strtbl oc) x.sections in List.iter (fun (data,relocs) -> data (); relocs ()) sects; patch_sym (); emit_int32 oc (Int32.of_int (Buffer.length strbuf + 4)); Buffer.output_buffer oc strbuf; List.iter (fun s -> s.sym_pos <- 0) x.symbols; List.iter (fun s -> s.sec_pos <- 0) x.sections; () end module Import = struct let read ic pos size = let buf = read ic pos size in let w = int16 buf 18 in let name = strz buf 20 '\000' in (* Printf.printf "Import header. Version = %i\n" (int16 buf 4); Printf.printf " machine = 0x%x\n" (int16 buf 6); Printf.printf " time stamp = 0x%lx\n" (int32 buf 8); Printf.printf " size data = %ld\n" (int32 buf 12); Printf.printf " ord/hint = %i\n" (int16 buf 16); Printf.printf " type = %i\n" (w land 0b11); Printf.printf " name type = %i\n" ((w land 0b11100) lsr 2); Printf.printf " symbol = %s\n" name; Printf.printf " DLL = %s\n" (strz buf (21 + String.length name) '\000'); *) name, w end module Lib = struct let magic_lib = "!\n" let read_lib ic libname = let strtbl = ref "" in let imports = ref [] and objects = ref [] in let obj size name = (* Printf.printf "-> %s (size %i)\n" name size; *) let pos = pos_in ic in if (size > 18) && (read ic pos 4 = "\000\000\255\255") then imports := Import.read ic pos size :: !imports else objects := (name, Coff.get ic pos pos (Printf.sprintf "%s(%s)" libname name)) :: !objects in let rec read_member () = let buf = read ic (pos_in ic) 60 in let base = pos_in ic in let size = int_of_string (strz (String.sub buf 48 10) 0 ' ') in let name = strz (String.sub buf 0 16) 0 ' ' in begin match name with | "/" | "" -> () | "//" -> strtbl := read ic (pos_in ic) size | s when s.[0] = '/' -> let ofs = int_of_string (String.sub s 1 (String.length s - 1)) in obj size (strz !strtbl ofs '\000') | s when s.[String.length s - 1] = '/' -> let s = String.sub s 0 (String.length s - 1) in obj size s | s -> Printf.ksprintf failwith "Cannot parse archive member %s" s end; seek_in ic (base + size + size mod 2); read_member () in (try read_member () with End_of_file -> ()); !objects,!imports let is_lib ic = in_channel_length ic >= String.length magic_lib && read ic 0 (String.length magic_lib) = magic_lib let obj_ofs ic = try let b = read ic 0x3c 4 in let ofs = int32_ b 0 in if read ic ofs 4 = "PE\000\000" then ofs + 4 else 0 with exn -> 0 let is_dll filename = let ic = open_in_bin filename in let ofs = obj_ofs ic in close_in ic; ofs > 0 let read filename = let ic = open_in_bin filename in try (* let t0 = Unix.gettimeofday () in Printf.printf "Reading %s...%!" filename; *) let r = if is_lib ic then `Lib (read_lib ic filename) else let ofs = obj_ofs ic in `Obj (Coff.get ic ofs 0 filename) in (* close_in ic; *) (* do not close: cf `Lazy *) (* let t1 = Unix.gettimeofday () in Printf.printf " Done (%f ms)\n%!" (t1 -. t0); *) r with exn -> close_in ic; raise exn let read filename = try read filename with exn -> failwith (Printf.sprintf "Error while reading %s: %s" filename (Printexc.to_string exn)) end module Stacksize = struct let set_stack_reserve filename reserve = let ic = open_in_bin filename in let hdr_offset = int16 (read ic 0x3c 2) 0 in let pe_signature = read ic hdr_offset 4 in assert(pe_signature = "PE\000\000"); let coff_hdr = read ic 0 20 in let opthdr_size = int16 coff_hdr 16 in let opthdr = read ic (hdr_offset + 24) opthdr_size in let machine = match int16 opthdr 0 with | 0x10b -> `x86 | 0x20b -> `x64 | magic -> Printf.ksprintf failwith "Cannot determine image target (magic = %x)." magic in let reserve_offset = hdr_offset + 24 + 72 in (* Printf.printf "current stack reserve %ld\n%!" (int32 opthdr 72); *) close_in ic; let oc = open_out_gen [Open_wronly; Open_binary] 0x777 filename in seek_out oc reserve_offset; emit_int32 oc reserve; if machine = `x64 then emit_int32 oc 0l; close_out oc end mingw-ocaml/flexdll/LICENSE0000644000175000017500000000176412124403240015031 0ustar tootstootsThe package FlexDLL is released under the terms of a zlib/libpng License. Copyright (c) 2007, 2008, 2009 Institut National de Recherche en Informatique et en Automatique This software is provided 'as-is', without any express or implied warranty. In no event will the authors be held liable for any damages arising from the use of this software. Permission is granted to anyone to use this software for any purpose, including commercial applications, and to alter it and redistribute it freely, subject to the following restrictions: 1. The origin of this software must not be misrepresented; you must not claim that you wrote the original software. If you use this software in a product, an acknowledgment in the product documentation would be appreciated but is not required. 2. Altered source versions must be plainly marked as such, and must not be misrepresented as being the original software. 3. This notice may not be removed or altered from any source distribution. mingw-ocaml/flexdll/CHANGES0000644000175000017500000001310512124403240015007 0ustar tootstootsVersion 0.30 - Allow the internal linker to create large DLLs (>= 16Mb) Version 0.29 - use "cygpath -S", not "cygpath -v" which no longer exists Version 0.28 - new option '-stack' to set the stack reserve - new option '-patch' (to be used in conjunction with -stack and -o to patch the an existing image) Version 0.27 - support for mingw64; the mingw toolcgain now relies on the 32-bit version of mingw64; the old "gcc -mno-cygwin" is no longer supporte. Patch from Antointe Mine: http://caml.inria.fr/mantis/view.php?id=5179 - fix directive parsing bug (http://caml.inria.fr/mantis/view.php?id=5339) - support for new file layout for cygwin's version of mingw - support for objects with more than 65536 relocations Version 0.26 - fix for Win64 (use a PE32+ optional header, and a lower base address) - use _putenv_s instead of putenv for FLEXDLL_RELOCATE (thanks to Yasutaka Atarashi) - use /dev/null instead of NUL for Cygwin (thanks to Yasutaka Atarashi) Version 0.25 - fix a bug with archive member names that contain a slash Version 0.24 - add new toolchain msvc64; replace the old combination "-chain msvc -x64" (-x64 has been removed) - change build system to create a single binary version of flexdll that includes both the 32-bit and 64-bit version for MSVC's support objects - switch to Visual Studio 2008 (to compile the binary distribution and for the default manifests) Version 0.23 - ignore -D and -U flags (OCaml PR #4979) - change limit before using a response file (OCaml PR #4645) Version 0.22 - fix a bug when emitting IMAGE_COMDAT_SELECT_ASSOCIATIVE symbols Version 0.21 - always use bash to call external commands under Cygwin (to make it work when gcc is a symlink) Version 0.20 - (build) Avoid the use of the rc tool - (dist) add version.rc to the source release - Allow "/link XXX" as an equivalent to "-link XXX" (or "/linkXXX") - Use an explicit .def file under MinGW and Cygwin to force the two symbols reloctbl and symtbl to be exported - Fixes for x64 - Allow to write sections with more than 0xffff relocations - Create a Win32 installer Version 0.19 - fix bug introduced in version 0.17 about virtual addresses for the builtin linker mode Version 0.18 - support for .sxdata section Version 0.17 - patch from Lars Nilsson to ease compilation of flexdll.h with C++ - prefer using XXX.dll.a (import lib) over XXX.a (static lib) - fix bug introduced in commit 136 about virtual addresses Version 0.16 - New -noexport command line option to force an empty symbol table Version 0.15, released on 2009-02-25 - protects calls to cygpath with long command lines (patch from Matthieu Dubuget) - always pass msvcrt.lib to link.exe Version 0.14, released on 2008-28-01 - mingw port: put /lib/mingw before /lib - support for a built-in linker Version 0.13, released on 2008-11-20 - another technique to work around the lack of response file for gcc: put the command line in an external bash script and apply bash to it (relies on the fact that Cygwin programs can call Cygwin programs with long command lines); this idea is from Xavier Leroy - the -subsystem switch is now supported for the mingw toolchain Version 0.12, released on 2008-11-17 - gcc 3 does not support response files; to support longer command lines, we use a custom replacement for cmd.exe (which restricts the length of the command line to 8kB whereas Windows supports 32kB) - patch for Richard Jones: do not find directories when looking for a file Version 0.11, released on 2008-11-10 - compiled with mingw port so as to depend on msvcrt.dll, not msvcr80.dll - experimental support for directly calling "ld" instead of "gcc" - by default, reexport symbols imported from an import library - quote the response file argument - use slashes instead of backslashed in response file (needed for mingw's ld) - by default, use the real manifest Version 0.10, released on 2008-10-21 - use "gcc -mno-cygwin -print-libgcc-file-name" to get the standard library directory for mingw - lower the length threshold to use a diversion file when calling the linker with many arguments Version 0.9, released on 2008-09-18 - fix bug with COFF symbols for sections (with more than 1 auxilliary block) - ignore debug relocations on x86 (of kind 0x000a, 0x000b) Version 0.8, released on 2008-03-10 - new -no-merge-manifest Version 0.7, released on 2008-03-09 - allow .dll.a as automatic extension for libraries - minor bug fixes Version 0.6, released on 2008-02-11 - support COMDAT section symbols - support mixed libraries (import library + regular objects) - optimizations (do not rewrite library objects when not needed, pass the lib to the linker) - new -real-manifest, replace -default-manifest - new -implib option - new -outdef option - new zlib/libpng license Version 0.5, released on 2008-01-11 - new -default-manifest option (always on, currently) - use a temp file name for getting the output of commands (allow several instances of flexlink to run in parallel) Version 0.4, released on 2008-01-02 - Code cleanup - FLEXLINKFLAGS env var to pass extra arguments Version 0.3, released on 2007-11-20 - Make it work under x86_64 - New -subsystem option (currently for MSVC chain only) - New -explain option - New -link option Version 0.2, released on 2007-11-06 - New -maindll option (to build a DLL that contains the "main program" from FlexDLL's point of view) - Can now explicitly enable/disable the use of cygpath (on by default only for Cygwin) - New -L xxx (or -Lxxx) option - New -where option - FLEXDIR environment variable (where to look for FlexDLL's .obj files) Version 0.1, released on 2007-06-14 - Initial release mingw-ocaml/flexdll/Makefile0000644000175000017500000001303212124403240015453 0ustar tootstootsVERSION = 0.30 all: flexlink.exe support include $(shell cygpath -ad "$(shell ocamlopt -where)/Makefile.config") MINGW_PREFIX = i686-w64-mingw32 MINCC = $(MINGW_PREFIX)-gcc MINGW64_PREFIX = x86_64-w64-mingw32 MIN64CC = $(MINGW64_PREFIX)-gcc .PHONY: version.ml version.ml: echo "let version = \"$(VERSION)\"" > version.ml echo "let mingw_prefix = \"$(MINGW_PREFIX)\"" >> version.ml echo "let mingw64_prefix = \"$(MINGW64_PREFIX)\"" >> version.ml # Supported tool-chains CHAINS = mingw mingw64 cygwin msvc msvc64 # Compilers # This Makefile assumes the 32-bit version of VS 2008 or Win7 SDK is in the path. MSVCC_ROOT = $(shell which cl.exe | cygpath -f - -ad | xargs -d \\n dirname | cygpath -f - -m) MSVC_LIB1 = $(shell dirname $(MSVCC_ROOT)) MSVC_LIB2 = $(shell which ResGen.exe | cygpath -f - -ad | xargs -d \\n dirname | xargs -d \\n dirname | cygpath -f - -m) MSVC_LIB = $(MSVC_LIB1)/Lib;$(MSVC_LIB2)/Lib MSVC_INCLUDE = $(MSVC_LIB1)/Include;$(MSVC_LIB2)/Include MSVC_PREFIX=LIB="$(MSVC_LIB)" INCLUDE="$(MSVC_INCLUDE)" MSVC64_LIB = $(MSVC_LIB1)/Lib/amd64;$(MSVC_LIB2)/Lib/x64 MSVC64_PREFIX=LIB="$(MSVC64_LIB)" INCLUDE="$(MSVC_INCLUDE)" show_root: @echo "$(MSVCC_ROOT)" @echo "$(MSVC_LIB)" MSVCC = $(MSVCC_ROOT)/cl.exe /nologo /MD -D_CRT_SECURE_NO_DEPRECATE /GS- MSVCC64 = $(MSVCC_ROOT)/amd64/cl.exe /nologo /MD -D_CRT_SECURE_NO_DEPRECATE /GS- CYGCC = gcc OCAMLOPT = ocamlopt #OCAMLOPT = FLEXLINKFLAGS=-real-manifest ocamlopt #LINKFLAGS = unix.cmxa #ifeq ($(SYSTEM), win64) #LINKFLAGS= #else LINKFLAGS = -ccopt "-link version_res.o" #endif support: for i in $(CHAINS); do $(MAKE) build_$$i ; done build_msvc: flexdll_msvc.obj flexdll_initer_msvc.obj build_msvc64: flexdll_msvc64.obj flexdll_initer_msvc64.obj build_cygwin: flexdll_cygwin.o flexdll_initer_cygwin.o build_mingw: flexdll_mingw.o flexdll_initer_mingw.o build_mingw64: flexdll_mingw64.o flexdll_initer_mingw64.o OBJS = version.ml coff.ml cmdline.ml create_dll.ml reloc.ml flexlink.exe: $(OBJS) version_res.o @echo Building flexlink.exe with TOOLCHAIN=$(TOOLCHAIN) rm -f flexlink.exe $(OCAMLOPT) -w -105 -o flexlink.exe $(LINKFLAGS) $(OBJS) version_res.o: version.rc windres version.rc version_res.o flexdll_msvc.obj: flexdll.h flexdll.c $(MSVC_PREFIX) $(MSVCC) /DMSVC -c /Fo"flexdll_msvc.obj" flexdll.c flexdll_msvc64.obj: flexdll.h flexdll.c $(MSVC64_PREFIX) $(MSVCC64) /DMSVC -c /Fo"flexdll_msvc64.obj" flexdll.c flexdll_cygwin.o: flexdll.h flexdll.c $(CYGCC) -c -DCYGWIN -o flexdll_cygwin.o flexdll.c flexdll_mingw.o: flexdll.h flexdll.c $(MINCC) -c -DMINGW -o flexdll_mingw.o flexdll.c flexdll_mingw64.o: flexdll.h flexdll.c $(MIN64CC) -c -DMINGW -o flexdll_mingw64.o flexdll.c flexdll_initer_msvc.obj: flexdll_initer.c $(MSVC_PREFIX) $(MSVCC) -c /Fo"flexdll_initer_msvc.obj" flexdll_initer.c flexdll_initer_msvc64.obj: flexdll_initer.c $(MSVC64_PREFIX) $(MSVCC64) -c /Fo"flexdll_initer_msvc64.obj" flexdll_initer.c flexdll_initer_cygwin.o: flexdll_initer.c $(CYGCC) -c -o flexdll_initer_cygwin.o flexdll_initer.c flexdll_initer_mingw.o: flexdll_initer.c $(MINCC) -c -o flexdll_initer_mingw.o flexdll_initer.c flexdll_initer_mingw64.o: flexdll_initer.c $(MIN64CC) -c -o flexdll_initer_mingw64.o flexdll_initer.c demo_msvc: flexlink.exe flexdll_msvc.obj flexdll_initer_msvc.obj (cd test && $(MSVC_PREFIX) $(MAKE) clean demo CHAIN=msvc CC="$(MSVCC)" O=obj) demo_cygwin: flexlink.exe flexdll_cygwin.o flexdll_initer_cygwin.o (cd test && $(MAKE) clean demo CHAIN=cygwin CC="$(CYGCC)" O=o) demo_mingw: flexlink.exe flexdll_mingw.o flexdll_initer_mingw.o (cd test && $(MAKE) clean demo CHAIN=mingw CC="$(MINCC)" O=o) demo_mingw64: flexlink.exe flexdll_mingw64.o flexdll_initer_mingw64.o (cd test && $(MAKE) clean demo CHAIN=mingw64 CC="$(MIN64CC)" O=o) demo_msvc64: flexlink.exe flexdll_msvc64.obj flexdll_initer_msvc64.obj (cd test && $(MSVC64_PREFIX) $(MAKE) clean demo CHAIN=msvc64 CC="$(MSVCC64)" O=obj) clean: rm -f *.obj *.o *.lib *.a *.exe *.cmx *.dll *.exp *.cmi *~ cd test && $(MAKE) clean ## Packaging COMMON_FILES = LICENSE README CHANGES flexdll.h flexdll.c flexdll_initer.c default.manifest default_amd64.manifest URL = frisch@frisch.fr:www/flexdll/ # Source packages PACKAGE = flexdll-$(VERSION).tar.gz package_src: rm -Rf flexdll mkdir flexdll mkdir flexdll/test cp -a *.ml Makefile $(COMMON_FILES) version.rc flexdll/ cp -aR test/Makefile test/*.c flexdll/test/ tar czf $(PACKAGE) flexdll rm -Rf flexdll upload: rsync $(PACKAGE) CHANGES LICENSE $(URL) upload_dev: $(MAKE) VERSION=dev upload_src upload_src: package_src upload # Binary package PACKAGE_BIN = flexdll-bin-$(VERSION)$(PACKAGE_BIN_SUFFIX).zip INSTALLER = flexdll-$(VERSION)$(PACKAGE_BIN_SUFFIX)-setup.exe package_bin: $(MAKE) clean all rm -f $(PACKAGE_BIN) zip $(PACKAGE_BIN) $(COMMON_FILES) \ flexlink.exe flexdll_*.obj flexdll_*.o do_upload_bin: rsync $(PACKAGE_BIN) $(URL) upload_bin: package_bin do_upload_bin show_toolchain: @echo Toolchain for the visible ocamlopt: $(TOOLCHAIN) swap: NOMLFICORE=1 $(OCAMLOPT) -o flexlink-new.exe $(LINKFLAGS) $(OBJS) cp flexlink.exe flexlink.exe.bak cp flexlink-new.exe flexlink.exe #PREFIX = "C:\Program Files\flexdll" # #install: # mkdir -p $(PREFIX) # cp $(COMMON_FILES) flexlink.exe flexdll_*.obj flexdll_*.o $(PREFIX) installer: rm -rf flexdll_install_files mkdir flexdll_install_files (cd flexdll_install_files && unzip ../$(PACKAGE_BIN)) /cygdrive/c/Program\ Files\ \(x86\)/NSIS/makensis installer.nsi mv flexdll_setup.exe $(INSTALLER) upload_installer: rsync $(INSTALLER) $(URL) upload_all: $(MAKE) upload_src upload_bin installer upload_installer mingw-ocaml/flexdll/README0000644000175000017500000000015212124403240014672 0ustar tootstootsFlexDLL: an implementation of a dlopen-like API for Windows Homepage: http://alain.frisch.fr/flexdll.htmlmingw-ocaml/flexdll/default_amd64.manifest0000755000175000017500000000061712124403240020172 0ustar tootstoots mingw-ocaml/flexdll/version.rc0000644000175000017500000000123212124403240016025 0ustar tootstoots// $Id: version.rc 17059 2008-09-07 20:15:33Z jmeber $ #include "afxres.h" LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_US #pragma code_page(1252) ///////////////////////////////////////////////////////////////////////////// // // Version // VS_VERSION_INFO VERSIONINFO FILEVERSION 0,0,0,30 PRODUCTVERSION 0,0,0,30 FILEFLAGSMASK 0x3fL FILEFLAGS 0x0L FILEOS 0x40004L FILETYPE 0x1L FILESUBTYPE 0x0L BEGIN BLOCK "StringFileInfo" BEGIN BLOCK "040904b0" BEGIN VALUE "FileVersion", "0.0.0.30" END END BLOCK "VarFileInfo" BEGIN VALUE "Translation", 0x409, 1200 END END mingw-ocaml/flexdll/flexdll.h0000644000175000017500000000134012124403240015615 0ustar tootstoots/***************************************************************** FlexDLL Alain Frisch Copyright 2007 Institut National de Recherche en Informatique et en Automatique. ******************************************************************/ /* Header for the runtime support library */ #ifndef FLEXDLL_H #define FLEXDLL_H #define FLEXDLL_RTLD_GLOBAL 0x0001 #define FLEXDLL_RTLD_LOCAL 0x0000 #define FLEXDLL_RTLD_NOEXEC 0x0002 #ifdef __cplusplus extern "C" { #endif void *flexdll_dlopen(const char *, int); void *flexdll_dlsym(void *, const char *); void flexdll_dlclose(void *); char *flexdll_dlerror(void); void flexdll_dump_exports(void *); void flexdll_dump_relocations(void *); #ifdef __cplusplus } #endif #endif mingw-ocaml/flexdll/flexdll_initer.c0000644000175000017500000000245712124403240017174 0ustar tootstoots/***************************************************************** FlexDLL Alain Frisch Copyright 2007 Institut National de Recherche en Informatique et en Automatique. ******************************************************************/ /* Custom entry point to perform relocations before the real entry point is called */ /* The adress of the flexdll_relocate function is passed in an environment variable. This is ugly, but I couldn't find a cleaner solution. Let me know if you have some idea! */ #include #include #include typedef int func(void*); extern int reloctbl; static int flexdll_init() { func *sym = 0; char *s = getenv("FLEXDLL_RELOCATE"); if (!s) { fprintf(stderr, "Cannot find FLEXDLL_RELOCATE\n"); return FALSE; } sscanf(s,"%p",&sym); if (sym && sym(&reloctbl)) return TRUE; return FALSE; } #ifdef __GNUC__ #ifdef __CYGWIN__ #define entry _cygwin_dll_entry #endif #ifdef __MINGW32__ #define entry DllMainCRTStartup #endif #else #define entry _DllMainCRTStartup #endif BOOL WINAPI entry(HINSTANCE, DWORD, LPVOID); BOOL WINAPI FlexDLLiniter(HINSTANCE hinstDLL, DWORD fdwReason, LPVOID lpReserved) { if (fdwReason == DLL_PROCESS_ATTACH && !flexdll_init()) return FALSE; return entry(hinstDLL, fdwReason, lpReserved); } mingw-ocaml/flexdll/reloc.ml0000644000175000017500000010311312124403240015451 0ustar tootstoots(************************************************************************) (* FlexDLL *) (* Alain Frisch *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. *) (************************************************************************) (* The main application: parse COFF files, compute relocation and export tables, rewrite some COFF files, call the native linker *) open Coff open Cmdline let search_path = ref [] let default_libs = ref [] let gcc = ref "gcc" let objdump = ref "objdump" let is_crt_lib = function | "LIBCMT" | "MSVCRT" -> true | fn -> false let flexdir = try let s = Sys.getenv "FLEXDIR" in if s = "" then raise Not_found else s with Not_found -> Filename.dirname Sys.executable_name (* Temporary files *) let temps = ref [] let add_temp fn = temps := fn :: !temps; fn let temp_file s x = add_temp (Filename.temp_file s x) let open_temp_file s x = let (f, c) = Filename.open_temp_file s x in (add_temp f, c) let safe_remove s = try Sys.remove s with Sys_error _ -> () let () = at_exit (fun () -> if not !save_temps then List.iter safe_remove !temps) (* Calling external commands *) let read_file fn = let ic = open_in fn in let r = ref [] in (try while true do r := input_line ic :: !r done with End_of_file -> ()); close_in ic; List.rev !r let get_output ?(use_bash = false) cmd = let fn = Filename.temp_file "flexdll" "" in let cmd' = cmd ^ " > " ^ (Filename.quote fn) in if String.length cmd' < 8182 && not use_bash then begin if (Sys.command cmd' <> 0) then failwith ("Cannot run " ^ cmd); end else begin let (cfn, oc) = open_temp_file "longcmd" ".sh" in output_string oc cmd'; close_out oc; if Sys.command (Printf.sprintf "bash %s" cfn) <> 0 then failwith ("Cannot run " ^ cmd) end; let r = read_file fn in Sys.remove fn; r let get_output1 ?use_bash cmd = List.hd (get_output ?use_bash cmd) (* Preparing command line *) let mk_dirs_opt pr = String.concat " " (List.map (fun s -> pr ^ (Filename.quote s)) !dirs) (* Build @responsefile to work around Windows limitations on command-line length *) let build_diversion lst = let (responsefile, oc) = open_temp_file "camlresp" "" in List.iter (fun f -> if f <> "" then begin let s = Filename.quote f in for i = 0 to String.length s - 1 do if s.[i] = '\\' then s.[i] <- '/' done; output_string oc s; output_char oc '\n' end) lst; close_out oc; "@" ^ responsefile type cmdline = { may_use_response_file: bool; mutable too_long: bool; } let new_cmdline () = let rf = match !toolchain with | `MSVC | `MSVC64 | `LIGHTLD -> true | `MINGW | `MINGW64 | `CYGWIN -> false in { may_use_response_file = rf; too_long = false; } let run_command cmdline cmd = let cmd_quiet = match !toolchain with | `MSVC | `MSVC64 when !verbose < 1 -> cmd ^ " >NUL" | _ -> cmd in (* note: for Cygwin, using bash allow to follow symlinks to find gcc... *) if cmdline.too_long || !toolchain = `CYGWIN then begin (* Dump the command in a text file and apply bash to it. *) let (fn, oc) = open_temp_file "longcmd" "" in output_string oc cmd; close_out oc; if !verbose >= 1 then Printf.printf "(call with bash: %s)\n%!" fn; if Sys.command (Printf.sprintf "bash %s" fn) <> 0 then failwith "Error during linking\n" end else if Sys.command cmd_quiet <> 0 then begin if cmd <> cmd_quiet then ignore (Sys.command cmd); failwith "Error during linking\n" end let quote_files cmdline lst = let s = String.concat " " (List.map (fun f -> if f = "" then f else Filename.quote f) lst) in if String.length s >= 1024 then if cmdline.may_use_response_file then Filename.quote (build_diversion lst) else (cmdline.too_long <- true; s) else s (* Looking for files *) let cygpath l = get_output (Printf.sprintf "cygpath -m %s" (String.concat " " (List.map Filename.quote l))) let file_exists fn = if Sys.file_exists fn && not (Sys.is_directory fn) then Some fn else if !use_cygpath && Sys.file_exists (fn ^ ".lnk") then Some (get_output1 (Printf.sprintf "cygpath -m %s" fn)) else None let rec find_file_in = function | [] -> None | fn::rest -> match file_exists fn with | Some x -> Some x | None -> find_file_in rest let find_file fn = let l = List.flatten (List.map (fun dir -> let fn = Filename.concat dir fn in [ fn; fn ^ ".lib"; fn ^ ".dll.a"; fn ^ ".a" ] ) (""::!search_path)) in match find_file_in l with | Some x -> Some x | None -> if !use_cygpath then find_file_in (cygpath l) else None let find_file = let memo = Hashtbl.create 16 in fun fn -> let k = String.lowercase fn in try Hashtbl.find memo k with Not_found -> try Hashtbl.find memo (k ^ ".lib") with Not_found -> let fn = if String.length fn > 2 && String.sub fn 0 2 = "-l" then "lib" ^ (String.sub fn 2 (String.length fn - 2)) else fn in let r = match find_file fn with | Some fn -> fn | None -> failwith (Printf.sprintf "Cannot find file %S" fn) in Hashtbl.add memo k r; Hashtbl.add memo (k ^ ".lib") r; r (*******************************) let int32_to_buf b i = Buffer.add_char b (Char.chr (i land 0xff)); Buffer.add_char b (Char.chr ((i lsr 8) land 0xff)); Buffer.add_char b (Char.chr ((i lsr 16) land 0xff)); Buffer.add_char b (Char.chr ((i lsr 24) land 0xff)) let int_to_buf b i = assert(i >= 0); match !machine with | `x86 -> int32_to_buf b i | `x64 -> int32_to_buf b i; int32_to_buf b 0 let exportable s = match !machine with | `x86 -> s <> "" && (s.[0] = '_' || s.[0] = '?') | `x64 -> if String.length s > 2 && s.[0] = '?' && s.[1] = '?' then false else true let drop_underscore obj s = match !machine with | `x86 -> assert (s <> ""); begin match s.[0] with | '_' -> String.sub s 1 (String.length s - 1) | '?' -> s | _ -> failwith (Printf.sprintf "In %s, symbol %s doesn't start with _ or ?" obj.obj_name s) end | `x64 -> s let has_prefix pr s = String.length s > String.length pr && String.sub s 0 (String.length pr) = pr let check_prefix pr s = if has_prefix pr s then Some (String.sub s (String.length pr) (String.length s - String.length pr)) else None let parse_libpath s = let n = String.length s in let rec aux l = if l >= n then [] else try let i = String.index_from s l ';' in String.sub s l (i - l) :: aux (succ i) with Not_found -> [ String.sub s l (n - l) ] in aux 0 module StrSet = Set.Make(String) (* Put all the relocations on the symbols defined by a predicate into a relocation table. A relocation table describes how to patch some addresses with the value of some external symbols (given by their name). It also lists segments that are normally write-protected and that must be de-protected to enable the patching process. *) let add_reloc_table x p sname = let sect = Section.create ".reltbl" 0xc0300040l in let data = Buffer.create 1024 in let strings = Buffer.create 1024 in let nonwr = ref [] in let nonwrsym = Symbol.intern sect 0l in let strsym = Symbol.intern sect 0l in let str_pos = Hashtbl.create 16 in Reloc.abs !machine sect 0l nonwrsym; int_to_buf data 0; (* TODO: use a single symbol per section *) let syms = ref [] in let reloc sec secsym min max rel = if p rel.symbol then ( (* kind *) let kind = match !machine, rel.rtype with | `x86, 0x06 | `x64, 0x01 -> 0x0002 (* absolute, native size (32/64) *) | `x86, 0x14 | `x64, 0x04 -> 0x0001 (* rel32 *) | `x64, 0x05 -> 0x0004 (* rel32_1 *) | `x64, 0x08 -> 0x0003 (* rel32_4 *) | `x64, 0x06 -> 0x0005 (* rel32_2 *) | `x86, (0x0a | 0x0b) -> 0x0100 (* debug relocs: ignore *) | _, k -> let msg = Printf.sprintf "Unsupported relocation kind %04x for %s" k rel.symbol.sym_name in failwith msg (* Printf.eprintf "%s\n" msg; 0x0001 *) in int_to_buf data kind; (* name *) let name = drop_underscore x rel.symbol.sym_name in let pos = try Hashtbl.find str_pos name with Not_found -> let pos = Buffer.length strings in Hashtbl.add str_pos name pos; Buffer.add_string strings name; Buffer.add_char strings '\000'; pos in Reloc.abs !machine sect (Int32.of_int (Buffer.length data)) strsym; int_to_buf data pos; Reloc.abs !machine sect (Int32.of_int (Buffer.length data)) (Lazy.force secsym); int_to_buf data (Int32.to_int rel.addr); if rel.addr <= !min then min := rel.addr; if rel.addr >= !max then max := rel.addr; false ) else true in let section sec = let min = ref Int32.max_int and max = ref Int32.min_int in let sym = lazy (let s = Symbol.intern sec 0l in syms := s :: !syms; s) in sec.relocs <- filter (reloc sec sym min max) sec.relocs; if (sec.sec_opts &&& 0x80000000l = 0l) && !min <= !max then nonwr := (!min,!max,Lazy.force sym) :: !nonwr in List.iter section x.sections; int_to_buf data 0; strsym.value <- Int32.of_int (Buffer.length data); Buffer.add_buffer data strings; nonwrsym.value <- Int32.of_int (Buffer.length data); List.iter (fun (min,max,secsym) -> Reloc.abs !machine sect (Int32.of_int (Buffer.length data)) secsym; int_to_buf data (Int32.to_int min); Reloc.abs !machine sect (Int32.of_int (Buffer.length data)) secsym; int_to_buf data (Int32.to_int max); int_to_buf data 0; ) !nonwr; int_to_buf data 0; int_to_buf data 0; sect.data <- `String (Buffer.contents data); x.sections <- sect :: x.sections; x.symbols <- (Symbol.export sname sect 0l) :: strsym :: nonwrsym :: List.filter (fun x -> not (p x)) x.symbols @ !syms (* Create a table for import symbols __imp_XXX *) let add_import_table obj imports = let sect = Section.create ".imptbl" 0xc0300040l in obj.sections <- sect :: obj.sections; sect.data <- `String (String.make (4 * List.length imports) '\000'); ignore (List.fold_left (fun i s -> let sym = Symbol.extern s in obj.symbols <- sym :: Symbol.export ("__imp_" ^ s) sect (Int32.of_int i) :: obj.symbols; Reloc.abs !machine sect (Int32.of_int i) sym; i + 4) 0 imports) (* Create a table that lists exported symbols (adress,name) *) let add_export_table obj exports symname = let sect = Section.create ".exptbl" 0xc0300040l in let data = Buffer.create 1024 in let strings = Buffer.create 1024 in let strsym = Symbol.intern sect 0l in obj.symbols <- strsym :: (Symbol.export symname sect 0l) :: obj.symbols; let exports = List.sort Pervasives.compare exports in (* The runtime library assumes that names are sorted! *) int_to_buf data (List.length exports); List.iter (fun s -> let sym = Symbol.extern s in obj.symbols <- sym :: obj.symbols; Reloc.abs !machine sect (Int32.of_int (Buffer.length data)) sym; int_to_buf data 0; Reloc.abs !machine sect (Int32.of_int (Buffer.length data)) strsym; int_to_buf data (Buffer.length strings); Buffer.add_string strings (drop_underscore obj s); Buffer.add_char strings '\000'; ) exports; strsym.value <- Int32.of_int (Buffer.length data); sect.data <- `String (Buffer.contents data ^ Buffer.contents strings); obj.sections <- sect :: obj.sections (* A master relocation table points to all the relocation tables in the DLL *) let add_master_reloc_table obj names symname = let sect = Section.create ".mreltbl" 0xc0300040l in let data = Buffer.create 1024 in obj.symbols <- (Symbol.export symname sect 0l) :: obj.symbols; List.iter (fun s -> let sym = Symbol.extern s in obj.symbols <- sym :: obj.symbols; Reloc.abs !machine sect (Int32.of_int (Buffer.length data)) sym; int_to_buf data 0; ) names; int_to_buf data 0; sect.data <- `String (Buffer.contents data); obj.sections <- sect :: obj.sections let collect_dllexports obj = let dirs = Coff.directives obj in let l = List.map (function (_,x::_) -> x | _ -> assert false) (List.find_all (fun (cmd,args) -> String.uppercase cmd = "EXPORT") dirs) in match !toolchain with | `MSVC | `MSVC64 -> List.map (drop_underscore obj) l | _ -> l let exports accu obj = List.fold_left (fun accu sym -> if Symbol.is_defin sym && exportable sym.sym_name then StrSet.add sym.sym_name accu else accu) accu obj.symbols let needed f accu obj = let l = List.filter Symbol.is_extern obj.symbols in List.fold_left (fun accu sym -> StrSet.add (f sym.sym_name) accu) accu l let collect f l = List.fold_left (fun accu x -> match f x with None -> accu | Some y -> y :: accu) [] l let cmd_verbose cmd = if !verbose >= 1 then Printf.printf "+ %s\n" cmd; Sys.command cmd let parse_dll_exports fn = let ic = open_in fn in let exps = ref [] in try while input_line ic <> "[Ordinal/Name Pointer] Table" do () done; while true do let s = input_line ic in let r = String.index s ']' in let sym = String.sub s (r+2) (String.length s - r - 2) in exps := ("_" ^ sym,0) :: !exps; done; assert false with Not_found | End_of_file -> close_in ic; !exps let dll_exports fn = match !toolchain with | `MSVC | `MSVC64 | `LIGHTLD -> failwith "Creation of import library not supported for this toolchain" | `CYGWIN | `MINGW | `MINGW64 -> let dmp = temp_file "dyndll" ".dmp" in if cmd_verbose (Printf.sprintf "%s -p %s > %s" !objdump fn dmp) <> 0 then failwith "Error while extracting exports from a DLL"; parse_dll_exports dmp let patch_output output_file = match !stack_reserve with | Some x -> Stacksize.set_stack_reserve output_file x | None -> () let build_dll link_exe output_file files exts extra_args = let main_pgm = link_exe <> `DLL in (* fully resolve filenames, eliminate duplicates *) let _,files = List.fold_left (fun (seen,accu) fn -> let fn = find_file fn in let k = String.lowercase fn in if StrSet.mem k seen then (seen, accu) else (StrSet.add k seen, fn :: accu) ) (StrSet.empty,[]) files in let files = List.rev files in (* load given files *) let loaded_filenames : (string,unit) Hashtbl.t = Hashtbl.create 16 in let files = List.map (fun fn -> if Lib.is_dll fn then fn,`Lib ([], dll_exports fn) else fn, Lib.read fn) files in List.iter (fun (fn,_) -> Hashtbl.add loaded_filenames fn ()) files; let objs = collect (function (f,`Obj x) -> Some (f,x) | _ -> None) files in let libs = collect (function (f,`Lib (x,_)) -> Some (f,x) | _ -> None) files in let from_imports = ref StrSet.empty in let defined = ref StrSet.empty in let add_def s = defined := StrSet.add s !defined in if main_pgm then add_def (usym "static_symtable") else add_def (usym "reloctbl"); if !machine = `x64 then add_def "__ImageBase" else add_def "___ImageBase"; let aliases = Hashtbl.create 16 in let rec normalize name = try let r = Hashtbl.find aliases name in if r <> name then normalize r else r with Not_found -> name in (* Collect all the available symbols, including those defined in default libraries *) let collected = Hashtbl.create 8 in let rec collect_defined_obj obj = List.iter (fun (x,y) -> if !verbose >= 2 then Printf.printf "alias %s -> %s\n" x y; Hashtbl.add aliases x y) (Coff.aliases obj); let dirs = Coff.directives obj in let all_args c = List.map snd ( List.find_all (fun (cmd,args) -> String.uppercase cmd = c) dirs) in let deflibs = if !builtin_linker || not !use_default_libs then [] else List.flatten (all_args "DEFAULTLIB") in List.iter (fun fn -> if !custom_crt && is_crt_lib fn then () else let fn = find_file fn in if not (Hashtbl.mem loaded_filenames fn) then (Hashtbl.add loaded_filenames fn (); collect_file fn)) deflibs; List.iter (fun sym -> if Symbol.is_defin sym then add_def sym.sym_name ) obj.symbols and collect_file fn = if not (Hashtbl.mem collected (String.lowercase fn)) then begin Hashtbl.replace collected (String.lowercase fn) (); if !verbose >= 2 then Printf.printf "** open: %s\n" fn; collect_defined fn (Lib.read fn) end and collect_defined fn = function | `Obj obj -> collect_defined_obj obj | `Lib (objs,imports) -> List.iter (fun (_,obj) -> collect_defined_obj obj) objs; List.iter (fun (s,_) -> if !verbose >= 2 then Printf.printf "lib %s import symbol %s\n%!" fn s; from_imports := StrSet.add s !from_imports; add_def s; add_def ("__imp_" ^ s) ) imports in List.iter (fun (fn,x) -> Hashtbl.replace collected (String.lowercase fn) (); collect_defined fn x) files; if !use_default_libs then List.iter (fun fn -> collect_file (find_file fn)) !default_libs; List.iter (fun fn -> collect_file (find_file fn)) exts; (* Determine which objects from the given libraries should be linked in. First step: find the mapping (symbol -> object) for these objects. *) let defined_in = Hashtbl.create 16 in let def_in_obj fn (objname,obj) = List.iter (fun sym -> if Symbol.is_defin sym then begin if !explain then Printf.printf "Symbol %s found in %s(%s)\n%!" sym.sym_name fn objname; Hashtbl.replace defined_in sym.sym_name (fn,objname,obj); end ) obj.symbols in List.iter (fun (fn,objs) -> if !explain then Printf.printf "Scanning lib %s\n%!" fn; List.iter (def_in_obj fn) objs) libs; let imported_from_implib = ref StrSet.empty in let imported = ref StrSet.empty in let normalize name = let name = normalize name in match check_prefix "__imp_" name with | Some s when not (StrSet.mem name !defined) && StrSet.mem s !defined -> s | _ -> name in let needed obj = needed normalize StrSet.empty obj in let imports obj = let n = needed obj in imported_from_implib := StrSet.union !imported_from_implib (StrSet.inter n !from_imports); let undefs = StrSet.diff n !defined in StrSet.filter (fun s -> match check_prefix "__imp_" s with | Some s' -> (*Printf.printf "import for %s: %s\n" obj.obj_name s; *) imported := StrSet.add s' !imported; false | None -> true) undefs in (* Second step: transitive closure, starting from given objects *) let libobjects = Hashtbl.create 16 in let reloctbls = ref [] in let exported = ref StrSet.empty in List.iter (fun s -> exported := StrSet.add (usym s) !exported) !defexports; (* re-export symbols imported from implibs *) (* disabled: symbols may be undefined in the DLL! that would raise an error at startup *) (* List.iter (function | (_,`Lib (_,l)) -> exported := List.fold_left (fun accu (s,_) -> if exportable s then StrSet.add s accu else accu ) !exported l | _ -> ()) files; *) let record_obj name obj = if !builtin_linker then "" else begin let fn = temp_file "dyndll" (if !toolchain = `MSVC || !toolchain = `MSVC64 then ".obj" else ".o") in let oc = open_out_bin fn in Coff.put oc obj; close_out oc; fn end in let add_reloc name obj imps = if !show_imports && not (StrSet.is_empty imps) then ( Printf.printf "** Imported symbols for %s:\n" name; StrSet.iter print_endline imps ); let reloctbl = Symbol.gen_sym () in reloctbls := reloctbl :: !reloctbls; add_reloc_table obj (fun s -> StrSet.mem s.sym_name imps) reloctbl in let errors = ref false in let error_imports name imps = if main_pgm then begin Printf.eprintf "** Cannot resolve symbols for %s:\n %s\n%!" name (String.concat "\n " (StrSet.elements imps)); errors := true end in let close_obj name imps obj = error_imports name imps; add_reloc name obj imps; record_obj name obj in let dll_exports = ref StrSet.empty in let rec link_obj fn obj = exported := exports !exported obj; dll_exports := List.fold_left (fun accu x -> StrSet.add x accu) !dll_exports (collect_dllexports obj); StrSet.iter (fun s -> if StrSet.mem s !exported then () else try let (libname, objname, _) as o = Hashtbl.find defined_in s in if !explain then Printf.printf "%s -> %s(%s) because of %s\n%!" fn libname objname s; link_libobj o with Not_found -> if !explain then Printf.printf "%s needs %s (not found)\n%!" fn s ) (needed obj) and link_libobj (libname,objname,obj) = if Hashtbl.mem libobjects (libname,objname) then () else (Hashtbl.replace libobjects (libname,objname) (obj,imports obj); link_obj (Printf.sprintf "%s(%s)" libname objname) obj) in let redirect = Hashtbl.create 16 in List.iter (fun (fn,obj) -> link_obj fn obj; let imps = imports obj in if (StrSet.is_empty imps) then () else Hashtbl.replace redirect fn (close_obj fn imps obj); ) objs; let need_lib = Hashtbl.create 16 in Hashtbl.iter (fun (libname,objname) (obj,imps) -> if StrSet.is_empty imps then Hashtbl.replace need_lib libname () (* the linker will find this object in this library *) else begin if !explain then Printf.printf "Library object %s(%s) needs to be rewritten\n" libname objname; Hashtbl.add redirect libname (close_obj (Printf.sprintf "%s(%s)" libname objname) imps obj) end ) libobjects; if !show_exports then ( Printf.printf "** Exported symbols:\n"; StrSet.iter print_endline !exported; Printf.printf "** Symbols from import libs:\n"; StrSet.iter print_endline !imported_from_implib; ); if !reexport_from_implibs then exported := StrSet.union !exported !imported_from_implib; (* Create the descriptor object *) let obj = Coff.create !machine in if not (StrSet.is_empty !imported) then begin error_imports "descriptor object" !imported; add_import_table obj (StrSet.elements !imported); add_reloc "descriptor object" obj !imported; end; add_export_table obj (if !noexport then [] else StrSet.elements !exported) (usym (if main_pgm then "static_symtable" else "symtbl")); if not main_pgm then add_master_reloc_table obj !reloctbls (usym "reloctbl"); if !errors then exit 2; if !builtin_linker then begin let objs = List.map (function | (_, `Obj obj) -> obj | (fn, _) -> failwith ("File is not an object file: " ^ fn) ) files in let oc = open_out_bin output_file in Create_dll.create_dll oc (obj :: objs); close_out oc end else let descr = record_obj "descriptor" obj in let files = List.flatten (List.map (fun (fn,d) -> let all = Hashtbl.find_all redirect fn in if all = [] then [fn] else match d with | `Lib _ when Hashtbl.mem need_lib fn -> all @ [fn] | `Lib (_, []) | `Obj _ -> all | `Lib _ -> all @ [fn] (* Note: extracted object have higher priorities than objects embedded in the library, so this is ok. We always keep libraries with import symbols. For mingw, it is necessary to put the library after extracted objects. *) ) files ) @ exts in let cmdline = new_cmdline () in let files = quote_files cmdline files in let descr = Filename.quote descr in begin match !deffile with | Some x when not !dry_mode -> let fn = if x = "" then Filename.chop_extension output_file ^ ".def" else x in if !verbose >= 1 then Printf.printf "Generate %s\n%!" fn; let oc = open_out fn in Printf.fprintf oc "LIBRARY %s\n" output_file; Printf.fprintf oc "EXPORTS\n"; StrSet.iter (Printf.fprintf oc " %s\n") !dll_exports; close_out oc | _ -> () end; let cmd = match !toolchain with | `MSVC | `MSVC64 -> (* Putting the file the descriptor object at the beginning with MSVC compilers seems to break Stack overflow recovery in OCaml. No idea why. *) let implib = if !implib then Filename.chop_extension output_file ^ ".lib" else temp_file "dyndll_implib" ".lib" in let _impexp = add_temp (Filename.chop_suffix implib ".lib" ^ ".exp") in let extra_args = if !custom_crt then "/nodefaultlib:LIBCMT /nodefaultlib:MSVCRT " ^ extra_args else "msvcrt.lib " ^ extra_args in let extra_args = if !machine = `x64 then "/base:0x10000 " ^ extra_args else extra_args in (* Flexdll requires that all images (main programs and all the DLLs) are not too far away. This is needed because of the 32-bit relative relocations (e.g. function calls). It seems that passing such a /base argument to link.exe gives some hope that this will be the case. Problems observed otherwise with the Windows 7 SDK in 64-bit mode. *) Printf.sprintf "link /nologo %s%s%s%s%s /implib:%s /out:%s /subsystem:%s %s %s %s" (if !verbose >= 2 then "/verbose " else "") (if link_exe = `EXE then "" else "/dll ") (if main_pgm then "" else "/export:symtbl /export:reloctbl ") (if main_pgm then "" else if !noentry then "/noentry " else let s = match !machine with | `x86 -> "FlexDLLiniter@12" | `x64 -> "FlexDLLiniter" in Printf.sprintf "/entry:%s " s ) (mk_dirs_opt "/libpath:") (Filename.quote implib) (Filename.quote output_file) !subsystem files descr extra_args | `CYGWIN -> let def_file = if main_pgm then "" else let def_file, oc = open_temp_file "flexlink" ".def" in Printf.fprintf oc "EXPORTS\n reloctbl\n symtbl\n"; close_out oc; Filename.quote def_file in Printf.sprintf "%s %s%s -L. %s %s -o %s %s %s %s %s" !gcc (if link_exe = `EXE then "" else "-shared ") (if main_pgm then "" else if !noentry then "-Wl,-e0 " else "-Wl,-e_FlexDLLiniter@12 ") (mk_dirs_opt "-I") (mk_dirs_opt "-L") (Filename.quote output_file) descr files def_file extra_args | `MINGW | `MINGW64 -> let def_file = if main_pgm then "" else let def_file, oc = open_temp_file "flexlink" ".def" in Printf.fprintf oc "EXPORTS\n reloctbl\n symtbl\n"; close_out oc; Filename.quote def_file in Printf.sprintf "%s -m%s %s%s -L. %s %s -o %s %s %s %s %s %s" !gcc !subsystem (if link_exe = `EXE then "" else "-shared ") (if main_pgm then "" else if !noentry then "-Wl,-e0 " else if !machine = `x86 then "-Wl,-e_FlexDLLiniter@12 " else "-Wl,-eFlexDLLiniter ") (mk_dirs_opt "-I") (mk_dirs_opt "-L") (Filename.quote output_file) descr files def_file (if !implib then "-Wl,--out-implib=" ^ Filename.quote (Filename.chop_extension output_file ^ ".a") else "") extra_args | `LIGHTLD -> no_merge_manifest := true; Printf.sprintf "ld %s%s -o %s %s %s %s %s" (if link_exe = `EXE then "" else "--shared ") (if main_pgm then "" else if !noentry then "-e0 " else "-e FlexDLLiniter@12 ") (Filename.quote output_file) descr files (if !implib then "--out-implib " ^ Filename.quote (Filename.chop_extension output_file ^ ".a") else "") extra_args in if !verbose >= 1 || !dry_mode then Printf.printf "+ %s\n%!" cmd; if not !dry_mode then begin let manifest_file = output_file ^ ".manifest" in safe_remove manifest_file; run_command cmdline cmd; if (not !no_merge_manifest) && !merge_manifest && (not !real_manifest || Sys.file_exists manifest_file) then begin let fn = if !real_manifest then manifest_file else let default_manifest = match !machine with | `x86 -> "default.manifest" | `x64 -> "default_amd64.manifest" in Filename.concat flexdir default_manifest in let mcmd = Printf.sprintf "mt -nologo -outputresource:%s -manifest %s" (Filename.quote (if link_exe = `EXE then output_file else output_file ^ ";#2")) (Filename.quote fn) in if !verbose >= 1 then Printf.printf "+ %s\n%!" mcmd; if Sys.command mcmd <> 0 then failwith "Error while merging the manifest"; safe_remove manifest_file; end; patch_output output_file end let setup_toolchain () = let mingw_libs pre = gcc := pre ^ "-gcc"; objdump := pre ^ "-objdump"; search_path := !dirs @ [ Filename.dirname (get_output1 (!gcc ^ " -print-libgcc-file-name")); get_output1 (!gcc ^ " -print-sysroot") ^ "/mingw/lib"; ]; default_libs := ["-lmingw32"; "-lgcc"; "-lmoldname"; "-lmingwex"; "-lmsvcrt"; "-luser32"; "-lkernel32"; "-ladvapi32"; "-lshell32" ]; if !exe_mode = `EXE then default_libs := "crt2.o" :: !default_libs else default_libs := "dllcrt2.o" :: !default_libs in match !toolchain with | _ when !builtin_linker -> search_path := !dirs; add_flexdll_obj := false; noentry := true | `CYGWIN -> gcc := "gcc"; objdump := "objdump"; search_path := !dirs @ [ "/lib"; "/lib/w32api"; Filename.dirname (get_output1 ~use_bash:true "gcc -print-libgcc-file-name"); ]; default_libs := ["-lkernel32"; "-luser32"; "-ladvapi32"; "-lshell32"; "-lcygwin"; "-lgcc"] | `MSVC | `MSVC64 -> search_path := !dirs @ parse_libpath (try Sys.getenv "LIB" with Not_found -> ""); if not !custom_crt then default_libs := ["msvcrt.lib"] | `MINGW -> mingw_libs Version.mingw_prefix | `MINGW64 -> mingw_libs Version.mingw64_prefix | `LIGHTLD -> search_path := !dirs let compile_if_needed file = if Filename.check_suffix file ".c" then begin let tmp_obj = temp_file "dyndll" (if !toolchain = `MSVC || !toolchain = `MSVC64 then ".obj" else ".o") in let cmd = match !toolchain with | `MSVC | `MSVC64 -> Printf.sprintf "cl /c /MD /nologo /Fo%s %s %s" (Filename.quote tmp_obj) (mk_dirs_opt "/I") file | `CYGWIN -> Printf.sprintf "gcc -c -o %s %s %s" (Filename.quote tmp_obj) (mk_dirs_opt "-I") file | `MINGW | `MINGW64 -> Printf.sprintf "%s -c -o %s %s %s" !gcc (Filename.quote tmp_obj) (mk_dirs_opt "-I") (Filename.quote file) | `LIGHTLD -> failwith "Compilation of C code is not supported for this toolchain" in if !verbose >= 1 || !dry_mode then Printf.printf "+ %s\n%!" cmd; if (Sys.command cmd <> 0) then failwith "Error while compiling"; tmp_obj end else file let dump fn = let fn = find_file fn in Printf.printf "*** %s:\n" fn; match Lib.read fn with | `Lib (objs,imports) -> List.iter (fun (n,o) -> Printf.printf "** %s(%s):\n" fn n; Coff.dump o ) objs; List.iter (fun (s,i) -> Printf.printf "** import: %s (%i)\n" s i) imports | `Obj o -> Coff.dump o let all_files () = let files = List.rev (List.map compile_if_needed !files) in let f = Filename.concat flexdir in let tc = match !toolchain with | `MSVC -> "msvc.obj" | `MSVC64 -> "msvc64.obj" | `CYGWIN -> "cygwin.o" | `MINGW64 -> "mingw64.o" | `MINGW | `LIGHTLD -> "mingw.o" in if !exe_mode <> `DLL then if !add_flexdll_obj then f ("flexdll_" ^ tc) :: files else files else if !noentry then files else f ("flexdll_initer_" ^ tc) :: files let main () = parse_cmdline (); setup_toolchain (); use_cygpath := begin match !toolchain, !cygpath_arg with | _, `Yes -> true | _, `No -> false | (`MINGW|`MINGW64|`CYGWIN), `None -> begin match Sys.os_type with | "Unix" | "Cygwin" -> Sys.command "cygpath -S 2>/dev/null >/dev/null" = 0 | "Win32" -> Sys.command "cygpath -S 2>NUL >NUL" = 0 | _ -> assert false end | (`MSVC|`MSVC64|`LIGHTLD), `None -> false end; if !verbose >= 2 then ( Printf.printf "** Use cygpath: %b\n" !use_cygpath; Printf.printf "** Search path:\n"; List.iter print_endline !search_path; if !use_default_libs then begin Printf.printf "** Default libraries:\n"; List.iter print_endline !default_libs; end ); let files = all_files () in match !mode with | `DUMP -> List.iter dump files | `NORMAL -> build_dll !exe_mode !output_file files !exts (String.concat " " (List.map Filename.quote (List.rev !extra_args))) | `PATCH -> patch_output !output_file let () = try main () with | Failure s -> Printf.eprintf "** Fatal error: %s\n" s; exit 2 | Invalid_argument s -> Printf.eprintf "** Fatal error: invalid argument (%s)\n" s; exit 2 | Arg.Help s -> Printf.printf "%s\n%s\n" s footer; exit 0 | Arg.Bad s -> Printf.eprintf "%s\n%s\n" s footer; exit 2 | exn -> Printf.eprintf "** Error: %s\n" (Printexc.to_string exn); exit 2 mingw-ocaml/flexdll/installer.nsi0000644000175000017500000000054412124403240016527 0ustar tootstoots!include "MUI.nsh" Name "FlexDLL" OutFile "flexdll_setup.exe" InstallDir "$PROGRAMFILES\flexdll" !insertmacro MUI_PAGE_DIRECTORY !insertmacro MUI_PAGE_INSTFILES !define MUI_FINISHPAGE_NOAUTOCLOSE !insertmacro MUI_PAGE_FINISH !insertmacro MUI_LANGUAGE "English" section setOutPath $INSTDIR file "flexdll_install_files\*" sectionEnd mingw-ocaml/flexdll/default.manifest0000644000175000017500000000061512124403240017172 0ustar tootstoots mingw-ocaml/flexdll/create_dll.ml0000644000175000017500000003034012124403240016444 0ustar tootstoots(* Create a DLL from a set of "closed" COFF files (no imported symbol). *) open Coff let (&&&) = Int32.logand let (|||) = Int32.logor let (<<<) = Int32.shift_left let read_int32 s i = Int32.of_int (Char.code s.[i]) ||| (Int32.of_int (Char.code s.[i+1]) <<< 8) ||| (Int32.of_int (Char.code s.[i+2]) <<< 16) ||| (Int32.of_int (Char.code s.[i+3]) <<< 24) let int32_to_buf b i = for k = 0 to 3 do Buffer.add_char b (Char.chr (Int32.to_int (Int32.shift_right i (k * 8)) land 0xff)) done let align x n = let k = Int32.rem x n in if k = 0l then x else Int32.add x (Int32.sub n k) let discard_section s = let opts = s.sec_opts in opts &&& (0x00000200l (* Info section (.drectve) *) ||| 0x00000800l (* Remove *) ||| 0x02000000l) <> 0l (* Discardable *) let sect_data s = match force_section_data s with | `String data -> data | _ -> assert false let split_relocs page_size relocs = let relocs = List.sort compare relocs in let blocks = ref [] and current_block = ref (ref []) and current_base = ref (-1l) in List.iter (fun rva -> let base = Int32.mul (Int32.div rva page_size) page_size in let ofs = Int32.to_int (Int32.sub rva base) in if base = !current_base then (!current_block) := ofs :: !(!current_block) else begin current_base := base; current_block := ref [ofs]; blocks := (base, !current_block) :: !blocks end ) relocs; List.rev_map (fun (base, relocs) -> (base, List.rev !relocs)) !blocks type sec_info = { sec_info_obj: coff; (* original object *) mutable sec_info_sec: section; (* target section in the image *) mutable sec_info_ofs: int32; (* offset within the target image *) sec_info_vaddress: int32 Lazy.t; } let create_dll oc objs = let image_base = 0x10000l in let page_size = 0x1000l in let dllname = "foo.dll" in (* msdos stub *) output_string oc "MZ"; for i = 3 to 0x3c do output_byte oc 0 done; emit_int32 oc 0xe8l; (* file offset of COFF file header, just here *) for i = 0x40 to 0xe7 do output_byte oc 0 done; let sections = Hashtbl.create 8 in let sec_id = ref 0 in let sec_info = Hashtbl.create 8 in let sym_id = ref 0 in let globals = Hashtbl.create 8 in let locals = Hashtbl.create 8 in let commons = Hashtbl.create 8 in let relocs = ref [] in List.iter (fun obj -> List.iter (fun s -> (* todo: cut the section name at 8 chars, remove the part of $ *) if discard_section s then () else let (l, sect) = try Hashtbl.find sections s.sec_name with Not_found -> let r = ref [], Section.create s.sec_name (s.sec_opts &&& (0x00000020l ||| 0x00000040l ||| 0x00000080l ||| 0x10000000l ||| 0x20000000l ||| 0x40000000l ||| 0x80000000l)) in Hashtbl.replace sections s.sec_name r; r in l := s :: !l; s.sec_pos <- !sec_id; incr sec_id; let rec info = { sec_info_obj = obj; sec_info_sec = sect; sec_info_ofs = 0l; sec_info_vaddress = lazy (Int32.add info.sec_info_ofs sect.vaddress) } in Hashtbl.replace sec_info s.sec_pos info ) obj.sections; List.iter (function | {sym_name=name; value=ofs; storage; section = `Section s} as sym when s.sec_pos >= 0 -> let info = Hashtbl.find sec_info s.sec_pos in let rva = lazy (Int32.add ofs (Lazy.force info.sec_info_vaddress)) in if storage = 2 then if Hashtbl.mem globals name then failwith ("Multiply defined symbol: " ^ name) else Hashtbl.replace globals name rva else begin sym.sym_pos <- !sym_id; incr sym_id; Hashtbl.replace locals sym.sym_pos rva end | {sym_name=name; storage=2; section=`Num 0; value=size } -> let oldsize = try Hashtbl.find commons name with Not_found -> 0l in Hashtbl.replace commons name (max size oldsize) | _ -> () ) obj.symbols; ) objs; let rva_of_global s = try Hashtbl.find globals s with Not_found -> failwith ("Cannot find global symbol " ^ s) in let rva_of_local s = try Hashtbl.find locals s with Not_found -> assert false in let sects = ref [] in (* Put image sections at their target rva *) let va = ref 0x1000l in let put_sect s = s.vsize <- Int32.of_int (Section.size s); s.vaddress <- !va; va := align (Int32.add !va s.vsize) 0x1000l; sects := s :: !sects in (* create the uninitialized section data *) let () = let bss = Section.create ".bss" 0xC0000080l in let total = ref 0l in Hashtbl.iter (fun name size -> if not (Hashtbl.mem globals name) then let pos = !total in total := Int32.add !total size; let rva = lazy (Int32.add pos bss.vaddress) in Hashtbl.replace globals name rva ) commons; bss.data <- `Uninit (Int32.to_int !total); if !total <> 0l then put_sect bss in Hashtbl.iter (fun name (l, sect) -> let sect_len = ref 0 in let mk_sect s = let buf = Buf.create () in let info = Hashtbl.find sec_info s.sec_pos in let sec_ofs = !sect_len in info.sec_info_ofs <- Int32.of_int sec_ofs; let sdata = sect_data s in sect_len := !sect_len + String.length sdata; Buf.string buf sdata; let mk_reloc r = (* rva of the target symbol *) let sym = r.symbol in let rva = if Symbol.is_extern sym || Symbol.is_export sym then rva_of_global sym.sym_name else if sym.sym_pos >= 0 then rva_of_local sym.sym_pos else begin Symbol.dump sym; failwith (Printf.sprintf "Cannot resolve symbol %s\n" sym.sym_name) end in (* rva of the relocation *) let rel_rva = lazy (Int32.add r.addr (Lazy.force info.sec_info_vaddress)) in let initial = read_int32 sdata (Int32.to_int r.addr) in let pos = Int32.to_int r.addr in match !Cmdline.machine, r.rtype with | `x86, 0x06 | `x64, 0x01 -> (* absolute address *) relocs := rel_rva :: !relocs; Buf.patch_lazy_int32 buf pos (lazy (Int32.add (Int32.add initial (Lazy.force rva)) image_base)) | `x86, 0x14 | `x64, 0x04 -> (* rel32 *) Buf.patch_lazy_int32 buf pos (lazy (Int32.sub (Int32.add initial (Lazy.force rva)) (Int32.add (Lazy.force rel_rva) 4l))) | _, k -> Printf.ksprintf failwith "Unsupport relocation kind %04x for %s" k r.symbol.sym_name in List.iter mk_reloc s.relocs; buf in let bufs = List.map mk_sect !l in sect.data <- `Buf bufs; put_sect sect ) sections; (* create the export table *) let edata = let edata = Section.create ".edata" 0x40000040l in let b = Buf.create () in edata.data <- `Buf [b]; let vaddress = lazy edata.vaddress in let export_symbols = ["symtbl";"reloctbl"] in let export_symbols = List.sort compare export_symbols in Buf.int32 b 0l; (* flags *) Buf.int32 b 0l; (* timestamp *) Buf.int32 b 0l; (* version *) let dllname_offset = Buf.future_int32 b vaddress in (* name rva *) Buf.int32 b 1l; (* ordinal base *) Buf.int32 b (Int32.of_int (List.length export_symbols)); (* addr table entries *) Buf.int32 b (Int32.of_int (List.length export_symbols)); (* number of name pointers *) let exp_tbl = Buf.future_int32 b vaddress in (* export address table rva *) let name_ptr_tbl = Buf.future_int32 b vaddress in (* name pointer rva *) let ord_ptr_tbl = Buf.future_int32 b vaddress in (* ordinal table pointer rva *) Buf.set_future b dllname_offset; Buf.string b dllname; Buf.int8 b 0; Buf.set_future b exp_tbl; List.iter (fun s -> Buf.lazy_int32 b (rva_of_global (Cmdline.usym s))) export_symbols; Buf.set_future b name_ptr_tbl; let export_symbols_ofs = List.map (fun _ -> Buf.future_int32 b vaddress) export_symbols in Buf.set_future b ord_ptr_tbl; for i = 0 to List.length export_symbols - 1 do Buf.int16 b i done; List.iter2 (fun s f -> Buf.set_future b f; Buf.string b s; Buf.int8 b 0 ) export_symbols export_symbols_ofs; put_sect edata; edata in (* create the reloc table *) let rdata = let rdata = Section.create ".rdata" 0x40000040l in let b = Buf.create () in rdata.data <- `Buf [b]; (* careful with list functions: the list of relocs can be very long *) let relocs = List.rev_map (fun rva -> Lazy.force rva) !relocs in let relocs = split_relocs page_size relocs in List.iter (fun (base, relocs) -> let n = List.length relocs in let size = 8 + 2 * n in let size = if n mod 2 = 1 then size + 2 else size in Buf.int32 b base; Buf.int32 b (Int32.of_int size); List.iter (fun ofs -> Buf.int16 b (ofs lor 0x3000)) (* HIGHLOW reloc *) relocs; if n mod 2 = 1 then Buf.int16 b 0 ) relocs; put_sect rdata; rdata in output_string oc "PE\000\000"; (* coff header *) let machine = !Cmdline.machine in let disp_mach ~x86 ~x64 = match machine with `x86 -> x86 | `x64 -> x64 in let emit_int32_64 x = emit_int32 oc x; if machine = `x64 then emit_int32 oc 0l in emit_int16 oc (disp_mach ~x86:0x14c ~x64:0x8664); emit_int16 oc (List.length !sects); (* number of sections *) emit_int32 oc 0l; (* date *) emit_int32 oc 0l; (* ptr to symbol table *) emit_int32 oc 0l; (* number of symbols *) emit_int16 oc ((disp_mach ~x86:28 ~x64:24) + (disp_mach ~x86:68 ~x64:88) + 8 * 16); (* size of optional headers *) emit_int16 oc (disp_mach ~x86:0x2102 (* flags: exec, 32-bit, dll *) ~x64:0x2022 (* flags: exec, large address aware(?), dll *) ); (* optional header *) (* standard fields *) emit_int16 oc (disp_mach ~x86:0x10b ~x64:0x20b); (* magic: pe32/pe32+ *) emit_int16 oc 8; (* linker version *) emit_int32 oc 0l; (* size of code *) emit_int32 oc 0l; (* size of initialized data *) emit_int32 oc 0l; (* size of uninitialized data *) emit_int32 oc 0l; (* entry point *) emit_int32 oc 0x1000l; (* base of code *) if machine = `x86 then emit_int32 oc 0x1000l; (* base of data *) (* windows-specific fields *) emit_int32_64 image_base; (* image base *) emit_int32 oc 0x1000l; (* section alignment *) emit_int32 oc 0x200l; (* file alignment *) emit_int32 oc 0x04l; (* OS version *) emit_int32 oc 0l; (* image version *) emit_int32 oc 0x04l; (* subsystem version *) emit_int32 oc 0l; (* win32 version *) emit_int32 oc !va; (* size of image *) let size_of_headers = pos_out oc in emit_int32 oc 0l; (* size of headers *) emit_int32 oc 0l; (* checksum *) emit_int16 oc 3; (* subsystem: windows CUI *) emit_int16 oc 0x400; (* characteristics: no EH *) emit_int32_64 0x100000l; (* size of stack reserve *) emit_int32_64 0x1000l; (* size of stack commit *) emit_int32_64 0x100000l; (* size of heap reserve *) emit_int32_64 0x1000l; (* size of heap commit *) emit_int32 oc 0l; (* loader flags *) emit_int32 oc 16l; (* number of directories *) (* directories *) for i = 0 to 15 do match i with | 0 -> emit_int32 oc edata.vaddress; emit_int32 oc edata.vsize | 5 -> emit_int32 oc rdata.vaddress; emit_int32 oc rdata.vsize | _ -> emit_int32 oc 0l; emit_int32 oc 0l; done; let sects = List.map (Section.put (fun _ -> assert false) oc) (List.rev !sects) in let align_file () = let i = pos_out oc mod 0x200 in if i <> 0 then for k = i + 1 to 0x200 do output_char oc '\000' done; in align_file (); patch_int32 oc size_of_headers (Int32.of_int (pos_out oc)); List.iter (fun (data,_) -> align_file (); data ()) sects mingw-ocaml/flexdll/test/0000755000175000017500000000000012124403240014773 5ustar tootstootsmingw-ocaml/flexdll/test/Makefile0000644000175000017500000000130112124403240016426 0ustar tootstoots#CC = cl /MD #O = obj #CHAIN = msvc #CC = gcc #O = o #CHAIN=cygwin #CC = gcc -mno-cygwin #O = o #CHAIN = mingw FLEXLINK = ../flexlink.exe -chain $(CHAIN) -merge-manifest $(EXTRA_OPTS) .PHONY: demo demo: dump.exe plug1.dll plug2.dll ./dump.exe plug1.dll plug2.dll dump.exe: dump.$(O) $(FLEXLINK) -exe -o dump.exe dump.$(O) dump.$(O): dump.c $(CC) -I.. -c dump.c plug1.$(O): plug1.c $(CC) -c plug1.c plug2.$(O): plug2.c $(CC) -c plug2.c plug1.dll: plug1.$(O) $(FLEXLINK) -o plug1.dll plug1.$(O) plug2.dll: plug2.$(O) $(FLEXLINK) -o plug2.dll plug2.$(O) plug12.dll: plug1.$(O) plug2.$(O) $(FLEXLINK) -o plug12.dll plug1.$(O) plug2.$(O) clean: rm -f *.o *.obj *.dll *.exe *~ *.manifest mingw-ocaml/flexdll/test/plug1.c0000644000175000017500000000016412124403240016170 0ustar tootstoots#include "stdio.h" int x = 10; void dump_x() { printf("AAA\nx=%i\n", x); } void torun() { api("plug1.torun();"); } mingw-ocaml/flexdll/test/dump.c0000644000175000017500000000220112124403240016077 0ustar tootstoots/***************************************************************** FlexDLL Alain Frisch Copyright 2007 Institut National de Recherche en Informatique et en Automatique. ******************************************************************/ /* An example (main program) */ #include #include #include "flexdll.h" typedef void torun(); void api(char *msg){ printf("API: %s\n", msg); } int main(int argc, char **argv) { void *sym; void *handle; int i; torun *torun; printf("INIT\n"); fflush(stdout); flexdll_dump_exports(NULL); printf("OK\n"); fflush(stdout); for (i = 1; i < argc; i++) { printf("** Loading %s\n", argv[i]); handle = flexdll_dlopen(argv[i], FLEXDLL_RTLD_GLOBAL); if (NULL == handle) { printf("error: %s\n", flexdll_dlerror()); exit(2); } printf("** handle = %p\n", handle); flexdll_dump_exports(handle); flexdll_dump_relocations(handle); if (NULL == handle) { printf("error: %s\n", flexdll_dlerror()); exit(2); } torun = flexdll_dlsym(handle, "torun"); printf("Now running %p...\n", torun); fflush(stdout); if (torun) torun(); } exit(0); } mingw-ocaml/flexdll/test/plug2.c0000644000175000017500000000030512124403240016166 0ustar tootstootsextern int x; void torun() { api("plug2.torun();"); /* dump_x(); // printf("XXX\n"); printf("x = %d\n", x); x = 100; printf("x = %d\n", x); dump_x(); // printf("XXX\n"); */ } mingw-ocaml/flexdll/flexdll.c0000644000175000017500000002461512124403240015622 0ustar tootstoots/***************************************************************** FlexDLL Alain Frisch Copyright 2007 Institut National de Recherche en Informatique et en Automatique. ******************************************************************/ /* Runtime support library */ #include #include #include #include "flexdll.h" typedef long intnat; typedef unsigned long uintnat; #define RELOC_REL32 0x0001 #define RELOC_ABS 0x0002 #define RELOC_REL32_4 0x0003 #define RELOC_REL32_1 0x0004 #define RELOC_REL32_2 0x0005 #define RELOC_DONE 0x0100 typedef struct { UINT_PTR kind; char *name; UINT_PTR *addr; } reloc_entry; typedef struct { char *first; char *last; UINT_PTR old; } nonwr; typedef struct { nonwr *nonwr; reloc_entry entries[]; } reloctbl; typedef struct { void *addr; char *name; } dynsymbol; typedef struct { UINT_PTR size; dynsymbol entries[]; } symtbl; typedef struct dlunit { void *handle; symtbl *symtbl; int global; int count; struct dlunit *next,*prev; } dlunit; typedef void *resolver(void*, const char*); static int error = 0; static char error_buffer[256]; /* Emulate a low-level dlopen-like interface */ #ifdef __CYGWIN32__ /* Under Cygwin, use the dlopen interface to allow POSIX paths */ #include static void *ll_dlopen(const char *libname, int for_execution) { return dlopen(libname, RTLD_NOW | RTLD_GLOBAL); /* Could use RTLD_LAZY if for_execution == 0, but needs testing */ } static void ll_dlclose(void * handle) { dlclose(handle); } static void * ll_dlsym(void * handle, char * name) { return dlsym(handle, name); } static char * ll_dlerror(void) { return dlerror(); } #else static void *ll_dlopen(const char *libname, int for_execution) { HMODULE m; m = LoadLibraryEx(libname, NULL, for_execution ? 0 : DONT_RESOLVE_DLL_REFERENCES); /* Under Win 95/98/ME, LoadLibraryEx can fail in cases where LoadLibrary would succeed. Just try again with LoadLibrary for good measure. */ if (m == NULL) m = LoadLibrary(libname); return (void *) m; } static void ll_dlclose(void *handle) { FreeLibrary((HMODULE) handle); } static void *ll_dlsym(void *handle, char *name) { return (void *) GetProcAddress((HMODULE) handle, name); } static char *ll_dlerror(void) { DWORD msglen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, NULL, /* message source */ GetLastError(), /* error number */ 0, /* default language */ error_buffer, /* destination */ sizeof(error_buffer), /* size of destination */ NULL); /* no inserts */ if (msglen == 0) return "unknown error"; else return error_buffer; } #endif /** Relocation tables **/ static void dump_reloctbl(reloctbl *tbl) { reloc_entry *ptr; nonwr *wr; if (!tbl) { printf("No relocation table\n"); return; } printf("Dynamic relocation table found at %p\n", tbl); for (wr = tbl->nonwr; wr->last != 0; wr++) printf(" Non-writable relocation in zone %p -> %p\n", wr->first, wr->last); for (ptr = tbl->entries; ptr->kind; ptr++) printf(" %p (kind:%04lx) (now:%p) %s\n", ptr->addr, ptr->kind, *((uintnat*) ptr->addr), ptr->name ); } static void dump_master_reloctbl(reloctbl **ptr) { if (!ptr) return; while (*ptr) dump_reloctbl(*ptr++); } static void allow_write(char *begin, char *end, uintnat new, UINT_PTR *old) { static long int pagesize = 0; int res; SYSTEM_INFO si; if (0 == pagesize) { GetSystemInfo (&si); pagesize = si.dwPageSize; } begin -= (size_t) begin % pagesize; res = VirtualProtect(begin, end - begin, new, (uintnat*) old); if (0 == res) { fprintf(stderr, "natdynlink: VirtualProtect failed (%s), begin = 0x%p, end = 0x%p\n", ll_dlerror(), begin, end); exit(2); } /* printf("%p -> %p\n", *old, new); */ } /* Avoid the use of snprintf */ static void cannot_resolve_msg(char *name) { static char msg[] = "Cannot resolve "; static int l = sizeof(msg) - 1; int n = strlen(name); memcpy(error_buffer,msg,l); memcpy(error_buffer+l,name,min(n,sizeof(error_buffer) - l - 1)); error_buffer[l+n] = 0; } static void relocate(resolver f, void *data, reloctbl *tbl) { reloc_entry *ptr; nonwr *wr; INT_PTR s; if (!tbl) return; for (wr = tbl->nonwr; wr->last != 0; wr++) allow_write(wr->first,wr->last + 4,PAGE_EXECUTE_WRITECOPY,&wr->old); for (ptr = tbl->entries; ptr->kind; ptr++) { if (ptr->kind & RELOC_DONE) continue; s = (UINT_PTR) f(data,ptr->name); if (!s) { error = 2; cannot_resolve_msg(ptr->name); return; } switch (ptr->kind & 0xff) { case RELOC_ABS: *(ptr->addr) += s; break; case RELOC_REL32: s -= (INT_PTR)(ptr -> addr) + 4; if (s != (INT32) s) { printf("flexdll error: cannot relocate, target is too far: %p\n", s); fflush(stdout); exit(1); } *((UINT32*) ptr->addr) = s; break; case RELOC_REL32_4: s -= (INT_PTR)(ptr -> addr) + 8; if (s != (INT32) s) { printf("flexdll error: cannot relocate, target is too far: %p\n", s); fflush(stdout); exit(1); } *((UINT32*) ptr->addr) = s; break; case RELOC_REL32_1: s -= (INT_PTR)(ptr -> addr) + 5; if (s != (INT32) s) { printf("flexdll error: cannot relocate, target is too far: %p\n", s); fflush(stdout); exit(1); } *((UINT32*) ptr->addr) = s; break; case RELOC_REL32_2: s -= (INT_PTR)(ptr -> addr) + 6; if (s != (INT32) s) { printf("flexdll error: cannot relocate, target is too far: %p\n", s); fflush(stdout); exit(1); } *((UINT32*) ptr->addr) = s; break; default: fprintf(stderr, "flexdll: unknown relocation kind"); exit(2); } ptr->kind |= RELOC_DONE; } /* Restore permissions. Should do it also in case of failure... */ for (wr = tbl->nonwr; wr->last != 0; wr++) allow_write(wr->first,wr->last + 4,wr->old,&wr->old); } static void relocate_master(resolver f, void *data, reloctbl **ptr) { while (0 == error && *ptr) relocate(f,data,*ptr++); } /* Symbol tables */ static void dump_symtbl(symtbl *tbl) { int i; if (!tbl) { printf("No symbol table\n"); return; } printf("Dynamic symbol at %p (size = %i)\n", tbl, tbl->size); fflush(stdout); for (i = 0; i < tbl->size; i++) { printf("[%i] ", i); fflush(stdout); printf(" %p: ", tbl->entries[i].addr); fflush(stdout); printf("%s\n", tbl->entries[i].name); fflush(stdout); } } static int compare_dynsymbol(const void *s1, const void *s2) { return strcmp(((dynsymbol*) s1) -> name, ((dynsymbol*) s2) -> name); } static void *find_symbol(symtbl *tbl, const char *name) { static dynsymbol s; dynsymbol *sym; if (!tbl) return NULL; s.name = (char*) name; sym = bsearch(&s,&tbl->entries,tbl->size, sizeof(dynsymbol),&compare_dynsymbol); return (NULL == sym ? NULL : sym -> addr); } /* API */ extern symtbl static_symtable; static dlunit *units = NULL; static dlunit main_unit; static void push_unit(dlunit *unit) { unit->next = units; unit->prev = NULL; if (units) units->prev = unit; units = unit; } static void unlink_unit(dlunit *unit) { if (unit->prev) unit->prev->next=unit->next; else units=unit->next; if (unit->next) unit->next->prev=unit->prev; } static void *find_symbol_global(void *data, const char *name) { void *sym; dlunit *unit; if (!name) return NULL; sym = find_symbol(&static_symtable, name); if (sym) return sym; for (unit = units; unit; unit = unit->next) { if (unit->global) { sym = find_symbol(unit->symtbl, name); if (sym) { if (unit != units) { unlink_unit(unit); push_unit(unit); } return sym; } } } return NULL; } int flexdll_relocate(void *tbl) { if (!tbl) { printf("No master relocation table\n"); return 0; } relocate_master(find_symbol_global, NULL, tbl); if (error) return 0; return 1; } void *flexdll_dlopen(const char *file, int mode) { void *handle; dlunit *unit; char flexdll_relocate_env[256]; int exec = (mode & FLEXDLL_RTLD_NOEXEC ? 0 : 1); error = 0; if (!file) return &main_unit; #ifdef MSVC sprintf(flexdll_relocate_env,"%p",&flexdll_relocate); _putenv_s("FLEXDLL_RELOCATE", flexdll_relocate_env); #endif #ifdef CYGWIN sprintf(flexdll_relocate_env,"%p",&flexdll_relocate); setenv("FLEXDLL_RELOCATE", flexdll_relocate_env, 1); #endif #ifdef MINGW { sprintf(flexdll_relocate_env,"FLEXDLL_RELOCATE=%p",&flexdll_relocate); char* s = malloc(strlen(flexdll_relocate_env) + 1); strcpy(s, flexdll_relocate_env); putenv(s); } #endif handle = ll_dlopen(file, exec); if (!handle) { if (!error) error = 1; return NULL; } unit = units; while ((NULL != unit) && (unit->handle != handle)) unit = unit->next; if (unit) { unit->count++; } else { unit = malloc(sizeof(dlunit)); unit->handle = handle; unit->symtbl = ll_dlsym(handle, "symtbl"); unit->count = 1; unit->global = 0; push_unit(unit); } if (mode & FLEXDLL_RTLD_GLOBAL) unit->global=1; if (exec) { /* Relocation has already been done if the flexdll's DLL entry point is used */ flexdll_relocate(ll_dlsym(handle, "reloctbl")); if (error) { flexdll_dlclose(unit); return NULL; } } return unit; } void flexdll_dlclose(void *u) { dlunit *unit = u; if (NULL == u || u == &main_unit) return; ll_dlclose(unit->handle); unit->count--; if (unit->count == 0) { unlink_unit(unit); free(unit); } } void *flexdll_dlsym(void *u, const char *name) { if (u == &main_unit) return find_symbol_global(NULL,name); else if (NULL == u) return find_symbol(&static_symtable,name); else return find_symbol(((dlunit*)u)->symtbl,name); } char *flexdll_dlerror() { switch (error) { case 0: return NULL; case 1: error = 0; return ll_dlerror(); case 2: error = 0; return error_buffer; } return NULL; } void flexdll_dump_exports(void *u) { dlunit *unit = u; if (NULL == u) { dump_symtbl(&static_symtable); } else if (u == &main_unit) { dump_symtbl(&static_symtable); for (unit = units; unit; unit = unit->next) if (unit->global) { dump_symtbl(unit->symtbl); } } else { dump_symtbl(unit->symtbl); } } void flexdll_dump_relocations(void *u) { if (NULL == u || u == &main_unit) return; dump_master_reloctbl(ll_dlsym(((dlunit*)u) -> handle, "reloctbl")); } mingw-ocaml/flexdll/cmdline.ml0000644000175000017500000002074712124403240015773 0ustar tootstoots(************************************************************************) (* FlexDLL *) (* Alain Frisch *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. *) (************************************************************************) let underscore = ref true (* Are "normal" symbols prefixed with an underscore? *) let machine : [ `x86 | `x64 ] ref = ref `x86 let noexport = ref false let custom_crt = ref false let reexport_from_implibs = ref true let use_default_libs = ref true let subsystem = ref "console" let explain = ref false let builtin_linker = ref false let toolchain : [ `MSVC | `MSVC64 | `MINGW | `MINGW64 | `CYGWIN | `LIGHTLD ] ref = ref `MSVC let save_temps = ref false let show_exports = ref false let show_imports = ref false let dry_mode = ref false let verbose = ref 0 let dirs = ref [] let no_merge_manifest = ref false let merge_manifest = ref false let real_manifest = ref true let add_flexdll_obj = ref true let files = ref [] let exts = ref [] let output_file = ref "" let exe_mode : [`DLL | `EXE | `MAINDLL] ref = ref `DLL let extra_args = ref [] let mode : [`NORMAL | `DUMP | `PATCH] ref = ref `NORMAL let defexports = ref [] let noentry = ref false let use_cygpath = ref true let cygpath_arg : [`Yes | `No | `None] ref = ref `None let implib = ref false let deffile = ref None let stack_reserve = ref None let usage_msg = Printf.sprintf "FlexDLL version %s\n\nUsage:\n flexlink -o file1.obj file2.obj ... -- \n" Version.version let footer = "\ Notes: * The -I, -l and -L options do not need to be separated from their argument. * An option like /linkXXX is an abbrevation for '-link XXX'. * FlexDLL's object files are searched by default in the same directory as flexlink, or in the directory given by the environment variable FLEXDIR if it is defined. * Extra argument can be passed in the environment variable FLEXLINKFLAGS. Homepage: http://alain.frisch.fr/flexdll.html" let specs = [ "-o", Arg.Set_string output_file, " Choose the name of the output file"; "-exe", Arg.Unit (fun () -> exe_mode := `EXE), " Link the main program as an exe file"; "-maindll", Arg.Unit (fun () -> exe_mode := `MAINDLL), " Link the main program as a dll file"; "-noflexdllobj", Arg.Clear add_flexdll_obj, " Do not add the Flexdll runtime object (for exe)"; "-noentry", Arg.Set noentry, " Do not use the Flexdll entry point (for dll)"; "-noexport", Arg.Set noexport, " Do not export any symbol"; "-I", Arg.String (fun dir -> dirs := dir :: !dirs), "

Add a directory where to search for files"; "-L", Arg.String (fun dir -> dirs := dir :: !dirs), " Add a directory where to search for files"; "-l", Arg.String (fun s -> files := ("-l" ^ s) :: !files), " Library file"; "-chain", Arg.Symbol (["msvc";"msvc64";"cygwin";"mingw";"mingw64";"ld"], (fun s -> machine := `x86; underscore := true; toolchain := match s with | "msvc" -> `MSVC | "msvc64" -> machine := `x64; underscore := false; `MSVC64 | "cygwin" -> `CYGWIN | "mingw" -> `MINGW | "mingw64" -> machine := `x64; underscore := false; `MINGW64 | "ld" -> `LIGHTLD | _ -> assert false)), " Choose which linker to use"; "-x64", Arg.Unit (fun () -> machine := `x64; underscore := false; toolchain := `MSVC64), " (Deprecated)"; "-defaultlib", Arg.String (fun s -> exts := s :: !exts), " External object (no export, no import)"; "-save-temps", Arg.Set save_temps, " Do not delete intermediate files"; "-implib", Arg.Set implib, " Do not delete the generated import library"; "-outdef", Arg.String (fun s -> deffile := Some s), " Produce a def file with exported symbols"; "-v", Arg.Unit (fun () -> incr verbose), " Increment verbosity (can be repeated)"; "-show-exports", Arg.Set show_exports, " Show exported symbols"; "-show-imports", Arg.Set show_imports, " Show imported symbols"; "-dry", Arg.Set dry_mode, " Show the linker command line, do not actually run it"; "-dump", Arg.Unit (fun () -> mode := `DUMP), " Only dump the content of object files"; "-patch", Arg.Unit (fun () -> mode := `PATCH), " Only patch the target image (to be used with -stack)"; "-nocygpath", Arg.Unit (fun () -> cygpath_arg := `No), " Do not use cygpath (default for msvc, mingw)"; "-cygpath", Arg.Unit (fun () -> cygpath_arg := `Yes), " Use cygpath (default for cygwin)"; "-no-merge-manifest", Arg.Set no_merge_manifest, " Do not merge the manifest (takes precedence over -merge-manifest)"; "-merge-manifest", Arg.Set merge_manifest, " Merge manifest to the dll or exe (if generated)"; "-real-manifest", Arg.Set real_manifest, " Use the generated manifest (default behavior)"; "-default-manifest", Arg.Clear real_manifest, " Use the default manifest (default.manifest/default_amd64.manifest)"; "-export", Arg.String (fun s -> defexports := s :: !defexports), " Explicitly export a symbol"; "-noreexport", Arg.Clear reexport_from_implibs, " Do not reexport symbols imported from import libraries"; "-where", Arg.Unit (fun () -> print_endline (Filename.dirname Sys.executable_name); exit 0 ), " Show the FlexDLL directory"; "-nounderscore", Arg.Clear underscore, " Normal symbols are not prefixed with an underscore"; "-nodefaultlibs", Arg.Clear use_default_libs, " Do not assume any default library"; "-builtin", Arg.Set builtin_linker, " Use built-in linker to produce a dll"; "-explain", Arg.Set explain, " Explain why library objects are linked"; "-subsystem", Arg.Set_string subsystem, " Set the subsystem (default: console)"; "-custom-crt", Arg.Set custom_crt, " Use a custom CRT"; "-stack", Arg.String (fun s -> try stack_reserve := Some (Int32.of_string s) with _ -> raise (Arg.Bad "integer argument expected for -stack")), " Set the stack reserve in the resulting image"; "-link", Arg.String (fun s -> extra_args := s :: !extra_args), "